HERWIG/herwig6510.f

   1 C  HERWIG---AliRoot/HERWIG
   2 C-----------------------------------------------------------------------
   3 C                           H E R W I G
   4 C
   5 C            a Monte Carlo event generator for simulating
   6 C        +---------------------------------------------------+
   7 C        | Hadron Emission Reactions With Interfering Gluons |
   8 C        +---------------------------------------------------+
   9 C I.G. Knowles(*), G. Marchesini(+), M.H.Seymour($,&) and B.R. Webber(#)
  10 C-----------------------------------------------------------------------
  11 C with Minimal Supersymmetric Standard Model Matrix Elements by
  12 C                  S. Moretti(") and K. Odagiri(^)
  13 C-----------------------------------------------------------------------
  14 C R parity violating Supersymmetric Decays and Matrix Elements by
  15 C                          P. Richardson(X)
  16 C-----------------------------------------------------------------------
  17 C matrix element corrections to top decay and Drell-Yan type processes
  18 C                         by G. Corcella(&)
  19 C-----------------------------------------------------------------------
  20 C Deep Inelastic Scattering and Heavy Flavour Electroproduction by
  21 C                  G. Abbiendi(@) and L. Stanco(%)
  22 C-----------------------------------------------------------------------
  23 C and Jet Photoproduction in Lepton-Hadron Collisions by J. Chyla(~)
  24 C-----------------------------------------------------------------------
  25 C(*)  Department of Physics & Astronomy, University of Edinburgh
  26 C(+)  Dipartimento di Fisica, Universita di Milano-Bicocca
  27 C($)  School of Physics & Astronomy, University of Manchester
  28 C(&)  Theory Physics Group, CERN
  29 C(#)  Cavendish Laboratory, Cambridge
  30 C(")  School of Physics & Astronomy, Southampton
  31 C(^)  Academia Sinica, Taiwan
  32 C(X)  Institute of Particle Physics Phenomenology, University of Durham
  33 C(@)  Dipartimento di Fisica, Universita di Bologna
  34 C(%)  Dipartimento di Fisica, Universita di Padova
  35 C(~)  Institute of Physics, Prague
  36 C-----------------------------------------------------------------------
  37 C                  Version 6.510 - 31st October 2005
  38 C-----------------------------------------------------------------------
  39 C Main references:
  40 C
  41 C    G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti, K.Odagiri,
  42 C    P.Richardson, M.H.Seymour and B.R.Webber, JHEP 0101 (2001) 010
  43 C
  44 C    G.Marchesini,  B.R.Webber,  G.Abbiendi,  I.G.Knowles,  M.H.Seymour,
  45 C    and L.Stanco, Computer Physics Communications 67 (1992) 465.
  46 C-----------------------------------------------------------------------
  47 C Please see the official HERWIG information page:
  48 C    http://hepwww.rl.ac.uk/theory/seymour/herwig/
  49 C-----------------------------------------------------------------------
  50 CDECK  ID>, CIRCEE.
  51 *CMZ :-        -03/07/01  17.07.47  by  Bryan Webber
  52 *-- Author :    Bryan Webber
  53 C-----------------------------------------------------------------------
  54       FUNCTION CIRCEE (X1, X2)
  55 C-----------------------------------------------------------------------
  56 C     DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
  57 C     IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
  58 C-----------------------------------------------------------------------
  59       IMPLICIT NONE
  60       DOUBLE PRECISION CIRCEE, X1, X2
  61       WRITE (6,10)
  62    10 FORMAT(/10X,'CIRCEE CALLED BUT NOT LINKED')
  63       CIRCEE = 0.0D0
  64       STOP
  65       END
  66 CDECK  ID>, CIRCES.
  67 *CMZ :-        -03/07/01  17.07.47  by  Bryan Webber
  68 *-- Author :    Bryan Webber
  69 C-----------------------------------------------------------------------
  70       SUBROUTINE CIRCES (XX1M, XX2M, XROOTS, XACC, XVER, XREV, XCHAT)
  71 C-----------------------------------------------------------------------
  72 C     DUMMY SUBROUTINE: DELETE AND SET CIRCOP NON-ZERO
  73 C     IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
  74 C-----------------------------------------------------------------------
  75       IMPLICIT NONE
  76       DOUBLE PRECISION XX1M, XX2M, XROOTS
  77       INTEGER XACC, XVER, XREV, XCHAT
  78       WRITE (6,10)
  79    10 FORMAT(/10X,'CIRCES CALLED BUT NOT LINKED')
  80       STOP
  81       END
  82 CDECK  ID>, CIRCGG.
  83 *CMZ :-        -03/07/01  17.07.47  by  Bryan Webber
  84 *-- Author :    Bryan Webber
  85 C-----------------------------------------------------------------------
  86       FUNCTION CIRCGG (X1, X2)
  87 C-----------------------------------------------------------------------
  88 C     DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
  89 C     IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
  90 C-----------------------------------------------------------------------
  91       IMPLICIT NONE
  92       DOUBLE PRECISION CIRCGG, X1, X2
  93       WRITE (6,10)
  94    10 FORMAT(/10X,'CIRCGG CALLED BUT NOT LINKED')
  95       CIRCGG = 0.0D0
  96       STOP
  97       END
  98 CDECK  ID>, DECADD.
  99 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
 100 *-- Author :    Luca Stanco
 101 C-----------------------------------------------------------------------
 102       SUBROUTINE DECADD(LOGI)
 103 C-----------------------------------------------------------------------
 104 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
 105 C     IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
 106 C-----------------------------------------------------------------------
 107       IMPLICIT NONE
 108       LOGICAL LOGI
 109       WRITE (6,10)
 110    10 FORMAT(/10X,'DECADD CALLED BUT NOT LINKED')
 111       STOP
 112       END
 113 CDECK  ID>, DEXAY.
 114 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
 115 *-- Author :    Peter Richardson
 116 C-----------------------------------------------------------------------
 117       SUBROUTINE DEXAY(IMODE,POL)
 118 C-----------------------------------------------------------------------
 119 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
 120 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
 121 C-----------------------------------------------------------------------
 122       IMPLICIT NONE
 123       INTEGER IMODE
 124       REAL POL(4)
 125       WRITE (6,10)
 126    10 FORMAT(/10X,'DEXAY CALLED BUT NOT LINKED')
 127       STOP
 128       END
 129 CDECK  ID>, EUDINI.
 130 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
 131 *-- Author :    Luca Stanco
 132 C-----------------------------------------------------------------------
 133       SUBROUTINE EUDINI
 134 C-----------------------------------------------------------------------
 135 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
 136 C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
 137 C-----------------------------------------------------------------------
 138       IMPLICIT NONE
 139       WRITE (6,10)
 140    10 FORMAT(/10X,'EUDINI CALLED BUT NOT LINKED')
 141       STOP
 142       END
 143 CDECK  ID>, FILHEP.
 144 *CMZ :-        -17/10/01  09:42:21  by  Peter Richardson
 145 *-- Author :    Martin W. Gruenewald
 146 C-----------------------------------------------------------------------
 147       SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
 148 C ----------------------------------------------------------------------
 149 C this subroutine fills one entry into the HEPEVT common
 150 C and updates the information for affected mother entries
 151 C used by TAUOLA
 152 C
 153 C written by Martin W. Gruenewald (91/01/28)
 154 C ----------------------------------------------------------------------
 155       INCLUDE 'herwig65.inc'
 156       LOGICAL QEDRAD
 157       COMMON /PHORAD/ QEDRAD(NMXHEP)
 158       INTEGER N,IHEP,IST,ID,JMO1,JMO2,JDA1,JDA2,I,IP
 159       REAL PINV
 160       LOGICAL PHFLAG
 161       REAL*4 P4(4)
 162 C
 163 C check address mode
 164       IF (N.EQ.0) THEN
 165 C append mode
 166         IHEP=NHEP+1
 167       ELSE IF (N.GT.0) THEN
 168 C absolute position
 169         IHEP=N
 170       ELSE
 171 C relative position
 172         IHEP=NHEP+N
 173       END IF
 174 C check on IHEP
 175       IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
 176 C add entry
 177       NHEP=IHEP
 178       ISTHEP(IHEP)=IST
 179       IDHEP(IHEP)=ID
 180       JMOHEP(1,IHEP)=JMO1
 181       IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
 182       JMOHEP(2,IHEP)=JMO2
 183       IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
 184       JDAHEP(1,IHEP)=JDA1
 185       JDAHEP(2,IHEP)=JDA2
 186       DO I=1,4
 187         PHEP(I,IHEP)=P4(I)
 188 C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
 189         VHEP(I,IHEP)=0.0
 190       END DO
 191       PHEP(5,IHEP)=PINV
 192 C FLAG FOR PHOTOS...
 193       QEDRAD(IHEP)=PHFLAG
 194 C update process:
 195       DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
 196         IF(IP.GT.0)THEN
 197 C if there is a daughter at IHEP, mother entry at IP has decayed
 198           IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
 199 C and daughter pointers of mother entry must be updated
 200           IF(JDAHEP(1,IP).EQ.0)THEN
 201             JDAHEP(1,IP)=IHEP
 202             JDAHEP(2,IP)=IHEP
 203           ELSE
 204             JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
 205           END IF
 206         END IF
 207       END DO
 208       END
 209 CDECK  ID>, FRAGMT.
 210 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
 211 *-- Author :    Luca Stanco
 212 C-----------------------------------------------------------------------
 213       SUBROUTINE FRAGMT(I,J,K)
 214 C-----------------------------------------------------------------------
 215 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
 216 C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
 217 C-----------------------------------------------------------------------
 218       IMPLICIT NONE
 219       INTEGER I,J,K
 220       WRITE (6,10)
 221    10 FORMAT(/10X,'FRAGMT CALLED BUT NOT LINKED')
 222       STOP
 223       END
 224 CDECK  ID>, HVCBVI.
 225 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
 226 *-- Author :    Mike Seymour
 227 C-----------------------------------------------------------------------
 228       SUBROUTINE HVCBVI
 229 C-----------------------------------------------------------------------
 230 C     DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
 231 C-----------------------------------------------------------------------
 232       IMPLICIT NONE
 233       WRITE (6,10)
 234    10 FORMAT(/10X,'HVCBVI CALLED BUT NOT LINKED')
 235       STOP
 236       END
 237 CDECK  ID>, HVHBVI.
 238 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
 239 *-- Author :    Mike Seymour
 240 C-----------------------------------------------------------------------
 241       SUBROUTINE HVHBVI
 242 C-----------------------------------------------------------------------
 243 C     DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
 244 C-----------------------------------------------------------------------
 245       IMPLICIT NONE
 246       WRITE (6,10)
 247    10 FORMAT(/10X,'HERBVI CALLED BUT NOT LINKED')
 248       STOP
 249       END
 250 CDECK  ID>, HWBAZF.
 251 *CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
 252 *-- Author :    Ian Knowles
 253 C-----------------------------------------------------------------------
 254       SUBROUTINE HWBAZF(IPAR,JPAR,VEC1,VEC2,VEC3,VEC)
 255 C-----------------------------------------------------------------------
 256 C     Azimuthal correlation functions for Collins' algorithm,
 257 C     see I.G.Knowles, Comp. Phys. Comm. 58 (90) 271 for notation.
 258 C-----------------------------------------------------------------------
 259       INCLUDE 'herwig65.inc'
 260       DOUBLE PRECISION Z1,Z2,DOT12,DOT23,DOT31,TR,FN(7),VEC1(2),VEC2(2),
 261      & VEC3(2),VEC(2)
 262       INTEGER IPAR,JPAR
 263       LOGICAL GLUI,GLUJ
 264       IF (.NOT.AZSPIN) RETURN
 265       Z1=PPAR(4,JPAR)/PPAR(4,IPAR)
 266       Z2=1.-Z1
 267       GLUI=IDPAR(IPAR).EQ.13
 268       GLUJ=IDPAR(JPAR).EQ.13
 269       IF (GLUI) THEN
 270          IF (GLUJ) THEN
 271 C           Branching: g--->gg
 272             FN(2)=Z2/Z1
 273             FN(3)=1./FN(2)
 274             FN(4)=Z1*Z2
 275             FN(1)=FN(2)+FN(3)+FN(4)
 276             FN(5)=FN(2)+2.*Z1
 277             FN(6)=FN(3)+2.*Z2
 278             FN(7)=FN(4)-2.
 279          ELSE
 280 C           Branching: g--->qqbar
 281             FN(1)=(Z1*Z1+Z2*Z2)/2.
 282             FN(2)=0.
 283             FN(3)=0.
 284             FN(4)=-Z1*Z2
 285             FN(5)=-(2.*Z1-1.)/2.
 286             FN(6)=-FN(5)
 287             FN(7)=FN(1)
 288          ENDIF
 289       ELSE
 290          IF (GLUJ) THEN
 291 C           Branching: q--->gq
 292             FN(1)=(1.+Z2*Z2)/(2.*Z1)
 293             FN(2)=Z2/Z1
 294             FN(3)=0.
 295             FN(4)=0.
 296             FN(5)=FN(1)
 297             FN(6)=(1.+Z2)/2.
 298             FN(7)=-FN(6)
 299          ELSE
 300 C           Branching: q--->qg
 301             FN(1)=(1.+Z1*Z1)/(2.*Z2)
 302             FN(2)=0.
 303             FN(3)=Z1/Z2
 304             FN(4)=0.
 305             FN(5)=(1.+Z1)/2.
 306             FN(6)=FN(1)
 307             FN(7)=-FN(5)
 308          ENDIF
 309       ENDIF
 310       DOT12=VEC1(1)*VEC2(1)+VEC1(2)*VEC2(2)
 311       DOT23=VEC2(1)*VEC3(1)+VEC2(2)*VEC3(2)
 312       DOT31=VEC3(1)*VEC1(1)+VEC3(2)*VEC1(2)
 313       TR=1./(FN(1)+FN(2)*DOT23+FN(3)*DOT31+FN(4)*DOT12)
 314       VEC(1)=((FN(2)+FN(5)*DOT23)*VEC1(1)
 315      &       +(FN(3)+FN(6)*DOT31)*VEC2(1)
 316      &       +(FN(4)+FN(7)*DOT12)*VEC3(1))*TR
 317       VEC(2)=((FN(2)+FN(5)*DOT23)*VEC1(2)
 318      &       +(FN(3)+FN(6)*DOT31)*VEC2(2)
 319      &       +(FN(4)+FN(7)*DOT12)*VEC3(2))*TR
 320       END
 321 CDECK  ID>, HWBCON.
 322 *CMZ :-        -11/10/01  12.01.52  by  Peter Richardson
 323 *-- Author :    Bryan Webber
 324 C-----------------------------------------------------------------------
 325       SUBROUTINE HWBCON
 326 C-----------------------------------------------------------------------
 327 C     MAKES COLOUR CONNECTIONS BETWEEN JETS
 328 C     MODIFIED 12/10/97 BY BRW FOR SUSY PROCESSES
 329 C     MODIFIED 11/01/01 BY PR  FOR SPIN CORRELATIONS(PROBLEM WITH ORDER
 330 C                                                    OF DECAYS)
 331 C     NEW VARAIBLE BACK TO ALLOW CODE TO SEARCH DOWN CHAIN
 332 C-----------------------------------------------------------------------
 333       INCLUDE 'herwig65.inc'
 334       INTEGER IHEP,IST,ID,JC,KC,JD,JHEP,LHEP,ID2,NTRY,KHEP
 335       LOGICAL BACK
 336       IF (IERROR.NE.0) RETURN
 337       IF(.NOT.RPARTY) THEN
 338         CALL HWBRCN
 339         RETURN
 340       ENDIF
 341       DO 20 IHEP=1,NHEP
 342       BACK = .FALSE.
 343       IST=ISTHEP(IHEP)
 344 C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
 345       IF (IST.LT.145.OR.IST.GT.152) GOTO 20
 346  51   IF (JMOHEP(2,IHEP).EQ.0.OR.BACK.OR.
 347      &     ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
 348 C---FIND COLOUR-CONNECTED PARTON
 349         IF(BACK) GOTO 52
 350         IF(JMOHEP(2,IHEP).EQ.0) THEN
 351           JC=JMOHEP(1,IHEP)
 352           IF (IST.NE.152) JC=JMOHEP(1,JC)
 353           JC =JMOHEP(2,JC)
 354         ELSE
 355           JC = JMOHEP(2,IHEP)
 356           JHEP = JC
 357         ENDIF
 358         IF (JC.EQ.0) THEN
 359           CALL HWWARN('HWBCON',51)
 360           GOTO 20
 361         ENDIF
 362 C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
 363  52       IF (ISTHEP(JC).EQ.155.OR.BACK) THEN
 364           IF (IDHEP(JMOHEP(1,JC)).EQ.94.OR.BACK) THEN
 365 C---DECAYED BEFORE HADRONIZING
 366             IF(BACK.OR.(JMOHEP(2,IHEP).NE.0.AND.
 367      &                  ISTHEP(JMOHEP(2,IHEP)).EQ.155)) GOTO 53
 368             JHEP=JMOHEP(2,JC)
 369 C--new bit to try and fix the problems for spin correlations
 370 C--move one step further up the tree and hope this helps
 371             IF (JHEP.EQ.0) THEN
 372               NTRY = 0
 373  1            NTRY = NTRY+1
 374               JC   = JMOHEP(1,JC)
 375               JHEP = JMOHEP(2,JC)
 376               IF(JHEP.NE.0.AND.ISTHEP(JHEP).EQ.155)
 377      &             JHEP = JMOHEP(2,JHEP)
 378               IF(JHEP.EQ.0.AND.NTRY.LT.NHEP) GOTO 1
 379               IF(NHEP.EQ.NTRY) GOTO 20
 380             ENDIF
 381  53         ID=IDHW(JHEP)
 382             IF (ISTHEP(JHEP).EQ.155) THEN
 383 C---SPECIAL FOR GLUINO DECAYS
 384               IF (ID.EQ.449) THEN
 385                 ID=IDHW(JC)
 386 C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
 387                 IF (ID.EQ.449.OR.ID.EQ.13.OR.
 388      &             (ID.GE.401.AND.ID.LE.406).OR.
 389      &             (ID.GE.413.AND.ID.LE.418).OR.
 390      &             ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
 391 C---LOOK FOR ANTI(S)QUARK OR GLUON
 392                   DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
 393                     ID=IDHW(KC)
 394                     IF ((ID.GE.  7.AND.ID.LE. 13).OR.
 395      &                  (ID.GE.407.AND.ID.LE.412).OR.
 396      &                  (ID.GE.419.AND.ID.LE.424)) GOTO 5
 397                   ENDDO
 398                 ELSE
 399 C---LOOK FOR (S)QUARK OR GLUON
 400                   DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
 401                     ID=IDHW(KC)
 402                     IF (ID.LE.  6.OR. ID.EQ. 13.OR.
 403      &                 (ID.GE.401.AND.ID.LE.406).OR.
 404      &                 (ID.GE.413.AND.ID.LE.418)) GOTO 5
 405                   ENDDO
 406                 ENDIF
 407 C---COULDNT FIND ONE
 408                 CALL HWWARN('HWBCON',101)
 409                 GOTO 999
 410     5           JC=KC
 411               ELSE
 412 C--PR MOD 30/6/99 should fix HWCFOR 104 errors
 413                 ID2 = IDHW(IHEP)
 414                 IF(IDHW(JDAHEP(1,JHEP)).EQ.449.AND.
 415      &             (ID2.LE.6.OR.(ID2.GE.115.AND.ID2.LE.120).OR.
 416      &             (ID2.GE.401.AND.ID2.LE.406).OR.ID2.EQ.13.OR.
 417      &             (ID2.GE.413.AND.ID2.LE.418).OR.ID2.EQ.449)) THEN
 418                   JC = JDAHEP(1,JHEP)
 419                 ELSE
 420 C--modifcation for top ME correction (modified for additional photon radiation)
 421                   IF(IDHW(JHEP).EQ.6) THEN
 422                     JC = JDAHEP(1,JHEP)+1
 423                   ELSE
 424                     JC = JDAHEP(1,JHEP)+1
 425                     IF(IDHW(JDAHEP(1,JHEP)+2).EQ.13) JC=JC+1
 426                   ENDIF
 427                 ENDIF
 428               ENDIF
 429             ELSEIF (ID.EQ.6.OR.ID.EQ.12.OR.
 430      &      (ID.GE.209.AND.ID.LE.218).OR.
 431      &      (ID.GE.401.AND.ID.LE.424).OR.ID.EQ.449) THEN
 432 C Wait for partner heavy quark to decay
 433 C              RETURN
 434 C---N.B. MAY BE A PROBLEM HERE
 435               GOTO 20
 436             ELSE
 437               JMOHEP(2,IHEP)=JHEP
 438               JDAHEP(2,JHEP)=IHEP
 439               GOTO 20
 440             ENDIF
 441           ELSE
 442             JC=JMOHEP(2,JC)
 443           ENDIF
 444         ENDIF
 445         JC=JDAHEP(1,JC)
 446         JD=JDAHEP(2,JC)
 447 C---SEARCH IN CORRESPONDING JET
 448         IF (JD.LT.JC) JD=JC
 449         LHEP=0
 450         DO 10 JHEP=JC,JD
 451         IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 10
 452         IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
 453         IF (JDAHEP(2,JHEP).NE.0) GOTO 10
 454 C---JOIN IHEP AND JHEP
 455         ID=IDHW(JHEP)
 456         JMOHEP(2,IHEP)=JHEP
 457         JDAHEP(2,JHEP)=IHEP
 458         GOTO 20
 459    10   CONTINUE
 460         IF (LHEP.NE.0) THEN
 461           JMOHEP(2,IHEP)=LHEP
 462         ELSE
 463 C--search down the tree
 464           DO 50 KHEP=JC,JD
 465           IF(ISTHEP(KHEP).EQ.3.AND.ISTHEP(JDAHEP(1,KHEP)).EQ.155) THEN
 466             JHEP = JDAHEP(1,KHEP)
 467             BACK = .TRUE.
 468             GOTO 51
 469           ENDIF
 470  50       CONTINUE
 471 C---DIDN'T FIND PARTNER OF IHEP YET
 472 C          CALL HWWARN('HWBCON',52)
 473 C          GOTO 20
 474         ENDIF
 475       ENDIF
 476   20  CONTINUE
 477 C---BREAK COLOUR CONNECTIONS WITH PHOTONS
 478       IHEP=1
 479   30  IF (IHEP.LE.NHEP) THEN
 480         IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149) THEN
 481 C  BRW FIX 13/03/99
 482           IF (JMOHEP(2,IHEP).NE.0) THEN
 483             IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
 484      &        JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
 485           ENDIF
 486 C  END FIX
 487           IF (JDAHEP(2,IHEP).NE.0) THEN
 488             IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
 489      &        JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
 490           ENDIF
 491           JMOHEP(2,IHEP)=IHEP
 492           JDAHEP(2,IHEP)=IHEP
 493         ENDIF
 494         IHEP=IHEP+1
 495         GOTO 30
 496       ENDIF
 497  999  RETURN
 498       END
 499 CDECK  ID>, HWBDED.
 500 *CMZ :-        -22/04/96  13.54.08  by  Mike Seymour
 501 *-- Author :    Mike Seymour
 502 C-----------------------------------------------------------------------
 503       SUBROUTINE HWBDED(IOPT)
 504 C     FILL MISSING AREA OF DALITZ PLOT WITH 3-JET AND 2-JET+GAMMA EVENTS
 505 C     IF (IOPT.EQ.1) SET UP EVENT RECORD
 506 C     IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
 507 C
 508 C********MODIFIED 13/11/00 BY BRW TO ALLOW MULTIPLE APPLICATION IN
 509 C*******SAME EVENT (FOR WW AND ZZ) N.B. NO CLEANUP CALLS FOR THESE!
 510 C-----------------------------------------------------------------------
 511       INCLUDE 'herwig65.inc'
 512       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,WMAX,WSUM,
 513      & X1MIN,X1MAX,X2MIN,X2MAX,QSCALE,GAMFAC,GLUFAC,R(3,3),CS,SN,M(3),
 514      & E(3),LAMBDA,A,B,C,PTSQ,EM,P1(5),P2(5),PVRT(4),EPS,MASDEP
 515       INTEGER ID,ID3,EMIT,NOEMIT,IEVT,IHEP,JHEP,KHEP,ICMF,IOPT,IEDT(3),
 516      & I,NDEL,LHEP,IP,JP,KP,IDUN
 517       EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
 518       SAVE X,WMAX,P1,P2
 519       SAVE WSUM,     X1MIN,X1MAX,EMIT,ICMF,IEVT
 520       DATA WSUM,WMAX,X1MIN,X1MAX,EMIT,ICMF,IEVT
 521      & /0.994651D0,1.84096D0,0.0D0,0.773459D0,3*0.0D0/
 522       LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
 523       IF (IOPT.EQ.1) THEN
 524 C---FIND AN UNTREATED CMF
 525         IF (IEVT.EQ.NEVHEP+NWGTS) RETURN
 526         IEVT=0
 527         ICMF=0
 528  5      IDUN=ICMF
 529         DO 10 IHEP=IDUN+1,NHEP
 530  10       IF (ICMF.EQ.IDUN .AND. ISTHEP(IHEP).EQ.110 .AND.
 531      &    JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
 532         IF (ICMF.EQ.IDUN) RETURN
 533         EM=PHEP(5,ICMF)
 534         IF (EM.LT.2*HWBVMC(1)) GOTO 5
 535 C---ONLY APPLY THE CORRECTION TO HADRONIC DECAYS
 536         IF (IDHW(JDAHEP(1,ICMF)).GT.12) GOTO 5
 537 C---GENERATE X1,X2 ACCORDING TO 1/((1-X1)*(1-X2))
 538  100    CONTINUE
 539 C---CHOOSE X1
 540         X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(0)
 541 C---CHOOSE X2
 542         X2MIN=MAX(X(1),1-X(1))
 543         X2MAX=(4*X(1)-3+2*DREAL(  DCMPLX(  X(1)**3+135*(X(1)-1)**3,
 544      &    3*HWUSQR(3*(128*X(1)**4-368*X(1)**3+405*X(1)**2-216*X(1)+54))*
 545      &    (X(1)-1)  )**(1./3)  ))/3
 546         IF (X2MAX.GE.ONE.OR.X2MIN.GE.ONE.OR.X2MAX.LE.X2MIN) GOTO 100
 547         X(2)=1-(1-X2MAX)*((1-X2MIN)/(1-X2MAX))**HWRGEN(1)
 548 C---CALCULATE WEIGHT
 549         W=2 * LOG((1-X1MIN)/(1-X1MAX))*LOG((1-X2MIN)/(1-X2MAX)) *
 550      &    (X(1)**2+X(2)**2)
 551 C---GENERATE UNWEIGHTED (X1,X2) PAIRS (EFFICIENCY IS ~50%)
 552         IF (WMAX*HWRGEN(2).GT.W) GOTO 100
 553 C---SYMMETRIZE X1,X2
 554         X(3)=2-X(1)-X(2)
 555         IF (HWRGEN(5).GT.HALF) THEN
 556           X(1)=X(2)
 557           X(2)=2-X(3)-X(1)
 558         ENDIF
 559 C---CHOOSE WHICH PARTON WILL EMIT
 560         EMIT=1
 561         IF (HWRGEN(6).LT.X(1)**2/(X(1)**2+X(2)**2)) EMIT=2
 562         NOEMIT=3-EMIT
 563         IHEP=JDAHEP(  EMIT,ICMF)
 564         JHEP=JDAHEP(NOEMIT,ICMF)
 565 C---PREFACTORS FOR GAMMA AND GLUON CASES
 566         QSCALE=HWUSQR((1-X(1))*(1-X(2))*(1-X(3)))*EM/X(NOEMIT)
 567         ID=IDHW(JDAHEP(1,ICMF))
 568         GAMFAC=ALPFAC*ALPHEM*ICHRG(ID)**2/(18*PIFAC)
 569         GLUFAC=0
 570         IF (QSCALE.GT.HWBVMC(13))
 571      &    GLUFAC=CFFAC/(2*PIFAC)*HWUALF(1,QSCALE)
 572 C---SWITCH OFF PHOTON EMISSION IN W DECAYS (THE M-E DOES NOT FACTORIZE)
 573         IF (ICHRG(IDHW(ICMF)).NE.0) GAMFAC=0
 574 C---IN FRACTION FAC*WSUM OF EVENTS ADD A GAMMA/GLUON
 575         IF     (GAMFAC*WSUM .GT. HWRGEN(3)) THEN
 576           ID3=59
 577         ELSEIF (GLUFAC*WSUM .GT. HWRGEN(4)) THEN
 578           ID3=13
 579         ELSE
 580           EMIT=0
 581           GOTO 5
 582         ENDIF
 583 C---CHECK INFRA-RED CUT-OFF FOR GAMMA/GLUON
 584         M(EMIT)=PHEP(5,IHEP)+VQCUT
 585         M(NOEMIT)=PHEP(5,JHEP)+VQCUT
 586         M(3)=HWBVMC(ID3)
 587         E(1)=HALF*EM*(X(1)+(M(1)**2-M(2)**2-M(3)**2)/EM**2)
 588         E(2)=HALF*EM*(X(2)+(M(2)**2-M(3)**2-M(1)**2)/EM**2)
 589         E(3)=EM-E(1)-E(2)
 590         PTSQ=-LAMBDA(E(NOEMIT)**2-M(NOEMIT)**2,E(3)**2-M(3)**2,
 591      &    E(EMIT)**2-M(EMIT)**2)
 592         IF (PTSQ.LE.ZERO .OR.
 593      $       E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3)) THEN
 594           EMIT=0
 595           GOTO 5
 596         ENDIF
 597 C---CALCULATE MASS-DEPENDENT SUPRESSION
 598         IF (MOD(IPROC,10).GT.0) THEN
 599           EPS=(RMASS(ID)/EM)**2
 600           MASDEP=X(1)**2+X(2)**2
 601      $         -4*EPS*X(3)-2*EPS*((1-X(2))/(1-X(1))+(1-X(1))/(1-X(2)))
 602      $         -4*EPS**2*X(3)**2/((1-X(1))*(1-X(2)))
 603           IF (MASDEP.LT.HWRGEN(7)*(X(1)**2+X(2)**2)) THEN
 604             EMIT=0
 605             GOTO 5
 606           ENDIF
 607         ENDIF
 608 C---STORE OLD MOMENTA
 609         CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P1)
 610         CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P2)
 611 C---GET THE NON-EMITTING PARTON'S CMF DIRECTION
 612         CALL HWULOF(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
 613         CALL HWRAZM(ONE,CS,SN)
 614         CALL HWUROT(PHEP(1,JHEP),CS,SN,R)
 615         M(EMIT)=PHEP(5,IHEP)
 616         M(NOEMIT)=PHEP(5,JHEP)
 617         M(3)=RMASS(ID3)
 618         KHEP=JDAHEP(2,ICMF)
 619         LHEP=KHEP+1
 620         IF (NHEP.GT.KHEP) THEN
 621 C---MOVE UP REST OF EVENT
 622            DO IP=NHEP,LHEP,-1
 623               JP=IP+1
 624               ISTHEP(JP)= ISTHEP(IP)
 625               IDHW(JP)=IDHW(IP)
 626               IDHEP(JP)=IDHEP(IP)
 627               KP=JMOHEP(1,IP)
 628               IF (KP.GT.KHEP) THEN
 629                  KP=KP+1
 630               ELSE
 631                  IF (JDAHEP(1,KP).EQ.IP) JDAHEP(1,KP)=JP
 632                  IF (JDAHEP(2,KP).EQ.IP) JDAHEP(2,KP)=JP
 633               ENDIF
 634               JMOHEP(1,JP)=KP
 635               KP=JMOHEP(2,IP)
 636               IF (KP.GT.KHEP) KP=KP+1
 637               JMOHEP(2,JP)=KP
 638               KP=JDAHEP(1,IP)
 639               IF (KP.GT.KHEP) KP=KP+1
 640               JDAHEP(1,JP)=KP
 641               KP=JDAHEP(2,IP)
 642               IF (KP.GT.KHEP) KP=KP+1
 643               JDAHEP(2,JP)=KP
 644               CALL HWVEQU(5,PHEP(1,IP),PHEP(1,JP))
 645               CALL HWVEQU(4,VHEP(1,IP),VHEP(1,JP))
 646            ENDDO
 647         ENDIF
 648 C---REORDER ENTRIES: IHEP=EMITTER, JHEP=NON-EMITTER, KHEP=EMITTED
 649         NHEP=NHEP+1
 650         IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
 651           IHEP=JDAHEP(1,ICMF)
 652           JHEP=LHEP
 653         ELSE
 654           IHEP=LHEP
 655           JHEP=JDAHEP(1,ICMF)
 656         ENDIF
 657 C---SET UP MOMENTA
 658         PHEP(5,JHEP)=M(NOEMIT)
 659         PHEP(5,IHEP)=M(EMIT)
 660         PHEP(5,KHEP)=M(3)
 661         PHEP(4,JHEP)=HALF*EM*(X(NOEMIT)+
 662      &                  (M(NOEMIT)**2-M(EMIT)**2-M(3)**2)/EM**2)
 663         PHEP(4,IHEP)=HALF*EM*(X(EMIT)+
 664      &                  (M(EMIT)**2-M(NOEMIT)**2-M(3)**2)/EM**2)
 665         PHEP(4,KHEP)=EM-PHEP(4,IHEP)-PHEP(4,JHEP)
 666         PHEP(3,JHEP)=HWUSQR(PHEP(4,JHEP)**2-PHEP(5,JHEP)**2)
 667         PHEP(3,IHEP)=( (PHEP(4,KHEP)**2-PHEP(5,KHEP)**2) -
 668      &    (PHEP(4,IHEP)**2-PHEP(5,IHEP)**2) -
 669      &    (PHEP(3,JHEP)**2) )*HALF/PHEP(3,JHEP)
 670         PHEP(3,KHEP)=-PHEP(3,IHEP)-PHEP(3,JHEP)
 671         PHEP(2,JHEP)=0
 672         PHEP(2,IHEP)=0
 673         PHEP(2,KHEP)=0
 674         PHEP(1,JHEP)=0
 675         PHEP(1,IHEP)=HWUSQR(PHEP(4,IHEP)**2-
 676      &    PHEP(3,IHEP)**2-PHEP(5,IHEP)**2)
 677         PHEP(1,KHEP)=-PHEP(1,IHEP)
 678 C---ORIENT IN CMF, THEN BOOST TO LAB
 679         CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
 680         CALL HWUROB(R,PHEP(1,JHEP),PHEP(1,JHEP))
 681         CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
 682         CALL HWULOB(PHEP(1,ICMF),PHEP(1,IHEP),PHEP(1,IHEP))
 683         CALL HWULOB(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
 684         CALL HWULOB(PHEP(1,ICMF),PHEP(1,KHEP),PHEP(1,KHEP))
 685 C---CALCULATE PRODUCTION VERTICES
 686         CALL HWVZRO(4,VHEP(1,JHEP))
 687         CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PVRT)
 688         CALL HWUDKL(ID,PVRT,VHEP(1,KHEP))
 689         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,IHEP))
 690 C---REORDER ENTRIES: IHEP=QUARK, JHEP=ANTI-QUARK, KHEP=EMITTED
 691         IF (IHEP.EQ.LHEP) THEN
 692           IHEP=JHEP
 693           JHEP=LHEP
 694         ENDIF
 695 C---STATUS, ID AND POINTERS
 696         ISTHEP(JHEP)=114
 697         IDHW(JHEP)=IDHW(KHEP)
 698         IDHEP(JHEP)=IDHEP(KHEP)
 699         IDHW(KHEP)=ID3
 700         IDHEP(KHEP)=IDPDG(ID3)
 701         JDAHEP(2,ICMF)=JHEP
 702         JMOHEP(1,JHEP)=ICMF
 703         JDAHEP(1,JHEP)=0
 704 C---COLOUR CONNECTIONS AND GLUON POLARIZATION
 705         JMOHEP(2,JHEP)=IHEP
 706         JDAHEP(2,IHEP)=JHEP
 707         IF (ID3.EQ.13) THEN
 708           JMOHEP(2,IHEP)=KHEP
 709           JMOHEP(2,KHEP)=JHEP
 710           JDAHEP(2,JHEP)=KHEP
 711           JDAHEP(2,KHEP)=IHEP
 712           GPOLN=((1-X(1))**2+(1-X(2))**2)/(4*(1-X(3)))
 713           GPOLN=1/(1+GPOLN)
 714         ELSE
 715           JMOHEP(2,IHEP)=JHEP
 716           JMOHEP(2,KHEP)=KHEP
 717           JDAHEP(2,JHEP)=IHEP
 718           JDAHEP(2,KHEP)=KHEP
 719         ENDIF
 720         IEVT=NEVHEP+NWGTS
 721         GOTO 5
 722       ELSEIF (IOPT.EQ.2) THEN
 723 C---MAKE THREE-JET EVENTS FROM THE `DEAD-ZONE' LOOK LIKE TWO-JET EVENTS
 724         IF (EMIT.EQ.0.OR.IEVT.NE.NEVHEP+NWGTS) THEN
 725           RETURN
 726         ELSEIF (EMIT.EQ.1) THEN
 727           IHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
 728           JHEP=JDAHEP(1,JDAHEP(1,ICMF))
 729         ELSE
 730           IHEP=JDAHEP(1,JDAHEP(2,ICMF))
 731           JHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
 732           JDAHEP(1,JDAHEP(2,ICMF))=JHEP
 733           IDHW(JHEP)=IDHW(IHEP)
 734           IF (ISTHEP(IHEP+1).EQ.100 .AND. ISTHEP(JHEP+1).EQ.100)
 735      &      CALL HWVEQU(5,PHEP(1,IHEP+1),PHEP(1,JHEP+1))
 736         ENDIF
 737         JMOHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
 738         JDAHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
 739         JMOHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
 740         JDAHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
 741         CALL HWVEQU(5,P1,PHEP(1,JDAHEP(1,ICMF)))
 742         CALL HWVEQU(5,P2,PHEP(1,JDAHEP(2,ICMF)))
 743         CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,JHEP))
 744         CALL HWUMAS(PHEP(1,JHEP))
 745         JDAHEP(2,JHEP)=JDAHEP(2,IHEP)
 746         IEDT(1)=JDAHEP(1,ICMF)+1
 747         IEDT(2)=IHEP
 748         IEDT(3)=IHEP+1
 749         NDEL=3
 750         IF (ISTHEP(IHEP+1).NE.100) NDEL=2
 751         CALL HWUEDT(NDEL,IEDT)
 752         DO 410 I=1,2
 753           IHEP=JDAHEP(1,JDAHEP(I,ICMF))
 754           JMOHEP(1,IHEP)=JDAHEP(I,ICMF)
 755           IF (ISTHEP(IHEP+1).EQ.100) THEN
 756             JMOHEP(1,IHEP+1)=JMOHEP(1,IHEP)
 757             JMOHEP(2,IHEP+1)=JMOHEP(2,JMOHEP(1,IHEP))
 758           ENDIF
 759           DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
 760             JMOHEP(1,JHEP)=IHEP
 761  400      CONTINUE
 762           CALL HWVZRO(4,VHEP(1,JDAHEP(I,ICMF)))
 763           CALL HWVZRO(4,VHEP(1,IHEP))
 764           IF (ISTHEP(IHEP+1).EQ.100) CALL HWVZRO(4,VHEP(1,IHEP+1))
 765  410    CONTINUE
 766         EMIT=0
 767         IEVT=0
 768       ELSE
 769         CALL HWWARN('HWBDED',500)
 770       ENDIF
 771       END
 772 CDECK  ID>, HWBDIS.
 773 *CMZ :-        -17/05/94  09.33.08  by  Mike Seymour
 774 *-- Author :    Mike Seymour
 775 C-----------------------------------------------------------------------
 776       SUBROUTINE HWBDIS(IOPT)
 777 C-----------------------------------------------------------------------
 778 C     FILL MISSING AREA OF DIS PHASE-SPACE WITH 2+1-JET EVENTS
 779 C     IF (IOPT.EQ.1) SET UP EVENT RECORD
 780 C     IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
 781 C-----------------------------------------------------------------------
 782       INCLUDE 'herwig65.inc'
 783       DOUBLE PRECISION HWRGEN,HWBVMC,HWUALF,HWULDO,P1(5),P2(5),P3(5),
 784      & PCMF(5),L(5),R(3,3),Q,XBJ,RN,XPMIN,XPMAX,XP,ZPMIN,ZPMAX,ZP,FAC,
 785      & X1,X2,XTSQ,XT,PTSQ,SIN1,SIN2,W1,W2,CFAC,PDFOLD(13),PDFNEW(13),
 786      & PHI,SCALE,Q1(5),Q2(5),DIR1,DIR2,DIR,PM(5),POLD,PNEW,COMINT,
 787      & BGFINT,COMWGT,C1,C2,CM,B1,B2,BM,PVRT(4)
 788       INTEGER IOPT,EMIT,ICMF,IHEP,JHEP,IIN,IOUT,ILEP,IHAD,ID,IDNEW,
 789      & IEDT(3),NDEL,NTRY,ITEMP
 790       LOGICAL BGF
 791       EXTERNAL HWRGEN,HWBVMC,HWUALF,HWULDO
 792       SAVE BGF,IIN,IOUT,ICMF,ID,Q1,Q2,XP,XBJ
 793       SAVE EMIT,COMINT,BGFINT,COMWGT,C1,C2,CM,B1,B2,BM
 794       DATA EMIT,COMINT,BGFINT,COMWGT/0D0,3.9827D0,1.2462D0,0.3D0/
 795       DATA C1,C2,CM,B1,B2,BM/0.56D0,0.20D0,10D0,0.667D0,0.167D0,3D0/
 796       IF (IERROR.NE.0) RETURN
 797       IF (IOPT.EQ.1) THEN
 798 C---FIND AN UNTREATED CMF
 799         IF (EMIT.EQ.NEVHEP+NWGTS) RETURN
 800         ICMF=0
 801         DO 10 IHEP=1,NHEP
 802  10       IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110 .AND.
 803      &    JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
 804         IF (ICMF.EQ.0) RETURN
 805         IIN=JMOHEP(2,ICMF)
 806         IOUT=JDAHEP(2,ICMF)
 807         ILEP=JMOHEP(1,ICMF)
 808         CALL HWVEQU(5,PHEP(1,IIN),P1)
 809         CALL HWVEQU(5,PHEP(1,IOUT),P2)
 810         CALL HWVEQU(5,PHEP(1,ILEP),L)
 811         IHAD=2
 812         IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
 813         ID=IDHW(IIN)
 814 C---STORE OLD MOMENTA
 815         CALL HWVEQU(5,P1,Q1)
 816         CALL HWVEQU(5,P2,Q2)
 817 C---BOOST AND ROTATE THE MOMENTA TO THE BREIT FRAME
 818         CALL HWVDIF(4,P2,P1,PCMF)
 819         CALL HWUMAS(PCMF)
 820         CALL HWVEQU(5,PHEP(1,IHAD),PM)
 821         Q=-PCMF(5)
 822         XBJ=HALF*Q**2/HWULDO(PM,PCMF)
 823         CALL HWVSCA(4,HALF/XBJ,PCMF,PCMF)
 824         CALL HWVSUM(4,PM,PCMF,PCMF)
 825         CALL HWUMAS(PCMF)
 826         CALL HWULOF(PCMF,L,L)
 827         CALL HWULOF(PCMF,PM,PM)
 828         CALL HWUROT(PM,ONE,ZERO,R)
 829         CALL HWUROF(R,L,L)
 830         PHI=ATAN2(L(2),L(1))
 831         CALL HWUROT(PM,COS(PHI),SIN(PHI),R)
 832 C---CHOOSE THE HADRONIC-PLANE CONFIGURATION, XP,ZP
 833         IF (HWRGEN(0).LT.COMWGT) THEN
 834 C-----CONSIDER GENERATING A QCD COMPTON EVENT
 835           BGF=.FALSE.
 836           P3(5)=RMASS(13)
 837  100      RN=HWRGEN(1)
 838           IF (RN.LT.C1) THEN
 839             ZP=HWRGEN(2)
 840             XPMAX=MIN(ZP,1-ZP)
 841             XP=HWRGEN(3)*XPMAX
 842             FAC=1/C1*2*XPMAX/((1-XP)*(1-ZP))*
 843      $           (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 844             IF (HWRGEN(4).LT.HALF) THEN
 845               ZPMAX=ZP
 846               ZP=XP
 847               XP=ZPMAX
 848             ENDIF
 849           ELSEIF (RN.LT.C1+C2) THEN
 850             XPMAX=0.83
 851             XP=XPMAX*HWRGEN(2)
 852             ZPMIN=MAX(XP,1-XP)
 853             ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
 854      $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
 855      $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
 856             ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
 857             FAC=1/C2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))/(1-XP)*
 858      $           (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 859           ELSE
 860             ZPMAX=0.85
 861             ZP=ZPMAX*HWRGEN(2)
 862             XPMIN=MAX(ZP,1-ZP)
 863             XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
 864             XP=1-((1-XPMIN)/(1-XPMAX))**HWRGEN(4)*(1-XPMAX)
 865             FAC=1/(1-C1-C2)*ZPMAX*LOG((1-XPMIN)/(1-XPMAX))/(1-ZP)*
 866      $           (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 867           ENDIF
 868           XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
 869           ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
 870      $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
 871      $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
 872           IF (XP.GT.XPMAX.OR.ZP.GT.ZPMAX.OR.CM*HWRGEN(4).GT.FAC)
 873      $         GOTO 100
 874         ELSE
 875 C-----CONSIDER GENERATING A BGF EVENT
 876           BGF=.TRUE.
 877           P3(5)=P1(5)
 878           P1(5)=RMASS(13)
 879  110      RN=HWRGEN(1)
 880           IF (RN.LT.B1) THEN
 881             ZP=HWRGEN(2)
 882             XPMAX=MIN(ZP,1-ZP)
 883             XP=HWRGEN(3)*XPMAX
 884             FAC=1/B1*2*XPMAX/(1-ZP)*
 885      $           ((  XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
 886      $           +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 887             IF (HWRGEN(4).LT.HALF) XP=1-XP
 888           ELSEIF (RN.LT.B1+B2) THEN
 889             XPMAX=0.83
 890             XP=XPMAX*HWRGEN(2)
 891             ZPMIN=MAX(XP,1-XP)
 892             ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
 893      $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
 894      $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
 895             ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
 896             FAC=1/B2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))*
 897      $           ((  XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
 898      $           +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 899           ELSE
 900             XPMAX=0.83
 901             XP=XPMAX*HWRGEN(2)
 902             ZPMAX=MIN(XP,1-XP)
 903             ZPMIN=2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
 904      $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
 905      $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
 906             ZP=(ZPMAX-ZPMIN)*HWRGEN(4)+ZPMIN
 907             FAC=1/(1-B1-B2)*XPMAX*(ZPMAX-ZPMIN)/(1-ZP)*
 908      $           ((  XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
 909      $           +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 910           ENDIF
 911           ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
 912      $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
 913      $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
 914           IF (ZP.GT.ZPMAX.OR.ZP.LT.ONE-ZPMAX.OR.BM*HWRGEN(4).GT.FAC)
 915      $         GOTO 110
 916         ENDIF
 917 C---CALCULATE THE ADDITIONAL FACTORS IN THE WEIGHT
 918         IF (BGF) THEN
 919           IDNEW=13
 920           CFAC=1./2
 921           FAC=BGFINT/(1-COMWGT)
 922         ELSE
 923           IDNEW=ID
 924           CFAC=4./3
 925           FAC=COMINT/COMWGT
 926         ENDIF
 927         SCALE=Q*SQRT((1-XP)*(1-ZP)*ZP/XP+1)
 928         ITEMP=ISTAT
 929         ISTAT=7
 930         CALL HWSFUN(XBJ,Q,IDHW(IHAD),NSTRU,PDFOLD,2)
 931         ISTAT=ITEMP
 932         IF (PDFOLD(ID).LE.ZERO) THEN
 933           CALL HWWARN('HWBDIS',100)
 934           GOTO 999
 935         ENDIF
 936         IF (XP.GT.XBJ) THEN
 937           CALL HWSFUN(XBJ/XP,SCALE,IDHW(IHAD),NSTRU,PDFNEW,2)
 938           FAC=CFAC/(2*PIFAC) * HWUALF(1,SCALE) * FAC *
 939      $         PDFNEW(IDNEW)/PDFOLD(ID)
 940         ELSE
 941           FAC=0
 942         ENDIF
 943 C---FOR PHOTON BEAMS, INCLUDE DIRECT PHOTON COUPLING
 944         IF (IDHW(IHAD).EQ.59) THEN
 945           ZPMIN=2./3.*XBJ*(1+DREAL( DCMPLX(10-45*XBJ+18*XBJ**2,3*SQRT(
 946      $         3*(9+66*XBJ-93*XBJ**2+12*XBJ**3-8*XBJ**4+24*XBJ**5
 947      $         -8*XBJ**6)))**(1./3.)*DCMPLX(0.5D0,0.86602540378444D0) ))
 948           ZPMAX=1-ZPMIN
 949           DIR1=(XBJ**2+(1-XBJ)**2)*(LOG(ZPMAX/ZPMIN)-(ZPMAX-ZPMIN))
 950           DIR2=4*XBJ*(1-XBJ)*(ZPMAX-ZPMIN)
 951           DIR=QFCH(MOD(ID-1,6)+1)**2*ALPHEM/(2*PIFAC*PDFOLD(ID))*XBJ
 952      $         *(DIR1+DIR2)
 953         ELSE
 954           DIR=0
 955         ENDIF
 956 C---DECIDE WHETHER TO MAKE AN EVENT HERE
 957         IF (HWRGEN(4).GT.FAC+DIR) RETURN
 958 C---FOR DIRECT COUPLING, CHOOSE ZP VALUE
 959         IF ((FAC+DIR)*HWRGEN(8).GT.FAC) THEN
 960           IF ((DIR1+DIR2)*HWRGEN(9).LT.DIR1) THEN
 961             NTRY=0
 962  120        NTRY=NTRY+2
 963             ZP=1-(ZPMAX/ZPMIN)**HWRGEN(NTRY+1)*ZPMIN
 964             IF ((ZPMIN**2+(1-ZPMIN)**2)*HWRGEN(NTRY).GT.ZP**2+(1-ZP)**2)
 965      $           GOTO 120
 966           ELSE
 967             ZP=SQRT((ZPMAX-ZPMIN)*HWRGEN(10)+ZPMIN**2)
 968           ENDIF
 969           XP=XBJ
 970           BGF=.TRUE.
 971           P3(5)=P2(5)
 972           P1(5)=0
 973         ENDIF
 974         X1=1-   ZP /XP
 975         X2=1-(1-ZP)/XP
 976         XTSQ=4*(1-XP)*(1-ZP)*ZP/XP
 977         XT=SQRT(XTSQ)
 978         SIN1=XT/SQRT(X1**2+XTSQ)
 979         SIN2=XT/SQRT(X2**2+XTSQ)
 980 C---CHOOSE THE AZIMUTH BETWEEN THE TWO PLANES
 981         IF (BGF) THEN
 982           W1=XP**2*(X1**2+1.5*XTSQ)
 983         ELSE
 984           W1=1
 985         ENDIF
 986         W2=XP**2*(X2**2+1.5*XTSQ)
 987         IF (HWRGEN(5)*(W1+W2).GT.W2) THEN
 988           IF (BGF) THEN
 989 C-----WEIGHTED BY (1+SIN1*COS(PHI))**2
 990  200        PHI=(2*HWRGEN(6)-1)*PIFAC
 991             IF (HWRGEN(7)*(1+SIN1)**2.GT.(1+SIN1*COS(PHI))**2) GOTO 200
 992           ELSE
 993 C-----UNIFORMLY
 994             PHI=(2*HWRGEN(6)-1)*PIFAC
 995           ENDIF
 996         ELSE
 997 C-----WEIGHTED BY (1-SIN2*COS(PHI))**2
 998  210      PHI=(2*HWRGEN(6)-1)*PIFAC
 999           IF (HWRGEN(7)*(1+SIN2)**2.GT.(1-SIN2*COS(PHI))**2) GOTO 210
1000         ENDIF
1001 C---RECONSTRUCT MOMENTA AND BOOST BACK TO LAB
1002         P1(1)=0
1003         P1(2)=0
1004         P1(3)=HALF*Q/XP
1005         P1(4)=SQRT(P1(3)**2+P1(5)**2)
1006         PTSQ=((ZP*Q*(P1(4)+P1(3)-Q)-P2(5)**2)*(P1(4)-P1(3)+(1-ZP)*Q)
1007      $       -P3(5)**2*ZP*Q)/(P1(4)-P1(3)+Q)
1008 C---CHECK INFRARED CUTOFF FOR THIS PARTON TYPE
1009         IF (PTSQ.LT.MAX(HWBVMC(ID),HWBVMC(IDHW(IOUT)))**2) RETURN
1010         P2(1)=SQRT(PTSQ)*COS(PHI)
1011         P2(2)=SQRT(PTSQ)*SIN(PHI)
1012         P2(3)=-0.5*(ZP*Q-(PTSQ+P2(5)**2)/(ZP*Q))
1013         P2(4)= 0.5*(ZP*Q+(PTSQ+P2(5)**2)/(ZP*Q))
1014         P3(1)=P1(1)-P2(1)
1015         P3(2)=P1(2)-P2(2)
1016         P3(3)=P1(3)-P2(3)-Q
1017         P3(4)=P1(4)-P2(4)
1018         CALL HWUROB(R,P1,P1)
1019         CALL HWUROB(R,P2,P2)
1020         CALL HWUROB(R,P3,P3)
1021         CALL HWULOB(PCMF,P1,P1)
1022         CALL HWULOB(PCMF,P2,P2)
1023         CALL HWULOB(PCMF,P3,P3)
1024 C---SPECIAL CASE FOR DIRECT PHOTON - COPY THE EXACT BEAM MOMENTUM
1025 C---SHARE THE MISMATCH EQUALLY BETWEEN THE OUTGOING PARTONS
1026 C---AND PUT THEM BACK ON SHELL
1027         IF (XP.EQ.XBJ) THEN
1028           CALL HWVDIF(4,PHEP(1,IHAD),P1,PM)
1029           CALL HWVSCA(4,HALF,PM,PM)
1030           CALL HWVSUM(4,PM,P2,P2)
1031           CALL HWVSUM(4,PM,P3,P3)
1032           CALL HWUMAS(P2)
1033           CALL HWUMAS(P3)
1034           CALL HWVEQU(5,PHEP(1,IHAD),P1)
1035           CALL HWVSUM(4,P2,P3,PCMF)
1036           CALL HWUMAS(PCMF)
1037           POLD=HWULDO(P2,PCMF)**2/PCMF(5)**2-SIGN(P2(5)**2,P2(5))
1038           PNEW=PCMF(5)**2/4-RMASS(ID)**2
1039           IF (PCMF(5).LE.ZERO.OR.POLD.LE.ZERO.OR.PNEW.LE.ZERO) RETURN
1040           CALL HWVSCA(4,SQRT(PNEW/POLD),P2,P2)
1041           CALL HWVSCA(4,HALF-HWULDO(P2,PCMF)/PCMF(5)**2,PCMF,PM)
1042           CALL HWVSUM(4,PM,P2,P2)
1043           CALL HWUMAS(P2)
1044           CALL HWVDIF(4,PCMF,P2,P3)
1045           CALL HWUMAS(P3)
1046         ENDIF
1047         NHEP=NHEP+1
1048         CALL HWVEQU(5,P1,PHEP(1,IIN))
1049         IF (BGF.AND.ID.GT.6.OR..NOT.BGF.AND.ID.LT.7) THEN
1050           CALL HWVEQU(5,P2,PHEP(1,IOUT))
1051           CALL HWVEQU(5,P3,PHEP(1,NHEP))
1052         ELSE
1053           CALL HWVEQU(5,P3,PHEP(1,IOUT))
1054           CALL HWVEQU(5,P2,PHEP(1,NHEP))
1055         ENDIF
1056         CALL HWVSUM(4,PHEP(1,ILEP),PHEP(1,IIN),PHEP(1,ICMF))
1057         CALL HWUMAS(PHEP(1,ICMF))
1058 C Decide which quark radiated and assign production vertices
1059         IF (BGF) THEN
1060 C Boson-Gluon fusion case
1061           IF (1-ZP.LT.HWRGEN(0)) THEN
1062 C Gluon splitting to quark
1063             CALL HWVZRO(4,VHEP(1,NHEP-1))
1064             CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
1065             CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1066             CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
1067           ELSE
1068 C Gluon splitting to antiquark
1069             CALL HWVZRO(4,VHEP(1,NHEP))
1070             CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
1071             CALL HWUDKL(ID,PVRT,VHEP(1,NHEP-1))
1072             CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
1073           ENDIF
1074         ELSE
1075 C QCD Compton case
1076           IF (1.LT.HWRGEN(0)*(1+(1-XP-ZP)**2+6*XP*(1-XP)*ZP*(1-ZP)))THEN
1077 C Incoming quark radiated the gluon
1078             CALL HWVZRO(4,VHEP(1,NHEP-1))
1079             CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
1080             CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1081             CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
1082           ELSE
1083 C Outgoing quark radiated the gluon
1084             CALL HWVZRO(4,VHEP(1,NHEP-4))
1085             CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
1086             CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1087             CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
1088           ENDIF
1089         ENDIF
1090 C---STATUS, ID AND POINTERS
1091         ISTHEP(NHEP)=114
1092         IF (BGF) THEN
1093           IF (XP.EQ.XBJ) THEN
1094             IDHW(IIN)=59
1095             IDHEP(IIN)=IDPDG(59)
1096           ELSE
1097             IDHW(IIN)=13
1098             IDHEP(IIN)=IDPDG(13)
1099           ENDIF
1100           IF (ID.LT.7) THEN
1101             IDHW(NHEP)=IDHW(IOUT)
1102             IDHEP(NHEP)=IDHEP(IOUT)
1103             IDHW(IOUT)=MOD(ID,6)+6
1104             IDHEP(IOUT)=IDPDG(IDHW(IOUT))
1105           ELSE
1106             IDHW(NHEP)=MOD(ID,6)
1107             IDHEP(NHEP)=IDPDG(IDHW(NHEP))
1108           ENDIF
1109         ELSEIF (ID.LT.7) THEN
1110           IDHW(NHEP)=13
1111           IDHEP(NHEP)=IDPDG(13)
1112         ELSE
1113           IDHW(NHEP)=IDHW(IOUT)
1114           IDHEP(NHEP)=IDHEP(IOUT)
1115           IDHW(IOUT)=13
1116           IDHEP(IOUT)=IDPDG(13)
1117         ENDIF
1118         JDAHEP(2,ICMF)=NHEP
1119         JMOHEP(1,NHEP)=ICMF
1120 C---COLOUR CONNECTIONS
1121         IF (XP.EQ.XBJ) THEN
1122           JMOHEP(2,IIN)=IIN
1123           JDAHEP(2,IIN)=IIN
1124           JMOHEP(2,IOUT)=NHEP
1125           JDAHEP(2,IOUT)=NHEP
1126           JMOHEP(2,NHEP)=IOUT
1127           JDAHEP(2,NHEP)=IOUT
1128         ELSE
1129           JDAHEP(2,IIN)=NHEP
1130           JDAHEP(2,NHEP)=IOUT
1131           JMOHEP(2,IOUT)=NHEP
1132           JMOHEP(2,NHEP)=IIN
1133         ENDIF
1134 C---FACTORISATION SCALE
1135         EMSCA=SCALE
1136         EMIT=NEVHEP+NWGTS
1137       ELSEIF (IOPT.EQ.2) THEN
1138 C---MAKE TWO-JET EVENTS LOOK LIKE ONE-JET EVENTS
1139         IF (EMIT.NE.NEVHEP+NWGTS .OR. XP.EQ.XBJ) RETURN
1140         IF (.NOT.BGF) THEN
1141           CALL HWVEQU(5,Q1,PHEP(1,IIN))
1142           CALL HWVEQU(5,Q2,PHEP(1,IOUT))
1143           JMOHEP(2,IIN)=IOUT
1144           JDAHEP(2,IIN)=IOUT
1145           JMOHEP(2,IOUT)=IIN
1146           JDAHEP(2,IOUT)=IIN
1147           JDAHEP(2,ICMF)=IOUT
1148           IHEP=JDAHEP(1,IOUT)
1149           JHEP=JDAHEP(1,IOUT+1)
1150           CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1151           CALL HWUMAS(PHEP(1,IHEP))
1152           JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
1153           IEDT(1)=IOUT+1
1154           IEDT(2)=JHEP
1155           IEDT(3)=JHEP+1
1156           NDEL=3
1157           IF (ISTHEP(JHEP+1).NE.100) NDEL=2
1158           IHEP=JDAHEP(1,IOUT)
1159           JMOHEP(1,IHEP)=IOUT
1160           IF (ISTHEP(IHEP+1).EQ.100) THEN
1161             JMOHEP(1,IHEP+1)=IOUT
1162             JMOHEP(2,IHEP+1)=IIN
1163           ENDIF
1164           DO 300 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1165             JMOHEP(1,JHEP)=IHEP
1166  300      CONTINUE
1167           IF (IDHW(IOUT).EQ.13) IDHW(IOUT)=IDHW(IOUT+1)
1168           IDHEP(IOUT)=IDPDG(IDHW(IOUT))
1169           IDHW(IHEP)=IDHW(IOUT)
1170           CALL HWUEDT(NDEL,IEDT)
1171         ELSEIF (ID.LT.7) THEN
1172           CALL HWVEQU(5,Q1,PHEP(1,IIN))
1173           CALL HWVEQU(5,Q2,PHEP(1,IOUT+1))
1174           JMOHEP(2,IIN)=IOUT+1
1175           JDAHEP(2,IIN)=IOUT+1
1176           JMOHEP(2,IOUT+1)=IIN
1177           JDAHEP(2,IOUT+1)=IIN
1178           JDAHEP(2,ICMF)=IOUT+1
1179           IHEP=JDAHEP(1,IIN)
1180           JHEP=JDAHEP(1,IOUT)
1181           CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1182           CALL HWUMAS(PHEP(1,IHEP))
1183           CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
1184           CALL HWUMAS(PHEP(1,ICMF))
1185           CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
1186      $         JDAHEP(1,JHEP),JDAHEP(2,IHEP))
1187           JHEP=JDAHEP(1,IOUT)
1188           JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
1189           IEDT(1)=IOUT
1190           IEDT(2)=JHEP
1191           IEDT(3)=JHEP+1
1192           NDEL=3
1193           IF (ISTHEP(JHEP+1).NE.100) NDEL=2
1194           CALL HWUEDT(NDEL,IEDT)
1195           IHEP=JDAHEP(1,IIN)
1196           DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1197             JMOHEP(1,JHEP)=IHEP
1198  400      CONTINUE
1199           IDHW(IIN)=ID
1200           IDHEP(IIN)=IDPDG(ID)
1201           IDHW(IHEP)=ID
1202         ELSE
1203           CALL HWVEQU(5,Q1,PHEP(1,IIN))
1204           CALL HWVEQU(5,Q2,PHEP(1,IOUT))
1205           JMOHEP(2,IIN)=IOUT
1206           JDAHEP(2,IIN)=IOUT
1207           JMOHEP(2,IOUT)=IIN
1208           JDAHEP(2,IOUT)=IIN
1209           JDAHEP(2,ICMF)=IOUT
1210           IHEP=JDAHEP(1,IIN)
1211           JHEP=JDAHEP(1,IOUT+1)
1212           CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1213           CALL HWUMAS(PHEP(1,IHEP))
1214           CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
1215           CALL HWUMAS(PHEP(1,ICMF))
1216           CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
1217      $         JDAHEP(1,JHEP),JDAHEP(1,IHEP)-1)
1218           JHEP=JDAHEP(1,IOUT+1)
1219           JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
1220           IEDT(1)=IOUT+1
1221           IEDT(2)=JHEP
1222           IEDT(3)=JHEP+1
1223           NDEL=3
1224           IF (ISTHEP(JHEP+1).NE.100.OR.JHEP.EQ.NHEP) NDEL=2
1225           CALL HWUEDT(NDEL,IEDT)
1226           IHEP=JDAHEP(1,IIN)
1227           DO 500 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1228             JMOHEP(1,JHEP)=IHEP
1229  500      CONTINUE
1230           IDHW(IIN)=ID
1231           IDHEP(IIN)=IDPDG(ID)
1232           IDHW(IHEP)=ID
1233         ENDIF
1234         CALL HWVZRO(4,VHEP(1,IIN))
1235         CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)))
1236         IF (ISTHEP(JDAHEP(1,IIN)+1).EQ.100)
1237      $       CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)+1))
1238         CALL HWVZRO(4,VHEP(1,IOUT))
1239         CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)))
1240         IF (ISTHEP(JDAHEP(1,IOUT)+1).EQ.100)
1241      $       CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)+1))
1242         EMIT=0
1243       ELSE
1244         CALL HWWARN('HWBDIS',500)
1245       ENDIF
1246  999  RETURN
1247       END
1248 CDECK  ID>, HWBDYP.
1249 *CMZ :-        -26/10/99  17.46.56  by  Mike Seymour
1250 *-- Author :    Gennaro Corcella
1251 C-----------------------------------------------------------------------
1252       SUBROUTINE HWBDYP(IOPT)
1253 C     MATRIX ELEMENT CORRECTIONS TO DRELL-YAN PROCESSES
1254 C-----------------------------------------------------------------------
1255       INCLUDE 'herwig65.inc'
1256       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,PMODK,AZ,CZ,
1257      & T,U,S,EM,TMIN,TMAX,PMOD2,GLUFAC,SMIN,SMAX,SZ,TEST,
1258      & JAC,M(3),W1,W,PMOD3,SCAPR,CPHI,SPHI,SCALE,XI1,XI2,
1259      & PDFOLD1(13),PDFOLD2(13),PDFNEW1(13),PDFNEW2(13),ETA1,ETA2,Y,
1260      & COMWGT1,COMWGT2,WW,COS3,MODP,RN,BETA1,SIN3,R3(3,3),CTH,STH,M1,
1261      & M2,M3,GAMMA1,R5(3,3),CW,SW,R4(3,3),SCALE1,X1,X2,X3,MM,
1262      & PHAD1(5),PHAD2(5),P1(5),P2(5),P3(5),P4(5),PF(5),PV(5),PK(5),
1263      & PR(5),PNE(5),PE(5),PP1(5),PP2(5),PZ(5),PS(5),PD(5),P2N(5),
1264      & PBOS(5),PLAB(5),PTOT(5),P3N(5),SVNTN
1265       LOGICAL GLUIN,GP
1266       INTEGER EMIT,NOEMIT,IHEP,JHEP,KHEP,ICMF,IOPT,CHEP,
1267      & ID2,ID1,K,ID4,ID5,IDBOS,IHAD1,IHAD2,NTMP
1268       EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
1269       SAVE PS,PF,ICMF,ID4,ID5
1270       SAVE EMIT,NTMP
1271       DATA EMIT,NTMP/2*0/
1272       IF (IOPT.EQ.1) THEN
1273         EMIT=0
1274         NTMP=0
1275 C-----CHOOSE WEIGHTS
1276         COMWGT1=0.1
1277         COMWGT2=0.55
1278 C---FIND AN UNTREATED CMF
1279         ICMF=0
1280         DO 10 IHEP=1,NHEP
1281  10     IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110.AND.
1282      &         JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
1283         IF (ICMF.EQ.0) RETURN
1284         EM=PHEP(5,ICMF)
1285 C-----SET THE VECTOR BOSON RAPIDITY
1286         Y=HALF*LOG((PHEP(4,ICMF)+PHEP(3,ICMF))/
1287      &       (PHEP(4,ICMF)-PHEP(3,ICMF)))
1288 C------SET PARTICLE IDENTIES
1289 c------ID1=QUARK, ID2=ANTIQUARK, IDBOS=VECTOR BOSON, ID4-5 BOSON DECAY
1290         IDBOS=IDHW(ICMF)
1291         ID1=IDHW(JMOHEP(1,ICMF))
1292         ID2=IDHW(JMOHEP(2,ICMF))
1293         ID4=IDHW(JDAHEP(1,ICMF))
1294         ID5=IDHW(JDAHEP(2,ICMF))
1295         M1=RMASS(ID1)
1296         M2=RMASS(ID2)
1297         M3=RMASS(13)
1298 C---STORE OLD MOMENTA
1299 C------VECTOR BOSON MOMENTUM
1300         CALL HWVEQU(5,PHEP(1,ICMF),PBOS)
1301 C----QUARK MOMENTUM
1302         CALL HWVEQU(5,PHEP(1,JMOHEP(1,ICMF)),P1)
1303 C------ANTIQUARK MOMENTUM
1304         CALL HWVEQU(5,PHEP(1,JMOHEP(2,ICMF)),P2)
1305 C-------VECTOR DECAY (LEPTON) PRODUCT MOMENTA
1306         CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P3)
1307         CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P4)
1308 C------LEPTON MOMENTA IN THE BOSON REST FRAME
1309         CALL HWULOF(PHEP(1,ICMF),P2,P2N)
1310         CALL HWULOF(PHEP(1,ICMF),P3,P3N)
1311 C------AZ=AZIMUTHAL ANGLE OF P3N
1312         AZ=ATAN2(P3N(2),P3N(1))
1313         CZ=COS(AZ)
1314         SZ=SIN(AZ)
1315 C------PHI=ANGLE BETWEEN P2N AND P3N
1316         SCAPR=P2N(1)*P3N(1)+P2N(2)*P3N(2)+P2N(3)*P3N(3)
1317         PMOD2=SQRT(P2N(1)**2+P2N(2)**2+P2N(3)**2)
1318         PMOD3=SQRT(P3N(1)**2+P3N(2)**2+P3N(3)**2)
1319         CPHI=SCAPR/(PMOD3*PMOD2)
1320         SPHI=SQRT(1-CPHI**2)
1321 C------HADRON MOMENTA
1322         IHAD1=1
1323         IHAD2=2
1324         IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
1325         IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
1326         CALL HWVEQU(5,PHEP(1,IHAD1),PHAD1)
1327         CALL HWVEQU(5,PHEP(1,IHAD2),PHAD2)
1328         CALL HWVSUM(4,PHAD1,PHAD2,PTOT)
1329         CALL HWUMAS(PTOT)
1330 C------ Q - QBAR ENERGY FRACTIONS (BORN PROCESS)
1331 c---minorimprovement---mhs---4/8/04---include mass effects correctly
1332         ETA1=(P1(4)+P1(3))/(PHAD1(4)+PHAD1(3))
1333         ETA2=(P2(4)-P2(3))/(PHAD2(4)-PHAD2(3))
1334 C------ PDFs FOR THE BORN PROCESS
1335         CALL HWSFUN(ETA1,EM,IDHW(IHAD1),NSTRU,PDFOLD1,1)
1336         CALL HWSFUN(ETA2,EM,IDHW(IHAD2),NSTRU,PDFOLD2,2)
1337 C-------CONSIDER Q(QBAR) IN THE INITIAL STATE
1338         RN=HWRGEN(9)
1339         IF (RN.LT.COMWGT1) THEN
1340 C-------NO GLUON IN THE INITIAL STATE
1341           GLUIN=.FALSE.
1342 C---CHOOSE S ACCORDING TO 1/S**2
1343           SVNTN=17
1344           SMIN=HALF*EM**2*(7-SQRT(SVNTN))
1345           SMAX=PTOT(5)**2
1346           IF (SMAX.LE.SMIN) RETURN
1347           S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
1348           JAC=S**2*(1/SMIN-1/SMAX)
1349 C---CHOOSE T ACCORDING TO (S-EM**2)/(T*U)=1/T+1/U
1350           TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
1351           TMIN=EM**2-S-TMAX
1352           IF (TMAX.LE.TMIN) RETURN
1353           T=TMAX*(TMIN/TMAX)**HWRGEN(1)
1354           IF (HWRGEN(2).GT.HALF) T=EM**2-S-T
1355           U=EM**2-S-T
1356           JAC=JAC*2*T*U/(S-EM**2)*LOG(TMIN/TMAX)
1357           SCALE=SQRT(U*T/S)
1358           SCALE1=SQRT(U*T/S+EM**2)
1359           GLUFAC=0
1360           IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
1361 C----Q-QBAR ENERGY FRACTIONS FOR Q QBAR-> VG
1362           XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
1363           XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1364 c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1365           IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
1366           IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN
1367 C-----PDFs WITH AN EMITTED GLUON
1368           CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1369           CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1370 C------CALCULATE WEIGHT
1371           W=JAC*((EM**2-T)**2+(EM**2-U)**2)/(S**2*T*U)
1372           W1=(GLUFAC/COMWGT1)*W*PDFNEW1(ID1)*PDFNEW2(ID2)/(PDFOLD1(ID1)*
1373      &         PDFOLD2(ID2))*(CFFAC*ETA1*ETA2/(XI1*XI2))
1374 C-------CHOOSE WHICH PARTON WILL EMIT
1375           EMIT=1
1376           IF (HWRGEN(6).LT.(EM**2-U)**2/((EM**2-U)**2+(EM**2-T)**2))
1377      &         EMIT=2
1378           NOEMIT=3-EMIT
1379         ELSE
1380 C--------GLUON IN THE INITIAL STATE
1381           GLUIN=.TRUE.
1382 C---CHOOSE S ACCORDING TO 1/S**2
1383           SMIN=EM**2
1384           SMAX=PTOT(5)**2
1385           IF (SMAX.LE.SMIN) RETURN
1386           S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
1387           JAC=S**2*(1/SMIN-1/SMAX)
1388 C---CHOOSE T ACCORDING TO 1/T
1389           TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
1390           TMIN=EM**2-S
1391           IF (TMAX.LE.TMIN) RETURN
1392           T=TMAX*(TMIN/TMAX)**HWRGEN(1)
1393           JAC=JAC*T*LOG(TMAX/TMIN)
1394           U=EM**2-S-T
1395           SCALE=SQRT(U*T/S)
1396           SCALE1=SQRT(U*T/S+EM**2)
1397           GLUFAC=0
1398           IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
1399 C--------INITIAL STATE GLUON COMING FROM HADRON 1
1400           IF (RN.LE.COMWGT2) THEN
1401             GP=.TRUE.
1402 C--------ENERGY FRACTIONS and PDFs
1403 c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
1404             XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
1405             XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1406 c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1407             IF ((1-XI1)*SCALE.LT.HWBVMC(13)) RETURN
1408             IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN
1409             CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1410             CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1411             WW=PDFNEW1(13)*PDFNEW2(ID2)/((COMWGT2-COMWGT1)*
1412      &           PDFOLD1(ID1)*PDFOLD2(ID2))
1413           ELSE
1414 C-------INITIAL STATE GLUON COMING FROM HADRON 2
1415             GP=.FALSE.
1416 C-------ENERGY FRACTIONS AND PDFs
1417 c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
1418             XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+U)/(S+T))
1419             XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1420 c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1421             IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
1422             IF ((1-XI2)*SCALE.LT.HWBVMC(13)) RETURN
1423             CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1424             CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1425             WW=PDFNEW1(ID1)*PDFNEW2(13)/((1-COMWGT2)*
1426      &           PDFOLD1(ID1)*PDFOLD2(ID2))
1427           ENDIF
1428           W=-HALF*JAC*((EM**2-T)**2+(EM**2-S)**2)/(S**3*T)
1429 C-------CHOOSE WHICH PARTON WILL EMIT
1430 c---bug fix---mhs---4/8/04---swap emitter and nonemitter
1431           EMIT=2
1432           IF (HWRGEN(10).LT.(EM**2-S)**2/((EM**2-S)**2+(EM**2-T)**2))
1433      &         EMIT=1
1434           NOEMIT=3-EMIT
1435 C-------FINAL WEIGHT FOR ALL THE CONSIDERED OPTIONS
1436           W1=GLUFAC*W*WW*ETA1*ETA2/(XI1*XI2)
1437         ENDIF
1438 C--------ADD ONE MORE GLUON
1439         IF (W1.GT.HWRGEN(4)) THEN
1440           NTMP=NEVHEP+NWGTS
1441         ELSE
1442           RETURN
1443         ENDIF
1444 C---------INCLUDE MASSES
1445         S=S+M1**2+M2**2+M3**2
1446         IF (.NOT.GLUIN) THEN
1447           TEST=((S+M1**2-M2**2)*(S+M3**2-EM**2)-2*S*(M1**2+M3**2-T))**2
1448      $         -((S-M1**2-M2**2)**2-4*M1**2*M2**2)*
1449      $         ((S-M3**2-EM**2)**2-4*M3**2*EM**2)
1450         ELSEIF (GP) THEN
1451           TEST=((S+M3**2-M2**2)*(S+M1**2-EM**2)-2*S*(M3**2+M1**2-T))**2
1452      $         -((S-M3**2-M2**2)**2-4*M3**2*M2**2)*
1453      $         ((S-M1**2-EM**2)**2-4*M1**2*EM**2)
1454         ELSE
1455           TEST=((S+M3**2-M1**2)*(S+M2**2-EM**2)-2*S*(M3**2+M2**2-T))**2
1456      $         -((S-M3**2-M1**2)**2-4*M3**2*M1**2)*
1457      $         ((S-M2**2-EM**2)**2-4*M2**2*EM**2)
1458         ENDIF
1459         IF (TEST.GE.0) THEN
1460           EMIT=0
1461           RETURN
1462         ENDIF
1463         M(1)=M1
1464         M(2)=M2
1465         M(3)=M3
1466 C----MOMENTA IN THE V-REST FRAME WITH NON EMITTER ALONG THE Z AXIS
1467 C----V=BOSON,K=GLUON,E=EMITTER,NE=NON-EMITTER
1468         PV(1)=0
1469         PV(2)=0
1470         PV(3)=0
1471         PV(4)=EM
1472         PV(5)=EM
1473         PNE(2)=0
1474         PNE(1)=0
1475         IF (.NOT.GLUIN) THEN
1476           PK(4)=(S-M(3)**2-EM**2)/(2*EM)
1477           PMODK=SQRT(PK(4)**2-M(3)**2)
1478           IF (EMIT.EQ.1) THEN
1479             MM=M(1)
1480             X1=T
1481             X2=U
1482             X3=-1
1483           ELSE
1484             MM=M(2)
1485             X1=U
1486             X2=T
1487             X3=+1
1488           ENDIF
1489           PNE(4)=(EM**2+MM**2-X1)/(2*EM)
1490           PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1491           COS3=HALF*(X2-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1492         ELSE
1493           PK(4)=(EM**2+M(3)**2-U)/(2*EM)
1494           PMODK=SQRT(PK(4)**2-M(3)**2)
1495           IF (EMIT.EQ.1) THEN
1496             IF (GP) THEN
1497               MM=M(1)
1498               X3=+1
1499             ELSE
1500               MM=M(2)
1501               X3=-1
1502             ENDIF
1503             PNE(4)=(S-MM**2-EM**2)/(2*EM)
1504             PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1505             COS3=HALF*(T-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1506           ELSE
1507             IF (GP) THEN
1508               MM=M(2)
1509               X3=-1
1510             ELSE
1511               MM=M(1)
1512               X3=+1
1513             ENDIF
1514             PNE(4)=(EM**2+MM**2-T)/(2*EM)
1515             PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1516             COS3=HALF*(MM**2+M(3)**2-S+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1517           ENDIF
1518         ENDIF
1519         CALL HWUMAS(PNE)
1520         SIN3=SQRT(1-COS3**2)
1521 C---------DEFINE A RANDOM ROTATION AROUND THE Z-AXIS
1522         CALL HWRAZM(PMODK*SIN3,PK(1),PK(2))
1523         PK(3)=PMODK*COS3
1524         CALL HWUMAS(PK)
1525         DO K=1,4
1526           IF (.NOT.GLUIN) THEN
1527             PE(K)=PV(K)+PK(K)-PNE(K)
1528           ELSE
1529             IF (EMIT.EQ.1) THEN
1530               PE(K)=PV(K)+PNE(K)-PK(K)
1531             ELSE
1532               PE(K)=PNE(K)+PK(K)-PV(K)
1533             ENDIF
1534           ENDIF
1535         ENDDO
1536         CALL HWUMAS(PE)
1537 c------LEPTON MOMENTA IN THE BOSON REST FRAME, WITH THE DIRECTION
1538 C------TAKEN FROM THE BORN PROCESS
1539         PS(5)=P3(5)
1540         PS(4)=(EM**2+P3(5)**2-P4(5)**2)/(2*EM)
1541         PS(3)=-SQRT(PS(4)**2-P3(5)**2)*CPHI
1542         PS(2)=SQRT(PS(4)**2-P3(5)**2)*SPHI*SZ
1543         PS(1)=SQRT(PS(4)**2-P3(5)**2)*SPHI*CZ
1544         PF(5)=P4(5)
1545         PF(4)=(EM**2+P4(5)**2-P3(5)**2)/(2*EM)
1546         PF(3)=-PS(3)
1547         PF(2)=-PS(2)
1548         PF(1)=-PS(1)
1549 C----FIND A STATIONARY VECTOR PLAB IN THE LAB FRAME
1550         IF (.NOT.GLUIN) THEN
1551           IF (EMIT.EQ.1) THEN
1552             CALL HWVEQU(5,PE,PP1)
1553             CALL HWVEQU(5,PNE,PP2)
1554           ELSE
1555             CALL HWVEQU(5,PNE,PP1)
1556             CALL HWVEQU(5,PE,PP2)
1557           ENDIF
1558         ELSE
1559           IF (GP) THEN
1560             CALL HWVEQU(5,PK,PP1)
1561             IF (EMIT.EQ.1) THEN
1562               CALL HWVEQU(5,PE,PP2)
1563             ELSE
1564               CALL HWVEQU(5,PNE,PP2)
1565             ENDIF
1566           ELSE
1567             CALL HWVEQU(5,PK,PP2)
1568             IF (EMIT.EQ.1) THEN
1569               CALL HWVEQU(5,PE,PP1)
1570             ELSE
1571               CALL HWVEQU(5,PNE,PP1)
1572             ENDIF
1573           ENDIF
1574         ENDIF
1575         CALL HWVSCA(4,1/XI1,PP1,PP1)
1576         CALL HWVSCA(4,1/XI2,PP2,PP2)
1577         CALL HWVSUM(4,PP1,PP2,PLAB)
1578         CALL HWUMAS(PLAB)
1579 C------BOOST TO PLAB REST FRAME
1580         CALL HWULOF(PLAB,PE,PE)
1581         CALL HWULOF(PLAB,PNE,PNE)
1582         CALL HWULOF(PLAB,PK,PK)
1583         CALL HWULOF(PLAB,PS,PS)
1584         CALL HWULOF(PLAB,PF,PF)
1585         CALL HWULOF(PLAB,PV,PV)
1586 C----PUT THE INITIAL PARTON BELONGING TO HADRON 1 ON THE Z-AXIS
1587         IF (.NOT.GLUIN) THEN
1588           IF (EMIT.EQ.1) THEN
1589             CALL HWVEQU(5,PE,PZ)
1590           ELSE
1591             CALL HWVEQU(5,PNE,PZ)
1592           ENDIF
1593         ELSE
1594           IF (GP) THEN
1595             CALL HWVEQU(5,PK,PZ)
1596           ELSE
1597             IF (EMIT.EQ.1) THEN
1598               CALL HWVEQU(5,PE,PZ)
1599             ELSE
1600               CALL HWVEQU(5,PNE,PZ)
1601             ENDIF
1602           ENDIF
1603         ENDIF
1604         MODP=SQRT(PZ(1)**2+PZ(2)**2)
1605         CTH=PZ(1)/MODP
1606         STH=PZ(2)/MODP
1607         CALL HWUROT(PZ,CTH,STH,R3)
1608 C-----ROTATE EVERYTHING BY R3
1609         CALL HWUROF(R3,PE,PE)
1610         CALL HWUROF(R3,PNE,PNE)
1611         CALL HWUROF(R3,PV,PV)
1612         CALL HWUROF(R3,PK,PK)
1613         CALL HWUROF(R3,PS,PS)
1614         CALL HWUROF(R3,PF,PF)
1615 C--REORDER ENTRIES:--IHEP=EMITTER,JHEP=NON-EMITTER,KHEP=EMITTED
1616         IF (.NOT.GLUIN) THEN
1617           IHEP=JMOHEP(EMIT,ICMF)
1618           JHEP=JMOHEP(NOEMIT,ICMF)
1619         ENDIF
1620         CHEP=ICMF
1621         IDHW(CHEP)=15
1622         IDHEP(CHEP)=IDPDG(15)
1623         ICMF=ICMF+1
1624         IDHW(ICMF)=IDBOS
1625         IDHEP(ICMF)=IDPDG(IDBOS)
1626 C-----NO GLUON IN THE INITIAL STATE: JUST ADD IT AFTER THE VECTOR BOSON
1627         IF (.NOT.GLUIN) THEN
1628           KHEP=ICMF+1
1629           ISTHEP(KHEP)=114
1630 C---STATUS OF EMITTER/NON EMITTER
1631           ISTHEP(IHEP)=110+EMIT
1632           ISTHEP(JHEP)=110+NOEMIT
1633         ELSE
1634 C-----GLUON COMING FROM THE 1ST HADRON
1635           IF (GP) THEN
1636             KHEP=CHEP-2
1637             ISTHEP(KHEP)=111
1638 C----EMIT=1
1639             IF (EMIT.EQ.1) THEN
1640               IHEP=KHEP+1
1641               ISTHEP(IHEP)=112
1642               JHEP=ICMF+1
1643               ISTHEP(JHEP)=114
1644               IDHW(IHEP)=ID2
1645               IF (ID1.LE.6) THEN
1646                 IDHW(JHEP)=ID1+6
1647               ELSE
1648                 IDHW(JHEP)=ID1-6
1649               ENDIF
1650             ELSE
1651 C-------EMIT=2
1652               JHEP=KHEP+1
1653               ISTHEP(JHEP)=112
1654               IDHW(JHEP)=ID2
1655               IHEP=ICMF+1
1656               ISTHEP(IHEP)=114
1657               IF (ID1.LE.6) THEN
1658                 IDHW(IHEP)=ID1+6
1659               ELSE
1660                 IDHW(IHEP)=ID1-6
1661               ENDIF
1662             ENDIF
1663           ENDIF
1664 C------GLUON COMING FROM THE HADRON 2
1665           IF (.NOT.GP) THEN
1666             KHEP=CHEP-1
1667             ISTHEP(KHEP)=112
1668 C-------EMIT=1
1669             IF (EMIT.EQ.1) THEN
1670               IHEP=KHEP-1
1671               ISTHEP(IHEP)=111
1672               IDHW(IHEP)=ID1
1673               JHEP=ICMF+1
1674               ISTHEP(JHEP)=114
1675               IF (ID2.LE.6) THEN
1676                 IDHW(JHEP)=ID2+6
1677               ELSE
1678                 IDHW(JHEP)=ID2-6
1679               ENDIF
1680             ELSE
1681 C-------EMIT=2
1682               JHEP=KHEP-1
1683               ISTHEP(JHEP)=111
1684               IDHW(JHEP)=ID1
1685               IHEP=ICMF+1
1686               ISTHEP(IHEP)=114
1687               IF (ID2.LE.6) THEN
1688                 IDHW(IHEP)=ID2+6
1689               ELSE
1690                 IDHW(IHEP)=ID2-6
1691               ENDIF
1692             ENDIF
1693           ENDIF
1694         ENDIF
1695         IDHEP(IHEP)=IDPDG(IDHW(IHEP))
1696         IDHEP(JHEP)=IDPDG(IDHW(JHEP))
1697         ISTHEP(ICMF)=113
1698         ISTHEP(CHEP)=110
1699         IDHW(KHEP)=13
1700         IDHEP(KHEP)=IDPDG(13)
1701 C---------DEFINE MOMENTA IN THE LAB FRAME
1702         CALL HWVEQU(5,PV,PHEP(1,ICMF))
1703         CALL HWVEQU(5,PK,PHEP(1,KHEP))
1704         CALL HWVEQU(5,PNE,PHEP(1,JHEP))
1705         CALL HWVEQU(5,PE,PHEP(1,IHEP))
1706         IF (.NOT.GLUIN) THEN
1707           CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,CHEP))
1708         ELSE
1709           IF (EMIT.EQ.1) THEN
1710             CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,CHEP))
1711           ELSE
1712             CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PHEP(1,CHEP))
1713           ENDIF
1714         ENDIF
1715         CALL HWUMAS(PHEP(1,CHEP))
1716         IF (.NOT.GLUIN) THEN
1717           JMOHEP(1,JHEP)=CHEP
1718           JMOHEP(1,IHEP)=CHEP
1719           JDAHEP(1,JHEP)=CHEP
1720           JDAHEP(1,IHEP)=CHEP
1721           JMOHEP(1,KHEP)=CHEP
1722           JDAHEP(1,KHEP)=0
1723           JMOHEP(1,ICMF)=CHEP
1724           JMOHEP(2,ICMF)=ICMF
1725           JDAHEP(1,ICMF)=0
1726           JDAHEP(2,ICMF)=ICMF
1727         ENDIF
1728         IF (GLUIN) THEN
1729           JMOHEP(2,ICMF)=ICMF
1730           JDAHEP(2,ICMF)=ICMF
1731           JMOHEP(1,KHEP)=CHEP
1732           JDAHEP(1,KHEP)=CHEP
1733           JMOHEP(1,IHEP)=CHEP
1734           JMOHEP(1,JHEP)=CHEP
1735           IF (EMIT.EQ.1) THEN
1736             JDAHEP(1,IHEP)=CHEP
1737             JDAHEP(1,JHEP)=0
1738           ELSE
1739             JDAHEP(1,JHEP)=CHEP
1740             JDAHEP(1,IHEP)=0
1741           ENDIF
1742         ENDIF
1743 C---COLOUR CONNECTIONS
1744         IF (.NOT.GLUIN) THEN
1745           IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
1746             JMOHEP(2,KHEP)=IHEP
1747             JDAHEP(2,KHEP)=JHEP
1748             JMOHEP(2,IHEP)=JHEP
1749             JDAHEP(2,IHEP)=KHEP
1750             JDAHEP(2,JHEP)=IHEP
1751             JMOHEP(2,JHEP)=KHEP
1752           ELSE
1753             JMOHEP(2,KHEP)=JHEP
1754             JDAHEP(2,KHEP)=IHEP
1755             JMOHEP(2,JHEP)=IHEP
1756             JDAHEP(2,JHEP)=KHEP
1757             JDAHEP(2,IHEP)=JHEP
1758             JMOHEP(2,IHEP)=KHEP
1759           ENDIF
1760         ENDIF
1761         IF (GLUIN) THEN
1762           IF (EMIT.EQ.1) THEN
1763             IF (IDHEP(IHEP).GT.0) THEN
1764               JMOHEP(2,IHEP)=JHEP
1765               JDAHEP(2,IHEP)=KHEP
1766               JMOHEP(2,JHEP)=KHEP
1767               JDAHEP(2,JHEP)=IHEP
1768               JMOHEP(2,KHEP)=IHEP
1769               JDAHEP(2,KHEP)=JHEP
1770             ELSE
1771               JMOHEP(2,IHEP)=KHEP
1772               JDAHEP(2,IHEP)=JHEP
1773               JMOHEP(2,JHEP)=IHEP
1774               JDAHEP(2,JHEP)=KHEP
1775               JMOHEP(2,KHEP)=JHEP
1776               JDAHEP(2,KHEP)=IHEP
1777             ENDIF
1778           ELSE
1779             IF (IDHEP(JHEP).GT.0) THEN
1780               JMOHEP(2,JHEP)=IHEP
1781               JDAHEP(2,JHEP)=KHEP
1782               JMOHEP(2,IHEP)=KHEP
1783               JDAHEP(2,IHEP)=JHEP
1784               JMOHEP(2,KHEP)=JHEP
1785               JDAHEP(2,KHEP)=IHEP
1786             ELSE
1787               JMOHEP(2,JHEP)=KHEP
1788               JDAHEP(2,JHEP)=IHEP
1789               JMOHEP(2,IHEP)=JHEP
1790               JDAHEP(2,IHEP)=KHEP
1791               JMOHEP(2,KHEP)=IHEP
1792               JDAHEP(2,KHEP)=JHEP
1793             ENDIF
1794           ENDIF
1795         ENDIF
1796         EMSCA=SQRT(EM**2+PHEP(1,ICMF)**2+PHEP(2,ICMF)**2)
1797 C--------SET STATUS AND LEPTON MOMENTA AFTER THE PARTON SHOWER
1798       ELSEIF (IOPT.EQ.2) THEN
1799         IF (EMIT.EQ.0.OR.NEVHEP+NWGTS.NE.NTMP) RETURN
1800         ISTHEP(JDAHEP(1,ICMF))=195
1801         IDHW(NHEP+1)=ID4
1802         IDHW(NHEP+2)=ID5
1803         IDHEP(NHEP+1)=IDPDG(ID4)
1804         IDHEP(NHEP+2)=IDPDG(ID5)
1805         ISTHEP(NHEP+1)=113
1806         ISTHEP(NHEP+2)=114
1807         CW=PHEP(3,ICMF)/SQRT(PHEP(1,ICMF)**2+PHEP(2,ICMF)**2+
1808      &       PHEP(3,ICMF)**2)
1809         SW=SQRT(1-CW**2)
1810         CALL HWUROT(PHEP(1,ICMF),CW,SW,R4)
1811         CALL HWUROF(R4,PHEP(1,ICMF),PR)
1812         PR(4)=PHEP(4,ICMF)
1813         CALL HWUMAS(PR)
1814         CALL HWUROF(R4,PS,PS)
1815         CALL HWUROF(R4,PF,PF)
1816         CALL HWUMAS(PS)
1817         CALL HWUMAS(PF)
1818         CALL HWUROT(PHEP(1,JDAHEP(1,ICMF)),CW,SW,R5)
1819         CALL HWUROF(R5,PHEP(1,JDAHEP(1,ICMF)),PD)
1820         PD(4)=PHEP(4,JDAHEP(1,ICMF))
1821         CALL HWUMAS(PD)
1822         BETA1=(PR(4)*PR(3)-SQRT(PR(4)**2*PD(3)**2-PR(3)**2*PD(3)**2+
1823      &       PD(3)**4))/(PD(3)**2+PR(4)**2)
1824         GAMMA1=1/SQRT(1-BETA1**2)
1825         PHEP(4,NHEP+1)=GAMMA1*PS(4)-BETA1*GAMMA1*PS(3)
1826         PHEP(3,NHEP+1)=-BETA1*GAMMA1*PS(4)+GAMMA1*PS(3)
1827         PHEP(4,NHEP+2)=GAMMA1*PF(4)-BETA1*GAMMA1*PF(3)
1828         PHEP(3,NHEP+2)=-BETA1*GAMMA1*PF(4)+GAMMA1*PF(3)
1829         PHEP(1,NHEP+1)=PS(1)
1830         PHEP(2,NHEP+1)=PS(2)
1831         PHEP(1,NHEP+2)=PF(1)
1832         PHEP(2,NHEP+2)=PF(2)
1833         CALL HWUMAS(PHEP(1,NHEP+1))
1834         CALL HWUMAS(PHEP(1,NHEP+2))
1835         CALL HWUROB(R5,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
1836         CALL HWUROB(R5,PHEP(1,NHEP+2),PHEP(1,NHEP+2))
1837         JDAHEP(1,JDAHEP(1,ICMF))=NHEP+1
1838         JDAHEP(2,JDAHEP(1,ICMF))=NHEP+2
1839         JMOHEP(1,NHEP+1)=JDAHEP(1,ICMF)
1840         JMOHEP(1,NHEP+2)=JDAHEP(1,ICMF)
1841         JMOHEP(2,NHEP+1)=NHEP+2
1842         JDAHEP(2,NHEP+1)=NHEP+2
1843         JMOHEP(2,NHEP+2)=NHEP+1
1844         JDAHEP(2,NHEP+2)=NHEP+1
1845 C--special for spin correlations(relabel in spin common block)
1846         IF(SYSPIN.AND.NSPN.NE.0) THEN
1847           IDSPN(2) = NHEP+1
1848           IDSPN(3) = NHEP+2
1849           ISNHEP(NHEP+1) = 2
1850           ISNHEP(NHEP+2) = 3
1851         ENDIF
1852         NHEP=NHEP+2
1853         EMIT=0
1854       ENDIF
1855       END
1856 CDECK  ID>, HWBFIN.
1857 *CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
1858 *-- Author :    Bryan Webber
1859 C-----------------------------------------------------------------------
1860       SUBROUTINE HWBFIN(IHEP)
1861 C-----------------------------------------------------------------------
1862 C     DELETES INTERNAL LINES FROM SHOWER, MAKES COLOUR CONNECTION INDEX
1863 C     AND COPIES INTO /HEPEVT/ IN COLOUR ORDER.
1864 C-----------------------------------------------------------------------
1865       INCLUDE 'herwig65.inc'
1866       INTEGER IHEP,ID,IJET,KHEP,IPAR,JPAR,NXPAR,IP,JP
1867       IF (IERROR.NE.0) RETURN
1868 C---SAVE VIRTUAL PARTON DATA
1869       NHEP=NHEP+1
1870       IF(NHEP.GT.NMXHEP) THEN
1871         CALL HWWARN('HWBFIN',100)
1872         GOTO 999
1873       ENDIF
1874       ID=IDPAR(2)
1875       IDHW(NHEP)=ID
1876       IDHEP(NHEP)=IDPDG(ID)
1877       ISTHEP(NHEP)=ISTHEP(IHEP)+20
1878       JMOHEP(1,NHEP)=IHEP
1879       JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
1880       JDAHEP(1,IHEP)=NHEP
1881       JDAHEP(1,NHEP)=0
1882       JDAHEP(2,NHEP)=0
1883       CALL HWVEQU(5,PPAR(1,2),PHEP(1,NHEP))
1884       CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
1885 C---FINISHED FOR SPECTATOR OR NON-PARTON JETS
1886       IF (ISTHEP(NHEP).GT.136) RETURN
1887       IF (ID.GT.13.AND.ID.LT.209 .AND. ID.NE.59) RETURN
1888       IF (ID.GT.220.AND.ABS(IDPDG(ID)).LT.1000000) RETURN
1889       IF (ID.GT.424.AND.ID.NE.449) RETURN
1890       IF (.NOT.TMPAR(2).AND.ID.EQ.59) RETURN
1891       IDHEP(NHEP)=94
1892       IJET=NHEP
1893       IF (NPAR.GT.2) THEN
1894 C---SAVE CONE DATA
1895         NHEP=NHEP+1
1896         IF(NHEP.GT.NMXHEP) THEN
1897           CALL HWWARN('HWBFIN',101)
1898           GOTO 999
1899         ENDIF
1900         IDHW(NHEP)=IDPAR(1)
1901         IDHEP(NHEP)=0
1902         ISTHEP(NHEP)=100
1903         JMOHEP(1,NHEP)=IHEP
1904         JMOHEP(2,NHEP)=JCOPAR(1,1)
1905         JDAHEP(1,NHEP)=0
1906         JDAHEP(2,NHEP)=0
1907         CALL HWVEQU(5,PPAR,PHEP(1,NHEP))
1908         CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
1909       ENDIF
1910       KHEP=NHEP
1911 C---START WITH ANTICOLOUR DAUGHTER OF HARDEST PARTON
1912       IPAR=2
1913       JPAR=JCOPAR(4,IPAR)
1914       NXPAR=NPAR/2
1915       DO 20 IP=1,NXPAR
1916       DO 10 JP=1,NXPAR
1917       IF (JPAR.EQ.0) GOTO 15
1918       IF (JCOPAR(2,JPAR).EQ.IPAR) THEN
1919         IPAR=JPAR
1920         JPAR=JCOPAR(4,IPAR)
1921       ELSE
1922         IPAR=JPAR
1923         JPAR=JCOPAR(1,IPAR)
1924       ENDIF
1925    10 CONTINUE
1926 C---COULDN'T FIND COLOUR PARTNER
1927       CALL HWWARN('HWBFIN',1)
1928    15 JPAR=JCOPAR(1,IPAR)
1929       KHEP=KHEP+1
1930       IF(KHEP.GT.NMXHEP) THEN
1931         CALL HWWARN('HWBFIN',102)
1932         GOTO 999
1933       ENDIF
1934       ID=IDPAR(IPAR)
1935       IF (TMPAR(IPAR)) THEN
1936         IF (ID.LT.14) THEN
1937           ISTHEP(KHEP)=139
1938         ELSEIF (ID.EQ.59) THEN
1939           ISTHEP(KHEP)=139
1940         ELSEIF (ID.LT.109) THEN
1941           ISTHEP(KHEP)=130
1942         ELSEIF (ID.LT.120) THEN
1943           ISTHEP(KHEP)=139
1944         ELSEIF (ABS(IDPDG(ID)).LT.1000000) THEN
1945           ISTHEP(KHEP)=130
1946         ELSEIF (ID.LT.425) THEN
1947           ISTHEP(KHEP)=139
1948         ELSEIF (ID.EQ.449) THEN
1949           ISTHEP(KHEP)=139
1950         ELSE
1951           ISTHEP(KHEP)=130
1952         ENDIF
1953       ELSE
1954         ISTHEP(KHEP)=ISTHEP(IHEP)+24
1955       ENDIF
1956       IDHW(KHEP)=ID
1957       IDHEP(KHEP)=IDPDG(ID)
1958       CALL HWVEQU(5,PPAR(1,IPAR),PHEP(1,KHEP))
1959       CALL HWVEQU(4,VPAR(1,IPAR),VHEP(1,KHEP))
1960       JMOHEP(1,KHEP)=IJET
1961       JMOHEP(2,KHEP)=KHEP+1
1962       JDAHEP(1,KHEP)=0
1963       JDAHEP(2,KHEP)=KHEP-1
1964    20 CONTINUE
1965       JMOHEP(2,KHEP)=0
1966       JDAHEP(2,NHEP+1)=0
1967       JDAHEP(1,IJET)=NHEP+1
1968       JDAHEP(2,IJET)=KHEP
1969       NHEP=KHEP
1970  999  RETURN
1971       END
1972 CDECK  ID>, HWBGEN.
1973 *CMZ :-        -14/10/99  18.04.56  by  Mike Seymour
1974 *-- Author :    Bryan Webber
1975 C-----------------------------------------------------------------------
1976       SUBROUTINE HWBGEN
1977 C-----------------------------------------------------------------------
1978 C     BRANCHING GENERATOR WITH INTERFERING GLUONS
1979 C     HWBGEN EVOLVES QCD JETS ACCORDING TO THE METHOD OF
1980 C     G.MARCHESINI & B.R.WEBBER, NUCL. PHYS. B238(1984)1
1981 C-----------------------------------------------------------------------
1982       INCLUDE 'herwig65.inc'
1983       DOUBLE PRECISION HWULDO,HWRGAU,EINHEP,ERTXI,RTXI,XF
1984       INTEGER NTRY,LASHEP,IHEP,NRHEP,ID,IST,JHEP,KPAR,I,J,IRHEP(NMXJET),
1985      & IRST(NMXJET),JPR
1986       LOGICAL HWRLOG
1987       EXTERNAL HWULDO,HWRGAU
1988       IF (IERROR.NE.0) RETURN
1989       IF (IPRO.EQ.80) RETURN
1990 C---CHECK THAT EMSCA IS SET
1991       IF (EMSCA.LE.ZERO) CALL HWWARN('HWBGEN',200)
1992       IF (HARDME) THEN
1993 C---FORCE A BRANCH INTO THE `DEAD ZONE' IN E+E-
1994         JPR=IPROC/10
1995 C**********13/11/00 BRW FIX TO ALLOW ALSO WW AND ZZ
1996         IF (JPR.EQ.10.OR.JPR.EQ.20.OR.JPR.EQ.25) CALL HWBDED(1)
1997 C**********END FIX
1998 C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DIS
1999         IF (IPRO.EQ.90) CALL HWBDIS(1)
2000 C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DRELL-YAN PROCESSES
2001         IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(1)
2002 C---FORCE A BRANCH INTO THE `DEAD ZONE' IN TOP DECAYS
2003         CALL HWBTOP
2004       ENDIF
2005 C---GENERATE INTRINSIC PT ONCE AND FOR ALL
2006       DO 5 JNHAD=1,2
2007         IF (PTRMS.NE.0.) THEN
2008           PTINT(1,JNHAD)=HWRGAU(1,ZERO,PXRMS)
2009           PTINT(2,JNHAD)=HWRGAU(2,ZERO,PXRMS)
2010           PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
2011         ELSE
2012           CALL HWVZRO(3,PTINT(1,JNHAD))
2013         ENDIF
2014  5    CONTINUE
2015       NTRY=0
2016       LASHEP=NHEP
2017  10   NTRY=NTRY+1
2018       IF (NTRY.GT.NETRY) THEN
2019         CALL HWWARN('HWBGEN',ISLENT*100)
2020         GOTO 999
2021       ENDIF
2022       NRHEP=0
2023       NHEP=LASHEP
2024       FROST=.FALSE.
2025       DO 100 IHEP=1,LASHEP
2026       IST=ISTHEP(IHEP)
2027       IF (IST.GE.111.AND.IST.LE.115) THEN
2028        NRHEP=NRHEP+1
2029        IRHEP(NRHEP)=IHEP
2030        IRST(NRHEP)=IST
2031        ID=IDHW(IHEP)
2032        IF (IST.NE.115) THEN
2033 C---FOUND A PARTON TO EVOLVE
2034         NEVPAR=IHEP
2035         NPAR=2
2036         IDPAR(1)=17
2037         IDPAR(2)=ID
2038         TMPAR(1)=.TRUE.
2039         PPAR(2,1)=0.
2040         PPAR(4,1)=1.
2041         DO 15 J=1,2
2042         DO 15 I=1,2
2043         JMOPAR(I,J)=0
2044  15     JCOPAR(I,J)=0
2045 C---SET UP EVOLUTION SCALE AND FRAME
2046         JHEP=JMOHEP(2,IHEP)
2047         IF (ID.EQ.13) THEN
2048           IF (HWRLOG(HALF)) JHEP=JDAHEP(2,IHEP)
2049         ELSEIF (IST.GT.112) THEN
2050           IF ((ID.GT.6.AND.ID.LT.13).OR.
2051      &        (ID.GT.214.AND.ID.LT.221)) JHEP=JDAHEP(2,IHEP)
2052         ELSE
2053           IF (ID.LT.7.OR.(ID.GT.208.AND.ID.LT.215)) JHEP=JDAHEP(2,IHEP)
2054         ENDIF
2055         IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN
2056           CALL HWWARN('HWBGEN',1)
2057           JHEP=IHEP
2058         ENDIF
2059         JCOPAR(1,1)=JHEP
2060         EINHEP=PHEP(4,IHEP)
2061         ERTXI=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
2062         IF (ERTXI.LT.ZERO) ERTXI=0.
2063         IF (IST.LE.112.AND.IHEP.EQ.JHEP) ERTXI=0.
2064         IF (ISTHEP(JHEP).EQ.155) THEN
2065           ERTXI=ERTXI/PHEP(5,JHEP)
2066           RTXI=1.
2067         ELSE
2068           ERTXI=SQRT(ERTXI)
2069           RTXI=ERTXI/EINHEP
2070         ENDIF
2071         IF (RTXI.EQ.ZERO) THEN
2072           XF=1.
2073           PPAR(1,1)=0.
2074           PPAR(3,1)=1.
2075           PPAR(1,2)=EINHEP
2076           PPAR(2,2)=0.
2077           PPAR(4,2)=EINHEP
2078         ELSE
2079           XF=1./RTXI
2080           PPAR(1,1)=1.
2081           PPAR(3,1)=0.
2082           PPAR(1,2)=ERTXI
2083           PPAR(2,2)=1.
2084           PPAR(4,2)=ERTXI
2085         ENDIF
2086         IF (PPAR(4,2).LT.PHEP(5,IHEP)) PPAR(4,2)=PHEP(5,IHEP)
2087 C---STORE MASS
2088         PPAR(5,2)=PHEP(5,IHEP)
2089         CALL HWVZRO(4,VPAR(1,1))
2090         CALL HWVZRO(4,VPAR(1,2))
2091         IF (IST.GT.112) THEN
2092           TMPAR(2)=.TRUE.
2093           INHAD=0
2094           JNHAD=0
2095           XFACT=0.
2096         ELSE
2097           TMPAR(2)=.FALSE.
2098           JNHAD=IST-110
2099           INHAD=JNHAD
2100           IF (JDAHEP(1,JNHAD).NE.0) INHAD=JDAHEP(1,JNHAD)
2101           XFACT=XF/PHEP(4,INHAD)
2102           ANOMSC(1,JNHAD)=ZERO
2103           ANOMSC(2,JNHAD)=ZERO
2104         ENDIF
2105 C---FOR QUARKS IN A COLOUR SINGLET, ALLOW SOFT MATRIX-ELEMENT CORRECTION
2106         HARDST=PPAR(4,2)
2107         IF (SOFTME.AND.IDHW(IHEP).LT.13.AND.
2108      $       ((JMOHEP(2,JHEP).EQ.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP).OR.
2109      $       ISTHEP(JHEP).EQ.155)) HARDST=0
2110 C---CREATE BRANCHES AND COMPUTE ENERGIES
2111         DO 20 KPAR=2,NMXPAR
2112         IF (TMPAR(KPAR)) THEN
2113           CALL HWBRAN(KPAR)
2114         ELSE
2115           CALL HWSBRN(KPAR)
2116         ENDIF
2117         IF (IERROR.NE.0) RETURN
2118         IF (FROST) GOTO 100
2119         IF (KPAR.EQ.NPAR) GOTO 30
2120  20     CONTINUE
2121 C---COMPUTE MASSES AND 3-MOMENTA
2122  30     CONTINUE
2123         CALL HWBMAS
2124         IF (AZSPIN) CALL HWBSPN
2125         IF (TMPAR(2)) THEN
2126            CALL HWBTIM(2,1)
2127         ELSE
2128            CALL HWBSPA
2129         ENDIF
2130 C---ENTER PARTON JET IN /HEPEVT/
2131         CALL HWBFIN(IHEP)
2132        ELSE
2133 C---COPY SPECTATOR
2134         NHEP=NHEP+1
2135         IF (ID.GT.120.AND.ID.LT.133 .OR. ID.GE.198.AND.ID.LE.201) THEN
2136           ISTHEP(NHEP)=190
2137         ELSE
2138           ISTHEP(NHEP)=152
2139         ENDIF
2140         IDHW(NHEP)=ID
2141         IDHEP(NHEP)=IDPDG(ID)
2142         JMOHEP(1,NHEP)=IHEP
2143         JMOHEP(2,NHEP)=0
2144         JDAHEP(2,NHEP)=0
2145         JDAHEP(1,IHEP)=NHEP
2146         CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
2147        ENDIF
2148        ISTHEP(IHEP)=ISTHEP(IHEP)+10
2149       ENDIF
2150  100  CONTINUE
2151       IF (.NOT.FROST) THEN
2152 C---COMBINE JETS
2153         ISTAT=20
2154         CALL HWBJCO
2155       ENDIF
2156       IF (.NOT.FROST) THEN
2157 C---ATTACH SPECTATORS
2158         ISTAT=30
2159         CALL HWSSPC
2160       ENDIF
2161       IF (FROST) THEN
2162 C---BAD JET: RESTORE PARTONS AND RE-EVOLVE
2163          DO 120 I=1,NRHEP
2164  120     ISTHEP(IRHEP(I))=IRST(I)
2165          GOTO 10
2166       ENDIF
2167 C---CONNECT COLOURS
2168       CALL HWBCON
2169       ISTAT=40
2170       LASHEP=NHEP
2171       IF (HARDME) THEN
2172 C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN E+E-
2173         IF (IPROC/10.EQ.10) CALL HWBDED(2)
2174 C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DIS
2175         IF (IPRO.EQ.90) CALL HWBDIS(2)
2176 C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DRELL-YAN PROC
2177         IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(2)
2178       ENDIF
2179 C---IF THE CLEAN-UP OPERATION ADDED ANY PARTONS TO THE EVENT RECORD
2180 C   IT MIGHT NEED RESHOWERING
2181       IF (NHEP.GT.LASHEP) THEN
2182         LASHEP=NHEP
2183         GOTO 10
2184       ENDIF
2185  999  RETURN
2186       END
2187 CDECK  ID>, HWBGUP.
2188 *CMZ :-        -16/07/02  09.40.25  by  Peter Richardson
2189 *-- Author :    Peter Richardson
2190 C----------------------------------------------------------------------
2191       SUBROUTINE HWBGUP(ISTART,ICMF)
2192 C----------------------------------------------------------------------
2193 C     Makes the colour connections and performs the parton shower
2194 C     for events read in from the GUPI (Generic User Process Interface)
2195 C     event common block
2196 C----------------------------------------------------------------------
2197       INCLUDE 'herwig65.inc'
2198       INTEGER MAXNUP
2199       PARAMETER (MAXNUP=500)
2200       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
2201       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
2202       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
2203      &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
2204      &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
2205      &              SPINUP(MAXNUP)
2206 C--Local variables
2207       INTEGER ISTART,ICMF,J,K,I,JCOL,ICOL
2208       LOGICAL FOUND
2209       COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
2210       INTEGER ILOC,JLOC
2211 C--now we need to do the colour connections
2212  20   ISTART = ISTART+1
2213       IF(ISTART.GT.NHEP) GOTO 30
2214       IF(ISTART.EQ.ICMF) ISTART = ISTART+1
2215       IF(JMOHEP(2,ISTART).NE.0.AND.JDAHEP(2,ISTART).NE.0) GOTO 20
2216       K = ISTART
2217       J = ILOC(K)
2218       IF(ICOLUP(1,J).NE.0) THEN
2219         JCOL = 1
2220         ICOL = ICOLUP(1,J)
2221       ELSE
2222         JCOL = 2
2223         ICOL = ICOLUP(2,J)
2224       ENDIF
2225       IF(ICOL.EQ.0) THEN
2226         JMOHEP(2,K) = K
2227         JDAHEP(2,K) = K
2228         GOTO 20
2229       ENDIF
2230 C--now search for the partner
2231 C--first search for the flavour partner if not looking for colour partner
2232 C--search for the flavour partner of the particle
2233 C--this must be set or HERWIG won't work
2234  10   IF(JDAHEP(2,K).NE.0.AND.JMOHEP(2,K).NE.0) GOTO 20
2235       IF(ICOL.EQ.0) THEN
2236         FOUND = .FALSE.
2237 C--look for unpaired particle
2238         DO 15 I=1,NUP
2239           IF(JLOC(I).EQ.0) GOTO 15
2240           IF(IDUP(I).EQ.21.OR.IDUP(I).EQ.9) GOTO 15
2241           IF(JLOC(I).EQ.ISTART) GOTO 15
2242           IF(ICOLUP(1,I).EQ.0.AND.ICOLUP(2,I).EQ.0) GOTO 15
2243 C--antiflavour partner
2244           IF(JDAHEP(2,JLOC(I)).EQ.0) THEN
2245 C--pair incoming     particle with outgoing     particle
2246 C-- or  outgoing antiparticle with outgoing     particle
2247             IF(ISTUP(I).GT.0.AND.IDUP(I).GT.0.AND.
2248      &         ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
2249      &          (IDUP(J).LT.0.AND.ISTUP(J).GT.0 )))  THEN
2250               FOUND = .TRUE.
2251               JCOL = 1
2252 C--pair incoming     particle with incoming antiparticle
2253 C-- or  outgoing antiparticle with incoming antiparticle
2254             ELSEIF(IDUP(I).LT.0.AND.ISTUP(I).EQ.-1.AND.
2255      &             ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
2256      &              (IDUP(J).LT.0.AND.ISTUP(J).GT.0 ))) THEN
2257               FOUND = .TRUE.
2258               JCOL = 2
2259             ENDIF
2260 C--make the connection
2261             IF(FOUND) THEN
2262               JMOHEP(2,K)       = JLOC(I)
2263               JDAHEP(2,JLOC(I)) = K
2264             ENDIF
2265           ENDIF
2266 C--flavour partner
2267           IF(JMOHEP(2,JLOC(I)).EQ.0.AND.(.NOT.FOUND)) THEN
2268 C--pair incoming antiparticle with outgoing antiparticle
2269 C-- or  outgoing     particle with outgoing antiparticle
2270             IF(IDUP(I).LT.0.AND.ISTUP(I).GT.0.AND.
2271      &         ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
2272      &          (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
2273               FOUND = .TRUE.
2274               JCOL = 2
2275 C--pair incoming antiparticle with incoming     particle
2276 C-- or  outgoing     particle with incoming     particle
2277             ELSEIF(IDUP(I).GT.0.AND.ISTUP(I).EQ.-1.AND.
2278      &             ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
2279      &              (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
2280               FOUND = .TRUE.
2281               JCOL = 1
2282             ENDIF
2283 C--make the connection
2284             IF(FOUND) THEN
2285               JDAHEP(2,K) = JLOC(I)
2286               JMOHEP(2,JLOC(I)) = K
2287             ENDIF
2288           ENDIF
2289 C--set up the search for the next partner
2290           IF(FOUND) THEN
2291             FOUND = .FALSE.
2292             ICOL = ICOLUP(JCOL,I)
2293             K = JLOC(I)
2294             J = I
2295             GOTO 10
2296           ENDIF
2297  15     CONTINUE
2298 C--if no other choice then connect to the first particle in the loop
2299         IF(JDAHEP(2,K).EQ.0.AND.JMOHEP(2,ISTART).EQ.0) THEN
2300            JDAHEP(2,K) = ISTART
2301            JMOHEP(2,ISTART) = K
2302         ELSEIF(JDAHEP(2,ISTART).EQ.0.AND.JMOHEP(2,K).EQ.0) THEN
2303            JMOHEP(2,K) = ISTART
2304            JDAHEP(2,ISTART) = K
2305         ELSE
2306           CALL HWWARN('HWBGUP',100)
2307           GOTO 999
2308         ENDIF
2309         GOTO 20
2310       ENDIF
2311 C--now the bit to find colour partners
2312       FOUND = .FALSE.
2313 C--special for particle from a decaying coloured particle
2314       IF(MOTHUP(1,J).NE.0) THEN
2315         IF(ISTUP(MOTHUP(1,J)).EQ.2.OR.ISTUP(MOTHUP(1,J)).EQ.3) THEN
2316           IF(IDUP(J).LT.0.AND.ICOL.EQ.ICOLUP(2,MOTHUP(1,J))) THEN
2317             JDAHEP(2,K) = JLOC(MOTHUP(1,J))
2318             JMOHEP(2,K) = JLOC(MOTHUP(1,J))
2319             GOTO 20
2320           ELSEIF(IDUP(J).GT.0.AND.ICOL.EQ.ICOLUP(1,MOTHUP(1,J))) THEN
2321             JDAHEP(2,K) = JLOC(MOTHUP(1,J))
2322             JMOHEP(2,K) = JLOC(MOTHUP(1,J))
2323             GOTO 20
2324           ENDIF
2325         ENDIF
2326       ENDIF
2327 C--search for the partner
2328       DO I=1,NUP
2329         IF(ICOLUP(1,I).EQ.ICOL.AND.I.NE.J) THEN
2330           IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GT.0).OR.
2331      &       (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).GE.0)) THEN
2332             JDAHEP(2,K)       = JLOC(I)
2333             JMOHEP(2,JLOC(I)) = K
2334             FOUND = .TRUE.
2335           ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1).OR.
2336      &          (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1)) THEN
2337             JMOHEP(2,K)       = JLOC(I)
2338             JDAHEP(2,JLOC(I)) = K
2339             FOUND = .TRUE.
2340           ENDIF
2341           IF(FOUND) JCOL = 2
2342         ELSEIF(ICOLUP(2,I).EQ.ICOL.AND.I.NE.J) THEN
2343           IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1).OR.
2344      &       (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1)) THEN
2345             JDAHEP(2,K) = JLOC(I)
2346             JMOHEP(2,JLOC(I)) = K
2347             FOUND = .TRUE.
2348           ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GE.0.AND.ISTUP(I).GE.0).OR.
2349      &           (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GE.0)) THEN
2350             JMOHEP(2,K) = JLOC(I)
2351             JDAHEP(2,JLOC(I)) = K
2352             FOUND = .TRUE.
2353           ENDIF
2354           IF(FOUND) JCOL = 1
2355         ENDIF
2356         IF(FOUND) THEN
2357           K = JLOC(I)
2358           J = I
2359           ICOL = ICOLUP(JCOL,I)
2360           GOTO 10
2361         ENDIF
2362       ENDDO
2363 C--special for self connected gluons
2364       IF(IDUP(J).EQ.21.OR.IDUP(J).EQ.9.AND.
2365      &     ICOLUP(1,J).EQ.ICOLUP(2,J)) THEN
2366         JMOHEP(2,K) = K
2367         JDAHEP(2,K) = K
2368 C--options for self connected gluons
2369         IF(LHGLSF) THEN
2370           CALL HWWARN('HWBGUP',1)
2371         ELSE
2372           CALL HWWARN('HWBGUP',101)
2373           GOTO 999
2374         ENDIF
2375         GOTO 20
2376       ENDIF
2377 C--perform the shower
2378  30   CALL HWBGEN
2379  999  RETURN
2380       END
2381 CDECK  ID>, HWBJCO.
2382 *CMZ :-        -30/09/02  09.19.58  by  Peter Richardson
2383 *-- Author :    Bryan Webber
2384 C-----------------------------------------------------------------------
2385       SUBROUTINE HWBJCO
2386 C-----------------------------------------------------------------------
2387 C     COMBINES JETS WITH REQUIRED KINEMATICS
2388 C-----------------------------------------------------------------------
2389       INCLUDE 'herwig65.inc'
2390       DOUBLE PRECISION HWULDO,EPS,PTX,PTY,PF,PTINF,PTCON,CN,CP,SP,PP0,
2391      & PM0,ET0,DET,ECM,EMJ,EMP,EMS,DMS,ES,DPF,ALF,AL(2),ET(2),PP(2),
2392      & PT(3),PA(5),PB(5),PC(5),PQ(5),PR(5),PS(5),RR(3,3),RS(3,3),ETC,
2393      & PJ(NMXJET),PM(NMXJET),PBR(5),RBR(3,3),DISP(4),PLAB(5)
2394       INTEGER LJET,IJ1,IST,IP,ICM,IP1,IP2,NP,IHEP,MHEP,JP,KP,LP,KHEP,
2395      & JHEP,NE,IJT,IEND(2),IJET(NMXJET),IPAR(NMXJET)
2396       LOGICAL AZCOR,JETRAD,DISPRO,DISLOW
2397       EXTERNAL HWULDO
2398       PARAMETER (EPS=1.D-4)
2399       IF (IERROR.NE.0) RETURN
2400       AZCOR=AZSOFT.OR.AZSPIN
2401       LJET=131
2402   10  IJET(1)=1
2403   20  IJ1=IJET(1)
2404       DO 40 IHEP=IJ1,NHEP
2405       IST=ISTHEP(IHEP)
2406       IF (IST.EQ.137.OR.IST.EQ.138) IST=133
2407       IF (IST.EQ.LJET) THEN
2408 C---FOUND AN UNBOOSTED JET - FIND PARTNERS
2409         IP=JMOHEP(1,IHEP)
2410         ICM=JMOHEP(1,IP)
2411         DISPRO=IPRO/10.EQ.9.AND.IDHW(ICM).EQ.15
2412         DISLOW=DISPRO.AND.JDAHEP(1,ICM).EQ.JDAHEP(2,ICM)-1
2413         IF (IST.EQ.131) THEN
2414           IP1=JMOHEP(1,ICM)
2415           IP2=JMOHEP(2,ICM)
2416         ELSE
2417           IP1=JDAHEP(1,ICM)
2418           IP2=JDAHEP(2,ICM)
2419         ENDIF
2420         IF (IP1.NE.IP) THEN
2421           CALL HWWARN('HWBJCO',100)
2422           GOTO 999
2423         ENDIF
2424         NP=0
2425         DO 30 JHEP=IP1,IP2
2426         NP=NP+1
2427         IPAR(NP)=JHEP
2428   30    IJET(NP)=JDAHEP(1,JHEP)
2429         GOTO 50
2430       ENDIF
2431   40  CONTINUE
2432 C---NO MORE JETS?
2433       IF (LJET.EQ.131) THEN
2434         LJET=133
2435         GOTO 10
2436       ENDIF
2437       RETURN
2438   50  IF (LJET.EQ.131) THEN
2439 C---SPACELIKE JETS: FIND SPACELIKE PARTONS
2440         IF (NP.NE.2) THEN
2441           CALL HWWARN('HWBJCO',103)
2442           GOTO 999
2443         ENDIF
2444 C---special for DIS: FIND BOOST AND ROTATION FROM LAB TO BREIT FRAME
2445         IF (DISPRO.AND.BREIT) THEN
2446           IP=2
2447           IF (JDAHEP(1,IP).NE.0) IP=JDAHEP(1,IP)
2448           CALL HWVDIF(4,PHEP(1,JMOHEP(1,ICM)),PHEP(1,JDAHEP(1,ICM)),PB)
2449           CALL HWUMAS(PB)
2450 C---IF Q**2<10**-2, SOMETHING MUST HAVE ALREADY GONE WRONG
2451           IF (PB(5)**2.LT.1.D-2) THEN
2452             CALL HWWARN('HWBJCO',102)
2453             GOTO 999
2454           ENDIF
2455           CALL HWVSCA(4,PB(5)**2/HWULDO(PHEP(1,IP),PB),PHEP(1,IP),PBR)
2456           CALL HWVSUM(4,PB,PBR,PBR)
2457           CALL HWUMAS(PBR)
2458           CALL HWULOF(PBR,PB,PB)
2459           CALL HWUROT(PB,ONE,ZERO,RBR)
2460         ENDIF
2461         PTX=0.
2462         PTY=0.
2463         PF=1.D0
2464         DO 90 IP=1,2
2465         MHEP=IJET(IP)
2466         IF (JDAHEP(1,MHEP).EQ.0) THEN
2467 C---SPECIAL FOR NON-PARTON JETS
2468           IHEP=MHEP
2469           GOTO 70
2470         ELSE
2471           IST=134+IP
2472           DO 60 IHEP=MHEP,NHEP
2473   60      IF (ISTHEP(IHEP).EQ.IST) GOTO 70
2474 C---COULDN'T FIND SPACELIKE PARTON
2475           CALL HWWARN('HWBJCO',101)
2476           GOTO 999
2477         ENDIF
2478   70    CALL HWVSCA(3,PF,PHEP(1,IHEP),PS)
2479         IF (PTINT(3,IP).GT.ZERO) THEN
2480 C---ADD INTRINSIC PT
2481           PT(1)=PTINT(1,IP)
2482           PT(2)=PTINT(2,IP)
2483           PT(3)=0.
2484           CALL HWUROT(PS, ONE,ZERO,RS)
2485           CALL HWUROB(RS,PT,PT)
2486           CALL HWVSUM(3,PS,PT,PS)
2487         ENDIF
2488         JP=IJET(IP)+1
2489         IF (AZCOR.AND.JP.LE.NHEP.AND.IDHW(JP).EQ.17) THEN
2490 C---ALIGN CONE WITH INTERFERING PARTON
2491           CALL HWUROT(PS, ONE,ZERO,RS)
2492           CALL HWUROF(RS,PHEP(1,JP),PR)
2493           PTCON=PR(1)**2+PR(2)**2
2494           KP=JMOHEP(2,JP)
2495           IF (KP.EQ.0) THEN
2496             CALL HWWARN('HWBJCO',1)
2497             PTINF=0.
2498           ELSE
2499             CALL HWVEQU(4,PHEP(1,KP),PB)
2500             IF (DISPRO.AND.BREIT) THEN
2501               CALL HWULOF(PBR,PB,PB)
2502               CALL HWUROF(RBR,PB,PB)
2503             ENDIF
2504             PTINF=PB(1)**2+PB(2)**2
2505             IF (PTINF.LT.EPS) THEN
2506 C---COLLINEAR JETS: ALIGN CONES
2507               KP=JDAHEP(1,KP)+1
2508 C---BUG FIX BY MHS 17/03/05: RETURNED TO VERSION 6.500!
2509               IF (ISTHEP(KP).EQ.100.AND.ISTHEP(KP-1).GE.141
2510      $                             .AND.ISTHEP(KP-1).LE.144) THEN
2511 C---END FIX
2512                 CALL HWVEQU(4,PHEP(1,KP),PB)
2513                 IF (DISPRO.AND.BREIT) THEN
2514                   CALL HWULOF(PBR,PB,PB)
2515                   CALL HWUROF(RBR,PB,PB)
2516                 ENDIF
2517                 PTINF=PB(1)**2+PB(2)**2
2518               ELSE
2519                 PTINF=0.
2520               ENDIF
2521             ENDIF
2522           ENDIF
2523           IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
2524             CN=1./SQRT(PTINF*PTCON)
2525             CP=CN*(PR(1)*PB(1)+PR(2)*PB(2))
2526             SP=CN*(PR(1)*PB(2)-PR(2)*PB(1))
2527           ELSE
2528             CALL HWRAZM( ONE,CP,SP)
2529           ENDIF
2530         ELSE
2531           CALL HWRAZM( ONE,CP,SP)
2532         ENDIF
2533 C---ROTATE SO SPACELIKE IS ALONG AXIS (APART FROM INTRINSIC PT)
2534         CALL HWUROT(PS,CP,SP,RS)
2535         IHEP=IJET(IP)
2536         KHEP=JDAHEP(2,IHEP)
2537         IF (KHEP.LT.IHEP) KHEP=IHEP
2538         IEND(IP)=KHEP
2539         DO 80 JHEP=IHEP,KHEP
2540         CALL HWUROF(RS,PHEP(1,JHEP),PHEP(1,JHEP))
2541   80    CALL HWUROF(RS,VHEP(1,JHEP),VHEP(1,JHEP))
2542         PP(IP)=PHEP(4,IHEP)+PF*PHEP(3,IHEP)
2543         ET(IP)=PHEP(1,IHEP)**2+PHEP(2,IHEP)**2-PHEP(5,IHEP)**2
2544 C---REDEFINE HARD CM
2545         PTX=PTX+PHEP(1,IHEP)
2546         PTY=PTY+PHEP(2,IHEP)
2547   90    PF=-PF
2548         PHEP(1,ICM)=PTX
2549         PHEP(2,ICM)=PTY
2550 C---special for DIS: keep lepton momenta fixed
2551         IF (DISPRO) THEN
2552           IP1=JMOHEP(1,ICM)
2553           IP2=JDAHEP(1,ICM)
2554           IJT=IJET(1)
2555 C---IJT will be used to store lepton momentum transfer
2556           CALL HWVDIF(4,PHEP(1,IP1),PHEP(1,IP2),PHEP(1,IJT))
2557           CALL HWUMAS(PHEP(1,IJT))
2558           IF (IDHEP(IP1).EQ.IDHEP(IP2)) THEN
2559             IDHW(IJT)=200
2560           ELSEIF (IDHEP(IP1).LT.IDHEP(IP2)) THEN
2561             IDHW(IJT)=199
2562           ELSE
2563             IDHW(IJT)=198
2564           ENDIF
2565           IDHEP(IJT)=IDPDG(IDHW(IJT))
2566           ISTHEP(IJT)=3
2567 C---calculate boost for struck parton
2568 C   PC is momentum of outgoing parton(s)
2569           IP2=JDAHEP(2,ICM)
2570           IF (.NOT.DISLOW) THEN
2571 C---FOR heavy QQbar PQ and PC are old and new QQbar momenta
2572             CALL HWVSUM(4,PHEP(1,IP2-1),PHEP(1,IP2),PQ)
2573             CALL HWUMAS(PQ)
2574             PC(5)=PQ(5)
2575           ELSE
2576             PC(5)=PHEP(5,JDAHEP(1,IP2))
2577           ENDIF
2578           CALL HWVSUM(2,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
2579           ET(1)=ET(2)
2580 C---USE BREIT FRAME BOSON MOMENTUM IF NECESSARY
2581           IF (BREIT) THEN
2582             ET(2)=ET(1)+PC(5)**2+PHEP(5,IJET(2))**2
2583             PM0=PHEP(5,IJT)
2584             PP0=-PM0
2585           ELSE
2586             ET(2)=PC(1)**2+PC(2)**2+PC(5)**2
2587             PP0=PHEP(4,IJT)+PHEP(3,IJT)
2588             PM0=PHEP(4,IJT)-PHEP(3,IJT)
2589           ENDIF
2590           ET0=(PP0*PM0)+ET(1)-ET(2)
2591           DET=ET0**2-4.*(PP0*PM0)*ET(1)
2592           IF (DET.LT.ZERO) THEN
2593             FROST=.TRUE.
2594             RETURN
2595           ENDIF
2596           ALF=(SQRT(DET)-ET0)/(2.*PP0*PP(2))
2597           PB(1)=0.
2598           PB(2)=0.
2599           PB(5)=2.D0
2600           PB(3)=ALF-(1./ALF)
2601           PB(4)=ALF+(1./ALF)
2602           DO 100 IHEP=IJET(2),IEND(2)
2603           CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2604           CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2605 C---BOOST FROM BREIT FRAME IF NECESSARY
2606           IF (BREIT) THEN
2607             CALL HWUROB(RBR,PHEP(1,IHEP),PHEP(1,IHEP))
2608             CALL HWULOB(PBR,PHEP(1,IHEP),PHEP(1,IHEP))
2609             CALL HWUROB(RBR,VHEP(1,IHEP),VHEP(1,IHEP))
2610             CALL HWULB4(PBR,VHEP(1,IHEP),VHEP(1,IHEP))
2611           ENDIF
2612   100     ISTHEP(IHEP)=ISTHEP(IHEP)+10
2613           CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJET(2)),DISP)
2614           DO 110 IHEP=IJET(2),IEND(2)
2615   110     CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2616           IF (IEND(2).GT.IJET(2)+1) ISTHEP(IJET(2)+1)=100
2617           CALL HWVSUM(4,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
2618           CALL HWVSUM(4,PHEP(1,IP1),PHEP(1,IJET(2)),PHEP(1,ICM))
2619           CALL HWUMAS(PHEP(1,ICM))
2620         ELSEIF (IPRO/10.EQ.5) THEN
2621 C Special to preserve photon momentum
2622            ETC=PTX**2+PTY**2+PHEP(5,ICM)**2
2623            ET0=ETC+ET(1)-ET(2)
2624            DET=ET0**2-4.*ETC*ET(1)
2625            IF (DET.LT.ZERO) THEN
2626               FROST=.TRUE.
2627               RETURN
2628            ENDIF
2629            ALF=(SQRT(DET)+ET0-2.*ET(1))/(2.*PP(1)*PP(2))
2630            PB(1)=0.
2631            PB(2)=0.
2632            PB(3)=ALF-1./ALF
2633            PB(4)=ALF+1./ALF
2634            PB(5)=2.
2635            IJT=IJET(2)
2636            DO 120 IHEP=IJT,IEND(2)
2637            CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2638            CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2639   120      ISTHEP(IHEP)=ISTHEP(IHEP)+10
2640            CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJT),DISP)
2641            DO 130 IHEP=IJT,IEND(2)
2642   130      CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2643            IF (IEND(2).GT.IJT+1) ISTHEP(IJT+1)=100
2644            ISTHEP(IJET(1))=ISTHEP(IJET(1))+10
2645            CALL HWVSUM(2,PHEP(3,IPAR(1)),PHEP(3,IJT),PHEP(3,ICM))
2646         ELSE
2647 C--change to preserve either long mom or rapidity rather than long mom
2648 C--by PR and BRW 30/9/02
2649           IF (PRESPL) THEN
2650 C--PRESERVE LONG MOM OF CMF
2651             PHEP(4,ICM)=
2652      &            SQRT(PTX**2+PTY**2+PHEP(3,ICM)**2+PHEP(5,ICM)**2)
2653           ELSE
2654 C--PRESERVE RAPIDITY OF CMF
2655             DET=SQRT(ONE+(PTX**2+PTY**2)/(PHEP(4,ICM)**2
2656      &                -PHEP(3,ICM)**2))
2657             CALL HWVSCA(2,DET,PHEP(3,ICM),PHEP(3,ICM))
2658           ENDIF
2659 C---NOW BOOST TO REQUIRED Q**2 AND X-F
2660           PP0=PHEP(4,ICM)+PHEP(3,ICM)
2661           PM0=PHEP(4,ICM)-PHEP(3,ICM)
2662           ET0=(PP0*PM0)+ET(1)-ET(2)
2663           DET=ET0**2-4.*(PP0*PM0)*ET(1)
2664           IF (DET.LT.ZERO) THEN
2665             FROST=.TRUE.
2666             RETURN
2667           ENDIF
2668           DET=SQRT(DET)+ET0
2669           AL(1)= 2.*PM0*PP(1)/DET
2670           AL(2)=(PM0/PP(2))*(1.-2.*ET(1)/DET)
2671           PB(1)=0.
2672           PB(2)=0.
2673           PB(5)=2.
2674           DO 160 IP=1,2
2675           PB(3)=AL(IP)-(1./AL(IP))
2676           PB(4)=AL(IP)+(1./AL(IP))
2677           IJT=IJET(IP)
2678           DO 140 IHEP=IJT,IEND(IP)
2679           CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2680           CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2681   140     ISTHEP(IHEP)=ISTHEP(IHEP)+10
2682           CALL HWVDIF(4,VHEP(1,IPAR(IP)),VHEP(1,IJT),DISP)
2683           DO 150 IHEP=IJT,IEND(IP)
2684   150     CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2685           IF (IEND(IP).GT.IJT+1) THEN
2686             ISTHEP(IJT+1)=100
2687           ELSEIF (IEND(IP).EQ.IJT) THEN
2688 C---NON-PARTON JET
2689             ISTHEP(IJT)=3
2690           ENDIF
2691   160     CONTINUE
2692         ENDIF
2693         ISTHEP(ICM)=120
2694       ELSE
2695 C---TIMELIKE JETS
2696 C---SPECIAL CASE: IF HARD PROCESS IS W/Z DECAY, PERFORM KINEMATIC
2697 C   RECONSTRUCTION IN ITS REST FRAME INSTEAD OF THE LAB FRAME
2698         IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
2699           CALL HWVEQU(5,PHEP(1,ICM),PLAB)
2700           CALL HWULOF(PLAB,PHEP(1,ICM),PHEP(1,ICM))
2701           CALL HWULF4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
2702           DO 165 IP=1,NP
2703             CALL HWULOF(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
2704             CALL HWULF4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
2705  165      CONTINUE
2706         ENDIF
2707 C   special for DIS: preserve outgoing lepton momentum
2708         IF (DISPRO) THEN
2709           CALL HWVEQU(5,PHEP(1,IPAR(1)),PHEP(1,IJET(1)))
2710           ISTHEP(IJET(1))=1
2711           LP=2
2712         ELSE
2713           CALL HWVEQU(5,PHEP(1,ICM),PC)
2714 C--- PQ AND PC ARE OLD AND NEW PARTON CM
2715           CALL HWVSUM(4,PHEP(1,IPAR(1)),PHEP(1,IPAR(2)),PQ)
2716           PQ(5)=PHEP(5,ICM)
2717           IF (NP.GT.2) THEN
2718             DO 170 KP=3,NP
2719   170       CALL HWVSUM(4,PHEP(1,IPAR(KP)),PQ,PQ)
2720           ENDIF
2721           LP=1
2722         ENDIF
2723         IF (.NOT.DISLOW) THEN
2724 C---FIND JET CM MOMENTA
2725           ECM=PQ(5)
2726           EMS=0.
2727           JETRAD=.FALSE.
2728           DO 180 KP=LP,NP
2729           EMJ=PHEP(5,IJET(KP))
2730           EMP=PHEP(5,IPAR(KP))
2731           JETRAD=JETRAD.OR.EMJ.NE.EMP
2732           EMS=EMS+EMJ
2733           PM(KP)= EMJ**2
2734 C---N.B. ROUNDING ERRORS HERE AT HIGH ENERGIES
2735           PJ(KP)=(HWULDO(PHEP(1,IPAR(KP)),PQ)/ECM)**2-EMP**2
2736           IF (PJ(KP).LE.ZERO) THEN
2737             CALL HWWARN('HWBJCO',104)
2738             GOTO 999
2739           ENDIF
2740   180     CONTINUE
2741           PF=1.
2742           IF (JETRAD) THEN
2743 C---JETS DID RADIATE
2744             IF (EMS.GE.ECM) THEN
2745               FROST=.TRUE.
2746               GOTO 240
2747             ENDIF
2748             DO 200 NE=1,NETRY
2749             EMS=-ECM
2750             DMS=0.
2751             DO 190 KP=LP,NP
2752             ES=SQRT(PF*PJ(KP)+PM(KP))
2753             EMS=EMS+ES
2754   190       DMS=DMS+PJ(KP)/ES
2755             DPF=2.*EMS/DMS
2756             IF (DPF.GT.PF) DPF=0.9*PF
2757             PF=PF-DPF
2758   200       IF (ABS(DPF).LT.EPS) GOTO 210
2759             CALL HWWARN('HWBJCO',105)
2760             GOTO 999
2761           ENDIF
2762   210     CONTINUE
2763         ENDIF
2764 C---BOOST PC AND PQ TO BREIT FRAME IF NECESSARY
2765         IF (DISPRO.AND.BREIT) THEN
2766           CALL HWULOF(PBR,PC,PC)
2767           CALL HWUROF(RBR,PC,PC)
2768           IF (.NOT.DISLOW) THEN
2769             CALL HWULOF(PBR,PQ,PQ)
2770             CALL HWUROF(RBR,PQ,PQ)
2771           ENDIF
2772         ENDIF
2773         DO 230 IP=LP,NP
2774 C---FIND CM ROTATION FOR JET IP
2775         IF (.NOT.DISLOW) THEN
2776           CALL HWVEQU(4,PHEP(1,IPAR(IP)),PR)
2777           IF (DISPRO.AND.BREIT) THEN
2778             CALL HWULOF(PBR,PR,PR)
2779             CALL HWUROF(RBR,PR,PR)
2780           ENDIF
2781 C--Modified by MHS 17/08/05 to do unboost in 2 stages (trans,long)
2782           PA(1)=PQ(1)
2783           PA(2)=PQ(2)
2784           PA(3)=ZERO
2785           PA(5)=SQRT(PQ(3)**2+PQ(5)**2)
2786           PA(4)=PQ(4)
2787           CALL HWULOF(PA,PR,PR)
2788           PA(1)=ZERO
2789           PA(2)=ZERO
2790           PA(3)=PQ(3)
2791           PA(4)=PA(5)
2792           PA(5)=PQ(5)
2793           CALL HWULOF(PA,PR,PR)
2794 C--End mod
2795           CALL HWUROT(PR, ONE,ZERO,RR)
2796           PR(1)=ZERO
2797           PR(2)=ZERO
2798           PR(3)=SQRT(PF*PJ(IP))
2799           PR(4)=SQRT(PF*PJ(IP)+PM(IP))
2800           PR(5)=PHEP(5,IJET(IP))
2801           CALL HWUROB(RR,PR,PR)
2802 C--Modified by BRW 25/10/02 to do boost in 2 stages (long,trans)
2803           PA(1)=ZERO
2804           PA(2)=ZERO
2805           PA(3)=PC(3)
2806           PA(5)=PC(5)
2807           PA(4)=SQRT(PA(3)**2+PA(5)**2)
2808           CALL HWULOB(PA,PR,PR)
2809           PA(1)=PC(1)
2810           PA(2)=PC(2)
2811           PA(3)=ZERO
2812           PA(5)=PA(4)
2813           PA(4)=PC(4)
2814           CALL HWULOB(PA,PR,PR)
2815 C--End mod
2816         ELSE
2817           CALL HWVEQU(5,PC,PR)
2818         ENDIF
2819 C---NOW PR IS LAB/BREIT MOMENTUM OF JET IP
2820         KP=IJET(IP)+1
2821         IF (AZCOR.AND.KP.LE.NHEP.AND.IDHW(KP).EQ.17) THEN
2822 C---ALIGN CONE WITH INTERFERING PARTON
2823           CALL HWUROT(PR, ONE,ZERO,RS)
2824           JP=JMOHEP(2,KP)
2825           IF (JP.EQ.0) THEN
2826             CALL HWWARN('HWBJCO',2)
2827             PTINF=0.
2828           ELSE
2829             CALL HWVEQU(4,PHEP(1,JP),PS)
2830             IF (DISPRO.AND.BREIT) THEN
2831               CALL HWULOF(PBR,PS,PS)
2832               CALL HWUROF(RBR,PS,PS)
2833             ENDIF
2834             CALL HWUROF(RS,PS,PS)
2835             PTINF=PS(1)**2+PS(2)**2
2836             IF (PTINF.LT.EPS) THEN
2837 C---COLLINEAR JETS: ALIGN CONES
2838               JP=JDAHEP(1,JP)+1
2839 C---BUG FIX BY MHS 17/03/05: RETURNED TO VERSION 6.500!
2840               IF (ISTHEP(JP).EQ.100.AND.ISTHEP(JP-1).GE.141
2841      $                             .AND.ISTHEP(JP-1).LE.144) THEN
2842 C---END FIX
2843                 CALL HWVEQU(4,PHEP(1,JP),PS)
2844                 IF (DISPRO.AND.BREIT) THEN
2845                   CALL HWULOF(PBR,PS,PS)
2846                   CALL HWUROF(RBR,PS,PS)
2847                 ENDIF
2848                 CALL HWUROF(RS,PS,PS)
2849                 PTINF=PS(1)**2+PS(2)**2
2850               ELSE
2851                 PTINF=0.
2852               ENDIF
2853             ENDIF
2854           ENDIF
2855           CALL HWVEQU(4,PHEP(1,KP),PB)
2856           IF (DISPRO.AND.BREIT) THEN
2857             CALL HWULOF(PBR,PB,PB)
2858             CALL HWUROF(RBR,PB,PB)
2859           ENDIF
2860           PTCON=PB(1)**2+PB(2)**2
2861           IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
2862             CN=1./SQRT(PTINF*PTCON)
2863             CP=CN*(PS(1)*PB(1)+PS(2)*PB(2))
2864             SP=CN*(PS(1)*PB(2)-PS(2)*PB(1))
2865           ELSE
2866             CALL HWRAZM( ONE,CP,SP)
2867           ENDIF
2868         ELSE
2869           CALL HWRAZM( ONE,CP,SP)
2870         ENDIF
2871         CALL HWUROT(PR,CP,SP,RS)
2872 C---FIND BOOST FOR JET IP
2873         ALF=(PHEP(3,IJET(IP))+PHEP(4,IJET(IP)))/
2874      &      (PR(4)+SQRT((PR(4)+PR(5))*(PR(4)-PR(5))))
2875         PB(1)=0.
2876         PB(2)=0.
2877         PB(3)=ALF-(1./ALF)
2878         PB(4)=ALF+(1./ALF)
2879         PB(5)=2.
2880         IHEP=IJET(IP)
2881         KHEP=JDAHEP(2,IHEP)
2882         IF (KHEP.LT.IHEP) KHEP=IHEP
2883         DO 220 JHEP=IHEP,KHEP
2884         CALL HWULOF(PB,PHEP(1,JHEP),PHEP(1,JHEP))
2885         CALL HWUROB(RS,PHEP(1,JHEP),PHEP(1,JHEP))
2886         CALL HWULF4(PB,VHEP(1,JHEP),VHEP(1,JHEP))
2887         CALL HWUROB(RS,VHEP(1,JHEP),VHEP(1,JHEP))
2888 C---BOOST FROM BREIT FRAME IF NECESSARY
2889         IF (DISPRO.AND.BREIT) THEN
2890           CALL HWUROB(RBR,PHEP(1,JHEP),PHEP(1,JHEP))
2891           CALL HWULOB(PBR,PHEP(1,JHEP),PHEP(1,JHEP))
2892           CALL HWUROB(RBR,VHEP(1,JHEP),VHEP(1,JHEP))
2893           CALL HWULB4(PBR,VHEP(1,JHEP),VHEP(1,JHEP))
2894         ENDIF
2895         CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,IPAR(IP)),VHEP(1,JHEP))
2896 C--MHS FIX 07/03/05 FOR VERTEX POSITION OF LONG LIVED NON-PARTON JETS
2897         IF (KHEP.EQ.IHEP.AND.(IDHW(JHEP).GE.121.AND.IDHW(JHEP).LE.132
2898      $       .OR.IDHW(JHEP).EQ.59))
2899      $       CALL HWVSUM(4,VTXPIP,VHEP(1,JHEP),VHEP(1,JHEP))
2900 C--END FIX
2901   220   ISTHEP(JHEP)=ISTHEP(JHEP)+10
2902         IF (KHEP.GT.IHEP+1) THEN
2903           ISTHEP(IHEP+1)=100
2904         ELSEIF (KHEP.EQ.IHEP) THEN
2905 C---NON-PARTON JET
2906           ISTHEP(IHEP)=190
2907         ENDIF
2908   230   CONTINUE
2909         IF (ISTHEP(ICM).EQ.110) ISTHEP(ICM)=120
2910 C---SPECIAL CASE: FOR W/Z DECAY BOOST BACK TO THE LAB FRAME
2911  240    IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
2912           CALL HWULOB(PLAB,PHEP(1,ICM),PHEP(1,ICM))
2913           CALL HWULB4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
2914           DO 260 IP=1,NP
2915             CALL HWULOB(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
2916             CALL HWULB4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
2917             CALL HWULOB(PLAB,PHEP(1,IJET(IP)),PHEP(1,IJET(IP)))
2918 C--MHS FIX 07/03/05 - DO NOT REBOOST PRIMARY VERTEX
2919             IF (ISTHEP(IJET(IP)).EQ.190)
2920      $           CALL HWVDIF(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
2921             CALL HWULB4(PLAB,VHEP(1,IJET(IP)),VHEP(1,IJET(IP)))
2922             IF (ISTHEP(IJET(IP)).EQ.190)
2923      $           CALL HWVSUM(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
2924 C---END FIX
2925             IF (JDAHEP(1,IJET(IP)).GT.0) THEN
2926               IF (JDAHEP(2,IJET(IP)).GT.JDAHEP(1,IJET(IP))) THEN
2927                 CALL HWULOB(PLAB,PHEP(1,IJET(IP)+1),PHEP(1,IJET(IP)+1))
2928                 CALL HWULB4(PLAB,VHEP(1,IJET(IP)+1),VHEP(1,IJET(IP)+1))
2929               ENDIF
2930               DO 250 IHEP=JDAHEP(1,IJET(IP)),JDAHEP(2,IJET(IP))
2931                 CALL HWULOB(PLAB,PHEP(1,IHEP),PHEP(1,IHEP))
2932                 CALL HWULB4(PLAB,VHEP(1,IHEP),VHEP(1,IHEP))
2933  250          CONTINUE
2934             ENDIF
2935  260      CONTINUE
2936         ENDIF
2937         IF (FROST) RETURN
2938       ENDIF
2939       GOTO 20
2940  999  RETURN
2941       END
2942 CDECK  ID>, HWBMAS.
2943 *CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
2944 *-- Author :    Bryan Webber
2945 C-----------------------------------------------------------------------
2946       SUBROUTINE HWBMAS
2947 C-----------------------------------------------------------------------
2948 C     Passes  backwards through a  jet cascade  calculating the masses
2949 C     and magnitudes of the longitudinal and transverse three momenta.
2950 C     Components given relative to direction of parent for a time-like
2951 C     vertex and with respect to z-axis for space-like vertices.
2952 C
2953 C     On input PPAR(1-5,*) contains:
2954 C     (E*sqrt(Xi),Xi,3-mom (if external),E,M-sq (if external))
2955 C
2956 C     On output PPAR(1-5,*) (if TMPAR(*)), containts:
2957 C     (P-trans,Xi or Xilast,P-long,E,M)
2958 C-----------------------------------------------------------------------
2959       INCLUDE 'herwig65.inc'
2960       DOUBLE PRECISION HWUSQR,EXI,PISQ,PJPK,EJEK,PTSQ,Z,ZMIN,ZMAX,
2961      $     EMI,EMJ,EMK,C,NQ,HWBVMC,RHO,POLD,PNEW,EOLD,ENEW,A,B
2962       INTEGER IPAR,JPAR,KPAR,MPAR,I,J,K
2963       EXTERNAL HWUSQR
2964       IF (IERROR.NE.0) RETURN
2965       IF (NPAR.GT.2) THEN
2966         DO 30 MPAR=NPAR-1,3,-2
2967          JPAR=MPAR
2968 C Find parent and partner of this branch
2969          IPAR=JMOPAR(1,JPAR)
2970          KPAR=JPAR+1
2971 C Determine type of branching
2972          IF (TMPAR(IPAR)) THEN
2973 C Time-like branching
2974 C           Compute mass of parent
2975             EXI=PPAR(1,JPAR)*PPAR(1,KPAR)
2976             PPAR(5,IPAR)=PPAR(5,JPAR)+PPAR(5,KPAR)+2.*EXI
2977 C           Compute three momentum of parent
2978             PISQ=PPAR(4,IPAR)*PPAR(4,IPAR)-PPAR(5,IPAR)
2979             PPAR(3,IPAR)=HWUSQR(PISQ)
2980 C---SPECIAL FOR G-->QQBAR: READJUST ANGULAR DISTRIBUTION
2981             IF (IDPAR(IPAR).EQ.13 .AND. IDPAR(JPAR).LT.13) THEN
2982               Z=PPAR(4,JPAR)/PPAR(4,IPAR)
2983               ZMIN=HWBVMC(IDPAR(JPAR))/PPAR(1,JPAR)*Z
2984               RHO=(Z*(3-Z*(3-2*Z))-ZMIN*(3-ZMIN*(3-2*ZMIN)))
2985      $             /(2*(1-2*ZMIN)*(1-ZMIN*(1-ZMIN)))
2986               NQ=PPAR(3,IPAR)*(PPAR(3,IPAR)+PPAR(4,IPAR))
2987               EMI=PPAR(5,IPAR)
2988               EMJ=PPAR(5,JPAR)
2989               EMK=PPAR(5,KPAR)
2990               ZMIN=MAX((EMI+EMJ-EMK)/(2*(EMI+NQ)),
2991      $      (EMI+EMJ-EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI))
2992               ZMAX=1-MAX((EMI-EMJ+EMK)/(2*(EMI+NQ)),
2993      $      (EMI-EMJ+EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI))
2994               C=2*RMASS(IDPAR(JPAR))**2/EMI
2995               Z=(4*ZMIN*(1.5*(1+C-ZMIN)+ZMIN**2)*(1-RHO)
2996      $          +4*ZMAX*(1.5*(1+C-ZMAX)+ZMAX**2)*RHO-2-3*C)/(1+2*C)**1.5
2997               Z=SQRT(1+2*C)*SINH(LOG(Z+SQRT(Z**2+1))/3)+0.5
2998               Z=(Z*NQ+(EMI+EMJ-EMK)/2)/(NQ+EMI)
2999               PPAR(4,JPAR)=Z*PPAR(4,IPAR)
3000               PPAR(4,KPAR)=PPAR(4,IPAR)-PPAR(4,JPAR)
3001               PPAR(3,JPAR)=HWUSQR(PPAR(4,JPAR)**2-EMJ)
3002               PPAR(3,KPAR)=HWUSQR(PPAR(4,KPAR)**2-EMK)
3003               PPAR(2,JPAR)=EXI/(PPAR(4,JPAR)*PPAR(4,KPAR))
3004               IF(JDAPAR(2,JPAR).NE.0)PPAR(2,JDAPAR(2,JPAR))=PPAR(2,JPAR)
3005               IF(JDAPAR(2,KPAR).NE.0)PPAR(2,JDAPAR(2,KPAR))=PPAR(2,JPAR)
3006 C---FIND DESCENDENTS OF THIS SPLITTING AND READJUST THEIR MOMENTA TOO
3007               DO 20 J=JPAR+2,NPAR-1,2
3008                 I=J
3009  10             I=JMOPAR(1,I)
3010                 IF (I.GT.IPAR) GOTO 10
3011                 IF (I.EQ.IPAR) THEN
3012                   I=JMOPAR(1,J)
3013                   K=J+1
3014                   POLD=PPAR(3,J)+PPAR(3,K)
3015                   EOLD=PPAR(4,J)+PPAR(4,K)
3016                   PNEW=HWUSQR(PPAR(4,I)**2-PPAR(5,I))
3017                   ENEW=PPAR(4,I)
3018                   A=(ENEW*EOLD-PNEW*POLD)/PPAR(5,I)
3019                   B=(PNEW*EOLD-ENEW*POLD)/PPAR(5,I)
3020                   PPAR(3,J)=A*PPAR(3,J)+B*PPAR(4,J)
3021                   PPAR(4,J)=(PPAR(4,J)+B*PPAR(3,J))/A
3022                   PPAR(3,K)=PNEW-PPAR(3,J)
3023                   PPAR(4,K)=ENEW-PPAR(4,J)
3024                   PPAR(2,J)=1-(PPAR(3,J)*PPAR(3,K)+PPAR(1,J)*PPAR(1,K))
3025      $                 /(PPAR(4,J)*PPAR(4,K))
3026                   IF (JDAPAR(2,J).NE.0) PPAR(2,JDAPAR(2,J))=PPAR(2,J)
3027                   IF (JDAPAR(2,K).NE.0) PPAR(2,JDAPAR(2,K))=PPAR(2,J)
3028                 ENDIF
3029  20           CONTINUE
3030             ENDIF
3031 C           Compute daughter' transverse and longitudinal momenta
3032             PJPK=PPAR(3,JPAR)*PPAR(3,KPAR)
3033             EJEK=PPAR(4,JPAR)*PPAR(4,KPAR)-EXI
3034             PTSQ=(PJPK+EJEK)*(PJPK-EJEK)/PISQ
3035             PPAR(1,JPAR)=HWUSQR(PTSQ)
3036             PPAR(3,JPAR)=HWUSQR(PPAR(3,JPAR)*PPAR(3,JPAR)-PTSQ)
3037             PPAR(1,KPAR)=-PPAR(1,JPAR)
3038             PPAR(3,KPAR)= PPAR(3,IPAR)-PPAR(3,JPAR)
3039          ELSE
3040 C Space-like branching
3041 C           Re-arrange such that JPAR is time-like
3042             IF (TMPAR(KPAR)) THEN
3043                KPAR=JPAR
3044                JPAR=JPAR+1
3045             ENDIF
3046 C           Compute time-like branch
3047             PTSQ=(2.-PPAR(2,JPAR))*PPAR(1,JPAR)*PPAR(1,JPAR)
3048      &          -PPAR(5,JPAR)
3049             PPAR(1,JPAR)=HWUSQR(PTSQ)
3050             PPAR(3,JPAR)=(1.-PPAR(2,JPAR))*PPAR(4,JPAR)
3051             PPAR(3,IPAR)=PPAR(3,KPAR)-PPAR(3,JPAR)
3052             PPAR(5,IPAR)=0.
3053             PPAR(1,KPAR)=0.
3054          ENDIF
3055 C Reset Xi to Xilast
3056          PPAR(2,KPAR)=PPAR(2,IPAR)
3057  30    CONTINUE
3058       ENDIF
3059       DO 40 IPAR=2,NPAR
3060  40   PPAR(5,IPAR)=HWUSQR(PPAR(5,IPAR))
3061       PPAR(1,2)=0.
3062       PPAR(2,2)=0.
3063       END
3064 CDECK  ID>, HWBRAN.
3065 *CMZ :-        -14/10/99  18.04.56  by  Mike Seymour
3066 *-- Author :    Bryan Webber & Mike Seymour
3067 C-----------------------------------------------------------------------
3068       SUBROUTINE HWBRAN(KPAR)
3069 C-----------------------------------------------------------------------
3070 C     BRANCHES TIMELIKE PARTON KPAR INTO TWO, PUTS PRODUCTS
3071 C     INTO NPAR+1 AND NPAR+2, AND INCREASES NPAR BY TWO
3072 C-----------------------------------------------------------------------
3073       INCLUDE 'herwig65.inc'
3074       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,PMOM,
3075      & QNOW,QLST,QKTHR,RN,QQBAR,DQQ,QGTHR,SNOW,QSUD,ZMIN,ZMAX,ZRAT,WMIN,
3076      & QLAM,Z1,Z2,ETEST,ZTEST,ENOW,XI,XIPREV,EPREV,QMAX,QGAM,SLST,SFNL,
3077      & TARG,ALF,BETA0(3:6),BETAP(3:6),SQRK(4:6,5),REJFAC,Z,X1,X2,OTHXI,
3078      & OTHZ,X3,FF,AW,XCUT,CC,JJ,HWUSQR
3079       INTEGER HWRINT,KPAR,ID,JD,IS,NTRY,N,ID1,ID2,MPAR,ISUD(13),IHEP,
3080      & JHEP,M,NF,NN,IREJ,NREJ,ITOP
3081       EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,HWRINT,HWUSQR
3082       SAVE BETA0,BETAP,SQRK
3083       SAVE ISUD
3084       DATA ISUD,BETA0/2,2,3,4,5,6,2,2,3,4,5,6,1,4*ZERO/
3085       IF (IERROR.NE.0) RETURN
3086 C---SET SQRK(M,N) TO THE PROBABILITY THAT A GLUON WILL NOT PRODUCE A
3087 C   QUARK-ANTIQUARK PAIR BETWEEN SCALES RMASS(M) AND 2*HWBVMC(N)
3088       IF (SUDORD.NE.1.AND.BETA0(3).EQ.ZERO) THEN
3089         DO 100 M=3,6
3090           BETA0(M)=(11.*CAFAC-2.*M)*0.5
3091  100      BETAP(M)=(17.*CAFAC**2-(5.*CAFAC+3.*CFFAC)*M)
3092      &            /BETA0(M)*0.25/PIFAC
3093         DO 120 N=1,5
3094           DO 110 M=4,6
3095             IF (M.LE.N) THEN
3096               SQRK(M,N)=ONE
3097             ELSEIF (M.EQ.4.OR.M.EQ.N+1) THEN
3098               NF=M
3099               IF (2*HWBVMC(N).GT.RMASS(M)) NF=M+1
3100               SQRK(M,N)=((BETAP(NF-1)+1/HWUALF(1,2*HWBVMC(N)))/
3101      $             (BETAP(NF-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(NF-1))
3102             ELSE
3103               SQRK(M,N)=SQRK(M-1,N)*
3104      $             ((BETAP(M-1)+1/HWUALF(1,RMASS(M-1)))/
3105      $             (BETAP(M-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(M-1))
3106             ENDIF
3107  110      CONTINUE
3108  120    CONTINUE
3109       ENDIF
3110       ID=IDPAR(KPAR)
3111 C--TEST FOR PARTON TYPE
3112       IF (ID.LE.13) THEN
3113         JD=ID
3114         IS=ISUD(ID)
3115       ELSEIF (ID.GE.209.AND.ID.LE.220) THEN
3116         JD=ID-208
3117         IS=7
3118       ELSE
3119         IS=0
3120       END IF
3121       QNOW=-1.
3122       IF (IS.NE.0) THEN
3123 C--TIMELIKE PARTON BRANCHING
3124         ENOW=PPAR(4,KPAR)
3125         XIPREV=PPAR(2,KPAR)
3126         IF (JMOPAR(1,KPAR).EQ.0) THEN
3127           EPREV=PPAR(4,KPAR)
3128         ELSE
3129           EPREV=PPAR(4,JMOPAR(1,KPAR))
3130         ENDIF
3131 C--IF THIS IS CHARGED & PHOTONS ARE ALLOWED, ANGLES MIGHT NOT BE ORDERED
3132         QMAX=0
3133         QLST=PPAR(1,KPAR)
3134         IF (ICHRG(ID).NE.0 .AND. VPCUT.LT.PPAR(1,2)) THEN
3135 C--LOOK FOR A PREVIOUS G->QQBAR, IF ANY
3136           MPAR=KPAR
3137  1        IF (JMOPAR(1,MPAR).NE.0) THEN
3138             IF (IDPAR(JMOPAR(1,MPAR)).EQ.ID) THEN
3139               MPAR=JMOPAR(1,MPAR)
3140               GOTO 1
3141             ENDIF
3142           ENDIF
3143 C--IF CLIMBED TO THE TOP OF THE LIST, FIND QED INTERFERENCE PARTNER
3144           IF (MPAR.EQ.2) THEN
3145             JHEP=0
3146             IF (ID.LT.7) THEN
3147               IHEP=JDAHEP(2,JCOPAR(1,1))
3148               IF (IHEP.GT.0) JHEP=JDAHEP(2,IHEP)
3149             ELSE
3150               IHEP=JMOHEP(2,JCOPAR(1,1))
3151               IF (IHEP.GT.0) JHEP=JMOHEP(2,IHEP)
3152             ENDIF
3153             IF (IHEP.GT.0.AND.JHEP.GT.0) THEN
3154                QMAX=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
3155      &              *(ENOW/PPAR(4,2))**2
3156             ELSE
3157 C--FIX AT HARD PROCESS SCALE IF POINTER NOT YET SET
3158 C  (CAN HAPPEN IN SUSY EVENTS)
3159                QMAX=EMSCA**2
3160             ENDIF
3161           ELSE
3162             QMAX=ENOW**2*PPAR(2,MPAR)
3163           ENDIF
3164 C--IF PREVIOUS BRANCHING WAS Q->QGAMMA, LOOK FOR A QCD BRANCHING
3165           MPAR=KPAR
3166  2        IF (JMOPAR(1,MPAR).NE.0) THEN
3167             IF (IDPAR(JDAPAR(1,JMOPAR(1,MPAR))).EQ.59 .OR.
3168      &        IDPAR(JDAPAR(2,JMOPAR(1,MPAR))).EQ.59) THEN
3169               MPAR=JMOPAR(1,MPAR)
3170               GOTO 2
3171             ENDIF
3172           ENDIF
3173           QLST=ENOW**2*PPAR(2,MPAR)
3174           QMAX=SQRT(MAX(ZERO,MIN(
3175      &         QMAX , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV))))
3176           QLST=SQRT(MIN(
3177      &         QLST , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV)))
3178         ENDIF
3179         NTRY=0
3180     5   NTRY=NTRY+1
3181         IF (NTRY.GT.NBTRY) THEN
3182           CALL HWWARN('HWBRAN',100)
3183           GOTO 999
3184         ENDIF
3185         IF (ID.EQ.13) THEN
3186 C--GLUON -> QUARK+ANTIQUARK OPTION
3187           IF (QLST.GT.QCDL3) THEN
3188             DO 8 N=1,NFLAV
3189             QKTHR=2.*HWBVMC(N)
3190             IF (QLST.GT.QKTHR) THEN
3191               RN=HWRGEN(N)
3192               IF (SUDORD.NE.1) THEN
3193 C---FIND IN WHICH FLAVOUR INTERVAL THE UPPER LIMIT LIES
3194                 NF=3
3195                 DO 200 M=MAX(3,N),NFLAV
3196  200              IF (QLST.GT.RMASS(M)) NF=M
3197 C---CALCULATE THE FORM FACTOR
3198                 IF (NF.EQ.MAX(3,N)) THEN
3199                   SFNL=((BETAP(NF)+1/HWUALF(1,QKTHR))/
3200      $                 (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
3201                   SLST=SFNL
3202                 ELSE
3203                   SFNL=((BETAP(NF)+1/HWUALF(1,RMASS(NF)))/
3204      $                 (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
3205                   SLST=SFNL*SQRK(NF,N)
3206                 ENDIF
3207               ENDIF
3208               IF (RN.GT.1.E-3) THEN
3209                 QQBAR=QCDL3*(QLST/QCDL3)**(RN**BETAF)
3210               ELSE
3211                 QQBAR=QCDL3
3212               ENDIF
3213               IF (SUDORD.NE.1) THEN
3214 C---FIND IN WHICH FLAVOUR INTERVAL THE SOLUTION LIES
3215                 IF (RN.GE.SFNL) THEN
3216                   NN=NF
3217                 ELSEIF (RN.GE.SLST) THEN
3218                   NN=MAX(3,N)
3219                   DO 210 M=MAX(3,N)+1,NF-1
3220  210                IF (RN.GE.SLST/SQRK(M,N)) NN=M
3221                 ELSE
3222                   NN=0
3223                   QQBAR=QCDL3
3224                 ENDIF
3225                 IF (NN.GT.0) THEN
3226                   IF (NN.EQ.NF) THEN
3227                     TARG=HWUALF(1,QLST)
3228                   ELSE
3229                     TARG=HWUALF(1,RMASS(NN+1))
3230                     RN=RN/SLST*SQRK(NN+1,N)
3231                   ENDIF
3232                   TARG=1/((BETAP(NN)+1/TARG)*RN**BETA0(NN)-BETAP(NN))
3233 C---NOW SOLVE HWUALF(1,QQBAR)=TARG FOR QQBAR ITERATIVELY
3234  7                QQBAR=MAX(QQBAR,HALF*QKTHR)
3235                   ALF=HWUALF(1,QQBAR)
3236                   IF (ABS(ALF-TARG).GT.ACCUR) THEN
3237                     NTRY=NTRY+1
3238                     IF (NTRY.GT.NBTRY) THEN
3239                       CALL HWWARN('HWBRAN',101)
3240                       GOTO 999
3241                     ENDIF
3242                     QQBAR=QQBAR*(1+3*PIFAC*(ALF-TARG)
3243      $                   /(BETA0(NN)*ALF**2*(1+BETAP(NN)*ALF)))
3244                     GOTO 7
3245                   ENDIF
3246                 ENDIF
3247               ENDIF
3248               IF (QQBAR.GT.QNOW.AND.QQBAR.GT.QKTHR) THEN
3249                 QNOW=QQBAR
3250                 ID2=N
3251               ENDIF
3252             ELSE
3253               GOTO 9
3254             ENDIF
3255     8       CONTINUE
3256           ENDIF
3257 C--GLUON->DIQUARKS OPTION
3258     9     IF (QLST.LT.QDIQK) THEN
3259             IF (PDIQK.NE.ZERO) THEN
3260               RN=HWRGEN(0)
3261               DQQ=QLST*EXP(-RN/PDIQK)
3262               IF (DQQ.GT.QNOW) THEN
3263                 IF (DQQ.GT.2.*RMASS(115)) THEN
3264                   QNOW=DQQ
3265                   ID2=115
3266                 ENDIF
3267               ENDIF
3268             ENDIF
3269           ENDIF
3270         ENDIF
3271 C--ENHANCE GLUON AND PHOTON EMISSION BY A FACTOR OF TWO IF THIS BRANCH
3272 C  IS CAPABLE OF BEING THE HARDEST SO FAR
3273         NREJ=1
3274         IF (TMPAR(2).AND.0.25*MAX(QLST,QMAX).GT.HARDST) NREJ=2
3275 C--BRANCHING ID->ID+GLUON
3276         QGTHR=HWBVMC(ID)+HWBVMC(13)
3277         IF (QLST.GT.QGTHR) THEN
3278          DO 300 IREJ=1,NREJ
3279           RN=HWRGEN(1)
3280           SLST=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,INTER)
3281           IF (RN.EQ.ZERO) THEN
3282             SNOW=2.
3283           ELSE
3284             SNOW=SLST/RN
3285           ENDIF
3286           IF (SNOW.LT.ONE) THEN
3287             QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,INTER)
3288 C---IF FORM FACTOR DID NOT GET INVERTED CORRECTLY TRY LINEAR INSTEAD
3289             IF (QSUD.GT.QLST) THEN
3290               SNOW=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,1)/RN
3291               QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,1)
3292               IF (QSUD.GT.QLST) THEN
3293                 CALL HWWARN('HWBRAN',1)
3294                 QSUD=-1
3295               ENDIF
3296             ENDIF
3297             IF (QSUD.GT.QGTHR.AND.QSUD.GT.QNOW) THEN
3298               ID2=13
3299               QNOW=QSUD
3300             ENDIF
3301           ENDIF
3302  300     CONTINUE
3303         ENDIF
3304 C--BRANCHING ID->ID+PHOTON
3305         IF (ICHRG(ID).NE.0) THEN
3306           QGTHR=MAX(HWBVMC(ID)+HWBVMC(59),HWBVMC(59)*EXP(0.75))
3307           IF (QMAX.GT.QGTHR) THEN
3308            DO 400 IREJ=1,NREJ
3309             RN=HWRGEN(2)
3310             IF (RN.EQ.ZERO) THEN
3311               QGAM=0
3312             ELSE
3313               QGAM=(LOG(QMAX/HWBVMC(59))-0.75)**2
3314      &            +PIFAC*9/(ICHRG(ID)**2*ALPFAC*ALPHEM)*LOG(RN)
3315               IF (QGAM.GT.ZERO) THEN
3316                 QGAM=HWBVMC(59)*EXP(0.75+SQRT(QGAM))
3317               ELSE
3318                 QGAM=0
3319               ENDIF
3320             ENDIF
3321             IF (QGAM.GT.QGTHR.AND.QGAM.GT.QNOW) THEN
3322               ID2=59
3323               QNOW=QGAM
3324             ENDIF
3325  400       CONTINUE
3326           ENDIF
3327         ENDIF
3328         IF (QNOW.GT.ZERO) THEN
3329 C--BRANCHING HAS OCCURRED
3330           ZMIN=HWBVMC(ID2)/QNOW
3331           ZMAX=1.-ZMIN
3332           IF (ID.EQ.13) THEN
3333             IF (ID2.EQ.13) THEN
3334 C--GLUON -> GLUON + GLUON
3335               ID1=13
3336               WMIN=ZMIN*ZMAX
3337               ETEST=(1.-WMIN)**2*HWUALF(5-SUDORD*2,QNOW*WMIN)
3338               ZRAT=(ZMAX*(1-ZMIN))/(ZMIN*(1-ZMAX))
3339 C--CHOOSE Z1 DISTRIBUTED ON (ZMIN,ZMAX)
3340 C  ACCORDING TO GLUON BRANCHING FUNCTION
3341    10         Z1=ZMAX/(ZMAX+(1-ZMAX)*ZRAT**HWRGEN(0))
3342               Z2=1.-Z1
3343               ZTEST=(1.-(Z1*Z2))**2*HWUALF(5-SUDORD*2,QNOW*(Z1*Z2))
3344               IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 10
3345               Z=Z1
3346             ELSEIF (ID2.NE.115) THEN
3347 C--GLUON -> QUARKS
3348               ID1=ID2+6
3349               ETEST=ZMIN**2+ZMAX**2
3350    20         Z1=HWRUNI(0,ZMIN,ZMAX)
3351               Z2=1.-Z1
3352               ZTEST=Z1*Z1+Z2*Z2
3353               IF (ZTEST.LT.ETEST*HWRGEN(0)) GOTO 20
3354             ELSE
3355 C--GLUON -> DIQUARKS
3356               ID2=HWRINT(115,117)
3357               ID1=ID2-6
3358               Z1=HWRUNI(0,ZMIN,ZMAX)
3359               Z2=1.-Z1
3360             ENDIF
3361           ELSE
3362 C--QUARK OR ANTIQUARK BRANCHING
3363             IF (ID2.EQ.13) THEN
3364 C--TO GLUON
3365               ZMAX=1.-HWBVMC(ID)/QNOW
3366               WMIN=MIN(ZMIN*(1.-ZMIN),ZMAX*(1.-ZMAX))
3367               ETEST=(1.+ZMAX**2)*HWUALF(5-SUDORD*2,QNOW*WMIN)
3368               ZRAT=ZMAX/ZMIN
3369    30         Z1=ZMIN*ZRAT**HWRGEN(0)
3370               Z2=1.-Z1
3371               ZTEST=(1.+Z2*Z2)*HWUALF(5-SUDORD*2,QNOW*Z1*Z2)
3372               IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 30
3373             ELSE
3374 C--TO PHOTON
3375               ZMIN=  HWBVMC(59)/QNOW
3376               ZMAX=1-HWBVMC(ID)/QNOW
3377               ZRAT=ZMAX/ZMIN
3378               ETEST=1+(1-ZMIN)**2
3379    40         Z1=ZMIN*ZRAT**HWRGEN(0)
3380               Z2=1-Z1
3381               ZTEST=1+Z2*Z2
3382               IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 40
3383             ENDIF
3384 C--QUARKS EMIT ON LOWER SIDE, ANTIQUARKS ON UPPER SIDE
3385             Z=Z1
3386             IF (JD.LE.6) THEN
3387               Z1=Z2
3388               Z2=1.-Z2
3389               ID1=ID
3390             ELSE
3391               ID1=ID2
3392               ID2=ID
3393             ENDIF
3394           ENDIF
3395 C--UPDATE THIS BRANCH AND CREATE NEW BRANCHES
3396           XI=(QNOW/ENOW)**2
3397           IF (ID1.NE.59.AND.ID2.NE.59) THEN
3398             IF (ID.EQ.13.AND.ID1.NE.13) THEN
3399               QLAM=QNOW
3400             ELSE
3401               QLAM=QNOW*Z1*Z2
3402             ENDIF
3403             IF (SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
3404      &           (2.-XI)*(QNOW*Z1*Z2)**2.GT.EMSCA**2) THEN
3405 C--BRANCHING REJECTED: REDUCE Q AND REPEAT
3406                 QMAX=QNOW
3407                 QLST=QNOW
3408                 QNOW=-1.
3409                 GOTO 5
3410             ENDIF
3411           ENDIF
3412 C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
3413           IF (ID.NE.13.OR.ID1.EQ.13) THEN
3414             QLAM=QNOW*Z1*Z2
3415             REJFAC=1
3416             IF (TMPAR(2).AND.QLAM.GT.HARDST) THEN
3417 C----SOFT MATRIX-ELEMENT CORRECTION TO TOP DECAYS
3418               ITOP=JCOPAR(1,1)
3419               IF (ISTHEP(ITOP).EQ.155.AND.(IDHW(ITOP).EQ.6
3420      $             .OR.IDHW(ITOP).EQ.12)) THEN
3421                 AW=(PHEP(5,JDAHEP(1,ITOP))/PHEP(5,ITOP))**2
3422                 FF=0.5*(1-AW)*(1-2*AW+1/AW)
3423                 CC=0.25*(1-AW)**2
3424                 X1=1-2*CC*Z*(1-Z)*XI
3425                 X3=0.5*(1-AW+2*CC*Z*(1-Z)*XI-(1-2*Z)
3426      &               *HWUSQR(((1+AW-2*CC*Z*(1-Z)*XI)**2-4*AW)
3427      &               /(1-2*Z*(1-Z)*XI)))
3428 C-----JACOBIAN FACTOR
3429                 JJ=(1-X1)*(2-AW-X1-2*X3)*(1-2*Z*(1-Z)*XI)/(
3430      $               4*CC**2*((X1+AW)**2-4*AW)*Z**2*(1-Z)**2*(1-2*Z)*XI)
3431 C-----REJECTION FACTOR
3432                 XCUT=2*GCUTME/PHEP(5,ITOP)
3433                 IF (X3.GT.XCUT) REJFAC=FF*JJ
3434      &               *X3**2*(1-X1)*(1+(1-Z)**2)/(Z*XI)
3435      &               /((1+1/AW-2*AW)*((1-AW)*X3-(1-X1)
3436      &               *(1-X3)-X3**2)+(1+1/(2*AW))*X3*(X1+X3-1)**2
3437      &               +2*X3**2*(1-X1))
3438               ELSEIF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
3439 C---COLOUR PARTNER IS ALSO OUTGOING
3440                 X1=1-Z*(1-Z)*XI
3441                 X2=0.5*(1+Z*(1-Z)*XI +
3442      $               (1-Z*(1-Z)*XI)*(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
3443                 REJFAC=SQRT(2*X1-1)/(X1*Z*(1-Z))
3444      $               *(1+(1-Z)**2)/(Z*XI)
3445      $               *(1-X1)*(1-X2)/(X1**2+X2**2)
3446 C---CHECK WHETHER IT IS IN THE OVERLAP REGION
3447                 OTHXI=4*(1-X2)*X2**2/(X2**2-(2*X2-1)*(2*X1+X2-2)**2)
3448                 IF (OTHXI.LT.ONE) THEN
3449                   OTHZ=0.5*(1-SQRT(2*X2-1)/X2*(2*X1+X2-2))
3450                   REJFAC=REJFAC+SQRT(2*X2-1)/(X2*OTHZ*(1-OTHZ))
3451      $                 *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
3452      $                 *(1-X2)*(1-X1)/(X2**2+X1**2)
3453                 ENDIF
3454               ELSE
3455 C---COLOUR PARTNER IS INCOMING (X1=XP, X2=ZP)
3456                 X1=1/(1+Z*(1-Z)*XI)
3457                 X2=0.5*(1+(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
3458                 REJFAC=SQRT(3-2/X1)/(X1**2*Z*(1-Z))
3459      $               *(1+(1-Z)**2)/(Z*XI)
3460      $               *(1-X1)*(1-X2)/
3461      $               (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
3462 C---CHECK WHETHER IT IS IN THE OVERLAP REGION
3463                 OTHXI=(SQRT(X1+2*(1-X2)*(1-X2+X1*X2))-SQRT(X1))**2/
3464      $               (1+X1-X2-SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2))))
3465                 OTHZ=(SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2)))-X1)/(1-X2)
3466                 IF (OTHXI.LT.OTHZ**2) THEN
3467                   REJFAC=REJFAC+OTHZ**3*(1-X1-X2+2*X1*X2)
3468      $                 /(X1**2*(1-OTHZ)*(OTHZ+OTHXI*(1-OTHZ)))
3469      $                 *(1+OTHZ**2)/((1-OTHZ)*OTHXI)
3470      $                 *(1-X1)*(1-X2)/
3471      $                 (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
3472                 ENDIF
3473               ENDIF
3474             ENDIF
3475             IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
3476               QMAX=QNOW
3477               QLST=QNOW
3478               QNOW=-1.
3479               GOTO 5
3480             ENDIF
3481             IF (QLAM.GT.HARDST) HARDST=QLAM
3482           ENDIF
3483           MPAR=NPAR+1
3484           IDPAR(MPAR)=ID1
3485           TMPAR(MPAR)=.TRUE.
3486           PPAR(1,MPAR)=QNOW*Z1
3487           PPAR(2,MPAR)=XI
3488           PPAR(4,MPAR)=ENOW*Z1
3489           NPAR=NPAR+2
3490           IDPAR(NPAR)=ID2
3491           TMPAR(NPAR)=.TRUE.
3492           PPAR(1,NPAR)=QNOW*Z2
3493           PPAR(2,NPAR)=XI
3494           PPAR(4,NPAR)=ENOW*Z2
3495 C---NEW MOTHER-DAUGHTER RELATIONS
3496           JDAPAR(1,KPAR)=MPAR
3497           JDAPAR(2,KPAR)=NPAR
3498           JMOPAR(1,MPAR)=KPAR
3499           JMOPAR(1,NPAR)=KPAR
3500 C---NEW COLOUR CONNECTIONS
3501           JCOPAR(3,KPAR)=NPAR
3502           JCOPAR(4,KPAR)=MPAR
3503           JCOPAR(1,MPAR)=NPAR
3504           JCOPAR(2,MPAR)=KPAR
3505           JCOPAR(1,NPAR)=KPAR
3506           JCOPAR(2,NPAR)=MPAR
3507 C
3508         ENDIF
3509       ENDIF
3510       IF (QNOW.LT.ZERO) THEN
3511 C--BRANCHING STOPS
3512         IF (ID.EQ.IDPAR(2).AND.PPAR(5,2).GT.1D-6) THEN
3513           PPAR(5,KPAR)=PPAR(5,2)**2
3514         ELSE
3515           PPAR(5,KPAR)=RMASS(ID)**2
3516         ENDIF
3517         PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
3518         IF (PMOM.LT.-1E-6) THEN
3519           CALL HWWARN('HWBRAN',104)
3520           GOTO 999
3521         ENDIF
3522         IF (PMOM.LT.ZERO) PMOM=ZERO
3523         PPAR(3,KPAR)=SQRT(PMOM)
3524         JDAPAR(1,KPAR)=0
3525         JDAPAR(2,KPAR)=0
3526         JCOPAR(3,KPAR)=0
3527         JCOPAR(4,KPAR)=0
3528       ENDIF
3529  999  RETURN
3530       END
3531 CDECK  ID>, HWBRCN.
3532 *CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
3533 *-- Author :    Peter Richardson
3534 C-----------------------------------------------------------------------
3535       SUBROUTINE HWBRCN
3536 C-----------------------------------------------------------------------
3537 C     SUBROUTINE TO REPLACE HWBCON IN RPARITY VIOLATING SUSY
3538 C     BASED ON HWBCON BY BRW
3539 C-----------------------------------------------------------------------
3540       INCLUDE 'herwig65.inc'
3541       INTEGER IHEP,IST,ID,JC,JD,JHEP,IDP,IDM,IDM2,
3542      &        RHEP,IST2,ANTC,XHEP,IP,COLP
3543       LOGICAL BVVUSE,BVVHRD,BVDEC1,BVDEC2,COLRD,ACOLRD,BVHRD,BVHRD2,
3544      &        BVDEC3
3545       LOGICAL IFGO
3546 C--logical functions to decide if baryon number violating
3547 C--BVDEC1 DELTAB=+1
3548       BVDEC1(IP) = ((IDHW(IP).GE.419.AND.IDHW(IP).LE.424).OR.
3549      &              IDHW(IP).EQ.411.OR.IDHW(IP).EQ.412.OR.
3550      &              IDHW(IP).EQ.449).AND.IDHW(JDAHEP(1,IP)).LE.6.
3551      &              AND.IDHW(JDAHEP(1,IP)+1).LE.6.AND.
3552      &              IDHW(JDAHEP(2,IP)).LE.6
3553 C--BVDEC2 DELTAB=-1
3554       BVDEC2(IP) = ((IDHW(IP).GE.413.AND.IDHW(IP).LE.418).OR.
3555      &              IDHW(IP).EQ.405.OR.IDHW(IP).EQ.406.OR.
3556      &              IDHW(IP).EQ.449).AND.
3557      &    IDHW(JDAHEP(1,IP)).GE.7.AND.IDHW(JDAHEP(1,IP)).LE.12.AND.
3558      &    IDHW(JDAHEP(1,IP)+1).GE.7.AND.IDHW(JDAHEP(1,IP)+1).LE.12.AND.
3559      &    IDHW(JDAHEP(2,IP)).GE.7.AND.IDHW(JDAHEP(2,IP)).LE.12
3560 C--Neutralino and Chargino Decays
3561       BVDEC3(IP) = ((IDHW(IP).GE.450.AND.IDHW(IP).LE.457).AND.
3562      &   (IDHW(JDAHEP(1,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)+1).LE.12.
3563      &    .AND.IDHW(JDAHEP(2,IP)).LE.12))
3564 C--Now the hard vertices
3565       BVHRD(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
3566      &    AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).LE.12.
3567      &    AND.IDHW(JDAHEP(2,IP)).GE.449.AND.IDHW(JDAHEP(2,IP)).LE.457
3568       BVHRD2(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
3569      &    AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).GE.198.
3570      &    AND.IDHW(JDAHEP(1,IP)).LE.207.
3571      &    AND.ABS(IDHEP(JDAHEP(2,IP))).GT.1000000
3572 C--Those particles which are coloured
3573       COLRD(IP) = IP.LE.6.OR.IP.EQ.13.OR.IP.EQ.449.OR.
3574      &   (IP.GE.401.AND.IP.LE.406).OR.(IP.GE.413.AND.IP.LE.418).OR.
3575      &   (IP.GE.115.AND.IP.LE.120).OR.IP.EQ.59
3576 C--Those particles which are anticoloured
3577       ACOLRD(IP) = (IP.GE.7.AND.IP.LE.12).OR.IP.EQ.13.OR.IP.EQ.449.OR.
3578      & (IP.GE.407.AND.IP.LE.412).OR.(IP.GE.419.AND.IP.LE.424).OR.
3579      & (IP.GE.109.AND.IP.LE.114).OR.IP.EQ.59
3580       IF (IERROR.NE.0) RETURN
3581 C--Added 31/03/00 PR
3582       IF(NHEP.GT.NMXHEP) THEN
3583         CALL HWWARN('HWBRCN',101)
3584         GOTO 999
3585       ENDIF
3586       COLP = 0
3587       IF(COLUPD.AND.HRDCOL(1,3).NE.0) THEN
3588         JD = 0
3589         DO IHEP = HRDCOL(1,3),HRDCOL(1,3)+4
3590           JD = JD+1
3591           IF(JD.NE.3) THEN
3592             JMOHEP(2,IHEP) = HRDCOL(1,JD)
3593             JDAHEP(2,IHEP) = HRDCOL(2,JD)
3594           ENDIF
3595         ENDDO
3596         COLUPD=.FALSE.
3597         DO IHEP=1,5
3598           DO JHEP=1,2
3599             HRDCOL(JHEP,IHEP)=0
3600           ENDDO
3601         ENDDO
3602       ELSEIF(COLUPD) THEN
3603         RETURN
3604       ENDIF
3605       DO 110 IHEP=1,NHEP
3606       IST=ISTHEP(IHEP)
3607       JD =0
3608       BVVUSE = .FALSE.
3609       BVVHRD = .FALSE.
3610 C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
3611       IF ((IST.LT.145.OR.IST.GT.152).AND.IST.NE.155) GOTO 110
3612       IF (JMOHEP(2,IHEP).EQ.0) THEN
3613 C---FIND COLOUR-CONNECTED PARTON
3614         IF(IST.EQ.155.AND.ABS(IDHEP(IHEP)).EQ.6) THEN
3615           JC = JMOHEP(1,IHEP)
3616         ELSEIF(IST.EQ.155) THEN
3617           GOTO 110
3618         ELSE
3619           JC=JMOHEP(1,IHEP)
3620         ENDIF
3621         IF (IST.NE.152) JC=JMOHEP(1,JC)
3622 C--Correction for BV
3623         IF(HRDCOL(1,1).NE.0) THEN
3624           IDP = IDHW(HRDCOL(1,1))
3625         ELSE
3626           IDP  = 0
3627         ENDIF
3628         IDM = JMOHEP(1,JC)
3629         IF(BVDEC1(IDM).OR.BVDEC2(IDM)) THEN
3630           IF(IDHW(IDM).EQ.449.AND.JDAHEP(1,IDM).EQ.JC) THEN
3631             JC=JMOHEP(2,JC)
3632           ELSE
3633             JD = JMOHEP(2,JC)
3634             JC = IDM
3635             IF(JC.EQ.JD) JD= JDAHEP(2,JC-1)
3636             BVVUSE = .TRUE.
3637           ENDIF
3638 C--NEW FOR BV HARD PROCESS
3639         ELSEIF(BVHRD(IDM)) THEN
3640           IF(IDHW(JDAHEP(2,JMOHEP(1,JC))).EQ.449) THEN
3641             JD   = JMOHEP(2,JC)
3642             IDM2 = JDAHEP(2,HRDCOL(1,2))
3643             IF(JD.EQ.IDM2) JD = HRDCOL(1,1)
3644             IF(JC.EQ.JDAHEP(2,IDM2).AND.COLRD(IDHW(IHEP))) THEN
3645               JC = JMOHEP(2,JC)
3646             ELSEIF(JC.EQ.IDM2) THEN
3647               IF(JDAHEP(2,JMOHEP(2,JC)).EQ.JC) THEN
3648                 JC = JMOHEP(2,JC)
3649               ELSE
3650               JMOHEP(2,IHEP)=JMOHEP(2,JC)
3651               GOTO 110
3652               ENDIF
3653             ELSE
3654               JC = HRDCOL(1,1)
3655               BVVUSE = .TRUE.
3656               BVVHRD = .TRUE.
3657               IF(ACOLRD(IDHW(IHEP))) JC = JD
3658               IF(JC.EQ.IDM2) GOTO 110
3659             ENDIF
3660           ELSE
3661             JC =JMOHEP(2,JC)
3662             BVVUSE = .TRUE.
3663             BVVHRD = .TRUE.
3664           ENDIF
3665         ELSEIF(BVHRD2(IDM)) THEN
3666           JD = JMOHEP(2,JC)
3667             IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
3668               JMOHEP(2,IHEP)=JMOHEP(2,JC)
3669               GOTO 110
3670             ENDIF
3671           IF(JD.EQ.JDAHEP(2,HRDCOL(1,2))) JD = HRDCOL(1,1)
3672           BVVUSE=.TRUE.
3673           BVVHRD = .TRUE.
3674           IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
3675             JC = JMOHEP(2,JC)
3676           ELSE
3677             JC = HRDCOL(1,1)
3678           ENDIF
3679         ELSE
3680           JC =JMOHEP(2,JC)
3681         ENDIF
3682         IF (JC.EQ.0) THEN
3683           CALL HWWARN('HWBCON',51)
3684           GOTO 110
3685         ENDIF
3686 C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
3687         IF (ISTHEP(JC).EQ.155) THEN
3688           IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
3689 C---DECAYED BEFORE HADRONIZING
3690             IF(BVVHRD) THEN
3691               JHEP = JC
3692             ELSEIF(BVVUSE) THEN
3693               JHEP=JDAHEP(2,JC-1)
3694             ELSE
3695               JHEP=JMOHEP(2,JC)
3696             ENDIF
3697             IF(JHEP.EQ.0.AND.ABS(IDHEP(JC)).EQ.6) THEN
3698               JHEP = JMOHEP(1,JMOHEP(1,JC))
3699               IF(BVDEC1(JMOHEP(1,JHEP)).OR.BVDEC2(JMOHEP(1,JHEP))) THEN
3700                 JC = JHEP
3701                 JHEP = JDAHEP(2,JC-1)
3702               ELSE
3703                 JHEP = 0
3704               ENDIF
3705             ENDIF
3706             IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
3707      &           ISTHEP(JHEP).NE.155.OR.JHEP.EQ.0) GOTO 110
3708             ID=IDHW(JHEP)
3709             IF (ISTHEP(JHEP).EQ.155) THEN
3710 C---SPECIAL FOR GLUINO DECAYS
3711               IF (ID.EQ.449) THEN
3712                 ID=IDHW(JC)
3713                 IF(BVVUSE) THEN
3714                   ID=IDHW(IHEP)
3715                   IF(ID.LE.6.OR.ID.EQ.13.OR.
3716      &               (ID.GE.115.AND.ID.LE.120)) THEN
3717                     ID = 7
3718                   ELSE
3719                     ID = 1
3720                   ENDIF
3721                 ENDIF
3722                 CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO)
3723                 IF(IFGO) GOTO 999
3724                 IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
3725               ELSE
3726                 JC=JDAHEP(2,JHEP)
3727                 IF(COLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JHEP)).EQ.449)
3728      &             JC=JDAHEP(1,JHEP)
3729                 IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
3730               ENDIF
3731             ELSE
3732               IF(BVVUSE) THEN
3733                 IF(BVDEC2(JMOHEP(1,JHEP)).OR.JD.NE.JHEP.OR.
3734      &            BVHRD(JMOHEP(1,JHEP)).OR.BVHRD2(JMOHEP(1,JHEP))) THEN
3735                   JC = JD
3736                   GOTO 100
3737                 ELSE
3738                   JMOHEP(2,IHEP)=JHEP
3739                   ID = IDHW(JHEP)
3740                   IF((ID.GE.7.AND.ID.LE.12).OR.
3741      &               (ID.GE.109.AND.ID.LE.114)) JMOHEP(2,JHEP)=IHEP
3742                 ENDIF
3743               ELSE
3744 C--new for particles connected to BV
3745                 IDM = JMOHEP(1,JHEP)
3746                 IF(BVDEC1(IDM).OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
3747                   JC = JHEP
3748                   IF(ABS(IDHEP(IHEP)).LT.1000000) GOTO 100
3749                   JMOHEP(2,IHEP)=JHEP
3750                   GOTO 110
3751                 ENDIF
3752 C--new for top's from BV
3753                 ID = IDHW(JC)
3754                 IDP  = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
3755                 IF((ID.EQ.6.AND.(BVDEC1(IDP))).
3756      &              OR.(ID.EQ.12.AND.BVDEC2(IDP)).
3757      &              OR.((ID.EQ.12.OR.ID.EQ.449).AND.BVHRD(IDP))) THEN
3758                    JMOHEP(2,IHEP)=JHEP
3759                    IF(JDAHEP(2,JHEP).EQ.JC) JDAHEP(2,JHEP)=IHEP
3760                 ELSE
3761                   IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12.
3762      &               AND.IDHW(JHEP).GE.7.AND.IDHW(JHEP).LE.12).OR.
3763      &               (IDHW(IHEP).LE.6.AND.IDHW(JHEP).LE.6)) THEN
3764                     JMOHEP(2,IHEP)=JHEP
3765                   ELSE
3766                     JMOHEP(2,IHEP)=JHEP
3767                     IF((COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(JHEP))).OR.
3768      &                (.NOT.COLRD(IDHW(IHEP)).AND.
3769      &                .NOT.ACOLRD(IDHW(JHEP)))) THEN
3770                       IF(JDAHEP(2,JHEP).EQ.0) THEN
3771                         JDAHEP(2,JHEP)=IHEP
3772                       ELSEIF(JMOHEP(2,JDAHEP(2,JHEP)).NE.JHEP) THEN
3773                         JDAHEP(2,JHEP)=IHEP
3774                       ENDIF
3775                     ELSE
3776                       IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
3777                     ENDIF
3778                   ENDIF
3779                 ENDIF
3780               ENDIF
3781               GOTO 110
3782             ENDIF
3783           ELSE
3784             JC=JMOHEP(2,JC)
3785           ENDIF
3786         ENDIF
3787  100    CONTINUE
3788         IF(BVVUSE.AND.ABS(IDHEP(JC)).LT.1000000.AND.JC.NE.JD
3789      &     .AND.JD.NE.0.AND.JD.NE.JMOHEP(1,JC)) JC = JD
3790         IF(BVVUSE.AND.ABS(IDHEP(JC)).GT.1000000) THEN
3791           IF(COLRD(IDHW(IHEP)).AND..NOT.BVVHRD) GOTO 110
3792         ENDIF
3793         IF(BVVUSE.AND.ISTHEP(JC).EQ.149) JC=JMOHEP(1,JMOHEP(1,JC))
3794 C--SEARCH IN THE JET
3795         IF((ISTHEP(JC).GT.145.AND.ISTHEP(JC).LT.152).AND.
3796      &     ISTHEP(IHEP).EQ.155) THEN
3797           JMOHEP(2,IHEP) = JC
3798           GOTO 110
3799         ENDIF
3800         CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,BVVHRD)
3801         IF(COLP.NE.0) THEN
3802           JMOHEP(2,IHEP) = COLP
3803           IF(COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(COLP)).
3804      &       AND.JDAHEP(2,COLP).EQ.0)
3805      &      JDAHEP(2,COLP) = IHEP
3806           IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12).AND.
3807      &       (IDHW(COLP).GE.7.AND.IDHW(COLP).LE.12)) THEN
3808              IF(JMOHEP(2,COLP).EQ.0) JMOHEP(2,COLP) = IHEP
3809           ENDIF
3810         ENDIF
3811       ENDIF
3812   110 CONTINUE
3813 C---BREAK COLOUR CONNECTIONS WITH PHOTONS modified for Rslash
3814       IHEP=1
3815   130 IF (IHEP.LE.NHEP) THEN
3816         IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149.AND.
3817      &      (JMOHEP(2,IHEP).NE.IHEP.OR.JDAHEP(2,IHEP).NE.IHEP)) THEN
3818           IF(JMOHEP(2,IHEP).NE.0) THEN
3819           IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
3820      &      JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
3821           ENDIF
3822           IF (JDAHEP(2,IHEP).NE.0) THEN
3823             IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
3824      &        JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
3825           ENDIF
3826           DO RHEP=1,NHEP
3827             IST=ISTHEP(RHEP)
3828             IF((IST.GE.147.AND.IST.LE.149).AND.JDAHEP(2,RHEP).EQ.IHEP)
3829      &        JDAHEP(2,RHEP)=JMOHEP(2,IHEP)
3830           ENDDO
3831           DO RHEP=1,NHEP
3832             IST=ISTHEP(RHEP)
3833             IF((IST.GE.147.AND.IST.LE.149).AND.JMOHEP(2,RHEP).EQ.IHEP)
3834      &        JMOHEP(2,RHEP) = JDAHEP(2,IHEP)
3835           ENDDO
3836           JMOHEP(2,IHEP)=IHEP
3837           JDAHEP(2,IHEP)=IHEP
3838         ENDIF
3839         IHEP=IHEP+1
3840         GOTO 130
3841       ENDIF
3842 C--Update the BV anticolour corrections
3843       DO 210 IHEP=1,NHEP+1
3844       IF(IHEP.EQ.1) GOTO 210
3845       IST2 = 0
3846       IF(IHEP.EQ.NHEP+1) THEN
3847         ANTC = HRDCOL(1,1)
3848         IF(ANTC.EQ.0.OR.(IDHW(JMOHEP(1,HRDCOL(1,2))).LE.6)) GOTO 210
3849         IST=155
3850         XHEP=HRDCOL(1,2)
3851         IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
3852         IF(ANTC.NE.0.AND.JDAHEP(1,ANTC).NE.0) IST2=ISTHEP(ANTC)
3853       ELSE
3854         ANTC = JDAHEP(2,IHEP-1)
3855         IF(ANTC.NE.0) IST2=ISTHEP(ANTC)
3856         IST=ISTHEP(IHEP)
3857         IDM = IDHW(IHEP)
3858         XHEP=IHEP
3859       ENDIF
3860       JC = 0
3861       JHEP = 0
3862       JD = 0
3863       IF(IST.EQ.155.AND.IST2.EQ.155) THEN
3864         IDM = IDHW(XHEP)
3865         IF(BVDEC1(XHEP).OR.BVDEC2(XHEP).OR.BVHRD(XHEP).OR.
3866      &     BVHRD2(XHEP)) THEN
3867           JC=ANTC
3868           ID = IDHW(JC)
3869           JHEP = JC
3870           IF(BVDEC1(JC).OR.BVDEC2(JC)) THEN
3871             IF(IHEP.EQ.(NHEP+1)) ANTC=JDAHEP(1,JC)
3872             GOTO 200
3873           ENDIF
3874           IF (ID.EQ.449) THEN
3875 C--SPECIAL FOR GLUINO DECAYS
3876             ID=IDHW(XHEP)
3877             IF(IHEP.EQ.NHEP+1) ID = 407
3878             CALL HWBRC1(JC,ID,JHEP,.FALSE.,IFGO)
3879             IF(IFGO) GOTO 999
3880           ELSE
3881             IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
3882               JC=JDAHEP(1,JHEP)
3883             ELSE
3884               JC=JDAHEP(2,JHEP)
3885             ENDIF
3886           ENDIF
3887 C--SEARCH IN JET
3888           CALL HWBRC2(COLP,XHEP,JC,.FALSE.,BVVUSE,.FALSE.)
3889           ANTC = COLP
3890           IF(IHEP.LE.NHEP.AND.ACOLRD(IDHW(IHEP)).AND.
3891      &       COLRD(IDHW(COLP)).AND.JMOHEP(2,COLP).EQ.0) THEN
3892              JMOHEP(2,COLP) = IHEP
3893           ELSEIF(IHEP.LE.NHEP.AND.IDHW(IHEP).LE.6.AND.
3894      &       IDHW(COLP).LE.6.AND.JDAHEP(2,COLP).EQ.0) THEN
3895              JDAHEP(2,COLP) = IHEP
3896           ELSEIF(IHEP.GT.NHEP.AND.
3897      &       ((BVHRD(XHEP).AND.COLRD(JDAHEP(1,XHEP))).
3898      &       OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
3899      &       ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
3900             JDAHEP(2,COLP) = IHEP
3901           ENDIF
3902         ENDIF
3903       ENDIF
3904   200 CONTINUE
3905       IF(IHEP.EQ.NHEP+1) THEN
3906         IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) THEN
3907           HRDCOL(1,1)=ANTC
3908         IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
3909           IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
3910      &    AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
3911      &      THEN
3912             JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
3913           ELSE
3914             JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3915           ENDIF
3916         ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
3917           JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3918         ENDIF
3919         ENDIF
3920       ELSEIF(IHEP.NE.1) THEN
3921         IF(JDAHEP(2,IHEP-1).NE.ANTC.AND.ANTC.NE.0) JDAHEP(2,IHEP-1)=ANTC
3922       ENDIF
3923  210  CONTINUE
3924 C--Update BV decaying particles connections
3925       DO 310 IHEP=1,NHEP+1
3926       IF(IHEP.EQ.1) GOTO 310
3927       IF(IHEP.EQ.NHEP+1) THEN
3928         ANTC=HRDCOL(1,1)
3929         IF(ANTC.EQ.0.OR.IDHW(JDAHEP(1,HRDCOL(1,2))).LE.6) GOTO 310
3930         IST=155
3931         XHEP=HRDCOL(1,2)
3932         IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
3933       ELSE
3934         ANTC=JMOHEP(2,IHEP)
3935         IST=ISTHEP(IHEP)
3936         IDM = IDHW(IHEP)
3937         XHEP=IHEP
3938       ENDIF
3939       IST2 = 0
3940       JC = 0
3941       JD = 0
3942       IF(ANTC.NE.0.AND.IHEP.NE.NHEP+1) THEN
3943         IF(JDAHEP(1,ANTC).NE.0) IST2 = ISTHEP(ANTC)
3944       ELSEIF(ANTC.NE.0.AND.IHEP.EQ.NHEP+1) THEN
3945         IST2=ISTHEP(ANTC)
3946       ENDIF
3947       IF(IST.EQ.155.AND.IST2.EQ.155) THEN
3948         IF(BVDEC2(XHEP).OR.BVHRD(XHEP).OR.BVHRD2(XHEP)) THEN
3949 C--FIND COLOUR CONNECTED PARTON
3950           JC = ANTC
3951           ID=IDHW(JC)
3952           JHEP = JC
3953           IF(BVDEC2(JHEP)) THEN
3954              ANTC=JC
3955              GOTO 300
3956           ENDIF
3957           IF (ID.EQ.449) THEN
3958             ID=IDHW(XHEP)
3959             IF(IHEP.EQ.NHEP+1) ID = 401
3960 C--SPECIAL FOR GLUINO DECAYS
3961             CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO)
3962             IF(IFGO) GOTO 999
3963           ELSE
3964             IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
3965               JC=JDAHEP(1,JHEP)
3966             ELSE
3967               JC=JDAHEP(2,JHEP)
3968             ENDIF
3969           ENDIF
3970 C--SEARCH IN JET
3971           CALL HWBRC2(COLP,XHEP,JC,.TRUE.,BVVUSE,.FALSE.)
3972           ANTC = COLP
3973           IF(COLP.EQ.0) GOTO 300
3974           IF(IHEP.LE.NHEP) THEN
3975             IF(JDAHEP(2,COLP).EQ.0) THEN
3976               JDAHEP(2,COLP) = JDAHEP(2,IHEP)
3977             ELSEIF(JMOHEP(2,JDAHEP(2,COLP)).NE.COLP) THEN
3978               JDAHEP(2,COLP) = JDAHEP(2,IHEP)
3979             ENDIF
3980           ELSEIF(IHEP.GT.NHEP.AND.
3981      &       ((BVHRD(XHEP).AND.ACOLRD(JDAHEP(1,XHEP)).AND.
3982      &       IDHW(JDAHEP(2,XHEP)).EQ.449).
3983      &       OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
3984      &       ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
3985             JDAHEP(2,COLP) = IHEP
3986           ENDIF
3987         ENDIF
3988       ENDIF
3989   300 CONTINUE
3990       IF(IHEP.NE.NHEP+1.AND.IHEP.NE.1) THEN
3991         IF(JMOHEP(2,IHEP).NE.ANTC.AND.ANTC.NE.0) JMOHEP(2,IHEP)=ANTC
3992       ELSEIF(IHEP.GT.NHEP) THEN
3993         IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) HRDCOL(1,1)=ANTC
3994         IF(ANTC.EQ.0) GOTO 310
3995         IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
3996           IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
3997      &    AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
3998      &      THEN
3999             JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
4000           ELSE
4001             JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
4002           ENDIF
4003         ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
4004           JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
4005         ENDIF
4006       ENDIF
4007  310  CONTINUE
4008 C--Update partons connected to decaying SUSY particle
4009       DO 400 IHEP=1,NHEP
4010       IST=ISTHEP(IHEP)
4011 C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
4012       IF (IST.LT.145.OR.IST.GT.152) GOTO 400
4013       IF(JMOHEP(2,IHEP).EQ.0) GOTO 400
4014       IF(ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
4015 C--FIND THE COLOUR CONNECTED PARTON
4016         JC=JMOHEP(2,IHEP)
4017         ID=IDHW(JC)
4018         JHEP = JC
4019         IF(BVDEC2(JC).AND.IDHW(JC).NE.449) THEN
4020           IF(IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12)
4021      &          JMOHEP(2,IHEP)=JDAHEP(1,JC)
4022           GOTO 400
4023         ENDIF
4024         IF (ID.EQ.449) THEN
4025 C--SPECIAL FOR GLUINO DECAYS
4026           ID=IDHW(IHEP)
4027           CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO)
4028           IF(IFGO) GOTO 999
4029         ELSE
4030           ID=IDHW(IHEP)
4031           IF(COLRD(ID).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
4032             JC=JDAHEP(1,JHEP)
4033           ELSE
4034             JC=JDAHEP(2,JHEP)
4035             IF(IDHW(JHEP).EQ.6.AND.IDHW(JC).EQ.13) JC=JC-1
4036           ENDIF
4037         ENDIF
4038 C--SEARCH IN JET
4039         CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,.FALSE.)
4040         JMOHEP(2,IHEP) = COLP
4041       ENDIF
4042  400  CONTINUE
4043 C--Update partons connected to decaying SUSY particle
4044       DO 500 IHEP=1,NHEP
4045       IST=ISTHEP(IHEP)
4046 C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
4047       IF (IST.LT.145.OR.IST.GT.152) GOTO 500
4048       IF(JDAHEP(2,IHEP).EQ.0) GOTO 500
4049       IF(ISTHEP(JDAHEP(2,IHEP)).EQ.155) THEN
4050 C--FIND THE COLOUR CONNECTED PARTON
4051         JC=JDAHEP(2,IHEP)
4052         ID=IDHW(JC)
4053         ID=IDHW(JC)
4054         IF (ID.EQ.449) THEN
4055           ID=IDHW(IHEP)
4056 C--SPECIAL FOR GLUINO DECAYS
4057           JHEP = JC
4058           CALL  HWBRC1(JC,ID,JHEP,.FALSE.,IFGO)
4059           IF(IFGO) GOTO 999
4060         ELSE
4061           IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
4062             JC = JDAHEP(1,JC)
4063           ELSE
4064             JC=JDAHEP(2,JC)
4065           ENDIF
4066         ENDIF
4067 C--SEARCH IN THE JET
4068         CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4069         IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
4070       ENDIF
4071  500  CONTINUE
4072 C--Flavour and anticolour connections in Rslash
4073       DO 610 IHEP=1,NHEP
4074         IST=ISTHEP(IHEP)
4075         IF(IST.LT.145.OR.IST.GT.152.OR.JDAHEP(2,IHEP).NE.0) GOTO 610
4076         JD = 0
4077         BVVUSE = .FALSE.
4078         JC = JMOHEP(1,IHEP)
4079         IF(IST.NE.152) JC = JMOHEP(1,JC)
4080         IF(JC.EQ.0) THEN
4081           CALL HWWARN('HWBRCN',51)
4082           GOTO 610
4083         ENDIF
4084 C--For particles which came from a top decay
4085         IF(ABS(IDHEP(JMOHEP(1,JC))).EQ.6) THEN
4086           JD = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
4087 C--flavour connect to self if needed
4088           IF(JDAHEP(2,JMOHEP(1,JC)-1).EQ.JMOHEP(1,JC)) THEN
4089             JDAHEP(2,IHEP) = IHEP
4090             GOTO 610
4091           ELSEIF(JDAHEP(2,JMOHEP(1,JC)-1).NE.0) THEN
4092             JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
4093             GOTO 610
4094           ELSE
4095             JC = JD
4096           ENDIF
4097         ENDIF
4098 C--Decide if this came from a BV decay
4099         IDM = JMOHEP(1,JC)
4100         IF(BVDEC1(IDM).OR.BVDEC2(IDM).OR.BVDEC3(IDM).
4101      &     OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
4102 C--Do BV piece
4103           IF(JDAHEP(2,JC).EQ.JMOHEP(1,JC)) THEN
4104            IF(IDHW(JMOHEP(1,JC)).EQ.449.AND.
4105      &        JDAHEP(1,JMOHEP(1,JC)).EQ.JC) THEN
4106               JC = JDAHEP(2,JMOHEP(1,JC)-1)
4107             ELSE
4108               JC = JMOHEP(2,JMOHEP(1,JC))
4109             ENDIF
4110             IF(ABS(IDHEP(JC)).LT.1000000) THEN
4111               IF(JDAHEP(1,JC).EQ.0) THEN
4112                 JDAHEP(2,IHEP) = JC
4113                 GOTO 610
4114               ELSE
4115                 GOTO 600
4116               ENDIF
4117             ELSEIF(ABS(IDHEP(JC)).GT.1000000
4118      &        .AND.ISTHEP(JC).NE.155) THEN
4119               GOTO 610
4120             ENDIF
4121             IF(ISTHEP(JC).EQ.155.AND.ACOLRD(IDHW(IHEP))) THEN
4122               JC = JDAHEP(1,JC)
4123             ELSE
4124               IF(ISTHEP(JC).EQ.155.AND.IDHW(JDAHEP(1,JC)).NE.449) THEN
4125                 JC = JDAHEP(1,JC)
4126               ELSE
4127                 JC = JDAHEP(2,JC)
4128               ENDIF
4129             ENDIF
4130           ELSE
4131 C--For the hard process
4132             IF(IDHW(IDM).EQ.15.AND.JC.EQ.JDAHEP(2,JMOHEP(1,JC))) THEN
4133               JDAHEP(2,IHEP) = JDAHEP(2,JC)
4134               GOTO 610
4135             ELSEIF(IDHW(IDM).EQ.15.AND.IDHW(IHEP).NE.449) THEN
4136               JD=HRDCOL(1,1)
4137               IF(BVHRD(IDM).AND.IDHW(JDAHEP(2,IDM)).NE.449) THEN
4138                 JC = JDAHEP(2,JC)
4139                 GOTO 600
4140               ELSEIF(JMOHEP(1,JDAHEP(2,JC)).EQ.JD) THEN
4141                 JC=JDAHEP(2,JC)
4142                 GOTO 600
4143               ENDIF
4144               IF(JDAHEP(2,JC).EQ.8) JC = JD
4145             ELSE
4146               JD=JMOHEP(2,JMOHEP(1,JC))
4147             ENDIF
4148             IF(COLRD(IDHW(IHEP)).AND..NOT.ACOLRD(IDHW(IHEP)).AND.
4149      &      ABS(IDHEP(JD)).GT.1000000.AND.ISTHEP(JD).NE.155) THEN
4150               JDAHEP(2,IHEP) = JD
4151               IF(JDAHEP(2,JD).EQ.0) JDAHEP(2,JD) = IHEP
4152             ENDIF
4153             IF(ABS(IDHEP(JD)).GT.1000000
4154      &        .AND.ISTHEP(JD).NE.155) GOTO 610
4155             IF(ISTHEP(JC).EQ.149) THEN
4156               JDAHEP(2,IHEP)=JC
4157               GOTO 610
4158             ENDIF
4159           IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JC).EQ.449.AND.BVDEC2(JC)) THEN
4160               JC = JDAHEP(1,JC)
4161             ELSE
4162               JC = JDAHEP(2,JC)
4163             ENDIF
4164           ENDIF
4165 C--SEARCH IN THE JET
4166  600      CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4167           IF(COLP.NE.0) THEN
4168             IF(ABS(IDHEP(COLP)).EQ.6.AND.JDAHEP(1,COLP).NE.0) THEN
4169               IF(ISTHEP(COLP).EQ.155) THEN
4170                 JC = JDAHEP(2,COLP)
4171               ELSE
4172                 JC = JDAHEP(2,JDAHEP(2,COLP))
4173               ENDIF
4174               GOTO 600
4175             ENDIF
4176             JDAHEP(2,IHEP) = COLP
4177           ENDIF
4178         ELSE
4179 C--check if it came from a top
4180           IF(ABS(IDHEP(JC)).EQ.6) THEN
4181 C--start the analysis again
4182             JC = JMOHEP(1,IHEP)
4183             IF(IST.NE.152) JC = JMOHEP(1,JC)
4184             JC = JDAHEP(2,JC)
4185             IF(JC.EQ.0) THEN
4186               CALL HWWARN('HWBRCN',52)
4187               GOTO 610
4188             ENDIF
4189               IF(ISTHEP(JC).EQ.155) THEN
4190                 IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
4191 C---DECAYED BEFORE HADRONIZING
4192                   JHEP=JDAHEP(2,JC-1)
4193                   IF (JHEP.EQ.0) GO TO 610
4194                   ID=IDHW(JHEP)
4195                   IF (ISTHEP(JHEP).EQ.155) THEN
4196 C---SPECIAL FOR GLUINO DECAYS
4197                     IF (ID.EQ.449) THEN
4198                       CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO)
4199                       IF(IFGO) GOTO 999
4200                     ELSE
4201                       JC=JDAHEP(2,JHEP)
4202                     ENDIF
4203                   ELSE
4204                     IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
4205                     JDAHEP(2,IHEP) = JHEP
4206                     GOTO 610
4207                   ENDIF
4208                 ELSE
4209                   JC=JDAHEP(2,JC-1)
4210                 ENDIF
4211               ENDIF
4212 C--SEARCH IN JET
4213               CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4214               IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
4215           ELSE
4216             IF(ISTHEP(JMOHEP(1,JC)).EQ.155
4217      &            .AND.IDHW(JC).LE.6) THEN
4218                JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
4219                IF(JDAHEP(2,IHEP).NE.0) GOTO 610
4220             ENDIF
4221             CALL HWWARN('HWBRCN',100)
4222             GOTO 610
4223           ENDIF
4224         ENDIF
4225  610  CONTINUE
4226  999  RETURN
4227       END
4228 CDECK  ID>, HWBRC1.
4229 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
4230 *-- Author :    PeterRichardson
4231 C-----------------------------------------------------------------------
4232       SUBROUTINE HWBRC1(JC,ID,JHEP,COL,IFGO)
4233 C-----------------------------------------------------------------------
4234 C--Function to find the right daugther of a decaying gluino
4235 C-----------------------------------------------------------------------
4236       INCLUDE 'herwig65.inc'
4237       INTEGER ID,JHEP,KC,JC
4238       LOGICAL COL,IFGO
4239 C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
4240 C--Rparity take the first daughther
4241       IFGO = .FALSE.
4242       IF(IDHW(JDAHEP(1,JHEP)).LE.12.AND.IDHW(JDAHEP(1,JHEP)+1).LE.12
4243      &   .AND.IDHW(JDAHEP(2,JHEP)).LE.12) THEN
4244         KC = JDAHEP(1,JHEP)
4245         GOTO 20
4246       ELSEIF ((COL.AND.(ID.EQ.449.OR.ID.EQ.13)).OR.
4247      &        (ID.GE.401.AND.ID.LE.406).OR.
4248      &       (ID.GE.413.AND.ID.LE.418).OR.ID.LE.6.OR.
4249      &       (ID.GE.115.AND.ID.LE.120)) THEN
4250 C---LOOK FOR ANTI(S)QUARK OR GLUON
4251         DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
4252           ID=IDHW(KC)
4253           IF ((ID.GE.7.AND.ID.LE.13).OR.(ID.GE.407.AND.ID.LE.412).OR.
4254      &       (ID.GE.419.AND.ID.LE.424)) GOTO 20
4255         ENDDO
4256       ELSE
4257 C---LOOK FOR (S)QUARK OR GLUON
4258         DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
4259           ID=IDHW(KC)
4260           IF (ID.LE.  6.OR. ID.EQ. 13.OR.(ID.GE.401.AND.ID.LE.406).OR.
4261      &       (ID.GE.413.AND.ID.LE.418)) GOTO 20
4262         ENDDO
4263       ENDIF
4264 C---COULDNT FIND ONE
4265       CALL HWWARN('HWBRC1',100)
4266       IFGO = .TRUE.
4267       RETURN
4268  20   JC=KC
4269       END
4270 CDECK  ID>, HWBRC2.
4271 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
4272 *-- Author :    Peter Richardson
4273 C-----------------------------------------------------------------------
4274       SUBROUTINE HWBRC2(COLP,IHEP,JC,CON,BVVUSE,BVVHRD)
4275 C-----------------------------------------------------------------------
4276 C--Function to search in the jet for the particle
4277 C-----------------------------------------------------------------------
4278       INCLUDE 'herwig65.inc'
4279       INTEGER JC,JD,QHEP,LHEP,IHEP,JHEP,IDM,NCOUNT,ID,IP,IDM2,COLP
4280       LOGICAL CON,BVVUSE,FLA,AFLA,BVVHRD
4281       FLA(IP)  = (IP.LE.6.OR.(IP.GE.115.AND.IP.LE.120).
4282      &           OR.(IP.GE.401.AND.IP.LE.406).
4283      &           OR.(IP.GE.413.AND.IP.LE.418))
4284       AFLA(IP) = ((IP.LE.12.AND.IP.GE.7).OR.(IP.GE.109.AND.IP.LE.114).
4285      &           OR.(IP.GE.407.AND.IP.LE.412).
4286      &           OR.(IP.GE.419.AND.IP.LE.424))
4287       ID = IDHW(IHEP)
4288       COLP = 0
4289 C--begining and end of jet
4290       IF(JDAHEP(1,JC).NE.0) THEN
4291         JC=JDAHEP(1,JC)
4292         JD=JDAHEP(2,JC)
4293       ELSE
4294         COLP = JC
4295         RETURN
4296       ENDIF
4297       IF (JD.LT.JC) JD=JC
4298       LHEP=0
4299       IF(CON) THEN
4300 C--SEARCH FOR A COLOUR PARTNER
4301         DO 110 JHEP=JC,JD
4302           IDM = IDHW(JHEP)
4303         IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 110
4304         IF(AFLA(ID).AND.IDM.EQ.13) GOTO 110
4305         IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
4306         IF ((BVVUSE.AND.JMOHEP(2,JHEP).NE.0).OR.
4307      &      (.NOT.BVVUSE.AND.JDAHEP(2,JHEP).NE.0)) GOTO 110
4308         IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000) THEN
4309           IF(BVVHRD.AND.AFLA(ID)) THEN
4310             CONTINUE
4311           ELSE
4312             RETURN
4313           ENDIF
4314         ENDIF
4315         IF(BVVUSE.AND.(
4316      &      ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449).AND.AFLA(IDM)).
4317      &  OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449))))
4318      &     GOTO 110
4319         IF(AFLA(ID).AND.(IDM.EQ.59.OR.IDM.EQ.449.OR.IDM.EQ.13)) GOTO 110
4320 C---JOIN IHEP AND JHEP
4321         COLP=JHEP
4322         IF(BVVUSE.OR.(ID.GE.7.AND.ID.LE.12.
4323      &     AND.((IDM.GE.7.AND.IDM.LE.12)))) RETURN
4324         IF(IHEP.NE.HRDCOL(1,2).AND.
4325      &     (((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.59)
4326      &       .AND.(AFLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449.OR.IDM.EQ.59))
4327      &     .OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.59))))
4328      &    JDAHEP(2,JHEP)=IHEP
4329         RETURN
4330  110    CONTINUE
4331         IF (LHEP.NE.0) COLP=LHEP
4332 C--Additional Baryon number violating piece
4333         IF(COLP.EQ.0) THEN
4334           IDM2= IDHW(JC)
4335          IF(JMOHEP(1,JC).LT.6) THEN
4336            IF(IDM2.LE.6) THEN
4337              IDM2= IDM2+6
4338            ELSEIF(IDM2.GT.6) THEN
4339              IDM2=IDM2-6
4340            ENDIF
4341          ENDIF
4342           IF(IHEP.EQ.HRDCOL(1,2).OR.
4343      &     ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
4344      &       .AND.(AFLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.13))) THEN
4345               QHEP = JD+1
4346  12           QHEP = QHEP-1
4347               IF(IDHEP(QHEP).EQ.0) GOTO 12
4348               IF(IDHW(QHEP).EQ.59) THEN
4349               IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4350                 COLP = IHEP
4351                 RETURN
4352               ELSE
4353                 GOTO 12
4354               ENDIF
4355               ENDIF
4356               NCOUNT = 0
4357  11           IF(JDAHEP(2,QHEP).NE.0) THEN
4358                 IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP.AND.
4359      &             JDAHEP(2,QHEP).NE.QHEP) THEN
4360                  IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
4361                    QHEP = JDAHEP(2,QHEP)
4362                    NCOUNT = NCOUNT+1
4363                    IF(NCOUNT.LT.NHEP) GOTO 11
4364                  ENDIF
4365                 ENDIF
4366               ENDIF
4367             ELSE
4368             QHEP = JC
4369  13         QHEP = QHEP+1
4370             IF(IDHEP(QHEP).EQ.0) GOTO 13
4371             IF(IDHW(QHEP).EQ.59) THEN
4372               IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4373                 COLP = IHEP
4374                 RETURN
4375               ELSE
4376                 GOTO 13
4377               ENDIF
4378             ENDIF
4379             NCOUNT = 0
4380  9          IF(JMOHEP(2,QHEP).NE.0) THEN
4381             IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
4382      &         JMOHEP(2,QHEP).NE.QHEP) THEN
4383                IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
4384                  QHEP = JMOHEP(2,QHEP)
4385                  NCOUNT = NCOUNT+1
4386                  IF(NCOUNT.LT.NHEP) GOTO 9
4387                ENDIF
4388             ENDIF
4389             ENDIF
4390           ENDIF
4391           IF(ABS(IDHEP(QHEP)).LT.1000000) COLP=QHEP
4392         ENDIF
4393       ELSE
4394 C--Search for an anticolour partner
4395         DO 210 JHEP=JC,JD
4396         IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 210
4397         IF (JMOHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
4398         IF (JMOHEP(2,JHEP).NE.0) GOTO 210
4399 C---JOIN IHEP AND JHEP
4400         COLP=JHEP
4401         RETURN
4402  210   CONTINUE
4403        IF (LHEP.NE.0) COLP=LHEP
4404 C--New piece
4405        IF(COLP.EQ.0) THEN
4406          IDM2=IDHW(JC)
4407          IF(JMOHEP(1,JC).LT.6) THEN
4408            IF(IDM2.LE.6) THEN
4409              IDM2= IDM2+6
4410            ELSEIF(IDM2.GT.6) THEN
4411              IDM2=IDM2-6
4412            ENDIF
4413          ENDIF
4414 C--Additional Baryon number violating piece
4415         IF((FLA(ID).AND.AFLA(IDM2)).OR.
4416      & ((AFLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
4417      &    .AND.(FLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.449)
4418      &  .AND..NOT.(IDHW(JMOHEP(1,JC)).EQ.13.AND.
4419      &        IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.12.AND.
4420      &        ISTHEP(JMOHEP(1,JMOHEP(1,JC))).EQ.155)
4421      &        )) THEN
4422 C--special for gluino decay to gluon
4423          IF(ID.EQ.449.AND.IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.449.AND.
4424      &          IDHW(JMOHEP(1,JC)).EQ.13) RETURN
4425          QHEP = JC
4426  211     QHEP = QHEP+1
4427          IF(IDHEP(QHEP).EQ.0) GOTO 211
4428          IF(IDHW(QHEP).EQ.59) THEN
4429            IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4430              COLP = IHEP
4431              RETURN
4432            ELSE
4433              GOTO 211
4434            ENDIF
4435          ENDIF
4436          NCOUNT = 0
4437  209     IF(JMOHEP(2,QHEP).NE.0) THEN
4438            IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
4439      &        JMOHEP(2,QHEP).NE.QHEP) THEN
4440               IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
4441                 QHEP = JMOHEP(2,QHEP)
4442                 NCOUNT = NCOUNT+1
4443                 IF(NCOUNT.LT.NHEP) GOTO 209
4444               ENDIF
4445            ENDIF
4446          ENDIF
4447         IF(QHEP.NE.0) COLP=QHEP
4448         IF(JDAHEP(2,QHEP).EQ.0.AND.IHEP.NE.6) THEN
4449           IDM2= IDHW(QHEP)
4450           IF(FLA(IHEP).AND.FLA(QHEP).OR.
4451      &       ((AFLA(IHEP).OR.ID.EQ.13.OR.ID.EQ.449).AND.
4452      &        (AFLA(QHEP).OR.IDM2.EQ.13.OR.IDM2.EQ.449)))
4453      &        JDAHEP(2,QHEP)=IHEP
4454         ENDIF
4455         ELSE
4456          QHEP = JD+1
4457  220     QHEP = QHEP-1
4458          IF(IDHEP(QHEP).EQ.0) GOTO 220
4459          IF(IDHW(QHEP).EQ.59) THEN
4460            IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4461              COLP = IHEP
4462              RETURN
4463            ELSE
4464              GOTO 220
4465            ENDIF
4466          ENDIF
4467           NCOUNT = 0
4468  219       IF(JDAHEP(2,QHEP).NE.0) THEN
4469             IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP) THEN
4470               IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
4471                 QHEP = JDAHEP(2,QHEP)
4472                 NCOUNT = NCOUNT+1
4473                 IF(NCOUNT.LT.200) GOTO 219
4474               ENDIF
4475             ENDIF
4476           ENDIF
4477         IF(QHEP.NE.0) COLP=QHEP
4478         IDM2 = IDHW(QHEP)
4479         IF(JDAHEP(2,QHEP).EQ.0.AND.
4480      &     (((AFLA(ID).OR.ID.EQ.13).AND.(AFLA(IDM2).OR.IDM2.EQ.13)).OR.
4481      &     (FLA(ID).AND.FLA(IDM2)))) JDAHEP(2,QHEP)=IHEP
4482         ENDIF
4483        ENDIF
4484       ENDIF
4485       END
4486 CDECK  ID>, HWBSPA.
4487 *CMZ :-        -26/04/91  14.26.44  by  Federico Carminati
4488 *-- Author :    Ian Knowles
4489 C-----------------------------------------------------------------------
4490       SUBROUTINE HWBSPA
4491 C-----------------------------------------------------------------------
4492 C     Constructs time-like 4-momenta & production vertices in space-like
4493 C     jet started by parton no.2 interference partner 1 and spin density
4494 C     DECPAR(2). RHOPAR(2) gives the jet spin density matrix.
4495 C     See I.G. Knowles, Comp. Phys. Comm. 58 (90) 271.
4496 C-----------------------------------------------------------------------
4497       INCLUDE 'herwig65.inc'
4498       DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EISCR,EINUM,EIDEN1,EIDEN2,
4499      & WT,SPIN,Z1,Z2,TR,PRMAX,CX,SX,CAZ,ROHEP(3),RMAT(3,3),ZERO2(2)
4500       INTEGER IPAR,JPAR,KPAR,LPAR,MPAR,JSTR,LSTR,MSTR
4501       LOGICAL EICOR
4502       EXTERNAL HWRGEN
4503       SAVE ZERO2,DMIN
4504       DATA ZERO2,DMIN/2*0D0,1D-15/
4505       IF (IERROR.NE.0) RETURN
4506       JPAR=2
4507       KPAR=1
4508       IF (NPAR.EQ.2) THEN
4509          CALL HWVZRO(2,RHOPAR(1,2))
4510          RETURN
4511       ENDIF
4512 C Generate azimuthal angle of JPAR's branching using an M-function
4513 C     Find the daughters of JPAR, with LPAR time-like
4514   10  LPAR=JDAPAR(1,JPAR)
4515       IF (TMPAR(LPAR)) THEN
4516          MPAR=LPAR+1
4517       ELSE
4518          MPAR=LPAR
4519          LPAR=MPAR+1
4520       ENDIF
4521 C Soft correlations
4522       CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
4523       CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4524       PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
4525       EIKON=1.
4526       EICOR=AZSOFT.AND.IDPAR(LPAR).EQ.13
4527       IF (EICOR) THEN
4528          IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
4529            EISCR=ONE
4530          ELSE
4531            EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
4532      &           /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
4533          ENDIF
4534          EINUM=PPAR(4,KPAR)*PPAR(4,LPAR)*ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
4535          EIDEN1=PPAR(4,KPAR)*PPAR(4,LPAR)-ROHEP(3)*PPAR(3,LPAR)
4536          EIDEN2=PT*ABS(PPAR(1,LPAR))
4537          EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN),ZERO)
4538       ENDIF
4539 C Spin correlations
4540       WT=ZERO
4541       SPIN=ONE
4542       IF (AZSPIN.AND.IDPAR(JPAR).EQ.13) THEN
4543          Z1=PPAR(4,JPAR)/PPAR(4,MPAR)
4544          Z2=ONE-Z1
4545          IF (IDPAR(MPAR).EQ.13) THEN
4546             TR=Z1/Z2+Z2/Z1+Z1*Z2
4547          ELSEIF (IDPAR(MPAR).LT.13) THEN
4548             TR=(ONE+Z2**2)/(TWO*Z1)
4549          ENDIF
4550          WT=Z2/(Z1*TR)
4551       ENDIF
4552 C Assign the azimuthal angle
4553       PRMAX=(1.+ABS(WT))*EIKON
4554   50  CALL HWRAZM( ONE,CX,SX)
4555       CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
4556 C Determine the angle between the branching planes
4557       CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4558       CAZ=ROHEP(1)/PT
4559       PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
4560       PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
4561       IF (EICOR) EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN),ZERO)
4562       IF (AZSPIN) SPIN=1.+WT*(DECPAR(1,JPAR)*PHIPAR(1,JPAR)
4563      &                       +DECPAR(2,JPAR)*PHIPAR(2,JPAR))
4564       IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
4565 C Construct full 4-momentum of LPAR, sum P-trans of MPAR
4566       PPAR(2,LPAR)=ZERO
4567       PPAR(2,MPAR)=ZERO
4568       CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
4569       CALL HWVDIF(2,PPAR(1,2),PPAR(1,LPAR),PPAR(1,2))
4570 C Test for end of space-like branches
4571       IF (JDAPAR(1,MPAR).EQ.0) GOTO 60
4572 C     Generate new Decay matrix
4573       CALL HWBAZF(MPAR,JPAR,ZERO2,DECPAR(1,JPAR),
4574      &            PHIPAR(1,JPAR),DECPAR(1,MPAR))
4575 C     Advance along the space-like branch
4576       JPAR=MPAR
4577       KPAR=LPAR
4578       GOTO 10
4579 C Retreat along space-like line
4580 C     Assign initial spin density matrix
4581   60  CONTINUE
4582       CALL HWVEQU(2,ZERO2,RHOPAR(1,MPAR))
4583       CALL HWUMAS(PPAR(1,2))
4584       CALL HWVZRO(4,VPAR(1,MPAR))
4585       JSTR=JPAR
4586       LSTR=LPAR
4587       MSTR=MPAR
4588   70  JPAR=JSTR
4589       LPAR=LSTR
4590       MPAR=MSTR
4591       CALL HWVEQU(4,VPAR(1,MPAR),VPAR(1,LPAR))
4592       IF (MPAR.EQ.2) RETURN
4593 C Construct spin density matrix for time-like branch
4594       CALL HWBAZF(MPAR,JPAR,RHOPAR(1,MPAR),PHIPAR(1,JPAR),
4595      &                      DECPAR(1,JPAR),RHOPAR(1,LPAR))
4596 C Evolve time-like side branch
4597       CALL HWBTIM(LPAR,MPAR)
4598 C Construct spin density matrix for space-like branch
4599       CALL HWBAZF(MPAR,JPAR,PHIPAR(1,JPAR),RHOPAR(1,MPAR),
4600      &                      DECPAR(1,LPAR),RHOPAR(1,JPAR))
4601 C Assign production vertex to J
4602       CALL HWVDIF(4,PPAR(1,MPAR),PPAR(1,LPAR),PPAR(1,JPAR))
4603       CALL HWUDKL(IDPAR(JPAR),PPAR(1,JPAR),VPAR(1,JPAR))
4604       CALL HWVSUM(4,VPAR(1,MPAR),VPAR(1,JPAR),VPAR(1,JPAR))
4605 C Find parent and partner of MPAR
4606       MPAR=JPAR
4607       JPAR=JMOPAR(1,MPAR)
4608 C BRW modified here 19/06/01 to avoid compiler-dependent bug
4609 C (overwriting of JPAR etc.)
4610       IPAR=MPAR+1
4611       KPAR=JMOPAR(1,IPAR)
4612       IF (JPAR.EQ.KPAR) THEN
4613          LPAR=MPAR+1
4614       ELSE
4615          LPAR=MPAR-1
4616       ENDIF
4617       JSTR=JPAR
4618       LSTR=LPAR
4619       MSTR=MPAR
4620       GOTO 70
4621       END
4622 CDECK  ID>, HWBSPN.
4623 *CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
4624 *-- Author :    Ian Knowles
4625 C-----------------------------------------------------------------------
4626       SUBROUTINE HWBSPN
4627 C-----------------------------------------------------------------------
4628 C     Constructs appropriate spin density/decay matrix for parton
4629 C     in hard subprocess, otherwise zero. Assignments based upon
4630 C     Comp. Phys. Comm. 58 (1990) 271.
4631 C-----------------------------------------------------------------------
4632       INCLUDE 'herwig65.inc'
4633       DOUBLE PRECISION C,V12,V23,V13,TR,C1,C2,C3,R1(2),R2(2)
4634       INTEGER IST
4635       SAVE R1,R2,V12
4636       IF (IERROR.NE.0) RETURN
4637       IST=MOD(ISTHEP(NEVPAR),10)
4638 C Assumed partons processed in the order IST=1,2,3,4
4639       IF (IPROC.GE.100.AND.IPROC.LE.116) THEN
4640 C  An e+e- ---> qqbar g event
4641          IF (IDPAR(2).EQ.13) THEN
4642             RHOPAR(1,2)=GPOLN
4643             RHOPAR(2,2)=0.
4644             RETURN
4645          ENDIF
4646       ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17) THEN
4647          IF (IHPRO.EQ. 7.OR.IHPRO.EQ. 8.OR.
4648      &       IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
4649      &       IHPRO.EQ.15.OR.IHPRO.EQ.16.OR.
4650      &      (IHPRO.GE.21.AND.IHPRO.LE.31)) THEN
4651 C A hard 2 --- > 2 QCD subprocess involving gluons
4652             IF (IST.EQ.2) THEN
4653                CALL HWVEQU(2,RHOPAR(1,2),R1(1))
4654                C=GCOEF(2)/GCOEF(1)
4655                DECPAR(1,2)=C*R1(1)
4656                DECPAR(2,2)=C*R1(2)
4657                RETURN
4658             ELSEIF (IST.EQ.3) THEN
4659                CALL HWVEQU(2,RHOPAR(1,2),R2(1))
4660                V12=R1(1)*R2(1)+R1(2)*R2(2)
4661                TR=1./(GCOEF(1)+GCOEF(2)*V12)
4662                RHOPAR(1,2)= (GCOEF(3)*R1(1)+GCOEF(4)*R2(1))*TR
4663                RHOPAR(2,2)=-(GCOEF(3)*R1(2)+GCOEF(4)*R2(2))*TR
4664                RETURN
4665             ELSEIF (IST.EQ.4) THEN
4666                V13=R1(1)*DECPAR(1,2)+R1(2)*DECPAR(2,2)
4667                V23=R2(1)*DECPAR(1,2)+R2(2)*DECPAR(2,2)
4668                TR=1./(GCOEF(1)+GCOEF(2)*V12+GCOEF(3)*V13+GCOEF(4)*V23)
4669                C1=(GCOEF(2)+GCOEF(5))*TR
4670                C2=(GCOEF(3)+GCOEF(6))*TR
4671                C3=(GCOEF(4)+GCOEF(6))*TR
4672                RHOPAR(1,2)=C1*DECPAR(1,2)+C2*R2(1)+C3*R1(1)
4673                RHOPAR(2,2)=C1*DECPAR(2,2)-C2*R1(2)-C3*R2(2)
4674                RETURN
4675             ENDIF
4676          ENDIF
4677       ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN
4678 C A gluon fusion ---> Higgs event
4679          IF (IST.EQ.2) THEN
4680             IF (IHIGGS.NE.4) THEN
4681                DECPAR(1,2)=RHOPAR(1,2)
4682                DECPAR(2,2)=-RHOPAR(2,2)
4683             ELSE
4684                DECPAR(1,2)=-RHOPAR(1,2)
4685                DECPAR(2,2)=RHOPAR(2,2)
4686             END IF
4687             RETURN
4688          ENDIF
4689       ELSEIF (IPRO.EQ.42) THEN
4690 C A gluon fusion (or qq-bar annihilation) ---> graviton production event
4691          IF (IST.EQ.2) THEN
4692             DECPAR(1,2)=RHOPAR(1,2)
4693             DECPAR(2,2)=RHOPAR(2,2)
4694             RETURN
4695          ENDIF
4696       ENDIF
4697       CALL HWVZRO(2,RHOPAR(1,2))
4698       CALL HWVZRO(2,DECPAR(1,2))
4699       END
4700 CDECK  ID>, HWBSU1.
4701 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
4702 *-- Author :    Bryan Webber, modified by Mike Seymour
4703 C-----------------------------------------------------------------------
4704       FUNCTION HWBSU1(ZLOG)
4705 C-----------------------------------------------------------------------
4706 C     Z TIMES THE INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
4707 C     HWBSU1 IS FOR UPPER PART OF Z INTEGRATION REGION
4708 C-----------------------------------------------------------------------
4709       IMPLICIT NONE
4710       DOUBLE PRECISION HWBSU1,HWBSUL,Z,ZLOG,U
4711       EXTERNAL HWBSUL
4712       Z=EXP(ZLOG)
4713       U=1.-Z
4714       HWBSU1=HWBSUL(Z)*(1.+U*U)
4715       END
4716 CDECK  ID>, HWBSU2.
4717 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
4718 *-- Author :    Bryan Webber, modified by Mike Seymour
4719 C-----------------------------------------------------------------------
4720       FUNCTION HWBSU2(Z)
4721 C-----------------------------------------------------------------------
4722 C     INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
4723 C     HWBSU2 IS FOR LOWER PART OF Z INTEGRATION REGION
4724 C-----------------------------------------------------------------------
4725       IMPLICIT NONE
4726       DOUBLE PRECISION HWBSU2,HWBSUL,Z,U
4727       EXTERNAL HWBSUL
4728       U=1.-Z
4729       HWBSU2=HWBSUL(Z)*(1.+Z*Z)/U
4730       END
4731 CDECK  ID>, HWBSUD.
4732 *CMZ :-        -14/07/92  13.28.23  by  Mike Seymour
4733 *-- Author :    Bryan Webber
4734 C-----------------------------------------------------------------------
4735       SUBROUTINE HWBSUD
4736 C-----------------------------------------------------------------------
4737 C     COMPUTES (OR READS) TABLES OF SUDAKOV FORM FACTORS
4738 C-----------------------------------------------------------------------
4739       INCLUDE 'herwig65.inc'
4740       DOUBLE PRECISION HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2,G1,G2,QRAT,
4741      & QLAM,POWER,AFAC,QMIN,QFAC,QNOW,ZMIN,ZMAX,Q1,QCOLD,VGOLD,VQOLD,
4742      & RMOLD(6),ACOLD,ZLO,ZHI
4743       INTEGER IQ,IS,L1,L2,L,LL,I,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
4744       EXTERNAL HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2
4745       SAVE NQOLD,NSOLD,NCOLD,NFOLD,SDOLD,QCOLD,VGOLD,VQOLD,RMOLD,ACOLD,
4746      & INOLD
4747       COMMON/HWSINT/QRAT,QLAM
4748       IF (LRSUD.EQ.0) THEN
4749         POWER=1./FLOAT(NQEV-1)
4750         AFAC=6.*CAFAC/BETAF
4751         QMIN=QG+QG
4752         QFAC=(1.1*QLIM/QMIN)**POWER
4753         SUD(1,1)=1.
4754         QEV(1,1)=QMIN
4755 C--IS=1 FOR GLUON->GLUON+GLUON FORM FACTOR
4756         DO 10 IQ=2,NQEV
4757         QNOW=QFAC*QEV(IQ-1,1)
4758         QLAM=QNOW/QCDL3
4759         ZMIN=QG/QNOW
4760         QRAT=1./ZMIN
4761         G1=0
4762         DO 5 I=3,6
4763           ZLO=ZMIN
4764           ZHI=HALF
4765           IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
4766           IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
4767           IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSUG,LOG(ZLO),LOG(ZHI),ACCUR)
4768     5   CONTINUE
4769         SUD(IQ,1)=EXP(AFAC*G1)
4770    10   QEV(IQ,1)=QNOW
4771         AFAC=3.*CFFAC/BETAF
4772 C--QUARK FORM FACTORS.
4773 C--IS=2,3,4,5,6,7 FOR U/D,S,C,B,T,V
4774         DO 15 IS=2,NSUD
4775         Q1=HWBVMC(IS)
4776         IF (IS.EQ.7) Q1=HWBVMC(209)
4777         QMIN=Q1+QG
4778         IF (QMIN.GT.QLIM) GOTO 15
4779         QFAC=(1.1*QLIM/QMIN)**POWER
4780         SUD(1,IS)=1.
4781         QEV(1,IS)=QMIN
4782         DO 14 IQ=2,NQEV
4783         QNOW=QFAC*QEV(IQ-1,IS)
4784         QLAM=QNOW/QCDL3
4785         ZMIN=QG/QNOW
4786         QRAT=1./ZMIN
4787         ZMAX=QG/QMIN
4788         G1=0
4789         DO 12 I=3,6
4790           ZLO=ZMIN
4791           ZHI=ZMAX
4792           IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
4793           IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
4794           IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSU1,LOG(ZLO),LOG(ZHI),ACCUR)
4795    12   CONTINUE
4796         ZMIN=Q1/QNOW
4797         QRAT=1./ZMIN
4798         ZMAX=Q1/QMIN
4799         G2=0
4800         DO 13 I=3,6
4801           ZLO=ZMIN
4802           ZHI=ZMAX
4803           IF (I.NE.6) ZLO=MAX(ZLO,Q1/RMASS(I+1))
4804           IF (I.NE.3) ZHI=MIN(ZHI,Q1/RMASS(I))
4805           IF (ZHI.GT.ZLO) G2=G2+HWUGAU(HWBSU2,ZLO,ZHI,ACCUR)
4806    13   CONTINUE
4807         SUD(IQ,IS)=EXP(AFAC*(G1+G2))
4808    14   QEV(IQ,IS)=QNOW
4809    15   CONTINUE
4810         QCOLD=QCDLAM
4811         VGOLD=VGCUT
4812         VQOLD=VQCUT
4813         ACOLD=ACCUR
4814         INOLD=INTER
4815         NQOLD=NQEV
4816         NSOLD=NSUD
4817         NCOLD=NCOLO
4818         NFOLD=NFLAV
4819         SDOLD=SUDORD
4820         DO 16 IS=1,NSUD
4821    16   RMOLD(IS)=RMASS(IS)
4822       ELSE
4823         IF (LRSUD.GT.0) THEN
4824           IF (IPRINT.NE.0) WRITE (6,17) LRSUD
4825    17     FORMAT(/10X,'READING SUDAKOV TABLE ON UNIT',I4)
4826           OPEN(UNIT=LRSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
4827           READ(UNIT=LRSUD) QCOLD,VGOLD,VQOLD,RMOLD,
4828      &       ACOLD,QEV,SUD,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
4829           CLOSE(UNIT=LRSUD)
4830         ENDIF
4831 C---CHECK THAT RELEVANT PARAMETERS ARE UNCHANGED
4832         IF (QCDLAM.NE.QCOLD) CALL HWWARN('HWBSUD',501)
4833         IF (VGCUT .NE.VGOLD) CALL HWWARN('HWBSUD',502)
4834         IF (VQCUT .NE.VQOLD) CALL HWWARN('HWBSUD',503)
4835         IF (ACCUR .NE.ACOLD) CALL HWWARN('HWBSUD',504)
4836         IF (INTER .NE.INOLD) CALL HWWARN('HWBSUD',505)
4837         IF (NQEV  .NE.NQOLD) CALL HWWARN('HWBSUD',506)
4838         IF (NSUD  .NE.NSOLD) CALL HWWARN('HWBSUD',507)
4839         IF (NCOLO .NE.NCOLD) CALL HWWARN('HWBSUD',508)
4840         IF (NFLAV .NE.NFOLD) CALL HWWARN('HWBSUD',509)
4841         IF (SUDORD.NE.SDOLD) CALL HWWARN('HWBSUD',510)
4842 C---CHECK MASSES AND THAT TABLES ARE BIG ENOUGH FOR THIS RUN
4843         DO 18 IS=1,NSUD
4844           IF (RMASS(IS).NE.RMOLD(IS))
4845      &      CALL HWWARN('HWBSUD',510+IS)
4846           IF (QEV(NQEV,IS).LT.QLIM.AND.HWBVMC(IS)+QG.LT.QLIM)
4847      &      CALL HWWARN('HWBSUD',500)
4848    18   CONTINUE
4849       ENDIF
4850       IF (LWSUD.GT.0) THEN
4851         IF (IPRINT.NE.0) WRITE (6,19) LWSUD
4852    19   FORMAT(/10X,'WRITING SUDAKOV TABLE ON UNIT',I4)
4853         OPEN (UNIT=LWSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
4854         WRITE(UNIT=LWSUD)  QCDLAM,VGCUT,VQCUT,(RMASS(I),I=1,6),
4855      &     ACCUR,QEV,SUD,INTER,NQEV,NSUD,NCOLO,NFLAV,SUDORD
4856         CLOSE(UNIT=LWSUD)
4857       ENDIF
4858       IF (IPRINT.GT.2) THEN
4859 C--PRINT EXTRACTS FROM TABLES OF FORM FACTORS
4860         DO 40 IS=1,NSUD
4861         WRITE(6,20) IS,NQEV
4862    20   FORMAT(1H1//10X,'EXTRACT FROM TABLE OF SUDAKOV FORM FACTOR NO.',
4863      &  I2,' (',I5,' ACTUAL ENTRIES)'//10X,'SUD IS PROBABILITY THAT',
4864      &  ' PARTON WITH GIVEN UPPER LIMIT ON Q WILL REACH THRESHOLD',
4865      &  ' WITHOUT BRANCHING'///2X,8('      Q     SUD ')/)
4866         L2=NQEV/8
4867         L1=L2/32
4868         IF (L1.LT.1) L1=1
4869         DO 40 L=L1,L2,L1
4870         LL=L+7*L2
4871         WRITE(6,30) (QEV(I,IS),SUD(I,IS),I=L,LL,L2)
4872    30   FORMAT(2X,8(F9.2,F7.4))
4873    40   CONTINUE
4874         WRITE(6,50)
4875    50   FORMAT(1H1)
4876       ENDIF
4877       END
4878 CDECK  ID>, HWBSUG.
4879 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
4880 *-- Author :    Bryan Webber, modified by Mike Seymour
4881 C-----------------------------------------------------------------------
4882       FUNCTION HWBSUG(ZLOG)
4883 C-----------------------------------------------------------------------
4884 C     Z TIMES INTEGRAND IN EXPONENT OF GLUON SUDAKOV FORM FACTOR
4885 C-----------------------------------------------------------------------
4886       IMPLICIT NONE
4887       DOUBLE PRECISION HWBSUG,HWBSUL,Z,ZLOG,W
4888       EXTERNAL HWBSUL
4889       Z=EXP(ZLOG)
4890       W=Z*(1.-Z)
4891       HWBSUG=HWBSUL(Z)*(W-2.+1./W)*Z
4892       END
4893 CDECK  ID>, HWBSUL.
4894 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
4895 *-- Author :    Mike Seymour
4896 C-----------------------------------------------------------------------
4897       FUNCTION HWBSUL(Z)
4898 C-----------------------------------------------------------------------
4899 C     LOGARITHMIC PART OF INTEGRAND IN EXPONENT OF SUDAKOV FORM FACTOR.
4900 C     THE SECOND ORDER ALPHAS CASE COMES FROM CONVERTING INTEGRAL OVER
4901 C     Q^2 INTO ONE OVER ALPHAS, WITH FLAVOUR THRESHOLDS.
4902 C-----------------------------------------------------------------------
4903       INCLUDE 'herwig65.inc'
4904       DOUBLE PRECISION HWBSUL,HWUALF,Z,QRAT,QLAM,U,AL,BL,QNOW,QMIN,
4905      & BET(6),BEP(6),MUMI(6),MUMA(6),ALMI(6),ALMA(6),FINT(6),ALFINT,
4906      & MUMIN,MUMAX,ALMIN,ALMAX
4907       INTEGER NF
4908       LOGICAL FIRST
4909       EXTERNAL HWUALF
4910       SAVE FIRST,BET,BEP,MUMI,MUMA
4911       COMMON/HWSINT/QRAT,QLAM
4912       DATA FIRST/.TRUE./
4913       ALFINT(AL,BL)=1/BET(NF)*
4914      &        LOG(BL/(AL*(1+BEP(NF)*BL))*(1+BEP(NF)*AL))
4915       HWBSUL=0
4916       U=1.-Z
4917       IF (SUDORD.EQ.1) THEN
4918         AL=LOG(QRAT*Z)
4919         BL=LOG(QLAM*U*Z)
4920         HWBSUL=LOG(1.-AL/BL)
4921       ELSE
4922         IF (FIRST) THEN
4923           DO 10 NF=3,6
4924             BET(NF)=(11*CAFAC-2*NF)/(12*PIFAC)
4925             BEP(NF)=(17*CAFAC**2-(5*CAFAC+3*CFFAC)*NF)/(24*PIFAC**2)
4926      &              /BET(NF)
4927             IF (NF.EQ.3) THEN
4928               MUMI(3)=0
4929               ALMI(3)=1D30
4930             ELSE
4931               MUMI(NF)=RMASS(NF)
4932               ALMI(NF)=HWUALF(1,MUMI(NF))
4933             ENDIF
4934             IF (NF.EQ.6) THEN
4935               MUMA(NF)=1D30
4936               ALMA(NF)=0
4937             ELSE
4938               MUMA(NF)=RMASS(NF+1)
4939               ALMA(NF)=HWUALF(1,MUMA(NF))
4940             ENDIF
4941             IF (NF.NE.3.AND.NF.NE.6) FINT(NF)=ALFINT(ALMI(NF),ALMA(NF))
4942  10       CONTINUE
4943           FIRST=.FALSE.
4944         ENDIF
4945         QNOW=QLAM*QCDL3
4946         QMIN=QNOW/QRAT
4947         MUMIN=  U*QMIN
4948         MUMAX=Z*U*QNOW
4949         IF (MUMAX.LE.MUMIN) RETURN
4950         ALMIN=HWUALF(1,MUMIN)
4951         ALMAX=HWUALF(1,MUMAX)
4952         NF=3
4953  20     IF (MUMIN.GT.MUMA(NF)) THEN
4954           NF=NF+1
4955           GOTO 20
4956         ENDIF
4957         IF (MUMAX.LT.MUMA(NF)) THEN
4958           HWBSUL=ALFINT(ALMIN,ALMAX)
4959         ELSE
4960           HWBSUL=ALFINT(ALMIN,ALMA(NF))
4961           NF=NF+1
4962  30       IF (MUMAX.GT.MUMA(NF)) THEN
4963             HWBSUL=HWBSUL+FINT(NF)
4964             NF=NF+1
4965             GOTO 30
4966           ENDIF
4967           HWBSUL=HWBSUL+ALFINT(ALMI(NF),ALMAX)
4968         ENDIF
4969         HWBSUL=HWBSUL*BET(5)
4970       ENDIF
4971       END
4972 CDECK  ID>, HWBTIM.
4973 *CMZ :-        -26/04/91  14.27.17  by  Federico Carminati
4974 *-- Author :    Ian Knowles
4975 C-----------------------------------------------------------------------
4976       SUBROUTINE HWBTIM(INITBR,INTERF)
4977 C-----------------------------------------------------------------------
4978 C     Constructs full 4-momentum & production vertices in time-like jet
4979 C     initiated by INITBR, interference partner INTERF and spin density
4980 C     RHOPAR(INITBR). DECPAR(INITBR) returns jet's spin density matrix.
4981 C     Includes azimuthal angular correlations between branching planes
4982 C     due to spin (if AZSPIN) using the algorithm of Knowles & Collins.
4983 C     Ses Nucl. Phys. B304 (1988) 794 & Comp. Phys. Comm. 58 (1990) 271.
4984 C-----------------------------------------------------------------------
4985       INCLUDE 'herwig65.inc'
4986       DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EINUM,EIDEN1,EIDEN2,EISCR,
4987      & WT,SPIN,Z1,Z2,PRMAX,CAZ,CX,SX,ROHEP(3),RMAT(3,3),ZERO2(2)
4988       INTEGER INITBR,INTERF,IPAR,JPAR,KPAR,LPAR,MPAR,NTRY,JOLD
4989       LOGICAL EICOR,SWAP
4990       EXTERNAL HWRGEN
4991       SAVE ZERO2,DMIN
4992       DATA ZERO2,DMIN/ZERO,ZERO,1.D-15/
4993       IF (IERROR.NE.0) RETURN
4994       JPAR=INITBR
4995       KPAR=INTERF
4996       IF ((JDAPAR(1,JPAR).NE.0).OR.(IDPAR(JPAR).EQ.13)) GOTO 30
4997 C No branching, assign decay matrix
4998       CALL HWVZRO(2,DECPAR(1,JPAR))
4999       RETURN
5000 C Advance up the leader
5001 C     Find the parent and partner of J
5002   10  IPAR=JMOPAR(1,JPAR)
5003       KPAR=JPAR+1
5004 C Generate new Rho
5005       IF (JMOPAR(1,KPAR).EQ.IPAR) THEN
5006 C        Generate Rho'
5007          CALL HWBAZF(IPAR,JPAR,PHIPAR(1,IPAR),RHOPAR(1,IPAR),
5008      &                                   ZERO2,RHOPAR(1,JPAR))
5009       ELSE
5010          KPAR=JPAR-1
5011          IF (JMOPAR(1,KPAR).NE.IPAR) THEN
5012            CALL HWWARN('HWBTIM',100)
5013            GOTO 999
5014          ENDIF
5015 C        Generate Rho''
5016          CALL HWBAZF(IPAR,KPAR,RHOPAR(1,IPAR),PHIPAR(1,IPAR),
5017      &                         DECPAR(1,KPAR),RHOPAR(1,JPAR))
5018       ENDIF
5019 C Generate azimuthal angle of J's branching
5020   30  IF (JDAPAR(1,JPAR).EQ.0) THEN
5021 C        Final state gluon
5022          CALL HWVZRO(2,DECPAR(1,JPAR))
5023          IF (JPAR.EQ.INITBR) RETURN
5024          GOTO 70
5025       ELSE
5026 C Assign an angle to a branching using an M-function
5027 C        Find the daughters of J
5028          LPAR=JDAPAR(1,JPAR)
5029          MPAR=JDAPAR(2,JPAR)
5030 C Soft correlations
5031          CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
5032          CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
5033          PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
5034          EIKON=1.
5035          SWAP=.FALSE.
5036          EICOR=AZSOFT.AND.((IDPAR(LPAR).EQ.13).OR.(IDPAR(MPAR).EQ.13))
5037          IF (EICOR) THEN
5038 C           Rearrange s.t. LPAR is the (softest) gluon
5039             IF (IDPAR(MPAR).EQ.13) THEN
5040                IF (IDPAR(LPAR).NE.13.OR.
5041      &             PPAR(4,MPAR).LT.PPAR(4,LPAR)) THEN
5042                   SWAP=.TRUE.
5043                   LPAR=MPAR
5044                   MPAR=LPAR-1
5045                ENDIF
5046             ENDIF
5047             EINUM=(PPAR(4,KPAR)*PPAR(4,LPAR))
5048      &        *ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
5049             EIDEN1=(PPAR(4,KPAR)*PPAR(4,LPAR))-ROHEP(3)*PPAR(3,LPAR)
5050             EIDEN2=PT*ABS(PPAR(1,LPAR))
5051             IF (ABS(PPAR(2,MPAR)).LT.DMIN) THEN
5052               IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
5053                  EISCR=ONE
5054               ELSE
5055                  CALL HWWARN('HWBTIM',102)
5056                  GOTO 999
5057               ENDIF
5058             ELSE
5059               EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
5060      &              /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
5061             ENDIF
5062             EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN)
5063          ENDIF
5064 C Spin correlations
5065          WT=0.
5066          SPIN=1.
5067          IF (AZSPIN) THEN
5068             Z1=PPAR(4,LPAR)/PPAR(4,JPAR)
5069             Z2=1.-Z1
5070             IF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).EQ.13) THEN
5071                WT=Z1*Z2/(Z1/Z2+Z2/Z1+Z1*Z2)
5072             ELSEIF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).LT.13) THEN
5073                WT=-2.*Z1*Z2/(Z1*Z1+Z2*Z2)
5074             ENDIF
5075          ENDIF
5076 C Assign the azimuthal angle
5077          PRMAX=(1.+ABS(WT))*EIKON
5078          NTRY=0
5079    50    NTRY=NTRY+1
5080          IF (NTRY.GT.NBTRY) THEN
5081            CALL HWWARN('HWBTIM',101)
5082            GOTO 999
5083          ENDIF
5084          CALL HWRAZM( ONE,CX,SX)
5085          CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
5086 C Determine the angle between the branching planes
5087          CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
5088          CAZ=ROHEP(1)/PT
5089          PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
5090          PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
5091          IF (EICOR) EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN)
5092          IF (AZSPIN) SPIN=1.+WT*(RHOPAR(1,JPAR)*PHIPAR(1,JPAR)
5093      &                          +RHOPAR(2,JPAR)*PHIPAR(2,JPAR))
5094          IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
5095 C Construct full 4-momentum of L and M
5096          JOLD=JPAR
5097          IF (SWAP) THEN
5098            PPAR(1,LPAR)=-PPAR(1,LPAR)
5099            PPAR(1,MPAR)=-PPAR(1,MPAR)
5100            JPAR=MPAR
5101          ELSE
5102            JPAR=LPAR
5103          ENDIF
5104          PPAR(2,LPAR)=0.
5105          CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
5106          PPAR(2,MPAR)=0.
5107          CALL HWUROB(RMAT,PPAR(1,MPAR),PPAR(1,MPAR))
5108 C Assign production vertex to L and M
5109          CALL HWUDKL(IDPAR(JOLD),PPAR(1,JOLD),VPAR(1,LPAR))
5110          CALL HWVSUM(4,VPAR(1,JOLD),VPAR(1,LPAR),VPAR(1,LPAR))
5111          CALL HWVEQU(4,VPAR(1,LPAR),VPAR(1,MPAR))
5112       ENDIF
5113   60  IF (JDAPAR(1,JPAR).NE.0) GOTO 10
5114 C Assign decay matrix
5115       CALL HWVZRO(2,DECPAR(1,JPAR))
5116 C Backtrack down the leader
5117   70  IPAR=JMOPAR(1,JPAR)
5118       KPAR=JDAPAR(1,IPAR)
5119       IF (KPAR.EQ.JPAR) THEN
5120 C        Develop the side branch
5121          JPAR=JDAPAR(2,IPAR)
5122          GOTO 60
5123       ELSE
5124 C        Construct decay matrix
5125          CALL HWBAZF(IPAR,KPAR,DECPAR(1,JPAR),DECPAR(1,KPAR),
5126      &                         PHIPAR(1,IPAR),DECPAR(1,IPAR))
5127       ENDIF
5128       IF (IPAR.EQ.INITBR) RETURN
5129       JPAR=IPAR
5130       GOTO 70
5131  999  RETURN
5132       END
5133 CDECK  ID>, HWBTOP.
5134 *CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
5135 *-- Author :    Gennaro Corcella
5136 C-----------------------------------------------------------------------
5137       SUBROUTINE HWBTOP
5138 C-----------------------------------------------------------------------
5139       INCLUDE 'herwig65.inc'
5140       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,
5141      & X3MIN,X3MAX,X1MIN,X1MAX,QSCALE,GLUFAC,R(3,3),M(3),
5142      & E(3),AW,PTSQ,EM,EPS,MASDEP,A,B,C,GAMDEP,LAMBDA,
5143      & PW(5),PT(5),PW1(5),CS,SN,EPG,QQ,RR,CC
5144       INTEGER ID,ID3,IHEP,KHEP,WHEP,ICMF,K
5145       EXTERNAL HWBVMC,HWUALF,HWUSQR,HWRGEN
5146       LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
5147 C---FIND AN UNTREATED CMF
5148       ICMF=0
5149       DO 10 IHEP=1,NHEP
5150 C----FIND A DECAYING TOP QUARK
5151  10     IF (ISTHEP(IHEP).EQ.155.AND.ISTHEP(JDAHEP(1,IHEP)).EQ.113
5152      &       .AND.(IDHW(IHEP).EQ.6.OR.IDHW(IHEP).EQ.12))
5153      &       ICMF=IHEP
5154       IF (ICMF.EQ.0) RETURN
5155       EM=PHEP(5,ICMF)
5156       X3MIN=2*GCUTME/EM
5157 C---GENERATE X(1),X(3) ACCORDING TO 1/((1-X(1))*X(3)**2)
5158  100  CONTINUE
5159 C-----AW=(MW/MT)**2
5160       AW=(PHEP(5,JDAHEP(1,ICMF))/EM)**2
5161 C---CHOOSE X3
5162       X3MAX=1-AW
5163       X(3)=X3MIN*X3MAX/(X3MIN+(X3MAX-X3MIN)*HWRGEN(0))
5164 C--CC, QQ AND RR ARE THE VARIABLE DEFINED IN OUR PAPER
5165 C--IN ORDER TO SOLVE THE CUBIC EQUATION
5166       CC=(1-AW)**2/4
5167       QQ=(AW**2-4*(1-X(3))*(2-CC-X(3))-2*AW*(3+2*X(3)))/3
5168      &     -((3+2*AW-4*X(3))**2)/9
5169       RR=((3+2*AW-4*X(3))*(AW**2-4*(1-X(3))*(2-CC-X(3))
5170      &     -2*AW*(3+2*X(3)))-3*(AW*(4-AW)*(2-CC)+(1-CC)
5171      &     *(2*(1-X(3))-AW)**2))/6-(ONE/27)*(3+2*AW-4*X(3))**3
5172 C---CHOOSE X1
5173       X1MAX=2*(-QQ**3)**(ONE/6)*COS(ACOS(RR/SQRT(-QQ**3))/3)
5174      &     -(3+2*AW-4*X(3))/3
5175       X1MIN=1-X(3)+(AW*X(3))/(1-X(3))
5176       IF (X1MAX.GE.1.OR.X1MIN.GE.1.OR.X1MAX.LE.X1MIN) GOTO 100
5177       X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(1)
5178 C---CALCULATE WEIGHT
5179       W=((1+1/AW-2*AW)*((1-AW)*X(3)-(1-X(1))*(1-X(3))-X(3)**2)
5180      &     +(1+1/(2*AW))*X(3)*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))
5181      &     *(1/X3MIN-1/X3MAX)*LOG((1-X1MIN)/(1-X1MAX))
5182 C---QSCALE=DURHAM-LIKE TRANSVERSE MOMENTUM OF THE GLUON
5183       QSCALE=EM*HWUSQR(X(3)*(1-X(1))/(2-X(1)-X(3)-AW))
5184 C---FACTOR FOR GLUON EMISSION
5185       ID=IDHW(JDAHEP(2,ICMF))
5186       GLUFAC=0
5187       IF (QSCALE.GT.HWBVMC(13)) GLUFAC=CFFAC*HWUALF(1,QSCALE)
5188      &     /(PIFAC*(1-AW)*(1-2*AW+1/AW))
5189 C---IN FRACTION GLUFAC*W OF EVENTS ADD A GLUON
5190       IF (GLUFAC*W.GT.HWRGEN(4)) THEN
5191         ID3=13
5192       ELSE
5193         GOTO 1000
5194       ENDIF
5195 C---CHECK INFRA-RED CUT-OFF FOR GLUON
5196       M(1)=PHEP(5,JDAHEP(1,ICMF))
5197       M(2)=HWBVMC(ID)
5198       M(3)=HWBVMC(ID3)
5199       E(1)=HALF*EM*(X(1)+AW+(-M(2)**2-M(3)**2)/EM**2)
5200       E(3)=HALF*EM*X(3)
5201       E(2)=EM-E(1)-E(3)
5202       PTSQ=-LAMBDA(E(1)**2-M(1)**2,E(3)**2-M(3)**2,
5203      &     E(2)**2-M(2)**2)
5204       IF (PTSQ.LE.0.OR.E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3))
5205      $     GOTO 1000
5206 C---CALCULATE MASS-DEPENDENT SUPPRESSION
5207       EPS=(RMASS(ID)/EM)**2
5208       EPG=(RMASS(ID3)/EM)**2
5209       GAMDEP=(1-AW)*(1+1/AW-2*AW)/(SQRT(1+AW**2+EPS**2
5210      &     -2*AW-2*EPS-2*AW*EPS)*(1+EPS+(1-EPS)**2/AW-2*AW))
5211       MASDEP=GAMDEP/(1-X(1))*((1+EPS+(1-EPS)**2/AW-2*AW)
5212      &     *((1-AW+EPS)*X(3)*(1-X(1))-(1-X(1))**2*(1-X(3))
5213      &     -X(3)**2*(1-X(1)+EPS))+(1+(1+EPS)/(2*AW))*X(3)
5214      &     *(1-X(1))*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1))**2)
5215       IF (MASDEP.LT.HWRGEN(7)*((1+1/AW-2*AW)*((1-AW)*X(3)
5216      &     -(1-X(1))*(1-X(3))-X(3)**2)+(1+1/(2*AW))*X(3)
5217      &     *(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))) GOTO 1000
5218 C---STORE OLD MOMENTA
5219 c---PT = TOP MOMENTUM, PW= W MOMENTUM
5220       CALL HWVEQU(5,PHEP(1,ICMF),PT)
5221       CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),PW)
5222 C--------GET THE NON-EMITTING PARTON CMF DIRECTION
5223       CALL HWULOF(PHEP(1,ICMF),PW,PW)
5224       CALL HWRAZM(ONE,CS,SN)
5225       CALL HWUROT(PW,CS,SN,R)
5226       CALL HWUROF(R,PW,PW)
5227       CALL HWUMAS(PW)
5228 C---REORDER ENTRIES: IHEP=EMITTER,  KHEP=EMITTED
5229       NHEP=NHEP+1
5230       IHEP=JDAHEP(2,ICMF)
5231       WHEP=JDAHEP(1,ICMF)
5232       KHEP=NHEP
5233 C---SET UP MOMENTA IN TOP REST FRAME
5234       PHEP(1,ICMF)=0
5235       PHEP(2,ICMF)=0
5236       PHEP(3,ICMF)=0
5237       PHEP(4,ICMF)=EM
5238       PHEP(5,ICMF)=EM
5239       PHEP(4,IHEP)=HALF*EM*(2-X(1)-X(3)+EPS-AW+EPG)
5240       PHEP(4,KHEP)=HALF*EM*X(3)
5241       PHEP(5,IHEP)=RMASS(ID)
5242       PHEP(5,KHEP)=RMASS(ID3)
5243       PHEP(3,KHEP)=HALF*EM*((X(1)+AW-EPS-EPG)*X(3)-2*(1+EPS-AW
5244      $     -EPG-(2+EPS+EPG-AW-X(1)-X(3))))/HWUSQR((X(1)+AW
5245      $     -EPS-EPG)**2-4*AW)
5246       PHEP(3,IHEP)=-PHEP(3,KHEP)-HALF*EM
5247      $     *HWUSQR((X(1)+AW-EPS-EPG)**2-4*AW)
5248       PHEP(2,IHEP)=0
5249       PHEP(1,KHEP)=HWUSQR(PHEP(4,KHEP)**2-PHEP(5,KHEP)**2
5250      $     -PHEP(3,KHEP)**2)
5251       PHEP(1,IHEP)=-PHEP(1,KHEP)
5252       PHEP(2,KHEP)=0
5253       CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PW1)
5254       CALL HWVDIF(4,PHEP(1,ICMF),PW1,PW1)
5255       CALL HWUMAS(PW1)
5256       DO K=1,5
5257         PHEP(K,WHEP)=PW1(K)
5258       ENDDO
5259 C---ORIENT IN CMF, THEN BOOST TO LAB
5260       CALL HWUROB(R,PHEP(1,ICMF),PHEP(1,ICMF))
5261       CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
5262       CALL HWUROB(R,PHEP(1,WHEP),PHEP(1,WHEP))
5263       CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
5264       CALL HWULOB(PT,PHEP(1,IHEP),PHEP(1,IHEP))
5265       CALL HWULOB(PT,PHEP(1,KHEP),PHEP(1,KHEP))
5266       CALL HWULOB(PT,PHEP(1,ICMF),PHEP(1,ICMF))
5267       CALL HWULOB(PT,PHEP(1,WHEP),PHEP(1,WHEP))
5268 C---STATUS AND COLOUR CONNECTION
5269 C--Bug fix 31/03/00 PR
5270       ISTHEP(KHEP)=114
5271       IDHW(KHEP)=ID3
5272       IDHEP(KHEP)=IDPDG(ID3)
5273       JMOHEP(1,KHEP)=ICMF
5274       JMOHEP(1,IHEP)=ICMF
5275       JDAHEP(1,KHEP)=0
5276       JDAHEP(2,ICMF)=KHEP
5277       IF(IDHW(ICMF).EQ.6) THEN
5278          JDAHEP(2,IHEP)=ICMF
5279          JDAHEP(2,KHEP)=IHEP
5280          JMOHEP(2,IHEP)=KHEP
5281          JMOHEP(2,KHEP)=ICMF
5282       ELSE
5283          JDAHEP(2,IHEP) = KHEP
5284          JDAHEP(2,KHEP) = ICMF
5285          JMOHEP(2,IHEP) = ICMF
5286          JMOHEP(2,KHEP) = IHEP
5287       ENDIF
5288 C--End of Fix
5289 C--modification to allow photon radiation via photos in top decay
5290  1000 IF(ITOPRD.EQ.1) CALL HWPHTP(ICMF)
5291       END
5292 CDECK  ID>, HWBVMC.
5293 *CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
5294 *-- Author :    Bryan Webber
5295 C-----------------------------------------------------------------------
5296       FUNCTION HWBVMC(ID)
5297 C-----------------------------------------------------------------------
5298 C     VIRTUAL MASS CUTOFF FOR PARTON TYPE ID
5299 C-----------------------------------------------------------------------
5300       INCLUDE 'herwig65.inc'
5301       DOUBLE PRECISION HWBVMC
5302       INTEGER ID
5303       IF (ID.EQ.13) THEN
5304         HWBVMC=RMASS(ID)+VGCUT
5305       ELSEIF (ID.LT.13) THEN
5306         HWBVMC=RMASS(ID)+VQCUT
5307       ELSEIF (ID.EQ.59) THEN
5308         HWBVMC=RMASS(ID)+VPCUT
5309       ELSE
5310         HWBVMC=RMASS(ID)
5311       ENDIF
5312       END
5313 CDECK  ID>, HWCBCT.
5314 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
5315 *-- Author :    Peter Richardson
5316 C-----------------------------------------------------------------------
5317       SUBROUTINE HWCBCT(JHEP,KHEP,THEP,PCL,SPLIT)
5318 C-----------------------------------------------------------------------
5319 C  Subroutine to split a baryonic cluster containing two heavy quarks
5320 C  Based on HWCCUT
5321 C-----------------------------------------------------------------------
5322       INCLUDE 'herwig65.inc'
5323       DOUBLE PRECISION HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,QM3,QM4,
5324      &                 PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),
5325      &                 VCLUS(4),DQM,EMX,EMY,SKAPPA,RKAPPA,VTMP(4),
5326      &                 DELTM,PDIQUK(5),AY(5)
5327       INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,THEP,ID1,ID2,ID3,ID4,NTRY,
5328      &        NTRYMX,J,IB
5329       LOGICAL SPLIT
5330       EXTERNAL HWUPCM,HWRGEN,HWVDOT
5331       PARAMETER(SKAPPA=1.,NTRYMX=100)
5332       IF(IERROR.NE.0) RETURN
5333       EMC=PCL(5)
5334       ID1=IDHW(JHEP)
5335       ID2=IDHW(KHEP)
5336       ID3=IDHW(THEP)
5337       QM1=RMASS(ID1)
5338       QM2=RMASS(ID2)
5339       QM3=RMASS(ID3)
5340       SPLIT = .FALSE.
5341       NTRY = 0
5342 C Decide if cluster contains a b-(anti)quark
5343       IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11.OR.
5344      &    ID3.EQ.5.OR.ID3.EQ.11) THEN
5345         IB=2
5346       ELSE
5347         IB=1
5348       ENDIF
5349 C-- Set the positon of the cluster to be that of the heavy quark
5350       CALL HWVEQU(4,VHEP(1,THEP),VCLUS)
5351 C--SPLIT THE BARYONIC CLUSTER INTO A HEAVY FLAVOUR MESON AND A HEAVY
5352 C--FLAVOUR BARYON
5353       PXY=EMC-QM1-QM2-QM3
5354  20   NTRY=NTRY+1
5355       IF(NTRY.GT.NTRYMX) RETURN
5356  30   EMX=QM1+QM2+PXY*HWRGEN(0)**PSPLT(IB)
5357       EMY=    QM3+PXY*HWRGEN(1)**PSPLT(IB)
5358       IF(EMX+EMY.GE.EMC) GOTO 30
5359 C--PULL A LIGHT QUARK PAIR OUT OF THE VACUUM
5360  40   ID4=HWRINT(1,3)
5361       IF(QWT(ID4).LT.HWRGEN(3)) GOTO 40
5362       QM4=RMASS(ID4)
5363 C--Now combine particles 3 & 4 into a diquark
5364 C--If three also heavy this diquark doesn't exist in HERWIG
5365 C--just assume mass is sum of quark masses,as for other diquarks
5366       DQM=QM3+QM4
5367 C--Now obtain the masses for the cluster splitting
5368       PCX=HWUPCM(EMX,QM1,DQM)
5369       IF(PCX.LT.ZERO) GOTO 20
5370       PCY=HWUPCM(EMY,QM2,QM4)
5371       IF(PCY.LT.ZERO) GOTO 20
5372       SPLIT=.TRUE.
5373 C--Now we've decided which light quark to pull out of the vacuum
5374 C--Find the direction of the second heavy quark
5375       CALL HWULOF(PCL,PHEP(1,THEP),AX)
5376       RCM=1./SQRT(HWVDOT(3,AX,AX))
5377       CALL HWVSCA(3,RCM,AX,AX)
5378 C--Construct the new CoM momenta(collinear)
5379       PXY=HWUPCM(EMC,EMX,EMY)
5380       CALL HWVSCA(3,PXY,AX,PC)
5381 C--pc is momenta of Y cluster along 2nd quark dirn in cluster frame
5382       PC(4)=SQRT(PXY**2+EMY**2)
5383       PC(5)=EMY
5384 C--pa is momenta of 2nd quark in Y frame
5385       CALL HWVSCA(3,PCY,AX,PA)
5386       PA(4)=SQRT(PCY**2+QM3**2)
5387       PA(5)=QM3
5388 C--pb is momenta of 2nd quark in cluster frame,pa now momenta of antiquark
5389       CALL HWULOB(PC,PA,PB)
5390       CALL HWVDIF(4,PC,PB,PA)
5391       PA(5)=QM4
5392       LHEP=NHEP+1
5393       MHEP=NHEP+2
5394 C--boost these momenta back to lab frame
5395       CALL HWULOB(PCL,PB,PHEP(1,THEP))
5396       CALL HWULOB(PCL,PA,PHEP(1,MHEP))
5397 C--pc now becomes momenta of X cluster in cluster frame
5398       CALL HWVSCA(3,-ONE,PC,PC)
5399       PC(4)=EMC-PC(4)
5400       PC(5)=EMX
5401 C--find the dirn of the 1st heavy quark in the X frame
5402 C--transform to cluster frame
5403       CALL HWULOF(PCL,PHEP(1,JHEP),AY)
5404 C--transform to X-frame
5405       CALL HWULOF(PC,AY,AY)
5406       RCM=1./SQRT(HWVDOT(3,AY,AY))
5407       CALL HWVSCA(3,RCM,AY,AY)
5408 C--pa now momenta of 1st havy quark along this dirn
5409       CALL HWVSCA(3,PCX,AY,PA)
5410       PA(4)=SQRT(PCX**2+QM1**2)
5411       PA(5)=QM1
5412 C--pb now momenta of 1st heavy quark in cluster frame then to lab
5413       CALL HWULOB(PC,PA,PB)
5414       CALL HWULOB(PCL,PB,PHEP(1,JHEP))
5415 C--now find the diquark momenta by momentum conservation
5416       DO 50 J=1,4
5417  50   PDIQUK(J)=PCL(J)-PHEP(J,THEP)-PHEP(J,MHEP)-PHEP(J,JHEP)
5418       PDIQUK(5)=DQM
5419 C--Now obtain the quark momenta from the diquark
5420       DO 60 J=1,3
5421  60   PA(J) = 0
5422       PA(4) = QM2
5423       PA(5) = QM2
5424       CALL HWULOB(PDIQUK,PA,PHEP(1,KHEP))
5425       CALL HWVDIF(4,PDIQUK,PHEP(1,KHEP),PHEP(1,LHEP))
5426 C--Construct new vertex positions
5427       RKAPPA=GEV2MM/SKAPPA
5428       CALL HWVSCA(3,RKAPPA,AX,AX)
5429       DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
5430       CALL HWVSCA(3,DELTM,AX,VTMP)
5431       VTMP(4)=(HALF*EMC-PXY)*RKAPPA
5432       CALL HWULB4(PCL,VTMP,VTMP)
5433       CALL HWVSUM(4,VTMP,VCLUS,VHEP(1,LHEP))
5434       CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5435 C--Relabel the colours of the quarks
5436       IDHEP(LHEP) = IDPDG(ID4)
5437       IDHEP(MHEP) = IDPDG(ID4)
5438       IF(IDHEP(JHEP).GT.0) THEN
5439         IDHW(LHEP)  = ID4+6
5440         IDHEP(LHEP) = -IDHEP(LHEP)
5441         IDHW(MHEP)  = ID4
5442         JDAHEP(2,LHEP) = JHEP
5443         JMOHEP(2,LHEP) = MHEP
5444         JMOHEP(2,MHEP) = JMOHEP(2,JHEP)
5445         JDAHEP(2,MHEP) = LHEP
5446         JMOHEP(2,JHEP) = LHEP
5447       ELSE
5448         IDHW(LHEP)  = ID4
5449         IDHW(MHEP)  = ID4+6
5450         IDHEP(MHEP) = -IDHEP(MHEP)
5451         JMOHEP(2,LHEP) = JHEP
5452         JDAHEP(2,MHEP) = JDAHEP(2,JHEP)
5453         JDAHEP(2,LHEP) = MHEP
5454         JMOHEP(2,MHEP) = LHEP
5455         JDAHEP(2,JHEP) = LHEP
5456       ENDIF
5457       ISTHEP(LHEP) = 151
5458       ISTHEP(MHEP) = 151
5459       JMOHEP(1,LHEP) = JMOHEP(1,KHEP)
5460       JDAHEP(1,LHEP) = 0
5461       JMOHEP(1,MHEP) = JMOHEP(1,JHEP)
5462       JDAHEP(1,MHEP) = 0
5463       NHEP = NHEP+2
5464       END
5465 CDECK  ID>, HWCBVI.
5466 *CMZ :-        -12/12/01  14:59:58  by  Peter Richardson
5467 *-- Author :    Mark Gibbs, modified by Peter Richardson
5468 C-----------------------------------------------------------------------
5469       SUBROUTINE HWCBVI
5470 C-----------------------------------------------------------------------
5471 C FINDS UNPAIRED PARTONS AFTER BARYON-NUMBER VIOLATION
5472 C  MODIFIED FOR RPARITY VIOLATING SUSY
5473 C-----------------------------------------------------------------------
5474       INCLUDE 'herwig65.inc'
5475       COMMON/HWBVIC/NBV,IBV(18)
5476       DOUBLE PRECISION HWRGEN,PDQ(5)
5477       INTEGER NBV,IBV,JBV,KBV,LBV,IHEP,IP1,IP2,IP3,JP1,JP2,JP3,
5478      & HWCBVT,NBR,MBV,IQ1,IQ2,IQ3,ID1,ID2,IDQ,IDIQK(3,3)
5479       LOGICAL SPLIT,DUNBV(18)
5480       SAVE IDIQK
5481       DATA IDIQK/111,110,113,110,109,112,113,112,114/
5482 C---Check for errors
5483       IF (IERROR.NE.0)  RETURN
5484 C---Correct colour connections are gluon splitting
5485       CALL HWCCCC
5486 C---Reset bvi clustering flag
5487       HVFCEN = .FALSE.
5488 C---LIST PARTONS WITH WRONG COLOUR PARTNERS-QUARKS ONLY
5489     5 NBV=0
5490       DO 10 IHEP=1,NHEP
5491       IF (ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
5492         IF (QORQQB(IDHW(IHEP))) THEN
5493           IF (.NOT.QORQQB(IDHW(JMOHEP(2,IHEP))).
5494      &        AND.JMOHEP(2,IHEP).GT.6) GOTO 10
5495         ELSE
5496 C---Extra check for Gamma's
5497           IF (IDHW(IHEP).EQ.59) GO TO 10
5498 C---End of bug fix.
5499           IF (QORQQB(IDHW(JDAHEP(2,IHEP)))) GO TO 10
5500           GO TO 10
5501         ENDIF
5502         IF(JMOHEP(2,IHEP).LT.6.AND.
5503      &     .NOT.QBORQQ(IDHW(JMOHEP(2,IHEP)))) GOTO 10
5504 C--new for hard process
5505         NBV=NBV+1
5506         IF (NBV.GT.18) THEN
5507           CALL HWWARN('HWCBVI',100)
5508           GOTO 999
5509         ENDIF
5510         IBV(NBV)=IHEP
5511         DUNBV(NBV)=.FALSE.
5512       ENDIF
5513    10 CONTINUE
5514 C--NOW FIND THE ANTIQUARKS WITH WRONG COLOUR CONNECTIONS
5515       DO 11 IHEP=1,NHEP
5516       IF(ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
5517         IF(QBORQQ(IDHW(IHEP))) THEN
5518           IF(.NOT.QBORQQ(IDHW(JDAHEP(2,IHEP))).AND.
5519      &        JDAHEP(2,IHEP).GT.6) GO TO 11
5520         ELSE
5521 C--Extra check for gamma's
5522           IF(IDHW(IHEP).EQ.59) GO TO 11
5523           IF(QBORQQ(IDHW(JMOHEP(2,IHEP)))) GO TO 11
5524           GO TO 11
5525         ENDIF
5526         IF(JDAHEP(2,IHEP).LT.6.AND.
5527      &    .NOT.QORQQB(IDHW(JDAHEP(2,IHEP)))) GOTO 11
5528         NBV=NBV+1
5529         IF(NBV.GT.18) THEN
5530           CALL HWWARN('HWCBVI',100)
5531           GOTO 999
5532         ENDIF
5533         IBV(NBV)=IHEP
5534         DUNBV(NBV)=.FALSE.
5535       ENDIF
5536  11   CONTINUE
5537       IF (NBV.EQ.0) RETURN
5538       IF(MOD(NBV,3).NE.0) THEN
5539         CALL HWWARN('HWCBVI',101)
5540         GOTO 999
5541       ENDIF
5542 C---PROCESS FOUND PARTONS, STARTING AT RANDOM POINT IN LIST
5543       NBR=INT(NBV*HWRGEN(0))
5544       DO 100 MBV=1,NBV
5545       JBV=MBV+NBR
5546       IF (JBV.GT.NBV) JBV=JBV-NBV
5547       IF (.NOT.DUNBV(JBV)) THEN
5548         DUNBV(JBV)=.TRUE.
5549         IP1=IBV(JBV)
5550         JP1=HWCBVT(IP1)
5551 C---FIND ASSOCIATED PARTONS
5552         DO 20 KBV=1,NBV
5553         IF (.NOT.DUNBV(KBV)) THEN
5554           IP2=IBV(KBV)
5555           JP2=HWCBVT(IP2)
5556           IF (JP2.EQ.JP1) THEN
5557             DUNBV(KBV)=.TRUE.
5558             DO 15 LBV=1,NBV
5559             IF (.NOT.DUNBV(LBV)) THEN
5560               IP3=IBV(LBV)
5561               JP3=HWCBVT(IP3)
5562               IF (JP3.EQ.JP2) THEN
5563                 DUNBV(LBV)=.TRUE.
5564                 GO TO 25
5565               ENDIF
5566             ENDIF
5567    15       CONTINUE
5568           ENDIF
5569         ENDIF
5570    20   CONTINUE
5571         CALL HWWARN('HWCBVI',102)
5572         GOTO 999
5573    25   IQ1=0
5574 C---LOOK FOR DIQUARK
5575         IF (ABS(IDHEP(IP1)).GT.100) THEN
5576           IQ1=IP1
5577           IQ2=IP2
5578           IQ3=IP3
5579         ELSEIF (ABS(IDHEP(IP2)).GT.100) THEN
5580           IQ1=IP2
5581           IQ2=IP3
5582           IQ3=IP1
5583         ELSEIF (ABS(IDHEP(IP3)).GT.100) THEN
5584           IQ1=IP3
5585           IQ2=IP1
5586           IQ3=IP2
5587         ENDIF
5588         IF (IQ1.EQ.0) THEN
5589 C---NO DIQUARKS: COMBINE TWO (ANTI)QUARKS
5590           IF (ABS(IDHEP(IP1)).GT.3) THEN
5591             IQ1=IP2
5592             IQ2=IP3
5593             IQ3=IP1
5594           ELSEIF (ABS(IDHEP(IP2)).GT.3) THEN
5595             IQ1=IP3
5596             IQ2=IP1
5597             IQ3=IP2
5598           ELSE
5599             IQ1=IP1
5600             IQ2=IP2
5601             IQ3=IP3
5602           ENDIF
5603           ID1=IDHEP(IQ1)
5604           ID2=IDHEP(IQ2)
5605 C---CHECK FLAVOURS
5606           IF (ID1.GT.0.AND.ID1.LT.4.AND.
5607      &        ID2.GT.0.AND.ID2.LT.4) THEN
5608             IDQ=IDIQK(ID1,ID2)
5609           ELSEIF (ID1.LT.0.AND.ID1.GT.-4.AND.
5610      &            ID1.LT.0.AND.ID2.GT.-4) THEN
5611             IDQ=IDIQK(-ID1,-ID2)+6
5612           ELSE
5613 C---CANT MAKE DIQUARKS WITH HEAVY QUARKS: TRY CLUSTER SPLITTING
5614             CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PDQ)
5615             CALL HWUMAS(PDQ)
5616 C--Use the original splitting procedure
5617             CALL HWCCUT(IQ1,IQ2,PDQ,.FALSE.,SPLIT)
5618             IF (IERROR.NE.0) RETURN
5619             IF(SPLIT) GOTO 5
5620 C--If it fails try the new procedure
5621             CALL HWVSUM(4,PDQ,PHEP(1,IQ3),PDQ)
5622             CALL HWUMAS(PDQ)
5623             IF(ABS(ID1).GT.3) THEN
5624               CALL HWCBCT(IQ3,IQ2,IQ1,PDQ,SPLIT)
5625             ELSEIF(ABS(ID2).GT.3) THEN
5626               CALL HWCBCT(IQ3,IQ1,IQ2,PDQ,SPLIT)
5627             ELSE
5628               CALL HWWARN('HWCBVI',100)
5629               GOTO 999
5630             ENDIF
5631             IF (SPLIT) GO TO 5
5632 C---Unable to form cluster; dispose of event
5633             CALL HWWARN('HWCBVI',-3)
5634             GOTO 999
5635           ENDIF
5636 C---OVERWRITE FIRST AND CANCEL SECOND
5637           IDHW(IQ1)=IDQ
5638           IDHEP(IQ1)=IDPDG(IDQ)
5639           CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PHEP(1,IQ1))
5640           CALL HWUMAS(PHEP(1,IQ1))
5641           ISTHEP(IQ2)=0
5642 C---REMAKE COLOUR CONNECTIONS
5643           IF (QORQQB(IDQ)) THEN
5644             JMOHEP(2,IQ1)=IQ3
5645             JDAHEP(2,IQ3)=IQ1
5646           ELSE
5647             JDAHEP(2,IQ1)=IQ3
5648             JMOHEP(2,IQ3)=IQ1
5649           ENDIF
5650         ELSE
5651 C---SPLIT A DIQUARK
5652           NHEP=NHEP+1
5653           CALL HWVSCA(5,HALF,PHEP(1,IQ1),PHEP(1,IQ1))
5654           CALL HWVEQU(5,PHEP(1,IQ1),PHEP(1,NHEP))
5655           ISTHEP(NHEP)=150
5656           JMOHEP(1,NHEP)=JMOHEP(1,IQ1)
5657           JDAHEP(1,NHEP)=0
5658 C---FIND FLAVOURS
5659           IDQ=IDHW(IQ1)
5660           DO 30 ID2=1,3
5661           DO 30 ID1=1,3
5662           IF (IDIQK(ID1,ID2).EQ.IDQ) THEN
5663             IDHW(IQ1)=ID1
5664             IDHW(NHEP)=ID2
5665 C---REMAKE COLOUR CONNECTIONS (DIQUARK)
5666             JMOHEP(2,IQ1)=IQ2
5667             JMOHEP(2,IQ2)=NHEP
5668             JMOHEP(2,IQ3)=IQ1
5669             JMOHEP(2,NHEP)=IQ3
5670             JDAHEP(2,IQ1)=IQ3
5671             JDAHEP(2,IQ2)=IQ1
5672             JDAHEP(2,IQ3)=NHEP
5673             JDAHEP(2,NHEP)=IQ2
5674             GO TO 35
5675           ELSEIF (IDIQK(ID1,ID2).EQ.IDQ-6) THEN
5676             IDHW(IQ1)=ID1+6
5677             IDHW(NHEP)=ID2+6
5678 C---REMAKE COLOUR CONNECTIONS (ANTIDIQUARK)
5679             JMOHEP(2,IQ1)=IQ3
5680             JMOHEP(2,IQ2)=IQ1
5681             JMOHEP(2,IQ3)=NHEP
5682             JMOHEP(2,NHEP)=IQ2
5683             JDAHEP(2,IQ1)=IQ2
5684             JDAHEP(2,IQ2)=NHEP
5685             JDAHEP(2,IQ3)=IQ1
5686             JDAHEP(2,NHEP)=IQ3
5687             GO TO 35
5688           ENDIF
5689    30     CONTINUE
5690           CALL HWWARN('HWCBVI',104)
5691           GOTO 999
5692    35     IDHEP(IQ1)=IDPDG(IDHW(IQ1))
5693           IDHEP(NHEP)=IDPDG(IDHW(NHEP))
5694         ENDIF
5695       ENDIF
5696   100 CONTINUE
5697  999  RETURN
5698       END
5699 CDECK  ID>, HWCBVT.
5700 *CMZ :-
5701 *-- Author :    Peter Richardson
5702 C-----------------------------------------------------------------------
5703       FUNCTION HWCBVT(IP)
5704 C-----------------------------------------------------------------------
5705 C  Function to find the baryon number violating vertex a parton came from
5706 C-----------------------------------------------------------------------
5707       INCLUDE 'herwig65.inc'
5708       INTEGER HWCBVT,IP,JP(2),KP,I,J,ID,TYPE,IDM,IDM2,IDM3,IDM4
5709       JP(1) = IP
5710       ID = IDHW(IP)
5711       IF(ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
5712         JP(2) = JMOHEP(2,IP)
5713       ELSE
5714         JP(2) = JDAHEP(2,IP)
5715       ENDIF
5716       DO I=1,2
5717         IDM = JMOHEP(1,JMOHEP(1,JMOHEP(1,JMOHEP(1,JP(I)))))
5718         IF(IDHW(IDM).EQ.6.OR.IDHW(IDM).EQ.12) THEN
5719           JP(I)=IDM
5720         ENDIF
5721       ENDDO
5722       DO J=1,7
5723         DO I=1,2
5724           KP = JMOHEP(1,JP(I))
5725           IDM = IDHW(KP)
5726           IDM2 = IDHW(JDAHEP(1,KP))
5727           IDM3 = IDHW(JDAHEP(2,KP))
5728           IDM4 = IDHW(JDAHEP(1,KP)+1)
5729           IF((ISTHEP(KP).EQ.155.AND.
5730      &      ((IDM.GE.449.AND.IDM.LE.457.AND.IDM2.LE.12.AND.
5731      &       IDM3.LE.12.AND.IDM4.LE.12).OR.
5732      &      (((IDM.GE.411.AND.IDM.LE.424).OR.IDM.EQ.405.OR.IDM.EQ.406)
5733      &      .AND.IDM2.LE.12.AND.IDM3.LE.12)))
5734      &        .OR.(IDM.EQ.15.AND.IDM2.LE.12.AND.
5735      &       IDHW(JMOHEP(1,KP)).LE.12.AND.
5736      &       IDHW(JMOHEP(2,KP)).LE.12.AND.IDM3.GE.449.AND.
5737      &       IDM3.LE.457).OR.
5738      &         (IDM.EQ.15.AND.IDM2.GE.198.AND.IDM2.LE.200.
5739      &          AND.ABS(IDPDG(IDM3)).GT.1000000)) THEN
5740             IF(IDHW(KP).EQ.449.AND.JDAHEP(1,KP).EQ.JP(I)) THEN
5741               KP = JMOHEP(1,KP)
5742             ELSEIF(IDHW(KP).EQ.15) THEN
5743               TYPE=IDHW(JDAHEP(1,KP))
5744               IF(TYPE.GE.7.AND.TYPE.LE.12.AND.
5745      &           JMOHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
5746                 KP=IP
5747               ELSEIF(TYPE.LE.6.AND.
5748      &           JDAHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
5749                 KP=IP
5750               ELSE
5751                 HWCBVT = KP
5752                 RETURN
5753               ENDIF
5754             ELSE
5755               HWCBVT = KP
5756               RETURN
5757             ENDIF
5758           ENDIF
5759           JP(I) =KP
5760         ENDDO
5761       ENDDO
5762       HWCBVT = 0
5763       END
5764 CDECK  ID>, HWCCCC.
5765 *CMZ :-
5766 *-- Author :    Peter Richardson
5767 C-----------------------------------------------------------------------
5768       SUBROUTINE HWCCCC
5769 C-----------------------------------------------------------------------
5770 C  Subroutine to correct colour connections after the gluon splitting
5771 C-----------------------------------------------------------------------
5772       INCLUDE 'herwig65.inc'
5773       INTEGER IHEP,STFSPT,LHEP,MHEP,RHEP
5774       IF(IERROR.NE.0) RETURN
5775 C--Find the first particle in the event record with status 150
5776       DO IHEP=1,NHEP
5777         IF(ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154) THEN
5778           STFSPT = IHEP
5779           GOTO 10
5780         ENDIF
5781       ENDDO
5782  10   CONTINUE
5783 C--Now find any that are colour connected to earlier particles
5784 C--in the event record
5785       DO IHEP=STFSPT,NHEP
5786 C--First the quarks and antidiquarks
5787         IF(IDHW(IHEP).LT.6.OR.
5788      &     (IDHW(IHEP).GE.115.AND.IDHW(IHEP).LE.120)) THEN
5789           IF(JMOHEP(2,IHEP).LT.STFSPT) THEN
5790             LHEP = IHEP
5791             MHEP = JMOHEP(2,IHEP)
5792             RHEP = MHEP
5793             IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
5794 C--As from Rparity connect to particle not to antiparticle
5795             IF(IDHW(MHEP).NE.13) THEN
5796               JMOHEP(2,LHEP) = RHEP
5797             ELSE
5798               RHEP = RHEP+1
5799               JMOHEP(2,LHEP) = RHEP
5800             ENDIF
5801           ENDIF
5802         ENDIF
5803 C--Now the antiquarks
5804         IF((IDHW(IHEP).GT.6.AND.IDHW(IHEP).LE.12).OR.
5805      &     (IDHW(IHEP).GE.109.AND.IDHW(IHEP).LE.114)) THEN
5806           IF(JDAHEP(2,IHEP).LT.STFSPT) THEN
5807             LHEP = IHEP
5808             MHEP = JDAHEP(2,IHEP)
5809             RHEP = MHEP
5810             IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
5811 C--As from Rparity connect to antiparticle not particle
5812             IF(IDHW(MHEP).NE.13) THEN
5813               JDAHEP(2,LHEP) = RHEP
5814             ELSE
5815               JDAHEP(2,LHEP) = RHEP
5816             ENDIF
5817           ENDIF
5818         ENDIF
5819       ENDDO
5820       END
5821 CDECK  ID>, HWCCUT.
5822 *CMZ :-        -26/04/91  14.29.39  by  Federico Carminati
5823 *-- Author :    Bryan Webber
5824 C-----------------------------------------------------------------------
5825       SUBROUTINE HWCCUT(JHEP,KHEP,PCL,BTCLUS,SPLIT)
5826 C-----------------------------------------------------------------------
5827 C     Cuts into 2 the cluster, momentum PCL, made of partons JHEP & KHEP
5828 C-----------------------------------------------------------------------
5829       INCLUDE 'herwig65.inc'
5830       DOUBLE PRECISION HWREXQ,HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,EMX,EMY,
5831      & QM3,PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),SKAPPA,DELTM,
5832      & VSCA,VTMP(4),RKAPPA,VCLUS
5833       INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,ID1,ID2,ID3,NTRY,NTRYMX,J,IB
5834       LOGICAL BTCLUS,SPLIT
5835       EXTERNAL HWREXQ,HWUPCM,HWRGEN,HWVDOT,HWRINT
5836       COMMON/HWCFRM/VCLUS(4,NMXHEP)
5837       PARAMETER (SKAPPA=1.,NTRYMX=100)
5838       IF (IERROR.NE.0) RETURN
5839       EMC=PCL(5)
5840       ID1=IDHW(JHEP)
5841       ID2=IDHW(KHEP)
5842       QM1=RMASS(ID1)
5843       QM2=RMASS(ID2)
5844       SPLIT=.FALSE.
5845       NTRY=0
5846 C Decide if cluster contains a b-(anti)quark
5847       IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11) THEN
5848         IB=2
5849       ELSE
5850         IB=1
5851       ENDIF
5852       IF (BTCLUS) THEN
5853 C Split beam and target clusters as soft clusters
5854 C Both (remnant) children treated like soft clusters if IOPREM=0(1)
5855   10    ID3=HWRINT(1,2)
5856         QM3=RMASS(ID3)
5857         IF (EMC.LE.QM1+QM2+2.*QM3) THEN
5858           ID3=3-ID3
5859           QM3=RMASS(ID3)
5860           IF (EMC.LE.QM1+QM2+2.*QM3) RETURN
5861         ENDIF
5862         PXY=EMC-QM1-QM2-TWO*QM3
5863         IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(JHEP).EQ.154.OR.
5864      &      IOPREM.EQ.0) THEN
5865           EMX=QM1+QM3+HWREXQ(BTCLM,PXY)
5866         ELSE
5867           EMX=QM1+QM3+PXY*HWRGEN(0)**PSPLT(IB)
5868         ENDIF
5869         IF (ISTHEP(KHEP).EQ.153.OR.ISTHEP(KHEP).EQ.154.OR.
5870      &      IOPREM.EQ.0) THEN
5871           EMY=QM2+QM3+HWREXQ(BTCLM,PXY)
5872         ELSE
5873           EMY=QM2+QM3+PXY*HWRGEN(1)**PSPLT(IB)
5874         ENDIF
5875         IF (EMX+EMY.GE.EMC) THEN
5876           NTRY=NTRY+1
5877           IF (NTRY.GT.NTRYMX) RETURN
5878           GOTO 10
5879         ENDIF
5880         PCX=HWUPCM(EMX,QM1,QM3)
5881         PCY=HWUPCM(EMY,QM2,QM3)
5882       ELSE
5883 C Choose fragment masses for ordinary cluster
5884         PXY=EMC-QM1-QM2
5885   20    NTRY=NTRY+1
5886         IF (NTRY.GT.NTRYMX) RETURN
5887   30    EMX=QM1+PXY*HWRGEN(0)**PSPLT(IB)
5888         EMY=QM2+PXY*HWRGEN(1)**PSPLT(IB)
5889         IF (EMX+EMY.GE.EMC) GOTO 30
5890 C u,d,s pair production with weights QWT
5891   40    ID3=HWRINT(1,3)
5892         IF (QWT(ID3).LT.HWRGEN(3)) GOTO 40
5893         QM3=RMASS(ID3)
5894         PCX=HWUPCM(EMX,QM1,QM3)
5895         IF (PCX.LT.ZERO) GOTO 20
5896         PCY=HWUPCM(EMY,QM2,QM3)
5897         IF (PCY.LT.ZERO) GOTO 20
5898         SPLIT=.TRUE.
5899       ENDIF
5900 C Boost antiquark to CoM frame to find axis
5901       CALL HWULOF(PCL,PHEP(1,KHEP),AX)
5902       RCM=1./SQRT(HWVDOT(3,AX,AX))
5903       CALL HWVSCA(3,RCM,AX,AX)
5904 C Construct new CoM momenta (collinear)
5905       PXY=HWUPCM(EMC,EMX,EMY)
5906       CALL HWVSCA(3,PXY,AX,PC)
5907       PC(4)=SQRT(PXY**2+EMY**2)
5908       PC(5)=EMY
5909       CALL HWVSCA(3,PCY,AX,PA)
5910       PA(4)=SQRT(PCY**2+QM2**2)
5911       PA(5)=QM2
5912       CALL HWULOB(PC,PA,PB)
5913       CALL HWVDIF(4,PC,PB,PA)
5914       PA(5)=QM3
5915       LHEP=NHEP+1
5916       MHEP=NHEP+2
5917       IF (MHEP.GT.NMXHEP) THEN
5918         CALL HWWARN('HWCCUT',100)
5919         GOTO 999
5920       ENDIF
5921       CALL HWULOB(PCL,PB,PHEP(1,KHEP))
5922       CALL HWULOB(PCL,PA,PHEP(1,MHEP))
5923       CALL HWVSCA(3,-ONE,PC,PC)
5924       PC(4)=EMC-PC(4)
5925       PC(5)=EMX
5926       CALL HWVSCA(3,PCX,AX,PA)
5927       PA(4)=SQRT(PCX**2+QM3**2)
5928       CALL HWULOB(PC,PA,PB)
5929       CALL HWULOB(PCL,PB,PHEP(1,LHEP))
5930       DO 50 J=1,4
5931   50  PHEP(J,JHEP)=PCL(J)-PHEP(J,KHEP)-PHEP(J,LHEP)-PHEP(J,MHEP)
5932       PHEP(5,JHEP)=QM1
5933       CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5934 C Construct new vertex positions
5935       RKAPPA=GEV2MM/SKAPPA
5936       CALL HWVSCA(3,RKAPPA,AX,AX)
5937       DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
5938       CALL HWVSCA(3,DELTM,AX,VTMP)
5939       VTMP(4)=(HALF*EMC-PXY)*RKAPPA
5940       CALL HWULB4(PCL,VTMP,VTMP)
5941       CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VHEP(1,LHEP))
5942       CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5943       VSCA=0.25*EMC+HALF*(PXY+DELTM)
5944       CALL HWVSCA(3,VSCA,AX,VTMP)
5945       VTMP(4)=(EMC-VSCA)*RKAPPA
5946       CALL HWULB4(PCL,VTMP,VTMP)
5947       CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,MHEP))
5948       VSCA=-0.25*EMC+HALF*(DELTM-PXY)
5949       CALL HWVSCA(3,VSCA,AX,VTMP)
5950       VTMP(4)=(EMC+VSCA)*RKAPPA
5951       CALL HWULB4(PCL,VTMP,VTMP)
5952       CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,JHEP))
5953 C (Re-)label quarks
5954       IDHW(LHEP)=ID3+6
5955       IDHW(MHEP)=ID3
5956       IDHEP(MHEP)= IDPDG(ID3)
5957       IDHEP(LHEP)=-IDPDG(ID3)
5958       ISTHEP(LHEP)=151
5959       ISTHEP(MHEP)=151
5960       JMOHEP(2,JHEP)=LHEP
5961       JDAHEP(2,KHEP)=MHEP
5962       JMOHEP(1,LHEP)=JMOHEP(1,KHEP)
5963       JMOHEP(2,LHEP)=MHEP
5964       JDAHEP(1,LHEP)=0
5965       JDAHEP(2,LHEP)=JHEP
5966       JMOHEP(1,MHEP)=JMOHEP(1,JHEP)
5967       JMOHEP(2,MHEP)=KHEP
5968       JDAHEP(1,MHEP)=0
5969       JDAHEP(2,MHEP)=LHEP
5970       NHEP=NHEP+2
5971  999  RETURN
5972       END
5973 CDECK  ID>, HWCDEC.
5974 *CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
5975 *-- Author :    Bryan Webber
5976 C-----------------------------------------------------------------------
5977       SUBROUTINE HWCDEC
5978 C-----------------------------------------------------------------------
5979 C     DECAYS CLUSTERS INTO PRIMARY HADRONS
5980 C-----------------------------------------------------------------------
5981       INCLUDE 'herwig65.inc'
5982       INTEGER JCL,KCL,IP,JP,KP,IST,ID1,ID2,ID3
5983       IF (IERROR.NE.0) RETURN
5984       IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN
5985 C---RELABEL CLUSTER CONNECTED TO REMNANT IN DIS
5986         DO 10 JCL=2,NHEP
5987         IF (ISTHEP(JCL).EQ.164) GOTO 20
5988         IF (ISTHEP(JCL).EQ.165) THEN
5989           IP=JMOHEP(1,JCL)
5990           JP=JMOHEP(2,JCL)
5991           KP=IP
5992           IF (ISTHEP(IP).EQ.162) THEN
5993             KP=JP
5994             JP=IP
5995           ENDIF
5996           IF (JMOHEP(2,KP).NE.JP) THEN
5997             IP=JMOHEP(2,KP)
5998           ELSE
5999             IP=JDAHEP(2,KP)
6000           ENDIF
6001           KCL=JDAHEP(1,IP)
6002           IF (ISTHEP(KCL)/10.NE.16) THEN
6003             CALL HWWARN('HWCDEC',100)
6004             GOTO 999
6005           ENDIF
6006           ISTHEP(KCL)=164
6007           GOTO 20
6008         ENDIF
6009    10   CONTINUE
6010       ENDIF
6011    20 CONTINUE
6012       DO 30 JCL=1,NHEP
6013       IST=ISTHEP(JCL)
6014       IF (IST.GT.162.AND.IST.LT.166) THEN
6015 C---DON'T HADRONIZE BEAM/TARGET CLUSTERS
6016         IF (IST.EQ.163.OR..NOT.GENSOF) THEN
6017 C---SET UP FLAVOURS FOR CLUSTER DECAY
6018           CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
6019           CALL HWCHAD(JCL,ID1,ID3,ID2)
6020         ENDIF
6021       ENDIF
6022    30 CONTINUE
6023       ISTAT=50
6024  999  RETURN
6025       END
6026 CDECK  ID>, HWCFLA.
6027 *CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
6028 *-- Author :    Bryan Webber
6029 C-----------------------------------------------------------------------
6030       SUBROUTINE HWCFLA(JD1,JD2,ID1,ID2)
6031 C-----------------------------------------------------------------------
6032 C     SETS UP FLAVOURS FOR CLUSTER DECAY
6033 C-----------------------------------------------------------------------
6034       IMPLICIT NONE
6035       INTEGER JD1,JD2,ID1,ID2,JD,JDEC(12)
6036       SAVE JDEC
6037       DATA JDEC/1,2,3,10,11,12,4,5,6,7,8,9/
6038       JD=JD1
6039       IF (JD.GT.12) JD=JD-108
6040       ID1=JDEC(JD)
6041       JD=JD2
6042       IF (JD.GT.12) JD=JD-96
6043       ID2=JDEC(JD-6)
6044       END
6045 CDECK  ID>, HWCFOR.
6046 *CMZ :-        -26/04/91  14.15.56  by  Federico Carminati
6047 *-- Author :    Bryan Webber
6048 C-----------------------------------------------------------------------
6049       SUBROUTINE HWCFOR
6050 C-----------------------------------------------------------------------
6051 C     Converts colour-connected quark-antiquark pairs into clusters
6052 C     Modified by IGK to include BRW's colour rearrangement and
6053 C     MHS's cluster vertices
6054 C     MODIFIED 16/10/97 BY BRW FOR SUSY PROCESSES
6055 C-----------------------------------------------------------------------
6056       INCLUDE 'herwig65.inc'
6057       DOUBLE PRECISION HWULDO,HWVDOT,HWRGEN,HWUPCM,DCL0,DCL(4),DCL1,
6058      & DFAC,DISP1(4),DISP2(4),DMAX,PCL(5),DOT1,DOT2,FAC,VCLUS,SCA1,SCA2,
6059      & EM0,EM1,EM2,PC0,PC1
6060       INTEGER HWRINT,MAP(120),IBHEP,IBCL,JBHEP,JHEP,
6061      & KHEP,LHEP,LCL,IHEP,MCL,I,ISTJ,ISTK,JCL,ID1,ID3,L
6062       LOGICAL HWRLOG,SPLIT
6063       EXTERNAL HWULDO,HWVDOT,HWRGEN,HWUPCM,HWRINT
6064       COMMON/HWCFRM/VCLUS(4,NMXHEP)
6065       SAVE MAP
6066       DATA MAP/1,2,3,4,5,6,1,2,3,4,5,6,96*0,7,8,9,10,11,12,7,8,9,10,11,
6067      & 12/
6068       IF (IERROR.NE.0) RETURN
6069 C Split gluons
6070       CALL HWCGSP
6071 C Find colour partners after baryon number violating event
6072       IF (HVFCEN) THEN
6073         IF(RPARTY) THEN
6074           CALL HVCBVI
6075         ELSE
6076           CALL HWCBVI
6077         ENDIF
6078       ENDIF
6079       IF (IERROR.NE.0) RETURN
6080 C Look for partons to cluster
6081       DO 10 IBHEP=1,NHEP
6082   10  IF (ISTHEP(IBHEP).GE.150.AND.ISTHEP(IBHEP).LE.154) GOTO 20
6083       IBCL=1
6084       GOTO 130
6085   20  CONTINUE
6086 C--Final check for colour disconnections
6087       DO 25 JHEP=IBHEP,NHEP
6088         IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6089      &      QORQQB(IDHW(JHEP))) THEN
6090           KHEP=JMOHEP(2,JHEP)
6091 C BRW FIX 13/03/99
6092           IF (KHEP.EQ.0.OR..NOT.(
6093      &      ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
6094      &      QBORQQ(IDHW(KHEP)))) THEN
6095             DO KHEP=IBHEP,NHEP
6096               IF (ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154
6097      &        .AND.QBORQQ(IDHW(KHEP))) THEN
6098                 LHEP=JDAHEP(2,KHEP)
6099                 IF (LHEP.EQ.0.OR..NOT.(
6100      &          ISTHEP(LHEP).GE.150.AND.ISTHEP(LHEP).LE.154.AND.
6101      &          QORQQB(IDHW(LHEP)))) THEN
6102                   JMOHEP(2,JHEP)=KHEP
6103                   JDAHEP(2,KHEP)=JHEP
6104                   GOTO 25
6105                 ENDIF
6106               ENDIF
6107             ENDDO
6108 C END FIX
6109             CALL HWWARN('HWCFOR',100)
6110             GOTO 999
6111           ENDIF
6112         ENDIF
6113   25  CONTINUE
6114       IF (CLRECO) THEN
6115 C Allow for colour rearrangement of primary clusters
6116         NRECO=0
6117 C Randomize starting point
6118         JBHEP=HWRINT(IBHEP,NHEP)
6119         JHEP=JBHEP
6120   30    JHEP=JHEP+1
6121         IF (JHEP.GT.NHEP) JHEP=IBHEP
6122         IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6123      &      QORQQB(IDHW(JHEP))) THEN
6124 C Find colour connected antiquark or diquark
6125           KHEP=JMOHEP(2,JHEP)
6126 C Find partner antiquark or diquark
6127           LHEP=JDAHEP(2,JHEP)
6128 C Find closest antiquark or diquark
6129           DCL0=1.D15
6130           LCL=0
6131           DO 40 IHEP=IBHEP,NHEP
6132           IF (ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154.AND.
6133      &        QBORQQ(IDHW(IHEP))) THEN
6134 C Check whether already reconnected
6135             IF (JDAHEP(2,IHEP).GT.0.AND.IHEP.NE.LHEP) THEN
6136               CALL HWVDIF(4,VHEP(1,IHEP),VHEP(1,JHEP),DCL)
6137               DCL1=ABS(HWULDO(DCL,DCL))
6138               IF (DCL1.LT.DCL0) THEN
6139                 DCL0=DCL1
6140                 LCL=IHEP
6141               ENDIF
6142             ENDIF
6143           ENDIF
6144   40      CONTINUE
6145           IF (LCL.NE.0.AND.LCL.NE.KHEP) THEN
6146             MCL=JDAHEP(2,LCL)
6147             IF (JDAHEP(2,MCL).NE.KHEP) THEN
6148 C Pairwise reconnection is possible
6149               CALL HWVDIF(4,VHEP(1,KHEP),VHEP(1,MCL ),DCL)
6150               DCL0=DCL0+ABS(HWULDO(DCL,DCL))
6151               CALL HWVDIF(4,VHEP(1,JHEP),VHEP(1,KHEP),DCL)
6152               DCL1=ABS(HWULDO(DCL,DCL))
6153               CALL HWVDIF(4,VHEP(1,LCL ),VHEP(1,MCL ),DCL)
6154               DCL1=DCL1+ABS(HWULDO(DCL,DCL))
6155               IF (DCL0.LT.DCL1.AND.HWRLOG(PRECO)) THEN
6156 C Reconnection occurs
6157                 JMOHEP(2,JHEP)= LCL
6158                 JDAHEP(2,LCL )=-JHEP
6159                 JMOHEP(2,MCL) = KHEP
6160                 JDAHEP(2,KHEP)=-MCL
6161                 NRECO=NRECO+1
6162               ENDIF
6163             ENDIF
6164           ENDIF
6165         ENDIF
6166         IF (JHEP.NE.JBHEP) GOTO 30
6167         IF (NRECO.NE.0) THEN
6168           DO 50 IHEP=IBHEP,NHEP
6169   50      JDAHEP(2,IHEP)=ABS(JDAHEP(2,IHEP))
6170         ENDIF
6171       ENDIF
6172 C Find (adjusted) cluster positions using MHS prescription
6173       DFAC=ONE
6174       DMAX=1D-10
6175       DO 70 JHEP=IBHEP,NHEP
6176       IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6177      &    QORQQB(IDHW(JHEP))) THEN
6178         KHEP=JMOHEP(2,JHEP)
6179         CALL HWUDKL(IDHW(JHEP),PHEP(1,JHEP),DISP1)
6180         CALL HWVSCA(4,DFAC,DISP1,DISP1)
6181         CALL HWUDKL(IDHW(KHEP),PHEP(1,KHEP),DISP2)
6182         CALL HWVSCA(4,DFAC,DISP2,DISP2)
6183 C Rescale the lengths of DISP1,DISP2 if too long
6184         DOT1=HWVDOT(3,DISP1,DISP1)
6185         DOT2=HWVDOT(3,DISP2,DISP2)
6186         IF (MAX(DOT1,DOT2).GT.DMAX**2) THEN
6187           CALL HWVSCA(4,DMAX/SQRT(DOT1),DISP1,DISP1)
6188           CALL HWVSCA(4,DMAX/SQRT(DOT2),DISP2,DISP2)
6189         ENDIF
6190         CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6191         DOT1=HWVDOT(3,DISP1,PCL)
6192         DOT2=HWVDOT(3,DISP2,PCL)
6193 C If PCL > 90^o from either quark, use a vector which isn't
6194         IF (DOT1.LE.ZERO.OR. DOT2.LE.ZERO) THEN
6195           CALL HWVSUM(4,DISP1,DISP2,PCL)
6196           DOT1=HWVDOT(3,DISP1,PCL)
6197           DOT2=HWVDOT(3,DISP2,PCL)
6198         ENDIF
6199 C If vectors are exactly opposite each other this method cannot work
6200         IF (DOT1.EQ.ZERO.OR.DOT2.EQ.ZERO) THEN
6201 C So use midpoint of quark constituents
6202           CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,KHEP),VCLUS(1,JHEP))
6203           CALL HWVSCA(4,HALF,VCLUS(1,JHEP),VCLUS(1,JHEP))
6204           GOTO 70
6205         ENDIF
6206 C Rescale DISP1 or DISP2 to give equal components in the PCL direction
6207         FAC=DOT1/DOT2
6208         IF (FAC.GT.ONE) THEN
6209           CALL HWVSCA(4,    FAC,DISP2,DISP2)
6210           DOT2=DOT1
6211         ELSE
6212           CALL HWVSCA(4,ONE/FAC,DISP1,DISP1)
6213           DOT1=DOT2
6214         ENDIF
6215 C Shift VHEP(1,JHEP) or VHEP(1,KHEP) s.t. their line is perp to PCL
6216         FAC=(HWVDOT(3,PCL,VHEP(1,KHEP))
6217      &      -HWVDOT(3,PCL,VHEP(1,JHEP)))/DOT1
6218         SCA1=MAX(ONE,ONE+FAC)
6219         SCA2=MAX(ONE,ONE-FAC)
6220         DO 60 I=1,4
6221   60    VCLUS(I,JHEP)=.5*(VHEP(I,JHEP)+VHEP(I,KHEP)
6222      &                   +SCA1*DISP1(I)+SCA2*DISP2(I))
6223       ENDIF
6224   70  CONTINUE
6225 C First chop up beam/target clusters
6226       DO 80 JHEP=IBHEP,NHEP
6227       KHEP=JMOHEP(2,JHEP)
6228       ISTJ=ISTHEP(JHEP)
6229       ISTK=ISTHEP(KHEP)
6230 C--PR MOD here 8/7/99
6231       IF (QORQQB(IDHW(JHEP)).AND.
6232      &   (((ISTJ.EQ.153.OR.ISTJ.EQ.154).AND.ISTK.NE.151.AND.ISTK.NE.0)
6233      &   .OR.((ISTK.EQ.153.OR.ISTK.EQ.154).
6234      &   AND.ISTJ.NE.151.AND.ISTJ.NE.0))) THEN
6235 C--end
6236         CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6237         CALL HWUMAS(PCL)
6238         CALL HWCCUT(JHEP,KHEP,PCL,.TRUE.,SPLIT)
6239         IF (IERROR.NE.0) RETURN
6240       ENDIF
6241   80  CONTINUE
6242 C Second chop up massive pairs
6243       DO 100 JHEP=IBHEP,NMXHEP
6244       IF (JHEP.GT.NHEP) GOTO 110
6245       IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6246      &    QORQQB(IDHW(JHEP))) THEN
6247   90    KHEP=JMOHEP(2,JHEP)
6248         CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6249         CALL HWUMAS(PCL)
6250         IF (PCL(5).GT.CTHRPW(MAP(IDHW(JHEP)),MAP(IDHW(KHEP)))) THEN
6251           CALL HWCCUT(JHEP,KHEP,PCL,.FALSE.,SPLIT)
6252           IF (IERROR.NE.0) RETURN
6253           IF (SPLIT) GOTO 90
6254         ENDIF
6255       ENDIF
6256   100 CONTINUE
6257 C Third create clusters and store production vertex
6258   110 IBCL=NHEP+1
6259       JCL=NHEP
6260       DO 120 JHEP=IBHEP,NHEP
6261       IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6262      &    QORQQB(IDHW(JHEP))) THEN
6263         JCL=JCL+1
6264         IF(JCL.GT.NMXHEP) THEN
6265           CALL HWWARN('HWCFOR',105)
6266           GOTO 999
6267         ENDIF
6268         IDHW(JCL)=19
6269         IDHEP(JCL)=91
6270         KHEP=JMOHEP(2,JHEP)
6271         IF (KHEP.EQ.0.OR..NOT.(
6272      &      ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
6273      &      QBORQQ(IDHW(KHEP)))) THEN
6274           CALL HWWARN('HWCFOR',104)
6275           GOTO 999
6276         ENDIF
6277         CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PHEP(1,JCL))
6278         CALL HWUMAS(PHEP(1,JCL))
6279         IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(KHEP).EQ.153) THEN
6280           ISTHEP(JCL)=164
6281         ELSEIF (ISTHEP(JHEP).EQ.154.OR.ISTHEP(KHEP).EQ.154) THEN
6282           ISTHEP(JCL)=165
6283         ELSE
6284           ISTHEP(JCL)=163
6285         ENDIF
6286         JMOHEP(1,JCL)=JHEP
6287         JMOHEP(2,JCL)=KHEP
6288         JDAHEP(1,JCL)=0
6289         JDAHEP(2,JCL)=0
6290         JDAHEP(1,JHEP)=JCL
6291         JDAHEP(1,KHEP)=JCL
6292         ISTHEP(JHEP)=ISTHEP(JHEP)+8
6293         ISTHEP(KHEP)=ISTHEP(KHEP)+8
6294         CALL HWVEQU(4,VCLUS(1,JHEP),VHEP(1,JCL))
6295       ENDIF
6296   120 CONTINUE
6297       NHEP=JCL
6298 C Fix up momenta for single-hadron clusters
6299   130 DO 150 JCL=IBCL,NHEP
6300 C Don't hadronize beam/target clusters
6301       IF (ISTHEP(JCL).LT.163.OR.ISTHEP(JCL).GT.165) GOTO 150
6302       IF (ISTHEP(JCL).NE.163.AND.GENSOF) GOTO 150
6303 C Set up flavours for cluster decay
6304       CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
6305       EM0=PHEP(5,JCL)
6306       IF ((B1LIM.EQ.ZERO).OR.(ID1.NE.11.AND.ID3.NE.11)) THEN
6307         IF (EM0.GT.MIN(RMIN(ID1,1)+RMIN(1,ID3),
6308      $       RMIN(ID1,2)+RMIN(2,ID3))) GOTO 150
6309       ELSE
6310 C Special for b clusters: allow 1-hadron decay above threshold
6311         IF (B1LIM*HWRGEN(1).LT.EM0/(MIN(RMIN(ID1,1)+RMIN(1,ID3),
6312      $       RMIN(ID1,2)+RMIN(2,ID3)))-1.)
6313      &   GOTO 150
6314       ENDIF
6315       EM1=RMIN(ID1,ID3)
6316       IF (ABS(EM0-EM1).LT.1.D-5) GOTO 150
6317 C Decide to go backward or forward to transfer 4-momentum
6318       L=1-2*HWRINT(0,1)
6319       MCL=NHEP-IBCL+1
6320       LCL=JCL
6321       DO 140 I=1,MCL
6322       LCL=LCL+L
6323       IF (LCL.LT.IBCL) LCL=LCL+MCL
6324       IF (LCL.GT.NHEP) LCL=LCL-MCL
6325       IF (LCL.EQ.JCL) THEN
6326         IF (EM0.GE.EM1+RMIN(1,1)) GOTO 150
6327         CALL HWWARN('HWCFOR',101)
6328         GOTO 999
6329       ENDIF
6330       IF (ISTHEP(LCL).LT.163.OR.ISTHEP(LCL).GT.165) GOTO 140
6331 C Rescale momenta in 2-cluster CoM
6332       CALL HWVSUM(4,PHEP(1,JCL),PHEP(1,LCL),PCL)
6333       CALL HWUMAS(PCL)
6334       EM2=PHEP(5,LCL)
6335       PC0=HWUPCM(PCL(5),EM0,EM2)
6336       PC1=HWUPCM(PCL(5),EM1,EM2)
6337       IF (PC1.LT.ZERO) THEN
6338 C Need to rescale other mass as well
6339         CALL HWCFLA(IDHW(JMOHEP(1,LCL)),IDHW(JMOHEP(2,LCL)),ID1,ID3)
6340         EM2=RMIN(ID1,ID3)
6341         PC1=HWUPCM(PCL(5),EM1,EM2)
6342         IF (PC1.LT.ZERO) GOTO 140
6343         PHEP(5,LCL)=EM2
6344       ENDIF
6345       IF (PC0.GT.ZERO) THEN
6346         PC0=PC1/PC0
6347         CALL HWULOF(PCL,PHEP(1,JCL),PHEP(1,JCL))
6348         CALL HWVSCA(3,PC0,PHEP(1,JCL),PHEP(1,JCL))
6349         PHEP(4,JCL)=SQRT(PC1**2+EM1**2)
6350         PHEP(5,JCL)=EM1
6351         CALL HWULOB(PCL,PHEP(1,JCL),PHEP(1,JCL))
6352         CALL HWVDIF(4,PCL,PHEP(1,JCL),PHEP(1,LCL))
6353         GOTO 150
6354       ELSEIF (PC0.EQ.ZERO) THEN
6355         PHEP(5,JCL)=EM1
6356         CALL HWDTWO(PCL,PHEP(1,JCL),PHEP(1,LCL),PC1,TWO,.TRUE.)
6357         GOTO 150
6358       ELSE
6359         CALL HWWARN('HWCFOR',102)
6360         GOTO 999
6361       ENDIF
6362   140 CONTINUE
6363       CALL HWWARN('HWCFOR',103)
6364       GOTO 999
6365   150 CONTINUE
6366       ISTAT=60
6367 C Non-partons labelled as partons (ie photons) should get copied
6368       DO 160 IHEP=1,NHEP
6369       IF (ISTHEP(IHEP).EQ.150) THEN
6370         NHEP=NHEP+1
6371         JDAHEP(1,IHEP)=NHEP
6372         ISTHEP(IHEP)=157
6373         ISTHEP(NHEP)=190
6374         IDHW(NHEP)=IDHW(IHEP)
6375         IDHEP(NHEP)=IDPDG(IDHW(IHEP))
6376         CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
6377 C--MHS FIX 07/03/05 - VERTEX SHOULD BE RELATIVE TO FIXED AXES
6378         CALL HWVSUM(4,VTXPIP,VHEP(1,IHEP),VHEP(1,NHEP))
6379 C--END FIXES
6380         JMOHEP(1,NHEP)=IHEP
6381         JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
6382         JDAHEP(1,NHEP)=0
6383         JDAHEP(2,NHEP)=0
6384       ENDIF
6385   160 CONTINUE
6386  999  RETURN
6387       END
6388 CDECK  ID>, HWCGSP.
6389 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
6390 *-- Author :    Bryan Webber
6391 C-----------------------------------------------------------------------
6392       SUBROUTINE HWCGSP
6393 C-----------------------------------------------------------------------
6394 C     SPLITS ANY TIMELIKE GLUONS REMAINING AFTER PERTURBATIVE
6395 C     BRANCHING INTO LIGHT (I.E. U OR D) Q-QBAR PAIRS
6396 C-----------------------------------------------------------------------
6397       INCLUDE 'herwig65.inc'
6398       DOUBLE PRECISION HWRGEN,PF
6399       INTEGER HWRINT,IHEP,JHEP,KHEP,LHEP,MHEP,ID,J,IST
6400       EXTERNAL HWRGEN,HWRINT
6401       IF (NGSPL.EQ.0) CALL HWWARN('HWCGSP',400)
6402       LHEP=NHEP-1
6403       MHEP=NHEP
6404       DO 100 IHEP=1,NHEP
6405       IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.149) THEN
6406         JHEP=JMOHEP(2,IHEP)
6407 C BRW FIX 12/03/99
6408         IF (JHEP.LE.0) THEN
6409           KHEP=0
6410           DO JHEP=1,NHEP
6411             IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
6412      &      .AND.JDAHEP(2,JHEP).LE.0) THEN
6413               KHEP=KHEP+1
6414               JMOHEP(2,IHEP)=JHEP
6415               JDAHEP(2,JHEP)=IHEP
6416             ENDIF
6417           ENDDO
6418           IF (KHEP.EQ.0) THEN
6419             CALL HWWARN('HWCGSP',102)
6420             GOTO 999
6421           ENDIF
6422           IF (KHEP.NE.1) THEN
6423             CALL HWWARN('HWCGSP',103)
6424             GOTO 999
6425           ENDIF
6426         ENDIF
6427 C END FIX
6428 C---CHECK FOR DECAYED HEAVY ANTIQUARKS
6429         IF (ISTHEP(JHEP).EQ.155) THEN
6430           JHEP=JDAHEP(1,JDAHEP(2,JHEP))
6431           DO 10 J=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
6432   10      IF (ISTHEP(J).EQ.149.AND.JDAHEP(2,J).EQ.0) GOTO 20
6433           CALL HWWARN('HWCGSP',100)
6434           GOTO 999
6435   20      JHEP=J
6436         ENDIF
6437         KHEP=JDAHEP(2,IHEP)
6438 C BRW FIX 12/03/99
6439         IF (KHEP.LE.0) THEN
6440           KHEP=0
6441           DO JHEP=1,NHEP
6442             IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
6443      &      .AND.JMOHEP(2,JHEP).LE.0) THEN
6444               KHEP=KHEP+1
6445               JDAHEP(2,IHEP)=JHEP
6446               JMOHEP(2,JHEP)=IHEP
6447             ENDIF
6448           ENDDO
6449           IF (KHEP.EQ.0) THEN
6450             CALL HWWARN('HWCGSP',104)
6451             GOTO 999
6452           ENDIF
6453           IF (KHEP.NE.1) THEN
6454             CALL HWWARN('HWCGSP',105)
6455             GOTO 999
6456           ENDIF
6457           KHEP=JDAHEP(2,IHEP)
6458         ENDIF
6459 C END FIX
6460 C---CHECK FOR DECAYED HEAVY QUARKS
6461         IF (ISTHEP(KHEP).EQ.155)  THEN
6462           CALL HWWARN('HWCGSP',101)
6463           GOTO 999
6464         ENDIF
6465         IF (IDHW(IHEP).EQ.13) THEN
6466 C---SPLIT A GLUON
6467           LHEP=LHEP+2
6468           MHEP=MHEP+2
6469           IF(MHEP.GT.NMXHEP) THEN
6470             CALL HWWARN('HWCGSP',106)
6471             GOTO 999
6472           ENDIF
6473   30      ID=HWRINT(1,NGSPL)
6474           IF (PGSPL(ID).LT.PGSMX*HWRGEN(0)) GOTO 30
6475           PHEP(5,LHEP)=RMASS(ID)
6476           PHEP(5,MHEP)=RMASS(ID)
6477 C---ASSUME ISOTROPIC ANGULAR DISTRIBUTION
6478           IF (PHEP(5,IHEP).GT.PHEP(5,LHEP)+PHEP(5,MHEP)) THEN
6479             CALL HWDTWO(PHEP(1,IHEP),PHEP(1,LHEP),
6480      &                  PHEP(1,MHEP),PGSPL(ID),TWO,.TRUE.)
6481           ELSE
6482             PF=HWRGEN(1)
6483             CALL HWVSCA(4,PF,PHEP(1,IHEP),PHEP(1,LHEP))
6484             CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,LHEP),PHEP(1,MHEP))
6485             PHEP(5,LHEP)=PF*PHEP(5,IHEP)
6486             PHEP(5,MHEP)=PHEP(5,IHEP)-PHEP(5,LHEP)
6487           ENDIF
6488           CALL HWUDKL(13,PHEP(1,IHEP),VHEP(1,LHEP))
6489           CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,LHEP),VHEP(1,LHEP))
6490           CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
6491           IDHW(LHEP)=ID+6
6492           IDHW(MHEP)=ID
6493           IDHEP(MHEP)= IDPDG(ID)
6494           IDHEP(LHEP)=-IDPDG(ID)
6495           ISTHEP(IHEP)=2
6496           ISTHEP(LHEP)=150
6497           ISTHEP(MHEP)=150
6498 C---NEW COLOUR CONNECTIONS
6499           IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP) JMOHEP(2,KHEP)=LHEP
6500           IF(RPARTY.OR.JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=MHEP
6501           JMOHEP(1,LHEP)=JMOHEP(1,IHEP)
6502           JMOHEP(2,LHEP)=MHEP
6503           JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
6504           JMOHEP(2,MHEP)=JHEP
6505           JDAHEP(1,LHEP)=0
6506           JDAHEP(2,LHEP)=KHEP
6507           JDAHEP(1,MHEP)=0
6508           JDAHEP(2,MHEP)=LHEP
6509           JDAHEP(1,IHEP)=LHEP
6510           JDAHEP(2,IHEP)=MHEP
6511         ELSE
6512 C---COPY A NON-GLUON
6513           LHEP=LHEP+1
6514           MHEP=MHEP+1
6515           IF(MHEP.GT.NMXHEP) THEN
6516             CALL HWWARN('HWCGSP',107)
6517             GOTO 999
6518           ENDIF
6519           CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
6520           CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,MHEP))
6521           IDHW(MHEP)=IDHW(IHEP)
6522           IDHEP(MHEP)=IDHEP(IHEP)
6523           IST=ISTHEP(IHEP)
6524           ISTHEP(IHEP)=2
6525           IF (IST.EQ.149) THEN
6526             ISTHEP(MHEP)=150
6527           ELSE
6528             ISTHEP(MHEP)=IST+6
6529           ENDIF
6530 C---NEW COLOUR CONNECTIONS
6531           IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP)
6532      &      JMOHEP(2,KHEP)=MHEP
6533           IF(RPARTY.OR.(JHEP.NE.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP))
6534      &      JDAHEP(2,JHEP)=MHEP
6535           JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
6536           JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
6537           JDAHEP(1,MHEP)=0
6538           JDAHEP(2,MHEP)=JDAHEP(2,IHEP)
6539           JDAHEP(1,IHEP)=MHEP
6540         ENDIF
6541       ENDIF
6542   100 CONTINUE
6543       NHEP=MHEP
6544  999  RETURN
6545       END
6546 CDECK  ID>, HWCHAD.
6547 *CMZ :-        -26/04/91  14.00.57  by  Federico Carminati
6548 *-- Author :    Bryan Webber
6549 C-----------------------------------------------------------------------
6550       SUBROUTINE HWCHAD(JCL,ID1,ID3,ID2)
6551 C-----------------------------------------------------------------------
6552 C     HADRONIZES CLUSTER JCL, CONSISTING OF PARTONS ID1,ID3
6553 C     ID2 RETURNS PARTON-ANTIPARTON PAIR CREATED
6554 C     (IN SPECIAL CLUSTER CODE - SEE HWCFLA)
6555 C
6556 C MODIFIED 15/11/99 TO SMEAR POSITIONS OF HADRONS BY 1/(CLUSTER MASS)
6557 C-----------------------------------------------------------------------
6558       INCLUDE 'herwig65.inc'
6559       DOUBLE PRECISION HWRGEN,HWRGAU,HWVDOT,EM0,EM1,EM2,EMADU,EMSQ,
6560      & PCMAX,PCM,PTEST,PCQK,PP(5),EMLOW,RMAT(3,3),CT,ST,CX,SX,HPSMR
6561       INTEGER HWRINT,JCL,ID1,ID2,ID3,ID,IR1,IR2,NTRY,IDMIN,IMAX,I,MHEP,
6562      & IM,JM,KM,IB
6563       LOGICAL DIQK
6564       EXTERNAL HWRGEN,HWRINT
6565       DIQK(ID)=ID.GT.3.AND.ID.LT.10
6566       IF (IERROR.NE.0) RETURN
6567       ID2=0
6568       EM0=PHEP(5,JCL)
6569       IF (LOCN(ID1,ID3).LE.0) THEN
6570         CALL HWWARN('HWCHAD',104)
6571         GOTO 999
6572       ENDIF
6573       IR1=NCLDK(LOCN(ID1,ID3))
6574       EM1=RMIN(ID1,ID3)
6575       IF (ABS(EM0-EM1).LT.0.001) THEN
6576 C---SINGLE-HADRON CLUSTER
6577         NHEP=NHEP+1
6578         IF (NHEP.GT.NMXHEP) THEN
6579           CALL HWWARN('HWCHAD',100)
6580           GOTO 999
6581         ENDIF
6582         IDHW(NHEP)=IR1
6583         IDHEP(NHEP)=IDPDG(IR1)
6584         ISTHEP(NHEP)=191
6585         JDAHEP(1,JCL)=NHEP
6586         JDAHEP(2,JCL)=NHEP
6587         CALL HWVEQU(5,PHEP(1,JCL),PHEP(1,NHEP))
6588         CALL HWVSUM(4,VHEP(1,JCL),VTXPIP,VHEP(1,NHEP))
6589       ELSE
6590         NTRY=0
6591         IDMIN=1
6592         EMLOW=RMIN(ID1,1)+RMIN(1,ID3)
6593         EMADU=RMIN(ID1,2)+RMIN(2,ID3)
6594         IF (EMADU.LT.EMLOW) THEN
6595           IDMIN=2
6596           EMLOW=EMADU
6597         ENDIF
6598         EMSQ=EM0**2
6599         PCMAX=EMSQ-EMLOW**2
6600         IF (PCMAX.GE.ZERO) THEN
6601 C---SET UP TWO QUARK-ANTIQUARK PAIRS OR A
6602 C   QUARK-DIQUARK AND AN ANTIDIQUARK-ANTIQUARK
6603           PCMAX=PCMAX*(EMSQ-(RMIN(ID1,IDMIN)-RMIN(IDMIN,ID3))**2)
6604           IMAX=12
6605           IF (DIQK(ID1).OR.DIQK(ID3)) IMAX=3
6606           DO 10 I=3,IMAX
6607           IF (EM0.LT.RMIN(ID1,I)+RMIN(I,ID3)) GOTO 20
6608   10      CONTINUE
6609           I=IMAX+1
6610   20      ID2=HWRINT(1,I-1)
6611           IF (PWT(ID2).NE.ONE) THEN
6612             IF (PWT(ID2).LT.HWRGEN(1)) GOTO 20
6613           ENDIF
6614 C---PICK TWO PARTICLES WITH THESE QUANTUM NUMBERS
6615           NTRY=NTRY+1
6616   30      IR1=LOCN(ID1,ID2)+INT(RESN(ID1,ID2)*HWRGEN(2))
6617           IF (CLDKWT(IR1).LT.HWRGEN(3)) GOTO 30
6618           IR1=NCLDK(IR1)
6619   40      IR2=LOCN(ID2,ID3)+INT(RESN(ID2,ID3)*HWRGEN(4))
6620           IF (CLDKWT(IR2).LT.HWRGEN(5)) GOTO 40
6621           IR2=NCLDK(IR2)
6622           EM1=RMASS(IR1)
6623           EM2=RMASS(IR2)
6624           PCM=EMSQ-(EM1+EM2)**2
6625           IF (PCM.GT.ZERO) GOTO 70
6626           IF (NTRY.LE.NDTRY) GOTO 20
6627 C---CAN'T FIND A DECAY MODE - CHOOSE LIGHTEST
6628   60      ID2=HWRINT(1,2)
6629           IR1=NCLDK(LOCN(ID1,ID2))
6630           IR2=NCLDK(LOCN(ID2,ID3))
6631           EM1=RMASS(IR1)
6632           EM2=RMASS(IR2)
6633           PCM=EMSQ-(EM1+EM2)**2
6634           IF (PCM.GT.ZERO) GOTO 70
6635           NTRY=NTRY+1
6636           IF (NTRY.LE.NDTRY+50) GOTO 60
6637           CALL HWWARN('HWCHAD',101)
6638           GOTO 999
6639 C---DECAY IS ALLOWED
6640   70      PCM=PCM*(EMSQ-(EM1-EM2)**2)
6641           IF (NTRY.GT.NCTRY) GOTO 80
6642           PTEST=PCM*SWTEF(IR1)*SWTEF(IR2)
6643           IF (PTEST.LT.PCMAX*HWRGEN(0)**2) GOTO 20
6644         ELSE
6645 C---ALLOW DECAY BY PI0 EMISSION IF ONLY POSSIBILITY
6646           ID2=1
6647           IR2=NCLDK(LOCN(1,1))
6648           EM2=RMASS(IR2)
6649           PCM=(EMSQ-(EM1+EM2)**2)*(EMSQ-(EM1-EM2)**2)
6650         ENDIF
6651 C---DECAY IS CHOSEN.  GENERATE DECAY MOMENTA
6652 C   AND PUT PARTICLES IN /HEPEVT/
6653   80    IF (PCM.LT.ZERO) THEN
6654           CALL HWWARN('HWCHAD',102)
6655           GOTO 999
6656         ENDIF
6657         PCM=0.5*SQRT(PCM)/EM0
6658         MHEP=NHEP+1
6659         NHEP=NHEP+2
6660         IF (NHEP.GT.NMXHEP) THEN
6661           CALL HWWARN('HWCHAD',103)
6662           GOTO 999
6663         ENDIF
6664         PHEP(5,MHEP)=EM1
6665         PHEP(5,NHEP)=EM2
6666 C Decide if cluster contains a b-(anti)quark or not
6667         IF (ID1.EQ.11.OR.ID2.EQ.11.OR.ID3.EQ.11) THEN
6668           IB=2
6669         ELSE
6670           IB=1
6671         ENDIF
6672         IF (CLDIR(IB).NE.0) THEN
6673           DO 110 IM=1,2
6674             JM=JMOHEP(IM,JCL)
6675             IF (JM.EQ.0) GOTO 110
6676             IF (ISTHEP(JM).NE.158) GOTO 110
6677 C   LOOK FOR PARENT PARTON
6678             DO 100 KM=JMOHEP(1,JM)+1,JM
6679               IF (ISTHEP(KM).EQ.2) THEN
6680                 IF (JDAHEP(1,KM).EQ.JM) THEN
6681 C   FOUND PARENT PARTON
6682                   IF (IDHW(KM).NE.13) THEN
6683 C   FIND ITS DIRECTION IN CLUSTER CMF
6684                    CALL HWULOF(PHEP(1,JCL),PHEP(1,KM),PP)
6685                    PCQK=PP(1)**2+PP(2)**2+PP(3)**2
6686                    IF (PCQK.GT.ZERO) THEN
6687                     PCQK=SQRT(PCQK)
6688                     IF (CLSMR(IB).GT.ZERO) THEN
6689 C   DO GAUSSIAN SMEARING OF DIRECTION
6690   90                 CT=ONE+CLSMR(IB)*LOG(HWRGEN(0))
6691                      IF (CT.LT.-ONE) GOTO 90
6692                      ST=ONE-CT*CT
6693                      IF (ST.GT.ZERO) ST=SQRT(ST)
6694                      CALL HWRAZM( ONE,CX,SX)
6695                      CALL HWUROT(PP,CX,SX,RMAT)
6696                      PP(1)=ZERO
6697                      PP(2)=PCQK*ST
6698                      PP(3)=PCQK*CT
6699                      CALL HWUROB(RMAT,PP,PP)
6700                     ENDIF
6701                     PCQK=PCM/PCQK
6702                     IF (IM.EQ.2) PCQK=-PCQK
6703                     CALL HWVSCA(3,PCQK,PP,PHEP(1,MHEP))
6704                     PHEP(4,MHEP)=SQRT(PHEP(5,MHEP)**2+PCM**2)
6705                     CALL HWULOB(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,MHEP))
6706                     CALL HWVDIF(4,PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP))
6707                     GOTO 130
6708                    ENDIF
6709                   ENDIF
6710                   GOTO 120
6711                 ENDIF
6712               ELSEIF (ISTHEP(KM).GT.140) THEN
6713 C   FINISHED THIS JET
6714                 GOTO 110
6715               ENDIF
6716  100        CONTINUE
6717  110      CONTINUE
6718         ENDIF
6719  120    CALL HWDTWO(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP),
6720      &              PCM,TWO,.TRUE.)
6721  130    IDHW(MHEP)=IR1
6722         IDHW(NHEP)=IR2
6723         IDHEP(MHEP)=IDPDG(IR1)
6724         IDHEP(NHEP)=IDPDG(IR2)
6725         ISTHEP(MHEP)=192
6726         ISTHEP(NHEP)=192
6727         JMOHEP(1,MHEP)=JCL
6728 C---SECOND MOTHER OF HADRON IS JET
6729         JMOHEP(2,MHEP)=JMOHEP(1,JMOHEP(1,JCL))
6730         JDAHEP(1,JCL)=MHEP
6731         JDAHEP(2,JCL)=NHEP
6732 C---SMEAR HADRON POSITIONS
6733         HPSMR=GEV2MM/PHEP(5,JCL)
6734         DO I=1,4
6735           VHEP(I,MHEP)=HWRGAU(I,ZERO,HPSMR)
6736         ENDDO
6737         VHEP(4,MHEP)=ABS(VHEP(4,MHEP))
6738      &           +SQRT(HWVDOT(3,VHEP(1,MHEP),VHEP(1,MHEP)))
6739         CALL HWULB4(PHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
6740         CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
6741         CALL HWVSUM(4,VTXPIP,VHEP(1,MHEP),VHEP(1,MHEP))
6742         DO I=1,4
6743           VHEP(I,NHEP)=HWRGAU(I,ZERO,HPSMR)
6744         ENDDO
6745         VHEP(4,NHEP)=ABS(VHEP(4,NHEP))
6746      &           +SQRT(HWVDOT(3,VHEP(1,NHEP),VHEP(1,NHEP)))
6747         CALL HWULB4(PHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
6748         CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
6749         CALL HWVSUM(4,VTXPIP,VHEP(1,NHEP),VHEP(1,NHEP))
6750       ENDIF
6751       ISTHEP(JCL)=180+MOD(ISTHEP(JCL),10)
6752       JMOHEP(1,NHEP)=JCL
6753       JMOHEP(2,NHEP)=JMOHEP(1,JMOHEP(1,JCL))
6754  999  RETURN
6755       END
6756 CDECK  ID>, HWD2ME.
6757 *CMZ :-        -09/04/02  13:37:38  by  Peter Richardson
6758 *-- Author :    Peter Richardson
6759 C-----------------------------------------------------------------------
6760       SUBROUTINE HWD2ME(IMODE)
6761 C-----------------------------------------------------------------------
6762 C     Computes the width and maximum weight for a two body mode
6763 C-----------------------------------------------------------------------
6764       INCLUDE 'herwig65.inc'
6765       INTEGER IMODE,I
6766       DOUBLE PRECISION A(2),M(3),PCM,E1,E2,HWUPCM,PHS,WGT,MWGT,PCM2,
6767      &     M2(3)
6768       EXTERNAL HWUPCM
6769 C--set up the masses and couplings
6770       M(1) = RMASS(IDK(ID2PRT(IMODE)))
6771       DO 1 I=1,2
6772       A(I)   = A2MODE(I,IMODE)
6773  1    M(I+1) = RMASS(IDKPRD(I,ID2PRT(IMODE)))
6774       DO 2 I=1,3
6775  2    M2(I)  = M(I)**2
6776 C--first compute the masses etc
6777       PCM = HWUPCM(M(1),M(2),M(3))
6778       PCM2 = PCM**2
6779       PHS = PCM/M2(1)/8.0D0/PIFAC
6780 C--now compute the width and max weight
6781 C--first the fermion --> fermion scalar diagrams
6782       IF(I2DRTP(IMODE).EQ.1) THEN
6783         WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(2)-M2(3))
6784      &              +FOUR*A(1)*A(2)*M(1)*M(2))
6785         E1 = SQRT(M2(2)+PCM2)
6786         E2 = SQRT(M2(3)+PCM2)
6787         MWGT = HALF*M2(1)/(E1+E2)*(E1+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6788 C--next the fermion --> scalar fermion   diagrams
6789       ELSEIF(I2DRTP(IMODE).EQ.2) THEN
6790         WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6791      &              +FOUR*A(1)*A(2)*M(1)*M(3))
6792         E1 = SQRT(M2(2)+PCM2)
6793         E2 = SQRT(M2(3)+PCM2)
6794         MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6795 C--next the fermion --> scalar antifermion   diagrams
6796       ELSEIF(I2DRTP(IMODE).EQ.3) THEN
6797         WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6798      &              +FOUR*A(1)*A(2)*M(1)*M(3))
6799         E1 = SQRT(M2(2)+PCM2)
6800         E2 = SQRT(M2(3)+PCM2)
6801         MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6802 C--next the fermion --> fermion gauge boson diagrams
6803       ELSEIF(I2DRTP(IMODE).EQ.4) THEN
6804         WGT = 2.0D0*(M2(1)-M2(2))**2
6805         MWGT = WGT
6806 C--next the scalar --> fermion antifermion diagrams
6807       ELSEIF(I2DRTP(IMODE).EQ.5) THEN
6808         WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6809      &        -FOUR*M(2)*M(3)*A(1)*A(2)
6810         MWGT = WGT
6811 C--next the scalar --> fermion fermion diagrams
6812       ELSEIF(I2DRTP(IMODE).EQ.6) THEN
6813         WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6814      &        -FOUR*M(2)*M(3)*A(1)*A(2)
6815         MWGT = WGT
6816 C--next the fermion --> fermion pion diagrams
6817       ELSEIF(I2DRTP(IMODE).EQ.7) THEN
6818         WGT = HALF/FOUR/RMASS(198)**4*(
6819      &        (A(1)**2+A(2)**2)*((M2(1)-M2(2))**2-M2(3)*(M2(1)+M2(2)))
6820      &         +FOUR*M(1)*M(2)*M2(3)*A(1)*A(2))
6821         E1 = SQRT(M2(2)+PCM2)
6822         E2 = SQRT(M2(3)+PCM2)
6823         MWGT =ONE/8.0D0/RMASS(198)**4*ABS(A(1)**2-A(2)**2)*
6824      &        M(1)*(M(1)*M2(3)+(M2(1)-M2(2)+M2(3))*(E2+PCM))+WGT
6825 C--next scalar --> antifermion fermion diagrams
6826       ELSEIF(I2DRTP(IMODE).EQ.8) THEN
6827         WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6828      &        -FOUR*M(2)*M(3)*A(1)*A(2)
6829         MWGT = WGT
6830 C--next fermion --> gravitino photon
6831       ELSEIF(I2DRTP(IMODE).EQ.9) THEN
6832         WGT = 8.0D0*M2(1)**3
6833         MWGT = WGT
6834 C--next fermion --> gravitino scalar
6835       ELSEIF(I2DRTP(IMODE).EQ.10) THEN
6836         WGT = HALF*(M2(1)-M2(3))**3
6837         E1 = SQRT(M2(2)+PCM2)
6838         E2 = SQRT(M2(3)+PCM2)
6839         MWGT = TWO*M2(1)/(E1+E2)*(E1+PCM)*(M2(1)-M2(3))**2 +WGT
6840 C--next sfermion --> fermion gravitino
6841       ELSEIF(I2DRTP(IMODE).EQ.11) THEN
6842         WGT = (M2(1)-M2(2))**3
6843         MWGT = WGT
6844 C--next antisfermion --> fermion gravitino
6845       ELSEIF(I2DRTP(IMODE).EQ.12) THEN
6846         WGT = (M2(1)-M2(2))**3
6847         MWGT = WGT
6848 C--next the scalar --> antifermion antifermion diagrams
6849       ELSEIF(I2DRTP(IMODE).EQ.13) THEN
6850         WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6851      &        -FOUR*M(2)*M(3)*A(1)*A(2)
6852         MWGT = WGT
6853 C--next the antifermion --> scalar antifermion diagrams
6854       ELSEIF(I2DRTP(IMODE).EQ.14) THEN
6855         WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6856      &              +FOUR*A(1)*A(2)*M(1)*M(3))
6857         E1 = SQRT(M2(2)+PCM2)
6858         E2 = SQRT(M2(3)+PCM2)
6859         MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6860 C--unrecognised issue warning
6861       ELSE
6862         CALL HWWARN('HWITWO',500)
6863       ENDIF
6864       WGT  =       P2MODE(IMODE)* WGT*PHS
6865       MWGT = 1.1D0*P2MODE(IMODE)*MWGT*PHS
6866 C--put the information in the common block
6867       WT2MAX(IMODE) = MWGT
6868 C--output the information
6869       IF(IPRINT.EQ.2) THEN
6870         WRITE(*,3010) WGT
6871         WRITE(*,3020) MWGT
6872         WRITE(*,3030) WGT/HBAR/BRFRAC(ID2PRT(IMODE))*
6873      &       RLTIM(IDK(ID2PRT(IMODE)))
6874       ENDIF
6875       RETURN
6876 C--format statements
6877  3010 FORMAT('            PARTIAL WIDTH  = ',G12.4)
6878  3020 FORMAT('            MAXIMUM WEIGHT = ',E12.4)
6879  3030 FORMAT('     RATIO TO ISAJET VALUE = ',G12.4)
6880       END
6881 CDECK  ID>, HWD3ME.
6882 *CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
6883 *-- Author :    Peter Richardson
6884 C-----------------------------------------------------------------------
6885       SUBROUTINE HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
6886 C-----------------------------------------------------------------------
6887 C     Subroutine to perform the three body decays for spin correlations
6888 C     and SUSY three body modes
6889 C-----------------------------------------------------------------------
6890       INCLUDE 'herwig65.inc'
6891       INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE,NDIA,ID1,ID2,
6892      &     DRTYPE(NDIAGR),NTRY,IDSPIN,NCTHRE,DRCF(NDIAGR)
6893       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,M342,HWRUNI,
6894      &     HWUPCM,M232,M242,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,
6895      &     BRW(6),BRZ(12),P(5,4),PM(5,4),WGTM,CFTHRE(NCFMAX,NCFMAX)
6896       DOUBLE COMPLEX S,D,RHOIN(2,2),F0(2,2,8),F3(2,2,8),F1(2,2,8),
6897      &     F2(2,2,8),F0M(2,2,8),F1M(2,2,8),F01(2,2,8,8)
6898       EXTERNAL HWRUNI,HWUPCM,HWRGEN
6899       COMMON/HWHEWS/S(8,8,2),D(8,8)
6900       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
6901      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
6902      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
6903       SAVE BRW,BRZ
6904       DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
6905       DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
6906      &         0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
6907 C--compute the masses of external particles for the decay mode
6908 C--first for true three body decay modes
6909       IF(ITYPE.EQ.0) THEN
6910 C--initalisation for the diagrams
6911         WTMAX  = WT3MAX(IMODE)
6912         PRE    = P3MODE(IMODE)
6913         NCTHRE = N3NCFL(IMODE)
6914         NDIA   = NDI3BY(IMODE)
6915         IDP(1) = IDK(ID3PRT(IMODE))
6916         DO 1 I=1,3
6917  1      IDP(I+1) = IDKPRD(I,ID3PRT(IMODE))
6918         DO 2 I=1,NCTHRE
6919         DO 2 J=1,NCTHRE
6920  2      CFTHRE(I,J) = SPN3CF(I,J,IMODE)
6921 C--enter the couplings for the diagrams
6922         DO 3 I=1,NDI3BY(IMODE)
6923         DRTYPE(I) = I3DRTP(I,IMODE)
6924         DRCF  (I) = I3DRCF(I,IMODE)
6925         DO 3 J=1,2
6926         A(J,I) = A3MODE(J,I,IMODE)
6927  3      B(J,I) = B3MODE(J,I,IMODE)
6928 C--enter the intermediate masses for the diagrams
6929         DO 4 I=1,NDI3BY(IMODE)
6930         IDP(I+4) = I3MODE(I,IMODE)
6931         MR(I)  = RMASS(I3MODE(I,IMODE))
6932         MS(I)  = MR(I)**2
6933         IF(I3MODE(I,IMODE).GT.200) THEN
6934           MWD(I) = RMASS(I3MODE(I,IMODE))*HBAR/RLTIM(I3MODE(I,IMODE))
6935         ELSEIF(I3MODE(I,IMODE).EQ.200) THEN
6936           MWD(I) = RMASS(200)*GAMZ
6937         ELSEIF(I3MODE(I,IMODE).EQ.198.OR.I3MODE(I,IMODE).EQ.199) THEN
6938           MWD(I) = RMASS(198)*GAMW
6939         ELSEIF(I3MODE(I,IMODE).EQ.59) THEN
6940           MWD(I) = 0.0D0
6941         ENDIF
6942  4      CONTINUE
6943 C--reorder for top quark decay modes(b first then W products)
6944         IF(IDP(1).EQ.6.OR.IDP(1).EQ.12) THEN
6945           I = IDP(2)
6946           IDP(2) = IDP(4)
6947           IDP(4) = IDP(3)
6948           IDP(3) = I
6949         ENDIF
6950 C--reorder if fermion not first
6951         IF(IDP(3).GT.IDP(4).AND.((IDP(1).EQ.6.OR.IDP(1).EQ.12).OR.
6952      &     IDP(2).GE.400)) THEN
6953           I = IDP(3)
6954           IDP(3) = IDP(4)
6955           IDP(4) = I
6956         ENDIF
6957 C--then for two body modes to gauge bosons including boson decays
6958       ELSE
6959 C--initalisation for the diagram
6960         WTMAX       = WTBMAX(ITYPE,IMODE)
6961         NDIA        = 1
6962         PRE         = PBMODE(ITYPE,IMODE)
6963         DRTYPE(1)   = IBDRTP(IMODE)
6964         DRCF  (1)   = 1
6965         NCTHRE      = 1
6966         CFTHRE(1,1) = ONE
6967 C--particles in decay
6968         IDP(1) = IDK(IDBPRT(IMODE))
6969         IDP(2) = IDKPRD(1,IDBPRT(IMODE))
6970         IF(IDP(2).GE.198.AND.IDP(2).LE.200)
6971      &       IDP(2) = IDKPRD(2,IDBPRT(IMODE))
6972         IDP(5) = IBMODE(IMODE)
6973 C--masses of virtual particles and couplings
6974         MR(1) = RMASS(IBMODE(IMODE))
6975         MS(1) = MR(1)**2
6976         DO J=1,2
6977           A(J,1) = ABMODE(J,IMODE)
6978           B(J,1) = BBMODE(J,ITYPE,IMODE)
6979         ENDDO
6980         IF(IBMODE(IMODE).EQ.200) THEN
6981           MWD(1) = RMASS(200)*GAMZ
6982         ELSE
6983           MWD(1) = RMASS(198)*GAMW
6984         ENDIF
6985 C--particles from boson decay
6986         IF(IBMODE(IMODE).EQ.200) THEN
6987           ID1 = ITYPE
6988           IF(ITYPE.GT.6) ID1 = ID1+114
6989           ID2 = ID1+6
6990         ELSE
6991           ID1 = 2*ITYPE-1
6992           IF(ITYPE.GT.3) ID1 = ID1+114
6993           ID2 = ID1+7
6994           IF(IBMODE(IMODE).EQ.198) THEN
6995             I   = ID1+6
6996             ID1 = ID2-6
6997             ID2 = I
6998           ENDIF
6999         ENDIF
7000         IDP(3) = ID1
7001         IDP(4) = ID2
7002 C--only do the decay if possible for an on-shell boson
7003         IF(RMASS(ID1)+RMASS(ID2).GT.MR(1)) RETURN
7004         IF(IPRINT.EQ.2.AND..NOT.GENEV)
7005      &        WRITE(6,3000) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4))
7006         MA(3) = RMASS(IDP(3))
7007         MA(4) = RMASS(IDP(4))
7008         DO 5 I=1,4
7009  5      MA2(I) = MA(I)**2
7010       ENDIF
7011 C--set up the masses MA OFF SHELL MB ON SHELL
7012       DO 6 I=1,4
7013         MB(I) = RMASS(IDP(I))
7014         MB2(I) = MB(I)**2
7015         IF(.NOT.GENEV) THEN
7016           MA (I) = MB (I)
7017           MA2(I) = MB2(I)
7018         ENDIF
7019  6    CONTINUE
7020       IF(MA(1).LT.MA(2)+MA(3)+MA(4)) RETURN
7021 C--compute the width and maximum weight if initialising
7022       IF(.NOT.GENEV) THEN
7023 C--search for maximum weight
7024         WMAX  = ZERO
7025         WSUM  = ZERO
7026         WSSUM = ZERO
7027         DO 7 I=1,NSEARCH
7028           CALL HWD3M0(1,NDIA,WGT,WGTM,RHOIN,IDSPIN)
7029           WGT = WGT*PRE
7030           WGTM=WGTM*PRE
7031           IF(WGTM.GT.WMAX) WMAX = WGTM
7032           WSUM = WSUM+WGT
7033           WSSUM = WSSUM+WGT**2
7034           IF(WGT.LT.ZERO) CALL HWWARN('HWD3ME',500)
7035  7      CONTINUE
7036 C--compute width and maximum weight
7037         WSUM = WSUM/DBLE(NSEARCH)
7038         WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
7039         WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
7040 C--if required output results
7041         IF(IPRINT.EQ.2) THEN
7042           WRITE(6,3010) WSUM,WSSUM
7043           WRITE(6,3020) WMAX
7044           IF(ITYPE.EQ.0) THEN
7045             TEMP = BRFRAC(ID3PRT(IMODE))*HBAR/RLTIM(IDK(ID3PRT(IMODE)))
7046           ELSE
7047             IF(IBMODE(IMODE).EQ.200) THEN
7048               TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
7049      &              RLTIM(IDK(IDBPRT(IMODE)))*BRZ(ITYPE)
7050             ELSE
7051               TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
7052      &              RLTIM(IDK(IDBPRT(IMODE)))*BRW(ITYPE)
7053             ENDIF
7054           ENDIF
7055           WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
7056         ENDIF
7057 C--set up the maximum weight
7058         IF(ITYPE.EQ.0) THEN
7059           WT3MAX(IMODE)       = 1.1D0*WMAX
7060         ELSE
7061           WTBMAX(ITYPE,IMODE) = 1.1D0*WMAX
7062         ENDIF
7063 C--if not initialising generate the momenta
7064       ELSE
7065 C--generate a configuation
7066         NTRY = 0
7067  100    NTRY = NTRY+1
7068         CALL HWD3M0(ID,NDIA,WGT,WGTM,RHOIN,IDSPIN)
7069         WGT = WGT*PRE
7070 C--check maximum isn't violated, increase and issue warning if it is
7071         IF(WGT.GT.WTMAX) THEN
7072           CALL HWWARN('HWD3ME',1)
7073           IF(ITYPE.EQ.0) THEN
7074             WRITE(6,3040) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(3)),
7075      &            RNAME(IDP(4)),WTMAX,WGT*1.1D0
7076           ELSE
7077             WRITE(6,3050) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(5))
7078             WRITE(6,3060) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4)),
7079      &           WTMAX,WGT*1.1D0
7080           ENDIF
7081           WTMAX = WGT*1.1D0
7082           IF(ITYPE.EQ.0) THEN
7083             WT3MAX(IMODE) = WTMAX
7084           ELSE
7085             WTBMAX(ITYPE,IMODE) = WTMAX
7086           ENDIF
7087         ENDIF
7088         IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
7089         IF(NTRY.GE.NSNTRY) THEN
7090           CALL HWWARN('HWD3ME',100)
7091           GOTO 999
7092         ENDIF
7093       ENDIF
7094       RETURN
7095 C--format statements for the outputs
7096  3000 FORMAT(/'  FOLLOWED BY ',A8,' --> ',A8,' ',A8)
7097  3010 FORMAT('            PARTIAL WIDTH  = ',G12.4,' +/- ',G12.4)
7098  3020 FORMAT('            MAXIMUM WEIGHT = ',E12.4)
7099  3030 FORMAT('     RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
7100  3040 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8,' ',A8,
7101      &     'EXCEEDS MAX',
7102      &       /10X,'    MAXIMUM WEIGHT =',1PG24.16,
7103      &       /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
7104  3050 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8)
7105  3060 FORMAT(/'  FOLLOWED BY ',A8,' --> ',A8,' ',A8,' EXCEEDS MAX',
7106      &       /10X,'    MAXIMUM WEIGHT =',1PG24.16,
7107      &       /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
7108  999  RETURN
7109       END
7110 CDECK  ID>, HWD3M0.
7111 *CMZ :-        -09/04/02  13:46:07  by  Peter Richardson
7112 *-- Author :    Peter Richardson
7113 C-----------------------------------------------------------------------
7114       SUBROUTINE HWD3M0(ID,NDIA,WGT,MWGT,RHOIN,IDSPIN)
7115 C-----------------------------------------------------------------------
7116 C     Subroutine to calculate the matrix element for a given mode
7117 C-----------------------------------------------------------------------
7118       INCLUDE 'herwig65.inc'
7119       INTEGER I,J,P0,P1,P2,P3,P0P,IB,ID,IDP(4+NDIAGR),IDSPIN,NDIA,
7120      &     DRTYPE(NDIAGR),NCTHRE,DRCF(NDIAGR)
7121       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,FJAC,M342,HWRUNI,
7122      &     M34,PCMA,PCMB,HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,PTMP(5),
7123      &     M232,M242,PRE,PLAB,PRW,XMASS,PCM,P(5,4),PM(5,4),MR,PREF(5),
7124      &     MMIN,MMAX,MWGT,CFTHRE(NCFMAX,NCFMAX),WGTB(NCFMAX),WGTC,
7125      &     HWRGEN,A02,A2
7126       DOUBLE COMPLEX S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F01(2,2,8,8),
7127      &     RHOIN(2,2),F0(2,2,8),F1(2,2,8),F2(2,2,8),F0M(2,2,8),
7128      &     RHOB(2,2),F1M(2,2,8),F3(2,2,8)
7129       EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRGEN
7130       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7131       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7132      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7133      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7134       COMMON/HWHEWS/S(8,8,2),D(8,8)
7135       PARAMETER(EPS=1D-10)
7136       SAVE PREF
7137       DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
7138 C--select the momenta of the particles
7139 C--first see if there is a boson mode
7140       IB = -1
7141       DO 1 I=1,NDIA
7142         IF(DRTYPE(I).EQ.1.OR.DRTYPE(I).EQ.5.OR.DRTYPE(I).EQ.6.OR.
7143      &     DRTYPE(I).EQ.7) IB = IDP(I+4)
7144  1    CONTINUE
7145 C--compute the mass of the 34 subsystem flat if no boson otherwise Breit-Wigner
7146       MMIN = (MA(3)+MA(4))**2
7147       MMAX = (MA(1)-MA(2))**2
7148       IF(IB.GT.0.AND.IB.NE.59) THEN
7149         CALL HWHGB1(1,2,IB,FJAC,M342,MMAX,MMIN)
7150       ELSEIF(IB.EQ.59) THEN
7151          M342 = HWRUNI(1,LOG(MMIN),LOG(MMAX))
7152          M342 = EXP(M342)
7153          FJAC = (LOG(MMAX)-LOG(MMIN))*M342
7154       ELSEIF((DRTYPE(1).EQ.2.OR.DRTYPE(1).EQ.17).AND.
7155      &        IDP(5).EQ.206.OR.IDP(5).EQ.207) THEN
7156         A02   = ATAN((MMIN-MS(1))/MWD(1))
7157         A2    = ATAN((MMAX-MS(1))/MWD(1))-A02
7158         M342  = MS(1)+MWD(1)*TAN(A02+A2*HWRGEN(1))
7159         FJAC  = A2*((M342-MS(1))**2+MWD(1)**2)/MWD(1)
7160       ELSE
7161         FJAC = MMAX-MMIN
7162         M342 = HWRUNI(1,MMIN,MMAX)
7163       ENDIF
7164       M34 = SQRT(M342)
7165       FJAC = HALF*FJAC/M34
7166 C--copy the momentum of the decaying particle into the internal common block
7167       CALL HWVEQU(5,PHEP(1,ID),P(1,1))
7168       DO 2 I=2,4
7169  2    P(5,I) = MA(I)
7170 C--perform the decay 1---> 2+34
7171       PCMA = HWUPCM(MA(1),MA(2),M34)
7172       PLAB(5,1) = M34
7173       CALL HWDTWO(P(1,1),PLAB(1,1),P(1,2),PCMA,2.0D0,.TRUE.)
7174 C--perform the decay 34 --> 3+4
7175       PCMB = HWUPCM(M34,MA(3),MA(4))
7176       CALL HWDTWO(PLAB(1,1),P(1,3),P(1,4),PCMB,2.0D0,.TRUE.)
7177 C--compute the phase sapce factors
7178       PHS = PCMA*PCMB*FJAC/32.0D0/PIFAC**3/MA2(1)
7179 C--compute the other possible masses for the propagator
7180       M232 = MA2(2)+MA2(3)+TWO*HWULDO(P(1,2),P(1,3))
7181       M242 = MA2(2)+MA2(4)+TWO*HWULDO(P(1,2),P(1,4))
7182 C--compute the vectors for the helicity amplitudes
7183       DO 3 I=1,4
7184 C--compute the references vectors
7185 C--not important if SM particle which can't have spin measured
7186 C--ie anything other the top and tau
7187 C--also not important if particle is approx massless
7188 C--first the SM particles other than top and tau
7189       IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
7190      &                .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
7191         CALL HWVEQU(5,PREF,PLAB(1,I+4))
7192 C--all other particles
7193       ELSE
7194         PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
7195         CALL HWVSCA(3,ONE/PP,P(1,I),N)
7196         PLAB(4,I+4) = HALF*(P(4,I)-PP)
7197         PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
7198         CALL HWVSCA(3,PP,N,PLAB(1,I+4))
7199         CALL HWUMAS(PLAB(1,I+4))
7200         PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
7201 C--fix to avoid problems if approx massless due to energy
7202         IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
7203       ENDIF
7204 C--now the massless vectors
7205       PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
7206       DO 4 J=1,4
7207  4    PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
7208  3    CALL HWUMAS(PLAB(1,I))
7209 C--change order of momenta for call to HE code
7210       DO 5 I=1,4
7211       PM(1,I) = P(3,I)
7212       PM(2,I) = P(1,I)
7213       PM(3,I) = P(2,I)
7214       PM(4,I) = P(4,I)
7215  5    PM(5,I) = P(5,I)
7216       DO 6 I=1,8
7217       PCM(1,I)=PLAB(3,I)
7218       PCM(2,I)=PLAB(1,I)
7219       PCM(3,I)=PLAB(2,I)
7220       PCM(4,I)=PLAB(4,I)
7221  6    PCM(5,I)=PLAB(5,I)
7222 C--compute the S functions
7223       CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
7224       DO 7 I=1,8
7225       DO 7 J=1,8
7226       S(I,J,2) = -S(I,J,2)
7227  7    D(I,J)   = TWO*D(I,J)
7228 C--compute the F functions
7229       CALL HWVSUM(5,PM(1,1),PM(1,2),PTMP)
7230       CALL HWUMAS(PTMP)
7231       CALL HWH2F2(8,F0 ,5,PM(1,1), MA(1))
7232       CALL HWH2F1(8,F1 ,6,PM(1,2), MA(2))
7233       CALL HWH2F1(8,F2 ,7,PM(1,3), MA(3))
7234       CALL HWH2F1(8,F3 ,8,PM(1,4), MA(4))
7235       CALL HWH2F1(8,F0M,5,PM(1,1),-MA(1))
7236       CALL HWH2F2(8,F1M,6,PM(1,2),-MA(2))
7237       CALL HWH2F3(8,F01,PTMP,ZERO)
7238 C--now find the prefactor for all the diagrams
7239       PRE = HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2))*
7240      &      HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
7241       PRE = ONE/SQRT(PRE)
7242 C--zero the matrix element
7243       DO 8 P0=1,2
7244       DO 8 P1=1,2
7245       DO 8 P2=1,2
7246       DO 8 P3=1,2
7247       DO 8 I =1,NCTHRE
7248  8    ME(P0,P1,P2,P3,I) = (0.0D0,0.0D0)
7249 C--now call the subroutines to compute the individual diagrams
7250       DO 9 I=1,NDIA
7251 C--vector boson exchange diagram
7252       IF(DRTYPE(I).EQ.1) THEN
7253         CALL HWD3M1(I,MED)
7254 C--Higgs boson exchange diagram
7255       ELSEIF(DRTYPE(I).EQ.2) THEN
7256         CALL HWD3M2(I,MED)
7257 C--antisfermion exchange diagram
7258       ELSEIF(DRTYPE(I).EQ.3) THEN
7259         CALL HWD3M3(I,MED)
7260 C--sfermion exchange diagram
7261       ELSEIF(DRTYPE(I).EQ.4) THEN
7262         CALL HWD3M4(I,MED)
7263 C--antifermion vector boson exchange diagram
7264       ELSEIF(DRTYPE(I).EQ.5) THEN
7265         CALL HWD3M5(I,MED)
7266 C--scalar vector boson exchange diagram
7267       ELSEIF(DRTYPE(I).EQ.6) THEN
7268         CALL HWD3M6(I,MED)
7269 C--gravitino fermion fermion
7270       ELSEIF(DRTYPE(I).EQ.7) THEN
7271         CALL HWD3M7(I,MED)
7272 C--fermion RPV1
7273       ELSEIF(DRTYPE(I).EQ.8) THEN
7274         CALL HWD3M8(I,MED)
7275 C--fermion RPV2
7276       ELSEIF(DRTYPE(I).EQ.9) THEN
7277         CALL HWD3M9(I,MED)
7278 C--fermion RPV3
7279       ELSEIF(DRTYPE(I).EQ.10) THEN
7280         CALL HWD3MA(I,MED)
7281 C--fermion --> 3 fermions 1
7282       ELSEIF(DRTYPE(I).EQ.11) THEN
7283         CALL HWD3MB(I,MED)
7284 C--fermion --> 3 fermions 2
7285       ELSEIF(DRTYPE(I).EQ.12) THEN
7286         CALL HWD3MC(I,MED)
7287 C--fermion --> 3 fermions 3
7288       ELSEIF(DRTYPE(I).EQ.13) THEN
7289         CALL HWD3MD(I,MED)
7290 C--fermion --> 3 antifermions 1
7291       ELSEIF(DRTYPE(I).EQ.14) THEN
7292         CALL HWD3MF(I,MED)
7293 C--fermion --> 3 antifermions 2
7294       ELSEIF(DRTYPE(I).EQ.15) THEN
7295         CALL HWD3MG(I,MED)
7296 C--fermion --> 3 antifermions 3
7297       ELSEIF(DRTYPE(I).EQ.16) THEN
7298         CALL HWD3MH(I,MED)
7299 C--antifermion --> antifermion fermion fermion
7300       ELSEIF(DRTYPE(I).EQ.17) THEN
7301         CALL HWD3MI(I,MED)
7302 C--error not known
7303       ELSE
7304         CALL HWWARN('HWD3M0',501)
7305       ENDIF
7306 C--add up the matrix elements
7307       DO 10 P0=1,2
7308       DO 10 P1=1,2
7309       DO 10 P2=1,2
7310       DO 10 P3=1,2
7311  10   ME(P0,P1,P2,P3,DRCF(I)) = ME(P0,P1,P2,P3,DRCF(I))
7312      &                           +MED(P0,P1,P2,P3)
7313  9    CONTINUE
7314 C--preform the final normalisation
7315       DO 15 P0=1,2
7316       DO 15 P1=1,2
7317       DO 15 P2=1,2
7318       DO 15 P3=1,2
7319       DO 15 I =1,NCTHRE
7320  15   ME(P0,P1,P2,P3,I) = PRE*ME(P0,P1,P2,P3,I)
7321 C--compute the unnormalised spin density matrix
7322       DO 35 P0 =1,2
7323       DO 35 P0P=1,2
7324       RHOB(P0,P0P) = (0.0D0,0.0D0)
7325       DO 35 P1=1,2
7326       DO 35 P2=1,2
7327       DO 35 P3=1,2
7328       DO 35 I =1,NCTHRE
7329       DO 35 J =1,NCTHRE
7330  35   RHOB(P0,P0P)=RHOB(P0,P0P)+CFTHRE(I,J)*ME(P0,P1,P2,P3,I)*
7331      &             DCONJG(ME(P0P,P1,P2,P3,J))
7332 C--compute the weight
7333       WGT = ZERO
7334       DO 45 P0=1,2
7335       DO 45 P0P=1,2
7336  45   WGT = WGT+DREAL(RHOIN(P0,P0P)*RHOB(P0,P0P))
7337 C--normalise this for phase space
7338       WGT = WGT*PHS
7339 C--if initialising select the max weight
7340       IF(SYSPIN.OR.THREEB)
7341      &        MWGT = PHS*(MAX(DBLE(RHOB(1,1)),DBLE(RHOB(2,2)))
7342      &               +ABS(DBLE(RHOB(1,2)))+ABS(DIMAG(RHOB(1,2))))
7343 C--if generating the event put the information in the common block
7344       IF(GENEV) THEN
7345 C--put the matrix element into the spin common block
7346         IF(SYSPIN) THEN
7347           DO 25 P0=1,2
7348           DO 25 P1=1,2
7349           DO 25 P2=1,2
7350           DO 25 P3=1,2
7351           DO 25 I =1,NCTHRE
7352  25       MESPN(P0,P1,P2,P3,I,IDSPIN) = ME(P0,P1,P2,P3,I)
7353           NCFL(IDSPIN) = NCTHRE
7354         ENDIF
7355 C--if more than one colour flow pick the flow
7356         IF(SPCOPT.EQ.2.AND.NCTHRE.NE.1) THEN
7357 C--contstruct the matrix elements for the colour flows
7358           WGTC = ZERO
7359           DO 50 I=1,NCTHRE
7360           WGTB(I) = ZERO
7361           DO 55 P0=1,2
7362           DO 55 P0P=1,2
7363           DO 55 P1=1,2
7364           DO 55 P2=1,2
7365           DO 55 P3=1,2
7366  55       WGTB(I) = WGTB(I)+CFTHRE(I,I)*DREAL(
7367      &    RHOIN(P0,P0P)*ME(P0 ,P1,P2,P3,I)*DCONJG(ME(P0P,P1,P2,P3,I)))
7368           WGTB(I) = WGTB(I)*PHS
7369  50       WGTC    = WGTC+WGTB(I)
7370           WGTC    = WGT/WGTC
7371           DO 60 I=1,NCTHRE
7372  60       WGTB(I) = WGTB(I)*WGTC
7373 C--select the colour flow
7374           WGTC    = HWRGEN(1)*WGT
7375           DO 70 I=1,NCTHRE
7376           IF(WGTB(I).GE.WGTC) THEN
7377             NCFL(IDSPIN) = I
7378             RETURN
7379           ENDIF
7380  70       WGTC = WGTC-WGTB(I)
7381 C--otherwise if wrong options set issue warning
7382         ELSEIF(NCTHRE.NE.1) THEN
7383           WRITE(6,1000)
7384           CALL HWWARN('HWD3M0',500)
7385         ENDIF
7386       ENDIF
7387  1000 FORMAT(/'MULTIPLE COLOUR FLOWS IN DECAY'/'SPCOPT=2 MUST BE USED')
7388       END
7389 CDECK  ID>, HWD3M1.
7390 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7391 *-- Author :    Peter Richardson
7392 C-----------------------------------------------------------------------
7393       SUBROUTINE HWD3M1(ID,ME)
7394 C-----------------------------------------------------------------------
7395 C  Subroutine to calculate the helicity amplitudes for the three body
7396 C  gauge boson exchange diagram
7397 C-----------------------------------------------------------------------
7398       INCLUDE 'herwig65.inc'
7399       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7400      &     F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
7401      &     AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8)
7402       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,
7403      &     MR,P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7404       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7405      &     DRCF(NDIAGR)
7406       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7407      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7408      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7409       PARAMETER(ZI=(0.0D0,1.0D0))
7410       COMMON/HWHEWS/S(8,8,2),D(8,8)
7411       SAVE O
7412       DATA O/2,1/
7413 C--compute the propagator factor
7414       PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7415       CN = -ONE/MS(ID)
7416 C--compute the C and D functions
7417       DO 10 P1=1,2
7418       DO 10 P2=1,2
7419         IF(P1.EQ.P2) THEN
7420 C--the A functions
7421           APP(P1,P2) =  B(  P2 ,ID)*S(7,3,O(P1))*S(4,8,  P1 )
7422           APM(P1,P2) = 0.0D0
7423           AMP(P1,P2) = 0.0D0
7424           AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7425 C--the C and E functions
7426           C(P1,P2) = A(  P1 ,ID)*( MA2(1)*S(6,2,O(P2))*S(2,5,  P2 )
7427      &                            -MA2(2)*S(6,1,O(P2))*S(1,5,  P2 ))
7428      &          +A(O(P1),ID)*MA(1)*MA(2)*( S(6,1,O(P2))*S(1,5,  P2 )
7429      &                                    -S(6,2,O(P2))*S(2,5,  P2 ))
7430           E(P1,P2) =CN*(B(  P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8,  P1 )
7431      &                               +MA2(4)*S(7,3,O(P1))*S(3,8,  P1 ))
7432      &         -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8,  P1 )
7433      &                                   +S(7,4,O(P1))*S(4,8,  P1 )))
7434         ELSE
7435 C--the A functions
7436           APP(P1,P2) = 0.0D0
7437           APM(P1,P2) = B(  P2 ,ID)*MA(3)*S(4,8,O(P1))
7438           AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7439           AMM(P1,P2) = 0.0D0
7440 C--the C and D functions
7441           C(P1,P2) = A(  P1 ,ID)*MA(2)*( MA2(1)*S(6,5,O(P2))
7442      &                   -S(6,2,O(P2))*S(2,1,  P2 )*S(1,5,O(P2)))
7443      &              +A(O(P1),ID)*MA(1)*(-MA2(2)*S(6,5,O(P2))
7444      &                   +S(6,2,O(P2))*S(2,1,  P2 )*S(1,5,O(P2)))
7445           E(P1,P2) =CN*( B(  P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7446      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
7447      &                  -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7448      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
7449         ENDIF
7450  10   CONTINUE
7451 C--compute the matrix element
7452       DO 20 P0=1,2
7453       DO 20 P1=1,2
7454       DO 20 P2=1,2
7455       DO 20 P3=1,2
7456         ME(P0,P1,P2,P3) =
7457      &     APP(P2,P3)*( A(O(P2),ID)*F1(O(P1),  P2 ,4)*F0(  P2 ,O(P0),3)
7458      &                 +A(  P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),4))
7459      &    +APM(P2,P3)*( A(  P2 ,ID)*F1(O(P1),O(P2),4)*F0(O(P2),O(P0),7)
7460      &                 +A(O(P2),ID)*F1(O(P1),  P2 ,7)*F0(  P2 ,O(P0),4))
7461      &    +AMP(P2,P3)*( A(O(P2),ID)*F1(O(P1),  P2 ,8)*F0(  P2 ,O(P0),3)
7462      &                 +A(  P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),8))
7463      &    +AMM(P2,P3)*( A(  P2 ,ID)*F1(O(P1),O(P2),8)*F0(O(P2),O(P0),7)
7464      &                 +A(O(P2),ID)*F1(O(P1),  P2 ,7)*F0(  P2 ,O(P0),8))
7465  20         ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
7466       END
7467 CDECK  ID>, HWD3M2.
7468 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7469 *-- Author :    Peter Richardson
7470 C-----------------------------------------------------------------------
7471       SUBROUTINE HWD3M2(ID,ME)
7472 C-----------------------------------------------------------------------
7473 C  Subroutine to calculate the helicity amplitudes for the three body
7474 C  Higgs boson exchange diagram
7475 C-----------------------------------------------------------------------
7476       INCLUDE 'herwig65.inc'
7477       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7478      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7479      &     F3(2,2,8)
7480       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7481      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7482       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7483      &     DRCF(NDIAGR)
7484       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7485      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7486      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7487       COMMON/HWHEWS/S(8,8,2),D(8,8)
7488       PARAMETER(ZI=(0.0D0,1.0D0))
7489       SAVE O
7490       DATA O/2,1/
7491 C--decide whether to do the diagram
7492       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
7493      &     IDP(4+ID).NE.206) THEN
7494         DO 5 P0=1,2
7495         DO 5 P1=1,2
7496         DO 5 P2=1,2
7497         DO 5 P3=1,2
7498  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7499         RETURN
7500       ENDIF
7501 C--calculate the propagator factor
7502       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7503 C--calculate the vertex functions
7504       DO 10 P1=1,2
7505       DO 10 P2=1,2
7506          V1(P1,P2) = PRE*( A(  P1 ,ID)*F1(O(P2),  P1 ,1)*S(1,5,P1)
7507      &                    +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
7508  10      V2(P1,P2) =       B(  P2 ,ID)*F2(O(P1),  P2 ,4)*S(4,8,P2)
7509      &                    -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
7510 C--calculate the matrix element
7511       DO 20 P0=1,2
7512       DO 20 P1=1,2
7513       DO 20 P2=1,2
7514       DO 20 P3=1,2
7515  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7516       END
7517 CDECK  ID>, HWD3M3.
7518 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7519 *-- Author :    Peter Richardson
7520 C-----------------------------------------------------------------------
7521       SUBROUTINE HWD3M3(ID,ME)
7522 C-----------------------------------------------------------------------
7523 C  Subroutine to calculate the helicity amplitudes for the three body
7524 C  antisfermion exchange diagram
7525 C-----------------------------------------------------------------------
7526       INCLUDE 'herwig65.inc'
7527       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7528      &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7529      &     F3(2,2,8)
7530       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7531      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7532       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7533      &     DRCF(NDIAGR)
7534       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7535      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7536      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7537       COMMON/HWHEWS/S(8,8,2),D(8,8)
7538       PARAMETER(ZI=(0.0D0,1.0D0))
7539       SAVE O
7540       DATA O/2,1/
7541 C--decide whether to do the diagram
7542       IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7543         DO 5 P0=1,2
7544         DO 5 P1=1,2
7545         DO 5 P2=1,2
7546         DO 5 P3=1,2
7547  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7548         RETURN
7549       ENDIF
7550 C--compute the propagator factor
7551       PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7552 C--compute the vertex factors
7553       DO 10 P1=1,2
7554       DO 10 P2=1,2
7555          V1(P1,P2) = PRE*( A(  P1 ,ID)*F2(O(P2),  P1 ,1)*S(1,5,P1)
7556      &                    +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
7557  10      V2(P1,P2) = B(  P2 ,ID)*F1(O(P1),  P2 ,4)*S(4,8,P2)
7558      &              -B(O(P2),ID)*F1(O(P1),O(P2),8)*MA(4)
7559 C--compute the matrix element
7560       DO 20 P0=1,2
7561       DO 20 P1=1,2
7562       DO 20 P2=1,2
7563       DO 20 P3=1,2
7564  20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7565       END
7566 CDECK  ID>, HWD3M4.
7567 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7568 *-- Author :    Peter Richardson
7569 C-----------------------------------------------------------------------
7570       SUBROUTINE HWD3M4(ID,ME)
7571 C-----------------------------------------------------------------------
7572 C  Subroutine to calculate the helicity amplitudes for the three body
7573 C  sfermion exchange diagram
7574 C-----------------------------------------------------------------------
7575       INCLUDE 'herwig65.inc'
7576       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7577      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7578      &     F3(2,2,8)
7579       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7580      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7581       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7582      &     DRCF(NDIAGR)
7583       COMMON/HWHEWS/S(8,8,2),D(8,8)
7584       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7585      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7586      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7587       PARAMETER(ZI=(0.0D0,1.0D0))
7588       SAVE O
7589       DATA O/2,1/
7590 C--decide whether to do the diagram
7591       IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7592         DO 5 P0=1,2
7593         DO 5 P1=1,2
7594         DO 5 P2=1,2
7595         DO 5 P3=1,2
7596  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7597         RETURN
7598       ENDIF
7599 C--compute the propagator factor
7600       PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7601 C--compute the factors for the two vertices
7602       DO 10 P1=1,2
7603       DO 10 P2=1,2
7604          V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,4)*S(4,8,  P2 )
7605      &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),8)*MA(4))
7606  10      V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
7607      &              -B(  P1 ,ID)*F2 (O(P2),  P1 ,6)*MA(2)
7608 C--now compute the matrix element
7609       DO 20 P0=1,2
7610       DO 20 P1=1,2
7611       DO 20 P2=1,2
7612       DO 20 P3=1,2
7613  20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7614       END
7615 CDECK  ID>, HWD3M5.
7616 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7617 *-- Author :    Peter Richardson
7618 C-----------------------------------------------------------------------
7619       SUBROUTINE HWD3M5(ID,ME)
7620 C-----------------------------------------------------------------------
7621 C  Subroutine to calculate the helicity amplitudes for the three body
7622 C  gauge boson exchange diagram (antiparticle decay)
7623 C-----------------------------------------------------------------------
7624       INCLUDE 'herwig65.inc'
7625       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
7626      &     F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
7627      &     AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
7628       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
7629      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7630       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7631      &     DRCF(NDIAGR)
7632       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7633      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7634      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7635       PARAMETER(ZI=(0.0D0,1.0D0))
7636       COMMON/HWHEWS/S(8,8,2),D(8,8)
7637       SAVE O
7638       DATA O/2,1/
7639 C--compute the propagator factor
7640       PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7641       CN = -ONE/MS(ID)
7642 C--compute the C and D functions
7643       DO 10 P1=1,2
7644       DO 10 P2=1,2
7645         IF(P1.EQ.P2) THEN
7646 C--the A functions
7647           APP(P1,P2) =  B(  P2 ,ID)*S(7,3,O(P1))*S(4,8,  P1 )
7648           APM(P1,P2) = 0.0D0
7649           AMP(P1,P2) = 0.0D0
7650           AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7651 C--the C and E functions
7652           C(P1,P2) = A(  P2 ,ID)*( MA2(1)*S(5,2,O(P1))*S(2,6,  P1 )
7653      &                            -MA2(2)*S(5,1,O(P1))*S(1,6,  P1 ))
7654      &          +A(O(P2),ID)*MA(1)*MA(2)*( S(5,1,O(P1))*S(1,6,  P1 )
7655      &                                    -S(5,2,O(P1))*S(2,6,  P1 ))
7656           E(P1,P2) =CN*(B(  P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8,  P1 )
7657      &                               +MA2(4)*S(7,3,O(P1))*S(3,8,  P1 ))
7658      &         -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8,  P1 )
7659      &                                   +S(7,4,O(P1))*S(4,8,  P1 )))
7660         ELSE
7661 C--the A functions
7662           APP(P1,P2) = 0.0D0
7663           APM(P1,P2) = B(  P2 ,ID)*MA(3)*S(4,8,O(P1))
7664           AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7665           AMM(P1,P2) = 0.0D0
7666 C--the C and D functions
7667           C(P1,P2) = A(  P2 ,ID)*MA(1)*( MA2(2)*S(5,6,O(P1))
7668      &                   -S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1)))
7669      &              +A(O(P2),ID)*MA(2)*(-MA2(1)*S(5,6,O(P1))
7670      &                   +S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1)))
7671           E(P1,P2) =CN*( B(  P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7672      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
7673      &                  -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7674      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
7675         ENDIF
7676  10   CONTINUE
7677 C--compute the matrix element
7678       DO 20 P0=1,2
7679       DO 20 P1=1,2
7680       DO 20 P2=1,2
7681       DO 20 P3=1,2
7682       ME(P0,P1,P2,P3) =
7683      &   APP(P2,P3)*( A(O(P2),ID)*F0M(O(P0),  P2 ,4)*F1M(  P2 ,O(P1),3)
7684      &               +A(  P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),4))
7685      &  +APM(P2,P3)*( A(  P2 ,ID)*F0M(O(P0),O(P2),4)*F1M(O(P2),O(P1),7)
7686      &               +A(O(P2),ID)*F0M(O(P0),  P2 ,7)*F1M(  P2 ,O(P1),4))
7687      &  +AMP(P2,P3)*( A(O(P2),ID)*F0M(O(P0),  P2 ,8)*F1M(  P2 ,O(P1),3)
7688      &               +A(  P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),8))
7689      &  +AMM(P2,P3)*( A(  P2 ,ID)*F0M(O(P0),O(P2),8)*F1M(O(P2),O(P1),7)
7690      &               +A(O(P2),ID)*F0M(O(P0),  P2 ,7)*F1M(  P2 ,O(P1),8))
7691  20   ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
7692       END
7693 CDECK  ID>, HWD3M6.
7694 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7695 *-- Author :    Peter Richardson
7696 C-----------------------------------------------------------------------
7697       SUBROUTINE HWD3M6(ID,ME)
7698 C-----------------------------------------------------------------------
7699 C  Subroutine to calculate the helicity amplitudes for the three body
7700 C  gauge boson exchange diagram
7701 C-----------------------------------------------------------------------
7702       INCLUDE 'herwig65.inc'
7703       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
7704      &     F0M(2,2,8),F2(2,2,8),PRE,C(2,2),ZI,APP(2,2),APM(2,2),
7705      &     AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
7706       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
7707      &     P(5,4),DOT,HWULDO,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7708       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7709      &     DRCF(NDIAGR)
7710       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7711      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7712      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7713       DOUBLE PRECISION XMASS,PLAB,PRW,PCM
7714       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7715       PARAMETER(ZI=(0.0D0,1.0D0))
7716       COMMON/HWHEWS/S(8,8,2),D(8,8)
7717       EXTERNAL HWULDO
7718       SAVE O
7719       DATA O/2,1/
7720 C--compute the propagator factor
7721       PRE = SQRT(HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2)))
7722       PRE = -HALF*PRE*A(1,ID)/(M342-MS(ID)+ZI*MWD(ID))
7723       CN = -ONE/MS(ID)
7724       DOT = HWULDO(P(1,1),P(1,3))+HWULDO(P(1,1),P(1,4))
7725      &     +HWULDO(P(1,2),P(1,3))+HWULDO(P(1,2),P(1,4))
7726 C--compute the C and D functions
7727       DO 10 P1=1,2
7728       DO 10 P2=1,2
7729         IF(P1.EQ.P2) THEN
7730 C--the A functions
7731           APP(P1,P2) =  B(  P2 ,ID)*S(7,3,O(P1))*S(4,8,  P1 )
7732           APM(P1,P2) = 0.0D0
7733           AMP(P1,P2) = 0.0D0
7734           AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7735 C--the C function
7736           C(P1,P2) =CN*(B(  P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8,  P1 )
7737      &                               +MA2(4)*S(7,3,O(P1))*S(3,8,  P1 ))
7738      &         -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8,  P1 )
7739      &                                   +S(7,4,O(P1))*S(4,8,  P1 )))
7740         ELSE
7741 C--the A functions
7742           APP(P1,P2) = 0.0D0
7743           APM(P1,P2) = B(  P2 ,ID)*MA(3)*S(4,8,O(P1))
7744           AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7745           AMM(P1,P2) = 0.0D0
7746 C--the C functions
7747           C(P1,P2) =CN*( B(  P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7748      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
7749      &                  -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7750      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
7751         ENDIF
7752  10   CONTINUE
7753 C--compute the matrix element
7754       DO 15 P0=1,2
7755       DO 15 P1=1,2
7756       DO 15 P2=1,2
7757       DO 15 P3=1,2
7758  15   ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7759       DO 20 P2=1,2
7760       DO 20 P3=1,2
7761  20   ME(1,1,P2,P3) = PRE*(DOT*C(P2,P3)
7762      & +APP(P2,P3)*F01(  P2 ,  P2 ,3,4)+APM(P2,P3)*F01(O(P2),O(P2),7,4)
7763      & +AMP(P2,P3)*F01(  P2 ,  P2 ,3,8)+AMM(P2,P3)*F01(O(P2),O(P2),7,8))
7764       END
7765 CDECK  ID>, HWD3M7.
7766 *CMZ :-        -13/03/02  14:19:47  by  Peter Richardson
7767 *-- Author :    Peter Richardson
7768 C-----------------------------------------------------------------------
7769       SUBROUTINE HWD3M7(ID,ME)
7770 C-----------------------------------------------------------------------
7771 C  Subroutine to calculate the helicity amplitudes for the three body
7772 C  decay fermion --> gravitino fermion antifermion (via gauge boson)
7773 C-----------------------------------------------------------------------
7774       INCLUDE 'herwig65.inc'
7775       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7776      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,F1M(2,2,8),F3(2,2,8)
7777       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7778      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX),HWULDO,DL(2,2)
7779       INTEGER P0,P1,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7780      &     DRCF(NDIAGR)
7781       COMMON/HWHEWS/S(8,8,2),D(8,8)
7782       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7783      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7784      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7785       PARAMETER(ZI=(0.0D0,1.0D0))
7786       DOUBLE PRECISION XMASS,PLAB,PRW,PCM
7787       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7788       EXTERNAL HWULDO
7789       SAVE O,DL
7790       DATA O/2,1/
7791       DATA DL/1.0D0,0.0D0,0.0D0,1.0D0/
7792 C--compute the propagator factor
7793       PRE = HALF*HWULDO(PCM(1,6),PM(1,2))*
7794      &      HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
7795       PRE = SQRT(PRE)
7796       PRE = PRE/(M342-MS(ID)+ZI*MWD(ID))
7797       DO 10 P0=1,2
7798       DO 10 P1=1,2
7799       ME(P0,P1,  P1 ,  P1 ) = PRE*B(  P1 ,ID)*(
7800      &   A(1,ID)*S(2,3,P1)*S(3,4,O(P1))*S(3,2,  P1 )*F0(O(P1),O(P0),2)
7801      &  +A(2,ID)* DL(P1,1)*S(2,3,  P1 )*S(4,2,O(P1))*F0(  1  ,O(P0),2))
7802       ME(P0,P1,O(P1),O(P1)) = PRE*B(O(P1),ID)*(
7803      &   A(1,ID)*S(2,4,P1)*S(4,3,O(P1))*S(4,2,  P1 )*F0(O(P1),O(P0),2)
7804      &  +A(2,ID)* DL(P1,1)*S(2,4,  P1 )*S(3,2,O(P1))*F0(  1  ,O(P0),2))
7805       ME(P0,P1,O(P1),  P1 ) = (0.0D0,0.0D0)
7806  10   ME(P0,P1,  P1 ,O(P1)) = (0.0D0,0.0D0)
7807       END
7808 CDECK  ID>, HWD3M8.
7809 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7810 *-- Author :    Peter Richardson
7811 C-----------------------------------------------------------------------
7812       SUBROUTINE HWD3M8(ID,ME)
7813 C-----------------------------------------------------------------------
7814 C  Subroutine to calculate the helicity amplitudes for 1st 3 body RPV
7815 C  diagram f--> fbar fbar f
7816 C-----------------------------------------------------------------------
7817       INCLUDE 'herwig65.inc'
7818       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7819      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7820      &     F3(2,2,8)
7821       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7822      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7823       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7824      &     DRCF(NDIAGR)
7825       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7826      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7827      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7828       COMMON/HWHEWS/S(8,8,2),D(8,8)
7829       PARAMETER(ZI=(0.0D0,1.0D0))
7830       SAVE O
7831       DATA O/2,1/
7832 C--decide whether to do the diagram
7833       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7834         DO 5 P0=1,2
7835         DO 5 P1=1,2
7836         DO 5 P2=1,2
7837         DO 5 P3=1,2
7838  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7839         RETURN
7840       ENDIF
7841 C--calculate the propagator factor
7842       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7843 C--calculate the vertex functions
7844       DO 10 P1=1,2
7845       DO 10 P2=1,2
7846       V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,2)*S(2,6,  P2)
7847      &                 -A(O(P2),ID)*F0M(  P1 ,O(P2),6)*MA(2))
7848  10   V2(P1,P2) =       B(  P1 ,ID)*F3 (O(P2),  P1 ,3)*S(3,7,P1)
7849      &                 -B(O(P1),ID)*F3 (O(P2),O(P1),7)*MA(3)
7850 C--calculate the matrix element
7851       DO 20 P0=1,2
7852       DO 20 P1=1,2
7853       DO 20 P2=1,2
7854       DO 20 P3=1,2
7855  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7856       END
7857 CDECK  ID>, HWD3M9.
7858 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7859 *-- Author :    Peter Richardson
7860 C-----------------------------------------------------------------------
7861       SUBROUTINE HWD3M9(ID,ME)
7862 C-----------------------------------------------------------------------
7863 C  Subroutine to calculate the helicity amplitudes for 2nd 3 body RPV
7864 C  diagram f --> fbar fbar f
7865 C-----------------------------------------------------------------------
7866       INCLUDE 'herwig65.inc'
7867       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7868      &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7869      &     F3(2,2,8)
7870       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7871      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7872       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7873      &     DRCF(NDIAGR)
7874       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7875      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7876      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7877       COMMON/HWHEWS/S(8,8,2),D(8,8)
7878       PARAMETER(ZI=(0.0D0,1.0D0))
7879       SAVE O
7880       DATA O/2,1/
7881 C--decide whether to do the diagram
7882       IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7883         DO 5 P0=1,2
7884         DO 5 P1=1,2
7885         DO 5 P2=1,2
7886         DO 5 P3=1,2
7887  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7888         RETURN
7889       ENDIF
7890 C--compute the propagator factor
7891       PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7892 C--compute the vertex factors
7893       DO 10 P1=1,2
7894       DO 10 P2=1,2
7895       V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,3)*S(3,7,P2)
7896      &                 -A(O(P2),ID)*F0M(  P1 ,O(P2),7)*MA(3))
7897  10   V2(P1,P2) =       B(  P1 ,ID)*F3 (O(P2),  P1 ,2)*S(2,6,P1)
7898      &                 -B(O(P1),ID)*F3 (O(P2),O(P1),6)*MA(2)
7899 C--compute the matrix element
7900       DO 20 P0=1,2
7901       DO 20 P1=1,2
7902       DO 20 P2=1,2
7903       DO 20 P3=1,2
7904  20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7905       END
7906 CDECK  ID>, HWD3MA.
7907 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7908 *-- Author :    Peter Richardson
7909 C-----------------------------------------------------------------------
7910       SUBROUTINE HWD3MA(ID,ME)
7911 C-----------------------------------------------------------------------
7912 C  Subroutine to calculate the helicity amplitudes for 3rd 3 body RPV
7913 C  diagram f --> fbar fbar f
7914 C-----------------------------------------------------------------------
7915       INCLUDE 'herwig65.inc'
7916       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7917      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7918      &     F3(2,2,8)
7919       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7920      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7921       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7922      &     DRCF(NDIAGR)
7923       COMMON/HWHEWS/S(8,8,2),D(8,8)
7924       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7925      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7926      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7927       PARAMETER(ZI=(0.0D0,1.0D0))
7928       SAVE O
7929       DATA O/2,1/
7930 C--decide whether to do the diagram
7931       IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7932         DO 5 P0=1,2
7933         DO 5 P1=1,2
7934         DO 5 P2=1,2
7935         DO 5 P3=1,2
7936  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7937         RETURN
7938       ENDIF
7939 C--compute the propagator factor
7940       PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7941 C--compute the factors for the two vertices
7942       DO 10 P1=1,2
7943       DO 10 P2=1,2
7944       V1(P1,P2) = PRE*( A(  P1 ,ID)*F3(O(P2),  P1 ,1)*S(1,5,P1)
7945      &                 +A(O(P1),ID)*F3(O(P2),O(P1),5)*MA(1))
7946  10   V2(P1,P2) =       B(  P2 ,ID)*F1(  P1 ,  P2 ,3)*S(3,7,P2)
7947      &                 -B(O(P2),ID)*F1(  P1 ,O(P2),7)*MA(3)
7948 C--now compute the matrix element
7949       DO 20 P0=1,2
7950       DO 20 P1=1,2
7951       DO 20 P2=1,2
7952       DO 20 P3=1,2
7953  20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7954       END
7955 CDECK  ID>, HWD3MB.
7956 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7957 *-- Author :    Peter Richardson
7958 C-----------------------------------------------------------------------
7959       SUBROUTINE HWD3MB(ID,ME)
7960 C-----------------------------------------------------------------------
7961 C  Subroutine to calculate the helicity amplitudes for 4th 3 body RPV
7962 C  diagram f --> f f f
7963 C-----------------------------------------------------------------------
7964       INCLUDE 'herwig65.inc'
7965       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7966      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7967      &     F3(2,2,8)
7968       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7969      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7970       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7971      &     DRCF(NDIAGR)
7972       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7973      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7974      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7975       COMMON/HWHEWS/S(8,8,2),D(8,8)
7976       PARAMETER(ZI=(0.0D0,1.0D0))
7977       SAVE O
7978       DATA O/2,1/
7979 C--decide whether to do the diagram
7980       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7981         DO 5 P0=1,2
7982         DO 5 P1=1,2
7983         DO 5 P2=1,2
7984         DO 5 P3=1,2
7985  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7986         RETURN
7987       ENDIF
7988 C--calculate the propagator factor
7989       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7990 C--calculate the vertex functions
7991       DO 10 P1=1,2
7992       DO 10 P2=1,2
7993          V1(P1,P2) = PRE*( A(  P1 ,ID)*F1(O(P2),  P1 ,1)*S(1,5,P1)
7994      &                    +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
7995  10      V2(P1,P2) =       B(O(P2),ID)*F2(O(P1),O(P2),4)*S(4,8,O(P2))
7996      &                    -B(  P2 ,ID)*F2(O(P1),  P2 ,8)*MA(4)
7997 C--calculate the matrix element
7998       DO 20 P0=1,2
7999       DO 20 P1=1,2
8000       DO 20 P2=1,2
8001       DO 20 P3=1,2
8002  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
8003       END
8004 CDECK  ID>, HWD3MC.
8005 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
8006 *-- Author :    Peter Richardson
8007 C-----------------------------------------------------------------------
8008       SUBROUTINE HWD3MC(ID,ME)
8009 C-----------------------------------------------------------------------
8010 C  Subroutine to calculate the helicity amplitudes for 5th 3 body RPV
8011 C  diagram f --> f f f
8012 C-----------------------------------------------------------------------
8013       INCLUDE 'herwig65.inc'
8014       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8015      &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
8016      &     F3(2,2,8)
8017       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8018      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8019       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8020      &     DRCF(NDIAGR)
8021       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8022      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8023      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8024       COMMON/HWHEWS/S(8,8,2),D(8,8)
8025       PARAMETER(ZI=(0.0D0,1.0D0))
8026       SAVE O
8027       DATA O/2,1/
8028 C--decide whether to do the diagram
8029       IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
8030         DO 5 P0=1,2
8031         DO 5 P1=1,2
8032         DO 5 P2=1,2
8033         DO 5 P3=1,2
8034  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8035         RETURN
8036       ENDIF
8037 C--compute the propagator factor
8038       PRE =-0.25D0/(M242-MS(ID)+ZI*MWD(ID))
8039 C--compute the vertex factors
8040       DO 10 P1=1,2
8041       DO 10 P2=1,2
8042          V1(P1,P2) = PRE*( A(  P1 ,ID)*F2(O(P2),  P1 ,1)*S(1,5,P1)
8043      &                    +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
8044  10      V2(P1,P2) = B(O(P2),ID)*F1(O(P1),O(P2),4)*S(4,8,O(P2))
8045      &              -B(  P2 ,ID)*F1(O(P1),  P2 ,8)*MA(4)
8046 C--compute the matrix element
8047       DO 20 P0=1,2
8048       DO 20 P1=1,2
8049       DO 20 P2=1,2
8050       DO 20 P3=1,2
8051  20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
8052       END
8053 CDECK  ID>, HWD3MD.
8054 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
8055 *-- Author :    Peter Richardson
8056 C-----------------------------------------------------------------------
8057       SUBROUTINE HWD3MD(ID,ME)
8058 C-----------------------------------------------------------------------
8059 C  Subroutine to calculate the helicity amplitudes for 6th 3 body RPV
8060 C  diagram f --> f f f
8061 C-----------------------------------------------------------------------
8062       INCLUDE 'herwig65.inc'
8063       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8064      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8065      &     F3(2,2,8)
8066       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8067      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8068       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8069      &     DRCF(NDIAGR)
8070       COMMON/HWHEWS/S(8,8,2),D(8,8)
8071       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8072      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8073      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8074       PARAMETER(ZI=(0.0D0,1.0D0))
8075       SAVE O
8076       DATA O/2,1/
8077 C--decide whether to do the diagram
8078       IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
8079         DO 5 P0=1,2
8080         DO 5 P1=1,2
8081         DO 5 P2=1,2
8082         DO 5 P3=1,2
8083  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8084         RETURN
8085       ENDIF
8086 C--compute the propagator factor
8087       PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
8088 C--compute the factors for the two vertices
8089       DO 10 P1=1,2
8090       DO 10 P2=1,2
8091          V1(P1,P2) = PRE*( A(O(P2),ID)*F0M(  P1 ,O(P2),4)*S(4,8,O(P2))
8092      &                    -A(  P2 ,ID)*F0M(  P1 ,  P2 ,8)*MA(4))
8093  10      V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
8094      &              -B(  P1 ,ID)*F2 (O(P2),  P1 ,6)*MA(2)
8095 C--now compute the matrix element
8096       DO 20 P0=1,2
8097       DO 20 P1=1,2
8098       DO 20 P2=1,2
8099       DO 20 P3=1,2
8100  20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
8101       END
8102 CDECK  ID>, HWD3MF.
8103 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
8104 *-- Author :    Peter Richardson
8105 C-----------------------------------------------------------------------
8106       SUBROUTINE HWD3MF(ID,ME)
8107 C-----------------------------------------------------------------------
8108 C  Subroutine to calculate the helicity amplitudes for 7th 3 body RPV
8109 C  diagram f --> fbar fbar fbar
8110 C-----------------------------------------------------------------------
8111       INCLUDE 'herwig65.inc'
8112       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8113      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8114      &     F3(2,2,8)
8115       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8116      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8117       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8118      &     DRCF(NDIAGR)
8119       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8120      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8121      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8122       COMMON/HWHEWS/S(8,8,2),D(8,8)
8123       PARAMETER(ZI=(0.0D0,1.0D0))
8124       SAVE O
8125       DATA O/2,1/
8126 C--decide whether to do the diagram
8127       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
8128         DO 5 P0=1,2
8129         DO 5 P1=1,2
8130         DO 5 P2=1,2
8131         DO 5 P3=1,2
8132  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8133         RETURN
8134       ENDIF
8135 C--calculate the propagator factor
8136       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
8137 C--calculate the vertex functions
8138       DO 10 P1=1,2
8139       DO 10 P2=1,2
8140          V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,2)*S(2,6,P2)
8141      &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),6)*MA(2))
8142  10      V2(P1,P2) =       B(  P2 ,ID)*F2(  P1 ,  P2 ,4)*S(4,8,P2)
8143      &                    -B(O(P2),ID)*F2(  P1 ,O(P2),8)*MA(4)
8144 C--calculate the matrix element
8145       DO 20 P0=1,2
8146       DO 20 P1=1,2
8147       DO 20 P2=1,2
8148       DO 20 P3=1,2
8149  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
8150       END
8151 CDECK  ID>, HWD3MG.
8152 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
8153 *-- Author :    Peter Richardson
8154 C-----------------------------------------------------------------------
8155       SUBROUTINE HWD3MG(ID,ME)
8156 C-----------------------------------------------------------------------
8157 C  Subroutine to calculate the helicity amplitudes for 8th 3 body RPV
8158 C  diagram f --> fbar fbar fbar
8159 C-----------------------------------------------------------------------
8160       INCLUDE 'herwig65.inc'
8161       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8162      &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
8163      &     F3(2,2,8)
8164       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8165      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8166       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8167      &     DRCF(NDIAGR)
8168       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8169      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8170      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8171       COMMON/HWHEWS/S(8,8,2),D(8,8)
8172       PARAMETER(ZI=(0.0D0,1.0D0))
8173       SAVE O
8174       DATA O/2,1/
8175 C--decide whether to do the diagram
8176       IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
8177         DO 5 P0=1,2
8178         DO 5 P1=1,2
8179         DO 5 P2=1,2
8180         DO 5 P3=1,2
8181  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8182         RETURN
8183       ENDIF
8184 C--compute the propagator factor
8185       PRE = 0.25D0/(M242-MS(ID)+ZI*MWD(ID))
8186 C--compute the vertex factors
8187       DO 10 P1=1,2
8188       DO 10 P2=1,2
8189          V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,3)*S(3,7,  P2 )
8190      &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),7)*MA(3))
8191  10      V2(P1,P2) =       B(  P1 ,ID)*F3 (  P2 ,  P1 ,2)*S(2,6,  P1 )
8192      &                    -B(O(P1),ID)*F3 (  P2 ,O(P1),6)*MA(2)
8193 C--compute the matrix element
8194       DO 20 P0=1,2
8195       DO 20 P1=1,2
8196       DO 20 P2=1,2
8197       DO 20 P3=1,2
8198  20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
8199       END
8200 CDECK  ID>, HWD3MH.
8201 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
8202 *-- Author :    Peter Richardson
8203 C-----------------------------------------------------------------------
8204       SUBROUTINE HWD3MH(ID,ME)
8205 C-----------------------------------------------------------------------
8206 C  Subroutine to calculate the helicity amplitudes for 9th 3 body RPV
8207 C  diagram f --> fbar fbar fbar
8208 C-----------------------------------------------------------------------
8209       INCLUDE 'herwig65.inc'
8210       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8211      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8212      &     F3(2,2,8)
8213       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8214      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8215       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8216      &     DRCF(NDIAGR)
8217       COMMON/HWHEWS/S(8,8,2),D(8,8)
8218       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8219      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8220      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8221       PARAMETER(ZI=(0.0D0,1.0D0))
8222       SAVE O
8223       DATA O/2,1/
8224 C--decide whether to do the diagram
8225       IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
8226         DO 5 P0=1,2
8227         DO 5 P1=1,2
8228         DO 5 P2=1,2
8229         DO 5 P3=1,2
8230  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8231         RETURN
8232       ENDIF
8233 C--compute the propagator factor
8234       PRE = -0.25D0/(M232-MS(ID)+ZI*MWD(ID))
8235 C--compute the factors for the two vertices
8236       DO 10 P1=1,2
8237       DO 10 P2=1,2
8238          V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,4)*S(4,8,P2)
8239      &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),8)*MA(4))
8240  10      V2(P1,P2) =       B(  P1 ,ID)*F2 (  P2 ,  P1 ,2)*S(2,6,P1)
8241      &                    -B(O(P1),ID)*F2 (  P2 ,O(P1),6)*MA(2)
8242 C--now compute the matrix element
8243       DO 20 P0=1,2
8244       DO 20 P1=1,2
8245       DO 20 P2=1,2
8246       DO 20 P3=1,2
8247  20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
8248       END
8249 CDECK  ID>, HWD3MI.
8250 *CMZ :-        -09/04/02  13:37:38  by  Peter Richardson
8251 *-- Author :    Peter Richardson
8252 C-----------------------------------------------------------------------
8253       SUBROUTINE HWD3MI(ID,ME)
8254 C-----------------------------------------------------------------------
8255 C  Subroutine to calculate the helicity amplitudes for the three body
8256 C  Higgs boson exchange diagram antifermion decay
8257 C-----------------------------------------------------------------------
8258       INCLUDE 'herwig65.inc'
8259       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8260      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8261      &     F3(2,2,8)
8262       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8263      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8264       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8265      &     DRCF(NDIAGR)
8266       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8267      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8268      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8269       COMMON/HWHEWS/S(8,8,2),D(8,8)
8270       PARAMETER(ZI=(0.0D0,1.0D0))
8271       SAVE O
8272       DATA O/2,1/
8273 C--decide whether to do the diagram
8274       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
8275      &   IDP(4+ID).NE.207) THEN
8276         DO 5 P0=1,2
8277         DO 5 P1=1,2
8278         DO 5 P2=1,2
8279         DO 5 P3=1,2
8280  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8281         RETURN
8282       ENDIF
8283 C--calculate the propagator factor
8284       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
8285 C--calculate the vertex functions
8286       DO 10 P1=1,2
8287       DO 10 P2=1,2
8288       V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(O(P1),  P2 ,2)*S(2,6,P2)
8289      &                 -A(O(P2),ID)*F0M(O(P1),O(P2),6)*MA(2))
8290  10   V2(P1,P2) =       B(  P2 ,ID)*F2(O(P1),  P2 ,4)*S(4,8,P2)
8291      &                 -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
8292 C--calculate the matrix element
8293       DO 20 P0=1,2
8294       DO 20 P1=1,2
8295       DO 20 P2=1,2
8296       DO 20 P3=1,2
8297  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
8298       END
8299 CDECK  ID>, HWD4ME.
8300 *CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
8301 *-- Author :    Peter Richardson
8302 C-----------------------------------------------------------------------
8303       SUBROUTINE HWD4ME(ID,ITYPE1,ITYPE2,IMODE)
8304 C-----------------------------------------------------------------------
8305 C     Subroutine to perform the four body Higgs decays
8306 C-----------------------------------------------------------------------
8307       INCLUDE 'herwig65.inc'
8308       INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE(2),NTRY,ITYPE1,ITYPE2
8309       DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,BRW(6),BRZ(12),
8310      &     HWUPCM,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,P(5,5)
8311       EXTERNAL HWRUNI,HWUPCM,HWRGEN
8312       COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
8313       SAVE BRW,BRZ
8314       DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
8315       DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8316      &         0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
8317       ITYPE(1) = ITYPE1
8318       ITYPE(2) = ITYPE2
8319       WTMAX = WT4MAX(ITYPE(1),ITYPE(2),IMODE)
8320       PRE=P4MODE(ITYPE(1),ITYPE(2),IMODE)
8321 C--compute the masses of external particles for the decay mode
8322       DO I=1,2
8323 C--couplings and masses of the internal particles
8324         A(I) = A4MODE(I,ITYPE1,IMODE)
8325         B(I) = B4MODE(I,ITYPE2,IMODE)
8326         MR(I)  = RMASS(I4MODE(I,IMODE))
8327         MS(I)  = MR(I)**2
8328         IF(I4MODE(I,IMODE).EQ.200) THEN
8329           MWD(I) = MR(I)*GAMZ
8330         ELSE
8331           MWD(I) = MR(I)*GAMW
8332         ENDIF
8333         IDP(5+I) = I4MODE(I,IMODE)
8334 C--id's of outgoing particles
8335         IF(I4MODE(I,IMODE).EQ.200) THEN
8336           IDP(2*I  ) = ITYPE(I)
8337           IF(ITYPE(I).GT.6) IDP(2*I) = IDP(2*I)+114
8338           IDP(2*I+1) = IDP(2*I)+6
8339         ELSE
8340           IDP(2*I  ) = 2*ITYPE(I)-1
8341           IF(ITYPE(I).GT.3) IDP(2*I) = IDP(2*I)+114
8342           IDP(2*I+1) = IDP(2*I)+7
8343           IF(I4MODE(I,IMODE).EQ.198) THEN
8344             J          = IDP(2*I  )+6
8345             IDP(2*I) = IDP(2*I+1)-6
8346             IDP(2*I+1) = J
8347           ENDIF
8348         ENDIF
8349       ENDDO
8350       IDP(1) = IDK(ID4PRT(IMODE))
8351       DO 1 I=1,5
8352       M(I) = RMASS(IDP(I))
8353  1    M2(I) = M(I)**2
8354       IF(M(1).LT.M(2)+M(3)+M(4)+M(5).OR.MR(1).LT.M(2)+M(3).OR.
8355      &     MR(2).LT.M(4)+M(5)) RETURN
8356       IF(IPRINT.EQ.2.AND..NOT.GENEV)
8357      &        WRITE(6,3000) RNAME(IDP(6)),RNAME(IDP(2)),RNAME(IDP(3)),
8358      &                      RNAME(IDP(7)),RNAME(IDP(4)),RNAME(IDP(5))
8359 C--compute the width and maximum weight if initialising
8360       IF(.NOT.GENEV) THEN
8361         WMAX  = ZERO
8362         WSUM  = ZERO
8363         WSSUM = ZERO
8364         DO I=1,NSEARCH
8365           CALL HWD4M0(1,WGT)
8366           WGT = WGT*PRE
8367           IF(WGT.GT.WMAX) WMAX = WGT
8368           WSUM = WSUM+WGT
8369           WSSUM = WSSUM+WGT**2
8370           IF(WGT.LT.ZERO) CALL HWWARN('HWD4ME',500)
8371         ENDDO
8372         WSUM = WSUM/DBLE(NSEARCH)
8373         WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
8374         WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
8375         IF(IPRINT.EQ.2) WRITE(6,3010) WSUM,WSSUM
8376         IF(IPRINT.EQ.2) WRITE(6,3020) WMAX
8377         TEMP = BRFRAC(ID4PRT(IMODE))*HBAR/RLTIM(IDK(ID4PRT(IMODE)))
8378         DO J=1,2
8379           IF(I4MODE(J,IMODE).EQ.200) THEN
8380             TEMP = TEMP*BRZ(ITYPE(J))
8381           ELSE
8382             TEMP = TEMP*BRW(ITYPE(J))
8383           ENDIF
8384         ENDDO
8385         IF(IPRINT.EQ.2) WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
8386 C--set up the maximum weight
8387         WT4MAX(ITYPE(1),ITYPE(2),IMODE) = WMAX
8388       ELSE
8389 C--generate a configuation
8390         NTRY = 0
8391         IF(SYSPIN.AND.NSPN.NE.0) CALL HWWARN('HWD4ME',501)
8392  100    NTRY = NTRY+1
8393         CALL HWD4M0(ID,WGT)
8394         WGT = WGT*PRE
8395         IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
8396         IF(NTRY.GE.NSNTRY) THEN
8397           CALL HWWARN('HWD4ME',100)
8398           GOTO 999
8399         ENDIF
8400       ENDIF
8401  3000 FORMAT(/'  FOLLOWED BY ',A8,' --> ',A8,' ',A8,' AND ',
8402      &                         A8,' --> ',A8,' ',A8)
8403  3010 FORMAT('            PARTIAL WIDTH  = ',G12.4,' +/- ',G12.4)
8404  3020 FORMAT('            MAXIMUM WEIGHT = ',E12.4)
8405  3030 FORMAT('     RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
8406  999  RETURN
8407       END
8408 CDECK  ID>, HWD4M0.
8409 *CMZ :-        -11/10/01  12:32:39  by  Peter Richardson
8410 *-- Author :    Peter Richardson
8411 C-----------------------------------------------------------------------
8412       SUBROUTINE HWD4M0(ID,WGT)
8413 C-----------------------------------------------------------------------
8414 C     Subroutine to calculate the matrix element for a given four body
8415 C     decay mode
8416 C-----------------------------------------------------------------------
8417       INCLUDE 'herwig65.inc'
8418       INTEGER I,J,P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),II,P4
8419       DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,
8420      &     M23,PCMA,PCMB(2),HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,
8421      &     M232,PRE,PLAB,PRW,XMASS,PCM,P(5,5),PM(5,5),MR,PREF(5),
8422      &     M45,M452,MJAC(2),PTMP(5,2),CN(2),DOT
8423       DOUBLE COMPLEX S,D,ME(2,2,2,2),APP(2,2),AMP(2,2),APM(2,2),
8424      &     AMM(2,2),BPP(2,2),BPM(2,2),BMP(2,2),BMM(2,2),ZI,
8425      &     F45(2,2,8,8),F23(2,2,8,8),C(2,2),E(2,2)
8426       LOGICAL HWRLOG
8427       EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRLOG
8428       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
8429       COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
8430       COMMON/HWHEWS/S(8,8,2),D(8,8)
8431       PARAMETER(EPS=1D-20,ZI=(0.0D0,1.0D0))
8432       SAVE O,PREF
8433       DATA O/2,1/
8434       DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
8435 C--select the masses of the gauge bosons and compute Jacobians
8436       IF(HWRLOG(HALF)) THEN
8437         CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M(4)-M(5))**2,
8438      &                                             (M(2)+M(3))**2)
8439         M23 = SQRT(M232)
8440         CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,
8441      &       (M(1)-M23)**2,(M(4)+M(5))**2)
8442         M45 = SQRT(M452)
8443       ELSE
8444         CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,(M(1)-M(2)-M(3))**2,
8445      &                                            (M(4)+M(5))**2)
8446         M45 = SQRT(M452)
8447         CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M45)**2,
8448      &       (M(2)+M(3))**2)
8449         M23 = SQRT(M232)
8450       ENDIF
8451       MJAC(1) = MJAC(1)/((M232-MS(1))**2+MWD(1)**2)
8452       MJAC(2) = MJAC(2)/((M452-MS(2))**2+MWD(2)**2)
8453       DO 1 I=2,5
8454  1    P(5,I) = M(I)
8455       DO 2 I=1,2
8456  2    CN(I) = -ONE/MS(I)
8457 C--now perform the decay of the Higgs to the bosons
8458       PCMA = HWUPCM(M(1),M23,M45)
8459       PLAB(5,1) = M23
8460       PLAB(5,2) = M45
8461       CALL HWVEQU(5,PHEP(1,ID),P(1,1))
8462       CALL HWDTWO(P(1,1),PLAB(1,1),PLAB(1,2),PCMA,2.0D0,.TRUE.)
8463       PCMB(1) = HWUPCM(M23,M(2),M(3))
8464       CALL HWDTWO(PLAB(1,1),P(1,2),P(1,3),PCMB(1),2.0D0,.TRUE.)
8465       PCMB(2) = HWUPCM(M45,M(4),M(5))
8466       CALL HWDTWO(PLAB(1,2),P(1,4),P(1,5),PCMB(2),2.0D0,.TRUE.)
8467       DOT = HWULDO(PLAB(1,1),PLAB(1,2))
8468 C--compute the phase sapce factors
8469       PHS = PCMA*PCMB(1)*PCMB(2)*MJAC(1)*MJAC(2)/512.0D0/PIFAC**5/
8470      &        M2(1)/M23/M45
8471 C--compute the vectors for the helicity amplitudes
8472       DO 3 I=1,4
8473       II=I+1
8474 C--compute the references vectors
8475 C--not important if SM particle which can't have spin measured
8476 C--ie anything other the top and tau
8477 C--also not important if particle is approx massless
8478 C--first the SM particles other than top and tau
8479       IF(IDP(II).LT.400.AND.(IDP(II).NE.6.AND.IDP(II).NE.12
8480      &                 .AND.IDP(II).NE.125.AND.IDP(II).NE.131)) THEN
8481         CALL HWVEQU(5,PREF,PLAB(1,I+4))
8482 C--all other particles
8483       ELSE
8484         PP = SQRT(HWVDOT(3,P(1,II),P(1,II)))
8485         CALL HWVSCA(3,ONE/PP,P(1,II),N)
8486         PLAB(4,I+4) = HALF*(P(4,II)-PP)
8487         PP = HALF*(PP-M(II)-PP**2/(M(II)+P(4,II)))
8488         CALL HWVSCA(3,PP,N,PLAB(1,I+4))
8489         CALL HWUMAS(PLAB(1,I+4))
8490         PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
8491 C--fix to avoid problems if approx massless due to energy
8492         IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
8493       ENDIF
8494 C--now the massless vectors
8495       PP = HALF*M2(II)/HWULDO(PLAB(1,I+4),P(1,II))
8496       DO 4 J=1,4
8497  4    PLAB(J,I) = P(J,II)-PP*PLAB(J,I+4)
8498  3    CALL HWUMAS(PLAB(1,I))
8499 C--change ordr of momenta for call to HE code
8500       DO 5 I=1,5
8501       PM(1,I) = P(3,I)
8502       PM(2,I) = P(1,I)
8503       PM(3,I) = P(2,I)
8504       PM(4,I) = P(4,I)
8505  5    PM(5,I) = P(5,I)
8506       DO 6 I=1,8
8507       PCM(1,I)=PLAB(3,I)
8508       PCM(2,I)=PLAB(1,I)
8509       PCM(3,I)=PLAB(2,I)
8510       PCM(4,I)=PLAB(4,I)
8511  6    PCM(5,I)=PLAB(5,I)
8512 C--compute the S functions
8513       CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
8514       DO 7 I=1,8
8515       DO 7 J=1,8
8516       S(I,J,2) = -S(I,J,2)
8517  7    D(I,J)   = TWO*D(I,J)
8518       CALL HWVSUM(4,PM(1,2),PM(1,3),PTMP(1,1))
8519       CALL HWVSUM(4,PM(1,4),PM(1,5),PTMP(1,2))
8520       CALL HWUMAS(PTMP(1,1))
8521       CALL HWUMAS(PTMP(1,2))
8522 C--compute the F functions
8523       CALL HWH2F3(8,F23,PTMP(1,1),ZERO)
8524       CALL HWH2F3(8,F45,PTMP(1,2),ZERO)
8525 C--now find the prefactor for all the diagrams
8526       PRE = HWULDO(PCM(1,5),PM(1,2))*HWULDO(PCM(1,6),PM(1,3))*
8527      &      HWULDO(PCM(1,7),PM(1,4))*HWULDO(PCM(1,8),PM(1,5))
8528       PRE = 0.25D0/SQRT(PRE)
8529 C--zero the matrix element
8530       DO 8 P0=1,2
8531       DO 8 P1=1,2
8532       DO 8 P2=1,2
8533       DO 8 P3=1,2
8534  8    ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8535 C--compute the A, B, C and E functions
8536       DO 9 P1=1,2
8537       DO 9 P2=1,2
8538         IF(P1.EQ.P2) THEN
8539 C--the A and B functions
8540           APP(P1,P2) =  A(  P2 )*S(5,1,O(P1))*S(2,6,  P1 )
8541           APM(P1,P2) = 0.0D0
8542           AMP(P1,P2) = 0.0D0
8543           AMM(P1,P2) = -A(O(P2))*M(2)*M(3)
8544           BPP(P1,P2) =  B(  P2 )*S(7,3,O(P1))*S(4,8,  P1 )
8545           BPM(P1,P2) = 0.0D0
8546           BMP(P1,P2) = 0.0D0
8547           BMM(P1,P2) = -B(O(P2))*M(4)*M(5)
8548 C--the C and E functions
8549           C(P1,P2) =CN(1)*(A(  P2 )*( M2(2)*S(5,2,O(P1))*S(2,6,  P1 )
8550      &                               +M2(3)*S(5,1,O(P1))*S(1,6,  P1 ))
8551      &         -A(O(P2))*M(2)*M(3)*( S(5,1,O(P1))*S(1,6,  P1 )
8552      &                              +S(5,2,O(P1))*S(2,6,  P1 )))
8553           E(P1,P2) =CN(2)*(B(  P2 )*( M2(4)*S(7,4,O(P1))*S(4,8,  P1 )
8554      &                               +M2(5)*S(7,3,O(P1))*S(3,8,  P1 ))
8555      &         -B(O(P2))*M(4)*M(5)*( S(7,3,O(P1))*S(3,8,  P1 )
8556      &                              +S(7,4,O(P1))*S(4,8,  P1 )))
8557         ELSE
8558 C--the A functions
8559           APP(P1,P2) = 0.0D0
8560           APM(P1,P2) = A(  P2 )*M(2)*S(2,6,O(P1))
8561           AMP(P1,P2) =-A(O(P2))*M(3)*S(5,1,O(P1))
8562           AMM(P1,P2) = 0.0D0
8563           BPP(P1,P2) = 0.0D0
8564           BPM(P1,P2) = B(  P2 )*M(4)*S(4,8,O(P1))
8565           BMP(P1,P2) =-B(O(P2))*M(5)*S(7,3,O(P1))
8566           BMM(P1,P2) = 0.0D0
8567 C--the C and D functions
8568           C(P1,P2) =CN(1)*( A(  P2 )*M(2)*( M2(3)*S(5,6,O(P1))
8569      &                      +S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1)))
8570      &                     -A(O(P2))*M(3)*( M2(2)*S(5,6,O(P1))
8571      &                      +S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1))))
8572           E(P1,P2) =CN(2)*( B(  P2 )*M(4)*( M2(5)*S(7,8,O(P1))
8573      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
8574      &                     -B(O(P2))*M(5)*( M2(4)*S(7,8,O(P1))
8575      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
8576         ENDIF
8577  9    CONTINUE
8578 C--now put the whole thing together to give the matrix element
8579       DO 10 P1=1,2
8580       DO 10 P2=1,2
8581       DO 10 P3=1,2
8582       DO 10 P4=1,2
8583         P0=O(P1)
8584         IF(P1.EQ.P3) THEN
8585           ME(P1,P2,P3,P4) =
8586      & APP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,2,P0)+BMP(P3,P4)*S(8,2,P0))
8587      &           +S(7,2,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
8588      &+APM(P1,P2)*(S(5,7,P0)*(BPM(P3,P4)*S(4,2,P1)+BMM(P3,P4)*S(8,2,P1))
8589      &           +S(3,2,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0)))
8590      &+AMP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,6,P0)+BMP(P3,P4)*S(8,6,P0))
8591      &           +S(7,6,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
8592      &+AMM(P1,P2)*(S(3,6,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0))
8593      &           +S(5,7,P0)*(BPM(P3,P4)*S(4,6,P1)+BMM(P3,P4)*S(8,6,P1)))
8594         ELSE
8595           ME(P1,P2,P3,P4) =
8596      & APP(P1,P2)*(S(3,2,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P4)*S(1,8,P1))
8597      &           +S(1,7,P1)*(BPM(P3,P4)*S(4,2,P0)+BMM(P3,P4)*S(8,2,P0)))
8598      &+APM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,2,P1)+BMP(P3,P4)*S(8,2,P1))
8599      &           +S(7,2,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
8600      &+AMP(P1,P2)*(S(3,6,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P3)*S(1,8,P1))
8601      &           +S(1,7,P1)*(BPM(P3,P4)*S(4,6,P0)+BMM(P3,P4)*S(8,6,P0)))
8602      &+AMM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,6,P1)+BMP(P3,P4)*S(8,6,P1))
8603      &           +S(7,6,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
8604         ENDIF
8605       ME(P1,P2,P3,P4) = TWO*ME(P1,P2,P3,P4)
8606      &      +C(P1,P2)*(
8607      &        BPP(P3,P4)*F23(P3,P3,3,4)+BPM(P3,P4)*F23(O(P3),O(P3),7,4)
8608      &       +BMP(P3,P4)*F23(P3,P3,3,8)+BMM(P3,P4)*F23(O(P3),O(P3),7,8))
8609      &      +E(P3,P4)*(
8610      &        APP(P1,P2)*F45(P1,P1,1,2)+APM(P1,P2)*F45(P0,P0,5,2)
8611      &       +AMP(P1,P2)*F45(P1,P1,1,6)+AMM(P1,P2)*F45(P0,P0,5,6))
8612      &       +DOT*C(P1,P2)*E(P3,P4)
8613  10   ME(P1,P2,P3,P4) = PRE*ME(P1,P2,P3,P4)
8614 C--compute the weight
8615       WGT = ZERO
8616       DO 40 P1=1,2
8617       DO 40 P2=1,2
8618       DO 40 P3=1,2
8619       DO 40 P4=1,2
8620  40   WGT = WGT+DREAL(ME(P1,P2,P3,P4)*DCONJG(ME(P1,P2,P3,P4)))
8621 C--normalise this for phase space
8622       WGT = WGT*PHS
8623 C--enter the matrix element into the spin common block
8624       IF(GENEV.AND.SYSPIN) THEN
8625         NSPN = 5
8626         DO 11 P1=1,2
8627         DO 11 P2=1,2
8628         DO 11 P3=1,2
8629         DO 11 P4=1,2
8630  11     MESPN(P1,P2,P3,P4,1,1) = ME(P1,P2,P3,P4)
8631         SPNCFC(1,1,1) = ONE
8632         NCFL(1) = 1
8633       ENDIF
8634       END
8635 CDECK  ID>, HWDBOS.
8636 *CMZ :-        -23/05/96  18.34.17  by  Mike Seymour
8637 *-- Author :    Mike Seymour
8638 C-----------------------------------------------------------------------
8639       SUBROUTINE HWDBOS(IBOSON)
8640 C-----------------------------------------------------------------------
8641 C     DECAY GAUGE BOSONS (ALREADY FOUND BY HWDHAD)
8642 C     USES SPIN DENSITY MATRIX IN RHOHEP (1ST CMPT=>-VE,2=>LONG,3=>+VE)
8643 C     IF BOSON CAME FROM HIGGS DECAY, GIVE BOTH THE SAME HELICITY (EPR)
8644 C     IF BOSON CAME FROM W+1JET, GIVE IT THE CORRECT DECAY CORRELATIONS
8645 C--BRW FIX 20/07/04: ADD FULL DECAY CORRELATIONS FOR W/Z+HIGGS
8646 C-----------------------------------------------------------------------
8647       INCLUDE 'herwig65.inc'
8648       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWULDO,R(3,3),CV,CA,BR,PCM,
8649      & PBOS(5),PMAX,PROB,RRLL,RLLR
8650       INTEGER HWRINT,IBOS,IBOSON,IPAIR,ICMF,IOPT,IHEL,IMOTH,
8651      & I,IQRK,IANT,ID,IQ
8652       LOGICAL QUARKS
8653       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWULDO,HWRINT
8654       IBOS=IBOSON
8655       IF (IDHW(IBOS).LT.198.OR.IDHW(IBOS).GT.200) THEN
8656         CALL HWWARN('HWDBOS',101)
8657         GOTO 999
8658       ENDIF
8659       QUARKS=.FALSE.
8660 C---SEE IF IT IS PART OF A PAIR
8661       IMOTH=JMOHEP(1,IBOS)
8662       IPAIR=JMOHEP(2,IBOS)
8663       ICMF=JMOHEP(1,IBOS)
8664 C--BRW FIX 17/07/03
8665       IF (IPAIR.EQ.IBOS) THEN
8666         IOPT=0
8667         IF (IPRO.EQ.26.OR.IPRO.EQ.27) ICMF=JMOHEP(1,IMOTH)
8668       ELSE
8669         IF (IDHW(ICMF).EQ.IDHW(IBOS).AND.ISTHEP(ICMF)/10.EQ.12) THEN
8670           IPAIR=JMOHEP(2,ICMF)
8671           IF (IPAIR.NE.0) THEN
8672             IPAIR=JDAHEP(1,IPAIR)
8673             IF (IPAIR.NE.0) JMOHEP(2,IPAIR)=IBOS
8674           ENDIF
8675           ICMF=JMOHEP(1,ICMF)
8676         ENDIF
8677         IOPT=0
8678         IF (IPAIR.NE.0) THEN
8679           IF (JMOHEP(2,IPAIR).NE.IBOS.OR.
8680      &        IDHW(IPAIR).LT.198.OR.IDHW(IPAIR).GT.200) IPAIR=0
8681         ENDIF
8682         IF (IPAIR.GT.0.AND.IPAIR.NE.IBOS) IOPT=1
8683       ENDIF
8684 C--END FIX
8685 C---SELECT DECAY PRODUCTS
8686    10 CALL HWDBOZ(IDHW(IBOS),IDN(1),IDN(2),CV,CA,BR,IOPT)
8687 C---V + 1JET, V+HIGGS DECAYS ARE NOW HANDLED HERE !
8688       IF (IPRO.EQ.21.OR.IPRO.EQ.26.OR.IPRO.EQ.27) THEN
8689         IQRK=IDHW(JMOHEP(1,ICMF))
8690         IANT=IDHW(JMOHEP(2,ICMF))
8691         IF (IQRK.EQ.13 .AND. IANT.LE.6) THEN
8692           IQRK=JMOHEP(2,ICMF)
8693           IANT=JDAHEP(2,ICMF)
8694         ELSEIF (IQRK.EQ.13) THEN
8695           IQRK=JDAHEP(2,ICMF)
8696           IANT=JMOHEP(2,ICMF)
8697         ELSEIF (IANT.EQ.13 .AND. IQRK.LE.6) THEN
8698           IQRK=JMOHEP(1,ICMF)
8699           IANT=JDAHEP(2,ICMF)
8700         ELSEIF (IANT.EQ.13) THEN
8701           IQRK=JDAHEP(2,ICMF)
8702           IANT=JMOHEP(1,ICMF)
8703         ELSEIF (IQRK.GT.IANT) THEN
8704           IQRK=JMOHEP(2,ICMF)
8705           IANT=JMOHEP(1,ICMF)
8706         ELSE
8707           IQRK=JMOHEP(1,ICMF)
8708           IANT=JMOHEP(2,ICMF)
8709         ENDIF
8710         PHEP(5,NHEP+1)=RMASS(IDN(1))
8711         PHEP(5,NHEP+2)=RMASS(IDN(2))
8712         PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
8713         IF (PCM.LT.ZERO) THEN
8714           CALL HWWARN('HWDBOS',103)
8715           GOTO 999
8716         ENDIF
8717         IF (IDHW(IBOS).EQ.200) THEN
8718           ID=IDN(1)
8719           IF (ID.GT.120) ID=ID-110
8720           IQ=IDHW(IQRK)
8721           IF (IQ.GT.6) IQ=IQ-6
8722           RRLL=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
8723      $         (VFCH(ID,1)**2+AFCH(ID,1)**2)
8724      $         +4*VFCH(IQ,1)*AFCH(IQ,1)*
8725      $         VFCH(ID,1)*AFCH(ID,1)
8726           RLLR=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
8727      $         (VFCH(ID,1)**2+AFCH(ID,1)**2)
8728      $         -4*VFCH(IQ,1)*AFCH(IQ,1)*
8729      $         VFCH(ID,1)*AFCH(ID,1)
8730         ELSE
8731           RRLL=ONE
8732           RLLR=ZERO
8733         ENDIF
8734         IF (IPRO.EQ.21) THEN
8735            PMAX=(RRLL+RLLR)*(HWULDO(PHEP(1,IANT),PHEP(1,IBOS))**2+
8736      &                       HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))**2)
8737         ELSE
8738            PMAX=(RRLL+RLLR)* HWULDO(PHEP(1,IANT),PHEP(1,IBOS))*
8739      &                       HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))
8740         ENDIF
8741  1         CALL HWDTWO(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
8742      &                 PCM,TWO,.TRUE.)
8743         IF (IPRO.EQ.21) THEN
8744            PROB=RRLL*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))**2+
8745      &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))**2)+
8746      &          RLLR*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))**2+
8747      &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))**2)
8748         ELSE
8749            PROB=RRLL* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))*
8750      &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))+
8751      &          RLLR* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))*
8752      &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))
8753         ENDIF
8754         IF (PROB.GT.PMAX.OR.PROB.LT.ZERO) THEN
8755           CALL HWWARN('HWDBOS',104)
8756           GOTO 999
8757         ENDIF
8758         IF (PMAX*HWRGEN(0).GT.PROB) GOTO 1
8759       ELSE
8760 C---SELECT HELICITY, UNLESS IT IS THE SECOND OF A HIGGS DECAY (EPR)
8761       IF (IPAIR.NE.IBOS .OR. IDHW(ICMF).NE.201) THEN
8762       IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).LE.ZERO) THEN
8763 C---COPY PARENT HELICITY IF IT WAS A GAUGE BOSON
8764         IF (IDHW(IMOTH).GE.198.AND.IDHW(IMOTH).LE.200) THEN
8765           CALL HWVEQU(3,RHOHEP(1,IMOTH),RHOHEP(1,IBOS))
8766           IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).GT.ZERO)
8767      &    GOTO 20
8768 C---MAY BE FROM A SUSY DECAY
8769         ELSEIF (ABS(IDHEP(IMOTH)).LT.1000000) THEN
8770           CALL HWWARN('HWDBOS',1)
8771         ENDIF
8772         RHOHEP(1,IBOS)=1.
8773         RHOHEP(2,IBOS)=1.
8774         RHOHEP(3,IBOS)=1.
8775       ENDIF
8776  20   IHEL=HWRINT(1,3)
8777       IF (HWRGEN(0).GT.RHOHEP(IHEL,IBOS)) GOTO 20
8778       ENDIF
8779 C---SELECT DIRECTION OF FERMION
8780  30   COSTH=HWRUNI(0,-ONE,ONE)
8781       IF (IHEL.EQ.1 .AND. (ONE+COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
8782       IF (IHEL.EQ.2 .AND. (ONE-COSTH**2).LT.HWRGEN(0)     ) GOTO 30
8783       IF (IHEL.EQ.3 .AND. (ONE-COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
8784 C---GENERATE DECAY RELATIVE TO Z-AXIS
8785       PHEP(5,NHEP+1)=RMASS(IDN(1))
8786       PHEP(5,NHEP+2)=RMASS(IDN(2))
8787       PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
8788       IF (PCM.LT.ZERO) THEN
8789         CALL HWWARN('HWDBOS',102)
8790         GOTO 999
8791       ENDIF
8792       CALL HWRAZM(PCM*SQRT(1-COSTH**2),PHEP(1,NHEP+1),PHEP(2,NHEP+1))
8793       PHEP(3,NHEP+1)=PCM*COSTH
8794       PHEP(4,NHEP+1)=SQRT(PHEP(5,NHEP+1)**2+PCM**2)
8795 C---ROTATE SO THAT Z-AXIS BECOMES BOSON'S DIRECTION IN ORIGINAL CM FRAME
8796       CALL HWULOF(PHEP(1,ICMF),PHEP(1,IBOS),PBOS)
8797       CALL HWUROT(PBOS, ONE,ZERO,R)
8798       CALL HWUROB(R,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
8799 C---BOOST BACK TO LAB
8800       CALL HWULOB(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+1))
8801       CALL HWVDIF(4,PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
8802       ENDIF
8803 C---STATUS, IDs AND POINTERS
8804       ISTHEP(IBOS)=195
8805       DO 50 I=1,2
8806         ISTHEP(NHEP+I)=193
8807         IDHW(NHEP+I)=IDN(I)
8808         IDHEP(NHEP+I)=IDPDG(IDN(I))
8809         JDAHEP(I,IBOS)=NHEP+I
8810         JMOHEP(1,NHEP+I)=IBOS
8811         JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
8812  50   CONTINUE
8813       NHEP=NHEP+2
8814       IF (IDN(1).LE.12) THEN
8815         ISTHEP(NHEP-1)=113
8816         ISTHEP(NHEP)=114
8817         JMOHEP(2,NHEP)=NHEP-1
8818         JDAHEP(2,NHEP)=NHEP-1
8819         JMOHEP(2,NHEP-1)=NHEP
8820         JDAHEP(2,NHEP-1)=NHEP
8821         QUARKS=.TRUE.
8822       ELSE
8823 C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS
8824         CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
8825         CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
8826 C--END FIX
8827       ENDIF
8828 C---IF FIRST OF A PAIR, DO SECOND DECAY
8829       IF (IPAIR.NE.0 .AND. IPAIR.NE.IBOS) THEN
8830         IBOS=IPAIR
8831         GOTO 10
8832       ENDIF
8833 C---IF QUARK DECAY, HADRONIZE
8834       IF (QUARKS) THEN
8835         EMSCA=PHEP(5,IBOS)
8836         CALL HWBGEN
8837         CALL HWDHOB
8838         CALL HWCFOR
8839         CALL HWCDEC
8840       ENDIF
8841  999  RETURN
8842       END
8843 CDECK  ID>, HWDBOZ.
8844 *CMZ :-        -29/04/91  18.00.03  by  Federico Carminati
8845 *-- Author :    Mike Seymour
8846 C-----------------------------------------------------------------------
8847       SUBROUTINE HWDBOZ(IDBOS,IFER,IANT,CV,CA,BR,IOPT)
8848 C-----------------------------------------------------------------------
8849 C     CHOOSE DECAY MODE OF BOSON
8850 C     IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
8851 C-----------------------------------------------------------------------
8852       INCLUDE 'herwig65.inc'
8853       DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
8854      & FACW
8855       INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
8856      & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER
8857       LOGICAL GENLST
8858       EXTERNAL HWRGEN,HWRINT
8859       SAVE FACW,FACZ,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
8860       SAVE IDMODE,BRMODE
8861       DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
8862 C---STORE THE DECAY MODES (FERMION FIRST)
8863       DATA IDMODE/  2,  7,  4,  9,  6, 11,  2,  9,  4,  7,
8864      &            122,127,124,129,126,131,8*0,
8865      &              1,  8,  3, 10,  5, 12,  3,  8,  1, 10,
8866      &            121,128,123,130,125,132,8*0,
8867      &              1,  7,  2,  8,  3,  9,  4, 10,  5, 11,  6, 12,
8868      &            121,127,123,129,125,131,122,128,124,130,126,132/
8869 C---STORE THE BRANCHING RATIOS TO THESE MODES
8870       DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8871      &            0.108D0,0.108D0,4*0.0D0,
8872      &            0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8873      &            0.108D0,0.108D0,4*0.0D0,
8874      &            0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8875      &            0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
8876 C---FACTORS FOR CV AND CA FOR W AND Z
8877       DATA FACW,FACZ/2*0.0D0/
8878       IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
8879       IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
8880       IF (IDBOS.LT.198.OR.IDBOS.GT.200) THEN
8881         CALL HWWARN('HWDBOZ',101)
8882         GOTO 999
8883       ENDIF
8884 C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
8885       IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
8886         NPAIR=0
8887         NUMDEC=0
8888         NWGLST=NWGTS
8889         GENLST=GENEV
8890         IF (IOPT.EQ.2) RETURN
8891       ENDIF
8892       NUMDEC=NUMDEC+1
8893       IF (NUMDEC.GT.MODMAX) THEN
8894         CALL HWWARN('HWDBOZ',102)
8895         GOTO 999
8896       ENDIF
8897 C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
8898       IF (IOPT.EQ.1) THEN
8899         IF (NUMDEC.GT.MODMAX-1) THEN
8900           CALL HWWARN('HWDBOZ',103)
8901           GOTO 999
8902         ENDIF
8903         IF (NPAIR.EQ.0) THEN
8904           IF (HWRGEN(1).GT.HALF) THEN
8905             MODTMP=MODBOS(NUMDEC+1)
8906             MODBOS(NUMDEC+1)=MODBOS(NUMDEC)
8907             MODBOS(NUMDEC)=MODTMP
8908           ENDIF
8909           NPAIR=NUMDEC
8910         ELSE
8911           NPAIR=0
8912         ENDIF
8913       ENDIF
8914 C---SELECT USER'S CHOICE
8915       IF (IDBOS.EQ.200) THEN
8916         IF (MODBOS(NUMDEC).EQ.1) THEN
8917           I1=1
8918           I2=6
8919         ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8920           I1=7
8921           I2=7
8922         ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8923           I1=8
8924           I2=8
8925         ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8926           I1=9
8927           I2=9
8928         ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8929           I1=7
8930           I2=8
8931         ELSEIF (MODBOS(NUMDEC).EQ.6) THEN
8932           I1=10
8933           I2=12
8934         ELSEIF (MODBOS(NUMDEC).EQ.7) THEN
8935           I1=5
8936           I2=5
8937         ELSE
8938           I1=1
8939           I2=12
8940         ENDIF
8941       ELSE
8942         IF (MODBOS(NUMDEC).EQ.1) THEN
8943           I1=1
8944           I2=5
8945         ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8946           I1=6
8947           I2=6
8948         ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8949           I1=7
8950           I2=7
8951         ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8952           I1=8
8953           I2=8
8954         ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8955           I1=6
8956           I2=7
8957         ELSE
8958           I1=1
8959           I2=8
8960         ENDIF
8961       ENDIF
8962  10   IDEC=HWRINT(I1,I2)
8963       IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
8964       IFER=IDMODE(1,IDEC,IDBOS-197)
8965       IANT=IDMODE(2,IDEC,IDBOS-197)
8966 C---CALCULATE BRANCHING RATIO
8967 C   (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
8968       BR=0
8969       DO 20 IDEC=I1,I2
8970  20     BR=BR+BRMODE(IDEC,IDBOS-197)
8971       IF (IOPT.EQ.1) THEN
8972         IF (NPAIR.NE.0) THEN
8973           I1LST=I1
8974           I2LST=I2
8975           BRLST=BR
8976         ELSE
8977           BRCOM=0
8978           DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
8979  30         BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
8980           BR=2*BR*BRLST - BRCOM**2
8981         ENDIF
8982       ENDIF
8983 C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
8984 C   CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
8985       IF (IDBOS.EQ.200) THEN
8986         IF (IFER.LE.6) THEN
8987 C Quark couplings
8988            CV=VFCH(IFER,1)
8989            CA=AFCH(IFER,1)
8990         ELSE
8991 C lepton couplings
8992            JFER=IFER-110
8993            CV=VFCH(JFER,1)
8994            CA=AFCH(JFER,1)
8995         ENDIF
8996         CV=CV * FACZ
8997         CA=CA * FACZ
8998       ELSE
8999         CV=FACW
9000         CA=FACW
9001       ENDIF
9002  999  RETURN
9003       END
9004 CDECK  ID>, HWDBZ2.
9005 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
9006 *-- Author :    Peter Richardson based on Mike Seymour's HWDBOZ
9007 C-----------------------------------------------------------------------
9008       SUBROUTINE HWDBZ2(IDBOS,IFER,IANT,CV,CA,BR,IOPT,MASS)
9009 C-----------------------------------------------------------------------
9010 C     CHOOSE DECAY MODE OF BOSON
9011 C     IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
9012 C     IDENTICAL TO HWDBOZ BUT REQUIRES DECAY MODE ACCESSIBLE FOR GIVEN
9013 C     MASS
9014 C-----------------------------------------------------------------------
9015       INCLUDE 'herwig65.inc'
9016       DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
9017      & FACW,MSMODE(12,3),MASS
9018       INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
9019      & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER,NTRY
9020       LOGICAL GENLST
9021       EXTERNAL HWRGEN,HWRINT
9022       SAVE FACW,FACZ,MSMODE,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
9023       SAVE IDMODE,BRMODE
9024       DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
9025 C---STORE THE DECAY MODES (FERMION FIRST)
9026       DATA IDMODE/  2,  7,  4,  9,  6, 11,  2,  9,  4,  7,
9027      &            122,127,124,129,126,131,8*0,
9028      &              1,  8,  3, 10,  5, 12,  3,  8,  1, 10,
9029      &            121,128,123,130,125,132,8*0,
9030      &              1,  7,  2,  8,  3,  9,  4, 10,  5, 11,  6, 12,
9031      &            121,127,123,129,125,131,122,128,124,130,126,132/
9032 C---STORE THE BRANCHING RATIOS TO THESE MODES
9033       DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
9034      &            0.108D0,0.108D0,4*0.0D0,
9035      &            0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
9036      &            0.108D0,0.108D0,4*0.0D0,
9037      &            0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
9038      &            0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
9039       DATA MSMODE/36*0.0D0/
9040 C---FACTORS FOR CV AND CA FOR W AND Z
9041       DATA FACW,FACZ/2*0.0D0/
9042       IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
9043       IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
9044       IF (IDBOS.LT.198.OR.IDBOS.GT.200) THEN
9045         CALL HWWARN('HWDBZ2',101)
9046         GOTO 999
9047       ENDIF
9048       IF(MSMODE(1,1).EQ.ZERO) THEN
9049         DO I1=1,12
9050           DO I2=1,3
9051             MSMODE(I1,I2)=RMASS(IDMODE(1,I1,I2))+RMASS(IDMODE(2,I1,I2))
9052           ENDDO
9053         ENDDO
9054       ENDIF
9055 C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
9056       IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
9057         NPAIR=0
9058         NUMDEC=0
9059         NWGLST=NWGTS
9060         GENLST=GENEV
9061         IF (IOPT.EQ.2) RETURN
9062       ENDIF
9063       NUMDEC=NUMDEC+1
9064       IF (NUMDEC.GT.MODMAX) THEN
9065         CALL HWWARN('HWDBZ2',102)
9066         GOTO 999
9067       ENDIF
9068 C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
9069       IF (IOPT.EQ.1) THEN
9070         IF (NUMDEC.GT.MODMAX-1) THEN
9071           CALL HWWARN('HWDBZ2',103)
9072           GOTO 999
9073         ENDIF
9074         IF (NPAIR.EQ.0) THEN
9075           IF (HWRGEN(1).GT.HALF) THEN
9076             MODTMP=MODBOS(NUMDEC+1)
9077             MODBOS(NUMDEC+1)=MODBOS(NUMDEC)
9078             MODBOS(NUMDEC)=MODTMP
9079           ENDIF
9080           NPAIR=NUMDEC
9081         ELSE
9082           NPAIR=0
9083         ENDIF
9084       ENDIF
9085 C---SELECT USER'S CHOICE
9086       IF (IDBOS.EQ.200) THEN
9087         IF (MODBOS(NUMDEC).EQ.1) THEN
9088           I1=1
9089           I2=6
9090         ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
9091           I1=7
9092           I2=7
9093         ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
9094           I1=8
9095           I2=8
9096         ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
9097           I1=9
9098           I2=9
9099         ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
9100           I1=7
9101           I2=8
9102         ELSEIF (MODBOS(NUMDEC).EQ.6) THEN
9103           I1=10
9104           I2=12
9105         ELSEIF (MODBOS(NUMDEC).EQ.7) THEN
9106           I1=5
9107           I2=5
9108         ELSE
9109           I1=1
9110           I2=12
9111         ENDIF
9112       ELSE
9113         IF (MODBOS(NUMDEC).EQ.1) THEN
9114           I1=1
9115           I2=5
9116         ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
9117           I1=6
9118           I2=6
9119         ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
9120           I1=7
9121           I2=7
9122         ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
9123           I1=8
9124           I2=8
9125         ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
9126           I1=6
9127           I2=7
9128         ELSE
9129           I1=1
9130           I2=8
9131         ENDIF
9132       ENDIF
9133       NTRY = 0
9134  10   IDEC=HWRINT(I1,I2)
9135       NTRY = NTRY+1
9136       IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
9137       IF(MASS.LT.MSMODE(IDEC,IDBOS-197).AND.NTRY.LT.NBTRY) GOTO 10
9138       IF(NTRY.GE.NBTRY) THEN
9139         BR = ZERO
9140         RETURN
9141       ENDIF
9142       IFER=IDMODE(1,IDEC,IDBOS-197)
9143       IANT=IDMODE(2,IDEC,IDBOS-197)
9144 C---CALCULATE BRANCHING RATIO
9145 C   (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
9146       BR=0
9147       DO 20 IDEC=I1,I2
9148  20     IF(MSMODE(IDEC,IDBOS-197).LT.MASS) BR=BR+BRMODE(IDEC,IDBOS-197)
9149       IF (IOPT.EQ.1) THEN
9150         IF (NPAIR.NE.0) THEN
9151           I1LST=I1
9152           I2LST=I2
9153           BRLST=BR
9154         ELSE
9155           BRCOM=0
9156           DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
9157  30         IF(MSMODE(IDEC,IDBOS-197).LT.MASS)
9158      &            BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
9159           BR=2*BR*BRLST - BRCOM**2
9160         ENDIF
9161       ENDIF
9162 C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
9163 C   CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
9164       IF (IDBOS.EQ.200) THEN
9165         IF (IFER.LE.6) THEN
9166 C Quark couplings
9167            CV=VFCH(IFER,1)
9168            CA=AFCH(IFER,1)
9169         ELSE
9170 C lepton couplings
9171            JFER=IFER-110
9172            CV=VFCH(JFER,1)
9173            CA=AFCH(JFER,1)
9174         ENDIF
9175         CV=CV * FACZ
9176         CA=CA * FACZ
9177       ELSE
9178         CV=FACW
9179         CA=FACW
9180       ENDIF
9181  999  RETURN
9182       END
9183 CDECK  ID>, HWDCHK.
9184 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
9185 *-- Author :    Ian Knowles
9186 C-----------------------------------------------------------------------
9187       SUBROUTINE HWDCHK(IDKY,L,IFGO)
9188 C-----------------------------------------------------------------------
9189 C     Checks line L of decay table is compatible with decay of particle
9190 C     IDKY, tidies up the line and sets NPRODS.
9191 C-----------------------------------------------------------------------
9192       INCLUDE 'herwig65.inc'
9193       DOUBLE PRECISION EPS,QS,Q,DM
9194       INTEGER IDKY,L,IFAULT,I,ID,J
9195       LOGICAL IFGO
9196       PARAMETER (EPS=1.D-6)
9197       IFGO = .FALSE.
9198       IF (VTOCDK(IDKY).AND.VTORDK(IDKY)) THEN
9199         IFGO = .TRUE.
9200         RETURN
9201       ENDIF
9202       IFAULT=0
9203       QS=FLOAT(ICHRG(IDKY))
9204       IF (IDKY.LE.12.OR.(IDKY.GE.109.AND.IDKY.LE.120)
9205      &              .OR.(IDKY.GE.209.AND.IDKY.LE.220)
9206      &              .OR.(IDKY.GE.401.AND.IDKY.LE.424)) QS=QS/3.
9207       DM=RMASS(IDKY)
9208       NPRODS(L)=0
9209       DO 10 I=1,5
9210       ID=IDKPRD(I,L)
9211       IF (ID.LT.0.OR.ID.EQ.20.OR.ID.GT.NRES) THEN
9212         WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5)
9213         IFAULT=IFAULT+1
9214       ELSEIF (ID.NE.0) THEN
9215         IF (VTORDK(ID)) THEN
9216           WRITE(6,30) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5),RNAME(ID)
9217           IFAULT=IFAULT+1
9218         ENDIF
9219         NPRODS(L)=NPRODS(L)+1
9220         IDKPRD(NPRODS(L),L)=ID
9221         Q=FLOAT(ICHRG(ID))
9222         IF (ID.LE.12.OR.(ID.GE.109.AND.ID.LE.120)
9223      &              .OR.(ID.GE.209.AND.ID.LE.220)
9224      &              .OR.(ID.GE.401.AND.ID.LE.424)) Q=Q/3.
9225         QS=QS-Q
9226         DM=DM-RMASS(ID)
9227       ENDIF
9228   10  CONTINUE
9229 C print any warnings
9230       IF (NPRODS(L).EQ.0) THEN
9231         WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5)
9232         IFAULT=IFAULT+1
9233       ELSE
9234         IF (ABS(QS).GT.EPS) THEN
9235           WRITE(6,40) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),QS
9236           IFAULT=IFAULT+1
9237         ENDIF
9238 C--modification so doesn't remove H --> W*W* Z*Z* modes
9239         IF (DM.LT.ZERO.AND..NOT.
9240      &        (FOURB.AND.IDK(L).GE.203.AND.IDK(L).LE.205.AND.
9241      &         IDKPRD(1,L).GE.198.AND.IDKPRD(2,L).LE.200.AND.
9242      &         IDKPRD(2,L).GE.198.AND.IDKPRD(2,L).LE.200)) THEN
9243           WRITE(6,50) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),DM
9244           IFAULT=IFAULT+1
9245         ENDIF
9246       ENDIF
9247   20  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9248      &       1X,'contains no or unrecognised decay product(s)')
9249   30  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9250      &       1X,'contains decay product ',A8,' which is vetoed')
9251   40  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9252      &       1X,'violates charge conservation, Qin-Qout= ',F6.3)
9253   50  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9254      &       1X,'is kinematically not allowed, Min-Mout= ',F10.3)
9255       IF (IFAULT.NE.0) THEN
9256         IFGO = .TRUE.
9257         RETURN
9258       ELSE
9259         RETURN
9260       ENDIF
9261       END
9262 CDECK  ID>, HWDCLE.
9263 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
9264 *-- Author :    Luca Stanco
9265 C-----------------------------------------------------------------------
9266       SUBROUTINE HWDCLE(IHEP)
9267 C-----------------------------------------------------------------------
9268 C INTERFACE TO QQ-CLEO MONTE CARLO (LS 11/12/91)
9269 C-----------------------------------------------------------------------
9270       INCLUDE 'herwig65.inc'
9271       INTEGER IHEP,IIHEP,NHEPHF,QQLMAT
9272       LOGICAL QQLERR
9273       CHARACTER*8 NAME
9274       EXTERNAL QQLMAT
9275 C---QQ-CLEO COMMON'S
9276 C***                 MCPARS.INC
9277       INTEGER MCTRK, NTRKS, MCVRTX, NVTXS, MCHANS, MCDTRS, MPOLQQ
9278       INTEGER MCNUM, MCSTBL, MCSTAB, MCTLQQ, MDECQQ
9279       INTEGER MHLPRB, MHLLST, MHLANG, MCPLST, MFDECA
9280       PARAMETER (MCTRK = 512)
9281       PARAMETER (NTRKS = MCTRK)
9282       PARAMETER (MCVRTX = 256)
9283       PARAMETER (NVTXS = MCVRTX)
9284       PARAMETER (MCHANS = 4000)
9285       PARAMETER (MCDTRS = 8000)
9286       PARAMETER (MPOLQQ = 300)
9287       PARAMETER (MCNUM = 500)
9288       PARAMETER (MCSTBL = 40)
9289       PARAMETER (MCSTAB = 512)
9290       PARAMETER (MCTLQQ = 100)
9291       PARAMETER (MDECQQ = 300)
9292       PARAMETER (MHLPRB = 500)
9293       PARAMETER (MHLLST = 1000)
9294       PARAMETER (MHLANG = 500)
9295       PARAMETER (MCPLST = 200)
9296       PARAMETER (MFDECA = 5)
9297 C***                 MCPROP.INC
9298       REAL AMASS, CHARGE, CTAU, SPIN, RWIDTH, RMASMN, RMASMX
9299       REAL RMIXPP, RCPMIX
9300       INTEGER NPMNQQ, NPMXQQ, IDMC, INVMC, LPARTY, CPARTY
9301       INTEGER IMIXPP, ICPMIX
9302       COMMON/MCMAS1/
9303      *       NPMNQQ, NPMXQQ,
9304      *       AMASS(-20:MCNUM), CHARGE(-20:MCNUM), CTAU(-20:MCNUM),
9305      *       IDMC(-20:MCNUM), SPIN(-20:MCNUM),
9306      *       RWIDTH(-20:MCNUM), RMASMN(-20:MCNUM), RMASMX(-20:MCNUM),
9307      *       LPARTY(-20:MCNUM), CPARTY(-20:MCNUM),
9308      *       IMIXPP(-20:MCNUM), RMIXPP(-20:MCNUM),
9309      *       ICPMIX(-20:MCNUM), RCPMIX(-20:MCNUM),
9310      *       INVMC(0:MCSTBL)
9311 C
9312       INTEGER NPOLQQ, IPOLQQ
9313       COMMON/MCPOL1/
9314      *       NPOLQQ, IPOLQQ(5,MPOLQQ)
9315 C
9316       CHARACTER QNAME*10, PNAME*10
9317       COMMON/MCNAMS/
9318      *       QNAME(37), PNAME(-20:MCNUM)
9319 C
9320 C***                 MCCOMS.INC
9321       INTEGER NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ
9322       INTEGER IEVTQQ, IRUNQQ, IBMRAD
9323       INTEGER NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ
9324       INTEGER IRANQQ, IRANMC, IRANCC, IRS2QQ
9325       INTEGER IPFTQQ, IPCDQQ, IPRNTV, ITYPEV, IDECSV, IDAUTV
9326       INTEGER ISTBMC, NDAUTV
9327       INTEGER IVPROD, IVDECA
9328       REAL BFLDQQ
9329       REAL ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ
9330       REAL BPOSQQ, BSIZQQ
9331       REAL ECM, P4CMQQ, P4PHQQ, ENERNW, BEAMNW, BEAMP, BEAMN
9332       REAL PSAV, P4QQ, HELCQQ
9333       CHARACTER DATEQQ*20, TIMEQQ*20, FOUTQQ*80, FCTLQQ*80, FDECQQ*80
9334       CHARACTER FGEOQQ*80
9335       CHARACTER CCTLQQ*80, CDECQQ*80
9336 C
9337       COMMON/MCCM1A/
9338      *   NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ(3), BFLDQQ,
9339      *   ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ,
9340      *   BPOSQQ(3), BSIZQQ(3),
9341      *   IEVTQQ, IRUNQQ,
9342      *   IBMRAD, ECM, P4CMQQ(4), P4PHQQ(4),
9343      *   ENERNW, BEAMNW, BEAMP, BEAMN,
9344      *   NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ,
9345      *   IRANQQ(2), IRANMC(2), IRANCC(2), IRS2QQ(5),
9346      *   IPFTQQ(MCTRK), IPCDQQ(MCTRK), IPRNTV(MCTRK), ITYPEV(MCTRK,2),
9347      *   IDECSV(MCTRK), IDAUTV(MCTRK), ISTBMC(MCTRK), NDAUTV(MCTRK),
9348      *   IVPROD(MCTRK), IVDECA(MCTRK),
9349      *   PSAV(MCTRK,4), HELCQQ(MCTRK), P4QQ(4,MCTRK)
9350 C
9351       COMMON/MCCM1B/
9352      *   DATEQQ, TIMEQQ, FOUTQQ, FCTLQQ, FDECQQ, FGEOQQ,
9353      *   CCTLQQ(MCTLQQ), CDECQQ(MDECQQ)
9354 C
9355       INTEGER NVRTX, ITRKIN, NTRKOU, ITRKOU, IVKODE
9356       REAL XVTX, TVTX, RVTX
9357       COMMON/MCCM2/
9358      *   NVRTX, XVTX(MCVRTX,3), TVTX(MCVRTX), RVTX(MCVRTX),
9359      *   ITRKIN(MCVRTX), NTRKOU(MCVRTX), ITRKOU(MCVRTX),
9360      *   IVKODE(MCVRTX)
9361 C***                 MCGEN.INC
9362       INTEGER QQIST,QQIFR,QQN,QQK,QQMESO,QQNC,QQKC,QQLASTN
9363       REAL QQPUD,QQPS1,QQSIGM,QQMAS,QQPAR,QQCMIX,QQCND,QQBSPI,QQBSYM,QQP
9364       REAL QQPC,QQCZF
9365 C
9366       COMMON/DATA1/QQIST,QQIFR,QQPUD,QQPS1,QQSIGM,QQMAS(15),QQPAR(25)
9367       COMMON/DATA2/QQCZF(15),QQMESO(36),QQCMIX(6,2)
9368       COMMON/DATA3/QQCND(3)
9369       COMMON/DATA5/QQBSPI(5),QQBSYM(3)
9370       COMMON/JET/QQN,QQK(250,2),QQP(250,5),QQNC,QQKC(10),QQPC(10,4),
9371      *  QQLASTN
9372 C---
9373       IF(FSTEVT) THEN
9374 C---INITIALIZE QQ-CLEO
9375         CALL QQINIT(QQLERR)
9376         IF(QQLERR) CALL HWWARN('HWDEUR',500)
9377       ENDIF
9378 C---CONSTRUCT THE HADRON FOR QQ-CLEO
9379 C NOTE: THE IDPDG CODE IS PROVIDED THROUGH THE QQLMAT ROUTINE
9380 C       FROM THE CLEO PACKAGE (QQ-CLEO <--> IDPDG CODE TRANSFORMATION)
9381       QQN=1
9382       IDHEP(IHEP)=IDPDG(IDHW(IHEP))
9383       QQK(1,1)=0
9384       QQK(1,2)=QQLMAT(IDHEP(IHEP),1)
9385       QQP(1,1)=SNGL(PHEP(1,IHEP))
9386       QQP(1,2)=SNGL(PHEP(2,IHEP))
9387       QQP(1,3)=SNGL(PHEP(3,IHEP))
9388       QQP(1,5)=AMASS(QQK(1,2))
9389       QQP(1,4)=SQRT(QQP(1,5)**2+QQP(1,1)**2+QQP(1,2)**2+QQP(1,3)**2)
9390 C---LET QQ-CLEO DO THE JOB
9391       QQNTRK=0
9392       NVRTX=0
9393       CALL DECADD(.FALSE.)
9394 C---UPDATE THE HERWIG TABLE : LOOP OVER QQN-CLEO FINAL PARTICLES
9395       DO 40 IIHEP=1,QQN
9396       NHEP=NHEP+1
9397       ISTHEP(NHEP)=198
9398       IF(ITYPEV(IIHEP,2).GE.0) ISTHEP(NHEP)=1
9399       IDHEP(NHEP)=QQLMAT(ITYPEV(IIHEP,1),2)
9400       CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
9401       IF(IIHEP.EQ.1) THEN
9402         ISTHEP(IHEP)=199
9403         JDAHEP(1,IHEP)=NHEP
9404         JDAHEP(2,IHEP)=NHEP
9405         ISTHEP(NHEP)=199
9406         NHEPHF=NHEP
9407         JMOHEP(1,NHEP)=IHEP
9408         JMOHEP(2,NHEP)=IHEP
9409       ELSE
9410         JMOHEP(1,NHEP)=IPRNTV(IIHEP)+NHEPHF-1
9411         JMOHEP(2,NHEP)=NHEPHF
9412       ENDIF
9413       JDAHEP(1,NHEP)=0
9414       JDAHEP(2,NHEP)=0
9415       IF(NDAUTV(IIHEP).GT.0) THEN
9416         JDAHEP(1,NHEP)=IDAUTV(IIHEP)+NHEPHF-1
9417         JDAHEP(2,NHEP)=JDAHEP(1,NHEP)+NDAUTV(IIHEP)-1
9418       ENDIF
9419       PHEP(1,NHEP)=QQP(IIHEP,1)
9420       PHEP(2,NHEP)=QQP(IIHEP,2)
9421       PHEP(3,NHEP)=QQP(IIHEP,3)
9422       PHEP(4,NHEP)=QQP(IIHEP,4)
9423       PHEP(5,NHEP)=QQP(IIHEP,5)
9424       VHEP(1,NHEP)=XVTX(IVPROD(IIHEP),1)
9425       VHEP(2,NHEP)=XVTX(IVPROD(IIHEP),2)
9426       VHEP(3,NHEP)=XVTX(IVPROD(IIHEP),3)
9427       VHEP(4,NHEP)=0.
9428    40 CONTINUE
9429       END
9430 CDECK  ID>, HWDEUR.
9431 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
9432 *-- Author :    Luca Stanco
9433 C-----------------------------------------------------------------------
9434       SUBROUTINE HWDEUR(IHEP)
9435 C-----------------------------------------------------------------------
9436 C INTERFACE TO EURODEC PACKAGE (LS 10/29/91)
9437 C-----------------------------------------------------------------------
9438       INCLUDE 'herwig65.inc'
9439       INTEGER IHEP,IIHEP,NHEPHF,IEUPDG,IPDGEU
9440       CHARACTER*8 NAME
9441 C---EURODEC COMMON'S : INITIAL INPUT
9442       INTEGER EULUN0,EULUN1,EULUN2,EURUN,EUEVNT
9443       CHARACTER*4 EUDATD,EUTIT
9444       REAL AMINIE(12),EUWEI
9445       COMMON/INPOUT/EULUN0,EULUN1,EULUN2
9446       COMMON/FILNAM/EUDATD,EUTIT
9447       COMMON/HVYINI/AMINIE
9448       COMMON/RUNINF/EURUN,EUEVNT,EUWEI
9449 C---EURODEC WORKING COMMON'S
9450       INTEGER NPMAX,NTMAX
9451       PARAMETER (NPMAX=18,NTMAX=2000)
9452       INTEGER EUNP,EUIP(NPMAX),EUPHEL(NPMAX),EUTEIL,EUINDX(NTMAX),
9453      &    EUORIG(NTMAX),EUDCAY(NTMAX),EUTHEL(NTMAX)
9454       REAL EUAPM(NPMAX),EUPCM(5,NPMAX),EUPVTX(3,NPMAX),EUPTEI(5,NTMAX),
9455      &    EUSECV(3,NTMAX)
9456       COMMON/MOMGEN/EUNP,EUIP,EUAPM,EUPCM,EUPHEL,EUPVTX
9457       COMMON/RESULT/EUTEIL,EUPTEI,EUINDX,EUORIG,EUDCAY,EUTHEL,EUSECV
9458 C---EURODEC COMMON'S FOR DECAY PROPERTIES
9459       INTEGER NGMAX,NCMAX
9460       PARAMETER (NGMAX=400,NCMAX=9000)
9461       INTEGER EUNPA,EUIPC(NGMAX),EUIPDG(NGMAX),EUIDP(NGMAX),
9462      &     EUCONV(NCMAX)
9463       REAL EUPM(NGMAX),EUPLT(NGMAX)
9464       COMMON/PCTABL/EUNPA,EUIPC,EUIPDG,EUPM,EUPLT,EUIDP
9465       COMMON/CONVRT/EUCONV
9466 C---
9467       IF(FSTEVT) THEN
9468 C---CHANGE HERE THE DEFAULT VALUES OF EURODEC COMMON'S
9469 C
9470 C---INITIALIZE EURODEC COMMON'S
9471 CC        CALL EUDCIN
9472 C---INITIALIZE EURODEC
9473         CALL EUDINI
9474       ENDIF
9475 C---CONSTRUCT THE HADRON FOR EURODEC FROM ID1,ID2
9476       EUNP=1
9477       IDHEP(IHEP)=IDPDG(IDHW(IHEP))
9478       EUIP(1)=IPDGEU(IDHEP(IHEP))
9479       EUAPM(1)=EUPM(EUCONV(IABS(EUIP(1))))
9480       EUPCM(1,1)=SNGL(PHEP(1,IHEP))
9481       EUPCM(2,1)=SNGL(PHEP(2,IHEP))
9482       EUPCM(3,1)=SNGL(PHEP(3,IHEP))
9483       EUPCM(5,1)=SQRT(EUPCM(1,1)**2+EUPCM(2,1)**2+EUPCM(3,1)**2)
9484       EUPCM(4,1)=SQRT(EUPCM(5,1)**2+EUAPM(1)**2)
9485 C NOT POLARIZED HADRONS
9486       EUPHEL(1)=0
9487 C HADRONS START FROM PRIMARY VERTEX
9488       EUPVTX(1,1)=0.
9489       EUPVTX(2,1)=0.
9490       EUPVTX(3,1)=0.
9491 C---LET EURODEC DO THE JOB
9492       EUTEIL=0
9493       CALL FRAGMT(1,1,0)
9494 C---UPDATE THE HERWIG TABLE : LOOP OVER N-EURODEC FINAL PARTICLES
9495       DO 40 IIHEP=1,EUTEIL
9496       NHEP=NHEP+1
9497       ISTHEP(NHEP)=198
9498       IF(EUDCAY(IIHEP).EQ.0) ISTHEP(NHEP)=1
9499       IDHEP(NHEP)=IEUPDG(EUINDX(IIHEP))
9500       CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
9501       IF(IIHEP.EQ.1) THEN
9502         ISTHEP(IHEP)=199
9503         JDAHEP(1,IHEP)=NHEP
9504         JDAHEP(2,IHEP)=NHEP
9505         ISTHEP(NHEP)=199
9506         NHEPHF=NHEP
9507         JMOHEP(1,NHEP)=IHEP
9508         JMOHEP(2,NHEP)=IHEP
9509         JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
9510         JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
9511       ELSE
9512         JMOHEP(1,NHEP)=MOD(EUORIG(IIHEP),10000)+NHEPHF-1
9513         JMOHEP(2,NHEP)=NHEPHF
9514         JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
9515         JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
9516       ENDIF
9517       PHEP(1,NHEP)=EUPTEI(1,IIHEP)
9518       PHEP(2,NHEP)=EUPTEI(2,IIHEP)
9519       PHEP(3,NHEP)=EUPTEI(3,IIHEP)
9520       PHEP(4,NHEP)=EUPTEI(4,IIHEP)
9521       PHEP(5,NHEP)=EUPTEI(5,IIHEP)
9522       VHEP(1,NHEP)=EUSECV(1,IIHEP)
9523       VHEP(2,NHEP)=EUSECV(2,IIHEP)
9524       VHEP(3,NHEP)=EUSECV(3,IIHEP)
9525       VHEP(4,NHEP)=0.
9526       IF (IIHEP.GT.NTMAX) THEN
9527         CALL HWWARN('HWDEUR',99)
9528         GOTO 999
9529       ENDIF
9530    40 CONTINUE
9531  999  RETURN
9532       END
9533 CDECK  ID>, HWDFOR.
9534 *CMZ :-        -01/04/99  19.52.44  by  Mike Seymour
9535 *-- Author :    Ian Knowles
9536 C-----------------------------------------------------------------------
9537       SUBROUTINE HWDFOR(P0,P1,P2,P3,P4)
9538 C-----------------------------------------------------------------------
9539 C     Generates 4-body decay 0->1+2+3+4 using pure phase space
9540 C-----------------------------------------------------------------------
9541       INCLUDE 'herwig65.inc'
9542       DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),B,C,AA,BB,
9543      & CC,DD,EE,TT,S1,RS1,FF,S2,PP,QQ,RR,P1CM,P234(5),P2CM,P34(5),P3CM
9544       INTEGER NTRY
9545       EXTERNAL HWRGEN
9546       B=P0(5)-P1(5)
9547       C=P2(5)+P3(5)+P4(5)
9548       IF (B.LT.C) THEN
9549         CALL HWWARN('HWDFOR',100)
9550         GOTO 999
9551       ENDIF
9552       AA=(P0(5)+P1(5))**2
9553       BB=B**2
9554       CC=C**2
9555       DD=(P3(5)+P4(5))**2
9556       EE=(P3(5)-P4(5))**2
9557       TT=(B-C)*P0(5)**7/16
9558 C Select squared masses S1 and S2 of 234 and 34 subsystems
9559       NTRY=0
9560   10  NTRY=NTRY+1
9561       IF(NTRY.GT.NDETRY) THEN
9562          CALL HWWARN('HWDFOR',101)
9563          GOTO 999
9564       ENDIF
9565       S1=BB+HWRGEN(1)*(CC-BB)
9566       RS1=SQRT(S1)
9567       FF=(RS1-P2(5))**2
9568       S2=DD+HWRGEN(2)*(FF-DD)
9569       PP=(AA-S1)*(BB-S1)
9570       QQ=((RS1+P2(5))**2-S2)*(FF-S2)/S1
9571       RR=(S2-DD)*(S2-EE)/S2
9572       IF (PP*QQ*RR*(FF-DD)**2.LT.TT*S1*S2*HWRGEN(3)**2) GOTO 10
9573 C Do two body decays: 0-->1+234, 234-->2+34 and 34-->3+4
9574       P1CM=SQRT(PP/4)/P0(5)
9575       P234(5)=RS1
9576       P2CM=SQRT(QQ/4)
9577       P34(5)=SQRT(S2)
9578       P3CM=SQRT(RR/4)
9579       CALL HWDTWO(P0  ,P1,P234,P1CM,TWO,.TRUE.)
9580       CALL HWDTWO(P234,P2,P34 ,P2CM,TWO,.TRUE.)
9581       CALL HWDTWO(P34 ,P3,P4  ,P3CM,TWO,.TRUE.)
9582  999  RETURN
9583       END
9584 CDECK  ID>, HWDFIV.
9585 *CMZ :-        -01/04/99  19.52.44  by  Mike Seymour
9586 *-- Author :    Ian Knowles
9587 C-----------------------------------------------------------------------
9588       SUBROUTINE HWDFIV(P0,P1,P2,P3,P4,P5)
9589 C-----------------------------------------------------------------------
9590 C     Generates 5-body decay 0->1+2+3+4+5 using pure phase space
9591 C-----------------------------------------------------------------------
9592       INCLUDE 'herwig65.inc'
9593       DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),P5(5),B,C,
9594      & AA,BB,CC,DD,EE,FF,TT,S1,RS1,GG,S2,RS2,HH,S3,PP,QQ,RR,SS,P1CM,
9595      & P2345(5),P2CM,P345(5),P3CM,P45(5),P4CM
9596       INTEGER NTRY
9597       EXTERNAL HWRGEN
9598       B=P0(5)-P1(5)
9599       C=P2(5)+P3(5)+P4(5)+P5(5)
9600       IF (B.LT.C) THEN
9601         CALL HWWARN('HWDFIV',100)
9602         GOTO 999
9603       ENDIF
9604       AA=(P0(5)+P1(5))**2
9605       BB=B**2
9606       CC=C**2
9607       DD=(P3(5)+P4(5)+P5(5))**2
9608       EE=(P4(5)+P5(5))**2
9609       FF=(P4(5)-P5(5))**2
9610       TT=(B-C)*P0(5)**11/729
9611 C Select squared masses S1, S2 and S3 of 2345, 345 and 45 subsystems
9612       NTRY=0
9613   10  NTRY=NTRY+1
9614       IF(NTRY.GT.NDETRY) THEN
9615          CALL HWWARN('HWDFIV',101)
9616          GOTO 999
9617       ENDIF
9618       S1=BB+HWRGEN(1)*(CC-BB)
9619       RS1=SQRT(S1)
9620       GG=(RS1-P2(5))**2
9621       S2=DD+HWRGEN(2)*(GG-DD)
9622       RS2=SQRT(S2)
9623       HH=(RS2-P3(5))**2
9624       S3=EE+HWRGEN(3)*(HH-EE)
9625       PP=(AA-S1)*(BB-S1)
9626       QQ=((RS1+P2(5))**2-S2)*(GG-S2)/S1
9627       RR=((RS2+P3(5))**2-S3)*(HH-S3)/S2
9628       SS=(S3-EE)*(S3-FF)/S3
9629       IF (PP*QQ*RR*SS*((GG-DD)*(HH-EE))**2.LT.TT*S1*S2*S3*HWRGEN(4)**2)
9630      & GOTO 10
9631 C Do two body decays: 0-->1+2345, 2345-->2+345, 345-->3+45 and 45-->4+5
9632       P1CM=SQRT(PP/4)/P0(5)
9633       P2345(5)=RS1
9634       P2CM=SQRT(QQ/4)
9635       P345(5)=RS2
9636       P3CM=SQRT(RR/4)
9637       P45(5)=SQRT(S3)
9638       P4CM=SQRT(SS/4)
9639       CALL HWDTWO(P0   ,P1,P2345,P1CM,TWO,.TRUE.)
9640       CALL HWDTWO(P2345,P2,P345 ,P2CM,TWO,.TRUE.)
9641       CALL HWDTWO(P345 ,P3,P45  ,P3CM,TWO,.TRUE.)
9642       CALL HWDTWO(P45  ,P4,P5   ,P4CM,TWO,.TRUE.)
9643  999  RETURN
9644       END
9645 CDECK  ID>, HWDHAD.
9646 *CMZ :-        -26/04/91  11.11.54  by  Peter Richardson
9647 *-- Author :    Ian Knowles, Bryan Webber & Mike Seymour
9648 C-----------------------------------------------------------------------
9649       SUBROUTINE HWDHAD
9650 C-----------------------------------------------------------------------
9651 C     GENERATES DECAYS OF UNSTABLE HADRONS AND LEPTONS
9652 C     Modified for TAUOLA interface 16/10/01 PR
9653 C-----------------------------------------------------------------------
9654       INCLUDE 'herwig65.inc'
9655       COMMON/FFS/TB,BT
9656       COMMON/SFF/IT1,IB1,IT2,IB2
9657       DOUBLE PRECISION TB,BT
9658       INTEGER IT1,IB1,IT2,IB2
9659       DOUBLE PRECISION HWRGEN,HWULDO,RN,BF,COSANG,RSUM,DIST(4),VERTX(4),
9660      & PMIX,WTMX,WTMX2,XS,DOT1,DOT2,HWDPWT,HWDWWT,HWDHWT,XXX,YYY
9661       INTEGER IHEP,ID,MHEP,IDM,I,IDS,IM,MO,IPDG
9662       LOGICAL STABLE
9663       EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT,HWULDO
9664       IF (IERROR.NE.0) RETURN
9665       DO 100 IHEP=1,NMXHEP
9666       IF (IHEP.GT.NHEP) THEN
9667         ISTAT=90
9668         RETURN
9669       ELSEIF (ISTHEP(IHEP).EQ.120 .AND.
9670      &  JDAHEP(1,IHEP).EQ.IHEP.AND.JDAHEP(2,IHEP).EQ.IHEP) THEN
9671 C---COPY COLOUR SINGLET CMF
9672         NHEP=NHEP+1
9673         IF (NHEP.GT.NMXHEP) THEN
9674           CALL HWWARN('HWDHAD',100)
9675           GOTO 999
9676         ENDIF
9677         CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
9678         CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
9679         IDHW(NHEP)=IDHW(IHEP)
9680         IDHEP(NHEP)=IDHEP(IHEP)
9681         ISTHEP(NHEP)=190
9682         JMOHEP(1,NHEP)=IHEP
9683         JMOHEP(2,NHEP)=NHEP
9684         JDAHEP(2,NHEP)=NHEP
9685         JDAHEP(1,IHEP)=NHEP
9686         JDAHEP(2,IHEP)=NHEP
9687       ELSEIF (ISTHEP(IHEP).GE.190.AND.ISTHEP(IHEP).LE.193) THEN
9688 C---FIRST CHECK FOR STABILITY
9689         ID=IDHW(IHEP)
9690         IF (RSTAB(ID)) THEN
9691           ISTHEP(IHEP)=1
9692           JDAHEP(1,IHEP)=0
9693           JDAHEP(2,IHEP)=0
9694 C---SPECIAL FOR GAUGE BOSON DECAY
9695           IF (ID.GE.198.AND.ID.LE.200) CALL HWDBOS(IHEP)
9696 C---SPECIAL FOR HIGGS BOSON DECAY
9697           IF (ID.EQ.201) CALL HWDHIG(ZERO)
9698         ELSE
9699 C---UNSTABLE.
9700 C Calculate position of decay vertex
9701           IF (DKLTM(ID).EQ.ZERO) THEN
9702             CALL HWVEQU(4,VHEP(1,IHEP),VERTX)
9703             MHEP=IHEP
9704             IDM=ID
9705           ELSE
9706             CALL HWUDKL(ID,PHEP(1,IHEP),DIST)
9707             CALL HWVSUM(4,VHEP(1,IHEP),DIST,VERTX)
9708             IF (MAXDKL) THEN
9709               CALL HWDXLM(VERTX,STABLE)
9710               IF (STABLE) THEN
9711                 ISTHEP(IHEP)=1
9712                 JDAHEP(1,IHEP)=0
9713                 JDAHEP(2,IHEP)=0
9714                 GOTO 100
9715               ENDIF
9716             ENDIF
9717             IF (MIXING.AND.(ID.EQ.221.OR.ID.EQ.223.OR.
9718      &                      ID.EQ.245.OR.ID.EQ.247)) THEN
9719 C Select flavour of decaying b-meson allowing for flavour oscillation
9720               IDS=MOD(ID,3)
9721               XXX=XMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
9722               YYY=YMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
9723               IF (ABS(YYY).LT.10) THEN
9724                 PMIX=HALF*(ONE-COS(XXX)/COSH(YYY))
9725               ELSE
9726                 PMIX=HALF
9727               ENDIF
9728               IF (HWRGEN(1).LE.PMIX) THEN
9729                 IF (ID.LE.223) THEN
9730                   IDM=ID+24
9731                 ELSE
9732                   IDM=ID-24
9733                 ENDIF
9734               ELSE
9735                 IDM=ID
9736               ENDIF
9737 C Introduce a decaying neutral b-meson
9738               IF (NHEP+1.GT.NMXHEP) THEN
9739                 CALL HWWARN('HWDHAD',101)
9740                 GOTO 999
9741               ENDIF
9742               MHEP=NHEP+1
9743               ISTHEP(MHEP)=ISTHEP(IHEP)
9744               ISTHEP(IHEP)=200
9745               JDAHEP(1,IHEP)=MHEP
9746               JDAHEP(2,IHEP)=MHEP
9747               IDHW(MHEP)=IDM
9748               IDHEP(MHEP)=IDPDG(IDM)
9749               JMOHEP(1,MHEP)=IHEP
9750               JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
9751               CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
9752               CALL HWVEQU(4,VERTX,VHEP(1,MHEP))
9753               NHEP=NHEP+1
9754             ELSE
9755               MHEP=IHEP
9756               IDM=ID
9757             ENDIF
9758           ENDIF
9759 C Use CLEO/EURODEC packages for b-hadrons if requested
9760           IF ((IDM.GE.221.AND.IDM.LE.231).OR.
9761      &        (IDM.GE.245.AND.IDM.LE.254)) THEN
9762             IF (BDECAY.EQ.'CLEO') THEN
9763               CALL HWDCLE(MHEP)
9764               GOTO 100
9765             ELSEIF (BDECAY.EQ.'EURO') THEN
9766               CALL HWDEUR(MHEP)
9767               GOTO 100
9768             ENDIF
9769           ENDIF
9770 C Use TAUOLA package for tau decays if requested
9771           IF((IDM.EQ.125.OR.IDM.EQ.131).AND.TAUDEC.EQ.'TAUOLA') THEN
9772             CALL HWDTAU(1,MHEP,0.0D0)
9773             GOTO 100
9774           ENDIF
9775 C Choose decay mode
9776           ISTHEP(MHEP)=ISTHEP(MHEP)+5
9777           RN=HWRGEN(2)
9778           BF=0.
9779           IM=LSTRT(IDM)
9780           DO 10 I=1,NMODES(IDM)
9781           BF=BF+BRFRAC(IM)
9782           IF (BF.GE.RN) GOTO 20
9783   10      IM=LNEXT(IM)
9784           CALL HWWARN('HWDHAD',50)
9785           GOTO 20
9786   20      IF ((IDKPRD(1,IM).GE.1.AND.IDKPRD(1,IM).LE.13).OR.
9787      &        (IDKPRD(3,IM).GE.1.AND.IDKPRD(3,IM).LE.13)) THEN
9788 C Partonic decay of a heavy-(b,c)-hadron, store details
9789             NQDK=NQDK+1
9790             IF (NQDK.GT.NMXQDK) THEN
9791               CALL HWWARN('HWDHAD',102)
9792               GOTO 999
9793             ENDIF
9794             LOCQ(NQDK)=MHEP
9795             IMQDK(NQDK)=IM
9796             CALL HWVEQU(4,VERTX,VTXQDK(1,NQDK))
9797             GOTO 100
9798           ELSE
9799 C Exclusive decay, add decay products to event record
9800             IF (NHEP+NPRODS(IM).GT.NMXHEP) THEN
9801               CALL HWWARN('HWDHAD',103)
9802               GOTO 999
9803             ENDIF
9804             JDAHEP(1,MHEP)=NHEP+1
9805             DO 30 I=1,NPRODS(IM)
9806             NHEP=NHEP+1
9807             IDHW(NHEP)=IDKPRD(I,IM)
9808             IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
9809             ISTHEP(NHEP)=193
9810             JMOHEP(1,NHEP)=MHEP
9811             JMOHEP(2,NHEP)=JMOHEP(2,MHEP)
9812             PHEP(5,NHEP)=RMASS(IDKPRD(I,IM))
9813   30        CALL HWVEQU(4,VERTX,VHEP(1,NHEP))
9814             JDAHEP(2,MHEP)=NHEP
9815           ENDIF
9816 C Next choose momenta:
9817           IF (NPRODS(IM).EQ.1) THEN
9818 C 1-body decay: K0(BR) --> K0S,K0L
9819             CALL HWVEQU(4,PHEP(1,MHEP),PHEP(1,NHEP))
9820           ELSEIF (NPRODS(IM).EQ.2) THEN
9821 C 2-body decay
9822 C---SPECIAL TREATMENT OF POLARIZED MESONS
9823             COSANG=TWO
9824             IF (ID.EQ.IDHW(JMOHEP(1,MHEP))) THEN
9825               MO=JMOHEP(1,MHEP)
9826               RSUM=0
9827               DO 40 I=1,3
9828   40          RSUM=RSUM+RHOHEP(I,MO)
9829               IF (RSUM.GT.ZERO) THEN
9830                 RSUM=RSUM*HWRGEN(3)
9831                 IF (RSUM.LT.RHOHEP(1,MO)) THEN
9832 C---(1+COSANG)**2
9833                   COSANG=MAX(HWRGEN(4),HWRGEN(5),HWRGEN(6))*TWO-ONE
9834                 ELSEIF (RSUM.LT.RHOHEP(1,MO)+RHOHEP(2,MO)) THEN
9835 C---1-COSANG**2
9836                   COSANG=2*COS((ACOS(HWRGEN(7)*TWO-ONE)+PIFAC)/THREE)
9837                 ELSE
9838 C---(1-COSANG)**2
9839                   COSANG=MIN(HWRGEN(8),HWRGEN(9),HWRGEN(10))*TWO-ONE
9840                 ENDIF
9841               ENDIF
9842             ENDIF
9843             CALL HWDTWO(PHEP(1,MHEP),PHEP(1,NHEP-1),
9844      &                  PHEP(1,NHEP),CMMOM(IM),COSANG,.FALSE.)
9845           ELSEIF (NPRODS(IM).EQ.3) THEN
9846 C 3-body decay
9847             IF (NME(IM).EQ.100) THEN
9848 C  Use free massless (V-A)*(V-A) Matrix Element
9849               CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
9850      &                    PHEP(1,NHEP),HWDWWT)
9851             ELSEIF (NME(IM).EQ.101) THEN
9852 C  Use bound massless (V-A)*(V-A) Matrix Element
9853               WTMX=((PHEP(5,MHEP)-PHEP(5,NHEP))
9854      &             *(PHEP(5,MHEP)+PHEP(5,NHEP))
9855      &             +(PHEP(5,NHEP-1)-PHEP(5,NHEP-2))
9856      &             *(PHEP(5,NHEP-1)+PHEP(5,NHEP-2)))/TWO
9857               WTMX2=WTMX**2
9858               IPDG=ABS(IDHEP(MHEP))
9859               XS=ONE-MAX(RMASS(MOD(IPDG/1000,10)),
9860      &                   RMASS(MOD(IPDG/100,10)),RMASS(MOD(IPDG/10,10)))
9861      &              /(RMASS(MOD(IPDG/1000,10))+RMASS(MOD(IPDG/100,10))
9862      &               +RMASS(MOD(IPDG/10,10)))
9863   50          CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
9864      &                    PHEP(1,NHEP),HWDWWT)
9865               DOT1=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-1))
9866               DOT2=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-2))
9867               IF (DOT1*(WTMX-DOT1-XS*DOT2).LT.HWRGEN(11)*WTMX2) GOTO 50
9868             ELSE IF (NME(IM).EQ.200) THEN
9869 C Use free massless ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) Matrix Element
9870 C sort tan(beta)
9871               IF((IDK(IM).EQ.  2).OR.(IDK(IM).EQ.  4).OR.
9872      &           (IDK(IM).EQ.  6).OR.(IDK(IM).EQ.  8).OR.
9873      &           (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
9874      &           (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
9875      &           (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
9876      &           (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
9877                 TB=TANB
9878               ELSE
9879                 TB=1./TANB
9880               END IF
9881               IF((IDKPRD(1,IM).EQ.  2).OR.(IDKPRD(1,IM).EQ.  4).OR.
9882      &           (IDKPRD(1,IM).EQ.  6).OR.(IDKPRD(1,IM).EQ.  8).OR.
9883      &           (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
9884      &           (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
9885      &           (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
9886      &           (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
9887                 BT=TANB
9888               ELSE
9889                 BT=1./TANB
9890               END IF
9891               IT1=IDK(IM)
9892               IB1=IDKPRD(3,IM)
9893               IT2=IDKPRD(1,IM)
9894               IB2=IDKPRD(2,IM)
9895               CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP),PHEP(1,NHEP-2),
9896      &                    PHEP(1,NHEP-1),HWDHWT)
9897             ELSE
9898               CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-2),PHEP(1,NHEP-1),
9899      &                    PHEP(1,NHEP),HWDPWT)
9900             ENDIF
9901           ELSEIF (NPRODS(IM).EQ.4) THEN
9902 C 4-body decay
9903             CALL HWDFOR(PHEP(1,MHEP  ),PHEP(1,NHEP-3),PHEP(1,NHEP-2),
9904      &                  PHEP(1,NHEP-1),PHEP(1,NHEP))
9905             IF(IERROR.NE.0) RETURN
9906           ELSEIF (NPRODS(IM).EQ.5) THEN
9907 C 5-body decay
9908             CALL HWDFIV(PHEP(1,MHEP  ),PHEP(1,NHEP-4),PHEP(1,NHEP-3),
9909      &                  PHEP(1,NHEP-2),PHEP(1,NHEP-1),PHEP(1,NHEP))
9910             IF(IERROR.NE.0) RETURN
9911           ELSE
9912             CALL HWWARN('HWDHAD',104)
9913             GOTO 999
9914           ENDIF
9915         ENDIF
9916       ENDIF
9917   100 CONTINUE
9918 C---MAY HAVE OVERFLOWED /HEPEVT/
9919       CALL HWWARN('HWDHAD',105)
9920  999  RETURN
9921       END
9922 CDECK  ID>, HWDHGC.
9923 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
9924 *-- Author :    Mike Seymour
9925 C-----------------------------------------------------------------------
9926       SUBROUTINE HWDHGC(TAU,FNREAL,FNIMAG)
9927 C-----------------------------------------------------------------------
9928 C  CALCULATE THE COMPLEX FUNCTION F OF HHG eq 2.18
9929 C  FOR USE IN H-->GAMMGAMM DECAYS
9930 C-----------------------------------------------------------------------
9931       INCLUDE 'herwig65.inc'
9932       DOUBLE PRECISION TAU,FNREAL,FNIMAG,FNLOG,FNSQR
9933       IF (TAU.GT.ONE) THEN
9934         FNREAL=(ASIN(1/SQRT(TAU)))**2
9935         FNIMAG=0
9936       ELSEIF (TAU.LT.ONE) THEN
9937         FNSQR=SQRT(1-TAU)
9938         FNLOG=LOG((1+FNSQR)/(1-FNSQR))
9939         FNREAL=-0.25 * (FNLOG**2 - PIFAC**2)
9940         FNIMAG= 0.5  * PIFAC*FNLOG
9941       ELSE
9942         FNREAL=0.25*PIFAC**2
9943         FNIMAG=0
9944       ENDIF
9945       END
9946 CDECK  ID>, HWDHGF.
9947 *CMZ :-        -02/05/91  11.11.45  by  Federico Carminati
9948 *-- Author :    Mike Seymour
9949 C-----------------------------------------------------------------------
9950       FUNCTION HWDHGF(X,Y)
9951 C-----------------------------------------------------------------------
9952 C  CALCULATE THE DOUBLE BREIT-WIGNER INTEGRAL
9953 C  X=(EMV/EMH)**2 , Y=EMV*GAMV/EMH**2
9954 C-----------------------------------------------------------------------
9955       INCLUDE 'herwig65.inc'
9956       DOUBLE PRECISION HWDHGF,X,Y,CHANGE,X1,X2,FAC1,FAC2,TH1,TH2,TH1HI,
9957      & TH1LO,TH2HI,TH2LO,X2MAX,SQFAC
9958       INTEGER NBIN,IBIN1,IBIN2
9959 C  CHANGE IS THE POINT WHERE DIRECT INTEGRATION BEGINS TO CONVERGE
9960 C  FASTER THAN STANDARD BREIT-WIGNER SUBSTITUTION
9961       SAVE CHANGE,NBIN
9962       DATA CHANGE,NBIN/0.425D0,25/
9963       HWDHGF=0
9964       IF (Y.LT.ZERO) RETURN
9965       IF (X.GT.CHANGE) THEN
9966 C---DIRECT INTEGRATION
9967         FAC1=0.25 / NBIN
9968         DO 200 IBIN1=1,NBIN
9969           X1=(IBIN1-0.5) * FAC1
9970           FAC2=( (1-SQRT(X1))**2-X1 ) / NBIN
9971           DO 100 IBIN2=1,NBIN
9972             X2=(IBIN2-0.5) * FAC2 + X1
9973             SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
9974             IF (SQFAC.LT.ZERO) GOTO 100
9975             HWDHGF=HWDHGF + 2.
9976      &        * ((1-X1-X2)**2+8*X1*X2)
9977      &        * SQRT(SQFAC)
9978      &        / ((X1-X)**2+Y**2) *Y
9979      &        / ((X2-X)**2+Y**2) *Y
9980      &        * FAC1*FAC2
9981  100      CONTINUE
9982  200    CONTINUE
9983       ELSE
9984 C---INTEGRATION USING TAN THETA SUBSTITUTIONS
9985         TH1LO=ATAN((0-X)/Y)
9986         TH1HI=ATAN((1-X)/Y)
9987         FAC1=(TH1HI-TH1LO) / NBIN
9988         DO 400 IBIN1=1,NBIN
9989           TH1=(IBIN1-0.5) * FAC1 + TH1LO
9990           X1=Y*TAN(TH1) + X
9991           X2MAX=MIN(X1,(1-SQRT(X1))**2)
9992           TH2LO=ATAN((0-X)/Y)
9993           TH2HI=ATAN((X2MAX-X)/Y)
9994           FAC2=(TH2HI-TH2LO) / NBIN
9995           DO 300 IBIN2=1,NBIN
9996             TH2=(IBIN2-0.5) * FAC2 + TH2LO
9997             X2=Y*TAN(TH2) + X
9998             SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
9999             IF (SQFAC.LT.ZERO) GOTO 300
10000             HWDHGF=HWDHGF + 2.
10001      &        * ((1-X1-X2)**2+8*X1*X2)
10002      &        * SQRT(SQFAC)
10003      &        * FAC1 * FAC2
10004  300      CONTINUE
10005  400    CONTINUE
10006       ENDIF
10007       HWDHGF=HWDHGF/(PIFAC*PIFAC)
10008       END
10009 CDECK  ID>, HWDHIG.
10010 *CMZ :-        -24/04/92  14.23.44  by  Mike Seymour
10011 *-- Author :    Mike Seymour
10012 C-----------------------------------------------------------------------
10013       SUBROUTINE HWDHIG(GAMINP)
10014 C-----------------------------------------------------------------------
10015 C     HIGGS DECAY ROUTINE
10016 C     A) FOR GAMinp=0 FIND AND DECAY HIGGS
10017 C     B) FOR GAMinp>0 CALCULATE TOTAL HIGGS WIDTH
10018 C                     FOR EMH=GAMINP. STORE RESULT IN GAMINP.
10019 C-----------------------------------------------------------------------
10020       INCLUDE 'herwig65.inc'
10021       DOUBLE PRECISION HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,GAMINP,EMH,
10022      & EMF,COLFAC,ENF,K1,K0,BET0,BET1,GAM0,GAM1,SCLOG,CFAC,XF,EM,GAMLIM,
10023      & GAM,XW,EMW,XZ,EMZ,YW,YZ,EMI,TAUT,TAUW,WIDHIG,VECDEC,EMB,GAMB,
10024      & TMIN,TMAX1,EM1,TMAX2,EM2,X1,X2,PROB,PCM,SUMR,SUMI,TAUTR,TAUTI,
10025      & TAUWR,TAUWI,GFACTR
10026       INTEGER HWRINT,IHIG,I,IFERM,NLOOK,I1,I2,IPART,IMODE,IDEC,MMAX
10027       LOGICAL HWRLOG
10028       EXTERNAL HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,HWRINT,HWRLOG
10029       SAVE GAM,EM,VECDEC
10030       PARAMETER (NLOOK=100)
10031       DIMENSION VECDEC(2,0:NLOOK)
10032       EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
10033       SAVE GAMLIM
10034       DATA GAMLIM,GAM,EM/10D0,2*0D0/
10035 C---IF DECAY, FIND HIGGS (HWDHAD WILL HAVE GIVEN IT STATUS=1)
10036       IF (GAMINP.EQ.ZERO) THEN
10037         IHIG=0
10038         DO 10 I=1,NHEP
10039  10       IF (IHIG.EQ.0.AND.IDHW(I).EQ.201.AND.ISTHEP(I).EQ.1) IHIG=I
10040         IF (IHIG.EQ.0) THEN
10041           CALL HWWARN('HWDHIG',101)
10042           GOTO 999
10043         ENDIF
10044         EMH=PHEP(5,IHIG)
10045         IF (EMH.LE.ZERO) THEN
10046           CALL HWWARN('HWDHIG',102)
10047           GOTO 999
10048         ENDIF
10049         EMSCA=EMH
10050       ELSE
10051         EMH=GAMINP
10052         IF (EMH.LE.ZERO) THEN
10053           GAMINP=0
10054           RETURN
10055         ENDIF
10056       ENDIF
10057 C---CALCULATE BRANCHING FRACTIONS
10058 C---FERMIONS
10059 C---NLL CORRECTION TO QUARK DECAY RATE (HHG eq 2.6-9)
10060       ENF=0
10061       DO 1 I=1,6
10062  1      IF (2*RMASS(I).LT.EMH) ENF=ENF+1
10063       K1=5/PIFAC**2
10064       K0=3/(4*PIFAC**2)
10065       BET0=(11*CAFAC-2*ENF)/3
10066       BET1=(34*CAFAC**2-(10*CAFAC+6*CFFAC)*ENF)/3
10067       GAM0=-8
10068       GAM1=-404./3+40*ENF/9
10069       SCLOG=LOG(EMH**2/QCDLAM**2)
10070       CFAC=1 + ( K1/K0 - 2*GAM0 + GAM0*BET1/BET0**2*LOG(SCLOG)
10071      &       +   (GAM0*BET1-GAM1*BET0)/BET0**2) / (BET0*SCLOG)
10072       DO 100 IFERM=1,9
10073         IF (IFERM.LE.6) THEN
10074           EMF=RMASS(IFERM)
10075           XF=(EMF/EMH)**2
10076           COLFAC=FLOAT(NCOLO)
10077           IF (EMF.GT.QCDLAM)
10078      &      EMF=EMF*(LOG(EMH/QCDLAM)/LOG(EMF/QCDLAM))**(GAM0/(2*BET0))
10079         ELSE
10080           EMF=RMASS(107+IFERM*2)
10081           XF=(EMF/EMH)**2
10082           COLFAC=1
10083           CFAC=1
10084         ENDIF
10085         IF (FOUR*XF.LT.ONE) THEN
10086         GFACTR=ALPHEM/(8.*SWEIN*EMW**2)
10087           BRHIG(IFERM)=COLFAC*GFACTR*EMH*EMF**2 * (1-4*XF)**1.5 * CFAC
10088         ELSE
10089           BRHIG(IFERM)=0
10090         ENDIF
10091  100  CONTINUE
10092 C---W*W*/Z*Z*
10093       IF (ABS(EM-EMH).GE.GAMLIM*GAM) THEN
10094 C---OFF EDGE OF LOOK-UP TABLE
10095         XW=(EMW/EMH)**2
10096         XZ=(EMZ/EMH)**2
10097         YW=EMW*GAMW/EMH**2
10098         YZ=EMZ*GAMZ/EMH**2
10099         BRHIG(10)=.50*GFACTR * EMH**3 * HWDHGF(XW,YW)
10100         BRHIG(11)=.25*GFACTR * EMH**3 * HWDHGF(XZ,YZ)
10101       ELSE
10102 C---LOOK IT UP
10103         EMI=((EMH-EM)/(GAM*GAMLIM)+1)*NLOOK/2.0
10104         I1=INT(EMI)
10105         I2=INT(EMI+1)
10106         BRHIG(10)=.50*GFACTR * EMH**3 * ( VECDEC(1,I1)*(I2-EMI) +
10107      &                                    VECDEC(1,I2)*(EMI-I1) )
10108         BRHIG(11)=.25*GFACTR * EMH**3 * ( VECDEC(2,I1)*(I2-EMI) +
10109      &                                    VECDEC(2,I2)*(EMI-I1) )
10110       ENDIF
10111 C---GAMMAGAMMA
10112       TAUT=(2*RMASS(6)/EMH)**2
10113       TAUW=(2*EMW/EMH)**2
10114       CALL HWDHGC(TAUT,TAUTR,TAUTI)
10115       CALL HWDHGC(TAUW,TAUWR,TAUWI)
10116       SUMR=4./3*(  - 2*TAUT*( 1 + (1-TAUT)*TAUTR ) ) * ENHANC(6)
10117      &         +(2 + 3*TAUW*( 1 + (2-TAUW)*TAUWR ) ) * ENHANC(10)
10118       SUMI=4./3*(  - 2*TAUT*(     (1-TAUT)*TAUTI ) ) * ENHANC(6)
10119      &         +(    3*TAUW*(     (2-TAUW)*TAUWI ) ) * ENHANC(10)
10120       BRHIG(12)=GFACTR*.03125*(ALPHEM/PIFAC)**2
10121      &         *EMH**3 * (SUMR**2 + SUMI**2)
10122       WIDHIG=0
10123       DO 200 IPART=1, 12
10124         IF (IPART.LT.12) BRHIG(IPART)=BRHIG(IPART)*ENHANC(IPART)**2
10125  200    WIDHIG=WIDHIG+BRHIG(IPART)
10126       IF (WIDHIG.EQ.ZERO) THEN
10127         CALL HWWARN('HWDHIG',103)
10128         GOTO 999
10129       ENDIF
10130       DO 300 IPART=1, 12
10131  300    BRHIG(IPART)=BRHIG(IPART)/WIDHIG
10132       IF (EM.NE.RMASS(201)) THEN
10133 C---SET UP W*W*/Z*Z* LOOKUP TABLES
10134         EM=EMH
10135         GAM=WIDHIG
10136         GAMLIM=MAX(GAMLIM,GAMMAX)
10137         DO 400 I=0,NLOOK
10138           EMH=(I*2.0/NLOOK-1)*GAM*GAMLIM+EM
10139           XW=(EMW/EMH)**2
10140           XZ=(EMZ/EMH)**2
10141           YW=EMW*GAMW/EMH**2
10142           YZ=EMZ*GAMZ/EMH**2
10143           VECDEC(1,I)=HWDHGF(XW,YW)
10144           VECDEC(2,I)=HWDHGF(XZ,YZ)
10145  400    CONTINUE
10146         EMH=EM
10147       ENDIF
10148       IF (GAMINP.GT.ZERO) THEN
10149         GAMINP=WIDHIG
10150         RETURN
10151       ENDIF
10152 C---SEE IF USER SPECIFIED A DECAY MODE
10153       IMODE=MOD(ABS(IPROC),100)
10154 C---IF NOT, CHOOSE ONE
10155       IF (IMODE.LT.1.OR.IMODE.GT.12) THEN
10156         MMAX=12
10157         IF (IMODE.LT.1) MMAX=6
10158  500    IMODE=HWRINT(1,MMAX)
10159         IF (BRHIG(IMODE).LT.HWRGEN(0)) GOTO 500
10160       ENDIF
10161 C---SEE IF SPECIFIED DECAY IS POSSIBLE
10162       IF (BRHIG(IMODE).EQ.ZERO) THEN
10163         CALL HWWARN('HWDHIG',104)
10164         GOTO 999
10165       ENDIF
10166       IF (IMODE.LE.6) THEN
10167         IDEC=IMODE
10168       ELSEIF (IMODE.LE.9) THEN
10169         IDEC=107+IMODE*2
10170       ELSEIF (IMODE.EQ.10) THEN
10171         IDEC=198
10172       ELSEIF (IMODE.EQ.11) THEN
10173         IDEC=200
10174       ELSEIF (IMODE.EQ.12) THEN
10175         IDEC=59
10176       ENDIF
10177 C---STATUS, IDs AND POINTERS
10178       ISTHEP(IHIG)=195
10179       DO 600 I=1,2
10180         ISTHEP(NHEP+I)=193
10181         IDHW(NHEP+I)=IDEC
10182         IDHEP(NHEP+I)=IDPDG(IDEC)
10183         JDAHEP(I,IHIG)=NHEP+I
10184         JMOHEP(1,NHEP+I)=IHIG
10185         JMOHEP(2,NHEP+I)=NHEP+(3-I)
10186         JDAHEP(2,NHEP+I)=NHEP+(3-I)
10187         PHEP(5,NHEP+I)=RMASS(IDEC)
10188         IDEC=IDEC+6
10189         IF (IDEC.EQ.204) IDEC=199
10190         IF (IDEC.EQ.206) IDEC=200
10191         IF (IDEC.EQ. 65) IDEC= 59
10192  600  CONTINUE
10193 C---ALLOW W/Z TO BE OFF-SHELL
10194       IF (IMODE.EQ.10.OR.IMODE.EQ.11) THEN
10195         IF (IMODE.EQ.10) THEN
10196           EMB=EMW
10197           GAMB=GAMW
10198         ELSE
10199           EMB=EMZ
10200           GAMB=GAMZ
10201         ENDIF
10202 C---STANDARD MASS DISTRIBUTION
10203  700    TMIN=ATAN(-EMB/GAMB)
10204         TMAX1=ATAN((EMH**2/EMB-EMB)/GAMB)
10205         EM1=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX1))+EMB))
10206         TMAX2=ATAN(((EMH-EM1)**2/EMB-EMB)/GAMB)
10207         EM2=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX2))+EMB))
10208         X1=(EM1/EMH)**2
10209         X2=(EM2/EMH)**2
10210 C---CORRECT MASS DISTRIBUTION
10211         PROB=HWUSQR(1+X1**2+X2**2-2*X1-2*X2-2*X1*X2)
10212      &        * ((X1+X2-1)**2 + 8*X1*X2)
10213         IF (.NOT.HWRLOG(PROB)) GOTO 700
10214 C---CALCULATE SPIN DENSITY MATRIX
10215         RHOHEP(1,NHEP+1)=4*X1*X2      / (8*X1*X2 + (X1+X2-1)**2)
10216         RHOHEP(2,NHEP+1)=(X1+X2-1)**2 / (8*X1*X2 + (X1+X2-1)**2)
10217         RHOHEP(3,NHEP+1)=RHOHEP(1,NHEP+1)
10218 C---SYMMETRIZE DISTRIBUTIONS IN PARTICLES 1,2
10219         IF (HWRLOG(HALF)) THEN
10220           PHEP(5,NHEP+1)=EM1
10221           PHEP(5,NHEP+2)=EM2
10222         ELSE
10223           PHEP(5,NHEP+1)=EM2
10224           PHEP(5,NHEP+2)=EM1
10225         ENDIF
10226       ENDIF
10227 C---DO DECAY
10228       PCM=HWUPCM(EMH,PHEP(5,NHEP+1),PHEP(5,NHEP+2))
10229       IF (PCM.LT.ZERO) THEN
10230         CALL HWWARN('HWDHIG',105)
10231         GOTO 999
10232       ENDIF
10233       CALL HWDTWO(PHEP(1,IHIG),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
10234      &            PCM,TWO,.TRUE.)
10235       NHEP=NHEP+2
10236 C---IF QUARK DECAY, HADRONIZE
10237       IF (IMODE.LE.6) THEN
10238         ISTHEP(NHEP-1)=113
10239         ISTHEP(NHEP)=114
10240         CALL HWBGEN
10241         CALL HWDHOB
10242         CALL HWCFOR
10243         CALL HWCDEC
10244 C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS OR PHOTONS
10245       ELSEIF (IMODE.LE.9.OR.IMODE.EQ.12) THEN
10246         CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
10247         CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
10248 C--END FIX
10249       ENDIF
10250  999  RETURN
10251       END
10252 CDECK  ID>, HWDHOB.
10253 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
10254 *-- Author :    Ian Knowles & Bryan Webber
10255 C-----------------------------------------------------------------------
10256       SUBROUTINE HWDHOB
10257 C-----------------------------------------------------------------------
10258 C   Performs decays of heavy objects (heavy quarks & SUSY particles)
10259 C   MODIFIED TO INCLUDE R-PARITY VIOLATING SUSY PR 9/4/99
10260 C   MODIFIED TO CALL A NUMBER OF ROUTINES TO DO THE VARIOUS BITS OF
10261 C   THE PROCESS
10262 C-----------------------------------------------------------------------
10263       INCLUDE 'herwig65.inc'
10264       DOUBLE PRECISION PW(5)
10265       INTEGER IHEP,IS,ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2),NHEPST
10266       LOGICAL FOUND
10267       SAVE NHEPST
10268       IF (IERROR.NE.0) RETURN
10269   10  FOUND=.FALSE.
10270       NHEPST = NHEP
10271       CLSAVE(1) = 0
10272       CLSAVE(2) = 0
10273       DO 60 IHEP=1,NMXHEP
10274       IS=ISTHEP(IHEP)
10275       ID=IDHW(IHEP)
10276       IF(SYSPIN.AND.NSPN.NE.0) CALL HWDSIN(CLSAVE)
10277       IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
10278      & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
10279      & ((IS.EQ.120.AND.JDAHEP(1,IHEP).EQ.IHEP).OR.
10280      & IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
10281         FOUND=.TRUE.
10282 C--select the decay mode and enter the decay products in the event record
10283         CALL  HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
10284         IF (IERROR.NE.0) RETURN
10285 C--select the momenta of the decay products
10286         CALL HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
10287         IF (IERROR.NE.0) RETURN
10288 C--make the colour connections
10289         CALL HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
10290         IF (IERROR.NE.0) RETURN
10291 C--perform the parton-showers
10292         CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
10293         IF (IERROR.NE.0) RETURN
10294       ENDIF
10295 C--perform the colour corrections for RPV
10296       CALL HWDHO5(MHEP,LHEP,CLSAVE)
10297       IF(IERROR.NE.0) RETURN
10298       IF (IHEP.EQ.NHEP) GOTO 70
10299   60  CONTINUE
10300   70  IF(SYSPIN.AND.NHEP.NE.NHEPST) FOUND=.TRUE.
10301       IF (FOUND) THEN
10302 C--final check for colour disconnection
10303         CALL HWDHO6
10304 C Go back to check for further heavy decay products
10305         GOTO 10
10306       ENDIF
10307       END
10308 CDECK  ID>, HWDHO1.
10309 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
10310 *-- Author :    Ian Knowles & Bryan Webber
10311 C-----------------------------------------------------------------------
10312       SUBROUTINE HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
10313 C-----------------------------------------------------------------------
10314 C   Subroutine to perform the first part of the heavy object decays
10315 C   IE to select the decay mode
10316 C   was part of HWDHOB
10317 C-----------------------------------------------------------------------
10318       INCLUDE 'herwig65.inc'
10319       DOUBLE PRECISION HWUMBW,HWRGEN,SDKM,RN,BF
10320       INTEGER IST(3),IHEP,ID,IM,I,JHEP,LHEP,MHEP,NPR,MTRY,NTRY,IS
10321       EXTERNAL HWRGEN
10322       SAVE IST
10323       DATA IST/113,114,114/
10324       IF (IERROR.NE.0) RETURN
10325       IF(.NOT.RPARTY) THEN
10326         NHEP = NHEP+1
10327         ISTHEP(NHEP) = 3
10328         IDHW(NHEP) = 20
10329         IDHEP(NHEP) = 0
10330         CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
10331         CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
10332         JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
10333         JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
10334         JDAHEP(1,NHEP)=JDAHEP(1,IHEP)
10335         JDAHEP(2,NHEP)=JDAHEP(2,IHEP)
10336       ENDIF
10337 C Make a copy of decaying object
10338       NHEP=NHEP+1
10339       ISTHEP(NHEP)=155
10340       IDHW(NHEP)=IDHW(IHEP)
10341       IDHEP(NHEP)=IDHEP(IHEP)
10342       CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
10343       CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
10344       JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
10345       JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
10346 C--copy the location of the particle in the spin block
10347       IF(SYSPIN.AND.NSPN.NE.0) THEN
10348          IF(ISNHEP(IHEP).EQ.0) THEN
10349            IS = IHEP
10350            MTRY = 0
10351  5         MTRY = MTRY+1
10352            IS = JMOHEP(1,IS)
10353            IF(ISNHEP(IS).EQ.0.AND.MTRY.LE.NETRY) GOTO 5
10354            IF(MTRY.GT.NETRY) THEN
10355              CALL HWWARN('HWDHO1',102)
10356              GOTO 999
10357            ENDIF
10358            ISNHEP(IHEP) = ISNHEP(IS)
10359          ENDIF
10360          ISNHEP(NHEP) = ISNHEP(JMOHEP(1,NHEP))
10361       ENDIF
10362       MTRY=0
10363  15   MTRY=MTRY+1
10364 C Select decay mode
10365       RN=HWRGEN(0)
10366       BF=0.
10367       IM=LSTRT(ID)
10368       DO 20 I=1,NMODES(ID)
10369       BF=BF+BRFRAC(IM)
10370       IF (BF.GE.RN) GOTO 30
10371   20  IM=LNEXT(IM)
10372       CALL HWWARN('HWDHO1',50)
10373   30  IF (NHEP+5.GT.NMXHEP) THEN
10374         CALL HWWARN('HWDHO1',100)
10375         GOTO 999
10376       ENDIF
10377       NPR=NPRODS(IM)
10378       JDAHEP(1,NHEP)=NHEP+1
10379       JDAHEP(2,NHEP)=NHEP+NPR
10380 C Reset colour pointers (if set)
10381       JHEP=JMOHEP(2,IHEP)
10382       IF (JHEP.GT.0) THEN
10383         IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
10384         IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
10385      &    .AND.ABS(IDHEP(JHEP)).GT.1000000
10386      &    .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
10387       ENDIF
10388       JHEP=JDAHEP(2,IHEP)
10389       IF (JHEP.GT.0) THEN
10390         IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
10391         IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
10392      &    .AND.ABS(IDHEP(JHEP)).GT.1000000
10393      &    .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
10394       ENDIF
10395 C--Reset colour pointers if baryon number violated
10396       IF(.NOT.RPARTY) THEN
10397         DO JHEP=1,NHEP
10398           IF(ISTHEP(JHEP).EQ.155
10399      &       .AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
10400      &       JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1)= NHEP
10401           IF(JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
10402           IF(JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
10403         ENDDO
10404         IF(HRDCOL(1,1).EQ.IHEP) HRDCOL(1,1)=NHEP
10405       ENDIF
10406 C Relabel original track
10407       IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3
10408       JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
10409       JDAHEP(1,IHEP)=NHEP
10410       JDAHEP(2,IHEP)=NHEP
10411 C Label decay products and choose masses
10412       LHEP=NHEP
10413       MHEP=LHEP+1
10414       NTRY=0
10415  35   NTRY=NTRY+1
10416       SDKM=PHEP(5,NHEP)
10417       DO 40 I=1,NPR
10418       NHEP=NHEP+1
10419       IDHW(NHEP)=IDKPRD(I,IM)
10420       IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
10421       ISTHEP(NHEP)=IST(I)
10422       JMOHEP(1,NHEP)=LHEP
10423       JDAHEP(1,NHEP)=0
10424       PHEP(5,NHEP)=HWUMBW(IDKPRD(I,IM))
10425  40   SDKM=SDKM-PHEP(5,NHEP)
10426       IF (SDKM.LT.ZERO) THEN
10427         NHEP=NHEP-NPR
10428         IF (NTRY.LE.NETRY) GO TO 35
10429         CALL HWWARN('HWDHO1',1)
10430         IF (MTRY.LE.NETRY) GO TO 15
10431         CALL HWWARN('HWDHO1',101)
10432         GOTO 999
10433       ENDIF
10434 C Assign production vertices to decay products
10435       CALL HWUDKL(ID,PHEP(1,IHEP),VHEP(1,MHEP))
10436       CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,MHEP),VHEP(1,MHEP))
10437       CALL HWVEQU(4,VHEP(1,MHEP),VHEP(1,NHEP))
10438  999  RETURN
10439       END
10440 CDECK  ID>, HWDH02.
10441 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
10442 *-- Author :    Ian Knowles & Bryan Webber
10443 C-----------------------------------------------------------------------
10444       SUBROUTINE HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
10445 C-----------------------------------------------------------------------
10446 C   Subroutine to perform the second part of the heavy object decays
10447 C   IE generate the kinematics for the decay
10448 C   was part of HWDHOB
10449 C-----------------------------------------------------------------------
10450       INCLUDE 'herwig65.inc'
10451       COMMON/FFS/TB,BT
10452       COMMON/SFF/IT1,IB1,IT2,IB2
10453       DOUBLE PRECISION TB,BT
10454       INTEGER IT1,IB1,IT2,IB2,ISP
10455       DOUBLE PRECISION GAMHPM
10456       DOUBLE PRECISION HWUPCM,HWRGEN,PCM,
10457      & EMMX,EMWSQ,GMWSQ,EMLIM,PW(5),EMTST,HWDPWT,HWDWWT,HWULDO,HWDHWT
10458       DOUBLE COMPLEX RHOIN(2,2,2)
10459       INTEGER IHEP,IM,KHEP,LHEP,MHEP,NPR,RHEP
10460       EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT
10461       SAVE RHOIN
10462       DATA RHOIN/(1.0D0,0.0D0),(0.0D0,0.0D0),
10463      &           (0.0D0,0.0D0),(0.0D0,0.0D0),
10464      &           (0.5D0,0.0D0),(0.0D0,0.0D0),
10465      &           (0.0D0,0.0D0),(0.5D0,0.0D0)/
10466       ISP = INT(2*RSPIN(IDHW(IHEP)))+1
10467       IF (IERROR.NE.0) RETURN
10468       IF (NPR.EQ.2) THEN
10469 C Two body decay: LHEP -> MHEP + NHEP
10470         IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
10471 C--generate a two body decay to a gauge boson as a three body decay
10472           CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,RHOIN(1,1,ISP),1)
10473 C--generate a two body decay of a Higgs to two gauge bosons
10474         ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
10475           CALL HWDSM4(1,IHEP,MHEP,NHEP,NME(IM)-40000)
10476 C--if spin correlations call the routine to set-up the matrix element
10477         ELSEIF(SYSPIN.AND.NME(IM).GE.30000.AND.NME(IM).LE.40000) THEN
10478           CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,RHOIN(1,1,ISP),1)
10479         ELSE
10480           PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
10481           CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
10482      &                PHEP(1,NHEP),PCM,TWO,.FALSE.)
10483         ENDIF
10484       ELSEIF (NPR.EQ.3) THEN
10485 C Three body decay: LHEP -> KHEP + MHEP + NHEP
10486         KHEP=MHEP
10487         MHEP=MHEP+1
10488 C Provisional colour self-connection of KHEP
10489         JMOHEP(2,KHEP)=KHEP
10490         JDAHEP(2,KHEP)=KHEP
10491         IF (NME(IM).EQ.100) THEN
10492 C Generate decay momenta using full (V-A)*(V-A) matrix element
10493           EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
10494           EMWSQ=RMASS(198)**2
10495           GMWSQ=(RMASS(198)*GAMW)**2
10496           EMLIM=GMWSQ
10497           IF (EMMX.LT.RMASS(198)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
10498   50      CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
10499      &                PHEP(1,KHEP),PHEP(1,NHEP),HWDWWT)
10500           CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10501           PW(5)=HWULDO(PW,PW)
10502           EMTST=(EMWSQ-PW(5))**2
10503           IF ((EMTST+GMWSQ)*HWRGEN(1).GT.EMLIM) GOTO 50
10504           PW(5)=SQRT(PW(5))
10505 C Assign production vertices to 1 and 2
10506           CALL HWUDKL(198,PW,VHEP(1,KHEP))
10507           CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
10508         ELSE IF (NME(IM).EQ.200) THEN
10509 C Generate decay momenta using full
10510 C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
10511           GAMHPM=RMASS(206)/DKLTM(206)
10512 C sort tan(beta)
10513           IF((IDK(IM).EQ.  2).OR.(IDK(IM).EQ.  4).OR.
10514      &       (IDK(IM).EQ.  6).OR.(IDK(IM).EQ.  8).OR.
10515      &       (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
10516      &       (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
10517      &       (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
10518      &       (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
10519             TB=TANB
10520           ELSE
10521             TB=1./TANB
10522           END IF
10523           IF((IDKPRD(1,IM).EQ.  2).OR.(IDKPRD(1,IM).EQ.  4).OR.
10524      &       (IDKPRD(1,IM).EQ.  6).OR.(IDKPRD(1,IM).EQ.  8).OR.
10525      &       (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
10526      &       (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
10527      &       (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
10528      &       (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
10529             BT=TANB
10530           ELSE
10531             BT=1./TANB
10532           END IF
10533           IT1=IDK(IM)
10534           IB1=IDKPRD(3,IM)
10535           IT2=IDKPRD(1,IM)
10536           IB2=IDKPRD(2,IM)
10537           EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
10538           EMWSQ=RMASS(206)**2
10539           GMWSQ=(RMASS(206)*GAMHPM)**2
10540           EMLIM=GMWSQ
10541           IF (EMMX.LT.RMASS(206)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
10542   55      CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP),
10543      &                PHEP(1,KHEP),PHEP(1,MHEP),HWDHWT)
10544           CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10545           PW(5)=HWULDO(PW,PW)
10546           EMTST=(EMWSQ-PW(5))**2
10547           IF ((EMTST+GMWSQ)*HWRGEN(2).GT.EMLIM) GOTO 55
10548           PW(5)=SQRT(PW(5))
10549 C Assign production vertices to 1 and 2
10550           CALL HWUDKL(206,PW,VHEP(1,KHEP))
10551           CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
10552         ELSEIF(NME(IM).EQ.300) THEN
10553 C Generate momenta using 3-body RPV matrix element
10554           CALL HWDRME(LHEP,KHEP)
10555 C--Three body SUSY decay
10556         ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
10557           CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
10558      &                RHOIN(1,1,ISP),1)
10559 C--special for top decay
10560           IF(ABS(IDHEP(IHEP)).EQ.6) THEN
10561             CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10562             CALL HWUMAS(PW)
10563           ENDIF
10564         ELSE
10565 C Three body phase space decay
10566           CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
10567      &                PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
10568         ENDIF
10569         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
10570       ELSEIF(NPR.EQ.4) THEN
10571 C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
10572         KHEP = MHEP
10573         RHEP = MHEP+1
10574         MHEP = MHEP+2
10575         ISTHEP(NHEP) = 114
10576 C Provisional colour connections of KHEP and RHEP
10577         JMOHEP(2,KHEP)=RHEP
10578         JDAHEP(2,KHEP)=RHEP
10579         JMOHEP(2,RHEP)=KHEP
10580         JDAHEP(2,RHEP)=KHEP
10581 C Four body phase space decay
10582         CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
10583      &                PHEP(1,MHEP),PHEP(1,NHEP))
10584         IF(IERROR.NE.0) RETURN
10585         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
10586         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
10587       ELSE
10588         CALL HWWARN('HWDHO2',100)
10589       ENDIF
10590       END
10591 CDECK  ID>, HWDHO3.
10592 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
10593 *-- Author :    Ian Knowles & Bryan Webber
10594 C-----------------------------------------------------------------------
10595       SUBROUTINE HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
10596 C-----------------------------------------------------------------------
10597 C   Subroutine to perform the third part of the heavy object decays
10598 C   IE setup the colour connections
10599 C   was part of HWDHOB
10600 C-----------------------------------------------------------------------
10601       INCLUDE 'herwig65.inc'
10602       INTEGER ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2)
10603       IF (IERROR.NE.0) RETURN
10604 C Colour connections
10605       IF (ID.EQ.6.OR.ID.EQ.12.OR.(ID.GE.209.AND.ID.LE.212)
10606      &                       .OR.(ID.GE.215.AND.ID.LE.218)) THEN
10607         IF ((NPR.EQ.3.AND.NME(IM).EQ.100).OR.
10608      &      ((SYSPIN.OR.THREEB).AND.NPR.EQ.3.AND.
10609      &        NME(IM).GE.10000.AND.NME(IM).LE.20000)) THEN
10610 C usual heavy quark decay
10611           JMOHEP(2,KHEP)=MHEP
10612           JDAHEP(2,KHEP)=MHEP
10613           JMOHEP(2,MHEP)=KHEP
10614           JDAHEP(2,MHEP)=KHEP
10615           JMOHEP(2,NHEP)=LHEP
10616           JDAHEP(2,NHEP)=LHEP
10617         ELSEIF (ABS(IDHEP(MHEP)).EQ.37) THEN
10618 C heavy quark to charged Higgs 2->2
10619           JMOHEP(2,MHEP)=MHEP
10620           JDAHEP(2,MHEP)=MHEP
10621           JMOHEP(2,NHEP)=LHEP
10622           JDAHEP(2,NHEP)=LHEP
10623         ELSEIF (ABS(IDHEP(NHEP)).EQ.37) THEN
10624 C heavy quark to charged Higgs 2->2
10625           JMOHEP(2,MHEP)=LHEP
10626           JDAHEP(2,MHEP)=LHEP
10627           JMOHEP(2,NHEP)=NHEP
10628           JDAHEP(2,NHEP)=NHEP
10629         ELSE IF (NPR.EQ.3.AND.NME(IM).EQ.200) THEN
10630 C heavy quark to charged Higgs 2->3
10631           JMOHEP(2,KHEP)=MHEP
10632           JDAHEP(2,KHEP)=MHEP
10633           JMOHEP(2,MHEP)=KHEP
10634           JDAHEP(2,MHEP)=KHEP
10635           JMOHEP(2,NHEP)=LHEP
10636           JDAHEP(2,NHEP)=LHEP
10637         ELSE
10638           CALL HWWARN('HWDHO3',100)
10639           GOTO 999
10640         ENDIF
10641       ELSE
10642         IF(.NOT.RPARTY.AND.
10643      &     ((NPR.EQ.2.AND.ID.GE.401.AND.ID.LT.448.AND.
10644      &         IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132)
10645      &     .OR.(NPR.EQ.3.AND.ID.GE.449.AND.ID.LE.457.AND.
10646      &         IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132.AND.
10647      &         IDHW(MHEP-1).LE.132))) THEN
10648 C R-parity violating SUSY decays
10649           IF(NPR.EQ.2) THEN
10650 C--Rparity slepton colour connections
10651             IF(ID.GE.425.AND.ID.LE.448) THEN
10652               IF(IDHW(MHEP).GT.12) THEN
10653                 JMOHEP(2,MHEP) = MHEP
10654                 JDAHEP(2,MHEP) = MHEP
10655                 JMOHEP(2,NHEP) = NHEP
10656                 JDAHEP(2,NHEP) = NHEP
10657               ELSE
10658                 JMOHEP(2,MHEP) = NHEP
10659                 JDAHEP(2,MHEP) = NHEP
10660                 JMOHEP(2,NHEP) = MHEP
10661                 JDAHEP(2,NHEP) = MHEP
10662               ENDIF
10663 C--Rparity squark colour connections
10664             ELSE
10665               IF(IDHEP(LHEP).GT.0) THEN
10666 C--LQD decay colour connections
10667                 IF(IDHW(MHEP).GT.12) THEN
10668                   JMOHEP(2,MHEP) = MHEP
10669                   JDAHEP(2,MHEP) = MHEP
10670                   JMOHEP(2,NHEP) = LHEP
10671                   JDAHEP(2,NHEP) = LHEP
10672                 ELSE
10673 C--UDD decay colour connections
10674                   HVFCEN = .TRUE.
10675                   CALL HWDRCL(LHEP,MHEP,CLSAVE)
10676                 ENDIF
10677               ELSE
10678 C--Antisquark connections
10679                 IF(IDHW(MHEP).GT.12) THEN
10680                   JMOHEP(2,MHEP) = MHEP
10681                   JDAHEP(2,MHEP) = MHEP
10682                   JMOHEP(2,NHEP) = LHEP
10683                   JDAHEP(2,NHEP) = LHEP
10684                 ELSE
10685                   HVFCEN = .TRUE.
10686                  CALL HWDRCL(LHEP,MHEP,CLSAVE)
10687                 ENDIF
10688               ENDIF
10689             ENDIF
10690           ELSE
10691             IF(ID.GE.450.AND.ID.LE.457) THEN
10692 C--Rparity Neutralino/Chargino colour connection
10693               IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
10694      &               AND.IDHW(NHEP).LE.12) THEN
10695                 HVFCEN = .TRUE.
10696                 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10697               ELSE
10698                 JMOHEP(2,MHEP) = NHEP
10699                 JDAHEP(2,MHEP) = NHEP
10700                 JMOHEP(2,NHEP) = MHEP
10701                 JDAHEP(2,NHEP) = MHEP
10702               ENDIF
10703 C--Rparity gluino colour connections
10704             ELSEIF(ID.EQ.449) THEN
10705               IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
10706      &               AND.IDHW(NHEP).LE.12) THEN
10707                 HVFCEN = .TRUE.
10708                 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10709 C--Now the lepton number violating decay
10710               ELSE
10711                 IF(IDHW(MHEP).LE.6) THEN
10712                   JMOHEP(2,MHEP) = LHEP
10713                   JDAHEP(2,MHEP) = NHEP
10714                   JMOHEP(2,NHEP) = MHEP
10715                   JDAHEP(2,NHEP) = LHEP
10716                 ELSE
10717                   JMOHEP(2,MHEP) = NHEP
10718                   JDAHEP(2,MHEP) = LHEP
10719                   JMOHEP(2,NHEP) = LHEP
10720                   JDAHEP(2,NHEP) = MHEP
10721                 ENDIF
10722               ENDIF
10723             ELSE
10724               CALL HWWARN('HWDHO3',101)
10725               GOTO 999
10726             ENDIF
10727           ENDIF
10728         ELSE
10729 C Normal SUSY decays
10730           IF (ID.LE.448.AND.ID.GT.207) THEN
10731 C Squark (or slepton)
10732             IF (IDHW(MHEP).EQ.449) THEN
10733               IF (IDHEP(LHEP).GT.0) THEN
10734                 JMOHEP(2,MHEP)=LHEP
10735                 JDAHEP(2,MHEP)=NHEP
10736                 JMOHEP(2,NHEP)=MHEP
10737                 JDAHEP(2,NHEP)=LHEP
10738               ELSE
10739                 JMOHEP(2,MHEP)=NHEP
10740                 JDAHEP(2,MHEP)=LHEP
10741                 JMOHEP(2,NHEP)=LHEP
10742                 JDAHEP(2,NHEP)=MHEP
10743               ENDIF
10744             ELSE
10745               IF(NPR.EQ.3.AND.IDHW(MHEP).LE.12) THEN
10746                 JMOHEP(2,MHEP)=NHEP
10747                 JDAHEP(2,MHEP)=NHEP
10748                 JMOHEP(2,NHEP)=MHEP
10749                 JDAHEP(2,NHEP)=MHEP
10750               ELSE
10751                 JMOHEP(2,MHEP)=MHEP
10752                 JDAHEP(2,MHEP)=MHEP
10753                 JMOHEP(2,NHEP)=LHEP
10754                 JDAHEP(2,NHEP)=LHEP
10755               ENDIF
10756             ENDIF
10757           ELSEIF (ID.EQ.449) THEN
10758 C Gluino
10759             IF (IDHW(NHEP).EQ.13) THEN
10760               JMOHEP(2,MHEP)=MHEP
10761               JDAHEP(2,MHEP)=MHEP
10762               JMOHEP(2,NHEP)=LHEP
10763               JDAHEP(2,NHEP)=LHEP
10764             ELSEIF (IDHEP(MHEP).GT.0) THEN
10765               JMOHEP(2,MHEP)=LHEP
10766               JDAHEP(2,MHEP)=NHEP
10767               JMOHEP(2,NHEP)=MHEP
10768               JDAHEP(2,NHEP)=LHEP
10769             ELSE
10770               JMOHEP(2,MHEP)=NHEP
10771               JDAHEP(2,MHEP)=LHEP
10772               JMOHEP(2,NHEP)=LHEP
10773               JDAHEP(2,NHEP)=MHEP
10774             ENDIF
10775           ELSE
10776 C Gaugino or Higgs
10777             JMOHEP(2,MHEP)=NHEP
10778             JDAHEP(2,MHEP)=NHEP
10779             JMOHEP(2,NHEP)=MHEP
10780             JDAHEP(2,NHEP)=MHEP
10781           ENDIF
10782         ENDIF
10783       ENDIF
10784  999  RETURN
10785       END
10786 CDECK  ID>, HWDHO4.
10787 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
10788 *-- Author :    Ian Knowles & Bryan Webber
10789 C-----------------------------------------------------------------------
10790       SUBROUTINE HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
10791 C-----------------------------------------------------------------------
10792 C   Subroutine to perform the fourth part of the heavy object decays
10793 C   IE parton-showers with special treatment for top
10794 C   was part of HWDHOB
10795 C-----------------------------------------------------------------------
10796       INCLUDE 'herwig65.inc'
10797       DOUBLE PRECISION PW(5),PDW(5,3)
10798       INTEGER IHEP,ID,IM,I,KHEP,LHEP,MHEP,NPR,NTRY,WHEP,SHEP
10799       DOUBLE COMPLEX RHOIN(2,2)
10800       SAVE RHOIN
10801       DATA RHOIN/(0.5D0,0.0D0),(0.0D0,0.0D0),
10802      &           (0.0D0,0.0D0),(0.5D0,0.0D0)/
10803       IF (IERROR.NE.0) RETURN
10804       SHEP = NHEP
10805 C---SPECIAL CASE FOR THREE-BODY TOP DECAYS:
10806 C   RELABEL THEM AS TWO TWO-BODY DECAYS FOR PARTON SHOWERING
10807       IF ((ID.EQ.6.OR.ID.EQ.12).AND.NPR.EQ.3.AND.
10808      &     (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.
10809      &     (NME(IM).GT.10000.AND.NME(IM).LE.20000.AND.
10810      &     (SYSPIN.OR.THREEB)))) THEN
10811 C---STORE W/H DECAY PRODUCTS
10812         CALL HWVEQU(10,PHEP(1,KHEP),PDW)
10813 C---BOOST THEM INTO W/H REST FRAME
10814         CALL HWULOF(PW,PDW(1,1),PDW(1,3))
10815 C---REPLACE THEM BY W/H
10816         CALL HWVEQU(5,PW,PHEP(1,KHEP))
10817         WHEP=KHEP
10818         IF (NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
10819      &      NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB)))IDHW(KHEP)=198
10820         IF((NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
10821      &      NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB))).AND.(ID.EQ.12))
10822      &       IDHW(KHEP)=199
10823         IF (NME(IM).EQ.200)IDHW(KHEP)=206
10824         IF((NME(IM).EQ.200).AND.(ID.EQ.12))IDHW(KHEP)=207
10825         IDHEP(KHEP)=IDPDG(IDHW(KHEP))
10826         JMOHEP(2,KHEP)=KHEP
10827         JDAHEP(2,KHEP)=KHEP
10828         CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,KHEP))
10829 C---AND MOVE B UP
10830         CALL HWVEQU(5,PHEP(1,NHEP),PHEP(1,MHEP))
10831         IDHW(MHEP)=IDHW(NHEP)
10832         IDHEP(MHEP)=IDHEP(NHEP)
10833         JDAHEP(2,LHEP)=MHEP
10834         JMOHEP(2,MHEP)=JMOHEP(2,NHEP)
10835         JDAHEP(2,MHEP)=JDAHEP(2,NHEP)
10836         CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,MHEP))
10837         NHEP=MHEP
10838 C---DO PARTON SHOWER
10839         EMSCA=PHEP(5,IHEP)
10840         CALL HWBGEN
10841         IF (IERROR.NE.0) RETURN
10842 C---FIND BOOSTED W/H MOMENTUM
10843         NTRY=0
10844  41     NTRY=NTRY+1
10845         IF (NTRY.GT.NHEP.OR.WHEP.LE.0.OR.WHEP.GT.NHEP) THEN
10846           CALL HWWARN('HWDHO4',100)
10847           GOTO 999
10848         ENDIF
10849         WHEP=JDAHEP(1,WHEP)
10850         IF (ISTHEP(WHEP).NE.190) GOTO 41
10851 C---AND HENCE ITS CHILDRENS MOMENTA
10852         CALL HWULOB(PHEP(1,WHEP),PDW(1,3),PHEP(1,NHEP+1))
10853         CALL HWVDIF(4,PHEP(1,WHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
10854         PHEP(5,NHEP+2)=PDW(5,2)
10855 C---LABEL THEM
10856         ISTHEP(WHEP)=195
10857         DO 51 I=1,2
10858           IDHW(NHEP+I)=IDKPRD(I,IM)
10859           IDHEP(NHEP+I)=IDPDG(IDHW(NHEP+I))
10860           ISTHEP(NHEP+I)=112+I
10861           JDAHEP(I,WHEP)=NHEP+I
10862           JMOHEP(1,NHEP+I)=WHEP
10863           JMOHEP(2,NHEP+I)=NHEP+3-I
10864           JDAHEP(2,NHEP+I)=NHEP+3-I
10865  51     CONTINUE
10866         NHEP=NHEP+2
10867 C---ASSIGN PRODUCTION VERTICES TO 1 AND 2
10868         IF(NME(IM).EQ.100)CALL HWUDKL(198,PW,VHEP(1,NHEP))
10869         IF(NME(IM).EQ.200)CALL HWUDKL(206,PW,VHEP(1,NHEP))
10870         CALL HWVSUM(4,VHEP(1,WHEP),VHEP(1,NHEP),VHEP(1,NHEP))
10871         CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
10872 C---DO PARTON SHOWERS
10873         EMSCA=PW(5)
10874 C--modification to use photos in top decays
10875         IF(ITOPRD.EQ.1) CALL HWPHTP(WHEP)
10876 C--end of modification
10877         CALL HWBGEN
10878         IF (IERROR.NE.0) RETURN
10879       ELSE
10880 C Do parton showers
10881         EMSCA=PHEP(5,IHEP)
10882         CALL HWBGEN
10883         IF (IERROR.NE.0) RETURN
10884 C--special for gauge boson decay modes of gauginos and four body higgs
10885 C--call routine to add decay products and generate parton shower
10886         IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
10887           CALL HWDSM3(-1,IHEP,MHEP,SHEP,0,NME(IM)-20000,RHOIN,
10888      &       ISNHEP(IHEP))
10889         ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
10890           CALL HWDSM4(2,IHEP,MHEP,SHEP,NME(IM)-40000)
10891         ENDIF
10892         IF (IERROR.NE.0) RETURN
10893       ENDIF
10894  999  RETURN
10895       END
10896 CDECK  ID>, HWDHO5.
10897 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
10898 *-- Author :    Ian Knowles & Bryan Webber
10899 C-----------------------------------------------------------------------
10900       SUBROUTINE HWDHO5(MHEP,LHEP,CLSAVE)
10901 C-----------------------------------------------------------------------
10902 C   Subroutine to perform the fifth part of the heavy object decays
10903 C   IE sort out RPV colour connections
10904 C   was part of HWDHOB
10905 C-----------------------------------------------------------------------
10906       INCLUDE 'herwig65.inc'
10907       INTEGER ID,LHEP,MHEP,IDM,IDM2,THEP,CLSAVE(2)
10908       IF (IERROR.NE.0) RETURN
10909 C--New to correct colour connections in Rslash
10910       IF(CLSAVE(1).NE.0) THEN
10911         THEP = MHEP+1
10912         ID   = IDHW(CLSAVE(1))
10913         IDM  = IDHW(JMOHEP(1,CLSAVE(1)))
10914         IDM2 = IDHW(LHEP)
10915         IF(IDM.EQ.15) ID=IDHW(JMOHEP(1,JMOHEP(1,CLSAVE(1))))
10916         IF((ID.LE.6.AND.((IDM.GE.419.AND.IDM.LE.424).OR.IDM.EQ.411.OR.
10917      &      IDM.EQ.412).
10918      &     AND.((IDM2.GE.413.AND.IDM2.LE.418)
10919      &     .OR.IDM2.EQ.449).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
10920      &     .OR.(ID.LE.6.AND.IDM.EQ.449.AND.
10921      &    (((IDM2.GE.413.AND.IDM2.LE.418).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
10922      &     .OR.IDM2.EQ.449)).OR.
10923      &    (IDM.EQ.15.AND.ID.LE.12.AND.ID.GE.7.AND.((IDM2.GE.413.AND.
10924      &     IDM2.LE.418).OR.IDM2.EQ.449.OR.IDM2.
10925      &     EQ.405.OR.IDM2.EQ.406))) THEN
10926           IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
10927             IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
10928      &                       JMOHEP(2,CLSAVE(2)) = THEP
10929             JDAHEP(2,MHEP) = CLSAVE(1)
10930             JDAHEP(2,THEP) = CLSAVE(2)
10931           ELSE
10932             IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
10933      &                       JMOHEP(2,CLSAVE(2)) = MHEP
10934             JDAHEP(2,MHEP) = CLSAVE(2)
10935             JDAHEP(2,THEP) = CLSAVE(1)
10936           ENDIF
10937         ELSEIF((ID.GT.6.AND.ID.LE.12.
10938      &     AND.((IDM.GE.413.AND.IDM.LE.418).OR.IDM.EQ.405.OR.
10939      &     IDM.EQ.406).AND.
10940      &      ((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
10941      &      IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
10942      &        (ID.GT.6.AND.ID.LE.12.AND.IDM.EQ.449.
10943      &   AND.((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
10944      &       IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
10945      &    (IDM.EQ.15.AND.ID.LE.6.AND.((IDM2.GE.419.AND.
10946      &     IDM2.LE.424).OR.IDM2.EQ.449.OR.IDM2.EQ.411.OR.
10947      &     IDM2.EQ.412))) THEN
10948           IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
10949             JDAHEP(2,CLSAVE(2))=THEP
10950             JMOHEP(2,MHEP)=CLSAVE(1)
10951             JMOHEP(2,THEP)=CLSAVE(2)
10952           ELSE
10953             JDAHEP(2,CLSAVE(2))=MHEP
10954             JMOHEP(2,MHEP)=CLSAVE(2)
10955             JMOHEP(2,THEP)=CLSAVE(1)
10956           ENDIF
10957         ENDIF
10958         COLUPD = .FALSE.
10959         CALL HWBCON
10960       ENDIF
10961       END
10962 CDECK  ID>, HWDHO6.
10963 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
10964 *-- Author :    Ian Knowles & Bryan Webber
10965 C-----------------------------------------------------------------------
10966       SUBROUTINE HWDHO6
10967 C-----------------------------------------------------------------------
10968 C   Subroutine to perform the final part of the heavy object decays
10969 C   IE sort out any colour connection problems
10970 C-----------------------------------------------------------------------
10971       INCLUDE 'herwig65.inc'
10972       INTEGER IHEP,IM,JHEP,ISM,JCM
10973       IF (IERROR.NE.0) RETURN
10974 C Fix any SUSY colour disconnections
10975       DO 80 IHEP=1,NHEP
10976         IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.151
10977      &    .AND.JDAHEP(2,IHEP).EQ.0) THEN
10978           IM=JMOHEP(1,IHEP)
10979 C Chase connection back through SUSY decays
10980   75      IM=JMOHEP(1,IM)
10981           ISM=ISTHEP(IM)
10982           IF (ISM.EQ.120) GOTO 80
10983           IF (ISM.NE.123.AND.ISM.NE.124.AND.ISM.NE.155) GOTO 75
10984 C Look for unclustered parton to connect
10985           DO JHEP=1,NHEP
10986             IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.151) THEN
10987               JCM=JMOHEP(2,JHEP)
10988               IF (JCM.EQ.IM) THEN
10989 C Found it: connect
10990                 JMOHEP(2,JHEP)=IHEP
10991                 JDAHEP(2,IHEP)=JHEP
10992                 GOTO 80
10993               ENDIF
10994             ENDIF
10995           ENDDO
10996 C Not found: need to go further back
10997           GOTO 75
10998         ENDIF
10999    80 CONTINUE
11000       END
11001 CDECK  ID>, HWDHVY.
11002 *CMZ :-        -26/04/91  12.19.24  by  Federico Carminati
11003 *-- Author :    Ian Knowles & Bryan Webber
11004 C-----------------------------------------------------------------------
11005       SUBROUTINE HWDHVY
11006 C-----------------------------------------------------------------------
11007 C     Performs partonic decays of hadrons containing heavy quark(s):
11008 C     either, meson/baryon spectator model weak decays;
11009 C     or, quarkonia -> 2-gluons, q-qbar, 3-gluons, or 2-gluons + photon.
11010 C-----------------------------------------------------------------------
11011       INCLUDE 'herwig65.inc'
11012       COMMON/FFS/TB,BT
11013       COMMON/SFF/IT1,IB1,IT2,IB2
11014       DOUBLE PRECISION TB,BT
11015       INTEGER IT1,IB1,IT2,IB2
11016       DOUBLE PRECISION GAMHPM
11017       DOUBLE PRECISION HWULDO,HWRGEN,XS,XB,EMWSQ,GMWSQ,EMLIM,PW(4),
11018      & EMTST,X1,X2,X3,TEST,HWDWWT,HWDHWT,HWDPWT
11019       INTEGER IST(3),I,IHEP,IM,ID,IDQ,IQ,IS,J
11020       EXTERNAL HWRGEN,HWDWWT,HWDHWT,HWDPWT,HWULDO
11021       SAVE IST
11022       DATA IST/113,114,114/
11023       IF (IERROR.NE.0) RETURN
11024       DO 100 I=1,NMXQDK
11025       IF (I.GT.NQDK) THEN
11026         NQDK=0
11027         RETURN
11028       ENDIF
11029       IHEP=LOCQ(I)
11030       IF (ISTHEP(IHEP).EQ.199) GOTO 100
11031       IM=IMQDK(I)
11032       IF (NHEP+NPRODS(IM).GT.NMXHEP) THEN
11033         CALL HWWARN('HWDHVY',100)
11034         GOTO 999
11035       ENDIF
11036       IF (IDKPRD(4,IM).NE.0) THEN
11037 C Weak decay of meson or baryon
11038 C Idenitify decaying heavy quark and spectator
11039         ID=IDHW(IHEP)
11040         IF (ID.EQ.136.OR.ID.EQ.140.OR.ID.EQ.144.OR.
11041      &      ID.EQ.150.OR.ID.EQ.155.OR.ID.EQ.158.OR.ID.EQ.161.OR.
11042      &     (ID.EQ.254.AND.IDKPRD(4,IM).EQ.11)) THEN
11043 C c hadron or c decay of B_c+
11044           IDQ=4
11045           IQ=NHEP+1
11046           IS=NHEP+2
11047         ELSEIF (ID.EQ.171.OR.ID.EQ.175.OR.ID.EQ.179.OR.
11048      &          ID.EQ.185.OR.ID.EQ.190.OR.ID.EQ.194.OR.ID.EQ.196.OR.
11049      &         (ID.EQ.230.AND.IDKPRD(4,IM).EQ.5)) THEN
11050 C cbar hadron or cbar decay of B_c-
11051           IDQ=10
11052           IS=NHEP+1
11053           IQ=NHEP+2
11054         ELSEIF ((ID.GE.221.AND.ID.LE.229).OR.
11055      &          (ID.EQ.230.AND.IDKPRD(4,IM).EQ.10)) THEN
11056 C b hadron or b decay of B_c-
11057           IDQ=5
11058           IQ=NHEP+1
11059           IS=NHEP+2
11060         ELSEIF ((ID.GE.245.AND.ID.LE.253).OR.
11061      &          (ID.EQ.254.AND.IDKPRD(4,IM).EQ.4)) THEN
11062 C bbar hadron or bbar decay of B_c+
11063           IDQ=11
11064           IS=NHEP+1
11065           IQ=NHEP+2
11066         ELSE
11067 C Decay not recognized
11068           CALL HWWARN('HWDHVY',101)
11069           GOTO 999
11070         ENDIF
11071 C Label constituents
11072         IF (NHEP+5.GT.NMXHEP) THEN
11073           CALL HWWARN('HWDHVY',102)
11074           GOTO 999
11075         ENDIF
11076         ISTHEP(IHEP)=199
11077         JDAHEP(1,IHEP)=NHEP+1
11078         JDAHEP(2,IHEP)=NHEP+2
11079         IDHW(IQ)=IDQ
11080         IDHW(IS)=IDKPRD(4,IM)
11081         IDHEP(IQ)=IDPDG(IDQ)
11082         IDHEP(IS)=IDPDG(IDKPRD(4,IM))
11083         ISTHEP(IQ)=155
11084         ISTHEP(IS)=115
11085         JMOHEP(1,IQ)=IHEP
11086         JMOHEP(2,IQ)=IS
11087         JDAHEP(1,IQ)=NHEP+3
11088         JDAHEP(2,IQ)=NHEP+5
11089         JMOHEP(1,IS)=IHEP
11090         JMOHEP(2,IS)=NHEP+5
11091         JDAHEP(1,IS)=0
11092         JDAHEP(2,IS)=NHEP+5
11093         NHEP=NHEP+2
11094 C and weak decay product jets
11095         DO 10 J=1,3
11096         NHEP=NHEP+1
11097         IDHW(NHEP)=IDKPRD(J,IM)
11098         IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
11099         ISTHEP(NHEP)=IST(J)
11100         JMOHEP(1,NHEP)=IQ
11101         JDAHEP(1,NHEP)=0
11102   10    PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
11103         JMOHEP(2,NHEP-2)=NHEP-1
11104         JDAHEP(2,NHEP-2)=NHEP-1
11105         JMOHEP(2,NHEP-1)=NHEP-2
11106         JDAHEP(2,NHEP-1)=NHEP-2
11107         JMOHEP(2,NHEP  )=IQ
11108         JDAHEP(2,NHEP  )=IQ
11109 C Share momenta in ratio of masses, preserving specator mass
11110         XS=RMASS(IDHW(IS))/PHEP(5,IHEP)
11111         XB=ONE-XS
11112         CALL HWVSCA(5,XB,PHEP(1,IHEP),PHEP(1,IQ))
11113         CALL HWVSCA(5,XS,PHEP(1,IHEP),PHEP(1,IS))
11114         IF (NME(IM).EQ.100) THEN
11115 C Generate decay momenta using full (V-A)*(V-A) matrix element
11116           EMWSQ=RMASS(198)**2
11117           GMWSQ=(RMASS(198)*GAMW)**2
11118           EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
11119   20      CALL HWDTHR(PHEP(1,IQ  ),PHEP(1,NHEP-1),
11120      &                PHEP(1,NHEP-2),PHEP(1,NHEP),HWDWWT)
11121           CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
11122           EMTST=(HWULDO(PW,PW)-EMWSQ)**2
11123           IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 20
11124         ELSEIF (NME(IM).EQ.200) THEN
11125 C Generate decay momenta using full
11126 C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
11127           GAMHPM=RMASS(206)/DKLTM(206)
11128 C sort tan(beta)
11129           IF((IQ.EQ.  2).OR.(IQ.EQ.  4).OR.
11130      &       (IQ.EQ.  6).OR.(IQ.EQ.  8).OR.
11131      &       (IQ.EQ. 10).OR.(IQ.EQ. 12).OR.
11132      &       (IQ.EQ.122).OR.(IQ.EQ.124).OR.
11133      &       (IQ.EQ.126).OR.(IQ.EQ.128).OR.
11134      &       (IQ.EQ.130).OR.(IQ.EQ.132))THEN
11135             TB=TANB
11136           ELSE
11137             TB=1./TANB
11138           END IF
11139           IF((IDKPRD(1,IM).EQ.  2).OR.(IDKPRD(1,IM).EQ.  4).OR.
11140      &       (IDKPRD(1,IM).EQ.  6).OR.(IDKPRD(1,IM).EQ.  8).OR.
11141      &       (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
11142      &       (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
11143      &       (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
11144      &       (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
11145             BT=TANB
11146           ELSE
11147             BT=1./TANB
11148           END IF
11149           IT1=IQ
11150           IB1=IDKPRD(3,IM)
11151           IT2=IDKPRD(1,IM)
11152           IB2=IDKPRD(2,IM)
11153           EMWSQ=RMASS(206)**2
11154           GMWSQ=(RMASS(206)*GAMHPM)**2
11155           EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
11156   25      CALL HWDTHR(PHEP(1,IQ  ),PHEP(1,NHEP),
11157      &                PHEP(1,NHEP-2),PHEP(1,NHEP-1),HWDHWT)
11158           CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
11159           EMTST=(HWULDO(PW,PW)-EMWSQ)**2
11160           IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 25
11161         ELSE
11162 C Use phase space
11163           CALL HWDTHR(PHEP(1,IQ  ),PHEP(1,NHEP-2),
11164      &                PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
11165           CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
11166         ENDIF
11167 C Set up production vertices
11168         CALL HWVZRO(4,VHEP(1,IQ))
11169         CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,IS))
11170         CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,NHEP))
11171         CALL HWUDKL(198,PW,VHEP(1,NHEP-2))
11172         CALL HWVSUM(4,VHEP(1,IQ),VHEP(1,NHEP-2),VHEP(1,NHEP-2))
11173         CALL HWVEQU(4,VHEP(1,NHEP-2),VHEP(1,NHEP-1))
11174         EMSCA=PHEP(5,IQ)
11175       ELSE
11176 C Quarkonium decay
11177 C Label products
11178         ISTHEP(IHEP)=199
11179         JDAHEP(1,IHEP)=NHEP+1
11180         DO 30 J=1,NPRODS(IM)
11181         NHEP=NHEP+1
11182         IDHW(NHEP)=IDKPRD(J,IM)
11183         IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
11184         ISTHEP(NHEP)=IST(J)
11185         JMOHEP(1,NHEP)=IHEP
11186         JDAHEP(1,NHEP)=0
11187         PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
11188   30    CALL HWVZRO(4,VHEP(1,NHEP))
11189         JDAHEP(2,IHEP)=NHEP
11190 C Establish colour connections and select momentum configuration
11191         IF (NPRODS(IM).EQ.3) THEN
11192           IF (IDKPRD(3,IM).EQ.13) THEN
11193 C 3-gluon decay
11194             JMOHEP(2,NHEP-2)=NHEP
11195             JMOHEP(2,NHEP-1)=NHEP-2
11196             JMOHEP(2,NHEP  )=NHEP-1
11197             JDAHEP(2,NHEP-2)=NHEP-1
11198             JDAHEP(2,NHEP-1)=NHEP
11199             JDAHEP(2,NHEP  )=NHEP-2
11200           ELSE
11201 C or 2-gluon + photon decay
11202             JMOHEP(2,NHEP-2)=NHEP-1
11203             JMOHEP(2,NHEP-1)=NHEP-2
11204             JMOHEP(2,NHEP  )=NHEP
11205             JDAHEP(2,NHEP-2)=NHEP-1
11206             JDAHEP(2,NHEP-1)=NHEP-2
11207             JDAHEP(2,NHEP  )=NHEP
11208           ENDIF
11209           IF (NME(IM).EQ.130) THEN
11210 C Use Ore & Powell orthopositronium matrix element
11211   40        CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
11212      &                               PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
11213             X1=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-2))/PHEP(5,IHEP)**2
11214             X2=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-1))/PHEP(5,IHEP)**2
11215             X3=TWO-X1-X2
11216             TEST=((X1*(ONE-X1))**2+(X2*(ONE-X2))**2+(X3*(ONE-X3))**2)
11217      &          /(X1*X2*X3)**2
11218             IF (TEST.LT.TWO*HWRGEN(0)) GOTO 40
11219           ELSE
11220 C Use phase space
11221             CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
11222      &                               PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
11223           ENDIF
11224         ELSE
11225 C Parapositronium 2-gluon or q-qbar decay
11226           JMOHEP(2,NHEP-1)=NHEP
11227           JMOHEP(2,NHEP  )=NHEP-1
11228           JDAHEP(2,NHEP-1)=NHEP
11229           JDAHEP(2,NHEP  )=NHEP-1
11230           CALL HWDTWO(PHEP(1,IHEP),PHEP(1,NHEP-1),
11231      &                             PHEP(1,NHEP),CMMOM(IM),TWO,.FALSE.)
11232         ENDIF
11233         EMSCA=PHEP(5,IHEP)
11234       ENDIF
11235 C Process this new hard scatter
11236       CALL HWVEQU(4,VTXQDK(1,I),VTXPIP)
11237       CALL HWBGEN
11238       CALL HWCFOR
11239       CALL HWCDEC
11240       CALL HWDHAD
11241   100 CONTINUE
11242       NQDK=0
11243  999  RETURN
11244       END
11245 CDECK  ID>, HWDRCL.
11246 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
11247 *-- Author :    Peter Richardson
11248 C-----------------------------------------------------------------------
11249       SUBROUTINE HWDRCL(IHEP,MHEP,CLSAVE)
11250 C-----------------------------------------------------------------------
11251 C     Sets the colour connections in Baryon number violating decays
11252 C-----------------------------------------------------------------------
11253       INCLUDE 'herwig65.inc'
11254       INTEGER IHEP,MHEP,ID,ID2,IDM2,IDM3,COLCON(2,2,3),FLACON(2,3),JHEP,
11255      &        DECAY,COLANT,KHEP,IDM,IDMB,IDMB2,IDMB3,IDMB4,QHEP,IDM4,
11256      &        CLSAVE(2),XHEP,I,HWRINT,THEP
11257       LOGICAL CONBV
11258 C--Colour connections for the decays
11259       SAVE COLCON,FLACON
11260       DATA COLCON/-1,1,-1,-2,-2,1,-3,-1,-1,1,-2,-1/
11261       DATA FLACON/1,-1,1,-1,-1,0/
11262 C--identify the decay
11263       IF(IERROR.NE.0) RETURN
11264       ID = IDHW(IHEP)
11265       ID2 = IDHW(MHEP)
11266       IF(ID.GE.450.AND.ID.LE.457) THEN
11267         DECAY = 1
11268       ELSEIF(ID.EQ.449) THEN
11269         DECAY = 2
11270       ELSEIF((ID.GE.411.AND.ID.LE.424).OR.ID.EQ.405.OR.ID.EQ.406) THEN
11271         DECAY = 3
11272       ELSE
11273 C--UNKNOWN DECAY
11274         CALL HWWARN('HWDRCL',100)
11275         GOTO 999
11276       ENDIF
11277       COLANT = 1
11278 C--identify the colour partner
11279       IF(DECAY.GT.1.AND.ID2.LE.6) THEN
11280 C--colour partner
11281         COLANT = 2
11282         KHEP = JDAHEP(2,IHEP-1)
11283       ELSEIF(DECAY.GT.1.AND.ID2.GE.7) THEN
11284 C--anticolour partner
11285         COLANT = 3
11286         KHEP = JMOHEP(2,IHEP)
11287       ELSE
11288         KHEP=IHEP
11289       ENDIF
11290       IDM   = IDHW(JMOHEP(1,KHEP))
11291       IF(ABS(IDPDG(IDM)).GT.1000000.OR.IDM.EQ.15) THEN
11292         IDM2  = IDHW(JDAHEP(1,JMOHEP(1,KHEP)))
11293         IDM3  = IDHW(JDAHEP(2,JMOHEP(1,KHEP)))
11294         IDM4  = IDHW(JDAHEP(2,JMOHEP(1,KHEP))-1)
11295         QHEP  = JMOHEP(1,KHEP)
11296         IDMB  = IDHW(JMOHEP(1,QHEP))
11297         IDMB2 = IDHW(JMOHEP(2,QHEP))
11298         IDMB3 = IDHW(JDAHEP(1,QHEP))
11299         IDMB4 = IDHW(JDAHEP(2,QHEP))
11300       ENDIF
11301 C--Now decide if the colour partner decayed via BV
11302       IF(COLANT.EQ.2.AND.((((IDM.GE.413.AND.IDM.LE.418).OR.
11303      &                     IDM.EQ.449.OR.IDM.EQ.405.OR.IDM.EQ.406).AND.
11304      &                       (IDM2.GE.7.AND.IDM2.LE.12.AND.
11305      &                       IDM3.GE.7.AND.IDM3.LE.12.AND.
11306      &                       IDM4.GE.7.AND.IDM4.LE.12)).OR.
11307      &             (IDM.EQ.15.AND.IDMB.LE.6.AND.IDMB2.LE.6.AND.
11308      &              ((IDMB3.GE.7.AND.IDMB4.GE.12.AND.IDMB4.EQ.449).OR.
11309      &               (IDMB3.GE.198.AND.IDMB3.LE.207.AND.
11310      &                ABS(IDPDG(IDMB4)).GT.1000000))))) THEN
11311         CONBV = .TRUE.
11312         COLUPD = .TRUE.
11313         HVFCEN = .FALSE.
11314         XHEP = JMOHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
11315       ELSEIF(COLANT.EQ.3.AND.((((IDM.GE.419.AND.IDM.LE.424).OR.
11316      &                   IDM.EQ.449.OR.IDM.EQ.411.OR.IDM.EQ.412).AND.
11317      &                    (IDM2.LE.6.AND.IDM3.LE.6.AND.IDM4.LE.6)).OR.
11318      &               (IDM.EQ.15.AND.IDMB.GE.7.AND.IDMB.LE.12.AND.
11319      &                IDMB2.GE.7.AND.IDMB2.LE.12.AND.((IDMB3.LE.6.AND.
11320      &                IDMB4.EQ.449).OR.(ABS(IDPDG(IDMB4)).GT.1000000
11321      &                .AND.IDMB3.GE.198.AND.IDMB3.LE.207))))) THEN
11322         CONBV = .TRUE.
11323         COLUPD = .TRUE.
11324         HVFCEN = .FALSE.
11325         XHEP = JDAHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
11326       ELSE
11327         CONBV = .FALSE.
11328         COLUPD = .FALSE.
11329         XHEP = 0
11330       ENDIF
11331       IF(CONBV) THEN
11332         IF(IDM.NE.15) THEN
11333           CLSAVE(1) = JDAHEP(2,JMOHEP(1,KHEP))-1
11334           CLSAVE(2) = CLSAVE(1)+1
11335         ELSE
11336           IF(IDMB4.EQ.449) THEN
11337             DO I=1,2
11338               CLSAVE(I) = JMOHEP(I,JMOHEP(1,KHEP))
11339               IF(CLSAVE(I).EQ.XHEP) CLSAVE(I)=JDAHEP(1,JMOHEP(1,KHEP))
11340             ENDDO
11341           ELSE
11342             CLSAVE(1) = JMOHEP(1,JMOHEP(1,KHEP))
11343             CLSAVE(2) = JMOHEP(2,JMOHEP(1,KHEP))
11344           ENDIF
11345         ENDIF
11346       ELSE
11347         CLSAVE(1)=0
11348         CLSAVE(2)=0
11349       ENDIF
11350 C--Now set the colours for angular ordering
11351       THEP = MHEP-1
11352       IF(DECAY.EQ.1) THEN
11353         IF(ID2.LE.6) THEN
11354           JMOHEP(2,THEP) = THEP+HWRINT(1,2)
11355           JDAHEP(2,THEP) = THEP
11356         ELSE
11357           JMOHEP(2,THEP) = THEP
11358           JDAHEP(2,THEP) = THEP+HWRINT(1,2)
11359         ENDIF
11360       ELSEIF(DECAY.EQ.2) THEN
11361         IF(ID2.LE.6) THEN
11362           JMOHEP(2,THEP) = IHEP
11363           JDAHEP(2,THEP) = THEP
11364         ELSE
11365           JMOHEP(2,THEP) = THEP
11366           JDAHEP(2,THEP) = IHEP
11367         ENDIF
11368       ENDIF
11369 C--Colour of the second two
11370       DO JHEP=1,2
11371         IF(ID2.LE.6) THEN
11372           JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
11373      &                           COLCON(HWRINT(1,2),JHEP,DECAY)
11374           JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
11375         ELSE
11376           JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
11377      &                           COLCON(HWRINT(1,2),JHEP,DECAY)
11378           JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
11379         ENDIF
11380       ENDDO
11381 C--Now set the colours of the colour partner
11382       IF(DECAY.GT.1.AND..NOT.CONBV) THEN
11383         IF(ID2.LE.6) JMOHEP(2,KHEP) = MHEP+HWRINT(0,1)
11384         IF(ID2.GE.7) JDAHEP(2,KHEP) = MHEP+HWRINT(0,1)
11385       ELSEIF(CONBV) THEN
11386         IF(ID2.GT.6) THEN
11387           JMOHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
11388           IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
11389             JMOHEP(2,CLSAVE(2)) = MHEP+1
11390           ELSE
11391             JMOHEP(2,CLSAVE(2)) = MHEP
11392           ENDIF
11393         ELSE
11394           JDAHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
11395           IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
11396             JDAHEP(2,CLSAVE(2)) = MHEP+1
11397           ELSE
11398             JDAHEP(2,CLSAVE(2)) = MHEP
11399           ENDIF
11400         ENDIF
11401       ENDIF
11402  999  RETURN
11403       END
11404 CDECK  ID>, HWDRME.
11405 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
11406 *-- Author :    Peter Richardson
11407 C-----------------------------------------------------------------------
11408       SUBROUTINE HWDRME(LHEP,MHEP)
11409 C-----------------------------------------------------------------------
11410 C     SUBROUTINE TO IMPLEMENT ALL RPARITY DECAY MATRIX ELEMENTS
11411 C-----------------------------------------------------------------------
11412       INCLUDE 'herwig65.inc'
11413       DOUBLE PRECISION SM(6),SW(6),HWULDO,INFCOL,AM, M12SQ,M23SQ,MSGN,
11414      &                 M13SQ,A(6),B(6),SWEAK,MW,DECMOM(5),TEST(3),EPS,
11415      &                 M12SQT(6),M23SQT(6),M13SQT(6),LIMIT,M(4),RAND,
11416      &                 MC(2),MX2(6),MX(6),HWDPWT,HWRGEN,HWDRM1,LAMD(3),
11417      &                 TEST2
11418       EXTERNAL         HWDRM1,HWULDO,HWDPWT,HWRGEN
11419       INTEGER K,SN(3),LHEP,CSP,I,SB(3),J,ND,LTRY,MHEP,NSP,ID(3),IG,
11420      &        IDHWTP,IDHPTP,MTRY
11421       PARAMETER(EPS=1D-20)
11422       IF(IERROR.NE.0) RETURN
11423 C--Electroweak parameters, etc
11424       SWEAK = SQRT(SWEIN)
11425       MW    = RMASS(198)
11426       M(4)  = PHEP(5,LHEP)
11427       IG    = IDHW(LHEP)
11428 C--Find the masses of the final state and zero parameters
11429       DO K=1,3
11430         ID(K) = IDHW(MHEP+K-1)
11431         IF(ID(K).LE.12) THEN
11432           SN(K)=ID(K)
11433         ELSE
11434           SN(K)=ID(K)-120
11435         ENDIF
11436         IF(SN(K).GT.6) SN(K)=SN(K)-6
11437         M(K) = PHEP(5,LHEP+K)
11438         SB(K)=SN(K)
11439         LAMD(K) = ZERO
11440       ENDDO
11441       DO J=1,6
11442         MX2(J) = ZERO
11443         MX(J)  = ZERO
11444         M13SQT(J) = ZERO
11445         M23SQT(J) = ZERO
11446         M12SQT(J) = ZERO
11447       ENDDO
11448 C--Evaluate the coefficents for the mode we want
11449       IF(IG.GE.450.AND.IG.LE.453) THEN
11450 C--NEUTRALINO
11451         NSP = IG-449
11452         AM = RMASS(IG)
11453         MSGN = ZSGNSS(NSP)
11454         MC(1) =  ZMIXSS(NSP,3)/(2*MW*COSB*SWEAK)
11455         MC(2) =  ZMIXSS(NSP,4)/(2*MW*SINB*SWEAK)
11456 C--Calculate the combinations of couplings needed
11457         IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11458 C--first for the UDD modes
11459           DO J=1,2
11460             A(J) = M(1)*MC(2)*QMIXSS(SN(1),2,J)
11461      &             +SLFCH(SN(1),NSP)*QMIXSS(SN(1),1,J)
11462             B(J) = MSGN*(M(1)*MC(2)*QMIXSS(SN(1),1,J)
11463      &             +SRFCH(SN(1),NSP)*QMIXSS(SN(1),2,J))
11464             MX2(J) = QMIXSS(SN(1),2,J)
11465             A(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
11466      &               +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11467             B(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
11468      &               +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11469             MX2(J+2) = QMIXSS(SN(2),2,J)
11470             A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11471      &              +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11472             B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11473      &              +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11474             MX2(J+2) = QMIXSS(SN(3),2,J)
11475           ENDDO
11476           DO K=1,3
11477             SN(K) = SN(K)+400
11478             SB(K) = SB(K)+412
11479           ENDDO
11480         ELSEIF(ID(1).GE.121.AND.ID(2).GE.121.AND.ID(3).GE.121) THEN
11481 C--Now for the LLE modes
11482           DO J=1,2
11483             A(J)  = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
11484      &              +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
11485             B(J)  = M(1)*MC(1)*LMIXSS(SN(1),2,J)
11486      &              +SLFCH(10+SN(1),NSP)*LMIXSS(SN(2),1,J)
11487             MX2(J)= LMIXSS(SN(1),1,J)
11488             A(J+2) = ZERO
11489             B(J+2) = SLFCH(10+SN(2),NSP)*LMIXSS(SN(2),1,J)
11490             MX2(J+2) =  LMIXSS(SN(2),1,J)
11491             A(J+4) = M(3)*MC(1)*LMIXSS(SN(3),2,J)
11492      &      +SLFCH(10+SN(3),NSP)*LMIXSS(SN(3),1,J)
11493             B(J+4) = MSGN*(M(3)*MC(1)*LMIXSS(SN(3),1,J)
11494      &      +SRFCH(10+SN(3),NSP)*LMIXSS(SN(3),2,J))
11495             MX2(4+J) = LMIXSS(SN(3),2,J)
11496           ENDDO
11497           DO J=1,3
11498             SN(J) = SN(J) + 424
11499             SB(J) = SB(J) + 436
11500           ENDDO
11501         ELSE
11502 C--Now for both types of LQD modes
11503           IF(MOD(SN(1),2).EQ.0) THEN
11504 C--First the neutrino,down,antidown mode
11505             DO J=1,2
11506               A(J) = ZERO
11507               B(J) = SLFCH(10+SN(1),NSP)*
11508      &               LMIXSS(SN(1),1,J)
11509               MX2(J) = LMIXSS(SN(1),1,J)
11510               A(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
11511      &        +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11512               B(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
11513      &        +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11514               MX2(2+J) = QMIXSS(SN(2),1,J)
11515               A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11516      &        +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11517               B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11518      &        +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11519               MX2(J+4) = QMIXSS(SN(3),2,J)
11520             ENDDO
11521           ELSE
11522 C--Now the charged lepton, antiup,down modes
11523             DO J=1,2
11524               A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
11525      &        +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
11526               B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J)
11527      &        +SLFCH(10+SN(1),NSP)*LMIXSS(SN(1),1,J)
11528               MX2(J) = LMIXSS(SN(1),1,J)
11529               A(J+2) =MSGN*(M(2)*MC(2)*QMIXSS(SN(2),1,J)
11530      &        +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11531               B(J+2) = M(2)*MC(2)*QMIXSS(SN(2),2,J)
11532      &        +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11533               MX2(2+J) = QMIXSS(SN(2),1,J)
11534               A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11535      &        +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11536               B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11537      &        +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11538               MX2(J+4) = QMIXSS(SN(3),2,J)
11539             ENDDO
11540           ENDIF
11541           SN(1) = SN(1) + 424
11542           SB(1) = SB(1) + 436
11543           DO J=2,3
11544             SN(J) = SN(J) + 400
11545             SB(J) = SB(J) + 412
11546           ENDDO
11547         ENDIF
11548         DO K=1,3
11549           SM(2*K-1) = RMASS(SN(K))
11550           SM(2*K)   = RMASS(SB(K))
11551           SW(2*K-1) = HBAR/RLTIM(SN(K))
11552           SW(2*K)   = HBAR/RLTIM(SB(K))
11553         ENDDO
11554         ND = 3
11555         DO K=1,3
11556           LAMD(K) = ONE
11557         ENDDO
11558         INFCOL = ONE
11559       ELSEIF(IG.EQ.449) THEN
11560 C--GLUINO
11561 C--First obtian the masses and widths needed
11562         AM  = RMASS(IG)
11563         ND = 3
11564 C--Calculate the combinations of couplings needed
11565         IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11566 C--first for the UDD modes
11567           INFCOL = -0.5D0
11568 C--Couplings
11569           DO I=1,3
11570             DO J=1,2
11571               A(2*I-2+J)  = -QMIXSS(SN(I),1,J)
11572               B(2*I-2+J)  =  QMIXSS(SN(I),2,J)
11573               MX2(2*I-2+J) =  QMIXSS(SN(I),2,J)
11574             ENDDO
11575             SN(I) = SN(I)+400
11576             SB(I) = SB(I)+412
11577           ENDDO
11578         ELSE
11579           INFCOL = ONE
11580 C--Now for both types of LQD modes
11581           IF(MOD(SN(1),2).EQ.0) THEN
11582 C--First the neutrino,down,antidown mode
11583             DO J=1,2
11584               A(J)  = ZERO
11585               B(J)  = ZERO
11586               MX2(J) = ZERO
11587               A(J+2)   =  QMIXSS(SN(2),2,J)
11588               B(J+2)   = -QMIXSS(SN(2),1,J)
11589               MX2(J+2) =  QMIXSS(SN(2),1,J)
11590               A(J+4)   = -QMIXSS(SN(3),1,J)
11591               B(J+4)   =  QMIXSS(SN(3),2,J)
11592               MX2(4+J) =  QMIXSS(SN(3),2,J)
11593             ENDDO
11594           ELSEIF(MOD(SN(1),2).EQ.1) THEN
11595 C--Now the charged lepton, antiup,down modes
11596             DO J=1,2
11597               A(J)  = ZERO
11598               B(J)  = ZERO
11599               MX2(J) = ZERO
11600               A(J+2)   =  QMIXSS(SN(2),2,J)
11601               B(J+2)   = -QMIXSS(SN(2),1,J)
11602               MX2(J+2) =  QMIXSS(SN(2),1,J)
11603               A(J+4)     = -QMIXSS(SN(3),1,J)
11604               B(J+4)   =  QMIXSS(SN(3),2,J)
11605               MX2(J+4) =  QMIXSS(SN(3),2,J)
11606             ENDDO
11607           ENDIF
11608           SN(1) = SN(1) + 424
11609           SB(1) = SB(1) + 436
11610           DO K=2,3
11611             SN(K) = SN(K) + 400
11612             SB(K) = SB(K) + 412
11613           ENDDO
11614         ENDIF
11615         DO K=1,3
11616           SM(2*K-1) = RMASS(SN(K))
11617           SM(2*K)   = RMASS(SB(K))
11618           SW(2*K-1) = HBAR/RLTIM(SN(K))
11619           SW(2*K)   = HBAR/RLTIM(SB(K))
11620         ENDDO
11621         DO K=1,3
11622           LAMD(K) = ONE
11623         ENDDO
11624       ELSEIF(IG.GE.454.AND.IG.LE.457) THEN
11625 C--CHARGINO
11626         CSP = IG-453
11627         IF(CSP.GT.2) CSP = CSP-2
11628         AM  = RMASS(IG)
11629         INFCOL = -ONE
11630         MSGN = WSGNSS(CSP)
11631         MC(1) =  ONE/(SQRT(2.0D0)*MW*COSB)
11632         MC(2) =  ONE/(SQRT(2.0D0)*MW*SINB)
11633 C--Calculate the combinations of the couplings needed
11634         IF(ID(1).GT.120.AND.ID(2).GT.120.AND.ID(3).GT.120) THEN
11635 C--first for the LLE modes, three modes
11636           IF(MOD(SN(1),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
11637 C--the one diagram mode nubar,positron, nu
11638             DO J=1,2
11639               A(J+4) = LMIXSS(SN(3)-1,1,J)*WMXUSS(CSP,1)
11640      & -RMASS(SN(3)+119)*MC(1)*LMIXSS(SN(3)-1,2,J)*WMXUSS(CSP,2)
11641               B(J+4) = ZERO
11642               MX2(J+4) = LMIXSS(SN(3)-1,2,J)
11643             ENDDO
11644             ND = 1
11645             SN(3) = SN(3)+423
11646             SB(3) = SB(3)+435
11647           ELSEIF(MOD(SN(1),2).EQ.0.AND.MOD(SN(2),2).EQ.0) THEN
11648 C--the first two diagram mode nu, nu, positron
11649             DO J=1,2
11650               A(J)   = ZERO
11651               B(J)   = LMIXSS(SN(1)-1,1,J)*WMXUSS(CSP,1)
11652      & -RMASS(SN(1)+119)*MC(1)*LMIXSS(SN(1)-1,2,J)*WMXUSS(CSP,2)
11653               A(J+2) = ZERO
11654               B(J+2) = LMIXSS(SN(2)-1,1,J)*WMXUSS(CSP,1)
11655      & -RMASS(SN(2)+119)*MC(1)*LMIXSS(SN(2)-1,2,J)*WMXUSS(CSP,2)
11656               MX2(J)   = LMIXSS(SN(1)-1,1,J)
11657               MX2(J+2) = LMIXSS(SN(2)-1,1,J)
11658             ENDDO
11659             ND = 2
11660             DO J=1,2
11661               SN(J) = SN(J)+423
11662               SB(J) = SB(J)+435
11663             ENDDO
11664           ELSE
11665 C--the second two diagram mode positron, positron, electron
11666             DO J=1,2
11667               A(J)   = -M(1)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(1)+1,1,J)
11668               B(J)   = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(1)+1,1,J)
11669               A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(2)+1,1,J)
11670               B(J+2) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
11671               MX2(J)   = LMIXSS(SN(1)+1,1,J)
11672               MX2(J+2) = LMIXSS(SN(2)+1,1,J)
11673             ENDDO
11674             DO J=1,2
11675               SN(J) = SN(J)+425
11676               SB(J) = SB(J)+437
11677             ENDDO
11678             ND = 2
11679           ENDIF
11680           DO K=1,3
11681             LAMD(K) = ONE
11682           ENDDO
11683         ELSEIF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11684 C--now for the UDD
11685           IF(MOD(SN(1),2).EQ.0) THEN
11686 C--two diagram mode
11687             LAMD(1) = LAMDA3(SN(2)/2,SN(1)/2,(SN(3)+1)/2)
11688             LAMD(2) = LAMDA3(SN(1)/2,SN(2)/2,(SN(3)+1)/2)
11689             DO J=1,2
11690               A(J)   = WMXUSS(CSP,1)*QMIXSS(SN(1)-1,1,J)
11691      & -RMASS(SN(1)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(1)-1,2,J)
11692               B(J)   = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(1)-1,1,J)
11693               A(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
11694      & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
11695               B(J+2) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)-1,1,J)
11696               MX2(J)   = QMIXSS(SN(1)-1,2,J)
11697               MX2(J+2) = QMIXSS(SN(2)-1,2,J)
11698             ENDDO
11699             DO J=1,2
11700               SN(J) = SN(J) + 399
11701               SB(J) = SB(J) + 411
11702             ENDDO
11703             ND = 2
11704           ELSE
11705 C--three diagram mode
11706             LAMD(1) = LAMDA3((SN(1)+1)/2,(SN(2)+1)/2,(SN(3)+1)/2)
11707             LAMD(2) = LAMDA3((SN(2)+1)/2,(SN(1)+1)/2,(SN(3)+1)/2)
11708             LAMD(3) = LAMDA3((SN(3)+1)/2,(SN(2)+1)/2,(SN(1)+1)/2)
11709             DO I=1,3
11710               DO J=1,2
11711                 A(J+2*I-2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(I)+1,1,J)
11712      & -RMASS(SN(I)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(I)+1,2,J))
11713                 B(J+2*I-2) = -M(I)*MC(1)*WMXUSS(CSP,2)
11714      &                       *QMIXSS(SN(I)+1,1,J)
11715                 MX2(J+2*I-2)   = QMIXSS(SN(I)+1,2,J)
11716               ENDDO
11717               SN(I) = SN(I) + 401
11718               SB(I) = SB(I) + 413
11719             ENDDO
11720             ND = 3
11721           ENDIF
11722         ELSE
11723 C--now for the LQD modes
11724           IF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.0) THEN
11725 C--first one diagram mode nubar, dbar, up
11726             DO J=1,2
11727               A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
11728      &                  QMIXSS(SN(3)-1,1,J)
11729               B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
11730      &        -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
11731               MX2(J+4)   = QMIXSS(SN(3)-1,2,J)
11732             ENDDO
11733             SN(3) = SN(3) + 399
11734             SB(3) = SB(3) + 411
11735             ND = 1
11736           ELSEIF(MOD(SN(2),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
11737 C--second one diagram mode positron, ubar, up
11738             DO J=1,2
11739               A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
11740      &                  QMIXSS(SN(3)-1,1,J)
11741               B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
11742      &   -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
11743               MX2(J+4)   = QMIXSS(SN(3)-1,2,J)
11744             ENDDO
11745             SN(3) = SN(3) + 399
11746             SB(3) = SB(3) + 411
11747             ND = 1
11748           ELSEIF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.1) THEN
11749 C--first two diagram mode positron, dbar, down
11750             DO J=1,2
11751               A(J)   = -M(1)*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)+1,1,J)
11752               B(J)   = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
11753               A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*QMIXSS(SN(2)+1,1,J)
11754               B(J+2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(2)+1,1,J)
11755      &   -RMASS(SN(2)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)+1,2,J))
11756               MX2(J)   = LMIXSS(SN(1)+1,1,J)
11757               MX2(J+2) = QMIXSS(SN(2)+1,1,J)
11758             ENDDO
11759             SN(1) = SN(1) + 425
11760             SB(1) = SB(1) + 437
11761             SN(2) = SN(2) + 401
11762             SB(2) = SB(2) + 413
11763             ND = 2
11764           ELSE
11765 C--second two diagram mode nu, up, dbar
11766             DO J=1,2
11767               A(J)   = ZERO
11768               B(J)   = WMXUSS(CSP,1)*LMIXSS(SN(1)-1,1,J)
11769      &   -RMASS(119+SN(1))*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)-1,2,J)
11770               A(J+2) = -MSGN*M(2)*MC(2)*WMXVSS(CSP,2)*
11771      &                 QMIXSS(SN(2)-1,1,J)
11772               B(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
11773      &   -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
11774               MX2(J)   = LMIXSS(SN(1)-1,1,J)
11775               MX2(J+2) = QMIXSS(SN(2)-1,1,J)
11776             ENDDO
11777             SN(1) = SN(1) + 423
11778             SB(1) = SB(1) + 435
11779             SN(2) = SN(2) + 399
11780             SB(2) = SB(2) + 411
11781             ND = 2
11782           ENDIF
11783           DO K=1,3
11784             LAMD(K) = ONE
11785           ENDDO
11786         ENDIF
11787         IF(ND.EQ.1) THEN
11788           DO K=1,2
11789             SM(2*K-1) = 0.0D0
11790             SM(2*K)   = 0.0D0
11791             SW(2*K-1) = 0.0D0
11792             SW(2*K)   = 0.0D0
11793           ENDDO
11794           SM(5) = RMASS(SN(3))
11795           SM(6)   = RMASS(SB(3))
11796           SW(5) = HBAR/RLTIM(SN(3))
11797           SW(6)   = HBAR/RLTIM(SB(3))
11798         ELSE
11799           DO K=1,2
11800             SM(2*K-1) = RMASS(SN(K))
11801             SM(2*K)   = RMASS(SB(K))
11802             SW(2*K-1) = HBAR/RLTIM(SN(K))
11803             SW(2*K)   = HBAR/RLTIM(SB(K))
11804             SM(4+K)   = ZERO
11805             SW(4+K)   = ZERO
11806           ENDDO
11807         ENDIF
11808       ELSE
11809 C--UNKNOWN
11810         CALL HWWARN('HWDRME',500)
11811       ENDIF
11812 C--Set mixing to zero if diagram not available
11813       IF((AM.LT.(ABS(SM(1))+M(1)).OR.ABS(SM(1)).LT.(M(2)+M(3)))
11814      &   .AND.ABS(MX2(1)).GT.ZERO.AND.ND.NE.1) MX(1) = MX2(1)*LAMD(1)
11815         IF((AM.LT.(ABS(SM(2))+M(1)).OR.ABS(SM(2)).LT.(M(2)+M(3)))
11816      &   .AND.ABS(MX2(2)).GT.ZERO.AND.ND.NE.1) MX(2) = MX2(2)*LAMD(1)
11817         IF((AM.LT.(ABS(SM(3))+M(2)).OR.ABS(SM(3)).LT.(M(1)+M(3)))
11818      &   .AND.ABS(MX2(3)).GT.ZERO.AND.ND.NE.1) MX(3) = MX2(3)*LAMD(2)
11819         IF((AM.LT.(ABS(SM(4))+M(2)).OR.ABS(SM(4)).LT.(M(1)+M(3)))
11820      &   .AND.ABS(MX2(4)).GT.ZERO.AND.ND.NE.1) MX(4) = MX2(4)*LAMD(2)
11821         IF((AM.LT.(ABS(SM(5))+M(3)).OR.ABS(SM(5)).LT.(M(1)+M(2)))
11822      &   .AND.ABS(MX2(5)).GT.ZERO.AND.ND.NE.2) MX(5) = MX2(5)*LAMD(3)
11823         IF((AM.LT.(ABS(SM(6))+M(3)).OR.ABS(SM(6)).LT.(M(1)+M(2)))
11824      &   .AND.ABS(MX2(6)).GT.ZERO.AND.ND.NE.2) MX(6) = MX2(6)*LAMD(3)
11825 C--Calculate the limiting points
11826       DO J=1,2
11827         IF(ND.NE.1) THEN
11828           IF(ABS(MX(J)).GT.EPS) CALL HWDRM5(M23SQT(J),M13SQT(J),
11829      &      M12SQT(J),A(J),B(J),M(2),M(3),M(1),M(4),SM(J),SW(J))
11830           IF(ABS(MX(J+2)).GT.EPS) CALL HWDRM5(M13SQT(2+J),M23SQT(2+J),
11831      &    M12SQT(2+J),A(2+J),B(2+J),M(1),M(3),M(2),M(4),SM(2+J),SW(2+J))
11832         ENDIF
11833         IF(ND.NE.2) THEN
11834           IF(ABS(MX(J+4)).GT.EPS) CALL HWDRM5(M12SQT(4+J),M23SQT(4+J),
11835      &    M13SQT(4+J),A(4+J),B(4+J),M(1),M(2),M(3),M(4),SM(4+J),SW(4+J))
11836         ENDIF
11837       ENDDO
11838 C--Now evaluate the limit using these points
11839       LIMIT = ZERO
11840       DO 100 I=1,6
11841         IF(ABS(MX(I)).LT.EPS) GOTO 100
11842         LIMIT = LIMIT+HWDRM1(TEST,M12SQT(I),M13SQT(I),M23SQT(I),A,B,MX,
11843      &                       M,SM,SW,INFCOL,AM,0,ND)
11844  100  CONTINUE
11845       LIMIT = TWO*LIMIT
11846 C--Now evaluate at a random point
11847       MTRY = 0
11848  25   MTRY = MTRY+1
11849       LTRY = 0
11850  35   LTRY = LTRY+1
11851       CALL HWDTHR(PHEP(1,LHEP),PHEP(1,MHEP),
11852      &                  PHEP(1,MHEP+1),PHEP(1,MHEP+2),HWDPWT)
11853 C--Now calculate the m12sq etc for the actual point
11854       M12SQ = M(1)**2+M(2)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+1))
11855       M13SQ = M(1)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+2))
11856       M23SQ = M(2)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP+1),PHEP(1,MHEP+2))
11857 C--Now calulate the matrix element
11858       TEST2 = HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,
11859      &                       M,SM,SW,INFCOL,AM,1,ND)
11860 C--Now test the value againest the limit
11861       RAND = HWRGEN(0)*LIMIT
11862       IF(TEST2.GT.LIMIT) THEN
11863         LIMIT = 1.1D0*TEST2
11864         CALL HWWARN('HWDRME',51)
11865         GOTO 150
11866       ENDIF
11867  150  IF(TEST2.LT.RAND.AND.LTRY.LT.NETRY) THEN
11868         GOTO 35
11869       ELSEIF(LTRY.GE.NETRY) THEN
11870         IF(MTRY.LE.NETRY) THEN
11871           LIMIT = LIMIT*0.9D0
11872           CALL HWWARN('HWDRME',52)
11873           GOTO 25
11874         ELSE
11875           CALL HWWARN('HWDRME',100)
11876           GOTO 999
11877         ENDIF
11878       ENDIF
11879 C--Reorder the particles in gluino decay to get angular ordering right
11880       IF(IG.EQ.449.AND.ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11881         DO LTRY=1,3
11882           IF(TEST(LTRY).GT.RAND) THEN
11883             IF(LTRY.EQ.2) THEN
11884               IDHWTP        = IDHW(MHEP)
11885               IDHW(MHEP)    = IDHW(MHEP+1)
11886               IDHW(MHEP+1)  = IDHWTP
11887               IDHPTP        = IDHEP(MHEP)
11888               IDHEP(MHEP)   = IDHEP(MHEP+1)
11889               IDHEP(MHEP+1) = IDHPTP
11890               CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
11891               CALL HWVEQU(5,PHEP(1,MHEP+1),PHEP(1,MHEP))
11892               CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+1))
11893             ELSEIF(LTRY.EQ.3) THEN
11894               IDHWTP        = IDHW(MHEP)
11895               IDHW(MHEP)    = IDHW(MHEP+2)
11896               IDHW(MHEP+2)    = IDHWTP
11897               IDHPTP        = IDHEP(MHEP)
11898               IDHEP(MHEP)   = IDHEP(MHEP+2)
11899               IDHEP(MHEP+2)   = IDHPTP
11900               DO I=1,5
11901               CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
11902               CALL HWVEQU(5,PHEP(1,MHEP+2),PHEP(1,MHEP))
11903               CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+2))
11904               ENDDO
11905             ENDIF
11906             GOTO 52
11907           ENDIF
11908           RAND=RAND-TEST(LTRY)
11909         ENDDO
11910       ENDIF
11911  52   CONTINUE
11912  999  RETURN
11913       END
11914 CDECK  ID>, HWDRM1.
11915 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
11916 *-- Author :    Peter Richardson
11917 C-----------------------------------------------------------------------
11918       FUNCTION HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,M,SM,SW
11919      &                ,INFCOL,AM,LM,ND)
11920 C-----------------------------------------------------------------------
11921 C     FUNCTION TO GIVE THE R-PARITY VIOLATING MATRIX ELEMENT AT A GIVEN
11922 C     PHASE-SPACE POINT
11923 C-----------------------------------------------------------------------
11924       IMPLICIT NONE
11925       DOUBLE PRECISION M12SQ,M13SQ,M23SQ,MX(6),A(6),B(6),SM(6),SW(6),
11926      &                 INFCOL,AM,TERM(21),TEST(3),PLN,NPLN,ZERO,
11927      &                 M(4),HWDRM1,HWDRM2,HWDRM3,HWDRM4
11928       PARAMETER (ZERO=0)
11929       EXTERNAL HWDRM2,HWDRM3,HWDRM4
11930       INTEGER LM,K,ND
11931 C--Zero the array
11932         DO K=1,21
11933           TERM(K) = 0.0D0
11934         ENDDO
11935         HWDRM1 = 0.0D0
11936 C--The amplitude
11937       IF(ABS(MX(1)).GT.ZERO.AND.ND.NE.1) THEN
11938         TERM(1) = MX(1)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(1),
11939      &            SW(1),A(1),B(1))
11940         IF(ABS(MX(2)).GT.ZERO) TERM(7)= MX(1)*MX(2)*HWDRM3(M23SQ,M(2),
11941      &   M(3),M(1),M(4),SM(1),SM(2),SW(1),SW(2),A(1),A(2),B(1),B(2))
11942         IF(ABS(MX(3)).GT.ZERO) TERM(10)=-MX(1)*MX(3)*HWDRM4(M13SQ,M23SQ,
11943      &  M(1),M(3),M(2),M(4),SM(3),SM(1),SW(3),SW(1),A(1),A(3),B(1),B(3))
11944         IF(ABS(MX(4)).GT.ZERO) TERM(11)=-MX(1)*MX(4)*HWDRM4(M13SQ,M23SQ,
11945      &  M(1),M(3),M(2),M(4),SM(4),SM(1),SW(4),SW(1),A(1),A(4),B(1),B(4))
11946         IF(ABS(MX(5)).GT.ZERO) TERM(12)=-MX(1)*MX(5)*HWDRM4(M23SQ,M12SQ,
11947      &  M(3),M(2),M(1),M(4),SM(1),SM(5),SW(1),SW(5),A(5),A(1),B(5),B(1))
11948         IF(ABS(MX(6)).GT.ZERO) TERM(13)=-MX(1)*MX(6)*HWDRM4(M23SQ,M12SQ,
11949      &  M(3),M(2),M(1),M(4),SM(1),SM(6),SW(1),SW(6),A(6),A(1),B(6),B(1))
11950       ENDIF
11951       IF(ABS(MX(2)).GT.ZERO.AND.ND.NE.1) THEN
11952         TERM(2) = MX(2)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(2),
11953      &            SW(2),A(2),B(2))
11954         IF(ABS(MX(3)).GT.ZERO) TERM(14)=-MX(2)*MX(3)*HWDRM4(M13SQ,M23SQ,
11955      &  M(1),M(3),M(2),M(4),SM(3),SM(2),SW(3),SW(2),A(2),A(3),B(2),B(3))
11956         IF(ABS(MX(4)).GT.ZERO) TERM(15)=-MX(2)*MX(4)*HWDRM4(M13SQ,M23SQ,
11957      &  M(1),M(3),M(2),M(4),SM(4),SM(2),SW(4),SW(2),A(2),A(4),B(2),B(4))
11958         IF(ABS(MX(5)).GT.ZERO) TERM(16)=-MX(2)*MX(5)*HWDRM4(M23SQ,M12SQ,
11959      &  M(3),M(2),M(1),M(4),SM(2),SM(5),SW(2),SW(5),A(5),A(2),B(5),B(2))
11960         IF(ABS(MX(6)).GT.ZERO) TERM(17)=-MX(2)*MX(6)*HWDRM4(M23SQ,M12SQ,
11961      &  M(3),M(2),M(1),M(4),SM(2),SM(6),SW(2),SW(6),A(6),A(2),B(6),B(2))
11962       ENDIF
11963       IF(ABS(MX(3)).GT.ZERO.AND.ND.NE.1) THEN
11964         TERM(3) = MX(3)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(3),
11965      &            SW(3),A(3),B(3))
11966         IF(ABS(MX(4)).GT.ZERO) TERM(8)= MX(3)*MX(4)*HWDRM3(M13SQ,M(1),
11967      &   M(3),M(2),M(4),SM(3),SM(4),SW(3),SW(4),A(3),A(4),B(3),B(4))
11968         IF(ABS(MX(5)).GT.ZERO) TERM(18)=-MX(3)*MX(5)*HWDRM4(M12SQ,M13SQ,
11969      &  M(2),M(1),M(3),M(4),SM(5),SM(3),SW(5),SW(3),A(3),A(5),B(3),B(5))
11970         IF(ABS(MX(6)).GT.ZERO) TERM(19)=-MX(3)*MX(6)*HWDRM4(M12SQ,M13SQ,
11971      &  M(2),M(1),M(3),M(4),SM(6),SM(3),SW(6),SW(3),A(3),A(6),B(3),B(6))
11972       ENDIF
11973       IF(ABS(MX(4)).GT.ZERO.AND.ND.NE.1) THEN
11974         TERM(4) = MX(4)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(4),
11975      &            SW(4),A(4),B(4))
11976         IF(ABS(MX(5)).GT.ZERO) TERM(20)=-MX(4)*MX(5)*HWDRM4(M12SQ,M13SQ,
11977      &  M(2),M(1),M(3),M(4),SM(5),SM(4),SW(5),SW(4),A(4),A(5),B(4),B(5))
11978         IF(ABS(MX(6)).GT.ZERO) TERM(21)=-MX(4)*MX(6)*HWDRM4(M12SQ,M13SQ,
11979      &  M(2),M(1),M(3),M(4),SM(6),SM(4),SW(6),SW(4),A(4),A(6),B(4),B(6))
11980       ENDIF
11981       IF(ABS(MX(5)).GT.ZERO.AND.ND.NE.2) THEN
11982         TERM(5) = MX(5)**2*HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(5),
11983      &            SW(5),A(5),B(5))
11984         IF(ABS(MX(6)).GT.ZERO) TERM(9)= MX(5)*MX(6)*HWDRM3(M12SQ,M(1),
11985      &     M(2),M(3),M(4),SM(5),SM(6),SW(5),SW(6),A(5),A(6),B(5),B(6))
11986       ENDIF
11987       IF(ABS(MX(6)).GT.ZERO.AND.ND.NE.2) TERM(6) = MX(6)**2*
11988      &    HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(6),SW(6),A(6),B(6))
11989       DO K=10,21
11990         TERM(K)=TERM(K)*INFCOL
11991       ENDDO
11992 C--Add them up
11993       DO K=1,21
11994         HWDRM1 = HWDRM1+TERM(K)
11995       ENDDO
11996 C--Different colour flows for the gluino
11997       IF(LM.NE.0) THEN
11998         NPLN = 0.0D0
11999         PLN = 0.0D0
12000         DO K=1,9
12001           PLN = PLN+TERM(K)
12002         ENDDO
12003         DO K=10,21
12004           NPLN= NPLN+TERM(K)
12005         ENDDO
12006         DO K=1,3
12007           TEST(K) = (TERM(2*K-1)+TERM(2*K)+TERM(6+K))*(1+NPLN/PLN)
12008         ENDDO
12009       ELSE
12010         DO K=1,3
12011           TEST(K) = 0.0D0
12012         ENDDO
12013       ENDIF
12014       IF(HWDRM1.LT.ZERO) CALL HWWARN('HWDRM1',50)
12015       END
12016 CDECK  ID>, HWDRM2.
12017 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
12018 *-- Author :    Peter Richardson
12019 C-----------------------------------------------------------------------
12020       FUNCTION HWDRM2(X,MA,MB,MC,MD,MR1,GAM1,A,B)
12021 C-----------------------------------------------------------------------
12022 C     Function to compute the matrix element squared part of a 3-body
12023 C     R-parity decay
12024 C-----------------------------------------------------------------------
12025       IMPLICIT NONE
12026       DOUBLE PRECISION X,MA,MB,MC,MD,A,B,HWDRM2,MR1,GAM1
12027       HWDRM2  = (X - MA**2 - MB**2)*(4*A*B*MC*MD +
12028      &    (A**2 + B**2)*(-X + MC**2 + MD**2))/
12029      &     ((X-MR1**2)**2+GAM1**2*MR1**2)
12030       END
12031 CDECK  ID>, HWDRM3.
12032 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
12033 *-- Author :    Peter Richardson
12034 C-----------------------------------------------------------------------
12035       FUNCTION HWDRM3(X,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
12036 C-----------------------------------------------------------------------
12037 C     Function to compute the light/heavy interference part of a 3-body
12038 C     R-parity decay
12039 C-----------------------------------------------------------------------
12040       IMPLICIT NONE
12041       DOUBLE PRECISION X,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM3,MR1,MR2,GAM1
12042      &                 ,GAM2
12043 C
12044       HWDRM3  = 2*(X - MA**2 - MB**2)*(2*(A2*B1 + A1*B2)*MC*MD +
12045      &    (A1*A2 + B1*B2)*(-X + MC**2 + MD**2))*
12046      &  (GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(X - MR2**2))/
12047      &  (((X-MR1**2)**2+GAM1**2*MR1**2)*((X-MR2**2)**2+GAM2**2*MR2**2))
12048       END
12049 CDECK  ID>, HWDRM4.
12050 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
12051 *-- Author :    Peter Richardson
12052 C-----------------------------------------------------------------------
12053       FUNCTION HWDRM4(X,Y,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
12054 C-----------------------------------------------------------------------
12055 C     Function to compute the interference part of a 3-body
12056 C     R-parity decay
12057 C-----------------------------------------------------------------------
12058       IMPLICIT NONE
12059       DOUBLE PRECISION X,Y,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM4,MR1,MR2,GAM1
12060      &                 ,GAM2
12061 C
12062       HWDRM4  = 2*((GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(Y - MR2**2))*
12063      &    (A2*B1*MC*MD*(X - MA**2 - MB**2) +
12064      &      A1*A2*MA*MC*(X + Y - MA**2 - MC**2) +
12065      &      A1*B2*MA*MD*(Y - MB**2 - MC**2) +
12066      &      B1*B2*(X*Y - MA**2*MC**2 - MB**2*MD**2)))/
12067      &  (((X-MR1**2)**2+GAM1**2*MR1**2)*((Y-MR2**2)**2+GAM2**2*MR2**2))
12068       END
12069 CDECK  ID>, HWDRM5.
12070 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
12071 *-- Author :    Peter Richardson
12072 C-----------------------------------------------------------------------
12073       SUBROUTINE HWDRM5(X,Y,Z,A,B,MA,MB,MC,MD,MR,GAM)
12074 C-----------------------------------------------------------------------
12075 C     Subroutine to find the maximum of the ME
12076 C-----------------------------------------------------------------------
12077       IMPLICIT NONE
12078       DOUBLE PRECISION X,Y,Z,MA,MB,MC,MD,MR,GAM,RES(3),A,B,C,D,
12079      &                 E2S,E3S,E2M,E3M,LOW,UPP,HWRUNI,EPS,ZERO
12080       EXTERNAL HWRUNI
12081       PARAMETER(EPS=1D-9,ZERO=0)
12082       C = A**2+B**2
12083       D = 4*A*B
12084       RES(1) = -D*(MA**2 + MB**2)*MC*MD +
12085      &          C*(GAM**2*MR**2 + MR**4 - MA**2*MC**2 - MB**2*MC**2 -
12086      &          MA**2*MD**2 - MB**2*MD**2)
12087       RES(2) = (GAM**2*MR**2 + (-MR**2 + MA**2 + MB**2)**2)*
12088      &          (D**2*MC**2*MD**2 +
12089      &          2*C*D*MC*MD*(-MR**2 + MC**2 + MD**2) +
12090      &          C**2*(GAM**2*MR**2 + (-MR**2 + MC**2 + MD**2)**2))
12091       RES(3) = -D*MC*MD+C*(2*MR**2-(MA**2+MB**2+MC**2+MD**2))
12092       IF(RES(2).GT.ZERO) THEN
12093         RES(2) = SQRT(RES(2))
12094       ELSE
12095         RES(2) = 0.0D0
12096       ENDIF
12097       IF((RES(1)+RES(2))/RES(3).GT.(MD-MC)**2.OR.
12098      &              (RES(1)+RES(2))/RES(3).LT.(MA+MB)**2) THEN
12099         X = (RES(1)-RES(2))/RES(3)
12100       ELSE
12101         X = (RES(1)+RES(2))/RES(3)
12102       ENDIF
12103       IF(X.GT.(MD-MC)**2) X = (MD-MC)**2
12104       IF(X.LT.(MA+MB)**2) X = (MA+MB)**2
12105       E2S = (X-MA**2+MB**2)/(2*SQRT(X))
12106       E3S = (MD**2-X-MC**2)/(2*SQRT(X))
12107       E2M = E2S**2-MB**2
12108       E3M = E3S**2-MC**2
12109       IF(E2M.LT.ZERO) THEN
12110         IF(ABS(E2M/E2S).GT.EPS) CALL HWWARN('HWDRM5',2)
12111         E2M= 0.0D0
12112       ENDIF
12113       IF(E3M.LT.ZERO) THEN
12114         IF(ABS(E3M/E3S).GT.EPS) CALL HWWARN('HWDRM5',3)
12115         E3M= 0.0D0
12116       ENDIF
12117       E2M = SQRT(E2M)
12118       E3M = SQRT(E3M)
12119       LOW = (E2S+E3S)**2-(E2M+E3M)**2
12120       UPP = (E2S+E3S)**2-(E2M-E3M)**2
12121       Y   = HWRUNI(1,LOW,UPP)
12122       Z   = MA**2+MB**2+MC**2+MD**2-X-Y
12123       END
12124 CDECK  ID>, HWDPWT.
12125 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
12126 *-- Author :    Bryan Webber
12127 C-----------------------------------------------------------------------
12128       FUNCTION HWDPWT(EMSQ,A,B,C)
12129 C-----------------------------------------------------------------------
12130 C     MATRIX ELEMENT SQUARED FOR PHASE SPACE DECAY
12131 C-----------------------------------------------------------------------
12132       IMPLICIT NONE
12133       DOUBLE PRECISION HWDPWT,EMSQ,A,B,C
12134       HWDPWT=1.
12135       END
12136 CDECK  ID>, HWDSIN.
12137 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
12138 *-- Author :    Peter Richardson
12139 C-----------------------------------------------------------------------
12140       SUBROUTINE HWDSIN(CLSAVE)
12141 C-----------------------------------------------------------------------
12142 C  Subroutine to perform decays including spin correlations
12143 C-----------------------------------------------------------------------
12144       INCLUDE 'herwig65.inc'
12145       DOUBLE PRECISION PW(5)
12146       INTEGER IDEC,IP,IS,IHEP,ID,IM,LHEP,MHEP,NPR,KHEP,CLSAVE(2),NTRY,
12147      &     ID1
12148       IF(IERROR.NE.0) RETURN
12149       NTRY = 0
12150       IDEC = 1
12151  1    NTRY = NTRY+1
12152 C--search the decay products and decide which one to decay next
12153       IF(.NOT.DECSPN(IDEC)) THEN
12154         CALL HWDSI1(IDEC,IP)
12155       ELSE
12156         IDEC = JMOSPN(IDEC)
12157         GOTO 1
12158       ENDIF
12159 C--first no more particles in this decay to develop so move up chain
12160       IF(IP.EQ.0) THEN
12161         IDEC = JMOSPN(IDEC)
12162 C--reached the end of this spin chain go back to HWDHOB
12163         IF(IDEC.EQ.0) THEN
12164           NSPN = 0
12165           RETURN
12166 C--otherwise keep going up the chain
12167         ELSE
12168           IF(NTRY.LE.NBTRY) THEN
12169             GOTO 1
12170           ELSE
12171             CALL HWWARN('HWDSIN',100)
12172             GOTO 999
12173           ENDIF
12174         ENDIF
12175 C--special for tau decays call spin correlation in tau decay routine
12176       ELSEIF(ABS(IDHEP(IDSPN(IP))).EQ.15) THEN
12177         CALL HWDSI3(IP)
12178         IF(IERROR.NE.0) RETURN
12179         GOTO 1
12180       ENDIF
12181 C--work out where that particle is
12182       IHEP = IDSPN(IP)
12183 C--if particle has daughters
12184  10   IF(JDAHEP(1,IHEP).NE.0) THEN
12185         IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
12186           DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
12187             IF(IDHW(ID1).EQ.ID) IHEP=ID1
12188           ENDDO
12189         ELSE
12190           IHEP = JDAHEP(1,IHEP)
12191         ENDIF
12192       ENDIF
12193       IS=ISTHEP(IHEP)
12194       ID=IDHW(IHEP)
12195       NTRY = NTRY+1
12196       IF(NTRY.GE.NBTRY) THEN
12197         CALL HWWARN('HWDSIN',101)
12198         GOTO 999
12199       ENDIF
12200       IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
12201      & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
12202      & (IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
12203         CALL HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
12204         IF(IERROR.NE.0) RETURN
12205       ELSE
12206         GOTO 10
12207       ENDIF
12208 C--perform the decay including spin correlations
12209       CALL HWDSI2(IHEP,IM,NPR,MHEP,KHEP,PW)
12210       IF(IERROR.NE.0) RETURN
12211 C--make the colour connections
12212       CALL HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
12213       IF (IERROR.NE.0) RETURN
12214 C--perform the parton-showers
12215       CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
12216       IF(IERROR.NE.0) RETURN
12217 C--perform RPV colour connections
12218       CALL HWDHO5(MHEP,LHEP,CLSAVE)
12219       IF(IERROR.NE.0) RETURN
12220 C--continue and perform the next decay
12221       IDEC = IP
12222       IF(NTRY.LE.NBTRY) THEN
12223         GOTO 1
12224       ELSE
12225         CALL HWWARN('HWDSIN',102)
12226       ENDIF
12227  999  RETURN
12228       END
12229 CDECK  ID>, HWDSI1.
12230 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
12231 *-- Author :    Peter Richardson
12232 C-----------------------------------------------------------------------
12233       SUBROUTINE HWDSI1(IDEC,IP)
12234 C-----------------------------------------------------------------------
12235 C  Subroutine to check a vertex and decide which branch to treat
12236 C-----------------------------------------------------------------------
12237       INCLUDE 'herwig65.inc'
12238       INTEGER IDEC,I,IPICK(5),IP,HWRINT,P1,P2,P3,P4,P3P,P4P,NPR,P0,P0P,
12239      &     P1P,P2P,IF1,IF2,P5,P5P
12240       DOUBLE PRECISION NORM
12241       DOUBLE COMPLEX RHOLP(2,2),RHOPS(2,2)
12242       EXTERNAL HWRINT
12243 C--loop over the daughters and decide what to do
12244       IP = 0
12245 C--if daughters of particle the same issue warning
12246       IF(JDASPN(1,IDEC).EQ.JDASPN(2,IDEC)) THEN
12247         CALL HWWARN('HWDSI1',100)
12248         GOTO 999
12249       ENDIF
12250 C--loop over the decay products
12251       DO I=JDASPN(1,IDEC),JDASPN(2,IDEC)
12252         IF(.NOT.DECSPN(I)) THEN
12253 C--first SM particles other than tau and top and stable particles
12254           IF(RSTAB(IDHW(IDSPN(I)))
12255      &    .OR.(IDHW(IDSPN(I)).LE.12.AND.ABS(IDHEP(IDSPN(I))).NE.6)
12256      &    .OR.(IDHW(IDSPN(I)).GE.121.AND.IDHW(IDSPN(I)).LE.132.AND.
12257      &          ABS(IDHEP(IDSPN(I))).NE.15)) THEN
12258              DECSPN(I) = .TRUE.
12259              RHOSPN(1,1,I) = HALF
12260              RHOSPN(1,2,I) = ZERO
12261              RHOSPN(2,1,I) = ZERO
12262              RHOSPN(2,2,I) = HALF
12263 C--spinless particles
12264           ELSEIF(RSPIN(IDHW(IDSPN(I))).EQ.ZERO) THEN
12265              DECSPN(I) = .TRUE.
12266              RHOSPN(1,1,I) = ONE
12267              RHOSPN(1,2,I) = ZERO
12268              RHOSPN(2,1,I) = ZERO
12269              RHOSPN(2,2,I) = ZERO
12270           ELSE
12271 C--particle which needs development
12272             IP = IP+1
12273             IPICK(IP) = I
12274           ENDIF
12275         ENDIF
12276       ENDDO
12277 C--pick the particle to decay next
12278       IF(IP.EQ.0) THEN
12279         IF(JMOSPN(IDEC).EQ.0) RETURN
12280 C--done everything compute the decay matrix and move up
12281         DECSPN(IDEC) = .TRUE.
12282         NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
12283         DO 20 P0=1,2
12284         DO 20 P0P=1,2
12285  20     RHOSPN(P0,P0P,IDEC) = ZERO
12286 C--two body decay
12287         IF(NPR.EQ.2) THEN
12288           DO 21 P0 =1,2
12289           DO 21 P0P=1,2
12290           DO 21 P1 =1,2
12291           DO 21 P1P=1,2
12292           DO 21 P2 =1,2
12293           DO 21 P2P=1,2
12294  21       RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
12295      &              MESPN(P0 ,P1 ,P2 ,1,NCFL(IDEC),IDEC)*
12296      &       DCONJG(MESPN(P0P,P1P,P2P,1,NCFL(IDEC),IDEC))*
12297      &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(2,IDEC))
12298 C--three body decay
12299         ELSEIF(NPR.EQ.3) THEN
12300           DO 25 P0 =1,2
12301           DO 25 P0P=1,2
12302           DO 25 P1 =1,2
12303           DO 25 P1P=1,2
12304           DO 25 P2 =1,2
12305           DO 25 P2P=1,2
12306           DO 25 P3 =1,2
12307           DO 25 P3P=1,2
12308  25       RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
12309      &           MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12310      &    DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12311      &    RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12312      &    RHOSPN(P3,P3P,JDASPN(2,IDEC))
12313 C--higher
12314         ELSE
12315           CALL HWWARN('HWDSI1',500)
12316         ENDIF
12317 C--now normalise this
12318         NORM = DBLE(RHOSPN(1,1,IDEC))+DBLE(RHOSPN(2,2,IDEC))
12319         IF(NORM.GT.ZERO) THEN
12320           NORM = ONE/NORM
12321           DO 35 P0=1,2
12322           DO 35 P0P=1,2
12323  35       RHOSPN(P0,P0P,IDEC) = NORM*RHOSPN(P0,P0P,IDEC)
12324         ELSE
12325           CALL HWWARN('HWDSI1',101)
12326           GOTO 999
12327         ENDIF
12328       ELSE
12329 C--pick the particle to be decayed
12330         IP = IPICK(HWRINT(1,IP))
12331 C--setup the spin density matrix for the decay
12332 C--special for the hard process
12333         IF(ISTHEP(IDSPN(IDEC)).EQ.120) THEN
12334           NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
12335 C--set up the spin density matrices for the incoming partons
12336 C--zero off diagonal elements
12337           RHOLP(2,1) = ZERO
12338           RHOLP(1,2) = ZERO
12339           RHOPS(2,1) = ZERO
12340           RHOPS(1,2) = ZERO
12341 C--set up for polarized incoming beams in lepton collisons
12342           IF(IDHW(JMOHEP(1,IDSPN(IDEC))).GE.121.AND.
12343      &       IDHW(JMOHEP(1,IDSPN(IDEC))).LE.132) THEN
12344             RHOLP(1,1) = HALF*(ONE+EPOLN(3))
12345             RHOLP(2,2) = HALF*(ONE-EPOLN(3))
12346             RHOPS(1,1) = HALF*(ONE-PPOLN(3))
12347             RHOPS(2,2) = HALF*(ONE+PPOLN(3))
12348 C--otherwise average
12349           ELSE
12350             RHOLP(1,1) = HALF
12351             RHOLP(2,2) = HALF
12352             RHOPS(1,1) = HALF
12353             RHOPS(2,2) = HALF
12354           ENDIF
12355 C--first decay product
12356           IF(NPR.EQ.2) THEN
12357            IF(IP.EQ.JDASPN(1,IDEC)) THEN
12358 C--if using first colour flow option
12359             IF(SPCOPT.EQ.1) THEN
12360               DO 5 P3 =1,2
12361               DO 5 P3P=1,2
12362               RHOSPN(P3,P3P,IP) = ZERO
12363               DO 5 IF1=1,NCFL(1)
12364               DO 5 IF2=1,NCFL(1)
12365               DO 5 P1 =1,2
12366               DO 5 P1P=1,2
12367               DO 5 P2 =1,2
12368               DO 5 P2P=1,2
12369               DO 5 P4 =1,2
12370               DO 5 P4P=1,2
12371  5            RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+SPNCFC(IF1,IF2,1)*
12372      &               MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
12373      &        DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
12374      &        RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
12375 C--if using second colour flow option
12376             ELSEIF(SPCOPT.EQ.2) THEN
12377               DO 6 P3 =1,2
12378               DO 6 P3P=1,2
12379               RHOSPN(P3,P3P,IP) = ZERO
12380               DO 6 P1 =1,2
12381               DO 6 P1P=1,2
12382               DO 6 P2 =1,2
12383               DO 6 P2P=1,2
12384               DO 6 P4 =1,2
12385               DO 6 P4P=1,2
12386  6            RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)
12387      &                +SPNCFC(NCFL(1),NCFL(1),1)*
12388      &               MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
12389      &        DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
12390      &        RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
12391 C--unknown option issue warning
12392             ELSE
12393               CALL HWWARN('HWDSI1',501)
12394             ENDIF
12395 C--second decay product
12396            ELSE
12397             IF(SPCOPT.EQ.1) THEN
12398               DO 10 P4 =1,2
12399               DO 10 P4P=1,2
12400               RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12401               DO 10 IF1=1,NCFL(1)
12402               DO 10 IF2=1,NCFL(1)
12403               DO 10 P1 =1,2
12404               DO 10 P1P=1,2
12405               DO 10 P2 =1,2
12406               DO 10 P2P=1,2
12407               DO 10 P3 =1,2
12408               DO 10 P3P=1,2
12409  10           RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+SPNCFC(IF1,IF2,1)*
12410      &                 MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
12411      &          DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
12412      &          RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
12413             ELSEIF(SPCOPT.EQ.2) THEN
12414               DO 11 P4 =1,2
12415               DO 11 P4P=1,2
12416               RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12417               DO 11 P1 =1,2
12418               DO 11 P1P=1,2
12419               DO 11 P2 =1,2
12420               DO 11 P2P=1,2
12421               DO 11 P3 =1,2
12422               DO 11 P3P=1,2
12423  11           RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)
12424      &                +SPNCFC(NCFL(1),NCFL(1),1)*
12425      &                 MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
12426      &          DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
12427      &          RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
12428             ELSE
12429               CALL HWWARN('HWDSI1',502)
12430               GOTO 999
12431             ENDIF
12432            ENDIF
12433 C--new for four body gauge boson pair processes
12434           ELSEIF(NPR.EQ.4) THEN
12435 C--first particle
12436            IF(IP.EQ.JDASPN(1,IDEC)) THEN
12437              DO 41 P1 =1,2
12438              DO 41 P1P=1,2
12439              RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12440              DO 41 P3 =1,2
12441              DO 41 P3P=1,2
12442              DO 41 P5 =1,2
12443              DO 41 P5P=1,2
12444  41          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12445      &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12446      &       RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12447      &       RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12448      &       RHOSPN(P3,P3P,JDASPN(2,IDEC))
12449 C--second particle
12450            ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12451              DO 42 P1 =1,2
12452              DO 42 P1P=1,2
12453              RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12454              DO 42 P3 =1,2
12455              DO 42 P3P=1,2
12456              DO 42 P5 =1,2
12457              DO 42 P5P=1,2
12458  42          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12459      &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12460      &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12461      &       RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12462      &       RHOSPN(P3,P3P,JDASPN(2,IDEC))
12463 C--third particle
12464            ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
12465              DO 43 P3 =1,2
12466              DO 43 P3P=1,2
12467              RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12468              DO 43 P1 =1,2
12469              DO 43 P1P=1,2
12470              DO 43 P5 =1,2
12471              DO 43 P5P=1,2
12472  43          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12473      &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12474      &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12475      &       RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12476      &       RHOSPN(P3,P3P,JDASPN(2,IDEC))
12477 C--fourth particle
12478            ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12479              DO 44 P3 =1,2
12480              DO 44 P3P=1,2
12481              RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12482              DO 44 P1 =1,2
12483              DO 44 P1P=1,2
12484              DO 44 P5 =1,2
12485              DO 44 P5P=1,2
12486  44          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12487      &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12488      &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12489      &       RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12490      &       RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
12491 C--unrecognized issue warning
12492            ELSE
12493              CALL HWWARN('HWDSI1',509)
12494              GOTO 999
12495            ENDIF
12496 C--unrecognized issue warning
12497           ELSE
12498             CALL HWWARN('HWDSI1',508)
12499             GOTO 999
12500           ENDIF
12501         ELSE
12502           NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
12503           DO 50 P1 =1,2
12504           DO 50 P1P=1,2
12505  50       RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12506 C--set-up matrix for 2-body decay
12507           IF(NPR.EQ.2) THEN
12508             IF(NCFL(IDEC).NE.1) CALL HWWARN('HWDSI1',503)
12509             IF(IP.EQ.JDASPN(1,IDEC)) THEN
12510               DO 60 P0 =1,2
12511               DO 60 P0P=1,2
12512               DO 60 P1 =1,2
12513               DO 60 P1P=1,2
12514               DO 60 P2 =1,2
12515               DO 60 P2P=1,2
12516  60           RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
12517      &               MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
12518      &        DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
12519      &        RHOSPN(P2,P2P,JDASPN(2,IDEC))
12520             ELSE
12521               DO 70 P0 =1,2
12522               DO 70 P0P=1,2
12523               DO 70 P1 =1,2
12524               DO 70 P1P=1,2
12525               DO 70 P2 =1,2
12526               DO 70 P2P=1,2
12527  70           RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
12528      &               MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
12529      &        DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
12530      &        RHOSPN(P1,P1P,JDASPN(1,IDEC))
12531             ENDIF
12532 C--set-up matrix for 3-body decay
12533           ELSEIF(NPR.EQ.3) THEN
12534             IF(SPCOPT.NE.2.AND.NCFL(IDEC).NE.1)
12535      &        CALL HWWARN('HWDSI1',504)
12536 C--first particle
12537             IF(IP.EQ.JDASPN(1,IDEC)) THEN
12538               DO 100 P0 =1,2
12539               DO 100 P0P=1,2
12540               DO 100 P1 =1,2
12541               DO 100 P1P=1,2
12542               DO 100 P2 =1,2
12543               DO 100 P2P=1,2
12544               DO 100 P3 =1,2
12545               DO 100 P3P=1,2
12546  100          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
12547      &               MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12548      &        DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12549      &        RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12550      &        RHOSPN(P3,P3P,JDASPN(2,IDEC))
12551 C--second particle
12552             ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12553               DO 105 P0 =1,2
12554               DO 105 P0P=1,2
12555               DO 105 P1 =1,2
12556               DO 105 P1P=1,2
12557               DO 105 P2 =1,2
12558               DO 105 P2P=1,2
12559               DO 105 P3 =1,2
12560               DO 105 P3P=1,2
12561  105          RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
12562      &               MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12563      &        DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12564      &        RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12565      &        RHOSPN(P3,P3P,JDASPN(2,IDEC))
12566 C--third particle
12567             ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12568               DO 110 P0 =1,2
12569               DO 110 P0P=1,2
12570               DO 110 P1 =1,2
12571               DO 110 P1P=1,2
12572               DO 110 P2 =1,2
12573               DO 110 P2P=1,2
12574               DO 110 P3 =1,2
12575               DO 110 P3P=1,2
12576  110          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+RHOSPN(P0,P0P,IDEC)*
12577      &               MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12578      &        DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12579      &        RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12580      &        RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)
12581 C--unrecognized
12582             ELSE
12583               CALL HWWARN('HWDSI1',102)
12584               GOTO 999
12585             ENDIF
12586           ELSEIF(NPR.EQ.4) THEN
12587 C--first particle
12588             IF(IP.EQ.JDASPN(1,IDEC)) THEN
12589               DO 151 P1 =1,2
12590               DO 151 P1P=1,2
12591               RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12592               DO 151 P2 =1,2
12593               DO 151 P2P=1,2
12594               DO 151 P3 =1,2
12595               DO 151 P3P=1,2
12596               DO 151 P4 =1,2
12597               DO 151 P4P=1,2
12598  151          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12599      &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12600      &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12601      &           RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12602      &           RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12603      &           RHOSPN(P4,P4P,JDASPN(2,IDEC))
12604 C--second particle
12605             ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12606               DO 152 P2 =1,2
12607               DO 152 P2P=1,2
12608               RHOSPN(P2,P2P,IP) = (0.0D0,0.0D0)
12609               DO 152 P1 =1,2
12610               DO 152 P1P=1,2
12611               DO 152 P3 =1,2
12612               DO 152 P3P=1,2
12613               DO 152 P4 =1,2
12614               DO 152 P4P=1,2
12615  152             RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+
12616      &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12617      &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12618      &           RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12619      &           RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12620      &           RHOSPN(P4,P4P,JDASPN(2,IDEC))
12621 C--third particle
12622             ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
12623               DO 153 P3 =1,2
12624               DO 153 P3P=1,2
12625               RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12626               DO 153 P1 =1,2
12627               DO 153 P1P=1,2
12628               DO 153 P2 =1,2
12629               DO 153 P2P=1,2
12630               DO 153 P4 =1,2
12631               DO 153 P4P=1,2
12632  153          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12633      &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12634      &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12635      &           RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12636      &           RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12637      &           RHOSPN(P4,P4P,JDASPN(2,IDEC))
12638 C--fourth particle
12639             ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12640               DO 154 P4 =1,2
12641               DO 154 P4P=1,2
12642               RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12643               DO 154 P1 =1,2
12644               DO 154 P1P=1,2
12645               DO 154 P2 =1,2
12646               DO 154 P2P=1,2
12647               DO 154 P3 =1,2
12648               DO 154 P3P=1,2
12649  154          RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+
12650      &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12651      &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12652      &           RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12653      &           RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12654      &           RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
12655             ELSE
12656               CALL HWWARN('HWDSI1',505)
12657             ENDIF
12658           ELSE
12659             CALL HWWARN('HWDSI1',506)
12660           ENDIF
12661         ENDIF
12662 C--normalise the spin density matrix
12663         NORM = DBLE(RHOSPN(1,1,IP))+DBLE(RHOSPN(2,2,IP))
12664         IF(NORM.GT.ZERO) THEN
12665           NORM = ONE/NORM
12666           DO 15 P3=1,2
12667           DO 15 P3P=1,2
12668  15       RHOSPN(P3,P3P,IP) = NORM*RHOSPN(P3,P3P,IP)
12669         ELSE
12670           CALL HWWARN('HWDSI1',107)
12671           GOTO 999
12672         ENDIF
12673       ENDIF
12674  999  RETURN
12675       END
12676 CDECK  ID>, HWDSI2.
12677 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
12678 *-- Author :    Peter Richardson
12679 C-----------------------------------------------------------------------
12680       SUBROUTINE HWDSI2(IHEP,IM,NPR,MHEP,KHEP,PW)
12681 C-----------------------------------------------------------------------
12682 C   Subroutine to perform the second part of the heavy object decays
12683 C   IE generate the kinematics for the decay
12684 C   including spin correlations
12685 C   was part of HWDHOB
12686 C-----------------------------------------------------------------------
12687       INCLUDE 'herwig65.inc'
12688       DOUBLE PRECISION HWRGEN,PW(5),HWDPWT,HWDWWT,PCM,HWUPCM
12689       INTEGER IHEP,IM,KHEP,MHEP,NPR,ISN,RHEP
12690       EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWUPCM
12691       IF (IERROR.NE.0) RETURN
12692       ISN = ISNHEP(IHEP)
12693       IF (NPR.EQ.2) THEN
12694 C Two body decay: LHEP -> MHEP + NHEP
12695         IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
12696 C--generate a two body decay to a gauge boson as a three body decay
12697           CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,
12698      &                 RHOSPN(1,1,ISN),ISN)
12699 C--two body decay
12700         ELSEIF(NME(IM).GT.30000.AND.NME(IM).LT.40000) THEN
12701           CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,
12702      &          RHOSPN(1,1,ISN),ISN)
12703 C--otherwise issue warning
12704 C--change by PR 9/30/02 to issue non-terminal warning and continue
12705         ELSE
12706           CALL HWWARN('HWDSI2',1)
12707           PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
12708           CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
12709      &                PHEP(1,NHEP),PCM,TWO,.FALSE.)
12710           DECSPN(ISN) = .TRUE.
12711           IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12712             RHOSPN(1,1,ISN) = ONE
12713             RHOSPN(1,2,ISN) = ZERO
12714             RHOSPN(2,1,ISN) = ZERO
12715             RHOSPN(2,2,ISN) = ZERO
12716           ELSE
12717             RHOSPN(1,1,ISN) = HALF
12718             RHOSPN(1,2,ISN) = ZERO
12719             RHOSPN(2,1,ISN) = ZERO
12720             RHOSPN(2,2,ISN) = HALF
12721           ENDIF
12722         ENDIF
12723       ELSEIF (NPR.EQ.3) THEN
12724 C Three body decay: LHEP -> KHEP + MHEP + NHEP
12725         KHEP=MHEP
12726         MHEP=MHEP+1
12727 C Provisional colour self-connection of KHEP
12728         JMOHEP(2,KHEP)=KHEP
12729         JDAHEP(2,KHEP)=KHEP
12730 C--if old codes issue warning
12731         IF (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.NME(IM).EQ.300) THEN
12732           CALL HWWARN('HWDSI2',502)
12733 C--three body spin matrix element
12734         ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
12735           CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
12736      &            RHOSPN(1,1,ISN),ISN)
12737 C--special for top decay
12738           IF(ABS(IDHEP(IHEP)).EQ.6) THEN
12739             CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
12740             CALL HWUMAS(PW)
12741           ENDIF
12742 C--unknown issue warning
12743         ELSE
12744           CALL HWWARN('HWDSI2',2)
12745 C Three body phase space decay
12746           CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
12747      &                PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
12748           CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
12749           DECSPN(ISN) = .TRUE.
12750           IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12751             RHOSPN(1,1,ISN) = ONE
12752             RHOSPN(1,2,ISN) = ZERO
12753             RHOSPN(2,1,ISN) = ZERO
12754             RHOSPN(2,2,ISN) = ZERO
12755           ELSE
12756             RHOSPN(1,1,ISN) = HALF
12757             RHOSPN(1,2,ISN) = ZERO
12758             RHOSPN(2,1,ISN) = ZERO
12759             RHOSPN(2,2,ISN) = HALF
12760           ENDIF
12761         ENDIF
12762       ELSEIF(NPR.EQ.4) THEN
12763         CALL HWWARN('HWDSI2',3)
12764 C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
12765         KHEP = MHEP
12766         RHEP = MHEP+1
12767         MHEP = MHEP+2
12768         ISTHEP(NHEP) = 114
12769 C Provisional colour connections of KHEP and RHEP
12770         JMOHEP(2,KHEP)=RHEP
12771         JDAHEP(2,KHEP)=RHEP
12772         JMOHEP(2,RHEP)=KHEP
12773         JDAHEP(2,RHEP)=KHEP
12774 C Four body phase space decay
12775         CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
12776      &                PHEP(1,MHEP),PHEP(1,NHEP))
12777         IF(IERROR.NE.0) RETURN
12778         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
12779         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
12780         DECSPN(ISN) = .TRUE.
12781         IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12782           RHOSPN(1,1,ISN) = ONE
12783           RHOSPN(1,2,ISN) = ZERO
12784           RHOSPN(2,1,ISN) = ZERO
12785           RHOSPN(2,2,ISN) = ZERO
12786         ELSE
12787           RHOSPN(1,1,ISN) = HALF
12788           RHOSPN(1,2,ISN) = ZERO
12789           RHOSPN(2,1,ISN) = ZERO
12790           RHOSPN(2,2,ISN) = HALF
12791         ENDIF
12792       ELSE
12793         CALL HWWARN('HWDSI2',100)
12794       ENDIF
12795       END
12796 CDECK  ID>, HWDSI3.
12797 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
12798 *-- Author :    Peter Richardson
12799 C-----------------------------------------------------------------------
12800       SUBROUTINE HWDSI3(IP)
12801 C-----------------------------------------------------------------------
12802 C     Subroutine to handle spin correlations in tau decays
12803 C     averages spin if not using TAUOLA
12804 C     if using TAUOLA selects the spin and uses TAUOLA to perform the
12805 C     decay
12806 C-----------------------------------------------------------------------
12807       INCLUDE 'herwig65.inc'
12808       INTEGER IP,IHEP,ID1,ID,NTRY
12809       DOUBLE PRECISION PPOL,HWRGEN,POL
12810       EXTERNAL HWRGEN
12811 C--if HERWIG is performing tau decays average over spins and return
12812 C--spin averaged tau decay will be done later
12813       IF(TAUDEC.EQ.'HERWIG') THEN
12814         DECSPN(IP) = .TRUE.
12815         RHOSPN(1,1,IP) = HALF
12816         RHOSPN(2,1,IP) = ZERO
12817         RHOSPN(1,2,IP) = ZERO
12818         RHOSPN(2,2,IP) = HALF
12819 C--if using tauola select the polarization for the decay
12820       ELSEIF(TAUDEC.EQ.'TAUOLA') THEN
12821 C--work out where that particle is
12822         IHEP = IDSPN(IP)
12823         NTRY = 0
12824  10     ID   = IDHW(IHEP)
12825         IF(JDAHEP(1,IHEP).NE.0) THEN
12826           IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
12827             DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
12828               IF(IDHW(ID1).EQ.ID) IHEP=ID1
12829             ENDDO
12830           ELSE
12831             IHEP = JDAHEP(1,IHEP)
12832           ENDIF
12833           NTRY = NTRY+1
12834           IF(NTRY.LT.NBTRY) THEN
12835             GOTO 10
12836           ELSE
12837             CALL HWWARN('HWDSI3',100)
12838             GOTO 999
12839           ENDIF
12840         ENDIF
12841 C--select the tau polarization
12842         PPOL = DBLE(RHOSPN(1,1,IP))
12843         IF(PPOL.GE.HWRGEN(0)) THEN
12844           POL = 1.0D0
12845           RHOSPN(1,1,IP) =  ONE
12846           RHOSPN(2,1,IP) = ZERO
12847           RHOSPN(1,2,IP) = ZERO
12848           RHOSPN(2,2,IP) = ZERO
12849         ELSE
12850           POL =-1.0D0
12851           RHOSPN(1,1,IP) = ZERO
12852           RHOSPN(2,1,IP) = ZERO
12853           RHOSPN(1,2,IP) = ZERO
12854           RHOSPN(2,2,IP) =  ONE
12855         ENDIF
12856 C--decay the particle
12857         CALL HWDTAU(1,IHEP,POL)
12858         DECSPN(IP) = .TRUE.
12859       ELSE
12860         CALL HWWARN('HWDSI3',500)
12861       ENDIF
12862  999  RETURN
12863       END
12864 CDECK  ID>, HWDSM2.
12865 *CMZ :-        -09/04/02  13:46:07  by  Peter Richardson
12866 *-- Author :    Peter Richardson
12867 C-----------------------------------------------------------------------
12868       SUBROUTINE HWDSM2(ID,IOUT1,IOUT2,IMODE,RHOIN,IDSPIN)
12869 C-----------------------------------------------------------------------
12870 C  Subroutine to calculate the two body matrix element for spin
12871 C  correlations
12872 C-----------------------------------------------------------------------
12873       INCLUDE 'herwig65.inc'
12874       INTEGER IOUT1,IOUT2,IMODE,IDSPIN,ID,I,J,IDP(3),P0,P1,P2,O(2),P0P,
12875      &     NTRY
12876       DOUBLE PRECISION XMASS,PLAB,PRW,PCM,PREF(5),P(5,3),PM(5,3),PCMA,
12877      &     HWUPCM,MA(3),MA2(3),HWULDO,PP,HWVDOT,N(3),EPS,PRE,PHS,A(2),
12878      &     WGT,WTMAX,HWRGEN
12879       DOUBLE COMPLEX RHOIN(2,2),S,D,ME(2,2,2),F1(2,2,8),F0(2,2,8),
12880      &     F2M(2,2,8),F1M(2,2,8),F1F(2,2,8),F2(2,2,8,8),F0B(2,2,8,8)
12881       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
12882       SAVE O,PREF
12883       DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
12884       DATA O/2,1/
12885       COMMON/HWHEWS/S(8,8,2),D(8,8)
12886       PARAMETER(EPS=1D-20)
12887       EXTERNAL HWUPCM,HWULDO,HWVDOT,HWRGEN
12888 C--first setup if this is the start of a new spin chain
12889       IF(NSPN.EQ.0) THEN
12890 C--zero the elements of the array
12891         CALL HWVZRI(  NMXHEP,ISNHEP)
12892         CALL HWVZRI(  NMXSPN,JMOSPN)
12893         CALL HWVZRI(2*NMXSPN,JDASPN)
12894         CALL HWVZRI(  NMXSPN, IDSPN)
12895         NSPN = NSPN+1
12896         JMOSPN(NSPN) = 0
12897         IDSPN (NSPN) = ID
12898         DECSPN(NSPN) = .FALSE.
12899         IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
12900           RHOSPN(1,1,NSPN) = ONE
12901           RHOSPN(2,1,NSPN) = ZERO
12902           RHOSPN(1,2,NSPN) = ZERO
12903           RHOSPN(2,2,NSPN) = ZERO
12904         ELSE
12905           RHOSPN(1,1,NSPN) = HALF
12906           RHOSPN(2,1,NSPN) = ZERO
12907           RHOSPN(1,2,NSPN) = ZERO
12908           RHOSPN(2,2,NSPN) = HALF
12909         ENDIF
12910         ISNHEP(ID)    = NSPN
12911       ENDIF
12912 C--MA is mass for this decay (OFF-SHELL)
12913 C--generate the momenta for a two body decay
12914       P(5,1) = PHEP(5,   ID)
12915       P(5,2) = PHEP(5,IOUT1)
12916       P(5,3) = PHEP(5,IOUT2)
12917       IDP(1) = IDHW(ID)
12918       IDP(2) = IDHW(IOUT1)
12919       IDP(3) = IDHW(IOUT2)
12920       DO 1 I=1,3
12921       MA(I)  = P(5,I)
12922  1    MA2(I) = MA(I)**2
12923       PCMA   = HWUPCM(P(5,1),P(5,2),P(5,3))
12924 C--setup the couplings
12925       DO 2 I=1,2
12926  2    A(I) = A2MODE(I,IMODE)
12927 C--phase space factor
12928       PHS = PCMA/MA2(1)/8.0D0/PIFAC
12929 C--maximum weight
12930       WTMAX = WT2MAX(IMODE)
12931       NTRY = 0
12932  1000 NTRY = NTRY+1
12933       CALL HWVEQU(5,PHEP(1,ID),P(1,1))
12934       CALL HWDTWO(P(1,1),P(1,2),P(1,3),PCMA,2.0D0,.TRUE.)
12935       DO 3 I=1,3
12936 C--compute the references vectors
12937 C--not important if SM particle which can't have spin measured
12938 C--ie anything other the top and tau
12939 C--also not important if particle is approx massless
12940 C--first the SM particles other than top and tau
12941       IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
12942      &                .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
12943         CALL HWVEQU(5,PREF,PLAB(1,I+3))
12944 C--all other particles
12945       ELSE
12946         PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
12947         CALL HWVSCA(3,ONE/PP,P(1,I),N)
12948         PLAB(4,I+3) = HALF*(P(4,I)-PP)
12949         PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
12950         CALL HWVSCA(3,PP,N,PLAB(1,I+3))
12951         CALL HWUMAS(PLAB(1,I+3))
12952         PP = HWVDOT(3,PLAB(1,I+3),PLAB(1,I+3))
12953 C--fix to avoid problems if approx massless due to energy
12954         IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+3))
12955       ENDIF
12956 C--now the massless vectors
12957       PP = HALF*P(5,I)**2/HWULDO(PLAB(1,I+3),P(1,I))
12958       DO 4 J=1,4
12959  4    PLAB(J,I) = P(J,I)-PP*PLAB(J,I+3)
12960  3    CALL HWUMAS(PLAB(1,I))
12961 C--change order of momenta for call to HE code
12962       DO 5 I=1,3
12963       PM(1,I) = P(3,I)
12964       PM(2,I) = P(1,I)
12965       PM(3,I) = P(2,I)
12966       PM(4,I) = P(4,I)
12967  5    PM(5,I) = P(5,I)
12968       DO 6 I=1,6
12969       PCM(1,I)=PLAB(3,I)
12970       PCM(2,I)=PLAB(1,I)
12971       PCM(3,I)=PLAB(2,I)
12972       PCM(4,I)=PLAB(4,I)
12973  6    PCM(5,I)=PLAB(5,I)
12974 C--compute the S functions
12975       CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
12976       DO 7 I=1,6
12977       DO 7 J=1,6
12978       S(I,J,2) = -S(I,J,2)
12979  7    D(I,J)   = TWO*D(I,J)
12980 C--now compute the F functions needed
12981       CALL HWH2F2(6,F1 ,5,PM(1,2), MA(2))
12982       CALL HWH2F2(6,F0 ,4,PM(1,1), MA(1))
12983       CALL HWH2F2(6,F1M,5,PM(1,2),-MA(2))
12984       CALL HWH2F2(6,F2M,6,PM(1,3),-MA(3))
12985       CALL HWH2F1(6,F1F,5,PM(1,2), MA(2))
12986       CALL HWH2F3(6,F2   ,PM(1,3),ZERO  )
12987       CALL HWH2F3(6,F0B  ,PM(1,1),ZERO  )
12988 C--now compute the diagrams
12989 C--fermion --> fermion scalar
12990       IF(I2DRTP(IMODE).EQ.1) THEN
12991         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
12992         PRE = HALF/SQRT(PRE)
12993         DO 10 P0=1,2
12994         DO 10 P1=1,2
12995         ME(P0,P1,2) = (0.0D0,0.0D0)
12996  10     ME(P0,P1,1) = PRE*( A(O(P1))*S(5,2,O(P1))*F0(  P1 ,O(P0),2)
12997      &                     +A(  P1 )*MA(2)*       F0(O(P1),O(P0),5))
12998 C--fermion --> scalar fermion   diagrams
12999       ELSEIF(I2DRTP(IMODE).EQ.2) THEN
13000         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
13001         PRE = HALF/SQRT(PRE)
13002         DO 20 P0=1,2
13003         DO 20 P2=1,2
13004         ME(P0,2,P2) = (0.0D0,0.0D0)
13005  20     ME(P0,1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F0(  P2 ,O(P0),3)
13006      &                     +A(  P2 )*MA(3)*       F0(O(P2),O(P0),6))
13007 C--fermion --> scalar antifermion
13008       ELSEIF(I2DRTP(IMODE).EQ.3) THEN
13009         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
13010         PRE =-HALF/SQRT(PRE)
13011         DO 30 P0=1,2
13012         DO 30 P2=1,2
13013         ME(P0,2,P2) = (0.0D0,0.0D0)
13014  30     ME(P0,1,P2) = PRE*( A(  P0 )*S(4,1,P0)*F2M(O(P0),O(P2),1)
13015      &                     -A(O(P0))*MA(1)    *F2M(  P0 ,O(P2),4))
13016 C--fermion --> fermion gauge boson
13017       ELSEIF(I2DRTP(IMODE).EQ.4) THEN
13018         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))*
13019      &        HWULDO(PM(1,3),PCM(1,6))
13020         PRE = HALF/SQRT(PRE)
13021         DO 40 P0=1,2
13022         DO 40 P1=1,2
13023         ME(P0,P1,1) =-PRE*A(1)*F1F(O(P1),2,3)*S(3,6,2)*F0(1,O(P0),3)
13024  40     ME(P0,P1,2) = PRE*     F1F(O(P1),1,3)*S(3,6,1)*F0(2,O(P0),3)
13025 C--scalar  --> fermion antifermion
13026       ELSEIF(I2DRTP(IMODE).EQ.5) THEN
13027         PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
13028         PRE =-HALF/SQRT(PRE)
13029         DO 50 P1=1,2
13030         DO 50 P2=1,2
13031         ME(2,P1,P2) = (0.0D0,0.0D0)
13032  50     ME(1,P1,P2) = PRE*( A(O(P1))*S(5,2,O(P1))*F2M(  P1 ,O(P2),2)
13033      &                     +A(  P1 )*MA(2)*       F2M(O(P1),O(P2),5))
13034 C--scalar --> fermion fermion
13035       ELSEIF(I2DRTP(IMODE).EQ.6) THEN
13036         PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
13037         PRE = HALF/SQRT(PRE)
13038         DO 60 P1=1,2
13039         DO 60 P2=1,2
13040         ME(2,P1,P2) = (0.0D0,0.0D0)
13041  60     ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M(  P2 ,P1,3)
13042      &                     +A(  P2 )*MA(3)*       F1M(O(P2),P1,6))
13043 C--fermion --> fermion pion
13044       ELSEIF(I2DRTP(IMODE).EQ.7) THEN
13045         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
13046         PRE = 0.25D0/SQRT(PRE)/RMASS(198)**2
13047         DO 70 P0=1,2
13048         DO 70 P1=1,2
13049         ME(P0,P1,2) = (0.0D0,0.0D0)
13050  70     ME(P0,P1,1) =PRE*(
13051      &              MA(1)*A(O(P0))*( S(5,2,O(P1))*F2(  P1 ,O(P0),2,4)
13052      &                                     +MA(2)*F2(O(P1),O(P0),5,4))
13053      &            +A(P0)*S(1,4,P0)*( S(5,2,O(P1))*F2(  P1 ,  P0 ,2,1)
13054      &                                     +MA(2)*F2(O(P1),  P0 ,5,1)))
13055 C--scalar  --> antifermion fermion
13056       ELSEIF(I2DRTP(IMODE).EQ.8) THEN
13057         PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
13058         PRE =-HALF/SQRT(PRE)
13059         DO 80 P1=1,2
13060         DO 80 P2=1,2
13061         ME(2,P1,P2) = (0.0D0,0.0D0)
13062  80     ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M(  P2 ,O(P1),3)
13063      &                     +A(  P2 )*MA(3)*       F1M(O(P2),O(P1),6))
13064 C--neutralino --> gravitino photon
13065       ELSEIF(I2DRTP(IMODE).EQ.9) THEN
13066         PRE = TWO*HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
13067         PRE = TWO/SQRT(PRE)
13068         DO 90 P1=1,2
13069         DO 90 P2=1,2
13070         ME(P1,P2,O(P2)) = (0.0D0,0.0D0)
13071  90     ME(P1,P2,  P2 ) = PRE*S(2,3,P2)*S(3,6,O(P2))*
13072      &       S(3,2,P2)*F0(O(P2),P1,2)
13073 C--neutralino --> gravitino scalar
13074       ELSEIF(I2DRTP(IMODE).EQ.10) THEN
13075         PRE = TWO*HWULDO(PM(1,1),PCM(1,4))
13076         PRE = ONE/SQRT(PRE)
13077         DO 100 P1=1,2
13078         DO 100 P2=1,2
13079         ME(P1,P2,2) = (0.0D0,0.0D0)
13080  100    ME(P1,P2,1) = PRE*F2(P2,1,2,2)*F0(1,O(P1),2)
13081 C--sfermion --> fermion gravitino
13082       ELSEIF(I2DRTP(IMODE).EQ.11) THEN
13083         PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
13084         PRE = ONE/SQRT(PRE)
13085         DO 110 P1=1,2
13086         DO 110 P2=1,2
13087         ME(2,P1,P2) = (0.0D0,0.0D0)
13088  110    ME(1,P1,P2) = PRE*A(O(P2))*F1M(O(P1),P2,3)*F0B(P2,P2,3,3)
13089 C--antisfermion --> antifermion gravitino
13090       ELSEIF(I2DRTP(IMODE).EQ.12) THEN
13091         PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
13092         PRE = ONE/SQRT(PRE)
13093         DO 120 P1=1,2
13094         DO 120 P2=1,2
13095         ME(2,P1,P2) = (0.0D0,0.0D0)
13096  120    ME(1,P1,P2) = PRE*A(O(P2))*F0B(P2,P2,3,3)*F1(P2,O(P1),3)
13097 C--scalar --> antifermion antifermion
13098       ELSEIF(I2DRTP(IMODE).EQ.13) THEN
13099         PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
13100         PRE = HALF/SQRT(PRE)
13101         DO 130 P1=1,2
13102         DO 130 P2=1,2
13103         ME(2,P1,P2) = (0.0D0,0.0D0)
13104  130    ME(1,P1,P2) = PRE*( A(  P1 )*S(5,2,  P1 )*F2M(O(P1),O(P2),2)
13105      &                     +A(O(P1))*MA(2)       *F2M(  P1 ,O(P2),5))
13106 C--antifermion --> scalar antifermion
13107       ELSEIF(I2DRTP(IMODE).EQ.14) THEN
13108         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
13109         PRE = HALF/SQRT(PRE)
13110         DO 140 P0=1,2
13111         DO 140 P2=1,2
13112         ME(P0,2,P2) = (0.0D0,0.0D0)
13113  140    ME(P0,1,P2) = PRE*( A(O(P0))*S(4,1,O(P0))*F2M(  P0 ,O(P2),1)
13114      &                     -A(  P0 )*MA(1)       *F2M(O(P0),O(P2),4))
13115 C--unrecognized type of diagram
13116       ELSE
13117         CALL HWWARN('HWDSM2',500)
13118       ENDIF
13119 C--now compute the weight
13120       WGT = ZERO
13121       DO 500 P0 =1,2
13122       DO 500 P0P=1,2
13123       DO 500 P1 =1,2
13124       DO 500 P2 =1,2
13125  500  WGT = WGT+PHS*P2MODE(IMODE)*DREAL(
13126      &       ME(P0,P1,P2)*DCONJG(ME(P0P,P1,P2))*RHOIN(P0,P0P))
13127       IF(I2DRTP(IMODE).EQ.5.OR.I2DRTP(IMODE).EQ.6.OR.
13128      &   I2DRTP(IMODE).EQ.8.OR.I2DRTP(IMODE).EQ.13) GOTO 300
13129 C--issue warning if greater than maximum
13130       IF(WGT.GT.WTMAX) THEN
13131         CALL HWWARN('HWDSM2',1)
13132         WRITE(6,2000) RNAME(IDK(ID2PRT(IMODE))),
13133      &   RNAME(IDKPRD(1,ID2PRT(IMODE))),RNAME(IDKPRD(2,ID2PRT(IMODE))),
13134      &   WTMAX,1.1D0*WGT
13135         WT2MAX(IMODE) = 1.1D0*WGT
13136         WTMAX         = WT2MAX(IMODE)
13137       ENDIF
13138       IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 1000
13139       IF(NTRY.GE.NSNTRY) THEN
13140         CALL HWWARN('HWDSM2',100)
13141         GOTO 999
13142       ENDIF
13143 C--now enter the momenta in the common block
13144  300  CALL HWVEQU(5,P(1,2),PHEP(1,IOUT1))
13145       CALL HWVEQU(5,P(1,3),PHEP(1,IOUT2))
13146 C--set up the spin information
13147 C--setup for all decays
13148       JMOSPN(NSPN+1) = IDSPIN
13149       JMOSPN(NSPN+2) = IDSPIN
13150       JDASPN(1,IDSPIN) = NSPN+1
13151       JDASPN(2,IDSPIN) = NSPN+2
13152       IDSPN(NSPN+1) = IOUT1
13153       IDSPN(NSPN+2) = IOUT2
13154       DO 11 I=1,2
13155       DECSPN(NSPN+I) = .FALSE.
13156       DO 11 J=1,2
13157  11   JDASPN(I,NSPN+J) = 0
13158       ISNHEP(IOUT1) = NSPN+1
13159       ISNHEP(IOUT2) = NSPN+2
13160       DO 12 I=1,2
13161         IF(RSPIN(IDHW(IDSPN(NSPN+I))).EQ.ZERO) THEN
13162           RHOSPN(1,1,NSPN+I) = ONE
13163           RHOSPN(2,1,NSPN+I) = ZERO
13164           RHOSPN(1,2,NSPN+I) = ZERO
13165           RHOSPN(2,2,NSPN+I) = ZERO
13166         ELSE
13167           RHOSPN(1,1,NSPN+I) = HALF
13168           RHOSPN(2,1,NSPN+I) = ZERO
13169           RHOSPN(1,2,NSPN+I) = ZERO
13170           RHOSPN(2,2,NSPN+I) = HALF
13171         ENDIF
13172  12   CONTINUE
13173       NSPN = NSPN+2
13174 C--now enter the matrix element
13175       DO 150 P0=1,2
13176       DO 150 P1=1,2
13177       DO 150 P2=1,2
13178       MESPN(P0,P1,P2,2,1,IDSPIN) = (0.0D0,0.0D0)
13179  150  MESPN(P0,P1,P2,1,1,IDSPIN) = ME(P0,P1,P2)
13180       SPNCFC(1,1,IDSPIN) = ONE
13181       NCFL(IDSPIN) = 1
13182       RETURN
13183 C--format statements
13184  2000 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8, 'EXCEEDS MAX',
13185      &       /10X,'    MAXIMUM WEIGHT =',1PG24.16,
13186      &       /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
13187  999  RETURN
13188       END
13189 CDECK  ID>, HWDSM3.
13190 *CMZ :-        -09/04/02  13:46:07  by  Peter Richardson
13191 *-- Author :    Peter Richardson
13192 C-----------------------------------------------------------------------
13193       SUBROUTINE HWDSM3(NPR,ID,IOUT1,IOUT2,IOUT3,IMODE,RHOIN,IDSPIN)
13194 C-----------------------------------------------------------------------
13195 C     Master subroutine for three body SUSY and spin ME's
13196 C     Uses HWD3ME to generate the momenta etc
13197 C-----------------------------------------------------------------------
13198       INCLUDE 'herwig65.inc'
13199       DOUBLE COMPLEX F0(2,2,8),F1(2,2,8),F1M(2,2,8),F3(2,2,8),
13200      &     F0M(2,2,8),F2(2,2,8),RHOIN(2,2),F01(2,2,8,8)
13201       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
13202      &  P(5,4),PZ(5),HWRGEN,CV,CA,BR,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
13203       INTEGER ID,IDP(4+NDIAGR),NPR,ITYPE,I,IB,ID1,ID2,IDSPIN,
13204      &     DRTYPE(NDIAGR),IOUT(3),IMODE,IOUT1,IOUT2,IOUT3,J,NCTHRE,
13205      &     DRCF(NDIAGR)
13206       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
13207      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
13208      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
13209       EXTERNAL HWRGEN
13210       SAVE PZ,IOUT,ITYPE,ID1,ID2
13211 C--calculate the matrix element for a three body decay
13212       IF(NPR.EQ.3) THEN
13213 C--set up the decay products, if a SUSY decay the SUSY particle
13214 C--must be the first decay product
13215         IF(ABS(IDHEP(IOUT1)).GT.1000000) THEN
13216           IOUT(1) = IOUT1
13217           IOUT(2) = IOUT2
13218           IOUT(3) = IOUT3
13219         ELSEIF(ABS(IDHEP(IOUT2)).GT.1000000) THEN
13220           IOUT(1) = IOUT2
13221           IOUT(2) = IOUT1
13222           IOUT(3) = IOUT3
13223         ELSEIF(ABS(IDHEP(IOUT3)).GT.1000000) THEN
13224           IOUT(1) = IOUT3
13225           IOUT(2) = IOUT1
13226           IOUT(3) = IOUT3
13227 C--special for top decay (bottom must be first)
13228         ELSEIF(ABS(IDHEP(ID)).EQ.6) THEN
13229           IOUT(1) = IOUT3
13230           IOUT(2) = IOUT1
13231           IOUT(3) = IOUT2
13232         ELSE
13233           IOUT(1) = IOUT2
13234           IOUT(2) = IOUT1
13235           IOUT(3) = IOUT3
13236         ENDIF
13237 C--fermion must be second and antifermion third
13238         IF(IDHEP(IOUT(2)).LT.0.AND.
13239      &    (ABS(IDHEP(IOUT(1))).GT.1000000.OR.ABS(IDHEP(ID)).EQ.6)) THEN
13240           I = IOUT(2)
13241           IOUT(2) = IOUT(3)
13242           IOUT(3) = I
13243         ENDIF
13244 C--setup the OFF SHELL MASSES
13245         MA(1) = PHEP(5,ID)
13246         DO 1 I=1,3
13247  1      MA(I+1) = PHEP(5,IOUT(I))
13248         DO 2 I=1,4
13249  2      MA2(I) = MA(I)**2
13250 C--call to ME code
13251         CALL HWD3ME(ID,0,IMODE,RHOIN,IDSPIN)
13252         IF(IERROR.NE.0) RETURN
13253 C--juggle the momenta for the RPV BV gluino if needed
13254         IF(SPCOPT.EQ.2.AND.N3NCFL(IMODE).EQ.3) THEN
13255           IF(NCFL(IDSPIN).EQ.2) THEN
13256             IOUT(1) = IOUT1
13257             IOUT(2) = IOUT2
13258             IOUT(3) = IOUT3
13259           ELSEIF(NCFL(IDSPIN).EQ.3) THEN
13260             IOUT(1) = IOUT3
13261             IOUT(2) = IOUT2
13262             IOUT(3) = IOUT1
13263           ENDIF
13264           DO I=1,3
13265             IDHW(IOUT(I)) = IDP(I+1)
13266           ENDDO
13267         ENDIF
13268 C--copy momenta into event record
13269         DO 3 I=1,3
13270  3      CALL HWVEQU(5,P(1,1+I),PHEP(1,IOUT(I)))
13271 C--enter the spin information in the common block
13272         IF(SYSPIN) THEN
13273 C--set up if start of new spin chain
13274           IF(NSPN.EQ.0) THEN
13275 C--zero the elements
13276             CALL HWVZRI(  NMXHEP,ISNHEP)
13277             CALL HWVZRI(  NMXSPN,JMOSPN)
13278             CALL HWVZRI(2*NMXSPN,JDASPN)
13279             CALL HWVZRI(  NMXSPN, IDSPN)
13280             NSPN = NSPN+1
13281             JMOSPN(NSPN) = 0
13282             IDSPN (NSPN) = ID
13283             DECSPN(NSPN) = .FALSE.
13284 C--set up spin density matrix for particle
13285             IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
13286               RHOSPN(1,1,NSPN) = ONE
13287               RHOSPN(2,1,NSPN) = ZERO
13288               RHOSPN(1,2,NSPN) = ZERO
13289               RHOSPN(2,2,NSPN) = ZERO
13290             ELSE
13291               RHOSPN(1,1,NSPN) = HALF
13292               RHOSPN(2,1,NSPN) = ZERO
13293               RHOSPN(1,2,NSPN) = ZERO
13294               RHOSPN(2,2,NSPN) = HALF
13295             ENDIF
13296             ISNHEP(ID)    = NSPN
13297           ENDIF
13298 C--enter the decay products
13299           JDASPN(1,IDSPIN) = NSPN+1
13300           JDASPN(2,IDSPIN) = NSPN+3
13301           DO 7 I=1,3
13302           JMOSPN(NSPN+I  ) = IDSPIN
13303           IDSPN (NSPN+I  ) = IOUT(I)
13304           DECSPN(NSPN+I  ) = .FALSE.
13305           ISNHEP(IOUT(I) ) = NSPN+I
13306           IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
13307             RHOSPN(1,1,NSPN+I) = ONE
13308             RHOSPN(2,1,NSPN+I) = ZERO
13309             RHOSPN(1,2,NSPN+I) = ZERO
13310             RHOSPN(2,2,NSPN+I) = ZERO
13311           ELSE
13312             RHOSPN(1,1,NSPN+I) = HALF
13313             RHOSPN(2,1,NSPN+I) = ZERO
13314             RHOSPN(1,2,NSPN+I) = ZERO
13315             RHOSPN(2,2,NSPN+I) = HALF
13316           ENDIF
13317           DO 7 J=1,2
13318  7        JDASPN(J,NSPN+I) = 0
13319           NSPN = NSPN+3
13320         ENDIF
13321 C--select the decay mode and generate the decay for a two body mode
13322       ELSEIF(NPR.EQ.2) THEN
13323         IF(IDHW(IOUT2).GE.198.AND.IDHW(IOUT2).LE.200) THEN
13324           IB = IDHW(IOUT2)
13325           IOUT(1) = IOUT1
13326           IOUT(2) = IOUT2
13327         ELSEIF(IDHW(IOUT1).GE.198.AND.IDHW(IOUT1).LE.200) THEN
13328           IB = IDHW(IOUT1)
13329           IOUT(1) = IOUT2
13330           IOUT(2) = IOUT1
13331         ELSE
13332           CALL HWWARN('HWDSM3',501)
13333         ENDIF
13334 C--setup the off shell masses and particle ids for me code
13335         MA(1) = PHEP(5,ID)
13336         MA(2) = PHEP(5,IOUT(1))
13337         CALL HWDBOZ(IB,ID1,ID2,CV,CA,BR,0)
13338         ITYPE = ID1
13339         IF(IB.EQ.199) ITYPE = ITYPE+1
13340         IF(ITYPE.GT.120) ITYPE = ITYPE-114
13341         IF(IB.NE.200) ITYPE = ITYPE/2
13342 C--generate momenta of decay products
13343         CALL HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
13344         CALL HWVEQU(5,P(1,2),PHEP(1,IOUT(1)))
13345         CALL HWVSUM(4,P(1,3),P(1,4),PZ)
13346         CALL HWUMAS(PZ)
13347         CALL HWVEQU(5,PZ,PHEP(1,IOUT(2)))
13348 C--enter the spin information in the common block if starting new chain
13349         IF(SYSPIN.AND.NSPN.EQ.0) THEN
13350 C--zero elements of common block
13351           CALL HWVZRI(  NMXHEP,ISNHEP)
13352           CALL HWVZRI(  NMXSPN,JMOSPN)
13353           CALL HWVZRI(2*NMXSPN,JDASPN)
13354           CALL HWVZRI(  NMXSPN, IDSPN)
13355           NSPN = NSPN+1
13356           JMOSPN(NSPN) = 0
13357           IDSPN (NSPN) = ID
13358           DECSPN(NSPN) = .FALSE.
13359           IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
13360             RHOSPN(1,1,NSPN) = ONE
13361             RHOSPN(2,1,NSPN) = ZERO
13362             RHOSPN(1,2,NSPN) = ZERO
13363             RHOSPN(2,2,NSPN) = ZERO
13364           ELSE
13365             RHOSPN(1,1,NSPN) = HALF
13366             RHOSPN(2,1,NSPN) = ZERO
13367             RHOSPN(1,2,NSPN) = ZERO
13368             RHOSPN(2,2,NSPN) = HALF
13369           ENDIF
13370           ISNHEP(ID)    = NSPN
13371         ENDIF
13372         IF(SYSPIN) THEN
13373           IDSPN (NSPN+1  ) = IOUT(1)
13374           ISNHEP(IOUT(1))  = NSPN+1
13375         ENDIF
13376 C--put the boson decay products into the event record for a two body mode
13377       ELSEIF(NPR.EQ.-1) THEN
13378         IOUT(1) = JDAHEP(1,IOUT(2))
13379         IOUT(2) = NHEP+1
13380         IOUT(3) = NHEP+2
13381 C--set up the status of the particles
13382         ISTHEP(IOUT(1)) = 195
13383         JDAHEP(1,IOUT(1)) = NHEP+1
13384         JDAHEP(2,IOUT(1)) = NHEP+2
13385 C--find the ID's of the particles
13386         IF(IDHW(IOUT(1)).EQ.200) THEN
13387           ID1 = ITYPE
13388           IF(ITYPE.GT.6) ID1 = ID1+114
13389           ID2 = ID1+6
13390         ELSE
13391           ID1 = 2*ITYPE-1
13392           IF(ITYPE.GT.3) ID1 = ID1+114
13393           ID2 = ID1+7
13394           IF(IDHW(IOUT(1)).EQ.198) THEN
13395             I   = ID1+6
13396             ID1 = ID2-6
13397             ID2 = I
13398           ENDIF
13399         ENDIF
13400 C--put id's of decay products into the event record
13401         IDHW(NHEP+1)  = ID1
13402         IDHW(NHEP+2)  = ID2
13403         IDHEP(NHEP+1) = IDPDG(ID1)
13404         IDHEP(NHEP+2) = IDPDG(ID2)
13405 C--boost decay products momenta to rest frame of boson
13406         CALL HWULOF(PZ,P(1,3),P(1,3))
13407         CALL HWULOF(PZ,P(1,4),P(1,4))
13408 C--boost back to lab using new boson
13409         CALL HWULOB(PHEP(1,IOUT(1)),P(1,3),PHEP(1,NHEP+1))
13410         CALL HWULOB(PHEP(1,IOUT(1)),P(1,4),PHEP(1,NHEP+2))
13411 C--setup for decay to quarks
13412         IF(ID1.LE.12) THEN
13413           ISTHEP(NHEP+1) = 113
13414           ISTHEP(NHEP+2) = 114
13415           JMOHEP(2,NHEP+1) = NHEP+2
13416           JDAHEP(2,NHEP+1) = NHEP+2
13417           JMOHEP(2,NHEP+2) = NHEP+1
13418           JDAHEP(2,NHEP+2) = NHEP+1
13419           JMOHEP(1,NHEP+1) = IOUT(1)
13420           JMOHEP(1,NHEP+2) = IOUT(1)
13421 C--setup for decay to leptons
13422         ELSE
13423           ISTHEP(NHEP+1) = 193
13424           ISTHEP(NHEP+2) = 193
13425           JMOHEP(1,NHEP+1) = IOUT(1)
13426           JMOHEP(1,NHEP+2) = IOUT(1)
13427           JMOHEP(2,NHEP+1) = JMOHEP(1,IOUT(1))
13428           JMOHEP(2,NHEP+2) = JMOHEP(1,IOUT(1))
13429           JDAHEP(1,NHEP+1) = 0
13430           JDAHEP(1,NHEP+2) = 0
13431           JDAHEP(2,NHEP+1) = 0
13432           JDAHEP(2,NHEP+2) = 0
13433         ENDIF
13434         NHEP=NHEP+2
13435 C--finish entering the spin information in the common block
13436         IF(SYSPIN) THEN
13437           JDASPN(1,IDSPIN) = NSPN+1
13438           JDASPN(2,IDSPIN) = NSPN+3
13439           DO 6 I=1,3
13440           JMOSPN(NSPN+I  ) = IDSPIN
13441           DECSPN(NSPN+I  ) = .FALSE.
13442           IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
13443             RHOSPN(1,1,NSPN+I) = ONE
13444             RHOSPN(2,1,NSPN+I) = ZERO
13445             RHOSPN(1,2,NSPN+I) = ZERO
13446             RHOSPN(2,2,NSPN+I) = ZERO
13447           ELSE
13448             RHOSPN(1,1,NSPN+I) = HALF
13449             RHOSPN(2,1,NSPN+I) = ZERO
13450             RHOSPN(1,2,NSPN+I) = ZERO
13451             RHOSPN(2,2,NSPN+I) = HALF
13452           ENDIF
13453           DO 6 J=1,2
13454  6        JDASPN(J,NSPN+I) =0
13455           NSPN = NSPN+3
13456           IDSPN (NSPN-1) = NHEP-1
13457           IDSPN (NSPN  ) = NHEP
13458           ISNHEP(NHEP-1) = NSPN-1
13459           ISNHEP(NHEP  ) = NSPN
13460         ENDIF
13461 C--perform the parton shower for the decay products of the gauge boson
13462         IF(ID1.LE.12) CALL HWBGEN
13463 C--error issue warning
13464       ELSE
13465         CALL HWWARN('HWDSM3',500)
13466       ENDIF
13467       END
13468 CDECK  ID>, HWDSM4.
13469 *CMZ :-        -11/10/01  14:03:42  by  Peter Richardson
13470 *-- Author :    Peter Richardson
13471 C-----------------------------------------------------------------------
13472       SUBROUTINE HWDSM4(IOPT,ID,IOUT1,IOUT2,IMODE)
13473 C-----------------------------------------------------------------------
13474 C     Subroutine to perform the four body decays
13475 C     IOPT = 1 select decay mode and generate momenta
13476 C     IOPT = 2 enter first decays and perform parton shower
13477 C-----------------------------------------------------------------------
13478       INCLUDE 'herwig65.inc'
13479       INTEGER IOPT,ID,IOUT1,IOUT2,IB(2),I,IDF(4),ITYPE(2),IMODE,
13480      &     IDP(4+NDIAGR),ID1,ID2,J
13481       DOUBLE PRECISION CV,CA,A,B,MS,MWD,MR,M,M2,P(5,5),PW(5,2),BR
13482       COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
13483       SAVE PW,ITYPE
13484 C--generate the decay
13485       IF(IOPT.EQ.1) THEN
13486         IB(1) = IDHW(IOUT1)
13487         IB(2) = IDHW(IOUT2)
13488 C--select the decays of the bosons
13489         DO 1 I=1,2
13490         CALL HWDBOZ(IB(I),IDF(2*I-1),IDF(2*I),CV,CA,BR,1)
13491         ITYPE(I) = IDF(2*I-1)
13492         IF(IB(I).EQ.199) ITYPE(I)    = ITYPE(I)+1
13493         IF(ITYPE(I).GT.120) ITYPE(I) = ITYPE(I)-114
13494  1      IF(IB(I).NE.200) ITYPE(I)    = ITYPE(I)/2
13495 C--generate the momenta of the decay products
13496         CALL HWD4ME(ID,ITYPE(1),ITYPE(2),IMODE)
13497         DO 2 I=1,2
13498         CALL HWVSUM(4,P(1,2*I),P(1,2*I+1),PW(1,I))
13499  2      CALL HWUMAS(PW(1,I))
13500         CALL HWVEQU(5,PW(1,1),PHEP(1,IOUT1))
13501         CALL HWVEQU(5,PW(1,2),PHEP(1,IOUT2))
13502         IF(SYSPIN) THEN
13503           IDSPN(1)     = JDAHEP(1,ID)
13504           DECSPN(1)    = .FALSE.
13505           ISNHEP(JDAHEP(1,ID)) = 1
13506           JDASPN(1,1)  = 2
13507           JDASPN(2,1)  = 5
13508           DO 4 I=2,5
13509           DECSPN(I) = .FALSE.
13510  4        JMOSPN(I) = 1
13511         ENDIF
13512       ELSEIF(IOPT.EQ.2) THEN
13513         IB(1) = JDAHEP(1,IOUT1)
13514         IB(2) = JDAHEP(1,IOUT2)
13515         DO 3 I=1,2
13516           ISTHEP(IB(I)) = 195
13517           JDAHEP(1,IB(I)) = NHEP+1
13518           JDAHEP(2,IB(I)) = NHEP+2
13519 C--find the ID's of the particles
13520           IF(IDHW(IB(I)).EQ.200) THEN
13521             ID1 = ITYPE(I)
13522             IF(ITYPE(I).GT.6) ID1 = ID1+114
13523             ID2 = ID1+6
13524           ELSE
13525             ID1 = 2*ITYPE(I)-1
13526             IF(ITYPE(I).GT.3) ID1 = ID1+114
13527             ID2 = ID1+7
13528             IF(IDHW(IB(I)).EQ.198) THEN
13529               J   = ID1+6
13530               ID1 = ID2-6
13531               ID2 = J
13532             ENDIF
13533           ENDIF
13534 C--put id's of decay products into the event record
13535           IDHW(NHEP+1)  = ID1
13536           IDHW(NHEP+2)  = ID2
13537           IDHEP(NHEP+1) = IDPDG(ID1)
13538           IDHEP(NHEP+2) = IDPDG(ID2)
13539 C--boost decay products momenta to rest frame of boson
13540           CALL HWULOF(PW(1,I),P(1,2*I  ),P(1,2*I  ))
13541           CALL HWULOF(PW(1,I),P(1,2*I+1),P(1,2*I+1))
13542 C--boost back to lab using new boson
13543           CALL HWULOB(PHEP(1,IB(I)),P(1,2*I  ),PHEP(1,NHEP+1))
13544           CALL HWULOB(PHEP(1,IB(I)),P(1,2*I+1),PHEP(1,NHEP+2))
13545 C--setup for decay to quarks
13546           IF(ID1.LE.12) THEN
13547             ISTHEP(NHEP+1) = 113
13548             ISTHEP(NHEP+2) = 114
13549             JMOHEP(2,NHEP+1) = NHEP+2
13550             JDAHEP(2,NHEP+1) = NHEP+2
13551             JMOHEP(2,NHEP+2) = NHEP+1
13552             JDAHEP(2,NHEP+2) = NHEP+1
13553             JMOHEP(1,NHEP+1) = IB(I)
13554             JMOHEP(1,NHEP+2) = IB(I)
13555 C--setup for decay to leptons
13556           ELSE
13557             ISTHEP(NHEP+1) = 193
13558             ISTHEP(NHEP+2) = 193
13559             JMOHEP(1,NHEP+1) = IB(I)
13560             JMOHEP(1,NHEP+2) = IB(I)
13561             JMOHEP(2,NHEP+1) = JMOHEP(1,IB(I))
13562             JMOHEP(2,NHEP+2) = JMOHEP(1,IB(I))
13563           ENDIF
13564 C--enter the information in the spin common block
13565           IF(SYSPIN) THEN
13566             IDSPN(2*I  ) = NHEP+1
13567             IDSPN(2*I+1) = NHEP+2
13568             ISNHEP(NHEP+1) = 2*I
13569             ISNHEP(NHEP+2) = 2*I+1
13570           ENDIF
13571           NHEP=NHEP+2
13572 C--perform the parton shower for the decay products of the gauge boson
13573           IF(ID1.LE.12) CALL HWBGEN
13574  3      CONTINUE
13575       ENDIF
13576       END
13577 CDECK  ID>, HWDTAU.
13578 *CMZ :-        -17/10/01  09:42:21  by  Peter Richardson
13579 *-- Author :    Peter Richardson
13580 C-----------------------------------------------------------------------
13581       SUBROUTINE HWDTAU(IOPT,IHEP,POL)
13582 C-----------------------------------------------------------------------
13583 C     HERWIG-TAUOLA interface to perform tau decays using TAUOLA rather
13584 C     than HERWIG
13585 C     IOPT =-1 initialises
13586 C     IOPT = 1 performs decay
13587 C     IOPT = 2 write outs final TAUOLA information
13588 C-----------------------------------------------------------------------
13589       INCLUDE 'herwig65.inc'
13590       INTEGER IOPT,IHEP,ID,ITAU,I,IMO,NHEPPO
13591       DOUBLE PRECISION POL
13592       REAL POL1(4)
13593       CHARACTER *8 DUMMY
13594 C--common block for PHOTOS
13595       LOGICAL QEDRAD
13596       COMMON /PHOQED/ QEDRAD(NMXHEP)
13597 C--common blocks for TAUOLA
13598       INTEGER NP1,NP2
13599       COMMON /TAUPOS/ NP1, NP2
13600       DOUBLE PRECISION Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
13601       COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
13602 C--initialisation
13603       IF(IOPT.EQ.-1) THEN
13604 C--initialise TAUOLA
13605         CALL INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
13606         CALL INIMAS
13607         CALL INIPHX(0.01d0)
13608         CALL INITDK
13609 C--generate a decay
13610       ELSEIF(IOPT.EQ.1) THEN
13611         ISTHEP(IHEP)=195
13612         ID = IDHW(IHEP)
13613         IMO = IHEP
13614  1      IMO = JMOHEP(1,IMO)
13615         IF(IDHW(IMO).EQ.ID) GOTO 1
13616 C--id of tau for tauola
13617         IF(ID.EQ.125) THEN
13618           ITAU = 2
13619           NP1 = IHEP
13620           NP2 = IHEP
13621         ELSEIF(ID.EQ.131) THEN
13622           ITAU = 1
13623           NP1 = IHEP
13624           NP2 = IHEP
13625         ELSE
13626           CALL HWWARN('HWDTAU',501)
13627         ENDIF
13628 C--set up the tau polarization
13629         POL1(1) = 0.
13630         POL1(2) = 0.
13631         POL1(3) = REAL(POL)
13632         POL1(4) = 0.
13633 C--tau momentum
13634 C--three components
13635         DO I=1,3
13636            IF(ID.EQ.125) THEN
13637               P1(I) =-PHEP(I,IHEP)
13638               P2(I) = PHEP(I,IHEP)
13639            ELSE
13640               P1(I) = PHEP(I,IHEP)
13641               P2(I) =-PHEP(I,IHEP)
13642            ENDIF
13643 C--we measure tau spins in lab frame
13644           Q1(I) = ZERO
13645         ENDDO
13646 C--energies
13647         P1(4)=PHEP(4,IHEP)
13648         P2(4)=PHEP(4,IHEP)
13649         Q1(4)=P1(4)+P2(4)
13650 C--perform the decay and generate QED radiation if needed
13651         NHEPPO=NHEP
13652         CALL DEXAY(ITAU,POL1)
13653         IF(IFPHOT.EQ.1) THEN
13654           IF(ID.EQ.1) THEN
13655             CALL PHOTOS(NP1)
13656           ELSE
13657             CALL PHOTOS(NP2)
13658           ENDIF
13659         ENDIF
13660         IF(NHEPPO.NE.NHEP) THEN
13661           DO 2 I=NHEPPO+1,NHEP
13662           CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
13663  2        CALL HWUIDT(1,IDHEP(I),IDHW(I),DUMMY)
13664         ENDIF
13665 C--write out info at end
13666       ELSEIF(IOPT.EQ.2) THEN
13667         CALL DEXAY(100,POL1)
13668 C--otherwise issue warning
13669       ELSE
13670         CALL HWWARN('HWDTAU',500)
13671       ENDIF
13672       END
13673 CDECK  ID>, HWDTHR.
13674 *CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
13675 *-- Author :    Bryan Webber
13676 C-----------------------------------------------------------------------
13677       SUBROUTINE HWDTHR(P0,P1,P2,P3,WEIGHT)
13678 C-----------------------------------------------------------------------
13679 C     GENERATES THREE-BODY DECAY 0->1+2+3 DISTRIBUTED
13680 C     ACCORDING TO PHASE SPACE * WEIGHT
13681 C-----------------------------------------------------------------------
13682       IMPLICIT NONE
13683       DOUBLE PRECISION HWRGEN,HWRUNI,A,B,C,D,AA,BB,CC,DD,EE,FF,PP,QQ,WW,
13684      & RR,PCM1,PC23,WEIGHT,P0(5),P1(5),P2(5),P3(5),P23(5),TWO
13685       EXTERNAL HWRGEN,HWRUNI,WEIGHT
13686       PARAMETER (TWO=2.D0)
13687       A=P0(5)+P1(5)
13688       B=P0(5)-P1(5)
13689       C=P2(5)+P3(5)
13690       IF (B.LT.C) THEN
13691         CALL HWWARN('HWDTHR',100)
13692         GOTO 999
13693       ENDIF
13694       D=ABS(P2(5)-P3(5))
13695       AA=A*A
13696       BB=B*B
13697       CC=C*C
13698       DD=D*D
13699       EE=(B-C)*(A-D)
13700       A=0.5*(AA+BB)
13701       B=0.5*(CC+DD)
13702       C=4./(A-B)**2
13703 C
13704 C  CHOOSE MASS OF SUBSYSTEM 23 WITH PRESCRIBED DISTRIBUTION
13705 C
13706    10 FF=HWRUNI(0,BB,CC)
13707       PP=(AA-FF)*(BB-FF)
13708       QQ=(CC-FF)*(DD-FF)
13709       WW=WEIGHT(FF,A,B,C)**2
13710       RR=EE*FF*HWRGEN(0)
13711       IF (PP*QQ*WW.LT.RR*RR) GOTO 10
13712 C
13713 C  FF IS MASS SQUARED OF SUBSYSTEM 23.
13714 C
13715 C  DO 2-BODY DECAYS 0->1+23, 23->2+3
13716 C
13717       P23(5)=SQRT(FF)
13718       PCM1=SQRT(PP)*0.5/P0(5)
13719       PC23=SQRT(QQ)*0.5/P23(5)
13720       CALL HWDTWO(P0,P1,P23,PCM1,TWO,.TRUE.)
13721       CALL HWDTWO(P23,P2,P3,PC23,TWO,.TRUE.)
13722  999  RETURN
13723       END
13724 CDECK  ID>, HWDTOP.
13725 *CMZ :-        -09/12/92  11.03.46  by  Bryan Webber
13726 *-- Author :    Bryan Webber
13727 C-----------------------------------------------------------------------
13728       SUBROUTINE HWDTOP(DECAY)
13729 C-----------------------------------------------------------------------
13730 C     DECIDES WHETHER TO DO TOP QUARK DECAY BEFORE HADRONIZATION
13731 C-----------------------------------------------------------------------
13732       INCLUDE 'herwig65.inc'
13733       LOGICAL DECAY
13734       DECAY=RMASS(6).GT.130D0
13735       END
13736 CDECK  ID>, HWDTWO.
13737 *CMZ :-        -27/01/94  17.38.49  by  Mike Seymour
13738 *-- Author :    Bryan Webber & Mike Seymour
13739 C-----------------------------------------------------------------------
13740       SUBROUTINE HWDTWO(P0,P1,P2,PCM,COSTH,ZAXIS)
13741 C-----------------------------------------------------------------------
13742 C     GENERATES DECAY 0 -> 1+2
13743 C
13744 C     PCM IS CM MOMENTUM
13745 C
13746 C     COSTH = COS THETA IN P0 REST FRAME (>1 FOR ISOTROPIC)
13747 C     IF ZAXIS=.TRUE., COS THETA IS MEASURED FROM THE ZAXIS
13748 C     IF .FALSE., IT IS MEASURED FROM P0'S DIRECTION
13749 C-----------------------------------------------------------------------
13750       IMPLICIT NONE
13751       DOUBLE PRECISION HWRUNI,ONE,ZERO,PCM,COSTH,C,S,P0(5),P1(5),P2(5),
13752      & PP(5),R(9)
13753       LOGICAL ZAXIS
13754       EXTERNAL HWRUNI
13755       PARAMETER (ZERO=0.D0, ONE=1.D0)
13756 C--CHOOSE C.M. ANGLES
13757       C=COSTH
13758       IF (C.GT.ONE) C=HWRUNI(0,-ONE,ONE)
13759       S=SQRT(ONE-C*C)
13760       CALL HWRAZM(PCM*S,PP(1),PP(2))
13761 C--PP IS MOMENTUM OF 2 IN C.M.
13762       PP(3)=-PCM*C
13763       PP(4)=SQRT(P2(5)**2+PCM**2)
13764       PP(5)=P2(5)
13765 C--ROTATE IF NECESSARY
13766       IF (COSTH.LE.ONE.AND..NOT.ZAXIS) THEN
13767         CALL HWUROT(P0,ONE,ZERO,R)
13768         CALL HWUROB(R,PP,PP)
13769       ENDIF
13770 C--BOOST FROM C.M. TO LAB FRAME
13771       CALL HWULOB(P0,PP,P2)
13772       CALL HWVDIF(4,P0,P2,P1)
13773       END
13774 CDECK  ID>, HWDWWT.
13775 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
13776 *-- Author :    Bryan Webber
13777 C-----------------------------------------------------------------------
13778       FUNCTION HWDWWT(EMSQ,A,B,C)
13779 C-----------------------------------------------------------------------
13780 C     MATRIX ELEMENT SQUARED FOR V-A WEAK DECAY
13781 C-----------------------------------------------------------------------
13782       IMPLICIT NONE
13783       DOUBLE PRECISION HWDWWT,EMSQ,A,B,C
13784       HWDWWT=(A-EMSQ)*(EMSQ-B)*C
13785       END
13786 CDECK  ID>, HWDHWT.
13787 *CMZ :-        -26/06/01  14.44.53  by  Stefano Moretti
13788 *-- Author :    Stefano Moretti
13789 C-----------------------------------------------------------------------
13790       FUNCTION HWDHWT(EMSQ,DUMMYA,DUMMYB,DUMMYC)
13791 C-----------------------------------------------------------------------
13792 C     MATRIX ELEMENT SQUARED FOR
13793 C     ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) WEAK DECAY
13794 C-----------------------------------------------------------------------
13795       INCLUDE 'herwig65.inc'
13796       COMMON/FFS/TB,BT
13797       COMMON/SFF/IT1,IB1,IT2,IB2
13798       DOUBLE PRECISION TB,BT
13799       INTEGER IT1,IB1,IT2,IB2
13800       DOUBLE PRECISION TBH,HBT,CB1,TB1,CB2,TB2
13801       DOUBLE PRECISION DUMMYA,DUMMYB,DUMMYC
13802       DOUBLE PRECISION HWDHWT,EMSQ
13803       CB1=RMASS(IT1)**2
13804       TB1=RMASS(IB1)**2
13805       CB2=RMASS(IT2)**2
13806       TB2=RMASS(IB2)**2
13807 C use formula (4.52) page 217 of `Higgs Hunter Guide'.
13808       TBH=(TB1+CB1-EMSQ)*(TB1*TB*TB+CB1/TB/TB)+4.*TB1*CB1
13809 C use formula (B. 1) page 411 of `Higgs Hunter Guide'.
13810       HBT=(EMSQ-TB2-CB2)*(TB2*BT*BT+CB2/BT/BT)-4.*TB2*CB2
13811       HWDHWT=TBH*HBT
13812       HWDHWT=ABS(HWDHWT)*SQRT(EMSQ)
13813       END
13814 CDECK  ID>, HWDXLM.
13815 *CMZ :-        -07/09/00  10:06:23  by  Peter Richardson
13816 *-- Author :    Ian Knowles
13817 C-----------------------------------------------------------------------
13818       SUBROUTINE HWDXLM(DKVRTX,STAB)
13819 C-----------------------------------------------------------------------
13820 C     Sets STAB=.TRUE. if DKVRTX lies outside the specified region.
13821 C  Revised 05/09/00 by BRW to put parameters in common
13822 C-----------------------------------------------------------------------
13823       INCLUDE 'herwig65.inc'
13824       DOUBLE PRECISION DKVRTX(4),RR
13825       LOGICAL STAB
13826       STAB=.FALSE.
13827       RR=DKVRTX(1)**2+DKVRTX(2)**2
13828       IF (IOPDKL.EQ.1) THEN
13829 C Cylindrical geometry
13830          IF (RR.GE.DXRCYL**2.OR.ABS(DKVRTX(3)).GE.DXZMAX) STAB=.TRUE.
13831       ELSEIF (IOPDKL.EQ.2) THEN
13832 C Spherical geometry
13833          RR=RR+DKVRTX(3)**2
13834          IF (RR.GE.DXRSPH**2) STAB=.TRUE.
13835       ELSE
13836 C User supplied geometry -- missing
13837          CALL HWWARN('HWDXLM',500)
13838       ENDIF
13839       END
13840 CDECK  ID>, HWECIR.
13841 *CMZ :-        -11/05/01  15.44.55  by  Mike Seymour
13842 *-- Author :    Mike Seymour
13843 C-----------------------------------------------------------------------
13844       FUNCTION HWECIR(Y)
13845 C-----------------------------------------------------------------------
13846 C   INTEGRAND OF BEAMSTRAHLUNG FUNCTION INTEGRATION
13847 C   NOTE THAT THE JACOBIAN TRANSFORMATION (1-Z)^ETA HAS ETA HARDCODED
13848 C-----------------------------------------------------------------------
13849       IMPLICIT NONE
13850       DOUBLE PRECISION HWECIR,Y,Z,ETA,CIRCEE
13851       EXTERNAL CIRCEE
13852       ETA=0.6D0
13853       Z=1-Y**(1/(1-ETA))
13854       HWECIR=(1-Z)**ETA/(1-ETA)*CIRCEE(Z,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
13855       END
13856 CDECK  ID>, HWEFIN.
13857 *CMZ :-        -15/07/02  17.56.53  by  Peter Richardson
13858 *-- Author :    Bryan Webber
13859 C-----------------------------------------------------------------------
13860       SUBROUTINE HWEFIN
13861 C-----------------------------------------------------------------------
13862 C     TERMINAL CALCULATIONS ON ELEMENTARY PROCESS
13863 C     Modified 28/03/01 by BRW to handle negative weights
13864 C     Modified 15/07/02 by PR for Les Houches Accord
13865 C-----------------------------------------------------------------------
13866       INCLUDE 'herwig65.inc'
13867       INTEGER I
13868       DOUBLE PRECISION RNWGT,SPWGT,ERWGT
13869 C--Les Houches Common Block
13870       INTEGER MAXPUP
13871       PARAMETER(MAXPUP=100)
13872       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
13873       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
13874       COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
13875      &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
13876      &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
13877       IF(TAUDEC.EQ.'TAUOLA') CALL HWDTAU(2,0,0.0D0)
13878       IF (NWGTS.EQ.0) THEN
13879         WRITE (6,1)
13880         WRITE (6,10)
13881    10   FORMAT(10X,'NO WEIGHTS GENERATED')
13882         RETURN
13883       ENDIF
13884 C--output Les Houches common block information
13885       IF(IPROC.LE.0) THEN
13886 C--WRITE THE HEADER
13887         WRITE(6,13)
13888         WRITE(6,14)
13889 C--FOR THE FIRST WEIGHT OPTION CALCULATE THE CROSS SECTION
13890         IF(ABS(IDWTUP).EQ.1) THEN
13891           DO I=1,NPRUP
13892             RNWGT     = 1.0D0/DBLE(LHIWGT(I))
13893             LHXSCT(I) = LHWGT(I)*RNWGT
13894             LHXERR(I) = SQRT(MAX(LHWGTS(I)*RNWGT-LHXSCT(I)**2,ZERO))
13895             LHXERR(I) = LHXERR(I)*SQRT(RNWGT)
13896             LHXSCT(I) = LHXSCT(I)*1.0D3
13897             LHXERR(I) = LHXERR(I)*1.0D3
13898             LHXMAX(I) = LHXMAX(I)*1.0D3
13899           ENDDO
13900 C--FOR THE SECOND WEIGHT OPTION THIS WAS AN INPUT
13901         ELSEIF(ABS(IDWTUP).EQ.2) THEN
13902           DO I=1,NPRUP
13903             LHXMAX(I) = LHXMAX(I)*1.0D3
13904           ENDDO
13905         ENDIF
13906         IF(ABS(IDWTUP).LE.2) THEN
13907           AVWGT = ZERO
13908           ERWGT = ZERO
13909           DO I=1,NPRUP
13910             WRITE(6,15) LPRUP(I),LHXSCT(I),LHXERR(I),LHXMAX(I)*1.0D-3,
13911      &            LHNEVT(I)
13912             AVWGT = AVWGT+LHXSCT(I)
13913             ERWGT = ERWGT+LHXERR(I)**2
13914           ENDDO
13915           AVWGT = AVWGT*1.0D-3
13916           ERWGT = SQRT(ERWGT)*1.0D-3
13917         ELSE
13918           RNWGT=1./FLOAT(NWGTS)
13919           IF (NEGWTS) AVABW=ABWSUM*RNWGT
13920           AVWGT=WGTSUM*RNWGT
13921           SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
13922           ERWGT=SPWGT*SQRT(RNWGT)
13923           IF (.NOT.NOWGT) WGTMAX=AVWGT
13924           IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
13925         ENDIF
13926 C--STANDARD HERWIG OPTION
13927       ELSE
13928         RNWGT=1./FLOAT(NWGTS)
13929         IF (NEGWTS) AVABW=ABWSUM*RNWGT
13930         AVWGT=WGTSUM*RNWGT
13931         SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
13932         ERWGT=SPWGT*SQRT(RNWGT)
13933         IF (.NOT.NOWGT) WGTMAX=AVWGT
13934         IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
13935       ENDIF
13936 C--PRINT OUT THE INFO
13937       WRITE (6,1)
13938  1    FORMAT(/10X,'OUTPUT ON ELEMENTARY PROCESS'/)
13939       IF (NEGWTS) THEN
13940          WRITE (6,12) NEVHEP,NNEGEV,NWGTS,NNEGWT,AVWGT,SPWGT,
13941      &        AVABW,WBIGST,WGTMAX,IPROC,
13942      &        1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
13943       ELSE
13944          WRITE (6,11) NEVHEP,NWGTS,AVWGT,SPWGT,WBIGST,WGTMAX,
13945      &        IPROC,
13946      &        1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
13947       ENDIF
13948  11   FORMAT(1P,
13949      &     10X,'N.B. NEGATIVE WEIGHTS NOT ALLOWED'//
13950      &     10X,'NUMBER OF EVENTS   = ',I11/
13951      &     10X,'NUMBER OF WEIGHTS  = ',I11/
13952      &     10X,'MEAN VALUE OF WGT  =',E12.4/
13953      &     10X,'RMS SPREAD IN WGT  =',E12.4/
13954      &     10X,'ACTUAL MAX WEIGHT  =',E12.4/
13955      &     10X,'ASSUMED MAX WEIGHT =',E12.4//
13956      &     10X,'PROCESS CODE IPROC = ',I11/
13957      &     10X,'CROSS SECTION (PB) =',G12.4/
13958      &     10X,'ERROR IN C-S  (PB) =',G12.4/
13959      &     10X,'EFFICIENCY PERCENT =',G12.4)
13960  12   FORMAT(1P,
13961      &     10X,'N.B. NEGATIVE WEIGHTS ALLOWED'//
13962      &     10X,'NUMBER OF EVENTS   = ',I11/
13963      &     10X,'NEGATIVE  EVENTS   = ',I11/
13964      &     10X,'NUMBER OF WEIGHTS  = ',I11/
13965      &     10X,'NEGATIVE  WEIGHTS  = ',I11/
13966      &     10X,'MEAN VALUE OF WGT  =',E12.4/
13967      &     10X,'RMS SPREAD IN WGT  =',E12.4/
13968      &     10X,'MEAN ABS WEIGHT    =',E12.4/
13969      &     10X,'ACTUAL MAX ABS WGT =',E12.4/
13970      &     10X,'ASSUMED MAXABS WGT =',E12.4//
13971      &     10X,'PROCESS CODE IPROC = ',I11/
13972      &     10X,'CROSS SECTION (PB) =',G12.4/
13973      &     10X,'ERROR IN C-S  (PB) =',G12.4/
13974      &     10X,'EFFICIENCY PERCENT =',G12.4)
13975  13   FORMAT(/1P,10X,'OUTPUT ON LES HOUCHES EVENTS'/)
13976  14   FORMAT(/1P,5X,' PROC CODE',1X,' XSECT(pb)     ',1X,
13977      &     '  XERR(pb)  ',1X,'   Max wgt(nb)',1X,'No. of events'/)
13978  15   FORMAT(5X,I7,E15.5,1X,E15.5,1X,E15.5,2X,I7)
13979       END
13980 CDECK  ID>, HWEGAM.
13981 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
13982 *-- Author :    Bryan Webber & Luca Stanco
13983 C-----------------------------------------------------------------------
13984       SUBROUTINE HWEGAM(IHEP,ZMI,ZMA,WWA)
13985 C-----------------------------------------------------------------------
13986 C     GENERATES A PHOTON IN WEIZSACKER-WILLIAMS (WWA=.TRUE.) OR
13987 C     ELSE EQUIVALENT PHOTON APPROX FROM INCOMING E+, E-, MU+ OR MU-
13988 C-----------------------------------------------------------------------
13989       INCLUDE 'herwig65.inc'
13990       DOUBLE PRECISION HWRGEN,HWRUNI,EGMIN,ZMIN,ZMAX,ZGAM,SS,ZMI,ZMA,
13991      & PPL,PMI,QT2,Q2,QQMIN,QQMAX,S0,A
13992       INTEGER IHEP,IHADIS
13993       LOGICAL WWA
13994       EXTERNAL HWRGEN,HWRUNI
13995       SAVE EGMIN
13996       DATA EGMIN/5.D0/
13997       IF (IERROR.NE.0)  RETURN
13998       IF (IHEP.LT.1.OR.IHEP.GT.2) CALL HWWARN('HWEGAM',500)
13999       SS=PHEP(5,3)
14000       IF (IHEP.EQ.1) THEN
14001         IHADIS=2
14002       ELSE
14003         IHADIS=1
14004         IF (JDAHEP(1,IHADIS).NE.0) IHADIS=JDAHEP(1,IHADIS)
14005       ENDIF
14006 C---DEFINE LIMITS FOR GAMMA MOMENTUM FRACTION
14007       IF (ZMI.LE.ZERO .OR. ZMA.GT.ONE) THEN
14008         CALL HWEGAS(S0)
14009         IF (S0.GT.ZERO) THEN
14010           S0 = (SQRT(S0)+ABS(PHEP(5,IHADIS)))**2-PHEP(5,IHADIS)**2
14011           S0 = MAX(S0,WHMIN**2)
14012           ZMIN = S0 / (SS**2 - PHEP(5,IHEP)**2 - PHEP(5,IHADIS)**2)
14013           ZMAX = ONE
14014         ELSE
14015 C---UNKNOWN PROCESS: USE ENERGY CUTOFF, AND WARN USER
14016           IF (FSTWGT) CALL HWWARN('HWEGAM',1)
14017           ZMIN = EGMIN / PHEP(4,IHEP)
14018           ZMAX = ONE
14019         ENDIF
14020       ELSE
14021         ZMIN=ZMI
14022         ZMAX=ZMA
14023       ENDIF
14024 C---APPLY USER DEFINED CUTS YWWMIN,YWWMAX AND INDIRECT LIMITS ON Z
14025       IF (.NOT.WWA) THEN
14026         ZMIN=MAX(ZMIN,YWWMIN,SQRT(Q2WWMN)/ABS(PHEP(3,IHEP)))
14027         ZMAX=MIN(ZMAX,YWWMAX)
14028       ELSE
14029         ZMAX=MIN(ZMAX,1-PHEP(5,IHEP)/PHEP(4,IHEP))
14030       ENDIF
14031       IF (ZMIN.GE.ZMAX) THEN
14032         GAMWT=ZERO
14033         RETURN
14034       ENDIF
14035 C---GENERATE GAMMA MOMENTUM FRACTION
14036       A=HALF
14037  10   IF (HWRGEN(2).LT.A) THEN
14038         ZGAM=(ZMIN/ZMAX)**HWRGEN(1)*ZMAX
14039       ELSE
14040         ZGAM=(ZMAX-ZMIN)*HWRGEN(1)+ZMIN
14041       ENDIF
14042       GAMWT = GAMWT * .5*ALPHEM/PIFAC *
14043      +     (1+(1-ZGAM)**2)/(A/LOG(ZMAX/ZMIN)+(1-A)/(ZMAX-ZMIN)*ZGAM)
14044       IF (WWA) THEN
14045         GAMWT = GAMWT * LOG((ONE-ZGAM)/ZGAM*(SS/PHEP(5,IHEP))**2)
14046       ELSE
14047 C---Q2WWMN AND Q2WWMX ARE USER-DEFINED LIMITS IN THE Q**2 INTEGRATION
14048         QQMAX=MIN(Q2WWMX,(ZGAM*PHEP(3,IHEP))**2)
14049         QQMIN=MAX(Q2WWMN,(PHEP(5,IHEP)*ZGAM)**2/(1.-ZGAM))
14050         IF (QQMIN.GT.QQMAX) THEN
14051           CALL HWWARN('HWEGAM',50)
14052           GOTO 10
14053         ENDIF
14054         Q2=EXP(HWRUNI(0,LOG(QQMIN),LOG(QQMAX)))
14055         GAMWT = GAMWT * LOG(QQMAX/QQMIN)
14056       ENDIF
14057       IF (GAMWT.LT.ZERO) GAMWT=ZERO
14058 C---FILL PHOTON
14059       NHEP=NHEP+1
14060       IDHW(NHEP)=59
14061       ISTHEP(NHEP)=3
14062       IDHEP(NHEP)=22
14063       JMOHEP(1,NHEP)=IHEP
14064       JMOHEP(2,NHEP)=0
14065       JDAHEP(1,NHEP)=0
14066       JDAHEP(2,NHEP)=0
14067       JDAHEP(1,IHEP)=NHEP
14068       IF (WWA) THEN
14069 C---FOR COLLINEAR KINEMATICS, ZGAM IS THE ENERGY FRACTION
14070         PHEP(4,NHEP)=PHEP(4,IHEP)*ZGAM
14071         PHEP(3,NHEP)=PHEP(3,IHEP)-SIGN(SQRT(
14072      &     (PHEP(4,IHEP)-PHEP(4,NHEP))**2-PHEP(5,IHEP)**2),PHEP(3,IHEP))
14073         PHEP(2,NHEP)=0
14074         PHEP(1,NHEP)=0
14075         CALL HWUMAS(PHEP(1,NHEP))
14076       ELSE
14077 C---FOR EXACT KINEMATICS, ZGAM IS TAKEN TO BE FRACTION OF (E+PZ)
14078         PPL=ZGAM*(ABS(PHEP(3,IHEP))+PHEP(4,IHEP))
14079         QT2=(ONE-ZGAM)*Q2-(ZGAM*PHEP(5,IHEP))**2
14080         PMI=(QT2-Q2)/PPL
14081         PHEP(5,NHEP)=-SQRT(Q2)
14082         PHEP(4,NHEP)=(PPL+PMI)/TWO
14083         PHEP(3,NHEP)=SIGN((PPL-PMI)/TWO,PHEP(3,IHEP))
14084         CALL HWRAZM(SQRT(QT2),PHEP(1,NHEP),PHEP(2,NHEP))
14085       ENDIF
14086 C---UPDATE OVERALL CM FRAME
14087       JMOHEP(IHEP,3)=NHEP
14088       CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
14089       CALL HWVSUM(4,PHEP(1,NHEP),PHEP(1,3),PHEP(1,3))
14090       CALL HWUMAS(PHEP(1,3))
14091 C---FILL OUTGOING LEPTON
14092       NHEP=NHEP+1
14093       IDHW(NHEP)=IDHW(IHEP)
14094       ISTHEP(NHEP)=1
14095       IDHEP(NHEP)=IDHEP(IHEP)
14096       JMOHEP(1,NHEP)=IHEP
14097       JMOHEP(2,NHEP)=0
14098       JDAHEP(1,NHEP)=0
14099       JDAHEP(2,NHEP)=0
14100       JDAHEP(2,IHEP)=NHEP
14101       CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP-1),PHEP(1,NHEP))
14102       PHEP(5,NHEP)=PHEP(5,IHEP)
14103       END
14104 CDECK  ID>, HWEGAS.
14105 *CMZ :-        -18/04/04  10.45.55  by  Mike Seymour
14106 *-- Author :    Bryan Webber & Luca Stanco
14107 C-----------------------------------------------------------------------
14108       SUBROUTINE HWEGAS(S0)
14109 C-----------------------------------------------------------------------
14110 C     FIND MINIMUM INVARIANT MASS SQUARED NEEDED FOR HARD PROCESS, S0
14111 C-----------------------------------------------------------------------
14112       INCLUDE 'herwig65.inc'
14113       DOUBLE PRECISION S0,RPM(2)
14114       INTEGER HQ,I
14115       IF (IPRO.EQ.13.OR.IPRO.EQ.14) THEN
14116         S0 = EMMIN**2
14117       ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.18.OR.IPRO.EQ.22.OR.IPRO.EQ.24.OR.
14118      &       IPRO.EQ.50.OR.IPRO.EQ.53.OR.IPRO.EQ.55)THEN
14119         S0 = 4.D0*PTMIN**2
14120       ELSEIF (IPRO.EQ.17.OR.IPRO.EQ.51) THEN
14121         HQ = MOD(IPROC,100)
14122         S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
14123       ELSEIF (IPRO.EQ.16.OR.IPRO.EQ.19.OR.
14124      &       IPRO.EQ.25.OR.IPRO.EQ.26.OR.IPRO.EQ.27.OR.
14125      &       IPRO.EQ.95) THEN
14126         S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
14127       ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN
14128         S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
14129       ELSEIF (IPRO.EQ.33) THEN
14130         IF((MOD(IPROC,10000).EQ.3350).OR.
14131      &       (MOD(IPROC,10000).EQ.3355))THEN
14132           S0 = MAX(2*RMASS(1),RMASS(206))**2
14133         ELSEIF(MOD(IPROC,10000).EQ.3315)THEN
14134           S0 = MAX(2*RMASS(1),RMASS(206),RMASS(203))**2
14135         ELSEIF(MOD(IPROC,10000).EQ.3325)THEN
14136           S0 = MAX(2*RMASS(1),RMASS(206),RMASS(204))**2
14137         ELSEIF(MOD(IPROC,10000).EQ.3335)THEN
14138           S0 = MAX(2*RMASS(1),RMASS(206),RMASS(205))**2
14139         ELSEIF(MOD(IPROC,10000).EQ.3365)THEN
14140           S0 = MAX(2*RMASS(1),RMASS(205),RMASS(203))**2
14141         ELSEIF(MOD(IPROC,10000).EQ.3375)THEN
14142           S0 = MAX(2*RMASS(1),RMASS(205),RMASS(204))**2
14143         ELSE
14144           S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
14145         END IF
14146       ELSEIF ((IPRO.EQ.34).OR.(IPRO.EQ.35)) THEN
14147         S0 = MAX(RMASS(5),RMASS(201+IHIGGS))**2
14148       ELSEIF (IPRO.EQ.36.OR.IPRO.EQ.37) THEN
14149         S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
14150       ELSEIF (IPRO.EQ.38) THEN
14151         IF((MOD(IPROC,10000).EQ.3839).OR.
14152      &       (MOD(IPROC,10000).EQ.3869).OR.
14153      &       (MOD(IPROC,10000).EQ.3899))THEN
14154           S0 = MAX(RMASS(6),RMASS(206))**2
14155         ELSE
14156           S0 = RMASS(201+IHIGGS)**2
14157         END IF
14158       ELSEIF (IPRO.EQ.23) THEN
14159         S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
14160         S0 = (PTMIN+SQRT(PTMIN**2+S0))**2
14161       ELSEIF (IPRO.EQ.20) THEN
14162         S0 = RMASS(6)**2
14163       ELSEIF (IPRO.EQ.21) THEN
14164         S0 = (PTMIN+SQRT(PTMIN**2+RMASS(198)**2))**2
14165 C--PR MOD 7/7/99
14166       ELSEIF (IPRO.EQ.30) THEN
14167         S0 = 4.0D0*(PTMIN**2+RMMNSS**2)
14168       ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
14169         HQ = MOD(IPROC,100)
14170         RPM(1) = RMMNSS
14171         RPM(2) = ZERO
14172         IF(HQ.GE.10.AND.HQ.LT.20) THEN
14173           RPM(1) = ABS(RMASS(450))
14174           IF(HQ.GT.10) RPM(1) = ABS(RMASS(449+MOD(HQ,10)))
14175         ELSEIF(HQ.GE.20.AND.HQ.LT.30) THEN
14176           RPM(1) = ABS(RMASS(454))
14177           IF(HQ.GT.20) RPM(1) = ABS(RMASS(453+MOD(HQ,20)))
14178         ELSEIF(HQ.EQ.30) THEN
14179           RPM(1) = RMASS(449)
14180         ELSEIF(HQ.EQ.40) THEN
14181           IF(IPRO.EQ.40) THEN
14182             RPM(1) = RMASS(425)
14183             DO I=1,5
14184               RPM(1) = MIN(RPM(1),RMASS(425+I))
14185             ENDDO
14186           ELSE
14187             RPM(1) = MIN(RMASS(405),RMASS(406))
14188           ENDIF
14189           RPM(2) = RMASS(198)
14190         ELSEIF(HQ.EQ.50) THEN
14191           IF(IPRO.EQ.40) THEN
14192             RPM(1) = RMASS(425)
14193             DO I=1,5
14194               RPM(1) = MIN(RPM(1),RMASS(425+I))
14195             ENDDO
14196             DO I=1,3
14197               RPM(2) = MIN(RPM(1),RMASS(433+2*I))
14198             ENDDO
14199             RPM(1) = MIN(RPM(1),RPM(2))
14200             RPM(2) = RMASS(203)
14201             DO I=1,2
14202               RPM(2) = MIN(RPM(2),RMASS(204+I))
14203             ENDDO
14204           ELSE
14205             RPM(1) = RMASS(401)
14206             RPM(2) = RMASS(413)
14207             DO I=1,5
14208               RPM(1) = MIN(RPM(1),RMASS(401+I))
14209               RPM(2) = MIN(RPM(2),RMASS(413+I))
14210             ENDDO
14211             RPM(1) = MIN(RPM(1),RPM(2))
14212             RPM(2) = RMASS(203)
14213             DO I=1,2
14214               RPM(2) = MIN(RPM(2),RMASS(204+I))
14215             ENDDO
14216           ENDIF
14217           RPM(2) = RMASS(203)
14218           DO I=1,2
14219             RPM(2) = MIN(RPM(2),RMASS(204+I))
14220           ENDDO
14221         ELSEIF(HQ.GE.60) THEN
14222           RPM(1) = ZERO
14223         ENDIF
14224         RPM(1) = RPM(1)**2
14225         RPM(2) = RPM(2)**2
14226         S0 = RPM(1)+RPM(2)+TWO*(PTMIN**2+
14227      &       SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2)))
14228 C--end of mod
14229 C--PR MOD 9/9/00
14230       ELSEIF (IPRO.EQ.42) THEN
14231         S0 = EMMIN**2
14232       ELSEIF (IPRO.EQ.52) THEN
14233         HQ = MOD(IPROC,100)
14234         S0 = (PTMIN+SQRT(PTMIN**2+RMASS(HQ)**2))**2
14235       ELSEIF (IPRO.EQ.60) THEN
14236         HQ = MOD(IPROC,100)
14237         IF (HQ.EQ.0) THEN
14238           S0 = 4.D0*PTMIN**2
14239         ELSE
14240           IF (HQ.GT.6) HQ=2*HQ+107
14241           IF (HQ.EQ.127) HQ=198
14242           S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
14243         ENDIF
14244       ELSEIF (IPRO.EQ.80) THEN
14245         S0 = WHMIN**2
14246       ELSEIF (IPRO.EQ.90) THEN
14247         S0 = Q2MIN
14248       ELSEIF (IPRO.EQ.91.OR.IPRO.EQ.92) THEN
14249         S0 = Q2MIN+4.D0*PTMIN**2
14250         HQ = MOD(IPROC,100)
14251         IF (HQ.GT.0) S0 = S0+4.D0*RMASS(HQ)**2
14252         IF (IPRO.EQ.91) S0 = MAX(S0,EMMIN**2)
14253       ELSE
14254         S0 = 0
14255       ENDIF
14256       END
14257 CDECK  ID>, HWEINI.
14258 *CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
14259 *-- Author :    Bryan Webber
14260 C-----------------------------------------------------------------------
14261       SUBROUTINE HWEINI
14262 C-----------------------------------------------------------------------
14263 C     INITIALISES ELEMENTARY PROCESS
14264 C     Modified 28/03/01 by BRW to handle negative weights
14265 C-----------------------------------------------------------------------
14266       INCLUDE 'herwig65.inc'
14267       DOUBLE PRECISION HWRSET,DUMMY,SAFETY
14268       EXTERNAL HWRSET
14269       PARAMETER (SAFETY=1.001)
14270       INTEGER NBSH,I
14271 C---NO OF WEIGHT GENERATED
14272       NWGTS=0
14273       NNEGWT=0
14274 C---ACCUMULATED WEIGHTS
14275       WGTSUM=ZERO
14276       ABWSUM=ZERO
14277 C---ACCUMULATED WEIGHT-SQUARED
14278       WSQSUM=ZERO
14279 C---CURRENT MAX WEIGHT
14280       WBIGST=ZERO
14281 C---LAST VALUE OF SCALE
14282       EMLST=ZERO
14283 C---NUMBER OF ERRORS REPORTED
14284       NUMER=0
14285 C---NUMBER OF ERRORS UNREPORTED
14286       NUMERU=0
14287 C---FIND MAXIMUM ABSOLUTE WEIGHT IN CASES WHERE THIS IS REQUIRED
14288       IF (NOWGT) THEN
14289         IF (WGTMAX.EQ.ZERO.AND.IPROC.GT.0) THEN
14290           NBSH=IBSH
14291           DUMMY = HWRSET(IBRN)
14292           WRITE(6,10) IPROC,IBRN,NBSH
14293    10     FORMAT(/10X,'INITIAL SEARCH FOR MAX WEIGHT'//
14294      &            10X,'PROCESS CODE IPROC = ',I11/
14295      &            10X,'RANDOM NO. SEED 1  = ',I11/
14296      &            10X,'           SEED 2  = ',I11/
14297      &            10X,'NUMBER OF SHOTS    = ',I11)
14298           NEVHEP=0
14299           DO 11 I=1,NBSH
14300           CALL HWEPRO
14301    11     CONTINUE
14302           WRITE(6,20)
14303    20     FORMAT(/10X,'INITIAL SEARCH FINISHED')
14304           IF (WBIGST*NWGTS.LT.SAFETY*WGTSUM)
14305      &                 WGTMAX=SAFETY*WBIGST
14306           CALL HWEFIN
14307           NWGTS=0
14308           NNEGWT=0
14309           WGTSUM=ZERO
14310           WSQSUM=ZERO
14311           ABWSUM=ZERO
14312           WBIGST=ZERO
14313         ELSE
14314           WRITE(6,21) AVWGT,WGTMAX
14315    21     FORMAT(/1P,10X,'INPUT EVT WEIGHT   =',E12.4/
14316      &               10X,'INPUT MAX WEIGHT   =',E12.4)
14317         ENDIF
14318       ENDIF
14319 C---RESET RANDOM NUMBER
14320       DUMMY = HWRSET(NRN)
14321       ISTAT=5
14322       END
14323 CDECK  ID>, HWEISR.
14324 *CMZ :-        -01/04/99  19.55.17  by  Mike Seymour
14325 *-- Author :    Mike Seymour
14326 C-----------------------------------------------------------------------
14327       SUBROUTINE HWEISR(IHEP)
14328 C-----------------------------------------------------------------------
14329 C     GENERATES AN ISR PHOTON FROM INCOMING E+, E-, MU+ OR MU-
14330 C-----------------------------------------------------------------------
14331       INCLUDE 'herwig65.inc'
14332       DOUBLE PRECISION CIRCKP(2)
14333       COMMON /HWCIR2/CIRCKP
14334       DOUBLE PRECISION HWRGEN,QSQMAX,QSQMIN,A,B,B1,B2,B3,B4,B5,B6,B7,B8,
14335      $ R,AA,T0,T1,C1,C2,T,Z(2),QSQ(2),PHI(2),C,NWID,NMASS
14336       INTEGER IHEP,I,J
14337       EXTERNAL HWRGEN
14338       SAVE Z,QSQ,PHI
14339 C---IF ZMXISR IS ZERO, THERE CAN BE NO ISR
14340       IF (ZMXISR.EQ.ZERO.OR.(IPRO.GT.3.AND.IPRO.LT.6)
14341      &     .OR.IPRO.GT.12.OR.IPROC.EQ.850) RETURN
14342 C---CHECK CONSISTENCY OF TMNISR AND ZMXISR
14343       IF (ZMXISR**2.LT.TMNISR) CALL HWWARN('HWEISR',200)
14344 C---CALCULATE VIRTUALITY LIMITS
14345       QSQMAX=4*PHEP(4,IHEP)**2
14346       QSQMIN=PHEP(5,IHEP)**2
14347 C---AND THEREFORE THE Z DEPENDENCE
14348       A=ALPHEM/PIFAC
14349       B=A*(LOG(QSQMAX/QSQMIN)-1)
14350 C---DECIDE HOW MUCH WEIGHT TO GIVE THE Z RESONANCE
14351       IF (IHEP.EQ.1) THEN
14352         IF (IPRO.EQ.1.OR.IPRO.EQ.6.OR.IPRO.EQ.8) THEN
14353           AA=10
14354         ELSEIF (IPRO.EQ.2) THEN
14355           AA=0
14356         ELSEIF (IPRO.EQ.3.OR.IPRO.EQ.7.OR.IPRO.EQ.10.OR.IPRO.EQ.11) THEN
14357           AA=1
14358         ELSEIF (IPRO.EQ.9) THEN
14359           AA=0
14360           IF((MOD(IPROC,10000).EQ.960).OR.
14361      &       (MOD(IPROC,10000).EQ.970))THEN
14362             AA=1
14363           ELSE
14364             CONTINUE
14365           ENDIF
14366         ELSE
14367           RETURN
14368         ENDIF
14369 C--set up the parameters for the resonance
14370         IF(IPRO.NE.8) THEN
14371 C--first the standard parameters if smoothing the Z resonance
14372           T0=RMASS(200)**2/QSQMAX
14373           T1=GAMZ*RMASS(200)/QSQMAX
14374         ELSE
14375 C--now the parameters for a resonant sneutrino in RPV
14376 C--uses the average of the muon and tau sneutrino mass and either the
14377 C--larger width or the difference in masses (whichever is larger)
14378           NMASS = HALF*(RMASS(428)+RMASS(430))
14379           NWID  = MAX(HBAR/RLTIM(428),HBAR/RLTIM(430))
14380           NWID  = MAX(NWID,ABS(RMASS(428)-RMASS(430)))
14381           T0    = NMASS**2/QSQMAX
14382           T1    = NWID*NMASS/QSQMAX
14383         ENDIF
14384         IF (T0.GT.ONE) THEN
14385           T0=0
14386           AA=0
14387         ENDIF
14388         AA=AA*(1-T0)
14389 C---GENERATE A T VALUE BETWEEN TMNISR AND 1 ACCORDING TO:
14390 C   ( b**2*log(zmxisr**2/t)/t + 2*b*(1-(1-zmxisr)**b)*((1-t)**(2*b-1)+1/t
14391 C     +(1-t0)**(2b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr**2-t)
14392 C  +( 2*b*(1-zmxisr)**b*((1-t)**(b-1)+1/t
14393 C     +(1-t0)**(b-1)*aa*t1/((t-t0)**2+t1**2))  ) *theta(zmxisr-t)
14394 C  +( (1-zmxisr)**(2*b)                        ) *delta(1-t)
14395         B1=(1-ZMXISR)**(2*B)
14396         B2=B1+2*(1-ZMXISR)**B*((1-TMNISR)**B-(1-ZMXISR)**B)
14397         B3=B2+2*B*(1-ZMXISR)**B*LOG(ZMXISR/TMNISR)
14398         B4=B3+2*B*(1-ZMXISR)**B*AA*(1-T0)**(B-1)
14399      $       *(ATAN((ZMXISR-T0)/T1)-ATAN((TMNISR-T0)/T1))
14400         B5=B4+(1-(1-ZMXISR)**B)*((1-TMNISR)**(2*B)-(1-ZMXISR**2)**(2*B))
14401         B6=B5+2*B*(1-(1-ZMXISR)**B)*LOG(ZMXISR**2/TMNISR)
14402         B7=B6+B**2*LOG(ZMXISR**2/TMNISR)**2/2
14403         B8=B7+2*B*(1-(1-ZMXISR)**B)*AA*(1-T0)**(2*B-1)
14404      $       *(ATAN((ZMXISR**2-T0)/T1)-ATAN((TMNISR-T0)/T1))
14405         R=B8*HWRGEN(0)
14406         IF (R.LE.B1) THEN
14407 C---NEITHER EMITS
14408           T=1
14409           GAMWT=GAMWT*B8/B1
14410           Z(1)=1
14411         ELSEIF (R.LE.B4) THEN
14412 C---ONE EMITS
14413           IF (R.LE.B2) THEN
14414             R=(R-B1)/(B2-B1)
14415             T=1-(1-TMNISR)*(1-R*(1-((1-ZMXISR)/(1-TMNISR))**B))**(1/B)
14416           ELSEIF (R.LE.B3) THEN
14417             R=(R-B2)/(B3-B2)
14418             T=(TMNISR/ZMXISR)**R*ZMXISR
14419           ELSE
14420             R=(R-B3)/(B4-B3)
14421             T=T0+T1*TAN(
14422      $           ATAN((ZMXISR-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
14423           ENDIF
14424           GAMWT=GAMWT*B8/(2*B*(1-ZMXISR)**B*((1-T)**(B-1)+1/T+
14425      $         (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
14426           Z(1)=1
14427           IF (HWRGEN(1).GT.HALF) Z(1)=T
14428           GAMWT=GAMWT*2
14429         ELSE
14430 C---BOTH EMIT
14431           IF (R.LE.B5) THEN
14432             R=(R-B4)/(B5-B4)
14433             T=1-(1-TMNISR)*
14434      $           (1-R*(1-((1-ZMXISR**2)/(1-TMNISR))**(2*B)))**(.5/B)
14435           ELSEIF (R.LE.B6) THEN
14436             R=(R-B5)/(B6-B5)
14437             T=(TMNISR/ZMXISR**2)**R*ZMXISR**2
14438           ELSEIF (R.LE.B7) THEN
14439             R=(R-B6)/(B7-B6)
14440             T=(TMNISR/ZMXISR**2)**SQRT(R)*ZMXISR**2
14441           ELSE
14442             R=(R-B7)/(B8-B7)
14443             T=T0+T1*TAN(
14444      $           ATAN((ZMXISR**2-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
14445           ENDIF
14446           GAMWT=GAMWT*B8/(B**2*LOG(ZMXISR**2/T)/T
14447      $         + 2*B*(1-(1-ZMXISR)**B)*((1-T)**(2*B-1)+1/T+
14448      $         (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
14449 C---GENERATE A Z VALUE BETWEEN T/ZMXISR AND ZMXISR ACCORDING TO:
14450 C   1/z+(1-z)**(b-1)+t/z**2*(1-t/z)**(b-1)
14451           C1=LOG(ZMXISR**2/T)
14452           C2=C1+2/B*((1-T/ZMXISR)**B-(1-ZMXISR)**B)
14453           IF (C2.GT.ZERO) THEN
14454             R=C2*HWRGEN(4)
14455             IF (R.LE.C1) THEN
14456               Z(1)=(T/ZMXISR**2)**HWRGEN(5)*ZMXISR
14457             ELSE
14458               Z(1)=1-(1-T/ZMXISR)*
14459      $             (1-HWRGEN(6)*(1-((1-ZMXISR)/(1-T/ZMXISR))**B))**(1/B)
14460               IF (2*R.LE.C2+C1) Z(1)=T/Z(1)
14461             ENDIF
14462           ELSE
14463             Z(1)=SQRT(T)
14464           ENDIF
14465           GAMWT=GAMWT*C2/Z(1)
14466      $         /(1/Z(1)+(1-Z(1))**(B-1)+T/Z(1)**2*(1-T/Z(1))**(B-1))
14467         ENDIF
14468 C---INCLUDE DISTRIBUTION FUNCTIONS
14469         Z(2)=T/Z(1)
14470         DO 10 I=1,2
14471           IF (Z(I).GT.ZMXISR) THEN
14472             Z(I)=1
14473             CIRCKP(I)=(1-ZMXISR)**B*EXP(3*B/4)*(1-B**2*PIFAC**2/12)
14474           ELSE
14475             CIRCKP(I)=(B*(1-Z(I))**(B-1)*(1+Z(I)**2)/2
14476      $           *EXP(B*Z(I)/2*(1+Z(I)/2))*(1-B**2*PIFAC**2/12)
14477      $           +B**2/8*((1+Z(I))*((1+Z(I))**2+3*LOG(Z(I)))
14478      $           -4*LOG(Z(I))/(1-Z(I))))
14479           ENDIF
14480           GAMWT=GAMWT*CIRCKP(I)
14481   10    CONTINUE
14482 C---CHOOSE BOTH QSQ VALUES
14483         DO 30 I=1,2
14484           IF (Z(I).GT.ZMXISR .OR. COLISR) THEN
14485             QSQ(I)=0
14486           ELSE
14487             J=3-I
14488 C---ACCORDING TO 1/(QSQ+QSQMIN) FROM 0 TO (1-Z)*(T/(Z+T))*QSQMAX
14489  20         QSQ(I)=(((1-Z(I))*(T/(Z(I)+T))
14490      $           *QSQMAX/QSQMIN+1)**HWRGEN(7)-1)*QSQMIN
14491 C---AND REJECT TO QSQ/(QSQ+QSQMIN)**2
14492             IF (HWRGEN(8)*(QSQ(I)+QSQMIN).GT.QSQ(I)) GOTO 20
14493           ENDIF
14494  30     CONTINUE
14495 C---CHOOSE BOTH AZIMUTHS
14496         PHI(1)=HWRGEN(9)*2*PIFAC
14497         PHI(2)=HWRGEN(10)*2*PIFAC
14498 C---USE S-HAT PRESCRIPTION TO MODIFY Z VALUES
14499         I=0
14500         IF ((1-Z(1))*QSQ(1).GT.(1-Z(2))*QSQ(2)) I=1
14501         IF ((1-Z(2))*QSQ(2).GT.(1-Z(1))*QSQ(1)) I=2
14502         IF (I.GT.0) THEN
14503           J=3-I
14504           Z(I)=Z(I)+QSQ(I)/QSQMAX
14505           IF (QSQ(J).GT.ZERO) THEN
14506             Z(J)=((QSQ(I)*QSQMAX+QSQ(J)*QSQMAX
14507      $           -QSQ(I)*QSQ(J))/QSQMAX**2+T)/Z(I)
14508             C=COS(PHI(1)-PHI(2))*SQRT(QSQ(1)*QSQ(2))/QSQMAX
14509             Z(J)=Z(J)+(-2*C**2*(1-Z(I))+2*C*SQRT((1-Z(I))
14510      $           *(C**2*(1-Z(I))+Z(I)**2*(1-Z(J)))))/Z(I)**2
14511           ENDIF
14512         ENDIF
14513       ELSEIF (IHEP.EQ.2) THEN
14514 C---EVERYTHING WAS GENERATED LAST TIME
14515       ELSE
14516 C---ROUTINE CALLED UNEXPECTEDLY
14517         CALL HWWARN('HWEISR',201)
14518       ENDIF
14519 C---IF Z IS TOO LARGE THERE IS NO EMISSION
14520       IF (Z(IHEP).GT.ZMXISR) RETURN
14521 C---PUT NEW LEPTON IN EVENT RECORD
14522       NHEP=NHEP+1
14523       IDHW(NHEP)=IDHW(IHEP)
14524       IDHEP(NHEP)=IDHEP(IHEP)
14525       ISTHEP(NHEP)=3
14526       JMOHEP(1,NHEP)=IHEP
14527       JMOHEP(2,NHEP)=0
14528       JDAHEP(1,NHEP)=0
14529       JDAHEP(2,NHEP)=0
14530       JDAHEP(1,IHEP)=NHEP
14531 C---AND OUTGOING PHOTON
14532       NHEP=NHEP+1
14533       IDHW(NHEP)=59
14534       IDHEP(NHEP)=22
14535       ISTHEP(NHEP)=1
14536       JMOHEP(1,NHEP)=IHEP
14537       JMOHEP(2,NHEP)=0
14538       JDAHEP(1,NHEP)=0
14539       JDAHEP(2,NHEP)=0
14540       JDAHEP(2,IHEP)=NHEP
14541 C---RECONSTRUCT PHOTON KINEMATICS (Z IS LIGHT-CONE MOMENTUM FRACTION)
14542       PHEP(1,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*COS(PHI(IHEP))
14543       PHEP(2,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*SIN(PHI(IHEP))
14544       PHEP(3,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)-QSQ(IHEP)/(4*PHEP(4,IHEP))
14545       IF (IHEP.EQ.2) PHEP(3,NHEP)=-PHEP(3,NHEP)
14546       PHEP(4,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)+QSQ(IHEP)/(4*PHEP(4,IHEP))
14547       PHEP(5,NHEP)=0
14548 C---AND LEPTON
14549       CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP),PHEP(1,NHEP-1))
14550       CALL HWUMAS(PHEP(1,NHEP-1))
14551 C---UPDATE OVERALL CM FRAME
14552       JMOHEP(IHEP,3)=NHEP-1
14553       CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
14554       CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,3),PHEP(1,3))
14555       CALL HWUMAS(PHEP(1,3))
14556       END
14557 CDECK  ID>, HWEONE.
14558 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
14559 *-- Author :    Bryan Webber
14560 C-----------------------------------------------------------------------
14561       SUBROUTINE HWEONE
14562 C-----------------------------------------------------------------------
14563 C     SETS UP 2->1 (COLOUR SINGLET) HARD SUBPROCESS
14564 C-----------------------------------------------------------------------
14565       INCLUDE 'herwig65.inc'
14566       DOUBLE PRECISION PA
14567       INTEGER ICMF,I,IBM,IHEP
14568 C---INCOMING LINES
14569       ICMF=NHEP+3
14570       DO 15 I=1,2
14571       IBM=I
14572 C---FIND BEAM AND TARGET
14573       IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
14574       IHEP=NHEP+I
14575       IDHW(IHEP)=IDN(I)
14576       IDHEP(IHEP)=IDPDG(IDN(I))
14577       ISTHEP(IHEP)=110+I
14578       JMOHEP(1,IHEP)=ICMF
14579       JMOHEP(I,ICMF)=IHEP
14580       JDAHEP(1,IHEP)=ICMF
14581 C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
14582       IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
14583         CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
14584         IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
14585       ELSE
14586         PHEP(1,IHEP)=0.
14587         PHEP(2,IHEP)=0.
14588         PHEP(5,IHEP)=RMASS(IDN(I))
14589         PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
14590         PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
14591         PHEP(3,IHEP)=PA-PHEP(4,IHEP)
14592       ENDIF
14593  15   CONTINUE
14594       PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
14595 C---HARD CENTRE OF MASS
14596       IDHW(ICMF)=IDCMF
14597       IDHEP(ICMF)=IDPDG(IDCMF)
14598       ISTHEP(ICMF)=110
14599       CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
14600       CALL HWUMAS(PHEP(1,ICMF))
14601 C---SET UP COLOUR STRUCTURE LABELS
14602       JMOHEP(2,NHEP+1)=NHEP+2
14603       JDAHEP(2,NHEP+1)=NHEP+2
14604       JMOHEP(2,NHEP+2)=NHEP+1
14605       JDAHEP(2,NHEP+2)=NHEP+1
14606       JDAHEP(1,NHEP+3)=NHEP+3
14607       JDAHEP(2,NHEP+3)=NHEP+3
14608       NHEP=NHEP+3
14609       END
14610 CDECK  ID>, HWEPRO.
14611 *CMZ :-        -15/07/02  17.56.53  by  Peter Richardson
14612 *-- Author :    Bryan Webber
14613 C-----------------------------------------------------------------------
14614       SUBROUTINE HWEPRO
14615 C-----------------------------------------------------------------------
14616 C     WHEN NEVHEP=0, CHOOSES X VALUES AND FINDS WEIGHT FOR PROCESS IPROC
14617 C     OTHERWISE, CHOOSES AND LOADS ALL VARIABLES FOR HARD PROCESS
14618 C     modifications for Les Houches accord by PR (7/15/02)
14619 C-----------------------------------------------------------------------
14620       INCLUDE 'herwig65.inc'
14621       DOUBLE PRECISION CIRCKP(2)
14622       COMMON /HWCIR2/CIRCKP
14623       DOUBLE PRECISION Z1,Z2,C1,C2,B1,B2,CIRCEE,CIRCGG,RS,MISS,ETA,
14624      $     HWUGAU,HWECIR,QMX1,QMN1,QMX2,QMN2,TEST
14625       INTEGER IHAD
14626       SAVE MISS
14627       DOUBLE PRECISION HWRGEN
14628       EXTERNAL HWRGEN,HWECIR
14629 C--Les Houches Common Block
14630       INTEGER MAXPUP
14631       PARAMETER(MAXPUP=100)
14632       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
14633       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
14634       COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
14635      &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
14636      &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
14637       IF (IERROR.NE.0)  RETURN
14638 C--pick the type of event to generate if using Les Houches accord
14639 C--first choice according to maxiumum weight
14640       IF(IPROC.LT.0) THEN
14641         IF(ABS(IDWTUP).EQ.1) THEN
14642           IF(ITYPLH.EQ.0) THEN
14643             TEST = HWRGEN(1)*LHMXSM
14644             DO ITYPLH=1,NPRUP
14645               IF(TEST.LE.ABS(LHXMAX(ITYPLH))) GOTO 5
14646               TEST = TEST-ABS(LHXMAX(ITYPLH))
14647             ENDDO
14648  5          WGTMAX = ABS(LHXMAX(ITYPLH))
14649             WBIGST = ABS(LHXMAX(ITYPLH))
14650           ENDIF
14651 C--second choice according to cross section
14652         ELSEIF(ABS(IDWTUP).EQ.2) THEN
14653           IF(ITYPLH.EQ.0) THEN
14654             TEST = HWRGEN(1)*LHMXSM
14655             DO ITYPLH=1,NPRUP
14656               IF(TEST.LE.ABS(LHXSCT(ITYPLH))) GOTO 6
14657               TEST = TEST-ABS(LHXSCT(ITYPLH))
14658             ENDDO
14659  6          WGTMAX = ABS(LHXMAX(ITYPLH))
14660             WBIGST = ABS(LHXMAX(ITYPLH))
14661           ENDIF
14662         ELSE
14663           WGTMAX = 1.0D0
14664           WBIGST = 1.0D0
14665           ITYPLH = 1
14666         ENDIF
14667       ENDIF
14668 C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS NOT ACCEPTED
14669    10 GENEV=.FALSE.
14670 C---FSTWGT IS .TRUE. DURING FIRST CALL TO HARD PROCESS ROUTINE
14671       FSTWGT=NWGTS.EQ.0
14672 C---FSTEVT IS .TRUE. THROUGHOUT THE FIRST EVENT
14673       FSTEVT=NEVHEP.EQ.1
14674 C---SET COLOUR CORRECTION TO FALSE
14675       COLUPD = .FALSE.
14676       HRDCOL(1,1)=0
14677       HRDCOL(1,3)=0
14678 C---SET UP INITIAL STATE
14679       NHEP=1
14680       ISTHEP(NHEP)=101
14681       PHEP(1,NHEP)=0.
14682       PHEP(2,NHEP)=0.
14683       PHEP(3,NHEP)=PBEAM1
14684       PHEP(4,NHEP)=EBEAM1
14685       PHEP(5,NHEP)=RMASS(IPART1)
14686       JMOHEP(1,NHEP)=0
14687       JMOHEP(2,NHEP)=0
14688       JDAHEP(1,NHEP)=0
14689       JDAHEP(2,NHEP)=0
14690       IDHW(NHEP)=IPART1
14691       IDHEP(NHEP)=IDPDG(IPART1)
14692       NHEP=NHEP+1
14693       ISTHEP(NHEP)=102
14694       PHEP(1,NHEP)=0.
14695       PHEP(2,NHEP)=0.
14696       PHEP(3,NHEP)=-PBEAM2
14697       PHEP(4,NHEP)=EBEAM2
14698       PHEP(5,NHEP)=RMASS(IPART2)
14699       JMOHEP(1,NHEP)=0
14700       JMOHEP(2,NHEP)=0
14701       JDAHEP(1,NHEP)=0
14702       JDAHEP(2,NHEP)=0
14703       IDHW(NHEP)=IPART2
14704       IDHEP(NHEP)=IDPDG(IPART2)
14705 C---NEXT ENTRY IS OVERALL CM FRAME
14706       NHEP=NHEP+1
14707       IDHW(NHEP)=14
14708       IDHEP(NHEP)=0
14709       ISTHEP(NHEP)=103
14710       JMOHEP(1,NHEP)=NHEP-2
14711       JMOHEP(2,NHEP)=NHEP-1
14712       JDAHEP(1,NHEP)=0
14713       JDAHEP(2,NHEP)=0
14714       CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
14715       CALL HWUMAS(PHEP(1,NHEP))
14716 C Select a primary interaction point
14717       IF (PIPSMR) THEN
14718         CALL HWRPIP
14719       ELSE
14720         CALL HWVZRO(4,VTXPIP)
14721       ENDIF
14722       CALL HWVEQU(3,VTXPIP,VHEP(1,NHEP))
14723       VHEP(4,NHEP)=0.0
14724 C---GENERATE PHOTONS (WEIZSACKER-WILLIAMS APPROX)
14725 C   FOR HADRONIC PROCESSES WITH LEPTON BEAMS
14726       GAMWT=ONE
14727       IF (IPRO.GT.12.AND.IPRO.LT.90) THEN
14728         IF (CIRCOP.EQ.0) THEN
14729            IF (ABS(IDHEP(1)).EQ.11.OR.ABS(IDHEP(1)).EQ.13)
14730      &          CALL HWEGAM(1,ZERO, ONE,.FALSE.)
14731            IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
14732      &          CALL HWEGAM(2,ZERO, ONE,.FALSE.)
14733         ELSE
14734 C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
14735           IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
14736      $         'This version only works for e+e- annihilation'
14737           IF (FSTWGT) THEN
14738             RS=NINT(PHEP(5,3)*10)/1D1
14739             CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
14740           ENDIF
14741           CALL HWEGAM(1,ZERO, ONE,.TRUE.)
14742           CALL HWEGAM(2,ZERO, ONE,.TRUE.)
14743           Z1=PHEP(4,4)/PHEP(4,1)
14744           Z2=PHEP(4,6)/PHEP(4,2)
14745 C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
14746           C1=CIRCGG(Z1,-1D0)/SQRT(CIRCGG(-1D0,-1D0))
14747           C2=CIRCGG(-1D0,Z2)/SQRT(CIRCGG(-1D0,-1D0))
14748 C---REMOVE SPURIOUS WEIGHT GIVEN IN HWEGAM
14749           GAMWT=GAMWT/(.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*
14750      $         LOG((ONE-Z1)/Z1*4*PHEP(4,1)*PHEP(4,2)/PHEP(5,1)**2))
14751      $               /(.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*
14752      $         LOG((ONE-Z2)/Z2*4*PHEP(4,4)*PHEP(4,2)/PHEP(5,1)**2))
14753 C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
14754           QMX1=MIN(Q2WWMX,(Z1*PHEP(3,1))**2)
14755           QMN1=MAX(Q2WWMN,(PHEP(5,1)*Z1)**2/(1-Z1))
14756           QMX2=MIN(Q2WWMX,(Z2*PHEP(3,2))**2)
14757           QMN2=MAX(Q2WWMN,(PHEP(5,2)*Z2)**2/(1-Z2))
14758           B1=.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*LOG(QMX1/QMN1)
14759           B2=.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*LOG(QMX2/QMN2)
14760           IF (CIRCOP.EQ.1) THEN
14761             GAMWT=GAMWT*B1*B2
14762           ELSEIF (CIRCOP.EQ.2) THEN
14763             GAMWT=GAMWT*C1*C2
14764           ELSEIF (CIRCOP.EQ.3) THEN
14765             GAMWT=GAMWT*(C1+B1)*(C2+B2)
14766           ELSE
14767             STOP 'Illegal value of circop!'
14768           ENDIF
14769         ENDIF
14770       ELSEIF (IPRO.GE.90) THEN
14771         IF (CIRCOP.NE.0) STOP 'Circe not interfaced for DIS processes'
14772         IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
14773      &       CALL HWEGAM(2,ZERO, ONE,.FALSE.)
14774       ENDIF
14775 C---GENERATE ISR PHOTONS FOR LEPTONIC PROCESSES
14776       IF (IPRO.GT.0.AND.IPRO.LE.12) THEN
14777         IF (CIRCOP.EQ.0) THEN
14778            CALL HWEISR(1)
14779            CALL HWEISR(2)
14780         ELSE
14781 C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
14782           IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
14783      $         'This version only works for e+e- annihilation'
14784           IF (FSTWGT) THEN
14785             RS=NINT(PHEP(5,3)*10)/1D1
14786             CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
14787 C---PRECALCULATE THE PART OF THE SPECTRUM MISSED BETWEEN ZMXISR AND 1
14788             ETA=0.6D0
14789             MISS=HWUGAU(HWECIR,1D-15**(1-ETA),(1-ZMXISR)**(1-ETA),1D-12)
14790           ENDIF
14791           COLISR=.TRUE.
14792           CALL HWEISR(1)
14793           CALL HWEISR(2)
14794           IHAD=1
14795           IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
14796           Z1=PHEP(4,IHAD)/PHEP(4,1)
14797           IHAD=2
14798           IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
14799           Z2=PHEP(4,IHAD)/PHEP(4,2)
14800 C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
14801           C1=CIRCEE(Z1,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
14802           C2=CIRCEE(-1D0,Z2)/SQRT(CIRCEE(-1D0,-1D0))
14803           IF (Z1.EQ.ONE) C1=C1+MISS
14804           IF (Z2.EQ.ONE) C2=C2+MISS
14805 C---REMOVE WEIGHT GIVEN IN HWEISR
14806           B1=CIRCKP(1)
14807           B2=CIRCKP(2)
14808           GAMWT=GAMWT/(B1*B2)
14809 C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
14810           IF (CIRCOP.EQ.1) THEN
14811             GAMWT=GAMWT*B1*B2
14812           ELSEIF (CIRCOP.EQ.2) THEN
14813             GAMWT=GAMWT*C1*C2
14814           ELSEIF (CIRCOP.EQ.3) THEN
14815 C---IN THE APPROXIMATION OF DOMINANCE BY THE DELTA-FUNCTION TERM
14816             IF (Z1.EQ.ONE) C1=C1-1
14817             IF (Z2.EQ.ONE) C2=C2-1
14818 C---IF IT DOES NOT DOMINATE, ZMXISR SHOULD BE DECREASED
14819             IF (B1+C1.LT.ZERO) CALL HWWARN('HWEPRO',501)
14820             IF (B2+C2.LT.ZERO) CALL HWWARN('HWEPRO',502)
14821             GAMWT=GAMWT*(C1+B1)*(C2+B2)
14822           ELSE
14823             STOP 'Illegal value of circop!'
14824           ENDIF
14825         ENDIF
14826       ENDIF
14827 C---IF USER LIMITS WERE TOO TIGHT, MIGHT NOT BE ANY PHASE-SPACE
14828       IF (GAMWT.LE.ZERO) GOTO 30
14829 C---IF CMF HAS ACQUIRED A TRANSVERSE BOOST, OR USER REQUESTS IT ANYWAY,
14830 C   BOOST EVENT RECORD BACK TO CMF
14831       IF (PHEP(1,3)**2+PHEP(2,3)**2.GT.ZERO .OR. USECMF) CALL HWUBST(1)
14832 C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS ACCEPTED
14833    20 CONTINUE
14834       IPRO=MOD(IPROC/100,100)
14835 C---PROCESS GENERATED BY LES HOUCHES INTERFACE
14836       IF(IPRO.LE.0) THEN
14837         CALL HWHGUP
14838 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
14839       ELSEIF (IPRO.EQ.1) THEN
14840         IF (IPROC.LT.110.OR.IPROC.GE.120) THEN
14841 C--- E+E- -> Q-QBAR OR L-LBAR
14842           CALL HWHEPA
14843         ELSE
14844 C--- E+E- -> Q-QBAR-GLUON
14845           CALL HWHEPG
14846         ENDIF
14847       ELSEIF (IPRO.EQ.2) THEN
14848 C--- E+E- -> W+ W-
14849         CALL HWHEWW
14850       ELSEIF (IPRO.EQ.3) THEN
14851 C---E+E- -> Z H
14852         CALL HWHIGZ
14853       ELSEIF (IPRO.EQ.4) THEN
14854 C---E+E- -> NUEB NUE H
14855         CALL HWHIGW
14856       ELSEIF (IPRO.EQ.5 .AND. IPROC.LT.550) THEN
14857 C---EE -> EE GAMGAM -> EE FFBAR/WW
14858         CALL HWHEGG
14859       ELSEIF (IPRO.EQ.5) THEN
14860 C---EE -> ENU GAMW -> ENU FF'BAR/WZ
14861         CALL HWHEGW
14862       ELSEIF (IPRO.EQ.6) THEN
14863 C---EE -> FOUR JETS
14864         CALL HWH4JT
14865       ELSEIF(IPRO.EQ.7) THEN
14866 C--EE -> SUSY PARTICLES(PAIR PRODUCTION)
14867         CALL HWHESP
14868       ELSEIF(IPRO.EQ.8) THEN
14869 C--EE -> RPV SUSY PARTICLE PRODUCTION
14870         CALL HWHREP
14871       ELSEIF (IPRO.EQ.9) THEN
14872         IF((MOD(IPROC,10000).EQ.955).OR.
14873      &     (MOD(IPROC,10000).EQ.965).OR.
14874      &     (MOD(IPROC,10000).EQ.975))THEN
14875 C---MSSM Higgs pair production in l+l-: H+ H- and A0 Higgs, Higgs=h0,H0.
14876           CALL HWHIHH
14877         ELSEIF((MOD(IPROC,10000).EQ.910).OR.
14878      &         (MOD(IPROC,10000).EQ.920))THEN
14879 C---MSSM scalar Higgs production from vector-vector fusion.
14880           CALL HWHIGW
14881         ELSEIF((MOD(IPROC,10000).EQ.960).OR.
14882      &         (MOD(IPROC,10000).EQ.970))THEN
14883 C---MSSM scalar Higgs production from Higgs-strahlung.
14884           CALL HWHIGZ
14885         END IF
14886       ELSEIF ((IPRO.EQ.10).OR.(IPRO.EQ.11)) THEN
14887 C---SM/MSSM Higgs production with heavy quark flavours via e+e-.
14888         CALL HWHIGE
14889       ELSEIF (IPRO.EQ.13) THEN
14890 C---GAMMA/Z0/Z' DRELL-YAN PROCESS
14891         CALL HWHDYP
14892       ELSEIF (IPRO.EQ.14) THEN
14893 C---W+/- PRODUCTION VIA DRELL-YAN PROCESS
14894         CALL HWHWPR
14895       ELSEIF (IPRO.EQ.15) THEN
14896 C---QCD HARD 2->2 PROCESSES
14897         CALL HWHQCD
14898       ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN
14899 C---SM/MSSM HIGGS PRODUCTION VIA QUARK/GLUON FUSION
14900         CALL HWHIGS
14901       ELSEIF (IPRO.EQ.17) THEN
14902 C---QCD HEAVY FLAVOUR PRODUCTION
14903         CALL HWHHVY
14904       ELSEIF (IPRO.EQ.18) THEN
14905 C---QCD DIRECT PHOTON + JET PRODUCTION
14906         CALL HWHPHO
14907       ELSEIF ((IPRO.EQ.19).OR.(IPRO.EQ.37)) THEN
14908 C---SM/MSSM HIGGS PRODUCTION VIA W/Z FUSION
14909         CALL HWHIGW
14910       ELSEIF (IPRO.EQ.20) THEN
14911 C---TOP PRODUCTION FROM W EXCHANGE
14912         CALL HWHWEX
14913       ELSEIF (IPRO.EQ.21) THEN
14914 C---VECTOR BOSON + JET PRODUCTION
14915         CALL HWHV1J
14916       ELSEIF (IPRO.EQ.22) THEN
14917 C QCD direct photon pair production
14918         CALL HWHPH2
14919       ELSEIF (IPRO.EQ.23) THEN
14920 C QCD Higgs plus jet production
14921         CALL HWHIGJ
14922       ELSEIF (IPRO.EQ.24) THEN
14923 C---COLOUR-SINGLET EXCHANGE
14924         CALL HWHSNG
14925       ELSEIF (IPRO.EQ.25) THEN
14926 C---SM Higgs production with heavy quark flavours via qq and gg.
14927         CALL HWHIGQ
14928       ELSEIF ((IPRO.EQ.26).OR.(IPRO.EQ.27)) THEN
14929 C---SM Higgs production with heavy gauge bosons via qq(').
14930         CALL HWHIGV
14931 C---Gauge boson pair in hadron hadron
14932       ELSEIF (IPRO.EQ.28) THEN
14933         IF (MOD(IPROC,10000).LT.2850) THEN
14934           CALL HWHGBP
14935         ELSE
14936           CALL HWHVVJ
14937         ENDIF
14938 C--Vector boson + two jets
14939       ELSEIF(IPRO.EQ.29) THEN
14940         CALL HWHV2J
14941       ELSEIF (IPRO.EQ.30) THEN
14942 C---HADRON-HADRON SUSY PROCESSES
14943         CALL HWHSSP
14944       ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN
14945 C---MSSM charged/neutral Higgs production in association with squarks.
14946         CALL HWHISQ
14947       ELSEIF (IPRO.EQ.33) THEN
14948         IF(MOD(IPROC,10000).EQ.3350)THEN
14949 C---MSSM charged Higgs production in association with W: W+H- + W-H+.
14950           CALL HWHIBK
14951         ELSEIF((MOD(IPROC,10000).EQ.3310).OR.
14952      &         (MOD(IPROC,10000).EQ.3320).OR.
14953      &         (MOD(IPROC,10000).EQ.3360).OR.
14954      &         (MOD(IPROC,10000).EQ.3370))THEN
14955 C---MSSM Higgs production with heavy gauge bosons via qq(').
14956           CALL HWHIGV
14957         ELSE
14958 C---MSSM charged/neutral Higgs pair production.
14959           CALL HWHIGH
14960         END IF
14961       ELSEIF (IPRO.EQ.34) THEN
14962 C---MSSM charged/neutral Higgs production via bg fusion.
14963         CALL HWHIBG
14964       ELSEIF (IPRO.EQ.35) THEN
14965 C---MSSM charged Higgs production via bq fusion.
14966         CALL HWHIBQ
14967       ELSEIF (IPRO.EQ.38) THEN
14968 C---MSSM charged/neutral Higgs production with heavy quarks via qq and gg.
14969         CALL HWHIGQ
14970       ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
14971 C---HADRON-HADRON R-PARITY VIOLATING SUSY PROCESSES
14972         CALL HWHRSP
14973       ELSEIF (IPRO.EQ.42) THEN
14974 C---SPIN-TWO RESONANCE
14975         CALL HWHGRV
14976       ELSEIF (IPRO.EQ.50) THEN
14977 C Point-like photon two-jet production
14978         CALL HWHPPT
14979       ELSEIF (IPRO.EQ.51) THEN
14980 C Point-like photon/QCD heavy flavour pair production
14981         CALL HWHPPH
14982       ELSEIF (IPRO.EQ.52) THEN
14983 C Point-like photon/QCD heavy flavour single excitation
14984         CALL HWHPPE
14985       ELSEIF (IPRO.EQ.53) THEN
14986 C Compton scattering of point-like photon and (anti)quark
14987         CALL HWHPQS
14988       ELSEIF (IPRO.EQ.55) THEN
14989 C Point-like photon/higher twist meson production
14990         CALL HWHPPM
14991       ELSEIF (IPRO.EQ.60) THEN
14992 C---QPM GAMMA-GAMMA-->QQBAR
14993         CALL HWHQPM
14994       ELSEIF (IPRO.GE.70.AND.IPRO.LE.79) THEN
14995 C---BARYON-NUMBER VIOLATION, AND OTHER MULTI-W PRODUCTION PROCESSES
14996         CALL HVHBVI
14997       ELSEIF (IPRO.EQ.80) THEN
14998 C---MINIMUM-BIAS: NO HARD SUBPROCESS
14999 C   FIND WEIGHT
15000         CALL HWMWGT
15001       ELSEIF (IPRO.EQ.90) THEN
15002 C---DEEP INELASTIC
15003         CALL HWHDIS
15004       ELSEIF(IPRO.EQ.91) THEN
15005 C---BOSON - GLUON(QUARK) FUSION -->  ANTIQUARK(GLUON) + QUARK
15006         CALL HWHBGF
15007       ELSEIF(IPRO.EQ.92) THEN
15008 C---DEEP INELASTIC WITH EXTRA JET: OBSOLETE PROCESS
15009         WRITE (6,40)
15010  40     FORMAT (1X,' IPROC=92** is no longer supported.'
15011      &         /1X,' Please use IPROC=91** instead.')
15012         CALL HWWARN('HWEPRO',500)
15013       ELSEIF(IPRO.EQ.95) THEN
15014 C---HIGGS PRODUCTION VIA W FUSION IN E P
15015         CALL HWHIGW
15016 C !!!!!!!!! IPRO >=0 NOT USED BY LH INTERFACE
15017       ELSE
15018 C---UNKNOWN PROCESS
15019         CALL HWWARN('HWEPRO',102)
15020         GOTO 999
15021       ENDIF
15022 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
15023 C genev= false
15024  30   IF (GENEV) THEN
15025          IF (NOWGT) THEN
15026             IF (NEGWTS) THEN
15027                IF (EVWGT.LT.ZERO) THEN
15028                   EVWGT=-AVABW
15029                ELSE
15030                   EVWGT= AVABW
15031                ENDIF
15032             ELSE
15033                EVWGT=AVWGT
15034             ENDIF
15035          ENDIF
15036          ISTAT=10
15037 C--New call spin correlation code if needed
15038          IF(SYSPIN.AND.(IPRO.EQ. 1.OR.IPRO.EQ.13.OR.IPRO.EQ.14.OR.
15039      &                  IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.20.OR.
15040      &                  IPRO.EQ. 7.OR.IPRO.EQ.30.OR.IPRO.EQ.40.OR.
15041      &                  IPRO.EQ.41.OR.IPRO.EQ.8)) CALL HWHSPN
15042 C--generate additional photon radiation in top production
15043          IF(ITOPRD.EQ.1.AND.MOD(IPROC,10000).EQ.1706) CALL HWPHTT
15044          RETURN
15045       ELSE
15046 C---IF AN EVENT IS CANCELLED BEFORE IT IS GENERATED, GIVE IT ZERO WEIGHT
15047         IF (IERROR.NE.0) THEN
15048           EVWGT=ZERO
15049           IERROR=0
15050         ENDIF
15051         EVWGT=EVWGT*GAMWT
15052         NWGTS=NWGTS+1
15053         ABWGT=ABS(EVWGT)
15054         IF (EVWGT.LT.ZERO) THEN
15055            IF (NEGWTS) THEN
15056               NNEGWT=NNEGWT+1
15057            ELSE
15058               IF (EVWGT.LT.-1.D-9) CALL HWWARN('HWEPRO',3)
15059               EVWGT=ZERO
15060               ABWGT=ZERO
15061            ENDIF
15062         ENDIF
15063         WGTSUM=WGTSUM+EVWGT
15064         WSQSUM=WSQSUM+EVWGT**2
15065         ABWSUM=ABWSUM+ABWGT
15066 C--weight addition for Les Houches accord
15067         IF(IPROC.LE.0) THEN
15068           IF(ABS(IDWTUP).EQ.1) THEN
15069              LHWGT (ITYPLH) = LHWGT (ITYPLH)+EVWGT
15070              LHWGTS(ITYPLH) = LHWGTS(ITYPLH)+EVWGT**2
15071              LHIWGT(ITYPLH) = LHIWGT(ITYPLH)+1
15072           ENDIF
15073         ENDIF
15074         IF (ABWGT.GT.WBIGST) THEN
15075            WBIGST=ABWGT
15076            IF (NOWGT.AND.WBIGST.GT.WGTMAX) THEN
15077               IF (NEVHEP.NE.0) CALL HWWARN('HWEPRO',1)
15078               WGTMAX=WBIGST*1.1
15079               WRITE (6,99) WGTMAX
15080 C--additional for Les Houche accord
15081               IF(IPROC.LE.0) THEN
15082                 IF(ABS(IDWTUP).EQ.1)
15083      &                LHMXSM = LHMXSM-LHXMAX(ITYPLH)+ABWGT
15084                 LHXMAX(ITYPLH) = EVWGT
15085               ENDIF
15086            ENDIF
15087         ENDIF
15088         IF (NEVHEP.NE.0) THEN
15089 C---LOW EFFICIENCY WARNINGS:
15090 C   WARN AT 10*EFFMIN, STOP AT EFFMIN
15091           IF (10*EFFMIN*NWGTS.GT.NEVHEP) THEN
15092             IF (EFFMIN*NWGTS.GT.NEVHEP) THEN
15093                WRITE (*,*) NWGTS
15094                CALL HWWARN('HWEPRO',200)
15095             ENDIF
15096             IF (EFFMIN.GT.ZERO) THEN
15097               IF (MOD(NWGTS,INT(10/EFFMIN)).EQ.0) THEN
15098                 CALL HWWARN('HWEPRO',2)
15099                 WRITE (6,98) WGTMAX
15100               ENDIF
15101             ENDIF
15102           ENDIF
15103           IF (NOWGT) THEN
15104             GENEV=ABWGT.GT.WGTMAX*HWRGEN(0)
15105           ELSE
15106             GENEV=ABWGT.NE.ZERO
15107           ENDIF
15108           IF (GENEV)  GOTO 20
15109           GOTO 10
15110         ENDIF
15111       ENDIF
15112  98   FORMAT(10X,'    MAXIMUM WEIGHT =',1PG24.16)
15113  99   FORMAT(10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
15114  999  RETURN
15115       END
15116 CDECK  ID>, HWETWO.
15117 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
15118 *-- Author :    Bryan Webber
15119 C-----------------------------------------------------------------------
15120       SUBROUTINE HWETWO(SMR3,SMR4)
15121 C-----------------------------------------------------------------------
15122 C     SETS UP 2->2 HARD SUBPROCESS
15123 c BRW change 18/8/04: BW smearing of mass i only if SMRi is true
15124 C-----------------------------------------------------------------------
15125       INCLUDE 'herwig65.inc'
15126       DOUBLE PRECISION HWUMBW,HWUPCM,PA,PCM
15127       INTEGER ICMF,IBM,I,J,K,IHEP,NTRY
15128       LOGICAL SMR3,SMR4
15129       EXTERNAL HWUPCM
15130 C---INCOMING LINES
15131       ICMF=NHEP+3
15132       DO 15 I=1,2
15133       IBM=I
15134 C---FIND BEAM AND TARGET
15135       IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
15136       IHEP=NHEP+I
15137       IDHW(IHEP)=IDN(I)
15138       IDHEP(IHEP)=IDPDG(IDN(I))
15139       ISTHEP(IHEP)=110+I
15140       JMOHEP(1,IHEP)=ICMF
15141       JMOHEP(I,ICMF)=IHEP
15142       JDAHEP(1,IHEP)=ICMF
15143 C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
15144       IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
15145         CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
15146         IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
15147       ELSE
15148         PHEP(1,IHEP)=0.
15149         PHEP(2,IHEP)=0.
15150         PHEP(5,IHEP)=RMASS(IDN(I))
15151         PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
15152         PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
15153         PHEP(3,IHEP)=PA-PHEP(4,IHEP)
15154       ENDIF
15155  15   CONTINUE
15156       PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
15157 C---HARD CENTRE OF MASS
15158       IDHW(ICMF)=IDCMF
15159       IDHEP(ICMF)=IDPDG(IDCMF)
15160       ISTHEP(ICMF)=110
15161       CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
15162       CALL HWUMAS(PHEP(1,ICMF))
15163 C---OUTGOING LINES
15164       NTRY=0
15165       DO 16 I=3,4
15166       IHEP=NHEP+I+1
15167       IDHW(IHEP)=IDN(I)
15168       IDHEP(IHEP)=IDPDG(IDN(I))
15169       ISTHEP(IHEP)=110+I
15170       JMOHEP(1,IHEP)=ICMF
15171  16   JDAHEP(I-2,ICMF)=IHEP
15172  19   CONTINUE
15173       IF (SMR3) THEN
15174          PHEP(5,NHEP+4)=HWUMBW(IDN(3))
15175       ELSE
15176          PHEP(5,NHEP+4)=RMASS(IDN(3))
15177       ENDIF
15178       IF (SMR4) THEN
15179          PHEP(5,NHEP+5)=HWUMBW(IDN(4))
15180       ELSE
15181          PHEP(5,NHEP+5)=RMASS(IDN(4))
15182       ENDIF
15183       PCM=HWUPCM(PHEP(5,NHEP+3),PHEP(5,NHEP+4),PHEP(5,NHEP+5))
15184       IF (PCM.LT.ZERO) THEN
15185         NTRY=NTRY+1
15186         IF (NTRY.LE.NETRY) GO TO 19
15187         CALL HWWARN('HWETWO',103)
15188         GOTO 999
15189       ENDIF
15190       IHEP=NHEP+4
15191       PHEP(4,IHEP)=SQRT(PCM**2+PHEP(5,IHEP)**2)
15192       PHEP(3,IHEP)=PCM*COSTH
15193       PHEP(1,IHEP)=SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
15194       CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
15195       CALL HWULOB(PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,IHEP))
15196       CALL HWVDIF(4,PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,NHEP+5))
15197 C---SET UP COLOUR STRUCTURE LABELS
15198       DO 30 I=1,4
15199       J=I
15200       IF (J.GT.2) J=J+1
15201       K=ICO(I)
15202       IF (K.GT.2) K=K+1
15203       JMOHEP(2,NHEP+J)=NHEP+K
15204    30 JDAHEP(2,NHEP+K)=NHEP+J
15205       NHEP=NHEP+5
15206  999  RETURN
15207       END
15208 CDECK  ID>, HWH2BK.
15209 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
15210 *-- Author :  Stefano Moretti
15211 C-----------------------------------------------------------------------
15212       SUBROUTINE HWH2BK(P1,P2,P3,P4,RMW,RMH,RES,RESL,REST)
15213 C-----------------------------------------------------------------------
15214 C...Matrix element for q(1) + q-bar(2) -> W+/-(3) +  H-/+(4),
15215 C...all masses retained.
15216 C...It factorises (PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
15217 C
15218 C...First release:  1-APR-1998 by Stefano Moretti
15219 C-----------------------------------------------------------------------
15220       INCLUDE 'herwig65.inc'
15221       INTEGER I
15222       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
15223       DOUBLE PRECISION P(0:3)
15224       DOUBLE PRECISION RES,S,T,U,MB2,MT2,MW2,MHP2,MH02,MA02,MSH2,
15225      &                 MGAMH0,MGAMA0,MGAMSH,PT,NC,KT2,RESL,REST
15226       DOUBLE PRECISION TT,UU,KKT2,TL
15227       DOUBLE COMPLEX Z,PV,PA
15228       DOUBLE PRECISION RMB,RMT,RMW,RMH
15229       DOUBLE PRECISION RMH01,GAMH01,
15230      &                 RMH02,GAMH02,
15231      &                 RMH03,GAMH03
15232       DOUBLE PRECISION VP,CFC
15233       EQUIVALENCE (RMB  ,RMASS(  5)),(RMT  ,RMASS(  6))
15234       EQUIVALENCE (RMH01,RMASS(204)),
15235      &            (RMH02,RMASS(203)),
15236      &            (RMH03,RMASS(205))
15237       PARAMETER (Z=(0D0,1D0),NC=3)
15238 C...Higgs widths.
15239       GAMH01=RMASS(204)/DKLTM(204)
15240       GAMH02=RMASS(203)/DKLTM(203)
15241       GAMH03=RMASS(205)/DKLTM(205)
15242 C...constant terms.
15243       MB2=RMB*RMB
15244       MT2=RMT*RMT
15245       MW2=RMW*RMW
15246       MHP2=RMH  *RMH
15247       MH02=RMH01*RMH01
15248       MA02=RMH03*RMH03
15249       MSH2=RMH02*RMH02
15250       MGAMH0=RMH01*GAMH01
15251       MGAMA0=RMH03*GAMH03
15252       MGAMSH=RMH02*GAMH02
15253 C...Mandelstam invariants.
15254       S=(P1(0)+P2(0))**2
15255       T=(P1(0)-P3(0))**2
15256       U=(P1(0)-P4(0))**2
15257         DO I=1,3
15258           S=S-(P1(I)+P2(I))**2
15259           T=T-(P1(I)-P3(I))**2
15260           U=U-(P1(I)-P4(I))**2
15261         END DO
15262 C...propagators and couplings.
15263       PV=(-SINA*COSBMA/(S-MSH2+Z*MGAMSH)
15264      &    -COSA*SINBMA/(S-MH02+Z*MGAMH0) )/COSB
15265       PA=         TANB/(S-MA02+Z*MGAMA0)
15266       PT=         1./(T-MT2)
15267       KT2=(U*T-MHP2*MW2)/S
15268 C...Total ME.
15269       RES=S/NC*( MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
15270      & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
15271      & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
15272      & PT**2*((MT2/TANB)**2*(2.*MW2+KT2)
15273      & +MB2*TANB**2*(2.*MW2*KT2+T**2)))
15274      & *2.
15275 C...Extracts spin dependence.
15276       VP=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
15277       CFC=P3(0)/VP
15278       DO I=1,3
15279         P(I)=P3(I)*CFC
15280       END DO
15281       P(0)=VP**2/P3(0)*CFC
15282       TT=(P1(0)-P(0))**2
15283       UU=(P2(0)-P(0))**2
15284       DO I=1,3
15285         TT=TT-(P1(I)-P(I))**2
15286         UU=UU-(P2(I)-P(I))**2
15287       END DO
15288       KKT2=((MW2+TT)*(MW2+UU)+(MW2+MHP2-T-U)*MW2)/S
15289       TL=((TT+MW2)*(UU+MW2)*((S+U-MW2)*(TT+MW2)/(UU+MW2)-T)
15290      &  +MW2*((MW2-T)*(MW2-U)-S*MW2))/S
15291 C...Longitudinal ME (along V direction).
15292       RESL=S/NC*(MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
15293      & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
15294      & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
15295      & PT**2*((MT2/TANB)**2*(KKT2)
15296      & +MB2*TANB**2*(TL)))
15297      & *2.
15298 C...Transverse ME (perpendicular to V direction).
15299       REST=RES-RESL
15300       END
15301 CDECK  ID>, HWH2DD.
15302 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
15303 *-- Author :    Peter Richardson
15304 C-----------------------------------------------------------------------
15305       FUNCTION HWH2DD(ND,I,J,K,L,Z1,Z2)
15306 C-----------------------------------------------------------------------
15307 C     Returns the coefficient D1-10 from Nucl. Phys. B262 (1985) 235-262
15308 C     N.B. THE STRONG COUPLING AND GV+/-GA ARE INCLUDED IN THE CROSS
15309 C     SECTION ROUTINE
15310 C     I-L are the particles (all outgoing)
15311 C     Z1 and Z2 are the decay products of the Z
15312 C-----------------------------------------------------------------------
15313       INCLUDE 'herwig65.inc'
15314       INTEGER ND,I,J,K,L,Z1,Z2
15315       DOUBLE COMPLEX HWH2DD,ZI,S,D,F
15316       PARAMETER(ZI=(0.0D0,1.0D0))
15317       COMMON/HWHEWS/S(8,8,2),D(8,8)
15318       COMMON/HWHZBB/F(8,8)
15319       IF(ND.EQ.1) THEN
15320         HWH2DD = ZI
15321       ELSEIF(ND.EQ.2) THEN
15322         HWH2DD =  ZI/F(J,K)/SQRT(TWO*D(I,K))
15323       ELSEIF(ND.EQ.3) THEN
15324         HWH2DD = -ZI/F(I,K)/SQRT(TWO*D(I,K))
15325       ELSEIF(ND.EQ.4) THEN
15326         HWH2DD = -ZI/F(K,L)/(F(Z1,I)+F(Z2,I)+F(Z1,Z2))
15327       ELSEIF(ND.EQ.5) THEN
15328         HWH2DD =  ZI/F(K,L)/(F(Z1,J)+F(Z2,J)+F(Z1,Z2))
15329       ELSEIF(ND.EQ.6) THEN
15330         HWH2DD =  ZI*HALF/F(J,L)/(F(J,L)+F(J,K)+F(K,L))/D(K,L)
15331       ELSEIF(ND.EQ.7) THEN
15332         HWH2DD = -ZI*HALF/F(I,K)/F(J,L)/D(K,L)
15333       ELSEIF(ND.EQ.8) THEN
15334         HWH2DD =  ZI*HALF/F(I,K)/(F(I,K)+F(I,L)+F(K,L))/D(K,L)
15335       ELSEIF(ND.EQ.9) THEN
15336         HWH2DD = -ZI/F(K,L)/(F(J,K)+F(J,L)+F(K,L))
15337       ELSEIF(ND.EQ.10) THEN
15338         HWH2DD =  ZI/F(K,L)/(F(I,K)+F(I,L)+F(K,L))
15339       ENDIF
15340       END
15341 CDECK  ID>, HWH2BH.
15342 *CMZ :-        -30/06/01  18.21.35  by  Stefano Moretti
15343 *-- Author :  Kosuke Odagiri & Stefano Moretti
15344 C-----------------------------------------------------------------------
15345       SUBROUTINE HWH2BH(P1,P2,P3,P4,P5,
15346      &                  EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,IFL,IRES,CKM,
15347      &                  GAMT,M2)
15348 C-----------------------------------------------------------------------
15349 C...Matrix element for b(1) + q(2) -> b(3) + q'(4) + H+/-(5) and C.C.,
15350 C...q(q') massless incoming(outgoing) quark, all other masses retained.
15351 C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW.
15352 C
15353 C...First release:  01-APR-1998 by Kosuke Odagiri
15354 C...First modified: 12-APR-1998 by Stefano Moretti
15355 C-----------------------------------------------------------------------
15356       INCLUDE 'herwig65.inc'
15357       INTEGER MU,IRES,IFL
15358       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
15359       DOUBLE PRECISION EMB,EMT,EMW,EMH,EMH01,EMH02,EMH03
15360       DOUBLE PRECISION GAMT,GAMWTMP,GAMH01,GAMH03,GAMH02,CKM
15361       DOUBLE PRECISION QW(0:3),QS(0:3)
15362       DOUBLE PRECISION N0,DOTHH,DOTSS,DOTWW,E1234
15363       DOUBLE PRECISION DOTTT,DOT12,DOT13,DOT14,DOT23
15364       DOUBLE PRECISION DOT24,DOT2H,DOT34,DOT3H,DOT4H
15365       DOUBLE PRECISION PT2,PV2,PA2
15366       DOUBLE PRECISION M2
15367       DOUBLE COMPLEX PV,PA,PT,PW,Z
15368       PARAMETER (GAMWTMP=0.D0,GAMH01=0.D0,GAMH03=0.D0,GAMH02=0.D0)
15369       PARAMETER (Z=(0.D0,1.D0))
15370       DOUBLE PRECISION SC,RICCI
15371       EXTERNAL SC,RICCI
15372 C
15373       DO 670 MU=0,3
15374          QW(MU)=P2(MU)-P4(MU)
15375          QS(MU)=P1(MU)-P3(MU)
15376  670  CONTINUE
15377 C
15378       DOTHH=EMH*EMH
15379       DOTSS=SC(QS,QS)
15380       DOTWW=SC(QW,QW)
15381       DOT13=EMB*EMB-DOTSS/2.D0
15382       DOT24=-DOTWW/2.D0
15383       DOT2H=SC(P2,P5)
15384       DOT4H=SC(P4,P5)
15385 C
15386       IF(IFL.EQ.1)THEN
15387         DOT12=SC(P1,P2)
15388         DOT14=SC(P1,P4)
15389         DOT23=SC(P2,P3)
15390         DOT34=SC(P3,P4)
15391         DOT3H=SC(P3,P5)
15392         E1234=RICCI(P1,P2,P3,P4)
15393       ELSE IF(IFL.EQ.-1)THEN
15394         DOT12=-SC(P3,P2)
15395         DOT14=-SC(P3,P4)
15396         DOT23=-SC(P2,P1)
15397         DOT34=-SC(P1,P4)
15398         DOT3H=-SC(P1,P5)
15399         E1234=-RICCI(P1,P2,P3,P4)
15400       END IF
15401 C
15402       DOTTT=DOTHH+EMB*EMB+2.D0*DOT3H
15403 C
15404       PV=COSA*SINBMA/(DOTSS-EMH01*EMH01+Z*EMH01*GAMH01)+
15405      1   SINA*COSBMA/(DOTSS-EMH02*EMH02+Z*EMH02*GAMH02)
15406       PA=SINB/(DOTSS-EMH03*EMH03+Z*EMH03*GAMH03)
15407       PW=1./(DOTWW-EMW*EMW+Z*EMW*GAMWTMP)
15408 C REMOVE TOP DIAGRAM.
15409       IF(IRES.EQ.1)PT=1./(DOTTT-EMT*EMT+Z*EMT*GAMT)
15410       IF(IRES.EQ.0)PT=(0.D0,0.D0)
15411       PT=PT*CKM
15412       PT2 =DREAL(DCONJG(PT)*PT)
15413       PV2 =DREAL(DCONJG(PV)*PV)
15414       PA2 =DREAL(DCONJG(PA)*PA)
15415 C
15416       N0=ABS(PW)
15417 C
15418       M2=N0*N0* ( EMB*EMB/COSB/COSB*(PV2+PA2)*DOT13*
15419      &   (2.D0*DOT4H*DOT2H-DOT24*DOTHH)+
15420      T 2.D0*PT2*DOT12*
15421      O   (EMB*EMB*TANB*TANB*(2.D0*DOT3H*DOT4H-DOT34*DOTHH)+
15422      P    EMT*EMT/TANB/TANB*(EMT*EMT*DOT34))+
15423      & EMB*EMB*TANB/COSB*DREAL(PV+PA)*
15424      X   (DREAL(PT)*(4.D0*DOT4H*DOT12*DOT13-
15425      T    (2.D0*DOT4H+DOTHH)*(DOT12*DOT34+DOT13*DOT24-DOT14*DOT23))+
15426      M    DIMAG(PT)*(2.D0*DOT4H+DOTHH)*E1234) )
15427       END
15428 C
15429       DOUBLE PRECISION FUNCTION SC(A,B)
15430       IMPLICIT NONE
15431       DOUBLE PRECISION A(0:3),B(0:3)
15432       SC=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3)
15433       END
15434 C
15435       DOUBLE PRECISION FUNCTION RICCI(A,B,C,D)
15436       IMPLICIT NONE
15437       DOUBLE PRECISION A(0:3),B(0:3),C(0:3),D(0:3)
15438       RICCI=
15439      & A(0)*B(1)*C(2)*D(3)+A(0)*B(2)*C(3)*D(1)+A(0)*B(3)*C(1)*D(2)-
15440      & A(0)*B(3)*C(2)*D(1)-A(0)*B(1)*C(3)*D(2)-A(0)*B(2)*C(1)*D(3)+
15441      & A(1)*B(0)*C(3)*D(2)+A(1)*B(2)*C(0)*D(3)+A(1)*B(3)*C(2)*D(0)-
15442      & A(1)*B(2)*C(3)*D(0)-A(1)*B(3)*C(0)*D(2)-A(1)*B(0)*C(2)*D(3)+
15443      & A(2)*B(3)*C(0)*D(1)+A(2)*B(0)*C(1)*D(3)+A(2)*B(1)*C(3)*D(0)-
15444      & A(2)*B(1)*C(0)*D(3)-A(2)*B(3)*C(1)*D(0)-A(2)*B(0)*C(3)*D(1)+
15445      & A(3)*B(2)*C(1)*D(0)+A(3)*B(0)*C(2)*D(1)+A(3)*B(1)*C(0)*D(2)-
15446      & A(3)*B(0)*C(1)*D(2)-A(3)*B(1)*C(2)*D(0)-A(3)*B(2)*C(0)*D(1)
15447       END
15448 CDECK  ID>, HWH2F1
15449 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
15450 C-----------------------------------------------------------------------
15451       SUBROUTINE HWH2F1(NP,F,I,P,MQ)
15452 C-----------------------------------------------------------------------
15453 C     Subroutine to implement the F function of Eijk and Kliess
15454 C     fixed first momenta and all second momenta
15455 C-----------------------------------------------------------------------
15456       INCLUDE 'herwig65.inc'
15457       DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15458       DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
15459       INTEGER I,J,NP
15460       EXTERNAL HWULDO
15461       COMMON/HWHEWS/S(8,8,2),D(8,8)
15462       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15463       PARAMETER(EPS=1D-10)
15464 C--find the massless momentum we need
15465       PDOT = HWULDO(PCM(1,I),P)
15466       P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15467       IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15468          PDOT = HALF
15469       ELSE
15470          PDOT = HALF*P(5)/PDOT
15471       ENDIF
15472       DO J=1,4
15473         PM(J) = P(J)-PDOT*PCM(J,I)
15474       ENDDO
15475       IF(P(5).GT.ZERO) THEN
15476          P(5)=SQRT(P(5))
15477       ELSE
15478          P(5)=ZERO
15479       ENDIF
15480       PM(5) = ZERO
15481 C--calculate its spinor product with the fixed momentum
15482       CALL HWH2SS(SIP,PCM(1,I),PM)
15483 C--calculate the F functions
15484       DO J=1,NP
15485         CALL HWH2SS(SJP,PM,PCM(1,J))
15486         F(1,1,J) = SIP(1)*SJP(2)
15487         F(1,2,J) = MQ*S(I,J,1)
15488         F(2,1,J) = MQ*S(I,J,2)
15489         F(2,2,J) = SIP(2)*SJP(1)
15490       ENDDO
15491       END
15492 CDECK  ID>, HWH2F2
15493 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
15494 C-----------------------------------------------------------------------
15495       SUBROUTINE HWH2F2(NP,F,I,P,MQ)
15496 C-----------------------------------------------------------------------
15497 C     Subroutine to implement the F function of Eijk and Kliess
15498 C     fixed second momenta and all first momenta
15499 C-----------------------------------------------------------------------
15500       INCLUDE 'herwig65.inc'
15501       DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15502       DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
15503       INTEGER I,J,NP
15504       EXTERNAL HWULDO
15505       COMMON/HWHEWS/S(8,8,2),D(8,8)
15506       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15507       PARAMETER(EPS=1D-10)
15508 C--find the massless momentum we need
15509       PDOT = HWULDO(PCM(1,I),P)
15510       P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15511       IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15512          PDOT = HALF
15513       ELSE
15514          PDOT = HALF*P(5)/PDOT
15515       ENDIF
15516       DO J=1,4
15517         PM(J) = P(J)-PDOT*PCM(J,I)
15518       ENDDO
15519       IF(P(5).GT.ZERO) THEN
15520          P(5)=SQRT(P(5))
15521       ELSE
15522          P(5)=ZERO
15523       ENDIF
15524       PM(5) = ZERO
15525 C--calculate its spinor product with the fixed momentum
15526       CALL HWH2SS(SIP,PM,PCM(1,I))
15527 C--calculate the F functions
15528       DO J=1,NP
15529         CALL HWH2SS(SJP,PCM(1,J),PM)
15530         F(1,1,J) = SIP(2)*SJP(1)
15531         F(1,2,J) = MQ*S(J,I,1)
15532         F(2,1,J) = MQ*S(J,I,2)
15533         F(2,2,J) = SIP(1)*SJP(2)
15534       ENDDO
15535       END
15536 CDECK  ID>, HWH2F3
15537 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
15538 C-----------------------------------------------------------------------
15539       SUBROUTINE HWH2F3(NP,F,P,MQ)
15540 C-----------------------------------------------------------------------
15541 C     Subroutine to implement the F function of Eijk and Kliess
15542 C     All first and second momenta
15543 C-----------------------------------------------------------------------
15544       INCLUDE 'herwig65.inc'
15545       DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15546       DOUBLE COMPLEX F(2,2,8,8),SIP(2),SJP(2),S,D
15547       INTEGER I,J,NP
15548       COMMON/HWHEWS/S(8,8,2),D(8,8)
15549       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15550       EXTERNAL HWULDO
15551       PARAMETER(EPS=1D-10)
15552 C--find the massless momentum we need
15553       DO I=1,NP
15554         PDOT = HWULDO(PCM(1,I),P)
15555         P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15556         IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15557            PDOT = HALF
15558         ELSE
15559            PDOT = HALF*P(5)/PDOT
15560         ENDIF
15561         DO J=1,4
15562           PM(J) = P(J)-PDOT*PCM(J,I)
15563         ENDDO
15564         IF(P(5).GT.ZERO) THEN
15565            P(5)=SQRT(P(5))
15566         ELSE
15567            P(5)=ZERO
15568         ENDIF
15569         PM(5) = ZERO
15570 C--calculate its spinor product with the fixed momentum
15571         CALL HWH2SS(SIP,PCM(1,I),PM)
15572 C--calculate the F functions
15573         DO J=I,NP
15574           CALL HWH2SS(SJP,PM,PCM(1,J))
15575           F(1,1,I,J) = SIP(1)*SJP(2)
15576           F(1,2,I,J) = MQ*S(I,J,1)
15577           F(2,1,I,J) = MQ*S(I,J,2)
15578           F(2,2,I,J) = SIP(2)*SJP(1)
15579         ENDDO
15580       ENDDO
15581       DO I=1,NP
15582         DO J=I+1,NP
15583           F(1,1,J,I) =  F(2,2,I,J)
15584           F(1,2,J,I) = -F(1,2,I,J)
15585           F(2,1,J,I) = -F(2,1,I,J)
15586           F(2,2,J,I) =  F(1,1,I,J)
15587         ENDDO
15588       ENDDO
15589       END
15590 CDECK  ID>, HWH2HE.
15591 *CMZ :-        -13/10/02  09.43.05  by  Peter Richardson
15592 *-- Author :    Kosuke Odagiri and Stefano Moretti
15593 C-----------------------------------------------------------------------
15594       SUBROUTINE HWH2HE(FIRST,GAUGE,IFL,IH,HFC,HBC,
15595      & E,S2W,TANB,AL,RMW,S,Q3, P3,P4,P5,
15596      & RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
15597      & RML,GAML,RMH,GAMH,RMA,GAMA,
15598      & RMZ,GAMZ,CFAC,RES)
15599 C-----------------------------------------------------------------------
15600 C     MATRIX ELEMENT SQUARED FOR
15601 C     e-(1) e+(2) -> f(3) f(')bar(4) Higgs(5)
15602 C     (SAME QUARK MASSES IN YUKAWA AND KINEMATICS)
15603 C-----------------------------------------------------------------------
15604       IMPLICIT NONE
15605       LOGICAL FIRST,GAUGE
15606       DOUBLE PRECISION HFC,HBC
15607       DOUBLE PRECISION CFAC
15608       DOUBLE PRECISION E,S2W,TANB,AL,RMW,S,Q3,RES
15609       DOUBLE PRECISION P3(0:3),P4(0:3),P5(0:3)
15610       DOUBLE PRECISION RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,RMZ,GAMZ
15611       DOUBLE PRECISION RML,GAML,RMH,GAMH,RMA,GAMA,Q2
15612       DOUBLE PRECISION XW,GE(-1:1),G3(-1:1),G4(-1:1),G5(-1:1)
15613       DOUBLE PRECISION RM(-1:1),RN1(-1:1),RN2(-1:1),RN3
15614       DOUBLE PRECISION SQS,TWOSQS,HLFSQS,P34,M34,PREFAC
15615       DOUBLE PRECISION RLE,RLLE,EP3(-1:1),EP4(-1:1),ZERO,ONE,TWO,HLF
15616       DOUBLE PRECISION BE,SA,CA,SB,CB
15617       INTEGER I,LE,L,IFL,IH
15618       DOUBLE COMPLEX PROPZ,PROP3(-1:1),PROP4(-1:1),PROP5,PROP6
15619       DOUBLE COMPLEX PROP7(-1:1)
15620       DOUBLE COMPLEX PP(-1:1),MM(-1:1),QQ(-1:1),ZP3,ZP4,ZP5
15621       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,HLF=.5D0)
15622       SAVE XW,GE,G3,G4,G5,RM,PREFAC
15623 C QUANTITIES WHICH CAN BE COMPUTED ONLY ONCE
15624       IF(FIRST)THEN
15625 C SOME COMMON INITIALISATIONS
15626         DO I=-1,1
15627           RM(I)=ZERO
15628           RN1(I)=ZERO
15629           RN2(I)=ZERO
15630         END DO
15631         RN3=ZERO
15632         XW=TWO*S2W
15633         GE( 0)=-ONE
15634         GE(+1)=-GE(0)*XW
15635         GE(-1)=-ONE+GE(1)
15636         IF(IH.LE.3)THEN
15637           G3( 0)=Q3
15638           G3(+1)=-G3(0)*XW
15639           G3(-1)=-ONE*(-Q3/ABS(Q3))+G3(1)
15640           G4( 0)=G3( 0)
15641           G4(+1)=G3(+1)
15642           G4(-1)=G3(-1)
15643           G5( 0)=ZERO
15644           G5(+1)=ONE
15645           G5(-1)=ONE
15646 C HIGGS ANGLES
15647           BE=ATAN(TANB)
15648           SA=SIN(AL)
15649           CA=COS(AL)
15650           SB=SIN(BE)
15651           CB=COS(BE)
15652 C MSSM SCALING FACTORS FOR COUPLINGS
15653           IF(IH.LE.2)THEN
15654             RM(-1)=+YM3/RMW*HFC
15655             RM(+1)=+YM4/RMW*HFC
15656           ELSE IF(IH.EQ.3)THEN
15657             RM(-1)=+YM3/RMW*HFC
15658             RM(+1)=-YM4/RMW*HFC
15659           END IF
15660           IF(IH.LE.2)THEN
15661             IF(IH.EQ.1)RN1(-1)=+YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15662      &                        *(-SQRT(ABS(ONE-HBC**2)))
15663             IF(IH.EQ.1)RN1(+1)=-YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15664      &                        *(-SQRT(ABS(ONE-HBC**2)))
15665             IF(IH.EQ.2)RN1(-1)=-YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15666      &                        *(+SQRT(ABS(ONE-HBC**2)))
15667             IF(IH.EQ.2)RN1(+1)=+YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15668      &                        *(+SQRT(ABS(ONE-HBC**2)))
15669             RN2(-1)=ZERO
15670             RN2(+1)=ZERO
15671             IF(IH.EQ.0)RN3=1.D0
15672             IF(IH.EQ.1)RN3=HBC
15673             IF(IH.EQ.2)RN3=HBC
15674           ELSE IF(IH.EQ.3)THEN
15675             RN1(-1)=+YM3/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
15676      &                      *COS(BE-AL)
15677             RN1(+1)=+YM4/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
15678      &                      *COS(BE-AL)
15679             RN2(-1)=+YM3/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
15680      &                      *SIN(BE-AL)
15681             RN2(+1)=+YM4/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
15682      &                      *SIN(BE-AL)
15683             RN3=ZERO
15684           END IF
15685           PREFAC=E**6/(XW*S)*CFAC/TWO
15686         ELSE
15687           G3( 0)=Q3
15688           G3(+1)=-G3(0)*XW
15689           G3(-1)=-ONE+G3(1)
15690           G4( 0)=ONE+G3(0)
15691           G4(+1)=-G4(0)*XW
15692           G4(-1)=ONE+G4(1)
15693           G5( 0)=ONE
15694           G5(+1)=ONE-XW
15695           G5(-1)=ONE-XW
15696           RM(-1)=YM3*TANB/RMW
15697           RM(+1)=YM4/TANB/RMW
15698           RN1(-1)=RM(-1)
15699           RN1(+1)=RM(+1)
15700           RN2(-1)=ZERO
15701           RN2(+1)=ZERO
15702           RN3=ZERO
15703           PREFAC=E**6/(XW*S)*CFAC
15704         END IF
15705         FIRST=.FALSE.
15706       END IF
15707 C SOME ENERGY CONSTANTS
15708       SQS=DSQRT(S)
15709       TWOSQS=TWO*SQS
15710       HLFSQS=HLF*SQS
15711       PROPZ=S/(XW*(TWO-XW)*DCMPLX(S-RMZ**2,-RMZ*GAMZ))
15712 C SOME KINEMATICS
15713       P34=P3(0)*P4(0)-P3(1)*P4(1)-P3(2)*P4(2)-P3(3)*P4(3)
15714       M34=RM3*RM4
15715       RES=ZERO
15716 C FF(')-BAR PROPAGATOR
15717       Q2=RM3**2+RM4**2+TWO*P34
15718 C CONSTRUCT AMPLITUDE
15719       DO LE=-1,1,2
15720         RLE=DFLOAT(LE)
15721         IF(IH.LE.2)THEN
15722           PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15723      &                 DCMPLX(Q2-RMA**2,-RMA*GAMA)
15724           PROP6=(0.D0,0.D0)
15725         ELSE IF(IH.EQ.3)THEN
15726           PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15727      &                 DCMPLX(Q2-RML**2,-RML*GAML)
15728           PROP6=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15729      &                 DCMPLX(Q2-RMH**2,-RMH*GAMH)
15730         ELSE
15731           PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15732      &                 DCMPLX(Q2-RM5**2,-RM5*GAM5)
15733         END IF
15734         ZP3=DCMPLX(P3(1),-RLE*P3(2))
15735         ZP4=DCMPLX(P4(1),-RLE*P4(2))
15736         ZP5=-ZP3-ZP4
15737         DO L=-1,1,2
15738           PROP3(L)=(GE(0)*G3(0)+GE(LE)*G3(L)*PROPZ)/
15739      &               DCMPLX(S-TWOSQS*P3(0),-RM3*GAM3)
15740           PROP4(L)=(GE(0)*G4(0)+GE(LE)*G4(L)*PROPZ)/
15741      &               DCMPLX(S-TWOSQS*P4(0),-RM4*GAM4)
15742           PROP7(L)=GE(LE)*G3(L)*PROPZ/DCMPLX(Q2-RMZ**2,-RMZ*GAMZ)
15743         END DO
15744         DO L=-1,1,2
15745           PP(L)=-RM(-L)*SQS*(PROP3(L)+PROP4(-L))
15746           MM(L)=RM3*RM(+L)*(PROP3(L)-PROP3(-L))
15747      &         +RM4*RM(-L)*(PROP4(L)-PROP4(-L))
15748      &         +TWO*RMZ**2/RMW*RN3*PROP7(L)
15749           IF(GAUGE)THEN
15750             ZP3=P3(0)-HLFSQS
15751             ZP4=P4(0)-HLFSQS
15752             ZP5=P5(0)-HLFSQS
15753             PP(L)=DCMPLX(ZERO,ZERO)
15754             MM(L)=MM(L)+PROPZ*GE(LE)*DFLOAT(L)/TWOSQS*
15755      &                           (RM3*RM(L)/ZP3-RM4*RM(-L)/ZP4)
15756           END IF
15757           QQ(L)=RM(L)*(PROP3(-L)*ZP3-PROP4(L)*ZP4)
15758      &         +RN1(L)*PROP5*ZP5
15759      &         -RN2(L)*PROP6*ZP5
15760      &         +RM3/RMW*RN3*(PROP7(L)-PROP7(-L))*ZP5
15761           RLLE=DFLOAT(L*LE)
15762           EP3(L)=P3(0)+RLLE*P3(3)
15763           EP4(L)=P4(0)+RLLE*P4(3)
15764         END DO
15765         DO L=-1,1,2
15766           RES=RES+DREAL(
15767      &      EP3(+L)*EP4(+L)*DCONJG(PP(+L))*PP(+L)+
15768      &      EP3(+L)*EP4(-L)*DCONJG(MM(+L))*MM(+L)-
15769      &      TWO*RM3*EP4(+L)*DCONJG(PP(+L))*MM(-L)-
15770      &      TWO*RM4*EP3(+L)*DCONJG(PP(+L))*MM(+L)+
15771      &      M34*(DCONJG(PP(-L))*PP(+L)+DCONJG(MM(-L))*MM(+L))
15772      &      +TWO*DCONJG(QQ(-L))
15773      &      *((RM3*MM(-L)-EP3(+L)*PP(+L))*ZP4-
15774      &        (RM4*MM(+L)-EP4(+L)*PP(+L))*ZP3+
15775      &        P34*QQ(-L)-M34*QQ(+L)))
15776         END DO
15777       END DO
15778       RES=PREFAC*RES
15779       END
15780 CDECK  ID>, HWH2M0.
15781 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
15782 *-- Author :    Peter Richardson
15783 C-----------------------------------------------------------------------
15784       SUBROUTINE HWH2M0(IQ,IDZ,MG,MQ)
15785 C-----------------------------------------------------------------------
15786 C     Massless matrix elements for gg-->qqZ and qq-->qqZ
15787 C     using the matrix elements given in Nucl. Phys. B262 (1985) 235-242
15788 C-----------------------------------------------------------------------
15789       INCLUDE 'herwig65.inc'
15790       INTEGER IQ,I,J,OZ(2,2),IDZ,P1,P2,P3,P4,IQI,ID(2),K
15791       DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),FLOW(3,3),CQFC,CQIFC,
15792      &     CGFC,CGIFC
15793       DOUBLE COMPLEX MQAMP(2),HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,
15794      &     HWH2T6,HWH2T7,HWH2T8,HWH2T9,HWH2T0,DCF(8),HWH2DD,
15795      &     MGAMP(2,2,2,2,2),TRPGL(2)
15796       EXTERNAL HWH2DD,HWH2T0,HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,HWH2T6,
15797      &         HWH2T7,HWH2T8,HWH2T9
15798       PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
15799      &          CGIFC=-2.0D0/3.0D0)
15800       COMMON /HWHZBC/G
15801       SAVE OZ,ID
15802       DATA OZ/6,5,5,6/
15803       DATA ID/1,2/
15804 C--flavour of the final-state quark (1 is down-type and 2 is up-type)
15805       IQI  = MOD(IQ,2)
15806       IF(IQI.EQ.0) IQI=2
15807 C--calculate qqbar---> q'q'barZ
15808       DCF(1) = HWH2DD(4,2,1,3,4,5,6)
15809       DCF(2) = HWH2DD(5,2,1,3,4,5,6)
15810       DCF(3) = HWH2DD(4,3,4,2,1,5,6)
15811       DCF(4) = HWH2DD(5,3,4,2,1,5,6)
15812       DCF(5) = HWH2DD(4,3,1,2,4,5,6)
15813       DCF(6) = HWH2DD(5,3,1,2,4,5,6)
15814       DCF(7) = HWH2DD(4,2,4,3,1,5,6)
15815       DCF(8) = HWH2DD(5,2,4,3,1,5,6)
15816       DO I=1,3
15817         DO J=1,3
15818           FLOW(I,J) = ZERO
15819         ENDDO
15820       ENDDO
15821       DO I=1,2
15822 C--calculate the matrix element, N.B. two possibe colour flows
15823        DO P1=1,2
15824         DO P2=1,2
15825          DO P3=1,2
15826             MQAMP(1)= G(IDZ,P3)*(
15827      &      G(ID(I),P1)*(DCF(1)*HWH2T4(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2)
15828      &                  +DCF(2)*HWH2T5(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2))
15829      &       +G(IQ,P2)*(DCF(3)*HWH2T4(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)
15830      &                 +DCF(4)*HWH2T5(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)))
15831           IF(ID(I).NE.IQI) THEN
15832             MQAMP(2)=ZERO
15833           ELSE
15834             MQAMP(2)= G(IDZ,P3)*(
15835      &        G(IQ,P1)*(DCF(5)*HWH2T4(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2)
15836      &                 +DCF(6)*HWH2T5(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2))
15837      &       +G(IQ,P2)*(DCF(7)*HWH2T4(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)
15838      &                 +DCF(8)*HWH2T5(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)))
15839           ENDIF
15840           FLOW(I,1) = FLOW(I,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
15841           FLOW(I,2) = ZERO
15842           FLOW(I,3) = ZERO
15843           IF(IQI.EQ.ID(I)) THEN
15844             FLOW(3,1) = FLOW(3,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
15845             FLOW(3,2) = FLOW(3,2)+DBLE(MQAMP(2)*DCONJG(MQAMP(2)))
15846             IF(P1.EQ.P2) FLOW(3,3) = FLOW(3,3)
15847      &                         -TWO*DBLE(MQAMP(1)*DCONJG(MQAMP(2)))
15848           ENDIF
15849          ENDDO
15850         ENDDO
15851        ENDDO
15852       ENDDO
15853       DO I=1,3
15854         FLOW(I,1) =  CQFC*FLOW(I,1)
15855         FLOW(I,2) =  CQFC*FLOW(I,2)
15856         FLOW(I,3) = CQIFC*FLOW(I,3)
15857       ENDDO
15858 C--now find the matrix elements
15859       DO I=1,5
15860         K = MOD(I,2)
15861         IF(K.EQ.0) K=2
15862         IF(I.EQ.IQ) K=3
15863         DO J=1,2
15864           IF(FLOW(K,J).NE.ZERO) MQ(J,I) = FLOW(K,J)*
15865      &                           (ONE+FLOW(K,3)/(FLOW(K,1)+FLOW(K,2)))
15866         ENDDO
15867       ENDDO
15868 C--calculate gg---> bbbarZ
15869 C--coefficients for the diagrams
15870       DCF(1) = HWH2DD( 6,3,4,1,2,5,6)
15871       DCF(2) = HWH2DD( 7,3,4,1,2,5,6)
15872       DCF(3) = HWH2DD( 8,3,4,1,2,5,6)
15873       DCF(4) = HWH2DD( 6,3,4,2,1,5,6)
15874       DCF(5) = HWH2DD( 7,3,4,2,1,5,6)
15875       DCF(6) = HWH2DD( 8,3,4,2,1,5,6)
15876       DCF(7) = HWH2DD( 9,3,4,1,2,5,6)
15877       DCF(8) = HWH2DD(10,3,4,1,2,5,6)
15878 C--helicity amplitudes
15879       DO P1=1,2
15880        DO P2=1,2
15881          DO P3=1,2
15882           DO P4=1,2
15883            TRPGL(1)=
15884      &            DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15885      &           +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15886            TRPGL(2)=
15887      &            DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
15888      &           +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
15889            MGAMP(1,P1,P2,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(
15890      &          TRPGL(1)
15891      &         +DCF(1)*HWH2T6(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15892      &         +DCF(2)*HWH2T7(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15893      &         +DCF(3)*HWH2T8(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15894      &          )
15895            MGAMP(2,P2,P1,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(-TRPGL(2)
15896      &         +DCF(4)*HWH2T6(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15897      &         +DCF(5)*HWH2T7(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15898      &         +DCF(6)*HWH2T8(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2))
15899          ENDDO
15900         ENDDO
15901        ENDDO
15902       ENDDO
15903 C--square to obtain the matrix element
15904       DO I=1,3
15905         FLOW(1,I) = ZERO
15906       ENDDO
15907       DO P1=1,2
15908         DO P2=1,2
15909           DO P3=1,2
15910             DO P4=1,2
15911              FLOW(1,1) = FLOW(1,1)+DBLE(MGAMP(1,P1,P2,P3,P4)*
15912      &                              DCONJG(MGAMP(1,P1,P2,P3,P4)))
15913              FLOW(1,2) = FLOW(1,2)+DBLE(MGAMP(2,P1,P2,P3,P4)*
15914      &                              DCONJG(MGAMP(2,P1,P2,P3,P4)))
15915              FLOW(1,3) = FLOW(1,3)+TWO*DBLE(MGAMP(1,P1,P2,P3,P4)*
15916      &                              DCONJG(MGAMP(2,P1,P2,P3,P4)))
15917             ENDDO
15918           ENDDO
15919         ENDDO
15920       ENDDO
15921       FLOW(1,1) = CGFC*FLOW(1,1)
15922       FLOW(1,2) = CGFC*FLOW(1,2)
15923       FLOW(1,3) = CGIFC*FLOW(1,3)
15924       DO I=1,2
15925         MG(I) = FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
15926       ENDDO
15927       END
15928 CDECK  ID>, HWH2MQ.
15929 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
15930 *-- Author :    Peter Richardson
15931 C-----------------------------------------------------------------------
15932       SUBROUTINE HWH2MQ(IQ,IDZ,MG,MQ)
15933 C-----------------------------------------------------------------------
15934 C     Massive matrix elements for gg --> qqbarZ and qqbar --> qqbarZ
15935 C-----------------------------------------------------------------------
15936       INCLUDE 'herwig65.inc'
15937       INTEGER IQ,I,IDZ,P1,P2,PL,PB,PBB,O(2),J,IQI
15938       DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),CQFC,CQIFC,CGFC,CGIFC,
15939      &     PTMP(5,10),XMASS,PLAB,PRW,PCM,HWULDO,QBL,QBBL,Q2B,Q1B,Q2BB,
15940      &     Q1BB,QM2,FLOW(3,3),PG,PBQB,PBBQBB,QM,PQ,Q1L,Q2L,
15941      &     Q1LB,Q2LB,MQB(2,3),QBB
15942       DOUBLE COMPLEX S,D,FBB(2,2,8),FBBB(2,2,8),FBLL(2,2,8,8),MQP(2),
15943      &     FBBLL(2,2,8,8),F1B(2,2,8,8),F1BB(2,2,8,8),F2B(2,2,8,8),
15944      &     F2BB(2,2,8,8),DL(2,2),DCF(8),MGAMP(3),MQAMP(3,2,2,2,2),
15945      &     MQQAMP(2,2,2,2,2),F1LL(2,2,8,8),F2LL(2,2,8,8)
15946       COMMON/HWHZBC/G
15947       COMMON/HWHEWS/S(8,8,2),D(8,8)
15948       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15949       PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
15950      &          CGIFC=-2.0D0/3.0D0)
15951       EXTERNAL HWULDO
15952       SAVE DL,O
15953       DATA DL/(1.0D0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
15954       DATA O   /2,1/
15955 C--mass of the final-state quark
15956       QM  = RMASS(IQ)
15957       QM2 = RMASS(IQ)**2
15958 C--first calculate the F functions we will need
15959       DO I=1,4
15960         PTMP(I,1)  =  PCM(I,9)+PCM(I,5)+PCM(I,6)
15961         PTMP(I,2)  = -PCM(I,10)-PCM(I,5)-PCM(I,6)
15962         PTMP(I,3)  =  PCM(I,9)-PCM(I,1)
15963         PTMP(I,4)  =  PCM(I,1)-PCM(I,10)
15964         PTMP(I,5)  =  PCM(I,9)-PCM(I,2)
15965         PTMP(I,6)  =  PCM(I,2)-PCM(I,10)
15966         PTMP(I,7)  =  PCM(I,9)
15967         PTMP(I,8)  = -PCM(I,10)
15968         PTMP(I,9)  = PCM(I,1)-PCM(I,5)-PCM(I,6)
15969         PTMP(I,10) =-PCM(I,2)+PCM(I,5)+PCM(I,6)
15970       ENDDO
15971       CALL HWH2F3(8,FBLL ,  PTMP(1, 1),QM)
15972       CALL HWH2F3(8,FBBLL,  PTMP(1, 2),QM)
15973       CALL HWH2F3(8,F1B  ,  PTMP(1, 3),QM)
15974       CALL HWH2F3(8,F1BB ,  PTMP(1, 4),QM)
15975       CALL HWH2F3(8,F2B  ,  PTMP(1, 5),QM)
15976       CALL HWH2F3(8,F2BB ,  PTMP(1, 6),QM)
15977       CALL HWH2F1(8,FBB  ,3,PTMP(1, 7),QM)
15978       CALL HWH2F2(8,FBBB ,4,PTMP(1, 8),QM)
15979       CALL HWH2F3(8,F1LL ,  PTMP(1, 9),QM)
15980       CALL HWH2F3(8,F2LL ,  PTMP(1,10),QM)
15981 C--calculate the momenta squared for the denominators
15982       QBB = HALF/(QM2+HWULDO(PCM(1,9),PCM(1,10)))
15983       QBL   = ONE/(HWULDO(PTMP(1,1),PTMP(1,1))-QM2)
15984       QBBL  = ONE/(HWULDO(PTMP(1,2),PTMP(1,2))-QM2)
15985       Q1B   = ONE/(HWULDO(PTMP(1,3),PTMP(1,3))-QM2)
15986       Q1BB  = ONE/(HWULDO(PTMP(1,4),PTMP(1,4))-QM2)
15987       Q2B   = ONE/(HWULDO(PTMP(1,5),PTMP(1,5))-QM2)
15988       Q2BB  = ONE/(HWULDO(PTMP(1,6),PTMP(1,6))-QM2)
15989       Q1L  = HWULDO(PTMP(1, 9),PTMP(1, 9))
15990       Q2L  = HWULDO(PTMP(1,10),PTMP(1,10))
15991       Q1LB = ONE/(Q1L-QM2)
15992       Q2LB = ONE/(Q2L-QM2)
15993       Q1L  = ONE/Q1L
15994       Q2L  = ONE/Q2L
15995 C--first construct the massless momenta
15996       PBQB   = HWULDO(PCM(1,3),PCM(1,9))
15997       PBBQBB = HWULDO(PCM(1,4),PCM(1,10))
15998 C--first gg  --> q qbar Z
15999 C--calculate the denominators due gluon polaizations and massive quarks
16000       PG   = 0.25D0/(PBQB*PBBQBB*DREAL(D(1,2)*D(1,2)))
16001 C--and the denominators
16002       DCF(1) = FOUR*QBL*Q2BB
16003       DCF(2) = FOUR*QBL*Q1BB
16004       DCF(3) = FOUR*Q1B*Q2BB
16005       DCF(4) = FOUR*Q2B*Q1BB
16006       DCF(5) = FOUR*Q1B*QBBL
16007       DCF(6) = FOUR*Q2B*QBBL
16008       DCF(7) =  TWO*QBL/D(1,2)
16009       DCF(8) =  TWO*QBBL/D(1,2)
16010 C--now calculate the matrix elements we need
16011       DO I=1,3
16012         FLOW(1,I) = ZERO
16013       ENDDO
16014       DO P1=1,2
16015       DO P2=1,2
16016       DO PL=1,2
16017       DO PB=1,2
16018       DO PBB=1,2
16019 C--first amplitude from notes
16020         MGAMP(1) = DCF(1)*(
16021      &     ( G(IQ,O(PL))*FBB(PB,   PL,6)*FBLL(  PL ,P1,5,2)
16022      &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),P1,6,2))*
16023      &         (F2BB(  P1 ,  P2 ,1,1)*FBBB(  P2 ,PBB,2)+
16024      &          F2BB(  P1 ,O(P2),1,2)*FBBB(O(P2),PBB,1))
16025      &    +( G(IQ,O(PL))*FBB(PB,  PL ,6)*FBLL(   PL,O(P1),5,1)
16026      &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P1),6,1))*
16027      &         (F2BB(O(P1),  P2 ,2,1)*FBBB(  P2 ,PBB,2)+
16028      &          F2BB(O(P1),O(P2),2,2)*FBBB(O(P2),PBB,1)))
16029 C--second amplitude from notes (1st with gluons interchanged)
16030         MGAMP(2) = DCF(2)*(
16031      &     ( G(IQ,O(PL))*FBB(PB,  PL ,6)*FBLL(  PL ,  P2 ,5,1)
16032      &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),  P2 ,6,1))*
16033      &         (F1BB(  P2 ,  P1 ,2,2)*FBBB(  P1 ,PBB,1)+
16034      &          F1BB(  P2 ,O(P1),2,1)*FBBB(O(P1),PBB,2))
16035      &    +( G(IQ,O(PL))*FBB(PB,  PL ,6)*FBLL(  PL ,O(P2),5,2)
16036      &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P2),6,2))*
16037      &         (F1BB(O(P2),  P1 ,1,2)*FBBB(  P1 ,PBB,1)+
16038      &          F1BB(O(P2),O(P1),1,1)*FBBB(O(P1),PBB,2)))
16039 C--third amplitude from notes
16040         MGAMP(1) = MGAMP(1)+DCF(3)*(
16041      &     G(IQ,O(PL))*( FBB(PB,  P1 ,2)*F1B(  P1 ,  PL ,1,6)
16042      &                  +FBB(PB,O(P1),1)*F1B(O(P1),  PL ,2,6))*
16043      &         (F2BB(PL,  P2 ,5,1)*FBBB(  P2 ,PBB,2)+
16044      &          F2BB(PL,O(P2),5,2)*FBBB(O(P2),PBB,1))
16045      &    +G(IQ,  PL )*( FBB(PB,  P1 ,2)*F1B(  P1 ,O(PL),1,5)
16046      &                  +FBB(PB,O(P1),1)*F1B(O(P1),O(PL),2,5))*
16047      &         (F2BB(O(PL),  P2 ,6,1)*FBBB(  P2 ,PBB,2)+
16048      &          F2BB(O(PL),O(P2),6,2)*FBBB(O(P2),PBB,1)))
16049 C--fourth amplitude from notes (3rd with gluons interchanged)
16050         MGAMP(2) = MGAMP(2)+DCF(4)*(
16051      &     G(IQ,O(PL))*( FBB(PB,  P2 ,1)*F2B(  P2 ,  PL ,2,6)
16052      &                  +FBB(PB,O(P2),2)*F2B(O(P2),  PL ,1,6))*
16053      &         (F1BB(  PL ,  P1 ,5,2)*FBBB(  P1 ,PBB,1)+
16054      &          F1BB(  PL ,O(P1),5,1)*FBBB(O(P1),PBB,2))
16055      &    +G(IQ,  PL )*( FBB(PB,  P2 ,1)*F2B(  P2 ,O(PL),2,5)
16056      &                  +FBB(PB,O(P2),2)*F2B(O(P2),O(PL),1,5))*
16057      &         ( F1BB(O(PL),  P1 ,6,2)*FBBB(  P1 ,PBB,1)
16058      &          +F1BB(O(PL),O(P1),6,1)*FBBB(O(P1),PBB,2)))
16059 C--fifth amplitude from notes
16060         MGAMP(1) = MGAMP(1)+DCF(5)*(
16061      &     ( G(IQ,O(PL))*FBBLL(  P2 ,  PL ,2,6)*FBBB(  PL ,PBB,5)
16062      &      +G(IQ,  PL )*FBBLL(  P2 ,O(PL),2,5)*FBBB(O(PL),PBB,6))*
16063      &         ( FBB(PB,  P1 ,2)*F1B(  P1 ,  P2 ,1,1)
16064      &          +FBB(PB,O(P1),1)*F1B(O(P1),  P2 ,2,1))
16065      &    +( G(IQ,O(PL))*FBBLL(O(P2),  PL ,1,6)*FBBB(  PL ,PBB,5)
16066      &      +G(IQ,  PL )*FBBLL(O(P2),O(PL),1,5)*FBBB(O(PL),PBB,6))*
16067      &         ( FBB(PB,  P1 ,2)*F1B(  P1 ,O(P2),1,2)
16068      &          +FBB(PB,O(P1),1)*F1B(O(P1),O(P2),2,2)))
16069 C--sixth amplitude from notes (5th with gluons interchanged)
16070         MGAMP(2) = MGAMP(2)+DCF(6)*(
16071      &     ( G(IQ,O(PL))*FBBLL(  P1 ,  PL ,1,6)*FBBB(  PL ,PBB,5)
16072      &      +G(IQ,  PL )*FBBLL(  P1 ,O(PL),1,5)*FBBB(O(PL),PBB,6))*
16073      &         ( FBB(PB,  P2 ,1)*F2B(  P2 ,  P1 ,2,2)
16074      &          +FBB(PB,O(P2),2)*F2B(O(P2),  P1 ,1,2))
16075      &    +( G(IQ,O(PL))*FBBLL(O(P1),  PL ,2,6)*FBBB(  PL ,PBB,5)
16076      &      +G(IQ,  PL )*FBBLL(O(P1),O(PL),2,5)*FBBB(O(PL),PBB,6))*
16077      &         ( FBB(PB,  P2 ,1)*F2B(  P2 ,O(P1),2,1)
16078      &          +FBB(PB,O(P2),2)*F2B(O(P2),O(P1),1,1)))
16079 C--seventh amplitude from notes (first non-Abelian one)
16080         MGAMP(3) = DCF(7)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
16081      &         G(IQ,O(PL))*FBB(PB,  PL ,6)*
16082      &                   ( FBLL(  PL ,1,5,1)*FBBB(1,PBB,1)
16083      &                    +FBLL(  PL ,2,5,1)*FBBB(2,PBB,1)
16084      &                    -FBLL(  PL ,1,5,2)*FBBB(1,PBB,2)
16085      &                    -FBLL(  PL ,2,5,2)*FBBB(2,PBB,2))
16086      &        +G(IQ,  PL )*FBB(PB,O(PL),5)*
16087      &                   ( FBLL(O(PL),1,6,1)*FBBB(1,PBB,1)
16088      &                    +FBLL(O(PL),2,6,1)*FBBB(2,PBB,1)
16089      &                    -FBLL(O(PL),1,6,2)*FBBB(1,PBB,2)
16090      &                    -FBLL(O(PL),2,6,2)*FBBB(2,PBB,2)))
16091 C--eighth amplitude from notes (second non-Abelian one)
16092 C--bug fix 12/7/03 by PR (too many continuations for NAG)
16093         MGAMP(3) = MGAMP(3)
16094      &        + DCF(8)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
16095      &         G(IQ,O(PL))*FBBB(  PL ,PBB,5)*
16096      &                   ( FBB(PB,1,1)*FBBLL(1,PL,1,6)
16097      &                    +FBB(PB,2,1)*FBBLL(2,PL,1,6)
16098      &                    -FBB(PB,1,2)*FBBLL(1,PL,2,6)
16099      &                    -FBB(PB,2,2)*FBBLL(2,PL,2,6))
16100      &        +G(IQ,  PL )*FBBB(O(PL),PBB,6)*
16101      &                   ( FBB(PB,1,1)*FBBLL(1,O(PL),1,5)
16102      &                    +FBB(PB,2,1)*FBBLL(2,O(PL),1,5)
16103      &                    -FBB(PB,1,2)*FBBLL(1,O(PL),2,5)
16104      &                    -FBB(PB,2,2)*FBBLL(2,O(PL),2,5)))
16105         MGAMP(1) = G(IDZ,PL)*(MGAMP(1)+MGAMP(3))
16106         MGAMP(2) = G(IDZ,PL)*(MGAMP(2)-MGAMP(3))
16107 C--now square them
16108         FLOW(1,1) = FLOW(1,1)+DREAL(MGAMP(1)*DCONJG(MGAMP(1)))
16109         FLOW(1,2) = FLOW(1,2)+DREAL(MGAMP(2)*DCONJG(MGAMP(2)))
16110         FLOW(1,3) = FLOW(1,3)+TWO*DREAL(MGAMP(1)*DCONJG(MGAMP(2)))
16111       ENDDO
16112       ENDDO
16113       ENDDO
16114       ENDDO
16115       ENDDO
16116 C--add up the diagrams to obtain the amplitudes for the two colour flows
16117       FLOW(1,1) = CGFC*FLOW(1,1)
16118       FLOW(1,2) = CGFC*FLOW(1,2)
16119       FLOW(1,3) = CGIFC*FLOW(1,3)
16120       DO I=1,2
16121         IF(FLOW(1,3).NE.ZERO) THEN
16122           MG(I) = PG*FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
16123         ELSE
16124           MG(I) = PG*FLOW(1,I)
16125         ENDIF
16126       ENDDO
16127 C--now q qbar --> q qbar Z
16128 C--calculate the denominators
16129       DCF(1) = -TWO*QBL/D(1,2)
16130       DCF(2) = -TWO*QBBL/D(1,2)
16131       DCF(3) = -TWO*Q1L*QBB
16132       DCF(4) = +TWO*Q2L*QBB
16133       DCF(5) =  TWO*Q1LB*Q2BB
16134       DCF(6) = -TWO*Q2LB*Q1B
16135       DCF(7) =  TWO*QBL*Q2BB
16136       DCF(8) = -TWO*QBBL*Q1B
16137       PQ = ONE/PBQB/PBBQBB
16138       DO P1=1,2
16139       DO PL=1,2
16140       DO PB=1,2
16141       DO PBB=1,2
16142 C--first the amplitudes for q qbar --> q' q'bar Z
16143 C--the first two amplitudes have Z off the final state and therefore
16144 C--the flavour of the incoming quarks doesn't matter
16145 C--first amplitude from notes
16146         MQAMP(3,P1,PL,PB,PBB) = G(IDZ,PL)*(
16147      &     DCF(1)*(G(IQ,O(PL))*FBB(O(PB),  PL ,6)*
16148      &                ( FBLL(  PL ,  P1 ,5,1)*FBBB(  P1 ,O(PBB),2)
16149      &                 +FBLL(  PL ,O(P1),5,2)*FBBB(O(P1),O(PBB),1))
16150      &            +G(IQ,  PL )*FBB(O(PB),O(PL),5)*
16151      &                ( FBLL(O(PL),  P1 ,6,1)*FBBB(  P1 ,O(PBB),2)
16152      &                 +FBLL(O(PL),O(P1),6,2)*FBBB(O(P1),O(PBB),1)))
16153 C--second amplitide from notes
16154      &    +DCF(2)*(G(IQ,O(PL))*FBBB(  PL ,O(PBB),5)*
16155      &          ( FBB(O(PB),  P1 ,1)*FBBLL(  P1 ,  PL ,2,6)
16156      &           +FBB(O(PB),O(P1),2)*FBBLL(O(P1),  PL ,1,6))
16157      &    +G(IQ,  PL )*FBBB(O(PL),O(PBB),6)*
16158      &          ( FBB(O(PB),  P1 ,1)*FBBLL(  P1 ,O(PL),2,5)
16159      &           +FBB(O(PB),O(P1),2)*FBBLL(O(P1),O(PL),1,5))))
16160 C--third amplitide from notes
16161         DO I=1,2
16162            MQAMP(I,P1,PL,PB,PBB) =
16163      &     DCF(3)*(G(I,O(PL))*DL(P1,O(PL))*S(5,1,  PL )*(
16164      &          S(1,6,O(PL))*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
16165      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
16166      &         -S(5,6,O(PL))*( FBB(O(PB),  P1 ,5)*FBBB(  P1 ,O(PBB),2)
16167      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),5)))
16168      &    +G(I,  PL )*DL(P1,  PL )*S(6,1,O(PL))*(
16169      &          S(1,5,  PL )*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
16170      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
16171      &      -S(6,5,  PL )*( FBB(O(PB),  P1 ,6)*FBBB(  P1 ,O(PBB),2)
16172      &                     +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),6))))
16173 C--fourth amplitude from notes
16174            MQAMP(I,P1,PL,PB,PBB) = MQAMP(I,P1,PL,PB,PBB)
16175      &    +DCF(4)*(G(I,O(PL))*DL(P1,O(PL))*S(2,6,  P1 )*(
16176      &          S(5,2,  PL )*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
16177      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
16178      &         -S(5,6,  PL )*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),6)
16179      &                        +FBB(O(PB),O(P1),6)*FBBB(O(P1),O(PBB),1)))
16180      &    +G(I,  PL )*DL(P1,  PL )*S(2,5,  P1 )*(
16181      &          S(6,2,O(PL))*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
16182      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
16183      &        -S(6,5,O(PL))*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),5)
16184      &                      +FBB(O(PB),O(P1),5)*FBBB(O(P1),O(PBB),1))))
16185            MQAMP(I,P1,PL,PB,PBB) = G(IDZ,PL)*MQAMP(I,P1,PL,PB,PBB)
16186         ENDDO
16187 C--now the extra amplitudes for q qbar --> q qbar Z
16188         DO P2=1,2
16189 C--first amplitude for notes
16190            MQQAMP(P1,P2,PL,PB,PBB) =
16191      &   DCF(5)*(DL(P2,PBB)*S(8,4,PBB)*(
16192      &          G(IQ,O(PL))*DL(P1,O(PL))*S(5,1,  PL )*
16193      &             ( FBB(O(PB),  PBB,8)*F1LL(  P2  ,  PL ,2,6)
16194      &              +FBB(O(PB),O(P2),2)*F1LL(O(PBB),  PL ,8,6))
16195      &         +G(IQ,  PL )*DL(P1,  PL )*S(6,1,O(PL))*
16196      &             ( FBB(O(PB),  PBB ,8)*F1LL(  P2  ,O(PL),2,5)
16197      &              +FBB(O(PB),O(P2) ,2)*F1LL(O(PBB),O(PL),8,5)))
16198      &      -QM*DL(P2,O(PBB))*(
16199      &          G(IQ,O(PL))*DL(P1,O(PL))*S(5,1,PL)*
16200      &             ( FBB(O(PB),O(PBB),8)*F1LL(  P2  ,  PL ,2,6)
16201      &              +FBB(O(PB),O(P2) ,2)*F1LL(  PBB ,  PL ,8,6))
16202      &         +G(IQ,  PL )*DL(P1,  PL )*S(6,1,O(PL))*
16203      &             ( FBB(O(PB),O(PBB),8)*F1LL(  P2  ,O(PL),2,5)
16204      &              +FBB(O(PB), O(P2),2)*F1LL(  PBB ,O(PL),8,5))))
16205 C--second amplitude from notes
16206            MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
16207      &  +DCF(6)*(DL(P1,PB)*S(3,7,O(PB))*(
16208      &          G(IQ,O(PL))*DL(P2,O(PL))*S(2,6,  P2 )*
16209      &             ( F2LL(  PL ,  P1 ,5,1)*FBBB(  PB ,O(PBB),7)
16210      &              +F2LL(  PL ,O(PB),5,7)*FBBB(O(P1),O(PBB),1))
16211      &         +G(IQ,  PL )*DL(P2,  PL )*S(2,5,  P2 )*
16212      &             ( F2LL(O(PL),  P1 ,6,1)*FBBB(  PB ,O(PBB),7)
16213      &              +F2LL(O(PL),O(PB),6,7)*FBBB(O(P1),O(PBB),1)))
16214      &     -QM*DL(P1,O(PB))*(
16215      &          G(IQ,O(PL))*DL(P2,O(PL))*S(2,6,  P2 )*
16216      &             ( F2LL(  PL ,  P1 ,5,1)*FBBB(O(PB),O(PBB),7)
16217      &              +F2LL(  PL ,  PB ,5,7)*FBBB(O(P1),O(PBB),1))
16218      &         +G(IQ,  PL )*DL(P2,  PL )*S(2,5,  P2 )*
16219      &             ( F2LL(O(PL),  P1 ,6,1)*FBBB(O(PB),O(PBB),7)
16220      &              +F2LL(O(PL),  PB ,6,7)*FBBB(O(P1),O(PBB),1))))
16221 C--third  amplitude from notes
16222            MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
16223      &  +DCF(7)*(DL(P2,PBB)*S(8,4,PBB)*(
16224      &          G(IQ,O(PL))*FBB(O(PB),  PL ,6)*
16225      &             ( DL(P2,O(P1) )*S(2,1,  P2  )*FBLL(  PL , PBB ,5,8)
16226      &              +DL(P1,PBB   )*S(8,1,O(PBB))*FBLL(  PL ,O(P2),5,2))
16227      &         +G(IQ,  PL )*FBB(O(PB),O(PL),5)*
16228      &             ( DL(P2,O(P1) )*S(2,1,  P2  )*FBLL(O(PL), PBB ,6,8)
16229      &              +DL(P1,PBB   )*S(8,1,O(PBB))*FBLL(O(PL),O(P2),6,2)))
16230      &      -QM*DL(P2,O(PBB))*(
16231      &          G(IQ,O(PL))*FBB(O(PB),PL,6)*
16232      &             ( DL(P2,O(P1) )*S(2,1,  P2  )*FBLL(  PL ,O(PBB),5,8)
16233      &              +DL(P1,O(PBB))*S(8,1,  PBB )*FBLL(  PL ,O(P2) ,5,2))
16234      &         +G(IQ,  PL )*FBB(O(PB),O(PB),5)*
16235      &           ( DL(P2,O(PL) )*S(2,1,  P2  )*FBLL(O(PL),O(PBB),6,8)
16236      &            +DL(P1,O(PBB))*S(8,1,  PBB )*FBLL(O(PL),O(P2) ,6,2))))
16237 C--fourth amplitude from notes
16238            MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
16239      &  +DCF(8)*(DL(P1,PB)*S(3,7,O(PB))*(
16240      &          DL(P1,O(P2))*S(2,1,P2)*
16241      &           ( G(IQ,O(PL))*FBBLL(PB,  PL ,7,6)*FBBB(  PL ,O(PBB),5)
16242      &            +G(IQ,  PL )*FBBLL(PB,O(PL),7,5)*FBBB(O(PL),O(PBB),6))
16243      &         +DL(P2,PB)*S(2,7,P2)*
16244      &     (G(IQ,O(PL))*FBBLL(O(P1),  PL ,1,6)*FBBB(  PL ,O(PBB),5)
16245      &     +G(IQ,   PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6)))
16246      &       +QM*DL(P1,O(PB))*(
16247      &          DL(P2,O(P1))*S(2,1,P2)*
16248      &        ( G(IQ,O(PL))*FBBLL(O(PB),  PL ,3,6)*FBBB(  PL ,O(PBB),5)
16249      &         +G(IQ,  PL )*FBBLL(O(PB),O(PL),3,5)*FBBB(O(PL),O(PBB),6))
16250      &          +DL(P2,O(PB))*S(2,3,P2)*
16251      &      ( G(IQ,O(PL))*FBBLL(O(P1),  PL ,1,6)*FBBB(  PL ,O(PBB),5)
16252      &      +G(IQ,  PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6))))
16253            MQQAMP(P1,P2,PL,PB,PBB) =  G(IDZ,PL)*MQQAMP(P1,P2,PL,PB,PBB)
16254         ENDDO
16255       ENDDO
16256       ENDDO
16257       ENDDO
16258       ENDDO
16259 C--now obtain the matrix elements squared for the quarks
16260       DO I=1,3
16261          DO J=1,3
16262             FLOW(I,J) = ZERO
16263          ENDDO
16264       ENDDO
16265       IF(MOD(IQ,2).EQ.1) THEN
16266         IQI = 1
16267       ELSE
16268         IQI = 2
16269       ENDIF
16270       DO P1=1,2
16271       DO PL=1,2
16272       DO PB=1,2
16273       DO PBB=1,2
16274 C--different quarks in inital and final states
16275          DO I=1,2
16276             MQP(I) = MQAMP(I,P1,PL,PB,PBB)+MQAMP(3,P1,PL,PB,PBB)
16277             FLOW(I,1) = FLOW(I,1)+DREAL(DCONJG(MQP(I))*MQP(I))
16278          ENDDO
16279 C--same quark in inital and final state
16280          DO P2=1,2
16281             FLOW(3,2) = FLOW(3,2)+DREAL(
16282      &          DCONJG(MQQAMP(P1,P2,PL,PB,PBB))*MQQAMP(P1,P2,PL,PB,PBB))
16283            IF(P1.EQ.P2) THEN
16284               FLOW(3,1) = FLOW(3,1)+DREAL(DCONJG(MQP(IQI))*MQP(IQI))
16285               FLOW(3,3) = FLOW(3,3)-TWO*
16286      &           DREAL(DCONJG(MQP(IQI))*MQQAMP(P1,P2,PL,PB,PBB))
16287            ENDIF
16288          ENDDO
16289       ENDDO
16290       ENDDO
16291       ENDDO
16292       ENDDO
16293 C--split up the non-planar pieces according to Kosuke's prescription
16294       DO I=1,3
16295       FLOW(I,1) =  CQFC*FLOW(I,1)
16296       FLOW(I,2) =  CQFC*FLOW(I,2)
16297       FLOW(I,3) = CQIFC*FLOW(I,3)
16298         DO J=1,2
16299           IF(FLOW(I,J).NE.ZERO) THEN
16300              MQB(J,I) = PQ*FLOW(I,J)*
16301      &                            (ONE+FLOW(I,3)/(FLOW(I,1)+FLOW(I,2)))
16302           ELSE
16303              MQB(J,I) = ZERO
16304           ENDIF
16305         ENDDO
16306       ENDDO
16307 C--now set them
16308       DO I=1,5
16309         IF(I.EQ.IQ) THEN
16310           DO J=1,2
16311             MQ(J,I) = MQB(J,3)
16312           ENDDO
16313         ELSEIF(MOD(I,2).EQ.1) THEN
16314           DO J=1,2
16315             MQ(J,I) = MQB(J,1)
16316           ENDDO
16317         ELSE
16318           DO J=1,2
16319             MQ(J,I) = MQB(J,2)
16320           ENDDO
16321         ENDIF
16322       ENDDO
16323       END
16324 CDECK  ID>, HWH2PS.
16325 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
16326 *-- Author :    Peter Richardson
16327 C-----------------------------------------------------------------------
16328       SUBROUTINE HWH2PS(WEIGHT,GEN,MQ,MQ2)
16329 C-----------------------------------------------------------------------
16330 C     Phase Space for vector boson plus 2 jets
16331 C-----------------------------------------------------------------------
16332       INCLUDE 'herwig65.inc'
16333       DOUBLE PRECISION WEIGHT,XMASS,PLAB,PRW,PCM,Y(3),Y35,Y34,Y45,RAND,
16334      &     HWRGEN,HWRUNI,M35,M35S,G(IMAXCH),DEM,MT(3),PT(3),MJAC,ETOT,
16335      &     STOT,MQ(3),MQ2(3),PS35,HWUPCM,TWOPI2,MT35,PTJ(3),MT2(3),A,C,
16336      &     PT2(3),YMIN,YMAX,EY(3),EY34,YJAC,YJJMAX,YJJMIN,EY35,PHI(3),
16337      &     MT45,PS45,EY45,M45,M45S,M34,PS34,M34S,MT34,XJAC,SJAC,PST,TAU,
16338      &     FLUX,ETMP,PZTMP,XT1,XT2,WI(IMAXCH)
16339       COMMON /HWPSOM/ WI
16340       INTEGER I,ICH,J
16341       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
16342       LOGICAL GEN
16343       EXTERNAL HWRGEN,HWRUNI,HWUPCM
16344       PARAMETER(YJJMIN=-8.0D0,YJJMAX=8.0D0)
16345       IF(IERROR.NE.0) RETURN
16346       TWOPI2 = FOUR*PIFAC**2
16347       WEIGHT = ZERO
16348       IF(OPTM) THEN
16349         DO I=1,IMAXCH
16350           WI(I) = ZERO
16351         ENDDO
16352       ENDIF
16353       GEN = .FALSE.
16354 C--centre of mass energy
16355       ETOT = PHEP(5,3)
16356       STOT = ETOT**2
16357 C--first select the channel to be used
16358       RAND=HWRGEN(0)
16359       DO ICH=1,IMAXCH
16360         IF(CHON(ICH)) THEN
16361           IF(CHNPRB(ICH).GT.RAND) GOTO 10
16362           RAND = RAND-CHNPRB(ICH)
16363         ENDIF
16364       ENDDO
16365  10   CONTINUE
16366 C--generate the phase space according to the channel selected
16367 C--FIRST CHANNEL
16368       IF(ICH.EQ.1) THEN
16369 C--first generate the mass of 35
16370         CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
16371         M35 = SQRT(M35S)
16372         PS35 = HWUPCM(M35,MQ(1),MQ(3))
16373         MJAC = HALF*MJAC*PS35/M35/TWOPI2
16374 C--the generate the PT of 4
16375         CALL HWH2P2(2,PTJ(1),MT2(2),MQ2(2)+PTMAX**2,MQ2(2)+PTMIN**2)
16376         MT (2) = SQRT(MT2(2))
16377         PT2(2) = MT2(2)-MQ2(2)
16378         PT(2)  = SQRT(PT2(2))
16379         MT35   = SQRT(M35S+PT2(2))
16380 C--generate the rapidities of 4 and 35
16381         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
16382         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
16383         IF(YMAX.LT.YMIN) RETURN
16384         Y35   = HWRUNI(1,YMIN,YMAX)
16385         EY35  = EXP(Y35)
16386         YJAC  = (YMAX-YMIN)
16387         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
16388         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
16389         IF(YMAX.LT.YMIN) RETURN
16390         Y(2)  = HWRUNI(2,YMIN,YMAX)
16391         YJAC  = (YMAX-YMIN)*YJAC
16392         EY(2) = EXP(Y(2))
16393 C--generate the incoming quark momentum fractions
16394         XX(1) = (MT(2)*EY(2)+MT35*EY35)/ETOT
16395         XX(2) = (MT(2)/EY(2)+MT35/EY35)/ETOT
16396         STOT = XX(1)*XX(2)*STOT
16397 C--azimuthal angle of 4 and 35
16398         PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16399 C--construct the momenta of 4 and 35
16400         PLAB(1,4) = PT(2)*SIN(PHI(1))
16401         PLAB(2,4) = PT(2)*COS(PHI(1))
16402         PLAB(3,4) = HALF*MT(2)*(EY(2)-ONE/EY(2))
16403         PLAB(4,4) = HALF*MT(2)*(EY(2)+ONE/EY(2))
16404         PLAB(5,4) = MQ(2)
16405         PLAB(1,6) =-PT(2)*SIN(PHI(1))
16406         PLAB(2,6) =-PT(2)*COS(PHI(1))
16407         PLAB(3,6) = HALF*MT35*(EY35-ONE/EY35)
16408         PLAB(4,6) = HALF*MT35*(EY35+ONE/EY35)
16409         PLAB(5,6) = M35
16410 C--perform the decay 35 --> 3+5
16411         PLAB(5,3) = MQ(1)
16412         PLAB(5,5) = MQ(3)
16413         CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
16414 C--phase space weight
16415         FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16416 C--SECOND CHANNEL
16417       ELSEIF(ICH.EQ.2) THEN
16418 C--first generate the pt's and azimuthal angles of 3 and 4
16419         DO I=1,2
16420            CALL HWH2P2(2,PTJ(I),MT2(I),MQ2(I)+PTMAX**2,MQ2(I)+PTMIN**2)
16421            PT2(I) = MT2(I)-MQ2(I)
16422            MT(I) = SQRT(MT2(I))
16423            PT(I) = SQRT(PT2(I))
16424            PHI(I) = HWRUNI(I,ZERO,TWO*PIFAC)
16425         ENDDO
16426 C--find the pt and azimuth of 5 by conservation of transverse momentum
16427         A      = PT(1)*SIN(PHI(1))+PT(2)*SIN(PHI(2))
16428         C      = PT(1)*COS(PHI(1))+PT(2)*COS(PHI(2))
16429         PT(3)  = A**2+C**2
16430         MT(3)  = SQRT(PT(3)+MQ2(3))
16431         PT(3)  = SQRT(PT(3))
16432         PHI(3) = -ACOS(-C/PT(3))
16433         IF(A.LT.ZERO) PHI(3)=-PHI(3)
16434 C--generate the rapidities of 3,4 and 5
16435         XX(1) = ZERO
16436         XX(2) = ZERO
16437         YJAC  = ONE
16438         DO I=1,3
16439           YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XX(1))/MT(I)))
16440           YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XX(2))/MT(I)))
16441           IF(YMAX.LT.YMIN) RETURN
16442           Y(I)  = HWRUNI(I+2,YMIN,YMAX)
16443           EY(I) = EXP(Y(I))
16444           XX(1) = XX(1)+MT(I)*EY(I)
16445           XX(2) = XX(2)+MT(I)/EY(I)
16446           YJAC  = YJAC*(YMAX-YMIN)
16447         ENDDO
16448 C--generate the incoming quark momentum fractions
16449         XX(1) = XX(1)/PHEP(5,3)
16450         XX(2) = XX(2)/PHEP(5,3)
16451         IF(XX(1).GT.ONE.OR.XX(2).GT.ONE) RETURN
16452 C--Construct the 4-momenta of the outgoing particles
16453         DO I=1,3
16454           PLAB(1,I+2) = PT(I)*SIN(PHI(I))
16455           PLAB(2,I+2) = PT(I)*COS(PHI(I))
16456           PLAB(3,I+2) = HALF*MT(I)*(EY(I)-ONE/EY(I))
16457           PLAB(4,I+2) = HALF*MT(I)*(EY(I)+ONE/EY(I))
16458           PLAB(5,I+2) = MQ(I)
16459        ENDDO
16460 C--phase space weight
16461        STOT = XX(1)*XX(2)*STOT
16462        FLUX = YJAC*PTJ(1)*PTJ(2)/64.0D0/PIFAC/TWOPI2/STOT**2
16463 C--THIRD CHANNEL
16464       ELSEIF(ICH.EQ.3) THEN
16465 C--first generate the mass of 45
16466         CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16467         M45 = SQRT(M45S)
16468         PS45 = HWUPCM(M45,MQ(2),MQ(3))
16469         MJAC = HALF*MJAC*PS45/M45/TWOPI2
16470 C--the generate the PT of 4
16471         CALL HWH2P2(2,PTJ(1),MT2(1),MQ2(1)+PTMAX**2,MQ2(1)+PTMIN**2)
16472         MT (1) = SQRT(MT2(1))
16473         PT2(1) = MT2(1)-MQ2(1)
16474         PT(1)  = SQRT(PT2(1))
16475         MT45   = SQRT(M45S+PT2(1))
16476 C--generate the rapidities of 3 and 45
16477         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
16478         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
16479         IF(YMAX.LT.YMIN) RETURN
16480         Y45   = HWRUNI(1,YMIN,YMAX)
16481         EY45  = EXP(Y45)
16482         YJAC  = (YMAX-YMIN)
16483         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
16484         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
16485         IF(YMAX.LT.YMIN) RETURN
16486         Y(1)  = HWRUNI(2,YMIN,YMAX)
16487         YJAC  = (YMAX-YMIN)*YJAC
16488         EY(1) = EXP(Y(1))
16489 C--generate the incoming quark momentum fractions
16490         XX(1) = (MT(1)*EY(1)+MT45*EY45)/ETOT
16491         XX(2) = (MT(1)/EY(1)+MT45/EY45)/ETOT
16492         STOT = XX(1)*XX(2)*STOT
16493 C--azimuthal angle of 3 and 45
16494         PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16495 C--construct the momenta of 3 and 45
16496         PLAB(1,3) = PT(1)*SIN(PHI(1))
16497         PLAB(2,3) = PT(1)*COS(PHI(1))
16498         PLAB(3,3) = HALF*MT(1)*(EY(1)-ONE/EY(1))
16499         PLAB(4,3) = HALF*MT(1)*(EY(1)+ONE/EY(1))
16500         PLAB(5,3) = MQ(1)
16501         PLAB(1,6) =-PT(1)*SIN(PHI(1))
16502         PLAB(2,6) =-PT(1)*COS(PHI(1))
16503         PLAB(3,6) = HALF*MT45*(EY45-ONE/EY45)
16504         PLAB(4,6) = HALF*MT45*(EY45+ONE/EY45)
16505         PLAB(5,6) = M45
16506 C--perform the decay 45 --> 4+5
16507         PLAB(5,4) = MQ(2)
16508         PLAB(5,5) = MQ(3)
16509         CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
16510 C--phase space weight
16511         FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16512 C--FOURTH CHANNEL
16513       ELSEIF(ICH.EQ.4) THEN
16514 C--generate shat according to a power law
16515         CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
16516      &                                        (MQ(1)+MQ(2)+MQ(3))**2)
16517         ETOT = SQRT(STOT)
16518 C--generate x1
16519         TAU   = STOT/PHEP(5,3)**2
16520         XJAC  = -LOG(TAU)
16521         XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
16522         XX(2) = TAU/XX(1)
16523 C--generate m35
16524         CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,
16525      &                                               (MQ(1)+MQ(3))**2)
16526         M35 = SQRT(M35S)
16527         PS35 = HWUPCM(M35,MQ(1),MQ(3))
16528         MJAC = HALF*MJAC*PS35/M35/TWOPI2
16529 C--generate the momenta of 4 and 35
16530         PST = HWUPCM(ETOT,M35,MQ(2))
16531         PLAB(1,7) = ZERO
16532         PLAB(2,7) = ZERO
16533         PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
16534         PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
16535         PLAB(5,7) = ETOT
16536         PLAB(5,3) = MQ(1)
16537         PLAB(5,6) = M35
16538         PLAB(5,4) = MQ(2)
16539         CALL HWDTWO(PLAB(1,7),PLAB(1,4),PLAB(1,6),PST,TWO,.TRUE.)
16540 C--perform the decay 35 --> 3+5
16541         PLAB(5,4) = MQ(2)
16542         PLAB(5,5) = MQ(3)
16543         CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
16544 C--phase space weight
16545         FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
16546 C--FIFTH CHANNEL
16547       ELSEIF(ICH.EQ.5) THEN
16548 C--generate shat according to a power law
16549         CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
16550      &                                        (MQ(1)+MQ(2)+MQ(3))**2)
16551         ETOT = SQRT(STOT)
16552 C--generate x1
16553         TAU   = STOT/PHEP(5,3)**2
16554         XJAC  = -LOG(TAU)
16555         XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
16556         XX(2) = TAU/XX(1)
16557 C--generate m45
16558         CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16559         M45 = SQRT(M45S)
16560         PS45 = HWUPCM(M45,MQ(2),MQ(3))
16561         MJAC = HALF*MJAC*PS45/M45/TWOPI2
16562 C--generate the momenta of 4 and 35
16563         PST = HWUPCM(ETOT,M45,MQ(1))
16564         PLAB(1,7) = ZERO
16565         PLAB(2,7) = ZERO
16566         PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
16567         PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
16568         PLAB(5,7) = ETOT
16569         PLAB(5,3) = MQ(1)
16570         PLAB(5,6) = M45
16571         CALL HWDTWO(PLAB(1,7),PLAB(1,3),PLAB(1,6),PST,TWO,.TRUE.)
16572 C--perform the decay 45 --> 4+5
16573         PLAB(5,4) = MQ(2)
16574         PLAB(5,5) = MQ(3)
16575         CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
16576 C--phase space weight
16577         FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
16578 C--SIXTH CHANNEL
16579       ELSEIF(ICH.EQ.6) THEN
16580 C--first generate the mass of 34
16581         CALL HWH2P1(2,MJAC,ZERO,M34S,(ETOT-MQ(3))**2,MJJMIN**2)
16582         M34 = SQRT(M34S)
16583         PS34 = HWUPCM(M34,MQ(1),MQ(2))
16584         MJAC = HALF*MJAC*PS34/M34/TWOPI2
16585 C--the generate the PT of 5
16586         CALL HWH2P2(2,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
16587         MT (3) = SQRT(MT2(3))
16588         PT2(3) = MT2(3)-MQ2(3)
16589         PT(3)  = SQRT(PT2(3))
16590         MT34   = SQRT(M34S+PT2(3))
16591 C--generate the rapidities of 5 and 34
16592         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
16593         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
16594         IF(YMAX.LT.YMIN) RETURN
16595         Y34   = HWRUNI(1,YMIN,YMAX)
16596         EY34  = EXP(Y34)
16597         YJAC  = (YMAX-YMIN)
16598         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
16599         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
16600         IF(YMAX.LT.YMIN) RETURN
16601         Y(3)  = HWRUNI(2,YMIN,YMAX)
16602         YJAC  = (YMAX-YMIN)*YJAC
16603         EY(3) = EXP(Y(3))
16604 C--generate the incoming quark momentum fractions
16605         XX(1) = (MT(3)*EY(3)+MT34*EY34)/ETOT
16606         XX(2) = (MT(3)/EY(3)+MT34/EY34)/ETOT
16607         STOT = XX(1)*XX(2)*STOT
16608 C--azimuthal angle of 3 and 45
16609         PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16610 C--construct the momenta of 5 and 34
16611         PLAB(1,5) = PT(3)*SIN(PHI(1))
16612         PLAB(2,5) = PT(3)*COS(PHI(1))
16613         PLAB(3,5) = HALF*MT(3)*(EY(3)-ONE/EY(3))
16614         PLAB(4,5) = HALF*MT(3)*(EY(3)+ONE/EY(3))
16615         PLAB(5,5) = MQ(3)
16616         PLAB(1,6) =-PT(3)*SIN(PHI(1))
16617         PLAB(2,6) =-PT(3)*COS(PHI(1))
16618         PLAB(3,6) = HALF*MT34*(EY34-ONE/EY34)
16619         PLAB(4,6) = HALF*MT34*(EY34+ONE/EY34)
16620         PLAB(5,6) = M34
16621 C--perform the decay 34 --> 3+4
16622         PLAB(5,3) = MQ(1)
16623         PLAB(5,4) = MQ(2)
16624         CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,4),PS34,TWO,.TRUE.)
16625 C--phase space weight
16626         FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16627       ELSE
16628         CALL HWWARN('HWH2PS',500)
16629       ENDIF
16630 C--calculate the variables we need for the smoothing functions
16631 C--pt,mt and y for outgoing particles
16632       DO I=1,3
16633         J=I+2
16634         PT2(I) = PLAB(1,J)**2+PLAB(2,J)**2
16635         PT(I)  = SQRT(PT2(I))
16636         MT2(I) = MQ2(I)+PT2(I)
16637         MT(I)  = SQRT(MT2(I))
16638         Y(I)   = HALF*LOG((PLAB(4,J)+PLAB(3,J))/(PLAB(4,J)-PLAB(3,J)))
16639         EY(I)  = EXP(Y(I))
16640         IF(I.LE.2.AND.(Y(I).LT.YJMIN.OR.Y(I).GT.YJMAX)) RETURN
16641       ENDDO
16642       IF(PT(1).LT.PTMIN.OR.PT(2).LT.PTMIN) RETURN
16643 C--masses of composite particles
16644       M34S = (PLAB(4,3)+PLAB(4,4))**2
16645       M45S = (PLAB(4,4)+PLAB(4,5))**2
16646       M35S = (PLAB(4,3)+PLAB(4,5))**2
16647       DO I=1,3
16648         M34S = M34S-(PLAB(I,3)+PLAB(I,4))**2
16649         M45S = M45S-(PLAB(I,4)+PLAB(I,5))**2
16650         M35S = M35S-(PLAB(I,3)+PLAB(I,5))**2
16651       ENDDO
16652       M34 = SQRT(M34S)
16653       M45 = SQRT(M45S)
16654       M35 = SQRT(M35S)
16655       IF(M34.LT.MJJMIN) RETURN
16656 C--tramsverse masses of the composite particles
16657       MT34 = ZERO
16658       MT35 = ZERO
16659       MT45 = ZERO
16660       DO I=1,2
16661         MT34 = MT34+(PLAB(I,3)+PLAB(I,4))**2
16662         MT35 = MT35+(PLAB(I,3)+PLAB(I,5))**2
16663         MT45 = MT45+(PLAB(I,4)+PLAB(I,5))**2
16664       ENDDO
16665       MT34 = SQRT(M34S+MT34)
16666       MT35 = SQRT(M35S+MT35)
16667       MT45 = SQRT(M45S+MT45)
16668 C--final the momenta
16669       PS34 = HWUPCM(M34,MQ(1),MQ(2))
16670       PS35 = HWUPCM(M35,MQ(1),MQ(3))
16671       PS45 = HWUPCM(M45,MQ(2),MQ(3))
16672 C--the rapidities of the composite particles
16673       ETMP  = PLAB(4,3)+PLAB(4,4)
16674       PZTMP = PLAB(3,3)+PLAB(3,4)
16675       Y34   = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16676       EY34  = EXP(Y34)
16677       ETMP  = PLAB(4,3)+PLAB(4,5)
16678       PZTMP = PLAB(3,3)+PLAB(3,5)
16679       Y35   = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16680       EY35  = EXP(Y35)
16681       ETMP  = PLAB(4,4)+PLAB(4,5)
16682       PZTMP = PLAB(3,4)+PLAB(3,5)
16683       Y45   = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16684       EY45  = EXP(Y45)
16685 C--find the pdf's and set the scale
16686       ETOT = SQRT(STOT)
16687       EMSCA = ETOT
16688       CALL HWSGEN(.FALSE.)
16689 C--construct the incoming momenta
16690       DO I=1,2
16691         PLAB(1,I) = ZERO
16692         PLAB(2,I) = ZERO
16693         PLAB(3,I) = HALF*XX(I)*PHEP(5,3)
16694         PLAB(4,I) = HALF*XX(I)*PHEP(5,3)
16695         PLAB(5,I) = ZERO
16696       ENDDO
16697       PLAB(3,2) = -PLAB(3,2)
16698       TAU   = XX(1)*XX(2)
16699 C--find the smoothing functions for the different channels
16700 C--function for first channel
16701       IF(CHON(1)) THEN
16702         CALL HWH2P1(1,MJAC,MQ2(1),M35S,(PHEP(5,3)-MQ(2))**2,
16703      &                                              (MQ(1)+MQ(3))**2)
16704         MJAC = MJAC/PS35*M35
16705         CALL HWH2P2(1,PTJ(1),MT2(2),PTMAX**2+MQ2(2),MQ2(2)+PTMIN**2)
16706         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
16707         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
16708         YJAC  = (YMAX-YMIN)
16709         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
16710         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
16711         YJAC  = (YMAX-YMIN)*YJAC
16712         G(1)  = 2.0D0*MJAC*PTJ(1)/YJAC
16713       ENDIF
16714 C--function for second channel
16715       IF(CHON(2)) THEN
16716         DO I=1,2
16717            CALL HWH2P2(1,PTJ(I),MT2(I),PTMAX**2+MQ2(I),MQ2(I)+PTMIN**2)
16718         ENDDO
16719         XT1 = ZERO
16720         XT2 = ZERO
16721         YJAC  = ONE
16722         DO I=1,3
16723           YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XT1)/MT(I)))
16724           YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XT2)/MT(I)))
16725           XT1  = XT1+MT(I)*EY(I)
16726           XT2  = XT2+MT(I)/EY(I)
16727           YJAC  = YJAC*(YMAX-YMIN)
16728         ENDDO
16729         G(2) = 4.0D0*PTJ(1)*PTJ(2)/YJAC
16730       ENDIF
16731 C--function for third channel
16732       IF(CHON(3)) THEN
16733         CALL HWH2P1(1,MJAC,MQ2(2),M45S,(PHEP(5,3)-MQ(1))**2,
16734      &                                            (MQ(2)+MQ(3))**2)
16735         MJAC = MJAC/PS45*M45
16736         CALL HWH2P2(1,PTJ(1),MT2(1),PTMAX**2+MQ2(1),MQ2(1)+PTMIN**2)
16737         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
16738         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
16739         YJAC  = (YMAX-YMIN)
16740         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
16741         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
16742         YJAC  = (YMAX-YMIN)*YJAC
16743         G(3)  = 2.0D0*MJAC*PTJ(1)/YJAC
16744       ENDIF
16745 C--function for fourth channel
16746       IF(CHON(4)) THEN
16747         CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
16748      &                                        (MQ(1)+MQ(2)+MQ(3))**2)
16749         XJAC  = -LOG(TAU)
16750         CALL HWH2P1(1,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
16751         M35 = SQRT(M35S)
16752         MJAC = MJAC/PS35*M35
16753         PST = HWUPCM(ETOT,M35,MQ(2))
16754         G(4) = SJAC*MJAC/XJAC*ETOT/PST
16755       ENDIF
16756 C--function for fifth channel
16757       IF(CHON(5)) THEN
16758         CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
16759      &                                        (MQ(1)+MQ(2)+MQ(3))**2)
16760         XJAC  = -LOG(TAU)
16761         CALL HWH2P1(1,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16762         MJAC = MJAC/PS45*M45
16763         PST = HWUPCM(ETOT,M45,MQ(1))
16764         G(5) = SJAC/XJAC*MJAC/PST*ETOT
16765       ENDIF
16766 C--function for sixth chaneel
16767       IF(CHON(6)) THEN
16768         CALL HWH2P1(1,MJAC,ZERO,M34S,(PHEP(5,3)-MQ(3))**2,MJJMIN**2)
16769         MJAC = MJAC/PS34*M34
16770         CALL HWH2P2(1,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
16771         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
16772         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
16773         YJAC  = (YMAX-YMIN)
16774         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
16775         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
16776         YJAC  = (YMAX-YMIN)*YJAC
16777         G(6)  = 2.0D0*MJAC/YJAC*PTJ(1)
16778       ENDIF
16779 C--add them all up
16780       DEM = ZERO
16781       DO I=1,IMAXCH
16782         IF(CHON(I)) DEM = DEM+CHNPRB(I)*G(I)
16783       ENDDO
16784 C--now the weight
16785       WEIGHT = FLUX*GEV2NB*G(ICH)/DEM
16786       GEN = .TRUE.
16787 C--compute the weights for the different channels if optimizing
16788       IF(OPTM) THEN
16789         DO I=1,IMAXCH
16790           IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
16791         ENDDO
16792       ENDIF
16793       END
16794 CDECK  ID>, HWH2P1.
16795 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
16796 *-- Author :    Peter Richardson
16797 C-----------------------------------------------------------------------
16798       SUBROUTINE HWH2P1(IOPT,FJAC,MQ2,M2,MMX,MMN)
16799 C-----------------------------------------------------------------------
16800 C     Subroutine to select virtual quark mass for HWH2PS
16801 C     IOPT=1 return the function at M2
16802 C     IOPT=2 calculate M2
16803 C-----------------------------------------------------------------------
16804       INCLUDE 'herwig65.inc'
16805       INTEGER IOPT
16806       DOUBLE PRECISION FJAC,MPOW,MMN,MQ2,M2,A1,A01,RPOW,QPOW,HWRGEN,MMX
16807       EXTERNAL HWRGEN
16808 C--smooth a powerlaw
16809       IF(EMPOW.EQ.TWO) THEN
16810         A01   = LOG(MMN-MQ2)
16811         A1    = LOG(MMX-MQ2)-A01
16812         IF(IOPT.EQ.1) THEN
16813           FJAC = ONE/(M2-MQ2)/A1
16814         ELSE
16815           M2 = EXP(A01+A1*HWRGEN(2))
16816           FJAC  = A1*M2
16817           M2 = M2+MQ2
16818         ENDIF
16819       ELSE
16820         MPOW = -EMPOW/TWO
16821         QPOW =  ONE+MPOW
16822         RPOW =  ONE/QPOW
16823         A01  =  (MMN-MQ2)**QPOW
16824         A1   =  (MMX-MQ2)**QPOW-A01
16825         IF(IOPT.EQ.1) THEN
16826           FJAC = QPOW*(M2-MQ2)**MPOW/A1
16827         ELSE
16828           M2 = (A01+A1*HWRGEN(2))**RPOW
16829           FJAC  = A1*RPOW/M2**MPOW
16830           M2 = M2+MQ2
16831         ENDIF
16832       ENDIF
16833       END
16834 CDECK  ID>, HWH2P2.
16835 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
16836 *-- Author :    Peter Richardson
16837 C-----------------------------------------------------------------------
16838       SUBROUTINE HWH2P2(IOPT,FJAC,PT2,PTMX2,PTMN2)
16839 C-----------------------------------------------------------------------
16840 C     Subroutine to select virtual quark mass for HWH2PS
16841 C     IOPT=1 return the function at M2
16842 C     IOPT=2 calculate M2
16843 C-----------------------------------------------------------------------
16844       INCLUDE 'herwig65.inc'
16845       INTEGER IOPT
16846       DOUBLE PRECISION FJAC,MPOW,A1,A01,RPOW,QPOW,HWRGEN,PT2,
16847      &     PPOW,PTMN2,PTMX2,Z
16848       EXTERNAL HWRGEN
16849 C--smooth a powerlaw
16850       PPOW = HALF*PTPOW
16851       IF(PPOW.EQ.ONE) THEN
16852         A01   = LOG(PTMN2)
16853         A1    = LOG(PTMX2)-A01
16854         IF(IOPT.EQ.1) THEN
16855           FJAC = ONE/PT2/A1
16856         ELSE
16857           PT2 = EXP(A01+A1*HWRGEN(2))
16858           FJAC  = A1*PT2
16859         ENDIF
16860       ELSE
16861         MPOW = -PPOW
16862         QPOW =  ONE+MPOW
16863         RPOW =  ONE/QPOW
16864         A01  =  PTMN2**QPOW
16865         A1   =  PTMX2**QPOW-A01
16866         IF(IOPT.EQ.1) THEN
16867           FJAC = QPOW*PT2**MPOW/A1
16868         ELSE
16869           Z    = A01+A1*HWRGEN(2)
16870           PT2  = Z**RPOW
16871           FJAC = A1*RPOW/Z*PT2
16872         ENDIF
16873       ENDIF
16874       END
16875 CDECK  ID>, HWH2QH.
16876 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
16877 *-- Author :  Kosuke Odagiri
16878 C-----------------------------------------------------------------------
16879       SUBROUTINE HWH2QH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,FACGPM,MGM3,
16880      & IGG,IQQ,GGQQHT,GGQQHU,GGQQHNP,QQQQH)
16881 C-----------------------------------------------------------------------
16882 C     MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> QQ(BAR) HIGGS
16883 C-----------------------------------------------------------------------
16884 C     NEEDS PREFACTOR G_S^4. COUPLINGS, E.G. FOR T(3)B(4)H-(5) ARE:
16885 C     FACGPM(1) = GW/SQRT(TWO) M_B / M_W * TANB
16886 C     FACGPM(2) = GW/SQRT(TWO) M_T / M_W / TANB
16887 C     MGM3 = (TOP MASS)*(TOP WIDTH)
16888 C     INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
16889 C     PREFACTORS:
16890 C     GGQQHTOT = (G_S**4)*(GGQQHT+GGQQHU-GGQQHNP/CAFAC**2)/(8.*CFFAC)
16891 C     QQQQHTOT = (G_S**4)*(QQQQH                         )*(1.-1./CAFAC**2)/4.
16892 C     N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
16893 C-----------------------------------------------------------------------
16894       IMPLICIT NONE
16895 C --- SUBPROCESS
16896       INTEGER IGG,IQQ
16897 C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS
16898       DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
16899       DOUBLE PRECISION K3(0:3),K4(0:3), Q3(0:3),Q4(0:3), R3(0:3),R4(0:3)
16900       DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4, TWOSQS
16901 C --- SPINORS
16902       DOUBLE COMPLEX U0(4), F3(4,2),F4(4,2), F3K(4,2),F4K(4,2)
16903       DOUBLE COMPLEX F3Q(4,2,2),F4Q(4,2,2), F3R(4,2,2),F4R(4,2,2)
16904 C --- MOMENTUM PROJECTION OPERATORS
16905       DOUBLE COMPLEX P3PROJ(4,4),P4PROJ(4,4),K3PROJ(4,4),K4PROJ(4,4)
16906       DOUBLE COMPLEX Q3PROJ(4,4),Q4PROJ(4,4),R3PROJ(4,4),R4PROJ(4,4)
16907 C --- SPINOR INDICES AND PERMUTATION MATRICES
16908       INTEGER I,J,K,L, PERM0(4), PL(4,2),PR(4,2), PERMU0(4)
16909 C --- CHIRALITY PROJECTION OPERATORS: 1 = - ,  2 = +
16910       DOUBLE PRECISION FACGPM(2),FACL(2,2),FACR(2,2),FAC0(2,2)
16911 C --- GG AMPLITUDES
16912       DOUBLE COMPLEX AMPS1(2,2),AMPS2(2,2)
16913       DOUBLE COMPLEX AMPT1(2,2,2,2),AMPT2(2,2,2,2),AMPT3(2,2,2,2)
16914       DOUBLE COMPLEX AMPU1(2,2,2,2),AMPU2(2,2,2,2),AMPU3(2,2,2,2)
16915       DOUBLE COMPLEX AMPS, AMPT, AMPU, AMPST, AMPSU, AMPTU
16916       DOUBLE PRECISION AMPST2, AMPSU2, AMPTU2
16917       DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
16918 C --- QQ AMPLITUDES
16919       DOUBLE PRECISION RM3452
16920       DOUBLE PRECISION S,PT32,PT42,PT52,GLAMBDA,LAMBDA,LAMBDAI,LA34,
16921      &                 PROP2,PROP3R,PROP3I,PROP4R,PROP4I,PROP34R,PT3452
16922       DOUBLE COMPLEX PROP3,PROP4,PROP
16923 C --- CONSTANTS
16924       DOUBLE PRECISION ZERO,ONE,TWO,MONE,FAC
16925       DOUBLE COMPLEX CZERO,CONE
16926       INTEGER LEFT,RIGHT
16927 C --- PARAMETER DEFINITIONS
16928       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,MONE=-ONE, LEFT=1,RIGHT=2)
16929       PARAMETER (CZERO=(0.D0,0.D0),CONE=(1.D0,0.D0))
16930       SAVE MGM4,PERM0,PL,FACL,PR,FACR,PERMU0,FAC0,U0
16931       DATA MGM4,U0,FAC0   /ZERO, 4*CONE        ,   ONE,ZERO, ZERO, ONE /
16932       DATA PERM0  ,PERMU0 / 1,2, 3,4           ,   1,0, 0,4            /
16933       DATA PL     ,PR     / 0,3, 0,1,  4,0, 2,0,   4,0, 2,0,  0,3, 0,1 /
16934       DATA FACL   ,FACR   /MONE, ONE,  ONE,MONE,   ONE,MONE, MONE, ONE /
16935 C --- INITIALIZE
16936       GGQQHT=ZERO
16937       GGQQHU=ZERO
16938       GGQQHNP=ZERO
16939       QQQQH=ZERO
16940 C --- GG ME.
16941       IF(IGG.EQ.0)GOTO 100
16942       TWOSQS = 0.5D0/SQS
16943       DO I = 0, 3
16944        Q3(I) = P3(I)-P1(I)
16945        Q4(I) = P4(I)-P2(I)
16946        R3(I) = P3(I)-P2(I)
16947        R4(I) = P4(I)-P1(I)
16948        K3(I) = P3(I)+P5(I)
16949        K4(I) = P4(I)+P5(I)
16950       END DO
16951       CALL HWUMPO(P3, RM3,     (P3(0)-P3(3))  ,ZERO,P3PROJ, .FALSE.)
16952       CALL HWUMPO(P4,-RM4,     (P4(0)+P4(3))  ,ZERO,P4PROJ, .FALSE.)
16953       CALL HWUMPO(Q3, RM3,-SQS*(P3(0)-P3(3))  ,ZERO,Q3PROJ, .FALSE.)
16954       CALL HWUMPO(Q4,-RM4,-SQS*(P4(0)+P4(3))  ,ZERO,Q4PROJ, .FALSE.)
16955       CALL HWUMPO(R3, RM3,-SQS*(P3(0)+P3(3))  ,ZERO,R3PROJ, .FALSE.)
16956       CALL HWUMPO(R4,-RM4,-SQS*(P4(0)-P4(3))  ,ZERO,R4PROJ, .FALSE.)
16957       CALL HWUMPO(K3, RM4,SQS*(SQS-2.D0*P4(0)),MGM4,K3PROJ, .TRUE.)
16958       CALL HWUMPO(K4,-RM3,SQS*(SQS-2.D0*P3(0)),MGM3,K4PROJ, .TRUE.)
16959       DO I=1,2
16960        CALL  HWUMPP(P3PROJ,FAC0(1,I),PERMU0 ,U0     ,F3(1,I)   , LEFT)
16961        CALL  HWUMPP(K3PROJ,FACGPM   ,PERM0  ,F3(1,I),F3K(1,I)  , LEFT)
16962        CALL  HWUMPP(P4PROJ,FAC0(1,I),PERMU0 ,U0     ,F4(1,I)   , RIGHT)
16963        CALL  HWUMPP(K4PROJ,FACGPM   ,PERM0  ,F4(1,I),F4K(1,I)  , RIGHT)
16964        DO J=1,2
16965         CALL HWUMPP(Q3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3Q(1,I,J), LEFT)
16966         CALL HWUMPP(R3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3R(1,I,J), LEFT)
16967         CALL HWUMPP(R4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4R(1,I,J), RIGHT)
16968         CALL HWUMPP(Q4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4Q(1,I,J), RIGHT)
16969        END DO
16970       END DO
16971       DO I=1,2
16972        DO J=1,2
16973         AMPS1(I,J)=( - F3K(1,I)* F4(3,J) + F3K(2,I)* F4(4,J)
16974      &               + F3K(3,I)* F4(1,J) - F3K(4,I)* F4(2,J) ) * TWOSQS
16975         AMPS2(I,J)=( -  F3(1,I)*F4K(3,J) +  F3(2,I)*F4K(4,J)
16976      &               +  F3(3,I)*F4K(1,J) -  F3(4,I)*F4K(2,J) ) * TWOSQS
16977         DO K=1,2
16978          AMPT1(1,K,I,J)= F3K(1,I)*F4Q(4,J,K)-F3K(3,I)*F4Q(2,J,K)
16979          AMPT1(2,K,I,J)=-F3K(2,I)*F4Q(3,J,K)+F3K(4,I)*F4Q(1,J,K)
16980          AMPT3(K,1,I,J)= F3Q(1,I,K)*F4K(4,J)-F3Q(3,I,K)*F4K(2,J)
16981          AMPT3(K,2,I,J)=-F3Q(2,I,K)*F4K(3,J)+F3Q(4,I,K)*F4K(1,J)
16982          AMPU1(K,1,I,J)= F3K(1,I)*F4R(4,J,K)-F3K(3,I)*F4R(2,J,K)
16983          AMPU1(K,2,I,J)=-F3K(2,I)*F4R(3,J,K)+F3K(4,I)*F4R(1,J,K)
16984          AMPU3(1,K,I,J)= F3R(1,I,K)*F4K(4,J)-F3R(3,I,K)*F4K(2,J)
16985          AMPU3(2,K,I,J)=-F3R(2,I,K)*F4K(3,J)+F3R(4,I,K)*F4K(1,J)
16986          DO L=1,2
16987           AMPT2(K,L,I,J)
16988      &    = FACGPM(1)*( F3Q(1,I,K)*F4Q(1,J,L)+F3Q(2,I,K)*F4Q(2,J,L) )
16989      &    + FACGPM(2)*( F3Q(3,I,K)*F4Q(3,J,L)+F3Q(4,I,K)*F4Q(4,J,L) )
16990           AMPU2(L,K,I,J)
16991      &    = FACGPM(1)*( F3R(1,I,K)*F4R(1,J,L)+F3R(2,I,K)*F4R(2,J,L) )
16992      &    + FACGPM(2)*( F3R(3,I,K)*F4R(3,J,L)+F3R(4,I,K)*F4R(4,J,L) )
16993          END DO
16994         END DO
16995        END DO
16996       END DO
16997       AMPST2 = ZERO
16998       AMPSU2 = ZERO
16999       AMPTU2 = ZERO
17000       DO I = 1, 2
17001        DO J = 1, 2
17002         DO K = 1, 2
17003          DO L = 1, 2
17004           IF (I.NE.J) THEN
17005            AMPS  = AMPS1(K,L) - AMPS2(K,L)
17006           ELSE
17007            AMPS  = CZERO
17008           END IF
17009           AMPT   = AMPT1(I,J,K,L)+AMPT2(I,J,K,L)+AMPT3(I,J,K,L)
17010           AMPU   = AMPU1(I,J,K,L)+AMPU2(I,J,K,L)+AMPU3(I,J,K,L)
17011           AMPST  = AMPS - AMPT
17012           AMPSU  = AMPS + AMPU
17013           AMPTU  = AMPT + AMPU
17014           AMPST2 = AMPST2 + DREAL(DCONJG(AMPST)*AMPST)
17015           AMPSU2 = AMPSU2 + DREAL(DCONJG(AMPSU)*AMPSU)
17016           AMPTU2 = AMPTU2 + DREAL(DCONJG(AMPTU)*AMPTU)
17017          END DO
17018         END DO
17019        END DO
17020       END DO
17021       FAC  = (P3(0)-P3(3))*(P4(0)+P4(3))
17022       GGQQHT  = FAC*AMPST2
17023       GGQQHU  = FAC*AMPSU2
17024       GGQQHNP = FAC*AMPTU2
17025  100  CONTINUE
17026 C --- QQ ME.
17027       IF(IQQ.EQ.0)GOTO 200
17028       S       = SQS**2
17029       PT32    = P3(1)**2+P3(2)**2
17030       PT42    = P4(1)**2+P4(2)**2
17031       PT52    = P5(1)**2+P5(2)**2
17032       PT3452  = (PT32+PT42-PT52)/TWO
17033       RM3452  = (RM3**2+RM4**2-RM5**2)/TWO
17034       GLAMBDA = FACGPM(1)**2+FACGPM(2)**2
17035       LAMBDA  = TWO*FACGPM(1)*FACGPM(2)/GLAMBDA
17036       LAMBDAI = (FACGPM(2)**2-FACGPM(1)**2)/GLAMBDA
17037       LA34    = S/TWO-SQS*P5(0)-RM3452-LAMBDA*RM3*RM4
17038       PROP3   = ONE/DCMPLX(SQS*(SQS-TWO*P4(0)),ZERO)
17039       PROP4   = ONE/DCMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
17040       PROP    = PROP3+PROP4
17041       PROP2   = DREAL(DCONJG(PROP)*PROP)
17042       PROP3R  = DREAL(DCONJG(PROP)*PROP3)
17043       PROP3I  = DIMAG(DCONJG(PROP)*PROP3)
17044       PROP4R  = DREAL(DCONJG(PROP)*PROP4)
17045       PROP4I  = DIMAG(DCONJG(PROP)*PROP4)
17046       PROP34R = DREAL(DCONJG(PROP3)*PROP4)
17047       QQQQH   = TWO*GLAMBDA/S*(S*PROP2*(PT3452+TWO*P3(0)*P4(0)-
17048      & LA34)+TWO*LA34*(PROP3R*PT42+PROP4R*PT32-PROP34R*PT52)-TWO*SQS*((
17049      & PROP3R*(P3(0)*PT42+P4(0)*PT3452)+PROP4R*(P4(0)*PT32+P3(0)*PT3452)
17050      & )-(PROP3I*P4(3)-PROP4I*P3(3))*LAMBDAI*(P3(1)*P4(2)-P3(2)*P4(1))))
17051  200  CONTINUE
17052       END
17053 CDECK  ID>, HWH2SH.
17054 *CMZ :-        -30/06/01  18.25.35  by  Stefano Moretti
17055 *-- Author :  Kosuke Odagiri & Stefano Moretti
17056 C-----------------------------------------------------------------------
17057       SUBROUTINE HWH2SH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,MGM3,MGM4,
17058      & IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
17059 C-----------------------------------------------------------------------
17060 C     MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> SQ SQ* HIGGS
17061 C-----------------------------------------------------------------------
17062 C     NEEDS PREFACTOR G_S^4 AND G_(HIGGS-SQ-SQ)^2
17063 C     MGM3, MGM4 = MASS * WIDTH
17064 C     INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
17065 C     PREFACTORS:
17066 C     GGSQHTOT =
17067 C     (G_S**4)*(G_HIGGS**2)*(GGSQHT+GGSQHU-GGSQHN/CAFAC**2)/(8.*CFFAC)
17068 C     QQSQHTOT =
17069 C     (G_S**4)*(G_HIGGS**2)*(QQSQH                        )*(1.-1./CAFAC**2)/4.
17070 C     N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
17071 C
17072 C...First release:  08-OCT-1999 by Kosuke Odagiri
17073 C...First modified: 12-NOV-1999 by Stefano Moretti
17074 C-----------------------------------------------------------------------
17075       IMPLICIT NONE
17076 C --- SUBPROCESS
17077       INTEGER IGG,IQQ
17078 C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS
17079       DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
17080       DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4
17081 C --- POLARISATION INDICES, PROPAGATORS AND GG AMPLITUDES
17082       INTEGER I,J
17083       DOUBLE PRECISION G14,G24,G23,G13,MSQS, GGSQHT,GGSQHU,GGSQHN
17084       DOUBLE COMPLEX G35,G45, AMPT,AMPU,AMPS,AMPC, AMPST,AMPSU,AMPTU
17085 C --- QQ AMPLITUDES
17086       DOUBLE PRECISION QQSQH
17087       DOUBLE PRECISION PT32,PT42,PT34
17088       DOUBLE COMPLEX PROP3,PROP4
17089 C --- CONSTANT PARAMETERS
17090       DOUBLE PRECISION ZERO,ONE,TWO,SQTWO,MSQTWO
17091       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0)
17092       SQTWO=SQRT(TWO)
17093       MSQTWO=-SQTWO/4.D0
17094       GGSQHT = ZERO
17095       GGSQHU = ZERO
17096       GGSQHN = ZERO
17097       QQSQH  = ZERO
17098       IF(IGG.EQ.0)GOTO 100
17099 C -- GG SCATTERING.
17100       MSQS = -SQTWO/SQS
17101       G13  = MSQS/(P3(0)-P3(3))
17102       G23  = MSQS/(P3(0)+P3(3))
17103       G14  = MSQS/(P4(0)-P4(3))
17104       G24  = MSQS/(P4(0)+P4(3))
17105       G35  = SQTWO/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
17106       G45  = SQTWO/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
17107       AMPS = 0.5D0*MSQS*(P4(3)*G35-P3(3)*G45)
17108       AMPC = MSQTWO*(G35+G45)
17109       DO 10 I = 1,2
17110        DO 20 J = 1,2
17111         AMPT=P3(I)*P4(J)*G24*G13-P4(I)*P4(J)*G24*G35-P3(I)*P3(J)*G13*G45
17112         AMPU=P4(I)*P3(J)*G14*G23-P4(I)*P4(J)*G14*G35-P3(I)*P3(J)*G23*G45
17113         IF (I.EQ.J) THEN
17114          AMPST = AMPT-AMPS+AMPC
17115          AMPSU = AMPU+AMPS+AMPC
17116         ELSE
17117          AMPST = AMPT
17118          AMPSU = AMPU
17119         END IF
17120         AMPTU  = AMPST+AMPSU
17121         GGSQHT = GGSQHT + DREAL(DCONJG(AMPST)*AMPST)
17122         GGSQHU = GGSQHU + DREAL(DCONJG(AMPSU)*AMPSU)
17123         GGSQHN = GGSQHN + DREAL(DCONJG(AMPTU)*AMPTU)
17124  20    CONTINUE
17125  10   CONTINUE
17126  100  CONTINUE
17127       IF(IQQ.EQ.0)GOTO 200
17128 C -- QQ SCATTERING.
17129       PT32  = P3(1)**2+P3(2)**2
17130       PT42  = P4(1)**2+P4(2)**2
17131       PT34  = P3(1)*P4(1)+P3(2)*P4(2)
17132       PROP3 = ONE/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
17133       PROP4 = ONE/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
17134       QQSQH = TWO/SQS**2*DREAL(PT32*DCONJG(PROP3)*PROP3+
17135      &            PT42*DCONJG(PROP4)*PROP4-TWO*PT34*DCONJG(PROP3)*PROP4)
17136  200  CONTINUE
17137       END
17138 CDECK  ID>, HWH2SS
17139 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17140 C-----------------------------------------------------------------------
17141       SUBROUTINE HWH2SS(S,K,KK)
17142 C-----------------------------------------------------------------------
17143 C     Subroutine to calculate the spinor products in the notation of
17144 C     Kleiss and Strirling S(1) is S and S(2) is T
17145 C-----------------------------------------------------------------------
17146       INCLUDE 'herwig65.inc'
17147       DOUBLE PRECISION WRN(2),K(5),KK(5),P(5,2),Q1,Q2,EPS,QTI,PTI,
17148      &     PT,QT,DPM,DMP,QP,QM,P1,P2,PP,PM
17149       DOUBLE COMPLEX S(2),ZI,Z1,ZT,ZQ,ZQS,ZPS,ZP,ZDPM,ZDMP
17150       INTEGER I,II,JJ
17151       EPS=0.0000001
17152       ZI=DCMPLX(ZERO,ONE)
17153       Z1=DCMPLX(ONE,ZERO)
17154 C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
17155       DO I=1,4
17156         P(I,2) = K(I)
17157         P(I,1) = KK(I)
17158       ENDDO
17159       DO 2 II=1,2
17160       WRN(II)=ONE
17161       IF(P(4,II).LT.ZERO) WRN(II)=-ONE
17162       DO 2 JJ=1,4
17163       P(JJ,II)=WRN(II)*P(JJ,II)
17164     2 CONTINUE
17165 C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
17166 C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
17167       Q1=P(4,1)+P(1,1)
17168       QP=ZERO
17169       IF(Q1.GT.EPS) QP=SQRT(Q1)
17170       Q2=P(4,1)-P(1,1)
17171       QM=0.0
17172       IF(Q2.GT.EPS)QM=SQRT(Q2)
17173       P1=P(4,2)+P(1,2)
17174       PP=ZERO
17175       IF(P1.GT.EPS)PP=SQRT(P1)
17176       P2=P(4,2)-P(1,2)
17177       PM=ZERO
17178       IF(P2.GT.EPS)PM=SQRT(P2)
17179       DMP=PM*QP
17180       ZDMP=DCMPLX(DMP,ZERO)
17181       DPM=PP*QM
17182       ZDPM=DCMPLX(DPM,ZERO)
17183 C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
17184       PT=SQRT(P(2,2)**2+P(3,2)**2)
17185       QT=SQRT(P(2,1)**2+P(3,1)**2)
17186       IF(PT.GT.EPS) GOTO 99
17187       ZP=Z1
17188       GOTO 98
17189    99 PTI=ONE/PT
17190       ZP=DCMPLX(PTI*P(2,2),PTI*P(3,2))
17191    98 ZPS=DCONJG(ZP)
17192       IF(QT.GT.EPS) GOTO 89
17193       ZQ=Z1
17194       GOTO 88
17195    89 QTI=ONE/QT
17196       ZQ=DCMPLX(QTI*P(2,1),QTI*P(3,1))
17197    88 ZQS=DCONJG(ZQ)
17198       ZT=Z1
17199       IF(WRN(1).LT.ZERO) ZT=ZT*ZI
17200       IF(WRN(2).LT.ZERO) ZT=ZT*ZI
17201       S(2)=-(ZDMP*ZP-ZDPM*ZQ)*ZT
17202       S(1)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
17203       END
17204 CDECK  ID>, HWH2T1.
17205 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17206 *-- Author :    Peter Richardson
17207 C-----------------------------------------------------------------------
17208       FUNCTION HWH2T1(I,J,K,L,Z1,Z2,P1)
17209 C-----------------------------------------------------------------------
17210 C     Returns the amplitude T1 from Nucl. Phys. B262 (1985) 235-262
17211 C     I-L are the particles
17212 C     Z1 and Z2 are the decay products of the Z
17213 C     P1 is the polarization of the line I,J
17214 C-----------------------------------------------------------------------
17215       INCLUDE 'herwig65.inc'
17216       DOUBLE COMPLEX HWH2T1,S,D
17217       INTEGER I,J,K,L,Z1,Z2,P1
17218       COMMON/HWHEWS/S(8,8,2),D(8,8)
17219       IF(P1.EQ.1) THEN
17220         HWH2T1 = TWO*S(I,Z2,1)*S(Z1,J,2)
17221       ELSEIF(P1.EQ.2) THEN
17222         HWH2T1 = TWO*S(I,Z1,2)*S(Z2,J,1)
17223       ELSE
17224         CALL HWWARN('HWH2T1',500)
17225       ENDIF
17226       END
17227 CDECK  ID>, HWH2T2
17228 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17229 *-- Author :    Peter Richardson
17230 C-----------------------------------------------------------------------
17231       FUNCTION HWH2T2(I,J,K,L,Z1,Z2,P1,P2)
17232 C-----------------------------------------------------------------------
17233 C     Returns the amplitude T2 from Nucl. Phys. B262 (1985) 235-262
17234 C     I-L are the particles
17235 C     Z1 and Z2 are the decay products of the Z
17236 C     P1 is the polarization of the line I,J
17237 C     P2 is the polarization of the gluon K
17238 C-----------------------------------------------------------------------
17239       INCLUDE 'herwig65.inc'
17240       DOUBLE COMPLEX HWH2T2,S,D
17241       INTEGER I,J,K,L,Z1,Z2,P1,P2
17242       DOUBLE PRECISION B(6)
17243       COMMON/HWHEWS/S(8,8,2),D(8,8)
17244       SAVE B
17245       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17246       IF(P1.EQ.1.AND.P2.EQ.1) THEN
17247         HWH2T2 = FOUR*B(J)*S(I,Z2,1)*S(Z1,J,2)*S(J,K,1)*S(I,J,2)
17248       ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
17249         HWH2T2 = FOUR*S(I,Z2,1)*S(K,J,2)*(B(J)*S(Z1,J,2)*S(J,I,1)
17250      &                                +B(K)*S(Z1,K,2)*S(K,I,1))
17251       ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
17252         HWH2T2 = FOUR*S(I,Z1,2)*S(K,J,1)*(B(J)*S(Z2,J,1)*S(J,I,2)
17253      &                                +B(K)*S(Z2,K,1)*S(K,I,2))
17254       ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
17255         HWH2T2 = FOUR*B(J)*S(I,Z1,2)*S(Z2,J,1)*S(J,K,2)*S(I,J,1)
17256       ELSE
17257         CALL HWWARN('HWH2T2',500)
17258       ENDIF
17259       END
17260 CDECK  ID>, HWH2T3.
17261 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17262 *-- Author :    Peter Richardson
17263 C-----------------------------------------------------------------------
17264       FUNCTION HWH2T3(I,J,K,L,Z1,Z2,P1,P2)
17265 C-----------------------------------------------------------------------
17266 C     Returns the amplitude T3 from Nucl. Phys. B262 (1985) 235-262
17267 C     I-L are the particles
17268 C     Z1 and Z2 are the decay products of the Z
17269 C     P1 is the polarization of the line I,J
17270 C     P2 is the polarization of the gluon K
17271 C-----------------------------------------------------------------------
17272       INCLUDE 'herwig65.inc'
17273       DOUBLE COMPLEX HWH2T3,S,D
17274       INTEGER I,J,K,L,Z1,Z2,P1,P2
17275       DOUBLE PRECISION B(6)
17276       COMMON/HWHEWS/S(8,8,2),D(8,8)
17277       SAVE B
17278       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17279       IF(P1.EQ.1.AND.P2.EQ.1) THEN
17280         HWH2T3 = FOUR*B(K)*S(I,K,1)*S(I,K,2)*S(K,Z2,1)*S(Z1,J,2)
17281       ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
17282         HWH2T3 = ZERO
17283       ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
17284         HWH2T3 = ZERO
17285       ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
17286         HWH2T3 = FOUR*B(K)*S(I,K,2)*S(I,K,1)*S(K,Z1,2)*S(Z2,J,1)
17287       ELSE
17288         CALL HWWARN('HWH2T3',500)
17289       ENDIF
17290       END
17291 CDECK  ID>, HWH2T4
17292 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17293 *-- Author :    Peter Richardson
17294 C-----------------------------------------------------------------------
17295       FUNCTION HWH2T4(I,J,K,L,Z1,Z2,P1,P2)
17296 C-----------------------------------------------------------------------
17297 C     Returns the amplitude T4 from Nucl. Phys. B262 (1985) 235-262
17298 C     I-L are the particles
17299 C     Z1 and Z2 are the decay products of the Z
17300 C     P1 is the polarization of the line I,J
17301 C     P2 is the polarization of the line K,L
17302 C-----------------------------------------------------------------------
17303       INCLUDE 'herwig65.inc'
17304       DOUBLE COMPLEX HWH2T4,AP,AM,S,D
17305       INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
17306       DOUBLE PRECISION B(6)
17307       COMMON/HWHEWS/S(8,8,2),D(8,8)
17308       SAVE B
17309       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17310       AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
17311      &     (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
17312       AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
17313      &     (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
17314       IF(P1.EQ.1.AND.P2.EQ.1) THEN
17315         HWH2T4 = AP(I,J,K,L)
17316       ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
17317         HWH2T4 = AP(I,J,L,K)
17318       ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
17319         HWH2T4 = AM(I,J,L,K)
17320       ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
17321         HWH2T4 = AM(I,J,K,L)
17322       ELSE
17323         CALL HWWARN('HWH2T4',500)
17324       ENDIF
17325       END
17326 CDECK  ID>, HWH2T5
17327 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17328 *-- Author :    Peter Richardson
17329 C-----------------------------------------------------------------------
17330       FUNCTION HWH2T5(I,J,K,L,Z1,Z2,P1,P2)
17331 C-----------------------------------------------------------------------
17332 C     Returns the amplitude T5 from Nucl. Phys. B262 (1985) 235-262
17333 C     I-L are the particles
17334 C     Z1 and Z2 are the decay products of the Z
17335 C     P1 is the polarization of the line I,J
17336 C     P2 is the polarization of the line K,L
17337 C-----------------------------------------------------------------------
17338       INCLUDE 'herwig65.inc'
17339       DOUBLE COMPLEX HWH2T5,AP,AM,S,D
17340       INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
17341       DOUBLE PRECISION B(6)
17342       COMMON/HWHEWS/S(8,8,2),D(8,8)
17343       SAVE B
17344       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17345       AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
17346      &     (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
17347       AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
17348      &     (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
17349       IF(P1.EQ.1.AND.P2.EQ.1) THEN
17350         HWH2T5 = AM(J,I,L,K)
17351       ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
17352         HWH2T5 = AM(J,I,K,L)
17353       ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
17354         HWH2T5 = AP(J,I,K,L)
17355       ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
17356         HWH2T5 = AP(J,I,L,K)
17357       ELSE
17358         CALL HWWARN('HWH2T5',500)
17359       ENDIF
17360       END
17361 CDECK  ID>, HWH2T6
17362 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17363 *-- Author :    Peter Richardson
17364 C-----------------------------------------------------------------------
17365       FUNCTION HWH2T6(I,J,K,L,Z1,Z2,P1,P2,P3)
17366 C-----------------------------------------------------------------------
17367 C     Returns the amplitude T6 from Nucl. Phys. B262 (1985) 235-262
17368 C     I-L are the particles
17369 C     Z1 and Z2 are the decay products of the Z
17370 C     P1 is the polarization of the line I,J
17371 C     P2 is the polarization of the gluon K
17372 C     P3 is the polarization of the gluon L
17373 C-----------------------------------------------------------------------
17374       INCLUDE 'herwig65.inc'
17375       DOUBLE COMPLEX HWH2T6,S,D
17376       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17377       DOUBLE PRECISION B(6)
17378       COMMON/HWHEWS/S(8,8,2),D(8,8)
17379       SAVE B
17380       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17381       IF(P1.EQ.1) THEN
17382          J1 = Z1
17383          J2 = Z2
17384       ELSE
17385          J1 = Z2
17386          J2 = Z1
17387       ENDIF
17388       IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17389      &   (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17390         HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*D(L,J)*S(K,J,2)*
17391      &             (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17392       ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17393      &       (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17394         HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(L,J,2)*S(J,K,1)*S(L,J,2)*
17395      &            (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17396       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17397      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17398         HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(K,J,2)*S(J,L,1)*S(K,J,2)*
17399      &            (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
17400       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17401      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17402         HWH2T6 = 8.0D0*S(I,J2,1)*S(L,J,2)*(B(J)*D(K,J)+B(L)*D(K,L))*
17403      &             (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
17404       ELSE
17405         CALL HWWARN('HWH2T6',500)
17406       ENDIF
17407       IF(P1.EQ.2) HWH2T6 = DCONJG(HWH2T6)
17408       END
17409 CDECK  ID>, HWH2T7
17410 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17411 *-- Author :    Peter Richardson
17412 C-----------------------------------------------------------------------
17413       FUNCTION HWH2T7(I,J,K,L,Z1,Z2,P1,P2,P3)
17414 C-----------------------------------------------------------------------
17415 C     Returns the amplitude T7 from Nucl. Phys. B262 (1985) 235-262
17416 C     I-L are the particles
17417 C     Z1 and Z2 are the decay products of the Z
17418 C     P1 is the polarization of the line I,J
17419 C     P2 is the polarization of the gluon K
17420 C     P3 is the polarization of the gluon L
17421 C-----------------------------------------------------------------------
17422       INCLUDE 'herwig65.inc'
17423       DOUBLE COMPLEX HWH2T7,S,D
17424       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17425       DOUBLE PRECISION B(6)
17426       COMMON/HWHEWS/S(8,8,2),D(8,8)
17427       SAVE B
17428       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17429       IF(P1.EQ.1) THEN
17430         J1 = Z1
17431         J2 = Z2
17432       ELSE
17433         J1 = Z2
17434         J2 = Z1
17435       ENDIF
17436       IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17437      &   (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17438         HWH2T7 = 8.0D0*B(J)*S(I,K,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)*
17439      &                 (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17440       ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17441      &       (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17442         HWH2T7 = 8.0D0*S(I,K,1)*S(L,J,2)*
17443      &                (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))*
17444      &                (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17445       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17446      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17447         HWH2T7 = 8.0D0*B(I)*B(J)*S(I,L,1)*S(K,I,2)*
17448      &        S(I,J2,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)
17449       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17450      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17451         HWH2T7 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,J2,1)*S(L,J,2)*
17452      &                 (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17453       ELSE
17454         CALL HWWARN('HWH2T7',500)
17455       ENDIF
17456       IF(P1.EQ.2) HWH2T7 = DCONJG(HWH2T7)
17457       END
17458 CDECK  ID>, HWH2T8
17459 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17460 *-- Author :    Peter Richardson
17461 C-----------------------------------------------------------------------
17462       FUNCTION HWH2T8(I,J,K,L,Z1,Z2,P1,P2,P3)
17463 C-----------------------------------------------------------------------
17464 C     Returns the amplitude T8 from Nucl. Phys. B262 (1985) 235-262
17465 C     I-L are the particles
17466 C     Z1 and Z2 are the decay products of the Z
17467 C     P1 is the polarization of the line I,J
17468 C     P2 is the polarization of the gluon K
17469 C     P3 is the polarization of the gluon L
17470 C-----------------------------------------------------------------------
17471       INCLUDE 'herwig65.inc'
17472       DOUBLE COMPLEX HWH2T8,S,D
17473       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17474       DOUBLE PRECISION B(6)
17475       COMMON/HWHEWS/S(8,8,2),D(8,8)
17476       SAVE B
17477       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17478       IF(P1.EQ.1) THEN
17479         J1 = Z1
17480         J2 = Z2
17481       ELSE
17482         J1 = Z2
17483         J2 = Z1
17484       ENDIF
17485       IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17486      &   (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17487         HWH2T8 = 8.0D0*S(I,K,1)*S(J1,J,2)*(B(I)*D(L,I)+B(K)*D(L,K))*
17488      &                (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
17489       ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17490      &       (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17491         HWH2T8 = 8.0D0*B(I)*S(I,K,1)*S(L,I,2)*S(I,K,1)*S(J1,J,2)*
17492      &                 (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17493       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17494      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17495         HWH2T8 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,L,1)*S(J1,J,2)*
17496      &                 (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
17497       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17498      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17499         HWH2T8 = 8.0D0*B(I)*S(I,L,1)*D(I,K)*S(J1,J,2)*
17500      &                 (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17501       ELSE
17502         CALL HWWARN('HWH2T8',500)
17503       ENDIF
17504       IF(P1.EQ.2) HWH2T8 = DCONJG(HWH2T8)
17505       END
17506 CDECK  ID>, HWH2T9
17507 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17508 *-- Author :    Peter Richardson
17509 C-----------------------------------------------------------------------
17510       FUNCTION HWH2T9(I,J,K,L,Z1,Z2,P1,P2,P3)
17511 C-----------------------------------------------------------------------
17512 C     Returns the amplitude T9 from Nucl. Phys. B262 (1985) 235-262
17513 C     N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
17514 C     I-L are the particles
17515 C     Z1 and Z2 are the decay products of the Z
17516 C     P1 is the polarization of the line I,J
17517 C     P2 is the polarization of the gluon K
17518 C     P3 is the polarization of the gluon L
17519 C-----------------------------------------------------------------------
17520       INCLUDE 'herwig65.inc'
17521       DOUBLE COMPLEX HWH2T9,S,D
17522       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17523       DOUBLE PRECISION B(6)
17524       COMMON/HWHEWS/S(8,8,2),D(8,8)
17525       SAVE B
17526       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17527       IF(P2.NE.P3) THEN
17528          HWH2T9 = ZERO
17529       ELSE
17530         IF(P1.EQ.1) THEN
17531           J1 = Z1
17532           J2 = Z2
17533         ELSEIF(P1.EQ.2) THEN
17534           J1 = Z2
17535           J2 = Z1
17536         ENDIF
17537         HWH2T9 = TWO*S(I,J2,1)*(
17538      &           B(K)*S(K,J,2)*(B(J)*S(J1,J,2)*S(J,K,1)
17539      &                           +B(L)*S(J1,L,2)*S(L,K,1))
17540      &          -B(L)*S(L,J,2)*(B(J)*S(J1,J,2)*S(J,L,1)
17541      &                           +B(K)*S(J1,K,2)*S(K,L,1)))
17542         IF(P1.EQ.2) HWH2T9 = DCONJG(HWH2T9)
17543       ENDIF
17544       END
17545 CDECK  ID>, HWH2T0
17546 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17547 *-- Author :    Peter Richardson
17548 C-----------------------------------------------------------------------
17549       FUNCTION HWH2T0(I,J,K,L,Z1,Z2,P1,P2,P3)
17550 C-----------------------------------------------------------------------
17551 C     Returns the amplitude T10 from Nucl. Phys. B262 (1985) 235-262
17552 C     N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
17553 C     I-L are the particles
17554 C     Z1 and Z2 are the decay products of the Z
17555 C     P1 is the polarization of the line I,J
17556 C     P2 is the polarization of the gluon K
17557 C     P3 is the polarization of the gluon L
17558 C-----------------------------------------------------------------------
17559       INCLUDE 'herwig65.inc'
17560       DOUBLE COMPLEX HWH2T0,S,D
17561       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17562       DOUBLE PRECISION B(6)
17563       COMMON/HWHEWS/S(8,8,2),D(8,8)
17564       SAVE B
17565       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17566       IF(P2.NE.P3) THEN
17567          HWH2T0 = ZERO
17568       ELSE
17569         IF(P1.EQ.1) THEN
17570           J1 = Z1
17571           J2 = Z2
17572         ELSEIF(P1.EQ.2) THEN
17573           J1 = Z2
17574           J2 = Z1
17575         ENDIF
17576         HWH2T0 = TWO*S(J1,J,2)*(
17577      &            B(K)*S(I,K,1)*(B(I)*S(K,I,2)*S(I,J2,1)
17578      &                           +B(L)*S(K,L,2)*S(L,J2,1))
17579      &           -B(L)*S(I,L,1)*(B(I)*S(L,I,2)*S(I,J2,1)
17580      &                           +B(K)*S(L,K,2)*S(K,J2,1)))
17581         IF(P1.EQ.2) HWH2T0 = DCONJG(HWH2T0)
17582       ENDIF
17583       END
17584 CDECK  ID>, HWH2VH.
17585 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
17586 *-- Author :  Stefano Moretti
17587 C-----------------------------------------------------------------------
17588       SUBROUTINE HWH2VH(P1,P2,P3,P4,RMV,RES,RESL,REST)
17589 C-----------------------------------------------------------------------
17590 C...Matrix element for q(1) + q(')-bar(2) -> V(3) + Higgs(4),
17591 C...V=Z(W+/-), all masses retained (but no Yukawa couplings to quarks).
17592 C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
17593 C...times:
17594 C...         (VQ*VQ+AQ*AQ)/(1.-SWEIN)/(1.-SWEIN)    if V=Z
17595 C...         VCKM(q,q')                             if V=W+/-
17596 C
17597 C...First release:  1-APR-1998 by Stefano Moretti
17598 C-----------------------------------------------------------------------
17599       IMPLICIT NONE
17600       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
17601       DOUBLE PRECISION P(0:3)
17602       DOUBLE PRECISION RMV,GAMV,RES,RESL,REST
17603       INTEGER I
17604       DOUBLE PRECISION S,S12,S13,S23
17605       DOUBLE PRECISION T,    T13,T23
17606       DOUBLE PRECISION PV,CFC
17607       PARAMETER (GAMV=0.D0)
17608       S=(P1(0)+P2(0))**2
17609       DO I=1,3
17610         S=S-(P1(I)+P2(I))**2
17611       END DO
17612       S12=P1(0)*P2(0)
17613       S13=P1(0)*P3(0)
17614       S23=P2(0)*P3(0)
17615       DO I=1,3
17616         S12=S12-P1(I)*P2(I)
17617         S13=S13-P1(I)*P3(I)
17618         S23=S23-P2(I)*P3(I)
17619       END DO
17620 C...Total ME.
17621       RES=(S12+2.D0/RMV/RMV*(S13*S23))
17622      &   /((S-RMV**2)**2+GAMV**2*RMV**2)
17623      &   /12.D0
17624 C...Extracts spin dependence.
17625       PV=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
17626       CFC=P3(0)/PV
17627       DO I=1,3
17628         P(I)=P3(I)*CFC
17629       END DO
17630       P(0)=PV**2/P3(0)*CFC
17631       T=P(0)**2
17632       DO I=1,3
17633         T=T-P(I)**2
17634       END DO
17635       T13=P1(0)*P(0)
17636       T23=P2(0)*P(0)
17637       DO I=1,3
17638         T13=T13-P1(I)*P(I)
17639         T23=T23-P2(I)*P(I)
17640       END DO
17641 C...Longitudinal ME (along V direction).
17642       RESL=(2.D0/RMV/RMV*(T13*T23)-S12*T/RMV/RMV)
17643      &    /((S-RMV**2)**2+GAMV**2*RMV**2)
17644      &    /12.D0
17645 C...Transverse ME (perpendicular to V direction).
17646       REST=RES-RESL
17647       END
17648 CDECK  ID>, HWH4JT.
17649 *CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
17650 *-- Author :    Ian Knowles
17651 C-----------------------------------------------------------------------
17652       SUBROUTINE HWH4JT
17653 C-----------------------------------------------------------------------
17654 C     Four jet production in e^+e^- annihilation: qqbar+gg & qqbar+qqbar
17655 C     IOP4JT controls the treatment of the colour flow interference term
17656 C     qqbar-gg case:
17657 C     IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
17658 C     qqbar-qqbar (identical quark flavour) case:
17659 C     IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
17660 C
17661 C     Matrix elements based on Ellis Ross & Terrano and Catani & Seymour
17662 C
17663 C     WARNING:  Phase space factor inaccurate for JADE y_cut > 0.14.
17664 C-----------------------------------------------------------------------
17665       INCLUDE 'herwig65.inc'
17666       INTEGER LM,LP,IQK,I,J,IDMN,IDMX,ID1,ID2,IST(4)
17667       DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,
17668      & HWH4J4,HWH4J5,HWH4J6,HWH4J7,QNOW,Q2NOW,QLST,SCUT,PSFAC,FACT,
17669      & X12,X13,X14,X23,X24,X34,
17670      & COLA,COLB,COLC,CLF(7,6),P12,P13,P14,P23,P24,P34,FACTR,EP1,EP2,
17671      & EP3,EP4,GG1,GG2,GG12,GG3,GG13,GG23,GGINT,WTGG,QQ,QP,QQINT,QQ1,
17672      & QQ2,WTQQ,WTQP,HCS,WTAB,WTBA,WTOT,RCS,YLST
17673      $     ,EF,QF,E(4)
17674       LOGICAL INCLQG(6),INCLQQ(6,6),ORIENT
17675       EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,HWH4J4,
17676      & HWH4J5,HWH4J6,HWH4J7
17677       SAVE HCS,QLST,WTQP,WTQQ,WTGG,FACTR,COLA,COLB,COLC,IDMN,IDMX,
17678      & CLF,GG1,GG2,GGINT,INCLQG,INCLQQ,LM,LP,QQ1,QQ2,QQINT,FACT,ORIENT,
17679      & Q2NOW,SCUT,YLST
17680       SAVE IST
17681       DATA QLST,YLST,IST/-1D0,-1D0,113,114,114,114/
17682 C
17683       IF (GENEV) THEN
17684         RCS=HCS*HWRGEN(0)
17685       ELSE
17686         IF (NHEP+5.GT.NMXHEP) THEN
17687           CALL HWWARN('HWH4JT',100)
17688           GOTO 999
17689         ENDIF
17690         QNOW=PHEP(5,3)
17691         IF (QNOW.NE.QLST.OR.Y4JT.NE.YLST) THEN
17692           QLST=QNOW
17693           YLST=Y4JT
17694           Q2NOW=QNOW**2
17695           SCUT=Y4JT*Q2NOW
17696 C Calculate allowed fraction of Phase Space using parameterization
17697           IF (DURHAM) THEN
17698             PSFAC=(1.-6.*Y4JT)**5.50*(1.-173.3*Y4JT*(1.-247.3*Y4JT
17699      &                              *(1.+148.3*Y4JT*(1.+3.913*Y4JT))))
17700      &                              /(1.-8.352*Y4JT*(1.-1102.*Y4JT
17701      &                              *(1.+1603.*Y4JT*(1.+22.99*Y4JT))))
17702           ELSE
17703             PSFAC=(1.-6.*Y4JT)**4.62*(1.-44.72*Y4JT*(1.-176.0*Y4JT
17704      &                              *(1.+102.9*Y4JT*(1.-6.579*Y4JT))))
17705      &                              /(1.-3.392*Y4JT*(1.-946.5*Y4JT
17706      &                              *(1.+423.4*Y4JT*(1.-3.971*Y4JT))))
17707           ENDIF
17708           FACT=GEV2NB*HWUAEM(Q2NOW)**2*CFFAC*FLOAT(NCOLO)*PSFAC
17709      &        /(THREE*16*PIFAC)
17710           COLA=CFFAC
17711           COLB=CFFAC-HALF*CAFAC
17712           COLC=HALF
17713           LM=1
17714           IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
17715           LP=2
17716           IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
17717           IQK=MOD(IPROC,10)
17718           IF (IQK.NE.0) THEN
17719             IDMN=IQK
17720             IDMX=IQK
17721           ELSE
17722             IDMN=1
17723             IDMX=6
17724           ENDIF
17725           DO 10 I=1,6
17726           CALL HWUCFF(11,I,Q2NOW,CLF(1,I))
17727           IF (QNOW.GT.TWO*(RMASS(I)+RMASS(13))) THEN
17728             INCLQG(I)=.TRUE.
17729           ELSE
17730             INCLQG(I)=.FALSE.
17731           ENDIF
17732           DO 10 J=I,6
17733           IF (QNOW.GT.TWO*(RMASS(I)+RMASS(J ))) THEN
17734             INCLQQ(I,J)=.TRUE.
17735             INCLQQ(J,I)=.TRUE.
17736           ELSE
17737             INCLQQ(I,J)=.FALSE.
17738             INCLQQ(J,I)=.FALSE.
17739           ENDIF
17740   10      CONTINUE
17741           IF (MOD(IPROC/10,10).EQ.5) THEN
17742             ORIENT=.FALSE.
17743           ELSE
17744             ORIENT=.TRUE.
17745           ENDIF
17746         ENDIF
17747 C Generate phase space point and check it passes cuts
17748         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
17749         DO 20 I=2,5
17750   20    PHEP(5,NHEP+I)=0.
17751   30    CALL HWDFOR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3),
17752      &              PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17753         IF(IERROR.NE.0) RETURN
17754         IF (DURHAM) THEN
17755           P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
17756           X12=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+3),
17757      &          PHEP(4,NHEP+3)/PHEP(4,NHEP+2))*P12
17758           IF (X12.GT.SCUT) THEN
17759             P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
17760             X13=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+4),
17761      &            PHEP(4,NHEP+4)/PHEP(4,NHEP+2))*P13
17762             IF (X13.GT.SCUT) THEN
17763               P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
17764               X14=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+5),
17765      &              PHEP(4,NHEP+5)/PHEP(4,NHEP+2))*P14
17766               IF (X14.GT.SCUT) THEN
17767                 P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
17768                 X23=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+4),
17769      &                PHEP(4,NHEP+4)/PHEP(4,NHEP+3))*P23
17770                 IF (X23.GT.SCUT) THEN
17771                   P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
17772                   X24=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+5),
17773      &                  PHEP(4,NHEP+5)/PHEP(4,NHEP+3))*P24
17774                   IF (X24.GT.SCUT) THEN
17775                     P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17776                     X34=MIN(PHEP(4,NHEP+4)/PHEP(4,NHEP+5),
17777      &                    PHEP(4,NHEP+5)/PHEP(4,NHEP+4))*P34
17778                     IF (X34.GT.SCUT) GOTO 40
17779                   ENDIF
17780                 ENDIF
17781               ENDIF
17782             ENDIF
17783           ENDIF
17784         ELSE
17785           P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
17786           IF (P12.GT.SCUT) THEN
17787             P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
17788             IF (P13.GT.SCUT) THEN
17789               P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
17790               IF (P14.GT.SCUT) THEN
17791                 P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
17792                 IF (P23.GT.SCUT) THEN
17793                   P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
17794                   IF (P24.GT.SCUT) THEN
17795                     P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17796                     IF (P34.GT.SCUT) GOTO 40
17797                   ENDIF
17798                 ENDIF
17799               ENDIF
17800             ENDIF
17801           ENDIF
17802         ENDIF
17803 C Failed cuts retry
17804         GOTO 30
17805 C Passed cuts: calculate contributions to Matrix Elements
17806   40    EMSCA=SQRT(MIN(P12,P13,P14,P23,P24,P34))
17807         IF (DURHAM) EMSCA=SQRT(MIN(X12,X13,X14,X23,X24,X34))
17808         IF (FIX4JT) EMSCA=SQRT(SCUT)
17809         FACTR=FACT*HWUALF(1,EMSCA)**2
17810         IF (ORIENT) THEN
17811           QF=HWULDO(PHEP(1,LP),PHEP(1,3))
17812           EF=Q2NOW/(2*SQRT(QF**2-HWULDO(PHEP(1,LP),PHEP(1,LP))*Q2NOW))
17813           QF=HALF-EF*QF/Q2NOW
17814           DO I=1,4
17815             E(I)=EF*PHEP(I,LP)+QF*PHEP(I,3)
17816           ENDDO
17817           EP1=HWULDO(E,PHEP(1,NHEP+2))
17818           EP2=HWULDO(E,PHEP(1,NHEP+3))
17819           EP3=HWULDO(E,PHEP(1,NHEP+4))
17820           EP4=HWULDO(E,PHEP(1,NHEP+5))
17821         ENDIF
17822 C q-qbar-g-g
17823         GG1=HWH4J1(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17824      &     +HWH4J1(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17825         GG2=HWH4J1(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17826      &     +HWH4J1(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17827         GG12=HWH4J2(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17828      &      +HWH4J2(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17829      &      +HWH4J2(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17830      &      +HWH4J2(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17831         GG3=HWH4J4(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17832      &     +HWH4J4(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17833         GG13=GG3+HWH4J5(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17834      &          +HWH4J5(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17835         GG23=GG3+HWH4J5(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17836      &          +HWH4J5(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17837 C Add up weights
17838         GG1  =COLA*(GG1 +GG13)
17839         GG2  =COLA*(GG2 +GG23)
17840         GGINT=COLB*(GG12-GG13-GG23)
17841         WTGG=FACTR*(GG1+GG2+GGINT)
17842 C q-qbar-q-qbar
17843         QP=HWH4J6(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
17844      &    +HWH4J6(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
17845      &    +HWH4J6(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
17846      &    +HWH4J6(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
17847         QQ=HWH4J6(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
17848      &    +HWH4J6(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
17849      &    +HWH4J6(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
17850      &    +HWH4J6(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
17851         QQINT=HWH4J7(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
17852      &       +HWH4J7(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
17853      &       +HWH4J7(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
17854      &       +HWH4J7(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
17855      &       +HWH4J7(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
17856      &       +HWH4J7(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
17857      &       +HWH4J7(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
17858      &       +HWH4J7(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
17859 C Add up weights
17860         WTQP=FACTR*COLC*QP/TWO
17861         QQ1  =COLC*QP
17862         QQ2  =COLC*QQ
17863         QQINT=COLB*QQINT
17864         WTQQ=FACTR*(QQ1+QQ2+QQINT)/2
17865       ENDIF
17866 C
17867       HCS=0.
17868       DO 60 ID1=IDMN,IDMX
17869       IF (INCLQG(ID1)) THEN
17870 C Gluon channel
17871         HCS=HCS+CLF(1,ID1)*WTGG
17872         IF (GENEV.AND.HCS.GT.RCS) THEN
17873 C Select colour flow
17874           WTAB=GG1
17875           WTBA=GG2
17876           IF (IOP4JT(1).EQ.1) THEN
17877             IF (GGINT.GE.ZERO) THEN
17878               WTAB=WTAB+GGINT
17879             ELSE
17880               WTBA=MAX(WTBA,WTBA+GGINT)
17881             ENDIF
17882           ELSEIF (IOP4JT(1).EQ.2) THEN
17883             IF (GGINT.GE.ZERO) THEN
17884               WTBA=WTBA+GGINT
17885             ELSE
17886               WTAB=MAX(WTAB,WTAB+GGINT)
17887             ENDIF
17888           ELSEIF (IOP4JT(1).NE.0) THEN
17889             CALL HWWARN('HWH4JT',101)
17890             GOTO 999
17891           ENDIF
17892           WTOT=WTAB+WTBA
17893           IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
17894             CALL HWHQCP( 13, 13,3142,91)
17895             GOTO 99
17896           ELSE
17897             CALL HWHQCP( 13, 13,4123,92)
17898             GOTO 99
17899           ENDIF
17900         ENDIF
17901       ENDIF
17902 C Quark channels
17903       DO 50 ID2=1,6
17904 C Identical quark pairs
17905       IF (ID1.EQ.ID2.AND.INCLQQ(ID1,ID1)) THEN
17906         HCS=HCS+CLF(1,ID1)*WTQQ
17907         IF (GENEV.AND.HCS.GT.RCS) THEN
17908 C Select colour flow
17909           WTAB=QQ1
17910           WTBA=QQ2
17911           IF (IOP4JT(2).EQ.1) THEN
17912             IF (QQINT.GE.ZERO) THEN
17913               WTAB=WTAB+QQINT
17914             ELSE
17915               WTBA=MAX(WTBA,WTBA+QQINT)
17916             ENDIF
17917           ELSEIF (IOP4JT(2).EQ.2) THEN
17918             IF (QQINT.GE.ZERO) THEN
17919               WTBA=WTBA+QQINT
17920             ELSE
17921               WTAB=MAX(WTAB,WTAB+QQINT)
17922             ENDIF
17923           ELSEIF (IOP4JT(2).NE.0) THEN
17924             CALL HWWARN('HWH4JT',102)
17925             GOTO 999
17926           ENDIF
17927           WTOT=WTAB+WTBA
17928           IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
17929             CALL HWHQCP(ID1,ID1+6,4123,93)
17930             GOTO 99
17931           ELSE
17932             CALL HWHQCP(ID1,ID1+6,2143,94)
17933             GOTO 99
17934           ENDIF
17935         ENDIF
17936 C Unlike quark pairs
17937       ELSEIF (INCLQQ(ID1,ID2)) THEN
17938         HCS=HCS+(CLF(1,ID1)+CLF(1,ID2))*WTQP
17939         IF (GENEV.AND.HCS.GT.RCS) THEN
17940           CALL HWHQCP(ID2,ID2+6,4123,95)
17941           GOTO 99
17942         ENDIF
17943       ENDIF
17944   50  CONTINUE
17945   60  CONTINUE
17946       EVWGT=HCS
17947       RETURN
17948 C Set up labels for selected final state
17949   99  IDN(1)=ID1
17950       IDN(2)=ID1+6
17951       J=NHEP+1
17952       IDHW(J)=200
17953       IDHEP(J)=23
17954       ISTHEP(J)=110
17955       JMOHEP(1,J)=LM
17956       JMOHEP(2,J)=LP
17957       JDAHEP(1,J)=NHEP+2
17958       JDAHEP(2,J)=NHEP+5
17959       DO 100 I=1,4
17960       J=NHEP+1+I
17961       IDHW(J)=IDN(I)
17962       IDHEP(J)=IDPDG(IDN(I))
17963       ISTHEP(J)=IST(I)
17964       JMOHEP(1,J)=NHEP+1
17965   100 JDAHEP(1,J)=0
17966 C And colour structure pointers
17967       DO 110 I=1,4
17968       J=ICO(I)
17969       JMOHEP(2,NHEP+1+I)=NHEP+1+J
17970   110 JDAHEP(2,NHEP+1+J)=NHEP+1+I
17971       NHEP=NHEP+5
17972  999  RETURN
17973       END
17974 CDECK  ID>, HWH4J1.
17975 *CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
17976 *-- Author :    Ian Knowles
17977 *- Split in 6 files by M. Kirsanov.
17978 C-----------------------------------------------------------------------
17979       FUNCTION HWH4J1(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17980 C-----------------------------------------------------------------------
17981 C     Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
17982 C-----------------------------------------------------------------------
17983       IMPLICIT NONE
17984       DOUBLE PRECISION HWH4J1,
17985      & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
17986       LOGICAL ORIENT
17987       S123=S12+S13+S23
17988       S124=S12+S14+S24
17989       S134=S13+S14+S34
17990       S234=S23+S24+S34
17991       S=S12+S13+S14+S23+S24+S34
17992       HWH4J1=(S12*((S12+S14+S23+S34)**2+S13*(S12+S14-S24)+S24*(S12+S23))
17993      &       +(S14*S23-S12*S34-S13*S24)*(S14+S23+S34)/2)
17994      &       /(S13*S24*S134*S234)
17995      &      +((S12+S24)*(S13+S34)-S14*S23)/(S13*S134**2)
17996      &      +2*S23*(S-S13)/(S13*S134*S24) + S34/(2*S13*S24)
17997       IF (ORIENT) THEN
17998         HWH4J1=HWH4J1
17999      &  +4*((EP1*EP1*((S-S13)*(S23+S24)-S24*S34)
18000      &      -EP1*EP2*(S12*(S123+S124)+(S+S12)*(S14+S23)+2*S14*S23
18001      &               +S24*S134+S234*(S13+2*S234))
18002      &      +EP1*EP3*(S*(S24-S12)+S12*S13+(S14+2*S234-S34)*S24)
18003      &      -EP1*EP4*(S12*S124+S23*(S+S12+S14))
18004      &      +EP2*EP2*((S-S24)*(S13+S14)+2*(S13+S34)*S234-S13*S34)
18005      &      -EP2*EP3*((S+S23)*(S12+S14)+(S12+2*(S23+S234))*S234)
18006      &      +EP2*EP4*(S12*(S24-S)+S13*(S+S23-S34)+2*(S13+S34-S234)*S234)
18007      &      +EP3*EP3*(S14+2*S234)*S24
18008      &      +EP3*EP4*(-S234*(2*(S12+S23)+S134)+S12*S34-S13*S24-S14*S23)
18009      &      +EP4*EP4*S13*S23)*S134
18010      &      +EP2*(EP1+EP3+EP4)*2*S14*S24*S234)/(S*S13*S24*S134**2*S234)
18011       ELSE
18012         HWH4J1=2*HWH4J1/3
18013       ENDIF
18014       END
18015 CDECK  ID>, HWH4J2.
18016 *CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
18017 *-- Author :    Ian Knowles
18018 C-----------------------------------------------------------------------
18019       FUNCTION HWH4J2(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18020 C-----------------------------------------------------------------------
18021 C     Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18022 C-----------------------------------------------------------------------
18023       IMPLICIT NONE
18024       DOUBLE PRECISION HWH4J2,
18025      & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
18026       LOGICAL ORIENT
18027       S123=S12+S13+S23
18028       S124=S12+S14+S24
18029       S134=S13+S14+S34
18030       S234=S23+S24+S34
18031       S=S12+S13+S14+S23+S24+S34
18032       HWH4J2=(S12*S14*(S24+S34)+S24*(S12*(S14+S34)+S13*(S14-S24)))
18033      &       /(S14*S23*S13*S134)
18034      &      +S12*(S+S34)*S124/(S24*S234*S14*S134)
18035      &      -(S13*(2*(S12+S24)+S23)+S14**2)/(S134*S13*S14)
18036      &      +S12*S123*S124/(2*S13*S24*S14*S23)
18037       IF (ORIENT) THEN
18038         HWH4J2=HWH4J2
18039      &  +4*((EP1*EP1*(S12*S134*S234-4*S23*S24*S34)
18040      &      +EP1*EP2*(2*(2*S13*S234+S14*S123)*S24-S12*S134*(S+S12+S34))
18041      &      +EP1*EP3*(S12*(4*S24*S34-S134*(S12+S14-S24))
18042      &               -4*(S13*S24-S14*S23)*S24)
18043      &      +EP1*EP4*(4*(S13+S14)*S23*S24-S12*S134*(S12+S13-S23))
18044      &      +EP2*EP2*(S12*S134-4*S13*S24)*S134
18045      &      +EP2*EP3*(4*S13*(S12+S23+S24)*S24-S12*S134*(S12-S14+S24))
18046      &      -EP2*EP4*(4*(S12*(S14+S134)+S13*(S134-S234))*S24
18047      &               +S12*(S12-S13+S23)*S134)
18048      &      -EP3*EP3*4*S12*S14*S24
18049      &      -EP3*EP4*2*S12*(2*S14*S24+S12*S134))*S234
18050      &      +(EP1*(EP1*(S23+S24)+EP2*(S134-2*S))
18051      &       -(EP1+EP2)*(EP3+EP4)*S12+EP2*EP2*(S13+S14))*2*S14*S24*S123)
18052      &    /(2*S*S13*S14*S234*S23*S24*S134)
18053       ELSE
18054         HWH4J2=2*HWH4J2/3
18055       ENDIF
18056       END
18057 CDECK  ID>, HWH4J4.
18058 *CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
18059 *-- Author :    Ian Knowles
18060 C-----------------------------------------------------------------------
18061       FUNCTION HWH4J4(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18062 C-----------------------------------------------------------------------
18063 C     Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18064 C-----------------------------------------------------------------------
18065       IMPLICIT NONE
18066       DOUBLE PRECISION HWH4J4,
18067      & S12,S13,S14,S23,S24,S34,S134,S234,S,EP1,EP2,EP3,EP4
18068       LOGICAL ORIENT
18069       S134=S13+S14+S34
18070       S234=S23+S24+S34
18071       S=S12+S13+S14+S23+S24+S34
18072       HWH4J4=-(S12*(S34*(3*(S+S34)+S12)-S134*S234-2*(S13*S24+S14*S23))
18073      &        +(S14*S23-S13*S24)*(S13-S14+S24-S23))/(2*S134*S234*S34**2)
18074      &      -(S12*(S134**2/2+2*S13*S14+S34*(S13+S14-S34))
18075      &       +S34*((S13+S14)*(S23+S24)+S14*S24+S13*S23)
18076      &       +(S13*S24-S14*S23)*(S14-S13))/(S34*S134)**2
18077       IF (ORIENT) THEN
18078         HWH4J4=HWH4J4
18079      &  +4*((-EP1*EP1*2*(S23+S24)*S34
18080      &       -EP1*EP2*(S13*(S23+3*S24)+S14*(3*S23+S24)-(4*S12-S34)*S34)
18081      &       +EP1*EP3*((2*S12-S24)*S34-(S13-S14)*S24)
18082      &       +EP1*EP4*((2*S12-S23)*S34+(S13-S14)*S23)
18083      &       -EP2*EP2*2*(S13+S14)*S34
18084      &       +EP2*EP3*(2*S12*S34-S14*(S23-S24+S34))
18085      &       +EP2*EP4*(2*S12*S34+S13*(S23-S24-S34))
18086      &       +EP3*EP3*2*S14*S24
18087      &       +EP3*EP4*2*(S12*S34-S13*S24-S14*S23)
18088      &       +EP4*EP4*2*S13*S23)/(S*S134*S234*S34**2)
18089      &      +(EP1*EP2*(S134*(S134+2*S34)+4*(S13*S14-S34**2))
18090      &       +EP2*EP3*2*(2*S13*S34+S14*(S13-S14+S34))
18091      &       +EP2*EP4*2*(2*S14*S34-S13*(S13-S14-S34)))
18092      &  /(S*(S134*S34)**2))
18093       ELSE
18094         HWH4J4=2*HWH4J4/3
18095       ENDIF
18096       END
18097 CDECK  ID>, HWH4J5.
18098 *CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
18099 *-- Author :    Ian Knowles
18100 C-----------------------------------------------------------------------
18101       FUNCTION HWH4J5(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18102 C-----------------------------------------------------------------------
18103 C     Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18104 C-----------------------------------------------------------------------
18105       IMPLICIT NONE
18106       DOUBLE PRECISION HWH4J5,
18107      & S12,S13,S14,S23,S24,S34,S134,S234,S,EP1,EP2,EP3,EP4,
18108      & SUM
18109       LOGICAL ORIENT
18110       S134=S13+S14+S34
18111       S234=S23+S24+S34
18112       S=S12+S13+S14+S23+S24+S34
18113       HWH4J5=(3*S12*S34**2-3*S13*S24*S34+3*S12*S24*S34+3*S14*S23*S34-
18114      $     S13*S24**2-S12*S23*S34+6*S12*S14*S34+2*S12*S13*S34-
18115      $     2*S12**2*S34+S14*S23*S24-3*S13*S23*S24-2*S13*S14*S24+
18116      $     4*S12*S14*S24+2*S12*S13*S24+3*S14*S23**2+2*S14**2*S23+
18117      $     2*S14**2*S12+2*S12**2*S14+6*S12*S14*S23-2*S12*S13**2-
18118      $     2*S12**2*S13)/(2*S13*S134*S234*S34)+
18119      $     (2*S12*S34**2-2*S13*S24*S34+S12*S24*S34+4*S13*S23*S34+
18120      $     4*S12*S14*S34+2*S12*S13*S34+2*S12**2*S34-S13*S24**2+
18121      $     3*S14*S23*S24+4*S13*S23*S24-2*S13*S14*S24+4*S12*S14*S24+
18122      $     2*S12*S13*S24+2*S14*S23**2+4*S13*S23**2+2*S13*S14*S23+
18123      $     2*S12*S14*S23+4*S12*S13*S23+2*S12*S14**2+4*S12**2*S13+
18124      $     4*S12*S13*S14+2*S12**2*S14)/(2*S13*S134*S24*S34)-
18125      $     (S12*S34**2-2*S14*S24*S34-2*S13*S24*S34-S14*S23*S34+
18126      $     S13*S23*S34+S12*S14*S34+2*S12*S13*S34-2*S14**2*S24-
18127      $     4*S13*S14*S24-4*S13**2*S24-S14**2*S23-S13**2*S23+
18128      $     S12*S13*S14-S12*S13**2)/(S13*S34*S134**2)
18129       IF (ORIENT) THEN
18130         SUM=
18131      &    +EP1*EP1*((S13-S14+S23-3*S24)*S34+(S134+S14+2*S34)*S234)
18132      &            *S24*S134
18133      &    +EP1*EP2*((2*(S12-S24)+S34)*S134-S14*(4*S12+S14+3*S23)
18134      &             +S13*(S13+S23)+S24*S34 )*S24*S134
18135      &    -EP1*EP2*(((2*S12*S134+S13*(2*(S12+S14+S23)-S24+S34)
18136      &              +S14*(S14-S23)+(2*S14-S34)*S234)*S234)*S134
18137      &             + 4*S13**2*S24*S234)
18138      &    +EP1*EP3*(S12*(2*S13-S134)+S13*(S24+2*S234)+S14*(3*S24-S234)
18139      &             +S34*(S234-3*S24))*S24*S134
18140      &    +EP1*EP4*((S12*(S13-S14+3*S34)-S23*(S13+3*S14-S34))*S24
18141      &             -(S12*(S13+S134+2*S34)+2*S13*S24
18142      &              +(S13-2*S14)*S23)*S234)*S134
18143      &    +EP2*EP2*(S13*((2*S13+S34)*S234+S24*(S134-2*S34))
18144      &             +2*S14*S134*(S24+S234))*S134
18145         SUM=SUM
18146      &    -EP2*EP3*(((S12*(S13+2*S14-S34)+S14*(S+2*S23-S34))*S24
18147      &              +(S12*(S13+S134)+(S13+S24+2*S234)*S14
18148      &               +2*S13*(2*S23+S34))*S234)*S134
18149      &             +4*S13**2*S24*S234)
18150      &    +EP2*EP4*(((S12*(S13-2*S134)+S13*(S+2*S23-3*S34))*S24
18151      &              -((S-3*S13+S23+2*S24)*S13+2*S12*S14
18152      &                +2*S14*(S23+2*S24))*S234)*S134-4*S13**2*S24*S234)
18153      &    +EP3*EP3*2*(S13*S234+S14*S24)*S24*S134
18154      &    +EP3*EP4*(2*(S12*S34-S13*S24-S14*S23)*S24
18155      &             -(S12*S134+2*S13*S23)*S234)*S134
18156      &    +EP4*EP4*2*(S12*S234+S23*S24)*S13*S134
18157         HWH4J5=HWH4J5+4*SUM/(S*S234*S134**2*S13*S34*S24)
18158       ELSE
18159         HWH4J5=2*HWH4J5/3
18160       ENDIF
18161       END
18162 CDECK  ID>, HWH4J6.
18163 *CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
18164 *-- Author :    Ian Knowles
18165 C-----------------------------------------------------------------------
18166       FUNCTION HWH4J6(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18167 C-----------------------------------------------------------------------
18168 C     Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18169 C-----------------------------------------------------------------------
18170       IMPLICIT NONE
18171       DOUBLE PRECISION HWH4J6,
18172      & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
18173       LOGICAL ORIENT
18174       S123=S12+S13+S23
18175       S124=S12+S14+S24
18176       S134=S13+S14+S34
18177       S234=S23+S24+S34
18178       S=S12+S13+S14+S23+S24+S34
18179       HWH4J6=(S23*(S123*S234-S*S23)+S12*(S123*S124-S*S12))/(S13*S123)**2
18180      &     -(S12*S34*(S234-2*S23)+S14*S23*(S234-2*S34)
18181      &      -S13*S24*(S234+S13))/(S13**2*S123*S134)
18182       IF (ORIENT) THEN
18183         HWH4J6=HWH4J6
18184      &  +4*(-EP1*EP1*2*S23*S34
18185      &      +EP1*EP2*((S12-S23)*S34-S13*(S24-S34))
18186      &      +(EP1*EP3+EP2*EP4)*2*(S12*S34-S13*S24+S14*S23)
18187      &      -EP1*EP4*(S13*S24-(3*(S13+S14)+S34)*S23)
18188      &      -(EP1+EP2+EP3)*EP4*2
18189      &       *(S12*(S13+S23)+(S12+S13)*S23)*S134/S123
18190      &      +EP2*EP2*S13*(S14+S34)
18191      &      +EP2*EP3*(S13*(S14-S24)-(S12-S23)*S14)
18192      &      -EP3*EP3*2*S12*S14
18193      &      -EP3*EP4*(S13*S24-(3*(S13+S34)+S14)*S12)
18194      &      +EP4*EP4*(S12+S23)*S13)/(S*S134*S123*S13**2)
18195       ELSE
18196         HWH4J6=2*HWH4J6/3
18197       ENDIF
18198       END
18199 CDECK  ID>, HWH4J7.
18200 *CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
18201 *-- Author :    Ian Knowles
18202 C-----------------------------------------------------------------------
18203       FUNCTION HWH4J7(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18204 C-----------------------------------------------------------------------
18205 C     Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18206 C-----------------------------------------------------------------------
18207       IMPLICIT NONE
18208       DOUBLE PRECISION HWH4J7,
18209      & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
18210       LOGICAL ORIENT
18211       S123=S12+S13+S23
18212       S124=S12+S14+S24
18213       S134=S13+S14+S34
18214       S234=S23+S24+S34
18215       S=S12+S13+S14+S23+S24+S34
18216       HWH4J7=((S12*S34+S13*S24-S14*S23)*(S13+S14+S23+S24)-2*S12*S24*S34)
18217      &      /(S13*S134*S23*S123)
18218      &      -S12*(S12*S-S123*S124)/(S123**2*S13*S23)
18219      &      -(S13+S14)*(S23+S24)*S34/(S13*S134*S23*S234)
18220       IF (ORIENT) THEN
18221         HWH4J7=HWH4J7
18222      &  +4*(+2*(EP1+EP2)*(S23*EP1-S13*EP2)*S34*S134
18223      &      -EP1*EP2*2*S34**2*S123
18224      &      +EP1*EP3*(S123*(S23+S24)*S34+2*S134*(S13*S24-S14*S23))
18225      &      +EP1*EP4*(S123*(S23+S24)*S34+2*S12**2*S134*S234/S123
18226      &               +2*S134*(S24*(S13-S12)-S23*(S12+S14)))
18227      &      +EP2*EP3*(2*(S12*S34+S13*S24-S14*S23)*S134
18228      &               +S123*(S13+S14)*S34)
18229      &      +EP2*EP4*(S123*(S13+S14)*S34+2*S12**2*S234*S134/S123
18230      &               -2*S134*(S12*S234-S13*S24+S14*S23))
18231      &      -EP3*EP3*S12*(2*S24*S134+S123*S34)
18232      &      +EP3*EP4*2*S12*(S134*(S23-S24)-S34*S123+S12*S134*S234/S123)
18233      &      +EP4*EP4*S12*(2*S23*S134-S123*S34))
18234      &     /(S*S13*S23*S123*S134*S234)
18235       ELSE
18236         HWH4J7=2*HWH4J7/3
18237       ENDIF
18238       END
18239 CDECK  ID>, HWHBGF.
18240 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
18241 *-- Author :    Giovanni Abbiendi & Luca Stanco
18242 C-----------------------------------------------------------------------
18243       SUBROUTINE HWHBGF
18244 C-----------------------------------------------------------------------
18245 C     Order Alpha_s processes in charged lepton-hadron collisions
18246 C
18247 C       Process code IPROC has to be set in the Main Program
18248 C       the following codes IPROC may be selected
18249 C
18250 C                9100 : NC  BOSON-GLUON FUSION
18251 C                9100+IQK (IQK=1,...,6) :  produced flavour is IQK
18252 C                9107 : produced  J/psi + gluon
18253 C
18254 C                9110 : NC  QCD COMPTON
18255 C                9110+IQK (IQK=1,...,12) : struck parton is IQK
18256 C
18257 C                9130 : NC order alpha_s processes (9100+9110)
18258 C
18259 C       Select maximum and minimum generated flavour when IQK=0
18260 C       setting IFLMIN and IFLMAX in the Main Program
18261 C       (allowed values from 1 to 6), default are 1 and 5
18262 C       allowing d,u,s,c,b,dbar,ubar,sbar,cbar,bbar
18263 C
18264 C           CHARGED CURRENT Boson-Gluon Fusion processes
18265 C                9141 : CC  s cbar  (c sbar)
18266 C                9142 : CC  b cbar  (c bbar)
18267 C                9143 : CC  s tbar  (t cbar)
18268 C                9144 : CC  b tbar  (t bbar)
18269 C
18270 C       other inputs : Q2MIN,Q2MAX,YBMIN,YBMAX,PTMIN,EMMIN,EMMAX
18271 C       when IPROC=(1)9107 : as above but Q2WWMN, Q2WWMX substitute
18272 C                            Q2MIN and Q2MAX (EPA is used); ZJMAX cut
18273 C
18274 C      Add 10000 to suppress soft remnant fragmentation
18275 C
18276 C      Mean EVWGT = cross section in nanoBarn
18277 C
18278 C-----------------------------------------------------------------------
18279       INCLUDE 'herwig65.inc'
18280       DOUBLE PRECISION HWRGEN,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,
18281      & ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,FSIGMA(18),
18282      & SIGSUM,PROB,PRAN,PVRT(4),X
18283       INTEGER LEP
18284       INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,LEPFIN,ID1,ID2,I,IDD
18285       LOGICAL CHARGD,INCLUD(18),INSIDE(18),IFGO
18286       EXTERNAL HWRGEN
18287       SAVE LEPFIN,ID1,ID2,FSIGMA,SIGSUM
18288       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18289      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18290      & IPROO,CHARGD,INCLUD,INSIDE
18291 C---Initialization
18292       IF (FSTWGT) THEN
18293 C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
18294         LEP=0
18295         IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
18296           LEP=1
18297         ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
18298           LEP=-1
18299         ENDIF
18300         IF (LEP.EQ.0) CALL HWWARN('HWHBGF',500)
18301         IPROO=MOD(IPROC,100)/10
18302         IF (IPROO.EQ.0.OR.IPROO.EQ.4) THEN
18303           IQK=MOD(IPROC,10)
18304           IFL=IQK
18305           IF (IQK.EQ.7) IFL=164
18306           CHARGD=IPROO.EQ.4
18307         ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
18308           IQK=MOD(IPROC,100)-10
18309           IFL=IQK+6
18310           CHARGD=.FALSE.
18311         ELSEIF (IPROO.EQ.3) THEN
18312           IQK=0
18313           IFL=0
18314           CHARGD=.FALSE.
18315         ELSE
18316           CALL HWWARN('HWHBGF',501)
18317         ENDIF
18318 C
18319         LEPFIN = IDHW(1)
18320         IF(CHARGD) THEN
18321           LEPFIN = IDHW(1)+1
18322           IF (IQK.EQ.1) THEN
18323             IFLAVU=4
18324             IFLAVD=3
18325             ID1  = 3
18326             ID2  = 10
18327           ELSEIF (IQK.EQ.2) THEN
18328             IFLAVU=4
18329             IFLAVD=5
18330             ID1  = 5
18331             ID2  = 10
18332           ELSEIF (IQK.EQ.3) THEN
18333             IFLAVU=6
18334             IFLAVD=3
18335             ID1  = 3
18336             ID2  =12
18337           ELSE
18338             IFLAVU=6
18339             IFLAVD=5
18340             ID1  = 5
18341             ID2  =12
18342           ENDIF
18343           IF (LEP.EQ.-1) THEN
18344             IDD=ID1
18345             ID1=ID2-6
18346             ID2=IDD+6
18347           ENDIF
18348         ENDIF
18349 C
18350         IF (IQK.EQ.0) THEN
18351           DO I=1,18
18352             INCLUD(I)=.TRUE.
18353           ENDDO
18354           IMIN=1
18355           IMAX=18
18356           DO I=1,6
18357             IF (I.LT.IFLMIN.OR.I.GT.IFLMAX) INCLUD(I)=.FALSE.
18358           ENDDO
18359           DO I=7,18
18360             IF (I.LE.12) THEN
18361               IF (I-6.LT.IFLMIN.OR.I-6.GT.IFLMAX) INCLUD(I)=.FALSE.
18362             ELSE
18363               IF (I-12.LT.IFLMIN.OR.I-12.GT.IFLMAX) INCLUD(I)=.FALSE.
18364             ENDIF
18365           ENDDO
18366           IF (IPROO.EQ.0) THEN
18367             DO I=7,18
18368               INCLUD(I)=.FALSE.
18369             ENDDO
18370             IMIN=IFLMIN
18371             IMAX=IFLMAX
18372           ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
18373             DO I=1,6
18374               INCLUD(I)=.FALSE.
18375             ENDDO
18376             IMIN=IFLMIN+6
18377             IMAX=IFLMAX+12
18378           ELSEIF (IPROO.EQ.3) THEN
18379             IMIN=IFLMIN
18380             IMAX=IFLMAX+12
18381           ENDIF
18382         ELSEIF (IQK.NE.0 .AND. (.NOT.CHARGD)) THEN
18383           DO I=1,18
18384             INCLUD(I)=.FALSE.
18385           ENDDO
18386           IF (IFL.LE.18) THEN
18387             INCLUD(IFL)=.TRUE.
18388             IMIN=IFL
18389             IMAX=IFL
18390           ELSEIF (IFL.EQ.164) THEN
18391             INCLUD(7)=.TRUE.
18392             IMIN=7
18393             IMAX=7
18394           ENDIF
18395         ENDIF
18396       ENDIF
18397 C---End of initialization
18398       IF(GENEV) THEN
18399       IF (.NOT.CHARGD) THEN
18400         IF (IQK.EQ.0) THEN
18401           PRAN= SIGSUM * HWRGEN(0)
18402           PROB=ZERO
18403           DO 10 IFL=IMIN,IMAX
18404             IF (.NOT.INSIDE(IFL)) GOTO 10
18405             PROB=PROB+FSIGMA(IFL)
18406             IF (PROB.GE.PRAN) GOTO 20
18407   10      CONTINUE
18408         ENDIF
18409 C---at this point the subprocess has been selected (IFL)
18410   20    CONTINUE
18411         IF (IFL.LE.6) THEN
18412 C---Boson-Gluon Fusion event
18413           IDHW(NHEP+1)=IDHW(1)
18414           IDHW(NHEP+2)=13
18415           IDHW(NHEP+3)=15
18416           IDHW(NHEP+4)=LEPFIN
18417           IDHW(NHEP+5)=IFL
18418           IDHW(NHEP+6)=IFL+6
18419         ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
18420 C---QCD_Compton event
18421           IDHW(NHEP+1)=IDHW(1)
18422           IDHW(NHEP+2)=IFL-6
18423           IDHW(NHEP+3)=15
18424           IDHW(NHEP+4)=LEPFIN
18425           IDHW(NHEP+5)=IFL-6
18426           IDHW(NHEP+6)=13
18427         ELSEIF (IFL.EQ.164) THEN
18428 C---gamma+gluon-->J/Psi+gluon
18429           IDHW(NHEP+1)=IDHW(1)
18430           IDHW(NHEP+2)=13
18431           IDHW(NHEP+3)=15
18432           IDHW(NHEP+4)=LEPFIN
18433           IDHW(NHEP+5)=164
18434           IDHW(NHEP+6)=13
18435         ELSE
18436           CALL HWWARN('HWHBGF',503)
18437         ENDIF
18438       ELSE
18439 C---Charged current event of specified flavours
18440         IDHW(NHEP+1)=IDHW(1)
18441         IDHW(NHEP+2)=13
18442         IDHW(NHEP+3)=15
18443         IDHW(NHEP+4)=LEPFIN
18444         IDHW(NHEP+5)=ID1
18445         IDHW(NHEP+6)=ID2
18446       ENDIF
18447 C
18448       DO 1 I=NHEP+1,NHEP+6
18449     1 IDHEP(I)=IDPDG(IDHW(I))
18450 C
18451 C---Codes common for all processes
18452       ISTHEP(NHEP+1)=111
18453       ISTHEP(NHEP+2)=112
18454       ISTHEP(NHEP+3)=110
18455       ISTHEP(NHEP+4)=113
18456       ISTHEP(NHEP+5)=114
18457       ISTHEP(NHEP+6)=114
18458 C
18459       DO I=NHEP+1,NHEP+6
18460         JMOHEP(1,I)=NHEP+3
18461         JDAHEP(1,I)=0
18462       ENDDO
18463 C---Incoming lepton
18464       JMOHEP(2,NHEP+1)=NHEP+4
18465       JDAHEP(2,NHEP+1)=NHEP+4
18466 C---Hard Process C.M.
18467       JMOHEP(1,NHEP+3)=NHEP+1
18468       JMOHEP(2,NHEP+3)=NHEP+2
18469       JDAHEP(1,NHEP+3)=NHEP+4
18470       JDAHEP(2,NHEP+3)=NHEP+6
18471 C---Outgoing lepton
18472       JMOHEP(2,NHEP+4)=NHEP+1
18473       JDAHEP(2,NHEP+4)=NHEP+1
18474 C
18475       IF (IFL.LE.6 .OR. CHARGD) THEN
18476 C---Codes for boson-gluon fusion processes
18477 C---  Incoming gluon
18478         JMOHEP(2,NHEP+2)=NHEP+6
18479         JDAHEP(2,NHEP+2)=NHEP+5
18480 C---  Outgoing quark
18481         JMOHEP(2,NHEP+5)=NHEP+2
18482         JDAHEP(2,NHEP+5)=NHEP+6
18483 C---  Outgoing antiquark
18484         JMOHEP(2,NHEP+6)=NHEP+5
18485         JDAHEP(2,NHEP+6)=NHEP+2
18486       ELSEIF (IFL.GE.7 .AND. IFL.LE.12) THEN
18487 C---Codes for V+q --> q+g
18488 C---  Incoming quark
18489         JMOHEP(2,NHEP+2)=NHEP+5
18490         JDAHEP(2,NHEP+2)=NHEP+6
18491 C---  Outgoing quark
18492         JMOHEP(2,NHEP+5)=NHEP+6
18493         JDAHEP(2,NHEP+5)=NHEP+2
18494 C---  Outgoing gluon
18495         JMOHEP(2,NHEP+6)=NHEP+2
18496         JDAHEP(2,NHEP+6)=NHEP+5
18497       ELSEIF (IFL.GE.13 .AND. IFL.LE.18) THEN
18498 C---Codes for V+qbar --> qbar+g
18499 C---  Incoming antiquark
18500         JMOHEP(2,NHEP+2)=NHEP+6
18501         JDAHEP(2,NHEP+2)=NHEP+5
18502 C---  Outgoing antiquark
18503         JMOHEP(2,NHEP+5)=NHEP+2
18504         JDAHEP(2,NHEP+5)=NHEP+6
18505 C---  Outgoing gluon
18506         JMOHEP(2,NHEP+6)=NHEP+5
18507         JDAHEP(2,NHEP+6)=NHEP+2
18508       ELSEIF (IFL.EQ.164) THEN
18509 C---Codes for Gamma+gluon --> J/Psi+gluon
18510 C---  Incoming gluon
18511         JMOHEP(2,NHEP+2)=NHEP+6
18512         JDAHEP(2,NHEP+2)=NHEP+6
18513 C---  Outgoing J/Psi
18514         JMOHEP(2,NHEP+5)=NHEP+1
18515         JDAHEP(2,NHEP+5)=NHEP+1
18516 C---  Outgoing gluon
18517         JMOHEP(2,NHEP+6)=NHEP+2
18518         JDAHEP(2,NHEP+6)=NHEP+2
18519       ENDIF
18520 C---Computation of momenta in Laboratory frame of reference
18521       CALL HWHBKI
18522       NHEP=NHEP+6
18523 C Decide which quark radiated and assign production vertices
18524       IF (IFL.LE.6) THEN
18525 C Boson-Gluon fusion case
18526         IF (1-Z.LT.HWRGEN(0)) THEN
18527 C Gluon splitting to quark
18528           CALL HWVZRO(4,VHEP(1,NHEP-1))
18529           CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
18530           CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP))
18531           CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
18532         ELSE
18533 C Gluon splitting to antiquark
18534           CALL HWVZRO(4,VHEP(1,NHEP))
18535           CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
18536           CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP-1))
18537           CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
18538         ENDIF
18539       ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
18540 C QCD Compton case
18541         X=1/(1+SHAT/Q2)
18542         IF (1.LT.HWRGEN(0)*(1+(1-X-Z)**2+6*X*(1-X)*Z*(1-Z))) THEN
18543 C Incoming quark radiated the gluon
18544           CALL HWVZRO(4,VHEP(1,NHEP-1))
18545           CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
18546           CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
18547           CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
18548         ELSE
18549 C Outgoing quark radiated the gluon
18550           CALL HWVZRO(4,VHEP(1,NHEP-4))
18551           CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
18552           CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
18553           CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
18554         ENDIF
18555       ENDIF
18556 C---HERWIG gets confused if lepton momentum is different from beam
18557 C   momentum, which it can be if incoming hadron has negative virtuality
18558 C   As a temporary fix, simply copy the momentum.
18559 C   Momentum conservation somehow gets taken care of HWBGEN!
18560       call hwvequ(5,phep(1,1),phep(1,nhep-5))
18561       ELSE
18562         EVWGT=ZERO
18563 C---generation of the 5 variables Y,Q2,SHAT,Z,PHI and Jacobian computation
18564 C---in the largest phase space avalaible for selected processes and
18565 C---filling of logical vector INSIDE to tag contributing ones
18566         CALL HWHBRN (IFGO)
18567         IF(IFGO) GOTO 999
18568 C---calculate differential cross section corresponding to the chosen
18569 C---variables and the weight for MC generation
18570         IF (IQK.EQ.0) THEN
18571 C---many subprocesses included
18572           DO I=1,18
18573             FSIGMA(I)=ZERO
18574           ENDDO
18575           SIGSUM=ZERO
18576           DO I=IMIN,IMAX
18577             IF (INSIDE(I)) THEN
18578               IFL=I
18579               DSIGMA=ZERO
18580               CALL HWHBSG
18581               FSIGMA(I)=DSIGMA
18582               SIGSUM=SIGSUM+DSIGMA
18583             ENDIF
18584           ENDDO
18585           EVWGT=SIGSUM * AJACOB
18586         ELSE
18587 C---only one subprocess included
18588           CALL HWHBSG
18589           EVWGT= DSIGMA * AJACOB
18590         ENDIF
18591         IF (EVWGT.LT.ZERO) EVWGT=ZERO
18592       ENDIF
18593  999  RETURN
18594       END
18595 CDECK  ID>, HWHBKI.
18596 *CMZ :-        -26/04/91  13.19.32  by  Federico Carminati
18597 *-- Author :    Giovanni Abbiendi & Luca Stanco
18598 C----------------------------------------------------------------------
18599       SUBROUTINE HWHBKI
18600 C----------------------------------------------------------------------
18601 C     gives the fourmomenta in the laboratory system for the particles
18602 C     of the hard 2-->3 subprocess, to match with HERWIG routines of
18603 C     jet evolution.
18604 C----------------------------------------------------------------------
18605       INCLUDE 'herwig65.inc'
18606       DOUBLE PRECISION HWUECM,HWUPCM,HWUSQR,Y,Q2,SHAT,Z,PHI,AJACOB,
18607      & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18608      & PGAMMA(5),SG,MF1,MF2,EP,PP,EL,PL,E1,E2,Q1,COSBET,SINBET,COSTHE,
18609      & SINTHE,SINAZI,COSAZI,ROTAZI(3,3),EGAM,A,PPROT,MREMIN,PGAM,PEP(5),
18610      & COSPHI,SINPHI,ROT(3,3),EPROT,PROTON(5),MPART
18611       INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,IHAD,J,IS,ICMF,LEP
18612       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18613       EXTERNAL HWUECM,HWUPCM,HWUSQR
18614       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18615      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18616      & IPROO,CHARGD,INCLUD,INSIDE
18617 C
18618       IHAD=2
18619       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18620 C---Set masses
18621       IF (CHARGD) THEN
18622         MPART=ZERO
18623         MF1=RMASS(IDHW(NHEP+5))
18624         MF2=RMASS(IDHW(NHEP+6))
18625         MREMIN=MP
18626       ELSE
18627         IS = IFL
18628         IF (IFL.EQ.164) IS=IQK
18629         MPART=ZERO
18630         IF (IFL.GE.7.AND.IFL.LE.18) MPART=RMASS(IFL-6)
18631         MF1=MFIN1(IS)
18632         MF2=MFIN2(IS)
18633         MREMIN = MREMIF(IS)
18634       ENDIF
18635 C---Calculation of kinematical variables for the generated event
18636 C   in the center of mass frame of the incoming boson and parton
18637 C   with parton along +z
18638       EGAM = HWUECM (SHAT, -Q2, MPART**2)
18639       PGAM = SQRT( EGAM**2 + Q2 )
18640       EP = RSHAT-EGAM
18641       PP = PGAM
18642       A = (W2+Q2-MP**2)/TWO
18643       PPROT = (A*PGAM-EGAM*SQRT(A**2+MP**2*Q2))/Q2
18644       IF (PPROT.LT.ZERO) THEN
18645         CALL HWWARN('HWHBKI',101)
18646         GOTO 999
18647       ENDIF
18648       EPROT = SQRT(PPROT**2+MP**2)
18649       IF ((EPROT+PPROT).LT.(EP+PP)) THEN
18650         CALL HWWARN('HWHBKI',102)
18651         GOTO 999
18652       ENDIF
18653       EL = ( PGAM / PPROT * SMA - Q2 ) / TWO
18654      +     / (EGAM + PGAM / PPROT * EPROT)
18655       IF (EL.GT.ME) THEN
18656         PL = SQRT ( EL**2 - ME**2 )
18657       ELSE
18658         CALL HWWARN ('HWHBKI',103)
18659         GOTO 999
18660       ENDIF
18661       COSBET = (TWO * EPROT * EL - SMA) / (TWO * PPROT * PL)
18662       IF ( ABS(COSBET) .GE. ONE ) THEN
18663         COSBET = SIGN (ONE,COSBET)
18664         SINBET = ZERO
18665       ELSE
18666         SINBET = SQRT (ONE - COSBET**2)
18667       ENDIF
18668       SG = ME**2 + MPART**2 + Q2 + TWO * RSHAT * EL
18669       IF (SG.LE.(RSHAT+ML)**2 .OR. SG.GE.(RS-MREMIN)**2) THEN
18670         CALL HWWARN ('HWHBKI',104)
18671         GOTO 999
18672       ENDIF
18673       Q1 = HWUPCM( RSHAT, MF1, MF2)
18674       E1 = SQRT(Q1**2+MF1**2)
18675       E2 = SQRT(Q1**2+MF2**2)
18676       IF (Q1 .GT. ZERO) THEN
18677         COSTHE=(TWO*EP*E1 - Z*(SHAT+Q2))/(TWO*PP*Q1)
18678         IF (ABS(COSTHE) .GT. ONE) THEN
18679           COSTHE=SIGN(ONE,COSTHE)
18680           SINTHE=ZERO
18681         ELSE
18682           SINTHE=SQRT(ONE-COSTHE**2)
18683         ENDIF
18684       ELSE
18685         COSTHE=ZERO
18686         SINTHE=ONE
18687       ENDIF
18688 C---Initial lepton
18689       PHEP(1,NHEP+1)=PL*SINBET
18690       PHEP(2,NHEP+1)=ZERO
18691       PHEP(3,NHEP+1)=PL*COSBET
18692       PHEP(4,NHEP+1)=EL
18693       PHEP(5,NHEP+1)=RMASS(IDHW(1))
18694 C---Initial Hadron
18695       PROTON(1)=ZERO
18696       PROTON(2)=ZERO
18697       PROTON(3)=PPROT
18698       PROTON(4)=EPROT
18699       CALL HWUMAS (PROTON)
18700 C---Initial parton
18701       PHEP(1,NHEP+2)=ZERO
18702       PHEP(2,NHEP+2)=ZERO
18703       PHEP(3,NHEP+2)=PP
18704       PHEP(4,NHEP+2)=EP
18705       PHEP(5,NHEP+2)=MPART
18706 C---HARD SUBPROCESS 2-->3 CENTRE OF MASS
18707       PHEP(1,NHEP+3)=PHEP(1,NHEP+1)+PHEP(1,NHEP+2)
18708       PHEP(2,NHEP+3)=PHEP(2,NHEP+1)+PHEP(2,NHEP+2)
18709       PHEP(3,NHEP+3)=PHEP(3,NHEP+1)+PHEP(3,NHEP+2)
18710       PHEP(4,NHEP+3)=PHEP(4,NHEP+1)+PHEP(4,NHEP+2)
18711       CALL HWUMAS  ( PHEP(1,NHEP+3) )
18712 C---Virtual boson
18713       PGAMMA(1)=ZERO
18714       PGAMMA(2)=ZERO
18715       PGAMMA(3)=-PGAM
18716       PGAMMA(4)=EGAM
18717       PGAMMA(5)=HWUSQR(Q2)
18718 C---Scattered lepton
18719       PHEP(1,NHEP+4)=PHEP(1,NHEP+1)-PGAMMA(1)
18720       PHEP(2,NHEP+4)=PHEP(2,NHEP+1)-PGAMMA(2)
18721       PHEP(3,NHEP+4)=PHEP(3,NHEP+1)-PGAMMA(3)
18722       PHEP(4,NHEP+4)=PHEP(4,NHEP+1)-PGAMMA(4)
18723       PHEP(5,NHEP+4)=RMASS(IDHW(1))
18724       IF (CHARGD) PHEP(5,NHEP+4)=ZERO
18725 C---First Final parton:  quark (or J/psi) in Boson-Gluon Fusion
18726 C---                     quark or antiquark in QCD Compton
18727       PHEP(1,NHEP+5)=Q1*SINTHE*COS(PHI)
18728       PHEP(2,NHEP+5)=Q1*SINTHE*SIN(PHI)
18729       PHEP(3,NHEP+5)=Q1*COSTHE
18730       PHEP(4,NHEP+5)=E1
18731       PHEP(5,NHEP+5)=MF1
18732 C---Second Final parton: antiquark in Boson-Gluon Fusion
18733 C---                     gluon in QCD Compton
18734       PHEP(1,NHEP+6)=-PHEP(1,NHEP+5)
18735       PHEP(2,NHEP+6)=-PHEP(2,NHEP+5)
18736       PHEP(3,NHEP+6)=-PHEP(3,NHEP+5)
18737       PHEP(4,NHEP+6)=E2
18738       PHEP(5,NHEP+6)=MF2
18739 C---Boost to lepton-hadron CM frame
18740       PEP(1) = PHEP(1,NHEP+1)
18741       PEP(2) = PHEP(2,NHEP+1)
18742       PEP(3) = PHEP(3,NHEP+1) + PPROT
18743       PEP(4) = PHEP(4,NHEP+1) + EPROT
18744       CALL HWUMAS (PEP)
18745       DO I=1,6
18746         CALL HWULOF (PEP,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18747       ENDDO
18748       CALL HWULOF (PEP,PROTON,PROTON)
18749       CALL HWULOF (PEP,PGAMMA,PGAMMA)
18750 C---Rotation around y-axis to align lepton beam with z-axis
18751       COSPHI = PHEP(3,NHEP+1) /
18752      &           SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
18753       SINPHI = PHEP(1,NHEP+1) /
18754      &           SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
18755       DO I=1,3
18756       DO J=1,3
18757         ROT(I,J)=ZERO
18758       ENDDO
18759       ENDDO
18760         ROT(1,1) = COSPHI
18761         ROT(1,3) = -SINPHI
18762         ROT(2,2) = ONE
18763         ROT(3,1) = SINPHI
18764         ROT(3,3) = COSPHI
18765       DO I=1,6
18766         CALL HWUROF (ROT,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18767       ENDDO
18768       CALL HWUROF (ROT,PROTON,PROTON)
18769       CALL HWUROF (ROT,PGAMMA,PGAMMA)
18770 C---Boost to the LAB frame
18771       ICMF=3
18772       DO I=1,6
18773         CALL HWULOB (PHEP(1,ICMF),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18774       ENDDO
18775       CALL HWULOB (PHEP(1,ICMF),PROTON,PROTON)
18776       CALL HWULOB (PHEP(1,ICMF),PGAMMA,PGAMMA)
18777 C---Random azimuthal rotation
18778       CALL HWRAZM (ONE,COSAZI,SINAZI)
18779       DO I=1,3
18780       DO J=1,3
18781         ROTAZI(I,J)=ZERO
18782       ENDDO
18783       ENDDO
18784         ROTAZI(1,1) = COSAZI
18785         ROTAZI(1,2) = SINAZI
18786         ROTAZI(2,1) = -SINAZI
18787         ROTAZI(2,2) = COSAZI
18788         ROTAZI(3,3) = ONE
18789       DO I=1,6
18790         CALL HWUROF (ROTAZI,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18791       ENDDO
18792       CALL HWUROF (ROTAZI,PROTON,PROTON)
18793       CALL HWUROF (ROTAZI,PGAMMA,PGAMMA)
18794  999  RETURN
18795       END
18796 CDECK  ID>, HWHBRN.
18797 *CMZ :-        -03/07/95  19.02.12  by  Giovanni Abbiendi
18798 *-- Author :    Giovanni Abbiendi & Luca Stanco
18799 C-----------------------------------------------------------------------
18800       SUBROUTINE HWHBRN (IFGO)
18801 C----------------------------------------------------------------------
18802 C     Returns a point in the phase space (Y,Q2,SHAT,Z,PHI) and the
18803 C     corresponding Jacobian factor AJACOB
18804 C     Fill the logical vector INSIDE to tag contributing subprocesses
18805 C     to the cross-section
18806 C-----------------------------------------------------------------------
18807       INCLUDE 'herwig65.inc'
18808       LOGICAL IFGO
18809       DOUBLE PRECISION HWRUNI,HWRGEN,HWUPCM,Y,Q2,SHAT,Z,PHI,AJACOB,
18810      & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18811      & MF1,MF2,YMIN,YMAX,YJAC,Q2INF,Q2SUP,Q2JAC,EMW2,ZMIN,ZMAX,ZJAC,
18812      & GAMMA2,LAMBDA,PHIJAC,ZINT,ZLMIN,ZL,EMW,TMIN,TMAX,EMLMIN,EMLMAX,
18813      & SHMIN,EMMIF(18),EMMAF(18),WMIF(18),WMIN,MREMIN,YMIF(18),Q1CM(18),
18814      & Q2MAF(18),EMMAWF(18),ZMIF(18),ZMAF(18),PLMAX,PINC,SHINF,SHSUP,
18815      & SHJAC,CTHLIM,Q1,DETDSH,SRY,SRY0,SRY1
18816       INTEGER LEP
18817       INTEGER IQK,IFLAVU,IFLAVD,I,IMIN,IMAX,IFL,IPROO,IHAD,NTRY,DEBUG
18818       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18819       EXTERNAL HWRUNI,HWRGEN,HWUPCM
18820       SAVE EMLMIN,EMLMAX,EMMIF,EMMAF,MREMIN,MF1,MF2,YMIF,
18821      &     YMIN,YMAX,WMIN,WMIF
18822       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18823      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18824      & IPROO,CHARGD,INCLUD,INSIDE
18825       EQUIVALENCE (EMW,RMASS(198))
18826 C
18827       IFGO = .FALSE.
18828       IHAD=2
18829       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18830 C---Initialization
18831       IF (FSTWGT.OR.IHAD.NE.2) THEN
18832         ME = RMASS(IDHW(1))
18833         MP = RMASS(IDHW(IHAD))
18834         RS = PHEP(5,3)
18835         SMA = RS**2-ME**2-MP**2
18836         PINC = HWUPCM(RS,ME,MP)
18837 C---Charged current
18838         IF (CHARGD) THEN
18839           ML=RMASS(IDHW(1)+1)
18840           YMAX = ONE - TWO*ML*MP / SMA
18841           YMAX = MIN(YMAX,YBMAX)
18842           MREMIN=MP
18843           IF (LEP.EQ.1) THEN
18844             MF1=RMASS(IFLAVD)
18845             MF2=RMASS(IFLAVU)
18846           ELSE
18847             MF1=RMASS(IFLAVU)
18848             MF2=RMASS(IFLAVD)
18849           ENDIF
18850           SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
18851      +            TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
18852           EMLMIN=MAX(EMMIN,SQRT(SHMIN))
18853           EMLMAX=MIN(EMMAX,RS-ML-MREMIN)
18854           DEBUG=1
18855           IF (EMLMIN.GT.EMLMAX) GOTO 888
18856           WMIN=EMLMIN+MREMIN
18857           PLMAX=HWUPCM(RS,ML,WMIN)
18858           YMIN = ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
18859      +                    PINC*PLMAX)/SMA
18860           YMIN = MAX(YMIN,YBMIN)
18861           DEBUG=2
18862           IF (YMIN.GT.YMAX) GOTO 888
18863         ELSE
18864 C---Neutral current
18865           ML = ME
18866           YMAX = ONE - TWO*ML*MP / SMA
18867           YMAX = MIN(YMAX,YBMAX)
18868           DO I=1,18
18869             YMIF(I)=ZERO
18870             EMMIF(I)=ZERO
18871             EMMAF(I)=ZERO
18872             WMIF(I)=ZERO
18873             IF (I.LE.8) THEN
18874 C---Boson-Gluon Fusion (also J/Psi) and QCD Compton with struck u or d
18875               MREMIF(I)=MP
18876               IF (I.LE.6) THEN
18877                 MFIN1(I)=RMASS(I)
18878                 MFIN2(I)=RMASS(I+6)
18879               ELSE
18880                 MFIN1(I)=RMASS(I-6)
18881                 MFIN2(I)=ZERO
18882               ENDIF
18883             ELSE
18884 C---QCD Compton with struck non-valence parton
18885               MREMIF(I)=MP+RMASS(I-6)
18886               MFIN1(I)=RMASS(I-6)
18887               MFIN2(I)=ZERO
18888             ENDIF
18889           ENDDO
18890           IF (IFL.EQ.164) THEN
18891 C---J/Psi
18892             MFIN1(7)=RMASS(164)
18893             MFIN2(7)=ZERO
18894           ENDIF
18895 C---y boundaries for different flavours and processes
18896           DO 100 I=IMIN,IMAX
18897             IF (INCLUD(I)) THEN
18898               MF1=MFIN1(I)
18899               MF2=MFIN2(I)
18900               MREMIN=MREMIF(I)
18901               SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
18902      +              TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
18903               EMMIF(I) = MAX(EMMIN,SQRT(SHMIN))
18904               EMMAF(I) = MIN(EMMAX,RS-ML-MREMIN)
18905               IF (EMMIF(I).GT.EMMAF(I)) THEN
18906                 INCLUD(I)=.FALSE.
18907                 CALL HWWARN('HWHBRN',3)
18908                 GOTO 100
18909               ENDIF
18910               WMIF(I) = EMMIF(I)+MREMIF(I)
18911               WMIN = WMIF(I)
18912               PLMAX = HWUPCM(RS,ML,WMIN)
18913               YMIF(I)=ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
18914      +                         PINC*PLMAX)/SMA
18915               IF (YMIF(I).GT.YMAX) THEN
18916                 INCLUD(I)=.FALSE.
18917                 CALL HWWARN('HWHBRN',4)
18918                 GOTO 100
18919               ENDIF
18920             ENDIF
18921  100      CONTINUE
18922 C---considering the largest boundaries
18923           EMLMIN=EMMIF(IMIN)
18924           EMLMAX=EMMAF(IMIN)
18925           IF (IPROO.EQ.3) THEN
18926             EMLMIN=MIN(EMMIF(IMIN),EMMIF(IMIN+6))
18927             EMLMAX=MAX(EMMAF(IMIN),EMMAF(IMIN+6))
18928           ENDIF
18929           DEBUG=3
18930           IF (EMLMIN.GT.EMLMAX) GOTO 888
18931           YMIN=YMIF(IMIN)
18932           IF (IPROO.EQ.3) YMIN=MIN(YMIF(IMIN),YMIF(IMIN+6))
18933           YMIN = MAX(YMIN,YBMIN)
18934           DEBUG=4
18935           IF (YMIN.GT.YMAX) GOTO 888
18936           WMIN = WMIF(IMIN)
18937           MREMIN = MREMIF(IMIN)
18938           MF1=MFIN1(IMIN)
18939           MF2=MFIN2(IMIN)
18940           IF (IPROO.EQ.3) THEN
18941             WMIN = MIN(WMIF(IMIN),WMIF(IMIN+6))
18942             MREMIN = MIN(MREMIF(IMIN),MREMIF(IMIN+6))
18943           ENDIF
18944         ENDIF
18945       ENDIF
18946 C---Random generation in largest phase space
18947       Y=ZERO
18948       Q2=ZERO
18949       SHAT=ZERO
18950       Z=ZERO
18951       PHI=ZERO
18952       AJACOB=ZERO
18953 C---y generation
18954       IF (.NOT.CHARGD) THEN
18955         IF (IFL.LE.5.OR.(IFL.GE.7.AND.IFL.LE.18)) THEN
18956           SRY0 = SQRT(YMIN)
18957           SRY1 = SQRT(YMAX)
18958           SRY = HWRUNI(0,SRY0,SRY1)
18959           Y = SRY**2
18960           YJAC = TWO*SRY*(SRY1-SRY0)
18961         ELSEIF (IFL.EQ.6) THEN
18962           Y = SQRT(HWRUNI(0,YMIN**2,YMAX**2))
18963           YJAC = HALF * (YMAX**2-YMIN**2) / Y
18964         ELSEIF (IFL.EQ.164) THEN
18965 C---in J/psi photoproduction Y and Q2 are given by the Equivalent Photon
18966 C   Approximation
18967    10     NTRY=0
18968    20     NTRY=NTRY+1
18969           IF (NTRY.GT.NETRY) THEN
18970             CALL HWWARN('HWHBRN',50)
18971             GOTO 10
18972           ENDIF
18973           Y = (YMIN/YMAX)**HWRGEN(1)*YMAX
18974           IF (ONE+(ONE-Y)**2.LT.TWO*HWRGEN(2)) GOTO 20
18975           YJAC=(TWO*LOG(YMAX/YMIN)-TWO*(YMAX-YMIN)
18976      &                            +HALF*(YMAX**2-YMIN**2))
18977         ENDIF
18978       ELSE
18979         IF (IPRO.EQ.5) THEN
18980           Y = EXP(HWRUNI(0,LOG(YMIN),LOG(YMAX)))
18981           YJAC = Y * LOG(YMAX/YMIN)
18982         ELSE
18983           Y = HWRUNI(0,YMIN,YMAX)
18984           YJAC = YMAX - YMIN
18985         ENDIF
18986       ENDIF
18987 C---Q**2 generation
18988       Q2INF = ME**2*Y**2 / (ONE-Y)
18989       Q2SUP = MP**2 + SMA*Y - WMIN**2
18990       IF (IFL.EQ.164) THEN
18991         Q2INF = MAX(Q2INF,Q2WWMN)
18992         Q2SUP = MIN(Q2SUP,Q2WWMX)
18993       ELSE
18994         Q2INF = MAX(Q2INF,Q2MIN)
18995         Q2SUP = MIN(Q2SUP,Q2MAX)
18996       ENDIF
18997       DEBUG=5
18998       IF (Q2INF .GT. Q2SUP) GOTO 888
18999 C
19000       IF (.NOT.CHARGD) THEN
19001         IF (IFL.EQ.164) THEN
19002           Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
19003           Q2JAC = LOG(Q2SUP/Q2INF)
19004         ELSEIF (Q2INF.LT.RMASS(4)**2) THEN
19005           Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
19006           Q2JAC = Q2 * LOG(Q2SUP/Q2INF)
19007         ELSE
19008           Q2 = Q2INF*Q2SUP/HWRUNI(0,Q2INF,Q2SUP)
19009           Q2JAC = Q2**2 * (Q2SUP-Q2INF)/(Q2SUP*Q2INF)
19010         ENDIF
19011       ELSE
19012         EMW2=EMW**2
19013         Q2=(Q2INF+EMW2)*(Q2SUP+EMW2)/(HWRUNI(0,Q2INF,Q2SUP)+EMW2)-EMW2
19014         Q2JAC=(Q2+EMW2)**2*(Q2SUP-Q2INF)/((Q2SUP+EMW2)*(Q2INF+EMW2))
19015       ENDIF
19016       W2 = MP**2 + SMA*Y - Q2
19017 C---s_hat generation
19018       SHINF = EMLMIN **2
19019       SHSUP = (MIN(SQRT(W2)-MREMIN,EMLMAX))**2
19020       DEBUG=6
19021       IF (SHINF .GT. SHSUP) GOTO 888
19022 C
19023       IF (IPRO.EQ.91) THEN
19024         IF (.NOT.CHARGD) THEN
19025           SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
19026           SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
19027         ELSE
19028           SHAT = EXP(HWRUNI(0,LOG(SHINF),LOG(SHSUP)))
19029           SHJAC = SHAT*(LOG(SHSUP/SHINF))
19030         ENDIF
19031       ELSE
19032         EMW2=EMW**2
19033         IF (SHINF.GT.EMW2+10*GAMW*EMW) THEN
19034           SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
19035           SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
19036         ELSEIF (SHSUP.LT.EMW2-10*EMW*GAMW) THEN
19037           SHAT = HWRUNI(0,SHINF,SHSUP)
19038           SHJAC = SHSUP-SHINF
19039         ELSE
19040           TMIN=ATAN((SHINF-EMW2)/(GAMW*EMW))
19041           TMAX=ATAN((SHSUP-EMW2)/(GAMW*EMW))
19042           SHAT = GAMW*EMW*TAN(HWRUNI(0,TMIN,TMAX))+EMW2
19043           SHJAC=((SHAT-EMW2)**2+(GAMW*EMW)**2)/(GAMW*EMW)*(TMAX-TMIN)
19044         ENDIF
19045       ENDIF
19046       DETDSH = ONE/SMA/Y
19047       SHJAC=SHJAC*DETDSH
19048       RSHAT = SQRT (SHAT)
19049 C--- z generation
19050       ZMIN = 10E10
19051       ZMAX = -ONE
19052       IF (.NOT.CHARGD) THEN
19053         DO I=1,18
19054           Q1CM(I) = ZERO
19055           ZMIF(I) = ZERO
19056           ZMAF(I) = ZERO
19057         ENDDO
19058         DO 150 I=IMIN,IMAX
19059           IF (INCLUD(I)) THEN
19060             Q1CM(I) = HWUPCM( RSHAT, MFIN1(I), MFIN2(I) )
19061             IF (Q1CM(I) .LT. PTMIN) THEN
19062               ZMAF(I)=-ONE
19063               GOTO 150
19064             ENDIF
19065             CTHLIM = SQRT(ONE - (PTMIN / Q1CM(I))**2)
19066             GAMMA2 = SHAT + MFIN1(I)**2 - MFIN2(I)**2
19067             LAMBDA = (SHAT-MFIN1(I)**2-MFIN2(I)**2)**2 -
19068      +                4.D0*MFIN1(I)**2*MFIN2(I)**2
19069             ZMIF(I) = (GAMMA2 - SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
19070             ZMIF(I) = MAX(ZMIF(I),ZERO)
19071             ZMAF(I) = (GAMMA2 + SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
19072             ZMAF(I) = MIN(ZMAF(I),ONE)
19073             ZMIN = MIN( ZMIN, ZMIF(I) )
19074             ZMAX = MAX( ZMAX, ZMAF(I) )
19075           ENDIF
19076  150    CONTINUE
19077         IF (IFL.EQ.164) ZMAX=MIN(ZMAX,ZJMAX)
19078       ELSE
19079         Q1 = HWUPCM(RSHAT,MF1,MF2)
19080         DEBUG=7
19081         IF (Q1.LT.PTMIN) GOTO 888
19082         CTHLIM = SQRT(ONE-(PTMIN/Q1)**2)
19083         GAMMA2 = SHAT+MF1**2-MF2**2
19084         LAMBDA = (SHAT-MF1**2-MF2**2)**2-4.D0*MF1**2*MF2**2
19085         ZMIN = (GAMMA2-SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
19086         ZMIN = MAX(ZMIN,1D-6)
19087         ZMAX = (GAMMA2+SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
19088         ZMAX = MIN(ZMAX,ONE-1D-6)
19089       ENDIF
19090       DEBUG=8
19091       IF (ZMIN .GT. ZMAX) GOTO 888
19092       ZLMIN = LOG(ZMIN/(ONE-ZMIN))
19093       ZINT = LOG(ZMAX/(ONE-ZMAX)) - LOG(ZMIN/(ONE-ZMIN))
19094       ZL = ZLMIN+HWRGEN(0)*ZINT
19095       Z = EXP(ZL)/(ONE+EXP(ZL))
19096       ZJAC = Z*(ONE-Z)*ZINT
19097 C
19098       DEBUG=9
19099       IF ((Y.LT.YMIN.OR.Y.GT.YMAX).OR.(Q2.LT.Q2INF.OR.Q2.GT.Q2SUP).OR.
19100      +   (SHAT.LT.SHINF.OR.SHAT.GT.SHSUP).OR.(Z.LT.ZMIN.OR.Z.GT.ZMAX))
19101      +     GOTO 888
19102 C---Phi generation
19103       PHI = HWRUNI(0,ZERO,2*PIFAC)
19104       PHIJAC = 2 * PIFAC
19105       IF (IFL.EQ.164) PHIJAC=ONE
19106 C
19107       AJACOB = YJAC * Q2JAC * SHJAC * ZJAC * PHIJAC
19108 C
19109       IF (IQK.NE.0.OR.IPRO.EQ.5) GOTO 999
19110 C---contributing subprocesses: filling of logical vector INSIDE
19111       DO I=1,18
19112         INSIDE(I)=.FALSE.
19113         Q2MAF(I)=ZERO
19114         EMMAWF(I)=ZERO
19115       ENDDO
19116       DO 200 I=IMIN,IMAX
19117       IF (INCLUD(I)) THEN
19118       IF ( Y.LT.YMIF(I) ) GOTO 200
19119 C
19120       Q2MAF(I) = MP**2 + SMA*Y - WMIF(I)**2
19121       Q2MAF(I) = MIN( Q2MAF(I), Q2MAX)
19122       IF (Q2INF .GT. Q2MAF(I)) GOTO 200
19123       IF (Q2.LT.Q2INF .OR. Q2.GT.Q2MAF(I)) GOTO 200
19124 C
19125       EMMAWF(I) = SQRT(W2) - MREMIF(I)
19126       EMMAWF(I) = MIN( EMMAWF(I), EMLMAX )
19127 C
19128       IF (EMMIF(I) .GT. EMMAWF(I)) GOTO 200
19129       IF (SHAT.LT.EMMIF(I)**2.OR.SHAT.GT.EMMAWF(I)**2) GOTO 200
19130 C
19131       IF (ZMIF(I) .GT. ZMAF(I)) GOTO 200
19132       IF (Z.LT.ZMIF(I) .OR. Z.GT.ZMAF(I)) GOTO 200
19133       INSIDE(I)=.TRUE.
19134       ENDIF
19135  200  CONTINUE
19136  999  RETURN
19137  888  EVWGT=ZERO
19138 C---UNCOMMENT THIS LINE TO GET A DEBUGGING WARNING FOR NO PHASE-SPACE
19139 C      CALL HWWARN('HWHBRN',DEBUG)
19140       IFGO = .TRUE.
19141       END
19142 CDECK  ID>, HWHBSG.
19143 *CMZ :-        -03/07/95  19.02.12  by  Giovanni Abbiendi
19144 *-- Author :    Giovanni Abbiendi & Luca Stanco
19145 C----------------------------------------------------------------------
19146       SUBROUTINE HWHBSG
19147 C----------------------------------------------------------------------
19148 C     Returns differential cross section DSIGMA in (Y,Q2,ETA,Z,PHI)
19149 C     Scale for structure functions and alpha_s selected by BGSHAT
19150 C----------------------------------------------------------------------
19151       INCLUDE 'herwig65.inc'
19152       DOUBLE PRECISION HWUALF,HWUAEM,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,
19153      & ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
19154      & SFUN(13),ALPHA,LDSIG,DLQ(7),SG,XG,MF1,MF2,MSUM,MDIF,MPRO,FFUN,
19155      & GFUN,H43,H41,H11,H12,H14,H16,H21,H22,G11,G12,G1A,G1B,G21,G22,G3,
19156      & GC,A11,A12,A44,ALPHAS,PDENS,AFACT,BFACT,CFACT,DFACT,GAMMA,S,T,U,
19157      & MREMIN,POL,CCOL,ETA
19158       INTEGER LEP
19159       INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,IHAD,ILEPT,IQ,IS
19160       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
19161       EXTERNAL HWUALF,HWUAEM
19162       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
19163      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
19164      & IPROO,CHARGD,INCLUD,INSIDE
19165 C
19166       IHAD=2
19167       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
19168 C---set masses
19169       IF (CHARGD) THEN
19170         MREMIN=MP
19171         IF (LEP.EQ.1) THEN
19172           MF1=RMASS(IFLAVD)
19173           MF2=RMASS(IFLAVU)
19174         ELSE
19175           MF1=RMASS(IFLAVU)
19176           MF2=RMASS(IFLAVD)
19177         ENDIF
19178       ELSE
19179         IS=IFL
19180         IF (IFL.EQ.164) IS=IQK
19181         MREMIN = MREMIF(IS)
19182         MF1 = MFIN1(IS)
19183         MF2 = MFIN2(IS)
19184       ENDIF
19185 C---choose subprocess scale
19186       IF (BGSHAT) THEN
19187         EMSCA = RSHAT
19188       ELSE
19189         S=SHAT+Q2
19190         IF (IFL.GE.7.AND.IFL.LE.18) S=SHAT+Q2-MF1**2
19191         T=-S*Z
19192         U=-S-T
19193         IF (IFL.GE.7.AND.IFL.LE.18) U=-S-T-2*MF1**2
19194         EMSCA = SQRT(TWO*S*T*U/(S**2+T**2+U**2))
19195         IF (IFL.EQ.164) EMSCA=SQRT(-U)
19196       ENDIF
19197       ALPHAS = HWUALF(1,EMSCA)
19198       IF (ALPHAS.GE.ONE.OR.ALPHAS.LE.ZERO) THEN
19199         CALL HWWARN('HWHBSG',51)
19200         GOTO 888
19201       ENDIF
19202 C---structure functions
19203       ETA = (SHAT+Q2)/SMA/Y
19204       IF (ETA.GT.ONE) ETA=ONE
19205       CALL HWSFUN (ETA,EMSCA,IDHW(IHAD),NSTRU,SFUN,2)
19206       XG = Q2/(SHAT + Q2)
19207       SG = ETA*SMA
19208       IF (SG.LE.(RSHAT+ML)**2.OR.SG.GE.(RS-MREMIN)**2) GOTO 888
19209 C
19210       IF (IFL.EQ.164) GOTO 200
19211 C
19212 C---Electroweak couplings
19213       ALPHA=HWUAEM(-Q2)
19214       IF (CHARGD) THEN
19215         POL = PPOLN(3) - EPOLN(3)
19216         DLQ(1)=.0625*VCKM(IFLAVU/2,(IFLAVD+1)/2)/SWEIN**2 *
19217      +         Q2**2/((Q2+RMASS(198)**2)**2+(RMASS(198)*GAMW)**2) *
19218      +         (ONE + POL)
19219         DLQ(2)=ZERO
19220         DLQ(3)=DLQ(1)
19221       ELSE
19222         IQ=MOD(IFL-1,6)+1
19223         ILEPT=MOD(IDHW(1)-121,6)+11
19224         CALL HWUCFF(ILEPT,IQ,-Q2,DLQ(1))
19225       ENDIF
19226 C
19227       IF (IFL.LE.6) THEN
19228 C---For Boson-Gluon Fusion
19229         PDENS = SFUN(13)/ETA
19230         CCOL = HALF
19231         MSUM = (MF1**2 + MF2**2) / (Y*SG)
19232         MDIF = (MF1**2 - MF2**2) / (Y*SG)
19233         MPRO = MF1*MF2 / (Y*SG)
19234 C
19235         FFUN = (1.D0-XG)*Z*(1.D0-Z) + (MDIF*(2.D0*Z-1.D0)-MSUM)/2.D0
19236         GFUN = (1.D0-XG)*(1.D0-Z) + XG*Z + MDIF
19237         IF ( FFUN .LT. ZERO ) FFUN = ZERO
19238         H43 = (8.D0*(2.D0*Z**2*XG-Z**2-2.D0*Z*XG+2.D0*Z*MDIF+Z-MDIF
19239      &         -MSUM)) / (Z*(1.D0-Z))**2
19240 C
19241         H41 = (8.D0*(Z**2-Z*XG+Z*MDIF-MDIF-MSUM)) / (Z**2*(1.D0-Z))
19242 C
19243         H11 = (4.D0*(2.D0*Z**4-4.D0*Z**3+2.D0*Z**2*MSUM*XG
19244      &         -2.D0*Z**2*MSUM+2.D0*Z**2*XG**2-2.D0*Z**2*XG+3.D0*Z**2
19245      &         +2.D0*Z*MDIF*MSUM+2.D0*Z*MDIF*XG-2.D0*Z*MSUM*XG
19246      &         +2.D0*Z*MSUM-2.D0*Z*XG**2+2.D0*Z*XG-Z-MDIF*MSUM-MDIF*XG
19247      &         -MSUM**2-MSUM*XG)) / (Z*(1.D0-Z))**2
19248 C
19249         H12 = (16.D0*(-Z*MDIF+Z*XG+MDIF+MSUM))/(Z**2*(1.D0-Z))
19250 C
19251         H14 = (16.D0*(-2.D0*Z**2*XG-2.D0*Z*MDIF+2.D0*Z*XG+MDIF+MSUM))
19252      &        / (Z*(1.D0-Z))**2
19253 C
19254         H16 = (32.D0*(Z*MDIF-Z*XG-MDIF-MSUM)) / (Z**2*(1.D0-Z))
19255 C
19256         H21 = (8.D0*MPRO*(-2.D0*Z**2*XG+2.D0*Z**2-2.D0*Z*MDIF+2.D0*Z*XG
19257      +         -2.D0*Z+MDIF+MSUM)) / (Z*(1.D0-Z))**2
19258 C
19259         H22 = (-32.D0*MPRO) / (Z*(1.D0-Z))
19260 C
19261         G11 = -2.D0*H11 + FFUN*H14
19262         G12 = 2.D0*XG*FFUN*H14 + H12 + GFUN * ( H16+GFUN*H14 )
19263         G1A = SQRT( XG*FFUN ) * ( H16 + 2.D0*GFUN*H14 )
19264         G1B = FFUN*H14
19265         G21 = -2.D0*H21
19266         G22 = H22
19267         G3  = H41 - GFUN*H43
19268         GC  = SQRT( XG*FFUN ) * (-2.D0*XG*H43 )
19269       ELSE
19270 C---for QCD Compton, massless matrix element
19271         PDENS = SFUN(IFL-6)/ETA
19272         CCOL = CFFAC
19273         FFUN = XG*(ONE-XG)*Z*(ONE-Z)
19274         GFUN = (ONE-XG)*(ONE-Z)+XG*Z
19275         G11 = 8.D0*((Z**2+XG**2)/(ONE-XG)/(ONE-Z)+TWO*(XG*Z+ONE))
19276         G12 = 64.D0*XG**2*Z+TWO*XG*G11
19277         G1A = 32.D0*XG*GFUN*SQRT(FFUN)/((ONE-XG)*(ONE-Z))
19278         G1B = 16.D0*XG*Z
19279         G3  = -16.D0*(ONE-XG)*(ONE-Z)+G11
19280         GC  = -16.D0*XG*SQRT(FFUN)*(ONE-Z-XG)/((ONE-XG)*(ONE-Z))
19281         G21 = ZERO
19282         G22 = ZERO
19283       ENDIF
19284 C
19285       A11 = XG * Y**2 * G11  +  (1.D0-Y) * G12
19286      &      - (2.D0-Y) * SQRT( 1.D0-Y ) * G1A  *  COS( PHI )
19287      &      + 2.D0 * XG * (1.D0-Y) * G1B  *  COS( 2.D0*PHI )
19288 C
19289       A12 = XG * Y**2 * G21  +  (1.D0-Y) * G22
19290 C
19291       A44 = XG * Y * (2.D0-Y) * G3
19292      &      - 2.D0 * Y * SQRT( 1.D0-Y ) * GC  *  COS( PHI )
19293 C
19294       IF ( Y*Q2**2 .LT. 1D-38 ) THEN
19295 C---prevent numerical uncertainties in DSIGMA computation
19296         DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL/(16.D0*PIFAC)
19297      &           *(DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
19298         IF ( DSIGMA .LE. ZERO ) GOTO 888
19299         LDSIG = LOG (DSIGMA) - LOG (Y) - 2.D0 * LOG (Q2)
19300         DSIGMA = EXP (LDSIG)
19301       ELSE
19302         DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL
19303      &         * (DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
19304      &         / (16.D0*PIFAC*Y*Q2**2)
19305       ENDIF
19306       IF (DSIGMA.LT.ZERO) GOTO 888
19307       RETURN
19308 C
19309   200 CONTINUE
19310 C--- J/psi production
19311       ALPHA = HWUAEM(-Q2)
19312       GAMMA = 4.8D-6
19313       PDENS = SFUN(13)/ETA
19314       AFACT = (8.D0*PIFAC*ALPHAS**2*RMASS(164)**3*GAMMA)/(3.D0*ALPHA)
19315       BFACT = ONE/(Y*SG*Z**2*((Z-ONE)*Y*SG-RMASS(164)**2)**2)
19316       CFACT = (RMASS(164)**2-Z*Y*SG)**2/(Y*SG*(ONE-XG)**2*
19317      &        ((ONE-XG)*Y*SG-RMASS(164)**2)**2*
19318      &        ((Z-ONE)*Y*SG-RMASS(164)**2)**2)
19319       DFACT = ((Z-ONE)*Y*SG)**2/(Y*SG*(ONE-XG)**2*
19320      &          ((ONE-XG)*Y*SG-RMASS(164)**2)**2*(Z*Y*SG)**2)
19321       DSIGMA = GEV2NB*ALPHA/(TWO*PIFAC)*AFACT*(BFACT+CFACT+DFACT)*PDENS
19322       IF (DSIGMA.LT.ZERO ) GOTO 888
19323       RETURN
19324  888  DSIGMA=ZERO
19325       END
19326 CDECK  ID>, HWHDIS.
19327 *CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
19328 *-- Author :    Giovanni Abbiendi & Luca Stanco
19329 C----------------------------------------------------------------------
19330       SUBROUTINE HWHDIS
19331 C----------------------------------------------------------------------
19332 C     DEEP INELASTIC LEPTON-HADRON SCATTERING: MEAN EVWGT = SIGMA IN NB
19333 C----------------------------------------------------------------------
19334       INCLUDE 'herwig65.inc'
19335       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,SAMP,SIG,Q2,
19336      & XBJ,Y,W,S,MLEP,MHAD,MLSCAT,YMIN,YMAX,XXMAX,Q2JAC,XXJAC,
19337      & JACOBI,A1,A2,A3,B1,B2,PCM,PCMEP,PCMLW,PCMEQ,PCMLQ,COSPHI,PA,
19338      & EQ,PZQ,SHAT,PROP,DLEFT,DRGHT,DUP,DWN,FACT,EFACT,OMY2,YPLUS,
19339      & YMNUS,SIGMA,AF(7,12),SMA,Q2SUP,HWUAEM,DCHRG,DNEUT
19340       INTEGER I,IQK,IQKIN,IQKOUT,IDSCAT,IHAD,ILEPT,LEP
19341       LOGICAL CHARGD
19342       EXTERNAL HWRGEN,HWRUNI,HWUPCM
19343       SAVE MLEP,MHAD,S,SMA,PCM,MLSCAT,A1,A2,A3,B1,B2,DLEFT,DRGHT,Q2,
19344      & AF,XBJ,Y,YPLUS,YMNUS,OMY2,FACT,EFACT,SIGMA,IDSCAT,CHARGD,
19345      & ILEPT,DCHRG,DNEUT,LEP
19346       IQK=MOD(IPROC,10)
19347       IHAD=2
19348       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
19349       IF (FSTWGT.OR.IHAD.NE.2) THEN
19350 C---INITIALISE PROCESS (MUST BE DONE EVERY TIME IF S VARIES)
19351 C---LEPTON AND HADRON MASSES, INVARIANT MASS, MOMENTUM IN C.M. FRAME
19352         MLEP=PHEP(5,1)
19353         MHAD=PHEP(5,IHAD)
19354         S=PHEP(5,3)**2
19355         SMA=S-MLEP**2-MHAD**2
19356         PCM=HWUPCM(SQRT(S),MLEP,MHAD)
19357 C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
19358         IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
19359           LEP=1
19360         ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
19361           LEP=-1
19362         ELSE
19363           CALL HWWARN('HWHDIS',500)
19364         ENDIF
19365         DCHRG=FLOAT(MOD(IDHW(1)  ,2))
19366         DNEUT=FLOAT(MOD(IDHW(1)+1,2))
19367         ILEPT=MOD(IDHW(1)-121,6)+11
19368 C---DLEFT,DRIGHT = 1,0 for leptons; = 0,1 for anti-leptons
19369         DLEFT=MAX(LEP,0)
19370         DRGHT=MAX(-LEP,0)
19371         CHARGD=MOD(IPROC,100)/10.EQ.1
19372 C---Evaluate constant factor in cross section and
19373 C   find and store scattered lepton identity
19374         IF (CHARGD) THEN
19375           IF ((EPOLN(3)-PPOLN(3)).EQ.ONE) THEN
19376              WRITE(6,5)
19377              CALL HWWARN('HWHDIS',501)
19378   5          FORMAT(1X,'WARNING: Cross-section is zero for the',
19379      &                ' specified lepton helicity')
19380           ENDIF
19381           FACT=GEV2NB*(ONE-(EPOLN(3)-PPOLN(3)))*.25D0*PIFAC
19382      &        /(SWEIN*RMASS(198)**2)**2
19383           IDSCAT=IDHW(1)+NINT(DCHRG-DNEUT)
19384         ELSE
19385           FACT=GEV2NB*TWO*PIFAC
19386           IDSCAT=IDHW(1)
19387         ENDIF
19388         MLSCAT=RMASS(IDSCAT)
19389 C---PARAMETERS USED FOR THE WEIGHT GENERATION IN NEUTRAL CURRENT
19390 C   PROCESSES. ASSUME D(SIGMA)/D(Q**2) GOES LIKE A1+A2/Q**2+A3/Q**4
19391 C   AND D(SIGMA)/D(X) LIKE B1+B2/X
19392         A1=0.5
19393         A2=0.5
19394         A3=1.
19395         B1=0.1
19396         B2=1.
19397       ENDIF
19398       IF (GENEV) THEN
19399 C---GENERATE EVENT (KINEMATICAL VARIABLES AND STRUCTURE FUNCTION
19400 C   ALREADY FOUND)
19401         PRAN=SIGMA*HWRGEN(0)
19402         IF (CHARGD) THEN
19403 C---CHARGED CURRENT PROCESS
19404           IF (IQK.EQ.0) THEN
19405 C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
19406             PROB=ZERO
19407             DO 10 I=1,6
19408             DUP=MOD(I+1,2)
19409             DWN=MOD(I  ,2)
19410             PROB=PROB+EFACT*
19411      &          ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
19412      &           +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I  ,1)
19413      &          +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
19414      &           +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
19415             IF (PROB.GE.PRAN) GOTO 20
19416    10       CONTINUE
19417             I=6
19418    20       IQK=I
19419           ENDIF
19420           DUP=MOD(IQK+1,2)
19421           DWN=MOD(IQK  ,2)
19422           IQKIN=IQK
19423           IF ((LEP.EQ. 1.AND.MOD(IQK+IDHW(1),2).EQ.0)
19424      &    .OR.(LEP.EQ.-1.AND.MOD(IQK+IDHW(1),2).EQ.1)) IQKIN=IQK+6
19425 C---FIND FLAVOUR OF THE OUTGOING QUARK
19426           PRAN=HWRGEN(0)
19427           PROB=ZERO
19428           IF (DUP.EQ.ONE) THEN
19429             DO 30 I=1,3
19430             PROB=PROB+VCKM(IQK/2,I)
19431             IF (PROB.GE.PRAN) GOTO 40
19432    30       CONTINUE
19433             I=3
19434    40       IQKOUT=2*I-1
19435             IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
19436           ELSE
19437             DO 50 I=1,3
19438             PROB=PROB+VCKM(I,(IQK+1)/2)
19439             IF (PROB.GE.PRAN) GOTO 60
19440    50       CONTINUE
19441             I=3
19442    60       IQKOUT=2*I
19443             IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
19444           ENDIF
19445         ELSE
19446 C---NEUTRAL CURRENT PROCESS
19447           IF (IQK.NE.0) THEN
19448             IQKIN=IQK
19449             PROB=EFACT*(AF(1,IQK)*YPLUS*DISF(IQK,1)+
19450      &       FLOAT(LEP)*AF(3,IQK)*YMNUS*DISF(IQK,1))
19451             IF (PROB.LT.PRAN) IQKIN=IQK+6
19452           ELSE
19453 C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
19454             PROB=ZERO
19455             SIG=ONE
19456             DO 70 I=1,12
19457             IF (I.GT.6) SIG=-ONE
19458             PROB=PROB+EFACT*(AF(1,I)*YPLUS*DISF(I,1)+
19459      &        FLOAT(LEP)*SIG*AF(3,I)*YMNUS*DISF(I,1))
19460             IF (PROB.GE.PRAN) GOTO 80
19461    70       CONTINUE
19462             I=12
19463    80       IQKIN=I
19464           ENDIF
19465           IQKOUT=IQKIN
19466         ENDIF
19467         IDN(1)=IDHW(1)
19468         IDN(2)=IQKIN
19469         IDN(3)=IDSCAT
19470         IDN(4)=IQKOUT
19471         ICO(1)=1
19472         ICO(2)=4
19473         ICO(3)=3
19474         ICO(4)=2
19475         XX(1)=1.
19476         XX(2)=XBJ
19477 C---CHECK PHASE SPACE WITH THE SELECTED FLAVOUR. IF OUTSIDE THE
19478 C   EVENT IS KILLED.
19479         PA=XBJ*(PHEP(4,IHAD)+ABS(PHEP(3,IHAD)))
19480         EQ=HALF*(PA+RMASS(IDN(2))**2/PA)
19481         PZQ=-(PA-EQ)
19482         SHAT=(PHEP(4,1)+EQ)**2-(PHEP(3,1)+PZQ)**2
19483         PCMEQ=HWUPCM(SQRT(SHAT),MLEP,RMASS(IDN(2)))
19484         PCMLQ=HWUPCM(SQRT(SHAT),MLSCAT,RMASS(IDN(4)))
19485         IF (PCMLQ.LT.ZERO) THEN
19486           CALL HWWARN('HWHDIS',101)
19487           GOTO 999
19488         ELSEIF (PCMLQ.EQ.ZERO) THEN
19489           COSTH=ZERO
19490         ELSE
19491           COSTH=(TWO*SQRT(PCMEQ**2+MLEP**2)*SQRT(PCMLQ**2+MLSCAT**2)
19492      &         -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEQ*PCMLQ)
19493         ENDIF
19494         IF (ABS(COSTH).GT.ONE) THEN
19495           CALL HWWARN('HWHDIS',102)
19496           GOTO 999
19497         ENDIF
19498         IDCMF=15
19499         CALL HWETWO(.TRUE.,.TRUE.)
19500       ELSE
19501         EVWGT=ZERO
19502         IF (CHARGD) THEN
19503 C---CHOOSE X,Y (CC PROCESS)
19504           YMIN=MAX(YBMIN,Q2MIN/SMA)
19505           YMAX=MIN(YBMAX,ONE)
19506           IF (YMIN.GT.YMAX) GOTO 999
19507           Y=HWRUNI(0,YMIN,YMAX)
19508           XXMIN=Q2MIN/S/Y
19509           XXMAX=MIN(Q2MAX/SMA/Y,ONE)
19510           IF (XXMIN.GT.XXMAX) GOTO 999
19511           XBJ=HWRUNI(0,XXMIN,XXMAX)
19512           Q2=XBJ*Y*(S-MLEP**2-MHAD**2)
19513           JACOBI=(YMAX-YMIN)*(XXMAX-XXMIN)*(S-MLEP**2-MHAD**2)*XBJ
19514         ELSE
19515 C---CHOOSE X,Q**2 (NC PROCESS)
19516           Q2SUP=MIN(Q2MAX,SMA*YBMAX)
19517           IF (Q2MIN.GT.Q2SUP) GOTO 999
19518           SAMP=(A1+A2+A3)*HWRGEN(0)
19519           IF (SAMP.LE.A1) THEN
19520             Q2=HWRUNI(0,Q2MIN,Q2SUP)
19521           ELSEIF (SAMP.LE.(A1+A2)) THEN
19522             Q2=EXP(HWRUNI(0,LOG(Q2MIN),LOG(Q2SUP)))
19523           ELSE
19524             Q2=-ONE/HWRUNI(0,-ONE/Q2MIN,-ONE/Q2SUP)
19525           ENDIF
19526           Q2JAC=(A1+A2+A3)/
19527      &      (A1/(Q2SUP-Q2MIN)
19528      &      +A2/LOG(Q2SUP/Q2MIN)/Q2
19529      &      +A3*Q2MIN*Q2SUP/(Q2SUP-Q2MIN)/Q2**2)
19530           XXMIN=Q2/SMA/YBMAX
19531           XXMAX=ONE
19532           IF (YBMIN.GT.ZERO) XXMAX=MIN(Q2/SMA/YBMIN,ONE)
19533           IF (XXMIN.GT.XXMAX) GOTO 999
19534           SAMP=(B1+B2)*HWRGEN(0)
19535           IF (SAMP.LE.B1) THEN
19536             XBJ=HWRUNI(0,XXMIN,XXMAX)
19537           ELSE
19538             XBJ=EXP(HWRUNI(0,LOG(XXMIN),LOG(XXMAX)))
19539           ENDIF
19540           XXJAC=(B1+B2)/(B1/(XXMAX-XXMIN)+B2/LOG(XXMAX/XXMIN)/XBJ)
19541           Y=Q2/(S-MLEP**2-MHAD**2)/XBJ
19542           JACOBI=Q2JAC*XXJAC
19543         ENDIF
19544 C---CHECK IF THE GENERATED POINT IS INSIDE PHASE SPACE. IF NOT
19545 C   RETURN WITH WEIGHT EQUAL TO ZERO.
19546         W=SQRT(MHAD**2+Q2*(ONE-XBJ)/XBJ)
19547         IF (W.LT.WHMIN) RETURN
19548         PCMEP=PCM
19549         PCMLW=HWUPCM(SQRT(S),MLSCAT,W)
19550         IF (PCMLW.LT.ZERO) THEN
19551           EVWGT=ZERO
19552           RETURN
19553         ELSEIF (PCMLW.EQ.ZERO) THEN
19554           COSPHI=ZERO
19555         ELSE
19556           COSPHI=
19557      &    (TWO*SQRT(PCMEP**2+MLEP**2)*SQRT(PCMLW**2+MLSCAT**2)
19558      &    -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEP*PCMLW)
19559         ENDIF
19560         IF (ABS(COSPHI).GT.ONE) THEN
19561           EVWGT=ZERO
19562           RETURN
19563         ENDIF
19564 C---SET SCALE EQUAL Q. EVALUATE STRUCTURE FUNCTIONS.
19565         EMSCA=SQRT(Q2)
19566         CALL HWSFUN(XBJ,EMSCA,IDHW(IHAD),NSTRU,DISF,2)
19567 C---SWITCH OFF ANY FLAVOURS THAT ARE BELOW THRESHOLD
19568         DO 90 I=1,12
19569  90     IF (W.LT.2*RMASS(I)) DISF(I,1)=0
19570 C---EVALUATE DIFFERENTIAL CROSS SECTION
19571         IF (CHARGD) THEN
19572           PROP=RMASS(198)**2/(Q2+RMASS(198)**2)
19573           EFACT=FACT*(HWUAEM(-Q2)*PROP)**2/XBJ
19574           OMY2=(ONE-Y)**2
19575           SIGMA=ZERO
19576           DO 100 I=1,6
19577           DUP=MOD(I+1,2)
19578           DWN=MOD(I  ,2)
19579           IF (IQK.NE.0.AND.IQK.NE.I) GOTO 100
19580           SIGMA=SIGMA+EFACT*
19581      &        ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
19582      &         +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I  ,1)
19583      &        +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
19584      &         +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
19585   100     CONTINUE
19586         ELSE
19587           EFACT=FACT/XBJ*(HWUAEM(-Q2)/Q2)**2
19588           YPLUS=ONE+(ONE-Y)**2
19589           YMNUS=ONE-(ONE-Y)**2
19590           DO 110 I=1,6
19591           CALL HWUCFF(ILEPT,I,-Q2,AF(1,I))
19592           AF(1,I+6)=AF(1,I)
19593           AF(3,I+6)=AF(3,I)
19594   110     CONTINUE
19595           SIGMA=ZERO
19596           DO 200 I=1,6
19597           IF (IQK.NE.0.AND.IQK.NE.I) GOTO 200
19598           SIGMA=SIGMA+EFACT*(AF(1,I)*YPLUS*(DISF(I,1)+DISF(I+6,1))+
19599      &            FLOAT(LEP)*AF(3,I)*YMNUS*(DISF(I,1)-DISF(I+6,1)))
19600   200     CONTINUE
19601         ENDIF
19602 C---FIND WEIGHT: DIFFERENTIAL CROSS SECTION TIME THE JACOBIAN FACTOR
19603         EVWGT=SIGMA*JACOBI
19604         IF (EVWGT.LT.ZERO) EVWGT=ZERO
19605       ENDIF
19606  999  RETURN
19607       END
19608 CDECK  ID>, HWHDYP.
19609 *CMZ :-        -18/05/99  12.41.07  by  Mike Seymour
19610 *-- Author :    Bryan Webber, Ian Knowles and Mike Seymour
19611 C-----------------------------------------------------------------------
19612       SUBROUTINE HWHDYP
19613 C-----------------------------------------------------------------------
19614 C     Drell-Yan Production of fermion pairs via photon, Z0 & (if ZPRIME)
19615 C     Z' exchange. Lepton universality is assumed for photon and Z, and
19616 C     for Z' if no lepton flavour is specified.
19617 C     MEAN EVWGT = SIGMA IN NB
19618 C
19619 C     Modified 16/01/01 by BRW to implement Peter Richardson's
19620 C     fix for bug in lepton mass effects on branching ratio
19621 C-----------------------------------------------------------------------
19622       INCLUDE 'herwig65.inc'
19623       DOUBLE PRECISION HWRGEN,HWRUNI,HWUAEM,EPS,C1,C2,C3,EMSQZ,EMGMZ,
19624      & EMSQZP,EMGMZP,CQF(7,6,16),QPOW,RPOW,A01,A1,A02,A2,A03,A3,CRAN,
19625      & EMJ1,EMJ2,EMJ3,EMJAC,FACT,QSQ,HCS,FACTR,RCS,EXTRA,PMAX,PTHETA
19626       INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,IADD(2,2),ID1,ID2,
19627      & ID3,ID4,JF
19628       EXTERNAL HWRGEN,HWRUNI,HWUAEM
19629       SAVE HCS,JQMN,JQMX,JLMN,JLMX,C1,C2,C3,QPOW,RPOW,EMSQZ,EMGMZ,
19630      & A1,A01,A2,A02,A3,A03,EMSQZP,EMGMZP,FACT,CQF
19631       PARAMETER (EPS=1.D-9)
19632       SAVE IADD
19633       DATA IADD/0,6,6,0/
19634       IF (GENEV) THEN
19635         RCS=HCS*HWRGEN(0)
19636       ELSE
19637         IF (FSTWGT) THEN
19638 C Set limits for which particles to include
19639           JLMN=1
19640           JLMX=0
19641           JQMN=1
19642           JQMX=0
19643           IMODE=MOD(IPROC,100)
19644           IF (IMODE.EQ.0) THEN
19645             JQMN=1
19646             JQMX=6
19647           ELSEIF (IMODE.LE.10) THEN
19648             JQMN=IMODE
19649             JQMX=IMODE
19650           ELSEIF (IMODE.EQ.50) THEN
19651             JLMN=11
19652             JLMX=16
19653           ELSEIF (IMODE.GE.50.AND.IMODE.LE.60) THEN
19654             JLMN=IMODE-40
19655             JLMX=IMODE-40
19656           ELSEIF (IMODE.EQ.99) THEN
19657             JQMN=1
19658             JQMX=6
19659             JLMN=11
19660             JLMX=16
19661           ELSE
19662             CALL HWWARN('HWHDYP',500)
19663           ENDIF
19664 C Set up parameters for importance sampling:
19665 C sum of power law and two Breit-Wigners (relative weights C1,C2,C3)
19666           C1=ONE
19667           C2=ONE
19668           C3=ZERO
19669           IF (ZPRIME) C3=ONE
19670           IF (EMPOW.EQ.ONE) CALL HWWARN('HWHDYP',501)
19671           IF (C2.EQ.ZERO) CALL HWWARN('HWHDYP',502)
19672           IF (C3.EQ.ZERO.AND.ZPRIME) CALL HWWARN('HWHDYP',503)
19673           QPOW=-EMPOW+1
19674           RPOW=1/QPOW
19675           EMSQZ=RMASS(200)**2
19676           EMGMZ=RMASS(200)*GAMZ
19677           A01=EMMIN**QPOW
19678           A1=(EMMAX**QPOW-A01)/C1
19679           A02=ATAN((EMMIN**2-EMSQZ)/EMGMZ)
19680           A2=(ATAN((EMMAX**2-EMSQZ)/EMGMZ)-A02)/C2
19681           IF (C3.GT.ZERO) THEN
19682             EMSQZP=RMASS(202)**2
19683             EMGMZP=RMASS(202)*GAMZP
19684             A03=ATAN((EMMIN**2-EMSQZP)/EMGMZP)
19685             A3=(ATAN((EMMAX**2-EMSQZP)/EMGMZP)-A03)/C3
19686           ENDIF
19687         ENDIF
19688         EVWGT=0.
19689 C Select a mass for the produced pair
19690         CRAN=(C1+C2+C3)*HWRGEN(1)
19691         IF (CRAN.LT.C1) THEN
19692 C Use power law
19693           EMSCA=(A01+A1*CRAN)**RPOW
19694           QSQ=EMSCA**2
19695         ELSEIF (CRAN.LT.C1+C2) THEN
19696 C Use Z Breit-Wigner
19697           CRAN=CRAN-C1
19698           QSQ=EMSQZ+EMGMZ*TAN(A02+A2*CRAN)
19699           EMSCA=SQRT(QSQ)
19700         ELSE
19701 C Use Z' Breit-Wigner
19702           CRAN=CRAN-C1-C2
19703           QSQ=EMSQZP+EMGMZP*TAN(A03+A3*CRAN)
19704           EMSCA=SQRT(QSQ)
19705         ENDIF
19706         EMJ1=EMSCA**EMPOW/(1-EMPOW)*A1
19707         EMJ2=((QSQ-EMSQZ)**2+EMGMZ**2)/(2*EMSCA*EMGMZ)*A2
19708         IF (C3.GT.ZERO) THEN
19709           EMJ3=((QSQ-EMSQZP)**2+EMGMZP**2)/(2*EMSCA*EMGMZP)*A3
19710           EMJAC=(C1+C2+C3)/(1/EMJ1+1/EMJ2+1/EMJ3)
19711         ELSE
19712           EMJAC=(C1+C2)/(1/EMJ1+1/EMJ2)
19713         ENDIF
19714 C Select initial momentum fractions
19715         XXMIN=QSQ/PHEP(5,3)**2
19716         XLMIN=LOG(XXMIN)
19717         CALL HWSGEN(.TRUE.)
19718         FACT=-GEV2NB*HWUAEM(QSQ)**2*PIFAC*8*EMJAC*XLMIN
19719      $       /(3*NCOLO*EMSCA**3)
19720 C Store cross-section coefficients
19721         DO 50 IQ=1,6
19722         DO 30 JQ=JQMN,JQMX
19723         IF (EMSCA.GT.2.*RMASS(JQ)) THEN
19724           CALL HWUCFF(IQ,JQ,QSQ,CQF(1,IQ,JQ))
19725         ELSE
19726           CALL HWVZRO(7,CQF(1,IQ,JQ))
19727         ENDIF
19728   30    CONTINUE
19729         DO 40 JL=JLMN,JLMX
19730         IF (EMSCA.GT.2.*RMASS(JL+110)) THEN
19731           CALL HWUCFF(IQ,JL,QSQ,CQF(1,IQ,JL))
19732         ELSE
19733           CALL HWVZRO(7,CQF(1,IQ,JL))
19734         ENDIF
19735   40    CONTINUE
19736   50    CONTINUE
19737       ENDIF
19738 C
19739       HCS=0.
19740       DO 90 I=1,2
19741 C I=1 quark first, I=2 anti-quark first
19742       DO 80 IQ=1,6
19743       ID1=IQ+IADD(1,I)
19744       ID2=IQ+IADD(2,I)
19745       IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
19746       FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
19747 C Quark final states
19748       DO 60 JQ=JQMN,JQMX
19749       ID3=JQ
19750       ID4=JQ+6
19751       IF (IQ.EQ.JQ) THEN
19752         HCS=HCS+FACTR*(CQF(1,IQ,JQ)*FLOAT(NCOLO)+3*HALF*QFCH(IQ)**4)
19753         IF (GENEV.AND.HCS.GT.RCS) THEN
19754           CALL HWHQCP(ID3,ID4,2143,50)
19755           GOTO 99
19756         ENDIF
19757       ELSE
19758         HCS=HCS+FACTR*CQF(1,IQ,JQ)*FLOAT(NCOLO)
19759         IF (GENEV.AND.HCS.GT.RCS) THEN
19760           CALL HWHQCP(ID3,ID4,2143,50)
19761           GOTO 99
19762         ENDIF
19763       ENDIF
19764   60  CONTINUE
19765 C Lepton final states
19766       DO 70 JL=JLMN,JLMX
19767       ID3=110+JL
19768       ID4=ID3+6
19769       HCS=HCS+FACTR*CQF(1,IQ,JL)
19770       IF (GENEV.AND.HCS.GT.RCS) THEN
19771         CALL HWHQCP(ID3,ID4,2134,50)
19772         GOTO 99
19773       ENDIF
19774   70  CONTINUE
19775   80  CONTINUE
19776   90  CONTINUE
19777       EVWGT=HCS
19778       RETURN
19779 C Generate event
19780   99  IDN(1)=ID1
19781       IDN(2)=ID2
19782       IDCMF=200
19783       IF (ID3.LE.6) THEN
19784         JF=JQ
19785       ELSE
19786         JF=JL
19787       ENDIF
19788 C Select polar angle from distribution:
19789 C CQF(1,IQ,JF)*(ONE+COSTH**2)+CQF(3,IQ,JF)*COSTH+EXTRA*(ONE+COSTH)
19790       IF (ID1.EQ.ID3.OR.ID2.EQ.ID3) THEN
19791         EXTRA=TWO*QFCH(ID3)**4/NCOLO
19792       ELSE
19793         EXTRA=0
19794       ENDIF
19795       PMAX=2.*(CQF(1,IQ,JF)+EXTRA)+ABS(CQF(3,IQ,JF))
19796   100 COSTH=HWRUNI(0,-ONE,ONE)
19797       PTHETA=CQF(1,IQ,JF)*(ONE+COSTH**2)+TWO*CQF(3,IQ,JF)*COSTH
19798      &      +EXTRA*(ONE+COSTH)
19799       IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 100
19800       IF (ID1.GT.ID2) COSTH=-COSTH
19801       IDCMF=200
19802       CALL HWETWO(.TRUE.,.TRUE.)
19803       END
19804 CDECK  ID>, HWHDYQ.
19805 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
19806 *-- Author :    Peter Richardson
19807 C-----------------------------------------------------------------------
19808       SUBROUTINE HWHDYQ(FSTCLL,HCS,IFLOW,IDP,ORD,IQ,MASS)
19809 C-----------------------------------------------------------------------
19810 C     Drell-Yan production with a q qbar pair
19811 C-----------------------------------------------------------------------
19812       INCLUDE 'herwig65.inc'
19813       INTEGER I,MAP(12),ORD,IFL,IDP(6),IFLOW,QCFL(2,2),GCFL(2),IDZ,IQ
19814       DOUBLE PRECISION HCS,RCS,MQ(2,5),HWRGEN,G(12,2),DIST(2),MG(2)
19815       LOGICAL FSTCLL,MASS
19816       EXTERNAL HWRGEN
19817       COMMON/HWHZBC/G
19818       SAVE MQ,MG
19819       SAVE MAP,QCFL,GCFL
19820       DATA MAP/1,2,3,4,5,6,11,12,13,14,15,16/
19821       DATA QCFL/2413,3142,4123,2341/
19822       DATA GCFL/2413,4123/
19823       IF(GENEV) THEN
19824         RCS = HCS*HWRGEN(1)
19825       ELSE
19826 C--to the initalisation
19827         IF(FSTCLL) THEN
19828 C--G(I,1) is the right charge and G(I,2) is the left charge
19829           DO I=1,12
19830             G(I,1) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
19831             G(I,2) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
19832           ENDDO
19833           FSTCLL = .FALSE.
19834         ENDIF
19835 C--identify the Z decay product
19836         IDZ = IDP(5)
19837         IF(IDZ.GT.6) IDZ = IDZ-114
19838 C--calculate the matrix elements
19839         IF(MASS) THEN
19840 C--massive case
19841           CALL HWH2MQ(IQ,IDZ,MG,MQ)
19842         ELSE
19843 C--massless case
19844           CALL HWH2M0(IQ,IDZ,MG,MQ)
19845         ENDIF
19846       ENDIF
19847 C--multiply the matrix elements by the PDF's to obtain the cross section
19848       HCS = ZERO
19849       IDP(3) = IQ
19850       IDP(4) = IQ+6
19851 C--first the qqbar initial states
19852       DO I=1,5
19853         IDP(1) = I
19854         IDP(2) = IDP(1)+6
19855         DIST(1) = DISF(IDP(1),1)*DISF(IDP(2),2)
19856         DIST(2) = DISF(IDP(1),2)*DISF(IDP(2),1)
19857         DO ORD=1,2
19858           DO IFL=1,2
19859             IFLOW = QCFL(IFL,ORD)
19860             HCS = HCS+DIST(ORD)*MQ(IFL,IDP(1))/36.0D0
19861             IF(GENEV.AND.HCS.GT.RCS) RETURN
19862           ENDDO
19863         ENDDO
19864       ENDDO
19865 C--then the gluon gluon inital state
19866       IDP(1) = 13
19867       IDP(2) = 13
19868       DIST(1) = DISF(IDP(1),1)*DISF(IDP(1),2)
19869       DO IFL=1,2
19870         IFLOW = GCFL(IFL)
19871         HCS = HCS+DIST(1)*MG(IFL)/256.0D0
19872         IF(GENEV.AND.HCS.GT.RCS) RETURN
19873       ENDDO
19874       END
19875 CDECK  ID>, HWHEGG.
19876 *CMZ :-        -19/03/92  10.13.56  by  Mike Seymour
19877 *-- Author :    Mike Seymour
19878 C-----------------------------------------------------------------------
19879       SUBROUTINE HWHEGG
19880 C----------------------------------------------------------------------
19881 C     HARD PROCESS: EE --> EEGAMGAM --> EEFFBAR/WW
19882 C     MEAN EVENT WEIGHT = CROSS-SECTION IN NB
19883 C     AFTER CUTS ON PT AND MASS OF CENTRE-OF-MASS SYSTEM
19884 C     AND COS(THETA) IN CENTRE-OF-MASS SYSTEM
19885 C     AND TIMES BRANCHING FRACTION IF WW
19886 C-----------------------------------------------------------------------
19887       INCLUDE 'herwig65.inc'
19888       DOUBLE PRECISION HWRGEN,HWULDO,EMSQ,BETA,S,T,U,TMIN,TMAX,TRAT,
19889      & DSDT,PROB,X,Z(2),ZMIN,ZMAX,PCMIN,PCMAX,PCFAC,PLOGMI,PLOGMA,PTCMF,
19890      & Q,PC,BLOG,EMCMIN,EMCMAX,EMLMIN,EMLMAX,WGT(6),RWGT,CV,CA,BR,QT(2),
19891      & QX(2),QY(2),PX,PY,ROOTS,DOT,A,B,C,SHAT,PCF(2),PCM(2),PCMAC,ZZ(2),
19892      & COLFAC
19893       INTEGER I,IGAM,ID,IDL,ID1,ID2,IHEP,JHEP,NADD,NTRY,NQ,JGAM
19894       LOGICAL HWRLOG
19895       EXTERNAL HWRGEN,HWULDO,HWRLOG
19896       SAVE S,BETA,X,ID,NQ,WGT,EMLMIN,EMLMAX,PCFAC,PLOGMA,PLOGMI,SHAT,
19897      &  PCF,PCM,Z,PCMAC,NADD
19898       IF (IERROR.NE.0) RETURN
19899 C---INITIALIZE LOCAL COPIES OF EMMIN,EMMAX
19900       IF (FSTWGT) THEN
19901         EMLMIN=EMMIN
19902         EMLMAX=EMMAX
19903       ENDIF
19904       IF (.NOT.GENEV) THEN
19905 C---CHOOSE Z1,Z2 AND CALCULATE SUB-PROCESS CROSS-SECTION
19906         EVWGT=0
19907 C-----FIND FINAL STATE PARTICLES
19908         IHPRO=MOD(IPROC,100)
19909         IF (IHPRO.EQ.0) THEN
19910           ID=1
19911           NQ=6
19912           COLFAC=FLOAT(NCOLO)
19913           NADD=6
19914         ELSEIF (IHPRO.LE.6) THEN
19915           ID=IHPRO
19916           NQ=1
19917           COLFAC=FLOAT(NCOLO)
19918           NADD=6
19919           Q=QFCH(ID)
19920         ELSEIF (IHPRO.LE.9) THEN
19921           ID=119+2*(IHPRO-6)
19922           NQ=1
19923           COLFAC=1.
19924           NADD=6
19925           Q=QFCH(ID-110)
19926         ELSEIF (IHPRO.LE.10) THEN
19927           ID=198
19928           NQ=1
19929           NADD=1
19930         ELSE
19931           CALL HWWARN('HWHEGG',200)
19932         ENDIF
19933 C-----SPLIT ELECTRONS TO PHOTONS
19934         NHEP=3
19935         GAMWT=1
19936         S=2*HWULDO(PHEP(1,1),PHEP(1,2))
19937         ROOTS=SQRT(S)
19938         EMCMIN=MAX(EMLMIN,MAX(2*RMASS(ID),PTMIN))
19939         EMCMAX=MIN(EMLMAX,ROOTS)
19940         IF (EMCMIN.GT.EMCMAX) RETURN
19941         ZMIN=EMCMIN**2/S
19942         ZMAX=1-PHEP(5,1)/PHEP(4,1)
19943         IF (ZMIN.GT.ZMAX) RETURN
19944         CALL HWEGAM(1,ZMIN,ZMAX,.TRUE.)
19945         Z(1)=PHEP(4,NHEP-1)/PHEP(4,1)
19946         ZMIN=EMCMIN**2/(Z(1)*S)
19947         ZMAX=MIN(EMCMAX**2/(Z(1)*S), ONE-PHEP(5,2)/PHEP(4,2))
19948         IF (ZMIN.GT.ZMAX) RETURN
19949         CALL HWEGAM(2,ZMIN,ZMAX,.TRUE.)
19950         Z(2)=PHEP(4,NHEP-1)/PHEP(4,2)
19951         EMSCA=PHEP(5,3)
19952         SHAT=EMSCA**2
19953 C-----REMOVE LOG TERMS FROM WEIGHT, CALCULATE NEW ONES FROM PT LIMITS
19954         GAMWT=GAMWT/(0.5*LOG((1-Z(1))*S/(Z(1)*PHEP(5,1)**2))
19955      &              *0.5*LOG((1-Z(2))*Z(1)*S/(Z(2)*PHEP(5,2)**2)))
19956         PCF(1)=Z(1)*PHEP(5,1)
19957         PCF(2)=Z(2)*PHEP(5,2)
19958         PCFAC=SQRT(PCF(1)*PCF(2))
19959         PCM(1)=(1-Z(1))*PHEP(4,1)
19960         PCM(2)=(1-Z(2))*PHEP(4,2)
19961         PCMAC=SQRT(PCM(1)*PCM(2))
19962         PCMIN=MAX(PTMIN,MAX(PCF(1),PCF(2)))
19963         PCMAX=MIN( MIN(PTMAX,PHEP(5,3)) , MIN(PCM(1),PCM(2)) )
19964         IF (PCMIN.GT.PCMAX) RETURN
19965         PLOGMI=(LOG(PCMIN/PCFAC))**2
19966         PLOGMA=(LOG(PCMAX/PCFAC))**2
19967         GAMWT=GAMWT*(PLOGMA-PLOGMI)
19968 C-----CALCULATE CROSS-SECTION
19969         DO 10 IDL=1,NQ
19970           WGT(IDL)=EVWGT
19971           IF (IHPRO.EQ.0) THEN
19972             ID=IDL
19973             Q=QFCH(ID)
19974           ENDIF
19975           EMSQ=RMASS(ID)**2
19976           X=4*EMSQ/SHAT
19977           IF (X.GT.ONE) GOTO 10
19978           BETA=SQRT(1-X)
19979           BLOG=LOG((1+BETA*CTMAX)/(1-BETA*CTMAX))/BETA
19980           IF (IHPRO.LE.9) THEN
19981             EVWGT=EVWGT+GEV2NB*4*PIFAC*COLFAC*Q**4*ALPHEM**2*BETA
19982      &           /SHAT * GAMWT * ( (1+X-0.5*X**2)*BLOG
19983      &                     - CTMAX*(1+X**2/(CTMAX**2*(X-1)+1)) )
19984             WGT(IDL)=EVWGT
19985           ELSE
19986             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
19987             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
19988             EVWGT=EVWGT + GEV2NB*6*PIFAC*ALPHEM**2*BETA/SHAT*BR
19989      &        * GAMWT * (-(  X-0.5*X**2)*BLOG
19990      &                     + CTMAX*(1+(X**2+16/3.)/(CTMAX**2*(X-1)+1)) )
19991           ENDIF
19992  10     CONTINUE
19993 C-----GAMWT MUST BE RESET TO ONE, SINCE IT IS REAPPLIED LATER!
19994         GAMWT=ONE
19995       ELSE
19996 C---GENERATE EVENT
19997 C-----CHOOSE PT OF THE CMF
19998         PTCMF=PCFAC*EXP(SQRT(HWRGEN(0)*(PLOGMA-PLOGMI)+PLOGMI))
19999 C-----CHOOSE WHICH PHOTON USUALLY HAS SMALLER PT
20000         NTRY=0
20001  20     IGAM=1
20002         IF (LOG(PCM(1)/PCF(1)).LT.HWRGEN(1)*2*LOG(PCMAC/PCFAC)) IGAM=2
20003         JGAM=3-IGAM
20004 C-----CHOOSE ITS PT
20005  30     NTRY=NTRY+1
20006         IF (NTRY.GT.NBTRY) THEN
20007           CALL HWWARN('HWHEGG',100)
20008           GOTO 999
20009         ENDIF
20010         QT(IGAM)=(PCM(IGAM)/PCF(IGAM))**HWRGEN(2)
20011         PROB=(QT(IGAM)**2/(QT(IGAM)**2+1))**2
20012         QT(IGAM)=QT(IGAM)*PCF(IGAM)
20013         IF (HWRLOG(1-PROB)) GOTO 30
20014 C-----CHOOSE ITS DIRECTION
20015         CALL HWRAZM(QT(IGAM),QX(IGAM),QY(IGAM))
20016 C-----CALCULATE THE OTHER PHOTON'S PT
20017         QX(JGAM)=PTCMF-QX(IGAM)
20018         QY(JGAM)=     -QY(IGAM)
20019         QT(JGAM)=SQRT(QX(JGAM)**2+QY(JGAM)**2)
20020         IF (QT(JGAM).LT.PCF(JGAM).OR.QT(JGAM).GT.PCM(JGAM)) GOTO 20
20021 C-----APPLY A RANDOM ROTATION AROUND THE BEAM AXIS
20022         CALL HWRAZM(ONE,PX,PY)
20023         IF (PX.EQ.ZERO) PX=1D-20
20024         QX(1)=(QX(1)*PX   -QY(1)*PY)
20025         QY(1)=(QY(1)      +QX(1)*PY)/PX
20026         QX(2)=(QX(2)*PX   -QY(2)*PY)
20027         QY(2)=(QY(2)      +QX(2)*PY)/PX
20028 C-----RECONSTRUCT MOMENTA
20029         IF (QT(IGAM).GT.QT(JGAM)) THEN
20030           IGAM=3-IGAM
20031           JGAM=3-JGAM
20032         ENDIF
20033         DOT=-Z(JGAM)*S+SHAT+2*(QX(1)*QX(2)+QY(1)*QY(2))
20034 C-------SOLVE QUADRATIC IN Z(IGAM) TO FIND ELECTRON ENERGIES
20035         A=S*(S*Z(JGAM)+QT(JGAM)**2)
20036         B=S*DOT*(1+Z(JGAM))
20037         C=DOT**2+S*QT(IGAM)**2*(1-Z(JGAM))**2-4*QT(IGAM)**2*QT(JGAM)**2
20038         IF (B**2.LT.4*A*C) GOTO 20
20039         ZZ(IGAM)=(-B+SQRT(B**2-4*A*C))/(2*A)
20040         IF (ZZ(IGAM).LT.ZERO .OR. ZZ(IGAM).GT.ONE-Z(IGAM)) GOTO 20
20041         ZZ(JGAM)=1-Z(JGAM)
20042 C-------REJECT AGAINST PHOTON DISTRIBUTION FUNCTION
20043         PROB=((1+ZZ(IGAM)**2)/(1-ZZ(IGAM)))/((1+(1-Z(IGAM))**2)/Z(IGAM))
20044      &      *((1+ZZ(JGAM)**2)/(1-ZZ(JGAM)))/((1+(1-Z(JGAM))**2)/Z(JGAM))
20045         IF (HWRLOG(1-PROB)) GOTO 20
20046 C-------RECONSTRUCT ALL OTHER VARIABLES
20047         DO 40 I=1,2
20048           IGAM=2*I+3
20049           PHEP(1,IGAM)=QX(I)
20050           PHEP(2,IGAM)=QY(I)
20051           PHEP(4,IGAM)=ZZ(I)*PHEP(4,I)
20052           PHEP(5,IGAM)=RMASS(IDHW(IGAM))
20053 C---------IF MOMENTUM CANNOT BE CONSERVED TRY AGAIN
20054           IF (PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-QT(I)**2 .LT. 0) GOTO 20
20055           PHEP(3,IGAM)=SIGN(SQRT(PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-
20056      &      QT(I)**2),PHEP(3,IGAM))
20057           CALL HWVDIF(4,PHEP(1,I),PHEP(1,IGAM),PHEP(1,IGAM-1))
20058           CALL HWUMAS(PHEP(1,IGAM-1))
20059  40     CONTINUE
20060 C-----TIDY UP EVENT RECORD
20061         NHEP=NHEP+1
20062         IDHW(NHEP)=IDHW(3)
20063         IDHEP(NHEP)=IDHEP(3)
20064         ISTHEP(NHEP)=110
20065         CALL HWVSUM(4,PHEP(1,4),PHEP(1,6),PHEP(1,NHEP))
20066         CALL HWVSUM(4,PHEP(1,1),PHEP(1,2),PHEP(1,3))
20067         CALL HWUMAS(PHEP(1,NHEP))
20068         CALL HWUMAS(PHEP(1,3))
20069         JMOHEP(1,NHEP)=4
20070         JMOHEP(2,NHEP)=6
20071         JMOHEP(1,3)=0
20072         JMOHEP(2,3)=0
20073 C-----CHOOSE FINAL STATE QUARK
20074         IF (IHPRO.EQ.0) THEN
20075           RWGT=HWRGEN(2)*EVWGT
20076           ID=1
20077           DO 50 IDL=1,NQ
20078             IF (RWGT.GT.WGT(IDL)) ID=IDL+1
20079  50       CONTINUE
20080           EMSQ=RMASS(ID)**2
20081           X=4*EMSQ/SHAT
20082           BETA=SQRT(1-X)
20083         ENDIF
20084 C-----CHOOSE T (WHERE T = MANDELSTAM_T - EMSQ)
20085         TMIN=-SHAT/2
20086         TMAX=-SHAT/2*(1-BETA*CTMAX)
20087         TRAT=TMAX/TMIN
20088         NTRY=0
20089         IF (IHPRO.LE.9) THEN
20090 C-------FOR FFBAR, CHOOSE T ACCORDING TO -SHAT/T
20091  60       NTRY=NTRY+1
20092           IF (NTRY.GT.NBTRY) THEN
20093             CALL HWWARN('HWHEGG',101)
20094             GOTO 999
20095           ENDIF
20096           T=TRAT**HWRGEN(3)*TMIN
20097           U=-T-SHAT
20098 C-------REWEIGHT TO CORRECT DISTRIBUTION
20099           DSDT=(T*U-2*EMSQ*(T+2*EMSQ))/T**2
20100      &        +( 2*EMSQ*(SHAT-4*EMSQ))/(T*U)
20101      &        +(T*U-2*EMSQ*(U+2*EMSQ))/U**2
20102           PROB=-DSDT*T/SHAT / (1 + 2*X - 2*X**2)
20103           IF (HWRLOG(1-PROB)) GOTO 60
20104         ELSE
20105 C-------FOR WW, CHOOSE T ACCORDING TO (SHAT/T)**2
20106  70       NTRY=NTRY+1
20107           IF (NTRY.GT.NBTRY) THEN
20108             CALL HWWARN('HWHEGG',102)
20109             GOTO 999
20110           ENDIF
20111           T=TMAX/(1-(1-TRAT)*HWRGEN(4))
20112           U=-T-SHAT
20113 C-------REWEIGHT TO CORRECT DISTRIBUTION
20114           DSDT=( 3*(T*U)**2 - SHAT*T*U*(4*SHAT+6*EMSQ)
20115      &      + SHAT**2*(2*SHAT**2+6*EMSQ**2) ) / (T*U)**2
20116           PROB=DSDT*(T/SHAT)**2 / (4.75 - 1.5*X + 1.5*X**2)
20117           IF (HWRLOG(1-PROB)) GOTO 70
20118         ENDIF
20119 C-----SYMMETRIZE IN T,U
20120         IF (HWRLOG(HALF)) T=U
20121 C-----FILL EVENT RECORD
20122         COSTH=(1+2*T/SHAT)/BETA
20123         PC=0.5*BETA*PHEP(5,NHEP)
20124         PHEP(5,NHEP+1)=RMASS(ID)
20125         PHEP(5,NHEP+2)=RMASS(ID)
20126         CALL HWDTWO(PHEP(1,NHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
20127      &              PC,COSTH,.TRUE.)
20128         DO 80 I=1,2
20129           IHEP=NHEP+I
20130           JHEP=NHEP+3-I
20131           ISTHEP(IHEP)=190
20132           IF (IHPRO.LE.6) ISTHEP(IHEP)=112+I
20133           IDHW(IHEP)=ID+NADD*(I-1)
20134           IDHEP(IHEP)=IDPDG(IDHW(IHEP))
20135           JDAHEP(I,NHEP)=IHEP
20136           JMOHEP(1,IHEP)=NHEP
20137           JMOHEP(2,IHEP)=JHEP
20138           JDAHEP(2,IHEP)=JHEP
20139           IF (IHPRO.EQ.10) THEN
20140             RHOHEP(1,IHEP)=0.3333
20141             RHOHEP(2,IHEP)=0.3333
20142             RHOHEP(3,IHEP)=0.3333
20143           ENDIF
20144  80     CONTINUE
20145         NHEP=NHEP+2
20146       ENDIF
20147  999  RETURN
20148       END
20149 CDECK  ID>, HWHEGW.
20150 *CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
20151 *-- Author :    Mike Seymour
20152 C-----------------------------------------------------------------------
20153       SUBROUTINE HWHEGW
20154 C----------------------------------------------------------------------
20155 C     W + GAMMA --> FF'BAR :  MEAN EVWGT = CROSS SECTION IN NANOBARN
20156 C     BASED ON BOSON GLUON FUSION OF ABBIENDI AND STANCO
20157 C-----------------------------------------------------------------------
20158       INCLUDE 'herwig65.inc'
20159       DOUBLE PRECISION HWRGEN,GMASS,EV(3),RV,Y,Q2,SHAT,Z,PHI,AJACOB,
20160      & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT
20161       INTEGER LEP
20162       INTEGER LEPFIN,ID1,ID2,I,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO
20163       LOGICAL CHARGD,INCLUD(18),INSIDE(18),IFGO
20164       EXTERNAL HWRGEN
20165       SAVE LEPFIN,ID1,ID2
20166       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
20167      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
20168      & IPROO,CHARGD,INCLUD,INSIDE
20169       IQK=MOD(IPROC,10)
20170       CHARGD=.TRUE.
20171       IF(GENEV) THEN
20172 C
20173         IDHW(4)=IDHW(1)
20174         IDHW(5)=59
20175         IDHW(6)=15
20176         IDHW(7)=LEPFIN
20177         IDHW(8)=ID1
20178         IDHW(9)=ID2
20179         DO 1 I=4,9
20180     1   IDHEP(I)=IDPDG(IDHW(I))
20181 C
20182         IFLAVD=ID1
20183         IFLAVU=ID2-6
20184 C
20185         ISTHEP(4)=111
20186         ISTHEP(5)=112
20187         ISTHEP(6)=110
20188         ISTHEP(7)=113
20189         ISTHEP(8)=114
20190         ISTHEP(9)=114
20191 C
20192         JMOHEP(1,4)=6
20193         JMOHEP(2,4)=7
20194         JMOHEP(1,5)=6
20195         JMOHEP(2,5)=5
20196         JMOHEP(1,6)=4
20197         JMOHEP(2,6)=5
20198         JMOHEP(1,7)=6
20199         JMOHEP(2,7)=4
20200         JMOHEP(1,8)=6
20201         JMOHEP(2,8)=9
20202         JMOHEP(1,9)=6
20203         JMOHEP(2,9)=8
20204         JDAHEP(1,4)=0
20205         JDAHEP(2,4)=7
20206         JDAHEP(1,5)=0
20207         JDAHEP(2,5)=5
20208         JDAHEP(1,6)=7
20209         JDAHEP(2,6)=9
20210         JDAHEP(1,7)=0
20211         JDAHEP(2,7)=4
20212         JDAHEP(1,8)=0
20213         JDAHEP(2,8)=9
20214         JDAHEP(1,9)=0
20215         JDAHEP(2,9)=8
20216 C---COMPUTATION OF MOMENTA IN LABORATORY FRAME OF REFERENCE
20217 C---Persuade HWHBKI that the gluon is actually a photon...
20218         GMASS=RMASS(13)
20219         RMASS(13)=0
20220         CALL HWHBKI
20221         RMASS(13)=GMASS
20222 C---put the other outgoing lepton in as well
20223         IDHW(10)=IDHW(2)
20224         IDHEP(10)=IDPDG(IDHW(10))
20225         ISTHEP(10)=1
20226         JMOHEP(1,10)=2
20227         JMOHEP(2,10)=0
20228         JDAHEP(1,10)=0
20229         JDAHEP(2,10)=0
20230         JDAHEP(1,2)=5
20231         JDAHEP(2,2)=10
20232         CALL HWVDIF(4,PHEP(1,2),PHEP(1,5),PHEP(1,10))
20233         CALL HWUMAS(PHEP(1,10))
20234         NHEP=10
20235 C
20236 C---if antilepton was first, do charge conjugation
20237         IF (LEP.EQ.-1) THEN
20238           DO 27 I=7,9
20239             IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
20240               IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
20241               IDHEP(I)=-IDHEP(I)
20242             ENDIF
20243  27       CONTINUE
20244         ENDIF
20245 C
20246 C---half the time, do charge conjugation and parity flip
20247         IF (HWRGEN(0).GT.HALF) THEN
20248           DO 2 I=4,10
20249             IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
20250               IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
20251               IDHEP(I)=-IDHEP(I)
20252             ENDIF
20253             PHEP(1,I)=-PHEP(1,I)
20254             PHEP(2,I)=-PHEP(2,I)
20255             PHEP(3,I)=-PHEP(3,I)
20256  2        CONTINUE
20257           JMOHEP(1,10)=3-JMOHEP(1,10)
20258         ENDIF
20259 C
20260       ELSE
20261 C
20262         EVWGT=ZERO
20263 C---LEP = 1 IF TRACK 1 IS A LEPTON, -1 FOR ANTILEPTON
20264         LEP=0
20265         IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
20266           LEP=1
20267         ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
20268           LEP=-1
20269         ENDIF
20270         IF (LEP.EQ.0) CALL HWWARN('HWHEGW',500)
20271 C---program only works if beam and target are charge conjugates
20272         IF (LEP*(IDHW(2)-IDHW(1)).NE.6) CALL HWWARN('HWHEGW',501)
20273 C---program only works for equal energy beams colliding
20274         IF (PHEP(3,3).NE.ZERO) CALL HWWARN('HWHEGW',503)
20275 C
20276 C---FINAL STATE IS ALWAYS SET UP AS IF PARTICLE IS BEFORE ANTI-PARTICLE
20277 C   AND THEN INVERTED IF NECESSARY
20278         LEPFIN = MIN(IDHW(1),IDHW(2))+1
20279         IF (IQK.LE.2) THEN
20280           IFLAVU=2
20281           IFLAVD=1
20282           ID1  = 1
20283           ID2  = 8
20284         ELSEIF (IQK.LE.4) THEN
20285           IFLAVU=4
20286           IFLAVD=3
20287           ID1  = 3
20288           ID2  =10
20289         ELSEIF (IQK.LE.6) THEN
20290           IFLAVU=6
20291           IFLAVD=5
20292           ID1  = 5
20293           ID2  =12
20294         ELSEIF (IQK.EQ.7) THEN
20295           IFLAVU=122
20296           IFLAVD=121
20297           ID1  = 121
20298           ID2  = 128
20299 C---INTERFERENCE TERMS IN EE -> EE NUE NUEB  NEGLECTED: SIGMA UNRELIABLE
20300           IF (FSTWGT) CALL HWWARN('HWHEGW',1)
20301         ELSEIF (IQK.EQ.8) THEN
20302           IFLAVU=124
20303           IFLAVD=123
20304           ID1  = 123
20305           ID2  = 130
20306         ELSEIF (IQK.EQ.9) THEN
20307           IFLAVU=126
20308           IFLAVD=125
20309           ID1  = 125
20310           ID2  = 132
20311         ELSE
20312           CALL HWWARN('HWHEGW',504)
20313         ENDIF
20314         IF (IQK.GT.0) THEN
20315           IF (IQK.LE.6) IQK=0
20316           CALL HWHBRN(IFGO)
20317           IF(IFGO) GOTO 999
20318           CALL HWHEGX
20319           EVWGT = 2 * DSIGMA * AJACOB
20320           IF (EVWGT.LT.ZERO) EVWGT=ZERO
20321         ELSE
20322 C---SUM OVER QUARK FLAVOURS
20323           CALL HWHBRN(IFGO)
20324           IF(IFGO) GOTO 999
20325           DO 3 I=1,3
20326             IF (SHAT.GT.(RMASS(IFLAVD)+RMASS(IFLAVU))**2) THEN
20327               CALL HWHEGX
20328               EV(I) = 2 * DSIGMA * AJACOB
20329               IF (EV(I).LT.ZERO) EV(I)=ZERO
20330             ELSE
20331               EV(I)=ZERO
20332             ENDIF
20333             EVWGT=EVWGT+EV(I)
20334             EV(I)=EVWGT
20335             IFLAVU=IFLAVU+2
20336             IFLAVD=IFLAVD+2
20337  3        CONTINUE
20338 C---CHOOSE QUARK FLAVOUR
20339           RV=EV(3)*HWRGEN(1)
20340           IF (RV.LT.EV(1)) THEN
20341             ID1 = 1
20342             ID2 = 8
20343           ELSEIF (RV.LT.EV(2)) THEN
20344             ID1 = 3
20345             ID2 =10
20346           ELSE
20347             ID1 = 5
20348             ID2 =12
20349           ENDIF
20350         ENDIF
20351       ENDIF
20352  999  RETURN
20353       END
20354 CDECK  ID>, HWHEGX.
20355 *CMZ :-        -17/07/92  16.42.56  by  Mike Seymour
20356 *-- Author :    Mike Seymour
20357 C-----------------------------------------------------------------------
20358       SUBROUTINE HWHEGX
20359 C-----------------------------------------------------------------------
20360 C     COMPUTES DIFFERENTIAL CROSS SECTION DSIGMA IN (Y,Q2,ETA,Z,PHI)
20361 C-----------------------------------------------------------------------
20362       INCLUDE 'herwig65.inc'
20363       DOUBLE PRECISION TMAX,TMIN,A1,A2,B1,B2,I0,I1,I2,I3,I4,I5,MUSQ,
20364      & MDSQ,ETA,Q1,COSTHE,S,G,T,U,C1,C2,D1,D2,F1,F2,COSBET,WPROP,D(4,4),
20365      & C(4,4),QU,QD,QE,QW,PHOTON,EMWSQ,EMSSQ,CFAC,Y,Q2,SHAT,Z,PHI,
20366      & AJACOB,DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,
20367      & RSHAT
20368       INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,J,LEP
20369       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
20370       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
20371      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
20372      & IPROO,CHARGD,INCLUD,INSIDE
20373 C---INPUT VARIABLES
20374       IF (IERROR.NE.0) RETURN
20375       DSIGMA=0
20376       IF (IFLAVU.LE.12) THEN
20377         QU=QFCH(MOD(IFLAVU-1,6)+1)
20378         QD=QFCH(MOD(IFLAVD-1,6)+1)
20379         CFAC=CAFAC
20380       ELSE
20381         QU=QFCH(MOD(IFLAVU-1,6)+11)
20382         QD=QFCH(MOD(IFLAVD-1,6)+11)
20383         CFAC=1
20384       ENDIF
20385       QE=QFCH(11)
20386       QW=+1
20387       EMWSQ=RMASS(198)**2
20388       EMSCA=PHEP(5,3)
20389       EMSSQ=EMSCA**2
20390       MUSQ=RMASS(IFLAVU)**2
20391       MDSQ=RMASS(IFLAVD)**2
20392       ETA=(SHAT+Q2)/EMSSQ/Y
20393       IF (ETA.GT.ONE) RETURN
20394 C---CALCULATE KINEMATIC TERMS
20395       G=0.5*(ETA*EMSSQ*Y-Q2) -0.5*(MUSQ+MDSQ)
20396       S=0.5*ETA*EMSSQ
20397       T=0.5*ETA*EMSSQ*(1-Y)
20398       U=0.5*Q2
20399       C1=0.5*ETA*EMSSQ*Y*Z
20400       C2=0.5*ETA*EMSSQ*Y*(1-Z)
20401       COSBET=(-ETA*EMSSQ*Y+Q2*(2-Y))/(Y*(ETA*EMSSQ-Q2))
20402       IF (SHAT.LE.(RMASS(IFLAVU)+RMASS(IFLAVD))**2) RETURN
20403       Q1=SQRT((SHAT**2+MUSQ**2+MDSQ**2
20404      &  -2*SHAT*MUSQ-2*SHAT*MDSQ-2*MUSQ*MDSQ)/SHAT**2)
20405       COSTHE=(1+(MDSQ-MUSQ)/SHAT-2*Z)/Q1
20406       IF (ABS(COSTHE).GE.ONE .OR. ABS(COSBET).GE.ONE) RETURN
20407       D1=0.25*(ETA*EMSSQ-Q2)*(1+(MDSQ-MUSQ)/SHAT-Q1*
20408      &     (COSTHE*COSBET+SQRT((1-COSTHE**2)*(1-COSBET**2))*COS(PHI)))
20409       D2=S-U-D1
20410       F1=D1+C1-G            -MDSQ
20411       F2=U+T-F1
20412 C---CALCULATE TRACE TERMS
20413       CALL HWVZRO(16,D)
20414       CALL HWVZRO(16,C)
20415       D(1,1)=2*F1*C2*S
20416       D(2,2)=2*C1*D2*T
20417       D(3,3)=-D1*(2*F2*G-D2*(F1+2*U))
20418      &       -D2*F1*(F2+U-D2+F1)
20419      &       +2*F1*F2*U
20420      &       -G*(-2*D1*(F1+F2+U)-F1*(D2+2*U)+2*D2*(U-F2)+2*U*(F2-U+G))
20421       D(4,4)=2*F1*C2*S
20422       D(1,2)=(D1+U-F2)*(D1*F2-F1*D2)-G*(D1*(F2+U)+U*(U-F2-G)+F1*D2)
20423       D(1,3)=D1*F2*(-2*F1+U-F2+D1)
20424      &      +F1*(F2*(D2-2*U)+F1*D2)
20425      &      +G*(-D1*(2*F1+F2+U)-F1*(D2+2*U)+U*(F2-U+G))
20426       D(1,4)=-2*F1*(D1+U)*(F2+G)
20427       D(2,3)=D1*(D2*(F1+2*(U-F2))+F2*(F2-U-D1))
20428      &      +F1*D2**2
20429      &      +G*(D1*(F2+U)+D2*(F1-2*(U-F2))+U*(U-F2-G))
20430       D(2,4)=-D1*F2*(U-F2+D1)
20431      &       -F1*D2*(U-D1-G-F2)
20432      &       -G*(U*(F2-U+G)-D1*(F2+U))
20433       D(3,4)=D1*(F1*(D2+2*F2)+F2*(F2-U-D1))
20434      &      +F1*(2*F2*U-D2*(U+F1))
20435      &      +G*(D1*(2*F1+F2+U)+U*(2*F1-F2+U-G))
20436 C---REGULATE PROPAGATORS
20437       TMAX=EMSSQ-2*G
20438       TMIN=PHEP(5,2)**2
20439       A1=2*C1+MDSQ*(G+U)/G
20440       A2=2*C2+MUSQ*(G+U)/G
20441       B1=(2*U+MUSQ)/(2*G+2*U)
20442       B2=(2*U+MDSQ)/(2*G+2*U)
20443       I0=LOG(TMAX/TMIN)
20444       I1=1/A1*(I0-LOG((A1+B1*TMAX)/(A1+B1*TMIN)))
20445       I2=1/A2*(I0-LOG((A2+B2*TMAX)/(A2+B2*TMIN)))
20446       I3=(B1*I1-B2*I2)/(B1*A2-B2*A1)
20447       I4=1/A1*(I1+1/(A1+B1*TMAX)-1/(A1+B1*TMIN))
20448       I5=1/A2*(I2+1/(A2+B2*TMAX)-1/(A2+B2*TMIN))
20449       WPROP=1/((2*G-EMWSQ)**2+GAMW**2*EMWSQ)
20450 C---CALCULATE COEFFICIENTS
20451       C(1,1)=    QU**2/(2*U+EMWSQ)**2                       *I5
20452       C(2,2)=    QD**2/(2*U+EMWSQ)**2                       *I4
20453       C(3,3)=    QW**2/(2*U+EMWSQ)**2    *WPROP             *I0
20454       C(4,4)=    QE**2/(2*S)**2          *WPROP             *I0
20455       C(1,2)=  2*QU*QD/(2*U+EMWSQ)**2                       *I3
20456       C(1,3)=  2*QW*QU/(2*U+EMWSQ)**2    *WPROP*(2*G-EMWSQ) *I2
20457       C(1,4)=  2*QU*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I2
20458       C(2,3)=  2*QW*QD/(2*U+EMWSQ)**2    *WPROP*(2*G-EMWSQ) *I1
20459       C(2,4)=  2*QD*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I1
20460       C(3,4)=  2*QW*QE/(2*S*(2*U+EMWSQ)) *WPROP             *I0
20461 C---CALCULATE PHOTON STRUCTURE FUNCTION
20462       PHOTON=ALPHEM * (1+(1-ETA)**2) / (2*PIFAC*ETA)
20463 C---SUM ALL TENSOR CONTRIBUTIONS
20464       DO 10 I=1,4
20465       DO 10 J=1,4
20466  10     DSIGMA=DSIGMA + C(I,J)*D(I,J)
20467 C---CALCULATE TOTAL SUMMED AND AVERAGED MATRIX ELEMENT SQUARED
20468       DSIGMA = DSIGMA * 2*CFAC*(4*PIFAC*ALPHEM)**3/SWEIN**2
20469 C---CALCULATE DIFFERENTIAL CROSS-SECTION
20470       DSIGMA = DSIGMA * GEV2NB*PHOTON/(512*PIFAC**4*ETA*EMSSQ)
20471       END
20472 CDECK  ID>, HWHEPA.
20473 *CMZ :-        -12/10/01  10.05.16  by  Peter Richardson
20474 *-- Author :    Bryan Webber and Ian Knowles
20475 C-----------------------------------------------------------------------
20476       SUBROUTINE HWHEPA
20477 C-----------------------------------------------------------------------
20478 C     (Initially polarised) e+e- --> ffbar (f=quark, mu or tau)
20479 C     If IPROC=107: --> gg, distributed as sum of light quarks.
20480 C     If fermion flavour specified mass effects fully included.
20481 C     EVWGT=sig(e+e- --> ffbar) in nb
20482 C-----------------------------------------------------------------------
20483       INCLUDE 'herwig65.inc'
20484       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUAEM,Q2NOW,Q2LST,FACTR,
20485      & VF2,VF,CLF(7),PRAN,PQWT,PMAX,PTHETA,SINTH2,CPHI,SPHI,C2PHI,S2PHI,
20486      & PPHI,SINTH,PCM,PP(5),EWGT
20487       INTEGER ID1,ID2,IDF,IQ,IQ1,I
20488       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUAEM
20489       SAVE Q2LST,FACTR,ID1,ID2,VF2,VF,CLF,EWGT
20490       DATA Q2LST/0.D0/
20491       IF (GENEV) THEN
20492         IF (ID2.EQ.0) THEN
20493 C Choose quark flavour
20494           PRAN=TQWT*HWRGEN(0)
20495           PQWT=0.
20496           DO 10 IQ=1,MAXFL
20497           PQWT=PQWT+CLQ(1,IQ)
20498           IF (PQWT.GT.PRAN) GOTO 11
20499    10     CONTINUE
20500           IQ=MAXFL
20501    11     IQ1=MAPQ(IQ)
20502           DO 20 I=1,7
20503    20     CLF(I)=CLQ(I,IQ)
20504         ELSE
20505           IQ1=ID1
20506         ENDIF
20507 C Label particles, assign outgoing particle masses
20508         IDHW(NHEP+1)=200
20509         IDHEP(NHEP+1)=23
20510         ISTHEP(NHEP+1)=110
20511         IF (ID1.EQ.7) THEN
20512           IDHW(NHEP+2)=13
20513           IDHW(NHEP+3)=13
20514           IDHEP(NHEP+2)=21
20515           IDHEP(NHEP+3)=21
20516           PHEP(5,NHEP+2)=RMASS(13)
20517           PHEP(5,NHEP+3)=RMASS(13)
20518         ELSE
20519           IDHW(NHEP+2)=IQ1
20520           IDHW(NHEP+3)=IQ1+6
20521           IDHEP(NHEP+2)=IDPDG(IQ1)
20522           IDHEP(NHEP+3)=-IDHEP(NHEP+2)
20523           PHEP(5,NHEP+2)=RMASS(IQ1)
20524           PHEP(5,NHEP+3)=RMASS(IQ1)
20525         ENDIF
20526         ISTHEP(NHEP+2)=113
20527         ISTHEP(NHEP+3)=114
20528         JMOHEP(1,NHEP+1)=1
20529         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20530         JMOHEP(2,NHEP+1)=2
20531         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20532         JMOHEP(1,NHEP+2)=NHEP+1
20533         JMOHEP(2,NHEP+2)=NHEP+3
20534         JMOHEP(1,NHEP+3)=NHEP+1
20535         JMOHEP(2,NHEP+3)=NHEP+2
20536         JDAHEP(1,NHEP+1)=NHEP+2
20537         JDAHEP(2,NHEP+1)=NHEP+3
20538         JDAHEP(1,NHEP+2)=0
20539         JDAHEP(2,NHEP+2)=NHEP+3
20540         JDAHEP(1,NHEP+3)=0
20541         JDAHEP(2,NHEP+3)=NHEP+2
20542 C Generate polar and azimuthal angular distributions:
20543 C  CLF(1)*(1+(VF*COSTH)**2)+CLF(2)*(1-VF**2)+CLF(3)*2.*VF*COSTH
20544 C +(VF*SINTH)**2*(CLF(4)*COS(2*PHI-PHI1-PHI2)
20545 C                +CLF(6)*SIN(2*PHI-PHI1-PHI2))
20546         PMAX=CLF(1)*(1.+VF2)+CLF(2)*(1.-VF2)+ABS(CLF(3))*2.*VF
20547   30    COSTH=HWRUNI(0,-ONE, ONE)
20548         PTHETA=CLF(1)*(1.+VF2*COSTH**2)+CLF(2)*(1.-VF2)
20549      &        +CLF(3)*2.*VF*COSTH
20550         IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 30
20551         IF (IDHW(1).GT.IDHW(2)) COSTH=-COSTH
20552         SINTH2=1.-COSTH**2
20553         IF (TPOL) THEN
20554           PMAX=PTHETA+VF2*SINTH2*SQRT(CLF(4)**2+CLF(6)**2)
20555   40      CALL HWRAZM(ONE,CPHI,SPHI)
20556           C2PHI=2.*CPHI**2-1.
20557           S2PHI=2.*CPHI*SPHI
20558           PPHI=PTHETA+(CLF(4)*(C2PHI*COSS+S2PHI*SINS)
20559      &                +CLF(6)*(S2PHI*COSS-C2PHI*SINS))*VF2*SINTH2
20560           IF (PPHI.LT.PMAX*HWRGEN(1)) GOTO 40
20561         ELSE
20562           CALL HWRAZM(ONE,CPHI,SPHI)
20563         ENDIF
20564 C Construct final state 4-mommenta
20565         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20566         PCM=HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20567 C PP is momentum of track NHEP+2 in CoM (track NHEP+1) frame
20568         SINTH=SQRT(SINTH2)
20569         PP(5)=PHEP(5,NHEP+2)
20570         PP(1)=PCM*SINTH*CPHI
20571         PP(2)=PCM*SINTH*SPHI
20572         PP(3)=PCM*COSTH
20573         PP(4)=SQRT(PCM**2+PP(5)**2)
20574         CALL HWULOB(PHEP(1,NHEP+1),PP(1),PHEP(1,NHEP+2))
20575         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
20576 C Set production vertices
20577         CALL HWVZRO(4,VHEP(1,NHEP+2))
20578         CALL HWVEQU(4,VHEP(1,NHEP+2),VHEP(1,NHEP+3))
20579         NHEP=NHEP+3
20580       ELSE
20581         EMSCA=PHEP(5,3)
20582         Q2NOW=EMSCA**2
20583         IF (Q2NOW.NE.Q2LST) THEN
20584 C Calculate coefficients for cross-section
20585           EMSCA=PHEP(5,3)
20586           Q2LST=Q2NOW
20587           FACTR=PIFAC*GEV2NB*HWUAEM(Q2NOW)**2/Q2NOW
20588           ID1=MOD(IPROC,10)
20589           ID2=MOD(ID1,7)
20590           IF (ID2.EQ.0) THEN
20591             CALL HWUEEC(1)
20592             VF2=1.
20593             VF=1.
20594             EWGT=FACTR*FLOAT(NCOLO)*TQWT*4./3.
20595           ELSE
20596             IF (IPROC.LT.150) THEN
20597               IDF=ID1
20598               FACTR=FACTR*FLOAT(NCOLO)
20599             ELSE
20600               ID1=2*ID1+119
20601               IDF=ID1-110
20602             ENDIF
20603             IF (EMSCA.LE.2.*RMASS(ID1)) THEN
20604               EWGT=0.
20605             ELSE
20606               CALL HWUCFF(11,IDF,Q2NOW,CLF(1))
20607               VF2=1.-4.*RMASS(ID1)**2/Q2NOW
20608               VF=SQRT(VF2)
20609               EWGT=FACTR*VF*(CLF(1)*(1.+VF2/3.)+CLF(2)*(1.-VF2))
20610             ENDIF
20611           ENDIF
20612         ENDIF
20613         EVWGT=EWGT
20614       ENDIF
20615       END
20616 CDECK  ID>, HWHEPG.
20617 *CMZ :-        -02/05/91  10.57.27  by  Federico Carminati
20618 *-- Author :    Bryan Webber and Ian Knowles
20619 C-----------------------------------------------------------------------
20620       SUBROUTINE HWHEPG
20621 C-----------------------------------------------------------------------
20622 C     (Initially polarised) e-e+ --> qqbar g with parton thrust < THMAX,
20623 C     equivalent to: maximum parton energy < THMAX*EMSCA/2; or a JADE E0
20624 c     scheme, y_cut=1.-THMAX.
20625 C     If flavour specified mass effects fully included.
20626 C     EVWGT=sig(e^-e^+ --> qqbar g) in nb
20627 C-----------------------------------------------------------------------
20628       INCLUDE 'herwig65.inc'
20629       DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT,Q2NOW,Q2LST,
20630      & PHASP,QGMAX,QGMIN,FACTR,QM2,CLF(7),ORDER,PRAN,PQWT,QQG,QBG,SUM,
20631      & RUT,QQLM,QQLP,QBLM,QBLP,DYN1,DYN2,DYN3,DYN4,DYN5,DYN6,XQ2,X2SUM,
20632      & PVRT(4)
20633       INTEGER ID1,IQ,I,LM,LP,IQ1
20634       LOGICAL MASS
20635       EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT
20636       SAVE Q2NOW,Q2LST,QGMAX,QGMIN,FACTR,ORDER,ID1,MASS,QM2,CLF,LM,LP,
20637      & IQ1,QQG,QBG,SUM
20638       DATA Q2LST/0.D0/
20639       IF (GENEV) THEN
20640 C Label produced partons and calculate gluon spin
20641         IDHW(NHEP+1)=200
20642         IDHW(NHEP+2)=IQ1
20643         IDHW(NHEP+3)=13
20644         IDHW(NHEP+4)=IQ1+6
20645         IDHEP(NHEP+1)=23
20646         IDHEP(NHEP+2)=IQ1
20647         IDHEP(NHEP+3)=21
20648         IDHEP(NHEP+4)=-IQ1
20649         ISTHEP(NHEP+1)=110
20650         ISTHEP(NHEP+2)=113
20651         ISTHEP(NHEP+3)=114
20652         ISTHEP(NHEP+4)=114
20653         JMOHEP(1,NHEP+1)=LM
20654         JMOHEP(2,NHEP+1)=LP
20655         JMOHEP(1,NHEP+2)=NHEP+1
20656         JMOHEP(2,NHEP+2)=NHEP+3
20657         JMOHEP(1,NHEP+3)=NHEP+1
20658         JMOHEP(2,NHEP+3)=NHEP+4
20659         JMOHEP(1,NHEP+4)=NHEP+1
20660         JMOHEP(2,NHEP+4)=NHEP+2
20661         JDAHEP(1,NHEP+1)=NHEP+2
20662         JDAHEP(2,NHEP+1)=NHEP+4
20663         JDAHEP(1,NHEP+2)=0
20664         JDAHEP(2,NHEP+2)=NHEP+4
20665         JDAHEP(1,NHEP+3)=0
20666         JDAHEP(2,NHEP+3)=NHEP+2
20667         JDAHEP(1,NHEP+4)=0
20668         JDAHEP(2,NHEP+4)=NHEP+3
20669 C Decide which quark radiated and assign production vertices
20670         XQ2=(Q2NOW-2.*QBG)**2
20671         X2SUM=XQ2+(Q2NOW-2.*QQG)**2
20672         IF (XQ2.LT.HWRGEN(0)*X2SUM) THEN
20673 C Quark radiated the gluon
20674           CALL HWVZRO(4,VHEP(1,NHEP+4))
20675           CALL HWVSUM(4,PHEP(1,NHEP+2),PHEP(1,NHEP+3),PVRT)
20676           CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
20677           CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+2))
20678         ELSE
20679 C Anti-quark radiated the gluon
20680           CALL HWVZRO(4,VHEP(1,NHEP+2))
20681           CALL HWVSUM(4,PHEP(1,NHEP+4),PHEP(1,NHEP+3),PVRT)
20682           CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
20683           CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+4))
20684         ENDIF
20685         IF (AZSPIN) THEN
20686 C  Calculate the transverse polarisation of the gluon
20687 C  Correlation with leptons presently neglected
20688            GPOLN=(QQG**2+QBG**2)/((Q2NOW-2.*SUM)*Q2NOW)
20689            GPOLN=2./(2.+GPOLN)
20690         ENDIF
20691         NHEP=NHEP+4
20692       ELSE
20693         EMSCA=PHEP(5,3)
20694         Q2NOW=EMSCA**2
20695         IF (Q2NOW.NE.Q2LST) THEN
20696           Q2LST=Q2NOW
20697           PHASP=3.*THMAX-2.
20698           IF (PHASP.LE.ZERO) CALL HWWARN('HWHEPG',400)
20699           QGMAX=.5*Q2NOW*THMAX
20700           QGMIN=.5*Q2NOW*(1.-THMAX)
20701           FACTR=GEV2NB*FLOAT(NCOLO)*CFFAC*HWUALF(1,EMSCA)
20702      &         *.5*(HWUAEM(Q2NOW)*PHASP)**2/Q2NOW
20703           LM=1
20704           IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
20705           LP=2
20706           IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
20707           ORDER=1.
20708           IF (IDHW(1).GT.IDHW(2)) ORDER=-ORDER
20709           ID1=MOD(IPROC,10)
20710           IF (ID1.NE.0) THEN
20711              MASS=.TRUE.
20712              QM2=RMASS(ID1)**2
20713              CALL HWUCFF(11,ID1,Q2NOW,CLF(1))
20714              FACTR=FACTR*CLF(1)
20715           ELSE
20716              MASS=.FALSE.
20717              CALL HWUEEC(1)
20718              FACTR=FACTR*TQWT
20719           ENDIF
20720         ENDIF
20721         IF (ID1.EQ.0) THEN
20722 C Select quark flavour
20723           PRAN=TQWT*HWRGEN(1)
20724           PQWT=0.
20725           DO 10 IQ=1,MAXFL
20726           PQWT=PQWT+CLQ(1,IQ)
20727           IF (PQWT.GT.PRAN) GOTO 11
20728    10     CONTINUE
20729           IQ=MAXFL
20730    11     IQ1=MAPQ(IQ)
20731           DO 20 I=1,7
20732    20     CLF(I)=CLQ(I,IQ)
20733         ELSEIF (Q2NOW.GT.4*QM2/(2*THMAX-1)) THEN
20734           IQ1=ID1
20735         ELSE
20736           EVWGT=0.
20737           RETURN
20738         ENDIF
20739 C Select final state momentum configuration
20740         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20741         PHEP(5,NHEP+2)=RMASS(IQ1)
20742         PHEP(5,NHEP+3)=RMASS(13)
20743         PHEP(5,NHEP+4)=RMASS(IQ1)
20744    30   CALL HWDTHR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),
20745      &              PHEP(1,NHEP+3),PHEP(1,NHEP+4),HWDPWT)
20746         QQG=HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
20747         IF (QQG.LT.QGMIN) GOTO 30
20748         QBG=HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+3))
20749         SUM=QQG+QBG
20750         IF (QBG.LT.QGMIN.OR.SUM.GT.QGMAX) GOTO 30
20751         QQLM=HWULDO(PHEP(1,NHEP+2),PHEP(1,LM))
20752         QQLP=HWULDO(PHEP(1,NHEP+2),PHEP(1,LP))
20753         QBLM=HWULDO(PHEP(1,NHEP+4),PHEP(1,LM))
20754         QBLP=HWULDO(PHEP(1,NHEP+4),PHEP(1,LP))
20755         DYN1=QQLM**2+QQLP**2+QBLM**2+QBLP**2
20756         DYN2=0.
20757         DYN3=DYN1-2.*(QQLM**2+QBLP**2)
20758         IF (MASS) THEN
20759            RUT=1./QQG+1./QBG
20760            DYN1=DYN1+8.*QM2*(1.-.25*Q2NOW*RUT
20761      &         +QQLM*QQLP/(Q2NOW*QBG)+QBLM*QBLP/(Q2NOW*QQG))
20762            DYN2=QM2*(Q2NOW-SUM*(2.+QM2*RUT)
20763      &         -4.*HWULDO(PHEP(1,NHEP+3),PHEP(1,LM))
20764      &            *HWULDO(PHEP(1,NHEP+3),PHEP(1,LP))/Q2NOW)
20765            DYN3=DYN3+QM2*2.*RUT*(QBG*(QBLP-QBLM)-QQG*(QQLP-QQLM))
20766         ENDIF
20767         EVWGT=CLF(1)*DYN1+CLF(2)*DYN2+ORDER*CLF(3)*DYN3
20768         IF (TPOL) THEN
20769 C Include event plane azimuthal angle
20770            DYN4=.5*Q2NOW
20771            DYN5=DYN4
20772            DYN6=0.
20773            IF (MASS) THEN
20774               DYN4=DYN4-QM2*SUM/QBG
20775               DYN5=DYN5-QM2*SUM/QQG
20776               DYN6=QM2
20777            ENDIF
20778            EVWGT=EVWGT
20779      &     +(CLF(4)*COSS-CLF(6)*SINS)
20780      &      *(DYN4*(PHEP(1,NHEP+2)**2-PHEP(2,NHEP+2)**2)
20781      &       +DYN5*(PHEP(1,NHEP+4)**2-PHEP(2,NHEP+4)**2))
20782      &     +(CLF(4)*SINS+CLF(6)*COSS)*2.
20783      &      *(DYN4*PHEP(1,NHEP+2)*PHEP(2,NHEP+2)
20784      &       +DYN5*PHEP(1,NHEP+4)*PHEP(2,NHEP+4))
20785      &     +(CLF(5)*COSS-CLF(7)*SINS)*DYN6
20786      &      *(PHEP(1,NHEP+3)**2-PHEP(2,NHEP+3)**2)
20787      &     +(CLF(5)*SINS+CLF(7)*COSS)*DYN6*2.
20788      &      *PHEP(1,NHEP+3)*PHEP(2,NHEP+3)
20789         ENDIF
20790 C Assign event weight
20791         EVWGT=EVWGT*FACTR/(QQG*QBG*CLF(1))
20792       ENDIF
20793       END
20794 CDECK  ID>, HWHESL.
20795 *CMZ :-        -17/10/00  17:43:25  by  Peter Richardson
20796 *-- Author :    Kosuke Odagiri & Peter Richardson
20797 C-----------------------------------------------------------------------
20798       SUBROUTINE HWHESL
20799 C-----------------------------------------------------------------------
20800 C     SUSY E+E- -> 2 SLEPTON PROCESSES
20801 C-----------------------------------------------------------------------
20802       INCLUDE 'herwig65.inc'
20803       DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
20804      & FACTR,SN2TH,MZ,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,T,SQPE
20805       INTEGER ID1,ID2,IL,IL1,IL2,I,J,IG,IG1,IHEP,NTRY,IDL,ILP,IDLR(2),
20806      & IDSLP(2)
20807       INTEGER SSNU, SSCH
20808       PARAMETER (SSNU = 449, SSCH = 453)
20809       EXTERNAL HWRGEN, HWUAEM,HWUMBW,HWUPCM,HWRUNI
20810       SAVE HCS,ME2,IDLR,IDSLP
20811       PARAMETER (EPS = 1.D-9)
20812       DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
20813       DOUBLE PRECISION F,FACT0
20814       PARAMETER (Z = (0.D0,1.D0))
20815       EQUIVALENCE (MZ, RMASS(200))
20816 C
20817       S     = PHEP(5,3)**2
20818       EMSC2 = S
20819       EMSCA = SQRT(EMSC2)
20820       IF(FSTWGT) THEN
20821         IL = MOD((IPROC-740),5)
20822         IF(IPROC.EQ.700.OR.IPROC.EQ.740) THEN
20823           IDLR(1) = 0
20824           IDLR(2) = 0
20825           IDSLP(1) = 1
20826           IDSLP(2) = 6
20827         ELSE
20828           IF(IL.EQ.0) THEN
20829             IDLR(1) = 1
20830             IDLR(2) = 1
20831             IDSLP(1) = 2*(IPROC-740)/5
20832           ELSEIF(IL.EQ.1) THEN
20833             IDLR(1) = 0
20834             IDLR(2) = 0
20835             IDSLP(1) = 2*(IPROC-741)/5+1
20836           ELSEIF(IL.EQ.2) THEN
20837             IDLR(1) = 1
20838             IDLR(2) = 1
20839             IDSLP(1) = 2*(IPROC-742)/5+1
20840           ELSEIF(IL.EQ.3) THEN
20841             IDLR(1) = 1
20842             IDLR(2) = 2
20843             IDSLP(1) = 2*(IPROC-743)/5+1
20844           ELSEIF(IL.EQ.4) THEN
20845             IDLR(1) = 2
20846             IDLR(2) = 2
20847             IDSLP(1) = 2*(IPROC-744)/5+1
20848           ENDIF
20849           IDSLP(2) = IDSLP(1)
20850         ENDIF
20851       ENDIF
20852       IF (GENEV) THEN
20853         RCS = HCS*HWRGEN(0)
20854       ELSE
20855         IDL   = ABS(IDHEP(1))
20856         ILP   = IDL-10
20857         COSTH = HWRUNI(1,-ONE,ONE)
20858         SN2TH = 0.25D0 - 0.25D0*COSTH**2
20859         FACT0 = GEV2NB*PIFAC*HWUAEM(EMSC2)**2/S
20860         FACTR = FACT0*SN2TH
20861         GZ    = (S-MZ**2+Z*S*GAMZ/MZ)/S
20862 c             ~  ~*
20863 c    e+ e- -> l  l
20864 c
20865         DO IL=1,6
20866           DO I=1,2
20867             DO J=1,2
20868               ME2(I,J,IL) = ZERO
20869             ENDDO
20870           ENDDO
20871         ENDDO
20872         DO IL = IDSLP(1),IDSLP(2)
20873           DO I = 1,2
20874             DO J = 1,2
20875               IF ((I.EQ.2.OR.J.EQ.2).AND.(((IL/2)*2).EQ.IL).OR.
20876      &            (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
20877      &              .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
20878                 QPE = -1.
20879               ELSE
20880                 ID1 = 412 + I*12 + IL
20881                 ID2 = 412 + J*12 + IL
20882                 IL1 = IL + 10
20883                 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
20884               ENDIF
20885               IF (QPE.GT.ZERO) THEN
20886                 SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
20887                 PF = SQPE/S
20888                 IF ((IL.NE.ILP).OR.(I.EQ.J)) THEN
20889                   A  = QFCH(IL1)*QFCH(IDL)
20890                   BL = LFCH(IL1)/GZ
20891                   BR = RFCH(IL1)/GZ
20892                   CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
20893                   CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
20894                   D  = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR
20895                   E  = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR
20896                   IF (IL.EQ.ILP+1.OR.IL.EQ.ILP) THEN
20897                     F = ZERO
20898                     T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
20899                     IF (IL.EQ.ILP) THEN
20900                       IF (I.EQ.J) THEN
20901                         IF (I.EQ.1) THEN
20902                           DO IG = 1,4
20903                             IG1 = SSNU+IG
20904                             F   = F + SLFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
20905                           ENDDO
20906                           D = D + F*S
20907                         ELSE
20908                           DO IG=1,4
20909                             IG1 = SSNU+IG
20910                             F   = F +SRFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
20911                           ENDDO
20912                           E = E + F*S
20913                         ENDIF
20914                       ELSE
20915                       ENDIF
20916                     ELSE
20917                       DO IG = 1,2
20918                         IG1 = SSCH+IG
20919                         F   = F + WMXVSS(IG,1)**2/(T-RMASS(IG1)**2)
20920                       ENDDO
20921                       D = D + F*S/(TWO*SWEIN)
20922                     ENDIF
20923                   ENDIF
20924                   ME2(I,J,IL)=FACTR*PF**3*DREAL(
20925      &                  (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
20926      &                 +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E)
20927                 ELSE
20928                   F = ZERO
20929                   T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
20930                   DO IG = 1,4
20931                     IG1 = SSNU+IG
20932                     F   = F + SLFCH(IL1,IG)*SRFCH(IL1,IG)*
20933      &                    ZSGNSS(IG)*RMASS(IG1)/(T-RMASS(IG1)**2)
20934                   ENDDO
20935 C--production of el- er+
20936                   IF(I.EQ.1.AND.J.EQ.2) THEN
20937                     ME2(I,J,IL)=FACT0*PF*F**2*S*
20938      &                    (ONE-EPOLN(3))*(ONE-PPOLN(3))
20939                   ELSE
20940 C--production of er- el+
20941                     ME2(I,J,IL)=FACT0*PF*F**2*S*
20942      &                    (ONE+EPOLN(3))*(ONE+PPOLN(3))
20943                   ENDIF
20944                 ENDIF
20945               ELSE
20946                 ME2(I,J,IL)=ZERO
20947               ENDIF
20948             ENDDO
20949           ENDDO
20950         ENDDO
20951       ENDIF
20952       HCS = ZERO
20953 C
20954       DO IL = 1,6
20955          DO I = 1,2
20956             DO J = 1,2
20957                IL1 = IL+I*12+412
20958                IL2 = IL+J*12+418
20959                HCS = HCS + ME2(I,J,IL)
20960                IF (GENEV.AND.HCS.GT.RCS) GOTO 100
20961             ENDDO
20962          ENDDO
20963        ENDDO
20964 C---GENERATE EVENT
20965  100  IF(GENEV) THEN
20966 C--change sign of COSTH if antiparticle first
20967       IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
20968         IDHW(NHEP+1)     = 15
20969         IDHEP(NHEP+1)    = 0
20970         ISTHEP(NHEP+1)   = 110
20971         IDHW(NHEP+2)     = IL1
20972         IDHW(NHEP+3)     = IL2
20973         IDHEP(NHEP+2)    = IDPDG(IL1)
20974         IDHEP(NHEP+3)    = IDPDG(IL2)
20975 C--select the particle masses and momenta
20976         NTRY = 0
20977  110    NTRY = NTRY+1
20978         PHEP(5,NHEP+2)   = HWUMBW(IL1)
20979         PHEP(5,NHEP+3)   = HWUMBW(IL2)
20980         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20981         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20982         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
20983           GOTO 110
20984         ELSEIF(PCM.LT.ZERO) THEN
20985           CALL HWWARN('HWHESL',100)
20986           GOTO 999
20987         ENDIF
20988 C--Set up the colours etc
20989         ISTHEP(NHEP+2)   = 113
20990         ISTHEP(NHEP+3)   = 114
20991         JMOHEP(1,NHEP+1) = 1
20992         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20993         JMOHEP(2,NHEP+1) = 2
20994         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20995         JMOHEP(1,NHEP+2) = NHEP+1
20996         JMOHEP(2,NHEP+2) = NHEP+2
20997         JMOHEP(1,NHEP+3) = NHEP+1
20998         JMOHEP(2,NHEP+3) = NHEP+3
20999         JDAHEP(1,NHEP+1) = NHEP+2
21000         JDAHEP(2,NHEP+1) = NHEP+3
21001         JDAHEP(1,NHEP+2) = 0
21002         JDAHEP(2,NHEP+2) = NHEP+2
21003         JDAHEP(1,NHEP+3) = 0
21004         JDAHEP(2,NHEP+3) = NHEP+3
21005 C--Set up the momenta
21006         IHEP  = NHEP+2
21007         IHEP  = NHEP+2
21008         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
21009         PHEP(3,IHEP) = PCM*COSTH
21010         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
21011         PHEP(2,IHEP) = ZERO
21012         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
21013         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
21014         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
21015         NHEP  = NHEP+3
21016       ELSE
21017         EVWGT = HCS
21018       ENDIF
21019  999  RETURN
21020       END
21021 CDECK  ID>, HWHESG.
21022 *CMZ :-        -18/10/00  13:46:47  by  Peter Richardson
21023 *-- Author :    Kosuke Odagiri & Peter Richardson
21024 C-----------------------------------------------------------------------
21025       SUBROUTINE HWHESG
21026 C-----------------------------------------------------------------------
21027 C     SUSY E+E- -> 2 GAUGINO PROCESSES
21028 C-----------------------------------------------------------------------
21029       INCLUDE 'herwig65.inc'
21030       DOUBLE PRECISION HWRGEN,HWUAEM,HCS,RCS,MNU(4),MNU2(4),HWRUNI,
21031      &                 FACA,M1(4,4),S2W,XC(4),XD(4),MSNU,
21032      &                 MZ,HWHSS2,U,T,QPE,SQPE,MSL,MSL2,MSR,MSR2,
21033      &                 SGN,S,SM,DM,PF,PCM,HWUPCM,XW,S22W,
21034      &                 MSNU2,MCH(2),MCH2(2),DAB,M2(2,2),HWUMBW
21035       INTEGER I,IQ1,IQ2,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,
21036      &        ISN,IDL,NTRY
21037       LOGICAL NEUT,CHAR
21038       SAVE HCS,M1,M2,NTID,ISL,ISR,ISN,IDL,CHID,NEUT,CHAR
21039       EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWHSS2,HWUPCM,HWUMBW
21040       DOUBLE COMPLEX Z, Z0, Z1, C1, C2, C3,GZ, CLL, CLR, CRL, CRR
21041       PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0), Z1 = (1.D0,0.D0))
21042       PARAMETER (SSNU=449,SSCH = 453)
21043       EQUIVALENCE (MZ, RMASS(200))
21044       EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
21045       EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
21046       EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
21047       EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
21048 C--Start of the code
21049       IF(GENEV) THEN
21050         RCS = HCS*HWRGEN(0)
21051       ELSE
21052 C--Decide which processes to generate
21053         IF(FSTWGT) THEN
21054           NEUT = .TRUE.
21055           CHAR = .TRUE.
21056 C--neutralino pair production
21057           IF(IPROC.GE.710.AND.IPROC.LE.726) THEN
21058             CHAR = .FALSE.
21059             IF(IPROC.EQ.710) THEN
21060               NTID(1) = 0
21061               NTID(2) = 0
21062             ELSE
21063               NTID(1) = INT((IPROC-707)/4)
21064               NTID(2) = MOD((IPROC-711),4)+1
21065             ENDIF
21066 C--chargino pair production
21067           ELSEIF(IPROC.GE.730.AND.IPROC.LE.734) THEN
21068             NEUT = .FALSE.
21069             IF(IPROC.EQ.730) THEN
21070               CHID(1) = 0
21071               CHID(2) = 0
21072             ELSE
21073               CHID(1) = INT((IPROC-729)/2)
21074               CHID(2) = MOD((IPROC-731),2)+1
21075             ENDIF
21076           ELSEIF(IPROC.NE.700) THEN
21077             CALL HWWARN('HWHESG',500)
21078           ENDIF
21079 C--check the particles in the beam
21080           IF(ABS(IDHEP(1)).EQ.11) THEN
21081 C--electron beams
21082             ISL = 425
21083             ISR = 437
21084             ISN = 426
21085           ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
21086 C--muon beams
21087             ISL = 427
21088             ISR = 439
21089             ISN = 428
21090           ELSE
21091             CALL HWWARN('HWHESG',501)
21092           ENDIF
21093           IDL=ABS(IDHEP(1))
21094         ENDIF
21095         DO I=1,4
21096           MNU(I) = RMASS(SSNU+I)
21097           MNU2(I) = MNU(I)**2
21098         ENDDO
21099         DO IG1 = 1,2
21100           MCH(IG1)  = RMASS(IG1+SSCH)
21101           MCH2(IG1) = MCH(IG1)**2
21102         ENDDO
21103         COSTH = HWRUNI(1,-ONE,ONE)
21104         XW    = TWO * SWEIN
21105         S22W  = XW * (TWO - XW)
21106         S2W   = SQRT(S22W)
21107         S     = PHEP(5,3)**2
21108         EMSCA = PHEP(5,3)
21109         FACA  = HWUAEM(S)**2
21110         GZ    = S-MZ**2+Z*S/MZ*GAMZ
21111         MSL   = RMASS(ISL)
21112         MSR   = RMASS(ISR)
21113         MSL2  = MSL**2
21114         MSR2  = MSR**2
21115         MSNU  = RMASS(ISN)
21116         MSNU2 = MSNU**2
21117 C--neutralino pair production
21118         IF(.NOT.NEUT) THEN
21119           DO IQ1=1,4
21120             DO IQ2=1,4
21121               M1(IQ1,IQ2) = ZERO
21122             ENDDO
21123           ENDDO
21124           GOTO 100
21125         ENDIF
21126         DO IQ1=1,4
21127           DO IQ2=1,4
21128             SM   = MNU(IQ1) + MNU(IQ2)
21129             QPE  = S - SM**2
21130             IF(QPE.GE.ZERO.AND.
21131      &           (NTID(1).EQ.0.OR.(IQ1.EQ.NTID(1).AND.IQ2.EQ.NTID(2))
21132      &           .OR.(IQ1.EQ.NTID(2).AND.IQ2.EQ.NTID(1)))) THEN
21133               DM   = MNU(IQ1) - MNU(IQ2)
21134               SQPE = SQRT(QPE*(S-DM**2))
21135               PF   = SQPE/S
21136               T    = HALF*(SQPE*COSTH - S + MNU2(IQ1) + MNU2(IQ2))
21137               U    = - T - S + MNU2(IQ1) + MNU2(IQ2)
21138               C1   = (XD(IQ1)*XD(IQ2)-XC(IQ1)*XC(IQ2))/S2W/GZ
21139               C2   = - C1
21140               SGN  = ZSGNSS(IQ1)*ZSGNSS(IQ2)
21141               CLL = LFCH(IDL)*C1+SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(U-MSL2)
21142               CLR = LFCH(IDL)*C2-SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(T-MSL2)
21143               CRL = RFCH(IDL)*C1-SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(T-MSR2)
21144               CRR = RFCH(IDL)*C2+SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(U-MSR2)
21145 C--modified to include beam polarization PR 10/10/01
21146               M1(IQ1,IQ2) = FACA*PF*GEV2NB*PIFAC/S*HALF*
21147      &          HWHSS2(S,T,U,MNU(IQ1),MNU(IQ2),SGN,CLL,CLR,CRL,CRR)
21148             ELSE
21149               M1(IQ1,IQ2) = ZERO
21150             ENDIF
21151           ENDDO
21152         ENDDO
21153 C--chargino pair production
21154  100    IF(.NOT.CHAR) THEN
21155           DO IG1=1,2
21156             DO IG2=1,2
21157               M2(IG1,IG2) = ZERO
21158             ENDDO
21159           ENDDO
21160           GOTO 200
21161         ENDIF
21162         DO IG1 = 1,2
21163           DO IG2 = 1,2
21164             SM  = MCH(IG1) + MCH(IG2)
21165             QPE = S - SM**2
21166             IF (QPE.GE.ZERO.AND.
21167      &           (CHID(1).EQ.0.OR.(CHID(1).EQ.IG1.AND.CHID(2).EQ.IG2)
21168      &            .OR.(CHID(1).EQ.IG2.AND.CHID(2).EQ.IG1))) THEN
21169               DM   = MCH(IG1) - MCH(IG2)
21170               SQPE = SQRT(QPE*(S-DM**2))
21171               PF   = SQPE/S
21172               T    = HALF*(SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2))
21173               U    = - T - S + MCH2(IG1) + MCH2(IG2)
21174               DAB  = ABS(FLOAT(IG1+IG2-3))
21175               C1   = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
21176               C2   = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
21177               SGN  = WSGNSS(IG1)*WSGNSS(IG2)
21178               C3   = -DAB*QFCH(IDL)/S
21179               CLL  = C3- LFCH(IDL)*C1
21180      &               +WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-MSNU2)*XW)
21181               CLR  = C3- LFCH(IDL)*C2
21182               CRL  = C3- RFCH(IDL)*C1
21183               CRR  = C3- RFCH(IDL)*C2
21184 C--modified to include beam polarization PR 10/10/01
21185               M2(IG1,IG2)=FACA*PF*GEV2NB*PIFAC/S*
21186      &             HWHSS2(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
21187             ELSE
21188               M2(IG1,IG2) = ZERO
21189             ENDIF
21190           ENDDO
21191         ENDDO
21192       ENDIF
21193 C--Add up the weights now
21194  200  HCS = ZERO
21195       IF(.NOT.NEUT) GOTO 250
21196       DO IQ1=1,4
21197         IG1 = SSNU+IQ1
21198         DO IQ2=1,4
21199           IG2 = SSNU+IQ2
21200           HCS = HCS+M1(IQ1,IQ2)
21201           IF(GENEV.AND.HCS.GT.RCS) GOTO 900
21202         ENDDO
21203       ENDDO
21204  250  IF(.NOT.CHAR) GOTO 900
21205       DO IQ1 = 1,2
21206         IG1 = SSCH+IQ1
21207         DO IQ2 = 1,2
21208           IG2 = SSCH+IQ2+2
21209           HCS = HCS + M2(IQ1,IQ2)
21210           IF (GENEV.AND.HCS.GT.RCS) GOTO 900
21211         ENDDO
21212       ENDDO
21213  900  IF(GENEV) THEN
21214 C--change sign of COSTH if antiparticle first
21215         IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
21216 C-Set up the particle types
21217         IDHW(NHEP+1)     = 15
21218         IDHEP(NHEP+1)    = 0
21219         ISTHEP(NHEP+1)   = 110
21220         IDHW(NHEP+2)     = IG1
21221         IDHW(NHEP+3)     = IG2
21222         IDHEP(NHEP+2)    = IDPDG(IG1)
21223         IDHEP(NHEP+3)    = IDPDG(IG2)
21224 C--select the particle masses and momenta
21225         NTRY = 0
21226  910    NTRY = NTRY+1
21227         PHEP(5,NHEP+2)   = HWUMBW(IG1)
21228         PHEP(5,NHEP+3)   = HWUMBW(IG2)
21229         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
21230         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
21231         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
21232           GOTO 910
21233         ELSEIF(PCM.LT.ZERO) THEN
21234           CALL HWWARN('HWHESG',100)
21235           GOTO 999
21236         ENDIF
21237 C--Set up the colours etc
21238         ISTHEP(NHEP+2)   = 113
21239         ISTHEP(NHEP+3)   = 114
21240         JMOHEP(1,NHEP+1) = 1
21241 C--PR Bug fix 10/10/01
21242         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
21243         JMOHEP(2,NHEP+1) = 2
21244         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
21245         JMOHEP(1,NHEP+2) = NHEP+1
21246         JMOHEP(2,NHEP+2) = NHEP+2
21247         JMOHEP(1,NHEP+3) = NHEP+1
21248         JMOHEP(2,NHEP+3) = NHEP+3
21249         JDAHEP(1,NHEP+1) = NHEP+2
21250         JDAHEP(2,NHEP+1) = NHEP+3
21251         JDAHEP(1,NHEP+2) = 0
21252         JDAHEP(2,NHEP+2) = NHEP+3
21253         JDAHEP(1,NHEP+3) = 0
21254         JDAHEP(2,NHEP+3) = NHEP+2
21255 C--Set up the momenta
21256         IHEP  = NHEP+2
21257         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
21258         PHEP(3,IHEP) = PCM*COSTH
21259         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
21260         PHEP(2,IHEP) = ZERO
21261         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
21262         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
21263         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
21264         NHEP  = NHEP+3
21265       ELSE
21266         EVWGT = HCS
21267       ENDIF
21268  999  RETURN
21269       END
21270 CDECK  ID>, HWHESP.
21271 *CMZ :-        -18/10/00  13:46:47  by  Peter Richardson
21272 *-- Author :    Kosuke Odagiri & Peter Richardson
21273 C-----------------------------------------------------------------------
21274       SUBROUTINE HWHESP
21275 C-----------------------------------------------------------------------
21276 C     SUSY E+E- -> 2 SPARTICLE PROCESSES
21277 C-----------------------------------------------------------------------
21278       INCLUDE 'herwig65.inc'
21279       DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN
21280       EXTERNAL HWRGEN
21281       SAVE SAVWT
21282       IF(IPROC.EQ.700) THEN
21283         IF(GENEV) THEN
21284           RANWT    = SAVWT(3)*HWRGEN(0)
21285           IF(RANWT.LT.SAVWT(1)) THEN
21286             CALL HWHESG
21287           ELSEIF(RANWT.LT.SAVWT(2)) THEN
21288             CALL HWHESL
21289           ELSEIF(RANWT.LT.SAVWT(3)) THEN
21290             CALL HWHESQ
21291           ENDIF
21292         ELSE
21293           CALL HWHESG
21294           SAVWT(1) = EVWGT
21295           CALL HWHESL
21296           SAVWT(2) = SAVWT(1)+EVWGT
21297           CALL HWHESQ
21298           SAVWT(3) = SAVWT(2)+EVWGT
21299           EVWGT    = SAVWT(3)
21300         ENDIF
21301       ELSEIF(IPROC.LT.740) THEN
21302         CALL HWHESG
21303       ELSEIF(IPROC.LT.760) THEN
21304         CALL HWHESL
21305       ELSEIF(IPROC.LT.790) THEN
21306         CALL HWHESQ
21307       ELSE
21308 C---UNRECOGNIZED PROCESS
21309         CALL HWWARN('HWHESP',500)
21310       ENDIF
21311       END
21312 CDECK  ID>, HWHESQ.
21313 *CMZ :-        -16/10/00  15:34:113  by  Peter Richardson
21314 *-- Author :    Kosuke Odagiri & Peter Richardson
21315 C-----------------------------------------------------------------------
21316       SUBROUTINE HWHESQ
21317 C-----------------------------------------------------------------------
21318 C     SUSY E+E- -> 2 SQUARK PROCESSES
21319 C-----------------------------------------------------------------------
21320       INCLUDE 'herwig65.inc'
21321       DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
21322      & FACTR,SN2TH,MZ,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,SQPE
21323       INTEGER ID1,ID2,IQ,IQ1,IQ2,I,J,IHEP,IDL,IDLR(2),IDSQU(2),NTRY
21324       EXTERNAL HWRGEN,HWUAEM,HWUMBW,HWUPCM,HWRUNI
21325       SAVE HCS,ME2,IDLR,IDSQU
21326       PARAMETER (EPS = 1.D-9)
21327       DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
21328       PARAMETER (Z = (0.D0,1.D0))
21329       EQUIVALENCE (MZ, RMASS(200))
21330 C
21331       S     = PHEP(5,3)**2
21332       EMSC2 = S
21333       EMSCA = SQRT(EMSC2)
21334       IF(FSTWGT) THEN
21335         IF(IPROC.EQ.700.OR.IPROC.EQ.760) THEN
21336            IDLR(1) = 0
21337            IDLR(2) = 0
21338            IDSQU(1) = 1
21339            IDSQU(2) = 6
21340         ELSEIF(IPROC.GT.760.AND.IPROC.LE.784) THEN
21341            IQ = MOD((IPROC-761),4)
21342            IF(IQ.EQ.0) THEN
21343               IDLR(1) = 0
21344               IDLR(2) = 0
21345            ELSEIF(IQ.EQ.1) THEN
21346               IDLR(1) = 1
21347               IDLR(2) = 1
21348            ELSEIF(IQ.EQ.2) THEN
21349               IDLR(1) = 1
21350               IDLR(2) = 2
21351            ELSEIF(IQ.EQ.3) THEN
21352               IDLR(1) = 2
21353               IDLR(2) = 2
21354            ENDIF
21355            IDSQU(1) = (IPROC-761)/4+1
21356            IDSQU(2) = IDSQU(1)
21357         ELSE
21358            CALL HWWARN('HWHESQ',500)
21359         ENDIF
21360       ENDIF
21361       IF (GENEV) THEN
21362         RCS   = HCS*HWRGEN(0)
21363       ELSE
21364         COSTH = HWRUNI(1,-ONE,ONE)
21365         SN2TH = 0.25D0 - 0.25D0*COSTH**2
21366         FACTR = CAFAC*GEV2NB*PIFAC*HWUAEM(EMSC2)**2*SN2TH/S
21367         GZ    = (S-MZ**2+Z*S*GAMZ/MZ)/S
21368         IDL   = ABS(IDHEP(1))
21369 c             ~  ~*
21370 c    e+ e- -> q  q
21371 c
21372         DO IQ=1,6
21373           DO I=1,2
21374             DO J=1,2
21375               ME2(I,J,IQ) = ZERO
21376             ENDDO
21377           ENDDO
21378         ENDDO
21379         DO IQ = IDSQU(1),IDSQU(2)
21380           DO I = 1,2
21381             DO J = 1,2
21382               IF ((I.NE.J).AND.(IQ.LT.5).OR.
21383      &            (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
21384      &              .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
21385                 QPE = -1.
21386               ELSE
21387                 ID1 = 388 + I*12 + IQ
21388                 ID2 = 388 + J*12 + IQ
21389                 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
21390               ENDIF
21391               IF (QPE.GT.ZERO) THEN
21392                 SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
21393                 PF = SQPE/S
21394                 A  = QFCH(IQ)*QFCH(IDL)
21395                 BL = LFCH(IQ)/GZ
21396                 BR = RFCH(IQ)/GZ
21397                 CL = QMIXSS(IQ,1,I)*QMIXSS(IQ,1,J)
21398                 CR = QMIXSS(IQ,2,I)*QMIXSS(IQ,2,J)
21399                 D  = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR
21400                 E  = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR
21401                 ME2(I,J,IQ)=FACTR*PF**3*DREAL(
21402      &                  (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
21403      &                 +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E)
21404               ELSE
21405                 ME2(I,J,IQ)=ZERO
21406               ENDIF
21407             ENDDO
21408           ENDDO
21409         ENDDO
21410       ENDIF
21411       HCS = ZERO
21412 C
21413       DO IQ = 1,6
21414         DO I = 1,2
21415           DO J = 1,2
21416             IQ1 = IQ+I*12+388
21417             IQ2 = IQ+J*12+394
21418             HCS = HCS + ME2(I,J,IQ)
21419             IF (GENEV.AND.HCS.GT.RCS) GOTO 100
21420           ENDDO
21421         ENDDO
21422       ENDDO
21423 C---GENERATE EVENT
21424  100  IF(GENEV) THEN
21425         IDHW(NHEP+1)     = 15
21426         IDHEP(NHEP+1)    = 0
21427         ISTHEP(NHEP+1)   = 110
21428         IDHW(NHEP+2)     = IQ1
21429         IDHW(NHEP+3)     = IQ2
21430         IDHEP(NHEP+2)    = IDPDG(IQ1)
21431         IDHEP(NHEP+3)    = IDPDG(IQ2)
21432 C--Select the particle masses and momenta
21433  110    NTRY = NTRY+1
21434         PHEP(5,NHEP+2)   = HWUMBW(IQ1)
21435         PHEP(5,NHEP+3)   = HWUMBW(IQ2)
21436         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
21437         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
21438         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
21439           GOTO 110
21440         ELSEIF(PCM.LT.ZERO) THEN
21441           CALL HWWARN('HWHESQ',100)
21442           GOTO 999
21443         ENDIF
21444 C--Set up the colours etc
21445         ISTHEP(NHEP+2)   = 113
21446         ISTHEP(NHEP+3)   = 114
21447         JMOHEP(1,NHEP+1) = 1
21448         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
21449         JMOHEP(2,NHEP+1) = 2
21450         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
21451         JMOHEP(1,NHEP+2) = NHEP+1
21452         JMOHEP(2,NHEP+2) = NHEP+3
21453         JMOHEP(1,NHEP+3) = NHEP+1
21454         JMOHEP(2,NHEP+3) = NHEP+2
21455         JDAHEP(1,NHEP+1) = NHEP+2
21456         JDAHEP(2,NHEP+1) = NHEP+3
21457         JDAHEP(1,NHEP+2) = 0
21458         JDAHEP(2,NHEP+2) = NHEP+3
21459         JDAHEP(1,NHEP+3) = 0
21460         JDAHEP(2,NHEP+3) = NHEP+2
21461 C--Set up the momenta
21462         IHEP  = NHEP+2
21463         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
21464         PHEP(3,IHEP) = PCM*COSTH
21465         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
21466         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
21467         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
21468         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
21469         NHEP  = NHEP+3
21470       ELSE
21471         EVWGT = HCS
21472       ENDIF
21473  999  RETURN
21474       END
21475 CDECK  ID>, HWHEW0.
21476 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
21477 *-- Author :    Zoltan Kunszt, modified by Bryan Webber & Mike Seymour
21478 C-----------------------------------------------------------------------
21479       SUBROUTINE HWHEW0(IP,ETOT,XM,PR,WEIGHT,CR)
21480 C-----------------------------------------------------------------------
21481       INCLUDE 'herwig65.inc'
21482       DOUBLE PRECISION HWRGEN,ETOT,XM(2),PR(5,2),WEIGHT,CR,XM1,XM2,S,
21483      & D1,PABS,D,CX,C,E,F,SC,G
21484       INTEGER IP,I
21485       EXTERNAL HWRGEN
21486       WEIGHT=ZERO
21487       XM1=XM(1)**2
21488       XM2=XM(2)**2
21489       S=ETOT*ETOT
21490       D1=S-XM1-XM2
21491       PABS=D1*D1-4.*XM1*XM2
21492       IF (PABS.LE.ZERO) RETURN
21493       PABS=SQRT(PABS)
21494       D=D1/PABS
21495       IF(IP.EQ.2)GOTO3
21496       CX=CR
21497       C=D-(D+CX)*((D-CR)/(D+CX))**HWRGEN(2)
21498       GOTO 4
21499 3     E=((D+ONE)/(D-ONE))*(TWO*HWRGEN(3)-ONE)
21500       C=D*((E-ONE)/(E+ONE))
21501 4     F=2D0*PIFAC*HWRGEN(4)
21502       SC=SQRT(ONE-C*C)
21503       PR(4,1)=(S+XM1-XM2)/(TWO*ETOT)
21504       PR(5,1)=PR(4,1)*PR(4,1)-XM1
21505       IF (PR(5,1).LE.ZERO) RETURN
21506       PR(5,1)=SQRT(PR(5,1))
21507       PR(4,2)=ETOT-PR(4,1)
21508       PR(3,1)=PR(5,1)*C
21509       PR(5,2)=PR(5,1)
21510       PR(2,1)=PR(5,1)*SC*COS(F)
21511       PR(1,1)=PR(5,1)*SC*SIN(F)
21512       DO 7 I=1,3
21513 7     PR(I,2)=-PR(I,1)
21514       G=0.
21515       IF(IP.EQ.1)G=(D-C)*LOG((D+CX)/(D-CR))
21516       IF(IP.EQ.2)G=(D*D-C*C)/D*LOG((D+ONE)/(D-ONE))
21517       WEIGHT=PIFAC*G*PR(5,1)/ETOT*HALF
21518       END
21519 CDECK  ID>, HWHEW1.
21520 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
21521 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21522 C-----------------------------------------------------------------------
21523       SUBROUTINE HWHEW1(NPART)
21524 C-----------------------------------------------------------------------
21525       IMPLICIT NONE
21526       DOUBLE PRECISION P(4,7),XMASS,PLAB,PRW,PCM
21527       INTEGER NPART,I,J,K
21528       COMMON/HWHEWP/ XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
21529       DO 10 I=1,NPART
21530       P(1,I)=PLAB(3,I)
21531       P(2,I)=PLAB(1,I)
21532       P(3,I)=PLAB(2,I)
21533       P(4,I)=PLAB(4,I)
21534   10  CONTINUE
21535       DO 20 J=1,4
21536       DO 30 K=1,(NPART-2)
21537   30  PCM(J,K)=P(J,K+2)
21538       PCM(J,NPART-1)=-P(J,1)
21539       PCM(J,NPART)=-P(J,2)
21540   20  CONTINUE
21541       END
21542 CDECK  ID>, HWHEW2.
21543 *CMZ :-        -26/04/91  13.22.25  by  Federico Carminati
21544 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21545 C-----------------------------------------------------------------------
21546       SUBROUTINE HWHEW2(NPART,PPCM,H,CH,D)
21547 C-----------------------------------------------------------------------
21548 C PCM SHOULD BE DEFINED SUCH THAT ALL 4-MOMENTA ARE OUTGOING.
21549 C CONVENTION FOR PCM AND P IS THAT DIRECTION 1 =BEAM, COMPONENT
21550 C 4 = ENERGY AND COMPONENT 2 AND 3 ARE TRANSVERSE COMPONENTS.
21551 C THUS INCOMING MOMENTA SHOULD CORRESPOND TO OUTGOING MOMENTA
21552 C OF NEGATIVE ENERGY.
21553 C PCM IS FILLED BY PHASE SPACE MONTE CARLO.
21554 C I1-I7 HERE REFER TO HOW PCM INDEXING IS MAPPED TO OUR STANDARD
21555 C 1-6=GLUON,GLUON,Q,QBAR,QP,QPBAR ORDERING `
21556 C-----------------------------------------------------------------------
21557       IMPLICIT NONE
21558       DOUBLE COMPLEX PT5,ZT,Z1,ZI,ZP,ZQ,ZD,ZPS,ZQS,ZDPM,ZDMP,H(8,8),
21559      & CH(8,8),D(8,8)
21560       DOUBLE PRECISION ZERO,ONE,PPCM(5,8),P(5,8),WRN(8),EPS,Q1,Q2,QP,QM,
21561      & P1,P2,PP,PM,DMP,DPM,PT,QT,PTI,QTI,HALF
21562       INTEGER J,L,IJ,II,JJ,I,NPART,IP1,IPP1
21563       PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
21564       EPS=0.0000001
21565       ZI=DCMPLX(ZERO,ONE)
21566       Z1=DCMPLX(ONE,ZERO)
21567 C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
21568       DO 1 L=1,NPART
21569       DO 1 IJ=1,4
21570 1     P(IJ,L)=PPCM(IJ,L)
21571       DO 2 II=1,8
21572       WRN(II)=ONE
21573       IF(P(4,II).LT.ZERO) WRN(II)=-ONE
21574       DO 2 JJ=1,4
21575       P(JJ,II)=WRN(II)*P(JJ,II)
21576     2 CONTINUE
21577 C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
21578 C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
21579       DO 11 I=1,NPART-1
21580       IP1=I+1
21581       DO 11 J=IP1,NPART
21582       Q1=P(4,I)+P(1,I)
21583       QP=0.0
21584       IF(Q1.GT.EPS)QP=SQRT(Q1)
21585       Q2=P(4,I)-P(1,I)
21586       QM=0.0
21587       IF(Q2.GT.EPS)QM=SQRT(Q2)
21588       P1=P(4,J)+P(1,J)
21589       PP=0.
21590       IF(P1.GT.EPS)PP=SQRT(P1)
21591       P2=P(4,J)-P(1,J)
21592       PM=0.
21593       IF(P2.GT.EPS)PM=SQRT(P2)
21594       DMP=PM*QP
21595       ZDMP=DCMPLX(DMP,ZERO)
21596       DPM=PP*QM
21597       ZDPM=DCMPLX(DPM,ZERO)
21598 C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
21599       PT=SQRT(P(2,J)**2+P(3,J)**2)
21600       QT=SQRT(P(2,I)**2+P(3,I)**2)
21601       IF(PT.GT.EPS) GOTO 99
21602       ZP=Z1
21603       GOTO 98
21604    99 PTI=ONE/PT
21605       ZP=DCMPLX(PTI*P(2,J),PTI*P(3,J))
21606    98 ZPS=DCONJG(ZP)
21607       IF(QT.GT.EPS) GOTO 89
21608       ZQ=Z1
21609       GOTO 88
21610    89 QTI=ONE/QT
21611       ZQ=DCMPLX(QTI*P(2,I),QTI*P(3,I))
21612    88 ZQS=DCONJG(ZQ)
21613       ZT=Z1
21614       IF(WRN(I).LT.ZERO) ZT=ZT*ZI
21615       IF(WRN(J).LT.ZERO) ZT=ZT*ZI
21616       H(J,I)=(ZDMP*ZP-ZDPM*ZQ)*ZT
21617       CH(J,I)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
21618       ZD=H(J,I)*CH(J,I)
21619       PT5=DCMPLX(HALF,ZERO)
21620       D(J,I)=PT5*ZD
21621    11 CONTINUE
21622       DO 60 I=1,NPART-1
21623       IPP1=I+1
21624       DO 60 J=IPP1,NPART
21625       H(I,J)=-H(J,I)
21626       CH(I,J)=-CH(J,I)
21627    60 D(I,J)=D(J,I)
21628       END
21629 CDECK  ID>, HWHEW3.
21630 *CMZ :-        -27/03/92  19.48.55  by  Mike Seymour
21631 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21632 C-----------------------------------------------------------------------
21633       SUBROUTINE HWHEW3(N1,N2,N3,N4,N5,N6,AMPWW)
21634 C-----------------------------------------------------------------------
21635 C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
21636 C OUTGOING ANTI-FERMIONS; 3,4 FOR W-, 5,6 FOR W+
21637 C
21638 C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
21639 C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
21640 C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
21641 C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
21642 C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
21643 C
21644 C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
21645 C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
21646 C FOR ON POLE APPROXIMATION AS DESIRED.
21647 C-----------------------------------------------------------------------
21648       INCLUDE 'herwig65.inc'
21649       DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMP1,ZAMP3,DWW,CWW,BWW,AWW,
21650      & AWWM,AWWP,AMPTEM,ZTWO,ZHALF
21651       DOUBLE PRECISION XW,ZMASS,T3,EQ1,RR,RL,ZM2,AMP2,RKW,COLFAC(4),
21652      & AMPWW(4)
21653       INTEGER I,N1,N2,N3,N4,N5,N6
21654       EXTERNAL HWHEW4
21655       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21656       EQUIVALENCE (XW,SWEIN),(ZMASS,RMASS(200))
21657       SAVE COLFAC,ZTWO,ZHALF
21658       DATA COLFAC/1.D0,3.D0,3.D0,9.D0/
21659       DATA ZTWO,ZHALF/(2.0D0,0.0D0),(0.5D0,0.0D0)/
21660       T3=-1.D0
21661       EQ1=-1.D0
21662       RR=-2.D0*EQ1*XW
21663       RL=T3+RR
21664       ZM2=ZMASS*ZMASS
21665       ZAMP1=DCMPLX(ZM2)/(ZTWO*ZD(N1,N2))
21666      &                /(ZTWO*ZD(N1,N2)+DCMPLX(-ZM2,GAMZ*ZMASS))
21667       ZAMP3=ZHALF/(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))
21668       DWW=DCMPLX(RL)*ZAMP1+T3/(ZTWO*ZD(N1,N2))
21669       CWW=DCMPLX(RR)*ZAMP1
21670       AWW=DWW
21671       BWW=DWW-ZAMP3
21672       AWWM=AWW*HWHEW4(N1,N2,N3,N4,N5,N6)-BWW*HWHEW4(N1,N2,N5,N6,N3,N4)
21673       AWWP=CWW*(HWHEW4(N2,N1,N5,N6,N3,N4)-HWHEW4(N2,N1,N3,N4,N5,N6))
21674       AMPTEM=AWWM*DCONJG(AWWM)+AWWP*DCONJG(AWWP)
21675       AMP2=DREAL(AMPTEM)
21676 C AMP2 DOES NOT INCLUDE COLOR OR FLAVOR SUMS OR AVERAGES YET
21677 C NOR DOES IT INCLUDE TO THIS POINT KWW**2
21678 C 1 LEPTON FLAVOR IF APPROPRIATE FOR NFINAL CHOICE
21679       RKW=0.25D0/XW**2
21680       DO 6 I=1,4
21681 6     AMPWW(I)=AMP2*COLFAC(I)*RKW*RKW
21682       END
21683 CDECK  ID>, HWHEW4.
21684 *CMZ :-        -26/04/91  10.18.57  by  Bryan Webber
21685 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21686 C-----------------------------------------------------------------------
21687       FUNCTION HWHEW4(N1,N2,N3,N4,N5,N6)
21688 C-----------------------------------------------------------------------
21689       IMPLICIT NONE
21690       DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD
21691       INTEGER N1,N2,N3,N4,N5,N6
21692       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21693       HWHEW4=4*ZH(N1,N3)*ZCH(N2,N6)*(ZH(N1,N5)*ZCH(N1,N4)
21694      X                              +ZH(N3,N5)*ZCH(N3,N4))
21695       END
21696 CDECK  ID>, HWHEW5.
21697 *CMZ :          20/08/91  22.09.33  by  Federico Carminati
21698 *-- Author :    Zoltan Kunszt, modified by Mike Seymour
21699 C-----------------------------------------------------------------------
21700       SUBROUTINE HWHEW5(N1,N2,N3,N4,N5,N6,HELSUM,HELCTY,ID1,ID2)
21701 C-----------------------------------------------------------------------
21702 C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
21703 C OUTGOING ANTI-FERMIONS; 3,4 FOR Z0, 5,6 FOR Z0
21704 C
21705 C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
21706 C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
21707 C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
21708 C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
21709 C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
21710 C
21711 C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
21712 C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
21713 C FOR ON POLE APPROXIMATION AS DESIRED.
21714 C
21715 C---SLIGHTLY MODIFIED BY MHS, SO THAT HELCTY REFERS TO THE FINAL STATE
21716 C   INDICATED BY ID1,ID2
21717 C-----------------------------------------------------------------------
21718       IMPLICIT NONE
21719       DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMM(8),ZS134,ZS156,ZS234,ZS256,
21720      & ZTWO
21721       DOUBLE PRECISION CPFAC,CPALL,HELSUM,HELCTY,AMM
21722       INTEGER N1,N2,N3,N4,N5,N6,ID1,ID2,I
21723       EXTERNAL HWHEW4
21724       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21725       COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
21726       SAVE ZTWO
21727       DATA ZTWO/(2.0D0,0.0D0)/
21728 C THE MATRIX ELEMENT DEPENDS ON
21729       ZS134=(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))*ZTWO
21730       ZS156=(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))*ZTWO
21731       ZS234=(ZD(N2,N3)+ZD(N2,N4)+ZD(N3,N4))*ZTWO
21732       ZS256=(ZD(N2,N5)+ZD(N2,N6)+ZD(N5,N6))*ZTWO
21733       ZAMM(1)=HWHEW4(N1,N2,N3,N4,N5,N6)/ZS134+
21734      >        HWHEW4(N1,N2,N5,N6,N3,N4)/ZS156
21735       ZAMM(2)=HWHEW4(N1,N2,N4,N3,N5,N6)/ZS134+
21736      >        HWHEW4(N1,N2,N5,N6,N4,N3)/ZS156
21737       ZAMM(3)=HWHEW4(N1,N2,N3,N4,N6,N5)/ZS134+
21738      >        HWHEW4(N1,N2,N6,N5,N3,N4)/ZS156
21739       ZAMM(4)=HWHEW4(N1,N2,N4,N3,N6,N5)/ZS134+
21740      >        HWHEW4(N1,N2,N6,N5,N4,N3)/ZS156
21741       ZAMM(5)=HWHEW4(N2,N1,N3,N4,N5,N6)/ZS234+
21742      >        HWHEW4(N2,N1,N5,N6,N3,N4)/ZS256
21743       ZAMM(6)=HWHEW4(N2,N1,N4,N3,N5,N6)/ZS234+
21744      >        HWHEW4(N2,N1,N5,N6,N4,N3)/ZS256
21745       ZAMM(7)=HWHEW4(N2,N1,N3,N4,N6,N5)/ZS234+
21746      >        HWHEW4(N2,N1,N6,N5,N3,N4)/ZS256
21747       ZAMM(8)=HWHEW4(N2,N1,N4,N3,N6,N5)/ZS234+
21748      >        HWHEW4(N2,N1,N6,N5,N4,N3)/ZS256
21749       HELSUM=0.0
21750       HELCTY=0.0
21751       DO 1 I=1,8
21752         AMM=DREAL(ZAMM(I)*DCONJG(ZAMM(I)))
21753         HELSUM=HELSUM+CPALL(I)*AMM
21754         HELCTY=HELCTY+CPFAC(ID1,ID2,I)*AMM
21755  1    CONTINUE
21756       END
21757 CDECK  ID>, HWHEWW.
21758 *CMZ :-        -02/05/91  10.58.29  by  Federico Carminati
21759 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21760 C-----------------------------------------------------------------------
21761       SUBROUTINE HWHEWW
21762 C-----------------------------------------------------------------------
21763 C     E+E- -> W+W-/Z0Z0 (BASED ON ZOLTAN KUNSZT'S PROGRAM)
21764 C-----------------------------------------------------------------------
21765       INCLUDE 'herwig65.inc'
21766       DOUBLE COMPLEX ZH,ZCH,ZD
21767       DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,ETOT,STOT,FLUXW,GAMM,GIMM,
21768      & WM2,WXMIN,WX1MAX,WX2MAX,FJAC1,FJAC2,WX1,WX2,WMM1,WMM2,XXM,W2BO,
21769      & PST,WEIGHT,TOTSIG,WMASS,WWIDTH,ELST,CV,CA,BR,XMASS,PLAB,PRW,PCM,
21770      & AMPWW(4),CCC,HELSUM,HELCTY,BRZED(12),BRTOT,CPFAC,CPALL,RLL(12),
21771      & RRL(12),DIST(4)
21772       INTEGER IB,IBOS,I,ID1,ID2,NTRY,IDP(10),IDBOS(2),J1,J2,IPRC,ILST,
21773      & IDZOLT(16),MAP(12),NEWHEP
21774       LOGICAL EISBM1,HWRLOG
21775       EXTERNAL HWUAEM,HWRGEN,HWUPCM
21776       SAVE IDP,STOT,FLUXW,GAMM,GIMM,WM2,WXMIN,WX1MAX,FJAC1,ELST,ILST,
21777      & IDBOS,WMASS,WWIDTH,BRZED
21778       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
21779       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21780       COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
21781       SAVE IDZOLT,MAP
21782       DATA ELST,ILST/0.D0,0/
21783       DATA IDZOLT/4,3,8,7,12,11,4*0,2,1,6,5,10,9/
21784       DATA MAP/12,11,2,1,14,13,4,3,16,15,6,5/
21785       IF (IERROR.NE.0) RETURN
21786       EISBM1=IDHW(1).LT.IDHW(2)
21787       IF (GENEV) THEN
21788         NEWHEP=NHEP
21789         NHEP=NHEP+2
21790         DO 20 IB=1,2
21791         IBOS=IB+NEWHEP
21792         CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
21793         IF (EISBM1) PHEP(3,IBOS)=-PHEP(3,IBOS)
21794         CALL HWVZRO(4,VHEP(1,IBOS))
21795         CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
21796         CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
21797         IDHW(IBOS)=IDBOS(IB)
21798         IDHEP(IBOS)=IDPDG(IDBOS(IB))
21799         JMOHEP(1,IBOS)=1
21800         JMOHEP(2,IBOS)=2
21801         ISTHEP(IBOS)=110
21802         DO 10 I=1,2
21803           CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
21804           IF (EISBM1) PHEP(3,NHEP+I)=-PHEP(3,NHEP+I)
21805           CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
21806 C---STATUS, IDs AND POINTERS
21807           ISTHEP(NHEP+I)=112+I
21808           IDHW(NHEP+I)=IDP(2*IB+I)
21809           IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
21810           JDAHEP(I,IBOS)=NHEP+I
21811           JMOHEP(1,NHEP+I)=IBOS
21812           JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
21813  10     CONTINUE
21814         NHEP=NHEP+2
21815         JMOHEP(2,NHEP)=NHEP-1
21816         JDAHEP(2,NHEP)=NHEP-1
21817         JMOHEP(2,NHEP-1)=NHEP
21818         JDAHEP(2,NHEP-1)=NHEP
21819  20     CONTINUE
21820       ELSE
21821         EMSCA=PHEP(5,3)
21822         ETOT=EMSCA
21823         IPRC=MOD(IPROC,100)
21824         IF (ETOT.NE.ELST .OR. IPRC.NE.ILST) THEN
21825           STOT=ETOT*ETOT
21826           FLUXW=GEV2NB*.125*(HWUAEM(STOT)/PIFAC)**4/STOT
21827           IF (IPRC.EQ.0) THEN
21828             WMASS=RMASS(198)
21829             WWIDTH=GAMW
21830             IDBOS(1)=198
21831             IDBOS(2)=199
21832           ELSEIF (IPRC.EQ.50) THEN
21833             WMASS=RMASS(200)
21834             WWIDTH=GAMZ
21835             IDBOS(1)=200
21836             IDBOS(2)=200
21837 C---LOAD FERMION COUPLINGS TO Z
21838             DO 30 I=1,12
21839               RLL(I)=VFCH(MAP(I),1)+AFCH(MAP(I),1)
21840               RRL(I)=VFCH(MAP(I),1)-AFCH(MAP(I),1)
21841  30         CONTINUE
21842             RLL(11)=0
21843             RRL(11)=0
21844             BRTOT=0
21845             DO 60 J1=1,12
21846               BRZED(J1)=0
21847               DO 50 J2=1,12
21848                 CCC=1
21849                 IF (MOD(J1-1,4).GE.2) CCC=CCC*CAFAC
21850                 IF (MOD(J2-1,4).GE.2) CCC=CCC*CAFAC
21851                 CPFAC(J1,J2,1)=CCC*(RLL(2)**2*RLL(J1)*RLL(J2))**2
21852                 CPFAC(J1,J2,2)=CCC*(RLL(2)**2*RRL(J1)*RLL(J2))**2
21853                 CPFAC(J1,J2,3)=CCC*(RLL(2)**2*RLL(J1)*RRL(J2))**2
21854                 CPFAC(J1,J2,4)=CCC*(RLL(2)**2*RRL(J1)*RRL(J2))**2
21855                 CPFAC(J1,J2,5)=CCC*(RRL(2)**2*RLL(J1)*RLL(J2))**2
21856                 CPFAC(J1,J2,6)=CCC*(RRL(2)**2*RRL(J1)*RLL(J2))**2
21857                 CPFAC(J1,J2,7)=CCC*(RRL(2)**2*RLL(J1)*RRL(J2))**2
21858                 CPFAC(J1,J2,8)=CCC*(RRL(2)**2*RRL(J1)*RRL(J2))**2
21859                 DO 40 I=1,8
21860                   IF (J1.EQ.1.AND.J2.EQ.1) CPALL(I)=0
21861                   CPALL(I)=CPALL(I)+CPFAC(J1,J2,I)
21862                   BRZED(J1)=BRZED(J1)+CPFAC(J1,J2,I)
21863                   BRTOT=BRTOT+CPFAC(J1,J2,I)
21864  40             CONTINUE
21865  50           CONTINUE
21866  60         CONTINUE
21867             DO 70 I=1,12
21868  70           BRZED(I)=BRZED(I)/BRTOT
21869           ELSE
21870             CALL HWWARN('HWHEWW',500)
21871           ENDIF
21872           GAMM=WMASS*WWIDTH
21873           GIMM=1.D0/GAMM
21874           WM2=WMASS*WMASS
21875           WXMIN=ATAN(-WMASS/WWIDTH)
21876           WX1MAX=ATAN((STOT-WM2)*GIMM)
21877           FJAC1=WX1MAX-WXMIN
21878           ILST=IPRC
21879           ELST=ETOT
21880         ENDIF
21881         EVWGT=0
21882 C---CHOOSE W MASSES
21883         WX1=WXMIN+FJAC1*HWRGEN(1)
21884         WMM1=GAMM*TAN(WX1)+WM2
21885         IF (WMM1.LE.0) RETURN
21886         XMASS(1)=SQRT(WMM1)
21887         WX2MAX=ATAN(((ETOT-XMASS(1))**2-WM2)*GIMM)
21888         FJAC2=WX2MAX-WXMIN
21889         WX2=WXMIN+FJAC2*HWRGEN(2)
21890         WMM2=GAMM*TAN(WX2)+WM2
21891         IF (WMM2.LE.0) RETURN
21892         XMASS(2)=SQRT(WMM2)
21893         IF (HWRLOG(HALF))THEN
21894          XXM=XMASS(1)
21895          XMASS(1)=XMASS(2)
21896          XMASS(2)=XXM
21897         ENDIF
21898 C---CTMAX=ANGULAR CUT ON COS W-ANGLE
21899         CALL HWHEW0(1,ETOT,XMASS(1),PRW(1,1),W2BO,CTMAX)
21900         IF (W2BO.EQ.ZERO) RETURN
21901 C---FOR ZZ EVENTS, FORCE BOSE STATISTICS, BY KILLING EVENTS WITH COS1<0
21902         IF (IPRC.NE.0) THEN
21903           IF (PRW(3,1).LT.ZERO) RETURN
21904 C---AND THEN SYMMETRIZE (THIS PROCEDURE VASTLY IMPROVES EFFICIENCY)
21905           IF (HWRLOG(HALF)) THEN
21906             PRW(3,1)=-PRW(3,1)
21907             PRW(3,2)=-PRW(3,2)
21908           ENDIF
21909         ENDIF
21910         PLAB(3,1)=0.5*ETOT
21911         PLAB(4,1)=PLAB(3,1)
21912         PLAB(3,2)=-PLAB(3,1)
21913         PLAB(4,2)=PLAB(3,1)
21914 C
21915 C---LET THE W BOSONS DECAY
21916         NTRY=0
21917  80     NTRY=NTRY+1
21918         DO 90 IB=1,2
21919         CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,1)
21920         PST=HWUPCM(XMASS(IB),RMASS(ID1),RMASS(ID2))
21921         IF (PST.LT.ZERO) THEN
21922           CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,2)
21923           IF (NTRY.LE.NBTRY) GOTO 80
21924 C          CALL HWWARN('HWHEWW',1)
21925           RETURN
21926         ENDIF
21927         PRW(5,IB)=XMASS(IB)
21928         IDP(2*IB+1)=ID1
21929         IDP(2*IB+2)=ID2
21930         PLAB(5,2*IB+1)=RMASS(ID1)
21931         PLAB(5,2*IB+2)=RMASS(ID2)
21932         CALL HWDTWO(PRW(1,IB),PLAB(1,2*IB+1),PLAB(1,2*IB+2),
21933      &              PST,TWO,.TRUE.)
21934  90     CONTINUE
21935         WEIGHT=FLUXW*W2BO*FJAC1*FJAC2*(0.5D0*PIFAC*GIMM)**2
21936         CALL HWHEW1(6)
21937         CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
21938         IF (IPRC.EQ.0) THEN
21939           CALL HWHEW3(5,6,3,4,1,2,AMPWW)
21940           TOTSIG=9.*AMPWW(1)+6.*(AMPWW(2)+AMPWW(3))+4.*AMPWW(4)
21941           EVWGT=TOTSIG*WEIGHT*BR
21942         ELSE
21943           ID1=IDZOLT(IDPDG(IDP(3)))
21944           ID2=IDZOLT(IDPDG(IDP(5)))
21945           CALL HWHEW5(5,6,3,4,1,2,HELSUM,HELCTY,ID1,ID2)
21946           EVWGT=HELCTY*WEIGHT*BR/(BRZED(ID1)*BRZED(ID2))
21947         ENDIF
21948       ENDIF
21949       END
21950 CDECK  ID>, HWHGBP.
21951 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
21952 *-- Author :    Peter Richardson
21953 C-----------------------------------------------------------------------
21954       SUBROUTINE HWHGBP
21955 C-----------------------------------------------------------------------
21956 C     Hadron-Hadron to WW/WZ/ZZ (BASED ON ZOLTAN KUNSZT'S PROGRAM)
21957 C-----------------------------------------------------------------------
21958       INCLUDE 'herwig65.inc'
21959       DOUBLE COMPLEX ZH,ZCH,ZD
21960       DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,FLUXW,CSW,XMASS,
21961      &     PLAB,PRW,PCM,HWRUNI,P(5,10),AMPWW,DIST(4),MW2,CFAC1,AMP,
21962      &     MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),FPI4
21963       INTEGER IB,IBOS,I,IDP,IDBOS,IPRC,NEWHEP,J,ICMF,IHEP,IBRAD,K,IOPT,
21964      &     MAP(4),IDRES
21965       LOGICAL PHOTON,GEN
21966       EXTERNAL HWUAEM,HWRGEN,HWUPCM,HWRUNI
21967       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21968       COMMON/HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
21969       COMMON /HWBOSN/XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
21970      &     IDRES,IDP(10),IOPT
21971       SAVE AMPWW,IPRC,PHOTON
21972       PARAMETER(FPI4=24936.72731D0)
21973       DOUBLE PRECISION WI(IMAXCH)
21974       COMMON /HWPSOM/ WI
21975       SAVE MAP
21976       DATA MAP/1,2,11,12/
21977       IF (IERROR.NE.0) RETURN
21978       IF (GENEV) THEN
21979         IF (IPRC.EQ.0) THEN
21980           CALL HWHGB2(AMPWW,IDP,PHOTON)
21981         ELSEIF(IPRC.EQ.10) THEN
21982           CALL HWHGB3(AMPWW,IDP,PHOTON)
21983         ELSEIF(IPRC.EQ.20) THEN
21984           CALL HWHGB4(AMPWW,IDP,PHOTON)
21985           IF((IDP(1).LE.6.AND.MOD(IDP(1),2).EQ.1).OR.
21986      &       (IDP(2).LE.6.AND.MOD(IDP(2),2).EQ.1)) THEN
21987             IDBOS(1)=199
21988             IDP(3) = IDP(3)+6
21989             IDP(4) = IDP(4)-6
21990           ENDIF
21991         ENDIF
21992 C--change the sign of the z component (in CMF) if particle first
21993         IF(IDP(1).LT.IDP(2)) THEN
21994           DO IB=1,2
21995             PRW(3,IB) = -PRW(3,IB)
21996             DO I=1,2
21997               PLAB(3,2*IB+I)=-PLAB(3,2*IB+I)
21998             ENDDO
21999           ENDDO
22000         ENDIF
22001 C--boost particles back to the lab frame from the centre of mass frame
22002         DO IB=1,2
22003           CALL HWULOB(PLAB(1,7),PRW(1,IB),PRW(1,IB))
22004         ENDDO
22005         DO I=1,6
22006           CALL HWULOB(PLAB(1,7),PLAB(1,I),PLAB(1,I))
22007         ENDDO
22008 C--put the particles in the event record
22009 C--first the incoming quarks
22010         ICMF = NHEP+3
22011         DO I=1,2
22012           IHEP = NHEP+I
22013           CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
22014           IDHW(IHEP) = IDP(I)
22015           IDHEP(IHEP)=IDPDG(IDP(I))
22016           ISTHEP(IHEP)=110+I
22017           JMOHEP(1,IHEP)=ICMF
22018           JMOHEP(I,ICMF)=IHEP
22019           JDAHEP(1,IHEP)=ICMF
22020         ENDDO
22021         JMOHEP(2,NHEP+1) = NHEP+2
22022         JMOHEP(2,NHEP+2) = NHEP+1
22023         JDAHEP(2,NHEP+1) = NHEP+2
22024         JDAHEP(2,NHEP+2) = NHEP+1
22025 C--Centre-of-mass energy
22026         ICMF = NHEP+3
22027 C--new for spin correlations
22028         IF(SYSPIN) THEN
22029           IDSPN(1) = ICMF
22030           ISNHEP(ICMF) = 1
22031           JMOSPN(1) = 0
22032           JDASPN(1,1) = 2
22033           JDASPN(2,1) = 5
22034           DECSPN(1) = .FALSE.
22035         ENDIF
22036         IDHW(ICMF)=15
22037         IDHEP(ICMF)=IDPDG(15)
22038         ISTHEP(ICMF)=110
22039         CALL HWVEQU(5,PLAB(1,7),PHEP(1,ICMF))
22040         CALL HWUMAS(PHEP(1,ICMF))
22041         JDAHEP(1,ICMF) = ICMF+1
22042         JDAHEP(2,ICMF) = ICMF+2
22043         NHEP   = NHEP+3
22044         NEWHEP = NHEP
22045         NHEP   = NHEP+2
22046 C--Now the bosons
22047         DO IB=1,2
22048           IBOS=IB+NEWHEP
22049           CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
22050           CALL HWVZRO(4,VHEP(1,IBOS))
22051           CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
22052           CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
22053           IDHW(IBOS)=IDBOS(IB)
22054           IDHEP(IBOS)=IDPDG(IDBOS(IB))
22055           JMOHEP(1,IBOS)=ICMF
22056           JMOHEP(2,IBOS)=ICMF
22057           JDAHEP(2,IBOS)=IBOS
22058           ISTHEP(IBOS)=112+IB
22059         ENDDO
22060 C--now generate the initial state shower
22061         CALL HWBGEN
22062         IF(IERROR.NE.0) RETURN
22063 C--now add the outgoing fermions to the event record
22064         DO 20 IB=1,2
22065         IBOS=IB+NEWHEP
22066         IBRAD = JDAHEP(1,IBOS)
22067         ISTHEP(IBRAD) = 195
22068         DO 10 I=1,2
22069           CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
22070           CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
22071 C--Boost the fermion momenta to the rest frame of the original W
22072           CALL HWULOF(PRW(1,IB),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
22073 C--Now boost back to the lab from rest frame of the W after radiation
22074           CALL HWULOB(PHEP(1,IBRAD),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
22075 C--Set the status and pointers
22076           ISTHEP(NHEP+I)=112+I
22077           IDHW(NHEP+I)=IDP(2*IB+I)
22078           IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
22079           JDAHEP(I,IBRAD)=NHEP+I
22080           JMOHEP(1,NHEP+I)=IBRAD
22081 C--New for spin correlations
22082           IF(SYSPIN) THEN
22083             ISNHEP(NHEP+I)   = 2*IB+I-1
22084             IDSPN(2*IB+I-1)  = NHEP+I
22085             JMOSPN(2*IB+I-1) = 1
22086             DECSPN(2*IB+I-1) = .FALSE.
22087             RHOSPN(1,1,2*IB+I-1) = HALF
22088             RHOSPN(1,2,2*IB+I-1) = ZERO
22089             RHOSPN(2,1,2*IB+I-1) = ZERO
22090             RHOSPN(2,2,2*IB+I-1) = HALF
22091             NSPN = NSPN+1
22092           ENDIF
22093  10     CONTINUE
22094         NHEP=NHEP+2
22095         JMOHEP(2,NHEP)=NHEP-1
22096         JDAHEP(2,NHEP)=NHEP-1
22097         JMOHEP(2,NHEP-1)=NHEP
22098         JDAHEP(2,NHEP-1)=NHEP
22099  20     CONTINUE
22100       ELSE
22101         IF(FSTWGT) THEN
22102           IPRC=MOD(IPROC,100)
22103           IF(MOD(IPRC,5).EQ.0.AND.MOD(IPRC,10).NE.0) THEN
22104             PHOTON = .FALSE.
22105             IPRC = IPRC-5
22106           ELSE
22107             PHOTON = .TRUE.
22108           ENDIF
22109           IOPT=1
22110           IF (IPRC.EQ.0) THEN
22111 C--WW production
22112             IDBOS(1)=199
22113             IDBOS(2)=198
22114             IDRES   =200
22115 C--ZZ production
22116           ELSEIF (IPRC.EQ.10) THEN
22117             IDBOS(1)=200
22118             IDBOS(2)=200
22119             IDRES   =200
22120           ELSEIF(IPRC.EQ.20) THEN
22121 C--WZ production
22122             IDBOS(1)=198
22123             IDBOS(2)=200
22124             IDRES   =198
22125             IOPT = 0
22126           ELSE
22127             CALL HWWARN('HWHGBP',500)
22128           ENDIF
22129 C--calculate the couplings etc
22130           MW2 = RMASS(198)**2
22131           GMW = RMASS(198)*GAMW
22132           MZ2 = RMASS(200)**2
22133           GMZ = RMASS(200)*GAMZ
22134 C--couplings to Z and photon
22135           DO I=1,4
22136             G(I,1) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
22137             G(I,2) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
22138             EE(I)  = QFCH(MAP(I))
22139           ENDDO
22140 C--elements of the CKM matrix for the various decay modes of the W
22141           DO I=1,3
22142             DO J=1,3
22143 C**Bug fix 2/7/01 by BRW (unsquare)
22144               CKM2(3*I-3+J) = VCKM(J,I)
22145 C**End bug fix
22146             ENDDO
22147             CKM2(9+I) = ONE
22148           ENDDO
22149 C--couplings of the up and down
22150           TAUI(1) = -ONE
22151           TAUI(2) =  ONE
22152           DO I=1,2
22153             RF(I)   = -TWO*QFCH(I)*SWEIN
22154             LF(I)   = TAUI(I)+RF(I)
22155           ENDDO
22156           CFAC1 = ONE/THREE
22157           CSW = SQRT((ONE-SWEIN)/SWEIN)
22158         ENDIF
22159         EVWGT=ZERO
22160 C--find the momenta and the phase space weight
22161         CALL HWHGBS(FLUXW,GEN)
22162         IF(.NOT.GEN) RETURN
22163 C--couplings
22164         AMP = FPI4*HWUAEM(EMSCA**2)**4
22165 C--copy the momenta and change the sign of the beam
22166         DO I=1,6
22167           P(1,I)=PLAB(3,I)
22168           P(2,I)=PLAB(1,I)
22169           P(3,I)=PLAB(2,I)
22170           P(4,I)=PLAB(4,I)
22171         ENDDO
22172         DO 120 J=1,4
22173         DO 130 K=3,6
22174   130   PCM(J,K)=P(J,K)
22175         PCM(J,1)=-P(J,1)
22176         PCM(J,2)=-P(J,2)
22177   120   CONTINUE
22178 C--use the e+e- code to calulate the spinor products
22179         CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
22180 C--calculate the matrix elements
22181        IF (IPRC.EQ.0) THEN
22182 C--WW matrix element
22183          CALL HWHGB2(AMPWW,IDP,PHOTON)
22184        ELSEIF(IPRC.EQ.10) THEN
22185 C--ZZ matrix element
22186          CALL HWHGB3(AMPWW,IDP,PHOTON)
22187        ELSEIF(IPRC.EQ.20) THEN
22188 C--WZ matrix element
22189          CALL HWHGB4(AMPWW,IDP,PHOTON)
22190        ENDIF
22191 C--Now calculate the cross section
22192        EVWGT = AMPWW*FLUXW*AMP
22193        IF(OPTM) THEN
22194          DO I=1,IMAXCH
22195            IF(CHON(I)) WI(I) = WI(I)*AMPWW**2*AMP**2
22196          ENDDO
22197        ENDIF
22198       ENDIF
22199       END
22200 CDECK  ID>, HWHGBS.
22201 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22202 *-- Author :    Peter Richardson
22203 C-----------------------------------------------------------------------
22204       SUBROUTINE HWHGBS(WEIGHT,GEN)
22205 C-----------------------------------------------------------------------
22206 C     Multichannel phase space for gauge boson pair production
22207 C     ICH returns the channel used if OPTM=.FALSE.
22208 C     ICH specifies the channel to be used if OPTM=.TRUE.
22209 C     This is used in optimising the weights for the different channels
22210 C-----------------------------------------------------------------------
22211       INCLUDE 'herwig65.inc'
22212       INTEGER ICH,IDBOS,ISM(2,IMAXCH),I,J,IB(2),IDRES,IDP,IOPT,IPRC,ID1
22213       DOUBLE PRECISION XMASS,PLAB,PRW,PCM,RAND,HWRGEN,BMS2(2),TJAC,PLM,
22214      &     MJAC(2),TWOPI2,SJAC,STOT,THAT,UHAT,TMIN,TMAX,UMIN,UMAX,PS(2),
22215      &     ETOT,HWUPCM,PST,HWRUNI,TAU,XJAC,PHI,SINTH,SIG(2),CV,CA,BR(2),
22216      &     G(IMAXCH),XF,DEM,TN,UN,SN,S1,S2,MB1,MB2,WEIGHT,BRFAC,BRZ(12)
22217       LOGICAL HWRLOG,GEN
22218       COMMON /HWBOSN/ XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
22219      &     IDRES,IDP(10),IOPT
22220       EXTERNAL HWRGEN,HWRLOG,HWUPCM,HWRUNI
22221       SAVE ISM,IPRC
22222       PARAMETER(TWOPI2=39.4784176D0)
22223       DOUBLE PRECISION WI(IMAXCH)
22224       COMMON /HWPSOM/ WI
22225       SAVE SIG,BRZ
22226       DATA SIG/1.0D0,-1.0D0/
22227       DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
22228      &         0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
22229       IF(IERROR.NE.0) RETURN
22230       WEIGHT = ZERO
22231       IF(OPTM) THEN
22232         DO I=1,IMAXCH
22233           WI(I) = ZERO
22234         ENDDO
22235       ENDIF
22236       GEN = .FALSE.
22237 C--set the smoothing for the bosons in the various channels
22238       IF(FSTWGT) THEN
22239         IPRC = MOD(IPROC,100)
22240         DO I=1,2
22241           ISM(1,I) = 1
22242           DO J=1,2
22243             ISM(1,4*I-2+J  ) = 1
22244             ISM(1,4*I+J    ) = 2
22245             ISM(2,4*I+2*J-3) = 1
22246             ISM(2,4*I+2*J-2) = 2
22247           ENDDO
22248         ENDDO
22249         ISM(2,1) = 1
22250         ISM(2,2) = 2
22251       ENDIF
22252 C--select the channel to be used
22253       RAND=HWRGEN(0)
22254       DO ICH=1,IMAXCH
22255         IF(CHON(ICH)) THEN
22256           IF(CHNPRB(ICH).GT.RAND) GOTO 10
22257           RAND = RAND-CHNPRB(ICH)
22258         ENDIF
22259       ENDDO
22260  10   CONTINUE
22261 C--select the boson masses and compute that part of the denominator
22262 C--decide which boson to do first
22263       IF(HWRLOG(HALF)) THEN
22264         IB(1) = 1
22265         IB(2) = 2
22266       ELSE
22267         IB(1) = 2
22268         IB(2) = 1
22269       ENDIF
22270 C--find the boson masses
22271       CALL HWHGB1(ISM(IB(1),ICH),2,IDBOS(IB(1)),MJAC(IB(1)),BMS2(IB(1)),
22272      &     (PHEP(5,3)-EMMIN)**2,EMMIN**2)
22273       XMASS(IB(1)) = SQRT(BMS2(IB(1)))
22274       CALL HWHGB1(ISM(IB(2),ICH),2,IDBOS(IB(2)),MJAC(IB(2)),BMS2(IB(2)),
22275      &     (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
22276       XMASS(IB(2)) = SQRT(BMS2(IB(2)))
22277       DO I=1,2
22278         MJAC(I) = HALF*MJAC(I)/TWOPI2
22279       ENDDO
22280 C--now generate the values of s
22281 C--according to a Breit-Wigner for the first two
22282       IF(ICH.LE.2) THEN
22283         CALL HWHGB1(1,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
22284      &        (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
22285 C--according to a power law for the rest
22286       ELSE
22287         CALL HWHGB1(2,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
22288      &        (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
22289       ENDIF
22290       ETOT = SQRT(STOT)
22291 C--find the centre of mass momenta
22292       PST = HWUPCM(ETOT,XMASS(1),XMASS(2))
22293       IF(PST.LT.PTMIN) RETURN
22294       PRW(4,1) = SQRT(BMS2(1)+PST**2)
22295       PRW(4,2) = SQRT(BMS2(2)+PST**2)
22296 C--now generate the value of t and u
22297       PLM = SQRT(PST**2-PTMIN**2)
22298       TMIN   = BMS2(1)-ETOT*(PRW(4,1)+PLM)
22299       TMAX   = BMS2(1)-ETOT*(PRW(4,1)-PLM)
22300       UMIN   = BMS2(2)-ETOT*(PRW(4,2)+PLM)
22301       UMAX   = BMS2(2)-ETOT*(PRW(4,2)-PLM)
22302       SN     = ONE/(TMAX-TMIN)
22303 C--for the first two channels uniform in t
22304       IF(ICH.LE.2) THEN
22305         THAT = HWRUNI(1,TMIN,TMAX)
22306         UHAT = BMS2(1)+BMS2(2)-STOT-THAT
22307         TJAC = TMAX-TMIN
22308 C--for the next four channels generate t according to 1/t
22309       ELSEIF(ICH.LE.6) THEN
22310         CALL HWHGB5(2,TJAC,THAT,TMAX,TMIN)
22311         UHAT = BMS2(1)+BMS2(2)-STOT-THAT
22312 C--for the last four channels generate u according to 1/u
22313       ELSEIF(ICH.LE.10) THEN
22314         CALL HWHGB5(2,TJAC,UHAT,UMAX,UMIN)
22315         THAT = BMS2(1)+BMS2(2)-STOT-UHAT
22316       ELSE
22317         CALL HWWARN('HWHGBS',500)
22318       ENDIF
22319       CALL HWHGB5(1,TN,THAT,TMAX,TMIN)
22320       CALL HWHGB5(1,UN,UHAT,UMAX,UMIN)
22321 C--generate the parton momentum fractions and find the pdf's
22322       TAU = STOT/PHEP(5,3)**2
22323       XX(1) = EXP(HWRUNI(3,LOG(TAU),ZERO))
22324       XX(2) = TAU/XX(1)
22325       XJAC = -LOG(TAU)*XX(1)
22326       XF   = ONE/XJAC
22327       EMSCA=ETOT
22328       CALL HWSGEN(.FALSE.)
22329 C--Centre of mass collison angle
22330       COSTH = (THAT-BMS2(1)+ETOT*PRW(4,1))/ETOT/PST
22331       PHI   = HWRUNI(4,ZERO,TWO*PIFAC)
22332       SINTH = SQRT(ONE-COSTH**2)
22333 C--incoming momenta in the centre of mass frame
22334       DO I=1,2
22335         PLAB(1,I) = ZERO
22336         PLAB(2,I) = ZERO
22337         PLAB(3,I) = HALF*ETOT
22338         PLAB(4,I) = HALF*ETOT
22339         PLAB(5,I) = ZERO
22340       ENDDO
22341       PLAB(3,2) = -PLAB(3,2)
22342 C--outgoing boson momenta in the centre of mass frame
22343       DO I=1,2
22344         PRW(1,I) = SIG(I)*SINTH*COS(PHI)*PST
22345         PRW(2,I) = SIG(I)*SINTH*SIN(PHI)*PST
22346         PRW(3,I) = SIG(I)*COSTH*PST
22347         PRW(5,I) = XMASS(I)
22348       ENDDO
22349 C--now find the boson decay products
22350 C--find the momenta of the boson decay products
22351       IF(IPRC.EQ.20) IDBOS(1)=198
22352       DO 90 I=1,2
22353         CALL HWDBZ2(IDBOS(I),IDP(2*I+1),IDP(2*I+2),CV,CA,BR(I),IOPT,
22354      &        XMASS(I))
22355         IF(BR(I).EQ.ZERO) RETURN
22356         PRW(5,I)=XMASS(I)
22357         PLAB(5,2*I+1) = ZERO
22358         PLAB(5,2*I+2) = ZERO
22359         PS(I) = HALF*XMASS(I)
22360         PLAB(5,2*I+1)=ZERO
22361         PLAB(5,2*I+2)=ZERO
22362         CALL HWDTWO(PRW(1,I),PLAB(1,2*I+1),PLAB(1,2*I+2),
22363      &              PS(I),TWO,.TRUE.)
22364  90   CONTINUE
22365       BRFAC = BR(2)
22366       IF(IOPT.EQ.0) BRFAC = BRFAC*BR(1)
22367       DO I=1,2
22368          IF(IDBOS(I).EQ.200) THEN
22369             ID1 = IDP(1+2*I)
22370             IF(ID1.GE.121) ID1 = ID1-114
22371             BRFAC = BRFAC/BRZ(ID1)
22372          ENDIF
22373       ENDDO
22374       DO I=1,2
22375         MJAC(I) = MJAC(I)*PS(I)/XMASS(I)
22376       ENDDO
22377 C--set up a vector with the centre of mass
22378       PLAB(1,7) = ZERO
22379       PLAB(2,7) = ZERO
22380       PLAB(3,7) = HALF*PHEP(5,3)*(XX(1)-XX(2))
22381       PLAB(4,7) = HALF*PHEP(5,3)*(XX(1)+XX(2))
22382       PLAB(5,7) = ETOT
22383 C--now find the denominator
22384       CALL HWHGB1(1,1,IDRES,S1,STOT,PHEP(5,3)**2,
22385      &     (XMASS(1)+XMASS(2))**2)
22386       CALL HWHGB1(2,1,IDRES,S2,STOT,PHEP(5,3)**2,
22387      &        (XMASS(1)+XMASS(2))**2)
22388       DEM = ZERO
22389       DO I=1,IMAXCH
22390         IF(CHON(I)) THEN
22391 C--factors due to the choice of s and t
22392           IF(I.LE.2) THEN
22393             G(I) = SN*S1
22394           ELSEIF(I.LE.6) THEN
22395             G(I) = TN*S2
22396           ELSE
22397             G(I) = UN*S2
22398           ENDIF
22399 C--factors due to the boson masses
22400           CALL HWHGB1(ISM(IB(1),I),1,IDBOS(IB(1)),MB1,BMS2(IB(1)),
22401      &         (PHEP(5,3)-EMMIN)**2,EMMIN**2)
22402           CALL HWHGB1(ISM(IB(2),I),1,IDBOS(IB(2)),MB2,BMS2(IB(2)),
22403      &         (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
22404           G(I)   = G(I)*MB1*MB2*XF
22405           DEM = DEM+CHNPRB(I)*G(I)
22406         ENDIF
22407       ENDDO
22408 C--now combine everything to get the weight
22409       WEIGHT = GEV2NB*TJAC*SJAC*G(ICH)/DEM/XX(1)*
22410      &     MJAC(1)*MJAC(2)*XJAC/64.0D0/PIFAC/STOT**3*BRFAC
22411       GEN = .TRUE.
22412 C--compute the weights for the different channels if optimizing
22413       IF(OPTM) THEN
22414         DO I=1,IMAXCH
22415           IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
22416         ENDDO
22417       ENDIF
22418       END
22419 CDECK  ID>, HWHGB1.
22420 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22421 *-- Author :    Peter Richardson
22422 C-----------------------------------------------------------------------
22423       SUBROUTINE HWHGB1(ISM,IOPT,IDBOZ,FJAC,MBOS2,MMAX,MMIN)
22424 C-----------------------------------------------------------------------
22425 C     Subroutine to select gauge boson mass for HWHGBP
22426 C     ISM=1 select according to Breit-Wigner for IDBOZ
22427 C     ISM=2 select according to power law  for IDBOZ
22428 C     IOPT=1 return the function at MBOS2
22429 C     IOPT=2 calculate MBOS2
22430 C-----------------------------------------------------------------------
22431       INCLUDE 'herwig65.inc'
22432       INTEGER IDBOZ,ISM,IOPT
22433       DOUBLE PRECISION MBOZ,FJAC,GBOZ,GMBOZ,MPOW,MMIN,
22434      &     MBOS2,A1,A2,A01,A02,RPOW,QPOW,HWRGEN,MMAX,EMSQ
22435       EXTERNAL HWRGEN
22436 C--set the boson mass
22437       IF(IDBOZ.EQ.198.OR.IDBOZ.EQ.199) THEN
22438         MBOZ = RMASS(198)
22439         GBOZ = GAMW
22440       ELSEIF(IDBOZ.EQ.200) THEN
22441         MBOZ = RMASS(200)
22442         GBOZ = GAMZ
22443       ELSE
22444         CALL HWWARN('HWHGB1',500)
22445       ENDIF
22446       EMSQ=MBOZ**2
22447       GMBOZ=MBOZ*GBOZ
22448 C--smooth a Breit-Wigner only
22449       IF(ISM.EQ.1) THEN
22450         A02   = ATAN((MMIN-EMSQ)/GMBOZ)
22451         A2    = ATAN((MMAX-EMSQ)/GMBOZ)-A02
22452         IF(IOPT.EQ.1) THEN
22453           FJAC = GMBOZ/((MBOS2-EMSQ)**2+GMBOZ**2)/A2
22454         ELSE
22455           MBOS2 = EMSQ+GMBOZ*TAN(A02+A2*HWRGEN(1))
22456           FJAC  = A2*((MBOS2-EMSQ)**2+GMBOZ**2)/GMBOZ
22457         ENDIF
22458 C--smooth a powerlaw only
22459       ELSEIF(ISM.EQ.2) THEN
22460         IF(EMPOW.EQ.TWO) THEN
22461           A01   = LOG(MMIN)
22462           A1    = LOG(MMAX)-A01
22463           IF(IOPT.EQ.1) THEN
22464             FJAC = ONE/MBOS2/A1
22465           ELSE
22466             MBOS2 = EXP(A01+A1*HWRGEN(2))
22467             FJAC  = A1*MBOS2
22468           ENDIF
22469         ELSE
22470           MPOW = -EMPOW/TWO
22471           QPOW =  ONE+MPOW
22472           RPOW =  ONE/QPOW
22473           A01  =  MMIN**QPOW
22474           A1   = (MMAX**QPOW-A01)
22475           IF(IOPT.EQ.1) THEN
22476             FJAC = QPOW*MBOS2**MPOW/A1
22477           ELSE
22478             MBOS2 = (A01+A1*HWRGEN(2))**RPOW
22479             FJAC  = A1*RPOW/MBOS2**MPOW
22480           ENDIF
22481         ENDIF
22482       ELSE
22483         CALL HWWARN('HWHGB1',501)
22484       ENDIF
22485       END
22486 CDECK  ID>, HWHGB2.
22487 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22488 *-- Author :    Peter Richardson
22489 C-----------------------------------------------------------------------
22490       SUBROUTINE HWHGB2(HCS,IDP,PHOTON)
22491 C-----------------------------------------------------------------------
22492 C     WW cross section in hadron hadron
22493 C-----------------------------------------------------------------------
22494       INCLUDE 'herwig65.inc'
22495       DOUBLE PRECISION HCS,RCS,HWRGEN,DIST(2),CFAC,WAMP(2),S34,S56,KWW2,
22496      &     MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
22497      &     CSW,CFAC1
22498       DOUBLE COMPLEX ZH,ZCH,ZD,Z1,Z2,ZHF,P12,Z12,S134,S156,AWW,BWW,
22499      &     CWW,DWW,AWWM(2),AWWP(2),HWHEW4
22500       INTEGER IDP(10),I,I1,I2,MAPZ(4,3),P1,P2,P3,P4
22501       PARAMETER(Z1=(0.0D0,1.0D0),Z2=(2.0D0,0.0D0),
22502      &          ZHF=(0.5D0,0.0D0))
22503       LOGICAL PHOTON
22504       EXTERNAL HWRGEN,HWHEW4
22505       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22506       COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22507       SAVE WAMP,AWWM,AWWP
22508       SAVE MAPZ
22509       DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
22510       IF(GENEV) THEN
22511         RCS = HCS*HWRGEN(1)
22512       ELSE
22513 C--Now calculate the matrix element
22514         Z12  = ONE/(Z2*ZD(1,2)-MZ2+Z1*GMZ)
22515         P12  = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/ZD(1,2)
22516         S134 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22517         S156 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22518         S34  = DBLE(Z2*ZD(3,4))
22519         S56  = DBLE(Z2*ZD(5,6))
22520         KWW2 = ONE/((S34-MW2)**2+GMW**2)/((S56-MW2)**2+GMW**2)
22521      &            /SWEIN**4/16.0D0
22522         DO I=1,2
22523           DWW     = LF(I)*Z12-RF(I)*P12
22524           CWW     = RF(I)*(Z12-P12)
22525           AWW     = DWW + ZHF*S134*(TAUI(I)+ONE)
22526           BWW     = DWW + ZHF*S156*(TAUI(I)-ONE)
22527           AWWM(I) = AWW*HWHEW4(1,2,3,4,5,6)-BWW*HWHEW4(1,2,5,6,3,4)
22528           AWWP(I) = CWW*(HWHEW4(2,1,5,6,3,4)-HWHEW4(2,1,3,4,5,6))
22529           WAMP(I) = KWW2*DBLE( AWWM(I)*DCONJG(AWWM(I))
22530      &                        +AWWP(I)*DCONJG(AWWP(I)))
22531         ENDDO
22532       ENDIF
22533       HCS = ZERO
22534       CFAC = CFAC1*81.0D0
22535       DO I=1,2
22536         DO I1=1,3
22537           IDP(1) = MAPZ(I,I1)
22538           IDP(2) = IDP(1)+6
22539           DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
22540           DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
22541           DO I2=1,2
22542             HCS = HCS+DIST(I2)*CFAC*WAMP(I)
22543             IF(GENEV.AND.HCS.GT.RCS) THEN
22544 C--new for spin correlations
22545               IF(SYSPIN) THEN
22546                 NSPN = 1
22547                 DO 10 P1=1,2
22548                 DO 10 P2=1,2
22549                 DO 10 P3=1,2
22550                 DO 10 P4=1,2
22551  10             MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
22552                 MESPN(1,2,2,1,1,1) = AWWP(I)
22553                 MESPN(2,2,2,1,1,1) = AWWM(I)
22554                 NCFL(1) = 1
22555                 SPNCFC(1,1,1) = ONE
22556               ENDIF
22557               GOTO 999
22558             ENDIF
22559             IDP(1) = IDP(1)+6
22560             IDP(2) = IDP(2)-6
22561           ENDDO
22562         ENDDO
22563       ENDDO
22564  999  RETURN
22565       END
22566 CDECK  ID>, HWHGB3.
22567 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22568 *-- Author :    Peter Richardson
22569 C-----------------------------------------------------------------------
22570       SUBROUTINE HWHGB3(HCS,IDP,PHOTON)
22571 C-----------------------------------------------------------------------
22572 C     ZZ cross section in hadron hadron
22573 C-----------------------------------------------------------------------
22574       INCLUDE 'herwig65.inc'
22575       DOUBLE PRECISION AMP(2),RCS,HCS,HWRGEN,DIST(2),S34,S56,CFAC,
22576      &     MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
22577      &     CSW,CFAC1
22578       DOUBLE COMPLEX ZH,ZCH,ZD,P34,P56,Z34,Z56,Z1,ZAMP(8),S134,S156,
22579      &        HWHEW4,TAMP,Z0,AMPT(2,2,2,2),CP
22580       INTEGER I,P1,P2,P3,IDP(10),I2,MAPZ(4,3),I1,ID(2),O(2)
22581       EXTERNAL HWHEW4,HWRGEN
22582       LOGICAL PHOTON
22583       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22584       COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22585       PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
22586       SAVE AMP,ID,AMPT
22587       SAVE MAPZ,O
22588       DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
22589       DATA O/2,1/
22590 C--initialisation
22591       IF(GENEV) THEN
22592          RCS = HCS*HWRGEN(0)
22593       ELSE
22594 C--Identitiys of the decay prodcucts (d=1,u=2,e=3,nu=4)
22595         DO I=1,2
22596           ID(I) = IDP(1+2*I)
22597           IF(ID(I).GE.121) ID(I) = ID(I)-114
22598           ID(I) = MOD(ID(I)+1,2)+2*INT((ID(I)-1)/6)+1
22599         ENDDO
22600 C--the various propagators we need
22601         S34 = TWO*DBLE(ZD(3,4))
22602         S56 = TWO*DBLE(ZD(5,6))
22603         Z34 = ONE/(S34-MZ2+Z1*GMZ)
22604         Z56 = ONE/(S56-MZ2+Z1*GMZ)
22605         IF(PHOTON) THEN
22606           P34 = Z34*(S34-MZ2)/S34
22607           P56 = Z56*(S56-MZ2)/S56
22608         ELSE
22609           P34 = Z0
22610           P56 = Z0
22611         ENDIF
22612         S134 = HALF/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22613         S156 = HALF/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22614 C--Now calculate the amplitudes
22615         ZAMP(1)=HWHEW4(1,2,3,4,5,6)*S134+HWHEW4(1,2,5,6,3,4)*S156
22616         ZAMP(2)=HWHEW4(1,2,4,3,5,6)*S134+HWHEW4(1,2,5,6,4,3)*S156
22617         ZAMP(3)=HWHEW4(1,2,3,4,6,5)*S134+HWHEW4(1,2,6,5,3,4)*S156
22618         ZAMP(4)=HWHEW4(1,2,4,3,6,5)*S134+HWHEW4(1,2,6,5,4,3)*S156
22619         ZAMP(5)=HWHEW4(2,1,3,4,5,6)*S156+HWHEW4(2,1,5,6,3,4)*S134
22620         ZAMP(6)=HWHEW4(2,1,4,3,5,6)*S156+HWHEW4(2,1,5,6,4,3)*S134
22621         ZAMP(7)=HWHEW4(2,1,3,4,6,5)*S156+HWHEW4(2,1,6,5,3,4)*S134
22622         ZAMP(8)=HWHEW4(2,1,4,3,6,5)*S156+HWHEW4(2,1,6,5,4,3)*S134
22623 C--Now the amplitudes squared for the process
22624         DO I=1,2
22625           TAMP = Z0
22626           DO P1=1,2
22627             DO P2=1,2
22628               DO P3=1,2
22629                 IF(PHOTON) THEN
22630                   CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
22631      &                +G(I,P1)*EE(I)*G(ID(1),P2)*EE(ID(2))*Z34*P56
22632      &                +G(I,P1)*EE(I)*EE(ID(1))*G(ID(2),P3)*P34*Z56
22633      &                +EE(I)**2*EE(ID(1))*EE(ID(2))*P34*P56
22634                 ELSE
22635                   CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
22636                 ENDIF
22637                 AMPT(I,P1,P2,P3) = ZAMP(4*P1+2*P3+P2-6)*CP
22638                 TAMP = TAMP+AMPT(I,P1,P2,P3)*DCONJG(AMPT(I,P1,P2,P3))
22639               ENDDO
22640             ENDDO
22641           ENDDO
22642           AMP(I) = HALF*DBLE(TAMP)
22643         ENDDO
22644       ENDIF
22645 C--Now calculate the cross section
22646       HCS = 0.0D0
22647       CFAC = CFAC1
22648       IF(ID(1).LE.2) CFAC = CFAC*THREE
22649       IF(ID(2).LE.2) CFAC = CFAC*THREE
22650       DO I=1,2
22651         DO I1=1,3
22652           IDP(1) = MAPZ(I,I1)
22653           IDP(2) = MAPZ(I,I1)+6
22654           DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
22655           DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
22656           DO I2=1,2
22657             HCS = HCS+CFAC*DIST(I2)*AMP(I)
22658             IF(GENEV.AND.HCS.GT.RCS) THEN
22659 C--New for spin correlations
22660               IF(SYSPIN) THEN
22661                 NSPN = 1
22662                 DO 10 P1=1,2
22663                 DO 10 P2=1,2
22664                 DO 10 P3=1,2
22665                 MESPN(P1,P2,P3,1,1,1) = AMPT(I,O(P1),O(P2),O(P3))
22666  10             MESPN(P1,P2,P3,2,1,1) = (0.0D0,0.0D0)
22667                 NCFL(1) = 1
22668                 SPNCFC(1,1,1) = ONE
22669               ENDIF
22670               GOTO 999
22671             ENDIF
22672           ENDDO
22673           IDP(1) = IDP(1)+6
22674           IDP(2) = IDP(2)-6
22675         ENDDO
22676       ENDDO
22677  999  RETURN
22678       END
22679 CDECK  ID>, HWHGB4.
22680 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22681 *-- Author :    Peter Richardson
22682 C-----------------------------------------------------------------------
22683       SUBROUTINE HWHGB4(HCS,IDP,PHOTON)
22684 C-----------------------------------------------------------------------
22685 C     WZ cross section in hadron hadron
22686 C-----------------------------------------------------------------------
22687       INCLUDE 'herwig65.inc'
22688       DOUBLE PRECISION AMP(2),HCS,RCS,HWRGEN,W34,DIST(2),S34,S56,CFAC,
22689      &     TCS,S12,MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),
22690      &     TAUI(2),CSW,CFAC1
22691       DOUBLE COMPLEX ZH,ZCH,ZD,P56,Z56,Z1,Z0,S134,S156,HWHEW4,
22692      &     CP(4),W12,F(4),TAMP(2,2)
22693       INTEGER IDP(10),I,J,I1,I2,ID,P1,P2,P3,P4
22694       LOGICAL PHOTON
22695       EXTERNAL HWRGEN,HWHEW4
22696       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22697       COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22698       PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
22699       SAVE AMP,ID,TAMP
22700       IF(GENEV) THEN
22701         RCS = HCS*HWRGEN(1)
22702       ELSE
22703 C--identity of the Z decay product (d=1,u=2,e=3,nu=4)
22704         ID = IDP(5)
22705         IF(ID.GE.121) ID = ID-114
22706         ID = MOD(ID+1,2)+2*INT((ID-1)/6)+1
22707 C--the various propagators we need
22708         S12 = TWO*DBLE(ZD(1,2))
22709         S34 = TWO*DBLE(ZD(3,4))
22710         S56 = TWO*DBLE(ZD(5,6))
22711         Z56 = ONE/(S56-MZ2+Z1*GMZ)
22712         IF(PHOTON) THEN
22713           P56 = Z56*(S56-MZ2)/S56
22714         ELSE
22715           P56 = Z0
22716         ENDIF
22717         W12 = ONE/(S12-MW2+Z1*GMW)
22718         S134 = HALF*W12*(S12-MW2)/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22719         S156 = HALF*W12*(S12-MW2)/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22720         W34  = ONE/((S34-MW2)**2+GMW**2)/SWEIN**2/FOUR
22721 C--calculate the coefficents of the various amplitudes
22722         F(1)  = HWHEW4(1,2,3,4,5,6)
22723         F(2)  = HWHEW4(1,2,5,6,3,4)
22724         F(3)  = HWHEW4(1,2,3,4,6,5)
22725         F(4)  = HWHEW4(1,2,6,5,3,4)
22726         DO I=1,2
22727           IF(I.EQ.1) THEN
22728             J=2
22729           ELSE
22730             J=1
22731           ENDIF
22732           CP(1) = G(J,1)*S134-TAUI(I)*CSW*W12
22733           CP(2) = G(I,1)*S156+TAUI(I)*CSW*W12
22734           IF(PHOTON) THEN
22735             CP(3) = EE(J)*S134-TAUI(I)*W12
22736             CP(4) = EE(I)*S156+TAUI(I)*W12
22737           ELSE
22738             CP(3) = Z0
22739             CP(4) = Z0
22740           ENDIF
22741           TAMP(I,1)  = F(1)*(G(ID,1)*Z56*CP(1)+EE(ID)*P56*CP(3))
22742      &                +F(2)*(G(ID,1)*Z56*CP(2)+EE(ID)*P56*CP(4))
22743           TAMP(I,2)  = F(3)*(G(ID,2)*Z56*CP(1)+EE(ID)*P56*CP(3))
22744      &                +F(4)*(G(ID,2)*Z56*CP(2)+EE(ID)*P56*CP(4))
22745           AMP(I) = W34*DBLE( TAMP(I,1)*DCONJG(TAMP(I,1))
22746      &                      +TAMP(I,2)*DCONJG(TAMP(I,2)))
22747         ENDDO
22748       ENDIF
22749 C--Now calculate the cross section
22750       HCS  = ZERO
22751       CFAC = CFAC1*9.0D0
22752       IF(ID.LE.2) CFAC = CFAC*THREE
22753       DO I=1,2
22754         DO I1=1,3
22755           IF(I.EQ.1) THEN
22756             IDP(1) = 2*I1+5
22757           ELSE
22758             IDP(1) = 2*I1+6
22759           ENDIF
22760           DO J=1,3
22761             IF(I.EQ.1) THEN
22762               IDP(2) = 2*J
22763 C**Bug fix 2/7/01 by BRW (unsquare)
22764               TCS = VCKM(J,I1)
22765             ELSE
22766               IDP(2) = 2*J-1
22767               TCS = VCKM(I1,J)
22768 C**End bug fix
22769             ENDIF
22770             DIST(1) = TCS*DISF(IDP(1),1)*DISF(IDP(2),2)
22771             DIST(2) = TCS*DISF(IDP(2),1)*DISF(IDP(1),2)
22772             DO I2=1,2
22773               HCS = HCS+CFAC*DIST(I2)*AMP(I)
22774               IF(GENEV.AND.HCS.GT.RCS) GOTO 900
22775             ENDDO
22776           ENDDO
22777         ENDDO
22778       ENDDO
22779  900  IF(GENEV.AND.I2.EQ.2) THEN
22780         I1 = IDP(1)
22781         IDP(1) = IDP(2)
22782         IDP(2) = I1
22783       ENDIF
22784       IF(SYSPIN.AND.GENEV) THEN
22785         NSPN = 1
22786         DO 10 P1=1,2
22787         DO 10 P2=1,2
22788         DO 10 P3=1,2
22789         DO 10 P4=1,2
22790  10     MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
22791         MESPN(2 ,2 ,1 ,1 ,1,1) = TAMP(I,2)
22792         MESPN(2 ,2 ,2 ,1 ,1,1) = TAMP(I,1)
22793         NCFL(1) = 1
22794         SPNCFC(1,1,1) = ONE
22795       ENDIF
22796       END
22797 CDECK  ID>, HWHGB5.
22798 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22799 *-- Author :    Peter Richardson
22800 C-----------------------------------------------------------------------
22801       SUBROUTINE HWHGB5(IOPT,FJAC,T,TMAX,TMIN)
22802 C-----------------------------------------------------------------------
22803 C     Subroutine to select t or u for HWHGBP
22804 C-----------------------------------------------------------------------
22805       INCLUDE 'herwig65.inc'
22806       INTEGER IOPT
22807       DOUBLE PRECISION FJAC,TPOW,TMIN,T,A1,A01,RPOW,QPOW,HWRGEN,TMAX,TN,
22808      &     TX,MT
22809       EXTERNAL HWRGEN
22810       TPOW = -1.0D0
22811       TX = -TMIN
22812       TN = -TMAX
22813       IF(TPOW.EQ.-ONE) THEN
22814          A1    = LOG(TX/TN)
22815         IF(IOPT.EQ.1) THEN
22816           FJAC =-ONE/T/A1
22817         ELSE
22818           T = -TN*EXP(A1*HWRGEN(2))
22819           FJAC  =-A1*T
22820         ENDIF
22821       ELSE
22822         QPOW = ONE+TPOW
22823         RPOW = ONE/QPOW
22824         A01   = TN**QPOW
22825         A1    = (TX**QPOW-A01)
22826         IF(IOPT.EQ.1) THEN
22827           MT = -T
22828           FJAC =QPOW*MT**TPOW/A1
22829         ELSE
22830           MT = (A01+A1*HWRGEN(2))**RPOW
22831           T = -MT
22832           FJAC  = A1*RPOW/MT**TPOW
22833         ENDIF
22834       ENDIF
22835       END
22836 CDECK  ID>, HWHGRV.
22837 *CMZ :-        -13/10/00  10:48:07  by  Peter Richardson
22838 *-- Author      Kosuke Odagiri
22839 C-----------------------------------------------------------------------
22840       SUBROUTINE HWHGRV
22841 C-----------------------------------------------------------------------
22842 C     Massive spin-2 resonance (massive graviton)
22843 C     Universal tensor coupling to the energy-momentum tensor is assumed
22844 C     viz L = - G(mu,nu) T(mu,nu) / GRVLAM
22845 C     If GAMGRV is zero, it is revaluated during the first run
22846 C     MEAN EVWGT = SIGMA IN NB
22847 C-----------------------------------------------------------------------
22848       INCLUDE 'herwig65.inc'
22849       DOUBLE PRECISION HWRGEN,HWRUNI,EPS,EMSQG,
22850      & EMGMG,S,CC,SS,SS2,M1(16),M2(16),M3,M4,M5(3),M6(3),
22851      & RNGLU,FACT,HCS,FACTR,RCS,A2,A02,QPE,SQPE,RGRV
22852       INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,ID1,ID2,ID3,ID4,
22853      & IADD(2,2)
22854       LOGICAL JGLU,JPHO,JW,JZ,JH
22855       EXTERNAL HWRGEN,HWRUNI
22856       SAVE HCS,JQMN,JQMX,JLMN,JLMX,JGLU,JPHO,JW,JZ,JH,EMSQG,EMGMG,
22857      & A2,A02,FACT,RNGLU,M1,M2,M3,M4,M5,M6
22858       PARAMETER (EPS=1.D-9)
22859       SAVE IADD
22860       DATA IADD/0,6,6,0/
22861       IF (GENEV) THEN
22862        RCS=HCS*HWRGEN(0)
22863       ELSE
22864        IF (FSTWGT) THEN
22865 C Set limits for which particles to include
22866         JLMN=1
22867         JLMX=0
22868         JQMN=1
22869         JQMX=0
22870         JGLU=.FALSE.
22871         JPHO=.FALSE.
22872         JW  =.FALSE.
22873         JZ  =.FALSE.
22874         JH  =.FALSE.
22875         IMODE=MOD(IPROC,100)
22876         IF (IMODE.EQ.0) THEN
22877          JQMN=1
22878          JQMX=6
22879          JGLU=.TRUE.
22880          JLMN=11
22881          JLMX=16
22882          JPHO=.TRUE.
22883          JW  =.TRUE.
22884          JZ  =.TRUE.
22885          JH  =.TRUE.
22886         ELSEIF (IMODE.EQ.10) THEN
22887          JQMN=1
22888          JQMX=6
22889          JGLU=.TRUE.
22890         ELSEIF (IMODE.GT.10.AND.IMODE.LE.16) THEN
22891          JQMN=IMODE-10
22892          JQMX=IMODE-10
22893         ELSEIF (IMODE.EQ.20) THEN
22894          JGLU=.TRUE.
22895         ELSEIF (IMODE.EQ.50) THEN
22896          JLMN=11
22897          JLMX=16
22898          JPHO=.TRUE.
22899         ELSEIF (IMODE.GT.50.AND.IMODE.LE.56) THEN
22900          JLMN=IMODE-40
22901          JLMX=IMODE-40
22902         ELSEIF (IMODE.EQ.60) THEN
22903          JPHO=.TRUE.
22904         ELSEIF (IMODE.EQ.70) THEN
22905          JW  =.TRUE.
22906          JZ  =.TRUE.
22907          JH  =.TRUE.
22908         ELSEIF (IMODE.EQ.71) THEN
22909          JW  =.TRUE.
22910         ELSEIF (IMODE.EQ.72) THEN
22911          JZ  =.TRUE.
22912         ELSEIF (IMODE.EQ.73) THEN
22913          JH  =.TRUE.
22914         ELSE
22915          CALL HWWARN('HWHGRV',500)
22916         ENDIF
22917         RNGLU=CAFAC**2-ONE
22918         IF (GAMGRV.EQ.ZERO) THEN
22919 C Calculate the width if GAMGRV=ZERO.
22920 C Quarks
22921          DO 10 JQ=1,6
22922           RGRV=(RMASS(JQ)/EMGRV)**2
22923           QPE=ONE-4.D0*RGRV
22924           IF (QPE.GT.ZERO) THEN
22925            SQPE=SQRT(QPE)
22926            GAMGRV=GAMGRV+CAFAC*SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
22927           END IF
22928   10     CONTINUE
22929 C Leptons
22930          DO 20 JL=121,126
22931           RGRV=(RMASS(JL)/EMGRV)**2
22932           QPE=ONE-4.D0*RGRV
22933           IF (QPE.GT.ZERO) THEN
22934            SQPE=SQRT(QPE)
22935            GAMGRV=GAMGRV+SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
22936           END IF
22937   20     CONTINUE
22938 C Photons
22939          GAMGRV=GAMGRV+HALF
22940 C gg
22941          GAMGRV=GAMGRV+HALF*RNGLU
22942 C ZZ
22943          RGRV=(RMASS(200)/EMGRV)**2
22944          QPE=ONE-4.D0*RGRV
22945          IF (QPE.GT.ZERO) THEN
22946           SQPE=SQRT(QPE)
22947           GAMGRV=GAMGRV+SQPE*
22948      &     (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)/TWO
22949          END IF
22950 C WW
22951          RGRV=(RMASS(198)/EMGRV)**2
22952          QPE=ONE-4.D0*RGRV
22953          IF (QPE.GT.ZERO) THEN
22954           SQPE=SQRT(QPE)
22955           GAMGRV=GAMGRV+SQPE*
22956      &     (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)
22957          END IF
22958 C HH
22959          RGRV=(RMASS(201)/EMGRV)**2
22960          QPE=ONE-4.D0*RGRV
22961          IF (QPE.GT.ZERO) THEN
22962           SQPE=SQRT(QPE)
22963           GAMGRV=GAMGRV+SQPE**5/12.D0/TWO
22964          END IF
22965          GAMGRV=GAMGRV*EMGRV**3/(GRVLAM**2*40.D0*PIFAC)
22966         END IF
22967         EMSQG=EMGRV**2
22968         EMGMG=EMGRV*GAMGRV
22969         A02=ATAN((EMMIN**2-EMSQG)/EMGMG)
22970         A2 =ATAN((EMMAX**2-EMSQG)/EMGMG)-A02
22971        ENDIF
22972        EVWGT=0.
22973 C Select a mass for the produced pair
22974        S=EMSQG+EMGMG*TAN(A02+A2*HWRGEN(1))
22975        EMSCA=SQRT(S)
22976 C Select initial momentum fractions
22977        XXMIN=S/PHEP(5,3)**2
22978        XLMIN=LOG(XXMIN)
22979        CALL HWSGEN(.TRUE.)
22980        COSTH=HWRUNI(0,-ONE,ONE)
22981 C
22982        FACT=-GEV2NB*A2*XLMIN*S**2/(GRVLAM**4*EMGMG*16.D0*PIFAC)
22983        CC = COSTH**2
22984        SS = ONE-CC
22985        SS2= SS**2
22986 C QQ,GG -> FF
22987        DO 110 I=1,6
22988          JQ=I
22989          JL=I+10
22990          QPE=ONE-4.D0*RMASS(JQ)**2/S
22991          IF (QPE.GT.ZERO) THEN
22992            SQPE=SQRT(QPE)
22993            M1(JQ)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
22994            M2(JQ)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
22995          ELSE
22996            M1(JQ)=ZERO
22997            M2(JQ)=ZERO
22998          END IF
22999          QPE=ONE-4.D0*RMASS(JL+110)**2/S
23000          IF (QPE.GT.ZERO) THEN
23001            SQPE=SQRT(QPE)
23002            M1(JL)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
23003            M2(JL)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
23004          ELSE
23005            M1(JL)=ZERO
23006            M2(JL)=ZERO
23007          END IF
23008   110  CONTINUE
23009 C QQ,GG -> BB (massless)
23010        M3=SS*(ONE+CC)/32.D0/CAFAC
23011        M4=(CC+SS2/8.D0)/4.D0/RNGLU
23012 C QQ,GG -> W,Z,H
23013        QPE=ONE-4.D0*RMASS(198)**2/S
23014        IF (QPE.GT.ZERO) THEN
23015        SQPE=SQRT(QPE)
23016        M5(1)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/8.D0/CAFAC
23017        M6(1)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/2.D0/RNGLU
23018        ELSE
23019        M5(1)=ZERO
23020        M6(1)=ZERO
23021        END IF
23022        QPE=ONE-4.D0*RMASS(200)**2/S
23023        IF (QPE.GT.ZERO) THEN
23024        SQPE=SQRT(QPE)
23025        M5(2)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/16.D0/CAFAC
23026        M6(2)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/4.D0/RNGLU
23027        ELSE
23028        M5(2)=ZERO
23029        M6(2)=ZERO
23030        END IF
23031        QPE=ONE-4.D0*RMASS(201)**2/S
23032        IF (QPE.GT.ZERO) THEN
23033        SQPE=SQRT(QPE)
23034        M5(3)=SQPE*(QPE**2*SS*CC)/64.D0/CAFAC
23035        M6(3)=SQPE*(QPE**2*SS2)/64.D0/RNGLU
23036        ELSE
23037        M5(3)=ZERO
23038        M6(3)=ZERO
23039        END IF
23040       END IF
23041       HCS=ZERO
23042       DO 90 I=1,2
23043 C I=1 quark first, I=2 anti-quark first
23044        DO 80 IQ=1,6
23045         ID1=IQ+IADD(1,I)
23046         ID2=IQ+IADD(2,I)
23047         IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
23048         FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
23049 C Quark final states
23050         DO 60 JQ=JQMN,JQMX
23051          ID3=JQ
23052          ID4=JQ+6
23053          HCS=HCS+FACTR*M1(JQ)*CAFAC
23054          IF (GENEV.AND.HCS.GT.RCS) THEN
23055            CALL HWHQCP(ID3,ID4,2143,50)
23056            GOTO 99
23057          ENDIF
23058   60    CONTINUE
23059 C Lepton final states
23060         DO 70 JL=JLMN,JLMX
23061          ID3=110+JL
23062          ID4=ID3+6
23063          HCS=HCS+FACTR*M1(JL)
23064          IF (GENEV.AND.HCS.GT.RCS) THEN
23065            CALL HWHQCP(ID3,ID4,2134,50)
23066            GOTO 99
23067          ENDIF
23068   70    CONTINUE
23069 C Bosonic final states
23070         IF (JPHO) THEN
23071          ID3=59
23072          ID4=59
23073          HCS=HCS+FACTR*M3
23074          IF (GENEV.AND.HCS.GT.RCS) THEN
23075            CALL HWHQCP(ID3,ID4,2134,50)
23076            GOTO 99
23077          ENDIF
23078         END IF
23079         IF (JW) THEN
23080          ID3=198
23081          ID4=199
23082          HCS=HCS+FACTR*M5(1)
23083          IF (GENEV.AND.HCS.GT.RCS) THEN
23084            CALL HWHQCP(ID3,ID4,2134,50)
23085            GOTO 99
23086          ENDIF
23087         END IF
23088         IF (JZ) THEN
23089          ID3=200
23090          ID4=200
23091          HCS=HCS+FACTR*M5(2)
23092          IF (GENEV.AND.HCS.GT.RCS) THEN
23093            CALL HWHQCP(ID3,ID4,2134,50)
23094            GOTO 99
23095          ENDIF
23096         END IF
23097         IF (JH) THEN
23098          ID3=201
23099          ID4=201
23100          HCS=HCS+FACTR*M5(3)
23101          IF (GENEV.AND.HCS.GT.RCS) THEN
23102            CALL HWHQCP(ID3,ID4,2134,50)
23103            GOTO 99
23104          ENDIF
23105         END IF
23106         IF (JGLU) THEN
23107          ID3=13
23108          ID4=13
23109          HCS=HCS+FACTR*M3*RNGLU
23110          IF (GENEV.AND.HCS.GT.RCS) THEN
23111            CALL HWHQCP(ID3,ID4,2143,50)
23112            GOTO 99
23113          ENDIF
23114         END IF
23115   80   CONTINUE
23116   90  CONTINUE
23117 C Gluon initial states
23118       ID1=13
23119       ID2=13
23120       IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
23121       FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
23122 C Quark final states
23123       DO 40 JQ=JQMN,JQMX
23124        ID3=JQ
23125        ID4=JQ+6
23126        HCS=HCS+FACTR*M2(JQ)*CAFAC
23127        IF (GENEV.AND.HCS.GT.RCS) THEN
23128          CALL HWHQCP(ID3,ID4,2143,51)
23129          GOTO 99
23130        ENDIF
23131   40  CONTINUE
23132 C Lepton final states
23133       DO 50 JL=JLMN,JLMX
23134        ID3=110+JL
23135        ID4=ID3+6
23136        HCS=HCS+FACTR*M2(JL)
23137        IF (GENEV.AND.HCS.GT.RCS) THEN
23138          CALL HWHQCP(ID3,ID4,2134,51)
23139          GOTO 99
23140        ENDIF
23141   50  CONTINUE
23142 C Vector boson final states
23143       IF (JPHO) THEN
23144        ID3=59
23145        ID4=59
23146        HCS=HCS+FACTR*M4
23147        IF (GENEV.AND.HCS.GT.RCS) THEN
23148          CALL HWHQCP(ID3,ID4,2134,51)
23149          GOTO 99
23150        ENDIF
23151       END IF
23152       IF (JW) THEN
23153        ID3=198
23154        ID4=199
23155        HCS=HCS+FACTR*M6(1)
23156        IF (GENEV.AND.HCS.GT.RCS) THEN
23157          CALL HWHQCP(ID3,ID4,2134,51)
23158          GOTO 99
23159        ENDIF
23160       END IF
23161       IF (JZ) THEN
23162        ID3=200
23163        ID4=200
23164        HCS=HCS+FACTR*M6(2)
23165        IF (GENEV.AND.HCS.GT.RCS) THEN
23166          CALL HWHQCP(ID3,ID4,2134,51)
23167          GOTO 99
23168        ENDIF
23169       END IF
23170       IF (JH) THEN
23171        ID3=201
23172        ID4=201
23173        HCS=HCS+FACTR*M6(3)
23174        IF (GENEV.AND.HCS.GT.RCS) THEN
23175          CALL HWHQCP(ID3,ID4,2134,51)
23176          GOTO 99
23177        ENDIF
23178       END IF
23179       IF (JGLU) THEN
23180        ID3=13
23181        ID4=13
23182        HCS=HCS+FACTR*M4*RNGLU
23183        IF (GENEV.AND.HCS.GT.RCS) THEN
23184          CALL HWHQCP(ID3,ID4,2143,51)
23185          GOTO 99
23186        ENDIF
23187       END IF
23188   30  CONTINUE
23189       EVWGT=HCS
23190       RETURN
23191 C Generate event
23192   99  IDN(1)=ID1
23193       IDN(2)=ID2
23194       IDCMF=208
23195       CALL HWETWO(.TRUE.,.TRUE.)
23196       IF (AZSPIN) THEN
23197 C Calculate coefficients for constructing spin density matrices
23198 C Set to zero for now
23199         CALL HWVZRO(7,GCOEF)
23200       END IF
23201       END
23202 CDECK  ID>, HWHGUP.
23203 *CMZ :-        -16/07/02  09.40.25  by  Peter Richardson
23204 *-- Author :    Peter Richardson
23205 C----------------------------------------------------------------------
23206       SUBROUTINE HWHGUP
23207 C----------------------------------------------------------------------
23208 C     Use the GUPI (Generic User Process Interface) event common block
23209 C     as the hard process for HERWIG
23210 C----------------------------------------------------------------------
23211       INCLUDE 'herwig65.inc'
23212 C--Les Houches Common Block
23213       INTEGER MAXPUP
23214       PARAMETER(MAXPUP=100)
23215       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
23216       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
23217       COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
23218      &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
23219      &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
23220       INTEGER MAXNUP
23221       PARAMETER (MAXNUP=500)
23222       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
23223       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
23224       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
23225      &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
23226      &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
23227      &              SPINUP(MAXNUP)
23228 C--Local variables
23229       COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
23230       INTEGER ILOC,JLOC,JHEP,ID
23231       INTEGER IHEP,IDIN(2),I,IDRES(2,MAXPUP),IRES,ICMF,ISTART,JRES,J
23232       DOUBLE PRECISION PTEMP(5)
23233       CHARACTER *8 DUMMY
23234       LOGICAL HWRLOG
23235       EXTERNAL HWRLOG
23236       IRES = 0
23237 C--zero the variables
23238       DO I=1,NUP
23239          JLOC(I) = 0
23240       ENDDO
23241       DO I=1,NMXHEP
23242          ILOC(I) = 0
23243       ENDDO
23244 c---generate hard subprocess
23245 C--now do the event selection bit
23246       IF(.NOT.GENEV) THEN
23247         IDPRUP = LPRUP(ITYPLH)
23248         CALL UPEVNT_GUP
23249         IF(ABS(IDWTUP).EQ.1.OR.ABS(IDWTUP).EQ.2.OR.
23250      &     ABS(IDWTUP).EQ.4) THEN
23251           EVWGT = XWGTUP*1.0D-3
23252         ELSEIF(ABS(IDWTUP).EQ.3) THEN
23253           EVWGT = SIGN(ONE,XWGTUP)
23254         ELSE
23255           CALL HWWARN('HWHGUP',510)
23256         ENDIF
23257 C--check the sign of the weight
23258         IF(IDWTUP.GT.ZERO.AND.EVWGT.LT.ZERO) CALL HWWARN('HWHGUP',520)
23259         RETURN
23260       ENDIF
23261 C--update the number of events
23262       LHNEVT(ITYPLH) = LHNEVT(ITYPLH)+1
23263       ITYPLH = 0
23264 C--first search to see if there are incoming beam particles in the record
23265       I = 0
23266       DO IHEP=1,NUP
23267         IF(ISTUP(IHEP).EQ.-9) THEN
23268           I=I+1
23269           IF(I.EQ.3) THEN
23270             CALL HWWARN('HWHGUP',102)
23271             GOTO 999
23272           ENDIF
23273           IDIN(I) = IHEP
23274         ENDIF
23275       ENDDO
23276 C--put the beam particles in the record
23277 C--require the soft event
23278       GENSOF = LHSOFT.AND.HWRLOG(PRSOF)
23279 C--if given for event from event common block
23280       NHEP = 0
23281       IF(I.EQ.2) THEN
23282 C--otherwise from the process common block
23283       ELSEIF(I.EQ.0) THEN
23284         DO I=1,2
23285           CALL HWUIDT(1,IDBMUP(I),IDHW(I),DUMMY)
23286           PHEP(1,I) = ZERO
23287           PHEP(2,I) = ZERO
23288           PHEP(4,I) = EBMUP(I)
23289           PHEP(5,I) = RMASS(IDHW(I))
23290           PHEP(3,I) = SQRT(EBMUP(I)**2-RMASS(IDHW(I))**2)
23291           ISTHEP(I) = 100+I
23292         ENDDO
23293         PHEP(3,2) = -PHEP(3,2)
23294         NHEP = NHEP+2
23295 C--if not correct issue warning
23296       ELSE
23297         CALL HWWARN('HWHGUP',103)
23298         GOTO 999
23299       ENDIF
23300 C--setup the centre-of-mass energy
23301       CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PHEP(1,NHEP+1))
23302       CALL HWUMAS(PHEP(1,NHEP+1))
23303       JMOHEP(1,NHEP+1) = NHEP-1
23304       JMOHEP(2,NHEP+1) = NHEP
23305       IDHW(3) = 14
23306       ISTHEP(3) = 103
23307       NHEP = NHEP+1
23308 C--search for the incoming particles in collision
23309       I = 0
23310       DO IHEP=1,NUP
23311         IF(ISTUP(IHEP).EQ.-1) THEN
23312           I = I+1
23313           IF(I.EQ.3) THEN
23314             CALL HWWARN('HWHGUP',100)
23315             GOTO 999
23316           ENDIF
23317           IDIN(I) = IHEP
23318         ENDIF
23319       ENDDO
23320 C--require two incoming particles
23321       IF(I.NE.2) THEN
23322         CALL HWWARN('HWHGUP',101)
23323         GOTO 999
23324       ENDIF
23325 C--Now write these particles into the event record
23326       DO I=1,2
23327         IDHEP(NHEP+I) = IDUP(IDIN(I))
23328         ISTHEP(NHEP+I) = 110+I
23329         CALL HWUIDT(1,IDUP(IDIN(I)),IDHW(NHEP+I),DUMMY)
23330         CALL HWVEQU(5,PUP(1,IDIN(I)),PHEP(1,NHEP+I))
23331         JMOHEP(1,NHEP+I) = NHEP+3
23332         ILOC(NHEP+I) = IDIN(I)
23333         JLOC(I) = NHEP+I
23334 C--special for pairtcles which are identical to the beam
23335         DO J=1,2
23336           IF(IDHEP(NHEP+I).EQ.IDHEP(J)) THEN
23337             JDAHEP(1,J) = NHEP+I
23338             JDAHEP(2,J) = NHEP+I
23339           ENDIF
23340         ENDDO
23341       ENDDO
23342       CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
23343       CALL HWUMAS(PHEP(1,NHEP+3))
23344 C--add the hard entry
23345       IDHW(NHEP+3) = 15
23346       ISTHEP(NHEP+3) = 110
23347       JMOHEP(1,NHEP+3) = NHEP+1
23348       JMOHEP(2,NHEP+3) = NHEP+2
23349       JDAHEP(1,NHEP+3) = NHEP+4
23350       NHEP = NHEP+3
23351       ICMF = NHEP
23352 C--now search for the outgoing particles and add them to the event record
23353       DO I=1,NUP
23354 C--normal outgoing particles
23355         IF(ISTUP(I).EQ.1.AND.
23356      &        (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
23357           NHEP = NHEP+1
23358           IDHEP(NHEP) = IDUP(I)
23359           CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
23360           CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
23361           JMOHEP(1,NHEP) = ICMF
23362           JMOHEP(2,NHEP) = 0
23363           JDAHEP(2,NHEP) = 0
23364           ILOC(NHEP) = I
23365           JLOC(I) = NHEP
23366 C--resonances which must have mass preserved and resonances
23367 C-- which don't have to have mass preserved
23368 C--for the time being we won't disguish between these two options
23369         ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
23370      &        (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
23371           NHEP = NHEP+1
23372           IDHEP(NHEP) = IDUP(I)
23373           CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
23374           CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
23375           IRES = IRES+1
23376           IDRES(1,IRES) = NHEP
23377           IDRES(2,IRES) = I
23378           JMOHEP(1,NHEP) = ICMF
23379           JMOHEP(2,NHEP) = 0
23380           JDAHEP(2,NHEP) = 0
23381           ILOC(NHEP) = I
23382           JLOC(I) = NHEP
23383         ELSEIF(ISTUP(I).NE.-9.AND.ISTUP(I).NE.-1.AND.ISTUP(I).NE.1.AND.
23384      &         ISTUP(I).NE.2.AND.ISTUP(I).NE.3) THEN
23385           CALL HWWARN('HWHGUP',500)
23386         ENDIF
23387       ENDDO
23388 C--Modified 2/7/03 for 2->1 processes
23389       IF(ICMF+1.EQ.NHEP) THEN
23390          NHEP = NHEP-1
23391          IDHEP(NHEP) = IDHEP(NHEP+1)
23392          IDHEP(NHEP+1) = 0
23393          IDHW(NHEP) = IDHW(NHEP+1)
23394          IDHW(NHEP+1) = 0
23395          CALL HWVEQU(5,PHEP(1,NHEP+1),PHEP(1,NHEP))
23396          JMOHEP(1,NHEP+1) = 0
23397          JMOHEP(2,NHEP+1) = 0
23398          JDAHEP(1,NHEP+1) = 0
23399          JDAHEP(2,NHEP+1) = 0
23400          JDAHEP(1,NHEP  ) = NHEP
23401          JDAHEP(2,NHEP  ) = NHEP
23402          ILOC(NHEP) = ILOC(NHEP+1)
23403          ILOC(NHEP+1) = 0
23404          JLOC(ILOC(NHEP)) = NHEP
23405          JLOC(NHEP+1) = 0
23406          DO I=1,IRES
23407             IF(IDRES(1,IRES).EQ.NHEP+1) IDRES(1,IRES) = NHEP
23408          ENDDO
23409       ELSE
23410          JDAHEP(2,ICMF) = NHEP
23411 C--setup the status codes
23412          ISTHEP(ICMF+1) = 113
23413          DO IHEP=ICMF+2,NHEP
23414             ISTHEP(IHEP) = 114
23415          ENDDO
23416       ENDIF
23417 C--End mod
23418       ISTART = ICMF-3
23419       EMSCA = SCALUP
23420 C--generate parton shower
23421       CALL HWBGUP(ISTART,ICMF)
23422 C--now we need to sort out the resonances
23423       IF(IRES.EQ.0) RETURN
23424       JRES = 1
23425  35   ID = IDHEP(IDRES(1,JRES))
23426  36   IF(JDAHEP(1,IDRES(1,JRES)).NE.0.AND.
23427      &     JDAHEP(1,IDRES(1,JRES)).NE.IDRES(1,JRES)) THEN
23428         IF(IDHEP(IDRES(1,JRES)).EQ.94) THEN
23429           DO IHEP=JDAHEP(1,IDRES(1,JRES)),JDAHEP(2,IDRES(1,JRES))
23430             IF(IDHEP(IHEP).EQ.ID) THEN
23431               IDRES(1,JRES) = IHEP
23432               GOTO 36
23433             ENDIF
23434           ENDDO
23435         ELSE
23436           IDRES(1,JRES) = JDAHEP(1,IDRES(1,JRES))
23437         ENDIF
23438         GOTO 36
23439       ENDIF
23440 C--make a copy of this particle
23441       IHEP = IDRES(1,JRES)
23442       JMOHEP(1,NHEP+1) = JMOHEP(1,IDRES(1,JRES))
23443       JMOHEP(2,NHEP+1) = JMOHEP(2,IDRES(1,JRES))
23444       IDHEP(NHEP+1) = IDHEP(IDRES(1,JRES))
23445       IDHW(NHEP+1)  =  IDHW(IDRES(1,JRES))
23446       CALL HWVEQU(5,PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP+1))
23447       IDRES(1,JRES) = NHEP+1
23448       JLOC(IDRES(2,JRES)) = IDRES(1,JRES)
23449       ISTHEP(NHEP+1) = 155
23450       NHEP = NHEP+1
23451 C Reset colour pointers (if set)
23452       JHEP=JMOHEP(2,IHEP)
23453       IF (JHEP.GT.0) THEN
23454         IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
23455         IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
23456      &    .AND.ABS(IDHEP(JHEP)).GT.1000000
23457      &    .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
23458       ENDIF
23459       JHEP=JDAHEP(2,IHEP)
23460       IF (JHEP.GT.0) THEN
23461         IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
23462         IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
23463      &    .AND.ABS(IDHEP(JHEP)).GT.1000000
23464      &    .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
23465       ENDIF
23466 C Relabel original track
23467       IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3
23468       JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
23469       JDAHEP(1,IHEP)=NHEP
23470       JDAHEP(2,IHEP)=NHEP
23471 C--look for all the particles which have this as a mother
23472 C--now search for the outgoing particles and add them to the event record
23473       JDAHEP(1,NHEP) = NHEP+1
23474       ISTHEP(NHEP+1) = 113
23475       DO I=1,NUP
23476         IF(ISTUP(I).EQ.1.AND.MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
23477           NHEP = NHEP+1
23478           IDHEP(NHEP) = IDUP(I)
23479           CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
23480           CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
23481           CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
23482           JMOHEP(1,NHEP) = IDRES(1,JRES)
23483           JMOHEP(2,NHEP) = 0
23484           JDAHEP(2,NHEP) = 0
23485           ILOC(NHEP) = I
23486           JLOC(I) = NHEP
23487         ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
23488      &          MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
23489           NHEP = NHEP+1
23490           IDHEP(NHEP) = IDUP(I)
23491           CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
23492           CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
23493           CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
23494           IRES = IRES+1
23495           IDRES(1,IRES) = NHEP
23496           IDRES(2,IRES) = I
23497           JMOHEP(1,NHEP) = IDRES(1,JRES)
23498           JMOHEP(2,NHEP) = 0
23499           JDAHEP(2,NHEP) = 0
23500           ILOC(NHEP) = I
23501           JLOC(I) = NHEP
23502         ENDIF
23503       ENDDO
23504 C--special for top decays to ensure b is second and W is first, this seems
23505 C--to cause problems if the order is the other way around
23506       IF(ABS(IDHEP(IDRES(1,JRES))).EQ.6.AND.
23507      &     NHEP-IDRES(1,JRES).EQ.2) THEN
23508         IF(ABS(IDHEP(NHEP-1)).EQ.5) THEN
23509 C--swap momenta
23510            CALL HWVEQU(5,PHEP(1,NHEP),PTEMP)
23511            CALL HWVEQU(5,PHEP(1,NHEP-1),PHEP(1,NHEP))
23512            CALL HWVEQU(5,PTEMP,PHEP(1,NHEP-1))
23513 C--swap id's
23514            J = IDHW(NHEP)
23515            IDHW(NHEP) = IDHW(NHEP-1)
23516            IDHW(NHEP-1) = J
23517            J = IDHEP(NHEP)
23518            IDHEP(NHEP) = IDHEP(NHEP-1)
23519            IDHEP(NHEP-1) = J
23520 C--locations
23521            J = ILOC(NHEP)
23522            ILOC(NHEP) = ILOC(NHEP-1)
23523            ILOC(NHEP-1) = J
23524            JLOC(ILOC(NHEP-1)) = NHEP-1
23525            JLOC(ILOC(NHEP))   = NHEP
23526 C--resonances
23527            DO I=1,IRES
23528               IF(IDRES(1,I).EQ.NHEP) IDRES(1,I) = NHEP-1
23529            ENDDO
23530         ENDIF
23531       ENDIF
23532       DO IHEP=IDRES(1,JRES)+2,NHEP
23533         ISTHEP(IHEP) = 114
23534       ENDDO
23535       JDAHEP(2,IDRES(1,JRES)) = NHEP
23536       ISTART = IDRES(1,JRES)
23537       EMSCA = PHEP(4,IDRES(1,JRES))
23538       CALL HWBGUP(ISTART,0)
23539       IF(JRES.NE.IRES) THEN
23540         JRES = JRES+1
23541         GOTO 35
23542       ENDIF
23543  999  RETURN
23544       END
23545 CDECK  ID>, HWHHVY.
23546 *CMZ :-        -18/05/99  14.55.44  by  Kosuke Odagiri
23547 *-- Author :    Bryan Webber
23548 C-----------------------------------------------------------------------
23549       SUBROUTINE HWHHVY
23550 C-----------------------------------------------------------------------
23551 C     QCD HEAVY FLAVOUR PRODUCTION: MEAN EVWGT = SIGMA IN NB
23552 C-----------------------------------------------------------------------
23553       INCLUDE 'herwig65.inc'
23554       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,Z1,Z2,ET,EJ,
23555      & QM2,QPE,FACTR,S,T,U,ST,TU,US,TUS,UST,EN,RN,AF,ASTU,
23556      & AUST,CF,CN,CS,CSTU,CSUT,CTSU,CTUS,HCS,UT,SU,GT,DIST,KK,KK2,
23557      & YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
23558       INTEGER IQ1,IQ2,ID1,ID2
23559       LOGICAL HQ1,HQ2
23560       EXTERNAL HWRGEN,HWRUNI,HWUALF
23561       SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US
23562       PARAMETER (EPS=1.D-9)
23563       IF (GENEV) THEN
23564         RCS=HCS*HWRGEN(0)
23565       ELSE
23566         EVWGT=0.
23567         CALL HWRPOW(ET,EJ)
23568         KK = ET/PHEP(5,3)
23569         KK2=KK**2
23570         IF (KK.GE.ONE) RETURN
23571         YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
23572         YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
23573         IF (YJ1INF.GE.YJ1SUP) RETURN
23574         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
23575         YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
23576         YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
23577         IF (YJ2INF.GE.YJ2SUP) RETURN
23578         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
23579         XX(1)=HALF*(Z1+Z2)*KK
23580         IF (XX(1).GE.ONE) RETURN
23581         XX(2)=XX(1)/(Z1*Z2)
23582         IF (XX(2).GE.ONE) RETURN
23583         S=XX(1)*XX(2)*PHEP(5,3)**2
23584         IQ1=MOD(IPROC,100)
23585         QM2=RMASS(IQ1)**2
23586         QPE=S-4.*QM2
23587         IF (QPE.LE.ZERO) RETURN
23588         COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
23589         IF (ABS(COSTH).GT.ONE) RETURN
23590 C---REDEFINE S, T, U AS P1.P2, -P1.P3, -P1.P4
23591         S=HALF*S
23592         T=-HALF*(1.+Z2/Z1)*(HALF*ET)**2
23593         U=-S-T
23594 C---SET EMSCA TO HEAVY HARD PROCESS SCALE
23595         EMSCA=SQRT(4.*S*T*U/(S*S+T*T+U*U))
23596         FACTR = GEV2NB*.125*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
23597      &         *(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
23598         CALL HWSGEN(.FALSE.)
23599 C
23600         ST=S/T
23601         TU=T/U
23602         UT=U/T
23603         US=U/S
23604         SU=S/U
23605         TUS=US/ST
23606         UST=ST/TU
23607 C
23608         EN=CAFAC
23609         RN=CFFAC/EN
23610         AF=FACTR*RN
23611         ASTU=AF*(1.-2.*UST+QM2/T)
23612         AUST=AF*(1.-2.*TUS+QM2/S)
23613         CF=FACTR/(2.*CFFAC)
23614         CN=1./(EN*EN)
23615 C-----------------------------------------------------------------------
23616 C---Heavy flavour colour decomposition modifications below (KO)
23617 C-----------------------------------------------------------------------
23618         CS=(TU+UT-CN/TUS)*(HALF-TUS+QM2/S-QM2**2/U/T/TWO)
23619         CSTU=CF*CS/(ONE+TU**2)
23620         CSUT=CF*CS/(ONE+UT**2)
23621         CS=(SU+US-CN/UST)*(HALF-UST+QM2/T-QM2**2/U/S/TWO)
23622         CTSU=-FACTR*CS/(ONE+SU**2)
23623         CTUS=-FACTR*CS/(ONE+US**2)
23624 C-----------------------------------------------------------------------
23625 C       CS=HALF/TU-QM2/T-HALF*(QM2/T)**2
23626 C       CSTU=CF*(CS-   US**2-QM2/S - CN*(CS+QM2*QM2/(S*T)))
23627 C       CS=HALF*TU-QM2/U-HALF*(QM2/U)**2
23628 C       CSUT=CF*(CS-1./ST**2-QM2/S - CN*(CS+QM2*QM2/(S*U)))
23629 C       CS=HALF*US-QM2/S-HALF*(QM2/S)**2
23630 C       CTSU=-FACTR*(CS-1./TU**2-QM2/T - CN*(CS+QM2*QM2/(S*T)))
23631 C       CS=HALF/US-QM2/U-HALF*(QM2/U)**2
23632 C       CTUS=-FACTR*(CS-   ST**2-QM2/T - CN*(CS+QM2*QM2/(T*U)))
23633 C-----------------------------------------------------------------------
23634       ENDIF
23635 C
23636       HCS=0.
23637       IQ2=IQ1+6
23638       DO 6 ID1=1,13
23639       IF (DISF(ID1,1).LT.EPS) GOTO 6
23640       HQ1=ID1.EQ.IQ1.OR.ID1.EQ.IQ2
23641       DO 5 ID2=1,13
23642       IF (DISF(ID2,2).LT.EPS) GOTO 5
23643       HQ2=ID2.EQ.IQ1.OR.ID2.EQ.IQ2
23644       DIST=DISF(ID1,1)*DISF(ID2,2)
23645       IF (HQ1.OR.HQ2) THEN
23646 C---PROCESSES INVOLVING HEAVY CONSTITUENT
23647 C   N.B. NEGLECT CASE THAT BOTH ARE HEAVY
23648       IF (HQ1.AND.HQ2) GOTO 5
23649       IF (ID1.LT.7) THEN
23650 C---QUARK FIRST
23651        IF (ID2.LT.7) THEN
23652          HCS=HCS+ASTU*DIST
23653          IF (GENEV.AND.HCS.GT.RCS) THEN
23654            CALL HWHQCP(ID1,ID2,3421, 3)
23655            GOTO 9
23656          ENDIF
23657        ELSEIF (ID2.NE.13) THEN
23658          HCS=HCS+ASTU*DIST
23659          IF (GENEV.AND.HCS.GT.RCS) THEN
23660            CALL HWHQCP(ID1,ID2,3142, 9)
23661            GOTO 9
23662          ENDIF
23663        ELSE
23664          HCS=HCS+CTSU*DIST
23665          IF (GENEV.AND.HCS.GT.RCS) THEN
23666            CALL HWHQCP(ID1,ID2,3142,10)
23667            GOTO 9
23668          ENDIF
23669          HCS=HCS+CTUS*DIST
23670          IF (GENEV.AND.HCS.GT.RCS) THEN
23671            CALL HWHQCP(ID1,ID2,3421,11)
23672            GOTO 9
23673          ENDIF
23674        ENDIF
23675       ELSEIF (ID1.NE.13) THEN
23676 C---QBAR FIRST
23677        IF (ID2.LT.7) THEN
23678          HCS=HCS+ASTU*DIST
23679          IF (GENEV.AND.HCS.GT.RCS) THEN
23680            CALL HWHQCP(ID1,ID2,2413,17)
23681            GOTO 9
23682          ENDIF
23683        ELSEIF (ID2.NE.13) THEN
23684          HCS=HCS+ASTU*DIST
23685          IF (GENEV.AND.HCS.GT.RCS) THEN
23686            CALL HWHQCP(ID1,ID2,4312,20)
23687            GOTO 9
23688          ENDIF
23689        ELSE
23690          HCS=HCS+CTSU*DIST
23691          IF (GENEV.AND.HCS.GT.RCS) THEN
23692            CALL HWHQCP(ID1,ID2,2413,21)
23693            GOTO 9
23694          ENDIF
23695          HCS=HCS+CTUS*DIST
23696          IF (GENEV.AND.HCS.GT.RCS) THEN
23697            CALL HWHQCP(ID1,ID2,4312,22)
23698            GOTO 9
23699          ENDIF
23700        ENDIF
23701       ELSE
23702 C---GLUON FIRST
23703        IF (ID2.LT.7) THEN
23704          HCS=HCS+CTSU*DIST
23705          IF (GENEV.AND.HCS.GT.RCS) THEN
23706            CALL HWHQCP(ID1,ID2,2413,23)
23707            GOTO 9
23708          ENDIF
23709          HCS=HCS+CTUS*DIST
23710          IF (GENEV.AND.HCS.GT.RCS) THEN
23711            CALL HWHQCP(ID1,ID2,3421,24)
23712            GOTO 9
23713          ENDIF
23714        ELSEIF (ID2.LT.13) THEN
23715          HCS=HCS+CTSU*DIST
23716          IF (GENEV.AND.HCS.GT.RCS) THEN
23717            CALL HWHQCP(ID1,ID2,3142,25)
23718            GOTO 9
23719          ENDIF
23720          HCS=HCS+CTUS*DIST
23721          IF (GENEV.AND.HCS.GT.RCS) THEN
23722            CALL HWHQCP(ID1,ID2,4312,26)
23723            GOTO 9
23724          ENDIF
23725        ENDIF
23726       ENDIF
23727       ELSEIF (ID2.NE.13.AND.ID2.EQ.ID1+6) THEN
23728 C---LIGHT Q-QBAR ANNIHILATION
23729          HCS=HCS+AUST*DIST
23730          IF (GENEV.AND.HCS.GT.RCS) THEN
23731            CALL HWHQCP(IQ1,IQ2,2413, 4)
23732            GOTO 9
23733          ENDIF
23734       ELSEIF (ID1.NE.13.AND.ID1.EQ.ID2+6) THEN
23735 C---LIGHT QBAR-Q ANNIHILATION
23736          HCS=HCS+AUST*DIST
23737          IF (GENEV.AND.HCS.GT.RCS) THEN
23738            CALL HWHQCP(IQ2,IQ1,3142,12)
23739            GOTO 9
23740          ENDIF
23741       ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN
23742 C---GLUON FUSION
23743          HCS=HCS+CSTU*DIST
23744          IF (GENEV.AND.HCS.GT.RCS) THEN
23745            CALL HWHQCP(IQ1,IQ2,2413,27)
23746            GOTO 9
23747          ENDIF
23748          HCS=HCS+CSUT*DIST
23749          IF (GENEV.AND.HCS.GT.RCS) THEN
23750            CALL HWHQCP(IQ1,IQ2,4123,28)
23751            GOTO 9
23752          ENDIF
23753       ENDIF
23754     5 CONTINUE
23755     6 CONTINUE
23756       EVWGT=HCS
23757       RETURN
23758 C---GENERATE EVENT
23759     9 IDN(1)=ID1
23760       IDN(2)=ID2
23761       IDCMF=15
23762       CALL HWETWO(.TRUE.,.TRUE.)
23763       IF (AZSPIN) THEN
23764 C Calculate coefficients for constructing spin density matrices
23765          IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
23766      &       IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
23767 C qqbar-->gg or qbarq-->gg
23768             UT=1./TU
23769             GCOEF(1)=UT+TU
23770             GCOEF(2)=-2.
23771             GCOEF(3)=0.
23772             GCOEF(4)=0.
23773             GCOEF(5)=GCOEF(1)
23774             GCOEF(6)=UT-TU
23775             GCOEF(7)=-GCOEF(6)
23776          ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
23777      &           IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
23778      &           IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
23779      &           IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
23780 C qg-->qg or qbarg-->qbarg or gq-->gq  or gqbar-->gqbar
23781             SU=1./US
23782             GCOEF(1)=-(SU+US)
23783             GCOEF(2)=0.
23784             GCOEF(3)=2.
23785             GCOEF(4)=0.
23786             GCOEF(5)=SU-US
23787             GCOEF(6)=GCOEF(1)
23788             GCOEF(7)=-GCOEF(5)
23789          ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
23790 C gg-->qqbar
23791             UT=1./TU
23792             GCOEF(1)=TU+UT
23793             GCOEF(2)=-2.
23794             GCOEF(3)=0.
23795             GCOEF(4)=0.
23796             GCOEF(5)=GCOEF(1)
23797             GCOEF(6)=TU-UT
23798             GCOEF(7)=-GCOEF(6)
23799          ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
23800      &                          IHPRO.EQ.31) THEN
23801 C gg-->gg
23802             GT=S*S+T*T+U*U
23803             GCOEF(2)=2.*U*U*T*T
23804             GCOEF(3)=2.*S*S*U*U
23805             GCOEF(4)=2.*S*S*T*T
23806             GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
23807             GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
23808             GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
23809             GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
23810          ELSE
23811             CALL HWVZRO(7,GCOEF)
23812          ENDIF
23813       ENDIF
23814       END
23815 CDECK  ID>, HWHIBG.
23816 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
23817 *-- Author :  Kosuke Odagiri & Stefano Moretti
23818 C-----------------------------------------------------------------------
23819 C...Generate completely differential cross section (EVWGT) in the variables
23820 C...X(I) with I=1,3 (see below) for the processes IPROC=3410,3420,3430,3450
23821 C...as described in the HERWIG 6 documentation file.
23822 C...It includes interface to PDFs and takes into account color connections
23823 C...among partons.
23824 C
23825 C...First release:  6-AUG-1999 by Kosuke Odagiri
23826 C...Last modified:  6-SEP-1999 by Stefano Moretti
23827 C
23828 C-----------------------------------------------------------------------
23829       SUBROUTINE HWHIBG
23830 C-----------------------------------------------------------------------
23831 C     HIGGS + HEAVY QUARK (BOTTOM & TOP) PRODUCTION (2HDM)
23832 C-----------------------------------------------------------------------
23833       INCLUDE 'herwig65.inc'
23834       DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS,
23835      & DIST, SM, DM, QPE, PF, SQPE, EMSC2, FACTR, S, T3, U4,
23836      & SN2TH, ME2(0:4), MW, XWEIN, PT2MIN, PT2, GQH(0:4), G1, RMMIN,
23837      & EMG, EMQ, EMH, EMG2, EMQ2, EMH2, EMHWT, ECM_MAX, X(3), XL(3),
23838      & XU(3), WEIGHT, ECM, SHAT, TAU, T, TL, TLMIN, TLMAX, TTMIN, TTMAX,
23839      & CTMP, PCM, PCM2, RCM, RCM2, FKLN
23840       INTEGER ID1, ID2, IH, IQ, I
23841       EXTERNAL HWRGEN, HWUALF, HWUAEM
23842       SAVE HCS,ME2,S,SHAT
23843       PARAMETER (EPS = 1.D-9)
23844       EQUIVALENCE (MW, RMASS(198))
23845       PARAMETER (EMG=0.,EMG2=0.)
23846 C...generate event.
23847       IF (GENEV) THEN
23848         RCS = HCS*HWRGEN(0)
23849       ELSE
23850         HCS = ZERO
23851         EVWGT = ZERO
23852 C...minimum transverse momentum.
23853         PTMIN = ZERO
23854         PT2MIN = PTMIN**2
23855 C...accompanying quark.
23856         IQ=5
23857         IF(IHIGGS.GE.5)IQ=6
23858         EMQ=RMASS(IQ)
23859         EMQ2=EMQ*EMQ
23860 C...on-shell Higgs.
23861         EMH=RMASS(201+IHIGGS)
23862         EMHWT=1.D0
23863         EMH2=EMH*EMH
23864         RMMIN=(EMQ+EMH)/2.
23865 C...energy at hadron level.
23866         ECM_MAX=PBEAM1+PBEAM2
23867         S=ECM_MAX*ECM_MAX
23868 C...phase space variables.
23869 C...IF IQ=5 -> X(1)=(LOG(|T|)-LOG(|TMIN|))/(LOG(|TMAX|)-LOG(|TMIN|),
23870 C...IF IQ=6 -> X(1)=COS(THETA_CM);
23871 C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+EMH)**2-1./ECM_MAX**2),
23872 C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
23873 C...phase space borders.
23874         IF(IQ.EQ.5)XL(1)=0.
23875         IF(IQ.EQ.6)XL(1)=-1.
23876         XU(1)=1.
23877         XL(2)=0.
23878         XU(2)=1.
23879         XL(3)=0.
23880         XU(3)=1.
23881 C...single phase space point.
23882         WEIGHT=1.
23883         DO I=1,3
23884           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
23885           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
23886         END DO
23887 C...energy at parton level.
23888         ECM=SQRT(1./(X(2)*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
23889      &                                    +1./ECM_MAX**2))
23890         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
23891         SHAT=ECM*ECM
23892         TAU=SHAT/S
23893 C...momentum fractions X1 and X2.
23894         XX(1)=EXP(LOG(TAU)*(1.-X(3)))
23895         XX(2)=TAU/XX(1)
23896 C...reconstruct polar angle.
23897         IF(IQ.EQ.5)THEN
23898           PCM2=((SHAT-EMQ2-EMG2)**2
23899      &        -(2.*EMQ*EMG)**2)/(4.*SHAT)
23900           PCM=SQRT(PCM2)
23901           RCM2=((SHAT-EMQ2-EMH2)**2
23902      &        -(2.*EMQ*EMH)**2)/(4.*SHAT)
23903           RCM=SQRT(RCM2)
23904           FKLN=SQRT((SHAT-(EMQ+EMG)**2)*(SHAT-(EMQ-EMG)**2))
23905      &        *SQRT((SHAT-(EMQ+EMH)**2)*(SHAT-(EMQ-EMH)**2))
23906           TTMAX=EMG2+EMQ2-0.5D0/ECM/ECM
23907      &        *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
23908      &    -FKLN)
23909           TTMIN=EMG2+EMQ2-0.5D0/ECM/ECM
23910      &        *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
23911      &    +FKLN)
23912           TLMAX=LOG(ABS(TTMIN))
23913           TLMIN=LOG(ABS(TTMAX))
23914           TL=X(1)*(TLMAX-TLMIN)+TLMIN
23915           T=EXP(TL)
23916           CTMP=-T-EMG2-EMQ2
23917      &       +2.*SQRT(PCM2+EMG2)*SQRT(RCM2+EMQ2)
23918           COSTH = CTMP/2./PCM/RCM
23919         ELSE IF(IQ.EQ.6)THEN
23920           COSTH = X(1)
23921         END IF
23922         SN2TH = 0.25D0 - 0.25D0*COSTH**2
23923         IF((0.25D0-RMMIN**2/SHAT).LT.0.)THEN
23924           EVWGT=0.
23925           RETURN
23926         END IF
23927         T3    = ( SQRT(0.25D0-RMMIN**2/SHAT) * COSTH - HALF ) * SHAT
23928         U4    = - T3 - SHAT
23929         EMSC2 = TWO*SHAT*T3*U4/(SHAT**2+T3**2+U4**2)
23930         EMSCA = SQRT( EMSC2 )
23931         CALL    HWSGEN(.FALSE.)
23932         EVWGT = ZERO
23933         XWEIN = TWO * SWEIN
23934         FACTR = GEV2NB*PIFAC*HWUAEM(EMSC2)/XWEIN/SHAT
23935      &                      *HWUALF(1,EMSCA)/TWO/CAFAC/2.
23936 C...Jacobians from COSTH to X(1).
23937         IF(IQ.EQ.5)THEN
23938           FACTR=FACTR*(TLMAX-TLMIN)/2./PCM/RCM*T
23939         ELSE
23940           CONTINUE
23941         END IF
23942 C...Jacobians from X1,X2 to X(2),X(3).
23943         FACTR=FACTR/S*(-LOG(TAU))*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
23944 C...CKM mixing top/bottom quark.
23945 c bug fix 20/05/01 SM.
23946         IF(IQ.EQ.6)FACTR=FACTR*VCKM(3,3)
23947 c end of bug fix.
23948 C...Higgs resonance.
23949         FACTR=FACTR*EMHWT
23950 C...constant weight.
23951         FACTR=FACTR*WEIGHT
23952 C...SM/MSSM couplings.
23953         IF (IHIGGS.EQ.0) THEN
23954           GQH(0)=(RMASS(5)/MW)**2/TWO
23955         ELSE
23956           G1     = (RMASS(5)/MW/COSB)**2/TWO
23957           GQH(1) = G1*SINA**2
23958           GQH(2) = G1*COSA**2
23959           GQH(3) = G1*SINB**2
23960           GQH(4) = GQH(3)+(RMASS(6)/MW/TANB)**2/TWO
23961         END IF
23962 C...Matrix elements.
23963         DO IH = 0,4
23964           ME2(IH) = ZERO
23965         END DO
23966 c
23967 c g b  -> Q  H
23968 c
23969         ID1 = 5
23970         IH=IHIGGS
23971         IF(IHIGGS.NE.0)IH=IHIGGS-1
23972         IF (IH.EQ.4) ID1 = 6
23973         ID2 = 201+IHIGGS
23974         SM   = RMASS(ID1)+RMASS(ID2)
23975         QPE  = SHAT-SM**2
23976         IF (QPE.GT.ZERO) THEN
23977           DM   = RMASS(ID1)-RMASS(ID2)
23978           QPE  = QPE*(SHAT-DM**2)/SHAT
23979         END IF
23980         PT2  = QPE*SN2TH
23981         IF (PT2.GT.PT2MIN) THEN
23982           SQPE = SQRT(QPE*SHAT)
23983           PF   = SQPE/SHAT
23984           T3   = (SQPE*COSTH - SHAT - SM*DM) / TWO
23985           U4   = - T3 - SHAT
23986           ME2(IH) = FACTR*PF * GQH(IH) *
23987      &     U4/SHAT/T3*(-U4+TWO*SM*DM/T3/U4*SHAT*PT2)
23988         ELSE
23989           ME2(IH) = ZERO
23990         END IF
23991       END IF
23992       HCS = ZERO
23993 c
23994 c     g b
23995       ID1 = 13
23996       ID2 = 5
23997       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23998         DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23999         DO IH = 0,3
24000           HCS = HCS + DIST*ME2(IH)
24001           IF (GENEV.AND.HCS.GT.RCS) THEN
24002             CALL HWHQCP(5,IHIGGS+201,2314,1)
24003             GOTO 9
24004           ENDIF
24005         END DO
24006         HCS = HCS + DIST*ME2(4)
24007         IF (GENEV.AND.HCS.GT.RCS) THEN
24008           CALL HWHQCP(6,207,2314,1)
24009           GOTO 9
24010         ENDIF
24011       END IF
24012 c       _
24013 c     g b
24014       ID1 = 13
24015       ID2 = 11
24016       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
24017         DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
24018         DO IH = 0,3
24019           HCS = HCS + DIST*ME2(IH)
24020           IF (GENEV.AND.HCS.GT.RCS) THEN
24021             CALL HWHQCP(11,IHIGGS+201,3124,1)
24022             GOTO 9
24023           ENDIF
24024         END DO
24025         HCS = HCS + DIST*ME2(4)
24026         IF (GENEV.AND.HCS.GT.RCS) THEN
24027           CALL HWHQCP(12,206,3124,1)
24028           GOTO 9
24029         ENDIF
24030       END IF
24031 c
24032 c     b g
24033       ID1 = 5
24034       ID2 = 13
24035       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
24036         DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
24037         DO IH = 0,3
24038           HCS = HCS + DIST*ME2(IH)
24039           IF (GENEV.AND.HCS.GT.RCS) THEN
24040             CALL HWHQCP(IHIGGS+201,5,4132,1)
24041             GOTO 9
24042           ENDIF
24043         END DO
24044         HCS = HCS + DIST*ME2(4)
24045         IF (GENEV.AND.HCS.GT.RCS) THEN
24046           CALL HWHQCP(207,6,4132,1)
24047           GOTO 9
24048         ENDIF
24049       END IF
24050 c     _
24051 c     b g
24052       ID1 = 11
24053       ID2 = 13
24054       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
24055         DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
24056         DO IH = 0,3
24057           HCS = HCS + DIST*ME2(IH)
24058           IF (GENEV.AND.HCS.GT.RCS) THEN
24059             CALL HWHQCP(IHIGGS+201,11,2431,1)
24060             GOTO 9
24061           ENDIF
24062         END DO
24063         HCS = HCS + DIST*ME2(4)
24064         IF (GENEV.AND.HCS.GT.RCS) THEN
24065           CALL HWHQCP(206,12,2431,1)
24066           GOTO 9
24067         ENDIF
24068       END IF
24069       EVWGT = HCS
24070       RETURN
24071 C---GENERATE EVENT
24072     9 IDN(1)=ID1
24073       IDN(2)=ID2
24074       IDCMF=15
24075       CALL HWETWO(.TRUE.,.TRUE.)
24076       IF (AZSPIN) THEN
24077 C Calculate coefficients for constructing spin density matrices
24078 C Set to zero for now
24079         CALL HWVZRO(7,GCOEF)
24080       END IF
24081       END
24082 CDECK  ID>, HWHIBK.
24083 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
24084 *-- Author :  Stefano Moretti
24085 C-----------------------------------------------------------------------
24086 C...Generate completely differential cross section (EVWGT) in the variables
24087 C...X(I) with I=1,4 (see below) for the process IPROC=3350, as described
24088 C...in the HERWIG 6 documentation file.
24089 C...It includes interface to PDFs and takes into account color connections
24090 C...among partons.
24091 C
24092 C...First release: 8-APR-1999 by Stefano Moretti
24093 C
24094       SUBROUTINE HWHIBK
24095 C-----------------------------------------------------------------------
24096 C     ASSOCIATE PRODUCTION W+H- FROM QUARK FUSION (2HDM)
24097 C-----------------------------------------------------------------------
24098       INCLUDE 'herwig65.inc'
24099       INTEGER I,J,IHEL
24100       DOUBLE PRECISION EMH,EMHWT,RMW,EMW
24101       DOUBLE PRECISION RMH
24102       DOUBLE PRECISION X(4),XL(4),XU(4)
24103       DOUBLE PRECISION CT,ST
24104       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
24105       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
24106       DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
24107       DOUBLE PRECISION M2,M2L,M2T
24108       DOUBLE PRECISION ALPHA,EMSC2
24109       DOUBLE PRECISION HWRGEN,HWUAEM
24110       DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
24111       DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
24112       DOUBLE PRECISION WEIGHT
24113       DOUBLE PRECISION VSAVE
24114       SAVE EMH,EMW,HCS,M2,M2L,M2T,FACT,S,CT
24115       LOGICAL HWRLOG
24116       EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2BK,HWETWO,HWRLOG
24117       PARAMETER (EPS=1.D-9)
24118       EQUIVALENCE (RMW  ,RMASS(198))
24119       EQUIVALENCE (RMH  ,RMASS(206))
24120       IF(GENEV)THEN
24121         RCS=HCS*HWRGEN(0)
24122       ELSE
24123         HCS=0.
24124         EVWGT=0.
24125 C...assign final state masses.
24126         EMH=RMH
24127         EMHWT=1.D0
24128 C...energy at hadron level.
24129         ECM_MAX=PBEAM1+PBEAM2
24130         S=ECM_MAX*ECM_MAX
24131 C...phase space variables.
24132 C...X(1)=COS(THETA_CM),
24133 C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMW+EMH)**2-1./ECM_MAX**2),
24134 C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
24135 C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
24136 C...where THETA=ATAN((EMW*EMW-RMW*RMW)/RMW/GAMW);
24137 C...phase space borders.
24138         XL(1)=-1.
24139         XU(1)=1.
24140         XL(2)=0.
24141         XU(2)=1.
24142         XL(3)=0.
24143         XU(3)=1.
24144         XL(4)=0.
24145         XU(4)=1.
24146 C...single phase space point.
24147         WEIGHT=1.
24148         DO I=1,4
24149           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
24150           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
24151         END DO
24152 C...resonant boson mass (limits to -10*W-widths to improve efficiency).
24153         RNMIN=RMW-GAMMAX*GAMW
24154         THETA_MIN=ATAN((RNMIN*RNMIN-RMW*RMW)/RMW/GAMW)
24155         RNMAX=ECM_MAX-EMH
24156         THETA_MAX=ATAN((RNMAX*RNMAX-RMW*RMW)/RMW/GAMW)
24157         EMW=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
24158      &     *RMW*GAMW+RMW*RMW)
24159 C...energy at parton level.
24160         ECM=SQRT(1./(X(2)*(1./(EMW+EMH)**2-1./ECM_MAX**2)
24161      &                                    +1./ECM_MAX**2))
24162         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
24163         SHAT=ECM*ECM
24164         TAU=SHAT/S
24165 C...momentum fractions X1 and X2.
24166         XX(1)=EXP(LOG(TAU)*(1.-X(3)))
24167         XX(2)=TAU/XX(1)
24168 C...two particle kinematics.
24169         CT=X(1)
24170         IF(HWRLOG(HALF))THEN
24171           ST=+SQRT(1.-CT*CT)
24172         ELSE
24173           ST=-SQRT(1.-CT*CT)
24174         END IF
24175         RCM2=((SHAT-EMW*EMW-EMH*EMH)**2
24176      &      -(2.*EMW*EMH)**2)/(4.*SHAT)
24177         RCM=SQRT(RCM2)
24178         P3(0)=SQRT(RCM2+EMW*EMW)
24179         P3(1)=0.
24180         P3(2)=RCM*ST
24181         P3(3)=RCM*CT
24182         P4(0)=SQRT(RCM2+EMH*EMH)
24183         P4(1)=0.
24184         P4(2)=-RCM*ST
24185         P4(3)=-RCM*CT
24186 C...incoming parton: massless.
24187         EMIN=0.
24188 C...initial state momenta in the partonic CM.
24189         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
24190      &      -(2.*EMIN*EMIN)**2)/(4.*SHAT)
24191         PCM=SQRT(PCM2)
24192         P1(0)=SQRT(PCM2+EMIN*EMIN)
24193         P1(1)=0.
24194         P1(2)=0.
24195         P1(3)=PCM
24196         P2(0)=SQRT(PCM2+EMIN*EMIN)
24197         P2(1)=0.
24198         P2(2)=0.
24199         P2(3)=-PCM
24200 C...color structured ME summed/averaged over final/initial spins and colors.
24201         CALL HWH2BK(P1,P2,P3,P4,EMW,EMH,M2,M2L,M2T)
24202         IF(M2.LE.0.)RETURN
24203 C...charge conjugation.
24204         M2=M2*2.
24205         M2L=M2L*2.
24206         M2T=M2T*2.
24207 C...constant factors: phi along beam and conversion GeV^2->nb.
24208         FACT=2.*PIFAC*GEV2NB
24209 C...Jacobians from X1,X2 to X(2),X(3)
24210         FACT=FACT/S*(-LOG(TAU))*(1./(EMW+EMH)**2-1./ECM_MAX**2)
24211 C...phase space Jacobians, pi's and flux.
24212         FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
24213 C...hard scale.
24214         EMSCA=RMW+RMH
24215 C...EW couplings.
24216         EMSC2=EMSCA*EMSCA
24217         ALPHA=HWUAEM(EMSC2)
24218         FACT=FACT*(PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
24219 C...Higgs resonance.
24220         FACT=FACT*EMHWT
24221 C...vector boson resonance.
24222         FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
24223 C...constant weight.
24224         FACT=FACT*WEIGHT
24225       END IF
24226 C...set up PDFs.
24227       HCS=0.
24228       CALL HWSGEN(.FALSE.)
24229       DO I=5,11,6
24230         IF(DISF(I,1).LT.EPS)THEN
24231           GOTO 200
24232         END IF
24233         IF(I.LE.6)J=I+6
24234         IF(I.GE.7)J=I-6
24235         IF(DISF(J,2).LT.EPS)THEN
24236           GOTO 200
24237         END IF
24238         DIST=DISF(I,1)*DISF(J,2)*S
24239 C...no need to set up color connections.
24240         HCS=HCS+M2*DIST*FACT
24241         IF(GENEV.AND.HCS.GT.RCS)THEN
24242 C...generate event.
24243           IDN(1)=I
24244           IDN(2)=J
24245           IDN(3)=NINT(198.+HWRGEN(0))
24246           IF(IDN(3).EQ.198)IDN(4)=207
24247           IF(IDN(3).EQ.199)IDN(4)=206
24248 C...set up status and IDs: use HWETWO.
24249           COSTH=CT
24250           IDCMF=15
24251           ICO(1)=2
24252           ICO(2)=1
24253           ICO(3)=3
24254           ICO(4)=4
24255 C...trick HWETWO in using off-shell V mass
24256           VSAVE=RMASS(IDN(3))
24257           RMASS(IDN(3))=EMW
24258 C-- BRW fix 27/8/04: avoid double smearing of V mass
24259           CALL HWETWO(.FALSE.,.TRUE.)
24260           RMASS(IDN(3))=VSAVE
24261           IF(AZSPIN)THEN
24262 C...set to zero the coefficients of the spin density matrices.
24263             CALL HWVZRO(7,GCOEF)
24264           END IF
24265 C...calculates approximately polarized decay matrix of gauge boson.
24266           IF(IERROR.NE.0)RETURN
24267           IHEL=0
24268           IF(ICHRG(I)*ICHRG(IDN(3)).LT.0.D0)IHEL=1
24269           IF(M2L.LT.0.)M2L=0.
24270           IF(M2T.LT.0.)M2T=0.
24271           RHOHEP(2,NHEP-1)=M2L/M2
24272           RHOHEP(1,NHEP-1)=M2T/M2*(1-IHEL)
24273           RHOHEP(3,NHEP-1)=M2T/M2*(  IHEL)
24274           RETURN
24275         END IF
24276  200    CONTINUE
24277       END DO
24278       EVWGT=HCS
24279       END
24280 CDECK  ID>, HWHIG1.
24281 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
24282 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24283 *- Split in 3 files by M. Kirsanov
24284 C-----------------------------------------------------------------------
24285       FUNCTION HWHIG1(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
24286 C-----------------------------------------------------------------------
24287 C     Basic matrix elements for Higgs + jet production; used in HWHIGA
24288 C-----------------------------------------------------------------------
24289       IMPLICIT NONE
24290       DOUBLE COMPLEX HWHIG1,BI(4),CI(7),DI(3)
24291       DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
24292       INTEGER I,J,K,I1,J1,K1
24293       COMMON/CINTS/BI,CI,DI
24294       PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
24295 C-----------------------------------------------------------------------
24296 C     +++ helicity amplitude for: g+g --> g+H
24297 C-----------------------------------------------------------------------
24298       S1=S-EH2
24299       T1=T-EH2
24300       U1=U-EH2
24301       HWHIG1=EQ2*FOUR*DSQRT(TWO*S*T*U)*(
24302      & -FOUR*(ONE/(U*T)+ONE/(U*U1)+ONE/(T*T1))
24303      & -FOUR*((TWO*S+T)*BI(K)/U1**2+(TWO*S+U)*BI(J)/T1**2)/S
24304      & -(S-FOUR*EQ2)*(S1*CI(I1)+(U-S)*CI(J1)+(T-S)*CI(K1))/(S*T*U)
24305      & -8.D0*EQ2*(CI(J1)/(T*T1)+CI(K1)/(U*U1))
24306      & +HALF*(S-FOUR*EQ2)*(S*T*DI(K)+U*S*DI(J)-U*T*DI(I))/(S*T*U)
24307      & +FOUR*EQ2*DI(I)/S
24308      & -TWO*(U*CI(K)+T*CI(J)+U1*CI(K1)+T1*CI(J1)-U*T*DI(I))/S**2 )
24309       END
24310 CDECK  ID>, HWHIG2.
24311 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
24312 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24313 C-----------------------------------------------------------------------
24314       FUNCTION HWHIG2(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
24315 C-----------------------------------------------------------------------
24316 C     Basic matrix elements for Higgs + jet production; used in HWHIGA
24317 C-----------------------------------------------------------------------
24318       IMPLICIT NONE
24319       DOUBLE COMPLEX HWHIG2,BI(4),CI(7),DI(3)
24320       DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
24321       INTEGER I,J,K,I1,J1,K1
24322       COMMON/CINTS/BI,CI,DI
24323       PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
24324 C-----------------------------------------------------------------------
24325 C     ++- helicity amplitude for: g+g --> g+H
24326 C-----------------------------------------------------------------------
24327       S1=S-EH2
24328       T1=T-EH2
24329       U1=U-EH2
24330       HWHIG2=EQ2*FOUR*DSQRT(TWO*S*T*U)*(FOUR*EH2
24331      & +(EH2-FOUR*EQ2)*(S1*CI(4)+T1*CI(5)+U1*CI(6))
24332      & -HALF*(EH2-FOUR*EQ2)*(S*T*DI(3)+U*S*DI(2)+U*T*DI(1)) )/(S*T*U)
24333       END
24334 CDECK  ID>, HWHIG5.
24335 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
24336 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24337 C-----------------------------------------------------------------------
24338       FUNCTION HWHIG5(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
24339 C-----------------------------------------------------------------------
24340 C     Basic matrix elements for Higgs + jet production; used in HWHIGA
24341 C-----------------------------------------------------------------------
24342       IMPLICIT NONE
24343       DOUBLE COMPLEX HWHIG5,BI(4),CI(7),DI(3)
24344       DOUBLE PRECISION S,T,U,EH2,EQ2,ONE,TWO,FOUR,HALF
24345       INTEGER I,J,K,I1,J1,K1
24346       COMMON/CINTS/BI,CI,DI
24347       PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
24348 C-----------------------------------------------------------------------
24349 C     Amplitude for: q+qbar --> g+H
24350 C-----------------------------------------------------------------------
24351       HWHIG5=DCMPLX(TWO)+DCMPLX(TWO*S/(S-EH2))*BI(I)
24352      &      +DCMPLX(FOUR*EQ2-U-T)*CI(K)
24353       END
24354 CDECK  ID>, HWHIBQ.
24355 *CMZ :-        -30/06/01  18.40.33  by  Stefano Moretti
24356 *-- Author :  Stefano Moretti
24357 C-----------------------------------------------------------------------
24358 C...Generate completely differential cross section (EVWGT) in the variables
24359 C...X(I) with I=1,6 (see below) for the process IPROC=3500, as described
24360 C...in the HERWIG 6 documentation file.
24361 C...It includes interface to PDFs and takes into account color connections
24362 C...among partons.
24363 C
24364 C...First release: 12-APR-2000 by Stefano Moretti
24365 C
24366 C-----------------------------------------------------------------------
24367       SUBROUTINE HWHIBQ
24368 C-----------------------------------------------------------------------
24369 C     PRODUCTION OF MSSM CHARGED HIGGSES FROM B-QUARK+LIGHT-QUARK FUSION
24370 C-----------------------------------------------------------------------
24371       INCLUDE 'herwig65.inc'
24372       INTEGER I,J,K,L,M,N
24373       INTEGER II,JJ,ITMP
24374       INTEGER IFL,IRES
24375       DOUBLE PRECISION EMQ,ENQ,EMQH,EMB,EMH,EMHWT,EMT,EMW
24376       DOUBLE PRECISION EMH01,EMH02,EMH03
24377       DOUBLE PRECISION WCKM,CKM,GAMT
24378       DOUBLE PRECISION X(6),XL(6),XU(6)
24379       DOUBLE PRECISION Q3(0:3),Q35(0:3)
24380       DOUBLE PRECISION Q1(5),Q2(5),H(5)
24381       DOUBLE PRECISION CT4,ST4,CT3,ST3,CF3,SF3,RQ42,RQ4,RQ32,RQ3,PQ3
24382       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
24383       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
24384       DOUBLE PRECISION XTMP
24385       DOUBLE PRECISION EMIN1,EMIN2,PCM2,PCM
24386       DOUBLE PRECISION M2B,M2BBAR
24387       DOUBLE PRECISION ALPHA,EMSC2
24388       DOUBLE PRECISION HWRGEN,HWUAEM
24389       DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
24390       DOUBLE PRECISION QAUX(0:3)
24391       DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
24392       DOUBLE PRECISION WEIGHT
24393       SAVE HCS,M2B,M2BBAR,FACT,S,WCKM,P3,P4,P5
24394       LOGICAL HWRLOG
24395       EXTERNAL HWRGEN,HWUAEM,HWH2BH,HWEONE,HWRLOG,
24396      &         HWUMAS,HWULOB
24397       EQUIVALENCE (EMB,RMASS(5)),(EMT,RMASS(6))
24398       EQUIVALENCE (EMW,RMASS(198))
24399       EQUIVALENCE (EMH01,RMASS(204)),
24400      &            (EMH02,RMASS(203)),
24401      &            (EMH03,RMASS(205))
24402       EQUIVALENCE (CKM,VCKM(3,3))
24403       PARAMETER (EPS=1.D-9)
24404       IF(GENEV)THEN
24405         RCS=HCS*HWRGEN(0)
24406       ELSE
24407         HCS=0.
24408         EVWGT=0.
24409 C...assign final state masses.
24410         EMQ=0.
24411         ENQ=0
24412         EMH=RMASS(206)
24413         EMHWT=1.
24414 C...assign top width.
24415         GAMT=HBAR/RLTIM(6)
24416 C...energy at hadron level.
24417         ECM_MAX=PBEAM1+PBEAM2
24418         S=ECM_MAX*ECM_MAX
24419 C...phase space variables.
24420 C...X(1)=(EMQH-EMQ-EMH)/(ECM-EMQ-ENQ-EMH),
24421 C...X(2)=1/[-(P2-P3)^2+MW^2],X(3)=COS(THETA4_CM_35),X(4)=FI4_CM_35,
24422 C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2),
24423 C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
24424 C...phase space borders.
24425         XL(1)=0.
24426         XU(1)=1.
24427 c...for XL(2),XU(2) see below (non constant).
24428         XL(3)=-1.
24429         XU(3)=1.
24430         XL(4)=0.
24431         XU(4)=2.*PIFAC
24432         XL(5)=0.
24433         XU(5)=1.
24434         XL(6)=0.
24435         XU(6)=1.
24436 C...single phase space point.
24437  100    CONTINUE
24438         WEIGHT=1.
24439         DO I=1,6
24440           IF(I.EQ.2)GOTO 125
24441           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
24442           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
24443  125      CONTINUE
24444         END DO
24445 C...energy at parton level.
24446         ECM=SQRT(1./(X(5)*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
24447      &                                        +1./ECM_MAX**2))
24448         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
24449         SHAT=ECM*ECM
24450         TAU=SHAT/S
24451 C...momentum fractions X1 and X2.
24452         XX(1)=EXP(LOG(TAU)*(1.-X(6)))
24453         XX(2)=TAU/XX(1)
24454 C...incoming partons massless.
24455         EMIN1=0.
24456         EMIN2=0.
24457 C...initial state momenta in the partonic CM.
24458         PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
24459      &         -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
24460         PCM=SQRT(PCM2)
24461 C...three particle kinematics.
24462         EMQH=X(1)*(ECM-EMQ-ENQ-EMH)+EMQ+EMH
24463         RQ42=((ECM*ECM-ENQ*ENQ-EMQH*EMQH)**2-(2.*ENQ*EMQH)**2)/
24464      &       (4.*ECM*ECM)
24465         IF(RQ42.LT.0.)THEN
24466           GOTO 100
24467         ELSE
24468           RQ4=SQRT(RQ42)
24469         ENDIF
24470 C...X(2): integrate over W propagator.
24471         XL(2)=1./(4.*SQRT(PCM2+EMIN2*EMIN2)*RQ4+EMW*EMW)
24472         XU(2)=1./(EMW*EMW)
24473         X(2)=XL(2)+(XU(2)-XL(2))*HWRGEN(0)
24474         WEIGHT=WEIGHT*ABS(XU(2)-XL(2))
24475         XTMP=1./X(2)
24476         XTMP=(XTMP-EMW*EMW)/2./SQRT(PCM2+EMIN2*EMIN2)
24477         CT4=1.-XTMP/((SHAT-EMQH*EMQH+2.*ENQ*ENQ)/(2.*ECM))
24478         IF(CT4.GT.+1.)CT4=+1.
24479         IF(CT4.LT.-1.)CT4=-1.
24480         IF(HWRLOG(HALF))THEN
24481           ST4=+SQRT(1.-CT4*CT4)
24482         ELSE
24483           ST4=-SQRT(1.-CT4*CT4)
24484         END IF
24485         CT3=X(3)
24486         ST3=SQRT(1.-CT3*CT3)
24487         CF3=COS(X(4))
24488         SF3=SIN(X(4))
24489         P4(1)=0.
24490         P4(2)=-RQ4*ST4
24491         P4(3)=-RQ4*CT4
24492         P4(0)=SQRT(RQ42+ENQ*ENQ)
24493         DO I=1,3
24494           Q35(I)=-P4(I)
24495         END DO
24496         Q35(0)=SQRT(RQ42+EMQH*EMQH)
24497         RQ32=((EMQH*EMQH-EMH*EMH-EMQ*EMQ)**2-(2.*EMH*EMQ)**2)/
24498      &      (4.*EMQH*EMQH)
24499         IF(RQ32.LT.0.)THEN
24500           GOTO 100
24501         ELSE
24502           RQ3=SQRT(RQ32)
24503         ENDIF
24504         Q3(1)=RQ3*ST3*CF3
24505         Q3(2)=RQ3*ST3*SF3
24506         Q3(3)=RQ3*CT3
24507         Q3(0)=SQRT(RQ32+EMQ*EMQ)
24508         PQ3=0.
24509         DO I=1,3
24510           PQ3=PQ3+Q35(I)*Q3(I)
24511         END DO
24512         P3(0)=(Q35(0)*Q3(0)+PQ3)/EMQH
24513         P5(0)=Q35(0)-P3(0)
24514         DO I=1,3
24515           P3(I)=Q3(I)+Q35(I)*(P3(0)+Q3(0))/(Q35(0)+EMQH)
24516           P5(I)=Q35(I)-P3(I)
24517         END DO
24518 C...initial state.
24519         P1(0)=SQRT(PCM2+EMIN1*EMIN1)
24520         P1(1)=0.
24521         P1(2)=0.
24522         P1(3)=PCM
24523         P2(0)=SQRT(PCM2+EMIN2*EMIN2)
24524         P2(1)=0.
24525         P2(2)=0.
24526         P2(3)=-PCM
24527 C...option: top diagram removed if can be resonant to avoid double counting.
24528         IRES=1
24529 C        IF((EMT-EMB-EMH).GE.0.)IRES=0
24530 C...color structured ME summed/averaged over final/initial spins and colors.
24531 C...IFL=+1 selects b.
24532         IFL=+1
24533         CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
24534      &              IFL,IRES,CKM,GAMT,M2B)
24535 C...IFL=-1 selects b-bar.
24536         IFL=-1
24537         CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
24538      &              IFL,IRES,CKM,GAMT,M2BBAR)
24539 C...constant factors: phi along beam and conversion GeV^2->nb.
24540         FACT=2.*PIFAC*GEV2NB
24541 C...Jacobians from X1,X2 to X(5),X(6)
24542         FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
24543 C...phase space Jacobians, pi's and flux.
24544         FACT=FACT*RQ3*RQ4/PCM/32./(2.*PIFAC)**5
24545      &      *(ECM-EMQ-ENQ-EMH)
24546         FACT=FACT/2./P2(0)/P4(0)
24547         FACT=FACT*(2.*P2(0)*P4(0)*(1.-CT4)+EMW*EMW)**2
24548 C...EW couplings.
24549         EMSCA=EMQ+ENQ+EMH
24550         EMSC2=EMSCA*EMSCA
24551         ALPHA=HWUAEM(EMSC2)
24552         FACT=FACT*64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
24553 C...Higgs resonance.
24554         FACT=FACT*EMHWT
24555 C...constant weight.
24556         FACT=FACT*WEIGHT
24557       END IF
24558 C...set up PDFs.
24559       HCS=0.
24560       CALL HWSGEN(.FALSE.)
24561       DO I=1,12
24562         IF(DISF(I,1).LT.EPS)THEN
24563           GOTO 200
24564         END IF
24565         DO J=1,12
24566           IF(DISF(J,2).LT.EPS)THEN
24567             GOTO 175
24568           END IF
24569           IF((I.NE.5).AND.(I.NE.11).AND.
24570      &       (J.NE.5).AND.(J.NE.11))THEN
24571             GOTO 150
24572           END IF
24573           II=J
24574           IF((I.NE.5).AND.(I.NE.11))II=I
24575           IF(II.GT.6)II=II-6
24576           ITMP=II
24577           II=(II+1)/2
24578           DIST=0.
24579           DO JJ=1,3
24580             WCKM=VCKM(II,JJ)
24581             IF((ITMP.EQ.5).AND.(II.EQ.3).AND.(JJ.EQ.3))WCKM=0.
24582             DIST=DIST+DISF(I,1)*DISF(J,2)*WCKM*S
24583           END DO
24584           IF((I.LE.6).AND.(J.LE.6))THEN
24585             HCS=HCS+M2B*DIST*FACT
24586           ELSE IF((I.LE.6).AND.(J.GE.7))THEN
24587             IF(J.NE.11)HCS=HCS+M2B*DIST*FACT
24588             IF(J.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
24589           ELSE IF((I.GE.7).AND.(J.LE.6))THEN
24590             IF(I.NE.11)HCS=HCS+M2B*DIST*FACT
24591             IF(I.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
24592           ELSE IF((I.GE.7).AND.(J.GE.7))THEN
24593             HCS=HCS+M2BBAR*DIST*FACT
24594           END IF
24595           IF(GENEV.AND.HCS.GT.RCS)THEN
24596 C...generate event.
24597             IDN(1)=I
24598             IDN(2)=J
24599             IF((I.EQ.5).OR.(I.EQ.11))THEN
24600               K=I
24601               L=J+(-1)**(J+1)
24602               IDN(3)=K
24603               IDN(4)=L
24604             ELSE
24605               L=I+(-1)**(J+1)
24606               K=J
24607               IDN(3)=L
24608               IDN(4)=K
24609             END IF
24610             IF(IDN(2).EQ.IDN(4))THEN
24611               IDN(5)=
24612      &        NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))-ICHRG(IDN(3))))
24613           ELSE
24614               IDN(5)=
24615      &        NINT(198.5-.1667*FLOAT(ICHRG(IDN(2))-ICHRG(IDN(4))))
24616             END IF
24617             IDN(5)=IDN(5)+8
24618 C...sets up incoming status and IDs only for 2->1: use HWEONE.
24619             IDCMF=15
24620             CALL HWEONE
24621             JDAHEP(1,NHEP)=NHEP+1
24622             JDAHEP(2,NHEP)=NHEP+3
24623             JMOHEP(1,NHEP+1)=NHEP
24624             JMOHEP(1,NHEP+2)=NHEP
24625             JMOHEP(1,NHEP+3)=NHEP
24626 C...randomly rotate final state momenta around beam axis.
24627             PHI=2.*PIFAC*HWRGEN(0)
24628             CPHI=COS(PHI)
24629             SPHI=SIN(PHI)
24630             ROT(1,1)=+CPHI
24631             ROT(1,2)=+SPHI
24632             ROT(1,3)=0.
24633             ROT(2,1)=-SPHI
24634             ROT(2,2)=+CPHI
24635             ROT(2,3)=0.
24636             ROT(3,1)=0.
24637             ROT(3,2)=0.
24638             ROT(3,3)=1.
24639             DO L=1,3
24640               DO M=1,3
24641                 QAUX(M)=0.
24642                 DO N=1,3
24643                   IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
24644                   IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
24645                   IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
24646                 END DO
24647               END DO
24648               DO M=1,3
24649                 IF(L.EQ.1)P3(M)=QAUX(M)
24650                 IF(L.EQ.2)P4(M)=QAUX(M)
24651                 IF(L.EQ.3)P5(M)=QAUX(M)
24652               END DO
24653             END DO
24654 C...outgoing momenta (give quark masses non covariantly!)
24655             DO M=1,3
24656               Q1(M)=P3(M)
24657               Q2(M)=P4(M)
24658               H( M)=P5(M)
24659             END DO
24660             Q1(4)=P3(0)
24661             Q2(4)=P4(0)
24662             H( 4)=P5(0)
24663             Q1(5)=RMASS(IDN(3))
24664             Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
24665             Q2(5)=RMASS(IDN(4))
24666             Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
24667             H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
24668             CALL HWUMAS(H)
24669             CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
24670             CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
24671             CALL HWULOB(PHEP(1,NHEP),H ,PHEP(1,NHEP+3))
24672 C...sets up outgoing status and IDs.
24673             ISTHEP(NHEP+1)=113
24674             ISTHEP(NHEP+2)=114
24675             ISTHEP(NHEP+3)=114
24676             IDHW(NHEP+1)=IDN(3)
24677             IDHEP(NHEP+1)=IDPDG(IDN(3))
24678             IDHW(NHEP+2)=IDN(4)
24679             IDHEP(NHEP+2)=IDPDG(IDN(4))
24680             IDHW(NHEP+3)=IDN(5)
24681             IDHEP(NHEP+3)=IDPDG(IDN(5))
24682 C...sets up colour connections.
24683             JMOHEP(2,NHEP+1)=NHEP-2
24684             JMOHEP(2,NHEP+2)=NHEP-1
24685             JMOHEP(2,NHEP-1)=NHEP+2
24686             JMOHEP(2,NHEP-2)=NHEP+1
24687             JMOHEP(2,NHEP+3)=NHEP+3
24688             JDAHEP(2,NHEP+1)=NHEP-2
24689             JDAHEP(2,NHEP+2)=NHEP-1
24690             JDAHEP(2,NHEP-1)=NHEP+2
24691             JDAHEP(2,NHEP-2)=NHEP+1
24692             JDAHEP(2,NHEP+3)=NHEP+3
24693             NHEP=NHEP+3
24694             IF(AZSPIN)THEN
24695 C...set to zero the coefficients of the spin density matrices.
24696               CALL HWVZRO(7,GCOEF)
24697             END IF
24698             RETURN
24699           END IF
24700  150      CONTINUE
24701  175      CONTINUE
24702         END DO
24703  200    CONTINUE
24704       END DO
24705       EVWGT=HCS
24706       END
24707 CDECK  ID>, HWHIGA.
24708 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
24709 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24710 C-----------------------------------------------------------------------
24711       SUBROUTINE HWHIGA(S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG)
24712 C-----------------------------------------------------------------------
24713 C     Gives amplitudes squared for q-qbar, q(bar)-g and gg -> Higgs +jet
24714 C     IAPHIG (set in HWIGIN)=0: zero mass approximation =1: exact result
24715 C                           =2: infinite mass limit.
24716 C     Only top loop included. A factor (alpha_s**3*alpha_W) is extracted
24717 C-----------------------------------------------------------------------
24718       INCLUDE 'herwig65.inc'
24719       DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2,BI(4),
24720      & CI(7),DI(3),EPSI,TAMP(7)
24721       DOUBLE PRECISION S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG,EMW2,RNGLU,RNQRK,
24722      & FLUXGG,FLUXGQ,FLUXQQ,EMQ2,TAMPI(7),TAMPR(7)
24723       INTEGER I
24724       LOGICAL NOMASS
24725       EXTERNAL HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2
24726       COMMON/SMALL/EPSI
24727       COMMON/CINTS/BI,CI,DI
24728       EPSI=DCMPLX(ZERO,-1.D-10)
24729       EMW2=RMASS(198)**2
24730 C Spin and colour flux factors plus enhancement factor
24731       RNGLU=1./FLOAT(NCOLO**2-1)
24732       RNQRK=1./FLOAT(NCOLO)
24733       FLUXGG=.25*RNGLU**2*ENHANC(6)**2
24734       FLUXGQ=.25*RNGLU*RNQRK*ENHANC(6)**2
24735       FLUXQQ=.25*RNQRK**2*ENHANC(6)**2
24736       IF (IAPHIG.EQ.2) THEN
24737 C Infinite mass limit in loops
24738          WTGG=(2./3.)**2*FLOAT(NCOLO*(NCOLO**2-1))
24739      &       *(EMH2**4+S**4+T**4+U**4)/(S*T*U*EMW2)*FLUXGG
24740          WTQQ= 16./9.*(U**2+T**2)/(S*EMW2)*FLUXQQ
24741          WTQG=-16./9.*(U**2+S**2)/(T*EMW2)*FLUXGQ
24742          WTGQ=-16./9.*(S**2+T**2)/(U*EMW2)*FLUXGQ
24743          RETURN
24744       ELSEIF (IAPHIG.EQ.1) THEN
24745 C Exact result for loops
24746          NOMASS=.FALSE.
24747       ELSEIF (IAPHIG.EQ.0) THEN
24748 C Small mass approximation in loops
24749          NOMASS=.TRUE.
24750       ELSE
24751          CALL HWWARN('HWHIGA',500)
24752       ENDIF
24753 C Include only top quark contribution
24754       EMQ2=RMASS(6)**2
24755       BI(1)=HWHIGB(NOMASS,S,ZERO,ZERO,EMQ2)
24756       BI(2)=HWHIGB(NOMASS,T,ZERO,ZERO,EMQ2)
24757       BI(3)=HWHIGB(NOMASS,U,ZERO,ZERO,EMQ2)
24758       BI(4)=HWHIGB(NOMASS,EMH2,ZERO,ZERO,EMQ2)
24759       BI(1)=BI(1)-BI(4)
24760       BI(2)=BI(2)-BI(4)
24761       BI(3)=BI(3)-BI(4)
24762       CI(1)=HWHIGC(NOMASS,S,ZERO,ZERO,EMQ2)
24763       CI(2)=HWHIGC(NOMASS,T,ZERO,ZERO,EMQ2)
24764       CI(3)=HWHIGC(NOMASS,U,ZERO,ZERO,EMQ2)
24765       CI(7)=HWHIGC(NOMASS,EMH2,ZERO,ZERO,EMQ2)
24766       CI(4)=(S*CI(1)-EMH2*CI(7))/(S-EMH2)
24767       CI(5)=(T*CI(2)-EMH2*CI(7))/(T-EMH2)
24768       CI(6)=(U*CI(3)-EMH2*CI(7))/(U-EMH2)
24769       DI(1)=HWHIGD(NOMASS,U,T,EMH2,EMQ2)
24770       DI(2)=HWHIGD(NOMASS,S,U,EMH2,EMQ2)
24771       DI(3)=HWHIGD(NOMASS,S,T,EMH2,EMQ2)
24772 C Compute complex amplitudes
24773       TAMP(1)=HWHIG1(S,T,U,EMH2,EMQ2,1,2,3,4,5,6)
24774       TAMP(2)=HWHIG2(S,T,U,EMH2,EMQ2,1,2,3,0,0,0)
24775       TAMP(3)=HWHIG1(T,S,U,EMH2,EMQ2,2,1,3,5,4,6)
24776       TAMP(4)=HWHIG1(U,T,S,EMH2,EMQ2,3,2,1,6,5,4)
24777       TAMP(5)=HWHIG5(S,T,U,EMH2,EMQ2,1,0,4,0,0,0)
24778       TAMP(6)=HWHIG5(T,S,U,EMH2,EMQ2,2,0,5,0,0,0)
24779       TAMP(7)=HWHIG5(U,T,S,EMH2,EMQ2,3,0,6,0,0,0)
24780       DO 20 I=1,7
24781       TAMPI(I)= DREAL(TAMP(I))
24782   20  TAMPR(I)=-DIMAG(TAMP(I))
24783 C Square and add prefactors
24784       WTGG=0.03125*FLOAT(NCOLO*(NCOLO**2-1))/EMW2
24785      &    *(TAMPR(1)**2+TAMPI(1)**2+TAMPR(2)**2+TAMPI(2)**2
24786      &     +TAMPR(3)**2+TAMPI(3)**2+TAMPR(4)**2+TAMPI(4)**2)*FLUXGG
24787       WTQQ= 16.*(U**2+T**2)/(U+T)**2*EMQ2**2/(S*EMW2)
24788      &     *(TAMPR(5)**2+TAMPI(5)**2)*FLUXQQ
24789       WTQG=-16.*(U**2+S**2)/(U+S)**2*EMQ2**2/(T*EMW2)
24790      &     *(TAMPR(6)**2+TAMPI(6)**2)*FLUXGQ
24791       WTGQ=-16.*(S**2+T**2)/(S+T)**2*EMQ2**2/(U*EMW2)
24792      &     *(TAMPR(7)**2+TAMPI(7)**2)*FLUXGQ
24793       END
24794 CDECK  ID>, HWHIGB.
24795 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
24796 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24797 *- split in 3 files by M. Kirsanov
24798 C-----------------------------------------------------------------------
24799       FUNCTION HWHIGB(NOMASS,S,T,EH2,EQ2)
24800 C-----------------------------------------------------------------------
24801 C     One loop scalar integrals, used in HWHIGJ.
24802 C     If NOMASS=.TRUE. use a small mass approx. for particle in loop.
24803 C-----------------------------------------------------------------------
24804       INCLUDE 'herwig65.inc'
24805       DOUBLE COMPLEX HWHIGB,HWUCI2,HWULI2,EPSI,PII
24806       DOUBLE PRECISION S,T,EQ2,EH2,RAT
24807       LOGICAL NOMASS
24808       EXTERNAL HWULI2,HWUCI2
24809       COMMON/SMALL/EPSI
24810 C-----------------------------------------------------------------------
24811 C     B_0(2p1.p2=S;mq,mq)
24812 C-----------------------------------------------------------------------
24813       PII=DCMPLX(ZERO,PIFAC)
24814       IF (NOMASS) THEN
24815          RAT=DABS(S/EQ2)
24816          HWHIGB=-DLOG(RAT)+TWO
24817          IF (S.GT.ZERO) HWHIGB=HWHIGB+PII
24818       ELSE
24819          RAT=S/(FOUR*EQ2)
24820          IF (S.LT.ZERO) THEN
24821             HWHIGB=TWO-TWO*DSQRT(ONE-ONE/RAT)
24822      &                    *DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))
24823          ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
24824             HWHIGB=TWO-TWO*DSQRT(ONE/RAT-ONE)*DASIN(DSQRT(RAT))
24825          ELSEIF (RAT.GT.ONE) THEN
24826             HWHIGB=TWO-DSQRT(ONE-ONE/RAT)
24827      &                *(TWO*DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))-PII)
24828          ENDIF
24829       ENDIF
24830       END
24831 CDECK  ID>, HWHIGC.
24832 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
24833 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24834 C-----------------------------------------------------------------------
24835       FUNCTION HWHIGC(NOMASS,S,T,EH2,EQ2)
24836 C-----------------------------------------------------------------------
24837 C     One loop scalar integrals, used in HWHIGJ.
24838 C     If NOMASS=.TRUE. use a small mass approx. for particle in loop.
24839 C-----------------------------------------------------------------------
24840       INCLUDE 'herwig65.inc'
24841       DOUBLE COMPLEX HWHIGC,HWUCI2,HWULI2,EPSI,PII
24842       DOUBLE PRECISION S,T,EQ2,EH2,RAT,COSH
24843       LOGICAL NOMASS
24844       EXTERNAL HWULI2,HWUCI2
24845       COMMON/SMALL/EPSI
24846 C-----------------------------------------------------------------------
24847 C     C_0(p{1,2}^2=0,2p1.p2=S;mq,mq,mq)
24848 C-----------------------------------------------------------------------
24849       PII=DCMPLX(ZERO,PIFAC)
24850       IF (NOMASS) THEN
24851          RAT=DABS(S/EQ2)
24852          HWHIGC=HALF*DLOG(RAT)**2
24853          IF (S.GT.ZERO) HWHIGC=HWHIGC-HALF*PIFAC**2-PII*DLOG(RAT)
24854          HWHIGC=HWHIGC/S
24855       ELSE
24856          RAT=S/(FOUR*EQ2)
24857          IF (S.LT.ZERO) THEN
24858             HWHIGC=TWO*DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))**2/S
24859          ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
24860             HWHIGC=-TWO*(DASIN(DSQRT(RAT)))**2/S
24861          ELSEIF (RAT.GT.ONE) THEN
24862             COSH=DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))
24863             HWHIGC=TWO*(COSH**2-PIFAC**2/FOUR-PII*COSH)/S
24864          ENDIF
24865       ENDIF
24866       END
24867 CDECK  ID>, HWHIGD.
24868 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
24869 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24870 C-----------------------------------------------------------------------
24871       FUNCTION HWHIGD(NOMASS,S,T,EH2,EQ2)
24872 C-----------------------------------------------------------------------
24873 C     One loop scalar integrals, used in HWHIGJ.
24874 C     If NOMASS=.TRUE. use a small mass approx. for particle in loop.
24875 C-----------------------------------------------------------------------
24876       INCLUDE 'herwig65.inc'
24877       DOUBLE COMPLEX HWHIGD,HWUCI2,HWULI2,EPSI,PII,Z1,Z2
24878       DOUBLE PRECISION S,T,EQ2,EH2,DLS,DLT,DLM,RZ12,DL1,DL2,
24879      & ST,ROOT,XP,XM
24880       LOGICAL NOMASS
24881       EXTERNAL HWULI2,HWUCI2
24882       COMMON/SMALL/EPSI
24883 C-----------------------------------------------------------------------
24884 C     D_0(p{1,2,3}^2=0,p4^2=EH2,2p1.p2=S,2p2.p3=T;mq,mq,mq,mq)
24885 C-----------------------------------------------------------------------
24886       PII=DCMPLX(ZERO,PIFAC)
24887       IF (NOMASS) THEN
24888          DLS=DLOG(DABS(S/EQ2))
24889          DLT=DLOG(DABS(T/EQ2))
24890          DLM=DLOG(DABS(EH2/EQ2))
24891          IF (S.GE.ZERO.AND.T.LE.ZERO) THEN
24892             DL1=DLOG((EH2-T)/S)
24893             Z1=T/(T-EH2)
24894             Z2=(S-EH2)/S
24895             HWHIGD=DLS**2+DLT**2-DLM**2+DL1**2
24896      &            +TWO*(DLOG(S/(EH2-T))*DLOG(-T/S)+HWULI2(Z1)-HWULI2(Z2)
24897      &                 +PII*DLOG(EH2/(EH2-T)))
24898          ELSEIF (S.LT.ZERO.AND.T.LT.ZERO) THEN
24899             Z1=(S-EH2)/S
24900             Z2=(T-EH2)/T
24901             RZ12=ONE/DREAL(Z1*Z2)
24902             DL1=DLOG((T-EH2)/(S-EH2))
24903             DL2=DLOG(RZ12)
24904             HWHIGD=DLS**2+DLT**2-DLM**2+TWO*PIFAC**2/THREE
24905      &            +TWO*DLOG(S/(T-EH2))*DLOG(ONE/DREAL(Z2))
24906      &            +TWO*DLOG(T/(S-EH2))*DLOG(ONE/DREAL(Z1))
24907      &            -DL1**2-DL2**2-TWO*(HWULI2(Z1)+HWULI2(Z2))
24908      &            +TWO*PII*DLOG(RZ12**2*EH2/EQ2)
24909          ENDIF
24910          HWHIGD=HWHIGD/(S*T)
24911       ELSE
24912          ST=S*T
24913          ROOT=DSQRT(ST**2-FOUR*ST*EQ2*(S+T-EH2))
24914          XP=HALF*(ST+ROOT)/ST
24915          XM=1-XP
24916          HWHIGD=TWO/ROOT*(-HWUCI2(EQ2,S,XP)-HWUCI2(EQ2,T,XP)
24917      &         +HWUCI2(EQ2,EH2,XP)+DLOG(-XM/XP)
24918      &         *(LOG(EQ2+EPSI)-LOG(EQ2+EPSI-S*XP*XM)
24919      &          +LOG(EQ2+EPSI-EH2*XP*XM)-LOG(EQ2+EPSI-T*XP*XM)))
24920       ENDIF
24921       END
24922 CDECK  ID>, HWHIGE.
24923 *CMZ :-        -13/10/02  09.43.05  by  Peter Richardson
24924 *-- Author :    Kosuke Odagiri and Stefano Moretti
24925 C-----------------------------------------------------------------------
24926 C...Generate completely differential cross section (EVWGT) in the variables
24927 C...X(I) with I=1,4 (see below) for the processes from IPROC=1000-1099 (SM),
24928 C...IPROC=1111-1139 (MSSM), as described in the HERWIG 6 documentation file.
24929 C...(For IPROC=1140-1145 it describes MSSM charged Higgs production.)
24930 C
24931 C...First release: 18-SEP-2002 by Stefano Moretti
24932 C
24933       SUBROUTINE HWHIGE
24934 C--------------------------------------------------------------------------
24935 C     LEPTOPRODUCTION OF MS(SM) HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
24936 C--------------------------------------------------------------------------
24937       INCLUDE 'herwig65.inc'
24938       INTEGER JHIGGS
24939       INTEGER I,L,M,N,NN
24940       INTEGER IH,IQ,JQ,IIQ,JJQ
24941       INTEGER IAD
24942       INTEGER IDEC,FLIP
24943       INTEGER ID1,ID2
24944       DOUBLE PRECISION CV,CA,BR
24945       DOUBLE PRECISION BRHIGQ,EMQ,ENQ,GMQ,EMQQ,EMH,GMH,EMHWT
24946       DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
24947       DOUBLE PRECISION X(4),XL(4),XU(4)
24948       DOUBLE PRECISION Q4(0:3),Q34(0:3)
24949       DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
24950       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
24951       DOUBLE PRECISION F(0:3),G(0:3)
24952       DOUBLE PRECISION ECM,SHAT,S
24953       DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
24954       DOUBLE PRECISION HFC,HBC
24955       DOUBLE PRECISION M2EE
24956       DOUBLE PRECISION ALPHA,EMSC2
24957       DOUBLE PRECISION HWRGEN,HWUAEM
24958       DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
24959       DOUBLE PRECISION QAUX(0:3)
24960       DOUBLE PRECISION EPS,HCS,RCS,FACT
24961       DOUBLE PRECISION WEIGHT
24962       INTEGER IFL,KHIGGS,JH,JFL
24963       LOGICAL FIRST,GAUGE
24964       DOUBLE PRECISION E,Q3,YM3,GAM3,YM4,GAM4,GAM5,COLOUR
24965       DOUBLE PRECISION RM3,RM4,RM5
24966       DOUBLE PRECISION S2W,RMW,RMZ
24967       DOUBLE PRECISION RMHL,GAMHL
24968       DOUBLE PRECISION RMHH,GAMHH
24969       DOUBLE PRECISION RMHA,GAMHA
24970       EQUIVALENCE (RMHL,RMASS(203)),(RMHH,RMASS(204)),(RMHA,RMASS(205))
24971       LOGICAL HWRLOG
24972       EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2HE,HWEONE,HWRLOG
24973       PARAMETER (EPS=1.D-9)
24974       SAVE HCS,M2EE,FACT,S,SHAT,P3,P4,P5
24975       SAVE IIQ,JJQ,JHIGGS
24976 C...ASSIGN Q/Q'-FLAVOUR.
24977       IF(IPROC.GE.1140)THEN
24978         IH=4
24979         IF(IPROC.EQ.1140)IQ=2
24980         IF(IPROC.EQ.1141)IQ=4
24981         IF(IPROC.EQ.1142)IQ=6
24982         IF(IPROC.EQ.1143)IQ=7
24983         IF(IPROC.EQ.1144)IQ=8
24984         IF(IPROC.EQ.1145)IQ=9
24985         IAD=7
24986         JQ=IQ+5
24987         GMQ=ZERO
24988         IF(JQ.EQ.11)GMQ=HBAR/RLTIM(6)
24989       ELSE
24990         IF(IMSSM.EQ.0)THEN
24991           IH=0
24992           IQ=6
24993         ELSE
24994           IF(IPROC.LT.1140)IH=3
24995           IF(IPROC.LT.1130)IH=2
24996           IF(IPROC.LT.1120)IH=1
24997           IQ=IPROC-1100-10*IH
24998         END IF
24999         IAD=6
25000         JQ=IQ+6
25001         GMQ=ZERO
25002       END IF
25003 C...PROCESS EVENT.
25004       IF(GENEV)THEN
25005         RCS=HCS*HWRGEN(0)
25006       ELSE
25007         EVWGT=0.
25008         HCS=0.
25009 C...ASSIGN FINAL STATE MASSES.
25010         IF(IQ.LE.6)THEN
25011           EMQ=RMASS(IQ)
25012           ENQ=RMASS(JQ)
25013         ELSE
25014           EMQ=RMASS(2*IQ-7+114+IAD)
25015           ENQ=RMASS(2*IQ-7+114    )
25016         END IF
25017         EMH=RMASS(201+IHIGGS)
25018         GMH=HBAR/RLTIM(201+IHIGGS)
25019         EMHWT=1.
25020 C...ENERGY AT PARTON LEVEL.
25021         ECM=PBEAM1+PBEAM2
25022         S=ECM*ECM
25023         SHAT=S
25024         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
25025 C...PHASE SPACE VARIABLES.
25026 C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
25027 C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
25028 C...                X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34),
25029 C...HEAVY QUARKS -> X(2)=COS(THETA5_CM),
25030 C...                X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
25031 C...PHASE SPACE BORDERS.
25032         XL(1)=0.
25033         XU(1)=1.
25034         IF((IQ+JQ).EQ.18)THEN
25035           XL(2)=-1.
25036           XL(4)=0.
25037           XU(4)=2.*PIFAC
25038         ELSE
25039           XL(2)=0.
25040           XL(4)=-1.
25041           XU(4)=1.
25042         END IF
25043         XU(2)=1.
25044         XL(3)=-1.
25045         XU(3)=1.
25046 C...SINGLE PHASE SPACE POINT.
25047  100    CONTINUE
25048         WEIGHT=1.
25049         DO I=1,4
25050           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
25051           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
25052         END DO
25053 C...THREE PARTICLE KINEMATICS.
25054         EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
25055 C...INCOMING PARTONS: ALL MASSLESS.
25056         EMIN=0.
25057         IF((IQ+JQ).EQ.18)THEN
25058           CT5=X(2)
25059           CT4=X(3)
25060           ST4=SQRT(1.-CT4*CT4)
25061           CF4=COS(X(4))
25062           SF4=SIN(X(4))
25063         ELSE
25064           PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2
25065      &        -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM)
25066           PCM=SQRT(PCM2)
25067           RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2
25068      &        -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM)
25069           RCM=SQRT(RCM2)
25070           TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
25071      &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
25072      &    -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
25073      &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
25074           TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
25075      &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
25076      &    +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
25077      &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
25078           TLMIN=LOG(ABS(TTMAX))
25079           TLMAX=LOG(ABS(TTMIN))
25080           TL=X(2)*(TLMAX-TLMIN)+TLMIN
25081           T=EXP(ABS(TL))
25082           CTMP=-T-EMIN**2-EMQQ**2
25083      &       +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2)
25084           CT5=CTMP/2./PCM/RCM
25085           ST4=X(3)
25086           CT4=SQRT(1.-ST4*ST4)
25087           CF4=X(4)
25088           SF4=SQRT(1.-CF4*CF4)
25089         END IF
25090         IF(HWRLOG(HALF))THEN
25091           ST5=+SQRT(1.-CT5*CT5)
25092         ELSE
25093           ST5=-SQRT(1.-CT5*CT5)
25094         END IF
25095         RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/
25096      &     (4.*ECM*ECM)
25097         IF(RQ52.LT.0.)THEN
25098           GOTO 100
25099         ELSE
25100           RQ5=SQRT(RQ52)
25101         ENDIF
25102         P5(1)=0.
25103         P5(2)=RQ5*ST5
25104         P5(3)=RQ5*CT5
25105         P5(0)=SQRT(RQ52+EMH*EMH)
25106         DO I=1,3
25107           Q34(I)=-P5(I)
25108         END DO
25109         Q34(0)=SQRT(RQ52+EMQQ*EMQQ)
25110         RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/
25111      &     (4.*EMQQ*EMQQ)
25112         IF(RQ42.LT.0.)THEN
25113           GOTO 100
25114         ELSE
25115           RQ4=SQRT(RQ42)
25116         ENDIF
25117         Q4(1)=RQ4*ST4*CF4
25118         Q4(2)=RQ4*ST4*SF4
25119         Q4(3)=RQ4*CT4
25120         Q4(0)=SQRT(RQ42+ENQ*ENQ)
25121         PQ4=0.
25122         DO I=1,3
25123           PQ4=PQ4+Q34(I)*Q4(I)
25124         END DO
25125         P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ
25126         P3(0)=Q34(0)-P4(0)
25127         DO I=1,3
25128           P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ)
25129           P3(I)=Q34(I)-P4(I)
25130         END DO
25131         IF(IMSSM.NE.0)THEN
25132           IF(IPROC.GE.1140)THEN
25133             IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
25134           ELSE
25135             IF((IQ.NE.6).AND.(IQ.NE.12).AND.
25136      &         (JQ.NE.6).AND.(JQ.NE.12))THEN
25137               IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
25138               IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
25139             ELSE
25140               CONTINUE
25141             END IF
25142           END IF
25143         END IF
25144 C...INITIAL STATE MOMENTA IN THE PARTONIC CM.
25145         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
25146      &         -(2.*EMIN*EMIN)**2)/(4.*SHAT)
25147         PCM=SQRT(PCM2)
25148         P1(0)=SQRT(PCM2+EMIN*EMIN)
25149         P1(1)=0.
25150         P1(2)=0.
25151         P1(3)=PCM
25152         P2(0)=SQRT(PCM2+EMIN*EMIN)
25153         P2(1)=0.
25154         P2(2)=0.
25155         P2(3)=-PCM
25156 C...COLOR STRUCTURED ME SUMMED/AVERAGED OVER FINAL/INITIAL SPINS AND COLORS.
25157 C...EW AND QCD COUPLINGS.
25158         EMSCA=EMQ+ENQ+EMH
25159         EMSC2=EMSCA*EMSCA
25160         ALPHA=HWUAEM(EMSC2)
25161         FIRST=.TRUE.
25162         GAUGE=.FALSE.
25163         E=SQRT(4.D0*PIFAC*ALPHA)
25164         IF(IPROC.GE.1140)THEN
25165           IFL=IQ-1
25166           IF(IQ.EQ.7)IFL=IQ
25167           IF(IQ.EQ.8)IFL=IQ+1
25168           IF(IQ.EQ.9)IFL=IQ+2
25169           RM3=ENQ
25170           YM3=ENQ
25171           GAM3=0.D0
25172           RM4=EMQ
25173           YM4=EMQ
25174           GAM4=GMQ
25175 C...CHARGED HIGGSES
25176           Q3=-1.D0
25177           IF(IFL.LE.6)Q3=-1.D0/3.D0
25178           JFL=0
25179           JH=IH
25180 C...ASSIGN FERMION MOMENTA
25181           DO I=0,3
25182             F(I)=P4(I)
25183             G(I)=P3(I)
25184           END DO
25185         ELSE
25186           IFL=IQ
25187           IF(IQ.EQ.7)IFL=IQ
25188           IF(IQ.EQ.8)IFL=IQ+1
25189           IF(IQ.EQ.9)IFL=IQ+2
25190           RM3=EMQ
25191           YM3=EMQ
25192           GAM3=0.D0
25193           RM4=ENQ
25194           YM4=ENQ
25195           GAM4=0.D0
25196 C...NEUTRAL HIGGSES
25197           IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ.5 ))THEN
25198             Q3=-1.D0/3.D0
25199           ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6 ))THEN
25200             Q3=+2.D0/3.D0
25201           ELSEIF((IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
25202             Q3=-1.D0
25203           END IF
25204           IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ. 5).OR.
25205      &       (IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
25206             JFL=1
25207           ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6))THEN
25208             JFL=2
25209           END IF
25210           KHIGGS=IHIGGS
25211           IF(IHIGGS.NE.0)KHIGGS=IHIGGS-1
25212           JH=KHIGGS
25213 C...ASSIGN FERMION MOMENTA
25214           DO I=0,3
25215             F(I)=P3(I)
25216             G(I)=P4(I)
25217           END DO
25218         END IF
25219         RM5=EMH
25220         GAM5=GMH
25221         S2W=SWEIN
25222         RMW=RMASS(198)
25223         RMZ=RMASS(200)
25224         GAMHL=HBAR/RLTIM(203)
25225         GAMHH=HBAR/RLTIM(204)
25226         GAMHA=HBAR/RLTIM(205)
25227         COLOUR=1.D0
25228         IF(IFL.LE.6)COLOUR=3.D0
25229 C...MSSM COUPLINGS.
25230         IF(JH.LE.3)THEN
25231           HFC=ENHANC(IQ)
25232           HBC=ENHANC(10)
25233         ELSE
25234           HFC=ONE
25235           HBC=ONE
25236         END IF
25237 C...ME.
25238         CALL HWH2HE(FIRST,GAUGE,JFL,JH,HFC,HBC,
25239      &     E,S2W,TANB,ALPHAH,RMW,S,Q3,F,G,P5,
25240      &     RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
25241      &     RMHL,GAMHL,RMHH,GAMHH,RMHA,GAMHA,
25242      &     RMZ,GAMZ,COLOUR,M2EE)
25243 C...CONSTANT FACTORS: PHI ALONG BEAM AND CONVERSION GEV^2->NB.
25244         FACT=2.*PIFAC*GEV2NB
25245 C...PHASE SPACE JACOBIANS, PI'S AND FLUX.
25246         FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
25247      &      *((ECM-EMH)**2-(EMQ+ENQ)**2)
25248      &      /2./EMQQ/S
25249 C...JACOBIANS FROM CT5 TO X(2).
25250         IF((IQ+JQ).EQ.18)THEN
25251           CONTINUE
25252         ELSE
25253           FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
25254           FACT=FACT*2.*ABS(ST4/CT4/SF4)
25255         END IF
25256 C...CHARGE CONJUGATION.
25257         IF(IPROC.GE.1140)THEN
25258 C...YES FOR CHARGED HIGGS.
25259           FACT=FACT*2.
25260         ELSE
25261 C...NO FOR NEUTRAL HIGGSES.
25262           CONTINUE
25263         END IF
25264 C...HIGGS RESONANCE.
25265         FACT=FACT*EMHWT
25266 C...CONSTANT WEIGHT.
25267         FACT=FACT*WEIGHT
25268 C...INCLUDE BR OF HIGGS.
25269         IF(IMSSM.EQ.0)THEN
25270           IDEC=MOD(IPROC,100)
25271           IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
25272           IF (IDEC.EQ.0) THEN
25273             BRHIGQ=0.D0
25274             DO I=1,6
25275               BRHIGQ=BRHIGQ+BRHIG(I)
25276             END DO
25277             FACT=FACT*BRHIGQ
25278           ENDIF
25279           IF (IDEC.EQ.10) THEN
25280             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25281             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25282             FACT=FACT*BR
25283           ELSEIF (IDEC.EQ.11) THEN
25284             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25285             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25286             FACT=FACT*BR
25287           ENDIF
25288         END IF
25289       END IF
25290 C...SET UP FLAVOURS IN FINAL STATE.
25291       IF(IPROC.GE.1140)THEN
25292         IF(HWRGEN(0).LT.0.5)THEN
25293           JHIGGS=207-201
25294           IIQ=IQ
25295           JJQ=JQ
25296           FLIP=0
25297         ELSE
25298           JHIGGS=206-201
25299           IIQ=IQ-1
25300           JJQ=JQ+1
25301           FLIP=1
25302         END IF
25303       ELSE
25304         JHIGGS=IHIGGS
25305         IIQ=IQ
25306         JJQ=JQ
25307         FLIP=0
25308       END IF
25309       HCS=FACT*M2EE
25310       IF (GENEV.AND.HCS.GT.RCS) THEN
25311 C...GENERATE EVENT.
25312         IDN(1)=IDHW(1)
25313         IDN(2)=IDHW(2)
25314         IF(IIQ.LE.12.AND.JJQ.LE.12)THEN
25315           IDN(3)=IIQ
25316           IDN(4)=JJQ
25317         ELSE
25318           IDN(3)=2*IIQ-7+114
25319           IDN(4)=2*IIQ-7+114+IAD
25320         END IF
25321         IDN(5)=201+JHIGGS
25322 C...INCOMING PARTONS: NOW MASSIVE.
25323         EMIN1=RMASS(IDN(1))
25324         EMIN2=RMASS(IDN(2))
25325 C...REDO INITIAL STATE MOMENTA IN THE PARTONIC CM.
25326         PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
25327      &         -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
25328         PCM=SQRT(PCM2)
25329         P1(0)=SQRT(PCM2+EMIN1*EMIN1)
25330         P1(1)=0.
25331         P1(2)=0.
25332         P1(3)=PCM
25333         P2(0)=SQRT(PCM2+EMIN2*EMIN2)
25334         P2(1)=0.
25335         P2(2)=0.
25336         P2(3)=-PCM
25337 C...SETS UP INCOMING STATUS AND IDS ONLY FOR 2->1: USE HWEONE.
25338         IDCMF=15
25339         XX(1)=ONE
25340         XX(2)=ONE
25341         CALL HWEONE
25342         JDAHEP(1,NHEP  )=NHEP+1
25343         JDAHEP(2,NHEP  )=NHEP+3
25344         JMOHEP(1,NHEP+1)=NHEP
25345         JMOHEP(1,NHEP+2)=NHEP
25346         JMOHEP(1,NHEP+3)=NHEP
25347 C...RANDOMLY ROTATE FINAL STATE MOMENTA AROUND BEAM AXIS.
25348         PHI=2.*PIFAC*HWRGEN(0)
25349         CPHI=COS(PHI)
25350         SPHI=SIN(PHI)
25351         ROT(1,1)=+CPHI
25352         ROT(1,2)=+SPHI
25353         ROT(1,3)=0.
25354         ROT(2,1)=-SPHI
25355         ROT(2,2)=+CPHI
25356         ROT(2,3)=0.
25357         ROT(3,1)=0.
25358         ROT(3,2)=0.
25359         ROT(3,3)=1.
25360         DO L=1,3
25361           DO M=1,3
25362             QAUX(M)=0.
25363             DO N=1,3
25364               IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
25365               IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
25366               IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
25367             END DO
25368           END DO
25369           DO M=1,3
25370             IF(L.EQ.1)P3(M)=QAUX(M)
25371             IF(L.EQ.2)P4(M)=QAUX(M)
25372             IF(L.EQ.3)P5(M)=QAUX(M)
25373           END DO
25374         END DO
25375 C...DO REAL INCOMING, OUTGOING MOMENTA IN THE LAB FRAME.
25376         DO M=NHEP-2,NHEP+3
25377           IF(M.EQ.NHEP  )GO TO 888
25378           DO N=0,3
25379             NN=N
25380             IF(N.EQ.0)NN=4
25381             IF(M.EQ.NHEP-2)PHEP(NN,M)=P1(N)
25382             IF(M.EQ.NHEP-1)PHEP(NN,M)=P2(N)
25383             IF(M.EQ.NHEP+1)PHEP(NN,M)=P3(N)*(1-FLIP)+P4(N)*FLIP
25384             IF(M.EQ.NHEP+2)PHEP(NN,M)=P4(N)*(1-FLIP)+P3(N)*FLIP
25385             IF(M.EQ.NHEP+3)PHEP(NN,M)=P5(N)
25386           END DO
25387  888      CONTINUE
25388         END DO
25389 C...NEEDS TO SET ALL FINAL STATE MASSES.
25390         PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
25391      &                         -PHEP(3,NHEP+1)**2
25392      &                         -PHEP(2,NHEP+1)**2
25393      &                         -PHEP(1,NHEP+1)**2))
25394         PHEP(5,NHEP+2)=SQRT(ABS(PHEP(4,NHEP+2)**2
25395      &                         -PHEP(3,NHEP+2)**2
25396      &                         -PHEP(2,NHEP+2)**2
25397      &                         -PHEP(1,NHEP+2)**2))
25398         PHEP(5,NHEP+3)=SQRT(ABS(PHEP(4,NHEP+3)**2
25399      &                         -PHEP(3,NHEP+3)**2
25400      &                         -PHEP(2,NHEP+3)**2
25401      &                         -PHEP(1,NHEP+3)**2))
25402 C...SETS CMF.
25403         DO I=1,4
25404           PHEP(I,NHEP  )=PHEP(I,NHEP-2)+PHEP(I,NHEP-1)
25405         END DO
25406         PHEP(5,NHEP  )=SQRT(ABS(PHEP(4,NHEP  )**2
25407      &                         -PHEP(3,NHEP  )**2
25408      &                         -PHEP(2,NHEP  )**2
25409      &                         -PHEP(1,NHEP  )**2))
25410 C...SETS UP OUTGOING STATUS AND IDS.
25411         ISTHEP(NHEP+1)=113
25412         ISTHEP(NHEP+2)=114
25413         ISTHEP(NHEP+3)=114
25414         IDHW(NHEP+1)=IDN(3)
25415         IDHEP(NHEP+1)=IDPDG(IDN(3))
25416         IDHW(NHEP+2)=IDN(4)
25417         IDHEP(NHEP+2)=IDPDG(IDN(4))
25418         IDHW(NHEP+3)=IDN(5)
25419         IDHEP(NHEP+3)=IDPDG(IDN(5))
25420 C...SETS UP COLOUR CONNECTIONS.
25421         JMOHEP(2,NHEP+1)=NHEP+2
25422         JMOHEP(2,NHEP+2)=NHEP+1
25423         JMOHEP(2,NHEP-1)=NHEP-2
25424         JMOHEP(2,NHEP-2)=NHEP-1
25425         JMOHEP(2,NHEP+3)=NHEP+3
25426         JDAHEP(2,NHEP+1)=NHEP+2
25427         JDAHEP(2,NHEP+2)=NHEP+1
25428         JDAHEP(2,NHEP-1)=NHEP-1
25429         JDAHEP(2,NHEP-2)=NHEP-2
25430         JDAHEP(2,NHEP+3)=NHEP+3
25431         NHEP=NHEP+3
25432         IF(AZSPIN)THEN
25433 C...SET TO ZERO THE COEFFICIENTS OF THE SPIN DENSITY MATRICES.
25434           CALL HWVZRO(7,GCOEF)
25435         END IF
25436       END IF
25437 C...COLLECT WEIGHT.
25438       EVWGT=HCS
25439       END
25440 CDECK  ID>, HWHIGH.
25441 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
25442 *-- Author :  Kosuke Odagiri & Stefano Moretti
25443 C-----------------------------------------------------------------------
25444 C...Generate completely differential cross section (EVWGT) in the variables
25445 C...X(I) with I=1,3 (see below) for the processes IPROC=3315,3325,3335,3355,
25446 C...3365,3375 as described in the HERWIG 6 documentation file.
25447 C...It includes interface to PDFs and takes into account color connections
25448 C...among partons.
25449 C
25450 C...First release:  16-AUG-1999 by Kosuke Odagiri
25451 C...Last modified:  26-SEP-1999 by Stefano Moretti
25452 C-----------------------------------------------------------------------
25453       SUBROUTINE HWHIGH
25454 C-----------------------------------------------------------------------
25455 C     DRELL-YAN 2 PARTON -> 2 HIGGS PAIR (2HDM)
25456 C-----------------------------------------------------------------------
25457       INCLUDE 'herwig65.inc'
25458       DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
25459      & FACTR, SN2TH, MZ, MW, MNN(2,2), MCC(2), MCN(3), EMSC2, GW2, GZ2,
25460      & GHH(4), XWEIN, S2W, ECM_MAX, X(3), XL(3),
25461      & XU(3), WEIGHT, ECM, SHAT, TAU, RMH1, RMH2, EMH1, EMH2,
25462      & EMHWT1, EMHWT2, EMHHWT
25463       INTEGER I, J, IQ, IQ1, IQ2, ID1, ID2, IH, JH, IH1, IH2
25464       EXTERNAL HWRGEN, HWUAEM
25465       SAVE HCS,MNN,MCC,MCN,EMHHWT,S,SHAT
25466       PARAMETER (EPS = 1.D-9)
25467       DOUBLE COMPLEX Z, GZ, A, D, E
25468       PARAMETER (Z = (0.D0,1.D0))
25469       EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
25470 C...process event.
25471       IF (GENEV) THEN
25472         RCS = HCS*HWRGEN(0)
25473       ELSE
25474         HCS = ZERO
25475         EVWGT = ZERO
25476 C...minimum transverse momentum.
25477         PTMIN = ZERO
25478 C...energy at hadron level.
25479         ECM_MAX=PBEAM1+PBEAM2
25480         S=ECM_MAX*ECM_MAX
25481 C...phase space variables.
25482 C...X(1)=COS(THETA_CM),
25483 C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMH1+EMH2)**2-1./ECM_MAX**2),
25484 C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
25485 C...phase space borders.
25486         XL(1)=-1.
25487         XU(1)=1.
25488         XL(2)=0.
25489         XU(2)=1.
25490         XL(3)=0.
25491         XU(3)=1.
25492 C...single phase space point.
25493         WEIGHT=1.
25494         DO I=1,3
25495           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
25496           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
25497         END DO
25498 C...final state masses.
25499         IF((MOD(IPROC,10000).EQ.3365).OR.
25500      &     (MOD(IPROC,10000).EQ.3375))THEN
25501           JH  = IHIGGS-1
25502           ID1 = 205
25503           ID2 = 202 + JH
25504         ELSE IF(MOD(IPROC,10000).EQ.3355)THEN
25505           JH  = 4
25506           ID1 = 206
25507           ID2 = 207
25508         ELSE IF((MOD(IPROC,10000).EQ.3315).OR.
25509      &          (MOD(IPROC,10000).EQ.3325).OR.
25510      &          (MOD(IPROC,10000).EQ.3335))THEN
25511           JH  = IHIGGS-1
25512           ID1 = 206
25513           ID2 = 202 + JH
25514         END IF
25515         RMH1=RMASS(ID1)
25516         RMH2=RMASS(ID2)
25517         EMH1=RMH1
25518         EMH2=RMH2
25519         EMHWT1=1.
25520         EMHWT2=1.
25521         EMHHWT=EMHWT1*EMHWT2
25522 C...energy at parton level.
25523         ECM=SQRT(1./(X(2)*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
25524      &                                      +1./ECM_MAX**2))
25525         IF((EMH1.LE.0.).OR.(EMH1.GE.ECM))RETURN
25526         IF((EMH2.LE.0.).OR.(EMH2.GE.ECM))RETURN
25527         SHAT=ECM*ECM
25528         TAU=SHAT/S
25529 C...momentum fractions X1 and X2.
25530         XX(1) = EXP(LOG(TAU)*(1.-X(3)))
25531         XX(2) = TAU/XX(1)
25532         COSTH = X(1)
25533         SN2TH = 0.25D0 - 0.25D0*COSTH**2
25534         EMSCA = EMH1+EMH2
25535         EMSC2 = EMSCA*EMSCA
25536         CALL    HWSGEN(.FALSE.)
25537         EVWGT = ZERO
25538         FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT/CAFAC*SN2TH/2.
25539 C...Jacobians from X1,X2 to X(2),X(3).
25540         FACTR = FACTR/S*(-LOG(TAU))*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
25541 C...constant weight.
25542         FACTR = FACTR*WEIGHT
25543 C...couplings and propagators.
25544         XWEIN = TWO*SWEIN
25545         S2W   = DSQRT(XWEIN*(TWO-XWEIN))
25546         GZ    = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT
25547         GZ2   = DREAL(DCONJG(GZ)*GZ)
25548         GW2   = ((ONE-MW**2/SHAT)**2+(GAMW/MW)**2)*XWEIN**2
25549 C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-.
25550         GHH(1)= COSBMA
25551         GHH(2)= SINBMA
25552         GHH(3)= ONE
25553         GHH(4)= ONE-XWEIN
25554 C...set to zero all MEs.
25555         DO I=1,2
25556           MCC(I)=ZERO
25557           MCN(I)=ZERO
25558           DO J=1,2
25559             MNN(I,J)=ZERO
25560           END DO
25561         END DO
25562         MCN(3)=ZERO
25563 C...start subprocesses.
25564         IF((MOD(IPROC,10000).EQ.3365).OR.
25565      &     (MOD(IPROC,10000).EQ.3375))THEN
25566 c
25567 c      _      o  o   o
25568 c    q q  -> A  h / H
25569 c
25570           DO IH = JH,JH
25571             QPE = SHAT-(EMH1+EMH2)**2
25572             IF (QPE.GT.ZERO) THEN
25573               PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
25574               DO IQ = 1,2
25575                 MNN(IH,IQ) =
25576      &          FACTR*PF**3*GHH(IH)**2*(LFCH(IQ)**2+RFCH(IQ)**2)/GZ2
25577               END DO
25578             ELSE
25579               CONTINUE
25580             END IF
25581           END DO
25582         ELSE IF(MOD(IPROC,10000).EQ.3355)THEN
25583 c
25584 c      _      +  -
25585 c    q q  -> H  H
25586 c
25587           IH = JH
25588           QPE = SHAT-(EMH1+EMH2)**2
25589           IF (QPE.GT.ZERO) THEN
25590             PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
25591             DO IQ = 1,2
25592               A = GHH(IH)/GZ
25593               D = QFCH(IQ)+A*LFCH(IQ)
25594               E = QFCH(IQ)+A*RFCH(IQ)
25595               MCC(IQ)=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
25596             END DO
25597           ELSE
25598             CONTINUE
25599           END IF
25600         ELSE IF((MOD(IPROC,10000).EQ.3315).OR.
25601      &          (MOD(IPROC,10000).EQ.3325).OR.
25602      &          (MOD(IPROC,10000).EQ.3335))THEN
25603 c
25604 c      _      +-  o   o   o
25605 c    q q' -> H   h / H / A
25606 c
25607           DO IH = JH,JH
25608             QPE = SHAT-(EMH1+EMH2)**2
25609             IF (QPE.GT.ZERO) THEN
25610               PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
25611               MCN(IH)=FACTR*PF**3/GW2*HALF*GHH(IH)**2
25612             ELSE
25613               CONTINUE
25614             END IF
25615           END DO
25616         END IF
25617       END IF
25618       HCS = 0.D0
25619 C...start PDFs.
25620       DO 1 ID1 = 1, 12
25621        IF (DISF(ID1,1).LT.EPS) GOTO 1
25622        IF (ID1.GT.6) THEN
25623         ID2 = ID1 - 6
25624        ELSE
25625         ID2 = ID1 + 6
25626        END IF
25627        IQ  = ID1 - ((ID1-1)/2)*2
25628        IF (DISF(ID2,2).LT.EPS) GOTO 1
25629        DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25630        IH1 = 205
25631        IH2 = 203
25632        HCS = HCS + DIST*EMHHWT*MNN(1,IQ)
25633        IF (GENEV.AND.HCS.GT.RCS) THEN
25634          CALL HWHQCP(IH1,IH2,2134,1)
25635          GOTO 9
25636        ENDIF
25637        IH2 = 204
25638        HCS = HCS + DIST*EMHHWT*MNN(2,IQ)
25639        IF (GENEV.AND.HCS.GT.RCS) THEN
25640          CALL HWHQCP(IH1,IH2,2134,2)
25641          GOTO 9
25642        ENDIF
25643        IH1 = 206
25644        IH2 = 207
25645        HCS = HCS + DIST*EMHHWT*MCC(IQ)
25646        IF (GENEV.AND.HCS.GT.RCS) THEN
25647          CALL HWHQCP(IH1,IH2,2134,3)
25648          GOTO 9
25649        ENDIF
25650     1 CONTINUE
25651 c      _     _       _     _
25652 c     ud(+), ud(-), du(-), du(+)
25653 c
25654       DO 2 IQ1 = 1, 3
25655       DO IQ2 = 1, 3
25656       IF(VCKM(IQ1,IQ2).GT.EPS) THEN
25657 c      _
25658 c     ud (+)
25659 c
25660        ID1 = IQ1 * 2
25661        ID2 = IQ2 * 2 + 5
25662        IH1 = 206
25663        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25664         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25665         DO IH = 1,3
25666          IH2 = 202+IH
25667          HCS = HCS + DIST*EMHHWT*MCN(IH)
25668          IF (GENEV.AND.HCS.GT.RCS) THEN
25669            CALL HWHQCP(IH1,IH2,2134,3+IH)
25670            GOTO 9
25671          ENDIF
25672         END DO
25673        END IF
25674 c     _
25675 c     du (+)
25676 c
25677        ID1 = IQ2 * 2 + 5
25678        ID2 = IQ1 * 2
25679        IH1 = 206
25680        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25681         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25682         DO IH = 1,3
25683          IH2 = 202+IH
25684          HCS = HCS + DIST*EMHHWT*MCN(IH)
25685          IF (GENEV.AND.HCS.GT.RCS) THEN
25686            CALL HWHQCP(IH1,IH2,2134,3+IH)
25687            GOTO 9
25688          ENDIF
25689         END DO
25690        END IF
25691 c      _
25692 c     du (-)
25693 c
25694        ID1 = IQ2 * 2 - 1
25695        ID2 = IQ1 * 2 + 6
25696        IH1 = 207
25697        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25698         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25699         DO IH = 1,3
25700          IH2 = 202+IH
25701          HCS = HCS + DIST*EMHHWT*MCN(IH)
25702          IF (GENEV.AND.HCS.GT.RCS) THEN
25703            CALL HWHQCP(IH1,IH2,2134,3+IH)
25704            GOTO 9
25705          ENDIF
25706         END DO
25707        END IF
25708 c     _
25709 c     ud (-)
25710 c
25711        ID1 = IQ1 * 2 + 6
25712        ID2 = IQ2 * 2 - 1
25713        IH1 = 207
25714        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25715         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25716         DO IH = 1,3
25717          IH2 = 202+IH
25718          HCS = HCS + DIST*EMHHWT*MCN(IH)
25719          IF (GENEV.AND.HCS.GT.RCS) THEN
25720            CALL HWHQCP(IH1,IH2,2134,3+IH)
25721            GOTO 9
25722          ENDIF
25723         END DO
25724        END IF
25725       END IF
25726       END DO
25727     2 CONTINUE
25728       EVWGT = HCS
25729       RETURN
25730 C...generate event.
25731     9 IDN(1)=ID1
25732       IDN(2)=ID2
25733       IDCMF=15
25734       CALL HWETWO(.TRUE.,.TRUE.)
25735       IF (AZSPIN) THEN
25736         CALL HWVZRO(7,GCOEF)
25737       END IF
25738       END
25739 CDECK  ID>, HWHIGJ.
25740 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
25741 *-- Author :    Ian Knowles
25742 C-----------------------------------------------------------------------
25743       SUBROUTINE HWHIGJ
25744 C-----------------------------------------------------------------------
25745 C     QCD Higgs plus jet production; mean EVWGT = Sigma in nb*Higgs B.R.
25746 C     Adapted from the program of U. Baur and E.W.N. Glover
25747 C     See: Nucl. Phys. B339 (1990) 38
25748 C-----------------------------------------------------------------------
25749       INCLUDE 'herwig65.inc'
25750       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWUAEM,EPS,RCS,EMH,EMHWT,
25751      & EMHTMP,BR,CV,CA,EMH2,ET,EJ,PT,EMT,EMAX,YMAX,YHINF,YHSUP,EXYH,
25752      & YMIN,YJINF,YJSUP,EXYJ,S,T,U,FACT,AMPQQ,AMPQG,AMPGQ,AMPGG,HCS,
25753      & FACTR
25754       INTEGER I,IDEC,ID1,ID2
25755       EXTERNAL HWRGEN,HWRUNI,HWUALF,HWUAEM
25756       SAVE HCS,AMPGG,AMPGQ,AMPQG,AMPQQ,EMH,FACT
25757       PARAMETER (EPS=1.D-9)
25758       IF (GENEV) THEN
25759          RCS=HCS*HWRGEN(0)
25760       ELSE
25761          EVWGT=0.
25762 C Select a Higgs mass
25763          CALL HWHIGM(EMH,EMHWT)
25764          IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
25765 C Store branching ratio for specified Higgs deacy channel
25766          IDEC=MOD(IPROC,100)
25767          BR=1.
25768          IF (IDEC.EQ.0) THEN
25769             BR=0.
25770             DO 10 I=1,6
25771   10        BR=BR+BRHIG(I)
25772          ELSEIF (IDEC.EQ.10) THEN
25773             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25774             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25775             BR=BR*BRHIG(IDEC)
25776          ELSEIF (IDEC.EQ.11) THEN
25777             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25778             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25779             BR=BR*BRHIG(IDEC)
25780          ELSEIF (IDEC.LE.12) THEN
25781             BR=BRHIG(IDEC)
25782          ENDIF
25783 C Select subprocess kinematics
25784          EMH2=EMH**2
25785          CALL HWRPOW(ET,EJ)
25786          PT=.5*ET
25787          EMT=SQRT(PT**2+EMH2)
25788          EMAX=0.5*(PHEP(5,3)+EMH2/PHEP(5,3))
25789          IF (EMAX.LE.EMT) RETURN
25790          YMAX=LOG((EMAX+SQRT(EMAX**2-EMT**2))/EMT)
25791          YHINF=MAX(YJMIN,-YMAX)
25792          YHSUP=MIN(YJMAX, YMAX)
25793          IF (YHSUP.LE.YHINF) RETURN
25794          EXYH=EXP(HWRUNI(1,YHINF,YHSUP))
25795          YMIN=LOG(PT/(PHEP(5,3)-EMT/EXYH))
25796          YMAX=LOG((PHEP(5,3)-EMT*EXYH)/PT)
25797          YJINF=MAX(YJMIN,YMIN)
25798          YJSUP=MIN(YJMAX,YMAX)
25799          IF (YJSUP.LE.YJINF) RETURN
25800          EXYJ=EXP(HWRUNI(2,YJINF,YJSUP))
25801          XX(1)=(EMT*EXYH+PT*EXYJ)/PHEP(5,3)
25802          XX(2)=(EMT/EXYH+PT/EXYJ)/PHEP(5,3)
25803          S=XX(1)*XX(2)*PHEP(5,3)**2
25804          T=EMH2-XX(1)*EMT*PHEP(5,3)/EXYH
25805          U=EMH2-S-T
25806          COSTH=(S+2.*T-EMH2)/(S-EMH2)
25807 C Set subprocess scale
25808          EMSCA=EMT
25809          CALL HWSGEN(.FALSE.)
25810          FACT=GEV2NB*PT*EJ*(YHSUP-YHINF)*(YJSUP-YJINF)*BR*EMHWT
25811      &       *HWUALF(1,EMSCA)**3*HWUAEM(EMH2)/(SWEIN*16*PIFAC*S**2)
25812          CALL HWHIGA(S,T,U,EMH2,AMPQQ,AMPQG,AMPGQ,AMPGG)
25813       ENDIF
25814       HCS=0.
25815       DO 30 ID1=1,13
25816       IF (DISF(ID1,1).LT.EPS) GOTO 30
25817       FACTR=FACT*DISF(ID1,1)
25818       IF (ID1.LT.7) THEN
25819 C Quark first:
25820          ID2=ID1+6
25821          HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
25822          IF (GENEV.AND.HCS.GT.RCS) THEN
25823            CALL HWHQCP(13 ,201,2314,81)
25824            GOTO 99
25825          ENDIF
25826          ID2=13
25827          HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
25828          IF (GENEV.AND.HCS.GT.RCS) THEN
25829            CALL HWHQCP(ID1,201,3124,82)
25830            GOTO 99
25831          ENDIF
25832       ELSEIF (ID1.LT.13) THEN
25833 C Antiquark first:
25834          ID2=ID1-6
25835          HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
25836          IF (GENEV.AND.HCS.GT.RCS) THEN
25837            CALL HWHQCP(13 ,201,3124,83)
25838            GOTO 99
25839          ENDIF
25840          ID2=13
25841          HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
25842          IF (GENEV.AND.HCS.GT.RCS) THEN
25843            CALL HWHQCP(ID1,201,2314,84)
25844            GOTO 99
25845          ENDIF
25846       ELSE
25847 C Gluon first:
25848          DO 20 ID2=1,12
25849          IF (DISF(ID2,2).LT.EPS) GOTO 20
25850          IF (ID2.LT.7) THEN
25851             HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
25852             IF (GENEV.AND.HCS.GT.RCS) THEN
25853               CALL HWHQCP(ID2,201,2314,85)
25854               GOTO 99
25855             ENDIF
25856          ELSE
25857             HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
25858             IF (GENEV.AND.HCS.GT.RCS) THEN
25859               CALL HWHQCP(ID2,201,3124,86)
25860               GOTO 99
25861             ENDIF
25862          ENDIF
25863   20     CONTINUE
25864          HCS=HCS+FACTR*DISF(13,2)*AMPGG
25865          IF (GENEV.AND.HCS.GT.RCS) THEN
25866            CALL HWHQCP(13 ,201,2314,87)
25867            GOTO 99
25868          ENDIF
25869       ENDIF
25870   30  CONTINUE
25871       EVWGT=HCS
25872       RETURN
25873 C Generate event
25874   99  IDN(1)=ID1
25875       IDN(2)=ID2
25876       IDCMF=15
25877 C Trick HWETWO into using off-shell Higgs mass
25878       EMHTMP=RMASS(IDN(4))
25879       RMASS(IDN(4))=EMH
25880 C-- BRW fix 27/8/04: avoid double smearing of H mass
25881       CALL HWETWO(.TRUE.,.FALSE.)
25882       RMASS(IDN(4))=EMHTMP
25883       END
25884 CDECK  ID>, HWHIGM.
25885 *CMZ :-        -02/05/91  11.17.14  by  Federico Carminati
25886 *-- Author :    Mike Seymour
25887 C-----------------------------------------------------------------------
25888       SUBROUTINE HWHIGM(EM,WEIGHT)
25889 C-----------------------------------------------------------------------
25890 C     CHOOSE HIGGS MASS:
25891 C     IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
25892 C       CHOOSE HIGGS MASS ACCORDING TO
25893 C       EM**4       /  (EM**2-EMH**2)**2 + (GAMH*EMH)**2
25894 C     ELSE
25895 C       CHOOSE HIGGS MASS ACCORDING TO
25896 C       EMH * GAMH  /  (EM**2-EMH**2)**2 + (GAMH*EMH)**2
25897 C     ENDIF
25898 C     IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.1) THEN
25899 C       SUPPLY WEIGHT FACTOR TO YIELD
25900 C       EM * GAM(EM)/  (EM**2-EMH**2)**2 + (GAM(EM)*EM)**2
25901 C     ELSE
25902 C       SUPPLY WEIGHT FACTOR TO YIELD
25903 C       EM*(EMH/EM)**4 * GAM(EM)
25904 C                   /  (EM**2-EMH**2)**2 + (GAM(EM)*EMH**2/EM)**2
25905 C       AS SUGGESTED IN M.H.SEYMOUR, PHYS.LETT.B354(1995)409.
25906 C     ENDIF
25907 C-----------------------------------------------------------------------
25908       INCLUDE 'herwig65.inc'
25909       DOUBLE PRECISION HWRUNI,EM,WEIGHT,EMH,DIF,FUN,THETA,T,EMHLST,W0,
25910      & W1,EMM,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,Z,F,GAMOFS
25911       INTEGER I
25912       EXTERNAL HWRUNI
25913       SAVE EMHLST,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,W0,W1
25914       EQUIVALENCE (EMH,RMASS(201))
25915       DATA EMHLST/0D0/
25916 C---SET UP INTEGRAND AND INDEFINITE INTEGRAL OF DISTRIBUTION
25917 C   THETA=ATAN((EM**2-EMH**2)/(GAMH*EMH)); T=TAN(THETA); T0=EMH/GAMH
25918       DIF(T,T0)=(T+T0)**2
25919       FUN(THETA,T,T0)=T + (T0*T0-1)*THETA + T0*LOG(1+T*T)
25920 C---SET UP CONSTANTS
25921       IF (EMH.NE.EMHLST .OR. FSTWGT) THEN
25922         EMHLST=EMH
25923         GAMEM=GAMH*EMH
25924         T0=EMH/GAMH
25925         TMIN=(MAX(ONE*1E-10,EMH-GAMMAX*GAMH))**2/GAMEM-T0
25926         TMAX=(              EMH+GAMMAX*GAMH )**2/GAMEM-T0
25927         THEMIN=ATAN(TMIN)
25928         THEMAX=ATAN(TMAX)
25929         ZMIN=FUN(THEMIN,TMIN,T0)
25930         ZMAX=FUN(THEMAX,TMAX,T0)
25931         W0=(ZMAX-ZMIN) / PIFAC * GAMEM
25932         W1=(THEMAX-THEMIN) / PIFAC
25933       ENDIF
25934 C---CHOOSE HIGGS MASS
25935       IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
25936         EM=0
25937         WEIGHT=0
25938         Z=HWRUNI(1,ZMIN,ZMAX)
25939 C---SOLVE FUN(THETA,TAN(THETA))=Z BY NEWTON'S METHOD
25940         THETA=MAX(THEMIN, MIN(THEMAX, Z/T0**2 ))
25941         I=1
25942         F=0
25943  10     IF (I.LE.20 .AND. ABS(1-F/Z).GT.1E-4) THEN
25944           I=I+1
25945           IF (2*ABS(THETA).GT.PIFAC) THEN
25946             CALL HWWARN('HWHIGM',51)
25947             GOTO 999
25948           ENDIF
25949           T=TAN(THETA)
25950           F=FUN(THETA,T,T0)
25951           THETA=THETA-(F-Z)/DIF(T,T0)
25952           GOTO 10
25953         ENDIF
25954         IF (I.GT.20) CALL HWWARN('HWHIGM',1)
25955       ELSE
25956         THETA=HWRUNI(0,THEMIN,THEMAX)
25957       ENDIF
25958       EM=SQRT(GAMEM*(T0+TAN(THETA)))
25959 C---NOW CALCULATE WEIGHT FACTOR FOR NON-CONSTANT HIGGS WIDTH
25960       GAMOFS=EM
25961       CALL HWDHIG(GAMOFS)
25962       IF (IOPHIG.EQ.0) THEN
25963         WEIGHT=W0*GAMOFS*EM /EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
25964      &                             /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
25965       ELSEIF (IOPHIG.EQ.1) THEN
25966         WEIGHT=W1*GAMOFS*EM /GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
25967      &                             /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
25968       ELSEIF (IOPHIG.EQ.2) THEN
25969         EMM=EM*(EMH/EM)**4
25970         WEIGHT=W0*GAMOFS*EMM/EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
25971      &                             /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
25972       ELSEIF (IOPHIG.EQ.3) THEN
25973         EMM=EM*(EMH/EM)**4
25974         WEIGHT=W1*GAMOFS*EMM/GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
25975      &                             /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
25976       ELSE
25977         CALL HWWARN('HWHIGM',500)
25978       ENDIF
25979  999  RETURN
25980       END
25981 CDECK  ID>, HWHIGQ.
25982 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
25983 *-- Author :  Stefano Moretti
25984 C-----------------------------------------------------------------------
25985 C...Generate completely differential cross section (EVWGT) in the variables
25986 C...X(I) with I=1,6 (see below) for the processes from IPROC=2500-2599 (SM),
25987 C...IPROC=3811-3899, as described in the HERWIG 6 documentation file.
25988 C...(For IPROC=3839,3869,3899 it describes MSSM charged Higgs production.)
25989 C...It includes interface to PDFs and takes into account color connections
25990 C...among partons.
25991 C
25992 C...First release: 08-APR-1999 by Stefano Moretti
25993 C...Last modified: 28-JUN-2001 by Stefano Moretti
25994 C
25995       SUBROUTINE HWHIGQ
25996 C-----------------------------------------------------------------------
25997 C     PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
25998 C-----------------------------------------------------------------------
25999       INCLUDE 'herwig65.inc'
26000       INTEGER JHIGGS
26001       INTEGER I,J,K,L,M,N
26002       INTEGER IS,IH,IQ,JQ,IIQ,JJQ,IQMIN,IQMAX,IGG,IQQ
26003       INTEGER IDEC,NC,FLIP
26004       INTEGER ID1,ID2
26005       DOUBLE PRECISION CV,CA,BR
26006       DOUBLE PRECISION BRHIGQ,EMQ,ENQ,EMQQ,EMH,EMHWT,EMW
26007       DOUBLE PRECISION PTMMIN,PTNMIN
26008       DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
26009       DOUBLE PRECISION X(6),XL(6),XU(6)
26010       DOUBLE PRECISION Q4(0:3),Q34(0:3)
26011       DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
26012       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
26013       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
26014       DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
26015       DOUBLE PRECISION M2GG,M2GGPL,M2GGMN,M2QQ
26016       DOUBLE PRECISION GM,GRND,FACGPM(2)
26017       DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
26018       DOUBLE PRECISION ALPHA,ALPHAS,EMSC2
26019       DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF
26020       DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
26021       DOUBLE PRECISION VCOL,GCOL,QAUX(0:3)
26022       DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
26023       DOUBLE PRECISION WEIGHT
26024       SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5
26025       SAVE IIQ,JJQ,JHIGGS
26026       LOGICAL HWRLOG
26027       EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2QH,HWETWO,HWRLOG
26028       PARAMETER (EPS=1.D-9)
26029       EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO)
26030 C...assign Q/Q'-flavour.
26031       IF((MOD(IPROC,10000).EQ.3839).OR.
26032      &   (MOD(IPROC,10000).EQ.3869).OR.
26033      &   (MOD(IPROC,10000).EQ.3899))THEN
26034         IQ=6
26035         JQ=11
26036         GM=HBAR/RLTIM(6)*RMASS(6)
26037       ELSE
26038         IF(IMSSM.EQ.0)THEN
26039           IS=0
26040           IH=0
26041           IQ=6
26042         ELSE
26043           IF(MOD(IPROC,10000).LT.4000)IS=6
26044           IF(MOD(IPROC,10000).LT.3870)IS=3
26045           IF(MOD(IPROC,10000).LT.3840)IS=0
26046           IH=MOD(IPROC,10000)/10-380-IS
26047           IQ=MOD(IPROC,10000)-3800-10*(IH+IS)
26048         END IF
26049         JQ=IQ+6
26050         GM=ZERO
26051       END IF
26052 C...process event.
26053       IF(GENEV)THEN
26054         RCS=HCS*HWRGEN(0)
26055       ELSE
26056         EVWGT=0.
26057         HCS=0.
26058 C...assign final state masses.
26059         EMQ=RMASS(IQ)
26060         ENQ=RMASS(JQ)
26061         EMH=RMASS(201+IHIGGS)
26062         EMHWT=1.
26063         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
26064 C...energy at hadron level.
26065         ECM_MAX=PBEAM1+PBEAM2
26066         S=ECM_MAX*ECM_MAX
26067 C...phase space variables.
26068 C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
26069 C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
26070 C...                X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34),
26071 C...HEAVY QUARKS -> X(2)=COS(THETA5_CM),
26072 C...                X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
26073 C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2),
26074 C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
26075 C...phase space borders.
26076         XL(1)=0.
26077         XU(1)=1.
26078         IF((IQ+JQ).EQ.18)THEN
26079           XL(2)=-1.
26080           XL(4)=0.
26081           XU(4)=2.*PIFAC
26082         ELSE
26083           XL(2)=0.
26084           XL(4)=-1.
26085           XU(4)=1.
26086         END IF
26087         XU(2)=1.
26088         XL(3)=-1.
26089         XU(3)=1.
26090         XL(5)=0.
26091         XU(5)=1.
26092         XL(6)=0.
26093         XU(6)=1.
26094 C...single phase space point.
26095  100    CONTINUE
26096         WEIGHT=1.
26097         DO I=1,6
26098           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
26099           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
26100         END DO
26101 C...energy at parton level.
26102         PTMMIN=0.
26103         PTNMIN=0.
26104         IF(IMSSM.NE.0)THEN
26105           IF((MOD(IPROC,10000).EQ.3839).OR.
26106      &       (MOD(IPROC,10000).EQ.3869).OR.
26107      &       (MOD(IPROC,10000).EQ.3899))THEN
26108             PTNMIN=PTMIN
26109           ELSE
26110             IF((IQ.NE.6).AND.(IQ.NE.12).AND.
26111      &         (JQ.NE.6).AND.(JQ.NE.12))THEN
26112               PTMMIN=PTMIN
26113               PTNMIN=PTMIN
26114             ELSE
26115               CONTINUE
26116             END IF
26117           END IF
26118         END IF
26119         ECM=SQRT(1./(X(5)*(1./(SQRT(PTMMIN**2+EMQ**2)
26120      &                        +SQRT(PTNMIN**2+ENQ**2)+EMH)**2
26121      &                                         -1./ECM_MAX**2)
26122      &                                         +1./ECM_MAX**2))
26123         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
26124         SHAT=ECM*ECM
26125         TAU=SHAT/S
26126 C...momentum fractions X1 and X2.
26127         XX(1)=EXP(LOG(TAU)*(1.-X(6)))
26128         XX(2)=TAU/XX(1)
26129 C...three particle kinematics.
26130         EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
26131 C...incoming partons: all massless.
26132         EMIN=0.
26133         IF((IQ+JQ).EQ.18)THEN
26134           CT5=X(2)
26135           CT4=X(3)
26136           ST4=SQRT(1.-CT4*CT4)
26137           CF4=COS(X(4))
26138           SF4=SIN(X(4))
26139         ELSE
26140           PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2
26141      &        -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM)
26142           PCM=SQRT(PCM2)
26143           RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2
26144      &        -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM)
26145           RCM=SQRT(RCM2)
26146           TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
26147      &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
26148      &    -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
26149      &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
26150           TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
26151      &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
26152      &    +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
26153      &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
26154           TLMIN=LOG(ABS(TTMAX))
26155           TLMAX=LOG(ABS(TTMIN))
26156           TL=X(2)*(TLMAX-TLMIN)+TLMIN
26157           T=EXP(ABS(TL))
26158           CTMP=-T-EMIN**2-EMQQ**2
26159      &       +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2)
26160           CT5=CTMP/2./PCM/RCM
26161           ST4=X(3)
26162           CT4=SQRT(1.-ST4*ST4)
26163           IF (HWRLOG(HALF)) CT4=-CT4
26164           CF4=X(4)
26165           SF4=SQRT(1.-CF4*CF4)
26166           IF (HWRLOG(HALF)) SF4=-SF4
26167         END IF
26168         ST5=SQRT(1.-CT5*CT5)
26169         IF (HWRLOG(HALF)) ST5=-ST5
26170         RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/
26171      &     (4.*ECM*ECM)
26172         IF(RQ52.LT.0.)THEN
26173           GOTO 100
26174         ELSE
26175           RQ5=SQRT(RQ52)
26176         ENDIF
26177         P5(1)=0.
26178         P5(2)=RQ5*ST5
26179         P5(3)=RQ5*CT5
26180         P5(0)=SQRT(RQ52+EMH*EMH)
26181         DO I=1,3
26182           Q34(I)=-P5(I)
26183         END DO
26184         Q34(0)=SQRT(RQ52+EMQQ*EMQQ)
26185         RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/
26186      &     (4.*EMQQ*EMQQ)
26187         IF(RQ42.LT.0.)THEN
26188           GOTO 100
26189         ELSE
26190           RQ4=SQRT(RQ42)
26191         ENDIF
26192         Q4(1)=RQ4*ST4*CF4
26193         Q4(2)=RQ4*ST4*SF4
26194         Q4(3)=RQ4*CT4
26195         Q4(0)=SQRT(RQ42+ENQ*ENQ)
26196         PQ4=0.
26197         DO I=1,3
26198           PQ4=PQ4+Q34(I)*Q4(I)
26199         END DO
26200         P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ
26201         P3(0)=Q34(0)-P4(0)
26202         DO I=1,3
26203           P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ)
26204           P3(I)=Q34(I)-P4(I)
26205         END DO
26206         IF(IMSSM.NE.0)THEN
26207           IF((MOD(IPROC,10000).EQ.3839).OR.
26208      &       (MOD(IPROC,10000).EQ.3869).OR.
26209      &       (MOD(IPROC,10000).EQ.3899))THEN
26210             IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
26211           ELSE
26212             IF((IQ.NE.6).AND.(IQ.NE.12).AND.
26213      &         (JQ.NE.6).AND.(JQ.NE.12))THEN
26214               IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
26215               IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
26216             ELSE
26217               CONTINUE
26218             END IF
26219           END IF
26220         END IF
26221 C...initial state momenta in the partonic CM.
26222         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
26223      &         -(2.*EMIN*EMIN)**2)/(4.*SHAT)
26224         PCM=SQRT(PCM2)
26225         P1(0)=SQRT(PCM2+EMIN*EMIN)
26226         P1(1)=0.
26227         P1(2)=0.
26228         P1(3)=PCM
26229         P2(0)=SQRT(PCM2+EMIN*EMIN)
26230         P2(1)=0.
26231         P2(2)=0.
26232         P2(3)=-PCM
26233 C...color structured ME summed/averaged over final/initial spins and colors.
26234         IGG=1
26235         IQQ=1
26236         IF((MOD(IPROC,10000).EQ.3839).OR.
26237      &     (MOD(IPROC,10000).EQ.3869).OR.
26238      &     (MOD(IPROC,10000).EQ.3899))THEN
26239           IF(MOD(IPROC,10000).EQ.3869)IQQ=0
26240           IF(MOD(IPROC,10000).EQ.3899)IGG=0
26241           GRND=TANB
26242         ELSE
26243           IF(IMSSM.NE.0)THEN
26244             IF((MOD(IPROC,10000)/10-380).EQ.4)IQQ=0
26245             IF((MOD(IPROC,10000)/10-380).EQ.7)IGG=0
26246           END IF
26247           GRND=ONE
26248         END IF
26249         FACGPM(1) = ENQ       *GRND
26250         FACGPM(2) = EMQ*PARITY/GRND
26251         CALL HWH2QH(ECM,P1,P2,P3,P4,P5,EMQ,ENQ,EMH,FACGPM,GM,IGG,IQQ,
26252      &              GGQQHT,GGQQHU,GGQQHNP,QQQQH)
26253         M2GG=GGQQHNP/(8.*CFFAC)
26254         M2GGPL=GGQQHT/(8.*CFFAC)
26255         M2GGMN=GGQQHU/(8.*CFFAC)
26256         M2QQ=QQQQH*(1.-1./CAFAC**2)/4.
26257 C...constant factors: phi along beam and conversion GeV^2->nb.
26258         FACT=2.*PIFAC*GEV2NB
26259 C...Jacobians from X1,X2 to X(5),X(6)
26260         FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
26261 C...phase space Jacobians, pi's and flux.
26262         FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
26263      &      *((ECM-EMH)**2-(EMQ+ENQ)**2)
26264      &      /2./EMQQ
26265 C...Jacobians from CT5 to X(2).
26266         IF((IQ+JQ).EQ.18)THEN
26267           CONTINUE
26268         ELSE
26269           FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
26270           FACT=FACT*2.*ABS(ST4/CT4/SF4)
26271         END IF
26272 C...EW and QCD couplings.
26273         EMSCA=EMQ+ENQ+EMH
26274         EMSC2=EMSCA*EMSCA
26275         ALPHA=HWUAEM(EMSC2)
26276         ALPHAS=HWUALF(1,EMSCA)
26277         FACT=FACT*4.*PIFAC*ALPHA/4./SWEIN/EMW/EMW
26278         FACT=FACT*16.*PIFAC**2*ALPHAS**2
26279         IF((MOD(IPROC,10000).EQ.3839).OR.
26280      &     (MOD(IPROC,10000).EQ.3869).OR.
26281      &     (MOD(IPROC,10000).EQ.3899))THEN
26282 C...enhancement factor for coupling+c.c.
26283           FACT=FACT*4.*VCKM(3,3)
26284         ELSE
26285 C...enhancement factor for MSSM.
26286           FACT=FACT*ENHANC(IQ)*ENHANC(IQ)
26287         END IF
26288 C...Higgs resonance.
26289         FACT=FACT*EMHWT
26290 C...constant weight.
26291         FACT=FACT*WEIGHT
26292 C...include BR of Higgs.
26293         IF(IMSSM.EQ.0)THEN
26294           IDEC=MOD(IPROC,100)
26295           IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
26296           IF (IDEC.EQ.0) THEN
26297             BRHIGQ=0.D0
26298             DO I=1,6
26299               BRHIGQ=BRHIGQ+BRHIG(I)
26300             END DO
26301             FACT=FACT*BRHIGQ
26302           ENDIF
26303 c bug fix 11/10/02 SM.
26304           IF (IDEC.EQ.10) THEN
26305             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26306             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26307             FACT=FACT*BR
26308           ELSEIF (IDEC.EQ.11) THEN
26309             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26310             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26311             FACT=FACT*BR
26312           ENDIF
26313 c end of bug fix.
26314         END IF
26315       END IF
26316 C...set up flavours in final state.
26317       IF((MOD(IPROC,10000).EQ.3839).OR.
26318      &   (MOD(IPROC,10000).EQ.3869).OR.
26319      &   (MOD(IPROC,10000).EQ.3899))THEN
26320         IF(HWRGEN(0).LT.0.5)THEN
26321           JHIGGS=207-201
26322           IIQ=6
26323           JJQ=11
26324           FLIP=0
26325         ELSE
26326           JHIGGS=206-201
26327           IIQ=5
26328           JJQ=12
26329           FLIP=1
26330         END IF
26331       ELSE
26332         JHIGGS=IHIGGS
26333         IIQ=IQ
26334         JJQ=JQ
26335         FLIP=0
26336       END IF
26337 C...set up PDFs.
26338       HCS=0.
26339       CALL HWSGEN(.FALSE.)
26340       IQMAX=13
26341       IQMIN=1
26342       IF((MOD(IPROC,10000).EQ.3839).OR.
26343      &   (MOD(IPROC,10000).EQ.3869).OR.
26344      &   (MOD(IPROC,10000).EQ.3899))THEN
26345         IF(MOD(IPROC,10000).EQ.3869)IQMIN=13
26346         IF(MOD(IPROC,10000).EQ.3899)IQMAX=12
26347       ELSE
26348         IF(IMSSM.NE.0)THEN
26349 C...Some compilers don't like this statement.
26350 C   Since it does nothing, just comment it out.
26351 C         IF((MOD(IPROC,10000).GE.3811).AND.
26352 C    &       (MOD(IPROC,10000).LE.3836))CONTINUE
26353           IF((MOD(IPROC,10000).GE.3841).AND.
26354      &       (MOD(IPROC,10000).LE.3866))IQMIN=13
26355           IF((MOD(IPROC,10000).GE.3871).AND.
26356      &       (MOD(IPROC,10000).LE.3896))IQMAX=12
26357         END IF
26358       END IF
26359       DO I=IQMIN,IQMAX
26360         IF(DISF(I,1).LT.EPS)THEN
26361           GOTO 200
26362         END IF
26363         K=I/7
26364         L=+1-2*K
26365         IF(I.EQ.13)L=0
26366         J=I+L*6
26367         IF(DISF(J,2).LT.EPS)THEN
26368           GOTO 200
26369         END IF
26370         DIST=DISF(I,1)*DISF(J,2)*S
26371         IF(I.LT.13)THEN
26372 C...set up color connections: qq-scattering.
26373           IF(J.EQ.I+6)THEN
26374             HCS=HCS+M2QQ*DIST*FACT
26375             IF(GENEV.AND.HCS.GT.RCS)THEN
26376               CONTINUE
26377               CALL HWHQCP(IIQ,JJQ,2413, 4)
26378               GOTO 9
26379             END IF
26380           ELSE IF(I.EQ.J+6)THEN
26381             HCS=HCS+M2QQ*DIST*FACT
26382             IF(GENEV.AND.HCS.GT.RCS)THEN
26383               FLIP=(2-2*FLIP)/2
26384               CALL HWHQCP(JJQ,IIQ,3142,12)
26385               GOTO 9
26386             END IF
26387           END IF
26388         ELSE
26389 C...set up color connections: gg-scattering.
26390           HCS=HCS
26391      &   +(M2GGPL-M2GG*M2GGPL/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
26392           IF(GENEV.AND.HCS.GT.RCS) THEN
26393             CALL HWHQCP(IIQ,JJQ,2413,27)
26394             GOTO 9
26395           ENDIF
26396           HCS=HCS
26397      &   +(M2GGMN-M2GG*M2GGMN/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
26398           IF(GENEV.AND.HCS.GT.RCS) THEN
26399             CALL HWHQCP(IIQ,JJQ,4123,28)
26400             GOTO 9
26401           ENDIF
26402         END IF
26403  200    CONTINUE
26404       END DO
26405       EVWGT=HCS
26406       RETURN
26407 C...generate event.
26408     9 IDN(1)=I
26409       IDN(2)=J
26410       IDN(5)=201+JHIGGS
26411 C...incoming partons: now massive.
26412       EMIN1=RMASS(IDN(1))
26413       EMIN2=RMASS(IDN(2))
26414 C...redo initial state momenta in the partonic CM.
26415       PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
26416      &       -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
26417       PCM=SQRT(PCM2)
26418       P1(0)=SQRT(PCM2+EMIN1*EMIN1)
26419       P1(1)=0.
26420       P1(2)=0.
26421       P1(3)=PCM
26422       P2(0)=SQRT(PCM2+EMIN2*EMIN2)
26423       P2(1)=0.
26424       P2(2)=0.
26425       P2(3)=-PCM
26426 C...randomly rotate final state momenta around beam axis.
26427       PHI=2.*PIFAC*HWRGEN(0)
26428       CPHI=COS(PHI)
26429       SPHI=SIN(PHI)
26430       ROT(1,1)=+CPHI
26431       ROT(1,2)=+SPHI
26432       ROT(1,3)=0.
26433       ROT(2,1)=-SPHI
26434       ROT(2,2)=+CPHI
26435       ROT(2,3)=0.
26436       ROT(3,1)=0.
26437       ROT(3,2)=0.
26438       ROT(3,3)=1.
26439       DO L=1,3
26440         DO M=1,3
26441           QAUX(M)=0.
26442           DO N=1,3
26443             IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
26444             IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
26445             IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
26446           END DO
26447         END DO
26448         DO M=1,3
26449           IF(L.EQ.1)P3(M)=QAUX(M)
26450           IF(L.EQ.2)P4(M)=QAUX(M)
26451           IF(L.EQ.3)P5(M)=QAUX(M)
26452         END DO
26453       END DO
26454 C...use HWETWO only to set up status and IDs of quarks.
26455       COSTH=0.
26456       IDCMF=15
26457       CALL HWETWO(.TRUE.,.TRUE.)
26458 C...do real incoming, outgoing momenta in the lab frame.
26459       VCOL=(XX(1)-XX(2))/(XX(1)+XX(2))
26460       GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2))
26461       DO M=NHEP-4,NHEP+1
26462         IF(M.EQ.NHEP-2)GO TO 888
26463         DO N=0,3
26464           IF(M.EQ.NHEP-4)QAUX(N)=P1(N)
26465           IF(M.EQ.NHEP-3)QAUX(N)=P2(N)
26466           IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP
26467           IF(M.EQ.NHEP  )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP
26468           IF(M.EQ.NHEP+1)QAUX(N)=P5(N)
26469         END DO
26470 C...perform boost.
26471         PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3))
26472         PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0))
26473         PHEP(2,M)=QAUX(2)
26474         PHEP(1,M)=QAUX(1)
26475  888    CONTINUE
26476       END DO
26477 C...needs to set all final state masses.
26478       PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2
26479      &                       -PHEP(3,NHEP-1)**2
26480      &                       -PHEP(2,NHEP-1)**2
26481      &                       -PHEP(1,NHEP-1)**2))
26482       PHEP(5,NHEP  )=SQRT(ABS(PHEP(4,NHEP  )**2
26483      &                       -PHEP(3,NHEP  )**2
26484      &                       -PHEP(2,NHEP  )**2
26485      &                       -PHEP(1,NHEP  )**2))
26486       PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
26487      &                       -PHEP(3,NHEP+1)**2
26488      &                       -PHEP(2,NHEP+1)**2
26489      &                       -PHEP(1,NHEP+1)**2))
26490 C...sets CMF.
26491       DO I=1,4
26492         PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3)
26493       END DO
26494       PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2
26495      &                       -PHEP(3,NHEP-2)**2
26496      &                       -PHEP(2,NHEP-2)**2
26497      &                       -PHEP(1,NHEP-2)**2))
26498 C...status and IDs for Higgs.
26499       ISTHEP(NHEP+1)=114
26500       IDHW(NHEP+1)=IDN(5)
26501       IDHEP(NHEP+1)=IDPDG(IDN(5))
26502 C...Higgs colour (self-)connections.
26503       JMOHEP(1,NHEP+1)=NHEP-2
26504       JMOHEP(2,NHEP+1)=NHEP+1
26505       JDAHEP(2,NHEP+1)=NHEP+1
26506       JDAHEP(2,NHEP-2)=NHEP+1
26507       NHEP=NHEP+1
26508       IF(AZSPIN)THEN
26509 C...set to zero the coefficients of the spin density matrices.
26510         CALL HWVZRO(7,GCOEF)
26511       END IF
26512       END
26513 C-----------------------------------------------------------------------
26514 CDECK  ID>, HWHIGS.
26515 *CMZ :-        -02/04/98  14.52.22  by  Mike Seymour
26516 *-- Author :    Mike Seymour
26517 *-- Modified:   Stefano Moretti 04/05/98
26518 C-----------------------------------------------------------------------
26519       SUBROUTINE HWHIGS
26520 C-----------------------------------------------------------------------
26521 C     HIGGS PRODUCTION VIA GLUON OR QUARK FUSION
26522 C     MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
26523 C-----------------------------------------------------------------------
26524       INCLUDE 'herwig65.inc'
26525       DOUBLE PRECISION HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM,BRHIGQ,EMH,
26526      & CSFAC(13),EVSUM(13),EMFAC,CV,CA,BR,RWGT,E1,E2,EMQ,GFACTR,RQM(6)
26527       INTEGER IDEC,I,J,ID1,ID2
26528       EXTERNAL HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM
26529       SAVE CSFAC,BR,EVSUM
26530       IF (GENEV) THEN
26531         RWGT=HWRGEN(0)*EVSUM(13)
26532         IDN(1)=1
26533         DO 10 I=1,12
26534  10       IF (RWGT.GT.EVSUM(I)) IDN(1)=I+1
26535         IDN(2)=13
26536         IF (IDN(1).LE.12) IDN(2)=IDN(1)-6
26537         IF (IDN(1).LE. 6) IDN(2)=IDN(1)+6
26538         IDCMF=201+IHIGGS
26539         CALL HWEONE
26540       ELSE
26541         EVWGT=0.
26542         EMH=RMASS(201+IHIGGS)
26543         EMFAC=1.D0
26544         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
26545         IF (EMH.LE.0 .OR. EMH.GE.PHEP(5,3)) RETURN
26546         EMSCA=EMH
26547         IF (EMSCA.NE.EMLST) THEN
26548           EMLST=EMH
26549           XXMIN=(EMH/PHEP(5,3))**2
26550           XLMIN=LOG(XXMIN)
26551           GFACTR=GEV2NB*HWUAEM(EMH**2)/(576.*SWEIN*RMASS(198)**2)
26552 C--MOD BY BRW 16/07/03 TO USE RUNNING MASSES
26553           CALL HWURQM(EMH,RQM)
26554           DO 20 I=1,13
26555             IF (I.EQ.13) THEN
26556               CSFAC(I)=-GFACTR*HWHIGT(  EMH)*XLMIN
26557      &                        *HWUALF(1,EMH)**2*EMFAC
26558             ELSEIF (I.GT.6) THEN
26559               CSFAC(I)=CSFAC(I-6)
26560             ELSE
26561               EMQ=RQM(I)
26562               IF (EMQ.GT.ZERO.AND.EMH.GT.TWO*EMQ) THEN
26563                 CSFAC(I)=-GFACTR*96.*PIFAC**2 *(1-(TWO*EMQ/EMH)**2)
26564      &                *(EMQ/EMH)**2 *XLMIN *EMFAC*ENHANC(I)**2
26565               ELSE
26566                 CSFAC(I)=0
26567               ENDIF
26568             ENDIF
26569 C--END MOD
26570  20       CONTINUE
26571 C  INCLUDE BRANCHING RATIO OF HIGGS
26572           IDEC=MOD(IPROC,100)
26573           BR=1
26574           IF(IMSSM.EQ.0)THEN
26575 C SM case
26576             IF (IDEC.EQ.0) THEN
26577               BRHIGQ=0
26578               DO 30 I=1,6
26579  30             BRHIGQ=BRHIGQ+BRHIG(I)
26580               BR=BRHIGQ
26581             ELSEIF (IDEC.EQ.10) THEN
26582               CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26583               CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26584               BR=BR*BRHIG(IDEC)
26585             ELSEIF (IDEC.EQ.11) THEN
26586               CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26587               CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26588               BR=BR*BRHIG(IDEC)
26589             ELSEIF (IDEC.LE.12) THEN
26590               BR=BRHIG(IDEC)
26591             ENDIF
26592           ENDIF
26593         ENDIF
26594         CALL HWSGEN(.TRUE.)
26595         EVWGT=0
26596         E1=PHEP(4,MAX(1,JDAHEP(1,1)))
26597         E2=PHEP(4,MAX(2,JDAHEP(1,2)))
26598         DO 40 I=1,13
26599           EMQ=RMASS(I)
26600           IF (EMH.GT.2*EMQ) THEN
26601             J=13
26602             IF (I.LE.12) J=I-6
26603             IF (I.LE. 6) J=I+6
26604             IF (XX(1).LT.0.5*(1-EMQ/E1+HWUSQR(1-2*EMQ/E1)) .AND.
26605      &          XX(2).LT.0.5*(1-EMQ/E2+HWUSQR(1-2*EMQ/E2)))
26606      &          EVWGT=EVWGT+DISF(I,1)*DISF(J,2)*CSFAC(I)*BR
26607           ENDIF
26608           EVSUM(I)=EVWGT
26609  40     CONTINUE
26610       ENDIF
26611       END
26612 CDECK  ID>, HWHIGT.
26613 *CMZ :-        -02/04/98  15.00.39  by  Mike Seymour
26614 *-- Author :    Mike Seymour
26615 C-----------------------------------------------------------------------
26616       FUNCTION HWHIGT(EMH)
26617 C-----------------------------------------------------------------------
26618 C  CALCULATE MOD SQUARED I DEFINED AS IN BARGER & PHILLIPS p433
26619 C  WARNING: THIS IS A FACTOR OF 3 GREATER THAN EHLQ'S ETA FUNCTION
26620 C  PARITY=+1 FOR SCALAR AND -1 FOR PSEUDOSCALAR
26621 C-----------------------------------------------------------------------
26622       INCLUDE 'herwig65.inc'
26623       DOUBLE PRECISION HWHIGT,RATIO,RAT2,EMH,FREAL,FIMAG,ETALOG,AIREAL,
26624      & AIIMAG
26625       INTEGER I,J,K,L
26626       HWHIGT=0
26627       IF (ABS(PARITY).NE.1) CALL HWWARN('HWHIGT',500)
26628       AIREAL=0
26629       AIIMAG=0
26630 C---CONTRIBUTION FROM QUARK LOOPS
26631       DO 100 I=1,NFLAV
26632         RATIO=RMASS(I)/EMH
26633         RAT2=RATIO**2
26634         IF     (RAT2.GT.0.25) THEN
26635           FREAL=-2.*ASIN(0.5/RATIO)**2
26636           FIMAG=0
26637         ELSEIF (RAT2.LT.0.25) THEN
26638           ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
26639           FREAL=0.5 * (ETALOG**2 - PIFAC**2)
26640           FIMAG=PIFAC * ETALOG
26641         ELSE
26642           FREAL=0.5 * (          - PIFAC**2)
26643           FIMAG=0
26644         ENDIF
26645         IF (PARITY.EQ.1) THEN
26646           AIREAL=AIREAL+3*RAT2*(2 + (4*RAT2-1)*FREAL)*ENHANC(I)
26647           AIIMAG=AIIMAG+3*RAT2*(    (4*RAT2-1)*FIMAG)*ENHANC(I)
26648         ELSE
26649           AIREAL=AIREAL-2*RAT2*(FREAL)*ENHANC(I)
26650           AIIMAG=AIIMAG-2*RAT2*(FIMAG)*ENHANC(I)
26651         ENDIF
26652  100  CONTINUE
26653 C---CONTRIBUTION FROM SQUARK LOOPS
26654       DO 200 I=1,12
26655         J=I/7
26656         K=6*J+I
26657         L=K
26658         IF(K.GT.6)L=K-12
26659         RATIO=RMASS(L)/EMH
26660         RAT2=RATIO**2
26661         IF     (RAT2.GT.0.25) THEN
26662           FREAL=-2.*ASIN(0.5/RATIO)**2
26663           FIMAG=0
26664         ELSEIF (RAT2.LT.0.25) THEN
26665           ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
26666           FREAL=0.5 * (ETALOG**2 - PIFAC**2)
26667           FIMAG=PIFAC * ETALOG
26668         ELSE
26669           FREAL=0.5 * (          - PIFAC**2)
26670           FIMAG=0
26671         ENDIF
26672         IF (PARITY.EQ.1) THEN
26673           AIREAL=AIREAL-3*RAT2*(1 + 2*RAT2*FREAL)*SENHNC(K)
26674           AIIMAG=AIIMAG-3*RAT2*(    2*RAT2*FIMAG)*SENHNC(K)
26675         ENDIF
26676  200  CONTINUE
26677 C---FUNCTION RETURNS MOD-SQUARED OF SUM
26678       HWHIGT=AIREAL**2 + AIIMAG**2
26679       END
26680 CDECK  ID>, HWHIGV.
26681 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
26682 *-- Author :  Stefano Moretti
26683 C-----------------------------------------------------------------------
26684 C...Generate completely differential cross section (EVWGT) in the variables
26685 C...X(I) with I=1,4 (see below) for the processes of ther series
26686 C...IPROC=2600,2700 as described in the HERWIG 6 documentation file.
26687 C...It includes interface to PDFs and takes into account color connections
26688 C...among partons.
26689 C
26690 C...First release: 8-APR-1999 by Stefano Moretti
26691 C
26692       SUBROUTINE HWHIGV
26693 C-----------------------------------------------------------------------
26694 C     MSSM NEUTRAL HIGGS PRODUCTION IN ASSOCIATION WITH GAUGE BOSON
26695 C--BRW fix 27/8/04: corrected off-shell gauge boson mass dependence
26696 C-----------------------------------------------------------------------
26697       INCLUDE 'herwig65.inc'
26698       INTEGER I,J,K,L,M,N
26699       INTEGER IV,IDEC
26700       INTEGER ID1,ID2
26701       DOUBLE PRECISION CV,CA,BR
26702       DOUBLE PRECISION BRHIGQ,EMH,EMHWT,EMV,RMV,GAMV,RMH
26703       DOUBLE PRECISION X(4),XL(4),XU(4)
26704       DOUBLE PRECISION CT,ST,CCT
26705       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
26706       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
26707       DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
26708       DOUBLE PRECISION QQV(12,12),C4W,VQ(12),AQ(12)
26709       DOUBLE PRECISION M2,M2L,M2T
26710       DOUBLE PRECISION ALPHA,EMSC2
26711       DOUBLE PRECISION HWRGEN,HWUAEM
26712       DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
26713       DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
26714       DOUBLE PRECISION WEIGHT
26715       DOUBLE PRECISION VSAVE,HSAVE,CFT,QR,QL
26716       SAVE EMH,EMV,HCS,M2,M2L,M2T,FACT,QQV,S,CT
26717       LOGICAL HWRLOG
26718       EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2VH,HWETWO,HWRLOG
26719       PARAMETER (EPS=1.D-9)
26720       IF(IMSSM.EQ.0)THEN
26721         IF(IPRO.EQ.26)IV=0
26722         IF(IPRO.EQ.27)IV=1
26723       ELSE
26724         IF((MOD(IPROC,10000).EQ.3310).OR.
26725      &     (MOD(IPROC,10000).EQ.3320))THEN
26726           IV=0
26727         ELSEIF((MOD(IPROC,10000).EQ.3360).OR.
26728      &         (MOD(IPROC,10000).EQ.3370))THEN
26729           IV=1
26730         END IF
26731       END IF
26732       IF(GENEV)THEN
26733         RCS=HCS*HWRGEN(0)
26734       ELSE
26735         HCS=0.
26736         EVWGT=0.
26737 C...assign final state masses.
26738         RMV=RMASS(198+2*IV)
26739         RMH=RMASS(201+IHIGGS)
26740         IF(IV.EQ.0)GAMV=GAMW
26741         IF(IV.EQ.1)GAMV=GAMZ
26742         EMH=RMH
26743         EMHWT=1.D0
26744         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
26745 C...energy at hadron level.
26746         ECM_MAX=PBEAM1+PBEAM2
26747         S=ECM_MAX*ECM_MAX
26748 C...phase space variables.
26749 C...X(1)=COS(THETA_CM),
26750 C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMV+EMH)**2-1./ECM_MAX**2),
26751 C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
26752 C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
26753 C...where THETA=ATAN((EMV*EMV-RMV*RMV)/RMV/GAMV);
26754 C...phase space borders.
26755         XL(1)=-1.
26756         XU(1)=1.
26757         XL(2)=0.
26758         XU(2)=1.
26759         XL(3)=0.
26760         XU(3)=1.
26761         XL(4)=0.
26762         XU(4)=1.
26763 C...single phase space point.
26764         WEIGHT=1.
26765         DO I=1,4
26766           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
26767           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
26768         END DO
26769 C...resonant boson mass.
26770         RNMIN=RMV-GAMMAX*GAMV
26771         THETA_MIN=ATAN((RNMIN*RNMIN-RMV*RMV)/RMV/GAMV)
26772         RNMAX=ECM_MAX-EMH
26773         THETA_MAX=ATAN((RNMAX*RNMAX-RMV*RMV)/RMV/GAMV)
26774         EMV=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
26775      &     *RMV*GAMV+RMV*RMV)
26776 C...energy at parton level.
26777         ECM=SQRT(1./(X(2)*(1./(EMV+EMH)**2-1./ECM_MAX**2)
26778      &                                    +1./ECM_MAX**2))
26779         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
26780         SHAT=ECM*ECM
26781         TAU=SHAT/S
26782 C...momentum fractions X1 and X2.
26783         XX(1)=EXP(LOG(TAU)*(1.-X(3)))
26784         XX(2)=TAU/XX(1)
26785 C...two particle kinematics.
26786         CT=X(1)
26787         IF(HWRLOG(HALF))THEN
26788           ST=+SQRT(1.-CT*CT)
26789         ELSE
26790           ST=-SQRT(1.-CT*CT)
26791         END IF
26792 C...single phase space point.
26793         RCM2=((SHAT-EMV*EMV-EMH*EMH)**2
26794      &      -(2.*EMV*EMH)**2)/(4.*SHAT)
26795         RCM=SQRT(RCM2)
26796         P3(0)=SQRT(RCM2+EMV*EMV)
26797         P3(1)=0.
26798         P3(2)=RCM*ST
26799         P3(3)=RCM*CT
26800         P4(0)=SQRT(RCM2+EMH*EMH)
26801         P4(1)=0.
26802         P4(2)=-RCM*ST
26803         P4(3)=-RCM*CT
26804 C...incoming partons: massless.
26805         EMIN=0.
26806 C...initial state momenta in the partonic CM.
26807         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
26808      &      -(2.*EMIN*EMIN)**2)/(4.*SHAT)
26809         PCM=SQRT(PCM2)
26810         P1(0)=SQRT(PCM2+EMIN*EMIN)
26811         P1(1)=0.
26812         P1(2)=0.
26813         P1(3)=PCM
26814         P2(0)=SQRT(PCM2+EMIN*EMIN)
26815         P2(1)=0.
26816         P2(2)=0.
26817         P2(3)=-PCM
26818 C...color structured ME summed/averaged over final/initial spins and colors.
26819         CALL HWH2VH(P1,P2,P3,P4,EMV,M2,M2L,M2T)
26820         IF(M2.LE.0.)RETURN
26821 C...vector-axial couplings of V to qq'/qq.
26822         IF(IV.EQ.0)THEN
26823           DO I=2,12,2
26824             K=I
26825             IF(I.GT.6)K=I-6
26826             M=K/2
26827             N=0
26828             DO J=1,11,2
26829               L=J
26830               IF(J.GT.6)L=J-6
26831               N=L-N
26832 c bug fix 20/05/01 SM.
26833               QQV(I,J)=VCKM(M,N)
26834 c end of bug fix.
26835               QQV(J,I)=QQV(I,J)
26836               IF(N.EQ.3)N=0
26837             END DO
26838           END DO
26839         ELSE IF(IV.EQ.1)THEN
26840           C4W=(1.-SWEIN)*(1.-SWEIN)
26841           DO I=1,11,2
26842             VQ(I)=2.*VFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26843             AQ(I)=2.*AFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26844             J=I+6
26845             IF(J.GT.12)J=J-12
26846             QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
26847           END DO
26848           DO I=2,12,2
26849             VQ(I)=2.*VFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26850             AQ(I)=2.*AFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26851             J=I+6
26852             IF(J.GT.12)J=J-12
26853             QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
26854           END DO
26855         END IF
26856 C...constant factors: phi along beam and conversion GeV^2->nb.
26857         FACT=2.*PIFAC*GEV2NB
26858 C...Jacobians from X1,X2 to X(2),X(3)
26859         FACT=FACT/S*(-LOG(TAU))*(1./(EMV+EMH)**2-1./ECM_MAX**2)
26860 C...phase space Jacobians, pi's and flux.
26861         FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
26862 C...EW couplings.
26863         EMSCA=RMV+RMH
26864         EMSC2=EMSCA*EMSCA
26865         ALPHA=HWUAEM(EMSC2)
26866 C--BRW fix 27/8/04: RMV*RMV --> EMV*EMV
26867         FACT=FACT*16.*PIFAC**2*ALPHA**2/SWEIN/SWEIN*EMV*EMV
26868 C...enhancement factor for MSSM.
26869         FACT=FACT*ENHANC(10+IV)*ENHANC(10+IV)
26870 C...Higgs resonance.
26871         FACT=FACT*EMHWT
26872 C...vector boson resonance.
26873         FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
26874 C...constant weight.
26875         FACT=FACT*WEIGHT
26876 C...include BR of Higgs.
26877         IF(IMSSM.EQ.0)THEN
26878           IDEC=MOD(IPROC,100)
26879           IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
26880           IF (IDEC.EQ.0) THEN
26881             BRHIGQ=0.D0
26882             DO I=1,6
26883               BRHIGQ=BRHIGQ+BRHIG(I)
26884             END DO
26885             FACT=FACT*BRHIGQ
26886           ENDIF
26887 c bug fix 11/10/02 SM.
26888           IF (IDEC.EQ.10) THEN
26889             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26890             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26891             FACT=FACT*BR
26892           ELSEIF (IDEC.EQ.11) THEN
26893             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26894             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26895             FACT=FACT*BR
26896           ENDIF
26897 c end of bug fix.
26898         END IF
26899       END IF
26900 C...set up PDFs.
26901       HCS=0.
26902       CALL HWSGEN(.FALSE.)
26903       DO I=1,12
26904         IF(DISF(I,1).LT.EPS)THEN
26905           GOTO 200
26906         END IF
26907         K=I/7
26908         L=+1-2*K
26909         IF(IV.EQ.0)THEN
26910           J=I+L*6+(-1)**(I+1)
26911         ELSE IF(IV.EQ.1)THEN
26912           J=I+L*6
26913         END IF
26914         IF(DISF(J,2).LT.EPS)THEN
26915           GOTO 200
26916         END IF
26917         DIST=DISF(I,1)*DISF(J,2)*S
26918 C...QQV vector and axial couplings.
26919         DIST=DIST*QQV(I,J)
26920 C...no need to set up color connections.
26921         HCS=HCS+M2*DIST*FACT
26922         IF(GENEV.AND.HCS.GT.RCS)THEN
26923 C...generate event.
26924           IDN(1)=I
26925           IDN(2)=J
26926           IF(IV.EQ.0)
26927      &    IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
26928           IF(IV.EQ.1)IDN(3)=200
26929           IDN(4)=201+IHIGGS
26930           COSTH=CT
26931           IDCMF=15
26932           ICO(1)=2
26933           ICO(2)=1
26934           ICO(3)=3
26935           ICO(4)=4
26936 C...trick HWETWO in using off-shell V and H masses.
26937           VSAVE=RMASS(IDN(3))
26938           HSAVE=RMASS(IDN(4))
26939           RMASS(IDN(3))=EMV
26940           RMASS(IDN(4))=EMH
26941 C-- BRW fix 27/8/04: avoid double smearing of W and H masses
26942           CALL HWETWO(.FALSE.,.FALSE.)
26943           RMASS(IDN(3))=VSAVE
26944           RMASS(IDN(4))=HSAVE
26945           IF(AZSPIN)THEN
26946 C...set to zero the coefficients of the spin density matrices.
26947             CALL HWVZRO(7,GCOEF)
26948           END IF
26949 C...calculates exactly polarized decay matrix of gauge boson.
26950           IF(IERROR.NE.0)RETURN
26951           CCT=CT
26952           IF(I.GT.6)CCT=-CT
26953           IF(M2L.LT.0.)M2L=0.
26954           IF(M2T.LT.0.)M2T=0.
26955           RHOHEP(2,NHEP-1)=M2L/M2
26956           CFT=(M2-M2L)/(1.+CCT**2)/2.
26957           IF(IV.EQ.0)THEN
26958             RHOHEP(1,NHEP-1)=CFT*(1.+CCT)**2/M2
26959             RHOHEP(3,NHEP-1)=CFT*(1.-CCT)**2/M2
26960           ELSE IF(IV.EQ.1)THEN
26961             QR=(VQ(I)-AQ(I))/2.
26962             QL=(VQ(I)+AQ(I))/2.
26963             RHOHEP(1,NHEP-1)=CFT*(QR**2*(1.-CCT)**2+QL**2*(1.+CCT)**2)
26964      &                      /(QR**2+QL**2)/M2
26965             RHOHEP(3,NHEP-1)=CFT*(QR**2*(1.+CCT)**2+QL**2*(1.-CCT)**2)
26966      &                    /(QR**2+QL**2)/M2
26967           END IF
26968         RETURN
26969         END IF
26970  200    CONTINUE
26971       END DO
26972       EVWGT=HCS
26973       END
26974 CDECK  ID>, HWHIGW.
26975 *CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
26976 *-- Author :    Mike Seymour, modified by Stefano Moretti
26977 C-----------------------------------------------------------------------
26978       SUBROUTINE HWHIGW
26979 C-----------------------------------------------------------------------
26980 C     HIGGS PRODUCTION VIA W/Z BOSON FUSION
26981 C     MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
26982 C-----------------------------------------------------------------------
26983       INCLUDE 'herwig65.inc'
26984       DOUBLE PRECISION HWULDO,HWRUNI,HWRGEN,HWUAEM,K1MAX2,K1MIN2,K12,
26985      & K2MAX2,K2MIN2,K22,EMW2,EMW,ROOTS,EMH2,EMH,ROOTS2,P1,PHI1,PHI2,
26986      & COSPHI,COSTH1,SINTH1,COSTH2,SINTH2,P2,WEIGHT,TAU,TAULN,CSFAC,
26987      & PSUM,PROB,Q1(5),Q2(5),H(5),A,B,C,TERM2,BRHIGQ,G1WW,G2WW,G1ZZ(6),
26988      & G2ZZ(6),AWW,AZZ(6),PWW,PZZ(6),EMZ,EMZ2,RSUM,GLUSQ,GRUSQ,GLDSQ,
26989      & GRDSQ,GLESQ,GRESQ,CW,CZ,EMFAC,CV,CA,BR,X2,ETA,P1JAC,FACTR,EH2
26990       INTEGER HWRINT,IDEC,I,ID1,ID2,IHAD
26991       LOGICAL EE,EP
26992       EXTERNAL HWULDO,HWRUNI,HWRGEN,HWUAEM,HWRINT
26993       SAVE EMW2,EMZ2,EE,GLUSQ,GRUSQ,GLDSQ,GRDSQ,GLESQ,GRESQ,G1ZZ,G2ZZ,
26994      & G1WW,G2WW,CW,CZ,PSUM,AWW,PWW,AZZ,PZZ,ROOTS,Q1,Q2,H,FACTR
26995       EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
26996       IHAD=2
26997       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
26998       IF (FSTWGT) THEN
26999         EMW2=EMW**2
27000         EMZ2=EMZ**2
27001         GLUSQ=(VFCH(2,1)+AFCH(2,1))**2
27002         GRUSQ=(VFCH(2,1)-AFCH(2,1))**2
27003         GLDSQ=(VFCH(1,1)+AFCH(1,1))**2
27004         GRDSQ=(VFCH(1,1)-AFCH(1,1))**2
27005         GLESQ=(VFCH(11,1)+AFCH(11,1))**2
27006         GRESQ=(VFCH(11,1)-AFCH(11,1))**2
27007         G1ZZ(1)=GLUSQ*GLUSQ+GRUSQ*GRUSQ
27008         G2ZZ(1)=GLUSQ*GRUSQ+GRUSQ*GLUSQ
27009         G1ZZ(2)=GLUSQ*GLDSQ+GRUSQ*GRDSQ
27010         G2ZZ(2)=GLUSQ*GRDSQ+GRUSQ*GLDSQ
27011         G1ZZ(3)=GLDSQ*GLDSQ+GRDSQ*GRDSQ
27012         G2ZZ(3)=GLDSQ*GRDSQ+GRDSQ*GLDSQ
27013         G1ZZ(4)=GLESQ*GLESQ+GRESQ*GRESQ
27014         G2ZZ(4)=GLESQ*GRESQ+GRESQ*GLESQ
27015         G1ZZ(5)=GLESQ*GLUSQ+GRESQ*GRUSQ
27016         G2ZZ(5)=GLESQ*GRUSQ+GRESQ*GLUSQ
27017         G1ZZ(6)=GLESQ*GLDSQ+GRESQ*GRDSQ
27018         G2ZZ(6)=GLESQ*GRDSQ+GRESQ*GLDSQ
27019         G1WW=0.25
27020         G2WW=0
27021         FACTR=GEV2NB/(128.*PIFAC**3)
27022         EH2=RMASS(201+IHIGGS)**2
27023         CW=256*(PIFAC*HWUAEM(EH2)/SWEIN)**3*EMW2
27024         CZ=256.*(PIFAC*HWUAEM(EH2))**3*EMZ2/(SWEIN*(1.-SWEIN))
27025       ENDIF
27026       EE=IPRO.LE.12
27027       EP=IPRO.GE.90
27028       IF (.NOT.GENEV) THEN
27029 C---CHOOSE PARAMETERS
27030         EVWGT=0.
27031         EMH=RMASS(201+IHIGGS)
27032         EMFAC=ONE
27033         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
27034         IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
27035         EMSCA=EMH
27036         IF (EE) THEN
27037           ROOTS=PHEP(5,3)
27038         ELSE
27039           TAU=(EMH/PHEP(5,3))**2
27040           TAULN=LOG(TAU)
27041           ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,-1D-10,TAULN)))
27042         ENDIF
27043         EMH2=EMH**2
27044         ROOTS2=ROOTS**2
27045 C---CHOOSE P1 ACCORDING TO (1-ETA)*(ETA-X2)/ETA**2
27046 C   WHERE ETA=1-2P1/ROOTS AND X2=EMH**2/S
27047         X2=EMH2/ROOTS2
27048  1      ETA=X2**HWRGEN(0)
27049         IF (HWRGEN(0)*(1-EMH/ROOTS)**2*ETA.GT.(1-ETA)*(ETA-X2))GOTO 1
27050         P1JAC=0.5*ROOTS*ETA**2/((1-ETA)*(ETA-X2))
27051      &    *(-LOG(X2)*(1+X2)-2*(1-X2))
27052         P1=0.5*ROOTS*(1-ETA)
27053 C---CHOOSE PHI1,2 UNIFORMLY
27054         PHI1=2*PIFAC*HWRGEN(0)
27055         PHI2=2*PIFAC*HWRGEN(0)
27056         COSPHI=COS(PHI2-PHI1)
27057 C---CHOOSE K1^2, ON PROPAGATOR FACTOR
27058         K1MAX2=2*P1*ROOTS
27059         K1MIN2=0
27060         K12=EMW2-(EMW2+K1MAX2)*(EMW2+K1MIN2)/
27061      &           ((K1MAX2-K1MIN2)*HWRGEN(0)+(EMW2+K1MIN2))
27062 C---CALCULATE COSTH1 FROM K1^2
27063         COSTH1=1+K12/(P1*ROOTS)
27064         SINTH1=SQRT(1-COSTH1**2)
27065 C---CHOOSE K2^2
27066         K2MAX2=ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)*(ROOTS-P1-P1*COSTH1)
27067      &        /((ROOTS-P1)**2-(P1*COSTH1)**2-(P1*SINTH1*COSPHI)**2)
27068         K2MIN2=0
27069         K22=EMW2-(EMW2+K2MAX2)*(EMW2+K2MIN2)/
27070      &           ((K2MAX2-K2MIN2)*HWRGEN(0)+(EMW2+K2MIN2))
27071 C---CALCULATE A,B,C FACTORS, AND...
27072         A=-2*K22*P1*COSTH1 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
27073         B=-2*K22*P1*SINTH1*COSPHI
27074         C=+2*K22*P1 - 2*ROOTS*K22 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
27075 C---SOLVE A*COSTH2 + B*SINTH2 + C = 0 FOR COSTH2
27076         TERM2=B**2 + A**2 - C**2
27077         IF (TERM2.LT.ZERO) RETURN
27078         TERM2=B*SQRT(TERM2)
27079         IF (A.GE.ZERO) RETURN
27080         COSTH2=(-A*C + TERM2)/(A**2+B**2)
27081         SINTH2=SQRT(1-COSTH2**2)
27082 C---FINALLY, GET P2
27083         IF (COSTH2.EQ.-ONE) RETURN
27084         P2=-K22/(ROOTS*(1+COSTH2))
27085 C---LOAD UP CMF MOMENTA
27086         Q1(1)=P1*SINTH1*COS(PHI1)
27087         Q1(2)=P1*SINTH1*SIN(PHI1)
27088         Q1(3)=P1*COSTH1
27089         Q1(4)=P1
27090         Q1(5)=0
27091         Q2(1)=P2*SINTH2*COS(PHI2)
27092         Q2(2)=P2*SINTH2*SIN(PHI2)
27093         Q2(3)=P2*COSTH2
27094         Q2(4)=P2
27095         Q2(5)=0
27096         H(1)=-Q1(1)-Q2(1)
27097         H(2)=-Q1(2)-Q2(2)
27098         H(3)=-Q1(3)-Q2(3)
27099         H(4)=-Q1(4)-Q2(4)+ROOTS
27100         CALL HWUMAS(H)
27101 C---CALCULATE MATRIX ELEMENTS SQUARED
27102         AWW=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G1WW
27103      &         +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2WW)
27104         DO 10 I=1,6
27105           AZZ(I)=ENHANC(11)**2 * CZ*(ROOTS2/2*HWULDO(Q1,Q2)*G1ZZ(I)
27106      &               +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2ZZ(I))
27107      &          *((K12-EMW2)/(K12-EMZ2)*(K22-EMW2)/(K22-EMZ2))**2
27108  10     CONTINUE
27109 C---CALCULATE WEIGHT IN INTEGRAL
27110         WEIGHT=FACTR*P2*P1JAC/(ROOTS2**2*HWULDO(H,Q2))
27111      &              *(K1MAX2-K1MIN2)/((K1MAX2+EMW2)*(K1MIN2+EMW2))
27112      &              *(K2MAX2-K2MIN2)/((K2MAX2+EMW2)*(K2MIN2+EMW2))
27113      &              * EMFAC
27114         EMSCA=EMW
27115         XXMIN=(ROOTS/PHEP(5,3))**2
27116         XLMIN=LOG(XXMIN)
27117 C---INCLUDE BRANCHING RATIO OF HIGGS
27118         IF(IMSSM.EQ.0)THEN
27119           IDEC=MOD(IPROC,100)
27120           IF (IDEC.GT.0.AND.IDEC.LE.12) WEIGHT=WEIGHT*BRHIG(IDEC)
27121           IF (IDEC.EQ.0) THEN
27122             BRHIGQ=0
27123             DO 20 I=1,6
27124  20           BRHIGQ=BRHIGQ+BRHIG(I)
27125             WEIGHT=WEIGHT*BRHIGQ
27126           ENDIF
27127           IF (IDEC.EQ.10) THEN
27128             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
27129             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
27130             WEIGHT=WEIGHT*BR
27131           ELSEIF (IDEC.EQ.11) THEN
27132             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
27133             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
27134             WEIGHT=WEIGHT*BR
27135           ENDIF
27136         END IF
27137         IF (EE) THEN
27138           CSFAC=WEIGHT
27139           PSUM=AWW+AZZ(4)
27140           EVWGT=CSFAC*PSUM
27141         ELSEIF (EP) THEN
27142           CSFAC=-WEIGHT*TAULN
27143           XX(1)=ONE
27144           XX(2)=XXMIN
27145           CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD),NSTRU,DISF(1,2),2)
27146           IF (IDHW(1).LE.126) THEN
27147             PWW=(DISF(2,2)+DISF(4,2)+DISF(7,2)+DISF( 9,2))*AWW
27148           ELSE
27149             PWW=(DISF(1,2)+DISF(3,2)+DISF(8,2)+DISF(10,2))*AWW
27150           ENDIF
27151           PZZ(5)=(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2))*AZZ(5)
27152           PZZ(6)=(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF( 9,2))*AZZ(6)
27153           PSUM=PWW+PZZ(5)+PZZ(6)
27154           EVWGT=CSFAC*PSUM
27155         ELSE
27156           CSFAC=WEIGHT*TAULN*XLMIN
27157           CALL HWSGEN(.TRUE.)
27158           PWW=((DISF(2,1)+DISF(4, 1)+DISF(7,1)+DISF(9,1))
27159      &        *(DISF(8,2)+DISF(10,2)+DISF(1,2)+DISF(3,2))
27160      &        +(DISF(8,1)+DISF(10,1)+DISF(1,1)+DISF(3,1))
27161      &        *(DISF(2,2)+DISF(4, 2)+DISF(7,2)+DISF(9,2)))
27162      &        *AWW
27163           PZZ(1)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
27164      &           *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
27165      &           *AZZ(1)
27166           PZZ(2)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
27167      &           *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9, 2))
27168      &           +(DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9, 1))
27169      &           *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
27170      &           *AZZ(2)
27171           PZZ(3)=((DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9,1))
27172      &           *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9,2)))
27173      &           *AZZ(3)
27174           PSUM=PWW+PZZ(1)+PZZ(2)+PZZ(3)
27175 C---EVENT WEIGHT IS SUM OVER ALL COMBINATIONS
27176           EVWGT=CSFAC*PSUM
27177         ENDIF
27178       ELSE
27179 C---GENERATE EVENT
27180 C---CHOOSE EVENT TYPE
27181         RSUM=PSUM*HWRGEN(0)
27182 C---ELECTRON BEAMS?
27183         IF (EE) THEN
27184           IDN(1)=IDHW(1)
27185           IDN(2)=IDHW(2)
27186 C---WW FUSION?
27187           IF (RSUM.LT.AWW) THEN
27188             IDN(3)=IDN(1)+1
27189             IDN(4)=IDN(2)+1
27190 C---ZZ FUSION?
27191           ELSE
27192             IDN(3)=IDN(1)
27193             IDN(4)=IDN(2)
27194           ENDIF
27195 C---LEPTON-HADRON COLLISION?
27196         ELSEIF (EP) THEN
27197 C---WW FUSION?
27198           IDN(1)=IDHW(1)
27199           IF (RSUM.LT.PWW) THEN
27200  24         IDN(2)=HWRINT(1,8)
27201             IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
27202             IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 24
27203             PROB=DISF(IDN(2),2)*AWW/PWW
27204             IF (HWRGEN(0).GT.PROB) GOTO 24
27205             IDN(3)=IDN(1)+1
27206             IF (HWRGEN(0).GT.SCABI) THEN
27207               IDN(4)= 4*INT((IDN(2)-1)/2)-IDN(2)+3
27208             ELSE
27209               IDN(4)=12*INT((IDN(2)-1)/6)-IDN(2)+5
27210             ENDIF
27211 C---ZZ FUSION FROM U-TYPE QUARK?
27212           ELSEIF (RSUM.LT.PWW+PZZ(5)) THEN
27213  26         IDN(2)=2*HWRINT(1,4)
27214             IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
27215             PROB=DISF(IDN(2),2)*AZZ(5)/PZZ(5)
27216             IF (HWRGEN(0).GT.PROB) GOTO 26
27217             IDN(3)=IDN(1)
27218             IDN(4)=IDN(2)
27219 C---ZZ FUSION FROM D-TYPE QUARK?
27220           ELSE
27221  28         IDN(2)=2*HWRINT(1,4)-1
27222             IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
27223             PROB=DISF(IDN(2),2)*AZZ(6)/PZZ(6)
27224             IF (HWRGEN(0).GT.PROB) GOTO 28
27225             IDN(3)=IDN(1)
27226             IDN(4)=IDN(2)
27227           ENDIF
27228 C---HADRON BEAMS?
27229         ELSE
27230 C---WW FUSION?
27231           IF (RSUM.LT.PWW) THEN
27232  31         DO 32 I=1,2
27233               IDN(I)=HWRINT(1,8)
27234               IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
27235  32         CONTINUE
27236             IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 31
27237             PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW/PWW
27238             IF (HWRGEN(0).GT.PROB) GOTO 31
27239 C---CHOOSE OUTGOING QUARKS
27240             DO 33 I=1,2
27241               IF (HWRGEN(0).GT.SCABI) THEN
27242                 IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
27243               ELSE
27244                 IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
27245               ENDIF
27246  33         CONTINUE
27247 C---ZZ FUSION FROM U-TYPE QUARKS?
27248           ELSEIF (RSUM.LT.PWW+PZZ(1)) THEN
27249  41         DO 42 I=1,2
27250               IDN(I)=2*HWRINT(1,4)
27251               IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
27252  42         CONTINUE
27253             PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1)/PZZ(1)
27254             IF (HWRGEN(0).GT.PROB) GOTO 41
27255             IDN(3)=IDN(1)
27256             IDN(4)=IDN(2)
27257 C---ZZ FUSION FROM D-TYPE QUARKS?
27258           ELSEIF (RSUM.LT.PWW+PZZ(1)+PZZ(3)) THEN
27259  51         DO 52 I=1,2
27260               IDN(I)=2*HWRINT(1,4)-1
27261               IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
27262  52         CONTINUE
27263             PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(3)/PZZ(3)
27264             IF (HWRGEN(0).GT.PROB) GOTO 51
27265             IDN(3)=IDN(1)
27266             IDN(4)=IDN(2)
27267 C---ZZ FUSION FROM UD-TYPE PAIRS?
27268           ELSE
27269  61         IF (HWRGEN(0).GT.HALF) THEN
27270               IDN(1)=2*HWRINT(1,4)-1
27271               IDN(2)=2*HWRINT(1,4)
27272             ELSE
27273               IDN(1)=2*HWRINT(1,4)
27274               IDN(2)=2*HWRINT(1,4)-1
27275             ENDIF
27276             DO 62 I=1,2
27277  62           IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
27278             PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2)/PZZ(2)
27279             IF (HWRGEN(0).GT.PROB) GOTO 61
27280             IDN(3)=IDN(1)
27281             IDN(4)=IDN(2)
27282           ENDIF
27283         ENDIF
27284 C---NOW BOOST TO LAB, AND SET UP STATUS CODES etc
27285         IDCMF=15
27286 C---INCOMING
27287         IF (.NOT.EE) CALL HWEONE
27288 C---CMF POINTERS
27289         JDAHEP(1,NHEP)=NHEP+1
27290         JDAHEP(2,NHEP)=NHEP+3
27291         JMOHEP(1,NHEP+1)=NHEP
27292         JMOHEP(1,NHEP+2)=NHEP
27293         JMOHEP(1,NHEP+3)=NHEP
27294 C---OUTGOING MOMENTA (GIVE QUARKS MASS NON-COVARIANTLY!)
27295         Q1(5)=RMASS(IDN(1))
27296         Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
27297         Q2(5)=RMASS(IDN(2))
27298         Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
27299         H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
27300         CALL HWUMAS(H)
27301         CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
27302         CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
27303         CALL HWULOB(PHEP(1,NHEP),H,PHEP(1,NHEP+3))
27304 C---STATUS AND IDs
27305         ISTHEP(NHEP+1)=113
27306         ISTHEP(NHEP+2)=114
27307         ISTHEP(NHEP+3)=114
27308         IDHW(NHEP+1)=IDN(3)
27309         IDHEP(NHEP+1)=IDPDG(IDN(3))
27310         IDHW(NHEP+2)=IDN(4)
27311         IDHEP(NHEP+2)=IDPDG(IDN(4))
27312         IDHW(NHEP+3)=201+IHIGGS
27313         IDHEP(NHEP+3)=IDPDG(201+IHIGGS)
27314 C---COLOUR LABELS
27315         JMOHEP(2,NHEP+1)=NHEP-2
27316         JMOHEP(2,NHEP+2)=NHEP-1
27317         JMOHEP(2,NHEP-1)=NHEP+2
27318         JMOHEP(2,NHEP-2)=NHEP+1
27319         JMOHEP(2,NHEP+3)=NHEP+3
27320         JDAHEP(2,NHEP+1)=NHEP-2
27321         JDAHEP(2,NHEP+2)=NHEP-1
27322         JDAHEP(2,NHEP-1)=NHEP+2
27323         JDAHEP(2,NHEP-2)=NHEP+1
27324         JDAHEP(2,NHEP+3)=NHEP+3
27325         NHEP=NHEP+3
27326       ENDIF
27327       END
27328 CDECK  ID>, HWHIGY.
27329 *CMZ :-        -26/04/91  13.37.37  by  Federico Carminati
27330 *-- Author :    Mike Seymour
27331 C-----------------------------------------------------------------------
27332       FUNCTION HWHIGY(A,B,XP)
27333 C-----------------------------------------------------------------------
27334 C     CALCULATE THE INTEGRAL OF BERENDS AND KLEISS APPENDIX B
27335 C-----------------------------------------------------------------------
27336       IMPLICIT NONE
27337       DOUBLE COMPLEX XQ,Z1,Z2,Z3,Z4,C0,C1,C2,C3,C4,C5,C6,C7,C8,FUN,Z
27338       DOUBLE PRECISION HWHIGY,TWO,A,B,XP,Y
27339       PARAMETER (TWO=2.D0)
27340 C---DECLARE ALL THE STATEMENT-FUNCTION DEFINITIONS
27341       C0(Z,A)=(Z**2-A)**2*((Z**2+A)**2-24*Z*(Z**2+A)+8*Z**2*(A+6))/Z**4
27342       C1(Z,A)=A**4/(3*Z)
27343       C2(Z,A)=-A**3*(24*Z-A)/(2*Z**2)
27344       C3(Z,A)=A**2*(8*Z**2*(A+6)-24*A*Z+A**2)/Z**3
27345       C4(Z,A)=-A**2*(24*Z**3+8*Z**2*(A+6)-24*A*Z+A**2)/Z**4
27346       C5(Z,A)=Z**3-24*Z**2+8*Z*(A+6)+24*A
27347       C6(Z,A)=0.5*Z**2-12*Z+4*(A+6)
27348       C7(Z,A)=Z/3-8
27349       C8(Z,A)=0.25
27350       FUN(Z,Y,A)=C0(Z,A)*LOG(Y-Z)
27351      &          +C1(Z,A)/Y**3
27352      &          +C2(Z,A)/Y**2
27353      &          +C3(Z,A)/Y
27354      &          +C4(Z,A)*LOG(Y)
27355      &          +C5(Z,A)*Y
27356      &          +C6(Z,A)*Y**2
27357      &          +C7(Z,A)*Y**3
27358      &          +C8(Z,A)*Y**4
27359 C---NOW EVALUATE THE INTEGRAL
27360       HWHIGY=0
27361       IF (A.GT.4) RETURN
27362       XQ=DCMPLX(XP,B)
27363       Z1=XQ+SQRT(XQ**2-A)
27364       Z2=XQ-SQRT(XQ**2-A)
27365       Z3=FUN(Z1,TWO,A)-FUN(Z1,SQRT(A),A)
27366       Z4=FUN(Z2,TWO,A)-FUN(Z2,SQRT(A),A)
27367       HWHIGY=DIMAG((Z3-Z4)/(Z1-Z2))/(8*B)
27368       END
27369 CDECK  ID>, HWHIGZ.
27370 *CMZ :-        -02/05/91  11.18.44  by  Federico Carminati
27371 *-- Author :    Mike Seymour, modified by Stefano Moretti
27372 C-----------------------------------------------------------------------
27373       SUBROUTINE HWHIGZ
27374 C-----------------------------------------------------------------------
27375 C     HIGGS PRODUCTION VIA THE BJORKEN PROCESS: E+E- --> Z(*) --> Z(*)H
27376 C     WHERE ONE OR BOTH OF THE Zs IS OFF-SHELL
27377 C     USES ALGORITHM OF BERENDS AND KLEISS: NUCL.PHYS. B260(1985)32
27378 C
27379 C     MEAN EVWGT = CROSS-SECTION (IN NB) * HIGGS BRANCHING FRACTION
27380 C-----------------------------------------------------------------------
27381       INCLUDE 'herwig65.inc'
27382       DOUBLE PRECISION HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO,EMZ,CVE,CAE,
27383      & POL1,POL2,CE1,CE2,CE3,PMAX,EMZ2,S,B,FACTR,EMH,EMFAC,EMH2,A,XP,
27384      & CV,CA,BRHIGQ,BR,X1,X2,FAC1,FAC2,XPP,XPPSQ,COEF,X,XSQ,PROB,C1,C2,
27385      & CHIGG,PTHETA,SHIGG,C3,PHIMAX,CPHI,SPHI,C2PHI,S2PHI,PCM,ELST
27386       INTEGER IDEC,I,NLOOP,ICMF,IHIG,IZED,IFER,IANT,ID1,ID2,IN1,IN2
27387       EXTERNAL HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO
27388       SAVE CVE,CAE,CE1,CE2,CE3,PMAX,EMZ2,S,EMH,B,FACTR,A,EMH2
27389       EQUIVALENCE (EMZ,RMASS(200))
27390       SAVE ELST
27391       DATA ELST/0/
27392 C---SET UP CONSTANTS
27393       IN1=1
27394       IF (JDAHEP(1,IN1).NE.0) IN1=JDAHEP(1,IN1)
27395       IN2=2
27396       IF (JDAHEP(1,IN2).NE.0) IN2=JDAHEP(1,IN2)
27397       IF (FSTWGT.OR.ELST.NE.PHEP(5,3)) THEN
27398         ELST=PHEP(5,3)
27399         CVE=VFCH(11,1)
27400         CAE=AFCH(11,1)
27401         POL1=1.-EPOLN(3)*PPOLN(3)
27402         POL2=EPOLN(3)-PPOLN(3)
27403         CE1=(POL1*(CVE**2+CAE**2)+POL2*2.*CVE*CAE)
27404         CE2=(POL1*2.*CVE*CAE+POL2*(CVE**2+CAE**2))
27405         IF ((IDHW(IN1).GT.IDHW(IN2).AND.PHEP(3,IN1).LT.ZERO).OR.
27406      &      (IDHW(IN2).GT.IDHW(IN1).AND.PHEP(3,IN2).LT.ZERO)) CE2=-CE2
27407         IF (TPOL) CE3=(CVE**2-CAE**2)
27408         PMAX=4
27409         EMZ2=EMZ**2
27410         S=PHEP(5,3)**2
27411         B=EMZ*GAMZ/S
27412         FACTR=GEV2NB*CE1*(HWUAEM(RMASS(201+IHIGGS)**2)*ENHANC(11))**2
27413      &       /(12.*S*SWEIN*(1.-SWEIN))*B/((1-EMZ2/S)**2+B**2)
27414       ENDIF
27415       IF (.NOT.GENEV) THEN
27416 C---CHOOSE HIGGS MASS, AND CALCULATE EVENT WEIGHT
27417         EVWGT=0D0
27418         EMH=RMASS(201+IHIGGS)
27419         EMFAC=ONE
27420         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
27421         IF (EMH.LE.ZERO .OR. EMH.GT.PHEP(5,3)) RETURN
27422         EMSCA=EMH
27423         EMH2=EMH**2
27424         A=4*EMH2/S
27425         XP=1+(EMH2-EMZ2)/S
27426         EVWGT=FACTR*HWHIGY(A,B,XP)*EMFAC
27427 C---INCLUDE BRANCHING RATIO OF HIGGS
27428         IF(IMSSM.EQ.0)THEN
27429           IDEC=MOD(IPROC,100)
27430           IF (IDEC.GT.0.AND.IDEC.LE.12) EVWGT=EVWGT*BRHIG(IDEC)
27431           IF (IDEC.EQ.0) THEN
27432             BRHIGQ=0
27433             DO 10 I=1,6
27434  10           BRHIGQ=BRHIGQ+BRHIG(I)
27435             EVWGT=EVWGT*BRHIGQ
27436           ENDIF
27437 C Add Z branching fractions
27438           CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,0)
27439           EVWGT=EVWGT*BR
27440           IF (IDEC.EQ.10) THEN
27441             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
27442             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
27443             EVWGT=EVWGT*BR
27444           ELSEIF (IDEC.EQ.11) THEN
27445             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
27446             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
27447             EVWGT=EVWGT*BR
27448           ENDIF
27449         END IF
27450       ELSE
27451 C---GENERATE EVENT
27452         ICMF=NHEP+1
27453         IHIG=NHEP+2
27454         IZED=NHEP+3
27455         IFER=NHEP+4
27456         IANT=NHEP+5
27457         CALL HWVEQU(5,PHEP(1,3),PHEP(1,ICMF))
27458         NHEP=NHEP+5
27459 C---CHOOSE ENERGY FRACTION OF HIGGS
27460         X1=SQRT(A)
27461         X2=1+0.25*A
27462         XP=1+(EMH2-EMZ2)/S
27463         FAC1=ATAN((X1-XP)/B)
27464         FAC2=ATAN((X2-XP)/B)
27465         XPP=MIN(X2,MAX(X1+B,XP))
27466         XPPSQ=XPP**2
27467         NLOOP=0
27468         COEF=1./((12+2*A-12*XPP+XPPSQ)*SQRT(XPPSQ-A))
27469  20       NLOOP=NLOOP+1
27470           IF (NLOOP.GT.NBTRY) THEN
27471             CALL HWWARN('HWHIGZ',101)
27472             GOTO 999
27473           ENDIF
27474           X=XP+B*TAN(HWRUNI(1,FAC1,FAC2))
27475           XSQ=X**2
27476           PROB=COEF*((12+2*A-12*X+XSQ)*SQRT(XSQ-A))
27477           IF (PROB.GT.PMAX) THEN
27478             PMAX=1.1*PROB
27479             CALL HWWARN('HWHIGZ',1)
27480             WRITE (6,21) PMAX
27481  21         FORMAT(7X,'NEW HWHIGZ MAX WEIGHT =',F8.4)
27482           ENDIF
27483         IF (PROB.LT.PMAX*HWRGEN(0)) GOTO 20
27484 C Choose Z decay mode
27485         CALL HWDBOZ(200,IDHW(IFER),IDHW(IANT),CV,CA,BR,0)
27486         C1=CE1*(CV**2+CA**2)
27487         C2=CE2*2.*CV*CA
27488 C---CHOOSE HIGGS DIRECTION
27489 C First polar angle
27490         NLOOP=0
27491         COEF=(XSQ-A)/(8.*(1.-X)+XSQ+A)
27492  30       NLOOP=NLOOP+1
27493           IF (NLOOP.GT.NBTRY) THEN
27494             CALL HWWARN('HWHIGZ',102)
27495             GOTO 999
27496           ENDIF
27497           CHIGG=HWRUNI(2,-ONE, ONE)
27498           PTHETA=1-COEF*CHIGG**2
27499         IF (PTHETA.LT.HWRGEN(1)) GOTO 30
27500         SHIGG=SQRT(1-CHIGG**2)
27501 C Now azimuthal angle
27502         IF (TPOL) THEN
27503            C3=CE3*(CV*2+CA**2)
27504            COEF=COEF*SHIGG**2*C3/C1
27505            PHIMAX=PTHETA+ABS(COEF)
27506   40       CALL HWRAZM(ONE,CPHI,SPHI)
27507            C2PHI=2.*CPHI**2-1.
27508            S2PHI=2.*CPHI*SPHI
27509            PROB=PTHETA-COEF*(C2PHI*COSS+S2PHI*SINS)
27510            IF (PROB.LT.HWRGEN(1)*PHIMAX) GOTO 40
27511         ELSE
27512            CALL HWRAZM(ONE,CPHI,SPHI)
27513         ENDIF
27514 C Construct Higgs and Z momenta
27515         PHEP(5,IHIG)=EMH
27516         PHEP(4,IHIG)=X*PHEP(5,ICMF)/2
27517         PCM=SQRT(PHEP(4,IHIG)**2-EMH2)
27518         PHEP(3,IHIG)=CHIGG*PCM
27519         PHEP(1,IHIG)=SHIGG*PCM*CPHI
27520         PHEP(2,IHIG)=SHIGG*PCM*SPHI
27521         CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,IHIG),PHEP(1,IZED))
27522         CALL HWUMAS(PHEP(1,IZED))
27523 C Choose orientation of Z decay
27524         NLOOP=0
27525         COEF=2.*(C1+ABS(C2))*HWULDO(PHEP(1,IN1),PHEP(1,IZED))
27526      &                      *HWULDO(PHEP(1,IN2),PHEP(1,IZED))/S
27527         IF (TPOL) COEF=COEF*(C1+ABS(C2)+ABS(C3))/(C1+ABS(C2))
27528         PCM=PHEP(5,IZED)/2
27529         PHEP(5,IFER)=0
27530         PHEP(5,IANT)=0
27531  50     NLOOP=NLOOP+1
27532         IF (NLOOP.GT.NBTRY) THEN
27533           CALL HWWARN('HWHIGZ',103)
27534           GOTO 999
27535         ENDIF
27536         CALL HWDTWO(PHEP(1,IZED),PHEP(1,IFER),PHEP(1,IANT),
27537      &              PCM,TWO,.TRUE.)
27538         PROB=C1*(PHEP(4,IFER)*PHEP(4,IANT)-PHEP(3,IFER)*PHEP(3,IANT))
27539      &      +C2*(PHEP(4,IFER)*PHEP(3,IANT)-PHEP(3,IFER)*PHEP(4,IANT))
27540         IF (TPOL) PROB=PROB+C3*
27541      &   (COSS*(PHEP(1,IFER)*PHEP(1,IANT)-PHEP(2,IFER)*PHEP(2,IANT))
27542      &   +SINS*(PHEP(1,IFER)*PHEP(2,IANT)+PHEP(2,IFER)*PHEP(1,IANT)))
27543         IF (PROB.LT.HWRGEN(2)*COEF) GOTO 50
27544 C---SET UP STATUS CODES,
27545         ISTHEP(ICMF)=120
27546         ISTHEP(IHIG)=190
27547         ISTHEP(IZED)=195
27548         ISTHEP(IFER)=113
27549         ISTHEP(IANT)=114
27550 C---COLOR CONNECTIONS,
27551         JMOHEP(1,ICMF)=1
27552         JMOHEP(2,ICMF)=2
27553         JDAHEP(1,ICMF)=IHIG
27554         JDAHEP(2,ICMF)=IZED
27555         JMOHEP(1,IHIG)=ICMF
27556         JMOHEP(1,IZED)=ICMF
27557         JMOHEP(1,IFER)=IZED
27558         JMOHEP(1,IANT)=IZED
27559         JMOHEP(2,IFER)=IANT
27560         JMOHEP(2,IANT)=IFER
27561         JDAHEP(1,IZED)=IFER
27562         JDAHEP(2,IZED)=IANT
27563         JDAHEP(2,IFER)=IANT
27564         JDAHEP(2,IANT)=IFER
27565 C---IDENTITY CODES
27566         IDHW(ICMF)=200
27567         IDHW(IHIG)=201+IHIGGS
27568         IDHW(IZED)=200
27569         IDHEP(ICMF)=IDPDG(IDHW(ICMF))
27570         IDHEP(IHIG)=IDPDG(IDHW(IHIG))
27571         IDHEP(IZED)=IDPDG(IDHW(IZED))
27572         IDHEP(IFER)=IDPDG(IDHW(IFER))
27573         IDHEP(IANT)=IDPDG(IDHW(IANT))
27574       ENDIF
27575  999  RETURN
27576       END
27577 CDECK  ID>, HWHIHH.
27578 *CMZ :-        -25/11/01  17.11.33  by  Stefano Moretti
27579 *-- Author :  Kosuke Odagiri, modified by Stefano Moretti
27580 C-----------------------------------------------------------------------
27581 C...Generate completely differential cross section (EVWGT) in the variable
27582 C...X(I) with I=1 (see below) for the processes IPROC=955,965,975 as
27583 C...described in the HERWIG 6 documentation file.
27584 C
27585 C...First release: 12-NOV-2001 by Stefano Moretti
27586 C
27587 C-----------------------------------------------------------------------
27588       SUBROUTINE HWHIHH
27589 C-----------------------------------------------------------------------
27590 C     PRODUCTION OF MSSM HIGGS PAIRS IN L+L- (L=E,MU)
27591 C-----------------------------------------------------------------------
27592       INCLUDE 'herwig65.inc'
27593       DOUBLE PRECISION HWRGEN, HWUAEM, HCS, RCS, S, PF, QPE,
27594      & FACTR, SN2TH, MZ, MNN(2), MCC, EMSC2, GZ2,
27595      & GHH(4), XWEIN, S2W, X(1), XL(1),
27596      & XU(1), WEIGHT, ECM, RMH1, RMH2, EMH1, EMH2,
27597      & EMHWT1, EMHWT2, EMHHWT, SHAT
27598       INTEGER I, ID1, ID2, IH1, IH2, IH, JH
27599       EXTERNAL HWRGEN, HWUAEM
27600       SAVE HCS,MNN,MCC,EMHHWT,S,SHAT
27601       DOUBLE COMPLEX Z, GZ, A, D, E
27602       PARAMETER (Z = (0.D0,1.D0))
27603       EQUIVALENCE (MZ, RMASS(200))
27604 C...process event.
27605       IF (GENEV) THEN
27606         RCS = HCS*HWRGEN(0)
27607       ELSE
27608         HCS = ZERO
27609         EVWGT = ZERO
27610 C...energy at parton level.
27611         ECM = PBEAM1+PBEAM2
27612         S = ECM*ECM
27613         SHAT = S
27614 C...phase space variables.
27615 C...X(1)=COS(THETA_CM),
27616 C...phase space borders.
27617         XL(1)= -1.
27618         XU(1)= 1.
27619 C...single phase space point.
27620         WEIGHT=1.
27621         DO I=1,1
27622           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
27623           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
27624         END DO
27625 C...final state masses.
27626         IF((MOD(IPROC,10000).EQ.965).OR.
27627      &     (MOD(IPROC,10000).EQ.975))THEN
27628           JH  = IHIGGS-1
27629           ID1 = 205
27630           ID2 = 202 + JH
27631         ELSE IF(MOD(IPROC,10000).EQ.955)THEN
27632           JH  = 4
27633           ID1 = 206
27634           ID2 = 207
27635         END IF
27636         RMH1=RMASS(ID1)
27637         RMH2=RMASS(ID2)
27638         EMH1=RMH1
27639         EMH2=RMH2
27640         EMHWT1=1.
27641         EMHWT2=1.
27642         EMHHWT=EMHWT1*EMHWT2
27643 C...polar angle.
27644         COSTH = X(1)
27645         SN2TH = 0.25D0 - 0.25D0*COSTH**2
27646         EMSCA = EMH1+EMH2
27647         EMSC2 = EMSCA*EMSCA
27648         EVWGT = ZERO
27649         FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT*SN2TH/2.
27650 C...constant weight.
27651         FACTR = FACTR*WEIGHT
27652 C...couplings and propagators.
27653         XWEIN = TWO*SWEIN
27654         S2W   = DSQRT(XWEIN*(TWO-XWEIN))
27655         GZ    = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT
27656         GZ2   = DREAL(DCONJG(GZ)*GZ)
27657 C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-.
27658         GHH(1)= COSBMA
27659         GHH(2)= SINBMA
27660         GHH(3)= ONE
27661         GHH(4)= ONE-XWEIN
27662 C...set to zero all MEs.
27663         DO I=1,2
27664           MNN(I)=ZERO
27665         END DO
27666         MCC=ZERO
27667 C...start subprocesses.
27668         IF((MOD(IPROC,10000).EQ.965).OR.
27669      &     (MOD(IPROC,10000).EQ.975))THEN
27670 c
27671 c   -  +      o  o   o
27672 c  l  l   -> A  h / H
27673 c
27674           DO IH = JH,JH
27675             QPE = SHAT-(EMH1+EMH2)**2
27676             IF (QPE.GT.ZERO) THEN
27677               PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
27678               MNN(IH) =
27679      &          FACTR*PF**3*GHH(IH)**2*(LFCH(11)**2+RFCH(11)**2)/GZ2
27680             ELSE
27681               CONTINUE
27682             END IF
27683           END DO
27684         ELSE IF(MOD(IPROC,10000).EQ.955)THEN
27685 c
27686 c   -  +     +  -
27687 c  l  l  -> H  H
27688 c
27689           IH = JH
27690           QPE = SHAT-(EMH1+EMH2)**2
27691           IF (QPE.GT.ZERO) THEN
27692             PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
27693             A = GHH(IH)/GZ
27694             D = QFCH(11)+A*LFCH(11)
27695             E = QFCH(11)+A*RFCH(11)
27696             MCC=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
27697           ELSE
27698             CONTINUE
27699           END IF
27700         END IF
27701       END IF
27702       HCS = ZERO
27703       IF(MOD(IPROC,10000).EQ.965)THEN
27704         IH1 = 205
27705         IH2 = 203
27706         HCS = HCS + EMHHWT*MNN(1)
27707       ELSE IF(MOD(IPROC,10000).EQ.975)THEN
27708         IH1 = 205
27709         IH2 = 204
27710         HCS = HCS + EMHHWT*MNN(2)
27711       ELSE IF(MOD(IPROC,10000).EQ.955)THEN
27712         IH1 = 206
27713         IH2 = 207
27714         HCS = HCS + EMHHWT*MCC
27715       END IF
27716       IF (GENEV.AND.HCS.GT.RCS) THEN
27717 C...generate event.
27718         IDN(1)=IDHW(1)
27719         IDN(2)=IDHW(2)
27720         IDN(3)=IH1
27721         IDN(4)=IH2
27722         IDCMF=15
27723         XX(1) = ONE
27724         XX(2) = ONE
27725         CALL HWETWO(.TRUE.,.TRUE.)
27726         IF (AZSPIN) THEN
27727           CALL HWVZRO(7,GCOEF)
27728         END IF
27729       END IF
27730       EVWGT = HCS
27731       END
27732 CDECK  ID>, HWHISQ.
27733 *CMZ :-        -30/06/01  18.41.23  by  Stefano Moretti
27734 *-- Author :  Stefano Moretti
27735 C-----------------------------------------------------------------------
27736 C...Generate completely differential cross section (EVWGT) in the variables
27737 C...X(I) with I=1,6 (see below) for the processes from IPROC=3110
27738 C...to IPROC=3298, as described in the HERWIG 6 documentation file.
27739 C...It includes interface to PDFs and takes into account color connections
27740 C...among partons.
27741 C
27742 C...First release: 08-APR-2000 by Stefano Moretti
27743 C...Last modified: 29-JUN-2001 by Stefano Moretti
27744 C
27745 C-----------------------------------------------------------------------
27746       SUBROUTINE HWHISQ
27747 C-----------------------------------------------------------------------
27748 C     PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH B,T-SQUARK PAIRS
27749 C-----------------------------------------------------------------------
27750       INCLUDE 'herwig65.inc'
27751       COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
27752       INTEGER      JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
27753       INTEGER I,J,K,L,M,N
27754       INTEGER IQMIN,IQMAX,IGG,IQQ,JPP
27755       INTEGER NC,FLIP
27756       INTEGER IF1,IF2
27757       INTEGER JHH,IMIX1,IMIX2
27758       INTEGER JSQ,JSQ1,JSQ2
27759       INTEGER IME,JME
27760       DOUBLE PRECISION EMSQ1,EMSQ2,GAMSQ1,GAMSQ2,EMSQQ,EMH,EMHWT
27761       DOUBLE PRECISION GSQ1,GSQ2
27762       DOUBLE PRECISION X(6),XL(6),XU(6)
27763       DOUBLE PRECISION Q4(0:3),Q34(0:3)
27764       DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
27765       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
27766       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
27767       DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
27768       DOUBLE PRECISION GGSQHT,GGSQHU,GGSQHN,QQSQH
27769       DOUBLE PRECISION M2GG(8),M2GGPL(8),M2GGMN(8),M2QQ(8)
27770       DOUBLE PRECISION ALPHA,ALPHAS,EMSC2
27771       DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF
27772       DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
27773       DOUBLE PRECISION VCOL,GCOL,QAUX(0:3)
27774       DOUBLE PRECISION EPS,HCS,RCS,GACT,FACT(8),DIST
27775       DOUBLE PRECISION WEIGHT
27776       SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5
27777       SAVE IME,JSQ1,JSQ2
27778       LOGICAL HWRLOG
27779       EXTERNAL HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2SH,HWETWO,HWRLOG
27780       PARAMETER (EPS=1.D-9)
27781       EQUIVALENCE (NC,NCOLO)
27782 C...process the event.
27783       IF(GENEV)THEN
27784         RCS=HCS*HWRGEN(0)
27785       ELSE
27786         HCS=0.
27787         EVWGT=0.
27788 C...loop over final state flavours.
27789         IME=0
27790         DO I=1,8
27791           M2GG(I)=0.
27792           M2GGPL(I)=0.
27793           M2GGMN(I)=0.
27794           M2QQ(I)=0.
27795           FACT(I)=0.
27796         END DO
27797         DO 2 IF1=IF1MIN,IF1MAX
27798         IF((IF1.GE.407).AND.(IF1.LE.416))GOTO 2
27799         DO 1 IF2=IF2MIN,IF2MAX
27800         IF((IF2.GE.413).AND.(IF2.LE.422))GOTO 1
27801 C...assign squark flavour.
27802         JSQ1=IF1
27803         JSQ2=IF2
27804 C...check charge.
27805         IF((ICHRG(JSQ1)+ICHRG(JSQ2))/3.NE.-ICHRG(201+JHIGGS+1))GOTO 1
27806         IME=IME+1
27807         IF((IME.LE.0).OR.(IME.GT.8)) THEN
27808           CALL HWWARN('HWHISQ',100)
27809           GOTO 999
27810         ENDIF
27811 C...assign final state masses and widths.
27812         EMSQ1=RMASS(JSQ1)
27813         EMSQ2=RMASS(JSQ2)
27814         GAMSQ1=HBAR/RLTIM(JSQ1)
27815         GAMSQ2=HBAR/RLTIM(JSQ2)
27816         EMH=RMASS(201+JHIGGS+1)
27817         EMHWT=1.
27818 C...energy at hadron level.
27819         ECM_MAX=PBEAM1+PBEAM2
27820         S=ECM_MAX*ECM_MAX
27821 C...phase space variables.
27822 C...X(1)=(EMSQQ-EMSQ1-EMSQ2)/(ECM-EMSQ1-EMSQ2-EMH),
27823 C...X(2)=COS(THETA5_CM),X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
27824 C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2),
27825 C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
27826 C...phase space borders.
27827         XL(1)=0.
27828         XU(1)=1.
27829         XL(2)=-1.
27830         XU(2)=1.
27831         XL(3)=-1.
27832         XU(3)=1.
27833         XL(4)=0.
27834         XU(4)=2.*PIFAC
27835         XL(5)=0.
27836         XU(5)=1.
27837         XL(6)=0.
27838         XU(6)=1.
27839 C...single phase space point.
27840  100    CONTINUE
27841         WEIGHT=1.
27842         DO I=1,6
27843           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
27844           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
27845         END DO
27846 C...energy at parton level.
27847         ECM=SQRT(1./(X(5)*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2)
27848      &                                            +1./ECM_MAX**2))
27849         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
27850         SHAT=ECM*ECM
27851         TAU=SHAT/S
27852 C...momentum fractions X1 and X2.
27853         XX(1)=EXP(LOG(TAU)*(1.-X(6)))
27854         XX(2)=TAU/XX(1)
27855 C...three particle kinematics.
27856         EMSQQ=X(1)*(ECM-EMSQ1-EMSQ2-EMH)+EMSQ1+EMSQ2
27857         CT5=X(2)
27858         IF(HWRLOG(HALF))THEN
27859           ST5=+SQRT(1.-CT5*CT5)
27860         ELSE
27861           ST5=-SQRT(1.-CT5*CT5)
27862         END IF
27863         CT4=X(3)
27864         ST4=SQRT(1.-CT4*CT4)
27865         CF4=COS(X(4))
27866         SF4=SIN(X(4))
27867         RQ52=((ECM*ECM-EMH*EMH-EMSQQ*EMSQQ)**2-(2.*EMH*EMSQQ)**2)/
27868      &     (4.*ECM*ECM)
27869         IF(RQ52.LT.0.)THEN
27870           GOTO 100
27871         ELSE
27872           RQ5=SQRT(RQ52)
27873         ENDIF
27874         P5(1)=0.
27875         P5(2)=RQ5*ST5
27876         P5(3)=RQ5*CT5
27877         P5(0)=SQRT(RQ52+EMH*EMH)
27878         DO I=1,3
27879           Q34(I)=-P5(I)
27880         END DO
27881         Q34(0)=SQRT(RQ52+EMSQQ*EMSQQ)
27882         RQ42=((EMSQQ*EMSQQ-EMSQ1*EMSQ1-EMSQ2*EMSQ2)**2
27883      &    -(2.*EMSQ1*EMSQ2)**2)/
27884      &     (4.*EMSQQ*EMSQQ)
27885         IF(RQ42.LT.0.)THEN
27886           GOTO 100
27887         ELSE
27888           RQ4=SQRT(RQ42)
27889         ENDIF
27890         Q4(1)=RQ4*ST4*CF4
27891         Q4(2)=RQ4*ST4*SF4
27892         Q4(3)=RQ4*CT4
27893         Q4(0)=SQRT(RQ42+EMSQ2*EMSQ2)
27894         PQ4=0.
27895         DO I=1,3
27896           PQ4=PQ4+Q34(I)*Q4(I)
27897         END DO
27898         P4(0)=(Q34(0)*Q4(0)+PQ4)/EMSQQ
27899         P3(0)=Q34(0)-P4(0)
27900         DO I=1,3
27901           P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMSQQ)
27902           P3(I)=Q34(I)-P4(I)
27903         END DO
27904 C...incoming partons: all massless.
27905         EMIN=0.
27906 C...initial state momenta in the partonic CM.
27907         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
27908      &         -(2.*EMIN*EMIN)**2)/(4.*SHAT)
27909         PCM=SQRT(PCM2)
27910         P1(0)=SQRT(PCM2+EMIN*EMIN)
27911         P1(1)=0.
27912         P1(2)=0.
27913         P1(3)=PCM
27914         P2(0)=SQRT(PCM2+EMIN*EMIN)
27915         P2(1)=0.
27916         P2(2)=0.
27917         P2(3)=-PCM
27918 C...color structured ME summed/averaged over final/initial spins and colors.
27919         IGG=1
27920         IQQ=1
27921         JPP=(MOD(IPROC,10000)/10-ILBL/10)
27922         IF((JPP.EQ.4).OR.(JPP.EQ.5).OR.(JPP.EQ.6))IQQ=0
27923         IF((JPP.EQ.7).OR.(JPP.EQ.8).OR.(JPP.EQ.9))IGG=0
27924         GSQ1=GAMSQ1*EMSQ1
27925         GSQ2=GAMSQ2*EMSQ2
27926         CALL HWH2SH(ECM,P1,P2,P3,P4,P5,EMSQ1,EMSQ2,EMH,GSQ1,GSQ2,
27927      &              IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
27928         M2GG(IME)=GGSQHN/(8.*CFFAC)
27929         M2GGPL(IME)=GGSQHT/(8.*CFFAC)
27930         M2GGMN(IME)=GGSQHU/(8.*CFFAC)
27931         M2QQ(IME)=QQSQH*(1.-1./CAFAC**2)/4.
27932 C...constant factors: phi along beam and conversion GeV^2->nb.
27933         GACT=2.*PIFAC*GEV2NB
27934 C...Jacobians from X1,X2 to X(5),X(6)
27935         GACT=GACT/S*(-LOG(TAU))*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2)
27936 C...phase space Jacobians, pi's and flux.
27937         GACT=GACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
27938      &      *(ECM-EMSQ1-EMSQ2-EMH)
27939 C...EW and QCD couplings.
27940         EMSCA=EMSQ1+EMSQ2+EMH
27941         EMSC2=EMSCA*EMSCA
27942         ALPHA=HWUAEM(EMSC2)
27943         ALPHAS=HWUALF(1,EMSCA)
27944         GACT=GACT*4.*PIFAC*ALPHA/SWEIN
27945         GACT=GACT*16.*PIFAC**2*ALPHAS**2
27946 C...enhancement factor for MSSM.
27947         JHH=JHIGGS
27948         IF(JHIGGS.EQ.5)JHH=4
27949         JSQ=JSQ1-400
27950         IF(JSQ1.GT.412)JSQ=JSQ1-412
27951         IMIX1=1
27952         IMIX2=1
27953         IF(JSQ1.GT.412)IMIX1=2
27954         IF(JSQ2.GT.418)IMIX2=2
27955         SENHNC(JSQ)=GHSQSS(JHH,JSQ,IMIX1,IMIX2)
27956         GACT=GACT*SENHNC(JSQ)*SENHNC(JSQ)
27957 C...Higgs resonance.
27958         GACT=GACT*EMHWT
27959 C...constant weight.
27960         GACT=GACT*WEIGHT
27961 C...collects it.
27962         FACT(IME)=GACT
27963  1      CONTINUE
27964  2      CONTINUE
27965       END IF
27966 C...set up flavours in final state.
27967       FLIP=0
27968 C...set up PDFs.
27969       HCS=0.
27970       CALL HWSGEN(.FALSE.)
27971       IQMAX=13
27972       IF(MOD(IPROC,10000)-ILBL.GE.70)IQMAX=12
27973       IQMIN=1
27974       IF(MOD(IPROC,10000)-ILBL.GE.40)IQMIN=13
27975       IF(MOD(IPROC,10000)-ILBL.GE.70)IQMIN=1
27976       DO 3 JME=1,IME
27977       IF((M2GGPL(JME)+M2GGMN(JME)).EQ.0.)GOTO 3
27978       DO I=IQMIN,IQMAX
27979         IF(DISF(I,1).LT.EPS)THEN
27980           GOTO 200
27981         END IF
27982         K=I/7
27983         L=+1-2*K
27984         IF(I.EQ.13)L=0
27985         J=I+L*6
27986         IF(DISF(J,2).LT.EPS)THEN
27987           GOTO 200
27988         END IF
27989         DIST=DISF(I,1)*DISF(J,2)*S
27990         IF(I.LT.13)THEN
27991 C...set up color connections: qq-scattering.
27992           IF(J.EQ.I+6)THEN
27993             HCS=HCS+M2QQ(JME)*DIST*FACT(JME)
27994             IF(GENEV.AND.HCS.GT.RCS)THEN
27995               CONTINUE
27996               CALL HWHQCP(JSQ1,JSQ2,2413, 4)
27997               GOTO 9
27998             END IF
27999           ELSE IF(I.EQ.J+6)THEN
28000             HCS=HCS+M2QQ(JME)*DIST*FACT(JME)
28001             IF(GENEV.AND.HCS.GT.RCS)THEN
28002               FLIP=1
28003               CALL HWHQCP(JSQ2,JSQ1,3142,12)
28004               GOTO 9
28005             END IF
28006           END IF
28007         ELSE
28008 C...set up color connections: gg-scattering.
28009           HCS=HCS
28010      &   +(M2GGPL(JME)-M2GG(JME)*M2GGPL(JME)
28011      &   /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
28012           IF(GENEV.AND.HCS.GT.RCS) THEN
28013             CALL HWHQCP(JSQ1,JSQ2,2413,27)
28014             GOTO 9
28015           ENDIF
28016           HCS=HCS
28017      &   +(M2GGMN(JME)-M2GG(JME)*M2GGMN(JME)
28018      &   /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
28019           IF(GENEV.AND.HCS.GT.RCS) THEN
28020             CALL HWHQCP(JSQ1,JSQ2,4123,28)
28021             GOTO 9
28022           ENDIF
28023         END IF
28024  200    CONTINUE
28025       END DO
28026  3    CONTINUE
28027       EVWGT=HCS
28028       RETURN
28029 C...generate event.
28030     9 IDN(1)=I
28031       IDN(2)=J
28032       IDN(5)=JH
28033 C...incoming partons: now massive.
28034       EMIN1=RMASS(IDN(1))
28035       EMIN2=RMASS(IDN(2))
28036 C...redo initial state momenta in the partonic CM.
28037       PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
28038      &       -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
28039       PCM=SQRT(PCM2)
28040       P1(0)=SQRT(PCM2+EMIN1*EMIN1)
28041       P1(1)=0.
28042       P1(2)=0.
28043       P1(3)=PCM
28044       P2(0)=SQRT(PCM2+EMIN2*EMIN2)
28045       P2(1)=0.
28046       P2(2)=0.
28047       P2(3)=-PCM
28048 C...randomly rotate final state momenta around beam axis.
28049       PHI=2.*PIFAC*HWRGEN(0)
28050       CPHI=COS(PHI)
28051       SPHI=SIN(PHI)
28052       ROT(1,1)=+CPHI
28053       ROT(1,2)=+SPHI
28054       ROT(1,3)=0.
28055       ROT(2,1)=-SPHI
28056       ROT(2,2)=+CPHI
28057       ROT(2,3)=0.
28058       ROT(3,1)=0.
28059       ROT(3,2)=0.
28060       ROT(3,3)=1.
28061       DO L=1,3
28062         DO M=1,3
28063           QAUX(M)=0.
28064           DO N=1,3
28065             IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
28066             IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
28067             IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
28068           END DO
28069         END DO
28070         DO M=1,3
28071           IF(L.EQ.1)P3(M)=QAUX(M)
28072           IF(L.EQ.2)P4(M)=QAUX(M)
28073           IF(L.EQ.3)P5(M)=QAUX(M)
28074         END DO
28075       END DO
28076 C...use HWETWO only to set up status and IDs of (s)quarks.
28077       COSTH=0.
28078       IDCMF=15
28079       CALL HWETWO(.TRUE.,.TRUE.)
28080 C...do real incoming, outgoing momenta in the lab frame.
28081       VCOL=(XX(1)-XX(2))/(XX(1)+XX(2))
28082       GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2))
28083       DO M=NHEP-4,NHEP+1
28084         IF(M.EQ.NHEP-2)GO TO 888
28085         DO N=0,3
28086           IF(M.EQ.NHEP-4)QAUX(N)=P1(N)
28087           IF(M.EQ.NHEP-3)QAUX(N)=P2(N)
28088           IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP
28089           IF(M.EQ.NHEP  )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP
28090           IF(M.EQ.NHEP+1)QAUX(N)=P5(N)
28091         END DO
28092 C...perform boost.
28093         PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3))
28094         PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0))
28095         PHEP(2,M)=QAUX(2)
28096         PHEP(1,M)=QAUX(1)
28097  888    CONTINUE
28098       END DO
28099 C...needs to set all final state masses.
28100       PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2
28101      &                       -PHEP(3,NHEP-1)**2
28102      &                       -PHEP(2,NHEP-1)**2
28103      &                       -PHEP(1,NHEP-1)**2))
28104       PHEP(5,NHEP  )=SQRT(ABS(PHEP(4,NHEP  )**2
28105      &                       -PHEP(3,NHEP  )**2
28106      &                       -PHEP(2,NHEP  )**2
28107      &                       -PHEP(1,NHEP  )**2))
28108       PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
28109      &                       -PHEP(3,NHEP+1)**2
28110      &                       -PHEP(2,NHEP+1)**2
28111      &                       -PHEP(1,NHEP+1)**2))
28112 C...sets CMF.
28113       DO I=1,4
28114         PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3)
28115       END DO
28116       PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2
28117      &                       -PHEP(3,NHEP-2)**2
28118      &                       -PHEP(2,NHEP-2)**2
28119      &                       -PHEP(1,NHEP-2)**2))
28120 C...status and IDs for Higgs.
28121       ISTHEP(NHEP+1)=114
28122       IDHW(NHEP+1)=IDN(5)
28123       IDHEP(NHEP+1)=IDPDG(IDN(5))
28124 C...Higgs colour (self-)connections.
28125       JMOHEP(1,NHEP+1)=NHEP-2
28126       JMOHEP(2,NHEP+1)=NHEP+1
28127       JDAHEP(2,NHEP+1)=NHEP+1
28128       JDAHEP(2,NHEP-2)=NHEP+1
28129       NHEP=NHEP+1
28130       IF(AZSPIN)THEN
28131 C...set to zero the coefficients of the spin density matrices.
28132         CALL HWVZRO(7,GCOEF)
28133       END IF
28134  999  RETURN
28135       END
28136 CDECK  ID>, HWHPH2.
28137 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
28138 *-- Author :    Ian Knowles
28139 C-----------------------------------------------------------------------
28140       SUBROUTINE HWHPH2
28141 C-----------------------------------------------------------------------
28142 C     QQD direct photon pair production: mean EVWGT = sigma in nb
28143 C-----------------------------------------------------------------------
28144       INCLUDE 'herwig65.inc'
28145       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
28146      & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,RS,S,T,U,CSTU,TQSQ,
28147      & DSTU,HCS
28148       INTEGER ID,ID1,ID2
28149       EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
28150       SAVE HCS,CSTU,DSTU,FACT
28151       PARAMETER (EPS=1.D-9)
28152       IF (GENEV) THEN
28153         RCS=HCS*HWRGEN(0)
28154       ELSE
28155         EVWGT=0.
28156         CALL HWRPOW(ET,EJ)
28157         KK=ET/PHEP(5,3)
28158         KK2=KK**2
28159         IF (KK.GE.ONE) RETURN
28160         YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
28161         YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
28162         IF (YJ1INF.GE.YJ1SUP) RETURN
28163         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
28164         YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
28165         YJ2SUP=MIN( YJMAX ,  LOG(2./KK-Z1) )
28166         IF (YJ2INF.GE.YJ2SUP) RETURN
28167         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
28168         XX(1)=0.5*(Z1+Z2)*KK
28169         IF (XX(1).GE.ONE) RETURN
28170         XX(2)=XX(1)/(Z1*Z2)
28171         IF (XX(2).GE.ONE) RETURN
28172         COSTH=(Z1-Z2)/(Z1+Z2)
28173         S=XX(1)*XX(2)*PHEP(5,3)**2
28174         RS=0.5*SQRT(S)
28175         T=-0.5*S*(1.-COSTH)
28176         U=-S-T
28177         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28178         FACT=GEV2NB*PIFAC*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
28179      &      *(ALPHEM/S)**2
28180         CALL HWSGEN(.FALSE.)
28181         CSTU=2.*(U/T+T/U)/CAFAC
28182         IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
28183            TQSQ=0.
28184            DO 10 ID=1,6
28185   10       IF (RMASS(ID).LT.RS) TQSQ=TQSQ+QFCH(ID)**2
28186            DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
28187      &         /64.*(HWUALF(1,EMSCA)*TQSQ/PIFAC)**2
28188         ELSE
28189            DSTU=0
28190         ENDIF
28191       ENDIF
28192       HCS=0.
28193       DO 30 ID=1,6
28194       FACTR=FACT*CSTU*QFCH(ID)**4
28195 C q+qbar ---> gamma+gamma
28196       ID1=ID
28197       ID2=ID+6
28198       IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 20
28199       HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
28200       IF (GENEV.AND.HCS.GT.RCS) THEN
28201         CALL HWHQCP(59,59,2134,61)
28202         GOTO 99
28203       ENDIF
28204 C qbar+q ---> gamma+gamma
28205   20  ID1=ID+6
28206       ID2=ID
28207       IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
28208       HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
28209       IF (GENEV.AND.HCS.GT.RCS) THEN
28210         CALL HWHQCP(59,59,2134,62)
28211         GOTO 99
28212       ENDIF
28213   30  CONTINUE
28214 C g+g ---> gamma+gamma
28215       ID1=13
28216       ID2=13
28217       HCS=HCS+DSTU
28218       IF (GENEV.AND.HCS.GT.RCS) THEN
28219         CALL HWHQCP(59,59,2134,63)
28220         GOTO 99
28221       ENDIF
28222       EVWGT=HCS
28223       RETURN
28224 C Generate event
28225   99  IDN(1)=ID1
28226       IDN(2)=ID2
28227       IDCMF=15
28228       CALL HWETWO(.TRUE.,.TRUE.)
28229       END
28230 CDECK  ID>, HWHPHO.
28231 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
28232 *-- Author :    Bryan Webber
28233 C-----------------------------------------------------------------------
28234       SUBROUTINE HWHPHO
28235 C-----------------------------------------------------------------------
28236 C     QCD DIRECT PHOTON + JET PRODUCTION: MEAN EVWGT = SIGMA IN NB
28237 C-----------------------------------------------------------------------
28238       INCLUDE 'herwig65.inc'
28239       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
28240      & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,FACTF,RS,S,T,U,CF,
28241      & AF,CSTU,CTSU,CUST,DSTU,HCS,TQCH
28242       INTEGER ID,ID1,ID2
28243       EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
28244       SAVE HCS,FACT,CSTU,CTSU,CUST,DSTU
28245       PARAMETER (EPS=1.D-9)
28246       IF (GENEV) THEN
28247         RCS=HCS*HWRGEN(0)
28248       ELSE
28249         EVWGT=0.
28250         CALL HWRPOW(ET,EJ)
28251         KK=ET/PHEP(5,3)
28252         KK2=KK**2
28253         IF (KK.GE.ONE) RETURN
28254         YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
28255         YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
28256         IF (YJ1INF.GE.YJ1SUP) RETURN
28257         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
28258         YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
28259         YJ2SUP=MIN( YJMAX ,  LOG(2./KK-Z1) )
28260         IF (YJ2INF.GE.YJ2SUP) RETURN
28261         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
28262         XX(1)=0.5*(Z1+Z2)*KK
28263         IF (XX(1).GE.ONE) RETURN
28264         XX(2)=XX(1)/(Z1*Z2)
28265         IF (XX(2).GE.ONE) RETURN
28266         COSTH=(Z1-Z2)/(Z1+Z2)
28267         S=XX(1)*XX(2)*PHEP(5,3)**2
28268         RS=0.5*SQRT(S)
28269         T=-0.5*S*(1.-COSTH)
28270         U=-S-T
28271 C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
28272         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28273         FACT=GEV2NB*PIFAC*0.5*ET*EJ*ALPHEM
28274      &      *HWUALF(1,EMSCA)*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)/S**2
28275         CALL HWSGEN(.FALSE.)
28276 C
28277         CF=2.*CFFAC/CAFAC
28278         AF=-1./CAFAC
28279         CSTU=CF*(U/T+T/U)
28280         CTSU=AF*(U/S+S/U)
28281         CUST=AF*(T/S+S/T)
28282         IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
28283            TQCH=0.
28284            DO 10 ID=1,6
28285   10       IF (RMASS(ID).LT.RS) TQCH=TQCH+QFCH(ID)
28286            DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
28287      &         *5./768.*(HWUALF(1,EMSCA)*TQCH/PIFAC)**2
28288         ELSE
28289            DSTU=0
28290         ENDIF
28291       ENDIF
28292 C
28293       HCS=0.
28294       DO 30 ID=1,6
28295       FACTR=FACT*QFCH(ID)**2
28296 C---QUARK FIRST
28297       ID1=ID
28298       IF (DISF(ID1,1).LT.EPS) GOTO 20
28299       ID2=ID1+6
28300       HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
28301       IF (GENEV.AND.HCS.GT.RCS) THEN
28302         CALL HWHQCP( 13, 59,2314,41)
28303         GOTO 9
28304       ENDIF
28305       ID2=13
28306       HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
28307       IF (GENEV.AND.HCS.GT.RCS) THEN
28308         CALL HWHQCP(ID1, 59,3124,42)
28309         GOTO 9
28310       ENDIF
28311 C---QBAR FIRST
28312   20  ID1=ID+6
28313       IF (DISF(ID1,1).LT.EPS) GOTO 30
28314       ID2=ID
28315       HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
28316       IF (GENEV.AND.HCS.GT.RCS) THEN
28317         CALL HWHQCP( 13, 59,3124,43)
28318         GOTO 9
28319       ENDIF
28320       ID2=13
28321       HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
28322       IF (GENEV.AND.HCS.GT.RCS) THEN
28323         CALL HWHQCP(ID1, 59,2314,44)
28324         GOTO 9
28325       ENDIF
28326   30  CONTINUE
28327 C---GLUON FIRST
28328       ID1=13
28329       FACTF=FACT*CUST*DISF(ID1,1)
28330       DO 50 ID=1,6
28331       FACTR=FACTF*QFCH(ID)**2
28332       ID2=ID
28333       IF (DISF(ID2,2).LT.EPS) GOTO 40
28334       HCS=HCS+FACTR*DISF(ID2,2)
28335       IF (GENEV.AND.HCS.GT.RCS) THEN
28336         CALL HWHQCP(ID2, 59,2314,45)
28337         GOTO 9
28338       ENDIF
28339   40  ID2=ID+6
28340       IF (DISF(ID2,2).LT.EPS) GOTO 50
28341       HCS=HCS+FACTR*DISF(ID2,2)
28342       IF (GENEV.AND.HCS.GT.RCS) THEN
28343         CALL HWHQCP(ID2, 59,3124,46)
28344         GOTO 9
28345       ENDIF
28346   50  CONTINUE
28347 C g+g ---> g+gamma
28348       ID2=13
28349       HCS=HCS+DSTU
28350       IF (GENEV.AND.HCS.GT.RCS) THEN
28351         CALL HWHQCP( 13, 59,2314,47)
28352         GOTO 9
28353       ENDIF
28354       EVWGT=HCS
28355       RETURN
28356 C---GENERATE EVENT
28357     9 IDN(1)=ID1
28358       IDN(2)=ID2
28359       IDCMF=15
28360       CALL HWETWO(.TRUE.,.TRUE.)
28361       END
28362 CDECK  ID>, HWHPPB.
28363 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
28364 *-- Author :    Ian Knowles
28365 C-----------------------------------------------------------------------
28366       FUNCTION HWHPPB(S,T,U)
28367 C-----------------------------------------------------------------------
28368 C     Quark box diagram contribution to photon/gluon scattering
28369 C     Internal quark mass neglected: m_q << U,T,S
28370 C-----------------------------------------------------------------------
28371       IMPLICIT NONE
28372       DOUBLE PRECISION HWHPPB,S,T,U,S2,T2,U2,PI2,ALNTU,ALNST,ALNSU
28373       PI2=ACOS(-1.D0)**2
28374       S2=S**2
28375       T2=T**2
28376       U2=U**2
28377       ALNTU=LOG(T/U)
28378       ALNST=LOG(-S/T)
28379       ALNSU=ALNST+ALNTU
28380       HWHPPB=5.*4.
28381      & +((2.*S2+2.*(U2-T2)*ALNTU+(T2+U2)*(ALNTU**2+PI2))/S2)**2
28382      & +((2.*U2+2.*(T2-S2)*ALNST+(T2+S2)* ALNST**2     )/U2)**2
28383      & +((2.*T2+2.*(U2-S2)*ALNSU+(U2+S2)* ALNSU**2     )/T2)**2
28384      & +4.*PI2*(((T2-S2+(T2+S2)*ALNST)/U2)**2
28385      &         +((U2-S2+(U2+S2)*ALNSU)/T2)**2)
28386       END
28387 CDECK  ID>, HWHPPE.
28388 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
28389 *-- Author :    Ian Knowles
28390 C-----------------------------------------------------------------------
28391       SUBROUTINE HWHPPE
28392 C-----------------------------------------------------------------------
28393 C     point-like photon/QCD heavy flavour single excitation, using exact
28394 C     massive lightcone kinematics, mean EVWGT = sigma in nb.
28395 C-----------------------------------------------------------------------
28396       INCLUDE 'herwig65.inc'
28397       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,
28398      & PT,PJ,PT2,PTM,EXY,T,CC,EXY2,S,U,C,SIGE,HCS,RCS
28399       INTEGER IQ1,IQ2,ID1,ID2,IHAD1,IHAD2
28400       EXTERNAL HWRGEN,HWRUNI,HWUALF
28401       SAVE PP1,PP2,IQ1,IQ2,QM2,FACTR,SIGE,HCS
28402       PARAMETER (EPS=1.E-9)
28403       IHAD1=1
28404       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28405       IHAD2=2
28406       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28407       IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
28408          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28409          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28410          XX(1)=1.
28411          IQ1=MOD(IPROC,100)
28412          IQ2=IQ1+6
28413          QM2=RMASS(IQ1)**2
28414          FACTR=GEV2NB*(YJMAX-YJMIN)*4.*PIFAC*CFFAC*PP1
28415      &        *ALPHEM*QFCH(IQ1)**2
28416       ENDIF
28417       IF (GENEV) THEN
28418          RCS=HCS*HWRGEN(0)
28419       ELSE
28420          EVWGT=0.
28421          CALL HWRPOW(PT,PJ)
28422          PT2=PT**2
28423          PTM=SQRT(PT2+QM2)
28424          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28425          T=-PP1*PT/EXY
28426          CC=T**2-4.*QM2*(PT2+T)
28427          IF (CC.LT.ZERO) RETURN
28428          EXY2=(2.*PT2+T-SQRT(CC))*PP1/(2.*T*PTM)
28429          IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
28430          XX(2)=(PT/EXY+PTM/EXY2)/PP2
28431          IF (XX(2).GT.ONE) RETURN
28432 C define: S=Shat-M**2, T=That ,U=Uhat-M**2 (2p.Q, -2p.g, -2p.Q')
28433          S=XX(2)*PP1*PP2
28434          U=-S-T
28435          COSTH=(1.+QM2/S)*(T-U)/S-QM2/S
28436 C Set hard process scale (Approx ET-jet)
28437          EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28438          C=QM2*T/(U*S)
28439          SIGE=-FACTR*PT*PJ*HWUALF(1,EMSCA)*(S/U+U/S+4.*C*(1.-C))
28440      &       /(S**2*EXY2*PTM*(1-QM2/(XX(2)*PP2*EXY2)**2))
28441          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28442       ENDIF
28443       HCS=0.
28444       ID1=59
28445 C photon+Q ---> g+Q
28446       ID2=IQ1
28447       IF (DISF(ID2,2).LT.EPS) GOTO 10
28448       HCS=HCS+SIGE*DISF(ID2,2)
28449       IF (GENEV.AND.HCS.GT.RCS) THEN
28450         CALL HWHQCP(13,ID2,1423,51)
28451         GOTO 99
28452       ENDIF
28453 C photon+Qbar ---> g+Qbar
28454   10  ID2=IQ2
28455       IF (DISF(ID2,2).LT.EPS) GOTO 20
28456       HCS=HCS+SIGE*DISF(ID2,2)
28457       IF (GENEV.AND.HCS.GT.RCS) THEN
28458         CALL HWHQCP(13,ID2,1342,52)
28459         GOTO 99
28460       ENDIF
28461   20  EVWGT=HCS
28462       RETURN
28463 C Generate event
28464   99  IDN(1)=ID1
28465       IDN(2)=ID2
28466       IDCMF=15
28467       CALL HWETWO(.TRUE.,.TRUE.)
28468       END
28469 CDECK  ID>, HWHPPH.
28470 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
28471 *-- Author :    Ian Knowles
28472 C-----------------------------------------------------------------------
28473       SUBROUTINE HWHPPH
28474 C-----------------------------------------------------------------------
28475 C     Point-like photon/gluon heavy flavour pair production, with
28476 C     exact lightcone massive kinematics, mean EVWGT = sigma in nb.
28477 C-----------------------------------------------------------------------
28478       INCLUDE 'herwig65.inc'
28479       DOUBLE PRECISION HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,ET,EJ,ET2,
28480      & EXY,EXY2,S,T,U,C
28481       INTEGER IQ1,IHAD1,IHAD2
28482       EXTERNAL HWRUNI,HWUALF
28483       SAVE PP1,PP2,IQ1,QM2,FACTR
28484       PARAMETER (EPS=1.E-9)
28485       IHAD1=1
28486       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28487       IHAD2=2
28488       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28489       IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
28490          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28491          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28492          XX(1)=1.
28493          IQ1=MOD(IPROC,100)
28494          QM2=RMASS(IQ1)**2
28495          IHPRO=53
28496          FACTR=-GEV2NB*(YJMAX-YJMIN)*.5*PIFAC*ALPHEM*QFCH(IQ1)**2
28497       ENDIF
28498       IF (GENEV) THEN
28499 C Generate event
28500          IDN(1)=59
28501          IDN(2)=13
28502          IDN(3)=IQ1
28503          IDN(4)=IQ1+6
28504          ICO(1)=1
28505          ICO(2)=4
28506          ICO(3)=2
28507          ICO(4)=3
28508          IDCMF=15
28509          CALL HWETWO(.TRUE.,.TRUE.)
28510       ELSE
28511 C Select kinematics
28512          EVWGT=0.
28513          CALL HWRPOW(ET,EJ)
28514          ET2=ET**2
28515          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28516          EXY2=2.*PP1/ET-EXY
28517          IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
28518          XX(2)=.5*ET*(1./EXY+1./EXY2)/PP2
28519          IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
28520          S=XX(2)*PP1*PP2
28521          IF (S.LT.ET2) RETURN
28522 C define: S=Shat, T=That-M**2, U=Uhat-M**2 (2p.g, -2p.Q, -2p.QBar)
28523          T=-.5*PP1*ET/EXY
28524          U=-S-T
28525          COSTH=(T-U)/(S*SQRT(1.-4.*QM2/S))
28526          EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28527          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28528 C photon+g ---> Q+Qbar
28529          IF (DISF(13,2).LT.EPS) THEN
28530             EVWGT=0.
28531          ELSE
28532             C=QM2*S/(U*T)
28533             EVWGT=FACTR*EJ*ET*HWUALF(1,EMSCA)
28534      &           *DISF(13,2)*(T/U+U/T+4.*C*(1.-C))/(S*T)
28535          ENDIF
28536       ENDIF
28537       END
28538 CDECK  ID>, HWHPPM.
28539 *CMZ :-        -09/12/93  15.50.26  by  Mike Seymour
28540 *-- Author :    Ian Knowles & Mike Seymour
28541 C-----------------------------------------------------------------------
28542       SUBROUTINE HWHPPM
28543 C-----------------------------------------------------------------------
28544 C     Point-like photon/QCD direct meson production
28545 C     See M. Benayoun, et al., Nucl. Phys. B282 (1987) 653 for details.
28546 C     mean EVWGT = sigma in nb
28547 C-----------------------------------------------------------------------
28548       INCLUDE 'herwig65.inc'
28549       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,ET,EJ,EXY,EXY2,
28550      & FACT,FACTR,S,T,U,REDS,DELT(3,3),C1STU,C3STU,HCS,RCS,CMIX,SMIX,
28551      & C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1,FPI2,FETA2(3),FETAP2(3),
28552      7 FRHO2,FPHI2(3),FOMEG2(3)
28553       INTEGER MNAME(3,3,2),N4(3),I,J,ID2,ID4,I2,I4,M1,M2,IHAD1,IHAD2
28554       LOGICAL SPIN0,SPIN1
28555       EXTERNAL HWRGEN,HWRUNI,HWUALF
28556       SAVE FPI2,FETA2,FETAP2,FRHO2,FPHI2,FOMEG2,HCS,REDS,FACT,DELT,
28557      & C1STU,C3STU
28558       PARAMETER (EPS=1.D-20)
28559       SAVE MNAME,N4,SPIN0,SPIN1,C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1
28560       DATA MNAME/21,38,42,30,21,34,50,46,0,23,39,43,31,23,35,51,47,0/
28561       DATA N4,SPIN0,SPIN1/3,3,2,.TRUE.,.TRUE./
28562       DATA C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1
28563      &     /1.D0,3*0.093D0,3*0.107D0/
28564       IF (FSTWGT) THEN
28565          FPI2=FPI**2
28566          CMIX=COS(ETAMIX*PIFAC/180.D0)
28567          SMIX=SIN(ETAMIX*PIFAC/180.D0)
28568          FETA2(1) =(+CMIX*FETA8/SQRT(TWO)-SMIX*FETA1)**2/THREE
28569          FETA2(2) =FETA2(1)
28570          FETA2(3) =(-CMIX*FETA8*SQRT(TWO)-SMIX*FETA1)**2/THREE
28571          FETAP2(1)=(+SMIX*FETA8/SQRT(TWO)+CMIX*FETA1)**2/THREE
28572          FETAP2(2)=FETAP2(1)
28573          FETAP2(3)=(-SMIX*FETA8*SQRT(TWO)+CMIX*FETA1)**2/THREE
28574          FRHO2=FRHO**2
28575          CMIX=COS(PHIMIX*PIFAC/180.D0)
28576          SMIX=SIN(PHIMIX*PIFAC/180.D0)
28577          FPHI2(1) =(+CMIX*FPHI8/SQRT(TWO)-SMIX*FPHI1)**2/THREE
28578          FPHI2(2) =FPHI2(1)
28579          FPHI2(3) =(-CMIX*FPHI8*SQRT(TWO)-SMIX*FPHI1)**2/THREE
28580          FOMEG2(1)=(+SMIX*FPHI8/SQRT(TWO)+CMIX*FPHI1)**2/THREE
28581          FOMEG2(2)=FOMEG2(1)
28582          FOMEG2(3)=(-SMIX*FPHI8*SQRT(TWO)+CMIX*FPHI1)**2/THREE
28583       ENDIF
28584       SPIN0=.NOT.(MOD(IPROC/10,10).EQ.2)
28585       SPIN1=.NOT.(MOD(IPROC/10,10).EQ.1)
28586       IF (GENEV) THEN
28587          RCS=HCS*HWRGEN(0)
28588       ELSE
28589          EVWGT=ZERO
28590          IHAD1=1
28591          IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28592          IHAD2=2
28593          IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28594          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28595          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28596          XX(1)=ONE
28597          CALL HWRPOW(ET,EJ)
28598          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28599          EXY2=TWO*PP1/ET-EXY
28600          IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28601          XX(2)=PP1/(PP2*EXY*EXY2)
28602          IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28603          S=XX(2)*PP1*PP2
28604          REDS=SQRT(S-ET*SQRT(S))
28605          T=-HALF*PP1*ET/EXY
28606          U=-S-T
28607          COSTH=(T-U)/S
28608 C Set EMSCA to hard process scale (Approx ET-jet)
28609          EMSCA=SQRT(TWO*S*T*U/(S*S+T*T+U*U))
28610          FACT=-GEV2NB*ET*EJ*(YJMAX-YJMIN)*ALPHEM*CFFAC
28611      &       *(HWUALF(1,EMSCA)*PIFAC*C1WVFN)**2*32.D0/(THREE*S*T)
28612          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28613          DO 10 I=1,3
28614          DO 10 J=1,3
28615  10      DELT(I,J)=(QFCH(I)*U+QFCH(J)*S)**2
28616          C1STU=-(S**2+U**2)/(T*S**2*U**2)
28617          C3STU=-8.D0*T/(S**2*U**2)
28618       ENDIF
28619       HCS=ZERO
28620       DO 50 I2=1,3
28621 C Quark initiated processes
28622       ID2=I2
28623       IF (DISF(ID2,2).LT.EPS) GOTO 30
28624       DO 20 ID4=1,N4(I2)
28625       M1=MNAME(ID2,ID4,1)
28626       FACTR=FACT*DELT(ID2,ID4)*DISF(ID2,2)
28627       IF (ID2.EQ.ID4) FACTR=HALF*FACTR
28628       IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
28629 C  photon+q --> meson_0+q'
28630          HCS=HCS+HALF*FACTR*C1STU*FPI2
28631          IF (GENEV.AND.HCS.GT.RCS) THEN
28632            CALL HWHQCP(M1,ID4,1432,71)
28633            GOTO 99
28634          ENDIF
28635       ENDIF
28636       M2=MNAME(ID2,ID4,2)
28637       IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
28638 C  photon+q --> meson_L+q'
28639          HCS=HCS+FACTR*C1STU*FRHO2
28640          IF (GENEV.AND.HCS.GT.RCS) THEN
28641            CALL HWHQCP(M2,ID4,1432,72)
28642            GOTO 99
28643          ENDIF
28644 C  photon+q --> meson_T+q'
28645          HCS=HCS+FACTR*C3STU*FRHO2
28646          IF (GENEV.AND.HCS.GT.RCS) THEN
28647            CALL HWHQCP(M2,ID4,1432,73)
28648            GOTO 99
28649          ENDIF
28650       ENDIF
28651   20  CONTINUE
28652       FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
28653       IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
28654 C  photon+q -->eta+q
28655          HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
28656          IF (GENEV.AND.HCS.GT.RCS) THEN
28657            CALL HWHQCP(22,ID2,1432,71)
28658            GOTO 99
28659          ENDIF
28660       ENDIF
28661       IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
28662 C  photon+q -->eta'+q
28663          HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
28664          IF (GENEV.AND.HCS.GT.RCS) THEN
28665            CALL HWHQCP(25,ID2,1432,71)
28666            GOTO 99
28667          ENDIF
28668       ENDIF
28669       IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
28670 C  photon+q -->phi_L+q
28671          HCS=HCS+FACTR*C1STU*FPHI2(I2)
28672          IF (GENEV.AND.HCS.GT.RCS) THEN
28673            CALL HWHQCP(56,ID2,1432,72)
28674            GOTO 99
28675          ENDIF
28676 C  photon+q -->phi_T+q
28677          HCS=HCS+FACTR*C3STU*FPHI2(I2)
28678          IF (GENEV.AND.HCS.GT.RCS) THEN
28679            CALL HWHQCP(56,ID2,1432,73)
28680            GOTO 99
28681          ENDIF
28682       ENDIF
28683       IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
28684 C  photon+q -->omega_L+q
28685          HCS=HCS+FACTR*C1STU*FOMEG2(I2)
28686          IF (GENEV.AND.HCS.GT.RCS) THEN
28687            CALL HWHQCP(24,ID2,1432,72)
28688            GOTO 99
28689          ENDIF
28690 C  photon+q -->omega_T+q
28691          HCS=HCS+FACTR*C3STU*FOMEG2(I2)
28692          IF (GENEV.AND.HCS.GT.RCS) THEN
28693            CALL HWHQCP(24,ID2,1432,73)
28694            GOTO 99
28695          ENDIF
28696       ENDIF
28697 C Anti-quark initiated processes
28698   30  ID2=I2+6
28699       IF (DISF(ID2,2).LT.EPS) GOTO 50
28700       DO 40 I4=1,N4(I2)
28701       ID4=I4+6
28702       FACTR=FACT*DELT(I2,I4)*DISF(ID2,2)
28703       IF (ID2.EQ.ID4) FACTR=HALF*FACTR
28704       M1=MNAME(I4,I2,1)
28705       IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
28706 C  photon+qbar --> meson_0+qbar'
28707          HCS=HCS+HALF*FACTR*C1STU*FPI2
28708          IF (GENEV.AND.HCS.GT.RCS) THEN
28709            CALL HWHQCP(M1,ID4,1432,74)
28710            GOTO 99
28711          ENDIF
28712       ENDIF
28713       M2=MNAME(I4,I2,2)
28714       IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
28715 C  photon+qbar --> meson_L+qbar'
28716          HCS=HCS+FACTR*C1STU*FRHO2
28717          IF (GENEV.AND.HCS.GT.RCS) THEN
28718            CALL HWHQCP(M2,ID4,1432,75)
28719            GOTO 99
28720          ENDIF
28721 C  photon+qbar --> meson_T+qbar'
28722          HCS=HCS+FACTR*C3STU*FRHO2
28723          IF (GENEV.AND.HCS.GT.RCS) THEN
28724            CALL HWHQCP(M2,ID4,1432,76)
28725            GOTO 99
28726          ENDIF
28727       ENDIF
28728   40  CONTINUE
28729       FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
28730       IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
28731 C  photon+qbar -->eta+qbar
28732          HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
28733          IF (GENEV.AND.HCS.GT.RCS) THEN
28734            CALL HWHQCP(22,ID2,1432,74)
28735            GOTO 99
28736          ENDIF
28737       ENDIF
28738       IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
28739 C  photon+qbar -->eta'+qbar
28740          HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
28741          IF (GENEV.AND.HCS.GT.RCS) THEN
28742            CALL HWHQCP(25,ID2,1432,74)
28743            GOTO 99
28744          ENDIF
28745       ENDIF
28746       IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
28747 C  photon+qbar -->phi_L+qbar
28748          HCS=HCS+FACTR*C1STU*FPHI2(I2)
28749          IF (GENEV.AND.HCS.GT.RCS) THEN
28750            CALL HWHQCP(56,ID2,1432,75)
28751            GOTO 99
28752          ENDIF
28753 C  photon+qbar -->phi_T+qbar
28754          HCS=HCS+FACTR*C3STU*FPHI2(I2)
28755          IF (GENEV.AND.HCS.GT.RCS) THEN
28756            CALL HWHQCP(56,ID2,1432,76)
28757            GOTO 99
28758          ENDIF
28759       ENDIF
28760       IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
28761 C  photon+qbar -->omega_L+qbar
28762          HCS=HCS+FACTR*C1STU*FOMEG2(I2)
28763          IF (GENEV.AND.HCS.GT.RCS) THEN
28764            CALL HWHQCP(24,ID2,1432,75)
28765            GOTO 99
28766          ENDIF
28767 C  photon+qbar -->omega_T+qbar
28768          HCS=HCS+FACTR*C3STU*FOMEG2(I2)
28769          IF (GENEV.AND.HCS.GT.RCS) THEN
28770            CALL HWHQCP(24,ID2,1432,76)
28771            GOTO 99
28772          ENDIF
28773       ENDIF
28774   50  CONTINUE
28775       EVWGT=HCS
28776       RETURN
28777 C Generate event
28778   99  IDN(1)=59
28779       IDN(2)=ID2
28780       IDCMF=15
28781       CALL HWETWO(.TRUE.,.TRUE.)
28782 C Set polarization vector
28783       IF (IHPRO.EQ.72.OR.IHPRO.EQ.75) THEN
28784         RHOHEP(2,NHEP-1)=ONE
28785       ELSEIF (IHPRO.EQ.73.OR.IHPRO.EQ.76) THEN
28786         RHOHEP(1,NHEP-1)=HALF
28787         RHOHEP(3,NHEP-1)=HALF
28788       ENDIF
28789       END
28790 CDECK  ID>, HWHPPT.
28791 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
28792 *-- Author :    Ian Knowles
28793 C-----------------------------------------------------------------------
28794       SUBROUTINE HWHPPT
28795 C-----------------------------------------------------------------------
28796 C     point-like photon/QCD di-jet production: mean EVWGT = sigma in nb
28797 C-----------------------------------------------------------------------
28798       INCLUDE 'herwig65.inc'
28799       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,PP1,PP2,ET,EJ,
28800      & EXY,EXY2,FACTR,RS,S,T,U,CSTU,CTSU,HCS
28801       INTEGER ID1,ID2,ID3,ID4,IHAD1,IHAD2
28802       EXTERNAL HWRGEN,HWRUNI,HWUALF
28803       SAVE CSTU,CTSU,HCS,FACTR,RS
28804       PARAMETER (EPS=1.E-9)
28805       IHAD1=1
28806       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28807       IHAD2=2
28808       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28809       IF (GENEV) THEN
28810          RCS=HCS*HWRGEN(0)
28811       ELSE
28812          EVWGT=0.
28813          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28814          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28815          XX(1)=1.
28816          CALL HWRPOW(ET,EJ)
28817          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28818          EXY2=2.*PP1/ET-EXY
28819          IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28820          XX(2)=PP1/(PP2*EXY*EXY2)
28821          IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28822          S=XX(2)*PP1*PP2
28823          RS=.5*SQRT(S)
28824          T=-PP1*0.5*ET/EXY
28825          U=-S-T
28826          COSTH=(T-U)/S
28827 C Set EMSCA to hard process scale (Approx ET-jet)
28828          EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28829          FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM
28830      &        *HWUALF(1,EMSCA)/(S*T)
28831          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28832          CSTU=U/T+T/U
28833          CTSU=-2.*CFFAC*(U/S+S/U)
28834       ENDIF
28835       HCS=0.
28836       ID1=59
28837       DO 20 ID2=1,13
28838       IF (DISF(ID2,2).LT.EPS) GOTO 20
28839       IF (ID2.LT.7) THEN
28840 C photon+q ---> g+q
28841          HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**2
28842          IF (GENEV.AND.HCS.GT.RCS) THEN
28843            CALL HWHQCP( 13,ID2,1423,51)
28844            GOTO 99
28845          ENDIF
28846       ELSEIF (ID2.LT.13) THEN
28847 C photon+qbar ---> g+qbar
28848          HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**2
28849          IF (GENEV.AND.HCS.GT.RCS) THEN
28850            CALL HWHQCP( 13,ID2,1342,52)
28851            GOTO 99
28852          ENDIF
28853       ELSE
28854 C photon+g ---> q+qbar
28855          DO 10 ID3=1,6
28856          IF (RS.GT.RMASS(ID3)) THEN
28857             ID4=ID3+6
28858             HCS=HCS+CSTU*DISF(ID2,2)*QFCH(ID3)**2
28859             IF (GENEV.AND.HCS.GT.RCS) THEN
28860               CALL HWHQCP(ID3,ID4,1423,53)
28861               GOTO 99
28862             ENDIF
28863          ENDIF
28864   10     CONTINUE
28865       ENDIF
28866   20  CONTINUE
28867       EVWGT=FACTR*HCS
28868       RETURN
28869 C Generate event
28870   99  IDN(1)=ID1
28871       IDN(2)=ID2
28872       IDCMF=15
28873       CALL HWETWO(.TRUE.,.TRUE.)
28874       END
28875 CDECK  ID>, HWHPQS.
28876 *CMZ :-        -27/03/95  13.27.22  by  Mike Seymour
28877 *-- Author :    Ian Knowles
28878 C-----------------------------------------------------------------------
28879       SUBROUTINE HWHPQS
28880 C-----------------------------------------------------------------------
28881 C     Compton scattering of point-like photon and (anti)quark
28882 C     mean EVWGT = sigma in nb
28883 C-----------------------------------------------------------------------
28884       INCLUDE 'herwig65.inc'
28885       DOUBLE PRECISION HWRGEN,HWRUNI,EPS,RCS,PP1,PP2,ET,EJ,EXY,EXY2,
28886      & FACTR,S,T,U,CTSU,HCS
28887       INTEGER ID1,ID2,IHAD1,IHAD2
28888       EXTERNAL HWRGEN,HWRUNI
28889       SAVE CTSU,HCS,FACTR
28890       PARAMETER (EPS=1.E-9)
28891       IHAD1=1
28892       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28893       IHAD2=2
28894       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28895       IF (GENEV) THEN
28896          RCS=HCS*HWRGEN(0)
28897       ELSE
28898          EVWGT=0.
28899          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28900          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28901          XX(1)=1.
28902          CALL HWRPOW(ET,EJ)
28903          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28904          EXY2=2.*PP1/ET-EXY
28905          IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28906          XX(2)=PP1/(PP2*EXY*EXY2)
28907          IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28908          S=XX(2)*PP1*PP2
28909          T=-PP1*0.5*ET/EXY
28910          U=-S-T
28911          COSTH=(T-U)/S
28912 C Set EMSCA to hard process scale (Approx ET-jet)
28913          EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28914          FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM**2/(S*T)
28915          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28916          CTSU=-2.*(U/S+S/U)
28917       ENDIF
28918       HCS=0.
28919       ID1=59
28920       DO 20 ID2=1,12
28921       IF (DISF(ID2,2).LT.EPS) GOTO 20
28922       IF (ID2.LT.7) THEN
28923 C photon+q ---> photon+q
28924          HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**4
28925          IF (GENEV.AND.HCS.GT.RCS) THEN
28926            CALL HWHQCP( 59,ID2,1432,66)
28927            GOTO 99
28928          ENDIF
28929       ELSE
28930 C photon+qbar ---> photon+qbar
28931          HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**4
28932          IF (GENEV.AND.HCS.GT.RCS) THEN
28933            CALL HWHQCP( 59,ID2,1432,67)
28934            GOTO 99
28935          ENDIF
28936       ENDIF
28937   20  CONTINUE
28938       EVWGT=FACTR*HCS
28939       RETURN
28940 C Generate event
28941   99  IDN(1)=ID1
28942       IDN(2)=ID2
28943       IDCMF=15
28944       CALL HWETWO(.TRUE.,.TRUE.)
28945       END
28946 CDECK  ID>, HWHQCD.
28947 *CMZ :-        -20/05/99  12.39.45  by  Kosuke Odagiri
28948 *-- Author :    Bryan Webber
28949 C-----------------------------------------------------------------------
28950       SUBROUTINE HWHQCD
28951 C-----------------------------------------------------------------------
28952 C     QCD HARD 2->2 PROCESSES: MEAN EVWGT = SIGMA IN NB
28953 C-----------------------------------------------------------------------
28954       INCLUDE 'herwig65.inc'
28955       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,RS,EPS,HF,RCS,Z1,Z2,ET,EJ,
28956      & FACTR,S,T,U,ST,TU,US,STU,TUS,UST,EN,RN,GFLA,AF,ASTU,ASUT,AUST,
28957      & BF,BSTU,BSUT,BUST,BUTS,CF,CSTU,CSUT,CTSU,CTUS,DF,DSTU,DTSU,DUTS,
28958      & DIST,HCS,UT,SU,GT,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
28959       INTEGER ID1,ID2,I
28960       EXTERNAL HWRGEN,HWRUNI,HWUALF
28961       SAVE HCS,ASTU,AUST,BSTU,BSUT,BUST,BUTS,CSTU,CSUT,CTSU,CTUS,
28962      & DSTU,DTSU,DUTS,GFLA,RCS,S,T,TU,U,US
28963       PARAMETER (EPS=1.E-9,HF=0.5)
28964       IF (GENEV) THEN
28965         RCS=HCS*HWRGEN(0)
28966       ELSE
28967         EVWGT=0.
28968         CALL HWRPOW(ET,EJ)
28969         KK = ET/PHEP(5,3)
28970         KK2=KK**2
28971         IF (KK.GE.ONE) RETURN
28972         YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
28973         YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
28974         IF (YJ1INF.GE.YJ1SUP) RETURN
28975         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
28976         YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
28977         YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
28978         IF (YJ2INF.GE.YJ2SUP) RETURN
28979         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
28980         XX(1)=.5*(Z1+Z2)*KK
28981         IF (XX(1).GE.ONE) RETURN
28982         XX(2)=XX(1)/(Z1*Z2)
28983         IF (XX(2).GE.ONE) RETURN
28984         COSTH=(Z1-Z2)/(Z1+Z2)
28985         S=XX(1)*XX(2)*PHEP(5,3)**2
28986         RS=HF*SQRT(S)
28987         DO 3 I=1,NFLAV
28988         IF (RS.LT.RMASS(I)) GOTO 4
28989     3   CONTINUE
28990         I=NFLAV+1
28991     4   MAXFL=I-1
28992         IF (MAXFL.EQ.0) THEN
28993           CALL HWWARN('HWHQCD',100)
28994           GOTO 999
28995         ENDIF
28996 C
28997         T=-HF*S*(1.-COSTH)
28998         U=-S-T
28999 C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
29000         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
29001         FACTR = GEV2NB*.5*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
29002      &        * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
29003         CALL HWSGEN(.FALSE.)
29004 C
29005         ST=S/T
29006         TU=T/U
29007         US=U/S
29008         STU=TU/US
29009         TUS=US/ST
29010         UST=ST/TU
29011 C
29012         EN=CAFAC
29013         RN=CFFAC/EN
29014         GFLA=HF*FLOAT(MAXFL)/(EN*RN)**2
29015         AF=FACTR*RN
29016         ASTU=AF*(1.-2.*UST)
29017         ASUT=AF*(1.-2.*STU)
29018         AUST=AF*(1.-2.*TUS)
29019 C-----------------------------------------------------------------------
29020 C---Colour decomposition modifications below (KO)
29021 C-----------------------------------------------------------------------
29022         BF=HF-AF/EN/TUS/(ASTU+ASUT)
29023         BSTU=BF*ASTU
29024         BSUT=BF*ASUT
29025         BF=ONE-TWO*AF/EN/STU/(AUST+ASTU)
29026         BUST=BF*AUST
29027         BUTS=BF*ASTU
29028 C-----------------------------------------------------------------------
29029 C       BF=2.*AF/EN
29030 C       BSTU=HF*(ASTU+BF*ST)
29031 C       BSUT=HF*(ASUT+BF/US)
29032 C       BUST=AUST+BF*US
29033 C       BUTS=ASTU+BF/TU
29034 C-----------------------------------------------------------------------
29035         CF=AF*EN
29036         CSTU=(CF*(RN-TUS))/TU
29037         CSUT=(CF*(RN-TUS))*TU
29038         CTSU=(FACTR*(UST-RN))*US
29039         CTUS=(FACTR*(UST-RN))/US
29040         DF=HF*FACTR/RN
29041         DSTU=DF*(1.+1./TUS-STU-UST)
29042         DTSU=DF*(1.+1./UST-STU-TUS)
29043         DUTS=DF*(1.+1./STU-UST-TUS)
29044       ENDIF
29045 C
29046       HCS=0.
29047       DO 6 ID1=1,13
29048       IF (DISF(ID1,1).LT.EPS) GOTO 6
29049       DO 5 ID2=1,13
29050       IF (DISF(ID2,2).LT.EPS) GOTO 5
29051       DIST=DISF(ID1,1)*DISF(ID2,2)
29052       IF (ID1.LT.7) THEN
29053 C---QUARK FIRST
29054        IF (ID2.LT.7) THEN
29055         IF (ID1.NE.ID2) THEN
29056          HCS=HCS+ASTU*DIST
29057          IF (GENEV.AND.HCS.GT.RCS) THEN
29058            CALL HWHQCP(ID1,ID2,3421, 3)
29059            GOTO 9
29060          ENDIF
29061         ELSE
29062          HCS=HCS+BSTU*DIST
29063          IF (GENEV.AND.HCS.GT.RCS) THEN
29064            CALL HWHQCP(ID1,ID2,3421, 1)
29065            GOTO 9
29066          ENDIF
29067          HCS=HCS+BSUT*DIST
29068          IF (GENEV.AND.HCS.GT.RCS) THEN
29069            CALL HWHQCP(ID1,ID2,4312, 2)
29070            GOTO 9
29071          ENDIF
29072         ENDIF
29073        ELSEIF (ID2.NE.13) THEN
29074         IF (ID2.NE.ID1+6) THEN
29075          HCS=HCS+ASTU*DIST
29076          IF (GENEV.AND.HCS.GT.RCS) THEN
29077            CALL HWHQCP(ID1,ID2,3142, 9)
29078            GOTO 9
29079          ENDIF
29080         ELSE
29081          HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
29082          IF (GENEV.AND.HCS.GT.RCS) THEN
29083            CALL HWHQCP(-ID1, 0,2413, 4)
29084            GOTO 9
29085          ENDIF
29086          HCS=HCS+BUTS*DIST
29087          IF (GENEV.AND.HCS.GT.RCS) THEN
29088            CALL HWHQCP(ID1,ID2,3142, 5)
29089            GOTO 9
29090          ENDIF
29091          HCS=HCS+BUST*DIST
29092          IF (GENEV.AND.HCS.GT.RCS) THEN
29093            CALL HWHQCP(ID1,ID2,2413, 6)
29094            GOTO 9
29095          ENDIF
29096          HCS=HCS+CSTU*DIST
29097          IF (GENEV.AND.HCS.GT.RCS) THEN
29098            CALL HWHQCP( 13, 13,2413, 7)
29099            GOTO 9
29100          ENDIF
29101          HCS=HCS+CSUT*DIST
29102          IF (GENEV.AND.HCS.GT.RCS) THEN
29103            CALL HWHQCP( 13, 13,2341, 8)
29104            GOTO 9
29105          ENDIF
29106         ENDIF
29107        ELSE
29108          HCS=HCS+CTSU*DIST
29109          IF (GENEV.AND.HCS.GT.RCS) THEN
29110            CALL HWHQCP(ID1,ID2,3142,10)
29111            GOTO 9
29112          ENDIF
29113          HCS=HCS+CTUS*DIST
29114          IF (GENEV.AND.HCS.GT.RCS) THEN
29115            CALL HWHQCP(ID1,ID2,3421,11)
29116            GOTO 9
29117          ENDIF
29118        ENDIF
29119       ELSEIF (ID1.NE.13) THEN
29120 C---QBAR FIRST
29121        IF (ID2.LT.7) THEN
29122         IF (ID1.NE.ID2+6) THEN
29123          HCS=HCS+ASTU*DIST
29124          IF (GENEV.AND.HCS.GT.RCS) THEN
29125            CALL HWHQCP(ID1,ID2,2413,17)
29126            GOTO 9
29127          ENDIF
29128         ELSE
29129          HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
29130          IF (GENEV.AND.HCS.GT.RCS) THEN
29131            CALL HWHQCP(-ID1, 0,3142,12)
29132            GOTO 9
29133          ENDIF
29134          HCS=HCS+BUTS*DIST
29135          IF (GENEV.AND.HCS.GT.RCS) THEN
29136            CALL HWHQCP(ID1,ID2,2413,13)
29137            GOTO 9
29138          ENDIF
29139          HCS=HCS+BUST*DIST
29140          IF (GENEV.AND.HCS.GT.RCS) THEN
29141            CALL HWHQCP(ID1,ID2,3142,14)
29142            GOTO 9
29143          ENDIF
29144          HCS=HCS+CSTU*DIST
29145          IF (GENEV.AND.HCS.GT.RCS) THEN
29146            CALL HWHQCP( 13, 13,3142,15)
29147            GOTO 9
29148          ENDIF
29149          HCS=HCS+CSUT*DIST
29150          IF (GENEV.AND.HCS.GT.RCS) THEN
29151            CALL HWHQCP( 13, 13,4123,16)
29152            GOTO 9
29153          ENDIF
29154         ENDIF
29155        ELSEIF (ID2.NE.13) THEN
29156         IF (ID1.NE.ID2) THEN
29157          HCS=HCS+ASTU*DIST
29158          IF (GENEV.AND.HCS.GT.RCS) THEN
29159            CALL HWHQCP(ID1,ID2,4312,20)
29160            GOTO 9
29161          ENDIF
29162         ELSE
29163          HCS=HCS+BSTU*DIST
29164          IF (GENEV.AND.HCS.GT.RCS) THEN
29165            CALL HWHQCP(ID1,ID2,4312,18)
29166            GOTO 9
29167          ENDIF
29168          HCS=HCS+BSUT*DIST
29169          IF (GENEV.AND.HCS.GT.RCS) THEN
29170            CALL HWHQCP(ID1,ID2,3421,19)
29171            GOTO 9
29172          ENDIF
29173         ENDIF
29174        ELSE
29175          HCS=HCS+CTSU*DIST
29176          IF (GENEV.AND.HCS.GT.RCS) THEN
29177            CALL HWHQCP(ID1,ID2,2413,21)
29178            GOTO 9
29179          ENDIF
29180          HCS=HCS+CTUS*DIST
29181          IF (GENEV.AND.HCS.GT.RCS) THEN
29182            CALL HWHQCP(ID1,ID2,4312,22)
29183            GOTO 9
29184          ENDIF
29185        ENDIF
29186       ELSE
29187 C---GLUON FIRST
29188        IF (ID2.LT.7) THEN
29189          HCS=HCS+CTSU*DIST
29190          IF (GENEV.AND.HCS.GT.RCS) THEN
29191            CALL HWHQCP(ID1,ID2,2413,23)
29192            GOTO 9
29193          ENDIF
29194          HCS=HCS+CTUS*DIST
29195          IF (GENEV.AND.HCS.GT.RCS) THEN
29196            CALL HWHQCP(ID1,ID2,3421,24)
29197            GOTO 9
29198          ENDIF
29199        ELSEIF (ID2.LT.13) THEN
29200          HCS=HCS+CTSU*DIST
29201          IF (GENEV.AND.HCS.GT.RCS) THEN
29202            CALL HWHQCP(ID1,ID2,3142,25)
29203            GOTO 9
29204          ENDIF
29205          HCS=HCS+CTUS*DIST
29206          IF (GENEV.AND.HCS.GT.RCS) THEN
29207            CALL HWHQCP(ID1,ID2,4312,26)
29208            GOTO 9
29209          ENDIF
29210        ELSE
29211          HCS=HCS+GFLA*CSTU*DIST
29212          IF (GENEV.AND.HCS.GT.RCS) THEN
29213            CALL HWHQCP(  0,  0,2413,27)
29214            GOTO 9
29215          ENDIF
29216          HCS=HCS+GFLA*CSUT*DIST
29217          IF (GENEV.AND.HCS.GT.RCS) THEN
29218            CALL HWHQCP(  0,  0,4123,28)
29219            GOTO 9
29220          ENDIF
29221          HCS=HCS+DTSU*DIST
29222          IF (GENEV.AND.HCS.GT.RCS) THEN
29223            CALL HWHQCP(ID1,ID2,2341,29)
29224            GOTO 9
29225          ENDIF
29226          HCS=HCS+DSTU*DIST
29227          IF (GENEV.AND.HCS.GT.RCS) THEN
29228            CALL HWHQCP(ID1,ID2,3421,30)
29229            GOTO 9
29230          ENDIF
29231         HCS=HCS+DUTS*DIST
29232          IF (GENEV.AND.HCS.GT.RCS) THEN
29233            CALL HWHQCP(ID1,ID2,2413,31)
29234            GOTO 9
29235          ENDIF
29236        ENDIF
29237       ENDIF
29238     5 CONTINUE
29239     6 CONTINUE
29240       EVWGT=HCS
29241       RETURN
29242 C---GENERATE EVENT
29243     9 IDN(1)=ID1
29244       IDN(2)=ID2
29245       IDCMF=15
29246       CALL HWETWO(.TRUE.,.TRUE.)
29247       IF (AZSPIN) THEN
29248 C Calculate coefficients for constructing spin density matrices
29249          IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
29250      &       IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
29251 C qqbar-->gg or qbarq-->gg
29252             UT=1./TU
29253             GCOEF(1)=UT+TU
29254             GCOEF(2)=-2.
29255             GCOEF(3)=0.
29256             GCOEF(4)=0.
29257             GCOEF(5)=GCOEF(1)
29258             GCOEF(6)=UT-TU
29259             GCOEF(7)=-GCOEF(6)
29260          ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
29261      &           IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
29262      &           IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
29263      &           IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
29264 C qg-->qg or qbarg-->qbarg or gq-->gq  or gqbar-->gqbar
29265             SU=1./US
29266             GCOEF(1)=-(SU+US)
29267             GCOEF(2)=0.
29268             GCOEF(3)=2.
29269             GCOEF(4)=0.
29270             GCOEF(5)=SU-US
29271             GCOEF(6)=GCOEF(1)
29272             GCOEF(7)=-GCOEF(5)
29273          ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
29274 C gg-->qqbar
29275             UT=1./TU
29276             GCOEF(1)=TU+UT
29277             GCOEF(2)=-2.
29278             GCOEF(3)=0.
29279             GCOEF(4)=0.
29280             GCOEF(5)=GCOEF(1)
29281             GCOEF(6)=TU-UT
29282             GCOEF(7)=-GCOEF(6)
29283          ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
29284      &                          IHPRO.EQ.31) THEN
29285 C gg-->gg
29286             GT=S*S+T*T+U*U
29287             GCOEF(2)=2.*U*U*T*T
29288             GCOEF(3)=2.*S*S*U*U
29289             GCOEF(4)=2.*S*S*T*T
29290             GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
29291             GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
29292             GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
29293             GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
29294          ELSE
29295             CALL HWVZRO(7,GCOEF)
29296          ENDIF
29297       ENDIF
29298  999  RETURN
29299       END
29300 CDECK  ID>, HWHQCP.
29301 *CMZ :-        -26/04/91  10.18.57  by  Bryan Webber
29302 *-- Author :    Bryan Webber
29303 C-----------------------------------------------------------------------
29304       SUBROUTINE HWHQCP(ID3,ID4,IPERM,IHPR)
29305 C-----------------------------------------------------------------------
29306 C     IDENTIFIES HARD SUBPROCESS
29307 C-----------------------------------------------------------------------
29308       INCLUDE 'herwig65.inc'
29309       INTEGER HWRINT,ID3,ID4,IPERM,IHPR,ND3
29310       EXTERNAL HWRINT
29311       IHPRO=IHPR
29312       IF (ID3.GT.0) THEN
29313         IDN(3)=ID3
29314         IDN(4)=ID4
29315       ELSE
29316         ND3=-ID3
29317         IF (ID3.GT.-7) THEN
29318     1     IDN(3)=HWRINT(1,MAXFL)
29319           IF (IDN(3).EQ.ND3) GOTO 1
29320           IDN(4)=IDN(3)+6
29321         ELSE
29322     2     IDN(3)=HWRINT(1,MAXFL)+6
29323           IF (IDN(3).EQ.ND3) GOTO 2
29324           IDN(4)=IDN(3)-6
29325         ENDIF
29326       ENDIF
29327       ICO(1)=IPERM/1000
29328       ICO(2)=IPERM/100-10*ICO(1)
29329       ICO(3)=IPERM/10 -10*(IPERM/100)
29330       ICO(4)=IPERM    -10*(IPERM/10)
29331       END
29332 CDECK  ID>, HWHQPM.
29333 *CMZ :-        -27/07/95  14.13.56  by  Mike Seymour
29334 *-- Author :    Mike Seymour
29335 C-----------------------------------------------------------------------
29336       SUBROUTINE HWHQPM
29337 C     HARD PROCESS: GAMGAM --> QQBAR/LLBAR/W+W-
29338 C     MEAN EVENT WEIGHT = CROSS-SECTION IN NB AFTER CUTS ON PT
29339 C-----------------------------------------------------------------------
29340       INCLUDE 'herwig65.inc'
29341       DOUBLE PRECISION RCS,HCS,RS,S,EMSQ,BE,TMIN,TMAX,T,U,FACTR,Q,CFAC,
29342      $     HWRGEN
29343       INTEGER IHAD1,IHAD2,HQ,ID3,ID4,I1,I2
29344       SAVE HCS,FACTR,HQ,RS
29345       IHAD1=1
29346       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
29347       IHAD2=2
29348       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
29349       IF (GENEV) THEN
29350         RCS=HCS*HWRGEN(0)
29351       ELSE
29352         EVWGT=0.
29353         RS=PHEP(5,3)
29354         S=RS**2
29355         HQ=MOD(IPROC,100)
29356         IF (HQ.EQ.0) THEN
29357           EMSQ=0
29358           BE=1
29359           CFAC=3
29360         ELSE
29361           IF (HQ.GT.6) HQ=2*HQ+107
29362           IF (HQ.EQ.127) HQ=198
29363           EMSQ=RMASS(HQ)**2
29364           BE=1-4*EMSQ/S
29365           IF (BE.LT.ZERO) RETURN
29366           BE=SQRT(BE)
29367           CFAC=1
29368           IF (HQ.LE.6) CFAC=3
29369         ENDIF
29370         TMIN=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMIN**2)/S,ZERO)))
29371         TMAX=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMAX**2)/S,ZERO)))
29372         IF (TMIN.GE.TMAX) RETURN
29373         T=-(TMAX/TMIN)**HWRGEN(1)*TMIN
29374         IF (HWRGEN(2).GT.HALF) T=-S-T
29375         U=-S-T
29376         COSTH=(T-U)/(BE*S)
29377         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
29378         IF (HQ.NE.198) THEN
29379           FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
29380      $         *2*PIFAC*CFAC*ALPHEM**2/S**2
29381      $         *((U-4*EMSQ)/T+(T-4*EMSQ)/U-4*(EMSQ/T+EMSQ/U)**2)
29382         ELSE
29383           FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
29384      $         *6*PIFAC*CFAC*ALPHEM**2/S**2
29385      $         *(1-S/(T*U)*(4D0/3*S+2*EMSQ)
29386      $         +(S/(T*U))**2*(2D0/3*S**2+2*EMSQ**2))
29387         ENDIF
29388       ENDIF
29389       HCS=0.
29390       XX(1)=1.
29391       XX(2)=1.
29392       IF (HQ.EQ.0) THEN
29393         I1=1
29394         I2=6
29395       ELSE
29396         I1=HQ
29397         I2=HQ
29398       ENDIF
29399       DO 10 ID3=I1,I2
29400         IF (RS.GT.2*RMASS(ID3)) THEN
29401           Q=ICHRG(ID3)
29402           IF (HQ.LE.6) Q=Q/THREE
29403           ID4=ID3+6
29404           IF (HQ.EQ.198) ID4=199
29405           HCS=HCS+Q**4
29406           IF (GENEV.AND.HCS.GT.RCS) THEN
29407             CALL HWHQCP(ID3,ID4,1243,61)
29408             GOTO 99
29409           ENDIF
29410         ENDIF
29411  10   CONTINUE
29412       EVWGT=FACTR*HCS
29413       RETURN
29414  99   IDN(1)=59
29415       IDN(2)=59
29416       IDCMF=15
29417       CALL HWETWO(.TRUE.,.TRUE.)
29418       END
29419 CDECK  ID>, HWHRBB.
29420 *CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
29421 *-- Author :    Peter Richardson
29422 C-----------------------------------------------------------------------
29423       SUBROUTINE HWHRBB
29424 C-----------------------------------------------------------------------
29425 C  Subroutine for 2 parton -> 2 parton via UDD resonant squarks
29426 C-----------------------------------------------------------------------
29427       INCLUDE 'herwig65.inc'
29428       DOUBLE PRECISION HCS,S,RCS,HWRGEN,MQ1,MQ2,TAU,LOWTLM,UPPTLM,RTAB,
29429      &                 SQSH,MATELM,SCF(12),CHANPB(2),HWRUNI,PCM,MIX(12),
29430      &                 ME(2,3,3,3,3),WD,MS(12),SWD(12),RAND,TAUA,
29431      &                 CHAN(12),EPS,SH,FAC,TAUB,LAM(6,3,3,3,3),
29432      &                 XMIN,XMAX,XPOW,XUPP,MS2(12),MSWD(12)
29433       INTEGER I,J,K,L,I1,J1,K1,L1,N,THEP,CONECT(4,5),HWRINT,
29434      &        GENR,GN,MIG,MXG,GEN
29435       LOGICAL FIRST
29436       EXTERNAL HWRGEN,HWRUNI
29437       PARAMETER(EPS=1D-20)
29438       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
29439       SAVE HCS,ME,MS,SWD,CHAN,LAM,MIX,FAC,SH,SQSH,SCF,MS2,MSWD
29440       SAVE CONECT
29441       DATA CONECT/1,1,3,4,-1,-1,2,3,0,0,0,0,1,1,-2,-3,-1,-1,-3,-4/
29442       IF(GENEV) THEN
29443         RCS = HCS*HWRGEN(0)
29444       ELSE
29445         IF(FSTWGT) THEN
29446 C--Extract masses and width's needed
29447           DO I=1,3
29448             MS(2*I-1)  = RMASS(399+2*I)
29449             MS(2*I)    = RMASS(411+2*I)
29450             MS(2*I+5)  = RMASS(400+2*I)
29451             MS(2*I+6)  = RMASS(412+2*I)
29452             SWD(2*I-1) = HBAR/RLTIM(399+2*I)
29453             SWD(2*I)   = HBAR/RLTIM(411+2*I)
29454             SWD(2*I+5) = HBAR/RLTIM(400+2*I)
29455             SWD(2*I+6) = HBAR/RLTIM(412+2*I)
29456           ENDDO
29457           DO I=1,12
29458              MS2(I)  = MS(I)**2
29459              MSWD(I) = MS(I)*SWD(I)
29460           ENDDO
29461 C--Now set up the parmaters for multichannel integration
29462           RAND = ZERO
29463           DO K=1,3
29464             CHANPB(1) = ZERO
29465             CHANPB(2) = ZERO
29466             DO I=1,3
29467               DO J=1,3
29468                 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
29469                 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
29470               ENDDO
29471             ENDDO
29472             RAND=RAND+CHANPB(1)+CHANPB(2)
29473             DO J=1,2
29474               CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
29475               CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K  ,2,J)**2
29476               MIX(2*K-2+J) = QMIXSS(2*K-1,2,J)**2
29477               MIX(2*K+4+J) = QMIXSS(2*K,2,J)**2
29478             ENDDO
29479           ENDDO
29480           IF(RAND.GT.ZERO) THEN
29481             DO I=1,12
29482               CHAN(I)=CHAN(I)/RAND
29483             ENDDO
29484           ELSE
29485             HCS =ZERO
29486             CALL HWWARN('HWHRBB',500)
29487           ENDIF
29488 C--find the couplings
29489           DO GN=1,3
29490             DO I=1,3
29491               DO J=1,3
29492                 DO K=1,3
29493                   DO L=1,3
29494                     LAM(GN,I,J,K,L)  =LAMDA3(I,J,GN)*LAMDA3(K,L,GN)
29495                     LAM(GN+3,I,J,K,L)=LAMDA3(GN,I,J)*LAMDA3(GN,K,L)
29496                   ENDDO
29497                 ENDDO
29498               ENDDO
29499             ENDDO
29500           ENDDO
29501         ENDIF
29502         EVWGT = ZERO
29503         S     = PHEP(5,3)**2
29504         COSTH = HWRUNI(0,-ONE,ONE)
29505 C--Generate the smoothing
29506         RAND=HWRUNI(0,ZERO,ONE)
29507         DO I=1,12
29508           IF(CHAN(I).GT.RAND) GOTO 20
29509           RAND=RAND-CHAN(I)
29510         ENDDO
29511  20     GENR=I
29512 C--Calculate hard scale and obtain parton distributions
29513         TAUA   = MS2(GENR)/S
29514         TAUB   = SWD(GENR)**2/S
29515         RTAB   = SQRT(TAUA*TAUB)
29516         XUPP = XMAX
29517         IF(XMAX**2.GT.S) XUPP = SQRT(S)
29518         LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
29519         UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
29520         TAU    = HWRUNI(0,LOWTLM,UPPTLM)
29521         TAU    = RTAB*TAN(RTAB*TAU)+TAUA
29522         SH     = S*TAU
29523         SQSH   = SQRT(SH)
29524         EMSCA  = SQSH
29525         XX(1)  = EXP(HWRUNI(0,ZERO,LOG(TAU)))
29526         XX(2)  = TAU/XX(1)
29527         CALL HWSGEN(.FALSE.)
29528 C--Calculate the prefactor due multichannel approach
29529         FAC = ZERO
29530         DO GN=1,12
29531          SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
29532          FAC=FAC+CHAN(GN)*SCF(GN)
29533         ENDDO
29534         FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
29535      &        /(24*PIFAC*SQSH*SH*TAU*FAC*S**2)
29536       ENDIF
29537 C--loop over the quarks
29538       HCS = ZERO
29539       DO GN=1,2
29540         IF(GN.EQ.1) THEN
29541           MIG = 1
29542           MXG = 6
29543         ELSE
29544           MIG = 7
29545           MXG = 12
29546         ENDIF
29547         DO K1=1,3
29548           DO 70 L1=1,3
29549             IF(GN.EQ.1) THEN
29550               K = 2*K1
29551               L = 2*L1-1
29552             ELSE
29553               K=2*K1-1
29554               L=2*L1-1
29555               IF(GN.EQ.2.AND.L1.GE.K1) GOTO 70
29556             ENDIF
29557             MQ1=RMASS(K)
29558             MQ2=RMASS(L)
29559             IF(SQSH.GT.(MQ1+MQ2)) THEN
29560               PCM=SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2)/(4*SH))
29561               WD = SH*(SH-MQ1**2-MQ2**2)*PCM
29562             ELSE
29563               GOTO 70
29564             ENDIF
29565             DO I1=1,3
29566               DO 60 J1=1,3
29567                 IF(GN.EQ.1) THEN
29568                   I = 2*I1
29569                   J = 2*J1-1
29570                 ELSE
29571                   I=2*I1-1
29572                   J=2*J1-1
29573                   IF(J1.GT.I1) GOTO 60
29574                 ENDIF
29575                 IF(GENEV) GOTO 50
29576                 MATELM = ZERO
29577                 DO 40 GEN=MIG,MXG
29578                   IF(ABS(MIX(GEN)).LT.EPS.OR.
29579      &             ABS(LAM(INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS) GOTO 40
29580                   DO 30 GENR=MIG,MXG
29581                     IF(ABS(LAM(INT((GENR+1)/2),I1,J1,K1,L1)).LT.EPS.
29582      &                OR.ABS(MIX(GENR)).LT.EPS) GOTO 30
29583                     MATELM =MATELM+SCF(GEN)*SCF(GENR)*WD*
29584      &                  ((SH-MS2(GEN))*(SH-MS2(GENR))+
29585      &                  MSWD(GEN)*MSWD(GENR))
29586      &                  *LAM(INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
29587      &                  *LAM(INT((GENR+1)/2),I1,J1,K1,L1)*MIX(GENR)
29588  30               CONTINUE
29589  40             CONTINUE
29590                 ME(GN,I1,J1,K1,L1) = MATELM*FAC
29591 C--Add up the term to get the cross-section
29592  50             HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I,1)*DISF(J,2)
29593                 IF(HCS.GT.RCS.AND.GENEV) THEN
29594                   CALL HWHRSS(1,I,J,K,L,0,0)
29595                   GOTO 100
29596                 ENDIF
29597                 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J,1)*DISF(I,2)
29598                 IF(HCS.GT.RCS.AND.GENEV) THEN
29599                   CALL HWHRSS(2,J,I,K,L,0,0)
29600                   GOTO 100
29601                 ENDIF
29602                 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I+6,1)*DISF(J+6,2)
29603                 IF(HCS.GT.RCS.AND.GENEV) THEN
29604                   CALL HWHRSS(1,I,J,K,L,1,0)
29605                   GOTO 100
29606                 ENDIF
29607                 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J+6,1)*DISF(I+6,2)
29608                 IF(HCS.GT.RCS.AND.GENEV) THEN
29609                   CALL HWHRSS(2,J,I,K,L,1,0)
29610                   GOTO 100
29611                 ENDIF
29612  60           CONTINUE
29613             ENDDO
29614  70       CONTINUE
29615         ENDDO
29616       ENDDO
29617  100  IF(GENEV) THEN
29618         CALL HWETWO(.TRUE.,.TRUE.)
29619 C--first stage of the colour connection corrections
29620         DO THEP=1,5
29621           IF(THEP.NE.3) THEN
29622             JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP+CONECT(HWRINT(1,4),THEP)
29623             JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
29624           ENDIF
29625         ENDDO
29626         THEP = NHEP-4
29627         IF(HWRINT(1,2).EQ.1) THEN
29628           HRDCOL(2,1) = THEP+3
29629           HRDCOL(2,2) = THEP+4
29630           HRDCOL(1,4) = THEP
29631           HRDCOL(1,5) = THEP+1
29632         ELSE
29633           HRDCOL(2,1) = THEP+4
29634           HRDCOL(2,2) = THEP+3
29635           HRDCOL(1,4) = THEP+1
29636           HRDCOL(1,5) = THEP
29637         ENDIF
29638         DO N=1,5
29639           IF(N.LE.2) THEN
29640             HRDCOL(1,N)=HRDCOL(2,N)
29641           ELSEIF(N.GE.4) THEN
29642             HRDCOL(2,N)=HRDCOL(1,N)
29643           ENDIF
29644         ENDDO
29645         HRDCOL(1,3) = 4
29646         COLUPD = .TRUE.
29647       ELSE
29648         EVWGT = HCS
29649       ENDIF
29650       END
29651 CDECK  ID>, HWHRBS.
29652 *CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
29653 *-- Author :    Peter Richardson
29654 C-----------------------------------------------------------------------
29655       SUBROUTINE HWHRBS
29656 C-----------------------------------------------------------------------
29657 C  Subroutine for 2 parton -> parton SUSY particle via UDD resonant
29658 C  squarks.
29659 C-----------------------------------------------------------------------
29660       INCLUDE 'herwig65.inc'
29661       DOUBLE PRECISION HCS,S,RCS,HWRGEN,ME(4),CW,MER(6),MZ,TAU,TAUA,
29662      &                 TAUB,LOWTLM,UPPTLM,HWRUNI,SH,SQSH,SCF(12),MW2,
29663      &                 LAMC(3),CHANPB(2),PCM,ECM,RAND,MEN(7,6,3,3),
29664      &                 MEC(2,6,3,3),RTAB,MS(12),SWD(12),AS,HWUALF,
29665      &                 MQ,MN,MQS,TH,UH,FAC,MX(14),CHAN(12),MC(2),
29666      &                 MNS,HWUAEM,SW,G,EC,MW,A(7,14),B(7,14),EPS,XUPP,
29667      &                 MEH(3,42),XMIN,XMAX,XPOW,FAC2,MH(4),ZSQU(2,2),
29668      &                 ZQRK(2),MZ2,GUU(4),GDD(4),ME2,MS2(12),MSWD(12)
29669       INTEGER I,J,K,I1,J1,GEN,THEP,HWRINT,L,GT,GU,GR,I2,
29670      &        CONECT(2,6,5),GN,GENR,SP,SPMN,SPMX,CON,CHARMN,CHARMX,
29671      &        CM,CN
29672       LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
29673       EXTERNAL HWRGEN,HWRUNI,HWUAEM,HWUALF,HWRINT
29674       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
29675       SAVE HCS,MS,SWD,MX,CHAN,A,B,SPMN,SPMX,RAD,MEN,MEC,HIGGS,
29676      &     CHARMN,CHARMX,NEUT,CHAR,SQSH,MEH,SW,CW,MW,MZ,MER,SH,MH,
29677      &     AS,EC,FAC,G,SCF,ZSQU,ZQRK,MW2,MZ2,MS2,MSWD,GUU,GDD
29678       PARAMETER(EPS=1D-20)
29679       SAVE CONECT
29680       DATA CONECT/ 4, 4, 2, 3, 0, 0, 1,-2,-1,-3,-4,-4,
29681      &             3, 4, 3, 3, 0, 0, 1,-3,-1,-4,-3,-3,
29682      &             1, 4,-1, 3, 0, 0, 1, 1,-3,-4,-1,-1,
29683      &             1, 3,-1, 2, 0, 0,-3,-2, 0, 0, 0, 0,
29684      &             1, 4,-1, 3, 0, 0,-3,-2,-1,-1,-1,-1/
29685       IF(GENEV) THEN
29686         RCS = HCS*HWRGEN(0)
29687       ELSE
29688         IF(FSTWGT) THEN
29689 C--Extract masses and width's needed
29690           DO I=1,3
29691             MS(2*I-1) = RMASS(399+2*I)
29692             MS(2*I)   = RMASS(411+2*I)
29693             MS(2*I+5) = RMASS(400+2*I)
29694             MS(2*I+6) = RMASS(412+2*I)
29695             SWD(2*I-1) = HBAR/RLTIM(399+2*I)
29696             SWD(2*I)   = HBAR/RLTIM(411+2*I)
29697             SWD(2*I+5) = HBAR/RLTIM(400+2*I)
29698             SWD(2*I+6) = HBAR/RLTIM(412+2*I)
29699           ENDDO
29700           DO I=1,12
29701              MS2(I)  = MS(I)**2
29702              MSWD(I) = MS(I)*SWD(I)
29703           ENDDO
29704 C--Electroweak parameters
29705           SW = SQRT(SWEIN)
29706           CW = SQRT(1-SWEIN)
29707           MW    = RMASS(198)
29708           MZ    = RMASS(200)
29709           MW2   = MW**2
29710           MZ2   = MZ**2
29711 C--Now set up the parmaters for multichannel integration
29712           RAND = ZERO
29713           DO K=1,3
29714             CHANPB(1) = ZERO
29715             CHANPB(2) = ZERO
29716             DO I=1,3
29717               DO J=1,3
29718                 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
29719                 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
29720               ENDDO
29721             ENDDO
29722             RAND=RAND+CHANPB(1)+CHANPB(2)
29723             DO J=1,2
29724               CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
29725               CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K  ,2,J)**2
29726               MX(2*K-2+J) = QMIXSS(2*K-1,2,J)
29727               MX(2*K+4+J) = QMIXSS(2*K,2,J)
29728             ENDDO
29729             MX(13) = ZERO
29730             MX(14) = ZERO
29731           ENDDO
29732           IF(RAND.GT.ZERO) THEN
29733             DO I=1,12
29734               CHAN(I)=CHAN(I)/RAND
29735             ENDDO
29736           ELSE
29737             CALL HWWARN('HWHRBS',500)
29738           ENDIF
29739 C--Couplings we need for the various processes
29740 C--Gluino
29741           DO I=1,3
29742             DO J=1,2
29743               A(1,2*I-2+J) =  QMIXSS(2*I-1,2,J)
29744               B(1,2*I-2+J) = -QMIXSS(2*I-1,1,J)
29745               A(1,2*I+4+J) =  QMIXSS(2*I,2,J)
29746               B(1,2*I+4+J) = -QMIXSS(2*I,1,J)
29747             ENDDO
29748           ENDDO
29749 C--Now the neutralinos
29750           DO L=1,4
29751             MC(1) =  ZMIXSS(L,3)/(2*MW*COSB*SW)
29752             MC(2) =  ZMIXSS(L,4)/(2*MW*SINB*SW)
29753             DO I=1,3
29754               DO J=1,2
29755                 A(L+1,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
29756      &                    RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
29757                 B(L+1,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
29758      &                    RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
29759                 A(L+1,2*I+4+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
29760      &                    RMASS(2*I)+SRFCH(2*I  ,L)*QMIXSS(2*I,2,J))
29761                 B(L+1,2*I+4+J) = MC(2)*QMIXSS(2*I,2,J)*
29762      &                    RMASS(2*I)+SLFCH(2*I,  L)*QMIXSS(2*I,1,J)
29763               ENDDO
29764             ENDDO
29765           ENDDO
29766 C--Now for the charginos
29767           DO L=1,2
29768             MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
29769             MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
29770             DO I=1,3
29771               DO J=1,2
29772                 A(5+L,2*I-2+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
29773      &                            RMASS(2*I)*QMIXSS(2*I-1,1,J)
29774                 B(5+L,2*I-2+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
29775      &              -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
29776                 A(5+L,2*I+4+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
29777      &                            *QMIXSS(2*I,1,J)
29778                 B(5+L,2*I+4+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
29779      &              -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
29780               ENDDO
29781             ENDDO
29782           ENDDO
29783 C--Zero couplings
29784           DO I=1,7
29785             A(I,13) = ZERO
29786             B(I,13) = ZERO
29787             A(I,14) = ZERO
29788             B(I,14) = ZERO
29789           ENDDO
29790 C--Couplings to the Z boson of squarks and right-handed quarks
29791           ZQRK(1)   = -SW**2/6.0D0/CW
29792           ZQRK(2)   =  SW**2/3.0D0/CW
29793           ZSQU(1,1) =  HALF*(QMIXSS(5,1,1)**2-2.0D0*SW**2/3.0D0)/CW
29794           ZSQU(1,2) =  HALF*QMIXSS(5,1,1)*QMIXSS(5,1,2)/CW
29795           ZSQU(2,1) = -HALF*(QMIXSS(6,1,1)**2-4.0D0*SW**2/3.0D0)/CW
29796           ZSQU(2,2) = -HALF*QMIXSS(6,1,1)*QMIXSS(6,1,2)/CW
29797 C--Higgs Masses
29798           DO I=1,4
29799             MH(I) = RMASS(202+I)
29800           ENDDO
29801 C--Higgs couplings to quarks
29802           DO I=1,3
29803             GUU(I) = GHUUSS(I)**2*HALF**2/MW2
29804             GDD(I) = GHDDSS(I)**2*HALF**2/MW2
29805           ENDDO
29806           GUU(4) = ONE/TANB**2/MW2/8.0D0
29807           GDD(4) = ONE*TANB**2/MW2/8.0D0
29808 C--decide which processes to generate from IPROC
29809           RAD   = .FALSE.
29810           NEUT  = .FALSE.
29811           CHAR  = .FALSE.
29812           HIGGS = .FALSE.
29813           SPMN = 1
29814           SPMX = 5
29815           CHARMN = 1
29816           CHARMX = 2
29817           IF(MOD(IPROC,10000).EQ.4100) THEN
29818             RAD   = .TRUE.
29819             NEUT  = .TRUE.
29820             CHAR  = .TRUE.
29821             HIGGS = .TRUE.
29822           ELSEIF(MOD(IPROC,10000).LT.4120) THEN
29823             SPMN = 2
29824             IF(MOD(IPROC,10000).NE.4110) THEN
29825               SPMN = MOD(IPROC,10)+1
29826               SPMX = SPMN
29827             ENDIF
29828             NEUT=.TRUE.
29829           ELSEIF(MOD(IPROC,10000).LT.4130) THEN
29830             IF(MOD(IPROC,10000).NE.4120) THEN
29831               CHARMN = MOD(IPROC,10)
29832               CHARMX=CHARMN
29833             ENDIF
29834             CHAR = .TRUE.
29835           ELSEIF(MOD(IPROC,10000).EQ.4130) THEN
29836             SPMX = 1
29837             NEUT=.TRUE.
29838           ELSEIF(MOD(IPROC,10000).EQ.4140) THEN
29839             RAD = .TRUE.
29840           ELSEIF(MOD(IPROC,10000).EQ.4150) THEN
29841             HIGGS = .TRUE.
29842           ELSE
29843             CALL HWWARN('HWHRBS',501)
29844           ENDIF
29845         ENDIF
29846         EVWGT = ZERO
29847         S     = PHEP(5,3)**2
29848         COSTH = HWRUNI(0,-ONE,ONE)
29849 C--zero the array
29850         DO I=1,6
29851           DO J=1,3
29852             DO K=1,3
29853               DO L=1,7
29854                 MEN(L,I,J,K)=ZERO
29855               ENDDO
29856               DO L=1,2
29857                 MEC(L,I,J,K)=ZERO
29858               ENDDO
29859             ENDDO
29860           ENDDO
29861         ENDDO
29862 C--Multichannel peak
29863         RAND=HWRUNI(0,ZERO,ONE)
29864         DO I=1,12
29865           IF(CHAN(I).GT.RAND) GOTO 25
29866           RAND=RAND-CHAN(I)
29867         ENDDO
29868  25     GENR=I
29869 C--Calculate the hard scale and obtain parton distributions
29870         TAUA   = MS2(GENR)/S
29871         TAUB   = SWD(GENR)**2/S
29872         RTAB   = SQRT(TAUA*TAUB)
29873         XUPP = XMAX
29874         IF(XMAX**2.GT.S) XUPP = SQRT(S)
29875         LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
29876         UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
29877         TAU    = HWRUNI(0,LOWTLM,UPPTLM)
29878         TAU    = RTAB*TAN(RTAB*TAU)+TAUA
29879         SH   = S*TAU
29880         SQSH = SQRT(SH)
29881         EMSCA  = SQSH
29882         XX(1)  = EXP(HWRUNI(0,ZERO,LOG(TAU)))
29883         XX(2)  = TAU/XX(1)
29884         CALL HWSGEN(.FALSE.)
29885 C--Strong, EM coupling and weak couplings
29886         AS = HWUALF(1,EMSCA)
29887         EC = SQRT(4*PIFAC*HWUAEM(SH))
29888         G  = EC/SW
29889 C--Calculate the prefactor due multichannel approach
29890         FAC = ZERO
29891         DO GN=1,12
29892          SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
29893          FAC=FAC+CHAN(GN)*SCF(GN)
29894         ENDDO
29895         FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
29896      &        /(48*PIFAC*SQSH*SH*TAU*FAC*S**2)
29897       ENDIF
29898       HCS = ZERO
29899       IF(.NOT.NEUT) GOTO 200
29900       DO 140 GN=1,6
29901         GR=2*GN
29902         IF(CHAN(GR).LT.EPS) GOTO 140
29903         DO 130 L=SPMN,SPMX
29904           K = 2*GN+5
29905           IF(GN.GT.3) K = 2*GN
29906           MQ = RMASS(K)
29907           MN = ABS(RMASS(448+L))
29908           MQS = MQ**2
29909           MNS = MN**2
29910           IF(SQSH.LT.(MQ+MN)) GOTO 130
29911           PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
29912           ECM=SQRT(PCM**2+MQS)
29913           TH = MQS-SQSH*(ECM-PCM*COSTH)
29914           UH = MQS-SQSH*(ECM+PCM*COSTH)
29915           DO I=1,3
29916             DO 120 J=1,3
29917               IF(GN.LE.3) THEN
29918                 GU = 6+2*I
29919                 I1 = 2*I
29920                 LAMC(1) = LAMDA3(I,J,GN)**2
29921               ELSE
29922                 GU = 2*I
29923                 I1 = 2*I-1
29924                 LAMC(1) = LAMDA3(GN-3,I,J)**2
29925                 IF(J.GT.I) LAMC(1) = ZERO
29926               ENDIF
29927               GT = 2*J
29928               J1 = 2*J-1
29929 C--Now the matrix elements
29930               IF(LAMC(1).LT.EPS) GOTO 120
29931               IF(GENEV) GOTO 110
29932 C--S channel
29933               ME(3) = MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*(A(L,GR)**2+
29934      &                 B(L,GR)**2)-4*MQ*MN*A(L,GR)*B(L,GR))
29935               ME(4) =-TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*A(L,GU)
29936      &                 /(TH-MS2(GT))/(UH-MS2(GU))
29937      &               +TWO*MX(GR)*MX(GU)*(SH-MS2(GR))*SCF(GR)*SH*
29938      &                 A(L,GU)*(A(L,GR)*UH+B(L,GR)*MQ*MN)/(UH-MS2(GU))
29939      &               +TWO*MX(GR)*MX(GT)*(SH-MS2(GR))*SCF(GR)*SH*
29940      &                 A(L,GT)*(A(L,GR)*TH+B(L,GR)*MQ*MN)/(TH-MS2(GT))
29941 C--L/R s channel and interference
29942               IF(ABS(MX(GR-1)).GT.EPS) THEN
29943                 ME(3) = ME(3)+
29944      &             MX(GR-1)**2*SCF(GR-1)*SH*((SH-MQS-MNS)*(A(L,GR-1)**2
29945      &                +B(L,GR-1)**2)-4*MQ*MN*A(L,GR-1)*B(L,GR-1))
29946      &            +TWO*MX(GR)*MX(GR-1)*SCF(GR)*SCF(GR-1)*SH*
29947      &                ((SH-MS2(GR))*(SH-MS2(GR-1))+MSWD(GR)*MSWD(GR-1))*
29948      &                ((SH-MQS-MNS)*(A(L,GR)*A(L,GR-1)
29949      &                +B(L,GR)*B(L,GR-1))
29950      &                -TWO*MQ*MN*(A(L,GR)*B(L,GR-1)+A(L,GR-1)*B(L,GR)))
29951                ME(4) = ME(4)+TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))
29952      &           *SCF(GR-1)*A(L,GU)*SH*(A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)
29953      &            /(UH-MS2(GU))
29954      &          +TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*SH*
29955      &            A(L,GT)*(A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT))
29956                 IF(ABS(MX(GU-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
29957      &                MX(GU-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GU-1)*SH*(
29958      &                A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)/(UH-MS2(GU-1))
29959                 IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
29960      &                MX(GT-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GT-1)*SH*
29961      &                (A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT-1))
29962               ENDIF
29963 C--u channel and L/R mixing
29964               ME(1)= MX(GU)**2*(MQS-UH)*(MNS-UH)*
29965      &               (A(L,GU)**2+B(L,GU)**2)/(UH-MS2(GU))**2
29966               IF(ABS(MX(GU-1)).GT.EPS) THEN
29967                 ME(1) = ME(1)+MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
29968      &                   (A(L,GU-1)**2+B(L,GU-1)**2)/(UH-MS2(GU-1))**2
29969      &                 +TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
29970      &                   (A(L,GU)*A(L,GU-1)+B(L,GU)*B(L,GU-1))
29971      &                   /(UH-MS2(GU))/(UH-MS2(GU-1))
29972                 ME(4) =ME(4)+TWO*MX(GR)*MX(GU-1)*(SH-MS2(GR))*
29973      &                   SCF(GR)*A(L,GU-1)*SH*(A(L,GR)*UH+B(L,GR)*MQ*MN)
29974      &                   /(UH-MS2(GU-1))
29975      &                -2*MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*
29976      &                   A(L,GU-1)/(TH-MS2(GT))/(UH-MS2(GU-1))
29977                 IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)-2*MX(GU-1)*MX(GT-1)
29978      &               *(MQS*MNS-UH*TH)*A(L,GT-1)*A(L,GU-1)
29979      &               /(TH-MS2(GT-1))/(UH-MS2(GU-1))
29980               ENDIF
29981 C--t channel and t channel L/R mixing
29982               ME(2) = MX(GT)**2*(MQS-TH)*(MNS-TH)*
29983      &                  (A(L,GT)**2+B(L,GT)**2)/(TH-MS2(GT))**2
29984               IF(ABS(MX(GT-1)).GT.EPS) THEN
29985                 ME(2) = ME(2)+MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
29986      &                   (A(L,GT-1)**2+B(L,GT-1)**2)/(TH-MS2(GT-1))**2
29987      &                 +TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*(A(L,GT)*
29988      &                   A(L,GT-1)+ B(L,GT)*B(L,GT-1))
29989      &                   /(TH-MS2(GT))/(TH-MS2(GT-1))
29990                 ME(4)=ME(4)-TWO*MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*
29991      &                 A(L,GT-1)*A(L,GU)/(TH-MS2(GT-1))/(UH-MS2(GU))
29992      &               +TWO*MX(GR)*MX(GT-1)*(SH-MS2(GR))*SCF(GR)*
29993      &                 A(L,GT-1)*SH*(A(L,GR)*TH+B(L,GR)*MQ*MN)
29994      &                 /(TH-MS2(GT-1))
29995               ENDIF
29996 C--Angular ordering and the phase space factors
29997               IF(L.EQ.1) THEN
29998                ME(4)=-HALF*ME(4)/(ME(1)+ME(2)+ME(3))
29999                LAMC(1) = 32.0D0*LAMC(1)*AS*PIFAC/THREE
30000                DO GEN=1,3
30001                  MEN(GEN,GN,I,J) = FAC*PCM*LAMC(1)*ME(GEN)*(ONE+ME(4))
30002                ENDDO
30003               ELSE
30004                LAMC(1) = TWO*LAMC(1)*EC**2
30005                MEN(L+2,GN,I,J)=FAC*PCM*LAMC(1)*(ME(1)+ME(2)+ME(3)+ME(4))
30006               ENDIF
30007 C--Multiply by the pdf's
30008  110          IF(L.EQ.1) THEN
30009                 CM = 1
30010                 CN = 3
30011               ELSE
30012                 CM = L+2
30013                 CN = L+2
30014               ENDIF
30015               DO GEN=CM,CN
30016               CON = 4
30017               IF(GEN.LE.3) CON = GEN
30018            HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1,1)*DISF(J1,2)
30019            IF(GENEV.AND.HCS.GT.RCS) THEN
30020              CALL HWHRSS(3,I1,J1,K,GEN,0,0)
30021              GOTO 900
30022            ENDIF
30023            HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1,1)*DISF(I1,2)
30024            IF(GENEV.AND.HCS.GT.RCS) THEN
30025              CALL HWHRSS(4,J1,I1,K,GEN,0,0)
30026              GOTO 900
30027            ENDIF
30028            HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
30029            IF(GENEV.AND.HCS.GT.RCS) THEN
30030              CALL HWHRSS(3,I1,J1,K,GEN,1,0)
30031              GOTO 900
30032            ENDIF
30033            HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
30034            IF(GENEV.AND.HCS.GT.RCS) THEN
30035              CALL HWHRSS(4,J1,I1,K,GEN,1,0)
30036              GOTO 900
30037            ENDIF
30038               ENDDO
30039  120        CONTINUE
30040           ENDDO
30041  130    CONTINUE
30042  140  CONTINUE
30043 C--Now the chargino processes if wanted
30044  200  IF(.NOT.CHAR) GOTO 300
30045         DO 240 GN=1,6
30046           GR=2*GN
30047           IF(CHAN(GR).LT.EPS) GOTO 240
30048           DO 230 L=CHARMN,CHARMX
30049           SP =5+L
30050           K = 2*GN+6
30051           IF(GN.GT.3) K = 2*GN-1
30052           MQ = RMASS(K)
30053           MN = ABS(RMASS(453+L))
30054           MQS = MQ**2
30055           MNS = MN**2
30056           IF(SQSH.LT.(MQ+MN)) GOTO 230
30057           PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
30058           ECM=SQRT(PCM**2+MQS)
30059           TH = MQS-SQSH*(ECM-PCM*COSTH)
30060           UH = MQS-SQSH*(ECM+PCM*COSTH)
30061           DO I=1,3
30062             DO 220 J=1,3
30063               IF(GN.LE.3) THEN
30064                 GU = 2*I
30065                 GT = 14
30066                 I1 = 2*I
30067                 LAMC(1) = LAMDA3(I,J,GN)
30068                 LAMC(2) = LAMDA3(GN,I,J)
30069                 LAMC(3) = ZERO
30070               ELSE
30071                 GU = 6+2*I
30072                 GT = 6+2*J
30073                 I1 = 2*I-1
30074                 LAMC(1) = LAMDA3(GN-3,I,J)
30075                 LAMC(2) = LAMDA3(I,J,GN-3)
30076                 LAMC(3) = LAMDA3(J,GN-3,I)
30077                 IF(J.GT.I) LAMC(1) = ZERO
30078               ENDIF
30079               J1 = 2*J-1
30080               IF(ABS(LAMC(1)).LT.EPS) GOTO 220
30081               IF(GENEV) GOTO 210
30082 C--Matrix element
30083 C--S channel
30084               ME(1) = LAMC(1)**2*MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*
30085      &              (A(SP,GR)**2+B(SP,GR)**2)-4*MQ*MN*A(SP,GR)*B(SP,GR))
30086               IF(ABS(MX(GU)).GT.EPS) THEN
30087                 ME(1) = ME(1)+LAMC(2)**2*MX(GU)**2*(MQS-UH)*(MNS-UH)*
30088      &                       (A(SP,GU)**2+B(SP,GU)**2)/(UH-MS2(GU))**2
30089      &                 +LAMC(1)*LAMC(2)*TWO*MX(GR)*MX(GU)*
30090      &                       (SH-MS2(GR))*SCF(GR)*A(SP,GU)*SH*
30091      &                       (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU))
30092                 IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)-LAMC(2)*LAMC(3)*
30093      &                       TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*
30094      &                       A(SP,GU)/(TH-MS2(GT))/(UH-MS2(GU))
30095              ENDIF
30096              IF(ABS(MX(GT)).GT.EPS) THEN
30097                ME(1) = ME(1)+LAMC(3)**2*MX(GT)**2*(MQS-TH)*(MNS-TH)*
30098      &                       (A(SP,GT)**2+B(SP,GT)**2)/(TH-MS2(GT))**2
30099      &                +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT)*
30100      &                       (SH-MS2(GR))*SCF(GR)*A(SP,GT)*SH*
30101      &                       (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT))
30102              ENDIF
30103 c--L/R s channel and interference
30104               IF(ABS(MX(GR-1)).GT.EPS) THEN
30105                 ME(1) = ME(1)+LAMC(1)**2*MX(GR-1)**2*SCF(GR-1)*SH*
30106      &                       ((SH-MQS-MNS)*(A(SP,GR-1)**2+B(SP,GR-1)**2)
30107      &                       -4*MQ*MN*A(SP,GR-1)*B(SP,GR-1))
30108      &                 +LAMC(1)**2*TWO*MX(GR)*MX(GR-1)*SCF(GR)*
30109      &                       SCF(GR-1)*SH*
30110      &                       ((SH-MS2(GR))*(SH-MS2(GR-1))+
30111      &                       MSWD(GR)*MSWD(GR-1))*
30112      &                       ((SH-MQS-MNS)*(A(SP,GR)*A(SP,GR-1)+
30113      &                       B(SP,GR)*B(SP,GR-1))-TWO*MQ*MN*
30114      &                       (A(SP,GR)*B(SP,GR-1)+A(SP,GR-1)*B(SP,GR)))
30115                  IF(ABS(MX(GU)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(2)*
30116      &                   TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))*SCF(GR-1)*
30117      &                   A(SP,GU)*SH*(A(SP,GR-1)*UH+B(SP,GR-1)*MQ*MN)
30118      &                   /(UH-MS2(GU))
30119                  IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(3)*
30120      &                   TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*
30121      &                   A(SP,GT)*SH*(A(SP,GR-1)*TH+B(SP,GR-1)*MQ*MN)
30122      &                   /(TH-MS2(GT))
30123                  IF(ABS(MX(GU-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(2)*
30124      &                   TWO*MX(GR-1)*MX(GU-1)*(SH-MS2(GR-1))*
30125      &                   SCF(GR-1)*A(SP,GU-1)*SH*(A(SP,GR-1)*UH+
30126      &                   B(SP,GR-1)*MQ*MN)/(UH-MS2(GU-1))
30127                 IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(3)*
30128      &                   TWO*MX(GR-1)*MX(GT-1)*(SH-MS2(GR-1))*
30129      &                   SCF(GR-1)*A(SP,GT-1)*SH*(A(SP,GR-1)*TH+
30130      &                    B(SP,GR-1)*MQ*MN)/(TH-MS2(GT-1))
30131               ENDIF
30132 C--u channel and L/R mixing
30133               IF(ABS(MX(GU-1)).GT.EPS) THEN
30134                 ME(1) = ME(1)+LAMC(2)**2*MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
30135      &                 (A(SP,GU-1)**2+B(SP,GU-1)**2)/(UH-MS2(GU-1))**2
30136      &             +LAMC(2)**2*TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
30137      &                 (A(SP,GU)*A(SP,GU-1)+B(SP,GU)*B(SP,GU-1))
30138      &                 /(UH-MS2(GU))/(UH-MS2(GU-1))
30139      &             +TWO*LAMC(1)*LAMC(2)*MX(GR)*MX(GU-1)*
30140      &                 (SH-MS2(GR))*SCF(GR)*A(SP,GU-1)*SH*
30141      &                 (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU-1))
30142                 IF(ABS(MX(GT)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
30143      &               MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*A(SP,GU-1)
30144      &               /(TH-MS2(GT))/(UH-MS2(GU-1))
30145                 IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*
30146      &               TWO*MX(GU-1)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*
30147      &               A(SP,GU-1)/(TH-MS2(GT-1))/(UH-MS2(GU-1))
30148               ENDIF
30149 C--t channel and t channel L/R mixing
30150              IF(ABS(MX(GT-1)).GT.EPS) THEN
30151                 ME(1) = ME(1)+LAMC(3)**2*MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
30152      &                 (A(SP,GT-1)**2+B(SP,GT-1)**2)/(TH-MS2(GT-1))**2
30153      &              +LAMC(3)**2*TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*
30154      &                 (A(SP,GT)*A(SP,GT-1)+B(SP,GT)*B(SP,GT-1))
30155      &                 /(TH-MS2(GT))/(TH-MS2(GT-1))
30156      &              +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT-1)*
30157      &                 (SH-MS2(GR))*SCF(GR)*A(SP,GT-1)*SH*
30158      &                 (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT-1))
30159                 IF(ABS(MX(GU)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
30160      &               MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*A(SP,GU)
30161      &               /(TH-MS2(GT-1))/(UH-MS2(GU))
30162               ENDIF
30163 c--phase space factors
30164               MEC(L,GN,I,J) = G**2*FAC*ME(1)*PCM
30165  210       CON = 4
30166            I2 = SP+2
30167            IF(MOD(K,2).EQ.1) I2 =I2+2
30168            HCS=HCS+MEC(L,GN,I,J)*DISF(I1,1)*DISF(J1,2)
30169            IF(GENEV.AND.HCS.GT.RCS) THEN
30170              CALL HWHRSS(3,I1,J1,K,I2,0,0)
30171              GOTO 900
30172            ENDIF
30173            HCS=HCS+MEC(L,GN,I,J)*DISF(J1,1)*DISF(I1,2)
30174            IF(GENEV.AND.HCS.GT.RCS) THEN
30175              CALL HWHRSS(4,J1,I1,K,I2,0,0)
30176              GOTO 900
30177            ENDIF
30178            HCS=HCS+MEC(L,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
30179            IF(GENEV.AND.HCS.GT.RCS) THEN
30180              CALL HWHRSS(3,I1,J1,K,I2+2,1,0)
30181              GOTO 900
30182            ENDIF
30183            HCS=HCS+MEC(L,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
30184            IF(GENEV.AND.HCS.GT.RCS) THEN
30185              CALL HWHRSS(4,J1,I1,K,I2+2,1,0)
30186              GOTO 900
30187            ENDIF
30188  220       CONTINUE
30189           ENDDO
30190  230      CONTINUE
30191  240      CONTINUE
30192 C--Now the radiative decays, if possible
30193  300  IF(.NOT.RAD.OR.(CHAN(5).LT.EPS.AND.CHAN(11).LT.EPS)) GOTO 400
30194       IF(GENEV) GOTO 320
30195       DO 310 I=1,6
30196  310  MER(I)=ZERO
30197 C--stop to light stop and Z
30198       IF(SH.GT.(MZ+MS(11))**2) THEN
30199         PCM = SQRT((SH-(MZ+MS(11))**2)*(SH-(MZ-MS(11))**2))*HALF/SQSH
30200         ECM=SQRT(PCM**2+MZ2)
30201         TH = MZ2-SQSH*(ECM-PCM*COSTH)
30202         UH = MZ2-SQSH*(ECM+PCM*COSTH)
30203         MER(3) = SH**2*PCM**2*(SCF(11)*ZSQU(2,1)**2*QMIXSS(6,2,1)**2
30204      &             +SCF(12)*ZSQU(2,2)**2*QMIXSS(6,2,2)**2
30205      &             +TWO*SCF(11)*SCF(12)*QMIXSS(6,2,1)*QMIXSS(6,2,2)*
30206      &                ZSQU(2,1)*ZSQU(2,2)*((SH-MS2(11))*
30207      &                (SH-MS2(12))+MSWD(11)*MSWD(12)))
30208      &       +QMIXSS(6,2,1)**2/UH**2*ZQRK(1)**2*(
30209      &             TWO*MZ2*(UH*TH-MS2(11)*MZ2)+UH**2*SH)
30210      &       +QMIXSS(6,2,1)**2/TH**2*ZQRK(1)**2*(
30211      &             TWO*MZ2*(UH*TH-MS2(11)*MZ2)+TH**2*SH)
30212      &       +ZQRK(1)*SH*QMIXSS(6,2,1)*
30213      &            (QMIXSS(6,2,1)*ZSQU(2,1)*(SH-MS2(11))*SCF(11)
30214      &            +QMIXSS(6,2,2)*ZSQU(2,2)*(SH-MS2(12))*SCF(12))
30215      &            *((MZ2*(TWO*MS2(11)-TH)+TH*(SH-MS2(11)))/TH
30216      &             +(MZ2*(TWO*MS2(11)-UH)+UH*(SH-MS2(11)))/UH)
30217      &       -TWO*QMIXSS(6,2,1)**2/UH/TH*ZQRK(1)**2*
30218      &            (TWO*MZ2*(MS2(11)-UH)*(MS2(11)-TH)-SH*TH*UH)
30219         MER(3) = MER(3)*FOUR*PCM/MZ2
30220       ENDIF
30221 C--sbottom to light sbottom and Z
30222       IF(SH.GT.(MZ+MS(5))**2) THEN
30223         PCM = SQRT((SH-(MZ+MS(5))**2)*(SH-(MZ-MS(5))**2))*HALF/SQSH
30224         ECM=SQRT(PCM**2+MZ2)
30225         TH = MZ2-SQSH*(ECM-PCM*COSTH)
30226         UH = MZ2-SQSH*(ECM+PCM*COSTH)
30227         MER(6) = SH**2*PCM**2*(SCF(5)*QMIXSS(5,2,1)**2*ZSQU(1,1)**2
30228      &                +SCF(6)*QMIXSS(5,2,2)**2*ZSQU(1,2)**2
30229      &                +TWO*SCF(5)*SCF(6)*QMIXSS(5,2,1)*QMIXSS(5,2,2)*
30230      &                 ZSQU(1,1)*ZSQU(1,2)*((SH-MS2(5))*
30231      &                 (SH-MS2(6))+MSWD(5)*MSWD(6)))
30232      &       +QMIXSS(5,2,1)**2/UH**2*ZQRK(1)**2*
30233      &           (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+UH**2*SH)
30234      &       +QMIXSS(5,2,1)**2/TH**2*ZQRK(2)**2*
30235      &           (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+TH**2*SH)
30236      &       +QMIXSS(5,2,1)*SH*
30237      &           (QMIXSS(5,2,1)*ZSQU(1,1)*(SH-MS2(5))*SCF(5)
30238      &           +QMIXSS(5,2,2)*ZSQU(1,2)*(SH-MS2(6))*SCF(6))*
30239      &            (ZQRK(1)/UH*(MZ2*(TWO*MS2(5)-UH)+(SH-MS2(5))*UH)
30240      &            +ZQRK(2)/TH*(MZ2*(TWO*MS2(5)-TH)+(SH-MS2(5))*TH))
30241      &       -TWO*QMIXSS(5,2,1)**2*ZQRK(1)*ZQRK(2)/UH/TH*
30242      &            (TWO*MZ2*(MS2(5)-UH)*(MS2(5)-TH)-SH*TH*UH)
30243         MER(6) = MER(6)*FOUR*PCM/MZ2
30244       ENDIF
30245 C--stop to sbottom and W
30246       DO J=1,2
30247         IF(SH.GT.(MW+MS(4+J))**2) THEN
30248           PCM =SQRT((SH-(MW+MS(4+J))**2)*(SH-(MW-MS(4+J))**2))*HALF/SQSH
30249 C--diagram square pieces
30250           DO I=1,2
30251             MER(J)=MER(J)+SCF(10+I)*
30252      &             (QMIXSS(6,2,I)*QMIXSS(6,1,I)*QMIXSS(5,1,J))**2
30253           ENDDO
30254 C--light/heavy interference
30255           MER(J)=TWO*SH**2*PCM**3/MW2*(MER(J)+TWO*SCF(11)*SCF(12)*
30256      &          ((SH-MS2(11))*(SH-MS2(12))
30257      &          +MSWD(11)*MSWD(12))*QMIXSS(5,1,J)**2*
30258      &          QMIXSS(6,2,1)*QMIXSS(6,2,2)*QMIXSS(6,1,1)*QMIXSS(6,1,2))
30259         ENDIF
30260 C--sbottom to stop and W
30261         IF(SH.GT.(MW+MS(10+J))**2) THEN
30262          PCM=SQRT((SH-(MW+MS(10+J))**2)*(SH-(MW-MS(10+J))**2))*HALF/SQSH
30263 C--diagram square pieces
30264           DO I=1,2
30265             MER(J+3)=MER(J+3)+SCF(4+I)*
30266      &           (QMIXSS(5,2,I)*QMIXSS(5,1,I)*QMIXSS(6,1,J))**2
30267           ENDDO
30268 C--light/heavy interference
30269           MER(J+3)=TWO*SH**2*PCM**3/MW2*(MER(J+3)+TWO*SCF(5)*SCF(6)*
30270      &          ((SH-MS2(5))*(SH-MS2(6))+
30271      &          MSWD(5)*MSWD(6))*QMIXSS(6,1,J)**2*
30272      &          QMIXSS(5,2,1)*QMIXSS(5,2,2)*QMIXSS(5,1,1)*QMIXSS(5,1,2))
30273         ENDIF
30274       ENDDO
30275 C--Now multiply by the parton distributions and phase space factors
30276  320  DO J=1,3
30277         DO K=1,3
30278           CON = 5
30279 C--resonant stop's
30280           IF(ABS(LAMDA3(3,J,K)).GT.EPS.AND.J.LT.K) THEN
30281             FAC2 = LAMDA3(3,J,K)**2*FAC*G**2
30282             DO I=1,3
30283             I1=2*J-1
30284             J1=2*K-1
30285             ME2 = MER(I)*FAC2
30286             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30287             IF(GENEV.AND.HCS.GT.RCS) THEN
30288               CALL HWHRSS(5,I1,J1,I,I,0,0)
30289               GOTO 900
30290             ENDIF
30291             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30292             IF(GENEV.AND.HCS.GT.RCS) THEN
30293               CALL HWHRSS(6,J1,I1,I,I,0,0)
30294               GOTO 900
30295             ENDIF
30296             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30297             IF(GENEV.AND.HCS.GT.RCS) THEN
30298               CALL HWHRSS(5,I1,J1,I,I,1,0)
30299               GOTO 900
30300             ENDIF
30301             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30302             IF(GENEV.AND.HCS.GT.RCS) THEN
30303               CALL HWHRSS(6,J1,I1,I,I,1,0)
30304               GOTO 900
30305             ENDIF
30306             ENDDO
30307           ENDIF
30308 C--resonant sbottom's
30309           IF(ABS(LAMDA3(J,K,3)).GT.EPS) THEN
30310             FAC2 = LAMDA3(J,K,3)**2*FAC*G**2
30311             DO I=4,6
30312             I1=2*J
30313             J1=2*K-1
30314             ME2 = MER(I)*FAC2
30315             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30316             IF(GENEV.AND.HCS.GT.RCS) THEN
30317               CALL HWHRSS(5,I1,J1,I,I,0,0)
30318               GOTO 900
30319             ENDIF
30320             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30321             IF(GENEV.AND.HCS.GT.RCS) THEN
30322               CALL HWHRSS(6,J1,I1,I,I,0,0)
30323               GOTO 900
30324             ENDIF
30325             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30326             IF(GENEV.AND.HCS.GT.RCS) THEN
30327               CALL HWHRSS(5,I1,J1,I,I,1,0)
30328               GOTO 900
30329             ENDIF
30330             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30331             IF(GENEV.AND.HCS.GT.RCS) THEN
30332               CALL HWHRSS(6,J1,I1,I,I,1,0)
30333               GOTO 900
30334             ENDIF
30335             ENDDO
30336           ENDIF
30337         ENDDO
30338       ENDDO
30339 C--Now the Higgs decays if possible
30340  400  IF(.NOT.HIGGS) GOTO 900
30341       IF(GENEV) GOTO 490
30342       DO I=1,3
30343          DO 405 J=1,42
30344  405        MEH(I,J) = ZERO
30345       ENDDO
30346       DO I=1,3
30347         DO 420 J=1,3
30348 C--Neutral Higgs down type squark
30349         IF(SQSH.LT.MH(J)+MS(2*I-1)) GOTO 410
30350         PCM = SQRT((SH-(MH(J)+MS(2*I-1))**2)*
30351      &             (SH-(MH(J)-MS(2*I-1))**2))*HALF/SQSH
30352         ECM=SQRT(PCM**2+MH(J)**2)
30353         TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
30354         UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
30355         MEH(1,3*I-3+J) = PCM*SH*(
30356      &            QMIXSS(2*I-1,2,1)**2*SCF(2*I-1)*GHSQSS(J,2*I-1,1,1)**2
30357      &             +QMIXSS(2*I-1,2,2)**2*SCF(2*I)*GHSQSS(J,2*I-1,2,1)**2
30358      &              +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
30359      &               *SCF(2*I)*GHSQSS(J,2*I-1,1,1)*GHSQSS(J,2*I-1,2,1)*
30360      &            ((SH-MS2(2*I-1))*(SH-MS2(2*I))+MSWD(2*I-1)*MSWD(2*I)))
30361         MEH(2,3*I-3+J) = PCM*GUU(J)*QMIXSS(2*I,2,1)**2/TH**2*
30362      &                   (TH*UH-MH(J)**2*MS2(2*I-1))
30363         MEH(3,3*I-3+J) = PCM*GDD(J)*QMIXSS(2*I,2,1)**2/UH**2*
30364      &                   (TH*UH-MH(J)**2*MS2(2*I-1))
30365 C--Neutral Higgs up type squarks
30366  410    IF(SQSH.LT.MH(J)+MS(2*I+5)) GOTO 420
30367         PCM = SQRT((SH-(MH(J)+MS(2*I+5))**2)*
30368      &             (SH-(MH(J)-MS(2*I+5))**2))*HALF/SQSH
30369         ECM=SQRT(PCM**2+MH(J)**2)
30370         TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
30371         UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
30372         MEH(1,3*I+6+J) = PCM*SH*(
30373      &               QMIXSS(2*I,2,1)**2*SCF(2*I+5)*GHSQSS(J,2*I,1,1)**2
30374      &              +QMIXSS(2*I,2,2)**2*SCF(2*I+6)*GHSQSS(J,2*I,2,1)**2
30375      &              +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
30376      &               *SCF(2*I+6)*GHSQSS(J,2*I,1,1)*GHSQSS(J,2*I,2,1)*
30377      &              ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
30378      &               MSWD(2*I+5)*MSWD(2*I+6)))
30379         MEH(2,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/TH**2*
30380      &                   (TH*UH-MH(J)**2*MS2(2*I+5))
30381         MEH(3,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/UH**2*
30382      &                   (TH*UH-MH(J)**2*MS2(2*I+5))
30383  420    CONTINUE
30384 C--Charged Higgs up type squark
30385         DO 440 J=1,2
30386         IF(SQSH.LT.MH(4)+MS(2*I+4+J)) GOTO 430
30387         PCM = SQRT((SH-(MH(4)+MS(2*I+4+J))**2)*
30388      &             (SH-(MH(4)-MS(2*I+4+J))**2))*HALF/SQSH
30389         ECM=SQRT(PCM**2+MH(4)**2)
30390         TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
30391         UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
30392         MEH(1,4*I+14+J) = PCM*SH*(
30393      &              QMIXSS(2*I-1,2,1)**2*GHSQSS(4,2*I,J,1)**2*SCF(2*I-1)
30394      &             +QMIXSS(2*I-1,2,2)**2*GHSQSS(4,2*I,J,2)**2*SCF(2*I)
30395      &              +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
30396      &               *SCF(2*I)*GHSQSS(4,2*I,J,1)*GHSQSS(4,2*I,J,2)*
30397      &              ((SH-MS2(2*I-1))*(SH-MS2(2*I))+
30398      &                   MSWD(2*I-1)*MSWD(2*I)))
30399         MEH(2,4*I+14+J) = PCM*QMIXSS(2*I,2,J)**2*GDD(4)/TH**2*
30400      &                    (UH*TH-MS2(2*I+4+J)*MH(4)**2)
30401 C--Charged Higgs down type squark
30402  430    IF(SQSH.LT.MH(4)+MS(2*I-2+J)) GOTO 440
30403         PCM = SQRT((SH-(MH(4)+MS(2*I-2+J))**2)*
30404      &             (SH-(MH(4)-MS(2*I-2+J))**2))*HALF/SQSH
30405         ECM=SQRT(PCM**2+MH(4)**2)
30406         TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
30407         UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
30408         MEH(1,4*I+16+J) = PCM*SH*(
30409      &              QMIXSS(2*I,2,1)**2*GHSQSS(4,2*I-1,J,1)**2*SCF(2*I+5)
30410      &             +QMIXSS(2*I,2,2)**2*GHSQSS(4,2*I-1,J,2)**2*SCF(2*I+6)
30411      &              +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
30412      &              *SCF(2*I+6)*GHSQSS(4,2*I-1,J,1)*GHSQSS(4,2*I-1,J,2)*
30413      &              ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
30414      &              MSWD(2*I+5)*MSWD(2*I+6)))
30415         MEH(2,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/TH**2*
30416      &                    (UH*TH-MS2(2*I-2+J)*MH(4)**2)
30417         MEH(3,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/UH**2*
30418      &                    (UH*TH-MS2(2*I-2+J)*MH(4)**2)
30419  440    CONTINUE
30420       ENDDO
30421  490  DO I=1,3
30422       DO J=1,3
30423         DO K=1,3
30424           CON = 5
30425           DO L=1,3
30426           IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
30427 C--neutral higgs and sdown
30428             FAC2 = FAC*G**2*LAMDA3(J,K,I)**2
30429             I1=2*J
30430             J1=2*K-1
30431             ME2 = FAC2*(MEH(1,3*I-3+L)+RMASS(I1)**2*MEH(2,3*I-3+L)
30432      &                  +RMASS(J1)**2*MEH(3,3*I-3+L))
30433             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30434             IF(GENEV.AND.HCS.GT.RCS) THEN
30435               CALL HWHRSS(7,I1,J1,L,2*I-1,0,0)
30436               GOTO 900
30437             ENDIF
30438             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30439             IF(GENEV.AND.HCS.GT.RCS) THEN
30440               CALL HWHRSS(8,J1,I1,L,2*I-1,0,0)
30441               GOTO 900
30442             ENDIF
30443             IF(I2.NE.200) I2=198
30444             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30445             IF(GENEV.AND.HCS.GT.RCS) THEN
30446               CALL HWHRSS(7,I1,J1,L,2*I-1,1,0)
30447               GOTO 900
30448             ENDIF
30449             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30450             IF(GENEV.AND.HCS.GT.RCS) THEN
30451               CALL HWHRSS(8,J1,I1,L,2*I-1,1,0)
30452               GOTO 900
30453             ENDIF
30454           ENDIF
30455           IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
30456             FAC2 = FAC*G**2*LAMDA3(I,J,K)**2
30457 C--neutral higgs and sup
30458             I1=2*J-1
30459             J1=2*K-1
30460             ME2 = FAC2*(MEH(1,3*I+6+L)+RMASS(I1)**2*MEH(2,3*I+6+L)
30461      &                  +RMASS(J1)**2*MEH(3,3*I+6+L))
30462             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30463             IF(GENEV.AND.HCS.GT.RCS) THEN
30464               CALL HWHRSS(7,I1,J1,L,2*I+5,0,0)
30465               GOTO 900
30466             ENDIF
30467             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30468             IF(GENEV.AND.HCS.GT.RCS) THEN
30469               CALL HWHRSS(8,J1,I1,L,2*I+5,0,0)
30470               GOTO 900
30471             ENDIF
30472             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30473             IF(GENEV.AND.HCS.GT.RCS) THEN
30474               CALL HWHRSS(7,I1,J1,L,2*I+5,1,0)
30475               GOTO 900
30476             ENDIF
30477             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30478             IF(GENEV.AND.HCS.GT.RCS) THEN
30479               CALL HWHRSS(8,J1,I1,L,2*I+5,1,0)
30480               GOTO 900
30481             ENDIF
30482           ENDIF
30483           ENDDO
30484           DO L=1,2
30485           IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
30486 C--charged higgs and sup
30487             I1=2*J
30488             J1=2*K-1
30489             FAC2 = FAC*G**2
30490             ME2 = FAC2*(LAMDA3(J,K,I)**2*MEH(1,4*I+L+14)
30491      &                 +LAMDA3(I,J,K)**2*RMASS(I1-1)**2*MEH(2,4*I+L+14))
30492             HCS= HCS+ME2*DISF(I1,1)*DISF(J1,2)
30493             IF(GENEV.AND.HCS.GT.RCS) THEN
30494               CALL HWHRSS(7,I1,J1,4,2*I+4+L,0,0)
30495               GOTO 900
30496             ENDIF
30497             HCS= HCS+ME2*DISF(J1,1)*DISF(I1,2)
30498             IF(GENEV.AND.HCS.GT.RCS) THEN
30499               CALL HWHRSS(8,J1,I1,4,2*I+4+L,0,0)
30500               GOTO 900
30501             ENDIF
30502             HCS= HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30503             IF(GENEV.AND.HCS.GT.RCS) THEN
30504               CALL HWHRSS(7,I1,J1,5,2*I+4+L,1,0)
30505               GOTO 900
30506             ENDIF
30507             HCS= HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30508             IF(GENEV.AND.HCS.GT.RCS) THEN
30509               CALL HWHRSS(8,J1,I1,5,2*I+4+L,1,0)
30510               GOTO 900
30511             ENDIF
30512           ENDIF
30513 C--charged higgs and sdown
30514           IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
30515             I1=2*J-1
30516             J1=2*K-1
30517             FAC2 = FAC*G**2
30518             ME2 = FAC2*(MEH(1,4*I+L+16)*LAMDA3(I,J,K)**2
30519      &                 +RMASS(I1+1)**2*LAMDA3(J,I,K)**2*MEH(2,4*I+L+16)
30520      &                 +RMASS(J1+1)**2*LAMDA3(K,I,J)**2*MEH(3,4*I+L+16))
30521             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30522             IF(GENEV.AND.HCS.GT.RCS) THEN
30523               CALL HWHRSS(7,I1,J1,5,2*I-2+L,0,0)
30524               GOTO 900
30525             ENDIF
30526             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30527             IF(GENEV.AND.HCS.GT.RCS) THEN
30528               CALL HWHRSS(8,J1,I1,5,2*I-2+L,0,0)
30529               GOTO 900
30530             ENDIF
30531             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30532             IF(GENEV.AND.HCS.GT.RCS) THEN
30533               CALL HWHRSS(7,I1,J1,4,2*I-2+L,1,0)
30534               GOTO 900
30535             ENDIF
30536             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30537             IF(GENEV.AND.HCS.GT.RCS) THEN
30538               CALL HWHRSS(8,J1,I1,4,2*I-2+L,1,0)
30539               GOTO 900
30540             ENDIF
30541           ENDIF
30542           ENDDO
30543         ENDDO
30544       ENDDO
30545       ENDDO
30546 C--calculate of the matrix elements
30547  900  IF(GENEV) THEN
30548         CALL HWETWO(.TRUE.,.TRUE.)
30549         IF(IERROR.NE.0) RETURN
30550         HVFCEN = .TRUE.
30551 C--first stage of the colour connection corrections
30552         DO THEP=1,5
30553           IF(THEP.NE.3) THEN
30554             JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP
30555      &                       +CONECT(HWRINT(1,2),THEP,CON)
30556             JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
30557           ENDIF
30558         ENDDO
30559         IF(IDHEP(NHEP-4).LT.0) THEN
30560           JDAHEP(2,NHEP-4)=NHEP-1
30561           JDAHEP(2,NHEP-3)=NHEP-3
30562           JDAHEP(2,NHEP-1)=NHEP-4
30563           IF(CON.EQ.5) JDAHEP(2,NHEP-4)=NHEP
30564           JDAHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
30565         ELSE
30566           JMOHEP(2,NHEP-4)=NHEP-1
30567           JMOHEP(2,NHEP-3)=NHEP-3
30568           JMOHEP(2,NHEP-1)=NHEP-4
30569           IF(CON.EQ.5) JMOHEP(2,NHEP-4)=NHEP
30570           JMOHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
30571         ENDIF
30572         IF(CON.EQ.5) THEN
30573           SP=JDAHEP(2,NHEP)
30574           JDAHEP(2,NHEP) = JDAHEP(2,NHEP-1)
30575           JDAHEP(2,NHEP-1) = SP
30576           SP=JMOHEP(2,NHEP)
30577           JMOHEP(2,NHEP) = JMOHEP(2,NHEP-1)
30578           JMOHEP(2,NHEP-1) = SP
30579         ENDIF
30580         HRDCOL(1,1) = NHEP
30581         HRDCOL(1,2) = NHEP-2
30582       ELSE
30583         EVWGT = HCS
30584       ENDIF
30585       END
30586 CDECK  ID>, HWHREE.
30587 *CMZ :-        -05/04/02  15:40:41  by  Peter Richardson
30588 *-- Author :    Peter Richardson
30589 C-----------------------------------------------------------------------
30590       SUBROUTINE HWHREE
30591 C-----------------------------------------------------------------------
30592 C     SUSY E+E- --> SM PARTICLES VIA RPV
30593 C     MODIFIED TO INCLUDE BEAM POLARIZATION EFFECTS BY PETER RICHARDSON
30594 C-----------------------------------------------------------------------
30595       INCLUDE 'herwig65.inc'
30596       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM,HCS,RCS,FACA,
30597      &                 S,T,PCM,MQ1,MQ2,SP,TP,TPZ,TPN,TPN2,MSL2(3),MZ,
30598      &                 MZ2,MSU2(3,2),MWD(3),GL,GR,GLP,GRP,EC,EE,THTMIN,
30599      &                 MIX(3,2),CFAC,LAM(4,3,3,3,3,3),MET,ME(2,3,3)
30600       DOUBLE COMPLEX FSLL,FSLR,FSRL,FSRR,FTLL,FTLR,FTRL,FTRR,Z,Z0,GZ,
30601      &               SCF(3)
30602       INTEGER I,IHEP,RSID(2),IL,GN,J,K,L,GNMN,GNMX,K1,L1,NTRY,GNR,FID(2)
30603       SAVE HCS,MSL2,MWD,LAM,ME,GL,GR,MZ,MZ2,MSU2,MIX,GNMN,GNMX,IL,RSID,
30604      &     FID
30605       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM
30606       PARAMETER(Z=(0.D0,1.D0),Z0=(0.D0,0.D0))
30607 C--Start of the code
30608       IF(GENEV) THEN
30609         RCS = HCS*HWRGEN(0)
30610       ELSE
30611         IF(FSTWGT) THEN
30612 C--identify the beam particles
30613           IF(ABS(IDHEP(1)).EQ.11) THEN
30614 C--electron beams
30615             RSID(1) = 2
30616             IL = 1
30617           ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
30618 C--muon beams
30619             RSID(1) = 1
30620             IL = 2
30621 C--unrecognized beam particles issue warning
30622           ELSE
30623             CALL HWWARN('HWHREE',500)
30624           ENDIF
30625           RSID(2) = 3
30626 C--masses of the sleptons
30627           DO I=1,3
30628             MSL2(I) = RMASS(424+2*I)
30629             MWD(I)  = MSL2(I)*HBAR/RLTIM(424+2*I)
30630             MSL2(I) = MSL2(I)**2
30631           ENDDO
30632 C--masses and mixings of the t channel squarks
30633           DO I=1,3
30634             MSU2(I,1) = RMASS(400+2*I)
30635             MSU2(I,2) = RMASS(412+2*I)
30636             DO J=1,2
30637               MIX(I,J)  = QMIXSS(2*I,1,J)**2
30638               MSU2(I,J) = MSU2(I,J)**2
30639             ENDDO
30640           ENDDO
30641 C--Z mass
30642           MZ = RMASS(200)
30643           MZ2 = MZ**2
30644 C--find the couplings
30645           DO GN=1,3
30646             DO I=1,3
30647               DO J=1,3
30648                 DO K=1,3
30649                   DO L=1,3
30650                     LAM(1,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA1(GN,K,L)
30651                     LAM(2,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA2(GN,K,L)
30652                     LAM(3,GN,I,J,K,L) = LAM(1,GN,I,J,K,L)
30653                     LAM(4,GN,I,J,K,L) = LAMDA2(I,GN,J)*LAMDA2(K,GN,L)
30654                   ENDDO
30655                 ENDDO
30656               ENDDO
30657             ENDDO
30658           ENDDO
30659 C--Z couplings
30660           GL = LFCH(11)
30661           GR = RFCH(11)
30662 C--select the process from the IPROC code
30663           IF(IPROC.EQ.860) THEN
30664             GNMN = 1
30665             GNMX = 2
30666             FID(1) = 0
30667             FID(2) = 0
30668           ELSEIF(IPROC.GE.870.AND.IPROC.LT.890) THEN
30669             J = MOD(IPROC,10)
30670             IF(MOD(IPROC,10).EQ.0) THEN
30671               FID(1) = 0
30672               FID(2) = 0
30673             ELSE
30674               FID(1) = MOD(J-1,3)+1
30675               FID(2) = INT((J-1)/3)+1
30676             ENDIF
30677             IF(IPROC.LT.880) THEN
30678               GNMN = 1
30679             ELSE
30680               GNMN = 2
30681             ENDIF
30682             GNMX = GNMN
30683           ELSE
30684             CALL HWWARN('HWHREE',501)
30685           ENDIF
30686         ENDIF
30687 C--calculate the kinematic varibles
30688         EVWGT  = ZERO
30689         S      = PHEP(5,3)**2
30690         THTMIN = ONE-FOUR*PTMIN**2/S
30691         IF(THTMIN.LT.ZERO) CALL HWWARN('HWHREE',502)
30692         THTMIN = SQRT(THTMIN)
30693         COSTH  = HWRUNI(0,-THTMIN,THTMIN)
30694         EMSCA  = PHEP(5,3)
30695         GZ     = ONE/(S-MZ**2+Z*MZ*GAMZ)
30696         EE     = HWUAEM(S)
30697         FACA   = GEV2NB*EE**2*PIFAC*S/FOUR
30698         EE     = 0.25D0/EE/PIFAC
30699         SP     = ONE/S
30700         T      = -HALF*S*(ONE-COSTH)
30701         TP     = ONE/T
30702         TPZ    = ONE/(T-MZ2)
30703 C--Calculate the prefactor due multichannel approach
30704         DO GN=1,3
30705           IF(GN.EQ.RSID(1).OR.GN.EQ.RSID(2)) THEN
30706             SCF(GN)= ONE/(S-MSL2(GN)+Z*MWD(GN))
30707           ELSE
30708             SCF(GN) = Z0
30709           ENDIF
30710         ENDDO
30711       ENDIF
30712 C--Now the loop to actually calculate the cross sections
30713       HCS = ZERO
30714       DO GN=GNMN,GNMX
30715         GNR = GN+2
30716         DO K1=1,3
30717           DO 80 L1=1,3
30718             IF(FID(1).NE.0.AND.(FID(1).NE.K1.OR.FID(2).NE.L1).AND.
30719      &         (FID(1).NE.L1.OR.FID(2).NE.K1)) GOTO 80
30720             IF(GN.EQ.1) THEN
30721               K = 119+2*K1
30722               L = 125+2*L1
30723               GLP = GL
30724               GRP = GR
30725               EC = ONE
30726               CFAC = ONE
30727             ELSEIF(GN.EQ.2) THEN
30728               K = 2*K1-1
30729               L = 2*L1+5
30730               GLP = LFCH(K)
30731               GRP = RFCH(K)
30732               EC = ONE/THREE
30733               CFAC = THREE
30734             ENDIF
30735             MQ1 = RMASS(K)
30736             MQ2 = RMASS(L)
30737             IF(EMSCA.LT.(MQ1+MQ2)) GOTO 80
30738             MET = ZERO
30739             IF(GENEV) GOTO 60
30740 C--calculate the matrix element
30741 C--set all coefficents to zero
30742             FSLL = Z0
30743             FSLR = Z0
30744             FSRL = Z0
30745             FSRR = Z0
30746             FTLL = Z0
30747             FTLR = Z0
30748             FTRL = Z0
30749             FTRR = Z0
30750 C--Standard Model terms
30751             IF(K1.EQ.L1) THEN
30752 C--first if same flavour pair production
30753               FSLL = EC*SP+GL*GRP*GZ
30754               FSLR = EC*SP+GL*GLP*GZ
30755               FSRL = EC*SP+GR*GRP*GZ
30756               FSRR = EC*SP+GR*GLP*GZ
30757 C--t channel terms if e+e- --> e+e-
30758               IF(K1.EQ.IL.AND.GN.EQ.1) THEN
30759                 FTLL = TP+GL*GR*TPZ
30760                 FTLR = TP+GL**2*TPZ
30761                 FTRL = TP+GR**2*TPZ
30762                 FTRR = TP+GL*GR*TPZ
30763               ENDIF
30764             ENDIF
30765 C--Now add the RPV terms
30766             DO I=1,3
30767               IF(GN.EQ.1) THEN
30768                 TPN  = ONE/(T-MSL2(I))
30769                 TPN2 = TPN
30770               ELSE
30771                 TPN  = MIX(I,1)/(T-MSU2(I,1))+ MIX(I,2)/(T-MSU2(I,2))
30772                 TPN2 = ZERO
30773               ENDIF
30774               FSLL = FSLL+HALF*LAM(GNR,I,IL,K1,IL,L1)*EE*TPN
30775               FSRR = FSRR+HALF*LAM(GNR,I,K1,IL,L1,IL)*EE*TPN2
30776               FTLL = FTLL+HALF*LAM(GN,I,IL,IL,K1,L1)*EE*SCF(I)
30777               FTRR = FTRR+HALF*LAM(GN,I,IL,IL,L1,K1)*EE*SCF(I)
30778             ENDDO
30779 C--now calculate the matrix element (including beam polarization)
30780             MET =(ONE+COSTH)**2*DREAL(
30781      &              DCONJG(FSLR)*FSLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30782      &             +DCONJG(FSRL)*FSRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
30783      &             +DCONJG(FTLR)*FTLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30784      &             +DCONJG(FTRL)*FTRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
30785      &             +TWO*FTLR*DCONJG(FSLR)*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30786      &             +TWO*FTRL*DCONJG(FSRL)*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
30787      &          +(ONE-COSTH)**2*DREAL(
30788      &               DCONJG(FSLL)*FSLL*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30789      &              +DCONJG(FSRR)*FSRR*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
30790      &          +FOUR*DREAL(
30791      &               DCONJG(FTLL)*FTLL*(ONE+EPOLN(3))*(ONE+PPOLN(3))
30792      &              +DCONJG(FTRR)*FTRR*(ONE-EPOLN(3))*(ONE-PPOLN(3)))
30793 C--final phase space factors
30794             ME(GN,K1,L1) = MET*CFAC*FACA*THTMIN
30795  60         HCS = HCS+ME(GN,K1,L1)
30796             IF(HCS.GT.RCS.AND.GENEV) GOTO 900
30797  80       CONTINUE
30798         ENDDO
30799       ENDDO
30800  900  IF(GENEV) THEN
30801 C--change sign of COSTH if antiparticle first
30802         IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
30803 C-Set up the particle types
30804         IDHW(NHEP+1)     = 15
30805         IDHEP(NHEP+1)    = 0
30806         ISTHEP(NHEP+1)   = 110
30807         IDHW(NHEP+2)     = K
30808         IDHW(NHEP+3)     = L
30809         IDHEP(NHEP+2)    = IDPDG(K)
30810         IDHEP(NHEP+3)    = IDPDG(L)
30811 C--Select the masses of the particles and the final-state momenta
30812  910    NTRY = NTRY+1
30813         PHEP(5,NHEP+2)   = HWUMBW(K)
30814         PHEP(5,NHEP+3)   = HWUMBW(L)
30815         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
30816         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
30817         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
30818           GOTO 910
30819         ELSEIF(PCM.LT.ZERO) THEN
30820           CALL HWWARN('HWHREE',100)
30821           GOTO 999
30822         ENDIF
30823 C--Set up the colours etc
30824         ISTHEP(NHEP+2)   = 113
30825         ISTHEP(NHEP+3)   = 114
30826         JMOHEP(1,NHEP+1) = 1
30827         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
30828         JMOHEP(2,NHEP+1) = 2
30829         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
30830         JMOHEP(1,NHEP+2) = NHEP+1
30831         JMOHEP(2,NHEP+2) = NHEP+3
30832         JMOHEP(1,NHEP+3) = NHEP+1
30833         JMOHEP(2,NHEP+3) = NHEP+2
30834         JDAHEP(1,NHEP+1) = NHEP+2
30835         JDAHEP(2,NHEP+1) = NHEP+3
30836         JDAHEP(1,NHEP+2) = 0
30837         JDAHEP(2,NHEP+2) = NHEP+3
30838         JDAHEP(1,NHEP+3) = 0
30839         JDAHEP(2,NHEP+3) = NHEP+2
30840 C--Set up the momenta
30841         IHEP  = NHEP+2
30842         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
30843         PHEP(3,IHEP) = PCM*COSTH
30844         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
30845         PHEP(2,IHEP) = ZERO
30846         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
30847         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
30848         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
30849         NHEP  = NHEP+3
30850       ELSE
30851         EVWGT = HCS
30852       ENDIF
30853  999  RETURN
30854       END
30855 CDECK  ID>, HWHREM.
30856 *CMZ :-        -01/06/94  17.03.31  by  Mike Seymour
30857 *-- Author :    Mike Seymour
30858 C-----------------------------------------------------------------------
30859       SUBROUTINE HWHREM(IBEAM,ITARG)
30860 C-----------------------------------------------------------------------
30861 C     IDENTIFY THE REMNANTS OF THE HARD SCATTERING
30862 C     AND BREAK THEIR COLOUR CONNECTION IF NECESSARY
30863 C-----------------------------------------------------------------------
30864       INCLUDE 'herwig65.inc'
30865       DOUBLE PRECISION PCL(5),
30866      $     P1P2,P1SQ,P2SQ,S,M1SQ,M2SQ,TMP1,TMP2,A,B,C,D,PTOT(4),HWULDO
30867       INTEGER IBEAM,ITARG,IHEP,NTEMP,I,ICOL,IANT
30868       LOGICAL LTEMP,T,COL,ANT
30869       PARAMETER (T=.TRUE.)
30870       COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
30871       ANT(I)=I.EQ.13 .OR. I.GE.7.AND.I.LE.12.OR. I.GE.109.AND.I.LE.114
30872 C---LOOK FOR UNTREATED BEAM AND TARGET REMNANTS
30873       IBEAM=0
30874       ITARG=0
30875       DO 10 IHEP=1,NHEP
30876         IF (ISTHEP(IHEP).EQ.148) THEN
30877           IF (ITARG.NE.0) THEN
30878             CALL HWWARN('HWHREM',100)
30879             GOTO 999
30880           ENDIF
30881           ITARG=IHEP
30882         ELSEIF (ISTHEP(IHEP).EQ.147) THEN
30883           IF (IBEAM.NE.0) THEN
30884             CALL HWWARN('HWHREM',101)
30885             GOTO 999
30886           ENDIF
30887           IBEAM=IHEP
30888         ENDIF
30889   10  CONTINUE
30890       IF (ITARG.EQ.0) THEN
30891         CALL HWWARN('HWHREM',102)
30892         GOTO 999
30893       ENDIF
30894       IF (IBEAM.EQ.0) THEN
30895         CALL HWWARN('HWHREM',103)
30896         GOTO 999
30897       ENDIF
30898 C---MHS FIX TO PREVENT MOMENTUM VIOLATION DUE TO OFF-SHELL BEAM REMNANTS
30899 C---FIND REMNANT MOMENTA AND MASSES
30900       P1P2=HWULDO(PHEP(1,IBEAM),PHEP(1,ITARG))
30901       P1SQ=HWULDO(PHEP(1,IBEAM),PHEP(1,IBEAM))
30902       P2SQ=HWULDO(PHEP(1,ITARG),PHEP(1,ITARG))
30903       S=P1SQ+2*P1P2+P2SQ
30904       TMP1=P1P2**2-P1SQ*P2SQ
30905       IF (TMP1.LE.0) THEN
30906         CALL HWWARN('HWHREM',104)
30907         GOTO 999
30908       ENDIF
30909       TMP1=SQRT(TMP1)
30910       M1SQ=RMASS(IDHW(IBEAM))**2
30911       M2SQ=RMASS(IDHW(ITARG))**2
30912       TMP2=(S-M1SQ-M2SQ)**2-4*M1SQ*M2SQ
30913       IF (TMP2.LE.0) THEN
30914         CALL HWWARN('HWHREM',105)
30915         GOTO 999
30916       ENDIF
30917       TMP2=SQRT(TMP2)
30918 C---EXCHANGE A LITTLE MOMENTUM TO PUT THEM BOTH ON MASS-SHELL
30919       A=(1-(P1P2+P2SQ)/TMP1)/2
30920       B=(1-(P1P2+P1SQ)/TMP1)/2
30921       C=(S-M1SQ+M2SQ-TMP2)/(2*S)
30922       D=(S+M1SQ-M2SQ-TMP2)/(2*S)
30923       CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PTOT)
30924       CALL HWVSCA(4,(1-A)*(1-C)+A*D,PHEP(1,IBEAM),PHEP(1,IBEAM))
30925       CALL HWVSCA(4,B*(1-C)+(1-B)*D,PHEP(1,ITARG),PHEP(1,ITARG))
30926       CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PHEP(1,IBEAM))
30927       CALL HWVDIF(4,PTOT,PHEP(1,IBEAM),PHEP(1,ITARG))
30928       CALL HWUMAS(PHEP(1,IBEAM))
30929       CALL HWUMAS(PHEP(1,ITARG))
30930 C---END MHS FIX
30931 C---IF THEY ARE COLOUR CONNECTED, DISCONNECT THEM BY EMITTING A SOFT
30932 C   GLUON AND SPLITTING THAT GLUON TO LIGHT QUARKS
30933 C  (WHICH NORMALLY GETS DONE AS THE FIRST STAGE OF CLUSTER FORMATION)
30934 C---LOOP OVER COLOUR/ANTICOLOUR LINE
30935       DO 20 I=1,2
30936         IF (I.EQ.1) THEN
30937           ICOL=IBEAM
30938           IANT=ITARG
30939         ELSE
30940           ICOL=ITARG
30941           IANT=IBEAM
30942         ENDIF
30943         IF (COL(IDHW(ICOL)).AND.ANT(IDHW(IANT)).AND.
30944      $       JMOHEP(2,ICOL).EQ.IANT.AND.JDAHEP(2,IANT).EQ.ICOL) THEN
30945           CALL HWVSUM(4,PHEP(1,ICOL),PHEP(1,IANT),PCL)
30946           CALL HWUMAS(PCL)
30947           NTEMP=NHEP
30948           CALL HWCCUT(ICOL,IANT,PCL,T,LTEMP)
30949           IF (IERROR.NE.0) RETURN
30950 C---IF NOTHING WAS CREATED THEY MUST BE BELOW THRESHOLD, SO GIVE UP
30951           IF (NHEP.NE.NTEMP+2) RETURN
30952 C---RELABEL THEM AS PERTUBATIVE JUST TO NEATEN UP THE EVENT RECORD
30953           ISTHEP(NHEP-1)=149
30954           ISTHEP(NHEP)=149
30955         ENDIF
30956  20   CONTINUE
30957  999  RETURN
30958       END
30959 CDECK  ID>, HWHREP.
30960 *CMZ :-        -18/10/00  13:46:47  by  Peter Richardson
30961 *-- Author :    Peter Richardson
30962 C-----------------------------------------------------------------------
30963       SUBROUTINE HWHREP
30964 C-----------------------------------------------------------------------
30965 C     SUSY E+E- RPV PRODUCTION
30966 C-----------------------------------------------------------------------
30967       INCLUDE 'herwig65.inc'
30968       IF(IPROC.GE.800.AND.IPROC.LE.850) THEN
30969         CALL HWHRES
30970       ELSEIF(IPROC.GE.860.AND.IPROC.LT.890) THEN
30971         CALL HWHREE
30972 C---UNRECOGNIZED PROCESS
30973       ELSE
30974         CALL HWWARN('HWHREP',500)
30975       ENDIF
30976       END
30977 CDECK  ID>, HWHRES.
30978 *CMZ :-        -07/04/02  10:38:51  by  Peter Richardson
30979 *-- Author :    Peter Richardson
30980 C-----------------------------------------------------------------------
30981       SUBROUTINE HWHRES
30982 C-----------------------------------------------------------------------
30983 C     SUSY E+E- --> RPV SINGLE SPARTICLE PRODUCTION
30984 C     POLARZATION EFFECTS ADDED 5/4/02 BY PETER RICHARDSON
30985 C-----------------------------------------------------------------------
30986       INCLUDE 'herwig65.inc'
30987       DOUBLE PRECISION HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW,HCS,RCS,FACA,
30988      &                 FACB,FACC,FACD,FACE,M1(4,4),M2(2,4),M3(8,2),
30989      &                 MW,MZ,MSCL(2,2),MSCL2(2,2),MZ2,MSL2,MSR2,MSNU2,
30990      &                 MW2,MCH(2),MCH2(2),MNU(4),MNU2(4),MLT(3),MLT2(3),
30991      &                 MNUT(2),MNUT2(2),RMNUT(2),S,U,T,QPE,SQPE,SM,DM,
30992      &                 PF,PCM,SCF(2),UP,TP,MH(4),MH2(4),THCOS(2),THTMIN,
30993      &                 A(6,4),B(6,4),SW,CW,MC,SIN2B,ZNU,RHO,HSL(2,2),
30994      &                 HL(4),M4(10,2),HNU(3)
30995       INTEGER I,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,NTRY,
30996      &        ISN,IDL,J,L,RSID(2),K,L2,IL,IDZ,RADID(2,8),GMIN,GMAX
30997       LOGICAL NEUT,CHAR,RAD,HIGGS,THSGN
30998       SAVE HCS,M1,M2,M3,M4,SW,CW,MW,MZ,MW2,MZ2,MLT,MLT2,MNUT,MNUT2,
30999      &     RMNUT,MNU,MNU2,MCH,MCH2,MSNU2,A,B,MSL2,MSR2,MSCL,
31000      &     MSCL2,ZNU,THCOS,HSL,HL,HNU,MH,MH2,GMIN,GMAX,
31001      &     RADID,NTID,ISL,ISR,ISN,IDL,CHID,RSID,IL,NEUT,CHAR,RAD,HIGGS
31002       EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW
31003       PARAMETER (SSNU=449,SSCH = 455)
31004 C--Start of the code
31005       IF(GENEV) THEN
31006         RCS = HCS*HWRGEN(0)
31007       ELSE
31008 C--Initialise the hard processes
31009         IF(FSTWGT) THEN
31010 C--Decide which processes to generate
31011           NEUT  = .FALSE.
31012           CHAR  = .FALSE.
31013           RAD   = .FALSE.
31014           HIGGS = .FALSE.
31015 C--all single sparticle production
31016           IF(IPROC.EQ.800) THEN
31017             NEUT  = .TRUE.
31018             CHAR  = .TRUE.
31019             RAD   = .TRUE.
31020             HIGGS = .TRUE.
31021             NTID(1) = 1
31022             NTID(2) = 4
31023             CHID(1) = 1
31024             CHID(2) = 2
31025             GMIN    = 1
31026             GMAX    = 6
31027 C--single neutralino production
31028           ELSEIF(IPROC.GE.810.AND.IPROC.LE.814) THEN
31029             NEUT = .TRUE.
31030             IF(IPROC.EQ.810) THEN
31031               NTID(1) = 1
31032               NTID(2) = 4
31033             ELSE
31034               NTID(1) = IPROC-810
31035               NTID(2) = NTID(1)
31036             ENDIF
31037 C--single chargino production
31038           ELSEIF(IPROC.GE.820.AND.IPROC.LE.822) THEN
31039             CHAR = .TRUE.
31040             IF(IPROC.EQ.820) THEN
31041               CHID(1) = 1
31042               CHID(2) = 2
31043             ELSE
31044               CHID(1) = IPROC-820
31045               CHID(2) = CHID(1)
31046             ENDIF
31047 C--single slepton production with gauge boson
31048           ELSEIF(IPROC.EQ.830) THEN
31049             RAD = .TRUE.
31050             GMIN    = 1
31051             GMAX    = 6
31052 C--single slepton production with Higgs boson
31053           ELSEIF(IPROC.EQ.840) THEN
31054             HIGGS = .TRUE.
31055 C--photon radiation processes
31056           ELSEIF(IPROC.EQ.850) THEN
31057             RAD = .TRUE.
31058             GMIN = 7
31059             GMAX = 8
31060 C--unrecognized process issue warning
31061           ELSE
31062             CALL HWWARN('HWHRES',500)
31063           ENDIF
31064 C--check the particles in the beam
31065           RSID(2) = 3
31066           IF(ABS(IDHEP(1)).EQ.11) THEN
31067 C--electron beams
31068             ISL     = 425
31069             ISR     = 437
31070             ISN     = 426
31071             RSID(1) = 2
31072             IL      = 1
31073           ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
31074 C--muon beams
31075             ISL     = 427
31076             ISR     = 439
31077             ISN     = 428
31078             RSID(1) = 1
31079             IL      = 2
31080 C--unrecognised beam particles issue warning
31081           ELSE
31082             CALL HWWARN('HWHRES',501)
31083           ENDIF
31084           IDL=ABS(IDHEP(1))
31085 C--masses and electroweak parameters
31086           SW  = SQRT(SWEIN)
31087           CW  = SQRT(1-SWEIN)
31088           MW  = RMASS(198)
31089           MZ  = RMASS(200)
31090           MW2 = MW**2
31091           MZ2 = MZ**2
31092           SIN2B = TWO*SINB*COSB
31093 C--neutralino and chargino masses
31094           DO I=1,4
31095             MNU(I)  = RMASS(SSNU+I)
31096             MNU2(I) = MNU(I)**2
31097           ENDDO
31098           DO I = 1,2
31099             MCH(I)  = RMASS(I+SSCH)
31100             MCH2(I) = MCH(I)**2
31101           ENDDO
31102 C--incoming lepton mass
31103           MLT(1) = RMASS(IDL+110)
31104 C--lepton masses in chargino production
31105           DO I=1,2
31106             MLT(I+1) = RMASS(119+2*RSID(I))
31107           ENDDO
31108           DO I=1,3
31109             MLT2(I) = MLT(I)**2
31110           ENDDO
31111 C--t-channel slepton masses
31112           MSL2  = RMASS(ISL)**2
31113           MSR2  = RMASS(ISR)**2
31114           MSNU2 = RMASS(ISN)**2
31115 C--resonant sneutrino masses and widths
31116           DO I=1,2
31117             MNUT(I)  = RMASS(424+2*RSID(I))
31118             MNUT2(I) = MNUT(I)**2
31119             RMNUT(I) = MNUT2(I)*HBAR**2/RLTIM(424+2*RSID(I))**2
31120           ENDDO
31121 C--now calculate the coefficients for the processes
31122 C--first neutralino production
31123           DO L=1,4
31124             MC = MLT(1)*ZMIXSS(L,3)/(TWO*MW*COSB*SW)
31125 C--first for the left slepton
31126             A(L,1) = SLFCH(IDL,L)
31127             B(L,1) = ZSGNSS(L)*MC
31128 C--then the right slepton
31129             A(L,2) = ZSGNSS(L)*SRFCH(IDL,L)
31130             B(L,2) = MC
31131 C--the resonant sneutrino
31132             DO I=1,2
31133               A(L,2+I) = SLFCH(10+2*RSID(I),L)
31134               B(L,2+I) = ZERO
31135             ENDDO
31136           ENDDO
31137 C--now chargino production
31138           DO L=1,2
31139             J=L+4
31140             MC = WMXUSS(L,2)/(SQRT(TWO)*MW*COSB*SW)
31141 C--first for the t channel sneutrino
31142             A(J,1) = WSGNSS(L)*WMXVSS(L,1)/SW
31143             B(J,1) = -MLT(1)*MC
31144 C--now for the resonant sneutrinos
31145             DO I=1,2
31146               A(J,I+1) = WSGNSS(L)*WMXVSS(L,1)/SW
31147               B(J,I+1) = -MLT(I+1)*MC
31148             ENDDO
31149           ENDDO
31150 C--coupling of the Z to the sneutrino
31151           ZNU = HALF/SW/CW
31152 C--now the masses and IDs of the slepton in the radiative processes
31153 C--IDs and masses of the charged sleptons
31154           DO I=1,2
31155             RADID(2,2*I-1) = 423+RSID(I)*2
31156             RADID(2,2*I  ) = 435+RSID(I)*2
31157             MSCL(I,1)      = RMASS(RADID(2,2*I-1))
31158             MSCL(I,2)      = RMASS(RADID(2,2*I))
31159             DO J=1,2
31160               MSCL2(I,J) = MSCL(I,J)**2
31161             ENDDO
31162           ENDDO
31163 C--ID of the W for charged slepton processes
31164           DO I=1,4
31165             RADID(1,I) = 198
31166           ENDDO
31167 C--ID's for the Z and gamma processes
31168           DO I=1,2
31169              RADID(1,I+4) = 200
31170              RADID(1,I+6) = 59
31171              RADID(2,I+4) = 424+RSID(I)*2
31172              RADID(2,I+6) = RADID(2,I+4)
31173           ENDDO
31174 C--couplings of the sleptons to the Higgs
31175           DO I=1,2
31176             DO J=1,2
31177               K = 2*RSID(I)-1
31178               L = 119+2*RSID(I)
31179               HSL(I,J) = LMIXSS(K,1,J)*(RMASS(L)**2*TANB-MW2*SIN2B)
31180      &                   +LMIXSS(K,2,J)*RMASS(L)*MUSS
31181               IF(RSID(I).EQ.3) HSL(I,J) = HSL(I,J)
31182      &          +LMIXSS(K,2,J)*RMASS(L)*ALSS*TANB
31183               HSL(I,J) = HSL(I,J)/SQRT(HALF)/MW
31184             ENDDO
31185           ENDDO
31186 C--coupling of the sneutrino to the Higgs
31187           HNU(1) =  HALF*MZ*SINBPA/CW
31188           HNU(2) = -HALF*MZ*COSBPA/CW
31189           HNU(3) = ZERO
31190 C--couplings of the leptons to the Higgs
31191           RHO   =  HALF*MLT(1)/MW
31192           HL(1) = -RHO*SINA/COSB
31193           HL(2) =  RHO*COSA/COSB
31194           HL(3) =  RHO*TANB
31195           HL(4) =  RHO*TANB/SQRT(HALF)
31196 C--Higgs Masses
31197           DO I=1,4
31198             MH(I)  = RMASS(202+I)
31199             MH2(I) = MH(I)**2
31200           ENDDO
31201         ENDIF
31202 C--Now calculate the weights
31203         COSTH    = HWRUNI(1,-ONE,ONE)
31204         S        = PHEP(5,3)**2
31205         EMSCA    = PHEP(5,3)
31206         FACA     = HWUAEM(S)*GEV2NB/S/8.0D0
31207         FACD     = HALF*FACA/SWEIN
31208         FACB     = HALF*FACD/MW2
31209         FACC     = HALF*FACA/MZ2
31210         FACE     = ALPHEM*GEV2NB/S/8.0D0
31211         DO I=1,2
31212           SCF(I) = ONE/((S-MNUT2(I))**2+RMNUT(I))
31213         ENDDO
31214 C--single neutralino production
31215         IF(.NOT.NEUT) THEN
31216           DO L=1,4
31217             DO J=1,4
31218               M1(L,J) = ZERO
31219             ENDDO
31220           ENDDO
31221           GOTO 100
31222         ENDIF
31223         DO L=NTID(1),NTID(2)
31224           DO J=1,2
31225             SQPE  = S - MNU2(L)
31226             K    = J+2
31227             IF(SQPE.GE.ZERO) THEN
31228               PF   = SQPE/S
31229               T    = HALF*(SQPE*COSTH-S+MNU2(L))
31230               U    = -T-S+MNU2(L)
31231               UP   = ONE/(U-MSL2)
31232               TP   = ONE/(T-MSR2)
31233 C--neutralino antineutrino production (including beam polarization)
31234               M1(L,J) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
31235      &                      A(L,K)**2*S*(S-MNU2(L))*SCF(J)
31236      &                     +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1)
31237      &                     +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2)
31238      &                     +TWO*U*T*UP*TP*A(L,1)*A(L,2))
31239      &           +U*(U-MNU2(L))*UP**2*(ONE-PPOLN(3))*
31240      &               (A(L,1)**2*(ONE-EPOLN(3))+B(L,1)**2*(ONE+EPOLN(3)))
31241      &           +T*(T-MNU2(L))*TP**2*(ONE-EPOLN(3))*
31242      &               (A(L,2)**2*(ONE-PPOLN(3))+B(L,2)**2*(ONE+PPOLN(3)))
31243 C--neutralino neutrino production (including beam polarization)
31244               M1(L,K) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
31245      &                      A(L,K)**2*S*(S-MNU2(L))*SCF(J)
31246      &                     +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1)
31247      &                     +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2)
31248      &                     +TWO*U*T*UP*TP*A(L,1)*A(L,2))
31249      &           +U*(U-MNU2(L))*UP**2*(ONE+PPOLN(3))*
31250      &               (A(L,1)**2*(ONE+EPOLN(3))+B(L,1)**2*(ONE-EPOLN(3)))
31251      &           +T*(T-MNU2(L))*TP**2*(ONE+EPOLN(3))*
31252      &               (A(L,2)**2*(ONE+PPOLN(3))+B(L,2)**2*(ONE-PPOLN(3)))
31253 C--final coefficients
31254               M1(L,J) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,J)
31255               M1(L,K) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,K)
31256             ELSE
31257               M1(L,J) = ZERO
31258               M1(L,K) = ZERO
31259             ENDIF
31260           ENDDO
31261         ENDDO
31262 C--single chargino production
31263  100    IF(.NOT.CHAR) THEN
31264           DO L=1,2
31265             DO J=1,4
31266               M2(L,J) = ZERO
31267             ENDDO
31268           ENDDO
31269           GOTO 200
31270         ENDIF
31271         DO L = CHID(1),CHID(2)
31272           DO J = 1,2
31273             K  = J+1
31274             L2 = L+4
31275             SM  = MCH(L) + MLT(K)
31276             QPE = S - SM**2
31277             IF (QPE.GE.ZERO) THEN
31278               DM   = MCH(L) - MLT(K)
31279               SQPE = SQRT(QPE*(S-DM**2))
31280               PF   = SQPE/S
31281               T    = HALF*(SQPE*COSTH-S+MCH2(L)+MLT2(K))
31282               U    = -T-S+MCH2(L)+MLT2(K)
31283               UP   = ONE/(U-MSNU2)
31284 C--chargino antilepton (including beam polarization)
31285               M2(L,J) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K)
31286      &                  +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))*
31287      &                    (ONE-EPOLN(3))*(ONE-PPOLN(3))
31288      &          +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE-PPOLN(3))*
31289      &             (A(L2,1)**2*(ONE-EPOLN(3))+B(L2,1)**2*(ONE+EPOLN(3)))
31290      &          -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE-EPOLN(3))*
31291      &             (ONE-PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
31292 C--chargino lepton (including beam polarization)
31293               M2(L,J+2) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K)
31294      &                  +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))*
31295      &                    (ONE+EPOLN(3))*(ONE+PPOLN(3))
31296      &          +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE+PPOLN(3))*
31297      &             (A(L2,1)**2*(ONE+EPOLN(3))+B(L2,1)**2*(ONE-EPOLN(3)))
31298      &          -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE+EPOLN(3))*
31299      &             (ONE+PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
31300 C--final coefficients
31301               M2(L,J)  =HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J)
31302               M2(L,J+2)=HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J+2)
31303             ELSE
31304               M2(L,J)   = ZERO
31305               M2(L,J+2) = ZERO
31306             ENDIF
31307           ENDDO
31308         ENDDO
31309 C--Radiative processes
31310  200    IF(.NOT.RAD) THEN
31311           DO I=1,8
31312             DO J=1,2
31313               M3(I,J) = ZERO
31314             ENDDO
31315           ENDDO
31316           GOTO 300
31317         ENDIF
31318         IF(GMAX.LT.7) THEN
31319 C--W charged slepton production
31320           DO I=1,2
31321             DO J=1,2
31322               QPE = S-(MW+MSCL(I,J))**2
31323               IF(QPE.GE.ZERO) THEN
31324                 DM   = MW-MSCL(I,J)
31325                 SQPE = SQRT(QPE*(S-DM**2))
31326                 PF   = SQPE/S
31327                 T    = HALF*(SQPE*COSTH-S+MW2+MSCL2(I,J))
31328                 U    = -T-S+MW2+MSCL2(I,J)
31329                 UP   = ONE/U
31330 C--W slepton
31331                 M3(2*I+J-2,1) = SCF(I)*S*SQPE**2
31332      &            +UP**2*(TWO*MW2*(U*T-MW2*MSCL2(I,J))+U**2*S)
31333      &            -TWO*UP*SCF(I)*(S-MNUT2(I))*S*(MW2*(TWO*MSCL2(I,J)-U)+
31334      &                  U*(S-MSCL2(I,J)))
31335                 M3(2*I+J-2,1) = LAMDA1(RSID(I),IL,IL)**2*FACB*PF
31336      &             *LMIXSS(2*RSID(I)-1,1,J)**2*M3(2*I+J-2,1)
31337 C--W- antislepton (including beam polarization)
31338                 M3(2*I+J-2,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*
31339      &                           M3(2*I+J-2,1)
31340 C--W+ antislepton (including beam polarization)
31341                 M3(2*I+J-2,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*
31342      &                           M3(2*I+J-2,1)
31343               ELSE
31344                 M3(2*I+J-2,1) = ZERO
31345                 M3(2*I+J-2,2) = ZERO
31346               ENDIF
31347             ENDDO
31348           ENDDO
31349 C--Z sneutrino production
31350           DO I=1,2
31351             QPE = S-(MZ+MNUT(I))**2
31352             IF(QPE.GE.ZERO) THEN
31353               DM    = MZ-MNUT(I)
31354               SQPE  = SQRT(QPE*(S-DM**2))
31355               PF    = SQPE/S
31356               T     = HALF*(SQPE*COSTH-S+MZ2+MNUT2(I))
31357               U     = -T-S+MZ2+MNUT2(I)
31358               UP    = ONE/U
31359               TP    = ONE/T
31360               IDZ   = 9+RSID(I)*2
31361 C--Z sneutrino production
31362               M3(I+4,1) = SCF(I)*S*SQPE**2*ZNU**2
31363      &           +TP**2*RFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*T**2)
31364      &           +UP**2*LFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*U**2)
31365      &           -TWO*ZNU*RFCH(IDZ)*TP*S*SCF(I)*(S-MNUT2(I))*
31366      &               (MZ2*(TWO*MNUT2(I)-T)+T*(S-MNUT2(I)))
31367      &           +TWO*ZNU*LFCH(IDZ)*UP*S*SCF(I)*(S-MNUT2(I))*
31368      &               (MZ2*(TWO*MNUT2(I)-U)+U*(S-MNUT2(I)))
31369      &           +TWO*LFCH(IDZ)*RFCH(IDZ)*UP*TP*
31370      &               (TWO*MZ2*(MNUT2(I)-T)*(MNUT2(I)-U)-S*U*T)
31371               M3(I+4,1) = LAMDA1(RSID(I),IL,IL)**2*FACC*PF*M3(I+4,1)
31372 C--Z antisneutrino (including beam polarization)
31373               M3(I+4,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*M3(I+4,1)
31374 C--Z sneutrino     (including beam polarization)
31375               M3(I+4,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*M3(I+4,1)
31376             ELSE
31377               M3(I+4,1) = ZERO
31378               M3(I+4,2) = ZERO
31379             ENDIF
31380           ENDDO
31381         ELSE
31382 C--gamma sneutrino production (includes Jacobian 1-costh**2)
31383 C--now includes polarization effects
31384           DO I=1,2
31385             SQPE = S-MNUT2(I)
31386             IF(SQPE.GE.ZERO) THEN
31387               PF       = SQPE/S
31388               PCM      = HALF*EMSCA*PF
31389               THTMIN   = PTMIN/PCM
31390               IF(THTMIN.GT.ONE) CALL HWWARN('HWHRES',502)
31391               THTMIN   = ONE-THTMIN**2
31392               THTMIN   = HALF*LOG((1+THTMIN)/(1-THTMIN))
31393               RHO      = HWRUNI(2,-THTMIN,THTMIN)
31394               THCOS(I) = -TANH(RHO)
31395               T        = HALF*(SQPE*THCOS(I)-S+MNUT2(I))
31396               U        = -T-S+MNUT2(I)
31397               UP       = ONE/U
31398               TP       = ONE/T
31399               M3(I+6,1)  = U*TP+T*UP+TWO*UP*TP*(MNUT2(I)-U)*(MNUT2(I)-T)
31400               M3(I+6,1)  = LAMDA1(RSID(I),IL,IL)**2*FACE*PF*M3(I+6,1)*
31401      &                   (ONE-THCOS(I)**2)*THTMIN
31402               M3(I+6,2) = M3(I+6,1)*(ONE-EPOLN(3))*(ONE-PPOLN(3))
31403               M3(I+6,1) = M3(I+6,1)*(ONE+EPOLN(3))*(ONE+PPOLN(3))
31404             ELSE
31405               M3(I+6,1) = ZERO
31406               M3(I+6,2) = ZERO
31407             ENDIF
31408           ENDDO
31409         ENDIF
31410 C--Higgs processes
31411  300    IF(.NOT.HIGGS) THEN
31412           DO I=1,10
31413             DO J=1,2
31414               M4(I,J) = ZERO
31415             ENDDO
31416           ENDDO
31417           GOTO 500
31418         ENDIF
31419 C--Charged Higgs charged slepton production
31420         DO I=1,2
31421           DO J=1,2
31422             QPE = S-(MH(4)+MSCL(I,J))**2
31423             IF(QPE.GE.ZERO) THEN
31424               DM   = MH(4)-MSCL(I,J)
31425               SQPE = SQRT(QPE*(S-DM**2))
31426               PF   = SQPE/S
31427               T    = HALF*(SQPE*COSTH-S+MH2(4)+MSCL2(I,J))
31428               U    = -T-S+MH2(4)+MSCL2(I,J)
31429 C--charged Higgs antislepton
31430               M4(2*I+J-2,1) = HSL(I,J)**2*S*SCF(I)*
31431      &                          (ONE-EPOLN(3))*(ONE-PPOLN(3))
31432      &                     +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
31433      &                          *(U*T-MSCL2(I,J)*MH2(4))/U**2*
31434      &                          (ONE+EPOLN(3))*(ONE-PPOLN(3))
31435 C--charged Higgs slepton
31436               M4(2*I+J-2,2) = HSL(I,J)**2*S*SCF(I)*
31437      &                          (ONE+EPOLN(3))*(ONE+PPOLN(3))
31438      &                     +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
31439      &                          *(U*T-MSCL2(I,J)*MH2(4))/U**2*
31440      &                          (ONE-EPOLN(3))*(ONE+PPOLN(3))
31441 C--final coefficients
31442               M4(2*I+J-2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
31443      &                        M4(2*I+J-2,1)*PF
31444               M4(2*I+J-2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
31445      &                        M4(2*I+J-2,2)*PF
31446             ELSE
31447               M4(2*I+J-2,1) = ZERO
31448               M4(2*I+J-2,2) = ZERO
31449             ENDIF
31450           ENDDO
31451         ENDDO
31452 C--neutral higgs sneutrino production
31453         DO L=1,3
31454           DO I=1,2
31455             QPE = S-(MH(L)+MNUT(I))**2
31456             IF(QPE.GE.ZERO) THEN
31457               DM   = MH(L)-MNUT(I)
31458               SQPE = SQRT(QPE*(S-DM**2))
31459               PF   = SQPE/S
31460               T    = HALF*(SQPE*COSTH-S+MH2(L)+MNUT2(I))
31461               U    = -T-S+MH2(L)+MNUT2(I)
31462               IF(L.NE.3) THEN
31463 C--h0, H0 antisneutrino (including beam polarization)
31464                 M4(2*L+I+2,1) = HNU(L)**2*S*SCF(I)*
31465      &                         (ONE-EPOLN(3))*(ONE-PPOLN(3))
31466      &             +HL(L)**2*( ONE/T**2*(ONE+EPOLN(3))*(ONE-PPOLN(3))
31467      &                        +ONE/U**2*(ONE-EPOLN(3))*(ONE+PPOLN(3)))
31468      &                        *(U*T-MH2(L)*MNUT2(I))
31469 C--h0, H0 sneutrino (including beam polarization)
31470                 M4(2*L+I+2,2) = HNU(L)**2*S*SCF(I)*
31471      &                         (ONE+EPOLN(3))*(ONE+PPOLN(3))
31472      &             +HL(L)**2*( ONE/T**2*(ONE-EPOLN(3))*(ONE+PPOLN(3))
31473      &                        +ONE/U**2*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
31474      &                        *(U*T-MH2(L)*MNUT2(I))
31475              ELSE
31476 C--A0 antisneutrino (including beam polarization)
31477                 M4(2*L+I+2,1) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
31478      &              HNU(L)**2*S*SCF(I)
31479      &             +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
31480 C--A0 sneutrino (including beam polarization)
31481                 M4(2*L+I+2,2) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
31482      &              HNU(L)**2*S*SCF(I)
31483      &             +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
31484              ENDIF
31485 C--final coefficients
31486               M4(2*L+I+2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
31487      &                        M4(2*L+I+2,1)*PF
31488               M4(2*L+I+2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
31489      &                        M4(2*L+I+2,2)*PF
31490             ELSE
31491               M4(2*L+I+2,1) = ZERO
31492               M4(2*L+I+2,2) = ZERO
31493             ENDIF
31494           ENDDO
31495         ENDDO
31496       ENDIF
31497 C--Add up the weights now
31498  500  HCS = ZERO
31499 C--single neutralino production
31500       IF(.NOT.NEUT) GOTO 550
31501       DO L=NTID(1),NTID(2)
31502         IG1= SSNU+L
31503         DO J=1,4
31504           IG2 = 126+2*RSID(MOD(J-1,2)+1)-6*INT((J-1)/2)
31505           HCS = HCS+M1(L,J)
31506           THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR.
31507      &            (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
31508           IF(GENEV.AND.HCS.GT.RCS) GOTO 900
31509         ENDDO
31510       ENDDO
31511 C--single chargino production
31512  550  IF(.NOT.CHAR) GOTO 600
31513       DO L=CHID(1),CHID(2)
31514         DO J=1,4
31515           IG1 = SSCH+L-2*INT((J-1)/2)
31516           IG2 = 125+2*RSID(MOD((J-1),2)+1)-6*INT((J-1)/2)
31517           HCS = HCS + M2(L,J)
31518           THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR.
31519      &            (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
31520           IF (GENEV.AND.HCS.GT.RCS) GOTO 900
31521         ENDDO
31522       ENDDO
31523 C--gauge boson slepton production
31524  600  IF(.NOT.RAD) GOTO 650
31525       DO I=GMIN,GMAX
31526         IG1 = RADID(1,I)
31527         IG2 = RADID(2,I)
31528         IF(I.GE.7) COSTH = THCOS(I-6)
31529         DO J=1,2
31530           HCS = HCS+M3(I,J)
31531           THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
31532      &            (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
31533           IF(GENEV.AND.HCS.GT.RCS) GOTO 900
31534           IF(I.LE.4) IG1 = IG1+1
31535           IG2 = IG2+6
31536         ENDDO
31537       ENDDO
31538 C--higgs slepton production
31539  650  IF(.NOT.HIGGS) GOTO 900
31540 C--charged Higgs slepton
31541       DO I=1,4
31542         IG1 = 207
31543         IG2 = RADID(2,I)+6
31544         DO J=1,2
31545           HCS=HCS+M4(I,J)
31546           THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
31547      &            (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
31548           IF(GENEV.AND.HCS.GT.RCS) GOTO 900
31549           IG1 = IG1-1
31550           IG2 = IG2-6
31551         ENDDO
31552       ENDDO
31553 C--Neutral Higgs sneutrino
31554       DO L=1,3
31555         DO I=1,2
31556           IG1 = 202+L
31557           IG2 = 430+2*RSID(I)
31558           DO J=1,2
31559             HCS = HCS+M4(2+2*L+I,J)
31560             THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
31561      &              (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
31562             IF(GENEV.AND.HCS.GT.RCS) GOTO 900
31563             IG2 = IG2-6
31564           ENDDO
31565         ENDDO
31566       ENDDO
31567  900  IF(GENEV) THEN
31568 C--change sign of COSTH if antiparticle first
31569         IF(THSGN) COSTH = -COSTH
31570 C-Set up the particle types
31571         IDHW(NHEP+1)     = 15
31572         IDHEP(NHEP+1)    = 0
31573         ISTHEP(NHEP+1)   = 110
31574         IDHW(NHEP+2)     = IG1
31575         IDHW(NHEP+3)     = IG2
31576         IDHEP(NHEP+2)    = IDPDG(IG1)
31577         IDHEP(NHEP+3)    = IDPDG(IG2)
31578 C--generate the particle masses and final-state momenta
31579         NTRY = 0
31580  910    NTRY = NTRY+1
31581         PHEP(5,NHEP+2)   = HWUMBW(IG1)
31582         PHEP(5,NHEP+3)   = HWUMBW(IG2)
31583 C--Set up the Centre-of-mass energy
31584         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
31585         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
31586         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
31587           GOTO 910
31588         ELSEIF(PCM.LT.ZERO) THEN
31589           CALL HWWARN('HWHRES',100)
31590           GOTO 999
31591         ENDIF
31592 C--Set up the colours etc
31593         ISTHEP(NHEP+2)   = 113
31594         ISTHEP(NHEP+3)   = 114
31595         JMOHEP(1,NHEP+1) = 1
31596         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
31597         JMOHEP(2,NHEP+1) = 2
31598         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
31599         JMOHEP(1,NHEP+2) = NHEP+1
31600         JMOHEP(2,NHEP+2) = NHEP+2
31601         JMOHEP(1,NHEP+3) = NHEP+1
31602         JMOHEP(2,NHEP+3) = NHEP+3
31603         JDAHEP(1,NHEP+1) = NHEP+2
31604         JDAHEP(2,NHEP+1) = NHEP+3
31605         JDAHEP(1,NHEP+2) = 0
31606         JDAHEP(2,NHEP+2) = NHEP+2
31607         JDAHEP(1,NHEP+3) = 0
31608         JDAHEP(2,NHEP+3) = NHEP+3
31609 C--set up the rest of the momenta
31610         IHEP  = NHEP+2
31611         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
31612         PHEP(3,IHEP) = PCM*COSTH
31613         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
31614         PHEP(2,IHEP) = ZERO
31615         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
31616         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
31617         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
31618         NHEP  = NHEP+3
31619       ELSE
31620         EVWGT = HCS
31621       ENDIF
31622  999  RETURN
31623       END
31624 CDECK  ID>, HWHRLL.
31625 *CMZ :-        -08/04/02  09:00:27  by  Peter Richardson
31626 *-- Author :    Peter Richardson
31627 C-----------------------------------------------------------------------
31628       SUBROUTINE HWHRLL
31629 C-----------------------------------------------------------------------
31630 C  Subroutine for resonant sleptons to standard model particles
31631 C  slepton mass and mass*width added to save statement to
31632 C  avoid problems with Linux by Peter Richardson
31633 C-----------------------------------------------------------------------
31634       INCLUDE 'herwig65.inc'
31635       DOUBLE PRECISION HCS,S,RCS,HWRGEN,FAC,ECM,TH,PCM,CFAC,CHANPB,SH,
31636      &                 TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,MSL(12),
31637      &                 SQSH,MET(2),SCF(12),MIX(12),ME(4,3,3,3,3,2),
31638      &                 RAND,CHAN(12),LAM(2,7,3,3,3,3),SLWD(12),RTAB,
31639      &                 WD,MQ1,MQ2,EPS,XMIN,XMAX,XPOW,XUPP,MSL2(12),
31640      &                 MSWD(12)
31641       INTEGER I,J,K,L,I1,J1,K1,L1,GEN,GN,GR,GNMX,GNMN,MIG,MXG,CUP,CF
31642       LOGICAL FIRST
31643       EXTERNAL HWRGEN,HWRUNI
31644       PARAMETER(EPS=1D-20)
31645       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
31646       SAVE HCS,ME,MSL,SLWD,LAM,MIX,CHAN,GNMN,GNMX,SH,SQSH,FAC,SCF,MSL2,
31647      &     MSWD
31648       IF(GENEV) THEN
31649         RCS = HCS*HWRGEN(0)
31650       ELSE
31651         IF(FSTWGT) THEN
31652           DO I=1,3
31653             MSL(2*I-1)  = RMASS(423+2*I)
31654             MSL(2*I)    = RMASS(435+2*I)
31655             MSL(2*I+5)  = RMASS(424+2*I)
31656             MSL(2*I+6)  = RMASS(436+2*I)
31657             SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
31658             SLWD(2*I)   = HBAR/RLTIM(435+2*I)
31659             SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
31660             SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
31661           ENDDO
31662           DO I=1,12
31663              MSL2(I) = MSL(I)**2
31664              MSWD(I) = MSL(I)*SLWD(I)
31665           ENDDO
31666           RAND = ZERO
31667           DO I=1,3
31668             CHANPB=ZERO
31669             DO J=1,3
31670               DO K=1,3
31671                 CHANPB=CHANPB+LAMDA2(I,J,K)**4
31672               ENDDO
31673             ENDDO
31674             RAND=RAND+2*CHANPB
31675             DO J=1,2
31676               CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHANPB
31677               CHAN(2*I+4+J) = LMIXSS(2*I  ,1,J)**2*CHANPB
31678               MIX(2*I-2+J)  = LMIXSS(2*I-1,1,J)**2
31679               MIX(2*I+4+J)  = LMIXSS(2*I  ,1,J)**2
31680             ENDDO
31681           ENDDO
31682           IF(RAND.GT.ZERO) THEN
31683             DO I=1,12
31684               CHAN(I)=CHAN(I)/RAND
31685             ENDDO
31686           ELSE
31687             CALL HWWARN('HWHRLL',500)
31688           ENDIF
31689 C--find the couplings
31690           DO GN=1,3
31691             DO I=1,3
31692               DO J=1,3
31693                 DO K=1,3
31694                   DO L=1,3
31695                     LAM(1,GN,I,J,K,L)  =LAMDA2(GN,I,J)*LAMDA1(GN,K,L)
31696                     LAM(2,GN,I,J,K,L)  =LAMDA2(GN,I,J)*LAMDA2(GN,K,L)
31697                     LAM(1,GN+3,I,J,K,L)=LAM(1,GN,I,J,K,L)
31698                     LAM(2,GN+3,I,J,K,L)=LAM(2,GN,I,J,K,L)
31699                   ENDDO
31700                 ENDDO
31701               ENDDO
31702             ENDDO
31703           ENDDO
31704 C--select the process from the IPROC code
31705           GNMN = 1
31706           GNMX = 4
31707           IF(MOD(IPROC,10000).EQ.4070) THEN
31708             GNMX = 2
31709           ELSEIF(MOD(IPROC,10000).EQ.4080) THEN
31710             GNMN = 3
31711           ENDIF
31712         ENDIF
31713         EVWGT = ZERO
31714         S     = PHEP(5,3)**2
31715         COSTH = HWRUNI(0,-ONE,ONE)
31716 C--Generate the smoothing
31717         RAND=HWRUNI(0,ZERO,ONE)
31718         DO I=1,12
31719           IF(CHAN(I).GT.RAND) GOTO 20
31720           RAND=RAND-CHAN(I)
31721         ENDDO
31722  20     GR = I
31723 C--Calculate hard scale and obtain parton distributions
31724         TAUA   = MSL2(GR)/S
31725         TAUB   = SLWD(GR)**2/S
31726         RTAB   = SQRT(TAUA*TAUB)
31727         XUPP = XMAX
31728         IF(XMAX**2.GT.S) XUPP = SQRT(S)
31729         LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
31730         UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
31731         TAU    = HWRUNI(0,LOWTLM,UPPTLM)
31732         TAU    = RTAB*TAN(RTAB*TAU)+TAUA
31733         SH     = S*TAU
31734         SQSH   = SQRT(SH)
31735         EMSCA  = SQSH
31736         XX(1)  = EXP(HWRUNI(0,ZERO,LOG(TAU)))
31737         XX(2)  = TAU/XX(1)
31738         CALL HWSGEN(.FALSE.)
31739 C--Calculate the prefactor due multichannel approach
31740         FAC = ZERO
31741         DO GN=1,12
31742          SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
31743          FAC=FAC+CHAN(GN)*SCF(GN)
31744         ENDDO
31745         FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
31746      &         /(96*PIFAC*SQSH*SH*TAU*FAC*S**2)
31747       ENDIF
31748 C--Now the loop to actually calculate the cross-sections
31749       HCS = ZERO
31750       DO GN=GNMN,GNMX
31751         IF(MOD(GN,2).EQ.1) THEN
31752           MIG = 1
31753           MXG = 6
31754         ELSE
31755           MIG = 7
31756           MXG = 12
31757         ENDIF
31758         IF(GN.LE.2) THEN
31759           CFAC = THREE*FAC
31760           CUP=2
31761         ELSE
31762           CFAC = FAC
31763           CUP=1
31764         ENDIF
31765         DO K1=1,3
31766           DO 80 L1=1,3
31767             IF(GN.EQ.1) THEN
31768               K = 2*K1
31769               L = 2*L1+5
31770             ELSEIF(GN.EQ.2) THEN
31771               K = 2*K1-1
31772               L = 2*L1+5
31773             ELSEIF(GN.EQ.3) THEN
31774               K = 120+2*K1
31775               L = 125+2*L1
31776             ELSEIF(GN.EQ.4) THEN
31777               K = 119+2*K1
31778               L = 125+2*L1
31779             ENDIF
31780             MQ1 = RMASS(K)
31781             MQ2 = RMASS(L)
31782             IF(SQSH.GT.(MQ1+MQ2)) THEN
31783               PCM = SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2))/(2*SQSH)
31784               WD = (SH-MQ1**2-MQ2**2)*SH*PCM
31785             ELSE
31786               GOTO 80
31787             ENDIF
31788             DO I1=1,3
31789               DO 70 J1=1,3
31790                 IF(MOD(GN,2).EQ.1) THEN
31791                   I=2*I1
31792                   J=2*J1+5
31793                 ELSE
31794                   I=2*I1-1
31795                   J=2*J1+5
31796                 ENDIF
31797                 DO GR =1,2
31798                   MET(GR) = ZERO
31799                 ENDDO
31800                 IF(GENEV) GOTO 60
31801                 DO 50 GEN=MIG,MXG
31802                   IF(ABS(LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS.
31803      &                OR.ABS(MIX(GEN)).LT.EPS) GOTO 50
31804                   DO GR=MIG,MXG
31805                     IF(ABS(LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)).GT.EPS.
31806      &                AND.ABS(MIX(GR)).GT.EPS) THEN
31807                       MET(1) =MET(1)+SCF(GEN)*SCF(GR)*WD*
31808      &                 ((SH-MSL2(GEN))*(SH-MSL2(GR))+MSWD(GEN)*MSWD(GR))
31809      &                 *LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
31810      &                 *LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)*MIX(GR)
31811                     ENDIF
31812                   ENDDO
31813 C--Now the t-channel diagrams if the s-channel particles is a sneutrino
31814                   IF(GN.EQ.2) THEN
31815                     ECM=SQRT(PCM**2+MQ1**2)
31816                     TH=MQ1**2-SQSH*(ECM-PCM*COSTH)
31817                     DO GR=MIG,MXG
31818                       MET(2)=MET(2)+(MQ1**2-TH)*(MQ2**2-TH)*PCM*
31819      &                       LAM(2,INT((GEN+1)/2),I1,K1,J1,L1)*MIX(GEN)*
31820      &                       LAM(2,INT((GR+1)/2),I1,K1,J1,L1)*MIX(GR)
31821      &                       /((TH-MSL2(GEN))*(TH-MSL2(GR)))
31822                     ENDDO
31823                    ENDIF
31824  50              CONTINUE
31825 C--final phase space factors
31826                 IF(MET(1).LT.EPS.AND.MET(2).LT.EPS) GOTO 70
31827                 DO GR = 1,2
31828                   ME(GN,I1,J1,K1,L1,GR) = MET(GR)*CFAC
31829                 ENDDO
31830  60             DO GR = 1,2
31831                   CF = GR
31832                   IF(CUP.EQ.1) CF=0
31833                   HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(I,1)*DISF(J,2)
31834                   IF(HCS.GT.RCS.AND.GENEV) THEN
31835                     CALL HWHRSS(9,I,J,K,L,0,CF)
31836                     GOTO 100
31837                   ENDIF
31838                   HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(J,1)*DISF(I,2)
31839                   IF(HCS.GT.RCS.AND.GENEV) THEN
31840                     CALL HWHRSS(10,J,I,K,L,0,CF)
31841                     GOTO 100
31842                   ENDIF
31843                   HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
31844      &                                       *DISF(I+6,1)*DISF(J-6,2)
31845                   IF(HCS.GT.RCS.AND.GENEV) THEN
31846                     CALL HWHRSS(9,I,J,K,L,1,CF)
31847                     GOTO 100
31848                   ENDIF
31849                   HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
31850      &                                       *DISF(J-6,1)*DISF(I+6,2)
31851                   IF(HCS.GT.RCS.AND.GENEV) THEN
31852                     CALL HWHRSS(10,J,I,K,L,1,CF)
31853                     GOTO 100
31854                   ENDIF
31855                 ENDDO
31856  70           CONTINUE
31857             ENDDO
31858  80       CONTINUE
31859         ENDDO
31860       ENDDO
31861  100  IF(GENEV) THEN
31862         CALL HWETWO(.TRUE.,.TRUE.)
31863       ELSE
31864         EVWGT = HCS
31865       ENDIF
31866       END
31867 CDECK  ID>, HWHRLS.
31868 *CMZ :-        -23/10/00  13:53:06  by  Peter Richardson
31869 *-- Author :    Peter Richardson
31870 C-----------------------------------------------------------------------
31871       SUBROUTINE HWHRLS
31872 C-----------------------------------------------------------------------
31873 C  Subroutine for 2 parton -> sparticle + X via LQD
31874 C-----------------------------------------------------------------------
31875       INCLUDE 'herwig65.inc'
31876       DOUBLE PRECISION HCS,A(6,12),B(6,12),S,RCS,HWRGEN,CW,FAC2,EC,ME2,
31877      &               MW,G,TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,SW,SQSH,LC,
31878      &               SH,MSL(12),MSU(12),MST(6),C(2,6,12),D(2,6,12),UH,
31879      &               TH,MEN(4,6,3,3),SCF(12),SLWD(12),MLT(6),MNT(4),PCM,
31880      &               MXS(12),MER(8),MCR(2),RTAB,H(18),MEH(3,18),MXT(12),
31881      &               CHAN(12),MXU(12),RAND,FAC,ECM,MC(2),MEC(2,6,3,3),
31882      &               MZ,CHPROB,EPS,HWUAEM,XMIN,XMAX,XPOW,SIN2B,GUU(4),
31883      &               ML,MN,MLS,MNS,XUPP,MW2,MZ2,ZSLP(2),ZQRK(2),GDD(4),
31884      &               MSL2(12),MH(4),MSWD(12)
31885       INTEGER I,J,K,L,J1,K1,GN,GR,SP,GU,GT,I2,I1,NEUTMN
31886      &        ,NEUTMX,CHARMN,CHARMX,P
31887       LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
31888       EXTERNAL HWRGEN,HWRUNI,HWUAEM
31889       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
31890       SAVE HCS,A,B,C,D,FAC,MER,MEC,MEN,MLT,MSL,MSU,MST,SLWD,MNT,MXT,MXU,
31891      &     SW,CW,MXS,H,MEH,CHAN,NEUTMN,NEUTMX,CHARMN,CHARMX,RAD,NEUT,
31892      &     CHAR,HIGGS,MW,MZ,MW2,MZ2,MCR,SH,SQSH,EC,G,SCF,ZSLP,ZQRK,GUU,
31893      &     GDD,MSL2,MH,MSWD
31894       PARAMETER(EPS=1D-20)
31895       IF(GENEV) THEN
31896         RCS = HCS*HWRGEN(0)
31897       ELSE
31898         IF(FSTWGT) THEN
31899 C--Calculate Electroweak parameters needed
31900           SW  = SQRT(SWEIN)
31901           CW  = SQRT(1-SWEIN)
31902           MW  = RMASS(198)
31903           MZ  = RMASS(200)
31904           MW2 = MW**2
31905           MZ2 = MZ**2
31906           SIN2B = TWO*SINB*COSB
31907 C--Masses and widths
31908           DO I=1,3
31909             MSL(2*I-1)  = RMASS(423+2*I)
31910             MSL(2*I)    = RMASS(435+2*I)
31911             MSL(2*I+5)  = RMASS(424+2*I)
31912             MSL(2*I+6)  = RMASS(436+2*I)
31913             SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
31914             SLWD(2*I)   = HBAR/RLTIM(435+2*I)
31915             SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
31916             SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
31917             MSU(2*I-1)  = RMASS(400+2*I)**2
31918             MSU(2*I)    = RMASS(412+2*I)**2
31919             MSU(2*I+5)  = RMASS(399+2*I)**2
31920             MSU(2*I+6)  = RMASS(411+2*I)**2
31921             MST(2*I-1)  = RMASS(399+2*I)**2
31922             MST(2*I)    = RMASS(411+2*I)**2
31923             MLT(2*I)    = ZERO
31924             MLT(2*I-1)  = RMASS(119+2*I)
31925           ENDDO
31926           DO I=1,12
31927              MSL2(I) = MSL(I)**2
31928              MSWD(I) = MSL(I)*SLWD(I)
31929           ENDDO
31930           DO I=1,4
31931             MNT(I)   = ABS(RMASS(449+I))
31932           ENDDO
31933           MCR(1) = ABS(RMASS(454))
31934           MCR(2) = ABS(RMASS(455))
31935 C--Couplings for the neutralinos
31936           DO L=1,4
31937             MC(1) =  ZMIXSS(L,3)/(2*MW*COSB*SW)
31938             MC(2) =  ZMIXSS(L,4)/(2*MW*SINB*SW)
31939             DO I=1,3
31940               DO J=1,2
31941 C--resonant charged sleptons
31942                 A(L,2*I-2+J) = MC(1)*MLT(2*I-1)*LMIXSS(2*I-1,2,J)
31943      &                         +SLFCH(9+2*I,L)*LMIXSS(2*I-1,1,J)
31944                 B(L,2*I-2+J) = ZSGNSS(L)*(MC(1)*MLT(2*I-1)*
31945      &            LMIXSS(2*I-1,1,J)+SRFCH(9+2*I,L)*LMIXSS(2*I-1,2,J))
31946 C--resonant sneutrinos
31947                 A(L,2*I+4+J) = SLFCH(10+2*I,L)*LMIXSS(2*I,1,J)
31948                 B(L,2*I+4+J) = ZERO
31949 C--u channel up type squarks
31950                 C(1,L,2*I-2+J) = MC(2)*QMIXSS(2*I,2,J)*
31951      &                    RMASS(2*I)+SLFCH(2*I,L)*QMIXSS(2*I,1,J)
31952                 D(1,L,2*I-2+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
31953      &                    RMASS(2*I)+SRFCH(2*I  ,L)*QMIXSS(2*I,2,J))
31954 C--u channel down type squarks
31955                 C(1,L,2*I+4+J) = MC(1)*QMIXSS(2*I-1,2,J)*
31956      &                    RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
31957                 D(1,L,2*I+4+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
31958      &                    RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
31959 C--t channel down type squarks
31960                 C(2,L,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
31961      &                    RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
31962                 D(2,L,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
31963      &                    RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
31964               ENDDO
31965             ENDDO
31966             DO I=1,6
31967               C(2,L,6+I) = C(2,L,I)
31968               D(2,L,6+I) = D(2,L,I)
31969             ENDDO
31970           ENDDO
31971 C--Couplings for charginos
31972           DO L=1,2
31973             MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
31974             MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
31975             SP=L+4
31976             DO I=1,3
31977               DO J=1,2
31978 C--resonant charged slepton
31979                 A(SP,2*I-2+J) = WMXUSS(L,1)*LMIXSS(2*I-1,1,J)
31980      &                          -LMIXSS(2*I-1,2,J)*WMXUSS(L,2)*
31981      &                             MLT(2*I-1)*MC(1)
31982                 B(SP,2*I-2+J) = ZERO
31983 C--resonant sneutrinos
31984                 A(SP,2*I+4+J) = WSGNSS(L)*WMXVSS(L,1)*LMIXSS(2*I,1,J)
31985                 B(SP,2*I+4+J) = -MLT(2*I-1)*WMXUSS(L,2)*LMIXSS(2*I,1,J)
31986      &                           *MC(1)
31987 C--u channel sup
31988                 C(1,SP,2*I-2+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
31989      &              -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
31990                 D(1,SP,2*I-2+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
31991      &                            *QMIXSS(2*I,1,J)
31992 C--u channel sdown
31993                 C(1,SP,2*I+4+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
31994      &              -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
31995                 D(1,SP,2*I+4+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
31996      &                            RMASS(2*I)*QMIXSS(2*I-1,1,J)
31997               ENDDO
31998             ENDDO
31999           ENDDO
32000 C--Couplings and massesfor Higgs
32001           DO I=1,4
32002              MH(I) = RMASS(202+I)
32003           ENDDO
32004 C--first the neutral Higgs
32005 C--fix to the sign of the A and mu term 31/03/00 PR
32006           DO I=1,3
32007             H(I)  = MLT(2*I-1)*HALF/MW/COSB*MUSS*COSA
32008             H(I+4) = MLT(2*I-1)*HALF/MW/COSB*MUSS*SINA
32009             H(I+8) =  -MLT(2*I-1)*HALF/MW*MUSS
32010           ENDDO
32011           H(3) = (H(3)+MLT(5)*HALF/MW/COSB*ALSS*SINA)*TWO*
32012      &           LMIXSS(5,2,1)*LMIXSS(5,1,1)
32013      &           -MZ*SINBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
32014      &           +SWEIN*LMIXSS(5,2,1)**2)+MLT(5)**2*SINA/MW/COSB
32015           H(4) = -MZ*SINBPA/CW*(LMIXSS(5,1,1)*LMIXSS(5,1,2)*(HALF-SWEIN)
32016      &            +SWEIN*LMIXSS(5,2,1)*LMIXSS(5,2,2))
32017      &            +MLT(5)*HALF/COSB/MW*(MUSS*COSA+ALSS*SINA)*
32018      &         (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
32019           H(7) = (H(7)-MLT(5)*HALF/MW/COSB*ALSS*COSA)*TWO*
32020      &            LMIXSS(5,2,1)*LMIXSS(5,1,1)
32021      &            +MZ*COSBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
32022      &            +LMIXSS(5,2,1)**2*SWEIN)-MLT(5)**2*COSA/MW/COSB
32023           H(8) = MZ*COSBPA/CW*(LMIXSS(5,1,2)*LMIXSS(5,1,1)*(HALF-SWEIN)
32024      &            +LMIXSS(5,2,2)*LMIXSS(5,2,1)*SWEIN)
32025      &            +MLT(5)*HALF/MW/COSB*(MUSS*SINA-ALSS*COSA)*
32026      &         (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
32027           H(12) = H(11)-MLT(5)*HALF/MW*ALSS*TANB
32028           H(11) = ZERO
32029 C--Now the charged Higgs
32030           DO J=1,2
32031             DO I=1,3
32032               H(10+2*I+J) = LMIXSS(2*I-1,1,J)*
32033      &                                  (MLT(2*I-1)**2*TANB-MW2*SIN2B)
32034      &                      +LMIXSS(2*I-1,2,J)*MLT(2*I-1)*MUSS
32035             ENDDO
32036             H(16+J) = H(16+J)+LMIXSS(5,2,J)*MLT(5)*ALSS*TANB
32037           ENDDO
32038 C--End of fix
32039 C--couplings of the Higgs to quarks
32040           DO I=1,3
32041              GUU(I) = GHUUSS(I)**2/MW2*HALF**2
32042              GDD(I) = GHDDSS(I)**2/MW2*HALF**2
32043           ENDDO
32044           GUU(4) = ONE/TANB**2/MW2/8.0D0
32045           GDD(4) = ONE*TANB**2/MW2/8.0D0
32046 C--Couplings of the Z to quarks, left up right down, and charged sleptons
32047           ZQRK(1) = -SW**2/6.0D0/CW
32048           ZQRK(2) =  (SW**2/3.0D0-HALF**2)/CW
32049           ZSLP(1) =  HALF*(LMIXSS(5,1,1)**2-2.0D0*SW**2)/CW
32050           ZSLP(2) =  HALF*LMIXSS(5,1,1)*LMIXSS(5,1,2)/CW
32051 C--parameters for multichannel integration
32052           RAND = ZERO
32053           DO I=1,3
32054             CHPROB = ZERO
32055             DO J=1,3
32056               DO K=1,3
32057                 CHPROB=CHPROB+LAMDA2(I,J,K)**2
32058               ENDDO
32059             ENDDO
32060             RAND = RAND+2*CHPROB
32061             DO J=1,2
32062               MXS(2*I-2+J)  = LMIXSS(2*I-1,1,J)
32063               MXS(2*I+4+J)  = LMIXSS(2*I,1,J)
32064               MXU(2*I-2+J)   = QMIXSS(2*I,1,J)
32065               MXU(2*I+4+J)   = QMIXSS(2*I-1,1,J)
32066               MXT(2*I-2+J)   = QMIXSS(2*I-1,2,J)
32067               MXT(2*I+4+J)   = QMIXSS(2*I-1,2,J)
32068               CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHPROB
32069               CHAN(2*I+4+J) = LMIXSS(2*I,1,J)**2*CHPROB
32070             ENDDO
32071           ENDDO
32072           IF(RAND.GT.ZERO) THEN
32073             DO I=1,12
32074               CHAN(I)=CHAN(I)/RAND
32075             ENDDO
32076           ELSE
32077             CALL HWWARN('HWHRLS',500)
32078           ENDIF
32079 C--decide what processes to generate
32080           RAD   = .FALSE.
32081           NEUT  = .FALSE.
32082           CHAR  = .FALSE.
32083           HIGGS = .FALSE.
32084           NEUTMN= 1
32085           NEUTMX = 4
32086           CHARMN = 1
32087           CHARMX = 2
32088 C--Decide which process to generate
32089           IF(MOD(IPROC,10000).EQ.4000) THEN
32090             RAD   = .TRUE.
32091             NEUT  = .TRUE.
32092             CHAR  = .TRUE.
32093             HIGGS = .TRUE.
32094           ELSEIF(MOD(IPROC,10000).LT.4020) THEN
32095             IF(MOD(IPROC,10000).NE.4010) THEN
32096               NEUTMN = MOD(IPROC,10)
32097               NEUTMX = NEUTMN
32098             ENDIF
32099             NEUT=.TRUE.
32100           ELSEIF(MOD(IPROC,10000).LT.4030) THEN
32101             IF(MOD(IPROC,10000).NE.4020) THEN
32102               CHARMN = MOD(IPROC,10)
32103               CHARMX=CHARMN
32104             ENDIF
32105             CHAR  = .TRUE.
32106           ELSEIF(MOD(IPROC,10000).EQ.4040) THEN
32107             RAD   = .TRUE.
32108           ELSEIF(MOD(IPROC,10000).EQ.4050) THEN
32109             HIGGS = .TRUE.
32110           ENDIF
32111         ENDIF
32112 C--basic parameters
32113         EVWGT = ZERO
32114         S     = PHEP(5,3)**2
32115         COSTH = HWRUNI(0,-ONE,ONE)
32116         RAND  = HWRUNI(0,ZERO,ONE)
32117 C--zero arrays
32118         DO I=1,6
32119           DO J=1,3
32120             DO K=1,3
32121               DO L=1,2
32122                MEN(L,I,J,K)   = ZERO
32123                MEN(L+2,I,J,K) = ZERO
32124                MEC(L,I,J,K)   = ZERO
32125               ENDDO
32126             ENDDO
32127           ENDDO
32128         ENDDO
32129         DO I=1,8
32130           MER(I)=ZERO
32131         ENDDO
32132 C--Perform multichannel integration
32133         DO I=1,12
32134           IF(CHAN(I).GT.RAND) THEN
32135              GR=I
32136              GOTO 25
32137           ENDIF
32138           RAND=RAND-CHAN(I)
32139         ENDDO
32140 C--Calculate the hard scale and obtain parton distributions
32141  25     TAUA   = MSL2(GR)/S
32142         TAUB   = SLWD(GR)**2/S
32143         RTAB   = SQRT(TAUA*TAUB)
32144         XUPP = XMAX
32145         IF(XMAX**2.GT.S) XUPP = SQRT(S)
32146         LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
32147         UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
32148         TAU    = HWRUNI(0,LOWTLM,UPPTLM)
32149         TAU    = RTAB*TAN(RTAB*TAU)+TAUA
32150         SH   = S*TAU
32151         SQSH = SQRT(SH)
32152         EMSCA  = SQSH
32153         XX(1)  = EXP(HWRUNI(0,LOG(TAU),ZERO))
32154         XX(2)  = TAU/XX(1)
32155         CALL HWSGEN(.FALSE.)
32156 C--EM and Weak couplings
32157         EC = SQRT(4*PIFAC*HWUAEM(SH))
32158         G  = EC/SW
32159 C--Calculate the prefactor due multichannel approach
32160         FAC = ZERO
32161         DO GN=1,12
32162          SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
32163          FAC=FAC+CHAN(GN)*SCF(GN)
32164         ENDDO
32165         FAC=-(UPPTLM-LOWTLM)*GEV2NB*LOG(TAU)/
32166      &       (48*TAU*FAC*PIFAC*S**2*SH*SQSH)
32167       ENDIF
32168       HCS = ZERO
32169 C--First we do the neutralino production
32170       IF(.NOT.NEUT) GOTO 200
32171       DO 140 GN=1,6
32172       I=GN
32173       GR = 2*GN-1
32174       I1 = 2*GN-1
32175       IF(GN.GT.3) THEN
32176         I=I-3
32177         I1=I1-5
32178       ENDIF
32179       IF(CHAN(GR).LT.EPS) GOTO 140
32180         DO 130 L=NEUTMN,NEUTMX
32181         MN  = MNT(L)
32182         MNS = MN**2
32183         ML  = MLT(I1)
32184         MLS = ML**2
32185         IF((ML+MN).GT.SQSH) GOTO 130
32186 C--that and uhat
32187         PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
32188         ECM = SQRT(PCM**2+MLS)
32189         TH = MLS-SQSH*(ECM-PCM*COSTH)
32190         UH = MLS-SQSH*(ECM+PCM*COSTH)
32191         DO J=1,3
32192           DO 120 K=1,3
32193             IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 120
32194             J1 = 2*J
32195             K1 = 2*K+5
32196             IF(GN.GT.3) J1=J1-1
32197             IF(GENEV) GOTO 110
32198 C--squarks in u and t channels
32199             GU = 6*INT((GN-1)/3)+2*J-1
32200             GT = 2*K
32201 C--calulate the matrix element
32202             ME2=MXS(GR)**2*SCF(GR)*SH*((SH-MLS-MNS)*
32203      &            (A(L,GR)**2+B(L,GR)**2)-4*ML*MN*A(L,GR)*B(L,GR))
32204      &          +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
32205      &               (C(1,L,GU)**2+D(1,L,GU)**2)/(UH-MSU(GU))**2
32206      &          +MXT(GT)**2*(MLS-TH)*(MNS-TH)*
32207      &               (C(2,L,GT)**2+D(2,L,GT)**2)/(TH-MST(GT))**2
32208      &          -TWO*MXT(GT)*MXU(GU)*C(1,L,GU)*C(2,L,GT)*(MLS*MNS-UH*TH)
32209      &                 /(UH-MSU(GU))/(TH-MST(GT))
32210      &          +TWO*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,L,GU)*
32211      &                 SH*(UH*A(L,GR)+ML*MN*B(L,GR))/(UH-MSU(GU))
32212      &          +TWO*MXS(GR)*MXT(GT)*(SH-MSL2(GR))*SCF(GR)*C(2,L,GT)*
32213      &                 SH*(TH*A(L,GR)+ML*MN*B(L,GR))/(TH-MST(GT))
32214 C--s channel mixing L/R mixing
32215             IF(ABS(MXS(GR+1)).GT.EPS) THEN
32216               ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
32217      &               (A(L,GR+1)**2+B(L,GR+1)**2)
32218      &               -4*ML*MN*A(L,GR+1)*B(L,GR+1))
32219      &            +TWO*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
32220      &               ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
32221      &               MSWD(GR)*MSWD(GR+1))*SH*
32222      &               ((SH-MLS-MNS)*(A(L,GR)*A(L,GR+1)+B(L,GR)*B(L,GR+1))
32223      &               -2*ML*MN*(A(L,GR)*B(L,GR+1)+A(L,GR+1)*B(L,GR)))
32224      &            +TWO*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*
32225      &               SH*C(1,L,GU)*(UH*A(L,GR+1)+ML*MN*B(L,GR+1))
32226      &               /(UH-MSU(GU))
32227      &            +TWO*MXS(GR+1)*MXT(GT)*(SH-MSL2(GR+1))*SCF(GR+1)*
32228      &               SH*C(2,L,GT)*(TH*A(L,GR+1)+ML*MN*B(L,GR+1))
32229      &               /(TH-MST(GT))
32230               IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXU(GU+1)*
32231      &               (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(1,L,GU+1)*
32232      &               (UH*A(L,GR+1)+ML*MN*B(L,GR+1))/(UH-MSU(GU+1))
32233               IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXT(GT-1)*
32234      &               (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(2,L,GT-1)*
32235      &               (TH*A(L,GR+1)+ML*MN*B(L,GR+1))/(TH-MST(GT-1))
32236             ENDIF
32237 C--u channel L/R mixing
32238             IF(ABS(MXU(GU+1)).GT.EPS) THEN
32239               ME2=ME2+MXU(GU+1)**2*(MLS-UH)*(MNS-UH)*(C(1,L,GU+1)**2+
32240      &               D(1,L,GU+1)**2)/(UH-MSU(GU+1))**2
32241      &            +TWO*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
32242      &               (C(1,L,GU)*C(1,L,GU+1)+D(1,L,GU)*D(1,L,GU+1))
32243      &               /(UH-MSU(GU))/(UH-MSU(GU+1))
32244      &            -TWO*MXT(GT)*MXU(GU+1)*C(1,L,GU+1)*C(2,L,GT)*
32245      &               (MLS*MNS-UH*TH)/(UH-MSU(GU+1))/(TH-MST(GT))
32246      &            +TWO*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*
32247      &               SH*C(1,L,GU+1)*(UH*A(L,GR)+ML*MN*B(L,GR))
32248      &               /(UH-MSU(GU+1))
32249               IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2-TWO*MXT(GT-1)*MXU(GU+1)*
32250      &               C(1,L,GU+1)*C(2,L,GT-1)*(MLS*MNS-UH*TH)
32251      &               /(UH-MSU(GU+1))/(TH-MST(GT-1))
32252             ENDIF
32253 C--t channel L/R mixing
32254             IF(ABS(MXT(GT-1)).GT.EPS) THEN
32255               ME2=ME2+MXT(GT-1)**2*(MLS-TH)*(MNS-TH)*(C(2,L,GT-1)**2
32256      &                +D(2,L,GT-1)**2)/(TH-MST(GT-1))**2
32257      &            +TWO*MXT(GT)*MXT(GT-1)*(MLS-TH)*(MNS-TH)*
32258      &               (C(2,L,GT)*C(2,L,GT-1)+D(2,L,GT)*D(2,L,GT-1))
32259      &               /(TH-MST(GT))/(TH-MST(GT-1))
32260      &            -TWO*MXT(GT-1)*MXU(GU)*C(1,L,GU)*C(2,L,GT-1)*
32261      &               (MLS*MNS-UH*TH)/(UH-MSU(GU))/(TH-MST(GT-1))
32262      &            +TWO*MXS(GR)*MXT(GT-1)*(SH-MSL2(GR))*SCF(GR)*
32263      &               SH*C(2,L,GT-1)*(TH*A(L,GR)+ML*MN*B(L,GR))
32264      &               /(TH-MST(GT-1))
32265             ENDIF
32266 C--multiply by lamda and factors
32267             MEN(L,GN,J,K) = FAC*ME2*EC**2*LAMDA2(I,J,K)**2*PCM
32268  110        I2=I1+6
32269             HCS = HCS+MEN(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
32270             IF(GENEV.AND.HCS.GT.RCS) THEN
32271               CALL HWHRSS(11,J1,K1,I2,L,0,0)
32272               GOTO 500
32273             ENDIF
32274             HCS = HCS+MEN(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
32275             IF(GENEV.AND.HCS.GT.RCS) THEN
32276               CALL HWHRSS(12,K1,J1,I2,L,0,0)
32277               GOTO 500
32278             ENDIF
32279             HCS = HCS+MEN(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
32280             IF(GENEV.AND.HCS.GT.RCS) THEN
32281               CALL HWHRSS(11,J1,K1,I2,L,1,0)
32282               GOTO 500
32283             ENDIF
32284             HCS = HCS+MEN(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
32285             IF(GENEV.AND.HCS.GT.RCS) THEN
32286               CALL HWHRSS(12,K1,J1,I2,L,1,0)
32287               GOTO 500
32288             ENDIF
32289  120      CONTINUE
32290         ENDDO
32291  130    CONTINUE
32292  140  CONTINUE
32293  200  IF(.NOT.CHAR) GOTO 300
32294 C--Chargino production
32295       DO 240 GN=1,6
32296       GR=2*GN-1
32297       I=GN
32298       I1 = 2*GN
32299       IF(GN.GT.3) THEN
32300         I1=I1-7
32301         I=GN-3
32302       ENDIF
32303       IF(CHAN(GR).LT.EPS) GOTO 240
32304       DO 230 L=CHARMN,CHARMX
32305         MN  = MCR(L)
32306         MNS = MN**2
32307         ML  = MLT(I1)
32308         MLS = ML**2
32309         SP = L+4
32310         IF((ML+MN).GT.EMSCA) GOTO 230
32311         PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
32312         ECM = SQRT(PCM**2+MLS)
32313         TH = MLS-SQSH*(ECM-PCM*COSTH)
32314         UH = MLS-SQSH*(ECM+PCM*COSTH)
32315         DO J=1,3
32316           DO 220 K=1,3
32317             IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 220
32318             J1=2*J
32319             K1=2*K+5
32320             IF(GN.GT.3) J1=J1-1
32321             IF(GENEV) GOTO 210
32322             GU = 2*J-1
32323             IF(GN.LE.3) GU=GU+6
32324 C--Calculate the matrix element, s and u terms
32325              ME2 =MXS(GR)**2*SCF(GR)*SH*(
32326      &             (SH-MLS-MNS)*(A(SP,GR)**2+B(SP,GR)**2)
32327      &             -4*ML*MN*A(SP,GR)*B(SP,GR))
32328      &          +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
32329      &             (C(1,SP,GU)**2+D(1,SP,GU)**2)/(UH-MSU(GU))**2
32330      &          -2*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,SP,GU)*
32331      &             SH*(UH*A(SP,GR)+B(SP,GR)*ML*MN)/(UH-MSU(GU))
32332 C--s channel L/R mixing
32333             IF(ABS(MXS(GR+1)).GT.EPS) THEN
32334               ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
32335      &               (A(SP,GR+1)**2+B(SP,GR+1)**2)
32336      &                -4*ML*MN*A(SP,GR+1)*B(SP,GR+1))
32337      &           +2*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
32338      &               ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
32339      &               MSWD(GR)*MSWD(GR+1))*SH*
32340      &               ((SH-MLS-MNS)*(A(SP,GR)*A(SP,GR+1)
32341      &               +B(SP,GR)*B(SP,GR+1))-4*ML*MN*
32342      &               (A(SP,GR)*B(SP,GR+1)+B(SP,GR)*A(SP,GR+1)))
32343      &           -2*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*SH*
32344      &               C(1,SP,GU)*(UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)
32345      &               /(UH-MSU(GU))
32346               IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2-2*MXS(GR+1)*MXU(GU+1)*
32347      &               (SH-MSL2(GR+1))*SCF(GR+1)*C(1,SP,GU+1)*SH*
32348      &         (UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)/(UH-MSU(GU+1))
32349             ENDIF
32350 C--u channel L/R mixing
32351             IF(ABS(MXU(GU+1)).GT.EPS) ME2 = ME2+MXU(GU+1)**2*(MLS-UH)*
32352      &             (MNS-UH)*(C(1,SP,GU+1)**2+D(1,SP,GU+1)**2)
32353      &             /(UH-MSU(GU+1))**2
32354      &          +2*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
32355      &             (C(1,SP,GU)*C(1,SP,GU+1)+D(1,SP,GU)*D(1,SP,GU+1))
32356      &             /(UH-MSU(GU))/(UH-MSU(GU+1))
32357      &          -2*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*SH*
32358      &             C(1,SP,GU+1)*(UH*A(SP,GR)+B(SP,GR)*ML*MN)
32359      &             /(UH-MSU(GU+1))
32360             MEC(L,GN,J,K) = FAC*ME2*G**2*LAMDA2(I,J,K)**2*PCM*HALF
32361  210        I2 = I1+6
32362             P = L+4
32363             HCS = HCS+MEC(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
32364             IF(GN.GT.3) P = P+2
32365             IF(GENEV.AND.HCS.GT.RCS) THEN
32366               CALL HWHRSS(11,J1,K1,I2,P,0,0)
32367               GOTO 500
32368             ENDIF
32369             HCS = HCS+MEC(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
32370             IF(GENEV.AND.HCS.GT.RCS) THEN
32371               CALL HWHRSS(12,K1,J1,I2,P,0,0)
32372               GOTO 500
32373             ENDIF
32374             HCS = HCS+MEC(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
32375             IF(GENEV.AND.HCS.GT.RCS) THEN
32376               CALL HWHRSS(11,J1,K1,I2,P,1,0)
32377               GOTO 500
32378             ENDIF
32379             HCS = HCS+MEC(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
32380             IF(GENEV.AND.HCS.GT.RCS) THEN
32381               CALL HWHRSS(12,K1,J1,I2,P,1,0)
32382               GOTO 500
32383             ENDIF
32384  220      CONTINUE
32385         ENDDO
32386  230  CONTINUE
32387  240  CONTINUE
32388  300   IF(.NOT.RAD) GOTO 400
32389 C--Radiative decays
32390        IF(GENEV) GOTO 320
32391        DO 310 GN=1,3
32392        I1= 2*GN+5
32393        I = 2*GN-1
32394 C--charged slepton to sneutrino W
32395        IF(SQSH.GT.(MW+MSL(I1))) THEN
32396        PCM = SQRT((SH-(MW+MSL(I1))**2)*(SH-(MW-MSL(I1))**2))*HALF/SQSH
32397        ECM = SQRT(PCM**2+MW2)
32398        TH = MW2-SQSH*(ECM-PCM*COSTH)
32399        UH = MW2-SQSH*(ECM+PCM*COSTH)
32400        ME2 = MXS(I)**4*SCF(I)*SH**2*PCM**2
32401      &       +HALF**2/TH**2*(TWO*MW2*(UH*TH-MSL2(I1)*MW2)+TH**2*SH)
32402      &       -HALF*MXS(I)**2*SH*(SH-MSL2(I))*SCF(I)/TH*
32403      &         (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
32404        IF(GN.EQ.3) ME2 = ME2+MXS(I+1)**4*SCF(I+1)*SH**2*PCM**2
32405      &     +2.0D0*MXS(I)**2*MXS(I+1)**2*SCF(I)*SCF(I+1)*SH**2*PCM**2
32406      &         *((SH-MSL2(I))*(SH-MSL2(I+1))+MSWD(I)*MSWD(I+1))
32407      &         -HALF*MXS(I+1)**2*SH*(SH-MSL2(I+1))*SCF(I+1)/TH*
32408      &         (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
32409        MER(GN) = ME2*PCM/MW2
32410        ENDIF
32411 C--sneutrino to charged slepton W
32412        IF(SQSH.GT.(MW+MSL(I))) THEN
32413        PCM = SQRT((SH-(MW+MSL(I))**2)*(SH-(MW-MSL(I))**2))*HALF/SQSH
32414        ECM = SQRT(PCM**2+MW2)
32415        TH = MW2-SQSH*(ECM-PCM*COSTH)
32416        UH = MW2-SQSH*(ECM+PCM*COSTH)
32417        ME2 = MXS(I)**2*SCF(I1)*SH**2*PCM**2
32418      &       +HALF**2*MXS(I)**2/TH**2*
32419      &                      (TWO*MW2*(UH*TH-MW2*MSL2(I))+TH**2*SH)
32420      &       -HALF*MXS(I)**2*SH*(SH-MSL2(I1))*SCF(I1)/TH*
32421      &        (MW2*(TWO*MSL2(I)-TH)+(SH-MSL2(I))*TH)
32422        MER(GN+4) = ME2*PCM/MW2
32423        ENDIF
32424  310   CONTINUE
32425 C--now the decay stau_2 to stau_1 Z
32426        IF(SQSH.GT.(MZ+MSL(5))) THEN
32427        PCM = SQRT((SH-(MZ+MSL(5))**2)*(SH-(MZ-MSL(5))**2))*HALF/SQSH
32428        ECM = SQRT(PCM**2+MZ2)
32429        TH = MZ2-SQSH*(ECM-PCM*COSTH)
32430        UH = MZ2-SQSH*(ECM+PCM*COSTH)
32431        ME2 = SH**2*PCM**2*(SCF(5)*MXS(5)**2*ZSLP(1)**2
32432      &              +SCF(6)*MXS(6)**2*ZSLP(2)**2+TWO*SCF(5)*SCF(6)*
32433      &              MXS(5)*MXS(6)*ZSLP(1)*ZSLP(2)*((SH-MSL2(5))*
32434      &              (SH-MSL2(6))+MSWD(5)*MSWD(6)))
32435      &      +MXS(5)**2*ZQRK(2)**2/TH**2*
32436      &              (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+TH**2*SH)
32437      &      +MXS(5)**2*ZQRK(1)**2/UH**2*
32438      &              (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+UH**2*SH)
32439      &      +MXS(5)*SH*(MXS(5)*SCF(5)*ZSLP(1)*(SH-MSL2(5))
32440      &              +MXS(6)*SCF(6)*ZSLP(2)*(SH-MSL2(6)))*
32441      &              (-ZQRK(2)/TH*(MZ2*(TWO*MSL2(5)-TH)+TH*(SH-MSL2(5)))
32442      &               +ZQRK(1)/UH*(MZ2*(TWO*MSL2(5)-UH)+UH*(SH-MSL2(5))))
32443      &      +TWO*MXS(5)**2*ZQRK(1)*ZQRK(2)/UH/TH*
32444      &               (TWO*MZ2*(MSL2(5)-UH)*(MSL2(5)-TH)-SH*UH*TH)
32445        MER(4) = TWO*ME2*PCM/MZ2
32446        ENDIF
32447 C--now the decay tau sneutrino to tau_2 W
32448        IF(SQSH.GT.(MW+MSL(6))) THEN
32449        PCM = SQRT((SH-(MW+MSL(6))**2)*(SH-(MW-MSL(6))**2))*HALF/SQSH
32450        ECM = SQRT(PCM**2+MW2)
32451        TH = MW2-SQSH*(ECM-PCM*COSTH)
32452        UH = MW2-SQSH*(ECM+PCM*COSTH)
32453        ME2 = MXS(6)**2*SCF(11)*SH**2*PCM**2
32454      &       +HALF**2*MXS(6)**2/TH**2*
32455      &                      (TWO*MW2*(UH*TH-MW2*MSL2(6))+TH**2*SH)
32456      &       -HALF*MXS(6)**2*SH*(SH-MSL2(11))*SCF(11)/TH*
32457      &        (MW2*(2*MSL2(6)-TH)+(SH-MSL2(6))*TH)
32458        MER(8) = ME2*PCM/MW2
32459        ENDIF
32460 C--Multiply by the parton distributions
32461  320   DO I=1,4
32462         DO J=1,3
32463          DO 330 K=1,3
32464          IF(I.LE.3) THEN
32465            LC = LAMDA2(I,J,K)**2
32466          ELSE
32467            LC = LAMDA2(3,J,K)**2
32468          ENDIF
32469          IF(LC.LT.EPS) GOTO 330
32470          FAC2 = G**2*LC*FAC
32471 C--radiative cross-sections
32472          J1=2*J
32473          K1=2*K+5
32474          ME2 = FAC2*MER(I)
32475          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32476          IF(GENEV.AND.HCS.GT.RCS) THEN
32477            CALL HWHRSS(13,J1,K1,I,I,0,0)
32478            GOTO 500
32479          ENDIF
32480          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32481          IF(GENEV.AND.HCS.GT.RCS) THEN
32482             CALL HWHRSS(14,K1,J1,I,I,0,0)
32483             GOTO 500
32484          ENDIF
32485          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32486          IF(GENEV.AND.HCS.GT.RCS) THEN
32487            CALL HWHRSS(13,J1,K1,I,I,1,0)
32488            GOTO 500
32489          ENDIF
32490          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32491          IF(GENEV.AND.HCS.GT.RCS) THEN
32492            CALL HWHRSS(14,K1,J1,I,I,1,0)
32493            GOTO 500
32494          ENDIF
32495          J1=2*J-1
32496          K1=2*K+5
32497          ME2 = FAC2*MER(I+4)
32498          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32499          IF(GENEV.AND.HCS.GT.RCS) THEN
32500            CALL HWHRSS(13,J1,K1,I+4,I+4,0,0)
32501            GOTO 500
32502          ENDIF
32503          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32504          IF(GENEV.AND.HCS.GT.RCS) THEN
32505            CALL HWHRSS(14,K1,J1,I+4,I+4,0,0)
32506            GOTO 500
32507          ENDIF
32508          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32509          IF(GENEV.AND.HCS.GT.RCS) THEN
32510            CALL HWHRSS(13,J1,K1,I+4,I+4,1,0)
32511            GOTO 500
32512          ENDIF
32513          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32514          IF(GENEV.AND.HCS.GT.RCS) THEN
32515            CALL HWHRSS(14,K1,J1,I+4,I+4,1,0)
32516            GOTO 500
32517          ENDIF
32518  330     CONTINUE
32519         ENDDO
32520        ENDDO
32521  400   IF(.NOT.HIGGS) GOTO 500
32522        IF(GENEV) GOTO 480
32523        DO I=1,3
32524           DO 405 J=1,18
32525  405      MEH(I,J) = ZERO
32526        ENDDO
32527 C--Neutral higgs charged slepton
32528        DO 420 L=1,3
32529          DO 410 I=1,2
32530 C--first two generations
32531            IF(SQSH.LT.MH(L)+MSL(2*I)) GOTO 410
32532            PCM = SQRT((SH-(MSL(2*I)+MH(L))**2)*
32533      &                (SH-(MSL(2*I)-MH(L))**2))*HALF/SQSH
32534            MEH(1,3*L-3+I) = PCM*SH*SCF(2*I-1)*H(4*L+I-4)**2
32535  410     CONTINUE
32536 C--third generation
32537          IF(SQSH.LT.MH(L)+MSL(5)) GOTO 420
32538          PCM = SQRT((SH-(MSL(5)+MH(L))**2)*
32539      &              (SH-(MSL(5)-MH(L))**2))*HALF/SQSH
32540          ECM = SQRT(PCM**2+MH(L)**2)
32541          TH = MH(L)**2-SQSH*(ECM-PCM*COSTH)
32542          UH = MH(L)**2-SQSH*(ECM+PCM*COSTH)
32543          MEH(1,3*L) = PCM*SH*(MXS(5)**2*SCF(5)*H(4*L-1)**2
32544      &                 +MXS(6)**2*SCF(6)*H(4*L)**2
32545      &                 +TWO*MXS(5)*MXS(6)*SCF(5)*SCF(6)*H(4*L-1)*
32546      &                 H(4*L)*((SH-MSL2(5))*(SH-MSL2(6))+
32547      &                 MSWD(5)*MSWD(6)) )
32548          ME2        = MXS(5)**2*PCM*(UH*TH-MSL2(5)*MH(L)**2)
32549          MEH(2,3*L) =ME2*GUU(L)/TH**2
32550          MEH(3,3*L) =ME2*GDD(L)/UH**2
32551  420     CONTINUE
32552 C--Charged higgs
32553         DO 440 I=1,3
32554 C--charged slepton charged Higgs
32555           DO 430 J=1,2
32556           IF(SQSH.LT.(MH(4)+MSL(2*I-2+J))) GOTO 430
32557           PCM = SQRT((SH-(MH(4)+MSL(2*I-2+J))**2)*
32558      &               (SH-(MH(4)-MSL(2*I-2+J))**2))*HALF/SQSH
32559           ECM = SQRT(PCM**2+MH(4)**2)
32560           TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
32561           UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
32562           MEH(1,2*I+J+7) = PCM*SH*HALF/MW2*H(2*I+J+10)**2*SCF(5+2*I)
32563           MEH(2,2*I+J+7) = PCM*GDD(4)*MXS(2*I-2+J)**2*
32564      &                      (UH*TH-MH(4)**2*MSL2(2*I-2+J))/TH**2
32565  430      CONTINUE
32566 C--Sneutrino Charged Higgs
32567           IF(SQSH.LT.(MH(4)+MSL(2*I+5))) GOTO 440
32568           PCM = SQRT((SH-(MH(4)+MSL(2*I+5))**2)*
32569      &               (SH-(MH(4)-MSL(2*I+5))**2))*HALF/SQSH
32570           ECM = SQRT(PCM**2+MH(4)**2)
32571           TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
32572           UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
32573           MEH(1,15+I) = PCM*SH*HALF/MW2*(
32574      &                MXS(2*I-1)**2*SCF(2*I-1)*H(11+2*I)**2
32575      &               +MXS(2*I)**2*SCF(2*I)*H(12+2*I)**2
32576      &               +TWO*MXS(2*I-1)*MXS(2*I)*SCF(2*I-1)*
32577      &                SCF(2*I)*H(11+2*I)*H(12+2*I)*
32578      &             ((SH-MSL2(2*I-1))*(SH-MSL2(2*I))+
32579      &              MSWD(2*I-1)*MSWD(2*I)))
32580           MEH(2,15+I) = PCM*GUU(4)*
32581      &                    (UH*TH-MH(4)**2*MSL2(2*I+5))/TH**2
32582  440    CONTINUE
32583 C--Multiply by the parton distributions
32584  480    DO I=1,3
32585         DO J=1,3
32586          DO 490 K=1,3
32587          IF(LAMDA2(I,J,K).LT.EPS) GOTO 490
32588 C--Higgs cross-sections
32589          J1=2*J
32590          K1=2*K+5
32591          FAC2 = G**2*LAMDA2(I,J,K)**2*FAC*HALF
32592          DO L=1,3
32593          ME2 = FAC2*(MEH(1,3*L-3+I)+RMASS(J1)**2*MEH(2,3*L-3+I)
32594      &            +RMASS(K1)**2*MEH(3,3*L-3+I))
32595          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32596          IF(GENEV.AND.HCS.GT.RCS) THEN
32597            CALL HWHRSS(15,J1,K1,I,L,0,0)
32598            GOTO 500
32599          ENDIF
32600          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32601          IF(GENEV.AND.HCS.GT.RCS) THEN
32602            CALL HWHRSS(16,K1,J1,I,L,0,0)
32603            GOTO 500
32604          ENDIF
32605          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32606          IF(GENEV.AND.HCS.GT.RCS) THEN
32607            CALL HWHRSS(15,J1,K1,I,L,1,0)
32608            GOTO 500
32609          ENDIF
32610          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32611          IF(GENEV.AND.HCS.GT.RCS) THEN
32612            CALL HWHRSS(16,K1,J1,I,L,1,0)
32613            GOTO 500
32614          ENDIF
32615          ENDDO
32616          ME2 = FAC2*(MEH(1,15+I)+RMASS(J1)**2*MEH(2,15+I))
32617          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32618          IF(GENEV.AND.HCS.GT.RCS) THEN
32619            CALL HWHRSS(15,J1,K1,9+I,4,0,0)
32620            GOTO 500
32621          ENDIF
32622          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32623          IF(GENEV.AND.HCS.GT.RCS) THEN
32624            CALL HWHRSS(16,K1,J1,9+I,4,0,0)
32625            GOTO 500
32626          ENDIF
32627          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32628          IF(GENEV.AND.HCS.GT.RCS) THEN
32629            CALL HWHRSS(15,J1,K1,9+I,5,1,0)
32630            GOTO 500
32631          ENDIF
32632          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32633          IF(GENEV.AND.HCS.GT.RCS) THEN
32634            CALL HWHRSS(16,K1,J1,9+I,5,1,0)
32635            GOTO 500
32636          ENDIF
32637          J1=2*J-1
32638          K1=2*K+5
32639          DO L=2,3
32640          ME2 = FAC2*(MEH(1,2*I+L+6)+RMASS(J1)**2*MEH(2,2*I+L+6))
32641          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32642          IF(GENEV.AND.HCS.GT.RCS) THEN
32643            CALL HWHRSS(15,J1,K1,2*I+L,5,0,0)
32644            GOTO 500
32645          ENDIF
32646          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32647          IF(GENEV.AND.HCS.GT.RCS) THEN
32648            CALL HWHRSS(16,K1,J1,2*I+L,5,0,0)
32649            GOTO 500
32650          ENDIF
32651          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32652          IF(GENEV.AND.HCS.GT.RCS) THEN
32653            CALL HWHRSS(15,J1,K1,2*I+L,4,1,0)
32654            GOTO 500
32655          ENDIF
32656          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32657          IF(GENEV.AND.HCS.GT.RCS) THEN
32658            CALL HWHRSS(16,K1,J1,2*I+L,4,1,0)
32659            GOTO 500
32660          ENDIF
32661          ENDDO
32662  490     CONTINUE
32663         ENDDO
32664        ENDDO
32665 C--Setup to generate the event
32666  500  IF(GENEV) THEN
32667         CALL HWETWO(.TRUE.,.TRUE.)
32668       ELSE
32669         EVWGT = HCS
32670       ENDIF
32671       END
32672 CDECK  ID>, HWHRSP.
32673 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
32674 *-- Author :    Peter Richardson
32675 C-----------------------------------------------------------------------
32676       SUBROUTINE HWHRSP
32677 C-----------------------------------------------------------------------
32678 C     Subroutine for all hadron-hadron Rparity violating processes
32679 C-----------------------------------------------------------------------
32680       INCLUDE 'herwig65.inc'
32681       IF(MOD(IPROC,10000).GE.4000.AND.MOD(IPROC,10000).LT.4060) THEN
32682 C--SINGLE SPARTICLE VIA LQD
32683         CALL HWHRLS
32684       ELSEIF(MOD(IPROC,10000).GE.4060.AND.MOD(IPROC,10000).LT.4100) THEN
32685 C--RESONANT SLEPTONS TO STANDARD MODEL VIA LQD
32686         CALL HWHRLL
32687       ELSEIF(MOD(IPROC,10000).GE.4100.AND.MOD(IPROC,10000).LT.4160) THEN
32688 C--SINGLE SPARTICLE VIA UDD
32689         CALL HWHRBS
32690 C--RESONANT SQUARKS TO STANDARD MODEL VIA UDD
32691       ELSEIF(MOD(IPROC,10000).EQ.4160) THEN
32692         CALL HWHRBB
32693       ELSE
32694 C--UNKNOWN PROCESS
32695         CALL HWWARN('HWHRSP',500)
32696       ENDIF
32697       END
32698 CDECK  ID>, HWHRSS.
32699 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
32700 *-- Author :    Peter Richardson
32701 C-----------------------------------------------------------------------
32702       SUBROUTINE HWHRSS(TYPE,ID1,ID2,ID3,ID4,R4,IPERM)
32703 C-----------------------------------------------------------------------
32704 C     IDENTIDY HARD R-PARITY VIOLATING PROCESS
32705 C-----------------------------------------------------------------------
32706       INCLUDE 'herwig65.inc'
32707       INTEGER ID3, ID4, R4, IPERM,TYPE,ID1,ID2,NEUTD1(8),SLEPID(8),
32708      &        NEUTD2(13),SQUID(6),SGN,HWUANT,SQUID2(12),SLPID2(12),
32709      &        GAGID1(6),GAGID2(8)
32710       EXTERNAL HWUANT
32711       SAVE NEUTD1,NEUTD2,SLEPID,SQUID ,SQUID2,SLPID2,GAGID1,GAGID2
32712       DATA NEUTD1 /450,451,452,453,454,455,456,457/
32713       DATA NEUTD2 /449,449,449,450,451,452,453,454,455,456,457,454,455/
32714       DATA SLEPID /432,434,436,435,431,433,435,447/
32715       DATA SQUID  /411,423,412,412,424,411/
32716       DATA SQUID2 /407,419,409,421,411,423,408,420,410,422,412,424/
32717       DATA SLPID2 /443,445,435,431,443,433,445,435,447,432,434,436/
32718       DATA GAGID1 /199,199,200,198,198,200/
32719       DATA GAGID2 /198,198,198,200,199,199,199,199/
32720       IDCMF = 15
32721       IF(IPERM.EQ.0) THEN
32722         ICO(1) = 2
32723         ICO(2) = 1
32724         ICO(3) = 3
32725         ICO(4) = 4
32726       ELSEIF(IPERM.EQ.1) THEN
32727         ICO(1) = 2
32728         ICO(2) = 1
32729         ICO(3) = 4
32730         ICO(4) = 3
32731       ELSEIF(IPERM.EQ.2) THEN
32732         ICO(1) = 3
32733         ICO(2) = 4
32734         ICO(3) = 1
32735         ICO(4) = 2
32736       ELSE
32737         CALL HWWARN('HWHRSS',100)
32738         GOTO 999
32739       ENDIF
32740       IF(TYPE.LE.8) THEN
32741         IDN(1) = ID1+R4*6
32742         IDN(2) = ID2+R4*6
32743       ELSE
32744         SGN = 1
32745         IF(MOD(TYPE,2).EQ.0) SGN = -1
32746         IDN(1) = ID1+R4*6*SGN
32747         IDN(2) = ID2-R4*6*SGN
32748       ENDIF
32749       IF(TYPE.LE.2) THEN
32750         IDN(3) = ID3+6*R4
32751         IDN(4) = ID4+6*R4
32752       ELSEIF(TYPE.GE.3.AND.TYPE.LE.4) THEN
32753         IDN(3) = ID3-R4*6
32754         IDN(4) = NEUTD2(ID4)
32755       ELSEIF(TYPE.GE.5.AND.TYPE.LE.6) THEN
32756         IDN(3) = GAGID1(ID3)
32757         IDN(4) = SQUID(ID4)-R4*6
32758         IF(R4.EQ.1) IDN(3) = HWUANT(IDN(3))
32759       ELSEIF(TYPE.GE.7.AND.TYPE.LE.8) THEN
32760         IDN(3) =202+ID3
32761         IDN(4) =  SQUID2(ID4)-R4*6
32762       ELSEIF(TYPE.GE.9.AND.TYPE.LE.10) THEN
32763         IDN(3) = ID3+6*R4
32764         IDN(4) = ID4-6*R4
32765         IF(IPERM.EQ.2.AND.TYPE.EQ.10) THEN
32766           SGN=IDN(3)
32767           IDN(3) = IDN(4)
32768           IDN(4) = SGN
32769         ENDIF
32770       ELSEIF(TYPE.GE.11.AND.TYPE.LE.12) THEN
32771         IDN(3) = 120+ID3-R4*6
32772         IDN(4) = NEUTD1(ID4)
32773         IF(R4.EQ.1) IDN(4) = HWUANT(IDN(4))
32774       ELSEIF(TYPE.GE.13.AND.TYPE.LE.14) THEN
32775         IDN(3) = SLEPID(ID3)-R4*6
32776         IDN(4) = GAGID2(ID4)
32777         IF(R4.NE.0) IDN(4) = HWUANT(IDN(4))
32778       ELSEIF(TYPE.GE.15.AND.TYPE.LE.16) THEN
32779         IDN(3) = SLPID2(ID3)-R4*6
32780         IDN(4) = 202+ID4
32781       ENDIF
32782       IF(MOD(TYPE,2).EQ.0.AND.TYPE.NE.8) COSTH=-COSTH
32783  999  RETURN
32784       END
32785 CDECK  ID>, HWHSCT.
32786 *CMZ :-        -18/03/04  18.42.43  by  Mike Seymour
32787 *-- Author :    Mike Seymour
32788 C-----------------------------------------------------------------------
32789       SUBROUTINE HWHSCT(REPORT,FIRSTC,JMUEO,PTJIM)
32790 C-----------------------------------------------------------------------
32791 C     RELABEL THE EVENT RECORD FOR EXTRA HARD SCATTERING,
32792 C     DO THE SCATTERING, PARTON SHOWER IT, AND CLEAN UP THE EVENT RECORD
32793 C     REPORT RETURNS THE OUTCOME:
32794 C     0 = SUCCESSFUL
32795 C     1 = FAILED DUE TO ERROR IN HARD SCATTERING GENERATION
32796 C     2 = FAILED DUE TO ENERGY CONSERVATION IN HARD SCATTERING
32797 C     3 = FAILED DUE TO ERROR IN PARTON EVOLUTION
32798 C     4 = FAILED DUE TO ENERGY CONSERVATION IN PARTON EVOLUTION
32799 C     5 = COMPLETELY FAILED (IERROR IS ALSO NON-ZERO TO CANCEL EVENT)
32800 C     FIRSTC IS AN INPUT FLAG THAT SAYS THAT THIS IS THE FIRST CALL
32801 C     OF THE EVENT
32802 C     JMUEO IS THE UNDERLYING EVENT OPTION: 1=>VETO EVENTS WITH M
32803 C     SCATTERS ABOVE PTMIN WITH PROBABILITY 1/(M+1)
32804 C     PTJIM IS THE MINIMUM TRANSVERSE MOMENTUM FOR ADDITIONAL SCATTERS
32805 C-----------------------------------------------------------------------
32806       INCLUDE 'herwig65.inc'
32807       DOUBLE PRECISION HWRGEN,HWRGET,HWRSET,WGT,PBOOST(5),RBOOST(3,3),
32808      $     WJMAX,PT,PTJIM,DUMMY,HWUPCM
32809       INTEGER IHEP,IBM,ITG,IBMN,ITGN,IBMT,ITGT,I,REPORT,NHARD,
32810      $     MYRN(2),TMPRN(2),JMUEO
32811       LOGICAL COL,FIRSTC,TMPFLG
32812       INTEGER IPRTMP
32813       EXTERNAL HWRGEN,HWRGET,HWRSET,HWUPCM
32814       SAVE WJMAX,MYRN,NHARD
32815       DATA WJMAX,MYRN,NHARD/0,004122,7679781,0/
32816       COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
32817       REPORT=5
32818       IF (IERROR.NE.0) RETURN
32819 C---RESET THE COUNTER FOR HARD SCATTERS ON THE FIRST CALL
32820       IF (FIRSTC) NHARD=0
32821 C---FIND BEAM AND TARGET REMNANTS
32822       CALL HWHREM(IBM,ITG)
32823       IF (IERROR.NE.0) RETURN
32824 C---RECALCULATE THEIR MASS CORRECTLY
32825       CALL HWUMAS(PHEP(1,IBM))
32826       CALL HWUMAS(PHEP(1,ITG))
32827 C---SET UP NEW ENTRIES IN THE EVENT RECORD
32828       NHEP=NHEP+1
32829       CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,NHEP))
32830       ISTHEP(NHEP)=3
32831       IBMN=NHEP
32832       IBMT=JDAHEP(1,1)
32833       IF (IBMT.EQ.0) THEN
32834         JMOHEP(1,NHEP)=1
32835         IDHW(NHEP)=72
32836       ELSE
32837         JMOHEP(1,NHEP)=IBMT
32838         IDHW(NHEP)=71
32839       ENDIF
32840       JMOHEP(2,NHEP)=0
32841       JDAHEP(1,NHEP)=0
32842       JDAHEP(2,NHEP)=0
32843       IDHEP(NHEP)=IDPDG(IDHW(NHEP))
32844       NHEP=NHEP+1
32845       CALL HWVEQU(5,PHEP(1,ITG),PHEP(1,NHEP))
32846       ISTHEP(NHEP)=3
32847       ITGN=NHEP
32848       ITGT=JDAHEP(1,2)
32849       IF (ITGT.EQ.0) THEN
32850         JMOHEP(1,NHEP)=2
32851         IDHW(NHEP)=72
32852       ELSE
32853         JMOHEP(1,NHEP)=ITGT
32854         IDHW(NHEP)=71
32855       ENDIF
32856       JMOHEP(2,NHEP)=0
32857       JDAHEP(1,NHEP)=0
32858       JDAHEP(2,NHEP)=0
32859       IDHEP(NHEP)=IDPDG(IDHW(NHEP))
32860 C---BOOST TO THEIR CENTRE-OF-MASS FRAME
32861       CALL HWVSUM(4,PHEP(1,IBMN),PHEP(1,ITGN),PBOOST)
32862       CALL HWUMAS(PBOOST)
32863       DO 100 IHEP=IBMN,NHEP
32864         CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
32865  100  CONTINUE
32866       CALL HWUROT(PHEP(1,IBMN),ONE,ZERO,RBOOST)
32867       DO 110 IHEP=IBMN,NHEP
32868         CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
32869  110  CONTINUE
32870 C---PERFORM A SEARCH FOR THE MAXIMUM WEIGHT, IF IT IS NOT YET FOUND
32871       IF (WJMAX.EQ.0) THEN
32872 C---USING LOCAL RANDOM NUMBER SEEDS
32873         DUMMY=HWRGET(TMPRN)
32874         DUMMY=HWRSET(MYRN)
32875         GENEV=.FALSE.
32876         DO I=1,IBSH
32877           CALL HWHSCU(WGT,PTJIM)
32878           WJMAX=MAX(WJMAX,WGT)
32879         ENDDO
32880         WRITE (6,'(A,G12.4)') ' Jimmy search for maximum weight=',WJMAX
32881         DUMMY=HWRGET(MYRN)
32882         DUMMY=HWRSET(TMPRN)
32883 C---BECAUSE OF THE ENERGY DEPENDENCE, LEAVE LOTS OF SAFETY MARGIN
32884         WJMAX=WJMAX*2
32885       ENDIF
32886 C---GENERATE A NEW HARD SCATTERING
32887  5    GENEV=.FALSE.
32888  10   CALL HWHSCU(WGT,PTJIM)
32889       IF (WGT.GT.WJMAX) THEN
32890         WRITE (6,'(A,G12.4/A,G12.4,A,G12.4)')
32891      $       ' Jimmy maximum weight exceeded!  SQRT(S)=',PHEP(5,3),
32892      $       ' Increasing from ',WJMAX,' to ',WGT*2
32893         WJMAX=WGT*2
32894       ENDIF
32895       IF (WGT.LE.WJMAX*HWRGEN(0)) GOTO 10
32896       GENEV=.TRUE.
32897       CALL HWHSCU(WGT,PTJIM)
32898 C---IF ADDING LOW PT SCATTERS TO HIGH PT EVENTS ADD AN EXTRA VETO ON
32899 C   SCATTERS THAT HAPPEN TO BE HIGH PT
32900       TMPFLG=.FALSE.
32901       IF (JMUEO.EQ.1) THEN
32902 C---FIRST RECONSTRUCT THE PT THAT WAS GENERATED IN THE SCATTERING
32903         PT=SQRT(PHEP(1,NHEP)**2+PHEP(2,NHEP)**2)*
32904      $       SQRT(XX(1)*XX(2))*PHEP(5,3)
32905      $       /(2*HWUPCM(PHEP(5,NHEP-2),PHEP(5,NHEP-1),PHEP(5,NHEP)))
32906 C---IF IT IS ABOVE THE TRIGGER THRESHOLD APPLY THE VETO
32907         IF (PT.GT.PTMIN) THEN
32908           IF ((NHARD+2)*HWRGEN(1).LT.1) THEN
32909             NHEP=IBMN-1
32910             GOTO 5
32911           ENDIF
32912           TMPFLG=.TRUE.
32913         ENDIF
32914       ENDIF
32915 C---IF MOMENTUM CANNOT BE CONSERVED, STOP GENERATING HARD SCATTERS
32916       IF (  PHEP(4,IBMN+2) .GT. PHEP(4,IBMN).OR.
32917      $      PHEP(4,ITGN+2) .GT. PHEP(4,ITGN).OR.
32918      $      PHEP(3,IBMN+2) .GT. PHEP(3,IBMN).OR.
32919      $     -PHEP(3,ITGN+2) .GT.-PHEP(3,ITGN).OR.IERROR.NE.0) THEN
32920         IF (IERROR.GT.0) THEN
32921           WRITE (6,'(A/A)')
32922      $       ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
32923      $       ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
32924           REPORT=1
32925         ELSE
32926           REPORT=2
32927         ENDIF
32928         NHEP=IBMN-1
32929         IERROR=0
32930         RETURN
32931       ENDIF
32932 C---RELABEL OUTGOING REMNANTS AS INCOMING HADRONS
32933       JDAHEP(1,1)=IBMN
32934       JDAHEP(1,2)=ITGN
32935 C---EVOLVE THEM
32936       ISLENT=-1
32937 C---SAVE THE CURRENT PROCESS TYPE, AND SWITCH TO
32938 C   QCD SCATTERING TO AVOID PROBLEMS WITH THE
32939 C   PARTON SHOWER.
32940       IPRTMP=IPRO
32941       IPRO=15
32942       CALL HWBGEN
32943       IPRO=IPRTMP
32944       ISLENT=1
32945 C---PUT THE LABELS BACK
32946       JDAHEP(1,1)=IBMT
32947       JDAHEP(1,2)=ITGT
32948 C---IF THERE WERE ANY PROBLEMS, STOP GENERATING HARD SCATTERS
32949       IF (IERROR.NE.0) THEN
32950         IF (IERROR.GT.0) THEN
32951           WRITE (6,'(A/A)')
32952      $       ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
32953      $       ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
32954           REPORT=3
32955         ELSE
32956           REPORT=4
32957         ENDIF
32958         NHEP=IBMN-1
32959         IERROR=0
32960         RETURN
32961       ENDIF
32962 C---UNDO THE LORENTZ BOOST
32963       DO 200 IHEP=IBMN,NHEP
32964         CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
32965         CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
32966  200  CONTINUE
32967 C---FIND THE NEW BEAM AND TARGET REMNANTS
32968       ISTHEP(IBM)=3
32969       ISTHEP(ITG)=3
32970       CALL HWHREM(IBMN,ITGN)
32971       IF (IERROR.NE.0) RETURN
32972 C---CONNECT UP THE COLOUR/FLAVOUR LINES OF THE TWO SCATTERS
32973       IDHW(IBMN)=IDHW(IBM)
32974       IDHEP(IBMN)=IDHEP(IBM)
32975       IF (COL(IDHW(IBM))) THEN
32976         JMOHEP(2,JDAHEP(2,IBMN))=JMOHEP(2,IBM)
32977         JDAHEP(2,JMOHEP(2,IBM))=JDAHEP(2,IBMN)
32978         JDAHEP(2,IBMN)=JDAHEP(2,IBM)
32979         JMOHEP(2,JDAHEP(2,IBM))=IBMN
32980       ELSE
32981         JDAHEP(2,JMOHEP(2,IBMN))=JDAHEP(2,IBM)
32982         JMOHEP(2,JDAHEP(2,IBM))=JMOHEP(2,IBMN)
32983         JMOHEP(2,IBMN)=JMOHEP(2,IBM)
32984         JDAHEP(2,JMOHEP(2,IBM))=IBMN
32985       ENDIF
32986       JMOHEP(2,IBM)=0
32987       JDAHEP(1,IBM)=IBMN
32988       JDAHEP(2,IBM)=0
32989       IDHW(ITGN)=IDHW(ITG)
32990       IDHEP(ITGN)=IDHEP(ITG)
32991       IF (COL(IDHW(ITG))) THEN
32992         JMOHEP(2,JDAHEP(2,ITGN))=JMOHEP(2,ITG)
32993         JDAHEP(2,JMOHEP(2,ITG))=JDAHEP(2,ITGN)
32994         JDAHEP(2,ITGN)=JDAHEP(2,ITG)
32995         JMOHEP(2,JDAHEP(2,ITG))=ITGN
32996       ELSE
32997         JDAHEP(2,JMOHEP(2,ITGN))=JDAHEP(2,ITG)
32998         JMOHEP(2,JDAHEP(2,ITG))=JMOHEP(2,ITGN)
32999         JMOHEP(2,ITGN)=JMOHEP(2,ITG)
33000         JDAHEP(2,JMOHEP(2,ITG))=ITGN
33001       ENDIF
33002       JMOHEP(2,ITG)=0
33003       JDAHEP(1,ITG)=ITGN
33004       JDAHEP(2,ITG)=0
33005 C---LOOK FOR COLOUR SINGLET GLUONS (A RARE BUT ANNOYING SPECIAL CASE)
33006       DO 20 IHEP=1,NHEP
33007         IF (IDHW(IHEP).EQ.13.AND.JMOHEP(2,IHEP).EQ.IHEP) THEN
33008           CALL HWWARN('HWHSCT',120)
33009           GOTO 999
33010         ENDIF
33011  20   CONTINUE
33012       REPORT=0
33013       IF (TMPFLG) NHARD=NHARD+1
33014  999  RETURN
33015       END
33016 CDECK  ID>, HWHSCU
33017 *CMZ :-        -17/03/04  14.37.43  by  Mike Seymour
33018 *-- Author :    Mike Seymour
33019 C-----------------------------------------------------------------------
33020       SUBROUTINE HWHSCU(WGT,PTJIM)
33021 C-----------------------------------------------------------------------
33022 C     SWAP THE HARD PROCESS GENERATION PARAMETERS,
33023 C     CALL HWHQCD, AND SWAP BACK
33024 C     WGT IS THE OUTPUT EVENT WEIGHT
33025 C-----------------------------------------------------------------------
33026       INCLUDE 'herwig65.inc'
33027       DOUBLE PRECISION WGT,PTJIM,XMIN,XMAX,XPOW,
33028      $     TMPXMN,TMPXMX,TMPXPW,TMPWGT
33029       LOGICAL FIRST
33030       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
33031 C---STORE THE CURRENT VALUES
33032       TMPWGT=EVWGT
33033       TMPXMN=XMIN
33034       TMPXMX=XMAX
33035       TMPXPW=XPOW
33036 C---REPLACE BY NEW ONES
33037       XMIN=2*PTJIM
33038       XMAX=2*SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
33039       XPOW=-4D0
33040 C---AND ENSURE THAT HWRPOW GETS REINITIALIZED
33041       FIRST=.TRUE.
33042 C---GENERATE A PHASE SPACE POINT
33043       CALL HWHQCD
33044       IF (IERROR.NE.0.OR.EVWGT.LT.0) THEN
33045         IERROR=0
33046         EVWGT=0
33047       ENDIF
33048       WGT=EVWGT
33049 C---PUT THE OLD VALUES BACK
33050       EVWGT=TMPWGT
33051       XMIN=TMPXMN
33052       XMAX=TMPXMX
33053       XPOW=TMPXPW
33054 C---AND AGAIN ENSURE THAT HWRPOW GETS REINITIALIZED
33055       FIRST=.TRUE.
33056 C---INCLUDE GAMWT HERE
33057       WGT=WGT*GAMWT
33058       END
33059 CDECK  ID>, HWHSNG.
33060 *CMZ :-        -20/09/95  14.59.15  by  Mike Seymour
33061 *-- Author :    Mike Seymour
33062 C-----------------------------------------------------------------------
33063       SUBROUTINE HWHSNG
33064 C     PARTON-PARTON SCATTERING VIA COLOUR SINGLET
33065 C     MEAN EVWGT = SIGMA IN NB
33066 C     TREATS ALL PARTONS ON EQUAL FOOTING WITH HWHSNM(ID1,ID2,S,T)
33067 C     PROVIDING THE MATRIX ELEMENT SQUARED FOR PARTON TYPES ID1 AND ID2
33068 C-----------------------------------------------------------------------
33069       INCLUDE 'herwig65.inc'
33070       INTEGER ID1,ID2
33071       DOUBLE PRECISION HWRGEN,HWRUNI,HWHSNM,EPS,RCS,ET,EJ,KK,KK2,
33072      & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,S,T,U,HCS
33073       SAVE HCS,FACT,S,T
33074       PARAMETER (EPS=1.D-9)
33075       IF (GENEV) THEN
33076         RCS=HCS*HWRGEN(0)
33077       ELSE
33078         EVWGT=0.
33079         CALL HWRPOW(ET,EJ)
33080         KK=ET/PHEP(5,3)
33081         KK2=KK**2
33082         IF (KK.GE.ONE) RETURN
33083         YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
33084         YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
33085         IF (YJ1INF.GE.YJ1SUP) RETURN
33086         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
33087         YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
33088         YJ2SUP=MIN( YJMAX ,  LOG(2./KK-Z1) )
33089         IF (YJ2INF.GE.YJ2SUP) RETURN
33090         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
33091         XX(1)=0.5*(Z1+Z2)*KK
33092         IF (XX(1).GE.ONE) RETURN
33093         XX(2)=XX(1)/(Z1*Z2)
33094         IF (XX(2).GE.ONE) RETURN
33095         COSTH=(Z1-Z2)/(Z1+Z2)
33096         S=XX(1)*XX(2)*PHEP(5,3)**2
33097         T=-0.5*S*(1.-COSTH)
33098         U=-S-T
33099 C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
33100         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
33101         FACT=GEV2NB*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
33102      $      /(16*PIFAC*S**2)
33103         CALL HWSGEN(.FALSE.)
33104       ENDIF
33105 C
33106       HCS=0.
33107       DO 20 ID1=1,13
33108         IF (DISF(ID1,1).LT.EPS) GOTO 20
33109         DO 10 ID2=1,13
33110           IF (DISF(ID2,1).LT.EPS) GOTO 10
33111           HCS=HCS+FACT*DISF(ID1,1)*DISF(ID2,2)*HWHSNM(ID1,ID2,S,T)
33112           IF (GENEV.AND.HCS.GT.RCS) THEN
33113             CALL HWHQCP(ID1,ID2,3412,90)
33114             GOTO 30
33115           ENDIF
33116  10     CONTINUE
33117  20   CONTINUE
33118       EVWGT=HCS
33119       RETURN
33120 C---GENERATE EVENT
33121  30   IDN(1)=ID1
33122       IDN(2)=ID2
33123       IDCMF=15
33124       CALL HWETWO(.TRUE.,.TRUE.)
33125       END
33126 CDECK  ID>, HWHSNM.
33127 *CMZ :-        -20/09/95  15.28.53  by  Mike Seymour
33128 *-- Author :    Mike Seymour
33129 C-----------------------------------------------------------------------
33130       FUNCTION HWHSNM(ID1,ID2,S,T)
33131 C     MATRIX ELEMENT SQUARED FOR COLOUR-SINGLET PARTON-PARTON SCATTERING
33132 C     INCLUDES SPIN AND COLOUR AVERAGES AND SUMS.
33133 C     FOR PHOTON EXCHANGE, INTERFERENCE WITH U-CHANNEL CONTRIBUTION IS
33134 C     INCLUDED FOR IDENTICAL QUARKS AND LIKEWISE S-CHANNEL CONTRIBUTION
33135 C     FOR IDENTICAL QUARK-ANTIQUARK PAIRS.
33136 C-----------------------------------------------------------------------
33137       INCLUDE 'herwig65.inc'
33138       DOUBLE PRECISION HWHSNM,HWUAEM,HWUALF,S,T,ASQ,AINU,AINS,Y,SOLD,
33139      $ TOLD,QQ(13,13),ZETA3
33140       INTEGER ID1,ID2
33141       LOGICAL PHOTON
33142 C---ZETA3=RIEMANN ZETA FUNCTION(3)
33143       PARAMETER (ZETA3=1.202056903159594D0)
33144       SAVE ASQ,AINU,AINS,SOLD,TOLD,QQ
33145       DATA ASQ,AINU,AINS,SOLD,TOLD,QQ/5*0,169*-1/
33146 C---PHOTON=.TRUE. FOR PHOTON EXCHANGE, .FALSE. FOR MUELLER-TANG
33147       PHOTON=MOD(IPROC,100).GE.50
33148 C---QQ CACHES THE KINEMATIC-INDEPENDENT FACTORS, TO MAKE IT RUN FASTER
33149 C  (BEARING IN MIND THAT THIS ROUTINE IS CALLED 169 TIMES PER EVENT)
33150       IF (QQ(ID1,ID2).LT.ZERO) THEN
33151         IF (PHOTON) THEN
33152           IF (ID1.EQ.13.OR.ID2.EQ.13) THEN
33153             QQ(ID1,ID2)=0
33154           ELSE
33155             QQ(ID1,ID2)=(QFCH(MOD(ID1-1,6)+1)*QFCH(MOD(ID2-1,6)+1))**2
33156      $           *(4*PIFAC)**2
33157           ENDIF
33158         ELSE
33159           IF (ID1.EQ.13.AND.ID2.EQ.13) THEN
33160             QQ(ID1,ID2)=CAFAC**4
33161           ELSEIF (ID1.EQ.13.OR.ID2.EQ.13) THEN
33162             QQ(ID1,ID2)=(CAFAC*CFFAC)**2
33163           ELSE
33164             QQ(ID1,ID2)=CFFAC**4
33165           ENDIF
33166           QQ(ID1,ID2)=QQ(ID1,ID2)*
33167      $         PIFAC**3/(4*(3.5*ASFIXD*CAFAC*ZETA3)**3)
33168      $         *(16*PIFAC)
33169         ENDIF
33170       ENDIF
33171 C---THE KINEMATIC-DEPENDENT PART IS ALSO CACHED
33172       IF (S.NE.SOLD.OR.T.NE.TOLD) THEN
33173         IF (PHOTON) THEN
33174           AINS=HWUAEM(T)**2
33175           ASQ=2*(S**2+(S+T)**2)/T**2*AINS
33176           AINU=-4*S/T*AINS/NCOLO
33177           AINS=4*AINS/NCOLO-AINU
33178         ELSE
33179           Y=LOG(S/(-T))+ONE
33180           ASQ=HWUALF(1,EMSCA)**4*(S/T)**2*EXP(2*OMEGA0*Y)/Y**3
33181           AINU=0
33182           AINS=0
33183         ENDIF
33184       ENDIF
33185 C---THE FINAL ANSWER IS JUST THEIR PRODUCT
33186       IF (ID1.EQ.ID2) THEN
33187         HWHSNM=QQ(ID1,ID2)*(ASQ+AINU)
33188       ELSEIF (ABS(ID1-ID2).EQ.6) THEN
33189         HWHSNM=QQ(ID1,ID2)*(ASQ+AINS)
33190       ELSE
33191         HWHSNM=QQ(ID1,ID2)*ASQ
33192       ENDIF
33193       END
33194 CDECK  ID>, HWHSPN.
33195 *CMZ :-        -01/10/01  19.41.18  by  Peter Richardson
33196 *-- Author :    Peter Richardson
33197 C-----------------------------------------------------------------------
33198       SUBROUTINE HWHSPN
33199 C-----------------------------------------------------------------------
33200 C     Calculates the spin correlations for the hard process
33201 C-----------------------------------------------------------------------
33202       INCLUDE 'herwig65.inc'
33203       INTEGER NDIAHD
33204       PARAMETER(NDIAHD=10)
33205       DOUBLE COMPLEX ZI,S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F3(2,2,8),
33206      &     F4(2,2,8),F3M(2,2,8),F4M(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
33207      &     FUP(2,2,8,8),FUM(2,2,8,8),FST(2,2,8)
33208       DOUBLE PRECISION P(5,4),A(2,NDIAHD),B(2,NDIAHD),XMASS,PLAB,
33209      &     PRW,PCM,MS(NDIAHD),MWD(NDIAHD),MR(NDIAHD),HWULDO,EE,
33210      &     PREF(5),EPS,N(3),HWVDOT,PP,PRE,SH,TH,UH,PM(5,4),DIJ(2,2),
33211      &     MA(4),MA2(4),PTMP(5),WGT,WGTB(NCFMAX),WGTC,HWRGEN
33212       INTEGER ICM,IHEP,IST,JHEP,KHEP,ID,LHEP,MHEP,IK,IL,IM,IJ,L1,L2,I,J,
33213      &     IDP(4+NDIAHD),DRTYPE(NDIAHD),NDIA,P1,P2,P3,P4,IFLOW(NDIAHD),
33214      &     ID1,ID2,III,JJJ,KKK,O(2),LLL,MMM
33215       DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
33216      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
33217      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
33218      &     HZZ(2),ZAB(12,2,2),HHB(2,3),HWUAEM
33219       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
33220      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
33221       LOGICAL SPIN,FIRST
33222       EXTERNAL HWUAEM
33223       PARAMETER(ZI=(0.0D0,1.0D0))
33224       COMMON/HWHEWS/S(8,8,2),D(8,8)
33225       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
33226      &     MA2,SH,TH,UH,IDP,DRTYPE
33227       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
33228       PARAMETER(EPS=1D-20)
33229       EXTERNAL HWULDO,HWVDOT,HWRGEN
33230       SAVE PREF,DIJ,O,FIRST
33231       DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
33232       DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
33233       DATA O/2,1/
33234       DATA FIRST/.TRUE./
33235       IF(IERROR.NE.0) RETURN
33236       IF(FIRST) THEN
33237         CALL HWISPC
33238         FIRST = .FALSE.
33239       ENDIF
33240 C--search the event record for the hard process
33241       DO 1 IHEP=1,NHEP
33242       IST = ISTHEP(IHEP)
33243       IF(IST.EQ.110.OR.IST.EQ.120) THEN
33244         ICM = IHEP
33245         GOTO 2
33246       ENDIF
33247  1    CONTINUE
33248 C--now decide whether or not to perform spin correlation
33249  2    KHEP = JDAHEP(1,ICM)
33250       IK   = IDHW(KHEP)
33251       JHEP = JDAHEP(2,ICM)
33252       IJ   = IDHW(JHEP)
33253       IF(JHEP-KHEP+1.NE.2) CALL HWWARN('HWHSPN',500)
33254       SPIN = .FALSE.
33255       DO 3 IHEP=KHEP,JHEP
33256         ID = IDHW(IHEP)
33257         IF(RSPIN(ID).EQ.0.5D0) SPIN=.TRUE.
33258  3    CONTINUE
33259       IF(.NOT.SPIN) RETURN
33260       IF((RSPIN(IDHW(KHEP)).EQ.ONE.AND.RSPIN(IDHW(JHEP)).EQ.ZERO).OR.
33261      &  (RSPIN(IDHW(KHEP)).EQ.ZERO.AND.RSPIN(IDHW(JHEP)).EQ.ONE)) RETURN
33262       LHEP = JMOHEP(1,ICM)
33263       MHEP = JMOHEP(2,ICM)
33264 C--now identify the hard process
33265 C--SM processes first
33266 C--fermion-antifermion production in lepton-lepton collisions
33267 C--or via Z/gamma in hadron-hadron collisions
33268       IF(IPRO.EQ.1.OR.IPRO.EQ.13) THEN
33269 C--only need spin correlations for top and tau production
33270         IF((IK.EQ.  6.AND.IJ.EQ. 12).OR.(IK.EQ. 12.AND.IJ.EQ.6  ).OR.
33271      &     (IK.EQ.125.AND.IJ.EQ.131).OR.(IK.EQ.131.AND.IJ.EQ.125)) THEN
33272 C--check fermion first and change order if not
33273           IF(IDHEP(LHEP).LT.0) THEN
33274             ID   = LHEP
33275             LHEP = MHEP
33276             MHEP = ID
33277           ENDIF
33278 C--Id's of the incoming and outgoing fermions
33279           IL  = IDHW(LHEP)
33280           ID1 = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
33281           ID2 = IK-6*INT((IK-1)/6)+10*INT((IK-1)/120)
33282 C--couplings for the diagrams
33283 C--first the photon exchange
33284           A(1,1) = -QFCH(ID1)
33285           A(2,1) = -QFCH(ID1)
33286           B(1,1) = -QFCH(ID2)
33287           B(2,1) = -QFCH(ID2)
33288           IDP(5) = 59
33289           DRTYPE(1) = 4
33290 C--then the Z exchange
33291           A(1,2) = -RFCH(ID1)
33292           A(2,2) = -LFCH(ID1)
33293           B(1,2) = -RFCH(ID2)
33294           B(2,2) = -LFCH(ID2)
33295           IDP(6) = 200
33296           DRTYPE(2) = 4
33297 C--setup the colour flow
33298           NDIA = 2
33299           NCFL(1) = 1
33300           SPNCFC(1,1,1) = ONE
33301           IFLOW(1) = 1
33302           IFLOW(2) = 1
33303         ELSE
33304           RETURN
33305         ENDIF
33306 C--fermion-antifermion via s-channel W in hadron-hadron
33307       ELSEIF(IPRO.EQ.14) THEN
33308         IF(IK.EQ.  6.OR.IK.EQ. 12.OR.IJ.EQ.  6.OR.IJ.EQ. 12.OR.
33309      &     IK.EQ.125.OR.IJ.EQ.131.OR.IK.EQ.131.OR.IJ.EQ.125) THEN
33310 C--check fermion first and reorder if not
33311           IF(IDHEP(LHEP).LT.0) THEN
33312             ID   = LHEP
33313             LHEP = MHEP
33314             MHEP = ID
33315           ENDIF
33316 C--couplings for the diagram
33317           A(1,1) = ZERO
33318           A(2,1) =-ORT/SW
33319           B(1,1) = ZERO
33320           B(2,1) =-ORT/SW
33321           IDP(5) = 198
33322           DRTYPE(1) = 4
33323           NDIA = 1
33324           NCFL(1) = 1
33325           SPNCFC(1,1,1) = ONE
33326           IFLOW(1) = 1
33327         ELSE
33328           RETURN
33329         ENDIF
33330 C--top quark production via QCD
33331       ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.17) THEN
33332         IF((IK.EQ.6.AND.IJ.EQ.12).OR.(IK.EQ.12.AND.IJ.EQ.6)) THEN
33333 C--check if the outgoing fermion is first and change order if not
33334           IF(IDHEP(KHEP).LT.0) THEN
33335             ID   = KHEP
33336             KHEP = JHEP
33337             JHEP = ID
33338           ENDIF
33339 C--quark-quark to t tbar
33340           IF(IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
33341 C--first check the incoming fermion is first and change order if not
33342             IF(IDHEP(LHEP).LT.0) THEN
33343               ID   = LHEP
33344               LHEP = MHEP
33345               MHEP = ID
33346             ENDIF
33347             IL   = IDHW(LHEP)
33348 C--couplings for the diagram
33349             A(1,1) =-ONE
33350             A(2,1) =-ONE
33351             B(1,1) =-ONE
33352             B(2,1) =-ONE
33353             IDP(5) = 13
33354             DRTYPE(1) = 4
33355             NDIA = 1
33356 C--setup the colour flow
33357             NCFL(1) = 1
33358             SPNCFC(1,1,1) = TWO/9.0D0
33359             IFLOW(1) = 1
33360 C--gluon-gluon to t tbar
33361           ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13) THEN
33362 C--setup the diagrams
33363             IDP(5) = 12
33364             IDP(6) = 12
33365             IDP(7) = 13
33366             IDP(8) = 13
33367             DRTYPE(1) = 5
33368             DRTYPE(2) = 6
33369             DRTYPE(3) = 7
33370             DRTYPE(4) = 7
33371             NDIA = 4
33372 C--setup the colour flow
33373             NCFL(1) = 2
33374             IFLOW(1) = 1
33375             IFLOW(2) = 2
33376             IFLOW(3) = 1
33377             IFLOW(4) = 2
33378             SPNCFC(1,1,1) = 0.25D0/THREE
33379             SPNCFC(2,2,1) = SPNCFC(1,1,1)
33380             SPNCFC(1,2,1) = ONE/THREE/32.0D0
33381             SPNCFC(2,1,1) = ONE/THREE/32.0D0
33382 C--incorrect initial state
33383           ELSE
33384             CALL HWWARN('HWHSPN',501)
33385           ENDIF
33386 C--don't need spin correlations haven't produced top
33387         ELSE
33388           RETURN
33389         ENDIF
33390 C--single top quark production in hadron collisions
33391       ELSEIF(IPRO.EQ.20) THEN
33392 C--change order if b quark not first and identify incoming particles
33393         IF(ABS(IDHEP(LHEP)).NE.5) THEN
33394           ID   = LHEP
33395           LHEP = MHEP
33396           MHEP = ID
33397         ENDIF
33398         IL  = IDHEP(LHEP)
33399         IM  = IDHEP(MHEP)
33400 C--change order if t quark not first
33401         IF(ABS(IDHEP(KHEP)).NE.6) THEN
33402           ID   = KHEP
33403           KHEP = JHEP
33404           JHEP = ID
33405         ENDIF
33406 C--identify diagram type
33407 C--fermion fermion
33408         IF(IL.GT.0.AND.IM.GT.0) THEN
33409           DRTYPE(1) = 17
33410 C--fermion antifermion
33411         ELSEIF(IL.GT.0.AND.IM.LT.0) THEN
33412           DRTYPE(1) = 18
33413 C--antifermion fermion
33414         ELSEIF(IL.LT.0.AND.IM.GT.0) THEN
33415           DRTYPE(1) = 19
33416 C--antifermion antifermion
33417         ELSEIF(IL.LT.0.AND.IM.LT.0) THEN
33418           DRTYPE(1) = 20
33419 C--incorrect initial state
33420         ELSE
33421           CALL HWWARN('HWHSPN',502)
33422         ENDIF
33423 C--couplings
33424         A(1,1) = ZERO
33425         A(2,1) = -ORT/SW
33426         B(1,1) = ZERO
33427         B(2,1) = -ORT/SW
33428 C--virtual particle etc
33429         IDP(5) = 198
33430         NDIA = 1
33431         NCFL(1) = 1
33432         SPNCFC(1,1,1) = ONE
33433         IFLOW(1) = 1
33434 C--SUSY particle production
33435       ELSEIF(IPRO.EQ.7.OR.IPRO.EQ.30) THEN
33436         IF(MOD(IPROC,10000).GT.3030) RETURN
33437 C--fermion-antifermion to neutralino neutralino
33438         IF(IK.GE.450.AND.IK.LE.453.AND.IJ.GE.450.AND.IJ.LE.453) THEN
33439 C--first check the fermion is first and change order if not
33440           IF(IDHEP(LHEP).LT.0) THEN
33441             ID   = LHEP
33442             LHEP = MHEP
33443             MHEP = ID
33444           ENDIF
33445           IL   = IDHW(LHEP)
33446           IM   = IDHW(MHEP)
33447 C--couplings of the various diagrams
33448           L1     = IK-449
33449           L2     = IJ-449
33450           ID     = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
33451 C--couplings for the Z exchange diagram
33452           A(1,1) = -RFCH(ID)
33453           A(2,1) = -LFCH(ID)
33454           B(2,1) = HALF*(-ZMIXSS(L1,3)*ZMIXSS(L2,3)
33455      &                   +ZMIXSS(L1,4)*ZMIXSS(L2,4))/SW/CW
33456           B(1,1) = -B(2,1)
33457           B(2,1) = B(2,1)*ZSGNSS(L1)*ZSGNSS(L2)
33458           DRTYPE(1) = 1
33459           IDP(5) = 200
33460 C--couplings for the t-channel diagrams
33461           A(1,2) = ZERO
33462           A(2,2) =-RT*SLFCH(ID,L1)
33463           B(1,2) =-RT*SLFCH(ID,L2)
33464           B(2,2) = ZERO
33465           IDP(6) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
33466           A(1,3) =-RT*SRFCH(ID,L1)*ZSGNSS(L1)
33467           A(2,3) = ZERO
33468           B(1,3) = ZERO
33469           B(2,3) =-RT*SRFCH(ID,L2)*ZSGNSS(L2)
33470           IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+412
33471           DRTYPE(2) = 2
33472           DRTYPE(3) = 2
33473 C--couplings for the u-channel diagrams
33474           A(1,4) = ZERO
33475           A(2,4) =-RT*SLFCH(ID,L2)*ZSGNSS(L2)
33476           B(1,4) =-RT*SLFCH(ID,L1)*ZSGNSS(L1)
33477           B(2,4) = ZERO
33478           IDP(8) = IDP(6)
33479           A(1,5) =-RT*SRFCH(ID,L2)
33480           A(2,5) = ZERO
33481           B(1,5) = ZERO
33482           B(2,5) =-RT*SRFCH(ID,L1)
33483           IDP(9) = IDP(7)
33484           DRTYPE(4) = 3
33485           DRTYPE(5) = 3
33486           NDIA=5
33487 C--setup the colour flow
33488           NCFL(1) = 1
33489           SPNCFC(1,1,1) = ONE
33490           IFLOW(1) = 1
33491           IFLOW(2) = 1
33492           IFLOW(3) = 1
33493           IFLOW(4) = 1
33494           IFLOW(5) = 1
33495 C--chargino pair production
33496         ELSEIF(IK.GE.454.AND.IK.LE.457.AND.IJ.GE.454.AND.IJ.LE.457) THEN
33497 C--first check the fermion is first and change order if not
33498           IF(IDHEP(LHEP).LT.0) THEN
33499             ID   = LHEP
33500             LHEP = MHEP
33501             MHEP = ID
33502           ENDIF
33503           IL   = IDHW(LHEP)
33504           IM   = IDHW(MHEP)
33505 C--couplings of the various diagrams
33506           L1     = IK-453-2*INT((IK-454)/2)
33507           L2     = IJ-453-2*INT((IJ-454)/2)
33508           ID     = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
33509 C--couplings for the s-channel photon exchange
33510           A(1,1) = -QFCH(ID)
33511           A(2,1) = -QFCH(ID)
33512           B(1,1) = -DIJ(L1,L2)
33513           B(2,1) = -DIJ(L1,L2)
33514           IDP(5) = 59
33515           DRTYPE(1) = 1
33516 C--couplings for the s-channel Z exchange
33517           A(1,2) = -RFCH(ID)
33518           A(2,2) = -LFCH(ID)
33519           B(1,2) =(-WMXUSS(L1,1)*WMXUSS(L2,1)
33520      &         -HALF*WMXUSS(L1,2)*WMXUSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
33521           B(2,2) =WSGNSS(L1)*WSGNSS(L2)*(-WMXVSS(L1,1)*WMXVSS(L2,1)
33522      &         -HALF*WMXVSS(L1,2)*WMXVSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
33523           IDP(6) = 200
33524           DRTYPE(2) = 1
33525 C--couplings for the t-channel diagram
33526           IF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).EQ.0) THEN
33527             A(1,3)    = ZERO
33528             A(2,3)    =-WMXUSS(L1,1)/SW
33529             B(1,3)    =-WMXUSS(L2,1)/SW
33530             B(2,3)    = ZERO
33531             DRTYPE(3) = 2
33532           ELSEIF(IDHEP(KHEP).LT.0.AND.MOD(IL,2).NE.0) THEN
33533             A(1,3)    =-WMXVSS(L1,1)*WSGNSS(L1)/SW
33534             A(2,3)    = ZERO
33535             B(1,3)    = ZERO
33536             B(2,3)    =-WMXVSS(L2,1)*WSGNSS(L2)/SW
33537             DRTYPE(3) = 2
33538           ELSEIF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).NE.0) THEN
33539             A(1,3)    = ZERO
33540             A(2,3)    =-WMXVSS(L2,1)*WSGNSS(L2)/SW
33541             B(1,3)    =-WMXVSS(L1,1)*WSGNSS(L1)/SW
33542             B(2,3)    = ZERO
33543             DRTYPE(3) = 3
33544           ELSE
33545             A(1,3)    =-WMXUSS(L2,1)/SW
33546             A(2,3)    = ZERO
33547             B(1,3)    = ZERO
33548             B(2,3)    =-WMXUSS(L1,1)/SW
33549             DRTYPE(3) = 3
33550           ENDIF
33551           IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
33552      &             +2*MOD(IL,2)-1
33553           NDIA = 3
33554 C--setup the colour flow
33555           NCFL(1) = 1
33556           SPNCFC(1,1,1) = ONE
33557           IFLOW(1) = 1
33558           IFLOW(2) = 1
33559           IFLOW(3) = 1
33560 C--chargino neutralino production
33561         ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.GE.450.AND.IJ.LE.453).OR.
33562      &       (IJ.GE.454.AND.IJ.LE.457.AND.IK.GE.450.AND.IK.LE.453)) THEN
33563 C--first check the fermion is first and change order if not
33564           IF(IDHEP(LHEP).LT.0) THEN
33565             ID   = LHEP
33566             LHEP = MHEP
33567             MHEP = ID
33568           ENDIF
33569 C--chargino first
33570           IF(IK.GT.453) THEN
33571 C--change order of outgoing particles if negative chargino
33572             IF(IDHEP(KHEP).LT.0) THEN
33573               ID =KHEP
33574               KHEP=JHEP
33575               JHEP=ID
33576             ENDIF
33577             L1 = IK-453-2*INT((IK-454)/2)
33578             L2 = IJ-449
33579 C--chargino second
33580           ELSE
33581             IF(IDHEP(JHEP).GT.0) THEN
33582               ID =KHEP
33583               KHEP=JHEP
33584               JHEP=ID
33585             ENDIF
33586             L1 = IJ-453-2*INT((IJ-454)/2)
33587             L2 = IK-449
33588           ENDIF
33589 C--first the W exchange diagram
33590           A(1,1) = ZERO
33591           A(2,1) =-ORT/SW
33592           B(1,1) =( ORT*ZMXNSS(L2,3)*WMXUSS(L1,2)
33593      &         +ZMXNSS(L2,2)*WMXUSS(L1,1))/SW
33594           B(2,1) =WSGNSS(L1)*ZSGNSS(L2)*(-ORT*ZMXNSS(L2,4)*WMXVSS(L1,2)
33595      &         +ZMXNSS(L2,2)*WMXVSS(L1,1))/SW
33596           IDP(5) = 198
33597           DRTYPE(1) = 1
33598 C--intermediate particles for the t and u channel diagrams
33599           IL = IDHW(LHEP)
33600           IM = IDHW(MHEP)
33601           IDP(6) = IM+394
33602           IDP(7) = IL+406
33603           IF(MOD(IL,2).EQ.0) THEN
33604             A(1,2) = ZERO
33605             A(2,2) =-WMXUSS(L1,1)/SW
33606             B(1,2) =-RT*SLFCH(IM-6,L2)
33607             B(2,2) = ZERO
33608             DRTYPE(2) = 2
33609             A(1,3) = ZERO
33610             A(2,3) =-RT*ZSGNSS(L2)*SLFCH(IL,L2)
33611             B(1,3) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
33612             B(2,3) = ZERO
33613             DRTYPE(3) = 3
33614           ELSE
33615             A(1,2) = ZERO
33616             A(2,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
33617             B(1,2) =-RT*ZSGNSS(L2)*SLFCH(IM-6,L2)
33618             B(2,2) = ZERO
33619             DRTYPE(2) = 3
33620             A(1,3) = ZERO
33621             A(2,3) =-RT*SLFCH(IL,L2)
33622             B(1,3) =-WMXUSS(L1,1)/SW
33623             B(2,3) = ZERO
33624             DRTYPE(3) = 2
33625           ENDIF
33626 C--setup the colour flow
33627           NDIA = 3
33628           NCFL(1) = 1
33629           SPNCFC(1,1,1) = ONE
33630           IFLOW(1) = 1
33631           IFLOW(2) = 1
33632           IFLOW(3) = 1
33633 C--neutralino gluino production
33634         ELSEIF((IK.EQ.449.AND.IJ.GE.450.AND.IJ.LE.453).OR.
33635      &         (IJ.EQ.449.AND.IK.GE.450.AND.IK.LE.453)) THEN
33636 C--first check the fermion is first and change order if not
33637           IF(IDHEP(LHEP).LT.0) THEN
33638             ID   = LHEP
33639             LHEP = MHEP
33640             MHEP = ID
33641           ENDIF
33642 C--check neutralino first and change order if not
33643           IF(IK.EQ.449) THEN
33644             L1 = IJ-449
33645             ID = KHEP
33646             KHEP = JHEP
33647             JHEP = ID
33648           ELSE
33649             L1 = IK-449
33650           ENDIF
33651           IL = IDHW(LHEP)
33652 C--coupling for the diagrams
33653 C--first t-channel squark exchange
33654           IDP(5) = 400+IL
33655           A(1,1) = ZERO
33656           A(2,1) =-RT*SLFCH(IL,L1)
33657           B(1,1) =-RT
33658           B(2,1) = ZERO
33659           DRTYPE(1) = 2
33660           IDP(6) = 412+IL
33661           A(1,2) =-RT*ZSGNSS(L1)*SRFCH(IL,L1)
33662           A(2,2) = ZERO
33663           B(1,2) = ZERO
33664           B(2,2) = RT
33665           DRTYPE(2) = 2
33666 C--then u-channel s squark exchange
33667           IDP(7) = 400+IL
33668           A(1,3) = ZERO
33669           A(2,3) =-RT
33670           B(1,3) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)
33671           B(2,3) = ZERO
33672           DRTYPE(3) = 3
33673           IDP(8) = 412+IL
33674           A(1,4) = RT
33675           A(2,4) = ZERO
33676           B(1,4) = ZERO
33677           B(2,4) =-RT*SRFCH(IL,L1)
33678           DRTYPE(4) = 3
33679 C--colour flow information
33680           NDIA = 4
33681           NCFL(1) = 1
33682           IFLOW(1) = 1
33683           IFLOW(2) = 1
33684           IFLOW(3) = 1
33685           IFLOW(4) = 1
33686           SPNCFC(1,1,1) = ONE
33687 C--chargino gluino production
33688         ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.EQ.449).OR.
33689      &         (IJ.GE.454.AND.IJ.LE.457.AND.IK.EQ.449)) THEN
33690 C--first check the fermion is first and change order if not
33691           IF(IDHEP(LHEP).LT.0) THEN
33692             ID   = LHEP
33693             LHEP = MHEP
33694             MHEP = ID
33695           ENDIF
33696 C--check chargino first and change order if not
33697           IF(IK.EQ.449) THEN
33698             L1 = IJ-453-2*INT((IJ-454)/2)
33699             ID = KHEP
33700             KHEP = JHEP
33701             JHEP = ID
33702           ELSE
33703             L1 = IK-453-2*INT((IK-454)/2)
33704           ENDIF
33705           IL = IDHW(LHEP)
33706           IM = IDHW(MHEP)
33707           IDP(5) = IM+394
33708           IDP(6) = IL+406
33709           IF(MOD(IL,2).EQ.0) THEN
33710             A(1,1) = ZERO
33711             A(2,1) =-WMXUSS(L1,1)/SW
33712             B(1,1) =-RT
33713             B(2,1) = ZERO
33714             DRTYPE(1) = 2
33715             A(1,2) = ZERO
33716             A(2,2) =-RT
33717             B(1,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
33718             B(2,2) = ZERO
33719             DRTYPE(2) = 3
33720           ELSE
33721             A(1,1) = ZERO
33722             A(2,1) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
33723             B(1,1) =-RT
33724             B(2,1) = ZERO
33725             DRTYPE(1) = 2
33726             A(1,2) = ZERO
33727             A(2,2) =-RT
33728             B(1,2) =-WMXUSS(L1,1)/SW
33729             B(2,2) = ZERO
33730             DRTYPE(2) = 3
33731           ENDIF
33732 C--setup the colour flow
33733           NDIA = 2
33734           NCFL(1) = 1
33735           SPNCFC(1,1,1) = ONE
33736           IFLOW(1) = 1
33737           IFLOW(2) = 1
33738 C--quark quark to gluino gluino
33739         ELSEIF(IJ.EQ.449.AND.IK.EQ.449.AND.
33740      &         IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
33741 C--change order if antiquark first
33742           IF(IDHEP(LHEP).LT.0) THEN
33743             ID   = LHEP
33744             LHEP = MHEP
33745             MHEP = ID
33746           ENDIF
33747           IL   = IDHW(LHEP)
33748 C--couplings of the various diagrams
33749           A(1,1) = ZERO
33750           A(2,1) =-RT
33751           B(1,1) =-RT
33752           B(2,1) = ZERO
33753           A(1,2) = RT
33754           A(2,2) = ZERO
33755           B(1,2) = ZERO
33756           B(2,2) = RT
33757           DO 4 I=1,2
33758           A(I,3) = A(I,1)
33759           B(I,3) = B(I,1)
33760           A(I,4) = A(I,2)
33761  4        B(I,4) = B(I,2)
33762           A(1,5) = ONE
33763           A(2,5) = ONE
33764           B(1,5) = ONE
33765           B(2,5) = ONE
33766           A(1,6) =-ONE
33767           A(2,6) =-ONE
33768           B(1,6) = ONE
33769           B(2,6) = ONE
33770 C--intermediate particles
33771           IDP(5) = 400+IL
33772           IDP(6) = 412+IL
33773           IDP(7) = 400+IL
33774           IDP(8) = 412+IL
33775           IDP(9)  = 13
33776           IDP(10) = 13
33777 C--types of diagram
33778           DRTYPE(1) = 2
33779           DRTYPE(2) = 2
33780           DRTYPE(3) = 3
33781           DRTYPE(4) = 3
33782           DRTYPE(5) = 1
33783           DRTYPE(6) = 1
33784           NDIA = 6
33785 C--setup the colour flow
33786           NCFL(1) = 2
33787           SPNCFC(1,1,1) = 8.0D0/27.0D0
33788           SPNCFC(2,2,1) = 8.0D0/27.0D0
33789           SPNCFC(1,2,1) =-ONE/27.0D0
33790           SPNCFC(2,1,1) =-ONE/27.0D0
33791           IFLOW(1) = 1
33792           IFLOW(2) = 1
33793           IFLOW(3) = 2
33794           IFLOW(4) = 2
33795           IFLOW(5) = 1
33796           IFLOW(6) = 2
33797 C--gluon gluon to gluino gluino
33798         ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13.AND.IJ.EQ.449
33799      &         .AND.IK.EQ.449) THEN
33800 C--setup the diagrams
33801           IDP(5) = 449
33802           IDP(6) = 449
33803           IDP(7) = 13
33804           IDP(8) = 13
33805           DRTYPE(1) = 14
33806           DRTYPE(2) = 15
33807           DRTYPE(3) = 16
33808           DRTYPE(4) = 16
33809           NDIA = 4
33810 C--setup the colour flow
33811           NCFL(1) = 2
33812           IFLOW(1) = 1
33813           IFLOW(2) = 2
33814           IFLOW(3) = 1
33815           IFLOW(4) = 2
33816           SPNCFC(1,1,1) = 9.0D0/16.0D0
33817           SPNCFC(2,2,1) = SPNCFC(1,1,1)
33818           SPNCFC(1,2,1) =-9.0D0/32.0D0
33819           SPNCFC(2,1,1) =-9.0D0/32.0D0
33820 C--neutralino squark production
33821         ELSEIF(    (IK.GE.450.AND.IK.LE.453.AND.
33822      &        ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
33823      &        .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
33824      &        ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
33825      &         THEN
33826 C--change order if gluon first
33827           IF(IDHW(LHEP).EQ.13) THEN
33828             ID   = LHEP
33829             LHEP = MHEP
33830             MHEP = ID
33831           ENDIF
33832 C--change order in squark first
33833           IF(IJ.GE.450) THEN
33834             ID = KHEP
33835             KHEP = JHEP
33836             JHEP = ID
33837             IK = IDHW(KHEP)
33838             IJ = IDHW(JHEP)
33839           ENDIF
33840           IL = IDHW(LHEP)
33841           L1 = IK-449
33842 C--left handed (lighter) squark
33843           IF(IJ.LT.412) THEN
33844             A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
33845             A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
33846 C--right handed (heavier) squark
33847           ELSEIF(IJ.GT.412) THEN
33848             A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
33849             A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
33850           ENDIF
33851           DO 5 I=1,2
33852  5        A(I,2) = A(I,1)
33853           IDP(5) = IJ
33854           IDP(6) = IL
33855 C--colour flow info
33856           DRTYPE(1) = 8
33857           DRTYPE(2) = 10
33858           NDIA = 2
33859           NCFL(1) = 1
33860           SPNCFC(1,1,1) = HALF/THREE
33861           IFLOW(1) = 1
33862           IFLOW(2) = 1
33863 C--neutralino antisquark production
33864         ELSEIF(    (IK.GE.450.AND.IK.LE.453.AND.
33865      &        ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
33866      &        .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
33867      &        ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
33868      &         THEN
33869 C--change order if gluon first
33870           IF(IDHW(LHEP).EQ.13) THEN
33871             ID   = LHEP
33872             LHEP = MHEP
33873             MHEP = ID
33874           ENDIF
33875 C--change order in squark first
33876           IF(IJ.GE.450) THEN
33877             ID = KHEP
33878             KHEP = JHEP
33879             JHEP = ID
33880             IK = IDHW(KHEP)
33881             IJ = IDHW(JHEP)
33882           ENDIF
33883           IL = IDHW(LHEP)-6
33884           L1 = IK-449
33885 C--left handed (lighter) squark
33886           IF(IJ.LE.412) THEN
33887             A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
33888             A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
33889 C--right handed (heavier) squark
33890           ELSEIF(IJ.GT.412) THEN
33891             A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
33892             A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
33893           ENDIF
33894           DO 6 I=1,2
33895  6        A(I,2) = A(I,1)
33896           IDP(5) = IJ
33897           IDP(6) = IL
33898 C--colour flow info
33899           DRTYPE(1) = 9
33900           DRTYPE(2) = 11
33901           NDIA = 2
33902           NCFL(1) = 1
33903           SPNCFC(1,1,1) = HALF/THREE
33904           IFLOW(1) = 1
33905           IFLOW(2) = 1
33906 C--chargino squark
33907         ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
33908      &         ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
33909      &         .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
33910      &        ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
33911      &         THEN
33912 C--change order if gluon first
33913           IF(IDHW(LHEP).EQ.13) THEN
33914             ID   = LHEP
33915             LHEP = MHEP
33916             MHEP = ID
33917           ENDIF
33918 C--change order if squark first
33919           IF(IJ.GE.454) THEN
33920             ID = KHEP
33921             KHEP = JHEP
33922             JHEP = ID
33923             IK = IDHW(KHEP)
33924             IJ = IDHW(JHEP)
33925           ENDIF
33926           IL = IDHW(LHEP)
33927           L1 = IK-453-2*INT((IK-454)/2)
33928 C--left handed (lighter) squark
33929           A(1,1) = ZERO
33930           IF(IJ.LE.412) THEN
33931             IF(MOD(IL,2).EQ.0) THEN
33932               A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
33933             ELSE
33934               A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
33935             ENDIF
33936 C--right handed (heavier) squark
33937           ELSEIF(IJ.GT.412) THEN
33938             IF(MOD(IL,2).EQ.0) THEN
33939               A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
33940             ELSE
33941               A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
33942             ENDIF
33943           ENDIF
33944           DO 7 I=1,2
33945  7        A(I,2) = A(I,1)
33946           IDP(5) = IJ
33947           IDP(6) = IL
33948 C--colour flow info
33949           DRTYPE(1) = 8
33950           DRTYPE(2) = 10
33951           NDIA = 2
33952           NCFL(1) = 1
33953           SPNCFC(1,1,1) = HALF/THREE
33954           IFLOW(1) = 1
33955           IFLOW(2) = 1
33956 C--chargino antisquark
33957         ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
33958      &         ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
33959      &         .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
33960      &        ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
33961      &         THEN
33962 C--change order if gluon first
33963           IF(IDHW(LHEP).EQ.13) THEN
33964             ID   = LHEP
33965             LHEP = MHEP
33966             MHEP = ID
33967           ENDIF
33968 C--change order in squark first
33969           IF(IJ.GE.454) THEN
33970             ID = KHEP
33971             KHEP = JHEP
33972             JHEP = ID
33973             IK = IDHW(KHEP)
33974             IJ = IDHW(JHEP)
33975           ENDIF
33976           IL = IDHW(LHEP)-6
33977           L1 = IK-453-2*INT((IK-454)/2)
33978 C--left handed (lighter) squark
33979           A(2,1) = ZERO
33980           IF(IJ.LE.412) THEN
33981             IF(MOD(IL,2).EQ.0) THEN
33982               A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
33983             ELSE
33984               A(1,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
33985             ENDIF
33986 C--right handed (heavier) squark
33987           ELSEIF(IJ.GT.412) THEN
33988             IF(MOD(IL,2).EQ.0) THEN
33989               A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
33990             ELSE
33991               A(1,1) = -WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
33992             ENDIF
33993           ENDIF
33994           DO 8 I=1,2
33995  8        A(I,2) = A(I,1)
33996           IDP(5) = IJ
33997           IDP(6) = IL
33998 C--colour flow info
33999           DRTYPE(1) = 9
34000           DRTYPE(2) = 11
34001           NDIA = 2
34002           NCFL(1) = 1
34003           SPNCFC(1,1,1) = ONE
34004           IFLOW(1) = 1
34005           IFLOW(2) = 1
34006 C--squark gluino production
34007         ELSEIF((IK.EQ.449.AND.((IJ.GE.401.AND.IJ.LE.406)
34008      &                         .OR.(IJ.GE.413.AND.IJ.LE.418)))
34009      &         .OR.(IJ.GE.449.AND.((IK.GE.401.AND.IK.LE.406)
34010      &                         .OR.(IK.GE.413.AND.IK.LE.418)))) THEN
34011 C--change order if gluon first
34012           IF(IDHW(LHEP).EQ.13) THEN
34013             ID   = LHEP
34014             LHEP = MHEP
34015             MHEP = ID
34016           ENDIF
34017           IL = IDHW(LHEP)
34018 C--change order in squark first
34019           IF(IJ.EQ.449) THEN
34020             ID = KHEP
34021             KHEP = JHEP
34022             JHEP = ID
34023             IJ = IDHW(JHEP)
34024           ENDIF
34025           ID = INT((IJ-401)/12)+1
34026           IF(ID.EQ.1) THEN
34027             A(1,1) = ZERO
34028             A(2,1) =-RT
34029           ELSE
34030             A(1,1) = RT
34031             A(2,1) = ZERO
34032           ENDIF
34033           DO 9 I=1,2
34034           A(I,2) =-A(I,1)
34035           A(I,3) = A(I,1)
34036  9        A(I,4) = A(I,1)
34037           DRTYPE(1) = 12
34038           DRTYPE(2) = 12
34039           DRTYPE(3) = 8
34040           DRTYPE(4) = 10
34041           IDP(5) = 449
34042           IDP(6) = 449
34043           IDP(7) = IJ
34044           IDP(8) = IL
34045 C--colour flows
34046           NDIA = 4
34047           NCFL(1) = 2
34048           IFLOW(1) = 1
34049           IFLOW(2) = 2
34050           IFLOW(3) = 1
34051           IFLOW(4) = 2
34052           SPNCFC(1,1,1) = 2.0D0/9.0D0
34053           SPNCFC(2,2,1) = 2.0D0/9.0D0
34054           SPNCFC(1,2,1) = -0.25D0/9.0D0
34055           SPNCFC(2,1,1) = -0.25D0/9.0D0
34056 C--antisquark gluino production
34057         ELSEIF((IK.GE.449..AND.((IJ.GE.407.AND.IJ.LE.412)
34058      &                          .OR.(IJ.GE.419.AND.IJ.LE.424)))
34059      &         .OR.(IJ.GE.449.AND.((IK.GE.407.AND.IK.LE.412)
34060      &                          .OR.(IK.GE.419.AND.IK.LE.424)))) THEN
34061 C--change order if gluon first
34062           IF(IDHW(LHEP).EQ.13) THEN
34063             ID   = LHEP
34064             LHEP = MHEP
34065             MHEP = ID
34066           ENDIF
34067           IL = IDHW(LHEP)
34068 C--change order in squark first
34069           IF(IJ.EQ.449) THEN
34070             ID = KHEP
34071             KHEP = JHEP
34072             JHEP = ID
34073             IJ = IDHW(JHEP)
34074           ENDIF
34075           ID = INT((IJ-401)/12)+1
34076           IF(ID.EQ.1) THEN
34077             A(1,1) =-RT
34078             A(2,1) = ZERO
34079           ELSE
34080             A(1,1) = ZERO
34081             A(2,1) = RT
34082           ENDIF
34083           DO 10 I=1,2
34084           A(I,2) =-A(I,1)
34085           A(I,3) = A(I,1)
34086  10       A(I,4) = A(I,1)
34087           DRTYPE(1) = 13
34088           DRTYPE(2) = 13
34089           DRTYPE(3) = 9
34090           DRTYPE(4) = 11
34091           IDP(5) = 449
34092           IDP(6) = 449
34093           IDP(7) = IJ
34094           IDP(8) = IL
34095 C--colour flows
34096           NDIA = 4
34097           NCFL(1) = 2
34098           IFLOW(1) = 1
34099           IFLOW(2) = 2
34100           IFLOW(3) = 1
34101           IFLOW(4) = 2
34102           SPNCFC(1,1,1) = 2.0D0/9.0D0
34103           SPNCFC(2,2,1) = 2.0D0/9.0D0
34104           SPNCFC(1,2,1) = -0.25D0/9.0D0
34105           SPNCFC(2,1,1) = -0.25D0/9.0D0
34106 C--unrecognised SUSY process
34107         ELSE
34108           CALL HWWARN('HWHSPN',503)
34109         ENDIF
34110 C--LLE processes
34111       ELSEIF(IPRO.EQ.8) THEN
34112 C--neutralino antineutrino production
34113         IF(IK.GE.450.AND.IK.LE.453.AND.
34114      &     IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0) THEN
34115 C--ensure lepton first
34116           IF(IDHEP(LHEP).LT.0) THEN
34117             ID = LHEP
34118             LHEP = MHEP
34119             MHEP = ID
34120           ENDIF
34121 C--RPV indices
34122           III = (IJ-126)/2
34123           JJJ = (IDHW(LHEP)-119)/2
34124           KKK = (IDHW(MHEP)-125)/2
34125           L1  = IK-449
34126           IDP(5) = 424+2*III
34127           DO 11 I=1,2
34128           IDP(5+I) = 423+2*JJJ+(I-1)*12
34129  11       IDP(7+I) = 423+2*KKK+(I-1)*12
34130 C--types of diagram
34131           DRTYPE(1) = 21
34132           DRTYPE(2) = 22
34133           DRTYPE(3) = 22
34134           DRTYPE(4) = 23
34135           DRTYPE(5) = 23
34136 C--RPV couplings
34137           A(1,1) = ZERO
34138           A(2,1) = -LAMDA1(III,JJJ,KKK)
34139           DO 12 I=1,2
34140           B(1,I+1) = ZERO
34141           B(2,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
34142           A(1,I+3) = ZERO
34143  12       A(2,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
34144 C--MSSM couplings
34145           DO 13 J=1,2
34146           B(J,1) = AFN(O(J),2*III+6,1,L1)
34147           DO 13 I=1,2
34148           A(J,I+1) = AFN(O(J),2*JJJ+5,I,L1)
34149  13       B(J,I+3) = AFN(  J ,2*KKK+5,I,L1)
34150 C--colour flows
34151           NDIA = 5
34152           NCFL(1) = 1
34153           DO 14 I=1,5
34154  14       IFLOW(I) = 1
34155           SPNCFC(1,1,1) = ONE
34156 C--neutralino neutrino production
34157         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.
34158      &         IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0) THEN
34159 C--ensure lepton first
34160           IF(IDHEP(LHEP).LT.0) THEN
34161             ID = LHEP
34162             LHEP = MHEP
34163             MHEP = ID
34164           ENDIF
34165 C--RPV indices
34166           III = (IJ-120)/2
34167           JJJ = (IDHW(MHEP)-125)/2
34168           KKK = (IDHW(LHEP)-119)/2
34169           L1  = IK-449
34170           IDP(5) = 424+2*III
34171           DO 15 I=1,2
34172           IDP(5+I) = 423+2*JJJ+(I-1)*12
34173  15       IDP(7+I) = 423+2*KKK+(I-1)*12
34174 C--types of diagram
34175           DRTYPE(1) = 24
34176           DRTYPE(2) = 25
34177           DRTYPE(3) = 25
34178           DRTYPE(4) = 26
34179           DRTYPE(5) = 26
34180 C--RPV couplings
34181           A(1,1) = -LAMDA1(III,JJJ,KKK)
34182           A(2,1) = ZERO
34183           DO 16 I=1,2
34184           B(1,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
34185           B(2,I+1) = ZERO
34186           A(1,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
34187  16       A(2,I+3) = ZERO
34188 C--MSSM couplings
34189           DO 17 J=1,2
34190           B(J,1) = AFN(  J ,2*III+6,1,L1)
34191           DO 17 I=1,2
34192           A(J,I+1) = AFN(  J ,2*JJJ+5,I,L1)
34193  17       B(J,I+3) = AFN(O(J),2*KKK+5,I,L1)
34194 C--colour flows
34195           NDIA = 5
34196           NCFL(1) = 1
34197           DO 18 I=1,5
34198  18       IFLOW(I) = 1
34199           SPNCFC(1,1,1) = ONE
34200 C--chargino antilepton
34201         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.
34202      &         IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
34203 C--ensure lepton first
34204           IF(IDHEP(LHEP).LT.0) THEN
34205             ID = LHEP
34206             LHEP = MHEP
34207             MHEP = ID
34208           ENDIF
34209 C--RPV indices
34210           III = (IJ-125)/2
34211           JJJ = (IDHW(LHEP)-119)/2
34212           KKK = (IDHW(MHEP)-125)/2
34213           L1 = IK-455
34214           IDP(5) = 2*III+424
34215           IDP(6) = 2*JJJ+424
34216 C--RPV couplings
34217           A(1,1) = ZERO
34218           A(2,1) = LAMDA1(III,JJJ,KKK)
34219           B(1,2) = ZERO
34220           B(2,2) =-LAMDA1(III,JJJ,KKK)
34221 C--MSSM couplings
34222           DO 19 J=1,2
34223           B(J,1) = AFC(O(J),2*III+6,1,L1)
34224  19       A(J,2) = AFC(O(J),2*JJJ+6,1,L1)
34225 C--colour flows
34226           DRTYPE(1) = 21
34227           DRTYPE(2) = 22
34228           NDIA = 2
34229           NCFL(1) = 1
34230           DO 20 I=1,2
34231  20       IFLOW(I) = 1
34232           SPNCFC(1,1,1) = ONE
34233 C--chargino lepton
34234         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.
34235      &         IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
34236 C--ensure lepton first
34237           IF(IDHEP(LHEP).LT.0) THEN
34238             ID = LHEP
34239             LHEP = MHEP
34240             MHEP = ID
34241           ENDIF
34242 C--RPV indices
34243           III = (IJ-119)/2
34244           JJJ = (IDHW(MHEP)-125)/2
34245           KKK = (IDHW(LHEP)-119)/2
34246           L1 = IK-453
34247           IDP(5) = 2*III+424
34248           IDP(6) = 2*JJJ+424
34249 C--RPV couplings
34250           A(1,1) = LAMDA1(III,JJJ,KKK)
34251           A(2,1) = ZERO
34252           B(1,2) =-LAMDA1(III,JJJ,KKK)
34253           B(2,2) = ZERO
34254 C--MSSM couplings
34255           DO 21 J=1,2
34256           B(J,1) = AFC(J,2*III+6,1,L1)
34257  21       A(J,2) = AFC(J,2*JJJ+6,1,L1)
34258 C--colour flows
34259           DRTYPE(1) = 24
34260           DRTYPE(2) = 25
34261           NDIA = 2
34262           NCFL(1) = 1
34263           DO 22 I=1,2
34264  22       IFLOW(I) = 1
34265           SPNCFC(1,1,1) = ONE
34266 C--e+e- production
34267         ELSEIF(IK.GE.121.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
34268      &         IJ.GE.121.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
34269 C--ensure incoming lepton first
34270           IF(IDHEP(LHEP).LT.0) THEN
34271             ID = MHEP
34272             MHEP = LHEP
34273             LHEP = ID
34274           ENDIF
34275 C--ensure outgoing lepton first
34276           IF(IDHEP(KHEP).LT.0) THEN
34277             ID = IK
34278             IK = IJ
34279             IJ = ID
34280             ID = KHEP
34281             KHEP = JHEP
34282             JHEP = ID
34283           ENDIF
34284 C--only need the correlations for tau production
34285           IF(IK.NE.125.AND.IJ.NE.131) RETURN
34286 C--find the RPV indices
34287           III = (IDHW(LHEP)-119)/2
34288           KKK = (IK-119)/2
34289           LLL = (IJ-125)/2
34290           NDIA = 0
34291           EE = SQRT(HWUAEM(SH)*FOUR*PIFAC)
34292 C--s-channel photon and Z exchange if needed
34293           IF(KKK.EQ.LLL) THEN
34294             NDIA = 2
34295             ID1 = 9+2*III
34296             ID2 = 9+2*KKK
34297 C--photon first
34298             A(1,1) = -EE*QFCH(ID1)
34299             A(2,1) = -EE*QFCH(ID1)
34300             B(1,1) = -EE*QFCH(ID2)
34301             B(2,1) = -EE*QFCH(ID2)
34302             IDP(5) = 59
34303             DRTYPE(1) = 4
34304 C--then the Z exchange
34305             A(1,2) = -EE*RFCH(ID1)
34306             A(2,2) = -EE*LFCH(ID1)
34307             B(1,2) = -EE*RFCH(ID2)
34308             B(2,2) = -EE*LFCH(ID2)
34309             IDP(6) = 200
34310             DRTYPE(2) = 4
34311           ENDIF
34312           DO 23 JJJ=1,3
34313 C--s-channel sneutrino exchange
34314             IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(LLL,JJJ,KKK)).GT.EPS) THEN
34315               NDIA = NDIA+1
34316               DRTYPE(NDIA) = 21
34317               IDP(NDIA+4) = 424+2*JJJ
34318               A(1,NDIA)   = LAMDA1(III,JJJ,III)
34319               A(2,NDIA)   = ZERO
34320               B(1,NDIA)   = ZERO
34321               B(2,NDIA)   = LAMDA1(LLL,JJJ,KKK)
34322             ENDIF
34323 C--s-channel antisneutrino exchange
34324             IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(KKK,JJJ,LLL)).GT.EPS) THEN
34325               NDIA = NDIA+1
34326               DRTYPE(NDIA) = 21
34327               IDP(NDIA+4)  = 424+2*JJJ
34328               A(1,NDIA)    = ZERO
34329               A(2,NDIA)    = LAMDA1(III,JJJ,III)
34330               B(1,NDIA)    = LAMDA1(KKK,JJJ,LLL)
34331               B(2,NDIA)    = ZERO
34332             ENDIF
34333 C--t-channel sneutrino exchange
34334             IF(ABS(LAMDA1(KKK,JJJ,III)*LAMDA1(LLL,JJJ,III)).GT.EPS) THEN
34335               NDIA = NDIA+1
34336               DRTYPE(NDIA) = 22
34337               IDP(NDIA+4)  = 424+2*JJJ
34338               A(1,NDIA)    = LAMDA1(KKK,JJJ,III)
34339               A(2,NDIA)    = ZERO
34340               B(1,NDIA)    = ZERO
34341               B(2,NDIA)    = LAMDA1(LLL,JJJ,III)
34342             ENDIF
34343 C--t-channel antisneutrino exchange
34344             IF(ABS(LAMDA1(III,JJJ,KKK)*LAMDA1(III,JJJ,LLL)).GT.EPS) THEN
34345               NDIA = NDIA+1
34346               DRTYPE(NDIA) = 22
34347               IDP(NDIA+4)  = 424+2*JJJ
34348               A(1,NDIA)    = ZERO
34349               A(2,NDIA)    = LAMDA1(III,JJJ,KKK)
34350               B(1,NDIA)    = LAMDA1(III,JJJ,LLL)
34351               B(2,NDIA)    = ZERO
34352             ENDIF
34353  23       CONTINUE
34354 C--setup the colour flow
34355           NCFL(1) = 1
34356           SPNCFC(1,1,1) = ONE
34357           DO 24 I=1,NDIA
34358  24       IFLOW(I) = 1
34359 C--d dbar production
34360         ELSEIF(IK.LE.12.AND.IK.LE.12.AND.
34361      &         MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
34362 C--can't produce quark which decays before hadronization
34363           RETURN
34364 C--unrecognised process
34365         ELSE
34366           CALL HWWARN('HWHSPN',504)
34367         ENDIF
34368 C--LQD processes
34369       ELSEIF(IPRO.EQ.40) THEN
34370 C--change outgoing order
34371         ID = IJ
34372         IJ = IK
34373         IK = ID
34374         ID = JHEP
34375         JHEP = KHEP
34376         KHEP = ID
34377 C--neutrino neutralino production
34378         IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
34379      &     IDPDG(IJ).GT.0) THEN
34380 C--change order if antiparticle first
34381           IF(IDHEP(LHEP).LT.0) THEN
34382             ID   = LHEP
34383             LHEP = MHEP
34384             MHEP = ID
34385           ENDIF
34386 C--indices for RPV coupling
34387           III = (IJ-120)/2
34388           JJJ = (IDHW(MHEP)-5)/2
34389           KKK = (IDHW(LHEP)+1)/2
34390           L1  = IK - 449
34391           IDP(5) = 424+2*III
34392           DO 25 I=1,2
34393           IDP(5+I) = 399+2*JJJ+(I-1)*12
34394  25       IDP(7+I) = 399+2*KKK+(I-1)*12
34395 C--types of diagram
34396           DRTYPE(1) = 24
34397           DRTYPE(2) = 25
34398           DRTYPE(3) = 25
34399           DRTYPE(4) = 26
34400           DRTYPE(5) = 26
34401 C--RPV couplings
34402           A(1,1) = -LAMDA2(III,JJJ,KKK)
34403           A(2,1) = ZERO
34404           DO 26 I=1,2
34405           B(1,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
34406           B(2,I+1) = ZERO
34407           A(1,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
34408  26       A(2,I+3) = ZERO
34409 C--MSSM couplings
34410           DO 27 J=1,2
34411           B(J,1) = AFN(  J ,2*III+6,1,L1)
34412           DO 27 I=1,2
34413           A(J,I+1) = AFN(  J ,2*JJJ-1,I,L1)
34414  27       B(J,I+3) = AFN(O(J),2*KKK-1,I,L1)
34415 C--colour flows
34416           NDIA = 5
34417           NCFL(1) = 1
34418           DO 28 I=1,5
34419  28       IFLOW(I) = 1
34420           SPNCFC(1,1,1) = ONE/THREE
34421 C--antineutrino neutralino production
34422         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
34423      &         IDPDG(IJ).LT.0) THEN
34424 C--change order if antiparticle first
34425           IF(IDHEP(LHEP).LT.0) THEN
34426             ID   = LHEP
34427             LHEP = MHEP
34428             MHEP = ID
34429           ENDIF
34430 C--indices for RPV coupling
34431           III = (IJ-126)/2
34432           JJJ = (IDHW(LHEP)+1)/2
34433           KKK = (IDHW(MHEP)-5)/2
34434           L1  = IK - 449
34435           IDP(5) = 424+2*III
34436           DO 29 I=1,2
34437           IDP(5+I) = 399+2*JJJ+(I-1)*12
34438  29       IDP(7+I) = 399+2*KKK+(I-1)*12
34439 C--types of diagram
34440           DRTYPE(1) = 21
34441           DRTYPE(2) = 22
34442           DRTYPE(3) = 22
34443           DRTYPE(4) = 23
34444           DRTYPE(5) = 23
34445 C--RPV couplings
34446           A(1,1) = ZERO
34447           A(2,1) = -LAMDA2(III,JJJ,KKK)
34448           DO 30 I=1,2
34449           B(1,I+1) = ZERO
34450           B(2,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
34451           A(1,I+3) = ZERO
34452  30       A(2,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
34453 C--MSSM couplings
34454           DO 31 J=1,2
34455           B(J,1) = AFN(O(J),2*III+6,1,L1)
34456           DO 31 I=1,2
34457           A(J,I+1) = AFN(O(J),2*JJJ-1,I,L1)
34458  31       B(J,I+3) = AFN(  J ,2*KKK-1,I,L1)
34459 C--colour flows
34460           NDIA = 5
34461           NCFL(1) = 1
34462           DO 32 I=1,5
34463  32       IFLOW(I) = 1
34464           SPNCFC(1,1,1) = ONE/THREE
34465 C--lepton neutralino production
34466         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
34467      &         IDPDG(IJ).GT.0) THEN
34468 C--change order if antiparticle first
34469           IF(IDHEP(LHEP).LT.0) THEN
34470             ID   = LHEP
34471             LHEP = MHEP
34472             MHEP = ID
34473           ENDIF
34474 C--indices for RPV coupling
34475           III = (IJ-119)/2
34476           JJJ = (IDHW(MHEP)-6)/2
34477           KKK = (IDHW(LHEP)+1)/2
34478           L1  = IK - 449
34479           DO 33 I=1,2
34480           IDP(4+I) = 423+2*III+(I-1)*12
34481           IDP(6+I) = 400+2*JJJ+(I-1)*12
34482  33       IDP(8+I) = 399+2*KKK+(I-1)*12
34483 C--types of diagram
34484           DRTYPE(1) = 24
34485           DRTYPE(2) = 24
34486           DRTYPE(3) = 25
34487           DRTYPE(4) = 25
34488           DRTYPE(5) = 26
34489           DRTYPE(6) = 26
34490 C--RPV couplings
34491           DO 34 I=1,2
34492           A(1,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
34493           A(2,I  ) = 0.0D0
34494           B(1,I+2) = QMIXSS(2*JJJ  ,1,I)*LAMDA2(III,JJJ,KKK)
34495           B(2,I+2) = 0.0D0
34496           A(1,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
34497           A(2,I+4) = 0.0D0
34498 C--MSSM couplings
34499           DO 34 J=1,2
34500           B(J,I  ) = AFN(  J ,2*III+5,I,L1)
34501           A(J,I+2) = AFN(  J ,2*JJJ  ,I,L1)
34502  34       B(J,I+4) = AFN(O(J),2*KKK-1,I,L1)
34503 C--colour flows
34504           NDIA = 6
34505           NCFL(1) = 1
34506           DO 35 I=1,6
34507  35       IFLOW(I) = 1
34508           SPNCFC(1,1,1) = ONE/THREE
34509 C--antilepton neutralino production
34510         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
34511      &         IDPDG(IJ).LT.0) THEN
34512 C--change order if antiparticle first
34513           IF(IDHEP(LHEP).LT.0) THEN
34514             ID   = LHEP
34515             LHEP = MHEP
34516             MHEP = ID
34517           ENDIF
34518 C--indices for RPV coupling
34519           III = (IJ-125)/2
34520           JJJ = IDHW(LHEP)/2
34521           KKK = (IDHW(MHEP)-5)/2
34522           L1  = IK - 449
34523           DO 36 I=1,2
34524           IDP(4+I) = 423+2*III+(I-1)*12
34525           IDP(6+I) = 400+2*JJJ+(I-1)*12
34526  36       IDP(8+I) = 399+2*KKK+(I-1)*12
34527 C--types of diagram
34528           DRTYPE(1) = 21
34529           DRTYPE(2) = 21
34530           DRTYPE(3) = 22
34531           DRTYPE(4) = 22
34532           DRTYPE(5) = 23
34533           DRTYPE(6) = 23
34534 C--RPV couplings
34535           DO 37 I=1,2
34536           A(1,I  ) = 0.0D0
34537           A(2,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
34538           B(1,I+2) = 0.0D0
34539           B(2,I+2) = QMIXSS(2*JJJ  ,1,I)*LAMDA2(III,JJJ,KKK)
34540           A(1,I+4) = 0.0D0
34541           A(2,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
34542 C--MSSM couplings
34543           DO 37 J=1,2
34544           B(J,I  ) = AFN(O(J),2*III+5,I,L1)
34545           A(J,I+2) = AFN(O(J),2*JJJ  ,I,L1)
34546  37       B(J,I+4) = AFN(  J ,2*KKK-1,I,L1)
34547 C--colour flows
34548           NDIA = 6
34549           NCFL(1) = 1
34550           DO 39 I=1,6
34551  39       IFLOW(I) = 1
34552           SPNCFC(1,1,1) = ONE/THREE
34553 C-- +ve chargino antineutrino
34554         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
34555 C--change order if antiparticle first
34556           IF(IDHEP(LHEP).LT.0) THEN
34557             ID   = LHEP
34558             LHEP = MHEP
34559             MHEP = ID
34560           ENDIF
34561 C--indices for RPV
34562           III = (IJ-126)/2
34563           JJJ =  IDHW(LHEP)/2
34564           KKK = (IDHW(MHEP)-5)/2
34565           L1 = IK-453
34566           DO 40 I=1,2
34567           IDP(4+I) = 423+2*III+(I-1)*12
34568  40       IDP(6+I) = 399+2*JJJ+(I-1)*12
34569 C--types of diagram
34570           DRTYPE(1) = 21
34571           DRTYPE(2) = 21
34572           DRTYPE(3) = 22
34573           DRTYPE(4) = 22
34574           DO 41 I=1,2
34575 C--RPV couplings
34576           A(1,I  ) = ZERO
34577           A(2,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
34578           B(1,I+2) = ZERO
34579           B(2,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
34580 C--MSSM couplings
34581           DO 41 J=1,2
34582           B(J,I  ) = AFC(O(J),2*III+5,I,L1)
34583  41       A(J,I+2) = AFC(O(J),2*JJJ-1,I,L1)
34584 C--colour flows
34585           NDIA = 4
34586           NCFL(1) = 1
34587           DO 42 I=1,4
34588  42       IFLOW(I) = 1
34589           SPNCFC(1,1,1) = ONE/THREE
34590 C-- -ve chargino neutrino
34591         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
34592 C--change order if antiparticle first
34593           IF(IDHEP(LHEP).LT.0) THEN
34594             ID   = LHEP
34595             LHEP = MHEP
34596             MHEP = ID
34597           ENDIF
34598 C--indices for RPV
34599           III = (IJ-120)/2
34600           JJJ = (IDHW(MHEP)-6)/2
34601           KKK = (IDHW(LHEP)+1)/2
34602           L1 = IK-455
34603           DO 43 I=1,2
34604           IDP(4+I) = 423+2*III+(I-1)*12
34605  43       IDP(6+I) = 399+2*JJJ+(I-1)*12
34606 C--types of diagram
34607           DRTYPE(1) = 24
34608           DRTYPE(2) = 24
34609           DRTYPE(3) = 25
34610           DRTYPE(4) = 25
34611           DO 44 I=1,2
34612 C--RPV couplings
34613           A(1,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
34614           A(2,I  ) = ZERO
34615           B(1,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
34616           B(2,I+2) = ZERO
34617 C--MSSM couplings
34618           DO 44 J=1,2
34619           B(J,I  ) = AFC(J,2*III+5,I,L1)
34620  44       A(J,I+2) = AFC(J,2*JJJ-1,I,L1)
34621 C--colour flows
34622           NDIA = 4
34623           NCFL(1) = 1
34624           DO 45 I=1,4
34625  45       IFLOW(I) = 1
34626           SPNCFC(1,1,1) = ONE/THREE
34627 C-- -ve chargino antilepton
34628         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
34629 C--change order if antiparticle first
34630           IF(IDHEP(LHEP).LT.0) THEN
34631             ID   = LHEP
34632             LHEP = MHEP
34633             MHEP = ID
34634           ENDIF
34635 C--indices for RPV
34636           III = (IJ-125)/2
34637           JJJ = (IDHW(LHEP)+1)/2
34638           KKK = (IDHW(MHEP)-5)/2
34639           L1 = IK-455
34640           IDP(5) = 424+2*III
34641           DO 46 I=1,2
34642  46       IDP(5+I) = 400+2*JJJ+(I-1)*12
34643 C--types of diagram
34644           DRTYPE(1) = 21
34645           DRTYPE(2) = 22
34646           DRTYPE(3) = 22
34647 C--RPV couplings
34648           A(1,1) = 0.0D0
34649           A(2,1) =-LAMDA2(III,JJJ,KKK)
34650           DO 47 I=1,2
34651           B(1,I+1) = 0.0D0
34652  47       B(2,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
34653 C--MSSM couplings
34654           DO 48 J=1,2
34655           B(J,1) = AFC(O(J),2*III+6,1,L1)
34656           DO 48 I=1,2
34657  48       A(J,I+1) = AFC(O(J),2*JJJ,I,L1)
34658 C--colour flows
34659           NDIA = 3
34660           NCFL(1) = 1
34661           DO 49 I=1,3
34662  49       IFLOW(I) = 1
34663           SPNCFC(1,1,1) = ONE/THREE
34664 C-- +ve chargino lepton
34665         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
34666 C--change order if antiparticle first
34667           IF(IDHEP(LHEP).LT.0) THEN
34668             ID   = LHEP
34669             LHEP = MHEP
34670             MHEP = ID
34671           ENDIF
34672 C--indices for RPV
34673           III = (IJ-119)/2
34674           JJJ = (IDHW(MHEP)-5)/2
34675           KKK = (IDHW(LHEP)+1)/2
34676           L1 = IK-453
34677           IDP(5) = 424+2*III
34678           DO 50 I=1,2
34679  50       IDP(5+I) = 400+2*JJJ+(I-1)*12
34680 C--types of diagram
34681           DRTYPE(1) = 24
34682           DRTYPE(2) = 25
34683           DRTYPE(3) = 25
34684 C--RPV couplings
34685           A(1,1) =-LAMDA2(III,JJJ,KKK)
34686           A(2,1) = 0.0D0
34687           DO 51 I=1,2
34688           B(1,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
34689  51       B(2,I+1) = 0.0D0
34690 C--MSSM couplings
34691           DO 52 J=1,2
34692           B(J,1) = AFC(J,2*III+6,1,L1)
34693           DO 52 I=1,2
34694  52       A(J,I+1) = AFC(J,2*JJJ,I,L1)
34695 C--colour flows
34696           NDIA = 3
34697           NCFL(1) = 1
34698           DO 53 I=1,3
34699  53       IFLOW(I) = 1
34700           SPNCFC(1,1,1) = ONE/THREE
34701 C--d dbar d dbar
34702         ELSEIF(IK.LE.12.AND.IJ.LE.12.AND.
34703      &         MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
34704 C--can't produce unstable quark (on hadronization timescale)
34705           RETURN
34706 C--u    dbar --> u    dbar
34707         ELSEIF((IJ.LE. 6.AND.MOD(IJ,2).EQ.0.AND.
34708      &          IK.LE.12.AND.MOD(IK,2).EQ.1).OR.
34709      &         (IK.LE.6 .AND.MOD(IK,2).EQ.0.AND.
34710      &          IJ.LE.12.AND.MOD(IJ,2).EQ.1)) THEN
34711 C--ensure u first (incoming)
34712           IF(MOD(IDHW(LHEP),2).EQ.1) THEN
34713             ID   = MHEP
34714             MHEP = LHEP
34715             LHEP = ID
34716           ENDIF
34717 C--ensure u first (outgoing)
34718           IF(MOD(IK,2).EQ.1) THEN
34719             ID = IJ
34720             IJ = IK
34721             IK = ID
34722             ID = JHEP
34723             JHEP = KHEP
34724             KHEP = ID
34725           ENDIF
34726 C--can't produce unstable quark (on hadronization timescale)
34727           IF(IK.NE.6) RETURN
34728 C--RPV indices
34729           JJJ = IDHW(LHEP)/2
34730           KKK = (IDHW(MHEP)-5)/2
34731           LLL = IK/2
34732           MMM = (IJ-5)/2
34733           NDIA = 0
34734           DO 54 III=1,3
34735           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
34736      &            GOTO 54
34737           DO 55 J=1,2
34738           IFLOW(NDIA+J) = 1
34739           IDP(4+NDIA+J) = 423+2*III+12*(J-1)
34740           A(1,NDIA+J) = ZERO
34741           A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
34742           B(1,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
34743           B(2,NDIA+J) = ZERO
34744  55       DRTYPE(NDIA+J) = 21
34745           NDIA = NDIA+2
34746  54       CONTINUE
34747           NCFL(1) = 1
34748           SPNCFC(1,1,1) = ONE
34749 C--ubar d    --> ubar d
34750         ELSEIF((IJ.LE.12.AND.MOD(IJ,2).EQ.0.AND.
34751      &          IK.LE. 6.AND.MOD(IK,2).EQ.1).OR.
34752      &         (IK.LE.12.AND.MOD(IK,2).EQ.0.AND.
34753      &          IJ.LE. 6.AND.MOD(IJ,2).EQ.1)) THEN
34754 C--ensure d first (incoming)
34755           IF(MOD(IDHW(LHEP),2).EQ.0) THEN
34756             ID   = MHEP
34757             MHEP = LHEP
34758             LHEP = ID
34759           ENDIF
34760 C--ensure d first (outgoing)
34761           IF(MOD(IK,2).EQ.0) THEN
34762             ID = IJ
34763             IJ = IK
34764             IK = ID
34765             ID = JHEP
34766             JHEP = KHEP
34767             KHEP = ID
34768           ENDIF
34769 C--can't produce unstable quark (on hadronization timescale)
34770           IF(IJ.NE.12) RETURN
34771 C--RPV indices
34772           JJJ = (IDHW(MHEP)-6)/2
34773           KKK = (IDHW(LHEP)+1)/2
34774           LLL = (IJ-6)/2
34775           MMM = (IK+1)/2
34776           NDIA = 0
34777           DO 56 III=1,3
34778           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
34779      &             GOTO 56
34780           DO 57 J=1,2
34781           IFLOW(NDIA+J) = 1
34782           IDP(4+NDIA+J) = 423+2*III+12*(J-1)
34783           A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
34784           A(2,NDIA+J) = ZERO
34785           B(1,NDIA+J) = ZERO
34786           B(2,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
34787  57       DRTYPE(NDIA+J) = 21
34788           NDIA = NDIA+2
34789  56       CONTINUE
34790           NCFL(1) = 1
34791           SPNCFC(1,1,1) = ONE
34792 C--d dbar --> ell- ell+
34793         ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
34794      &         IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
34795      &         IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
34796      &         IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
34797 C--change outgoing order
34798           ID = IK
34799           IK = IJ
34800           IJ = ID
34801           ID = JHEP
34802           JHEP = KHEP
34803           KHEP = ID
34804 C--change order if dbar first
34805           IF(IDHEP(LHEP).LT.0) THEN
34806             ID = LHEP
34807             LHEP = MHEP
34808             MHEP = ID
34809           ENDIF
34810 C--don't do correlations if no taus
34811           IF(IK.NE.125.AND.IJ.NE.131) RETURN
34812 C--RPV couplings
34813           JJJ = (IDHW(LHEP)+1)/2
34814           KKK = (IDHW(MHEP)-5)/2
34815           LLL = (IK-119)/2
34816           MMM = (IJ-125)/2
34817           NDIA = 0
34818           DO 58 III=1,3
34819           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
34820      &             GOTO 58
34821           NDIA = NDIA+1
34822           IFLOW(NDIA) = 1
34823           IDP(4+NDIA) = 424+2*III
34824           A(1,NDIA) = ZERO
34825           A(2,NDIA) = LAMDA2(III,JJJ,KKK)
34826           B(1,NDIA) = LAMDA1(III,LLL,MMM)
34827           B(2,NDIA) = ZERO
34828           DRTYPE(NDIA) = 21
34829  58       CONTINUE
34830           NCFL(1) = 1
34831           SPNCFC(1,1,1) = ONE/THREE
34832 C--dbar d --> ell+ ell-
34833         ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
34834      &         IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
34835      &         IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
34836      &         IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
34837 C--change order if dbar first
34838           IF(IDHEP(LHEP).LT.0) THEN
34839             ID = LHEP
34840             LHEP = MHEP
34841             MHEP = ID
34842           ENDIF
34843 C--don't do correlations if no taus
34844           IF(IK.NE.125.AND.IJ.NE.131) RETURN
34845 C--RPV couplings
34846           JJJ = (IDHW(MHEP)-5)/2
34847           KKK = (IDHW(LHEP)+1)/2
34848           LLL = (IJ-125)/2
34849           MMM = (IK-119)/2
34850           NDIA = 0
34851           DO 59 III=1,3
34852           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
34853      &             GOTO 59
34854           NDIA = NDIA+1
34855           IFLOW(NDIA) = 1
34856           IDP(4+NDIA) = 424+2*III
34857           A(1,NDIA) = LAMDA2(III,JJJ,KKK)
34858           A(2,NDIA) = ZERO
34859           B(1,NDIA) = ZERO
34860           B(2,NDIA) = LAMDA1(III,LLL,MMM)
34861           DRTYPE(NDIA) = 21
34862  59       CONTINUE
34863           NCFL(1) = 1
34864           SPNCFC(1,1,1) = ONE/THREE
34865 C--u dbar --> nu ell+
34866         ELSEIF((IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.0.AND.
34867      &          IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1).OR.
34868      &         (IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
34869      &          IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0)) THEN
34870 C--ensure u first
34871           IF(MOD(IDHW(LHEP),2).NE.0) THEN
34872             ID = LHEP
34873             LHEP = MHEP
34874             MHEP = ID
34875           ENDIF
34876 C--ensure nu first
34877           IF(MOD(IK,2).NE.0) THEN
34878             ID = IK
34879             IK = IJ
34880             IJ = ID
34881             ID = JHEP
34882             JHEP = KHEP
34883             KHEP = ID
34884           ENDIF
34885 C--only need correlations if tau
34886           IF(IJ.NE.131) RETURN
34887 C--RPV couplings
34888           JJJ = IDHW(LHEP)/2
34889           KKK = (IDHW(MHEP)-5)/2
34890           LLL = (IK-120)/2
34891           MMM = (IJ-125)/2
34892           NDIA = 0
34893           DO 60 III=1,3
34894           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
34895      &             GOTO 60
34896           DO 61 J=1,2
34897           IFLOW(NDIA+J) = 1
34898           IDP(4+NDIA+J) = 423+2*III+12*(J-1)
34899           A(1,NDIA+J) = ZERO
34900           A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
34901           B(1,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
34902           B(2,NDIA+J) = ZERO
34903  61       DRTYPE(NDIA+J) = 21
34904           NDIA = NDIA+2
34905  60       CONTINUE
34906           NCFL(1) = 1
34907           SPNCFC(1,1,1) = ONE/THREE
34908 C--ubar d --> ell nubar
34909         ELSEIF((IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.0.AND.
34910      &          IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1).OR.
34911      &         (IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
34912      &          IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0)) THEN
34913 C--ensure u second
34914           IF(MOD(IDHW(MHEP),2).NE.0) THEN
34915             ID = LHEP
34916             LHEP = MHEP
34917             MHEP = ID
34918           ENDIF
34919 C--   ensure nu second
34920           IF(MOD(IJ,2).NE.0) THEN
34921             ID = IK
34922             IK = IJ
34923             IJ = ID
34924             ID = JHEP
34925             JHEP = KHEP
34926             KHEP = ID
34927           ENDIF
34928 C--only need correlations if tau
34929           IF(IK.NE.125) RETURN
34930 C--RPV couplings
34931           JJJ = (IDHW(MHEP)-6)/2
34932           KKK = (IDHW(LHEP)+1)/2
34933           LLL = (IJ-126)/2
34934           MMM = (IK-119)/2
34935           NDIA = 0
34936           DO 62 III=1,3
34937           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
34938      &             GOTO 62
34939           DO 63 J=1,2
34940           IFLOW(NDIA+J) = 1
34941           IDP(4+NDIA+J) = 423+2*III+12*(J-1)
34942           A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
34943           A(2,NDIA+J) = ZERO
34944           B(1,NDIA+J) = ZERO
34945           B(2,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
34946  63       DRTYPE(NDIA+J) = 21
34947           NDIA = NDIA+2
34948  62       CONTINUE
34949           NCFL(1) = 1
34950           SPNCFC(1,1,1) = ONE/THREE
34951 C--unrecognized process
34952         ELSE
34953           CALL HWWARN('HWHSPN',505)
34954         ENDIF
34955 C--UDD processes
34956       ELSEIF(IPRO.EQ.41) THEN
34957 C--change outgoing order
34958         ID = IJ
34959         IJ = IK
34960         IK = ID
34961         ID = JHEP
34962         JHEP = KHEP
34963         KHEP = ID
34964 C--ubar neutralino
34965         IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
34966      &     IDPDG(IJ).LT.0) THEN
34967 C--indices for RPV
34968           III = (IJ-6)/2
34969           JJJ = (IDHW(LHEP)+1)/2
34970           KKK = (IDHW(MHEP)+1)/2
34971           L1  = IK - 449
34972 C--types of diagram
34973           DRTYPE(1) = 27
34974           DRTYPE(2) = 27
34975           DRTYPE(3) = 28
34976           DRTYPE(4) = 28
34977           DRTYPE(5) = 29
34978           DRTYPE(6) = 29
34979 C--RPV couplings
34980           DO 64 J=1,2
34981           A(1,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
34982           A(2,J  ) = ZERO
34983           B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
34984           B(2,J+2) = ZERO
34985           A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
34986           A(2,J+4) = ZERO
34987 C--particles
34988           IDP(4+J) = 400+2*III+12*(J-1)
34989           IDP(6+J) = 399+2*JJJ+12*(J-1)
34990           IDP(8+J) = 399+2*KKK+12*(J-1)
34991 C--MSSM couplings
34992           DO 64 I=1,2
34993           B(I,J)   = AFN(O(I),2*III,J,L1)
34994           A(I,J+2) = AFN(O(I),2*JJJ-1,J,L1)
34995  64       B(I,J+4) = AFN(O(I),2*KKK-1,J,L1)
34996 C--colour flows
34997           NDIA = 6
34998           NCFL(1) = 1
34999           DO 65 I=1,6
35000  65       IFLOW(I) = 1
35001           SPNCFC(1,1,1) = TWO/THREE
35002 C--u    neutralino
35003         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
35004      &         IDPDG(IJ).GT.0) THEN
35005 C--indices for RPV
35006           III = IJ/2
35007           JJJ = (IDHW(LHEP)-5)/2
35008           KKK = (IDHW(MHEP)-5)/2
35009           L1  = IK - 449
35010 C--types of diagram
35011           DRTYPE(1) = 30
35012           DRTYPE(2) = 30
35013           DRTYPE(3) = 31
35014           DRTYPE(4) = 31
35015           DRTYPE(5) = 32
35016           DRTYPE(6) = 32
35017 C--RPV couplings
35018           DO 66 J=1,2
35019           A(1,J  ) = ZERO
35020           A(2,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
35021           B(1,J+2) = ZERO
35022           B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
35023           A(1,J+4) = ZERO
35024           A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
35025 C--particles
35026           IDP(4+J) = 400+2*III+12*(J-1)
35027           IDP(6+J) = 399+2*JJJ+12*(J-1)
35028           IDP(8+J) = 399+2*KKK+12*(J-1)
35029 C--MSSM couplings
35030           DO 66 I=1,2
35031           B(I,J)   = AFN(I,2*III,J,L1)
35032           A(I,J+2) = AFN(I,2*JJJ-1,J,L1)
35033  66       B(I,J+4) = AFN(I,2*KKK-1,J,L1)
35034 C--colour flows
35035           NDIA = 6
35036           NCFL(1) = 1
35037           DO 67 I=1,6
35038  67       IFLOW(I) = 1
35039           SPNCFC(1,1,1) = TWO/THREE
35040 C--dbar neutralino
35041         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
35042      &         IDPDG(IJ).LT.0) THEN
35043 C--ensure u type first
35044           IF(MOD(IDHW(LHEP),2).NE.0) THEN
35045             ID   = LHEP
35046             LHEP = MHEP
35047             MHEP = ID
35048           ENDIF
35049 C--RPV indices
35050           III = IDHW(LHEP)/2
35051           JJJ = (IDHW(MHEP)+1)/2
35052           KKK = (IJ-5)/2
35053           L1  = IK - 449
35054 C--types of diagram
35055           DRTYPE(1) = 27
35056           DRTYPE(2) = 27
35057           DRTYPE(3) = 28
35058           DRTYPE(4) = 28
35059           DRTYPE(5) = 29
35060           DRTYPE(6) = 29
35061 C--RPV couplings
35062           DO 68 I=1,2
35063           A(1,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35064           A(2,I  ) = ZERO
35065           B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35066           B(2,I+2) = ZERO
35067           A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
35068           A(2,I+4) = ZERO
35069 C--particles
35070           IDP(4+I) = 399+2*KKK+12*(I-1)
35071           IDP(6+I) = 400+2*III+12*(I-1)
35072           IDP(8+I) = 399+2*JJJ+12*(I-1)
35073 C--MSSM couplings
35074           DO 68 J=1,2
35075           B(J,I  ) = AFN(O(J),2*KKK-1,I,L1)
35076           A(J,I+2) = AFN(O(J),2*III  ,I,L1)
35077  68       B(J,I+4) = AFN(O(J),2*JJJ-1,I,L1)
35078 C--colour flows
35079           NDIA = 6
35080           NCFL(1) = 1
35081           DO 69 I=1,6
35082  69       IFLOW(I) = 1
35083           SPNCFC(1,1,1) = TWO/THREE
35084 C--d    neutralino
35085         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
35086      &         IDPDG(IJ).GT.0) THEN
35087 C--ensure u type first
35088           IF(MOD(IDHW(LHEP),2).NE.0) THEN
35089             ID   = LHEP
35090             LHEP = MHEP
35091             MHEP = ID
35092           ENDIF
35093 C--RPV indices
35094           III = (IDHW(LHEP)-6)/2
35095           JJJ = (IDHW(MHEP)-5)/2
35096           KKK = (IJ+1)/2
35097           L1  = IK - 449
35098 C--types of diagram
35099           DRTYPE(1) = 30
35100           DRTYPE(2) = 30
35101           DRTYPE(3) = 31
35102           DRTYPE(4) = 31
35103           DRTYPE(5) = 32
35104           DRTYPE(6) = 32
35105 C--RPV couplings
35106           DO 70 I=1,2
35107           A(1,I  ) = ZERO
35108           A(2,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35109           B(1,I+2) = ZERO
35110           B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35111           A(1,I+4) = ZERO
35112           A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
35113 C--particles
35114           IDP(4+I) = 399+2*KKK+12*(I-1)
35115           IDP(6+I) = 400+2*III+12*(I-1)
35116           IDP(8+I) = 399+2*JJJ+12*(I-1)
35117 C--MSSM couplings
35118           DO 70 J=1,2
35119           B(J,I  ) = AFN(J,2*KKK-1,I,L1)
35120           A(J,I+2) = AFN(J,2*III  ,I,L1)
35121  70       B(J,I+4) = AFN(J,2*JJJ-1,I,L1)
35122 C--colour flows
35123           NDIA = 6
35124           NCFL(1) = 1
35125           DO 71 I=1,6
35126  71       IFLOW(I) = 1
35127           SPNCFC(1,1,1) = TWO/THREE
35128 C--ubar gluino
35129         ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).LT.0) THEN
35130 C--indices for RPV
35131           III = (IJ-6)/2
35132           JJJ = (IDHW(LHEP)+1)/2
35133           KKK = (IDHW(MHEP)+1)/2
35134 C--types of diagram
35135           DRTYPE(1) = 27
35136           DRTYPE(2) = 27
35137           DRTYPE(3) = 28
35138           DRTYPE(4) = 28
35139           DRTYPE(5) = 29
35140           DRTYPE(6) = 29
35141 C--RPV couplings
35142           DO 72 J=1,2
35143           A(1,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
35144           A(2,J  ) = ZERO
35145           B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
35146           B(2,J+2) = ZERO
35147           A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
35148           A(2,J+4) = ZERO
35149 C--particles
35150           IDP(4+J) = 400+2*III+12*(J-1)
35151           IDP(6+J) = 399+2*JJJ+12*(J-1)
35152           IDP(8+J) = 399+2*KKK+12*(J-1)
35153 C--MSSM couplings
35154           DO 72 I=1,2
35155           B(I,J)   = AFG(O(I),2*III,J)
35156           A(I,J+2) = AFG(O(I),2*JJJ-1,J)
35157  72       B(I,J+4) = AFG(O(I),2*KKK-1,J)
35158 C--colour flows
35159           NDIA = 6
35160           NCFL(1) = 3
35161           DO 73 I=1,2
35162           IFLOW(I  ) = 1
35163           IFLOW(I+2) = 2
35164  73       IFLOW(I+4) = 3
35165           DO 74 I=1,3
35166           DO 74 J=1,3
35167           IF(I.EQ.J) THEN
35168             SPNCFC(I,J,1) = 8.0D0/9.0D0
35169           ELSE
35170             SPNCFC(I,J,1) =-4.0D0/9.0D0
35171           ENDIF
35172  74       CONTINUE
35173 C--u    gluino
35174         ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).GT.0) THEN
35175 C--indices for RPV
35176           III = IJ/2
35177           JJJ = (IDHW(LHEP)-5)/2
35178           KKK = (IDHW(MHEP)-5)/2
35179 C--types of diagram
35180           DRTYPE(1) = 30
35181           DRTYPE(2) = 30
35182           DRTYPE(3) = 31
35183           DRTYPE(4) = 31
35184           DRTYPE(5) = 32
35185           DRTYPE(6) = 32
35186 C--RPV couplings
35187           DO 75 J=1,2
35188           A(1,J  ) = ZERO
35189           A(2,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
35190           B(1,J+2) = ZERO
35191           B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
35192           A(1,J+4) = ZERO
35193           A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
35194 C--particles
35195           IDP(4+J) = 400+2*III+12*(J-1)
35196           IDP(6+J) = 399+2*JJJ+12*(J-1)
35197           IDP(8+J) = 399+2*KKK+12*(J-1)
35198 C--MSSM couplings
35199           DO 75 I=1,2
35200           B(I,J)   = AFG(I,2*III,J)
35201           A(I,J+2) = AFG(I,2*JJJ-1,J)
35202  75       B(I,J+4) = AFG(I,2*KKK-1,J)
35203 C--colour flows
35204           NDIA = 6
35205           NCFL(1) = 3
35206           DO 76 I=1,2
35207           IFLOW(I  ) = 1
35208           IFLOW(I+2) = 2
35209  76       IFLOW(I+4) = 3
35210           DO 77 I=1,3
35211           DO 77 J=1,3
35212           IF(I.EQ.J) THEN
35213             SPNCFC(I,J,1) = 8.0D0/9.0D0
35214           ELSE
35215             SPNCFC(I,J,1) =-4.0D0/9.0D0
35216           ENDIF
35217  77       CONTINUE
35218 C--dbar gluino
35219         ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).LT.0) THEN
35220 C--ensure u type first
35221           IF(MOD(IDHW(LHEP),2).NE.0) THEN
35222             ID   = LHEP
35223             LHEP = MHEP
35224             MHEP = ID
35225           ENDIF
35226 C--RPV indices
35227           III = IDHW(LHEP)/2
35228           JJJ = (IDHW(MHEP)+1)/2
35229           KKK = (IJ-5)/2
35230 C--types of diagram
35231           DRTYPE(1) = 27
35232           DRTYPE(2) = 27
35233           DRTYPE(3) = 28
35234           DRTYPE(4) = 28
35235           DRTYPE(5) = 29
35236           DRTYPE(6) = 29
35237 C--RPV couplings
35238           DO 78 I=1,2
35239           A(1,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35240           A(2,I  ) = ZERO
35241           B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35242           B(2,I+2) = ZERO
35243           A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
35244           A(2,I+4) = ZERO
35245 C--particles
35246           IDP(4+I) = 399+2*KKK+12*(I-1)
35247           IDP(6+I) = 400+2*III+12*(I-1)
35248           IDP(8+I) = 399+2*JJJ+12*(I-1)
35249 C--MSSM couplings
35250           DO 78 J=1,2
35251           B(J,I  ) = AFG(O(J),2*KKK-1,I)
35252           A(J,I+2) = AFG(O(J),2*III  ,I)
35253  78       B(J,I+4) = AFG(O(J),2*JJJ-1,I)
35254 C--colour flows
35255           NDIA = 6
35256           NCFL(1) = 3
35257           DO 79 I=1,2
35258           IFLOW(I  ) = 1
35259           IFLOW(I+2) = 2
35260  79       IFLOW(I+4) = 3
35261           DO 80 I=1,3
35262           DO 80 J=1,3
35263           IF(I.EQ.J) THEN
35264             SPNCFC(I,J,1) = 8.0D0/9.0D0
35265           ELSE
35266             SPNCFC(I,J,1) =-4.0D0/9.0D0
35267           ENDIF
35268  80       CONTINUE
35269 C--d    gluino
35270         ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).GT.0) THEN
35271 C--ensure u type first
35272           IF(MOD(IDHW(LHEP),2).NE.0) THEN
35273             ID   = LHEP
35274             LHEP = MHEP
35275             MHEP = ID
35276           ENDIF
35277 C--RPV indices
35278           III = (IDHW(LHEP)-6)/2
35279           JJJ = (IDHW(MHEP)-5)/2
35280           KKK = (IJ+1)/2
35281 C--types of diagram
35282           DRTYPE(1) = 30
35283           DRTYPE(2) = 30
35284           DRTYPE(3) = 31
35285           DRTYPE(4) = 31
35286           DRTYPE(5) = 32
35287           DRTYPE(6) = 32
35288 C--RPV couplings
35289           DO 81 I=1,2
35290           A(1,I  ) = ZERO
35291           A(2,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35292           B(1,I+2) = ZERO
35293           B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35294           A(1,I+4) = ZERO
35295           A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
35296 C--particles
35297           IDP(4+I) = 399+2*KKK+12*(I-1)
35298           IDP(6+I) = 400+2*III+12*(I-1)
35299           IDP(8+I) = 399+2*JJJ+12*(I-1)
35300 C--MSSM couplings
35301           DO 81 J=1,2
35302           B(J,I  ) = AFG(J,2*KKK-1,I)
35303           A(J,I+2) = AFG(J,2*III  ,I)
35304  81       B(J,I+4) = AFG(J,2*JJJ-1,I)
35305 C--colour flows
35306           NDIA = 6
35307           NCFL(1) = 3
35308           DO 82 I=1,2
35309           IFLOW(I  ) = 1
35310           IFLOW(I+2) = 2
35311  82       IFLOW(I+4) = 3
35312           DO 83 I=1,3
35313           DO 83 J=1,3
35314           IF(I.EQ.J) THEN
35315             SPNCFC(I,J,1) = 8.0D0/9.0D0
35316           ELSE
35317             SPNCFC(I,J,1) =-4.0D0/9.0D0
35318           ENDIF
35319  83       CONTINUE
35320 C--dbar -ve chargino
35321         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
35322 C--change order so highest generation first
35323           IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
35324             ID = MHEP
35325             MHEP = LHEP
35326             LHEP = ID
35327           ENDIF
35328 C--RPV indices
35329           III = (IJ-5)/2
35330           JJJ = (IDHW(LHEP)+1)/2
35331           KKK = (IDHW(MHEP)+1)/2
35332           L1  = IK-455
35333 C--types of diagram
35334           DRTYPE(1) = 27
35335           DRTYPE(2) = 27
35336           DRTYPE(3) = 28
35337           DRTYPE(4) = 28
35338           DRTYPE(5) = 29
35339           DRTYPE(6) = 29
35340 C--RPV couplings
35341           DO 84 I=1,2
35342           A(1,I  ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35343           A(2,I  ) = ZERO
35344           B(1,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
35345           B(2,I+2) = ZERO
35346           A(1,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
35347           A(2,I+4) = ZERO
35348 C--particles
35349           IDP(4+I) = 400+2*III+12*(I-1)
35350           IDP(6+I) = 400+2*JJJ+12*(I-1)
35351           IDP(8+I) = 400+2*KKK+12*(I-1)
35352 C--MSSM couplings
35353           DO 84 J=1,2
35354           B(J,I  ) = AFC(O(J),2*III,I,L1)
35355           A(J,I+2) = AFC(O(J),2*JJJ,I,L1)
35356  84       B(J,I+4) = AFC(O(J),2*KKK,I,L1)
35357 C--colour flows
35358           NDIA = 6
35359           NCFL(1) = 1
35360           DO 85 I=1,6
35361  85       IFLOW(I) = 1
35362           SPNCFC(1,1,1) = TWO/THREE
35363 C--d    +ve chargino
35364         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
35365 C--change order so highest generation first
35366           IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
35367             ID = MHEP
35368             MHEP = LHEP
35369             LHEP = ID
35370           ENDIF
35371 C--RPV indices
35372           III = (IJ+1)/2
35373           JJJ = (IDHW(LHEP)-5)/2
35374           KKK = (IDHW(MHEP)-5)/2
35375           L1  = IK-453
35376 C--types of diagram
35377           DRTYPE(1) = 30
35378           DRTYPE(2) = 30
35379           DRTYPE(3) = 31
35380           DRTYPE(4) = 31
35381           DRTYPE(5) = 32
35382           DRTYPE(6) = 32
35383 C--RPV couplings
35384           DO 86 I=1,2
35385           A(1,I  ) = ZERO
35386           A(2,I  ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35387           B(1,I+2) = ZERO
35388           B(2,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
35389           A(1,I+4) = ZERO
35390           A(2,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
35391 C--particles
35392           IDP(4+I) = 400+2*III+12*(I-1)
35393           IDP(6+I) = 400+2*JJJ+12*(I-1)
35394           IDP(8+I) = 400+2*KKK+12*(I-1)
35395 C--MSSM couplings
35396           DO 86 J=1,2
35397           B(J,I  ) = AFC(J,2*III,I,L1)
35398           A(J,I+2) = AFC(J,2*JJJ,I,L1)
35399  86       B(J,I+4) = AFC(J,2*KKK,I,L1)
35400 C--colour flows
35401           NDIA = 6
35402           NCFL(1) = 1
35403           DO 87 I=1,6
35404  87       IFLOW(I) = 1
35405           SPNCFC(1,1,1) = TWO/THREE
35406 C--ubar +ve chargino
35407         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
35408 C--ensure u type first
35409           IF(MOD(IDHW(LHEP),2).NE.0) THEN
35410             ID   = LHEP
35411             LHEP = MHEP
35412             MHEP = ID
35413           ENDIF
35414 C--RPV indices
35415           III = IDHW(LHEP)/2
35416           JJJ = (IDHW(MHEP)+1)/2
35417           KKK = (IJ-6)/2
35418           L1  = IK-453
35419 C--types of diagram
35420           DRTYPE(1) = 27
35421           DRTYPE(2) = 27
35422           DRTYPE(3) = 28
35423           DRTYPE(4) = 28
35424 C--RPV couplings
35425           DO 88 I=1,2
35426           A(1,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35427           A(2,I  ) = ZERO
35428           B(1,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
35429           B(2,I+2) = ZERO
35430 C--particles
35431           IDP(4+I) = 399+2*KKK+12*(I-1)
35432           IDP(6+I) = 399+2*III+12*(I-1)
35433 C--MSSM couplings
35434           DO 88 J=1,2
35435           B(J,I  ) = AFC(O(J),2*KKK-1,I,L1)
35436  88       A(J,I+2) = AFC(O(J),2*III-1,I,L1)
35437 C--colour flows
35438           NDIA = 4
35439           NCFL(1) = 1
35440           DO 89 I=1,4
35441  89       IFLOW(I) = 1
35442           SPNCFC(1,1,1) = TWO/THREE
35443 C--u    -ve chargino
35444         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
35445 C--ensure u type first
35446           IF(MOD(IDHW(LHEP),2).NE.0) THEN
35447             ID   = LHEP
35448             LHEP = MHEP
35449             MHEP = ID
35450           ENDIF
35451 C--RPV indices
35452           III = (IDHW(LHEP)-6)/2
35453           JJJ = (IDHW(MHEP)-5)/2
35454           KKK = IJ/2
35455           L1  = IK-455
35456 C--types of diagram
35457           DRTYPE(1) = 30
35458           DRTYPE(2) = 30
35459           DRTYPE(3) = 31
35460           DRTYPE(4) = 31
35461 C--RPV couplings
35462           DO 90 I=1,2
35463           A(1,I  ) = ZERO
35464           A(2,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35465           B(1,I+2) = ZERO
35466           B(2,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
35467 C--particles
35468           IDP(4+I) = 399+2*KKK+12*(I-1)
35469           IDP(6+I) = 399+2*III+12*(I-1)
35470 C--MSSM couplings
35471           DO 90 J=1,2
35472           B(J,I  ) = AFC(J,2*KKK-1,I,L1)
35473  90       A(J,I+2) = AFC(J,2*III-1,I,L1)
35474 C--colour flows
35475           NDIA = 4
35476           NCFL(1) = 1
35477           DO 91 I=1,4
35478  91       IFLOW(I) = 1
35479           SPNCFC(1,1,1) = TWO/THREE
35480 C--d d --> d d
35481         ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IK).GT.0.AND.
35482      &         MOD(IK,2).EQ.1.AND.MOD(IJ,2).EQ.1) THEN
35483 C--can't produce unstable quark on hadronisation timescale
35484           RETURN
35485 C--dbar dbar --> dbar dbar
35486         ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
35487      &         MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
35488 C--can't produce unstable quark on hadronisation timescale
35489           RETURN
35490 C--u d --> u d
35491         ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IJ).GT.0.AND.
35492      &         ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
35493      &          (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
35494 C--ensure u first (incoming)
35495           IF(MOD(IDHW(LHEP),2).EQ.1) THEN
35496             ID   = MHEP
35497             MHEP = LHEP
35498             LHEP = ID
35499           ENDIF
35500 C--ensure u first (outgoing)
35501           IF(MOD(IK,2).EQ.1) THEN
35502             ID = IJ
35503             IJ = IK
35504             IK = ID
35505             ID = JHEP
35506             JHEP = KHEP
35507             KHEP = ID
35508           ENDIF
35509 C--can't produce unstable quark on hadronisation timescale
35510           IF(IK.NE.6) RETURN
35511 C--RPV indices
35512           III = IDHW(LHEP)/2
35513           KKK = (IDHW(MHEP)+1)/2
35514           LLL = IK/2
35515           MMM = (IJ+1)/2
35516           NDIA = 0
35517           DO 92 JJJ=1,3
35518           IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
35519      &            GOTO 92
35520           DO 93 J=1,2
35521           IFLOW(NDIA+J) = 1
35522           IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
35523           A(1,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
35524           A(2,NDIA+J) = ZERO
35525           B(1,NDIA+J) = ZERO
35526           B(2,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
35527  93       DRTYPE(NDIA+J) = 33
35528           NDIA = NDIA+2
35529  92       CONTINUE
35530           NCFL(1) = 1
35531           SPNCFC(1,1,1) = ONE/THREE
35532 C--ubar dbar --> ubar dbar
35533         ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
35534      &         ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
35535      &          (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
35536 C--ensure u first (incoming)
35537           IF(MOD(IDHW(LHEP),2).EQ.1) THEN
35538             ID   = MHEP
35539             MHEP = LHEP
35540             LHEP = ID
35541           ENDIF
35542 C--ensure u first (outgoing)
35543           IF(MOD(IK,2).EQ.1) THEN
35544             ID = IJ
35545             IJ = IK
35546             IK = ID
35547             ID = JHEP
35548             JHEP = KHEP
35549             KHEP = ID
35550           ENDIF
35551 C--can't produce unstable quark on hadronisation timescale
35552           IF(IK.NE.6) RETURN
35553 C--RPV indices
35554           III = (IDHW(LHEP)-6)/2
35555           KKK = (IDHW(MHEP)-5)/2
35556           LLL = (IK-6)/2
35557           MMM = (IJ-5)/2
35558           NDIA = 0
35559           DO 94 JJJ=1,3
35560           IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
35561      &             GOTO 94
35562           DO 95 J=1,2
35563           IFLOW(NDIA+J) = 1
35564           IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
35565           A(1,NDIA+J) = ZERO
35566           A(2,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
35567           B(1,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
35568           B(2,NDIA+J) = ZERO
35569  95       DRTYPE(NDIA+J) = 34
35570           NDIA = NDIA+2
35571  94       CONTINUE
35572           NCFL(1) = 1
35573           SPNCFC(1,1,1) = ONE/THREE
35574 C--unrecognized process
35575         ELSE
35576           CALL HWWARN('HWHSPN',506)
35577         ENDIF
35578 C--unrecognized process
35579       ELSE
35580         CALL HWWARN('HWHSPN',507)
35581       ENDIF
35582 C--copy the momenta into the internal array
35583       CALL HWVEQU(5,PHEP(1,LHEP),P(1,1))
35584       CALL HWVEQU(5,PHEP(1,MHEP),P(1,2))
35585       CALL HWVEQU(5,PHEP(1,KHEP),P(1,3))
35586       CALL HWVEQU(5,PHEP(1,JHEP),P(1,4))
35587 C--now compute the masses etc for the diagrams
35588       IDP(1) = IDHW(LHEP)
35589       IDP(2) = IDHW(MHEP)
35590       IDP(3) = IDHW(KHEP)
35591       IDP(4) = IDHW(JHEP)
35592       DO 104 I=1,4
35593       MA (I) = P(5,I)
35594  104  MA2(I) = SIGN(MA(I)**2,MA(I))
35595       DO 105 I=1,NDIA
35596       MR(I) = RMASS(IDP(4+I))
35597       MS(I) = MR(I)**2
35598       IF(IDP(I+4).EQ.200) THEN
35599         MWD(I) = RMASS(200)*GAMZ
35600       ELSEIF(IDP(I+4).EQ.198.OR.IDP(I+4).EQ.199) THEN
35601         MWD(I) = RMASS(198)*GAMW
35602       ELSEIF(IDP(I+4).EQ.59.OR.IDP(I+4).EQ.13.OR.
35603      &  IDP(I+4).LE.5.OR.(IDP(I+4).GE.7.AND.IDP(I+4).LE.11)) THEN
35604         MR(I)  = ZERO
35605         MS(I)  = ZERO
35606         MWD(I) = ZERO
35607       ELSE
35608         MWD(I) = MR(I)*HBAR/RLTIM(IDP(I+4))
35609       ENDIF
35610  105  CONTINUE
35611 C--set up the mandelstam variables
35612       SH = TWO*HWULDO(P(1,1),P(1,2))
35613       CALL HWVSCA(4,-ONE,P(1,3),PLAB(1,2))
35614       CALL HWVSUM(5,P(1,1),PLAB(1,2),PLAB(1,1))
35615       TH = P(5,3)**2-TWO*HWULDO(P(1,1),P(1,3))
35616       UH = P(5,4)**2-TWO*HWULDO(P(1,1),P(1,4))
35617 C--copy the momenta into the common block for spinor computation
35618       DO 106 I=1,4
35619       IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
35620      &                .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
35621         CALL HWVEQU(5,PREF,PLAB(1,I+4))
35622 C--all other particles
35623       ELSE
35624         PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
35625         CALL HWVSCA(3,ONE/PP,P(1,I),N)
35626         PLAB(4,I+4) = HALF*(P(4,I)-PP)
35627         PP = HALF*(PP-P(5,I)-PP**2/(P(5,I)+P(4,I)))
35628         CALL HWVSCA(3,PP,N,PLAB(1,I+4))
35629         CALL HWUMAS(PLAB(1,I+4))
35630         PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
35631 C--fix to avoid problems if approx massless due to energy
35632         IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
35633       ENDIF
35634 C--now the massless vectors
35635       PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
35636       DO 107 J=1,4
35637  107  PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
35638  106  CALL HWUMAS(PLAB(1,I))
35639 C--change order of momenta for call to HE code
35640       DO 108 I=1,4
35641       PM(1,I) = P(3,I)
35642       PM(2,I) = P(1,I)
35643       PM(3,I) = P(2,I)
35644       PM(4,I) = P(4,I)
35645  108  PM(5,I) = P(5,I)
35646       DO 109 I=1,8
35647       PCM(1,I)=PLAB(3,I)
35648       PCM(2,I)=PLAB(1,I)
35649       PCM(3,I)=PLAB(2,I)
35650       PCM(4,I)=PLAB(4,I)
35651  109  PCM(5,I)=PLAB(5,I)
35652 C--compute the S functions
35653       CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
35654       DO 110 I=1,8
35655       DO 110 J=1,8
35656       S(I,J,2) = -S(I,J,2)
35657  110  D(I,J)   = TWO*D(I,J)
35658 C--compute the F functions
35659       CALL HWH2F1(8,F3 ,7,PM(1,3), MA(3))
35660       CALL HWH2F2(8,F4 ,8,PM(1,4),-MA(4))
35661       CALL HWH2F1(8,F4M,8,PM(1,4), MA(4))
35662       CALL HWH2F2(8,F3M,7,PM(1,3),-MA(3))
35663 C--t and u channel functions
35664 C--first the t channel ones
35665       CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
35666       CALL HWVSUM(4,PM(1,2),PTMP,PTMP)
35667       CALL HWUMAS(PTMP)
35668       CALL HWH2F3(8,FTP,PTMP, MR(1))
35669       CALL HWH2F3(8,FTM,PTMP,-MR(1))
35670 C--then the u-channel ones
35671       CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
35672       CALL HWVSUM(4,PM(1,1),PTMP,PTMP)
35673       CALL HWUMAS(PTMP)
35674       CALL HWH2F3(8,FUP,PTMP, MR(1))
35675       CALL HWH2F3(8,FUM,PTMP,-MR(1))
35676 C--function for t-channel scalar exchange
35677       CALL HWVSUM(4,PM(1,4),PM(1,4),PTMP)
35678       CALL HWUMAS(PTMP)
35679       CALL HWH2F1(8,FST,2,PTMP,ZERO)
35680 C--compute the prefactor for all diagrams
35681       PRE = HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
35682       PRE = ONE/SQRT(PRE)
35683 C--zero the matrix element
35684       DO 200 P1=1,2
35685       DO 200 P2=1,2
35686       DO 200 P3=1,2
35687       DO 200 P4=1,2
35688       DO 200 I=1,NCFL(1)
35689  200  ME(P1,P2,P3,P4,I) = (0.0D0,0.0D0)
35690 C--now call the subroutines to compute the individual diagrams
35691       DO 210 I=1,NDIA
35692 C--s-channel vector boson exchange diagram (f fbar to fermion fermion)
35693       IF(DRTYPE(I).EQ.1) THEN
35694         CALL HWHS01(I,MED)
35695 C--t-channel sfermion exchange diagram (f fbar to fermion fermion)
35696       ELSEIF(DRTYPE(I).EQ.2) THEN
35697         CALL HWHS02(I,MED)
35698 C--u-channel sfermion exchange diagram(f fbar to fermion fermion)
35699       ELSEIF(DRTYPE(I).EQ.3) THEN
35700         CALL HWHS03(I,MED)
35701 C--s-channel vector boson (f fbar to fermion antifermion)
35702       ELSEIF(DRTYPE(I).EQ.4) THEN
35703         CALL HWHS04(I,MED)
35704 C--t-channel fermion exchange (g g to fermion antifermion)
35705       ELSEIF(DRTYPE(I).EQ.5) THEN
35706         CALL HWHS05(I,MED)
35707 C--u-channel fermion exchange (g g to fermion antifermion)
35708       ELSEIF(DRTYPE(I).EQ.6) THEN
35709         CALL HWHS06(I,MED)
35710 C--s-channel gluon exchange (g g to fermion antifermion)
35711       ELSEIF(DRTYPE(I).EQ.7) THEN
35712         CALL HWHS07(I,MED)
35713 C--t-channel sfermion exchange (g q to fermion sfermion)
35714       ELSEIF(DRTYPE(I).EQ.8) THEN
35715         CALL HWHS08(I,MED)
35716 C--t-channel sfermion exchange  (g qbar to fermion antisfermion)
35717       ELSEIF(DRTYPE(I).EQ.9) THEN
35718         CALL HWHS09(I,MED)
35719 C--s-channel quark exchange     (g q to fermion antisfermion)
35720       ELSEIF(DRTYPE(I).EQ.10) THEN
35721         CALL HWHS10(I,MED)
35722 C--s-channel antiquark exchange (g qbar to fermion antisfermion)
35723       ELSEIF(DRTYPE(I).EQ.11) THEN
35724         CALL HWHS11(I,MED)
35725 C--u-channel gluino exchange (g q to fermion antisfermion)
35726       ELSEIF(DRTYPE(I).EQ.12) THEN
35727         CALL HWHS12(I,MED)
35728 C--u-channel gluino exchange (g qbar to fermion antisfermion)
35729       ELSEIF(DRTYPE(I).EQ.13) THEN
35730         CALL HWHS13(I,MED)
35731 C--t-channel fermion exchange (g g to fermion fermion)
35732       ELSEIF(DRTYPE(I).EQ.14) THEN
35733         CALL HWHS14(I,MED)
35734 C--u-channel fermion exchange (g g to fermion fermion)
35735       ELSEIF(DRTYPE(I).EQ.15) THEN
35736         CALL HWHS15(I,MED)
35737 C--s-channel gluon exchange (g g to fermion fermion)
35738       ELSEIF(DRTYPE(I).EQ.16) THEN
35739         CALL HWHS16(I,MED)
35740 C--t-channel gauge boson exchange (fermion fermion)
35741       ELSEIF(DRTYPE(I).EQ.17) THEN
35742         CALL HWHS17(I,MED)
35743 C--t-channel gauge boson exchange (fermion antifermion)
35744       ELSEIF(DRTYPE(I).EQ.18) THEN
35745         CALL HWHS18(I,MED)
35746 C--t-channel gauge boson exchange (antifermion fermion)
35747       ELSEIF(DRTYPE(I).EQ.19) THEN
35748         CALL HWHS19(I,MED)
35749 C--t-channel gauge boson exchange (antifermion antifermion)
35750       ELSEIF(DRTYPE(I).EQ.20) THEN
35751         CALL HWHS20(I,MED)
35752 C--s-channel scalar exchange (f fbar --> f fbar)
35753       ELSEIF(DRTYPE(I).EQ.21) THEN
35754         CALL HWHS21(I,MED)
35755 C--t-channel scalar exchange (f fbar --> f fbar)
35756       ELSEIF(DRTYPE(I).EQ.22) THEN
35757         CALL HWHS22(I,MED)
35758 C--u-channel scalar exchange (f fbar --> f fbar)
35759       ELSEIF(DRTYPE(I).EQ.23) THEN
35760         CALL HWHS23(I,MED)
35761 C--s-channel scalar exchange (fbar f --> f f)
35762       ELSEIF(DRTYPE(I).EQ.24) THEN
35763         CALL HWHS24(I,MED)
35764 C--t-channel scalar exchange (fbar f --> f f)
35765       ELSEIF(DRTYPE(I).EQ.25) THEN
35766         CALL HWHS25(I,MED)
35767 C--u-channel scalar exchange (fbar f --> f f)
35768       ELSEIF(DRTYPE(I).EQ.26) THEN
35769         CALL HWHS26(I,MED)
35770 C--s-channel scalar exchange (f f --> f fbar)
35771       ELSEIF(DRTYPE(I).EQ.27) THEN
35772         CALL HWHS27(I,MED)
35773 C--t-channel scalar exchange (f f --> f fbar)
35774       ELSEIF(DRTYPE(I).EQ.28) THEN
35775         CALL HWHS28(I,MED)
35776 C--u-channel scalar exchange (f f --> f fbar)
35777       ELSEIF(DRTYPE(I).EQ.29) THEN
35778         CALL HWHS29(I,MED)
35779 C--s-channel scalar exchange (fbar fbar --> f f)
35780       ELSEIF(DRTYPE(I).EQ.30) THEN
35781         CALL HWHS30(I,MED)
35782 C--t-channel scalar exchange (fbar fbar --> f f)
35783       ELSEIF(DRTYPE(I).EQ.31) THEN
35784         CALL HWHS31(I,MED)
35785 C--u-channel scalar exchange (fbar fbar --> f f)
35786       ELSEIF(DRTYPE(I).EQ.32) THEN
35787         CALL HWHS32(I,MED)
35788 C--s-channel scalar exchange (f f --> f f)
35789       ELSEIF(DRTYPE(I).EQ.33) THEN
35790         CALL HWHS33(I,MED)
35791 C--s-channel scalar exchange (fbar fbar --> fbar fbar)
35792       ELSEIF(DRTYPE(I).EQ.34) THEN
35793         CALL HWHS34(I,MED)
35794 C--error not known
35795       ELSE
35796         CALL HWWARN('HWHSPN',508)
35797       ENDIF
35798 C--add up the matrix elements
35799       DO 210 P1=1,2
35800       DO 210 P2=1,2
35801       DO 210 P3=1,2
35802       DO 210 P4=1,2
35803  210  ME(P1,P2,P3,P4,IFLOW(I)) = ME(P1,P2,P3,P4,IFLOW(I))
35804      &                             +MED(P1,P2,P3,P4)
35805 C--preform the final normalisation
35806       DO 215 P1=1,2
35807       DO 215 P2=1,2
35808       DO 215 P3=1,2
35809       DO 215 P4=1,2
35810       DO 215 I=1,NCFL(1)
35811  215  ME(P1,P2,P3,P4,I) = PRE*ME(P1,P2,P3,P4,I)
35812 C--now enter the matrix element in the spin common block
35813       NSPN        = 1
35814       IDSPN(1)    = ICM
35815       ISNHEP(ICM) = 1
35816       JMOSPN(1)   = 0
35817       JDASPN(1,1) = 2
35818       JDASPN(2,1) = 3
35819       DECSPN(1) = .FALSE.
35820       DO 225 P1=1,2
35821       DO 225 P2=1,2
35822       DO 225 P3=1,2
35823       DO 225 P4=1,2
35824       DO 225 I=1,NCFL(1)
35825  225  MESPN(P1,P2,P3,P4,I,1) = ME(P1,P2,P3,P4,I)
35826 C--now enter the daughter particles
35827       NSPN         = NSPN+2
35828       IDSPN(2)     = KHEP
35829       ISNHEP(KHEP) = 2
35830       IDSPN(3)     = JHEP
35831       ISNHEP(JHEP) = 3
35832       JMOSPN(2)    = 1
35833       JMOSPN(3)    = 1
35834 C--spin density matrices for daughter particles
35835       DO 230 P1=1,2
35836       DO 230 P2=1,2
35837       DO 230 I=1,3
35838       RHOSPN(1,1,I) = HALF
35839       RHOSPN(1,2,I) = ZERO
35840       RHOSPN(2,1,I) = ZERO
35841  230  RHOSPN(2,2,I) = HALF
35842       DECSPN(2) = .FALSE.
35843       DECSPN(3) = .FALSE.
35844 C--select the colour flow if needed
35845       IF(SPCOPT.EQ.2.AND.NCFL(1).NE.1) THEN
35846         WGT = ZERO
35847 C--assume no incoming polarization, no processes with more than one
35848 C--colour flow in e+e-
35849         DO 335 I =1,NCFL(1)
35850         WGTB(I) = ZERO
35851         DO 335 P1=1,2
35852         DO 335 P2=1,2
35853         DO 335 P3=1,2
35854         DO 335 P4=1,2
35855         WGTB(I) = WGTB(I)+SPNCFC(I,I,1)*DREAL(
35856      &         MESPN(P1,P2,P3,P4,I,1)*DCONJG(MESPN(P1,P2,P3,P4,I,1)))
35857         DO 335 J =1,NCFL(1)
35858  335    WGT = WGT+SPNCFC(I,J,1)*DREAL(
35859      &         MESPN(P1,P2,P3,P4,I,1)*DCONJG(MESPN(P1,P2,P3,P4,J,1)))
35860         WGTC = ZERO
35861         DO 340 I=1,NCFL(1)
35862  340    WGTC = WGTC+WGTB(I)
35863         WGTC = WGT/WGTC
35864         DO 345 I=1,NCFL(1)
35865  345    WGTB(I) = WGTB(I)*WGTC
35866         WGTC = WGT*HWRGEN(0)
35867         DO 350 I=1,NCFL(1)
35868         IF(WGTB(I).GE.WGTC) THEN
35869           NCFL(1) = I
35870           RETURN
35871         ENDIF
35872  350    WGTC =WGTC-WGTB(I)
35873       ENDIF
35874       END
35875 CDECK  ID>, HWHS01.
35876 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35877 *-- Author :    Peter Richardson
35878 C-----------------------------------------------------------------------
35879       SUBROUTINE HWHS01(ID,ME)
35880 C-----------------------------------------------------------------------
35881 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35882 C  section f fbar --> gauge boson --> fermion fermion
35883 C  This diagram 1 from DAMTP-2001-83 with opposite sign of P4
35884 C-----------------------------------------------------------------------
35885       INCLUDE 'herwig65.inc'
35886       INTEGER NDIAHD
35887       PARAMETER(NDIAHD=10)
35888       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35889      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35890      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35891       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35892      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35893       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35894       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35895      &     MA2,SH,TH,UH,IDP,DRTYPE
35896       PARAMETER(ZI=(0.0D0,1.0D0))
35897       COMMON/HWHEWS/S(8,8,2),D(8,8)
35898       SAVE O
35899       DATA O/2,1/
35900 C--compute the propagator factor
35901       PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
35902       DO 10 P1=1,2
35903       DO 10 P2=1,2
35904       DO 10 P3=1,2
35905       DO 10 P4=1,2
35906         IF(P1.EQ.P2) THEN
35907           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
35908      &          B(O(P1),ID)*F3(O(P3),  P1 ,1)*F4(  P1 ,P4,2)
35909      &         +B(  P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),P4,1))
35910         ELSE
35911           ME(P1,P2,P3,P4) = ZERO
35912         ENDIF
35913  10   CONTINUE
35914       END
35915 CDECK  ID>, HWHS02.
35916 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35917 *-- Author :    Peter Richardson
35918 C-----------------------------------------------------------------------
35919       SUBROUTINE HWHS02(ID,ME)
35920 C-----------------------------------------------------------------------
35921 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35922 C  section  f fbar ---> fermion fermion via t-channel scalar exchange
35923 C  This diagram 2 from DAMTP-2001-83 with opposite sign of P4
35924 C-----------------------------------------------------------------------
35925       INCLUDE 'herwig65.inc'
35926       INTEGER NDIAHD
35927       PARAMETER(NDIAHD=10)
35928       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35929      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35930      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35931       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35932      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35933       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35934       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35935      &     MA2,SH,TH,UH,IDP,DRTYPE
35936       COMMON/HWHEWS/S(8,8,2),D(8,8)
35937       SAVE O
35938       DATA O/2,1/
35939 C--compute the propagator factor
35940       PRE = -HALF/(TH-MS(ID))
35941       DO 10 P1=1,2
35942       DO 10 P2=1,2
35943       DO 10 P3=1,2
35944       DO 10 P4=1,2
35945  10   ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
35946      &        F3(O(P3),P1,1)*F4(P2,P4,2)
35947       END
35948 CDECK  ID>, HWHS03.
35949 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35950 *-- Author :    Peter Richardson
35951 C-----------------------------------------------------------------------
35952       SUBROUTINE HWHS03(ID,ME)
35953 C-----------------------------------------------------------------------
35954 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35955 C  section  f fbar ---> fermion fermion via u-channel scalar exchange
35956 C  This diagram 3 from DAMTP-2001-83 with opposite sign of P4
35957 C-----------------------------------------------------------------------
35958       INCLUDE 'herwig65.inc'
35959       INTEGER NDIAHD
35960       PARAMETER(NDIAHD=10)
35961       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,
35962      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35963      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35964       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35965      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35966       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35967       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35968      &     MA2,SH,TH,UH,IDP,DRTYPE
35969       COMMON/HWHEWS/S(8,8,2),D(8,8)
35970       SAVE O
35971       DATA O/2,1/
35972 C--compute the propagator factor
35973       PRE = HALF/(UH-MS(ID))
35974       DO 10 P1=1,2
35975       DO 10 P2=1,2
35976       DO 10 P3=1,2
35977       DO 10 P4=1,2
35978  10   ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
35979      &        F4M(O(P4),P1,1)*F3M(P2,P3,2)
35980       END
35981 CDECK  ID>, HWHS04.
35982 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35983 *-- Author :    Peter Richardson
35984 C-----------------------------------------------------------------------
35985       SUBROUTINE HWHS04(ID,ME)
35986 C-----------------------------------------------------------------------
35987 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35988 C  section f fbar --> gauge boson --> fermion antifermion
35989 C  This diagram 1 from DAMTP-2001-83
35990 C-----------------------------------------------------------------------
35991       INCLUDE 'herwig65.inc'
35992       INTEGER NDIAHD
35993       PARAMETER(NDIAHD=10)
35994       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35995      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35996      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35997       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35998      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35999       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36000       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36001      &     MA2,SH,TH,UH,IDP,DRTYPE
36002       PARAMETER(ZI=(0.0D0,1.0D0))
36003       COMMON/HWHEWS/S(8,8,2),D(8,8)
36004       SAVE O
36005       DATA O/2,1/
36006 C--compute the propagator factor
36007       PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
36008       DO 10 P1=1,2
36009       DO 10 P2=1,2
36010       DO 10 P3=1,2
36011       DO 10 P4=1,2
36012         IF(P1.EQ.P2) THEN
36013           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
36014      &          B(O(P1),ID)*F3(O(P3),  P1 ,1)*F4(  P1 ,O(P4),2)
36015      &         +B(  P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),O(P4),1))
36016         ELSE
36017           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36018         ENDIF
36019  10   CONTINUE
36020       END
36021 CDECK  ID>, HWHS05.
36022 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36023 *-- Author :    Peter Richardson
36024 C-----------------------------------------------------------------------
36025       SUBROUTINE HWHS05(ID,ME)
36026 C-----------------------------------------------------------------------
36027 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36028 C  section gluon gluon --> fermion antifermion (1st colour flow)
36029 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
36030 C  This diagram 4 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
36031 C-----------------------------------------------------------------------
36032       INCLUDE 'herwig65.inc'
36033       INTEGER NDIAHD
36034       PARAMETER(NDIAHD=10)
36035       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36036      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36037      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36038       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36039      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36040       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36041       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36042      &     MA2,SH,TH,UH,IDP,DRTYPE
36043       PARAMETER(ZI=(0.0D0,1.0D0))
36044       COMMON/HWHEWS/S(8,8,2),D(8,8)
36045       SAVE O
36046       DATA O/2,1/
36047 C--compute the propagator factor
36048       PRE =+ONE/SH/(TH-MS(ID))
36049       DO 10 P1=1,2
36050       DO 10 P2=1,2
36051       DO 10 P3=1,2
36052       DO 10 P4=1,2
36053  10   ME(P1,P2,P3,P4) = PRE*(
36054      &  F3(O(P3),  P1 ,2)*( FTP(  P1 ,  P2 ,1,1)*F4(  P2 ,O(P4),2)
36055      &                     +FTP(  P1 ,O(P2),1,2)*F4(O(P2),O(P4),1))
36056      & +F3(O(P3),O(P1),1)*( FTP(O(P1),  P2 ,2,1)*F4(  P2 ,O(P4),2)
36057      &                     +FTP(O(P1),O(P2),2,2)*F4(O(P2),O(P4),1)))
36058       END
36059 CDECK  ID>, HWHS06.
36060 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36061 *-- Author :    Peter Richardson
36062 C-----------------------------------------------------------------------
36063       SUBROUTINE HWHS06(ID,ME)
36064 C-----------------------------------------------------------------------
36065 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36066 C  section gluon gluon --> fermion antifermion (2st colour flow)
36067 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
36068 C  This diagram 5 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
36069 C-----------------------------------------------------------------------
36070       INCLUDE 'herwig65.inc'
36071       INTEGER NDIAHD
36072       PARAMETER(NDIAHD=10)
36073       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36074      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36075      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36076       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36077      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36078       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36079       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36080      &     MA2,SH,TH,UH,IDP,DRTYPE
36081       PARAMETER(ZI=(0.0D0,1.0D0))
36082       COMMON/HWHEWS/S(8,8,2),D(8,8)
36083       SAVE O
36084       DATA O/2,1/
36085 C--compute the propagator factor
36086       PRE =-ONE/SH/(UH-MS(ID))
36087       DO 10 P1=1,2
36088       DO 10 P2=1,2
36089       DO 10 P3=1,2
36090       DO 10 P4=1,2
36091  10   ME(P1,P2,P3,P4) = PRE*(
36092      &     F3(O(P3),  P2 ,1)*( FUP(  P2 ,  P1 ,2,2)*F4(  P1 ,O(P4),1)
36093      &                        +FUP(  P2 ,O(P1),2,1)*F4(O(P1),O(P4),2))
36094      &    +F3(O(P3),O(P2),2)*( FUP(O(P2),  P1 ,1,2)*F4(  P1 ,O(P4),1)
36095      &                        +FUP(O(P2),O(P1),1,1)*F4(O(P1),O(P4),2)))
36096       END
36097 CDECK  ID>, HWHS07.
36098 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36099 *-- Author :    Peter Richardson
36100 C-----------------------------------------------------------------------
36101       SUBROUTINE HWHS07(ID,ME)
36102 C-----------------------------------------------------------------------
36103 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36104 C  section gluon gluon --> fermion antifermion (triple gluon piece)
36105 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
36106 C  This diagram 6 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
36107 C-----------------------------------------------------------------------
36108       INCLUDE 'herwig65.inc'
36109       INTEGER NDIAHD
36110       PARAMETER(NDIAHD=10)
36111       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36112      &     ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
36113      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36114       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36115      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36116       INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36117       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36118      &     MA2,SH,TH,UH,IDP,DRTYPE
36119       PARAMETER(ZI=(0.0D0,1.0D0))
36120       COMMON/HWHEWS/S(8,8,2),D(8,8)
36121       SAVE O
36122       DATA O/2,1/
36123 C--compute the propagator factor
36124       PRE = HALF/SH**2
36125       DO 10 P3=1,2
36126       DO 10 P4=1,2
36127       MET = (0.0D0,0.0D0)
36128       DO 5 I=1,2
36129  5    MET=MET+F3(O(P3),I,1)*F4(I,O(P4),1)-F3(O(P3),I,2)*F4(I,O(P4),2)
36130       DO 10 P1=1,2
36131       DO 10 P2=1,2
36132       IF(P1.EQ.P2) THEN
36133         ME(P1,P2,P3,P4) = PRE*S(1,2,P1)*S(1,2,O(P1))*MET
36134       ELSE
36135         ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36136       ENDIF
36137  10   CONTINUE
36138       END
36139 CDECK  ID>, HWHS08.
36140 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36141 *-- Author :    Peter Richardson
36142 C-----------------------------------------------------------------------
36143       SUBROUTINE HWHS08(ID,ME)
36144 C-----------------------------------------------------------------------
36145 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36146 C  section quark gluon --> fermion sfermion
36147 C  This diagram 7 from DAMTP-2001-83 with the gauge choice L2=1
36148 C-----------------------------------------------------------------------
36149       INCLUDE 'herwig65.inc'
36150       INTEGER NDIAHD
36151       PARAMETER(NDIAHD=10)
36152       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36153      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36154      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36155       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36156      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36157       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36158       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36159      &     MA2,SH,TH,UH,IDP,DRTYPE
36160       PARAMETER(ZI=(0.0D0,1.0D0))
36161       COMMON/HWHEWS/S(8,8,2),D(8,8)
36162       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36163       EXTERNAL HWULDO
36164       SAVE O
36165       DATA O/2,1/
36166 C--compute the propagator factor
36167       PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36168      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
36169      &        (TH-MS(ID))
36170       DO 10 P1=1,2
36171       DO 10 P2=1,2
36172       DO 10 P3=1,2
36173       ME(P1,P2,P3,2) = ZERO
36174  10   ME(P1,P2,P3,1) = A(P1,ID)*PRE*FST(P2,P2,1)*F3(O(P3),  P1,1)
36175       END
36176 CDECK  ID>, HWHS09.
36177 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36178 *-- Author :    Peter Richardson
36179 C-----------------------------------------------------------------------
36180       SUBROUTINE HWHS09(ID,ME)
36181 C-----------------------------------------------------------------------
36182 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36183 C  section antiquark gluon --> fermion antisfermion
36184 C  This diagram 10 from DAMTP-2001-83 with the gauge choice L2=1
36185 C-----------------------------------------------------------------------
36186       INCLUDE 'herwig65.inc'
36187       INTEGER NDIAHD
36188       PARAMETER(NDIAHD=10)
36189       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36190      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36191      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36192       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36193      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36194       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36195       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36196      &     MA2,SH,TH,UH,IDP,DRTYPE
36197       PARAMETER(ZI=(0.0D0,1.0D0))
36198       COMMON/HWHEWS/S(8,8,2),D(8,8)
36199       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36200       EXTERNAL HWULDO
36201       SAVE O
36202       DATA O/2,1/
36203 C--compute the propagator factor
36204       PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36205      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
36206      &        (TH-MS(ID))
36207       DO 10 P1=1,2
36208       DO 10 P2=1,2
36209       DO 10 P3=1,2
36210       ME(P1,P2,P3,2) = ZERO
36211   10  ME(P1,P2,P3,1) = A(O(P1),ID)*PRE*FST(P2,P2,1)*F3M(P1,P3,1)
36212       END
36213 CDECK  ID>, HWHS10.
36214 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36215 *-- Author :    Peter Richardson
36216 C-----------------------------------------------------------------------
36217       SUBROUTINE HWHS10(ID,ME)
36218 C-----------------------------------------------------------------------
36219 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36220 C  section quark gluon --> fermion antisfermion (s-channel quark)
36221 C  This is diagram 8 from DAMTP-2001-83 with the gauge choice L2=1
36222 C-----------------------------------------------------------------------
36223       INCLUDE 'herwig65.inc'
36224       INTEGER NDIAHD
36225       PARAMETER(NDIAHD=10)
36226       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36227      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36228      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36229       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36230      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36231       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36232       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36233      &     MA2,SH,TH,UH,IDP,DRTYPE
36234       PARAMETER(ZI=(0.0D0,1.0D0))
36235       COMMON/HWHEWS/S(8,8,2),D(8,8)
36236       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36237       EXTERNAL HWULDO
36238       SAVE O
36239       DATA O/2,1/
36240 C--compute the propagator factor
36241       PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36242      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
36243       DO 10 P1=1,2
36244       DO 10 P2=1,2
36245       DO 10 P3=1,2
36246       IF(P1.EQ.P2) THEN
36247         ME(p1,p2,p3,1) = PRE*A(  P2 ,ID)*F3(O(P3),  P2 ,1)*S(1,2,P2)*
36248      &        S(1,1,O(P2))
36249       ELSE
36250         ME(P1,P2,P3,1) = PRE*
36251      &      A(O(P2),ID)*( F3(O(P3),O(P2),1)*S(1,1,O(P2))
36252      &                   +F3(O(P3),O(P2),2)*S(2,1,O(P2)))*S(2,1,P2)
36253       ENDIF
36254  10   ME(P1,P2,P3,2) = ZERO
36255       END
36256 CDECK  ID>, HWHS11.
36257 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36258 *-- Author :    Peter Richardson
36259 C-----------------------------------------------------------------------
36260       SUBROUTINE HWHS11(ID,ME)
36261 C-----------------------------------------------------------------------
36262 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36263 C  section quark gluon --> fermion antisfermion (s-channel quark)
36264 C  This is diagram 11 from DAMTP-2001-83 with the gauge choice L2=1
36265 C-----------------------------------------------------------------------
36266       INCLUDE 'herwig65.inc'
36267       INTEGER NDIAHD
36268       PARAMETER(NDIAHD=10)
36269       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36270      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36271      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36272       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36273      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36274       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36275       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36276      &     MA2,SH,TH,UH,IDP,DRTYPE
36277       PARAMETER(ZI=(0.0D0,1.0D0))
36278       COMMON/HWHEWS/S(8,8,2),D(8,8)
36279       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36280       EXTERNAL HWULDO
36281       SAVE O
36282       DATA O/2,1/
36283 C--compute the propagator factor
36284       PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36285      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
36286       DO 10 P1=1,2
36287       DO 10 P2=1,2
36288       DO 10 P3=1,2
36289       IF(P1.EQ.P2) THEN
36290         ME(P1,P2,P3,1) = PRE*A(O(P2),ID)*S(1,2,P1)*
36291      &        (S(1,1,O(P2))*F3M(P2,P3,1)+S(1,2,O(P2))*F3M(P2,P3,2))
36292       ELSE
36293         ME(P1,P2,P3,1)=PRE*A(P2,ID)*S(1,1,P1)*S(2,1,P2)*F3M(O(P2),P3,1)
36294       ENDIF
36295  10   ME(P1,P2,P3,2) = ZERO
36296       END
36297 CDECK  ID>, HWHS12.
36298 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36299 *-- Author :    Peter Richardson
36300 C-----------------------------------------------------------------------
36301       SUBROUTINE HWHS12(ID,ME)
36302 C-----------------------------------------------------------------------
36303 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36304 C  section quark gluon --> fermion antisfermion (s-channel quark)
36305 C  This is diagram 9 from DAMTP-2001-83 with the gauge choice L2=1
36306 C-----------------------------------------------------------------------
36307       INCLUDE 'herwig65.inc'
36308       INTEGER NDIAHD
36309       PARAMETER(NDIAHD=10)
36310       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36311      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36312      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36313       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36314      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36315       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36316       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36317      &     MA2,SH,TH,UH,IDP,DRTYPE
36318       PARAMETER(ZI=(0.0D0,1.0D0))
36319       COMMON/HWHEWS/S(8,8,2),D(8,8)
36320       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36321       EXTERNAL HWULDO
36322       SAVE O
36323       DATA O/2,1/
36324 C--compute the propagator factor
36325       PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36326      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
36327       DO 10 P1=1,2
36328       DO 10 P2=1,2
36329       DO 10 P3=1,2
36330       ME(P1,P2,P3,1) = PRE*A(P1,ID)*(
36331      &                       F3(O(P3),  P2 ,1)*FUP(  P2 ,P1, 2,1)
36332      &                      +F3(O(P3),O(P2), 2)*FUP(O(P2),P1,1,1))
36333  10   ME(P1,P2,P3,2) = ZERO
36334       END
36335 CDECK  ID>, HWHS13.
36336 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36337 *-- Author :    Peter Richardson
36338 C-----------------------------------------------------------------------
36339       SUBROUTINE HWHS13(ID,ME)
36340 C-----------------------------------------------------------------------
36341 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36342 C  section quark gluon --> fermion antisfermion (s-channel quark)
36343 C  This is diagram 12 from DAMTP-2001-83 with the gauge choice L2=1
36344 C-----------------------------------------------------------------------
36345       INCLUDE 'herwig65.inc'
36346       INTEGER NDIAHD
36347       PARAMETER(NDIAHD=10)
36348       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36349      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36350      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36351       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36352      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36353       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36354       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36355      &     MA2,SH,TH,UH,IDP,DRTYPE
36356       PARAMETER(ZI=(0.0D0,1.0D0))
36357       COMMON/HWHEWS/S(8,8,2),D(8,8)
36358       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36359       EXTERNAL HWULDO
36360       SAVE O
36361       DATA O/2,1/
36362 C--compute the propagator factor
36363       PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36364      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
36365       DO 10 P1=1,2
36366       DO 10 P2=1,2
36367       DO 10 P3=1,2
36368       ME(P1,P2,P3,1) = PRE*A(O(P1),ID)*(
36369      &                       FUM(P1,  P2 ,1,1)*F3M(  P2 ,P3, 2)
36370      &                      +FUM(P1,O(P2),1, 2)*F3M(O(P2),P3,1))
36371  10   ME(P1,P2,P3,2) = ZERO
36372       END
36373 CDECK  ID>, HWHS14.
36374 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36375 *-- Author :    Peter Richardson
36376 C-----------------------------------------------------------------------
36377       SUBROUTINE HWHS14(ID,ME)
36378 C-----------------------------------------------------------------------
36379 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36380 C  section gluon gluon --> fermion antifermion (1st colour flow)
36381 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
36382 C  This diagram 4 from DAMTP-2001-83 with opposite helicity for 4
36383 C  and gauge choice L1=2 L2=1
36384 C-----------------------------------------------------------------------
36385       INCLUDE 'herwig65.inc'
36386       INTEGER NDIAHD
36387       PARAMETER(NDIAHD=10)
36388       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36389      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
36390      &     FUP(2,2,8,8),FUM(2,2,8,8)
36391       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36392      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36393       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36394       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36395      &     MA2,SH,TH,UH,IDP,DRTYPE
36396       PARAMETER(ZI=(0.0D0,1.0D0))
36397       COMMON/HWHEWS/S(8,8,2),D(8,8)
36398       SAVE O
36399       DATA O/2,1/
36400 C--compute the propagator factor
36401       PRE =+ONE/(TH-MS(ID))/SH
36402 C--matrix element
36403       DO 10 P1=1,2
36404       DO 10 P2=1,2
36405       DO 10 P3=1,2
36406       DO 10 P4=1,2
36407  10   ME(P1,P2,P3,P4) = PRE*(
36408      &  F3(O(P3),  P1 ,2)*( FTP(  P1 ,  P2 , 1,1)*F4(  P2 ,P4,2)
36409      &                     +FTP(  P1 ,O(P2), 1,2)*F4(O(P2),P4,1))
36410      & +F3(O(P3),O(P1),1)*( FTP(O(P1),  P2 ,2,1)*F4(  P2 ,P4,2)
36411      &                     +FTP(O(P1),O(P2),2,2)*F4(O(P2),P4,1)))
36412       END
36413 CDECK  ID>, HWHS15.
36414 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36415 *-- Author :    Peter Richardson
36416 C-----------------------------------------------------------------------
36417       SUBROUTINE HWHS15(ID,ME)
36418 C-----------------------------------------------------------------------
36419 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36420 C  section gluon gluon --> fermion antifermion (2st colour flow)
36421 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
36422 C  This diagram 5 from DAMTP-2001-83 with opposite helicity for 4
36423 C  and gauge choice L1=2 L2=1
36424 C-----------------------------------------------------------------------
36425       INCLUDE 'herwig65.inc'
36426       INTEGER NDIAHD
36427       PARAMETER(NDIAHD=10)
36428       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36429      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
36430      &     FUP(2,2,8,8),FUM(2,2,8,8)
36431       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36432      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36433       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36434       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST, A,B,MS,MWD,MR,MA,
36435      &    MA2,SH,TH,UH,IDP,DRTYPE
36436       PARAMETER(ZI=(0.0D0,1.0D0))
36437       COMMON/HWHEWS/S(8,8,2),D(8,8)
36438       SAVE O
36439       DATA O/2,1/
36440 C--compute the propagator factor
36441       PRE =-ONE/(UH-MS(ID))/SH
36442 C--matrix element
36443       DO 10 P1=1,2
36444       DO 10 P2=1,2
36445       DO 10 P3=1,2
36446       DO 10 P4=1,2
36447  10   ME(P1,P2,P3,P4) = PRE*(
36448      & F3(O(P3),  P2 ,1)*( FUP(  P2 ,  P1 ,2,2)*F4(  P1 ,P4,1)
36449      &                    +FUP(  P2 ,O(P1),2,1)*F4(O(P1),P4,2))
36450      &+F3(O(P3),O(P2),2)*( FUP(O(P2),  P1 ,1,2)*F4(  P1 ,P4,1)
36451      &                    +FUP(O(P2),O(P1),1,1)*F4(O(P1),P4,2)))
36452       END
36453 CDECK  ID>, HWHS16.
36454 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36455 *-- Author :    Peter Richardson
36456 C-----------------------------------------------------------------------
36457       SUBROUTINE HWHS16(ID,ME)
36458 C-----------------------------------------------------------------------
36459 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36460 C  section gluon gluon --> fermion antifermion (triple gluon piece)
36461 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
36462 C  This diagram 6 from DAMTP-2001-83 with opposite helicity for 4
36463 C  and gauge choice L1=2 L2=1
36464 C-----------------------------------------------------------------------
36465       INCLUDE 'herwig65.inc'
36466       INTEGER NDIAHD
36467       PARAMETER(NDIAHD=10)
36468       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36469      &     ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
36470      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36471       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36472      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36473       INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36474       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36475      &     MA2,SH,TH,UH,IDP,DRTYPE
36476       PARAMETER(ZI=(0.0D0,1.0D0))
36477       COMMON/HWHEWS/S(8,8,2),D(8,8)
36478       SAVE O
36479       DATA O/2,1/
36480 C--compute the propagator factor
36481       PRE = HALF/SH**2
36482 C--matrix element
36483       DO 10 P3=1,2
36484       DO 10 P4=1,2
36485       MET = (0.0D0,0.0D0)
36486       DO 5 I=1,2
36487  5    MET=MET+F3(O(P3),I,1)*F4(I,P4,1)-F3(O(P3),I,2)*F4(I,P4,2)
36488       DO 10 P1=1,2
36489       DO 10 P2=1,2
36490       IF(P1.EQ.P2) THEN
36491         ME(P1,P2,P3,P4) = PRE*MET*S(1,2,P1)*S(1,2,O(P1))
36492       ELSE
36493         ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36494       ENDIF
36495  10   CONTINUE
36496       END
36497 CDECK  ID>, HWHS17.
36498 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36499 *-- Author :    Peter Richardson
36500 C-----------------------------------------------------------------------
36501       SUBROUTINE HWHS17(ID,ME)
36502 C-----------------------------------------------------------------------
36503 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36504 C  section fermion fermion --> fermion fermion (t-channel boson)
36505 C  This diagram 13 from DAMTP-2001-83
36506 C-----------------------------------------------------------------------
36507       INCLUDE 'herwig65.inc'
36508       INTEGER NDIAHD
36509       PARAMETER(NDIAHD=10)
36510       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36511      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36512      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
36513       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36514      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36515       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36516       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36517      &     MA2,SH,TH,UH,IDP,DRTYPE
36518       PARAMETER(ZI=(0.0D0,1.0D0))
36519       COMMON/HWHEWS/S(8,8,2),D(8,8)
36520       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36521       EXTERNAL HWULDO
36522       SAVE O,DL
36523       DATA O/2,1/
36524       DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
36525 C--compute the propagator factor
36526       PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
36527       DO 10 P1=1,2
36528       DO 10 P2=1,2
36529       DO 10 P3=1,2
36530       DO 10 P4=1,2
36531         IF(P2.EQ.P4) THEN
36532           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
36533      &          ( DL(P1,O(P2))*F3(O(P3),  P2 ,2)*S(4,1,  P2 )
36534      &           +DL(P1,  P2 )*F3(O(P3),O(P2),4)*S(2,1,O(P2)))
36535         ELSE
36536           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36537         ENDIF
36538  10   CONTINUE
36539       END
36540 CDECK  ID>, HWHS18.
36541 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36542 *-- Author :    Peter Richardson
36543 C-----------------------------------------------------------------------
36544       SUBROUTINE HWHS18(ID,ME)
36545 C-----------------------------------------------------------------------
36546 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36547 C  section fermion antifermion --> fermion antifermion (t-channel boson)
36548 C  This diagram 14 from DAMTP-2001-83
36549 C-----------------------------------------------------------------------
36550       INCLUDE 'herwig65.inc'
36551       INTEGER NDIAHD
36552       PARAMETER(NDIAHD=10)
36553       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36554      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36555      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
36556       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36557      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36558       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36559       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36560      &     MA2,SH,TH,UH,IDP,DRTYPE
36561       PARAMETER(ZI=(0.0D0,1.0D0))
36562       COMMON/HWHEWS/S(8,8,2),D(8,8)
36563       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36564       EXTERNAL HWULDO
36565       SAVE O,DL
36566       DATA O/2,1/
36567       DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
36568 C--compute the propagator factor
36569       PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
36570       DO 10 P1=1,2
36571       DO 10 P2=1,2
36572       DO 10 P3=1,2
36573       DO 10 P4=1,2
36574         IF(P2.EQ.P4) THEN
36575           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
36576      &          ( DL(P1,O(P2))*F3(O(P3),  P2 ,4)*S(2,1,  P2 )
36577      &           +DL(P1,  P2 )*F3(O(P3),O(P2),2)*S(4,1,O(P2)))
36578         ELSE
36579           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36580         ENDIF
36581  10   CONTINUE
36582       END
36583 CDECK  ID>, HWHS19.
36584 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36585 *-- Author :    Peter Richardson
36586 C-----------------------------------------------------------------------
36587       SUBROUTINE HWHS19(ID,ME)
36588 C-----------------------------------------------------------------------
36589 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36590 C  section antifermion fermion --> antifermion fermion (t-channel boson)
36591 C  This diagram 15 from DAMTP-2001-83
36592 C-----------------------------------------------------------------------
36593       INCLUDE 'herwig65.inc'
36594       INTEGER NDIAHD
36595       PARAMETER(NDIAHD=10)
36596       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36597      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36598      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
36599       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36600      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36601       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36602       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36603      &     MA2,SH,TH,UH,IDP,DRTYPE
36604       PARAMETER(ZI=(0.0D0,1.0D0))
36605       COMMON/HWHEWS/S(8,8,2),D(8,8)
36606       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36607       EXTERNAL HWULDO
36608       SAVE O,DL
36609       DATA O/2,1/
36610       DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
36611 C--compute the propagator factor
36612       PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
36613       DO 10 P1=1,2
36614       DO 10 P2=1,2
36615       DO 10 P3=1,2
36616       DO 10 P4=1,2
36617         IF(P2.EQ.P4) THEN
36618           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
36619      &          ( DL(P1,O(P2))*S(1,2,  P1 )*F3M(  P2 ,O(P3),4)
36620      &           +DL(P1,  P2 )*S(1,4,  P1 )*F3M(O(P2),O(P3),2))
36621         ELSE
36622           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36623         ENDIF
36624  10   CONTINUE
36625       END
36626 CDECK  ID>, HWHS20.
36627 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36628 *-- Author :    Peter Richardson
36629 C-----------------------------------------------------------------------
36630       SUBROUTINE HWHS20(ID,ME)
36631 C-----------------------------------------------------------------------
36632 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36633 C  section antifermion fermion --> antifermion fermion (t-channel boson)
36634 C  This diagram 16 from DAMTP-2001-83
36635 C-----------------------------------------------------------------------
36636       INCLUDE 'herwig65.inc'
36637       INTEGER NDIAHD
36638       PARAMETER(NDIAHD=10)
36639       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36640      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36641      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
36642       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36643      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36644       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36645       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36646      &     MA2,SH,TH,UH,IDP,DRTYPE
36647       PARAMETER(ZI=(0.0D0,1.0D0))
36648       COMMON/HWHEWS/S(8,8,2),D(8,8)
36649       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36650       EXTERNAL HWULDO
36651       SAVE O,DL
36652       DATA O/2,1/
36653       DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
36654 C--compute the propagator factor
36655       PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
36656       DO 10 P1=1,2
36657       DO 10 P2=1,2
36658       DO 10 P3=1,2
36659       DO 10 P4=1,2
36660         IF(P2.EQ.P4) THEN
36661           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
36662      &          ( DL(P1,O(P2))*S(1,4,  P1 )*F3M(  P2 ,O(P3),2)
36663      &           +DL(P1,  P2 )*S(1,2,  P1 )*F3M(O(P2),O(P3),4))
36664         ELSE
36665           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36666         ENDIF
36667  10   CONTINUE
36668       END
36669 CDECK  ID>, HWHS21.
36670 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
36671 *-- Author :    Peter Richardson
36672 C-----------------------------------------------------------------------
36673       SUBROUTINE HWHS21(ID,ME)
36674 C-----------------------------------------------------------------------
36675 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36676 C  section  f fbar ---> f fbar via s-channel scalar exchange
36677 C  This is diagram 1 from RPV notes
36678 C-----------------------------------------------------------------------
36679       INCLUDE 'herwig65.inc'
36680       INTEGER NDIAHD
36681       PARAMETER(NDIAHD=10)
36682       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36683      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36684      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36685       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36686      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36687       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36688       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36689      &     MA2,SH,TH,UH,IDP,DRTYPE
36690       COMMON/HWHEWS/S(8,8,2),D(8,8)
36691       PARAMETER(ZI=(0.0D0,1.0D0))
36692       SAVE O
36693       DATA O/2,1/
36694 C--compute the propagator factor
36695       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
36696       DO 10 P1=1,2
36697       DO 10 P3=1,2
36698       DO 10 P4=1,2
36699       ME(P1,  P1 ,P3,P4) = (0.0D0,0.0D0)
36700  10   ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
36701      &     ( B(  P4 ,ID)*F3(O(P3),  P4 ,4)*S(4,8,P4)
36702      &      -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
36703       END
36704 CDECK  ID>, HWHS22.
36705 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
36706 *-- Author :    Peter Richardson
36707 C-----------------------------------------------------------------------
36708       SUBROUTINE HWHS22(ID,ME)
36709 C-----------------------------------------------------------------------
36710 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36711 C  section  f fbar ---> f fbar via t-channel scalar exchange
36712 C  This is diagram 2 from RPV notes
36713 C-----------------------------------------------------------------------
36714       INCLUDE 'herwig65.inc'
36715       INTEGER NDIAHD
36716       PARAMETER(NDIAHD=10)
36717       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36718      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36719      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36720       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36721      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36722       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36723       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36724      &     MA2,SH,TH,UH,IDP,DRTYPE
36725       COMMON/HWHEWS/S(8,8,2),D(8,8)
36726       SAVE O
36727       DATA O/2,1/
36728 C--compute the propagator factor
36729       PRE = -HALF/(TH-MS(ID))
36730       DO 10 P1=1,2
36731       DO 10 P2=1,2
36732       DO 10 P3=1,2
36733       DO 10 P4=1,2
36734  10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(  P1 ,ID)*
36735      &                  F4(P2,O(P4),2)*F3(O(P3),P1,1)
36736       END
36737 CDECK  ID>, HWHS23.
36738 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
36739 *-- Author :    Peter Richardson
36740 C-----------------------------------------------------------------------
36741       SUBROUTINE HWHS23(ID,ME)
36742 C-----------------------------------------------------------------------
36743 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36744 C  section  f fbar ---> fermion fermion via t-channel scalar exchange
36745 C  This is diagram 3 from RPV notes
36746 C-----------------------------------------------------------------------
36747       INCLUDE 'herwig65.inc'
36748       INTEGER NDIAHD
36749       PARAMETER(NDIAHD=10)
36750       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36751      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36752      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36753       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36754      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36755       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36756       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36757      &     MA2,SH,TH,UH,IDP,DRTYPE
36758       COMMON/HWHEWS/S(8,8,2),D(8,8)
36759       SAVE O
36760       DATA O/2,1/
36761 C--compute the propagator factor
36762       PRE = HALF/(UH-MS(ID))
36763       DO 10 P1=1,2
36764       DO 10 P2=1,2
36765       DO 10 P3=1,2
36766       DO 10 P4=1,2
36767  10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(  P1 ,ID)*
36768      &                  F4M(P4,P1,1)*F3M(P2,P3,2)
36769       END
36770 CDECK  ID>, HWHS24.
36771 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
36772 *-- Author :    Peter Richardson
36773 C-----------------------------------------------------------------------
36774       SUBROUTINE HWHS24(ID,ME)
36775 C-----------------------------------------------------------------------
36776 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36777 C  section  f fbar ---> f f via s-channel scalar exchange
36778 C  This is diagram 4 from RPV notes
36779 C-----------------------------------------------------------------------
36780       INCLUDE 'herwig65.inc'
36781       INTEGER NDIAHD
36782       PARAMETER(NDIAHD=10)
36783       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36784      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36785      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36786       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36787      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36788       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36789       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36790      &     MA2,SH,TH,UH,IDP,DRTYPE
36791       COMMON/HWHEWS/S(8,8,2),D(8,8)
36792       PARAMETER(ZI=(0.0D0,1.0D0))
36793       SAVE O
36794       DATA O/2,1/
36795 C--compute the propagator factor
36796       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
36797       DO 10 P1=1,2
36798       DO 10 P3=1,2
36799       DO 10 P4=1,2
36800       ME(P1,  P1 ,P3,P4) = (0.0D0,0.0D0)
36801  10   ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
36802      &                    ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
36803      &                     -B(  P3 ,ID)*F4M(O(P4),  P3 ,7)*MA(3))
36804       END
36805 CDECK  ID>, HWHS25.
36806 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
36807 *-- Author :    Peter Richardson
36808 C-----------------------------------------------------------------------
36809       SUBROUTINE HWHS25(ID,ME)
36810 C-----------------------------------------------------------------------
36811 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36812 C  section  f fbar ---> f f via u-channel scalar exchange
36813 C  This is diagram 5 from RPV notes
36814 C-----------------------------------------------------------------------
36815       INCLUDE 'herwig65.inc'
36816       INTEGER NDIAHD
36817       PARAMETER(NDIAHD=10)
36818       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36819      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36820      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36821       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36822      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36823       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36824       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36825      &     MA2,SH,TH,UH,IDP,DRTYPE
36826       COMMON/HWHEWS/S(8,8,2),D(8,8)
36827       SAVE O
36828       DATA O/2,1/
36829 C--compute the propagator factor
36830       PRE = -HALF/(UH-MS(ID))
36831       DO 10 P1=1,2
36832       DO 10 P2=1,2
36833       DO 10 P3=1,2
36834       DO 10 P4=1,2
36835  10   ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
36836      &                  F4M(O(P4),P1,1)*F3M(P2,P3,2)
36837       END
36838 CDECK  ID>, HWHS26.
36839 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
36840 *-- Author :    Peter Richardson
36841 C-----------------------------------------------------------------------
36842       SUBROUTINE HWHS26(ID,ME)
36843 C-----------------------------------------------------------------------
36844 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36845 C  section  f fbar ---> f f via t-channel scalar exchange
36846 C  This is diagram 6 from RPV notes
36847 C-----------------------------------------------------------------------
36848       INCLUDE 'herwig65.inc'
36849       INTEGER NDIAHD
36850       PARAMETER(NDIAHD=10)
36851       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36852      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36853      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36854       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36855      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36856       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36857       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36858      &     MA2,SH,TH,UH,IDP,DRTYPE
36859       COMMON/HWHEWS/S(8,8,2),D(8,8)
36860       SAVE O
36861       DATA O/2,1/
36862 C--compute the propagator factor
36863       PRE = HALF/(TH-MS(ID))
36864       DO 10 P1=1,2
36865       DO 10 P2=1,2
36866       DO 10 P3=1,2
36867       DO 10 P4=1,2
36868  10   ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
36869      &                  F4(P2,P4,2)*F3(O(P3),P1,1)
36870       END
36871 CDECK  ID>, HWHS27.
36872 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
36873 *-- Author :    Peter Richardson
36874 C-----------------------------------------------------------------------
36875       SUBROUTINE HWHS27(ID,ME)
36876 C-----------------------------------------------------------------------
36877 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36878 C  section  f f ---> f fbar via s-channel scalar exchange
36879 C  This is diagram 7 from RPV notes
36880 C-----------------------------------------------------------------------
36881       INCLUDE 'herwig65.inc'
36882       INTEGER NDIAHD
36883       PARAMETER(NDIAHD=10)
36884       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36885      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36886      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36887       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36888      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36889       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36890       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36891      &     MA2,SH,TH,UH,IDP,DRTYPE
36892       COMMON/HWHEWS/S(8,8,2),D(8,8)
36893       PARAMETER(ZI=(0.0D0,1.0D0))
36894       SAVE O
36895       DATA O/2,1/
36896 C--compute the propagator factor
36897       PRE =-HALF/(SH-MS(ID)+ZI*MWD(ID))
36898       DO 10 P1=1,2
36899       DO 10 P3=1,2
36900       DO 10 P4=1,2
36901       ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
36902  10   ME(P1,  P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
36903      &     ( B(  P4 ,ID)*F3(O(P3),  P4 ,4)*S(4,8,P4)
36904      &      -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
36905       END
36906 CDECK  ID>, HWHS28.
36907 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
36908 *-- Author :    Peter Richardson
36909 C-----------------------------------------------------------------------
36910       SUBROUTINE HWHS28(ID,ME)
36911 C-----------------------------------------------------------------------
36912 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36913 C  section  f f ---> f fbar via t-channel scalar exchange
36914 C  This is diagram 8 from RPV notes
36915 C-----------------------------------------------------------------------
36916       INCLUDE 'herwig65.inc'
36917       INTEGER NDIAHD
36918       PARAMETER(NDIAHD=10)
36919       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36920      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36921      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36922       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36923      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36924       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36925       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36926      &     MA2,SH,TH,UH,IDP,DRTYPE
36927       COMMON/HWHEWS/S(8,8,2),D(8,8)
36928       PARAMETER(ZI=(0.0D0,1.0D0))
36929       SAVE O
36930       DATA O/2,1/
36931 C--compute the propagator factor
36932       PRE = -HALF/(TH-MS(ID))
36933       DO 10 P1=1,2
36934       DO 10 P2=1,2
36935       DO 10 P3=1,2
36936       DO 10 P4=1,2
36937  10   ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A(  P1 ,ID)*
36938      &                  F4(O(P2),O(P4),2)*F3(O(P3),P1,1)
36939       END
36940 CDECK  ID>, HWHS29.
36941 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
36942 *-- Author :    Peter Richardson
36943 C-----------------------------------------------------------------------
36944       SUBROUTINE HWHS29(ID,ME)
36945 C-----------------------------------------------------------------------
36946 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36947 C  section  f f ---> f fbar via u-channel scalar exchange
36948 C  This is diagram 9 from RPV notes
36949 C-----------------------------------------------------------------------
36950       INCLUDE 'herwig65.inc'
36951       INTEGER NDIAHD
36952       PARAMETER(NDIAHD=10)
36953       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36954      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36955      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36956       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36957      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36958       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36959       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36960      &     MA2,SH,TH,UH,IDP,DRTYPE
36961       COMMON/HWHEWS/S(8,8,2),D(8,8)
36962       PARAMETER(ZI=(0.0D0,1.0D0))
36963       SAVE O
36964       DATA O/2,1/
36965 C--compute the propagator factor
36966       PRE = HALF/(UH-MS(ID))
36967       DO 10 P1=1,2
36968       DO 10 P2=1,2
36969       DO 10 P3=1,2
36970       DO 10 P4=1,2
36971  10   ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A(P1,ID)*
36972      &                  F3(O(P3),P2,2)*F4(O(P1),O(P4),1)
36973       END
36974 CDECK  ID>, HWHS30.
36975 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
36976 *-- Author :    Peter Richardson
36977 C-----------------------------------------------------------------------
36978       SUBROUTINE HWHS30(ID,ME)
36979 C-----------------------------------------------------------------------
36980 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36981 C  section  fbar fbar ---> f f via s-channel scalar exchange
36982 C  This is diagram 10 from RPV notes
36983 C-----------------------------------------------------------------------
36984       INCLUDE 'herwig65.inc'
36985       INTEGER NDIAHD
36986       PARAMETER(NDIAHD=10)
36987       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36988      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36989      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36990       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36991      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36992       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36993       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36994      &     MA2,SH,TH,UH,IDP,DRTYPE
36995       COMMON/HWHEWS/S(8,8,2),D(8,8)
36996       PARAMETER(ZI=(0.0D0,1.0D0))
36997       SAVE O
36998       DATA O/2,1/
36999 C--compute the propagator factor
37000       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
37001       DO 10 P1=1,2
37002       DO 10 P3=1,2
37003       DO 10 P4=1,2
37004       ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
37005  10   ME(P1,  P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
37006      &                    ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
37007      &                     -B(  P3 ,ID)*F4M(O(P4),  P3 ,7)*MA(3))
37008       END
37009 CDECK  ID>, HWHS31.
37010 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
37011 *-- Author :    Peter Richardson
37012 C-----------------------------------------------------------------------
37013       SUBROUTINE HWHS31(ID,ME)
37014 C-----------------------------------------------------------------------
37015 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
37016 C  section  fbar fbar ---> f f via t-channel scalar exchange
37017 C  This is diagram 11 from RPV notes
37018 C-----------------------------------------------------------------------
37019       INCLUDE 'herwig65.inc'
37020       INTEGER NDIAHD
37021       PARAMETER(NDIAHD=10)
37022       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
37023      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
37024      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
37025       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
37026      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
37027       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
37028       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
37029      &     MA2,SH,TH,UH,IDP,DRTYPE
37030       COMMON/HWHEWS/S(8,8,2),D(8,8)
37031       PARAMETER(ZI=(0.0D0,1.0D0))
37032       SAVE O
37033       DATA O/2,1/
37034 C--compute the propagator factor
37035       PRE = HALF/(TH-MS(ID))
37036       DO 10 P1=1,2
37037       DO 10 P2=1,2
37038       DO 10 P3=1,2
37039       DO 10 P4=1,2
37040  10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
37041      &                  F4M(O(P4),O(P2),2)*F3M(P1,P3,1)
37042       END
37043 CDECK  ID>, HWHS32.
37044 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
37045 *-- Author :    Peter Richardson
37046 C-----------------------------------------------------------------------
37047       SUBROUTINE HWHS32(ID,ME)
37048 C-----------------------------------------------------------------------
37049 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
37050 C  section  fbar fbar ---> f f via u-channel scalar exchange
37051 C  This is diagram 12 from RPV notes
37052 C-----------------------------------------------------------------------
37053       INCLUDE 'herwig65.inc'
37054       INTEGER NDIAHD
37055       PARAMETER(NDIAHD=10)
37056       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
37057      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
37058      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
37059       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
37060      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
37061       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
37062       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
37063      &     MA2,SH,TH,UH,IDP,DRTYPE
37064       COMMON/HWHEWS/S(8,8,2),D(8,8)
37065       PARAMETER(ZI=(0.0D0,1.0D0))
37066       SAVE O
37067       DATA O/2,1/
37068 C--compute the propagator factor
37069       PRE =-HALF/(UH-MS(ID))
37070       DO 10 P1=1,2
37071       DO 10 P2=1,2
37072       DO 10 P3=1,2
37073       DO 10 P4=1,2
37074  10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
37075      &                   F4M(O(P4),O(P1),1)*F3M(P2,P3,2)
37076       END
37077 CDECK  ID>, HWHS33.
37078 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
37079 *-- Author :    Peter Richardson
37080 C-----------------------------------------------------------------------
37081       SUBROUTINE HWHS33(ID,ME)
37082 C-----------------------------------------------------------------------
37083 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
37084 C  section  f f ---> f f via s-channel scalar exchange
37085 C  This is diagram 13 from RPV
37086 C-----------------------------------------------------------------------
37087       INCLUDE 'herwig65.inc'
37088       INTEGER NDIAHD
37089       PARAMETER(NDIAHD=10)
37090       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
37091      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
37092      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
37093       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
37094      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
37095       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
37096       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
37097      &     MA2,SH,TH,UH,IDP,DRTYPE
37098       COMMON/HWHEWS/S(8,8,2),D(8,8)
37099       PARAMETER(ZI=(0.0D0,1.0D0))
37100       SAVE O
37101       DATA O/2,1/
37102 C--compute the propagator factor
37103       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
37104       DO 10 P1=1,2
37105       DO 10 P3=1,2
37106       DO 10 P4=1,2
37107       ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
37108  10   ME(P1,  P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
37109      &     ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
37110      &      -B(  P3 ,ID)*F4M(O(P4),  P3 ,7)*MA(3))
37111       END
37112 CDECK  ID>, HWHS34.
37113 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
37114 *-- Author :    Peter Richardson
37115 C-----------------------------------------------------------------------
37116       SUBROUTINE HWHS34(ID,ME)
37117 C-----------------------------------------------------------------------
37118 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
37119 C  section  fbar fbar ---> fbar fbar via t-channel scalar exchange
37120 C  This is diagram 14 from RPV notes
37121 C-----------------------------------------------------------------------
37122       INCLUDE 'herwig65.inc'
37123       INTEGER NDIAHD
37124       PARAMETER(NDIAHD=10)
37125       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
37126      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
37127      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
37128       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
37129      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
37130       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
37131       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
37132      &     MA2,SH,TH,UH,IDP,DRTYPE
37133       COMMON/HWHEWS/S(8,8,2),D(8,8)
37134       PARAMETER(ZI=(0.0D0,1.0D0))
37135       SAVE O
37136       DATA O/2,1/
37137 C--compute the propagator factor
37138       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
37139       DO 10 P1=1,2
37140       DO 10 P3=1,2
37141       DO 10 P4=1,2
37142       ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
37143  10   ME(P1,  P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
37144      &     ( B(  P4 ,ID)*F3(P3,  P4 ,4)*S(4,8,P4)
37145      &      -B(O(P4),ID)*F3(P3,O(P4),8)*MA(4))
37146       END
37147 CDECK  ID>, HWHSS1.
37148 *CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
37149 *-- Author :    Kosuke Odagiri
37150 C-----------------------------------------------------------------------
37151       FUNCTION HWHSS1(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
37152 C-----------------------------------------------------------------------
37153 C     QQ(BAR) -> GAUGINOS
37154 C-----------------------------------------------------------------------
37155       IMPLICIT NONE
37156       DOUBLE PRECISION HWHSS1, S, T, U, M3, M4, SGN
37157       DOUBLE COMPLEX CLL, CLR, CRL, CRR
37158       HWHSS1 = DREAL(
37159      & (DCONJG(CLL)*CLL+DCONJG(CRR)*CRR)*(U-M3*M3)*(U-M4*M4)+
37160      & (DCONJG(CLR)*CLR+DCONJG(CRL)*CRL)*(T-M3*M3)*(T-M4*M4)+
37161      & (DCONJG(CLL)*CLR+DCONJG(CRL)*CRR)*2.*SGN*M3*M4*S )
37162       END
37163 CDECK  ID>, HWHSS2.
37164 *CMZ :-        -10/10/01  10:38:15  by  Peter Richardson
37165 *-- Author :    Kosuke Odagiri
37166 C-----------------------------------------------------------------------
37167       FUNCTION HWHSS2(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
37168 C-----------------------------------------------------------------------
37169 C     LL(BAR) -> GAUGINOS (including beam polarization)
37170 C-----------------------------------------------------------------------
37171       INCLUDE 'herwig65.inc'
37172       DOUBLE PRECISION HWHSS2, S, T, U, M3, M4, SGN
37173       DOUBLE COMPLEX CLL, CLR, CRL, CRR
37174       HWHSS2 =
37175 C--first the incoming left electron
37176      & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DREAL(
37177      & DCONJG(CLL)*CLL*(U-M3*M3)*(U-M4*M4)+
37178      & DCONJG(CLR)*CLR*(T-M3*M3)*(T-M4*M4)+
37179      & DCONJG(CLL)*CLR*2.*SGN*M3*M4*S )
37180 C--then the incoming right electron
37181      &+(ONE+EPOLN(3))*(ONE-PPOLN(3))*DREAL(
37182      & DCONJG(CRR)*CRR*(U-M3*M3)*(U-M4*M4)+
37183      & DCONJG(CRL)*CRL*(T-M3*M3)*(T-M4*M4)+
37184      & DCONJG(CRL)*CRR*2.*SGN*M3*M4*S )
37185       END
37186 CDECK  ID>, HWHSSG.
37187 *CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
37188 *-- Author :    Kosuke Odagiri
37189 C-----------------------------------------------------------------------
37190       SUBROUTINE HWHSSG
37191 C-----------------------------------------------------------------------
37192 C     SUSY 2 PARTON -> 2 GAUGINOS PROCESSES        (1 - 3)
37193 C                   -> GAUGINO + SPARTON PROCESSES (4 - 7)
37194 C-----------------------------------------------------------------------
37195       INCLUDE 'herwig65.inc'
37196       DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS, DIST,
37197      & ML(6), ML2(6), MR(6), MR2(6), MCH(2), MCH2(2), MNU(4), MNU2(4),
37198      & MSQK, MG, MG2, SM, DM, DAB, QPE, SGN, PF, SQPE, EMSC2,
37199      & FAC0, FACA, FACB, FACC, S, T, T3, U, U4, SN2TH
37200       DOUBLE PRECISION M1(2,2,6), M2(4,4,6), M3(2,4,6,6),
37201      & M4(4,6), M5(2,6,6), M6L(4,6), M6R(4,6), M7(2,2,6,6),
37202      & XA(4), XB(4), XC(4), XD(4), MZ, MW, XW, SQXW, S2W, S22W
37203       INTEGER I, IQ, IQ1, IQ2, IQ3, IQ4, IG1, IG2, IG3, IG4,
37204      & ID1, ID2, IGL, SSL, SSR, GLU, SSNU, SSCH, INU, ICH, IWD(6), IPB
37205       DOUBLE PRECISION DQD(6), DQU(6), HWHSS1
37206       EXTERNAL HWRGEN, HWUALF, HWUAEM, HWHSS1
37207       SAVE HCS, M1, M2, M3, M4, M5, M6L, M6R, M7
37208       PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
37209       PARAMETER (SSNU = 449, SSCH = 453, INU = 49, ICH = 53)
37210       DOUBLE COMPLEX Z, Z0, C1, C2, C3, GZ, GW, CLL, CLR, CRL, CRR
37211       PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0))
37212       EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198)), (MG, RMASS(GLU))
37213       EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1))
37214       EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1))
37215       EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2))
37216       EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2))
37217       EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
37218       EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
37219       EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
37220       EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
37221       SAVE IWD,DQD,DQU
37222       DATA IWD/2,1,4,3,6,5/
37223       DATA DQD/ONE,ZERO,ONE,ZERO,ONE,ZERO/
37224       DATA DQU/ZERO,ONE,ZERO,ONE,ZERO,ONE/
37225 C
37226       CALL    HWSGEN(.FALSE.)
37227       IF (GENEV) THEN
37228         RCS = HCS*HWRGEN(0)
37229       ELSE
37230         SN2TH = 0.25D0 - 0.25D0*COSTH**2
37231         S=XX(1)*XX(2)*PHEP(5,3)**2
37232         EMSC2 = EMSCA**2
37233         FAC0  = FACTSS*HWUAEM(EMSC2)
37234 c       prefactor for pair production, includes 1/Nc colour factor
37235         FACA  = FAC0*HWUAEM(EMSC2) / CAFAC
37236 c       prefactor for qq -> gaugino + gluino, includes CF/Nc colour factor
37237         FACB  = FAC0*HWUALF(1,EMSCA) * CFFAC / CAFAC
37238 c       prefactor for qg -> gaugino + squark, includes 1/2Nc colour factor
37239         FACC  = FACB / CFFAC / TWO
37240         MG2   = MG**2
37241         GZ    = S-MZ**2+Z*S/MZ*GAMZ
37242         GW    = S-MW**2+Z*S/MW*GAMW
37243         DO IQ = 1,6
37244           IQ1     = SSL + IQ
37245           IQ2     = SSR + IQ
37246           ML(IQ)  = RMASS(IQ1)
37247           ML2(IQ) = ML(IQ)**2
37248           MR(IQ)  = RMASS(IQ2)
37249           MR2(IQ) = MR(IQ)**2
37250         END DO
37251         XW    =   TWO * SWEIN
37252         SQXW  =   SQRT(XW)
37253         S22W  =   XW * (TWO - XW)
37254         S2W   =   SQRT(S22W)
37255         DO IG1 = 1,4
37256           MNU(IG1)  = RMASS(IG1+SSNU)
37257           MNU2(IG1) = MNU(IG1)**2
37258         END DO
37259         DO IG1 = 1,2
37260           MCH(IG1)  = RMASS(IG1+SSCH)
37261           MCH2(IG1) = MCH(IG1)**2
37262         END DO
37263 c       _     ~+ ~-
37264 c (1) q q  -> X  X
37265 c              a  b
37266         DO IG1 = 1,2
37267           DO IG2 = 1,2
37268             SM  = MCH(IG1) + MCH(IG2)
37269             QPE = S - SM**2
37270             IF (QPE.GE.ZERO) THEN
37271               DM   = MCH(IG1) - MCH(IG2)
37272               SQPE = SQRT(QPE*(S-DM**2))
37273               PF   = SQPE/S
37274               T    = (SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2)) / TWO
37275               U    = - T - S + MCH2(IG1) + MCH2(IG2)
37276               DAB  = ABS(FLOAT(IG1+IG2-3))
37277               C1   = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
37278               C2   = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
37279               SGN = WSGNSS(IG1)*WSGNSS(IG2)
37280 C--PR bug fix 31/03/00
37281               DO IQ = 1,6
37282                 C3 = -DAB*QFCH(IQ)/S
37283                 CLL = C3 - LFCH(IQ)*C1 +
37284      &        DQD(IQ)*WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-ML2(IWD(IQ)))*XW)
37285                 CLR = C3 - LFCH(IQ)*C2 -
37286      &        DQU(IQ)*WMXUSS(IG1,1)*WMXUSS(IG2,1)/((T-ML2(IWD(IQ)))*XW)
37287                 CRL = C3 - RFCH(IQ)*C1
37288                 CRR = C3 - RFCH(IQ)*C2
37289                 M1(IG1,IG2,IQ)=FACA*PF*
37290      &            HWHSS1(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
37291               END DO
37292 C--End of Fix
37293             ELSE
37294               DO IQ = 1,6
37295                 M1(IG1,IG2,IQ) = ZERO
37296               END DO
37297             END IF
37298           END DO
37299         END DO
37300 c       _     ~o ~o
37301 c (2) q q  -> X  X
37302 c              i  j
37303         DO IG1 = 1,4
37304           DO IG2 = 1,4
37305             SM   = MNU(IG1) + MNU(IG2)
37306             QPE  = S - SM**2
37307             IF (QPE.GE.ZERO) THEN
37308               DM   = MNU(IG1) - MNU(IG2)
37309               SQPE = SQRT(QPE*(S-DM**2))
37310               PF   = SQPE/S
37311               T    = (SQPE*COSTH - S + MNU2(IG1) + MNU2(IG2)) / TWO
37312               U    = - T - S + MNU2(IG1) + MNU2(IG2)
37313               C1   = (XD(IG1)*XD(IG2)-XC(IG1)*XC(IG2))/S2W/GZ
37314               C2   = - C1
37315               SGN  = ZSGNSS(IG1)*ZSGNSS(IG2)
37316               DO IQ = 1,6
37317                 CLL =LFCH(IQ)*C1+SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(U-ML2(IQ))
37318                 CLR =LFCH(IQ)*C2-SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(T-ML2(IQ))
37319                 CRL =RFCH(IQ)*C1-SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(T-MR2(IQ))
37320                 CRR =RFCH(IQ)*C2+SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(U-MR2(IQ))
37321                 M2(IG1,IG2,IQ) = FACA*PF*HALF*
37322      &            HWHSS1(S,T,U,MNU(IG1),MNU(IG2),SGN,CLL,CLR,CRL,CRR)
37323               END DO
37324             ELSE
37325               DO IQ = 1,6
37326                 M2(IG1,IG2,IQ) = ZERO
37327               END DO
37328             END IF
37329           END DO
37330         END DO
37331 c       _     ~+ ~o
37332 c (3) U D  -> X  X
37333 c              a  i
37334         DO IG1 = 1,2
37335           DO IG2 = 1,4
37336             SM  = MCH(IG1) + MNU(IG2)
37337             QPE = S - SM**2
37338             IF (QPE.GE.ZERO) THEN
37339               DM   = MCH(IG1) - MNU(IG2)
37340               SQPE = SQRT(QPE*(S-DM**2))
37341               PF   = SQPE/S
37342               T    = (SQPE*COSTH - S + MCH2(IG1) + MNU2(IG2)) / TWO
37343               U    = - T - S + MCH2(IG1) + MNU2(IG2)
37344               C1   = XA(IG2)+S2W/XW*XB(IG2)
37345 c note the new s-channel signs below. (PR BUG FIX 3/9/01)
37346               C2   = (-XD(IG2)*WMXVSS(IG1,2)/SQXW+C1*WMXVSS(IG1,1))/GW
37347               C3   = ( XC(IG2)*WMXUSS(IG1,2)/SQXW+C1*WMXUSS(IG1,1))/GW
37348               SGN = WSGNSS(IG1)*ZSGNSS(IG2)
37349               DO IQ1 = 1,3
37350                 IQ3 = IQ1*2
37351                 DO IQ2 = 1,3
37352                   IQ4 = IQ2*2-1
37353                   CLL = C2+WMXVSS(IG1,1)*SLFCH(IQ3,IG2)/(U-ML2(IQ3))
37354                   CLR = C3-WMXUSS(IG1,1)*SLFCH(IQ4,IG2)/(T-ML2(IQ4))
37355                   M3(IG1,IG2,IQ1,IQ2) = FACA*PF*VCKM(IQ1,IQ2)/XW*
37356      &              HWHSS1(S,T,U,MCH(IG1),MNU(IG2),SGN,CLL,CLR,Z0,Z0)
37357                 END DO
37358               END DO
37359             ELSE
37360               DO IQ1 = 1,3
37361                 DO IQ2 = 1,3
37362                   M3(IG1,IG2,IQ1,IQ2) = ZERO
37363                 END DO
37364               END DO
37365             END IF
37366           END DO
37367         END DO
37368 c       _     ~o ~
37369 c (4) q q  -> X  g
37370 c              i
37371         DO IG1 = 1,4
37372           SM   = MNU(IG1) + MG
37373           QPE  = S - SM**2
37374           IF (QPE.GE.ZERO) THEN
37375             DM   = MNU(IG1) - MG
37376             SQPE = SQRT(QPE*(S-DM**2))
37377             PF   = SQPE/S
37378             T    = (SQPE*COSTH - S + MG2 + MNU2(IG1)) / TWO
37379             U    = - T - S + MG2 + MNU2(IG1)
37380             DO IQ = 1,6
37381               CLL =   SLFCH(IQ,IG1)/(U-ML2(IQ))
37382               CLR = - SLFCH(IQ,IG1)/(T-ML2(IQ))
37383               CRL = - SRFCH(IQ,IG1)/(T-MR2(IQ))
37384               CRR =   SRFCH(IQ,IG1)/(U-MR2(IQ))
37385               M4(IG1,IQ) = FACB*PF*
37386      &          HWHSS1(S,T,U,MNU(IG1),MG,ZSGNSS(IG1),CLL,CLR,CRL,CRR)
37387             END DO
37388           ELSE
37389             DO IQ = 1,6
37390               M4(IG1,IQ) = ZERO
37391             END DO
37392           END IF
37393         END DO
37394 c       _     ~+ ~
37395 c (5) U D  -> X  g
37396 c              a
37397         DO IG1 = 1,2
37398           SM   = MCH(IG1) + MG
37399           QPE  = S - SM**2
37400           IF (QPE.GE.ZERO) THEN
37401             DM   = MCH(IG1) - MG
37402             SQPE = SQRT(QPE*(S-DM**2))
37403             PF   = SQPE/S
37404             T    = (SQPE*COSTH - S + MCH2(IG1) + MG2) / TWO
37405             U    = - T - S + MCH2(IG1) + MG2
37406             DO IQ1 = 1,3
37407               IQ3 = IQ1*2
37408               DO IQ2 = 1,3
37409                 IQ4 = IQ2*2-1
37410                 CLL =   WMXVSS(IG1,1)/(U-ML2(IQ3))
37411                 CLR = - WMXUSS(IG1,1)/(T-ML2(IQ4))
37412                 M5(IG1,IQ1,IQ2) = FACB*PF*VCKM(IQ1,IQ2)/XW*
37413      &            HWHSS1(S,T,U,MCH(IG1),MG,WSGNSS(IG1),CLL,CLR,Z0,Z0)
37414               END DO
37415             END DO
37416           ELSE
37417             DO IQ1 = 1,3
37418               DO IQ2 = 1,3
37419                 M5(IG1,IQ1,IQ2) = ZERO
37420               END DO
37421             END DO
37422           END IF
37423         END DO
37424 c             ~o ~
37425 c (6) g q  -> X  q
37426 c              i  LR
37427         DO IG1 = 1,4
37428           DO IQ = 1,6
37429 c           left squarks
37430             SM   = MNU(IG1)+ML(IQ)
37431             QPE  = S - SM**2
37432             IF (QPE.GE.ZERO) THEN
37433               DM   = MNU(IG1)-ML(IQ)
37434               SQPE = SQRT(QPE*(S-DM**2))
37435               PF   = SQPE/S
37436               T3   = (SQPE*COSTH - S - SM*DM) / TWO
37437               U4   = - T3 - S
37438 C--KO bug fix 06/10/00
37439               M6L(IG1,IQ) = FACC*PF*((QMIXSS(IQ,1,1)*SLFCH(IQ,IG1))**2
37440      &          +(QMIXSS(IQ,2,1)*SRFCH(IQ,IG1))**2)*
37441      &         T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
37442             ELSE
37443               M6L(IG1,IQ) = ZERO
37444             END IF
37445 c           right squarks
37446             SM   = MNU(IG1)+MR(IQ)
37447             QPE  = S - SM**2
37448             IF (QPE.GE.ZERO) THEN
37449               DM   = MNU(IG1)-MR(IQ)
37450               SQPE = SQRT(QPE*(S-DM**2))
37451               PF   = SQPE/S
37452               T3   = (SQPE*COSTH - S - SM*DM) / TWO
37453               U4   = - T3 - S
37454 C--PR bug fix 28/08/01
37455               M6R(IG1,IQ) = FACC*PF * ((QMIXSS(IQ,1,2)*SLFCH(IQ,IG1))**2
37456      &         +(QMIXSS(IQ,2,2)*SRFCH(IQ,IG1))**2)*
37457      &         T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
37458             ELSE
37459               M6R(IG1,IQ) = ZERO
37460             END IF
37461           END DO
37462         END DO
37463 c             ~+-~
37464 c (7) g q  -> X  q'
37465 c              a  L
37466         DO IG1 = 1,2
37467           DO IQ1 = 1,3
37468            IQ3 = IQ1*2
37469            DO IQ2 = 1,3
37470             IQ4 = IQ2*2-1
37471             DO I = 1,2
37472 c             U initiated processes
37473               IF (I.EQ.1) THEN
37474                 MSQK = ML(IQ4)
37475               ELSE
37476                 MSQK = MR(IQ4)
37477               END IF
37478               SM  = MCH(IG1) + MSQK
37479               QPE = S - SM**2
37480               IF (((I.EQ.1).OR.(IQ2.EQ.3)).AND.(QPE.GE.ZERO)) THEN
37481                 DM   = MCH(IG1) - MSQK
37482                 SQPE = SQRT(QPE*(S-DM**2))
37483                 PF   = SQPE/S
37484                 T3   = (SQPE*COSTH - S - SM*DM) / TWO
37485                 U4   = - T3 - S
37486                 M7(I,IG1,IQ3,IQ4)=FACC*PF*WMXUSS(IG1,1)**2*VCKM(IQ1,IQ2)
37487      &            /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
37488      &            QMIXSS(IQ4,1,I)**2
37489               ELSE
37490                 M7(I,IG1,IQ3,IQ4) = ZERO
37491               END IF
37492 c             D initiated processes
37493               IF (I.EQ.1) THEN
37494                 MSQK = ML(IQ3)
37495               ELSE
37496                 MSQK = MR(IQ3)
37497               END IF
37498               SM  = MCH(IG1) + MSQK
37499               QPE = S - SM**2
37500               IF (((I.EQ.1).OR.(IQ1.EQ.3)).AND.(QPE.GE.ZERO)) THEN
37501                 DM   = MCH(IG1) - MSQK
37502                 SQPE = SQRT(QPE*(S-DM**2))
37503                 PF   = SQPE/S
37504                 T3   = (SQPE*COSTH - S - SM*DM) / TWO
37505                 U4   = - T3 - S
37506                 M7(I,IG1,IQ4,IQ3)=FACC*PF*WMXVSS(IG1,1)**2*VCKM(IQ1,IQ2)
37507      &            /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
37508      &            QMIXSS(IQ3,1,I)**2
37509               ELSE
37510                 M7(I,IG1,IQ4,IQ3) = ZERO
37511               END IF
37512             END DO
37513            END DO
37514           END DO
37515         END DO
37516       END IF
37517       HCS = 0.
37518 c       _    _       ~+ ~-   ~o ~o   ~o ~
37519 c     q q ,  q q  -> X  X ,  X  X ,  X  g
37520 c                     a  b    i  j    i
37521       DO 1 ID1 = 1,12
37522       IF (DISF(ID1,1).LT.EPS) GOTO 1
37523       IF (ID1.GT.6) THEN
37524        ID2 = ID1 - 6
37525        IQ  = ID2
37526        IPB = 4132
37527       ELSE
37528        ID2 = ID1 + 6
37529        IQ  = ID1
37530        IPB = 2431
37531       END IF
37532       IF (DISF(ID2,2).LT.EPS) GOTO 1
37533       DIST = DISF(ID1,1)*DISF(ID2,2)
37534       DO IG1 = 1,2
37535         IG3 = ICH+IG1
37536         DO IG2 = 1,2
37537           IG4 = ICH+IG2+2
37538           HCS = HCS + DIST*M1(IG1,IG2,IQ)
37539 C--PR bug fix 10/10/01
37540           IF (GENEV.AND.HCS.GT.RCS) THEN
37541             IF(ID2.LT.ID1) COSTH=-COSTH
37542             CALL HWHSSS(IG3,0,IG4,0,2134,21)
37543             GOTO 9
37544           ENDIF
37545         END DO
37546       END DO
37547       DO IG1 = 1,4
37548         IG3 = INU+IG1
37549         DO IG2 = 1,4
37550           IG4 = INU+IG2
37551           IF (IG2.GE.IG1) HCS = HCS + DIST*M2(IG1,IG2,IQ)
37552 C--PR bug fix 10/10/01
37553           IF (GENEV.AND.HCS.GT.RCS) THEN
37554             IF(ID2.LT.ID1) COSTH=-COSTH
37555             CALL HWHSSS(IG3,0,IG4,0,2134,22)
37556             GOTO 9
37557           ENDIF
37558         END DO
37559         HCS = HCS + DIST*M4(IG1,IQ)
37560 C--PR bug fix 10/10/01
37561         IF (GENEV.AND.HCS.GT.RCS) THEN
37562           IF(ID2.LT.ID1) COSTH=-COSTH
37563           CALL HWHSSS(IG3,0,IGL,0, IPB,24)
37564           GOTO 9
37565         ENDIF
37566       END DO
37567     1 CONTINUE
37568 c       _    _       ~+-~o   ~+-~
37569 c     q q',  q q' -> X  X ,  X  g
37570 c                     a  i    a
37571 c
37572 c      _     _       _     _
37573 c     ud(+), ud(-), du(-), du(+)
37574       DO 2 IQ1 = 1, 3
37575       DO IQ2 = 1, 3
37576       IF(VCKM(IQ1,IQ2).GT.EPS) THEN
37577 c      _
37578 c     ud (+)
37579        ID1 = IQ1 * 2
37580        ID2 = IQ2 * 2 + 5
37581        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37582         DIST = DISF(ID1,1)*DISF(ID2,2)
37583         DO IG1 = 1,2
37584          IG3 = ICH+IG1
37585          DO IG2 = 1,4
37586           IG4 = INU+IG2
37587           HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
37588           IF (GENEV.AND.HCS.GT.RCS) THEN
37589             CALL HWHSSS(IG3,0,IG4,0,2134,23)
37590             GOTO 9
37591           ENDIF
37592          END DO
37593          HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
37594          IF (GENEV.AND.HCS.GT.RCS) THEN
37595            CALL HWHSSS(IG3,0,IGL,0,2431,25)
37596            GOTO 9
37597          ENDIF
37598         END DO
37599        END IF
37600 c     _
37601 c     du (+)
37602        ID1 = IQ2 * 2 + 5
37603        ID2 = IQ1 * 2
37604        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37605         DIST = DISF(ID1,1)*DISF(ID2,2)
37606         DO IG1 = 1,2
37607          IG3 = ICH+IG1
37608          DO IG2 = 1,4
37609           IG4 = INU+IG2
37610           HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
37611           IF (GENEV.AND.HCS.GT.RCS) THEN
37612             CALL HWHSSS(IG4,0,IG3,0,2134,23)
37613             GOTO 9
37614           ENDIF
37615          END DO
37616          HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
37617          IF (GENEV.AND.HCS.GT.RCS) THEN
37618            CALL HWHSSS(IGL,0,IG3,0,3124,25)
37619            GOTO 9
37620          ENDIF
37621         END DO
37622        END IF
37623 c      _
37624 c     du (-)
37625        ID1 = IQ2 * 2 - 1
37626        ID2 = IQ1 * 2 + 6
37627        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37628         DIST = DISF(ID1,1)*DISF(ID2,2)
37629         DO IG1 = 1,2
37630          IG3 = ICH+IG1+2
37631          DO IG2 = 1,4
37632           IG4 = INU+IG2
37633           HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
37634           IF (GENEV.AND.HCS.GT.RCS) THEN
37635             CALL HWHSSS(IG4,0,IG3,0,2134,23)
37636             GOTO 9
37637           ENDIF
37638          END DO
37639          HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
37640          IF (GENEV.AND.HCS.GT.RCS) THEN
37641            CALL HWHSSS(IGL,0,IG3,0,2314,25)
37642            GOTO 9
37643          ENDIF
37644         END DO
37645        END IF
37646 c     _
37647 c     ud (-)
37648        ID1 = IQ1 * 2 + 6
37649        ID2 = IQ2 * 2 - 1
37650        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37651         DIST = DISF(ID1,1)*DISF(ID2,2)
37652         DO IG1 = 1,2
37653          IG3 = ICH+IG1+2
37654          DO IG2 = 1,4
37655           IG4 = INU+IG2
37656           HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
37657           IF (GENEV.AND.HCS.GT.RCS) THEN
37658             CALL HWHSSS(IG3,0,IG4,0,2134,23)
37659             GOTO 9
37660           ENDIF
37661          END DO
37662          HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
37663          IF (GENEV.AND.HCS.GT.RCS) THEN
37664            CALL HWHSSS(IG3,0,IGL,0,4132,25)
37665            GOTO 9
37666          ENDIF
37667         END DO
37668        END IF
37669       END IF
37670       END DO
37671     2 CONTINUE
37672 c              _           _       ~o ~    ~+-~
37673 c     g q ,  g q ,  q g ,  q g  -> X  q ,  X  q'
37674 c                                   i  LR   a  L
37675 c     neutralino
37676       DO IQ1 = 1,6
37677 c
37678 c      gq
37679        ID1 = 13
37680        ID2 = IQ1
37681        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37682         DIST = DISF(ID1,1)*DISF(ID2,2)
37683         DO IG1 = 1,4
37684          IG3 = INU+IG1
37685          HCS = HCS + DIST*M6L(IG1,IQ1)
37686          IF (GENEV.AND.HCS.GT.RCS) THEN
37687            CALL HWHSSS(IG3,0,ID2,0,2431,26)
37688            GOTO 9
37689          ENDIF
37690          HCS = HCS + DIST*M6R(IG1,IQ1)
37691          IF (GENEV.AND.HCS.GT.RCS) THEN
37692            CALL HWHSSS(IG3,0,ID2,2,2431,26)
37693            GOTO 9
37694          ENDIF
37695         END DO
37696        END IF
37697 c       _
37698 c      gq
37699        ID1 = 13
37700        ID2 = IQ1 + 6
37701        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37702         DIST = DISF(ID1,1)*DISF(ID2,2)
37703         DO IG1 = 1,4
37704          IG3 = INU+IG1
37705          HCS = HCS + DIST*M6L(IG1,IQ1)
37706          IF (GENEV.AND.HCS.GT.RCS) THEN
37707            CALL HWHSSS(IG3,0,ID2,0,4132,26)
37708            GOTO 9
37709          ENDIF
37710          HCS = HCS + DIST*M6R(IG1,IQ1)
37711          IF (GENEV.AND.HCS.GT.RCS) THEN
37712            CALL HWHSSS(IG3,0,ID2,2,4132,26)
37713            GOTO 9
37714          ENDIF
37715         END DO
37716        END IF
37717 c
37718 c      qg
37719        ID1 = IQ1
37720        ID2 = 13
37721        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37722         DIST = DISF(ID1,1)*DISF(ID2,2)
37723         DO IG1 = 1,4
37724          IG3 = INU+IG1
37725          HCS = HCS + DIST*M6L(IG1,IQ1)
37726          IF (GENEV.AND.HCS.GT.RCS) THEN
37727            CALL HWHSSS(ID1,0,IG3,0,3124,26)
37728            GOTO 9
37729          ENDIF
37730          HCS = HCS + DIST*M6R(IG1,IQ1)
37731          IF (GENEV.AND.HCS.GT.RCS) THEN
37732            CALL HWHSSS(ID1,2,IG3,0,3124,26)
37733            GOTO 9
37734          ENDIF
37735         END DO
37736        END IF
37737 c      _
37738 c      qg
37739        ID1 = IQ1 + 6
37740        ID2 = 13
37741        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37742         DIST = DISF(ID1,1)*DISF(ID2,2)
37743         DO IG1 = 1,4
37744          IG3 = INU+IG1
37745          HCS = HCS + DIST*M6L(IG1,IQ1)
37746          IF (GENEV.AND.HCS.GT.RCS) THEN
37747            CALL HWHSSS(ID1,0,IG3,0,2314,26)
37748            GOTO 9
37749          ENDIF
37750          HCS = HCS + DIST*M6R(IG1,IQ1)
37751          IF (GENEV.AND.HCS.GT.RCS) THEN
37752            CALL HWHSSS(ID1,2,IG3,0,2314,26)
37753            GOTO 9
37754          ENDIF
37755         END DO
37756        END IF
37757       END DO
37758 c     chargino
37759       DO IQ1 = 1,3
37760        IQ3 = IQ1*2
37761        DO 3 IQ2 = 1,3
37762         IF (VCKM(IQ1,IQ2).LT.EPS) GOTO 3
37763         IQ4 = IQ2*2-1
37764         DO IG1 = 1,2
37765          IG3 = ICH+IG1
37766          IG4 = ICH+IG1+2
37767 c
37768 c        gq & qg
37769          ID1 = 13
37770          ID2 = IQ3
37771          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
37772          IF (GENEV.AND.HCS.GT.RCS) THEN
37773            CALL HWHSSS(IG3,0,IQ4,0,2431,27)
37774            GOTO 9
37775          ENDIF
37776          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
37777          IF (GENEV.AND.HCS.GT.RCS) THEN
37778            CALL HWHSSS(IG3,0,IQ4,2,2431,27)
37779            GOTO 9
37780          ENDIF
37781          ID2 = IQ4
37782          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
37783          IF (GENEV.AND.HCS.GT.RCS) THEN
37784            CALL HWHSSS(IG4,0,IQ3,0,2431,27)
37785            GOTO 9
37786          ENDIF
37787          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
37788          IF (GENEV.AND.HCS.GT.RCS) THEN
37789            CALL HWHSSS(IG4,0,IQ3,2,2431,27)
37790            GOTO 9
37791          ENDIF
37792          ID1 = IQ3
37793          ID2 = 13
37794          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
37795          IF (GENEV.AND.HCS.GT.RCS) THEN
37796            CALL HWHSSS(IQ4,0,IG3,0,3124,27)
37797            GOTO 9
37798          ENDIF
37799          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
37800          IF (GENEV.AND.HCS.GT.RCS) THEN
37801            CALL HWHSSS(IQ4,2,IG3,0,3124,27)
37802            GOTO 9
37803          ENDIF
37804          ID1 = IQ4
37805          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
37806          IF (GENEV.AND.HCS.GT.RCS) THEN
37807            CALL HWHSSS(IQ3,0,IG4,0,3124,27)
37808            GOTO 9
37809          ENDIF
37810          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
37811          IF (GENEV.AND.HCS.GT.RCS) THEN
37812            CALL HWHSSS(IQ3,2,IG4,0,3124,27)
37813            GOTO 9
37814          ENDIF
37815 c         _   _
37816 c        gq & qg
37817          ID1 = 13
37818          ID2 = IQ3 + 6
37819          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
37820          IF (GENEV.AND.HCS.GT.RCS) THEN
37821            CALL HWHSSS(IG4,0,IQ4,1,4132,27)
37822            GOTO 9
37823          ENDIF
37824          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
37825          IF (GENEV.AND.HCS.GT.RCS) THEN
37826            CALL HWHSSS(IG4,0,IQ4,3,4132,27)
37827            GOTO 9
37828          ENDIF
37829          ID2 = IQ4 + 6
37830          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
37831          IF (GENEV.AND.HCS.GT.RCS) THEN
37832            CALL HWHSSS(IG3,0,IQ3,1,4132,27)
37833            GOTO 9
37834          ENDIF
37835          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
37836          IF (GENEV.AND.HCS.GT.RCS) THEN
37837            CALL HWHSSS(IG3,0,IQ3,3,4132,27)
37838            GOTO 9
37839          ENDIF
37840          ID1 = IQ3 + 6
37841          ID2 = 13
37842          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
37843          IF (GENEV.AND.HCS.GT.RCS) THEN
37844            CALL HWHSSS(IQ4,1,IG4,0,2314,27)
37845            GOTO 9
37846          ENDIF
37847          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
37848          IF (GENEV.AND.HCS.GT.RCS) THEN
37849            CALL HWHSSS(IQ4,3,IG4,0,2314,27)
37850            GOTO 9
37851          ENDIF
37852          ID1 = IQ4 + 6
37853          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
37854          IF (GENEV.AND.HCS.GT.RCS) THEN
37855            CALL HWHSSS(IQ3,1,IG3,0,2314,27)
37856            GOTO 9
37857          ENDIF
37858          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
37859          IF (GENEV.AND.HCS.GT.RCS) THEN
37860            CALL HWHSSS(IQ3,3,IG3,0,2314,27)
37861            GOTO 9
37862          ENDIF
37863         END DO
37864     3  CONTINUE
37865       END DO
37866       EVWGT = HCS
37867       RETURN
37868 C---GENERATE EVENT
37869     9 IDN(1)=ID1
37870       IDN(2)=ID2
37871       IDCMF=15
37872       CALL HWETWO(.TRUE.,.TRUE.)
37873       IF (AZSPIN) THEN
37874 C Calculate coefficients for constructing spin density matrices
37875 C Set to zero for now
37876         CALL HWVZRO(7,GCOEF)
37877       END IF
37878       END
37879 CDECK  ID>, HWHSSL.
37880 *CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
37881 *-- Author :    Kosuke Odagiri
37882 C-----------------------------------------------------------------------
37883       SUBROUTINE HWHSSL
37884 C-----------------------------------------------------------------------
37885 C     SUSY 2 PARTON -> 2 SLEPTON PROCESSES
37886 C-----------------------------------------------------------------------
37887       INCLUDE 'herwig65.inc'
37888       DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
37889      & FACTR, SN2TH, MZ, MW, ME2(2,2,6,2), ME2W(2,3), EMSC2, GW2
37890       INTEGER IQ, IQ1, IQ2, ID1, ID2, IL, IL1, IL2, I, J
37891       EXTERNAL HWRGEN, HWUAEM
37892       SAVE HCS, ME2, ME2W
37893       PARAMETER (EPS = 1.D-9)
37894       DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
37895       PARAMETER (Z = (0.D0,1.D0))
37896       EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
37897 C
37898       S     = XX(1)*XX(2)*PHEP(5,3)**2
37899       EMSC2 = S
37900       EMSCA = SQRT(EMSC2)
37901       CALL    HWSGEN(.FALSE.)
37902       IF (GENEV) THEN
37903         RCS = HCS*HWRGEN(0)
37904       ELSE
37905         SN2TH = 0.25D0 - 0.25D0*COSTH**2
37906         FACTR = FACTSS*HWUAEM(EMSC2)**2/CAFAC*SN2TH
37907         GZ    = (S-MZ**2+Z*S*GAMZ/MZ)/S
37908         GW2   = ((ONE-MW**2/S)**2+(GAMW/MW)**2)*(TWO*SWEIN)**2
37909 c      _     ~  ~*
37910 c    q q  -> l  l
37911 c
37912         DO IL = 1,6
37913           DO I = 1,2
37914             DO J = 1,2
37915               IF (((I.NE.J).AND.(IL.NE.5)).OR.
37916      &            ((I.EQ.2).AND.(((IL/2)*2).EQ.IL))) THEN
37917                 QPE = -1.
37918               ELSE
37919                 ID1 = 412 + I*12 + IL
37920                 ID2 = 412 + J*12 + IL
37921                 IL1 = IL + 10
37922                 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
37923               END IF
37924               IF (QPE.GT.ZERO) THEN
37925                 PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
37926                 DO IQ = 1,2
37927                  A = QFCH(IL1)*QFCH(IQ)
37928                  BL = LFCH(IL1)/GZ
37929                  BR = RFCH(IL1)/GZ
37930                  CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
37931                  CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
37932                  D = (A+BL*LFCH(IQ))*CL+(A+BR*LFCH(IQ))*CR
37933                  E = (A+BL*RFCH(IQ))*CL+(A+BR*RFCH(IQ))*CR
37934                  ME2(I,J,IL,IQ)=FACTR*PF**3
37935      $                *DREAL(DCONJG(D)*D+DCONJG(E)*E)
37936                 END DO
37937               ELSE
37938                 ME2(I,J,IL,1)=ZERO
37939                 ME2(I,J,IL,2)=ZERO
37940               END IF
37941             END DO
37942           END DO
37943         END DO
37944 c      _     ~  ~*
37945 c    q q' -> l  v
37946 c
37947         DO IL = 1,3
37948          DO I = 1,2
37949           IF ((IL.NE.3).AND.(I.EQ.2)) THEN
37950             QPE = -1.
37951           ELSE
37952             ID1 = 411 + IL*2 + I*12
37953             ID2 = 424 + IL*2
37954             QPE = S-(RMASS(ID1)+RMASS(ID2))**2
37955           END IF
37956           IF (QPE.GT.ZERO) THEN
37957             PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
37958             ME2W(I,IL)=FACTR*PF**3/GW2
37959             IF (IL.EQ.3) ME2W(I,3)=ME2W(I,3)*LMIXSS(5,1,I)**2
37960           ELSE
37961             ME2W(I,IL)=ZERO
37962           END IF
37963          END DO
37964         END DO
37965       END IF
37966       HCS = 0.
37967 C
37968       DO 1 ID1 = 1, 12
37969        IF (DISF(ID1,1).LT.EPS) GOTO 1
37970        IF (ID1.GT.6) THEN
37971         ID2 = ID1 - 6
37972        ELSE
37973         ID2 = ID1 + 6
37974        END IF
37975        IQ  = ID1 - ((ID1-1)/2)*2
37976        IF (DISF(ID2,2).LT.EPS) GOTO 1
37977        DIST = DISF(ID1,1)*DISF(ID2,2)
37978        DO IL = 1,6
37979         DO I = 1,2
37980          DO J = 1,2
37981           IL1 = IL+I*12
37982           IL2 = IL+J*12
37983           HCS = HCS + DIST*ME2(I,J,IL,IQ)
37984           IF (GENEV.AND.HCS.GT.RCS) THEN
37985             CALL HWHSSS(IL1,2,IL2,3,2134,30)
37986             GOTO 9
37987           ENDIF
37988          END DO
37989         END DO
37990        END DO
37991     1 CONTINUE
37992 c      _     _       _     _
37993 c     ud(+), ud(-), du(-), du(+)
37994       DO 2 IQ1 = 1, 3
37995       DO IQ2 = 1, 3
37996       IF(VCKM(IQ1,IQ2).GT.EPS) THEN
37997 c      _
37998 c     ud (+)
37999        ID1 = IQ1 * 2
38000        ID2 = IQ2 * 2 + 5
38001        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
38002         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
38003         DO IL = 1,3
38004          IL1 = IL*2-1
38005          IL2 = IL1+1
38006          HCS = HCS + DIST*ME2W(1,IL)
38007          IF (GENEV.AND.HCS.GT.RCS) THEN
38008            CALL HWHSSS(IL1,5,IL2,4,2134,30)
38009            GOTO 9
38010          ENDIF
38011         END DO
38012         HCS = HCS + DIST*ME2W(2,3)
38013         IF (GENEV.AND.HCS.GT.RCS) THEN
38014           CALL HWHSSS(5,7,6,4,2134,30)
38015           GOTO 9
38016         ENDIF
38017        END IF
38018 c     _
38019 c     du (+)
38020        ID1 = IQ2 * 2 + 5
38021        ID2 = IQ1 * 2
38022        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
38023         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
38024         DO IL = 1,3
38025          IL1 = IL*2-1
38026          IL2 = IL1+1
38027          HCS = HCS + DIST*ME2W(1,IL)
38028          IF (GENEV.AND.HCS.GT.RCS) THEN
38029            CALL HWHSSS(IL1,5,IL2,4,2134,30)
38030            GOTO 9
38031          ENDIF
38032         END DO
38033         HCS = HCS + DIST*ME2W(2,3)
38034         IF (GENEV.AND.HCS.GT.RCS) THEN
38035           CALL HWHSSS(5,7,6,4,2134,30)
38036           GOTO 9
38037         ENDIF
38038        END IF
38039 c      _
38040 c     du (-)
38041        ID1 = IQ2 * 2 - 1
38042        ID2 = IQ1 * 2 + 6
38043        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
38044         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
38045         DO IL = 1,3
38046          IL1 = IL*2-1
38047          IL2 = IL1+1
38048          HCS = HCS + DIST*ME2W(1,IL)
38049          IF (GENEV.AND.HCS.GT.RCS) THEN
38050            CALL HWHSSS(IL1,4,IL2,5,2134,30)
38051            GOTO 9
38052          ENDIF
38053         END DO
38054         HCS = HCS + DIST*ME2W(2,3)
38055         IF (GENEV.AND.HCS.GT.RCS) THEN
38056           CALL HWHSSS(5,6,6,5,2134,30)
38057           GOTO 9
38058         ENDIF
38059        END IF
38060 c     _
38061 c     ud (-)
38062        ID1 = IQ1 * 2 + 6
38063        ID2 = IQ2 * 2 - 1
38064        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
38065         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
38066         DO IL = 1,3
38067          IL1 = IL*2-1
38068          IL2 = IL1+1
38069          HCS = HCS + DIST*ME2W(1,IL)
38070          IF (GENEV.AND.HCS.GT.RCS) THEN
38071            CALL HWHSSS(IL1,4,IL2,5,2134,30)
38072            GOTO 9
38073          ENDIF
38074         END DO
38075         HCS = HCS + DIST*ME2W(2,3)
38076         IF (GENEV.AND.HCS.GT.RCS) THEN
38077           CALL HWHSSS(5,6,6,5,2134,30)
38078           GOTO 9
38079         ENDIF
38080        END IF
38081       END IF
38082       END DO
38083     2 CONTINUE
38084       EVWGT = HCS
38085       RETURN
38086 C---GENERATE EVENT
38087     9 IDN(1)=ID1
38088       IDN(2)=ID2
38089       IDCMF=15
38090       CALL HWETWO(.TRUE.,.TRUE.)
38091       IF (AZSPIN) THEN
38092 C Calculate coefficients for constructing spin density matrices
38093 C Set to zero for now
38094         CALL HWVZRO(7,GCOEF)
38095       END IF
38096       END
38097 CDECK  ID>, HWHSSQ.
38098 *CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
38099 *-- Author :    Kosuke Odagiri
38100 C-----------------------------------------------------------------------
38101       SUBROUTINE HWHSSQ
38102 C-----------------------------------------------------------------------
38103 C     SUSY HARD 2 PARTON -> 2 SPARTON PROCESSES
38104 C-----------------------------------------------------------------------
38105       INCLUDE 'herwig65.inc'
38106       DOUBLE PRECISION HWRGEN, HWUALF, EPS, HCS, RCS, DIST, NC, NC2,
38107      & NC2C, ML2(6), ML4(6), MR2(6), MR4(6), MG2, SM, DM, QPE,
38108      & SQPE, FACTR, AFAC, AF, BONE, CFAC, CFC2, CFC3, CONE,
38109      & CONN, CONT, CONU, CONL, CONR, DFAC, DONE, PF, S,
38110      & S2, TT, TT2, TMG, TMG2, UU, UU2, UMG, UMG2,
38111      & L, L2, TTML, UUML, R, R2, TTMR, UUMR, SN2TH
38112       DOUBLE PRECISION
38113      & AUSTLL(6),   AUSTRR(6),
38114      & ASTULL(6,6), ASTURR(6,6), ASTULR(6,6), ASTURL(6,6),
38115      & AUTSLL(6,6), AUTSRR(6,6), AUTSLR(6,6), AUTSRL(6,6),
38116      & BSTULL(6),   BSTURR(6),   BSTULR(6),   BSTURL(6),
38117      & BSUTLL(6),   BSUTRR(6),   BSUTLR(6),   BSUTRL(6),
38118      & BUTSLL(6),   BUTSRR(6),   BUTSLR(6),   BUTSRL(6),
38119      & BUSTLL(6),   BUSTRR(6),   BUSTLR(6),   BUSTRL(6),
38120      & CSTU(6), CSUT(6), CSTUL(6), CSTUR(6), CSUTL(6), CSUTR(6),
38121      & CTSUL(6), CTSUR(6), CTUSL(6), CTUSR(6), DUTS, DTSU, DSTU
38122       INTEGER IQ, IQ1, IQ2, ID1, ID2, ID2MIN, IGL, SSL, SSR, GLU
38123       EXTERNAL HWRGEN, HWUALF
38124       SAVE HCS, AUSTLL, AUSTRR, ASTULL, ASTURR, ASTULR, ASTURL,
38125      & AUTSLL, AUTSRR, AUTSLR, AUTSRL, BSTULL, BSTURR, BSTULR,
38126      & BSTURL, BSUTLL, BSUTRR, BSUTLR, BSUTRL, BUTSLL, BUTSRR, BUTSLR,
38127      & BUTSRL, BUSTLL, BUSTRR, BUSTLR, BUSTRL, CSTU, CSUT, CSTUL, CSTUR,
38128      & CSUTL, CSUTR, CTSUL, CTSUR, CTUSL, CTUSR, DUTS, DTSU, DSTU
38129       PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
38130       CALL    HWSGEN(.FALSE.)
38131       IF (GENEV) THEN
38132         RCS = HCS*HWRGEN(0)
38133       ELSE
38134         SN2TH = 0.25D0 - 0.25D0*COSTH**2
38135         S     = XX(1)*XX(2)*PHEP(5,3)**2
38136         FACTR = FACTSS*HWUALF(1,EMSCA)**2
38137         NC    = CAFAC
38138         NC2   = NC**2
38139         NC2C  = ONE - ONE/NC2
38140         AFAC  = FACTR*NC2C/FOUR
38141         CFAC  = FACTR*CFFAC/FOUR
38142         CFC2  = FACTR/CFFAC/FOUR
38143         CFC3  = FACTR/FOUR
38144         DFAC  = FACTR/NC2C
38145         S2    = S**2
38146         MG2   = RMASS(GLU)**2
38147         DO 10 IQ = 1, 6
38148           IQ1     = SSL + IQ
38149           IQ2     = SSR + IQ
38150           ML2(IQ) = RMASS(IQ1)**2
38151           ML4(IQ) = ML2(IQ)**2
38152           MR2(IQ) = RMASS(IQ2)**2
38153           MR4(IQ) = MR2(IQ)**2
38154    10   CONTINUE
38155 c     gluino pair production
38156         QPE  = S - FOUR*MG2
38157         IF (QPE.GE.ZERO) THEN
38158           SQPE = SQRT(S*QPE)
38159           PF   = SQPE/S
38160           TT   = (SQPE*COSTH - S) / TWO
38161           TT2  = TT**2
38162           UU   = - S - TT
38163           UU2  = UU**2
38164 c            ~ ~
38165 c     g g -> g g
38166 c
38167           DONE =
38168      &     DFAC*PF/TWO*(UU2+TT2+FOUR*MG2*S*SQPE**2*SN2TH/TT/UU)/S2/TT/UU
38169           DUTS = DONE*UU2
38170           DTSU = DONE*TT2
38171           DSTU = DONE*S2
38172 c       _    ~ ~
38173 c     q q -> g g
38174 c
38175           DO 21 IQ = 1, 6
38176             L    = ML2(IQ)-MG2
38177             L2   = L**2
38178             TTML = TT-L
38179             UUML = UU-L
38180             R    = MR2(IQ)-MG2
38181             R2   = R**2
38182             TTMR = TT-R
38183             UUMR = UU-R
38184             CONE = TWO*PF**2*SN2TH
38185             CONL = CONE/UUML/TTML
38186             CONR = CONE/UUMR/TTMR
38187             CONT = (UU2-L2)*CONL+(UU2-R2)*CONR+L2/TTML**2+R2/TTMR**2
38188             CONU = (TT2-L2)*CONL+(TT2-R2)*CONR+L2/UUML**2+R2/UUMR**2
38189             CONN = CFAC*(PF-PF/NC2/(CONT+CONU)*( S2*(CONL+CONR)+
38190      &            L2*((TT-UU)*CONL/CONE)**2+R2*((TT-UU)*CONR/CONE)**2 ))
38191             CSTU(IQ) = CONT*CONN
38192             CSUT(IQ) = CONU*CONN
38193    21     CONTINUE
38194         ELSE
38195           DUTS = ZERO
38196           DTSU = ZERO
38197           DSTU = ZERO
38198           DO 23 IQ = 1, 6
38199             CSTU(IQ) = ZERO
38200             CSUT(IQ) = ZERO
38201    23     CONTINUE
38202         END IF
38203 c     left handed squark (identical flavour) pair production
38204         DO 22 IQ = 1, 6
38205           QPE = S - FOUR*ML2(IQ)
38206           IF (QPE.GE.ZERO) THEN
38207             SQPE = SQRT(S*QPE)
38208             PF   = SQPE/S
38209             TT   = (SQPE*COSTH - S) / TWO
38210             TT2  = TT**2
38211             UU   = - S - TT
38212             UU2  = UU**2
38213 c            ~ ~*
38214 c     g g -> q q
38215 c             L L
38216             CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+ML4(IQ))/TT2/UU2
38217             CONN = CONE-CONE*S2/(TT2+UU2)/NC2
38218             CSTUL(IQ)  = CONN*UU2
38219             CSUTL(IQ)  = CONN*TT2
38220 c            ~ ~
38221 c     q q -> q q
38222 c             L L
38223             TMG  = TT+ML2(IQ)-MG2
38224             TMG2 = TMG**2
38225             UMG  = UU+ML2(IQ)-MG2
38226             UMG2 = UMG**2
38227             BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
38228             BSTULL(IQ) = BONE/TMG2
38229             BSUTLL(IQ) = BONE/UMG2
38230 c       _    ~ ~*
38231 c     q q -> q q
38232 c             L L
38233             AF   = AFAC*PF*PF**2*SN2TH
38234             BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
38235             BUTSLL(IQ) = BONE*S2
38236             BUSTLL(IQ) = BONE*TWO*TMG2
38237 c       _     ~ ~*
38238 c     q q  -> q'q'       q =/= q'
38239 c              L L
38240             AUSTLL(IQ) = TWO*AF
38241           ELSE
38242             CSTUL(IQ)  = ZERO
38243             CSUTL(IQ)  = ZERO
38244             BSTULL(IQ) = ZERO
38245             BSUTLL(IQ) = ZERO
38246             BUTSLL(IQ) = ZERO
38247             BUSTLL(IQ) = ZERO
38248             AUSTLL(IQ) = ZERO
38249           END IF
38250 c     right handed squark (identical flavour) pair production
38251           QPE = S - FOUR*MR2(IQ)
38252           IF (QPE.GE.ZERO) THEN
38253             SQPE = SQRT(S*QPE)
38254             PF   = SQPE/S
38255             TT   = (SQPE*COSTH - S) / TWO
38256             TT2  = TT**2
38257             UU   = - S - TT
38258             UU2  = UU**2
38259 c            ~ ~*
38260 c     g g -> q q
38261 c             R R
38262             CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+MR4(IQ))/TT2/UU2
38263             CONN = CONE-CONE*S2/(TT2+UU2)/NC2
38264             CSTUR(IQ) = CONN*UU2
38265             CSUTR(IQ) = CONN*TT2
38266 c            ~ ~
38267 c     q q -> q q
38268 c             R R
38269             TMG  = TT+MR2(IQ)-MG2
38270             TMG2 = TMG**2
38271             UMG  = UU+MR2(IQ)-MG2
38272             UMG2 = UMG**2
38273             BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
38274             BSTURR(IQ) = BONE/TMG2
38275             BSUTRR(IQ) = BONE/UMG2
38276 c       _    ~ ~*
38277 c     q q -> q q
38278 c             R R
38279             AF = AFAC*PF*PF**2*SN2TH
38280             BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
38281             BUTSRR(IQ) = BONE*S2
38282             BUSTRR(IQ) = BONE*TWO*TMG2
38283 c       _     ~ ~*
38284 c     q q  -> q'q'       q =/= q'
38285 c              R R
38286             AUSTRR(IQ) = TWO*AF
38287           ELSE
38288             CSTUR(IQ)  = ZERO
38289             CSUTR(IQ)  = ZERO
38290             BSTURR(IQ) = ZERO
38291             BSUTRR(IQ) = ZERO
38292             BUTSRR(IQ) = ZERO
38293             BUSTRR(IQ) = ZERO
38294             AUSTRR(IQ) = ZERO
38295           END IF
38296 c     left and right handed squark (identical flavour) pair production
38297           IQ1  = SSL + IQ
38298           IQ2  = SSR + IQ
38299           SM   = RMASS(IQ1)+RMASS(IQ2)
38300           QPE  = S - SM**2
38301           IF (QPE.GE.ZERO) THEN
38302             DM   = RMASS(IQ1)-RMASS(IQ2)
38303             SQPE = SQRT( QPE*(S-DM**2) )
38304             PF   = SQPE/S
38305             AF   = AFAC*PF
38306             TT   = (SQPE*COSTH - S - SM*DM) / TWO
38307             UU   = - S - TT
38308             TMG  = TT + ML2(IQ) - MG2
38309             TMG2 = TMG**2
38310             UMG  = UU + MR2(IQ) - MG2
38311             UMG2 = UMG**2
38312 c            ~ ~
38313 c     q q -> q q
38314 c             L R
38315             BONE = AFAC*PF*SQPE**2*SN2TH
38316             BSTULR(IQ) = BONE/TMG2
38317             BSUTLR(IQ) = BONE/UMG2
38318 c       _    ~ ~*
38319 c     q q -> q q
38320 c             L R
38321             BUTSLR(IQ) = AFAC*PF*MG2*S/TMG2
38322             BUSTLR(IQ) = ZERO
38323             TT   = (SQPE*COSTH - S + SM*DM) / TWO
38324             UU   = - S - TT
38325             TMG  = TT + MR2(IQ) - MG2
38326             TMG2 = TMG**2
38327             UMG  = UU + ML2(IQ) - MG2
38328             UMG2 = UMG**2
38329 c            ~ ~
38330 c     q q -> q q
38331 c             R L
38332 c            BONE = AFAC*PF*SQPE**2*SN2TH
38333 c            BSTURL(IQ) = BONE/TMG2
38334 c            BSUTRL(IQ) = BONE/UMG2
38335             BSTURL(IQ) = ZERO
38336             BSUTRL(IQ) = ZERO
38337 c       _    ~ ~*
38338 c     q q -> q q
38339 c             R L
38340             BUTSRL(IQ) = AFAC*PF*MG2*S/TMG2
38341             BUSTRL(IQ) = ZERO
38342           ELSE
38343             BSTULR(IQ) = ZERO
38344             BSUTLR(IQ) = ZERO
38345             BUTSLR(IQ) = ZERO
38346             BUSTLR(IQ) = ZERO
38347             BSTURL(IQ) = ZERO
38348             BSUTRL(IQ) = ZERO
38349             BUTSRL(IQ) = ZERO
38350             BUSTRL(IQ) = ZERO
38351           END IF
38352    22   CONTINUE
38353 c     distinct flavours - gq, qq'
38354         DO 11 ID1 = 1, 6
38355           IQ1  = SSL + ID1
38356           SM   = RMASS(GLU)+RMASS(IQ1)
38357           QPE  = S - SM**2
38358           IF (QPE.GE.ZERO) THEN
38359             DM   = RMASS(GLU)-RMASS(IQ1)
38360             SQPE = SQRT( QPE*(S-DM**2) )
38361             PF   = SQPE/S
38362             TT   = (SQPE*COSTH - S - SM*DM) / TWO
38363             TT2  = TT**2
38364             UU   = - S - TT
38365             UU2  = UU**2
38366 c            ~ ~
38367 c     g q -> g q
38368 c               L
38369             CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+ML2(ID1)/UU))/S/TT/UU
38370             CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
38371             CTSUL(ID1) = CONN*UU2
38372             CTUSL(ID1) = CONN*S2
38373           ELSE
38374             CTSUL(ID1) = ZERO
38375             CTUSL(ID1) = ZERO
38376           END IF
38377           IQ2  = SSR + ID1
38378           SM   = RMASS(GLU)+RMASS(IQ2)
38379           QPE  = S - SM**2
38380           IF (QPE.GE.ZERO) THEN
38381             DM   = RMASS(GLU)-RMASS(IQ2)
38382             SQPE = SQRT( QPE*(S-DM**2) )
38383             PF   = SQPE/S
38384             TT   = (SQPE*COSTH - S - SM*DM) / TWO
38385             TT2  = TT**2
38386             UU   = - S - TT
38387             UU2  = UU**2
38388 c            ~ ~
38389 c     g q -> g q
38390 c               R
38391             CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+MR2(ID1)/UU))/S/TT/UU
38392             CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
38393             CTSUR(ID1) = CONN*UU2
38394             CTUSR(ID1) = CONN*S2
38395           ELSE
38396             CTSUR(ID1) = ZERO
38397             CTUSR(ID1) = ZERO
38398           END IF
38399           IF(ID1.EQ.6) GOTO 11
38400           ID2MIN = ID1+1
38401           DO 12 ID2 = ID2MIN, 6
38402             IQ1  = SSL + ID1
38403             IQ2  = SSL + ID2
38404             SM   = RMASS(IQ1)+RMASS(IQ2)
38405             QPE  = S - SM**2
38406             IF (QPE.GE.ZERO) THEN
38407               DM   = RMASS(IQ1)-RMASS(IQ2)
38408               SQPE = SQRT( QPE*(S-DM**2) )
38409               PF   = SQPE/S
38410               TT   = (SQPE*COSTH - S - SM*DM) / TWO
38411               UU   = - S - TT
38412               TMG  = TT+ML2(ID1)-MG2
38413               AF   = AFAC*PF/TMG/TMG
38414 c             ~ ~
38415 c     q q' -> q q'
38416 c              L L
38417               ASTULL(ID1,ID2) = AF*MG2*S
38418               ASTULL(ID2,ID1) = ASTULL(ID1,ID2)
38419 c       _     ~ ~*
38420 c     q q' -> q q'
38421 c              L L
38422               AUTSLL(ID1,ID2) = AF*SQPE**2*SN2TH
38423               AUTSLL(ID2,ID1) = AUTSLL(ID1,ID2)
38424             ELSE
38425               ASTULL(ID1,ID2) = ZERO
38426               ASTULL(ID2,ID1) = ZERO
38427               AUTSLL(ID1,ID2) = ZERO
38428               AUTSLL(ID2,ID1) = ZERO
38429             END IF
38430             IQ1  = SSR + ID1
38431             IQ2  = SSR + ID2
38432             SM   = RMASS(IQ1)+RMASS(IQ2)
38433             QPE  = S - SM**2
38434             IF (QPE.GE.ZERO) THEN
38435               DM   = RMASS(IQ1)-RMASS(IQ2)
38436               SQPE = SQRT( QPE*(S-DM**2) )
38437               PF   = SQPE/S
38438               TT   = (SQPE*COSTH - S - SM*DM) / TWO
38439               UU   = - S - TT
38440               TMG  = TT+MR2(ID1)-MG2
38441               AF   = AFAC*PF/TMG/TMG
38442 c             ~ ~
38443 c     q q' -> q q'
38444 c              R R
38445               ASTURR(ID1,ID2) = AF*MG2*S
38446               ASTURR(ID2,ID1) = ASTURR(ID1,ID2)
38447 c       _     ~ ~*
38448 c     q q' -> q q'
38449 c              R R
38450               AUTSRR(ID1,ID2) = AF*SQPE**2*SN2TH
38451               AUTSRR(ID2,ID1) = AUTSRR(ID1,ID2)
38452             ELSE
38453               ASTURR(ID1,ID2) = ZERO
38454               ASTURR(ID2,ID1) = ZERO
38455               AUTSRR(ID1,ID2) = ZERO
38456               AUTSRR(ID2,ID1) = ZERO
38457             END IF
38458             IQ1  = SSL + ID1
38459             IQ2  = SSR + ID2
38460             SM   = RMASS(IQ1)+RMASS(IQ2)
38461             QPE  = S - SM**2
38462             IF (QPE.GE.ZERO) THEN
38463               DM   = RMASS(IQ1)-RMASS(IQ2)
38464               SQPE = SQRT( QPE*(S-DM**2) )
38465               PF   = SQPE/S
38466               TT   = (SQPE*COSTH - S - SM*DM) / TWO
38467               UU   = - S - TT
38468               TMG  = TT+ML2(ID1)-MG2
38469               AF   = AFAC*PF/TMG/TMG
38470 c             ~ ~
38471 c     q q' -> q q'
38472 c              L R
38473               ASTULR(ID1,ID2) = AF*SQPE**2*SN2TH
38474               ASTULR(ID2,ID1) = ASTULR(ID1,ID2)
38475 c       _     ~ ~*
38476 c     q q' -> q q'
38477 c              L R
38478               AUTSLR(ID1,ID2) = AF*MG2*S
38479               AUTSLR(ID2,ID1) = AUTSLR(ID1,ID2)
38480               TT   = (SQPE*COSTH - S + SM*DM) / TWO
38481               UU   = - S - TT
38482               TMG    = TT+MR2(ID1)-MG2
38483               AF   = AFAC*PF/TMG/TMG
38484 c             ~ ~
38485 c     q q' -> q q'
38486 c              R L
38487               ASTURL(ID1,ID2) = AF*SQPE**2*SN2TH
38488               ASTURL(ID2,ID1) = ASTULR(ID1,ID2)
38489 c       _     ~ ~*
38490 c     q q' -> q q'
38491 c              R L
38492               AUTSRL(ID1,ID2) = AF*MG2*S
38493               AUTSRL(ID2,ID1) = AUTSLR(ID1,ID2)
38494             ELSE
38495               ASTULR(ID1,ID2) = ZERO
38496               ASTULR(ID2,ID1) = ZERO
38497               AUTSLR(ID1,ID2) = ZERO
38498               AUTSLR(ID2,ID1) = ZERO
38499               ASTURL(ID1,ID2) = ZERO
38500               ASTURL(ID2,ID1) = ZERO
38501               AUTSRL(ID1,ID2) = ZERO
38502               AUTSRL(ID2,ID1) = ZERO
38503             END IF
38504    12     CONTINUE
38505    11   CONTINUE
38506       END IF
38507       HCS = ZERO
38508       DO 6 ID1 = 1, 13
38509       IF (DISF(ID1,1).LT.EPS) GOTO 6
38510       DO 5 ID2 = 1, 13
38511       IF (DISF(ID2,2).LT.EPS) GOTO 5
38512       DIST = DISF(ID1,1)*DISF(ID2,2)
38513       IF (ID1.LT.7) THEN
38514        IQ1 = ID1
38515        IF (ID2.LT.7) THEN
38516         IQ2 = ID2
38517         IF (IQ1.NE.IQ2) THEN
38518 c        ~ ~
38519 c qq' -> q q'
38520          HCS = HCS + ASTULL(IQ1,IQ2)*DIST
38521          IF (GENEV.AND.HCS.GT.RCS) THEN
38522            CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38523            GOTO 9
38524          ENDIF
38525          HCS = HCS + ASTURR(IQ1,IQ2)*DIST
38526          IF (GENEV.AND.HCS.GT.RCS) THEN
38527            CALL HWHSSS(IQ1,2,IQ2,2,3421,10)
38528            GOTO 9
38529          ENDIF
38530          HCS = HCS + ASTULR(IQ1,IQ2)*DIST
38531          IF (GENEV.AND.HCS.GT.RCS) THEN
38532            CALL HWHSSS(IQ1,0,IQ2,2,3421,10)
38533            GOTO 9
38534          ENDIF
38535          HCS = HCS + ASTURL(IQ1,IQ2)*DIST
38536          IF (GENEV.AND.HCS.GT.RCS) THEN
38537            CALL HWHSSS(IQ1,2,IQ2,0,3421,10)
38538            GOTO 9
38539          ENDIF
38540         ELSE
38541 c        ~ ~
38542 c qq  -> q q
38543          HCS = HCS +     BSTULL(IQ1)*DIST
38544          IF (GENEV.AND.HCS.GT.RCS) THEN
38545            CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38546            GOTO 9
38547          ENDIF
38548          HCS = HCS +     BSTURR(IQ1)*DIST
38549          IF (GENEV.AND.HCS.GT.RCS) THEN
38550            CALL HWHSSS(IQ1,2,IQ2,2,3421,10)
38551            GOTO 9
38552          ENDIF
38553          HCS = HCS +     BSTULR(IQ1)*DIST
38554          IF (GENEV.AND.HCS.GT.RCS) THEN
38555            CALL HWHSSS(IQ1,0,IQ2,2,3421,10)
38556            GOTO 9
38557          ENDIF
38558          HCS = HCS +     BSTURL(IQ1)*DIST
38559          IF (GENEV.AND.HCS.GT.RCS) THEN
38560            CALL HWHSSS(IQ1,2,IQ2,0,3421,10)
38561            GOTO 9
38562          ENDIF
38563          HCS = HCS +     BSUTLL(IQ1)*DIST
38564          IF (GENEV.AND.HCS.GT.RCS) THEN
38565            CALL HWHSSS(IQ1,0,IQ2,0,4312,10)
38566            GOTO 9
38567          ENDIF
38568          HCS = HCS +     BSUTRR(IQ1)*DIST
38569          IF (GENEV.AND.HCS.GT.RCS) THEN
38570            CALL HWHSSS(IQ1,2,IQ2,2,4312,10)
38571            GOTO 9
38572          ENDIF
38573          HCS = HCS +     BSUTLR(IQ1)*DIST
38574          IF (GENEV.AND.HCS.GT.RCS) THEN
38575            CALL HWHSSS(IQ1,0,IQ2,2,4312,10)
38576            GOTO 9
38577          ENDIF
38578          HCS = HCS +     BSUTRL(IQ1)*DIST
38579          IF (GENEV.AND.HCS.GT.RCS) THEN
38580            CALL HWHSSS(IQ1,2,IQ2,0,4312,10)
38581            GOTO 9
38582          ENDIF
38583         END IF
38584        ELSEIF (ID2.NE.13) THEN
38585         IQ2 = ID2-6
38586         IF (IQ1.NE.IQ2) THEN
38587 c  _     ~ ~*
38588 c qq' -> q q'
38589          HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
38590          IF (GENEV.AND.HCS.GT.RCS) THEN
38591            CALL HWHSSS(IQ1,0,IQ2,1,3142,10)
38592            GOTO 9
38593          ENDIF
38594          HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
38595          IF (GENEV.AND.HCS.GT.RCS) THEN
38596            CALL HWHSSS(IQ1,2,IQ2,3,3142,10)
38597            GOTO 9
38598          ENDIF
38599          HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
38600          IF (GENEV.AND.HCS.GT.RCS) THEN
38601            CALL HWHSSS(IQ1,0,IQ2,3,3142,10)
38602            GOTO 9
38603          ENDIF
38604          HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
38605          IF (GENEV.AND.HCS.GT.RCS) THEN
38606            CALL HWHSSS(IQ1,2,IQ2,1,3142,10)
38607            GOTO 9
38608          ENDIF
38609         ELSE
38610 c  _     ~ ~*
38611 c qq  -> q'q'   (q =/= q')
38612          DO 30 IQ = 1, 6
38613          IF (IQ .EQ.IQ1) GOTO 30
38614          HCS = HCS +     AUSTLL(IQ )*DIST
38615          IF (GENEV.AND.HCS.GT.RCS) THEN
38616            CALL HWHSSS(IQ ,0,IQ ,1,2413,10)
38617            GOTO 9
38618          ENDIF
38619          HCS = HCS +     AUSTRR(IQ )*DIST
38620          IF (GENEV.AND.HCS.GT.RCS) THEN
38621            CALL HWHSSS(IQ ,2,IQ ,3,2413,10)
38622            GOTO 9
38623          ENDIF
38624   30     CONTINUE
38625 c  _     ~ ~*
38626 c qq  -> q q
38627          HCS = HCS +     BUTSLL(IQ1)*DIST
38628          IF (GENEV.AND.HCS.GT.RCS) THEN
38629            CALL HWHSSS(IQ1,0,IQ2,1,3142,10)
38630            GOTO 9
38631          ENDIF
38632          HCS = HCS +     BUTSRR(IQ1)*DIST
38633          IF (GENEV.AND.HCS.GT.RCS) THEN
38634            CALL HWHSSS(IQ1,2,IQ2,3,3142,10)
38635            GOTO 9
38636          ENDIF
38637          HCS = HCS +     BUTSLR(IQ1)*DIST
38638          IF (GENEV.AND.HCS.GT.RCS) THEN
38639            CALL HWHSSS(IQ1,0,IQ2,3,3142,10)
38640            GOTO 9
38641          ENDIF
38642          HCS = HCS +     BUTSRL(IQ1)*DIST
38643          IF (GENEV.AND.HCS.GT.RCS) THEN
38644            CALL HWHSSS(IQ1,2,IQ2,1,3142,10)
38645            GOTO 9
38646          ENDIF
38647          HCS = HCS +     BUSTLL(IQ1)*DIST
38648          IF (GENEV.AND.HCS.GT.RCS) THEN
38649            CALL HWHSSS(IQ1,0,IQ2,1,2413,10)
38650            GOTO 9
38651          ENDIF
38652          HCS = HCS +     BUSTRR(IQ1)*DIST
38653          IF (GENEV.AND.HCS.GT.RCS) THEN
38654            CALL HWHSSS(IQ1,2,IQ2,3,2413,10)
38655            GOTO 9
38656          ENDIF
38657          HCS = HCS +     BUSTLR(IQ1)*DIST
38658          IF (GENEV.AND.HCS.GT.RCS) THEN
38659            CALL HWHSSS(IQ1,0,IQ2,3,2413,10)
38660            GOTO 9
38661          ENDIF
38662          HCS = HCS +     BUSTRL(IQ1)*DIST
38663          IF (GENEV.AND.HCS.GT.RCS) THEN
38664            CALL HWHSSS(IQ1,2,IQ2,1,2413,10)
38665            GOTO 9
38666          ENDIF
38667          IQ  = IGL
38668 c  _     ~ ~
38669 c qq  -> g g
38670          HCS = HCS +       CSTU(IQ1)*DIST
38671          IF (GENEV.AND.HCS.GT.RCS) THEN
38672            CALL HWHSSS(IQ ,0,IQ ,0,2413,10)
38673            GOTO 9
38674          ENDIF
38675          HCS = HCS +       CSUT(IQ1)*DIST
38676          IF (GENEV.AND.HCS.GT.RCS) THEN
38677            CALL HWHSSS(IQ ,0,IQ ,0,2341,10)
38678            GOTO 9
38679          ENDIF
38680         END IF
38681        ELSE
38682          IQ2 = IGL
38683 c        ~ ~
38684 c qg  -> q g
38685          HCS = HCS +      CTSUL(IQ1)*DIST
38686          IF (GENEV.AND.HCS.GT.RCS) THEN
38687            CALL HWHSSS(IQ1,0,IQ2,0,3142,10)
38688            GOTO 9
38689          ENDIF
38690          HCS = HCS +      CTSUR(IQ1)*DIST
38691          IF (GENEV.AND.HCS.GT.RCS) THEN
38692            CALL HWHSSS(IQ1,2,IQ2,0,3142,10)
38693            GOTO 9
38694          ENDIF
38695          HCS = HCS +      CTUSL(IQ1)*DIST
38696          IF (GENEV.AND.HCS.GT.RCS) THEN
38697            CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38698            GOTO 9
38699          ENDIF
38700          HCS = HCS +      CTUSR(IQ1)*DIST
38701          IF (GENEV.AND.HCS.GT.RCS) THEN
38702            CALL HWHSSS(IQ1,2,IQ2,0,3421,10)
38703            GOTO 9
38704          ENDIF
38705        END IF
38706       ELSEIF (ID1.NE.13) THEN
38707        IQ1 = ID1 - 6
38708        IF (ID2.LT.7) THEN
38709         IQ2 = ID2
38710         IF (IQ1.NE.IQ2) THEN
38711 c _      ~*~
38712 c qq' -> q q'
38713          HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
38714          IF (GENEV.AND.HCS.GT.RCS) THEN
38715            CALL HWHSSS(IQ1,1,IQ2,0,2413,10)
38716            GOTO 9
38717          ENDIF
38718          HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
38719          IF (GENEV.AND.HCS.GT.RCS) THEN
38720            CALL HWHSSS(IQ1,3,IQ2,2,2413,10)
38721            GOTO 9
38722          ENDIF
38723          HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
38724          IF (GENEV.AND.HCS.GT.RCS) THEN
38725            CALL HWHSSS(IQ1,1,IQ2,2,2413,10)
38726            GOTO 9
38727          ENDIF
38728          HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
38729          IF (GENEV.AND.HCS.GT.RCS) THEN
38730            CALL HWHSSS(IQ1,3,IQ2,0,2413,10)
38731            GOTO 9
38732          ENDIF
38733         ELSE
38734 c _      ~*~
38735 c qq  -> q'q'   (q =/= q')
38736          DO 31 IQ = 1, 6
38737          IF (IQ .EQ.IQ1) GOTO 31
38738          HCS = HCS +      AUSTLL(IQ)*DIST
38739          IF (GENEV.AND.HCS.GT.RCS) THEN
38740            CALL HWHSSS(IQ ,1,IQ ,0,3142,10)
38741            GOTO 9
38742          ENDIF
38743          HCS = HCS +      AUSTRR(IQ)*DIST
38744          IF (GENEV.AND.HCS.GT.RCS) THEN
38745            CALL HWHSSS(IQ ,3,IQ ,2,3142,10)
38746            GOTO 9
38747          ENDIF
38748    31    CONTINUE
38749 c _      ~*~
38750 c qq  -> q q
38751          HCS = HCS +     BUTSLL(IQ1)*DIST
38752          IF (GENEV.AND.HCS.GT.RCS) THEN
38753            CALL HWHSSS(IQ1,1,IQ2,0,2413,10)
38754            GOTO 9
38755          ENDIF
38756          HCS = HCS +     BUTSRR(IQ1)*DIST
38757          IF (GENEV.AND.HCS.GT.RCS) THEN
38758            CALL HWHSSS(IQ1,3,IQ2,2,2413,10)
38759            GOTO 9
38760          ENDIF
38761          HCS = HCS +     BUTSLR(IQ1)*DIST
38762          IF (GENEV.AND.HCS.GT.RCS) THEN
38763            CALL HWHSSS(IQ1,1,IQ2,2,2413,10)
38764            GOTO 9
38765          ENDIF
38766          HCS = HCS +     BUTSRL(IQ1)*DIST
38767          IF (GENEV.AND.HCS.GT.RCS) THEN
38768            CALL HWHSSS(IQ1,3,IQ2,0,2413,10)
38769            GOTO 9
38770          ENDIF
38771          HCS = HCS +     BUSTLL(IQ1)*DIST
38772          IF (GENEV.AND.HCS.GT.RCS) THEN
38773            CALL HWHSSS(IQ1,1,IQ2,0,3142,10)
38774            GOTO 9
38775          ENDIF
38776          HCS = HCS +     BUSTRR(IQ1)*DIST
38777          IF (GENEV.AND.HCS.GT.RCS) THEN
38778            CALL HWHSSS(IQ1,3,IQ2,2,3142,10)
38779            GOTO 9
38780          ENDIF
38781          HCS = HCS +     BUSTLR(IQ1)*DIST
38782          IF (GENEV.AND.HCS.GT.RCS) THEN
38783            CALL HWHSSS(IQ1,1,IQ2,2,3142,10)
38784            GOTO 9
38785          ENDIF
38786          HCS = HCS +     BUSTRL(IQ1)*DIST
38787          IF (GENEV.AND.HCS.GT.RCS) THEN
38788            CALL HWHSSS(IQ1,3,IQ2,0,3142,10)
38789            GOTO 9
38790          ENDIF
38791 c _      ~ ~
38792 c qq  -> g g
38793          HCS = HCS +       CSTU(IQ1)*DIST
38794          IF (GENEV.AND.HCS.GT.RCS) THEN
38795            CALL HWHSSS(IGL,0,IGL,0,3142,10)
38796            GOTO 9
38797          ENDIF
38798          HCS = HCS +       CSUT(IQ1)*DIST
38799          IF (GENEV.AND.HCS.GT.RCS) THEN
38800            CALL HWHSSS(IGL,0,IGL,0,4123,10)
38801            GOTO 9
38802          ENDIF
38803         END IF
38804        ELSEIF (ID2.NE.13) THEN
38805         IQ2 = ID2 - 6
38806         IF (IQ1.NE.IQ2) THEN
38807 c __     ~*~*
38808 c qq' -> q q'
38809          HCS = HCS + ASTULL(IQ1,IQ2)*DIST
38810          IF (GENEV.AND.HCS.GT.RCS) THEN
38811            CALL HWHSSS(IQ1,1,IQ2,1,4312,10)
38812            GOTO 9
38813          ENDIF
38814          HCS = HCS + ASTURR(IQ1,IQ2)*DIST
38815          IF (GENEV.AND.HCS.GT.RCS) THEN
38816            CALL HWHSSS(IQ1,3,IQ2,3,4312,10)
38817            GOTO 9
38818          ENDIF
38819          HCS = HCS + ASTULR(IQ1,IQ2)*DIST
38820          IF (GENEV.AND.HCS.GT.RCS) THEN
38821            CALL HWHSSS(IQ1,1,IQ2,3,4312,10)
38822            GOTO 9
38823          ENDIF
38824          HCS = HCS + ASTURL(IQ1,IQ2)*DIST
38825          IF (GENEV.AND.HCS.GT.RCS) THEN
38826            CALL HWHSSS(IQ1,3,IQ2,1,4312,10)
38827            GOTO 9
38828          ENDIF
38829         ELSE
38830 c __     ~*~*
38831 c qq  -> q q
38832          HCS = HCS +     BSTULL(IQ1)*DIST
38833          IF (GENEV.AND.HCS.GT.RCS) THEN
38834            CALL HWHSSS(IQ1,1,IQ2,1,4312,10)
38835            GOTO 9
38836          ENDIF
38837          HCS = HCS +     BSTURR(IQ1)*DIST
38838          IF (GENEV.AND.HCS.GT.RCS) THEN
38839            CALL HWHSSS(IQ1,3,IQ2,3,4312,10)
38840            GOTO 9
38841          ENDIF
38842          HCS = HCS +     BSTULR(IQ1)*DIST
38843          IF (GENEV.AND.HCS.GT.RCS) THEN
38844            CALL HWHSSS(IQ1,1,IQ2,3,4312,10)
38845            GOTO 9
38846          ENDIF
38847          HCS = HCS +     BSTURL(IQ1)*DIST
38848          IF (GENEV.AND.HCS.GT.RCS) THEN
38849            CALL HWHSSS(IQ1,3,IQ2,1,4312,10)
38850            GOTO 9
38851          ENDIF
38852          HCS = HCS +     BSUTLL(IQ1)*DIST
38853          IF (GENEV.AND.HCS.GT.RCS) THEN
38854            CALL HWHSSS(IQ1,1,IQ2,1,3421,10)
38855            GOTO 9
38856          ENDIF
38857          HCS = HCS +     BSUTRR(IQ1)*DIST
38858          IF (GENEV.AND.HCS.GT.RCS) THEN
38859            CALL HWHSSS(IQ1,3,IQ2,3,3421,10)
38860            GOTO 9
38861          ENDIF
38862          HCS = HCS +     BSUTLR(IQ1)*DIST
38863          IF (GENEV.AND.HCS.GT.RCS) THEN
38864            CALL HWHSSS(IQ1,1,IQ2,3,3421,10)
38865            GOTO 9
38866          ENDIF
38867          HCS = HCS +     BSUTRL(IQ1)*DIST
38868          IF (GENEV.AND.HCS.GT.RCS) THEN
38869            CALL HWHSSS(IQ1,3,IQ2,1,3421,10)
38870            GOTO 9
38871          ENDIF
38872         END IF
38873        ELSE
38874          IQ2 = IGL
38875 c _      ~*~
38876 c qg  -> q g
38877          HCS = HCS +      CTSUL(IQ1)*DIST
38878          IF (GENEV.AND.HCS.GT.RCS) THEN
38879            CALL HWHSSS(IQ1,1,IQ2,0,2413,10)
38880            GOTO 9
38881          ENDIF
38882          HCS = HCS +      CTSUR(IQ1)*DIST
38883          IF (GENEV.AND.HCS.GT.RCS) THEN
38884            CALL HWHSSS(IQ1,3,IQ2,0,2413,10)
38885            GOTO 9
38886          ENDIF
38887          HCS = HCS +      CTUSL(IQ1)*DIST
38888          IF (GENEV.AND.HCS.GT.RCS) THEN
38889            CALL HWHSSS(IQ1,1,IQ2,0,4312,10)
38890            GOTO 9
38891          ENDIF
38892          HCS = HCS +      CTUSR(IQ1)*DIST
38893          IF (GENEV.AND.HCS.GT.RCS) THEN
38894            CALL HWHSSS(IQ1,3,IQ2,0,4312,10)
38895            GOTO 9
38896          ENDIF
38897        END IF
38898       ELSE
38899        IQ1 = IGL
38900        IF (ID2.LT.7) THEN
38901          IQ2 = ID2
38902 c        ~ ~
38903 c gq  -> g q
38904          HCS = HCS +      CTSUL(IQ2)*DIST
38905          IF (GENEV.AND.HCS.GT.RCS) THEN
38906            CALL HWHSSS(IQ1,0,IQ2,0,2413,10)
38907            GOTO 9
38908          ENDIF
38909          HCS = HCS +      CTSUR(IQ2)*DIST
38910          IF (GENEV.AND.HCS.GT.RCS) THEN
38911            CALL HWHSSS(IQ1,0,IQ2,2,2413,10)
38912            GOTO 9
38913          ENDIF
38914          HCS = HCS +      CTUSL(IQ2)*DIST
38915          IF (GENEV.AND.HCS.GT.RCS) THEN
38916            CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38917            GOTO 9
38918          ENDIF
38919          HCS = HCS +      CTUSR(IQ2)*DIST
38920          IF (GENEV.AND.HCS.GT.RCS) THEN
38921            CALL HWHSSS(IQ1,0,IQ2,2,3421,10)
38922            GOTO 9
38923          ENDIF
38924        ELSEIF (ID2.LT.13) THEN
38925          IQ2 = ID2 - 6
38926 c  _     ~ ~*
38927 c gq  -> g q
38928          HCS = HCS +      CTSUL(IQ2)*DIST
38929          IF (GENEV.AND.HCS.GT.RCS) THEN
38930            CALL HWHSSS(IQ1,0,IQ2,1,3142,10)
38931            GOTO 9
38932          ENDIF
38933          HCS = HCS +      CTSUR(IQ2)*DIST
38934          IF (GENEV.AND.HCS.GT.RCS) THEN
38935            CALL HWHSSS(IQ1,0,IQ2,3,3142,10)
38936            GOTO 9
38937          ENDIF
38938          HCS = HCS +      CTUSL(IQ2)*DIST
38939          IF (GENEV.AND.HCS.GT.RCS) THEN
38940            CALL HWHSSS(IQ1,0,IQ2,1,4312,10)
38941            GOTO 9
38942          ENDIF
38943          HCS = HCS +      CTUSR(IQ2)*DIST
38944          IF (GENEV.AND.HCS.GT.RCS) THEN
38945            CALL HWHSSS(IQ1,0,IQ2,3,4312,10)
38946            GOTO 9
38947          ENDIF
38948        ELSE
38949          IQ2 = IGL
38950 c        ~ ~*
38951 c gg  -> q q
38952          DO 32 IQ = 1, 6
38953          HCS = HCS +       CSTUL(IQ)*DIST
38954          IF (GENEV.AND.HCS.GT.RCS) THEN
38955            CALL HWHSSS(IQ ,0,IQ ,1,2413,10)
38956            GOTO 9
38957          ENDIF
38958          HCS = HCS +       CSTUR(IQ)*DIST
38959          IF (GENEV.AND.HCS.GT.RCS) THEN
38960            CALL HWHSSS(IQ ,2,IQ ,3,2413,10)
38961            GOTO 9
38962          ENDIF
38963          HCS = HCS +       CSUTL(IQ)*DIST
38964          IF (GENEV.AND.HCS.GT.RCS) THEN
38965            CALL HWHSSS(IQ ,0,IQ ,1,4123,10)
38966            GOTO 9
38967          ENDIF
38968          HCS = HCS +       CSUTR(IQ)*DIST
38969          IF (GENEV.AND.HCS.GT.RCS) THEN
38970            CALL HWHSSS(IQ ,2,IQ ,3,4123,10)
38971            GOTO 9
38972          ENDIF
38973    32    CONTINUE
38974 c        ~ ~
38975 c gg  -> g g
38976          HCS = HCS +            DTSU*DIST
38977          IF (GENEV.AND.HCS.GT.RCS) THEN
38978            CALL HWHSSS(IQ1,0,IQ2,0,2341,10)
38979            GOTO 9
38980          ENDIF
38981          HCS = HCS +            DSTU*DIST
38982          IF (GENEV.AND.HCS.GT.RCS) THEN
38983            CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38984            GOTO 9
38985          ENDIF
38986          HCS = HCS +            DUTS*DIST
38987          IF (GENEV.AND.HCS.GT.RCS) THEN
38988            CALL HWHSSS(IQ1,0,IQ2,0,2413,10)
38989            GOTO 9
38990          ENDIF
38991        END IF
38992       END IF
38993     5 CONTINUE
38994     6 CONTINUE
38995       EVWGT = HCS
38996       RETURN
38997 C---GENERATE EVENT
38998     9 IDN(1)=ID1
38999       IDN(2)=ID2
39000       IDCMF=15
39001       CALL HWETWO(.TRUE.,.TRUE.)
39002       IF (AZSPIN) THEN
39003 C Calculate coefficients for constructing spin density matrices
39004 C Set to zero for now
39005         CALL HWVZRO(7,GCOEF)
39006       END IF
39007       END
39008 CDECK  ID>, HWHSSP.
39009 *CMZ :-        -25/06/99  20.33.45  by  Kosuke Odagiri
39010 *-- Author :    Kosuke Odagiri & Bryan Webber
39011 C-----------------------------------------------------------------------
39012       SUBROUTINE HWHSSP
39013 C-----------------------------------------------------------------------
39014 C     SUSY HARD 2 PARTON -> 2 SPARTON/GAUGINO/SLEPTON PROCESSES
39015 C-----------------------------------------------------------------------
39016       INCLUDE 'herwig65.inc'
39017       DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN,HWRUNI,Z1,Z2,ET,EJ,
39018      & QPE,S,T,U,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP,SVEMSC
39019       INTEGER ISP
39020       EXTERNAL HWRGEN,HWRUNI
39021       SAVE SAVWT,SVEMSC
39022       IF (.NOT.GENEV) THEN
39023         EVWGT=ZERO
39024         CALL HWRPOW(ET,EJ)
39025         KK = ET/PHEP(5,3)
39026         KK2=KK**2
39027         IF (KK.GE.ONE) RETURN
39028         YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
39029         YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
39030         IF (YJ1INF.GE.YJ1SUP) RETURN
39031         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
39032         YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
39033         YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
39034         IF (YJ2INF.GE.YJ2SUP) RETURN
39035         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
39036         XX(1)=HALF*(Z1+Z2)*KK
39037         IF (XX(1).GE.ONE) RETURN
39038         XX(2)=XX(1)/(Z1*Z2)
39039         IF (XX(2).GE.ONE) RETURN
39040         S=XX(1)*XX(2)*PHEP(5,3)**2
39041         QPE=S-(TWO*RMMNSS)**2
39042         IF (QPE.LE.ZERO) RETURN
39043         COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
39044         IF (ABS(COSTH).GT.ONE) RETURN
39045         T=-(ONE+Z2/Z1)*(HALF*ET)**2
39046         U=-S-T
39047 C---SET EMSCA TO HEAVY HARD PROCESS SCALE
39048         SVEMSC = SQRT(TWO*S*T*U/(S*S+T*T+U*U))
39049         FACTSS = GEV2NB*HALF*PIFAC*EJ*ET/S**2
39050      &         * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
39051      &         * SQRT(S/QPE)
39052       ENDIF
39053       EMSCA=SVEMSC
39054       ISP=MOD(IPROC,100)
39055       IF (ISP.EQ.0) THEN
39056         IF (GENEV) THEN
39057           RANWT=SAVWT(3)*HWRGEN(0)
39058           IF (RANWT.LT.SAVWT(1)) THEN
39059             CALL HWHSSQ
39060           ELSEIF (RANWT.LT.SAVWT(2)) THEN
39061             CALL HWHSSG
39062           ELSE
39063             CALL HWHSSL
39064           ENDIF
39065         ELSE
39066           CALL HWHSSQ
39067           SAVWT(1)=EVWGT
39068           CALL HWHSSG
39069           SAVWT(2)=SAVWT(1)+EVWGT
39070           CALL HWHSSL
39071           SAVWT(3)=SAVWT(2)+EVWGT
39072           EVWGT=SAVWT(3)
39073         ENDIF
39074       ELSEIF (ISP.EQ.10) THEN
39075         CALL HWHSSQ
39076       ELSEIF (ISP.EQ.20) THEN
39077         CALL HWHSSG
39078       ELSEIF (ISP.EQ.30) THEN
39079         CALL HWHSSL
39080       ELSE
39081 C---UNRECOGNIZED PROCESS
39082         CALL HWWARN('HWHSSP',500)
39083       ENDIF
39084       END
39085 CDECK  ID>, HWHSSS.
39086 *CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
39087 *-- Author :    Kosuke Odagiri
39088 C-----------------------------------------------------------------------
39089       SUBROUTINE HWHSSS(ID3,R3,ID4,R4,IPERM,IHPR)
39090 C-----------------------------------------------------------------------
39091 C     IDENTIFIES HARD SUSY SUBPROCESS
39092 C-----------------------------------------------------------------------
39093       INCLUDE 'herwig65.inc'
39094       INTEGER ID3, R3, ID4, R4, IPERM, IHPR, SSL
39095       PARAMETER (SSL = 400)
39096        IHPRO  = 3000 + IHPR
39097        IDN(3) = SSL + ID3 + R3*6
39098        IDN(4) = SSL + ID4 + R4*6
39099        ICO(1) = IPERM/1000
39100        ICO(2) = IPERM/100 - 10*ICO(1)
39101        ICO(3) = IPERM/10  - 10*(IPERM/100)
39102        ICO(4) = IPERM     - 10*(IPERM/10)
39103       END
39104 CDECK  ID>, HWHV1J.
39105 *CMZ :-        -18/05/99  14.37.45  by  Mike Seymour
39106 *-- Author :    Mike Seymour
39107 C-----------------------------------------------------------------------
39108       SUBROUTINE HWHV1J
39109 C-----------------------------------------------------------------------
39110 C   V + 1 JET PRODUCTION, WHERE V=W (IHPRO.LT.5) OR Z (IHPRO.GE.5).
39111 C   USES CROSS-SECTIONS OF EHLQ FOR ANNIHILATION AND COMPTON SCATTERING
39112 C   IHPRO=0 FOR BOTH, 1 FOR ANNIHILATION, AND 2 FOR COMPTON.
39113 C-----------------------------------------------------------------------
39114       INCLUDE 'herwig65.inc'
39115       DOUBLE PRECISION HWRGEN,HWRUNI,DISFAC(2,12,2),EMV2,DISMAX,S,T,U,
39116      & SHAT,THAT,UHAT,Z,HWUALF,PT,EMT,GFACTR,SIGANN,SIGCOM(2),CSFAC,ET,
39117      & EJ,YMIN,YMAX,VYMIN,VYMAX,EMAX,CV,CA,BR,EMV,GAMV,HWUAEM,TMIN,TMAX
39118       INTEGER HWRINT,IDINIT(2,12,2),ICOFLO(4,2),I,J,K,L,M,ID1,ID2,
39119      $     IDV,IDI,IDM
39120       EXTERNAL HWRINT
39121       SAVE DISFAC,SHAT,THAT,EMV,EMV2,IDV,IDI
39122       SAVE IDINIT,ICOFLO
39123 C---IDINIT HOLDS THE INITIAL STATES FOR ANNIHILATION PROCESSES
39124       DATA IDINIT/1,8,2,7,3,10,4,9,5,12,6,11,1,10,2,9,3,8,4,7,5,12,6,11,
39125      $            1,7,2,8,3,9,4,10,5,11,6,12,1,7,2,8,3,9,4,10,5,11,6,12/
39126 C---ICOFLO HOLDS THE COLOR FLOW FOR EACH PROCESS
39127 C---DISFAC HOLDS THE DISTRIBUTION FUNCTION*CROSS-SECTION FOR EACH
39128 C   POSSIBLE SUB-PROCESS.
39129 C   INDEX1=INITIAL STATE PERMUTATION (1=AS IDINIT/QG;2=OPPOSITE/GQ),
39130 C        2=QUARK (FOR ANNIHILATION, >6 IMPLIES CABIBBO ROTATED PAIR),
39131 C        3=PROCESS (1=ANNIHILATION, 2=COMPTON)
39132       DATA ICOFLO,DISFAC/2,4,3,1,4,1,3,2,48*0.D0/
39133       IF (GENEV) THEN
39134         DISMAX=0
39135         DO 110 I=1,2
39136         DO 110 J=1,12
39137         DO 110 K=1,2
39138  110      DISMAX=MAX(DISFAC(K,J,I),DISMAX)
39139  120    I=HWRINT(1,2)
39140         J=HWRINT(1,12)
39141         K=HWRINT(1,2)
39142         IF (HWRGEN(0)*DISMAX.GT.DISFAC(K,J,I)) GOTO 120
39143         IF (I.EQ.1) THEN
39144 C---ANNIHILATION
39145           IDN(1)=IDINIT(K,J,IDI)
39146           IDN(2)=IDINIT(3-K,J,IDI)
39147           IDN(4)=13
39148         ELSE
39149 C---COMPTON SCATTERING
39150           IDN(1)=J
39151           IDN(2)=13
39152           IF (IDV.EQ.200) THEN
39153             IDN(4)=J
39154           ELSE
39155             IF (J.EQ.5.OR.J.EQ.6.OR.J.GE.11.OR.HWRGEN(0).GT.SCABI) THEN
39156 C---CHANGE QUARKS (1->2,2->1,3->4,4->3,...)
39157               IDN(4)=4*INT((J-1)/2)-J+3
39158             ELSE
39159 C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,...)
39160               IDN(4)=12*INT((J-1)/6)-J+5
39161             ENDIF
39162           ENDIF
39163           IF ((SQRT(EMV2)+RMASS(IDN(4)))**2.GT.SHAT) GOTO 120
39164           IF (K.EQ.2) THEN
39165 C---SWAP INITIAL STATES
39166             IDN(3)=IDN(1)
39167             IDN(1)=IDN(2)
39168             IDN(2)=IDN(3)
39169           ENDIF
39170         ENDIF
39171         IF (IDV.EQ.200) THEN
39172           IDN(3)=200
39173         ELSE
39174 C---W+ OR W-? USE CHARGE CONSERVATION TO WORK OUT
39175           IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
39176         ENDIF
39177         M=K
39178         IF (I.EQ.2.AND.J.LE.6) M=3-K
39179         DO 130 L=1,4
39180  130      ICO(L)=ICOFLO(L,M)
39181         IDCMF=15
39182         COSTH=(SHAT+2*THAT-EMV2)/(SHAT-EMV2)
39183 C---TRICK HWETWO INTO USING THE OFF-SHELL V MASS
39184         RMASS(IDN(3))=SQRT(EMV2)
39185 C-- BRW fix 27/8/04: avoid double smearing of V mass
39186         CALL HWETWO(.FALSE.,.TRUE.)
39187         RMASS(IDN(3))=EMV
39188         RHOHEP(1,NHEP-1)=0.5
39189         RHOHEP(2,NHEP-1)=0.0
39190         RHOHEP(3,NHEP-1)=0.5
39191       ELSE
39192         EVWGT=0.
39193         IHPRO=MOD(IPROC,100)/10
39194         IF (IHPRO.LT.5) THEN
39195           IDV=198
39196           IDI=1
39197           IDM=10
39198           GAMV=GAMW
39199         ELSE
39200           IDV=200
39201           IDI=2
39202           IDM=6
39203           GAMV=GAMZ
39204           IHPRO=IHPRO-5
39205         ENDIF
39206         EMV=RMASS(IDV)
39207 c---mhs---implement cut on number of widths from nominal mass
39208         TMIN=-ATAN(2*GAMMAX-GAMV*GAMMAX**2/EMV)
39209         TMAX=ATAN(2*GAMMAX+GAMV*GAMMAX**2/EMV)
39210         EMV2=EMV*(EMV+GAMV*TAN(HWRUNI(0,TMIN,TMAX)))
39211         IF (EMV2.LE.ZERO) RETURN
39212         CALL HWRPOW(ET,EJ)
39213         PT=0.5*ET
39214         EMT=SQRT(PT**2+EMV2)
39215         EMAX=0.5*(PHEP(5,3)+EMV2/PHEP(5,3))
39216         IF (EMAX.LE.EMT) RETURN
39217         VYMAX=0.5*LOG((EMAX+SQRT(EMAX**2-EMT**2))
39218      &              /(EMAX-SQRT(EMAX**2-EMT**2)))
39219         VYMIN=-VYMAX
39220         IF (VYMAX.LE.VYMIN) RETURN
39221         Z=EXP(HWRUNI(0,VYMIN,VYMAX))
39222         S= PHEP(5,3)**2
39223         T=-PHEP(5,3)*EMT/Z+EMV2
39224         U=-PHEP(5,3)*EMT*Z+EMV2
39225         XXMIN=-U/(S+T-EMV2)
39226         IF (XXMIN.LT.ZERO.OR.XXMIN.GT.ONE) RETURN
39227         YMIN=MAX(LOG((XXMIN*PHEP(5,3)-EMT*Z)/PT),YJMIN)
39228         YMAX=MIN(LOG((PHEP(5,3)-EMT*Z)/PT),YJMAX)
39229         IF (YMAX.LE.YMIN) RETURN
39230         XX(1)=(Z*EMT+EXP(HWRUNI(2,YMIN,YMAX))*PT)/PHEP(5,3)
39231         IF (XX(1).LE.ZERO.OR.XX(1).GT.ONE) RETURN
39232         THAT =XX(1)*T+(1.-XX(1))*EMV2
39233         XX(2)=-THAT / (XX(1)*S+U-EMV2)
39234         IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
39235         UHAT =XX(2)*U+(1.-XX(2))*EMV2
39236         SHAT =XX(1)*XX(2)*S
39237         EMSCA=EMT
39238         CALL HWSGEN(.FALSE.)
39239 c---mhs minor improvement: replace thomson coupling by running coupling
39240 c---mhs bug fix: missing factor of m^2/m0^2, where m0 is nominal mass
39241         GFACTR=GEV2NB*2.*PIFAC*HWUAEM(EMV2)*HWUALF(1,EMSCA)/(9.*SWEIN)
39242      $       *EMV2/EMV**2
39243         SIGANN=GFACTR*((THAT-EMV2)**2+(UHAT-EMV2)**2)
39244      &               /(SHAT**2*THAT*UHAT)
39245         SIGCOM(2)=.375*GFACTR*(SHAT**2+UHAT**2+2*EMV2*THAT)
39246      &                       /(-UHAT*SHAT**3)
39247         SIGCOM(1)=.375*GFACTR*(SHAT**2+THAT**2+2*EMV2*UHAT)
39248      &                       /(-THAT*SHAT**3)
39249 C---IF USER SPECIFIED A SUB-PROCESS, ZERO THE OTHER
39250         IF (IHPRO.EQ.1) THEN
39251           SIGCOM(1)=0.
39252           SIGCOM(2)=0.
39253         ENDIF
39254         IF (IHPRO.EQ.2) SIGANN=0.
39255         DO 210 I=1,IDM
39256           IF (IDV.EQ.200) THEN
39257             J=I
39258             IF(I.GT.6) J=I-6
39259             DISFAC(1,I,1)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
39260           ELSE
39261             IF (I.LE.4) THEN
39262               DISFAC(1,I,1)=1-SCABI
39263             ELSEIF (I.GE.7) THEN
39264               DISFAC(1,I,1)=SCABI
39265             ELSE
39266               DISFAC(1,I,1)=1.
39267             ENDIF
39268           ENDIF
39269           DISFAC(2,I,1)=DISFAC(1,I,1) *
39270      &         SIGANN*DISF(IDINIT(1,I,IDI),2)*DISF(IDINIT(2,I,IDI),1)
39271           DISFAC(1,I,1)=DISFAC(1,I,1) *
39272      &         SIGANN*DISF(IDINIT(1,I,IDI),1)*DISF(IDINIT(2,I,IDI),2)
39273  210    CONTINUE
39274         DO 211 I=IDM+1,12
39275           DISFAC(1,I,1)=0
39276           DISFAC(2,I,1)=0
39277  211    CONTINUE
39278         DO 220 I=1,12
39279           IF (IDV.EQ.200) THEN
39280             J=I
39281             IF(I.GT.6) J=I-6
39282             DISFAC(1,I,2)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
39283           ELSE
39284             DISFAC(1,I,2)=1.
39285 c---mhs fix: switch off bg->Wt process since we neglect quark masses!
39286             IF (I.EQ.5.OR.I.EQ.11) DISFAC(1,I,2)=0
39287           ENDIF
39288           DISFAC(2,I,2)=DISFAC(1,I,2)*SIGCOM(2)*DISF(I,2)*DISF(13,1)
39289           DISFAC(1,I,2)=DISFAC(1,I,2)*SIGCOM(1)*DISF(I,1)*DISF(13,2)
39290  220    CONTINUE
39291         DO 230 I=1,2
39292         DO 230 J=1,12
39293         DO 230 K=1,2
39294  230      EVWGT=EVWGT+DISFAC(K,J,I)
39295         CSFAC=PT*EJ*(YMAX-YMIN)*(VYMAX-VYMIN)*(TMAX-TMIN)/PIFAC
39296 C---INCLUDE BRANCHING RATIO OF V
39297         CALL HWDBOZ(IDV,ID1,ID2,CV,CA,BR,0)
39298         EVWGT=EVWGT*CSFAC*BR
39299       ENDIF
39300       END
39301 CDECK  ID>, HWHV2J.
39302 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
39303 *-- Author :    Peter Richardson
39304 C-----------------------------------------------------------------------
39305       SUBROUTINE HWHV2J
39306 C-----------------------------------------------------------------------
39307 C     Vector Boson production with two hard jets
39308 C     Master subroutine for all vector boson + 2 jet processes
39309 C     Currently implemented qqbar Z only
39310 C-----------------------------------------------------------------------
39311       INCLUDE 'herwig65.inc'
39312       INTEGER I,J,K,IDBS,IPRC,IDP(6),ORD,IB,ICMF,IHEP,IFLOW,IZ,IBRAD,
39313      &     ICOL(5),IDZ,IQ
39314       DOUBLE PRECISION HWRGEN,HWRUNI,XMASS,PLAB,PRW,PCM,HWUAEM,BR,FLUX,
39315      &     MBOS,MBOS2,ME,DT(4),B(6),HWUPCM,CV,CA,PST,HWUALF,GMBS,FPI4,
39316      &     MQ(3),MQ2(3),MJAC,BRZED(12),PTP(5,2),PDOT(2),HWULDO,TWOPI2,
39317      &     AMP,WI(IMAXCH)
39318       DOUBLE COMPLEX S,D,F
39319       LOGICAL FSTCLL,MASS,GEN
39320       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUALF,HWUAEM,HWULDO
39321       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
39322       COMMON/HWHEWS/S(8,8,2),D(8,8)
39323       COMMON/HWHZBB/F(8,8)
39324       COMMON /HWPSOM/ WI
39325       SAVE ME,MBOS,MBOS2,GMBS,IDBS,IPRC,IDP,FSTCLL,MQ,MQ2,TWOPI2,FPI4,
39326      &     IQ,MASS
39327       SAVE B,BRZED
39328       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
39329       DATA BRZED/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
39330      &           0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
39331 C--generate the event
39332       IF(GENEV) THEN
39333 C--find the particles produced
39334         IF(IPRC.EQ.0) THEN
39335           WRITE(*,1000)
39336           STOP
39337         ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
39338           CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
39339         ELSE
39340           CALL HWWARN('HWHV2J',502)
39341         ENDIF
39342         IF(ORD.EQ.2) THEN
39343           IB     = IDP(1)
39344           IDP(1) = IDP(2)
39345           IDP(2) = IB
39346           PRW(3,1) = -PRW(3,1)
39347           DO I=3,6
39348             PLAB(3,I)=-PLAB(3,I)
39349           ENDDO
39350         ENDIF
39351 C--enter the incoming particles
39352         ICMF = NHEP+3
39353         DO I=1,2
39354           IHEP = NHEP+I
39355           CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
39356           IDHW(IHEP) = IDP(I)
39357           IDHEP(IHEP)= IDPDG(IDP(I))
39358           ISTHEP(IHEP)=110+I
39359           JMOHEP(1,IHEP)=ICMF
39360           JMOHEP(I,ICMF)=IHEP
39361           JDAHEP(1,IHEP)=ICMF
39362         ENDDO
39363         IDHW(ICMF)=15
39364         IDHEP(ICMF)=IDPDG(15)
39365         ISTHEP(ICMF)=110
39366         CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
39367         CALL HWUMAS(PHEP(1,ICMF))
39368         JDAHEP(1,ICMF) = ICMF+1
39369         JDAHEP(2,ICMF) = ICMF+3
39370         NHEP = NHEP+3
39371 C--Now the outgoing jets
39372         DO 10 I=1,2
39373           CALL HWVEQU(5,PLAB(1,2+I),PHEP(1,NHEP+I))
39374 C--Set the status and pointers
39375           ISTHEP(NHEP+I)=113
39376           IDHW(NHEP+I)=IDP(2+I)
39377           IDHEP(NHEP+I)=IDPDG(IDP(2+I))
39378           JMOHEP(1,NHEP+I)=NHEP
39379  10     CONTINUE
39380         NHEP=NHEP+2
39381 C--Now sort out the colour connections
39382         ICOL(1)=IFLOW/1000
39383         ICOL(2)=IFLOW/100-10*ICOL(1)
39384         ICOL(3)=IFLOW/10 -10*(IFLOW/100)
39385         ICOL(4)=IFLOW    -10*(IFLOW/10)
39386         DO 30 I=1,4
39387         J=I
39388         IF (J.GT.2) J=J+1
39389         K=ICOL(I)
39390         IF (K.GT.2) K=K+1
39391         JMOHEP(2,NHEP-5+J)=NHEP+K-5
39392  30     JDAHEP(2,NHEP-5+K)=NHEP+J-5
39393 C--Now add the Z to the event record
39394         CALL HWVEQU(5,PRW(1,1),PHEP(1,NHEP+1))
39395         CALL HWVZRO(4,VHEP(1,NHEP+1))
39396         CALL HWUDKL(200,PHEP(1,NHEP+1),DT)
39397         CALL HWVSUM(4,VHEP(1,NHEP+1),DT,DT)
39398         IDHW(NHEP+1)=IDBS
39399         IDHEP(NHEP+1)=IDPDG(IDBS)
39400         JMOHEP(1,NHEP+1)=ICMF
39401         JMOHEP(2,NHEP+1)=ICMF
39402         ISTHEP(NHEP+1)=114
39403         NHEP = NHEP+1
39404         IBRAD = NHEP
39405 C--generate the inital-state shower
39406         CALL HWBGEN
39407 C--now add the decay products of the Z
39408         IZ = JDAHEP(1,IBRAD)
39409         ISTHEP(IZ) = 195
39410         JDAHEP(1,IZ) = NHEP+1
39411         JDAHEP(2,IZ) = NHEP+2
39412         IDHW(NHEP+1) = IDP(5)
39413         IDHW(NHEP+2) = IDP(6)
39414         ISTHEP(NHEP+1) = 113
39415         ISTHEP(NHEP+2) = 114
39416         IDHEP(NHEP+1) = IDPDG(IDP(5))
39417         IDHEP(NHEP+2) = IDPDG(IDP(6))
39418         JMOHEP(1,NHEP+1) = IZ
39419         JMOHEP(1,NHEP+2) = IZ
39420         JMOHEP(2,NHEP+1) = NHEP+2
39421         JDAHEP(2,NHEP+1) = NHEP+2
39422         JMOHEP(2,NHEP+2) = NHEP+1
39423         JDAHEP(2,NHEP+2) = NHEP+1
39424         CALL HWVEQU(5,PLAB(1,5),PHEP(1,NHEP+1))
39425         CALL HWVEQU(5,PLAB(1,6),PHEP(1,NHEP+2))
39426         DO IHEP=NHEP+1,NHEP+2
39427           CALL HWVEQU(4,DT,VHEP(1,IHEP))
39428 C--Boost the fermion momenta to the rest frame of the original Z
39429           CALL HWULOF(PRW(1,1),PHEP(1,IHEP),PHEP(1,IHEP))
39430 C--Now boost back to the lab from rest frame of the Z after radiation
39431           CALL HWULOB(PHEP(1,IZ),PHEP(1,IHEP),PHEP(1,IHEP))
39432         ENDDO
39433         NHEP = NHEP+2
39434       ELSE
39435 C--initialisation
39436         IF(FSTWGT) THEN
39437 C--for second option minimum invariant mass of the jet pair
39438 C--set the type of events to be generated
39439           TWOPI2= FOUR*PIFAC**2
39440           FPI4  = (FOUR*PIFAC)**4
39441           IPRC = MOD(IPROC,100)
39442           IF(IPRC.GE.0.AND.IPRC.LE.16) THEN
39443 C--Z + 2 jets
39444             MBOS  = RMASS(200)
39445             MBOS2 = MBOS**2
39446             GMBS  = MBOS2*GAMZ**2
39447             IDBS  = 200
39448             MQ(1) = ZERO
39449             MQ(2) = ZERO
39450             IF(IPRC.EQ.0) THEN
39451               IQ    = 0
39452             ELSEIF(IPRC.GT.0.AND.IPRC.LE.6) THEN
39453               IQ = IPRC
39454               IF(MJJMIN.LT.TWO*RMASS(IQ)) MJJMIN = TWO*RMASS(IQ)
39455             ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
39456               MASS = .TRUE.
39457               IQ = IPRC-10
39458               MQ(1) = RMASS(IQ)
39459               MQ(2) = RMASS(IQ)
39460               IF(MJJMIN.LT.(MQ(1)+MQ(2))) MJJMIN = MQ(1)+MQ(2)
39461             ELSE
39462               CALL HWWARN('HWHV2J',500)
39463             ENDIF
39464             DO I=1,2
39465               MQ2(I) = MQ(I)**2
39466             ENDDO
39467           ELSE
39468             CALL HWWARN('HWHV2J',503)
39469           ENDIF
39470           FSTCLL = .TRUE.
39471         ENDIF
39472 C--generate the weight
39473         EVWGT = ZERO
39474 C--find the mass of the gauge boson
39475         CALL HWHGB1(1,2,IDBS,MJAC,MQ2(3),(PHEP(5,3)-MQ(1)-MQ(2))**2,
39476      &                                                       EMMIN**2)
39477         MQ(3) = SQRT(MQ2(3))
39478         MJAC = MJAC/((MQ2(3)-MBOS2)**2+GMBS)
39479 C--do the phase space
39480         CALL HWH2PS(FLUX,GEN,MQ,MQ2)
39481         AMP = ONE
39482         IF(.NOT.GEN) RETURN
39483 C--copy the gauge boson momentum
39484         CALL HWVEQU(5,PLAB(1,5),PRW(1,1))
39485 C--select the decay mode of the boson
39486         CALL HWDBOZ(IDBS,IDP(5),IDP(6),CV,CA,BR,0)
39487         IDZ = IDP(5)
39488         IF(IDZ.GT.6) IDZ = IDZ-114
39489         BR = BR/BRZED(IDZ)
39490         IF(IDZ.LE.6) AMP = AMP*THREE
39491 C--Finds the momenta of the boson decay products
39492         PST=HWUPCM(PRW(5,1),ZERO,ZERO)
39493         PLAB(5,5)=ZERO
39494         PLAB(5,6)=ZERO
39495         IF(PRW(5,1).LT.(RMASS(IDP(5))+RMASS(IDP(6)))) RETURN
39496         CALL HWDTWO(PRW(1,1),PLAB(1,5),PLAB(1,6),PST,TWO,.FALSE.)
39497         MJAC = HALF*PST*MJAC/TWOPI2/MQ(3)
39498 C--copy the momenta, change order and boost to CMF
39499         PTP(1,1) = ZERO
39500         PTP(2,1) = ZERO
39501         PTP(3,1) = HALF*(XX(1)-XX(2))*PHEP(5,3)
39502         PTP(4,1) = HALF*(XX(1)+XX(2))*PHEP(5,3)
39503         PTP(5,1) = PHEP(5,3)*SQRT(XX(1)*XX(2))
39504         DO I=1,6
39505           CALL HWULOF(PTP(1,1),PLAB(1,I),PTP(1,2))
39506           PCM(1,I)=PTP(3,2)
39507           PCM(2,I)=PTP(1,2)
39508           PCM(3,I)=PTP(2,2)
39509           PCM(4,I)=PTP(4,2)
39510         ENDDO
39511         IF(MASS) THEN
39512 C--Massive momentum case
39513 C--reorder the products
39514 C--move b and bbar to 9 and 10
39515           DO I=3,4
39516             DO J=1,5
39517               PCM(J,I+6) = PCM(J,I)
39518             ENDDO
39519           ENDDO
39520 C--select the reference momenta for the b and bbar and put in 3,4
39521 C--the results is independent of this choice
39522           CALL HWVEQU(5,PCM(1,1),PCM(1,3))
39523           CALL HWVEQU(5,PCM(1,1),PCM(1,4))
39524 C--find the massless vectors for the b and bbar
39525           PDOT(1) = HALF*MQ2(1)/HWULDO(PCM(1,3),PCM(1, 9))
39526           PDOT(2) = HALF*MQ2(2)/HWULDO(PCM(1,4),PCM(1,10))
39527           DO I=1,4
39528             PCM(I,7) = PCM(I,9) -PDOT(1)*PCM(I,3)
39529             PCM(I,8) = PCM(I,10)-PDOT(2)*PCM(I,4)
39530           ENDDO
39531           PCM(5,7) = ZERO
39532           PCM(5,8) = ZERO
39533 C--use e+e- code to calculate the spinor products
39534           CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
39535           DO I=1,8
39536             DO J=1,8
39537               S(I,J,2) = -S(I,J,2)
39538               D(I,J)   = TWO*D(I,J)
39539             ENDDO
39540           ENDDO
39541         ELSE
39542 C--Massless case, use the e+e- code to calculate the spinor products
39543           CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
39544           DO I=1,6
39545             DO J=1,6
39546               D(I,J) = TWO*D(I,J)
39547               F(I,J) = B(I)*B(J)*D(I,J)
39548               S(I,J,2) = -S(I,J,2)
39549             ENDDO
39550           ENDDO
39551         ENDIF
39552 C--now call the code to calculate the matrix element*PDF
39553         IF(IPRC.EQ.0) THEN
39554           WRITE(*,1000)
39555           STOP
39556         ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
39557           CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
39558         ELSE
39559           CALL HWWARN('HWHV2J',501)
39560           GOTO 999
39561         ENDIF
39562         AMP = AMP*MJAC*BR*FPI4*HWUAEM(EMSCA**2)**2*HWUALF(1,EMSCA)**2
39563         EVWGT = FLUX*ME*AMP
39564         IF(OPTM) THEN
39565           DO I=1,IMAXCH
39566             IF(CHON(I)) WI(I) = WI(I)*ME**2*AMP**2
39567           ENDDO
39568         ENDIF
39569       ENDIF
39570       RETURN
39571  1000 FORMAT('DRELL-YAN + 2 JETS NOT YET IMPLEMENTED')
39572  999  RETURN
39573       END
39574 CDECK  ID>, HWHVVJ.
39575 *CMZ :-        -11/05/01  09.19.45  by  Bryan Webber
39576 *-- Author :    Bryan Webber
39577 C-----------------------------------------------------------------------
39578       SUBROUTINE HWHVVJ
39579 C-----------------------------------------------------------------------
39580 C   VV + 1 JET PRODUCTION, WHERE VV=WW,ZZ,WZ FOR IPROC=2850,2860,2870
39581 C-----------------------------------------------------------------------
39582       IMPLICIT NONE
39583       PRINT *,'  VV + 1 JET CALLED BUT NOT YET IMPLEMENTED'
39584       CALL HWWARN('HWHVVJ',500)
39585       END
39586 CDECK  ID>, HWHWEX.
39587 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
39588 *-- Author :    Mike Seymour
39589 C-----------------------------------------------------------------------
39590       SUBROUTINE HWHWEX
39591 C-----------------------------------------------------------------------
39592 C     TOP QUARK PRODUCTION VIA W EXCHANGE: MEAN EVWGT=TOP PROD C-S IN NB
39593 C     C-S IS SUM OF:
39594 C     UbarBbar, DBbar, DbarB, UB, CbarBbar, SBbar, SbarB, AND CB
39595 C     UNLESS USER SPECIFIES OTHERWISE BY MOD(IPROC,100)=1-8 RESPECTIVELY
39596 C---DSDCOS HOLDS THE CROSS-SECTIONS FOR THE PROCESSES LISTED ABOVE
39597 C   (1-8) ARE WITH B FROM BEAM 1, (9-16) ARE WITH B FROM BEAM 2.
39598 C-----------------------------------------------------------------------
39599       INCLUDE 'herwig65.inc'
39600       DOUBLE PRECISION HWRGEN,HWRUNI,DSDCOS(16),EMT2,EMT,EMW2,EMW,
39601      & CMFMIN,TAUMIN,TAUMLN,S,T,U,ROOTS,DSMAX
39602       INTEGER HWRINT,IDHWEX(2,16),I
39603       EXTERNAL HWRGEN,HWRUNI,HWRINT
39604       SAVE DSDCOS,DSMAX
39605       EQUIVALENCE (EMW,RMASS(198)),(EMT,RMASS(6))
39606 C---IDHWEX HOLDS THE IDs OF THE INCOMING PARTICLES FOR EACH SUB-PROCESS
39607       SAVE IDHWEX
39608       DATA IDHWEX/11,8,11,1,5,7,5,2,11,10,11,3,5,9,5,4,
39609      &            8,11,1,11,7,5,2,5,10,11,3,11,9,5,4,5/
39610       EMT2=EMT**2
39611       EMW2=EMW**2
39612       IF (GENEV) THEN
39613  300    IHPRO=HWRINT(1,16)
39614         IF (HWRGEN(0).GT.DSDCOS(IHPRO)/DSMAX) GOTO 300
39615         DO 10 I=1,2
39616           IDN(I)=IDHWEX(I,IHPRO)
39617           IF (IDN(I).EQ.5 .OR. IDN(I).EQ.11) THEN
39618 C---CHANGE B QUARK INTO T QUARK
39619             IDN(I+2)=IDN(I)+1
39620           ELSEIF (HWRGEN(0).GT.SCABI) THEN
39621 C---CHANGE QUARKS (1->2,2->1,3->4,4->3,7->8,8->7,...)
39622             IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
39623           ELSE
39624 C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,4->1,7->10,...)
39625             IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
39626           ENDIF
39627           ICO(I)=I+2
39628           ICO(I+2)=I
39629  10     CONTINUE
39630         IDCMF=15
39631         CALL HWETWO(.TRUE.,.TRUE.)
39632       ELSE
39633         EVWGT=0.
39634         CMFMIN=EMT
39635         TAUMIN=(CMFMIN/PHEP(5,3))**2
39636         TAUMLN=LOG(TAUMIN)
39637         ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,ZERO,TAUMLN)))
39638         XXMIN=(ROOTS/PHEP(5,3))**2
39639         XLMIN=LOG(XXMIN)
39640         COSTH=HWRUNI(0,-ONE, ONE)
39641         S=ROOTS**2
39642         T=-0.5*S*(1-COSTH)
39643         U=-0.5*S*(1+COSTH)
39644         EMSCA=SQRT(2*S*T*U/(S*S+T*T+U*U))
39645         DSDCOS(1)=GEV2NB*PIFAC*.125*(ALPHEM/SWEIN)**2
39646      &           *(S-EMT2)**2 / S / (EMW2 + 0.5*(S-EMT2)*(1-COSTH))**2
39647         DSDCOS(2)=DSDCOS(1) / 4
39648      &    * (1 + EMT2/S + 2*COSTH + (1-EMT2/S)*COSTH**2)
39649         DSDCOS(3)=DSDCOS(2)
39650         DSDCOS(4)=DSDCOS(1)
39651 C---IF USER SPECIFIED SUB-PROCESS THEN ZERO ALL THE OTHERS
39652         IHPRO=MOD(IPROC,100)
39653         IF (IHPRO.GT.8) THEN
39654           CALL HWWARN('HWHWEX',1)
39655           IHPRO=0
39656         ENDIF
39657         DO 100 I=1,8
39658           IF (I.LE.4) DSDCOS(I+4)=DSDCOS(I)
39659           IF (IHPRO.NE.0 .AND. IHPRO.NE.I) DSDCOS(I)=0
39660           DSDCOS(I+8)=DSDCOS(I)
39661  100    CONTINUE
39662         CALL HWSGEN(.TRUE.)
39663         DSMAX=0
39664         DO 200 I=1,16
39665           DSDCOS(I)=DSDCOS(I)*DISF(IDHWEX(1,I),1)*DISF(IDHWEX(2,I),2)
39666           EVWGT=EVWGT + 2*TAUMLN*XLMIN*DSDCOS(I)
39667           IF (DSDCOS(I).GT.DSMAX) DSMAX=DSDCOS(I)
39668  200    CONTINUE
39669       ENDIF
39670       END
39671 CDECK  ID>, HWHWPR.
39672 *CMZ :-        -18/05/99  14.22.13  by  Mike Seymour
39673 *-- Author :    Bryan Webber
39674 C-----------------------------------------------------------------------
39675       SUBROUTINE HWHWPR
39676 C-----------------------------------------------------------------------
39677 C     W+/- PRODUCTION AND DECAY VIA DRELL-YAN PROCESS
39678 C     MEAN EVWGT IS SIG(W+/-)*(BRANCHING FRACTION) IN NB
39679 C-----------------------------------------------------------------------
39680       INCLUDE 'herwig65.inc'
39681       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,COEF,CSFAC,EMW,
39682      & FTQK,PTOP,ETOP,EBOT,PMAX,FHAD,FTOT,BRAF,FLEP,TMIN,HWUAEM,TMAX
39683       INTEGER HWRINT,ICH,IC,IL,ID,IDEC,JDEC,IWP(2,16)
39684       LOGICAL HWRLOG
39685       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWRINT,HWRLOG
39686       SAVE CSFAC,IDEC,FLEP,FTQK,ETOP,PTOP,EBOT,PMAX,PROB
39687       SAVE IWP
39688       DATA IWP/2,7,1,8,7,2,8,1,4,9,3,10,9,4,10,3,
39689      &         2,9,3,8,9,2,8,3,4,7,1,10,7,4,10,1/
39690       IF (GENEV) THEN
39691 C---GENERATE EVENT (X'S AND STRUCTURE FUNCTIONS ALREADY FOUND)
39692         PRAN=PROB*HWRGEN(0)
39693 C---LOOP OVER PARTON FLAVOURS
39694         PROB=0.
39695         COEF=1.-SCABI
39696         DO 10 IC=1,16
39697           IF (IC.EQ.9) COEF=SCABI
39698           PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
39699           IF (PROB.GE.PRAN) GOTO 20
39700    10   CONTINUE
39701 C---STORE INCOMING PARTONS
39702    20   IDN(1)=IWP(1,IC)
39703         IDN(2)=IWP(2,IC)
39704         ICO(1)=2
39705         ICO(2)=1
39706 C---ICH=1/2 FOR W+/-
39707         ICH=2-MOD(IC,2)
39708         IF ((IDEC.GT.49.AND.IDEC.LT.54).OR.
39709      &      (IDEC.EQ.99.AND.HWRLOG(FLEP))) THEN
39710 C---LEPTONIC DECAY
39711           IL=IDEC-50
39712           IF (IL.EQ.0.OR.IL.GT.3) IL=HWRINT(1,3)
39713           IDN(3)=2*IL+121-ICH
39714           IDN(4)=2*IL+124+ICH
39715 C---W DECAY ANGLE (1+COSTH)**2
39716           COSTH=2.*HWRGEN(1)**0.3333-1.
39717         ELSEIF (IDEC.EQ.5.OR.IDEC.EQ.6.OR.
39718      &        ((IDEC.EQ.0.OR.IDEC.EQ.99).AND.HWRLOG(FTQK))) THEN
39719 C---W -> TOP + BOTTOM DECAY
39720           IDN(3)=7-ICH
39721           IDN(4)=10+ICH
39722    21     COSTH=HWRUNI(1,-ONE, ONE)
39723           IF ((ETOP+(PTOP*COSTH))*(EBOT+(PTOP*COSTH)).LT.
39724      &         PMAX*HWRGEN(1)) GOTO 21
39725         ELSE
39726 C---OTHER HADRONIC DECAY
39727    25     PROB=0.
39728           PRAN=2.*HWRGEN(2)
39729           COEF=1.-SCABI
39730           DO 30 ID=ICH,16,4
39731             IF (ID.GT.8) COEF=SCABI
39732             PROB=PROB+COEF
39733             IF (PROB.GE.PRAN) THEN
39734               IDN(3)=IWP(1,ID)
39735               IDN(4)=IWP(2,ID)
39736               GOTO 40
39737             ENDIF
39738    30     CONTINUE
39739    40     CONTINUE
39740           IF (IDEC.GT.0.AND.IDEC.LT.5) THEN
39741             JDEC=IDEC+6
39742             IF (IDN(3).NE.IDEC.AND.IDN(4).NE.IDEC
39743      &     .AND.IDN(3).NE.JDEC.AND.IDN(4).NE.JDEC) GOTO 25
39744           ENDIF
39745           COSTH=2.*HWRGEN(1)**0.3333-1.
39746         ENDIF
39747         IDCMF=197+ICH
39748         IF (IDN(1).GT.6) COSTH=-COSTH
39749         ICO(3)=4
39750         ICO(4)=3
39751         CALL HWETWO(.TRUE.,.TRUE.)
39752       ELSE
39753         IDEC=MOD(IPROC,100)
39754         IF (IDEC.EQ.5.OR.IDEC.EQ.6) THEN
39755           TMIN=ATAN((RMASS(6)**2-RMASS(199)**2)/(GAMW*RMASS(199)))
39756         ELSE
39757           TMIN=-ATAN(RMASS(199)/GAMW)
39758         ENDIF
39759         EVWGT=0.
39760 c---mhs---implement cut on number of widths from nominal mass
39761         TMIN=MAX(TMIN,-ATAN(2*GAMMAX-GAMW*GAMMAX**2/RMASS(199)))
39762         TMAX=ATAN(2*GAMMAX+GAMW*GAMMAX**2/RMASS(199))
39763         EMW=GAMW*TAN(HWRUNI(0,TMIN,TMAX))+RMASS(199)
39764         IF (EMW.LE.ZERO) RETURN
39765         EMW=SQRT(EMW*RMASS(199))
39766         IF (EMW.LE.QSPAC.OR.EMW.GE.PHEP(5,3)) RETURN
39767         EMSCA=EMW
39768         IF (EMLST.NE.EMW) THEN
39769           EMLST=EMW
39770           XXMIN=(EMW/PHEP(5,3))**2
39771           XLMIN=LOG(XXMIN)
39772           CSFAC=-GEV2NB*PIFAC**2*HWUAEM(EMSCA**2)
39773      &          /(3.*SWEIN*RMASS(199)**2)*XLMIN
39774 C---COMPUTE TOP AND LEPTONIC FRACTIONS
39775           FTQK=0.
39776           IF (NFLAV.GT.5) THEN
39777             PTOP=HWUPCM(EMW,RMASS(5),RMASS(6))
39778             IF (PTOP.GT.ZERO) THEN
39779               ETOP=SQRT(PTOP**2+RMASS(6)**2)
39780               EBOT=EMW-ETOP
39781               FTQK=2.*PTOP*(3.*ETOP*EBOT+PTOP**2)/EMW**3
39782               PMAX=(ETOP+PTOP)*(EBOT+PTOP)
39783             ENDIF
39784           ENDIF
39785           FHAD=FTQK+2.
39786           FTOT=FTQK+3.
39787 C---MULTIPLY WEIGHT BY BRANCHING FRACTION
39788           IF (IDEC.EQ.0) THEN
39789             BRAF=FHAD
39790           ELSEIF (IDEC.LT.5.OR.IDEC.EQ.50) THEN
39791             BRAF=1.
39792           ELSEIF (IDEC.LT.7) THEN
39793             BRAF=FTQK
39794           ELSEIF (IDEC.EQ.99) THEN
39795             BRAF=FTOT
39796           ELSE
39797             BRAF=1/THREE
39798           ENDIF
39799 c---mhs fix: normalization should be to on-shell total width
39800 c  (only different if chosen mass is above top threshold)
39801           CSFAC=CSFAC*BRAF/THREE*(TMAX-TMIN)/PIFAC
39802           FTQK=FTQK/FHAD
39803           FLEP=1./FTOT
39804         ENDIF
39805         CALL HWSGEN(.TRUE.)
39806 C---LOOP OVER PARTON FLAVOURS
39807         PROB=0.
39808         COEF=1.-SCABI
39809         DO 100 IC=1,16
39810           IF (IC.EQ.9) COEF=SCABI
39811           PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
39812   100   CONTINUE
39813         EVWGT=PROB*CSFAC
39814       ENDIF
39815       END
39816 CDECK  ID>, HWICHK.
39817 *-- Author :  M. Kirsanov
39818 C-----------------------------------------------------------------------
39819       SUBROUTINE HWICHK
39820 C-----------------------------------------------------------------------
39821       INCLUDE 'herwig65.inc'
39822       IF(RMASS(1).LT.0.1.OR.RMASS(1).GT.1.0.OR.
39823      &   FMRS(1,1,20,1).LT.0.1.OR.FMRS(1,1,20,1).GT.1.0) THEN
39824         STOP 'Block data hwudat not loaded, stop execution'
39825       ENDIF
39826       END
39827 CDECK  ID>, HWIODK.
39828 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
39829 *-- Author :    Ian Knowles
39830 C-----------------------------------------------------------------------
39831       SUBROUTINE HWIODK(IUNIT,IOPT,IME)
39832 C-----------------------------------------------------------------------
39833 C     If IUNIT > 0 writes out present HERWIG decay tables to unit IUNIT
39834 C              < 0 reads in decay tables from unit IUNIT
39835 C     The format used during the read/write is specified by IOPT
39836 C     =1 PDG; =2 HERWIG numeric; =3 HERWIG character name.
39837 C     When reading in if IME =1 matrix element codes >= 100 are accepted
39838 C                             0                            are set zero.
39839 C-----------------------------------------------------------------------
39840       INCLUDE 'herwig65.inc'
39841       INTEGER IUNIT,IOPT,IME,JUNIT,I,J,K,L,IDKY,ITMP(5),IDUM
39842       CHARACTER*8 CDK(NMXDKS),CDKPRD(5,NMXDKS),CDUM
39843       JUNIT=ABS(IUNIT)
39844       OPEN(UNIT=JUNIT,FORM='FORMATTED',STATUS='UNKNOWN')
39845       IF (IUNIT.GT.0) THEN
39846 C Write out the decay table
39847         WRITE(JUNIT,100) NDKYS
39848         IF (IOPT.EQ.1) THEN
39849           DO 20 I=1,NRES
39850           IF (NMODES(I).EQ.0) GOTO 20
39851           K=LSTRT(I)
39852           DO 10 J=1,NMODES(I)
39853           WRITE(JUNIT,110) IDPDG(I),BRFRAC(K),NME(K),
39854      &                    (IDPDG(IDKPRD(L,K)),L=1,5)
39855   10      K=LNEXT(K)
39856   20      CONTINUE
39857         ELSEIF (IOPT.EQ.2) THEN
39858           DO 40 I=1,NRES
39859           IF (NMODES(I).EQ.0) GOTO 40
39860           K=LSTRT(I)
39861           DO 30 J=1,NMODES(I)
39862           WRITE(JUNIT,120) I,BRFRAC(K),NME(K),(IDKPRD(L,K),L=1,5)
39863   30      K=LNEXT(K)
39864   40      CONTINUE
39865         ELSEIF (IOPT.EQ.3) THEN
39866           DO 60 I=1,NRES
39867           IF (NMODES(I).EQ.0) GOTO 60
39868           K=LSTRT(I)
39869           DO 50 J=1,NMODES(I)
39870           WRITE(JUNIT,130) RNAME(I),BRFRAC(K),NME(K),
39871      &                    (RNAME(IDKPRD(L,K)),L=1,5)
39872   50      K=LNEXT(K)
39873   60      CONTINUE
39874         ENDIF
39875       ELSEIF (IUNIT.LT.0) THEN
39876 C Read in the decay table and convert to HERWIG numeric format
39877         READ(JUNIT,100) NDKYS
39878         IF (NDKYS.GT.NMXDKS) THEN
39879           CALL HWWARN('HWIODK',100)
39880           GOTO 999
39881         ENDIF
39882         IF (IOPT.EQ.1) THEN
39883           DO 70 I=1,NDKYS
39884           READ(JUNIT,110) IDKY,BRFRAC(I),NME(I),ITMP
39885           IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
39886           CALL HWUIDT(1,IDKY,IDK(I),CDUM)
39887           DO 70 J=1,5
39888   70      CALL HWUIDT(1,ITMP(J),IDKPRD(J,I),CDUM)
39889         ELSEIF (IOPT.EQ.2) THEN
39890           DO 80 I=1,NDKYS
39891           READ(JUNIT,120) IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5)
39892           IF (IDK(I).LT.0.OR.IDK(I).GT.NRES) IDK(I)=20
39893   80      IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
39894         ELSEIF (IOPT.EQ.3) THEN
39895           DO 90 I=1,NDKYS
39896           READ(JUNIT,130) CDK(I),BRFRAC(I),NME(I),(CDKPRD(J,I),J=1,5)
39897           IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
39898           CALL HWUIDT(3,IDUM,IDK(I),CDK(I))
39899           DO 90 J=1,5
39900   90      CALL HWUIDT(3,IDUM,IDKPRD(J,I),CDKPRD(J,I))
39901         ELSE
39902           CALL HWWARN('HWIODK',101)
39903           GOTO 999
39904         ENDIF
39905       ENDIF
39906       CLOSE(UNIT=JUNIT)
39907   100 FORMAT(1X,I4)
39908   110 FORMAT(1X,I7,1X,F7.5,1X,I3,5(1X,I7))
39909   120 FORMAT(1X,I3,1X,F7.5,6(1X,I3))
39910   130 FORMAT(1X,A8,1X,F7.5,1X,I3,5(1X,A8))
39911  999  RETURN
39912       END
39913 CDECK  ID>, HWIGIN.
39914 *CMZ :-        -12/10/01  09.50.50  by  Peter Richardson
39915 *-- Author :    Bryan Webber
39916 C----------------------------------------------------------------------
39917       SUBROUTINE HWIGIN
39918 C-----------------------------------------------------------------------
39919 C     SETS INPUT PARAMETERS
39920 C----------------------------------------------------------------------
39921       INCLUDE 'herwig65.inc'
39922       DOUBLE PRECISION FAC,ANGLE
39923       INTEGER I,J,N,L
39924       CHARACTER*28 TITLE
39925       SAVE TITLE
39926       DATA TITLE/'HERWIG 6.510  31st Oct. 2005'/
39927       WRITE (6,10) TITLE
39928   10  FORMAT(//10X,A28//,
39929      &         10X,'Please reference:  G. Marchesini, B.R. Webber,',/,
39930      &         10X,'G.Abbiendi, I.G.Knowles, M.H.Seymour & L.Stanco',/,
39931      &         10X,'Computer Physics Communications 67 (1992) 465',/,
39932      &         10X,'                   and',/,
39933      &         10X,'G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti,'
39934      & ,/,     10X,'K.Odagiri, P.Richardson, M.H.Seymour & B.R.Webber,'
39935      & ,/,     10X,'JHEP 0101 (2001) 010')
39936       CALL HWICHK
39937 C---PRINT OPTIONS:
39938 C     IPRINT=0     NO PRINTOUT
39939 C            1     PRINT SELECTED INPUT PARAMETERS
39940 C            2     1 + TABLE OF PARTICLE CODES AND PROPERTIES
39941 C            3     2 + TABLES OF SUDAKOV FORM FACTORS
39942       IPRINT=1
39943 C Format for track numbers in event listing
39944 C     PRNDEC=.TRUE.  use decimal
39945 C            .FALSE. use hexadecimal
39946       PRNDEC=(NMXHEP.LE.9999)
39947 C Number of significant figures to print out in event listing
39948 C NPRFMT (< 2) compact 80 character stout and A4-long tex output,
39949 C (= 2) 2 decimal places in stout, (> 2) - 5 decimal places in stout
39950       NPRFMT=1
39951 C Print out vertex information
39952       PRVTX=.TRUE.
39953 C Print out particle properties/event record to stout, tex or web
39954       PRNDEF=.TRUE.
39955       PRNTEX=.FALSE.
39956       PRNWEB=.FALSE.
39957 C---MAX NO OF EVENTS TO PRINT
39958       MAXPR=1
39959 C---UNIT FOR READING SUDAKOV FORM FACTORS (IF ZERO THEN COMPUTE THEM)
39960       LRSUD=0
39961 C---UNIT FOR WRITING SUDAKOV FORM FACTORS (IF ZERO THEN NOT WRITTEN)
39962       LWSUD=77
39963 C---UNIT FOR WRITING EVENT DATA IN HWANAL (IF ZERO THEN NOT WRITTEN)
39964       LWEVT=0
39965 C---SEEDS FOR RANDOM NUMBER GENERATOR (CALLED HWRGEN)
39966       NRN(1)= 17673
39967       NRN(2)= 63565
39968 C---ALLOW NEGATIVE WEIGHTS?
39969       NEGWTS=.FALSE.
39970 C---AZIMUTHAL CORRELATIONS?
39971 C   THESE INCLUDE SOFT GLUON (INSIDE CONE)
39972       AZSOFT=.TRUE.
39973 C   AND NEAREST-NEIGHBOUR SPIN CORRELATIONS
39974       AZSPIN=.TRUE.
39975 C---MATRIX-ELEMENT MATCHING FOR E+E-, DIS, DRELL-YAN AND TOP DECAY
39976 C---HARD EMISSION
39977       HARDME=.TRUE.
39978 C---SOFT EMISSION
39979       SOFTME=.TRUE.
39980 C---GLUON ENERGY CUT FOR TOP DECAY CASE
39981       GCUTME=2
39982 C Electromagnetic fine structure constant: Thomson limit
39983       ALPHEM=.0072993
39984 C---QCD LAMBDA: CORRESPONDS TO 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X ONLY
39985       QCDLAM=0.18
39986 C---NUMBER OF COLOURS
39987       NCOLO=3
39988 C---NUMBER OF FLAVOURS
39989       NFLAV=6
39990 C---QUARK, GLUON AND PHOTON VIRTUAL MASS CUTOFFS IN
39991 C   PARTON SHOWER (ADDED TO MASSES GIVEN BELOW)
39992       VQCUT=0.48
39993       VGCUT=0.10
39994       VPCUT=0.40
39995       ALPFAC=1
39996 C---D,U,S,C,B,T QUARK AND GLUON MASSES (IN THAT ORDER)
39997       RMASS(1)=0.32
39998       RMASS(2)=0.32
39999       RMASS(3)=0.5
40000       RMASS(4)=1.55
40001       RMASS(5)=4.95
40002       RMASS(6)=174.3
40003       RMASS(13)=0.75
40004 C---W+/- AND Z0 MASSES
40005       RMASS(198)=80.42
40006       RMASS(199)=80.42
40007       RMASS(200)=91.188
40008 C---HIGGS BOSON MASS
40009       RMASS(201)=115.
40010 C---WIDTHS OF W, Z, HIGGS
40011       GAMW=2.12
40012       GAMZ=2.495
40013 C SM Higgs width is actually recomputed by HWDHIG
40014 C but this value corresponds to RMASS(201)=115.
40015       GAMH=0.0037
40016 C Include additional neutral, massive vector boson (Z')
40017       ZPRIME=.FALSE.
40018 C Z' mass and width
40019       RMASS(202)=500.
40020       GAMZP=5.
40021 C Graviton properties
40022 C Graviton mass and width (default mass 1 TeV and calculated width)
40023       EMGRV  = 1000.0D0
40024       GAMGRV = ZERO
40025 C Graviton coupling (this has dimensions of mass)
40026       GRVLAM = 10000.0D0
40027 C Lepton (EPOLN) and anti-lepton (PPOLN) beam polarisations used in:
40028 C e+e- --> ffbar/qqbar g; and l/lbar N DIS.
40029 C Cpts. 1,2 Transverse polarisation; cpt. 3 longitudinal polarisation.
40030 C Note require POLN(1)**2+POLN(2)**2+POLN(3)**2 < 1.
40031       DO 20 I=1,3
40032       EPOLN(I)=0.
40033   20  PPOLN(I)=0.
40034 C-----------------------------------------------------------------------
40035 C     Specify couplings of weak vector bosons to fermions:
40036 C
40037 C     electric current:      QFCH(I)*e*G_mu       (electric charge, e>0)
40038 C     weak neutral current: [VFCH(I,J).1+AFCH(I,J).G_5]*e*G_mu
40039 C     weak charged current: SQRT(VCKM(K,L)/2.)*g*(1+G_5)*G_mu
40040 C
40041 C     I= 1- 6: d,u,s,c,b,t (quarks)
40042 C      =11-16: e,nu_e,mu,nu_mu,tau,nu_tau (leptons) (`I=IDHW-110')
40043 C     J=1 for minimal SM:
40044 C      =2 for Z' couplings (ZPRIME=.TRUE.)
40045 C     K=1,2,3 for u,c,t;    L=1,2,3 for d,s,b
40046 C-----------------------------------------------------------------------
40047 C Minimal standard model neutral vector boson couplings
40048 C VFCH(I,1)=(T3/2-Q*S^2_W)/(C_W*S_W);  AFCH(I,1)=T3/(2*C_W*S_W)
40049 C sin**2 Weinberg angle (PDG '94)
40050       SWEIN=.2319
40051       FAC=1./SQRT(SWEIN*(1.-SWEIN))
40052       DO 30 I=1,3
40053 C Down-type quarks
40054       J=2*I-1
40055       QFCH(J)=-1./3.
40056       VFCH(J,1)=(-0.25+SWEIN/3.)*FAC
40057       AFCH(J,1)= -0.25*FAC
40058 C Up-type quarks
40059       J=2*I
40060       QFCH(J)=+2./3.
40061       VFCH(J,1)=(+0.25-2.*SWEIN/3.)*FAC
40062       AFCH(J,1)= +0.25*FAC
40063 C Charged leptons
40064       J=2*I+9
40065       QFCH(J)=-1.
40066       VFCH(J,1)=(-0.25+SWEIN)*FAC
40067       AFCH(J,1)= -0.25*FAC
40068 C Neutrinos
40069       J=2*I+10
40070       QFCH(J)=0.
40071       VFCH(J,1)=+0.25*FAC
40072       AFCH(J,1)=+0.25*FAC
40073   30  CONTINUE
40074 C Additional Z' couplings (To be set by the user)
40075       IF (.NOT.ZPRIME) THEN
40076          DO 40 I=1,6
40077          AFCH(I,2)=0.
40078          AFCH(10+I,2)=0.
40079          VFCH(I,2)=0.
40080          VFCH(10+I,2)=0.
40081   40     CONTINUE
40082       ENDIF
40083 C--calculate left and right couplings of bosons for axial and vector ones
40084       DO 45 J=1,16
40085         IF(J.LE.6.OR.J.GE.11) THEN
40086           LFCH(J)=VFCH(J,1)+AFCH(J,1)
40087           RFCH(J)=VFCH(J,1)-AFCH(J,1)
40088         ENDIF
40089  45   CONTINUE
40090 C Cabibbo-Kobayashi-Maskawa matrix elements squared (PDG '92):
40091 C sin**2 of Cabibbo angle
40092       SCABI=.0488
40093 C u ---> d,s,b
40094       VCKM(1,1)=1.-SCABI
40095       VCKM(1,2)=SCABI
40096       VCKM(1,3)=0.0
40097 C c ---> d,s,b
40098       VCKM(2,1)=SCABI
40099       VCKM(2,2)=1.-SCABI-.002
40100       VCKM(2,3)=0.002
40101 C t ---> d,b,s
40102       VCKM(3,1)=0.0
40103       VCKM(3,2)=0.002
40104       VCKM(3,3)=0.998
40105 C---GAUGE BOSON DECAYS
40106       DO 50 I=1,12
40107       BRHIG(I)=1.D0/12
40108       ENHANC(I)=1.D0
40109  50   CONTINUE
40110       DO 55 I=1,MODMAX
40111       MODBOS(I)=0
40112  55   CONTINUE
40113 C
40114 C THE iTH GAUGE BOSON DECAY PER EVENT IS CONTROLLED BY MODBOS AS FOLLOWS
40115 C         MODBOS(i)     W DECAY        Z DECAY
40116 C             0           all            all
40117 C             1          qqbar          qqbar
40118 C             2           enu            e+e-
40119 C             3           munu          mu+mu-
40120 C             4          taunu         tau+tau-
40121 C             5        enu & munu      ee & mumu
40122 C             6           all            nunu
40123 C             7           all           bbbar
40124 C            >7           all            all
40125 C BOSON PAIRS (eg FROM HIGGS DECAY)ARE CHOSEN FROM MODBOS(i),MODBOS(i+1)
40126 C
40127 C---CONTROL OF LARGE EMH BEHAVIOUR (SEE HWHIGM FOR DETAILS)
40128       IOPHIG=3
40129       GAMMAX=10.
40130 C Specify approximation used in HWHIGA
40131       IAPHIG=1
40132 C---MASSES OF HYPOTHETICAL NEW QUARKS GO
40133 C   INTO 209-214 (ANTIQUARKS IN 215-220)
40134 C   ID = 209,210 ARE B',T' WITH DECAYS T'->B'->C
40135 C        211,212 ARE B',T' WITH DECAYS T'->B'->T
40136 C        215-218 ARE THEIR ANTIQUARKS
40137       RMASS(209)=200.
40138       RMASS(215)=200.
40139 C---MAXIMUM CLUSTER MASS PARAMETERS
40140 C   N.B. LIMIT FOR Q1-Q2BAR CLUSTER MASS
40141 C   IS (CLMAX**CLPOW + (QM1+QM2)**CLPOW)**(1/CLPOW)
40142       CLMAX=3.35
40143       CLPOW=2.0
40144 C   For PSPLT(I), CLDIR(I) & CLSMR(I): I=1 light u,d,s,c cluster
40145 C                                       =2 heavy b cluster
40146 C---MASS SPECTRUM OF PRODUCTS IN CLUSTER
40147 C   SPLITTING ABOVE CLMAX - FLAT IN M**PSPLT(*)
40148       PSPLT(1)=1.0
40149       PSPLT(2)=PSPLT(1)
40150 C---KINEMATIC TREATMENT OF CLUSTER DECAY
40151 C   0=ISOTROPIC, 1=REMEMBER DIRECTION OF PERTURBATIVELY PRODUCED QUARKS
40152       CLDIR(1)=1
40153       CLDIR(2)=CLDIR(1)
40154 C   IF CLDIR(*)=1, DO GAUSSIAN SMEARING OF DIRECTION:
40155 C   ACTUALLY EXPONENTIAL IN 1-COS(THETA) WITH MEAN CLSMR(*)
40156       CLSMR(1)=0.0
40157       CLSMR(2)=CLSMR(1)
40158 C---OPTION FOR TREATMENT OF REMNANT CLUSTERS:
40159 C   0=BOTH CHILDREN ARE SOFT, (EQUIVALENT TO PREVIOUS VERSIONS)
40160 C   1=REMNANT CHILD IS SOFT, BUT PERTURBATIVE CHILD IS NORMAL
40161       IOPREM=1
40162 C---TREATMENT OF LOWER LIMIT FOR SPACELIKE EVOLUTION
40163 C   0=EVOLUTION STOPS AT QSPAC, BUT STRUCT FUNS CAN GET CALLED AT
40164 C   SMALLER SCALES IN FORCED EMISSION (EQUIVALENT TO V5.7 AND EARLIER)
40165 C   1=EVOLUTION STOPS AT QSPAC, STRUCTURE FUNCTIONS FREEZE AT QSPAC
40166 C   2=EVOLUTION CONTINUES TO INFRARED CUT, BUT S.F.S FREEZE AT QSPAC
40167       ISPAC=0
40168 C---LOWER LIMIT FOR SPACELIKE EVOLUTION
40169       QSPAC=2.5
40170 C---SWITCH OFF SPACE-LIKE SHOWERS
40171       NOSPAC=.FALSE.
40172 C---INTRINSIC PT OF SPACELIKE PARTONS (RMS)
40173       PTRMS=0.0
40174 C---MASS PARAMETER IN REMNANT FRAGMENTATION
40175       BTCLM=1.0
40176 C---PARAMETERS CONTROLLING VERY SMALL-X BEHAVIOUR OF PDFS
40177       PDFX0=0
40178       PDFPOW=0
40179 C---STRUCTURE FUNCTION SET:
40180 C   SET MODPDF(I)=MODE AND AUTPDF='AUTHOR GROUP' TO USE CERN LIBRARY
40181 C   PDFLIB PACKAGE FOR STRUCTURE FUNCTIONS IN BEAM I
40182       MODPDF(1)=34
40183       MODPDF(2)=34
40184       AUTPDF(1)='CTEQ'
40185       AUTPDF(2)='CTEQ'
40186 C   OR SET MODPDF(I)=-1 TO USE BUILT-IN STRUCTURE FUNCTION SET:
40187 C   1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
40188 C   3,4 FOR EICHTEN+AL SETS 1,2 (NUCLEONS ONLY)
40189 C    5  FOR OWENS      SET  1.1 (SOFT GLUE ONLY)
40190 C    6  FOR MRST98LO   central alpha_s/gluon
40191 C    7  FOR MRST98LO   higher gluon
40192 C    8  FOR MRST98LO average of central and higher gluon (default)
40193       NSTRU=8
40194 C   PARAMETER FOR B CLUSTER DECAY TO 1 HADRON. IF MCL IS CLUSTER MASS
40195 C   AND MTH IS THRESHOLD FOR 2-HADRON DECAY, THEN PROBABILITY IS
40196 C   1 IF MCL<MTH, 0 IF MCL>(1+B1LIM)*MTH, WITH LINEAR INTERPOLATION,
40197       B1LIM=0.0
40198 C---B DECAY PACKAGE ('HERW'=>HERWIG, 'EURO'=>EURODEC, 'CLEO'=>CLEO)
40199       BDECAY='HERW'
40200 C---TAU DECAY PACKAGE ('HERWIG'=>HERWIG, 'TAUOLA'=> TAUOLA)
40201       TAUDEC='HERWIG'
40202 C--default options for TAUOLA (if used)
40203 C JAK=0 ALL MODES
40204 C JAK=1 ELECTRON MODE
40205 C JAK=2 MUON MODE
40206 C JAK=3 PION MODE
40207 C JAK=4 RHO MODE
40208 C JAK=5 A1 MODE
40209 C JAK=6 K MODE
40210 C JAK=7 K* MODE
40211 C JAK=8 nPI MODE
40212 C--tau decay modes (1 is tau+ and 2 is tau-)
40213       JAK1 = 0
40214       JAK2 = 0
40215 C--radiative corrections in tau decay (1 on/ 0 off)
40216       ITDKRC=1
40217 C--use PHOTOS in tau decays (1 PHOTOS/ 0 no PHOTOS)
40218       IFPHOT=1
40219 C--use PHOTOS in ttbar production and decay
40220       ITOPRD=0
40221 C---HARD SUBPROCESS SCALE TO BE USED IN 4-JET MATRIX ELEMENT OPTION
40222 C   IF (FIX4JT) THEN SCALE=C.M. ENERGY
40223 C   ELSE SCALE=2.*MIN(PI.PJ)
40224       FIX4JT=.FALSE.
40225 C---HARD SUBPROCESS SCALE TO BE USED IN BOSON-GLUON FUSION
40226 C   IF (BGSHAT) THEN SCALE=SHAT
40227 C   ELSE SCALE=2.*SHAT*THAT*UHAT/(SHAT**2+THAT**2+UHAT**2)
40228       BGSHAT=.FALSE.
40229 C---RECONSTRUCT DIS EVENTS IN BREIT FRAME
40230       BREIT=.TRUE.
40231 C---TREAT ALL EVENTS IN THEIR CMF (ELSE USE LAB FRAME)
40232       USECMF=.TRUE.
40233 C---TREAT W/Z DECAY IN ITS REST FRAME
40234       WZRFR=.TRUE.
40235 C---PROBABILITY OF UNDERLYING SOFT EVENT:
40236       PRSOF=ONE
40237 C---SOFT UNDERLYING OR MIN BIAS EVENT PARAMETERS
40238 C   DEFAULT VALUES ARE FROM UA5 COLLAB, NPB291(1987)445
40239 C   NCH_PPBAR(SQRT(S)) = PMBN1*S**PMBN2+PMBN3
40240       PMBN1= 9.11
40241       PMBN2= 0.115
40242       PMBN3=-9.50
40243 C   1/K (IN NEG BINOMIAL) = PMBK1*LN(S)+PMBK2
40244       PMBK1= 0.029
40245       PMBK2=-0.104
40246 C   SOFT CLUSTER MASS SPECTRUM (M-M1-M2-PMBM1)*EXP(-PMBM2*M)
40247       PMBM1= 0.4
40248       PMBM2= 2.0
40249 C   SOFT CLUSTER PT SPECTRUM PT*EXP(-B*SQRT(PT**2+M**2))
40250 C   B=PMBP1 FOR D,U, PMBP2 FOR S,C, PMBP3 FOR DIQUARKS
40251       PMBP1= 5.2
40252       PMBP2= 3.0
40253       PMBP3= 5.2
40254 C---MULTIPLICITY ENHANCEMENT FOR UNDERLYING SOFT EVENT:
40255 C   NCH = NCH_PPBAR(ENSOF*SQRT(S))
40256       ENSOF=1.
40257 C   PARAMETERS FOR MUELLER TANG FORMULA: IPROC=2400
40258 C---THE VALUE TO USE FOR FIXED ALPHA_S IN DENOMINATOR
40259       ASFIXD=0.25
40260 C---OMEGA0=12*LOG(2)*ALPHA_S/PI, BUT NOT NECESSARILY THE SAME ALPHA_S
40261       OMEGA0=0.3
40262 C---MIN AND MAX JET RAPIDITIES IN QCD 2->2,
40263 C   HEAVY FLAVOUR, SUSY AND DIRECT PHOTON PROCESSES
40264       YJMAX=8.
40265       YJMIN=-YJMAX
40266 C---MIN AND MAX PARTON TRANSVERSE MOMENTUM
40267 C   IN ELEMENTARY 2 -> 2 SUBPROCESSES
40268       PTMIN=1D1
40269       PTMAX=1D8
40270 C---UPPER LIMIT ON HARD PROCESS SCALE
40271       QLIM=1D8
40272 C---MAX PARTON THRUST IN 2->3 HARD PROCESSES
40273       THMAX=0.9
40274 C   Set parameters for 2->4 hard process
40275 C   Choose inter-jet metric (else JADE) and minimum y-cut
40276       DURHAM=.TRUE.
40277       Y4JT=0.01
40278 C---TREATMENT OF COLOUR INTERFERENCE IN E+E- -> 4 JETS:
40279 C     qqbar-gg case:
40280 C     IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
40281 C     qqbar-qqbar (identical quark flavour) case:
40282 C     IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
40283       IOP4JT(1)=0
40284       IOP4JT(2)=0
40285 C---MIN AND MAX DILEPTON INVARIANT MASS IN DRELL-YAN PROCESS
40286       EMMIN=0D0
40287       EMMAX=1D8
40288 C---MIN AND MAX ABS(Q**2) IN DEEP INELASTIC LEPTON SCATTERING
40289       Q2MIN=0D0
40290       Q2MAX=1D10
40291 C---MIN AND MAX ABS(Q**2) IN WEISZACKER-WILLIAMS APPROXIMATION
40292       Q2WWMN=0.
40293       Q2WWMX=4.
40294 C---MIN AND MAX ENERGY FRACTION IN WEISZACKER-WILLIAMS APPROXIMATION
40295       YWWMIN=0.
40296       YWWMAX=1.
40297 C---MINIMUM HADRONIC MASS FOR PHOTON-INDUCED PROCESSES (INCLUDING DIS)
40298       WHMIN=0.
40299 C---IF PHOMAS IS NON-ZERO, PARTON DISTRIBUTION FUNCTIONS FOR OFF-SHELL
40300 C   PHOTONS IS DAMPED, WITH MASS PARAMETER = PHOMAS
40301       PHOMAS=0.
40302 C---MIN AND MAX FLAVOURS GENERATED BY IPROC=9100,9110,9130
40303       IFLMIN=1
40304       IFLMAX=5
40305 C---MAX Z IN J/PSI PHOTO- AND ELECTRO- PRODUCTION
40306       ZJMAX=0.9
40307 C---MIN AND MAX BJORKEN-Y
40308       YBMIN=0.
40309       YBMAX=1.
40310 C---MIN jet-jet mass in Drell-Yan+2 jets
40311       MJJMIN = 10.0D0
40312 C---MAX COS(THETA) FOR W'S IN E+E- -> W+W-
40313       CTMAX=0.9999
40314 C   Minimum virtuality^2 of partons to use in calculating distances
40315       VMIN2=0.1
40316 C   Exageration factor for lifetimes of weakly decaying heavy particles
40317       EXAG=1.
40318 C   Include colour rearrangement in cluster formation
40319       CLRECO=.FALSE.
40320 C   Probability for colour rearrangement to occur
40321       PRECO=1./9.
40322 C   Minimum lifetime for particle to be considered stable
40323       PLTCUT=1.D-8
40324 C   Incude neutral B-meson mixing
40325       MIXING=.TRUE.
40326 C   Set B_s and B_d mixing parameters: X=Delta m/Gamma
40327       XMIX(1)=10.0
40328       XMIX(2)=0.70
40329 C   Y=Delta Gamma/2*Gamma
40330       YMIX(1)=0.2
40331       YMIX(2)=0.0
40332 C   Include a cut on particle decay lengths
40333       MAXDKL=.FALSE.
40334 C   Set option for decay length cut (see HWDXLM)
40335       IOPDKL=1
40336 C   Radius for cylindrical option (mm) (IOPDKL=1)
40337       DXRCYL=20.0D0
40338 C   Length for cylindrical option(IOPDKL=1)
40339       DXZMAX=500.0D0
40340 C   Radius for spherical option(IOPDKL=2)
40341       DXRSPH=100.0D0
40342 C   Smear the primary interaction vertex: see HWRPIP for details
40343       PIPSMR=.FALSE.
40344 C   Widths of Gaussian smearing in x,y,z (mm)
40345       VIPWID(1)=0.25D0
40346       VIPWID(2)=0.015D0
40347       VIPWID(3)=1.8D0
40348       DO 60 I=0,NMXRES
40349 C   Veto cluster decays into particle type I
40350       VTOCDK(I)=.FALSE.
40351 C   Veto unstable particle decays into modes involving particle type I
40352   60  VTORDK(I)=.FALSE.
40353 C   Veto f_0(980) and a_0(980) production in cluster decays
40354       VTOCDK(290)=.TRUE.
40355       VTOCDK(291)=.TRUE.
40356       VTOCDK(292)=.TRUE.
40357       VTOCDK(293)=.TRUE.
40358 C---MINIMUM AND MAXIMUM S-HAT/S RANGE FOR PHOTON ISR
40359       TMNISR=1D-4
40360       ZMXISR=1-1D-6
40361 C---COLISR IS .TRUE. TO MAKE ISR PHOTONS COLLINEAR WITH BEAMS
40362       COLISR=.FALSE.
40363 C A Priori weights for mesons w.r.t. pionic n=1, 0-(+) states:
40364 C old VECWT=REPWT(0,1,0) & TENWT=REPWT(0,2,0)
40365       DO 70 N=0,4
40366       DO 70 J=0,4
40367       DO 70 L=0,3
40368   70  REPWT(L,J,N)=1.
40369 C and singlet (Lambda-like) and decuplet barons
40370       SNGWT=1.
40371       DECWT=1.
40372 C---A PRIORI WEIGHTS FOR D,U,S,C,B,T QUARKS AND DIQUARKS (IN THAT ORDER)
40373       PWT(1)=1.
40374       PWT(2)=1.
40375       PWT(3)=1.
40376       PWT(4)=1.
40377       PWT(5)=1.
40378       PWT(6)=1.
40379       PWT(7)=1.
40380 C   Octet-Singlet isoscalar mixing angles in degrees
40381 C   (use ANGLE for ideal mixing, recommended for F0MIX & OMHMIX)
40382       ANGLE=ATAN(ONE/SQRT(TWO))*180./ACOS(-ONE)
40383 C     eta - eta'
40384       ETAMIX=-23.
40385 C     phi - omega
40386       PHIMIX=+36.
40387 C     h_1(1380) - h_1(1170)
40388       H1MIX=ANGLE
40389 C     MISSING - f_0(1370)
40390       F0MIX=ANGLE
40391 C     f_1(1420) - f_1(1285)
40392       F1MIX=ANGLE
40393 C     f'_2 - f_2
40394       F2MIX=+26.
40395 C     MISSING - omega(1600)
40396       OMHMIX=ANGLE
40397 C     eta_2(1645) - eta_2(1870)
40398       ET2MIX=ANGLE
40399 C     phi_3 - omega_3
40400       PH3MIX=+28.
40401 C---PARAMETERS FOR NON-PERTURBATIVE SPLITTING OF GLUONS INTO
40402 C   DIQUARK-ANTIDIQUARK PAIRS:
40403 C   SCALE AT WHICH GLUONS CAN BE SPLIT INTO DIQUARKS
40404 C   (0.0 FOR NO SPLITTING)
40405       QDIQK=0.0
40406 C   PROBABILITY (PER UNIT LOG SCALE) OF DIQUARK SPLITTING
40407       PDIQK=5.0
40408 C---PARAMETERS FOR IMPORTANCE SAMPLING
40409 C   ASSUME QCD 2->2 DSIG/DET FALLS LIKE ET**(-PTPOW)
40410 C   WHERE ET=SQRT(MQ**2+PT**2) FOR HEAVY FLAVOURS
40411       PTPOW=4.
40412 C   DEFAULT PTPOW=2 FOR SUSY PROCESSES
40413       IF (MOD(IPROC/100,100).EQ.30) PTPOW=2.
40414 C   ASSUME DRELL-YAN DSIG/DEM FALLS LIKE EM**(-EMPOW)
40415       EMPOW=4.
40416 C   ASSUME DEEP INELASTIC DSIG/DQ**2 FALLS LIKE (Q**2)**(-Q2POW)
40417       Q2POW=2.5
40418 C---GENERATE UNWEIGHTED EVENTS (EVWGT=AVWGT)?
40419       NOWGT=.TRUE.
40420 C---DEFAULT MEAN EVENT WEIGHT
40421       AVWGT=1.
40422 C---ASSUMED MAXIMUM WEIGHT (ZERO TO RECOMPUTE)
40423       WGTMAX=0.
40424 C---MINIMUM ACCEPTABLE EVENT GENERATION EFFICIENCY
40425       EFFMIN=1D-3
40426 C---MAX NO OF (CODE.GE.100) ERRORS
40427       MAXER=MAX(10,MAXEV/100)
40428 C---TIME (SEC) NEEDED TO TERMINATE GRACEFULLY
40429       TLOUT=5.
40430 C---CURRENT NO OF EVENTS
40431       NEVHEP=0
40432 C---CURRENT NO OF ENTRIES IN /HEPEVT/
40433       NHEP=0
40434 C---ISTAT IS STATUS OF EVENT (I.E. STAGE IN PROCESSING)
40435       ISTAT=0
40436 C---IERROR IS ERROR CODE
40437       IERROR=0
40438 C---MORE TECHNICAL PARAMETERS - SHOULDN'T NEED ADJUSTMENT
40439 C---PI
40440       PIFAC=ACOS(-1.D0)
40441 C Speed of light (mm/s)
40442       CSPEED=2.99792D11
40443 C Cross-section conversion factor (hbar.c/e)**2
40444       GEV2NB=389379.D0
40445 C---NUMBER OF SHOTS FOR INITIAL MAX WEIGHT SEARCH
40446       IBSH=10000
40447 C---RANDOM NO. SEEDS FOR INITIAL MAX WEIGHT SEARCH
40448       IBRN(1)=1246579
40449       IBRN(2)=8447766
40450 C--Number of shots and steps for the optimisation procedure
40451       IOPSH  = 1000
40452       IOPSTP = 10
40453 C---NUMBER OF ENTRIES IN LOOKUP TABLES OF SUDAKOV FORM FACTORS
40454       NQEV=1024
40455 C---MAXIMUM BIN SIZE IN Z FOR SPACELIKE BRANCHING
40456       ZBINM=0.05
40457 C---MAXIMUM NUMBER OF Z BINS FOR SPACELIKE BRANCHING
40458       NZBIN=100
40459 C---MAXIMUM NUMBER OF BRANCH REJECTIONS (TO AVOID INFINITE LOOPS)
40460       NBTRY=200
40461 C---MAXIMUM NUMBER OF TRIES TO GENERATE CLUSTER DECAY
40462       NCTRY=200
40463 C---MAXIMUM NUMBER OF TRIES TO GENERATE MASS REQUESTED
40464       NETRY=200
40465 C---MAXIMUM NUMBER OF TRIES TO GENERATE SOFT SUBPROCESS
40466       NSTRY=200
40467 C---MAXIMUM NUMBER OF TRIES TO GENERATE SPIN DECAYS
40468       NSNTRY=500
40469 C---MAXIMUM NUMBER OF TRIES TO GENERATE FOUR/FIVE BODY DECAYS
40470       NDETRY=20000
40471 C---PRECISION FOR GAUSSIAN INTEGRATION
40472       ACCUR=1.D-6
40473 C---ORDER OF INTERPOLATION IN SUDAKOV TABLES
40474       INTER=3
40475 C---ORDER TO USE FOR ALPHAS IN SUDAKOV TABLES
40476       SUDORD=1
40477 C---DEFAULT UNIT FOR THE SUSY DATA FILE
40478       LRSUSY = 66
40479 C---CONSERVATION OF RPARITY
40480       RPARTY = .TRUE.
40481 C---CHECK WHETHER SUSY DATA INPUTTED
40482       SUSYIN = .FALSE.
40483 C---SPIN CORRELATIONS IN TOP/TAU/SUSY DECAYS
40484       SYSPIN = .TRUE.
40485 C---THREE BODY SUSY MATRIX ELEMENTS
40486       THREEB = .TRUE.
40487 C---FOUR  BODY SUSY MATRIX ELEMENTS
40488       FOURB  = .FALSE.
40489 C---OPTION FOR DIFFERENT COLOUR FLOWS IN SPIN CORRELATION
40490 C---(1 is first  option in DAMTP-2001-83 only for SM/MSSM)
40491 C---(2 is second option in DAMTP-2001-83 needed for RPV)
40492       SPCOPT = 1
40493 C---number of weights for maximum search for 3/4 body MEs
40494       NSEARCH = 500
40495 C--unit to read three/four body decays from (if 0 computed)
40496       LRDEC = 0
40497 C--unit to write three/four body decays to (if 0 not written)
40498       LWDEC = 88
40499 C--WHETHER OR NOT TO OPTIMIZE THE WEIGHTS IN MULTICHANNEL PROCESSES
40500       OPTM = .FALSE.
40501 C--initializes the multichannel integrals
40502       CALL HWIPHS(1)
40503 C   CIRCE INTERFACE
40504 C---CIRCE IS CONTROLLED BY THESE NEW VARIABLES:
40505 C---CIRCOP = CIRCE OPTION: 0=NO CIRCE, STANDARD HERWIG
40506 C                          1=NO CIRCE, HERWIG WITH COLLINEAR KINEMATICS
40507 C                          2=BEAMSTRAHLUNG FROM CIRCE
40508 C                          3=BEAMSTRAHLUNG FROM CIRCE PLUS BREMSTRAHLUNG
40509 C   THEREFORE 0 SHOULD BE REGARDED AS OFF AND 3 AS ON.  THE OTHERS ARE
40510 C   MAINLY THERE FOR CROSS-CHECKING PURPOSES
40511       CIRCOP=0
40512 C---CIRCAC, CIRCVR, CIRCRV, CIRCCH = CIRCE INPUTS ACC, VER, REV AND CHAT
40513 C   EG CIRCAC=1=SBAND, CIRCAC=2=TESLA, CIRCAC=3=XBAND
40514       CIRCAC=2
40515       CIRCVR=7
40516       CIRCRV=9999 12 31
40517       CIRCCH=0
40518 C---END OF CIRCE VARIABLES
40519 C--options for Les Houches Accord
40520 C--allow self connected gluons (.TRUE.) or forbid (.FALSE.)
40521       LHGLSF = .FALSE.
40522 C--generate the soft event (.TRUE.) or don't (.FALSE.)
40523       LHSOFT = .TRUE.
40524 C--conserve longitudinal momentum (.true.) or rapidity of hard process
40525       PRESPL = .TRUE.
40526       END
40527 CDECK  ID>, HWIGUP.
40528 *CMZ :-        -15/07/02  16.42.23  by  Peter Richardson
40529 *-- Author :    Peter Richardson
40530 C----------------------------------------------------------------------
40531       SUBROUTINE HWIGUP
40532 C----------------------------------------------------------------------
40533 C     Use the GUPI (Generic User Process Interface) run common block
40534 C     to initialise HERWIG -- Initialization for Les Houches interface
40535 C----------------------------------------------------------------------
40536       INCLUDE 'herwig65.inc'
40537       INTEGER MAXPUP
40538       PARAMETER(MAXPUP=100)
40539       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
40540       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
40541       COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
40542      &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
40543      &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
40544       CHARACTER *8 DUMMY,PDFNUC(9),PDFPI(9),PDFPHT(9)
40545       INTEGER I,IDB(2)
40546       SAVE PDFNUC,PDFPI ,PDFPHT
40547       DATA PDFNUC/ 'DO','DFLM','MRS','CTEQ','GRV','ABFOW','BM',
40548      &             '        ','         '/
40549       DATA PDFPI / 'OW-P','        ','SMRS-P','        ','GRV-P',
40550      &             'ABFKW-P','        ','        ','        '/
40551       DATA PDFPHT /'DO-G','DG-G','LAC-G','GS-G','GRV-G','ACG-G',
40552      &             '         ','WHIT-G','SaSph'/
40553 C--call the user routine to do the initialisation
40554       CALL UPINIT_GUP
40555 C$$$$$$  I modified the previous sentence UPINIT for UPINIT_GUP  (otherwise it can't call it, why??? I have no idea!!)
40556 C--setup the beam particles and momentum
40557       CALL HWUIDT(1,IDBMUP(1),IDB(1),DUMMY)
40558       PART1=DUMMY
40559       CALL HWUIDT(1,IDBMUP(2),IDB(2),DUMMY)
40560       PART2=DUMMY
40561       PBEAM1 = SQRT(EBMUP(1)**2-RMASS(IDB(1))**2)
40562       PBEAM2 = SQRT(EBMUP(2)**2-RMASS(IDB(2))**2)
40563 C--set up for PDFLIB if need
40564       DO I=1,2
40565         IF(PDFGUP(I).NE.-1) THEN
40566           IF(PDFGUP(I).LT.1.OR.PDFGUP(I).GT.9) CALL HWWARN('HWIGUP',500)
40567           MODPDF(I) = PDFSUP(I)
40568 C--proton/neutron beams
40569           IF(ABS(IDBMUP(I)).EQ.2212.OR.ABS(IDBMUP(I)).EQ.2112) THEN
40570             AUTPDF(I) = PDFNUC(PDFGUP(I))
40571 C--photon beams
40572           ELSEIF(ABS(IDBMUP(I)).EQ.22) THEN
40573             AUTPDF(I) = PDFPHT(PDFGUP(I))
40574 C--pion beams
40575           ELSEIF(ABS(IDBMUP(I)).EQ.211) THEN
40576             AUTPDF(I) = PDFPI(PDFGUP(I))
40577 C--unknown beam type
40578           ELSE
40579             CALL HWWARN('HWIGUP',500)
40580           ENDIF
40581         ENDIF
40582       ENDDO
40583 C--decide what to do about the weights
40584       IF(ABS(IDWTUP).EQ.1) THEN
40585         WGTMAX = ZERO
40586         AVWGT  = ONE
40587         AVABW  = ONE
40588         NOWGT  = .TRUE.
40589 C--sum up the magnitudes of the maximum weight
40590         LHMXSM = ZERO
40591         DO I=1,NPRUP
40592           LHXMAX(I) = XMAXUP(I)*1.0D-3
40593           LHMXSM    = LHMXSM+ABS(LHXMAX(I))
40594         ENDDO
40595         ITYPLH = 0
40596       ELSEIF(ABS(IDWTUP).EQ.2) THEN
40597         WGTMAX = ZERO
40598         AVWGT  = ONE
40599         AVABW  = ONE
40600         NOWGT = .TRUE.
40601 C--sum the cross sections and obtain the total
40602         LHMXSM = ZERO
40603         DO I=1,NPRUP
40604           LHXSCT(I) = XSECUP(I)*1.0D-3
40605           LHXMAX(I) = XMAXUP(I)*1.0D-3
40606           LHMXSM = LHMXSM+ABS(LHXSCT(I))
40607         ENDDO
40608         ITYPLH = 0
40609       ELSEIF(ABS(IDWTUP).EQ.3) THEN
40610         WGTMAX = ONE
40611         AVWGT  = ONE
40612         AVABW  = ONE
40613         NOWGT = .TRUE.
40614       ELSEIF(ABS(IDWTUP).EQ.4) THEN
40615         WGTMAX = ONE
40616         AVWGT  = ONE
40617         NOWGT = .FALSE.
40618       ENDIF
40619       IF(IDWTUP.LT.0) NEGWTS = .TRUE.
40620 C--zero the weight
40621       DO I=1,NPRUP
40622         LHWGT (I) = ZERO
40623         LHWGTS(I) = ZERO
40624         LHIWGT(I) = 0
40625         LHNEVT(I) = 0
40626       ENDDO
40627       END
40628 CDECK  ID>, HWIMDE.
40629 *CMZ :-        -12/10/01  17.14.22  by  Peter Richardson
40630 *-- Author :    Peter Richardson
40631 C-----------------------------------------------------------------------
40632       SUBROUTINE HWIMDE
40633 C-----------------------------------------------------------------------
40634 C     Subroutine to merge Higgs WW/ZZ decay modes for four body ME
40635 C-----------------------------------------------------------------------
40636       INCLUDE 'herwig65.inc'
40637       INTEGER IH,I,NMODE,J,K
40638       LOGICAL REMOVE
40639       DOUBLE PRECISION BR
40640       REMOVE = .FALSE.
40641 C--first identify the WW modes
40642       DO IH=203,204
40643         BR = ZERO
40644         NMODE = 0
40645         DO I=NDECSY,NDKYS
40646           IF(IDK(I).EQ.IH.AND.((IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
40647      &      .AND.(IDKPRD(1,I).EQ.198.OR.IDKPRD(1,I).EQ.199).AND.
40648      &          ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
40649      &           (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
40650      &            IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132)))
40651      &          .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
40652      &          (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
40653      &            (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
40654      &             IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
40655      &          .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).NE.0)
40656      &          .AND.
40657      &          (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
40658      &           (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
40659      &            IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
40660      &       .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).NE.0))))) THEN
40661             BR=BR+BRFRAC(I)
40662             NME(I) = -100
40663             NMODE=NMODE+1
40664           ENDIF
40665         ENDDO
40666 C--add the new mode to the event record
40667         IF(NMODE.GT.0) THEN
40668           REMOVE = .TRUE.
40669           NDKYS = NDKYS+1
40670           IDK(NDKYS) = IH
40671           BRFRAC(NDKYS) = BR
40672           NME(I) = 0
40673           IDKPRD(1,NDKYS) = 198
40674           IDKPRD(2,NDKYS) = 199
40675           DO I=3,5
40676             IDKPRD(I,NDKYS) = 0
40677           ENDDO
40678         ENDIF
40679       ENDDO
40680 C--now do the ZZ modes
40681       DO IH=203,204
40682         BR = ZERO
40683         NMODE = 0
40684         DO I=NDECSY,NDKYS
40685           IF(IDK(I).EQ.IH.AND.(IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
40686      &          .AND.IDKPRD(1,I).EQ.200.AND.
40687      &          ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
40688      &           (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
40689      &            IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132))
40690      &          .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
40691      &          (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
40692      &            (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
40693      &             IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
40694      &          .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).EQ.0)
40695      &          .AND.
40696      &          (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
40697      &           (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
40698      &            IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
40699      &     .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).EQ.0))))) THEN
40700             BR=BR+BRFRAC(I)
40701             NME(I) = -100
40702             NMODE=NMODE+1
40703           ENDIF
40704         ENDDO
40705 C--add the new mode to the event record
40706         IF(NMODE.GT.0) THEN
40707           REMOVE = .TRUE.
40708           NDKYS = NDKYS+1
40709           IDK(NDKYS) = IH
40710           BRFRAC(NDKYS) = BR
40711           NME(I) = 0
40712           IDKPRD(1,NDKYS) = 200
40713           IDKPRD(2,NDKYS) = 200
40714           DO I=3,5
40715             IDKPRD(I,NDKYS) = 0
40716           ENDDO
40717         ENDIF
40718       ENDDO
40719       IF(.NOT.REMOVE) RETURN
40720 C--now remove the modes we have marked
40721       I = 0
40722       DO J=NDECSY,NDKYS
40723  10     IF(NME(I+J).EQ.-100) I=I+1
40724         IDK(J) = IDK(J+I)
40725         BRFRAC(J)=BRFRAC(I+J)
40726         NME(J) = NME(I+J)
40727         DO K=1,5
40728           IDKPRD(K,J)=IDKPRD(K,I+J)
40729         ENDDO
40730         IF(NME(J).EQ.-100) GOTO 10
40731       ENDDO
40732 C--reset the number of modes
40733       NDKYS = NDKYS-I
40734       END
40735 CDECK  ID>, HWIPHS.
40736 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
40737 *-- Author :    Peter Richardson
40738 C-----------------------------------------------------------------------
40739       SUBROUTINE HWIPHS(IOPT)
40740 C-----------------------------------------------------------------------
40741 C     Subroutine to initialise the multichannel integration
40742 C     IOPT = 1 sets the weights for the different channels to their
40743 C              default values
40744 C     IOPT = 2 optimises the weights for the process selected
40745 C-----------------------------------------------------------------------
40746       INCLUDE 'herwig65.inc'
40747       INTEGER I,IPRC,ICH,IOPT,ISTP,IWGT,IFER,IANT,IGAU,IQRK
40748       LOGICAL CALLED,TEV,LHC
40749       DOUBLE PRECISION CHNPST(IMAXCH,IMAXOP),D(IMAXOP),CHWGTS(IMAXCH),
40750      &     TOTAL,DEM,DMIN,CV,CA,BR,WA(IMAXCH),WITOT,WI(IMAXCH),
40751      &     TEVGWT(10,5),LHCGWT(10,5),TEVQWT(6,6,2),LHCQWT(6,6,2)
40752       COMMON /HWPSOM/ WI
40753       SAVE CALLED,DEM,TEVGWT,LHCGWT,TEVQWT,LHCQWT
40754       DATA CALLED/.FALSE./
40755       DATA TEVGWT/0.19684D0,0.00403D0,0.63772D0,0.01209D0,0.01321D0,
40756      &            0.00054D0,0.12984D0,0.00257D0,0.00296D0,0.00019D0,
40757      &            0.24146D0,0.00944D0,0.33949D0,0.01430D0,0.01918D0,
40758      &            0.00169D0,0.33919D0,0.01433D0,0.01931D0,0.00161D0,
40759      &            0.22270D0,0.00004D0,0.38873D0,0.00007D0,0.00009D0,
40760      &            0.00000D0,0.38820D0,0.00007D0,0.00009D0,0.00000D0,
40761      &            0.03228D0,0.00629D0,0.43227D0,0.01147D0,0.00010D0,
40762      &            0.03685D0,0.43270D0,0.01193D0,0.00010D0,0.03602D0,
40763      &            0.05828D0,0.00018D0,0.46870D0,0.00033D0,0.00047D0,
40764      &            0.00092D0,0.46940D0,0.00033D0,0.00047D0,0.00094D0/
40765       DATA LHCGWT/0.10679D0,0.00075D0,0.50915D0,0.00105D0,0.00126D0,
40766      &            0.00039D0,0.37853D0,0.00080D0,0.00092D0,0.00037D0,
40767      &            0.18163D0,0.00456D0,0.38555D0,0.00906D0,0.01160D0,
40768      &            0.00095D0,0.38498D0,0.00920D0,0.01163D0,0.00084D0,
40769      &            0.16647D0,0.00003D0,0.41691D0,0.00007D0,0.00009D0,
40770      &            0.00000D0,0.41627D0,0.00007D0,0.00009D0,0.00000D0,
40771      &            0.01957D0,0.00578D0,0.42971D0,0.01087D0,0.00015D0,
40772      &            0.02305D0,0.47944D0,0.00750D0,0.00016D0,0.02377D0,
40773      &            0.03659D0,0.00027D0,0.45268D0,0.00041D0,0.00063D0,
40774      &            0.00062D0,0.50700D0,0.00045D0,0.00069D0,0.00066D0/
40775       DATA TEVQWT/0.37855D0,0.15212D0,0.38016D0,0.00048D0,0.00047D0,
40776      &            0.08822D0,0.37292D0,0.19051D0,0.36770D0,0.00178D0,
40777      &            0.00180D0,0.06529D0,0.37724D0,0.12202D0,0.37579D0,
40778      &            0.00013D0,0.00013D0,0.12470D0,0.36728D0,0.12100D0,
40779      &            0.36521D0,0.00014D0,0.00014D0,0.14622D0,0.37548D0,
40780      &            0.12144D0,0.37410D0,0.00013D0,0.00013D0,0.12873D0,
40781      &            0.08694D0,0.32633D0,0.07192D0,0.00000D0,0.00000D0,
40782      &            0.51481D0,0.37831D0,0.15131D0,0.38081D0,0.00079D0,
40783      &            0.00077D0,0.08801D0,0.37494D0,0.19012D0,0.36496D0,
40784      &            0.00243D0,0.00246D0,0.06509D0,0.37726D0,0.12071D0,
40785      &            0.37641D0,0.00031D0,0.00032D0,0.12499D0,0.36248D0,
40786      &            0.12007D0,0.36203D0,0.00242D0,0.00243D0,0.15057D0,
40787      &            0.31054D0,0.13065D0,0.30760D0,0.04158D0,0.04178D0,
40788      &            0.16785D0,0.04116D0,0.00125D0,0.04116D0,0.32149D0,
40789      &            0.32030D0,0.27465D0/
40790       DATA LHCQWT/0.45556D0,0.06337D0,0.45712D0,0.00022D0,0.00022D0,
40791      &            0.02351D0,0.43712D0,0.07332D0,0.45023D0,0.00021D0,
40792      &            0.00021D0,0.03890D0,0.44611D0,0.08021D0,0.44572D0,
40793      &            0.00176D0,0.00170D0,0.02450D0,0.47268D0,0.03728D0,
40794      &            0.46843D0,0.00004D0,0.00004D0,0.02152D0,0.45662D0,
40795      &            0.06644D0,0.45586D0,0.00065D0,0.00063D0,0.01980D0,
40796      &            0.18486D0,0.27252D0,0.19067D0,0.00000D0,0.00000D0,
40797      &            0.35195D0,0.45530D0,0.06307D0,0.45770D0,0.00037D0,
40798      &            0.00038D0,0.02318D0,0.43653D0,0.07295D0,0.45173D0,
40799      &            0.00036D0,0.00036D0,0.03807D0,0.47312D0,0.04168D0,
40800      &            0.46993D0,0.00010D0,0.00010D0,0.01506D0,0.47047D0,
40801      &            0.03721D0,0.46860D0,0.00101D0,0.00100D0,0.02172D0,
40802      &            0.44379D0,0.05231D0,0.45440D0,0.01608D0,0.01624D0,
40803      &            0.01717D0,0.25443D0,0.04115D0,0.25503D0,0.18346D0,
40804      &            0.18255D0,0.08337D0/
40805       IF(IERROR.NE.0) RETURN
40806 C--initialize for tevatron or LHC based on energy
40807       TEV = NINT(PBEAM1/1000.0D0).EQ.1
40808       LHC = NINT(PBEAM1/1000.0D0).EQ.7
40809 C--first the initalisation
40810       IF(IOPT.EQ.1) THEN
40811         IPRO = MOD(IPROC/100,100)
40812         IPRC=MOD(IPROC,100)
40813         DO I=1,20
40814           CHNPRB(I) = ZERO
40815           CHON(I) = .FALSE.
40816         ENDDO
40817 C--gauge boson pair production
40818         IF(IPRO.EQ.28.AND.IPRC.LT.50) THEN
40819           IF(MOD(IPRC,5).NE.0.OR.IPRC.EQ.5.OR.IPRC.GT.25)
40820      &          CALL HWWARN('HWIPHS',500)
40821           DO I=1,10
40822              CHON(I) = .TRUE.
40823           ENDDO
40824 C--select the process
40825           IGAU = INT(IPRC/5)
40826           IF(IGAU.EQ.0) IGAU = IGAU+1
40827           IF(TEV) THEN
40828             DO I=1,10
40829               CHNPRB(I) = TEVGWT(I,IGAU)
40830             ENDDO
40831           ELSEIF(LHC) THEN
40832             DO I=1,10
40833               CHNPRB(I) = LHCGWT(I,IGAU)
40834             ENDDO
40835           ELSE
40836             DO I=1,10
40837               CHNPRB(I) = 0.1D0
40838             ENDDO
40839           ENDIF
40840           CALLED=.TRUE.
40841           DEM = ONE/DBLE(IOPSH)
40842 C--Drell Yan + 2 jet production
40843         ELSEIF(IPRO.EQ.29) THEN
40844           DO I=1,6
40845             CHON(I) = .TRUE.
40846           ENDDO
40847           IF(IPRC.LE.6) THEN
40848             IGAU = 1
40849           ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
40850             IGAU = 2
40851           ELSE
40852             CALL HWWARN('HWIPHS',502)
40853           ENDIF
40854           IQRK = MOD(IPRC,10)
40855           IF(IQRK.EQ.0.OR.IQRK.GT.6) CALL HWWARN('HWIPHS',503)
40856           IF(TEV) THEN
40857             DO I=1,6
40858               CHNPRB(I) = TEVQWT(I,IQRK,IGAU)
40859             ENDDO
40860           ELSEIF(LHC) THEN
40861             DO I=1,6
40862               CHNPRB(I) = LHCQWT(I,IQRK,IGAU)
40863             ENDDO
40864           ELSE
40865             DO I=1,6
40866               CHNPRB(I) = 1.0D0/6.0D0
40867             ENDDO
40868           ENDIF
40869           CALLED=.TRUE.
40870           DEM = ONE/DBLE(IOPSH)
40871         ELSE
40872           CALLED=.FALSE.
40873           RETURN
40874         ENDIF
40875       ELSE
40876         IF(.NOT.CALLED) RETURN
40877         TOTAL = ZERO
40878         DO I=1,IMAXCH
40879           IF(CHON(I)) TOTAL = TOTAL+CHNPRB(I)
40880         ENDDO
40881         IF(TOTAL.EQ.ZERO) CALL HWWARN('HWIPHS',501)
40882         IF(TOTAL.NE.ONE) THEN
40883           DO I=1,IMAXCH
40884             IF(CHON(I)) CHNPRB(I) = CHNPRB(I)/TOTAL
40885           ENDDO
40886         ENDIF
40887         IF(.NOT.OPTM) RETURN
40888         WRITE(*,50)
40889 C--optimise the weights
40890         FSTWGT=.TRUE.
40891 C---SET UP INITIAL STATE
40892         NHEP=1
40893         ISTHEP(NHEP)=101
40894         PHEP(1,NHEP)=0.
40895         PHEP(2,NHEP)=0.
40896         PHEP(3,NHEP)=PBEAM1
40897         PHEP(4,NHEP)=EBEAM1
40898         PHEP(5,NHEP)=RMASS(IPART1)
40899         JMOHEP(1,NHEP)=0
40900         JMOHEP(2,NHEP)=0
40901         JDAHEP(1,NHEP)=0
40902         JDAHEP(2,NHEP)=0
40903         IDHW(NHEP)=IPART1
40904         IDHEP(NHEP)=IDPDG(IPART1)
40905         NHEP=NHEP+1
40906         ISTHEP(NHEP)=102
40907         PHEP(1,NHEP)=0.
40908         PHEP(2,NHEP)=0.
40909         PHEP(3,NHEP)=-PBEAM2
40910         PHEP(4,NHEP)=EBEAM2
40911         PHEP(5,NHEP)=RMASS(IPART2)
40912         JMOHEP(1,NHEP)=0
40913         JMOHEP(2,NHEP)=0
40914         JDAHEP(1,NHEP)=0
40915         JDAHEP(2,NHEP)=0
40916         IDHW(NHEP)=IPART2
40917         IDHEP(NHEP)=IDPDG(IPART2)
40918 C---NEXT ENTRY IS OVERALL CM FRAME
40919         NHEP=NHEP+1
40920         IDHW(NHEP)=14
40921         IDHEP(NHEP)=0
40922         ISTHEP(NHEP)=103
40923         JMOHEP(1,NHEP)=NHEP-2
40924         JMOHEP(2,NHEP)=NHEP-1
40925         JDAHEP(1,NHEP)=0
40926         JDAHEP(2,NHEP)=0
40927         CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
40928         CALL HWUMAS(PHEP(1,NHEP))
40929         DO ISTP=1,IOPSTP
40930           WRITE(*,100) ISTP
40931           DO ICH=1,IMAXCH
40932             CHWGTS(ICH)  = ZERO
40933             CHNPST(ICH,ISTP) = CHNPRB(ICH)
40934             IF(CHON(ICH)) WRITE(*,200) ICH,CHNPRB(ICH)
40935           ENDDO
40936 C--compute the weights for the various channels
40937           DO I=1,IOPSH
40938              IF(IPRO.EQ.28) THEN
40939                CALL HWHGBP
40940                FSTWGT=.FALSE.
40941                CALL HWDBZ2(200,IFER,IANT,CV,CA,BR,2,ZERO)
40942              ELSEIF(IPRO.EQ.29) THEN
40943                CALL HWHV2J
40944                FSTWGT=.FALSE.
40945                CALL HWDBOZ(200,IFER,IANT,CV,CA,BR,2)
40946              ENDIF
40947              DO ICH=1,IMAXCH
40948              IF(CHON(ICH)) CHWGTS(ICH) = CHWGTS(ICH)+WI(ICH)
40949              ENDDO
40950           ENDDO
40951           WITOT = ZERO
40952           DO ICH=1,IMAXCH
40953             IF(CHON(ICH)) THEN
40954               WA(ICH)  = CHWGTS(ICH)*DEM
40955               WITOT = WITOT+WA(ICH)*CHNPRB(ICH)
40956             ENDIF
40957           ENDDO
40958 C--now pick the next set of probablities for the different channels
40959           TOTAL = ZERO
40960           DO ICH=1,IMAXCH
40961             IF(CHON(ICH)) THEN
40962               CHNPRB(ICH) = CHNPRB(ICH)*SQRT(WA(ICH))
40963               TOTAL = TOTAL+CHNPRB(ICH)
40964             ENDIF
40965           ENDDO
40966           DO ICH=1,IMAXCH
40967             CHNPRB(ICH)=CHNPRB(ICH)/TOTAL
40968           ENDDO
40969           D(ISTP) = ZERO
40970           DO ICH=1,IMAXCH
40971             IF(CHON(ICH)) THEN
40972               IF(D(ISTP).EQ.ZERO) THEN
40973                  D(ISTP) = ABS(WITOT-WA(ICH))
40974               ELSE
40975                  D(ISTP) = MAX(D(ISTP),ABS(WITOT-WA(ICH)))
40976               ENDIF
40977             ENDIF
40978           ENDDO
40979           WRITE(*,300) D(ISTP)
40980         ENDDO
40981 C--pick the best set of weights
40982         IWGT = 1
40983         DMIN = D(1)
40984         DO I=2,IOPSTP
40985           IF(D(I).LT.DMIN) THEN
40986             IWGT = I
40987             DMIN = D(I)
40988           ENDIF
40989         ENDDO
40990         WRITE(*,500) IWGT
40991         DO I=1,IMAXCH
40992           IF(CHON(I)) THEN
40993             CHNPRB(I)=CHNPST(I,IWGT)
40994             WRITE(*,200) I,CHNPRB(I)
40995           ENDIF
40996         ENDDO
40997         OPTM = .FALSE.
40998       ENDIF
40999       RETURN
41000  50   FORMAT(/10X,'OPTIMIZING THE WEIGHTS FOR MULTICHANNEL INTEGRATION')
41001  100  FORMAT(/10X,'PERFORMING ITERATION',I2,/10X)
41002  200  FORMAT( 12X,'CHNPRB(',I2,') = ',F7.5)
41003  300  FORMAT(/10X,'DIFFERENCE IN W BETWEEN CHANNELS',E15.5)
41004  500  FORMAT(/10X,'SELECTED ITERATION',I2)
41005       END
41006 CDECK  ID>, HWISPC.
41007 *CMZ :-        -27/07/99  16.38.25  by  Peter Richardson
41008 *-- Author :    Peter Richardson
41009 C-----------------------------------------------------------------------
41010       SUBROUTINE HWISPC
41011 C-----------------------------------------------------------------------
41012 C     Calculates the couplings for the SUSY decays for spin correlations
41013 C     and 3/4 body matrix elements
41014 C-----------------------------------------------------------------------
41015       INCLUDE 'herwig65.inc'
41016       DOUBLE PRECISION HWUALF,PRE,MCHAR(2),QIJPP(4,4),SIJPP(4,4),
41017      &     DIJ(2,2),QIJ(2,2),R(4,2),SIJ(2,2)
41018       INTEGER I,J,K,L,IH,IK,IL,IQ
41019       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
41020      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
41021       DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
41022      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
41023      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
41024      &     HZZ(2),ZAB(12,2,2),HHB(2,3)
41025       EXTERNAL HWUALF
41026       SAVE DIJ
41027       DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
41028       IF(IERROR.NE.0) RETURN
41029 C--coupling constants
41030       SW  = SQRT(SWEIN)
41031       CW  = SQRT(ONE-SWEIN)
41032       TW  = SW/CW
41033       E   = SQRT(FOUR*PIFAC/128.0D0)
41034       G   = E/SW
41035       RT  = SQRT(TWO)
41036       ORT = ONE/RT
41037       MW  = RMASS(198)
41038       MZ  = RMASS(200)
41039       IF(.NOT.SUSYIN) RETURN
41040       GS  = SQRT(HWUALF(3,RMASS(449))*FOUR*PIFAC)
41041 C--couplings of the neutralinos to the squarks
41042       DO 1 L=1,4
41043       MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
41044       MCHAR(2) = ORT*G*ZMIXSS(L,4)/MW/SINB
41045       DO 1 I=1,3
41046       J = 2*I-1
41047       DO 2 K=1,2
41048       AFN(1,J,K,L) =-MCHAR(1)*RMASS(J)*QMIXSS(J,2,K)
41049      &                    -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
41050  2    AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(J)*QMIXSS(J,1,K)
41051      &                          +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
41052       J = 2*I
41053       DO 1 K=1,2
41054       AFN(1,J,K,L) =-MCHAR(2)*RMASS(J)*QMIXSS(J,2,K)
41055      &                       -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
41056  1    AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(2)*RMASS(J)*QMIXSS(J,1,K)
41057      &                        +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
41058 C--couplings of the neutralinos to the sleptons
41059       DO 3 L=1,4
41060       MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
41061       DO 3 I=1,3
41062       J = 2*I-1
41063       IL = J+10
41064       IK = J+6
41065       DO 4 K=1,2
41066       AFN(1,IK,K,L) =-(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,2,K)
41067      &                        +RT*E*LMIXSS(J,1,K)*SLFCH(IL,L))
41068  4    AFN(2,IK,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,1,K)
41069      &                            +RT*E*LMIXSS(J,2,K)*SRFCH(IL,L))
41070       J = J+1
41071       IL = IL+1
41072       IK = IK+1
41073       DO 3 K=1,2
41074       AFN(1,IK,K,L) =-RT*E*LMIXSS(J,1,K)*SLFCH(IL,L)
41075  3    AFN(2,IK,K,L) = ZERO
41076 C--couplings of the gluinos to the squarks
41077       DO 5 I=1,6
41078       DO 5 K=1,2
41079       AFG(1,I,K) = -GS*RT*QMIXSS(I,1,K)
41080  5    AFG(2,I,K) = +GS*RT*QMIXSS(I,2,K)
41081 C--couplings of the charginos to the squarks
41082       DO 6 L=1,2
41083       MCHAR(1) =-WMXVSS(L,2)*ORT/MW/SINB
41084       MCHAR(2) =-WMXUSS(L,2)*ORT/MW/COSB
41085       DO 6 I=1,3
41086       J = 2*I-1
41087       DO 7 K=1,2
41088       AFC(1,J,K,L) = -G*( WMXUSS(L,1)*QMIXSS(J,1,K)
41089      &                   +MCHAR(2)*RMASS(J)*QMIXSS(J,2,K))
41090  7    AFC(2,J,K,L) = -G*WSGNSS(L)*MCHAR(1)*
41091      &              RMASS(J+1)*QMIXSS(J,1,K)
41092       J = 2*I
41093       DO 6 K=1,2
41094       AFC(1,J,K,L) = -G*WSGNSS(L)*( WMXVSS(L,1)*QMIXSS(J,1,K)
41095      &                           +MCHAR(1)*RMASS(J)*QMIXSS(J,2,K))
41096  6    AFC(2,J,K,L) = -G*MCHAR(2)*RMASS(J-1)*QMIXSS(J,1,K)
41097 C--couplings of the charginos to the sleptons
41098       DO 8 L=1,2
41099       MCHAR(1) = -WMXUSS(L,2)*ORT/MW/COSB
41100       DO 8 I=1,3
41101       J = 2*I-1
41102       IL = J+6
41103       DO 9 K=1,2
41104       AFC(1,IL,K,L) = -G*(WMXUSS(L,1)*LMIXSS(J,1,K)
41105      &                +RMASS(120+J)*MCHAR(1)*LMIXSS(J,2,K))
41106  9    AFC(2,IL,K,L) = ZERO
41107       J = J+1
41108       IL = IL+1
41109       DO 8 K=1,2
41110       AFC(1,IL,K,L) =-WSGNSS(L)*G*WMXVSS(L,1)
41111  8    AFC(2,IL,K,L) =-MCHAR(1)*G*RMASS(119+J)
41112 C--couplings of chargino-neutralino to the W
41113       DO 10 I=1,4
41114       DO 10 J=1,2
41115       OIJ(1,I,J) = G*( ORT*ZMXNSS(I,3)*WMXUSS(J,2)
41116      &                    +ZMXNSS(I,2)*WMXUSS(J,1))
41117  10   OIJ(2,I,J) = ZSGNSS(I)*WSGNSS(J)*G*(-ORT*ZMXNSS(I,4)*WMXVSS(J,2)
41118      &                                        +ZMXNSS(I,2)*WMXVSS(J,1))
41119 C--couplings of chargino-chargino to the Z
41120       PRE = G/CW
41121       DO 11 I=1,2
41122       DO 11 J=1,2
41123       OIJP(1,I,J) = PRE*(-WMXUSS(I,1)*WMXUSS(J,1)
41124      &             -HALF*WMXUSS(I,2)*WMXUSS(J,2)+DIJ(I,J)*SWEIN)
41125  11   OIJP(2,I,J) = WSGNSS(I)*WSGNSS(J)*PRE*(-WMXVSS(I,1)*WMXVSS(J,1)
41126      &             -HALF*WMXVSS(I,2)*WMXVSS(J,2)+DIJ(I,J)*SWEIN)
41127 C--couplings of neutralino-neutralino to the Z
41128       PRE = HALF*G/CW
41129       DO 12 I=1,4
41130       DO 12 J=1,4
41131       OIJPP(1,I,J) = PRE*(ZMIXSS(I,3)*ZMIXSS(J,3)
41132      &                           -ZMIXSS(I,4)*ZMIXSS(J,4))
41133  12   OIJPP(2,I,J) = -ZSGNSS(I)*ZSGNSS(J)*OIJPP(1,I,J)
41134 C--couplings of the neutralino-neutralino to the Higgs
41135       DO 13 I=1,4
41136       DO 13 J=1,4
41137       QIJPP(I,J) = HALF*ZSGNSS(I)*
41138      &                      (ZMXNSS(I,3)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
41139      &                      +ZMXNSS(J,3)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
41140  13   SIJPP(I,J) = HALF*ZSGNSS(I)*
41141      &                      (ZMXNSS(I,4)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
41142      &                      +ZMXNSS(J,4)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
41143       DO 14 I=1,4
41144       DO 14 J=1,4
41145       HNN(1,1,I,J) = G*(QIJPP(I,J)*SINA+SIJPP(I,J)*COSA)
41146       HNN(2,1,I,J) = G*(QIJPP(J,I)*SINA+SIJPP(J,I)*COSA)
41147       HNN(1,2,I,J) = G*(SIJPP(I,J)*SINA-QIJPP(I,J)*COSA)
41148       HNN(2,2,I,J) = G*(SIJPP(J,I)*SINA-QIJPP(J,I)*COSA)
41149       HNN(1,3,I,J) = G*(QIJPP(I,J)*SINB-SIJPP(I,J)*COSB)
41150  14   HNN(2,3,I,J) =-G*(QIJPP(J,I)*SINB-SIJPP(J,I)*COSB)
41151 C--couplings of chargino-chargino to the Higgs
41152       DO 15 I=1,2
41153       DO 15 J=1,2
41154       QIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,1)*WMXUSS(J,2)
41155  15   SIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,2)*WMXUSS(J,1)
41156       DO 16 I=1,2
41157       DO 16 J=1,2
41158       HCC(1,1,I,J) = G*(QIJ(I,J)*SINA-SIJ(I,J)*COSA)
41159       HCC(2,1,I,J) = G*(QIJ(J,I)*SINA-SIJ(J,I)*COSA)
41160       HCC(1,2,I,J) =-G*(QIJ(I,J)*COSA+SIJ(I,J)*SINA)
41161       HCC(2,2,I,J) =-G*(QIJ(J,I)*COSA+SIJ(J,I)*SINA)
41162       HCC(1,3,I,J) = G*(QIJ(I,J)*SINB+SIJ(I,J)*COSB)
41163  16   HCC(2,3,I,J) =-G*(QIJ(J,I)*SINB+SIJ(J,I)*COSB)
41164 C--couplings of chargino-neutralino to the Higgs
41165       DO 17 I=1,4
41166       DO 17 J=1,2
41167       HNC(1,I,J) =-G*ZSGNSS(I)*SINB*(ZMXNSS(I,3)*WMXUSS(J,1)
41168      &            -ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXUSS(J,2))
41169  17   HNC(2,I,J) =-G*WSGNSS(J)*COSB*(ZMXNSS(I,4)*WMXVSS(J,1)
41170      &            +ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXVSS(J,2))
41171 C--fermion couplings to the Higgs
41172       R(1,1) = HALF*G*SINA/MW/COSB
41173       R(1,2) =-HALF*G*COSA/MW/SINB
41174       R(2,1) =-HALF*G*COSA/MW/COSB
41175       R(2,2) =-HALF*G*SINA/MW/SINB
41176       R(3,1) = HALF*G*TANB/MW
41177       R(3,2) = HALF*G*COTB/MW
41178       R(4,1) = G*ORT*TANB/MW
41179       R(4,2) = G*ORT*COTB/MW
41180       DO 18 I=1,3
41181       J = 2*I-1
41182       K = 2*I
41183       IL = J+6
41184       IQ = K+6
41185       DO 19 IK=1,3
41186       DO 19 L=1,2
41187       HFF(L,IK,J ) = R(IK,1)*RMASS(J)
41188       HFF(L,IK,K ) = R(IK,2)*RMASS(K)
41189       HFF(L,IK,IL) = R(IK,1)*RMASS(114+IL)
41190  19   HFF(L,IK,IQ) = ZERO
41191       HFF(2,3,J )  = -HFF(2,3, J)
41192       HFF(2,3,K )  = -HFF(2,3, K)
41193       HFF(2,3,IL)  = -HFF(2,3,IL)
41194       HFF(1,4,I)   = RMASS(J)*R(4,1)
41195       HFF(2,4,I)   = RMASS(K)*R(4,2)
41196       HFF(1,4,I+3) = RMASS(114+IL)*R(4,1)
41197  18   HFF(2,4,I+3) = ZERO
41198 C--couplings of the Higgs to gauge boson pairs
41199       HWW(1) = G*MW*SINBMA
41200       HWW(2) = G*MW*COSBMA
41201       HZZ(1) = G*MZ*SINBMA/CW
41202       HZZ(2) = G*MZ*COSBMA/CW
41203 C--couplings of the Z to the sfermions
41204       DO 20 I=1,3
41205       IQ = 2*I-1
41206       IL = 2*I
41207       IK = 2*I+5
41208       IH = 2*I+6
41209       DO 20 J=1,2
41210       DO 20 K=1,2
41211       ZAB(IQ,J,K) = G/CW*HALF*( QMIXSS(IQ,1,J)*QMIXSS(IQ,1,K)
41212      &                         -TWO*DIJ(J,K) *SWEIN/THREE)
41213       ZAB(IL,J,K) = G/CW*HALF*(-QMIXSS(IL,1,J)*QMIXSS(IL,1,K)
41214      &                         -FOUR*DIJ(J,K)*SWEIN/THREE)
41215       ZAB(IK,J,K) = G/CW*HALF*( LMIXSS(IQ,1,J)*LMIXSS(IQ,1,K)
41216      &                         -TWO*DIJ(J,K)*SWEIN)
41217  20   ZAB(IH,J,K) =-G/CW*HALF*DIJ(J,1)*DIJ(K,1)
41218 C--couplings of the Higgs Higgs to the gauge bosons
41219       HHB(1,1) = HALF*G*COSBMA
41220       HHB(1,2) = HALF*G*SINBMA
41221       HHB(1,3) = HALF*G
41222       HHB(2,1) =-HALF*G*COSBMA/CW
41223       HHB(2,2) = HALF*G*SINBMA/CW
41224       HHB(2,3) = ZERO
41225       END
41226 CDECK  ID>, HWISPN.
41227 *CMZ :-        -12/10/01  17.22.48  by  Peter Richardson
41228 *-- Author :    Peter Richardson
41229 C-----------------------------------------------------------------------
41230       SUBROUTINE HWISPN
41231 C-----------------------------------------------------------------------
41232 C     Initialise all the decay modes for three/four body MEs and spin
41233 C     correlations
41234 C-----------------------------------------------------------------------
41235       INCLUDE 'herwig65.inc'
41236       INTEGER I,J,K,NDKYST
41237 C--set the number of two and three body modes to zero
41238       N2MODE = 0
41239       N3MODE = 0
41240       NBMODE = 0
41241       N4MODE = 0
41242 C--if not reading in decay info calculate it
41243       IF(LRDEC.EQ.0) THEN
41244 C--initialise the couplings for the various decay modes
41245         CALL HWISPC
41246 C--Top decays and SUSY three body decays (including SUSY gauge
41247 C--boson 2 body modes which are treated as three body)
41248         IF(THREEB) CALL HWISP3
41249         IF(IERROR.NE.0) RETURN
41250 C--then four body modes if needed
41251         IF(FOURB)  CALL HWISP4
41252         IF(IERROR.NE.0) RETURN
41253 C--Two body modes if needed for spin correlations
41254         IF(SYSPIN) CALL HWISP2
41255         IF(IERROR.NE.0) RETURN
41256 C--otherwise read it in
41257       ELSEIF(LRDEC.GT.0) THEN
41258 C--open the unit
41259         IF (IPRINT.NE.0) WRITE (6,1) LRDEC
41260    1    FORMAT(/10X,'READING MATRIX ELEMENT TABLE ON UNIT',I4)
41261         OPEN(UNIT=LRDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
41262 C--read  options
41263         READ(UNIT=LRDEC) NDKYST
41264         IF(NDKYS.NE.NDKYST) CALL HWWARN('HWISPN',501)
41265         READ(UNIT=LRDEC) SYSPIN,THREEB,FOURB
41266 C--read two body decays
41267         IF(SYSPIN) THEN
41268           READ(UNIT=LRDEC) N2MODE
41269           DO 2 I=1,N2MODE
41270  2        READ(UNIT=LRDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
41271      &                     ID2PRT(I),I2DRTP(I)
41272         ENDIF
41273 C--read three body decays
41274         IF(SYSPIN.OR.THREEB) THEN
41275           READ(UNIT=LRDEC) N3MODE
41276           DO 3 I=1,N3MODE
41277           READ(UNIT=LRDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
41278      &            ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
41279           DO 3 J=1,NDI3BY(I)
41280  3        READ(UNIT=LRDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
41281      &                      I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
41282 C--read two body gauge boson modes
41283           READ(UNIT=LRDEC) NBMODE
41284           DO 4 I=1,NBMODE
41285  4        READ(UNIT=LRDEC) (ABMODE(J,I),J=1,2),
41286      &            ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
41287      &            (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
41288         ENDIF
41289 C--read four body decays
41290         IF(FOURB) THEN
41291           READ(UNIT=LRDEC) N4MODE
41292           DO 5 I=1,N4MODE
41293  5        READ(UNIT=LRDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
41294      &            ((B4MODE(J,K,I),J=1,2),K=1,12),
41295      &            ((P4MODE(J,K,I),J=1,12),K=1,12),
41296      &            ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
41297      &            (I4MODE(J,I),J=1,2)
41298         ENDIF
41299 C--finally read in the matrix element codes
41300         READ(UNIT=LRDEC) NME
41301       ELSE
41302         CALL HWWARN('HWISPN',500)
41303       ENDIF
41304 C--write the decay information if needed
41305       IF(LWDEC.GT.0) THEN
41306 C--open the file
41307         IF (IPRINT.NE.0) WRITE (6,6) LWDEC
41308  6      FORMAT(/10X,'WRITING MATRIX ELEMENT TABLE ON UNIT',I4)
41309         OPEN(UNIT=LWDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
41310 C--write  options
41311         WRITE(UNIT=LWDEC) NDKYS
41312         WRITE(UNIT=LWDEC) SYSPIN,THREEB,FOURB
41313 C--write two body decays
41314         IF(SYSPIN) THEN
41315           WRITE(UNIT=LWDEC) N2MODE
41316           DO 7 I=1,N2MODE
41317  7        WRITE(UNIT=LWDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
41318      &                     ID2PRT(I),I2DRTP(I)
41319         ENDIF
41320 C--write three body decays
41321         IF(SYSPIN.OR.THREEB) THEN
41322           WRITE(UNIT=LWDEC) N3MODE
41323           DO 8 I=1,N3MODE
41324           WRITE(UNIT=LWDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
41325      &            ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
41326           DO 8 J=1,NDI3BY(I)
41327  8        WRITE(UNIT=LWDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
41328      &                      I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
41329 C--write two body gauge boson modes
41330           WRITE(UNIT=LWDEC) NBMODE
41331           DO 9 I=1,NBMODE
41332  9        WRITE(UNIT=LWDEC) (ABMODE(J,I),J=1,2),
41333      &            ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
41334      &            (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
41335         ENDIF
41336 C--write four body decays
41337         IF(FOURB) THEN
41338           WRITE(UNIT=LWDEC) N4MODE
41339           DO 10 I=1,N4MODE
41340  10       WRITE(UNIT=LWDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
41341      &            ((B4MODE(J,K,I),J=1,2),K=1,12),
41342      &            ((P4MODE(J,K,I),J=1,12),K=1,12),
41343      &            ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
41344      &            (I4MODE(J,I),J=1,2)
41345         ENDIF
41346 C--finally write the matrix element codes
41347         WRITE(UNIT=LWDEC) NME
41348       ENDIF
41349       END
41350 CDECK  ID>, HWISP2.
41351 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
41352 *-- Author :    Peter Richardson
41353 C-----------------------------------------------------------------------
41354       SUBROUTINE HWISP2
41355 C-----------------------------------------------------------------------
41356 C     Initialise the SUSY two body modes for spin correlations
41357 C-----------------------------------------------------------------------
41358       INCLUDE 'herwig65.inc'
41359       INTEGER I,J,IL,IH,L,L1,IM,O(2),II,JJ,III,JJJ,KKK
41360       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
41361      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
41362       DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
41363      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
41364      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
41365      &     HZZ(2),ZAB(12,2,2),HHB(2,3),FPI
41366       SAVE O,FPI
41367       DATA O/2,1/
41368       DATA FPI/0.09298D0/
41369       IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
41370 C--now the two body modes for spin corrections
41371       DO 1000 JJ=1,NRES
41372       DO 1000 II=1,NMODES(JJ)
41373         IF(II.EQ.1) THEN
41374           I = LSTRT(JJ)
41375         ELSE
41376           I = LNEXT(I)
41377         ENDIF
41378         IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0.OR.
41379      &        (NME(I).GT.10000.AND.NME(I).LT.50000)) GOTO 1000
41380         L1 = IDK(I)-449
41381 C--two body top to charged higgs decay
41382         IF(IDK(I).EQ.6.AND.IDKPRD(1,I).EQ.206.AND.
41383      &                     IDKPRD(2,I).EQ.5) THEN
41384             N2MODE = N2MODE+1
41385             IF(N2MODE.GT.NMODE2) THEN
41386               CALL HWWARN('HWISP2',100)
41387               GOTO 999
41388             ENDIF
41389             NME(I) = 30000+N2MODE
41390             ID2PRT(N2MODE) = I
41391             I2DRTP(N2MODE) = 2
41392             P2MODE(N2MODE) = ONE
41393             DO 201 J=1,2
41394  201        A2MODE(J,N2MODE) = HFF(O(J),4,3)
41395 C--two body antitop to charged higgs
41396         ELSEIF(IDK(I).EQ.12.AND.IDKPRD(1,I).EQ.207.AND.
41397      &                          IDKPRD(2,I).EQ.11) THEN
41398             N2MODE = N2MODE+1
41399             IF(N2MODE.GT.NMODE2) THEN
41400               CALL HWWARN('HWISP2',101)
41401               GOTO 999
41402             ENDIF
41403             NME(I) = 30000+N2MODE
41404             ID2PRT(N2MODE) = I
41405             I2DRTP(N2MODE) = 14
41406             P2MODE(N2MODE) = ONE
41407             DO 202 J=1,2
41408  202        A2MODE(J,N2MODE) = HFF(  J ,4,3)
41409 C--two body modes of the gluino
41410         ELSEIF(L1.EQ.0) THEN
41411           L = IDKPRD(1,I)-449
41412 C--gluino to antisfermion fermion
41413           IF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41414             N2MODE = N2MODE+1
41415             IF(N2MODE.GT.NMODE2) THEN
41416               CALL HWWARN('HWISP2',102)
41417               GOTO 999
41418             ENDIF
41419             NME(I) = 30000+N2MODE
41420             ID2PRT(N2MODE) = I
41421             I2DRTP(N2MODE) = 2
41422             P2MODE(N2MODE) = HALF
41423             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41424             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41425             DO 1 J=1,2
41426  1          A2MODE(J,N2MODE) = AFG(J,IL,IM)
41427 C--gluino to sfermion antifermion
41428           ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41429             N2MODE = N2MODE+1
41430             IF(N2MODE.GT.NMODE2) THEN
41431               CALL HWWARN('HWISP2',103)
41432               GOTO 999
41433             ENDIF
41434             NME(I) = 30000+N2MODE
41435             ID2PRT(N2MODE) = I
41436             I2DRTP(N2MODE) = 3
41437             P2MODE(N2MODE) = HALF
41438             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41439             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41440             DO 2 J=1,2
41441  2          A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
41442 C--gluino to neutralino gluon
41443           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.13) THEN
41444             N2MODE = N2MODE+1
41445             IF(N2MODE.GT.NMODE2) THEN
41446               CALL HWWARN('HWISP2',104)
41447               GOTO 999
41448             ENDIF
41449             NME(I) = 30000+N2MODE
41450             ID2PRT(N2MODE) = I
41451             I2DRTP(N2MODE) = 4
41452             P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
41453      &           (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
41454      &           HBAR/RLTIM(IDK(I))*BRFRAC(I)
41455             A2MODE(1,N2MODE) = ZSGNSS(L)
41456 C--gluino to gravitino gluon
41457           ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.13) THEN
41458             N2MODE = N2MODE+1
41459             IF(N2MODE.GT.NMODE2) THEN
41460               CALL HWWARN('HWISP2',105)
41461               GOTO 999
41462             ENDIF
41463             NME(I) = 30000+N2MODE
41464             ID2PRT(N2MODE) = I
41465             I2DRTP(N2MODE) = 9
41466             P2MODE(N2MODE) = ONE/24.0D0
41467           ENDIF
41468 C--two body modes of the neutralinos
41469         ELSEIF(L1.GE.1.AND.L1.LE.4) THEN
41470           L  = IDKPRD(1,I)-449
41471           IH = IDKPRD(2,I)-202
41472 C--first the neutralino modes to neutralino Higgs
41473           IF(L.GE.1.AND.L.LE.4.AND.IH.GE.1.AND.IH.LE.3) THEN
41474             N2MODE = N2MODE+1
41475             IF(N2MODE.GE.NMODE2) THEN
41476               CALL HWWARN('HWISP2',106)
41477               GOTO 999
41478             ENDIF
41479             NME(I) = 30000+N2MODE
41480             ID2PRT(N2MODE) = I
41481             I2DRTP(N2MODE) = 1
41482             P2MODE(N2MODE) = ONE
41483             DO 3 J=1,2
41484  3          A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
41485 C--neutralino to positive chargino negative Higgs
41486           ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IH.EQ.5) THEN
41487             L = L-4
41488             N2MODE = N2MODE+1
41489             IF(N2MODE.GE.NMODE2) THEN
41490               CALL HWWARN('HWISP2',107)
41491               GOTO 999
41492             ENDIF
41493             NME(I) = 30000+N2MODE
41494             ID2PRT(N2MODE) = I
41495             I2DRTP(N2MODE) = 1
41496             P2MODE(N2MODE) = ONE
41497             DO 4 J=1,2
41498  4          A2MODE(J,N2MODE) = HNC(O(J),L1,L)
41499 C--neutralino to negative chargino positive Higgs
41500           ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IH.EQ.6) THEN
41501             L = L-6
41502             N2MODE = N2MODE+1
41503             IF(N2MODE.GE.NMODE2) THEN
41504               CALL HWWARN('HWISP2',108)
41505               GOTO 999
41506             ENDIF
41507             NME(I) = 30000+N2MODE
41508             ID2PRT(N2MODE) = I
41509             I2DRTP(N2MODE) = 1
41510             P2MODE(N2MODE) = ONE
41511             DO 5 J=1,2
41512  5          A2MODE(J,N2MODE) = HNC(J,L1,L)
41513 C--neutralino to antisfermion sfermion
41514           ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41515             N2MODE = N2MODE+1
41516             IF(N2MODE.GT.NMODE2) THEN
41517               CALL HWWARN('HWISP2',109)
41518               GOTO 999
41519             ENDIF
41520             NME(I) = 30000+N2MODE
41521             ID2PRT(N2MODE) = I
41522             I2DRTP(N2MODE) = 2
41523             P2MODE(N2MODE) = ONE
41524             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41525             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41526             IF(IL.LE.6) P2MODE(N2MODE) = THREE
41527             DO 6 J=1,2
41528  6          A2MODE(J,N2MODE) = AFN(J,IL,IM,L1)
41529 C--neutralino to sfermion antifermion
41530           ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41531             N2MODE = N2MODE+1
41532             IF(N2MODE.GT.NMODE2) THEN
41533               CALL HWWARN('HWISP2',110)
41534               GOTO 999
41535             ENDIF
41536             NME(I) = 30000+N2MODE
41537             ID2PRT(N2MODE) = I
41538             I2DRTP(N2MODE) = 3
41539             P2MODE(N2MODE) = ONE
41540             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41541             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41542             IF(IL.LE.6) P2MODE(N2MODE) = THREE
41543             DO 7 J=1,2
41544  7          A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L1)
41545 C--neutralino to neutralino photon
41546           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.59) THEN
41547             N2MODE = N2MODE+1
41548             IF(N2MODE.GT.NMODE2) THEN
41549               CALL HWWARN('HWISP2',111)
41550               GOTO 999
41551             ENDIF
41552             NME(I) = 30000+N2MODE
41553             ID2PRT(N2MODE) = I
41554             I2DRTP(N2MODE) = 4
41555             P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
41556      &           (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
41557      &           HBAR/RLTIM(IDK(I))*BRFRAC(I)
41558             A2MODE(1,N2MODE) = ZSGNSS(L)*ZSGNSS(L1)
41559 C--neutralino to gravitino photon for GMSB
41560           ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.59) THEN
41561             N2MODE = N2MODE+1
41562             IF(N2MODE.GT.NMODE2) THEN
41563               CALL HWWARN('HWISP2',112)
41564               GOTO 999
41565             ENDIF
41566             NME(I) = 30000+N2MODE
41567             ID2PRT(N2MODE) = I
41568             I2DRTP(N2MODE) = 9
41569             P2MODE(N2MODE) = ZMIXSS(L1,1)**2/24.0D0
41570 C--neutralino to gravitino Higgs for GMSB
41571           ELSEIF(IDKPRD(1,I).EQ.458.AND.IH.GE.1.AND.IH.LE.3) THEN
41572             N2MODE = N2MODE+1
41573             IF(N2MODE.GT.NMODE2) THEN
41574               CALL HWWARN('HWISP2',113)
41575               GOTO 999
41576             ENDIF
41577             NME(I) = 30000+N2MODE
41578             ID2PRT(N2MODE) = I
41579             I2DRTP(N2MODE) = 10
41580             IF(IH.EQ.1) THEN
41581               P2MODE(N2MODE) = ZMIXSS(L1,3)*SINA-ZMIXSS(L1,4)*COSA
41582             ELSEIF(IH.EQ.2) THEN
41583               P2MODE(N2MODE) = ZMIXSS(L1,3)*COSA+ZMIXSS(L1,4)*SINA
41584             ELSE
41585               P2MODE(N2MODE) = ZMIXSS(L1,3)*SINB+ZMIXSS(L1,4)*COSB
41586             ENDIF
41587             P2MODE(N2MODE) = P2MODE(N2MODE)**2/3.0D0
41588           ELSE
41589             CALL HWWARN('HWISP2',1)
41590           ENDIF
41591 C--two body modes of the positive charginos
41592         ELSEIF(L1.EQ.5.OR.L1.EQ.6) THEN
41593           L1 = L1-4
41594           L  = IDKPRD(1,I)-449
41595           IH = IDKPRD(2,I)-202
41596 C--first the chargino modes to chargino Higgs
41597           IF((L.EQ.5.OR.L.EQ.6).AND.IH.GE.1.AND.IH.LE.3) THEN
41598             L = L-4
41599             N2MODE = N2MODE+1
41600             IF(N2MODE.GT.NMODE2) THEN
41601               CALL HWWARN('HWISP2',114)
41602               GOTO 999
41603             ENDIF
41604             NME(I) = 30000+N2MODE
41605             ID2PRT(N2MODE) = I
41606             I2DRTP(N2MODE) = 1
41607             P2MODE(N2MODE) = ONE
41608             DO 8 J=1,2
41609  8          A2MODE(J,N2MODE) = HCC(J,IH,L,L1)
41610 C--then the chargino modes to neutralino Higgs
41611           ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.4) THEN
41612             N2MODE = N2MODE+1
41613             IF(N2MODE.GT.NMODE2) THEN
41614               CALL HWWARN('HWISP2',115)
41615               GOTO 999
41616             ENDIF
41617             NME(I) = 30000+N2MODE
41618             ID2PRT(N2MODE) = I
41619             I2DRTP(N2MODE) = 1
41620             P2MODE(N2MODE) = ONE
41621             DO 9 J=1,2
41622  9          A2MODE(J,N2MODE) = HNC(J,L,L1)
41623 C--chargino modes to antisfermion fermion
41624           ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41625             N2MODE = N2MODE+1
41626             IF(N2MODE.GT.NMODE2) THEN
41627               CALL HWWARN('HWISP2',116)
41628               GOTO 999
41629             ENDIF
41630             NME(I) = 30000+N2MODE
41631             ID2PRT(N2MODE) = I
41632             I2DRTP(N2MODE) = 2
41633             P2MODE(N2MODE) = ONE
41634             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41635             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41636             IF(IL.LE.6) P2MODE(N2MODE) = THREE
41637             DO 10 J=1,2
41638  10         A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
41639 C--chargino modes to sfermion antifermion
41640           ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41641             N2MODE = N2MODE+1
41642             IF(N2MODE.GT.NMODE2) THEN
41643               CALL HWWARN('HWISP2',117)
41644               GOTO 999
41645             ENDIF
41646             NME(I) = 30000+N2MODE
41647             ID2PRT(N2MODE) = I
41648             I2DRTP(N2MODE) = 3
41649             P2MODE(N2MODE) = ONE
41650             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41651             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41652             IF(IL.LE.6) P2MODE(N2MODE) = THREE
41653             DO 11 J=1,2
41654  11         A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
41655 C--chargino --> neutralino pi+
41656           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.38) THEN
41657             N2MODE = N2MODE+1
41658             IF(N2MODE.GT.NMODE2) THEN
41659               CALL HWWARN('HWISP2',118)
41660               GOTO 999
41661             ENDIF
41662             NME(I) = 30000+N2MODE
41663             ID2PRT(N2MODE) = I
41664             I2DRTP(N2MODE) = 7
41665             P2MODE(N2MODE) = FPI**2*G**2
41666             DO 12 J=1,2
41667  12         A2MODE(J,N2MODE) = OIJ(J,L,L1)
41668           ENDIF
41669 C--two body modes of the negative charginos
41670         ELSEIF(L1.EQ.7.OR.L1.EQ.8) THEN
41671           L1 = L1-6
41672           L  = IDKPRD(1,I)-449
41673           IH = IDKPRD(2,I)-202
41674 C--first the chargino modes to chargino Higgs
41675           IF((L.EQ.7.OR.L.EQ.8).AND.IH.GE.1.AND.IH.LE.3) THEN
41676             L = L-6
41677             N2MODE = N2MODE+1
41678             IF(N2MODE.GT.NMODE2) THEN
41679               CALL HWWARN('HWISP2',119)
41680               GOTO 999
41681             ENDIF
41682             NME(I) = 30000+N2MODE
41683             ID2PRT(N2MODE) = I
41684             I2DRTP(N2MODE) = 1
41685             P2MODE(N2MODE) = ONE
41686             DO 13 J=1,2
41687  13         A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
41688 C--then the chargino modes to neutralino Higgs
41689           ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.5) THEN
41690             N2MODE = N2MODE+1
41691             IF(N2MODE.GT.NMODE2) THEN
41692               CALL HWWARN('HWISP2',120)
41693               GOTO 999
41694             ENDIF
41695             NME(I) = 30000+N2MODE
41696             ID2PRT(N2MODE) = I
41697             I2DRTP(N2MODE) = 1
41698             P2MODE(N2MODE) = ONE
41699             DO 14 J=1,2
41700  14         A2MODE(J,N2MODE) = HNC(O(J),L,L1)
41701 C--chargino to antisfermion fermion
41702           ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41703             N2MODE = N2MODE+1
41704             IF(N2MODE.GT.NMODE2) THEN
41705               CALL HWWARN('HWISP2',121)
41706               GOTO 999
41707             ENDIF
41708             NME(I) = 30000+N2MODE
41709             ID2PRT(N2MODE) = I
41710             I2DRTP(N2MODE) = 2
41711             P2MODE(N2MODE) = ONE
41712             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41713             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41714             IF(IL.LE.6) P2MODE(N2MODE) = THREE
41715             DO 15 J=1,2
41716  15         A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
41717 C--chargino to sfermion antifermion
41718           ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41719             N2MODE = N2MODE+1
41720             IF(N2MODE.GT.NMODE2) THEN
41721               CALL HWWARN('HWISP2',122)
41722               GOTO 999
41723             ENDIF
41724             NME(I) = 30000+N2MODE
41725             ID2PRT(N2MODE) = I
41726             I2DRTP(N2MODE) = 3
41727             P2MODE(N2MODE) = ONE
41728             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41729             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41730             IF(IL.LE.6) P2MODE(N2MODE) = THREE
41731             DO 16 J=1,2
41732  16         A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
41733 C--chargino --> neutralino pi-
41734           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.30) THEN
41735             N2MODE = N2MODE+1
41736             IF(N2MODE.GT.NMODE2) THEN
41737               CALL HWWARN('HWISP2',123)
41738               GOTO 999
41739             ENDIF
41740             NME(I) = 30000+N2MODE
41741             ID2PRT(N2MODE) = I
41742             I2DRTP(N2MODE) = 7
41743             P2MODE(N2MODE) = FPI**2*G**2
41744             DO 17 J=1,2
41745  17         A2MODE(J,N2MODE) =-OIJ(O(J),L,L1)
41746           ENDIF
41747         ELSEIF(L1.GE.-48.AND.L1.LT.0) THEN
41748 C--sfermion decay modes
41749           L = IDKPRD(1,I)-449
41750 C--first sfermion modes to gluinos
41751           IF(L.EQ.0) THEN
41752 C--first sfermion --> fermion gluino
41753             IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
41754               N2MODE = N2MODE+1
41755               IF(N2MODE.GT.NMODE2) THEN
41756                 CALL HWWARN('HWISP2',124)
41757                 GOTO 999
41758               ENDIF
41759               NME(I) = 30000+N2MODE
41760               ID2PRT(N2MODE) = I
41761               I2DRTP(N2MODE) = 6
41762               P2MODE(N2MODE) = FOUR/THREE
41763               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41764               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41765               DO 18 J=1,2
41766  18           A2MODE(J,N2MODE) = AFG(J,IL,IM)
41767 C--then antisfermion --> antifermion gluino
41768             ELSE
41769               N2MODE = N2MODE+1
41770               IF(N2MODE.GT.NMODE2) THEN
41771                 CALL HWWARN('HWISP2',125)
41772                 GOTO 999
41773               ENDIF
41774               NME(I) = 30000+N2MODE
41775               ID2PRT(N2MODE) = I
41776               I2DRTP(N2MODE) = 5
41777               P2MODE(N2MODE) = FOUR/THREE
41778               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41779               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41780               DO 19 J=1,2
41781  19           A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
41782             ENDIF
41783 C--then sfermion modes to neutralinos
41784           ELSEIF(L.GE.1.AND.L.LE.4) THEN
41785 C--first sfermion --> fermion neutralino
41786             IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
41787               N2MODE = N2MODE+1
41788               IF(N2MODE.GT.NMODE2) THEN
41789                 CALL HWWARN('HWISP2',126)
41790                 GOTO 999
41791               ENDIF
41792               NME(I) = 30000+N2MODE
41793               ID2PRT(N2MODE) = I
41794               I2DRTP(N2MODE) = 6
41795               P2MODE(N2MODE) = ONE
41796               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41797               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41798               DO 20 J=1,2
41799  20           A2MODE(J,N2MODE) = AFN(J,IL,IM,L)
41800 C--then antisfermion --> fermion neutralino
41801             ELSE
41802               N2MODE = N2MODE+1
41803               IF(N2MODE.GT.NMODE2) THEN
41804                 CALL HWWARN('HWISP2',127)
41805                 GOTO 999
41806               ENDIF
41807               NME(I) = 30000+N2MODE
41808               ID2PRT(N2MODE) = I
41809               I2DRTP(N2MODE) = 5
41810               P2MODE(N2MODE) = ONE
41811               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41812               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41813               DO 21 J=1,2
41814  21           A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L)
41815             ENDIF
41816 C--sfermion modes to charginos
41817           ELSEIF(L.GE.5.AND.L.LE.8) THEN
41818             L = MOD(L-5,2)+1
41819 C--first sfermion --> fermion chargino
41820             IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
41821               N2MODE = N2MODE+1
41822               IF(N2MODE.GT.NMODE2) THEN
41823                 CALL HWWARN('HWISP2',128)
41824                 GOTO 999
41825               ENDIF
41826               NME(I) = 30000+N2MODE
41827               ID2PRT(N2MODE) = I
41828               I2DRTP(N2MODE) = 6
41829               P2MODE(N2MODE) = ONE
41830               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41831               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41832               DO 22 J=1,2
41833  22           A2MODE(J,N2MODE) = AFC(J,IL,IM,L)
41834 C--then antisfermion --> fermion chargino
41835             ELSE
41836               N2MODE = N2MODE+1
41837               IF(N2MODE.GT.NMODE2) THEN
41838                 CALL HWWARN('HWISP2',129)
41839                 GOTO 999
41840               ENDIF
41841               NME(I) = 30000+N2MODE
41842               ID2PRT(N2MODE) = I
41843               I2DRTP(N2MODE) = 5
41844               P2MODE(N2MODE) = ONE
41845               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41846               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41847               DO 23 J=1,2
41848  23           A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L)
41849             ENDIF
41850 C--sfermion modes to  fermion gravitino
41851           ELSEIF(IDKPRD(2,I).EQ.458) THEN
41852             IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41853               N2MODE = N2MODE+1
41854               IF(N2MODE.GT.NMODE2) THEN
41855                 CALL HWWARN('HWISP2',130)
41856                 GOTO 999
41857               ENDIF
41858               NME(I) = 30000+N2MODE
41859               ID2PRT(N2MODE) = I
41860               I2DRTP(N2MODE) = 11
41861               P2MODE(N2MODE) = ONE/THREE
41862               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41863               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41864               IF(IL.LE.6) THEN
41865                 DO 40 J=1,2
41866  40             A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
41867               ELSE
41868                 DO 41 J=1,2
41869  41             A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
41870               ENDIF
41871             ELSE
41872               N2MODE = N2MODE+1
41873               IF(N2MODE.GT.NMODE2) THEN
41874                 CALL HWWARN('HWISP2',131)
41875                 GOTO 999
41876               ENDIF
41877               NME(I) = 30000+N2MODE
41878               ID2PRT(N2MODE) = I
41879               I2DRTP(N2MODE) = 12
41880               P2MODE(N2MODE) = ONE/THREE
41881               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41882               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41883               IF(IL.LE.6) THEN
41884                 DO 42 J=1,2
41885  42             A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
41886               ELSE
41887                 DO 43 J=1,2
41888  43             A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
41889               ENDIF
41890             ENDIF
41891 C--R-parity violating decay modes
41892 C--LLE modes
41893           ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
41894      &           IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41895      &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132) THEN
41896 C--charged slepton decays
41897             IF(MOD(IDK(I),2).EQ.1) THEN
41898 C--right slepton decay
41899               IF(IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I))).EQ.
41900      &           IDPDG(IDKPRD(2,I))/ABS(IDPDG(IDKPRD(2,I)))) THEN
41901 C--particle decay
41902                 N2MODE = N2MODE+1
41903                 IF(N2MODE.GT.NMODE2) THEN
41904                   CALL HWWARN('HWISP2',132)
41905                   GOTO 999
41906                 ENDIF
41907                 NME(I) = 30000+N2MODE
41908                 ID2PRT(N2MODE) = I
41909                 P2MODE(N2MODE) = ONE
41910                 IF(IDPDG(IDK(I)).GT.0) THEN
41911                   KKK = (IDK(I)-423)/2
41912                   IF(KKK.GT.3) THEN
41913                      KKK = KKK-6
41914                      IM = 2
41915                   ELSE
41916                      IM = 1
41917                   ENDIF
41918                   IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41919                     III = (IDKPRD(1,I)-120)/2
41920                     JJJ = (IDKPRD(2,I)-119)/2
41921                   ELSE
41922                     III = (IDKPRD(2,I)-120)/2
41923                     JJJ = (IDKPRD(1,I)-119)/2
41924                   ENDIF
41925                   I2DRTP(N2MODE) = 6
41926                   A2MODE(1,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
41927      &                 LAMDA1(III,JJJ,KKK)
41928                   A2MODE(2,N2MODE) = 0.0D0
41929                 ELSE
41930 C--antiparticle decay
41931                   KKK = (IDK(I)-429)/2
41932                   IF(KKK.GT.3) THEN
41933                      KKK = KKK-6
41934                      IM = 2
41935                   ELSE
41936                      IM = 1
41937                   ENDIF
41938                   IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41939                     III = (IDKPRD(1,I)-126)/2
41940                     JJJ = (IDKPRD(2,I)-125)/2
41941                   ELSE
41942                     III = (IDKPRD(2,I)-126)/2
41943                     JJJ = (IDKPRD(1,I)-125)/2
41944                   ENDIF
41945                   I2DRTP(N2MODE) = 13
41946                   A2MODE(1,N2MODE) = 0.0D0
41947                   A2MODE(2,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
41948      &                 LAMDA1(III,JJJ,KKK)
41949                 ENDIF
41950 C--left slepton decay
41951               ELSE
41952                 N2MODE = N2MODE+1
41953                 IF(N2MODE.GT.NMODE2) THEN
41954                   CALL HWWARN('HWISP2',133)
41955                   GOTO 999
41956                 ENDIF
41957                 NME(I) = 30000+N2MODE
41958                 ID2PRT(N2MODE) = I
41959                 P2MODE(N2MODE) = ONE
41960                 IF(IDPDG(IDK(I)).GT.0) THEN
41961                   JJJ = (IDK(I)-423)/2
41962                   IF(JJJ.GT.3) THEN
41963                     JJJ = JJJ-6
41964                     IM = 2
41965                   ELSE
41966                     IM = 1
41967                   ENDIF
41968                   IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41969                     III = (IDKPRD(1,I)-126)/2
41970                     KKK = (IDKPRD(2,I)-119)/2
41971                     I2DRTP(N2MODE) = 8
41972                   ELSE
41973                     III = (IDKPRD(2,I)-126)/2
41974                     KKK = (IDKPRD(1,I)-119)/2
41975                     I2DRTP(N2MODE) = 5
41976                   ENDIF
41977                   A2MODE(1,N2MODE) = 0.0D0
41978                   A2MODE(2,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
41979      &                 LAMDA1(III,JJJ,KKK)
41980                 ELSE
41981                   JJJ = (IDK(I)-429)/2
41982                   IF(JJJ.GT.3) THEN
41983                     JJJ = JJJ-6
41984                     IM = 2
41985                   ELSE
41986                     IM = 1
41987                   ENDIF
41988                   IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41989                     III = (IDKPRD(1,I)-120)/2
41990                     KKK = (IDKPRD(2,I)-125)/2
41991                     I2DRTP(N2MODE) = 5
41992                   ELSE
41993                     III = (IDKPRD(2,I)-120)/2
41994                     KKK = (IDKPRD(1,I)-125)/2
41995                     I2DRTP(N2MODE) = 8
41996                   ENDIF
41997                   A2MODE(1,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
41998      &                 LAMDA1(III,JJJ,KKK)
41999                   A2MODE(2,N2MODE) = 0.0D0
42000                 ENDIF
42001               ENDIF
42002 C--sneutrino decays
42003             ELSEIF(MOD(IDK(I),2).EQ.0.AND.IDK(I).LE.436) THEN
42004 C--sneutrino decay
42005               N2MODE = N2MODE+1
42006               IF(N2MODE.GT.NMODE2) THEN
42007                 CALL HWWARN('HWISP2',134)
42008                 GOTO 999
42009               ENDIF
42010               NME(I) = 30000+N2MODE
42011               ID2PRT(N2MODE) = I
42012               P2MODE(N2MODE) = ONE
42013               IF(IDPDG(IDK(I)).GT.0) THEN
42014                 III = (IDK(I)-424)/2
42015                 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
42016                   KKK = (IDKPRD(1,I)-119)/2
42017                   JJJ = (IDKPRD(2,I)-125)/2
42018                   I2DRTP(N2MODE) = 5
42019                 ELSE
42020                   JJJ = (IDKPRD(1,I)-125)/2
42021                   KKK = (IDKPRD(2,I)-119)/2
42022                   I2DRTP(N2MODE) = 8
42023                 ENDIF
42024                 A2MODE(1,N2MODE) = 0.0D0
42025                 A2MODE(2,N2MODE) = LAMDA1(III,JJJ,KKK)
42026 C--antisneutrino decay
42027               ELSE
42028                 III = (IDK(I)-430)/2
42029                 IF(IDPDG(IDKPRD(1,I)).LT.0) THEN
42030                   KKK = (IDKPRD(1,I)-125)/2
42031                   JJJ = (IDKPRD(2,I)-119)/2
42032                   I2DRTP(N2MODE) = 8
42033                 ELSE
42034                   JJJ = (IDKPRD(1,I)-119)/2
42035                   KKK = (IDKPRD(2,I)-125)/2
42036                   I2DRTP(N2MODE) = 5
42037                 ENDIF
42038                 A2MODE(1,N2MODE) = LAMDA1(III,JJJ,KKK)
42039                 A2MODE(2,N2MODE) = 0.0D0
42040               ENDIF
42041             ENDIF
42042 C--LQD modes
42043 C--squark decays
42044           ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
42045      &           IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
42046      &           IDKPRD(2,I).LE.12) THEN
42047 C--up type squark decay
42048             IF(MOD(IDK(I),2).EQ.0) THEN
42049               N2MODE = N2MODE+1
42050               IF(N2MODE.GT.NMODE2) THEN
42051                 CALL HWWARN('HWISP2',135)
42052                 GOTO 999
42053               ENDIF
42054               NME(I) = 30000+N2MODE
42055               ID2PRT(N2MODE) = I
42056               P2MODE(N2MODE) = ONE
42057               IF(IDPDG(IDK(I)).GT.0) THEN
42058                 JJJ = (IDK(I)-400)/2
42059                 IF(JJJ.GT.3) THEN
42060                   JJJ = JJJ-6
42061                   IM  = 2
42062                 ELSE
42063                   IM = 1
42064                 ENDIF
42065                 III = (IDKPRD(1,I)-125)/2
42066                 KKK = (IDKPRD(2,I)+1)/2
42067                 I2DRTP(N2MODE) = 8
42068                 A2MODE(1,N2MODE) = ZERO
42069                 A2MODE(2,N2MODE) = QMIXSS(2*JJJ,1,IM)*
42070      &                             LAMDA2(III,JJJ,KKK)
42071               ELSE
42072                 JJJ = (IDK(I)-406)/2
42073                 IF(JJJ.GT.3) THEN
42074                   JJJ = JJJ-6
42075                   IM  = 2
42076                 ELSE
42077                   IM = 1
42078                 ENDIF
42079                 III = (IDKPRD(1,I)-119)/2
42080                 KKK = (IDKPRD(2,I)-5)/2
42081                 I2DRTP(N2MODE) = 5
42082                 A2MODE(1,N2MODE) = QMIXSS(2*JJJ,1,IM)*
42083      &                             LAMDA2(III,JJJ,KKK)
42084                 A2MODE(2,N2MODE) = ZERO
42085               ENDIF
42086 C--down type squark to lepton up
42087             ELSEIF(MOD(IDK(I),2).EQ.1.AND.MOD(IDKPRD(1,I),2).EQ.1) THEN
42088               N2MODE = N2MODE+1
42089               IF(N2MODE.GT.NMODE2) THEN
42090                 CALL HWWARN('HWISP2',136)
42091                 GOTO 999
42092               ENDIF
42093               NME(I) = 30000+N2MODE
42094               ID2PRT(N2MODE) = I
42095               P2MODE(N2MODE) = ONE
42096 C--particle
42097               IF(IDPDG(IDK(I)).GT.0) THEN
42098                 KKK = (IDK(I)-399)/2
42099                 IF(KKK.GT.3) THEN
42100                   KKK = KKK-6
42101                   IM  = 2
42102                 ELSE
42103                   IM  = 1
42104                 ENDIF
42105                 III = (IDKPRD(1,I)-119)/2
42106                 JJJ = IDKPRD(2,I)/2
42107                 I2DRTP(N2MODE) = 6
42108                 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
42109      &                             LAMDA2(III,JJJ,KKK)
42110                 A2MODE(2,N2MODE) = ZERO
42111 C--antiparticle
42112               ELSE
42113                 KKK = (IDK(I)-405)/2
42114                 IF(KKK.GT.3) THEN
42115                   KKK = KKK-6
42116                   IM  = 2
42117                 ELSE
42118                   IM  = 1
42119                 ENDIF
42120                 III = (IDKPRD(1,I)-125)/2
42121                 JJJ = (IDKPRD(2,I)-6)/2
42122                 I2DRTP(N2MODE) = 13
42123                 A2MODE(1,N2MODE) = ZERO
42124                 A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
42125      &                             LAMDA2(III,JJJ,KKK)
42126               ENDIF
42127 C--down (left) squark --> nu d
42128             ELSEIF(MOD(IDK(I),2).EQ.1.AND.
42129      &           IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
42130      &          -IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
42131               N2MODE = N2MODE+1
42132               IF(N2MODE.GT.NMODE2) THEN
42133                 CALL HWWARN('HWISP2',137)
42134                 GOTO 999
42135               ENDIF
42136               NME(I) = 30000+N2MODE
42137               ID2PRT(N2MODE) = I
42138               P2MODE(N2MODE) = ONE
42139               IF(IDPDG(IDK(I)).GT.0) THEN
42140                 JJJ = (IDK(I)-399)/2
42141                 IF(JJJ.GT.3) THEN
42142                   JJJ = JJJ-6
42143                   IM  = 2
42144                 ELSE
42145                   IM  = 1
42146                 ENDIF
42147                 III = (IDKPRD(1,I)-126)/2
42148                 KKK = (IDKPRD(2,I)+1)/2
42149                 I2DRTP(N2MODE) = 8
42150                 A2MODE(1,N2MODE) = ZERO
42151                 A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
42152      &                             LAMDA2(III,JJJ,KKK)
42153               ELSE
42154                 JJJ = (IDK(I)-405)/2
42155                 IF(JJJ.GT.3) THEN
42156                   JJJ = JJJ-6
42157                   IM = 2
42158                 ELSE
42159                   IM = 1
42160                 ENDIF
42161                 III = (IDKPRD(1,I)-120)/2
42162                 KKK = (IDKPRD(2,I)-5)/2
42163                 I2DRTP(N2MODE) = 5
42164                 A2MODE(1,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
42165      &                             LAMDA2(III,JJJ,KKK)
42166                 A2MODE(2,N2MODE) = ZERO
42167               ENDIF
42168 C--down (right) squark --> nu d
42169             ELSEIF(MOD(IDK(I),2).EQ.1.AND.
42170      &           IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
42171      &           IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
42172               N2MODE = N2MODE+1
42173               IF(N2MODE.GT.NMODE2) THEN
42174                 CALL HWWARN('HWISP2',138)
42175                 GOTO 999
42176               ENDIF
42177               NME(I) = 30000+N2MODE
42178               ID2PRT(N2MODE) = I
42179               P2MODE(N2MODE) = ONE
42180               IF(IDPDG(IDK(I)).GT.0) THEN
42181                 KKK = (IDK(I)-399)/2
42182                 IF(KKK.GT.3) THEN
42183                   KKK = KKK-6
42184                   IM  = 2
42185                 ELSE
42186                   IM  = 1
42187                 ENDIF
42188                 III = (IDKPRD(1,I)-120)/2
42189                 JJJ = (IDKPRD(2,I)+1)/2
42190                 I2DRTP(N2MODE) = 6
42191                 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
42192      &                             LAMDA2(III,JJJ,KKK)
42193                 A2MODE(2,N2MODE) = ZERO
42194               ELSE
42195                 KKK = (IDK(I)-405)/2
42196                 IF(KKK.GT.3) THEN
42197                   KKK = KKK-6
42198                   IM  = 2
42199                 ELSE
42200                   IM  = 1
42201                 ENDIF
42202                 III = (IDKPRD(1,I)-126)/2
42203                 JJJ = (IDKPRD(2,I)-5)/2
42204                 I2DRTP(N2MODE) = 13
42205                 A2MODE(1,N2MODE) = ZERO
42206                 A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
42207      &                             LAMDA2(III,JJJ,KKK)
42208               ENDIF
42209             ELSE
42210               CALL HWWARN('HWISP2',2)
42211             ENDIF
42212 C--slepton decays
42213           ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
42214      &           IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
42215 C--sneutrino decay
42216             IF(MOD(IDK(I),2).EQ.0) THEN
42217               N2MODE = N2MODE+1
42218               IF(N2MODE.GT.NMODE2) THEN
42219                 CALL HWWARN('HWISP2',140)
42220                 GOTO 999
42221               ENDIF
42222               NME(I) = 30000+N2MODE
42223               ID2PRT(N2MODE) = I
42224               P2MODE(N2MODE) = THREE
42225 C--particle
42226               IF(IDPDG(IDK(I)).GT.0) THEN
42227                 III = (IDK(I)-424)/2
42228                 JJJ = (IDKPRD(1,I)-5)/2
42229                 KKK = (IDKPRD(2,I)+1)/2
42230                 I2DRTP(N2MODE) = 8
42231                 A2MODE(1,N2MODE) = 0.0D0
42232                 A2MODE(2,N2MODE) = LAMDA2(III,JJJ,KKK)
42233 C--antiparticle
42234               ELSE
42235                 III = (IDK(I)-430)/2
42236                 JJJ = (IDKPRD(1,I)+1)/2
42237                 KKK = (IDKPRD(2,I)-5)/2
42238                 I2DRTP(N2MODE) = 5
42239                 A2MODE(1,N2MODE) = LAMDA2(III,JJJ,KKK)
42240                 A2MODE(2,N2MODE) = 0.0D0
42241               ENDIF
42242 C--slepton decay
42243             ELSEIF(MOD(IDK(I),2).EQ.1) THEN
42244               N2MODE = N2MODE+1
42245               IF(N2MODE.GT.NMODE2) THEN
42246                 CALL HWWARN('HWISP2',141)
42247                 GOTO 999
42248               ENDIF
42249               NME(I) = 30000+N2MODE
42250               ID2PRT(N2MODE) = I
42251               P2MODE(N2MODE) = THREE
42252 C--particle
42253               IF(IDPDG(IDK(I)).GT.0) THEN
42254                 III = (IDK(I)-423)/2
42255                 IF(III.GT.3) THEN
42256                    III = III -6
42257                    IM = 2
42258                 ELSE
42259                    IM = 1
42260                 ENDIF
42261                 JJJ = (IDKPRD(1,I)-6)/2
42262                 KKK = (IDKPRD(2,I)+1)/2
42263                 I2DRTP(N2MODE) = 8
42264                 A2MODE(1,N2MODE) = 0.0D0
42265                 A2MODE(2,N2MODE) = LMIXSS(2*III-1,1,IM)*
42266      &                             LAMDA2(III,JJJ,KKK)
42267 C--antiparticle
42268               ELSE
42269                 III = (IDK(I)-429)/2
42270                 IF(III.GT.3) THEN
42271                    III = III -6
42272                    IM = 2
42273                 ELSE
42274                    IM = 1
42275                 ENDIF
42276                 JJJ = IDKPRD(1,I)/2
42277                 KKK = (IDKPRD(2,I)-5)/2
42278                 I2DRTP(N2MODE) = 5
42279                 A2MODE(1,N2MODE) = LMIXSS(2*III-1,1,IM)*
42280      &                             LAMDA2(III,JJJ,KKK)
42281                 A2MODE(2,N2MODE) = 0.0D0
42282               ENDIF
42283             ELSE
42284               CALL HWWARN('HWISP2',3)
42285             ENDIF
42286 C--UDD modes
42287           ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
42288      &           IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
42289 C--up type squark decay
42290             IF(MOD(IDK(I),2).EQ.0) THEN
42291               N2MODE = N2MODE+1
42292               IF(N2MODE.GT.NMODE2) THEN
42293                 CALL HWWARN('HWISP2',143)
42294                 GOTO 999
42295               ENDIF
42296               NME(I) = 30000+N2MODE
42297               ID2PRT(N2MODE) = I
42298               P2MODE(N2MODE) = 2.0D0
42299 C--squark decay
42300               IF(IDPDG(IDK(I)).GT.0) THEN
42301                 III = (IDK(I)-400)/2
42302                 IF(III.GT.3) THEN
42303                   III = III-6
42304                   IM = 2
42305                 ELSE
42306                   IM = 1
42307                 ENDIF
42308                 JJJ = (IDKPRD(1,I)-5)/2
42309                 KKK = (IDKPRD(2,I)-5)/2
42310                 I2DRTP(N2MODE) = 13
42311                 A2MODE(1,N2MODE)=QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
42312                 A2MODE(2,N2MODE)=0.0D0
42313 C--antisquark decay
42314               ELSE
42315                 III = (IDK(I)-406)/2
42316                 IF(III.GT.3) THEN
42317                   III = III-6
42318                   IM = 2
42319                 ELSE
42320                   IM = 1
42321                 ENDIF
42322                 JJJ = (IDKPRD(1,I)+1)/2
42323                 KKK = (IDKPRD(2,I)+1)/2
42324                 I2DRTP(N2MODE) = 6
42325                 A2MODE(1,N2MODE) =0.0D0
42326                 A2MODE(2,N2MODE) =QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
42327               ENDIF
42328             ELSE
42329 C--down type squark decay
42330               N2MODE = N2MODE+1
42331               IF(N2MODE.GT.NMODE2) THEN
42332                 CALL HWWARN('HWISP2',144)
42333                 GOTO 999
42334               ENDIF
42335               NME(I) = 30000+N2MODE
42336               ID2PRT(N2MODE) = I
42337               P2MODE(N2MODE) = 2.0D0
42338 C--squark decay
42339               IF(IDPDG(IDK(I)).GT.0) THEN
42340                 JJJ = (IDK(I)-399)/2
42341                 IF(JJJ.GT.3) THEN
42342                   JJJ = JJJ-6
42343                   IM = 2
42344                 ELSE
42345                   IM = 1
42346                 ENDIF
42347                 III = (IDKPRD(1,I)-6)/2
42348                 KKK = (IDKPRD(2,I)-5)/2
42349                 I2DRTP(N2MODE) = 13
42350                 A2MODE(1,N2MODE)= QMIXSS(2*JJJ-1,2,IM)*
42351      &                            LAMDA3(III,JJJ,KKK)
42352                 A2MODE(2,N2MODE)= 0.0D0
42353 C--antisquark decay
42354               ELSE
42355                 JJJ = (IDK(I)-405)/2
42356                 IF(JJJ.GT.3) THEN
42357                   JJJ = JJJ-6
42358                   IM = 2
42359                 ELSE
42360                   IM = 1
42361                 ENDIF
42362                 III = IDKPRD(1,I)/2
42363                 KKK = (IDKPRD(2,I)+1)/2
42364                 I2DRTP(N2MODE) = 6
42365                 A2MODE(1,N2MODE) = 0.0D0
42366                 A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,2,IM)*
42367      &                             LAMDA3(III,JJJ,KKK)
42368               ENDIF
42369             ENDIF
42370           ELSE
42371             IF(.NOT.(RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.
42372      &         RSPIN(IDKPRD(2,I)).EQ.ZERO)) CALL HWWARN('HWISP2',4)
42373           ENDIF
42374         ELSEIF(IDK(I).GE.203.AND.IDK(I).LE.207) THEN
42375           IH = IDK(I)-202
42376           L  = IDKPRD(1,I)-449
42377           L1 = IDKPRD(2,I)-449
42378 C--Neutral Higgs decays
42379           IF(IH.GE.1.AND.IH.LE.3) THEN
42380 C--Higgs to neutralino neutralino
42381             IF(L.GE.1.AND.L.LE.4) THEN
42382               N2MODE = N2MODE+1
42383               IF(N2MODE.GT.NMODE2) THEN
42384                 CALL HWWARN('HWISP2',146)
42385                 GOTO 999
42386               ENDIF
42387               NME(I) = 30000+N2MODE
42388               ID2PRT(N2MODE) = I
42389               I2DRTP(N2MODE) = 6
42390               P2MODE(N2MODE) = ONE
42391               IF(L.EQ.L1) P2MODE(N2MODE) = HALF
42392               DO 24 J=1,2
42393  24           A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
42394 C--Higgs to chargino chargino
42395             ELSEIF(L.GE.5.AND.L.LE.8) THEN
42396               L  = MOD(L -5,2)+1
42397               L1 = MOD(L1-5,2)+1
42398               N2MODE = N2MODE+1
42399               IF(N2MODE.GT.NMODE2) THEN
42400                 CALL HWWARN('HWISP2',147)
42401                 GOTO 999
42402               ENDIF
42403               NME(I) = 30000+N2MODE
42404               ID2PRT(N2MODE) = I
42405               I2DRTP(N2MODE) = 6
42406               P2MODE(N2MODE) = ONE
42407               DO 25 J=1,2
42408               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
42409                 A2MODE(J,N2MODE) = HCC(  J ,IH,L,L1)
42410               ELSE
42411                 A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
42412               ENDIF
42413  25           CONTINUE
42414 C--Higgs to fermion antifermion
42415             ELSEIF((L.GE.-448.AND.L.LE.-437)
42416      &         .OR.(L.GE.-328.AND.L.LE.-317)) THEN
42417               N2MODE = N2MODE+1
42418               IF(N2MODE.GT.NMODE2) THEN
42419                 CALL HWWARN('HWISP2',148)
42420                 GOTO 999
42421               ENDIF
42422               NME(I) = 30000+N2MODE
42423               ID2PRT(N2MODE) = I
42424               I2DRTP(N2MODE) = 5
42425               P2MODE(N2MODE) = ONE
42426               IL = IDKPRD(1,I)
42427               IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42428               IF(IL.LE.6) P2MODE(N2MODE) = THREE
42429               DO 26 J=1,2
42430  26           A2MODE(J,N2MODE) = HFF(J,IH,IL)
42431             ELSE
42432               IF(.NOT.
42433      &       (RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.RSPIN(IDKPRD(2,I)).EQ.ZERO)
42434      &        .AND..NOT.(IDKPRD(1,I).EQ.13.AND.IDKPRD(2,I).EQ.13)
42435      &        .AND..NOT.(IDKPRD(1,I).EQ.59.AND.IDKPRD(2,I).EQ.59)
42436      &        .AND..NOT.(IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
42437      &                   IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200))
42438      &        CALL HWWARN('HWISP2',5)
42439             ENDIF
42440 C--charged Higgs decays
42441           ELSE
42442             IH = IDK(I)-205
42443             L  = IDKPRD(1,I)-449
42444             L1 = IDKPRD(2,I)-449
42445 C--positive Higgs decays
42446             IF(IH.EQ.1) THEN
42447 C--decay to chargino neutralino
42448               IF(L.EQ.5.OR.L.EQ.6) THEN
42449                 L = L-4
42450                 N2MODE = N2MODE+1
42451                 IF(N2MODE.GT.NMODE2) THEN
42452                   CALL HWWARN('HWISP2',149)
42453                   GOTO 999
42454                 ENDIF
42455                 NME(I) = 30000+N2MODE
42456                 ID2PRT(N2MODE) = I
42457                 I2DRTP(N2MODE) = 6
42458                 P2MODE(N2MODE) = ONE
42459                 DO 27 J=1,2
42460  27             A2MODE(J,N2MODE) = HNC(O(J),L1,L)
42461 C--decay to neutralino chargino
42462               ELSEIF(L.GE.1.AND.L.LE.4) THEN
42463                 L1 = L1-4
42464                 N2MODE = N2MODE+1
42465                 IF(N2MODE.GT.NMODE2) THEN
42466                   CALL HWWARN('HWISP2',150)
42467                   GOTO 999
42468                 ENDIF
42469                 NME(I) = 30000+N2MODE
42470                 ID2PRT(N2MODE) = I
42471                 I2DRTP(N2MODE) = 6
42472                 P2MODE(N2MODE) = ONE
42473                 DO 28 J=1,2
42474  28             A2MODE(J,N2MODE) = HNC(O(J),L1,L)
42475 C--fermion antifermion decay modes
42476               ELSEIF((L.GE.-448.AND.L.LE.-437)
42477      &               .OR.(L.GE.-328.AND.L.LE.-317)) THEN
42478                 N2MODE = N2MODE+1
42479                 IF(N2MODE.GT.NMODE2) THEN
42480                   CALL HWWARN('HWISP2',151)
42481                   GOTO 999
42482                 ENDIF
42483                 NME(I) = 30000+N2MODE
42484                 ID2PRT(N2MODE) = I
42485                 I2DRTP(N2MODE) = 5
42486                 P2MODE(N2MODE) = ONE
42487                 IL = IDKPRD(1,I)
42488                 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42489                 IL = INT((IL+1)/2)
42490                 IF(IL.LE.3) P2MODE(N2MODE) = THREE
42491                 DO 29 J=1,2
42492  29             A2MODE(J,N2MODE) = HFF(J,4,IL)
42493               ELSE
42494                 IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(2,I)).NE.
42495      &           ZERO) CALL HWWARN('HWISP2',6)
42496               ENDIF
42497 C--negative Higgs decays
42498             ELSE
42499 C--Higgs to chargino neutralino
42500               IF(L.EQ.7.OR.L.EQ.8) THEN
42501                 L = L-6
42502                 N2MODE = N2MODE+1
42503                 IF(N2MODE.GT.NMODE2) THEN
42504                   CALL HWWARN('HWISP2',152)
42505                   GOTO 999
42506                 ENDIF
42507                 NME(I) = 30000+N2MODE
42508                 ID2PRT(N2MODE) = I
42509                 I2DRTP(N2MODE) = 6
42510                 P2MODE(N2MODE) = ONE
42511                 DO 30 J=1,2
42512  30             A2MODE(J,N2MODE) = HNC(J,L1,L)
42513 C--Higgs to neutralino chargino
42514               ELSEIF(L.GE.1.AND.L.LE.4) THEN
42515                 L1 = L1-6
42516                 N2MODE = N2MODE+1
42517                 IF(N2MODE.GT.NMODE2) THEN
42518                   CALL HWWARN('HWISP2',153)
42519                   GOTO 999
42520                 ENDIF
42521                 NME(I) = 30000+N2MODE
42522                 ID2PRT(N2MODE) = I
42523                 I2DRTP(N2MODE) = 6
42524                 P2MODE(N2MODE) = ONE
42525                 DO 31 J=1,2
42526  31             A2MODE(J,N2MODE) = HNC(J,L1,L)
42527 C--fermion antifermion decay modes
42528               ELSEIF((L.GE.-448.AND.L.LE.-437)
42529      &               .OR.(L.GE.-328.AND.L.LE.-317)) THEN
42530                 N2MODE = N2MODE+1
42531                 IF(N2MODE.GT.NMODE2) THEN
42532                   CALL HWWARN('HWISP2',154)
42533                   GOTO 999
42534                 ENDIF
42535                 NME(I) = 30000+N2MODE
42536                 ID2PRT(N2MODE) = I
42537                 I2DRTP(N2MODE) = 8
42538                 P2MODE(N2MODE) = ONE
42539                 IL = IDKPRD(1,I)
42540                 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42541                 IL = INT((IL+1)/2)
42542                 IF(IL.LE.3) P2MODE(N2MODE) = THREE
42543                 DO 32 J=1,2
42544  32             A2MODE(J,N2MODE) = HFF(O(J),4,IL)
42545               ELSE
42546                 IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(1,I)).NE.
42547      &           ZERO) CALL HWWARN('HWISP2',7)
42548               ENDIF
42549             ENDIF
42550           ENDIF
42551         ENDIF
42552  1000 CONTINUE
42553 C--now find the maximum weights and compute the decay rates
42554       DO 2000 I=1,N2MODE
42555       IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(ID2PRT(I))),
42556      &   RNAME(IDKPRD(1,ID2PRT(I))),RNAME(IDKPRD(2,ID2PRT(I)))
42557  2000 CALL HWD2ME(I)
42558       RETURN
42559  5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
42560      &     A8,' --> ',A8,' ',A8/)
42561  999  RETURN
42562       END
42563 CDECK  ID>, HWISP3.
42564 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
42565 *-- Author :    Peter Richardson
42566 C-----------------------------------------------------------------------
42567       SUBROUTINE HWISP3
42568 C-----------------------------------------------------------------------
42569 C     Initialise the top/SUSY three body decay modes
42570 C     gravitino and RPV modes added by Peter Richardson
42571 C-----------------------------------------------------------------------
42572       INCLUDE 'herwig65.inc'
42573       INTEGER I,J,K,L,L1,IL,IQ,IQ1,IQ2,IFR,SIFR,IH,IH1,IM,O(2),II,JJ,
42574      &     III,JJJ,KKK
42575       DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
42576      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
42577      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
42578      &     HZZ(2),ZAB(12,2,2),HHB(2,3)
42579       DOUBLE COMPLEX RHOIN(2,2)
42580       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
42581      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
42582       SAVE O
42583       DATA O/2,1/
42584       IF(IERROR.NE.0) RETURN
42585 C--loop over the decays and find the top decays
42586       DO 1000 JJ=6,12,6
42587       DO 1000 II=1,NMODES(JJ)
42588         IF(II.EQ.1) THEN
42589           I = LSTRT(JJ)
42590         ELSE
42591           I = LNEXT(I)
42592         ENDIF
42593 C--top decay via W
42594         IF(IDK(I).EQ.6.AND.NME(I).EQ.100) THEN
42595           N3MODE = N3MODE+1
42596           IF(N3MODE.GT.NMODE3) THEN
42597             CALL HWWARN('HWISP3',100)
42598             GOTO 999
42599           ENDIF
42600           P3MODE(N3MODE) = ONE
42601           IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
42602           SPN3CF(1,1,N3MODE) = ONE
42603           N3NCFL(N3MODE) = 1
42604           ID3PRT(N3MODE) = I
42605           NME(I)         = 10000+N3MODE
42606           NDI3BY(N3MODE)   = 1
42607           I3DRTP(1,N3MODE) = 1
42608           I3DRCF(1,N3MODE) = 1
42609           I3MODE(1,N3MODE) = 198
42610           A3MODE(1,1,N3MODE) = ZERO
42611           A3MODE(2,1,N3MODE) = -G*ORT
42612           B3MODE(1,1,N3MODE) = ZERO
42613           B3MODE(2,1,N3MODE) = -G*ORT
42614 C--antitop decay via W
42615         ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.100) THEN
42616           N3MODE = N3MODE+1
42617           IF(N3MODE.GT.NMODE3) THEN
42618             CALL HWWARN('HWISP3',101)
42619             GOTO 999
42620           ENDIF
42621           P3MODE(N3MODE) = ONE
42622           IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
42623           SPN3CF(1,1,N3MODE) = ONE
42624           N3NCFL(N3MODE) = 1
42625           ID3PRT(N3MODE) = I
42626           NME(I) = 10000+N3MODE
42627           NDI3BY(N3MODE)   = 1
42628           I3DRTP(1,N3MODE) = 5
42629           I3DRCF(1,N3MODE) = 1
42630           I3MODE(1,N3MODE) = 199
42631           A3MODE(1,1,N3MODE) = ZERO
42632           A3MODE(2,1,N3MODE) = -G*ORT
42633           B3MODE(1,1,N3MODE) = ZERO
42634           B3MODE(2,1,N3MODE) = -G*ORT
42635 C--top decay via charged Higgs
42636         ELSEIF(IDK(I).EQ.6.AND.NME(I).EQ.200) THEN
42637           N3MODE = N3MODE+1
42638           IF(N3MODE.GT.NMODE3) THEN
42639             CALL HWWARN('HWISP3',102)
42640             GOTO 999
42641           ENDIF
42642           P3MODE(N3MODE) = ONE
42643           IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
42644           SPN3CF(1,1,N3MODE) = ONE
42645           N3NCFL(N3MODE) = 1
42646           ID3PRT(N3MODE) = I
42647           NME(I) = 10000+N3MODE
42648           NDI3BY(N3MODE)   = 1
42649           I3DRTP(1,N3MODE) = 2
42650           I3DRCF(1,N3MODE) = 1
42651           I3MODE(1,N3MODE) = 206
42652           IL = IDKPRD(1,I)
42653           IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42654           IL = INT((IL+1)/2)
42655           DO 201 J=1,2
42656           A3MODE(J,1,N3MODE) = HFF(O(J),4,3)
42657  201      B3MODE(J,1,N3MODE) = HFF(  J ,4,IL)
42658 C--antitop decay via charged Higgs
42659         ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.200) THEN
42660           N3MODE = N3MODE+1
42661           IF(N3MODE.GT.NMODE3) THEN
42662             CALL HWWARN('HWISP3',103)
42663             GOTO 999
42664           ENDIF
42665           P3MODE(N3MODE) = ONE
42666           IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
42667           SPN3CF(1,1,N3MODE) = ONE
42668           N3NCFL(N3MODE) = 1
42669           ID3PRT(N3MODE) = I
42670           NME(I) = 10000+N3MODE
42671           NDI3BY(N3MODE)   = 1
42672           I3DRTP(1,N3MODE) = 17
42673           I3DRCF(1,N3MODE) = 1
42674           I3MODE(1,N3MODE) = 207
42675           IL = IDKPRD(1,I)
42676           IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42677           IL = INT((IL+1)/2)
42678           DO 202 J=1,2
42679           A3MODE(J,1,N3MODE) = HFF(  J ,4,3)
42680  202      B3MODE(J,1,N3MODE) = HFF(O(J),4,IL)
42681         ENDIF
42682  1000 CONTINUE
42683       IF(.NOT.SUSYIN) GOTO 2999
42684 C--loop over all the SUSY decay modes and find the ones we want
42685 C--first the true three body gaugino decays
42686       DO 2000 JJ=1,NRES
42687       DO 2000 II=1,NMODES(JJ)
42688         IF(II.EQ.1) THEN
42689           I = LSTRT(JJ)
42690         ELSE
42691           I = LNEXT(I)
42692         ENDIF
42693         L = IDKPRD(1,I)-449
42694         IF(IDKPRD(3,I).EQ.0.OR.IDKPRD(4,I).NE.0) GOTO 2500
42695 C--gluino modes first
42696         IF(IDK(I).EQ.449) THEN
42697 C--first the gluino modes to quark-antiquark neutralino
42698           IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
42699      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42700             IQ = IDKPRD(2,I)
42701             IF(IQ.GT.6) IQ=IQ-6
42702             IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',200)
42703             N3MODE = N3MODE+1
42704             IF(N3MODE.GT.NMODE3) THEN
42705               CALL HWWARN('HWISP3',104)
42706               GOTO 999
42707             ENDIF
42708             P3MODE(N3MODE) = HALF
42709             SPN3CF(1,1,N3MODE) = ONE
42710             N3NCFL(N3MODE) = 1
42711             ID3PRT(N3MODE) = I
42712             NME(I) = 10000+N3MODE
42713             NDI3BY(N3MODE)   = 4
42714 C--only squark exchange diagrams
42715             DO 1 K=1,2
42716             I3DRTP(K  ,N3MODE) = 3
42717             I3DRCF(K  ,N3MODE) = 1
42718             I3DRTP(K+2,N3MODE) = 4
42719             I3DRCF(K+2,N3MODE) = 1
42720             I3MODE(K  ,N3MODE) = 12*(K-1)+400+IQ
42721             I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ
42722             DO 1 J=1,2
42723             A3MODE(J,K  ,N3MODE) = AFG(  J ,IQ,K)
42724             B3MODE(J,K  ,N3MODE) = AFN(O(J),IQ,K,L)
42725             A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ,K)
42726  1          B3MODE(J,K+2,N3MODE) = ZSGNSS(L)*AFN(  J ,IQ,K,L)
42727 C--then the gluino modes to quark-antiquark +ve chargino
42728           ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
42729      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42730             L = L-4
42731             IQ = IDKPRD(2,I)
42732             IF(IQ.GT.6) IQ=IQ-6
42733             IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',201)
42734             IQ = (IQ+MOD(IQ,2))/2
42735             IQ1 = 2*IQ-1
42736             IQ2 = 2*IQ
42737             N3MODE = N3MODE+1
42738             IF(N3MODE.GT.NMODE3) THEN
42739               CALL HWWARN('HWISP3',105)
42740               GOTO 999
42741             ENDIF
42742             P3MODE(N3MODE) = HALF
42743             SPN3CF(1,1,N3MODE) = ONE
42744             N3NCFL(N3MODE) = 1
42745             ID3PRT(N3MODE) = I
42746             NME(I) = 10000+N3MODE
42747             NDI3BY(N3MODE)   = 4
42748 C--only squark exchange diagrams
42749             DO 2 K=1,2
42750             I3DRTP(K  ,N3MODE) = 3
42751             I3DRCF(K  ,N3MODE) = 1
42752             I3DRTP(K+2,N3MODE) = 4
42753             I3DRCF(K+2,N3MODE) = 1
42754             I3MODE(K  ,N3MODE) = 12*(K-1)+400+IQ1
42755             I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
42756             DO 2 J=1,2
42757             A3MODE(J,K  ,N3MODE) = AFG(  J ,IQ1,K)
42758             B3MODE(J,K  ,N3MODE) = AFC(O(J),IQ1,K,L)
42759             A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
42760  2          B3MODE(J,K+2,N3MODE) = AFC(  J ,IQ2,K,L)
42761 C--then the gluino modes to quark-antiquark -ve chargino
42762           ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
42763      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42764             L = L-6
42765             IQ = IDKPRD(2,I)
42766             IF(IQ.GT.6) IQ=IQ-6
42767             IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',202)
42768             IQ = (IQ+MOD(IQ,2))/2
42769             IQ1 = 2*IQ
42770             IQ2 = 2*IQ-1
42771             N3MODE = N3MODE+1
42772             IF(N3MODE.GT.NMODE3) THEN
42773               CALL HWWARN('HWISP3',106)
42774               GOTO 999
42775             ENDIF
42776             P3MODE(N3MODE) = HALF
42777             SPN3CF(1,1,N3MODE) = ONE
42778             N3NCFL(N3MODE) = 1
42779             ID3PRT(N3MODE) = I
42780             NME(I) = 10000+N3MODE
42781             NDI3BY(N3MODE)   = 4
42782 C--only squark exchange diagrams
42783             DO 3 K=1,2
42784             I3DRTP(K  ,N3MODE) = 3
42785             I3DRCF(K  ,N3MODE) = 1
42786             I3DRTP(K+2,N3MODE) = 4
42787             I3DRCF(K+2,N3MODE) = 1
42788             I3MODE(K  ,N3MODE) = 12*(K-1)+400+IQ1
42789             I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
42790             DO 3 J=1,2
42791             A3MODE(J,K  ,N3MODE) = AFG(  J ,IQ1,K)
42792             B3MODE(J,K  ,N3MODE) = AFC(O(J),IQ1,K,L)
42793             A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
42794  3          B3MODE(J,K+2,N3MODE) = AFC(  J ,IQ2,K,L)
42795 C--RPV decay modes
42796 C--LQD first
42797           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
42798      &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
42799             N3MODE = N3MODE+1
42800             IF(N3MODE.GT.NMODE3) THEN
42801               CALL HWWARN('HWISP3',107)
42802               GOTO 999
42803             ENDIF
42804             ID3PRT(N3MODE) = I
42805             NME(I) = 10000+N3MODE
42806             P3MODE(N3MODE) = HALF
42807             SPN3CF(1,1,N3MODE) = ONE
42808             N3NCFL(N3MODE) = 1
42809             NDI3BY(N3MODE) = 4
42810             DO 98 J=1,4
42811  98         I3DRCF(J,N3MODE) = 1
42812 C--first the neutrino mode
42813             IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
42814 C--particle mode
42815               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
42816                 III = (IDKPRD(1,I)-120)/2
42817                 JJJ = (IDKPRD(2,I)+1)/2
42818                 KKK = (IDKPRD(3,I)-5)/2
42819                 DO 99 K=1,2
42820                 I3DRTP(K  ,N3MODE) = 3
42821                 I3DRTP(K+2,N3MODE) = 4
42822                 I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
42823                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
42824                 B3MODE(2,K  ,N3MODE) = 0.0D0
42825                 B3MODE(1,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
42826      &                                 LAMDA2(III,JJJ,KKK)
42827                 B3MODE(2,K+2,N3MODE) = 0.0D0
42828                 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
42829      &                                 LAMDA2(III,JJJ,KKK)
42830                 DO 99 J=1,2
42831                 A3MODE(J,K  ,N3MODE) = AFG(  J ,2*JJJ-1,K)
42832  99             A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
42833 C--antiparticle mode
42834               ELSE
42835                 III = (IDKPRD(1,I)-126)/2
42836                 JJJ = (IDKPRD(2,I)-5)/2
42837                 KKK = (IDKPRD(3,I)+1)/2
42838                 DO 101 K=1,2
42839                 I3DRTP(K  ,N3MODE) = 9
42840                 I3DRTP(K+2,N3MODE) = 10
42841                 I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
42842                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
42843                 B3MODE(1,K  ,N3MODE) = 0.0D0
42844                 B3MODE(2,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
42845      &                                 LAMDA2(III,JJJ,KKK)
42846                 B3MODE(1,K+2,N3MODE) = 0.0D0
42847                 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
42848      &                                 LAMDA2(III,JJJ,KKK)
42849                 DO 101 J=1,2
42850                 A3MODE(J,K  ,N3MODE) = AFG(O(J),2*JJJ-1,K)
42851  101            A3MODE(J,K+2,N3MODE) = AFG(  J ,2*KKK-1,K)
42852               ENDIF
42853 C--then the charged lepton mode
42854             ELSE
42855 C--particle mode
42856               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
42857                 III = (IDKPRD(1,I)-119)/2
42858                 JJJ = IDKPRD(2,I)/2
42859                 KKK = (IDKPRD(3,I)-5)/2
42860                 DO 102 K=1,2
42861                 I3DRTP(K  ,N3MODE) = 3
42862                 I3DRTP(K+2,N3MODE) = 4
42863                 I3MODE(K  ,N3MODE) = 400+2*JJJ+(K-1)*12
42864                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
42865                 B3MODE(2,K  ,N3MODE) = 0.0D0
42866                 B3MODE(1,K  ,N3MODE) = QMIXSS(2*JJJ,1,K)*
42867      &                                 LAMDA2(III,JJJ,KKK)
42868                 B3MODE(2,K+2,N3MODE) = 0.0D0
42869                 B3MODE(1,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42870      &                                 LAMDA2(III,JJJ,KKK)
42871                 DO 102 J=1,2
42872                 A3MODE(J,K  ,N3MODE) = AFG(  J ,2*JJJ  ,K)
42873  102            A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
42874 C--antiparticle mode
42875               ELSE
42876                 III = (IDKPRD(1,I)-125)/2
42877                 JJJ = (IDKPRD(2,I)-6)/2
42878                 KKK = (IDKPRD(3,I)+1)/2
42879                 DO 103 K=1,2
42880                 I3DRTP(K  ,N3MODE) = 9
42881                 I3DRTP(K+2,N3MODE) = 10
42882                 I3MODE(K  ,N3MODE) = 400+2*JJJ+(K-1)*12
42883                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
42884                 B3MODE(1,K  ,N3MODE) = 0.0D0
42885                 B3MODE(2,K  ,N3MODE) = QMIXSS(2*JJJ,1,K)*
42886      &                                 LAMDA2(III,JJJ,KKK)
42887                 B3MODE(1,K+2,N3MODE) = 0.0D0
42888                 B3MODE(2,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42889      &                                 LAMDA2(III,JJJ,KKK)
42890                 DO 103 J=1,2
42891                 A3MODE(J,K  ,N3MODE) = AFG(O(J),2*JJJ  ,K)
42892  103            A3MODE(J,K+2,N3MODE) = AFG(  J ,2*KKK-1,K)
42893               ENDIF
42894             ENDIF
42895 C--then UDD
42896           ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
42897      &           IDKPRD(3,I).LE.12) THEN
42898             N3MODE = N3MODE+1
42899             IF(N3MODE.GT.NMODE3) THEN
42900               CALL HWWARN('HWISP3',108)
42901               GOTO 999
42902             ENDIF
42903             P3MODE(N3MODE) = ONE
42904             N3NCFL(N3MODE) = 3
42905             ID3PRT(N3MODE) = I
42906             NME(I) = 10000+N3MODE
42907             NDI3BY(N3MODE)   = 6
42908             DO 70 J=1,3
42909             DO 70 K=1,3
42910               IF(J.NE.K) THEN
42911                 SPN3CF(J,K,N3MODE) = -HALF
42912               ELSE
42913                 SPN3CF(J,K,N3MODE) =  ONE
42914               ENDIF
42915  70         CONTINUE
42916 C--particle mode
42917             IF(IDKPRD(1,I).LE.6) THEN
42918 C--antiparticle mode
42919               III =  IDKPRD(1,I)/2
42920               JJJ = (IDKPRD(2,I)+1)/2
42921               KKK = (IDKPRD(3,I)+1)/2
42922               DO 71 K=1,2
42923               I3DRTP(K  ,N3MODE) = 11
42924               I3DRCF(K  ,N3MODE) = 1
42925               I3DRTP(K+2,N3MODE) = 12
42926               I3DRCF(K+2,N3MODE) = 2
42927               I3DRTP(K+4,N3MODE) = 13
42928               I3DRCF(K+4,N3MODE) = 3
42929               I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
42930               I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
42931               I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
42932               B3MODE(2,K  ,N3MODE) = QMIXSS(2*III,2,K)*
42933      &                               LAMDA3(III,JJJ,KKK)
42934               B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
42935      &                               LAMDA3(III,JJJ,KKK)
42936               B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42937      &                               LAMDA3(III,JJJ,KKK)
42938               B3MODE(1,K  ,N3MODE) = 0.0D0
42939               B3MODE(1,K+2,N3MODE) = 0.0D0
42940               B3MODE(1,K+4,N3MODE) = 0.0D0
42941               DO 71 J=1,2
42942               A3MODE(J,K  ,N3MODE) = AFG(J,2*III  ,K)
42943               A3MODE(J,K+2,N3MODE) = AFG(J,2*JJJ-1,K)
42944  71           A3MODE(J,K+4,N3MODE) = AFG(J,2*KKK-1,K)
42945             ELSE
42946               III = (IDKPRD(1,I)-6)/2
42947               JJJ = (IDKPRD(2,I)-5)/2
42948               KKK = (IDKPRD(3,I)-5)/2
42949               DO 72 K=1,2
42950               I3DRTP(K  ,N3MODE) = 14
42951               I3DRCF(K  ,N3MODE) = 1
42952               I3DRTP(K+2,N3MODE) = 15
42953               I3DRCF(K+2,N3MODE) = 2
42954               I3DRTP(K+4,N3MODE) = 16
42955               I3DRCF(K+4,N3MODE) = 3
42956               I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
42957               I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
42958               I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
42959               B3MODE(1,K  ,N3MODE) = QMIXSS(2*III,2,K)*
42960      &                               LAMDA3(III,JJJ,KKK)
42961               B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
42962      &                               LAMDA3(III,JJJ,KKK)
42963               B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42964      &                               LAMDA3(III,JJJ,KKK)
42965               B3MODE(2,K  ,N3MODE) = 0.0D0
42966               B3MODE(2,K+2,N3MODE) = 0.0D0
42967               B3MODE(2,K+4,N3MODE) = 0.0D0
42968               DO 72 J=1,2
42969               A3MODE(J,K  ,N3MODE) = AFG(O(J),2*III  ,K)
42970               A3MODE(J,K+2,N3MODE) = AFG(O(J),2*JJJ-1,K)
42971  72           A3MODE(J,K+4,N3MODE) = AFG(O(J),2*KKK-1,K)
42972             ENDIF
42973 C--unrecognized decay issue warning
42974           ELSE
42975             CALL HWWARN('HWISP3',1)
42976           ENDIF
42977         ELSEIF(IDK(I).GE.450.AND.IDK(I).LE.453) THEN
42978           L1 = IDK(I)-449
42979 C--neutralino modes next
42980           IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
42981      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42982 C--first the neutralino modes to fermion-antifermion neutralino
42983             IFR  = IDKPRD(2,I)
42984             J    = INT((IFR-1)/120)
42985             IFR  = IFR-6*INT((IFR-1)/6)+6*J
42986             IL   = IFR+4*J
42987             SIFR = IFR+18*J
42988             N3MODE = N3MODE+1
42989             IF(N3MODE.GT.NMODE3) THEN
42990               CALL HWWARN('HWISP3',109)
42991               GOTO 999
42992             ENDIF
42993             P3MODE(N3MODE) = ONE
42994             IF(IFR.LE.6) P3MODE(N3MODE)=THREE
42995             SPN3CF(1,1,N3MODE) = ONE
42996             N3NCFL(N3MODE) = 1
42997             ID3PRT(N3MODE) = I
42998             NME(I) = 10000+N3MODE
42999             NDI3BY(N3MODE) = 4
43000 C--sfermion exchange diagrams
43001             DO 4 K=1,2
43002             I3DRTP(K  ,N3MODE) = 3
43003             I3DRCF(K  ,N3MODE) = 1
43004             I3DRTP(K+2,N3MODE) = 4
43005             I3DRCF(K+2,N3MODE) = 1
43006             I3MODE(K  ,N3MODE) = 12*(K-1)+400+SIFR
43007             I3MODE(K+2,N3MODE) = 12*(K-1)+406+SIFR
43008             DO 4 J=1,2
43009             A3MODE(J,K  ,N3MODE) = AFN(  J ,IFR,K,L1)
43010             B3MODE(J,K  ,N3MODE) = AFN(O(J),IFR,K,L )
43011             A3MODE(J,K+2,N3MODE) = ZSGNSS(L1)*AFN(O(J),IFR,K,L1)
43012  4          B3MODE(J,K+2,N3MODE) = ZSGNSS(L )*AFN(  J ,IFR,K,L )
43013 C--now add higgs diagrams if third generation fermion, if Higgs off shell
43014             IF(IFR.EQ.5.OR.IFR.EQ.6.OR.IFR.EQ.11) THEN
43015               DO 5 J=1,3
43016                 IF(RMASS(IDK(I)).LT.
43017      &                RMASS(203+J)+RMASS(IDKPRD(1,I))) THEN
43018                   NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43019                   I3DRTP(  NDI3BY(N3MODE),N3MODE) = 2
43020                   I3DRCF(  NDI3BY(N3MODE),N3MODE) = 1
43021                   I3MODE(  NDI3BY(N3MODE),N3MODE) = 203+J
43022                   DO 6 K=1,2
43023                   A3MODE(K,NDI3BY(N3MODE),N3MODE) = HNN(K,J,L,L1)
43024  6                B3MODE(K,NDI3BY(N3MODE),N3MODE) = HFF(K,J,IFR)
43025                 ENDIF
43026  5            CONTINUE
43027             ENDIF
43028 C-- and gauge boson diagrams if Z not on-shell
43029             IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
43030               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43031               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43032               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43033               I3MODE(NDI3BY(N3MODE),N3MODE) = 200
43034               DO 7 J=1,2
43035  7            A3MODE(J,NDI3BY(N3MODE),N3MODE) =  OIJPP(J,L,L1)
43036               B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
43037               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
43038             ENDIF
43039           ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
43040      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43041 C--then  the neutralino modes to fermion-antifermion +ve chargino
43042 C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
43043             IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
43044             L = L-4
43045             N3MODE = N3MODE+1
43046             IF(N3MODE.GT.NMODE3) THEN
43047               CALL HWWARN('HWISP3',110)
43048               GOTO 999
43049             ENDIF
43050             ID3PRT(N3MODE) = I
43051             NME(I) = 10000+N3MODE
43052             NDI3BY(N3MODE) = 1
43053             P3MODE(N3MODE) = ONE
43054             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43055             SPN3CF(1,1,N3MODE) = ONE
43056             N3NCFL(N3MODE) = 1
43057 C--gauge boson diagram
43058             I3DRTP(1,N3MODE) = 1
43059             I3DRCF(1,N3MODE) = 1
43060             I3MODE(1,N3MODE) = 199
43061             DO 8 J=1,2
43062  8          A3MODE(J,1,N3MODE) = OIJ(J,L1,L)
43063             B3MODE(1,1,N3MODE) = ZERO
43064             B3MODE(2,1,N3MODE) = -G*ORT
43065           ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
43066      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43067 C--then  the neutralino modes to fermion-antifermion -ve chargino
43068 C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
43069             IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
43070             L = L-6
43071             N3MODE = N3MODE+1
43072             IF(N3MODE.GT.NMODE3) THEN
43073               CALL HWWARN('HWISP3',111)
43074               GOTO 999
43075             ENDIF
43076             ID3PRT(N3MODE) = I
43077             NME(I) = 10000+N3MODE
43078             NDI3BY(N3MODE) = 1
43079             P3MODE(N3MODE) = ONE
43080             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43081             SPN3CF(1,1,N3MODE) = ONE
43082             N3NCFL(N3MODE) = 1
43083 C--gauge boson diagram
43084             I3DRTP(1,N3MODE) = 1
43085             I3DRCF(1,N3MODE) = 1
43086             I3MODE(1,N3MODE) = 198
43087             DO 9 J=1,2
43088  9          A3MODE(J,1,N3MODE) =-OIJ(O(J),L1,L)
43089             B3MODE(1,1,N3MODE) = ZERO
43090             B3MODE(2,1,N3MODE) = -G*ORT
43091 C--gravitino E+e- modes
43092           ELSEIF(L.EQ.9.AND.(IDKPRD(2,I).LE.12.OR.
43093      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43094             IFR  = IDKPRD(2,I)
43095             J    = INT((IFR-1)/120)
43096             IFR  = IFR-6*INT((IFR-1)/6)+6*J
43097             IL   = IFR+4*J
43098             N3MODE = N3MODE+1
43099             IF(N3MODE.GT.NMODE3) THEN
43100               CALL HWWARN('HWISP3',112)
43101               GOTO 999
43102             ENDIF
43103             ID3PRT(N3MODE) = I
43104             NME(I) = 10000+N3MODE
43105             NDI3BY(N3MODE) = 1
43106             P3MODE(N3MODE) = ONE
43107             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43108             SPN3CF(1,1,N3MODE) = ONE
43109             N3NCFL(N3MODE) = 1
43110 C--diagram
43111             I3DRTP(1,N3MODE) = 7
43112             I3DRCF(1,N3MODE) = 1
43113             I3MODE(1,N3MODE) = 59
43114             A3MODE(1,1,N3MODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,1)
43115             A3MODE(2,1,N3MODE) = 0
43116             B3MODE(1,1,N3MODE) = -E*QFCH(IL)
43117             B3MODE(2,1,N3MODE) = -E*QFCH(IL)
43118 C--R-parity violating modes
43119 C--LLE modes
43120           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43121      &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
43122      &           IDKPRD(3,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
43123             N3MODE = N3MODE+1
43124             IF(N3MODE.GT.NMODE3) THEN
43125               CALL HWWARN('HWISP3',113)
43126               GOTO 999
43127             ENDIF
43128             ID3PRT(N3MODE) = I
43129             NME(I) = 10000+N3MODE
43130             NDI3BY(N3MODE) = 5
43131             P3MODE(N3MODE) = ONE
43132             SPN3CF(1,1,N3MODE) = ONE
43133             N3NCFL(N3MODE) = 1
43134 C--particle mode
43135             DO 53 J=1,6
43136  53         I3DRCF(J,N3MODE) = 1
43137             IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
43138               III = (IDKPRD(1,I)-119)/2
43139               JJJ = (IDKPRD(2,I)-120)/2
43140               KKK = (IDKPRD(3,I)-125)/2
43141               DO 51 J=1,2
43142               I3DRTP(J  ,N3MODE) = 2
43143               I3DRTP(J+2,N3MODE) = 4
43144               I3MODE(J  ,N3MODE) = 423+2*III+(J-1)*12
43145               I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
43146               B3MODE(1,J  ,N3MODE) = LMIXSS(2*III-1,1,J)*
43147      &             LAMDA1(III,JJJ,KKK)
43148               B3MODE(2,J  ,N3MODE) = 0.0D0
43149               B3MODE(1,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
43150      &             LAMDA1(III,JJJ,KKK)
43151               B3MODE(2,J+2,N3MODE) = 0.0D0
43152               DO 51 K=1,2
43153               A3MODE(K,J  ,N3MODE) = AFN(  K ,5+2*III,J,L1)
43154  51           A3MODE(K,J+2,N3MODE) = AFN(O(K),5+2*KKK,J,L1)
43155               DO 48 K=1,2
43156  48           A3MODE(K,5,N3MODE) = AFN(  K ,6+2*JJJ,1,L1)
43157               I3DRTP(5,N3MODE) = 3
43158               I3MODE(5,N3MODE) = 430+2*JJJ
43159               B3MODE(1,5,N3MODE) = LAMDA1(III,JJJ,KKK)
43160               B3MODE(2,5,N3MODE) = 0.0D0
43161 C--antiparticle mode
43162             ELSE
43163               III = (IDKPRD(1,I)-125)/2
43164               JJJ = (IDKPRD(2,I)-126)/2
43165               KKK = (IDKPRD(3,I)-119)/2
43166               DO 52 J=1,2
43167               I3DRTP(J  ,N3MODE) = 8
43168               I3DRTP(J+2,N3MODE) = 10
43169               I3MODE(J  ,N3MODE) = 423+2*III+(J-1)*12
43170               I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
43171               B3MODE(2,J  ,N3MODE) = LMIXSS(2*III-1,1,J)*
43172      &             LAMDA1(III,JJJ,KKK)
43173               B3MODE(1,J  ,N3MODE) = 0.0D0
43174               B3MODE(2,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
43175      &             LAMDA1(III,JJJ,KKK)
43176               B3MODE(1,J+2,N3MODE) = 0.0D0
43177               DO 52 K=1,2
43178               A3MODE(K,J  ,N3MODE) = AFN(O(K),5+2*III,J,L1)
43179  52           A3MODE(K,J+2,N3MODE) = AFN(  K ,5+2*KKK,J,L1)
43180               DO 49 K=1,2
43181  49           A3MODE(K,5,N3MODE) = AFN(O(K),6+2*JJJ,1,L1)
43182               I3DRTP(5,N3MODE) = 9
43183               I3MODE(5,N3MODE) = 430+2*JJJ
43184               B3MODE(2,5,N3MODE) = LAMDA1(III,JJJ,KKK)
43185               B3MODE(1,5,N3MODE) = 0.0D0
43186             ENDIF
43187 C--LQD modes
43188           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43189      &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
43190             N3MODE = N3MODE+1
43191             IF(N3MODE.GT.NMODE3) THEN
43192               CALL HWWARN('HWISP3',114)
43193               GOTO 999
43194             ENDIF
43195             ID3PRT(N3MODE) = I
43196             NME(I) = 10000+N3MODE
43197             P3MODE(N3MODE) = 3.0D0
43198             SPN3CF(1,1,N3MODE) = ONE
43199             N3NCFL(N3MODE) = 1
43200             DO 81 J=1,6
43201  81         I3DRCF(J,N3MODE) = 1
43202 C--first the neutrino mode
43203             IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
43204               NDI3BY(N3MODE) = 5
43205 C--particle mode
43206               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
43207                 III = (IDKPRD(1,I)-120)/2
43208                 JJJ = (IDKPRD(2,I)+1)/2
43209                 KKK = (IDKPRD(3,I)-5)/2
43210                 DO 82 K=1,2
43211                 I3DRTP(K  ,N3MODE) = 3
43212                 I3DRTP(K+2,N3MODE) = 4
43213                 I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
43214                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
43215                 B3MODE(2,K  ,N3MODE) = 0.0D0
43216                 B3MODE(1,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
43217      &                                 LAMDA2(III,JJJ,KKK)
43218                 B3MODE(2,K+2,N3MODE) = 0.0D0
43219                 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
43220      &                                 LAMDA2(III,JJJ,KKK)
43221                 DO 82 J=1,2
43222                 A3MODE(J,K  ,N3MODE) = AFN(  J ,2*JJJ-1,K,L1)
43223  82             A3MODE(J,K+2,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
43224                 I3DRTP(5,N3MODE) = 2
43225                 I3MODE(5,N3MODE) = 424+2*III
43226                 B3MODE(2,5,N3MODE) = 0.0D0
43227                 B3MODE(1,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
43228                 DO 83 J=1,2
43229  83             A3MODE(J,5,N3MODE) = AFN(J,6+2*III,1,L1)
43230 C--antiparticle mode
43231               ELSE
43232                 III = (IDKPRD(1,I)-126)/2
43233                 JJJ = (IDKPRD(2,I)-5)/2
43234                 KKK = (IDKPRD(3,I)+1)/2
43235                 DO 84 K=1,2
43236                 I3DRTP(K  ,N3MODE) = 9
43237                 I3DRTP(K+2,N3MODE) = 10
43238                 I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
43239                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
43240                 B3MODE(1,K  ,N3MODE) = 0.0D0
43241                 B3MODE(2,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
43242      &                                 LAMDA2(III,JJJ,KKK)
43243                 B3MODE(1,K+2,N3MODE) = 0.0D0
43244                 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
43245      &                                 LAMDA2(III,JJJ,KKK)
43246                 DO 84 J=1,2
43247                 A3MODE(J,K  ,N3MODE) = AFN(O(J),2*JJJ-1,K,L1)
43248  84             A3MODE(J,K+2,N3MODE) = AFN(  J ,2*KKK-1,K,L1)
43249                 I3DRTP(5,N3MODE) = 8
43250                 I3MODE(5,N3MODE) = 424+2*III
43251                 B3MODE(1,5,N3MODE) = 0.0D0
43252                 B3MODE(2,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
43253                 DO 85 J=1,2
43254  85             A3MODE(J,5,N3MODE) = AFN(O(J),6+2*III,1,L1)
43255               ENDIF
43256 C--then the charged lepton mode
43257             ELSE
43258               NDI3BY(N3MODE) = 6
43259 C--particle mode
43260               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
43261                 III = (IDKPRD(1,I)-119)/2
43262                 JJJ = IDKPRD(2,I)/2
43263                 KKK = (IDKPRD(3,I)-5)/2
43264                 DO 86 K=1,2
43265                 I3DRTP(K  ,N3MODE) = 2
43266                 I3DRTP(K+2,N3MODE) = 3
43267                 I3DRTP(K+4,N3MODE) = 4
43268                 I3MODE(K  ,N3MODE) = 423+2*III+(K-1)*12
43269                 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
43270                 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
43271                 B3MODE(2,K  ,N3MODE) = 0.0D0
43272                 B3MODE(1,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
43273      &                                 LAMDA2(III,JJJ,KKK)
43274                 B3MODE(2,K+2,N3MODE) = 0.0D0
43275                 B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
43276      &                                 LAMDA2(III,JJJ,KKK)
43277                 B3MODE(2,K+4,N3MODE) = 0.0D0
43278                 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
43279      &                                 LAMDA2(III,JJJ,KKK)
43280                 DO 86 J=1,2
43281                 A3MODE(J,K  ,N3MODE) = AFN(  J ,2*III+5,K,L1)
43282                 A3MODE(J,K+2,N3MODE) = AFN(  J ,2*JJJ  ,K,L1)
43283  86             A3MODE(J,K+4,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
43284 C--antiparticle mode
43285               ELSE
43286                 III = (IDKPRD(1,I)-125)/2
43287                 JJJ = (IDKPRD(2,I)-6)/2
43288                 KKK = (IDKPRD(3,I)+1)/2
43289                 DO 87 K=1,2
43290                 I3DRTP(K  ,N3MODE) = 8
43291                 I3DRTP(K+2,N3MODE) = 9
43292                 I3DRTP(K+4,N3MODE) = 10
43293                 I3MODE(K  ,N3MODE) = 423+2*III+(K-1)*12
43294                 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
43295                 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
43296                 B3MODE(1,K  ,N3MODE) = 0.0D0
43297                 B3MODE(2,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
43298      &                                 LAMDA2(III,JJJ,KKK)
43299                 B3MODE(1,K+2,N3MODE) = 0.0D0
43300                 B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
43301      &                                 LAMDA2(III,JJJ,KKK)
43302                 B3MODE(1,K+4,N3MODE) = 0.0D0
43303                 B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
43304      &                                 LAMDA2(III,JJJ,KKK)
43305                 DO 87 J=1,2
43306                 A3MODE(J,K  ,N3MODE) = AFN(O(J),2*III+5,K,L1)
43307                 A3MODE(J,K+2,N3MODE) = AFN(O(J),2*JJJ  ,K,L1)
43308  87             A3MODE(J,K+4,N3MODE) = AFN(  J ,2*KKK-1,K,L1)
43309               ENDIF
43310             ENDIF
43311 C--UDD modes
43312           ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
43313      &           IDKPRD(3,I).LE.12) THEN
43314             N3MODE = N3MODE+1
43315             IF(N3MODE.GT.NMODE3) THEN
43316               CALL HWWARN('HWISP3',115)
43317               GOTO 999
43318             ENDIF
43319             ID3PRT(N3MODE) = I
43320             NME(I) = 10000+N3MODE
43321             NDI3BY(N3MODE) = 6
43322             P3MODE(N3MODE) = 6.0D0
43323             SPN3CF(1,1,N3MODE) = ONE
43324             N3NCFL(N3MODE) = 1
43325             DO 61 J=1,6
43326  61         I3DRCF(J,N3MODE) = 1
43327 C--particle mode
43328             IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
43329               III = IDKPRD(1,I)/2
43330               JJJ = (IDKPRD(2,I)+1)/2
43331               KKK = (IDKPRD(3,I)+1)/2
43332               DO 62 J=1,2
43333               I3DRTP(J  ,N3MODE) = 11
43334               I3DRTP(J+2,N3MODE) = 12
43335               I3DRTP(J+4,N3MODE) = 13
43336               I3MODE(J  ,N3MODE) = 400+2*III+(J-1)*12
43337               I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
43338               I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
43339               B3MODE(2,J  ,N3MODE) = QMIXSS(2*III,2,J)*
43340      &                               LAMDA3(III,JJJ,KKK)
43341               B3MODE(2,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
43342      &                               LAMDA3(III,JJJ,KKK)
43343               B3MODE(2,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
43344      &                               LAMDA3(III,JJJ,KKK)
43345               B3MODE(1,J  ,N3MODE) = 0.0D0
43346               B3MODE(1,J+2,N3MODE) = 0.0D0
43347               B3MODE(1,J+4,N3MODE) = 0.0D0
43348               DO 62 K=1,2
43349               A3MODE(K,J  ,N3MODE) = AFN(K,2*III  ,J,L1)
43350               A3MODE(K,J+2,N3MODE) = AFN(K,2*JJJ-1,J,L1)
43351  62           A3MODE(K,J+4,N3MODE) = AFN(K,2*KKK-1,J,L1)
43352 C--antiparticle mode
43353             ELSE
43354               III = (IDKPRD(1,I)-6)/2
43355               JJJ = (IDKPRD(2,I)-5)/2
43356               KKK = (IDKPRD(3,I)-5)/2
43357               DO 63 J=1,2
43358               I3DRTP(J  ,N3MODE) = 14
43359               I3DRTP(J+2,N3MODE) = 15
43360               I3DRTP(J+4,N3MODE) = 16
43361               I3MODE(J  ,N3MODE) = 400+2*III+(J-1)*12
43362               I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
43363               I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
43364               B3MODE(2,J  ,N3MODE) = 0.0D0
43365               B3MODE(2,J+2,N3MODE) = 0.0D0
43366               B3MODE(2,J+4,N3MODE) = 0.0D0
43367               B3MODE(1,J  ,N3MODE) = QMIXSS(2*III,2,J)*
43368      &                               LAMDA3(III,JJJ,KKK)
43369               B3MODE(1,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
43370      &                               LAMDA3(III,JJJ,KKK)
43371               B3MODE(1,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
43372      &                               LAMDA3(III,JJJ,KKK)
43373               DO 63 K=1,2
43374               A3MODE(K,J  ,N3MODE) = AFN(O(K),2*III  ,J,L1)
43375               A3MODE(K,J+2,N3MODE) = AFN(O(K),2*JJJ-1,J,L1)
43376  63           A3MODE(K,J+4,N3MODE) = AFN(O(K),2*KKK-1,J,L1)
43377             ENDIF
43378 C--unrecognized decay issue warning
43379           ELSE
43380             CALL HWWARN('HWISP3',2)
43381           ENDIF
43382         ELSEIF(IDK(I).GE.454.AND.IDK(I).LE.455) THEN
43383 C--+ve chargino modes
43384 C--first the chargino modes to fermion-antifermion neutralino
43385           IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
43386      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43387             IFR = IDKPRD(2,I)
43388             IFR = IFR+MOD(IFR,2)
43389             J    = INT((IFR-1)/120)
43390             IFR  = IFR-6*INT((IFR-1)/6)+6*J
43391             IL   = IFR+4*J
43392             SIFR = IFR+18*J
43393             L1 = IDK(I)-453
43394             N3MODE = N3MODE+1
43395             IF(N3MODE.GT.NMODE3) THEN
43396               CALL HWWARN('HWISP3',116)
43397               GOTO 999
43398             ENDIF
43399             ID3PRT(N3MODE) = I
43400             NME(I) = 10000+N3MODE
43401             NDI3BY(N3MODE) = 4
43402             P3MODE(N3MODE) = ONE
43403             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43404             SPN3CF(1,1,N3MODE) = ONE
43405             N3NCFL(N3MODE) = 1
43406 C--sfermion exchange diagrams
43407             DO 10 K=1,2
43408             I3DRTP(K  ,N3MODE) = 3
43409             I3DRCF(K  ,N3MODE) = 1
43410             I3DRTP(K+2,N3MODE) = 4
43411             I3DRCF(K+2,N3MODE) = 1
43412             I3MODE(K  ,N3MODE) = 12*(K-1)+405+SIFR
43413             I3MODE(K+2,N3MODE) = 12*(K-1)+400+SIFR
43414             DO 10 J=1,2
43415             A3MODE(J,K  ,N3MODE) = AFC(  J ,IFR-1,K,L1)
43416             B3MODE(J,K  ,N3MODE) = AFN(O(J),IFR-1,K,L )
43417             A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR  ,K,L1)
43418  10         B3MODE(J,K+2,N3MODE) = AFN(  J ,IFR  ,K,L )
43419 C--gauge boson diagram
43420             IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
43421               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43422               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43423               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43424               I3MODE(NDI3BY(N3MODE),N3MODE) = 198
43425               DO 11 J=1,2
43426  11           A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJ(J,L,L1)
43427               B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
43428               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
43429             ENDIF
43430 C--then  the chargino modes to fermion-antifermion chargino
43431           ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
43432      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43433             L = L-4
43434             IFR = IDKPRD(2,I)
43435             J    = INT((IFR-1)/120)
43436             IFR  = IFR-6*INT((IFR-1)/6)+6*J
43437             IL   = IFR+4*J
43438             SIFR = IFR+18*J
43439             IF(MOD(IFR,2).EQ.0) THEN
43440               IFR = IFR-1
43441               SIFR = SIFR-1
43442             ELSE
43443               IFR = IFR+1
43444               SIFR = SIFR+1
43445             ENDIF
43446             L1 = IDK(I)-453
43447             N3MODE = N3MODE+1
43448             IF(N3MODE.GT.NMODE3) THEN
43449               CALL HWWARN('HWISP3',117)
43450               GOTO 999
43451             ENDIF
43452             ID3PRT(N3MODE) = I
43453             NME(I) = 10000+N3MODE
43454             NDI3BY(N3MODE) = 2
43455             P3MODE(N3MODE) = ONE
43456             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43457             SPN3CF(1,1,N3MODE) = ONE
43458             N3NCFL(N3MODE) = 1
43459 C--sfermion exchange diagrams
43460             IF(MOD(IL,2).EQ.0) THEN
43461               DO 12 K=1,2
43462               I3DRTP(K,N3MODE) = 3
43463               I3DRCF(K,N3MODE) = 1
43464               I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
43465               DO 12 J=1,2
43466               A3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L1)
43467  12           B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
43468             ELSE
43469               DO 13 K=1,2
43470               I3DRTP(K,N3MODE) = 4
43471               I3DRCF(K,N3MODE) = 1
43472               I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
43473               DO 13 J=1,2
43474               A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
43475  13           B3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L )
43476             ENDIF
43477 C--gauge boson diagram
43478             IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
43479               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43480               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43481               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43482               I3MODE(NDI3BY(N3MODE),N3MODE) = 200
43483               DO 14 J=1,2
43484  14           A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJP(J,L,L1)
43485               B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
43486               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
43487             ENDIF
43488 C--R-parity violating decays
43489 C--LLE first
43490           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43491      &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
43492      &           IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
43493             L1 = IDK(I)-453
43494 C--neutrino lepton neutrino
43495             IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
43496      &         MOD(IDKPRD(3,I),2).EQ.0) THEN
43497               N3MODE = N3MODE+1
43498               IF(N3MODE.GT.NMODE3) THEN
43499                 CALL HWWARN('HWISP3',118)
43500                 GOTO 999
43501               ENDIF
43502               ID3PRT(N3MODE) = I
43503               NME(I) = 10000+N3MODE
43504               NDI3BY(N3MODE) = 2
43505               P3MODE(N3MODE) = ONE
43506               N3NCFL(N3MODE) = 1
43507               SPN3CF(1,1,N3MODE) = ONE
43508               III = (IDKPRD(1,I)-126)/2
43509               JJJ = (IDKPRD(2,I)-125)/2
43510               KKK = (IDKPRD(3,I)-120)/2
43511               DO 54 K=1,2
43512               I3DRTP(K,N3MODE) = 10
43513               I3DRCF(K,N3MODE) = 1
43514               I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
43515               B3MODE(1,K,N3MODE) = 0.0D0
43516               B3MODE(2,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
43517               DO 54 J=1,2
43518  54           A3MODE(J,K,N3MODE) = AFC(J,5+2*KKK,K,L1)
43519 C--neutrino neutrino lepton
43520             ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
43521      &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43522               N3MODE = N3MODE+1
43523               IF(N3MODE.GT.NMODE3) THEN
43524                 CALL HWWARN('HWISP3',119)
43525                 GOTO 999
43526               ENDIF
43527               ID3PRT(N3MODE) = I
43528               NME(I) = 10000+N3MODE
43529               NDI3BY(N3MODE) = 4
43530               P3MODE(N3MODE) = ONE
43531               N3NCFL(N3MODE) = 1
43532               SPN3CF(1,1,N3MODE) = ONE
43533               III = (IDKPRD(1,I)-120)/2
43534               JJJ = (IDKPRD(2,I)-120)/2
43535               KKK = (IDKPRD(3,I)-125)/2
43536               DO 55 K=1,2
43537               I3DRTP(K  ,N3MODE) = 2
43538               I3DRTP(K+2,N3MODE) = 3
43539               I3DRCF(K  ,N3MODE) = 1
43540               I3DRCF(K+2,N3MODE) = 1
43541               I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
43542               I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
43543               B3MODE(1,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
43544      &             LMIXSS(2*III-1,1,K)
43545               B3MODE(2,K,N3MODE) = 0.0D0
43546               B3MODE(1,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
43547      &             LMIXSS(2*JJJ-1,1,K)
43548               B3MODE(2,K+2,N3MODE) = 0.0D0
43549               DO 55 J=1,2
43550               A3MODE(J,K,N3MODE)   = AFC(J,5+2*III,K,L1)
43551  55           A3MODE(J,K+2,N3MODE) = AFC(J,5+2*JJJ,K,L1)
43552 C--lepton lepton lepton
43553             ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
43554      &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43555               N3MODE = N3MODE+1
43556               IF(N3MODE.GT.NMODE3) THEN
43557                 CALL HWWARN('HWISP3',120)
43558                 GOTO 999
43559               ENDIF
43560               ID3PRT(N3MODE) = I
43561               NME(I) = 10000+N3MODE
43562               NDI3BY(N3MODE) = 2
43563               P3MODE(N3MODE) = ONE
43564               N3NCFL(N3MODE) = 1
43565               SPN3CF(1,1,N3MODE) = ONE
43566               III = (IDKPRD(1,I)-125)/2
43567               JJJ = (IDKPRD(2,I)-125)/2
43568               KKK = (IDKPRD(3,I)-119)/2
43569               I3DRTP(1,N3MODE) = 8
43570               I3DRTP(2,N3MODE) = 9
43571               I3DRCF(1,N3MODE) = 1
43572               I3DRCF(2,N3MODE) = 1
43573               I3MODE(1,N3MODE) = 424+2*III
43574               I3MODE(2,N3MODE) = 424+2*JJJ
43575               B3MODE(1,1,N3MODE) = 0.0D0
43576               B3MODE(2,1,N3MODE) = LAMDA1(III,JJJ,KKK)
43577               B3MODE(1,2,N3MODE) = 0.0D0
43578               B3MODE(2,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
43579               DO 56 J=1,2
43580               A3MODE(J,1,N3MODE) = AFC(O(J),6+2*III,1,L1)
43581  56           A3MODE(J,2,N3MODE) = AFC(O(J),6+2*JJJ,1,L1)
43582             ELSE
43583               CALL HWWARN('HWISP3',3)
43584             ENDIF
43585 C--LQD decays
43586           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43587      &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
43588             L1 = IDK(I)-453
43589 C--nubar dbar u
43590             IF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
43591               N3MODE = N3MODE+1
43592               IF(N3MODE.GT.NMODE3) THEN
43593                 CALL HWWARN('HWISP3',121)
43594                 GOTO 999
43595               ENDIF
43596               ID3PRT(N3MODE) = I
43597               NME(I) = 10000+N3MODE
43598               NDI3BY(N3MODE) = 2
43599               P3MODE(N3MODE) = THREE
43600               N3NCFL(N3MODE) = 1
43601               SPN3CF(1,1,N3MODE) = ONE
43602               III = (IDKPRD(1,I)-126)/2
43603               JJJ = (IDKPRD(2,I)-5)/2
43604               KKK = IDKPRD(3,I)/2
43605               DO 88 K=1,2
43606               I3DRTP(K,N3MODE) = 10
43607               I3DRCF(K,N3MODE) = 1
43608               I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
43609               B3MODE(1,K,N3MODE) = 0.0D0
43610               B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
43611      &                             LAMDA2(III,JJJ,KKK)
43612               DO 88 J=1,2
43613  88           A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
43614 C--l+ ubar u
43615             ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
43616      &             MOD(IDKPRD(2,I),2).EQ.0) THEN
43617               N3MODE = N3MODE+1
43618               IF(N3MODE.GT.NMODE3) THEN
43619                 CALL HWWARN('HWISP3',122)
43620                 GOTO 999
43621               ENDIF
43622               ID3PRT(N3MODE) = I
43623               NME(I) = 10000+N3MODE
43624               NDI3BY(N3MODE) = 2
43625               P3MODE(N3MODE) = THREE
43626               N3NCFL(N3MODE) = 1
43627               SPN3CF(1,1,N3MODE) = ONE
43628               III = (IDKPRD(1,I)-125)/2
43629               JJJ = (IDKPRD(2,I)-6)/2
43630               KKK = IDKPRD(3,I)/2
43631               DO 89 K=1,2
43632               I3DRTP(K,N3MODE) = 10
43633               I3DRCF(K,N3MODE) = 1
43634               I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
43635               B3MODE(1,K,N3MODE) = 0.0D0
43636               B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
43637      &                             LAMDA2(III,JJJ,KKK)
43638               DO 89 J=1,2
43639  89           A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
43640 C--l+ dbar d
43641             ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
43642      &             MOD(IDKPRD(2,I),2).EQ.1) THEN
43643               N3MODE = N3MODE+1
43644               IF(N3MODE.GT.NMODE3) THEN
43645                 CALL HWWARN('HWISP3',123)
43646                 GOTO 999
43647               ENDIF
43648               ID3PRT(N3MODE) = I
43649               NME(I) = 10000+N3MODE
43650               NDI3BY(N3MODE) = 3
43651               P3MODE(N3MODE) = THREE
43652               N3NCFL(N3MODE) = 1
43653               SPN3CF(1,1,N3MODE) = ONE
43654               III = (IDKPRD(1,I)-125)/2
43655               JJJ = (IDKPRD(2,I)-5)/2
43656               KKK = (IDKPRD(3,I)+1)/2
43657               I3DRTP(1,N3MODE) = 8
43658               I3DRCF(1,N3MODE) = 1
43659               I3MODE(1,N3MODE) = 424+2*III
43660               B3MODE(1,1,N3MODE) = 0.0D0
43661               B3MODE(2,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
43662               DO 91 J=1,2
43663  91           A3MODE(J,1,N3MODE) = AFC(O(J),2*III+6,1,L1)
43664               DO 92 K=1,2
43665               I3DRTP(K+1,N3MODE) = 9
43666               I3DRCF(K+1,N3MODE) = 1
43667               I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
43668               B3MODE(1,K+1,N3MODE) = 0.0D0
43669               B3MODE(2,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
43670      &                               LAMDA2(III,JJJ,KKK)
43671               DO 92 J=1,2
43672  92           A3MODE(J,K+1,N3MODE) = AFC(O(J),2*JJJ,K,L1)
43673 C--nu u dbar
43674             ELSEIF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
43675               N3MODE = N3MODE+1
43676               IF(N3MODE.GT.NMODE3) THEN
43677                 CALL HWWARN('HWISP3',124)
43678                 GOTO 999
43679               ENDIF
43680               ID3PRT(N3MODE) = I
43681               NME(I) = 10000+N3MODE
43682               NDI3BY(N3MODE) = 4
43683               P3MODE(N3MODE) = THREE
43684               N3NCFL(N3MODE) = 1
43685               SPN3CF(1,1,N3MODE) = ONE
43686               III = (IDKPRD(1,I)-120)/2
43687               JJJ = IDKPRD(2,I)/2
43688               KKK = (IDKPRD(3,I)-5)/2
43689               DO 90 K=1,2
43690               I3DRTP(K  ,N3MODE) = 2
43691               I3DRTP(K+2,N3MODE) = 3
43692               I3DRCF(K  ,N3MODE) = 1
43693               I3DRCF(K+2,N3MODE) = 1
43694               I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
43695               I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
43696               B3MODE(1,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
43697      &                               LAMDA2(III,JJJ,KKK)
43698               B3MODE(2,K  ,N3MODE) = 0.0D0
43699               B3MODE(1,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
43700      &                               LAMDA2(III,JJJ,KKK)
43701               B3MODE(2,K+2,N3MODE) = 0.0D0
43702               DO 90 J=1,2
43703               A3MODE(J,K  ,N3MODE) = AFC(J,2*III+5,K,L1)
43704  90           A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
43705 C--unrecognised
43706             ELSE
43707               CALL HWWARN('HWISP3',4)
43708             ENDIF
43709 C--UDD decays
43710           ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
43711      &           IDKPRD(3,I).LE.12) THEN
43712              L1 = IDK(I)-453
43713 C--dbar dbar dbar mode
43714             IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
43715      &         MOD(IDKPRD(3,I),2).EQ.1) THEN
43716               N3MODE = N3MODE+1
43717               IF(N3MODE.GT.NMODE3) THEN
43718                 CALL HWWARN('HWISP3',125)
43719                 GOTO 999
43720               ENDIF
43721               ID3PRT(N3MODE) = I
43722               NME(I) = 10000+N3MODE
43723               NDI3BY(N3MODE) = 6
43724               N3NCFL(N3MODE) = 1
43725               SPN3CF(1,1,N3MODE) = ONE
43726               III = (IDKPRD(1,I)-5)/2
43727               JJJ = (IDKPRD(2,I)-5)/2
43728               KKK = (IDKPRD(3,I)-5)/2
43729               P3MODE(N3MODE) = ONE
43730               IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
43731               IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
43732               IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
43733               P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
43734               DO 66 K=1,6
43735  66           I3DRCF(K,N3MODE) = 1
43736               DO 65 K=1,2
43737               I3DRTP(K  ,N3MODE) = 14
43738               I3DRTP(K+2,N3MODE) = 15
43739               I3DRTP(K+4,N3MODE) = 16
43740               I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
43741               I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
43742               I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
43743               B3MODE(1,K  ,N3MODE) = QMIXSS(2*III,2,K)*
43744      &                               LAMDA3(III,JJJ,KKK)
43745               B3MODE(2,K  ,N3MODE) = 0.0D0
43746               B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
43747      &                               LAMDA3(JJJ,III,KKK)
43748               B3MODE(2,K+2,N3MODE) = 0.0D0
43749               B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
43750      &                               LAMDA3(KKK,III,JJJ)
43751               B3MODE(2,K+4,N3MODE) = 0.0D0
43752               DO 65 J=1,2
43753               A3MODE(J,K  ,N3MODE) = AFC(O(J),2*III,K,L1)
43754               A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ,K,L1)
43755  65           A3MODE(J,K+4,N3MODE) = AFC(O(J),2*KKK,K,L1)
43756 C--u u d mode
43757             ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
43758      &              .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43759               N3MODE = N3MODE+1
43760               IF(N3MODE.GT.NMODE3) THEN
43761                 CALL HWWARN('HWISP3',126)
43762                 GOTO 999
43763               ENDIF
43764               ID3PRT(N3MODE) = I
43765               NME(I) = 10000+N3MODE
43766               NDI3BY(N3MODE) = 4
43767               P3MODE(N3MODE) = 6.0D0
43768               N3NCFL(N3MODE) = 1
43769               SPN3CF(1,1,N3MODE) = ONE
43770               III = IDKPRD(1,I)/2
43771               JJJ = IDKPRD(2,I)/2
43772               KKK = (IDKPRD(3,I)+1)/2
43773               IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
43774               DO 64 K=1,2
43775               I3DRTP(K  ,N3MODE) = 11
43776               I3DRTP(K+2,N3MODE) = 12
43777               I3DRCF(K  ,N3MODE) = 1
43778               I3DRCF(K+2,N3MODE) = 1
43779               I3MODE(K  ,N3MODE) = 399+2*III+(K-1)*12
43780               I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
43781               B3MODE(1,K  ,N3MODE) = 0.0D0
43782               B3MODE(2,K  ,N3MODE) = QMIXSS(2*III-1,2,K)*
43783      &                               LAMDA3(JJJ,III,KKK)
43784 c              B3MODE(2,K,N3MODE) = 0.0D0
43785               B3MODE(1,K+2,N3MODE) = 0.0D0
43786               B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
43787      &                               LAMDA3(III,JJJ,KKK)
43788               DO 64 J=1,2
43789               A3MODE(J,K  ,N3MODE) = AFC(J,2*III-1,K,L1)
43790  64           A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
43791 C--unrecognized decay issue warning
43792             ELSE
43793               CALL HWWARN('HWISP3',5)
43794             ENDIF
43795 C--unrecognized decay issue warning
43796           ELSE
43797             CALL HWWARN('HWISP3',6)
43798           ENDIF
43799         ELSEIF(IDK(I).GE.456.AND.IDK(I).LE.457) THEN
43800 C-- -ve chargino modes last
43801 C--first the chargino modes to fermion-antifermion neutralino
43802           IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
43803      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43804             IFR = IDKPRD(2,I)
43805             IFR = IFR+MOD(IFR,2)
43806             J    = INT((IFR-1)/120)
43807             IFR  = IFR-6*INT((IFR-1)/6)+6*J
43808             IL   = IFR+4*J
43809             SIFR = IFR+18*J
43810             L1 = IDK(I)-455
43811             N3MODE = N3MODE+1
43812             IF(N3MODE.GT.NMODE3) THEN
43813               CALL HWWARN('HWISP3',127)
43814               GOTO 999
43815             ENDIF
43816             ID3PRT(N3MODE) = I
43817             NME(I) = 10000+N3MODE
43818             NDI3BY(N3MODE) = 4
43819             P3MODE(N3MODE) = ONE
43820             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43821             SPN3CF(1,1,N3MODE) = ONE
43822             N3NCFL(N3MODE) = 1
43823 C--sfermion exchange diagrams
43824             DO 15 K=1,2
43825             I3DRTP(K  ,N3MODE) = 3
43826             I3DRCF(K  ,N3MODE) = 1
43827             I3DRTP(K+2,N3MODE) = 4
43828             I3DRCF(K+2,N3MODE) = 1
43829             I3MODE(K  ,N3MODE) = 12*(K-1)+406+SIFR
43830             I3MODE(K+2,N3MODE) = 12*(K-1)+399+SIFR
43831             DO 15 J=1,2
43832             A3MODE(J,K  ,N3MODE) = AFC(  J ,IFR  ,K,L1)
43833             B3MODE(J,K  ,N3MODE) = AFN(O(J),IFR  ,K,L )
43834             A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR-1,K,L1)
43835  15         B3MODE(J,K+2,N3MODE) = AFN(  J ,IFR-1,K,L )
43836 C--gauge boson diagram
43837             IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
43838               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43839               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43840               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43841               I3MODE(NDI3BY(N3MODE),N3MODE) = 199
43842               DO 16 J=1,2
43843  16           A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJ(O(J),L,L1)
43844               B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
43845               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
43846             ENDIF
43847 C--then  the chargino modes to fermion-antifermion chargino
43848           ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
43849      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43850             L = L-6
43851             IFR = IDKPRD(2,I)
43852             J    = INT((IFR-1)/120)
43853             IFR  = IFR-6*INT((IFR-1)/6)+6*J
43854             IL   = IFR+4*J
43855             SIFR = IFR+18*J
43856             IF(MOD(IFR,2).EQ.0) THEN
43857               IFR = IFR-1
43858               SIFR = SIFR-1
43859             ELSE
43860               IFR = IFR+1
43861               SIFR = SIFR+1
43862             ENDIF
43863             L1 = IDK(I)-455
43864             N3MODE = N3MODE+1
43865             IF(N3MODE.GT.NMODE3) THEN
43866               CALL HWWARN('HWISP3',128)
43867               GOTO 999
43868             ENDIF
43869             ID3PRT(N3MODE) = I
43870             NME(I) = 10000+N3MODE
43871             NDI3BY(N3MODE) = 2
43872             P3MODE(N3MODE) = ONE
43873             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43874             SPN3CF(1,1,N3MODE) = ONE
43875             N3NCFL(N3MODE) = 1
43876 C--sfermion exchange diagrams
43877             IF(MOD(IL,2).EQ.0) THEN
43878               DO 17 K=1,2
43879               I3DRTP(K,N3MODE) = 4
43880               I3DRCF(K,N3MODE) = 1
43881               I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
43882               DO 17 J=1,2
43883               A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
43884  17           B3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L )
43885             ELSE
43886               DO 18 K=1,2
43887               I3DRTP(K,N3MODE) = 3
43888               I3DRCF(K,N3MODE) = 1
43889               I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
43890               DO 18 J=1,2
43891               A3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L1)
43892  18           B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
43893             ENDIF
43894 C--gauge boson diagram
43895             IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
43896               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43897               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43898               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43899               I3MODE(NDI3BY(N3MODE),N3MODE) = 200
43900               DO 19 J=1,2
43901  19           A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJP(O(J),L,L1)
43902               B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
43903               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
43904             ENDIF
43905 C--R-parity violating decays
43906 C--LLE first
43907           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43908      &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
43909      &           IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
43910              L1 = IDK(I)-455
43911 C--neutrino lepton neutrino
43912             IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
43913      &         MOD(IDKPRD(3,I),2).EQ.0) THEN
43914               N3MODE = N3MODE+1
43915               IF(N3MODE.GT.NMODE3) THEN
43916                 CALL HWWARN('HWISP3',129)
43917                 GOTO 999
43918               ENDIF
43919               ID3PRT(N3MODE) = I
43920               NME(I) = 10000+N3MODE
43921               NDI3BY(N3MODE) = 2
43922               P3MODE(N3MODE) = ONE
43923               N3NCFL(N3MODE) = 1
43924               SPN3CF(1,1,N3MODE) = ONE
43925               III = (IDKPRD(1,I)-120)/2
43926               JJJ = (IDKPRD(2,I)-119)/2
43927               KKK = (IDKPRD(3,I)-126)/2
43928               DO 57 K=1,2
43929               I3DRTP(K,N3MODE) = 4
43930               I3DRCF(K,N3MODE) = 1
43931               I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
43932               B3MODE(2,K,N3MODE) = 0.0D0
43933               B3MODE(1,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
43934               DO 57 J=1,2
43935  57           A3MODE(J,K,N3MODE) = AFC(O(J),5+2*KKK,K,L1)
43936 C--neutrino neutrino lepton
43937             ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
43938      &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43939               N3MODE = N3MODE+1
43940               IF(N3MODE.GT.NMODE3) THEN
43941                 CALL HWWARN('HWISP3',130)
43942                 GOTO 999
43943               ENDIF
43944               ID3PRT(N3MODE) = I
43945               NME(I) = 10000+N3MODE
43946               NDI3BY(N3MODE) = 4
43947               P3MODE(N3MODE) = ONE
43948               N3NCFL(N3MODE) = 1
43949               SPN3CF(1,1,N3MODE) = ONE
43950               III = (IDKPRD(1,I)-126)/2
43951               JJJ = (IDKPRD(2,I)-126)/2
43952               KKK = (IDKPRD(3,I)-119)/2
43953               DO 58 K=1,2
43954               I3DRTP(K  ,N3MODE) = 8
43955               I3DRTP(K+2,N3MODE) = 9
43956               I3DRCF(K  ,N3MODE) = 1
43957               I3DRCF(K+2,N3MODE) = 1
43958               I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
43959               I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
43960               B3MODE(2,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
43961      &             LMIXSS(2*III-1,1,K)
43962               B3MODE(1,K,N3MODE) = 0.0D0
43963               B3MODE(2,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
43964      &             LMIXSS(2*JJJ-1,1,K)
43965               B3MODE(1,K+2,N3MODE) = 0.0D0
43966               DO 58 J=1,2
43967               A3MODE(J,K,N3MODE)   = AFC(O(J),5+2*III,K,L1)
43968  58           A3MODE(J,K+2,N3MODE) = AFC(O(J),5+2*JJJ,K,L1)
43969 C--lepton lepton lepton
43970             ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
43971      &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43972               N3MODE = N3MODE+1
43973               IF(N3MODE.GT.NMODE3) THEN
43974                 CALL HWWARN('HWISP3',131)
43975                 GOTO 999
43976               ENDIF
43977               ID3PRT(N3MODE) = I
43978               NME(I) = 10000+N3MODE
43979               NDI3BY(N3MODE) = 2
43980               P3MODE(N3MODE) = ONE
43981               N3NCFL(N3MODE) = 1
43982               SPN3CF(1,1,N3MODE) = ONE
43983               III = (IDKPRD(1,I)-119)/2
43984               JJJ = (IDKPRD(2,I)-119)/2
43985               KKK = (IDKPRD(3,I)-125)/2
43986               I3DRTP(1,N3MODE) = 2
43987               I3DRTP(2,N3MODE) = 3
43988               I3DRCF(1,N3MODE) = 1
43989               I3DRCF(2,N3MODE) = 1
43990               I3MODE(1,N3MODE) = 424+2*III
43991               I3MODE(2,N3MODE) = 424+2*JJJ
43992               B3MODE(1,1,N3MODE) = LAMDA1(III,JJJ,KKK)
43993               B3MODE(2,1,N3MODE) = 0.0D0
43994               B3MODE(1,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
43995               B3MODE(2,2,N3MODE) = 0.0D0
43996               DO 59 J=1,2
43997               A3MODE(J,1,N3MODE) = AFC(J,6+2*III,1,L1)
43998  59           A3MODE(J,2,N3MODE) = AFC(J,6+2*JJJ,1,L1)
43999             ELSE
44000               CALL HWWARN('HWISP3',7)
44001             ENDIF
44002 C--LQD decays
44003           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
44004      &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
44005             L1 = IDK(I)-455
44006 C--nu d ubar
44007             IF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
44008               N3MODE = N3MODE+1
44009               IF(N3MODE.GT.NMODE3) THEN
44010                 CALL HWWARN('HWISP3',132)
44011                 GOTO 999
44012               ENDIF
44013               ID3PRT(N3MODE) = I
44014               NME(I) = 10000+N3MODE
44015               NDI3BY(N3MODE) = 2
44016               P3MODE(N3MODE) = THREE
44017               N3NCFL(N3MODE) = 1
44018               SPN3CF(1,1,N3MODE) = ONE
44019               III = (IDKPRD(1,I)-120)/2
44020               JJJ = (IDKPRD(2,I)+1)/2
44021               KKK = (IDKPRD(3,I)-6)/2
44022               DO 93 K=1,2
44023               I3DRTP(K,N3MODE) = 4
44024               I3DRCF(K,N3MODE) = 1
44025               I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
44026               B3MODE(2,K,N3MODE) = 0.0D0
44027               B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
44028      &                             LAMDA2(III,JJJ,KKK)
44029               DO 93 J=1,2
44030  93           A3MODE(J,K,N3MODE) = AFC(O(J),2*KKK-1,K,L1)
44031 C--l- u ubar
44032             ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
44033      &             MOD(IDKPRD(2,I),2).EQ.0) THEN
44034               N3MODE = N3MODE+1
44035               IF(N3MODE.GT.NMODE3) THEN
44036                 CALL HWWARN('HWISP3',133)
44037                 GOTO 999
44038               ENDIF
44039               ID3PRT(N3MODE) = I
44040               NME(I) = 10000+N3MODE
44041               NDI3BY(N3MODE) = 2
44042               P3MODE(N3MODE) = THREE
44043               N3NCFL(N3MODE) = 1
44044               SPN3CF(1,1,N3MODE) = ONE
44045               III = (IDKPRD(1,I)-119)/2
44046               JJJ = IDKPRD(2,I)/2
44047               KKK = (IDKPRD(3,I)-6)/2
44048               DO 94 K=1,2
44049               I3DRTP(K,N3MODE) = 4
44050               I3DRCF(K,N3MODE) = 1
44051               I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
44052               B3MODE(2,K,N3MODE) = 0.0D0
44053               B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
44054      &                             LAMDA2(III,JJJ,KKK)
44055               DO 94 J=1,2
44056  94           A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
44057 C--l- d dbar
44058             ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
44059      &             MOD(IDKPRD(2,I),2).EQ.1) THEN
44060               N3MODE = N3MODE+1
44061               IF(N3MODE.GT.NMODE3) THEN
44062                 CALL HWWARN('HWISP3',134)
44063                 GOTO 999
44064               ENDIF
44065               ID3PRT(N3MODE) = I
44066               NME(I) = 10000+N3MODE
44067               NDI3BY(N3MODE) = 3
44068               P3MODE(N3MODE) = THREE
44069               N3NCFL(N3MODE) = 1
44070               SPN3CF(1,1,N3MODE) = ONE
44071               III = (IDKPRD(1,I)-119)/2
44072               JJJ = (IDKPRD(2,I)+1)/2
44073               KKK = (IDKPRD(3,I)-5)/2
44074               I3DRTP(1,N3MODE) = 2
44075               I3DRCF(1,N3MODE) = 1
44076               I3MODE(1,N3MODE) = 424+2*III
44077               B3MODE(2,1,N3MODE) = 0.0D0
44078               B3MODE(1,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
44079               DO 95 J=1,2
44080  95           A3MODE(J,1,N3MODE) = AFC(J,2*III+6,1,L1)
44081               DO 96 K=1,2
44082               I3DRTP(K+1,N3MODE) = 3
44083               I3DRCF(K+1,N3MODE) = 1
44084               I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
44085               B3MODE(2,K+1,N3MODE) = 0.0D0
44086               B3MODE(1,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
44087      &                               LAMDA2(III,JJJ,KKK)
44088               DO 96 J=1,2
44089  96           A3MODE(J,K+1,N3MODE) = AFC(J,2*JJJ,K,L1)
44090 C--nubar ubar d
44091             ELSEIF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
44092               N3MODE = N3MODE+1
44093               IF(N3MODE.GT.NMODE3) THEN
44094                 CALL HWWARN('HWISP3',135)
44095                 GOTO 999
44096               ENDIF
44097               ID3PRT(N3MODE) = I
44098               NME(I) = 10000+N3MODE
44099               NDI3BY(N3MODE) = 4
44100               P3MODE(N3MODE) = THREE
44101               N3NCFL(N3MODE) = 1
44102               SPN3CF(1,1,N3MODE) = ONE
44103               III = (IDKPRD(1,I)-126)/2
44104               JJJ = (IDKPRD(2,I)-6)/2
44105               KKK = (IDKPRD(3,I)+1)/2
44106               DO 97 K=1,2
44107               I3DRTP(K  ,N3MODE) = 8
44108               I3DRTP(K+2,N3MODE) = 9
44109               I3DRCF(K  ,N3MODE) = 1
44110               I3DRCF(K+2,N3MODE) = 1
44111               I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
44112               I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
44113               B3MODE(2,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
44114      &                               LAMDA2(III,JJJ,KKK)
44115               B3MODE(1,K  ,N3MODE) = 0.0D0
44116               B3MODE(2,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
44117      &                               LAMDA2(III,JJJ,KKK)
44118               B3MODE(1,K+2,N3MODE) = 0.0D0
44119               DO 97 J=1,2
44120               A3MODE(J,K  ,N3MODE) = AFC(O(J),2*III+5,K,L1)
44121  97           A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
44122 C--unrecognised
44123             ELSE
44124               CALL HWWARN('HWISP3',8)
44125             ENDIF
44126 C-- UDD modes
44127           ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
44128      &           IDKPRD(3,I).LE.12) THEN
44129              L1 = IDK(I)-455
44130 C-- d d d mode
44131             IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
44132      &         MOD(IDKPRD(3,I),2).EQ.1) THEN
44133               N3MODE = N3MODE+1
44134               IF(N3MODE.GT.NMODE3) THEN
44135                 CALL HWWARN('HWISP3',136)
44136                 GOTO 999
44137               ENDIF
44138               ID3PRT(N3MODE) = I
44139               NME(I) = 10000+N3MODE
44140               NDI3BY(N3MODE) = 6
44141               N3NCFL(N3MODE) = 1
44142               SPN3CF(1,1,N3MODE) = ONE
44143               III = (IDKPRD(1,I)+1)/2
44144               JJJ = (IDKPRD(2,I)+1)/2
44145               KKK = (IDKPRD(3,I)+1)/2
44146               P3MODE(N3MODE) = ONE
44147               IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
44148               IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
44149               IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
44150               P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
44151               DO 68 K=1,6
44152  68           I3DRCF(K,N3MODE) = 1
44153               DO 67 K=1,2
44154               I3DRTP(K  ,N3MODE) = 12
44155               I3DRTP(K+2,N3MODE) = 13
44156               I3DRTP(K+4,N3MODE) = 14
44157               I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
44158               I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
44159               I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
44160               B3MODE(1,K  ,N3MODE) = 0.0D0
44161               B3MODE(1,K+2,N3MODE) = 0.0D0
44162               B3MODE(1,K+4,N3MODE) = 0.0D0
44163               B3MODE(2,K  ,N3MODE) = QMIXSS(2*III,2,K)*
44164      &                               LAMDA3(III,JJJ,KKK)
44165               B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
44166      &                               LAMDA3(JJJ,III,KKK)
44167               B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
44168      &                               LAMDA3(KKK,III,JJJ)
44169               DO 67 J=1,2
44170               A3MODE(J,K  ,N3MODE) = AFC(J,2*III,K,L1)
44171               A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ,K,L1)
44172  67           A3MODE(J,K+4,N3MODE) = AFC(J,2*KKK,K,L1)
44173 C--u u d mode
44174             ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
44175      &              .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
44176               N3MODE = N3MODE+1
44177               IF(N3MODE.GT.NMODE3) THEN
44178                 CALL HWWARN('HWISP3',137)
44179                 GOTO 999
44180               ENDIF
44181               ID3PRT(N3MODE) = I
44182               NME(I) = 10000+N3MODE
44183               NDI3BY(N3MODE) = 4
44184               P3MODE(N3MODE) = 6.0D0
44185               N3NCFL(N3MODE) = 1
44186               SPN3CF(1,1,N3MODE) = ONE
44187               III = (IDKPRD(1,I)-6)/2
44188               JJJ = (IDKPRD(2,I)-6)/2
44189               KKK = (IDKPRD(3,I)-5)/2
44190               IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
44191               DO 69 K=1,2
44192               I3DRTP(K  ,N3MODE) = 11
44193               I3DRTP(K+2,N3MODE) = 12
44194               I3DRCF(K  ,N3MODE) = 1
44195               I3DRCF(K+2,N3MODE) = 1
44196               I3MODE(K  ,N3MODE) = 399+2*III+(K-1)*12
44197               I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
44198               B3MODE(1,K  ,N3MODE) = QMIXSS(2*III-1,2,K)*
44199      &                               LAMDA3(JJJ,III,KKK)
44200               B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
44201      &                               LAMDA3(III,JJJ,KKK)
44202               B3MODE(2,K+2,N3MODE) = 0.0D0
44203               B3MODE(2,K+2,N3MODE) = 0.0D0
44204               DO 69 J=1,2
44205               A3MODE(J,K  ,N3MODE) = AFC(O(J),2*III-1,K,L1)
44206  69           A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
44207 C--unrecognized decay issue warning
44208             ELSE
44209               CALL HWWARN('HWISP3',9)
44210             ENDIF
44211 C--unrecognized decay issue warning
44212           ELSE
44213             CALL HWWARN('HWISP3',10)
44214           ENDIF
44215         ENDIF
44216 C--NOW FIND THE TWO BODY MODES WE WILL TREAT AS THREE BODY
44217  2500   IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0) GOTO 2000
44218         L1  = IDK(I)-449
44219         IH1 = IDK(I)-202
44220         IH  = IDKPRD(1,I)-202
44221 C--first the neutralino decay modes
44222         IF(L1.GE.1.AND.L1.LE.4.AND.
44223      &     IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44224 C--neutralino --> neutralino Z
44225           IF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.200) THEN
44226             NBMODE = NBMODE+1
44227             IF(NBMODE.GT.NMODEB) THEN
44228               CALL HWWARN('HWISP3',138)
44229               GOTO 999
44230             ENDIF
44231             NME(I) = 20000+NBMODE
44232             IDBPRT(NBMODE) = I
44233             IBMODE(NBMODE) = 200
44234             IBDRTP(NBMODE) = 1
44235             DO 20 J=1,2
44236  20         ABMODE(J,NBMODE) = OIJPP(J,L,L1)
44237             DO 21 K=1,12
44238             IF(K.LE.6) THEN
44239               IL = K
44240               PBMODE(K,NBMODE) = THREE
44241             ELSE
44242               IL=K+4
44243               PBMODE(K,NBMODE) = ONE
44244             ENDIF
44245             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44246  21         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44247 C--neutralino --> chargino+ W-
44248           ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.199) THEN
44249             L = L-4
44250             NBMODE = NBMODE+1
44251             IF(NBMODE.GT.NMODEB) THEN
44252               CALL HWWARN('HWISP3',139)
44253               GOTO 999
44254             ENDIF
44255             NME(I) = 20000+NBMODE
44256             IDBPRT(NBMODE) = I
44257             IBMODE(NBMODE) = 199
44258             IBDRTP(NBMODE) = 1
44259             DO 22 J=1,2
44260  22         ABMODE(J,NBMODE) = OIJ(J,L1,L)
44261             DO 23 K=1,6
44262             PBMODE(K,NBMODE) = ONE
44263             IF(K.LE.3) PBMODE(K,NBMODE) = THREE
44264             BBMODE(1,K,NBMODE) = ZERO
44265  23         BBMODE(2,K,NBMODE) = -G*ORT
44266 C--neutralino --> chargino- W+
44267           ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.198) THEN
44268             L = L-6
44269             NBMODE = NBMODE+1
44270             IF(NBMODE.GT.NMODEB) THEN
44271               CALL HWWARN('HWISP3',140)
44272               GOTO 999
44273             ENDIF
44274             NME(I) = 20000+NBMODE
44275             IDBPRT(NBMODE) = I
44276             IBMODE(NBMODE) = 198
44277             IBDRTP(NBMODE) = 1
44278             DO 24 J=1,2
44279  24         ABMODE(J,NBMODE) =-OIJ(O(J),L1,L)
44280             DO 25 K=1,6
44281             PBMODE(K,NBMODE) = ONE
44282             IF(K.LE.3) PBMODE(K,NBMODE) = THREE
44283             BBMODE(1,K,NBMODE) = ZERO
44284  25         BBMODE(2,K,NBMODE) = -G*ORT
44285 C--gravitino Z modes
44286           ELSEIF(L.EQ.9.AND.IDKPRD(2,I).EQ.200) THEN
44287             NBMODE = NBMODE+1
44288             IF(NBMODE.GT.NMODEB) THEN
44289               CALL HWWARN('HWISP3',141)
44290               GOTO 999
44291             ENDIF
44292             NME(I) = 20000+NBMODE
44293             IDBPRT(NBMODE) = I
44294             IBMODE(NBMODE) = 200
44295             IBDRTP(NBMODE) = 7
44296             ABMODE(1,NBMODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,2)
44297             ABMODE(2,NBMODE) = 2.0D0/SQRT(6.0D0)*RMASS(200)*
44298      &                         (ZMIXSS(L1,3)*COSB-ZMIXSS(L1,4)*SINB)
44299             DO 41 K=1,12
44300             IF(K.LE.6) THEN
44301               IL = K
44302               PBMODE(K,NBMODE) = THREE
44303             ELSE
44304               IL=K+4
44305               PBMODE(K,NBMODE) = ONE
44306             ENDIF
44307             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44308  41         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44309 C--unrecognized decay issue warning
44310           ELSE
44311             CALL HWWARN('HWISP3',11)
44312           ENDIF
44313 C--then the +ve chargino decay modes
44314         ELSEIF((L1.EQ.5.OR.L1.EQ.6)
44315      &         .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44316           L1 = L1-4
44317 C--chargino --> chargino Z
44318           IF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.200) THEN
44319             L = L-4
44320             NBMODE = NBMODE+1
44321             IF(NBMODE.GT.NMODEB) THEN
44322               CALL HWWARN('HWISP3',142)
44323               GOTO 999
44324             ENDIF
44325             NME(I) = 20000+NBMODE
44326             IDBPRT(NBMODE) = I
44327             IBMODE(NBMODE) = 200
44328             IBDRTP(NBMODE) = 1
44329             DO 26 J=1,2
44330  26         ABMODE(J,NBMODE) = OIJP(J,L,L1)
44331             DO 27 K=1,12
44332             IF(K.LE.6) THEN
44333               IL = K
44334               PBMODE(K,NBMODE) = THREE
44335             ELSE
44336               IL=K+4
44337               PBMODE(K,NBMODE) = ONE
44338             ENDIF
44339             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44340  27         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44341 C--chargino --> neutralino W+
44342           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.198) THEN
44343             NBMODE = NBMODE+1
44344             IF(NBMODE.GT.NMODEB) THEN
44345               CALL HWWARN('HWISP3',143)
44346               GOTO 999
44347             ENDIF
44348             NME(I) = 20000+NBMODE
44349             IDBPRT(NBMODE) = I
44350             IBMODE(NBMODE) = 198
44351             IBDRTP(NBMODE) = 1
44352             DO 28 J=1,2
44353  28         ABMODE(J,NBMODE) = OIJ(J,L,L1)
44354             DO 29 K=1,6
44355             PBMODE(K,NBMODE) = ONE
44356             IF(K.LE.3) PBMODE(K,NBMODE) = THREE
44357             BBMODE(1,K,NBMODE) = ZERO
44358  29         BBMODE(2,K,NBMODE) = -G*ORT
44359 C--unrecognised decay issue warning
44360           ELSE
44361             CALL HWWARN('HWISP3',12)
44362           ENDIF
44363 C--then the -ve chargino decay modes
44364         ELSEIF((L1.EQ.7.OR.L1.EQ.8)
44365      &         .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44366           L1 = L1-6
44367 C--chargino --> chargino Z
44368           IF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.200) THEN
44369             L = L-6
44370             NBMODE = NBMODE+1
44371             IF(NBMODE.GT.NMODEB) THEN
44372               CALL HWWARN('HWISP3',144)
44373               GOTO 999
44374             ENDIF
44375             NME(I) = 20000+NBMODE
44376             IDBPRT(NBMODE) = I
44377             IBMODE(NBMODE) = 200
44378             IBDRTP(NBMODE) = 1
44379             DO 30 J=1,2
44380  30         ABMODE(J,NBMODE) =-OIJP(O(J),L,L1)
44381             DO 31 K=1,12
44382             IF(K.LE.6) THEN
44383               IL = K
44384               PBMODE(K,NBMODE) = THREE
44385             ELSE
44386               IL=K+4
44387               PBMODE(K,NBMODE) = ONE
44388             ENDIF
44389             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44390  31         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44391 C--chargino --> neutralino W-
44392           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.199) THEN
44393             NBMODE = NBMODE+1
44394             IF(NBMODE.GT.NMODEB) THEN
44395               CALL HWWARN('HWISP3',145)
44396               GOTO 999
44397             ENDIF
44398             NME(I) = 20000+NBMODE
44399             IDBPRT(NBMODE) = I
44400             IBMODE(NBMODE) = 199
44401             IBDRTP(NBMODE) = 1
44402             DO 32 J=1,2
44403  32         ABMODE(J,NBMODE) =-OIJ(O(J),L,L1)
44404             DO 33 K=1,6
44405             PBMODE(K,NBMODE) = ONE
44406             IF(K.LE.3) PBMODE(K,NBMODE) = THREE
44407             BBMODE(1,K,NBMODE) = ZERO
44408  33         BBMODE(2,K,NBMODE) = -G*ORT
44409 C--unrecognised decay issue warning
44410           ELSE
44411             CALL HWWARN('HWISP3',13)
44412           ENDIF
44413 C--gauge boson decay modes of the Higgs
44414         ELSEIF(IH.GE.1.AND.IH.LE.5.AND.IH1.GE.1.AND.IH1.LE.5.AND.
44415      &         IDKPRD(1,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44416 C--decay of the A0 to scalar Higgs and Z boson
44417           IF(IH1.EQ.3.AND.IH.LE.2) THEN
44418             NBMODE = NBMODE+1
44419             IF(NBMODE.GT.NMODEB) THEN
44420               CALL HWWARN('HWISP3',146)
44421               GOTO 999
44422             ENDIF
44423             NME(I) = 20000+NBMODE
44424             IDBPRT(NBMODE) = I
44425             IBMODE(NBMODE) = 200
44426             IBDRTP(NBMODE) = 6
44427             ABMODE(1,NBMODE) =-HHB(2,IH)
44428             ABMODE(2,NBMODE) = ZERO
44429             DO 34 K=1,12
44430             IF(K.LE.6) THEN
44431               IL = K
44432               PBMODE(K,NBMODE) = 3.0D0
44433             ELSE
44434               IL=K+4
44435               PBMODE(K,NBMODE) = 1.0D0
44436             ENDIF
44437             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44438  34         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44439 C--decay of scalar Higgs to A0 and Z
44440           ELSEIF(IH.EQ.3.AND.IH1.LE.3) THEN
44441             NBMODE = NBMODE+1
44442             IF(NBMODE.GT.NMODEB) THEN
44443               CALL HWWARN('HWISP3',147)
44444               GOTO 999
44445             ENDIF
44446             NME(I) = 20000+NBMODE
44447             IDBPRT(NBMODE) = I
44448             IBMODE(NBMODE) = 200
44449             IBDRTP(NBMODE) = 6
44450             ABMODE(1,NBMODE) = HHB(2,IH1)
44451             ABMODE(2,NBMODE) = ZERO
44452             DO 35 K=1,12
44453             IF(K.LE.6) THEN
44454               IL = K
44455               PBMODE(K,NBMODE) = 3.0D0
44456             ELSE
44457               IL=K+4
44458               PBMODE(K,NBMODE) = 1.0D0
44459             ENDIF
44460             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44461  35         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44462 C--decay of the positively charged Higgs
44463           ELSEIF(IH1.EQ.4.AND.IH.LE.3) THEN
44464             NBMODE = NBMODE+1
44465             IF(NBMODE.GT.NMODEB) THEN
44466               CALL HWWARN('HWISP3',148)
44467               GOTO 999
44468             ENDIF
44469             NME(I) = 20000+NBMODE
44470             IDBPRT(NBMODE) = I
44471             IBMODE(NBMODE) = 198
44472             IBDRTP(NBMODE) = 6
44473             ABMODE(1,NBMODE) =-HHB(1,IH)
44474             ABMODE(2,NBMODE) = ZERO
44475             DO 36 K=1,6
44476             PBMODE(K,NBMODE) = 1.0D0
44477             IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
44478             BBMODE(1,K,NBMODE) = ZERO
44479  36         BBMODE(2,K,NBMODE) = -G*ORT
44480 C--decay of the negatively charged Higgs
44481           ELSEIF(IH1.EQ.5.AND.IH.LE.3) THEN
44482             NBMODE = NBMODE+1
44483             IF(NBMODE.GT.NMODEB) THEN
44484               CALL HWWARN('HWISP3',149)
44485               GOTO 999
44486             ENDIF
44487             NME(I) = 20000+NBMODE
44488             IDBPRT(NBMODE) = I
44489             IBMODE(NBMODE) = 199
44490             IBDRTP(NBMODE) = 6
44491             ABMODE(1,NBMODE) =-HHB(1,IH)
44492             ABMODE(2,NBMODE) = ZERO
44493             DO 37 K=1,6
44494             PBMODE(K,NBMODE) = 1.0D0
44495             IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
44496             BBMODE(1,K,NBMODE) = ZERO
44497  37         BBMODE(2,K,NBMODE) = -G*ORT
44498           ENDIF
44499 C--finally sfermion modes to gauge bosons
44500         ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.448.AND.
44501      &         IDKPRD(2,I).GE.401.AND.IDKPRD(2,I).LE.448.AND.
44502      &         IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200) THEN
44503 C--change the order of the decay products
44504           IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
44505           IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
44506           IH = MOD(INT((IDKPRD(2,I)-389)/12)+1,2)+1
44507           IQ = 6*INT((IDKPRD(2,I)-401)/24)+MOD(IDKPRD(2,I)-401,6)+1
44508 C--first the Z decay modes
44509           IF(IDKPRD(1,I).EQ.200) THEN
44510             NBMODE = NBMODE+1
44511             IF(NBMODE.GT.NMODEB) THEN
44512               CALL HWWARN('HWISP3',150)
44513               GOTO 999
44514             ENDIF
44515             NME(I) = 20000+NBMODE
44516             IDBPRT(NBMODE) = I
44517             IBMODE(NBMODE) = 200
44518             IBDRTP(NBMODE) = 6
44519             ABMODE(1,NBMODE) = ZAB(IL,IM,IH)
44520             ABMODE(2,NBMODE) = ZERO
44521             DO 38 K=1,12
44522             IF(K.LE.6) THEN
44523               IL = K
44524               PBMODE(K,NBMODE) = 3.0D0
44525             ELSE
44526               IL=K+4
44527               PBMODE(K,NBMODE) = 1.0D0
44528             ENDIF
44529             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44530  38         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44531 C--then  the W+ decay modes
44532           ELSEIF(IDKPRD(1,I).EQ.198) THEN
44533             NBMODE = NBMODE+1
44534             IF(NBMODE.GT.NMODEB) THEN
44535               CALL HWWARN('HWISP3',151)
44536               GOTO 999
44537             ENDIF
44538             NME(I) = 20000+NBMODE
44539             IDBPRT(NBMODE) = I
44540             IBMODE(NBMODE) = 198
44541             IBDRTP(NBMODE) = 6
44542             IF(IL.LE.6) THEN
44543               ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
44544             ELSE
44545               ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
44546      &                                  LMIXSS(IQ-6,1,IH)
44547             ENDIF
44548             ABMODE(2,NBMODE) = ZERO
44549             DO 39 K=1,6
44550             PBMODE(K,NBMODE) = 1.0D0
44551             IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
44552             BBMODE(1,K,NBMODE) = ZERO
44553  39         BBMODE(2,K,NBMODE) = -G*ORT
44554           ELSEIF(IDKPRD(1,I).EQ.199) THEN
44555             NBMODE = NBMODE+1
44556             IF(NBMODE.GT.NMODEB) THEN
44557               CALL HWWARN('HWISP3',152)
44558               GOTO 999
44559             ENDIF
44560             NME(I) = 20000+NBMODE
44561             IDBPRT(NBMODE) = I
44562             IBMODE(NBMODE) = 199
44563             IBDRTP(NBMODE) = 6
44564             IF(IL.LE.6) THEN
44565               ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
44566             ELSE
44567               ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
44568      &                                  LMIXSS(IQ-6,1,IH)
44569             ENDIF
44570             ABMODE(2,NBMODE) = ZERO
44571             DO 40 K=1,6
44572             PBMODE(K,NBMODE) = 1.0D0
44573             IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
44574             BBMODE(1,K,NBMODE) = ZERO
44575  40         BBMODE(2,K,NBMODE) = -G*ORT
44576           ENDIF
44577         ENDIF
44578  2000 CONTINUE
44579 C--now compute the maximum weights for the three body decays found
44580  2999 CONTINUE
44581       DO 3000 I=1,N3MODE
44582       IF(RSPIN(IDK(ID3PRT(I))).EQ.ZERO) THEN
44583         RHOIN(1,1) = ONE
44584         RHOIN(1,2) = ZERO
44585         RHOIN(2,1) = ZERO
44586         RHOIN(2,2) = ZERO
44587       ELSE
44588         RHOIN(1,1) = HALF
44589         RHOIN(1,2) = ZERO
44590         RHOIN(2,1) = ZERO
44591         RHOIN(2,2) = HALF
44592       ENDIF
44593       PHEP(5,1) = RMASS(IDK(ID3PRT(I)))
44594       PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
44595       PHEP(1,1) = 100.0D0
44596       PHEP(2,1) = 0.0D0
44597       PHEP(3,1) = 0.0D0
44598       IF(IPRINT.EQ.2) WRITE(6,5000) RNAME(IDK(ID3PRT(I))),
44599      &   RNAME(IDKPRD(1,ID3PRT(I))),RNAME(IDKPRD(2,ID3PRT(I))),
44600      &   RNAME(IDKPRD(3,ID3PRT(I)))
44601  3000 CALL HWD3ME(1,0,I,RHOIN,1)
44602       IF(.NOT.SUSYIN) RETURN
44603 C--and for the two body gauge boson modes
44604       DO 4000 I=1,NBMODE
44605       IF(RSPIN(IDK(IDBPRT(I))).EQ.ZERO) THEN
44606         RHOIN(1,1) = ONE
44607         RHOIN(1,2) = ZERO
44608         RHOIN(2,1) = ZERO
44609         RHOIN(2,2) = ZERO
44610       ELSE
44611         RHOIN(1,1) = HALF
44612         RHOIN(1,2) = ZERO
44613         RHOIN(2,1) = ZERO
44614         RHOIN(2,2) = HALF
44615       ENDIF
44616       PHEP(5,1) = RMASS(IDK(IDBPRT(I)))
44617       PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
44618       PHEP(1,1) = 100.0D0
44619       PHEP(2,1) = 0.0D0
44620       PHEP(3,1) = 0.0D0
44621       IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(IDBPRT(I))),
44622      & RNAME(IDKPRD(1,IDBPRT(I))),RNAME(IDKPRD(2,IDBPRT(I)))
44623       IL = 12
44624       IF(IBMODE(I).NE.200) IL = 6
44625       DO 4000 J=1,IL
44626  4000 CALL HWD3ME(1,J,I,RHOIN,1)
44627       RETURN
44628  5000 FORMAT(/'CALCULATING THREE BODY DECAY ',
44629      &     A8,' --> ',A8,' ',A8,' ',A8/)
44630  5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
44631      &     A8,' --> ',A8,' ',A8/)
44632  999  RETURN
44633       END
44634 CDECK  ID>, HWISP4.
44635 *CMZ :-        -12/10/01  12.04.54  by  Peter Richardson
44636 *-- Author :    Peter Richardson
44637 C-----------------------------------------------------------------------
44638       SUBROUTINE HWISP4
44639 C-----------------------------------------------------------------------
44640 C     Initialise the Higgs four body modes
44641 C-----------------------------------------------------------------------
44642       INCLUDE 'herwig65.inc'
44643       INTEGER I,J,K,IL,IH,II,JJ
44644       DOUBLE PRECISION COL(2),SW,CW,TW,E,G,RT,ORT,MW,MZ,AFN(2,12,2,4),
44645      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
44646      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
44647      &     HZZ(2),ZAB(12,2,2),HHB(2,3),GS
44648       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
44649      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
44650       IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
44651 C--four body Higgs modes via virtual WW and ZZ
44652       DO 1000 JJ=1,NRES
44653       DO 1000 II=1,NMODES(JJ)
44654         IF(II.EQ.1) THEN
44655           I = LSTRT(JJ)
44656         ELSE
44657           I = LNEXT(I)
44658         ENDIF
44659         IH=IDK(I)-202
44660         IF((IH.EQ.1.OR.IH.EQ.2).AND.IDKPRD(3,I).EQ.0.AND.
44661      &       IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
44662      &       IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44663 C--first the WW modes
44664           IF(IDKPRD(1,I).NE.200) THEN
44665             N4MODE = N4MODE+1
44666             IF(N4MODE.GT.NMODE4) THEN
44667               CALL HWWARN('HWISP4',100)
44668               GOTO 999
44669             ENDIF
44670             NME(I) = 40000+N4MODE
44671             ID4PRT(N4MODE) = I
44672             I4MODE(1,N4MODE) = 198
44673             I4MODE(2,N4MODE) = 199
44674             DO 1 K=1,6
44675             A4MODE(1,K,N4MODE) = ZERO
44676             A4MODE(2,K,N4MODE) =-G*ORT
44677             B4MODE(1,K,N4MODE) = ZERO
44678  1          B4MODE(2,K,N4MODE) =-G*ORT
44679 C--now the prefactors
44680             DO 2 J=1,6
44681             COL(1) = HWW(IH)**2
44682             IF(J.LE.3) COL(1) = THREE*COL(1)
44683             DO 2 K=1,6
44684             COL(2) = ONE
44685             IF(K.LE.3) COL(2) = THREE*COL(2)
44686  2          P4MODE(J,K,N4MODE) = COL(1)*COL(2)
44687 C--then the ZZ modes
44688           ELSE
44689             N4MODE = N4MODE+1
44690             IF(N4MODE.GT.NMODE4) THEN
44691               CALL HWWARN('HWISP4',101)
44692               GOTO 999
44693             ENDIF
44694             NME(I) = 40000+N4MODE
44695             ID4PRT(N4MODE) = I
44696             I4MODE(1,N4MODE) = 200
44697             I4MODE(2,N4MODE) = 200
44698             DO 3 K=1,12
44699             IL = K
44700             IF(K.GT.6) IL=K+4
44701             A4MODE(1,K,N4MODE) =-E*RFCH(IL)
44702             A4MODE(2,K,N4MODE) =-E*LFCH(IL)
44703             B4MODE(1,K,N4MODE) =-E*RFCH(IL)
44704  3          B4MODE(2,K,N4MODE) =-E*LFCH(IL)
44705             DO 4 J=1,12
44706             COL(1) = HALF*HZZ(IH)**2
44707             IF(J.LE.6) COL(1)=THREE*COL(1)
44708             DO 4 K=1,12
44709             COL(2) = ONE
44710             IF(K.LE.6) COL(2) = THREE
44711  4          P4MODE(J,K,N4MODE) = COL(1)*COL(2)
44712           ENDIF
44713         ENDIF
44714  1000 CONTINUE
44715 C--compute the maximum weights
44716       IF(N4MODE.EQ.0) RETURN
44717       DO 2000 I=1,N4MODE
44718       PHEP(5,1) = RMASS(IDK(ID4PRT(I)))
44719       PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
44720       PHEP(1,1) = 100.0D0
44721       PHEP(2,1) = 0.0D0
44722       PHEP(3,1) = 0.0D0
44723       IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(ID4PRT(I))),
44724      &            RNAME(IDKPRD(1,ID4PRT(I))),RNAME(IDKPRD(2,ID4PRT(I)))
44725       IL = 12
44726       IF(I4MODE(1,I).NE.200) IL = 6
44727       DO 2000 J=1,IL
44728       DO 2000 K=1,IL
44729  2000 CALL HWD4ME(1,J,K,I)
44730       RETURN
44731  5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
44732      &     A8,' --> ',A8,' ',A8/)
44733  999  RETURN
44734       END
44735 CDECK  ID>, HWISSP.
44736 *CMZ :-        -12/10/01  09:41:43  by  Peter Richardson
44737 *-- Author :    Bryan Webber, modified by Kosuke Odagiri
44738 C-----------------------------------------------------------------------
44739       SUBROUTINE HWISSP
44740 C-----------------------------------------------------------------------
44741 C  Reads in SUSY particle properties and decays,
44742 C  in format generated by ISAWIG
44743 C-----------------------------------------------------------------------
44744       INCLUDE 'herwig65.inc'
44745       INTEGER I,J,K,IH,IHW,NSSP,NDEC,MDKYS
44746       DOUBLE PRECISION BETAH, WEINCOS,WEINSIN, MW,MZ, RMMAX
44747       DOUBLE PRECISION FTM,FTMUU(4),FTMDD(4),FTMTT(4),FTMBB(4),FTMU,FTMD
44748       DOUBLE PRECISION YTM,YTM1,DTERM(4), SQHF,SNBCSB,MZSW2
44749       LOGICAL FIRST
44750       EQUIVALENCE (MW,RMASS(198)), (MZ,RMASS(200))
44751       SAVE MDKYS
44752       SAVE FIRST
44753       DATA FIRST/.TRUE./
44754       IF (FIRST) THEN
44755         MDKYS=NDKYS
44756         FIRST=.FALSE.
44757       ELSE
44758         NDKYS=MDKYS
44759       ENDIF
44760 C--reset susy input flag
44761       IF (LRSUSY.LT.0) CALL HWWARN('HWISSP',500)
44762       SUSYIN = .TRUE.
44763 C
44764 C  Input SUSY particle + top quark table
44765 C
44766       WRITE (6,9)       '                           '
44767   9   FORMAT(//10X,A28//,
44768      &         10X,'Since SUSY processes are called,'
44769      & ,/,     10X,'please also reference: S.Moretti, K.Odagiri,'
44770      & ,/,     10X,'P.Richardson, M.H.Seymour & B.R.Webber,'
44771      & ,/,     10X,'JHEP 0204 (2002) 028')
44772       WRITE (6,10) LRSUSY
44773  10   FORMAT (/10X,'Reading in SUSY data from unit',I3)
44774       READ (LRSUSY,'(I4)') NSSP
44775       IF (NSSP.LE.0) RETURN
44776       RMMAX=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
44777       RMMNSS=RMMAX
44778       DO I=1,NSSP
44779         READ (LRSUSY,1) IHW,RMASS(IHW),RLTIM(IHW)
44780 C  Negative gaugino mass means physical field is gamma_5*psi
44781 C  Store the signs
44782         IF ((IHW.GE.450).AND.(IHW.LE.457)) THEN
44783           IF (IHW.LE.453) THEN
44784             J=IHW-449
44785             ZSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
44786           ELSEIF (IHW.LE.455) THEN
44787             J=IHW-453
44788             WSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
44789           ENDIF
44790           RMASS(IHW)=ABS(RMASS(IHW))
44791         ENDIF
44792         IF (ABS(IDPDG(IHW)).GT.1000000.AND.(RMASS(IHW).NE.ZERO))
44793      &    RMMNSS=MIN(RMMNSS,RMASS(IHW))
44794         IF (IHW.GT.NRES) THEN
44795           IF (IHW.GT.NMXRES) CALL HWWARN('HWISSP',501)
44796           NRES=IHW
44797         ENDIF
44798       ENDDO
44799       XLMNSS=TWO*LOG(RMMNSS/RMMAX)
44800     1 FORMAT(I5,F12.4,E15.5)
44801 C
44802 C  Input decay modes
44803 C
44804       NDECSY = NDKYS+1
44805       DO I=1,NSSP
44806         READ (LRSUSY,'(I4)') NDEC
44807         IF (NDEC.GT.0) THEN
44808           DO J=1,NDEC
44809             NDKYS=NDKYS+1
44810             IF (NDKYS.GT.NMXDKS) THEN
44811               CALL HWWARN('HWISSP',100)
44812               GOTO 999
44813             ENDIF
44814             READ (LRSUSY,11) IDK(NDKYS),BRFRAC(NDKYS),NME(NDKYS),
44815      &      (IDKPRD(K,NDKYS),K=1,5)
44816    11       FORMAT(I6,F16.8,6I6)
44817           ENDDO
44818         ENDIF
44819       ENDDO
44820 C
44821 C  Mixings and other SUSY parameters
44822 C
44823       READ (LRSUSY,'(2F16.8)') TANB,ALPHAH
44824       DO I=1,4
44825         READ (LRSUSY,13) ZMXNSS(I,1),ZMXNSS(I,2),ZMXNSS(I,3),ZMXNSS(I,4)
44826       END DO
44827       WEINSIN = SQRT(SWEIN)
44828       WEINCOS = SQRT(1.-SWEIN)
44829       DO I=1,4
44830         ZMIXSS(I,1) =  WEINCOS*ZMXNSS(I,1)+WEINSIN*ZMXNSS(I,2)
44831         ZMIXSS(I,2) = -WEINSIN*ZMXNSS(I,1)+WEINCOS*ZMXNSS(I,2)
44832         ZMIXSS(I,3) =  ZMXNSS(I,3)
44833         ZMIXSS(I,4) =  ZMXNSS(I,4)
44834       END DO
44835       DO J=1,16
44836         IF ((J.LE.6).OR.(J.GE.11)) THEN
44837 C--left and right couplings now computed in HWIGIN
44838           DO I=1,4
44839             SLFCH(J,I)= ZMIXSS(I,1)*QFCH(J)+ZMIXSS(I,2)*LFCH(J)
44840             SRFCH(J,I)=-ZMIXSS(I,1)*QFCH(J)-ZMIXSS(I,2)*RFCH(J)
44841           END DO
44842         ENDIF
44843       END DO
44844       READ (LRSUSY,13) WMXVSS(1,1),WMXVSS(1,2), WMXVSS(2,1),WMXVSS(2,2)
44845       READ (LRSUSY,13) WMXUSS(1,1),WMXUSS(1,2), WMXUSS(2,1),WMXUSS(2,2)
44846       READ (LRSUSY,'(3F16.8)') THETAT,THETAB,THETAL
44847       READ (LRSUSY,'(3F16.8)') ATSS,ABSS,ALSS
44848       READ (LRSUSY,'( F16.8)') MUSS
44849       DO I=1,6
44850         QMIXSS(I,1,1)=1.
44851         QMIXSS(I,1,2)=0.
44852         QMIXSS(I,2,1)=0.
44853         QMIXSS(I,2,2)=1.
44854         LMIXSS(I,1,1)=1.
44855         LMIXSS(I,1,2)=0.
44856         LMIXSS(I,2,1)=0.
44857         LMIXSS(I,2,2)=1.
44858       END DO
44859       QMIXSS(6,1,1)= COS(THETAT)
44860       QMIXSS(6,1,2)= SIN(THETAT)
44861       QMIXSS(6,2,1)=-QMIXSS(6,1,2)
44862       QMIXSS(6,2,2)= QMIXSS(6,1,1)
44863       QMIXSS(5,1,1)= COS(THETAB)
44864       QMIXSS(5,1,2)= SIN(THETAB)
44865       QMIXSS(5,2,1)=-QMIXSS(5,1,2)
44866       QMIXSS(5,2,2)= QMIXSS(5,1,1)
44867       LMIXSS(5,1,1)= COS(THETAL)
44868       LMIXSS(5,1,2)= SIN(THETAL)
44869       LMIXSS(5,2,1)=-LMIXSS(5,1,2)
44870       LMIXSS(5,2,2)= LMIXSS(5,1,1)
44871 C--Evaluating Higgs parameters and couplings
44872       BETAH=ATAN(TANB)
44873       COTB=ONE/TANB
44874       COSBPA=COS(BETAH+ALPHAH)
44875       SINBPA=SIN(BETAH+ALPHAH)
44876       COSBMA=COS(BETAH-ALPHAH)
44877       SINBMA=SIN(BETAH-ALPHAH)
44878       COSA=COS(ALPHAH)
44879       SINA=SIN(ALPHAH)
44880       COSB=COS(BETAH)
44881       SINB=SIN(BETAH)
44882       GHWWSS(1)=SINBMA
44883       GHWWSS(2)=COSBMA
44884       GHWWSS(3)=ZERO
44885       DO 30 I=1,3
44886         GHZZSS(I)=GHWWSS(I)
44887  30   CONTINUE
44888       GHDDSS(1)=-SINA/COSB
44889       GHDDSS(2)= COSA/COSB
44890       GHDDSS(3)= TANB
44891       GHUUSS(1)= COSA/SINB
44892       GHUUSS(2)= SINA/SINB
44893       GHUUSS(3)= COTB
44894       GHWHSS(1)= COSBMA
44895       GHWHSS(2)= SINBMA
44896       GHWHSS(3)= ONE
44897       MZSW2    = MZ**2 * SQRT(SWEIN*(ONE-SWEIN))
44898       DTERM(1) =-SINBPA*MZSW2
44899       DTERM(2) = COSBPA*MZSW2
44900       DTERM(3) = ZERO
44901       FTMUU(1) = MUSS*SINA/SINB
44902       FTMUU(2) =-MUSS*COSA/SINB
44903       FTMUU(3) =-MUSS
44904       FTMUU(4) =-MUSS
44905       FTMTT(1) = ATSS*COSA/SINB
44906       FTMTT(2) = ATSS*SINA/SINB
44907       FTMTT(3) =-ATSS*COTB
44908       FTMTT(4) =-ATSS*COTB
44909       FTMDD(1) =-MUSS*COSA/COSB
44910       FTMDD(2) =-MUSS*SINA/COSB
44911       FTMDD(3) =-MUSS
44912       FTMDD(4) =-MUSS
44913       FTMBB(1) =-ABSS*SINA/COSB
44914       FTMBB(2) = ABSS*COSA/COSB
44915       FTMBB(3) =-ABSS*TANB
44916       FTMBB(4) =-ABSS*TANB
44917       DO 40 IH=1,4
44918         FTMU=FTMUU(IH)
44919         FTMD=FTMDD(IH)
44920         DO 50 I=1,6
44921           IF (I.EQ.5) FTMU=FTMU+FTMTT(IH)
44922           IF (I.EQ.5) FTMD=FTMD+FTMBB(IH)
44923           IF (MOD(I,2).EQ.0) THEN
44924            YTM = GHUUSS(IH)
44925            FTM = FTMU
44926           ELSE
44927            YTM = GHDDSS(IH)
44928            FTM = FTMD
44929           END IF
44930           IF (IH.EQ.3) THEN
44931            GHSQSS(IH,I,1,1) = ZERO
44932            GHSQSS(IH,I,2,2) = ZERO
44933            GHSQSS(IH,I,1,2) = FTM*HALF*RMASS(I)/MW
44934            GHSQSS(IH,I,2,1) = - GHSQSS(IH,I,1,2)
44935            GOTO 50
44936           ELSEIF (IH.EQ.4) THEN
44937            SQHF=SQRT(HALF)
44938            SNBCSB=SINB*COSB
44939            DO 60 J=1,2
44940             DO 70 K=1,2
44941              IF (MOD(I,2).EQ.1) THEN
44942               GHSQSS(IH,I,J,K)=SQHF*(
44943      &          RMASS(I  )*FTMD*QMIXSS(I,2,J)*QMIXSS(I+1,1,K)
44944      &         +RMASS(I+1)*FTMU*QMIXSS(I,1,J)*QMIXSS(I+1,2,K)
44945      &         +( MW**2*TWO*SNBCSB-RMASS(I+1)**2*COTB
44946      &           -RMASS(I  )**2*TANB )*QMIXSS(I,1,J)*QMIXSS(I+1,1,K)
44947      &         -RMASS(I)*RMASS(I+1)/SNBCSB
44948      &          *QMIXSS(I,2,J)*QMIXSS(I+1,2,K) ) / MW
44949              ELSE
44950               GHSQSS(IH,I,J,K)=GHSQSS(IH,I-1,K,J)
44951              END IF
44952  70         END DO
44953  60        END DO
44954           ELSE
44955            DO 80 J=1,2
44956             DO 90 K=1,2
44957              YTM1=ZERO
44958              IF (J.EQ.K) YTM1=YTM*RMASS(I)**2
44959              GHSQSS(IH,I,J,K)=( YTM1
44960      &        +( LFCH(I)*QMIXSS(I,1,J)*QMIXSS(I,1,K)
44961      &          -RFCH(I)*QMIXSS(I,2,J)*QMIXSS(I,2,K) )*DTERM(IH)
44962      &        +FTM*HALF*RMASS(I)*(QMIXSS(I,1,J)*QMIXSS(I,2,K)
44963      &                           +QMIXSS(I,2,J)*QMIXSS(I,1,K)) ) / MW
44964  90         CONTINUE
44965  80        CONTINUE
44966           END IF
44967  50     CONTINUE
44968  40   CONTINUE
44969 C--Rparity violation
44970       READ (LRSUSY,'(L5)') RPARTY
44971       IF(.NOT.RPARTY) THEN
44972         READ(LRSUSY,20) (((LAMDA1(I,J,K),K=1,3),J=1,3),I=1,3)
44973         READ(LRSUSY,20) (((LAMDA2(I,J,K),K=1,3),J=1,3),I=1,3)
44974         READ(LRSUSY,20) (((LAMDA3(I,J,K),K=1,3),J=1,3),I=1,3)
44975       ENDIF
44976  13   FORMAT(4F16.8)
44977  20   FORMAT(27E16.8)
44978       CLOSE(LRSUSY)
44979       IF(FOURB) CALL HWIMDE
44980  999  RETURN
44981       END
44982 CDECK  ID>, HWMEVT.
44983 *CMZ :-        -04/05/99  14.28.59  by  Bryan Webber
44984 *-- Author :    Bryan Webber
44985 C-----------------------------------------------------------------------
44986       SUBROUTINE HWMEVT
44987 C-----------------------------------------------------------------------
44988 C     IPROC = 1000,... ADDS SOFT UNDERLYING EVENT
44989 C           = 8000:  CREATES MINIMUM-BIAS EVENT
44990 C     SUPPRESSED BY ADDING 10000 TO IPROC
44991 C-----------------------------------------------------------------------
44992       INCLUDE 'herwig65.inc'
44993       DOUBLE PRECISION HWREXP,ENFAC,TECM,SECM,SUMM,EMCL,BMP(5),BMR(3,3)
44994       INTEGER HWRINT,NETC,IBT,IDBT,ID1,ID2,ID3,KHEP,LHEP,NTRY,ICMS,
44995      & NPPBAR,MCHT,JCL,JD1,JD2,JD3,ICH,MODC,NCHT,INHEP(2),
44996      & INID(2,2),JBT
44997 C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
44998 C--RMS CLUSTER COORDINATES (GAUSSIAN) AND C*LIFETIME (IN MM)
44999       DOUBLE PRECISION VCLX,VCLY,VCLZ,VCLT,HWRGAU,HWRGEN
45000       EXTERNAL HWREXP,HWRINT,HWRGAU,HWRGEN
45001       SAVE VCLX,VCLY,VCLZ,VCLT
45002       DATA VCLX,VCLY,VCLZ,VCLT/4*1D-12/
45003 C--END FIX
45004       IF (IERROR.NE.0) RETURN
45005       IF (.NOT.GENSOF) GOTO 990
45006       IF (IPROC.EQ.8000) THEN
45007 C---SET UP BEAM AND TARGET CLUSTERS
45008     5   NETC=0
45009         DO 10 IBT=1,2
45010         JBT=IBT
45011         IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
45012         IDBT=IDHW(JBT)
45013         IF (IDBT.EQ.73.OR.IDBT.EQ.75) THEN
45014           INID(1,IBT)=HWRINT(1,2)
45015           INID(2,IBT)=110
45016         ELSEIF (IDBT.EQ.91.OR.IDBT.EQ.93) THEN
45017           INID(1,IBT)=116
45018           INID(2,IBT)=HWRINT(7,8)
45019         ELSEIF (IDBT.EQ.30) THEN
45020           INID(1,IBT)=HWRINT(1,2)
45021           INID(2,IBT)=8
45022         ELSEIF (IDBT.EQ.38) THEN
45023           INID(1,IBT)=2
45024           INID(2,IBT)=HWRINT(7,8)
45025         ELSEIF (IDBT.EQ.34) THEN
45026           INID(1,IBT)=3
45027           INID(2,IBT)=HWRINT(7,8)
45028         ELSEIF (IDBT.EQ.46) THEN
45029           INID(1,IBT)=HWRINT(1,2)
45030           INID(2,IBT)=9
45031         ELSEIF (IDBT.EQ.59) THEN
45032           INID(1,IBT)=HWRINT(1,2)
45033           INID(2,IBT)=HWRINT(7,8)
45034         ELSE
45035           CALL HWWARN('HWMEVT',100)
45036           GOTO 999
45037         ENDIF
45038         NETC=NETC+ICHRG(IDBT)
45039      &    -(ICHRG(INID(1,IBT))+ICHRG(INID(2,IBT)))/3
45040         ENFAC=1.
45041         IDHW(NHEP+IBT)=19
45042         IDHEP(NHEP+IBT)=91
45043         ISTHEP(NHEP+IBT)=163+IBT
45044         JMOHEP(1,NHEP+IBT)=JBT
45045    10   CONTINUE
45046         IF (NETC.EQ.0) THEN
45047           ID3=HWRINT(1,2)
45048         ELSEIF (NETC.EQ.-1) THEN
45049           ID3=1
45050         ELSEIF (NETC.EQ.1) THEN
45051           ID3=2
45052         ELSE
45053           GOTO 5
45054         ENDIF
45055         DO 12 IBT=1,2
45056         NHEP=NHEP+1
45057         JBT=IBT
45058         IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
45059         CALL HWVEQU(5,PHEP(1,JBT),PHEP(1,NHEP))
45060    12   INHEP(IBT)=NHEP
45061       ELSE
45062 C---FIND BEAM AND TARGET CLUSTERS
45063         DO 20 IBT=1,2
45064         DO 15 KHEP=1,NHEP
45065         IF (ISTHEP(KHEP).EQ.163+IBT) THEN
45066           INHEP(IBT)=KHEP
45067           INID(1,IBT)=IDHW(JMOHEP(1,KHEP))
45068           INID(2,IBT)=IDHW(JMOHEP(2,KHEP))
45069           GOTO 20
45070         ENDIF
45071    15   CONTINUE
45072 C---COULDN'T FIND ONE
45073         INHEP(IBT)=0
45074    20   CONTINUE
45075         JCL=-1
45076 C---TEST FOR BOTH FOUND
45077         IF (INHEP(1).EQ.0) JCL=INHEP(2)
45078         IF (INHEP(2).EQ.0) JCL=INHEP(1)
45079         IF (JCL.EQ.0) THEN
45080           CALL HWWARN('HWMEVT',101)
45081           GOTO 999
45082         ENDIF
45083         IF (JCL.GT.0) THEN
45084           ISTHEP(JCL)=163
45085           CALL HWCFOR
45086           CALL HWCDEC
45087           CALL HWDHAD
45088           CALL HWDHVY
45089           GOTO 90
45090         ENDIF
45091         ID3=HWRINT(1,2)
45092         ENFAC=ENSOF
45093         NETC=0
45094       ENDIF
45095 C---FIND SOFT CM MOMENTUM AND MULTIPLICITY
45096       NTRY=0
45097       NHEP=NHEP+1
45098       IF (NHEP.GT.NMXHEP) THEN
45099         CALL HWWARN('HWMEVT',102)
45100         GOTO 999
45101       ENDIF
45102       ICMS=NHEP
45103       IDHW(NHEP)=16
45104       IDHEP(NHEP)=0
45105 C--Bug Fix 31/03/00 PR
45106       JMOHEP(1,ICMS)=INHEP(1)
45107       JMOHEP(2,ICMS)=INHEP(2)
45108 C--End of Fix
45109       ISTHEP(NHEP)=170
45110       CALL HWVSUM(4,PHEP(1,INHEP(1)),PHEP(1,INHEP(2)),PHEP(1,NHEP))
45111       CALL HWUMAS(PHEP(1,NHEP))
45112       TECM=PHEP(5,NHEP)
45113       IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN
45114         SECM=TECM*ENFAC
45115       ELSE
45116         SECM=PHEP(5,3)*ENFAC
45117       ENDIF
45118 C---CHOOSE MULTIPLICITY
45119    25 CALL HWMULT(SECM,NPPBAR)
45120    30 NCL=0
45121       MCHT=0
45122       IERROR=0
45123       NHEP =ICMS
45124       SUMM=0.
45125       NTRY=NTRY+1
45126 C---CREATE CLUSTERS
45127    35 NCL=NCL+1
45128       NHEP=NHEP+1
45129       IF (NHEP.GT.NMXHEP) THEN
45130         CALL HWWARN('HWMEVT',103)
45131         GOTO 999
45132       ENDIF
45133       JCL=NHEP
45134       IDHW(JCL)=19
45135       IDHEP(JCL)=91
45136       IF (NCL.LT.3) THEN
45137         ISTHEP(JCL)=170+NCL
45138         ID1=INID(1,NCL)
45139         ID2=INID(2,NCL)
45140       ELSE
45141         ID1=ID2-6
45142         IF (NCL.EQ.3) ID1=ID3
45143         ID2=HWRINT(7,8)
45144         ISTHEP(JCL)=173
45145       ENDIF
45146       JMOHEP(1,JCL)=ICMS
45147       JMOHEP(2,JCL)=0
45148       CALL HWVZRO(3,PHEP(1,JCL))
45149       PHEP(4,JCL)=RMASS(ID1)+RMASS(ID2)+PMBM1+HWREXP(TWO/PMBM2)
45150       PHEP(5,JCL)=PHEP(4,JCL)
45151 C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
45152 C--VERTEX POSITION FOR CLUSTER FORMATION
45153       VHEP(1,JCL)=HWRGAU(1,ZERO,VCLX)
45154       VHEP(2,JCL)=HWRGAU(2,ZERO,VCLY)
45155       VHEP(3,JCL)=HWRGAU(3,ZERO,VCLZ)
45156       VHEP(4,JCL)=SQRT(VHEP(1,JCL)**2+VHEP(2,JCL)**2+VHEP(3,JCL)**2)
45157      &            -VCLT*LOG(HWRGEN(0))
45158 C--MHS FIX 07/03/05 - MEASURE DISPLACEMENTS RELATIVE TO SOFT CM
45159       CALL HWVZRO(4,VTXPIP)
45160 C--END FIXES
45161 C---HADRONIZE AND DECAY CLUSTERS
45162       CALL HWCFLA(ID1,ID2,JD1,JD2)
45163       CALL HWCHAD(JCL,JD1,JD2,JD3)
45164       IF (IERROR.NE.0) RETURN
45165       IF (JD3.EQ.0) THEN
45166         EMCL=RMASS(IDHW(NHEP))
45167         IF (PHEP(4,JCL).NE.EMCL) THEN
45168           PHEP(4,JCL)=EMCL
45169           PHEP(5,JCL)=EMCL
45170           PHEP(4,NHEP)=EMCL
45171           PHEP(5,NHEP)=EMCL
45172         ENDIF
45173       ELSE
45174         EMCL=PHEP(5,JCL)
45175       ENDIF
45176       IDCL(NCL)=JD3
45177       PPCL(5,NCL)=EMCL
45178       SUMM=SUMM +EMCL
45179       CALL HWDHAD
45180       CALL HWDHVY
45181       IF (IERROR.NE.0) RETURN
45182 C---CHECK CHARGED MULTIPLICITY
45183       MODC=0
45184       DO 50 KHEP=JCL,NHEP
45185       IF (ISTHEP(KHEP).EQ.1) THEN
45186          ICH=ICHRG(IDHW(KHEP))
45187          IF (ICH.NE.0) THEN
45188             MCHT=MCHT+ABS(ICH)
45189             MODC=MODC+ICH
45190          ENDIF
45191       ENDIF
45192    50 CONTINUE
45193       IF (NCL.EQ.1) THEN
45194          NCHT=NPPBAR+NETC+ABS(MODC)
45195          GOTO 35
45196       ELSEIF (NCL.EQ.2) THEN
45197          NCHT=NCHT+ABS(MODC)
45198          IF (NCHT.LT.0) NCHT=NCHT+2
45199       ENDIF
45200       IF (MCHT.LT.NCHT) THEN
45201         GOTO 35
45202       ELSEIF (MCHT.GT.NCHT) THEN
45203         IF (MOD(NTRY,50).EQ.0) GOTO 25
45204         IF (NTRY.LT.NSTRY) GOTO 30
45205 C---NO PHASE SPACE FOR SOFT EVENT
45206         NHEP=ICMS-1
45207         IF (IPROC.EQ.8000) THEN
45208 C---MINIMUM BIAS: RELABEL BEAM AND TARGET CLUSTERS
45209           DO 60 IBT=1,2
45210             KHEP=INHEP(IBT)
45211             LHEP=JMOHEP(1,KHEP)
45212             ISTHEP(KHEP)=1
45213             IDHEP(KHEP)=IDHEP(LHEP)
45214             IDHW(KHEP)=IDHW(LHEP)
45215    60     CONTINUE
45216         ELSE
45217 C---UNDERLYING EVENT: DECAY THEM
45218           ISTHEP(INHEP(1))=163
45219           ISTHEP(INHEP(2))=163
45220           CALL HWCFOR
45221           CALL HWCDEC
45222           CALL HWDHAD
45223           CALL HWDHVY
45224         ENDIF
45225         GOTO 90
45226       ENDIF
45227 C---GENERATE CLUSTER MOMENTA IN CLUSTER CM
45228 C   FRAME.   N.B. SECOND CLUSTER IS TARGET
45229       IF (SUMM.GT.TECM) GOTO 25
45230       CALL HWMLPS(TECM)
45231       IF (NCL.EQ.0) GOTO 25
45232       JCL=0
45233 C---ROTATE & BOOST CLUSTERS & DECAY PRODUCTS
45234       CALL HWULOF(PHEP(1,ICMS),PHEP(1,INHEP(1)),BMP)
45235       CALL HWUROT(BMP, ONE,ZERO,BMR)
45236 C---BMR PUTS BEAM ALONG Z AXIS (WE WANT INVERSE)
45237       DO 70 KHEP=ICMS+1,NHEP
45238       IF (ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
45239      $       .AND.JMOHEP(1,KHEP).EQ.ICMS) THEN
45240           ISTHEP(KHEP)=ISTHEP(KHEP)+3
45241           LHEP=KHEP
45242           JCL=JCL+1
45243           CALL HWUROB(BMR,PPCL(1,JCL),PPCL(1,JCL))
45244           CALL HWULOB(PHEP(1,ICMS),PPCL(1,JCL),PPCL(1,JCL))
45245 C---NOW PPCL(*,JCL) IS LAB MOMENTUM OF JTH CLUSTER
45246       ENDIF
45247       CALL HWULOB(PPCL(1,JCL),PHEP(1,KHEP),PHEP(1,KHEP))
45248 C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
45249       CALL HWULOB(PPCL(1,JCL),VHEP(1,KHEP),VHEP(1,KHEP))
45250 C--MHS FIX 07/03/05 - ASSUME THAT SOFT CM COINCIDES WITH PRIMARY IP
45251       IF (.NOT.(ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
45252      $       .AND.JMOHEP(1,KHEP).EQ.ICMS))
45253      $     CALL HWVSUM(4,VHEP(1,3),VHEP(1,KHEP),VHEP(1,KHEP))
45254 C--END FIXES
45255    70 CONTINUE
45256       ISTHEP(INHEP(1))=167
45257       ISTHEP(INHEP(2))=168
45258       JDAHEP(1,INHEP(1))=ICMS
45259       JDAHEP(2,INHEP(1))=0
45260       JDAHEP(1,INHEP(2))=ICMS
45261       JDAHEP(2,INHEP(2))=0
45262       JDAHEP(1,ICMS)=ICMS+1
45263       JDAHEP(2,ICMS)=LHEP
45264    90 CONTINUE
45265   990 ISTAT=100
45266  999  RETURN
45267       END
45268 CDECK  ID>, HWMLPS.
45269 *CMZ :-        -04/05/99  14.17.04  by  Bryan Webber
45270 *-- Author :    David Ward, modified by Bryan Webber
45271 C-----------------------------------------------------------------------
45272       SUBROUTINE HWMLPS(TECM)
45273 C-----------------------------------------------------------------------
45274 C     GENERATES CYLINDRICAL PHASE SPACE USING THE METHOD OF JADACH
45275 C     RETURNS WITH NCL=0 IF UNSUCCESSFUL
45276 C-----------------------------------------------------------------------
45277       INCLUDE 'herwig65.inc'
45278       DOUBLE PRECISION HWREXT,HWRUNG,HWUSQR,TECM,ESS,ALOGS,EPS,SUMX,
45279      & SUMY,PT,PX,PY,PT2,SUMPT2,SUMTM,XIMIN,XIMAX,YY,SUM1,SUM2,SUM3,
45280      & SUM4,EX,FY,DD,DYY,ZZ,E1,TM,SLOP,XI(NMXCL)
45281       INTEGER NTRY,I,NIT,IY(NMXCL),IDP
45282       EXTERNAL HWREXT,HWRUNG,HWUSQR
45283       IF (NCL.GT.NMXCL) THEN
45284         CALL HWWARN('HWMLPS',1)
45285         NCL=NMXCL
45286       ENDIF
45287       ESS=TECM**2
45288       ALOGS=LOG(ESS)
45289       EPS=1D-10/NCL
45290       NTRY=0
45291   11  NTRY=NTRY+1
45292       IF (NTRY.GT.NSTRY) THEN
45293         NCL=0
45294         RETURN
45295       ENDIF
45296       SUMX=0.
45297       SUMY=0.
45298       DO 12 I=1,NCL
45299 C---Pt distribution of form exp(-b*Mt)
45300 C---Factors for pt slopes to fit data.  IDCL contains the type of
45301 C   q-qbar pair produced in this cluster (0 if 1-particle cluster).
45302       IDP=IDCL(I)
45303       IF (IDP.LE.2) THEN
45304         SLOP=PMBP1
45305       ELSEIF(IDP.EQ.3.OR.IDP.EQ.10) THEN
45306         SLOP=PMBP2
45307       ELSEIF(IDP.GT.3.AND.IDP.LE.9) THEN
45308         SLOP=PMBP3
45309       ELSE
45310         CALL HWWARN('HWMLPS',IDP)
45311         IF(IDP.LT.0.OR.IDP.GT.49) GOTO 999
45312         SLOP=PMBP2
45313       ENDIF
45314       PT=HWREXT(PPCL(5,I),SLOP)
45315       PT=HWUSQR(PT**2-PPCL(5,I)**2)
45316       CALL HWRAZM(PT,PX,PY)
45317       PPCL(1,I)=PX
45318       PPCL(2,I)=PY
45319       SUMX=SUMX+PPCL(1,I)
45320   12  SUMY=SUMY+PPCL(2,I)
45321       SUMX=SUMX/NCL
45322       SUMY=SUMY/NCL
45323       SUMPT2=0.
45324       SUMTM=0.
45325       DO 13 I=1,NCL
45326       PPCL(1,I)=PPCL(1,I)-SUMX
45327       PPCL(2,I)=PPCL(2,I)-SUMY
45328       PT2=PPCL(1,I)**2+PPCL(2,I)**2
45329       SUMPT2=SUMPT2+PT2
45330 C---STORE TRANSVERSE MASS IN PPCL(3,I) TEMPORARILY
45331       PPCL(3,I)=SQRT(PT2+PPCL(5,I)**2)
45332   13  SUMTM=SUMTM+PPCL(3,I)
45333       IF (SUMTM.GT.TECM) GOTO 11
45334       DO 14 I=1,NCL
45335 C---Form of "reduced rapidity" distribution
45336       XI(I)=HWRUNG(0.6*ONE,ONE)
45337   14  CONTINUE
45338       CALL HWUSOR(XI,NCL,IY,1)
45339       XIMIN=XI(1)
45340       XIMAX=XI(NCL)-XI(1)
45341 C---N.B. TARGET CLUSTER IS SECOND
45342       XI(1)=0.
45343       DO 16 I=NCL-1,2,-1
45344       XI(I+1)=(XI(I)-XIMIN)/XIMAX
45345   16  CONTINUE
45346       XI(2)=1.
45347       YY=LOG(ESS/(PPCL(3,1)*PPCL(3,2)))
45348       DO 18 NIT=1,10
45349       SUM1=0.
45350       SUM2=0.
45351       SUM3=0.
45352       SUM4=0.
45353       DO 19 I=1,NCL
45354       TM=PPCL(3,I)
45355       EX=EXP(YY*XI(I))
45356       SUM1=SUM1+(TM*EX)
45357       SUM2=SUM2+(TM/EX)
45358       SUM3=SUM3+(TM*EX)*XI(I)
45359   19  SUM4=SUM4+(TM/EX)*XI(I)
45360       FY=ALOGS-LOG(SUM1*SUM2)
45361       DD=(SUM3*SUM2-SUM1*SUM4)/(SUM1*SUM2)
45362       DYY=FY/DD
45363       IF(ABS(DYY/YY).LT.EPS) GOTO 20
45364   18  YY=YY+DYY
45365 C---Y ITERATIONS EXCEEDED - TRY AGAIN
45366       IF (NTRY.LT.100) GOTO 11
45367       EPS=10.*EPS
45368       IF (EPS.GT.ONE) THEN
45369         CALL HWWARN('HWMLPS',100)
45370         GOTO 999
45371       ENDIF
45372       CALL HWWARN('HWMLPS',50)
45373       GOTO 11
45374    20 YY=YY+DYY
45375       ZZ=LOG(TECM/SUM1)
45376       DO 22 I=1,NCL
45377       TM=PPCL(3,I)
45378       E1=EXP(ZZ+YY*XI(I))
45379       PPCL(3,I)=(0.5*TM)*((1./E1)-E1)
45380       PPCL(4,I)=(0.5*TM)*((1./E1)+E1)
45381   22  CONTINUE
45382  999  RETURN
45383       END
45384 CDECK  ID>, HWMNBI.
45385 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
45386 *-- Author :    David Ward, modified by Bryan Webber
45387 C-----------------------------------------------------------------------
45388       FUNCTION HWMNBI(N,AVNCH,EK)
45389 C-----------------------------------------------------------------------
45390 C---Computes negative binomial probability
45391 C-----------------------------------------------------------------------
45392       IMPLICIT NONE
45393       DOUBLE PRECISION HWMNBI,AVNCH,EK,R
45394       INTEGER N,I
45395       IF(N.LE.0) THEN
45396        HWMNBI=0
45397       ELSE
45398        R=AVNCH/EK
45399        HWMNBI=(1.+R)**(-EK)
45400        R=R/(1.+R)
45401        DO 1 I=1,N
45402        HWMNBI=HWMNBI*R*(EK+I-1)/I
45403     1  CONTINUE
45404       ENDIF
45405       END
45406 CDECK  ID>, HWMODK.
45407 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
45408 *-- Author :    Ian Knowles
45409 C-----------------------------------------------------------------------
45410       SUBROUTINE HWMODK(IDKTMP,BRTMP,IMETMP,
45411      & IATMP,IBTMP,ICTMP,IDTMP,IETMP)
45412 C-----------------------------------------------------------------------
45413 C     Takes the decay, IDKTMP -> I-(A+B+C+D+E)-TMP, and simply stores it
45414 C     if internal pointers not set up (.NOT.DKPSET) else if pre-existing
45415 C     mode updates branching ratio BRTMP and matrix element code IMETMP,
45416 C     if -ve leaves as is. If a new mode adds to table and if consistent
45417 C     adjusts pointers,  sets CMMOM (for two-body mode) and resets RSTAB
45418 C     if necessary.  The branching ratios of any other IDKTMP decays are
45419 C     scaled by (1.-BRTMP)/(1.-BR_OLD)
45420 C-----------------------------------------------------------------------
45421       INCLUDE 'herwig65.inc'
45422       DOUBLE PRECISION HWUPCM,BRTMP,SCALE,EPS
45423       INTEGER IDKTMP,IMETMP,IATMP,IBTMP,ICTMP,IDTMP,IETMP,IDKY,ITMP(5),
45424      & L,I,J,K,JPREV
45425       LOGICAL MATCH(5),IFGO
45426       CHARACTER*8 CDUM
45427       EXTERNAL HWUPCM
45428       PARAMETER (EPS=1.D-6)
45429 C Convert to internal format
45430       CALL HWUIDT(1,IDKTMP,IDKY,CDUM)
45431       IF (IDKY.EQ.20) THEN
45432         WRITE(6,10) IDKTMP
45433   10    FORMAT(1X,'Particle decaying,',I7,', is not recognised')
45434         RETURN
45435       ENDIF
45436       CALL HWUIDT(1,IATMP,ITMP(1),CDUM)
45437       CALL HWUIDT(1,IBTMP,ITMP(2),CDUM)
45438       CALL HWUIDT(1,ICTMP,ITMP(3),CDUM)
45439       CALL HWUIDT(1,IDTMP,ITMP(4),CDUM)
45440       CALL HWUIDT(1,IETMP,ITMP(5),CDUM)
45441 C If internal pointers not yet set up simply store decay
45442       IF (.NOT.DKPSET) THEN
45443         NDKYS=NDKYS+1
45444         IF (NDKYS.GT.NMXDKS) THEN
45445           CALL HWWARN('HWMODK',100)
45446           GOTO 999
45447         ENDIF
45448         IDK(NDKYS)=IDKY
45449         BRFRAC(NDKYS)=BRTMP
45450         NME(NDKYS)=IMETMP
45451         DO 20 I=1,5
45452   20    IDKPRD(I,NDKYS)=ITMP(I)
45453       ELSE
45454         IF (NMODES(IDKY).GT.0) THEN
45455 C First search to see if mode pre-exists
45456           IF ((ITMP(2).GE.1.AND.ITMP(2).LE.13).OR.
45457      &        (ITMP(3).GE.1.AND.ITMP(3).LE.13)) THEN
45458 C Partonic respect order
45459             L=LSTRT(IDKY)
45460             DO 30 K=1,NMODES(IDKY)
45461                 IF (ITMP(1).EQ.IDKPRD(1,L).AND.
45462      &              ITMP(2).EQ.IDKPRD(2,L).AND.
45463      &              ITMP(3).EQ.IDKPRD(3,L).AND.
45464      &              ITMP(4).EQ.IDKPRD(4,L).AND.
45465      &              ITMP(5).EQ.IDKPRD(5,L)) GOTO 90
45466   30        L=LNEXT(L)
45467           ELSE
45468 C Allow for different order in matching
45469             L=LSTRT(IDKY)
45470             DO 70 I=1,NMODES(IDKY)
45471             DO 40 J=1,5
45472   40        MATCH(J)=.FALSE.
45473             DO 60 J=1,5
45474             DO 50 K=1,5
45475             IF (.NOT.MATCH(K).AND.ITMP(K).EQ.IDKPRD(J,L)) THEN
45476               MATCH(K)=.TRUE.
45477               GOTO 60
45478             ENDIF
45479   50        CONTINUE
45480   60        CONTINUE
45481             IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
45482      &          MATCH(4).AND.MATCH(5)) GOTO 90
45483   70        L=LNEXT(L)
45484           ENDIF
45485         ENDIF
45486 C A new mode put decay products in table
45487         NDKYS=NDKYS+1
45488         IF (NDKYS.GT.NMXDKS) THEN
45489           CALL HWWARN('HWMODK',101)
45490           GOTO 999
45491         ENDIF
45492         DO 80 I=1,5
45493   80    IDKPRD(I,NDKYS)=ITMP(I)
45494 C If decay consistent set up new pointers
45495         CALL HWDCHK(IDKY,NDKYS,IFGO)
45496         IF(IFGO) GOTO 980
45497         IF (NMODES(IDKY).EQ.0) THEN
45498           LSTRT(IDKY)=NDKYS
45499           IF (RLTIM(IDKY).LT.PLTCUT.AND.RMASS(IDKY).NE.ZERO) THEN
45500             RSTAB(IDKY)=.FALSE.
45501             DKLTM(IDKY)=RLTIM(IDKY)*RMASS(IDKY)/HBAR
45502           ELSE
45503             RSTAB(IDKY)=.TRUE.
45504           ENDIF
45505         ELSE
45506           LNEXT(L)=NDKYS
45507         ENDIF
45508         NMODES(IDKY)=NMODES(IDKY)+1
45509         LNEXT(NDKYS)=NDKYS
45510         L=NDKYS
45511 C Set CMMOM if two body decay
45512         IF (NPRODS(L).EQ.2) CMMOM(L)=
45513      &   HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,L)),RMASS(IDKPRD(2,L)))
45514 C A Pre-existing mode, line L, add/update ME code and BR, scaling all
45515 C other branching fractions
45516   90    IF (IMETMP.GT.0) NME(L)=IMETMP
45517         IF (ABS(BRTMP-1.).LT.EPS) THEN
45518 C This modes dominant: eliminate others
45519           NMODES(IDKY)=1
45520           LSTRT(IDKY)=L
45521           BRFRAC(L)=ONE
45522           LNEXT(L)=L
45523         ELSEIF (ABS(BRTMP).LT.EPS) THEN
45524 C This mode insignificant: eliminate it
45525           IF (NMODES(IDKY).EQ.1) THEN
45526             RSTAB(IDKY)=.TRUE.
45527           ELSE
45528             J=LSTRT(IDKY)
45529             IF (J.EQ.L) THEN
45530               LSTRT(IDKY)=LNEXT(J)
45531             ELSE
45532               JPREV=J
45533               DO 100 I=2,NMODES(IDKY)
45534               J=LNEXT(J)
45535               IF (J.EQ.L) LNEXT(JPREV)=LNEXT(J)
45536   100         JPREV=J
45537             ENDIF
45538 C           Rescale other modes
45539             SCALE=ONE/(ONE-BRFRAC(L))
45540             J=LSTRT(IDKY)
45541             DO 110 I=1,NMODES(IDKY)-1
45542             BRFRAC(J)=SCALE*BRFRAC(J)
45543   110       J=LNEXT(J)
45544           ENDIF
45545           NMODES(IDKY)=NMODES(IDKY)-1
45546         ELSE
45547 C Rescale all other modes
45548           IF (NMODES(IDKY).EQ.1) THEN
45549             BRFRAC(L)=ONE
45550           ELSE
45551             IF (L.EQ.NDKYS) THEN
45552               SCALE=ONE-BRTMP
45553             ELSE
45554               SCALE=(ONE-BRTMP)/(ONE-BRFRAC(L))
45555             ENDIF
45556             J=LSTRT(IDKY)
45557             DO 120 I=1,NMODES(IDKY)
45558             IF (J.NE.L) BRFRAC(J)=SCALE*BRFRAC(J)
45559   120       J=LNEXT(J)
45560             BRFRAC(L)=BRTMP
45561           ENDIF
45562         ENDIF
45563       ENDIF
45564       GOTO 999
45565   980 WRITE(6,990)
45566   990 FORMAT(1X,'Decay mode inconsistent, no modifications made')
45567  999  RETURN
45568       END
45569 CDECK  ID>, HWMULT.
45570 *CMZ :-        -04/05/99  11.11.55  by  Bryan Webber
45571 *-- Author :    David Ward, modified by Bryan Webber
45572 C-----------------------------------------------------------------------
45573       SUBROUTINE HWMULT(EPPBAR,NCHT)
45574 C-----------------------------------------------------------------------
45575 C     Chooses charged multiplicity NCHT at the p-pbar c.m. energy EPPBAR
45576 C-----------------------------------------------------------------------
45577       INCLUDE 'herwig65.inc'
45578       DOUBLE PRECISION HWMNBI,HWRGEN,EPPBAR,E0,ALOGS,RK,EK,AVN,SUM,R,
45579      & CUM(500)
45580       INTEGER NCHT,IMAX,I,N
45581       SAVE E0,CUM,IMAX
45582       EXTERNAL HWMNBI,HWRGEN
45583       DATA E0/0/
45584       IF (EPPBAR.NE.E0) THEN
45585          E0=EPPBAR
45586 C---Initialize
45587          ALOGS=2.*LOG(EPPBAR)
45588          RK=PMBK1*ALOGS+PMBK2
45589          IF (ABS(RK).GT.1000.) RK=1000.
45590          EK=1./RK
45591          AVN=PMBN1*EXP(PMBN2*ALOGS)+PMBN3
45592          IF (AVN.LT.ONE) AVN=1.
45593          SUM=0.
45594          IMAX=1
45595          DO 10 I=1,500
45596          N=2*I
45597          CUM(I)=HWMNBI(N,AVN,EK)
45598          IF (CUM(I).LT.1D-7*SUM) GOTO 11
45599          IMAX=I
45600          SUM=SUM+CUM(I)
45601          CUM(I)=SUM
45602   10     CONTINUE
45603   11     CONTINUE
45604          IF (IMAX.LE.1) THEN
45605             IMAX=1
45606             CUM(1)=1
45607          ELSEIF (IMAX.EQ.500) THEN
45608             E0=0
45609             CALL HWWARN('HWMULT',101)
45610             GOTO 999
45611          ELSE
45612             DO 12 I=1,IMAX
45613   12        CUM(I)=CUM(I)/SUM
45614          ENDIF
45615       ENDIF
45616 C --- Select NCHT
45617       R=HWRGEN(0)
45618       DO 20 I=1,IMAX
45619       IF(R.GT.CUM(I)) GOTO 20
45620       NCHT=2*I
45621       RETURN
45622   20  CONTINUE
45623       CALL HWWARN('HWMULT',100)
45624  999  RETURN
45625       END
45626 CDECK  ID>, HWMWGT.
45627 *CMZ :-        -02/11/93  11.11.55  by  Bryan Webber
45628 *-- Author :    Bryan Webber
45629 C-----------------------------------------------------------------------
45630       SUBROUTINE HWMWGT
45631 C-----------------------------------------------------------------------
45632 C COMPUTES WEIGHT FOR MINIMUM-BIAS EVENT
45633 C-----------------------------------------------------------------------
45634       INCLUDE 'herwig65.inc'
45635       DOUBLE PRECISION S,X,Y
45636       INTEGER IDB,IDT,IDBT
45637       IF (IERROR.NE.0) RETURN
45638       IDB=IDHW(1)
45639       IF (JDAHEP(1,1).NE.0) IDB=IDHW(JDAHEP(1,1))
45640       IDT=IDHW(2)
45641       IF (JDAHEP(1,2).NE.0) IDT=IDHW(JDAHEP(1,2))
45642       IDBT=100*IDB+IDT
45643       IF (IDT.GT.IDB) IDBT=100*IDT+IDB
45644 C---USE TOTAL CROSS SECTION FITS OF DONNACHIE & LANDSHOFF
45645 C   CERN-TH.6635/92
45646       IF (IDBT.EQ.9173) THEN
45647         X=21.70
45648         Y=98.39
45649       ELSEIF (IDBT.EQ.7373) THEN
45650         X=21.70
45651         Y=56.08
45652       ELSEIF (IDBT.EQ.7330) THEN
45653         X=13.63
45654         Y=36.02
45655       ELSEIF (IDBT.EQ.7338) THEN
45656         X=13.63
45657         Y=27.56
45658       ELSEIF (IDBT.EQ.7334) THEN
45659         X=11.82
45660         Y=26.36
45661       ELSEIF (IDBT.EQ.7346) THEN
45662         X=11.82
45663         Y= 8.15
45664       ELSEIF (IDBT.EQ.7359) THEN
45665         X=.0677
45666         Y=.1290
45667       ELSEIF (IDBT.EQ.9175) THEN
45668         X=21.70
45669         Y=92.71
45670       ELSEIF (IDBT.EQ.7573) THEN
45671         X=21.70
45672         Y=54.77
45673       ELSEIF (IDBT.EQ.5959) THEN
45674 C---FOR GAMMA-GAMMA ASSUME X AND Y FACTORIZE
45675         X=2.1E-4
45676         Y=3.0E-4
45677       ELSE
45678         PRINT *,' IDBT=',IDBT
45679         CALL HWWARN('HWMWGT',100)
45680         GOTO 999
45681       ENDIF
45682       S=PHEP(5,3)**2
45683 C---EVWGT IS NON-DIFFRACTIVE CROSS SECTION IN NANOBARNS
45684 C   ASSUMING NON-DIFFRACTIVE = TOTAL*0.7
45685       EVWGT=.7E6*(X*S**.0808 + Y*S**(-.4525))
45686  999  RETURN
45687       END
45688 CDECK  ID>, HWPHTP.
45689 *CMZ :-        -11/08/03  15:30:25  by  Peter Richardson
45690 *-- Author :    Peter Richardson and Zbigniew Was
45691 C-----------------------------------------------------------------------
45692       SUBROUTINE HWPHTP(IHEP)
45693 C-----------------------------------------------------------------------
45694 C     subroutine for radiation in top decays
45695 C-----------------------------------------------------------------------
45696       INCLUDE 'herwig65.inc'
45697       INTEGER IHEP,KK,IPOS,NN,NHEP0,KK1,KK2,JMOH(NMXHEP)
45698       DOUBLE PRECISION HWDPWT
45699       EXTERNAL HWDPWT
45700 C--add an extra photon for top or W
45701       IF(IERROR.NE.0) RETURN
45702       IF(ABS(IDHEP(IHEP)).EQ.6.OR.ABS(IDHEP(IHEP)).EQ.24) THEN
45703         NHEP0=NHEP
45704         KK1=JDAHEP(1,IHEP)
45705         KK2=JDAHEP(2,IHEP)
45706 C--copy the colour mother infomation
45707         DO KK=KK1,KK2
45708           JMOH(KK)=JMOHEP(2,KK)
45709           JMOHEP(2,KK)=0
45710         ENDDO
45711 C--call photos
45712         IPOS=-IHEP
45713         CALL PHOTOS(IPOS)
45714 C--reset the colour mother infomation
45715         DO KK=KK1,KK2
45716           JMOHEP(2,KK)=JMOH(KK)
45717         ENDDO
45718 C--update the decaying particle
45719         JDAHEP(2,IHEP) = NHEP
45720 C--set up the additions photons in the record
45721         NN=NHEP-NHEP0
45722         NHEP=NHEP0
45723         IF(NN.GT.0) THEN
45724           DO KK=1,NN
45725 C--photon mass probably not needed
45726             PHEP(5,NHEP+1) = ZERO
45727 C--info on the photon
45728             ISTHEP(NHEP+1) = 114
45729             IDHW(NHEP+1) = 59
45730             IDHEP(NHEP+1) = 22
45731             JMOHEP(1,NHEP+1) = IHEP
45732             JMOHEP(2,NHEP+1) = NHEP+1
45733             JDAHEP(2,NHEP+1) = NHEP+1
45734             NHEP = NHEP+1
45735           ENDDO
45736         ENDIF
45737       ENDIF
45738       END
45739 CDECK  ID>, HWPHTT.
45740 *CMZ :-        -11/08/03  15:30:25  by  Peter Richardson
45741 *-- Author :    Peter Richardson and Zbigniew Was
45742 C-----------------------------------------------------------------------
45743       SUBROUTINE HWPHTT
45744 C-----------------------------------------------------------------------
45745 C     subroutine for radiation in top production
45746 C-----------------------------------------------------------------------
45747       INCLUDE 'herwig65.inc'
45748 C--local variables
45749       INTEGER IMO(10),IFOUND,JMO(2),I,J,K,L,NSTART,NHEPX
45750 C--initialisation
45751       IF(IERROR.NE.0) RETURN
45752       IFOUND=0
45753       DO K=1,10
45754         IMO(K)=0
45755       ENDDO
45756 C--loop to find mothers of any tops
45757       NSTART=1
45758       DO I=NSTART,NHEP
45759         IF (ABS(IDHEP(I)).EQ.6) THEN
45760           DO K=1,IFOUND
45761            IF(IMO(K).EQ.JMOHEP(1,I)) GOTO 10
45762           ENDDO
45763           IFOUND=IFOUND+1
45764           IMO(IFOUND)=JMOHEP(1,I)
45765         ENDIF
45766  10     CONTINUE
45767       ENDDO
45768 C--generate the radiation
45769       DO K=1,IFOUND
45770 C--save the colour mother pointers
45771         JMO(1)=JMOHEP(2,JDAHEP(1,IMO(K)))
45772         JMO(2)=JMOHEP(2,1+JDAHEP(1,IMO(K)))
45773 C--zero the second mothers
45774         JMOHEP(2,JDAHEP(1,IMO(K)))=0
45775         JMOHEP(2,JDAHEP(2,IMO(K)))=0
45776 C--call photos to generate radiation
45777         CALL PHOTOS(IMO(K))
45778         NHEPX=NHEP
45779         DO 11 J=NHEP,1,-1
45780           IF(IDHEP(J).EQ.22) THEN
45781             NHEPX=NHEPX-1
45782           ELSE
45783             GOTO 11
45784           ENDIF
45785  11     CONTINUE
45786 C--reset the colour pointers
45787         JMOHEP(2,  JDAHEP(1,IMO(K)))=JMO(1)
45788         JMOHEP(2,1+JDAHEP(1,IMO(K)))=JMO(2)
45789 C--setup the photons
45790         DO L=NHEPX+1,NHEP
45791           ISTHEP(L)=114
45792           JMOHEP(2,L) = L
45793           JDAHEP(2,L) = L
45794           IDHW(L) = 59
45795         ENDDO
45796       ENDDO
45797       END
45798 CDECK  ID>, HWRAZM.
45799 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
45800 *-- Author :    Bryan Webber
45801 C-----------------------------------------------------------------------
45802       SUBROUTINE HWRAZM(PT,PX,PY)
45803 C-----------------------------------------------------------------------
45804 C     RANDOMLY ROTATED 2-VECTOR (PX,PY) OF LENGTH PT
45805 C-----------------------------------------------------------------------
45806       IMPLICIT NONE
45807       DOUBLE PRECISION HWRGEN,PT,PX,PY,C,S,CS,QT,ONE,ZERO
45808       PARAMETER(ONE=1.0D0, ZERO=0.0D0)
45809       EXTERNAL HWRGEN
45810    10 C=2.*HWRGEN(1)-1.
45811       S=2.*HWRGEN(2)-1.
45812       CS=C*C+S*S
45813       IF (CS.GT.ONE .OR. CS.EQ.ZERO) GOTO 10
45814       QT=PT/CS
45815       PX=(C*C-S*S)*QT
45816       PY=2.*C*S*QT
45817       END
45818 CDECK  ID>, HWREXP.
45819 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
45820 *-- Author :    David Ward, modified by Bryan Webber
45821 C-----------------------------------------------------------------------
45822       FUNCTION HWREXP(AV)
45823 C-----------------------------------------------------------------------
45824 C     Random number from dN/d(x**2)=exp(-b*x) with mean AV
45825 C-----------------------------------------------------------------------
45826       IMPLICIT NONE
45827       DOUBLE PRECISION HWREXP,HWRGEN,AV,B,R1,R2
45828       EXTERNAL HWRGEN
45829       B=2./AV
45830       R1=HWRGEN(0)
45831       R2=HWRGEN(1)
45832       HWREXP=-LOG(R1*R2)/B
45833       END
45834 CDECK  ID>, HWREXQ.
45835 *CMZ :-        -02/06/94  11.02.47  by  Mike Seymour
45836 *-- Author :    David Ward, modified by Bryan Webber and Mike Seymour
45837 C-----------------------------------------------------------------------
45838       FUNCTION HWREXQ(AV,XMAX)
45839 C-----------------------------------------------------------------------
45840 C     Random number from dN/d(x**2)=EXQ(-b*x) with mean AV,
45841 C     But truncated at XMAX
45842 C-----------------------------------------------------------------------
45843       IMPLICIT NONE
45844       DOUBLE PRECISION HWREXQ,HWRGEN,AV,B,BXMAX,R1,R2,XMAX,R,RMIN
45845       EXTERNAL HWRGEN
45846       B=2./AV
45847       BXMAX=B*XMAX
45848       IF (BXMAX.LT.50) THEN
45849         RMIN=EXP(-BXMAX)
45850       ELSE
45851         RMIN=0
45852       ENDIF
45853  10   R1=HWRGEN(0)*(1-RMIN)+RMIN
45854       R2=HWRGEN(1)*(1-RMIN)+RMIN
45855       R=R1*R2
45856       IF (R.LT.RMIN) GOTO 10
45857       HWREXQ=-LOG(R)/B
45858       END
45859 CDECK  ID>, HWREXT.
45860 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
45861 *-- Author :    David Ward, modified by Bryan Webber
45862 C-----------------------------------------------------------------------
45863       FUNCTION HWREXT(AM0,B)
45864 C-----------------------------------------------------------------------
45865 C     Random number from dN/d(x**2)=exp(-B*TM) distribution, where
45866 C     TM = SQRT(X**2+AM0**2).  Uses Newton's method to solve F-R=0
45867 C-----------------------------------------------------------------------
45868       IMPLICIT NONE
45869       DOUBLE PRECISION HWREXT,HWRGEN,AM0,B,R,A,F,DF,DAM,AM
45870       INTEGER NIT
45871       EXTERNAL HWRGEN
45872       R=HWRGEN(0)
45873 C --- Starting value
45874       AM=AM0-LOG(R)/B
45875       DO 1 NIT=1,20
45876       A=EXP(-B*(AM-AM0))/(1.+B*AM0)
45877       F=(1.+B*AM)*A-R
45878       DF=-B**2*AM*A
45879       DAM=-F/DF
45880       AM=AM+DAM
45881       IF(AM.LT.AM0) AM=AM0+.001
45882       IF(ABS(DAM).LT..001) GOTO 2
45883    1  CONTINUE
45884       CALL HWWARN('HWREXT',1)
45885    2  HWREXT=AM
45886       END
45887 CDECK  ID>, HWRGAU.
45888 *CMZ :-        -19/05/99  11.11.56  by  Mike Seymour
45889 *-- Author :    Mike Seymour
45890 C-----------------------------------------------------------------------
45891       FUNCTION HWRGAU(J,A,B)
45892 C-----------------------------------------------------------------------
45893 C     Gaussian random number, mean A, standard deviation B.
45894 C     Generates uncorrelated pairs and throws one of them away.
45895 C-----------------------------------------------------------------------
45896       INCLUDE 'herwig65.inc'
45897       DOUBLE PRECISION HWRGAU,HWRGEN,A,B,X,TRASH
45898       INTEGER J
45899       EXTERNAL HWRGEN
45900  10   X=HWRGEN(J)
45901       IF (X.LE.ZERO.OR.X.GT.ONE) GOTO 10
45902       X=SQRT(-TWO*LOG(X))
45903       CALL HWRAZM(X,X,TRASH)
45904       HWRGAU=A+B*X
45905       END
45906 CDECK  ID>, HWRGEN.
45907 *CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
45908 *-- Author :    F. James, modified by Mike Seymour
45909 *- Split in 3 files by M. Kirsanov. Initial seeds ISEED set in HWUDAT
45910 C-----------------------------------------------------------------------
45911       FUNCTION HWRGEN(I)
45912 C-----------------------------------------------------------------------
45913 C     MAIN RANDOM NUMBER GENERATOR
45914 C     USES METHOD OF l'Ecuyer, (VIA F.JAMES, COMP PHYS COMM 60(1990)329)
45915 C-----------------------------------------------------------------------
45916       IMPLICIT NONE
45917       DOUBLE PRECISION HWRGEN
45918       COMMON/HWSEED/ISEED(2)
45919       INTEGER ISEED
45920       INTEGER I,K,IZ
45921 C
45922       K=ISEED(1)/53668
45923       ISEED(1)=40014*(ISEED(1)-K*53668)-K*12211
45924       IF (ISEED(1).LT.0) ISEED(1)=ISEED(1)+2147483563
45925       K=ISEED(2)/52774
45926       ISEED(2)=40692*(ISEED(2)-K*52774)-K*3791
45927       IF (ISEED(2).LT.0) ISEED(2)=ISEED(2)+2147483399
45928       IZ=ISEED(1)-ISEED(2)
45929       IF (IZ.LT.1) IZ=IZ+2147483562
45930       HWRGEN=DBLE(IZ)*4.656613001013252D-10
45931 C--->                (4.656613001013252D-10 = 1.D0/2147483589)
45932       END
45933 CDECK  ID>, HWRSET.
45934 *CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
45935 *-- Author :    F. James, modified by Mike Seymour
45936 C-----------------------------------------------------------------------
45937       FUNCTION HWRSET(JSEED)
45938 C-----------------------------------------------------------------------
45939 C     MAIN RANDOM NUMBER GENERATOR
45940 C     SETTING SEEDS
45941 C-----------------------------------------------------------------------
45942       IMPLICIT NONE
45943       DOUBLE PRECISION HWRSET
45944       COMMON/HWSEED/ISEED(2)
45945       INTEGER ISEED
45946       INTEGER JSEED(2)
45947       HWRSET=0.0D0
45948       IF (JSEED(1).EQ.0.OR.JSEED(2).EQ.0) THEN
45949         CALL HWWARN('HWRSET',99)
45950         GOTO 999
45951       ENDIF
45952       ISEED(1)=JSEED(1)
45953       ISEED(2)=JSEED(2)
45954  999  RETURN
45955       END
45956 CDECK  ID>, HWRGET.
45957 *CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
45958 *-- Author :    F. James, modified by Mike Seymour
45959 C-----------------------------------------------------------------------
45960       FUNCTION HWRGET(JSEED)
45961 C-----------------------------------------------------------------------
45962 C     MAIN RANDOM NUMBER GENERATOR
45963 C     GET SEEDS
45964 C-----------------------------------------------------------------------
45965       IMPLICIT NONE
45966       DOUBLE PRECISION HWRGET
45967       COMMON/HWSEED/ISEED(2)
45968       INTEGER ISEED
45969       INTEGER JSEED(2)
45970 C
45971       JSEED(1)=ISEED(1)
45972       JSEED(2)=ISEED(2)
45973       HWRGET=0.0D0
45974       END
45975 CDECK  ID>, HWRINT.
45976 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
45977 *-- Author :    Bryan Webber
45978 C-----------------------------------------------------------------------
45979       FUNCTION HWRINT(IMIN,IMAX)
45980 C-----------------------------------------------------------------------
45981 C     RANDOM INTEGER IN [IMIN,IMAX]. N.B. ASSUMES IMAX.GE.IMIN
45982 C-----------------------------------------------------------------------
45983       IMPLICIT NONE
45984       DOUBLE PRECISION HWRGEN,RN,ONE
45985       INTEGER HWRINT,IMIN,IMAX
45986       EXTERNAL HWRGEN
45987       PARAMETER (ONE=1.0D0)
45988     1 RN=HWRGEN(0)
45989       IF (RN.EQ.ONE) GOTO 1
45990       RN=RN*(IMAX-IMIN+1)
45991       HWRINT=IMIN+INT(RN)
45992       END
45993 CDECK  ID>, HWRLOG.
45994 *CMZ :-        -26/04/91  14.15.56  by  Federico Carminati
45995 *-- Author :    Bryan Webber
45996 C-----------------------------------------------------------------------
45997       FUNCTION HWRLOG(A)
45998 C-----------------------------------------------------------------------
45999 C     Returns .TRUE. with probability A
46000 C-----------------------------------------------------------------------
46001       IMPLICIT NONE
46002       DOUBLE PRECISION HWRGEN,A,R
46003       LOGICAL HWRLOG
46004       EXTERNAL HWRGEN
46005       HWRLOG=.TRUE.
46006       R=HWRGEN(0)
46007       IF(R.GT.A) HWRLOG=.FALSE.
46008       END
46009 CDECK  ID>, HWRPIP.
46010 *CMZ :-        -07/09/00  10:06:23  by Peter Richardson
46011 *-- Author :    Ian Knowles
46012 C-----------------------------------------------------------------------
46013       SUBROUTINE HWRPIP
46014 C-----------------------------------------------------------------------
46015 C     Generates a random primary IP using a triple Gaussian distribution
46016 C-----------------------------------------------------------------------
46017       INCLUDE 'herwig65.inc'
46018       DOUBLE PRECISION HWRGAU
46019       INTEGER I
46020       EXTERNAL HWRGAU
46021       DO 10 I=1,3
46022   10  VTXPIP(I)=HWRGAU(I,ZERO,VIPWID(I))
46023       VTXPIP(4)=ZERO
46024       END
46025 CDECK  ID>, HWRPOW.
46026 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
46027 *-- Author :    Bryan Webber
46028 C-----------------------------------------------------------------------
46029       SUBROUTINE HWRPOW(XVAL,XJAC)
46030 C-----------------------------------------------------------------------
46031 C     RETURNS XVAL DISTRIBUTED ON (XMIN,XMAX) LIKE XVAL**XPOW
46032 C     AND CORRESPONDING JACOBIAN FACTOR XJAC
46033 C     SET FIRST=.TRUE. IF NEW XMIN,XMAX OR XPOW
46034 C-----------------------------------------------------------------------
46035       IMPLICIT NONE
46036       DOUBLE PRECISION HWRGEN,XVAL,XJAC,XMIN,XMAX,XPOW,P,Q,A,B,C,Z,ZERO
46037       LOGICAL FIRST
46038       PARAMETER(ZERO=0.0D0)
46039       EXTERNAL HWRGEN
46040       SAVE Q,A,B,C
46041       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
46042       IF (FIRST) THEN
46043         P=XPOW+1.
46044         IF (P.EQ.ZERO) CALL HWWARN('HWRPOW',500)
46045         Q=1./P
46046         A=XMIN**P
46047         B=XMAX**P-A
46048         C=B*Q
46049         FIRST=.FALSE.
46050       ENDIF
46051       Z=A+B*HWRGEN(0)
46052       XVAL=Z**Q
46053       XJAC=XVAL*C/Z
46054       END
46055 CDECK  ID>, HWRUNG.
46056 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
46057 *-- Author :    David Ward, modified by Bryan Webber
46058 C-----------------------------------------------------------------------
46059       FUNCTION HWRUNG(A,B)
46060 C-----------------------------------------------------------------------
46061 C     Random number from distribution having flat top [-A,A] & gaussian
46062 C     tail of s.d. B
46063 C-----------------------------------------------------------------------
46064       IMPLICIT NONE
46065       DOUBLE PRECISION HWRUNG,HWRGAU,HWRUNI,A,B,PRUN,ZERO
46066       LOGICAL HWRLOG
46067       EXTERNAL HWRGAU,HWRUNI,HWRLOG
46068       PARAMETER (ZERO=0.D0)
46069       IF (A.EQ.ZERO) THEN
46070         PRUN=0
46071       ELSE
46072         PRUN=1./(1.+B*1.2533/A)
46073       ENDIF
46074       IF(HWRLOG(PRUN)) THEN
46075         HWRUNG=HWRUNI(0,-A,A)
46076       ELSE
46077         HWRUNG=HWRGAU(0,ZERO,B)
46078         HWRUNG=HWRUNG+SIGN(A,HWRUNG)
46079       ENDIF
46080       END
46081 CDECK  ID>, HWRUNI.
46082 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
46083 *-- Author :    Bryan Webber
46084 C-----------------------------------------------------------------------
46085       FUNCTION HWRUNI(I,A,B)
46086 C-----------------------------------------------------------------------
46087 C     Uniform random random number in range [A,B]
46088 C-----------------------------------------------------------------------
46089       IMPLICIT NONE
46090       DOUBLE PRECISION HWRUNI,HWRGEN,A,B,RN
46091       INTEGER I
46092       EXTERNAL HWRGEN
46093       RN=HWRGEN(I)
46094       HWRUNI=A+RN*(B-A)
46095       END
46096 CDECK  ID>, HWSBRN.
46097 *CMZ :-        -18/10/99  19.08.45  by  Mike Seymour
46098 *-- Author :    Bryan Webber
46099 C-----------------------------------------------------------------------
46100       SUBROUTINE HWSBRN(KPAR)
46101 C-----------------------------------------------------------------------
46102 C     DOES BRANCHING OF SPACELIKE PARTON KPAR
46103 C-----------------------------------------------------------------------
46104       INCLUDE 'herwig65.inc'
46105       DOUBLE PRECISION HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,
46106      & HWSSUD,XLAST,QNOW,QLST,QP,QMIN,QLAM,QSAV,SMAX,SLST,SNOW,RN,SUDA,
46107      & SUDB,ZZ,ENOW,XI,PMOM,DIST(13),DMIN,X1,X2,REJFAC,OTHXI,OTHZ,QTMP,
46108      & PTMP(2),JAC,OTHJAC,S,T,U,EMB2,PTMX
46109       INTEGER N0,IS,ID,ID1,ID2,IDHAD,N1,I,MQ,NTRY,NDEL,NA,NB,IW1,IW2,
46110      & KPAR,LPAR,MPAR,ISUD(13),IREJ,NREJ
46111       LOGICAL HWSVAL,FORCE,VALPAR,FTMP
46112       EXTERNAL HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,HWSSUD,
46113      & HWSVAL
46114       COMMON/HWTABC/XLAST,N0,IS,ID
46115       SAVE ISUD,DMIN
46116       DATA ISUD,DMIN/2,2,3,4,5,6,2,2,3,4,5,6,1,1.D-15/
46117       IF (IERROR.NE.0) RETURN
46118       ID=IDPAR(KPAR)
46119 C--TEST FOR PARTON TYPE
46120       IF (ID.LE.13) THEN
46121         IS=ISUD(ID)
46122       ELSEIF (ID.GE.208) THEN
46123         IS=7
46124       ELSE
46125         IS=0
46126       END IF
46127       QNOW=-1.
46128       IF (IS.NE.0) THEN
46129 C--SPACELIKE PARTON BRANCHING
46130         QLST=PPAR(1,KPAR)
46131         IDHAD=IDHW(INHAD)
46132         VALPAR=HWSVAL(ID)
46133         QP=HWBVMC(ID)
46134         XLAST=XFACT*PPAR(4,KPAR)
46135         IF (XLAST.GE.ONE) THEN
46136           CALL HWWARN('HWSBRN',107)
46137           GOTO 999
46138         ENDIF
46139 C--SET UP Q BOUNDARY
46140         IF (VALPAR) THEN
46141           QMIN=QG/(1.-XLAST)
46142         ELSEIF (ID.EQ.13) THEN
46143           QMIN=QV/(1.-XLAST)
46144         ELSE
46145           QMIN=.5*(QP+QV+SQRT((QP-QV)**2+4.*QP*QV*XLAST))/(1.-XLAST)
46146         ENDIF
46147         QSAV=QMIN
46148         IF (QMIN.LE.QSPAC.AND.ISPAC.LT.2) THEN
46149           QMIN=QSPAC
46150           N1=NSPAC(IS)
46151         ELSEIF (QMIN.LE.QEV(1,IS)) THEN
46152           QMIN=QEV(1,IS)
46153           N1=1
46154         ELSE
46155           DO 110 I=2,NQEV
46156           IF (QEV(I,IS).GT.QMIN) GOTO 120
46157   110     CONTINUE
46158   120     N1=I-1
46159         ENDIF
46160         N0=N1-1
46161         MQ=NQEV-N0
46162         NTRY=0
46163   125   NTRY=NTRY+1
46164         NREJ=1
46165         IF (QLST.GT.QMIN.AND..NOT.NOSPAC.OR..NOT.VALPAR) THEN
46166           IF (QLST.LE.QMIN) THEN
46167 C--CHECK PHASE SPACE FOR FORCED SPLITTING OF NON-VALENCE PARTON
46168             IF (QLST.LT.QSAV) THEN
46169               CALL HWWARN('HWSBRN',ISLENT*105)
46170               GOTO 999
46171             ENDIF
46172             FORCE=.TRUE.
46173             QNOW=(QLST/QSAV)**HWRGEN(0)*QSAV
46174           ELSE
46175 C--ENHANCE EMISSION BY A FACTOR OF TWO IF THIS BRANCH
46176 C  IS CAPABLE OF BEING THE HARDEST SO FAR
46177            IF (QLST.GT.HARDST) NREJ=2
46178            QTMP=-1
46179            DO 300 IREJ=1,NREJ
46180 C--FIND NEW VALUE OF SUD/DIST
46181             CALL HWSFUN(XLAST,QMIN,IDHAD,NSTRU,DIST,JNHAD)
46182             IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QMIN)
46183             IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
46184             SMAX=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QMIN,INTER)/DIST(ID)
46185             CALL HWSFUN(XLAST,QLST,IDHAD,NSTRU,DIST,JNHAD)
46186             IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QLST)
46187             IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
46188             SLST=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QLST,INTER)/DIST(ID)
46189             RN=HWRGEN(0)
46190             IF (RN.EQ.ZERO) THEN
46191               SNOW=SLST*2.
46192             ELSE
46193               SNOW=SLST/RN
46194             ENDIF
46195             IF (VALPAR.AND.SNOW.GE.SMAX) GOTO 200
46196             IF (SNOW.LT.SMAX.AND..NOT.NOSPAC) THEN
46197               FORCE=.FALSE.
46198             ELSE
46199 C--FORCE SPLITTING OF NON-VALENCE PARTON
46200               FORCE=.TRUE.
46201               QNOW=(MIN(QLST,1.1*QMIN)/QSAV)**HWRGEN(0)*QSAV
46202             ENDIF
46203             IF (QNOW.LT.ZERO) THEN
46204 C--BRANCHING OCCURS. FIRST CHECK FOR MONOTONIC FORM FACTOR
46205               SUDA=SMAX
46206               NDEL=32
46207               NA=N1
46208   130         NB=NA+NDEL
46209               IF (NB.GT.NQEV) THEN
46210                 CALL HWWARN('HWSBRN',103)
46211                 GOTO 999
46212               ENDIF
46213               CALL HWSFUN(XLAST,QEV(NB,IS),IDHAD,NSTRU,DIST,JNHAD)
46214               IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QEV(NB,IS))
46215               IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
46216               SUDB=SUD(NB,IS)/DIST(ID)
46217               IF (SUDB.GT.SUDA) THEN
46218                 SUDA=SUDB
46219                 NA=NB
46220                 GOTO 130
46221               ELSEIF (NA.NE.N1) THEN
46222                 IF (SUDB.LT.SNOW) THEN
46223                   NDEL=NDEL/2
46224                   IF (NDEL.EQ.0) THEN
46225                     CALL HWWARN('HWSBRN',100)
46226                     GOTO 999
46227                   ENDIF
46228                   GOTO 130
46229                 ENDIF
46230                 N1=NB
46231                 N0=N1-1
46232                 MQ=NQEV-N0
46233               ENDIF
46234 C--NOW FIND NEW Q
46235               QNOW=HWSTAB(QEV(N1,IS),HWSSUD,MQ,SNOW,INTER)
46236               IF (QNOW.LE.QMIN.OR.QNOW.GT.QLST) THEN
46237 C--INTERPOLATION PROBLEM: USE LINEAR INSTEAD
46238 C                CALL HWWARN('HWSBRN',1)
46239                 QNOW=HWRUNI(0,QMIN,QLST)
46240               ENDIF
46241             ENDIF
46242  200        CONTINUE
46243             IF (QNOW.GT.QTMP) THEN
46244               QTMP=QNOW
46245               FTMP=FORCE
46246             ENDIF
46247             QNOW=-1
46248  300       CONTINUE
46249            QNOW=QTMP
46250            FORCE=FTMP
46251           ENDIF
46252           IF (QNOW.LT.ZERO) GOTO 210
46253 C--NOW FIND NEW X
46254           CALL HWSFBR(XLAST,QNOW,FORCE,ID,1,ID1,ID2,IW1,IW2,ZZ)
46255           IF (ID1.LT.0) THEN
46256 C--NO PHASE SPACE FOR BRANCHING
46257             FROST=.TRUE.
46258             RETURN
46259           ELSEIF (ID1.EQ.0) THEN
46260 C--BRANCHING REJECTED: REDUCE Q AND REPEAT
46261             IF (NTRY.GT.NBTRY.OR.IERROR.NE.0) THEN
46262               CALL HWWARN('HWSBRN',102)
46263               GOTO 999
46264             ENDIF
46265             QLST=QNOW
46266             QNOW=-1.
46267             GOTO 125
46268           ELSEIF (ID1.EQ.59) THEN
46269 C--ANOMALOUS PHOTON SPLITTING: ADD PT TO INTRINSIC PT AND STOP BRANCHING
46270             IF (IDHAD.NE.59) THEN
46271               CALL HWWARN('HWSBRN',109)
46272               GOTO 999
46273             ENDIF
46274             ENOW=PPAR(4,KPAR)/XLAST
46275             XI=(QNOW/ENOW)**2
46276             QLAM=QNOW*(1.-XLAST)
46277             IF ((2.-XI)*QLAM**2.GT.EMSCA**2) THEN
46278 C--BRANCHING REJECTED: REDUCE Q AND REPEAT
46279               IF (NTRY.GT.NBTRY) THEN
46280                 CALL HWWARN('HWSBRN',110)
46281                 GOTO 999
46282               ENDIF
46283               QLST=QNOW
46284               QNOW=-1.
46285               GOTO 125
46286             ENDIF
46287             CALL HWRAZM(QNOW*(1.-XLAST),PTMP(1),PTMP(2))
46288             CALL HWVSUM(2,PTMP,PTINT(1,JNHAD),PTINT(1,JNHAD))
46289             PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
46290             ANOMSC(1,JNHAD)=QNOW
46291             ANOMSC(2,JNHAD)=QNOW*(1.-XLAST)
46292             QNOW=-1.
46293             QLST=QNOW
46294             GOTO 125
46295           ELSEIF (FORCE.AND..NOT.HWSVAL(ID1).AND.ID1.NE.13) THEN
46296 C--FORCED BRANCHING PRODUCED A NON-VALENCE PARTON: TRY AGAIN
46297             IF (NTRY.GT.NBTRY) THEN
46298               CALL HWWARN('HWSBRN',108)
46299               GOTO 999
46300             ENDIF
46301             QLST=QNOW
46302             QNOW=-1.
46303             GOTO 125
46304           ENDIF
46305         ENDIF
46306   210   CONTINUE
46307         IF (QNOW.GT.ZERO) THEN
46308 C--BRANCHING HAS OCCURRED
46309           ENOW=PPAR(4,KPAR)/ZZ
46310           XI=(QNOW/ENOW)**2
46311           QLAM=QNOW*(1.-ZZ)
46312           IF ((SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
46313      &        (2.-XI)*QLAM**2.GT.EMSCA**2).AND..NOT.FORCE) THEN
46314 C--BRANCHING REJECTED: REDUCE Q AND REPEAT
46315               IF (NTRY.GT.NBTRY) THEN
46316                 CALL HWWARN('HWSBRN',104)
46317                 GOTO 999
46318               ENDIF
46319               QLST=QNOW
46320               QNOW=-1.
46321               GOTO 125
46322           ENDIF
46323 C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
46324           IF (.NOT.FORCE) THEN
46325             REJFAC=1
46326             IF (QLAM.GT.HARDST .AND. ID.NE.13) THEN
46327               IF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
46328 C---COLOUR PARTNER IS OUTGOING (X1=XP, X2=ZP)
46329                 X2=SQRT((ZZ**2-(1-ZZ)*XI)**2+2*(ZZ*(1-ZZ))**2*XI*(2-XI))
46330                 X1=(ZZ**2+(1-ZZ)*XI-X2)/(2*(1-ZZ)*XI)
46331                 X2=(ZZ**2-(1-ZZ)*XI+X2)/(2*ZZ**2)
46332                 IF (ID2.EQ.13) THEN
46333 C---GLUON EMISSION
46334                   REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
46335      $                 /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
46336      $                 *(1+ZZ**2)/((1-ZZ)*XI)
46337      $                 *(1-X1)*(1-X2)/
46338      $                 (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
46339 C---CHECK WHETHER IT IS IN THE OVERLAP REGION
46340                   OTHXI=2*(1-X1)/(1-X1+2*(3*X1-2)*X2*(1-X2))
46341                   IF (OTHXI.LT.ONE) THEN
46342                     OTHZ=(1-(2*X2-1)*SQRT((3*X1-2)/X1))/2
46343                     REJFAC=REJFAC+SQRT(3-2/X1)/(X1**2*OTHZ*(1-OTHZ))
46344      $               *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
46345      $               *(1-X1)*(1-X2)/
46346      $               (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
46347                   ENDIF
46348                 ELSEIF (ID1.EQ.13) THEN
46349 C---GLUON SPLITTING
46350                   REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
46351      $                 /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
46352      $                 *(ZZ**2+(1-ZZ)**2)/XI
46353      $                 *(1-X2)/
46354      $                 ((  X1+X2-2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2
46355      $                 +(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
46356                 ENDIF
46357               ELSE
46358 C---COLOUR PARTNER IS ALSO INCOMING
46359                 T=-(1-ZZ)*XI/ZZ**2
46360                 S=2*(ZZ**2+(1-ZZ)*XI)/(ZZ**2*(2*ZZ+XI*(1-ZZ)))
46361                 U=1-S-T
46362                 JAC=-T*(1-T)/S**2*ZZ**5/(XI*(1-ZZ)**2*(ZZ+XI*(1-ZZ)))
46363                 IF (ID2.EQ.13) THEN
46364 C---GLUON EMISSION
46365                   REJFAC=(1+ZZ**2)/((1-ZZ)*ZZ*XI)
46366      &                 *JAC*S**2*T*U/((1-U)**2+(1-T)**2)
46367 C---CHECK WHETHER IT IS IN THE OVERLAPPING REGION
46368                   OTHZ=(1+SQRT(1-2*U*(1-U)/S))/U
46369                   OTHXI=2*(1-OTHZ+T/S)/(1-OTHZ)
46370                   IF (OTHXI.LT.OTHZ**2) THEN
46371                     OTHJAC=-U*(1-U)/S**2*OTHZ**5/(OTHXI*
46372      &                   (1-OTHZ)**2*(OTHZ+OTHXI*(1-OTHZ)))
46373                     REJFAC=REJFAC+(1+OTHZ**2)/((1-OTHZ)*OTHZ*OTHXI)
46374      &                   *OTHJAC*S**2*T*U/((1-U)**2+(1-T)**2)
46375                   ENDIF
46376                 ELSEIF (ID1.EQ.13) THEN
46377 C---GLUON SPLITTING
46378                   REJFAC=-((1-ZZ)**2+ZZ**2)/(ZZ*XI)
46379      &                 *JAC*S**3*T/((1-S)**2+(1-T)**2)
46380                 ENDIF
46381               ENDIF
46382             ENDIF
46383             IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
46384               QLST=QNOW
46385               QNOW=-1.
46386               GOTO 125
46387             ENDIF
46388             IF (QLAM.GT.HARDST) HARDST=QLAM
46389           ENDIF
46390           IF (IW2.GT.IW1) THEN
46391             LPAR=NPAR+1
46392             MPAR=NPAR+2
46393 C---NEW MOTHER-DAUGHTER RELATIONS
46394 C   N.B. DEFINED MOVING AWAY FROM HARD PROCESS
46395             JDAPAR(1,KPAR)=LPAR
46396             JDAPAR(2,KPAR)=MPAR
46397 C---NEW COLOUR CONNECTIONS
46398             JCOPAR(3,KPAR)=MPAR
46399             JCOPAR(4,KPAR)=LPAR
46400             JCOPAR(1,MPAR)=KPAR
46401             JCOPAR(2,MPAR)=LPAR
46402             JCOPAR(1,LPAR)=MPAR
46403             JCOPAR(2,LPAR)=KPAR
46404           ELSE
46405             MPAR=NPAR+1
46406             LPAR=NPAR+2
46407             JDAPAR(1,KPAR)=MPAR
46408             JDAPAR(2,KPAR)=LPAR
46409             JCOPAR(3,KPAR)=LPAR
46410             JCOPAR(4,KPAR)=MPAR
46411             JCOPAR(1,MPAR)=LPAR
46412             JCOPAR(2,MPAR)=KPAR
46413             JCOPAR(1,LPAR)=KPAR
46414             JCOPAR(2,LPAR)=MPAR
46415           ENDIF
46416           JMOPAR(1,LPAR)=KPAR
46417           JMOPAR(1,MPAR)=KPAR
46418           IDPAR(LPAR)=ID1
46419           IDPAR(MPAR)=ID2
46420           TMPAR(LPAR)=.FALSE.
46421           TMPAR(MPAR)=.TRUE.
46422           PPAR(1,LPAR)=QNOW
46423           PPAR(2,LPAR)=XI
46424           PPAR(4,LPAR)=ENOW
46425           PPAR(1,MPAR)=QNOW*(1.-ZZ)
46426           PPAR(2,MPAR)=XI
46427           PPAR(4,MPAR)=ENOW*(1.-ZZ)
46428           NPAR=NPAR+2
46429         ENDIF
46430       ENDIF
46431       IF (QNOW.LT.ZERO) THEN
46432 C--BRANCHING STOPS
46433         JDAPAR(1,KPAR)=0
46434         JDAPAR(2,KPAR)=0
46435         JCOPAR(3,KPAR)=0
46436         JCOPAR(4,KPAR)=0
46437         IF (ID.LE.13) THEN
46438 C---PUT SPECTATOR (APPROXIMATELY) ON-SHELL
46439           XLAST=XFACT*PPAR(4,KPAR)
46440           IF ((1-XLAST)**2.LT.(RMASS(ID)**2+PTINT(3,JNHAD))*XFACT**2)
46441      &         THEN
46442             FROST=.TRUE.
46443             RETURN
46444           ENDIF
46445 C---BRW MOD: INCLUDE HIGHER ORDER CORRECTION IN MASS CALCULATION
46446 c$$$          PPAR(5,KPAR)=-(RMASS(ID)**2*XLAST+PTINT(3,JNHAD))/(1.-XLAST)
46447 c$$$     &         +XLAST*SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
46448           PTMX=(RMASS(ID)**2+PTINT(3,JNHAD))/(ONE-XLAST)
46449           EMB2=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
46450           PPAR(5,KPAR)=-PTINT(3,JNHAD)-XLAST*(PTMX-EMB2)-0.25D0*
46451      $     ((PTMX-EMB2)**2+XLAST*(PTMX**2/(ONE-XLAST)-EMB2**2))*XFACT**2
46452 C---END BRW MOD
46453         ELSEIF (ID.EQ.IDHW(INHAD)) THEN
46454 C---IF INCOMING PARTON IS INCOMING BEAM, ALLOW IT TO BE OFF-SHELL
46455           PPAR(5,KPAR)=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
46456         ELSE
46457           PPAR(5,KPAR)=RMASS(ID)**2
46458         ENDIF
46459         PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
46460         IF (PMOM.LT.ZERO) THEN
46461           FROST=.TRUE.
46462           RETURN
46463         ENDIF
46464         PPAR(3,KPAR)=SQRT(PMOM)
46465       ENDIF
46466  999  RETURN
46467       END
46468 CDECK  ID>, HWSDGG.
46469 *CMZ :=        =26/04/91  12.47.48  by  Federico Carminati
46470 *-- Author :    Drees, Grassie, Charchula, modified by Bryan Webber
46471 C ===============================================================
46472 C  DREES & GRASSIE PARAMETRIZATION OF PHOTON STRUCTURE FUNCTION
46473 C
46474 C    HWSDGQ(X,Q2,NFL,NCH) - X*QUARK_IN_PHOTON/ALPHA  (!)
46475 C    HWSDGG(X,Q2,NFL)     - X*GLUON_IN_PHOTON/ALPHA  (!)
46476 C WHERE:
46477 C        (INTEGER) NCH - QUARK CHARGE: 1 FOR 1/3
46478 C                                      2 FOR 2/3
46479 C        (INTEGER) NFL - NUMBER OF QUARK FLAVOURS /3 OR 4/
46480 C                   Q2 - SQUARE OF MOMENTUM Q /IN GEV2/
46481 C                   X  - LONGITUDINAL FRACTION
46482 C  LAMBDA=0.4 GEV
46483 C
46484 C       NFL=3:     1 < Q2 < 50   GEV^2
46485 C       NFL=4:    20 < Q2 < 500  GEV^2
46486 C       NFL=5:   200 < Q2 < 10^4 GEV^2
46487 C
46488 C
46489 C  KRZYSZTOF CHARCHULA  /14.02.1989/
46490 C================================================================
46491 C
46492 C PS. Note that for the case of three flavors, one has to add
46493 C the QPM charm contribution for getting F2.
46494 C
46495 C================================================================
46496 C MODIFIED FOR HERWIG BY BRW 19/4/91
46497 C--- -----------------------------------------------
46498 C        GLUON PART OF THE PHOTON SF
46499 C--- -----------------------------------------------
46500       FUNCTION HWSDGG(X,Q2,NFL)
46501       IMPLICIT REAL (A-H,P-Z)
46502       INTEGER NFL
46503       DIMENSION A(3,4,3),AT(3)
46504       ALAM2=0.160
46505       T=LOG(Q2/ALAM2)
46506 C- ---  CHECK WHETHER NFL  HAVE RIGHT VALUES -----
46507       IF (.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5)))THEN
46508         WRITE(6,131)
46509  131   FORMAT(' NUMBER OF FLAVOURS(NFL) HAS NOT BEEN SET TO: 3,4 OR 5;'/
46510      *'          NFL=3 IS ASSUMED')
46511        NFL=3
46512       ELSEIF (T.LE.0) THEN
46513        WRITE(6,132)
46514  132   FORMAT(' HWSDGG CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
46515        HWSDGG=0
46516        RETURN
46517       ENDIF
46518 C ------ INITIALIZATION OF PARAMETERS ARRAY -----
46519       DATA(((A(I,J,K),I=1,3),J=1,4),K=1,3)/
46520      + -0.20700,-0.19870, 5.11900,
46521      +  0.61580, 0.62570,-0.27520,
46522      +  1.07400, 8.35200,-6.99300,
46523      +  0.00000, 5.02400, 2.29800,
46524      +    0.8926E-2, 0.05090,-0.23130,
46525      +    0.659400, 0.27740, 0.13820,
46526      +    0.476600,-0.39060, 6.54200,
46527      +    0.019750,-0.32120, 0.51620,
46528      +  0.031970, -0.618E-2, -0.1216,
46529      +  1.0180,    0.94760,  0.90470,
46530      +  0.24610,  -0.60940,  2.6530,
46531      +  0.027070, -0.010670, 0.2003E-2/
46532 C ------ Q2 DEPENDENCE -----------
46533       LF=NFL-2
46534       DO 20 I=1,3
46535         AT(I)=A(I,1,LF)*T**A(I,2,LF)+A(I,3,LF)*T**(-A(I,4,LF))
46536  20   CONTINUE
46537 C ------ GLUON DISTRIBUTION -------------
46538       HWSDGG=AT(1)*X**AT(2)*(1.0-X)**AT(3)/137.
46539       END
46540 CDECK  ID>, HWSDGQ.
46541 *CMZ :-        -26/04/91  13.04.45  by  Federico Carminati
46542 *-- Author :    Drees, Grassie, Charchula, modified by Bryan Webber
46543 C --------------------------------------
46544 C  QUARK PART OF THE PHOTON SF
46545 C --------------------------------------
46546       FUNCTION HWSDGQ(X,Q2,NFL,NCH)
46547       IMPLICIT REAL (A-H,P-Z)
46548       INTEGER NFL,NCH
46549       DIMENSION A(5,4,2,3),AT(5,2),XQPOM(2),E(2)
46550       COMMON/DG/F2
46551 C SQUARE OF LAMBDA=0.4 GEV
46552       ALAM2=0.160
46553       T=LOG(Q2/ALAM2)
46554 C
46555 C  CHECK WHETHER NFL AND NCH HAVE RIGHT VALUES
46556 C
46557       IF(.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5))) THEN
46558        WRITE(6,111)
46559  111   FORMAT('NUMBER OF FLAVOURS (NFL) HAS NOT BEEN SET TO: 3,4 OR 5'/
46560      *'          NFL=3 IS ASSUMED')
46561        NFL=3
46562       ELSEIF (T.LE.0) THEN
46563        WRITE(6,132)
46564  132   FORMAT(' HWSDGQ CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
46565        HWSDGQ=0
46566        RETURN
46567       ENDIF
46568       IF (.NOT.((NCH.EQ.1).OR.(NCH.EQ.2))) THEN
46569          WRITE(6,121)
46570  121     FORMAT(' QUARK CHARGE NUMBER (NCH) HAS NOT BEEN SET',
46571      *'           TO 1 OR 2;'/
46572      *'           NCH=1 IS ASSUMED')
46573          NCH=1
46574       ENDIF
46575 C ------ INITIALIZATION ------
46576       DATA(((A(I,J,K,1),I=1,5),J=1,4),K=1,2)/
46577      + 2.28500,  6.07300, -0.42020,-0.08080, 0.05530,
46578      +-0.01530, -0.81320,  0.01780, 0.63460, 1.13600,
46579      + 1.3300E3,-41.3100,   0.92160, 1.20800, 0.95120,
46580      + 4.21900,  3.16500,  0.18000, 0.20300, 0.01160,
46581      +16.6900,   0.17600, -0.02080,-0.01680,-0.19860,
46582      +-0.79160,  0.04790,  0.3386E-2,1.35300, 1.10000,
46583      + 1.0990E3,  1.04700,  4.85300, 1.42600, 1.13600,
46584      + 4.42800,  0.02500,  0.84040, 1.23900,-0.27790/
46585         DATA(((A(I,J,K,2),I=1,5),J=1,4),K=1,2)/
46586      +-0.37110,-0.17170, 0.087660,-0.89150,-0.18160,
46587      + 1.06100, 0.78150, 0.021970, 0.28570, 0.58660,
46588      + 4.75800, 1.53500, 0.109600, 2.97300, 2.42100,
46589      +-0.01500, 0.7067E-2,0.204000, 0.11850, 0.40590,
46590      +-0.12070,25.00000,-0.012300,-0.09190, 0.020150,
46591      + 1.07100,-1.64800, 1.162000, 0.79120, 0.98690,
46592      + 1.97700,-0.015630,0.482400, 0.63970,-0.070360,
46593      +-0.8625E-2,6.43800,-0.011000, 2.32700, 0.016940/
46594         DATA(((A(I,J,K,3),I=1,5),J=1,4),K=1,2)/
46595      +15.80,     2.7420,  0.029170,-0.03420, -0.023020,
46596      +-0.94640, -0.73320, 0.046570, 0.71960,  0.92290,
46597      +-0.50,     0.71480, 0.17850,  0.73380,  0.58730,
46598      +-0.21180,  3.2870,  0.048110, 0.081390,-0.79E-4,
46599      + 6.7340,  59.880,  -0.3226E-2,-0.03321,   0.10590,
46600      +-1.0080,  -2.9830,  0.84320,  0.94750,  0.69540,
46601      +-0.085940, 4.480,   0.36160, -0.31980, -0.66630,
46602      + 0.076250, 0.96860, 0.1383E-2, 0.021320, 0.36830/
46603 C ------- EVALUATION OF PARAMETERS IN Q2 ---------
46604       E(1)=1.0
46605       IF (NFL.EQ.3) THEN
46606         E(2)=9.0
46607         LF=1
46608       ELSEIF (NFL.EQ.4) THEN
46609         E(2)=10.0
46610         LF=2
46611       ELSEIF (NFL.EQ.5) THEN
46612         E(2)=55.0/6.0
46613         LF=3
46614       ENDIF
46615       DO 10 J=1,2
46616         DO 20 I=1,5
46617            ATP=A(I,1,J,LF)*T**A(I,2,J,LF)
46618            AT(I,J)=ATP+A(I,3,J,LF)*T**(-A(I,4,J,LF))
46619  20     CONTINUE
46620  10   CONTINUE
46621       DO 30 J=1,2
46622        POM1=X*(X*X+(1.0-X)**2)/(AT(1,J)-AT(2,J)*ALOG(1.0-X))
46623        POM2=AT(3,J)*X**AT(4,J)*(1.0-X)**AT(5,J)
46624        XQPOM(J)=E(J)*POM1+POM2
46625  30   CONTINUE
46626 C -------  QUARK DISTRIBUTIONS ----------
46627       HWSDGQ=0
46628       IF (NFL.EQ.3) THEN
46629          IF (NCH.EQ.2) THEN
46630            HWSDGQ=1.0/6.0*(XQPOM(2)+9.0*XQPOM(1))
46631          ELSEIF(NCH.EQ.1) THEN
46632            HWSDGQ=1.0/6.0*(XQPOM(2)-9.0/2.0*XQPOM(1))
46633          ENDIF
46634         F2=2.0/9.0*XQPOM(2)+XQPOM(1)
46635       ELSEIF (NFL.EQ.4) THEN
46636          IF (NCH.EQ.2) THEN
46637            HWSDGQ=1.0/8.0*(XQPOM(2)+6.0*XQPOM(1))
46638          ELSEIF(NCH.EQ.1) THEN
46639            HWSDGQ=1.0/8.0*(XQPOM(2)-6.0*XQPOM(1))
46640          ENDIF
46641         F2=5.0/18.0*XQPOM(2)+XQPOM(1)
46642       ELSEIF (NFL.EQ.5) THEN
46643          IF (NCH.EQ.2) THEN
46644            HWSDGQ=1.0/10.0*(XQPOM(2)+15.0/2.0*XQPOM(1))
46645          ELSEIF(NCH.EQ.1) THEN
46646            HWSDGQ=1.0/10.0*(XQPOM(2)-5.0*XQPOM(1))
46647          ENDIF
46648         F2=11.0/45.0*XQPOM(2)+XQPOM(1)
46649       ENDIF
46650       HWSDGQ=HWSDGQ/137.
46651       END
46652 CDECK  ID>, HWSFBR.
46653 *CMZ :-        -15/07/92  14.08.45  by  Mike Seymour
46654 *-- Author :    Bryan Webber
46655 C-----------------------------------------------------------------------
46656       SUBROUTINE HWSFBR(X,QQ,FORCED,ID,IW,ID1,ID2,IW1,IW2,Z)
46657 C-----------------------------------------------------------------------
46658 C     FINDS BRANCHING (ID1->ID+ID2) AND Z=X/X1 IN BACKWARD
46659 C     EVOLUTION AT ENERGY FRACTION X AND SCALE QQ
46660 C
46661 C     FORCED=.TRUE. FORCES SPLITTING OF NON-VALENCE PARTON
46662 C
46663 C     IW,IW1,IW2 ARE COLOUR CONNECTION WORDS
46664 C
46665 C     ID1.LT.0 ON RETURN MEANS NO PHASE SPACE
46666 C     ID1.EQ.0 ON RETURN FLAGS REJECTED BRANCHINGS
46667 C-----------------------------------------------------------------------
46668       INCLUDE 'herwig65.inc'
46669       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUAEM,QP,X,QQ,Z,WQG,WQV,
46670      & WQP,XQV,ZMIN,ZMAX,YMIN,YMAX,DELY,YY,PSUM,EZ,WQN,WR,ZR,WZ,ZZ,AZ,
46671      & PVAL,EY,DIST(13),PROB(13,100),PPHO
46672       INTEGER ID,IW,ID1,ID2,IW1,IW2,NZ,IDHAD,IP,IZ
46673       LOGICAL HWRLOG,HWSVAL,FORCED,NONF,NONV,PHOTPR
46674       EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUAEM,HWRLOG,HWSVAL
46675       ID1=-1
46676       QP=HWBVMC(ID)
46677       WQG=1.-QG/QQ
46678       WQV=1.-QV/QQ
46679       WQP=1.-QP/QQ
46680       XQV=X/WQV
46681       NONV=.NOT.HWSVAL(ID)
46682       NONF=.NOT.FORCED
46683       IF (ID.EQ.13) THEN
46684         ZMIN=X
46685         IF (NONF) THEN
46686           ZMAX=WQG
46687         ELSE
46688           ZMAX=WQV
46689         ENDIF
46690       ELSE
46691         IF (NONV) THEN
46692           ZMIN=XQV
46693           IF (NONF) THEN
46694             ZMAX=WQG
46695           ELSE
46696             ZMAX=WQP
46697           ENDIF
46698         ELSE
46699           ZMIN=X
46700           ZMAX=MAX(WQG,WQP)
46701         ENDIF
46702       ENDIF
46703       IF (ZMIN.GE.ZMAX) RETURN
46704       ID1=0
46705 C---INTERPOLATION VARIABLE IS Y=LN(Z/(1-Z))
46706       YMIN=LOG(ZMIN/(1.-ZMIN))
46707       YMAX=LOG(ZMAX/(1.-ZMAX))
46708       DELY=YMAX-YMIN
46709       NZ=MIN(INT(ZBINM*DELY)+1,NZBIN)
46710       DELY=(YMAX-YMIN)/FLOAT(NZ)
46711       YY=YMIN+0.5*DELY
46712       PSUM=0.
46713       IDHAD=IDHW(INHAD)
46714 C---SET UP TABLES FOR CHOOSING BRANCHING
46715       DO 40 IZ=1,NZ
46716       EZ=EXP(YY)
46717       WR=1.+EZ
46718       ZR=WR/EZ
46719       WZ=1./WR
46720       ZZ=WZ*EZ
46721       AZ=WZ*ZZ*HWUALF(5-2*SUDORD,MAX(WZ*QQ,QG))
46722       CALL HWSFUN(X*ZR,QQ,IDHAD,NSTRU,DIST,JNHAD)
46723       IF (ID.NE.13) THEN
46724 C---SPLITTING INTO QUARK
46725         DO 10 IP=1,ID-1
46726    10   PROB(IP,IZ)=PSUM
46727         IF (NONF) PSUM=PSUM+DIST(ID)*AZ*CFFAC*(1.+ZZ*ZZ)*WR
46728         DO 20 IP=ID,12
46729    20   PROB(IP,IZ)=PSUM
46730         PSUM=PSUM+DIST(13)*AZ*0.5*(ZZ*ZZ+WZ*WZ)
46731         PROB(13,IZ)=PSUM
46732       ELSE
46733 C---SPLITTING INTO GLUON
46734         DO 30 IP=1,12
46735         PSUM=PSUM+DIST(IP)*AZ*CFFAC*(1.+WZ*WZ)*ZR
46736    30   PROB(IP,IZ)=PSUM
46737         IF (NONF) PSUM=PSUM+DIST(13)*AZ*2.*CAFAC*(WZ*ZR+ZZ*WR+WZ*ZZ)
46738         PROB(13,IZ)=PSUM
46739       ENDIF
46740    40 YY=YY+DELY
46741    50 PHOTPR=IDHAD.EQ.59.AND.ID.NE.13
46742       IF (PHOTPR) THEN
46743 C---ALLOW ANOMALOUS PHOTON SPLITTING
46744          PPHO=ZMIN*HWUAEM(-QQ*QQ)*CAFAC*(ZMIN**2+(1.-ZMIN)**2)
46745      &        *ICHRG(ID)**2/9D0
46746          IF (PPHO.GT.(PPHO+PSUM*DELY)*HWRGEN(2)) THEN
46747 C---ANOMALOUS PHOTON SPLITTING OCCURRED
46748            ID1=59
46749            RETURN
46750          ENDIF
46751        ENDIF
46752       IF (PSUM.LE.ZERO) RETURN
46753 C---CHOOSE Z
46754       PVAL=PSUM*HWRGEN(0)
46755       DO 60 IZ=1,NZ
46756       IF (PROB(13,IZ).GT.PVAL) GOTO 70
46757    60 CONTINUE
46758       IZ=NZ
46759    70 EY=EXP(YMIN+DELY*(FLOAT(IZ)-HWRGEN(1)))
46760       ZZ=EY/(1.+EY)
46761 C---CHOOSE BRANCHING
46762       DO 80 IP=1,13
46763       IF (PROB(IP,IZ).GT.PVAL) GOTO 90
46764    80 CONTINUE
46765       IP=13
46766 C---CHECK THAT Z IS INSIDE PHASE SPACE (RETURN IF NOT)
46767    90 CONTINUE
46768       IF (ID.NE.13) THEN
46769         IF (IP.EQ.ID) THEN
46770           IF ((NONV.AND.ZZ*WQP.LT.XQV).OR.ZZ.GT.WQG) THEN
46771             IF (PHOTPR) GOTO 50
46772             RETURN
46773           ENDIF
46774         ELSE
46775           IF (ZZ.LT.XQV.OR.ZZ.GT.WQP) THEN
46776             IF (PHOTPR) GOTO 50
46777             RETURN
46778           ENDIF
46779         ENDIF
46780       ELSE
46781         IF (IP.EQ.ID) THEN
46782           IF (ZZ.LT.XQV.OR.ZZ.GT.WQG) RETURN
46783         ELSEIF (.NOT.HWSVAL(IP)) THEN
46784           WQN=1.-HWBVMC(IP)/QQ
46785           IF (ZZ*WQN.LT.XQV.OR.ZZ.GT.WQN) RETURN
46786         ENDIF
46787       ENDIF
46788 C---EVERYTHING OK: LABEL NEW BRANCHES
46789       Z=ZZ
46790       ID1=IP
46791       IW1=IW*2
46792       IW2=IW1+1
46793       IF (ID.LE.6) THEN
46794         IF (ID1.EQ.13) THEN
46795           ID2=ID+6
46796         ELSE
46797           ID2=13
46798           IW2=IW1
46799         ENDIF
46800       ELSE IF (ID.NE.13) THEN
46801         IF (ID1.EQ.13) THEN
46802           ID2=ID-6
46803           IW2=IW1
46804         ELSE
46805           ID2=13
46806         ENDIF
46807       ELSE
46808         ID2=ID1
46809         IF (ID1.EQ.13) THEN
46810           IF (HWRLOG(HALF)) IW2=IW1
46811         ELSE IF (ID1.GT.6) THEN
46812           IW2=IW1
46813         END IF
46814       END IF
46815       IF (IW2.EQ.IW1) IW1=IW1+1
46816       END
46817 CDECK  ID>, HWSFUN.
46818 *CMZ :-        -02/05/91  11.30.51  by  Federico Carminati
46819 *-- Author :    Miscellaneous, combined by Bryan Webber
46820 C-----------------------------------------------------------------------
46821       SUBROUTINE HWSFUN(XIN,SCALE,IDHAD,NSET,DIST,IBEAM)
46822 C-----------------------------------------------------------------------
46823 C     NUCLEON AND PION STRUCTURE FUNCTIONS DIST=X*QRK(X,Q=SCALE)
46824 C
46825 C     IDHAD = TYPE OF HADRON:
46826 C     73=P  91=PBAR  75=N  93=NBAR  38=PI+  30=PI-  59=PHOTON
46827 C
46828 C     NEW SPECIAL CODES:
46829 C     71=`REMNANT PHOTON' 72=`REMNANT NUCLEON'
46830 C
46831 C     NSET = STRUCTURE FUNCTION SET
46832 C          = 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
46833 C          = 3,4 FOR EICHTEN ET AL SETS 1,2 (NUCLEON ONLY)
46834 C          = 5   FOR OWENS SET 1.1 (PREPRINT FSU-HEP-910606)
46835 C
46836 C     FOR PHOTON DREES+GRASSIE IS USED
46837 C
46838 C     N.B. IF IBEAM.GT.0.AND.MODPDF(IBEAM).GE.0 THEN NSET IS
46839 C     IGNORED AND CERN PDFLIB WITH AUTHOR GROUP=AUTPDF(IBEAM) AND
46840 C     SET=MODPDF(IBEAM) IS USED.  FOR COMPATABILITY WITH VERSIONS 3
46841 C     AND EARLIER, AUTPDF SHOULD BE SET TO 'MODE'
46842 C     NOTE THAT NO CONSISTENCY CHECK IS MADE, FOR EXAMPLE THAT THE
46843 C     REQUESTED SET FOR A PHOTON IS ACTUALLY A PHOTON SET
46844 C
46845 C     IF (ISPAC.GT.0) SCALE IS REPLACED BY MAX(SCALE,QSPAC)
46846 C
46847 C     IF (X.LT.PDFX0) REPLACE X*F(X) BY PDFX0*F(PDFX0)*(X/PDFX0)**PDFPOW
46848 C
46849 C     FOR PHOTON, IF (PHOMAS.GT.0) THEN QUARK DISTRIBUTIONS ARE
46850 C     SUPPRESSED BY      LOG((Q**2+PHOMAS**2)/(P**2+PHOMAS**2))
46851 C                    L = -------------------------------------- ,
46852 C                        LOG((Q**2+PHOMAS**2)/(     PHOMAS**2))
46853 C     WHILE GLUON DISTRIBUTIONS ARE SUPPRESSED BY L**2,
46854 C     WHERE Q=SCALE AND P=VIRTUALITY OF THE PHOTON
46855 C
46856 C   DUKE+OWENS = D.W.DUKE AND J.F.OWENS, PHYS. REV. D30 (1984) 49 (P/N)
46857 C              + J.F.OWENS, PHYS. REV. D30 (1984) 943 (PI+/-)
46858 C   WITH EXTRA SIGNIFICANT FIGURES VIA ED BERGER
46859 C   WARNING....MOMENTUM SUM RULE BADLY VIOLATED ABOVE 1 TEV
46860 C   DUKE+OWENS SETS 1,2 OBSOLETE. SET 1 UPDATED TO OWENS 1.1 (1991)
46861 C   PION NOT RELIABLE ABOVE SCALE = 50 GEV
46862 C
46863 C   EICHTEN ET AL = E.EICHTEN,I.HINCHLIFFE,K.LANE AND C.QUIGG,
46864 C                   REV. MOD. PHYS. 56 (1984) 579
46865 C   REVISED AS IN   REV. MOD. PHYS. 58 (1986) 1065
46866 C   RELIABLE RANGE : SQRT(5)GEV < SCALE < 10TEV, 1E-4 < X < 1
46867 C
46868 C   DREES+GRASSIE = M.DREES & K.GRASSIE, ZEIT. PHYS. C28 (1985) 451
46869 C   MODIFIED IN     M.DREES & C.S.KIM, DESY 91-039
46870 C                         AND C.S.KIM, DTP/91/16   FOR HEAVY QUARKS
46871 C
46872 C   FOR CERN PDFLIB DETAILS SEE PDFLIB DOC Q ON CERNVM OR
46873 C   CERN_ROOT:[DOC]PDFLIB.TXT ON VXCERN
46874 C-----------------------------------------------------------------------
46875 C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
46876 C-----------------------------------------------------------------------
46877       INCLUDE 'herwig65.inc'
46878       DOUBLE PRECISION HWSGAM,X,SCALE,XOLD,QOLD,XMWN,QSCA,SS,SMIN,S,T,
46879      & TMIN,TMAX,VX,AA,VT,WT,UPV,DNV,SEA,STR,CHM,BTM,TOP,GLU,WX,XQSUM,
46880      & DMIN,TPMIN,TPMAX,DIST(13),G(2),Q0(5),QL(5),F(5),A(6,5),
46881      & B(3,6,5,4),XQ(6),TX(6),TT(6),TB(6),NEHLQ(8,2),CEHLQ(6,6,2,8,2),
46882      & BB(4,6,5),VAL(20),USEA,DSEA,TOTAL,SCALEF,FAC,TBMIN(2),TTMIN(2)
46883       DOUBLE PRECISION XIN,PDFFAC
46884       REAL HWSDGG,HWSDGQ,XSP,Q2,P2,W2,EMB2,EMC2,ALAM2,XPGA(-6:6),F2GM,
46885      & XPVMD,XPANL,XPANH,XPBEH,XPDIR
46886       COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
46887      &     XPDIR(-6:6)
46888       LOGICAL PDFWRX(2,2),PDFWRQ(2,2)
46889       DOUBLE PRECISION PDFXMN,PDFXMX,PDFQMN,PDFQMX
46890       COMMON /W50513/PDFXMN,PDFXMX,PDFQMN,PDFQMX
46891       INTEGER IDHAD,NSET,IBEAM,IOLD,NOLD,IP,I,J,K,NX,IT,IX,IFL,NFL,
46892      & MPDF,IHAD,ISET,IOP1,IOP2,IP2
46893       CHARACTER*20 PARM(20)
46894       CHARACTER*20 PARMSAVE
46895       DOUBLE PRECISION VALSAVE
46896       COMMON/HWSFSA/PARMSAVE
46897       COMMON/HWSFSB/VALSAVE
46898       EXTERNAL HWSGAM,HWSDGG,HWSDGQ
46899       SAVE QOLD,IOLD,NOLD,XOLD,SS,S,T,TMIN,TMAX,G,A,TX,TT,TB,IP,NX
46900       SAVE PDFWRX,PDFWRQ,B,BB,NEHLQ,CEHLQ,TBMIN,TTMIN,DMIN,Q0,QL
46901       DATA PDFWRX,PDFWRQ/8*.TRUE./
46902       DATA (((B(I,J,K,1),I=1,3),J=1,6),K=1,5)/
46903      &3.D0,0.D0,0.D0,.419D0,.004383D0,-.007412D0,
46904      &3.46D0,.72432D0,-.065998D0,4.4D0,-4.8644D0,1.3274D0,
46905      &6*0.D0,1.D0,
46906      &0.D0,0.D0,.763D0,-.23696D0,.025836D0,4.D0,.62664D0,-.019163D0,
46907      &0.D0,-.42068D0,.032809D0,6*0.D0,1.265D0,-1.1323D0,.29268D0,
46908      &0.D0,-.37162D0,-.028977D0,8.05D0,1.5877D0,-.15291D0,
46909      &0.D0,6.3059D0,-.27342D0,0.D0,-10.543D0,-3.1674D0,
46910      &0.D0,14.698D0,9.798D0,0.D0,.13479D0,-.074693D0,
46911      &-.0355D0,-.22237D0,-.057685D0,6.3494D0,3.2649D0,-.90945D0,
46912      &0.D0,-3.0331D0,1.5042D0,0.D0,17.431D0,-11.255D0,
46913      &0.D0,-17.861D0,15.571D0,1.564D0,-1.7112D0,.63751D0,
46914      &0.D0,-.94892D0,.32505D0,6.D0,1.4345D0,-1.0485D0,
46915      &9.D0,-7.1858D0,.25494D0,0.D0,-16.457D0,10.947D0,
46916      &0.D0,15.261D0,-10.085D0/
46917       DATA (((B(I,J,K,2),I=1,3),J=1,6),K=1,5)/
46918      &3.D0,0.D0,0.D0,.3743D0,.013946D0,-.00031695D0,
46919      &3.329D0,.75343D0,-.076125D0,6.032D0,-6.2153D0,1.5561D0,
46920      &6*0.D0,1.D0,0.D0,
46921      &0.D0,.7608D0,-.2317D0,.023232D0,3.83D0,.62746D0,-.019155D0,
46922      &0.D0,-.41843D0,.035972D0,6*0.D0,1.6714D0,-1.9168D0,.58175D0,
46923      &0.D0,-.27307D0,-.16392D0,9.145D0,.53045D0,-.76271D0,
46924      &0.D0,15.665D0,-2.8341D0,0.D0,-100.63D0,44.658D0,
46925      &0.D0,223.24D0,-116.76D0,0.D0,.067368D0,-.030574D0,
46926      &-.11989D0,-.23293D0,-.023273D0,3.5087D0,3.6554D0,-.45313D0,
46927      &0.D0,-.47369D0,.35793D0,0.D0,9.5041D0,-5.4303D0,
46928      &0.D0,-16.563D0,15.524D0,.8789D0,-.97093D0,.43388D0,
46929      &0.D0,-1.1612D0,.4759D0,4.D0,1.2271D0,-.25369D0,
46930      &9.D0,-5.6354D0,-.81747D0,0.D0,-7.5438D0,5.5034D0,
46931      &0.D0,-.59649D0,.12611D0/
46932       DATA (((B(I,J,K,3),I=1,3),J=1,6),K=1,5)/
46933      &1.D0,0.D0,0.D0,0.4D0,-0.06212D0,-0.007109D0,0.7D0,0.6478D0,
46934      &0.01335D0,27*0.D0,0.9D0,-0.2428D0,0.1386D0,0.D0,-0.2120D0,
46935      &0.003671D0,5.0D0,0.8673D0,0.04747D0,
46936      &0.D0,1.266D0,-2.215D0,0.D0,2.382D0,0.3482D0,3*0.D0,
46937      &0.D0,0.07928D0,-0.06134D0,-0.02212D0,-0.3785D0,-0.1088D0,2.894D0,
46938      &9.433D0,
46939      &-10.852D0,0.D0,5.248D0,-7.187D0,0.D0,8.388D0,-11.61D0,3*0.D0,
46940      &0.888D0,-1.802D0,1.812D0,0.D0,-1.576D0,1.20D0,3.11D0,-0.1317D0,
46941      &0.5068D0,6.0D0,2.801D0,-12.16D0,0.D0,-17.28D0,20.49D0,3*0.D0/
46942       DATA (((B(I,J,K,4),I=1,3),J=1,6),K=1,5)/
46943      &1.D0,0.D0,0.D0,0.4D0,-0.05909D0,-0.006524D0,0.628D0,0.6436D0,
46944      &0.01451D0,27*0.D0,
46945      &0.90D0,-0.1417D0,-0.1740D0,0.D0,-0.1697D0,-0.09623D0,5.0D0,
46946      &-2.474D0,1.575D0,
46947      &0.D0,-2.534D0,1.378D0,0.D0,0.5621D0,-0.2701D0,3*0.D0,
46948      &0.D0,0.06229D0,-0.04099D0,-0.0882D0,-0.2892D0,-0.1082D0,1.924D0,
46949      &0.2424D0,
46950      &2.036D0,0.D0,-4.463D0,5.209D0,0.D0,-0.8367D0,-0.04840D0,3*0.D0,
46951      &0.794D0,-0.9144D0,0.5966D0,0.D0,-1.237D0,0.6582D0,2.89D0,0.5966D0,
46952      &-0.2550D0,
46953      &6.0D0,-3.671D0,-2.304D0,0.D0,-8.191D0,7.758D0,3*0.D0/
46954 C---COEFFTS FOR NEW OWENS 1.1 SET
46955       DATA BB/3.D0,3*0.D0,.665D0,-.1097D0,-.002442D0,0.D0,
46956      &3.614D0,.8395D0,-.02186D0,0.D0,.8673D0,-1.6637D0,.342D0,0.D0,
46957      &0.D0,1.1049D0,-.2369D0,5*0.D0,1.D0,3*0.D0,
46958      &.8388D0,-.2092D0,.02657D0,0.D0,4.667D0,.7951D0,.1081D0,0.D0,
46959      &0.D0,-1.0232D0,.05799D0,0.D0,0.D0,.8616D0,.153D0,5*0.D0,
46960      &.909D0,-.4023D0,.006305D0,0.D0,
46961      &0.D0,-.3823D0,.02766D0,0.D0,7.278D0,-.7904D0,.8108D0,0.D0,
46962      &0.D0,-1.6629D0,.5719D0,0.D0,0.D0,-.01333D0,.5299D0,0.D0,
46963      &0.D0,.1211D0,-.1739D0,0.D0,0.D0,.09469D0,-.07066D0,.01236D0,
46964      &-.1447D0,-.402D0,.1533D0,-.06479D0,6.7599D0,1.6596D0,.6798D0,
46965      &-.8525D0,0.D0,-4.4559D0,3.3756D0,-.9468D0,
46966      &0.D0,7.862D0,-3.6591D0,.03672D0,0.D0,-.2472D0,-.751D0,.0487D0,
46967      &3.017D0,-4.7347D0,3.3594D0,-.9443D0,0.D0,-.9342D0,.5454D0,
46968      &-.1668D0,
46969      &5.304D0,1.4654D0,-1.4292D0,.7569D0,0.D0,-3.9141D0,2.8445D0,
46970      &-.8411D0,
46971      &0.D0,9.0176D0,-10.426D0,4.0983D0,0.D0,-5.9602D0,7.515D0,-2.7329D0/
46972 C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
46973 C...EICHTEN, HINCHLIFFE, LANE, QUIGG PROTON STRUCTURE FUNCTION
46974 C...POWERS OF 1-X IN DIFFERENT CASES
46975       DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
46976 C...EXPANSION COEFFICIENTS FOR UP VALENCE QUARK DISTRIBUTION
46977       DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
46978      1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
46979      2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
46980      3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
46981      4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
46982      5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
46983      6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
46984      1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
46985      2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
46986      3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
46987      4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
46988      5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
46989      6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
46990       DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
46991      1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
46992      2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
46993      3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
46994      4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
46995      5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
46996      6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
46997      1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
46998      2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
46999      3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
47000      4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
47001      5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
47002      6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
47003 C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION
47004       DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
47005      1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
47006      2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
47007      3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
47008      4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
47009      5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
47010      6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
47011      1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
47012      2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
47013      3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
47014      4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
47015      5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
47016      6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
47017       DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
47018      1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
47019      2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
47020      3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
47021      4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
47022      5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
47023      6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
47024      1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
47025      2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
47026      3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
47027      4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
47028      5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
47029      6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
47030 C...EXPANSION COEFFICIENTS FOR UP AND DOWN SEA QUARK DISTRIBUTIONS
47031       DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
47032      1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
47033      2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
47034      3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
47035      4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
47036      5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
47037      6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
47038      1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
47039      2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
47040      3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
47041      4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
47042      5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
47043      6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
47044       DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
47045      1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
47046      2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
47047      3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
47048      4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
47049      5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
47050      6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
47051      1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
47052      2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
47053      3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
47054      4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
47055      5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
47056      6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
47057 C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION
47058       DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
47059      1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
47060      2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
47061      3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
47062      4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
47063      5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
47064      6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
47065      1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
47066      2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
47067      3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
47068      4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
47069      5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
47070      6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
47071       DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
47072      1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
47073      2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
47074      3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
47075      4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
47076      5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
47077      6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
47078      1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
47079      2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
47080      3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
47081      4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
47082      5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
47083      6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
47084 C...EXPANSION COEFFICIENTS FOR STRANGE SEA QUARK DISTRIBUTION
47085       DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
47086      1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
47087      2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
47088      3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
47089      4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
47090      5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
47091      6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
47092      1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
47093      2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
47094      3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
47095      4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
47096      5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
47097      6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
47098       DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
47099      1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
47100      2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
47101      3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
47102      4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
47103      5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
47104      6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
47105      1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
47106      2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
47107      3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
47108      4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
47109      5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
47110      6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
47111 C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION
47112       DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
47113      1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
47114      2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
47115      3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
47116      4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
47117      5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
47118      6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
47119      1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
47120      2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
47121      3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
47122      4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
47123      5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
47124      6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
47125       DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
47126      1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
47127      2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
47128      3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
47129      4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
47130      5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
47131      6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
47132      1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
47133      2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
47134      3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
47135      4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
47136      5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
47137      6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
47138 C...EXPANSION COEFFICIENTS FOR BOTTOM SEA QUARK DISTRIBUTION
47139       DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
47140      1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
47141      2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
47142      3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
47143      4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
47144      5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
47145      6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
47146      1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
47147      2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
47148      3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
47149      4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
47150      5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
47151      6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
47152       DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
47153      1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
47154      2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
47155      3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
47156      4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
47157      5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
47158      6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
47159      1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
47160      2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
47161      3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
47162      4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
47163      5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
47164      6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
47165 C...EXPANSION COEFFICIENTS FOR TOP SEA QUARK DISTRIBUTION
47166       DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
47167      1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
47168      2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
47169      3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
47170      4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
47171      5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
47172      6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
47173      1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
47174      2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
47175      3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
47176      4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
47177      5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
47178      6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
47179       DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
47180      1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
47181      2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
47182      3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
47183      4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
47184      5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
47185      6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
47186      1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
47187      2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
47188      3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
47189      4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
47190      5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
47191      6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
47192       DATA TBMIN,TTMIN/8.1905D0,7.4474D0,11.5528D0,10.8097D0/
47193       DATA XOLD,QOLD,IOLD,NOLD/-1.D0,0.D0,0,0/
47194       DATA DMIN,Q0,QL/0.D0,2*2.D0,2*2.236D0,2.D0,.2D0,
47195      &                .4D0,.2D0,.29D0,.177D0/
47196 C---X IS EQUAL TO XIN, UNLESS IT IS LESS THAN PDFX0
47197       X=MAX(XIN,PDFX0)
47198       IF (X.LE.ZERO) THEN
47199         CALL HWWARN('HWSFUN',100)
47200         GOTO 999
47201       ENDIF
47202       XMWN=ONE-X
47203       IF (XMWN.LE.ZERO) THEN
47204         DO 1 I=1,13
47205           DIST(I)=0
47206  1      CONTINUE
47207         RETURN
47208       ENDIF
47209 C---FREEZE THE SCALE IF REQUIRED
47210       SCALEF=SCALE
47211       IF (ISPAC.GT.0) SCALEF=MAX(SCALEF,QSPAC)
47212 C---CHECK IF PDFLIB REQUESTED
47213       IF (IBEAM.EQ.1.OR.IBEAM.EQ.2) THEN
47214         MPDF=MODPDF(IBEAM)
47215       ELSE
47216         MPDF=-1
47217       ENDIF
47218       QSCA=ABS(SCALEF)
47219       IF (IDHAD.EQ.59.OR.IDHAD.EQ.71) THEN
47220         IF (MPDF.GE.0) THEN
47221 C---USE PDFLIB PHOTON STRUCTURE FUNCTIONS
47222           PARM(1)=AUTPDF(IBEAM)
47223           VAL(1)=FLOAT(MPDF)
47224 C---FIX TO CALL SCHULER-SJOSTRAND CODE
47225           IF (AUTPDF(IBEAM).EQ.'SaSph') THEN
47226             XSP=SNGL(X)
47227             IF (    XSP.LE.ZERO) THEN
47228               CALL HWWARN('HWSFUN',102)
47229               GOTO 999
47230             ENDIF
47231             IF (ONE-XSP.LE.ZERO) THEN
47232               CALL HWWARN('HWSFUN',103)
47233               GOTO 999
47234             ENDIF
47235             Q2=SNGL(QSCA**2)
47236             ISET=MOD(MODPDF(IBEAM),10)
47237             IOP1=MOD(MODPDF(IBEAM)/10,2)
47238             IOP2=MOD(MODPDF(IBEAM)/20,2)
47239             IP2=MODPDF(IBEAM)/100
47240             IF (IOP2.EQ.0) THEN
47241               P2=0.
47242             ELSE
47243               IHAD=IBEAM
47244               IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
47245               P2=SNGL(PHEP(5,IHAD)**2)
47246             ENDIF
47247             CALL SASGAM(ISET,XSP,Q2,P2,IP2,F2GM,XPGA)
47248             IF (IOP1.EQ.1 .AND. ISTAT.LT.10) THEN
47249               DO 5 I=-6,6
47250  5            XPGA(I)=XPVMD(I)+XPANL(I)+XPBEH(I)+XPDIR(I)
47251             ENDIF
47252             UPV=XPGA(2)
47253             DNV=XPGA(1)
47254             USEA=XPGA(2)
47255             DSEA=XPGA(1)
47256             STR=XPGA(3)
47257             CHM=XPGA(4)
47258             BTM=XPGA(5)
47259             TOP=XPGA(6)
47260             GLU=XPGA(0)
47261           ELSE
47262             IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
47263               PARMSAVE=PARM(1)
47264               VALSAVE=VAL(1)
47265               CALL PDFSET(PARM,VAL)
47266             ENDIF
47267             IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
47268      &          X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
47269               CALL HWWARN('HWSFUN',2)
47270               WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
47271      &             ' OUTSIDE ALLOWED RANGE!'
47272               WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
47273      &             ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
47274               WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47275               IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
47276               IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
47277             ENDIF
47278             IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
47279      &          QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
47280               CALL HWWARN('HWSFUN',3)
47281               WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
47282      &             ' OUTSIDE ALLOWED RANGE!'
47283               WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
47284      &             ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
47285               WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47286               IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
47287               IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
47288             ENDIF
47289             CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
47290           ENDIF
47291           DIST(1)=DSEA
47292           DIST(2)=USEA
47293           DIST(7)=DSEA
47294           DIST(8)=USEA
47295         ELSE
47296           XSP=SNGL(X)
47297           IF (    XSP.LE.ZERO) THEN
47298             CALL HWWARN('HWSFUN',102)
47299             GOTO 999
47300           ENDIF
47301           IF (ONE-XSP.LE.ZERO) THEN
47302             CALL HWWARN('HWSFUN',103)
47303             GOTO 999
47304           ENDIF
47305           Q2=SNGL(SCALEF**2)
47306           W2=Q2*(1-XSP)/XSP
47307           EMC2=SNGL(4*RMASS(4)**2)
47308           EMB2=SNGL(4*RMASS(5)**2)
47309           ALAM2=0.160
47310           NFL=3
47311           IF (Q2.GT.50.) NFL=4
47312           IF (Q2.GT.500.) NFL=5
47313           STR=HWSDGQ(XSP,Q2,NFL,1)
47314           CHM=HWSDGQ(XSP,Q2,NFL,2)
47315           GLU=HWSDGG(XSP,Q2,NFL)
47316           DIST(1)=STR
47317           DIST(2)=CHM
47318           DIST(7)=STR
47319           DIST(8)=CHM
47320           IF (W2.GT.EMB2) THEN
47321             BTM=STR
47322             IF (W2*ALAM2.LT.Q2*EMB2)
47323      &          BTM=BTM*LOG(W2/EMB2)/LOG(Q2/ALAM2)
47324           ELSE
47325             BTM=0.
47326           ENDIF
47327           IF (W2.GT.EMC2) THEN
47328             IF (W2*ALAM2.LT.Q2*EMC2)
47329      &          CHM=CHM*LOG(W2/EMC2)/LOG(Q2/ALAM2)
47330           ELSE
47331             CHM=0.
47332           ENDIF
47333           TOP=0.
47334         ENDIF
47335 C---INCLUDE SUPPRESSION FROM PHOTON VIRTUALITY IF NECESSARY
47336         IF (PHOMAS.GT.ZERO.AND.(IBEAM.EQ.1.OR.IBEAM.EQ.2)) THEN
47337           IHAD=IBEAM
47338           IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
47339           IF (IDHW(IHAD).EQ.59) THEN
47340             FAC=LOG((QSCA**2+PHOMAS**2)/(PHEP(5,IHAD)**2+PHOMAS**2))/
47341      $          LOG((QSCA**2+PHOMAS**2)/(                PHOMAS**2))
47342             IF (FAC.LT.ZERO) FAC=ZERO
47343             DIST(1)=DIST(1)*FAC
47344             DIST(2)=DIST(2)*FAC
47345             DIST(7)=DIST(7)*FAC
47346             DIST(8)=DIST(8)*FAC
47347             STR=STR*FAC
47348             CHM=CHM*FAC
47349             BTM=BTM*FAC
47350             TOP=TOP*FAC
47351             GLU=GLU*FAC**2
47352           ELSE
47353             CALL HWWARN('HWSFUN',1)
47354           ENDIF
47355         ENDIF
47356         GOTO 900
47357       ENDIF
47358       IF (MPDF.GE.0) THEN
47359 C---USE PDFLIB NUCLEON STRUCTURE FUNCTIONS
47360         PARM(1)=AUTPDF(IBEAM)
47361         VAL(1)=FLOAT(MPDF)
47362         IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
47363           PARMSAVE=PARM(1)
47364           VALSAVE=VAL(1)
47365           CALL PDFSET(PARM,VAL)
47366         ENDIF
47367         IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
47368      &      X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
47369           CALL HWWARN('HWSFUN',4)
47370           WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
47371      &         ' OUTSIDE ALLOWED RANGE!'
47372           WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
47373      &         ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
47374           WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47375           IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
47376           IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
47377         ENDIF
47378         IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
47379      &      QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
47380           CALL HWWARN('HWSFUN',5)
47381           WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
47382      &         ' OUTSIDE ALLOWED RANGE!'
47383           WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
47384      &         ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
47385           WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47386           IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
47387           IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
47388         ENDIF
47389         CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
47390 C--new MRST98 LO PDF's
47391       ELSEIF(NSET.GE.6.AND.NSET.LE.8) THEN
47392         CALL HWSMRS(X,SCALEF,NSET-5,UPV,DNV,USEA,DSEA,STR,CHM,BTM,GLU)
47393         TOP=ZERO
47394       ELSE
47395         IF (NSET.LT.1.OR.NSET.GT.5) CALL HWWARN('HWSFUN',400)
47396         IF (QSCA.LT.Q0(NSET)) QSCA=Q0(NSET)
47397         IF (QSCA.NE.QOLD.OR.IDHAD.NE.IOLD.OR.NSET.NE.NOLD) THEN
47398 C---INITIALIZE
47399           QOLD=QSCA
47400           IOLD=IDHAD
47401           NOLD=NSET
47402           SS=LOG(QSCA/QL(NSET))
47403           SMIN=LOG(Q0(NSET)/QL(NSET))
47404           IF (NSET.LT.3.OR.NSET.EQ.5) THEN
47405             S=LOG(SS/SMIN)
47406           ELSE
47407             T=2.*SS
47408             TMIN=2.*SMIN
47409             TMAX=2.*LOG(1.E4/QL(NSET))
47410           ENDIF
47411           IF (IDHAD.GE.72) THEN
47412             IF (NSET.LT.3) THEN
47413               IP=NSET
47414               DO 10 I=1,5
47415               DO 10 J=1,6
47416    10         A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
47417               DO 20 K=1,2
47418               AA=ONE+A(2,K)+A(3,K)
47419    20         G(K)=HWSGAM(AA)/((ONE+A(2,K)*A(4,K)/AA)*HWSGAM(A(2,K))
47420      &            *HWSGAM(ONE+A(3,K)))
47421             ELSEIF (NSET.EQ.5) THEN
47422               DO 21 I=1,5
47423               DO 21 J=1,6
47424    21         A(J,I)=BB(1,J,I)+S*(BB(2,J,I)+S*(BB(3,J,I)+S*BB(4,J,I)))
47425               DO 22 K=1,2
47426               AA=ONE+A(2,K)+A(3,K)
47427    22         G(K)=HWSGAM(AA)/((ONE+A(2,K)/AA*(A(4,K)+
47428      &            (ONE+A(2,K))/(ONE+AA)*A(5,K)))*HWSGAM(A(2,K))
47429      &            *HWSGAM(ONE+A(3,K)))
47430             ELSE
47431               IP=NSET-2
47432               VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
47433               WT=VT*VT
47434 C...CHEBYSHEV POLYNOMIALS FOR T EXPANSION
47435               TT(1)=1.
47436               TT(2)=VT
47437               TT(3)=   2.*WT- 1.
47438               TT(4)=  (4.*WT- 3.)*VT
47439               TT(5)=  (8.*WT- 8.)*WT+1.
47440               TT(6)=((16.*WT-20.)*WT+5.)*VT
47441             ENDIF
47442           ELSEIF (NSET.LT.3) THEN
47443               IP=NSET+2
47444               DO 30 I=1,5
47445               DO 30 J=1,6
47446    30         A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
47447               AA=ONE+A(2,1)+A(3,1)
47448               G(1)=HWSGAM(AA)/(HWSGAM(A(2,1))*HWSGAM(ONE+A(3,1)))
47449               G(2)=0.
47450            ENDIF
47451         ENDIF
47452 C
47453         IF (NSET.LT.3.OR.NSET.EQ.5) THEN
47454           DO 50 I=1,5
47455    50     F(I)=A(1,I)*X**A(2,I)*XMWN**A(3,I)*(ONE+X*
47456      &        (A(4,I)+X*(A(5,I)  +  X*A(6,I))))
47457           F(1)=F(1)*G(1)
47458           F(2)=F(2)*G(2)
47459           UPV=F(1)-F(2)
47460           DNV=F(2)
47461           SEA=F(3)/6.
47462           STR=SEA
47463           CHM=F(4)
47464           BTM=ZERO
47465           TOP=ZERO
47466           GLU=F(5)
47467         ELSE
47468           IF (X.NE.XOLD) THEN
47469             XOLD=X
47470             IF (X.GT.0.1) THEN
47471               NX=1
47472               VX=(2.*X-1.1)/0.9
47473             ELSE
47474               NX=2
47475               VX=MAX(-ONE,(2.*LOG(X)+11.51293)/6.90776)
47476             ENDIF
47477             WX=VX*VX
47478             TX(1)=1.
47479             TX(2)=VX
47480             TX(3)=   2.*WX- 1.
47481             TX(4)=  (4.*WX- 3.)*VX
47482             TX(5)=  (8.*WX- 8.)*WX+1.
47483             TX(6)=((16.*WX-20.)*WX+5.)*VX
47484           ENDIF
47485 C...CALCULATE STRUCTURE FUNCTIONS
47486           DO 120 IFL=1,6
47487           XQSUM=0.
47488           DO 110 IT=1,6
47489           DO 110 IX=1,6
47490   110     XQSUM=XQSUM+CEHLQ(IX,IT,NX,IFL,IP)*TX(IX)*TT(IT)
47491   120     XQ(IFL)=XQSUM*XMWN**NEHLQ(IFL,IP)
47492           UPV=XQ(1)
47493           DNV=XQ(2)
47494           STR=XQ(5)
47495           CHM=XQ(6)
47496           SEA=XQ(3)
47497           GLU=XQ(4)
47498 C...SPECIAL EXPANSION FOR BOTTOM (THRESHOLD EFFECTS)
47499           IF (NFLAV.LT.5.OR.T.LE.TBMIN(IP)) THEN
47500             BTM=0.
47501           ELSE
47502             VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TBMIN(IP))/(TMAX-TBMIN(IP))))
47503             WT=VT*VT
47504             TB(1)=1.
47505             TB(2)=VT
47506             TB(3)=   2.*WT- 1.
47507             TB(4)=  (4.*WT- 3.)*VT
47508             TB(5)=  (8.*WT- 8.)*WT+1.
47509             TB(6)=((16.*WT-20.)*WT+5.)*VT
47510             XQSUM=0.
47511             DO 130 IT=1,6
47512             DO 130 IX=1,6
47513   130       XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,IP)*TX(IX)*TB(IT)
47514             BTM=XQSUM*XMWN**NEHLQ(7,IP)
47515           ENDIF
47516 C...SPECIAL EXPANSION FOR TOP (THRESHOLD EFFECTS)
47517           TPMIN=TTMIN(IP)+TMTOP
47518 C---TMTOP=2.*LOG(TOPMAS/30.)
47519           TPMAX=TMAX+TMTOP
47520           IF (NFLAV.LT.6.OR.T.LE.TPMIN) THEN
47521             TOP=0.
47522           ELSE
47523             VT=MAX(-ONE,MIN(ONE,(2.*T-TPMAX-TPMIN)/(TPMAX-TPMIN)))
47524             WT=VT*VT
47525             TB(1)=1.
47526             TB(2)=VT
47527             TB(3)=   2.*WT- 1.
47528             TB(4)=  (4.*WT- 3.)*VT
47529             TB(5)=  (8.*WT- 8.)*WT+1.
47530             TB(6)=((16.*WT-20.)*WT+5.)*VT
47531             XQSUM=0.
47532             DO 150 IT=1,6
47533             DO 150 IX=1,6
47534   150       XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,IP)*TX(IX)*TB(IT)
47535             TOP=XQSUM*XMWN**NEHLQ(8,IP)
47536           ENDIF
47537         ENDIF
47538       ENDIF
47539       IF (MPDF.LT.0.AND.NSET.LE.5) THEN
47540         USEA=SEA
47541         DSEA=USEA
47542       ENDIF
47543       IF(MPDF.LT.0.AND.NSET.GT.2.AND.(IDHAD.EQ.38.OR.IDHAD.EQ.30)) THEN
47544         WRITE(6,*) '     THIS SET OF PDFS DOES NOT SUPPORT PIONS'
47545         WRITE(6,*) 'EITHER USE SET NSTRU=1,2 OR A PION SET FROM PDFLIB'
47546         STOP
47547       ENDIF
47548       IF (IDHAD.EQ.73.OR.IDHAD.EQ.72) THEN
47549          DIST(1)=DSEA+DNV
47550          DIST(2)=USEA+UPV
47551          DIST(7)=DSEA
47552          DIST(8)=USEA
47553       ELSEIF (IDHAD.EQ.91) THEN
47554          DIST(1)=DSEA
47555          DIST(2)=USEA
47556          DIST(7)=DSEA+DNV
47557          DIST(8)=USEA+UPV
47558       ELSEIF (IDHAD.EQ.75) THEN
47559          DIST(1)=USEA+UPV
47560          DIST(2)=DSEA+DNV
47561          DIST(7)=USEA
47562          DIST(8)=DSEA
47563       ELSEIF (IDHAD.EQ.93) THEN
47564          DIST(1)=USEA
47565          DIST(2)=DSEA
47566          DIST(7)=USEA+UPV
47567          DIST(8)=DSEA+DNV
47568       ELSEIF (IDHAD.EQ.38) THEN
47569          DIST(1)=USEA
47570          DIST(2)=USEA+UPV
47571          DIST(7)=USEA+UPV
47572          DIST(8)=USEA
47573       ELSEIF (IDHAD.EQ.30) THEN
47574          DIST(1)=USEA+UPV
47575          DIST(2)=USEA
47576          DIST(7)=USEA
47577          DIST(8)=USEA+UPV
47578       ELSE
47579          PRINT *,' CALLED HWSFUN FOR IDHAD =',IDHAD
47580          CALL HWWARN('HWSFUN',401)
47581       ENDIF
47582   900 DIST(3)=STR
47583       DIST(4)=CHM
47584       DIST(5)=BTM
47585       DIST(6)=TOP
47586       DIST(9)=STR
47587       DIST(10)=CHM
47588       DIST(11)=BTM
47589       DIST(12)=TOP
47590       DIST(13)=GLU
47591       DO 901 I=1,13
47592       IF (DIST(I).LT.DMIN) DIST(I)=DMIN
47593   901 CONTINUE
47594 C---FOR REMNANT NUCLEONS SWITCH OFF VALENCE QUARKS,
47595 C   WHILE MAINTAINING MOMENTUM SUM RULE
47596       IF (IDHAD.EQ.72) THEN
47597         TOTAL=0
47598         DO 910 I=1,13
47599           TOTAL=TOTAL+DIST(I)
47600  910    CONTINUE
47601         DIST(1)=DIST(1)-DNV
47602         DIST(2)=DIST(2)-UPV
47603         IF (TOTAL.GT.DNV+UPV) THEN
47604           DO 920 I=1,13
47605             DIST(I)=DIST(I)*TOTAL/(TOTAL-DNV-UPV)
47606  920      CONTINUE
47607         ENDIF
47608       ENDIF
47609 C---IF X HAS BEEN FROZEN USE A POWER LAW
47610       IF (XIN.LT.PDFX0) THEN
47611         PDFFAC=(XIN/PDFX0)**PDFPOW
47612         DO 930 I=1,13
47613           DIST(I)=DIST(I)*PDFFAC
47614  930    CONTINUE
47615       ENDIF
47616  999  RETURN
47617       END
47618 CDECK  ID>, HWSGAM.
47619 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
47620 *-- Author :    Adapted by Bryan Webber
47621 C-----------------------------------------------------------------------
47622       FUNCTION HWSGAM(ZINPUT)
47623 C-----------------------------------------------------------------------
47624 C   Gamma function computed by eq. 6.1.40, Abramowitz.
47625 C   B(M) = B2m/(2m *(2m-1)) where B2m is the 2m'th Bernoulli number.
47626 C   HLNTPI = .5*LOG(2.*PI)
47627 C-----------------------------------------------------------------------
47628       IMPLICIT NONE
47629       DOUBLE PRECISION HWSGAM,ZINPUT,B(10),HLNTPI,Z,SHIFT,G,T,RECZSQ
47630       INTEGER I
47631       SAVE B,HLNTPI
47632       DATA B/
47633      1       0.83333333333333333333D-01,   -0.27777777777777777778D-02,
47634      1       0.79365079365079365079D-03,   -0.59523809523809523810D-03,
47635      1       0.84175084175084175084D-03,   -0.19175269175269175269D-02,
47636      1       0.64102564102564102564D-02,   -0.29550653594771241830D-01,
47637      1       0.17964437236883057316D0  ,    -1.3924322169059011164D0  /
47638       DATA HLNTPI/0.91893853320467274178D0/
47639 C
47640 C   Shift argument to large value ( > 20 )
47641 C
47642       Z=ZINPUT
47643       SHIFT=1.
47644    10 IF (Z.LT.20.D0) THEN
47645          SHIFT = SHIFT*Z
47646          Z = Z + 1.D0
47647          GOTO 10
47648       ENDIF
47649 C
47650 C   Compute asymptotic formula
47651 C
47652       G = (Z-.5D0)*LOG(Z) - Z + HLNTPI
47653       T = 1.D0/Z
47654       RECZSQ = T**2
47655       DO 20 I = 1,10
47656          G = G + B(I)*T
47657          T = T*RECZSQ
47658    20 CONTINUE
47659       HWSGAM = EXP(G)/SHIFT
47660       END
47661 CDECK  ID>, HWSGEN.
47662 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
47663 *-- Author :    Bryan Webber
47664 C-----------------------------------------------------------------------
47665       SUBROUTINE HWSGEN(GENEX)
47666 C-----------------------------------------------------------------------
47667 C     GENERATES X VALUES (IF GENEX)
47668 C     EVALUATES STRUCTURE FUNCTIONS AND ENFORCES CUTOFFS ON X
47669 C-----------------------------------------------------------------------
47670       INCLUDE 'herwig65.inc'
47671       DOUBLE PRECISION HWBVMC,HWRUNI,X,QL
47672       INTEGER I,J
47673       LOGICAL GENEX
47674       EXTERNAL HWBVMC,HWRUNI
47675       IF (GENEX) THEN
47676         XX(1)=EXP(HWRUNI(0,ZERO,XLMIN))
47677         XX(2)=XXMIN/XX(1)
47678       ENDIF
47679       DO 10 I=1,2
47680         J=I
47681         IF (JDAHEP(1,I).NE.0) J=JDAHEP(1,I)
47682         X=XX(I)
47683         QL=(1.-X)*EMSCA
47684         CALL HWSFUN(X,EMSCA,IDHW(J),NSTRU,DISF(1,I),I)
47685       DO 10 J=1,13
47686         IF (QL.LT.HWBVMC(J)) DISF(J,I)=0.
47687    10 CONTINUE
47688       END
47689 CDECK  ID>, HWSGQQ.
47690 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
47691 *-- Author :    Bryan Webber
47692 C-----------------------------------------------------------------------
47693       FUNCTION HWSGQQ(QSCA)
47694 C-----------------------------------------------------------------------
47695 C     CORRECTION TO GLUON STRUCTURE FUNCTION FOR BACKWARD EVOLUTION:
47696 C     G->Q-QBAR PART OF FORM FACTOR
47697 C-----------------------------------------------------------------------
47698       INCLUDE 'herwig65.inc'
47699       DOUBLE PRECISION HWSGQQ,HWUALF,QSCA,GG
47700       EXTERNAL HWUALF
47701       GG=HWUALF(1,QSCA)**(-ONE/BETAF)
47702       IF (GG.LT.ONE) GG=ONE
47703       IF (QSCA.GT.RMASS(6)) THEN
47704         HWSGQQ=GG**6
47705       ELSEIF (QSCA.GT.RMASS(5)) THEN
47706         HWSGQQ=GG**5
47707       ELSEIF (QSCA.GT.RMASS(4)) THEN
47708         HWSGQQ=GG**4
47709       ELSE
47710         HWSGQQ=GG**3
47711       ENDIF
47712       END
47713 CDECK  ID>, HWSMRS.
47714 *CMZ :-        -26/04/01  10.00.16  by  Peter Richardson
47715 *-- Author :    Dick Roberts, modified by Peter Richardson
47716 C-----------------------------------------------------------------------
47717       SUBROUTINE HWSMRS(X,Q,MODE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU)
47718 C-----------------------------------------------------------------------
47719 C     MRST98 Leading order PDF's central and higher gluon + average
47720 C-----------------------------------------------------------------------
47721       INCLUDE 'herwig65.inc'
47722       DOUBLE PRECISION X,Q,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU,XMIN,XMAX,
47723      &     QSQMIN,QSQMAX,Q2,QQ(NQMRS),XXMRS(NXMRS),G(NPMRS),N0(NPMRS),
47724      &     XSAVE,Q2SAVE,XXX,A,B,FAC
47725       INTEGER MODE,INIT,NTENTH,N,M,I,J,K,ML,WARN(2)
47726       PARAMETER(NTENTH=23)
47727       SAVE INIT,WARN,XMIN,XMAX,QSQMIN,QSQMAX,XXMRS,QQ,N0
47728       DATA XMIN,XMAX,QSQMIN,QSQMAX/1D-5,1D0,1.25D0,1D7/
47729       DATA XXMRS/1d-5,2d-5,4d-5,6d-5,8d-5,
47730      &        1d-4,2d-4,4d-4,6d-4,8d-4,
47731      &        1d-3,2d-3,4d-3,6d-3,8d-3,
47732      &        1d-2,1.4d-2,2d-2,3d-2,4d-2,6d-2,8d-2,
47733      &     .1d0,.125d0,.15d0,.175d0,.2d0,.225d0,.25d0,.275d0,
47734      &     .3d0,.325d0,.35d0,.375d0,.4d0,.425d0,.45d0,.475d0,
47735      &     .5d0,.525d0,.55d0,.575d0,.6d0,.65d0,.7d0,.75d0,
47736      &     .8d0,.9d0,1d0/
47737       DATA QQ/1.25d0,1.5d0,2d0,2.5d0,3.2d0,4d0,5d0,6.4d0,8d0,1d1,
47738      &        1.2d1,1.8d1,2.6d1,4d1,6.4d1,1d2,
47739      &        1.6d2,2.4d2,4d2,6.4d2,1d3,1.8d3,3.2d3,5.6d3,1d4,
47740      &        1.8d4,3.2d4,5.6d4,1d5,1.8d5,3.2d5,5.6d5,1d6,
47741      &        1.8d6,3.2d6,5.6d6,1d7/
47742       DATA N0/3,4,5,9,9,9,9,9/
47743       DATA INIT,WARN/0,0,0/
47744       Q2=Q*Q
47745 C--issue warning if x or q out of range
47746       IF((Q2.LT.QSQMIN.OR.Q2.GT.QSQMAX).AND.WARN(1).EQ.0) THEN
47747         CALL HWWARN('HWSMRS',5)
47748         WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH Q',
47749      &         ' OUTSIDE ALLOWED RANGE!'
47750         WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',Q,
47751      &         ', MINIMUM=',SQRT(QSQMIN),', MAXIMUM=',SQRT(QSQMAX)
47752         WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47753         WARN(1) = 1
47754       ENDIF
47755       IF((X.LT.XMIN.OR.X.GT.XMAX).AND.WARN(2).EQ.0) THEN
47756         CALL HWWARN('HWSMRS',4)
47757         WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH X',
47758      &         ' OUTSIDE ALLOWED RANGE!'
47759         WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
47760      &         ', MINIMUM=',XMIN,', MAXIMUM=',XMAX
47761         WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47762         WARN(2) = 1
47763       ENDIF
47764 C--now the evaluation
47765       XSAVE  = X
47766       Q2SAVE = Q2
47767 C--first the initialisation
47768       IF(INIT.NE.0) GOTO 10
47769       DO 15 ML=3,1,-1
47770       DO 20 N=1,NXMRS-1
47771       DO 20 M=1,NQMRS
47772       DO 20 I=1,NPMRS
47773 c notation: 1=uval 2=val 3=glue 4=usea 5=chm 6=str 7=btm 8=dsea
47774         IF(ML.LE.2) THEN
47775           FMRS(ML,I,N,M) = FMRS(ML,I,N,M)/(1.0D0-XXMRS(N))**N0(I)
47776         ELSE
47777           FMRS(ML,I,N,M) = 0.5D0*(FMRS(1,I,N,M)+FMRS(2,I,N,M))/
47778      &                              (1.0D0-XXMRS(N))**N0(I)
47779         ENDIF
47780  20   CONTINUE
47781       DO 31 J=1,NTENTH-1
47782       DO 31 I=1,8
47783       IF(I.EQ.5.OR.I.EQ.7) GOTO 31
47784       DO 30 K=1,NQMRS
47785  30   FMRS(ML,I,J,K)=DLOG10(FMRS(ML,I,J,K)/FMRS(ML,I,NTENTH,K))
47786      &                 +FMRS(ML,I,NTENTH,K)
47787  31   CONTINUE
47788       DO 40 I=1,NPMRS
47789       DO 40 M=1,NQMRS
47790  40   FMRS(ML,I,NXMRS,M)=0.0D0
47791  15   CONTINUE
47792       DO 32 J=1,NTENTH-1
47793  32   XXMRS(J)=DLOG10(XXMRS(J)/XXMRS(NTENTH))+XXMRS(NTENTH)
47794       INIT=1
47795  10   CONTINUE
47796 C--check x and q within range of set
47797       IF(X.LT.XMIN) X=XMIN
47798       IF(X.GT.XMAX) X=XMAX
47799       IF(Q2.LT.QSQMIN)  Q2=QSQMIN
47800       IF(Q2.GT.QSQMAX)  Q2=QSQMAX
47801 C--find X and Q
47802       XXX=X
47803       IF(X.LT.XXMRS(NTENTH)) XXX=DLOG10(X/XXMRS(NTENTH))+XXMRS(NTENTH)
47804       N = 0
47805  70   N=N+1
47806       IF(XXX.GT.XXMRS(N+1)) GOTO 70
47807       A=(XXX-XXMRS(N))/(XXMRS(N+1)-XXMRS(N))
47808       M=0
47809  80   M=M+1
47810       IF(Q2.GT.QQ(M+1)) GOTO 80
47811       B=(Q2-QQ(M))/(QQ(M+1)-QQ(M))
47812       DO 60 I=1,NPMRS
47813       G(I)= (1.0D0-A)*(1.0D0-B)*FMRS(MODE,I,N  ,M  )
47814      &     +(1.0D0-A)*       B *FMRS(MODE,I,N  ,M+1)
47815      &     +       A *(1.0D0-B)*FMRS(MODE,I,N+1,M  )
47816      &     +       A *       B *FMRS(MODE,I,N+1,M+1)
47817       IF(N.GE.NTENTH) GOTO 65
47818       IF(I.EQ.5.OR.I.EQ.7) GOTO 65
47819       FAC  = (1.0D0-B)*FMRS(MODE,I,NTENTH,M)+B*FMRS(MODE,I,NTENTH,M+1)
47820       G(I) = FAC*10.0d0**(G(I)-FAC)
47821   65  continue
47822       G(I)=G(I)*(1.0d0-X)**N0(I)
47823   60  continue
47824       UPV  = G(1)
47825       DNV  = G(2)
47826       USEA = G(4)
47827       DSEA = G(8)
47828       STR  = G(6)
47829       CHM  = G(5)
47830       GLU  = G(3)
47831       BOT  = G(7)
47832       X    = XSAVE
47833       Q2   = Q2SAVE
47834       END
47835 CDECK  ID>, HWSSPC.
47836 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
47837 *-- Author :    Bryan Webber
47838 C-----------------------------------------------------------------------
47839       SUBROUTINE HWSSPC
47840 C-----------------------------------------------------------------------
47841 C     REPLACES SPACELIKE PARTONS BY SPECTATORS
47842 C-----------------------------------------------------------------------
47843       INCLUDE 'herwig65.inc'
47844       DOUBLE PRECISION HWUSQR,EMSQ,EMTR,EPAR,XPAR,QSQ,PCL(5)
47845       INTEGER KHEP,IP,JP,IDH,IDP,ISP,IDSPC,JHEP
47846       EXTERNAL HWUSQR
47847       IF (IERROR.NE.0) RETURN
47848       DO 50 KHEP=1,NHEP
47849       IF (ISTHEP(KHEP).EQ.145.OR.ISTHEP(KHEP).EQ.146) THEN
47850         IP=ISTHEP(KHEP)-144
47851         JP=IP
47852         IF (JDAHEP(1,IP).NE.0) JP=JDAHEP(1,IP)
47853         IDH=IDHW(JP)
47854         IDP=IDHW(KHEP)
47855         IF (IDH.NE.IDP) THEN
47856           IF (IDH.EQ.59) THEN
47857 C---PHOTON CASE
47858             IF (IDP.LT.7) THEN
47859               IDSPC=IDP+6
47860             ELSEIF (IDP.LT.13) THEN
47861               IDSPC=IDP-6
47862             ELSE
47863               CALL HWWARN('HWSSPC',100)
47864               GOTO 999
47865             ENDIF
47866 C---IDENTIFY SPECTATOR
47867 C   (1) QUARK CASE
47868           ELSEIF (IDP.LE.3) THEN
47869             DO 10 ISP=1,12
47870   10        IF (IDH.EQ.NCLDK(LOCN(IDP,ISP))) GOTO 20
47871             CALL HWWARN('HWSSPC',101)
47872             GOTO 999
47873   20        IF (ISP.LE.3) THEN
47874               IDSPC=ISP+6
47875             ELSEIF (ISP.LE.9) THEN
47876               IDSPC=ISP+105
47877             ELSE
47878               IDSPC=ISP
47879             ENDIF
47880 C---(2) ANTIQUARK CASE
47881           ELSEIF (IDP.GT.6.AND.IDP.LE.9) THEN
47882             IDP=IDP-6
47883             DO 30 ISP=1,12
47884   30        IF (IDH.EQ.NCLDK(LOCN(ISP,IDP))) GOTO 40
47885             CALL HWWARN('HWSSPC',103)
47886             GOTO 999
47887   40        IF (ISP.LE.3) THEN
47888               IDSPC=ISP
47889             ELSEIF (ISP.LE.9) THEN
47890               IDSPC=ISP+111
47891             ELSE
47892               IDSPC=ISP-6
47893             ENDIF
47894 C---SPECIAL CASE FOR REMNANT HADRON
47895           ELSEIF (IDH.EQ.71.OR.IDH.EQ.72) THEN
47896             IF (IDP.EQ.13) THEN
47897               IDSPC=IDP
47898             ELSE
47899               CALL HWWARN('HWSSPC',106)
47900               GOTO 999
47901             ENDIF
47902           ELSE
47903             CALL HWWARN('HWSSPC',105)
47904             GOTO 999
47905           ENDIF
47906 C---REPLACE PARTON BY SPECTATOR
47907           IDHW(KHEP)=IDSPC
47908           IDHEP(KHEP)=IDPDG(IDSPC)
47909           ISTHEP(KHEP)=146+IP
47910           EMSQ=SIGN(PHEP(5,KHEP)**2,PHEP(5,KHEP))
47911           EMTR=EMSQ+PHEP(1,KHEP)**2+PHEP(2,KHEP)**2
47912           EPAR=PHEP(4,KHEP)
47913           CALL HWVDIF(4,PHEP(1,JP),PHEP(1,KHEP),PHEP(1,KHEP))
47914           IF (EPAR**2.LT.10000.*ABS(EMTR)) THEN
47915             CALL HWUMAS(PHEP(1,KHEP))
47916           ELSE
47917 C---COMPUTE SPECTATOR MASS ELIMINATING ROUNDING ERRORS
47918             XPAR=EPAR/PHEP(4,JP)
47919             QSQ=SIGN(PHEP(5,JP)**2,PHEP(5,JP))
47920             PHEP(5,KHEP)=HWUSQR((1.-XPAR)*QSQ+EMSQ-EMTR/XPAR
47921      &                 -((QSQ*XPAR**2-EMTR)/(2*EPAR*XPAR**2))**2*XPAR)
47922           ENDIF
47923 C---CHECK FOR UNPHYSICAL SPECTATOR
47924           IF (PHEP(4,KHEP).LT.ZERO) FROST=.TRUE.
47925 C---FIND MASS OF CORRESPONDING CLUSTER, IF PARTNER IS IN THE SAME JET
47926           IF (QORQQB(IDHW(KHEP))) THEN
47927             JHEP=JMOHEP(2,KHEP)
47928           ELSEIF (QBORQQ(IDHW(KHEP))) THEN
47929             JHEP=JDAHEP(2,KHEP)
47930           ELSE
47931             JHEP=0
47932           ENDIF
47933           IF (JHEP.GT.0) THEN
47934             CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PCL)
47935             CALL HWUMAS(PCL)
47936 C---IF IT IS NEGATIVE, REJECT
47937             IF (PCL(5).LT.ZERO) FROST=.TRUE.
47938           ENDIF
47939         ENDIF
47940       ENDIF
47941   50  CONTINUE
47942  999  RETURN
47943       END
47944 CDECK  ID>, HWSSUD.
47945 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
47946 *-- Author :    Bryan Webber
47947 C-----------------------------------------------------------------------
47948       FUNCTION HWSSUD(I)
47949 C-----------------------------------------------------------------------
47950       INCLUDE 'herwig65.inc'
47951       DOUBLE PRECISION HWSSUD,HWSGQQ,DMIN,QSCA,XLAST,DIST(13)
47952       INTEGER I,N0,IS,ID
47953       EXTERNAL HWSGQQ
47954       COMMON/HWTABC/XLAST,N0,IS,ID
47955       SAVE DMIN
47956       DATA DMIN/1.D-15/
47957       QSCA=QEV(N0+I,IS)
47958       CALL HWSFUN(XLAST,QSCA,IDHW(INHAD),NSTRU,DIST,JNHAD)
47959       IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QSCA)
47960       IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
47961       HWSSUD=SUD(N0+I,IS)/DIST(ID)
47962       END
47963 CDECK  ID>, HWSTAB.
47964 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
47965 *-- Author :    Adapted by Bryan Webber
47966 C-----------------------------------------------------------------------
47967       FUNCTION HWSTAB(F,AFUN,NN,X,MM)
47968 C-----------------------------------------------------------------------
47969 C     MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
47970 C     LIKE HWUTAB BUT USES FUNCTION AFUN IN PLACE OF ARRAY A
47971 C-----------------------------------------------------------------------
47972       IMPLICIT NONE
47973       INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
47974       DOUBLE PRECISION HWSTAB,AFUN,SUM,X,F(NN),T(20),D(20)
47975       LOGICAL EXTRA
47976       EXTERNAL AFUN
47977       SAVE MMAX
47978       DATA MMAX/10/
47979       N=NN
47980       M=MIN(MM,MMAX,N-1)
47981       MPLUS=M+1
47982       IX=0
47983       IY=N+1
47984       IF (AFUN(1).GT.AFUN(N)) GOTO 94
47985    91 MID=(IX+IY)/2
47986       IF (X.GE.AFUN(MID)) GOTO 92
47987       IY=MID
47988       GOTO 93
47989    92 IX=MID
47990    93 IF (IY-IX.GT.1) GOTO 91
47991       GOTO 97
47992    94 MID=(IX+IY)/2
47993       IF (X.LE.AFUN(MID)) GOTO 95
47994       IY=MID
47995       GOTO 96
47996    95 IX=MID
47997    96 IF (IY-IX.GT.1) GOTO 94
47998    97 NPTS=M+2-MOD(M,2)
47999       IP=0
48000       L=0
48001       GOTO 99
48002    98 L=-L
48003       IF (L.GE.0) L=L+1
48004    99 ISUB=IX+L
48005       IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 100
48006       NPTS=MPLUS
48007       GOTO 101
48008   100 IP=IP+1
48009       T(IP)=AFUN(ISUB)
48010       D(IP)=F(ISUB)
48011   101 IF (IP.LT.NPTS) GOTO 98
48012       EXTRA=NPTS.NE.MPLUS
48013       DO 14 L=1,M
48014       IF (.NOT.EXTRA) GOTO 12
48015       ISUB=MPLUS-L
48016       D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
48017    12 I=MPLUS
48018       DO 13 J=L,M
48019       ISUB=I-L
48020       D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
48021       I=I-1
48022    13 CONTINUE
48023    14 CONTINUE
48024       SUM=D(MPLUS)
48025       IF (EXTRA) SUM=0.5*(SUM+D(M+2))
48026       J=M
48027       DO 15 L=1,M
48028       SUM=D(J)+(X-T(J))*SUM
48029       J=J-1
48030    15 CONTINUE
48031       HWSTAB=SUM
48032       END
48033 CDECK  ID>, HWSVAL.
48034 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
48035 *-- Author :    Bryan Webber
48036 C-----------------------------------------------------------------------
48037       FUNCTION HWSVAL(ID)
48038 C-----------------------------------------------------------------------
48039 C     TRUE FOR VALENCE PARTON ID IN INCOMING HADRON INHAD
48040 C-----------------------------------------------------------------------
48041       INCLUDE 'herwig65.inc'
48042       INTEGER ID,IDHAD
48043       LOGICAL HWSVAL
48044       HWSVAL=.FALSE.
48045       IDHAD=IDHW(INHAD)
48046       IF (IDHAD.EQ.73.OR.IDHAD.EQ.75) THEN
48047         IF (ID.EQ.1.OR.ID.EQ.2) HWSVAL=.TRUE.
48048       ELSEIF (IDHAD.EQ.91.OR.IDHAD.EQ.93) THEN
48049         IF (ID.EQ.7.OR.ID.EQ.8) HWSVAL=.TRUE.
48050       ELSEIF (IDHAD.EQ.30) THEN
48051         IF (ID.EQ.1.OR.ID.EQ.8) HWSVAL=.TRUE.
48052       ELSEIF (IDHAD.EQ.38) THEN
48053         IF (ID.EQ.2.OR.ID.EQ.7) HWSVAL=.TRUE.
48054       ELSEIF (IDHAD.EQ.59) THEN
48055         IF (ID.LT.6.OR.(ID.GT.6.AND.ID.LT.12)) HWSVAL=.TRUE.
48056       ELSEIF (IDHAD.EQ.71.OR.IDHAD.EQ.72) THEN
48057         IF (ID.EQ.13) HWSVAL=.TRUE.
48058       ELSE
48059         CALL HWWARN('HWSVAL',100)
48060       ENDIF
48061       END
48062 CDECK  ID>, HWUAEM.
48063 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
48064 *-- Author :    Ian Knowles
48065 C-----------------------------------------------------------------------
48066       FUNCTION HWUAEM(Q2)
48067 C-----------------------------------------------------------------------
48068 C     Running electromagnetic coupling constant.
48069 C     See R. Kleiss et al.: CERN yellow report 89-08, vol.3 p.129
48070 C     Hadronic component from: H. Burkhardt et al.: Z. Phys C43 (89) 497
48071 C-----------------------------------------------------------------------
48072       INCLUDE 'herwig65.inc'
48073       DOUBLE PRECISION HWUAEM,HWUAER,Q2,EPS,A1,B1,C1,A2,B2,C2,A3,B3,C3,
48074      & A4,B4,C4,AEMPI,EEL2,EMU2,ETAU2,ETOP2,REPIGG,X
48075       LOGICAL FIRST
48076       EXTERNAL HWUAER
48077       SAVE FIRST,AEMPI,EEL2,EMU2,ETAU2,ETOP2
48078       PARAMETER (EPS=1.D-6)
48079       SAVE A1,B1,C1,A2,B2,C2,A3,B3,C3,A4,B4,C4
48080       DATA A1,B1,C1/0.0    D0,0.00835D0,1.000D0/
48081       DATA A2,B2,C2/0.0    D0,0.00238D0,3.927D0/
48082       DATA A3,B3,C3/0.00165D0,0.00299D0,1.000D0/
48083       DATA A4,B4,C4/0.00221D0,0.00293D0,1.000D0/
48084       DATA FIRST/.TRUE./
48085       IF (FIRST) THEN
48086          AEMPI=ALPHEM/(THREE*PIFAC)
48087          EEL2 =RMASS(121)**2
48088          EMU2 =RMASS(123)**2
48089          ETAU2=RMASS(125)**2
48090          ETOP2=RMASS(6)**2
48091          FIRST=.FALSE.
48092       ENDIF
48093       IF (ABS(Q2).LT.EPS) THEN
48094           HWUAEM=ALPHEM
48095           RETURN
48096       ENDIF
48097 C Leptonic component
48098       REPIGG=AEMPI*(HWUAER(EEL2/Q2)+HWUAER(EMU2/Q2)+HWUAER(ETAU2/Q2))
48099 C Hadronic component from light quarks
48100       X=ABS(Q2)
48101       IF (X.LT.9.D-2) THEN
48102           REPIGG=REPIGG+A1+B1*LOG(ONE+C1*X)
48103       ELSEIF (X.LT.9.D0) THEN
48104           REPIGG=REPIGG+A2+B2*LOG(ONE+C2*X)
48105       ELSEIF (X.LT.1.D4) THEN
48106           REPIGG=REPIGG+A3+B3*LOG(ONE+C3*X)
48107       ELSE
48108           REPIGG=REPIGG+A4+B4*LOG(ONE+C4*X)
48109       ENDIF
48110 C Top Contribution
48111       REPIGG=REPIGG+AEMPI*HWUAER(ETOP2/Q2)
48112       HWUAEM=ALPHEM/(ONE-REPIGG)
48113       END
48114 CDECK  ID>, HWUAER.
48115 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
48116 *-- Author :    Ian Knowles
48117 C-----------------------------------------------------------------------
48118       FUNCTION HWUAER(R)
48119 C-----------------------------------------------------------------------
48120 C     Real part of photon self-energy: Pi_{gg}(R=M^2/Q^2)
48121 C-----------------------------------------------------------------------
48122       IMPLICIT NONE
48123       DOUBLE PRECISION HWUAER,R,ZERO,ONE,TWO,FOUR,FVTHR,THIRD,RMAX,BETA
48124       PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0,
48125      &           FVTHR=1.666666666666667D0, THIRD=.3333333333333333D0)
48126       PARAMETER (RMAX=1.D6)
48127       IF (ABS(R).LT.1.D-3) THEN
48128 C Use assymptotic formula
48129          HWUAER=-FVTHR-LOG(ABS(R))
48130       ELSEIF (ABS(R).GT.RMAX) THEN
48131          HWUAER=ZERO
48132       ELSEIF (FOUR*R.GT.ONE) THEN
48133          BETA=SQRT(FOUR*R-ONE)
48134          HWUAER=THIRD
48135      &         -(ONE+TWO*R)*(TWO-BETA*ACOS(ONE-ONE/(TWO*R)))
48136       ELSE
48137          BETA=SQRT(ONE-FOUR*R)
48138          HWUAER=THIRD
48139      &         -(ONE+TWO*R)*(TWO+BETA*LOG(ABS((BETA-ONE)/(BETA+ONE))))
48140       ENDIF
48141       END
48142 CDECK  ID>, HWUALF.
48143 *CMZ :-        -15/07/92  14.08.45  by  Mike Seymour
48144 *-- Author :    Bryan Webber
48145 C-----------------------------------------------------------------------
48146       FUNCTION HWUALF(IOPT,SCALE)
48147 C-----------------------------------------------------------------------
48148 C     STRONG COUPLING CONSTANT
48149 C     IOPT.EQ.0  INITIALIZES
48150 C         .EQ.1  TWO-LOOP, FLAVOUR THRESHOLDS
48151 C         .EQ.2  RATIO OF ABOVE TO ONE-LOOP
48152 C                WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
48153 C         .EQ.3  ONE-LOOP WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
48154 C-----------------------------------------------------------------------
48155       INCLUDE 'herwig65.inc'
48156       DOUBLE PRECISION HWUALF,SCALE,KAFAC,B3,B4,B5,B6,C3,C4,C5,C6,C35,
48157      & C45,C65,D35,RHO,RAT,RLF,DRH,EPS
48158       INTEGER IOPT,ITN
48159       SAVE B3,B4,B5,B6,C3,C4,C5,C6,C35,C45,C65,D35
48160       SAVE EPS
48161       DATA EPS/1.D-6/
48162       IF (IOPT.EQ.0) THEN
48163 C---INITIALIZE CONSTANTS
48164         CAFAC=FLOAT(NCOLO)
48165         CFFAC=FLOAT(NCOLO**2-1)/(2.*CAFAC)
48166         B3=((11.*CAFAC)- 6.)/(12.*PIFAC)
48167         B4=((11.*CAFAC)- 8.)/(12.*PIFAC)
48168         B5=((11.*CAFAC)-10.)/(12.*PIFAC)
48169         B6=((11.*CAFAC)-12.)/(12.*PIFAC)
48170         BETAF=6.*PIFAC*B5
48171         C3=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*3.)/(24.*PIFAC**2)/B3**2
48172         C4=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*4.)/(24.*PIFAC**2)/B4**2
48173         C5=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*5.)/(24.*PIFAC**2)/B5**2
48174         C6=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*6.)/(24.*PIFAC**2)/B6**2
48175         KAFAC=CAFAC*(67./18.-PIFAC**2/6.)-25./9.
48176 C---QCDLAM IS 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X OR Z
48177 C---QCDL5  IS 5-FLAVOUR LAMBDA-MC
48178         QCDL5=QCDLAM*EXP(KAFAC/(4.*PIFAC*B5))/SQRT(2.D0)
48179 C---COMPUTE THRESHOLD MATCHING
48180         RHO=2.*LOG(RMASS(6)/QCDL5)
48181         RAT=LOG(RHO)/RHO
48182         C65=(B5/(1.-C5*RAT)-B6/(1.-C6*RAT))*RHO
48183         RHO=2.*LOG(RMASS(5)/QCDL5)
48184         RAT=LOG(RHO)/RHO
48185         C45=(B5/(1.-C5*RAT)-B4/(1.-C4*RAT))*RHO
48186         RHO=2.*LOG(RMASS(4)/QCDL5)
48187         RAT=LOG(RHO)/RHO
48188         C35=(B4/(1.-C4*RAT)-B3/(1.-C3*RAT))*RHO+C45
48189 C---FIND QCDL3
48190         D35=-1./(B3*C35)
48191         DO 10 ITN=1,100
48192           RAT=LOG(D35)/D35
48193           RLF=B3*D35/(1.-C3*RAT)
48194           DRH=B3*(RLF+C35)*D35**2/((1.-2.*C3*RAT+C3/D35)*RLF**2)
48195           D35=D35-DRH
48196           IF (ABS(DRH).LT.EPS*D35) GOTO 20
48197    10   CONTINUE
48198    20   QCDL3=QCDL5*EXP(0.5*D35)
48199       ENDIF
48200       IF (SCALE.LE.QCDL5) THEN
48201         CALL HWWARN('HWUALF',51)
48202         GOTO 999
48203       ENDIF
48204       RHO=2.*LOG(SCALE/QCDL5)
48205       IF (IOPT.EQ.3) THEN
48206         IF (RHO.LE.D35) THEN
48207           CALL HWWARN('HWUALF',52)
48208           GOTO 999
48209         ENDIF
48210         HWUALF=1./(B5*(RHO-D35))
48211         RETURN
48212       ENDIF
48213       RAT=LOG(RHO)/RHO
48214       IF (SCALE.GT.RMASS(6)) THEN
48215         RLF=B6*RHO/(1.-C6*RAT)+C65
48216       ELSEIF (SCALE.GT.RMASS(5)) THEN
48217         RLF=B5*RHO/(1.-C5*RAT)
48218       ELSEIF (SCALE.GT.RMASS(4)) THEN
48219         RLF=B4*RHO/(1.-C4*RAT)+C45
48220       ELSE
48221         RLF=B3*RHO/(1.-C3*RAT)+C35
48222       ENDIF
48223       IF (RLF.LE.ZERO) THEN
48224         CALL HWWARN('HWUALF',53)
48225         GOTO 999
48226       ENDIF
48227       IF (IOPT.EQ.1) THEN
48228         HWUALF=1./RLF
48229       ELSE
48230         HWUALF=B5*(RHO-D35)/RLF
48231         IF (HWUALF.GT.ONE) THEN
48232           CALL HWWARN('HWUALF',54)
48233           GOTO 999
48234         ENDIF
48235       ENDIF
48236       RETURN
48237  999  HWUALF=ZERO
48238       END
48239 CDECK  ID>, HWUANT.
48240 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
48241 *-- Author :    Ian Knowles
48242 C-----------------------------------------------------------------------
48243       FUNCTION HWUANT(IPART)
48244 C-----------------------------------------------------------------------
48245 C     Returns the antiparticle of IPART; uses HERWIG numbering
48246 C-----------------------------------------------------------------------
48247       INCLUDE 'herwig65.inc'
48248       INTEGER HWUANT,IPART,IPDG,IANTI,OLDERR
48249       CHARACTER*8 CDUM
48250       OLDERR=IERROR
48251       IPDG=IDPDG(IPART)
48252       IF (IPDG.EQ. 9.OR.IPDG.EQ.21.OR.IPDG.EQ.22.OR.IPDG.EQ.23.OR.
48253      &    IPDG.EQ.25.OR.IPDG.EQ.26.OR.IPDG.EQ.32.OR.IPDG.EQ.35.OR.
48254      &    IPDG.EQ.36.OR.IPDG.EQ.39.OR.IPDG.EQ.91.OR.IPDG.EQ.98.OR.
48255      &    IPDG.EQ.99.OR.IPDG.EQ.130.OR.IPDG.EQ.310.OR.
48256      &    IPDG.EQ.1000021.OR.IPDG.EQ.1000022.OR.IPDG.EQ.1000023.OR.
48257      &    IPDG.EQ.1000025.OR.IPDG.EQ.1000035.OR.IPDG.EQ.1000039.OR.
48258      &    (FLOAT(INT(RSPIN(IPART))).EQ.RSPIN(IPART).AND.
48259      &     MOD(IPDG/100,10).EQ.MOD(IPDG/10,10).AND.
48260      &     MOD(IPDG/10,10).NE.0)) THEN
48261 C Self-conjugate boson
48262         IANTI=IPART
48263       ELSEIF(IPART.EQ.211.OR.IPART.EQ.212) THEN
48264 C Fourth generation (anti-)quarks
48265         IANTI=IPART+6
48266       ELSEIF(IPART.EQ.217.OR.IPART.EQ.218) THEN
48267         IANTI=IPART-6
48268       ELSE
48269 C Non-zero charge particle
48270         CALL HWUIDT(1,-IPDG,IANTI,CDUM)
48271       ENDIF
48272       IF (IANTI.EQ.20) WRITE(6,10) RNAME(IPART)
48273   10  FORMAT(1X,A8,' has no antiparticle'/)
48274       HWUANT=IANTI
48275       IERROR=OLDERR
48276       END
48277 CDECK  ID>, HWUATS.
48278 *CMZ :-        -07/07/99  17.42.00  by  Kosuke Odagiri
48279 *-- Author :    Kosuke Odagiri
48280 C-----------------------------------------------------------------------
48281       SUBROUTINE HWUATS
48282 C-----------------------------------------------------------------------
48283 C     Replaces all &'s in TXNAME by backslashes
48284 C-----------------------------------------------------------------------
48285       INCLUDE 'herwig65.inc'
48286       INTEGER I,J,L
48287       CHARACTER*1 Z
48288       Z=CHAR(92)
48289       L=LEN(TXNAME(1,1))
48290       DO 1 I=0,NMXRES
48291         DO 2 J=1,L
48292           IF (TXNAME(1,I)(J:J).EQ.'&') TXNAME(1,I)(J:J)=Z
48293  2      CONTINUE
48294  1    CONTINUE
48295       END
48296 CDECK  ID>, HWUBPR.
48297 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
48298 *-- Author :    Bryan Webber
48299 C-----------------------------------------------------------------------
48300       SUBROUTINE HWUBPR
48301 C-----------------------------------------------------------------------
48302 C     PRINTS OUT DATA ON PARTON SHOWER
48303 C-----------------------------------------------------------------------
48304       INCLUDE 'herwig65.inc'
48305       INTEGER I,J
48306       IF (PRVTX) THEN
48307         WRITE(6,10) INHAD,XFACT
48308   10    FORMAT(///10X,'DATA ON LAST PARTON SHOWER:   INHAD =',I3,
48309      &  '    XFACT =',E11.3//'  IPAR ID     TM  DA1 CMO AMO CDA',
48310      &  ' ADA  P-X     P-Y     P-Z   ENERGY    MASS',
48311      &  '   V-X        V-Y        V-Z        V-C*T')
48312         DO 20 J=1,NPAR
48313   20    WRITE(6,30) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
48314      &   (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5),(VPAR(I,J),I=1,4)
48315   30    FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2,4E11.4)
48316       ELSE
48317         WRITE(6,40) INHAD,XFACT
48318   40    FORMAT(///10X,'DATA ON LAST PARTON SHOWER:   INHAD =',I3,
48319      &  '    XFACT =',E11.3//'  IPAR ID     TM  DA1 CMO AMO CDA',
48320      &  ' ADA  P-X     P-Y     P-Z   ENERGY    MASS')
48321         DO 50 J=1,NPAR
48322   50    WRITE(6,60) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
48323      &   (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5)
48324   60    FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2)
48325       ENDIF
48326       END
48327 CDECK  ID>, HWUBST.
48328 *CMZ :-        -18/10/93  10.21.56  by  Mike Seymour
48329 *-- Author :    Mike Seymour
48330 C-----------------------------------------------------------------------
48331       SUBROUTINE HWUBST(IOPT)
48332 C-----------------------------------------------------------------------
48333 C     BOOST THE ENTIRE EVENT RECORD TO (IOPT=1) OR FROM (IOPT=0) ITS
48334 C     CENTRE-OF-MASS FRAME, WITH INCOMING HADRONS ON Z-AXIS
48335 C-----------------------------------------------------------------------
48336       INCLUDE 'herwig65.inc'
48337       DOUBLE PRECISION PBOOST(5),RBOOST(3,3)
48338       INTEGER IOPT,IHEP,BOOSTD,IHAD
48339       SAVE BOOSTD,PBOOST,RBOOST
48340       DATA BOOSTD/-1/
48341       IF (IERROR.NE.0) RETURN
48342       IF (IOPT.EQ.1) THEN
48343 C---FIND FIRST INCOMING HADRON
48344         IHAD=1
48345         IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
48346 C---IF WE'RE ALREADY IN THE RIGHT FRAME, DON'T DO ANYTHING
48347         IF (PHEP(1,3)**2+PHEP(2,3)**2+PHEP(3,3)**2.EQ.ZERO .AND.
48348      &      PHEP(1,IHAD)**2+PHEP(2,IHAD)**2.EQ.ZERO) RETURN
48349 C---FIND AND APPLY BOOST
48350         CALL HWVEQU(5,PHEP(1,3),PBOOST)
48351         DO 100 IHEP=1,NHEP
48352           CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
48353           CALL HWULOF(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
48354  100    CONTINUE
48355         CALL HWULOF(PBOOST,VTXPIP,VTXPIP)
48356 C---FIND AND APPLY ROTATION TO PUT IT ON Z-AXIS
48357         CALL HWUROT(PHEP(1,IHAD),ONE,ZERO,RBOOST)
48358         DO 110 IHEP=1,NHEP
48359           CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
48360           CALL HWUROF(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
48361  110    CONTINUE
48362         CALL HWUROF(RBOOST,VTXPIP,VTXPIP)
48363 C---ENSURE THAT WE ONLY EVER UNBOOST THE SAME EVENT THAT WE BOOSTED
48364 C   (BEARING IN MIND THAT NWGTS IS UPDATED AFTER GENERATING THE WEIGHT)
48365         BOOSTD=NWGTS+1
48366       ELSEIF (IOPT.EQ.0) THEN
48367         IF (BOOSTD.NE.NWGTS) RETURN
48368 C---UNDO ROTATION AND BOOST
48369         DO 200 IHEP=1,NHEP
48370           CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
48371           CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
48372           CALL HWUROB(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
48373           CALL HWULB4(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
48374  200    CONTINUE
48375       ENDIF
48376       END
48377 CDECK  ID>, HWUCFF.
48378 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
48379 *-- Author :    Bryan Webber and Ian Knowles
48380 C-----------------------------------------------------------------------
48381       SUBROUTINE HWUCFF(I,J,QSQ,CLF)
48382 C-----------------------------------------------------------------------
48383 C     Calculates basic coefficients in cross-section formula for
48384 C     ffbar --> f'fbar', at virtuality QSQ, I labels initial, J
48385 C     labels final fermion; type given as:
48386 C        I,J= 1- 6: d,u,s,c,b,t
48387 C           =11-16: e,nu_e,mu,nu_mu,tau,nu_tau
48388 C-----------------------------------------------------------------------
48389       INCLUDE 'herwig65.inc'
48390       DOUBLE PRECISION QSQ,CLF(7),POL1,POL2,QIF,VI,AI,VF,AF,PG,DQM,PMW,
48391      & DEN,XRE,XIM,XSQ,VI2,AI2,VF2,AF2,PG2,PG12,DQM2,PMW2,DEN2,XRE2,
48392      & XIM2,XSQ2,XRE12,XIM12
48393       INTEGER I,J
48394 C Longitudinal Polarisation factors
48395       POL1=1.-EPOLN(3)*PPOLN(3)
48396       POL2=PPOLN(3)-EPOLN(3)
48397 C Standard model couplings
48398       QIF=QFCH(I)*QFCH(J)
48399       VI=VFCH(I,1)
48400       AI=AFCH(I,1)
48401       VF=VFCH(J,1)
48402       AF=AFCH(J,1)
48403       PG=POL1*(VI**2+AI**2)+POL2*2.*VI*AI
48404 C Z propagator factors
48405       DQM=QSQ-RMASS(200)**2
48406       PMW=GAMZ*RMASS(200)
48407       DEN=QSQ/(DQM**2+PMW**2)
48408       XRE=DEN*DQM
48409       XIM=DEN*PMW
48410       XSQ=DEN*QSQ
48411 C Calculate cross-section coefficients
48412       CLF(1)=POL1*QIF**2+XRE*2.*QIF*(POL1*VI+POL2*AI)*VF
48413      &      +XSQ*PG*(VF**2+AF**2)
48414       CLF(2)=CLF(1)-2.*XSQ*PG*AF**2
48415       CLF(3)=2.*(XRE*QIF*(POL1*AI+POL2*VI)*AF
48416      &      +XSQ*(POL1*2.*VI*AI+POL2*(VI**2+AI**2))*VF*AF)
48417       IF (TPOL) THEN
48418          CLF(4)=QIF**2+XRE*2.*QIF*VI*VF+XSQ*(VI**2-AI**2)*(VF**2+AF**2)
48419          CLF(5)=CLF(4)-2.*XSQ*(VI**2-AI**2)*AF**2
48420          CLF(6)=XIM*2.*QIF*AI*VF
48421          CLF(7)=CLF(6)
48422       ENDIF
48423       IF (ZPRIME) THEN
48424 C Z' couplings:
48425          VI2=VFCH(I,2)
48426          AI2=AFCH(I,2)
48427          VF2=VFCH(J,2)
48428          AF2=AFCH(J,2)
48429          PG2=POL1*(VI2**2+AI2**2)+POL2*2.*VI2*AI2
48430          PG12=POL1*(VI*VI2+AI*AI2)+POL2*(VI*AI2+AI+VI2)
48431 C Z' propagator factors
48432          DQM2=QSQ-RMASS(202)**2
48433          PMW2=RMASS(202)*GAMZP
48434          DEN2=QSQ/(DQM2**2+PMW2**2)
48435          XRE2=DEN2*DQM2
48436          XIM2=DEN2*PMW2
48437          XSQ2=DEN2*QSQ
48438          XRE12=DEN*DEN2*(DQM*DQM2+PMW*PMW2)
48439          XIM12=DEN*DEN2*(DQM*PMW2-DQM2*PMW)
48440 C Additional contributions to cross-section coefficients
48441          CLF(1)=CLF(1)+XRE2*2.*QIF*(POL1*VI2+POL2*AI2)*VF2
48442      &    +XSQ2*PG2*(VF2**2+AF2**2)+XRE12*2.*PG12*(VF*VF2+AF*AF2)
48443          CLF(2)=CLF(1)-2.*(XSQ2*PG2*AF2**2+XRE12*2.*PG12*AF*AF2)
48444          CLF(3)=CLF(3)+2.*(XRE2*QIF*(POL1*AI2+POL2*VI2)*AF2
48445      &    +XSQ2*(POL1*2.*VI2*AI2+POL2*(VI2**2+AI2**2))*VF2*AF2
48446      &    +XRE12*(POL1*(VI*AI2+AI*VI2)+POL1*(VI*VI2+AI*AI2))
48447      &    *(VF*VF2+AF*AF2))
48448          IF (TPOL) THEN
48449             CLF(4)=CLF(4)+XRE2*2.*QIF*VI2*VF2
48450      &       +XSQ2*(VI2**2-AI2**2)*(VF2**2+AF2**2)
48451      &       +XRE12*2.*(VI*VI2-AI*AI2)*(VF*VF2+AF*AF2)
48452             CLF(5)=CLF(4)-2*(XSQ2*(VI2**2-AI2**2)*AF2**2
48453      &       +XRE12*2.*(VI*VI2-AI*AI2)*AF*AF2)
48454             CLF(6)=CLF(6)+2.*(XIM2*QIF*AI2*VF2
48455      &       -XIM12*(VI*AI2-AI*VI2)*(VF*VF2+AF*AF2))
48456             CLF(7)=CLF(6)+4.*XIM12*(VI*AI2-AI*AI2)*AF*AF2
48457          ENDIF
48458       ENDIF
48459       END
48460 CDECK  ID>, HWUCI2.
48461 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
48462 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
48463 C-----------------------------------------------------------------------
48464       FUNCTION HWUCI2(A,B,Y0)
48465 C-----------------------------------------------------------------------
48466 C     Integral  LOG(A-EPSI-BY(1-Y))/(Y-Y0)
48467 C-----------------------------------------------------------------------
48468       IMPLICIT NONE
48469       DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
48470       DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
48471       EXTERNAL HWULI2
48472       COMMON/SMALL/EPSI
48473       PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
48474       IF(B.EQ.ZERO)THEN
48475          HWUCI2=DCMPLX(ZERO,ZERO)
48476       ELSE
48477          Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
48478          Y2=ONE-Y1
48479          Z1=Y0/(Y0-Y1)
48480          Z2=(Y0-ONE)/(Y0-Y1)
48481          Z3=Y0/(Y0-Y2)
48482          Z4=(Y0-ONE)/(Y0-Y2)
48483          HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
48484       ENDIF
48485       END
48486 CDECK  ID>, HWUDAT.
48487 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
48488 *-- Author :    Ian Knowles & Bryan Webber
48489 C-----------------------------------------------------------------------
48490       BLOCK DATA HWUDAT
48491 C-----------------------------------------------------------------------
48492 C     Loads common blocks with particle properties data; for particle I:
48493 C        RNAME(I) = Name
48494 C        IDPDG(I) = PDG code
48495 C        IFLAV(I) = HERWIG flavour code
48496 C        ICHRG(I) = Electric charge (|e-|)          (*3 for (di-)quarks)
48497 C        RMASS(I) = Mass (GeV/c^2)
48498 C        RLTIM(I) = Proper life time (s)
48499 C        RSPIN(I) = Spin
48500 C       QORQQB(I) = .TRUE. if it is a quark or an antidiquark
48501 C       QBORQQ(I) = .TRUE. if it is an antiquark or a diquark
48502 C     And stores the particle decay tables: call HWUDPR to print them
48503 C-----------------------------------------------------------------------
48504       INCLUDE 'herwig65.inc'
48505       COMMON/HWSEED/ISEED(2)
48506       INTEGER ISEED
48507       INTEGER NLAST,NNEXT,NLEFT,NREST,I,J,MMWIDE,MMLONG,MMHOFF,MMVOFF
48508       COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
48509 c      PARAMETER (NLAST=458,NNEXT=458+1,NLEFT=NMXRES-458)
48510 c      PARAMETER (NREST=NMXRES-120)
48511 c      DATA NRES/458/
48512       PARAMETER (NLAST=458,NNEXT=NLAST+1,NLEFT=NMXRES-NLAST)
48513       PARAMETER (NREST=NMXRES-120)
48514       DATA NRES/NLAST/
48515 C Don't forget to change the three occurances above as well
48516       DATA MMWIDE,MMLONG,MMHOFF,MMVOFF/190,280,-39,-35/
48517       DATA ISEED/12345,67890/
48518       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48519      &      RSPIN(I),I=0,16)/
48520      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48521      & 'DQRK    ',       1,   0,-1,0.3200D0,0.000D+00,0.5D0,
48522      & 'UQRK    ',       2,   0,+2,0.3200D0,0.000D+00,0.5D0,
48523      & 'SQRK    ',       3,   0,-1,0.5000D0,0.000D+00,0.5D0,
48524      & 'CQRK    ',       4,   0,+2,1.5500D0,0.000D+00,0.5D0,
48525      & 'BQRK    ',       5,   0,-1,4.9500D0,0.000D+00,0.5D0,
48526      & 'TQRK    ',       6,   0,+2,174.30D0,4.000D-25,0.5D0,
48527      & 'DBAR    ',      -1,   0,+1,0.3200D0,0.000D+00,0.5D0,
48528      & 'UBAR    ',      -2,   0,-2,0.3200D0,0.000D+00,0.5D0,
48529      & 'SBAR    ',      -3,   0,+1,0.5000D0,0.000D+00,0.5D0,
48530      & 'CBAR    ',      -4,   0,-2,1.5500D0,0.000D+00,0.5D0,
48531      & 'BBAR    ',      -5,   0,+1,4.9500D0,0.000D+00,0.5D0,
48532      & 'TBAR    ',      -6,   0,-2,174.30D0,4.000D-25,0.5D0,
48533      & 'GLUON   ',      21,   0, 0,0.7500D0,0.000D+00,1.0D0,
48534      & 'CMF     ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48535      & 'HARD    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48536      & 'SOFT    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0/
48537       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48538      &      RSPIN(I),I=17,32)/
48539      & 'CONE    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48540      & 'HEAVY   ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48541      & 'CLUS    ',      91,   0, 0,0.0000D0,0.000D+00,0.0D0,
48542      & '****    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48543      & 'PI0     ',     111,  11, 0,.13498D0,8.400D-17,0.0D0,
48544      & 'ETA     ',     221,  33, 0,.54730D0,0.000D+00,0.0D0,
48545      & 'RHO0    ',     113,  11, 0,.77000D0,0.000D+00,1.0D0,
48546      & 'OMEGA   ',     223,  33, 0,.78194D0,0.000D+00,1.0D0,
48547      & 'ETAP    ',     331,  33, 0,.95778D0,0.000D+00,0.0D0,
48548      & 'F_2     ',     225,  33, 0,1.2750D0,0.000D+00,2.0D0,
48549      & 'A_10    ',   20113,  11, 0,1.2300D0,0.000D+00,1.0D0,
48550      & 'FL_1    ',   20223,  33, 0,1.2819D0,0.000D+00,1.0D0,
48551      & 'A_20    ',     115,  11, 0,1.3181D0,0.000D+00,2.0D0,
48552      & 'PI-     ',    -211,  12,-1,.13957D0,2.603D-08,0.0D0,
48553      & 'RHO-    ',    -213,  12,-1,.77000D0,0.000D+00,1.0D0,
48554      & 'A_1-    ',  -20213,  12,-1,1.2300D0,0.000D+00,1.0D0/
48555       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48556      &      RSPIN(I),I=33,48)/
48557      & 'A_2-    ',    -215,  12,-1,1.3181D0,0.000D+00,2.0D0,
48558      & 'K-      ',    -321,  32,-1,.49368D0,1.237D-08,0.0D0,
48559      & 'K*-     ',    -323,  32,-1,.89166D0,0.000D+00,1.0D0,
48560      & 'KH_1-   ',  -20323,  32,-1,1.8500D0,0.000D+00,1.0D0,
48561      & 'K*_2-   ',    -325,  32,-1,1.4256D0,0.000D+00,2.0D0,
48562      & 'PI+     ',     211,  21,+1,.13957D0,2.603D-08,0.0D0,
48563      & 'RHO+    ',     213,  21,+1,.77000D0,0.000D+00,1.0D0,
48564      & 'A_1+    ',   20213,  21,+1,1.2300D0,0.000D+00,1.0D0,
48565      & 'A_2+    ',     215,  21,+1,1.3181D0,0.000D+00,2.0D0,
48566      & 'KBAR0   ',    -311,  31, 0,.49767D0,0.000D+00,0.0D0,
48567      & 'K*BAR0  ',    -313,  31, 0,.89610D0,0.000D+00,1.0D0,
48568      & 'KH_1BAR0',  -20313,  31, 0,1.8500D0,0.000D+00,1.0D0,
48569      & 'K*_2BAR0',    -315,  31, 0,1.4324D0,0.000D+00,2.0D0,
48570      & 'K+      ',     321,  23,+1,.49368D0,1.237D-08,0.0D0,
48571      & 'K*+     ',     323,  23,+1,.89166D0,0.000D+00,1.0D0,
48572      & 'KH_1+   ',   20323,  23,+1,1.8500D0,0.000D+00,1.0D0/
48573       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48574      &      RSPIN(I),I=49,64)/
48575      & 'K*_2+   ',     325,  23,+1,1.4256D0,0.000D+00,2.0D0,
48576      & 'K0      ',     311,  13, 0,.49767D0,0.000D+00,0.0D0,
48577      & 'K*0     ',     313,  13, 0,.89610D0,0.000D+00,1.0D0,
48578      & 'KH_10   ',   20313,  13, 0,1.8500D0,0.000D+00,1.0D0,
48579      & 'K*_20   ',     315,  13, 0,1.4324D0,0.000D+00,2.0D0,
48580      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48581      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48582      & 'PHI     ',     333,  33, 0,1.0194D0,0.000D+00,1.0D0,
48583      & 'FH_1    ',   20333,  33, 0,1.4262D0,0.000D+00,1.0D0,
48584      & 'FP_2    ',     335,  33, 0,1.5250D0,0.000D+00,2.0D0,
48585      & 'GAMMA   ',      22,   0, 0,0.0000D0,1.000D+30,1.0D0,
48586      & 'K_S0    ',     310,   0, 0,.49767D0,8.926D-11,0.0D0,
48587      & 'K_L0    ',     130,   0, 0,.49767D0,5.170D-08,0.0D0,
48588      & 'A_0(H)0 ',   10111,  11, 0,1.4740D0,0.000D+00,0.0D0,
48589      & 'A_0(H)+ ',   10211,  21,+1,1.4740D0,0.000D+00,0.0D0,
48590      & 'A_0(H)- ',  -10211,  12,-1,1.4740D0,0.000D+00,0.0D0/
48591       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48592      &      RSPIN(I),I=65,80)/
48593      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48594      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48595      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48596      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48597      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48598      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48599      & 'REMG    ',      98,   0, 0,0.0000D0,0.000D+00,0.0D0,
48600      & 'REMN    ',      99,   0, 0,0.0000D0,0.000D+00,0.0D0,
48601      & 'P       ',    2212, 122,+1,.93827D0,1.000D+30,0.5D0,
48602      & 'DELTA+  ',    2214, 122,+1,1.2320D0,0.000D+00,1.5D0,
48603      & 'N       ',    2112, 112, 0,.93957D0,8.870D+02,0.5D0,
48604      & 'DELTA0  ',    2114, 112, 0,1.2320D0,0.000D+00,1.5D0,
48605      & 'DELTA-  ',    1114, 111,-1,1.2320D0,0.000D+00,1.5D0,
48606      & 'LAMBDA  ',    3122, 123, 0,1.1157D0,2.632D-10,0.5D0,
48607      & 'SIGMA0  ',    3212, 123, 0,1.1926D0,7.400D-20,0.5D0,
48608      & 'SIGMA*0 ',    3214, 123, 0,1.3837D0,0.000D+00,1.5D0/
48609       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48610      &      RSPIN(I),I=81,96)/
48611      & 'SIGMA-  ',    3112, 113,-1,1.1974D0,1.479D-10,0.5D0,
48612      & 'SIGMA*- ',    3114, 113,-1,1.3872D0,0.000D+00,1.5D0,
48613      & 'XI-     ',    3312, 133,-1,1.3213D0,1.639D-10,0.5D0,
48614      & 'XI*-    ',    3314, 133,-1,1.5350D0,0.000D+00,1.5D0,
48615      & 'DELTA++ ',    2224, 222,+2,1.2320D0,0.000D+00,1.5D0,
48616      & 'SIGMA+  ',    3222, 223,+1,1.1894D0,7.990D-11,0.5D0,
48617      & 'SIGMA*+ ',    3224, 223,+1,1.3828D0,0.000D+00,1.5D0,
48618      & 'XI0     ',    3322, 233, 0,1.3149D0,2.900D-10,0.5D0,
48619      & 'XI*0    ',    3324, 233, 0,1.5318D0,0.000D+00,1.5D0,
48620      & 'OMEGA-  ',    3334, 333,-1,1.6725D0,8.220D-11,1.5D0,
48621      & 'PBAR    ',   -2212,-122,-1,.93827D0,1.000D+30,0.5D0,
48622      & 'DELTABR-',   -2214,-122,-1,1.2320D0,0.000D+00,1.5D0,
48623      & 'NBAR    ',   -2112,-112, 0,.93957D0,8.870D+02,0.5D0,
48624      & 'DELTABR0',   -2114,-112, 0,1.2320D0,0.000D+00,1.5D0,
48625      & 'DELTABR+',   -1114,-111,+1,1.2320D0,0.000D+00,1.5D0,
48626      & 'LAMBDABR',   -3122,-123, 0,1.1157D0,2.632D-10,0.5D0/
48627       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48628      &      RSPIN(I),I=97,112)/
48629      & 'SIGMABR0',   -3212,-123, 0,1.1926D0,7.400D-20,0.5D0,
48630      & 'SGMA*BR0',   -3214,-123, 0,1.3837D0,0.000D+00,1.5D0,
48631      & 'SIGMABR+',   -3112,-113,+1,1.1974D0,1.479D-10,0.5D0,
48632      & 'SGMA*BR+',   -3114,-113,+1,1.3872D0,0.000D+00,1.5D0,
48633      & 'XIBAR+  ',   -3312,-133,+1,1.3213D0,1.639D-10,0.5D0,
48634      & 'XI*BAR+ ',   -3314,-133,+1,1.5350D0,0.000D+00,1.5D0,
48635      & 'DLTABR--',   -2224,-222,-2,1.2320D0,0.000D+00,1.5D0,
48636      & 'SIGMABR-',   -3222,-223,-1,1.1894D0,7.990D-11,0.5D0,
48637      & 'SGMA*BR-',   -3224,-223,-1,1.3828D0,0.000D+00,1.5D0,
48638      & 'XIBAR0  ',   -3322,-233, 0,1.3149D0,2.900D-10,0.5D0,
48639      & 'XI*BAR  ',   -3324,-233, 0,1.5318D0,0.000D+00,1.5D0,
48640      & 'OMEGABR+',   -3334,-333,+1,1.6725D0,8.220D-11,1.5D0,
48641      & 'UU      ',    2203,   0,+4,0.6400D0,0.000D+00,0.0D0,
48642      & 'UD      ',    2101,   0,+1,0.6400D0,0.000D+00,0.0D0,
48643      & 'DD      ',    1103,   0,-2,0.6400D0,0.000D+00,0.0D0,
48644      & 'US      ',    3201,   0,+1,0.8200D0,0.000D+00,0.0D0/
48645       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48646      &      RSPIN(I),I=113,128)/
48647      & 'DS      ',    3101,   0,-2,0.8200D0,0.000D+00,0.0D0,
48648      & 'SS      ',    3303,   0,-2,1.0000D0,0.000D+00,0.0D0,
48649      & 'UBARUBAR',   -2203,   0,-4,0.6400D0,0.000D+00,0.0D0,
48650      & 'UBARDBAR',   -2101,   0,-1,0.6400D0,0.000D+00,0.0D0,
48651      & 'DBARDBAR',   -1103,   0,+2,0.6400D0,0.000D+00,0.0D0,
48652      & 'UBARSBAR',   -3201,   0,-1,0.8200D0,0.000D+00,0.0D0,
48653      & 'DBARSBAR',   -3101,   0,+2,0.8200D0,0.000D+00,0.0D0,
48654      & 'SBARSBAR',   -3303,   0,+2,1.0000D0,0.000D+00,0.0D0,
48655      & 'E-      ',      11,   0,-1,5.11D-04,1.000D+30,0.5D0,
48656      & 'NU_E    ',      12,   0, 0,0.0000D0,1.000D+30,0.5D0,
48657      & 'MU-     ',      13,   0,-1,.10566D0,2.197D-06,0.5D0,
48658      & 'NU_MU   ',      14,   0, 0,0.0000D0,1.000D+30,0.5D0,
48659      & 'TAU-    ',      15,   0,-1,1.7771D0,2.916D-13,0.5D0,
48660      & 'NU_TAU  ',      16,   0, 0,0.0000D0,1.000D+30,0.5D0,
48661      & 'E+      ',     -11,   0,+1,5.11D-04,1.000D+30,0.5D0,
48662      & 'NU_EBAR ',     -12,   0, 0,0.0000D0,1.000D+30,0.5D0/
48663       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48664      &      RSPIN(I),I=129,144)/
48665      & 'MU+     ',     -13,   0,+1,.10566D0,2.197D-06,0.5D0,
48666      & 'NU_MUBAR',     -14,   0, 0,0.0000D0,1.000D+30,0.5D0,
48667      & 'TAU+    ',     -15,   0,+1,1.7771D0,2.916D-13,0.5D0,
48668      & 'NU_TAUBR',     -16,   0, 0,0.0000D0,1.000D+30,0.5D0,
48669      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48670      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48671      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48672      & 'D+      ',     411,  41,+1,1.8693D0,1.057D-12,0.0D0,
48673      & 'D*+     ',     413,  41,+1,2.0100D0,0.000D+00,1.0D0,
48674      & 'DH_1+   ',   20413,  41,+1,2.4270D0,0.000D+00,1.0D0,
48675      & 'D*_2+   ',     415,  41,+1,2.4590D0,0.000D+00,2.0D0,
48676      & 'D0      ',     421,  42, 0,1.8646D0,4.150D-13,0.0D0,
48677      & 'D*0     ',     423,  42, 0,2.0067D0,0.000D+00,1.0D0,
48678      & 'DH_10   ',   20423,  42, 0,2.4222D0,0.000D+00,1.0D0,
48679      & 'D*_20   ',     425,  42, 0,2.4589D0,0.000D+00,2.0D0,
48680      & 'D_S+    ',     431,  43,+1,1.9685D0,4.670D-13,0.0D0/
48681       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48682      &      RSPIN(I),I=145,160)/
48683      & 'D*_S+   ',     433,  43,+1,2.1124D0,0.000D+00,1.0D0,
48684      & 'DH_S1+  ',   20433,  43,+1,2.5354D0,0.000D+00,1.0D0,
48685      & 'D*_S2+  ',     435,  43,+1,2.5735D0,0.000D+00,2.0D0,
48686      & 'SGMA_C++',    4222, 224,+2,2.4528D0,0.000D+00,0.5D0,
48687      & 'SGM*_C++',    4224, 224,+2,2.5194D0,0.000D+00,1.5D0,
48688      & 'LMBDA_C+',    4122, 124,+1,2.2849D0,2.060D-13,0.5D0,
48689      & 'SIGMA_C+',    4212, 124,+1,2.4536D0,0.000D+00,0.5D0,
48690      & 'SGMA*_C+',    4214, 124,+1,2.5185D0,0.000D+00,1.5D0,
48691      & 'SIGMA_C0',    4112, 114, 0,2.4522D0,0.000D+00,0.5D0,
48692      & 'SGMA*_C0',    4114, 114, 0,2.5175D0,0.000D+00,1.5D0,
48693      & 'XI_C+   ',    4232, 234,+1,2.4656D0,3.500D-13,0.5D0,
48694      & 'XIP_C+  ',    4322, 234,+1,2.5750D0,0.000D+00,0.5D0,
48695      & 'XI*_C+  ',    4324, 234,+1,2.6446D0,0.000D+00,1.5D0,
48696      & 'XI_C0   ',    4132, 134, 0,2.4703D0,9.800D-14,0.5D0,
48697      & 'XIP_C0  ',    4312, 134, 0,2.5800D0,0.000D+00,0.5D0,
48698      & 'XI*_C0  ',    4314, 134, 0,2.6438D0,0.000D+00,1.5D0/
48699       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48700      &      RSPIN(I),I=161,176)/
48701      & 'OMEGA_C0',    4332, 334, 0,2.7040D0,6.400D-14,0.5D0,
48702      & 'OMGA*_C0',    4334, 334, 0,2.7300D0,0.000D+00,1.5D0,
48703      & 'ETA_C   ',     441,  44, 0,2.9798D0,0.000D+00,0.0D0,
48704      & 'JPSI    ',     443,  44, 0,3.0969D0,0.000D+00,1.0D0,
48705      & 'CHI_C1  ',   10441,  44, 0,3.4173D0,0.000D+00,0.0D0,
48706      & 'PSI2S   ',  100443,  44, 0,3.6860D0,0.000D+00,1.0D0,
48707      & 'PSID    ',   30443,  44, 0,3.7699D0,0.000D+00,1.0D0,
48708      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48709      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48710      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48711      & 'D-      ',    -411,  14,-1,1.8693D0,1.057D-12,0.0D0,
48712      & 'D*-     ',    -413,  14,-1,2.0100D0,0.000D+00,1.0D0,
48713      & 'DH_1-   ',  -20413,  14,-1,2.4270D0,0.000D+00,1.0D0,
48714      & 'D*_2-   ',    -415,  14,-1,2.4590D0,0.000D+00,2.0D0,
48715      & 'DBAR0   ',    -421,  24, 0,1.8646D0,4.140D-13,0.0D0,
48716      & 'D*BAR0  ',    -423,  24, 0,2.0067D0,0.000D+00,1.0D0/
48717       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48718      &      RSPIN(I),I=177,192)/
48719      & 'DH_1BAR0',  -20423,  24, 0,2.4222D0,0.000D+00,1.0D0,
48720      & 'D*_2BAR0',    -425,  24, 0,2.4589D0,0.000D+00,2.0D0,
48721      & 'D_S-    ',    -431,  34,-1,1.9685D0,4.670D-13,0.0D0,
48722      & 'D*_S-   ',    -433,  34,-1,2.1124D0,0.000D+00,1.0D0,
48723      & 'DH_S1-  ',  -20433,  34,-1,2.5354D0,0.000D+00,1.0D0,
48724      & 'D*_S2-  ',    -435,  34,-1,2.5735D0,0.000D+00,2.0D0,
48725      & 'SGMA_C--',   -4222,-224,-2,2.4528D0,0.000D+00,0.5D0,
48726      & 'SGM*_C--',   -4224,-224,-2,2.5194D0,0.000D+00,1.5D0,
48727      & 'LMBDA_C-',   -4122,-124,-1,2.2849D0,2.060D-13,0.5D0,
48728      & 'SIGMA_C-',   -4212,-124,-1,2.4536D0,0.000D+00,0.5D0,
48729      & 'SGMA*_C-',   -4214,-124,-1,2.5185D0,0.000D+00,1.5D0,
48730      & 'SGM_CBR0',   -4112,-114, 0,2.4522D0,0.000D+00,0.5D0,
48731      & 'SG*_CBR0',   -4114,-114, 0,2.5175D0,0.000D+00,1.5D0,
48732      & 'XI_C-   ',   -4232,-234,-1,2.4656D0,3.500D-13,0.5D0,
48733      & 'XIP_C-  ',   -4322,-234,-1,2.5750D0,0.000D+00,0.5D0,
48734      & 'XI*_C-  ',   -4324,-234,-1,2.6446D0,0.000D+00,1.5D0/
48735       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48736      &      RSPIN(I),I=193,208)/
48737      & 'XI_CBAR0',   -4132,-134, 0,2.4703D0,9.800D-14,0.5D0,
48738      & 'XIP_CBR0',   -4312,-134, 0,2.5800D0,0.000D+00,0.5D0,
48739      & 'XI*_CBR0',   -4314,-134, 0,2.6438D0,0.000D+00,1.5D0,
48740      & 'OMG_CBR0',   -4332,-334, 0,2.7040D0,6.400D-14,0.5D0,
48741      & 'OM*_CBR0',   -4334,-334, 0,2.7300D0,0.000D+00,1.5D0,
48742      & 'W+      ',      24,   0,+1,80.420D0,0.000D+00,1.0D0,
48743      & 'W-      ',     -24,   0,-1,80.420D0,0.000D+00,1.0D0,
48744      & 'Z0/GAMA*',      23,   0, 0,91.188D0,0.000D+00,1.0D0,
48745      & 'HIGGS   ',      25,   0, 0,115.00D0,0.000D+00,0.0D0,
48746      & 'Z0P     ',      32,   0, 0,500.00D0,0.000D+00,1.0D0,
48747      & 'HIGGSL0 ',      26,   0, 0,0.0000D0,1.000D+30,0.0D0,
48748      & 'HIGGSH0 ',      35,   0, 0,0.0000D0,1.000D+30,0.0D0,
48749      & 'HIGGSA0 ',      36,   0, 0,0.0000D0,1.000D+30,0.0D0,
48750      & 'HIGGS+  ',      37,   0,+1,0.0000D0,1.000D+30,0.0D0,
48751      & 'HIGGS-  ',     -37,   0,-1,0.0000D0,1.000D+30,0.0D0,
48752      & 'GRAVITON',      39,   0, 0,0.0000D0,1.000D+30,2.0D0/
48753       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48754      &      RSPIN(I),I=209,224)/
48755      & 'VQRK    ',       7,   0,-1,200.00D0,0.000D+00,0.5D0,
48756      & 'AQRK    ',       8,   0,+2,400.00D0,0.000D+00,0.5D0,
48757      & 'HQRK    ',       7,   0,-1,400.00D0,0.000D+00,0.5D0,
48758      & 'HPQK    ',       8,   0,+2,600.00D0,0.000D+00,0.5D0,
48759      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48760      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48761      & 'VBAR    ',      -7,   0,+1,200.00D0,0.000D+00,0.5D0,
48762      & 'ABAR    ',      -8,   0,-2,400.00D0,0.000D+00,0.5D0,
48763      & 'HBAR    ',      -7,   0,+1,400.00D0,0.000D+00,0.5D0,
48764      & 'HPBR    ',      -8,   0,-2,600.00D0,0.000D+00,0.5D0,
48765      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48766      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
48767      & 'B_DBAR0 ',    -511,  51, 0,5.2792D0,1.614D-12,0.0D0,
48768      & 'B-      ',    -521,  52,-1,5.2789D0,1.652D-12,0.0D0,
48769      & 'B_SBAR0 ',    -531,  53, 0,5.3693D0,1.540D-12,0.0D0,
48770      & 'SIGMA_B+',    5222, 225,+1,5.8200D0,1.070D-12,0.5D0/
48771       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48772      &      RSPIN(I),I=225,240)/
48773      & 'LMBDA_B0',    5122, 125, 0,5.6240D0,1.070D-12,0.5D0,
48774      & 'SIGMA_B-',    5112, 115,-1,5.8200D0,1.070D-12,0.5D0,
48775      & 'XI_B0   ',    5232, 235, 0,5.8000D0,1.070D-12,0.5D0,
48776      & 'XI_B-   ',    5132, 135,-1,5.8000D0,1.070D-12,0.5D0,
48777      & 'OMEGA_B-',    5332, 335,-1,6.0400D0,1.070D-12,0.5D0,
48778      & 'B_C-    ',    -541,  54,-1,6.2500D0,1.000D-12,0.5D0,
48779      & 'UPSLON1S',     553,  55, 0,9.4604D0,0.000D+00,1.0D0,
48780      & 'T_B-    ',    -651,  56,-1,0.0000D0,0.000D+00,0.0D0,
48781      & 'T+      ',     611,  61,+1,0.0000D0,0.000D+00,0.0D0,
48782      & 'T0      ',     621,  62, 0,0.0000D0,0.000D+00,0.0D0,
48783      & 'T_S+    ',     631,  63,+1,0.0000D0,0.000D+00,0.0D0,
48784      & 'SGMA_T++',    6222, 226,+2,0.0000D0,0.000D+00,0.5D0,
48785      & 'LMBDA_T0',    6122, 126,+1,0.0000D0,0.000D+00,0.5D0,
48786      & 'SIGMA_T0',    6112, 116, 0,0.0000D0,0.000D+00,0.5D0,
48787      & 'XI_T+   ',    6232, 236,+1,0.0000D0,0.000D+00,0.5D0,
48788      & 'XI_T0   ',    6132, 136, 0,0.0000D0,0.000D+00,0.5D0/
48789       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48790      &      RSPIN(I),I=241,256)/
48791      & 'OMEGA_T0',    6332, 336, 0,0.0000D0,0.000D+00,0.5D0,
48792      & 'T_C0    ',     641,  64, 0,0.0000D0,0.000D+00,0.0D0,
48793      & 'T_B+    ',     651,  65,+1,0.0000D0,0.000D+00,0.0D0,
48794      & 'TOPONIUM',     663,  66, 0,0.0000D0,0.000D+00,1.0D0,
48795      & 'B_D0    ',     511,  15, 0,5.2792D0,1.614D-12,0.0D0,
48796      & 'B+      ',     521,  25,+1,5.2789D0,1.652D-12,0.0D0,
48797      & 'B_S0    ',     531,  35, 0,5.3693D0,1.540D-12,0.0D0,
48798      & 'SGM_BBR-',   -5222,-225,-1,5.8200D0,1.070D-12,0.5D0,
48799      & 'LMD_BBR0',   -5122,-125, 0,5.6240D0,1.070D-12,0.5D0,
48800      & 'SGM_BBR+',   -5112,-115,+1,5.8200D0,1.070D-12,0.5D0,
48801      & 'XI_BBAR0',   -5232,-235, 0,5.8000D0,1.070D-12,0.5D0,
48802      & 'XI_B+   ',   -5132,-135,+1,5.8000D0,1.070D-12,0.5D0,
48803      & 'OMG_BBR+',   -5332,-335,+1,6.0400D0,1.070D-12,0.5D0,
48804      & 'B_C+    ',     541,  45,+1,6.2500D0,1.000D-12,0.5D0,
48805      & 'T-      ',    -611,  16,-1,0.0000D0,0.000D+00,0.0D0,
48806      & 'TBAR0   ',    -621,  26, 0,0.0000D0,0.000D+00,0.0D0/
48807       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48808      &      RSPIN(I),I=257,272)/
48809      & 'T_S-    ',    -631,  36,-1,0.0000D0,0.000D+00,0.0D0,
48810      & 'SGMA_T--',   -6222,-226,-2,0.0000D0,0.000D+00,0.5D0,
48811      & 'LAMDA_T-',   -6122,-126,-1,0.0000D0,0.000D+00,0.5D0,
48812      & 'SGM_TBR0',   -6112,-116, 0,0.0000D0,0.000D+00,0.5D0,
48813      & 'XI_T-   ',   -6232,-236,-1,0.0000D0,0.000D+00,0.5D0,
48814      & 'XI_TBAR0',   -6132,-136, 0,0.0000D0,0.000D+00,0.5D0,
48815      & 'OMG_TBR0',   -6332,-336, 0,0.0000D0,0.000D+00,0.5D0,
48816      & 'T_CBAR0 ',    -641,  46, 0,0.0000D0,0.000D+00,0.0D0,
48817      & 'B*BAR0  ',    -513,  51, 0,5.3249D0,0.000D+00,1.0D0,
48818      & 'B*-     ',    -523,  52,-1,5.3249D0,0.000D+00,1.0D0,
48819      & 'B*_SBAR0',    -533,  53, 0,5.4163D0,0.000D+00,1.0D0,
48820      & 'BH_1BAR0',  -20513,  51, 0,5.7600D0,0.000D+00,1.0D0,
48821      & 'BH_1-   ',  -20523,  52,-1,5.7600D0,0.000D+00,1.0D0,
48822      & 'BH_S1BR0',  -20533,  53, 0,5.8550D0,0.000D+00,1.0D0,
48823      & 'B*_2BAR0',    -515,  51, 0,5.7700D0,0.000D+00,2.0D0,
48824      & 'B*_2-   ',    -525,  52,-1,5.7700D0,0.000D+00,2.0D0/
48825       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48826      &      RSPIN(I),I=273,288)/
48827      & 'B*_S2BR0',    -535,  53, 0,5.8650D0,0.000D+00,2.0D0,
48828      & 'B*0     ',     513,  15, 0,5.3249D0,0.000D+00,1.0D0,
48829      & 'B*+     ',     523,  25,+1,5.3249D0,0.000D+00,1.0D0,
48830      & 'B*_S0   ',     533,  35, 0,5.4163D0,0.000D+00,1.0D0,
48831      & 'BH_10   ',   20513,  15, 0,5.7600D0,0.000D+00,1.0D0,
48832      & 'BH_1+   ',   20523,  25,+1,5.7600D0,0.000D+00,1.0D0,
48833      & 'BH_S10  ',   20533,  35, 0,5.8550D0,0.000D+00,1.0D0,
48834      & 'B*_20   ',     515,  15, 0,5.7700D0,0.000D+00,2.0D0,
48835      & 'B*_2+   ',     525,  25,+1,5.7700D0,0.000D+00,2.0D0,
48836      & 'B*_S20  ',     535,  35, 0,5.8650D0,0.000D+00,2.0D0,
48837      & '        ',       0,   0, 0,0.0000D0,0.000D+00,  0D0,
48838      & '        ',       0,   0, 0,0.0000D0,0.000D+00,  0D0,
48839      & 'B_10    ',   10113,  11, 0,1.2295D0,0.000D+00,1.0D0,
48840      & 'B_1+    ',   10213,  21,+1,1.2295D0,0.000D+00,1.0D0,
48841      & 'B_1-    ',  -10213,  12,-1,1.2295D0,0.000D+00,1.0D0,
48842      & 'HL_10   ',   10223,  33, 0,1.1700D0,0.000D+00,1.0D0/
48843       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48844      &      RSPIN(I),I=289,304)/
48845      & 'HH_10   ',   10333,  33, 0,1.3950D0,0.000D+00,1.0D0,
48846      & 'A_00    ', 9000111,  11, 0,.99600D0,0.000D+00,0.0D0,
48847      & 'A_0+    ', 9000211,  21,+1,.99600D0,0.000D+00,0.0D0,
48848      & 'A_0-    ',-9000211,  12,-1,.99600D0,0.000D+00,0.0D0,
48849      & 'F0P0    ', 9010221,  33, 0,.99600D0,0.000D+00,0.0D0,
48850      & 'FH_00   ',   10221,  33, 0,1.3500D0,0.000D+00,0.0D0,
48851      & 'B*_C+   ',     543,  45,+1,6.2950D0,0.000D+00,1.0D0,
48852      & 'B*_C-   ',    -543,  54,-1,6.2950D0,0.000D+00,1.0D0,
48853      & 'BH_C1+  ',   20543,  45,+1,6.7300D0,0.000D+00,1.0D0,
48854      & 'BH_C1-  ',  -20543,  54,-1,6.7300D0,0.000D+00,1.0D0,
48855      & 'B*_C2+  ',     545,  45,+1,6.7400D0,0.000D+00,2.0D0,
48856      & 'B*_C2-  ',    -545,  54,-1,6.7400D0,0.000D+00,2.0D0,
48857      & 'H_C     ',   10443,  44, 0,3.5261D0,0.000D+00,1.0D0,
48858      & 'CHI_C0  ',   20443,  44, 0,3.5105D0,0.000D+00,0.0D0,
48859      & 'CHI_C2  ',     445,  44, 0,3.5562D0,0.000D+00,2.0D0,
48860      & 'ETA_B   ',     551,  55, 0,9.0000D0,0.000D+00,0.0D0/
48861       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48862      &      RSPIN(I),I=305,320)/
48863      & 'H_B     ',   10553,  55, 0,9.8880D0,0.000D+00,1.0D0,
48864      & 'CHI_B0  ',   10551,  55, 0,9.8598D0,0.000D+00,0.0D0,
48865      & 'CHI_B1  ',   20553,  55, 0,9.8919D0,0.000D+00,1.0D0,
48866      & 'CHI_B2  ',     555,  55, 0,9.9132D0,0.000D+00,2.0D0,
48867      & 'KL_10   ',   10313,  13, 0,1.5700D0,0.000D+00,1.0D0,
48868      & 'KL_1+   ',   10323,  23,+1,1.5700D0,0.000D+00,1.0D0,
48869      & 'KL_1BAR0',  -10313,  31, 0,1.5700D0,0.000D+00,1.0D0,
48870      & 'KL_1-   ',  -10323,  32,-1,1.5700D0,0.000D+00,1.0D0,
48871      & 'DL_1+   ',   10413,  41,+1,2.4270D0,0.000D+00,1.0D0,
48872      & 'DL_10   ',   10423,  42, 0,2.4222D0,0.000D+00,1.0D0,
48873      & 'DL_S1+  ',   10433,  43,+1,2.5354D0,0.000D+00,1.0D0,
48874      & 'DL_1-   ',  -10413,  14,-1,2.4270D0,0.000D+00,1.0D0,
48875      & 'DL_1BAR0',  -10423,  24, 0,2.4222D0,0.000D+00,1.0D0,
48876      & 'DL_S1-  ',  -10433,  34,-1,2.5354D0,0.000D+00,1.0D0,
48877      & 'BL_10   ',   10513,  15, 0,5.7600D0,0.000D+00,1.0D0,
48878      & 'BL_1+   ',   10523,  25,+1,5.7600D0,0.000D+00,1.0D0/
48879       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48880      &      RSPIN(I),I=321,336)/
48881      & 'BL_S10  ',   10533,  35, 0,5.8530D0,0.000D+00,1.0D0,
48882      & 'BL_C1+  ',   10543,  45,+1,6.7300D0,0.000D+00,1.0D0,
48883      & 'BL_1BAR0',  -10513,  51, 0,5.7600D0,0.000D+00,1.0D0,
48884      & 'BL_1-   ',  -10523,  52,-1,5.7600D0,0.000D+00,1.0D0,
48885      & 'BL_S1BR0',  -10533,  53, 0,5.8530D0,0.000D+00,1.0D0,
48886      & 'BL_C1-  ',  -10543,  54,-1,6.7300D0,0.000D+00,1.0D0,
48887      & 'K*_0+   ',   10321,  23,+1,1.4290D0,0.000D+00,0.0D0,
48888      & 'K*_00   ',   10311,  13, 0,1.4290D0,0.000D+00,0.0D0,
48889      & 'K*_0BAR0',  -10311,  31, 0,1.4290D0,0.000D+00,0.0D0,
48890      & 'K*_0-   ',  -10321,  32,-1,1.4290D0,0.000D+00,0.0D0,
48891      & 'D*_0+   ',   10411,  41,+1,2.4230D0,0.000D+00,0.0D0,
48892      & 'D*_00   ',   10421,  42, 0,2.4230D0,0.000D+00,0.0D0,
48893      & 'D*_S0+  ',   10431,  43,+1,2.5250D0,0.000D+00,0.0D0,
48894      & 'D*_0-   ',  -10411,  14,-1,2.4230D0,0.000D+00,0.0D0,
48895      & 'D*_0BAR0',  -10421,  24, 0,2.4230D0,0.000D+00,0.0D0,
48896      & 'D*_S0-  ',  -10431,  34,-1,2.5250D0,0.000D+00,0.0D0/
48897       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48898      &      RSPIN(I),I=337,352)/
48899      & 'B*_00   ',   10511,  15, 0,5.7600D0,0.000D+00,0.0D0,
48900      & 'B*_0+   ',   10521,  25,+1,5.7600D0,0.000D+00,0.0D0,
48901      & 'B*_S00  ',   10531,  35, 0,5.8550D0,0.000D+00,0.0D0,
48902      & 'B*_C0+  ',   10541,  45,+1,6.7300D0,0.000D+00,0.0D0,
48903      & 'B*_0BAR0',  -10511,  51, 0,5.7600D0,0.000D+00,0.0D0,
48904      & 'B*_0-   ',  -10521,  52,-1,5.7600D0,0.000D+00,0.0D0,
48905      & 'B*_S0BR0',  -10531,  53, 0,5.8550D0,0.000D+00,0.0D0,
48906      & 'B*_C0-  ',  -10541,  54,-1,6.7300D0,0.000D+00,0.0D0,
48907      & 'SGMA*_B-',    5114, 115,-1,5.8400D0,0.000D+00,1.5D0,
48908      & 'SIGMA_B0',    5212, 125, 0,5.8200D0,0.000D+00,0.5D0,
48909      & 'SGMA*_B0',    5214, 125, 0,5.8400D0,0.000D+00,1.5D0,
48910      & 'SGMA*_B+',    5224, 225,+1,5.8400D0,0.000D+00,1.5D0,
48911      & 'XIP_B0  ',    5322, 235, 0,5.9450D0,0.000D+00,0.5D0,
48912      & 'XI*_B0  ',    5324, 235, 0,5.9450D0,0.000D+00,1.5D0,
48913      & 'XIP_B-  ',    5312, 135,-1,5.9450D0,0.000D+00,0.5D0,
48914      & 'XI*_B-  ',    5314, 135,-1,5.9450D0,0.000D+00,1.5D0/
48915       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48916      &      RSPIN(I),I=353,368)/
48917      & '0MGA*_B-',    5334, 335,-1,6.0600D0,0.000D+00,1.5D0,
48918      & 'SG*_BBR+',   -5114,-115,+1,5.8400D0,0.000D+00,1.5D0,
48919      & 'SGM_BBR0',   -5212,-125, 0,5.8200D0,0.000D+00,0.5D0,
48920      & 'SG*_BBR0',   -5214,-125, 0,5.8400D0,0.000D+00,1.5D0,
48921      & 'SG*_BBR-',   -5224,-225,-1,5.8400D0,0.000D+00,1.5D0,
48922      & 'XIP_BBR0',   -5322,-235, 0,5.9450D0,0.000D+00,0.5D0,
48923      & 'XI*_BBR0',   -5324,-235, 0,5.9450D0,0.000D+00,1.5D0,
48924      & 'XIP_B+  ',   -5312,-135,+1,5.9450D0,0.000D+00,0.5D0,
48925      & 'XI*_B+  ',   -5314,-135,+1,5.9450D0,0.000D+00,1.5D0,
48926      & '0MGA*_B+',   -5334,-335,+1,6.0600D0,0.000D+00,1.5D0,
48927      & 'KDL_2+  ',   10325,  23,+1,1.7730D0,0.000D+00,2.0D0,
48928      & 'KDL_20  ',   10315,  13, 0,1.7730D0,0.000D+00,2.0D0,
48929      & 'KDL_2BR0',  -10315,  31, 0,1.7730D0,0.000D+00,2.0D0,
48930      & 'KDL_2-  ',  -10325,  32,-1,1.7730D0,0.000D+00,2.0D0,
48931      & 'KD*+    ',   30323,  23,+1,1.7170D0,0.000D+00,1.0D0,
48932      & 'KD*0    ',   30313,  13, 0,1.7170D0,0.000D+00,1.0D0/
48933       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48934      &      RSPIN(I),I=369,384)/
48935      & 'KD*BAR0 ',  -30313,  31, 0,1.7170D0,0.000D+00,1.0D0,
48936      & 'KD*-    ',  -30323,  32,-1,1.7170D0,0.000D+00,1.0D0,
48937      & 'KDH_2+  ',   20325,  23,+1,1.8160D0,0.000D+00,2.0D0,
48938      & 'KDH_20  ',   20315,  13, 0,1.8160D0,0.000D+00,2.0D0,
48939      & 'KDH_2BR0',  -20315,  31, 0,1.8160D0,0.000D+00,2.0D0,
48940      & 'KDH_2-  ',  -20325,  32,-1,1.8160D0,0.000D+00,2.0D0,
48941      & 'KD_3+   ',     327,  23,+1,1.7730D0,0.000D+00,3.0D0,
48942      & 'KD_30   ',     317,  13, 0,1.7730D0,0.000D+00,3.0D0,
48943      & 'KD_3BAR0',    -317,  31, 0,1.7730D0,0.000D+00,3.0D0,
48944      & 'KD_3-   ',    -327,  32,-1,1.7730D0,0.000D+00,3.0D0,
48945      & 'PI_2+   ',   10215,  21,+1,1.6700D0,0.000D+00,2.0D0,
48946      & 'PI_20   ',   10115,  11, 0,1.6700D0,0.000D+00,2.0D0,
48947      & 'PI_2-   ',  -10215,  12,-1,1.6700D0,0.000D+00,2.0D0,
48948      & 'RHOD+   ',   30213,  21,+1,1.7000D0,0.000D+00,1.0D0,
48949      & 'RHOD0   ',   30113,  11, 0,1.7000D0,0.000D+00,1.0D0,
48950      & 'RHOD-   ',  -30213,  12,-1,1.7000D0,0.000D+00,1.0D0/
48951       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48952      &      RSPIN(I),I=385,400)/
48953      & 'RHO_3+  ',     217,  21,+1,1.6910D0,0.000D+00,3.0D0,
48954      & 'RHO_30  ',     117,  11, 0,1.6910D0,0.000D+00,3.0D0,
48955      & 'RHO_3-  ',    -217,  12,-1,1.6910D0,0.000D+00,3.0D0,
48956      & 'UPSLON2S',  100553,  55, 0,10.023D0,0.000D+00,1.0D0,
48957      & 'CHI2P_B0',  110551,  55, 0,10.232D0,0.000D+00,0.0D0,
48958      & 'CHI2P_B1',  120553,  55, 0,10.255D0,0.000D+00,1.0D0,
48959      & 'CHI2P_B2',  100555,  55, 0,10.269D0,0.000D+00,2.0D0,
48960      & 'UPSLON3S',  200553,  55, 0,10.355D0,0.000D+00,1.0D0,
48961      & 'UPSLON4S',  300553,  55, 0,10.580D0,0.000D+00,1.0D0,
48962      & '        ',       0,   0, 0,0.0   D0,  0.0D+00,  0D0,
48963      & 'OMEGA_3 ',     227,  33, 0,1.6670D0,0.000D+00,3.0D0,
48964      & 'PHI_3   ',     337,  33, 0,1.8540D0,0.000D+00,3.0D0,
48965      & 'ETA_2(L)',   10225,  33, 0,1.6320D0,0.000D+00,2.0D0,
48966      & 'ETA_2(H)',   10335,  33, 0,1.8540D0,0.000D+00,2.0D0,
48967      & 'OMEGA(H)',   30223,  33, 0,1.6490D0,0.000D+00,1.0D0,
48968      & '        ',       0,   0, 0,0.0   D0,0.0D+00  ,  0D0/
48969       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48970      &      RSPIN(I),I=401,416)/
48971      & 'SSDL    ', 1000001,   0,-1,0.00D0,1.000D+30,0.0D0,
48972      & 'SSUL    ', 1000002,   0,+2,0.00D0,1.000D+30,0.0D0,
48973      & 'SSSL    ', 1000003,   0,-1,0.00D0,1.000D+30,0.0D0,
48974      & 'SSCL    ', 1000004,   0,+2,0.00D0,1.000D+30,0.0D0,
48975      & 'SSB1    ', 1000005,   0,-1,0.00D0,1.000D+30,0.0D0,
48976      & 'SST1    ', 1000006,   0,+2,0.00D0,1.000D+30,0.0D0,
48977      & 'SSDLBR  ',-1000001,   0,+1,0.00D0,1.000D+30,0.0D0,
48978      & 'SSULBR  ',-1000002,   0,-2,0.00D0,1.000D+30,0.0D0,
48979      & 'SSSLBR  ',-1000003,   0,+1,0.00D0,1.000D+30,0.0D0,
48980      & 'SSCLBR  ',-1000004,   0,-2,0.00D0,1.000D+30,0.0D0,
48981      & 'SSB1BR  ',-1000005,   0,+1,0.00D0,1.000D+30,0.0D0,
48982      & 'SST1BR  ',-1000006,   0,-2,0.00D0,1.000D+30,0.0D0,
48983      & 'SSDR    ', 2000001,   0,-1,0.00D0,1.000D+30,0.0D0,
48984      & 'SSUR    ', 2000002,   0,+2,0.00D0,1.000D+30,0.0D0,
48985      & 'SSSR    ', 2000003,   0,-1,0.00D0,1.000D+30,0.0D0,
48986      & 'SSCR    ', 2000004,   0,+2,0.00D0,1.000D+30,0.0D0/
48987       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48988      &      RSPIN(I),I=417,432)/
48989      & 'SSB2    ', 2000005,   0,-1,0.00D0,1.000D+30,0.0D0,
48990      & 'SST2    ', 2000006,   0,+2,0.00D0,1.000D+30,0.0D0,
48991      & 'SSDRBR  ',-2000001,   0,+1,0.00D0,1.000D+30,0.0D0,
48992      & 'SSURBR  ',-2000002,   0,-2,0.00D0,1.000D+30,0.0D0,
48993      & 'SSSRBR  ',-2000003,   0,+1,0.00D0,1.000D+30,0.0D0,
48994      & 'SSCRBR  ',-2000004,   0,-2,0.00D0,1.000D+30,0.0D0,
48995      & 'SSB2BR  ',-2000005,   0,+1,0.00D0,1.000D+30,0.0D0,
48996      & 'SST2BR  ',-2000006,   0,-2,0.00D0,1.000D+30,0.0D0,
48997      & 'SSEL-   ', 1000011,   0,-1,0.00D0,1.000D+30,0.0D0,
48998      & 'SSNUEL  ', 1000012,   0, 0,0.00D0,1.000D+30,0.0D0,
48999      & 'SSMUL-  ', 1000013,   0,-1,0.00D0,1.000D+30,0.0D0,
49000      & 'SSNUMUL ', 1000014,   0, 0,0.00D0,1.000D+30,0.0D0,
49001      & 'SSTAU1- ', 1000015,   0,-1,0.00D0,1.000D+30,0.0D0,
49002      & 'SSNUTL  ', 1000016,   0, 0,0.00D0,1.000D+30,0.0D0,
49003      & 'SSEL+   ',-1000011,   0,+1,0.00D0,1.000D+30,0.0D0,
49004      & 'SSNUELBR',-1000012,   0, 0,0.00D0,1.000D+30,0.0D0/
49005       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
49006      &      RSPIN(I),I=433,448)/
49007      & 'SSMUL+  ',-1000013,   0,+1,0.00D0,1.000D+30,0.0D0,
49008      & 'SSNUMLBR',-1000014,   0, 0,0.00D0,1.000D+30,0.0D0,
49009      & 'SSTAU1+ ',-1000015,   0,+1,0.00D0,1.000D+30,0.0D0,
49010      & 'SSNUTLBR',-1000016,   0, 0,0.00D0,1.000D+30,0.0D0,
49011      & 'SSER-   ', 2000011,   0,-1,0.00D0,1.000D+30,0.0D0,
49012      & 'SSNUER  ', 2000012,   0, 0,0.00D0,1.000D+30,0.0D0,
49013      & 'SSMUR-  ', 2000013,   0,-1,0.00D0,1.000D+30,0.0D0,
49014      & 'SSNUMUR ', 2000014,   0, 0,0.00D0,1.000D+30,0.0D0,
49015      & 'SSTAU2- ', 2000015,   0,-1,0.00D0,1.000D+30,0.0D0,
49016      & 'SSNUTR  ', 2000016,   0, 0,0.00D0,1.000D+30,0.0D0,
49017      & 'SSER+   ',-2000011,   0,+1,0.00D0,1.000D+30,0.0D0,
49018      & 'SSNUERBR',-2000012,   0, 0,0.00D0,1.000D+30,0.0D0,
49019      & 'SSMUR+  ',-2000013,   0,+1,0.00D0,1.000D+30,0.0D0,
49020      & 'SSNUMRBR',-2000014,   0, 0,0.00D0,1.000D+30,0.0D0,
49021      & 'SSTAU2+ ',-2000015,   0,+1,0.00D0,1.000D+30,0.0D0,
49022      & 'SSNUTRBR',-2000016,   0, 0,0.00D0,1.000D+30,0.0D0/
49023       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
49024      &      RSPIN(I),I=449,NLAST)/
49025      & 'GLUINO  ', 1000021,   0, 0,0.00D0,1.000D+30,0.5D0,
49026      & 'NTLINO1 ', 1000022,   0, 0,0.00D0,1.000D+30,0.5D0,
49027      & 'NTLINO2 ', 1000023,   0, 0,0.00D0,1.000D+30,0.5D0,
49028      & 'NTLINO3 ', 1000025,   0, 0,0.00D0,1.000D+30,0.5D0,
49029      & 'NTLINO4 ', 1000035,   0, 0,0.00D0,1.000D+30,0.5D0,
49030      & 'CHGINO1+', 1000024,   0,+1,0.00D0,1.000D+30,0.5D0,
49031      & 'CHGINO2+', 1000037,   0,+1,0.00D0,1.000D+30,0.5D0,
49032      & 'CHGINO1-',-1000024,   0,-1,0.00D0,1.000D+30,0.5D0,
49033      & 'CHGINO2-',-1000037,   0,-1,0.00D0,1.000D+30,0.5D0,
49034      & 'GRAVTINO', 1000039,   0, 0,0.00D0,1.000D+30,1.5D0/
49035 C
49036       DATA QORQQB/.FALSE.,
49037      & 6*.TRUE.,6*.FALSE.,96*.FALSE.,6*.FALSE.,6*.TRUE.,NREST*.FALSE./
49038       DATA QBORQQ/.FALSE.,
49039      & 6*.FALSE.,6*.TRUE.,96*.FALSE.,6*.TRUE.,6*.FALSE.,NREST*.FALSE./
49040 C
49041 C     In the character strings use an ampersand to represent a backslash
49042 C     to avoid compiler problems with the C escape character
49043       DATA ((TXNAME(J,I),J=1,2),I=0,8)/
49044      & '                                     ',
49045      & '                                     ',
49046      & '                                    d',
49047      & '                                    d',
49048      & '                                    u',
49049      & '                                    u',
49050      & '                                    s',
49051      & '                                    s',
49052      & '                                    c',
49053      & '                                    c',
49054      & '                                    b',
49055      & '                                    b',
49056      & '                                    t',
49057      & '                                    t',
49058      & '                        $&bar{&rm d}$',
49059      & '                                   -d',
49060      & '                        $&bar{&rm u}$',
49061      & '                                   -u'/
49062       DATA ((TXNAME(J,I),J=1,2),I=9,16)/
49063      & '                        $&bar{&rm s}$',
49064      & '                                   -s',
49065      & '                        $&bar{&rm c}$',
49066      & '                                   -c',
49067      & '                        $&bar{&rm b}$',
49068      & '                                   -b',
49069      & '                        $&bar{&rm t}$',
49070      & '                                   -t',
49071      & '                                  $g$',
49072      & '                                    g',
49073      & '                                  CoM',
49074      & '                                  CoM',
49075      & '                                 Hard',
49076      & '                                 Hard',
49077      & '                                 Soft',
49078      & '                                 Soft'/
49079       DATA ((TXNAME(J,I),J=1,2),I=17,24)/
49080      & '                                 Cone',
49081      & '                                 Cone',
49082      & '                                Heavy',
49083      & '                                Heavy',
49084      & '                              Cluster',
49085      & '                              Cluster',
49086      & '               $&star&star&star&star$',
49087      & '                                 ****',
49088      & '                              $&pi^0$',
49089      & '                       pi<SUP>0</SUP>',
49090      & '                               $&eta$',
49091      & '                                  eta',
49092      & '                             $&rho^0$',
49093      & '                      rho<SUP>0</SUP>',
49094      & '                             $&omega$',
49095      & '                                omega'/
49096       DATA ((TXNAME(J,I),J=1,2),I=25,32)/
49097      & '                        $&eta^&prime$',
49098      & '                      eta<SUP>''</SUP>',
49099      & '                                $f_2$',
49100      & '                        f<SUB>2</SUB>',
49101      & '                              $a^0_1$',
49102      & '            a<SUB>1</SUB><SUP>0</SUP>',
49103      & '                             $f_1(L)$',
49104      & '                     f<SUB>1</SUB>(L)',
49105      & '                              $a^0_2$',
49106      & '            a<SUB>2</SUB><SUP>0</SUP>',
49107      & '                              $&pi^-$',
49108      & '                       pi<SUP>-</SUP>',
49109      & '                             $&rho^-$',
49110      & '                      rho<SUP>-</SUP>',
49111      & '                              $a^-_1$',
49112      & '            a<SUB>1</SUB><SUP>-</SUP>'/
49113       DATA ((TXNAME(J,I),J=1,2),I=33,40)/
49114      & '                              $a^-_2$',
49115      & '            a<SUB>2</SUB><SUP>-</SUP>',
49116      & '                                K$^-$',
49117      & '                        K<SUP>-</SUP>',
49118      & '                         K$^{&star-}$',
49119      & '                       K<SUP>*-</SUP>',
49120      & '                           K$_1(H)^-$',
49121      & '         K<SUB>1</SUB>(H)<SUP>-</SUP>',
49122      & '                       K$^{&star-}_2$',
49123      & '           K<SUB>2</SUB><SUP>*-</SUP>',
49124      & '                              $&pi^+$',
49125      & '                       pi<SUP>+</SUP>',
49126      & '                             $&rho^+$',
49127      & '                      rho<SUP>+</SUP>',
49128      & '                              $a^+_1$',
49129      & '            a<SUB>1</SUB><SUP>+</SUP>'/
49130       DATA ((TXNAME(J,I),J=1,2),I=41,48)/
49131      & '                              $a^+_2$',
49132      & '            a<SUB>2</SUB><SUP>+</SUP>',
49133      & '                 $&overline{&rm K}^0$',
49134      & '                       -K<SUP>0</SUP>',
49135      & '          $&overline{&rm K}^{&star0}$',
49136      & '                      -K<SUP>*0</SUP>',
49137      & '            $&overline{&rm K}_1(H)^0$',
49138      & '        -K<SUB>1</SUB>(H)<SUP>0</SUP>',
49139      & '        $&overline{&rm K}^{&star0}_2$',
49140      & '          -K<SUB>2</SUB><SUP>*0</SUP>',
49141      & '                                K$^+$',
49142      & '                        K<SUP>+</SUP>',
49143      & '                         K$^{&star+}$',
49144      & '                       K<SUP>*+</SUP>',
49145      & '                           K$_1(H)^+$',
49146      & '         K<SUB>1</SUB>(H)<SUP>+</SUP>'/
49147       DATA ((TXNAME(J,I),J=1,2),I=49,56)/
49148      & '                       K$^{&star+}_2$',
49149      & '        K<SUB>2</SUB>(H)<SUP>*+</SUP>',
49150      & '                                K$^0$',
49151      & '                        K<SUP>0</SUP>',
49152      & '                         K$^{&star0}$',
49153      & '                       K<SUP>*-</SUP>',
49154      & '                           K$_1(H)^0$',
49155      & '         K<SUB>1</SUB>(H)<SUP>0</SUP>',
49156      & '                       K$^{&star0}_2$',
49157      & '           K<SUB>2</SUB><SUP>*0</SUP>',
49158      & '                                     ',
49159      & '                                     ',
49160      & '                                     ',
49161      & '                                     ',
49162      & '                               $&phi$',
49163      & '                                  phi'/
49164       DATA ((TXNAME(J,I),J=1,2),I=57,64)/
49165      & '                          $f_1(1420)$',
49166      & '                  f<SUB>1</SUB>(1420)',
49167      & '                         $f^&prime_2$',
49168      & '            f<SUP>''</SUP><SUB>2</SUB>',
49169      & '                             $&gamma$',
49170      & '                                gamma',
49171      & '                        K$^0_{&rm S}$',
49172      & '            K<SUB>S</SUB><SUP>0</SUP>',
49173      & '                        K$^0_{&rm L}$',
49174      & '            K<SUB>L</SUB><SUP>0</SUP>',
49175      & '                        $a_0(1450)^0$',
49176      & '      a<SUB>0</SUB>(1450)<SUP>0</SUP>',
49177      & '                        $a_0(1450)^+$',
49178      & '      a<SUB>0</SUB>(1450)<SUP>+</SUP>',
49179      & '                        $a_0(1450)^-$',
49180      & '      a<SUB>0</SUB>(1450)<SUP>-</SUP>'/
49181       DATA ((TXNAME(J,I),J=1,2),I=65,72)/
49182      & '                                     ',
49183      & '                                     ',
49184      & '                                     ',
49185      & '                                     ',
49186      & '                                     ',
49187      & '                                     ',
49188      & '                                     ',
49189      & '                                     ',
49190      & '                                     ',
49191      & '                                     ',
49192      & '                                     ',
49193      & '                                     ',
49194      & '                     $&gamma$-remnant',
49195      & '                        gamma-remnant',
49196      & '                          $N$-remnant',
49197      & '                            N-remnant'/
49198       DATA ((TXNAME(J,I),J=1,2),I=73,80)/
49199      & '                                    p',
49200      & '                                    p',
49201      & '                           $&Delta^+$',
49202      & '                    Delta<SUP>+</SUP>',
49203      & '                                    n',
49204      & '                                    n',
49205      & '                           $&Delta^0$',
49206      & '                    Delta<SUP>0</SUP>',
49207      & '                           $&Delta^-$',
49208      & '                    Delta<SUP>-</SUP>',
49209      & '                            $&Lambda$',
49210      & '                               Lambda',
49211      & '                           $&Sigma^0$',
49212      & '                    Sigma<SUP>0</SUP>',
49213      & '                    $&Sigma^{&star0}$',
49214      & '                   Sigma<SUP>*0</SUP>'/
49215       DATA ((TXNAME(J,I),J=1,2),I=81,88)/
49216      & '                           $&Sigma^-$',
49217      & '                    Sigma<SUP>-</SUP>',
49218      & '                    $&Sigma^{&star-}$',
49219      & '                   Sigma<SUP>*-</SUP>',
49220      & '                              $&Xi^-$',
49221      & '                       Xi<SUP>-</SUP>',
49222      & '                       $&Xi^{&star-}$',
49223      & '                      Xi<SUP>*-</SUP>',
49224      & '                        $&Delta^{++}$',
49225      & '                   Delta<SUP>++</SUP>',
49226      & '                           $&Sigma^+$',
49227      & '                    Sigma<SUP>+</SUP>',
49228      & '                    $&Sigma^{&star+}$',
49229      & '                   Sigma<SUP>*+</SUP>',
49230      & '                              $&Xi^0$',
49231      & '                       Xi<SUP>0</SUP>'/
49232       DATA ((TXNAME(J,I),J=1,2),I=89,96)/
49233      & '                       $&Xi^{&star0}$',
49234      & '                      Xi<SUP>*0</SUP>',
49235      & '                           $&Omega^-$',
49236      & '                    Omega<SUP>-</SUP>',
49237      & '                        $&bar{&rm p}$',
49238      & '                                   -p',
49239      & '                $&overline{&Delta}^-$',
49240      & '                   -Delta<SUP>-</SUP>',
49241      & '                        $&bar{&rm n}$',
49242      & '                                   -n',
49243      & '                $&overline{&Delta}^0$',
49244      & '                   -Delta<SUP>0</SUP>',
49245      & '                $&overline{&Delta}^+$',
49246      & '                   -Delta<SUP>+</SUP>',
49247      & '                 $&overline{&Lambda}$',
49248      & '                              -Lambda'/
49249       DATA ((TXNAME(J,I),J=1,2),I=97,104)/
49250      & '                $&overline{&Sigma}^0$',
49251      & '                   -Sigma<SUP>0</SUP>',
49252      & '         $&overline{&Sigma}^{&star0}$',
49253      & '                  -Sigma<SUP>*0</SUP>',
49254      & '                $&overline{&Sigma}^+$',
49255      & '                   -Sigma<SUP>+</SUP>',
49256      & '         $&overline{&Sigma}^{&star+}$',
49257      & '                  -Sigma<SUP>*+</SUP>',
49258      & '                   $&overline{&Xi}^+$',
49259      & '                      -Xi<SUP>+</SUP>',
49260      & '            $&overline{&Xi}^{&star+}$',
49261      & '                     -Xi<SUP>*+</SUP>',
49262      & '             $&overline{&Delta}^{--}$',
49263      & '                  -Delta<SUP>--</SUP>',
49264      & '                $&overline{&Sigma}^-$',
49265      & '                   -Sigma<SUP>-</SUP>'/
49266       DATA ((TXNAME(J,I),J=1,2),I=105,112)/
49267      & '         $&overline{&Sigma}^{&star-}$',
49268      & '                  -Sigma<SUP>*-</SUP>',
49269      & '                   $&overline{&Xi}^0$',
49270      & '                      -Xi<SUP>0</SUP>',
49271      & '              $&overline&Xi^{&star0}$',
49272      & '                     -Xi<SUP>*0</SUP>',
49273      & '                $&overline{&Omega}^+$',
49274      & '                   -Omega<SUP>+</SUP>',
49275      & '                                   uu',
49276      & '                                   uu',
49277      & '                                   ud',
49278      & '                                   ud',
49279      & '                                   dd',
49280      & '                                   dd',
49281      & '                                   us',
49282      & '                                   us'/
49283       DATA ((TXNAME(J,I),J=1,2),I=113,120)/
49284      & '                                   ds',
49285      & '                                   ds',
49286      & '                                   ss',
49287      & '                                   ss',
49288      & '             $&bar{&rm u}&bar{&rm u}$',
49289      & '                                  -uu',
49290      & '             $&bar{&rm u}&bar{&rm d}$',
49291      & '                                  -ud',
49292      & '             $&bar{&rm d}&bar{&rm d}$',
49293      & '                                  -dd',
49294      & '             $&bar{&rm u}&bar{&rm s}$',
49295      & '                                  -us',
49296      & '             $&bar{&rm d}&bar{&rm s}$',
49297      & '                                  -ds',
49298      & '             $&bar{&rm s}&bar{&rm s}$',
49299      & '                                  -ss'/
49300       DATA ((TXNAME(J,I),J=1,2),I=121,128)/
49301      & '                                e$^-$',
49302      & '                        e<SUP>-</SUP>',
49303      & '                        $&nu_{&rm e}$',
49304      & '                       nu<SUB>e</SUB>',
49305      & '                              $&mu^-$',
49306      & '                       mu<SUP>-</SUP>',
49307      & '                            $&nu_&mu$',
49308      & '                      nu<SUB>mu</SUB>',
49309      & '                             $&tau^-$',
49310      & '                      tau<SUP>-</SUP>',
49311      & '                           $&nu_&tau$',
49312      & '                     nu<SUB>tau</SUB>',
49313      & '                                e$^+$',
49314      & '                        e<SUP>+</SUP>',
49315      & '                  $&bar{&nu}_{&rm e}$',
49316      & '                      -nu<SUB>e</SUB>'/
49317       DATA ((TXNAME(J,I),J=1,2),I=129,136)/
49318      & '                              $&mu^+$',
49319      & '                       mu<SUP>+</SUP>',
49320      & '                      $&bar{&nu}_&mu$',
49321      & '                     -nu<SUB>mu</SUB>',
49322      & '                             $&tau^+$',
49323      & '                      tau<SUP>+</SUP>',
49324      & '                     $&bar{&nu}_&tau$',
49325      & '                    -nu<SUB>tau</SUB>',
49326      & '                                     ',
49327      & '                                     ',
49328      & '                                     ',
49329      & '                                     ',
49330      & '                                     ',
49331      & '                                     ',
49332      & '                                D$^+$',
49333      & '                        D<SUP>+</SUP>'/
49334       DATA ((TXNAME(J,I),J=1,2),I=137,144)/
49335      & '                         D$^{&star+}$',
49336      & '                       D<SUP>*+</SUP>',
49337      & '                           D$_1(H)^+$',
49338      & '         D<SUB>1</SUB>(H)<SUP>+</SUP>',
49339      & '                       D$_2^{&star+}$',
49340      & '           D<SUB>2</SUB><SUP>*+</SUP>',
49341      & '                                D$^0$',
49342      & '                        D<SUP>0</SUP>',
49343      & '                         D$^{&star0}$',
49344      & '                       D<SUP>*0</SUP>',
49345      & '                           D$_1(H)^0$',
49346      & '         D<SUB>1</SUB>(H)<SUP>0</SUP>',
49347      & '                       D$_2^{&star0}$',
49348      & '           D<SUB>2</SUB><SUP>*0</SUP>',
49349      & '                        D$_{&rm s}^+$',
49350      & '            D<SUB>s</SUB><SUP>+</SUP>'/
49351       DATA ((TXNAME(J,I),J=1,2),I=145,152)/
49352      & '                 D$_{&rm s}^{&star+}$',
49353      & '           D<SUB>s</SUB><SUP>*+</SUP>',
49354      & '                    D$_{&rm s1}(H)^+$',
49355      & '        D<SUB>s1</SUB>(H)<SUP>+</SUP>',
49356      & '                D$^{&star+}_{&rm s2}$',
49357      & '       D<SUB>s1</SUB>(H)<SUP>*+</SUP>',
49358      & '                $&Sigma_{&rm c}^{++}$',
49359      & '       Sigma<SUB>c</SUB><SUP>++</SUP>',
49360      & '           $&Sigma_{&rm c}^{&star++}$',
49361      & '      Sigma<SUB>c</SUB><SUP>*++</SUP>',
49362      & '                  $&Lambda_{&rm c}^+$',
49363      & '       Lambda<SUB>c</SUB><SUP>+</SUP>',
49364      & '                   $&Sigma_{&rm c}^+$',
49365      & '        Sigma<SUB>c</SUB><SUP>+</SUP>',
49366      & '            $&Sigma_{&rm c}^{&star+}$',
49367      & '       Sigma<SUB>c</SUB><SUP>*+</SUP>'/
49368       DATA ((TXNAME(J,I),J=1,2),I=153,160)/
49369      & '                   $&Sigma_{&rm c}^0$',
49370      & '        Sigma<SUB>c</SUB><SUP>0</SUP>',
49371      & '            $&Sigma_{&rm c}^{&star0}$',
49372      & '       Sigma<SUB>c</SUB><SUP>*0</SUP>',
49373      & '                      $&Xi_{&rm c}^+$',
49374      & '           Xi<SUB>c</SUB><SUP>+</SUP>',
49375      & '              $&Xi_{&rm c}^{&prime+}$',
49376      & '          Xi<SUB>c</SUB><SUP>''+</SUP>',
49377      & '               $&Xi_{&rm c}^{&star+}$',
49378      & '          Xi<SUB>c</SUB><SUP>*+</SUP>',
49379      & '                      $&Xi_{&rm c}^0$',
49380      & '           Xi<SUB>c</SUB><SUP>0</SUP>',
49381      & '              $&Xi_{&rm c}^{&prime0}$',
49382      & '          Xi<SUB>c</SUB><SUP>''0</SUP>',
49383      & '               $&Xi_{&rm c}^{&star0}$',
49384      & '          Xi<SUB>c</SUB><SUP>*0</SUP>'/
49385       DATA ((TXNAME(J,I),J=1,2),I=161,168)/
49386      & '                   $&Omega_{&rm c}^0$',
49387      & '        Omega<SUB>c</SUB><SUP>0</SUP>',
49388      & '            $&Omega_{&rm c}^{&star0}$',
49389      & '       Omega<SUB>c</SUB><SUP>*0</SUP>',
49390      & '                   $&eta_{&rm c}(1S)$',
49391      & '                  eta<SUB>c</SUB>(1S)',
49392      & '                             J/$&psi$',
49393      & '                                J/psi',
49394      & '                  $&chi_{&rm c0}(1P)$',
49395      & '                 chi<SUB>c0</SUB>(1P)',
49396      & '                           $&psi(2S)$',
49397      & '                              psi(2S)',
49398      & '                           $&psi(1D)$',
49399      & '                              psi(1D)',
49400      & '                                     ',
49401      & '                                     '/
49402       DATA ((TXNAME(J,I),J=1,2),I=169,176)/
49403      & '                                     ',
49404      & '                                     ',
49405      & '                                     ',
49406      & '                                     ',
49407      & '                                D$^-$',
49408      & '                        D<SUP>-</SUP>',
49409      & '                         D$^{&star-}$',
49410      & '                       D<SUP>*-</SUP>',
49411      & '                           D$_1(H)^-$',
49412      & '         D<SUB>1</SUB>(H)<SUP>-</SUP>',
49413      & '                       D$_2^{&star-}$',
49414      & '           D<SUB>2</SUB><SUP>*-</SUP>',
49415      & '                 $&overline{&rm D}^0$',
49416      & '                       -D<SUP>0</SUP>',
49417      & '          $&overline{&rm D}^{&star0}$',
49418      & '                      -D<SUP>*0</SUP>'/
49419       DATA ((TXNAME(J,I),J=1,2),I=177,184)/
49420      & '            $&overline{&rm D}_1(H)^0$',
49421      & '        -D<SUB>1</SUB>(H)<SUP>0</SUP>',
49422      & '        $&overline{&rm D}_2^{&star0}$',
49423      & '          -D<SUB>2</SUB><SUP>*0</SUP>',
49424      & '                        D$_{&rm s}^-$',
49425      & '            D<SUB>s</SUB><SUP>-</SUP>',
49426      & '                 D$_{&rm s}^{&star-}$',
49427      & '           D<SUB>s</SUB><SUP>*-</SUP>',
49428      & '                    D$_{&rm s1}(H)^-$',
49429      & '        D<SUB>s1</SUB>(H)<SUP>-</SUP>',
49430      & '                D$_{&rm s2}^{&star-}$',
49431      & '       D<SUB>s1</SUB>(H)<SUP>*-</SUP>',
49432      & '     $&overline{&Sigma}_{&rm c}^{--}$',
49433      & '      -Sigma<SUB>c</SUB><SUP>--</SUP>',
49434      & '$&overline{&Sigma}_{&rm c}^{&star--}$',
49435      & '     -Sigma<SUB>c</SUB><SUP>*--</SUP>'/
49436       DATA ((TXNAME(J,I),J=1,2),I=185,192)/
49437      & '       $&overline{&Lambda}_{&rm c}^-$',
49438      & '      -Lambda<SUB>c</SUB><SUP>-</SUP>',
49439      & '        $&overline{&Sigma}_{&rm c}^-$',
49440      & '       -Sigma<SUB>c</SUB><SUP>-</SUP>',
49441      & ' $&overline{&Sigma}_{&rm c}^{&star-}$',
49442      & '      -Sigma<SUB>c</SUB><SUP>*-</SUP>',
49443      & '        $&overline{&Sigma}_{&rm c}^0$',
49444      & '       -Sigma<SUB>c</SUB><SUP>0</SUP>',
49445      & ' $&overline{&Sigma}_{&rm c}^{&star0}$',
49446      & '      -Sigma<SUB>c</SUB><SUP>*0</SUP>',
49447      & '           $&overline{&Xi}_{&rm c}^-$',
49448      & '          -Xi<SUB>c</SUB><SUP>-</SUP>',
49449      & '   $&overline{&Xi}_{&rm c}^{&prime-}$',
49450      & '         -Xi<SUB>c</SUB><SUP>''-</SUP>',
49451      & '    $&overline{&Xi}_{&rm c}^{&star-}$',
49452      & '         -Xi<SUB>c</SUB><SUP>*-</SUP>'/
49453       DATA ((TXNAME(J,I),J=1,2),I=193,200)/
49454      & '           $&overline{&Xi}_{&rm c}^0$',
49455      & '          -Xi<SUB>c</SUB><SUP>0</SUP>',
49456      & '   $&overline{&Xi}_{&rm c}^{&prime0}$',
49457      & '         -Xi<SUB>c</SUB><SUP>''0</SUP>',
49458      & '    $&overline{&Xi}_{&rm c}^{&star0}$',
49459      & '         -Xi<SUB>c</SUB><SUP>*0</SUP>',
49460      & '        $&overline{&Omega}_{&rm c}^0$',
49461      & '       -Omega<SUB>c</SUB><SUP>0</SUP>',
49462      & ' $&overline{&Omega}_{&rm c}^{&star0}$',
49463      & '      -Omega<SUB>c</SUB><SUP>*0</SUP>',
49464      & '                                W$^+$',
49465      & '                        W<SUP>+</SUP>',
49466      & '                                W$^-$',
49467      & '                        W<SUP>-</SUP>',
49468      & '                   Z$^0/&gamma^&star$',
49469      & '      Z<SUP>0</SUP>/gamma<SUP>*</SUP>'/
49470       DATA ((TXNAME(J,I),J=1,2),I=201,208)/
49471      & '                       $H^0_{&rm SM}$',
49472      & '           H<SUP>0</SUP><SUB>SM</SUB>',
49473      & '                        Z$^{&prime0}$',
49474      & '                       Z<SUP>''0</SUP>',
49475      & '                                $h^0$',
49476      & '                        h<SUP>0</SUP>',
49477      & '                                $H^0$',
49478      & '                        H<SUP>0</SUP>',
49479      & '                                $A^0$',
49480      & '                        A<SUP>0</SUP>',
49481      & '                                $H^+$',
49482      & '                        H<SUP>+</SUP>',
49483      & '                                $H^-$',
49484      & '                        H<SUP>-</SUP>',
49485      & '                                  $G$',
49486      & '                                    G'/
49487       DATA ((TXNAME(J,I),J=1,2),I=209,216)/
49488      & '                              V-quark',
49489      & '                              V-quark',
49490      & '                              A-quark',
49491      & '                              A-quark',
49492      & '                              H-quark',
49493      & '                              H-quark',
49494      & '                     H$^&prime$-quark',
49495      & '                  H<SUP>''</SUP>-quark',
49496      & '                                     ',
49497      & '                                     ',
49498      & '                                     ',
49499      & '                                     ',
49500      & '             $&overline{&rm V}$-quark',
49501      & '                             -V-quark',
49502      & '             $&overline{&rm A}$-quark',
49503      & '                             -A-quark'/
49504       DATA ((TXNAME(J,I),J=1,2),I=217,224)/
49505      & '             $&overline{&rm H}$-quark',
49506      & '                             -H-quark',
49507      & '      $&overline{&rm H}^&prime$-quark',
49508      & '                 -H<SUP>''</SUP>-quark',
49509      & '                                     ',
49510      & '                                     ',
49511      & '                                     ',
49512      & '                                     ',
49513      & '         $&overline{&rm B}_{&rm d}^0$',
49514      & '           -B<SUB>d</SUB><SUP>0</SUP>',
49515      & '                                B$^-$',
49516      & '                        B<SUP>-</SUP>',
49517      & '         $&overline{&rm B}_{&rm s}^0$',
49518      & '           -B<SUB>s</SUB><SUP>0</SUP>',
49519      & '                   $&Sigma_{&rm b}^+$',
49520      & '        Sigma<SUB>b</SUB><SUP>+</SUP>'/
49521       DATA ((TXNAME(J,I),J=1,2),I=225,232)/
49522      & '                  $&Lambda_{&rm b}^0$',
49523      & '       Lambda<SUB>b</SUB><SUP>0</SUP>',
49524      & '                   $&Sigma_{&rm b}^-$',
49525      & '        Sigma<SUB>b</SUB><SUP>-</SUP>',
49526      & '                      $&Xi_{&rm b}^0$',
49527      & '           Xi<SUB>b</SUB><SUP>0</SUP>',
49528      & '                      $&Xi_{&rm b}^-$',
49529      & '           Xi<SUB>b</SUB><SUP>-</SUP>',
49530      & '                   $&Omega_{&rm b}^-$',
49531      & '        Omega<SUB>b</SUB><SUP>-</SUP>',
49532      & '                        B$_{&rm c}^-$',
49533      & '            B<SUB>c</SUB><SUP>-</SUP>',
49534      & '                       $&Upsilon(1S)$',
49535      & '                          Upsilon(1S)',
49536      & '                        T$_{&rm b}^-$',
49537      & '            T<SUB>b</SUB><SUP>-</SUP>'/
49538       DATA ((TXNAME(J,I),J=1,2),I=233,240)/
49539      & '                                T$^+$',
49540      & '                        T<SUP>+</SUP>',
49541      & '                                T$^0$',
49542      & '                        T<SUP>0</SUP>',
49543      & '                        T$_{&rm s}^+$',
49544      & '            T<SUB>s</SUB><SUP>+</SUP>',
49545      & '                $&Sigma_{&rm t}^{++}$',
49546      & '       Sigma<SUB>t</SUB><SUP>++</SUP>',
49547      & '                  $&Lambda_{&rm t}^0$',
49548      & '       Lambda<SUB>t</SUB><SUP>0</SUP>',
49549      & '                   $&Sigma_{&rm t}^0$',
49550      & '        Sigma<SUB>t</SUB><SUP>0</SUP>',
49551      & '                     $&chi_{&rm t}^+$',
49552      & '           Xi<SUB>t</SUB><SUP>+</SUP>',
49553      & '                     $&chi_{&rm t}^0$',
49554      & '           Xi<SUB>t</SUB><SUP>0</SUP>'/
49555       DATA ((TXNAME(J,I),J=1,2),I=241,248)/
49556      & '                   $&Omega_{&rm t}^0$',
49557      & '        Omega<SUB>t</SUB><SUP>0</SUP>',
49558      & '                        T$_{&rm c}^0$',
49559      & '            T<SUB>c</SUB><SUP>0</SUP>',
49560      & '                        T$_{&rm b}^+$',
49561      & '            T<SUB>b</SUB><SUP>+</SUP>',
49562      & '                             Toponium',
49563      & '                             Toponium',
49564      & '                        B$_{&rm d}^0$',
49565      & '            B<SUB>d</SUB><SUP>0</SUP>',
49566      & '                                B$^+$',
49567      & '                        B<SUP>+</SUP>',
49568      & '                        B$_{&rm s}^0$',
49569      & '            B<SUB>s</SUB><SUP>0</SUP>',
49570      & '        $&overline{&Sigma}_{&rm b}^-$',
49571      & '       -Sigma<SUB>b</SUB><SUP>-</SUP>'/
49572       DATA ((TXNAME(J,I),J=1,2),I=249,256)/
49573      & '       $&overline{&Lambda}_{&rm b}^-$',
49574      & '      -Lambda<SUB>b</SUB><SUP>-</SUP>',
49575      & '        $&overline{&Sigma}_{&rm b}^+$',
49576      & '       -Sigma<SUB>b</SUB><SUP>+</SUP>',
49577      & '           $&overline{&Xi}_{&rm b}^0$',
49578      & '          -Xi<SUB>b</SUB><SUP>0</SUP>',
49579      & '                      $&Xi_{&rm b}^+$',
49580      & '           Xi<SUB>b</SUB><SUP>+</SUP>',
49581      & '        $&overline{&Omega}_{&rm b}^+$',
49582      & '       -Omega<SUB>b</SUB><SUP>+</SUP>',
49583      & '                        B$_{&rm c}^+$',
49584      & '            B<SUB>c</SUB><SUP>+</SUP>',
49585      & '                                T$^-$',
49586      & '                        T<SUP>-</SUP>',
49587      & '                 $&overline{&rm T}^0$',
49588      & '                        T<SUP>0</SUP>'/
49589       DATA ((TXNAME(J,I),J=1,2),I=257,264)/
49590      & '                        T$_{&rm s}^-$',
49591      & '            T<SUB>s</SUB><SUP>-</SUP>',
49592      & '     $&overline{&Sigma}_{&rm t}^{--}$',
49593      & '       Sigma<SUB>t</SUB><SUP>--</SUP>',
49594      & '       $&overline{&Lambda}_{&rm t}^-$',
49595      & '      -Lambda<SUB>t</SUB><SUP>-</SUP>',
49596      & '        $&overline{&Sigma}_{&rm t}^0$',
49597      & '       -Sigma<SUB>t</SUB><SUP>0</SUP>',
49598      & '           $&overline{&Xi}_{&rm t}^-$',
49599      & '          -Xi<SUB>t</SUB><SUP>-</SUP>',
49600      & '           $&overline{&Xi}_{&rm t}^0$',
49601      & '          -Xi<SUB>t</SUB><SUP>0</SUP>',
49602      & '        $&overline{&Omega}_{&rm t}^0$',
49603      & '       -Omega<SUB>t</SUB><SUP>0</SUP>',
49604      & '         $&overline{&rm T}_{&rm c}^0$',
49605      & '            T<SUB>c</SUB><SUP>0</SUP>'/
49606       DATA ((TXNAME(J,I),J=1,2),I=265,272)/
49607      & '          $&overline{&rm B}^{&star0}$',
49608      & '                      -B<SUP>*0</SUP>',
49609      & '                         B$^{&star-}$',
49610      & '                       B<SUP>*-</SUP>',
49611      & '  $&overline{&rm B}_{&rm s}^{&star0}$',
49612      & '          -B<SUB>s</SUB><SUP>*0</SUP>',
49613      & '            $&overline{&rm B}_1(H)^0$',
49614      & '        -B<SUB>1</SUB>(H)<SUP>0</SUP>',
49615      & '                           B$_1(H)^-$',
49616      & '         B<SUB>1</SUB>(H)<SUP>-</SUP>',
49617      & '     $&overline{&rm B}_{&rm s1}(H)^0$',
49618      & '       -B<SUB>s1</SUB>(H)<SUP>0</SUP>',
49619      & '        $&overline{&rm B}_2^{&star0}$',
49620      & '          -B<SUB>2</SUB><SUP>*0</SUP>',
49621      & '                       B$_2^{&star-}$',
49622      & '           B<SUB>2</SUB><SUP>*-</SUP>'/
49623       DATA ((TXNAME(J,I),J=1,2),I=273,280)/
49624      & '                B$_{&rm s2}^{&star0}$',
49625      & '          B<SUB>s2</SUB><SUP>*0</SUP>',
49626      & '                         B$^{&star0}$',
49627      & '                       B<SUP>*0</SUP>',
49628      & '                         B$^{&star+}$',
49629      & '                       B<SUP>*+</SUP>',
49630      & '                 B$_{&rm s}^{&star0}$',
49631      & '           B<SUB>s</SUB><SUP>*0</SUP>',
49632      & '                           B$_1(H)^0$',
49633      & '         B<SUB>1</SUB>(H)<SUP>0</SUP>',
49634      & '                           B$_1(H)^+$',
49635      & '         B<SUB>1</SUB>(H)<SUP>+</SUP>',
49636      & '                    B$_{&rm s1}(H)^0$',
49637      & '        B<SUB>s1</SUB>(H)<SUP>0</SUP>',
49638      & '                       B$_2^{&star0}$',
49639      & '           B<SUB>2</SUB><SUP>*0</SUP>'/
49640       DATA ((TXNAME(J,I),J=1,2),I=281,288)/
49641      & '                       B$_2^{&star+}$',
49642      & '           B<SUB>2</SUB><SUP>*+</SUP>',
49643      & '                B$_{&rm s2}^{&star0}$',
49644      & '          B<SUB>s2</SUB><SUP>*0</SUP>',
49645      & '                                     ',
49646      & '                                     ',
49647      & '                                     ',
49648      & '                                     ',
49649      & '                              b$_1^0$',
49650      & '            b<SUB>1</SUB><SUP>0</SUP>',
49651      & '                              b$_1^+$',
49652      & '            b<SUB>1</SUB><SUP>+</SUP>',
49653      & '                              b$_1^-$',
49654      & '            b<SUB>1</SUB><SUP>-</SUP>',
49655      & '                           h$_1(L)^0$',
49656      & '         h<SUB>1</SUB>(L)<SUP>0</SUP>'/
49657       DATA ((TXNAME(J,I),J=1,2),I=289,296)/
49658      & '                           h$_1(H)^0$',
49659      & '         h<SUB>1</SUB>(H)<SUP>0</SUP>',
49660      & '                         a$_0(980)^0$',
49661      & '       a<SUB>0</SUB>(980)<SUP>0</SUP>',
49662      & '                         a$_0(980)^+$',
49663      & '       a<SUB>0</SUB>(980)<SUP>+</SUP>',
49664      & '                         a$_0(980)^-$',
49665      & '       a<SUB>0</SUB>(980)<SUP>-</SUP>',
49666      & '                           f$_0(980)$',
49667      & '                   f<SUB>0</SUB>(980)',
49668      & '                          f$_0(1370)$',
49669      & '                  f<SUB>0</SUB>(1370)',
49670      & '                 B$_{&rm c}^{&star+}$',
49671      & '           B<SUB>c</SUB><SUP>*+</SUP>',
49672      & '                 B$_{&rm c}^{&star-}$',
49673      & '           B<SUB>c</SUB><SUP>*-</SUP>'/
49674       DATA ((TXNAME(J,I),J=1,2),I=297,304)/
49675      & '                    B$_{&rm c1}(H)^+$',
49676      & '        B<SUB>c1</SUB>(H)<SUP>+</SUP>',
49677      & '                    B$_{&rm c1}(H)^-$',
49678      & '        B<SUB>c1</SUB>(H)<SUP>-</SUP>',
49679      & '                B$_{&rm c2}^{&star+}$',
49680      & '          B<SUB>c2</SUB><SUP>*+</SUP>',
49681      & '                B$_{&rm c2}^{&star-}$',
49682      & '          B<SUB>c2</SUB><SUP>*-</SUP>',
49683      & '                      h$_{&rm c}(1P)$',
49684      & '                    h<SUB>c</SUB>(1P)',
49685      & '                  $&chi_{&rm c0}(1P)$',
49686      & '                 chi<SUB>c0</SUB>(1P)',
49687      & '                  $&chi_{&rm c2}(1P)$',
49688      & '                 chi<SUB>c2</SUB>(1P)',
49689      & '                   $&eta_{&rm b}(1S)$',
49690      & '                  eta<SUB>b</SUB>(1S)'/
49691       DATA ((TXNAME(J,I),J=1,2),I=305,312)/
49692      & '                      h$_{&rm b}(1P)$',
49693      & '                    h<SUB>b</SUB>(1P)',
49694      & '                  $&chi_{&rm b0}(1P)$',
49695      & '                 chi<SUB>b0</SUB>(1P)',
49696      & '                  $&chi_{&rm b1}(1P)$',
49697      & '                 chi<SUB>b1</SUB>(1P)',
49698      & '                  $&chi_{&rm b2}(1P)$',
49699      & '                 chi<SUB>b2</SUB>(1P)',
49700      & '                           K$_1(L)^0$',
49701      & '         K<SUB>1</SUB>(L)<SUP>0</SUP>',
49702      & '                           K$_1(L)^+$',
49703      & '         K<SUB>1</SUB>(L)<SUP>+</SUP>',
49704      & '            $&overline{&rm K}_1(L)^0$',
49705      & '        -K<SUB>1</SUB>(L)<SUP>0</SUP>',
49706      & '                           K$_1(L)^-$',
49707      & '         K<SUB>1</SUB>(L)<SUP>-</SUP>'/
49708       DATA ((TXNAME(J,I),J=1,2),I=313,320)/
49709      & '                           D$_1(L)^+$',
49710      & '         D<SUB>1</SUB>(L)<SUP>+</SUP>',
49711      & '                           D$_1(L)^0$',
49712      & '         D<SUB>1</SUB>(L)<SUP>0</SUP>',
49713      & '                    D$_{&rm s1}(L)^+$',
49714      & '        D<SUB>s1</SUB>(L)<SUP>+</SUP>',
49715      & '                           D$_1(L)^-$',
49716      & '         D<SUB>1</SUB>(L)<SUP>-</SUP>',
49717      & '            $&overline{&rm D}_1(L)^0$',
49718      & '         D<SUB>1</SUB>(L)<SUP>0</SUP>',
49719      & '                    D$_{&rm s1}(L)^-$',
49720      & '        D<SUB>s1</SUB>(L)<SUP>-</SUP>',
49721      & '                           B$_1(L)^0$',
49722      & '         B<SUB>1</SUB>(L)<SUP>0</SUP>',
49723      & '                           B$_1(L)^+$',
49724      & '         B<SUB>1</SUB>(L)<SUP>+</SUP>'/
49725       DATA ((TXNAME(J,I),J=1,2),I=321,328)/
49726      & '                    B$_{&rm s1}(L)^0$',
49727      & '        B<SUB>s1</SUB>(L)<SUP>0</SUP>',
49728      & '                    B$_{&rm c1}(L)^+$',
49729      & '        B<SUB>c1</SUB>(L)<SUP>+</SUP>',
49730      & '            $&overline{&rm B}_1(L)^0$',
49731      & '        -B<SUB>1</SUB>(L)<SUP>0</SUP>',
49732      & '                           B$_1(L)^-$',
49733      & '         B<SUB>1</SUB>(L)<SUP>-</SUP>',
49734      & '     $&overline{&rm B}_{&rm s1}(L)^0$',
49735      & '       -B<SUB>s1</SUB>(L)<SUP>0</SUP>',
49736      & '                    B$_{&rm c1}(L)^-$',
49737      & '        B<SUB>c1</SUB>(L)<SUP>-</SUP>',
49738      & '                       K$_0^{&star+}$',
49739      & '           K<SUB>0</SUB><SUP>*+</SUP>',
49740      & '                       K$_0^{&star0}$',
49741      & '           K<SUB>0</SUB><SUP>*0</SUP>'/
49742       DATA ((TXNAME(J,I),J=1,2),I=329,336)/
49743      & '        $&overline{&rm K}_0^{&star0}$',
49744      & '          -K<SUB>0</SUB><SUP>*0</SUP>',
49745      & '                       K$_0^{&star-}$',
49746      & '           K<SUB>0</SUB><SUP>*-</SUP>',
49747      & '                       D$_0^{&star+}$',
49748      & '           D<SUB>0</SUB><SUP>*+</SUP>',
49749      & '                       D$_0^{&star0}$',
49750      & '           D<SUB>0</SUB><SUP>*0</SUP>',
49751      & '                D$_{&rm s0}^{&star+}$',
49752      & '          D<SUB>s0</SUB><SUP>*+</SUP>',
49753      & '                       D$_0^{&star-}$',
49754      & '           D<SUB>0</SUB><SUP>*-</SUP>',
49755      & '        $&overline{&rm D}_0^{&star0}$',
49756      & '          -D<SUB>0</SUB><SUP>*0</SUP>',
49757      & '                D$_{&rm s0}^{&star-}$',
49758      & '          D<SUB>s0</SUB><SUP>*-</SUP>'/
49759       DATA ((TXNAME(J,I),J=1,2),I=337,344)/
49760      & '                       B$_0^{&star0}$',
49761      & '           B<SUB>0</SUB><SUP>*0</SUP>',
49762      & '                       B$_0^{&star+}$',
49763      & '           B<SUB>0</SUB><SUP>*+</SUP>',
49764      & '                B$_{&rm s0}^{&star0}$',
49765      & '          B<SUB>s0</SUB><SUP>*0</SUP>',
49766      & '                B$_{&rm c0}^{&star+}$',
49767      & '          B<SUB>c0</SUB><SUP>*+</SUP>',
49768      & '        $&overline{&rm B}_0^{&star0}$',
49769      & '          -B<SUB>0</SUB><SUP>*0</SUP>',
49770      & '                       B$_0^{&star-}$',
49771      & '           B<SUB>0</SUB><SUP>*-</SUP>',
49772      & ' $&overline{&rm B}_{&rm s0}^{&star0}$',
49773      & '         -B<SUB>s0</SUB><SUP>*0</SUP>',
49774      & '                B$_{&rm c0}^{&star-}$',
49775      & '          B<SUB>c0</SUB><SUP>*-</SUP>'/
49776       DATA ((TXNAME(J,I),J=1,2),I=345,352)/
49777      & '                   $&Sigma_{&rm b}^0$',
49778      & '        Sigma<SUB>b</SUB><SUP>0</SUP>',
49779      & '            $&Sigma_{&rm b}^{&star-}$',
49780      & '       Sigma<SUB>b</SUB><SUP>*-</SUP>',
49781      & '            $&Sigma_{&rm b}^{&star0}$',
49782      & '       Sigma<SUB>b</SUB><SUP>*0</SUP>',
49783      & '            $&Sigma_{&rm b}^{&star+}$',
49784      & '       Sigma<SUB>b</SUB><SUP>*+</SUP>',
49785      & '              $&Xi_{&rm b}^{&prime0}$',
49786      & '          Xi<SUB>b</SUB><SUP>''0</SUP>',
49787      & '               $&Xi_{&rm b}^{&star0}$',
49788      & '          Xi<SUB>b</SUB><SUP>*0</SUP>',
49789      & '              $&Xi_{&rm b}^{&prime-}$',
49790      & '          Xi<SUB>b</SUB><SUP>''-</SUP>',
49791      & '               $&Xi_{&rm b}^{&star-}$',
49792      & '          Xi<SUB>b</SUB><SUP>*-</SUP>'/
49793       DATA ((TXNAME(J,I),J=1,2),I=353,360)/
49794      & '            $&Omega_{&rm b}^{&star-}$',
49795      & '      -Omega<SUB>b</SUB><SUP>*-</SUP>',
49796      & ' $&overline{&Sigma}_{&rm b}^{&star+}$',
49797      & '       Sigma<SUB>b</SUB><SUP>*+</SUP>',
49798      & '        $&overline{&Sigma}_{&rm b}^0$',
49799      & '       -Sigma<SUB>b</SUB><SUP>0</SUP>',
49800      & ' $&overline{&Sigma}_{&rm b}^{&star0}$',
49801      & '      -Sigma<SUB>b</SUB><SUP>*0</SUP>',
49802      & ' $&overline{&Sigma}_{&rm b}^{&star-}$',
49803      & '      -Sigma<SUB>b</SUB><SUP>*-</SUP>',
49804      & '   $&overline{&Xi}_{&rm b}^{&prime0}$',
49805      & '         -Xi<SUB>b</SUB><SUP>''0</SUP>',
49806      & '    $&overline{&Xi}_{&rm b}^{&star0}$',
49807      & '         -Xi<SUB>b</SUB><SUP>*0</SUP>',
49808      & '   $&overline{&Xi}_{&rm b}^{&prime+}$',
49809      & '         -Xi<SUB>b</SUB><SUP>''+</SUP>'/
49810       DATA ((TXNAME(J,I),J=1,2),I=361,368)/
49811      & '    $&overline{&Xi}_{&rm b}^{&star+}$',
49812      & '         -Xi<SUB>b</SUB><SUP>*+</SUP>',
49813      & '            $&Omega_{&rm b}^{&star+}$',
49814      & '       Omega<SUB>b</SUB><SUP>*+</SUP>',
49815      & '                          K$(DL)_2^+$',
49816      & '        K(DL)<SUB>2</SUB><SUP>+</SUP>',
49817      & '                          K$(DL)_2^0$',
49818      & '        K(DL)<SUB>2</SUB><SUP>0</SUP>',
49819      & '           $&overline{&rm K}(DL)_2^0$',
49820      & '       -K(DL)<SUB>2</SUB><SUP>0</SUP>',
49821      & '                          K$(DL)_2^-$',
49822      & '        K(DL)<SUB>2</SUB><SUP>-</SUP>',
49823      & '                      K$(D)^{&star+}$',
49824      & '                    K(D)<SUP>*+</SUP>',
49825      & '                      K$(D)^{&star0}$',
49826      & '                    K(D)<SUP>*0</SUP>'/
49827       DATA ((TXNAME(J,I),J=1,2),I=369,376)/
49828      & '      $&overline{&rm  K}(D)^{&star0}$',
49829      & '                   -K(D)<SUP>*0</SUP>',
49830      & '                      K$(D)^{&star-}$',
49831      & '                    K(D)<SUP>*-</SUP>',
49832      & '                          K$(DH)_2^+$',
49833      & '        K(DH)<SUB>2</SUB><SUP>+</SUP>',
49834      & '                          K$(DH)_2^0$',
49835      & '        K(DH)<SUB>2</SUB><SUP>0</SUP>',
49836      & '           $&overline{&rm K}(DH)_2^0$',
49837      & '       -K(DH)<SUB>2</SUB><SUP>0</SUP>',
49838      & '                          K$(DH)_2^-$',
49839      & '        K(DH)<SUB>2</SUB><SUP>-</SUP>',
49840      & '                           K$(D)_3^+$',
49841      & '         K(D)<SUB>3</SUB><SUP>+</SUP>',
49842      & '                           K$(D)_3^0$',
49843      & '         K(D)<SUB>3</SUB><SUP>0</SUP>'/
49844       DATA ((TXNAME(J,I),J=1,2),I=377,384)/
49845      & '            $&overline{&rm K}(D)_3^0$',
49846      & '        -K(D)<SUB>3</SUB><SUP>0</SUP>',
49847      & '                           K$(D)_3^-$',
49848      & '         K(D)<SUB>3</SUB><SUP>-</SUP>',
49849      & '                            $&pi_2^+$',
49850      & '           pi<SUB>2</SUB><SUP>+</SUP>',
49851      & '                            $&pi_2^0$',
49852      & '           pi<SUB>2</SUB><SUP>0</SUP>',
49853      & '                            $&pi_2^-$',
49854      & '           pi<SUB>2</SUB><SUP>-</SUP>',
49855      & '                          $&rho(D)^+$',
49856      & '                   rho(D)<SUP>+</SUP>',
49857      & '                          $&rho(D)^0$',
49858      & '                   rho(D)<SUP>0</SUP>',
49859      & '                          $&rho(D)^-$',
49860      & '                   rho(D)<SUP>-</SUP>'/
49861       DATA ((TXNAME(J,I),J=1,2),I=385,392)/
49862      & '                           $&rho_3^+$',
49863      & '          rho<SUB>3</SUB><SUP>+</SUP>',
49864      & '                           $&rho_3^0$',
49865      & '          rho<SUB>3</SUB><SUP>0</SUP>',
49866      & '                           $&rho_3^-$',
49867      & '          rho<SUB>3</SUB><SUP>-</SUP>',
49868      & '                       $&Upsilon(2S)$',
49869      & '                          Upsilon(2S)',
49870      & '                  $&chi_{&rm b0}(2P)$',
49871      & '                 Chi<SUB>b0</SUB>(2P)',
49872      & '                  $&chi_{&rm b1}(2P)$',
49873      & '                 Chi<SUB>b1</SUB>(2P)',
49874      & '                  $&chi_{&rm b2}(2P)$',
49875      & '                 Chi<SUB>b2</SUB>(2P)',
49876      & '                       $&Upsilon(3S)$',
49877      & '                          Upsilon(3S)'/
49878       DATA ((TXNAME(J,I),J=1,2),I=393,400)/
49879      & '                       $&Upsilon(4S)$',
49880      & '                          Upsilon(4S)',
49881      & '                                     ',
49882      & '                                     ',
49883      & '                           $&omega_3$',
49884      & '                    omega<SUB>3</SUB>',
49885      & '                             $&phi_3$',
49886      & '                      phi<SUB>3</SUB>',
49887      & '                          $&eta_2(L)$',
49888      & '                   eta<SUB>2</SUB>(L)',
49889      & '                          $&eta_2(H)$',
49890      & '                   eta<SUB>2</SUB>(H)',
49891      & '                          $&omega(H)$',
49892      & '                             omega(H)',
49893      & '                                     ',
49894      & '                                     '/
49895       DATA ((TXNAME(J,I),J=1,2),I=401,408)/
49896      & '              $&tilde{&rm d}_{&rm L}$',
49897      & '                       ~d<SUB>L</SUB>',
49898      & '              $&tilde{&rm u}_{&rm L}$',
49899      & '                       ~u<SUB>L</SUB>',
49900      & '              $&tilde{&rm s}_{&rm L}$',
49901      & '                       ~s<SUB>L</SUB>',
49902      & '              $&tilde{&rm c}_{&rm L}$',
49903      & '                       ~c<SUB>L</SUB>',
49904      & '                    $&tilde{&rm b}_1$',
49905      & '                       ~b<SUB>1</SUB>',
49906      & '                    $&tilde{&rm t}_1$',
49907      & '                       ~t<SUB>1</SUB>',
49908      & '   $&overline{&tilde{&rm d}}_{&rm L}$',
49909      & '                      -~d<SUB>L</SUB>',
49910      & '   $&overline{&tilde{&rm u}}_{&rm L}$',
49911      & '                      -~u<SUB>L</SUB>'/
49912       DATA ((TXNAME(J,I),J=1,2),I=409,416)/
49913      & '   $&overline{&tilde{&rm s}}_{&rm L}$',
49914      & '                      -~s<SUB>L</SUB>',
49915      & '   $&overline{&tilde{&rm c}}_{&rm L}$',
49916      & '                      -~c<SUB>L</SUB>',
49917      & '         $&overline{&tilde{&rm b}}_1$',
49918      & '                      -~b<SUB>1</SUB>',
49919      & '         $&overline{&tilde{&rm t}}_1$',
49920      & '                      -~t<SUB>1</SUB>',
49921      & '              $&tilde{&rm d}_{&rm R}$',
49922      & '                       ~d<SUB>R</SUB>',
49923      & '              $&tilde{&rm u}_{&rm R}$',
49924      & '                       ~u<SUB>R</SUB>',
49925      & '              $&tilde{&rm s}_{&rm R}$',
49926      & '                       ~s<SUB>R</SUB>',
49927      & '              $&tilde{&rm c}_{&rm R}$',
49928      & '                       ~c<SUB>R</SUB>'/
49929       DATA ((TXNAME(J,I),J=1,2),I=417,424)/
49930      & '                    $&tilde{&rm b}_2$',
49931      & '                       ~b<SUB>2</SUB>',
49932      & '                    $&tilde{&rm t}_2$',
49933      & '                       ~t<SUB>2</SUB>',
49934      & '   $&overline{&tilde{&rm d}}_{&rm R}$',
49935      & '                      -~d<SUB>R</SUB>',
49936      & '   $&overline{&tilde{&rm u}}_{&rm R}$',
49937      & '                      -~u<SUB>R</SUB>',
49938      & '   $&overline{&tilde{&rm s}}_{&rm R}$',
49939      & '                      -~s<SUB>R</SUB>',
49940      & '   $&overline{&tilde{&rm c}}_{&rm R}$',
49941      & '                      -~c<SUB>R</SUB>',
49942      & '         $&overline{&tilde{&rm b}}_2$',
49943      & '                      -~b<SUB>2</SUB>',
49944      & '         $&overline{&tilde{&rm t}}_2$',
49945      & '                      -~t<SUB>2</SUB>'/
49946       DATA ((TXNAME(J,I),J=1,2),I=425,432)/
49947      & '            $&tilde{&rm e}^-_{&rm L}$',
49948      & '           ~e<SUP>-</SUP><SUB>L</SUB>',
49949      & '                $&tilde{&nu}_{&rm e}$',
49950      & '                    ~nu<SUB>e L</SUB>',
49951      & '              $&tilde{&mu}^-_{&rm L}$',
49952      & '          ~mu<SUP>-</SUP><SUB>L</SUB>',
49953      & '                    $&tilde{&nu}_&mu$',
49954      & '                   ~nu<SUB>mu L</SUB>',
49955      & '                   $&tilde{&tau}^-_1$',
49956      & '         ~tau<SUP>-</SUP><SUB>1</SUB>',
49957      & '                   $&tilde{&nu}_&tau$',
49958      & '                  ~nu<SUB>tau L</SUB>',
49959      & '            $&tilde{&rm e}^+_{&rm L}$',
49960      & '           ~e<SUP>+</SUP><SUB>L</SUB>',
49961      & '    $&overline{&tilde{&nu}}_{&rm eL}$',
49962      & '                    -~nu<SUB>eL</SUB>'/
49963       DATA ((TXNAME(J,I),J=1,2),I=433,440)/
49964      & '              $&tilde{&mu}^+_{&rm L}$',
49965      & '          ~mu<SUP>+</SUP><SUB>L</SUB>',
49966      & '  $&overline{&tilde{&nu}}_{&rm&mu L}$',
49967      & '                  -~nu<SUB>mu L</SUB>',
49968      & '                   $&tilde{&tau}^+_1$',
49969      & '         ~tau<SUP>+</SUP><SUB>1</SUB>',
49970      & ' $&overline{&tilde{&nu}}_{&rm&tau L}$',
49971      & '                 -~nu<SUB>tau L</SUB>',
49972      & '            $&tilde{&rm e}^-_{&rm R}$',
49973      & '           ~e<SUP>-</SUP><SUB>R</SUB>',
49974      & '               $&tilde{&nu}_{&rm eR}$',
49975      & '                    ~nu<SUB>e R</SUB>',
49976      & '              $&tilde{&mu}^-_{&rm R}$',
49977      & '          ~mu<SUP>-</SUP><SUB>R</SUB>',
49978      & '           $&tilde{&nu}_{&mu{&rm R}}$',
49979      & '                   ~nu<SUB>mu R</SUB>'/
49980       DATA ((TXNAME(J,I),J=1,2),I=441,448)/
49981      & '                   $&tilde{&tau}^-_2$',
49982      & '         ~tau<SUP>-</SUP><SUB>2</SUB>',
49983      & '          $&tilde{&nu}_{&tau{&rm R}}$',
49984      & '                  ~nu<SUB>tau R</SUB>',
49985      & '            $&tilde{&rm e}^+_{&rm R}$',
49986      & '           ~e<SUP>+</SUP><SUB>R</SUB>',
49987      & '    $&overline{&tilde{&nu}}_{&rm eR}$',
49988      & '                   -~nu<SUB>e R</SUB>',
49989      & '              $&tilde{&mu}^+_{&rm R}$',
49990      & '          ~mu<SUP>+</SUP><SUB>R</SUB>',
49991      & '  $&overline{&tilde{&nu}}_{&rm&mu R}$',
49992      & '                  -~nu<SUB>mu R</SUB>',
49993      & '                   $&tilde{&tau}^+_2$',
49994      & '         ~tau<SUP>+</SUP><SUB>2</SUB>',
49995      & ' $&overline{&tilde{&nu}}_{&rm&tau R}$',
49996      & '                 -~nu<SUB>tau R</SUB>'/
49997       DATA ((TXNAME(J,I),J=1,2),I=449,456)/
49998      & '                          $&tilde{g}$',
49999      & '                                   ~g',
50000      & '                   $&tilde{&chi}^0_1$',
50001      & '         ~chi<SUP>0</SUP><SUB>1</SUB>',
50002      & '                   $&tilde{&chi}^0_2$',
50003      & '         ~chi<SUP>0</SUP><SUB>2</SUB>',
50004      & '                   $&tilde{&chi}^0_3$',
50005      & '         ~chi<SUP>0</SUP><SUB>3</SUB>',
50006      & '                   $&tilde{&chi}^0_4$',
50007      & '         ~chi<SUP>0</SUP><SUB>4</SUB>',
50008      & '                   $&tilde{&chi}^+_1$',
50009      & '         ~chi<SUP>+</SUP><SUB>1</SUB>',
50010      & '                   $&tilde{&chi}^+_2$',
50011      & '         ~chi<SUP>+</SUP><SUB>2</SUB>',
50012      & '                   $&tilde{&chi}^-_1$',
50013      & '         ~chi<SUP>-</SUP><SUB>1</SUB>'/
50014       DATA ((TXNAME(J,I),J=1,2),I=457,NLAST)/
50015      & '                   $&tilde{&chi}^-_2$',
50016      & '         ~chi<SUP>-</SUP><SUB>2</SUB>',
50017      & '                          $&tilde{G}$',
50018      & '                                   ~G'/
50019 C
50020       DATA (RNAME(I),I=NNEXT,NMXRES)/NLEFT*'        '/
50021       DATA (IDPDG(I),I=NNEXT,NMXRES)/NLEFT*0/
50022       DATA (IFLAV(I),I=NNEXT,NMXRES)/NLEFT*0/
50023       DATA (RMASS(I),I=NNEXT,NMXRES)/NLEFT*0.0000D0/
50024       DATA (RLTIM(I),I=NNEXT,NMXRES)/NLEFT*0.000D+00/
50025       DATA (RSPIN(I),I=NNEXT,NMXRES)/NLEFT*0.0D0/
50026       DATA (TXNAME(1,I),I=NNEXT,NMXRES)/
50027      & NLEFT*'                                    '/
50028       DATA (TXNAME(2,I),I=NNEXT,NMXRES)/
50029      & NLEFT*'                                    '/
50030 C
50031       DATA (RSTAB(I),I=1,NMXRES)/NMXRES*.FALSE./
50032       DATA DKPSET/.FALSE./
50033 C
50034       DATA NDKYS/2263/
50035       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=   1,  19)/
50036      &   6,0.334D0,100,  2,  7,  5,  0,  0,
50037      &   6,0.333D0,100,  4,  9,  5,  0,  0,
50038      &   6,0.111D0,100,122,127,  5,  0,  0,
50039      &   6,0.111D0,100,124,129,  5,  0,  0,
50040      &   6,0.111D0,100,126,131,  5,  0,  0,
50041      &  12,0.334D0,100,  8,  1, 11,  0,  0,
50042      &  12,0.333D0,100, 10,  3, 11,  0,  0,
50043      &  12,0.111D0,100,128,121, 11,  0,  0,
50044      &  12,0.111D0,100,130,123, 11,  0,  0,
50045      &  12,0.111D0,100,132,125, 11,  0,  0,
50046      &  21,0.988D0,  0, 59, 59,  0,  0,  0,
50047      &  21,0.012D0,  0,127,121, 59,  0,  0,
50048      &  22,0.388D0,  0, 59, 59,  0,  0,  0,
50049      &  22,0.319D0,  0, 21, 21, 21,  0,  0,
50050      &  22,0.001D0,  0, 21, 59, 59,  0,  0,
50051      &  22,0.236D0,  0, 38, 30, 21,  0,  0,
50052      &  22,0.049D0,  0, 38, 30, 59,  0,  0,
50053      &  22,0.005D0,  0,127,121, 59,  0,  0,
50054      &  22,0.002D0,  0, 38, 30,127,121,  0/
50055       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  20,  38)/
50056      &  23,0.989D0,  0, 38, 30,  0,  0,  0,
50057      &  23,0.010D0,  0, 38, 30, 59,  0,  0,
50058      &  23,0.001D0,  0, 21, 59,  0,  0,  0,
50059      &  24,0.888D0,  0, 38, 30, 21,  0,  0,
50060      &  24,0.085D0,  0, 21, 59,  0,  0,  0,
50061      &  24,0.022D0,  0, 38, 30,  0,  0,  0,
50062      &  24,0.001D0,  0, 22, 59,  0,  0,  0,
50063      &  24,0.001D0,  0, 21,127,121,  0,  0,
50064      &  24,0.003D0,  0, 38, 30, 21, 21,  0,
50065      &  25,0.437D0,  0, 38, 30, 22,  0,  0,
50066      &  25,0.302D0,  0, 23, 59,  0,  0,  0,
50067      &  25,0.208D0,  0, 21, 21, 22,  0,  0,
50068      &  25,0.030D0,  0, 24, 59,  0,  0,  0,
50069      &  25,0.021D0,  0, 59, 59,  0,  0,  0,
50070      &  25,0.002D0,  0, 21, 21, 21,  0,  0,
50071      &  26,0.566D0,  0, 38, 30,  0,  0,  0,
50072      &  26,0.283D0,  0, 21, 21,  0,  0,  0,
50073      &  26,0.069D0,  0, 38, 30, 21, 21,  0,
50074      &  26,0.023D0,  0, 46, 34,  0,  0,  0/
50075       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  39,  57)/
50076      &  26,0.023D0,  0, 50, 42,  0,  0,  0,
50077      &  26,0.028D0,  0, 38, 38, 30, 30,  0,
50078      &  26,0.005D0,  0, 22, 22,  0,  0,  0,
50079      &  26,0.003D0,  0, 21, 21, 21, 21,  0,
50080      &  27,0.499D0,  0, 39, 30,  0,  0,  0,
50081      &  27,0.499D0,  0, 31, 38,  0,  0,  0,
50082      &  27,0.002D0,  0, 21, 59, 59,  0,  0,
50083      &  28,0.148D0,  0, 21, 21, 38, 30,  0,
50084      &  28,0.148D0,  0, 23, 38, 30,  0,  0,
50085      &  28,0.147D0,  0,291, 30,  0,  0,  0,
50086      &  28,0.147D0,  0,290, 21,  0,  0,  0,
50087      &  28,0.147D0,  0,292, 38,  0,  0,  0,
50088      &  28,0.067D0,  0, 22, 38, 30,  0,  0,
50089      &  28,0.033D0,  0, 22, 21, 21,  0,  0,
50090      &  28,0.032D0,  0, 46, 42, 30,  0,  0,
50091      &  28,0.016D0,  0, 46, 34, 21,  0,  0,
50092      &  28,0.016D0,  0, 50, 42, 21,  0,  0,
50093      &  28,0.032D0,  0, 50, 34, 38,  0,  0,
50094      &  28,0.066D0,  0, 59, 23,  0,  0,  0/
50095       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  58,  76)/
50096      &  28,0.001D0,  0, 56, 59,  0,  0,  0,
50097      &  29,0.349D0,  0, 39, 30,  0,  0,  0,
50098      &  29,0.349D0,  0, 31, 38,  0,  0,  0,
50099      &  29,0.144D0,  0, 22, 21,  0,  0,  0,
50100      &  29,0.104D0,  0, 24, 38, 30,  0,  0,
50101      &  29,0.024D0,  0, 46, 34,  0,  0,  0,
50102      &  29,0.024D0,  0, 50, 42,  0,  0,  0,
50103      &  29,0.006D0,  0, 25, 21,  0,  0,  0,
50104      &  30,1.000D0,  0,123,130,  0,  0,  0,
50105      &  31,1.000D0,  0, 30, 21,  0,  0,  0,
50106      &  32,0.499D0,  0, 31, 21,  0,  0,  0,
50107      &  32,0.499D0,  0, 23, 30,  0,  0,  0,
50108      &  32,0.002D0,  0, 30, 59,  0,  0,  0,
50109      &  33,0.349D0,  0, 31, 21,  0,  0,  0,
50110      &  33,0.349D0,  0, 23, 30,  0,  0,  0,
50111      &  33,0.144D0,  0, 22, 30,  0,  0,  0,
50112      &  33,0.101D0,  0, 24, 30, 21,  0,  0,
50113      &  33,0.048D0,  0, 50, 34,  0,  0,  0,
50114      &  33,0.006D0,  0, 25, 30,  0,  0,  0/
50115       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  77,  95)/
50116      &  33,0.003D0,  0, 30, 59,  0,  0,  0,
50117      &  34,0.629D0,  0,123,130,  0,  0,  0,
50118      &  34,0.212D0,  0, 30, 21,  0,  0,  0,
50119      &  34,0.056D0,  0, 30, 38, 30,  0,  0,
50120      &  34,0.017D0,  0, 30, 21, 21,  0,  0,
50121      &  34,0.048D0,101,121,128, 21,  0,  0,
50122      &  34,0.032D0,101,123,130, 21,  0,  0,
50123      &  34,0.006D0,  0,123,130, 59,  0,  0,
50124      &  35,0.666D0,  0, 42, 30,  0,  0,  0,
50125      &  35,0.333D0,  0, 34, 21,  0,  0,  0,
50126      &  35,0.001D0,  0, 34, 59,  0,  0,  0,
50127      &  36,0.627D0,  0, 43, 30,  0,  0,  0,
50128      &  36,0.313D0,  0, 35, 21,  0,  0,  0,
50129      &  36,0.020D0,  0, 42, 31,  0,  0,  0,
50130      &  36,0.010D0,  0, 34, 23,  0,  0,  0,
50131      &  36,0.020D0,  0, 34,294,  0,  0,  0,
50132      &  36,0.010D0,  0, 34, 24,  0,  0,  0,
50133      &  37,0.331D0,  0, 42, 30,  0,  0,  0,
50134      &  37,0.166D0,  0, 34, 21,  0,  0,  0/
50135       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  96, 114)/
50136      &  37,0.168D0,  0, 43, 30,  0,  0,  0,
50137      &  37,0.084D0,  0, 35, 21,  0,  0,  0,
50138      &  37,0.087D0,  0, 35, 38, 30,  0,  0,
50139      &  37,0.044D0,  0, 35, 21, 21,  0,  0,
50140      &  37,0.059D0,  0, 42, 31,  0,  0,  0,
50141      &  37,0.029D0,  0, 34, 23,  0,  0,  0,
50142      &  37,0.029D0,  0, 34, 24,  0,  0,  0,
50143      &  37,0.002D0,  0, 34, 59,  0,  0,  0,
50144      &  37,0.001D0,  0, 34, 22,  0,  0,  0,
50145      &  38,1.000D0,  0,129,124,  0,  0,  0,
50146      &  39,1.000D0,  0, 38, 21,  0,  0,  0,
50147      &  40,0.499D0,  0, 39, 21,  0,  0,  0,
50148      &  40,0.499D0,  0, 23, 38,  0,  0,  0,
50149      &  40,0.002D0,  0, 38, 59,  0,  0,  0,
50150      &  41,0.349D0,  0, 39, 21,  0,  0,  0,
50151      &  41,0.349D0,  0, 23, 38,  0,  0,  0,
50152      &  41,0.144D0,  0, 22, 38,  0,  0,  0,
50153      &  41,0.101D0,  0, 24, 38, 21,  0,  0,
50154      &  41,0.048D0,  0, 46, 42,  0,  0,  0/
50155       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 115, 133)/
50156      &  41,0.006D0,  0, 25, 38,  0,  0,  0,
50157      &  41,0.003D0,  0, 38, 59,  0,  0,  0,
50158      &  42,0.500D0,  0, 60,  0,  0,  0,  0,
50159      &  42,0.500D0,  0, 61,  0,  0,  0,  0,
50160      &  43,0.665D0,  0, 34, 38,  0,  0,  0,
50161      &  43,0.333D0,  0, 42, 21,  0,  0,  0,
50162      &  43,0.002D0,  0, 42, 59,  0,  0,  0,
50163      &  44,0.627D0,  0, 35, 38,  0,  0,  0,
50164      &  44,0.313D0,  0, 43, 21,  0,  0,  0,
50165      &  44,0.020D0,  0, 34, 39,  0,  0,  0,
50166      &  44,0.010D0,  0, 42, 23,  0,  0,  0,
50167      &  44,0.020D0,  0, 42,294,  0,  0,  0,
50168      &  44,0.010D0,  0, 42, 24,  0,  0,  0,
50169      &  45,0.331D0,  0, 34, 38,  0,  0,  0,
50170      &  45,0.166D0,  0, 42, 21,  0,  0,  0,
50171      &  45,0.168D0,  0, 35, 38,  0,  0,  0,
50172      &  45,0.084D0,  0, 43, 21,  0,  0,  0,
50173      &  45,0.089D0,  0, 42, 38, 30,  0,  0,
50174      &  45,0.044D0,  0, 42, 21, 21,  0,  0/
50175       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 134, 152)/
50176      &  45,0.059D0,  0, 34, 39,  0,  0,  0,
50177      &  45,0.029D0,  0, 42, 23,  0,  0,  0,
50178      &  45,0.029D0,  0, 42, 24,  0,  0,  0,
50179      &  45,0.001D0,  0, 42, 22,  0,  0,  0,
50180      &  46,0.629D0,  0,129,124,  0,  0,  0,
50181      &  46,0.212D0,  0, 38, 21,  0,  0,  0,
50182      &  46,0.056D0,  0, 38, 38, 30,  0,  0,
50183      &  46,0.017D0,  0, 38, 21, 21,  0,  0,
50184      &  46,0.032D0,101,129,124, 21,  0,  0,
50185      &  46,0.048D0,101,127,122, 21,  0,  0,
50186      &  46,0.006D0,  0,129,124, 59,  0,  0,
50187      &  47,0.666D0,  0, 50, 38,  0,  0,  0,
50188      &  47,0.333D0,  0, 46, 21,  0,  0,  0,
50189      &  47,0.001D0,  0, 46, 59,  0,  0,  0,
50190      &  48,0.627D0,  0, 51, 38,  0,  0,  0,
50191      &  48,0.313D0,  0, 47, 21,  0,  0,  0,
50192      &  48,0.020D0,  0, 50, 39,  0,  0,  0,
50193      &  48,0.010D0,  0, 46, 23,  0,  0,  0,
50194      &  48,0.020D0,  0, 46,294,  0,  0,  0/
50195       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 153, 171)/
50196      &  48,0.010D0,  0, 46, 24,  0,  0,  0,
50197      &  49,0.331D0,  0, 50, 38,  0,  0,  0,
50198      &  49,0.166D0,  0, 46, 21,  0,  0,  0,
50199      &  49,0.168D0,  0, 51, 38,  0,  0,  0,
50200      &  49,0.084D0,  0, 47, 21,  0,  0,  0,
50201      &  49,0.087D0,  0, 47, 38, 30,  0,  0,
50202      &  49,0.044D0,  0, 47, 21, 21,  0,  0,
50203      &  49,0.059D0,  0, 50, 39,  0,  0,  0,
50204      &  49,0.029D0,  0, 46, 23,  0,  0,  0,
50205      &  49,0.029D0,  0, 46, 24,  0,  0,  0,
50206      &  49,0.002D0,  0, 46, 59,  0,  0,  0,
50207      &  49,0.001D0,  0, 46, 22,  0,  0,  0,
50208      &  50,0.500D0,  0, 60,  0,  0,  0,  0,
50209      &  50,0.500D0,  0, 61,  0,  0,  0,  0,
50210      &  51,0.665D0,  0, 46, 30,  0,  0,  0,
50211      &  51,0.333D0,  0, 50, 21,  0,  0,  0,
50212      &  51,0.002D0,  0, 50, 59,  0,  0,  0,
50213      &  52,0.627D0,  0, 47, 30,  0,  0,  0,
50214      &  52,0.313D0,  0, 51, 21,  0,  0,  0/
50215       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 172, 190)/
50216      &  52,0.020D0,  0, 46, 31,  0,  0,  0,
50217      &  52,0.010D0,  0, 50, 23,  0,  0,  0,
50218      &  52,0.020D0,  0, 50,294,  0,  0,  0,
50219      &  52,0.010D0,  0, 50, 24,  0,  0,  0,
50220      &  53,0.331D0,  0, 46, 30,  0,  0,  0,
50221      &  53,0.166D0,  0, 50, 21,  0,  0,  0,
50222      &  53,0.168D0,  0, 47, 30,  0,  0,  0,
50223      &  53,0.084D0,  0, 51, 21,  0,  0,  0,
50224      &  53,0.089D0,  0, 50, 38, 30,  0,  0,
50225      &  53,0.044D0,  0, 50, 21, 21,  0,  0,
50226      &  53,0.059D0,  0, 46, 31,  0,  0,  0,
50227      &  53,0.029D0,  0, 50, 23,  0,  0,  0,
50228      &  53,0.029D0,  0, 50, 24,  0,  0,  0,
50229      &  53,0.001D0,  0, 50, 22,  0,  0,  0,
50230      &  56,0.490D0,  0, 46, 34,  0,  0,  0,
50231      &  56,0.342D0,  0, 61, 60,  0,  0,  0,
50232      &  56,0.043D0,  0, 39, 30,  0,  0,  0,
50233      &  56,0.043D0,  0, 23, 21,  0,  0,  0,
50234      &  56,0.043D0,  0, 31, 38,  0,  0,  0/
50235       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 191, 209)/
50236      &  56,0.025D0,  0, 38, 30, 21,  0,  0,
50237      &  56,0.013D0,  0, 22, 59,  0,  0,  0,
50238      &  56,0.001D0,  0, 21, 59,  0,  0,  0,
50239      &  57,0.250D0,  0, 50, 43,  0,  0,  0,
50240      &  57,0.250D0,  0, 34, 47,  0,  0,  0,
50241      &  57,0.250D0,  0, 42, 51,  0,  0,  0,
50242      &  57,0.250D0,  0, 46, 35,  0,  0,  0,
50243      &  58,0.356D0,  0, 46, 34,  0,  0,  0,
50244      &  58,0.356D0,  0, 50, 42,  0,  0,  0,
50245      &  58,0.279D0,  0, 22, 22,  0,  0,  0,
50246      &  58,0.006D0,  0, 38, 30,  0,  0,  0,
50247      &  58,0.003D0,  0, 21, 21,  0,  0,  0,
50248      &  60,0.684D0,  0, 38, 30,  0,  0,  0,
50249      &  60,0.314D0,  0, 21, 21,  0,  0,  0,
50250      &  60,0.002D0,  0, 38, 30, 59,  0,  0,
50251      &  61,0.216D0,  0, 21, 21, 21,  0,  0,
50252      &  61,0.124D0,  0, 38, 30, 21,  0,  0,
50253      &  61,0.135D0,101,123,130, 38,  0,  0,
50254      &  61,0.135D0,101,124,129, 30,  0,  0/
50255       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 210, 228)/
50256      &  61,0.187D0,101,121,128, 38,  0,  0,
50257      &  61,0.187D0,101,122,127, 30,  0,  0,
50258      &  61,0.006D0,  0,121,128, 38, 59,  0,
50259      &  61,0.006D0,  0,122,127, 30, 59,  0,
50260      &  61,0.002D0,  0, 38, 30,  0,  0,  0,
50261      &  61,0.001D0,  0, 21, 21,  0,  0,  0,
50262      &  61,0.001D0,  0, 59, 59,  0,  0,  0,
50263      &  74,0.663D0,  0, 73, 21,  0,  0,  0,
50264      &  74,0.331D0,  0, 75, 38,  0,  0,  0,
50265      &  74,0.006D0,  0, 73, 59,  0,  0,  0,
50266      &  75,1.000D0,101,121,128, 73,  0,  0,
50267      &  76,0.663D0,  0, 75, 21,  0,  0,  0,
50268      &  76,0.331D0,  0, 73, 30,  0,  0,  0,
50269      &  76,0.006D0,  0, 75, 59,  0,  0,  0,
50270      &  77,1.000D0,  0, 75, 30,  0,  0,  0,
50271      &  78,0.638D0,  0, 73, 30,  0,  0,  0,
50272      &  78,0.358D0,  0, 75, 21,  0,  0,  0,
50273      &  78,0.002D0,  0, 75, 59,  0,  0,  0,
50274      &  78,0.001D0,  0, 73, 30, 59,  0,  0/
50275       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 229, 247)/
50276      &  78,0.001D0,101,121,128, 73,  0,  0,
50277      &  79,0.995D0,  0, 78, 59,  0,  0,  0,
50278      &  79,0.005D0,  0, 78,127,121,  0,  0,
50279      &  80,0.880D0,  0, 78, 21,  0,  0,  0,
50280      &  80,0.060D0,  0, 86, 30,  0,  0,  0,
50281      &  80,0.060D0,  0, 81, 38,  0,  0,  0,
50282      &  81,0.998D0,  0, 75, 30,  0,  0,  0,
50283      &  81,0.001D0,  0, 75, 30, 59,  0,  0,
50284      &  81,0.001D0,101,121,128, 75,  0,  0,
50285      &  82,0.880D0,  0, 78, 30,  0,  0,  0,
50286      &  82,0.060D0,  0, 79, 30,  0,  0,  0,
50287      &  82,0.060D0,  0, 81, 21,  0,  0,  0,
50288      &  83,0.999D0,  0, 78, 30,  0,  0,  0,
50289      &  83,0.001D0,101,121,128, 78,  0,  0,
50290      &  84,0.667D0,  0, 88, 30,  0,  0,  0,
50291      &  84,0.333D0,  0, 83, 21,  0,  0,  0,
50292      &  85,1.000D0,  0, 73, 38,  0,  0,  0,
50293      &  86,0.516D0,  0, 73, 21,  0,  0,  0,
50294      &  86,0.483D0,  0, 75, 38,  0,  0,  0/
50295       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 248, 266)/
50296      &  86,0.001D0,  0, 73, 59,  0,  0,  0,
50297      &  87,0.880D0,  0, 78, 38,  0,  0,  0,
50298      &  87,0.060D0,  0, 86, 21,  0,  0,  0,
50299      &  87,0.060D0,  0, 79, 38,  0,  0,  0,
50300      &  88,0.995D0,  0, 78, 21,  0,  0,  0,
50301      &  88,0.001D0,  0, 78, 59,  0,  0,  0,
50302      &  88,0.004D0,  0, 79, 59,  0,  0,  0,
50303      &  89,0.667D0,  0, 83, 38,  0,  0,  0,
50304      &  89,0.333D0,  0, 88, 21,  0,  0,  0,
50305      &  90,0.675D0,  0, 78, 34,  0,  0,  0,
50306      &  90,0.233D0,  0, 88, 30,  0,  0,  0,
50307      &  90,0.086D0,  0, 83, 21,  0,  0,  0,
50308      &  90,0.006D0,101,121,128, 88,  0,  0,
50309      &  92,0.663D0,  0, 91, 21,  0,  0,  0,
50310      &  92,0.331D0,  0, 93, 30,  0,  0,  0,
50311      &  92,0.006D0,  0, 91, 59,  0,  0,  0,
50312      &  93,1.000D0,101,127,122, 91,  0,  0,
50313      &  94,0.663D0,  0, 93, 21,  0,  0,  0,
50314      &  94,0.331D0,  0, 91, 38,  0,  0,  0/
50315       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 267, 285)/
50316      &  94,0.006D0,  0, 93, 59,  0,  0,  0,
50317      &  95,1.000D0,  0, 93, 38,  0,  0,  0,
50318      &  96,0.638D0,  0, 91, 38,  0,  0,  0,
50319      &  96,0.358D0,  0, 93, 21,  0,  0,  0,
50320      &  96,0.002D0,  0, 93, 59,  0,  0,  0,
50321      &  96,0.001D0,  0, 91, 38, 59,  0,  0,
50322      &  96,0.001D0,101,127,122, 91,  0,  0,
50323      &  97,0.995D0,  0, 96, 59,  0,  0,  0,
50324      &  97,0.005D0,  0, 96,127,121,  0,  0,
50325      &  98,0.880D0,  0, 96, 21,  0,  0,  0,
50326      &  98,0.060D0,  0,104, 38,  0,  0,  0,
50327      &  98,0.060D0,  0, 99, 30,  0,  0,  0,
50328      &  99,0.998D0,  0, 93, 38,  0,  0,  0,
50329      &  99,0.001D0,  0, 93, 38, 59,  0,  0,
50330      &  99,0.001D0,101,127,122, 93,  0,  0,
50331      & 100,0.880D0,  0, 96, 38,  0,  0,  0,
50332      & 100,0.060D0,  0, 97, 38,  0,  0,  0,
50333      & 100,0.060D0,  0, 99, 21,  0,  0,  0,
50334      & 101,0.999D0,  0, 96, 38,  0,  0,  0/
50335       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 286, 304)/
50336      & 101,0.001D0,101,127,122, 96,  0,  0,
50337      & 102,0.667D0,  0,106, 38,  0,  0,  0,
50338      & 102,0.333D0,  0,101, 21,  0,  0,  0,
50339      & 103,1.000D0,  0, 91, 30,  0,  0,  0,
50340      & 104,0.516D0,  0, 91, 21,  0,  0,  0,
50341      & 104,0.483D0,  0, 93, 30,  0,  0,  0,
50342      & 104,0.001D0,  0, 91, 59,  0,  0,  0,
50343      & 105,0.880D0,  0, 96, 30,  0,  0,  0,
50344      & 105,0.060D0,  0,104, 21,  0,  0,  0,
50345      & 105,0.060D0,  0, 97, 30,  0,  0,  0,
50346      & 106,0.995D0,  0, 96, 21,  0,  0,  0,
50347      & 106,0.001D0,  0, 96, 59,  0,  0,  0,
50348      & 106,0.004D0,  0, 97, 59,  0,  0,  0,
50349      & 107,0.667D0,  0,101, 30,  0,  0,  0,
50350      & 107,0.333D0,  0,106, 21,  0,  0,  0,
50351      & 108,0.675D0,  0, 96, 46,  0,  0,  0,
50352      & 108,0.233D0,  0,106, 38,  0,  0,  0,
50353      & 108,0.086D0,  0,101, 21,  0,  0,  0,
50354      & 108,0.006D0,101,127,122,106,  0,  0/
50355       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 305, 323)/
50356      & 123,0.986D0,100,121,128,124,  0,  0,
50357      & 123,0.014D0,  0,121,128,124, 59,  0,
50358      & 125,0.178D0,100,121,128,126,  0,  0,
50359      & 125,0.171D0,100,123,130,126,  0,  0,
50360      & 125,0.002D0,  0,123,130, 59,126,  0,
50361      & 125,0.111D0,  0, 30,126,  0,  0,  0,
50362      & 125,0.253D0,  0, 31,126,  0,  0,  0,
50363      & 125,0.181D0,  0, 32,126,  0,  0,  0,
50364      & 125,0.002D0,  0, 30, 22, 21,126,  0,
50365      & 125,0.018D0,  0, 30, 24,126,  0,  0,
50366      & 125,0.004D0,  0, 30, 24, 21,126,  0,
50367      & 125,0.015D0,  0, 31, 23,126,  0,  0,
50368      & 125,0.001D0,  0, 31, 24, 21,126,  0,
50369      & 125,0.024D0,  0, 32, 21,126,  0,  0,
50370      & 125,0.002D0,  0, 32, 38, 30,126,  0,
50371      & 125,0.007D0,  0, 34,126,  0,  0,  0,
50372      & 125,0.014D0,  0, 35,126,  0,  0,  0,
50373      & 125,0.003D0,  0, 35, 21,126,  0,  0,
50374      & 125,0.001D0,  0, 34, 38, 30,126,  0/
50375       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 324, 342)/
50376      & 125,0.004D0,  0, 30, 43,126,  0,  0,
50377      & 125,0.003D0,  0, 34, 50,126,  0,  0,
50378      & 125,0.003D0,  0, 34, 51,126,  0,  0,
50379      & 125,0.003D0,  0, 30, 50, 42,126,  0,
50380      & 129,0.986D0,100,127,122,130,  0,  0,
50381      & 129,0.014D0,  0,127,122,130, 59,  0,
50382      & 131,0.178D0,100,127,122,132,  0,  0,
50383      & 131,0.171D0,100,129,124,132,  0,  0,
50384      & 131,0.002D0,  0,129,124, 59,132,  0,
50385      & 131,0.111D0,  0, 38,132,  0,  0,  0,
50386      & 131,0.253D0,  0, 39,132,  0,  0,  0,
50387      & 131,0.181D0,  0, 40,132,  0,  0,  0,
50388      & 131,0.002D0,  0, 38, 22, 21,132,  0,
50389      & 131,0.018D0,  0, 38, 24,132,  0,  0,
50390      & 131,0.004D0,  0, 38, 24, 21,132,  0,
50391      & 131,0.015D0,  0, 39, 23,132,  0,  0,
50392      & 131,0.001D0,  0, 39, 24, 21,132,  0,
50393      & 131,0.024D0,  0, 40, 21,132,  0,  0,
50394      & 131,0.002D0,  0, 40, 38, 30,132,  0/
50395       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 343, 361)/
50396      & 131,0.007D0,  0, 46,132,  0,  0,  0,
50397      & 131,0.014D0,  0, 47,132,  0,  0,  0,
50398      & 131,0.003D0,  0, 47, 21,132,  0,  0,
50399      & 131,0.001D0,  0, 46, 38, 30,132,  0,
50400      & 131,0.004D0,  0, 38, 51,132,  0,  0,
50401      & 131,0.003D0,  0, 46, 42,132,  0,  0,
50402      & 131,0.003D0,  0, 46, 43,132,  0,  0,
50403      & 131,0.003D0,  0, 38, 50, 42,132,  0,
50404      & 136,0.067D0,101,122,127, 42,  0,  0,
50405      & 136,0.067D0,101,124,129, 42,  0,  0,
50406      & 136,0.048D0,101,122,127, 43,  0,  0,
50407      & 136,0.048D0,101,124,129, 43,  0,  0,
50408      & 136,0.003D0,  0, 34, 38,122,127,  0,
50409      & 136,0.003D0,  0, 34, 38,124,129,  0,
50410      & 136,0.006D0,101,122,127, 21,  0,  0,
50411      & 136,0.006D0,101,124,129, 21,  0,  0,
50412      & 136,0.002D0,101,122,127, 23,  0,  0,
50413      & 136,0.002D0,101,124,129, 23,  0,  0,
50414      & 136,0.055D0,  0, 34, 38, 38,  0,  0/
50415       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 362, 380)/
50416      & 136,0.031D0,  0, 34, 39, 38,  0,  0,
50417      & 136,0.042D0,  0, 34, 38, 38, 21, 21,
50418      & 136,0.002D0,  0, 34, 38, 38, 38, 31,
50419      & 136,0.021D0,  0, 35, 38, 38,  0,  0,
50420      & 136,0.027D0,  0, 42, 38,  0,  0,  0,
50421      & 136,0.066D0,  0, 42, 39,  0,  0,  0,
50422      & 136,0.081D0,  0, 42, 40,  0,  0,  0,
50423      & 136,0.024D0,  0, 42, 38, 21,  0,  0,
50424      & 136,0.004D0,  0, 42, 38, 23,  0,  0,
50425      & 136,0.069D0,  0, 42, 38, 38, 30, 21,
50426      & 136,0.001D0,  0, 42, 38, 38, 30, 23,
50427      & 136,0.022D0,  0, 43, 38,  0,  0,  0,
50428      & 136,0.021D0,  0, 43, 39,  0,  0,  0,
50429      & 136,0.042D0,  0, 43, 38, 21,  0,  0,
50430      & 136,0.008D0,  0, 43, 38, 23,  0,  0,
50431      & 136,0.010D0,  0, 43, 38, 38, 30,  0,
50432      & 136,0.050D0,  0,311, 38,  0,  0,  0,
50433      & 136,0.034D0,  0,329, 38,  0,  0,  0,
50434      & 136,0.010D0,  0,369, 38,  0,  0,  0/
50435       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 381, 399)/
50436      & 136,0.031D0,  0, 46, 42, 42,  0,  0,
50437      & 136,0.003D0,  0, 38, 21,  0,  0,  0,
50438      & 136,0.001D0,  0, 38, 23,  0,  0,  0,
50439      & 136,0.002D0,  0, 38, 38, 30,  0,  0,
50440      & 136,0.008D0,  0, 38, 22,  0,  0,  0,
50441      & 136,0.001D0,  0, 38, 38, 38, 30, 30,
50442      & 136,0.003D0,  0, 38, 38, 38, 30, 31,
50443      & 136,0.008D0,  0, 46, 42,  0,  0,  0,
50444      & 136,0.005D0,  0, 46, 43,  0,  0,  0,
50445      & 136,0.026D0,  0, 47, 43,  0,  0,  0,
50446      & 136,0.005D0,  0, 46, 34, 38,  0,  0,
50447      & 136,0.007D0,  0, 38, 56,  0,  0,  0,
50448      & 136,0.023D0,  0, 38, 56, 21,  0,  0,
50449      & 136,0.005D0,  0, 46, 46, 34,  0,  0,
50450      & 137,0.683D0,  0,140, 38,  0,  0,  0,
50451      & 137,0.306D0,  0,136, 21,  0,  0,  0,
50452      & 137,0.011D0,  0,136, 59,  0,  0,  0,
50453      & 138,0.667D0,  0,141, 38,  0,  0,  0,
50454      & 138,0.333D0,  0,137, 21,  0,  0,  0/
50455       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 400, 418)/
50456      & 139,0.220D0,  0,140, 38,  0,  0,  0,
50457      & 139,0.110D0,  0,136, 21,  0,  0,  0,
50458      & 139,0.380D0,  0,141, 38,  0,  0,  0,
50459      & 139,0.190D0,  0,137, 21,  0,  0,  0,
50460      & 139,0.004D0,  0,136, 22,  0,  0,  0,
50461      & 139,0.064D0,  0,141, 38, 21,  0,  0,
50462      & 139,0.032D0,  0,137, 38, 30,  0,  0,
50463      & 140,0.037D0,101,122,127, 34,  0,  0,
50464      & 140,0.037D0,101,124,129, 34,  0,  0,
50465      & 140,0.016D0,101,122,127, 35,  0,  0,
50466      & 140,0.016D0,101,124,129, 35,  0,  0,
50467      & 140,0.013D0,  0, 34, 21,122,127,  0,
50468      & 140,0.013D0,  0, 34, 21,124,129,  0,
50469      & 140,0.012D0,  0, 42, 30,122,127,  0,
50470      & 140,0.012D0,  0, 42, 30,124,129,  0,
50471      & 140,0.003D0,101,122,127, 30,  0,  0,
50472      & 140,0.003D0,101,124,129, 30,  0,  0,
50473      & 140,0.039D0,  0, 34, 38,  0,  0,  0,
50474      & 140,0.091D0,  0, 34, 39,  0,  0,  0/
50475       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 419, 437)/
50476      & 140,0.067D0,  0, 34, 40,  0,  0,  0,
50477      & 140,0.004D0,  0, 34, 38, 21,  0,  0,
50478      & 140,0.100D0,  0, 34, 38, 21, 21,  0,
50479      & 140,0.058D0,  0, 34, 38, 23,  0,  0,
50480      & 140,0.020D0,  0, 34, 38, 24,  0,  0,
50481      & 140,0.006D0,  0, 34, 38, 25,  0,  0,
50482      & 140,0.043D0,  0, 35, 38,  0,  0,  0,
50483      & 140,0.035D0,  0, 35, 39,  0,  0,  0,
50484      & 140,0.007D0,  0,312, 38,  0,  0,  0,
50485      & 140,0.007D0,  0,330, 38,  0,  0,  0,
50486      & 140,0.020D0,  0, 42, 21,  0,  0,  0,
50487      & 140,0.006D0,  0, 42, 22,  0,  0,  0,
50488      & 140,0.009D0,  0, 42, 23,  0,  0,  0,
50489      & 140,0.016D0,  0, 42, 24,  0,  0,  0,
50490      & 140,0.014D0,  0, 42, 25,  0,  0,  0,
50491      & 140,0.003D0,  0, 42,293,  0,  0,  0,
50492      & 140,0.007D0,  0, 42, 56,  0,  0,  0,
50493      & 140,0.003D0,  0, 42, 26,  0,  0,  0,
50494      & 140,0.004D0,  0, 42,294,  0,  0,  0/
50495       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 438, 456)/
50496      & 140,0.006D0,  0, 42, 21, 21,  0,  0,
50497      & 140,0.042D0,  0, 42, 38, 30, 21,  0,
50498      & 140,0.004D0,  0, 42, 38, 38, 30, 30,
50499      & 140,0.076D0,  0, 42, 38, 30, 21, 21,
50500      & 140,0.026D0,  0, 43, 21,  0,  0,  0,
50501      & 140,0.014D0,  0, 43, 22,  0,  0,  0,
50502      & 140,0.014D0,  0, 43, 23,  0,  0,  0,
50503      & 140,0.011D0,  0, 43, 24,  0,  0,  0,
50504      & 140,0.018D0,  0, 43, 38, 30,  0,  0,
50505      & 140,0.004D0,  0, 42, 46, 34,  0,  0,
50506      & 140,0.004D0,  0, 42, 46, 34, 21,  0,
50507      & 140,0.005D0,  0, 42, 42, 50,  0,  0,
50508      & 140,0.002D0,  0, 38, 30,  0,  0,  0,
50509      & 140,0.001D0,  0, 21, 21,  0,  0,  0,
50510      & 140,0.008D0,  0, 38, 30, 21,  0,  0,
50511      & 140,0.007D0,  0, 38, 38, 30, 30,  0,
50512      & 140,0.015D0,  0, 38, 38, 30, 30, 21,
50513      & 140,0.004D0,  0, 46, 34,  0,  0,  0,
50514      & 140,0.003D0,  0, 47, 34,  0,  0,  0/
50515       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 457, 475)/
50516      & 140,0.002D0,  0, 46, 35,  0,  0,  0,
50517      & 140,0.001D0,  0, 50, 42,  0,  0,  0,
50518      & 140,0.002D0,  0, 51, 43,  0,  0,  0,
50519      & 140,0.003D0,  0, 50, 34, 38,  0,  0,
50520      & 140,0.003D0,  0, 42, 46, 30,  0,  0,
50521      & 140,0.001D0,  0, 46, 34, 38, 30, 21,
50522      & 140,0.002D0,  0, 56, 23,  0,  0,  0,
50523      & 140,0.001D0,  0, 56, 38, 30,  0,  0,
50524      & 141,0.636D0,  0,140, 21,  0,  0,  0,
50525      & 141,0.364D0,  0,140, 59,  0,  0,  0,
50526      & 142,0.667D0,  0,137, 30,  0,  0,  0,
50527      & 142,0.333D0,  0,141, 21,  0,  0,  0,
50528      & 143,0.220D0,  0,136, 30,  0,  0,  0,
50529      & 143,0.110D0,  0,140, 21,  0,  0,  0,
50530      & 143,0.380D0,  0,137, 30,  0,  0,  0,
50531      & 143,0.190D0,  0,141, 21,  0,  0,  0,
50532      & 143,0.004D0,  0,140, 22,  0,  0,  0,
50533      & 143,0.064D0,  0,137, 30, 21,  0,  0,
50534      & 143,0.032D0,  0,141, 38, 30,  0,  0/
50535       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 476, 494)/
50536      & 144,0.009D0,  0,124,129,  0,  0,  0,
50537      & 144,0.019D0,101,122,127, 56,  0,  0,
50538      & 144,0.019D0,101,124,129, 56,  0,  0,
50539      & 144,0.025D0,101,122,127, 22,  0,  0,
50540      & 144,0.025D0,101,124,129, 22,  0,  0,
50541      & 144,0.009D0,101,122,127, 25,  0,  0,
50542      & 144,0.009D0,101,124,129, 25,  0,  0,
50543      & 144,0.036D0,  0, 46, 42,  0,  0,  0,
50544      & 144,0.034D0,  0, 46, 43,  0,  0,  0,
50545      & 144,0.007D0,  0, 46,329,  0,  0,  0,
50546      & 144,0.043D0,  0, 47, 42,  0,  0,  0,
50547      & 144,0.058D0,  0, 47, 43,  0,  0,  0,
50548      & 144,0.011D0,  0, 46, 34, 38,  0,  0,
50549      & 144,0.055D0,  0, 46, 34, 38, 21,  0,
50550      & 144,0.003D0,  0, 46, 34, 38, 38, 30,
50551      & 144,0.014D0,  0, 46, 42, 38, 30,  0,
50552      & 144,0.017D0,  0, 50, 34, 38, 38,  0,
50553      & 144,0.036D0,  0, 56, 38,  0,  0,  0,
50554      & 144,0.067D0,  0, 56, 39,  0,  0,  0/
50555       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 495, 513)/
50556      & 144,0.023D0,  0, 56, 38, 21,  0,  0,
50557      & 144,0.018D0,  0, 56, 38, 38, 30,  0,
50558      & 144,0.020D0,  0, 22, 38,  0,  0,  0,
50559      & 144,0.001D0,  0, 23, 38,  0,  0,  0,
50560      & 144,0.009D0,  0, 24, 38,  0,  0,  0,
50561      & 144,0.049D0,  0, 25, 38,  0,  0,  0,
50562      & 144,0.011D0,  0,293, 38,  0,  0,  0,
50563      & 144,0.015D0,  0, 22, 38, 21,  0,  0,
50564      & 144,0.016D0,  0, 25, 38, 21,  0,  0,
50565      & 144,0.103D0,  0, 22, 39,  0,  0,  0,
50566      & 144,0.120D0,  0, 25, 39,  0,  0,  0,
50567      & 144,0.010D0,  0, 38, 38, 30,  0,  0,
50568      & 144,0.046D0,  0, 38, 38, 30, 21,  0,
50569      & 144,0.003D0,  0, 38, 38, 38, 30, 30,
50570      & 144,0.042D0,  0, 38, 30, 30, 38, 39,
50571      & 144,0.001D0,  0, 46, 23,  0,  0,  0,
50572      & 144,0.005D0,  0, 46, 38, 30,  0,  0,
50573      & 144,0.001D0,  0, 46, 56,  0,  0,  0,
50574      & 144,0.004D0,  0, 50, 38,  0,  0,  0/
50575       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 514, 532)/
50576      & 144,0.007D0,  0, 51, 38,  0,  0,  0,
50577      & 145,0.900D0,  0,144, 59,  0,  0,  0,
50578      & 145,0.100D0,  0,144, 21,  0,  0,  0,
50579      & 146,0.500D0,  0,137, 50,  0,  0,  0,
50580      & 146,0.500D0,  0,141, 46,  0,  0,  0,
50581      & 147,0.440D0,  0,136, 50,  0,  0,  0,
50582      & 147,0.440D0,  0,140, 46,  0,  0,  0,
50583      & 147,0.055D0,  0,137, 50,  0,  0,  0,
50584      & 147,0.055D0,  0,141, 46,  0,  0,  0,
50585      & 147,0.010D0,  0,144, 22,  0,  0,  0,
50586      & 148,1.000D0,  0,150, 38,  0,  0,  0,
50587      & 149,1.000D0,  0,150, 38,  0,  0,  0,
50588      & 150,0.028D0,101,122,127, 78,  0,  0,
50589      & 150,0.010D0,101,122,127, 80,  0,  0,
50590      & 150,0.028D0,101,124,129, 78,  0,  0,
50591      & 150,0.010D0,101,124,129, 80,  0,  0,
50592      & 150,0.026D0,  0, 73, 42,  0,  0,  0,
50593      & 150,0.030D0,  0, 73, 42, 21,  0,  0,
50594      & 150,0.029D0,  0, 73, 42, 38, 30,  0/
50595       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 533, 551)/
50596      & 150,0.014D0,  0, 73, 42, 22,  0,  0,
50597      & 150,0.020D0,  0, 73, 43,  0,  0,  0,
50598      & 150,0.029D0,  0, 73, 34, 38,  0,  0,
50599      & 150,0.039D0,  0, 73, 34, 38, 21,  0,
50600      & 150,0.002D0,  0, 73, 34, 38, 38, 30,
50601      & 150,0.010D0,  0, 73, 34, 38, 21, 21,
50602      & 150,0.014D0,  0, 73, 35, 38,  0,  0,
50603      & 150,0.010D0,  0, 74, 42,  0,  0,  0,
50604      & 150,0.020D0,  0, 74, 43,  0,  0,  0,
50605      & 150,0.010D0,  0, 74, 43, 21,  0,  0,
50606      & 150,0.007D0,  0, 85, 34,  0,  0,  0,
50607      & 150,0.014D0,  0, 85, 35,  0,  0,  0,
50608      & 150,0.004D0,  0, 73,293,  0,  0,  0,
50609      & 150,0.003D0,  0, 73, 38, 30,  0,  0,
50610      & 150,0.003D0,  0, 73, 38, 30, 38, 30,
50611      & 150,0.001D0,  0, 73, 56,  0,  0,  0,
50612      & 150,0.002D0,  0, 73, 46, 34,  0,  0,
50613      & 150,0.010D0,  0, 78, 38,  0,  0,  0,
50614      & 150,0.020D0,  0, 78, 39,  0,  0,  0/
50615       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 552, 570)/
50616      & 150,0.030D0,  0, 78, 38, 21,  0,  0,
50617      & 150,0.010D0,  0, 78, 38, 22,  0,  0,
50618      & 150,0.020D0,  0, 78, 38, 24,  0,  0,
50619      & 150,0.035D0,  0, 78, 38, 38, 30,  0,
50620      & 150,0.020D0,  0, 78, 38, 21, 21,  0,
50621      & 150,0.010D0,  0, 78, 38, 38, 30, 21,
50622      & 150,0.010D0,  0, 78, 38, 21, 21, 21,
50623      & 150,0.007D0,  0, 78, 46, 42,  0,  0,
50624      & 150,0.011D0,  0, 79, 38,  0,  0,  0,
50625      & 150,0.022D0,  0, 79, 38, 21,  0,  0,
50626      & 150,0.013D0,  0, 79, 38, 38, 30,  0,
50627      & 150,0.010D0,  0, 79, 38, 21, 21,  0,
50628      & 150,0.007D0,  0, 79, 38, 38, 30, 21,
50629      & 150,0.005D0,  0, 79, 38, 21, 21, 21,
50630      & 150,0.005D0,  0, 80, 38,  0,  0,  0,
50631      & 150,0.015D0,  0, 80, 39,  0,  0,  0,
50632      & 150,0.011D0,  0, 86, 21,  0,  0,  0,
50633      & 150,0.007D0,  0, 86, 22,  0,  0,  0,
50634      & 150,0.010D0,  0, 86, 23,  0,  0,  0/
50635       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 571, 589)/
50636      & 150,0.031D0,  0, 86, 24,  0,  0,  0,
50637      & 150,0.010D0,  0, 86, 25,  0,  0,  0,
50638      & 150,0.004D0,  0, 86, 56,  0,  0,  0,
50639      & 150,0.026D0,  0, 86, 38, 30,  0,  0,
50640      & 150,0.005D0,  0, 86, 38, 38, 30, 30,
50641      & 150,0.005D0,  0, 86, 38, 30, 21, 21,
50642      & 150,0.005D0,  0, 87, 21,  0,  0,  0,
50643      & 150,0.006D0,  0, 87, 23,  0,  0,  0,
50644      & 150,0.004D0,  0, 86, 46, 34,  0,  0,
50645      & 150,0.002D0,  0, 86, 46, 30,  0,  0,
50646      & 150,0.001D0,  0, 86, 46, 30, 21,  0,
50647      & 150,0.016D0,  0, 81, 38, 38,  0,  0,
50648      & 150,0.003D0,  0, 88, 46,  0,  0,  0,
50649      & 150,0.002D0,  0, 89, 46,  0,  0,  0,
50650      & 150,0.003D0,  0, 83, 46, 38,  0,  0,
50651      & 150,0.040D0,  0, 75, 46, 21,  0,  0,
50652      & 150,0.040D0,  0, 75, 46, 38, 30,  0,
50653      & 150,0.020D0,  0, 75, 46, 21, 21,  0,
50654      & 150,0.010D0,  0, 75, 46, 38, 30, 21/
50655       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 590, 608)/
50656      & 150,0.010D0,  0, 75, 46, 21, 21, 21,
50657      & 150,0.020D0,  0, 75, 47, 21,  0,  0,
50658      & 150,0.040D0,  0, 75, 42, 38,  0,  0,
50659      & 150,0.020D0,  0, 75, 42, 39,  0,  0,
50660      & 150,0.010D0,  0, 75, 42, 38, 38, 30,
50661      & 150,0.010D0,  0, 75, 42, 38, 21, 21,
50662      & 150,0.006D0,  0, 75, 43, 38,  0,  0,
50663      & 151,1.000D0,  0,150, 21,  0,  0,  0,
50664      & 152,1.000D0,  0,150, 21,  0,  0,  0,
50665      & 153,1.000D0,  0,150, 30,  0,  0,  0,
50666      & 154,1.000D0,  0,150, 30,  0,  0,  0,
50667      & 155,0.045D0,101,122,127, 88,  0,  0,
50668      & 155,0.005D0,101,122,127, 89,  0,  0,
50669      & 155,0.045D0,101,124,129, 88,  0,  0,
50670      & 155,0.005D0,101,124,129, 89,  0,  0,
50671      & 155,0.021D0,  0, 86, 42,  0,  0,  0,
50672      & 155,0.032D0,  0, 87, 42,  0,  0,  0,
50673      & 155,0.032D0,  0, 79, 38, 42,  0,  0,
50674      & 155,0.045D0,  0, 86, 43,  0,  0,  0/
50675       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 609, 627)/
50676      & 155,0.065D0,  0, 87, 43,  0,  0,  0,
50677      & 155,0.065D0,  0, 79, 38, 43,  0,  0,
50678      & 155,0.055D0,  0, 88, 38,  0,  0,  0,
50679      & 155,0.160D0,  0, 88, 39,  0,  0,  0,
50680      & 155,0.105D0,  0, 89, 38,  0,  0,  0,
50681      & 155,0.320D0,  0, 89, 39,  0,  0,  0,
50682      & 156,1.000D0,  0,155, 59,  0,  0,  0,
50683      & 157,0.667D0,  0,158, 38,  0,  0,  0,
50684      & 157,0.333D0,  0,155, 21,  0,  0,  0,
50685      & 158,0.045D0,101,122,127, 83,  0,  0,
50686      & 158,0.045D0,101,124,129, 83,  0,  0,
50687      & 158,0.005D0,101,122,127, 84,  0,  0,
50688      & 158,0.005D0,101,124,129, 84,  0,  0,
50689      & 158,0.020D0,  0, 79, 42,  0,  0,  0,
50690      & 158,0.020D0,  0, 79, 21, 42,  0,  0,
50691      & 158,0.020D0,  0, 80, 42,  0,  0,  0,
50692      & 158,0.060D0,  0, 79, 43,  0,  0,  0,
50693      & 158,0.060D0,  0, 79, 21, 43,  0,  0,
50694      & 158,0.060D0,  0, 80, 43,  0,  0,  0/
50695       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 628, 646)/
50696      & 158,0.020D0,  0, 86, 34,  0,  0,  0,
50697      & 158,0.060D0,  0, 86, 35,  0,  0,  0,
50698      & 158,0.040D0,  0, 87, 34,  0,  0,  0,
50699      & 158,0.120D0,  0, 87, 35,  0,  0,  0,
50700      & 158,0.020D0,  0, 83, 38,  0,  0,  0,
50701      & 158,0.060D0,  0, 83, 39,  0,  0,  0,
50702      & 158,0.040D0,  0, 84, 38,  0,  0,  0,
50703      & 158,0.120D0,  0, 84, 39,  0,  0,  0,
50704      & 158,0.010D0,  0, 88, 21,  0,  0,  0,
50705      & 158,0.030D0,  0, 88, 23,  0,  0,  0,
50706      & 158,0.020D0,  0, 89, 21,  0,  0,  0,
50707      & 158,0.060D0,  0, 89, 23,  0,  0,  0,
50708      & 158,0.030D0,  0, 88, 56,  0,  0,  0,
50709      & 158,0.030D0,  0, 90, 46,  0,  0,  0,
50710      & 159,1.000D0,  0,158, 59,  0,  0,  0,
50711      & 160,0.670D0,  0,155, 30,  0,  0,  0,
50712      & 160,0.330D0,  0,158, 21,  0,  0,  0,
50713      & 161,0.050D0,101,122,127, 90,  0,  0,
50714      & 161,0.050D0,101,124,129, 90,  0,  0/
50715       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 647, 665)/
50716      & 161,0.075D0,  0, 88, 42,  0,  0,  0,
50717      & 161,0.225D0,  0, 88, 43,  0,  0,  0,
50718      & 161,0.150D0,  0, 89, 42,  0,  0,  0,
50719      & 161,0.450D0,  0, 89, 43,  0,  0,  0,
50720      & 162,1.000D0,  0,161, 59,  0,  0,  0,
50721      & 163,0.028D0,  0, 25, 38, 30,  0,  0,
50722      & 163,0.014D0,  0, 25, 21, 21,  0,  0,
50723      & 163,0.018D0,  0, 39, 31,  0,  0,  0,
50724      & 163,0.009D0,  0, 23, 23,  0,  0,  0,
50725      & 163,0.010D0,  0, 51, 34, 38,  0,  0,
50726      & 163,0.010D0,  0, 43, 47, 30,  0,  0,
50727      & 163,0.004D0,  0, 51, 43,  0,  0,  0,
50728      & 163,0.004D0,  0, 47, 35,  0,  0,  0,
50729      & 163,0.007D0,  0, 56, 56,  0,  0,  0,
50730      & 163,0.022D0,  0, 46, 42, 30,  0,  0,
50731      & 163,0.011D0,  0, 46, 34, 21,  0,  0,
50732      & 163,0.011D0,  0, 50, 42, 21,  0,  0,
50733      & 163,0.022D0,  0, 50, 34, 38,  0,  0,
50734      & 163,0.032D0,  0, 22, 38, 30,  0,  0/
50735       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 666, 684)/
50736      & 163,0.016D0,  0, 22, 21, 21,  0,  0,
50737      & 163,0.020D0,  0, 38, 30, 46, 34,  0,
50738      & 163,0.012D0,  0, 38, 30, 38, 30,  0,
50739      & 163,0.001D0,  0, 73, 91,  0,  0,  0,
50740      & 163,0.001D0,  0, 59, 59,  0,  0,  0,
50741      & 163,0.748D0,  0, 13, 13,  0,  0,  0,
50742      & 164,0.060D0,  0,121,127,  0,  0,  0,
50743      & 164,0.060D0,  0,123,129,  0,  0,  0,
50744      & 164,0.004D0,  0, 39, 30,  0,  0,  0,
50745      & 164,0.004D0,  0, 23, 21,  0,  0,  0,
50746      & 164,0.004D0,  0, 31, 38,  0,  0,  0,
50747      & 164,0.003D0,  0, 41, 31,  0,  0,  0,
50748      & 164,0.003D0,  0, 29, 23,  0,  0,  0,
50749      & 164,0.003D0,  0, 33, 39,  0,  0,  0,
50750      & 164,0.009D0,  0, 24, 38, 38, 30, 30,
50751      & 164,0.007D0,  0, 24, 38, 30,  0,  0,
50752      & 164,0.003D0,  0, 51, 45,  0,  0,  0,
50753      & 164,0.003D0,  0, 43, 53,  0,  0,  0,
50754      & 164,0.003D0,  0, 24, 51, 42,  0,  0/
50755       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 685, 703)/
50756      & 164,0.003D0,  0, 24, 43, 50,  0,  0,
50757      & 164,0.004D0,  0, 24, 26,  0,  0,  0,
50758      & 164,0.003D0,  0, 46, 35,  0,  0,  0,
50759      & 164,0.003D0,  0, 34, 47,  0,  0,  0,
50760      & 164,0.002D0,  0, 50, 43,  0,  0,  0,
50761      & 164,0.002D0,  0, 42, 51,  0,  0,  0,
50762      & 164,0.003D0,  0, 24, 21, 21,  0,  0,
50763      & 164,0.002D0,  0,286, 30,  0,  0,  0,
50764      & 164,0.002D0,  0,287, 38,  0,  0,  0,
50765      & 164,0.003D0,  0, 24, 46, 42, 30,  0,
50766      & 164,0.003D0,  0, 24, 34, 50, 38,  0,
50767      & 164,0.002D0,  0,285, 21,  0,  0,  0,
50768      & 164,0.001D0,  0, 56, 51, 42,  0,  0,
50769      & 164,0.001D0,  0, 56, 43, 50,  0,  0,
50770      & 164,0.001D0,  0, 24, 50, 42,  0,  0,
50771      & 164,0.001D0,  0, 24, 46, 34,  0,  0,
50772      & 164,0.002D0,  0, 56, 38, 30, 38, 30,
50773      & 164,0.002D0,  0, 85, 91, 30,  0,  0,
50774      & 164,0.002D0,  0,103, 73, 38,  0,  0/
50775       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 704, 722)/
50776      & 164,0.002D0,  0, 24, 22,  0,  0,  0,
50777      & 164,0.001D0,  0, 56, 50, 42,  0,  0,
50778      & 164,0.001D0,  0, 56, 46, 34,  0,  0,
50779      & 164,0.001D0,  0, 73, 91, 24,  0,  0,
50780      & 164,0.001D0,  0, 85,103,  0,  0,  0,
50781      & 164,0.001D0,  0, 82,100,  0,  0,  0,
50782      & 164,0.001D0,  0, 87,105,  0,  0,  0,
50783      & 164,0.001D0,  0, 73, 91, 25,  0,  0,
50784      & 164,0.001D0,  0, 56, 58,  0,  0,  0,
50785      & 164,0.001D0,  0, 56, 38, 30,  0,  0,
50786      & 164,0.001D0,  0, 56, 46, 42, 30,  0,
50787      & 164,0.001D0,  0, 56, 34, 50, 38,  0,
50788      & 164,0.001D0,  0, 56, 22,  0,  0,  0,
50789      & 164,0.001D0,  0, 84,102,  0,  0,  0,
50790      & 164,0.001D0,  0, 73, 34, 98,  0,  0,
50791      & 164,0.001D0,  0, 91, 46, 80,  0,  0,
50792      & 164,0.034D0,  0, 38, 38, 30, 30, 21,
50793      & 164,0.029D0,  0, 23, 23, 23, 21,  0,
50794      & 164,0.015D0,  0, 38, 30, 21,  0,  0/
50795       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 723, 741)/
50796      & 164,0.012D0,  0, 38, 30, 21, 34, 46,
50797      & 164,0.009D0,  0, 23, 23, 23, 24,  0,
50798      & 164,0.007D0,  0, 38, 30, 34, 46,  0,
50799      & 164,0.002D0,  0, 46, 42, 30,  0,  0,
50800      & 164,0.001D0,  0, 46, 34, 21,  0,  0,
50801      & 164,0.001D0,  0, 50, 42, 21,  0,  0,
50802      & 164,0.002D0,  0, 50, 34, 38,  0,  0,
50803      & 164,0.006D0,  0, 73, 91, 38, 30,  0,
50804      & 164,0.004D0,  0, 38, 30, 38, 30,  0,
50805      & 164,0.004D0,  0, 38, 30, 38, 30, 23,
50806      & 164,0.004D0,  0, 75, 93, 38, 30,  0,
50807      & 164,0.001D0,  0, 86,104,  0,  0,  0,
50808      & 164,0.001D0,  0, 79, 97,  0,  0,  0,
50809      & 164,0.001D0,  0, 81, 99,  0,  0,  0,
50810      & 164,0.003D0,  0, 23, 23, 34, 46,  0,
50811      & 164,0.002D0,  0, 73, 91, 38, 30, 21,
50812      & 164,0.002D0,  0, 73, 91,  0,  0,  0,
50813      & 164,0.002D0,  0, 73, 91, 22,  0,  0,
50814      & 164,0.002D0,  0, 73, 93, 30,  0,  0/
50815       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 742, 760)/
50816      & 164,0.002D0,  0, 75, 93,  0,  0,  0,
50817      & 164,0.001D0,  0, 83,102,  0,  0,  0,
50818      & 164,0.001D0,  0, 88,106,  0,  0,  0,
50819      & 164,0.001D0,  0, 78, 96,  0,  0,  0,
50820      & 164,0.001D0,  0, 73, 91, 21,  0,  0,
50821      & 164,0.001D0,  0, 78,104, 38,  0,  0,
50822      & 164,0.001D0,  0, 96, 86, 30,  0,  0,
50823      & 164,0.001D0,  0, 73, 34, 96,  0,  0,
50824      & 164,0.001D0,  0, 91, 46, 78,  0,  0,
50825      & 164,0.001D0,  0, 46, 34, 46, 34,  0,
50826      & 164,0.013D0,  0, 59,163,  0,  0,  0,
50827      & 164,0.008D0,  0, 59, 38, 30, 21, 21,
50828      & 164,0.004D0,  0, 59, 22, 38, 30,  0,
50829      & 164,0.002D0,  0, 59, 22, 21, 21,  0,
50830      & 164,0.003D0,  0, 59, 39, 31,  0,  0,
50831      & 164,0.002D0,  0, 59, 23, 23,  0,  0,
50832      & 164,0.004D0,  0, 59, 25,  0,  0,  0,
50833      & 164,0.003D0,  0, 59, 38, 30, 38, 30,
50834      & 164,0.002D0,  0, 59, 24, 24,  0,  0/
50835       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 761, 779)/
50836      & 164,0.001D0,  0, 59, 26,  0,  0,  0,
50837      & 164,0.001D0,  0, 59, 22,  0,  0,  0,
50838      & 164,0.001D0,  0, 59, 28,  0,  0,  0,
50839      & 164,0.001D0,  0, 59, 58,  0,  0,  0,
50840      & 164,0.020D0,  0,  1,  7,  0,  0,  0,
50841      & 164,0.080D0,  0,  2,  8,  0,  0,  0,
50842      & 164,0.020D0,  0,  3,  9,  0,  0,  0,
50843      & 164,0.364D0,130, 13, 13, 13,  0,  0,
50844      & 164,0.091D0,130, 13, 13, 59,  0,  0,
50845      & 165,0.037D0,  0, 38, 30, 38, 30,  0,
50846      & 165,0.030D0,  0, 38, 30, 46, 34,  0,
50847      & 165,0.016D0,  0, 23, 38, 30,  0,  0,
50848      & 165,0.015D0,  0, 23, 38, 30, 38, 30,
50849      & 165,0.004D0,  0, 46, 43, 30,  0,  0,
50850      & 165,0.002D0,  0, 46, 35, 21,  0,  0,
50851      & 165,0.002D0,  0, 51, 43, 21,  0,  0,
50852      & 165,0.004D0,  0, 51, 35, 38,  0,  0,
50853      & 165,0.008D0,  0, 38, 30,  0,  0,  0,
50854      & 165,0.007D0,  0, 46, 34,  0,  0,  0/
50855       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 780, 798)/
50856      & 165,0.005D0,  0, 38, 30, 73, 91,  0,
50857      & 165,0.003D0,  0, 21, 21,  0,  0,  0,
50858      & 165,0.003D0,  0, 22, 22,  0,  0,  0,
50859      & 165,0.007D0,  0, 59,164,  0,  0,  0,
50860      & 165,0.857D0,  0, 13, 13,  0,  0,  0,
50861      & 166,0.008D0,  0,121,127,  0,  0,  0,
50862      & 166,0.008D0,  0,123,129,  0,  0,  0,
50863      & 166,0.001D0,  0,125,131,  0,  0,  0,
50864      & 166,0.338D0,  0,164, 38, 30,  0,  0,
50865      & 166,0.169D0,  0,164, 21, 21,  0,  0,
50866      & 166,0.027D0,  0,164, 22,  0,  0,  0,
50867      & 166,0.001D0,  0,164, 21,  0,  0,  0,
50868      & 166,0.004D0,  0, 23, 23, 23, 21,  0,
50869      & 166,0.003D0,  0, 23, 23, 21,  0,  0,
50870      & 166,0.002D0,  0, 38, 30, 46, 34,  0,
50871      & 166,0.001D0,  0, 38, 30, 73, 91,  0,
50872      & 166,0.093D0,  0, 59,165,  0,  0,  0,
50873      & 166,0.087D0,  0, 59,302,  0,  0,  0,
50874      & 166,0.078D0,  0, 59,303,  0,  0,  0/
50875       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 799, 817)/
50876      & 166,0.003D0,  0, 59,163,  0,  0,  0,
50877      & 166,0.003D0,  0,  1,  7,  0,  0,  0,
50878      & 166,0.012D0,  0,  2,  8,  0,  0,  0,
50879      & 166,0.003D0,  0,  3,  9,  0,  0,  0,
50880      & 166,0.127D0,130, 13, 13, 13,  0,  0,
50881      & 166,0.032D0,130, 13, 13, 59,  0,  0,
50882      & 167,0.500D0,  0,136,171,  0,  0,  0,
50883      & 167,0.500D0,  0,140,175,  0,  0,  0,
50884      & 171,0.067D0,101,128,121, 50,  0,  0,
50885      & 171,0.067D0,101,130,123, 50,  0,  0,
50886      & 171,0.048D0,101,128,121, 51,  0,  0,
50887      & 171,0.048D0,101,130,123, 51,  0,  0,
50888      & 171,0.003D0,  0,128,121, 46, 30,  0,
50889      & 171,0.003D0,  0,130,123, 46, 30,  0,
50890      & 171,0.006D0,101,128,121, 21,  0,  0,
50891      & 171,0.006D0,101,130,123, 21,  0,  0,
50892      & 171,0.002D0,101,128,121, 23,  0,  0,
50893      & 171,0.002D0,101,130,123, 23,  0,  0,
50894      & 171,0.055D0,  0, 46, 30, 30,  0,  0/
50895       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 818, 836)/
50896      & 171,0.031D0,  0, 46, 31, 30,  0,  0,
50897      & 171,0.042D0,  0, 46, 30, 30, 21, 21,
50898      & 171,0.002D0,  0, 46, 30, 30, 30, 39,
50899      & 171,0.021D0,  0, 47, 30, 30,  0,  0,
50900      & 171,0.027D0,  0, 50, 30,  0,  0,  0,
50901      & 171,0.066D0,  0, 50, 31,  0,  0,  0,
50902      & 171,0.081D0,  0, 50, 32,  0,  0,  0,
50903      & 171,0.024D0,  0, 50, 30, 21,  0,  0,
50904      & 171,0.004D0,  0, 50, 30, 23,  0,  0,
50905      & 171,0.069D0,  0, 50, 30, 30, 38, 21,
50906      & 171,0.001D0,  0, 50, 30, 30, 38, 23,
50907      & 171,0.022D0,  0, 51, 30,  0,  0,  0,
50908      & 171,0.021D0,  0, 51, 31,  0,  0,  0,
50909      & 171,0.042D0,  0, 51, 30, 21,  0,  0,
50910      & 171,0.008D0,  0, 51, 30, 23,  0,  0,
50911      & 171,0.010D0,  0, 51, 30, 30, 38,  0,
50912      & 171,0.050D0,  0,309, 30,  0,  0,  0,
50913      & 171,0.034D0,  0,328, 30,  0,  0,  0,
50914      & 171,0.010D0,  0,368, 30,  0,  0,  0/
50915       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 837, 855)/
50916      & 171,0.031D0,  0, 34, 50, 50,  0,  0,
50917      & 171,0.003D0,  0, 30, 21,  0,  0,  0,
50918      & 171,0.001D0,  0, 30, 23,  0,  0,  0,
50919      & 171,0.002D0,  0, 30, 30, 38,  0,  0,
50920      & 171,0.008D0,  0, 30, 22,  0,  0,  0,
50921      & 171,0.001D0,  0, 30, 30, 30, 38, 38,
50922      & 171,0.003D0,  0, 30, 30, 30, 38, 39,
50923      & 171,0.008D0,  0, 34, 50,  0,  0,  0,
50924      & 171,0.005D0,  0, 34, 51,  0,  0,  0,
50925      & 171,0.026D0,  0, 35, 51,  0,  0,  0,
50926      & 171,0.005D0,  0, 34, 46, 30,  0,  0,
50927      & 171,0.007D0,  0, 30, 56,  0,  0,  0,
50928      & 171,0.023D0,  0, 30, 56, 21,  0,  0,
50929      & 171,0.005D0,  0, 34, 34, 46,  0,  0,
50930      & 172,0.683D0,  0,175, 30,  0,  0,  0,
50931      & 172,0.306D0,  0,171, 21,  0,  0,  0,
50932      & 172,0.011D0,  0,171, 59,  0,  0,  0,
50933      & 173,0.667D0,  0,176, 30,  0,  0,  0,
50934      & 173,0.333D0,  0,172, 21,  0,  0,  0/
50935       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 856, 874)/
50936      & 174,0.220D0,  0,175, 30,  0,  0,  0,
50937      & 174,0.110D0,  0,171, 21,  0,  0,  0,
50938      & 174,0.380D0,  0,176, 30,  0,  0,  0,
50939      & 174,0.190D0,  0,172, 21,  0,  0,  0,
50940      & 174,0.004D0,  0,171, 22,  0,  0,  0,
50941      & 174,0.064D0,  0,176, 30, 21,  0,  0,
50942      & 174,0.032D0,  0,172, 38, 30,  0,  0,
50943      & 175,0.037D0,101,128,121, 46,  0,  0,
50944      & 175,0.037D0,101,130,123, 46,  0,  0,
50945      & 175,0.016D0,101,128,121, 47,  0,  0,
50946      & 175,0.016D0,101,130,123, 47,  0,  0,
50947      & 175,0.013D0,  0,128,121, 46, 21,  0,
50948      & 175,0.013D0,  0,130,123, 46, 21,  0,
50949      & 175,0.012D0,  0,128,121, 50, 38,  0,
50950      & 175,0.012D0,  0,130,123, 50, 38,  0,
50951      & 175,0.003D0,101,128,121, 38,  0,  0,
50952      & 175,0.003D0,101,130,123, 38,  0,  0,
50953      & 175,0.039D0,  0, 46, 30,  0,  0,  0,
50954      & 175,0.091D0,  0, 46, 31,  0,  0,  0/
50955       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 875, 893)/
50956      & 175,0.067D0,  0, 46, 32,  0,  0,  0,
50957      & 175,0.004D0,  0, 46, 30, 21,  0,  0,
50958      & 175,0.100D0,  0, 46, 30, 21, 21,  0,
50959      & 175,0.058D0,  0, 46, 30, 23,  0,  0,
50960      & 175,0.020D0,  0, 46, 30, 24,  0,  0,
50961      & 175,0.006D0,  0, 46, 30, 25,  0,  0,
50962      & 175,0.043D0,  0, 47, 30,  0,  0,  0,
50963      & 175,0.035D0,  0, 47, 31,  0,  0,  0,
50964      & 175,0.007D0,  0,310, 30,  0,  0,  0,
50965      & 175,0.007D0,  0,327, 30,  0,  0,  0,
50966      & 175,0.020D0,  0, 50, 21,  0,  0,  0,
50967      & 175,0.006D0,  0, 50, 22,  0,  0,  0,
50968      & 175,0.009D0,  0, 50, 23,  0,  0,  0,
50969      & 175,0.016D0,  0, 50, 24,  0,  0,  0,
50970      & 175,0.014D0,  0, 50, 25,  0,  0,  0,
50971      & 175,0.003D0,  0, 50,293,  0,  0,  0,
50972      & 175,0.007D0,  0, 50, 56,  0,  0,  0,
50973      & 175,0.003D0,  0, 50, 26,  0,  0,  0,
50974      & 175,0.004D0,  0, 50,294,  0,  0,  0/
50975       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 894, 912)/
50976      & 175,0.006D0,  0, 50, 21, 21,  0,  0,
50977      & 175,0.042D0,  0, 50, 30, 38, 21,  0,
50978      & 175,0.004D0,  0, 50, 30, 30, 38, 38,
50979      & 175,0.076D0,  0, 50, 30, 38, 21, 21,
50980      & 175,0.026D0,  0, 51, 21,  0,  0,  0,
50981      & 175,0.014D0,  0, 51, 22,  0,  0,  0,
50982      & 175,0.014D0,  0, 51, 23,  0,  0,  0,
50983      & 175,0.011D0,  0, 51, 24,  0,  0,  0,
50984      & 175,0.018D0,  0, 51, 30, 38,  0,  0,
50985      & 175,0.004D0,  0, 50, 34, 46,  0,  0,
50986      & 175,0.004D0,  0, 50, 34, 46, 21,  0,
50987      & 175,0.005D0,  0, 50, 50, 42,  0,  0,
50988      & 175,0.002D0,  0, 30, 38,  0,  0,  0,
50989      & 175,0.001D0,  0, 21, 21,  0,  0,  0,
50990      & 175,0.008D0,  0, 30, 38, 21,  0,  0,
50991      & 175,0.007D0,  0, 30, 30, 38, 38,  0,
50992      & 175,0.015D0,  0, 30, 30, 38, 38, 21,
50993      & 175,0.004D0,  0, 34, 46,  0,  0,  0,
50994      & 175,0.003D0,  0, 35, 46,  0,  0,  0/
50995       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 913, 931)/
50996      & 175,0.002D0,  0, 34, 47,  0,  0,  0,
50997      & 175,0.001D0,  0, 42, 50,  0,  0,  0,
50998      & 175,0.002D0,  0, 43, 51,  0,  0,  0,
50999      & 175,0.003D0,  0, 42, 46, 30,  0,  0,
51000      & 175,0.003D0,  0, 50, 34, 38,  0,  0,
51001      & 175,0.001D0,  0, 34, 46, 30, 38, 21,
51002      & 175,0.002D0,  0, 56, 23,  0,  0,  0,
51003      & 175,0.001D0,  0, 56, 30, 38,  0,  0,
51004      & 176,0.636D0,  0,175, 21,  0,  0,  0,
51005      & 176,0.364D0,  0,175, 59,  0,  0,  0,
51006      & 177,0.667D0,  0,172, 38,  0,  0,  0,
51007      & 177,0.333D0,  0,176, 21,  0,  0,  0,
51008      & 178,0.220D0,  0,171, 38,  0,  0,  0,
51009      & 178,0.110D0,  0,175, 21,  0,  0,  0,
51010      & 178,0.380D0,  0,172, 38,  0,  0,  0,
51011      & 178,0.190D0,  0,176, 21,  0,  0,  0,
51012      & 178,0.004D0,  0,175, 22,  0,  0,  0,
51013      & 178,0.064D0,  0,172, 38, 21,  0,  0,
51014      & 178,0.032D0,  0,176, 38, 30,  0,  0/
51015       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 932, 950)/
51016      & 179,0.009D0,  0,130,123,  0,  0,  0,
51017      & 179,0.019D0,101,128,121, 56,  0,  0,
51018      & 179,0.019D0,101,130,123, 56,  0,  0,
51019      & 179,0.025D0,101,128,121, 22,  0,  0,
51020      & 179,0.025D0,101,130,123, 22,  0,  0,
51021      & 179,0.009D0,101,128,121, 25,  0,  0,
51022      & 179,0.009D0,101,130,123, 25,  0,  0,
51023      & 179,0.036D0,  0, 34, 50,  0,  0,  0,
51024      & 179,0.034D0,  0, 34, 51,  0,  0,  0,
51025      & 179,0.007D0,  0, 34,328,  0,  0,  0,
51026      & 179,0.043D0,  0, 35, 50,  0,  0,  0,
51027      & 179,0.058D0,  0, 35, 51,  0,  0,  0,
51028      & 179,0.011D0,  0, 34, 46, 30,  0,  0,
51029      & 179,0.055D0,  0, 34, 46, 30, 21,  0,
51030      & 179,0.003D0,  0, 34, 46, 30, 38, 30,
51031      & 179,0.014D0,  0, 34, 50, 38, 30,  0,
51032      & 179,0.017D0,  0, 42, 46, 30, 30,  0,
51033      & 179,0.036D0,  0, 56, 30,  0,  0,  0,
51034      & 179,0.067D0,  0, 56, 31,  0,  0,  0/
51035       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 951, 969)/
51036      & 179,0.023D0,  0, 56, 30, 21,  0,  0,
51037      & 179,0.018D0,  0, 56, 30, 38, 30,  0,
51038      & 179,0.020D0,  0, 22, 30,  0,  0,  0,
51039      & 179,0.001D0,  0, 23, 30,  0,  0,  0,
51040      & 179,0.009D0,  0, 24, 30,  0,  0,  0,
51041      & 179,0.049D0,  0, 25, 30,  0,  0,  0,
51042      & 179,0.011D0,  0,293, 30,  0,  0,  0,
51043      & 179,0.015D0,  0, 22, 30, 21,  0,  0,
51044      & 179,0.016D0,  0, 25, 30, 21,  0,  0,
51045      & 179,0.103D0,  0, 22, 31,  0,  0,  0,
51046      & 179,0.120D0,  0, 25, 31,  0,  0,  0,
51047      & 179,0.010D0,  0, 30, 38, 30,  0,  0,
51048      & 179,0.046D0,  0, 30, 38, 30, 21,  0,
51049      & 179,0.003D0,  0, 30, 38, 38, 30, 30,
51050      & 179,0.042D0,  0, 30, 38, 38, 30, 31,
51051      & 179,0.001D0,  0, 34, 23,  0,  0,  0,
51052      & 179,0.005D0,  0, 34, 38, 30,  0,  0,
51053      & 179,0.001D0,  0, 34, 56,  0,  0,  0,
51054      & 179,0.004D0,  0, 42, 30,  0,  0,  0/
51055       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 970, 988)/
51056      & 179,0.007D0,  0, 43, 30,  0,  0,  0,
51057      & 180,0.900D0,  0,179, 59,  0,  0,  0,
51058      & 180,0.100D0,  0,179, 21,  0,  0,  0,
51059      & 181,0.500D0,  0,172, 42,  0,  0,  0,
51060      & 181,0.500D0,  0,176, 34,  0,  0,  0,
51061      & 182,0.440D0,  0,171, 42,  0,  0,  0,
51062      & 182,0.440D0,  0,175, 34,  0,  0,  0,
51063      & 182,0.055D0,  0,172, 42,  0,  0,  0,
51064      & 182,0.055D0,  0,176, 34,  0,  0,  0,
51065      & 182,0.010D0,  0,179, 22,  0,  0,  0,
51066      & 183,1.000D0,  0,185, 30,  0,  0,  0,
51067      & 184,1.000D0,  0,185, 30,  0,  0,  0,
51068      & 185,0.028D0,101,128,121, 96,  0,  0,
51069      & 185,0.010D0,101,128,121, 98,  0,  0,
51070      & 185,0.028D0,101,130,123, 96,  0,  0,
51071      & 185,0.010D0,101,130,123, 98,  0,  0,
51072      & 185,0.026D0,  0, 91, 50,  0,  0,  0,
51073      & 185,0.030D0,  0, 91, 50, 21,  0,  0,
51074      & 185,0.029D0,  0, 91, 50, 38, 30,  0/
51075       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 989,1007)/
51076      & 185,0.014D0,  0, 91, 50, 22,  0,  0,
51077      & 185,0.020D0,  0, 91, 51,  0,  0,  0,
51078      & 185,0.029D0,  0, 91, 46, 30,  0,  0,
51079      & 185,0.039D0,  0, 91, 46, 30, 21,  0,
51080      & 185,0.002D0,  0, 91, 46, 30, 30, 38,
51081      & 185,0.010D0,  0, 91, 46, 30, 21, 21,
51082      & 185,0.014D0,  0, 91, 47, 30,  0,  0,
51083      & 185,0.010D0,  0, 92, 50,  0,  0,  0,
51084      & 185,0.020D0,  0, 92, 51,  0,  0,  0,
51085      & 185,0.010D0,  0, 92, 51, 21,  0,  0,
51086      & 185,0.007D0,  0,103, 46,  0,  0,  0,
51087      & 185,0.014D0,  0,103, 47,  0,  0,  0,
51088      & 185,0.004D0,  0, 91,293,  0,  0,  0,
51089      & 185,0.003D0,  0, 91, 38, 30,  0,  0,
51090      & 185,0.003D0,  0, 91, 38, 30, 38, 30,
51091      & 185,0.001D0,  0, 91, 56,  0,  0,  0,
51092      & 185,0.002D0,  0, 91, 46, 34,  0,  0,
51093      & 185,0.010D0,  0, 96, 30,  0,  0,  0,
51094      & 185,0.020D0,  0, 96, 31,  0,  0,  0/
51095       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1008,1026)/
51096      & 185,0.030D0,  0, 96, 30, 21,  0,  0,
51097      & 185,0.010D0,  0, 96, 30, 22,  0,  0,
51098      & 185,0.020D0,  0, 96, 30, 24,  0,  0,
51099      & 185,0.035D0,  0, 96, 30, 30, 38,  0,
51100      & 185,0.020D0,  0, 96, 30, 21, 21,  0,
51101      & 185,0.010D0,  0, 96, 30, 38, 30, 21,
51102      & 185,0.010D0,  0, 96, 30, 21, 21, 21,
51103      & 185,0.007D0,  0, 96, 34, 50,  0,  0,
51104      & 185,0.011D0,  0, 97, 30,  0,  0,  0,
51105      & 185,0.022D0,  0, 97, 30, 21,  0,  0,
51106      & 185,0.013D0,  0, 97, 30, 38, 30,  0,
51107      & 185,0.010D0,  0, 97, 30, 21, 21,  0,
51108      & 185,0.007D0,  0, 97, 30, 38, 30, 21,
51109      & 185,0.005D0,  0, 97, 30, 21, 21, 21,
51110      & 185,0.005D0,  0, 98, 30,  0,  0,  0,
51111      & 185,0.015D0,  0, 98, 31,  0,  0,  0,
51112      & 185,0.011D0,  0,104, 21,  0,  0,  0,
51113      & 185,0.007D0,  0,104, 22,  0,  0,  0,
51114      & 185,0.010D0,  0,104, 23,  0,  0,  0/
51115       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1027,1045)/
51116      & 185,0.031D0,  0,104, 24,  0,  0,  0,
51117      & 185,0.010D0,  0,104, 25,  0,  0,  0,
51118      & 185,0.004D0,  0,104, 56,  0,  0,  0,
51119      & 185,0.026D0,  0,104, 38, 30,  0,  0,
51120      & 185,0.005D0,  0,104, 38, 38, 30, 30,
51121      & 185,0.005D0,  0,104, 38, 30, 21, 21,
51122      & 185,0.005D0,  0,105, 21,  0,  0,  0,
51123      & 185,0.006D0,  0,105, 23,  0,  0,  0,
51124      & 185,0.004D0,  0,104, 46, 34,  0,  0,
51125      & 185,0.002D0,  0,104, 34, 38,  0,  0,
51126      & 185,0.001D0,  0,104, 34, 38, 21,  0,
51127      & 185,0.016D0,  0, 99, 30, 30,  0,  0,
51128      & 185,0.003D0,  0,106, 34,  0,  0,  0,
51129      & 185,0.002D0,  0,107, 34,  0,  0,  0,
51130      & 185,0.003D0,  0,101, 34, 30,  0,  0,
51131      & 185,0.040D0,  0, 93, 34, 21,  0,  0,
51132      & 185,0.040D0,  0, 93, 34, 38, 30,  0,
51133      & 185,0.020D0,  0, 93, 34, 21, 21,  0,
51134      & 185,0.010D0,  0, 93, 34, 38, 30, 21/
51135       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1046,1064)/
51136      & 185,0.010D0,  0, 93, 34, 21, 21, 21,
51137      & 185,0.020D0,  0, 93, 35, 21,  0,  0,
51138      & 185,0.040D0,  0, 93, 50, 30,  0,  0,
51139      & 185,0.020D0,  0, 93, 50, 31,  0,  0,
51140      & 185,0.010D0,  0, 93, 50, 30, 38, 30,
51141      & 185,0.010D0,  0, 93, 50, 30, 21, 21,
51142      & 185,0.006D0,  0, 93, 51, 30,  0,  0,
51143      & 186,1.000D0,  0,185, 21,  0,  0,  0,
51144      & 187,1.000D0,  0,185, 21,  0,  0,  0,
51145      & 188,1.000D0,  0,185, 38,  0,  0,  0,
51146      & 189,1.000D0,  0,185, 38,  0,  0,  0,
51147      & 190,0.045D0,101,128,121,106,  0,  0,
51148      & 190,0.005D0,101,128,121,107,  0,  0,
51149      & 190,0.045D0,101,130,123,106,  0,  0,
51150      & 190,0.005D0,101,130,123,107,  0,  0,
51151      & 190,0.021D0,  0,104, 50,  0,  0,  0,
51152      & 190,0.032D0,  0,105, 50,  0,  0,  0,
51153      & 190,0.032D0,  0, 97, 30, 50,  0,  0,
51154      & 190,0.045D0,  0,104, 51,  0,  0,  0/
51155       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1065,1083)/
51156      & 190,0.065D0,  0,105, 51,  0,  0,  0,
51157      & 190,0.065D0,  0, 97, 30, 51,  0,  0,
51158      & 190,0.055D0,  0,106, 30,  0,  0,  0,
51159      & 190,0.160D0,  0,106, 31,  0,  0,  0,
51160      & 190,0.105D0,  0,107, 30,  0,  0,  0,
51161      & 190,0.320D0,  0,107, 31,  0,  0,  0,
51162      & 191,1.000D0,  0,190, 59,  0,  0,  0,
51163      & 192,0.667D0,  0,193, 30,  0,  0,  0,
51164      & 192,0.333D0,  0,190, 21,  0,  0,  0,
51165      & 193,0.045D0,101,128,121,101,  0,  0,
51166      & 193,0.045D0,101,130,123,101,  0,  0,
51167      & 193,0.005D0,101,128,121,102,  0,  0,
51168      & 193,0.005D0,101,130,123,102,  0,  0,
51169      & 193,0.020D0,  0, 97, 50,  0,  0,  0,
51170      & 193,0.020D0,  0, 97, 21, 50,  0,  0,
51171      & 193,0.020D0,  0, 98, 50,  0,  0,  0,
51172      & 193,0.060D0,  0, 97, 51,  0,  0,  0,
51173      & 193,0.060D0,  0, 97, 21, 51,  0,  0,
51174      & 193,0.060D0,  0, 98, 51,  0,  0,  0/
51175       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1084,1102)/
51176      & 193,0.020D0,  0,104, 46,  0,  0,  0,
51177      & 193,0.060D0,  0,104, 47,  0,  0,  0,
51178      & 193,0.040D0,  0,105, 46,  0,  0,  0,
51179      & 193,0.120D0,  0,105, 47,  0,  0,  0,
51180      & 193,0.020D0,  0,101, 30,  0,  0,  0,
51181      & 193,0.060D0,  0,101, 31,  0,  0,  0,
51182      & 193,0.040D0,  0,102, 30,  0,  0,  0,
51183      & 193,0.120D0,  0,102, 31,  0,  0,  0,
51184      & 193,0.010D0,  0,106, 21,  0,  0,  0,
51185      & 193,0.030D0,  0,106, 23,  0,  0,  0,
51186      & 193,0.020D0,  0,107, 21,  0,  0,  0,
51187      & 193,0.060D0,  0,107, 23,  0,  0,  0,
51188      & 193,0.030D0,  0,106, 56,  0,  0,  0,
51189      & 193,0.030D0,  0,108, 34,  0,  0,  0,
51190      & 194,1.000D0,  0,193, 59,  0,  0,  0,
51191      & 195,0.670D0,  0,190, 38,  0,  0,  0,
51192      & 195,0.330D0,  0,193, 21,  0,  0,  0,
51193      & 196,0.050D0,101,128,121,108,  0,  0,
51194      & 196,0.050D0,101,130,123,108,  0,  0/
51195       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1103,1121)/
51196      & 196,0.075D0,  0,106, 50,  0,  0,  0,
51197      & 196,0.225D0,  0,106, 51,  0,  0,  0,
51198      & 196,0.150D0,  0,107, 50,  0,  0,  0,
51199      & 196,0.450D0,  0,107, 51,  0,  0,  0,
51200      & 197,1.000D0,  0,196, 59,  0,  0,  0,
51201      & 209,0.250D0,100,  1,  8,  4,  0,  0,
51202      & 209,0.250D0,100,  3, 10,  4,  0,  0,
51203      & 209,0.250D0,100,  5, 12,  4,  0,  0,
51204      & 209,0.085D0,100,121,128,  4,  0,  0,
51205      & 209,0.085D0,100,123,130,  4,  0,  0,
51206      & 209,0.080D0,100,125,132,  4,  0,  0,
51207      & 210,0.250D0,100,  2,  7,209,  0,  0,
51208      & 210,0.250D0,100,  4,  9,209,  0,  0,
51209      & 210,0.250D0,100,  6, 11,209,  0,  0,
51210      & 210,0.085D0,100,122,127,209,  0,  0,
51211      & 210,0.085D0,100,124,129,209,  0,  0,
51212      & 210,0.080D0,100,126,131,209,  0,  0,
51213      & 211,0.250D0,100,  1,  8,  6,  0,  0,
51214      & 211,0.250D0,100,  3, 10,  6,  0,  0/
51215       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1122,1140)/
51216      & 211,0.250D0,100,  5, 12,  6,  0,  0,
51217      & 211,0.085D0,100,121,128,  6,  0,  0,
51218      & 211,0.085D0,100,123,130,  6,  0,  0,
51219      & 211,0.080D0,100,125,132,  6,  0,  0,
51220      & 212,0.250D0,100,  2,  7,211,  0,  0,
51221      & 212,0.250D0,100,  4,  9,211,  0,  0,
51222      & 212,0.250D0,100,  6, 11,211,  0,  0,
51223      & 212,0.085D0,100,122,127,211,  0,  0,
51224      & 212,0.085D0,100,124,129,211,  0,  0,
51225      & 212,0.080D0,100,126,131,211,  0,  0,
51226      & 215,0.250D0,100,  7,  2, 10,  0,  0,
51227      & 215,0.250D0,100,  9,  4, 10,  0,  0,
51228      & 215,0.250D0,100, 11,  6, 10,  0,  0,
51229      & 215,0.085D0,100,127,122, 10,  0,  0,
51230      & 215,0.085D0,100,129,124, 10,  0,  0,
51231      & 215,0.080D0,100,131,126, 10,  0,  0,
51232      & 216,0.250D0,100,  8,  1,215,  0,  0,
51233      & 216,0.250D0,100, 10,  3,215,  0,  0,
51234      & 216,0.250D0,100, 12,  5,215,  0,  0/
51235       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1141,1159)/
51236      & 216,0.085D0,100,128,121,215,  0,  0,
51237      & 216,0.085D0,100,130,123,215,  0,  0,
51238      & 216,0.080D0,100,132,125,215,  0,  0,
51239      & 217,0.250D0,100,  7,  2, 12,  0,  0,
51240      & 217,0.250D0,100,  9,  4, 12,  0,  0,
51241      & 217,0.250D0,100, 11,  6, 12,  0,  0,
51242      & 217,0.085D0,100,127,122, 12,  0,  0,
51243      & 217,0.085D0,100,129,124, 12,  0,  0,
51244      & 217,0.080D0,100,131,126, 12,  0,  0,
51245      & 218,0.250D0,100,  8,  1,217,  0,  0,
51246      & 218,0.250D0,100, 10,  3,217,  0,  0,
51247      & 218,0.250D0,100, 12,  5,217,  0,  0,
51248      & 218,0.085D0,100,128,121,217,  0,  0,
51249      & 218,0.085D0,100,130,123,217,  0,  0,
51250      & 218,0.080D0,100,132,125,217,  0,  0,
51251      & 221,0.016D0,101,121,128,136,  0,  0,
51252      & 221,0.016D0,101,123,130,136,  0,  0,
51253      & 221,0.008D0,101,125,132,136,  0,  0,
51254      & 221,0.048D0,101,121,128,137,  0,  0/
51255       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1160,1178)/
51256      & 221,0.048D0,101,123,130,137,  0,  0,
51257      & 221,0.022D0,101,125,132,137,  0,  0,
51258      & 221,0.003D0,101,121,128,331,  0,  0,
51259      & 221,0.003D0,101,123,130,331,  0,  0,
51260      & 221,0.001D0,101,125,132,331,  0,  0,
51261      & 221,0.008D0,101,121,128,138,  0,  0,
51262      & 221,0.008D0,101,123,130,138,  0,  0,
51263      & 221,0.004D0,101,125,132,138,  0,  0,
51264      & 221,0.008D0,101,121,128,313,  0,  0,
51265      & 221,0.008D0,101,123,130,313,  0,  0,
51266      & 221,0.004D0,101,125,132,313,  0,  0,
51267      & 221,0.013D0,101,121,128,139,  0,  0,
51268      & 221,0.013D0,101,123,130,139,  0,  0,
51269      & 221,0.006D0,101,125,132,139,  0,  0,
51270      & 221,0.004D0,  0,136, 30,  0,  0,  0,
51271      & 221,0.010D0,  0,136, 31,  0,  0,  0,
51272      & 221,0.006D0,  0,136, 32,  0,  0,  0,
51273      & 221,0.003D0,  0,137, 30,  0,  0,  0,
51274      & 221,0.009D0,  0,137, 31,  0,  0,  0/
51275       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1179,1197)/
51276      & 221,0.017D0,  0,137, 32,  0,  0,  0,
51277      & 221,0.011D0,  0,136,179,  0,  0,  0,
51278      & 221,0.015D0,  0,136,180,  0,  0,  0,
51279      & 221,0.011D0,  0,137,179,  0,  0,  0,
51280      & 221,0.022D0,  0,137,180,  0,  0,  0,
51281      & 221,0.001D0,  0,164, 42,  0,  0,  0,
51282      & 221,0.002D0,  0,164, 43,  0,  0,  0,
51283      & 221,0.001D0,  0,165, 42,  0,  0,  0,
51284      & 221,0.001D0,  0,165, 43,  0,  0,  0,
51285      & 221,0.001D0,  0,166, 42,  0,  0,  0,
51286      & 221,0.001D0,  0,166, 43,  0,  0,  0,
51287      & 221,0.207D0,100,  1,  8,  4,  7,  0,
51288      & 221,0.207D0,100,  3, 10,  4,  7,  0,
51289      & 221,0.024D0,100,  1,  8,  2,  7,  0,
51290      & 221,0.024D0,100,  3, 10,  2,  7,  0,
51291      & 221,0.012D0,100,  3,  8,  4,  7,  0,
51292      & 221,0.012D0,100,  1, 10,  4,  7,  0,
51293      & 221,0.069D0,100,  4,  8,  1,  7,  0,
51294      & 221,0.069D0,100,  4, 10,  3,  7,  0/
51295       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1198,1216)/
51296      & 221,0.008D0,100,  2,  8,  1,  7,  0,
51297      & 221,0.008D0,100,  2, 10,  3,  7,  0,
51298      & 221,0.004D0,100,  4,  8,  3,  7,  0,
51299      & 221,0.004D0,100,  4, 10,  1,  7,  0,
51300      & 222,0.016D0,101,121,128,140,  0,  0,
51301      & 222,0.016D0,101,123,130,140,  0,  0,
51302      & 222,0.008D0,101,125,132,140,  0,  0,
51303      & 222,0.048D0,101,121,128,141,  0,  0,
51304      & 222,0.048D0,101,123,130,141,  0,  0,
51305      & 222,0.022D0,101,125,132,141,  0,  0,
51306      & 222,0.003D0,101,121,128,332,  0,  0,
51307      & 222,0.003D0,101,123,130,332,  0,  0,
51308      & 222,0.001D0,101,125,132,332,  0,  0,
51309      & 222,0.008D0,101,121,128,142,  0,  0,
51310      & 222,0.008D0,101,123,130,142,  0,  0,
51311      & 222,0.004D0,101,125,132,142,  0,  0,
51312      & 222,0.008D0,101,121,128,314,  0,  0,
51313      & 222,0.008D0,101,123,130,314,  0,  0,
51314      & 222,0.004D0,101,125,132,314,  0,  0/
51315       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1217,1235)/
51316      & 222,0.013D0,101,121,128,143,  0,  0,
51317      & 222,0.013D0,101,123,130,143,  0,  0,
51318      & 222,0.006D0,101,125,132,143,  0,  0,
51319      & 222,0.004D0,  0,140, 30,  0,  0,  0,
51320      & 222,0.010D0,  0,140, 31,  0,  0,  0,
51321      & 222,0.006D0,  0,140, 32,  0,  0,  0,
51322      & 222,0.003D0,  0,141, 30,  0,  0,  0,
51323      & 222,0.009D0,  0,141, 31,  0,  0,  0,
51324      & 222,0.017D0,  0,141, 32,  0,  0,  0,
51325      & 222,0.011D0,  0,140,179,  0,  0,  0,
51326      & 222,0.015D0,  0,140,180,  0,  0,  0,
51327      & 222,0.011D0,  0,141,179,  0,  0,  0,
51328      & 222,0.022D0,  0,141,180,  0,  0,  0,
51329      & 222,0.001D0,  0,164, 34,  0,  0,  0,
51330      & 222,0.002D0,  0,164, 35,  0,  0,  0,
51331      & 222,0.001D0,  0,165, 34,  0,  0,  0,
51332      & 222,0.001D0,  0,165, 35,  0,  0,  0,
51333      & 222,0.001D0,  0,166, 34,  0,  0,  0,
51334      & 222,0.001D0,  0,166, 35,  0,  0,  0/
51335       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1236,1254)/
51336      & 222,0.207D0,100,  1,  8,  4,  8,  0,
51337      & 222,0.207D0,100,  3, 10,  4,  8,  0,
51338      & 222,0.024D0,100,  1,  8,  2,  8,  0,
51339      & 222,0.024D0,100,  3, 10,  2,  8,  0,
51340      & 222,0.012D0,100,  3,  8,  4,  8,  0,
51341      & 222,0.012D0,100,  1, 10,  4,  8,  0,
51342      & 222,0.069D0,100,  4,  8,  1,  8,  0,
51343      & 222,0.069D0,100,  4, 10,  3,  8,  0,
51344      & 222,0.008D0,100,  2,  8,  1,  8,  0,
51345      & 222,0.008D0,100,  2, 10,  3,  8,  0,
51346      & 222,0.004D0,100,  4,  8,  3,  8,  0,
51347      & 222,0.004D0,100,  4, 10,  1,  8,  0,
51348      & 223,0.016D0,101,121,128,144,  0,  0,
51349      & 223,0.016D0,101,123,130,144,  0,  0,
51350      & 223,0.008D0,101,125,132,144,  0,  0,
51351      & 223,0.048D0,101,121,128,145,  0,  0,
51352      & 223,0.048D0,101,123,130,145,  0,  0,
51353      & 223,0.022D0,101,125,132,145,  0,  0,
51354      & 223,0.003D0,101,121,128,333,  0,  0/
51355       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1255,1273)/
51356      & 223,0.003D0,101,123,130,333,  0,  0,
51357      & 223,0.001D0,101,125,132,333,  0,  0,
51358      & 223,0.008D0,101,121,128,146,  0,  0,
51359      & 223,0.008D0,101,123,130,146,  0,  0,
51360      & 223,0.004D0,101,125,132,146,  0,  0,
51361      & 223,0.008D0,101,121,128,315,  0,  0,
51362      & 223,0.008D0,101,123,130,315,  0,  0,
51363      & 223,0.004D0,101,125,132,315,  0,  0,
51364      & 223,0.013D0,101,121,128,147,  0,  0,
51365      & 223,0.013D0,101,123,130,147,  0,  0,
51366      & 223,0.006D0,101,125,132,147,  0,  0,
51367      & 223,0.004D0,  0,144, 30,  0,  0,  0,
51368      & 223,0.010D0,  0,144, 31,  0,  0,  0,
51369      & 223,0.006D0,  0,144, 32,  0,  0,  0,
51370      & 223,0.003D0,  0,145, 30,  0,  0,  0,
51371      & 223,0.009D0,  0,145, 31,  0,  0,  0,
51372      & 223,0.017D0,  0,145, 32,  0,  0,  0,
51373      & 223,0.011D0,  0,144,179,  0,  0,  0,
51374      & 223,0.015D0,  0,144,180,  0,  0,  0/
51375       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1274,1292)/
51376      & 223,0.011D0,  0,145,179,  0,  0,  0,
51377      & 223,0.022D0,  0,145,180,  0,  0,  0,
51378      & 223,0.001D0,  0,164, 25,  0,  0,  0,
51379      & 223,0.002D0,  0,164, 56,  0,  0,  0,
51380      & 223,0.001D0,  0,165, 25,  0,  0,  0,
51381      & 223,0.001D0,  0,165, 56,  0,  0,  0,
51382      & 223,0.001D0,  0,166, 25,  0,  0,  0,
51383      & 223,0.001D0,  0,166, 56,  0,  0,  0,
51384      & 223,0.207D0,100,  1,  8,  4,  9,  0,
51385      & 223,0.207D0,100,  3, 10,  4,  9,  0,
51386      & 223,0.024D0,100,  1,  8,  2,  9,  0,
51387      & 223,0.024D0,100,  3, 10,  2,  9,  0,
51388      & 223,0.012D0,100,  3,  8,  4,  9,  0,
51389      & 223,0.012D0,100,  1, 10,  4,  9,  0,
51390      & 223,0.069D0,100,  4,  8,  1,  9,  0,
51391      & 223,0.069D0,100,  4, 10,  3,  9,  0,
51392      & 223,0.008D0,100,  2,  8,  1,  9,  0,
51393      & 223,0.008D0,100,  2, 10,  3,  9,  0,
51394      & 223,0.004D0,100,  4,  8,  3,  9,  0/
51395       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1293,1311)/
51396      & 223,0.004D0,100,  4, 10,  1,  9,  0,
51397      & 224,0.090D0,100,121,128,  4,109,  0,
51398      & 224,0.090D0,100,123,130,  4,109,  0,
51399      & 224,0.045D0,100,125,132,  4,109,  0,
51400      & 224,0.010D0,100,121,128,  2,109,  0,
51401      & 224,0.010D0,100,123,130,  2,109,  0,
51402      & 224,0.005D0,100,125,132,  2,109,  0,
51403      & 224,0.242D0,100,  1,  8,  4,109,  0,
51404      & 224,0.242D0,100,  3, 10,  4,109,  0,
51405      & 224,0.027D0,100,  1,  8,  2,109,  0,
51406      & 224,0.027D0,100,  3, 10,  2,109,  0,
51407      & 224,0.012D0,100,  3,  8,  4,109,  0,
51408      & 224,0.012D0,100,  1, 10,  4,109,  0,
51409      & 224,0.081D0,100,  4,  8,  1,109,  0,
51410      & 224,0.081D0,100,  4, 10,  3,109,  0,
51411      & 224,0.009D0,100,  2,  8,  1,109,  0,
51412      & 224,0.009D0,100,  2, 10,  3,109,  0,
51413      & 224,0.004D0,100,  4,  8,  3,109,  0,
51414      & 224,0.004D0,100,  4, 10,  1,109,  0/
51415       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1312,1330)/
51416      & 225,0.090D0,100,121,128,  4,110,  0,
51417      & 225,0.090D0,100,123,130,  4,110,  0,
51418      & 225,0.045D0,100,125,132,  4,110,  0,
51419      & 225,0.010D0,100,121,128,  2,110,  0,
51420      & 225,0.010D0,100,123,130,  2,110,  0,
51421      & 225,0.005D0,100,125,132,  2,110,  0,
51422      & 225,0.242D0,100,  1,  8,  4,110,  0,
51423      & 225,0.242D0,100,  3, 10,  4,110,  0,
51424      & 225,0.027D0,100,  1,  8,  2,110,  0,
51425      & 225,0.027D0,100,  3, 10,  2,110,  0,
51426      & 225,0.012D0,100,  3,  8,  4,110,  0,
51427      & 225,0.012D0,100,  1, 10,  4,110,  0,
51428      & 225,0.081D0,100,  4,  8,  1,110,  0,
51429      & 225,0.081D0,100,  4, 10,  3,110,  0,
51430      & 225,0.009D0,100,  2,  8,  1,110,  0,
51431      & 225,0.009D0,100,  2, 10,  3,110,  0,
51432      & 225,0.004D0,100,  4,  8,  3,110,  0,
51433      & 225,0.004D0,100,  4, 10,  1,110,  0,
51434      & 226,0.090D0,100,121,128,  4,111,  0/
51435       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1331,1349)/
51436      & 226,0.090D0,100,123,130,  4,111,  0,
51437      & 226,0.045D0,100,125,132,  4,111,  0,
51438      & 226,0.010D0,100,121,128,  2,111,  0,
51439      & 226,0.010D0,100,123,130,  2,111,  0,
51440      & 226,0.005D0,100,125,132,  2,111,  0,
51441      & 226,0.242D0,100,  1,  8,  4,111,  0,
51442      & 226,0.242D0,100,  3, 10,  4,111,  0,
51443      & 226,0.027D0,100,  1,  8,  2,111,  0,
51444      & 226,0.027D0,100,  3, 10,  2,111,  0,
51445      & 226,0.012D0,100,  3,  8,  4,111,  0,
51446      & 226,0.012D0,100,  1, 10,  4,111,  0,
51447      & 226,0.081D0,100,  4,  8,  1,111,  0,
51448      & 226,0.081D0,100,  4, 10,  3,111,  0,
51449      & 226,0.009D0,100,  2,  8,  1,111,  0,
51450      & 226,0.009D0,100,  2, 10,  3,111,  0,
51451      & 226,0.004D0,100,  4,  8,  3,111,  0,
51452      & 226,0.004D0,100,  4, 10,  1,111,  0,
51453      & 227,0.090D0,100,121,128,  4,112,  0,
51454      & 227,0.090D0,100,123,130,  4,112,  0/
51455       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1350,1368)/
51456      & 227,0.045D0,100,125,132,  4,112,  0,
51457      & 227,0.010D0,100,121,128,  2,112,  0,
51458      & 227,0.010D0,100,123,130,  2,112,  0,
51459      & 227,0.005D0,100,125,132,  2,112,  0,
51460      & 227,0.242D0,100,  1,  8,  4,112,  0,
51461      & 227,0.242D0,100,  3, 10,  4,112,  0,
51462      & 227,0.027D0,100,  1,  8,  2,112,  0,
51463      & 227,0.027D0,100,  3, 10,  2,112,  0,
51464      & 227,0.012D0,100,  3,  8,  4,112,  0,
51465      & 227,0.012D0,100,  1, 10,  4,112,  0,
51466      & 227,0.081D0,100,  4,  8,  1,112,  0,
51467      & 227,0.081D0,100,  4, 10,  3,112,  0,
51468      & 227,0.009D0,100,  2,  8,  1,112,  0,
51469      & 227,0.009D0,100,  2, 10,  3,112,  0,
51470      & 227,0.004D0,100,  4,  8,  3,112,  0,
51471      & 227,0.004D0,100,  4, 10,  1,112,  0,
51472      & 228,0.090D0,100,121,128,  4,113,  0,
51473      & 228,0.090D0,100,123,130,  4,113,  0,
51474      & 228,0.045D0,100,125,132,  4,113,  0/
51475       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1369,1387)/
51476      & 228,0.010D0,100,121,128,  2,113,  0,
51477      & 228,0.010D0,100,123,130,  2,113,  0,
51478      & 228,0.005D0,100,125,132,  2,113,  0,
51479      & 228,0.242D0,100,  1,  8,  4,113,  0,
51480      & 228,0.242D0,100,  3, 10,  4,113,  0,
51481      & 228,0.027D0,100,  1,  8,  2,113,  0,
51482      & 228,0.027D0,100,  3, 10,  2,113,  0,
51483      & 228,0.012D0,100,  3,  8,  4,113,  0,
51484      & 228,0.012D0,100,  1, 10,  4,113,  0,
51485      & 228,0.081D0,100,  4,  8,  1,113,  0,
51486      & 228,0.081D0,100,  4, 10,  3,113,  0,
51487      & 228,0.009D0,100,  2,  8,  1,113,  0,
51488      & 228,0.009D0,100,  2, 10,  3,113,  0,
51489      & 228,0.004D0,100,  4,  8,  3,113,  0,
51490      & 228,0.004D0,100,  4, 10,  1,113,  0,
51491      & 229,0.090D0,100,121,128,  4,114,  0,
51492      & 229,0.090D0,100,123,130,  4,114,  0,
51493      & 229,0.045D0,100,125,132,  4,114,  0,
51494      & 229,0.010D0,100,121,128,  2,114,  0/
51495       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1388,1406)/
51496      & 229,0.010D0,100,123,130,  2,114,  0,
51497      & 229,0.005D0,100,125,132,  2,114,  0,
51498      & 229,0.242D0,100,  1,  8,  4,114,  0,
51499      & 229,0.242D0,100,  3, 10,  4,114,  0,
51500      & 229,0.027D0,100,  1,  8,  2,114,  0,
51501      & 229,0.027D0,100,  3, 10,  2,114,  0,
51502      & 229,0.012D0,100,  3,  8,  4,114,  0,
51503      & 229,0.012D0,100,  1, 10,  4,114,  0,
51504      & 229,0.081D0,100,  4,  8,  1,114,  0,
51505      & 229,0.081D0,100,  4, 10,  3,114,  0,
51506      & 229,0.009D0,100,  2,  8,  1,114,  0,
51507      & 229,0.009D0,100,  2, 10,  3,114,  0,
51508      & 229,0.004D0,100,  4,  8,  3,114,  0,
51509      & 229,0.004D0,100,  4, 10,  1,114,  0,
51510      & 230,0.080D0,100,121,128,  4, 10,  0,
51511      & 230,0.080D0,100,123,130,  4, 10,  0,
51512      & 230,0.040D0,100,125,132,  4, 10,  0,
51513      & 230,0.080D0,100,121,128,  9,  5,  0,
51514      & 230,0.080D0,100,123,130,  9,  5,  0/
51515       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1407,1425)/
51516      & 230,0.228D0,100,  1,  8,  4, 10,  0,
51517      & 230,0.228D0,100,  3, 10,  4, 10,  0,
51518      & 230,0.012D0,100,  3,  8,  4, 10,  0,
51519      & 230,0.012D0,100,  1, 10,  4, 10,  0,
51520      & 230,0.076D0,100,  4,  8,  1, 10,  0,
51521      & 230,0.076D0,100,  4, 10,  3, 10,  0,
51522      & 230,0.004D0,100,  4,  8,  3, 10,  0,
51523      & 230,0.004D0,100,  4, 10,  1, 10,  0,
51524      & 231,0.025D0,  0,121,127,  0,  0,  0,
51525      & 231,0.025D0,  0,123,129,  0,  0,  0,
51526      & 231,0.025D0,  0,125,131,  0,  0,  0,
51527      & 231,0.008D0,  0,  1,  7,  0,  0,  0,
51528      & 231,0.033D0,  0,  2,  8,  0,  0,  0,
51529      & 231,0.008D0,  0,  3,  9,  0,  0,  0,
51530      & 231,0.033D0,  0,  4, 10,  0,  0,  0,
51531      & 231,0.801D0,130, 13, 13, 13,  0,  0,
51532      & 231,0.042D0,130, 13, 13, 59,  0,  0,
51533      & 245,0.016D0,101,127,122,171,  0,  0,
51534      & 245,0.016D0,101,129,124,171,  0,  0/
51535       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1426,1444)/
51536      & 245,0.008D0,101,131,126,171,  0,  0,
51537      & 245,0.048D0,101,127,122,172,  0,  0,
51538      & 245,0.048D0,101,129,124,172,  0,  0,
51539      & 245,0.022D0,101,131,126,172,  0,  0,
51540      & 245,0.003D0,101,127,122,334,  0,  0,
51541      & 245,0.003D0,101,129,124,334,  0,  0,
51542      & 245,0.001D0,101,131,126,334,  0,  0,
51543      & 245,0.008D0,101,127,122,173,  0,  0,
51544      & 245,0.008D0,101,129,124,173,  0,  0,
51545      & 245,0.004D0,101,131,126,173,  0,  0,
51546      & 245,0.008D0,101,127,122,316,  0,  0,
51547      & 245,0.008D0,101,129,124,316,  0,  0,
51548      & 245,0.004D0,101,131,126,316,  0,  0,
51549      & 245,0.013D0,101,127,122,174,  0,  0,
51550      & 245,0.013D0,101,129,124,174,  0,  0,
51551      & 245,0.006D0,101,131,126,174,  0,  0,
51552      & 245,0.004D0,  0,171, 38,  0,  0,  0,
51553      & 245,0.010D0,  0,171, 39,  0,  0,  0,
51554      & 245,0.006D0,  0,171, 40,  0,  0,  0/
51555       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1445,1463)/
51556      & 245,0.003D0,  0,172, 38,  0,  0,  0,
51557      & 245,0.009D0,  0,172, 39,  0,  0,  0,
51558      & 245,0.017D0,  0,172, 40,  0,  0,  0,
51559      & 245,0.011D0,  0,171,144,  0,  0,  0,
51560      & 245,0.015D0,  0,171,145,  0,  0,  0,
51561      & 245,0.011D0,  0,172,144,  0,  0,  0,
51562      & 245,0.022D0,  0,172,145,  0,  0,  0,
51563      & 245,0.001D0,  0,164, 50,  0,  0,  0,
51564      & 245,0.002D0,  0,164, 51,  0,  0,  0,
51565      & 245,0.001D0,  0,165, 50,  0,  0,  0,
51566      & 245,0.001D0,  0,165, 51,  0,  0,  0,
51567      & 245,0.001D0,  0,166, 50,  0,  0,  0,
51568      & 245,0.001D0,  0,166, 51,  0,  0,  0,
51569      & 245,0.207D0,100,  7,  2, 10,  1,  0,
51570      & 245,0.207D0,100,  9,  4, 10,  1,  0,
51571      & 245,0.024D0,100,  7,  2,  8,  1,  0,
51572      & 245,0.024D0,100,  9,  4,  8,  1,  0,
51573      & 245,0.012D0,100,  9,  2, 10,  1,  0,
51574      & 245,0.012D0,100,  7,  4, 10,  1,  0/
51575       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1464,1482)/
51576      & 245,0.069D0,100, 10,  2,  7,  1,  0,
51577      & 245,0.069D0,100, 10,  4,  9,  1,  0,
51578      & 245,0.008D0,100,  8,  2,  7,  1,  0,
51579      & 245,0.008D0,100,  8,  4,  9,  1,  0,
51580      & 245,0.004D0,100, 10,  2,  9,  1,  0,
51581      & 245,0.004D0,100, 10,  4,  7,  1,  0,
51582      & 246,0.016D0,101,127,122,175,  0,  0,
51583      & 246,0.016D0,101,129,124,175,  0,  0,
51584      & 246,0.008D0,101,131,126,175,  0,  0,
51585      & 246,0.048D0,101,127,122,176,  0,  0,
51586      & 246,0.048D0,101,129,124,176,  0,  0,
51587      & 246,0.022D0,101,131,126,176,  0,  0,
51588      & 246,0.003D0,101,127,122,335,  0,  0,
51589      & 246,0.003D0,101,129,124,335,  0,  0,
51590      & 246,0.001D0,101,131,126,335,  0,  0,
51591      & 246,0.008D0,101,127,122,177,  0,  0,
51592      & 246,0.008D0,101,129,124,177,  0,  0,
51593      & 246,0.004D0,101,131,126,177,  0,  0,
51594      & 246,0.008D0,101,127,122,317,  0,  0/
51595       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1483,1501)/
51596      & 246,0.008D0,101,129,124,317,  0,  0,
51597      & 246,0.004D0,101,131,126,317,  0,  0,
51598      & 246,0.013D0,101,127,122,178,  0,  0,
51599      & 246,0.013D0,101,129,124,178,  0,  0,
51600      & 246,0.006D0,101,131,126,178,  0,  0,
51601      & 246,0.004D0,  0,175, 38,  0,  0,  0,
51602      & 246,0.010D0,  0,175, 39,  0,  0,  0,
51603      & 246,0.006D0,  0,175, 40,  0,  0,  0,
51604      & 246,0.003D0,  0,176, 38,  0,  0,  0,
51605      & 246,0.009D0,  0,176, 39,  0,  0,  0,
51606      & 246,0.017D0,  0,176, 40,  0,  0,  0,
51607      & 246,0.011D0,  0,175,144,  0,  0,  0,
51608      & 246,0.015D0,  0,175,145,  0,  0,  0,
51609      & 246,0.011D0,  0,176,144,  0,  0,  0,
51610      & 246,0.022D0,  0,176,145,  0,  0,  0,
51611      & 246,0.001D0,  0,164, 46,  0,  0,  0,
51612      & 246,0.002D0,  0,164, 47,  0,  0,  0,
51613      & 246,0.001D0,  0,165, 46,  0,  0,  0,
51614      & 246,0.001D0,  0,165, 47,  0,  0,  0/
51615       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1502,1520)/
51616      & 246,0.001D0,  0,166, 46,  0,  0,  0,
51617      & 246,0.001D0,  0,166, 47,  0,  0,  0,
51618      & 246,0.207D0,100,  7,  2, 10,  2,  0,
51619      & 246,0.207D0,100,  9,  4, 10,  2,  0,
51620      & 246,0.024D0,100,  7,  2,  8,  2,  0,
51621      & 246,0.024D0,100,  9,  4,  8,  2,  0,
51622      & 246,0.012D0,100,  9,  2, 10,  2,  0,
51623      & 246,0.012D0,100,  7,  4, 10,  2,  0,
51624      & 246,0.069D0,100, 10,  2,  7,  2,  0,
51625      & 246,0.069D0,100, 10,  4,  9,  2,  0,
51626      & 246,0.008D0,100,  8,  2,  7,  2,  0,
51627      & 246,0.008D0,100,  8,  4,  9,  2,  0,
51628      & 246,0.004D0,100, 10,  2,  9,  2,  0,
51629      & 246,0.004D0,100, 10,  4,  7,  2,  0,
51630      & 247,0.016D0,101,127,122,179,  0,  0,
51631      & 247,0.016D0,101,129,124,179,  0,  0,
51632      & 247,0.008D0,101,131,126,179,  0,  0,
51633      & 247,0.048D0,101,127,122,180,  0,  0,
51634      & 247,0.048D0,101,129,124,180,  0,  0/
51635       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1521,1539)/
51636      & 247,0.022D0,101,131,126,180,  0,  0,
51637      & 247,0.003D0,101,127,122,336,  0,  0,
51638      & 247,0.003D0,101,129,124,336,  0,  0,
51639      & 247,0.001D0,101,131,126,336,  0,  0,
51640      & 247,0.008D0,101,127,122,181,  0,  0,
51641      & 247,0.008D0,101,129,124,181,  0,  0,
51642      & 247,0.004D0,101,131,126,181,  0,  0,
51643      & 247,0.008D0,101,127,122,318,  0,  0,
51644      & 247,0.008D0,101,129,124,318,  0,  0,
51645      & 247,0.004D0,101,131,126,318,  0,  0,
51646      & 247,0.013D0,101,127,122,182,  0,  0,
51647      & 247,0.013D0,101,129,124,182,  0,  0,
51648      & 247,0.006D0,101,131,126,182,  0,  0,
51649      & 247,0.004D0,  0,179, 38,  0,  0,  0,
51650      & 247,0.010D0,  0,179, 39,  0,  0,  0,
51651      & 247,0.006D0,  0,179, 40,  0,  0,  0,
51652      & 247,0.003D0,  0,180, 38,  0,  0,  0,
51653      & 247,0.009D0,  0,180, 39,  0,  0,  0,
51654      & 247,0.017D0,  0,180, 40,  0,  0,  0/
51655       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1540,1558)/
51656      & 247,0.011D0,  0,179,144,  0,  0,  0,
51657      & 247,0.015D0,  0,179,145,  0,  0,  0,
51658      & 247,0.011D0,  0,180,144,  0,  0,  0,
51659      & 247,0.022D0,  0,180,145,  0,  0,  0,
51660      & 247,0.001D0,  0,164, 25,  0,  0,  0,
51661      & 247,0.002D0,  0,164, 56,  0,  0,  0,
51662      & 247,0.001D0,  0,165, 25,  0,  0,  0,
51663      & 247,0.001D0,  0,165, 56,  0,  0,  0,
51664      & 247,0.001D0,  0,166, 25,  0,  0,  0,
51665      & 247,0.001D0,  0,166, 56,  0,  0,  0,
51666      & 247,0.207D0,100,  7,  2, 10,  3,  0,
51667      & 247,0.207D0,100,  9,  4, 10,  3,  0,
51668      & 247,0.024D0,100,  7,  2,  8,  3,  0,
51669      & 247,0.024D0,100,  9,  4,  8,  3,  0,
51670      & 247,0.012D0,100,  9,  2, 10,  3,  0,
51671      & 247,0.012D0,100,  7,  4, 10,  3,  0,
51672      & 247,0.069D0,100, 10,  2,  7,  3,  0,
51673      & 247,0.069D0,100, 10,  4,  9,  3,  0,
51674      & 247,0.008D0,100,  8,  2,  7,  3,  0/
51675       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1559,1577)/
51676      & 247,0.008D0,100,  8,  4,  9,  3,  0,
51677      & 247,0.004D0,100, 10,  2,  9,  3,  0,
51678      & 247,0.004D0,100, 10,  4,  7,  3,  0,
51679      & 248,0.090D0,100,127,122, 10,115,  0,
51680      & 248,0.090D0,100,129,124, 10,115,  0,
51681      & 248,0.045D0,100,131,126, 10,115,  0,
51682      & 248,0.010D0,100,127,122,  8,115,  0,
51683      & 248,0.010D0,100,129,124,  8,115,  0,
51684      & 248,0.005D0,100,131,126,  8,115,  0,
51685      & 248,0.242D0,100,  7,  2, 10,115,  0,
51686      & 248,0.242D0,100,  9,  4, 10,115,  0,
51687      & 248,0.027D0,100,  7,  2,  8,115,  0,
51688      & 248,0.027D0,100,  9,  4,  8,115,  0,
51689      & 248,0.012D0,100,  9,  2, 10,115,  0,
51690      & 248,0.012D0,100,  7,  4, 10,115,  0,
51691      & 248,0.081D0,100, 10,  2,  7,115,  0,
51692      & 248,0.081D0,100, 10,  4,  9,115,  0,
51693      & 248,0.009D0,100,  8,  2,  7,115,  0,
51694      & 248,0.009D0,100,  8,  4,  9,115,  0/
51695       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1578,1596)/
51696      & 248,0.004D0,100, 10,  2,  9,115,  0,
51697      & 248,0.004D0,100, 10,  4,  7,115,  0,
51698      & 249,0.090D0,100,127,122, 10,116,  0,
51699      & 249,0.090D0,100,129,124, 10,116,  0,
51700      & 249,0.045D0,100,131,126, 10,116,  0,
51701      & 249,0.010D0,100,127,122,  8,116,  0,
51702      & 249,0.010D0,100,129,124,  8,116,  0,
51703      & 249,0.005D0,100,131,126,  8,116,  0,
51704      & 249,0.242D0,100,  7,  2, 10,116,  0,
51705      & 249,0.242D0,100,  9,  4, 10,116,  0,
51706      & 249,0.027D0,100,  7,  2,  8,116,  0,
51707      & 249,0.027D0,100,  9,  4,  8,116,  0,
51708      & 249,0.012D0,100,  9,  2, 10,116,  0,
51709      & 249,0.012D0,100,  7,  4, 10,116,  0,
51710      & 249,0.081D0,100, 10,  2,  7,116,  0,
51711      & 249,0.081D0,100, 10,  4,  9,116,  0,
51712      & 249,0.009D0,100,  8,  2,  7,116,  0,
51713      & 249,0.009D0,100,  8,  4,  9,116,  0,
51714      & 249,0.004D0,100, 10,  2,  9,116,  0/
51715       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1597,1615)/
51716      & 249,0.004D0,100, 10,  4,  7,116,  0,
51717      & 250,0.090D0,100,127,122, 10,117,  0,
51718      & 250,0.090D0,100,129,124, 10,117,  0,
51719      & 250,0.045D0,100,131,126, 10,117,  0,
51720      & 250,0.010D0,100,127,122,  8,117,  0,
51721      & 250,0.010D0,100,129,124,  8,117,  0,
51722      & 250,0.005D0,100,131,126,  8,117,  0,
51723      & 250,0.242D0,100,  7,  2, 10,117,  0,
51724      & 250,0.242D0,100,  9,  4, 10,117,  0,
51725      & 250,0.027D0,100,  7,  2,  8,117,  0,
51726      & 250,0.027D0,100,  9,  4,  8,117,  0,
51727      & 250,0.012D0,100,  9,  2, 10,117,  0,
51728      & 250,0.012D0,100,  7,  4, 10,117,  0,
51729      & 250,0.081D0,100, 10,  2,  7,117,  0,
51730      & 250,0.081D0,100, 10,  4,  9,117,  0,
51731      & 250,0.009D0,100,  8,  2,  7,117,  0,
51732      & 250,0.009D0,100,  8,  4,  9,117,  0,
51733      & 250,0.004D0,100, 10,  2,  9,117,  0,
51734      & 250,0.004D0,100, 10,  4,  7,117,  0/
51735       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1616,1634)/
51736      & 251,0.090D0,100,127,122, 10,118,  0,
51737      & 251,0.090D0,100,129,124, 10,118,  0,
51738      & 251,0.045D0,100,131,126, 10,118,  0,
51739      & 251,0.010D0,100,127,122,  8,118,  0,
51740      & 251,0.010D0,100,129,124,  8,118,  0,
51741      & 251,0.005D0,100,131,126,  8,118,  0,
51742      & 251,0.242D0,100,  7,  2, 10,118,  0,
51743      & 251,0.242D0,100,  9,  4, 10,118,  0,
51744      & 251,0.027D0,100,  7,  2,  8,118,  0,
51745      & 251,0.027D0,100,  9,  4,  8,118,  0,
51746      & 251,0.012D0,100,  9,  2, 10,118,  0,
51747      & 251,0.012D0,100,  7,  4, 10,118,  0,
51748      & 251,0.081D0,100, 10,  2,  7,118,  0,
51749      & 251,0.081D0,100, 10,  4,  9,118,  0,
51750      & 251,0.009D0,100,  8,  2,  7,118,  0,
51751      & 251,0.009D0,100,  8,  4,  9,118,  0,
51752      & 251,0.004D0,100, 10,  2,  9,118,  0,
51753      & 251,0.004D0,100, 10,  4,  7,118,  0,
51754      & 252,0.090D0,100,127,122, 10,119,  0/
51755       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1635,1653)/
51756      & 252,0.090D0,100,129,124, 10,119,  0,
51757      & 252,0.045D0,100,131,126, 10,119,  0,
51758      & 252,0.010D0,100,127,122,  8,119,  0,
51759      & 252,0.010D0,100,129,124,  8,119,  0,
51760      & 252,0.005D0,100,131,126,  8,119,  0,
51761      & 252,0.242D0,100,  7,  2, 10,119,  0,
51762      & 252,0.242D0,100,  9,  4, 10,119,  0,
51763      & 252,0.027D0,100,  7,  2,  8,119,  0,
51764      & 252,0.027D0,100,  9,  4,  8,119,  0,
51765      & 252,0.012D0,100,  9,  2, 10,119,  0,
51766      & 252,0.012D0,100,  7,  4, 10,119,  0,
51767      & 252,0.081D0,100, 10,  2,  7,119,  0,
51768      & 252,0.081D0,100, 10,  4,  9,119,  0,
51769      & 252,0.009D0,100,  8,  2,  7,119,  0,
51770      & 252,0.009D0,100,  8,  4,  9,119,  0,
51771      & 252,0.004D0,100, 10,  2,  9,119,  0,
51772      & 252,0.004D0,100, 10,  4,  7,119,  0,
51773      & 253,0.090D0,100,127,122, 10,120,  0,
51774      & 253,0.090D0,100,129,124, 10,120,  0/
51775       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1654,1672)/
51776      & 253,0.045D0,100,131,126, 10,120,  0,
51777      & 253,0.010D0,100,127,122,  8,120,  0,
51778      & 253,0.010D0,100,129,124,  8,120,  0,
51779      & 253,0.005D0,100,131,126,  8,120,  0,
51780      & 253,0.242D0,100,  7,  2, 10,120,  0,
51781      & 253,0.242D0,100,  9,  4, 10,120,  0,
51782      & 253,0.027D0,100,  7,  2,  8,120,  0,
51783      & 253,0.027D0,100,  9,  4,  8,120,  0,
51784      & 253,0.012D0,100,  9,  2, 10,120,  0,
51785      & 253,0.012D0,100,  7,  4, 10,120,  0,
51786      & 253,0.081D0,100, 10,  2,  7,120,  0,
51787      & 253,0.081D0,100, 10,  4,  9,120,  0,
51788      & 253,0.009D0,100,  8,  2,  7,120,  0,
51789      & 253,0.009D0,100,  8,  4,  9,120,  0,
51790      & 253,0.004D0,100, 10,  2,  9,120,  0,
51791      & 253,0.004D0,100, 10,  4,  7,120,  0,
51792      & 254,0.080D0,100,127,122, 10,  4,  0,
51793      & 254,0.080D0,100,129,124, 10,  4,  0,
51794      & 254,0.040D0,100,131,126, 10,  4,  0/
51795       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1673,1691)/
51796      & 254,0.080D0,100,127,122,  3, 11,  0,
51797      & 254,0.080D0,100,129,124,  3, 11,  0,
51798      & 254,0.228D0,100,  7,  2, 10,  4,  0,
51799      & 254,0.228D0,100,  9,  4, 10,  4,  0,
51800      & 254,0.012D0,100,  9,  2, 10,  4,  0,
51801      & 254,0.012D0,100,  7,  4, 10,  4,  0,
51802      & 254,0.076D0,100, 10,  2,  7,  4,  0,
51803      & 254,0.076D0,100, 10,  4,  9,  4,  0,
51804      & 254,0.004D0,100, 10,  2,  9,  4,  0,
51805      & 254,0.004D0,100, 10,  4,  7,  4,  0,
51806      & 265,1.000D0,  0,221, 59,  0,  0,  0,
51807      & 266,1.000D0,  0,222, 59,  0,  0,  0,
51808      & 267,1.000D0,  0,223, 59,  0,  0,  0,
51809      & 268,0.667D0,  0,266, 38,  0,  0,  0,
51810      & 268,0.333D0,  0,265, 21,  0,  0,  0,
51811      & 269,0.667D0,  0,265, 30,  0,  0,  0,
51812      & 269,0.333D0,  0,266, 21,  0,  0,  0,
51813      & 270,0.500D0,  0,265, 50,  0,  0,  0,
51814      & 270,0.500D0,  0,266, 46,  0,  0,  0/
51815       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1692,1710)/
51816      & 271,0.290D0,  0,266, 38,  0,  0,  0,
51817      & 271,0.150D0,  0,265, 21,  0,  0,  0,
51818      & 271,0.290D0,  0,222, 38,  0,  0,  0,
51819      & 271,0.150D0,  0,221, 21,  0,  0,  0,
51820      & 271,0.060D0,  0,266, 38, 21,  0,  0,
51821      & 271,0.020D0,  0,265, 38, 30,  0,  0,
51822      & 271,0.010D0,  0,265, 21, 21,  0,  0,
51823      & 271,0.020D0,  0,222, 38, 21,  0,  0,
51824      & 271,0.010D0,  0,221, 38, 30,  0,  0,
51825      & 272,0.290D0,  0,265, 30,  0,  0,  0,
51826      & 272,0.150D0,  0,266, 21,  0,  0,  0,
51827      & 272,0.290D0,  0,221, 30,  0,  0,  0,
51828      & 272,0.150D0,  0,222, 21,  0,  0,  0,
51829      & 272,0.060D0,  0,265, 30, 21,  0,  0,
51830      & 272,0.020D0,  0,266, 38, 30,  0,  0,
51831      & 272,0.010D0,  0,266, 21, 21,  0,  0,
51832      & 272,0.020D0,  0,221, 30, 21,  0,  0,
51833      & 272,0.010D0,  0,222, 38, 30,  0,  0,
51834      & 273,0.350D0,  0,221, 50,  0,  0,  0/
51835       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1711,1729)/
51836      & 273,0.350D0,  0,222, 46,  0,  0,  0,
51837      & 273,0.150D0,  0,265, 50,  0,  0,  0,
51838      & 273,0.150D0,  0,266, 46,  0,  0,  0,
51839      & 274,1.000D0,  0,245, 59,  0,  0,  0,
51840      & 275,1.000D0,  0,246, 59,  0,  0,  0,
51841      & 276,1.000D0,  0,247, 59,  0,  0,  0,
51842      & 277,0.667D0,  0,275, 30,  0,  0,  0,
51843      & 277,0.333D0,  0,274, 21,  0,  0,  0,
51844      & 278,0.667D0,  0,274, 38,  0,  0,  0,
51845      & 278,0.333D0,  0,275, 21,  0,  0,  0,
51846      & 279,0.500D0,  0,274, 42,  0,  0,  0,
51847      & 279,0.500D0,  0,275, 34,  0,  0,  0,
51848      & 280,0.290D0,  0,275, 30,  0,  0,  0,
51849      & 280,0.150D0,  0,274, 21,  0,  0,  0,
51850      & 280,0.290D0,  0,246, 30,  0,  0,  0,
51851      & 280,0.150D0,  0,245, 21,  0,  0,  0,
51852      & 280,0.060D0,  0,275, 30, 21,  0,  0,
51853      & 280,0.020D0,  0,274, 38, 30,  0,  0,
51854      & 280,0.010D0,  0,274, 21, 21,  0,  0/
51855       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1730,1748)/
51856      & 280,0.020D0,  0,246, 30, 21,  0,  0,
51857      & 280,0.010D0,  0,245, 38, 30,  0,  0,
51858      & 281,0.290D0,  0,274, 38,  0,  0,  0,
51859      & 281,0.150D0,  0,275, 21,  0,  0,  0,
51860      & 281,0.290D0,  0,245, 38,  0,  0,  0,
51861      & 281,0.150D0,  0,246, 21,  0,  0,  0,
51862      & 281,0.060D0,  0,274, 38, 21,  0,  0,
51863      & 281,0.020D0,  0,275, 38, 30,  0,  0,
51864      & 281,0.010D0,  0,275, 21, 21,  0,  0,
51865      & 281,0.020D0,  0,245, 38, 21,  0,  0,
51866      & 281,0.010D0,  0,246, 38, 30,  0,  0,
51867      & 282,0.350D0,  0,245, 42,  0,  0,  0,
51868      & 282,0.350D0,  0,246, 34,  0,  0,  0,
51869      & 282,0.150D0,  0,274, 42,  0,  0,  0,
51870      & 282,0.150D0,  0,275, 34,  0,  0,  0,
51871      & 285,1.000D0,  0, 24, 21,  0,  0,  0,
51872      & 286,0.998D0,  0, 24, 38,  0,  0,  0,
51873      & 286,0.002D0,  0, 38, 59,  0,  0,  0,
51874      & 287,0.998D0,  0, 24, 30,  0,  0,  0/
51875       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1749,1767)/
51876      & 287,0.002D0,  0, 30, 59,  0,  0,  0,
51877      & 288,0.330D0,  0, 39, 30,  0,  0,  0,
51878      & 288,0.340D0,  0, 23, 21,  0,  0,  0,
51879      & 288,0.330D0,  0, 31, 38,  0,  0,  0,
51880      & 289,0.250D0,  0, 46, 35,  0,  0,  0,
51881      & 289,0.250D0,  0, 34, 47,  0,  0,  0,
51882      & 289,0.250D0,  0, 50, 43,  0,  0,  0,
51883      & 289,0.250D0,  0, 42, 51,  0,  0,  0,
51884      & 290,0.996D0,  0, 22, 21,  0,  0,  0,
51885      & 290,0.002D0,  0, 46, 34,  0,  0,  0,
51886      & 290,0.002D0,  0, 50, 42,  0,  0,  0,
51887      & 291,0.996D0,  0, 22, 38,  0,  0,  0,
51888      & 291,0.004D0,  0, 46, 42,  0,  0,  0,
51889      & 292,0.996D0,  0, 22, 30,  0,  0,  0,
51890      & 292,0.004D0,  0, 50, 34,  0,  0,  0,
51891      & 293,0.520D0,  0, 38, 30,  0,  0,  0,
51892      & 293,0.260D0,  0, 21, 21,  0,  0,  0,
51893      & 293,0.110D0,  0, 46, 34,  0,  0,  0,
51894      & 293,0.110D0,  0, 50, 42,  0,  0,  0/
51895       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1768,1786)/
51896      & 294,0.620D0,  0, 38, 30,  0,  0,  0,
51897      & 294,0.310D0,  0, 21, 21,  0,  0,  0,
51898      & 294,0.035D0,  0, 46, 34,  0,  0,  0,
51899      & 294,0.035D0,  0, 50, 42,  0,  0,  0,
51900      & 295,1.000D0,  0,254, 59,  0,  0,  0,
51901      & 296,1.000D0,  0,230, 59,  0,  0,  0,
51902      & 297,1.000D0,  0,254, 59,  0,  0,  0,
51903      & 298,1.000D0,  0,230, 59,  0,  0,  0,
51904      & 299,1.000D0,  0,254, 59,  0,  0,  0,
51905      & 300,1.000D0,  0,230, 59,  0,  0,  0,
51906      & 301,0.050D0,  0,121,127,  0,  0,  0,
51907      & 301,0.050D0,  0,123,129,  0,  0,  0,
51908      & 301,0.017D0,  0,  1,  7,  0,  0,  0,
51909      & 301,0.066D0,  0,  2,  8,  0,  0,  0,
51910      & 301,0.017D0,  0,  3,  9,  0,  0,  0,
51911      & 301,0.640D0,130, 13, 13, 13,  0,  0,
51912      & 301,0.160D0,130, 13, 13, 59,  0,  0,
51913      & 302,0.022D0,  0, 38, 30, 38, 30, 23,
51914      & 302,0.016D0,  0, 38, 30, 38, 30,  0/
51915       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1787,1805)/
51916      & 302,0.009D0,  0, 38, 30, 46, 34,  0,
51917      & 302,0.004D0,  0, 23, 38, 30,  0,  0,
51918      & 302,0.002D0,  0, 46, 43, 30,  0,  0,
51919      & 302,0.002D0,  0, 34, 51, 38,  0,  0,
51920      & 302,0.001D0,  0, 38, 30, 73, 91,  0,
51921      & 302,0.273D0,  0, 59,164,  0,  0,  0,
51922      & 302,0.671D0,  0, 13, 13,  0,  0,  0,
51923      & 303,0.022D0,  0, 38, 30, 38, 30,  0,
51924      & 303,0.019D0,  0, 38, 30, 46, 34,  0,
51925      & 303,0.012D0,  0, 38, 30, 38, 30, 23,
51926      & 303,0.007D0,  0, 23, 38, 30,  0,  0,
51927      & 303,0.002D0,  0, 46, 43, 30,  0,  0,
51928      & 303,0.002D0,  0, 34, 51, 38,  0,  0,
51929      & 303,0.003D0,  0, 38, 30, 73, 91,  0,
51930      & 303,0.002D0,  0, 38, 30,  0,  0,  0,
51931      & 303,0.002D0,  0, 46, 34,  0,  0,  0,
51932      & 303,0.001D0,  0, 21, 21,  0,  0,  0,
51933      & 303,0.135D0,  0, 59,164,  0,  0,  0,
51934      & 303,0.793D0,  0, 13, 13,  0,  0,  0/
51935       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1806,1824)/
51936      & 304,1.000D0,  0, 13, 13,  0,  0,  0,
51937      & 305,1.000D0,  0, 13, 13,  0,  0,  0,
51938      & 306,0.050D0,  0, 59,231,  0,  0,  0,
51939      & 306,0.950D0,  0, 13, 13,  0,  0,  0,
51940      & 307,0.350D0,  0, 59,231,  0,  0,  0,
51941      & 307,0.650D0,  0, 13, 13,  0,  0,  0,
51942      & 308,0.220D0,  0, 59,231,  0,  0,  0,
51943      & 308,0.780D0,  0, 13, 13,  0,  0,  0,
51944      & 309,0.280D0,  0, 46, 31,  0,  0,  0,
51945      & 309,0.140D0,  0, 50, 23,  0,  0,  0,
51946      & 309,0.187D0,  0,327, 30,  0,  0,  0,
51947      & 309,0.093D0,  0,328, 21,  0,  0,  0,
51948      & 309,0.110D0,  0, 50, 24,  0,  0,  0,
51949      & 309,0.107D0,  0, 47, 30,  0,  0,  0,
51950      & 309,0.053D0,  0, 51, 21,  0,  0,  0,
51951      & 309,0.030D0,  0, 50,293,  0,  0,  0,
51952      & 310,0.280D0,  0, 50, 39,  0,  0,  0,
51953      & 310,0.140D0,  0, 46, 23,  0,  0,  0,
51954      & 310,0.187D0,  0,328, 38,  0,  0,  0/
51955       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1825,1843)/
51956      & 310,0.093D0,  0,327, 21,  0,  0,  0,
51957      & 310,0.110D0,  0, 46, 24,  0,  0,  0,
51958      & 310,0.107D0,  0, 51, 38,  0,  0,  0,
51959      & 310,0.053D0,  0, 47, 21,  0,  0,  0,
51960      & 310,0.030D0,  0, 46,293,  0,  0,  0,
51961      & 311,0.280D0,  0, 34, 39,  0,  0,  0,
51962      & 311,0.140D0,  0, 42, 23,  0,  0,  0,
51963      & 311,0.187D0,  0,330, 38,  0,  0,  0,
51964      & 311,0.093D0,  0,329, 21,  0,  0,  0,
51965      & 311,0.110D0,  0, 42, 24,  0,  0,  0,
51966      & 311,0.107D0,  0, 35, 38,  0,  0,  0,
51967      & 311,0.053D0,  0, 43, 21,  0,  0,  0,
51968      & 311,0.030D0,  0, 42,293,  0,  0,  0,
51969      & 312,0.280D0,  0, 42, 31,  0,  0,  0,
51970      & 312,0.140D0,  0, 34, 23,  0,  0,  0,
51971      & 312,0.187D0,  0,329, 30,  0,  0,  0,
51972      & 312,0.093D0,  0,330, 21,  0,  0,  0,
51973      & 312,0.110D0,  0, 34, 24,  0,  0,  0,
51974      & 312,0.107D0,  0, 43, 30,  0,  0,  0/
51975       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1844,1862)/
51976      & 312,0.053D0,  0, 35, 21,  0,  0,  0,
51977      & 312,0.030D0,  0, 34,293,  0,  0,  0,
51978      & 313,0.430D0,  0,140, 38,  0,  0,  0,
51979      & 313,0.215D0,  0,136, 21,  0,  0,  0,
51980      & 313,0.235D0,  0,140, 38, 21,  0,  0,
51981      & 313,0.120D0,  0,136, 38, 30,  0,  0,
51982      & 314,0.430D0,  0,136, 30,  0,  0,  0,
51983      & 314,0.215D0,  0,140, 21,  0,  0,  0,
51984      & 314,0.235D0,  0,136, 30, 21,  0,  0,
51985      & 314,0.120D0,  0,140, 38, 30,  0,  0,
51986      & 315,0.480D0,  0,136, 50,  0,  0,  0,
51987      & 315,0.480D0,  0,140, 46,  0,  0,  0,
51988      & 315,0.040D0,  0,145, 59,  0,  0,  0,
51989      & 316,0.430D0,  0,175, 30,  0,  0,  0,
51990      & 316,0.215D0,  0,171, 21,  0,  0,  0,
51991      & 316,0.235D0,  0,175, 30, 21,  0,  0,
51992      & 316,0.120D0,  0,171, 38, 30,  0,  0,
51993      & 317,0.430D0,  0,171, 38,  0,  0,  0,
51994      & 317,0.215D0,  0,175, 21,  0,  0,  0/
51995       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1863,1881)/
51996      & 317,0.235D0,  0,171, 38, 21,  0,  0,
51997      & 317,0.120D0,  0,175, 38, 30,  0,  0,
51998      & 318,0.480D0,  0,171, 42,  0,  0,  0,
51999      & 318,0.480D0,  0,175, 34,  0,  0,  0,
52000      & 318,0.040D0,  0,180, 59,  0,  0,  0,
52001      & 319,0.540D0,  0,275, 30,  0,  0,  0,
52002      & 319,0.270D0,  0,274, 21,  0,  0,  0,
52003      & 319,0.030D0,  0,275, 30, 21,  0,  0,
52004      & 319,0.010D0,  0,274, 38, 30,  0,  0,
52005      & 319,0.010D0,  0,274, 21, 21,  0,  0,
52006      & 319,0.090D0,  0,246, 30, 21,  0,  0,
52007      & 319,0.030D0,  0,245, 38, 30,  0,  0,
52008      & 319,0.020D0,  0,245, 21, 21,  0,  0,
52009      & 320,0.540D0,  0,274, 38,  0,  0,  0,
52010      & 320,0.270D0,  0,275, 21,  0,  0,  0,
52011      & 320,0.030D0,  0,274, 38, 21,  0,  0,
52012      & 320,0.010D0,  0,275, 38, 30,  0,  0,
52013      & 320,0.010D0,  0,275, 21, 21,  0,  0,
52014      & 320,0.090D0,  0,245, 38, 21,  0,  0/
52015       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1882,1900)/
52016      & 320,0.030D0,  0,246, 38, 30,  0,  0,
52017      & 320,0.020D0,  0,246, 21, 21,  0,  0,
52018      & 321,0.500D0,  0,266, 46,  0,  0,  0,
52019      & 321,0.500D0,  0,265, 50,  0,  0,  0,
52020      & 322,1.000D0,  0,254, 59,  0,  0,  0,
52021      & 323,0.540D0,  0,266, 38,  0,  0,  0,
52022      & 323,0.270D0,  0,265, 21,  0,  0,  0,
52023      & 323,0.030D0,  0,266, 38, 21,  0,  0,
52024      & 323,0.010D0,  0,265, 38, 30,  0,  0,
52025      & 323,0.010D0,  0,265, 21, 21,  0,  0,
52026      & 323,0.090D0,  0,222, 38, 21,  0,  0,
52027      & 323,0.030D0,  0,221, 38, 30,  0,  0,
52028      & 323,0.020D0,  0,221, 21, 21,  0,  0,
52029      & 324,0.540D0,  0,265, 30,  0,  0,  0,
52030      & 324,0.270D0,  0,266, 21,  0,  0,  0,
52031      & 324,0.030D0,  0,265, 30, 21,  0,  0,
52032      & 324,0.010D0,  0,266, 38, 30,  0,  0,
52033      & 324,0.010D0,  0,266, 21, 21,  0,  0,
52034      & 324,0.090D0,  0,221, 30, 21,  0,  0/
52035       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1901,1919)/
52036      & 324,0.030D0,  0,222, 38, 30,  0,  0,
52037      & 324,0.020D0,  0,222, 21, 21,  0,  0,
52038      & 325,0.500D0,  0,275, 34,  0,  0,  0,
52039      & 325,0.500D0,  0,274, 42,  0,  0,  0,
52040      & 326,1.000D0,  0,230, 59,  0,  0,  0,
52041      & 327,0.667D0,  0, 50, 38,  0,  0,  0,
52042      & 327,0.333D0,  0, 46, 21,  0,  0,  0,
52043      & 328,0.667D0,  0, 46, 30,  0,  0,  0,
52044      & 328,0.333D0,  0, 50, 21,  0,  0,  0,
52045      & 329,0.667D0,  0, 34, 38,  0,  0,  0,
52046      & 329,0.333D0,  0, 42, 21,  0,  0,  0,
52047      & 330,0.667D0,  0, 42, 30,  0,  0,  0,
52048      & 330,0.333D0,  0, 34, 21,  0,  0,  0,
52049      & 331,0.667D0,  0,140, 38,  0,  0,  0,
52050      & 331,0.333D0,  0,136, 21,  0,  0,  0,
52051      & 332,0.667D0,  0,136, 30,  0,  0,  0,
52052      & 332,0.333D0,  0,140, 21,  0,  0,  0,
52053      & 333,0.500D0,  0,136, 50,  0,  0,  0,
52054      & 333,0.500D0,  0,140, 46,  0,  0,  0/
52055       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1920,1938)/
52056      & 334,0.667D0,  0,175, 30,  0,  0,  0,
52057      & 334,0.333D0,  0,171, 21,  0,  0,  0,
52058      & 335,0.667D0,  0,171, 38,  0,  0,  0,
52059      & 335,0.333D0,  0,175, 21,  0,  0,  0,
52060      & 336,0.500D0,  0,171, 42,  0,  0,  0,
52061      & 336,0.500D0,  0,175, 34,  0,  0,  0,
52062      & 337,0.667D0,  0,246, 30,  0,  0,  0,
52063      & 337,0.333D0,  0,245, 21,  0,  0,  0,
52064      & 338,0.667D0,  0,245, 38,  0,  0,  0,
52065      & 338,0.333D0,  0,246, 21,  0,  0,  0,
52066      & 339,0.500D0,  0,246, 34,  0,  0,  0,
52067      & 339,0.500D0,  0,245, 42,  0,  0,  0,
52068      & 340,1.000D0,  0,254, 59,  0,  0,  0,
52069      & 341,0.667D0,  0,222, 38,  0,  0,  0,
52070      & 341,0.333D0,  0,221, 21,  0,  0,  0,
52071      & 342,0.667D0,  0,221, 30,  0,  0,  0,
52072      & 342,0.333D0,  0,222, 21,  0,  0,  0,
52073      & 343,0.500D0,  0,222, 46,  0,  0,  0,
52074      & 343,0.500D0,  0,221, 50,  0,  0,  0/
52075       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1939,1957)/
52076      & 344,1.000D0,  0,230, 59,  0,  0,  0,
52077      & 345,1.000D0,  0,225, 30,  0,  0,  0,
52078      & 346,1.000D0,  0,225, 21,  0,  0,  0,
52079      & 347,1.000D0,  0,225, 21,  0,  0,  0,
52080      & 348,1.000D0,  0,225, 38,  0,  0,  0,
52081      & 349,0.600D0,  0,228, 38,  0,  0,  0,
52082      & 349,0.300D0,  0,227, 21,  0,  0,  0,
52083      & 349,0.100D0,  0,227, 59,  0,  0,  0,
52084      & 350,0.600D0,  0,228, 38,  0,  0,  0,
52085      & 350,0.300D0,  0,227, 21,  0,  0,  0,
52086      & 350,0.100D0,  0,227, 59,  0,  0,  0,
52087      & 351,0.600D0,  0,227, 30,  0,  0,  0,
52088      & 351,0.300D0,  0,228, 21,  0,  0,  0,
52089      & 351,0.100D0,  0,228, 59,  0,  0,  0,
52090      & 352,0.600D0,  0,227, 30,  0,  0,  0,
52091      & 352,0.300D0,  0,228, 21,  0,  0,  0,
52092      & 352,0.100D0,  0,228, 59,  0,  0,  0,
52093      & 353,1.000D0,  0,229, 59,  0,  0,  0,
52094      & 354,1.000D0,  0,249, 38,  0,  0,  0/
52095       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1958,1976)/
52096      & 355,1.000D0,  0,249, 21,  0,  0,  0,
52097      & 356,1.000D0,  0,249, 21,  0,  0,  0,
52098      & 357,1.000D0,  0,249, 30,  0,  0,  0,
52099      & 358,0.600D0,  0,252, 30,  0,  0,  0,
52100      & 358,0.300D0,  0,251, 21,  0,  0,  0,
52101      & 358,0.100D0,  0,251, 59,  0,  0,  0,
52102      & 359,0.600D0,  0,252, 30,  0,  0,  0,
52103      & 359,0.300D0,  0,251, 21,  0,  0,  0,
52104      & 359,0.100D0,  0,251, 59,  0,  0,  0,
52105      & 360,0.600D0,  0,251, 38,  0,  0,  0,
52106      & 360,0.300D0,  0,252, 21,  0,  0,  0,
52107      & 360,0.100D0,  0,252, 59,  0,  0,  0,
52108      & 361,0.600D0,  0,251, 38,  0,  0,  0,
52109      & 361,0.300D0,  0,252, 21,  0,  0,  0,
52110      & 361,0.100D0,  0,252, 59,  0,  0,  0,
52111      & 362,1.000D0,  0,253, 59,  0,  0,  0,
52112      & 363,0.400D0,  0, 53, 38,  0,  0,  0,
52113      & 363,0.200D0,  0, 49, 21,  0,  0,  0,
52114      & 363,0.100D0,  0, 51, 38,  0,  0,  0/
52115       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1977,1995)/
52116      & 363,0.050D0,  0, 47, 21,  0,  0,  0,
52117      & 363,0.150D0,  0, 46, 26,  0,  0,  0,
52118      & 363,0.050D0,  0, 46, 56,  0,  0,  0,
52119      & 363,0.050D0,  0, 46, 24,  0,  0,  0,
52120      & 364,0.400D0,  0, 49, 30,  0,  0,  0,
52121      & 364,0.200D0,  0, 53, 21,  0,  0,  0,
52122      & 364,0.100D0,  0, 47, 30,  0,  0,  0,
52123      & 364,0.050D0,  0, 51, 21,  0,  0,  0,
52124      & 364,0.150D0,  0, 50, 26,  0,  0,  0,
52125      & 364,0.050D0,  0, 50, 56,  0,  0,  0,
52126      & 364,0.050D0,  0, 50, 24,  0,  0,  0,
52127      & 365,0.400D0,  0, 37, 38,  0,  0,  0,
52128      & 365,0.200D0,  0, 45, 21,  0,  0,  0,
52129      & 365,0.100D0,  0, 35, 38,  0,  0,  0,
52130      & 365,0.050D0,  0, 43, 21,  0,  0,  0,
52131      & 365,0.150D0,  0, 42, 26,  0,  0,  0,
52132      & 365,0.050D0,  0, 42, 56,  0,  0,  0,
52133      & 365,0.050D0,  0, 42, 24,  0,  0,  0,
52134      & 366,0.400D0,  0, 45, 30,  0,  0,  0/
52135       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1996,2014)/
52136      & 366,0.200D0,  0, 37, 21,  0,  0,  0,
52137      & 366,0.100D0,  0, 43, 30,  0,  0,  0,
52138      & 366,0.050D0,  0, 35, 21,  0,  0,  0,
52139      & 366,0.150D0,  0, 34, 26,  0,  0,  0,
52140      & 366,0.050D0,  0, 34, 56,  0,  0,  0,
52141      & 366,0.050D0,  0, 34, 24,  0,  0,  0,
52142      & 367,0.258D0,  0, 50, 38,  0,  0,  0,
52143      & 367,0.129D0,  0, 46, 21,  0,  0,  0,
52144      & 367,0.209D0,  0, 50, 39,  0,  0,  0,
52145      & 367,0.105D0,  0, 46, 23,  0,  0,  0,
52146      & 367,0.199D0,  0, 51, 38,  0,  0,  0,
52147      & 367,0.100D0,  0, 47, 21,  0,  0,  0,
52148      & 368,0.258D0,  0, 46, 30,  0,  0,  0,
52149      & 368,0.129D0,  0, 50, 21,  0,  0,  0,
52150      & 368,0.209D0,  0, 46, 31,  0,  0,  0,
52151      & 368,0.105D0,  0, 50, 23,  0,  0,  0,
52152      & 368,0.199D0,  0, 47, 30,  0,  0,  0,
52153      & 368,0.100D0,  0, 51, 21,  0,  0,  0,
52154      & 369,0.258D0,  0, 34, 38,  0,  0,  0/
52155       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2015,2033)/
52156      & 369,0.129D0,  0, 42, 21,  0,  0,  0,
52157      & 369,0.209D0,  0, 34, 39,  0,  0,  0,
52158      & 369,0.105D0,  0, 42, 23,  0,  0,  0,
52159      & 369,0.199D0,  0, 35, 38,  0,  0,  0,
52160      & 369,0.100D0,  0, 43, 21,  0,  0,  0,
52161      & 370,0.258D0,  0, 42, 30,  0,  0,  0,
52162      & 370,0.129D0,  0, 34, 21,  0,  0,  0,
52163      & 370,0.209D0,  0, 42, 31,  0,  0,  0,
52164      & 370,0.105D0,  0, 34, 23,  0,  0,  0,
52165      & 370,0.199D0,  0, 43, 30,  0,  0,  0,
52166      & 370,0.100D0,  0, 35, 21,  0,  0,  0,
52167      & 371,0.400D0,  0, 53, 38,  0,  0,  0,
52168      & 371,0.200D0,  0, 49, 21,  0,  0,  0,
52169      & 371,0.100D0,  0, 51, 38,  0,  0,  0,
52170      & 371,0.050D0,  0, 47, 21,  0,  0,  0,
52171      & 371,0.150D0,  0, 46, 26,  0,  0,  0,
52172      & 371,0.050D0,  0, 46, 56,  0,  0,  0,
52173      & 371,0.050D0,  0, 46, 24,  0,  0,  0,
52174      & 372,0.400D0,  0, 49, 30,  0,  0,  0/
52175       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2034,2052)/
52176      & 372,0.200D0,  0, 53, 21,  0,  0,  0,
52177      & 372,0.100D0,  0, 47, 30,  0,  0,  0,
52178      & 372,0.050D0,  0, 51, 21,  0,  0,  0,
52179      & 372,0.150D0,  0, 50, 26,  0,  0,  0,
52180      & 372,0.050D0,  0, 50, 56,  0,  0,  0,
52181      & 372,0.050D0,  0, 50, 24,  0,  0,  0,
52182      & 373,0.400D0,  0, 37, 38,  0,  0,  0,
52183      & 373,0.200D0,  0, 45, 21,  0,  0,  0,
52184      & 373,0.100D0,  0, 35, 38,  0,  0,  0,
52185      & 373,0.050D0,  0, 43, 21,  0,  0,  0,
52186      & 373,0.150D0,  0, 42, 26,  0,  0,  0,
52187      & 373,0.050D0,  0, 42, 56,  0,  0,  0,
52188      & 373,0.050D0,  0, 42, 24,  0,  0,  0,
52189      & 374,0.400D0,  0, 45, 30,  0,  0,  0,
52190      & 374,0.200D0,  0, 37, 21,  0,  0,  0,
52191      & 374,0.100D0,  0, 43, 30,  0,  0,  0,
52192      & 374,0.050D0,  0, 35, 21,  0,  0,  0,
52193      & 374,0.150D0,  0, 34, 26,  0,  0,  0,
52194      & 374,0.050D0,  0, 34, 56,  0,  0,  0/
52195       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2053,2071)/
52196      & 374,0.050D0,  0, 34, 24,  0,  0,  0,
52197      & 375,0.208D0,  0, 50, 39,  0,  0,  0,
52198      & 375,0.104D0,  0, 46, 23,  0,  0,  0,
52199      & 375,0.134D0,  0, 51, 38,  0,  0,  0,
52200      & 375,0.067D0,  0, 47, 21,  0,  0,  0,
52201      & 375,0.124D0,  0, 50, 38,  0,  0,  0,
52202      & 375,0.062D0,  0, 46, 21,  0,  0,  0,
52203      & 375,0.301D0,  0, 46, 22,  0,  0,  0,
52204      & 376,0.208D0,  0, 46, 31,  0,  0,  0,
52205      & 376,0.104D0,  0, 50, 23,  0,  0,  0,
52206      & 376,0.134D0,  0, 47, 30,  0,  0,  0,
52207      & 376,0.067D0,  0, 51, 21,  0,  0,  0,
52208      & 376,0.124D0,  0, 46, 30,  0,  0,  0,
52209      & 376,0.062D0,  0, 50, 21,  0,  0,  0,
52210      & 376,0.301D0,  0, 50, 22,  0,  0,  0,
52211      & 377,0.208D0,  0, 34, 39,  0,  0,  0,
52212      & 377,0.104D0,  0, 42, 23,  0,  0,  0,
52213      & 377,0.134D0,  0, 35, 38,  0,  0,  0,
52214      & 377,0.067D0,  0, 43, 21,  0,  0,  0/
52215       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2072,2090)/
52216      & 377,0.124D0,  0, 34, 38,  0,  0,  0,
52217      & 377,0.062D0,  0, 42, 21,  0,  0,  0,
52218      & 377,0.301D0,  0, 42, 22,  0,  0,  0,
52219      & 378,0.208D0,  0, 42, 31,  0,  0,  0,
52220      & 378,0.104D0,  0, 34, 23,  0,  0,  0,
52221      & 378,0.134D0,  0, 43, 30,  0,  0,  0,
52222      & 378,0.067D0,  0, 35, 21,  0,  0,  0,
52223      & 378,0.124D0,  0, 42, 30,  0,  0,  0,
52224      & 378,0.062D0,  0, 34, 21,  0,  0,  0,
52225      & 378,0.301D0,  0, 34, 22,  0,  0,  0,
52226      & 379,0.562D0,  0, 26, 38,  0,  0,  0,
52227      & 379,0.155D0,  0, 39, 21,  0,  0,  0,
52228      & 379,0.155D0,  0, 23, 38,  0,  0,  0,
52229      & 379,0.088D0,  0,293, 38,  0,  0,  0,
52230      & 379,0.020D0,  0, 46, 43,  0,  0,  0,
52231      & 379,0.020D0,  0, 42, 47,  0,  0,  0,
52232      & 380,0.562D0,  0, 26, 21,  0,  0,  0,
52233      & 380,0.155D0,  0, 39, 30,  0,  0,  0,
52234      & 380,0.155D0,  0, 31, 38,  0,  0,  0/
52235       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2091,2109)/
52236      & 380,0.088D0,  0,293, 21,  0,  0,  0,
52237      & 380,0.010D0,  0, 46, 35,  0,  0,  0,
52238      & 380,0.010D0,  0, 50, 43,  0,  0,  0,
52239      & 380,0.010D0,  0, 34, 47,  0,  0,  0,
52240      & 380,0.010D0,  0, 42, 51,  0,  0,  0,
52241      & 381,0.562D0,  0, 26, 30,  0,  0,  0,
52242      & 381,0.155D0,  0, 31, 21,  0,  0,  0,
52243      & 381,0.155D0,  0, 23, 30,  0,  0,  0,
52244      & 381,0.088D0,  0,293, 30,  0,  0,  0,
52245      & 381,0.020D0,  0, 34, 51,  0,  0,  0,
52246      & 381,0.020D0,  0, 50, 35,  0,  0,  0,
52247      & 382,0.360D0,  0, 31, 38, 38,  0,  0,
52248      & 382,0.180D0,  0, 23, 38, 21,  0,  0,
52249      & 382,0.040D0,  0, 39, 21, 21,  0,  0,
52250      & 382,0.020D0,  0, 39, 38, 30,  0,  0,
52251      & 382,0.300D0,  0, 38, 21,  0,  0,  0,
52252      & 382,0.040D0,  0, 46, 43,  0,  0,  0,
52253      & 382,0.040D0,  0, 42, 47,  0,  0,  0,
52254      & 382,0.020D0,  0, 22, 39,  0,  0,  0/
52255       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2110,2128)/
52256      & 383,0.180D0,  0, 39, 30, 21,  0,  0,
52257      & 383,0.180D0,  0, 31, 38, 21,  0,  0,
52258      & 383,0.160D0,  0, 23, 21, 21,  0,  0,
52259      & 383,0.080D0,  0, 23, 38, 30,  0,  0,
52260      & 383,0.300D0,  0, 38, 30,  0,  0,  0,
52261      & 383,0.020D0,  0, 46, 35,  0,  0,  0,
52262      & 383,0.020D0,  0, 50, 43,  0,  0,  0,
52263      & 383,0.020D0,  0, 34, 47,  0,  0,  0,
52264      & 383,0.020D0,  0, 42, 51,  0,  0,  0,
52265      & 383,0.020D0,  0, 22, 23,  0,  0,  0,
52266      & 384,0.360D0,  0, 39, 30, 30,  0,  0,
52267      & 384,0.180D0,  0, 23, 30, 21,  0,  0,
52268      & 384,0.040D0,  0, 31, 21, 21,  0,  0,
52269      & 384,0.020D0,  0, 31, 30, 38,  0,  0,
52270      & 384,0.300D0,  0, 30, 21,  0,  0,  0,
52271      & 384,0.040D0,  0, 34, 51,  0,  0,  0,
52272      & 384,0.040D0,  0, 50, 35,  0,  0,  0,
52273      & 384,0.020D0,  0, 22, 31,  0,  0,  0,
52274      & 385,0.184D0,  0, 41, 21,  0,  0,  0/
52275       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2129,2147)/
52276      & 385,0.184D0,  0, 29, 38,  0,  0,  0,
52277      & 385,0.184D0,  0, 39, 23,  0,  0,  0,
52278      & 385,0.236D0,  0, 38, 21,  0,  0,  0,
52279      & 385,0.160D0,  0, 24, 38,  0,  0,  0,
52280      & 385,0.018D0,  0, 46, 43,  0,  0,  0,
52281      & 385,0.018D0,  0, 42, 47,  0,  0,  0,
52282      & 385,0.016D0,  0, 46, 42,  0,  0,  0,
52283      & 386,0.184D0,  0, 41, 30,  0,  0,  0,
52284      & 386,0.184D0,  0, 33, 38,  0,  0,  0,
52285      & 386,0.184D0,  0, 39, 31,  0,  0,  0,
52286      & 386,0.236D0,  0, 38, 30,  0,  0,  0,
52287      & 386,0.160D0,  0, 24, 21,  0,  0,  0,
52288      & 386,0.009D0,  0, 46, 35,  0,  0,  0,
52289      & 386,0.009D0,  0, 50, 43,  0,  0,  0,
52290      & 386,0.009D0,  0, 34, 47,  0,  0,  0,
52291      & 386,0.009D0,  0, 42, 51,  0,  0,  0,
52292      & 386,0.008D0,  0, 46, 34,  0,  0,  0,
52293      & 386,0.008D0,  0, 42, 50,  0,  0,  0,
52294      & 387,0.184D0,  0, 33, 21,  0,  0,  0/
52295       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2148,2166)/
52296      & 387,0.184D0,  0, 29, 30,  0,  0,  0,
52297      & 387,0.184D0,  0, 31, 23,  0,  0,  0,
52298      & 387,0.236D0,  0, 30, 21,  0,  0,  0,
52299      & 387,0.160D0,  0, 24, 30,  0,  0,  0,
52300      & 387,0.018D0,  0, 34, 51,  0,  0,  0,
52301      & 387,0.018D0,  0, 50, 35,  0,  0,  0,
52302      & 387,0.016D0,  0, 34, 50,  0,  0,  0,
52303      & 388,0.183D0,  0,231, 38, 30,  0,  0,
52304      & 388,0.091D0,  0,231, 21, 21,  0,  0,
52305      & 388,0.067D0,  0, 59,307,  0,  0,  0,
52306      & 388,0.066D0,  0, 59,308,  0,  0,  0,
52307      & 388,0.043D0,  0, 59,309,  0,  0,  0,
52308      & 388,0.446D0,130, 13, 13, 13,  0,  0,
52309      & 388,0.023D0,130, 13, 13, 59,  0,  0,
52310      & 388,0.013D0,  0,121,127,  0,  0,  0,
52311      & 388,0.013D0,  0,123,129,  0,  0,  0,
52312      & 388,0.013D0,  0,125,131,  0,  0,  0,
52313      & 388,0.004D0,  0,  1,  7,  0,  0,  0,
52314      & 388,0.017D0,  0,  2,  8,  0,  0,  0/
52315       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2167,2185)/
52316      & 388,0.004D0,  0,  3,  9,  0,  0,  0,
52317      & 388,0.017D0,  0,  4, 10,  0,  0,  0,
52318      & 389,0.046D0,  0, 59,388,  0,  0,  0,
52319      & 389,0.009D0,  0, 59,231,  0,  0,  0,
52320      & 389,0.755D0,  0, 13, 13,  0,  0,  0,
52321      & 389,0.030D0,  0,121,127,  0,  0,  0,
52322      & 389,0.030D0,  0,123,129,  0,  0,  0,
52323      & 389,0.030D0,  0,125,131,  0,  0,  0,
52324      & 389,0.010D0,  0,  1,  7,  0,  0,  0,
52325      & 389,0.040D0,  0,  2,  8,  0,  0,  0,
52326      & 389,0.010D0,  0,  3,  9,  0,  0,  0,
52327      & 389,0.040D0,  0,  4, 10,  0,  0,  0,
52328      & 390,0.210D0,  0, 59,388,  0,  0,  0,
52329      & 390,0.085D0,  0, 59,231,  0,  0,  0,
52330      & 390,0.565D0,  0, 13, 13,  0,  0,  0,
52331      & 390,0.022D0,  0,121,127,  0,  0,  0,
52332      & 390,0.022D0,  0,123,129,  0,  0,  0,
52333      & 390,0.022D0,  0,125,131,  0,  0,  0,
52334      & 390,0.007D0,  0,  1,  7,  0,  0,  0/
52335       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2186,2204)/
52336      & 390,0.030D0,  0,  2,  8,  0,  0,  0,
52337      & 390,0.007D0,  0,  3,  9,  0,  0,  0,
52338      & 390,0.030D0,  0,  4, 10,  0,  0,  0,
52339      & 391,0.162D0,  0, 59,388,  0,  0,  0,
52340      & 391,0.071D0,  0, 59,231,  0,  0,  0,
52341      & 391,0.615D0,  0, 13, 13,  0,  0,  0,
52342      & 391,0.024D0,  0,121,127,  0,  0,  0,
52343      & 391,0.024D0,  0,123,129,  0,  0,  0,
52344      & 391,0.024D0,  0,125,131,  0,  0,  0,
52345      & 391,0.008D0,  0,  1,  7,  0,  0,  0,
52346      & 391,0.032D0,  0,  2,  8,  0,  0,  0,
52347      & 391,0.008D0,  0,  3,  9,  0,  0,  0,
52348      & 391,0.032D0,  0,  4, 10,  0,  0,  0,
52349      & 392,0.034D0,  0,267, 38, 30,  0,  0,
52350      & 392,0.017D0,  0,267, 21, 21,  0,  0,
52351      & 392,0.044D0,  0,231, 38, 30,  0,  0,
52352      & 392,0.022D0,  0,231, 21, 21,  0,  0,
52353      & 392,0.050D0,  0,267, 59, 59,  0,  0,
52354      & 392,0.114D0,  0, 59,389,  0,  0,  0/
52355       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2205,2223)/
52356      & 392,0.113D0,  0, 59,390,  0,  0,  0,
52357      & 392,0.054D0,  0, 59,391,  0,  0,  0,
52358      & 392,0.403D0,130, 13, 13, 13,  0,  0,
52359      & 392,0.021D0,130, 13, 13, 59,  0,  0,
52360      & 392,0.020D0,  0,121,127,  0,  0,  0,
52361      & 392,0.020D0,  0,123,129,  0,  0,  0,
52362      & 392,0.020D0,  0,125,131,  0,  0,  0,
52363      & 392,0.007D0,  0,  1,  7,  0,  0,  0,
52364      & 392,0.027D0,  0,  2,  8,  0,  0,  0,
52365      & 392,0.007D0,  0,  3,  9,  0,  0,  0,
52366      & 392,0.027D0,  0,  4, 10,  0,  0,  0,
52367      & 393,0.250D0,  0,246,222,  0,  0,  0,
52368      & 393,0.250D0,  0,245,221,  0,  0,  0,
52369      & 393,0.385D0,130, 13, 13, 13,  0,  0,
52370      & 393,0.020D0,130, 13, 13, 59,  0,  0,
52371      & 393,0.015D0,  0,121,127,  0,  0,  0,
52372      & 393,0.015D0,  0,123,129,  0,  0,  0,
52373      & 393,0.015D0,  0,125,131,  0,  0,  0,
52374      & 393,0.005D0,  0,  1,  7,  0,  0,  0/
52375       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2224,2242)/
52376      & 393,0.020D0,  0,  2,  8,  0,  0,  0,
52377      & 393,0.005D0,  0,  3,  9,  0,  0,  0,
52378      & 393,0.020D0,  0,  4, 10,  0,  0,  0,
52379      & 395,0.195D0,  0, 39, 30,  0,  0,  0,
52380      & 395,0.195D0,  0, 23, 21,  0,  0,  0,
52381      & 395,0.195D0,  0, 31, 38,  0,  0,  0,
52382      & 395,0.105D0,  0,286, 30,  0,  0,  0,
52383      & 395,0.105D0,  0,285, 21,  0,  0,  0,
52384      & 395,0.105D0,  0,287, 38,  0,  0,  0,
52385      & 395,0.065D0,  0, 24, 38, 30,  0,  0,
52386      & 395,0.035D0,  0, 24, 21, 21,  0,  0,
52387      & 396,0.320D0,  0, 46, 34,  0,  0,  0,
52388      & 396,0.320D0,  0, 60, 61,  0,  0,  0,
52389      & 396,0.090D0,  0, 46, 35,  0,  0,  0,
52390      & 396,0.090D0,  0, 42, 51,  0,  0,  0,
52391      & 396,0.090D0,  0, 50, 43,  0,  0,  0,
52392      & 396,0.090D0,  0, 34, 47,  0,  0,  0,
52393      & 397,0.312D0,  0, 41, 30,  0,  0,  0,
52394      & 397,0.312D0,  0, 29, 21,  0,  0,  0/
52395       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2243,2261)/
52396      & 397,0.312D0,  0, 33, 38,  0,  0,  0,
52397      & 397,0.016D0,  0, 46, 35,  0,  0,  0,
52398      & 397,0.016D0,  0, 42, 51,  0,  0,  0,
52399      & 397,0.016D0,  0, 50, 43,  0,  0,  0,
52400      & 397,0.016D0,  0, 34, 47,  0,  0,  0,
52401      & 398,0.805D0,  0, 26, 22,  0,  0,  0,
52402      & 398,0.065D0,  0, 41, 30,  0,  0,  0,
52403      & 398,0.065D0,  0, 29, 21,  0,  0,  0,
52404      & 398,0.065D0,  0, 33, 38,  0,  0,  0,
52405      & 399,0.667D0,  0, 24, 38, 30,  0,  0,
52406      & 399,0.333D0,  0, 24, 21, 21,  0,  0,
52407      &  62,0.440D0,  0, 21, 22,  0,  0,  0,
52408      &  62,0.160D0,  0, 21, 25,  0,  0,  0,
52409      &  62,0.200D0,  0, 50, 42,  0,  0,  0,
52410      &  62,0.200D0,  0, 46, 34,  0,  0,  0,
52411      &  63,0.440D0,  0, 38, 22,  0,  0,  0,
52412      &  63,0.160D0,  0, 38, 25,  0,  0,  0,
52413      &  63,0.400D0,  0, 46, 42,  0,  0,  0,
52414      &  64,0.440D0,  0, 30, 22,  0,  0,  0/
52415       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2262,2263)/
52416      &  64,0.160D0,  0, 30, 25,  0,  0,  0,
52417      &  64,0.400D0,  0, 50, 34,  0,  0,  0/
52418 C--data for MRST98 LO PDF's
52419       DATA (FMRS(1,1,I, 1),I=1,49)/
52420      &     0.01518D0,  0.01868D0,  0.02298D0,  0.02594D0,  0.02828D0,
52421      &     0.03023D0,  0.03724D0,  0.04592D0,  0.05197D0,  0.05679D0,
52422      &     0.06085D0,  0.07576D0,  0.09547D0,  0.11035D0,  0.12307D0,
52423      &     0.13453D0,  0.15525D0,  0.18319D0,  0.22542D0,  0.26441D0,
52424      &     0.33553D0,  0.39881D0,  0.45451D0,  0.51363D0,  0.56120D0,
52425      &     0.59755D0,  0.62324D0,  0.63889D0,  0.64529D0,  0.64295D0,
52426      &     0.63335D0,  0.61691D0,  0.59464D0,  0.56748D0,  0.53621D0,
52427      &     0.50180D0,  0.46495D0,  0.42660D0,  0.38735D0,  0.34791D0,
52428      &     0.30888D0,  0.27105D0,  0.23455D0,  0.16807D0,  0.11197D0,
52429      &     0.06774D0,  0.03566D0,  0.00443D0,  0.00000D0/
52430       DATA (FMRS(1,1,I, 2),I=1,49)/
52431      &     0.01534D0,  0.01889D0,  0.02325D0,  0.02625D0,  0.02862D0,
52432      &     0.03061D0,  0.03771D0,  0.04653D0,  0.05268D0,  0.05757D0,
52433      &     0.06171D0,  0.07691D0,  0.09707D0,  0.11230D0,  0.12533D0,
52434      &     0.13708D0,  0.15827D0,  0.18678D0,  0.22968D0,  0.26907D0,
52435      &     0.34038D0,  0.40321D0,  0.45801D0,  0.51556D0,  0.56122D0,
52436      &     0.59551D0,  0.61905D0,  0.63261D0,  0.63699D0,  0.63286D0,
52437      &     0.62162D0,  0.60381D0,  0.58043D0,  0.55244D0,  0.52060D0,
52438      &     0.48591D0,  0.44902D0,  0.41090D0,  0.37213D0,  0.33332D0,
52439      &     0.29514D0,  0.25827D0,  0.22283D0,  0.15873D0,  0.10506D0,
52440      &     0.06310D0,  0.03294D0,  0.00399D0,  0.00000D0/
52441       DATA (FMRS(1,1,I, 3),I=1,49)/
52442      &     0.01559D0,  0.01920D0,  0.02365D0,  0.02672D0,  0.02914D0,
52443      &     0.03116D0,  0.03842D0,  0.04744D0,  0.05374D0,  0.05876D0,
52444      &     0.06301D0,  0.07866D0,  0.09949D0,  0.11525D0,  0.12874D0,
52445      &     0.14090D0,  0.16278D0,  0.19212D0,  0.23598D0,  0.27589D0,
52446      &     0.34735D0,  0.40941D0,  0.46279D0,  0.51792D0,  0.56073D0,
52447      &     0.59195D0,  0.61237D0,  0.62289D0,  0.62439D0,  0.61773D0,
52448      &     0.60419D0,  0.58448D0,  0.55962D0,  0.53052D0,  0.49799D0,
52449      &     0.46298D0,  0.42617D0,  0.38844D0,  0.35048D0,  0.31268D0,
52450      &     0.27573D0,  0.24031D0,  0.20643D0,  0.14575D0,  0.09554D0,
52451      &     0.05679D0,  0.02927D0,  0.00342D0,  0.00000D0/
52452       DATA (FMRS(1,1,I, 4),I=1,49)/
52453      &     0.01577D0,  0.01944D0,  0.02395D0,  0.02707D0,  0.02952D0,
52454      &     0.03158D0,  0.03895D0,  0.04812D0,  0.05453D0,  0.05964D0,
52455      &     0.06398D0,  0.07996D0,  0.10128D0,  0.11743D0,  0.13126D0,
52456      &     0.14371D0,  0.16610D0,  0.19602D0,  0.24052D0,  0.28078D0,
52457      &     0.35225D0,  0.41367D0,  0.46596D0,  0.51926D0,  0.56000D0,
52458      &     0.58897D0,  0.60716D0,  0.61554D0,  0.61505D0,  0.60661D0,
52459      &     0.59150D0,  0.57049D0,  0.54465D0,  0.51484D0,  0.48194D0,
52460      &     0.44680D0,  0.41012D0,  0.37271D0,  0.33536D0,  0.29833D0,
52461      &     0.26227D0,  0.22791D0,  0.19519D0,  0.13692D0,  0.08913D0,
52462      &     0.05257D0,  0.02685D0,  0.00306D0,  0.00000D0/
52463       DATA (FMRS(1,1,I, 5),I=1,49)/
52464      &     0.01597D0,  0.01969D0,  0.02427D0,  0.02744D0,  0.02993D0,
52465      &     0.03202D0,  0.03952D0,  0.04885D0,  0.05537D0,  0.06058D0,
52466      &     0.06501D0,  0.08134D0,  0.10319D0,  0.11975D0,  0.13393D0,
52467      &     0.14669D0,  0.16958D0,  0.20009D0,  0.24521D0,  0.28578D0,
52468      &     0.35715D0,  0.41781D0,  0.46887D0,  0.52022D0,  0.55877D0,
52469      &     0.58539D0,  0.60126D0,  0.60744D0,  0.60489D0,  0.59469D0,
52470      &     0.57807D0,  0.55581D0,  0.52903D0,  0.49861D0,  0.46535D0,
52471      &     0.43012D0,  0.39368D0,  0.35672D0,  0.32002D0,  0.28380D0,
52472      &     0.24878D0,  0.21549D0,  0.18398D0,  0.12819D0,  0.08284D0,
52473      &     0.04845D0,  0.02451D0,  0.00272D0,  0.00000D0/
52474       DATA (FMRS(1,1,I, 6),I=1,49)/
52475      &     0.01613D0,  0.01990D0,  0.02455D0,  0.02776D0,  0.03029D0,
52476      &     0.03241D0,  0.04001D0,  0.04949D0,  0.05611D0,  0.06141D0,
52477      &     0.06592D0,  0.08256D0,  0.10485D0,  0.12178D0,  0.13626D0,
52478      &     0.14927D0,  0.17260D0,  0.20361D0,  0.24924D0,  0.29005D0,
52479      &     0.36128D0,  0.42124D0,  0.47121D0,  0.52086D0,  0.55750D0,
52480      &     0.58213D0,  0.59603D0,  0.60035D0,  0.59612D0,  0.58445D0,
52481      &     0.56659D0,  0.54334D0,  0.51581D0,  0.48493D0,  0.45142D0,
52482      &     0.41618D0,  0.37998D0,  0.34345D0,  0.30732D0,  0.27182D0,
52483      &     0.23768D0,  0.20532D0,  0.17482D0,  0.12110D0,  0.07777D0,
52484      &     0.04515D0,  0.02267D0,  0.00245D0,  0.00000D0/
52485       DATA (FMRS(1,1,I, 7),I=1,49)/
52486      &     0.01630D0,  0.02011D0,  0.02482D0,  0.02807D0,  0.03063D0,
52487      &     0.03278D0,  0.04049D0,  0.05010D0,  0.05683D0,  0.06221D0,
52488      &     0.06680D0,  0.08373D0,  0.10647D0,  0.12373D0,  0.13849D0,
52489      &     0.15175D0,  0.17549D0,  0.20695D0,  0.25304D0,  0.29403D0,
52490      &     0.36506D0,  0.42430D0,  0.47319D0,  0.52118D0,  0.55597D0,
52491      &     0.57870D0,  0.59079D0,  0.59337D0,  0.58760D0,  0.57458D0,
52492      &     0.55556D0,  0.53145D0,  0.50329D0,  0.47196D0,  0.43832D0,
52493      &     0.40316D0,  0.36719D0,  0.33110D0,  0.29555D0,  0.26076D0,
52494      &     0.22742D0,  0.19600D0,  0.16642D0,  0.11467D0,  0.07318D0,
52495      &     0.04221D0,  0.02103D0,  0.00223D0,  0.00000D0/
52496       DATA (FMRS(1,1,I, 8),I=1,49)/
52497      &     0.01647D0,  0.02033D0,  0.02511D0,  0.02840D0,  0.03100D0,
52498      &     0.03318D0,  0.04101D0,  0.05076D0,  0.05760D0,  0.06307D0,
52499      &     0.06774D0,  0.08499D0,  0.10819D0,  0.12581D0,  0.14088D0,
52500      &     0.15440D0,  0.17856D0,  0.21047D0,  0.25702D0,  0.29817D0,
52501      &     0.36893D0,  0.42735D0,  0.47507D0,  0.52128D0,  0.55411D0,
52502      &     0.57487D0,  0.58505D0,  0.58586D0,  0.57850D0,  0.56412D0,
52503      &     0.54397D0,  0.51898D0,  0.49021D0,  0.45851D0,  0.42474D0,
52504      &     0.38970D0,  0.35404D0,  0.31842D0,  0.28351D0,  0.24949D0,
52505      &     0.21700D0,  0.18654D0,  0.15795D0,  0.10821D0,  0.06861D0,
52506      &     0.03930D0,  0.01942D0,  0.00201D0,  0.00000D0/
52507       DATA (FMRS(1,1,I, 9),I=1,49)/
52508      &     0.01662D0,  0.02053D0,  0.02536D0,  0.02869D0,  0.03133D0,
52509      &     0.03353D0,  0.04146D0,  0.05135D0,  0.05828D0,  0.06382D0,
52510      &     0.06856D0,  0.08610D0,  0.10971D0,  0.12764D0,  0.14296D0,
52511      &     0.15670D0,  0.18121D0,  0.21352D0,  0.26045D0,  0.30172D0,
52512      &     0.37220D0,  0.42986D0,  0.47655D0,  0.52120D0,  0.55234D0,
52513      &     0.57141D0,  0.57995D0,  0.57927D0,  0.57058D0,  0.55506D0,
52514      &     0.53402D0,  0.50830D0,  0.47904D0,  0.44709D0,  0.41323D0,
52515      &     0.37832D0,  0.34296D0,  0.30776D0,  0.27344D0,  0.24008D0,
52516      &     0.20833D0,  0.17868D0,  0.15093D0,  0.10287D0,  0.06487D0,
52517      &     0.03693D0,  0.01812D0,  0.00183D0,  0.00000D0/
52518       DATA (FMRS(1,1,I,10),I=1,49)/
52519      &     0.01676D0,  0.02072D0,  0.02560D0,  0.02898D0,  0.03164D0,
52520      &     0.03388D0,  0.04190D0,  0.05191D0,  0.05894D0,  0.06456D0,
52521      &     0.06937D0,  0.08718D0,  0.11117D0,  0.12940D0,  0.14497D0,
52522      &     0.15892D0,  0.18377D0,  0.21643D0,  0.26368D0,  0.30503D0,
52523      &     0.37520D0,  0.43209D0,  0.47774D0,  0.52089D0,  0.55041D0,
52524      &     0.56787D0,  0.57486D0,  0.57280D0,  0.56285D0,  0.54631D0,
52525      &     0.52442D0,  0.49810D0,  0.46842D0,  0.43624D0,  0.40236D0,
52526      &     0.36762D0,  0.33255D0,  0.29778D0,  0.26402D0,  0.23132D0,
52527      &     0.20029D0,  0.17139D0,  0.14445D0,  0.09798D0,  0.06147D0,
52528      &     0.03479D0,  0.01695D0,  0.00168D0,  0.00000D0/
52529       DATA (FMRS(1,1,I,11),I=1,49)/
52530      &     0.01688D0,  0.02087D0,  0.02580D0,  0.02920D0,  0.03189D0,
52531      &     0.03415D0,  0.04225D0,  0.05236D0,  0.05946D0,  0.06515D0,
52532      &     0.07001D0,  0.08804D0,  0.11234D0,  0.13081D0,  0.14657D0,
52533      &     0.16068D0,  0.18579D0,  0.21873D0,  0.26622D0,  0.30762D0,
52534      &     0.37751D0,  0.43378D0,  0.47859D0,  0.52054D0,  0.54880D0,
52535      &     0.56500D0,  0.57079D0,  0.56765D0,  0.55675D0,  0.53942D0,
52536      &     0.51689D0,  0.49012D0,  0.46015D0,  0.42782D0,  0.39393D0,
52537      &     0.35936D0,  0.32453D0,  0.29009D0,  0.25678D0,  0.22461D0,
52538      &     0.19416D0,  0.16583D0,  0.13951D0,  0.09427D0,  0.05892D0,
52539      &     0.03318D0,  0.01609D0,  0.00157D0,  0.00000D0/
52540       DATA (FMRS(1,1,I,12),I=1,49)/
52541      &     0.01713D0,  0.02119D0,  0.02622D0,  0.02969D0,  0.03243D0,
52542      &     0.03474D0,  0.04300D0,  0.05334D0,  0.06060D0,  0.06641D0,
52543      &     0.07140D0,  0.08989D0,  0.11485D0,  0.13381D0,  0.14997D0,
52544      &     0.16442D0,  0.19008D0,  0.22357D0,  0.27152D0,  0.31299D0,
52545      &     0.38219D0,  0.43708D0,  0.48008D0,  0.51946D0,  0.54505D0,
52546      &     0.55859D0,  0.56192D0,  0.55654D0,  0.54370D0,  0.52483D0,
52547      &     0.50100D0,  0.47335D0,  0.44283D0,  0.41025D0,  0.37649D0,
52548      &     0.34225D0,  0.30799D0,  0.27433D0,  0.24202D0,  0.21092D0,
52549      &     0.18167D0,  0.15459D0,  0.12954D0,  0.08683D0,  0.05380D0,
52550      &     0.03001D0,  0.01438D0,  0.00136D0,  0.00000D0/
52551       DATA (FMRS(1,1,I,13),I=1,49)/
52552      &     0.01734D0,  0.02147D0,  0.02658D0,  0.03011D0,  0.03290D0,
52553      &     0.03525D0,  0.04366D0,  0.05419D0,  0.06158D0,  0.06752D0,
52554      &     0.07261D0,  0.09150D0,  0.11703D0,  0.13641D0,  0.15292D0,
52555      &     0.16765D0,  0.19375D0,  0.22769D0,  0.27599D0,  0.31747D0,
52556      &     0.38599D0,  0.43964D0,  0.48105D0,  0.51822D0,  0.54152D0,
52557      &     0.55284D0,  0.55412D0,  0.54689D0,  0.53251D0,  0.51240D0,
52558      &     0.48756D0,  0.45925D0,  0.42833D0,  0.39563D0,  0.36202D0,
52559      &     0.32809D0,  0.29438D0,  0.26143D0,  0.22998D0,  0.19977D0,
52560      &     0.17155D0,  0.14553D0,  0.12155D0,  0.08091D0,  0.04976D0,
52561      &     0.02753D0,  0.01306D0,  0.00120D0,  0.00000D0/
52562       DATA (FMRS(1,1,I,14),I=1,49)/
52563      &     0.01759D0,  0.02179D0,  0.02699D0,  0.03059D0,  0.03343D0,
52564      &     0.03582D0,  0.04441D0,  0.05515D0,  0.06270D0,  0.06876D0,
52565      &     0.07397D0,  0.09331D0,  0.11948D0,  0.13933D0,  0.15621D0,
52566      &     0.17125D0,  0.19782D0,  0.23224D0,  0.28086D0,  0.32228D0,
52567      &     0.38998D0,  0.44216D0,  0.48181D0,  0.51649D0,  0.53727D0,
52568      &     0.54619D0,  0.54525D0,  0.53606D0,  0.52007D0,  0.49864D0,
52569      &     0.47286D0,  0.44390D0,  0.41261D0,  0.37987D0,  0.34645D0,
52570      &     0.31295D0,  0.27985D0,  0.24773D0,  0.21718D0,  0.18802D0,
52571      &     0.16091D0,  0.13605D0,  0.11323D0,  0.07479D0,  0.04562D0,
52572      &     0.02500D0,  0.01174D0,  0.00105D0,  0.00000D0/
52573       DATA (FMRS(1,1,I,15),I=1,49)/
52574      &     0.01784D0,  0.02212D0,  0.02742D0,  0.03109D0,  0.03399D0,
52575      &     0.03643D0,  0.04519D0,  0.05616D0,  0.06388D0,  0.07007D0,
52576      &     0.07541D0,  0.09522D0,  0.12203D0,  0.14235D0,  0.15961D0,
52577      &     0.17496D0,  0.20199D0,  0.23684D0,  0.28574D0,  0.32703D0,
52578      &     0.39374D0,  0.44435D0,  0.48208D0,  0.51422D0,  0.53243D0,
52579      &     0.53888D0,  0.53581D0,  0.52470D0,  0.50714D0,  0.48444D0,
52580      &     0.45778D0,  0.42824D0,  0.39670D0,  0.36400D0,  0.33079D0,
52581      &     0.29784D0,  0.26546D0,  0.23422D0,  0.20462D0,  0.17657D0,
52582      &     0.15056D0,  0.12684D0,  0.10517D0,  0.06893D0,  0.04169D0,
52583      &     0.02264D0,  0.01051D0,  0.00091D0,  0.00000D0/
52584       DATA (FMRS(1,1,I,16),I=1,49)/
52585      &     0.01807D0,  0.02243D0,  0.02782D0,  0.03155D0,  0.03450D0,
52586      &     0.03698D0,  0.04591D0,  0.05708D0,  0.06495D0,  0.07127D0,
52587      &     0.07672D0,  0.09696D0,  0.12435D0,  0.14510D0,  0.16268D0,
52588      &     0.17830D0,  0.20573D0,  0.24094D0,  0.29002D0,  0.33115D0,
52589      &     0.39689D0,  0.44603D0,  0.48202D0,  0.51185D0,  0.52778D0,
52590      &     0.53213D0,  0.52713D0,  0.51440D0,  0.49550D0,  0.47182D0,
52591      &     0.44444D0,  0.41444D0,  0.38277D0,  0.35014D0,  0.31726D0,
52592      &     0.28479D0,  0.25306D0,  0.22258D0,  0.19389D0,  0.16682D0,
52593      &     0.14175D0,  0.11905D0,  0.09839D0,  0.06403D0,  0.03844D0,
52594      &     0.02069D0,  0.00951D0,  0.00080D0,  0.00000D0/
52595       DATA (FMRS(1,1,I,17),I=1,49)/
52596      &     0.01831D0,  0.02273D0,  0.02822D0,  0.03202D0,  0.03502D0,
52597      &     0.03755D0,  0.04663D0,  0.05802D0,  0.06604D0,  0.07249D0,
52598      &     0.07805D0,  0.09872D0,  0.12670D0,  0.14787D0,  0.16578D0,
52599      &     0.18165D0,  0.20947D0,  0.24500D0,  0.29423D0,  0.33515D0,
52600      &     0.39986D0,  0.44747D0,  0.48171D0,  0.50924D0,  0.52291D0,
52601      &     0.52522D0,  0.51836D0,  0.50409D0,  0.48395D0,  0.45934D0,
52602      &     0.43132D0,  0.40095D0,  0.36919D0,  0.33668D0,  0.30419D0,
52603      &     0.27223D0,  0.24118D0,  0.21147D0,  0.18368D0,  0.15756D0,
52604      &     0.13343D0,  0.11172D0,  0.09203D0,  0.05947D0,  0.03543D0,
52605      &     0.01891D0,  0.00861D0,  0.00070D0,  0.00000D0/
52606       DATA (FMRS(1,1,I,18),I=1,49)/
52607      &     0.01851D0,  0.02299D0,  0.02855D0,  0.03241D0,  0.03546D0,
52608      &     0.03802D0,  0.04724D0,  0.05881D0,  0.06696D0,  0.07351D0,
52609      &     0.07917D0,  0.10019D0,  0.12865D0,  0.15015D0,  0.16833D0,
52610      &     0.18440D0,  0.21252D0,  0.24831D0,  0.29761D0,  0.33832D0,
52611      &     0.40212D0,  0.44845D0,  0.48121D0,  0.50687D0,  0.51871D0,
52612      &     0.51934D0,  0.51104D0,  0.49556D0,  0.47446D0,  0.44911D0,
52613      &     0.42066D0,  0.39005D0,  0.35822D0,  0.32587D0,  0.29370D0,
52614      &     0.26224D0,  0.23174D0,  0.20270D0,  0.17561D0,  0.15023D0,
52615      &     0.12693D0,  0.10599D0,  0.08707D0,  0.05595D0,  0.03312D0,
52616      &     0.01756D0,  0.00793D0,  0.00063D0,  0.00000D0/
52617       DATA (FMRS(1,1,I,19),I=1,49)/
52618      &     0.01875D0,  0.02330D0,  0.02896D0,  0.03288D0,  0.03599D0,
52619      &     0.03859D0,  0.04798D0,  0.05977D0,  0.06807D0,  0.07475D0,
52620      &     0.08052D0,  0.10198D0,  0.13101D0,  0.15292D0,  0.17139D0,
52621      &     0.18771D0,  0.21617D0,  0.25222D0,  0.30155D0,  0.34198D0,
52622      &     0.40461D0,  0.44935D0,  0.48033D0,  0.50374D0,  0.51343D0,
52623      &     0.51210D0,  0.50212D0,  0.48526D0,  0.46307D0,  0.43693D0,
52624      &     0.40797D0,  0.37715D0,  0.34533D0,  0.31321D0,  0.28148D0,
52625      &     0.25058D0,  0.22080D0,  0.19255D0,  0.16635D0,  0.14187D0,
52626      &     0.11948D0,  0.09946D0,  0.08142D0,  0.05198D0,  0.03054D0,
52627      &     0.01606D0,  0.00718D0,  0.00056D0,  0.00000D0/
52628       DATA (FMRS(1,1,I,20),I=1,49)/
52629      &     0.01896D0,  0.02358D0,  0.02932D0,  0.03331D0,  0.03646D0,
52630      &     0.03911D0,  0.04864D0,  0.06062D0,  0.06906D0,  0.07585D0,
52631      &     0.08173D0,  0.10357D0,  0.13310D0,  0.15536D0,  0.17410D0,
52632      &     0.19062D0,  0.21937D0,  0.25563D0,  0.30495D0,  0.34510D0,
52633      &     0.40666D0,  0.44998D0,  0.47941D0,  0.50085D0,  0.50868D0,
52634      &     0.50571D0,  0.49430D0,  0.47628D0,  0.45320D0,  0.42642D0,
52635      &     0.39707D0,  0.36611D0,  0.33435D0,  0.30245D0,  0.27113D0,
52636      &     0.24074D0,  0.21159D0,  0.18404D0,  0.15862D0,  0.13491D0,
52637      &     0.11330D0,  0.09405D0,  0.07676D0,  0.04872D0,  0.02844D0,
52638      &     0.01484D0,  0.00658D0,  0.00050D0,  0.00000D0/
52639       DATA (FMRS(1,1,I,21),I=1,49)/
52640      &     0.01916D0,  0.02384D0,  0.02966D0,  0.03370D0,  0.03689D0,
52641      &     0.03958D0,  0.04926D0,  0.06141D0,  0.06998D0,  0.07687D0,
52642      &     0.08284D0,  0.10503D0,  0.13502D0,  0.15758D0,  0.17655D0,
52643      &     0.19325D0,  0.22223D0,  0.25866D0,  0.30794D0,  0.34779D0,
52644      &     0.40831D0,  0.45032D0,  0.47832D0,  0.49795D0,  0.50413D0,
52645      &     0.49968D0,  0.48705D0,  0.46802D0,  0.44417D0,  0.41690D0,
52646      &     0.38723D0,  0.35619D0,  0.32452D0,  0.29287D0,  0.26194D0,
52647      &     0.23205D0,  0.20344D0,  0.17655D0,  0.15180D0,  0.12880D0,
52648      &     0.10792D0,  0.08934D0,  0.07273D0,  0.04591D0,  0.02665D0,
52649      &     0.01381D0,  0.00607D0,  0.00045D0,  0.00000D0/
52650       DATA (FMRS(1,1,I,22),I=1,49)/
52651      &     0.01941D0,  0.02417D0,  0.03009D0,  0.03420D0,  0.03745D0,
52652      &     0.04018D0,  0.05003D0,  0.06241D0,  0.07114D0,  0.07817D0,
52653      &     0.08426D0,  0.10688D0,  0.13744D0,  0.16039D0,  0.17965D0,
52654      &     0.19656D0,  0.22582D0,  0.26244D0,  0.31163D0,  0.35107D0,
52655      &     0.41025D0,  0.45056D0,  0.47676D0,  0.49416D0,  0.49829D0,
52656      &     0.49204D0,  0.47792D0,  0.45768D0,  0.43295D0,  0.40511D0,
52657      &     0.37512D0,  0.34401D0,  0.31250D0,  0.28120D0,  0.25076D0,
52658      &     0.22150D0,  0.19361D0,  0.16754D0,  0.14361D0,  0.12149D0,
52659      &     0.10149D0,  0.08376D0,  0.06796D0,  0.04260D0,  0.02455D0,
52660      &     0.01262D0,  0.00549D0,  0.00039D0,  0.00000D0/
52661       DATA (FMRS(1,1,I,23),I=1,49)/
52662      &     0.01965D0,  0.02448D0,  0.03049D0,  0.03467D0,  0.03797D0,
52663      &     0.04075D0,  0.05077D0,  0.06336D0,  0.07225D0,  0.07940D0,
52664      &     0.08560D0,  0.10863D0,  0.13972D0,  0.16302D0,  0.18254D0,
52665      &     0.19964D0,  0.22916D0,  0.26592D0,  0.31498D0,  0.35400D0,
52666      &     0.41189D0,  0.45060D0,  0.47511D0,  0.49045D0,  0.49274D0,
52667      &     0.48487D0,  0.46938D0,  0.44808D0,  0.42260D0,  0.39428D0,
52668      &     0.36409D0,  0.33294D0,  0.30164D0,  0.27069D0,  0.24070D0,
52669      &     0.21203D0,  0.18488D0,  0.15951D0,  0.13633D0,  0.11502D0,
52670      &     0.09581D0,  0.07887D0,  0.06380D0,  0.03974D0,  0.02273D0,
52671      &     0.01159D0,  0.00500D0,  0.00035D0,  0.00000D0/
52672       DATA (FMRS(1,1,I,24),I=1,49)/
52673      &     0.01987D0,  0.02478D0,  0.03088D0,  0.03511D0,  0.03847D0,
52674      &     0.04129D0,  0.05147D0,  0.06426D0,  0.07329D0,  0.08055D0,
52675      &     0.08686D0,  0.11027D0,  0.14184D0,  0.16546D0,  0.18521D0,
52676      &     0.20248D0,  0.23220D0,  0.26906D0,  0.31795D0,  0.35654D0,
52677      &     0.41317D0,  0.45035D0,  0.47330D0,  0.48677D0,  0.48734D0,
52678      &     0.47799D0,  0.46135D0,  0.43917D0,  0.41301D0,  0.38430D0,
52679      &     0.35392D0,  0.32282D0,  0.29171D0,  0.26113D0,  0.23164D0,
52680      &     0.20355D0,  0.17701D0,  0.15231D0,  0.12990D0,  0.10928D0,
52681      &     0.09079D0,  0.07455D0,  0.06012D0,  0.03723D0,  0.02116D0,
52682      &     0.01072D0,  0.00459D0,  0.00031D0,  0.00000D0/
52683       DATA (FMRS(1,1,I,25),I=1,49)/
52684      &     0.02010D0,  0.02507D0,  0.03126D0,  0.03556D0,  0.03897D0,
52685      &     0.04183D0,  0.05216D0,  0.06515D0,  0.07433D0,  0.08171D0,
52686      &     0.08812D0,  0.11191D0,  0.14397D0,  0.16790D0,  0.18786D0,
52687      &     0.20530D0,  0.23522D0,  0.27216D0,  0.32085D0,  0.35900D0,
52688      &     0.41434D0,  0.45001D0,  0.47142D0,  0.48304D0,  0.48197D0,
52689      &     0.47120D0,  0.45346D0,  0.43043D0,  0.40367D0,  0.37460D0,
52690      &     0.34407D0,  0.31306D0,  0.28215D0,  0.25197D0,  0.22296D0,
52691      &     0.19546D0,  0.16953D0,  0.14549D0,  0.12381D0,  0.10387D0,
52692      &     0.08608D0,  0.07049D0,  0.05669D0,  0.03490D0,  0.01971D0,
52693      &     0.00991D0,  0.00421D0,  0.00028D0,  0.00000D0/
52694       DATA (FMRS(1,1,I,26),I=1,49)/
52695      &     0.02032D0,  0.02536D0,  0.03164D0,  0.03600D0,  0.03946D0,
52696      &     0.04236D0,  0.05285D0,  0.06604D0,  0.07535D0,  0.08285D0,
52697      &     0.08936D0,  0.11352D0,  0.14603D0,  0.17026D0,  0.19043D0,
52698      &     0.20801D0,  0.23810D0,  0.27509D0,  0.32355D0,  0.36123D0,
52699      &     0.41527D0,  0.44945D0,  0.46936D0,  0.47919D0,  0.47657D0,
52700      &     0.46453D0,  0.44572D0,  0.42188D0,  0.39463D0,  0.36526D0,
52701      &     0.33462D0,  0.30373D0,  0.27307D0,  0.24328D0,  0.21472D0,
52702      &     0.18782D0,  0.16253D0,  0.13914D0,  0.11811D0,  0.09886D0,
52703      &     0.08171D0,  0.06673D0,  0.05353D0,  0.03277D0,  0.01840D0,
52704      &     0.00919D0,  0.00387D0,  0.00025D0,  0.00000D0/
52705       DATA (FMRS(1,1,I,27),I=1,49)/
52706      &     0.02054D0,  0.02564D0,  0.03200D0,  0.03642D0,  0.03992D0,
52707      &     0.04287D0,  0.05350D0,  0.06688D0,  0.07633D0,  0.08394D0,
52708      &     0.09053D0,  0.11504D0,  0.14798D0,  0.17249D0,  0.19284D0,
52709      &     0.21055D0,  0.24079D0,  0.27781D0,  0.32602D0,  0.36325D0,
52710      &     0.41604D0,  0.44883D0,  0.46732D0,  0.47551D0,  0.47145D0,
52711      &     0.45823D0,  0.43846D0,  0.41392D0,  0.38625D0,  0.35664D0,
52712      &     0.32595D0,  0.29518D0,  0.26477D0,  0.23536D0,  0.20725D0,
52713      &     0.18088D0,  0.15618D0,  0.13340D0,  0.11297D0,  0.09435D0,
52714      &     0.07779D0,  0.06337D0,  0.05071D0,  0.03088D0,  0.01724D0,
52715      &     0.00855D0,  0.00357D0,  0.00023D0,  0.00000D0/
52716       DATA (FMRS(1,1,I,28),I=1,49)/
52717      &     0.02074D0,  0.02591D0,  0.03234D0,  0.03682D0,  0.04037D0,
52718      &     0.04335D0,  0.05412D0,  0.06768D0,  0.07725D0,  0.08496D0,
52719      &     0.09165D0,  0.11648D0,  0.14982D0,  0.17457D0,  0.19509D0,
52720      &     0.21292D0,  0.24327D0,  0.28031D0,  0.32827D0,  0.36504D0,
52721      &     0.41665D0,  0.44811D0,  0.46527D0,  0.47196D0,  0.46656D0,
52722      &     0.45228D0,  0.43165D0,  0.40650D0,  0.37846D0,  0.34867D0,
52723      &     0.31800D0,  0.28733D0,  0.25718D0,  0.22812D0,  0.20048D0,
52724      &     0.17458D0,  0.15043D0,  0.12823D0,  0.10834D0,  0.09029D0,
52725      &     0.07427D0,  0.06037D0,  0.04820D0,  0.02920D0,  0.01621D0,
52726      &     0.00800D0,  0.00332D0,  0.00021D0,  0.00000D0/
52727       DATA (FMRS(1,1,I,29),I=1,49)/
52728      &     0.02094D0,  0.02617D0,  0.03269D0,  0.03722D0,  0.04081D0,
52729      &     0.04383D0,  0.05475D0,  0.06848D0,  0.07818D0,  0.08599D0,
52730      &     0.09277D0,  0.11792D0,  0.15165D0,  0.17664D0,  0.19733D0,
52731      &     0.21527D0,  0.24574D0,  0.28277D0,  0.33045D0,  0.36674D0,
52732      &     0.41715D0,  0.44728D0,  0.46313D0,  0.46834D0,  0.46164D0,
52733      &     0.44631D0,  0.42488D0,  0.39917D0,  0.37077D0,  0.34082D0,
52734      &     0.31017D0,  0.27964D0,  0.24978D0,  0.22107D0,  0.19390D0,
52735      &     0.16849D0,  0.14488D0,  0.12325D0,  0.10390D0,  0.08640D0,
52736      &     0.07092D0,  0.05751D0,  0.04581D0,  0.02761D0,  0.01524D0,
52737      &     0.00748D0,  0.00308D0,  0.00019D0,  0.00000D0/
52738       DATA (FMRS(1,1,I,30),I=1,49)/
52739      &     0.02115D0,  0.02644D0,  0.03303D0,  0.03762D0,  0.04125D0,
52740      &     0.04431D0,  0.05536D0,  0.06927D0,  0.07910D0,  0.08701D0,
52741      &     0.09387D0,  0.11934D0,  0.15345D0,  0.17867D0,  0.19951D0,
52742      &     0.21755D0,  0.24811D0,  0.28512D0,  0.33251D0,  0.36831D0,
52743      &     0.41752D0,  0.44634D0,  0.46092D0,  0.46470D0,  0.45678D0,
52744      &     0.44042D0,  0.41827D0,  0.39206D0,  0.36329D0,  0.33323D0,
52745      &     0.30260D0,  0.27226D0,  0.24270D0,  0.21435D0,  0.18761D0,
52746      &     0.16271D0,  0.13963D0,  0.11853D0,  0.09974D0,  0.08276D0,
52747      &     0.06777D0,  0.05484D0,  0.04358D0,  0.02615D0,  0.01436D0,
52748      &     0.00700D0,  0.00286D0,  0.00017D0,  0.00000D0/
52749       DATA (FMRS(1,1,I,31),I=1,49)/
52750      &     0.02134D0,  0.02669D0,  0.03336D0,  0.03800D0,  0.04168D0,
52751      &     0.04477D0,  0.05595D0,  0.07003D0,  0.07997D0,  0.08798D0,
52752      &     0.09492D0,  0.12069D0,  0.15515D0,  0.18059D0,  0.20157D0,
52753      &     0.21970D0,  0.25034D0,  0.28732D0,  0.33440D0,  0.36974D0,
52754      &     0.41780D0,  0.44538D0,  0.45878D0,  0.46121D0,  0.45216D0,
52755      &     0.43488D0,  0.41206D0,  0.38539D0,  0.35634D0,  0.32619D0,
52756      &     0.29560D0,  0.26544D0,  0.23618D0,  0.20818D0,  0.18185D0,
52757      &     0.15743D0,  0.13483D0,  0.11423D0,  0.09594D0,  0.07945D0,
52758      &     0.06492D0,  0.05243D0,  0.04157D0,  0.02483D0,  0.01357D0,
52759      &     0.00658D0,  0.00267D0,  0.00016D0,  0.00000D0/
52760       DATA (FMRS(1,1,I,32),I=1,49)/
52761      &     0.02153D0,  0.02693D0,  0.03367D0,  0.03836D0,  0.04208D0,
52762      &     0.04521D0,  0.05651D0,  0.07075D0,  0.08080D0,  0.08890D0,
52763      &     0.09592D0,  0.12197D0,  0.15676D0,  0.18239D0,  0.20349D0,
52764      &     0.22170D0,  0.25240D0,  0.28933D0,  0.33609D0,  0.37098D0,
52765      &     0.41793D0,  0.44434D0,  0.45663D0,  0.45780D0,  0.44772D0,
52766      &     0.42965D0,  0.40618D0,  0.37910D0,  0.34986D0,  0.31963D0,
52767      &     0.28912D0,  0.25913D0,  0.23015D0,  0.20249D0,  0.17658D0,
52768      &     0.15257D0,  0.13044D0,  0.11030D0,  0.09247D0,  0.07643D0,
52769      &     0.06234D0,  0.05026D0,  0.03976D0,  0.02365D0,  0.01287D0,
52770      &     0.00620D0,  0.00250D0,  0.00014D0,  0.00000D0/
52771       DATA (FMRS(1,1,I,33),I=1,49)/
52772      &     0.02171D0,  0.02717D0,  0.03398D0,  0.03872D0,  0.04248D0,
52773      &     0.04565D0,  0.05708D0,  0.07147D0,  0.08164D0,  0.08983D0,
52774      &     0.09693D0,  0.12326D0,  0.15838D0,  0.18421D0,  0.20543D0,
52775      &     0.22371D0,  0.25448D0,  0.29136D0,  0.33779D0,  0.37222D0,
52776      &     0.41806D0,  0.44331D0,  0.45449D0,  0.45441D0,  0.44330D0,
52777      &     0.42446D0,  0.40038D0,  0.37291D0,  0.34349D0,  0.31319D0,
52778      &     0.28277D0,  0.25295D0,  0.22427D0,  0.19695D0,  0.17145D0,
52779      &     0.14785D0,  0.12618D0,  0.10650D0,  0.08912D0,  0.07353D0,
52780      &     0.05986D0,  0.04817D0,  0.03803D0,  0.02252D0,  0.01220D0,
52781      &     0.00585D0,  0.00235D0,  0.00013D0,  0.00000D0/
52782       DATA (FMRS(1,1,I,34),I=1,49)/
52783      &     0.02190D0,  0.02741D0,  0.03429D0,  0.03909D0,  0.04289D0,
52784      &     0.04609D0,  0.05764D0,  0.07219D0,  0.08247D0,  0.09075D0,
52785      &     0.09793D0,  0.12453D0,  0.15996D0,  0.18597D0,  0.20731D0,
52786      &     0.22565D0,  0.25646D0,  0.29325D0,  0.33935D0,  0.37330D0,
52787      &     0.41800D0,  0.44209D0,  0.45219D0,  0.45092D0,  0.43883D0,
52788      &     0.41923D0,  0.39461D0,  0.36679D0,  0.33718D0,  0.30687D0,
52789      &     0.27654D0,  0.24693D0,  0.21853D0,  0.19159D0,  0.16650D0,
52790      &     0.14332D0,  0.12207D0,  0.10288D0,  0.08593D0,  0.07076D0,
52791      &     0.05749D0,  0.04618D0,  0.03639D0,  0.02146D0,  0.01157D0,
52792      &     0.00552D0,  0.00220D0,  0.00012D0,  0.00000D0/
52793       DATA (FMRS(1,1,I,35),I=1,49)/
52794      &     0.02208D0,  0.02764D0,  0.03459D0,  0.03943D0,  0.04327D0,
52795      &     0.04650D0,  0.05818D0,  0.07288D0,  0.08327D0,  0.09162D0,
52796      &     0.09888D0,  0.12574D0,  0.16147D0,  0.18765D0,  0.20909D0,
52797      &     0.22750D0,  0.25834D0,  0.29505D0,  0.34083D0,  0.37432D0,
52798      &     0.41794D0,  0.44094D0,  0.45002D0,  0.44763D0,  0.43463D0,
52799      &     0.41432D0,  0.38921D0,  0.36108D0,  0.33130D0,  0.30099D0,
52800      &     0.27077D0,  0.24136D0,  0.21322D0,  0.18665D0,  0.16193D0,
52801      &     0.13915D0,  0.11830D0,  0.09955D0,  0.08301D0,  0.06823D0,
52802      &     0.05533D0,  0.04437D0,  0.03490D0,  0.02050D0,  0.01100D0,
52803      &     0.00523D0,  0.00207D0,  0.00011D0,  0.00000D0/
52804       DATA (FMRS(1,1,I,36),I=1,49)/
52805      &     0.02225D0,  0.02787D0,  0.03488D0,  0.03977D0,  0.04364D0,
52806      &     0.04690D0,  0.05869D0,  0.07354D0,  0.08402D0,  0.09246D0,
52807      &     0.09978D0,  0.12689D0,  0.16290D0,  0.18924D0,  0.21077D0,
52808      &     0.22923D0,  0.26010D0,  0.29672D0,  0.34217D0,  0.37521D0,
52809      &     0.41781D0,  0.43978D0,  0.44789D0,  0.44447D0,  0.43062D0,
52810      &     0.40968D0,  0.38412D0,  0.35571D0,  0.32579D0,  0.29550D0,
52811      &     0.26538D0,  0.23618D0,  0.20831D0,  0.18206D0,  0.15771D0,
52812      &     0.13531D0,  0.11485D0,  0.09649D0,  0.08034D0,  0.06592D0,
52813      &     0.05337D0,  0.04272D0,  0.03354D0,  0.01963D0,  0.01049D0,
52814      &     0.00496D0,  0.00196D0,  0.00011D0,  0.00000D0/
52815       DATA (FMRS(1,1,I,37),I=1,49)/
52816      &     0.02242D0,  0.02809D0,  0.03517D0,  0.04010D0,  0.04401D0,
52817      &     0.04731D0,  0.05921D0,  0.07420D0,  0.08479D0,  0.09331D0,
52818      &     0.10070D0,  0.12805D0,  0.16433D0,  0.19082D0,  0.21245D0,
52819      &     0.23095D0,  0.26184D0,  0.29836D0,  0.34345D0,  0.37604D0,
52820      &     0.41760D0,  0.43853D0,  0.44568D0,  0.44123D0,  0.42654D0,
52821      &     0.40499D0,  0.37899D0,  0.35034D0,  0.32029D0,  0.29001D0,
52822      &     0.26003D0,  0.23104D0,  0.20345D0,  0.17752D0,  0.15354D0,
52823      &     0.13153D0,  0.11147D0,  0.09348D0,  0.07771D0,  0.06366D0,
52824      &     0.05147D0,  0.04112D0,  0.03222D0,  0.01879D0,  0.01000D0,
52825      &     0.00471D0,  0.00185D0,  0.00010D0,  0.00000D0/
52826       DATA (FMRS(1,1,I,38),I=1,49)/
52827      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52828      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52829      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52830      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52831      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52832      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52833      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52834      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52835      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52836      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52837       DATA (FMRS(1,2,I, 1),I=1,49)/
52838      &     0.00513D0,  0.00648D0,  0.00818D0,  0.00938D0,  0.01034D0,
52839      &     0.01116D0,  0.01418D0,  0.01818D0,  0.02118D0,  0.02372D0,
52840      &     0.02613D0,  0.03576D0,  0.05040D0,  0.06228D0,  0.07266D0,
52841      &     0.08202D0,  0.09864D0,  0.12002D0,  0.14955D0,  0.17387D0,
52842      &     0.21184D0,  0.23954D0,  0.25956D0,  0.27606D0,  0.28502D0,
52843      &     0.28790D0,  0.28586D0,  0.27985D0,  0.27060D0,  0.25918D0,
52844      &     0.24535D0,  0.23028D0,  0.21416D0,  0.19735D0,  0.18044D0,
52845      &     0.16347D0,  0.14671D0,  0.13049D0,  0.11512D0,  0.10018D0,
52846      &     0.08630D0,  0.07360D0,  0.06172D0,  0.04171D0,  0.02610D0,
52847      &     0.01478D0,  0.00721D0,  0.00074D0,  0.00000D0/
52848       DATA (FMRS(1,2,I, 2),I=1,49)/
52849      &     0.00518D0,  0.00654D0,  0.00828D0,  0.00950D0,  0.01049D0,
52850      &     0.01133D0,  0.01443D0,  0.01854D0,  0.02162D0,  0.02423D0,
52851      &     0.02670D0,  0.03657D0,  0.05155D0,  0.06366D0,  0.07421D0,
52852      &     0.08371D0,  0.10052D0,  0.12206D0,  0.15163D0,  0.17583D0,
52853      &     0.21329D0,  0.24028D0,  0.25950D0,  0.27498D0,  0.28295D0,
52854      &     0.28491D0,  0.28206D0,  0.27535D0,  0.26555D0,  0.25365D0,
52855      &     0.23952D0,  0.22423D0,  0.20802D0,  0.19123D0,  0.17441D0,
52856      &     0.15763D0,  0.14114D0,  0.12520D0,  0.11019D0,  0.09565D0,
52857      &     0.08218D0,  0.06990D0,  0.05847D0,  0.03927D0,  0.02442D0,
52858      &     0.01373D0,  0.00665D0,  0.00066D0,  0.00000D0/
52859       DATA (FMRS(1,2,I, 3),I=1,49)/
52860      &     0.00524D0,  0.00664D0,  0.00843D0,  0.00970D0,  0.01072D0,
52861      &     0.01159D0,  0.01481D0,  0.01908D0,  0.02229D0,  0.02501D0,
52862      &     0.02757D0,  0.03781D0,  0.05328D0,  0.06572D0,  0.07653D0,
52863      &     0.08622D0,  0.10330D0,  0.12505D0,  0.15465D0,  0.17864D0,
52864      &     0.21528D0,  0.24119D0,  0.25922D0,  0.27320D0,  0.27971D0,
52865      &     0.28035D0,  0.27635D0,  0.26864D0,  0.25807D0,  0.24551D0,
52866      &     0.23101D0,  0.21544D0,  0.19911D0,  0.18240D0,  0.16578D0,
52867      &     0.14929D0,  0.13320D0,  0.11772D0,  0.10322D0,  0.08926D0,
52868      &     0.07639D0,  0.06473D0,  0.05394D0,  0.03591D0,  0.02212D0,
52869      &     0.01231D0,  0.00589D0,  0.00057D0,  0.00000D0/
52870       DATA (FMRS(1,2,I, 4),I=1,49)/
52871      &     0.00529D0,  0.00672D0,  0.00855D0,  0.00985D0,  0.01090D0,
52872      &     0.01179D0,  0.01510D0,  0.01949D0,  0.02279D0,  0.02558D0,
52873      &     0.02822D0,  0.03873D0,  0.05456D0,  0.06724D0,  0.07823D0,
52874      &     0.08806D0,  0.10532D0,  0.12720D0,  0.15680D0,  0.18061D0,
52875      &     0.21663D0,  0.24172D0,  0.25888D0,  0.27177D0,  0.27723D0,
52876      &     0.27696D0,  0.27213D0,  0.26373D0,  0.25262D0,  0.23966D0,
52877      &     0.22489D0,  0.20919D0,  0.19281D0,  0.17616D0,  0.15968D0,
52878      &     0.14345D0,  0.12763D0,  0.11250D0,  0.09838D0,  0.08485D0,
52879      &     0.07242D0,  0.06118D0,  0.05083D0,  0.03363D0,  0.02058D0,
52880      &     0.01136D0,  0.00539D0,  0.00050D0,  0.00000D0/
52881       DATA (FMRS(1,2,I, 5),I=1,49)/
52882      &     0.00534D0,  0.00680D0,  0.00868D0,  0.01001D0,  0.01108D0,
52883      &     0.01200D0,  0.01540D0,  0.01993D0,  0.02332D0,  0.02620D0,
52884      &     0.02891D0,  0.03971D0,  0.05590D0,  0.06884D0,  0.08000D0,
52885      &     0.08997D0,  0.10741D0,  0.12941D0,  0.15897D0,  0.18257D0,
52886      &     0.21790D0,  0.24212D0,  0.25836D0,  0.27010D0,  0.27446D0,
52887      &     0.27326D0,  0.26762D0,  0.25853D0,  0.24692D0,  0.23356D0,
52888      &     0.21851D0,  0.20270D0,  0.18633D0,  0.16975D0,  0.15345D0,
52889      &     0.13751D0,  0.12199D0,  0.10721D0,  0.09351D0,  0.08043D0,
52890      &     0.06843D0,  0.05765D0,  0.04775D0,  0.03138D0,  0.01907D0,
52891      &     0.01045D0,  0.00491D0,  0.00045D0,  0.00000D0/
52892       DATA (FMRS(1,2,I, 6),I=1,49)/
52893      &     0.00539D0,  0.00688D0,  0.00879D0,  0.01015D0,  0.01125D0,
52894      &     0.01219D0,  0.01567D0,  0.02031D0,  0.02379D0,  0.02674D0,
52895      &     0.02951D0,  0.04056D0,  0.05708D0,  0.07022D0,  0.08154D0,
52896      &     0.09162D0,  0.10921D0,  0.13130D0,  0.16082D0,  0.18422D0,
52897      &     0.21894D0,  0.24239D0,  0.25783D0,  0.26859D0,  0.27204D0,
52898      &     0.27005D0,  0.26373D0,  0.25409D0,  0.24206D0,  0.22838D0,
52899      &     0.21313D0,  0.19724D0,  0.18088D0,  0.16440D0,  0.14826D0,
52900      &     0.13257D0,  0.11731D0,  0.10284D0,  0.08950D0,  0.07679D0,
52901      &     0.06517D0,  0.05477D0,  0.04524D0,  0.02956D0,  0.01786D0,
52902      &     0.00972D0,  0.00453D0,  0.00040D0,  0.00000D0/
52903       DATA (FMRS(1,2,I, 7),I=1,49)/
52904      &     0.00544D0,  0.00695D0,  0.00890D0,  0.01029D0,  0.01141D0,
52905      &     0.01237D0,  0.01593D0,  0.02068D0,  0.02425D0,  0.02727D0,
52906      &     0.03010D0,  0.04138D0,  0.05820D0,  0.07155D0,  0.08301D0,
52907      &     0.09319D0,  0.11091D0,  0.13308D0,  0.16253D0,  0.18572D0,
52908      &     0.21983D0,  0.24255D0,  0.25721D0,  0.26706D0,  0.26966D0,
52909      &     0.26692D0,  0.25996D0,  0.24983D0,  0.23740D0,  0.22344D0,
52910      &     0.20806D0,  0.19209D0,  0.17575D0,  0.15940D0,  0.14342D0,
52911      &     0.12794D0,  0.11298D0,  0.09881D0,  0.08579D0,  0.07344D0,
52912      &     0.06219D0,  0.05213D0,  0.04295D0,  0.02791D0,  0.01677D0,
52913      &     0.00906D0,  0.00419D0,  0.00037D0,  0.00000D0/
52914       DATA (FMRS(1,2,I, 8),I=1,49)/
52915      &     0.00549D0,  0.00703D0,  0.00902D0,  0.01044D0,  0.01159D0,
52916      &     0.01257D0,  0.01622D0,  0.02109D0,  0.02474D0,  0.02783D0,
52917      &     0.03073D0,  0.04227D0,  0.05940D0,  0.07296D0,  0.08456D0,
52918      &     0.09485D0,  0.11270D0,  0.13493D0,  0.16429D0,  0.18726D0,
52919      &     0.22070D0,  0.24263D0,  0.25647D0,  0.26535D0,  0.26707D0,
52920      &     0.26357D0,  0.25596D0,  0.24532D0,  0.23250D0,  0.21829D0,
52921      &     0.20276D0,  0.18675D0,  0.17045D0,  0.15424D0,  0.13845D0,
52922      &     0.12321D0,  0.10855D0,  0.09470D0,  0.08203D0,  0.07005D0,
52923      &     0.05917D0,  0.04947D0,  0.04065D0,  0.02627D0,  0.01569D0,
52924      &     0.00842D0,  0.00386D0,  0.00033D0,  0.00000D0/
52925       DATA (FMRS(1,2,I, 9),I=1,49)/
52926      &     0.00553D0,  0.00711D0,  0.00913D0,  0.01057D0,  0.01174D0,
52927      &     0.01274D0,  0.01647D0,  0.02144D0,  0.02517D0,  0.02833D0,
52928      &     0.03129D0,  0.04304D0,  0.06045D0,  0.07418D0,  0.08591D0,
52929      &     0.09629D0,  0.11425D0,  0.13653D0,  0.16579D0,  0.18855D0,
52930      &     0.22139D0,  0.24264D0,  0.25577D0,  0.26380D0,  0.26479D0,
52931      &     0.26063D0,  0.25250D0,  0.24142D0,  0.22830D0,  0.21390D0,
52932      &     0.19824D0,  0.18222D0,  0.16597D0,  0.14988D0,  0.13426D0,
52933      &     0.11924D0,  0.10484D0,  0.09128D0,  0.07889D0,  0.06724D0,
52934      &     0.05666D0,  0.04727D0,  0.03875D0,  0.02492D0,  0.01480D0,
52935      &     0.00790D0,  0.00360D0,  0.00030D0,  0.00000D0/
52936       DATA (FMRS(1,2,I,10),I=1,49)/
52937      &     0.00558D0,  0.00718D0,  0.00923D0,  0.01071D0,  0.01190D0,
52938      &     0.01291D0,  0.01671D0,  0.02178D0,  0.02559D0,  0.02881D0,
52939      &     0.03183D0,  0.04379D0,  0.06146D0,  0.07536D0,  0.08720D0,
52940      &     0.09766D0,  0.11571D0,  0.13802D0,  0.16719D0,  0.18973D0,
52941      &     0.22198D0,  0.24256D0,  0.25502D0,  0.26225D0,  0.26252D0,
52942      &     0.25776D0,  0.24914D0,  0.23766D0,  0.22428D0,  0.20968D0,
52943      &     0.19393D0,  0.17791D0,  0.16173D0,  0.14575D0,  0.13032D0,
52944      &     0.11552D0,  0.10136D0,  0.08807D0,  0.07596D0,  0.06462D0,
52945      &     0.05433D0,  0.04524D0,  0.03701D0,  0.02369D0,  0.01400D0,
52946      &     0.00743D0,  0.00336D0,  0.00028D0,  0.00000D0/
52947       DATA (FMRS(1,2,I,11),I=1,49)/
52948      &     0.00562D0,  0.00723D0,  0.00932D0,  0.01081D0,  0.01202D0,
52949      &     0.01305D0,  0.01691D0,  0.02206D0,  0.02593D0,  0.02920D0,
52950      &     0.03226D0,  0.04438D0,  0.06226D0,  0.07629D0,  0.08822D0,
52951      &     0.09874D0,  0.11687D0,  0.13920D0,  0.16827D0,  0.19064D0,
52952      &     0.22242D0,  0.24246D0,  0.25439D0,  0.26100D0,  0.26071D0,
52953      &     0.25548D0,  0.24648D0,  0.23472D0,  0.22112D0,  0.20638D0,
52954      &     0.19059D0,  0.17454D0,  0.15845D0,  0.14257D0,  0.12728D0,
52955      &     0.11265D0,  0.09869D0,  0.08561D0,  0.07373D0,  0.06261D0,
52956      &     0.05256D0,  0.04369D0,  0.03568D0,  0.02275D0,  0.01339D0,
52957      &     0.00707D0,  0.00318D0,  0.00026D0,  0.00000D0/
52958       DATA (FMRS(1,2,I,12),I=1,49)/
52959      &     0.00570D0,  0.00736D0,  0.00950D0,  0.01104D0,  0.01228D0,
52960      &     0.01335D0,  0.01733D0,  0.02266D0,  0.02665D0,  0.03003D0,
52961      &     0.03319D0,  0.04566D0,  0.06397D0,  0.07827D0,  0.09038D0,
52962      &     0.10102D0,  0.11928D0,  0.14164D0,  0.17050D0,  0.19247D0,
52963      &     0.22321D0,  0.24211D0,  0.25293D0,  0.25822D0,  0.25677D0,
52964      &     0.25059D0,  0.24082D0,  0.22847D0,  0.21448D0,  0.19945D0,
52965      &     0.18361D0,  0.16759D0,  0.15163D0,  0.13598D0,  0.12100D0,
52966      &     0.10676D0,  0.09321D0,  0.08058D0,  0.06917D0,  0.05856D0,
52967      &     0.04898D0,  0.04057D0,  0.03301D0,  0.02089D0,  0.01219D0,
52968      &     0.00638D0,  0.00284D0,  0.00022D0,  0.00000D0/
52969       DATA (FMRS(1,2,I,13),I=1,49)/
52970      &     0.00578D0,  0.00747D0,  0.00966D0,  0.01124D0,  0.01252D0,
52971      &     0.01361D0,  0.01770D0,  0.02318D0,  0.02729D0,  0.03076D0,
52972      &     0.03400D0,  0.04677D0,  0.06545D0,  0.07997D0,  0.09223D0,
52973      &     0.10297D0,  0.12133D0,  0.14370D0,  0.17234D0,  0.19395D0,
52974      &     0.22379D0,  0.24170D0,  0.25156D0,  0.25575D0,  0.25334D0,
52975      &     0.24638D0,  0.23598D0,  0.22317D0,  0.20887D0,  0.19364D0,
52976      &     0.17776D0,  0.16180D0,  0.14597D0,  0.13054D0,  0.11583D0,
52977      &     0.10193D0,  0.08873D0,  0.07648D0,  0.06548D0,  0.05529D0,
52978      &     0.04609D0,  0.03806D0,  0.03088D0,  0.01941D0,  0.01124D0,
52979      &     0.00583D0,  0.00257D0,  0.00020D0,  0.00000D0/
52980       DATA (FMRS(1,2,I,14),I=1,49)/
52981      &     0.00586D0,  0.00760D0,  0.00985D0,  0.01147D0,  0.01278D0,
52982      &     0.01391D0,  0.01812D0,  0.02377D0,  0.02801D0,  0.03158D0,
52983      &     0.03491D0,  0.04802D0,  0.06710D0,  0.08186D0,  0.09428D0,
52984      &     0.10512D0,  0.12358D0,  0.14593D0,  0.17430D0,  0.19551D0,
52985      &     0.22431D0,  0.24113D0,  0.24990D0,  0.25292D0,  0.24948D0,
52986      &     0.24168D0,  0.23063D0,  0.21737D0,  0.20273D0,  0.18735D0,
52987      &     0.17142D0,  0.15550D0,  0.13986D0,  0.12470D0,  0.11033D0,
52988      &     0.09680D0,  0.08400D0,  0.07217D0,  0.06162D0,  0.05183D0,
52989      &     0.04308D0,  0.03546D0,  0.02866D0,  0.01788D0,  0.01027D0,
52990      &     0.00528D0,  0.00231D0,  0.00017D0,  0.00000D0/
52991       DATA (FMRS(1,2,I,15),I=1,49)/
52992      &     0.00596D0,  0.00773D0,  0.01005D0,  0.01171D0,  0.01307D0,
52993      &     0.01423D0,  0.01857D0,  0.02439D0,  0.02876D0,  0.03244D0,
52994      &     0.03586D0,  0.04932D0,  0.06880D0,  0.08380D0,  0.09637D0,
52995      &     0.10730D0,  0.12584D0,  0.14815D0,  0.17622D0,  0.19694D0,
52996      &     0.22466D0,  0.24034D0,  0.24804D0,  0.24983D0,  0.24536D0,
52997      &     0.23677D0,  0.22506D0,  0.21136D0,  0.19645D0,  0.18096D0,
52998      &     0.16500D0,  0.14922D0,  0.13378D0,  0.11890D0,  0.10488D0,
52999      &     0.09171D0,  0.07933D0,  0.06793D0,  0.05781D0,  0.04848D0,
53000      &     0.04016D0,  0.03293D0,  0.02652D0,  0.01642D0,  0.00936D0,
53001      &     0.00477D0,  0.00206D0,  0.00015D0,  0.00000D0/
53002       DATA (FMRS(1,2,I,16),I=1,49)/
53003      &     0.00604D0,  0.00786D0,  0.01023D0,  0.01194D0,  0.01333D0,
53004      &     0.01452D0,  0.01898D0,  0.02497D0,  0.02945D0,  0.03323D0,
53005      &     0.03674D0,  0.05050D0,  0.07034D0,  0.08554D0,  0.09824D0,
53006      &     0.10925D0,  0.12785D0,  0.15009D0,  0.17786D0,  0.19815D0,
53007      &     0.22486D0,  0.23952D0,  0.24625D0,  0.24698D0,  0.24163D0,
53008      &     0.23233D0,  0.22009D0,  0.20603D0,  0.19091D0,  0.17529D0,
53009      &     0.15938D0,  0.14374D0,  0.12849D0,  0.11388D0,  0.10016D0,
53010      &     0.08733D0,  0.07533D0,  0.06433D0,  0.05458D0,  0.04564D0,
53011      &     0.03769D0,  0.03082D0,  0.02473D0,  0.01521D0,  0.00860D0,
53012      &     0.00435D0,  0.00186D0,  0.00013D0,  0.00000D0/
53013       DATA (FMRS(1,2,I,17),I=1,49)/
53014      &     0.00614D0,  0.00799D0,  0.01042D0,  0.01217D0,  0.01359D0,
53015      &     0.01482D0,  0.01940D0,  0.02555D0,  0.03016D0,  0.03404D0,
53016      &     0.03763D0,  0.05170D0,  0.07188D0,  0.08729D0,  0.10010D0,
53017      &     0.11119D0,  0.12983D0,  0.15200D0,  0.17943D0,  0.19928D0,
53018      &     0.22497D0,  0.23860D0,  0.24438D0,  0.24406D0,  0.23786D0,
53019      &     0.22788D0,  0.21517D0,  0.20077D0,  0.18546D0,  0.16976D0,
53020      &     0.15392D0,  0.13841D0,  0.12338D0,  0.10905D0,  0.09563D0,
53021      &     0.08314D0,  0.07152D0,  0.06090D0,  0.05152D0,  0.04295D0,
53022      &     0.03537D0,  0.02883D0,  0.02306D0,  0.01409D0,  0.00791D0,
53023      &     0.00396D0,  0.00168D0,  0.00011D0,  0.00000D0/
53024       DATA (FMRS(1,2,I,18),I=1,49)/
53025      &     0.00621D0,  0.00810D0,  0.01058D0,  0.01236D0,  0.01382D0,
53026      &     0.01507D0,  0.01975D0,  0.02604D0,  0.03075D0,  0.03471D0,
53027      &     0.03837D0,  0.05269D0,  0.07316D0,  0.08872D0,  0.10163D0,
53028      &     0.11277D0,  0.13143D0,  0.15352D0,  0.18066D0,  0.20012D0,
53029      &     0.22496D0,  0.23774D0,  0.24276D0,  0.24159D0,  0.23471D0,
53030      &     0.22421D0,  0.21113D0,  0.19645D0,  0.18102D0,  0.16532D0,
53031      &     0.14952D0,  0.13412D0,  0.11930D0,  0.10519D0,  0.09201D0,
53032      &     0.07983D0,  0.06850D0,  0.05818D0,  0.04914D0,  0.04085D0,
53033      &     0.03356D0,  0.02728D0,  0.02176D0,  0.01322D0,  0.00738D0,
53034      &     0.00367D0,  0.00154D0,  0.00010D0,  0.00000D0/
53035       DATA (FMRS(1,2,I,19),I=1,49)/
53036      &     0.00631D0,  0.00824D0,  0.01077D0,  0.01261D0,  0.01410D0,
53037      &     0.01538D0,  0.02018D0,  0.02663D0,  0.03146D0,  0.03553D0,
53038      &     0.03927D0,  0.05390D0,  0.07469D0,  0.09044D0,  0.10345D0,
53039      &     0.11464D0,  0.13332D0,  0.15529D0,  0.18206D0,  0.20106D0,
53040      &     0.22486D0,  0.23661D0,  0.24071D0,  0.23855D0,  0.23089D0,
53041      &     0.21978D0,  0.20626D0,  0.19133D0,  0.17575D0,  0.16006D0,
53042      &     0.14433D0,  0.12911D0,  0.11452D0,  0.10069D0,  0.08783D0,
53043      &     0.07600D0,  0.06503D0,  0.05507D0,  0.04638D0,  0.03845D0,
53044      &     0.03149D0,  0.02552D0,  0.02030D0,  0.01225D0,  0.00679D0,
53045      &     0.00335D0,  0.00139D0,  0.00009D0,  0.00000D0/
53046       DATA (FMRS(1,2,I,20),I=1,49)/
53047      &     0.00640D0,  0.00837D0,  0.01095D0,  0.01282D0,  0.01434D0,
53048      &     0.01565D0,  0.02057D0,  0.02717D0,  0.03210D0,  0.03625D0,
53049      &     0.04007D0,  0.05496D0,  0.07605D0,  0.09195D0,  0.10504D0,
53050      &     0.11628D0,  0.13496D0,  0.15682D0,  0.18325D0,  0.20182D0,
53051      &     0.22471D0,  0.23557D0,  0.23887D0,  0.23587D0,  0.22753D0,
53052      &     0.21592D0,  0.20204D0,  0.18691D0,  0.17123D0,  0.15556D0,
53053      &     0.13990D0,  0.12485D0,  0.11047D0,  0.09690D0,  0.08432D0,
53054      &     0.07279D0,  0.06213D0,  0.05248D0,  0.04407D0,  0.03646D0,
53055      &     0.02978D0,  0.02408D0,  0.01910D0,  0.01145D0,  0.00631D0,
53056      &     0.00309D0,  0.00127D0,  0.00008D0,  0.00000D0/
53057       DATA (FMRS(1,2,I,21),I=1,49)/
53058      &     0.00648D0,  0.00848D0,  0.01111D0,  0.01302D0,  0.01457D0,
53059      &     0.01591D0,  0.02092D0,  0.02766D0,  0.03269D0,  0.03692D0,
53060      &     0.04081D0,  0.05593D0,  0.07728D0,  0.09331D0,  0.10647D0,
53061      &     0.11774D0,  0.13641D0,  0.15816D0,  0.18425D0,  0.20243D0,
53062      &     0.22446D0,  0.23452D0,  0.23710D0,  0.23336D0,  0.22443D0,
53063      &     0.21239D0,  0.19820D0,  0.18290D0,  0.16716D0,  0.15148D0,
53064      &     0.13595D0,  0.12104D0,  0.10685D0,  0.09353D0,  0.08121D0,
53065      &     0.06995D0,  0.05958D0,  0.05021D0,  0.04207D0,  0.03472D0,
53066      &     0.02829D0,  0.02282D0,  0.01806D0,  0.01077D0,  0.00590D0,
53067      &     0.00287D0,  0.00118D0,  0.00007D0,  0.00000D0/
53068       DATA (FMRS(1,2,I,22),I=1,49)/
53069      &     0.00659D0,  0.00863D0,  0.01133D0,  0.01328D0,  0.01487D0,
53070      &     0.01624D0,  0.02138D0,  0.02828D0,  0.03345D0,  0.03777D0,
53071      &     0.04174D0,  0.05717D0,  0.07882D0,  0.09501D0,  0.10826D0,
53072      &     0.11956D0,  0.13822D0,  0.15980D0,  0.18547D0,  0.20313D0,
53073      &     0.22408D0,  0.23313D0,  0.23482D0,  0.23017D0,  0.22053D0,
53074      &     0.20797D0,  0.19344D0,  0.17794D0,  0.16215D0,  0.14650D0,
53075      &     0.13110D0,  0.11639D0,  0.10245D0,  0.08944D0,  0.07745D0,
53076      &     0.06653D0,  0.05651D0,  0.04748D0,  0.03968D0,  0.03265D0,
53077      &     0.02652D0,  0.02133D0,  0.01682D0,  0.00997D0,  0.00542D0,
53078      &     0.00262D0,  0.00106D0,  0.00006D0,  0.00000D0/
53079       DATA (FMRS(1,2,I,23),I=1,49)/
53080      &     0.00669D0,  0.00878D0,  0.01153D0,  0.01352D0,  0.01515D0,
53081      &     0.01655D0,  0.02181D0,  0.02888D0,  0.03416D0,  0.03858D0,
53082      &     0.04263D0,  0.05833D0,  0.08027D0,  0.09661D0,  0.10992D0,
53083      &     0.12125D0,  0.13987D0,  0.16129D0,  0.18654D0,  0.20370D0,
53084      &     0.22365D0,  0.23178D0,  0.23266D0,  0.22717D0,  0.21689D0,
53085      &     0.20387D0,  0.18906D0,  0.17340D0,  0.15758D0,  0.14198D0,
53086      &     0.12670D0,  0.11220D0,  0.09851D0,  0.08577D0,  0.07408D0,
53087      &     0.06350D0,  0.05377D0,  0.04507D0,  0.03757D0,  0.03084D0,
53088      &     0.02497D0,  0.02003D0,  0.01574D0,  0.00927D0,  0.00500D0,
53089      &     0.00240D0,  0.00096D0,  0.00006D0,  0.00000D0/
53090       DATA (FMRS(1,2,I,24),I=1,49)/
53091      &     0.00679D0,  0.00892D0,  0.01172D0,  0.01376D0,  0.01542D0,
53092      &     0.01685D0,  0.02222D0,  0.02944D0,  0.03483D0,  0.03934D0,
53093      &     0.04345D0,  0.05941D0,  0.08161D0,  0.09806D0,  0.11144D0,
53094      &     0.12278D0,  0.14136D0,  0.16260D0,  0.18745D0,  0.20414D0,
53095      &     0.22314D0,  0.23041D0,  0.23054D0,  0.22429D0,  0.21345D0,
53096      &     0.20006D0,  0.18498D0,  0.16918D0,  0.15336D0,  0.13783D0,
53097      &     0.12271D0,  0.10840D0,  0.09494D0,  0.08246D0,  0.07106D0,
53098      &     0.06075D0,  0.05132D0,  0.04292D0,  0.03570D0,  0.02922D0,
53099      &     0.02361D0,  0.01888D0,  0.01480D0,  0.00867D0,  0.00465D0,
53100      &     0.00221D0,  0.00088D0,  0.00005D0,  0.00000D0/
53101       DATA (FMRS(1,2,I,25),I=1,49)/
53102      &     0.00689D0,  0.00906D0,  0.01192D0,  0.01399D0,  0.01569D0,
53103      &     0.01715D0,  0.02264D0,  0.03000D0,  0.03550D0,  0.04009D0,
53104      &     0.04429D0,  0.06049D0,  0.08294D0,  0.09952D0,  0.11294D0,
53105      &     0.12429D0,  0.14282D0,  0.16389D0,  0.18832D0,  0.20454D0,
53106      &     0.22261D0,  0.22902D0,  0.22843D0,  0.22145D0,  0.21007D0,
53107      &     0.19632D0,  0.18101D0,  0.16509D0,  0.14928D0,  0.13382D0,
53108      &     0.11886D0,  0.10475D0,  0.09153D0,  0.07931D0,  0.06819D0,
53109      &     0.05815D0,  0.04900D0,  0.04089D0,  0.03393D0,  0.02770D0,
53110      &     0.02232D0,  0.01781D0,  0.01392D0,  0.00811D0,  0.00432D0,
53111      &     0.00204D0,  0.00081D0,  0.00004D0,  0.00000D0/
53112       DATA (FMRS(1,2,I,26),I=1,49)/
53113      &     0.00699D0,  0.00920D0,  0.01211D0,  0.01423D0,  0.01596D0,
53114      &     0.01744D0,  0.02304D0,  0.03056D0,  0.03616D0,  0.04084D0,
53115      &     0.04510D0,  0.06154D0,  0.08423D0,  0.10091D0,  0.11437D0,
53116      &     0.12573D0,  0.14419D0,  0.16508D0,  0.18909D0,  0.20485D0,
53117      &     0.22201D0,  0.22760D0,  0.22631D0,  0.21867D0,  0.20676D0,
53118      &     0.19266D0,  0.17717D0,  0.16120D0,  0.14536D0,  0.12999D0,
53119      &     0.11520D0,  0.10128D0,  0.08831D0,  0.07633D0,  0.06548D0,
53120      &     0.05572D0,  0.04685D0,  0.03900D0,  0.03228D0,  0.02629D0,
53121      &     0.02113D0,  0.01682D0,  0.01311D0,  0.00760D0,  0.00403D0,
53122      &     0.00189D0,  0.00074D0,  0.00004D0,  0.00000D0/
53123       DATA (FMRS(1,2,I,27),I=1,49)/
53124      &     0.00708D0,  0.00933D0,  0.01230D0,  0.01445D0,  0.01621D0,
53125      &     0.01773D0,  0.02343D0,  0.03108D0,  0.03678D0,  0.04155D0,
53126      &     0.04587D0,  0.06253D0,  0.08544D0,  0.10221D0,  0.11571D0,
53127      &     0.12707D0,  0.14546D0,  0.16617D0,  0.18977D0,  0.20509D0,
53128      &     0.22139D0,  0.22623D0,  0.22430D0,  0.21604D0,  0.20367D0,
53129      &     0.18926D0,  0.17361D0,  0.15759D0,  0.14176D0,  0.12648D0,
53130      &     0.11185D0,  0.09812D0,  0.08537D0,  0.07364D0,  0.06303D0,
53131      &     0.05352D0,  0.04490D0,  0.03729D0,  0.03081D0,  0.02503D0,
53132      &     0.02007D0,  0.01594D0,  0.01240D0,  0.00714D0,  0.00376D0,
53133      &     0.00176D0,  0.00068D0,  0.00004D0,  0.00000D0/
53134       DATA (FMRS(1,2,I,28),I=1,49)/
53135      &     0.00718D0,  0.00946D0,  0.01247D0,  0.01467D0,  0.01646D0,
53136      &     0.01800D0,  0.02380D0,  0.03158D0,  0.03738D0,  0.04221D0,
53137      &     0.04660D0,  0.06346D0,  0.08657D0,  0.10342D0,  0.11695D0,
53138      &     0.12830D0,  0.14663D0,  0.16715D0,  0.19037D0,  0.20527D0,
53139      &     0.22075D0,  0.22489D0,  0.22237D0,  0.21353D0,  0.20079D0,
53140      &     0.18610D0,  0.17031D0,  0.15425D0,  0.13844D0,  0.12326D0,
53141      &     0.10877D0,  0.09523D0,  0.08268D0,  0.07119D0,  0.06080D0,
53142      &     0.05153D0,  0.04314D0,  0.03575D0,  0.02948D0,  0.02390D0,
53143      &     0.01913D0,  0.01516D0,  0.01177D0,  0.00675D0,  0.00353D0,
53144      &     0.00164D0,  0.00063D0,  0.00003D0,  0.00000D0/
53145       DATA (FMRS(1,2,I,29),I=1,49)/
53146      &     0.00727D0,  0.00959D0,  0.01265D0,  0.01488D0,  0.01670D0,
53147      &     0.01827D0,  0.02417D0,  0.03208D0,  0.03797D0,  0.04288D0,
53148      &     0.04733D0,  0.06440D0,  0.08769D0,  0.10463D0,  0.11818D0,
53149      &     0.12952D0,  0.14777D0,  0.16810D0,  0.19092D0,  0.20540D0,
53150      &     0.22008D0,  0.22352D0,  0.22043D0,  0.21103D0,  0.19791D0,
53151      &     0.18297D0,  0.16705D0,  0.15095D0,  0.13519D0,  0.12011D0,
53152      &     0.10577D0,  0.09241D0,  0.08008D0,  0.06881D0,  0.05866D0,
53153      &     0.04961D0,  0.04145D0,  0.03427D0,  0.02822D0,  0.02282D0,
53154      &     0.01822D0,  0.01441D0,  0.01116D0,  0.00637D0,  0.00332D0,
53155      &     0.00153D0,  0.00059D0,  0.00003D0,  0.00000D0/
53156       DATA (FMRS(1,2,I,30),I=1,49)/
53157      &     0.00737D0,  0.00972D0,  0.01283D0,  0.01510D0,  0.01695D0,
53158      &     0.01854D0,  0.02454D0,  0.03258D0,  0.03856D0,  0.04354D0,
53159      &     0.04805D0,  0.06532D0,  0.08879D0,  0.10580D0,  0.11936D0,
53160      &     0.13069D0,  0.14886D0,  0.16900D0,  0.19141D0,  0.20548D0,
53161      &     0.21937D0,  0.22213D0,  0.21850D0,  0.20855D0,  0.19507D0,
53162      &     0.17994D0,  0.16388D0,  0.14775D0,  0.13208D0,  0.11709D0,
53163      &     0.10291D0,  0.08973D0,  0.07760D0,  0.06655D0,  0.05664D0,
53164      &     0.04779D0,  0.03985D0,  0.03289D0,  0.02702D0,  0.02182D0,
53165      &     0.01738D0,  0.01372D0,  0.01060D0,  0.00602D0,  0.00312D0,
53166      &     0.00143D0,  0.00055D0,  0.00003D0,  0.00000D0/
53167       DATA (FMRS(1,2,I,31),I=1,49)/
53168      &     0.00746D0,  0.00985D0,  0.01300D0,  0.01530D0,  0.01718D0,
53169      &     0.01880D0,  0.02489D0,  0.03306D0,  0.03912D0,  0.04417D0,
53170      &     0.04873D0,  0.06619D0,  0.08983D0,  0.10690D0,  0.12048D0,
53171      &     0.13179D0,  0.14987D0,  0.16982D0,  0.19186D0,  0.20553D0,
53172      &     0.21868D0,  0.22081D0,  0.21666D0,  0.20623D0,  0.19242D0,
53173      &     0.17710D0,  0.16093D0,  0.14478D0,  0.12919D0,  0.11430D0,
53174      &     0.10026D0,  0.08726D0,  0.07533D0,  0.06447D0,  0.05479D0,
53175      &     0.04614D0,  0.03840D0,  0.03163D0,  0.02594D0,  0.02091D0,
53176      &     0.01662D0,  0.01309D0,  0.01009D0,  0.00571D0,  0.00295D0,
53177      &     0.00134D0,  0.00051D0,  0.00003D0,  0.00000D0/
53178       DATA (FMRS(1,2,I,32),I=1,49)/
53179      &     0.00755D0,  0.00997D0,  0.01317D0,  0.01550D0,  0.01741D0,
53180      &     0.01905D0,  0.02522D0,  0.03351D0,  0.03966D0,  0.04477D0,
53181      &     0.04938D0,  0.06700D0,  0.09079D0,  0.10792D0,  0.12151D0,
53182      &     0.13280D0,  0.15080D0,  0.17056D0,  0.19223D0,  0.20552D0,
53183      &     0.21797D0,  0.21951D0,  0.21489D0,  0.20403D0,  0.18991D0,
53184      &     0.17441D0,  0.15817D0,  0.14202D0,  0.12646D0,  0.11170D0,
53185      &     0.09780D0,  0.08498D0,  0.07322D0,  0.06257D0,  0.05306D0,
53186      &     0.04463D0,  0.03708D0,  0.03049D0,  0.02496D0,  0.02008D0,
53187      &     0.01594D0,  0.01252D0,  0.00963D0,  0.00542D0,  0.00279D0,
53188      &     0.00126D0,  0.00048D0,  0.00002D0,  0.00000D0/
53189       DATA (FMRS(1,2,I,33),I=1,49)/
53190      &     0.00764D0,  0.01009D0,  0.01333D0,  0.01570D0,  0.01763D0,
53191      &     0.01930D0,  0.02556D0,  0.03396D0,  0.04019D0,  0.04537D0,
53192      &     0.05004D0,  0.06783D0,  0.09177D0,  0.10895D0,  0.12254D0,
53193      &     0.13381D0,  0.15173D0,  0.17130D0,  0.19261D0,  0.20552D0,
53194      &     0.21726D0,  0.21822D0,  0.21313D0,  0.20185D0,  0.18743D0,
53195      &     0.17175D0,  0.15545D0,  0.13931D0,  0.12379D0,  0.10917D0,
53196      &     0.09540D0,  0.08276D0,  0.07118D0,  0.06072D0,  0.05139D0,
53197      &     0.04317D0,  0.03581D0,  0.02938D0,  0.02402D0,  0.01929D0,
53198      &     0.01528D0,  0.01198D0,  0.00920D0,  0.00516D0,  0.00264D0,
53199      &     0.00119D0,  0.00045D0,  0.00002D0,  0.00000D0/
53200       DATA (FMRS(1,2,I,34),I=1,49)/
53201      &     0.00773D0,  0.01021D0,  0.01350D0,  0.01590D0,  0.01786D0,
53202      &     0.01955D0,  0.02590D0,  0.03441D0,  0.04072D0,  0.04597D0,
53203      &     0.05068D0,  0.06863D0,  0.09272D0,  0.10994D0,  0.12353D0,
53204      &     0.13477D0,  0.15260D0,  0.17197D0,  0.19290D0,  0.20543D0,
53205      &     0.21649D0,  0.21688D0,  0.21134D0,  0.19965D0,  0.18497D0,
53206      &     0.16913D0,  0.15278D0,  0.13665D0,  0.12121D0,  0.10669D0,
53207      &     0.09308D0,  0.08060D0,  0.06921D0,  0.05894D0,  0.04980D0,
53208      &     0.04176D0,  0.03458D0,  0.02833D0,  0.02311D0,  0.01853D0,
53209      &     0.01465D0,  0.01147D0,  0.00879D0,  0.00491D0,  0.00250D0,
53210      &     0.00112D0,  0.00042D0,  0.00002D0,  0.00000D0/
53211       DATA (FMRS(1,2,I,35),I=1,49)/
53212      &     0.00781D0,  0.01033D0,  0.01366D0,  0.01609D0,  0.01808D0,
53213      &     0.01979D0,  0.02622D0,  0.03484D0,  0.04123D0,  0.04653D0,
53214      &     0.05129D0,  0.06941D0,  0.09362D0,  0.11088D0,  0.12448D0,
53215      &     0.13569D0,  0.15342D0,  0.17260D0,  0.19318D0,  0.20535D0,
53216      &     0.21576D0,  0.21562D0,  0.20966D0,  0.19759D0,  0.18266D0,
53217      &     0.16668D0,  0.15028D0,  0.13418D0,  0.11882D0,  0.10439D0,
53218      &     0.09094D0,  0.07861D0,  0.06739D0,  0.05729D0,  0.04834D0,
53219      &     0.04048D0,  0.03346D0,  0.02736D0,  0.02228D0,  0.01784D0,
53220      &     0.01408D0,  0.01100D0,  0.00842D0,  0.00468D0,  0.00237D0,
53221      &     0.00106D0,  0.00039D0,  0.00002D0,  0.00000D0/
53222       DATA (FMRS(1,2,I,36),I=1,49)/
53223      &     0.00790D0,  0.01044D0,  0.01382D0,  0.01628D0,  0.01829D0,
53224      &     0.02002D0,  0.02653D0,  0.03525D0,  0.04172D0,  0.04707D0,
53225      &     0.05188D0,  0.07013D0,  0.09447D0,  0.11177D0,  0.12535D0,
53226      &     0.13654D0,  0.15418D0,  0.17318D0,  0.19341D0,  0.20524D0,
53227      &     0.21505D0,  0.21440D0,  0.20805D0,  0.19563D0,  0.18048D0,
53228      &     0.16438D0,  0.14795D0,  0.13186D0,  0.11657D0,  0.10226D0,
53229      &     0.08894D0,  0.07676D0,  0.06571D0,  0.05578D0,  0.04700D0,
53230      &     0.03929D0,  0.03242D0,  0.02648D0,  0.02153D0,  0.01720D0,
53231      &     0.01356D0,  0.01058D0,  0.00808D0,  0.00448D0,  0.00226D0,
53232      &     0.00101D0,  0.00037D0,  0.00002D0,  0.00000D0/
53233       DATA (FMRS(1,2,I,37),I=1,49)/
53234      &     0.00798D0,  0.01056D0,  0.01397D0,  0.01646D0,  0.01850D0,
53235      &     0.02025D0,  0.02684D0,  0.03567D0,  0.04221D0,  0.04762D0,
53236      &     0.05247D0,  0.07087D0,  0.09532D0,  0.11265D0,  0.12622D0,
53237      &     0.13738D0,  0.15492D0,  0.17373D0,  0.19361D0,  0.20510D0,
53238      &     0.21429D0,  0.21315D0,  0.20641D0,  0.19365D0,  0.17829D0,
53239      &     0.16207D0,  0.14561D0,  0.12954D0,  0.11434D0,  0.10013D0,
53240      &     0.08696D0,  0.07493D0,  0.06406D0,  0.05429D0,  0.04567D0,
53241      &     0.03812D0,  0.03141D0,  0.02561D0,  0.02079D0,  0.01659D0,
53242      &     0.01305D0,  0.01017D0,  0.00775D0,  0.00428D0,  0.00215D0,
53243      &     0.00095D0,  0.00035D0,  0.00002D0,  0.00000D0/
53244       DATA (FMRS(1,2,I,38),I=1,49)/
53245      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53246      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53247      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53248      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53249      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53250      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53251      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53252      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53253      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53254      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53255       DATA (FMRS(1,3,I, 1),I=1,49)/
53256      &     3.68244D0,  3.61785D0,  3.55346D0,  3.51555D0,  3.48837D0,
53257      &     3.46702D0,  3.39811D0,  3.32177D0,  3.27072D0,  3.23000D0,
53258      &     3.19378D0,  3.05765D0,  2.86346D0,  2.71339D0,  2.58651D0,
53259      &     2.47572D0,  2.28777D0,  2.06245D0,  1.78178D0,  1.57726D0,
53260      &     1.30519D0,  1.14076D0,  1.03654D0,  0.95264D0,  0.89447D0,
53261      &     0.84663D0,  0.80090D0,  0.75325D0,  0.70217D0,  0.64784D0,
53262      &     0.59048D0,  0.53173D0,  0.47263D0,  0.41459D0,  0.35887D0,
53263      &     0.30634D0,  0.25757D0,  0.21335D0,  0.17415D0,  0.13936D0,
53264      &     0.10957D0,  0.08459D0,  0.06372D0,  0.03369D0,  0.01574D0,
53265      &     0.00625D0,  0.00195D0,  0.00005D0,  0.00000D0/
53266       DATA (FMRS(1,3,I, 2),I=1,49)/
53267      &     6.24307D0,  5.86376D0,  5.50631D0,  5.30646D0,  5.16844D0,
53268      &     5.06337D0,  4.74657D0,  4.44005D0,  4.26242D0,  4.13555D0,
53269      &     4.03502D0,  3.71094D0,  3.34882D0,  3.11051D0,  2.92600D0,
53270      &     2.77355D0,  2.52821D0,  2.24967D0,  1.91859D0,  1.68481D0,
53271      &     1.37946D0,  1.19535D0,  1.07673D0,  0.97819D0,  0.90750D0,
53272      &     0.84881D0,  0.79381D0,  0.73852D0,  0.68149D0,  0.62276D0,
53273      &     0.56254D0,  0.50226D0,  0.44285D0,  0.38548D0,  0.33123D0,
53274      &     0.28073D0,  0.23437D0,  0.19279D0,  0.15633D0,  0.12427D0,
53275      &     0.09707D0,  0.07445D0,  0.05572D0,  0.02906D0,  0.01339D0,
53276      &     0.00524D0,  0.00161D0,  0.00004D0,  0.00000D0/
53277       DATA (FMRS(1,3,I, 3),I=1,49)/
53278      &    11.05139D0,  9.94786D0,  8.95244D0,  8.41536D0,  8.05287D0,
53279      &     7.78166D0,  6.98996D0,  6.26416D0,  5.86369D0,  5.58758D0,
53280      &     5.37431D0,  4.72923D0,  4.08790D0,  3.70661D0,  3.43015D0,
53281      &     3.21204D0,  2.87740D0,  2.51734D0,  2.11023D0,  1.83283D0,
53282      &     1.47833D0,  1.26530D0,  1.12571D0,  1.00618D0,  0.91793D0,
53283      &     0.84442D0,  0.77712D0,  0.71204D0,  0.64770D0,  0.58389D0,
53284      &     0.52071D0,  0.45928D0,  0.40030D0,  0.34459D0,  0.29298D0,
53285      &     0.24576D0,  0.20309D0,  0.16540D0,  0.13284D0,  0.10462D0,
53286      &     0.08093D0,  0.06152D0,  0.04560D0,  0.02333D0,  0.01054D0,
53287      &     0.00404D0,  0.00122D0,  0.00003D0,  0.00000D0/
53288       DATA (FMRS(1,3,I, 4),I=1,49)/
53289      &    15.37825D0, 13.53065D0, 11.90193D0, 11.03924D0, 10.46378D0,
53290      &    10.03696D0,  8.81034D0,  7.71341D0,  7.12073D0,  6.71781D0,
53291      &     6.40918D0,  5.49848D0,  4.63276D0,  4.13943D0,  3.79203D0,
53292      &     3.52386D0,  3.12196D0,  2.70149D0,  2.23890D0,  1.93011D0,
53293      &     1.54059D0,  1.30714D0,  1.15286D0,  1.01886D0,  0.91881D0,
53294      &     0.83562D0,  0.76055D0,  0.68952D0,  0.62095D0,  0.55452D0,
53295      &     0.49011D0,  0.42861D0,  0.37052D0,  0.31647D0,  0.26702D0,
53296      &     0.22241D0,  0.18246D0,  0.14751D0,  0.11769D0,  0.09209D0,
53297      &     0.07074D0,  0.05343D0,  0.03933D0,  0.01985D0,  0.00885D0,
53298      &     0.00335D0,  0.00100D0,  0.00002D0,  0.00000D0/
53299       DATA (FMRS(1,3,I, 5),I=1,49)/
53300      &    20.54786D0, 17.73643D0, 15.30522D0, 14.03720D0, 13.19955D0,
53301      &    12.58273D0, 10.83264D0,  9.29877D0,  8.48369D0,  7.93560D0,
53302      &     7.51848D0,  6.31010D0,  5.19808D0,  4.58383D0,  4.16067D0,
53303      &     3.83948D0,  3.36690D0,  2.88348D0,  2.36367D0,  2.02276D0,
53304      &     1.59751D0,  1.34336D0,  1.17440D0,  1.02619D0,  0.91484D0,
53305      &     0.82260D0,  0.74049D0,  0.66431D0,  0.59227D0,  0.52387D0,
53306      &     0.45886D0,  0.39784D0,  0.34106D0,  0.28898D0,  0.24193D0,
53307      &     0.20003D0,  0.16291D0,  0.13075D0,  0.10361D0,  0.08049D0,
53308      &     0.06141D0,  0.04606D0,  0.03367D0,  0.01676D0,  0.00737D0,
53309      &     0.00275D0,  0.00081D0,  0.00002D0,  0.00000D0/
53310       DATA (FMRS(1,3,I, 6),I=1,49)/
53311      &    25.87997D0, 22.00579D0, 18.70564D0, 17.00514D0, 15.89031D0,
53312      &    15.07400D0, 12.78092D0, 10.80231D0,  9.76436D0,  9.07223D0,
53313      &     8.54820D0,  7.05063D0,  5.70461D0,  4.97765D0,  4.48471D0,
53314      &     4.11512D0,  3.57867D0,  3.03899D0,  2.46867D0,  2.09967D0,
53315      &     1.64344D0,  1.37152D0,  1.19009D0,  1.03003D0,  0.90944D0,
53316      &     0.81000D0,  0.72245D0,  0.64242D0,  0.56795D0,  0.49835D0,
53317      &     0.43318D0,  0.37285D0,  0.31739D0,  0.26712D0,  0.22217D0,
53318      &     0.18254D0,  0.14775D0,  0.11786D0,  0.09285D0,  0.07171D0,
53319      &     0.05439D0,  0.04056D0,  0.02948D0,  0.01450D0,  0.00631D0,
53320      &     0.00232D0,  0.00067D0,  0.00002D0,  0.00000D0/
53321       DATA (FMRS(1,3,I, 7),I=1,49)/
53322      &    31.48650D0, 26.43816D0, 22.19174D0, 20.02570D0, 18.61470D0,
53323      &    17.58636D0, 14.72161D0, 12.28168D0, 11.01532D0, 10.17669D0,
53324      &     9.54456D0,  7.75761D0,  6.18119D0,  5.34474D0,  4.78459D0,
53325      &     4.36861D0,  3.77149D0,  3.17878D0,  2.56125D0,  2.16614D0,
53326      &     1.68135D0,  1.39321D0,  1.20050D0,  1.02990D0,  0.90129D0,
53327      &     0.79577D0,  0.70378D0,  0.62075D0,  0.54457D0,  0.47435D0,
53328      &     0.40939D0,  0.34999D0,  0.29601D0,  0.24758D0,  0.20467D0,
53329      &     0.16718D0,  0.13453D0,  0.10670D0,  0.08361D0,  0.06425D0,
53330      &     0.04845D0,  0.03594D0,  0.02598D0,  0.01264D0,  0.00544D0,
53331      &     0.00198D0,  0.00057D0,  0.00001D0,  0.00000D0/
53332       DATA (FMRS(1,3,I, 8),I=1,49)/
53333      &    38.19562D0, 31.67731D0, 26.26192D0, 23.52700D0, 21.75654D0,
53334      &    20.47217D0, 16.92324D0, 13.93891D0, 12.40615D0, 11.39793D0,
53335      &    10.64140D0,  8.52490D0,  6.69053D0,  5.73328D0,  5.09966D0,
53336      &     4.63338D0,  3.97084D0,  3.32155D0,  2.65414D0,  2.23167D0,
53337      &     1.71719D0,  1.41235D0,  1.20819D0,  1.02708D0,  0.89064D0,
53338      &     0.77934D0,  0.68328D0,  0.59764D0,  0.52014D0,  0.44964D0,
53339      &     0.38523D0,  0.32704D0,  0.27476D0,  0.22832D0,  0.18758D0,
53340      &     0.15228D0,  0.12182D0,  0.09604D0,  0.07484D0,  0.05719D0,
53341      &     0.04288D0,  0.03164D0,  0.02275D0,  0.01095D0,  0.00466D0,
53342      &     0.00168D0,  0.00048D0,  0.00001D0,  0.00000D0/
53343       DATA (FMRS(1,3,I, 9),I=1,49)/
53344      &    44.69263D0, 36.69535D0, 30.11768D0, 26.82255D0, 24.70025D0,
53345      &    23.16639D0, 18.95601D0, 15.45187D0, 13.66736D0, 12.49995D0,
53346      &    11.62724D0,  9.20581D0,  7.13631D0,  6.07035D0,  5.37118D0,
53347      &     4.86033D0,  4.14011D0,  3.44140D0,  2.73081D0,  2.28485D0,
53348      &     1.74506D0,  1.42613D0,  1.21246D0,  1.02274D0,  0.88003D0,
53349      &     0.76424D0,  0.66513D0,  0.57765D0,  0.49935D0,  0.42889D0,
53350      &     0.36519D0,  0.30820D0,  0.25746D0,  0.21275D0,  0.17388D0,
53351      &     0.14043D0,  0.11178D0,  0.08767D0,  0.06799D0,  0.05171D0,
53352      &     0.03859D0,  0.02834D0,  0.02028D0,  0.00968D0,  0.00408D0,
53353      &     0.00146D0,  0.00041D0,  0.00001D0,  0.00000D0/
53354       DATA (FMRS(1,3,I,10),I=1,49)/
53355      &    51.42669D0, 41.84610D0, 34.03689D0, 30.15309D0, 27.66303D0,
53356      &    25.86942D0, 20.97504D0, 16.93923D0, 14.89954D0, 13.57172D0,
53357      &    12.58248D0,  9.85775D0,  7.55746D0,  6.38605D0,  5.62372D0,
53358      &     5.07013D0,  4.29501D0,  3.54959D0,  2.79853D0,  2.33075D0,
53359      &     1.76763D0,  1.43584D0,  1.21358D0,  1.01625D0,  0.86814D0,
53360      &     0.74860D0,  0.64707D0,  0.55827D0,  0.47958D0,  0.40941D0,
53361      &     0.34660D0,  0.29089D0,  0.24172D0,  0.19871D0,  0.16160D0,
53362      &     0.12988D0,  0.10289D0,  0.08032D0,  0.06202D0,  0.04695D0,
53363      &     0.03489D0,  0.02551D0,  0.01818D0,  0.00860D0,  0.00360D0,
53364      &     0.00128D0,  0.00036D0,  0.00001D0,  0.00000D0/
53365       DATA (FMRS(1,3,I,11),I=1,49)/
53366      &    57.20334D0, 46.22931D0, 37.34534D0, 32.95134D0, 30.14391D0,
53367      &    28.12686D0, 22.64741D0, 18.16087D0, 15.90648D0, 14.44434D0,
53368      &    13.35786D0, 10.38182D0,  7.89242D0,  6.63544D0,  5.82215D0,
53369      &     5.23423D0,  4.41529D0,  3.63279D0,  2.84983D0,  2.36499D0,
53370      &     1.78374D0,  1.44206D0,  1.21326D0,  1.01023D0,  0.85815D0,
53371      &     0.73593D0,  0.63273D0,  0.54312D0,  0.46430D0,  0.39449D0,
53372      &     0.33248D0,  0.27783D0,  0.22993D0,  0.18826D0,  0.15250D0,
53373      &     0.12212D0,  0.09637D0,  0.07495D0,  0.05770D0,  0.04352D0,
53374      &     0.03223D0,  0.02349D0,  0.01668D0,  0.00784D0,  0.00326D0,
53375      &     0.00115D0,  0.00032D0,  0.00001D0,  0.00000D0/
53376       DATA (FMRS(1,3,I,12),I=1,49)/
53377      &    70.62117D0, 56.29525D0, 44.85603D0, 39.26056D0, 35.71024D0,
53378      &    33.17249D0, 26.34026D0, 20.82458D0, 18.08508D0, 16.32156D0,
53379      &    15.01807D0, 11.48651D0,  8.58576D0,  7.14521D0,  6.22372D0,
53380      &     5.56345D0,  4.65284D0,  3.79371D0,  2.94559D0,  2.42633D0,
53381      &     1.80899D0,  1.44797D0,  1.20662D0,  0.99291D0,  0.83369D0,
53382      &     0.70687D0,  0.60112D0,  0.51056D0,  0.43209D0,  0.36357D0,
53383      &     0.30359D0,  0.25146D0,  0.20630D0,  0.16753D0,  0.13462D0,
53384      &     0.10696D0,  0.08376D0,  0.06466D0,  0.04944D0,  0.03702D0,
53385      &     0.02722D0,  0.01971D0,  0.01390D0,  0.00645D0,  0.00265D0,
53386      &     0.00093D0,  0.00026D0,  0.00001D0,  0.00000D0/
53387       DATA (FMRS(1,3,I,13),I=1,49)/
53388      &    83.50434D0, 65.82890D0, 51.87140D0, 45.10521D0, 40.83618D0,
53389      &    37.79736D0, 29.67546D0, 23.19327D0, 20.00393D0, 17.96325D0,
53390      &    16.46149D0, 12.42825D0,  9.16326D0,  7.56303D0,  6.54853D0,
53391      &     5.82663D0,  4.83880D0,  3.91602D0,  3.01472D0,  2.46779D0,
53392      &     1.82202D0,  1.44614D0,  1.19543D0,  0.97402D0,  0.80992D0,
53393      &     0.68027D0,  0.57325D0,  0.48262D0,  0.40504D0,  0.33808D0,
53394      &     0.28014D0,  0.23033D0,  0.18761D0,  0.15130D0,  0.12077D0,
53395      &     0.09534D0,  0.07419D0,  0.05692D0,  0.04326D0,  0.03220D0,
53396      &     0.02354D0,  0.01696D0,  0.01189D0,  0.00546D0,  0.00222D0,
53397      &     0.00077D0,  0.00021D0,  0.00001D0,  0.00000D0/
53398       DATA (FMRS(1,3,I,14),I=1,49)/
53399      &    99.26808D0, 77.34151D0, 60.22972D0, 52.01289D0, 46.85941D0,
53400      &    43.20707D0, 33.52017D0, 25.88194D0, 22.16110D0, 19.79557D0,
53401      &    18.06292D0, 13.45200D0,  9.77556D0,  7.99825D0,  6.88178D0,
53402      &     6.09288D0,  5.02224D0,  4.03207D0,  3.07569D0,  2.50055D0,
53403      &     1.82658D0,  1.43637D0,  1.17694D0,  0.94870D0,  0.78062D0,
53404      &     0.64903D0,  0.54156D0,  0.45166D0,  0.37564D0,  0.31084D0,
53405      &     0.25547D0,  0.20834D0,  0.16843D0,  0.13481D0,  0.10686D0,
53406      &     0.08378D0,  0.06476D0,  0.04934D0,  0.03727D0,  0.02756D0,
53407      &     0.02003D0,  0.01435D0,  0.01000D0,  0.00454D0,  0.00183D0,
53408      &     0.00063D0,  0.00017D0,  0.00000D0,  0.00000D0/
53409       DATA (FMRS(1,3,I,15),I=1,49)/
53410      &   117.13634D0, 90.22787D0, 69.46667D0, 59.58908D0, 53.42973D0,
53411      &    49.08310D0, 37.64029D0, 28.72286D0, 24.42074D0, 21.70264D0,
53412      &    19.72087D0, 14.49332D0, 10.38573D0,  8.42544D0,  7.20484D0,
53413      &     6.34818D0,  5.19436D0,  4.13748D0,  3.12707D0,  2.52493D0,
53414      &     1.82437D0,  1.42118D0,  1.15415D0,  0.92032D0,  0.74934D0,
53415      &     0.61673D0,  0.50955D0,  0.42103D0,  0.34703D0,  0.28471D0,
53416      &     0.23205D0,  0.18777D0,  0.15064D0,  0.11967D0,  0.09419D0,
53417      &     0.07336D0,  0.05631D0,  0.04263D0,  0.03201D0,  0.02354D0,
53418      &     0.01700D0,  0.01211D0,  0.00839D0,  0.00377D0,  0.00151D0,
53419      &     0.00052D0,  0.00014D0,  0.00000D0,  0.00000D0/
53420       DATA (FMRS(1,3,I,16),I=1,49)/
53421      &   134.87820D0,102.87527D0, 78.42588D0, 66.88609D0, 59.72612D0,
53422      &    54.69190D0, 41.52393D0, 31.36570D0, 26.50579D0, 23.45176D0,
53423      &    21.23395D0, 15.42784D0, 10.92244D0,  8.79593D0,  7.48170D0,
53424      &     6.56462D0,  5.33723D0,  4.22208D0,  3.16533D0,  2.54035D0,
53425      &     1.81781D0,  1.40424D0,  1.13142D0,  0.89365D0,  0.72095D0,
53426      &     0.58811D0,  0.48181D0,  0.39483D0,  0.32289D0,  0.26295D0,
53427      &     0.21278D0,  0.17100D0,  0.13629D0,  0.10758D0,  0.08415D0,
53428      &     0.06517D0,  0.04972D0,  0.03744D0,  0.02797D0,  0.02046D0,
53429      &     0.01470D0,  0.01042D0,  0.00719D0,  0.00321D0,  0.00127D0,
53430      &     0.00043D0,  0.00012D0,  0.00000D0,  0.00000D0/
53431       DATA (FMRS(1,3,I,17),I=1,49)/
53432      &   154.38010D0,116.63111D0, 88.06633D0, 74.68806D0, 66.42747D0,
53433      &    60.64011D0, 45.59593D0, 34.10384D0, 28.65021D0, 25.24085D0,
53434      &    22.77463D0, 16.36506D0, 11.45095D0,  9.15610D0,  7.74790D0,
53435      &     6.77064D0,  5.47057D0,  4.29852D0,  3.19720D0,  2.55058D0,
53436      &     1.80771D0,  1.38488D0,  1.10716D0,  0.86634D0,  0.69264D0,
53437      &     0.56014D0,  0.45511D0,  0.36997D0,  0.30026D0,  0.24276D0,
53438      &     0.19507D0,  0.15573D0,  0.12333D0,  0.09676D0,  0.07524D0,
53439      &     0.05794D0,  0.04395D0,  0.03292D0,  0.02447D0,  0.01781D0,
53440      &     0.01274D0,  0.00899D0,  0.00618D0,  0.00274D0,  0.00108D0,
53441      &     0.00037D0,  0.00010D0,  0.00000D0,  0.00000D0/
53442       DATA (FMRS(1,3,I,18),I=1,49)/
53443      &   171.60985D0,128.66806D0, 96.41977D0, 81.40891D0, 72.17590D0,
53444      &    65.72558D0, 49.04064D0, 36.39427D0, 30.43144D0, 26.71914D0,
53445      &    24.04215D0, 17.12464D0, 11.87120D0,  9.43856D0,  7.95410D0,
53446      &     6.92832D0,  5.57016D0,  4.35322D0,  3.21721D0,  2.55406D0,
53447      &     1.79608D0,  1.36671D0,  1.08575D0,  0.84319D0,  0.66925D0,
53448      &     0.53749D0,  0.43376D0,  0.35041D0,  0.28267D0,  0.22722D0,
53449      &     0.18154D0,  0.14418D0,  0.11359D0,  0.08871D0,  0.06865D0,
53450      &     0.05262D0,  0.03976D0,  0.02965D0,  0.02195D0,  0.01592D0,
53451      &     0.01135D0,  0.00798D0,  0.00547D0,  0.00241D0,  0.00095D0,
53452      &     0.00032D0,  0.00009D0,  0.00000D0,  0.00000D0/
53453       DATA (FMRS(1,3,I,19),I=1,49)/
53454      &   193.78899D0,144.01862D0,106.97157D0, 89.85031D0, 79.36631D0,
53455      &    72.06629D0, 53.29134D0, 39.18974D0, 32.59051D0, 28.50177D0,
53456      &    25.56394D0, 18.02311D0, 12.35926D0,  9.76179D0,  8.18702D0,
53457      &     7.10431D0,  5.67841D0,  4.40968D0,  3.23437D0,  2.55292D0,
53458      &     1.77867D0,  1.34261D0,  1.05865D0,  0.81484D0,  0.64125D0,
53459      &     0.51082D0,  0.40904D0,  0.32798D0,  0.26269D0,  0.20975D0,
53460      &     0.16651D0,  0.13145D0,  0.10293D0,  0.07994D0,  0.06153D0,
53461      &     0.04691D0,  0.03527D0,  0.02618D0,  0.01929D0,  0.01394D0,
53462      &     0.00989D0,  0.00693D0,  0.00473D0,  0.00207D0,  0.00081D0,
53463      &     0.00027D0,  0.00007D0,  0.00000D0,  0.00000D0/
53464       DATA (FMRS(1,3,I,20),I=1,49)/
53465      &   214.89481D0,158.49641D0,116.83355D0, 97.69725D0, 86.02460D0,
53466      &    77.91979D0, 57.17770D0, 41.71972D0, 34.53225D0, 30.09744D0,
53467      &    26.92084D0, 18.81368D0, 12.78187D0, 10.03830D0,  8.38419D0,
53468      &     7.25181D0,  5.76723D0,  4.45410D0,  3.24560D0,  2.54901D0,
53469      &     1.76164D0,  1.32048D0,  1.03446D0,  0.79010D0,  0.61721D0,
53470      &     0.48824D0,  0.38835D0,  0.30938D0,  0.24629D0,  0.19551D0,
53471      &     0.15438D0,  0.12122D0,  0.09444D0,  0.07299D0,  0.05594D0,
53472      &     0.04245D0,  0.03178D0,  0.02349D0,  0.01725D0,  0.01242D0,
53473      &     0.00879D0,  0.00614D0,  0.00418D0,  0.00182D0,  0.00071D0,
53474      &     0.00024D0,  0.00007D0,  0.00000D0,  0.00000D0/
53475       DATA (FMRS(1,3,I,21),I=1,49)/
53476      &   234.93695D0,172.12665D0,126.03609D0,104.98046D0, 92.18044D0,
53477      &    83.31506D0, 60.72429D0, 44.00365D0, 36.27307D0, 31.52044D0,
53478      &    28.12565D0, 19.50453D0, 13.14306D0, 10.27071D0,  8.54710D0,
53479      &     7.37140D0,  5.83642D0,  4.48556D0,  3.24949D0,  2.54059D0,
53480      &     1.74309D0,  1.29840D0,  1.01128D0,  0.76711D0,  0.59538D0,
53481      &     0.46805D0,  0.37012D0,  0.29319D0,  0.23219D0,  0.18337D0,
53482      &     0.14410D0,  0.11261D0,  0.08738D0,  0.06725D0,  0.05133D0,
53483      &     0.03881D0,  0.02895D0,  0.02133D0,  0.01562D0,  0.01121D0,
53484      &     0.00791D0,  0.00551D0,  0.00374D0,  0.00162D0,  0.00063D0,
53485      &     0.00021D0,  0.00006D0,  0.00000D0,  0.00000D0/
53486       DATA (FMRS(1,3,I,22),I=1,49)/
53487      &   261.98752D0,190.37146D0,138.25069D0,114.59908D0,100.28083D0,
53488      &    90.39440D0, 65.33586D0, 46.94503D0, 38.50155D0, 33.33386D0,
53489      &    29.65516D0, 20.37022D0, 13.58831D0, 10.55348D0,  8.74295D0,
53490      &     7.51340D0,  5.91633D0,  4.51953D0,  3.25037D0,  2.52703D0,
53491      &     1.71812D0,  1.26985D0,  0.98192D0,  0.73853D0,  0.56860D0,
53492      &     0.44359D0,  0.34825D0,  0.27396D0,  0.21556D0,  0.16918D0,
53493      &     0.13216D0,  0.10269D0,  0.07927D0,  0.06069D0,  0.04611D0,
53494      &     0.03471D0,  0.02577D0,  0.01891D0,  0.01380D0,  0.00987D0,
53495      &     0.00694D0,  0.00482D0,  0.00326D0,  0.00141D0,  0.00055D0,
53496      &     0.00018D0,  0.00005D0,  0.00000D0,  0.00000D0/
53497       DATA (FMRS(1,3,I,23),I=1,49)/
53498      &   289.01031D0,208.43709D0,150.23653D0,123.98669D0,108.15595D0,
53499      &    97.25583D0, 69.76177D0, 49.73855D0, 40.60409D0, 35.03629D0,
53500      &    31.08496D0, 21.16773D0, 13.99081D0, 10.80513D0,  8.91469D0,
53501      &     7.63597D0,  5.98282D0,  4.54504D0,  3.24687D0,  2.51128D0,
53502      &     1.69316D0,  1.24243D0,  0.95435D0,  0.71223D0,  0.54431D0,
53503      &     0.42170D0,  0.32889D0,  0.25710D0,  0.20110D0,  0.15697D0,
53504      &     0.12195D0,  0.09429D0,  0.07242D0,  0.05518D0,  0.04175D0,
53505      &     0.03132D0,  0.02316D0,  0.01693D0,  0.01232D0,  0.00878D0,
53506      &     0.00615D0,  0.00426D0,  0.00288D0,  0.00124D0,  0.00048D0,
53507      &     0.00016D0,  0.00004D0,  0.00000D0,  0.00000D0/
53508       DATA (FMRS(1,3,I,24),I=1,49)/
53509      &   315.12421D0,225.74153D0,161.61246D0,132.84715D0,115.55888D0,
53510      &   103.68510D0, 73.86555D0, 52.29894D0, 42.51674D0, 36.57598D0,
53511      &    32.37159D0, 21.87235D0, 14.33730D0, 11.01653D0,  9.05547D0,
53512      &     7.73389D0,  6.03187D0,  4.55934D0,  3.23736D0,  2.49207D0,
53513      &     1.66734D0,  1.21544D0,  0.92800D0,  0.68769D0,  0.52210D0,
53514      &     0.40197D0,  0.31164D0,  0.24228D0,  0.18850D0,  0.14640D0,
53515      &     0.11322D0,  0.08715D0,  0.06666D0,  0.05059D0,  0.03813D0,
53516      &     0.02850D0,  0.02101D0,  0.01531D0,  0.01111D0,  0.00790D0,
53517      &     0.00552D0,  0.00382D0,  0.00258D0,  0.00111D0,  0.00043D0,
53518      &     0.00014D0,  0.00004D0,  0.00000D0,  0.00000D0/
53519       DATA (FMRS(1,3,I,25),I=1,49)/
53520      &   342.80673D0,243.95296D0,173.49684D0,142.06322D0,123.23465D0,
53521      &   110.33495D0, 78.07693D0, 54.90473D0, 44.45325D0, 38.12883D0,
53522      &    33.66507D0, 22.57285D0, 14.67683D0, 11.22134D0,  9.19035D0,
53523      &     7.82660D0,  6.07682D0,  4.57070D0,  3.22605D0,  2.47181D0,
53524      &     1.64130D0,  1.18872D0,  0.90224D0,  0.66398D0,  0.50084D0,
53525      &     0.38326D0,  0.29541D0,  0.22842D0,  0.17680D0,  0.13666D0,
53526      &     0.10521D0,  0.08063D0,  0.06143D0,  0.04643D0,  0.03487D0,
53527      &     0.02598D0,  0.01909D0,  0.01388D0,  0.01004D0,  0.00712D0,
53528      &     0.00496D0,  0.00343D0,  0.00231D0,  0.00099D0,  0.00038D0,
53529      &     0.00013D0,  0.00004D0,  0.00000D0,  0.00000D0/
53530       DATA (FMRS(1,3,I,26),I=1,49)/
53531      &   370.71918D0,262.16998D0,185.28712D0,151.16048D0,130.78375D0,
53532      &   116.85600D0, 82.16776D0, 57.40948D0, 46.30192D0, 39.60334D0,
53533      &    34.88776D0, 23.22383D0, 14.98428D0, 11.40259D0,  9.30664D0,
53534      &     7.90402D0,  6.11093D0,  4.57472D0,  3.21035D0,  2.44880D0,
53535      &     1.61427D0,  1.16192D0,  0.87693D0,  0.64114D0,  0.48063D0,
53536      &     0.36570D0,  0.28035D0,  0.21566D0,  0.16615D0,  0.12784D0,
53537      &     0.09801D0,  0.07482D0,  0.05679D0,  0.04277D0,  0.03202D0,
53538      &     0.02378D0,  0.01743D0,  0.01263D0,  0.00912D0,  0.00645D0,
53539      &     0.00449D0,  0.00310D0,  0.00208D0,  0.00089D0,  0.00034D0,
53540      &     0.00012D0,  0.00003D0,  0.00000D0,  0.00000D0/
53541       DATA (FMRS(1,3,I,27),I=1,49)/
53542      &   398.31635D0,280.05777D0,196.78310D0,159.99336D0,138.09111D0,
53543      &   123.15311D0, 86.08746D0, 59.78946D0, 48.04917D0, 40.99130D0,
53544      &    36.03455D0, 23.82682D0, 15.26416D0, 11.56505D0,  9.40909D0,
53545      &     7.97073D0,  6.13825D0,  4.57511D0,  3.19349D0,  2.42581D0,
53546      &     1.58834D0,  1.13668D0,  0.85340D0,  0.62017D0,  0.46227D0,
53547      &     0.34987D0,  0.26689D0,  0.20435D0,  0.15674D0,  0.12011D0,
53548      &     0.09172D0,  0.06977D0,  0.05278D0,  0.03962D0,  0.02958D0,
53549      &     0.02190D0,  0.01601D0,  0.01157D0,  0.00834D0,  0.00589D0,
53550      &     0.00409D0,  0.00282D0,  0.00189D0,  0.00081D0,  0.00031D0,
53551      &     0.00010D0,  0.00003D0,  0.00000D0,  0.00000D0/
53552       DATA (FMRS(1,3,I,28),I=1,49)/
53553      &   425.10541D0,297.30496D0,207.79007D0,168.41481D0,145.03664D0,
53554      &   129.12375D0, 89.77434D0, 62.00834D0, 49.66874D0, 42.27205D0,
53555      &    37.08847D0, 24.37295D0, 15.51221D0, 11.70602D0,  9.49577D0,
53556      &     8.02523D0,  6.15776D0,  4.57120D0,  3.17506D0,  2.40249D0,
53557      &     1.56325D0,  1.11278D0,  0.83141D0,  0.60084D0,  0.44554D0,
53558      &     0.33559D0,  0.25483D0,  0.19432D0,  0.14844D0,  0.11333D0,
53559      &     0.08624D0,  0.06537D0,  0.04932D0,  0.03692D0,  0.02748D0,
53560      &     0.02030D0,  0.01481D0,  0.01068D0,  0.00768D0,  0.00541D0,
53561      &     0.00376D0,  0.00258D0,  0.00173D0,  0.00074D0,  0.00028D0,
53562      &     0.00010D0,  0.00003D0,  0.00000D0,  0.00000D0/
53563       DATA (FMRS(1,3,I,29),I=1,49)/
53564      &   452.96622D0,315.13217D0,219.09509D0,177.03108D0,152.12305D0,
53565      &   135.20210D0, 93.50108D0, 64.23380D0, 51.28493D0, 43.54515D0,
53566      &    38.13279D0, 24.90754D0, 15.75054D0, 11.83897D0,  9.57579D0,
53567      &     8.07414D0,  6.17308D0,  4.56436D0,  3.15482D0,  2.37807D0,
53568      &     1.53780D0,  1.08891D0,  0.80971D0,  0.58195D0,  0.42935D0,
53569      &     0.32187D0,  0.24333D0,  0.18479D0,  0.14060D0,  0.10697D0,
53570      &     0.08112D0,  0.06130D0,  0.04611D0,  0.03442D0,  0.02556D0,
53571      &     0.01884D0,  0.01371D0,  0.00987D0,  0.00709D0,  0.00499D0,
53572      &     0.00346D0,  0.00237D0,  0.00159D0,  0.00068D0,  0.00026D0,
53573      &     0.00009D0,  0.00002D0,  0.00000D0,  0.00000D0/
53574       DATA (FMRS(1,3,I,30),I=1,49)/
53575      &   481.05176D0,332.98895D0,230.34398D0,185.57016D0,159.12541D0,
53576      &   141.19426D0, 97.14677D0, 66.39220D0, 52.84356D0, 44.76743D0,
53577      &    39.13180D0, 25.41137D0, 15.96984D0, 11.95815D0,  9.64523D0,
53578      &     8.11468D0,  6.18265D0,  4.55389D0,  3.13269D0,  2.35270D0,
53579      &     1.51231D0,  1.06542D0,  0.78862D0,  0.56381D0,  0.41396D0,
53580      &     0.30893D0,  0.23257D0,  0.17592D0,  0.13335D0,  0.10111D0,
53581      &     0.07645D0,  0.05760D0,  0.04319D0,  0.03217D0,  0.02383D0,
53582      &     0.01753D0,  0.01273D0,  0.00915D0,  0.00656D0,  0.00461D0,
53583      &     0.00319D0,  0.00219D0,  0.00146D0,  0.00062D0,  0.00024D0,
53584      &     0.00008D0,  0.00002D0,  0.00000D0,  0.00000D0/
53585       DATA (FMRS(1,3,I,31),I=1,49)/
53586      &   508.69336D0,350.46606D0,241.29128D0,193.85184D0,165.89978D0,
53587      &   146.97998D0,100.64462D0, 68.44891D0, 54.32217D0, 45.92301D0,
53588      &    40.07352D0, 25.88124D0, 16.17098D0, 12.06571D0,  9.70659D0,
53589      &     8.14933D0,  6.18899D0,  4.54214D0,  3.11075D0,  2.32815D0,
53590      &     1.48813D0,  1.04340D0,  0.76902D0,  0.54710D0,  0.39988D0,
53591      &     0.29718D0,  0.22284D0,  0.16794D0,  0.12688D0,  0.09590D0,
53592      &     0.07230D0,  0.05433D0,  0.04063D0,  0.03020D0,  0.02232D0,
53593      &     0.01639D0,  0.01188D0,  0.00852D0,  0.00610D0,  0.00428D0,
53594      &     0.00296D0,  0.00203D0,  0.00136D0,  0.00057D0,  0.00022D0,
53595      &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
53596       DATA (FMRS(1,3,I,32),I=1,49)/
53597      &   535.18030D0,367.11212D0,251.65173D0,201.65910D0,172.26764D0,
53598      &   152.40591D0,103.89980D0, 70.34598D0, 55.67789D0, 46.97741D0,
53599      &    40.92907D0, 26.30087D0, 16.34517D0, 12.15570D0,  9.75539D0,
53600      &     8.17448D0,  6.18955D0,  4.52735D0,  3.08788D0,  2.30359D0,
53601      &     1.46475D0,  1.02248D0,  0.75063D0,  0.53161D0,  0.38695D0,
53602      &     0.28648D0,  0.21405D0,  0.16077D0,  0.12112D0,  0.09128D0,
53603      &     0.06863D0,  0.05145D0,  0.03839D0,  0.02847D0,  0.02101D0,
53604      &     0.01540D0,  0.01114D0,  0.00798D0,  0.00571D0,  0.00400D0,
53605      &     0.00276D0,  0.00189D0,  0.00126D0,  0.00054D0,  0.00020D0,
53606      &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
53607       DATA (FMRS(1,3,I,33),I=1,49)/
53608      &   563.08673D0,384.57391D0,262.47256D0,209.79239D0,178.88937D0,
53609      &   158.04028D0,107.26506D0, 72.29848D0, 57.06943D0, 48.05758D0,
53610      &    41.80413D0, 26.72791D0, 16.52149D0, 12.24650D0,  9.80451D0,
53611      &     8.19975D0,  6.19012D0,  4.51259D0,  3.06514D0,  2.27926D0,
53612      &     1.44171D0,  1.00196D0,  0.73265D0,  0.51654D0,  0.37443D0,
53613      &     0.27615D0,  0.20559D0,  0.15389D0,  0.11561D0,  0.08687D0,
53614      &     0.06514D0,  0.04872D0,  0.03627D0,  0.02685D0,  0.01977D0,
53615      &     0.01446D0,  0.01045D0,  0.00747D0,  0.00534D0,  0.00374D0,
53616      &     0.00258D0,  0.00176D0,  0.00118D0,  0.00050D0,  0.00019D0,
53617      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
53618       DATA (FMRS(1,3,I,34),I=1,49)/
53619      &   590.49207D0,401.61096D0,272.95639D0,217.63766D0,185.25558D0,
53620      &   163.44283D0,110.46277D0, 74.13376D0, 58.36747D0, 49.05885D0,
53621      &    42.61046D0, 27.11206D0, 16.67322D0, 12.31989D0,  9.84041D0,
53622      &     8.21457D0,  6.18338D0,  4.49312D0,  3.03982D0,  2.25340D0,
53623      &     1.41818D0,  0.98144D0,  0.71494D0,  0.50189D0,  0.36238D0,
53624      &     0.26631D0,  0.19763D0,  0.14748D0,  0.11046D0,  0.08279D0,
53625      &     0.06193D0,  0.04622D0,  0.03434D0,  0.02537D0,  0.01865D0,
53626      &     0.01362D0,  0.00983D0,  0.00702D0,  0.00501D0,  0.00351D0,
53627      &     0.00242D0,  0.00165D0,  0.00110D0,  0.00046D0,  0.00018D0,
53628      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
53629       DATA (FMRS(1,3,I,35),I=1,49)/
53630      &   617.67798D0,418.44214D0,283.27148D0,225.33791D0,191.49365D0,
53631      &   168.72942D0,113.57884D0, 75.91459D0, 59.62379D0, 50.02613D0,
53632      &    43.38823D0, 27.48080D0, 16.81807D0, 12.38969D0,  9.87443D0,
53633      &     8.22855D0,  6.17694D0,  4.47470D0,  3.01600D0,  2.22915D0,
53634      &     1.39622D0,  0.96237D0,  0.69854D0,  0.48839D0,  0.35132D0,
53635      &     0.25731D0,  0.19037D0,  0.14164D0,  0.10579D0,  0.07911D0,
53636      &     0.05904D0,  0.04396D0,  0.03261D0,  0.02405D0,  0.01765D0,
53637      &     0.01287D0,  0.00928D0,  0.00662D0,  0.00472D0,  0.00330D0,
53638      &     0.00227D0,  0.00155D0,  0.00103D0,  0.00044D0,  0.00017D0,
53639      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
53640       DATA (FMRS(1,3,I,36),I=1,49)/
53641      &   643.85529D0,434.56937D0,293.10349D0,232.65437D0,197.40677D0,
53642      &   173.73129D0,116.50865D0, 77.57690D0, 60.79072D0, 50.92106D0,
53643      &    44.10533D0, 27.81589D0, 16.94600D0, 12.44906D0,  9.90141D0,
53644      &     8.23759D0,  6.16791D0,  4.45540D0,  2.99242D0,  2.20560D0,
53645      &     1.37532D0,  0.94442D0,  0.68324D0,  0.47589D0,  0.34114D0,
53646      &     0.24908D0,  0.18375D0,  0.13636D0,  0.10159D0,  0.07580D0,
53647      &     0.05645D0,  0.04195D0,  0.03106D0,  0.02287D0,  0.01676D0,
53648      &     0.01221D0,  0.00879D0,  0.00626D0,  0.00446D0,  0.00311D0,
53649      &     0.00214D0,  0.00146D0,  0.00097D0,  0.00041D0,  0.00016D0,
53650      &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
53651       DATA (FMRS(1,3,I,37),I=1,49)/
53652      &   670.62598D0,450.98129D0,303.05762D0,240.03790D0,203.35986D0,
53653      &   178.75746D0,119.43383D0, 79.22430D0, 61.94125D0, 51.79964D0,
53654      &    44.80675D0, 28.13850D0, 17.06516D0, 12.50182D0,  9.92310D0,
53655      &     8.24227D0,  6.15572D0,  4.43398D0,  2.96756D0,  2.18122D0,
53656      &     1.35409D0,  0.92638D0,  0.66799D0,  0.46354D0,  0.33115D0,
53657      &     0.24105D0,  0.17731D0,  0.13125D0,  0.09756D0,  0.07262D0,
53658      &     0.05397D0,  0.04005D0,  0.02960D0,  0.02176D0,  0.01592D0,
53659      &     0.01159D0,  0.00833D0,  0.00593D0,  0.00422D0,  0.00294D0,
53660      &     0.00202D0,  0.00138D0,  0.00092D0,  0.00039D0,  0.00015D0,
53661      &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
53662       DATA (FMRS(1,3,I,38),I=1,49)/
53663      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53664      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53665      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53666      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53667      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53668      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53669      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53670      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53671      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53672      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53673       DATA (FMRS(1,4,I, 1),I=1,49)/
53674      &     0.86800D0,  0.76598D0,  0.67520D0,  0.62675D0,  0.59428D0,
53675      &     0.57013D0,  0.50046D0,  0.43816D0,  0.40484D0,  0.38253D0,
53676      &     0.36613D0,  0.31874D0,  0.27654D0,  0.25397D0,  0.23882D0,
53677      &     0.22750D0,  0.21099D0,  0.19387D0,  0.17401D0,  0.15872D0,
53678      &     0.13363D0,  0.11222D0,  0.09356D0,  0.07392D0,  0.05824D0,
53679      &     0.04613D0,  0.03700D0,  0.03017D0,  0.02498D0,  0.02125D0,
53680      &     0.01786D0,  0.01513D0,  0.01268D0,  0.01040D0,  0.00852D0,
53681      &     0.00674D0,  0.00520D0,  0.00388D0,  0.00299D0,  0.00201D0,
53682      &     0.00134D0,  0.00094D0,  0.00051D0,  0.00021D0,  0.00007D0,
53683      &     0.00003D0, -0.00001D0,  0.00000D0,  0.00000D0/
53684       DATA (FMRS(1,4,I, 2),I=1,49)/
53685      &     0.88205D0,  0.77983D0,  0.68869D0,  0.63997D0,  0.60729D0,
53686      &     0.58296D0,  0.51264D0,  0.44961D0,  0.41580D0,  0.39312D0,
53687      &     0.37640D0,  0.32792D0,  0.28442D0,  0.26097D0,  0.24515D0,
53688      &     0.23328D0,  0.21590D0,  0.19782D0,  0.17683D0,  0.16077D0,
53689      &     0.13467D0,  0.11273D0,  0.09381D0,  0.07406D0,  0.05839D0,
53690      &     0.04632D0,  0.03722D0,  0.03037D0,  0.02516D0,  0.02135D0,
53691      &     0.01792D0,  0.01513D0,  0.01262D0,  0.01032D0,  0.00842D0,
53692      &     0.00664D0,  0.00510D0,  0.00380D0,  0.00291D0,  0.00197D0,
53693      &     0.00130D0,  0.00091D0,  0.00051D0,  0.00020D0,  0.00007D0,
53694      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
53695       DATA (FMRS(1,4,I, 3),I=1,49)/
53696      &     0.91886D0,  0.81356D0,  0.71953D0,  0.66920D0,  0.63541D0,
53697      &     0.61023D0,  0.53738D0,  0.47189D0,  0.43666D0,  0.41295D0,
53698      &     0.39539D0,  0.34428D0,  0.29794D0,  0.27277D0,  0.25567D0,
53699      &     0.24279D0,  0.22388D0,  0.20416D0,  0.18131D0,  0.16398D0,
53700      &     0.13630D0,  0.11352D0,  0.09418D0,  0.07425D0,  0.05857D0,
53701      &     0.04653D0,  0.03744D0,  0.03056D0,  0.02532D0,  0.02139D0,
53702      &     0.01791D0,  0.01504D0,  0.01246D0,  0.01016D0,  0.00822D0,
53703      &     0.00648D0,  0.00493D0,  0.00368D0,  0.00278D0,  0.00188D0,
53704      &     0.00124D0,  0.00086D0,  0.00051D0,  0.00020D0,  0.00006D0,
53705      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
53706       DATA (FMRS(1,4,I, 4),I=1,49)/
53707      &     0.95997D0,  0.84981D0,  0.75147D0,  0.69884D0,  0.66351D0,
53708      &     0.63718D0,  0.56100D0,  0.49247D0,  0.45556D0,  0.43069D0,
53709      &     0.41221D0,  0.35830D0,  0.30918D0,  0.28239D0,  0.26415D0,
53710      &     0.25039D0,  0.23017D0,  0.20908D0,  0.18474D0,  0.16642D0,
53711      &     0.13752D0,  0.11409D0,  0.09444D0,  0.07437D0,  0.05864D0,
53712      &     0.04662D0,  0.03752D0,  0.03063D0,  0.02535D0,  0.02135D0,
53713      &     0.01783D0,  0.01492D0,  0.01232D0,  0.01000D0,  0.00803D0,
53714      &     0.00631D0,  0.00479D0,  0.00358D0,  0.00268D0,  0.00180D0,
53715      &     0.00120D0,  0.00084D0,  0.00049D0,  0.00020D0,  0.00006D0,
53716      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53717       DATA (FMRS(1,4,I, 5),I=1,49)/
53718      &     1.02269D0,  0.90363D0,  0.79759D0,  0.74093D0,  0.70294D0,
53719      &     0.67465D0,  0.59289D0,  0.51944D0,  0.47990D0,  0.45324D0,
53720      &     0.43337D0,  0.37541D0,  0.32249D0,  0.29359D0,  0.27391D0,
53721      &     0.25907D0,  0.23726D0,  0.21456D0,  0.18851D0,  0.16906D0,
53722      &     0.13883D0,  0.11469D0,  0.09468D0,  0.07442D0,  0.05863D0,
53723      &     0.04662D0,  0.03753D0,  0.03061D0,  0.02531D0,  0.02124D0,
53724      &     0.01767D0,  0.01472D0,  0.01211D0,  0.00977D0,  0.00782D0,
53725      &     0.00614D0,  0.00464D0,  0.00341D0,  0.00257D0,  0.00173D0,
53726      &     0.00113D0,  0.00080D0,  0.00046D0,  0.00018D0,  0.00005D0,
53727      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
53728       DATA (FMRS(1,4,I, 6),I=1,49)/
53729      &     1.08763D0,  0.95875D0,  0.84428D0,  0.78326D0,  0.74239D0,
53730      &     0.71199D0,  0.62427D0,  0.54563D0,  0.50333D0,  0.47482D0,
53731      &     0.45353D0,  0.39146D0,  0.33478D0,  0.30385D0,  0.28279D0,
53732      &     0.26692D0,  0.24362D0,  0.21944D0,  0.19183D0,  0.17138D0,
53733      &     0.13995D0,  0.11519D0,  0.09486D0,  0.07444D0,  0.05860D0,
53734      &     0.04659D0,  0.03750D0,  0.03056D0,  0.02523D0,  0.02111D0,
53735      &     0.01751D0,  0.01454D0,  0.01191D0,  0.00957D0,  0.00764D0,
53736      &     0.00598D0,  0.00450D0,  0.00328D0,  0.00247D0,  0.00167D0,
53737      &     0.00107D0,  0.00076D0,  0.00044D0,  0.00016D0,  0.00005D0,
53738      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
53739       DATA (FMRS(1,4,I, 7),I=1,49)/
53740      &     1.16556D0,  1.02401D0,  0.89875D0,  0.83219D0,  0.78769D0,
53741      &     0.75465D0,  0.65951D0,  0.57450D0,  0.52889D0,  0.49818D0,
53742      &     0.47520D0,  0.40838D0,  0.34748D0,  0.31432D0,  0.29177D0,
53743      &     0.27481D0,  0.24995D0,  0.22424D0,  0.19505D0,  0.17361D0,
53744      &     0.14101D0,  0.11563D0,  0.09500D0,  0.07441D0,  0.05852D0,
53745      &     0.04652D0,  0.03740D0,  0.03045D0,  0.02509D0,  0.02093D0,
53746      &     0.01733D0,  0.01434D0,  0.01170D0,  0.00939D0,  0.00744D0,
53747      &     0.00582D0,  0.00436D0,  0.00318D0,  0.00238D0,  0.00161D0,
53748      &     0.00104D0,  0.00073D0,  0.00042D0,  0.00014D0,  0.00005D0,
53749      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
53750       DATA (FMRS(1,4,I, 8),I=1,49)/
53751      &     1.26306D0,  1.10484D0,  0.96554D0,  0.89180D0,  0.84263D0,
53752      &     0.80618D0,  0.70157D0,  0.60853D0,  0.55877D0,  0.52532D0,
53753      &     0.50028D0,  0.42768D0,  0.36175D0,  0.32597D0,  0.30171D0,
53754      &     0.28349D0,  0.25687D0,  0.22944D0,  0.19851D0,  0.17597D0,
53755      &     0.14210D0,  0.11607D0,  0.09509D0,  0.07433D0,  0.05839D0,
53756      &     0.04638D0,  0.03725D0,  0.03028D0,  0.02490D0,  0.02071D0,
53757      &     0.01710D0,  0.01411D0,  0.01147D0,  0.00917D0,  0.00724D0,
53758      &     0.00565D0,  0.00421D0,  0.00306D0,  0.00228D0,  0.00155D0,
53759      &     0.00101D0,  0.00070D0,  0.00040D0,  0.00013D0,  0.00005D0,
53760      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
53761       DATA (FMRS(1,4,I, 9),I=1,49)/
53762      &     1.36120D0,  1.18550D0,  1.03156D0,  0.95040D0,  0.89642D0,
53763      &     0.85647D0,  0.74219D0,  0.64102D0,  0.58710D0,  0.55092D0,
53764      &     0.52385D0,  0.44558D0,  0.37481D0,  0.33656D0,  0.31068D0,
53765      &     0.29130D0,  0.26304D0,  0.23405D0,  0.20153D0,  0.17803D0,
53766      &     0.14303D0,  0.11643D0,  0.09515D0,  0.07423D0,  0.05825D0,
53767      &     0.04622D0,  0.03709D0,  0.03010D0,  0.02471D0,  0.02052D0,
53768      &     0.01688D0,  0.01389D0,  0.01125D0,  0.00895D0,  0.00706D0,
53769      &     0.00550D0,  0.00409D0,  0.00295D0,  0.00220D0,  0.00150D0,
53770      &     0.00098D0,  0.00067D0,  0.00039D0,  0.00013D0,  0.00005D0,
53771      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
53772       DATA (FMRS(1,4,I,10),I=1,49)/
53773      &     1.47041D0,  1.27446D0,  1.10370D0,  1.01406D0,  0.95460D0,
53774      &     0.91068D0,  0.78549D0,  0.67526D0,  0.61674D0,  0.57757D0,
53775      &     0.54827D0,  0.46388D0,  0.38797D0,  0.34713D0,  0.31960D0,
53776      &     0.29901D0,  0.26910D0,  0.23853D0,  0.20444D0,  0.17998D0,
53777      &     0.14388D0,  0.11673D0,  0.09517D0,  0.07410D0,  0.05807D0,
53778      &     0.04602D0,  0.03690D0,  0.02989D0,  0.02450D0,  0.02029D0,
53779      &     0.01665D0,  0.01365D0,  0.01102D0,  0.00875D0,  0.00689D0,
53780      &     0.00534D0,  0.00396D0,  0.00285D0,  0.00213D0,  0.00144D0,
53781      &     0.00094D0,  0.00064D0,  0.00038D0,  0.00013D0,  0.00004D0,
53782      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
53783       DATA (FMRS(1,4,I,11),I=1,49)/
53784      &     1.56638D0,  1.35212D0,  1.16625D0,  1.06903D0,  1.00469D0,
53785      &     0.95725D0,  0.82240D0,  0.70420D0,  0.64167D0,  0.59990D0,
53786      &     0.56868D0,  0.47904D0,  0.39878D0,  0.35576D0,  0.32683D0,
53787      &     0.30525D0,  0.27397D0,  0.24210D0,  0.20674D0,  0.18151D0,
53788      &     0.14453D0,  0.11694D0,  0.09517D0,  0.07398D0,  0.05791D0,
53789      &     0.04585D0,  0.03673D0,  0.02971D0,  0.02433D0,  0.02010D0,
53790      &     0.01646D0,  0.01346D0,  0.01083D0,  0.00860D0,  0.00675D0,
53791      &     0.00520D0,  0.00385D0,  0.00277D0,  0.00207D0,  0.00139D0,
53792      &     0.00090D0,  0.00062D0,  0.00037D0,  0.00013D0,  0.00004D0,
53793      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
53794       DATA (FMRS(1,4,I,12),I=1,49)/
53795      &     1.80214D0,  1.54109D0,  1.31694D0,  1.20067D0,  1.12412D0,
53796      &     1.06789D0,  0.90916D0,  0.77146D0,  0.69919D0,  0.65116D0,
53797      &     0.61534D0,  0.51323D0,  0.42280D0,  0.37478D0,  0.34269D0,
53798      &     0.31886D0,  0.28449D0,  0.24976D0,  0.21162D0,  0.18471D0,
53799      &     0.14585D0,  0.11732D0,  0.09509D0,  0.07364D0,  0.05748D0,
53800      &     0.04542D0,  0.03629D0,  0.02928D0,  0.02389D0,  0.01964D0,
53801      &     0.01603D0,  0.01303D0,  0.01043D0,  0.00824D0,  0.00644D0,
53802      &     0.00493D0,  0.00365D0,  0.00261D0,  0.00193D0,  0.00129D0,
53803      &     0.00082D0,  0.00058D0,  0.00033D0,  0.00012D0,  0.00003D0,
53804      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53805       DATA (FMRS(1,4,I,13),I=1,49)/
53806      &     2.04055D0,  1.73004D0,  1.46588D0,  1.32988D0,  1.24076D0,
53807      &     1.17553D0,  0.99250D0,  0.83521D0,  0.75328D0,  0.69907D0,
53808      &     0.65875D0,  0.54456D0,  0.44445D0,  0.39176D0,  0.35673D0,
53809      &     0.33084D0,  0.29368D0,  0.25636D0,  0.21574D0,  0.18736D0,
53810      &     0.14688D0,  0.11755D0,  0.09493D0,  0.07328D0,  0.05705D0,
53811      &     0.04498D0,  0.03587D0,  0.02887D0,  0.02347D0,  0.01921D0,
53812      &     0.01564D0,  0.01265D0,  0.01010D0,  0.00793D0,  0.00617D0,
53813      &     0.00472D0,  0.00348D0,  0.00248D0,  0.00181D0,  0.00123D0,
53814      &     0.00077D0,  0.00054D0,  0.00031D0,  0.00011D0,  0.00003D0,
53815      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53816       DATA (FMRS(1,4,I,14),I=1,49)/
53817      &     2.34878D0,  1.97162D0,  1.65417D0,  1.49212D0,  1.38650D0,
53818      &     1.30951D0,  1.09500D0,  0.91263D0,  0.81846D0,  0.75649D0,
53819      &     0.71054D0,  0.58140D0,  0.46952D0,  0.41122D0,  0.37271D0,
53820      &     0.34438D0,  0.30396D0,  0.26367D0,  0.22023D0,  0.19019D0,
53821      &     0.14790D0,  0.11770D0,  0.09464D0,  0.07279D0,  0.05650D0,
53822      &     0.04444D0,  0.03534D0,  0.02838D0,  0.02299D0,  0.01873D0,
53823      &     0.01518D0,  0.01221D0,  0.00971D0,  0.00758D0,  0.00587D0,
53824      &     0.00448D0,  0.00329D0,  0.00233D0,  0.00171D0,  0.00117D0,
53825      &     0.00073D0,  0.00051D0,  0.00028D0,  0.00010D0,  0.00003D0,
53826      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53827       DATA (FMRS(1,4,I,15),I=1,49)/
53828      &     2.72076D0,  2.25974D0,  1.87603D0,  1.68193D0,  1.55614D0,
53829      &     1.46482D0,  1.21228D0,  1.00004D0,  0.89145D0,  0.82040D0,
53830      &     0.76790D0,  0.62156D0,  0.49638D0,  0.43184D0,  0.38951D0,
53831      &     0.35852D0,  0.31456D0,  0.27109D0,  0.22467D0,  0.19292D0,
53832      &     0.14878D0,  0.11770D0,  0.09423D0,  0.07216D0,  0.05583D0,
53833      &     0.04380D0,  0.03471D0,  0.02777D0,  0.02242D0,  0.01821D0,
53834      &     0.01468D0,  0.01176D0,  0.00931D0,  0.00721D0,  0.00560D0,
53835      &     0.00425D0,  0.00310D0,  0.00215D0,  0.00160D0,  0.00107D0,
53836      &     0.00067D0,  0.00046D0,  0.00026D0,  0.00009D0,  0.00003D0,
53837      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53838       DATA (FMRS(1,4,I,16),I=1,49)/
53839      &     3.10372D0,  2.55317D0,  2.09952D0,  1.87189D0,  1.72513D0,
53840      &     1.61899D0,  1.32738D0,  1.08482D0,  0.96174D0,  0.88163D0,
53841      &     0.82262D0,  0.65935D0,  0.52128D0,  0.45078D0,  0.40481D0,
53842      &     0.37132D0,  0.32407D0,  0.27766D0,  0.22852D0,  0.19522D0,
53843      &     0.14943D0,  0.11759D0,  0.09376D0,  0.07153D0,  0.05518D0,
53844      &     0.04316D0,  0.03411D0,  0.02721D0,  0.02189D0,  0.01771D0,
53845      &     0.01421D0,  0.01135D0,  0.00894D0,  0.00691D0,  0.00532D0,
53846      &     0.00403D0,  0.00292D0,  0.00202D0,  0.00150D0,  0.00098D0,
53847      &     0.00063D0,  0.00043D0,  0.00024D0,  0.00009D0,  0.00003D0,
53848      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53849       DATA (FMRS(1,4,I,17),I=1,49)/
53850      &     3.53791D0,  2.88253D0,  2.34786D0,  2.08172D0,  1.91099D0,
53851      &     1.78798D0,  1.45224D0,  1.17581D0,  1.03669D0,  0.94660D0,
53852      &     0.88048D0,  0.69881D0,  0.54694D0,  0.47011D0,  0.42034D0,
53853      &     0.38424D0,  0.33357D0,  0.28414D0,  0.23224D0,  0.19739D0,
53854      &     0.14997D0,  0.11738D0,  0.09322D0,  0.07083D0,  0.05448D0,
53855      &     0.04248D0,  0.03349D0,  0.02663D0,  0.02135D0,  0.01720D0,
53856      &     0.01373D0,  0.01094D0,  0.00857D0,  0.00662D0,  0.00504D0,
53857      &     0.00382D0,  0.00275D0,  0.00191D0,  0.00140D0,  0.00091D0,
53858      &     0.00060D0,  0.00040D0,  0.00021D0,  0.00008D0,  0.00002D0,
53859      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53860       DATA (FMRS(1,4,I,18),I=1,49)/
53861      &     3.93600D0,  3.18179D0,  2.57144D0,  2.26962D0,  2.07679D0,
53862      &     1.93828D0,  1.56224D0,  1.25519D0,  1.10169D0,  1.00271D0,
53863      &     0.93026D0,  0.73238D0,  0.56848D0,  0.48622D0,  0.43319D0,
53864      &     0.39487D0,  0.34131D0,  0.28936D0,  0.23517D0,  0.19905D0,
53865      &     0.15030D0,  0.11713D0,  0.09270D0,  0.07021D0,  0.05385D0,
53866      &     0.04190D0,  0.03295D0,  0.02612D0,  0.02087D0,  0.01677D0,
53867      &     0.01334D0,  0.01060D0,  0.00827D0,  0.00637D0,  0.00486D0,
53868      &     0.00366D0,  0.00263D0,  0.00181D0,  0.00134D0,  0.00088D0,
53869      &     0.00056D0,  0.00038D0,  0.00020D0,  0.00007D0,  0.00002D0,
53870      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53871       DATA (FMRS(1,4,I,19),I=1,49)/
53872      &     4.46512D0,  3.57604D0,  2.86339D0,  2.51369D0,  2.29136D0,
53873      &     2.13222D0,  1.70289D0,  1.35573D0,  1.18356D0,  1.07308D0,
53874      &     0.99248D0,  0.77387D0,  0.59477D0,  0.50571D0,  0.44864D0,
53875      &     0.40759D0,  0.35048D0,  0.29545D0,  0.23852D0,  0.20087D0,
53876      &     0.15057D0,  0.11671D0,  0.09200D0,  0.06939D0,  0.05304D0,
53877      &     0.04116D0,  0.03225D0,  0.02548D0,  0.02030D0,  0.01627D0,
53878      &     0.01289D0,  0.01018D0,  0.00793D0,  0.00608D0,  0.00462D0,
53879      &     0.00346D0,  0.00247D0,  0.00170D0,  0.00124D0,  0.00082D0,
53880      &     0.00052D0,  0.00036D0,  0.00020D0,  0.00007D0,  0.00002D0,
53881      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53882       DATA (FMRS(1,4,I,20),I=1,49)/
53883      &     4.98110D0,  3.95717D0,  3.14315D0,  2.74636D0,  2.49515D0,
53884      &     2.31589D0,  1.83490D0,  1.44924D0,  1.25928D0,  1.13790D0,
53885      &     1.04961D0,  0.81156D0,  0.61839D0,  0.52309D0,  0.46234D0,
53886      &     0.41880D0,  0.35851D0,  0.30072D0,  0.24136D0,  0.20237D0,
53887      &     0.15073D0,  0.11629D0,  0.09134D0,  0.06865D0,  0.05232D0,
53888      &     0.04048D0,  0.03163D0,  0.02492D0,  0.01980D0,  0.01582D0,
53889      &     0.01251D0,  0.00983D0,  0.00765D0,  0.00583D0,  0.00441D0,
53890      &     0.00330D0,  0.00234D0,  0.00161D0,  0.00116D0,  0.00076D0,
53891      &     0.00049D0,  0.00034D0,  0.00019D0,  0.00006D0,  0.00002D0,
53892      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53893       DATA (FMRS(1,4,I,21),I=1,49)/
53894      &     5.48855D0,  4.32906D0,  3.41400D0,  2.97058D0,  2.69088D0,
53895      &     2.49185D0,  1.96033D0,  1.53734D0,  1.33025D0,  1.19843D0,
53896      &     1.10279D0,  0.84628D0,  0.63987D0,  0.53877D0,  0.47461D0,
53897      &     0.42879D0,  0.36557D0,  0.30530D0,  0.24373D0,  0.20356D0,
53898      &     0.15074D0,  0.11580D0,  0.09065D0,  0.06792D0,  0.05161D0,
53899      &     0.03984D0,  0.03104D0,  0.02440D0,  0.01932D0,  0.01538D0,
53900      &     0.01214D0,  0.00950D0,  0.00738D0,  0.00561D0,  0.00423D0,
53901      &     0.00315D0,  0.00224D0,  0.00152D0,  0.00110D0,  0.00072D0,
53902      &     0.00045D0,  0.00032D0,  0.00018D0,  0.00006D0,  0.00002D0,
53903      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53904       DATA (FMRS(1,4,I,22),I=1,49)/
53905      &     6.18910D0,  4.83835D0,  3.78189D0,  3.27368D0,  2.95458D0,
53906      &     2.72828D0,  2.12748D0,  1.65375D0,  1.42355D0,  1.27771D0,
53907      &     1.17223D0,  0.89116D0,  0.66734D0,  0.55867D0,  0.49010D0,
53908      &     0.44134D0,  0.37438D0,  0.31092D0,  0.24658D0,  0.20493D0,
53909      &     0.15066D0,  0.11512D0,  0.08974D0,  0.06696D0,  0.05069D0,
53910      &     0.03901D0,  0.03030D0,  0.02374D0,  0.01874D0,  0.01485D0,
53911      &     0.01168D0,  0.00911D0,  0.00704D0,  0.00533D0,  0.00400D0,
53912      &     0.00297D0,  0.00211D0,  0.00142D0,  0.00104D0,  0.00068D0,
53913      &     0.00042D0,  0.00029D0,  0.00017D0,  0.00005D0,  0.00002D0,
53914      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53915       DATA (FMRS(1,4,I,23),I=1,49)/
53916      &     6.90776D0,  5.35634D0,  4.15288D0,  3.57780D0,  3.21822D0,
53917      &     2.96398D0,  2.29266D0,  1.76775D0,  1.51442D0,  1.35462D0,
53918      &     1.23937D0,  0.93411D0,  0.69332D0,  0.57734D0,  0.50454D0,
53919      &     0.45297D0,  0.38246D0,  0.31600D0,  0.24910D0,  0.20608D0,
53920      &     0.15048D0,  0.11442D0,  0.08886D0,  0.06603D0,  0.04982D0,
53921      &     0.03823D0,  0.02961D0,  0.02314D0,  0.01820D0,  0.01437D0,
53922      &     0.01125D0,  0.00875D0,  0.00671D0,  0.00507D0,  0.00380D0,
53923      &     0.00282D0,  0.00198D0,  0.00134D0,  0.00099D0,  0.00065D0,
53924      &     0.00039D0,  0.00026D0,  0.00015D0,  0.00005D0,  0.00002D0,
53925      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53926       DATA (FMRS(1,4,I,24),I=1,49)/
53927      &     7.62426D0,  5.86871D0,  4.51692D0,  3.87481D0,  3.47482D0,
53928      &     3.19280D0,  2.45168D0,  1.87657D0,  1.60070D0,  1.42736D0,
53929      &     1.30266D0,  0.97414D0,  0.71722D0,  0.59437D0,  0.51760D0,
53930      &     0.46341D0,  0.38962D0,  0.32042D0,  0.25117D0,  0.20694D0,
53931      &     0.15017D0,  0.11367D0,  0.08795D0,  0.06511D0,  0.04897D0,
53932      &     0.03748D0,  0.02894D0,  0.02253D0,  0.01769D0,  0.01392D0,
53933      &     0.01087D0,  0.00842D0,  0.00645D0,  0.00484D0,  0.00362D0,
53934      &     0.00267D0,  0.00187D0,  0.00128D0,  0.00093D0,  0.00060D0,
53935      &     0.00037D0,  0.00024D0,  0.00014D0,  0.00004D0,  0.00002D0,
53936      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53937       DATA (FMRS(1,4,I,25),I=1,49)/
53938      &     8.39819D0,  6.41814D0,  4.90446D0,  4.18965D0,  3.74601D0,
53939      &     3.43405D0,  2.61811D0,  1.98959D0,  1.68991D0,  1.50231D0,
53940      &     1.36770D0,  1.01493D0,  0.74134D0,  0.61144D0,  0.53063D0,
53941      &     0.47380D0,  0.39668D0,  0.32474D0,  0.25316D0,  0.20772D0,
53942      &     0.14981D0,  0.11289D0,  0.08703D0,  0.06420D0,  0.04813D0,
53943      &     0.03673D0,  0.02828D0,  0.02194D0,  0.01719D0,  0.01349D0,
53944      &     0.01049D0,  0.00810D0,  0.00620D0,  0.00463D0,  0.00344D0,
53945      &     0.00252D0,  0.00177D0,  0.00122D0,  0.00086D0,  0.00056D0,
53946      &     0.00034D0,  0.00023D0,  0.00012D0,  0.00004D0,  0.00001D0,
53947      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53948       DATA (FMRS(1,4,I,26),I=1,49)/
53949      &     9.19912D0,  6.98269D0,  5.29980D0,  4.50945D0,  4.02062D0,
53950      &     3.67776D0,  2.78497D0,  2.10203D0,  1.77824D0,  1.57626D0,
53951      &     1.43169D0,  1.05466D0,  0.76454D0,  0.62772D0,  0.54298D0,
53952      &     0.48357D0,  0.40325D0,  0.32867D0,  0.25488D0,  0.20830D0,
53953      &     0.14936D0,  0.11205D0,  0.08608D0,  0.06328D0,  0.04729D0,
53954      &     0.03598D0,  0.02762D0,  0.02140D0,  0.01669D0,  0.01307D0,
53955      &     0.01014D0,  0.00780D0,  0.00595D0,  0.00443D0,  0.00330D0,
53956      &     0.00240D0,  0.00168D0,  0.00114D0,  0.00081D0,  0.00053D0,
53957      &     0.00032D0,  0.00022D0,  0.00012D0,  0.00004D0,  0.00001D0,
53958      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53959       DATA (FMRS(1,4,I,27),I=1,49)/
53960      &    10.00621D0,  7.54783D0,  5.69293D0,  4.82623D0,  4.29189D0,
53961      &     3.91798D0,  2.94832D0,  2.21133D0,  1.86373D0,  1.64761D0,
53962      &     1.49327D0,  1.09257D0,  0.78647D0,  0.64301D0,  0.55451D0,
53963      &     0.49265D0,  0.40930D0,  0.33223D0,  0.25638D0,  0.20876D0,
53964      &     0.14886D0,  0.11122D0,  0.08517D0,  0.06240D0,  0.04650D0,
53965      &     0.03528D0,  0.02702D0,  0.02089D0,  0.01623D0,  0.01267D0,
53966      &     0.00980D0,  0.00752D0,  0.00573D0,  0.00425D0,  0.00316D0,
53967      &     0.00230D0,  0.00159D0,  0.00107D0,  0.00077D0,  0.00050D0,
53968      &     0.00030D0,  0.00020D0,  0.00011D0,  0.00003D0,  0.00001D0,
53969      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53970       DATA (FMRS(1,4,I,28),I=1,49)/
53971      &    10.80590D0,  8.10435D0,  6.07766D0,  5.13510D0,  4.55568D0,
53972      &     4.15111D0,  3.10583D0,  2.31601D0,  1.94527D0,  1.71546D0,
53973      &     1.55167D0,  1.12822D0,  0.80689D0,  0.65715D0,  0.56511D0,
53974      &     0.50095D0,  0.41476D0,  0.33539D0,  0.25764D0,  0.20907D0,
53975      &     0.14833D0,  0.11039D0,  0.08428D0,  0.06155D0,  0.04576D0,
53976      &     0.03462D0,  0.02647D0,  0.02040D0,  0.01582D0,  0.01230D0,
53977      &     0.00949D0,  0.00726D0,  0.00551D0,  0.00409D0,  0.00302D0,
53978      &     0.00221D0,  0.00152D0,  0.00102D0,  0.00073D0,  0.00048D0,
53979      &     0.00029D0,  0.00019D0,  0.00010D0,  0.00004D0,  0.00001D0,
53980      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53981       DATA (FMRS(1,4,I,29),I=1,49)/
53982      &    11.65207D0,  8.68978D0,  6.48001D0,  5.45700D0,  4.82993D0,
53983      &     4.39300D0,  3.26826D0,  2.42329D0,  2.02852D0,  1.78454D0,
53984      &     1.61099D0,  1.16415D0,  0.82729D0,  0.67117D0,  0.57557D0,
53985      &     0.50910D0,  0.42008D0,  0.33842D0,  0.25880D0,  0.20930D0,
53986      &     0.14773D0,  0.10953D0,  0.08337D0,  0.06069D0,  0.04500D0,
53987      &     0.03397D0,  0.02591D0,  0.01991D0,  0.01541D0,  0.01194D0,
53988      &     0.00919D0,  0.00702D0,  0.00530D0,  0.00393D0,  0.00290D0,
53989      &     0.00211D0,  0.00145D0,  0.00096D0,  0.00070D0,  0.00045D0,
53990      &     0.00028D0,  0.00018D0,  0.00010D0,  0.00003D0,  0.00001D0,
53991      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53992       DATA (FMRS(1,4,I,30),I=1,49)/
53993      &    12.52131D0,  9.28774D0,  6.88859D0,  5.78276D0,  5.10678D0,
53994      &     4.63673D0,  3.43094D0,  2.53005D0,  2.11104D0,  1.85281D0,
53995      &     1.66948D0,  1.19929D0,  0.84705D0,  0.68466D0,  0.58556D0,
53996      &     0.51685D0,  0.42507D0,  0.34121D0,  0.25979D0,  0.20942D0,
53997      &     0.14709D0,  0.10866D0,  0.08245D0,  0.05983D0,  0.04425D0,
53998      &     0.03334D0,  0.02536D0,  0.01943D0,  0.01501D0,  0.01160D0,
53999      &     0.00891D0,  0.00678D0,  0.00511D0,  0.00378D0,  0.00279D0,
54000      &     0.00202D0,  0.00138D0,  0.00091D0,  0.00067D0,  0.00043D0,
54001      &     0.00026D0,  0.00018D0,  0.00010D0,  0.00003D0,  0.00001D0,
54002      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54003       DATA (FMRS(1,4,I,31),I=1,49)/
54004      &    13.38978D0,  9.88200D0,  7.29246D0,  6.10376D0,  5.37897D0,
54005      &     4.87592D0,  3.58970D0,  2.63365D0,  2.19084D0,  1.91866D0,
54006      &     1.72578D0,  1.23288D0,  0.86578D0,  0.69738D0,  0.59494D0,
54007      &     0.52409D0,  0.42970D0,  0.34375D0,  0.26065D0,  0.20947D0,
54008      &     0.14644D0,  0.10781D0,  0.08158D0,  0.05902D0,  0.04354D0,
54009      &     0.03274D0,  0.02484D0,  0.01899D0,  0.01463D0,  0.01128D0,
54010      &     0.00865D0,  0.00657D0,  0.00493D0,  0.00364D0,  0.00268D0,
54011      &     0.00194D0,  0.00132D0,  0.00087D0,  0.00064D0,  0.00041D0,
54012      &     0.00025D0,  0.00017D0,  0.00009D0,  0.00003D0,  0.00001D0,
54013      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54014       DATA (FMRS(1,4,I,32),I=1,49)/
54015      &    14.23688D0, 10.45864D0,  7.68231D0,  6.41264D0,  5.64030D0,
54016      &     5.10517D0,  3.74102D0,  2.73180D0,  2.26617D0,  1.98065D0,
54017      &     1.77865D0,  1.26417D0,  0.88305D0,  0.70902D0,  0.60346D0,
54018      &     0.53062D0,  0.43382D0,  0.34595D0,  0.26134D0,  0.20941D0,
54019      &     0.14577D0,  0.10696D0,  0.08072D0,  0.05825D0,  0.04287D0,
54020      &     0.03215D0,  0.02436D0,  0.01857D0,  0.01428D0,  0.01098D0,
54021      &     0.00840D0,  0.00638D0,  0.00476D0,  0.00351D0,  0.00258D0,
54022      &     0.00187D0,  0.00127D0,  0.00083D0,  0.00061D0,  0.00039D0,
54023      &     0.00024D0,  0.00016D0,  0.00009D0,  0.00002D0,  0.00001D0,
54024      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54025       DATA (FMRS(1,4,I,33),I=1,49)/
54026      &    15.13941D0, 11.07021D0,  8.09390D0,  6.73786D0,  5.91493D0,
54027      &     5.34574D0,  3.89907D0,  2.83385D0,  2.34427D0,  2.04479D0,
54028      &     1.83327D0,  1.29634D0,  0.90070D0,  0.72088D0,  0.61213D0,
54029      &     0.53725D0,  0.43798D0,  0.34817D0,  0.26202D0,  0.20935D0,
54030      &     0.14510D0,  0.10612D0,  0.07988D0,  0.05749D0,  0.04221D0,
54031      &     0.03158D0,  0.02388D0,  0.01816D0,  0.01393D0,  0.01069D0,
54032      &     0.00816D0,  0.00620D0,  0.00459D0,  0.00338D0,  0.00248D0,
54033      &     0.00179D0,  0.00121D0,  0.00080D0,  0.00058D0,  0.00037D0,
54034      &     0.00022D0,  0.00014D0,  0.00008D0,  0.00002D0,  0.00001D0,
54035      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54036       DATA (FMRS(1,4,I,34),I=1,49)/
54037      &    16.04276D0, 11.67919D0,  8.50158D0,  7.05899D0,  6.18548D0,
54038      &     5.58230D0,  4.05359D0,  2.93300D0,  2.41985D0,  2.10667D0,
54039      &     1.88583D0,  1.32700D0,  0.91732D0,  0.73194D0,  0.62013D0,
54040      &     0.54331D0,  0.44171D0,  0.35007D0,  0.26248D0,  0.20913D0,
54041      &     0.14434D0,  0.10523D0,  0.07901D0,  0.05671D0,  0.04155D0,
54042      &     0.03102D0,  0.02340D0,  0.01777D0,  0.01360D0,  0.01042D0,
54043      &     0.00793D0,  0.00600D0,  0.00446D0,  0.00326D0,  0.00238D0,
54044      &     0.00173D0,  0.00118D0,  0.00076D0,  0.00055D0,  0.00036D0,
54045      &     0.00022D0,  0.00014D0,  0.00007D0,  0.00002D0,  0.00001D0,
54046      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54047       DATA (FMRS(1,4,I,35),I=1,49)/
54048      &    16.94849D0, 12.28721D0,  8.90688D0,  7.37746D0,  6.45332D0,
54049      &     5.81617D0,  4.20570D0,  3.03017D0,  2.49373D0,  2.16705D0,
54050      &     1.93704D0,  1.35674D0,  0.93336D0,  0.74257D0,  0.62781D0,
54051      &     0.54911D0,  0.44527D0,  0.35187D0,  0.26291D0,  0.20892D0,
54052      &     0.14363D0,  0.10440D0,  0.07819D0,  0.05599D0,  0.04092D0,
54053      &     0.03050D0,  0.02296D0,  0.01740D0,  0.01329D0,  0.01017D0,
54054      &     0.00772D0,  0.00583D0,  0.00433D0,  0.00315D0,  0.00229D0,
54055      &     0.00167D0,  0.00114D0,  0.00073D0,  0.00053D0,  0.00035D0,
54056      &     0.00021D0,  0.00013D0,  0.00007D0,  0.00002D0,  0.00001D0,
54057      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54058       DATA (FMRS(1,4,I,36),I=1,49)/
54059      &    17.83243D0, 12.87802D0,  9.29900D0,  7.68475D0,  6.71127D0,
54060      &     6.04107D0,  4.35129D0,  3.12272D0,  2.56388D0,  2.22424D0,
54061      &     1.98545D0,  1.38466D0,  0.94830D0,  0.75241D0,  0.63488D0,
54062      &     0.55441D0,  0.44848D0,  0.35346D0,  0.26323D0,  0.20867D0,
54063      &     0.14292D0,  0.10358D0,  0.07741D0,  0.05529D0,  0.04033D0,
54064      &     0.03000D0,  0.02255D0,  0.01705D0,  0.01300D0,  0.00993D0,
54065      &     0.00753D0,  0.00566D0,  0.00421D0,  0.00306D0,  0.00221D0,
54066      &     0.00161D0,  0.00110D0,  0.00071D0,  0.00051D0,  0.00034D0,
54067      &     0.00020D0,  0.00013D0,  0.00007D0,  0.00002D0,  0.00001D0,
54068      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54069       DATA (FMRS(1,4,I,37),I=1,49)/
54070      &    18.74867D0, 13.48785D0,  9.70200D0,  7.99976D0,  6.97522D0,
54071      &     6.27087D0,  4.49936D0,  3.21639D0,  2.63465D0,  2.28182D0,
54072      &     2.03408D0,  1.41252D0,  0.96307D0,  0.76207D0,  0.64176D0,
54073      &     0.55956D0,  0.45155D0,  0.35492D0,  0.26347D0,  0.20834D0,
54074      &     0.14216D0,  0.10274D0,  0.07660D0,  0.05459D0,  0.03974D0,
54075      &     0.02950D0,  0.02213D0,  0.01670D0,  0.01272D0,  0.00970D0,
54076      &     0.00733D0,  0.00550D0,  0.00408D0,  0.00297D0,  0.00214D0,
54077      &     0.00155D0,  0.00105D0,  0.00068D0,  0.00049D0,  0.00032D0,
54078      &     0.00018D0,  0.00012D0,  0.00007D0,  0.00002D0,  0.00001D0,
54079      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54080       DATA (FMRS(1,4,I,38),I=1,49)/
54081      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54082      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54083      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54084      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54085      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54086      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54087      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54088      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54089      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54090      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54091       DATA (FMRS(1,5,I, 1),I=1,49)/
54092      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54093      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54094      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54095      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54096      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54097      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54098      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54099      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54100      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54101      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54102       DATA (FMRS(1,5,I, 2),I=1,49)/
54103      &     0.00003D0,  0.00003D0,  0.00002D0,  0.00002D0,  0.00002D0,
54104      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
54105      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
54106      &     0.00002D0,  0.00002D0,  0.00001D0,  0.00001D0,  0.00001D0,
54107      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
54108      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
54109      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00000D0,  0.00000D0,
54110      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54111      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54112      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54113       DATA (FMRS(1,5,I, 3),I=1,49)/
54114      &     0.03227D0,  0.02900D0,  0.02605D0,  0.02445D0,  0.02338D0,
54115      &     0.02257D0,  0.02019D0,  0.01798D0,  0.01674D0,  0.01586D0,
54116      &     0.01516D0,  0.01302D0,  0.01084D0,  0.00956D0,  0.00865D0,
54117      &     0.00795D0,  0.00692D0,  0.00587D0,  0.00477D0,  0.00405D0,
54118      &     0.00317D0,  0.00263D0,  0.00225D0,  0.00190D0,  0.00163D0,
54119      &     0.00139D0,  0.00119D0,  0.00101D0,  0.00085D0,  0.00072D0,
54120      &     0.00059D0,  0.00048D0,  0.00039D0,  0.00031D0,  0.00025D0,
54121      &     0.00019D0,  0.00015D0,  0.00011D0,  0.00008D0,  0.00006D0,
54122      &     0.00004D0,  0.00003D0,  0.00002D0,  0.00001D0,  0.00000D0,
54123      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54124       DATA (FMRS(1,5,I, 4),I=1,49)/
54125      &     0.08412D0,  0.07493D0,  0.06672D0,  0.06231D0,  0.05935D0,
54126      &     0.05713D0,  0.05068D0,  0.04474D0,  0.04144D0,  0.03913D0,
54127      &     0.03731D0,  0.03177D0,  0.02623D0,  0.02303D0,  0.02077D0,
54128      &     0.01905D0,  0.01652D0,  0.01397D0,  0.01129D0,  0.00957D0,
54129      &     0.00745D0,  0.00615D0,  0.00525D0,  0.00441D0,  0.00375D0,
54130      &     0.00320D0,  0.00272D0,  0.00230D0,  0.00193D0,  0.00161D0,
54131      &     0.00132D0,  0.00108D0,  0.00087D0,  0.00069D0,  0.00054D0,
54132      &     0.00042D0,  0.00032D0,  0.00024D0,  0.00018D0,  0.00013D0,
54133      &     0.00009D0,  0.00006D0,  0.00004D0,  0.00001D0,  0.00000D0,
54134      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54135       DATA (FMRS(1,5,I, 5),I=1,49)/
54136      &     0.14877D0,  0.13082D0,  0.11499D0,  0.10659D0,  0.10097D0,
54137      &     0.09680D0,  0.08477D0,  0.07388D0,  0.06791D0,  0.06379D0,
54138      &     0.06056D0,  0.05091D0,  0.04152D0,  0.03619D0,  0.03249D0,
54139      &     0.02969D0,  0.02561D0,  0.02153D0,  0.01729D0,  0.01459D0,
54140      &     0.01127D0,  0.00925D0,  0.00785D0,  0.00655D0,  0.00553D0,
54141      &     0.00469D0,  0.00396D0,  0.00333D0,  0.00278D0,  0.00231D0,
54142      &     0.00189D0,  0.00153D0,  0.00123D0,  0.00097D0,  0.00076D0,
54143      &     0.00059D0,  0.00045D0,  0.00034D0,  0.00025D0,  0.00018D0,
54144      &     0.00012D0,  0.00009D0,  0.00006D0,  0.00001D0,  0.00000D0,
54145      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54146       DATA (FMRS(1,5,I, 6),I=1,49)/
54147      &     0.22202D0,  0.19306D0,  0.16779D0,  0.15452D0,  0.14570D0,
54148      &     0.13918D0,  0.12051D0,  0.10386D0,  0.09484D0,  0.08868D0,
54149      &     0.08388D0,  0.06972D0,  0.05624D0,  0.04872D0,  0.04355D0,
54150      &     0.03966D0,  0.03405D0,  0.02848D0,  0.02274D0,  0.01911D0,
54151      &     0.01466D0,  0.01197D0,  0.01011D0,  0.00838D0,  0.00703D0,
54152      &     0.00592D0,  0.00498D0,  0.00416D0,  0.00346D0,  0.00286D0,
54153      &     0.00233D0,  0.00188D0,  0.00150D0,  0.00118D0,  0.00092D0,
54154      &     0.00071D0,  0.00054D0,  0.00041D0,  0.00030D0,  0.00021D0,
54155      &     0.00015D0,  0.00010D0,  0.00007D0,  0.00001D0,  0.00000D0,
54156      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54157       DATA (FMRS(1,5,I, 7),I=1,49)/
54158      &     0.30272D0,  0.26063D0,  0.22430D0,  0.20535D0,  0.19284D0,
54159      &     0.18362D0,  0.15743D0,  0.13433D0,  0.12195D0,  0.11355D0,
54160      &     0.10705D0,  0.08808D0,  0.07034D0,  0.06058D0,  0.05394D0,
54161      &     0.04898D0,  0.04185D0,  0.03485D0,  0.02767D0,  0.02316D0,
54162      &     0.01766D0,  0.01434D0,  0.01204D0,  0.00992D0,  0.00828D0,
54163      &     0.00693D0,  0.00580D0,  0.00482D0,  0.00399D0,  0.00328D0,
54164      &     0.00266D0,  0.00214D0,  0.00170D0,  0.00133D0,  0.00104D0,
54165      &     0.00080D0,  0.00060D0,  0.00045D0,  0.00033D0,  0.00024D0,
54166      &     0.00016D0,  0.00011D0,  0.00007D0,  0.00001D0,  0.00000D0,
54167      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54168       DATA (FMRS(1,5,I, 8),I=1,49)/
54169      &     0.40640D0,  0.34641D0,  0.29514D0,  0.26863D0,  0.25121D0,
54170      &     0.23843D0,  0.20237D0,  0.17095D0,  0.15427D0,  0.14303D0,
54171      &     0.13440D0,  0.10944D0,  0.08650D0,  0.07407D0,  0.06568D0,
54172      &     0.05945D0,  0.05056D0,  0.04189D0,  0.03309D0,  0.02757D0,
54173      &     0.02089D0,  0.01686D0,  0.01408D0,  0.01153D0,  0.00956D0,
54174      &     0.00796D0,  0.00662D0,  0.00548D0,  0.00451D0,  0.00369D0,
54175      &     0.00298D0,  0.00239D0,  0.00189D0,  0.00148D0,  0.00114D0,
54176      &     0.00087D0,  0.00066D0,  0.00049D0,  0.00037D0,  0.00026D0,
54177      &     0.00018D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
54178      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54179       DATA (FMRS(1,5,I, 9),I=1,49)/
54180      &     0.51210D0,  0.43288D0,  0.36574D0,  0.33126D0,  0.30871D0,
54181      &     0.29222D0,  0.24594D0,  0.20601D0,  0.18499D0,  0.17091D0,
54182      &     0.16014D0,  0.12927D0,  0.10130D0,  0.08631D0,  0.07626D0,
54183      &     0.06885D0,  0.05833D0,  0.04813D0,  0.03783D0,  0.03141D0,
54184      &     0.02366D0,  0.01900D0,  0.01580D0,  0.01287D0,  0.01061D0,
54185      &     0.00880D0,  0.00728D0,  0.00600D0,  0.00491D0,  0.00401D0,
54186      &     0.00322D0,  0.00257D0,  0.00203D0,  0.00158D0,  0.00122D0,
54187      &     0.00093D0,  0.00070D0,  0.00052D0,  0.00039D0,  0.00028D0,
54188      &     0.00018D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
54189      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54190       DATA (FMRS(1,5,I,10),I=1,49)/
54191      &     0.62615D0,  0.52524D0,  0.44038D0,  0.39709D0,  0.36888D0,
54192      &     0.34831D0,  0.29091D0,  0.24179D0,  0.21613D0,  0.19903D0,
54193      &     0.18601D0,  0.14895D0,  0.11579D0,  0.09820D0,  0.08649D0,
54194      &     0.07789D0,  0.06575D0,  0.05404D0,  0.04228D0,  0.03498D0,
54195      &     0.02621D0,  0.02095D0,  0.01734D0,  0.01405D0,  0.01153D0,
54196      &     0.00952D0,  0.00784D0,  0.00644D0,  0.00525D0,  0.00426D0,
54197      &     0.00342D0,  0.00272D0,  0.00213D0,  0.00166D0,  0.00127D0,
54198      &     0.00097D0,  0.00073D0,  0.00054D0,  0.00040D0,  0.00029D0,
54199      &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
54200      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54201       DATA (FMRS(1,5,I,11),I=1,49)/
54202      &     0.72756D0,  0.60673D0,  0.50572D0,  0.45443D0,  0.42111D0,
54203      &     0.39687D0,  0.32951D0,  0.27226D0,  0.24251D0,  0.22276D0,
54204      &     0.20777D0,  0.16535D0,  0.12775D0,  0.10795D0,  0.09484D0,
54205      &     0.08524D0,  0.07175D0,  0.05879D0,  0.04583D0,  0.03782D0,
54206      &     0.02821D0,  0.02247D0,  0.01853D0,  0.01496D0,  0.01223D0,
54207      &     0.01005D0,  0.00826D0,  0.00676D0,  0.00549D0,  0.00445D0,
54208      &     0.00355D0,  0.00282D0,  0.00221D0,  0.00171D0,  0.00131D0,
54209      &     0.00099D0,  0.00074D0,  0.00055D0,  0.00041D0,  0.00029D0,
54210      &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
54211      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54212       DATA (FMRS(1,5,I,12),I=1,49)/
54213      &     0.97596D0,  0.80419D0,  0.66232D0,  0.59100D0,  0.54494D0,
54214      &     0.51159D0,  0.41968D0,  0.34257D0,  0.30297D0,  0.27688D0,
54215      &     0.25720D0,  0.20210D0,  0.15417D0,  0.12932D0,  0.11303D0,
54216      &     0.10119D0,  0.08465D0,  0.06892D0,  0.05333D0,  0.04376D0,
54217      &     0.03235D0,  0.02557D0,  0.02094D0,  0.01675D0,  0.01359D0,
54218      &     0.01109D0,  0.00904D0,  0.00734D0,  0.00594D0,  0.00477D0,
54219      &     0.00379D0,  0.00299D0,  0.00233D0,  0.00179D0,  0.00137D0,
54220      &     0.00103D0,  0.00077D0,  0.00057D0,  0.00042D0,  0.00030D0,
54221      &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
54222      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54223       DATA (FMRS(1,5,I,13),I=1,49)/
54224      &     1.22977D0,  1.00344D0,  0.81836D0,  0.72605D0,  0.66675D0,
54225      &     0.62396D0,  0.50684D0,  0.40963D0,  0.36016D0,  0.32776D0,
54226      &     0.30345D0,  0.23597D0,  0.17813D0,  0.14851D0,  0.12924D0,
54227      &     0.11531D0,  0.09599D0,  0.07773D0,  0.05977D0,  0.04882D0,
54228      &     0.03581D0,  0.02811D0,  0.02289D0,  0.01818D0,  0.01465D0,
54229      &     0.01187D0,  0.00963D0,  0.00777D0,  0.00625D0,  0.00500D0,
54230      &     0.00395D0,  0.00310D0,  0.00241D0,  0.00185D0,  0.00140D0,
54231      &     0.00105D0,  0.00078D0,  0.00058D0,  0.00043D0,  0.00031D0,
54232      &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
54233      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54234       DATA (FMRS(1,5,I,14),I=1,49)/
54235      &     1.55816D0,  1.25825D0,  1.01555D0,  0.89552D0,  0.81883D0,
54236      &     0.76371D0,  0.61389D0,  0.49095D0,  0.42897D0,  0.38864D0,
54237      &     0.35854D0,  0.27572D0,  0.20581D0,  0.17047D0,  0.14766D0,
54238      &     0.13128D0,  0.10869D0,  0.08751D0,  0.06683D0,  0.05430D0,
54239      &     0.03950D0,  0.03078D0,  0.02489D0,  0.01962D0,  0.01569D0,
54240      &     0.01264D0,  0.01018D0,  0.00817D0,  0.00653D0,  0.00519D0,
54241      &     0.00408D0,  0.00319D0,  0.00246D0,  0.00188D0,  0.00142D0,
54242      &     0.00106D0,  0.00078D0,  0.00058D0,  0.00043D0,  0.00031D0,
54243      &     0.00019D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
54244      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54245       DATA (FMRS(1,5,I,15),I=1,49)/
54246      &     1.94525D0,  1.55494D0,  1.24230D0,  1.08896D0,  0.99149D0,
54247      &     0.92172D0,  0.73335D0,  0.58046D0,  0.50409D0,  0.45471D0,
54248      &     0.41801D0,  0.31797D0,  0.23473D0,  0.19316D0,  0.16655D0,
54249      &     0.14754D0,  0.12149D0,  0.09725D0,  0.07376D0,  0.05961D0,
54250      &     0.04299D0,  0.03326D0,  0.02672D0,  0.02089D0,  0.01659D0,
54251      &     0.01327D0,  0.01061D0,  0.00847D0,  0.00673D0,  0.00532D0,
54252      &     0.00416D0,  0.00323D0,  0.00248D0,  0.00188D0,  0.00142D0,
54253      &     0.00105D0,  0.00077D0,  0.00057D0,  0.00042D0,  0.00031D0,
54254      &     0.00019D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
54255      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54256       DATA (FMRS(1,5,I,16),I=1,49)/
54257      &     2.34531D0,  1.85826D0,  1.47159D0,  1.28330D0,  1.16416D0,
54258      &     1.07915D0,  0.85101D0,  0.66758D0,  0.57668D0,  0.51821D0,
54259      &     0.47495D0,  0.35786D0,  0.26164D0,  0.21408D0,  0.18385D0,
54260      &     0.16236D0,  0.13305D0,  0.10596D0,  0.07987D0,  0.06425D0,
54261      &     0.04599D0,  0.03535D0,  0.02822D0,  0.02192D0,  0.01729D0,
54262      &     0.01375D0,  0.01093D0,  0.00867D0,  0.00685D0,  0.00540D0,
54263      &     0.00420D0,  0.00325D0,  0.00248D0,  0.00188D0,  0.00141D0,
54264      &     0.00104D0,  0.00076D0,  0.00056D0,  0.00041D0,  0.00030D0,
54265      &     0.00018D0,  0.00011D0,  0.00006D0,  0.00001D0,  0.00000D0,
54266      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54267       DATA (FMRS(1,5,I,17),I=1,49)/
54268      &     2.80142D0,  2.20072D0,  1.72790D0,  1.49927D0,  1.35523D0,
54269      &     1.25280D0,  0.97945D0,  0.76167D0,  0.65458D0,  0.58603D0,
54270      &     0.53553D0,  0.39978D0,  0.28955D0,  0.23561D0,  0.20153D0,
54271      &     0.17743D0,  0.14473D0,  0.11467D0,  0.08591D0,  0.06880D0,
54272      &     0.04888D0,  0.03733D0,  0.02963D0,  0.02285D0,  0.01791D0,
54273      &     0.01415D0,  0.01119D0,  0.00883D0,  0.00694D0,  0.00544D0,
54274      &     0.00421D0,  0.00324D0,  0.00247D0,  0.00186D0,  0.00139D0,
54275      &     0.00102D0,  0.00075D0,  0.00055D0,  0.00040D0,  0.00029D0,
54276      &     0.00018D0,  0.00011D0,  0.00006D0,  0.00001D0,  0.00000D0,
54277      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54278       DATA (FMRS(1,5,I,18),I=1,49)/
54279      &     3.21652D0,  2.50960D0,  1.95700D0,  1.69126D0,  1.52443D0,
54280      &     1.40610D0,  1.09176D0,  0.84313D0,  0.72161D0,  0.64414D0,
54281      &     0.58724D0,  0.43516D0,  0.31280D0,  0.25339D0,  0.21606D0,
54282      &     0.18974D0,  0.15419D0,  0.12166D0,  0.09071D0,  0.07236D0,
54283      &     0.05109D0,  0.03882D0,  0.03067D0,  0.02352D0,  0.01834D0,
54284      &     0.01442D0,  0.01135D0,  0.00892D0,  0.00699D0,  0.00545D0,
54285      &     0.00421D0,  0.00322D0,  0.00245D0,  0.00184D0,  0.00137D0,
54286      &     0.00100D0,  0.00073D0,  0.00053D0,  0.00039D0,  0.00029D0,
54287      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00001D0,  0.00000D0,
54288      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54289       DATA (FMRS(1,5,I,19),I=1,49)/
54290      &     3.76652D0,  2.91536D0,  2.25532D0,  1.93997D0,  1.74280D0,
54291      &     1.60338D0,  1.23496D0,  0.94601D0,  0.80577D0,  0.71678D0,
54292      &     0.65167D0,  0.47873D0,  0.34109D0,  0.27487D0,  0.23349D0,
54293      &     0.20445D0,  0.16541D0,  0.12988D0,  0.09628D0,  0.07646D0,
54294      &     0.05359D0,  0.04046D0,  0.03178D0,  0.02422D0,  0.01877D0,
54295      &     0.01467D0,  0.01149D0,  0.00898D0,  0.00700D0,  0.00543D0,
54296      &     0.00418D0,  0.00319D0,  0.00241D0,  0.00180D0,  0.00134D0,
54297      &     0.00098D0,  0.00071D0,  0.00052D0,  0.00038D0,  0.00028D0,
54298      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00001D0,  0.00000D0,
54299      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54300       DATA (FMRS(1,5,I,20),I=1,49)/
54301      &     4.30575D0,  3.30993D0,  2.54302D0,  2.17866D0,  1.95165D0,
54302      &     1.79153D0,  1.37036D0,  1.04242D0,  0.88422D0,  0.78423D0,
54303      &     0.71130D0,  0.51866D0,  0.36673D0,  0.29419D0,  0.24910D0,
54304      &     0.21757D0,  0.17534D0,  0.13711D0,  0.10112D0,  0.07999D0,
54305      &     0.05571D0,  0.04184D0,  0.03270D0,  0.02477D0,  0.01909D0,
54306      &     0.01486D0,  0.01158D0,  0.00901D0,  0.00699D0,  0.00541D0,
54307      &     0.00414D0,  0.00315D0,  0.00237D0,  0.00177D0,  0.00131D0,
54308      &     0.00095D0,  0.00069D0,  0.00050D0,  0.00037D0,  0.00027D0,
54309      &     0.00016D0,  0.00009D0,  0.00005D0,  0.00001D0,  0.00000D0,
54310      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54311       DATA (FMRS(1,5,I,21),I=1,49)/
54312      &     4.82956D0,  3.69021D0,  2.81808D0,  2.40576D0,  2.14966D0,
54313      &     1.96944D0,  1.49728D0,  1.13198D0,  0.95669D0,  0.84628D0,
54314      &     0.76597D0,  0.55486D0,  0.38968D0,  0.31136D0,  0.26288D0,
54315      &     0.22909D0,  0.18399D0,  0.14333D0,  0.10523D0,  0.08295D0,
54316      &     0.05744D0,  0.04293D0,  0.03340D0,  0.02518D0,  0.01931D0,
54317      &     0.01496D0,  0.01161D0,  0.00900D0,  0.00696D0,  0.00536D0,
54318      &     0.00409D0,  0.00310D0,  0.00233D0,  0.00173D0,  0.00128D0,
54319      &     0.00093D0,  0.00067D0,  0.00049D0,  0.00036D0,  0.00027D0,
54320      &     0.00015D0,  0.00009D0,  0.00005D0,  0.00001D0,  0.00000D0,
54321      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54322       DATA (FMRS(1,5,I,22),I=1,49)/
54323      &     5.55546D0,  4.21326D0,  3.19353D0,  2.71436D0,  2.41786D0,
54324      &     2.20981D0,  1.66741D0,  1.25104D0,  1.05255D0,  0.92807D0,
54325      &     0.83783D0,  0.60198D0,  0.41926D0,  0.33333D0,  0.28043D0,
54326      &     0.24370D0,  0.19489D0,  0.15111D0,  0.11032D0,  0.08657D0,
54327      &     0.05953D0,  0.04421D0,  0.03422D0,  0.02563D0,  0.01955D0,
54328      &     0.01506D0,  0.01163D0,  0.00897D0,  0.00690D0,  0.00529D0,
54329      &     0.00403D0,  0.00304D0,  0.00227D0,  0.00168D0,  0.00124D0,
54330      &     0.00090D0,  0.00064D0,  0.00047D0,  0.00035D0,  0.00026D0,
54331      &     0.00015D0,  0.00008D0,  0.00005D0,  0.00001D0,  0.00000D0,
54332      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54333       DATA (FMRS(1,5,I,23),I=1,49)/
54334      &     6.30033D0,  4.74567D0,  3.57260D0,  3.02443D0,  2.68642D0,
54335      &     2.44984D0,  1.83585D0,  1.36787D0,  1.14612D0,  1.00758D0,
54336      &     0.90746D0,  0.64718D0,  0.44730D0,  0.35401D0,  0.29686D0,
54337      &     0.25731D0,  0.20497D0,  0.15824D0,  0.11492D0,  0.08982D0,
54338      &     0.06136D0,  0.04532D0,  0.03489D0,  0.02598D0,  0.01971D0,
54339      &     0.01511D0,  0.01161D0,  0.00892D0,  0.00683D0,  0.00522D0,
54340      &     0.00395D0,  0.00297D0,  0.00222D0,  0.00163D0,  0.00120D0,
54341      &     0.00087D0,  0.00062D0,  0.00045D0,  0.00034D0,  0.00025D0,
54342      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00001D0,  0.00000D0,
54343      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54344       DATA (FMRS(1,5,I,24),I=1,49)/
54345      &     7.03684D0,  5.26796D0,  3.94145D0,  3.32468D0,  2.94556D0,
54346      &     2.68082D0,  1.99651D0,  1.47829D0,  1.23404D0,  1.08198D0,
54347      &     0.97239D0,  0.68884D0,  0.47281D0,  0.37266D0,  0.31157D0,
54348      &     0.26944D0,  0.21386D0,  0.16445D0,  0.11886D0,  0.09256D0,
54349      &     0.06285D0,  0.04618D0,  0.03539D0,  0.02621D0,  0.01979D0,
54350      &     0.01510D0,  0.01155D0,  0.00884D0,  0.00675D0,  0.00513D0,
54351      &     0.00387D0,  0.00290D0,  0.00216D0,  0.00159D0,  0.00116D0,
54352      &     0.00084D0,  0.00060D0,  0.00044D0,  0.00033D0,  0.00024D0,
54353      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54354      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54355       DATA (FMRS(1,5,I,25),I=1,49)/
54356      &     7.83575D0,  5.83079D0,  4.33631D0,  3.64485D0,  3.22112D0,
54357      &     2.92590D0,  2.16582D0,  1.59383D0,  1.32566D0,  1.15927D0,
54358      &     1.03966D0,  0.73165D0,  0.49881D0,  0.39156D0,  0.32642D0,
54359      &     0.28163D0,  0.22275D0,  0.17063D0,  0.12274D0,  0.09523D0,
54360      &     0.06428D0,  0.04699D0,  0.03585D0,  0.02642D0,  0.01984D0,
54361      &     0.01507D0,  0.01148D0,  0.00875D0,  0.00665D0,  0.00505D0,
54362      &     0.00380D0,  0.00284D0,  0.00210D0,  0.00154D0,  0.00112D0,
54363      &     0.00081D0,  0.00058D0,  0.00042D0,  0.00031D0,  0.00024D0,
54364      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54365      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54366       DATA (FMRS(1,5,I,26),I=1,49)/
54367      &     8.65815D0,  6.40607D0,  4.73699D0,  3.96832D0,  3.49865D0,
54368      &     3.17213D0,  2.33459D0,  1.70806D0,  1.41577D0,  1.23500D0,
54369      &     1.10538D0,  0.77305D0,  0.52365D0,  0.40947D0,  0.34040D0,
54370      &     0.29306D0,  0.23101D0,  0.17630D0,  0.12625D0,  0.09761D0,
54371      &     0.06550D0,  0.04766D0,  0.03620D0,  0.02654D0,  0.01984D0,
54372      &     0.01501D0,  0.01139D0,  0.00864D0,  0.00655D0,  0.00495D0,
54373      &     0.00371D0,  0.00276D0,  0.00204D0,  0.00149D0,  0.00108D0,
54374      &     0.00078D0,  0.00056D0,  0.00041D0,  0.00030D0,  0.00023D0,
54375      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54376      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54377       DATA (FMRS(1,5,I,27),I=1,49)/
54378      &     9.48773D0,  6.98283D0,  5.13620D0,  4.28942D0,  3.77342D0,
54379      &     3.41540D0,  2.50025D0,  1.81942D0,  1.50325D0,  1.30829D0,
54380      &     1.16884D0,  0.81270D0,  0.54722D0,  0.42638D0,  0.35354D0,
54381      &     0.30375D0,  0.23869D0,  0.18153D0,  0.12945D0,  0.09975D0,
54382      &     0.06658D0,  0.04823D0,  0.03648D0,  0.02662D0,  0.01982D0,
54383      &     0.01493D0,  0.01129D0,  0.00853D0,  0.00645D0,  0.00486D0,
54384      &     0.00363D0,  0.00270D0,  0.00199D0,  0.00145D0,  0.00105D0,
54385      &     0.00075D0,  0.00054D0,  0.00039D0,  0.00030D0,  0.00022D0,
54386      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54387      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54388       DATA (FMRS(1,5,I,28),I=1,49)/
54389      &    10.30763D0,  7.54945D0,  5.52601D0,  4.60181D0,  4.04004D0,
54390      &     3.65097D0,  2.65960D0,  1.92581D0,  1.58647D0,  1.37780D0,
54391      &     1.22885D0,  0.84989D0,  0.56911D0,  0.44198D0,  0.36560D0,
54392      &     0.31352D0,  0.24565D0,  0.18623D0,  0.13228D0,  0.10162D0,
54393      &     0.06750D0,  0.04868D0,  0.03669D0,  0.02666D0,  0.01976D0,
54394      &     0.01484D0,  0.01118D0,  0.00842D0,  0.00635D0,  0.00477D0,
54395      &     0.00355D0,  0.00263D0,  0.00193D0,  0.00141D0,  0.00102D0,
54396      &     0.00073D0,  0.00052D0,  0.00038D0,  0.00029D0,  0.00022D0,
54397      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54398      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54399       DATA (FMRS(1,5,I,29),I=1,49)/
54400      &    11.17527D0,  8.14579D0,  5.93397D0,  4.92768D0,  4.31749D0,
54401      &     3.89565D0,  2.82415D0,  2.03499D0,  1.67156D0,  1.44867D0,
54402      &     1.28991D0,  0.88743D0,  0.59103D0,  0.45751D0,  0.37756D0,
54403      &     0.32318D0,  0.25249D0,  0.19081D0,  0.13501D0,  0.10341D0,
54404      &     0.06835D0,  0.04909D0,  0.03686D0,  0.02667D0,  0.01969D0,
54405      &     0.01473D0,  0.01106D0,  0.00831D0,  0.00624D0,  0.00467D0,
54406      &     0.00347D0,  0.00257D0,  0.00188D0,  0.00136D0,  0.00099D0,
54407      &     0.00070D0,  0.00050D0,  0.00037D0,  0.00028D0,  0.00021D0,
54408      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54409      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54410       DATA (FMRS(1,5,I,30),I=1,49)/
54411      &    12.06456D0,  8.75358D0,  6.34740D0,  5.25678D0,  4.59701D0,
54412      &     4.14168D0,  2.98858D0,  2.14338D0,  1.75569D0,  1.51853D0,
54413      &     1.34994D0,  0.92405D0,  0.61221D0,  0.47241D0,  0.38898D0,
54414      &     0.33235D0,  0.25894D0,  0.19508D0,  0.13752D0,  0.10502D0,
54415      &     0.06908D0,  0.04942D0,  0.03697D0,  0.02664D0,  0.01960D0,
54416      &     0.01461D0,  0.01093D0,  0.00819D0,  0.00613D0,  0.00458D0,
54417      &     0.00339D0,  0.00250D0,  0.00183D0,  0.00132D0,  0.00095D0,
54418      &     0.00068D0,  0.00049D0,  0.00036D0,  0.00027D0,  0.00021D0,
54419      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54420      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54421       DATA (FMRS(1,5,I,31),I=1,49)/
54422      &    12.95374D0,  9.35831D0,  6.75669D0,  5.58162D0,  4.87232D0,
54423      &     4.38360D0,  3.14942D0,  2.24882D0,  1.83726D0,  1.58610D0,
54424      &     1.40790D0,  0.95916D0,  0.63237D0,  0.48653D0,  0.39975D0,
54425      &     0.34099D0,  0.26498D0,  0.19905D0,  0.13983D0,  0.10648D0,
54426      &     0.06974D0,  0.04970D0,  0.03705D0,  0.02660D0,  0.01950D0,
54427      &     0.01449D0,  0.01081D0,  0.00807D0,  0.00603D0,  0.00449D0,
54428      &     0.00332D0,  0.00244D0,  0.00178D0,  0.00129D0,  0.00093D0,
54429      &     0.00066D0,  0.00047D0,  0.00035D0,  0.00026D0,  0.00020D0,
54430      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54431      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54432       DATA (FMRS(1,5,I,32),I=1,49)/
54433      &    13.81822D0,  9.94319D0,  7.15042D0,  5.89310D0,  5.13569D0,
54434      &     4.61461D0,  3.30209D0,  2.34827D0,  1.91389D0,  1.64940D0,
54435      &     1.46205D0,  0.99170D0,  0.65086D0,  0.49940D0,  0.40952D0,
54436      &     0.34877D0,  0.27037D0,  0.20256D0,  0.14182D0,  0.10773D0,
54437      &     0.07026D0,  0.04989D0,  0.03708D0,  0.02652D0,  0.01938D0,
54438      &     0.01436D0,  0.01068D0,  0.00795D0,  0.00592D0,  0.00440D0,
54439      &     0.00325D0,  0.00238D0,  0.00174D0,  0.00125D0,  0.00090D0,
54440      &     0.00064D0,  0.00046D0,  0.00034D0,  0.00026D0,  0.00020D0,
54441      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54442      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54443       DATA (FMRS(1,5,I,33),I=1,49)/
54444      &    14.74174D0, 10.56553D0,  7.56770D0,  6.22245D0,  5.41371D0,
54445      &     4.85814D0,  3.46239D0,  2.45228D0,  1.99384D0,  1.71531D0,
54446      &     1.51837D0,  1.02539D0,  0.66993D0,  0.51263D0,  0.41953D0,
54447      &     0.35674D0,  0.27589D0,  0.20614D0,  0.14386D0,  0.10899D0,
54448      &     0.07078D0,  0.05009D0,  0.03711D0,  0.02645D0,  0.01927D0,
54449      &     0.01422D0,  0.01055D0,  0.00784D0,  0.00582D0,  0.00432D0,
54450      &     0.00318D0,  0.00233D0,  0.00169D0,  0.00122D0,  0.00087D0,
54451      &     0.00062D0,  0.00044D0,  0.00033D0,  0.00025D0,  0.00020D0,
54452      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54453      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54454       DATA (FMRS(1,5,I,34),I=1,49)/
54455      &    15.66159D0, 11.18202D0,  7.97872D0,  6.54573D0,  5.68591D0,
54456      &     5.09611D0,  3.61802D0,  2.55254D0,  2.07056D0,  1.77835D0,
54457      &     1.57208D0,  1.05721D0,  0.68771D0,  0.52486D0,  0.42872D0,
54458      &     0.36401D0,  0.28085D0,  0.20931D0,  0.14560D0,  0.11004D0,
54459      &     0.07117D0,  0.05019D0,  0.03707D0,  0.02633D0,  0.01912D0,
54460      &     0.01408D0,  0.01041D0,  0.00771D0,  0.00572D0,  0.00423D0,
54461      &     0.00311D0,  0.00227D0,  0.00165D0,  0.00118D0,  0.00085D0,
54462      &     0.00060D0,  0.00043D0,  0.00032D0,  0.00025D0,  0.00020D0,
54463      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54464      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54465       DATA (FMRS(1,5,I,35),I=1,49)/
54466      &    16.58568D0, 11.79905D0,  8.38856D0,  6.86738D0,  5.95633D0,
54467      &     5.33223D0,  3.77185D0,  2.65127D0,  2.14594D0,  1.84019D0,
54468      &     1.62469D0,  1.08825D0,  0.70498D0,  0.53670D0,  0.43761D0,
54469      &     0.37103D0,  0.28563D0,  0.21235D0,  0.14727D0,  0.11103D0,
54470      &     0.07154D0,  0.05029D0,  0.03704D0,  0.02622D0,  0.01898D0,
54471      &     0.01394D0,  0.01028D0,  0.00760D0,  0.00562D0,  0.00415D0,
54472      &     0.00304D0,  0.00222D0,  0.00161D0,  0.00115D0,  0.00082D0,
54473      &     0.00058D0,  0.00042D0,  0.00031D0,  0.00024D0,  0.00019D0,
54474      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54475      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54476       DATA (FMRS(1,5,I,36),I=1,49)/
54477      &    17.48656D0, 12.39804D0,  8.78469D0,  7.17746D0,  6.21652D0,
54478      &     5.55909D0,  3.91895D0,  2.74520D0,  2.21743D0,  1.89869D0,
54479      &     1.67437D0,  1.11736D0,  0.72106D0,  0.54767D0,  0.44580D0,
54480      &     0.37747D0,  0.28999D0,  0.21509D0,  0.14875D0,  0.11190D0,
54481      &     0.07184D0,  0.05035D0,  0.03698D0,  0.02610D0,  0.01884D0,
54482      &     0.01380D0,  0.01016D0,  0.00749D0,  0.00553D0,  0.00407D0,
54483      &     0.00298D0,  0.00217D0,  0.00157D0,  0.00112D0,  0.00080D0,
54484      &     0.00057D0,  0.00041D0,  0.00031D0,  0.00024D0,  0.00019D0,
54485      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54486      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54487       DATA (FMRS(1,5,I,37),I=1,49)/
54488      &    18.41889D0, 13.01534D0,  9.19117D0,  7.49481D0,  6.48233D0,
54489      &     5.79049D0,  4.06828D0,  2.84006D0,  2.28940D0,  1.95745D0,
54490      &     1.72416D0,  1.14634D0,  0.73693D0,  0.55843D0,  0.45379D0,
54491      &     0.38373D0,  0.29419D0,  0.21770D0,  0.15013D0,  0.11269D0,
54492      &     0.07209D0,  0.05037D0,  0.03690D0,  0.02596D0,  0.01869D0,
54493      &     0.01365D0,  0.01003D0,  0.00738D0,  0.00543D0,  0.00399D0,
54494      &     0.00291D0,  0.00212D0,  0.00153D0,  0.00109D0,  0.00078D0,
54495      &     0.00055D0,  0.00040D0,  0.00030D0,  0.00023D0,  0.00019D0,
54496      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
54497      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54498       DATA (FMRS(1,5,I,38),I=1,49)/
54499      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54500      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54501      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54502      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54503      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54504      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54505      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54506      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54507      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54508      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54509       DATA (FMRS(1,6,I, 1),I=1,49)/
54510      &     0.44989D0,  0.39539D0,  0.34747D0,  0.32216D0,  0.30531D0,
54511      &     0.29285D0,  0.25722D0,  0.22578D0,  0.20909D0,  0.19792D0,
54512      &     0.18955D0,  0.16547D0,  0.14378D0,  0.13212D0,  0.12429D0,
54513      &     0.11845D0,  0.11003D0,  0.10150D0,  0.09208D0,  0.08532D0,
54514      &     0.07497D0,  0.06641D0,  0.05872D0,  0.04993D0,  0.04200D0,
54515      &     0.03492D0,  0.02867D0,  0.02327D0,  0.01867D0,  0.01463D0,
54516      &     0.01149D0,  0.00885D0,  0.00675D0,  0.00511D0,  0.00375D0,
54517      &     0.00275D0,  0.00200D0,  0.00140D0,  0.00092D0,  0.00067D0,
54518      &     0.00045D0,  0.00028D0,  0.00020D0,  0.00007D0,  0.00002D0,
54519      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54520       DATA (FMRS(1,6,I, 2),I=1,49)/
54521      &     0.46639D0,  0.41136D0,  0.36279D0,  0.33706D0,  0.31990D0,
54522      &     0.30719D0,  0.27073D0,  0.23840D0,  0.22115D0,  0.20956D0,
54523      &     0.20084D0,  0.17557D0,  0.15249D0,  0.13993D0,  0.13142D0,
54524      &     0.12504D0,  0.11578D0,  0.10635D0,  0.09591D0,  0.08845D0,
54525      &     0.07719D0,  0.06805D0,  0.05996D0,  0.05084D0,  0.04269D0,
54526      &     0.03544D0,  0.02909D0,  0.02361D0,  0.01895D0,  0.01488D0,
54527      &     0.01169D0,  0.00902D0,  0.00689D0,  0.00524D0,  0.00385D0,
54528      &     0.00283D0,  0.00206D0,  0.00146D0,  0.00096D0,  0.00071D0,
54529      &     0.00048D0,  0.00029D0,  0.00022D0,  0.00008D0,  0.00002D0,
54530      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54531       DATA (FMRS(1,6,I, 3),I=1,49)/
54532      &     0.50684D0,  0.44821D0,  0.39632D0,  0.36876D0,  0.35036D0,
54533      &     0.33670D0,  0.29743D0,  0.26242D0,  0.24363D0,  0.23094D0,
54534      &     0.22132D0,  0.19327D0,  0.16725D0,  0.15293D0,  0.14314D0,
54535      &     0.13576D0,  0.12501D0,  0.11402D0,  0.10188D0,  0.09328D0,
54536      &     0.08055D0,  0.07049D0,  0.06177D0,  0.05212D0,  0.04362D0,
54537      &     0.03613D0,  0.02960D0,  0.02400D0,  0.01926D0,  0.01513D0,
54538      &     0.01189D0,  0.00918D0,  0.00704D0,  0.00535D0,  0.00395D0,
54539      &     0.00290D0,  0.00211D0,  0.00152D0,  0.00101D0,  0.00074D0,
54540      &     0.00051D0,  0.00031D0,  0.00023D0,  0.00008D0,  0.00002D0,
54541      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54542       DATA (FMRS(1,6,I, 4),I=1,49)/
54543      &     0.55058D0,  0.48672D0,  0.43021D0,  0.40019D0,  0.38014D0,
54544      &     0.36526D0,  0.32246D0,  0.28426D0,  0.26371D0,  0.24981D0,
54545      &     0.23922D0,  0.20826D0,  0.17939D0,  0.16343D0,  0.15249D0,
54546      &     0.14425D0,  0.13221D0,  0.11993D0,  0.10640D0,  0.09689D0,
54547      &     0.08300D0,  0.07224D0,  0.06305D0,  0.05299D0,  0.04421D0,
54548      &     0.03653D0,  0.02989D0,  0.02420D0,  0.01939D0,  0.01523D0,
54549      &     0.01197D0,  0.00924D0,  0.00709D0,  0.00537D0,  0.00399D0,
54550      &     0.00293D0,  0.00213D0,  0.00154D0,  0.00102D0,  0.00074D0,
54551      &     0.00053D0,  0.00032D0,  0.00024D0,  0.00009D0,  0.00002D0,
54552      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54553       DATA (FMRS(1,6,I, 5),I=1,49)/
54554      &     0.61607D0,  0.54291D0,  0.47835D0,  0.44415D0,  0.42133D0,
54555      &     0.40441D0,  0.35583D0,  0.31254D0,  0.28927D0,  0.27353D0,
54556      &     0.26150D0,  0.22639D0,  0.19363D0,  0.17555D0,  0.16316D0,
54557      &     0.15384D0,  0.14026D0,  0.12643D0,  0.11130D0,  0.10077D0,
54558      &     0.08558D0,  0.07403D0,  0.06431D0,  0.05381D0,  0.04474D0,
54559      &     0.03686D0,  0.03008D0,  0.02432D0,  0.01945D0,  0.01528D0,
54560      &     0.01199D0,  0.00925D0,  0.00709D0,  0.00537D0,  0.00398D0,
54561      &     0.00293D0,  0.00214D0,  0.00154D0,  0.00103D0,  0.00074D0,
54562      &     0.00052D0,  0.00032D0,  0.00024D0,  0.00008D0,  0.00002D0,
54563      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54564       DATA (FMRS(1,6,I, 6),I=1,49)/
54565      &     0.68336D0,  0.60005D0,  0.52679D0,  0.48807D0,  0.46228D0,
54566      &     0.44318D0,  0.38846D0,  0.33984D0,  0.31375D0,  0.29611D0,
54567      &     0.28263D0,  0.24332D0,  0.20674D0,  0.18660D0,  0.17283D0,
54568      &     0.16249D0,  0.14745D0,  0.13219D0,  0.11560D0,  0.10414D0,
54569      &     0.08779D0,  0.07555D0,  0.06535D0,  0.05447D0,  0.04515D0,
54570      &     0.03709D0,  0.03021D0,  0.02439D0,  0.01946D0,  0.01528D0,
54571      &     0.01197D0,  0.00923D0,  0.00707D0,  0.00536D0,  0.00396D0,
54572      &     0.00291D0,  0.00213D0,  0.00154D0,  0.00103D0,  0.00073D0,
54573      &     0.00051D0,  0.00032D0,  0.00023D0,  0.00008D0,  0.00002D0,
54574      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54575       DATA (FMRS(1,6,I, 7),I=1,49)/
54576      &     0.76355D0,  0.66723D0,  0.58292D0,  0.53852D0,  0.50902D0,
54577      &     0.48721D0,  0.42490D0,  0.36978D0,  0.34030D0,  0.32042D0,
54578      &     0.30522D0,  0.26107D0,  0.22021D0,  0.19782D0,  0.18257D0,
54579      &     0.17114D0,  0.15457D0,  0.13784D0,  0.11976D0,  0.10736D0,
54580      &     0.08987D0,  0.07693D0,  0.06629D0,  0.05503D0,  0.04547D0,
54581      &     0.03726D0,  0.03027D0,  0.02439D0,  0.01942D0,  0.01523D0,
54582      &     0.01190D0,  0.00918D0,  0.00701D0,  0.00533D0,  0.00392D0,
54583      &     0.00287D0,  0.00209D0,  0.00153D0,  0.00101D0,  0.00073D0,
54584      &     0.00050D0,  0.00032D0,  0.00022D0,  0.00007D0,  0.00002D0,
54585      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54586       DATA (FMRS(1,6,I, 8),I=1,49)/
54587      &     0.86343D0,  0.75010D0,  0.65144D0,  0.59973D0,  0.56547D0,
54588      &     0.54018D0,  0.46822D0,  0.40492D0,  0.37123D0,  0.34856D0,
54589      &     0.33127D0,  0.28125D0,  0.23529D0,  0.21028D0,  0.19331D0,
54590      &     0.18063D0,  0.16233D0,  0.14394D0,  0.12420D0,  0.11077D0,
54591      &     0.09202D0,  0.07835D0,  0.06722D0,  0.05555D0,  0.04575D0,
54592      &     0.03737D0,  0.03028D0,  0.02434D0,  0.01934D0,  0.01514D0,
54593      &     0.01181D0,  0.00909D0,  0.00694D0,  0.00526D0,  0.00387D0,
54594      &     0.00282D0,  0.00206D0,  0.00150D0,  0.00100D0,  0.00072D0,
54595      &     0.00049D0,  0.00031D0,  0.00021D0,  0.00008D0,  0.00002D0,
54596      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54597       DATA (FMRS(1,6,I, 9),I=1,49)/
54598      &     0.96361D0,  0.83251D0,  0.71897D0,  0.65971D0,  0.62055D0,
54599      &     0.59171D0,  0.50993D0,  0.43838D0,  0.40047D0,  0.37504D0,
54600      &     0.35567D0,  0.29991D0,  0.24906D0,  0.22156D0,  0.20298D0,
54601      &     0.18914D0,  0.16924D0,  0.14933D0,  0.12809D0,  0.11373D0,
54602      &     0.09387D0,  0.07954D0,  0.06798D0,  0.05596D0,  0.04595D0,
54603      &     0.03743D0,  0.03026D0,  0.02427D0,  0.01926D0,  0.01505D0,
54604      &     0.01172D0,  0.00900D0,  0.00687D0,  0.00519D0,  0.00383D0,
54605      &     0.00278D0,  0.00203D0,  0.00148D0,  0.00098D0,  0.00071D0,
54606      &     0.00048D0,  0.00031D0,  0.00021D0,  0.00008D0,  0.00002D0,
54607      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54608       DATA (FMRS(1,6,I,10),I=1,49)/
54609      &     1.07479D0,  0.92315D0,  0.79255D0,  0.72469D0,  0.67997D0,
54610      &     0.64711D0,  0.55427D0,  0.47353D0,  0.43097D0,  0.40251D0,
54611      &     0.38089D0,  0.31894D0,  0.26290D0,  0.23280D0,  0.21256D0,
54612      &     0.19753D0,  0.17599D0,  0.15455D0,  0.13181D0,  0.11654D0,
54613      &     0.09559D0,  0.08062D0,  0.06865D0,  0.05629D0,  0.04608D0,
54614      &     0.03743D0,  0.03019D0,  0.02416D0,  0.01913D0,  0.01493D0,
54615      &     0.01161D0,  0.00890D0,  0.00677D0,  0.00511D0,  0.00377D0,
54616      &     0.00274D0,  0.00200D0,  0.00145D0,  0.00096D0,  0.00068D0,
54617      &     0.00046D0,  0.00030D0,  0.00020D0,  0.00008D0,  0.00002D0,
54618      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54619       DATA (FMRS(1,6,I,11),I=1,49)/
54620      &     1.17232D0,  1.00213D0,  0.85623D0,  0.78069D0,  0.73104D0,
54621      &     0.69461D0,  0.59200D0,  0.50321D0,  0.45658D0,  0.42550D0,
54622      &     0.40194D0,  0.33467D0,  0.27424D0,  0.24195D0,  0.22032D0,
54623      &     0.20431D0,  0.18142D0,  0.15872D0,  0.13477D0,  0.11875D0,
54624      &     0.09692D0,  0.08144D0,  0.06915D0,  0.05653D0,  0.04615D0,
54625      &     0.03741D0,  0.03011D0,  0.02406D0,  0.01902D0,  0.01482D0,
54626      &     0.01152D0,  0.00881D0,  0.00669D0,  0.00505D0,  0.00371D0,
54627      &     0.00270D0,  0.00197D0,  0.00143D0,  0.00094D0,  0.00066D0,
54628      &     0.00045D0,  0.00029D0,  0.00020D0,  0.00008D0,  0.00002D0,
54629      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54630       DATA (FMRS(1,6,I,12),I=1,49)/
54631      &     1.41135D0,  1.19389D0,  1.00931D0,  0.91452D0,  0.85253D0,
54632      &     0.80723D0,  0.68048D0,  0.57199D0,  0.51554D0,  0.47813D0,
54633      &     0.44992D0,  0.37007D0,  0.29939D0,  0.26209D0,  0.23729D0,
54634      &     0.21905D0,  0.19312D0,  0.16764D0,  0.14100D0,  0.12337D0,
54635      &     0.09965D0,  0.08309D0,  0.07010D0,  0.05694D0,  0.04624D0,
54636      &     0.03729D0,  0.02989D0,  0.02378D0,  0.01873D0,  0.01456D0,
54637      &     0.01128D0,  0.00861D0,  0.00651D0,  0.00490D0,  0.00360D0,
54638      &     0.00260D0,  0.00189D0,  0.00137D0,  0.00090D0,  0.00062D0,
54639      &     0.00043D0,  0.00028D0,  0.00019D0,  0.00007D0,  0.00002D0,
54640      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54641       DATA (FMRS(1,6,I,13),I=1,49)/
54642      &     1.65256D0,  1.38522D0,  1.16028D0,  1.04559D0,  0.97092D0,
54643      &     0.91653D0,  0.76529D0,  0.63704D0,  0.57085D0,  0.52722D0,
54644      &     0.49446D0,  0.40243D0,  0.32201D0,  0.28002D0,  0.25230D0,
54645      &     0.23200D0,  0.20332D0,  0.17533D0,  0.14629D0,  0.12724D0,
54646      &     0.10187D0,  0.08438D0,  0.07080D0,  0.05719D0,  0.04622D0,
54647      &     0.03712D0,  0.02965D0,  0.02350D0,  0.01845D0,  0.01430D0,
54648      &     0.01104D0,  0.00841D0,  0.00634D0,  0.00476D0,  0.00349D0,
54649      &     0.00251D0,  0.00182D0,  0.00132D0,  0.00086D0,  0.00060D0,
54650      &     0.00042D0,  0.00026D0,  0.00018D0,  0.00006D0,  0.00002D0,
54651      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54652       DATA (FMRS(1,6,I,14),I=1,49)/
54653      &     1.96387D0,  1.62942D0,  1.35081D0,  1.20988D0,  1.11860D0,
54654      &     1.05236D0,  0.86939D0,  0.71589D0,  0.63738D0,  0.58593D0,
54655      &     0.54750D0,  0.44041D0,  0.34815D0,  0.30054D0,  0.26935D0,
54656      &     0.24663D0,  0.21473D0,  0.18383D0,  0.15206D0,  0.13140D0,
54657      &     0.10419D0,  0.08567D0,  0.07145D0,  0.05736D0,  0.04609D0,
54658      &     0.03684D0,  0.02930D0,  0.02313D0,  0.01809D0,  0.01398D0,
54659      &     0.01074D0,  0.00816D0,  0.00615D0,  0.00459D0,  0.00334D0,
54660      &     0.00240D0,  0.00174D0,  0.00125D0,  0.00082D0,  0.00057D0,
54661      &     0.00038D0,  0.00024D0,  0.00016D0,  0.00006D0,  0.00002D0,
54662      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54663       DATA (FMRS(1,6,I,15),I=1,49)/
54664      &     2.33902D0,  1.92024D0,  1.57497D0,  1.40179D0,  1.29021D0,
54665      &     1.20956D0,  0.98833D0,  0.80477D0,  0.71175D0,  0.65116D0,
54666      &     0.60614D0,  0.48174D0,  0.37612D0,  0.32226D0,  0.28724D0,
54667      &     0.26188D0,  0.22649D0,  0.19248D0,  0.15783D0,  0.13549D0,
54668      &     0.10637D0,  0.08680D0,  0.07195D0,  0.05738D0,  0.04585D0,
54669      &     0.03646D0,  0.02886D0,  0.02269D0,  0.01768D0,  0.01360D0,
54670      &     0.01043D0,  0.00789D0,  0.00592D0,  0.00441D0,  0.00321D0,
54671      &     0.00230D0,  0.00166D0,  0.00118D0,  0.00078D0,  0.00054D0,
54672      &     0.00037D0,  0.00022D0,  0.00015D0,  0.00006D0,  0.00002D0,
54673      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54674       DATA (FMRS(1,6,I,16),I=1,49)/
54675      &     2.72482D0,  2.21608D0,  1.80052D0,  1.59364D0,  1.46096D0,
54676      &     1.36541D0,  1.10490D0,  0.89086D0,  0.78327D0,  0.71357D0,
54677      &     0.66200D0,  0.52058D0,  0.40200D0,  0.34217D0,  0.30354D0,
54678      &     0.27569D0,  0.23704D0,  0.20015D0,  0.16285D0,  0.13900D0,
54679      &     0.10817D0,  0.08767D0,  0.07227D0,  0.05729D0,  0.04554D0,
54680      &     0.03606D0,  0.02842D0,  0.02227D0,  0.01728D0,  0.01326D0,
54681      &     0.01012D0,  0.00763D0,  0.00571D0,  0.00425D0,  0.00307D0,
54682      &     0.00219D0,  0.00158D0,  0.00112D0,  0.00073D0,  0.00051D0,
54683      &     0.00035D0,  0.00021D0,  0.00014D0,  0.00005D0,  0.00002D0,
54684      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54685       DATA (FMRS(1,6,I,17),I=1,49)/
54686      &     3.16184D0,  2.54784D0,  2.05090D0,  1.80533D0,  1.64858D0,
54687      &     1.53608D0,  1.23122D0,  0.98314D0,  0.85944D0,  0.77972D0,
54688      &     0.72099D0,  0.56109D0,  0.42865D0,  0.36249D0,  0.32006D0,
54689      &     0.28962D0,  0.24759D0,  0.20774D0,  0.16775D0,  0.14236D0,
54690      &     0.10984D0,  0.08843D0,  0.07249D0,  0.05712D0,  0.04518D0,
54691      &     0.03560D0,  0.02794D0,  0.02182D0,  0.01686D0,  0.01291D0,
54692      &     0.00980D0,  0.00737D0,  0.00550D0,  0.00408D0,  0.00294D0,
54693      &     0.00209D0,  0.00150D0,  0.00107D0,  0.00069D0,  0.00049D0,
54694      &     0.00034D0,  0.00019D0,  0.00014D0,  0.00005D0,  0.00001D0,
54695      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54696       DATA (FMRS(1,6,I,18),I=1,49)/
54697      &     3.56226D0,  2.84906D0,  2.27616D0,  1.99475D0,  1.81581D0,
54698      &     1.68774D0,  1.34241D0,  1.06358D0,  0.92544D0,  0.83679D0,
54699      &     0.77171D0,  0.59551D0,  0.45100D0,  0.37940D0,  0.33372D0,
54700      &     0.30107D0,  0.25620D0,  0.21386D0,  0.17164D0,  0.14499D0,
54701      &     0.11108D0,  0.08895D0,  0.07258D0,  0.05692D0,  0.04483D0,
54702      &     0.03518D0,  0.02753D0,  0.02142D0,  0.01651D0,  0.01260D0,
54703      &     0.00954D0,  0.00717D0,  0.00532D0,  0.00393D0,  0.00284D0,
54704      &     0.00201D0,  0.00144D0,  0.00103D0,  0.00066D0,  0.00045D0,
54705      &     0.00032D0,  0.00018D0,  0.00013D0,  0.00004D0,  0.00001D0,
54706      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54707       DATA (FMRS(1,6,I,19),I=1,49)/
54708      &     4.09416D0,  3.24567D0,  2.57011D0,  2.24065D0,  2.03209D0,
54709      &     1.88332D0,  1.48448D0,  1.16540D0,  1.00850D0,  0.90831D0,
54710      &     0.83504D0,  0.63803D0,  0.47827D0,  0.39987D0,  0.35015D0,
54711      &     0.31478D0,  0.26640D0,  0.22104D0,  0.17612D0,  0.14797D0,
54712      &     0.11241D0,  0.08943D0,  0.07259D0,  0.05659D0,  0.04434D0,
54713      &     0.03464D0,  0.02699D0,  0.02092D0,  0.01606D0,  0.01221D0,
54714      &     0.00922D0,  0.00691D0,  0.00511D0,  0.00375D0,  0.00271D0,
54715      &     0.00191D0,  0.00136D0,  0.00097D0,  0.00063D0,  0.00043D0,
54716      &     0.00030D0,  0.00017D0,  0.00012D0,  0.00004D0,  0.00001D0,
54717      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54718       DATA (FMRS(1,6,I,20),I=1,49)/
54719      &     4.61257D0,  3.62885D0,  2.85161D0,  2.47491D0,  2.23738D0,
54720      &     2.06842D0,  1.61774D0,  1.26001D0,  1.08527D0,  0.97415D0,
54721      &     0.89315D0,  0.67662D0,  0.50274D0,  0.41811D0,  0.36471D0,
54722      &     0.32688D0,  0.27534D0,  0.22728D0,  0.17996D0,  0.15048D0,
54723      &     0.11349D0,  0.08979D0,  0.07253D0,  0.05626D0,  0.04389D0,
54724      &     0.03414D0,  0.02651D0,  0.02047D0,  0.01566D0,  0.01187D0,
54725      &     0.00894D0,  0.00668D0,  0.00493D0,  0.00361D0,  0.00261D0,
54726      &     0.00182D0,  0.00129D0,  0.00093D0,  0.00059D0,  0.00040D0,
54727      &     0.00028D0,  0.00016D0,  0.00011D0,  0.00004D0,  0.00001D0,
54728      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54729       DATA (FMRS(1,6,I,21),I=1,49)/
54730      &     5.12222D0,  4.00261D0,  3.12404D0,  2.70057D0,  2.43446D0,
54731      &     2.24566D0,  1.74429D0,  1.34911D0,  1.15718D0,  1.03559D0,
54732      &     0.94721D0,  0.71215D0,  0.52500D0,  0.43455D0,  0.37776D0,
54733      &     0.33766D0,  0.28323D0,  0.23271D0,  0.18324D0,  0.15257D0,
54734      &     0.11432D0,  0.08998D0,  0.07237D0,  0.05588D0,  0.04342D0,
54735      &     0.03365D0,  0.02604D0,  0.02004D0,  0.01529D0,  0.01156D0,
54736      &     0.00869D0,  0.00646D0,  0.00477D0,  0.00348D0,  0.00251D0,
54737      &     0.00175D0,  0.00124D0,  0.00088D0,  0.00057D0,  0.00038D0,
54738      &     0.00026D0,  0.00015D0,  0.00010D0,  0.00004D0,  0.00001D0,
54739      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54740       DATA (FMRS(1,6,I,22),I=1,49)/
54741      &     5.82554D0,  4.51423D0,  3.49391D0,  3.00548D0,  2.69986D0,
54742      &     2.48370D0,  1.91285D0,  1.46678D0,  1.25167D0,  1.11601D0,
54743      &     1.01775D0,  0.75806D0,  0.55345D0,  0.45543D0,  0.39424D0,
54744      &     0.35121D0,  0.29307D0,  0.23942D0,  0.18722D0,  0.15507D0,
54745      &     0.11526D0,  0.09014D0,  0.07211D0,  0.05536D0,  0.04279D0,
54746      &     0.03301D0,  0.02543D0,  0.01950D0,  0.01483D0,  0.01117D0,
54747      &     0.00837D0,  0.00620D0,  0.00456D0,  0.00332D0,  0.00238D0,
54748      &     0.00166D0,  0.00117D0,  0.00083D0,  0.00053D0,  0.00035D0,
54749      &     0.00024D0,  0.00015D0,  0.00010D0,  0.00003D0,  0.00001D0,
54750      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54751       DATA (FMRS(1,6,I,23),I=1,49)/
54752      &     6.54676D0,  5.03439D0,  3.86673D0,  3.31126D0,  2.96506D0,
54753      &     2.72090D0,  2.07933D0,  1.58195D0,  1.34364D0,  1.19398D0,
54754      &     1.08591D0,  0.80195D0,  0.58033D0,  0.47501D0,  0.40960D0,
54755      &     0.36377D0,  0.30212D0,  0.24551D0,  0.19078D0,  0.15726D0,
54756      &     0.11602D0,  0.09021D0,  0.07181D0,  0.05483D0,  0.04218D0,
54757      &     0.03240D0,  0.02486D0,  0.01900D0,  0.01440D0,  0.01081D0,
54758      &     0.00808D0,  0.00597D0,  0.00437D0,  0.00317D0,  0.00227D0,
54759      &     0.00157D0,  0.00111D0,  0.00080D0,  0.00050D0,  0.00034D0,
54760      &     0.00022D0,  0.00014D0,  0.00009D0,  0.00003D0,  0.00001D0,
54761      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54762       DATA (FMRS(1,6,I,24),I=1,49)/
54763      &     7.26565D0,  5.54876D0,  4.23247D0,  3.60982D0,  3.22311D0,
54764      &     2.95109D0,  2.23956D0,  1.69183D0,  1.43093D0,  1.26769D0,
54765      &     1.15015D0,  0.84286D0,  0.60508D0,  0.49288D0,  0.42351D0,
54766      &     0.37509D0,  0.31017D0,  0.25086D0,  0.19381D0,  0.15905D0,
54767      &     0.11655D0,  0.09013D0,  0.07142D0,  0.05426D0,  0.04157D0,
54768      &     0.03180D0,  0.02431D0,  0.01852D0,  0.01399D0,  0.01048D0,
54769      &     0.00780D0,  0.00574D0,  0.00419D0,  0.00304D0,  0.00217D0,
54770      &     0.00149D0,  0.00106D0,  0.00075D0,  0.00048D0,  0.00032D0,
54771      &     0.00021D0,  0.00013D0,  0.00009D0,  0.00003D0,  0.00001D0,
54772      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54773       DATA (FMRS(1,6,I,25),I=1,49)/
54774      &     8.04192D0,  6.10017D0,  4.62168D0,  3.92618D0,  3.49572D0,
54775      &     3.19370D0,  2.40717D0,  1.80591D0,  1.52114D0,  1.34361D0,
54776      &     1.21613D0,  0.88453D0,  0.63003D0,  0.51078D0,  0.43739D0,
54777      &     0.38633D0,  0.31813D0,  0.25609D0,  0.19674D0,  0.16076D0,
54778      &     0.11701D0,  0.09001D0,  0.07101D0,  0.05368D0,  0.04095D0,
54779      &     0.03121D0,  0.02377D0,  0.01805D0,  0.01359D0,  0.01015D0,
54780      &     0.00753D0,  0.00553D0,  0.00402D0,  0.00291D0,  0.00207D0,
54781      &     0.00142D0,  0.00101D0,  0.00071D0,  0.00045D0,  0.00030D0,
54782      &     0.00020D0,  0.00012D0,  0.00008D0,  0.00003D0,  0.00001D0,
54783      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54784       DATA (FMRS(1,6,I,26),I=1,49)/
54785      &     8.84513D0,  6.66663D0,  5.01863D0,  4.24745D0,  3.77171D0,
54786      &     3.43873D0,  2.57518D0,  1.91937D0,  1.61043D0,  1.41849D0,
54787      &     1.28102D0,  0.92509D0,  0.65405D0,  0.52788D0,  0.45056D0,
54788      &     0.39694D0,  0.32555D0,  0.26091D0,  0.19936D0,  0.16223D0,
54789      &     0.11732D0,  0.08979D0,  0.07053D0,  0.05307D0,  0.04031D0,
54790      &     0.03061D0,  0.02325D0,  0.01759D0,  0.01321D0,  0.00982D0,
54791      &     0.00728D0,  0.00532D0,  0.00387D0,  0.00279D0,  0.00197D0,
54792      &     0.00136D0,  0.00096D0,  0.00067D0,  0.00043D0,  0.00029D0,
54793      &     0.00019D0,  0.00011D0,  0.00007D0,  0.00003D0,  0.00001D0,
54794      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54795       DATA (FMRS(1,6,I,27),I=1,49)/
54796      &     9.65435D0,  7.23356D0,  5.41328D0,  4.56560D0,  4.04426D0,
54797      &     3.68017D0,  2.73960D0,  2.02962D0,  1.69683D0,  1.49072D0,
54798      &     1.34344D0,  0.96379D0,  0.67674D0,  0.54393D0,  0.46286D0,
54799      &     0.40680D0,  0.33241D0,  0.26531D0,  0.20171D0,  0.16351D0,
54800      &     0.11755D0,  0.08953D0,  0.07005D0,  0.05247D0,  0.03970D0,
54801      &     0.03004D0,  0.02275D0,  0.01715D0,  0.01284D0,  0.00953D0,
54802      &     0.00704D0,  0.00513D0,  0.00373D0,  0.00268D0,  0.00189D0,
54803      &     0.00130D0,  0.00092D0,  0.00064D0,  0.00040D0,  0.00027D0,
54804      &     0.00018D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
54805      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54806       DATA (FMRS(1,6,I,28),I=1,49)/
54807      &    10.45602D0,  7.79175D0,  5.79941D0,  4.87575D0,  4.30926D0,
54808      &     3.91444D0,  2.89810D0,  2.13519D0,  1.77921D0,  1.55938D0,
54809      &     1.40263D0,  1.00018D0,  0.69787D0,  0.55877D0,  0.47417D0,
54810      &     0.41582D0,  0.33862D0,  0.26925D0,  0.20376D0,  0.16459D0,
54811      &     0.11767D0,  0.08923D0,  0.06955D0,  0.05189D0,  0.03911D0,
54812      &     0.02950D0,  0.02227D0,  0.01675D0,  0.01249D0,  0.00926D0,
54813      &     0.00681D0,  0.00496D0,  0.00359D0,  0.00258D0,  0.00181D0,
54814      &     0.00125D0,  0.00088D0,  0.00062D0,  0.00038D0,  0.00026D0,
54815      &     0.00017D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
54816      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54817       DATA (FMRS(1,6,I,29),I=1,49)/
54818      &    11.30416D0,  8.37884D0,  6.20316D0,  5.19892D0,  4.58469D0,
54819      &     4.15747D0,  3.06152D0,  2.24335D0,  1.86330D0,  1.62927D0,
54820      &     1.46273D0,  1.03685D0,  0.71898D0,  0.57351D0,  0.48535D0,
54821      &     0.42471D0,  0.34469D0,  0.27305D0,  0.20570D0,  0.16558D0,
54822      &     0.11773D0,  0.08889D0,  0.06902D0,  0.05129D0,  0.03852D0,
54823      &     0.02896D0,  0.02179D0,  0.01634D0,  0.01216D0,  0.00899D0,
54824      &     0.00659D0,  0.00479D0,  0.00347D0,  0.00248D0,  0.00174D0,
54825      &     0.00119D0,  0.00084D0,  0.00059D0,  0.00036D0,  0.00024D0,
54826      &     0.00016D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
54827      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54828       DATA (FMRS(1,6,I,30),I=1,49)/
54829      &    12.17534D0,  8.97841D0,  6.61310D0,  5.52592D0,  4.86271D0,
54830      &     4.40230D0,  3.22516D0,  2.35097D0,  1.94663D0,  1.69833D0,
54831      &     1.52199D0,  1.07270D0,  0.73942D0,  0.58770D0,  0.49605D0,
54832      &     0.43317D0,  0.35042D0,  0.27659D0,  0.20745D0,  0.16642D0,
54833      &     0.11771D0,  0.08850D0,  0.06847D0,  0.05068D0,  0.03793D0,
54834      &     0.02842D0,  0.02132D0,  0.01595D0,  0.01184D0,  0.00872D0,
54835      &     0.00639D0,  0.00464D0,  0.00334D0,  0.00238D0,  0.00167D0,
54836      &     0.00115D0,  0.00081D0,  0.00056D0,  0.00034D0,  0.00023D0,
54837      &     0.00015D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00000D0,
54838      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54839       DATA (FMRS(1,6,I,31),I=1,49)/
54840      &    13.04562D0,  9.57419D0,  7.01826D0,  5.84808D0,  5.13599D0,
54841      &     4.64254D0,  3.38483D0,  2.45538D0,  2.02720D0,  1.76492D0,
54842      &     1.57901D0,  1.10697D0,  0.75881D0,  0.60107D0,  0.50610D0,
54843      &     0.44109D0,  0.35574D0,  0.27985D0,  0.20903D0,  0.16716D0,
54844      &     0.11764D0,  0.08810D0,  0.06793D0,  0.05010D0,  0.03737D0,
54845      &     0.02791D0,  0.02089D0,  0.01558D0,  0.01154D0,  0.00848D0,
54846      &     0.00620D0,  0.00450D0,  0.00323D0,  0.00230D0,  0.00160D0,
54847      &     0.00110D0,  0.00077D0,  0.00053D0,  0.00032D0,  0.00022D0,
54848      &     0.00015D0,  0.00008D0,  0.00006D0,  0.00002D0,  0.00000D0,
54849      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54850       DATA (FMRS(1,6,I,32),I=1,49)/
54851      &    13.89443D0, 10.15226D0,  7.40931D0,  6.15805D0,  5.39834D0,
54852      &     4.87276D0,  3.53699D0,  2.55429D0,  2.10325D0,  1.82761D0,
54853      &     1.63256D0,  1.13890D0,  0.77669D0,  0.61332D0,  0.51524D0,
54854      &     0.44825D0,  0.36050D0,  0.28271D0,  0.21036D0,  0.16773D0,
54855      &     0.11750D0,  0.08767D0,  0.06738D0,  0.04952D0,  0.03683D0,
54856      &     0.02743D0,  0.02048D0,  0.01524D0,  0.01125D0,  0.00826D0,
54857      &     0.00603D0,  0.00436D0,  0.00312D0,  0.00222D0,  0.00155D0,
54858      &     0.00106D0,  0.00074D0,  0.00051D0,  0.00031D0,  0.00021D0,
54859      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
54860      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54861       DATA (FMRS(1,6,I,33),I=1,49)/
54862      &    14.79866D0, 10.76526D0,  7.82209D0,  6.48437D0,  5.67399D0,
54863      &     5.11430D0,  3.69589D0,  2.65710D0,  2.18207D0,  1.89245D0,
54864      &     1.68785D0,  1.17170D0,  0.79496D0,  0.62581D0,  0.52453D0,
54865      &     0.45551D0,  0.36532D0,  0.28560D0,  0.21171D0,  0.16831D0,
54866      &     0.11736D0,  0.08724D0,  0.06684D0,  0.04896D0,  0.03630D0,
54867      &     0.02696D0,  0.02007D0,  0.01490D0,  0.01098D0,  0.00805D0,
54868      &     0.00586D0,  0.00423D0,  0.00302D0,  0.00214D0,  0.00150D0,
54869      &     0.00102D0,  0.00071D0,  0.00049D0,  0.00030D0,  0.00020D0,
54870      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
54871      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54872       DATA (FMRS(1,6,I,34),I=1,49)/
54873      &    15.70368D0, 11.37564D0,  8.23095D0,  6.80656D0,  5.94554D0,
54874      &     5.35181D0,  3.85123D0,  2.75698D0,  2.25835D0,  1.95501D0,
54875      &     1.74107D0,  1.20298D0,  0.81219D0,  0.63747D0,  0.53315D0,
54876      &     0.46219D0,  0.36968D0,  0.28814D0,  0.21281D0,  0.16870D0,
54877      &     0.11711D0,  0.08674D0,  0.06626D0,  0.04836D0,  0.03575D0,
54878      &     0.02649D0,  0.01967D0,  0.01456D0,  0.01071D0,  0.00784D0,
54879      &     0.00568D0,  0.00409D0,  0.00292D0,  0.00207D0,  0.00144D0,
54880      &     0.00098D0,  0.00068D0,  0.00047D0,  0.00029D0,  0.00019D0,
54881      &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
54882      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54883       DATA (FMRS(1,6,I,35),I=1,49)/
54884      &    16.61098D0, 11.98498D0,  8.63737D0,  7.12604D0,  6.21432D0,
54885      &     5.58657D0,  4.00413D0,  2.85486D0,  2.33290D0,  2.01603D0,
54886      &     1.79291D0,  1.23331D0,  0.82880D0,  0.64868D0,  0.54141D0,
54887      &     0.46858D0,  0.37384D0,  0.29056D0,  0.21385D0,  0.16907D0,
54888      &     0.11687D0,  0.08628D0,  0.06571D0,  0.04780D0,  0.03525D0,
54889      &     0.02604D0,  0.01929D0,  0.01425D0,  0.01046D0,  0.00764D0,
54890      &     0.00552D0,  0.00397D0,  0.00283D0,  0.00200D0,  0.00139D0,
54891      &     0.00095D0,  0.00066D0,  0.00045D0,  0.00028D0,  0.00019D0,
54892      &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
54893      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54894       DATA (FMRS(1,6,I,36),I=1,49)/
54895      &    17.49641D0, 12.57703D0,  9.03053D0,  7.43428D0,  6.47316D0,
54896      &     5.81232D0,  4.15045D0,  2.94807D0,  2.40367D0,  2.07383D0,
54897      &     1.84191D0,  1.26179D0,  0.84428D0,  0.65906D0,  0.54902D0,
54898      &     0.47444D0,  0.37762D0,  0.29271D0,  0.21474D0,  0.16935D0,
54899      &     0.11660D0,  0.08580D0,  0.06517D0,  0.04726D0,  0.03476D0,
54900      &     0.02562D0,  0.01894D0,  0.01396D0,  0.01022D0,  0.00745D0,
54901      &     0.00538D0,  0.00386D0,  0.00274D0,  0.00194D0,  0.00135D0,
54902      &     0.00092D0,  0.00063D0,  0.00044D0,  0.00027D0,  0.00018D0,
54903      &     0.00011D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
54904      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54905       DATA (FMRS(1,6,I,37),I=1,49)/
54906      &    18.41415D0, 13.18812D0,  9.43458D0,  7.75025D0,  6.73800D0,
54907      &     6.04297D0,  4.29926D0,  3.04240D0,  2.47507D0,  2.13202D0,
54908      &     1.89114D0,  1.29020D0,  0.85959D0,  0.66927D0,  0.55646D0,
54909      &     0.48015D0,  0.38126D0,  0.29476D0,  0.21554D0,  0.16955D0,
54910      &     0.11628D0,  0.08530D0,  0.06461D0,  0.04672D0,  0.03427D0,
54911      &     0.02520D0,  0.01858D0,  0.01367D0,  0.00999D0,  0.00727D0,
54912      &     0.00525D0,  0.00375D0,  0.00266D0,  0.00188D0,  0.00131D0,
54913      &     0.00088D0,  0.00061D0,  0.00042D0,  0.00026D0,  0.00017D0,
54914      &     0.00011D0,  0.00006D0,  0.00004D0,  0.00001D0,  0.00000D0,
54915      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54916       DATA (FMRS(1,6,I,38),I=1,49)/
54917      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54918      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54919      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54920      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54921      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54922      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54923      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54924      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54925      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54926      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54927       DATA (FMRS(1,7,I, 1),I=1,49)/
54928      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54929      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54930      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54931      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54932      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54933      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54934      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54935      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54936      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54937      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54938       DATA (FMRS(1,7,I, 2),I=1,49)/
54939      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54940      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54941      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54942      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54943      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54944      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54945      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54946      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54947      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54948      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54949       DATA (FMRS(1,7,I, 3),I=1,49)/
54950      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54951      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54952      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54953      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54954      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54955      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54956      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54957      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54958      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54959      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54960       DATA (FMRS(1,7,I, 4),I=1,49)/
54961      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54962      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54963      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54964      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54965      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54966      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54967      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54968      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54969      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54970      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54971       DATA (FMRS(1,7,I, 5),I=1,49)/
54972      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54973      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54974      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54975      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54976      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54977      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54978      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54979      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54980      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54981      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54982       DATA (FMRS(1,7,I, 6),I=1,49)/
54983      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54984      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54985      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54986      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54987      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54988      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54989      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54990      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54991      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54992      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54993       DATA (FMRS(1,7,I, 7),I=1,49)/
54994      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54995      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54996      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54997      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54998      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54999      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55000      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55001      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55002      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55003      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55004       DATA (FMRS(1,7,I, 8),I=1,49)/
55005      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55006      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55007      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55008      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55009      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55010      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55011      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55012      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55013      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55014      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55015       DATA (FMRS(1,7,I, 9),I=1,49)/
55016      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55017      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55018      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55019      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55020      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55021      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55022      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55023      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55024      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55025      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55026       DATA (FMRS(1,7,I,10),I=1,49)/
55027      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55028      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55029      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55030      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55031      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55032      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55033      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55034      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55035      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55036      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55037       DATA (FMRS(1,7,I,11),I=1,49)/
55038      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55039      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55040      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55041      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55042      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55043      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55044      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55045      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55046      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55047      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55048       DATA (FMRS(1,7,I,12),I=1,49)/
55049      &     0.00042D0,  0.00036D0,  0.00032D0,  0.00030D0,  0.00028D0,
55050      &     0.00027D0,  0.00023D0,  0.00020D0,  0.00019D0,  0.00018D0,
55051      &     0.00017D0,  0.00014D0,  0.00012D0,  0.00011D0,  0.00010D0,
55052      &     0.00009D0,  0.00008D0,  0.00007D0,  0.00006D0,  0.00005D0,
55053      &     0.00005D0,  0.00004D0,  0.00003D0,  0.00003D0,  0.00003D0,
55054      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00001D0,
55055      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
55056      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55057      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55058      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55059       DATA (FMRS(1,7,I,13),I=1,49)/
55060      &     0.21520D0,  0.16773D0,  0.13065D0,  0.11283D0,  0.10165D0,
55061      &     0.09372D0,  0.07266D0,  0.05600D0,  0.04786D0,  0.04266D0,
55062      &     0.03883D0,  0.02862D0,  0.02044D0,  0.01649D0,  0.01402D0,
55063      &     0.01228D0,  0.00994D0,  0.00781D0,  0.00579D0,  0.00460D0,
55064      &     0.00322D0,  0.00243D0,  0.00191D0,  0.00146D0,  0.00114D0,
55065      &     0.00089D0,  0.00070D0,  0.00055D0,  0.00043D0,  0.00034D0,
55066      &     0.00026D0,  0.00020D0,  0.00015D0,  0.00011D0,  0.00009D0,
55067      &     0.00006D0,  0.00005D0,  0.00003D0,  0.00002D0,  0.00001D0,
55068      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55069      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55070       DATA (FMRS(1,7,I,14),I=1,49)/
55071      &     0.62424D0,  0.48455D0,  0.37589D0,  0.32385D0,  0.29126D0,
55072      &     0.26818D0,  0.20706D0,  0.15892D0,  0.13546D0,  0.12053D0,
55073      &     0.10954D0,  0.08034D0,  0.05707D0,  0.04589D0,  0.03892D0,
55074      &     0.03403D0,  0.02747D0,  0.02151D0,  0.01589D0,  0.01258D0,
55075      &     0.00876D0,  0.00658D0,  0.00515D0,  0.00391D0,  0.00303D0,
55076      &     0.00236D0,  0.00185D0,  0.00144D0,  0.00112D0,  0.00088D0,
55077      &     0.00067D0,  0.00051D0,  0.00039D0,  0.00029D0,  0.00022D0,
55078      &     0.00016D0,  0.00011D0,  0.00008D0,  0.00006D0,  0.00004D0,
55079      &     0.00002D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55080      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55081       DATA (FMRS(1,7,I,15),I=1,49)/
55082      &     1.00765D0,  0.77678D0,  0.59844D0,  0.51350D0,  0.46049D0,
55083      &     0.42306D0,  0.32436D0,  0.24719D0,  0.20981D0,  0.18611D0,
55084      &     0.16874D0,  0.12279D0,  0.08652D0,  0.06923D0,  0.05850D0,
55085      &     0.05102D0,  0.04100D0,  0.03196D0,  0.02347D0,  0.01849D0,
55086      &     0.01279D0,  0.00955D0,  0.00743D0,  0.00560D0,  0.00430D0,
55087      &     0.00334D0,  0.00260D0,  0.00202D0,  0.00157D0,  0.00121D0,
55088      &     0.00093D0,  0.00071D0,  0.00053D0,  0.00040D0,  0.00029D0,
55089      &     0.00021D0,  0.00015D0,  0.00011D0,  0.00007D0,  0.00005D0,
55090      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55091      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55092       DATA (FMRS(1,7,I,16),I=1,49)/
55093      &     1.42250D0,  1.08981D0,  0.83442D0,  0.71339D0,  0.63810D0,
55094      &     0.58505D0,  0.44575D0,  0.33755D0,  0.28542D0,  0.25249D0,
55095      &     0.22841D0,  0.16506D0,  0.11545D0,  0.09197D0,  0.07747D0,
55096      &     0.06738D0,  0.05394D0,  0.04186D0,  0.03057D0,  0.02399D0,
55097      &     0.01648D0,  0.01223D0,  0.00946D0,  0.00708D0,  0.00541D0,
55098      &     0.00417D0,  0.00323D0,  0.00250D0,  0.00193D0,  0.00149D0,
55099      &     0.00113D0,  0.00086D0,  0.00064D0,  0.00048D0,  0.00035D0,
55100      &     0.00026D0,  0.00018D0,  0.00013D0,  0.00009D0,  0.00005D0,
55101      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55102      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55103       DATA (FMRS(1,7,I,17),I=1,49)/
55104      &     1.90329D0,  1.44918D0,  1.10274D0,  0.93938D0,  0.83807D0,
55105      &     0.76686D0,  0.58064D0,  0.43692D0,  0.36805D0,  0.32470D0,
55106      &     0.29309D0,  0.21032D0,  0.14604D0,  0.11582D0,  0.09725D0,
55107      &     0.08437D0,  0.06728D0,  0.05198D0,  0.03776D0,  0.02950D0,
55108      &     0.02012D0,  0.01485D0,  0.01142D0,  0.00850D0,  0.00645D0,
55109      &     0.00494D0,  0.00381D0,  0.00293D0,  0.00225D0,  0.00172D0,
55110      &     0.00131D0,  0.00098D0,  0.00073D0,  0.00054D0,  0.00040D0,
55111      &     0.00029D0,  0.00021D0,  0.00014D0,  0.00010D0,  0.00006D0,
55112      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55113      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55114       DATA (FMRS(1,7,I,18),I=1,49)/
55115      &     2.33137D0,  1.76616D0,  1.33713D0,  1.13567D0,  1.01106D0,
55116      &     0.92363D0,  0.69576D0,  0.52083D0,  0.43738D0,  0.38501D0,
55117      &     0.34690D0,  0.24753D0,  0.17085D0,  0.13502D0,  0.11307D0,
55118      &     0.09789D0,  0.07781D0,  0.05991D0,  0.04333D0,  0.03374D0,
55119      &     0.02288D0,  0.01680D0,  0.01286D0,  0.00952D0,  0.00719D0,
55120      &     0.00549D0,  0.00420D0,  0.00322D0,  0.00246D0,  0.00188D0,
55121      &     0.00142D0,  0.00107D0,  0.00079D0,  0.00059D0,  0.00043D0,
55122      &     0.00031D0,  0.00022D0,  0.00015D0,  0.00010D0,  0.00006D0,
55123      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55124      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55125       DATA (FMRS(1,7,I,19),I=1,49)/
55126      &     2.89798D0,  2.18213D0,  1.64207D0,  1.38971D0,  1.23410D0,
55127      &     1.12518D0,  0.84241D0,  0.62670D0,  0.52435D0,  0.46034D0,
55128      &     0.41389D0,  0.29333D0,  0.20103D0,  0.15819D0,  0.13206D0,
55129      &     0.11405D0,  0.09031D0,  0.06924D0,  0.04982D0,  0.03863D0,
55130      &     0.02602D0,  0.01899D0,  0.01446D0,  0.01064D0,  0.00798D0,
55131      &     0.00606D0,  0.00462D0,  0.00352D0,  0.00268D0,  0.00204D0,
55132      &     0.00153D0,  0.00115D0,  0.00085D0,  0.00062D0,  0.00046D0,
55133      &     0.00034D0,  0.00024D0,  0.00016D0,  0.00010D0,  0.00006D0,
55134      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55135      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55136       DATA (FMRS(1,7,I,20),I=1,49)/
55137      &     3.45978D0,  2.59142D0,  1.93977D0,  1.63658D0,  1.45012D0,
55138      &     1.31987D0,  0.98290D0,  0.72728D0,  0.60655D0,  0.53126D0,
55139      &     0.47676D0,  0.33590D0,  0.22879D0,  0.17936D0,  0.14933D0,
55140      &     0.12869D0,  0.10156D0,  0.07757D0,  0.05556D0,  0.04293D0,
55141      &     0.02875D0,  0.02087D0,  0.01582D0,  0.01157D0,  0.00864D0,
55142      &     0.00653D0,  0.00495D0,  0.00376D0,  0.00285D0,  0.00216D0,
55143      &     0.00162D0,  0.00120D0,  0.00089D0,  0.00065D0,  0.00048D0,
55144      &     0.00035D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
55145      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55146      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55147       DATA (FMRS(1,7,I,21),I=1,49)/
55148      &     3.99390D0,  2.97724D0,  2.21795D0,  1.86604D0,  1.65015D0,
55149      &     1.49961D0,  1.11138D0,  0.81834D0,  0.68051D0,  0.59480D0,
55150      &     0.53289D0,  0.37345D0,  0.25296D0,  0.19764D0,  0.16415D0,
55151      &     0.14119D0,  0.11109D0,  0.08457D0,  0.06032D0,  0.04645D0,
55152      &     0.03094D0,  0.02236D0,  0.01688D0,  0.01228D0,  0.00913D0,
55153      &     0.00687D0,  0.00519D0,  0.00392D0,  0.00296D0,  0.00223D0,
55154      &     0.00167D0,  0.00124D0,  0.00091D0,  0.00067D0,  0.00049D0,
55155      &     0.00036D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
55156      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55157      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55158       DATA (FMRS(1,7,I,22),I=1,49)/
55159      &     4.74104D0,  3.51318D0,  2.60162D0,  2.18119D0,  1.92405D0,
55160      &     1.74515D0,  1.28558D0,  0.94085D0,  0.77956D0,  0.67959D0,
55161      &     0.60758D0,  0.42298D0,  0.28453D0,  0.22138D0,  0.18331D0,
55162      &     0.15728D0,  0.12329D0,  0.09346D0,  0.06632D0,  0.05087D0,
55163      &     0.03366D0,  0.02418D0,  0.01815D0,  0.01313D0,  0.00971D0,
55164      &     0.00726D0,  0.00546D0,  0.00411D0,  0.00309D0,  0.00232D0,
55165      &     0.00172D0,  0.00128D0,  0.00094D0,  0.00068D0,  0.00049D0,
55166      &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
55167      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55168      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55169       DATA (FMRS(1,7,I,23),I=1,49)/
55170      &     5.50879D0,  4.05964D0,  2.98973D0,  2.49849D0,  2.19888D0,
55171      &     1.99086D0,  1.45844D0,  1.06135D0,  0.87646D0,  0.76222D0,
55172      &     0.68014D0,  0.47060D0,  0.31455D0,  0.24380D0,  0.20130D0,
55173      &     0.17233D0,  0.13462D0,  0.10166D0,  0.07179D0,  0.05486D0,
55174      &     0.03607D0,  0.02577D0,  0.01926D0,  0.01386D0,  0.01019D0,
55175      &     0.00758D0,  0.00568D0,  0.00425D0,  0.00318D0,  0.00238D0,
55176      &     0.00176D0,  0.00130D0,  0.00095D0,  0.00069D0,  0.00050D0,
55177      &     0.00037D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
55178      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55179      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55180       DATA (FMRS(1,7,I,24),I=1,49)/
55181      &     6.25919D0,  4.58931D0,  3.36270D0,  2.80183D0,  2.46064D0,
55182      &     2.22421D0,  1.62105D0,  1.17360D0,  0.96617D0,  0.83838D0,
55183      &     0.74677D0,  0.51381D0,  0.34143D0,  0.26369D0,  0.21716D0,
55184      &     0.18553D0,  0.14447D0,  0.10870D0,  0.07643D0,  0.05820D0,
55185      &     0.03805D0,  0.02705D0,  0.02012D0,  0.01441D0,  0.01054D0,
55186      &     0.00781D0,  0.00582D0,  0.00434D0,  0.00324D0,  0.00241D0,
55187      &     0.00178D0,  0.00131D0,  0.00095D0,  0.00069D0,  0.00050D0,
55188      &     0.00037D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
55189      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55190      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55191       DATA (FMRS(1,7,I,25),I=1,49)/
55192      &     7.07966D0,  5.16501D0,  3.76564D0,  3.12838D0,  2.74171D0,
55193      &     2.47426D0,  1.79422D0,  1.29235D0,  1.06071D0,  0.91840D0,
55194      &     0.81663D0,  0.55877D0,  0.36917D0,  0.28412D0,  0.23339D0,
55195      &     0.19900D0,  0.15447D0,  0.11582D0,  0.08108D0,  0.06153D0,
55196      &     0.03999D0,  0.02830D0,  0.02096D0,  0.01493D0,  0.01087D0,
55197      &     0.00803D0,  0.00595D0,  0.00442D0,  0.00329D0,  0.00244D0,
55198      &     0.00180D0,  0.00131D0,  0.00096D0,  0.00069D0,  0.00050D0,
55199      &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
55200      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55201      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55202       DATA (FMRS(1,7,I,26),I=1,49)/
55203      &     7.91829D0,  5.74916D0,  4.17141D0,  3.45573D0,  3.02255D0,
55204      &     2.72346D0,  1.96537D0,  1.40870D0,  1.15285D0,  0.99608D0,
55205      &     0.88421D0,  0.60182D0,  0.39541D0,  0.30330D0,  0.24854D0,
55206      &     0.21150D0,  0.16368D0,  0.12231D0,  0.08527D0,  0.06448D0,
55207      &     0.04169D0,  0.02937D0,  0.02165D0,  0.01535D0,  0.01113D0,
55208      &     0.00818D0,  0.00604D0,  0.00447D0,  0.00331D0,  0.00245D0,
55209      &     0.00180D0,  0.00131D0,  0.00095D0,  0.00068D0,  0.00049D0,
55210      &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
55211      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55212      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55213       DATA (FMRS(1,7,I,27),I=1,49)/
55214      &     8.76657D0,  6.33661D0,  4.57707D0,  3.78184D0,  3.30161D0,
55215      &     2.97059D0,  2.13403D0,  1.52261D0,  1.24269D0,  1.07161D0,
55216      &     0.94977D0,  0.64324D0,  0.42046D0,  0.32150D0,  0.26285D0,
55217      &     0.22328D0,  0.17230D0,  0.12835D0,  0.08912D0,  0.06719D0,
55218      &     0.04322D0,  0.03031D0,  0.02226D0,  0.01571D0,  0.01134D0,
55219      &     0.00830D0,  0.00611D0,  0.00451D0,  0.00333D0,  0.00245D0,
55220      &     0.00180D0,  0.00131D0,  0.00095D0,  0.00068D0,  0.00048D0,
55221      &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
55222      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55223      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55224       DATA (FMRS(1,7,I,28),I=1,49)/
55225      &     9.60252D0,  6.91204D0,  4.97199D0,  4.09813D0,  3.57154D0,
55226      &     3.20914D0,  2.29574D0,  1.63105D0,  1.32784D0,  1.14296D0,
55227      &     1.01154D0,  0.68194D0,  0.44362D0,  0.33823D0,  0.27595D0,
55228      &     0.23401D0,  0.18011D0,  0.13377D0,  0.09255D0,  0.06957D0,
55229      &     0.04454D0,  0.03111D0,  0.02277D0,  0.01600D0,  0.01150D0,
55230      &     0.00839D0,  0.00616D0,  0.00453D0,  0.00333D0,  0.00245D0,
55231      &     0.00179D0,  0.00130D0,  0.00094D0,  0.00067D0,  0.00048D0,
55232      &     0.00035D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
55233      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55234      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55235       DATA (FMRS(1,7,I,29),I=1,49)/
55236      &    10.48807D0,  7.51842D0,  5.38590D0,  4.42859D0,  3.85291D0,
55237      &     3.45734D0,  2.46302D0,  1.74255D0,  1.41507D0,  1.21586D0,
55238      &     1.07451D0,  0.72111D0,  0.46688D0,  0.35494D0,  0.28897D0,
55239      &     0.24464D0,  0.18781D0,  0.13908D0,  0.09587D0,  0.07187D0,
55240      &     0.04579D0,  0.03185D0,  0.02323D0,  0.01626D0,  0.01165D0,
55241      &     0.00847D0,  0.00619D0,  0.00454D0,  0.00333D0,  0.00244D0,
55242      &     0.00178D0,  0.00129D0,  0.00093D0,  0.00066D0,  0.00047D0,
55243      &     0.00035D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
55244      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55245      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55246       DATA (FMRS(1,7,I,30),I=1,49)/
55247      &    11.39334D0,  8.13482D0,  5.80422D0,  4.76138D0,  4.13555D0,
55248      &     3.70617D0,  2.62967D0,  1.85288D0,  1.50103D0,  1.28747D0,
55249      &     1.13621D0,  0.75917D0,  0.48927D0,  0.37093D0,  0.30137D0,
55250      &     0.25473D0,  0.19506D0,  0.14404D0,  0.09894D0,  0.07396D0,
55251      &     0.04691D0,  0.03251D0,  0.02363D0,  0.01647D0,  0.01175D0,
55252      &     0.00851D0,  0.00621D0,  0.00454D0,  0.00332D0,  0.00243D0,
55253      &     0.00176D0,  0.00127D0,  0.00091D0,  0.00065D0,  0.00046D0,
55254      &     0.00034D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
55255      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55256      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55257       DATA (FMRS(1,7,I,31),I=1,49)/
55258      &    12.30020D0,  8.74942D0,  6.21933D0,  5.09070D0,  4.41468D0,
55259      &     3.95152D0,  2.79315D0,  1.96055D0,  1.58465D0,  1.35697D0,
55260      &     1.19598D0,  0.79580D0,  0.51068D0,  0.38615D0,  0.31314D0,
55261      &     0.26427D0,  0.20189D0,  0.14868D0,  0.10179D0,  0.07589D0,
55262      &     0.04793D0,  0.03309D0,  0.02397D0,  0.01665D0,  0.01184D0,
55263      &     0.00855D0,  0.00621D0,  0.00453D0,  0.00330D0,  0.00241D0,
55264      &     0.00174D0,  0.00126D0,  0.00090D0,  0.00064D0,  0.00046D0,
55265      &     0.00034D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
55266      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55267      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55268       DATA (FMRS(1,7,I,32),I=1,49)/
55269      &    13.17835D0,  9.34137D0,  6.61692D0,  5.40505D0,  4.68045D0,
55270      &     4.18467D0,  2.94753D0,  2.06155D0,  1.66276D0,  1.42169D0,
55271      &     1.25150D0,  0.82954D0,  0.53019D0,  0.39993D0,  0.32374D0,
55272      &     0.27283D0,  0.20796D0,  0.15278D0,  0.10427D0,  0.07755D0,
55273      &     0.04878D0,  0.03356D0,  0.02424D0,  0.01677D0,  0.01189D0,
55274      &     0.00856D0,  0.00621D0,  0.00451D0,  0.00328D0,  0.00239D0,
55275      &     0.00173D0,  0.00124D0,  0.00089D0,  0.00063D0,  0.00045D0,
55276      &     0.00033D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
55277      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55278      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55279       DATA (FMRS(1,7,I,33),I=1,49)/
55280      &    14.12059D0,  9.97430D0,  7.04054D0,  5.73929D0,  4.96264D0,
55281      &     4.43195D0,  3.11069D0,  2.16791D0,  1.74484D0,  1.48959D0,
55282      &     1.30967D0,  0.86476D0,  0.55049D0,  0.41422D0,  0.33471D0,
55283      &     0.28168D0,  0.21423D0,  0.15699D0,  0.10682D0,  0.07925D0,
55284      &     0.04965D0,  0.03404D0,  0.02451D0,  0.01690D0,  0.01194D0,
55285      &     0.00857D0,  0.00620D0,  0.00449D0,  0.00326D0,  0.00237D0,
55286      &     0.00171D0,  0.00123D0,  0.00088D0,  0.00062D0,  0.00044D0,
55287      &     0.00032D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
55288      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55289      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55290       DATA (FMRS(1,7,I,34),I=1,49)/
55291      &    15.05309D0, 10.59701D0,  7.45476D0,  6.06488D0,  5.23678D0,
55292      &     4.67164D0,  3.26773D0,  2.26948D0,  1.82284D0,  1.55389D0,
55293      &     1.36460D0,  0.89767D0,  0.56921D0,  0.42730D0,  0.34468D0,
55294      &     0.28967D0,  0.21983D0,  0.16070D0,  0.10902D0,  0.08069D0,
55295      &     0.05036D0,  0.03441D0,  0.02470D0,  0.01698D0,  0.01196D0,
55296      &     0.00856D0,  0.00617D0,  0.00446D0,  0.00323D0,  0.00234D0,
55297      &     0.00168D0,  0.00121D0,  0.00086D0,  0.00061D0,  0.00043D0,
55298      &     0.00032D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
55299      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55300      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55301       DATA (FMRS(1,7,I,35),I=1,49)/
55302      &    15.99294D0, 11.22254D0,  7.86947D0,  6.39022D0,  5.51032D0,
55303      &     4.91055D0,  3.42373D0,  2.37005D0,  1.89992D0,  1.61733D0,
55304      &     1.41872D0,  0.92998D0,  0.58753D0,  0.44006D0,  0.35440D0,
55305      &     0.29744D0,  0.22527D0,  0.16430D0,  0.11114D0,  0.08207D0,
55306      &     0.05103D0,  0.03476D0,  0.02489D0,  0.01705D0,  0.01198D0,
55307      &     0.00855D0,  0.00615D0,  0.00444D0,  0.00321D0,  0.00232D0,
55308      &     0.00166D0,  0.00119D0,  0.00085D0,  0.00060D0,  0.00042D0,
55309      &     0.00031D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
55310      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55311      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55312       DATA (FMRS(1,7,I,36),I=1,49)/
55313      &    16.90825D0, 11.82917D0,  8.26989D0,  6.70353D0,  5.77324D0,
55314      &     5.13985D0,  3.57272D0,  2.46560D0,  1.97292D0,  1.67727D0,
55315      &     1.46976D0,  0.96025D0,  0.60456D0,  0.45187D0,  0.36334D0,
55316      &     0.30458D0,  0.23023D0,  0.16756D0,  0.11304D0,  0.08330D0,
55317      &     0.05162D0,  0.03506D0,  0.02503D0,  0.01710D0,  0.01198D0,
55318      &     0.00853D0,  0.00612D0,  0.00440D0,  0.00318D0,  0.00229D0,
55319      &     0.00164D0,  0.00117D0,  0.00083D0,  0.00059D0,  0.00042D0,
55320      &     0.00031D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
55321      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55322      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55323       DATA (FMRS(1,7,I,37),I=1,49)/
55324      &    17.85379D0, 12.45318D0,  8.67996D0,  7.02354D0,  6.04126D0,
55325      &     5.37323D0,  3.72362D0,  2.56187D0,  2.04622D0,  1.73730D0,
55326      &     1.52078D0,  0.99029D0,  0.62133D0,  0.46343D0,  0.37206D0,
55327      &     0.31151D0,  0.23502D0,  0.17068D0,  0.11483D0,  0.08444D0,
55328      &     0.05214D0,  0.03531D0,  0.02515D0,  0.01713D0,  0.01196D0,
55329      &     0.00850D0,  0.00608D0,  0.00437D0,  0.00315D0,  0.00226D0,
55330      &     0.00162D0,  0.00115D0,  0.00082D0,  0.00058D0,  0.00041D0,
55331      &     0.00030D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
55332      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
55333      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55334       DATA (FMRS(1,7,I,38),I=1,49)/
55335      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55336      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55337      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55338      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55339      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55340      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55341      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55342      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55343      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55344      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55345       DATA (FMRS(1,8,I, 1),I=1,49)/
55346      &     0.88043D0,  0.77333D0,  0.67888D0,  0.62888D0,  0.59555D0,
55347      &     0.57086D0,  0.50019D0,  0.43775D0,  0.40464D0,  0.38254D0,
55348      &     0.36610D0,  0.31885D0,  0.27689D0,  0.25464D0,  0.23989D0,
55349      &     0.22903D0,  0.21364D0,  0.19859D0,  0.18303D0,  0.17273D0,
55350      &     0.15826D0,  0.14656D0,  0.13527D0,  0.12062D0,  0.10522D0,
55351      &     0.08955D0,  0.07420D0,  0.05981D0,  0.04692D0,  0.03554D0,
55352      &     0.02630D0,  0.01878D0,  0.01298D0,  0.00870D0,  0.00554D0,
55353      &     0.00339D0,  0.00198D0,  0.00110D0,  0.00049D0,  0.00026D0,
55354      &     0.00012D0,  0.00002D0,  0.00002D0,  0.00000D0, -0.00001D0,
55355      &    -0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55356       DATA (FMRS(1,8,I, 2),I=1,49)/
55357      &     0.89442D0,  0.78714D0,  0.69235D0,  0.64208D0,  0.60853D0,
55358      &     0.58367D0,  0.51236D0,  0.44919D0,  0.41561D0,  0.39314D0,
55359      &     0.37639D0,  0.32808D0,  0.28485D0,  0.26176D0,  0.24637D0,
55360      &     0.23501D0,  0.21882D0,  0.20291D0,  0.18634D0,  0.17532D0,
55361      &     0.15979D0,  0.14730D0,  0.13538D0,  0.12014D0,  0.10435D0,
55362      &     0.08847D0,  0.07306D0,  0.05873D0,  0.04595D0,  0.03477D0,
55363      &     0.02571D0,  0.01837D0,  0.01273D0,  0.00855D0,  0.00550D0,
55364      &     0.00340D0,  0.00204D0,  0.00117D0,  0.00055D0,  0.00031D0,
55365      &     0.00017D0,  0.00006D0,  0.00005D0,  0.00001D0,  0.00000D0,
55366      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55367       DATA (FMRS(1,8,I, 3),I=1,49)/
55368      &     0.93116D0,  0.82082D0,  0.72315D0,  0.67127D0,  0.63662D0,
55369      &     0.61092D0,  0.53708D0,  0.47148D0,  0.43647D0,  0.41299D0,
55370      &     0.39541D0,  0.34450D0,  0.29850D0,  0.27374D0,  0.25714D0,
55371      &     0.24483D0,  0.22722D0,  0.20981D0,  0.19154D0,  0.17933D0,
55372      &     0.16210D0,  0.14837D0,  0.13550D0,  0.11937D0,  0.10300D0,
55373      &     0.08681D0,  0.07133D0,  0.05711D0,  0.04449D0,  0.03362D0,
55374      &     0.02480D0,  0.01774D0,  0.01234D0,  0.00831D0,  0.00539D0,
55375      &     0.00338D0,  0.00208D0,  0.00122D0,  0.00062D0,  0.00038D0,
55376      &     0.00022D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
55377      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55378       DATA (FMRS(1,8,I, 4),I=1,49)/
55379      &     0.97222D0,  0.85703D0,  0.75505D0,  0.70088D0,  0.66470D0,
55380      &     0.63785D0,  0.56070D0,  0.49207D0,  0.45539D0,  0.43075D0,
55381      &     0.41225D0,  0.35857D0,  0.30984D0,  0.28350D0,  0.26581D0,
55382      &     0.25266D0,  0.23382D0,  0.21514D0,  0.19549D0,  0.18234D0,
55383      &     0.16379D0,  0.14912D0,  0.13552D0,  0.11873D0,  0.10198D0,
55384      &     0.08556D0,  0.07005D0,  0.05591D0,  0.04344D0,  0.03278D0,
55385      &     0.02413D0,  0.01727D0,  0.01201D0,  0.00813D0,  0.00530D0,
55386      &     0.00334D0,  0.00207D0,  0.00123D0,  0.00065D0,  0.00042D0,
55387      &     0.00025D0,  0.00012D0,  0.00009D0,  0.00002D0,  0.00002D0,
55388      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55389       DATA (FMRS(1,8,I, 5),I=1,49)/
55390      &     1.03488D0,  0.91080D0,  0.80113D0,  0.74294D0,  0.70410D0,
55391      &     0.67529D0,  0.59258D0,  0.51904D0,  0.47974D0,  0.45332D0,
55392      &     0.43343D0,  0.37573D0,  0.32325D0,  0.29486D0,  0.27577D0,
55393      &     0.26158D0,  0.24123D0,  0.22104D0,  0.19979D0,  0.18555D0,
55394      &     0.16552D0,  0.14984D0,  0.13548D0,  0.11801D0,  0.10084D0,
55395      &     0.08422D0,  0.06865D0,  0.05459D0,  0.04229D0,  0.03183D0,
55396      &     0.02342D0,  0.01674D0,  0.01163D0,  0.00790D0,  0.00517D0,
55397      &     0.00326D0,  0.00204D0,  0.00126D0,  0.00069D0,  0.00044D0,
55398      &     0.00027D0,  0.00014D0,  0.00010D0,  0.00004D0,  0.00001D0,
55399      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55400       DATA (FMRS(1,8,I, 6),I=1,49)/
55401      &     1.09976D0,  0.96588D0,  0.84779D0,  0.78524D0,  0.74353D0,
55402      &     0.71261D0,  0.62395D0,  0.54523D0,  0.50318D0,  0.47492D0,
55403      &     0.45362D0,  0.39183D0,  0.33563D0,  0.30525D0,  0.28482D0,
55404      &     0.26964D0,  0.24787D0,  0.22628D0,  0.20357D0,  0.18835D0,
55405      &     0.16700D0,  0.15043D0,  0.13540D0,  0.11734D0,  0.09983D0,
55406      &     0.08303D0,  0.06744D0,  0.05346D0,  0.04131D0,  0.03103D0,
55407      &     0.02280D0,  0.01628D0,  0.01131D0,  0.00768D0,  0.00506D0,
55408      &     0.00319D0,  0.00201D0,  0.00126D0,  0.00071D0,  0.00044D0,
55409      &     0.00028D0,  0.00015D0,  0.00010D0,  0.00005D0,  0.00001D0,
55410      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55411       DATA (FMRS(1,8,I, 7),I=1,49)/
55412      &     1.17764D0,  1.03108D0,  0.90223D0,  0.83415D0,  0.78882D0,
55413      &     0.75526D0,  0.65918D0,  0.57411D0,  0.52875D0,  0.49829D0,
55414      &     0.47532D0,  0.40880D0,  0.34842D0,  0.31585D0,  0.29397D0,
55415      &     0.27773D0,  0.25447D0,  0.23144D0,  0.20722D0,  0.19102D0,
55416      &     0.16837D0,  0.15091D0,  0.13525D0,  0.11665D0,  0.09880D0,
55417      &     0.08184D0,  0.06625D0,  0.05236D0,  0.04036D0,  0.03026D0,
55418      &     0.02219D0,  0.01583D0,  0.01099D0,  0.00745D0,  0.00494D0,
55419      &     0.00313D0,  0.00199D0,  0.00124D0,  0.00071D0,  0.00044D0,
55420      &     0.00028D0,  0.00014D0,  0.00011D0,  0.00005D0,  0.00001D0,
55421      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55422       DATA (FMRS(1,8,I, 8),I=1,49)/
55423      &     1.27508D0,  1.11188D0,  0.96899D0,  0.89374D0,  0.84374D0,
55424      &     0.80677D0,  0.70124D0,  0.60814D0,  0.55864D0,  0.52545D0,
55425      &     0.50042D0,  0.42815D0,  0.36279D0,  0.32765D0,  0.30409D0,
55426      &     0.28664D0,  0.26167D0,  0.23701D0,  0.21111D0,  0.19383D0,
55427      &     0.16977D0,  0.15136D0,  0.13503D0,  0.11586D0,  0.09768D0,
55428      &     0.08056D0,  0.06499D0,  0.05119D0,  0.03935D0,  0.02943D0,
55429      &     0.02154D0,  0.01534D0,  0.01065D0,  0.00723D0,  0.00480D0,
55430      &     0.00305D0,  0.00194D0,  0.00121D0,  0.00071D0,  0.00043D0,
55431      &     0.00029D0,  0.00014D0,  0.00011D0,  0.00005D0,  0.00001D0,
55432      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55433       DATA (FMRS(1,8,I, 9),I=1,49)/
55434      &     1.37316D0,  1.19249D0,  1.03498D0,  0.95232D0,  0.89751D0,
55435      &     0.85705D0,  0.74185D0,  0.64064D0,  0.58699D0,  0.55108D0,
55436      &     0.52402D0,  0.44610D0,  0.37594D0,  0.33836D0,  0.31323D0,
55437      &     0.29464D0,  0.26809D0,  0.24193D0,  0.21452D0,  0.19627D0,
55438      &     0.17094D0,  0.15171D0,  0.13480D0,  0.11515D0,  0.09667D0,
55439      &     0.07946D0,  0.06388D0,  0.05018D0,  0.03847D0,  0.02871D0,
55440      &     0.02099D0,  0.01493D0,  0.01036D0,  0.00705D0,  0.00466D0,
55441      &     0.00297D0,  0.00189D0,  0.00119D0,  0.00071D0,  0.00043D0,
55442      &     0.00029D0,  0.00015D0,  0.00010D0,  0.00005D0,  0.00002D0,
55443      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55444       DATA (FMRS(1,8,I,10),I=1,49)/
55445      &     1.48232D0,  1.28141D0,  1.10710D0,  1.01596D0,  0.95567D0,
55446      &     0.91125D0,  0.78516D0,  0.67489D0,  0.61664D0,  0.57774D0,
55447      &     0.54846D0,  0.46445D0,  0.38919D0,  0.34906D0,  0.32230D0,
55448      &     0.30254D0,  0.27439D0,  0.24670D0,  0.21778D0,  0.19857D0,
55449      &     0.17201D0,  0.15198D0,  0.13451D0,  0.11441D0,  0.09567D0,
55450      &     0.07837D0,  0.06280D0,  0.04920D0,  0.03762D0,  0.02802D0,
55451      &     0.02045D0,  0.01454D0,  0.01009D0,  0.00685D0,  0.00453D0,
55452      &     0.00289D0,  0.00185D0,  0.00117D0,  0.00069D0,  0.00044D0,
55453      &     0.00029D0,  0.00015D0,  0.00011D0,  0.00004D0,  0.00002D0,
55454      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55455       DATA (FMRS(1,8,I,11),I=1,49)/
55456      &     1.57825D0,  1.35904D0,  1.16962D0,  1.07091D0,  1.00575D0,
55457      &     0.95780D0,  0.82207D0,  0.70384D0,  0.64159D0,  0.60009D0,
55458      &     0.56890D0,  0.47964D0,  0.40007D0,  0.35779D0,  0.32966D0,
55459      &     0.30893D0,  0.27945D0,  0.25052D0,  0.22036D0,  0.20038D0,
55460      &     0.17283D0,  0.15216D0,  0.13426D0,  0.11380D0,  0.09487D0,
55461      &     0.07750D0,  0.06195D0,  0.04843D0,  0.03696D0,  0.02748D0,
55462      &     0.02002D0,  0.01423D0,  0.00988D0,  0.00669D0,  0.00443D0,
55463      &     0.00283D0,  0.00181D0,  0.00116D0,  0.00068D0,  0.00044D0,
55464      &     0.00028D0,  0.00016D0,  0.00011D0,  0.00004D0,  0.00001D0,
55465      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55466       DATA (FMRS(1,8,I,12),I=1,49)/
55467      &     1.81391D0,  1.54794D0,  1.32027D0,  1.20251D0,  1.12515D0,
55468      &     1.06843D0,  0.90882D0,  0.77111D0,  0.69913D0,  0.65138D0,
55469      &     0.61560D0,  0.51392D0,  0.42424D0,  0.37702D0,  0.34578D0,
55470      &     0.32285D0,  0.29039D0,  0.25868D0,  0.22580D0,  0.20412D0,
55471      &     0.17445D0,  0.15244D0,  0.13361D0,  0.11242D0,  0.09312D0,
55472      &     0.07561D0,  0.06012D0,  0.04679D0,  0.03556D0,  0.02636D0,
55473      &     0.01913D0,  0.01356D0,  0.00940D0,  0.00637D0,  0.00422D0,
55474      &     0.00270D0,  0.00172D0,  0.00112D0,  0.00066D0,  0.00042D0,
55475      &     0.00027D0,  0.00016D0,  0.00011D0,  0.00004D0,  0.00001D0,
55476      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55477       DATA (FMRS(1,8,I,13),I=1,49)/
55478      &     2.05224D0,  1.73683D0,  1.46916D0,  1.33169D0,  1.24177D0,
55479      &     1.17604D0,  0.99216D0,  0.83488D0,  0.75325D0,  0.69933D0,
55480      &     0.65905D0,  0.54532D0,  0.44603D0,  0.39419D0,  0.36006D0,
55481      &     0.33511D0,  0.29992D0,  0.26571D0,  0.23041D0,  0.20724D0,
55482      &     0.17571D0,  0.15255D0,  0.13296D0,  0.11116D0,  0.09157D0,
55483      &     0.07397D0,  0.05855D0,  0.04538D0,  0.03436D0,  0.02540D0,
55484      &     0.01839D0,  0.01299D0,  0.00900D0,  0.00610D0,  0.00403D0,
55485      &     0.00259D0,  0.00165D0,  0.00107D0,  0.00064D0,  0.00040D0,
55486      &     0.00027D0,  0.00015D0,  0.00011D0,  0.00004D0,  0.00001D0,
55487      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55488       DATA (FMRS(1,8,I,14),I=1,49)/
55489      &     2.36037D0,  1.97834D0,  1.65740D0,  1.49390D0,  1.38749D0,
55490      &     1.31001D0,  1.09465D0,  0.91231D0,  0.81846D0,  0.75678D0,
55491      &     0.71089D0,  0.58224D0,  0.47125D0,  0.41385D0,  0.37630D0,
55492      &     0.34896D0,  0.31058D0,  0.27348D0,  0.23541D0,  0.21054D0,
55493      &     0.17694D0,  0.15252D0,  0.13212D0,  0.10968D0,  0.08980D0,
55494      &     0.07213D0,  0.05680D0,  0.04381D0,  0.03304D0,  0.02434D0,
55495      &     0.01758D0,  0.01241D0,  0.00857D0,  0.00582D0,  0.00382D0,
55496      &     0.00247D0,  0.00159D0,  0.00103D0,  0.00060D0,  0.00038D0,
55497      &     0.00026D0,  0.00014D0,  0.00011D0,  0.00004D0,  0.00001D0,
55498      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55499       DATA (FMRS(1,8,I,15),I=1,49)/
55500      &     2.73224D0,  2.26638D0,  1.87922D0,  1.68367D0,  1.55710D0,
55501      &     1.46530D0,  1.21194D0,  0.99975D0,  0.89148D0,  0.82073D0,
55502      &     0.76831D0,  0.62250D0,  0.49828D0,  0.43470D0,  0.39338D0,
55503      &     0.36342D0,  0.32158D0,  0.28138D0,  0.24036D0,  0.21374D0,
55504      &     0.17800D0,  0.15230D0,  0.13108D0,  0.10804D0,  0.08789D0,
55505      &     0.07017D0,  0.05499D0,  0.04222D0,  0.03170D0,  0.02325D0,
55506      &     0.01673D0,  0.01178D0,  0.00810D0,  0.00551D0,  0.00361D0,
55507      &     0.00232D0,  0.00150D0,  0.00098D0,  0.00058D0,  0.00036D0,
55508      &     0.00025D0,  0.00014D0,  0.00010D0,  0.00004D0,  0.00001D0,
55509      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55510       DATA (FMRS(1,8,I,16),I=1,49)/
55511      &     3.11511D0,  2.55975D0,  2.10267D0,  1.87361D0,  1.72607D0,
55512      &     1.61945D0,  1.32704D0,  1.08455D0,  0.96180D0,  0.88200D0,
55513      &     0.82308D0,  0.66038D0,  0.52333D0,  0.45384D0,  0.40893D0,
55514      &     0.37652D0,  0.33144D0,  0.28836D0,  0.24465D0,  0.21643D0,
55515      &     0.17877D0,  0.15196D0,  0.13002D0,  0.10649D0,  0.08613D0,
55516      &     0.06841D0,  0.05335D0,  0.04078D0,  0.03051D0,  0.02230D0,
55517      &     0.01601D0,  0.01123D0,  0.00772D0,  0.00522D0,  0.00344D0,
55518      &     0.00221D0,  0.00143D0,  0.00094D0,  0.00056D0,  0.00035D0,
55519      &     0.00023D0,  0.00014D0,  0.00009D0,  0.00004D0,  0.00001D0,
55520      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55521       DATA (FMRS(1,8,I,17),I=1,49)/
55522      &     3.54920D0,  2.88904D0,  2.35096D0,  2.08340D0,  1.91191D0,
55523      &     1.78843D0,  1.45191D0,  1.17555D0,  1.03678D0,  0.94701D0,
55524      &     0.88099D0,  0.69993D0,  0.54914D0,  0.47339D0,  0.42472D0,
55525      &     0.38973D0,  0.34130D0,  0.29525D0,  0.24881D0,  0.21897D0,
55526      &     0.17941D0,  0.15149D0,  0.12887D0,  0.10488D0,  0.08433D0,
55527      &     0.06664D0,  0.05172D0,  0.03936D0,  0.02933D0,  0.02138D0,
55528      &     0.01531D0,  0.01070D0,  0.00735D0,  0.00494D0,  0.00327D0,
55529      &     0.00210D0,  0.00135D0,  0.00089D0,  0.00053D0,  0.00034D0,
55530      &     0.00022D0,  0.00013D0,  0.00009D0,  0.00004D0,  0.00001D0,
55531      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55532       DATA (FMRS(1,8,I,18),I=1,49)/
55533      &     3.94722D0,  3.18825D0,  2.57451D0,  2.27128D0,  2.07769D0,
55534      &     1.93872D0,  1.56191D0,  1.25495D0,  1.10181D0,  1.00316D0,
55535      &     0.93081D0,  0.73357D0,  0.57081D0,  0.48966D0,  0.43777D0,
55536      &     0.40060D0,  0.34934D0,  0.30080D0,  0.25209D0,  0.22090D0,
55537      &     0.17980D0,  0.15100D0,  0.12785D0,  0.10349D0,  0.08283D0,
55538      &     0.06518D0,  0.05037D0,  0.03822D0,  0.02839D0,  0.02063D0,
55539      &     0.01472D0,  0.01026D0,  0.00705D0,  0.00475D0,  0.00313D0,
55540      &     0.00200D0,  0.00129D0,  0.00084D0,  0.00049D0,  0.00033D0,
55541      &     0.00020D0,  0.00013D0,  0.00009D0,  0.00003D0,  0.00001D0,
55542      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55543       DATA (FMRS(1,8,I,19),I=1,49)/
55544      &     4.47623D0,  3.58243D0,  2.86642D0,  2.51532D0,  2.29224D0,
55545      &     2.13264D0,  1.70256D0,  1.35552D0,  1.18371D0,  1.07357D0,
55546      &     0.99309D0,  0.77516D0,  0.59726D0,  0.50937D0,  0.45348D0,
55547      &     0.41360D0,  0.35886D0,  0.30730D0,  0.25582D0,  0.22304D0,
55548      &     0.18010D0,  0.15028D0,  0.12653D0,  0.10177D0,  0.08099D0,
55549      &     0.06341D0,  0.04879D0,  0.03686D0,  0.02728D0,  0.01973D0,
55550      &     0.01404D0,  0.00977D0,  0.00668D0,  0.00449D0,  0.00295D0,
55551      &     0.00189D0,  0.00122D0,  0.00079D0,  0.00046D0,  0.00031D0,
55552      &     0.00019D0,  0.00011D0,  0.00008D0,  0.00003D0,  0.00001D0,
55553      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55554       DATA (FMRS(1,8,I,20),I=1,49)/
55555      &     4.99213D0,  3.96349D0,  3.14614D0,  2.74797D0,  2.49601D0,
55556      &     2.31631D0,  1.83458D0,  1.44905D0,  1.25946D0,  1.13844D0,
55557      &     1.05027D0,  0.81294D0,  0.62102D0,  0.52694D0,  0.46740D0,
55558      &     0.42508D0,  0.36719D0,  0.31292D0,  0.25900D0,  0.22482D0,
55559      &     0.18028D0,  0.14958D0,  0.12531D0,  0.10024D0,  0.07938D0,
55560      &     0.06186D0,  0.04742D0,  0.03568D0,  0.02633D0,  0.01896D0,
55561      &     0.01347D0,  0.00937D0,  0.00636D0,  0.00427D0,  0.00280D0,
55562      &     0.00180D0,  0.00116D0,  0.00076D0,  0.00045D0,  0.00029D0,
55563      &     0.00019D0,  0.00009D0,  0.00007D0,  0.00003D0,  0.00001D0,
55564      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55565       DATA (FMRS(1,8,I,21),I=1,49)/
55566      &     5.49949D0,  4.33534D0,  3.41695D0,  2.97216D0,  2.69173D0,
55567      &     2.49225D0,  1.96002D0,  1.53717D0,  1.33047D0,  1.19901D0,
55568      &     1.10350D0,  0.84773D0,  0.64263D0,  0.54279D0,  0.47988D0,
55569      &     0.43530D0,  0.37453D0,  0.31778D0,  0.26166D0,  0.22622D0,
55570      &     0.18027D0,  0.14882D0,  0.12412D0,  0.09878D0,  0.07788D0,
55571      &     0.06045D0,  0.04618D0,  0.03463D0,  0.02546D0,  0.01831D0,
55572      &     0.01296D0,  0.00899D0,  0.00611D0,  0.00409D0,  0.00268D0,
55573      &     0.00172D0,  0.00111D0,  0.00073D0,  0.00045D0,  0.00028D0,
55574      &     0.00018D0,  0.00010D0,  0.00007D0,  0.00003D0,  0.00001D0,
55575      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55576       DATA (FMRS(1,8,I,22),I=1,49)/
55577      &     6.19994D0,  4.84455D0,  3.78480D0,  3.27524D0,  2.95541D0,
55578      &     2.72867D0,  2.12718D0,  1.65361D0,  1.42381D0,  1.27834D0,
55579      &     1.17300D0,  0.89272D0,  0.67027D0,  0.56291D0,  0.49563D0,
55580      &     0.44814D0,  0.38367D0,  0.32378D0,  0.26487D0,  0.22786D0,
55581      &     0.18016D0,  0.14778D0,  0.12256D0,  0.09693D0,  0.07601D0,
55582      &     0.05870D0,  0.04463D0,  0.03333D0,  0.02440D0,  0.01750D0,
55583      &     0.01234D0,  0.00854D0,  0.00580D0,  0.00388D0,  0.00253D0,
55584      &     0.00162D0,  0.00104D0,  0.00069D0,  0.00042D0,  0.00026D0,
55585      &     0.00018D0,  0.00010D0,  0.00006D0,  0.00003D0,  0.00001D0,
55586      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55587       DATA (FMRS(1,8,I,23),I=1,49)/
55588      &     6.91850D0,  5.36248D0,  4.15576D0,  3.57933D0,  3.21903D0,
55589      &     2.96436D0,  2.29236D0,  1.76765D0,  1.51472D0,  1.35530D0,
55590      &     1.24020D0,  0.93576D0,  0.69640D0,  0.58179D0,  0.51031D0,
55591      &     0.46004D0,  0.39207D0,  0.32922D0,  0.26771D0,  0.22925D0,
55592      &     0.17994D0,  0.14672D0,  0.12105D0,  0.09521D0,  0.07427D0,
55593      &     0.05708D0,  0.04320D0,  0.03213D0,  0.02345D0,  0.01676D0,
55594      &     0.01179D0,  0.00813D0,  0.00551D0,  0.00368D0,  0.00240D0,
55595      &     0.00152D0,  0.00099D0,  0.00064D0,  0.00039D0,  0.00024D0,
55596      &     0.00017D0,  0.00009D0,  0.00006D0,  0.00003D0,  0.00001D0,
55597      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55598       DATA (FMRS(1,8,I,24),I=1,49)/
55599      &     7.63491D0,  5.87479D0,  4.51976D0,  3.87632D0,  3.47562D0,
55600      &     3.19317D0,  2.45140D0,  1.87649D0,  1.60104D0,  1.42808D0,
55601      &     1.30355D0,  0.97589D0,  0.72045D0,  0.59900D0,  0.52360D0,
55602      &     0.47074D0,  0.39952D0,  0.33394D0,  0.27005D0,  0.23029D0,
55603      &     0.17956D0,  0.14561D0,  0.11956D0,  0.09355D0,  0.07262D0,
55604      &     0.05557D0,  0.04190D0,  0.03105D0,  0.02258D0,  0.01609D0,
55605      &     0.01128D0,  0.00777D0,  0.00525D0,  0.00350D0,  0.00227D0,
55606      &     0.00145D0,  0.00095D0,  0.00060D0,  0.00036D0,  0.00023D0,
55607      &     0.00015D0,  0.00008D0,  0.00006D0,  0.00003D0,  0.00001D0,
55608      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55609       DATA (FMRS(1,8,I,25),I=1,49)/
55610      &     8.40875D0,  6.42416D0,  4.90727D0,  4.19114D0,  3.74679D0,
55611      &     3.43441D0,  2.61784D0,  1.98954D0,  1.69029D0,  1.50308D0,
55612      &     1.36865D0,  1.01677D0,  0.74472D0,  0.61626D0,  0.53686D0,
55613      &     0.48138D0,  0.40687D0,  0.33856D0,  0.27230D0,  0.23124D0,
55614      &     0.17912D0,  0.14448D0,  0.11807D0,  0.09190D0,  0.07100D0,
55615      &     0.05410D0,  0.04063D0,  0.03001D0,  0.02174D0,  0.01545D0,
55616      &     0.01080D0,  0.00742D0,  0.00500D0,  0.00332D0,  0.00215D0,
55617      &     0.00138D0,  0.00091D0,  0.00056D0,  0.00034D0,  0.00022D0,
55618      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
55619      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55620       DATA (FMRS(1,8,I,26),I=1,49)/
55621      &     9.20959D0,  6.98865D0,  5.30257D0,  4.51092D0,  4.02140D0,
55622      &     3.67813D0,  2.78472D0,  2.10201D0,  1.77866D0,  1.57708D0,
55623      &     1.43269D0,  1.05659D0,  0.76808D0,  0.63273D0,  0.54942D0,
55624      &     0.49139D0,  0.41371D0,  0.34277D0,  0.27426D0,  0.23197D0,
55625      &     0.17855D0,  0.14327D0,  0.11656D0,  0.09025D0,  0.06944D0,
55626      &     0.05268D0,  0.03941D0,  0.02899D0,  0.02094D0,  0.01485D0,
55627      &     0.01035D0,  0.00708D0,  0.00476D0,  0.00316D0,  0.00205D0,
55628      &     0.00131D0,  0.00085D0,  0.00054D0,  0.00031D0,  0.00021D0,
55629      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
55630      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55631       DATA (FMRS(1,8,I,27),I=1,49)/
55632      &    10.01660D0,  7.55374D0,  5.69567D0,  4.82767D0,  4.29265D0,
55633      &     3.91834D0,  2.94808D0,  2.21134D0,  1.86419D0,  1.64848D0,
55634      &     1.49433D0,  1.09459D0,  0.79015D0,  0.64820D0,  0.56116D0,
55635      &     0.50070D0,  0.42001D0,  0.34660D0,  0.27598D0,  0.23256D0,
55636      &     0.17794D0,  0.14210D0,  0.11511D0,  0.08871D0,  0.06797D0,
55637      &     0.05137D0,  0.03829D0,  0.02806D0,  0.02022D0,  0.01430D0,
55638      &     0.00994D0,  0.00679D0,  0.00455D0,  0.00301D0,  0.00196D0,
55639      &     0.00124D0,  0.00081D0,  0.00052D0,  0.00030D0,  0.00020D0,
55640      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
55641      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55642       DATA (FMRS(1,8,I,28),I=1,49)/
55643      &    10.81622D0,  8.11020D0,  6.08037D0,  5.13653D0,  4.55643D0,
55644      &     4.15146D0,  3.10560D0,  2.31605D0,  1.94577D0,  1.71637D0,
55645      &     1.55278D0,  1.13032D0,  0.81070D0,  0.66250D0,  0.57195D0,
55646      &     0.50921D0,  0.42571D0,  0.35000D0,  0.27744D0,  0.23299D0,
55647      &     0.17730D0,  0.14094D0,  0.11373D0,  0.08726D0,  0.06658D0,
55648      &     0.05015D0,  0.03725D0,  0.02723D0,  0.01957D0,  0.01380D0,
55649      &     0.00957D0,  0.00653D0,  0.00437D0,  0.00288D0,  0.00188D0,
55650      &     0.00119D0,  0.00077D0,  0.00050D0,  0.00029D0,  0.00019D0,
55651      &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00001D0,
55652      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55653       DATA (FMRS(1,8,I,29),I=1,49)/
55654      &    11.66230D0,  8.69558D0,  6.48269D0,  5.45841D0,  4.83067D0,
55655      &     4.39335D0,  3.26805D0,  2.42336D0,  2.02906D0,  1.78549D0,
55656      &     1.61215D0,  1.16634D0,  0.83123D0,  0.67669D0,  0.58260D0,
55657      &     0.51757D0,  0.43126D0,  0.35327D0,  0.27879D0,  0.23332D0,
55658      &     0.17659D0,  0.13975D0,  0.11233D0,  0.08581D0,  0.06521D0,
55659      &     0.04895D0,  0.03623D0,  0.02642D0,  0.01893D0,  0.01332D0,
55660      &     0.00922D0,  0.00628D0,  0.00420D0,  0.00276D0,  0.00179D0,
55661      &     0.00113D0,  0.00073D0,  0.00048D0,  0.00028D0,  0.00018D0,
55662      &     0.00012D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00001D0,
55663      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55664       DATA (FMRS(1,8,I,30),I=1,49)/
55665      &    12.53147D0,  9.29349D0,  6.89124D0,  5.78416D0,  5.10752D0,
55666      &     4.63707D0,  3.43073D0,  2.53015D0,  2.11162D0,  1.85381D0,
55667      &     1.67070D0,  1.20157D0,  0.85112D0,  0.69035D0,  0.59278D0,
55668      &     0.52552D0,  0.43648D0,  0.35628D0,  0.27996D0,  0.23352D0,
55669      &     0.17581D0,  0.13853D0,  0.11093D0,  0.08439D0,  0.06389D0,
55670      &     0.04778D0,  0.03525D0,  0.02563D0,  0.01832D0,  0.01286D0,
55671      &     0.00888D0,  0.00603D0,  0.00403D0,  0.00265D0,  0.00171D0,
55672      &     0.00109D0,  0.00070D0,  0.00046D0,  0.00026D0,  0.00017D0,
55673      &     0.00011D0,  0.00006D0,  0.00004D0,  0.00001D0,  0.00000D0,
55674      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55675       DATA (FMRS(1,8,I,31),I=1,49)/
55676      &    13.39986D0,  9.88770D0,  7.29509D0,  6.10513D0,  5.37969D0,
55677      &     4.87627D0,  3.58951D0,  2.63377D0,  2.19145D0,  1.91971D0,
55678      &     1.72706D0,  1.23525D0,  0.86997D0,  0.70322D0,  0.60234D0,
55679      &     0.53296D0,  0.44131D0,  0.35903D0,  0.28099D0,  0.23364D0,
55680      &     0.17503D0,  0.13736D0,  0.10960D0,  0.08305D0,  0.06264D0,
55681      &     0.04669D0,  0.03435D0,  0.02491D0,  0.01775D0,  0.01244D0,
55682      &     0.00857D0,  0.00581D0,  0.00387D0,  0.00255D0,  0.00164D0,
55683      &     0.00105D0,  0.00067D0,  0.00044D0,  0.00025D0,  0.00016D0,
55684      &     0.00011D0,  0.00006D0,  0.00004D0,  0.00002D0,  0.00000D0,
55685      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55686       DATA (FMRS(1,8,I,32),I=1,49)/
55687      &    14.24690D0, 10.46430D0,  7.68491D0,  6.41400D0,  5.64102D0,
55688      &     5.10551D0,  3.74084D0,  2.73196D0,  2.26682D0,  1.98174D0,
55689      &     1.77998D0,  1.26662D0,  0.88736D0,  0.71501D0,  0.61103D0,
55690      &     0.53966D0,  0.44562D0,  0.36142D0,  0.28180D0,  0.23363D0,
55691      &     0.17423D0,  0.13620D0,  0.10832D0,  0.08177D0,  0.06147D0,
55692      &     0.04567D0,  0.03352D0,  0.02425D0,  0.01724D0,  0.01204D0,
55693      &     0.00828D0,  0.00559D0,  0.00373D0,  0.00245D0,  0.00158D0,
55694      &     0.00099D0,  0.00065D0,  0.00042D0,  0.00024D0,  0.00015D0,
55695      &     0.00010D0,  0.00006D0,  0.00004D0,  0.00002D0,  0.00000D0,
55696      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55697       DATA (FMRS(1,8,I,33),I=1,49)/
55698      &    15.14936D0, 11.07583D0,  8.09647D0,  6.73922D0,  5.91564D0,
55699      &     5.34608D0,  3.89891D0,  2.83403D0,  2.34496D0,  2.04593D0,
55700      &     1.83464D0,  1.29886D0,  0.90513D0,  0.72701D0,  0.61986D0,
55701      &     0.54647D0,  0.44998D0,  0.36383D0,  0.28262D0,  0.23362D0,
55702      &     0.17343D0,  0.13505D0,  0.10704D0,  0.08050D0,  0.06032D0,
55703      &     0.04468D0,  0.03270D0,  0.02360D0,  0.01675D0,  0.01165D0,
55704      &     0.00800D0,  0.00538D0,  0.00360D0,  0.00236D0,  0.00153D0,
55705      &     0.00094D0,  0.00062D0,  0.00040D0,  0.00024D0,  0.00014D0,
55706      &     0.00010D0,  0.00005D0,  0.00004D0,  0.00002D0,  0.00000D0,
55707      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55708       DATA (FMRS(1,8,I,34),I=1,49)/
55709      &    16.05264D0, 11.68476D0,  8.50413D0,  7.06033D0,  6.18619D0,
55710      &     5.58264D0,  4.05344D0,  2.93321D0,  2.42057D0,  2.10785D0,
55711      &     1.88726D0,  1.32960D0,  0.92187D0,  0.73821D0,  0.62802D0,
55712      &     0.55270D0,  0.45389D0,  0.36590D0,  0.28320D0,  0.23345D0,
55713      &     0.17251D0,  0.13385D0,  0.10575D0,  0.07924D0,  0.05918D0,
55714      &     0.04371D0,  0.03189D0,  0.02297D0,  0.01625D0,  0.01129D0,
55715      &     0.00773D0,  0.00520D0,  0.00346D0,  0.00227D0,  0.00146D0,
55716      &     0.00090D0,  0.00059D0,  0.00038D0,  0.00022D0,  0.00014D0,
55717      &     0.00009D0,  0.00005D0,  0.00004D0,  0.00001D0,  0.00000D0,
55718      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55719       DATA (FMRS(1,8,I,35),I=1,49)/
55720      &    16.95831D0, 12.29275D0,  8.90942D0,  7.37879D0,  6.45402D0,
55721      &     5.81651D0,  4.20556D0,  3.03041D0,  2.49449D0,  2.16827D0,
55722      &     1.93852D0,  1.35941D0,  0.93802D0,  0.74899D0,  0.63586D0,
55723      &     0.55868D0,  0.45763D0,  0.36787D0,  0.28375D0,  0.23328D0,
55724      &     0.17165D0,  0.13272D0,  0.10453D0,  0.07807D0,  0.05811D0,
55725      &     0.04281D0,  0.03114D0,  0.02238D0,  0.01579D0,  0.01096D0,
55726      &     0.00748D0,  0.00503D0,  0.00334D0,  0.00218D0,  0.00141D0,
55727      &     0.00087D0,  0.00056D0,  0.00036D0,  0.00021D0,  0.00013D0,
55728      &     0.00009D0,  0.00005D0,  0.00004D0,  0.00001D0,  0.00000D0,
55729      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55730       DATA (FMRS(1,8,I,36),I=1,49)/
55731      &    17.84218D0, 12.88352D0,  9.30151D0,  7.68607D0,  6.71197D0,
55732      &     6.04141D0,  4.35117D0,  3.12299D0,  2.56467D0,  2.22550D0,
55733      &     1.98697D0,  1.38741D0,  0.95307D0,  0.75895D0,  0.64306D0,
55734      &     0.56414D0,  0.46100D0,  0.36960D0,  0.28418D0,  0.23305D0,
55735      &     0.17079D0,  0.13162D0,  0.10337D0,  0.07695D0,  0.05711D0,
55736      &     0.04196D0,  0.03045D0,  0.02184D0,  0.01537D0,  0.01065D0,
55737      &     0.00725D0,  0.00488D0,  0.00323D0,  0.00211D0,  0.00135D0,
55738      &     0.00084D0,  0.00054D0,  0.00035D0,  0.00020D0,  0.00012D0,
55739      &     0.00009D0,  0.00005D0,  0.00003D0,  0.00001D0,  0.00000D0,
55740      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55741       DATA (FMRS(1,8,I,37),I=1,49)/
55742      &    18.75837D0, 13.49331D0,  9.70449D0,  8.00107D0,  6.97591D0,
55743      &     6.27121D0,  4.49926D0,  3.21668D0,  2.63548D0,  2.28312D0,
55744      &     2.03566D0,  1.41534D0,  0.96795D0,  0.76874D0,  0.65009D0,
55745      &     0.56943D0,  0.46423D0,  0.37122D0,  0.28450D0,  0.23274D0,
55746      &     0.16989D0,  0.13050D0,  0.10219D0,  0.07583D0,  0.05612D0,
55747      &     0.04112D0,  0.02978D0,  0.02129D0,  0.01496D0,  0.01035D0,
55748      &     0.00703D0,  0.00473D0,  0.00312D0,  0.00203D0,  0.00130D0,
55749      &     0.00081D0,  0.00052D0,  0.00034D0,  0.00019D0,  0.00012D0,
55750      &     0.00008D0,  0.00005D0,  0.00003D0,  0.00001D0,  0.00000D0,
55751      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55752       DATA (FMRS(1,8,I,38),I=1,49)/
55753      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55754      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55755      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55756      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55757      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55758      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55759      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55760      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55761      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55762      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55763       DATA (FMRS(2,1,I, 1),I=1,49)/
55764      &     0.01616D0,  0.01968D0,  0.02397D0,  0.02690D0,  0.02921D0,
55765      &     0.03113D0,  0.03797D0,  0.04639D0,  0.05222D0,  0.05685D0,
55766      &     0.06076D0,  0.07508D0,  0.09409D0,  0.10852D0,  0.12095D0,
55767      &     0.13220D0,  0.15265D0,  0.18041D0,  0.22265D0,  0.26180D0,
55768      &     0.33338D0,  0.39710D0,  0.45318D0,  0.51262D0,  0.56037D0,
55769      &     0.59685D0,  0.62256D0,  0.63820D0,  0.64458D0,  0.64218D0,
55770      &     0.63256D0,  0.61605D0,  0.59381D0,  0.56668D0,  0.53544D0,
55771      &     0.50113D0,  0.46441D0,  0.42608D0,  0.38703D0,  0.34764D0,
55772      &     0.30873D0,  0.27101D0,  0.23457D0,  0.16829D0,  0.11224D0,
55773      &     0.06802D0,  0.03588D0,  0.00449D0,  0.00000D0/
55774       DATA (FMRS(2,1,I, 2),I=1,49)/
55775      &     0.01632D0,  0.01989D0,  0.02423D0,  0.02721D0,  0.02954D0,
55776      &     0.03149D0,  0.03843D0,  0.04698D0,  0.05290D0,  0.05761D0,
55777      &     0.06159D0,  0.07621D0,  0.09566D0,  0.11046D0,  0.12320D0,
55778      &     0.13473D0,  0.15566D0,  0.18401D0,  0.22694D0,  0.26649D0,
55779      &     0.33826D0,  0.40154D0,  0.45671D0,  0.51456D0,  0.56041D0,
55780      &     0.59481D0,  0.61838D0,  0.63191D0,  0.63628D0,  0.63211D0,
55781      &     0.62085D0,  0.60298D0,  0.57964D0,  0.55165D0,  0.51988D0,
55782      &     0.48526D0,  0.44851D0,  0.41042D0,  0.37182D0,  0.33308D0,
55783      &     0.29500D0,  0.25823D0,  0.22287D0,  0.15893D0,  0.10532D0,
55784      &     0.06336D0,  0.03315D0,  0.00405D0,  0.00000D0/
55785       DATA (FMRS(2,1,I, 3),I=1,49)/
55786      &     0.01657D0,  0.02020D0,  0.02463D0,  0.02767D0,  0.03005D0,
55787      &     0.03204D0,  0.03912D0,  0.04786D0,  0.05393D0,  0.05876D0,
55788      &     0.06285D0,  0.07791D0,  0.09803D0,  0.11338D0,  0.12658D0,
55789      &     0.13853D0,  0.16018D0,  0.18937D0,  0.23326D0,  0.27335D0,
55790      &     0.34527D0,  0.40778D0,  0.46152D0,  0.51696D0,  0.55995D0,
55791      &     0.59126D0,  0.61170D0,  0.62221D0,  0.62369D0,  0.61697D0,
55792      &     0.60343D0,  0.58371D0,  0.55889D0,  0.52978D0,  0.49735D0,
55793      &     0.46237D0,  0.42568D0,  0.38804D0,  0.35014D0,  0.31246D0,
55794      &     0.27562D0,  0.24027D0,  0.20650D0,  0.14595D0,  0.09580D0,
55795      &     0.05701D0,  0.02946D0,  0.00347D0,  0.00000D0/
55796       DATA (FMRS(2,1,I, 4),I=1,49)/
55797      &     0.01676D0,  0.02044D0,  0.02493D0,  0.02801D0,  0.03042D0,
55798      &     0.03244D0,  0.03964D0,  0.04852D0,  0.05470D0,  0.05962D0,
55799      &     0.06379D0,  0.07918D0,  0.09980D0,  0.11554D0,  0.12909D0,
55800      &     0.14134D0,  0.16349D0,  0.19329D0,  0.23784D0,  0.27828D0,
55801      &     0.35023D0,  0.41207D0,  0.46471D0,  0.51833D0,  0.55923D0,
55802      &     0.58830D0,  0.60648D0,  0.61486D0,  0.61433D0,  0.60584D0,
55803      &     0.59072D0,  0.56980D0,  0.54398D0,  0.51418D0,  0.48131D0,
55804      &     0.44619D0,  0.40966D0,  0.37236D0,  0.33505D0,  0.29814D0,
55805      &     0.26220D0,  0.22791D0,  0.19528D0,  0.13713D0,  0.08936D0,
55806      &     0.05277D0,  0.02703D0,  0.00310D0,  0.00000D0/
55807       DATA (FMRS(2,1,I, 5),I=1,49)/
55808      &     0.01695D0,  0.02068D0,  0.02524D0,  0.02837D0,  0.03082D0,
55809      &     0.03287D0,  0.04018D0,  0.04922D0,  0.05552D0,  0.06053D0,
55810      &     0.06480D0,  0.08053D0,  0.10168D0,  0.11784D0,  0.13174D0,
55811      &     0.14430D0,  0.16698D0,  0.19737D0,  0.24257D0,  0.28331D0,
55812      &     0.35517D0,  0.41625D0,  0.46767D0,  0.51932D0,  0.55801D0,
55813      &     0.58472D0,  0.60061D0,  0.60677D0,  0.60420D0,  0.59394D0,
55814      &     0.57732D0,  0.55511D0,  0.52831D0,  0.49795D0,  0.46473D0,
55815      &     0.42958D0,  0.39324D0,  0.35636D0,  0.31976D0,  0.28363D0,
55816      &     0.24869D0,  0.21549D0,  0.18405D0,  0.12838D0,  0.08307D0,
55817      &     0.04866D0,  0.02468D0,  0.00276D0,  0.00000D0/
55818       DATA (FMRS(2,1,I, 6),I=1,49)/
55819      &     0.01712D0,  0.02090D0,  0.02552D0,  0.02868D0,  0.03117D0,
55820      &     0.03325D0,  0.04066D0,  0.04984D0,  0.05623D0,  0.06133D0,
55821      &     0.06568D0,  0.08172D0,  0.10333D0,  0.11984D0,  0.13405D0,
55822      &     0.14688D0,  0.17001D0,  0.20090D0,  0.24663D0,  0.28761D0,
55823      &     0.35934D0,  0.41972D0,  0.47004D0,  0.51998D0,  0.55675D0,
55824      &     0.58145D0,  0.59540D0,  0.59970D0,  0.59545D0,  0.58373D0,
55825      &     0.56587D0,  0.54263D0,  0.51509D0,  0.48426D0,  0.45082D0,
55826      &     0.41570D0,  0.37956D0,  0.34309D0,  0.30710D0,  0.27167D0,
55827      &     0.23758D0,  0.20532D0,  0.17488D0,  0.12129D0,  0.07799D0,
55828      &     0.04537D0,  0.02283D0,  0.00249D0,  0.00000D0/
55829       DATA (FMRS(2,1,I, 7),I=1,49)/
55830      &     0.01728D0,  0.02111D0,  0.02578D0,  0.02899D0,  0.03151D0,
55831      &     0.03361D0,  0.04113D0,  0.05044D0,  0.05693D0,  0.06211D0,
55832      &     0.06653D0,  0.08287D0,  0.10492D0,  0.12178D0,  0.13628D0,
55833      &     0.14936D0,  0.17290D0,  0.20425D0,  0.25045D0,  0.29164D0,
55834      &     0.36316D0,  0.42280D0,  0.47203D0,  0.52030D0,  0.55522D0,
55835      &     0.57804D0,  0.59016D0,  0.59271D0,  0.58692D0,  0.57390D0,
55836      &     0.55488D0,  0.53075D0,  0.50265D0,  0.47135D0,  0.43776D0,
55837      &     0.40267D0,  0.36679D0,  0.33078D0,  0.29535D0,  0.26064D0,
55838      &     0.22735D0,  0.19600D0,  0.16649D0,  0.11484D0,  0.07339D0,
55839      &     0.04241D0,  0.02117D0,  0.00226D0,  0.00000D0/
55840       DATA (FMRS(2,1,I, 8),I=1,49)/
55841      &     0.01745D0,  0.02133D0,  0.02606D0,  0.02931D0,  0.03187D0,
55842      &     0.03400D0,  0.04163D0,  0.05108D0,  0.05768D0,  0.06295D0,
55843      &     0.06745D0,  0.08411D0,  0.10662D0,  0.12385D0,  0.13865D0,
55844      &     0.15200D0,  0.17596D0,  0.20780D0,  0.25445D0,  0.29582D0,
55845      &     0.36707D0,  0.42589D0,  0.47392D0,  0.52041D0,  0.55338D0,
55846      &     0.57422D0,  0.58442D0,  0.58519D0,  0.57783D0,  0.56344D0,
55847      &     0.54329D0,  0.51831D0,  0.48960D0,  0.45793D0,  0.42423D0,
55848      &     0.38922D0,  0.35366D0,  0.31814D0,  0.28333D0,  0.24940D0,
55849      &     0.21696D0,  0.18656D0,  0.15803D0,  0.10837D0,  0.06882D0,
55850      &     0.03949D0,  0.01956D0,  0.00204D0,  0.00000D0/
55851       DATA (FMRS(2,1,I, 9),I=1,49)/
55852      &     0.01760D0,  0.02152D0,  0.02631D0,  0.02960D0,  0.03218D0,
55853      &     0.03434D0,  0.04207D0,  0.05164D0,  0.05833D0,  0.06368D0,
55854      &     0.06825D0,  0.08519D0,  0.10811D0,  0.12566D0,  0.14073D0,
55855      &     0.15430D0,  0.17863D0,  0.21087D0,  0.25789D0,  0.29938D0,
55856      &     0.37036D0,  0.42844D0,  0.47541D0,  0.52034D0,  0.55162D0,
55857      &     0.57077D0,  0.57932D0,  0.57861D0,  0.56993D0,  0.55438D0,
55858      &     0.53332D0,  0.50767D0,  0.47844D0,  0.44653D0,  0.41277D0,
55859      &     0.37787D0,  0.34261D0,  0.30753D0,  0.27327D0,  0.24001D0,
55860      &     0.20832D0,  0.17873D0,  0.15102D0,  0.10304D0,  0.06508D0,
55861      &     0.03712D0,  0.01826D0,  0.00186D0,  0.00000D0/
55862       DATA (FMRS(2,1,I,10),I=1,49)/
55863      &     0.01775D0,  0.02171D0,  0.02655D0,  0.02988D0,  0.03249D0,
55864      &     0.03468D0,  0.04249D0,  0.05219D0,  0.05897D0,  0.06440D0,
55865      &     0.06904D0,  0.08625D0,  0.10956D0,  0.12741D0,  0.14273D0,
55866      &     0.15651D0,  0.18119D0,  0.21379D0,  0.26115D0,  0.30273D0,
55867      &     0.37339D0,  0.43070D0,  0.47663D0,  0.52004D0,  0.54971D0,
55868      &     0.56723D0,  0.57424D0,  0.57214D0,  0.56221D0,  0.54564D0,
55869      &     0.52375D0,  0.49748D0,  0.46783D0,  0.43572D0,  0.40192D0,
55870      &     0.36718D0,  0.33221D0,  0.29755D0,  0.26385D0,  0.23124D0,
55871      &     0.20028D0,  0.17145D0,  0.14454D0,  0.09813D0,  0.06166D0,
55872      &     0.03497D0,  0.01708D0,  0.00171D0,  0.00000D0/
55873       DATA (FMRS(2,1,I,11),I=1,49)/
55874      &     0.01786D0,  0.02185D0,  0.02674D0,  0.03010D0,  0.03274D0,
55875      &     0.03494D0,  0.04284D0,  0.05263D0,  0.05949D0,  0.06497D0,
55876      &     0.06967D0,  0.08709D0,  0.11072D0,  0.12880D0,  0.14432D0,
55877      &     0.15827D0,  0.18322D0,  0.21609D0,  0.26371D0,  0.30535D0,
55878      &     0.37572D0,  0.43240D0,  0.47751D0,  0.51970D0,  0.54811D0,
55879      &     0.56435D0,  0.57017D0,  0.56701D0,  0.55612D0,  0.53878D0,
55880      &     0.51626D0,  0.48950D0,  0.45957D0,  0.42732D0,  0.39351D0,
55881      &     0.35893D0,  0.32420D0,  0.28986D0,  0.25663D0,  0.22452D0,
55882      &     0.19414D0,  0.16588D0,  0.13961D0,  0.09442D0,  0.05909D0,
55883      &     0.03336D0,  0.01621D0,  0.00160D0,  0.00000D0/
55884       DATA (FMRS(2,1,I,12),I=1,49)/
55885      &     0.01811D0,  0.02217D0,  0.02715D0,  0.03057D0,  0.03326D0,
55886      &     0.03551D0,  0.04357D0,  0.05358D0,  0.06059D0,  0.06620D0,
55887      &     0.07102D0,  0.08890D0,  0.11320D0,  0.13179D0,  0.14772D0,
55888      &     0.16201D0,  0.18751D0,  0.22095D0,  0.26905D0,  0.31076D0,
55889      &     0.38043D0,  0.43573D0,  0.47902D0,  0.51865D0,  0.54434D0,
55890      &     0.55794D0,  0.56131D0,  0.55592D0,  0.54308D0,  0.52418D0,
55891      &     0.50041D0,  0.47277D0,  0.44227D0,  0.40979D0,  0.37605D0,
55892      &     0.34185D0,  0.30765D0,  0.27411D0,  0.24188D0,  0.21085D0,
55893      &     0.18166D0,  0.15463D0,  0.12966D0,  0.08698D0,  0.05397D0,
55894      &     0.03017D0,  0.01449D0,  0.00138D0,  0.00000D0/
55895       DATA (FMRS(2,1,I,13),I=1,49)/
55896      &     0.01832D0,  0.02245D0,  0.02751D0,  0.03099D0,  0.03372D0,
55897      &     0.03601D0,  0.04421D0,  0.05440D0,  0.06155D0,  0.06727D0,
55898      &     0.07220D0,  0.09048D0,  0.11535D0,  0.13437D0,  0.15065D0,
55899      &     0.16524D0,  0.19119D0,  0.22510D0,  0.27356D0,  0.31528D0,
55900      &     0.38427D0,  0.43832D0,  0.48002D0,  0.51742D0,  0.54081D0,
55901      &     0.55220D0,  0.55352D0,  0.54629D0,  0.53189D0,  0.51174D0,
55902      &     0.48699D0,  0.45870D0,  0.42778D0,  0.39517D0,  0.36159D0,
55903      &     0.32774D0,  0.29406D0,  0.26124D0,  0.22984D0,  0.19975D0,
55904      &     0.17155D0,  0.14556D0,  0.12166D0,  0.08107D0,  0.04993D0,
55905      &     0.02767D0,  0.01316D0,  0.00122D0,  0.00000D0/
55906       DATA (FMRS(2,1,I,14),I=1,49)/
55907      &     0.01856D0,  0.02276D0,  0.02791D0,  0.03145D0,  0.03424D0,
55908      &     0.03657D0,  0.04493D0,  0.05533D0,  0.06263D0,  0.06849D0,
55909      &     0.07353D0,  0.09227D0,  0.11778D0,  0.13727D0,  0.15393D0,
55910      &     0.16884D0,  0.19528D0,  0.22966D0,  0.27847D0,  0.32014D0,
55911      &     0.38833D0,  0.44089D0,  0.48079D0,  0.51572D0,  0.53660D0,
55912      &     0.54555D0,  0.54466D0,  0.53550D0,  0.51948D0,  0.49806D0,
55913      &     0.47232D0,  0.44337D0,  0.41209D0,  0.37941D0,  0.34606D0,
55914      &     0.31264D0,  0.27962D0,  0.24761D0,  0.21707D0,  0.18804D0,
55915      &     0.16093D0,  0.13609D0,  0.11331D0,  0.07496D0,  0.04577D0,
55916      &     0.02513D0,  0.01183D0,  0.00106D0,  0.00000D0/
55917       DATA (FMRS(2,1,I,15),I=1,49)/
55918      &     0.01882D0,  0.02309D0,  0.02833D0,  0.03194D0,  0.03478D0,
55919      &     0.03716D0,  0.04569D0,  0.05632D0,  0.06378D0,  0.06977D0,
55920      &     0.07493D0,  0.09414D0,  0.12031D0,  0.14028D0,  0.15732D0,
55921      &     0.17254D0,  0.19946D0,  0.23430D0,  0.28337D0,  0.32492D0,
55922      &     0.39212D0,  0.44309D0,  0.48109D0,  0.51344D0,  0.53176D0,
55923      &     0.53830D0,  0.53520D0,  0.52410D0,  0.50654D0,  0.48389D0,
55924      &     0.45725D0,  0.42772D0,  0.39621D0,  0.36351D0,  0.33050D0,
55925      &     0.29757D0,  0.26525D0,  0.23404D0,  0.20451D0,  0.17653D0,
55926      &     0.15059D0,  0.12691D0,  0.10526D0,  0.06909D0,  0.04183D0,
55927      &     0.02276D0,  0.01059D0,  0.00092D0,  0.00000D0/
55928       DATA (FMRS(2,1,I,16),I=1,49)/
55929      &     0.01904D0,  0.02338D0,  0.02872D0,  0.03239D0,  0.03528D0,
55930      &     0.03770D0,  0.04639D0,  0.05722D0,  0.06483D0,  0.07094D0,
55931      &     0.07621D0,  0.09585D0,  0.12261D0,  0.14301D0,  0.16039D0,
55932      &     0.17588D0,  0.20321D0,  0.23842D0,  0.28769D0,  0.32908D0,
55933      &     0.39530D0,  0.44481D0,  0.48105D0,  0.51110D0,  0.52712D0,
55934      &     0.53155D0,  0.52655D0,  0.51382D0,  0.49491D0,  0.47126D0,
55935      &     0.44390D0,  0.41395D0,  0.38228D0,  0.34968D0,  0.31695D0,
55936      &     0.28453D0,  0.25288D0,  0.22245D0,  0.19380D0,  0.16677D0,
55937      &     0.14180D0,  0.11912D0,  0.09847D0,  0.06418D0,  0.03856D0,
55938      &     0.02081D0,  0.00959D0,  0.00081D0,  0.00000D0/
55939       DATA (FMRS(2,1,I,17),I=1,49)/
55940      &     0.01928D0,  0.02369D0,  0.02911D0,  0.03284D0,  0.03578D0,
55941      &     0.03825D0,  0.04709D0,  0.05813D0,  0.06589D0,  0.07213D0,
55942      &     0.07751D0,  0.09758D0,  0.12493D0,  0.14576D0,  0.16348D0,
55943      &     0.17924D0,  0.20696D0,  0.24251D0,  0.29193D0,  0.33312D0,
55944      &     0.39831D0,  0.44629D0,  0.48077D0,  0.50852D0,  0.52228D0,
55945      &     0.52463D0,  0.51781D0,  0.50355D0,  0.48335D0,  0.45879D0,
55946      &     0.43078D0,  0.40049D0,  0.36872D0,  0.33629D0,  0.30386D0,
55947      &     0.27197D0,  0.24101D0,  0.21137D0,  0.18360D0,  0.15751D0,
55948      &     0.13349D0,  0.11178D0,  0.09210D0,  0.05961D0,  0.03555D0,
55949      &     0.01901D0,  0.00868D0,  0.00071D0,  0.00000D0/
55950       DATA (FMRS(2,1,I,18),I=1,49)/
55951      &     0.01947D0,  0.02394D0,  0.02943D0,  0.03322D0,  0.03621D0,
55952      &     0.03871D0,  0.04769D0,  0.05889D0,  0.06678D0,  0.07312D0,
55953      &     0.07860D0,  0.09903D0,  0.12687D0,  0.14804D0,  0.16603D0,
55954      &     0.18199D0,  0.21002D0,  0.24583D0,  0.29534D0,  0.33632D0,
55955      &     0.40060D0,  0.44729D0,  0.48029D0,  0.50614D0,  0.51810D0,
55956      &     0.51876D0,  0.51049D0,  0.49502D0,  0.47387D0,  0.44861D0,
55957      &     0.42013D0,  0.38960D0,  0.35780D0,  0.32553D0,  0.29342D0,
55958      &     0.26197D0,  0.23158D0,  0.20258D0,  0.17557D0,  0.15022D0,
55959      &     0.12699D0,  0.10608D0,  0.08715D0,  0.05607D0,  0.03324D0,
55960      &     0.01765D0,  0.00799D0,  0.00064D0,  0.00000D0/
55961       DATA (FMRS(2,1,I,19),I=1,49)/
55962      &     0.01970D0,  0.02424D0,  0.02983D0,  0.03369D0,  0.03672D0,
55963      &     0.03927D0,  0.04841D0,  0.05983D0,  0.06787D0,  0.07433D0,
55964      &     0.07993D0,  0.10079D0,  0.12921D0,  0.15080D0,  0.16909D0,
55965      &     0.18531D0,  0.21368D0,  0.24977D0,  0.29932D0,  0.34002D0,
55966      &     0.40312D0,  0.44820D0,  0.47944D0,  0.50301D0,  0.51281D0,
55967      &     0.51154D0,  0.50156D0,  0.48470D0,  0.46252D0,  0.43645D0,
55968      &     0.40748D0,  0.37672D0,  0.34495D0,  0.31293D0,  0.28123D0,
55969      &     0.25036D0,  0.22064D0,  0.19244D0,  0.16630D0,  0.14187D0,
55970      &     0.11955D0,  0.09954D0,  0.08152D0,  0.05209D0,  0.03065D0,
55971      &     0.01614D0,  0.00723D0,  0.00056D0,  0.00000D0/
55972       DATA (FMRS(2,1,I,20),I=1,49)/
55973      &     0.01991D0,  0.02452D0,  0.03019D0,  0.03410D0,  0.03718D0,
55974      &     0.03977D0,  0.04905D0,  0.06066D0,  0.06884D0,  0.07541D0,
55975      &     0.08111D0,  0.10235D0,  0.13129D0,  0.15323D0,  0.17180D0,
55976      &     0.18822D0,  0.21689D0,  0.25320D0,  0.30276D0,  0.34318D0,
55977      &     0.40521D0,  0.44885D0,  0.47855D0,  0.50013D0,  0.50806D0,
55978      &     0.50515D0,  0.49374D0,  0.47571D0,  0.45269D0,  0.42596D0,
55979      &     0.39662D0,  0.36569D0,  0.33399D0,  0.30222D0,  0.27090D0,
55980      &     0.24056D0,  0.21144D0,  0.18393D0,  0.15855D0,  0.13491D0,
55981      &     0.11336D0,  0.09413D0,  0.07687D0,  0.04883D0,  0.02854D0,
55982      &     0.01493D0,  0.00663D0,  0.00051D0,  0.00000D0/
55983       DATA (FMRS(2,1,I,21),I=1,49)/
55984      &     0.02011D0,  0.02477D0,  0.03051D0,  0.03448D0,  0.03760D0,
55985      &     0.04023D0,  0.04965D0,  0.06143D0,  0.06973D0,  0.07641D0,
55986      &     0.08220D0,  0.10379D0,  0.13319D0,  0.15544D0,  0.17424D0,
55987      &     0.19085D0,  0.21976D0,  0.25625D0,  0.30577D0,  0.34590D0,
55988      &     0.40689D0,  0.44921D0,  0.47746D0,  0.49725D0,  0.50352D0,
55989      &     0.49914D0,  0.48649D0,  0.46748D0,  0.44367D0,  0.41645D0,
55990      &     0.38678D0,  0.35582D0,  0.32417D0,  0.29264D0,  0.26169D0,
55991      &     0.23187D0,  0.20335D0,  0.17646D0,  0.15176D0,  0.12881D0,
55992      &     0.10798D0,  0.08943D0,  0.07284D0,  0.04602D0,  0.02675D0,
55993      &     0.01389D0,  0.00613D0,  0.00046D0,  0.00000D0/
55994       DATA (FMRS(2,1,I,22),I=1,49)/
55995      &     0.02035D0,  0.02509D0,  0.03093D0,  0.03496D0,  0.03814D0,
55996      &     0.04081D0,  0.05040D0,  0.06241D0,  0.07087D0,  0.07768D0,
55997      &     0.08359D0,  0.10562D0,  0.13559D0,  0.15824D0,  0.17734D0,
55998      &     0.19417D0,  0.22338D0,  0.26006D0,  0.30949D0,  0.34920D0,
55999      &     0.40885D0,  0.44948D0,  0.47592D0,  0.49348D0,  0.49770D0,
56000      &     0.49152D0,  0.47736D0,  0.45716D0,  0.43246D0,  0.40467D0,
56001      &     0.37468D0,  0.34367D0,  0.31217D0,  0.28097D0,  0.25052D0,
56002      &     0.22133D0,  0.19355D0,  0.16747D0,  0.14359D0,  0.12150D0,
56003      &     0.10155D0,  0.08384D0,  0.06806D0,  0.04272D0,  0.02464D0,
56004      &     0.01269D0,  0.00554D0,  0.00040D0,  0.00000D0/
56005       DATA (FMRS(2,1,I,23),I=1,49)/
56006      &     0.02058D0,  0.02539D0,  0.03132D0,  0.03542D0,  0.03865D0,
56007      &     0.04137D0,  0.05112D0,  0.06333D0,  0.07195D0,  0.07888D0,
56008      &     0.08490D0,  0.10735D0,  0.13786D0,  0.16087D0,  0.18023D0,
56009      &     0.19726D0,  0.22673D0,  0.26356D0,  0.31287D0,  0.35216D0,
56010      &     0.41052D0,  0.44953D0,  0.47430D0,  0.48980D0,  0.49215D0,
56011      &     0.48435D0,  0.46885D0,  0.44758D0,  0.42215D0,  0.39387D0,
56012      &     0.36366D0,  0.33261D0,  0.30132D0,  0.27045D0,  0.24050D0,
56013      &     0.21190D0,  0.18476D0,  0.15947D0,  0.13635D0,  0.11504D0,
56014      &     0.09587D0,  0.07894D0,  0.06387D0,  0.03984D0,  0.02282D0,
56015      &     0.01167D0,  0.00505D0,  0.00036D0,  0.00000D0/
56016       DATA (FMRS(2,1,I,24),I=1,49)/
56017      &     0.02080D0,  0.02568D0,  0.03170D0,  0.03585D0,  0.03914D0,
56018      &     0.04189D0,  0.05180D0,  0.06421D0,  0.07296D0,  0.08001D0,
56019      &     0.08614D0,  0.10897D0,  0.13997D0,  0.16330D0,  0.18290D0,
56020      &     0.20010D0,  0.22978D0,  0.26672D0,  0.31586D0,  0.35473D0,
56021      &     0.41182D0,  0.44931D0,  0.47248D0,  0.48612D0,  0.48676D0,
56022      &     0.47750D0,  0.46081D0,  0.43866D0,  0.41258D0,  0.38389D0,
56023      &     0.35352D0,  0.32245D0,  0.29140D0,  0.26089D0,  0.23143D0,
56024      &     0.20340D0,  0.17690D0,  0.15229D0,  0.12990D0,  0.10931D0,
56025      &     0.09084D0,  0.07461D0,  0.06021D0,  0.03734D0,  0.02125D0,
56026      &     0.01078D0,  0.00462D0,  0.00032D0,  0.00000D0/
56027       DATA (FMRS(2,1,I,25),I=1,49)/
56028      &     0.02102D0,  0.02596D0,  0.03207D0,  0.03629D0,  0.03962D0,
56029      &     0.04242D0,  0.05248D0,  0.06508D0,  0.07398D0,  0.08115D0,
56030      &     0.08738D0,  0.11059D0,  0.14207D0,  0.16573D0,  0.18556D0,
56031      &     0.20292D0,  0.23281D0,  0.26985D0,  0.31879D0,  0.35722D0,
56032      &     0.41303D0,  0.44900D0,  0.47060D0,  0.48240D0,  0.48138D0,
56033      &     0.47074D0,  0.45292D0,  0.42993D0,  0.40324D0,  0.37421D0,
56034      &     0.34370D0,  0.31266D0,  0.28186D0,  0.25172D0,  0.22275D0,
56035      &     0.19528D0,  0.16943D0,  0.14547D0,  0.12379D0,  0.10391D0,
56036      &     0.08611D0,  0.07055D0,  0.05678D0,  0.03501D0,  0.01980D0,
56037      &     0.00997D0,  0.00424D0,  0.00029D0,  0.00000D0/
56038       DATA (FMRS(2,1,I,26),I=1,49)/
56039      &     0.02124D0,  0.02625D0,  0.03244D0,  0.03672D0,  0.04010D0,
56040      &     0.04294D0,  0.05315D0,  0.06595D0,  0.07499D0,  0.08227D0,
56041      &     0.08860D0,  0.11218D0,  0.14413D0,  0.16809D0,  0.18813D0,
56042      &     0.20564D0,  0.23571D0,  0.27281D0,  0.32152D0,  0.35948D0,
56043      &     0.41398D0,  0.44847D0,  0.46857D0,  0.47858D0,  0.47599D0,
56044      &     0.46404D0,  0.44519D0,  0.42139D0,  0.39420D0,  0.36490D0,
56045      &     0.33431D0,  0.30337D0,  0.27282D0,  0.24304D0,  0.21455D0,
56046      &     0.18765D0,  0.16244D0,  0.13911D0,  0.11808D0,  0.09890D0,
56047      &     0.08174D0,  0.06681D0,  0.05361D0,  0.03286D0,  0.01847D0,
56048      &     0.00924D0,  0.00390D0,  0.00026D0,  0.00000D0/
56049       DATA (FMRS(2,1,I,27),I=1,49)/
56050      &     0.02145D0,  0.02652D0,  0.03279D0,  0.03713D0,  0.04055D0,
56051      &     0.04343D0,  0.05378D0,  0.06677D0,  0.07594D0,  0.08333D0,
56052      &     0.08975D0,  0.11368D0,  0.14607D0,  0.17031D0,  0.19054D0,
56053      &     0.20819D0,  0.23841D0,  0.27555D0,  0.32402D0,  0.36153D0,
56054      &     0.41478D0,  0.44786D0,  0.46655D0,  0.47490D0,  0.47088D0,
56055      &     0.45773D0,  0.43795D0,  0.41346D0,  0.38583D0,  0.35628D0,
56056      &     0.32564D0,  0.29483D0,  0.26454D0,  0.23512D0,  0.20709D0,
56057      &     0.18074D0,  0.15610D0,  0.13337D0,  0.11295D0,  0.09439D0,
56058      &     0.07783D0,  0.06346D0,  0.05079D0,  0.03096D0,  0.01730D0,
56059      &     0.00860D0,  0.00360D0,  0.00023D0,  0.00000D0/
56060       DATA (FMRS(2,1,I,28),I=1,49)/
56061      &     0.02164D0,  0.02677D0,  0.03312D0,  0.03751D0,  0.04098D0,
56062      &     0.04390D0,  0.05439D0,  0.06755D0,  0.07684D0,  0.08433D0,
56063      &     0.09084D0,  0.11510D0,  0.14789D0,  0.17239D0,  0.19279D0,
56064      &     0.21056D0,  0.24091D0,  0.27806D0,  0.32630D0,  0.36334D0,
56065      &     0.41540D0,  0.44716D0,  0.46451D0,  0.47135D0,  0.46602D0,
56066      &     0.45177D0,  0.43117D0,  0.40606D0,  0.37805D0,  0.34829D0,
56067      &     0.31763D0,  0.28699D0,  0.25693D0,  0.22788D0,  0.20031D0,
56068      &     0.17447D0,  0.15036D0,  0.12818D0,  0.10834D0,  0.09032D0,
56069      &     0.07432D0,  0.06046D0,  0.04827D0,  0.02929D0,  0.01628D0,
56070      &     0.00804D0,  0.00334D0,  0.00021D0,  0.00000D0/
56071       DATA (FMRS(2,1,I,29),I=1,49)/
56072      &     0.02184D0,  0.02703D0,  0.03346D0,  0.03790D0,  0.04142D0,
56073      &     0.04437D0,  0.05500D0,  0.06833D0,  0.07775D0,  0.08534D0,
56074      &     0.09195D0,  0.11653D0,  0.14972D0,  0.17447D0,  0.19503D0,
56075      &     0.21292D0,  0.24339D0,  0.28054D0,  0.32851D0,  0.36507D0,
56076      &     0.41592D0,  0.44635D0,  0.46240D0,  0.46773D0,  0.46111D0,
56077      &     0.44581D0,  0.42442D0,  0.39875D0,  0.37037D0,  0.34044D0,
56078      &     0.30980D0,  0.27932D0,  0.24952D0,  0.22085D0,  0.19375D0,
56079      &     0.16840D0,  0.14482D0,  0.12320D0,  0.10392D0,  0.08643D0,
56080      &     0.07097D0,  0.05759D0,  0.04588D0,  0.02770D0,  0.01531D0,
56081      &     0.00752D0,  0.00311D0,  0.00019D0,  0.00000D0/
56082       DATA (FMRS(2,1,I,30),I=1,49)/
56083      &     0.02204D0,  0.02729D0,  0.03379D0,  0.03829D0,  0.04185D0,
56084      &     0.04484D0,  0.05560D0,  0.06911D0,  0.07865D0,  0.08634D0,
56085      &     0.09303D0,  0.11793D0,  0.15151D0,  0.17649D0,  0.19722D0,
56086      &     0.21521D0,  0.24577D0,  0.28291D0,  0.33057D0,  0.36667D0,
56087      &     0.41631D0,  0.44543D0,  0.46021D0,  0.46408D0,  0.45622D0,
56088      &     0.43995D0,  0.41780D0,  0.39163D0,  0.36293D0,  0.33287D0,
56089      &     0.30229D0,  0.27195D0,  0.24246D0,  0.21416D0,  0.18750D0,
56090      &     0.16265D0,  0.13957D0,  0.11850D0,  0.09976D0,  0.08278D0,
56091      &     0.06783D0,  0.05492D0,  0.04366D0,  0.02623D0,  0.01442D0,
56092      &     0.00705D0,  0.00289D0,  0.00017D0,  0.00000D0/
56093       DATA (FMRS(2,1,I,31),I=1,49)/
56094      &     0.02222D0,  0.02753D0,  0.03410D0,  0.03866D0,  0.04226D0,
56095      &     0.04528D0,  0.05617D0,  0.06985D0,  0.07951D0,  0.08729D0,
56096      &     0.09407D0,  0.11927D0,  0.15320D0,  0.17841D0,  0.19928D0,
56097      &     0.21737D0,  0.24802D0,  0.28513D0,  0.33249D0,  0.36812D0,
56098      &     0.41660D0,  0.44449D0,  0.45808D0,  0.46059D0,  0.45160D0,
56099      &     0.43442D0,  0.41159D0,  0.38497D0,  0.35599D0,  0.32584D0,
56100      &     0.29532D0,  0.26514D0,  0.23594D0,  0.20800D0,  0.18176D0,
56101      &     0.15738D0,  0.13478D0,  0.11421D0,  0.09597D0,  0.07947D0,
56102      &     0.06498D0,  0.05251D0,  0.04166D0,  0.02491D0,  0.01363D0,
56103      &     0.00662D0,  0.00270D0,  0.00016D0,  0.00000D0/
56104       DATA (FMRS(2,1,I,32),I=1,49)/
56105      &     0.02240D0,  0.02776D0,  0.03441D0,  0.03901D0,  0.04265D0,
56106      &     0.04571D0,  0.05672D0,  0.07055D0,  0.08032D0,  0.08819D0,
56107      &     0.09505D0,  0.12053D0,  0.15480D0,  0.18021D0,  0.20120D0,
56108      &     0.21937D0,  0.25009D0,  0.28716D0,  0.33421D0,  0.36938D0,
56109      &     0.41675D0,  0.44346D0,  0.45593D0,  0.45721D0,  0.44717D0,
56110      &     0.42917D0,  0.40572D0,  0.37869D0,  0.34947D0,  0.31928D0,
56111      &     0.28882D0,  0.25885D0,  0.22992D0,  0.20233D0,  0.17646D0,
56112      &     0.15252D0,  0.13038D0,  0.11028D0,  0.09251D0,  0.07647D0,
56113      &     0.06240D0,  0.05033D0,  0.03984D0,  0.02372D0,  0.01293D0,
56114      &     0.00625D0,  0.00253D0,  0.00015D0,  0.00000D0/
56115       DATA (FMRS(2,1,I,33),I=1,49)/
56116      &     0.02258D0,  0.02800D0,  0.03471D0,  0.03936D0,  0.04304D0,
56117      &     0.04613D0,  0.05727D0,  0.07126D0,  0.08114D0,  0.08911D0,
56118      &     0.09604D0,  0.12181D0,  0.15642D0,  0.18202D0,  0.20315D0,
56119      &     0.22140D0,  0.25219D0,  0.28920D0,  0.33594D0,  0.37065D0,
56120      &     0.41690D0,  0.44243D0,  0.45378D0,  0.45384D0,  0.44278D0,
56121      &     0.42397D0,  0.39993D0,  0.37250D0,  0.34307D0,  0.31283D0,
56122      &     0.28245D0,  0.25269D0,  0.22404D0,  0.19681D0,  0.17131D0,
56123      &     0.14780D0,  0.12613D0,  0.10648D0,  0.08918D0,  0.07357D0,
56124      &     0.05991D0,  0.04824D0,  0.03811D0,  0.02259D0,  0.01226D0,
56125      &     0.00589D0,  0.00237D0,  0.00014D0,  0.00000D0/
56126       DATA (FMRS(2,1,I,34),I=1,49)/
56127      &     0.02276D0,  0.02823D0,  0.03502D0,  0.03972D0,  0.04344D0,
56128      &     0.04656D0,  0.05782D0,  0.07197D0,  0.08196D0,  0.09001D0,
56129      &     0.09702D0,  0.12306D0,  0.15799D0,  0.18378D0,  0.20502D0,
56130      &     0.22334D0,  0.25418D0,  0.29111D0,  0.33751D0,  0.37174D0,
56131      &     0.41686D0,  0.44123D0,  0.45149D0,  0.45035D0,  0.43832D0,
56132      &     0.41874D0,  0.39416D0,  0.36638D0,  0.33679D0,  0.30651D0,
56133      &     0.27625D0,  0.24670D0,  0.21831D0,  0.19144D0,  0.16636D0,
56134      &     0.14329D0,  0.12204D0,  0.10286D0,  0.08597D0,  0.07080D0,
56135      &     0.05755D0,  0.04624D0,  0.03646D0,  0.02153D0,  0.01162D0,
56136      &     0.00556D0,  0.00222D0,  0.00012D0,  0.00000D0/
56137       DATA (FMRS(2,1,I,35),I=1,49)/
56138      &     0.02294D0,  0.02846D0,  0.03531D0,  0.04006D0,  0.04381D0,
56139      &     0.04697D0,  0.05834D0,  0.07264D0,  0.08274D0,  0.09087D0,
56140      &     0.09796D0,  0.12426D0,  0.15949D0,  0.18547D0,  0.20682D0,
56141      &     0.22520D0,  0.25608D0,  0.29293D0,  0.33900D0,  0.37277D0,
56142      &     0.41683D0,  0.44010D0,  0.44933D0,  0.44706D0,  0.43413D0,
56143      &     0.41383D0,  0.38877D0,  0.36068D0,  0.33093D0,  0.30063D0,
56144      &     0.27049D0,  0.24114D0,  0.21302D0,  0.18649D0,  0.16180D0,
56145      &     0.13914D0,  0.11828D0,  0.09955D0,  0.08303D0,  0.06826D0,
56146      &     0.05540D0,  0.04443D0,  0.03497D0,  0.02057D0,  0.01106D0,
56147      &     0.00526D0,  0.00209D0,  0.00012D0,  0.00000D0/
56148       DATA (FMRS(2,1,I,36),I=1,49)/
56149      &     0.02310D0,  0.02867D0,  0.03558D0,  0.04038D0,  0.04417D0,
56150      &     0.04736D0,  0.05885D0,  0.07328D0,  0.08348D0,  0.09170D0,
56151      &     0.09885D0,  0.12540D0,  0.16092D0,  0.18705D0,  0.20850D0,
56152      &     0.22693D0,  0.25784D0,  0.29461D0,  0.34036D0,  0.37368D0,
56153      &     0.41672D0,  0.43895D0,  0.44722D0,  0.44390D0,  0.43013D0,
56154      &     0.40920D0,  0.38369D0,  0.35531D0,  0.32545D0,  0.29515D0,
56155      &     0.26511D0,  0.23598D0,  0.20812D0,  0.18191D0,  0.15758D0,
56156      &     0.13530D0,  0.11483D0,  0.09649D0,  0.08034D0,  0.06595D0,
56157      &     0.05344D0,  0.04278D0,  0.03361D0,  0.01970D0,  0.01054D0,
56158      &     0.00499D0,  0.00197D0,  0.00011D0,  0.00000D0/
56159       DATA (FMRS(2,1,I,37),I=1,49)/
56160      &     0.02327D0,  0.02889D0,  0.03587D0,  0.04071D0,  0.04453D0,
56161      &     0.04775D0,  0.05935D0,  0.07393D0,  0.08423D0,  0.09253D0,
56162      &     0.09975D0,  0.12655D0,  0.16235D0,  0.18864D0,  0.21018D0,
56163      &     0.22866D0,  0.25959D0,  0.29626D0,  0.34166D0,  0.37452D0,
56164      &     0.41652D0,  0.43771D0,  0.44502D0,  0.44067D0,  0.42606D0,
56165      &     0.40453D0,  0.37859D0,  0.34994D0,  0.31996D0,  0.28968D0,
56166      &     0.25976D0,  0.23084D0,  0.20328D0,  0.17738D0,  0.15341D0,
56167      &     0.13150D0,  0.11145D0,  0.09348D0,  0.07773D0,  0.06369D0,
56168      &     0.05153D0,  0.04117D0,  0.03229D0,  0.01885D0,  0.01005D0,
56169      &     0.00474D0,  0.00186D0,  0.00010D0,  0.00000D0/
56170       DATA (FMRS(2,1,I,38),I=1,49)/
56171      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56172      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56173      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56174      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56175      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56176      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56177      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56178      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56179      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56180      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56181       DATA (FMRS(2,2,I, 1),I=1,49)/
56182      &     0.00683D0,  0.00832D0,  0.01013D0,  0.01138D0,  0.01237D0,
56183      &     0.01320D0,  0.01619D0,  0.02004D0,  0.02286D0,  0.02522D0,
56184      &     0.02744D0,  0.03623D0,  0.04952D0,  0.06032D0,  0.06982D0,
56185      &     0.07843D0,  0.09385D0,  0.11395D0,  0.14220D0,  0.16592D0,
56186      &     0.20382D0,  0.23228D0,  0.25344D0,  0.27158D0,  0.28216D0,
56187      &     0.28647D0,  0.28570D0,  0.28068D0,  0.27216D0,  0.26127D0,
56188      &     0.24773D0,  0.23281D0,  0.21663D0,  0.19968D0,  0.18252D0,
56189      &     0.16522D0,  0.14809D0,  0.13153D0,  0.11576D0,  0.10050D0,
56190      &     0.08631D0,  0.07335D0,  0.06127D0,  0.04098D0,  0.02531D0,
56191      &     0.01409D0,  0.00672D0,  0.00064D0,  0.00000D0/
56192       DATA (FMRS(2,2,I, 2),I=1,49)/
56193      &     0.00687D0,  0.00838D0,  0.01023D0,  0.01151D0,  0.01252D0,
56194      &     0.01336D0,  0.01643D0,  0.02037D0,  0.02327D0,  0.02569D0,
56195      &     0.02797D0,  0.03698D0,  0.05059D0,  0.06162D0,  0.07129D0,
56196      &     0.08004D0,  0.09567D0,  0.11595D0,  0.14429D0,  0.16793D0,
56197      &     0.20539D0,  0.23318D0,  0.25356D0,  0.27069D0,  0.28025D0,
56198      &     0.28363D0,  0.28200D0,  0.27624D0,  0.26713D0,  0.25572D0,
56199      &     0.24185D0,  0.22669D0,  0.21040D0,  0.19345D0,  0.17637D0,
56200      &     0.15928D0,  0.14242D0,  0.12615D0,  0.11076D0,  0.09591D0,
56201      &     0.08215D0,  0.06963D0,  0.05800D0,  0.03856D0,  0.02367D0,
56202      &     0.01309D0,  0.00619D0,  0.00057D0,  0.00000D0/
56203       DATA (FMRS(2,2,I, 3),I=1,49)/
56204      &     0.00693D0,  0.00848D0,  0.01038D0,  0.01170D0,  0.01274D0,
56205      &     0.01362D0,  0.01679D0,  0.02088D0,  0.02389D0,  0.02641D0,
56206      &     0.02877D0,  0.03812D0,  0.05220D0,  0.06356D0,  0.07349D0,
56207      &     0.08244D0,  0.09836D0,  0.11888D0,  0.14732D0,  0.17082D0,
56208      &     0.20757D0,  0.23434D0,  0.25356D0,  0.26918D0,  0.27725D0,
56209      &     0.27927D0,  0.27642D0,  0.26960D0,  0.25969D0,  0.24758D0,
56210      &     0.23327D0,  0.21778D0,  0.20136D0,  0.18446D0,  0.16756D0,
56211      &     0.15079D0,  0.13434D0,  0.11852D0,  0.10371D0,  0.08946D0,
56212      &     0.07631D0,  0.06442D0,  0.05345D0,  0.03522D0,  0.02142D0,
56213      &     0.01172D0,  0.00548D0,  0.00049D0,  0.00000D0/
56214       DATA (FMRS(2,2,I, 4),I=1,49)/
56215      &     0.00697D0,  0.00855D0,  0.01050D0,  0.01184D0,  0.01291D0,
56216      &     0.01380D0,  0.01706D0,  0.02126D0,  0.02435D0,  0.02694D0,
56217      &     0.02937D0,  0.03897D0,  0.05339D0,  0.06499D0,  0.07510D0,
56218      &     0.08419D0,  0.10031D0,  0.12100D0,  0.14949D0,  0.17285D0,
56219      &     0.20905D0,  0.23506D0,  0.25342D0,  0.26794D0,  0.27493D0,
56220      &     0.27599D0,  0.27230D0,  0.26475D0,  0.25426D0,  0.24171D0,
56221      &     0.22712D0,  0.21140D0,  0.19495D0,  0.17811D0,  0.16138D0,
56222      &     0.14485D0,  0.12869D0,  0.11323D0,  0.09881D0,  0.08500D0,
56223      &     0.07230D0,  0.06086D0,  0.05034D0,  0.03297D0,  0.01992D0,
56224      &     0.01081D0,  0.00501D0,  0.00044D0,  0.00000D0/
56225       DATA (FMRS(2,2,I, 5),I=1,49)/
56226      &     0.00702D0,  0.00863D0,  0.01062D0,  0.01200D0,  0.01309D0,
56227      &     0.01401D0,  0.01735D0,  0.02167D0,  0.02485D0,  0.02751D0,
56228      &     0.03001D0,  0.03988D0,  0.05465D0,  0.06649D0,  0.07678D0,
56229      &     0.08602D0,  0.10233D0,  0.12317D0,  0.15168D0,  0.17488D0,
56230      &     0.21046D0,  0.23564D0,  0.25309D0,  0.26645D0,  0.27234D0,
56231      &     0.27243D0,  0.26786D0,  0.25959D0,  0.24854D0,  0.23557D0,
56232      &     0.22068D0,  0.20486D0,  0.18841D0,  0.17163D0,  0.15506D0,
56233      &     0.13880D0,  0.12296D0,  0.10788D0,  0.09387D0,  0.08052D0,
56234      &     0.06829D0,  0.05730D0,  0.04726D0,  0.03074D0,  0.01844D0,
56235      &     0.00993D0,  0.00456D0,  0.00039D0,  0.00000D0/
56236       DATA (FMRS(2,2,I, 6),I=1,49)/
56237      &     0.00706D0,  0.00870D0,  0.01073D0,  0.01213D0,  0.01325D0,
56238      &     0.01419D0,  0.01761D0,  0.02203D0,  0.02528D0,  0.02801D0,
56239      &     0.03057D0,  0.04067D0,  0.05575D0,  0.06780D0,  0.07825D0,
56240      &     0.08760D0,  0.10408D0,  0.12504D0,  0.15354D0,  0.17659D0,
56241      &     0.21162D0,  0.23607D0,  0.25274D0,  0.26511D0,  0.27006D0,
56242      &     0.26933D0,  0.26403D0,  0.25518D0,  0.24367D0,  0.23035D0,
56243      &     0.21525D0,  0.19935D0,  0.18289D0,  0.16620D0,  0.14980D0,
56244      &     0.13377D0,  0.11822D0,  0.10346D0,  0.08981D0,  0.07685D0,
56245      &     0.06502D0,  0.05441D0,  0.04475D0,  0.02894D0,  0.01725D0,
56246      &     0.00923D0,  0.00420D0,  0.00035D0,  0.00000D0/
56247       DATA (FMRS(2,2,I, 7),I=1,49)/
56248      &     0.00711D0,  0.00877D0,  0.01083D0,  0.01227D0,  0.01340D0,
56249      &     0.01436D0,  0.01785D0,  0.02237D0,  0.02570D0,  0.02850D0,
56250      &     0.03112D0,  0.04143D0,  0.05680D0,  0.06905D0,  0.07964D0,
56251      &     0.08911D0,  0.10573D0,  0.12679D0,  0.15527D0,  0.17816D0,
56252      &     0.21263D0,  0.23638D0,  0.25229D0,  0.26373D0,  0.26781D0,
56253      &     0.26630D0,  0.26033D0,  0.25095D0,  0.23903D0,  0.22536D0,
56254      &     0.21011D0,  0.19416D0,  0.17766D0,  0.16111D0,  0.14488D0,
56255      &     0.12910D0,  0.11382D0,  0.09936D0,  0.08606D0,  0.07347D0,
56256      &     0.06201D0,  0.05178D0,  0.04247D0,  0.02732D0,  0.01619D0,
56257      &     0.00860D0,  0.00389D0,  0.00031D0,  0.00000D0/
56258       DATA (FMRS(2,2,I, 8),I=1,49)/
56259      &     0.00716D0,  0.00885D0,  0.01095D0,  0.01241D0,  0.01357D0,
56260      &     0.01455D0,  0.01812D0,  0.02275D0,  0.02616D0,  0.02902D0,
56261      &     0.03170D0,  0.04225D0,  0.05792D0,  0.07038D0,  0.08112D0,
56262      &     0.09070D0,  0.10747D0,  0.12863D0,  0.15707D0,  0.17976D0,
56263      &     0.21362D0,  0.23661D0,  0.25172D0,  0.26218D0,  0.26535D0,
56264      &     0.26303D0,  0.25640D0,  0.24647D0,  0.23413D0,  0.22018D0,
56265      &     0.20477D0,  0.18875D0,  0.17228D0,  0.15585D0,  0.13983D0,
56266      &     0.12430D0,  0.10932D0,  0.09519D0,  0.08225D0,  0.07005D0,
56267      &     0.05898D0,  0.04912D0,  0.04018D0,  0.02570D0,  0.01514D0,
56268      &     0.00799D0,  0.00358D0,  0.00028D0,  0.00000D0/
56269       DATA (FMRS(2,2,I, 9),I=1,49)/
56270      &     0.00720D0,  0.00891D0,  0.01105D0,  0.01254D0,  0.01372D0,
56271      &     0.01472D0,  0.01836D0,  0.02308D0,  0.02656D0,  0.02948D0,
56272      &     0.03221D0,  0.04297D0,  0.05891D0,  0.07154D0,  0.08241D0,
56273      &     0.09208D0,  0.10897D0,  0.13020D0,  0.15860D0,  0.18111D0,
56274      &     0.21443D0,  0.23674D0,  0.25116D0,  0.26078D0,  0.26316D0,
56275      &     0.26017D0,  0.25299D0,  0.24260D0,  0.22991D0,  0.21577D0,
56276      &     0.20023D0,  0.18414D0,  0.16776D0,  0.15141D0,  0.13557D0,
56277      &     0.12027D0,  0.10555D0,  0.09171D0,  0.07908D0,  0.06721D0,
56278      &     0.05646D0,  0.04691D0,  0.03829D0,  0.02437D0,  0.01428D0,
56279      &     0.00749D0,  0.00333D0,  0.00026D0,  0.00000D0/
56280       DATA (FMRS(2,2,I,10),I=1,49)/
56281      &     0.00724D0,  0.00898D0,  0.01115D0,  0.01266D0,  0.01386D0,
56282      &     0.01488D0,  0.01859D0,  0.02340D0,  0.02695D0,  0.02993D0,
56283      &     0.03271D0,  0.04366D0,  0.05985D0,  0.07265D0,  0.08364D0,
56284      &     0.09340D0,  0.11040D0,  0.13168D0,  0.16002D0,  0.18235D0,
56285      &     0.21512D0,  0.23679D0,  0.25054D0,  0.25935D0,  0.26099D0,
56286      &     0.25738D0,  0.24967D0,  0.23885D0,  0.22588D0,  0.21153D0,
56287      &     0.19588D0,  0.17977D0,  0.16345D0,  0.14723D0,  0.13156D0,
56288      &     0.11648D0,  0.10202D0,  0.08846D0,  0.07613D0,  0.06457D0,
56289      &     0.05413D0,  0.04488D0,  0.03655D0,  0.02315D0,  0.01349D0,
56290      &     0.00703D0,  0.00311D0,  0.00024D0,  0.00000D0/
56291       DATA (FMRS(2,2,I,11),I=1,49)/
56292      &     0.00727D0,  0.00904D0,  0.01123D0,  0.01276D0,  0.01398D0,
56293      &     0.01501D0,  0.01877D0,  0.02366D0,  0.02727D0,  0.03029D0,
56294      &     0.03311D0,  0.04422D0,  0.06061D0,  0.07353D0,  0.08461D0,
56295      &     0.09444D0,  0.11152D0,  0.13285D0,  0.16112D0,  0.18330D0,
56296      &     0.21564D0,  0.23680D0,  0.25001D0,  0.25818D0,  0.25925D0,
56297      &     0.25517D0,  0.24705D0,  0.23591D0,  0.22272D0,  0.20821D0,
56298      &     0.19248D0,  0.17638D0,  0.16011D0,  0.14399D0,  0.12847D0,
56299      &     0.11356D0,  0.09932D0,  0.08597D0,  0.07388D0,  0.06256D0,
56300      &     0.05235D0,  0.04334D0,  0.03522D0,  0.02223D0,  0.01290D0,
56301      &     0.00670D0,  0.00295D0,  0.00022D0,  0.00000D0/
56302       DATA (FMRS(2,2,I,12),I=1,49)/
56303      &     0.00735D0,  0.00915D0,  0.01141D0,  0.01298D0,  0.01423D0,
56304      &     0.01529D0,  0.01917D0,  0.02422D0,  0.02794D0,  0.03106D0,
56305      &     0.03397D0,  0.04541D0,  0.06221D0,  0.07541D0,  0.08668D0,
56306      &     0.09664D0,  0.11388D0,  0.13528D0,  0.16340D0,  0.18523D0,
56307      &     0.21662D0,  0.23667D0,  0.24876D0,  0.25560D0,  0.25550D0,
56308      &     0.25041D0,  0.24145D0,  0.22968D0,  0.21606D0,  0.20125D0,
56309      &     0.18540D0,  0.16932D0,  0.15319D0,  0.13731D0,  0.12210D0,
56310      &     0.10759D0,  0.09378D0,  0.08090D0,  0.06929D0,  0.05847D0,
56311      &     0.04874D0,  0.04022D0,  0.03256D0,  0.02039D0,  0.01173D0,
56312      &     0.00603D0,  0.00263D0,  0.00019D0,  0.00000D0/
56313       DATA (FMRS(2,2,I,13),I=1,49)/
56314      &     0.00742D0,  0.00926D0,  0.01156D0,  0.01317D0,  0.01446D0,
56315      &     0.01554D0,  0.01952D0,  0.02471D0,  0.02853D0,  0.03173D0,
56316      &     0.03472D0,  0.04644D0,  0.06360D0,  0.07703D0,  0.08845D0,
56317      &     0.09852D0,  0.11589D0,  0.13732D0,  0.16529D0,  0.18680D0,
56318      &     0.21735D0,  0.23643D0,  0.24757D0,  0.25329D0,  0.25220D0,
56319      &     0.24629D0,  0.23665D0,  0.22439D0,  0.21043D0,  0.19540D0,
56320      &     0.17949D0,  0.16343D0,  0.14746D0,  0.13180D0,  0.11686D0,
56321      &     0.10269D0,  0.08926D0,  0.07677D0,  0.06556D0,  0.05517D0,
56322      &     0.04584D0,  0.03772D0,  0.03044D0,  0.01893D0,  0.01082D0,
56323      &     0.00551D0,  0.00238D0,  0.00017D0,  0.00000D0/
56324       DATA (FMRS(2,2,I,14),I=1,49)/
56325      &     0.00750D0,  0.00938D0,  0.01173D0,  0.01339D0,  0.01471D0,
56326      &     0.01583D0,  0.01992D0,  0.02526D0,  0.02920D0,  0.03250D0,
56327      &     0.03557D0,  0.04761D0,  0.06516D0,  0.07882D0,  0.09041D0,
56328      &     0.10060D0,  0.11809D0,  0.13955D0,  0.16731D0,  0.18846D0,
56329      &     0.21802D0,  0.23605D0,  0.24613D0,  0.25062D0,  0.24846D0,
56330      &     0.24169D0,  0.23135D0,  0.21858D0,  0.20428D0,  0.18902D0,
56331      &     0.17309D0,  0.15708D0,  0.14130D0,  0.12590D0,  0.11127D0,
56332      &     0.09745D0,  0.08445D0,  0.07239D0,  0.06165D0,  0.05170D0,
56333      &     0.04281D0,  0.03511D0,  0.02824D0,  0.01743D0,  0.00988D0,
56334      &     0.00499D0,  0.00213D0,  0.00015D0,  0.00000D0/
56335       DATA (FMRS(2,2,I,15),I=1,49)/
56336      &     0.00758D0,  0.00950D0,  0.01192D0,  0.01362D0,  0.01498D0,
56337      &     0.01613D0,  0.02034D0,  0.02584D0,  0.02990D0,  0.03330D0,
56338      &     0.03646D0,  0.04882D0,  0.06676D0,  0.08067D0,  0.09242D0,
56339      &     0.10271D0,  0.12031D0,  0.14177D0,  0.16927D0,  0.19002D0,
56340      &     0.21855D0,  0.23546D0,  0.24445D0,  0.24771D0,  0.24448D0,
56341      &     0.23683D0,  0.22584D0,  0.21262D0,  0.19799D0,  0.18255D0,
56342      &     0.16661D0,  0.15073D0,  0.13511D0,  0.12003D0,  0.10571D0,
56343      &     0.09233D0,  0.07973D0,  0.06812D0,  0.05781D0,  0.04834D0,
56344      &     0.03990D0,  0.03259D0,  0.02612D0,  0.01599D0,  0.00899D0,
56345      &     0.00450D0,  0.00190D0,  0.00013D0,  0.00000D0/
56346       DATA (FMRS(2,2,I,16),I=1,49)/
56347      &     0.00766D0,  0.00962D0,  0.01210D0,  0.01384D0,  0.01522D0,
56348      &     0.01640D0,  0.02073D0,  0.02638D0,  0.03055D0,  0.03403D0,
56349      &     0.03728D0,  0.04992D0,  0.06822D0,  0.08234D0,  0.09422D0,
56350      &     0.10460D0,  0.12228D0,  0.14371D0,  0.17097D0,  0.19133D0,
56351      &     0.21891D0,  0.23481D0,  0.24283D0,  0.24499D0,  0.24085D0,
56352      &     0.23246D0,  0.22090D0,  0.20727D0,  0.19242D0,  0.17687D0,
56353      &     0.16094D0,  0.14517D0,  0.12974D0,  0.11493D0,  0.10094D0,
56354      &     0.08792D0,  0.07568D0,  0.06448D0,  0.05456D0,  0.04548D0,
56355      &     0.03743D0,  0.03047D0,  0.02435D0,  0.01480D0,  0.00826D0,
56356      &     0.00410D0,  0.00171D0,  0.00011D0,  0.00000D0/
56357       DATA (FMRS(2,2,I,17),I=1,49)/
56358      &     0.00775D0,  0.00975D0,  0.01228D0,  0.01406D0,  0.01548D0,
56359      &     0.01669D0,  0.02112D0,  0.02692D0,  0.03120D0,  0.03478D0,
56360      &     0.03810D0,  0.05104D0,  0.06968D0,  0.08400D0,  0.09602D0,
56361      &     0.10648D0,  0.12423D0,  0.14563D0,  0.17261D0,  0.19256D0,
56362      &     0.21918D0,  0.23405D0,  0.24112D0,  0.24221D0,  0.23719D0,
56363      &     0.22809D0,  0.21600D0,  0.20198D0,  0.18694D0,  0.17130D0,
56364      &     0.15541D0,  0.13976D0,  0.12455D0,  0.11000D0,  0.09636D0,
56365      &     0.08368D0,  0.07182D0,  0.06101D0,  0.05149D0,  0.04278D0,
56366      &     0.03510D0,  0.02849D0,  0.02269D0,  0.01370D0,  0.00759D0,
56367      &     0.00374D0,  0.00155D0,  0.00010D0,  0.00000D0/
56368       DATA (FMRS(2,2,I,18),I=1,49)/
56369      &     0.00782D0,  0.00985D0,  0.01243D0,  0.01424D0,  0.01569D0,
56370      &     0.01692D0,  0.02146D0,  0.02738D0,  0.03175D0,  0.03540D0,
56371      &     0.03879D0,  0.05197D0,  0.07089D0,  0.08537D0,  0.09749D0,
56372      &     0.10801D0,  0.12581D0,  0.14716D0,  0.17390D0,  0.19349D0,
56373      &     0.21930D0,  0.23333D0,  0.23963D0,  0.23986D0,  0.23413D0,
56374      &     0.22447D0,  0.21197D0,  0.19769D0,  0.18248D0,  0.16678D0,
56375      &     0.15094D0,  0.13543D0,  0.12040D0,  0.10608D0,  0.09270D0,
56376      &     0.08031D0,  0.06878D0,  0.05828D0,  0.04908D0,  0.04068D0,
56377      &     0.03329D0,  0.02694D0,  0.02140D0,  0.01285D0,  0.00708D0,
56378      &     0.00346D0,  0.00142D0,  0.00009D0,  0.00000D0/
56379       DATA (FMRS(2,2,I,19),I=1,49)/
56380      &     0.00791D0,  0.00998D0,  0.01261D0,  0.01447D0,  0.01595D0,
56381      &     0.01722D0,  0.02186D0,  0.02794D0,  0.03242D0,  0.03616D0,
56382      &     0.03963D0,  0.05310D0,  0.07234D0,  0.08702D0,  0.09924D0,
56383      &     0.10983D0,  0.12767D0,  0.14895D0,  0.17537D0,  0.19453D0,
56384      &     0.21933D0,  0.23238D0,  0.23773D0,  0.23696D0,  0.23039D0,
56385      &     0.22010D0,  0.20715D0,  0.19257D0,  0.17716D0,  0.16147D0,
56386      &     0.14570D0,  0.13034D0,  0.11556D0,  0.10152D0,  0.08847D0,
56387      &     0.07643D0,  0.06526D0,  0.05515D0,  0.04631D0,  0.03827D0,
56388      &     0.03122D0,  0.02519D0,  0.01995D0,  0.01190D0,  0.00650D0,
56389      &     0.00315D0,  0.00128D0,  0.00008D0,  0.00000D0/
56390       DATA (FMRS(2,2,I,20),I=1,49)/
56391      &     0.00799D0,  0.01010D0,  0.01278D0,  0.01467D0,  0.01619D0,
56392      &     0.01748D0,  0.02223D0,  0.02844D0,  0.03302D0,  0.03684D0,
56393      &     0.04038D0,  0.05409D0,  0.07362D0,  0.08846D0,  0.10078D0,
56394      &     0.11143D0,  0.12930D0,  0.15050D0,  0.17662D0,  0.19539D0,
56395      &     0.21931D0,  0.23148D0,  0.23602D0,  0.23438D0,  0.22712D0,
56396      &     0.21628D0,  0.20296D0,  0.18814D0,  0.17260D0,  0.15692D0,
56397      &     0.14124D0,  0.12600D0,  0.11146D0,  0.09768D0,  0.08490D0,
56398      &     0.07317D0,  0.06233D0,  0.05253D0,  0.04400D0,  0.03627D0,
56399      &     0.02950D0,  0.02375D0,  0.01875D0,  0.01112D0,  0.00604D0,
56400      &     0.00291D0,  0.00117D0,  0.00007D0,  0.00000D0/
56401       DATA (FMRS(2,2,I,21),I=1,49)/
56402      &     0.00806D0,  0.01021D0,  0.01293D0,  0.01486D0,  0.01641D0,
56403      &     0.01772D0,  0.02256D0,  0.02890D0,  0.03357D0,  0.03747D0,
56404      &     0.04106D0,  0.05501D0,  0.07479D0,  0.08976D0,  0.10217D0,
56405      &     0.11285D0,  0.13073D0,  0.15184D0,  0.17768D0,  0.19608D0,
56406      &     0.21918D0,  0.23055D0,  0.23436D0,  0.23195D0,  0.22407D0,
56407      &     0.21277D0,  0.19913D0,  0.18411D0,  0.16851D0,  0.15282D0,
56408      &     0.13724D0,  0.12215D0,  0.10780D0,  0.09426D0,  0.08175D0,
56409      &     0.07030D0,  0.05975D0,  0.05024D0,  0.04199D0,  0.03453D0,
56410      &     0.02802D0,  0.02251D0,  0.01772D0,  0.01045D0,  0.00564D0,
56411      &     0.00270D0,  0.00108D0,  0.00006D0,  0.00000D0/
56412       DATA (FMRS(2,2,I,22),I=1,49)/
56413      &     0.00816D0,  0.01035D0,  0.01313D0,  0.01511D0,  0.01669D0,
56414      &     0.01803D0,  0.02299D0,  0.02949D0,  0.03427D0,  0.03826D0,
56415      &     0.04194D0,  0.05616D0,  0.07626D0,  0.09141D0,  0.10390D0,
56416      &     0.11463D0,  0.13252D0,  0.15350D0,  0.17897D0,  0.19689D0,
56417      &     0.21895D0,  0.22932D0,  0.23223D0,  0.22887D0,  0.22024D0,
56418      &     0.20839D0,  0.19437D0,  0.17913D0,  0.16346D0,  0.14778D0,
56419      &     0.13233D0,  0.11744D0,  0.10335D0,  0.09011D0,  0.07794D0,
56420      &     0.06684D0,  0.05665D0,  0.04749D0,  0.03958D0,  0.03245D0,
56421      &     0.02625D0,  0.02103D0,  0.01650D0,  0.00967D0,  0.00518D0,
56422      &     0.00246D0,  0.00097D0,  0.00005D0,  0.00000D0/
56423       DATA (FMRS(2,2,I,23),I=1,49)/
56424      &     0.00826D0,  0.01049D0,  0.01333D0,  0.01534D0,  0.01695D0,
56425      &     0.01833D0,  0.02340D0,  0.03004D0,  0.03494D0,  0.03901D0,
56426      &     0.04276D0,  0.05725D0,  0.07764D0,  0.09293D0,  0.10551D0,
56427      &     0.11628D0,  0.13416D0,  0.15502D0,  0.18011D0,  0.19758D0,
56428      &     0.21867D0,  0.22812D0,  0.23018D0,  0.22598D0,  0.21667D0,
56429      &     0.20434D0,  0.19000D0,  0.17460D0,  0.15883D0,  0.14320D0,
56430      &     0.12787D0,  0.11321D0,  0.09934D0,  0.08640D0,  0.07454D0,
56431      &     0.06376D0,  0.05389D0,  0.04504D0,  0.03744D0,  0.03063D0,
56432      &     0.02471D0,  0.01973D0,  0.01544D0,  0.00899D0,  0.00479D0,
56433      &     0.00225D0,  0.00088D0,  0.00005D0,  0.00000D0/
56434       DATA (FMRS(2,2,I,24),I=1,49)/
56435      &     0.00835D0,  0.01062D0,  0.01351D0,  0.01556D0,  0.01721D0,
56436      &     0.01861D0,  0.02378D0,  0.03057D0,  0.03556D0,  0.03972D0,
56437      &     0.04354D0,  0.05827D0,  0.07891D0,  0.09434D0,  0.10698D0,
56438      &     0.11778D0,  0.13564D0,  0.15636D0,  0.18108D0,  0.19811D0,
56439      &     0.21829D0,  0.22687D0,  0.22819D0,  0.22319D0,  0.21330D0,
56440      &     0.20053D0,  0.18593D0,  0.17036D0,  0.15459D0,  0.13902D0,
56441      &     0.12383D0,  0.10936D0,  0.09573D0,  0.08306D0,  0.07149D0,
56442      &     0.06100D0,  0.05144D0,  0.04289D0,  0.03556D0,  0.02901D0,
56443      &     0.02335D0,  0.01859D0,  0.01451D0,  0.00840D0,  0.00444D0,
56444      &     0.00208D0,  0.00081D0,  0.00004D0,  0.00000D0/
56445       DATA (FMRS(2,2,I,25),I=1,49)/
56446      &     0.00844D0,  0.01075D0,  0.01369D0,  0.01578D0,  0.01746D0,
56447      &     0.01889D0,  0.02417D0,  0.03109D0,  0.03619D0,  0.04043D0,
56448      &     0.04431D0,  0.05929D0,  0.08018D0,  0.09573D0,  0.10844D0,
56449      &     0.11926D0,  0.13709D0,  0.15767D0,  0.18202D0,  0.19861D0,
56450      &     0.21788D0,  0.22561D0,  0.22620D0,  0.22044D0,  0.20998D0,
56451      &     0.19681D0,  0.18196D0,  0.16625D0,  0.15048D0,  0.13499D0,
56452      &     0.11994D0,  0.10567D0,  0.09228D0,  0.07987D0,  0.06858D0,
56453      &     0.05838D0,  0.04911D0,  0.04085D0,  0.03379D0,  0.02749D0,
56454      &     0.02207D0,  0.01753D0,  0.01364D0,  0.00785D0,  0.00413D0,
56455      &     0.00192D0,  0.00074D0,  0.00004D0,  0.00000D0/
56456       DATA (FMRS(2,2,I,26),I=1,49)/
56457      &     0.00853D0,  0.01088D0,  0.01388D0,  0.01600D0,  0.01772D0,
56458      &     0.01917D0,  0.02456D0,  0.03161D0,  0.03680D0,  0.04112D0,
56459      &     0.04508D0,  0.06028D0,  0.08140D0,  0.09707D0,  0.10983D0,
56460      &     0.12067D0,  0.13846D0,  0.15889D0,  0.18286D0,  0.19901D0,
56461      &     0.21739D0,  0.22430D0,  0.22419D0,  0.21773D0,  0.20672D0,
56462      &     0.19320D0,  0.17811D0,  0.16233D0,  0.14654D0,  0.13113D0,
56463      &     0.11622D0,  0.10216D0,  0.08901D0,  0.07686D0,  0.06584D0,
56464      &     0.05592D0,  0.04692D0,  0.03894D0,  0.03214D0,  0.02608D0,
56465      &     0.02089D0,  0.01655D0,  0.01285D0,  0.00735D0,  0.00384D0,
56466      &     0.00177D0,  0.00068D0,  0.00003D0,  0.00000D0/
56467       DATA (FMRS(2,2,I,27),I=1,49)/
56468      &     0.00862D0,  0.01100D0,  0.01405D0,  0.01622D0,  0.01796D0,
56469      &     0.01944D0,  0.02492D0,  0.03211D0,  0.03739D0,  0.04178D0,
56470      &     0.04580D0,  0.06121D0,  0.08256D0,  0.09833D0,  0.11114D0,
56471      &     0.12198D0,  0.13974D0,  0.16000D0,  0.18361D0,  0.19934D0,
56472      &     0.21688D0,  0.22303D0,  0.22227D0,  0.21516D0,  0.20368D0,
56473      &     0.18983D0,  0.17455D0,  0.15870D0,  0.14292D0,  0.12759D0,
56474      &     0.11282D0,  0.09895D0,  0.08604D0,  0.07413D0,  0.06336D0,
56475      &     0.05370D0,  0.04495D0,  0.03722D0,  0.03066D0,  0.02482D0,
56476      &     0.01983D0,  0.01568D0,  0.01214D0,  0.00691D0,  0.00359D0,
56477      &     0.00164D0,  0.00063D0,  0.00003D0,  0.00000D0/
56478       DATA (FMRS(2,2,I,28),I=1,49)/
56479      &     0.00871D0,  0.01113D0,  0.01422D0,  0.01642D0,  0.01819D0,
56480      &     0.01970D0,  0.02527D0,  0.03257D0,  0.03795D0,  0.04240D0,
56481      &     0.04648D0,  0.06209D0,  0.08364D0,  0.09950D0,  0.11235D0,
56482      &     0.12320D0,  0.14090D0,  0.16101D0,  0.18426D0,  0.19960D0,
56483      &     0.21635D0,  0.22178D0,  0.22043D0,  0.21273D0,  0.20082D0,
56484      &     0.18670D0,  0.17123D0,  0.15532D0,  0.13957D0,  0.12434D0,
56485      &     0.10972D0,  0.09602D0,  0.08332D0,  0.07164D0,  0.06111D0,
56486      &     0.05170D0,  0.04318D0,  0.03568D0,  0.02933D0,  0.02371D0,
56487      &     0.01889D0,  0.01491D0,  0.01151D0,  0.00652D0,  0.00337D0,
56488      &     0.00153D0,  0.00058D0,  0.00003D0,  0.00000D0/
56489       DATA (FMRS(2,2,I,29),I=1,49)/
56490      &     0.00880D0,  0.01125D0,  0.01439D0,  0.01662D0,  0.01842D0,
56491      &     0.01995D0,  0.02562D0,  0.03305D0,  0.03850D0,  0.04303D0,
56492      &     0.04716D0,  0.06297D0,  0.08471D0,  0.10067D0,  0.11354D0,
56493      &     0.12440D0,  0.14205D0,  0.16199D0,  0.18487D0,  0.19981D0,
56494      &     0.21577D0,  0.22050D0,  0.21856D0,  0.21030D0,  0.19797D0,
56495      &     0.18358D0,  0.16796D0,  0.15200D0,  0.13629D0,  0.12116D0,
56496      &     0.10670D0,  0.09318D0,  0.08069D0,  0.06924D0,  0.05894D0,
56497      &     0.04976D0,  0.04148D0,  0.03421D0,  0.02806D0,  0.02263D0,
56498      &     0.01799D0,  0.01417D0,  0.01091D0,  0.00615D0,  0.00316D0,
56499      &     0.00143D0,  0.00054D0,  0.00003D0,  0.00000D0/
56500       DATA (FMRS(2,2,I,30),I=1,49)/
56501      &     0.00889D0,  0.01137D0,  0.01456D0,  0.01683D0,  0.01865D0,
56502      &     0.02021D0,  0.02596D0,  0.03351D0,  0.03906D0,  0.04365D0,
56503      &     0.04784D0,  0.06384D0,  0.08576D0,  0.10180D0,  0.11470D0,
56504      &     0.12555D0,  0.14314D0,  0.16292D0,  0.18544D0,  0.19997D0,
56505      &     0.21516D0,  0.21921D0,  0.21670D0,  0.20790D0,  0.19518D0,
56506      &     0.18054D0,  0.16480D0,  0.14880D0,  0.13314D0,  0.11810D0,
56507      &     0.10380D0,  0.09048D0,  0.07819D0,  0.06696D0,  0.05688D0,
56508      &     0.04793D0,  0.03987D0,  0.03282D0,  0.02686D0,  0.02162D0,
56509      &     0.01715D0,  0.01347D0,  0.01036D0,  0.00581D0,  0.00297D0,
56510      &     0.00134D0,  0.00050D0,  0.00002D0,  0.00000D0/
56511       DATA (FMRS(2,2,I,31),I=1,49)/
56512      &     0.00897D0,  0.01149D0,  0.01472D0,  0.01702D0,  0.01887D0,
56513      &     0.02045D0,  0.02630D0,  0.03396D0,  0.03958D0,  0.04424D0,
56514      &     0.04848D0,  0.06466D0,  0.08676D0,  0.10286D0,  0.11579D0,
56515      &     0.12663D0,  0.14416D0,  0.16377D0,  0.18594D0,  0.20009D0,
56516      &     0.21455D0,  0.21797D0,  0.21493D0,  0.20563D0,  0.19256D0,
56517      &     0.17769D0,  0.16185D0,  0.14582D0,  0.13021D0,  0.11528D0,
56518      &     0.10112D0,  0.08798D0,  0.07588D0,  0.06486D0,  0.05500D0,
56519      &     0.04626D0,  0.03841D0,  0.03155D0,  0.02578D0,  0.02071D0,
56520      &     0.01640D0,  0.01285D0,  0.00986D0,  0.00551D0,  0.00280D0,
56521      &     0.00125D0,  0.00046D0,  0.00002D0,  0.00000D0/
56522       DATA (FMRS(2,2,I,32),I=1,49)/
56523      &     0.00905D0,  0.01160D0,  0.01487D0,  0.01721D0,  0.01909D0,
56524      &     0.02069D0,  0.02661D0,  0.03438D0,  0.04008D0,  0.04480D0,
56525      &     0.04909D0,  0.06543D0,  0.08768D0,  0.10385D0,  0.11679D0,
56526      &     0.12763D0,  0.14509D0,  0.16454D0,  0.18637D0,  0.20016D0,
56527      &     0.21393D0,  0.21676D0,  0.21323D0,  0.20346D0,  0.19008D0,
56528      &     0.17502D0,  0.15909D0,  0.14304D0,  0.12749D0,  0.11266D0,
56529      &     0.09863D0,  0.08567D0,  0.07376D0,  0.06293D0,  0.05328D0,
56530      &     0.04474D0,  0.03708D0,  0.03039D0,  0.02479D0,  0.01988D0,
56531      &     0.01572D0,  0.01229D0,  0.00941D0,  0.00524D0,  0.00265D0,
56532      &     0.00118D0,  0.00043D0,  0.00002D0,  0.00000D0/
56533       DATA (FMRS(2,2,I,33),I=1,49)/
56534      &     0.00914D0,  0.01172D0,  0.01503D0,  0.01740D0,  0.01930D0,
56535      &     0.02092D0,  0.02693D0,  0.03481D0,  0.04058D0,  0.04536D0,
56536      &     0.04970D0,  0.06621D0,  0.08862D0,  0.10485D0,  0.11781D0,
56537      &     0.12863D0,  0.14602D0,  0.16531D0,  0.18679D0,  0.20022D0,
56538      &     0.21330D0,  0.21555D0,  0.21154D0,  0.20131D0,  0.18763D0,
56539      &     0.17238D0,  0.15637D0,  0.14031D0,  0.12482D0,  0.11010D0,
56540      &     0.09620D0,  0.08342D0,  0.07168D0,  0.06106D0,  0.05161D0,
56541      &     0.04326D0,  0.03580D0,  0.02928D0,  0.02384D0,  0.01908D0,
56542      &     0.01506D0,  0.01176D0,  0.00899D0,  0.00498D0,  0.00251D0,
56543      &     0.00111D0,  0.00041D0,  0.00002D0,  0.00000D0/
56544       DATA (FMRS(2,2,I,34),I=1,49)/
56545      &     0.00922D0,  0.01183D0,  0.01519D0,  0.01758D0,  0.01951D0,
56546      &     0.02116D0,  0.02725D0,  0.03523D0,  0.04108D0,  0.04592D0,
56547      &     0.05030D0,  0.06698D0,  0.08953D0,  0.10581D0,  0.11878D0,
56548      &     0.12959D0,  0.14690D0,  0.16601D0,  0.18715D0,  0.20021D0,
56549      &     0.21262D0,  0.21429D0,  0.20982D0,  0.19916D0,  0.18519D0,
56550      &     0.16977D0,  0.15369D0,  0.13763D0,  0.12221D0,  0.10760D0,
56551      &     0.09385D0,  0.08123D0,  0.06969D0,  0.05926D0,  0.05001D0,
56552      &     0.04183D0,  0.03456D0,  0.02822D0,  0.02295D0,  0.01833D0,
56553      &     0.01444D0,  0.01126D0,  0.00858D0,  0.00473D0,  0.00238D0,
56554      &     0.00105D0,  0.00038D0,  0.00002D0,  0.00000D0/
56555       DATA (FMRS(2,2,I,35),I=1,49)/
56556      &     0.00930D0,  0.01194D0,  0.01534D0,  0.01777D0,  0.01972D0,
56557      &     0.02138D0,  0.02755D0,  0.03564D0,  0.04156D0,  0.04645D0,
56558      &     0.05088D0,  0.06771D0,  0.09039D0,  0.10673D0,  0.11970D0,
56559      &     0.13050D0,  0.14773D0,  0.16667D0,  0.18748D0,  0.20020D0,
56560      &     0.21197D0,  0.21309D0,  0.20820D0,  0.19714D0,  0.18290D0,
56561      &     0.16734D0,  0.15119D0,  0.13514D0,  0.11978D0,  0.10528D0,
56562      &     0.09167D0,  0.07922D0,  0.06786D0,  0.05760D0,  0.04853D0,
56563      &     0.04052D0,  0.03343D0,  0.02726D0,  0.02213D0,  0.01765D0,
56564      &     0.01387D0,  0.01080D0,  0.00822D0,  0.00451D0,  0.00226D0,
56565      &     0.00099D0,  0.00036D0,  0.00002D0,  0.00000D0/
56566       DATA (FMRS(2,2,I,36),I=1,49)/
56567      &     0.00938D0,  0.01205D0,  0.01549D0,  0.01794D0,  0.01992D0,
56568      &     0.02160D0,  0.02784D0,  0.03602D0,  0.04201D0,  0.04696D0,
56569      &     0.05143D0,  0.06840D0,  0.09121D0,  0.10758D0,  0.12056D0,
56570      &     0.13134D0,  0.14849D0,  0.16728D0,  0.18776D0,  0.20016D0,
56571      &     0.21132D0,  0.21194D0,  0.20664D0,  0.19522D0,  0.18074D0,
56572      &     0.16504D0,  0.14884D0,  0.13281D0,  0.11752D0,  0.10313D0,
56573      &     0.08965D0,  0.07735D0,  0.06616D0,  0.05608D0,  0.04717D0,
56574      &     0.03933D0,  0.03239D0,  0.02637D0,  0.02137D0,  0.01702D0,
56575      &     0.01336D0,  0.01038D0,  0.00788D0,  0.00431D0,  0.00215D0,
56576      &     0.00094D0,  0.00034D0,  0.00001D0,  0.00000D0/
56577       DATA (FMRS(2,2,I,37),I=1,49)/
56578      &     0.00946D0,  0.01216D0,  0.01563D0,  0.01812D0,  0.02011D0,
56579      &     0.02182D0,  0.02814D0,  0.03641D0,  0.04247D0,  0.04747D0,
56580      &     0.05199D0,  0.06909D0,  0.09202D0,  0.10844D0,  0.12142D0,
56581      &     0.13217D0,  0.14925D0,  0.16786D0,  0.18802D0,  0.20008D0,
56582      &     0.21063D0,  0.21075D0,  0.20506D0,  0.19327D0,  0.17856D0,
56583      &     0.16274D0,  0.14648D0,  0.13048D0,  0.11526D0,  0.10099D0,
56584      &     0.08766D0,  0.07551D0,  0.06448D0,  0.05458D0,  0.04583D0,
56585      &     0.03816D0,  0.03137D0,  0.02550D0,  0.02064D0,  0.01641D0,
56586      &     0.01285D0,  0.00997D0,  0.00756D0,  0.00412D0,  0.00204D0,
56587      &     0.00089D0,  0.00032D0,  0.00001D0,  0.00000D0/
56588       DATA (FMRS(2,2,I,38),I=1,49)/
56589      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56590      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56591      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56592      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56593      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56594      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56595      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56596      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56597      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56598      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56599       DATA (FMRS(2,3,I, 1),I=1,49)/
56600      &     2.49594D0,  2.59678D0,  2.70121D0,  2.76381D0,  2.80882D0,
56601      &     2.84400D0,  2.95410D0,  3.06293D0,  3.12376D0,  3.16433D0,
56602      &     3.19612D0,  3.26381D0,  3.24185D0,  3.15396D0,  3.04339D0,
56603      &     2.92461D0,  2.68378D0,  2.34265D0,  1.85814D0,  1.47710D0,
56604      &     0.96403D0,  0.68739D0,  0.56164D0,  0.53053D0,  0.57114D0,
56605      &     0.63752D0,  0.70266D0,  0.75190D0,  0.77864D0,  0.78165D0,
56606      &     0.76223D0,  0.72410D0,  0.67143D0,  0.60861D0,  0.54010D0,
56607      &     0.46946D0,  0.39966D0,  0.33340D0,  0.27271D0,  0.21796D0,
56608      &     0.17035D0,  0.13022D0,  0.09678D0,  0.04919D0,  0.02174D0,
56609      &     0.00799D0,  0.00226D0,  0.00004D0,  0.00000D0/
56610       DATA (FMRS(2,3,I, 2),I=1,49)/
56611      &     4.92533D0,  4.79050D0,  4.65910D0,  4.58370D0,  4.53079D0,
56612      &     4.49006D0,  4.36491D0,  4.24084D0,  4.16793D0,  4.11560D0,
56613      &     4.07957D0,  3.94076D0,  3.72768D0,  3.53640D0,  3.35786D0,
56614      &     3.19001D0,  2.88282D0,  2.48367D0,  1.95213D0,  1.55132D0,
56615      &     1.02835D0,  0.75268D0,  0.62744D0,  0.59181D0,  0.62218D0,
56616      &     0.67462D0,  0.72413D0,  0.75779D0,  0.77032D0,  0.76124D0,
56617      &     0.73236D0,  0.68747D0,  0.63069D0,  0.56612D0,  0.49789D0,
56618      &     0.42912D0,  0.36239D0,  0.29993D0,  0.24354D0,  0.19324D0,
56619      &     0.14994D0,  0.11382D0,  0.08400D0,  0.04209D0,  0.01833D0,
56620      &     0.00664D0,  0.00185D0,  0.00003D0,  0.00000D0/
56621       DATA (FMRS(2,3,I, 3),I=1,49)/
56622      &     9.56993D0,  8.80858D0,  8.10702D0,  7.72221D0,  7.45989D0,
56623      &     7.26226D0,  6.67868D0,  6.13604D0,  5.83460D0,  5.62657D0,
56624      &     5.47187D0,  4.98498D0,  4.45878D0,  4.10350D0,  3.81920D0,
56625      &     3.57625D0,  3.16921D0,  2.68460D0,  2.08542D0,  1.65674D0,
56626      &     1.11953D0,  0.84374D0,  0.71690D0,  0.67195D0,  0.68567D0,
56627      &     0.71718D0,  0.74433D0,  0.75653D0,  0.75014D0,  0.72558D0,
56628      &     0.68509D0,  0.63243D0,  0.57149D0,  0.50592D0,  0.43925D0,
56629      &     0.37400D0,  0.31223D0,  0.25550D0,  0.20529D0,  0.16120D0,
56630      &     0.12380D0,  0.09303D0,  0.06796D0,  0.03337D0,  0.01425D0,
56631      &     0.00506D0,  0.00138D0,  0.00002D0,  0.00000D0/
56632       DATA (FMRS(2,3,I, 4),I=1,49)/
56633      &    13.80940D0, 12.36505D0, 11.07010D0, 10.37511D0,  9.90777D0,
56634      &     9.55916D0,  8.54772D0,  7.63175D0,  7.13319D0,  6.79336D0,
56635      &     6.53831D0,  5.76591D0,  4.99154D0,  4.51033D0,  4.14636D0,
56636      &     3.84778D0,  3.36791D0,  2.82235D0,  2.17611D0,  1.72845D0,
56637      &     1.18134D0,  0.90432D0,  0.77478D0,  0.72147D0,  0.72239D0,
56638      &     0.73883D0,  0.75059D0,  0.74861D0,  0.73014D0,  0.69610D0,
56639      &     0.64889D0,  0.59216D0,  0.52949D0,  0.46423D0,  0.39938D0,
56640      &     0.33717D0,  0.27919D0,  0.22665D0,  0.18078D0,  0.14088D0,
56641      &     0.10742D0,  0.08015D0,  0.05814D0,  0.02814D0,  0.01185D0,
56642      &     0.00415D0,  0.00112D0,  0.00002D0,  0.00000D0/
56643       DATA (FMRS(2,3,I, 5),I=1,49)/
56644      &    18.88911D0, 16.54105D0, 14.48190D0, 13.39606D0, 12.67388D0,
56645      &    12.13950D0, 10.61083D0,  9.25560D0,  8.52999D0,  8.04031D0,
56646      &     7.67199D0,  6.58349D0,  5.54112D0,  4.92668D0,  4.47939D0,
56647      &     4.12305D0,  3.56848D0,  2.96102D0,  2.26733D0,  1.80038D0,
56648      &     1.24179D0,  0.96142D0,  0.82726D0,  0.76409D0,  0.75165D0,
56649      &     0.75317D0,  0.75022D0,  0.73504D0,  0.70570D0,  0.66340D0,
56650      &     0.61066D0,  0.55093D0,  0.48745D0,  0.42321D0,  0.36077D0,
56651      &     0.30193D0,  0.24792D0,  0.19962D0,  0.15797D0,  0.12220D0,
56652      &     0.09245D0,  0.06850D0,  0.04934D0,  0.02353D0,  0.00976D0,
56653      &     0.00337D0,  0.00090D0,  0.00002D0,  0.00000D0/
56654       DATA (FMRS(2,3,I, 6),I=1,49)/
56655      &    24.17862D0, 20.81157D0, 17.90894D0, 16.39907D0, 15.40344D0,
56656      &    14.67132D0, 12.59987D0, 10.79385D0,  9.83948D0,  9.20057D0,
56657      &     8.72036D0,  7.32519D0,  6.02998D0,  5.29291D0,  4.77007D0,
56658      &     4.36196D0,  3.74120D0,  3.07968D0,  2.34504D0,  1.86151D0,
56659      &     1.29269D0,  1.00884D0,  0.87005D0,  0.79769D0,  0.77342D0,
56660      &     0.76224D0,  0.74721D0,  0.72151D0,  0.68376D0,  0.63535D0,
56661      &     0.57871D0,  0.51714D0,  0.45352D0,  0.39051D0,  0.33033D0,
56662      &     0.27444D0,  0.22374D0,  0.17892D0,  0.14065D0,  0.10811D0,
56663      &     0.08127D0,  0.05985D0,  0.04284D0,  0.02018D0,  0.00827D0,
56664      &     0.00283D0,  0.00075D0,  0.00001D0,  0.00000D0/
56665       DATA (FMRS(2,3,I, 7),I=1,49)/
56666      &    29.73861D0, 25.23818D0, 21.41267D0, 19.44500D0, 18.15658D0,
56667      &    17.21404D0, 14.57125D0, 12.29875D0, 11.11092D0, 10.32111D0,
56668      &     9.72854D0,  8.02926D0,  6.48794D0,  5.63342D0,  5.03891D0,
56669      &     4.58210D0,  3.89945D0,  3.18799D0,  2.41570D0,  1.91680D0,
56670      &     1.33767D0,  1.04936D0,  0.90523D0,  0.82366D0,  0.78841D0,
56671      &     0.76591D0,  0.74039D0,  0.70578D0,  0.66114D0,  0.60793D0,
56672      &     0.54844D0,  0.48585D0,  0.42265D0,  0.36114D0,  0.30329D0,
56673      &     0.25030D0,  0.20271D0,  0.16106D0,  0.12587D0,  0.09616D0,
56674      &     0.07187D0,  0.05262D0,  0.03744D0,  0.01745D0,  0.00707D0,
56675      &     0.00239D0,  0.00063D0,  0.00001D0,  0.00000D0/
56676       DATA (FMRS(2,3,I, 8),I=1,49)/
56677      &    36.41777D0, 30.48425D0, 25.50925D0, 22.97827D0, 21.33235D0,
56678      &    20.13434D0, 16.80486D0, 13.98059D0, 12.52029D0, 11.55588D0,
56679      &    10.83420D0,  8.78991D0,  6.97511D0,  5.99232D0,  5.32046D0,
56680      &     4.81154D0,  4.06330D0,  3.29938D0,  2.48793D0,  1.97297D0,
56681      &     1.38262D0,  1.08896D0,  0.93866D0,  0.84707D0,  0.80034D0,
56682      &     0.76640D0,  0.73057D0,  0.68748D0,  0.63647D0,  0.57905D0,
56683      &     0.51730D0,  0.45416D0,  0.39180D0,  0.33216D0,  0.27689D0,
56684      &     0.22693D0,  0.18251D0,  0.14405D0,  0.11189D0,  0.08494D0,
56685      &     0.06310D0,  0.04592D0,  0.03248D0,  0.01496D0,  0.00600D0,
56686      &     0.00201D0,  0.00052D0,  0.00001D0,  0.00000D0/
56687       DATA (FMRS(2,3,I, 9),I=1,49)/
56688      &    42.89913D0, 35.51439D0, 29.39055D0, 26.30256D0, 24.30551D0,
56689      &    22.85784D0, 18.86316D0, 15.51177D0, 13.79420D0, 12.66617D0,
56690      &    11.82423D0,  9.46212D0,  7.39982D0,  6.30264D0,  5.56252D0,
56691      &     5.00794D0,  4.20275D0,  3.39360D0,  2.54868D0,  2.01994D0,
56692      &     1.41958D0,  1.12075D0,  0.96469D0,  0.86425D0,  0.80777D0,
56693      &     0.76439D0,  0.72030D0,  0.67061D0,  0.61480D0,  0.55436D0,
56694      &     0.49120D0,  0.42796D0,  0.36659D0,  0.30874D0,  0.25576D0,
56695      &     0.20835D0,  0.16660D0,  0.13075D0,  0.10101D0,  0.07629D0,
56696      &     0.05637D0,  0.04082D0,  0.02872D0,  0.01310D0,  0.00521D0,
56697      &     0.00173D0,  0.00045D0,  0.00001D0,  0.00000D0/
56698       DATA (FMRS(2,3,I,10),I=1,49)/
56699      &    49.61974D0, 40.67585D0, 33.33157D0, 29.65726D0, 27.29273D0,
56700      &    25.58490D0, 20.90223D0, 17.01226D0, 15.03449D0, 13.74211D0,
56701      &    12.78005D0, 10.10345D0,  7.80003D0,  6.59295D0,  5.78776D0,
56702      &     5.18997D0,  4.33113D0,  3.47979D0,  2.60379D0,  2.06215D0,
56703      &     1.45191D0,  1.14765D0,  0.98577D0,  0.87686D0,  0.81144D0,
56704      &     0.75966D0,  0.70838D0,  0.65310D0,  0.59339D0,  0.53065D0,
56705      &     0.46666D0,  0.40372D0,  0.34354D0,  0.28753D0,  0.23679D0,
56706      &     0.19183D0,  0.15254D0,  0.11910D0,  0.09155D0,  0.06880D0,
56707      &     0.05059D0,  0.03647D0,  0.02554D0,  0.01155D0,  0.00456D0,
56708      &     0.00150D0,  0.00039D0,  0.00001D0,  0.00000D0/
56709       DATA (FMRS(2,3,I,11),I=1,49)/
56710      &    55.39180D0, 45.07076D0, 36.65840D0, 32.47479D0, 29.79258D0,
56711      &    27.86062D0, 22.58892D0, 18.24235D0, 16.04583D0, 14.61602D0,
56712      &    13.55394D0, 10.61757D0,  8.11747D0,  6.82180D0,  5.96451D0,
56713      &     5.33234D0,  4.43100D0,  3.54652D0,  2.64619D0,  2.09446D0,
56714      &     1.47626D0,  1.16746D0,  1.00084D0,  0.88523D0,  0.81292D0,
56715      &     0.75482D0,  0.69824D0,  0.63893D0,  0.57653D0,  0.51229D0,
56716      &     0.44790D0,  0.38538D0,  0.32625D0,  0.27173D0,  0.22275D0,
56717      &     0.17969D0,  0.14226D0,  0.11063D0,  0.08472D0,  0.06341D0,
56718      &     0.04647D0,  0.03337D0,  0.02328D0,  0.01046D0,  0.00410D0,
56719      &     0.00135D0,  0.00035D0,  0.00001D0,  0.00000D0/
56720       DATA (FMRS(2,3,I,12),I=1,49)/
56721      &    68.81419D0, 55.16745D0, 44.20809D0, 38.82247D0, 35.39534D0,
56722      &    32.94036D0, 26.30577D0, 20.91710D0, 18.22705D0, 16.48958D0,
56723      &    15.20488D0, 11.69679D0,  8.77186D0,  7.28789D0,  6.32113D0,
56724      &     5.61724D0,  4.62839D0,  3.67636D0,  2.72714D0,  2.15522D0,
56725      &     1.52072D0,  1.20219D0,  1.02548D0,  0.89610D0,  0.81011D0,
56726      &     0.73981D0,  0.67337D0,  0.60686D0,  0.53995D0,  0.47362D0,
56727      &     0.40911D0,  0.34808D0,  0.29158D0,  0.24046D0,  0.19523D0,
56728      &     0.15609D0,  0.12251D0,  0.09445D0,  0.07178D0,  0.05329D0,
56729      &     0.03875D0,  0.02763D0,  0.01914D0,  0.00848D0,  0.00328D0,
56730      &     0.00107D0,  0.00027D0,  0.00001D0,  0.00000D0/
56731       DATA (FMRS(2,3,I,13),I=1,49)/
56732      &    81.72071D0, 64.73620D0, 51.25830D0, 44.69851D0, 40.54929D0,
56733      &    37.59021D0, 29.65526D0, 23.28836D0, 20.14139D0, 18.12166D0,
56734      &    16.63424D0, 12.61228D0,  9.31401D0,  7.66787D0,  6.60816D0,
56735      &     5.84402D0,  4.78269D0,  3.77556D0,  2.78721D0,  2.19932D0,
56736      &     1.55169D0,  1.22492D0,  1.03973D0,  0.89912D0,  0.80240D0,
56737      &     0.72291D0,  0.64937D0,  0.57800D0,  0.50838D0,  0.44121D0,
56738      &     0.37732D0,  0.31807D0,  0.26412D0,  0.21603D0,  0.17402D0,
56739      &     0.13809D0,  0.10760D0,  0.08235D0,  0.06220D0,  0.04588D0,
56740      &     0.03314D0,  0.02349D0,  0.01618D0,  0.00709D0,  0.00272D0,
56741      &     0.00088D0,  0.00022D0,  0.00001D0,  0.00000D0/
56742       DATA (FMRS(2,3,I,14),I=1,49)/
56743      &    97.52657D0, 76.29261D0, 59.65305D0, 51.63612D0, 46.59734D0,
56744      &    43.02061D0, 33.50751D0, 25.97167D0, 22.28590D0, 19.93624D0,
56745      &    18.21366D0, 13.60275D0,  9.88582D0,  8.06142D0,  6.90102D0,
56746      &     6.07241D0,  4.93443D0,  3.87015D0,  2.84210D0,  2.23830D0,
56747      &     1.57740D0,  1.24193D0,  1.04776D0,  0.89562D0,  0.78827D0,
56748      &     0.70003D0,  0.62012D0,  0.54473D0,  0.47326D0,  0.40608D0,
56749      &     0.34362D0,  0.28678D0,  0.23589D0,  0.19121D0,  0.15279D0,
56750      &     0.12024D0,  0.09296D0,  0.07060D0,  0.05295D0,  0.03880D0,
56751      &     0.02782D0,  0.01961D0,  0.01341D0,  0.00581D0,  0.00221D0,
56752      &     0.00071D0,  0.00018D0,  0.00000D0,  0.00000D0/
56753       DATA (FMRS(2,3,I,15),I=1,49)/
56754      &   115.42858D0, 89.21046D0, 68.91241D0, 59.22810D0, 53.17852D0,
56755      &    48.90368D0, 37.62299D0, 28.79719D0, 24.52433D0, 21.81818D0,
56756      &    19.84305D0, 14.60749D0, 10.45530D0,  8.44881D0,  7.18665D0,
56757      &     6.29326D0,  5.07912D0,  3.95881D0,  2.89174D0,  2.27205D0,
56758      &     1.59726D0,  1.25251D0,  1.04935D0,  0.88634D0,  0.76946D0,
56759      &     0.67380D0,  0.58880D0,  0.51059D0,  0.43833D0,  0.37190D0,
56760      &     0.31141D0,  0.25732D0,  0.20974D0,  0.16850D0,  0.13349D0,
56761      &     0.10422D0,  0.07994D0,  0.06028D0,  0.04489D0,  0.03267D0,
56762      &     0.02328D0,  0.01630D0,  0.01109D0,  0.00475D0,  0.00179D0,
56763      &     0.00057D0,  0.00015D0,  0.00000D0,  0.00000D0/
56764       DATA (FMRS(2,3,I,16),I=1,49)/
56765      &   133.20726D0,101.88441D0, 77.88580D0, 66.53202D0, 59.47687D0,
56766      &    54.51081D0, 41.49468D0, 31.41946D0, 26.58451D0, 23.53963D0,
56767      &    21.32609D0, 15.50695D0, 10.95547D0,  8.78473D0,  7.43186D0,
56768      &     6.48132D0,  5.20052D0,  4.03146D0,  2.93090D0,  2.29753D0,
56769      &     1.61041D0,  1.25744D0,  1.04659D0,  0.87462D0,  0.75027D0,
56770      &     0.64906D0,  0.56054D0,  0.48074D0,  0.40844D0,  0.34317D0,
56771      &     0.28476D0,  0.23329D0,  0.18860D0,  0.15037D0,  0.11827D0,
56772      &     0.09171D0,  0.06985D0,  0.05235D0,  0.03876D0,  0.02805D0,
56773      &     0.01988D0,  0.01385D0,  0.00937D0,  0.00398D0,  0.00150D0,
56774      &     0.00048D0,  0.00012D0,  0.00000D0,  0.00000D0/
56775       DATA (FMRS(2,3,I,17),I=1,49)/
56776      &   152.75288D0,115.66533D0, 87.53463D0, 74.33386D0, 66.17272D0,
56777      &    60.44971D0, 45.54741D0, 34.13087D0, 28.69873D0, 25.29647D0,
56778      &    22.83273D0, 16.40709D0, 11.44748D0,  9.11138D0,  7.66812D0,
56779      &     6.66113D0,  5.31487D0,  4.09842D0,  2.96558D0,  2.31899D0,
56780      &     1.61977D0,  1.25878D0,  1.04063D0,  0.86046D0,  0.72956D0,
56781      &     0.62377D0,  0.53260D0,  0.45191D0,  0.38010D0,  0.31636D0,
56782      &     0.26019D0,  0.21141D0,  0.16955D0,  0.13419D0,  0.10481D0,
56783      &     0.08073D0,  0.06109D0,  0.04550D0,  0.03350D0,  0.02411D0,
56784      &     0.01700D0,  0.01178D0,  0.00794D0,  0.00335D0,  0.00125D0,
56785      &     0.00040D0,  0.00010D0,  0.00000D0,  0.00000D0/
56786       DATA (FMRS(2,3,I,18),I=1,49)/
56787      &   170.01192D0,127.71370D0, 95.88535D0, 81.04548D0, 71.90795D0,
56788      &    65.51928D0, 48.96956D0, 36.39437D0, 30.45131D0, 26.74517D0,
56789      &    24.06967D0, 17.13549D0, 11.83889D0,  9.36824D0,  7.85201D0,
56790      &     6.79985D0,  5.40144D0,  4.14772D0,  2.98965D0,  2.33267D0,
56791      &     1.62383D0,  1.25653D0,  1.03280D0,  0.84662D0,  0.71111D0,
56792      &     0.60235D0,  0.50969D0,  0.42880D0,  0.35778D0,  0.29558D0,
56793      &     0.24138D0,  0.19483D0,  0.15529D0,  0.12217D0,  0.09488D0,
56794      &     0.07271D0,  0.05474D0,  0.04057D0,  0.02974D0,  0.02131D0,
56795      &     0.01497D0,  0.01034D0,  0.00694D0,  0.00291D0,  0.00108D0,
56796      &     0.00035D0,  0.00009D0,  0.00000D0,  0.00000D0/
56797       DATA (FMRS(2,3,I,19),I=1,49)/
56798      &   192.21783D0,143.06714D0,106.42301D0, 89.46533D0, 79.07272D0,
56799      &    71.83153D0, 53.18588D0, 39.15232D0, 32.57201D0, 28.48916D0,
56800      &    25.55252D0, 17.99626D0, 12.29353D0,  9.66291D0,  8.06074D0,
56801      &     6.95556D0,  5.49677D0,  4.20023D0,  3.01333D0,  2.34451D0,
56802      &     1.62470D0,  1.25025D0,  1.02039D0,  0.82787D0,  0.68779D0,
56803      &     0.57628D0,  0.48256D0,  0.40194D0,  0.33226D0,  0.27214D0,
56804      &     0.22041D0,  0.17653D0,  0.13970D0,  0.10915D0,  0.08422D0,
56805      &     0.06416D0,  0.04803D0,  0.03538D0,  0.02582D0,  0.01841D0,
56806      &     0.01287D0,  0.00885D0,  0.00592D0,  0.00247D0,  0.00092D0,
56807      &     0.00029D0,  0.00008D0,  0.00000D0,  0.00000D0/
56808       DATA (FMRS(2,3,I,20),I=1,49)/
56809      &   213.34880D0,157.54303D0,116.26574D0, 97.28644D0, 85.70139D0,
56810      &    77.65329D0, 57.03621D0, 41.64487D0, 34.47643D0, 30.04790D0,
56811      &    26.87277D0, 18.75275D0, 12.68704D0,  9.91527D0,  8.23788D0,
56812      &     7.08656D0,  5.57571D0,  4.24254D0,  3.03117D0,  2.35234D0,
56813      &     1.62325D0,  1.24282D0,  1.00799D0,  0.81051D0,  0.66705D0,
56814      &     0.55370D0,  0.45951D0,  0.37948D0,  0.31121D0,  0.25302D0,
56815      &     0.20347D0,  0.16190D0,  0.12732D0,  0.09891D0,  0.07590D0,
56816      &     0.05752D0,  0.04285D0,  0.03141D0,  0.02283D0,  0.01621D0,
56817      &     0.01129D0,  0.00774D0,  0.00517D0,  0.00215D0,  0.00079D0,
56818      &     0.00025D0,  0.00007D0,  0.00000D0,  0.00000D0/
56819       DATA (FMRS(2,3,I,21),I=1,49)/
56820      &   233.39284D0,171.15466D0,125.43786D0,104.53514D0, 91.82097D0,
56821      &    83.01126D0, 60.54451D0, 43.89167D0, 36.18145D0, 31.43626D0,
56822      &    28.04374D0, 19.41375D0, 13.02433D0, 10.12820D0,  8.38525D0,
56823      &     7.19405D0,  5.63853D0,  4.27419D0,  3.04230D0,  2.35510D0,
56824      &     1.61821D0,  1.23292D0,  0.99418D0,  0.79299D0,  0.64721D0,
56825      &     0.53284D0,  0.43872D0,  0.35966D0,  0.29291D0,  0.23658D0,
56826      &     0.18910D0,  0.14961D0,  0.11702D0,  0.09045D0,  0.06907D0,
56827      &     0.05212D0,  0.03865D0,  0.02823D0,  0.02044D0,  0.01446D0,
56828      &     0.01004D0,  0.00687D0,  0.00457D0,  0.00189D0,  0.00070D0,
56829      &     0.00022D0,  0.00006D0,  0.00000D0,  0.00000D0/
56830       DATA (FMRS(2,3,I,22),I=1,49)/
56831      &   260.44016D0,189.36696D0,137.60457D0,114.10131D0, 99.86725D0,
56832      &    90.03576D0, 65.10178D0, 46.78208D0, 38.36169D0, 33.20363D0,
56833      &    29.52871D0, 20.24143D0, 13.44020D0, 10.38777D0,  8.56307D0,
56834      &     7.32250D0,  5.71195D0,  4.30962D0,  3.05294D0,  2.35572D0,
56835      &     1.60960D0,  1.21865D0,  0.97551D0,  0.77034D0,  0.62226D0,
56836      &     0.50716D0,  0.41356D0,  0.33596D0,  0.27128D0,  0.21734D0,
56837      &     0.17244D0,  0.13547D0,  0.10527D0,  0.08085D0,  0.06139D0,
56838      &     0.04607D0,  0.03398D0,  0.02471D0,  0.01781D0,  0.01255D0,
56839      &     0.00868D0,  0.00593D0,  0.00393D0,  0.00162D0,  0.00060D0,
56840      &     0.00019D0,  0.00005D0,  0.00000D0,  0.00000D0/
56841       DATA (FMRS(2,3,I,23),I=1,49)/
56842      &   287.44696D0,207.38838D0,149.53354D0,123.42919D0,107.68206D0,
56843      &    96.83708D0, 69.47065D0, 49.52397D0, 40.41636D0, 34.86102D0,
56844      &    30.91543D0, 21.00356D0, 13.81644D0, 10.61949D0,  8.71986D0,
56845      &     7.43441D0,  5.77408D0,  4.33783D0,  3.05923D0,  2.35324D0,
56846      &     1.59919D0,  1.20346D0,  0.95679D0,  0.74861D0,  0.59903D0,
56847      &     0.48379D0,  0.39106D0,  0.31505D0,  0.25241D0,  0.20076D0,
56848      &     0.15822D0,  0.12352D0,  0.09541D0,  0.07286D0,  0.05504D0,
56849      &     0.04110D0,  0.03018D0,  0.02185D0,  0.01570D0,  0.01103D0,
56850      &     0.00760D0,  0.00518D0,  0.00342D0,  0.00141D0,  0.00052D0,
56851      &     0.00017D0,  0.00004D0,  0.00000D0,  0.00000D0/
56852       DATA (FMRS(2,3,I,24),I=1,49)/
56853      &   313.51825D0,224.63136D0,160.84229D0,132.22295D0,115.01953D0,
56854      &   103.20245D0, 73.51698D0, 52.03463D0, 42.28400D0, 36.35911D0,
56855      &    32.16307D0, 21.67765D0, 14.14149D0, 10.81558D0,  8.84983D0,
56856      &     7.52509D0,  5.82169D0,  4.35654D0,  3.05952D0,  2.34629D0,
56857      &     1.58590D0,  1.18656D0,  0.93734D0,  0.72724D0,  0.57702D0,
56858      &     0.46218D0,  0.37070D0,  0.29646D0,  0.23590D0,  0.18642D0,
56859      &     0.14603D0,  0.11337D0,  0.08712D0,  0.06621D0,  0.04979D0,
56860      &     0.03702D0,  0.02708D0,  0.01953D0,  0.01399D0,  0.00980D0,
56861      &     0.00674D0,  0.00458D0,  0.00302D0,  0.00124D0,  0.00046D0,
56862      &     0.00015D0,  0.00004D0,  0.00000D0,  0.00000D0/
56863       DATA (FMRS(2,3,I,25),I=1,49)/
56864      &   341.15173D0,242.77290D0,172.65150D0,141.36496D0,122.62321D0,
56865      &   109.78229D0, 77.66644D0, 54.58787D0, 44.17350D0, 37.86890D0,
56866      &    33.41642D0, 22.34751D0, 14.46016D0, 11.00588D0,  8.97477D0,
56867      &     7.61137D0,  5.86592D0,  4.37273D0,  3.05810D0,  2.33803D0,
56868      &     1.57177D0,  1.16920D0,  0.91780D0,  0.70620D0,  0.55570D0,
56869      &     0.44154D0,  0.35145D0,  0.27905D0,  0.22057D0,  0.17322D0,
56870      &     0.13490D0,  0.10417D0,  0.07964D0,  0.06025D0,  0.04510D0,
56871      &     0.03340D0,  0.02434D0,  0.01749D0,  0.01249D0,  0.00873D0,
56872      &     0.00599D0,  0.00406D0,  0.00268D0,  0.00110D0,  0.00041D0,
56873      &     0.00013D0,  0.00004D0,  0.00000D0,  0.00000D0/
56874       DATA (FMRS(2,3,I,26),I=1,49)/
56875      &   368.98822D0,260.90195D0,184.35516D0,150.38000D0,130.09390D0,
56876      &   116.22827D0, 81.69344D0, 57.04021D0, 45.97627D0, 39.30195D0,
56877      &    34.60083D0, 22.97047D0, 14.74975D0, 11.17543D0,  9.08370D0,
56878      &     7.68467D0,  5.90104D0,  4.38251D0,  3.05244D0,  2.32659D0,
56879      &     1.55551D0,  1.15047D0,  0.89759D0,  0.68521D0,  0.53495D0,
56880      &     0.42187D0,  0.33342D0,  0.26295D0,  0.20656D0,  0.16128D0,
56881      &     0.12493D0,  0.09597D0,  0.07303D0,  0.05500D0,  0.04100D0,
56882      &     0.03027D0,  0.02198D0,  0.01575D0,  0.01122D0,  0.00782D0,
56883      &     0.00536D0,  0.00363D0,  0.00239D0,  0.00098D0,  0.00036D0,
56884      &     0.00012D0,  0.00003D0,  0.00000D0,  0.00000D0/
56885       DATA (FMRS(2,3,I,27),I=1,49)/
56886      &   396.49847D0,278.69458D0,195.76036D0,159.12776D0,137.32101D0,
56887      &   122.44904D0, 85.54959D0, 59.36906D0, 47.67925D0, 40.65031D0,
56888      &    35.71157D0, 23.54779D0, 15.01388D0, 11.32784D0,  9.18018D0,
56889      &     7.74858D0,  5.93008D0,  4.38884D0,  3.04508D0,  2.31422D0,
56890      &     1.53913D0,  1.13220D0,  0.87829D0,  0.66558D0,  0.51586D0,
56891      &     0.40401D0,  0.31721D0,  0.24862D0,  0.19419D0,  0.15083D0,
56892      &     0.11625D0,  0.08889D0,  0.06736D0,  0.05053D0,  0.03753D0,
56893      &     0.02761D0,  0.01999D0,  0.01428D0,  0.01015D0,  0.00707D0,
56894      &     0.00483D0,  0.00327D0,  0.00215D0,  0.00088D0,  0.00033D0,
56895      &     0.00011D0,  0.00003D0,  0.00000D0,  0.00000D0/
56896       DATA (FMRS(2,3,I,28),I=1,49)/
56897      &   423.18488D0,295.83777D0,206.67247D0,167.46211D0,144.18538D0,
56898      &   128.34305D0, 89.17443D0, 61.53922D0, 49.25727D0, 41.89430D0,
56899      &    36.73269D0, 24.07136D0, 15.24876D0, 11.46075D0,  9.26257D0,
56900      &     7.80186D0,  5.95221D0,  4.39115D0,  3.03561D0,  2.30059D0,
56901      &     1.52239D0,  1.11417D0,  0.85969D0,  0.64709D0,  0.49822D0,
56902      &     0.38776D0,  0.30261D0,  0.23584D0,  0.18326D0,  0.14166D0,
56903      &     0.10869D0,  0.08277D0,  0.06247D0,  0.04670D0,  0.03458D0,
56904      &     0.02536D0,  0.01831D0,  0.01305D0,  0.00927D0,  0.00644D0,
56905      &     0.00439D0,  0.00297D0,  0.00195D0,  0.00080D0,  0.00030D0,
56906      &     0.00010D0,  0.00003D0,  0.00000D0,  0.00000D0/
56907       DATA (FMRS(2,3,I,29),I=1,49)/
56908      &   450.92862D0,313.54996D0,217.87523D0,175.98549D0,151.18591D0,
56909      &   134.34097D0, 92.83694D0, 63.71518D0, 50.83173D0, 43.13081D0,
56910      &    37.74429D0, 24.58404D0, 15.47489D0, 11.58672D0,  9.33925D0,
56911      &     7.85026D0,  5.97071D0,  4.39081D0,  3.02434D0,  2.28559D0,
56912      &     1.50481D0,  1.09565D0,  0.84093D0,  0.62877D0,  0.48096D0,
56913      &     0.37201D0,  0.28863D0,  0.22371D0,  0.17297D0,  0.13307D0,
56914      &     0.10166D0,  0.07711D0,  0.05798D0,  0.04320D0,  0.03189D0,
56915      &     0.02332D0,  0.01680D0,  0.01195D0,  0.00847D0,  0.00587D0,
56916      &     0.00400D0,  0.00270D0,  0.00178D0,  0.00073D0,  0.00027D0,
56917      &     0.00009D0,  0.00002D0,  0.00000D0,  0.00000D0/
56918       DATA (FMRS(2,3,I,30),I=1,49)/
56919      &   478.88074D0,331.28183D0,229.01660D0,184.42841D0,158.10007D0,
56920      &   140.25114D0, 96.41853D0, 65.82523D0, 52.35015D0, 44.31818D0,
56921      &    38.71195D0, 25.06767D0, 15.68364D0, 11.70050D0,  9.40671D0,
56922      &     7.89123D0,  5.98412D0,  4.38708D0,  3.01099D0,  2.26914D0,
56923      &     1.48646D0,  1.07684D0,  0.82225D0,  0.61085D0,  0.46437D0,
56924      &     0.35704D0,  0.27550D0,  0.21242D0,  0.16347D0,  0.12519D0,
56925      &     0.09525D0,  0.07197D0,  0.05394D0,  0.04005D0,  0.02949D0,
56926      &     0.02151D0,  0.01546D0,  0.01097D0,  0.00776D0,  0.00538D0,
56927      &     0.00366D0,  0.00247D0,  0.00162D0,  0.00067D0,  0.00025D0,
56928      &     0.00008D0,  0.00002D0,  0.00000D0,  0.00000D0/
56929       DATA (FMRS(2,3,I,31),I=1,49)/
56930      &   506.38092D0,348.62979D0,239.85460D0,192.61319D0,164.78622D0,
56931      &   145.95520D0, 99.85363D0, 67.83522D0, 53.79026D0, 45.44058D0,
56932      &    39.62410D0, 25.51892D0, 15.87554D0, 11.80362D0,  9.46678D0,
56933      &     7.92687D0,  5.99445D0,  4.38186D0,  2.99723D0,  2.25276D0,
56934      &     1.46868D0,  1.05889D0,  0.80464D0,  0.59419D0,  0.44909D0,
56935      &     0.34338D0,  0.26361D0,  0.20228D0,  0.15498D0,  0.11820D0,
56936      &     0.08960D0,  0.06746D0,  0.05040D0,  0.03731D0,  0.02741D0,
56937      &     0.01994D0,  0.01431D0,  0.01014D0,  0.00716D0,  0.00495D0,
56938      &     0.00337D0,  0.00227D0,  0.00149D0,  0.00061D0,  0.00023D0,
56939      &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
56940       DATA (FMRS(2,3,I,32),I=1,49)/
56941      &   532.71063D0,365.14023D0,250.10423D0,200.32385D0,171.06720D0,
56942      &   151.30153D0,103.04897D0, 69.68893D0, 55.11074D0, 46.46502D0,
56943      &    40.45333D0, 25.92270D0, 16.04272D0, 11.89083D0,  9.51556D0,
56944      &     7.95409D0,  5.99947D0,  4.37358D0,  2.98195D0,  2.23557D0,
56945      &     1.45083D0,  1.04132D0,  0.78773D0,  0.57848D0,  0.43489D0,
56946      &     0.33086D0,  0.25280D0,  0.19316D0,  0.14738D0,  0.11200D0,
56947      &     0.08461D0,  0.06352D0,  0.04732D0,  0.03494D0,  0.02560D0,
56948      &     0.01860D0,  0.01332D0,  0.00942D0,  0.00665D0,  0.00459D0,
56949      &     0.00312D0,  0.00210D0,  0.00138D0,  0.00057D0,  0.00021D0,
56950      &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
56951       DATA (FMRS(2,3,I,33),I=1,49)/
56952      &   560.44952D0,382.45715D0,260.80753D0,208.35481D0,177.59706D0,
56953      &   156.85155D0,106.35128D0, 71.59602D0, 56.46558D0, 47.51407D0,
56954      &    41.30114D0, 26.33344D0, 16.21190D0, 11.97881D0,  9.56466D0,
56955      &     7.98144D0,  6.00450D0,  4.36531D0,  2.96673D0,  2.21850D0,
56956      &     1.43317D0,  1.02401D0,  0.77116D0,  0.56317D0,  0.42112D0,
56957      &     0.31878D0,  0.24243D0,  0.18443D0,  0.14015D0,  0.10612D0,
56958      &     0.07989D0,  0.05980D0,  0.04442D0,  0.03272D0,  0.02392D0,
56959      &     0.01734D0,  0.01239D0,  0.00875D0,  0.00617D0,  0.00426D0,
56960      &     0.00289D0,  0.00195D0,  0.00128D0,  0.00052D0,  0.00020D0,
56961      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
56962       DATA (FMRS(2,3,I,34),I=1,49)/
56963      &   587.66711D0,399.34082D0,271.17145D0,216.09799D0,183.87283D0,
56964      &   162.17198D0,109.48943D0, 73.38959D0, 57.73061D0, 48.48780D0,
56965      &    42.08379D0, 26.70440D0, 16.35846D0, 12.05124D0,  9.60203D0,
56966      &     7.99942D0,  6.00308D0,  4.35260D0,  2.94870D0,  2.19937D0,
56967      &     1.41431D0,  1.00609D0,  0.75435D0,  0.54797D0,  0.40769D0,
56968      &     0.30718D0,  0.23257D0,  0.17622D0,  0.13341D0,  0.10068D0,
56969      &     0.07556D0,  0.05639D0,  0.04179D0,  0.03071D0,  0.02240D0,
56970      &     0.01621D0,  0.01157D0,  0.00816D0,  0.00575D0,  0.00396D0,
56971      &     0.00269D0,  0.00181D0,  0.00119D0,  0.00049D0,  0.00018D0,
56972      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
56973       DATA (FMRS(2,3,I,35),I=1,49)/
56974      &   614.66376D0,416.01791D0,281.36646D0,223.69629D0,190.02084D0,
56975      &   167.37685D0,112.54659D0, 75.12943D0, 58.95456D0, 49.42817D0,
56976      &    42.83852D0, 27.06040D0, 16.49837D0, 12.12015D0,  9.63748D0,
56977      &     8.01641D0,  6.00168D0,  4.34055D0,  2.93168D0,  2.18137D0,
56978      &     1.39666D0,  0.98938D0,  0.73876D0,  0.53395D0,  0.39535D0,
56979      &     0.29658D0,  0.22360D0,  0.16878D0,  0.12732D0,  0.09577D0,
56980      &     0.07167D0,  0.05334D0,  0.03944D0,  0.02892D0,  0.02106D0,
56981      &     0.01521D0,  0.01085D0,  0.00764D0,  0.00537D0,  0.00370D0,
56982      &     0.00251D0,  0.00169D0,  0.00111D0,  0.00046D0,  0.00017D0,
56983      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
56984       DATA (FMRS(2,3,I,36),I=1,49)/
56985      &   640.64490D0,431.98953D0,291.07977D0,230.91319D0,195.84616D0,
56986      &   172.29993D0,115.42027D0, 76.75350D0, 60.09168D0, 50.29848D0,
56987      &    43.53482D0, 27.38445D0, 16.62263D0, 12.17943D0,  9.66642D0,
56988      &     8.02868D0,  5.99763D0,  4.32731D0,  2.91439D0,  2.16350D0,
56989      &     1.37952D0,  0.97339D0,  0.72400D0,  0.52085D0,  0.38394D0,
56990      &     0.28684D0,  0.21543D0,  0.16204D0,  0.12184D0,  0.09139D0,
56991      &     0.06820D0,  0.05064D0,  0.03736D0,  0.02734D0,  0.01987D0,
56992      &     0.01434D0,  0.01021D0,  0.00718D0,  0.00505D0,  0.00348D0,
56993      &     0.00236D0,  0.00159D0,  0.00104D0,  0.00043D0,  0.00016D0,
56994      &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
56995       DATA (FMRS(2,3,I,37),I=1,49)/
56996      &   667.19971D0,448.23413D0,300.90906D0,238.19307D0,201.70891D0,
56997      &   177.24495D0,118.28902D0, 78.36304D0, 61.21302D0, 51.15329D0,
56998      &    44.21644D0, 27.69705D0, 16.73916D0, 12.23290D0,  9.69072D0,
56999      &     8.03703D0,  5.99069D0,  4.31202D0,  2.89571D0,  2.14460D0,
57000      &     1.36178D0,  0.95706D0,  0.70912D0,  0.50779D0,  0.37268D0,
57001      &     0.27731D0,  0.20750D0,  0.15552D0,  0.11658D0,  0.08719D0,
57002      &     0.06491D0,  0.04808D0,  0.03540D0,  0.02586D0,  0.01877D0,
57003      &     0.01352D0,  0.00961D0,  0.00676D0,  0.00475D0,  0.00327D0,
57004      &     0.00222D0,  0.00149D0,  0.00098D0,  0.00040D0,  0.00015D0,
57005      &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
57006       DATA (FMRS(2,3,I,38),I=1,49)/
57007      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57008      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57009      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57010      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57011      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57012      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57013      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57014      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57015      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57016      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57017       DATA (FMRS(2,4,I, 1),I=1,49)/
57018      &     0.96883D0,  0.83010D0,  0.71060D0,  0.64853D0,  0.60767D0,
57019      &     0.57770D0,  0.49346D0,  0.42161D0,  0.38501D0,  0.36146D0,
57020      &     0.34535D0,  0.30095D0,  0.26559D0,  0.24803D0,  0.23669D0,
57021      &     0.22831D0,  0.21597D0,  0.20255D0,  0.18524D0,  0.17029D0,
57022      &     0.14323D0,  0.11890D0,  0.09745D0,  0.07499D0,  0.05725D0,
57023      &     0.04365D0,  0.03351D0,  0.02602D0,  0.02043D0,  0.01653D0,
57024      &     0.01318D0,  0.01067D0,  0.00853D0,  0.00671D0,  0.00530D0,
57025      &     0.00405D0,  0.00296D0,  0.00217D0,  0.00162D0,  0.00103D0,
57026      &     0.00065D0,  0.00047D0,  0.00023D0,  0.00008D0,  0.00004D0,
57027      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57028       DATA (FMRS(2,4,I, 2),I=1,49)/
57029      &     0.97285D0,  0.83723D0,  0.71985D0,  0.65865D0,  0.61827D0,
57030      &     0.58859D0,  0.50491D0,  0.43319D0,  0.39649D0,  0.37279D0,
57031      &     0.35657D0,  0.31149D0,  0.27487D0,  0.25626D0,  0.24402D0,
57032      &     0.23487D0,  0.22125D0,  0.20637D0,  0.18739D0,  0.17135D0,
57033      &     0.14312D0,  0.11837D0,  0.09689D0,  0.07465D0,  0.05719D0,
57034      &     0.04386D0,  0.03391D0,  0.02652D0,  0.02098D0,  0.01703D0,
57035      &     0.01365D0,  0.01107D0,  0.00885D0,  0.00698D0,  0.00550D0,
57036      &     0.00421D0,  0.00309D0,  0.00226D0,  0.00169D0,  0.00108D0,
57037      &     0.00069D0,  0.00049D0,  0.00025D0,  0.00010D0,  0.00003D0,
57038      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
57039       DATA (FMRS(2,4,I, 3),I=1,49)/
57040      &     0.99630D0,  0.86193D0,  0.74498D0,  0.68373D0,  0.64319D0,
57041      &     0.61334D0,  0.52882D0,  0.45586D0,  0.41827D0,  0.39388D0,
57042      &     0.37707D0,  0.32984D0,  0.29034D0,  0.26968D0,  0.25582D0,
57043      &     0.24531D0,  0.22956D0,  0.21234D0,  0.19077D0,  0.17310D0,
57044      &     0.14315D0,  0.11778D0,  0.09624D0,  0.07426D0,  0.05716D0,
57045      &     0.04417D0,  0.03445D0,  0.02716D0,  0.02168D0,  0.01765D0,
57046      &     0.01422D0,  0.01151D0,  0.00919D0,  0.00726D0,  0.00569D0,
57047      &     0.00437D0,  0.00323D0,  0.00233D0,  0.00177D0,  0.00113D0,
57048      &     0.00072D0,  0.00052D0,  0.00028D0,  0.00011D0,  0.00003D0,
57049      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
57050       DATA (FMRS(2,4,I, 4),I=1,49)/
57051      &     1.02892D0,  0.89240D0,  0.77327D0,  0.71073D0,  0.66929D0,
57052      &     0.63873D0,  0.55202D0,  0.47687D0,  0.43798D0,  0.41263D0,
57053      &     0.39503D0,  0.34528D0,  0.30287D0,  0.28033D0,  0.26505D0,
57054      &     0.25342D0,  0.23594D0,  0.21688D0,  0.19336D0,  0.17449D0,
57055      &     0.14328D0,  0.11746D0,  0.09586D0,  0.07403D0,  0.05716D0,
57056      &     0.04437D0,  0.03479D0,  0.02755D0,  0.02207D0,  0.01800D0,
57057      &     0.01451D0,  0.01172D0,  0.00935D0,  0.00736D0,  0.00577D0,
57058      &     0.00444D0,  0.00328D0,  0.00236D0,  0.00178D0,  0.00114D0,
57059      &     0.00075D0,  0.00052D0,  0.00029D0,  0.00011D0,  0.00004D0,
57060      &     0.00003D0,  0.00000D0,  0.00000D0,  0.00000D0/
57061       DATA (FMRS(2,4,I, 5),I=1,49)/
57062      &     1.08451D0,  0.94133D0,  0.81630D0,  0.75061D0,  0.70706D0,
57063      &     0.67493D0,  0.58367D0,  0.50437D0,  0.46318D0,  0.43623D0,
57064      &     0.41737D0,  0.36373D0,  0.31732D0,  0.29240D0,  0.27539D0,
57065      &     0.26243D0,  0.24295D0,  0.22186D0,  0.19623D0,  0.17608D0,
57066      &     0.14355D0,  0.11725D0,  0.09556D0,  0.07384D0,  0.05715D0,
57067      &     0.04453D0,  0.03504D0,  0.02784D0,  0.02236D0,  0.01824D0,
57068      &     0.01470D0,  0.01187D0,  0.00949D0,  0.00742D0,  0.00580D0,
57069      &     0.00445D0,  0.00328D0,  0.00235D0,  0.00175D0,  0.00116D0,
57070      &     0.00074D0,  0.00053D0,  0.00029D0,  0.00011D0,  0.00004D0,
57071      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
57072       DATA (FMRS(2,4,I, 6),I=1,49)/
57073      &     1.14357D0,  0.99242D0,  0.86045D0,  0.79114D0,  0.74518D0,
57074      &     0.71127D0,  0.61492D0,  0.53108D0,  0.48742D0,  0.45878D0,
57075      &     0.43857D0,  0.38094D0,  0.33056D0,  0.30333D0,  0.28470D0,
57076      &     0.27048D0,  0.24918D0,  0.22626D0,  0.19875D0,  0.17749D0,
57077      &     0.14383D0,  0.11711D0,  0.09533D0,  0.07370D0,  0.05713D0,
57078      &     0.04464D0,  0.03521D0,  0.02805D0,  0.02256D0,  0.01839D0,
57079      &     0.01482D0,  0.01197D0,  0.00955D0,  0.00745D0,  0.00580D0,
57080      &     0.00443D0,  0.00326D0,  0.00233D0,  0.00174D0,  0.00116D0,
57081      &     0.00074D0,  0.00053D0,  0.00029D0,  0.00011D0,  0.00004D0,
57082      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
57083       DATA (FMRS(2,4,I, 7),I=1,49)/
57084      &     1.21691D0,  1.05450D0,  0.91294D0,  0.83868D0,  0.78948D0,
57085      &     0.75319D0,  0.65015D0,  0.56049D0,  0.51374D0,  0.48302D0,
57086      &     0.46120D0,  0.39885D0,  0.34401D0,  0.31429D0,  0.29395D0,
57087      &     0.27845D0,  0.25529D0,  0.23055D0,  0.20123D0,  0.17890D0,
57088      &     0.14416D0,  0.11703D0,  0.09514D0,  0.07357D0,  0.05711D0,
57089      &     0.04471D0,  0.03532D0,  0.02818D0,  0.02268D0,  0.01846D0,
57090      &     0.01487D0,  0.01199D0,  0.00952D0,  0.00742D0,  0.00577D0,
57091      &     0.00441D0,  0.00322D0,  0.00229D0,  0.00172D0,  0.00114D0,
57092      &     0.00072D0,  0.00051D0,  0.00029D0,  0.00010D0,  0.00004D0,
57093      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57094       DATA (FMRS(2,4,I, 8),I=1,49)/
57095      &     1.31000D0,  1.13230D0,  0.97784D0,  0.89699D0,  0.84348D0,
57096      &     0.80406D0,  0.69226D0,  0.59511D0,  0.54444D0,  0.51110D0,
57097      &     0.48726D0,  0.41913D0,  0.35898D0,  0.32638D0,  0.30408D0,
57098      &     0.28713D0,  0.26192D0,  0.23518D0,  0.20389D0,  0.18042D0,
57099      &     0.14454D0,  0.11697D0,  0.09497D0,  0.07342D0,  0.05705D0,
57100      &     0.04474D0,  0.03539D0,  0.02827D0,  0.02275D0,  0.01851D0,
57101      &     0.01488D0,  0.01197D0,  0.00947D0,  0.00737D0,  0.00571D0,
57102      &     0.00437D0,  0.00318D0,  0.00224D0,  0.00169D0,  0.00111D0,
57103      &     0.00070D0,  0.00049D0,  0.00029D0,  0.00010D0,  0.00004D0,
57104      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57105       DATA (FMRS(2,4,I, 9),I=1,49)/
57106      &     1.40457D0,  1.21051D0,  1.04237D0,  0.95458D0,  0.89657D0,
57107      &     0.85387D0,  0.73299D0,  0.62815D0,  0.57350D0,  0.53752D0,
57108      &     0.51167D0,  0.43783D0,  0.37258D0,  0.33726D0,  0.31316D0,
57109      &     0.29488D0,  0.26778D0,  0.23925D0,  0.20624D0,  0.18177D0,
57110      &     0.14489D0,  0.11694D0,  0.09483D0,  0.07330D0,  0.05698D0,
57111      &     0.04474D0,  0.03543D0,  0.02831D0,  0.02277D0,  0.01852D0,
57112      &     0.01487D0,  0.01192D0,  0.00942D0,  0.00732D0,  0.00564D0,
57113      &     0.00433D0,  0.00313D0,  0.00219D0,  0.00166D0,  0.00109D0,
57114      &     0.00068D0,  0.00049D0,  0.00028D0,  0.00010D0,  0.00003D0,
57115      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57116       DATA (FMRS(2,4,I,10),I=1,49)/
57117      &     1.51092D0,  1.29750D0,  1.11331D0,  1.01744D0,  0.95421D0,
57118      &     0.90772D0,  0.77643D0,  0.66288D0,  0.60378D0,  0.56488D0,
57119      &     0.53682D0,  0.45681D0,  0.38616D0,  0.34803D0,  0.32208D0,
57120      &     0.30246D0,  0.27350D0,  0.24321D0,  0.20851D0,  0.18308D0,
57121      &     0.14525D0,  0.11692D0,  0.09469D0,  0.07316D0,  0.05689D0,
57122      &     0.04470D0,  0.03541D0,  0.02828D0,  0.02274D0,  0.01846D0,
57123      &     0.01479D0,  0.01184D0,  0.00933D0,  0.00722D0,  0.00556D0,
57124      &     0.00426D0,  0.00307D0,  0.00215D0,  0.00161D0,  0.00106D0,
57125      &     0.00067D0,  0.00048D0,  0.00027D0,  0.00010D0,  0.00003D0,
57126      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57127       DATA (FMRS(2,4,I,11),I=1,49)/
57128      &     1.60472D0,  1.37368D0,  1.17498D0,  1.07183D0,  1.00391D0,
57129      &     0.95405D0,  0.81348D0,  0.69224D0,  0.62923D0,  0.58777D0,
57130      &     0.55781D0,  0.47247D0,  0.39725D0,  0.35677D0,  0.32928D0,
57131      &     0.30856D0,  0.27807D0,  0.24637D0,  0.21032D0,  0.18413D0,
57132      &     0.14554D0,  0.11692D0,  0.09459D0,  0.07304D0,  0.05681D0,
57133      &     0.04465D0,  0.03537D0,  0.02823D0,  0.02270D0,  0.01839D0,
57134      &     0.01471D0,  0.01176D0,  0.00923D0,  0.00712D0,  0.00549D0,
57135      &     0.00419D0,  0.00301D0,  0.00213D0,  0.00157D0,  0.00105D0,
57136      &     0.00065D0,  0.00047D0,  0.00027D0,  0.00010D0,  0.00004D0,
57137      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57138       DATA (FMRS(2,4,I,12),I=1,49)/
57139      &     1.83637D0,  1.55987D0,  1.32404D0,  1.20242D0,  1.12267D0,
57140      &     1.06429D0,  0.90056D0,  0.76032D0,  0.68777D0,  0.64012D0,
57141      &     0.60555D0,  0.50757D0,  0.42172D0,  0.37588D0,  0.34496D0,
57142      &     0.32177D0,  0.28792D0,  0.25312D0,  0.21417D0,  0.18636D0,
57143      &     0.14617D0,  0.11691D0,  0.09435D0,  0.07276D0,  0.05658D0,
57144      &     0.04447D0,  0.03521D0,  0.02807D0,  0.02254D0,  0.01819D0,
57145      &     0.01452D0,  0.01154D0,  0.00905D0,  0.00695D0,  0.00533D0,
57146      &     0.00404D0,  0.00292D0,  0.00205D0,  0.00149D0,  0.00100D0,
57147      &     0.00062D0,  0.00045D0,  0.00024D0,  0.00010D0,  0.00003D0,
57148      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57149       DATA (FMRS(2,4,I,13),I=1,49)/
57150      &     2.07152D0,  1.74663D0,  1.47172D0,  1.33085D0,  1.23884D0,
57151      &     1.17167D0,  0.98420D0,  0.82476D0,  0.74268D0,  0.68890D0,
57152      &     0.64981D0,  0.53955D0,  0.44363D0,  0.39281D0,  0.35874D0,
57153      &     0.33333D0,  0.29647D0,  0.25893D0,  0.21746D0,  0.18826D0,
57154      &     0.14670D0,  0.11688D0,  0.09412D0,  0.07248D0,  0.05632D0,
57155      &     0.04424D0,  0.03500D0,  0.02787D0,  0.02234D0,  0.01798D0,
57156      &     0.01431D0,  0.01132D0,  0.00886D0,  0.00679D0,  0.00517D0,
57157      &     0.00390D0,  0.00284D0,  0.00195D0,  0.00143D0,  0.00095D0,
57158      &     0.00059D0,  0.00043D0,  0.00023D0,  0.00009D0,  0.00002D0,
57159      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57160       DATA (FMRS(2,4,I,14),I=1,49)/
57161      &     2.37643D0,  1.98603D0,  1.65879D0,  1.49235D0,  1.38415D0,
57162      &     1.30543D0,  1.08702D0,  0.90288D0,  0.80867D0,  0.74716D0,
57163      &     0.70240D0,  0.57696D0,  0.46881D0,  0.41209D0,  0.37432D0,
57164      &     0.34632D0,  0.30599D0,  0.26535D0,  0.22106D0,  0.19032D0,
57165      &     0.14723D0,  0.11682D0,  0.09381D0,  0.07211D0,  0.05596D0,
57166      &     0.04392D0,  0.03471D0,  0.02757D0,  0.02204D0,  0.01767D0,
57167      &     0.01400D0,  0.01105D0,  0.00862D0,  0.00657D0,  0.00496D0,
57168      &     0.00374D0,  0.00270D0,  0.00182D0,  0.00137D0,  0.00090D0,
57169      &     0.00057D0,  0.00039D0,  0.00023D0,  0.00007D0,  0.00002D0,
57170      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57171       DATA (FMRS(2,4,I,15),I=1,49)/
57172      &     2.74566D0,  2.27231D0,  1.87960D0,  1.68150D0,  1.55338D0,
57173      &     1.46052D0,  1.20454D0,  0.99082D0,  0.88227D0,  0.81170D0,
57174      &     0.76034D0,  0.61745D0,  0.49560D0,  0.43237D0,  0.39059D0,
57175      &     0.35980D0,  0.31580D0,  0.27191D0,  0.22470D0,  0.19238D0,
57176      &     0.14774D0,  0.11669D0,  0.09344D0,  0.07165D0,  0.05549D0,
57177      &     0.04347D0,  0.03429D0,  0.02720D0,  0.02166D0,  0.01729D0,
57178      &     0.01366D0,  0.01073D0,  0.00832D0,  0.00636D0,  0.00476D0,
57179      &     0.00357D0,  0.00255D0,  0.00175D0,  0.00131D0,  0.00086D0,
57180      &     0.00052D0,  0.00037D0,  0.00021D0,  0.00007D0,  0.00002D0,
57181      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57182       DATA (FMRS(2,4,I,16),I=1,49)/
57183      &     3.12622D0,  2.56414D0,  2.10216D0,  1.87087D0,  1.72199D0,
57184      &     1.61445D0,  1.31978D0,  1.07596D0,  0.95298D0,  0.87335D0,
57185      &     0.81544D0,  0.65540D0,  0.52031D0,  0.45090D0,  0.40535D0,
57186      &     0.37197D0,  0.32458D0,  0.27772D0,  0.22787D0,  0.19414D0,
57187      &     0.14813D0,  0.11651D0,  0.09303D0,  0.07117D0,  0.05501D0,
57188      &     0.04302D0,  0.03385D0,  0.02678D0,  0.02128D0,  0.01692D0,
57189      &     0.01332D0,  0.01043D0,  0.00806D0,  0.00611D0,  0.00459D0,
57190      &     0.00341D0,  0.00242D0,  0.00166D0,  0.00123D0,  0.00082D0,
57191      &     0.00050D0,  0.00034D0,  0.00020D0,  0.00006D0,  0.00003D0,
57192      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57193       DATA (FMRS(2,4,I,17),I=1,49)/
57194      &     3.55799D0,  2.89188D0,  2.34954D0,  2.08007D0,  1.90742D0,
57195      &     1.78316D0,  1.44470D0,  1.16721D0,  1.02825D0,  0.93863D0,
57196      &     0.87356D0,  0.69490D0,  0.54567D0,  0.46976D0,  0.42028D0,
57197      &     0.38422D0,  0.33334D0,  0.28346D0,  0.23097D0,  0.19583D0,
57198      &     0.14845D0,  0.11627D0,  0.09257D0,  0.07063D0,  0.05448D0,
57199      &     0.04252D0,  0.03337D0,  0.02631D0,  0.02087D0,  0.01652D0,
57200      &     0.01297D0,  0.01012D0,  0.00778D0,  0.00585D0,  0.00440D0,
57201      &     0.00326D0,  0.00231D0,  0.00157D0,  0.00115D0,  0.00076D0,
57202      &     0.00047D0,  0.00031D0,  0.00019D0,  0.00006D0,  0.00003D0,
57203      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57204       DATA (FMRS(2,4,I,18),I=1,49)/
57205      &     3.95423D0,  3.18985D0,  2.57232D0,  2.26740D0,  2.07281D0,
57206      &     1.93314D0,  1.55464D0,  1.24668D0,  1.09337D0,  0.99486D0,
57207      &     0.92342D0,  0.72838D0,  0.56689D0,  0.48541D0,  0.43260D0,
57208      &     0.39429D0,  0.34049D0,  0.28810D0,  0.23344D0,  0.19715D0,
57209      &     0.14866D0,  0.11602D0,  0.09214D0,  0.07013D0,  0.05399D0,
57210      &     0.04205D0,  0.03295D0,  0.02591D0,  0.02050D0,  0.01618D0,
57211      &     0.01266D0,  0.00984D0,  0.00753D0,  0.00565D0,  0.00424D0,
57212      &     0.00314D0,  0.00221D0,  0.00150D0,  0.00109D0,  0.00072D0,
57213      &     0.00043D0,  0.00030D0,  0.00018D0,  0.00006D0,  0.00002D0,
57214      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57215       DATA (FMRS(2,4,I,19),I=1,49)/
57216      &     4.48113D0,  3.58253D0,  2.86323D0,  2.51070D0,  2.28676D0,
57217      &     2.12659D0,  1.69508D0,  1.34718D0,  1.17523D0,  1.06522D0,
57218      &     0.98559D0,  0.76963D0,  0.59272D0,  0.50431D0,  0.44739D0,
57219      &     0.40630D0,  0.34895D0,  0.29355D0,  0.23628D0,  0.19863D0,
57220      &     0.14882D0,  0.11566D0,  0.09156D0,  0.06947D0,  0.05334D0,
57221      &     0.04144D0,  0.03238D0,  0.02540D0,  0.02000D0,  0.01574D0,
57222      &     0.01227D0,  0.00950D0,  0.00724D0,  0.00541D0,  0.00404D0,
57223      &     0.00298D0,  0.00211D0,  0.00142D0,  0.00103D0,  0.00067D0,
57224      &     0.00041D0,  0.00028D0,  0.00016D0,  0.00006D0,  0.00002D0,
57225      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57226       DATA (FMRS(2,4,I,20),I=1,49)/
57227      &     4.99499D0,  3.96212D0,  3.14196D0,  2.74258D0,  2.48991D0,
57228      &     2.30973D0,  1.82681D0,  1.44056D0,  1.25085D0,  1.12995D0,
57229      &     1.04258D0,  0.80704D0,  0.61586D0,  0.52113D0,  0.46048D0,
57230      &     0.41689D0,  0.35636D0,  0.29827D0,  0.23871D0,  0.19986D0,
57231      &     0.14892D0,  0.11531D0,  0.09101D0,  0.06887D0,  0.05276D0,
57232      &     0.04087D0,  0.03186D0,  0.02494D0,  0.01954D0,  0.01534D0,
57233      &     0.01192D0,  0.00921D0,  0.00699D0,  0.00520D0,  0.00387D0,
57234      &     0.00284D0,  0.00201D0,  0.00135D0,  0.00099D0,  0.00063D0,
57235      &     0.00039D0,  0.00027D0,  0.00014D0,  0.00005D0,  0.00002D0,
57236      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57237       DATA (FMRS(2,4,I,21),I=1,49)/
57238      &     5.50061D0,  4.33261D0,  3.41176D0,  2.96594D0,  2.68491D0,
57239      &     2.48503D0,  1.95181D0,  1.52837D0,  1.32157D0,  1.19023D0,
57240      &     1.09549D0,  0.84140D0,  0.63686D0,  0.53627D0,  0.47219D0,
57241      &     0.42632D0,  0.36291D0,  0.30239D0,  0.24078D0,  0.20086D0,
57242      &     0.14892D0,  0.11489D0,  0.09045D0,  0.06826D0,  0.05215D0,
57243      &     0.04031D0,  0.03135D0,  0.02446D0,  0.01914D0,  0.01497D0,
57244      &     0.01162D0,  0.00892D0,  0.00678D0,  0.00502D0,  0.00373D0,
57245      &     0.00273D0,  0.00191D0,  0.00128D0,  0.00093D0,  0.00060D0,
57246      &     0.00037D0,  0.00026D0,  0.00014D0,  0.00005D0,  0.00001D0,
57247      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57248       DATA (FMRS(2,4,I,22),I=1,49)/
57249      &     6.19859D0,  4.83989D0,  3.77815D0,  3.26780D0,  2.94753D0,
57250      &     2.72049D0,  2.11828D0,  1.64429D0,  1.41443D0,  1.26909D0,
57251      &     1.16448D0,  0.88574D0,  0.66367D0,  0.55547D0,  0.48697D0,
57252      &     0.43816D0,  0.37106D0,  0.30748D0,  0.24329D0,  0.20204D0,
57253      &     0.14885D0,  0.11433D0,  0.08969D0,  0.06745D0,  0.05136D0,
57254      &     0.03959D0,  0.03069D0,  0.02386D0,  0.01861D0,  0.01451D0,
57255      &     0.01121D0,  0.00856D0,  0.00649D0,  0.00480D0,  0.00355D0,
57256      &     0.00258D0,  0.00180D0,  0.00120D0,  0.00087D0,  0.00057D0,
57257      &     0.00034D0,  0.00024D0,  0.00013D0,  0.00004D0,  0.00001D0,
57258      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57259       DATA (FMRS(2,4,I,23),I=1,49)/
57260      &     6.91462D0,  5.35579D0,  4.14753D0,  3.57056D0,  3.20996D0,
57261      &     2.95511D0,  2.28266D0,  1.75769D0,  1.50477D0,  1.34548D0,
57262      &     1.23109D0,  0.92809D0,  0.68898D0,  0.57345D0,  0.50073D0,
57263      &     0.44914D0,  0.37855D0,  0.31211D0,  0.24552D0,  0.20305D0,
57264      &     0.14871D0,  0.11376D0,  0.08894D0,  0.06666D0,  0.05060D0,
57265      &     0.03890D0,  0.03007D0,  0.02332D0,  0.01811D0,  0.01408D0,
57266      &     0.01081D0,  0.00824D0,  0.00620D0,  0.00458D0,  0.00337D0,
57267      &     0.00246D0,  0.00171D0,  0.00112D0,  0.00082D0,  0.00053D0,
57268      &     0.00032D0,  0.00022D0,  0.00013D0,  0.00004D0,  0.00001D0,
57269      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57270       DATA (FMRS(2,4,I,24),I=1,49)/
57271      &     7.62855D0,  5.86601D0,  4.50985D0,  3.86607D0,  3.46522D0,
57272      &     3.18268D0,  2.44073D0,  1.86575D0,  1.59038D0,  1.41758D0,
57273      &     1.29375D0,  0.96750D0,  0.71223D0,  0.58984D0,  0.51319D0,
57274      &     0.45902D0,  0.38523D0,  0.31616D0,  0.24739D0,  0.20383D0,
57275      &     0.14846D0,  0.11312D0,  0.08817D0,  0.06586D0,  0.04986D0,
57276      &     0.03821D0,  0.02946D0,  0.02275D0,  0.01763D0,  0.01365D0,
57277      &     0.01046D0,  0.00797D0,  0.00597D0,  0.00439D0,  0.00323D0,
57278      &     0.00235D0,  0.00162D0,  0.00107D0,  0.00078D0,  0.00051D0,
57279      &     0.00031D0,  0.00021D0,  0.00012D0,  0.00003D0,  0.00001D0,
57280      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57281       DATA (FMRS(2,4,I,25),I=1,49)/
57282      &     8.39955D0,  6.41302D0,  4.89545D0,  4.17923D0,  3.73489D0,
57283      &     3.42253D0,  2.60607D0,  1.97793D0,  1.67884D0,  1.49183D0,
57284      &     1.35810D0,  1.00761D0,  0.73567D0,  0.60627D0,  0.52562D0,
57285      &     0.46884D0,  0.39183D0,  0.32012D0,  0.24919D0,  0.20455D0,
57286      &     0.14818D0,  0.11246D0,  0.08739D0,  0.06506D0,  0.04911D0,
57287      &     0.03752D0,  0.02885D0,  0.02220D0,  0.01716D0,  0.01324D0,
57288      &     0.01012D0,  0.00771D0,  0.00575D0,  0.00422D0,  0.00309D0,
57289      &     0.00225D0,  0.00154D0,  0.00103D0,  0.00074D0,  0.00048D0,
57290      &     0.00030D0,  0.00020D0,  0.00010D0,  0.00002D0,  0.00001D0,
57291      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57292       DATA (FMRS(2,4,I,26),I=1,49)/
57293      &     9.19737D0,  6.97494D0,  5.28863D0,  4.49714D0,  4.00779D0,
57294      &     3.66466D0,  2.77170D0,  2.08938D0,  1.76629D0,  1.56497D0,
57295      &     1.42130D0,  1.04661D0,  0.75821D0,  0.62194D0,  0.53740D0,
57296      &     0.47810D0,  0.39797D0,  0.32376D0,  0.25078D0,  0.20510D0,
57297      &     0.14782D0,  0.11174D0,  0.08657D0,  0.06424D0,  0.04835D0,
57298      &     0.03684D0,  0.02824D0,  0.02168D0,  0.01670D0,  0.01284D0,
57299      &     0.00977D0,  0.00742D0,  0.00552D0,  0.00404D0,  0.00296D0,
57300      &     0.00214D0,  0.00146D0,  0.00097D0,  0.00071D0,  0.00044D0,
57301      &     0.00028D0,  0.00017D0,  0.00010D0,  0.00003D0,  0.00001D0,
57302      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57303       DATA (FMRS(2,4,I,27),I=1,49)/
57304      &    10.00116D0,  7.53729D0,  5.67949D0,  4.81192D0,  4.27724D0,
57305      &     3.90320D0,  2.93374D0,  2.19765D0,  1.85088D0,  1.63549D0,
57306      &     1.48207D0,  1.08380D0,  0.77950D0,  0.63664D0,  0.54841D0,
57307      &     0.48671D0,  0.40364D0,  0.32707D0,  0.25218D0,  0.20556D0,
57308      &     0.14742D0,  0.11104D0,  0.08576D0,  0.06344D0,  0.04762D0,
57309      &     0.03619D0,  0.02766D0,  0.02119D0,  0.01627D0,  0.01248D0,
57310      &     0.00947D0,  0.00716D0,  0.00532D0,  0.00389D0,  0.00284D0,
57311      &     0.00205D0,  0.00139D0,  0.00092D0,  0.00068D0,  0.00042D0,
57312      &     0.00026D0,  0.00016D0,  0.00009D0,  0.00003D0,  0.00001D0,
57313      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57314       DATA (FMRS(2,4,I,28),I=1,49)/
57315      &    10.79744D0,  8.09092D0,  6.06186D0,  5.11871D0,  4.53915D0,
57316      &     4.13458D0,  3.08987D0,  2.30126D0,  1.93148D0,  1.70248D0,
57317      &     1.53966D0,  1.11875D0,  0.79931D0,  0.65024D0,  0.55853D0,
57318      &     0.49459D0,  0.40879D0,  0.33003D0,  0.25337D0,  0.20589D0,
57319      &     0.14698D0,  0.11033D0,  0.08498D0,  0.06267D0,  0.04691D0,
57320      &     0.03557D0,  0.02711D0,  0.02071D0,  0.01586D0,  0.01214D0,
57321      &     0.00920D0,  0.00692D0,  0.00514D0,  0.00376D0,  0.00272D0,
57322      &     0.00196D0,  0.00133D0,  0.00087D0,  0.00064D0,  0.00040D0,
57323      &     0.00025D0,  0.00016D0,  0.00009D0,  0.00003D0,  0.00001D0,
57324      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57325       DATA (FMRS(2,4,I,29),I=1,49)/
57326      &    11.63983D0,  8.67317D0,  6.46161D0,  5.43834D0,  4.81133D0,
57327      &     4.37457D0,  3.25082D0,  2.40738D0,  2.01373D0,  1.77063D0,
57328      &     1.59811D0,  1.15395D0,  0.81909D0,  0.66374D0,  0.56853D0,
57329      &     0.50235D0,  0.41381D0,  0.33288D0,  0.25448D0,  0.20616D0,
57330      &     0.14650D0,  0.10959D0,  0.08417D0,  0.06189D0,  0.04620D0,
57331      &     0.03495D0,  0.02656D0,  0.02024D0,  0.01545D0,  0.01181D0,
57332      &     0.00893D0,  0.00670D0,  0.00496D0,  0.00362D0,  0.00261D0,
57333      &     0.00187D0,  0.00127D0,  0.00083D0,  0.00060D0,  0.00038D0,
57334      &     0.00023D0,  0.00015D0,  0.00008D0,  0.00003D0,  0.00001D0,
57335      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57336       DATA (FMRS(2,4,I,30),I=1,49)/
57337      &    12.50504D0,  9.26774D0,  6.86743D0,  5.76168D0,  5.08599D0,
57338      &     4.61626D0,  3.41191D0,  2.51292D0,  2.09519D0,  1.83795D0,
57339      &     1.65570D0,  1.18836D0,  0.83825D0,  0.67674D0,  0.57810D0,
57340      &     0.50972D0,  0.41855D0,  0.33552D0,  0.25546D0,  0.20633D0,
57341      &     0.14597D0,  0.10882D0,  0.08334D0,  0.06111D0,  0.04550D0,
57342      &     0.03432D0,  0.02602D0,  0.01977D0,  0.01507D0,  0.01148D0,
57343      &     0.00865D0,  0.00649D0,  0.00478D0,  0.00347D0,  0.00250D0,
57344      &     0.00177D0,  0.00121D0,  0.00078D0,  0.00056D0,  0.00036D0,
57345      &     0.00022D0,  0.00014D0,  0.00008D0,  0.00002D0,  0.00001D0,
57346      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57347       DATA (FMRS(2,4,I,31),I=1,49)/
57348      &    13.36928D0,  9.85846D0,  7.26844D0,  6.08018D0,  5.35592D0,
57349      &     4.85338D0,  3.56907D0,  2.61529D0,  2.17393D0,  1.90285D0,
57350      &     1.71111D0,  1.22123D0,  0.85642D0,  0.68899D0,  0.58709D0,
57351      &     0.51663D0,  0.42295D0,  0.33794D0,  0.25632D0,  0.20644D0,
57352      &     0.14544D0,  0.10808D0,  0.08256D0,  0.06036D0,  0.04483D0,
57353      &     0.03373D0,  0.02551D0,  0.01933D0,  0.01470D0,  0.01117D0,
57354      &     0.00840D0,  0.00629D0,  0.00462D0,  0.00334D0,  0.00240D0,
57355      &     0.00170D0,  0.00116D0,  0.00075D0,  0.00053D0,  0.00034D0,
57356      &     0.00021D0,  0.00014D0,  0.00007D0,  0.00002D0,  0.00001D0,
57357      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57358       DATA (FMRS(2,4,I,32),I=1,49)/
57359      &    14.21204D0, 10.43149D0,  7.65538D0,  6.38652D0,  5.61495D0,
57360      &     5.08051D0,  3.71876D0,  2.71221D0,  2.24821D0,  1.96390D0,
57361      &     1.76311D0,  1.25185D0,  0.87317D0,  0.70020D0,  0.59526D0,
57362      &     0.52288D0,  0.42687D0,  0.34005D0,  0.25702D0,  0.20645D0,
57363      &     0.14487D0,  0.10733D0,  0.08179D0,  0.05963D0,  0.04417D0,
57364      &     0.03317D0,  0.02503D0,  0.01893D0,  0.01436D0,  0.01089D0,
57365      &     0.00816D0,  0.00610D0,  0.00447D0,  0.00322D0,  0.00232D0,
57366      &     0.00164D0,  0.00111D0,  0.00072D0,  0.00051D0,  0.00033D0,
57367      &     0.00020D0,  0.00013D0,  0.00007D0,  0.00002D0,  0.00001D0,
57368      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57369       DATA (FMRS(2,4,I,33),I=1,49)/
57370      &    15.10980D0, 11.03912D0,  8.06381D0,  6.70901D0,  5.88712D0,
57371      &     5.31881D0,  3.87508D0,  2.81294D0,  2.32519D0,  2.02704D0,
57372      &     1.81681D0,  1.28330D0,  0.89029D0,  0.71163D0,  0.60357D0,
57373      &     0.52922D0,  0.43085D0,  0.34218D0,  0.25771D0,  0.20646D0,
57374      &     0.14430D0,  0.10659D0,  0.08103D0,  0.05890D0,  0.04353D0,
57375      &     0.03261D0,  0.02455D0,  0.01854D0,  0.01403D0,  0.01061D0,
57376      &     0.00794D0,  0.00591D0,  0.00432D0,  0.00310D0,  0.00224D0,
57377      &     0.00159D0,  0.00107D0,  0.00069D0,  0.00049D0,  0.00032D0,
57378      &     0.00019D0,  0.00012D0,  0.00006D0,  0.00002D0,  0.00001D0,
57379      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57380       DATA (FMRS(2,4,I,34),I=1,49)/
57381      &    16.00814D0, 11.64399D0,  8.46821D0,  7.02730D0,  6.15513D0,
57382      &     5.55303D0,  4.02783D0,  2.91076D0,  2.39965D0,  2.08793D0,
57383      &     1.86846D0,  1.31328D0,  0.90643D0,  0.72231D0,  0.61128D0,
57384      &     0.53505D0,  0.43443D0,  0.34403D0,  0.25822D0,  0.20634D0,
57385      &     0.14366D0,  0.10580D0,  0.08022D0,  0.05817D0,  0.04288D0,
57386      &     0.03206D0,  0.02408D0,  0.01814D0,  0.01369D0,  0.01034D0,
57387      &     0.00771D0,  0.00572D0,  0.00418D0,  0.00300D0,  0.00216D0,
57388      &     0.00152D0,  0.00103D0,  0.00065D0,  0.00048D0,  0.00031D0,
57389      &     0.00018D0,  0.00012D0,  0.00006D0,  0.00002D0,  0.00001D0,
57390      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57391       DATA (FMRS(2,4,I,35),I=1,49)/
57392      &    16.90871D0, 12.24779D0,  8.87019D0,  7.34290D0,  6.42039D0,
57393      &     5.78454D0,  4.17816D0,  3.00661D0,  2.47242D0,  2.14733D0,
57394      &     1.91876D0,  1.34235D0,  0.92199D0,  0.73258D0,  0.61867D0,
57395      &     0.54063D0,  0.43786D0,  0.34580D0,  0.25870D0,  0.20622D0,
57396      &     0.14305D0,  0.10506D0,  0.07947D0,  0.05749D0,  0.04228D0,
57397      &     0.03154D0,  0.02364D0,  0.01777D0,  0.01338D0,  0.01009D0,
57398      &     0.00750D0,  0.00555D0,  0.00406D0,  0.00290D0,  0.00208D0,
57399      &     0.00145D0,  0.00100D0,  0.00062D0,  0.00047D0,  0.00030D0,
57400      &     0.00017D0,  0.00012D0,  0.00005D0,  0.00002D0,  0.00000D0,
57401      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57402       DATA (FMRS(2,4,I,36),I=1,49)/
57403      &    17.78739D0, 12.83436D0,  9.25897D0,  7.64732D0,  6.67578D0,
57404      &     6.00710D0,  4.32199D0,  3.09786D0,  2.54148D0,  2.20357D0,
57405      &     1.96631D0,  1.36964D0,  0.93649D0,  0.74208D0,  0.62547D0,
57406      &     0.54573D0,  0.44096D0,  0.34736D0,  0.25907D0,  0.20605D0,
57407      &     0.14244D0,  0.10433D0,  0.07874D0,  0.05683D0,  0.04170D0,
57408      &     0.03105D0,  0.02321D0,  0.01741D0,  0.01309D0,  0.00985D0,
57409      &     0.00731D0,  0.00540D0,  0.00394D0,  0.00282D0,  0.00201D0,
57410      &     0.00140D0,  0.00096D0,  0.00060D0,  0.00045D0,  0.00029D0,
57411      &     0.00016D0,  0.00012D0,  0.00005D0,  0.00001D0,  0.00000D0,
57412      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57413       DATA (FMRS(2,4,I,37),I=1,49)/
57414      &    18.69798D0, 13.43965D0,  9.65843D0,  7.95932D0,  6.93703D0,
57415      &     6.23444D0,  4.46823D0,  3.19019D0,  2.61115D0,  2.26017D0,
57416      &     2.01407D0,  1.39688D0,  0.95084D0,  0.75143D0,  0.63213D0,
57417      &     0.55070D0,  0.44393D0,  0.34881D0,  0.25937D0,  0.20581D0,
57418      &     0.14178D0,  0.10356D0,  0.07799D0,  0.05614D0,  0.04110D0,
57419      &     0.03053D0,  0.02278D0,  0.01705D0,  0.01280D0,  0.00961D0,
57420      &     0.00713D0,  0.00525D0,  0.00382D0,  0.00273D0,  0.00195D0,
57421      &     0.00136D0,  0.00092D0,  0.00058D0,  0.00043D0,  0.00028D0,
57422      &     0.00015D0,  0.00011D0,  0.00005D0,  0.00001D0,  0.00000D0,
57423      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57424       DATA (FMRS(2,4,I,38),I=1,49)/
57425      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57426      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57427      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57428      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57429      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57430      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57431      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57432      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57433      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57434      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57435       DATA (FMRS(2,5,I, 1),I=1,49)/
57436      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57437      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57438      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57439      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57440      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57441      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57442      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57443      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57444      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57445      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57446       DATA (FMRS(2,5,I, 2),I=1,49)/
57447      &     0.00003D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
57448      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
57449      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
57450      &     0.00002D0,  0.00002D0,  0.00001D0,  0.00001D0,  0.00001D0,
57451      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
57452      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
57453      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
57454      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57455      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57456      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57457       DATA (FMRS(2,5,I, 3),I=1,49)/
57458      &     0.02821D0,  0.02609D0,  0.02411D0,  0.02301D0,  0.02226D0,
57459      &     0.02169D0,  0.01996D0,  0.01827D0,  0.01727D0,  0.01654D0,
57460      &     0.01595D0,  0.01400D0,  0.01174D0,  0.01027D0,  0.00917D0,
57461      &     0.00829D0,  0.00696D0,  0.00558D0,  0.00415D0,  0.00329D0,
57462      &     0.00239D0,  0.00200D0,  0.00182D0,  0.00170D0,  0.00161D0,
57463      &     0.00151D0,  0.00140D0,  0.00127D0,  0.00113D0,  0.00099D0,
57464      &     0.00084D0,  0.00071D0,  0.00058D0,  0.00047D0,  0.00038D0,
57465      &     0.00029D0,  0.00023D0,  0.00017D0,  0.00013D0,  0.00009D0,
57466      &     0.00006D0,  0.00004D0,  0.00003D0,  0.00001D0,  0.00000D0,
57467      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57468       DATA (FMRS(2,5,I, 4),I=1,49)/
57469      &     0.07423D0,  0.06794D0,  0.06215D0,  0.05896D0,  0.05679D0,
57470      &     0.05514D0,  0.05023D0,  0.04550D0,  0.04276D0,  0.04079D0,
57471      &     0.03919D0,  0.03404D0,  0.02827D0,  0.02460D0,  0.02188D0,
57472      &     0.01974D0,  0.01650D0,  0.01320D0,  0.00980D0,  0.00778D0,
57473      &     0.00567D0,  0.00475D0,  0.00430D0,  0.00399D0,  0.00376D0,
57474      &     0.00351D0,  0.00322D0,  0.00290D0,  0.00256D0,  0.00223D0,
57475      &     0.00189D0,  0.00158D0,  0.00129D0,  0.00104D0,  0.00083D0,
57476      &     0.00064D0,  0.00049D0,  0.00037D0,  0.00027D0,  0.00020D0,
57477      &     0.00014D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00000D0,
57478      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57479       DATA (FMRS(2,5,I, 5),I=1,49)/
57480      &     0.13335D0,  0.12014D0,  0.10818D0,  0.10170D0,  0.09731D0,
57481      &     0.09401D0,  0.08430D0,  0.07519D0,  0.07001D0,  0.06635D0,
57482      &     0.06344D0,  0.05426D0,  0.04442D0,  0.03837D0,  0.03396D0,
57483      &     0.03053D0,  0.02541D0,  0.02025D0,  0.01501D0,  0.01192D0,
57484      &     0.00870D0,  0.00726D0,  0.00654D0,  0.00602D0,  0.00561D0,
57485      &     0.00519D0,  0.00472D0,  0.00422D0,  0.00370D0,  0.00319D0,
57486      &     0.00269D0,  0.00224D0,  0.00183D0,  0.00146D0,  0.00116D0,
57487      &     0.00089D0,  0.00068D0,  0.00051D0,  0.00038D0,  0.00027D0,
57488      &     0.00019D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00000D0,
57489      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57490       DATA (FMRS(2,5,I, 6),I=1,49)/
57491      &     0.20163D0,  0.17920D0,  0.15918D0,  0.14846D0,  0.14125D0,
57492      &     0.13587D0,  0.12018D0,  0.10574D0,  0.09768D0,  0.09205D0,
57493      &     0.08763D0,  0.07395D0,  0.05979D0,  0.05130D0,  0.04521D0,
57494      &     0.04052D0,  0.03360D0,  0.02669D0,  0.01976D0,  0.01569D0,
57495      &     0.01145D0,  0.00954D0,  0.00855D0,  0.00780D0,  0.00720D0,
57496      &     0.00661D0,  0.00597D0,  0.00530D0,  0.00461D0,  0.00396D0,
57497      &     0.00333D0,  0.00275D0,  0.00223D0,  0.00178D0,  0.00140D0,
57498      &     0.00108D0,  0.00082D0,  0.00061D0,  0.00045D0,  0.00032D0,
57499      &     0.00022D0,  0.00015D0,  0.00010D0,  0.00003D0,  0.00000D0,
57500      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57501       DATA (FMRS(2,5,I, 7),I=1,49)/
57502      &     0.27774D0,  0.24395D0,  0.21415D0,  0.19835D0,  0.18780D0,
57503      &     0.17996D0,  0.15730D0,  0.13677D0,  0.12547D0,  0.11766D0,
57504      &     0.11157D0,  0.09303D0,  0.07437D0,  0.06341D0,  0.05566D0,
57505      &     0.04974D0,  0.04109D0,  0.03255D0,  0.02405D0,  0.01909D0,
57506      &     0.01394D0,  0.01158D0,  0.01033D0,  0.00936D0,  0.00857D0,
57507      &     0.00780D0,  0.00699D0,  0.00616D0,  0.00533D0,  0.00455D0,
57508      &     0.00380D0,  0.00313D0,  0.00253D0,  0.00201D0,  0.00157D0,
57509      &     0.00121D0,  0.00091D0,  0.00068D0,  0.00050D0,  0.00036D0,
57510      &     0.00024D0,  0.00016D0,  0.00011D0,  0.00003D0,  0.00000D0,
57511      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57512       DATA (FMRS(2,5,I, 8),I=1,49)/
57513      &     0.37644D0,  0.32674D0,  0.28346D0,  0.26073D0,  0.24565D0,
57514      &     0.23449D0,  0.20256D0,  0.17404D0,  0.15854D0,  0.14793D0,
57515      &     0.13972D0,  0.11511D0,  0.09095D0,  0.07707D0,  0.06738D0,
57516      &     0.06004D0,  0.04941D0,  0.03901D0,  0.02877D0,  0.02283D0,
57517      &     0.01667D0,  0.01381D0,  0.01226D0,  0.01101D0,  0.01000D0,
57518      &     0.00902D0,  0.00803D0,  0.00703D0,  0.00604D0,  0.00513D0,
57519      &     0.00426D0,  0.00349D0,  0.00280D0,  0.00222D0,  0.00173D0,
57520      &     0.00132D0,  0.00099D0,  0.00074D0,  0.00054D0,  0.00039D0,
57521      &     0.00026D0,  0.00017D0,  0.00011D0,  0.00003D0,  0.00000D0,
57522      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57523       DATA (FMRS(2,5,I, 9),I=1,49)/
57524      &     0.47784D0,  0.41072D0,  0.35284D0,  0.32270D0,  0.30279D0,
57525      &     0.28813D0,  0.24646D0,  0.20968D0,  0.18991D0,  0.17647D0,
57526      &     0.16612D0,  0.13548D0,  0.10603D0,  0.08938D0,  0.07787D0,
57527      &     0.06921D0,  0.05678D0,  0.04472D0,  0.03292D0,  0.02612D0,
57528      &     0.01906D0,  0.01575D0,  0.01392D0,  0.01241D0,  0.01119D0,
57529      &     0.01003D0,  0.00887D0,  0.00772D0,  0.00660D0,  0.00557D0,
57530      &     0.00461D0,  0.00376D0,  0.00301D0,  0.00237D0,  0.00184D0,
57531      &     0.00140D0,  0.00105D0,  0.00077D0,  0.00057D0,  0.00041D0,
57532      &     0.00027D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
57533      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57534       DATA (FMRS(2,5,I,10),I=1,49)/
57535      &     0.58781D0,  0.50078D0,  0.42641D0,  0.38796D0,  0.36269D0,
57536      &     0.34414D0,  0.29176D0,  0.24601D0,  0.22164D0,  0.20518D0,
57537      &     0.19257D0,  0.15561D0,  0.12070D0,  0.10126D0,  0.08794D0,
57538      &     0.07799D0,  0.06379D0,  0.05011D0,  0.03684D0,  0.02922D0,
57539      &     0.02130D0,  0.01755D0,  0.01544D0,  0.01368D0,  0.01225D0,
57540      &     0.01090D0,  0.00959D0,  0.00830D0,  0.00706D0,  0.00594D0,
57541      &     0.00489D0,  0.00397D0,  0.00316D0,  0.00248D0,  0.00192D0,
57542      &     0.00146D0,  0.00109D0,  0.00080D0,  0.00059D0,  0.00042D0,
57543      &     0.00027D0,  0.00018D0,  0.00012D0,  0.00003D0,  0.00000D0,
57544      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57545       DATA (FMRS(2,5,I,11),I=1,49)/
57546      &     0.68602D0,  0.58051D0,  0.49095D0,  0.44491D0,  0.41476D0,
57547      &     0.39269D0,  0.33066D0,  0.27690D0,  0.24847D0,  0.22936D0,
57548      &     0.21477D0,  0.17232D0,  0.13275D0,  0.11095D0,  0.09613D0,
57549      &     0.08510D0,  0.06944D0,  0.05445D0,  0.03997D0,  0.03169D0,
57550      &     0.02308D0,  0.01898D0,  0.01663D0,  0.01466D0,  0.01306D0,
57551      &     0.01157D0,  0.01013D0,  0.00872D0,  0.00740D0,  0.00620D0,
57552      &     0.00508D0,  0.00411D0,  0.00327D0,  0.00256D0,  0.00197D0,
57553      &     0.00149D0,  0.00111D0,  0.00081D0,  0.00060D0,  0.00042D0,
57554      &     0.00028D0,  0.00018D0,  0.00012D0,  0.00003D0,  0.00000D0,
57555      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57556       DATA (FMRS(2,5,I,12),I=1,49)/
57557      &     0.92772D0,  0.77438D0,  0.64603D0,  0.58078D0,  0.53835D0,
57558      &     0.50746D0,  0.42147D0,  0.34811D0,  0.30983D0,  0.28433D0,
57559      &     0.26501D0,  0.20960D0,  0.15924D0,  0.13208D0,  0.11385D0,
57560      &     0.10043D0,  0.08155D0,  0.06370D0,  0.04663D0,  0.03692D0,
57561      &     0.02683D0,  0.02195D0,  0.01909D0,  0.01665D0,  0.01467D0,
57562      &     0.01287D0,  0.01115D0,  0.00952D0,  0.00801D0,  0.00666D0,
57563      &     0.00542D0,  0.00436D0,  0.00344D0,  0.00268D0,  0.00205D0,
57564      &     0.00155D0,  0.00115D0,  0.00083D0,  0.00061D0,  0.00043D0,
57565      &     0.00028D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
57566      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57567       DATA (FMRS(2,5,I,13),I=1,49)/
57568      &     1.17595D0,  0.97076D0,  0.80093D0,  0.71538D0,  0.66007D0,
57569      &     0.61997D0,  0.50921D0,  0.41588D0,  0.36771D0,  0.33586D0,
57570      &     0.31184D0,  0.24377D0,  0.18310D0,  0.15092D0,  0.12956D0,
57571      &     0.11394D0,  0.09216D0,  0.07174D0,  0.05238D0,  0.04143D0,
57572      &     0.03003D0,  0.02446D0,  0.02114D0,  0.01827D0,  0.01595D0,
57573      &     0.01387D0,  0.01193D0,  0.01011D0,  0.00845D0,  0.00698D0,
57574      &     0.00565D0,  0.00451D0,  0.00355D0,  0.00275D0,  0.00209D0,
57575      &     0.00157D0,  0.00116D0,  0.00084D0,  0.00061D0,  0.00043D0,
57576      &     0.00028D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
57577      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57578       DATA (FMRS(2,5,I,14),I=1,49)/
57579      &     1.49839D0,  1.22261D0,  0.99703D0,  0.88447D0,  0.81213D0,
57580      &     0.75993D0,  0.61688D0,  0.49791D0,  0.43718D0,  0.39731D0,
57581      &     0.36742D0,  0.28369D0,  0.21052D0,  0.17237D0,  0.14732D0,
57582      &     0.12915D0,  0.10402D0,  0.08067D0,  0.05873D0,  0.04638D0,
57583      &     0.03352D0,  0.02715D0,  0.02331D0,  0.01995D0,  0.01725D0,
57584      &     0.01486D0,  0.01267D0,  0.01065D0,  0.00884D0,  0.00725D0,
57585      &     0.00583D0,  0.00463D0,  0.00362D0,  0.00279D0,  0.00211D0,
57586      &     0.00158D0,  0.00116D0,  0.00083D0,  0.00061D0,  0.00043D0,
57587      &     0.00027D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
57588      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57589       DATA (FMRS(2,5,I,15),I=1,49)/
57590      &     1.87945D0,  1.51634D0,  1.22268D0,  1.07750D0,  0.98475D0,
57591      &     0.91809D0,  0.73686D0,  0.58798D0,  0.51279D0,  0.46377D0,
57592      &     0.42722D0,  0.32591D0,  0.23902D0,  0.19443D0,  0.16545D0,
57593      &     0.14459D0,  0.11596D0,  0.08960D0,  0.06503D0,  0.05127D0,
57594      &     0.03691D0,  0.02973D0,  0.02534D0,  0.02147D0,  0.01838D0,
57595      &     0.01569D0,  0.01327D0,  0.01107D0,  0.00912D0,  0.00743D0,
57596      &     0.00594D0,  0.00469D0,  0.00364D0,  0.00279D0,  0.00210D0,
57597      &     0.00156D0,  0.00114D0,  0.00082D0,  0.00059D0,  0.00041D0,
57598      &     0.00026D0,  0.00017D0,  0.00010D0,  0.00003D0,  0.00000D0,
57599      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57600       DATA (FMRS(2,5,I,16),I=1,49)/
57601      &     2.27429D0,  1.81716D0,  1.45106D0,  1.27151D0,  1.15736D0,
57602      &     1.07564D0,  0.85491D0,  0.67549D0,  0.58568D0,  0.52749D0,
57603      &     0.48429D0,  0.36563D0,  0.26542D0,  0.21469D0,  0.18200D0,
57604      &     0.15862D0,  0.12673D0,  0.09760D0,  0.07063D0,  0.05559D0,
57605      &     0.03988D0,  0.03195D0,  0.02705D0,  0.02273D0,  0.01930D0,
57606      &     0.01634D0,  0.01371D0,  0.01136D0,  0.00930D0,  0.00753D0,
57607      &     0.00599D0,  0.00470D0,  0.00364D0,  0.00277D0,  0.00208D0,
57608      &     0.00154D0,  0.00112D0,  0.00080D0,  0.00058D0,  0.00040D0,
57609      &     0.00025D0,  0.00016D0,  0.00010D0,  0.00003D0,  0.00000D0,
57610      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57611       DATA (FMRS(2,5,I,17),I=1,49)/
57612      &     2.72539D0,  2.15724D0,  1.70653D0,  1.48715D0,  1.34837D0,
57613      &     1.24937D0,  0.98364D0,  0.76983D0,  0.66373D0,  0.59537D0,
57614      &     0.54484D0,  0.40724D0,  0.29272D0,  0.23547D0,  0.19888D0,
57615      &     0.17287D0,  0.13761D0,  0.10564D0,  0.07622D0,  0.05987D0,
57616      &     0.04278D0,  0.03409D0,  0.02869D0,  0.02390D0,  0.02012D0,
57617      &     0.01691D0,  0.01408D0,  0.01159D0,  0.00943D0,  0.00759D0,
57618      &     0.00600D0,  0.00469D0,  0.00361D0,  0.00273D0,  0.00204D0,
57619      &     0.00151D0,  0.00109D0,  0.00078D0,  0.00056D0,  0.00039D0,
57620      &     0.00024D0,  0.00015D0,  0.00009D0,  0.00003D0,  0.00000D0,
57621      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57622       DATA (FMRS(2,5,I,18),I=1,49)/
57623      &     3.13641D0,  2.46418D0,  1.93488D0,  1.67881D0,  1.51744D0,
57624      &     1.40264D0,  1.09608D0,  0.85138D0,  0.73076D0,  0.65340D0,
57625      &     0.59642D0,  0.44225D0,  0.31539D0,  0.25259D0,  0.21272D0,
57626      &     0.18450D0,  0.14644D0,  0.11211D0,  0.08069D0,  0.06328D0,
57627      &     0.04506D0,  0.03575D0,  0.02993D0,  0.02476D0,  0.02070D0,
57628      &     0.01729D0,  0.01432D0,  0.01172D0,  0.00949D0,  0.00760D0,
57629      &     0.00598D0,  0.00466D0,  0.00357D0,  0.00269D0,  0.00201D0,
57630      &     0.00147D0,  0.00106D0,  0.00075D0,  0.00054D0,  0.00038D0,
57631      &     0.00023D0,  0.00015D0,  0.00009D0,  0.00003D0,  0.00000D0,
57632      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57633       DATA (FMRS(2,5,I,19),I=1,49)/
57634      &     3.68153D0,  2.86757D0,  2.23222D0,  1.92702D0,  1.73553D0,
57635      &     1.59976D0,  1.23927D0,  0.95419D0,  0.81477D0,  0.72581D0,
57636      &     0.66053D0,  0.48527D0,  0.34292D0,  0.27324D0,  0.22931D0,
57637      &     0.19839D0,  0.15691D0,  0.11975D0,  0.08593D0,  0.06725D0,
57638      &     0.04768D0,  0.03762D0,  0.03130D0,  0.02569D0,  0.02130D0,
57639      &     0.01766D0,  0.01453D0,  0.01182D0,  0.00951D0,  0.00757D0,
57640      &     0.00594D0,  0.00459D0,  0.00350D0,  0.00264D0,  0.00195D0,
57641      &     0.00143D0,  0.00103D0,  0.00072D0,  0.00052D0,  0.00036D0,
57642      &     0.00022D0,  0.00014D0,  0.00008D0,  0.00003D0,  0.00000D0,
57643      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57644       DATA (FMRS(2,5,I,20),I=1,49)/
57645      &     4.21665D0,  3.26014D0,  2.51906D0,  2.16522D0,  1.94405D0,
57646      &     1.78768D0,  1.37455D0,  1.05042D0,  0.89295D0,  0.79293D0,
57647      &     0.71977D0,  0.52460D0,  0.36780D0,  0.29178D0,  0.24415D0,
57648      &     0.21076D0,  0.16620D0,  0.12648D0,  0.09052D0,  0.07070D0,
57649      &     0.04993D0,  0.03920D0,  0.03244D0,  0.02644D0,  0.02178D0,
57650      &     0.01794D0,  0.01467D0,  0.01187D0,  0.00951D0,  0.00753D0,
57651      &     0.00588D0,  0.00453D0,  0.00344D0,  0.00258D0,  0.00191D0,
57652      &     0.00139D0,  0.00099D0,  0.00070D0,  0.00050D0,  0.00035D0,
57653      &     0.00021D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00000D0,
57654      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57655       DATA (FMRS(2,5,I,21),I=1,49)/
57656      &     4.73651D0,  3.63839D0,  2.79314D0,  2.39169D0,  2.14159D0,
57657      &     1.96521D0,  1.50121D0,  1.13968D0,  0.96506D0,  0.85456D0,
57658      &     0.77398D0,  0.56020D0,  0.39006D0,  0.30823D0,  0.25724D0,
57659      &     0.22164D0,  0.17431D0,  0.13232D0,  0.09445D0,  0.07364D0,
57660      &     0.05181D0,  0.04050D0,  0.03335D0,  0.02701D0,  0.02212D0,
57661      &     0.01812D0,  0.01474D0,  0.01187D0,  0.00946D0,  0.00747D0,
57662      &     0.00580D0,  0.00446D0,  0.00337D0,  0.00252D0,  0.00185D0,
57663      &     0.00135D0,  0.00096D0,  0.00068D0,  0.00049D0,  0.00034D0,
57664      &     0.00020D0,  0.00013D0,  0.00007D0,  0.00003D0,  0.00000D0,
57665      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57666       DATA (FMRS(2,5,I,22),I=1,49)/
57667      &     5.45753D0,  4.15887D0,  3.16726D0,  2.69936D0,  2.40907D0,
57668      &     2.20495D0,  1.67083D0,  1.25820D0,  1.06032D0,  0.93568D0,
57669      &     0.84511D0,  0.60646D0,  0.41869D0,  0.32928D0,  0.27391D0,
57670      &     0.23544D0,  0.18455D0,  0.13964D0,  0.09936D0,  0.07728D0,
57671      &     0.05411D0,  0.04206D0,  0.03442D0,  0.02766D0,  0.02248D0,
57672      &     0.01829D0,  0.01478D0,  0.01184D0,  0.00938D0,  0.00736D0,
57673      &     0.00570D0,  0.00435D0,  0.00328D0,  0.00244D0,  0.00179D0,
57674      &     0.00129D0,  0.00092D0,  0.00065D0,  0.00046D0,  0.00032D0,
57675      &     0.00019D0,  0.00012D0,  0.00007D0,  0.00003D0,  0.00000D0,
57676      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57677       DATA (FMRS(2,5,I,23),I=1,49)/
57678      &     6.19783D0,  4.68879D0,  3.54494D0,  3.00840D0,  2.67675D0,
57679      &     2.44420D0,  1.83862D0,  1.37436D0,  1.15316D0,  1.01443D0,
57680      &     0.91394D0,  0.65074D0,  0.44579D0,  0.34906D0,  0.28951D0,
57681      &     0.24830D0,  0.19403D0,  0.14639D0,  0.10384D0,  0.08058D0,
57682      &     0.05616D0,  0.04343D0,  0.03534D0,  0.02820D0,  0.02276D0,
57683      &     0.01841D0,  0.01478D0,  0.01177D0,  0.00929D0,  0.00725D0,
57684      &     0.00558D0,  0.00425D0,  0.00319D0,  0.00236D0,  0.00173D0,
57685      &     0.00124D0,  0.00088D0,  0.00062D0,  0.00044D0,  0.00031D0,
57686      &     0.00018D0,  0.00011D0,  0.00007D0,  0.00003D0,  0.00000D0,
57687      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57688       DATA (FMRS(2,5,I,24),I=1,49)/
57689      &     6.92966D0,  5.20839D0,  3.91218D0,  3.30740D0,  2.93482D0,
57690      &     2.67420D0,  1.99847D0,  1.48399D0,  1.24028D0,  1.08801D0,
57691      &     0.97803D0,  0.69152D0,  0.47043D0,  0.36691D0,  0.30350D0,
57692      &     0.25978D0,  0.20243D0,  0.15231D0,  0.10773D0,  0.08341D0,
57693      &     0.05788D0,  0.04454D0,  0.03605D0,  0.02858D0,  0.02293D0,
57694      &     0.01844D0,  0.01473D0,  0.01167D0,  0.00917D0,  0.00713D0,
57695      &     0.00547D0,  0.00415D0,  0.00310D0,  0.00229D0,  0.00167D0,
57696      &     0.00120D0,  0.00085D0,  0.00059D0,  0.00043D0,  0.00030D0,
57697      &     0.00017D0,  0.00011D0,  0.00006D0,  0.00003D0,  0.00000D0,
57698      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57699       DATA (FMRS(2,5,I,25),I=1,49)/
57700      &     7.72396D0,  5.76848D0,  4.30532D0,  3.62618D0,  3.20915D0,
57701      &     2.91815D0,  2.16681D0,  1.59861D0,  1.33097D0,  1.16435D0,
57702      &     1.04435D0,  0.73337D0,  0.49551D0,  0.38498D0,  0.31761D0,
57703      &     0.27133D0,  0.21084D0,  0.15821D0,  0.11158D0,  0.08620D0,
57704      &     0.05955D0,  0.04560D0,  0.03673D0,  0.02893D0,  0.02307D0,
57705      &     0.01845D0,  0.01466D0,  0.01156D0,  0.00904D0,  0.00700D0,
57706      &     0.00535D0,  0.00404D0,  0.00301D0,  0.00221D0,  0.00161D0,
57707      &     0.00115D0,  0.00081D0,  0.00057D0,  0.00041D0,  0.00028D0,
57708      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00003D0,  0.00000D0,
57709      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57710       DATA (FMRS(2,5,I,26),I=1,49)/
57711      &     8.54145D0,  6.34073D0,  4.70401D0,  3.94803D0,  3.48525D0,
57712      &     3.16305D0,  2.33446D0,  1.71181D0,  1.42007D0,  1.23908D0,
57713      &     1.10907D0,  0.77380D0,  0.51947D0,  0.40212D0,  0.33092D0,
57714      &     0.28218D0,  0.21869D0,  0.16367D0,  0.11510D0,  0.08871D0,
57715      &     0.06103D0,  0.04651D0,  0.03727D0,  0.02918D0,  0.02314D0,
57716      &     0.01840D0,  0.01456D0,  0.01142D0,  0.00889D0,  0.00686D0,
57717      &     0.00522D0,  0.00393D0,  0.00292D0,  0.00214D0,  0.00155D0,
57718      &     0.00111D0,  0.00078D0,  0.00054D0,  0.00039D0,  0.00027D0,
57719      &     0.00016D0,  0.00009D0,  0.00005D0,  0.00003D0,  0.00000D0,
57720      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57721       DATA (FMRS(2,5,I,27),I=1,49)/
57722      &     9.36625D0,  6.91445D0,  5.10115D0,  4.26741D0,  3.75848D0,
57723      &     3.40490D0,  2.49891D0,  1.82207D0,  1.50649D0,  1.31134D0,
57724      &     1.17150D0,  0.81249D0,  0.54219D0,  0.41829D0,  0.34343D0,
57725      &     0.29234D0,  0.22601D0,  0.16873D0,  0.11834D0,  0.09101D0,
57726      &     0.06235D0,  0.04731D0,  0.03774D0,  0.02938D0,  0.02318D0,
57727      &     0.01834D0,  0.01444D0,  0.01128D0,  0.00875D0,  0.00672D0,
57728      &     0.00510D0,  0.00383D0,  0.00283D0,  0.00207D0,  0.00150D0,
57729      &     0.00107D0,  0.00075D0,  0.00052D0,  0.00038D0,  0.00026D0,
57730      &     0.00015D0,  0.00009D0,  0.00005D0,  0.00003D0,  0.00000D0,
57731      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57732       DATA (FMRS(2,5,I,28),I=1,49)/
57733      &    10.18132D0,  7.47793D0,  5.48877D0,  4.57798D0,  4.02345D0,
57734      &     3.63894D0,  2.65699D0,  1.92733D0,  1.58864D0,  1.37981D0,
57735      &     1.23051D0,  0.84875D0,  0.56329D0,  0.43322D0,  0.35493D0,
57736      &     0.30165D0,  0.23267D0,  0.17330D0,  0.12123D0,  0.09305D0,
57737      &     0.06349D0,  0.04798D0,  0.03811D0,  0.02952D0,  0.02317D0,
57738      &     0.01825D0,  0.01431D0,  0.01114D0,  0.00861D0,  0.00659D0,
57739      &     0.00498D0,  0.00373D0,  0.00275D0,  0.00201D0,  0.00145D0,
57740      &     0.00103D0,  0.00072D0,  0.00050D0,  0.00036D0,  0.00026D0,
57741      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00003D0,  0.00000D0,
57742      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57743       DATA (FMRS(2,5,I,29),I=1,49)/
57744      &    11.04388D0,  8.07089D0,  5.89435D0,  4.90182D0,  4.29909D0,
57745      &     3.88193D0,  2.82014D0,  2.03528D0,  1.67258D0,  1.44958D0,
57746      &     1.29048D0,  0.88533D0,  0.58442D0,  0.44808D0,  0.36634D0,
57747      &     0.31085D0,  0.23922D0,  0.17778D0,  0.12404D0,  0.09501D0,
57748      &     0.06457D0,  0.04859D0,  0.03843D0,  0.02962D0,  0.02314D0,
57749      &     0.01814D0,  0.01416D0,  0.01098D0,  0.00846D0,  0.00645D0,
57750      &     0.00486D0,  0.00363D0,  0.00267D0,  0.00194D0,  0.00140D0,
57751      &     0.00099D0,  0.00069D0,  0.00048D0,  0.00035D0,  0.00025D0,
57752      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00003D0,  0.00000D0,
57753      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57754       DATA (FMRS(2,5,I,30),I=1,49)/
57755      &    11.92777D0,  8.67505D0,  6.30518D0,  5.22873D0,  4.57663D0,
57756      &     4.12613D0,  2.98306D0,  2.14237D0,  1.75551D0,  1.51831D0,
57757      &     1.34943D0,  0.92100D0,  0.60483D0,  0.46237D0,  0.37725D0,
57758      &     0.31962D0,  0.24543D0,  0.18198D0,  0.12665D0,  0.09681D0,
57759      &     0.06554D0,  0.04912D0,  0.03869D0,  0.02967D0,  0.02307D0,
57760      &     0.01801D0,  0.01401D0,  0.01082D0,  0.00830D0,  0.00632D0,
57761      &     0.00475D0,  0.00353D0,  0.00259D0,  0.00188D0,  0.00135D0,
57762      &     0.00095D0,  0.00066D0,  0.00047D0,  0.00034D0,  0.00024D0,
57763      &     0.00014D0,  0.00008D0,  0.00004D0,  0.00002D0,  0.00000D0,
57764      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57765       DATA (FMRS(2,5,I,31),I=1,49)/
57766      &    12.81161D0,  9.27611D0,  6.71181D0,  5.55130D0,  4.84990D0,
57767      &     4.36615D0,  3.14234D0,  2.24650D0,  1.83587D0,  1.58474D0,
57768      &     1.40629D0,  0.95519D0,  0.62425D0,  0.47590D0,  0.38756D0,
57769      &     0.32788D0,  0.25125D0,  0.18591D0,  0.12907D0,  0.09846D0,
57770      &     0.06642D0,  0.04959D0,  0.03891D0,  0.02970D0,  0.02299D0,
57771      &     0.01788D0,  0.01385D0,  0.01067D0,  0.00816D0,  0.00619D0,
57772      &     0.00464D0,  0.00344D0,  0.00252D0,  0.00182D0,  0.00130D0,
57773      &     0.00092D0,  0.00064D0,  0.00045D0,  0.00033D0,  0.00023D0,
57774      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
57775      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57776       DATA (FMRS(2,5,I,32),I=1,49)/
57777      &    13.67059D0,  9.85720D0,  7.10279D0,  5.86046D0,  5.11119D0,
57778      &     4.59523D0,  3.29346D0,  2.34466D0,  1.91134D0,  1.64694D0,
57779      &     1.45941D0,  0.98687D0,  0.64209D0,  0.48825D0,  0.39691D0,
57780      &     0.33535D0,  0.25648D0,  0.18940D0,  0.13119D0,  0.09990D0,
57781      &     0.06714D0,  0.04995D0,  0.03906D0,  0.02968D0,  0.02289D0,
57782      &     0.01773D0,  0.01369D0,  0.01051D0,  0.00801D0,  0.00606D0,
57783      &     0.00453D0,  0.00335D0,  0.00245D0,  0.00177D0,  0.00126D0,
57784      &     0.00089D0,  0.00062D0,  0.00043D0,  0.00032D0,  0.00023D0,
57785      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
57786      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57787       DATA (FMRS(2,5,I,33),I=1,49)/
57788      &    14.58850D0, 10.47558D0,  7.51716D0,  6.18731D0,  5.38695D0,
57789      &     4.83668D0,  3.45207D0,  2.44727D0,  1.99002D0,  1.71168D0,
57790      &     1.51462D0,  1.01965D0,  0.66046D0,  0.50094D0,  0.40651D0,
57791      &     0.34300D0,  0.26182D0,  0.19296D0,  0.13335D0,  0.10136D0,
57792      &     0.06788D0,  0.05032D0,  0.03921D0,  0.02967D0,  0.02278D0,
57793      &     0.01759D0,  0.01353D0,  0.01035D0,  0.00787D0,  0.00594D0,
57794      &     0.00443D0,  0.00327D0,  0.00238D0,  0.00172D0,  0.00122D0,
57795      &     0.00086D0,  0.00060D0,  0.00042D0,  0.00031D0,  0.00022D0,
57796      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
57797      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57798       DATA (FMRS(2,5,I,34),I=1,49)/
57799      &    15.50215D0, 11.08776D0,  7.92505D0,  6.50796D0,  5.65681D0,
57800      &     5.07248D0,  3.60600D0,  2.54615D0,  2.06552D0,  1.77359D0,
57801      &     1.56726D0,  1.05062D0,  0.67763D0,  0.51270D0,  0.41535D0,
57802      &     0.35001D0,  0.26666D0,  0.19615D0,  0.13524D0,  0.10260D0,
57803      &     0.06847D0,  0.05058D0,  0.03928D0,  0.02960D0,  0.02264D0,
57804      &     0.01742D0,  0.01336D0,  0.01019D0,  0.00772D0,  0.00581D0,
57805      &     0.00432D0,  0.00318D0,  0.00232D0,  0.00166D0,  0.00118D0,
57806      &     0.00083D0,  0.00058D0,  0.00041D0,  0.00030D0,  0.00022D0,
57807      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
57808      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57809       DATA (FMRS(2,5,I,35),I=1,49)/
57810      &    16.42021D0, 11.70052D0,  8.33176D0,  6.82695D0,  5.92484D0,
57811      &     5.30641D0,  3.75809D0,  2.64348D0,  2.13966D0,  1.83429D0,
57812      &     1.61881D0,  1.08081D0,  0.69429D0,  0.52409D0,  0.42389D0,
57813      &     0.35678D0,  0.27133D0,  0.19921D0,  0.13706D0,  0.10380D0,
57814      &     0.06904D0,  0.05083D0,  0.03934D0,  0.02953D0,  0.02251D0,
57815      &     0.01726D0,  0.01320D0,  0.01004D0,  0.00759D0,  0.00569D0,
57816      &     0.00422D0,  0.00310D0,  0.00225D0,  0.00162D0,  0.00115D0,
57817      &     0.00080D0,  0.00056D0,  0.00039D0,  0.00029D0,  0.00021D0,
57818      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
57819      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57820       DATA (FMRS(2,5,I,36),I=1,49)/
57821      &    17.31499D0, 12.29519D0,  8.72473D0,  7.13436D0,  6.18265D0,
57822      &     5.53107D0,  3.90347D0,  2.73604D0,  2.20994D0,  1.89170D0,
57823      &     1.66747D0,  1.10914D0,  0.70980D0,  0.53464D0,  0.43178D0,
57824      &     0.36300D0,  0.27560D0,  0.20200D0,  0.13869D0,  0.10485D0,
57825      &     0.06952D0,  0.05103D0,  0.03937D0,  0.02945D0,  0.02237D0,
57826      &     0.01710D0,  0.01303D0,  0.00989D0,  0.00746D0,  0.00558D0,
57827      &     0.00413D0,  0.00303D0,  0.00220D0,  0.00157D0,  0.00111D0,
57828      &     0.00078D0,  0.00054D0,  0.00038D0,  0.00028D0,  0.00021D0,
57829      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
57830      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57831       DATA (FMRS(2,5,I,37),I=1,49)/
57832      &    18.24071D0, 12.90782D0,  9.12782D0,  7.44886D0,  6.44591D0,
57833      &     5.76014D0,  4.05101D0,  2.82949D0,  2.28068D0,  1.94934D0,
57834      &     1.71624D0,  1.13734D0,  0.72513D0,  0.54501D0,  0.43949D0,
57835      &     0.36907D0,  0.27974D0,  0.20467D0,  0.14023D0,  0.10583D0,
57836      &     0.06996D0,  0.05118D0,  0.03937D0,  0.02934D0,  0.02221D0,
57837      &     0.01693D0,  0.01286D0,  0.00973D0,  0.00732D0,  0.00547D0,
57838      &     0.00404D0,  0.00296D0,  0.00214D0,  0.00153D0,  0.00108D0,
57839      &     0.00076D0,  0.00052D0,  0.00037D0,  0.00027D0,  0.00020D0,
57840      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
57841      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57842       DATA (FMRS(2,5,I,38),I=1,49)/
57843      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57844      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57845      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57846      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57847      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57848      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57849      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57850      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57851      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57852      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57853       DATA (FMRS(2,6,I, 1),I=1,49)/
57854      &     0.49855D0,  0.42587D0,  0.36389D0,  0.33197D0,  0.31109D0,
57855      &     0.29584D0,  0.25332D0,  0.21750D0,  0.19938D0,  0.18774D0,
57856      &     0.17961D0,  0.15726D0,  0.13904D0,  0.12982D0,  0.12379D0,
57857      &     0.11933D0,  0.11282D0,  0.10593D0,  0.09760D0,  0.09090D0,
57858      &     0.07946D0,  0.06933D0,  0.06013D0,  0.04980D0,  0.04078D0,
57859      &     0.03302D0,  0.02641D0,  0.02091D0,  0.01639D0,  0.01253D0,
57860      &     0.00964D0,  0.00728D0,  0.00545D0,  0.00406D0,  0.00291D0,
57861      &     0.00211D0,  0.00151D0,  0.00106D0,  0.00067D0,  0.00051D0,
57862      &     0.00036D0,  0.00020D0,  0.00015D0,  0.00005D0,  0.00001D0,
57863      &    -0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
57864       DATA (FMRS(2,6,I, 2),I=1,49)/
57865      &     0.50643D0,  0.43610D0,  0.37562D0,  0.34428D0,  0.32368D0,
57866      &     0.30859D0,  0.26628D0,  0.23029D0,  0.21194D0,  0.20007D0,
57867      &     0.19176D0,  0.16857D0,  0.14897D0,  0.13868D0,  0.13176D0,
57868      &     0.12655D0,  0.11883D0,  0.11060D0,  0.10078D0,  0.09314D0,
57869      &     0.08065D0,  0.07007D0,  0.06069D0,  0.05033D0,  0.04135D0,
57870      &     0.03363D0,  0.02706D0,  0.02157D0,  0.01702D0,  0.01315D0,
57871      &     0.01020D0,  0.00777D0,  0.00589D0,  0.00442D0,  0.00323D0,
57872      &     0.00236D0,  0.00171D0,  0.00122D0,  0.00079D0,  0.00059D0,
57873      &     0.00042D0,  0.00024D0,  0.00018D0,  0.00006D0,  0.00002D0,
57874      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57875       DATA (FMRS(2,6,I, 3),I=1,49)/
57876      &     0.53555D0,  0.46535D0,  0.40441D0,  0.37256D0,  0.35153D0,
57877      &     0.33606D0,  0.29238D0,  0.25475D0,  0.23531D0,  0.22262D0,
57878      &     0.21361D0,  0.18804D0,  0.16542D0,  0.15305D0,  0.14451D0,
57879      &     0.13799D0,  0.12824D0,  0.11785D0,  0.10571D0,  0.09664D0,
57880      &     0.08259D0,  0.07132D0,  0.06165D0,  0.05118D0,  0.04219D0,
57881      &     0.03449D0,  0.02794D0,  0.02243D0,  0.01784D0,  0.01392D0,
57882      &     0.01089D0,  0.00837D0,  0.00641D0,  0.00486D0,  0.00360D0,
57883      &     0.00265D0,  0.00193D0,  0.00138D0,  0.00092D0,  0.00067D0,
57884      &     0.00048D0,  0.00029D0,  0.00022D0,  0.00008D0,  0.00002D0,
57885      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57886       DATA (FMRS(2,6,I, 4),I=1,49)/
57887      &     0.57226D0,  0.49911D0,  0.43533D0,  0.40188D0,  0.37974D0,
57888      &     0.36342D0,  0.31717D0,  0.27704D0,  0.25615D0,  0.24242D0,
57889      &     0.23256D0,  0.20428D0,  0.17865D0,  0.16439D0,  0.15446D0,
57890      &     0.14683D0,  0.13543D0,  0.12334D0,  0.10944D0,  0.09929D0,
57891      &     0.08411D0,  0.07232D0,  0.06240D0,  0.05181D0,  0.04280D0,
57892      &     0.03507D0,  0.02851D0,  0.02298D0,  0.01835D0,  0.01437D0,
57893      &     0.01128D0,  0.00872D0,  0.00670D0,  0.00509D0,  0.00378D0,
57894      &     0.00278D0,  0.00204D0,  0.00149D0,  0.00099D0,  0.00072D0,
57895      &     0.00050D0,  0.00032D0,  0.00023D0,  0.00009D0,  0.00003D0,
57896      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57897       DATA (FMRS(2,6,I, 5),I=1,49)/
57898      &     0.63213D0,  0.55147D0,  0.48109D0,  0.44417D0,  0.41970D0,
57899      &     0.40166D0,  0.35046D0,  0.30587D0,  0.28254D0,  0.26712D0,
57900      &     0.25592D0,  0.22358D0,  0.19384D0,  0.17718D0,  0.16554D0,
57901      &     0.15661D0,  0.14330D0,  0.12931D0,  0.11348D0,  0.10220D0,
57902      &     0.08579D0,  0.07344D0,  0.06325D0,  0.05250D0,  0.04341D0,
57903      &     0.03561D0,  0.02901D0,  0.02344D0,  0.01875D0,  0.01473D0,
57904      &     0.01158D0,  0.00897D0,  0.00690D0,  0.00525D0,  0.00392D0,
57905      &     0.00287D0,  0.00212D0,  0.00153D0,  0.00104D0,  0.00075D0,
57906      &     0.00052D0,  0.00033D0,  0.00023D0,  0.00009D0,  0.00002D0,
57907      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57908       DATA (FMRS(2,6,I, 6),I=1,49)/
57909      &     0.69484D0,  0.60548D0,  0.52759D0,  0.48675D0,  0.45969D0,
57910      &     0.43974D0,  0.38311D0,  0.33372D0,  0.30779D0,  0.29059D0,
57911      &     0.27800D0,  0.24152D0,  0.20772D0,  0.18874D0,  0.17549D0,
57912      &     0.16535D0,  0.15028D0,  0.13457D0,  0.11704D0,  0.10475D0,
57913      &     0.08728D0,  0.07444D0,  0.06400D0,  0.05308D0,  0.04390D0,
57914      &     0.03605D0,  0.02939D0,  0.02378D0,  0.01903D0,  0.01499D0,
57915      &     0.01179D0,  0.00914D0,  0.00703D0,  0.00535D0,  0.00400D0,
57916      &     0.00293D0,  0.00217D0,  0.00156D0,  0.00107D0,  0.00077D0,
57917      &     0.00053D0,  0.00034D0,  0.00024D0,  0.00009D0,  0.00002D0,
57918      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57919       DATA (FMRS(2,6,I, 7),I=1,49)/
57920      &     0.77164D0,  0.67034D0,  0.58230D0,  0.53624D0,  0.50577D0,
57921      &     0.48332D0,  0.41966D0,  0.36421D0,  0.33508D0,  0.31572D0,
57922      &     0.30145D0,  0.26012D0,  0.22178D0,  0.20031D0,  0.18536D0,
57923      &     0.17396D0,  0.15711D0,  0.13969D0,  0.12049D0,  0.10724D0,
57924      &     0.08874D0,  0.07542D0,  0.06472D0,  0.05362D0,  0.04433D0,
57925      &     0.03642D0,  0.02969D0,  0.02403D0,  0.01923D0,  0.01516D0,
57926      &     0.01193D0,  0.00926D0,  0.00710D0,  0.00541D0,  0.00405D0,
57927      &     0.00297D0,  0.00219D0,  0.00158D0,  0.00108D0,  0.00077D0,
57928      &     0.00052D0,  0.00033D0,  0.00024D0,  0.00008D0,  0.00002D0,
57929      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57930       DATA (FMRS(2,6,I, 8),I=1,49)/
57931      &     0.86838D0,  0.75105D0,  0.64953D0,  0.59658D0,  0.56163D0,
57932      &     0.53592D0,  0.46317D0,  0.39995D0,  0.36678D0,  0.34473D0,
57933      &     0.32838D0,  0.28112D0,  0.23740D0,  0.21303D0,  0.19616D0,
57934      &     0.18334D0,  0.16450D0,  0.14520D0,  0.12419D0,  0.10991D0,
57935      &     0.09031D0,  0.07647D0,  0.06547D0,  0.05416D0,  0.04475D0,
57936      &     0.03674D0,  0.02994D0,  0.02423D0,  0.01939D0,  0.01529D0,
57937      &     0.01202D0,  0.00932D0,  0.00715D0,  0.00545D0,  0.00407D0,
57938      &     0.00298D0,  0.00220D0,  0.00159D0,  0.00108D0,  0.00077D0,
57939      &     0.00052D0,  0.00033D0,  0.00024D0,  0.00008D0,  0.00002D0,
57940      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57941       DATA (FMRS(2,6,I, 9),I=1,49)/
57942      &     0.96608D0,  0.83177D0,  0.71606D0,  0.65593D0,  0.61632D0,
57943      &     0.58722D0,  0.50510D0,  0.43397D0,  0.39671D0,  0.37195D0,
57944      &     0.35355D0,  0.30046D0,  0.25156D0,  0.22448D0,  0.20581D0,
57945      &     0.19169D0,  0.17103D0,  0.15004D0,  0.12743D0,  0.11224D0,
57946      &     0.09169D0,  0.07737D0,  0.06612D0,  0.05461D0,  0.04508D0,
57947      &     0.03697D0,  0.03013D0,  0.02435D0,  0.01949D0,  0.01536D0,
57948      &     0.01207D0,  0.00933D0,  0.00718D0,  0.00545D0,  0.00407D0,
57949      &     0.00298D0,  0.00219D0,  0.00159D0,  0.00106D0,  0.00076D0,
57950      &     0.00052D0,  0.00033D0,  0.00024D0,  0.00009D0,  0.00002D0,
57951      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57952       DATA (FMRS(2,6,I,10),I=1,49)/
57953      &     1.07543D0,  0.92116D0,  0.78892D0,  0.72047D0,  0.67548D0,
57954      &     0.64249D0,  0.54968D0,  0.46963D0,  0.42782D0,  0.40008D0,
57955      &     0.37941D0,  0.32003D0,  0.26568D0,  0.23578D0,  0.21528D0,
57956      &     0.19985D0,  0.17739D0,  0.15473D0,  0.13057D0,  0.11449D0,
57957      &     0.09302D0,  0.07823D0,  0.06672D0,  0.05501D0,  0.04535D0,
57958      &     0.03715D0,  0.03025D0,  0.02442D0,  0.01953D0,  0.01538D0,
57959      &     0.01207D0,  0.00932D0,  0.00717D0,  0.00543D0,  0.00405D0,
57960      &     0.00296D0,  0.00217D0,  0.00158D0,  0.00105D0,  0.00075D0,
57961      &     0.00051D0,  0.00033D0,  0.00023D0,  0.00008D0,  0.00002D0,
57962      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57963       DATA (FMRS(2,6,I,11),I=1,49)/
57964      &     1.17158D0,  0.99923D0,  0.85209D0,  0.77617D0,  0.72639D0,
57965      &     0.68993D0,  0.58762D0,  0.49971D0,  0.45391D0,  0.42357D0,
57966      &     0.40096D0,  0.33616D0,  0.27719D0,  0.24495D0,  0.22293D0,
57967      &     0.20642D0,  0.18248D0,  0.15848D0,  0.13306D0,  0.11628D0,
57968      &     0.09406D0,  0.07891D0,  0.06718D0,  0.05531D0,  0.04555D0,
57969      &     0.03727D0,  0.03032D0,  0.02446D0,  0.01953D0,  0.01537D0,
57970      &     0.01205D0,  0.00930D0,  0.00714D0,  0.00540D0,  0.00402D0,
57971      &     0.00294D0,  0.00214D0,  0.00155D0,  0.00104D0,  0.00074D0,
57972      &     0.00050D0,  0.00032D0,  0.00022D0,  0.00008D0,  0.00002D0,
57973      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57974       DATA (FMRS(2,6,I,12),I=1,49)/
57975      &     1.40820D0,  1.18938D0,  1.00430D0,  0.90953D0,  0.84767D0,
57976      &     0.80252D0,  0.67658D0,  0.56932D0,  0.51382D0,  0.47719D0,
57977      &     0.44989D0,  0.37226D0,  0.30256D0,  0.26497D0,  0.23955D0,
57978      &     0.22062D0,  0.19343D0,  0.16648D0,  0.13836D0,  0.12007D0,
57979      &     0.09626D0,  0.08032D0,  0.06811D0,  0.05588D0,  0.04588D0,
57980      &     0.03745D0,  0.03039D0,  0.02446D0,  0.01948D0,  0.01531D0,
57981      &     0.01197D0,  0.00921D0,  0.00706D0,  0.00532D0,  0.00395D0,
57982      &     0.00288D0,  0.00209D0,  0.00151D0,  0.00101D0,  0.00072D0,
57983      &     0.00049D0,  0.00031D0,  0.00021D0,  0.00008D0,  0.00002D0,
57984      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57985       DATA (FMRS(2,6,I,13),I=1,49)/
57986      &     1.64756D0,  1.37951D0,  1.15467D0,  1.04031D0,  0.96596D0,
57987      &     0.91188D0,  0.76181D0,  0.63505D0,  0.56988D0,  0.52704D0,
57988      &     0.49515D0,  0.40510D0,  0.32525D0,  0.28268D0,  0.25415D0,
57989      &     0.23303D0,  0.20292D0,  0.17336D0,  0.14288D0,  0.12329D0,
57990      &     0.09812D0,  0.08148D0,  0.06886D0,  0.05629D0,  0.04609D0,
57991      &     0.03753D0,  0.03037D0,  0.02438D0,  0.01937D0,  0.01519D0,
57992      &     0.01185D0,  0.00910D0,  0.00695D0,  0.00523D0,  0.00387D0,
57993      &     0.00281D0,  0.00204D0,  0.00147D0,  0.00097D0,  0.00069D0,
57994      &     0.00048D0,  0.00029D0,  0.00020D0,  0.00007D0,  0.00002D0,
57995      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57996       DATA (FMRS(2,6,I,14),I=1,49)/
57997      &     1.95709D0,  1.62260D0,  1.34467D0,  1.20438D0,  1.11362D0,
57998      &     1.04783D0,  0.86639D0,  0.71460D0,  0.63715D0,  0.58648D0,
57999      &     0.54885D0,  0.44345D0,  0.35130D0,  0.30283D0,  0.27064D0,
58000      &     0.24698D0,  0.21351D0,  0.18099D0,  0.14786D0,  0.12681D0,
58001      &     0.10011D0,  0.08269D0,  0.06959D0,  0.05666D0,  0.04624D0,
58002      &     0.03752D0,  0.03025D0,  0.02422D0,  0.01919D0,  0.01499D0,
58003      &     0.01165D0,  0.00893D0,  0.00678D0,  0.00510D0,  0.00375D0,
58004      &     0.00271D0,  0.00197D0,  0.00141D0,  0.00093D0,  0.00065D0,
58005      &     0.00045D0,  0.00028D0,  0.00019D0,  0.00007D0,  0.00002D0,
58006      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58007       DATA (FMRS(2,6,I,15),I=1,49)/
58008      &     2.33106D0,  1.91266D0,  1.56849D0,  1.39616D0,  1.28524D0,
58009      &     1.20514D0,  0.98569D0,  0.80398D0,  0.71204D0,  0.65222D0,
58010      &     0.60792D0,  0.48491D0,  0.37897D0,  0.32402D0,  0.28785D0,
58011      &     0.26145D0,  0.22441D0,  0.18878D0,  0.15289D0,  0.13035D0,
58012      &     0.10206D0,  0.08383D0,  0.07023D0,  0.05691D0,  0.04625D0,
58013      &     0.03736D0,  0.03004D0,  0.02396D0,  0.01891D0,  0.01473D0,
58014      &     0.01139D0,  0.00872D0,  0.00659D0,  0.00494D0,  0.00362D0,
58015      &     0.00261D0,  0.00189D0,  0.00136D0,  0.00089D0,  0.00062D0,
58016      &     0.00043D0,  0.00026D0,  0.00018D0,  0.00006D0,  0.00002D0,
58017      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58018       DATA (FMRS(2,6,I,16),I=1,49)/
58019      &     2.71585D0,  2.20785D0,  1.79373D0,  1.58787D0,  1.45597D0,
58020      &     1.36104D0,  1.10250D0,  0.89041D0,  0.78391D0,  0.71494D0,
58021      &     0.66403D0,  0.52372D0,  0.40449D0,  0.34337D0,  0.30346D0,
58022      &     0.27452D0,  0.23417D0,  0.19570D0,  0.15732D0,  0.13343D0,
58023      &     0.10373D0,  0.08475D0,  0.07072D0,  0.05705D0,  0.04617D0,
58024      &     0.03716D0,  0.02977D0,  0.02366D0,  0.01861D0,  0.01445D0,
58025      &     0.01114D0,  0.00850D0,  0.00640D0,  0.00478D0,  0.00350D0,
58026      &     0.00251D0,  0.00181D0,  0.00130D0,  0.00086D0,  0.00058D0,
58027      &     0.00040D0,  0.00024D0,  0.00016D0,  0.00006D0,  0.00002D0,
58028      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58029       DATA (FMRS(2,6,I,17),I=1,49)/
58030      &     3.15180D0,  2.53892D0,  2.04375D0,  1.79938D0,  1.64351D0,
58031      &     1.53170D0,  1.22899D0,  0.98294D0,  0.86032D0,  0.78129D0,
58032      &     0.72315D0,  0.56409D0,  0.43066D0,  0.36305D0,  0.31926D0,
58033      &     0.28768D0,  0.24394D0,  0.20257D0,  0.16168D0,  0.13644D0,
58034      &     0.10531D0,  0.08560D0,  0.07112D0,  0.05711D0,  0.04602D0,
58035      &     0.03691D0,  0.02945D0,  0.02332D0,  0.01829D0,  0.01415D0,
58036      &     0.01087D0,  0.00826D0,  0.00621D0,  0.00462D0,  0.00337D0,
58037      &     0.00241D0,  0.00173D0,  0.00124D0,  0.00082D0,  0.00055D0,
58038      &     0.00038D0,  0.00023D0,  0.00015D0,  0.00005D0,  0.00002D0,
58039      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58040       DATA (FMRS(2,6,I,18),I=1,49)/
58041      &     3.55145D0,  2.83962D0,  2.26870D0,  1.98860D0,  1.81061D0,
58042      &     1.68328D0,  1.34021D0,  1.06346D0,  0.92638D0,  0.83839D0,
58043      &     0.77383D0,  0.59827D0,  0.45255D0,  0.37938D0,  0.33229D0,
58044      &     0.29849D0,  0.25191D0,  0.20813D0,  0.16517D0,  0.13882D0,
58045      &     0.10653D0,  0.08622D0,  0.07137D0,  0.05708D0,  0.04584D0,
58046      &     0.03664D0,  0.02914D0,  0.02300D0,  0.01798D0,  0.01388D0,
58047      &     0.01064D0,  0.00807D0,  0.00604D0,  0.00448D0,  0.00326D0,
58048      &     0.00232D0,  0.00166D0,  0.00119D0,  0.00077D0,  0.00053D0,
58049      &     0.00036D0,  0.00022D0,  0.00015D0,  0.00005D0,  0.00001D0,
58050      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58051       DATA (FMRS(2,6,I,19),I=1,49)/
58052      &     4.08243D0,  3.23554D0,  2.56218D0,  2.23414D0,  2.02661D0,
58053      &     1.87862D0,  1.48217D0,  1.16519D0,  1.00935D0,  0.90979D0,
58054      &     0.83697D0,  0.64037D0,  0.47917D0,  0.39910D0,  0.34794D0,
58055      &     0.31141D0,  0.26137D0,  0.21468D0,  0.16924D0,  0.14156D0,
58056      &     0.10788D0,  0.08686D0,  0.07159D0,  0.05697D0,  0.04554D0,
58057      &     0.03624D0,  0.02871D0,  0.02258D0,  0.01759D0,  0.01353D0,
58058      &     0.01034D0,  0.00780D0,  0.00582D0,  0.00431D0,  0.00313D0,
58059      &     0.00222D0,  0.00159D0,  0.00113D0,  0.00073D0,  0.00050D0,
58060      &     0.00034D0,  0.00021D0,  0.00014D0,  0.00005D0,  0.00001D0,
58061      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58062       DATA (FMRS(2,6,I,20),I=1,49)/
58063      &     4.59984D0,  3.61795D0,  2.84314D0,  2.46798D0,  2.23154D0,
58064      &     2.06341D0,  1.61522D0,  1.25965D0,  1.08594D0,  0.97542D0,
58065      &     0.89482D0,  0.67853D0,  0.50302D0,  0.41664D0,  0.36179D0,
58066      &     0.32280D0,  0.26966D0,  0.22039D0,  0.17274D0,  0.14391D0,
58067      &     0.10901D0,  0.08736D0,  0.07173D0,  0.05682D0,  0.04524D0,
58068      &     0.03586D0,  0.02831D0,  0.02220D0,  0.01723D0,  0.01322D0,
58069      &     0.01007D0,  0.00756D0,  0.00563D0,  0.00415D0,  0.00301D0,
58070      &     0.00213D0,  0.00152D0,  0.00108D0,  0.00071D0,  0.00046D0,
58071      &     0.00032D0,  0.00019D0,  0.00013D0,  0.00004D0,  0.00001D0,
58072      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58073       DATA (FMRS(2,6,I,21),I=1,49)/
58074      &     5.10866D0,  3.99099D0,  3.11497D0,  2.69310D0,  2.42814D0,
58075      &     2.24021D0,  1.74141D0,  1.34843D0,  1.15753D0,  1.03651D0,
58076      &     0.94850D0,  0.71355D0,  0.52465D0,  0.43244D0,  0.37419D0,
58077      &     0.33296D0,  0.27700D0,  0.22539D0,  0.17578D0,  0.14590D0,
58078      &     0.10992D0,  0.08772D0,  0.07175D0,  0.05660D0,  0.04490D0,
58079      &     0.03547D0,  0.02791D0,  0.02182D0,  0.01688D0,  0.01291D0,
58080      &     0.00980D0,  0.00735D0,  0.00546D0,  0.00401D0,  0.00289D0,
58081      &     0.00204D0,  0.00145D0,  0.00103D0,  0.00067D0,  0.00045D0,
58082      &     0.00030D0,  0.00018D0,  0.00012D0,  0.00004D0,  0.00001D0,
58083      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58084       DATA (FMRS(2,6,I,22),I=1,49)/
58085      &     5.81063D0,  4.50144D0,  3.48388D0,  2.99716D0,  2.69275D0,
58086      &     2.47752D0,  1.90937D0,  1.46556D0,  1.25149D0,  1.11639D0,
58087      &     1.01845D0,  0.75875D0,  0.55228D0,  0.45248D0,  0.38985D0,
58088      &     0.34573D0,  0.28616D0,  0.23159D0,  0.17950D0,  0.14831D0,
58089      &     0.11099D0,  0.08809D0,  0.07172D0,  0.05628D0,  0.04443D0,
58090      &     0.03495D0,  0.02738D0,  0.02132D0,  0.01642D0,  0.01252D0,
58091      &     0.00947D0,  0.00708D0,  0.00524D0,  0.00384D0,  0.00275D0,
58092      &     0.00194D0,  0.00137D0,  0.00097D0,  0.00062D0,  0.00042D0,
58093      &     0.00028D0,  0.00017D0,  0.00011D0,  0.00004D0,  0.00001D0,
58094      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58095       DATA (FMRS(2,6,I,23),I=1,49)/
58096      &     6.53035D0,  5.02028D0,  3.85558D0,  3.30194D0,  2.95702D0,
58097      &     2.71384D0,  2.07512D0,  1.58008D0,  1.34283D0,  1.19373D0,
58098      &     1.08596D0,  0.80189D0,  0.57834D0,  0.47125D0,  0.40444D0,
58099      &     0.35757D0,  0.29461D0,  0.23726D0,  0.18285D0,  0.15046D0,
58100      &     0.11188D0,  0.08836D0,  0.07162D0,  0.05593D0,  0.04396D0,
58101      &     0.03443D0,  0.02686D0,  0.02084D0,  0.01599D0,  0.01216D0,
58102      &     0.00917D0,  0.00683D0,  0.00504D0,  0.00368D0,  0.00262D0,
58103      &     0.00186D0,  0.00129D0,  0.00092D0,  0.00058D0,  0.00038D0,
58104      &     0.00026D0,  0.00015D0,  0.00010D0,  0.00004D0,  0.00001D0,
58105      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58106       DATA (FMRS(2,6,I,24),I=1,49)/
58107      &     7.24769D0,  5.53321D0,  4.22004D0,  3.59932D0,  3.21397D0,
58108      &     2.94299D0,  2.23445D0,  1.68918D0,  1.42937D0,  1.26671D0,
58109      &     1.14944D0,  0.84202D0,  0.60229D0,  0.48837D0,  0.41766D0,
58110      &     0.36826D0,  0.30216D0,  0.24227D0,  0.18575D0,  0.15227D0,
58111      &     0.11258D0,  0.08849D0,  0.07143D0,  0.05553D0,  0.04345D0,
58112      &     0.03390D0,  0.02636D0,  0.02037D0,  0.01559D0,  0.01181D0,
58113      &     0.00887D0,  0.00659D0,  0.00484D0,  0.00353D0,  0.00252D0,
58114      &     0.00176D0,  0.00124D0,  0.00088D0,  0.00055D0,  0.00037D0,
58115      &     0.00025D0,  0.00014D0,  0.00009D0,  0.00003D0,  0.00001D0,
58116      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58117       DATA (FMRS(2,6,I,25),I=1,49)/
58118      &     8.02203D0,  6.08288D0,  4.60775D0,  3.91431D0,  3.48531D0,
58119      &     3.18439D0,  2.40103D0,  1.80237D0,  1.51875D0,  1.34182D0,
58120      &     1.21461D0,  0.88286D0,  0.62643D0,  0.50552D0,  0.43085D0,
58121      &     0.37888D0,  0.30963D0,  0.24719D0,  0.18858D0,  0.15401D0,
58122      &     0.11322D0,  0.08857D0,  0.07120D0,  0.05510D0,  0.04294D0,
58123      &     0.03336D0,  0.02585D0,  0.01990D0,  0.01519D0,  0.01146D0,
58124      &     0.00858D0,  0.00636D0,  0.00466D0,  0.00338D0,  0.00242D0,
58125      &     0.00168D0,  0.00119D0,  0.00083D0,  0.00052D0,  0.00035D0,
58126      &     0.00023D0,  0.00013D0,  0.00009D0,  0.00003D0,  0.00001D0,
58127      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58128       DATA (FMRS(2,6,I,26),I=1,49)/
58129      &     8.82307D0,  6.64735D0,  5.00295D0,  4.23399D0,  3.75981D0,
58130      &     3.42801D0,  2.56785D0,  1.91480D0,  1.60708D0,  1.41578D0,
58131      &     1.27859D0,  0.92256D0,  0.64966D0,  0.52190D0,  0.44338D0,
58132      &     0.38892D0,  0.31662D0,  0.25175D0,  0.19114D0,  0.15555D0,
58133      &     0.11371D0,  0.08855D0,  0.07090D0,  0.05462D0,  0.04239D0,
58134      &     0.03281D0,  0.02532D0,  0.01944D0,  0.01478D0,  0.01112D0,
58135      &     0.00830D0,  0.00614D0,  0.00448D0,  0.00324D0,  0.00231D0,
58136      &     0.00160D0,  0.00113D0,  0.00079D0,  0.00049D0,  0.00033D0,
58137      &     0.00022D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00001D0,
58138      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58139       DATA (FMRS(2,6,I,27),I=1,49)/
58140      &     9.62987D0,  7.21210D0,  5.39571D0,  4.55043D0,  4.03076D0,
58141      &     3.66794D0,  2.73100D0,  2.02398D0,  1.69250D0,  1.48708D0,
58142      &     1.34010D0,  0.96040D0,  0.67159D0,  0.53727D0,  0.45509D0,
58143      &     0.39827D0,  0.32310D0,  0.25593D0,  0.19347D0,  0.15692D0,
58144      &     0.11411D0,  0.08848D0,  0.07058D0,  0.05414D0,  0.04185D0,
58145      &     0.03228D0,  0.02482D0,  0.01900D0,  0.01440D0,  0.01080D0,
58146      &     0.00804D0,  0.00593D0,  0.00431D0,  0.00312D0,  0.00222D0,
58147      &     0.00152D0,  0.00108D0,  0.00075D0,  0.00046D0,  0.00031D0,
58148      &     0.00020D0,  0.00012D0,  0.00008D0,  0.00003D0,  0.00001D0,
58149      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58150       DATA (FMRS(2,6,I,28),I=1,49)/
58151      &    10.42894D0,  7.76794D0,  5.77982D0,  4.85875D0,  4.29406D0,
58152      &     3.90061D0,  2.88817D0,  2.12844D0,  1.77387D0,  1.55479D0,
58153      &     1.39837D0,  0.99596D0,  0.69200D0,  0.55150D0,  0.46587D0,
58154      &     0.40684D0,  0.32899D0,  0.25970D0,  0.19552D0,  0.15809D0,
58155      &     0.11441D0,  0.08837D0,  0.07023D0,  0.05366D0,  0.04133D0,
58156      &     0.03176D0,  0.02435D0,  0.01859D0,  0.01405D0,  0.01051D0,
58157      &     0.00780D0,  0.00573D0,  0.00416D0,  0.00301D0,  0.00213D0,
58158      &     0.00146D0,  0.00103D0,  0.00071D0,  0.00045D0,  0.00029D0,
58159      &     0.00020D0,  0.00011D0,  0.00008D0,  0.00003D0,  0.00001D0,
58160      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58161       DATA (FMRS(2,6,I,29),I=1,49)/
58162      &    11.27410D0,  8.35239D0,  6.18132D0,  5.17989D0,  4.56762D0,
58163      &     4.14187D0,  3.05014D0,  2.23540D0,  1.85687D0,  1.62366D0,
58164      &     1.45750D0,  1.03178D0,  0.71238D0,  0.56563D0,  0.47653D0,
58165      &     0.41529D0,  0.33476D0,  0.26336D0,  0.19748D0,  0.15919D0,
58166      &     0.11465D0,  0.08820D0,  0.06985D0,  0.05316D0,  0.04080D0,
58167      &     0.03125D0,  0.02388D0,  0.01817D0,  0.01370D0,  0.01022D0,
58168      &     0.00757D0,  0.00554D0,  0.00401D0,  0.00290D0,  0.00205D0,
58169      &     0.00140D0,  0.00098D0,  0.00068D0,  0.00043D0,  0.00028D0,
58170      &     0.00019D0,  0.00011D0,  0.00007D0,  0.00002D0,  0.00001D0,
58171      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58172       DATA (FMRS(2,6,I,30),I=1,49)/
58173      &    12.14199D0,  8.94909D0,  6.58882D0,  5.50470D0,  4.84361D0,
58174      &     4.38480D0,  3.21222D0,  2.34175D0,  1.93908D0,  1.69167D0,
58175      &     1.51576D0,  1.06678D0,  0.73213D0,  0.57923D0,  0.48674D0,
58176      &     0.42334D0,  0.34023D0,  0.26678D0,  0.19927D0,  0.16016D0,
58177      &     0.11481D0,  0.08798D0,  0.06944D0,  0.05264D0,  0.04025D0,
58178      &     0.03073D0,  0.02343D0,  0.01777D0,  0.01335D0,  0.00994D0,
58179      &     0.00734D0,  0.00536D0,  0.00388D0,  0.00278D0,  0.00196D0,
58180      &     0.00135D0,  0.00094D0,  0.00065D0,  0.00041D0,  0.00027D0,
58181      &     0.00017D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
58182      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58183       DATA (FMRS(2,6,I,31),I=1,49)/
58184      &    13.00875D0,  9.54182D0,  6.99142D0,  5.82458D0,  5.11479D0,
58185      &     4.62308D0,  3.37031D0,  2.44489D0,  2.01852D0,  1.75723D0,
58186      &     1.57179D0,  1.10022D0,  0.75086D0,  0.59207D0,  0.49634D0,
58187      &     0.43089D0,  0.34532D0,  0.26994D0,  0.20090D0,  0.16103D0,
58188      &     0.11492D0,  0.08774D0,  0.06903D0,  0.05213D0,  0.03973D0,
58189      &     0.03024D0,  0.02300D0,  0.01739D0,  0.01303D0,  0.00968D0,
58190      &     0.00712D0,  0.00520D0,  0.00375D0,  0.00268D0,  0.00188D0,
58191      &     0.00130D0,  0.00090D0,  0.00063D0,  0.00039D0,  0.00025D0,
58192      &     0.00016D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
58193      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58194       DATA (FMRS(2,6,I,32),I=1,49)/
58195      &    13.85388D0, 10.11672D0,  7.37984D0,  6.13221D0,  5.37500D0,
58196      &     4.85130D0,  3.52087D0,  2.54252D0,  2.09344D0,  1.81889D0,
58197      &     1.62437D0,  1.13136D0,  0.76814D0,  0.60383D0,  0.50509D0,
58198      &     0.43774D0,  0.34990D0,  0.27275D0,  0.20231D0,  0.16173D0,
58199      &     0.11495D0,  0.08745D0,  0.06859D0,  0.05162D0,  0.03921D0,
58200      &     0.02977D0,  0.02256D0,  0.01702D0,  0.01273D0,  0.00943D0,
58201      &     0.00693D0,  0.00505D0,  0.00364D0,  0.00260D0,  0.00181D0,
58202      &     0.00125D0,  0.00086D0,  0.00060D0,  0.00037D0,  0.00024D0,
58203      &     0.00016D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
58204      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58205       DATA (FMRS(2,6,I,33),I=1,49)/
58206      &    14.75398D0, 10.72621D0,  7.78974D0,  6.45599D0,  5.64833D0,
58207      &     5.09068D0,  3.67806D0,  2.64398D0,  2.17108D0,  1.88265D0,
58208      &     1.67867D0,  1.16335D0,  0.78579D0,  0.61581D0,  0.51399D0,
58209      &     0.44470D0,  0.35453D0,  0.27558D0,  0.20373D0,  0.16245D0,
58210      &     0.11497D0,  0.08717D0,  0.06816D0,  0.05112D0,  0.03871D0,
58211      &     0.02930D0,  0.02213D0,  0.01666D0,  0.01243D0,  0.00919D0,
58212      &     0.00674D0,  0.00490D0,  0.00353D0,  0.00251D0,  0.00175D0,
58213      &     0.00120D0,  0.00083D0,  0.00058D0,  0.00036D0,  0.00023D0,
58214      &     0.00015D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
58215      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58216       DATA (FMRS(2,6,I,34),I=1,49)/
58217      &    15.65461D0, 11.33290D0,  8.19558D0,  6.77553D0,  5.91747D0,
58218      &     5.32596D0,  3.83165D0,  2.74249D0,  2.24617D0,  1.94414D0,
58219      &     1.73088D0,  1.19385D0,  0.80244D0,  0.62703D0,  0.52226D0,
58220      &     0.45111D0,  0.35875D0,  0.27811D0,  0.20493D0,  0.16299D0,
58221      &     0.11490D0,  0.08681D0,  0.06768D0,  0.05059D0,  0.03819D0,
58222      &     0.02883D0,  0.02172D0,  0.01631D0,  0.01213D0,  0.00895D0,
58223      &     0.00656D0,  0.00475D0,  0.00341D0,  0.00243D0,  0.00169D0,
58224      &     0.00116D0,  0.00080D0,  0.00055D0,  0.00034D0,  0.00022D0,
58225      &     0.00015D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
58226      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58227       DATA (FMRS(2,6,I,35),I=1,49)/
58228      &    16.55734D0, 11.93842D0,  8.59892D0,  7.09231D0,  6.18381D0,
58229      &     5.55847D0,  3.98278D0,  2.83900D0,  2.31954D0,  2.00411D0,
58230      &     1.78173D0,  1.22341D0,  0.81850D0,  0.63782D0,  0.53020D0,
58231      &     0.45726D0,  0.36278D0,  0.28052D0,  0.20606D0,  0.16351D0,
58232      &     0.11482D0,  0.08647D0,  0.06722D0,  0.05009D0,  0.03770D0,
58233      &     0.02838D0,  0.02133D0,  0.01598D0,  0.01187D0,  0.00873D0,
58234      &     0.00639D0,  0.00462D0,  0.00330D0,  0.00235D0,  0.00163D0,
58235      &     0.00111D0,  0.00077D0,  0.00053D0,  0.00033D0,  0.00021D0,
58236      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
58237      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58238       DATA (FMRS(2,6,I,36),I=1,49)/
58239      &    17.43806D0, 12.52661D0,  8.98898D0,  7.39784D0,  6.44021D0,
58240      &     5.78196D0,  4.12737D0,  2.93087D0,  2.38917D0,  2.06088D0,
58241      &     1.82979D0,  1.25117D0,  0.83346D0,  0.64781D0,  0.53752D0,
58242      &     0.46291D0,  0.36645D0,  0.28268D0,  0.20706D0,  0.16393D0,
58243      &     0.11470D0,  0.08612D0,  0.06676D0,  0.04960D0,  0.03723D0,
58244      &     0.02796D0,  0.02096D0,  0.01566D0,  0.01161D0,  0.00852D0,
58245      &     0.00623D0,  0.00449D0,  0.00321D0,  0.00227D0,  0.00158D0,
58246      &     0.00107D0,  0.00074D0,  0.00051D0,  0.00031D0,  0.00020D0,
58247      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
58248      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58249       DATA (FMRS(2,6,I,37),I=1,49)/
58250      &    18.35067D0, 13.13351D0,  9.38971D0,  7.71095D0,  6.70247D0,
58251      &     6.01024D0,  4.27436D0,  3.02381D0,  2.45940D0,  2.11802D0,
58252      &     1.87806D0,  1.27887D0,  0.84828D0,  0.65765D0,  0.54469D0,
58253      &     0.46841D0,  0.37001D0,  0.28475D0,  0.20797D0,  0.16429D0,
58254      &     0.11453D0,  0.08573D0,  0.06628D0,  0.04909D0,  0.03675D0,
58255      &     0.02752D0,  0.02059D0,  0.01535D0,  0.01135D0,  0.00831D0,
58256      &     0.00606D0,  0.00437D0,  0.00311D0,  0.00220D0,  0.00153D0,
58257      &     0.00103D0,  0.00072D0,  0.00049D0,  0.00030D0,  0.00019D0,
58258      &     0.00013D0,  0.00007D0,  0.00005D0,  0.00001D0,  0.00000D0,
58259      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58260       DATA (FMRS(2,6,I,38),I=1,49)/
58261      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58262      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58263      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58264      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58265      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58266      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58267      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58268      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58269      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58270      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58271       DATA (FMRS(2,7,I, 1),I=1,49)/
58272      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58273      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58274      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58275      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58276      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58277      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58278      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58279      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58280      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58281      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58282       DATA (FMRS(2,7,I, 2),I=1,49)/
58283      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58284      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58285      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58286      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58287      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58288      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58289      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58290      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58291      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58292      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58293       DATA (FMRS(2,7,I, 3),I=1,49)/
58294      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58295      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58296      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58297      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58298      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58299      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58300      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58301      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58302      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58303      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58304       DATA (FMRS(2,7,I, 4),I=1,49)/
58305      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58306      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58307      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58308      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58309      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58310      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58311      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58312      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58313      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58314      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58315       DATA (FMRS(2,7,I, 5),I=1,49)/
58316      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58317      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58318      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58319      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58320      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58321      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58322      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58323      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58324      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58325      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58326       DATA (FMRS(2,7,I, 6),I=1,49)/
58327      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58328      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58329      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58330      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58331      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58332      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58333      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58334      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58335      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58336      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58337       DATA (FMRS(2,7,I, 7),I=1,49)/
58338      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58339      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58340      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58341      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58342      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58343      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58344      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58345      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58346      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58347      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58348       DATA (FMRS(2,7,I, 8),I=1,49)/
58349      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58350      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58351      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58352      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58353      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58354      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58355      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58356      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58357      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58358      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58359       DATA (FMRS(2,7,I, 9),I=1,49)/
58360      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58361      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58362      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58363      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58364      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58365      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58366      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58367      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58368      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58369      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58370       DATA (FMRS(2,7,I,10),I=1,49)/
58371      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58372      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58373      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58374      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58375      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58376      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58377      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58378      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58379      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58380      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58381       DATA (FMRS(2,7,I,11),I=1,49)/
58382      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58383      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58384      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58385      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58386      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58387      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58388      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58389      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58390      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58391      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58392       DATA (FMRS(2,7,I,12),I=1,49)/
58393      &     0.00041D0,  0.00036D0,  0.00032D0,  0.00030D0,  0.00028D0,
58394      &     0.00027D0,  0.00023D0,  0.00021D0,  0.00019D0,  0.00018D0,
58395      &     0.00017D0,  0.00014D0,  0.00012D0,  0.00011D0,  0.00010D0,
58396      &     0.00009D0,  0.00008D0,  0.00007D0,  0.00006D0,  0.00005D0,
58397      &     0.00004D0,  0.00004D0,  0.00003D0,  0.00003D0,  0.00003D0,
58398      &     0.00003D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
58399      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
58400      &     0.00001D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
58401      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58402      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58403       DATA (FMRS(2,7,I,13),I=1,49)/
58404      &     0.21131D0,  0.16558D0,  0.12967D0,  0.11232D0,  0.10141D0,
58405      &     0.09365D0,  0.07296D0,  0.05647D0,  0.04835D0,  0.04314D0,
58406      &     0.03929D0,  0.02893D0,  0.02049D0,  0.01636D0,  0.01376D0,
58407      &     0.01193D0,  0.00947D0,  0.00725D0,  0.00522D0,  0.00409D0,
58408      &     0.00289D0,  0.00226D0,  0.00187D0,  0.00153D0,  0.00127D0,
58409      &     0.00106D0,  0.00087D0,  0.00071D0,  0.00058D0,  0.00046D0,
58410      &     0.00037D0,  0.00028D0,  0.00022D0,  0.00016D0,  0.00012D0,
58411      &     0.00009D0,  0.00007D0,  0.00005D0,  0.00003D0,  0.00002D0,
58412      &     0.00001D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
58413      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58414       DATA (FMRS(2,7,I,14),I=1,49)/
58415      &     0.61374D0,  0.47881D0,  0.37330D0,  0.32254D0,  0.29066D0,
58416      &     0.26804D0,  0.20788D0,  0.16016D0,  0.13675D0,  0.12177D0,
58417      &     0.11072D0,  0.08109D0,  0.05711D0,  0.04545D0,  0.03813D0,
58418      &     0.03299D0,  0.02611D0,  0.01996D0,  0.01434D0,  0.01121D0,
58419      &     0.00789D0,  0.00617D0,  0.00509D0,  0.00414D0,  0.00341D0,
58420      &     0.00282D0,  0.00231D0,  0.00188D0,  0.00151D0,  0.00120D0,
58421      &     0.00094D0,  0.00073D0,  0.00056D0,  0.00042D0,  0.00031D0,
58422      &     0.00023D0,  0.00016D0,  0.00012D0,  0.00008D0,  0.00005D0,
58423      &     0.00003D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58424      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58425       DATA (FMRS(2,7,I,15),I=1,49)/
58426      &     0.99259D0,  0.76862D0,  0.59480D0,  0.51168D0,  0.45967D0,
58427      &     0.42287D0,  0.32549D0,  0.24886D0,  0.21152D0,  0.18775D0,
58428      &     0.17025D0,  0.12366D0,  0.08636D0,  0.06840D0,  0.05719D0,
58429      &     0.04937D0,  0.03895D0,  0.02967D0,  0.02125D0,  0.01657D0,
58430      &     0.01162D0,  0.00903D0,  0.00740D0,  0.00597D0,  0.00488D0,
58431      &     0.00399D0,  0.00325D0,  0.00263D0,  0.00210D0,  0.00166D0,
58432      &     0.00130D0,  0.00100D0,  0.00076D0,  0.00057D0,  0.00042D0,
58433      &     0.00031D0,  0.00022D0,  0.00015D0,  0.00011D0,  0.00007D0,
58434      &     0.00004D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58435      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58436       DATA (FMRS(2,7,I,16),I=1,49)/
58437      &     1.40334D0,  1.07950D0,  0.82983D0,  0.71109D0,  0.63704D0,
58438      &     0.58478D0,  0.44710D0,  0.33953D0,  0.28741D0,  0.25436D0,
58439      &     0.23011D0,  0.16589D0,  0.11498D0,  0.09067D0,  0.07559D0,
58440      &     0.06510D0,  0.05120D0,  0.03889D0,  0.02777D0,  0.02161D0,
58441      &     0.01509D0,  0.01166D0,  0.00950D0,  0.00760D0,  0.00617D0,
58442      &     0.00501D0,  0.00405D0,  0.00325D0,  0.00258D0,  0.00203D0,
58443      &     0.00158D0,  0.00121D0,  0.00091D0,  0.00068D0,  0.00050D0,
58444      &     0.00037D0,  0.00026D0,  0.00018D0,  0.00012D0,  0.00008D0,
58445      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58446      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58447       DATA (FMRS(2,7,I,17),I=1,49)/
58448      &     1.88020D0,  1.43681D0,  1.09723D0,  0.93659D0,  0.83676D0,
58449      &     0.76647D0,  0.58212D0,  0.43908D0,  0.37019D0,  0.32667D0,
58450      &     0.29484D0,  0.21099D0,  0.14515D0,  0.11396D0,  0.09473D0,
58451      &     0.08141D0,  0.06382D0,  0.04833D0,  0.03440D0,  0.02672D0,
58452      &     0.01856D0,  0.01428D0,  0.01156D0,  0.00918D0,  0.00739D0,
58453      &     0.00596D0,  0.00478D0,  0.00381D0,  0.00301D0,  0.00236D0,
58454      &     0.00181D0,  0.00138D0,  0.00104D0,  0.00077D0,  0.00057D0,
58455      &     0.00041D0,  0.00030D0,  0.00020D0,  0.00014D0,  0.00009D0,
58456      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58457      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58458       DATA (FMRS(2,7,I,18),I=1,49)/
58459      &     2.30534D0,  1.75221D0,  1.33088D0,  1.13244D0,  1.00946D0,
58460      &     0.92305D0,  0.69723D0,  0.52301D0,  0.43952D0,  0.38693D0,
58461      &     0.34856D0,  0.24795D0,  0.16954D0,  0.13265D0,  0.11000D0,
58462      &     0.09436D0,  0.07379D0,  0.05574D0,  0.03958D0,  0.03067D0,
58463      &     0.02123D0,  0.01626D0,  0.01309D0,  0.01033D0,  0.00826D0,
58464      &     0.00663D0,  0.00529D0,  0.00419D0,  0.00329D0,  0.00257D0,
58465      &     0.00197D0,  0.00150D0,  0.00112D0,  0.00083D0,  0.00061D0,
58466      &     0.00044D0,  0.00032D0,  0.00022D0,  0.00015D0,  0.00009D0,
58467      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58468      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58469       DATA (FMRS(2,7,I,19),I=1,49)/
58470      &     2.86856D0,  2.16633D0,  1.63487D0,  1.38587D0,  1.23207D0,
58471      &     1.12426D0,  0.84372D0,  0.62876D0,  0.52633D0,  0.46206D0,
58472      &     0.41530D0,  0.29334D0,  0.19914D0,  0.15517D0,  0.12832D0,
58473      &     0.10984D0,  0.08563D0,  0.06450D0,  0.04565D0,  0.03529D0,
58474      &     0.02431D0,  0.01851D0,  0.01482D0,  0.01161D0,  0.00922D0,
58475      &     0.00734D0,  0.00582D0,  0.00458D0,  0.00358D0,  0.00278D0,
58476      &     0.00212D0,  0.00160D0,  0.00119D0,  0.00088D0,  0.00064D0,
58477      &     0.00047D0,  0.00033D0,  0.00023D0,  0.00015D0,  0.00009D0,
58478      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58479      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58480       DATA (FMRS(2,7,I,20),I=1,49)/
58481      &     3.42748D0,  2.57399D0,  1.93167D0,  1.63211D0,  1.44759D0,
58482      &     1.31854D0,  0.98395D0,  0.72909D0,  0.60825D0,  0.53267D0,
58483      &     0.47783D0,  0.33544D0,  0.22632D0,  0.17572D0,  0.14495D0,
58484      &     0.12384D0,  0.09630D0,  0.07234D0,  0.05105D0,  0.03938D0,
58485      &     0.02701D0,  0.02047D0,  0.01631D0,  0.01268D0,  0.01001D0,
58486      &     0.00793D0,  0.00625D0,  0.00489D0,  0.00380D0,  0.00294D0,
58487      &     0.00223D0,  0.00168D0,  0.00125D0,  0.00091D0,  0.00066D0,
58488      &     0.00048D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
58489      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58490      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58491       DATA (FMRS(2,7,I,21),I=1,49)/
58492      &     3.95907D0,  2.95830D0,  2.20894D0,  1.86088D0,  1.64705D0,
58493      &     1.49778D0,  1.11204D0,  0.81980D0,  0.68185D0,  0.59583D0,
58494      &     0.53354D0,  0.37251D0,  0.24993D0,  0.19343D0,  0.15921D0,
58495      &     0.13581D0,  0.10535D0,  0.07895D0,  0.05557D0,  0.04278D0,
58496      &     0.02922D0,  0.02205D0,  0.01748D0,  0.01352D0,  0.01061D0,
58497      &     0.00835D0,  0.00655D0,  0.00511D0,  0.00395D0,  0.00304D0,
58498      &     0.00230D0,  0.00172D0,  0.00128D0,  0.00093D0,  0.00067D0,
58499      &     0.00049D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
58500      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58501      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58502       DATA (FMRS(2,7,I,22),I=1,49)/
58503      &     4.70301D0,  3.49223D0,  2.59131D0,  2.17500D0,  1.92006D0,
58504      &     1.74251D0,  1.28559D0,  0.94171D0,  0.78029D0,  0.68000D0,
58505      &     0.60759D0,  0.42132D0,  0.28074D0,  0.21641D0,  0.17764D0,
58506      &     0.15121D0,  0.11695D0,  0.08738D0,  0.06130D0,  0.04706D0,
58507      &     0.03198D0,  0.02400D0,  0.01891D0,  0.01452D0,  0.01131D0,
58508      &     0.00885D0,  0.00690D0,  0.00535D0,  0.00412D0,  0.00314D0,
58509      &     0.00237D0,  0.00177D0,  0.00130D0,  0.00095D0,  0.00068D0,
58510      &     0.00049D0,  0.00036D0,  0.00024D0,  0.00016D0,  0.00009D0,
58511      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58512      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58513       DATA (FMRS(2,7,I,23),I=1,49)/
58514      &     5.46775D0,  4.03669D0,  2.97803D0,  2.49113D0,  2.19384D0,
58515      &     1.98726D0,  1.45764D0,  1.06148D0,  0.87647D0,  0.76190D0,
58516      &     0.67941D0,  0.46817D0,  0.30998D0,  0.23809D0,  0.19493D0,
58517      &     0.16562D0,  0.12774D0,  0.09517D0,  0.06655D0,  0.05097D0,
58518      &     0.03446D0,  0.02573D0,  0.02017D0,  0.01538D0,  0.01190D0,
58519      &     0.00925D0,  0.00718D0,  0.00553D0,  0.00424D0,  0.00322D0,
58520      &     0.00242D0,  0.00179D0,  0.00132D0,  0.00095D0,  0.00069D0,
58521      &     0.00049D0,  0.00036D0,  0.00024D0,  0.00016D0,  0.00009D0,
58522      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58523      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58524       DATA (FMRS(2,7,I,24),I=1,49)/
58525      &     6.21519D0,  4.56429D0,  3.34948D0,  2.79317D0,  2.45443D0,
58526      &     2.21950D0,  1.61934D0,  1.17290D0,  0.96539D0,  0.83728D0,
58527      &     0.74526D0,  0.51062D0,  0.33614D0,  0.25732D0,  0.21020D0,
58528      &     0.17828D0,  0.13715D0,  0.10192D0,  0.07106D0,  0.05428D0,
58529      &     0.03653D0,  0.02714D0,  0.02117D0,  0.01604D0,  0.01234D0,
58530      &     0.00954D0,  0.00736D0,  0.00565D0,  0.00431D0,  0.00326D0,
58531      &     0.00243D0,  0.00180D0,  0.00132D0,  0.00095D0,  0.00068D0,
58532      &     0.00049D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
58533      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58534      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58535       DATA (FMRS(2,7,I,25),I=1,49)/
58536      &     7.03262D0,  5.13776D0,  3.75072D0,  3.11823D0,  2.73413D0,
58537      &     2.46827D0,  1.79141D0,  1.29068D0,  1.05901D0,  0.91641D0,
58538      &     0.81423D0,  0.55475D0,  0.36312D0,  0.27706D0,  0.22581D0,
58539      &     0.19119D0,  0.14672D0,  0.10875D0,  0.07559D0,  0.05760D0,
58540      &     0.03859D0,  0.02852D0,  0.02214D0,  0.01668D0,  0.01276D0,
58541      &     0.00981D0,  0.00753D0,  0.00575D0,  0.00436D0,  0.00329D0,
58542      &     0.00245D0,  0.00180D0,  0.00132D0,  0.00095D0,  0.00068D0,
58543      &     0.00048D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
58544      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58545      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58546       DATA (FMRS(2,7,I,26),I=1,49)/
58547      &     7.86804D0,  5.71947D0,  4.15459D0,  3.44391D0,  3.01342D0,
58548      &     2.71602D0,  1.96133D0,  1.40596D0,  1.15014D0,  0.99314D0,
58549      &     0.88088D0,  0.59694D0,  0.38863D0,  0.29560D0,  0.24039D0,
58550      &     0.20320D0,  0.15555D0,  0.11500D0,  0.07970D0,  0.06059D0,
58551      &     0.04040D0,  0.02973D0,  0.02296D0,  0.01720D0,  0.01308D0,
58552      &     0.01001D0,  0.00765D0,  0.00581D0,  0.00439D0,  0.00330D0,
58553      &     0.00245D0,  0.00180D0,  0.00131D0,  0.00094D0,  0.00067D0,
58554      &     0.00048D0,  0.00034D0,  0.00024D0,  0.00016D0,  0.00009D0,
58555      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58556      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58557       DATA (FMRS(2,7,I,27),I=1,49)/
58558      &     8.71308D0,  6.30440D0,  4.55822D0,  3.76823D0,  3.29083D0,
58559      &     2.96160D0,  2.12868D0,  1.51874D0,  1.23894D0,  1.06767D0,
58560      &     0.94548D0,  0.63752D0,  0.41296D0,  0.31319D0,  0.25418D0,
58561      &     0.21452D0,  0.16385D0,  0.12085D0,  0.08351D0,  0.06334D0,
58562      &     0.04205D0,  0.03081D0,  0.02369D0,  0.01765D0,  0.01336D0,
58563      &     0.01017D0,  0.00773D0,  0.00586D0,  0.00441D0,  0.00330D0,
58564      &     0.00244D0,  0.00178D0,  0.00129D0,  0.00092D0,  0.00066D0,
58565      &     0.00047D0,  0.00034D0,  0.00024D0,  0.00016D0,  0.00009D0,
58566      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58567      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58568       DATA (FMRS(2,7,I,28),I=1,49)/
58569      &     9.54571D0,  6.87720D0,  4.95101D0,  4.08263D0,  3.55902D0,
58570      &     3.19851D0,  2.28903D0,  1.62602D0,  1.32303D0,  1.13803D0,
58571      &     1.00630D0,  0.67540D0,  0.43546D0,  0.32936D0,  0.26680D0,
58572      &     0.22485D0,  0.17138D0,  0.12612D0,  0.08693D0,  0.06579D0,
58573      &     0.04350D0,  0.03173D0,  0.02430D0,  0.01801D0,  0.01357D0,
58574      &     0.01029D0,  0.00779D0,  0.00587D0,  0.00441D0,  0.00329D0,
58575      &     0.00242D0,  0.00177D0,  0.00128D0,  0.00091D0,  0.00065D0,
58576      &     0.00046D0,  0.00033D0,  0.00024D0,  0.00016D0,  0.00009D0,
58577      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58578      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58579       DATA (FMRS(2,7,I,29),I=1,49)/
58580      &    10.42768D0,  7.48069D0,  5.36257D0,  4.41099D0,  3.83846D0,
58581      &     3.44489D0,  2.45481D0,  1.73627D0,  1.40913D0,  1.20986D0,
58582      &     1.06825D0,  0.71372D0,  0.45804D0,  0.34552D0,  0.27937D0,
58583      &     0.23511D0,  0.17881D0,  0.13130D0,  0.09026D0,  0.06816D0,
58584      &     0.04488D0,  0.03260D0,  0.02487D0,  0.01834D0,  0.01375D0,
58585      &     0.01038D0,  0.00783D0,  0.00588D0,  0.00440D0,  0.00327D0,
58586      &     0.00240D0,  0.00175D0,  0.00126D0,  0.00090D0,  0.00063D0,
58587      &     0.00045D0,  0.00033D0,  0.00024D0,  0.00016D0,  0.00009D0,
58588      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58589      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58590       DATA (FMRS(2,7,I,30),I=1,49)/
58591      &    11.32906D0,  8.09395D0,  5.77834D0,  4.74153D0,  4.11903D0,
58592      &     3.69178D0,  2.61985D0,  1.84528D0,  1.49390D0,  1.28038D0,
58593      &     1.12893D0,  0.75094D0,  0.47979D0,  0.36099D0,  0.29135D0,
58594      &     0.24485D0,  0.18584D0,  0.13617D0,  0.09335D0,  0.07035D0,
58595      &     0.04613D0,  0.03338D0,  0.02536D0,  0.01861D0,  0.01389D0,
58596      &     0.01045D0,  0.00785D0,  0.00587D0,  0.00438D0,  0.00324D0,
58597      &     0.00237D0,  0.00172D0,  0.00124D0,  0.00088D0,  0.00062D0,
58598      &     0.00044D0,  0.00032D0,  0.00024D0,  0.00016D0,  0.00009D0,
58599      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58600      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58601       DATA (FMRS(2,7,I,31),I=1,49)/
58602      &    12.23197D0,  8.70533D0,  6.19083D0,  5.06852D0,  4.39601D0,
58603      &     3.93512D0,  2.78170D0,  1.95161D0,  1.57633D0,  1.34878D0,
58604      &     1.18767D0,  0.78675D0,  0.50057D0,  0.37571D0,  0.30272D0,
58605      &     0.25408D0,  0.19247D0,  0.14074D0,  0.09625D0,  0.07237D0,
58606      &     0.04728D0,  0.03408D0,  0.02579D0,  0.01885D0,  0.01401D0,
58607      &     0.01049D0,  0.00785D0,  0.00586D0,  0.00435D0,  0.00321D0,
58608      &     0.00235D0,  0.00170D0,  0.00122D0,  0.00086D0,  0.00061D0,
58609      &     0.00043D0,  0.00031D0,  0.00023D0,  0.00016D0,  0.00009D0,
58610      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58611      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58612       DATA (FMRS(2,7,I,32),I=1,49)/
58613      &    13.10605D0,  9.29397D0,  6.58574D0,  5.38050D0,  4.65963D0,
58614      &     4.16627D0,  2.93446D0,  2.05131D0,  1.65329D0,  1.41245D0,
58615      &     1.24220D0,  0.81972D0,  0.51953D0,  0.38906D0,  0.31298D0,
58616      &     0.26237D0,  0.19840D0,  0.14478D0,  0.09878D0,  0.07413D0,
58617      &     0.04825D0,  0.03465D0,  0.02614D0,  0.01902D0,  0.01408D0,
58618      &     0.01051D0,  0.00784D0,  0.00583D0,  0.00432D0,  0.00318D0,
58619      &     0.00232D0,  0.00167D0,  0.00120D0,  0.00085D0,  0.00060D0,
58620      &     0.00042D0,  0.00031D0,  0.00023D0,  0.00016D0,  0.00009D0,
58621      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58622      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58623       DATA (FMRS(2,7,I,33),I=1,49)/
58624      &    14.04396D0,  9.92333D0,  7.00645D0,  5.71217D0,  4.93947D0,
58625      &     4.41134D0,  3.09586D0,  2.15625D0,  1.73413D0,  1.47923D0,
58626      &     1.29933D0,  0.85413D0,  0.53923D0,  0.40291D0,  0.32360D0,
58627      &     0.27095D0,  0.20451D0,  0.14895D0,  0.10139D0,  0.07594D0,
58628      &     0.04925D0,  0.03524D0,  0.02649D0,  0.01920D0,  0.01416D0,
58629      &     0.01053D0,  0.00783D0,  0.00580D0,  0.00428D0,  0.00315D0,
58630      &     0.00229D0,  0.00165D0,  0.00118D0,  0.00083D0,  0.00058D0,
58631      &     0.00041D0,  0.00030D0,  0.00022D0,  0.00016D0,  0.00009D0,
58632      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58633      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58634       DATA (FMRS(2,7,I,34),I=1,49)/
58635      &    14.97171D0, 10.54223D0,  7.41762D0,  6.03510D0,  5.21118D0,
58636      &     4.64879D0,  3.25111D0,  2.25643D0,  1.81093D0,  1.54244D0,
58637      &     1.35325D0,  0.88628D0,  0.55744D0,  0.41560D0,  0.33329D0,
58638      &     0.27873D0,  0.21001D0,  0.15267D0,  0.10367D0,  0.07749D0,
58639      &     0.05007D0,  0.03571D0,  0.02675D0,  0.01931D0,  0.01419D0,
58640      &     0.01051D0,  0.00779D0,  0.00576D0,  0.00424D0,  0.00311D0,
58641      &     0.00225D0,  0.00162D0,  0.00115D0,  0.00081D0,  0.00057D0,
58642      &     0.00041D0,  0.00030D0,  0.00022D0,  0.00016D0,  0.00009D0,
58643      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58644      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58645       DATA (FMRS(2,7,I,35),I=1,49)/
58646      &    15.90678D0, 11.16388D0,  7.82922D0,  6.35772D0,  5.48225D0,
58647      &     4.88541D0,  3.40531D0,  2.35558D0,  1.88678D0,  1.60477D0,
58648      &     1.40636D0,  0.91783D0,  0.57524D0,  0.42799D0,  0.34272D0,
58649      &     0.28629D0,  0.21535D0,  0.15626D0,  0.10587D0,  0.07899D0,
58650      &     0.05087D0,  0.03616D0,  0.02700D0,  0.01941D0,  0.01421D0,
58651      &     0.01050D0,  0.00776D0,  0.00572D0,  0.00420D0,  0.00307D0,
58652      &     0.00222D0,  0.00159D0,  0.00113D0,  0.00080D0,  0.00056D0,
58653      &     0.00040D0,  0.00029D0,  0.00022D0,  0.00016D0,  0.00009D0,
58654      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58655      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58656       DATA (FMRS(2,7,I,36),I=1,49)/
58657      &    16.81722D0, 11.76659D0,  8.22652D0,  6.66831D0,  5.74271D0,
58658      &     5.11243D0,  3.55252D0,  2.44976D0,  1.95860D0,  1.66366D0,
58659      &     1.45643D0,  0.94739D0,  0.59179D0,  0.43945D0,  0.35142D0,
58660      &     0.29325D0,  0.22023D0,  0.15953D0,  0.10786D0,  0.08033D0,
58661      &     0.05156D0,  0.03654D0,  0.02720D0,  0.01949D0,  0.01422D0,
58662      &     0.01047D0,  0.00772D0,  0.00567D0,  0.00416D0,  0.00303D0,
58663      &     0.00219D0,  0.00157D0,  0.00111D0,  0.00078D0,  0.00055D0,
58664      &     0.00039D0,  0.00029D0,  0.00022D0,  0.00016D0,  0.00009D0,
58665      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58666      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58667       DATA (FMRS(2,7,I,37),I=1,49)/
58668      &    17.75747D0, 12.38637D0,  8.63327D0,  6.98544D0,  6.00814D0,
58669      &     5.34342D0,  3.70158D0,  2.54461D0,  2.03070D0,  1.72263D0,
58670      &     1.50647D0,  0.97674D0,  0.60811D0,  0.45069D0,  0.35992D0,
58671      &     0.30003D0,  0.22496D0,  0.16268D0,  0.10975D0,  0.08160D0,
58672      &     0.05220D0,  0.03687D0,  0.02737D0,  0.01954D0,  0.01421D0,
58673      &     0.01044D0,  0.00767D0,  0.00562D0,  0.00411D0,  0.00299D0,
58674      &     0.00215D0,  0.00154D0,  0.00109D0,  0.00077D0,  0.00053D0,
58675      &     0.00038D0,  0.00028D0,  0.00021D0,  0.00016D0,  0.00009D0,
58676      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
58677      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58678       DATA (FMRS(2,7,I,38),I=1,49)/
58679      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58680      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58681      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58682      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58683      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58684      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58685      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58686      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58687      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
58688      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58689       DATA (FMRS(2,8,I, 1),I=1,49)/
58690      &     0.98494D0,  0.83942D0,  0.71517D0,  0.65113D0,  0.60921D0,
58691      &     0.57857D0,  0.49313D0,  0.42114D0,  0.38478D0,  0.36147D0,
58692      &     0.34532D0,  0.30109D0,  0.26601D0,  0.24883D0,  0.23797D0,
58693      &     0.23013D0,  0.21908D0,  0.20797D0,  0.19531D0,  0.18554D0,
58694      &     0.16898D0,  0.15367D0,  0.13862D0,  0.11992D0,  0.10161D0,
58695      &     0.08421D0,  0.06813D0,  0.05380D0,  0.04148D0,  0.03102D0,
58696      &     0.02276D0,  0.01618D0,  0.01125D0,  0.00763D0,  0.00500D0,
58697      &     0.00317D0,  0.00203D0,  0.00121D0,  0.00069D0,  0.00043D0,
58698      &     0.00027D0,  0.00012D0,  0.00011D0,  0.00003D0,  0.00000D0,
58699      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58700       DATA (FMRS(2,8,I, 2),I=1,49)/
58701      &     0.98889D0,  0.84649D0,  0.72438D0,  0.66122D0,  0.61978D0,
58702      &     0.58944D0,  0.50458D0,  0.43271D0,  0.39626D0,  0.37282D0,
58703      &     0.35655D0,  0.31168D0,  0.27538D0,  0.25719D0,  0.24547D0,
58704      &     0.23690D0,  0.22464D0,  0.21217D0,  0.19794D0,  0.18712D0,
58705      &     0.16930D0,  0.15330D0,  0.13787D0,  0.11894D0,  0.10059D0,
58706      &     0.08325D0,  0.06732D0,  0.05317D0,  0.04104D0,  0.03076D0,
58707      &     0.02264D0,  0.01619D0,  0.01134D0,  0.00776D0,  0.00516D0,
58708      &     0.00334D0,  0.00218D0,  0.00135D0,  0.00080D0,  0.00052D0,
58709      &     0.00034D0,  0.00018D0,  0.00014D0,  0.00004D0,  0.00001D0,
58710      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58711       DATA (FMRS(2,8,I, 3),I=1,49)/
58712      &     1.01222D0,  0.87111D0,  0.74946D0,  0.68626D0,  0.64467D0,
58713      &     0.61416D0,  0.52846D0,  0.45538D0,  0.41806D0,  0.39393D0,
58714      &     0.37708D0,  0.33010D0,  0.29099D0,  0.27082D0,  0.25752D0,
58715      &     0.24766D0,  0.23338D0,  0.21871D0,  0.20204D0,  0.18963D0,
58716      &     0.16990D0,  0.15288D0,  0.13686D0,  0.11759D0,  0.09914D0,
58717      &     0.08186D0,  0.06611D0,  0.05221D0,  0.04030D0,  0.03030D0,
58718      &     0.02237D0,  0.01612D0,  0.01138D0,  0.00788D0,  0.00532D0,
58719      &     0.00353D0,  0.00233D0,  0.00151D0,  0.00092D0,  0.00061D0,
58720      &     0.00042D0,  0.00024D0,  0.00016D0,  0.00005D0,  0.00002D0,
58721      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58722       DATA (FMRS(2,8,I, 4),I=1,49)/
58723      &     1.04476D0,  0.90153D0,  0.77771D0,  0.71324D0,  0.67074D0,
58724      &     0.63953D0,  0.55166D0,  0.47640D0,  0.43777D0,  0.41269D0,
58725      &     0.39507D0,  0.34558D0,  0.30362D0,  0.28161D0,  0.26695D0,
58726      &     0.25601D0,  0.24007D0,  0.22367D0,  0.20514D0,  0.19155D0,
58727      &     0.17043D0,  0.15264D0,  0.13620D0,  0.11664D0,  0.09810D0,
58728      &     0.08084D0,  0.06518D0,  0.05144D0,  0.03971D0,  0.02989D0,
58729      &     0.02211D0,  0.01600D0,  0.01135D0,  0.00790D0,  0.00539D0,
58730      &     0.00362D0,  0.00238D0,  0.00157D0,  0.00098D0,  0.00066D0,
58731      &     0.00045D0,  0.00026D0,  0.00018D0,  0.00006D0,  0.00003D0,
58732      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58733       DATA (FMRS(2,8,I, 5),I=1,49)/
58734      &     1.10026D0,  0.95040D0,  0.82069D0,  0.75308D0,  0.70848D0,
58735      &     0.67571D0,  0.58330D0,  0.50390D0,  0.46299D0,  0.43632D0,
58736      &     0.41743D0,  0.36409D0,  0.31818D0,  0.29384D0,  0.27750D0,
58737      &     0.26527D0,  0.24742D0,  0.22908D0,  0.20853D0,  0.19368D0,
58738      &     0.17108D0,  0.15248D0,  0.13556D0,  0.11567D0,  0.09702D0,
58739      &     0.07977D0,  0.06421D0,  0.05061D0,  0.03905D0,  0.02941D0,
58740      &     0.02179D0,  0.01578D0,  0.01121D0,  0.00787D0,  0.00539D0,
58741      &     0.00363D0,  0.00243D0,  0.00163D0,  0.00101D0,  0.00068D0,
58742      &     0.00046D0,  0.00028D0,  0.00020D0,  0.00007D0,  0.00002D0,
58743      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58744       DATA (FMRS(2,8,I, 6),I=1,49)/
58745      &     1.15923D0,  1.00143D0,  0.86481D0,  0.79358D0,  0.74658D0,
58746      &     0.71202D0,  0.61454D0,  0.53061D0,  0.48723D0,  0.45888D0,
58747      &     0.43867D0,  0.38135D0,  0.33152D0,  0.30491D0,  0.28699D0,
58748      &     0.27355D0,  0.25394D0,  0.23384D0,  0.21150D0,  0.19554D0,
58749      &     0.17166D0,  0.15236D0,  0.13502D0,  0.11484D0,  0.09608D0,
58750      &     0.07883D0,  0.06335D0,  0.04988D0,  0.03847D0,  0.02897D0,
58751      &     0.02148D0,  0.01557D0,  0.01108D0,  0.00781D0,  0.00536D0,
58752      &     0.00363D0,  0.00245D0,  0.00167D0,  0.00103D0,  0.00070D0,
58753      &     0.00046D0,  0.00029D0,  0.00021D0,  0.00007D0,  0.00002D0,
58754      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58755       DATA (FMRS(2,8,I, 7),I=1,49)/
58756      &     1.23248D0,  1.06345D0,  0.91726D0,  0.84109D0,  0.79085D0,
58757      &     0.75393D0,  0.64976D0,  0.56002D0,  0.51357D0,  0.48314D0,
58758      &     0.46132D0,  0.39931D0,  0.34507D0,  0.31602D0,  0.29642D0,
58759      &     0.28173D0,  0.26034D0,  0.23848D0,  0.21438D0,  0.19736D0,
58760      &     0.17224D0,  0.15227D0,  0.13452D0,  0.11404D0,  0.09516D0,
58761      &     0.07789D0,  0.06251D0,  0.04914D0,  0.03786D0,  0.02851D0,
58762      &     0.02113D0,  0.01532D0,  0.01096D0,  0.00772D0,  0.00530D0,
58763      &     0.00360D0,  0.00243D0,  0.00166D0,  0.00104D0,  0.00071D0,
58764      &     0.00048D0,  0.00030D0,  0.00020D0,  0.00008D0,  0.00002D0,
58765      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58766       DATA (FMRS(2,8,I, 8),I=1,49)/
58767      &     1.32548D0,  1.14118D0,  0.98212D0,  0.89937D0,  0.84484D0,
58768      &     0.80478D0,  0.69187D0,  0.59465D0,  0.54428D0,  0.51124D0,
58769      &     0.48741D0,  0.41964D0,  0.36014D0,  0.32825D0,  0.30675D0,
58770      &     0.29065D0,  0.26725D0,  0.24348D0,  0.21747D0,  0.19931D0,
58771      &     0.17288D0,  0.15217D0,  0.13398D0,  0.11319D0,  0.09418D0,
58772      &     0.07689D0,  0.06158D0,  0.04833D0,  0.03719D0,  0.02798D0,
58773      &     0.02073D0,  0.01504D0,  0.01077D0,  0.00760D0,  0.00523D0,
58774      &     0.00355D0,  0.00240D0,  0.00165D0,  0.00105D0,  0.00070D0,
58775      &     0.00048D0,  0.00029D0,  0.00020D0,  0.00007D0,  0.00002D0,
58776      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58777       DATA (FMRS(2,8,I, 9),I=1,49)/
58778      &     1.41996D0,  1.21934D0,  1.04662D0,  0.95694D0,  0.89790D0,
58779      &     0.85457D0,  0.73259D0,  0.62769D0,  0.57336D0,  0.53768D0,
58780      &     0.51185D0,  0.43840D0,  0.37384D0,  0.33927D0,  0.31599D0,
58781      &     0.29859D0,  0.27338D0,  0.24788D0,  0.22018D0,  0.20102D0,
58782      &     0.17344D0,  0.15210D0,  0.13351D0,  0.11246D0,  0.09333D0,
58783      &     0.07602D0,  0.06075D0,  0.04762D0,  0.03659D0,  0.02749D0,
58784      &     0.02036D0,  0.01479D0,  0.01057D0,  0.00748D0,  0.00516D0,
58785      &     0.00349D0,  0.00238D0,  0.00163D0,  0.00104D0,  0.00069D0,
58786      &     0.00047D0,  0.00028D0,  0.00019D0,  0.00006D0,  0.00002D0,
58787      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58788       DATA (FMRS(2,8,I,10),I=1,49)/
58789      &     1.52623D0,  1.30628D0,  1.11753D0,  1.01977D0,  0.95552D0,
58790      &     0.90841D0,  0.77603D0,  0.66243D0,  0.60365D0,  0.56506D0,
58791      &     0.53703D0,  0.45743D0,  0.38751D0,  0.35017D0,  0.32507D0,
58792      &     0.30636D0,  0.27933D0,  0.25214D0,  0.22280D0,  0.20266D0,
58793      &     0.17397D0,  0.15202D0,  0.13306D0,  0.11174D0,  0.09248D0,
58794      &     0.07516D0,  0.05994D0,  0.04691D0,  0.03600D0,  0.02702D0,
58795      &     0.02000D0,  0.01454D0,  0.01039D0,  0.00736D0,  0.00507D0,
58796      &     0.00344D0,  0.00235D0,  0.00162D0,  0.00103D0,  0.00069D0,
58797      &     0.00047D0,  0.00027D0,  0.00019D0,  0.00006D0,  0.00002D0,
58798      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58799       DATA (FMRS(2,8,I,11),I=1,49)/
58800      &     1.61996D0,  1.38242D0,  1.17917D0,  1.07414D0,  1.00521D0,
58801      &     0.95472D0,  0.81307D0,  0.69180D0,  0.62911D0,  0.58797D0,
58802      &     0.55803D0,  0.47313D0,  0.39867D0,  0.35901D0,  0.33241D0,
58803      &     0.31262D0,  0.28411D0,  0.25553D0,  0.22487D0,  0.20396D0,
58804      &     0.17439D0,  0.15196D0,  0.13270D0,  0.11116D0,  0.09180D0,
58805      &     0.07446D0,  0.05929D0,  0.04635D0,  0.03552D0,  0.02665D0,
58806      &     0.01972D0,  0.01433D0,  0.01024D0,  0.00726D0,  0.00500D0,
58807      &     0.00340D0,  0.00233D0,  0.00161D0,  0.00102D0,  0.00069D0,
58808      &     0.00047D0,  0.00027D0,  0.00019D0,  0.00006D0,  0.00002D0,
58809      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58810       DATA (FMRS(2,8,I,12),I=1,49)/
58811      &     1.85147D0,  1.56851D0,  1.32816D0,  1.20469D0,  1.12394D0,
58812      &     1.06494D0,  0.90014D0,  0.75989D0,  0.68768D0,  0.64036D0,
58813      &     0.60582D0,  0.50832D0,  0.42330D0,  0.37835D0,  0.34837D0,
58814      &     0.32616D0,  0.29437D0,  0.26278D0,  0.22928D0,  0.20671D0,
58815      &     0.17525D0,  0.15178D0,  0.13188D0,  0.10989D0,  0.09032D0,
58816      &     0.07294D0,  0.05789D0,  0.04511D0,  0.03448D0,  0.02582D0,
58817      &     0.01907D0,  0.01385D0,  0.00987D0,  0.00700D0,  0.00482D0,
58818      &     0.00328D0,  0.00224D0,  0.00154D0,  0.00100D0,  0.00066D0,
58819      &     0.00045D0,  0.00027D0,  0.00019D0,  0.00006D0,  0.00002D0,
58820      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58821       DATA (FMRS(2,8,I,13),I=1,49)/
58822      &     2.08649D0,  1.75519D0,  1.47580D0,  1.33308D0,  1.24007D0,
58823      &     1.17230D0,  0.98378D0,  0.82434D0,  0.74261D0,  0.68917D0,
58824      &     0.65012D0,  0.54038D0,  0.44535D0,  0.39548D0,  0.36240D0,
58825      &     0.33801D0,  0.30327D0,  0.26901D0,  0.23303D0,  0.20903D0,
58826      &     0.17595D0,  0.15158D0,  0.13113D0,  0.10875D0,  0.08901D0,
58827      &     0.07161D0,  0.05666D0,  0.04403D0,  0.03356D0,  0.02508D0,
58828      &     0.01848D0,  0.01341D0,  0.00954D0,  0.00676D0,  0.00467D0,
58829      &     0.00317D0,  0.00216D0,  0.00148D0,  0.00096D0,  0.00064D0,
58830      &     0.00043D0,  0.00027D0,  0.00018D0,  0.00006D0,  0.00002D0,
58831      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58832       DATA (FMRS(2,8,I,14),I=1,49)/
58833      &     2.39126D0,  1.99450D0,  1.66281D0,  1.49454D0,  1.38536D0,
58834      &     1.30604D0,  1.08660D0,  0.90248D0,  0.80863D0,  0.74747D0,
58835      &     0.70276D0,  0.57787D0,  0.47070D0,  0.41497D0,  0.37825D0,
58836      &     0.35132D0,  0.31319D0,  0.27591D0,  0.23714D0,  0.21153D0,
58837      &     0.17666D0,  0.15129D0,  0.13023D0,  0.10742D0,  0.08751D0,
58838      &     0.07010D0,  0.05525D0,  0.04280D0,  0.03250D0,  0.02426D0,
58839      &     0.01784D0,  0.01291D0,  0.00918D0,  0.00650D0,  0.00451D0,
58840      &     0.00308D0,  0.00210D0,  0.00146D0,  0.00091D0,  0.00061D0,
58841      &     0.00040D0,  0.00024D0,  0.00017D0,  0.00007D0,  0.00002D0,
58842      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58843       DATA (FMRS(2,8,I,15),I=1,49)/
58844      &     2.76033D0,  2.28068D0,  1.88356D0,  1.68366D0,  1.55456D0,
58845      &     1.46111D0,  1.20412D0,  0.99043D0,  0.88227D0,  0.81205D0,
58846      &     0.76076D0,  0.61847D0,  0.49766D0,  0.43549D0,  0.39480D0,
58847      &     0.36513D0,  0.32340D0,  0.28293D0,  0.24126D0,  0.21400D0,
58848      &     0.17728D0,  0.15089D0,  0.12922D0,  0.10598D0,  0.08590D0,
58849      &     0.06852D0,  0.05375D0,  0.04146D0,  0.03141D0,  0.02338D0,
58850      &     0.01716D0,  0.01238D0,  0.00882D0,  0.00618D0,  0.00431D0,
58851      &     0.00292D0,  0.00200D0,  0.00136D0,  0.00088D0,  0.00058D0,
58852      &     0.00038D0,  0.00023D0,  0.00015D0,  0.00006D0,  0.00002D0,
58853      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58854       DATA (FMRS(2,8,I,16),I=1,49)/
58855      &     3.14075D0,  2.57242D0,  2.10607D0,  1.87299D0,  1.72314D0,
58856      &     1.61501D0,  1.31935D0,  1.07560D0,  0.95301D0,  0.87374D0,
58857      &     0.81592D0,  0.65651D0,  0.52253D0,  0.45423D0,  0.40982D0,
58858      &     0.37760D0,  0.33254D0,  0.28915D0,  0.24485D0,  0.21612D0,
58859      &     0.17773D0,  0.15044D0,  0.12821D0,  0.10460D0,  0.08439D0,
58860      &     0.06702D0,  0.05238D0,  0.04027D0,  0.03041D0,  0.02258D0,
58861      &     0.01653D0,  0.01190D0,  0.00847D0,  0.00593D0,  0.00412D0,
58862      &     0.00279D0,  0.00191D0,  0.00129D0,  0.00084D0,  0.00056D0,
58863      &     0.00036D0,  0.00023D0,  0.00014D0,  0.00006D0,  0.00002D0,
58864      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58865       DATA (FMRS(2,8,I,17),I=1,49)/
58866      &     3.57238D0,  2.90007D0,  2.35339D0,  2.08215D0,  1.90855D0,
58867      &     1.78371D0,  1.44428D0,  1.16687D0,  1.02831D0,  0.93907D0,
58868      &     0.87409D0,  0.69611D0,  0.54805D0,  0.47331D0,  0.42502D0,
58869      &     0.39015D0,  0.34166D0,  0.29530D0,  0.24836D0,  0.21814D0,
58870      &     0.17810D0,  0.14991D0,  0.12715D0,  0.10317D0,  0.08284D0,
58871      &     0.06549D0,  0.05101D0,  0.03909D0,  0.02941D0,  0.02178D0,
58872      &     0.01590D0,  0.01142D0,  0.00811D0,  0.00570D0,  0.00393D0,
58873      &     0.00267D0,  0.00181D0,  0.00123D0,  0.00079D0,  0.00053D0,
58874      &     0.00034D0,  0.00022D0,  0.00013D0,  0.00006D0,  0.00001D0,
58875      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58876       DATA (FMRS(2,8,I,18),I=1,49)/
58877      &     3.96850D0,  3.19797D0,  2.57613D0,  2.26945D0,  2.07391D0,
58878      &     1.93368D0,  1.55423D0,  1.24636D0,  1.09346D0,  0.99533D0,
58879      &     0.92399D0,  0.72966D0,  0.56941D0,  0.48914D0,  0.43755D0,
58880      &     0.40046D0,  0.34910D0,  0.30027D0,  0.25115D0,  0.21971D0,
58881      &     0.17833D0,  0.14941D0,  0.12622D0,  0.10197D0,  0.08154D0,
58882      &     0.06423D0,  0.04986D0,  0.03809D0,  0.02858D0,  0.02112D0,
58883      &     0.01538D0,  0.01101D0,  0.00783D0,  0.00549D0,  0.00377D0,
58884      &     0.00256D0,  0.00173D0,  0.00118D0,  0.00076D0,  0.00050D0,
58885      &     0.00033D0,  0.00020D0,  0.00012D0,  0.00005D0,  0.00002D0,
58886      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58887       DATA (FMRS(2,8,I,19),I=1,49)/
58888      &     4.49525D0,  3.59055D0,  2.86699D0,  2.51271D0,  2.28784D0,
58889      &     2.12710D0,  1.69466D0,  1.34689D0,  1.17536D0,  1.06574D0,
58890      &     0.98622D0,  0.77102D0,  0.59540D0,  0.50826D0,  0.45260D0,
58891      &     0.41278D0,  0.35791D0,  0.30610D0,  0.25436D0,  0.22147D0,
58892      &     0.17849D0,  0.14870D0,  0.12502D0,  0.10045D0,  0.07994D0,
58893      &     0.06271D0,  0.04847D0,  0.03689D0,  0.02761D0,  0.02033D0,
58894      &     0.01477D0,  0.01056D0,  0.00749D0,  0.00523D0,  0.00359D0,
58895      &     0.00243D0,  0.00165D0,  0.00112D0,  0.00070D0,  0.00047D0,
58896      &     0.00031D0,  0.00018D0,  0.00012D0,  0.00004D0,  0.00002D0,
58897      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58898       DATA (FMRS(2,8,I,20),I=1,49)/
58899      &     5.00899D0,  3.97007D0,  3.14567D0,  2.74457D0,  2.49097D0,
58900      &     2.31023D0,  1.82640D0,  1.44029D0,  1.25101D0,  1.13051D0,
58901      &     1.04327D0,  0.80852D0,  0.61869D0,  0.52527D0,  0.46592D0,
58902      &     0.42363D0,  0.36563D0,  0.31116D0,  0.25711D0,  0.22294D0,
58903      &     0.17857D0,  0.14803D0,  0.12392D0,  0.09909D0,  0.07852D0,
58904      &     0.06137D0,  0.04727D0,  0.03584D0,  0.02676D0,  0.01965D0,
58905      &     0.01424D0,  0.01018D0,  0.00720D0,  0.00501D0,  0.00343D0,
58906      &     0.00232D0,  0.00157D0,  0.00107D0,  0.00066D0,  0.00045D0,
58907      &     0.00029D0,  0.00018D0,  0.00012D0,  0.00004D0,  0.00001D0,
58908      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58909       DATA (FMRS(2,8,I,21),I=1,49)/
58910      &     5.51448D0,  4.34048D0,  3.41543D0,  2.96790D0,  2.68596D0,
58911      &     2.48552D0,  1.95141D0,  1.52811D0,  1.32176D0,  1.19083D0,
58912      &     1.09623D0,  0.84295D0,  0.63982D0,  0.54059D0,  0.47785D0,
58913      &     0.43329D0,  0.37244D0,  0.31558D0,  0.25945D0,  0.22413D0,
58914      &     0.17852D0,  0.14733D0,  0.12285D0,  0.09781D0,  0.07721D0,
58915      &     0.06012D0,  0.04616D0,  0.03490D0,  0.02597D0,  0.01904D0,
58916      &     0.01376D0,  0.00981D0,  0.00692D0,  0.00481D0,  0.00330D0,
58917      &     0.00222D0,  0.00150D0,  0.00102D0,  0.00064D0,  0.00042D0,
58918      &     0.00028D0,  0.00017D0,  0.00011D0,  0.00004D0,  0.00001D0,
58919      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58920       DATA (FMRS(2,8,I,22),I=1,49)/
58921      &     6.21231D0,  4.84766D0,  3.78177D0,  3.26973D0,  2.94855D0,
58922      &     2.72097D0,  2.11789D0,  1.64406D0,  1.41467D0,  1.26974D0,
58923      &     1.16528D0,  0.88741D0,  0.66681D0,  0.56001D0,  0.49289D0,
58924      &     0.44543D0,  0.38094D0,  0.32104D0,  0.26228D0,  0.22553D0,
58925      &     0.17838D0,  0.14638D0,  0.12146D0,  0.09617D0,  0.07554D0,
58926      &     0.05855D0,  0.04477D0,  0.03372D0,  0.02502D0,  0.01828D0,
58927      &     0.01316D0,  0.00936D0,  0.00658D0,  0.00457D0,  0.00313D0,
58928      &     0.00210D0,  0.00142D0,  0.00097D0,  0.00060D0,  0.00039D0,
58929      &     0.00026D0,  0.00016D0,  0.00010D0,  0.00004D0,  0.00001D0,
58930      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58931       DATA (FMRS(2,8,I,23),I=1,49)/
58932      &     6.92819D0,  5.36347D0,  4.15110D0,  3.57245D0,  3.21096D0,
58933      &     2.95557D0,  2.28227D0,  1.75749D0,  1.50504D0,  1.34618D0,
58934      &     1.23195D0,  0.92986D0,  0.69228D0,  0.57821D0,  0.50690D0,
58935      &     0.45669D0,  0.38876D0,  0.32601D0,  0.26481D0,  0.22674D0,
58936      &     0.17816D0,  0.14541D0,  0.12011D0,  0.09461D0,  0.07396D0,
58937      &     0.05707D0,  0.04348D0,  0.03263D0,  0.02417D0,  0.01758D0,
58938      &     0.01264D0,  0.00894D0,  0.00628D0,  0.00436D0,  0.00298D0,
58939      &     0.00199D0,  0.00135D0,  0.00091D0,  0.00057D0,  0.00037D0,
58940      &     0.00024D0,  0.00015D0,  0.00010D0,  0.00004D0,  0.00001D0,
58941      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58942       DATA (FMRS(2,8,I,24),I=1,49)/
58943      &     7.64199D0,  5.87362D0,  4.51337D0,  3.86793D0,  3.46620D0,
58944      &     3.18314D0,  2.44035D0,  1.86558D0,  1.59069D0,  1.41834D0,
58945      &     1.29468D0,  0.96937D0,  0.71569D0,  0.59480D0,  0.51959D0,
58946      &     0.46683D0,  0.39572D0,  0.33035D0,  0.26693D0,  0.22767D0,
58947      &     0.17780D0,  0.14441D0,  0.11876D0,  0.09309D0,  0.07246D0,
58948      &     0.05571D0,  0.04226D0,  0.03164D0,  0.02333D0,  0.01693D0,
58949      &     0.01213D0,  0.00857D0,  0.00600D0,  0.00415D0,  0.00282D0,
58950      &     0.00189D0,  0.00128D0,  0.00086D0,  0.00054D0,  0.00035D0,
58951      &     0.00022D0,  0.00014D0,  0.00009D0,  0.00003D0,  0.00001D0,
58952      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58953       DATA (FMRS(2,8,I,25),I=1,49)/
58954      &     8.41285D0,  6.42055D0,  4.89893D0,  4.18106D0,  3.73585D0,
58955      &     3.42298D0,  2.60571D0,  1.97779D0,  1.67919D0,  1.49264D0,
58956      &     1.35909D0,  1.00958D0,  0.73928D0,  0.61142D0,  0.53225D0,
58957      &     0.47690D0,  0.40260D0,  0.33461D0,  0.26898D0,  0.22853D0,
58958      &     0.17741D0,  0.14339D0,  0.11741D0,  0.09159D0,  0.07099D0,
58959      &     0.05437D0,  0.04108D0,  0.03067D0,  0.02252D0,  0.01631D0,
58960      &     0.01165D0,  0.00822D0,  0.00574D0,  0.00396D0,  0.00268D0,
58961      &     0.00180D0,  0.00120D0,  0.00081D0,  0.00050D0,  0.00033D0,
58962      &     0.00021D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00001D0,
58963      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58964       DATA (FMRS(2,8,I,26),I=1,49)/
58965      &     9.21054D0,  6.98238D0,  5.29207D0,  4.49895D0,  4.00873D0,
58966      &     3.66510D0,  2.77134D0,  2.08927D0,  1.76669D0,  1.56583D0,
58967      &     1.42235D0,  1.04868D0,  0.76198D0,  0.62728D0,  0.54426D0,
58968      &     0.48640D0,  0.40901D0,  0.33853D0,  0.27078D0,  0.22922D0,
58969      &     0.17691D0,  0.14232D0,  0.11604D0,  0.09010D0,  0.06954D0,
58970      &     0.05305D0,  0.03996D0,  0.02972D0,  0.02176D0,  0.01572D0,
58971      &     0.01122D0,  0.00790D0,  0.00548D0,  0.00378D0,  0.00255D0,
58972      &     0.00171D0,  0.00115D0,  0.00078D0,  0.00048D0,  0.00031D0,
58973      &     0.00020D0,  0.00012D0,  0.00008D0,  0.00002D0,  0.00001D0,
58974      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58975       DATA (FMRS(2,8,I,27),I=1,49)/
58976      &    10.01421D0,  7.54466D0,  5.68289D0,  4.81371D0,  4.27818D0,
58977      &     3.90363D0,  2.93340D0,  2.19757D0,  1.85131D0,  1.63639D0,
58978      &     1.48318D0,  1.08596D0,  0.78341D0,  0.64217D0,  0.55547D0,
58979      &     0.49525D0,  0.41494D0,  0.34210D0,  0.27239D0,  0.22977D0,
58980      &     0.17638D0,  0.14126D0,  0.11473D0,  0.08869D0,  0.06818D0,
58981      &     0.05182D0,  0.03892D0,  0.02884D0,  0.02107D0,  0.01518D0,
58982      &     0.01082D0,  0.00760D0,  0.00526D0,  0.00363D0,  0.00244D0,
58983      &     0.00163D0,  0.00110D0,  0.00075D0,  0.00046D0,  0.00030D0,
58984      &     0.00019D0,  0.00012D0,  0.00007D0,  0.00002D0,  0.00001D0,
58985      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58986       DATA (FMRS(2,8,I,28),I=1,49)/
58987      &    10.81038D0,  8.09822D0,  6.06522D0,  5.12048D0,  4.54007D0,
58988      &     4.13500D0,  3.08954D0,  2.30121D0,  1.93196D0,  1.70343D0,
58989      &     1.54082D0,  1.12100D0,  0.80336D0,  0.65594D0,  0.56579D0,
58990      &     0.50334D0,  0.42032D0,  0.34528D0,  0.27377D0,  0.23019D0,
58991      &     0.17582D0,  0.14022D0,  0.11347D0,  0.08735D0,  0.06690D0,
58992      &     0.05067D0,  0.03795D0,  0.02804D0,  0.02043D0,  0.01468D0,
58993      &     0.01043D0,  0.00733D0,  0.00506D0,  0.00348D0,  0.00235D0,
58994      &     0.00155D0,  0.00105D0,  0.00071D0,  0.00043D0,  0.00029D0,
58995      &     0.00018D0,  0.00011D0,  0.00007D0,  0.00002D0,  0.00001D0,
58996      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
58997       DATA (FMRS(2,8,I,29),I=1,49)/
58998      &    11.65265D0,  8.68040D0,  6.46494D0,  5.44008D0,  4.81224D0,
58999      &     4.37498D0,  3.25050D0,  2.40736D0,  2.01424D0,  1.77163D0,
59000      &     1.59933D0,  1.15629D0,  0.82328D0,  0.66961D0,  0.57598D0,
59001      &     0.51130D0,  0.42557D0,  0.34836D0,  0.27505D0,  0.23054D0,
59002      &     0.17519D0,  0.13914D0,  0.11219D0,  0.08600D0,  0.06563D0,
59003      &     0.04954D0,  0.03699D0,  0.02726D0,  0.01981D0,  0.01419D0,
59004      &     0.01006D0,  0.00705D0,  0.00487D0,  0.00334D0,  0.00225D0,
59005      &     0.00148D0,  0.00100D0,  0.00068D0,  0.00041D0,  0.00027D0,
59006      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00002D0,  0.00001D0,
59007      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59008       DATA (FMRS(2,8,I,30),I=1,49)/
59009      &    12.51775D0,  9.27489D0,  6.87071D0,  5.76340D0,  5.08688D0,
59010      &     4.61667D0,  3.41161D0,  2.51293D0,  2.09575D0,  1.83900D0,
59011      &     1.65698D0,  1.19078D0,  0.84258D0,  0.68277D0,  0.58574D0,
59012      &     0.51889D0,  0.43052D0,  0.35121D0,  0.27618D0,  0.23078D0,
59013      &     0.17451D0,  0.13804D0,  0.11091D0,  0.08467D0,  0.06438D0,
59014      &     0.04844D0,  0.03605D0,  0.02651D0,  0.01920D0,  0.01373D0,
59015      &     0.00970D0,  0.00677D0,  0.00468D0,  0.00321D0,  0.00215D0,
59016      &     0.00142D0,  0.00096D0,  0.00064D0,  0.00040D0,  0.00026D0,
59017      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00002D0,  0.00001D0,
59018      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59019       DATA (FMRS(2,8,I,31),I=1,49)/
59020      &    13.38188D0,  9.86555D0,  7.27170D0,  6.08188D0,  5.35680D0,
59021      &     4.85378D0,  3.56878D0,  2.61532D0,  2.17453D0,  1.90394D0,
59022      &     1.71244D0,  1.22374D0,  0.86087D0,  0.69518D0,  0.59491D0,
59023      &     0.52599D0,  0.43513D0,  0.35383D0,  0.27719D0,  0.23095D0,
59024      &     0.17383D0,  0.13697D0,  0.10968D0,  0.08342D0,  0.06322D0,
59025      &     0.04742D0,  0.03518D0,  0.02580D0,  0.01865D0,  0.01331D0,
59026      &     0.00937D0,  0.00652D0,  0.00451D0,  0.00308D0,  0.00206D0,
59027      &     0.00136D0,  0.00092D0,  0.00061D0,  0.00038D0,  0.00024D0,
59028      &     0.00016D0,  0.00010D0,  0.00006D0,  0.00002D0,  0.00001D0,
59029      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59030       DATA (FMRS(2,8,I,32),I=1,49)/
59031      &    14.22455D0, 10.43853D0,  7.65861D0,  6.38821D0,  5.61583D0,
59032      &     5.08091D0,  3.71848D0,  2.71227D0,  2.24884D0,  1.96503D0,
59033      &     1.76449D0,  1.25443D0,  0.87775D0,  0.70654D0,  0.60325D0,
59034      &     0.53242D0,  0.43925D0,  0.35613D0,  0.27800D0,  0.23100D0,
59035      &     0.17312D0,  0.13592D0,  0.10849D0,  0.08223D0,  0.06212D0,
59036      &     0.04645D0,  0.03438D0,  0.02514D0,  0.01814D0,  0.01292D0,
59037      &     0.00909D0,  0.00631D0,  0.00435D0,  0.00297D0,  0.00198D0,
59038      &     0.00130D0,  0.00088D0,  0.00059D0,  0.00036D0,  0.00023D0,
59039      &     0.00015D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00000D0,
59040      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59041       DATA (FMRS(2,8,I,33),I=1,49)/
59042      &    15.12220D0, 11.04609D0,  8.06700D0,  6.71068D0,  5.88799D0,
59043      &     5.31921D0,  3.87481D0,  2.81304D0,  2.32586D0,  2.02823D0,
59044      &     1.81825D0,  1.28597D0,  0.89499D0,  0.71812D0,  0.61173D0,
59045      &     0.53894D0,  0.44342D0,  0.35844D0,  0.27882D0,  0.23104D0,
59046      &     0.17241D0,  0.13488D0,  0.10730D0,  0.08105D0,  0.06103D0,
59047      &     0.04549D0,  0.03359D0,  0.02450D0,  0.01765D0,  0.01253D0,
59048      &     0.00880D0,  0.00610D0,  0.00420D0,  0.00286D0,  0.00191D0,
59049      &     0.00125D0,  0.00083D0,  0.00057D0,  0.00034D0,  0.00022D0,
59050      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
59051      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59052       DATA (FMRS(2,8,I,34),I=1,49)/
59053      &    16.02044D0, 11.65091D0,  8.47137D0,  7.02895D0,  6.15599D0,
59054      &     5.55343D0,  4.02757D0,  2.91088D0,  2.40036D0,  2.08916D0,
59055      &     1.86995D0,  1.31603D0,  0.91125D0,  0.72894D0,  0.61960D0,
59056      &     0.54494D0,  0.44718D0,  0.36046D0,  0.27943D0,  0.23094D0,
59057      &     0.17160D0,  0.13377D0,  0.10610D0,  0.07985D0,  0.05994D0,
59058      &     0.04455D0,  0.03282D0,  0.02388D0,  0.01715D0,  0.01216D0,
59059      &     0.00853D0,  0.00590D0,  0.00405D0,  0.00275D0,  0.00184D0,
59060      &     0.00120D0,  0.00080D0,  0.00054D0,  0.00033D0,  0.00021D0,
59061      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
59062      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59063       DATA (FMRS(2,8,I,35),I=1,49)/
59064      &    16.92092D0, 12.25466D0,  8.87333D0,  7.34454D0,  6.42124D0,
59065      &     5.78493D0,  4.17791D0,  3.00675D0,  2.47316D0,  2.14860D0,
59066      &     1.92031D0,  1.34518D0,  0.92693D0,  0.73935D0,  0.62715D0,
59067      &     0.55068D0,  0.45078D0,  0.36238D0,  0.28002D0,  0.23083D0,
59068      &     0.17082D0,  0.13273D0,  0.10496D0,  0.07873D0,  0.05891D0,
59069      &     0.04367D0,  0.03209D0,  0.02331D0,  0.01669D0,  0.01182D0,
59070      &     0.00827D0,  0.00571D0,  0.00391D0,  0.00265D0,  0.00178D0,
59071      &     0.00117D0,  0.00077D0,  0.00052D0,  0.00031D0,  0.00020D0,
59072      &     0.00012D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
59073      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59074       DATA (FMRS(2,8,I,36),I=1,49)/
59075      &    17.79951D0, 12.84117D0,  9.26208D0,  7.64895D0,  6.67663D0,
59076      &     6.00749D0,  4.32176D0,  3.09803D0,  2.54226D0,  2.20489D0,
59077      &     1.96790D0,  1.37254D0,  0.94153D0,  0.74899D0,  0.63410D0,
59078      &     0.55594D0,  0.45404D0,  0.36409D0,  0.28048D0,  0.23067D0,
59079      &     0.17006D0,  0.13172D0,  0.10387D0,  0.07767D0,  0.05796D0,
59080      &     0.04286D0,  0.03142D0,  0.02277D0,  0.01627D0,  0.01150D0,
59081      &     0.00803D0,  0.00554D0,  0.00379D0,  0.00256D0,  0.00172D0,
59082      &     0.00113D0,  0.00074D0,  0.00050D0,  0.00030D0,  0.00019D0,
59083      &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
59084      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59085       DATA (FMRS(2,8,I,37),I=1,49)/
59086      &    18.71000D0, 13.44641D0,  9.66151D0,  7.96092D0,  6.93787D0,
59087      &     6.23483D0,  4.46802D0,  3.19039D0,  2.61196D0,  2.26153D0,
59088      &     2.01571D0,  1.39986D0,  0.95599D0,  0.75847D0,  0.64090D0,
59089      &     0.56106D0,  0.45717D0,  0.36568D0,  0.28085D0,  0.23044D0,
59090      &     0.16924D0,  0.13067D0,  0.10276D0,  0.07660D0,  0.05700D0,
59091      &     0.04204D0,  0.03075D0,  0.02224D0,  0.01586D0,  0.01118D0,
59092      &     0.00780D0,  0.00537D0,  0.00367D0,  0.00247D0,  0.00167D0,
59093      &     0.00108D0,  0.00071D0,  0.00047D0,  0.00029D0,  0.00018D0,
59094      &     0.00011D0,  0.00006D0,  0.00004D0,  0.00002D0,  0.00000D0,
59095      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59096       DATA (FMRS(2,8,I,38),I=1,49)/
59097      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
59098      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
59099      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
59100      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
59101      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
59102      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
59103      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
59104      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
59105      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
59106      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
59107       END
59108 CDECK  ID>, HWUDKL.
59109 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
59110 *-- Author :    Ian Knowles
59111 C-----------------------------------------------------------------------
59112       SUBROUTINE HWUDKL(ID,PMOM,DISP)
59113 C-----------------------------------------------------------------------
59114 C     Given a real or virtual particle, flavour ID and 4-momentum PMOM,
59115 C     returns DISP its distance travelled in mm.
59116 C
59117 C     Modified 16/01/01 by BRW to force particle on mass shell if
59118 C     p^2-m^2 < 10^-10 GeV^2 (rounding errors)
59119 C-----------------------------------------------------------------------
59120       INCLUDE 'herwig65.inc'
59121       DOUBLE PRECISION HWRGEN,PMOM(4),DISP(4),PMOM2,SCALE,OFFSH
59122       INTEGER ID
59123       EXTERNAL HWRGEN
59124       PMOM2=(PMOM(4)+PMOM(3))*(PMOM(4)-PMOM(3))-PMOM(1)**2-PMOM(2)**2
59125       OFFSH=PMOM2-RMASS(ID)**2
59126       IF (OFFSH.LT.1D-10) OFFSH=ZERO
59127       SCALE=-GEV2MM*LOG(HWRGEN(0))/SQRT(OFFSH**2+(PMOM2/DKLTM(ID))**2)
59128       IF (ID.GT.197.AND.ID.LT.203) SCALE=SCALE*EXAG
59129       CALL HWVSCA(4,SCALE,PMOM,DISP)
59130       END
59131 C-----------------------------------------------------------------------
59132 CDECK  ID>, HWUDKS.
59133 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
59134 *-- Author :    Ian Knowles
59135 C-----------------------------------------------------------------------
59136       SUBROUTINE HWUDKS
59137 C-----------------------------------------------------------------------
59138 C     Sets up internal pointers based on the decay table in HWUDAT or as
59139 C     supplied via HWIODK. Computes CoM momenta of two-body decay modes.
59140 C     Particles with long lifetimes or no allowed decay (excepting light
59141 C     b hadrons when CLEO/EURODEC decays requested) are set stable, else
59142 C     calculate DKLTM(I) = mass/width ( = mass * lifetime/hbar).
59143 C     Gives warnings if: a particle has no decay modes or antiparticle's
59144 C     modes are not the charge conjugates of the particles.
59145 C     (N.B. CP violation permits this).
59146 C-----------------------------------------------------------------------
59147       INCLUDE 'herwig65.inc'
59148       DOUBLE PRECISION HWUPCM,HWUAEM,HWUALF,BRSUM,EPS,SCALE,
59149      & BRTMP(NMXDKS),FN,X,W,Q,FAC
59150       INTEGER HWUANT,I,IDKY,LAST,LTMP(NMXMOD),J,L,K,M,N,INDX(NMXMOD),
59151      & IRES,IAPDG,IPART,LR,LP,KPRDLR
59152       LOGICAL BPDK,TOPDKS,MATCH(5),PMATCH(NMXMOD),IFGO
59153       CHARACTER*7 CVETO(2)
59154       CHARACTER*8 CDUM
59155       EXTERNAL HWUPCM,HWUAEM,HWUALF,HWUANT
59156       PARAMETER(EPS=1.E-6)
59157       FN(X,Q,W)=X**4/(((X*X-Q*Q)**2+W*W*(X*X+Q*Q)-2.*W**4)
59158      &               *SQRT(X**4+Q**4+W**4-2.*(X*X*Q*Q+X*X*W*W+Q*Q*W*W)))
59159       WRITE(6,10)
59160   10  FORMAT(/10X,'Checking consistency of decay tables'/)
59161       DKPSET=.TRUE.
59162 C First zero arrays
59163       DO 20 I=1,NMXRES
59164       LSTRT(I)=0
59165   20  NMODES(I)=0
59166       DO 30 I=1,NMXDKS
59167       NPRODS(I)=0
59168       LNEXT(I)=0
59169   30  CMMOM(I)=0
59170       BPDK=BDECAY.NE.'HERW'
59171       DO 180 I=1,NDKYS
59172 C Search for next decaying particle type
59173       IDKY=IDK(I)
59174 C Skip if particle is not recognised or already dealt with
59175       IF (IDKY.EQ.0.OR.IDKY.EQ.20) THEN
59176         WRITE(6,40) I
59177   40    FORMAT(1X,'Line ',I4,': decaying particle not recognised')
59178         GOTO 180
59179       ENDIF
59180       IF (NMODES(IDKY).GT.0) GOTO 180
59181 C Check and include first decay mode, storing a copy
59182       CALL HWDCHK(IDKY,I,IFGO)
59183       IF(IFGO) GOTO 180
59184       LSTRT(IDKY)=I
59185       NMODES(IDKY)=1
59186       BRSUM=BRFRAC(I)
59187       LTMP(1)=I
59188       BRTMP(1)=-BRFRAC(I)
59189       LAST=I
59190 C Sets CMMOM(IDKY) = CoM momentum for first 2-body decay mode I (else 0)
59191       IF (NPRODS(I).EQ.2) CMMOM(I)=
59192      & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,I)),RMASS(IDKPRD(2,I)))
59193 C Include any other decay modes of IDKY
59194       DO 120 J=I+1,NDKYS
59195       IF (IDK(J).EQ.IDKY) THEN
59196 C First see if it is a copy of the same decay channel
59197         IF ((IDKPRD(2,J).GE.1.AND.IDKPRD(2,J).LE.13).OR.
59198      &      (IDKPRD(3,J).GE.1.AND.IDKPRD(3,J).LE.13)) THEN
59199 C Partonic respect order
59200           L=LSTRT(IDKY)
59201           DO 50 K=1,NMODES(IDKY)
59202               IF (IDKPRD(1,L).EQ.IDKPRD(1,J).AND.
59203      &            IDKPRD(2,L).EQ.IDKPRD(2,J).AND.
59204      &            IDKPRD(3,L).EQ.IDKPRD(3,J).AND.
59205      &            IDKPRD(4,L).EQ.IDKPRD(4,J).AND.
59206      &            IDKPRD(5,L).EQ.IDKPRD(5,J)) GOTO 100
59207   50      L=LNEXT(L)
59208         ELSE
59209 C Allow for different order in matching
59210           L=LSTRT(IDKY)
59211           DO 90 K=1,NMODES(IDKY)
59212           DO 60 M=1,5
59213   60      MATCH(M)=.FALSE.
59214           DO 80 M=1,5
59215           DO 70 N=1,5
59216           IF (.NOT.MATCH(N).AND.IDKPRD(N,L).EQ.IDKPRD(M,J)) THEN
59217             MATCH(N)=.TRUE.
59218             GOTO 80
59219           ENDIF
59220   70      CONTINUE
59221   80      CONTINUE
59222           IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
59223      &        MATCH(4).AND.MATCH(5)) GOTO 100
59224   90      L=LNEXT(L)
59225         ENDIF
59226         CALL HWDCHK(IDKY,J,IFGO)
59227         IF(IFGO) GOTO 120
59228         NMODES(IDKY)=NMODES(IDKY)+1
59229         IF (NMODES(IDKY).GT.NMXMOD) THEN
59230           CALL HWWARN('HWUDKS',100)
59231           GOTO 999
59232         ENDIF
59233         LNEXT(LAST)=J
59234         BRSUM=BRSUM+BRFRAC(J)
59235         LTMP(NMODES(IDKY))=J
59236         BRTMP(NMODES(IDKY))=-BRFRAC(J)
59237         LAST=J
59238 C Sets CMMOM(IDKY) = CoM momentum for next 2-body decay mode J (else 0)
59239         IF (NPRODS(J).EQ.2) CMMOM(J)=
59240      &   HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,J)),RMASS(IDKPRD(2,J)))
59241       ENDIF
59242       GOTO 120
59243   100 WRITE(6,110) L,J,BRFRAC(J),NME(J)
59244       BRSUM=BRSUM-BRFRAC(L)+BRFRAC(J)
59245       BRFRAC(L)=BRFRAC(J)
59246       BRTMP(L)=-BRFRAC(L)
59247       NME(L)=NME(J)
59248   110 FORMAT(1X,'Line ',I4,' is the same as line ',I4/
59249      &       1X,'Take BR ',F5.3,' and ME code ',I3,' from second entry')
59250   120 CONTINUE
59251 C Set sum of branching ratios to 1. if necessary
59252       IF (ABS(BRSUM-1.).GT.EPS) THEN
59253         WRITE(6,130) RNAME(IDKY),BRSUM
59254   130   FORMAT(1X,A8,': BR sum =',F8.5)
59255         IF (ABS(BRSUM).LT.EPS) THEN
59256           WRITE(6,140)
59257   140     FORMAT(1X,'Setting particle stable'/)
59258           NMODES(IDKY)=0
59259         ELSE
59260           WRITE(6,150)
59261   150     FORMAT(1X,'Rescaling to 1'/)
59262           SCALE=1./BRSUM
59263           K=LSTRT(IDKY)
59264           DO 160 J=1,NMODES(IDKY)
59265           BRFRAC(K)=SCALE*BRFRAC(K)
59266   160     K=LNEXT(K)
59267         ENDIF
59268       ENDIF
59269 C Sort branching ratios into descending order and rearrange pointers
59270       CALL HWUSOR(BRTMP,NMODES(IDKY),INDX,2)
59271       LSTRT(IDKY)=LTMP(INDX(1))
59272       LNEXT(LTMP(INDX(1)))=LTMP(INDX(1))
59273       DO 170 J=2,NMODES(IDKY)
59274       IF (ABS(BRFRAC(LTMP(INDX(J)))).LT.EPS) THEN
59275         NMODES(IDKY)=J-1
59276         GOTO 175
59277       ENDIF
59278   170 LNEXT(LTMP(INDX(J-1)))=LTMP(INDX(J))
59279   175 LNEXT(LTMP(INDX(NMODES(IDKY))))=LTMP(INDX(NMODES(IDKY)))
59280   180 CONTINUE
59281 C If not a short lived particle with a decay mode then set stable
59282       DO 190 I=1,NRES
59283       IF (.NOT.RSTAB(I).AND.RLTIM(I).LT.PLTCUT.AND.
59284      &    (NMODES(I).GT.0.OR.
59285      &     (BPDK.AND.((I.GE.221.AND.I.LE.231).OR.
59286      &                (I.GE.245.AND.I.LE.254))))) THEN
59287         DKLTM(I)=RLTIM(I)*RMASS(I)/HBAR
59288       ELSE
59289         RSTAB(I)=.TRUE.
59290       ENDIF
59291   190 CONTINUE
59292 C Set up DKLTM for light quarks
59293       DO 200 I=1,5
59294       DKLTM(I)=RMASS(I)**2/VMIN2
59295   200 DKLTM(I+6)=DKLTM(I)
59296 C gluon
59297       DKLTM(13)=RMASS(13)**2/VMIN2
59298 C and diquarks
59299       DO 210 I=109,114
59300       DKLTM(I)=RMASS(I)**2/VMIN2
59301   210 DKLTM(I+6)=DKLTM(I)
59302 C Set up DKLTM for weak bosons
59303       DKLTM(198)=RMASS(198)/GAMW
59304       DKLTM(199)=DKLTM(198)
59305       DKLTM(200)=RMASS(200)/GAMZ
59306       DKLTM(201)=RMASS(201)/GAMH
59307       DKLTM(202)=RMASS(202)/GAMZP
59308 C Set up DKTRM for massive quarks (plus check m_Q > M_W + m_q)
59309       FAC=SWEIN*(FOUR*RMASS(198))**2/HWUAEM(RMASS(198)**2)
59310       IF (.NOT.SUSYIN) THEN
59311         IF (RMASS(6).GT.RMASS(5)+RMASS(198)) THEN
59312           DKLTM(6)=FAC*FN(RMASS(6  ),RMASS(5  ),RMASS(198))
59313      &            /(1-HWUALF(1,RMASS(6))*2*(2*PIFAC**2/3-5/2)/(3*PIFAC))
59314           DKLTM(12)=DKLTM(6)
59315         ELSE
59316           WRITE(6,220) RNAME(6),RNAME(5),RNAME(198)
59317         ENDIF
59318       ENDIF
59319       IF (RMASS(209).GT.RMASS(4)+RMASS(198)) THEN
59320         DKLTM(209)=FAC*FN(RMASS(209),RMASS(4  ),RMASS(198))
59321         DKLTM(215)=DKLTM(209)
59322       ELSE
59323         WRITE(6,220) RNAME(209),RNAME(4),RNAME(198)
59324       ENDIF
59325       IF (RMASS(210).GT.RMASS(209)+RMASS(198)) THEN
59326         DKLTM(210)=FAC*FN(RMASS(210),RMASS(209),RMASS(198))
59327         DKLTM(216)=DKLTM(210)
59328       ELSE
59329         WRITE(6,220) RNAME(210),RNAME(209),RNAME(198)
59330       ENDIF
59331       IF (RMASS(211).GT.RMASS(6)+RMASS(198)) THEN
59332         DKLTM(211)=FAC*FN(RMASS(211),RMASS(6  ),RMASS(198))
59333         DKLTM(217)=DKLTM(211)
59334       ELSE
59335         WRITE(6,220) RNAME(211),RNAME(6),RNAME(198)
59336       ENDIF
59337       IF (RMASS(212).GT.RMASS(211)+RMASS(198)) THEN
59338         DKLTM(212)=FAC*FN(RMASS(212),RMASS(211),RMASS(198))
59339         DKLTM(218)=DKLTM(212)
59340       ELSE
59341         WRITE(6,220) RNAME(212),RNAME(211),RNAME(198)
59342       ENDIF
59343  220  FORMAT(1X,'W not real in the decay: ',A8,' --> ',A8,' + ',A8)
59344 C Now carry out diagnostic checks on decay table
59345       CALL HWDTOP(TOPDKS)
59346       DO 310 IRES=1,NRES
59347       IAPDG=ABS(IDPDG(IRES))
59348 C Do not check (di-)quarks, gauge bosons, higgses or special particles
59349       IF ((IAPDG.GE.1.AND.IAPDG.LE.9).OR.
59350      &    (MOD(IAPDG/10,10).EQ.0.AND.MOD(IAPDG/1000,10).NE.0).OR.
59351      &    (IAPDG.GE.21.AND.IAPDG.LE.26).OR.
59352      &    IAPDG.EQ.32.OR.
59353      &    (IAPDG.GE.35.AND.IAPDG.LE.37).OR.
59354      &    IAPDG.EQ.91.OR.
59355      &    IAPDG.EQ.98.OR.IAPDG.EQ.99) THEN
59356         GOTO 310
59357 C Ignore top hadrons if top decays
59358       ELSEIF(TOPDKS.AND.((IRES.GE.232.AND.IRES.LE.244).OR.
59359      &                   (IRES.GE.255.AND.IRES.LE.264))) THEN
59360         GOTO 310
59361 C Ignore particles not produced in cluster or particle decays
59362       ELSEIF(VTOCDK(IRES).AND.VTORDK(IRES)) THEN
59363         GOTO 310
59364 C Ignore B's if EURO or CLEO decay package used
59365       ELSEIF(((IRES.GE.221.AND.IRES.LE.223).OR.
59366      &        (IRES.GE.245.AND.IRES.LE.247)).AND.BDECAY.NE.'HERW') THEN
59367         WRITE(6,320) BDECAY,RNAME(IRES)
59368 C Check decay modes exist for massive, short lived particles
59369       ELSEIF (NMODES(IRES).EQ.0.AND.RMASS(IRES).NE.ZERO.AND.
59370      &        RLTIM(IRES).LT.PLTCUT) THEN
59371         IF (VTOCDK(IRES)) THEN
59372           CVETO(1)='VETOED '
59373         ELSE
59374           CVETO(1)='ALLOWED'
59375         ENDIF
59376         IF (VTORDK(IRES)) THEN
59377           CVETO(2)='VETOED '
59378         ELSE
59379           CVETO(2)='ALLOWED'
59380         ENDIF
59381         WRITE(6,330) RNAME(IRES),CVETO(1),CVETO(2)
59382 C ignore particles with no modes if massless or long lived
59383       ELSEIF (NMODES(IRES).EQ.0.AND.
59384      &        (RMASS(IRES).EQ.ZERO.OR.RLTIM(IRES).GT.PLTCUT)) THEN
59385         GOTO 310
59386       ELSEIF (IDPDG(IRES).LT.0) THEN
59387 C Antiparticle: check decays are charge conjugates of particle decays
59388         CALL HWUIDT(1,-IDPDG(IRES),IPART,CDUM)
59389         IF (NMODES(IPART).EQ.0) THEN
59390 C Nothing to compare to
59391           WRITE(6,340) RNAME(IPART),RNAME(IRES)
59392         ELSE
59393 C First initialize particle matching array
59394           DO 230 I=1,NMODES(IPART)
59395   230     PMATCH(I)=.FALSE.
59396 C Loop through antiparticle decay modes
59397           LR=LSTRT(IRES)
59398           DO 290 I=1,NMODES(IRES)
59399 C Search for conjugate mode allowing for different particle order
59400           LP=LSTRT(IPART)
59401           DO 270 J=1,NMODES(IPART)
59402           IF (PMATCH(J)) GOTO 270
59403           DO 240 K=1,5
59404   240     MATCH(K)=.FALSE.
59405           DO 260 K=1,5
59406           KPRDLR=HWUANT(IDKPRD(K,LR))
59407           DO 250 L=1,5
59408           IF (.NOT.MATCH(L).AND.KPRDLR.EQ.IDKPRD(L,LP) ) THEN
59409             MATCH(L)=.TRUE.
59410             GOTO 260
59411           ENDIF
59412   250     CONTINUE
59413   260     CONTINUE
59414           IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
59415      &        MATCH(4).AND.MATCH(5)) GOTO 280
59416   270     LP=LNEXT(LP)
59417 C No match found
59418           WRITE(6,350) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5)
59419           GOTO 290
59420 C Match found, check branching ratios and matrix element codes
59421   280     PMATCH(J)=.TRUE.
59422           IF (BRFRAC(LR).NE.BRFRAC(LP))
59423      &     WRITE(6,360) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
59424      &                  BRFRAC(LR),BRFRAC(LP)
59425           IF (NME(LR).NE.NME(LP))
59426      &     WRITE(6,370) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
59427      &                  NME(LR),NME(LP)
59428   290     LR=LNEXT(LR)
59429 C Check for unmatched modes of particle conjugate to antiparticle
59430           LP=LSTRT(IPART)
59431           DO 300 I=1,NMODES(IPART)
59432           IF (.NOT.PMATCH(I))
59433      &     WRITE(6,350) LP,RNAME(IPART),(RNAME(IDKPRD(J,LP)),J=1,5)
59434   300     LP=LNEXT(LP)
59435         ENDIF
59436       ENDIF
59437   310 CONTINUE
59438   320 FORMAT(1X,A8,' decay package to be used for particle ',A8)
59439   330 FORMAT(1X,'No decay modes available for particle ',A8/
59440      & 1X,'Production in cluster decays ',A7,' and particle decays ',A7)
59441   340 FORMAT(1X,A8,' has no modes conjugate to those of ',A8)
59442   350 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
59443      &       1X,'A charge conjugate decay mode does not exist')
59444   360 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
59445      &       1X,'BR ',F5.3,' unequal to that of conjugate mode ',F5.3)
59446   370 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
59447      &       1X,'ME code ',I3,' unequal to that of conjugate mode ',I3)
59448  999  RETURN
59449       END
59450 CDECK  ID>, HWUDPR.
59451 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
59452 *-- Author :    Ian Knowles, Bryan Webber & Kosuke Odagiri
59453 C-----------------------------------------------------------------------
59454       SUBROUTINE HWUDPR
59455 C-----------------------------------------------------------------------
59456 C     Prints out particle properies/decay tables in a number of formats:
59457 C     If (PRNDEF) ASCII to stout
59458 C     If (PRNTEX) LaTeX to the file HW_decays.tex
59459 C                 Paper size and offsets as set in HWUEPR
59460 C                 Uses the package longtable.sty
59461 C                 Designed to be printed as landscape
59462 C     If (PRNWEB) HTML  to the file HW_decays/index.html
59463 C                                            /PART0000001.html etc.
59464 C-----------------------------------------------------------------------
59465       INCLUDE 'herwig65.inc'
59466       INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,IUNITT,IUNTW1,IUNTW2,I,NM,J,K,
59467      & L,M
59468       CHARACTER*1  Z
59469       CHARACTER*2  ZZ,ACHRG
59470       CHARACTER*3  ASPIN(0:10)
59471       CHARACTER*6  BGCOLS(5),TBCOLS(3)
59472       CHARACTER*7  HWUNST,TMPNME
59473       CHARACTER*17 FNAMEP
59474       CHARACTER*33 FNAMEW
59475       COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
59476       EXTERNAL HWUNST
59477       SAVE BGCOLS,TBCOLS,ASPIN
59478       DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
59479       DATA TBCOLS/'ccccff','9966ff','ffff00'/
59480       DATA ASPIN/' 0 ','1/2',' 1 ','3/2',' 2 ','5/2',' 3 ','7/2',
59481      &           ' 4 ','9/2',' 5 '/
59482 C
59483       Z=CHAR(92)
59484       ZZ=Z//Z
59485 C
59486       IUNITT=50
59487       IUNTW1=51
59488       IUNTW2=52
59489 C Open and write out file header information for index file
59490       IF (PRNDEF) THEN
59491         IF (NPRFMT.LE.1) THEN
59492           WRITE (6,10) NRES
59493         ELSE
59494           WRITE (6,20) NRES
59495         END IF
59496       END IF
59497       IF (PRNTEX) THEN
59498         OPEN(IUNITT,STATUS='UNKNOWN',FILE='HW_decays.tex')
59499         IF (NPRFMT.LE.1) THEN
59500           WRITE(IUNITT,30) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,
59501      &     Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,ZZ,Z,Z
59502         ELSE
59503           WRITE(IUNITT,40) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMHOFF,Z,MMVOFF,
59504      &     Z,Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,Z,ZZ,Z,Z
59505         END IF
59506       ENDIF
59507       IF (PRNWEB) THEN
59508         OPEN(IUNTW1,STATUS='UNKNOWN',FILE='HW_decays/index.html')
59509         WRITE(IUNTW1,50) BGCOLS,TBCOLS,NRES,((TBCOLS(I),I=2,3),J=1,7)
59510       ENDIF
59511    10 FORMAT(1H1//15X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'/)
59512    20 FORMAT(1H1//30X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'//
59513      & 5X,'Name        IDPDG   Mass   Chg Spn Lifetime Modes ',
59514      & ' Branching fractions ME codes and decay products')
59515    30 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
59516      & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
59517      & A1,'hoffset   ',I4,'mm ',A1,'voffset    ',I4,'mm'/
59518      & A1,'pagestyle{empty}'/A1,'begin{document}'/
59519      & A1,'begin{center}'/A1,'begin{longtable}{|r|c|r|r|r|r|r|r|}'/
59520      & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
59521      & '& Lifetime & Modes ',A2/A1,'hline'/
59522      & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
59523      & A1,'multicolumn{8}{|c|}{HERWIG 6.5: Table of properties',
59524      & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
59525      & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
59526      & 'Lifetime & Modes ',A2/A1,'hline'/A1,'endfirsthead')
59527    40 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
59528      & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
59529      & A1,'hoffset   ',I4,'mm ',A1,'voffset    ',I4,'mm'/
59530      & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}'/
59531      & A1,'begin{longtable}{|r|c|r|r|r|r|r|r|c|r|ccccc|}'/
59532      & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
59533      & '& Lifetime & Modes & B.R. & M.E. & ' /
59534      & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
59535      & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
59536      & A1,'multicolumn{15}{|c|}{HERWIG 6.5: Table of properties',
59537      & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
59538      & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
59539      & 'Lifetime & Modes & B.R. & M.E. & '/
59540      & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
59541      & A1,'endfirsthead')
59542    50 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
59543      & '<TITLE>HERWIG 6.5 Particle Properties</TITLE>'/'</HEAD>'/
59544      & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
59545      & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>'/
59546      & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>',
59547      & '<TR>'/'<TH COLSPAN=8 BGCOLOR=#',A6,' ALIGN="CENTER">',
59548      & '<A HREF=="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
59549      & 'HERWIG 6.5:</A><FONT COLOR=#',A6,'> Table of properties of',
59550      & ' the ',I3,' particles used</FONT></TH>'/'<TR>'/'<TH></TH>'/
59551      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
59552      & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,'>',
59553      & 'Id PDG</FONT></TH>'/
59554      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
59555      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
59556      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
59557      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
59558      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
59559      & '</TR>')
59560 C Loop through resonances
59561       DO 260 I=1,NRES
59562 C Skip particles that can't be produced or blank lines
59563       IF ((VTOCDK(I).AND.VTORDK(I)).OR.
59564      &    (RNAME(I).EQ.'        ')) GOTO 260
59565 C Open and write out header information for particle file
59566       IF (PRNWEB) THEN
59567         TMPNME = HWUNST(I)
59568         WRITE(FNAMEP,'(A5,A7,A5)') 'PART_',TMPNME,'.html'
59569         WRITE(FNAMEW,'(A,A17)') 'HW_decays/',FNAMEP
59570         OPEN(IUNTW2,STATUS='UNKNOWN',FILE=FNAMEW)
59571         WRITE(IUNTW2,60) RNAME(I),BGCOLS
59572         WRITE(IUNTW2,70) TBCOLS,((TBCOLS(L),L=2,3),M=1,6)
59573       ENDIF
59574    60 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
59575      & '<TITLE>HERWIG 6.5: ',A8,' properties</TITLE>'/'</HEAD>'/
59576      & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
59577      & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>')
59578    70 FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
59579      & '<TR>'/'<TH></TH>'/
59580      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
59581      & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,
59582      & '>Id PDG</FONT></TH>'/
59583      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
59584      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
59585      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
59586      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
59587      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
59588      & '</TR>')
59589 C Trick to output charge in fractions for di/s - quarks
59590       IF ((I.GE.  1.AND.I.LE. 12).OR.(I.GE.109.AND.I.LE.120).OR.
59591      &    (I.GE.209.AND.I.LE.218).OR.(I.GE.401.AND.I.LE.424)) THEN
59592         ACHRG='/3'
59593       ELSE
59594         ACHRG='  '
59595       ENDIF
59596 C Write out special particles with no decay modes
59597       IF (NMODES(I).EQ.0) THEN
59598         IF (PRNDEF) THEN
59599           IF (NPRFMT.LE.1) THEN
59600             WRITE(6,80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
59601      &                  ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
59602           ELSE
59603             WRITE(6,90) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
59604      &                  ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
59605           ENDIF
59606         ENDIF
59607 C Add particle to LaTeX file
59608         IF (PRNTEX) THEN
59609           IF (NPRFMT.LE.1) THEN
59610             WRITE(IUNITT,100) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
59611      &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,ZZ
59612           ELSE
59613             WRITE(IUNITT,110) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
59614      &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,Z,ZZ
59615           ENDIF
59616         ENDIF
59617         IF (PRNWEB) THEN
59618 C Add properties to Web index
59619           WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
59620      &                      IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
59621      &                      ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
59622 C Add properties to Web particle file
59623           WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),
59624      &                      IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
59625      &                      ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
59626         ENDIF
59627    80   FORMAT(/1X,I3,1X,A8,' IDPDG=',I8,', M=',F8.3,', Q=',I2,',  J=',
59628      &   A3,', T=',1P,E9.3,',',I3,' Modes')
59629    90   FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3)
59630   100   FORMAT(A1,'hline',I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,
59631      &   A2,'$ & ',A3,' & $',1P,E9.3,'$ & ',I3,' ',A2)
59632   110   FORMAT(A1,'cline{1-8}'/
59633      &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',A3,
59634      &   ' & $',1P,E9.3,'$ & ',I3,' & ',A1,'multicolumn{7}{|c|}{} ',A2)
59635   120   FORMAT('<TR>'/
59636      &   '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
59637      &   '</FONT></TD>'/
59638      &   '<TD ALIGN="CENTER"><A HREF="',A17,'">',A37,'</A></TD>'/
59639      &   '<TD ALIGN="RIGHT">',I8,'</TD>'/
59640      &   '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
59641      &   '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
59642      &   '<TD ALIGN="RIGHT">',A3,'</TD>'/
59643      &   '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
59644      &   '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>')
59645   130   FORMAT('<TR>'/
59646      &   '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
59647      &   '</FONT></TD>'/
59648      &   '<TD ALIGN="CENTER">',A37,'</TD>'/
59649      &   '<TD ALIGN="RIGHT">',I8,'</TD>'/
59650      &   '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
59651      &   '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
59652      &   '<TD ALIGN="RIGHT">',A3,'</TD>'/
59653      &   '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
59654      &   '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>'/'</TABLE>'/'<P>')
59655       ELSE
59656 C Particle with decay modes
59657         IF (RSTAB(I)) THEN
59658           NM=0
59659         ELSEIF (VTOCDK(I)) THEN
59660           NM=-NMODES(I)
59661         ELSE
59662           NM=NMODES(I)
59663         ENDIF
59664         K=LSTRT(I)
59665 C Write out properties and first decay mode
59666         IF (PRNDEF) THEN
59667           IF (NPRFMT.LE.1) THEN
59668             WRITE(6, 80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
59669      &       ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
59670             WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
59671           ELSE
59672             WRITE(6,150) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
59673      &       ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,BRFRAC(K),NME(K),
59674      &       (RNAME(IDKPRD(L,K)),L=1,5)
59675           ENDIF
59676         ENDIF
59677         IF (PRNTEX) THEN
59678           IF (NPRFMT.LE.1) THEN
59679             WRITE(IUNITT,160) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
59680      &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,ZZ,Z
59681             WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
59682      &       BRFRAC(K),Z,NME(K),ZZ
59683           ELSE
59684             WRITE(IUNITT,180) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
59685      &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,
59686      &       BRFRAC(K),NME(K),(TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ,Z
59687           ENDIF
59688         END IF
59689         IF (PRNWEB) THEN
59690 C Add properties to index
59691           WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
59692      &     IDPDG(I),RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),
59693      &     RLTIM(I),NM
59694 C Add properties to Web particle file
59695           WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),IDPDG(I),
59696      &     RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
59697           WRITE(IUNTW2,190) TBCOLS,TXNAME(2,I),
59698      &     ((TBCOLS(L),L=2,3),M=1,3)
59699           WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),1,BRFRAC(K),NME(K),
59700      &     (TXNAME(2,IDKPRD(L,K)),L=1,5)
59701         ENDIF
59702   140   FORMAT(5X,'BR[ -->',5(1X,A8),']=',F5.3,', ME code',I5)
59703   150   FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3,
59704      &   2X,F5.3,1X,I3,5(1X,A8))
59705   160   FORMAT(A1,'hline',
59706      &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
59707      &   A3,' & $',1P,E9.3,'$ & ',I3,' ',A2/A1,'cline{2-8}')
59708   170   FORMAT(' & & ',A1,'multicolumn{2}{l}{$',A1,'longrightarrow$'/
59709      &   5(A37,' '),'}'/' & ',A1,'multicolumn{2}{l}{BR = ',F5.3,'} & ',
59710      &   A1,'multicolumn{2}{l|}{ME code = ',I3,'} ',A2)
59711   180   FORMAT(A1,'hline'/
59712      &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
59713      &   A3,' & $',1P,E9.3,'$ & ',I3,' & ',F5.3,' & ',I3,
59714      &   5(' & ',A37), ' ',A2/A1,'cline{2-8}')
59715   190   FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/'<TR>'/
59716      &   '<TH COLSPAN=8 BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',A37,
59717      &   ' Decay Modes</FONT></TH>'/'</TR>'/'<TR>'/'<TH></TH>',
59718      &   '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>B.R.</FONT></TH>'/
59719      &   '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>M.E.</FONT></TH>'/
59720      &   '<TH BGCOLOR=#',A6,' ALIGN="CENTER" COLSPAN=5>',
59721      &   '<FONT COLOR=#',A6,'>Decay products</FONT></TH>'/'</TR>')
59722   200   FORMAT('<TR>'/
59723      &   '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',
59724      &   I3,'</FONT></TD>'/
59725      &   '<TD ALIGN="RIGHT">',F5.3,'</TD>'/
59726      &   '<TD ALIGN="RIGHT">',I3,'</TD>'/
59727      &   5('<TD ALIGN="CENTER">',A37,'</TD>'/),'</TR>')
59728 C Write out additional decay modes
59729         IF (NMODES(I).GE.2) THEN
59730           DO 210 J=2,NMODES(I)
59731           K=LNEXT(K)
59732           IF (PRNDEF) THEN
59733             IF (NPRFMT.LE.1) THEN
59734               WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
59735             ELSE
59736               WRITE(6,220) BRFRAC(K),NME(K),(RNAME(IDKPRD(L,K)),L=1,5)
59737             END IF
59738           END IF
59739           IF (PRNTEX) THEN
59740             IF (NPRFMT.LE.1) THEN
59741               WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
59742      &         BRFRAC(K),Z,NME(K),ZZ
59743             ELSE
59744               WRITE(IUNITT,230) Z,BRFRAC(K),NME(K),
59745      &         (TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ
59746             ENDIF
59747           ENDIF
59748           IF (PRNWEB) WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),J,
59749      &     BRFRAC(K),NME(K),(TXNAME(2,IDKPRD(L,K)),L=1,5)
59750   210     CONTINUE
59751           IF (PRNTEX.AND.NPRFMT.EQ.2.AND.NMODES(I+1).EQ.0)
59752      &     WRITE(IUNITT,240) Z
59753   220     FORMAT(54X,F5.3,1X,I3,5(1X,A8))
59754   230     FORMAT(' & ',A1,'multicolumn{7}{|c|}{} & ',F5.3,' & ',I3,
59755      &     5(' & ',A37),' ',A2)
59756   240     FORMAT(A1,'hline')
59757         ENDIF
59758       ENDIF
59759 C Close Web particle file
59760       IF (PRNWEB) THEN
59761         WRITE(IUNTW2,250)
59762         CLOSE(IUNTW2)
59763       ENDIF
59764   250 FORMAT('</TABLE>'/'</CENTER>'/'<P>'/
59765      & 'Main particle <A HREF="index.html">index</A>'/
59766      & '</BODY>'/'</HTML>')
59767   260 CONTINUE
59768 C Close the LaTeX file
59769       IF (PRNTEX) THEN
59770         WRITE(IUNITT,270) Z,Z,Z
59771         CLOSE(IUNITT)
59772       ENDIF
59773 C Close the index file
59774       IF (PRNWEB) THEN
59775         WRITE(IUNTW1,280)
59776         CLOSE(IUNTW1)
59777       ENDIF
59778   270 FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
59779   280 FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
59780       END
59781 CDECK  ID>, HWUECM.
59782 *CMZ :-        -29/01/93  11.11.55  by  Bryan Webber
59783 *-- Author :    Giovanni Abbiendi & Luca Stanco
59784 C---------------------------------------------------------------------
59785       FUNCTION HWUECM (S,M1QUAD,M2QUAD)
59786 C-----------------------------------------------------------------------
59787 C     C.M. ENERGY OF A PARTICLE IN 1-->2 BRANCH, MAY BE SPACELIKE
59788 C---------------------------------------------------------------------
59789       IMPLICIT NONE
59790       DOUBLE PRECISION HWUECM,S,M1QUAD,M2QUAD
59791       HWUECM = (S+M1QUAD-M2QUAD)/(2.D0*SQRT(S))
59792       END
59793 CDECK  ID>, HWUEDT.
59794 *CMZ :-        -09/12/91  12.07.08  by  Mike Seymour
59795 *-- Author :    Mike Seymour
59796 C-----------------------------------------------------------------------
59797       SUBROUTINE HWUEDT(N,IEDT)
59798 C-----------------------------------------------------------------------
59799 C     EDIT THE EVENT RECORD
59800 C     IF N>0 DELETE THE N ENTRIES IN IEDT FROM EVENT RECORD
59801 C     IF N<0 INSERT LINES AFTER THE -N ENTRIES IN IEDT
59802 C-----------------------------------------------------------------------
59803       INCLUDE 'herwig65.inc'
59804       INTEGER N,IEDT(*),IMAP(0:NMXHEP),IHEP,I,J,I1,I2
59805       COMMON /HWUMAP/IMAP
59806 C---MOVE ENTRIES AND CALCULATE MAPPING OF POINTERS
59807       IF (N.EQ.0) THEN
59808         RETURN
59809       ELSEIF (N.GT.0) THEN
59810         I=1
59811         I1=1
59812         I2=NHEP
59813       ELSE
59814         I=NHEP-N
59815         I1=NHEP
59816         I2=1
59817       ENDIF
59818       DO 110 IHEP=I1,I2,SIGN(1,I2-I1)
59819         IMAP(IHEP)=I
59820         DO 100 J=1,ABS(N)
59821           IF (IHEP.EQ.IEDT(J)) THEN
59822             IF (N.GT.0) IMAP(IHEP)=0
59823             I=I-1
59824             IF (N.LT.0) IMAP(IHEP)=I
59825           ENDIF
59826  100    CONTINUE
59827         IF (IMAP(IHEP).EQ.I .AND. IHEP.NE.I) THEN
59828           ISTHEP(I)=ISTHEP(IHEP)
59829           IDHW(I)=IDHW(IHEP)
59830           IDHEP(I)=IDHEP(IHEP)
59831           JMOHEP(1,I)=JMOHEP(1,IHEP)
59832           JMOHEP(2,I)=JMOHEP(2,IHEP)
59833           JDAHEP(1,I)=JDAHEP(1,IHEP)
59834           JDAHEP(2,I)=JDAHEP(2,IHEP)
59835           CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,I))
59836           CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
59837           ISTHEP(IHEP)=0
59838           IDHW(IHEP)=20
59839           IDHEP(IHEP)=0
59840           JMOHEP(1,IHEP)=0
59841           JMOHEP(2,IHEP)=0
59842           JDAHEP(1,IHEP)=0
59843           JDAHEP(2,IHEP)=0
59844           CALL HWVZRO(5,PHEP(1,IHEP))
59845           CALL HWVZRO(4,VHEP(1,IHEP))
59846         ENDIF
59847         I=I+SIGN(1,N)
59848  110  CONTINUE
59849       NHEP=NHEP-N
59850 C---RELABEL POINTERS, SETTING ANY WHICH WERE TO DELETED ENTRIES TO ZERO
59851       IMAP(0)=0
59852       DO 200 IHEP=1,NHEP
59853         JMOHEP(1,IHEP)=IMAP(JMOHEP(1,IHEP))
59854         JMOHEP(2,IHEP)=IMAP(JMOHEP(2,IHEP))
59855         JDAHEP(1,IHEP)=IMAP(JDAHEP(1,IHEP))
59856         JDAHEP(2,IHEP)=IMAP(JDAHEP(2,IHEP))
59857  200  CONTINUE
59858       END
59859 CDECK  ID>, HWUEEC.
59860 *CMZ :-        -26/04/91  14.22.30  by  Federico Carminati
59861 *-- Author :    Bryan Webber and Ian Knowles
59862 C-----------------------------------------------------------------------
59863       SUBROUTINE HWUEEC(IL)
59864 C-----------------------------------------------------------------------
59865 C     Loads cross-section coefficients, for kinematically open channels,
59866 C     in llbar-->qqbar; lepton label IL=1-6: e,nu_e,mu,nu_mu,tau,nu_tau.
59867 C-----------------------------------------------------------------------
59868       INCLUDE 'herwig65.inc'
59869       DOUBLE PRECISION Q2
59870       INTEGER IL,JL,IQ
59871       Q2=EMSCA**2
59872       JL=IL+10
59873       MAXFL=0
59874       TQWT=0.
59875       DO 10 IQ=1,NFLAV
59876       IF (EMSCA.GT.2.*RMASS(IQ)) THEN
59877          MAXFL=MAXFL+1
59878          MAPQ(MAXFL)=IQ
59879          CALL HWUCFF(JL,IQ,Q2,CLQ(1,MAXFL))
59880          TQWT=TQWT+CLQ(1,MAXFL)
59881       ENDIF
59882   10  CONTINUE
59883       IF (MAXFL.EQ.0) CALL HWWARN('HWUEEC',100)
59884       END
59885 CDECK  ID>, HWUEMV.
59886 *CMZ :-        -30/06/94  19.31.08  by  Mike Seymour
59887 *-- Author :    Mike Seymour
59888 C-----------------------------------------------------------------------
59889       SUBROUTINE HWUEMV(N,IFROM,ITO)
59890 C-----------------------------------------------------------------------
59891 C     MOVE A BLOCK OF ENTRIES IN THE EVENT RECORD
59892 C     N ENTRIES IN HEPEVT STARTING AT IFROM ARE MOVED TO AFTER ITO
59893 C-----------------------------------------------------------------------
59894       INCLUDE 'herwig65.inc'
59895       INTEGER N,IFROM,ITO,IMAP(0:NMXHEP),LFROM,LTO,I,IEDT(NMXHEP),IHEP,
59896      $ JHEP,KHEP
59897       COMMON /HWUMAP/IMAP
59898       LFROM=IFROM
59899       LTO=ITO
59900       DO 100 I=1,N
59901  100  IEDT(I)=LTO
59902       CALL HWUEDT(-N,IEDT)
59903       DO 300 I=1,N
59904         IHEP=LTO+I
59905         JHEP=IMAP(LFROM+I-1)
59906         ISTHEP(IHEP)=ISTHEP(JHEP)
59907         IDHW(IHEP)=IDHW(JHEP)
59908         IDHEP(IHEP)=IDHEP(JHEP)
59909         JMOHEP(1,IHEP)=JMOHEP(1,JHEP)
59910         JMOHEP(2,IHEP)=JMOHEP(2,JHEP)
59911         JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
59912         JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
59913         CALL HWVEQU(5,PHEP(1,JHEP),PHEP(1,IHEP))
59914         CALL HWVEQU(4,VHEP(1,JHEP),VHEP(1,IHEP))
59915         DO 200 KHEP=1,NHEP
59916           IF (JMOHEP(1,KHEP).EQ.JHEP) JMOHEP(1,KHEP)=IHEP
59917           IF (JMOHEP(2,KHEP).EQ.JHEP) JMOHEP(2,KHEP)=IHEP
59918           IF (JDAHEP(1,KHEP).EQ.JHEP) JDAHEP(1,KHEP)=IHEP
59919           IF (JDAHEP(2,KHEP).EQ.JHEP) JDAHEP(2,KHEP)=IHEP
59920  200    CONTINUE
59921         IEDT(I)=JHEP
59922  300  CONTINUE
59923       CALL HWUEDT(N,IEDT)
59924       END
59925 CDECK  ID>, HWUEPR.
59926 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
59927 *-- Author :    Ian Knowles, Bryan Webber & Kosuke Odagiri
59928 C-----------------------------------------------------------------------
59929       SUBROUTINE HWUEPR
59930 C-----------------------------------------------------------------------
59931 C     Prints out event data in a number of possible formats:
59932 C     If (PRNDEF) ASCII to stout
59933 C     If (PRNTEX) LaTeX to the file HWEV_*******.tex
59934 C                 Please check paper size and offsets given in mm
59935 C                 Uses the package longtable.sty
59936 C                 If (PRVTX>OR.NPRFMT.EQ.2) designed to be printed
59937 C                 as landscape
59938 C     If (PRNWEB) HTML  to the file HWEV_*******.html
59939 C                 Call HWUDPR to create particle property files in
59940 C                 the subdirectory HW_decays/
59941 C     ******* gives the event number 0000001 etc.
59942 C-----------------------------------------------------------------------
59943       INCLUDE 'herwig65.inc'
59944       INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,I,IST,IS,ID,MS,J,K,IUNITW,
59945      & IUNITT
59946       CHARACTER*1 Z
59947       CHARACTER*2 ZZ
59948       CHARACTER*6 BGCOLS(5),TBCOLS(3),THEAD(17,3)
59949       CHARACTER*7 HWUNST,TMPNME
59950       CHARACTER*16 FNAMET
59951       CHARACTER*17 FNAMEW
59952       CHARACTER*27 FNAMEP
59953       CHARACTER*28 TITLE(11),SECTXT
59954       LOGICAL FIRST(11),NEWSEC
59955       COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
59956       EXTERNAL HWUNST
59957 C
59958       SAVE BGCOLS,TBCOLS,THEAD,TITLE
59959       DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
59960       DATA TBCOLS/'ccccff','9966ff','ffff00'/
59961       DATA THEAD/ 17*'9966ff',17*'ffff00',
59962      &            'IHEP  ','  ID  ',' IDPDG',' IST  ',' MO1  ',' MO2  ',
59963      &            ' DA1  ',' DA2  ',' P-X  ',' P-Y  ',' P-Z  ','ENERGY',
59964      &            ' MASS ',' V-X  ',' V-Y  ',' V-Z  ',' V-C*T'/
59965       DATA TITLE/'     ---INITIAL STATE---    ',
59966      &           '    ---HARD SUBPROCESS---   ',
59967      &           '    ---PARTON SHOWERS---    ',
59968      &           '    ---GLUON SPLITTING---   ',
59969      &           '   ---CLUSTER FORMATION---  ',
59970      &           '    ---CLUSTER DECAYS---    ',
59971      &           ' ---STRONG HADRON DECAYS--- ',
59972      &           ' ---HEAVY PARTICLE DECAYS---',
59973      &           '  ---H/W/Z BOSON DECAYS---  ',
59974      &           ' ---SOFT UNDERLYING EVENT---',
59975      &           '  ---MULTIPLE SCATTERING--- '/
59976       Z=CHAR(92)
59977       ZZ=Z//Z
59978 C
59979       IUNITT=50
59980       IUNITW=51
59981 C Write out any required file header information
59982       TMPNME=HWUNST(NEVHEP)
59983       IF (PRNTEX) THEN
59984         WRITE(FNAMET,'(A5,A7,A4)') 'HWEV_',TMPNME,'.tex'
59985         OPEN(IUNITT,STATUS='UNKNOWN',FILE=FNAMET)
59986         IF (PRVTX.OR.NPRFMT.EQ.2) THEN
59987           WRITE(IUNITT,10) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMVOFF,Z,MMHOFF,Z,Z,Z
59988         ELSE
59989           WRITE(IUNITT,10) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,Z,Z,Z
59990         ENDIF
59991       ENDIF
59992       IF (PRNWEB) THEN
59993         WRITE(FNAMEW,'(A5,A7,A5)') 'HWEV_',TMPNME,'.html'
59994         OPEN(IUNITW,STATUS='UNKNOWN',FILE=FNAMEW)
59995         WRITE(IUNITW,20) BGCOLS
59996       ENDIF
59997    10 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
59998      & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
59999      & A1,'hoffset   ',I4,'mm ',A1,'voffset    ',I4,'mm'/
60000      & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}')
60001    20 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
60002      & '<TITLE>HERWIG Event Record</TITLE>'/'</HEAD>'/
60003      & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
60004      & ' ALINK=#',A6,' VLINK=#',A6,'>')
60005 C Write out event header details and set up tables
60006       IF (PRNDEF) THEN
60007         WRITE(6,30) NEVHEP,PBEAM1,PART1,PBEAM2,PART2,
60008      &   IPROC,NRN,ISTAT,IERROR,EVWGT
60009       ENDIF
60010       IF (PRNTEX) THEN
60011         WRITE(IUNITT,40) Z,Z,Z,ISTAT,ZZ,Z,
60012      &   IPROC,PBEAM1,PBEAM2,NRN(1),
60013      &   IERROR,ZZ,Z,Z,NEVHEP,TXNAME(1,IDHW(1)),TXNAME(1,IDHW(2)),
60014      &   NRN(2),EVWGT,ZZ,Z,Z,Z
60015         IF (PRVTX) THEN
60016           WRITE(IUNITT,50) Z,Z,Z,Z,Z
60017         ELSE
60018           WRITE(IUNITT,60) Z,Z,Z,Z,Z
60019         ENDIF
60020       ENDIF
60021       IF (PRNWEB) THEN
60022         WRITE(IUNITW,70) TBCOLS(1),TBCOLS(2),(TBCOLS(2),TBCOLS(3),
60023      &   I=1,4),ISTAT,TBCOLS(2),TBCOLS(3),
60024      &   IPROC,PBEAM1,PBEAM2,NRN(1),
60025      &   TBCOLS(2),TBCOLS(3),IERROR
60026         WRITE(IUNITW,71) TBCOLS(2),TBCOLS(3),NEVHEP,TXNAME(2,IDHW(1)),
60027      &   TXNAME(2,IDHW(2)),NRN(2),TBCOLS(2),TBCOLS(3),EVWGT,TBCOLS(1)
60028       ENDIF
60029    30 FORMAT(///1X,'EVENT ',I7,':',F8.2,' GEV/C ',A8,' ON ',F8.2,
60030      & ' GEV/C ',A8,' PROCESS:',I6/1X,'SEEDS: ',I11,' & ',I11,
60031      & '   STATUS: ',I4,' ERROR:',I4,'  WEIGHT: ',1P,E11.4/)
60032    40 FORMAT(A1,'begin{tabular}{|l|r|c|c|r|l|c|}'/A1,'hline'/
60033      & A1,'multicolumn{2}{|c|}{HERWIG 6.5} & Beam 1: & Beam 2: & ',
60034      & 'Seeds: & Status: & ',I4, ' ',A2/A1,'hline'/'Process: & ',I6,
60035      & ' & ',F8.2,'~GeV/c & ',F8.2,'~GeV/c',' & ',I11,' & Error: & ',
60036      & I4,' ',A2/A1,'cline{1-2} ',A1,'cline{6-7}'/'Event: & ',I7,' & ',
60037      & A37,' & ',A37,' & ',I11,' & Weight: & ',1P,E11.4,' ',A2/A1,
60038      & 'hline'/A1,'end{tabular}'/A1,'vskip 5mm')
60039    50 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|r|r|r|r|}'/
60040      & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
60041    60 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|}'/
60042      & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
60043    70 FORMAT(/'<CENTER>'/'<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
60044      & '<TR>'/'<TH BGCOLOR=#',A6,' COLSPAN=2>',
60045      & '<A HREF="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
60046      & 'HERWIG 6.5</A></TH>'/
60047      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 1:</FONT></TH>'/
60048      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 2:</FONT></TH>'/
60049      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Seeds:</FONT></TH>'/
60050      & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
60051      & '>Status:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>'/
60052      & '<TR>'/
60053      & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
60054      & '>Process:</Th>'/'<TD>',I6,'</TD>'/
60055      & '<TD>',F8.2,' GeV/c</TD>'/'<TD>',F8.2,' GeV/c</TD>'/
60056      & '<TD ALIGN="RIGHT">',I11,'</TD>'/
60057      & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
60058      & '>Error:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>')
60059    71 FORMAT('<TR>'/
60060      & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
60061      & '>Event:</Th>'/'<TD ALIGN="RIGHT">',I7,'</TD>'/
60062      & '<TD ALIGN="CENTER">',A37,'</TD>'/
60063      & '<TD ALIGN="CENTER">',A37,'</TD>'/
60064      & '<TD ALIGN="RIGHT">',I11,'</TD>'/
60065      & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
60066      & '>Weight:</FONT></TH>'/'<TD>',1P,E11.4,'</TD>'/'</TR>'/
60067      & '</TABLE>'//'<P>'/
60068      & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>')
60069 C Initialize control flags
60070       DO 80 I=1,11
60071    80 FIRST(I)=.TRUE.
60072 C Loop through event record
60073       DO 410 I=1,NHEP
60074       NEWSEC=.FALSE.
60075 C First find start of new sections
60076       IST=ISTHEP(I)
60077       IS=IST/10
60078       ID=IDHW(I)
60079       IF (IST.EQ.101) THEN
60080         NEWSEC=.TRUE.
60081         SECTXT=TITLE(1)
60082       ELSEIF (FIRST(2).AND.IS.EQ.12) THEN
60083         NEWSEC=.TRUE.
60084         SECTXT=TITLE(2)
60085         FIRST(2)=.FALSE.
60086       ELSEIF (FIRST(3).AND.IS.EQ.14) THEN
60087         NEWSEC=.TRUE.
60088         SECTXT=TITLE(3)
60089         FIRST(3)=.FALSE.
60090         FIRST(8)=.TRUE.
60091         FIRST(9)=.TRUE.
60092         FIRST(11)=.TRUE.
60093       ELSEIF (FIRST(4).AND.IST.GE.158.AND.IST.NE.160
60094      &                .AND.IST.LE.162) THEN
60095         NEWSEC=.TRUE.
60096         SECTXT=TITLE(4)
60097         FIRST(4)=.FALSE.
60098       ELSEIF (FIRST(5).AND.(IS.EQ.16.OR.IS.EQ.18)
60099      &                .AND.IST.GT.162) THEN
60100         NEWSEC=.TRUE.
60101         SECTXT=TITLE(5)
60102         FIRST(5)=.FALSE.
60103       ELSEIF (IS.EQ.19.OR.IST.EQ.1.OR.IST.EQ.200) THEN
60104         MS=ISTHEP(JMOHEP(1,I))/10
60105         IF (MS.EQ.15.OR.MS.EQ.16.OR.MS.EQ.18) THEN
60106           IF (FIRST(6)) THEN
60107             NEWSEC=.TRUE.
60108             SECTXT=TITLE(6)
60109             FIRST(6)=.FALSE.
60110           ENDIF
60111         ELSEIF (FIRST(7).AND.(.NOT.FIRST(6))) THEN
60112           NEWSEC=.TRUE.
60113           SECTXT=TITLE(7)
60114           FIRST(7)=.FALSE.
60115         ENDIF
60116       ELSEIF (FIRST(8).AND.(IST.EQ.125.OR.IST.EQ.155.OR.
60117      &        (IST.EQ.123.AND.ISTHEP(JMOHEP(1,I)).EQ.199))) THEN
60118         NEWSEC=.TRUE.
60119         SECTXT=TITLE(8)
60120         FIRST(3)=.TRUE.
60121         FIRST(4)=.TRUE.
60122         FIRST(5)=.TRUE.
60123         FIRST(6)=.TRUE.
60124         FIRST(7)=.TRUE.
60125         FIRST(8)=.FALSE.
60126       ELSEIF (FIRST(9).AND.(IST.EQ.123.OR.IST.EQ.124)) THEN
60127         MS=ABS(IDHEP(JMOHEP(1,I)))
60128         IF (MS.EQ.23.OR.MS.EQ.24.OR.MS.EQ.25) THEN
60129           NEWSEC=.TRUE.
60130           SECTXT=TITLE(9)
60131           FIRST(3)=.TRUE.
60132           FIRST(4)=.TRUE.
60133           FIRST(5)=.TRUE.
60134           FIRST(6)=.TRUE.
60135           FIRST(7)=.TRUE.
60136           FIRST(8)=.TRUE.
60137           FIRST(9)=.FALSE.
60138         ENDIF
60139       ELSEIF (IST.EQ.170) THEN
60140         NEWSEC=.TRUE.
60141         SECTXT=TITLE(10)
60142         FIRST(6)=.FALSE.
60143         FIRST(7)=.FALSE.
60144         FIRST(8)=.FALSE.
60145       ELSEIF (FIRST(11).AND.(ID.EQ.71.OR.ID.EQ.72)) THEN
60146         NEWSEC=.TRUE.
60147         SECTXT=TITLE(11)
60148         FIRST(3)=.TRUE.
60149         FIRST(11)=.FALSE.
60150       ENDIF
60151 C Print out section heading
60152       IF (NEWSEC) THEN
60153         IF (PRVTX) THEN
60154           IF (PRNDEF) THEN
60155             IF (NPRFMT.EQ.1) THEN
60156               WRITE(6, 90) SECTXT,(THEAD(J,3),J=1,17)
60157             ELSE
60158               WRITE(6,100) SECTXT,(THEAD(J,3),J=1,17)
60159             ENDIF
60160           ENDIF
60161           IF (PRNTEX) WRITE(IUNITT,110) Z,Z,SECTXT,ZZ,Z,
60162      &     (Z,THEAD(J,3),J=1,17),ZZ,Z
60163           IF (PRNWEB) WRITE(IUNITW,120) TBCOLS(2),TBCOLS(3),
60164      &     SECTXT,((THEAD(K,J),J=1,3),K=1,17)
60165    90     FORMAT(/46X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5,
60166      &     4(4X,A6))
60167   100     FORMAT(/58X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5,
60168      &     4X,A6,2(5X,A6),6X,A6)
60169   110     FORMAT(A1,'hline'/A1,'multicolumn{17}{|c|}{',A28,'} ',A2/A1,
60170      &     'hline'/16(A1,'multicolumn{1}{|c|}{',A6,'} & '),
60171      &     A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
60172   120     FORMAT('<TR><TH COLSPAN=17 BGCOLOR=#',A6,'>',
60173      &     '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
60174      &     '<TR>',17(/,1X,'<TH BGCOLOR=#',A6,'>
60175      &     <FONT COLOR=',A6,'>',A6,'</FONT></TH>'),'</TR>')
60176         ELSE
60177           IF (PRNDEF) THEN
60178             IF (NPRFMT.EQ.1) THEN
60179               WRITE(6,130) SECTXT,(THEAD(J,3),J=1,13)
60180             ELSE
60181               WRITE(6,140) SECTXT,(THEAD(J,3),J=1,13)
60182             ENDIF
60183           END IF
60184           IF (PRNTEX) WRITE(IUNITT,150) Z,Z,SECTXT,ZZ,Z,
60185      &     (Z,THEAD(J,3),J=1,13),ZZ,Z
60186           IF (PRNWEB) WRITE(IUNITW,160) TBCOLS(2),TBCOLS(3),
60187      &     SECTXT,((THEAD(K,J),J=1,3),K=1,13)
60188   130     FORMAT(/26X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5)
60189   140     FORMAT(/36X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5)
60190   150     FORMAT(A1,'hline'/A1,'multicolumn{13}{|c|}{',A28,'} ',A2/A1,
60191      &     'hline'/12(A1,'multicolumn{1}{|c|}{',A6,'} & '),
60192      &     A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
60193   160     FORMAT('<TR><TH COLSPAN=13 BGCOLOR=#',A6,'>',
60194      &     '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
60195      &     '<TR>',13(/'<TH BGCOLOR=#',A6,'>',
60196      &     '<FONT COLOR=#',A6,'>',A6,'</FONT></TH>'),'</TR>')
60197         ENDIF
60198       ENDIF
60199 C Now print out the data line
60200       IF (PRVTX) THEN
60201 C     Include vertex information
60202         IF (PRNDEF) THEN
60203           IF (PRNDEC) THEN
60204             IF (NPRFMT.EQ.1) THEN
60205               WRITE(6,190) I,RNAME(IDHW(I)),IDHEP(I),IST,
60206      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60207      &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60208             ELSE
60209               WRITE(6,200) I,RNAME(IDHW(I)),IDHEP(I),IST,
60210      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60211      &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60212             ENDIF
60213           ELSE
60214             IF (NPRFMT.EQ.1) THEN
60215               WRITE(6,210) I,RNAME(IDHW(I)),IDHEP(I),IST,
60216      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60217      &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60218             ELSE
60219               WRITE(6,220) I,RNAME(IDHW(I)),IDHEP(I),IST,
60220      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60221      &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60222             ENDIF
60223           ENDIF
60224         ENDIF
60225         IF (PRNTEX) WRITE(IUNITT,230) I,TXNAME(1,IDHW(I)),IDHEP(I),
60226      &   IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60227      &   (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4),ZZ
60228         IF (PRNWEB) THEN
60229           WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
60230           IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
60231             WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
60232           ELSE
60233             TMPNME=HWUNST(IDHW(I))
60234             WRITE(FNAMEP,'(A15,A7,A5)')
60235      &       'HW_decays/PART_',TMPNME,'.html'
60236             WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
60237           ENDIF
60238           DO 170 J=1,2
60239             IF (JMOHEP(J,I).NE.0) THEN
60240               WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
60241             ELSE
60242               WRITE(IUNITW,280) JMOHEP(J,I)
60243             ENDIF
60244   170     CONTINUE
60245           DO 180 J=1,2
60246             IF (JDAHEP(J,I).NE.0) THEN
60247               WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
60248             ELSE
60249               WRITE(IUNITW,280) JDAHEP(J,I)
60250             ENDIF
60251   180     CONTINUE
60252           IF (NPRFMT.EQ.1) THEN
60253             WRITE(IUNITW,290) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60254           ELSE
60255             WRITE(IUNITW,300) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60256           ENDIF
60257         ENDIF
60258   190   FORMAT(1X,I4,1X,A8,I8,5I4,   2F8.2,2F7.1,F8.2,1P,4E10.3)
60259   200   FORMAT(1X,I4,1X,A8,I8,5I4,   5F12.5,1P,4E11.4)
60260   210   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2,1P,4E10.3)
60261   220   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5,1P,4E11.4)
60262   230   FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
60263      &   5(' & $',F8.2,'$'),4(' & $',1P,E11.3,'$'),' ',A2)
60264   240   FORMAT('<TR>'/'<TD BGCOLOR=#',A6,' ALIGN="RIGHT">',
60265      &   '<FONT COLOR=#',A6,'><A NAME="',I4,'">',I4,'</A></FONT></TD>'/)
60266   250   FORMAT('<TD ALIGN="CENTER">',A37,'</TD>'/'<TD ALIGN="RIGHT">',
60267      &   I8,'</TD>'/'<TD ALIGN="RIGHT">',I4,'</TD>')
60268   260   FORMAT('<TD ALIGN="CENTER"><A HREF="',A27,'">',A37,'</A></TD>'/
60269      &   '<TD ALIGN="RIGHT">',I8,'</TD>'/
60270      &   '<TD ALIGN="RIGHT">',I4,'</TD>')
60271   270   FORMAT(/'<TD ALIGN="RIGHT"><A HREF="#',I4,'">',I4,'</A></TD>')
60272   280   FORMAT(/'<TD ALIGN="RIGHT">',I4,'</TD>')
60273   290   FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>'),1P,
60274      &   4(/'<TD ALIGN="RIGHT">',E10.3,'</TD>')/'</TR>')
60275   300   FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>'),1P,
60276      &   4(/'<TD ALIGN="RIGHT">',E11.4,'</TD>')/'</TR>')
60277       ELSE
60278 C     Do not include vertex information
60279         IF (PRNDEF) THEN
60280           IF (PRNDEC) THEN
60281             IF (NPRFMT.EQ.1) THEN
60282               WRITE(6,330) I,RNAME(IDHW(I)),IDHEP(I),IST,
60283      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60284      &         (PHEP(J,I),J=1,5)
60285             ELSE
60286               WRITE(6,340) I,RNAME(IDHW(I)),IDHEP(I),IST,
60287      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60288      &         (PHEP(J,I),J=1,5)
60289             ENDIF
60290           ELSE
60291             IF (NPRFMT.EQ.1) THEN
60292               WRITE(6,350) I,RNAME(IDHW(I)),IDHEP(I),IST,
60293      &          JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60294      &          (PHEP(J,I),J=1,5)
60295             ELSE
60296               WRITE(6,360) I,RNAME(IDHW(I)),IDHEP(I),IST,
60297      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60298      &         (PHEP(J,I),J=1,5)
60299             ENDIF
60300           ENDIF
60301         ENDIF
60302         IF (PRNTEX) THEN
60303           IF (NPRFMT.EQ.1) THEN
60304             WRITE(IUNITT,370) I,TXNAME(1,IDHW(I)),IDHEP(I),
60305      &       IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60306      &       (PHEP(J,I),J=1,5),ZZ
60307           ELSE
60308             WRITE(IUNITT,380) I,TXNAME(1,IDHW(I)),IDHEP(I),
60309      &       IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60310      &       (PHEP(J,I),J=1,5),ZZ
60311           ENDIF
60312         ENDIF
60313         IF (PRNWEB) THEN
60314           WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
60315           IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
60316             WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
60317           ELSE
60318             TMPNME = HWUNST(IDHW(I))
60319             WRITE(FNAMEP,'(A15,A7,A5)')
60320      &       'HW_decays/PART_',TMPNME,'.html'
60321             WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
60322           ENDIF
60323           DO 310 J=1,2
60324             IF (JMOHEP(J,I).NE.0) THEN
60325               WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
60326             ELSE
60327               WRITE(IUNITW,280) JMOHEP(J,I)
60328             ENDIF
60329   310     CONTINUE
60330           DO 320 J=1,2
60331             IF (JDAHEP(J,I).NE.0) THEN
60332               WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
60333             ELSE
60334               WRITE(IUNITW,280) JDAHEP(J,I)
60335             ENDIF
60336   320     CONTINUE
60337           IF (NPRFMT.EQ.1) THEN
60338             WRITE(IUNITW,390) (PHEP(J,I),J=1,5)
60339           ELSE
60340             WRITE(IUNITW,400) (PHEP(J,I),J=1,5)
60341           ENDIF
60342         ENDIF
60343   330   FORMAT(1X,I4,1X,A8,I8,5I4   ,2F8.2,2F7.1,F8.2)
60344   340   FORMAT(1X,I4,1X,A8,I8,5I4   ,5F12.5)
60345   350   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2)
60346   360   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5)
60347   370   FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
60348      &   5(' & $',F8.2,'$'),' ',A2)
60349   380   FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
60350      &   5(' & $',F12.5,'$'),' ',A2)
60351   390   FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>')/'</TR>')
60352   400   FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>')/'</TR>')
60353       ENDIF
60354   410 CONTINUE
60355 C Close the files
60356       IF (PRNTEX) THEN
60357         WRITE(IUNITT,420) Z,Z,Z
60358   420   FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
60359         CLOSE(IUNITT)
60360       ENDIF
60361       IF (PRNWEB) THEN
60362         WRITE(IUNITW,430)
60363   430   FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
60364         CLOSE(IUNITW)
60365       ENDIF
60366       END
60367 CDECK  ID>, HWUGUP.
60368 *CMZ :-        -13/02/02  07.20.46  by  Peter Richardson
60369 *-- Author :    Peter Richardson
60370 C-----------------------------------------------------------------------
60371       SUBROUTINE HWUGUP
60372 C-----------------------------------------------------------------------
60373 C     Subroutine to handle termination of HERWIG if reaches end of event
60374 C     file
60375 C-----------------------------------------------------------------------
60376       INCLUDE 'herwig65.inc'
60377 C--reset the number of events to the correct value
60378       NEVHEP = NEVHEP-1
60379 C--output information on the events
60380       CALL HWEFIN
60381       STOP
60382       END
60383 CDECK  ID>, HWUFNE.
60384 *CMZ :-        -16/10/93  12.42.15  by  Mike Seymour
60385 *-- Author :    Mike Seymour
60386 C-----------------------------------------------------------------------
60387       SUBROUTINE HWUFNE
60388 C-----------------------------------------------------------------------
60389 C     FINALISES THE EVENT BY UNDOING THE LORENTZ BOOST IF THERE WAS ONE,
60390 C     CHECKING FOR ERRORS, AND PRINTING
60391 C-----------------------------------------------------------------------
60392       INCLUDE 'herwig65.inc'
60393       INTEGER IHEP
60394       LOGICAL CALLED
60395       COMMON/HWDBUG/CALLED
60396       CALLED=.TRUE.
60397 C---UNBOOST EVENT RECORD IF NECESSARY
60398       CALL HWUBST(0)
60399 C---CHECK FOR NEGATIVE ENERGY PARTICLES (REMNANT BUG?)
60400       DO IHEP=1,NHEP
60401          IF (ISTHEP(IHEP).EQ.1.AND.PHEP(4,IHEP).LT.ZERO) THEN
60402            CALL HWWARN('HWUFNE',100)
60403            GOTO 99
60404          ENDIF
60405       ENDDO
60406  99   CONTINUE
60407 C---CHANGE LIGHTEST SUSY HIGGS CODE TO THE PDG VALUE
60408        DO IHEP=1,NHEP
60409           IF (IDHEP(IHEP).EQ.26) IDHEP(IHEP)=25
60410        ENDDO
60411 C---CHECK FOR FATAL ERROR
60412       IF (IERROR.NE.0) THEN
60413         IF (IERROR.GT.0) THEN
60414           NUMER=NUMER+1
60415         ELSE
60416           NUMERU=NUMERU+1
60417         ENDIF
60418         IF (NUMER.GT.MAXER) CALL HWWARN('HWUFNE',300)
60419         NEVHEP=NEVHEP-1
60420         IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV-1
60421 C---PRINT FIRST MAXPR EVENTS
60422       ELSEIF (NEVHEP.LE.MAXPR) THEN
60423         CALL HWUEPR
60424       END IF
60425       END
60426 CDECK  ID>, HWUGAU.
60427 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60428 *-- Author :    Adapted by Bryan Webber
60429 C-----------------------------------------------------------------------
60430       FUNCTION HWUGAU(F,A,B,EPS)
60431 C-----------------------------------------------------------------------
60432 C     ADAPTIVE GAUSSIAN INTEGRATION OF FUNCTION F
60433 C     IN INTERVAL (A,B) WITH PRECISION EPS
60434 C     (MODIFIED CERN LIBRARY ROUTINE GAUSS)
60435 C-----------------------------------------------------------------------
60436       IMPLICIT NONE
60437       DOUBLE PRECISION HWUGAU,F,A,B,EPS,CONST,AA,BB,C1,C2,S8,U,S16,
60438      & W(12),X(12),ZERO
60439       INTEGER I
60440       EXTERNAL F
60441       PARAMETER (ZERO=0.0D0)
60442       SAVE W,X
60443       DATA W/.1012285363D0,.2223810345D0,.3137066459D0,
60444      &       .3626837834D0,.0271524594D0,.0622535239D0,
60445      &       .0951585117D0,.1246289713D0,.1495959888D0,
60446      &       .1691565194D0,.1826034150D0,.1894506105D0/
60447       DATA X/.9602898565D0,.7966664774D0,.5255324099D0,
60448      &       .1834346425D0,.9894009350D0,.9445750231D0,
60449      &       .8656312024D0,.7554044084D0,.6178762444D0,
60450      &       .4580167777D0,.2816035508D0,.0950125098D0/
60451       HWUGAU=0.
60452       IF (A.EQ.B) RETURN
60453       CONST=.005/ABS(B-A)
60454       BB=A
60455     1 AA=BB
60456       BB=B
60457     2    C1=0.5*(BB+AA)
60458          C2=0.5*(BB-AA)
60459          S8=0.
60460          DO 3 I=1,4
60461             U=C2*X(I)
60462             S8=S8+W(I)*(F(C1+U)+F(C1-U))
60463     3    CONTINUE
60464          S8=C2*S8
60465          S16=0.
60466          DO 4 I=5,12
60467             U=C2*X(I)
60468             S16=S16+W(I)*(F(C1+U)+F(C1-U))
60469     4    CONTINUE
60470          S16=C2*S16
60471          IF (ABS(S16-S8).LE.EPS*(1.+ABS(S16))) GOTO 5
60472          BB=C1
60473          IF (CONST*ABS(C2).NE.ZERO) GOTO 2
60474 C---TOO HIGH ACCURACY REQUESTED
60475          CALL HWWARN('HWUGAU',500)
60476     5 HWUGAU=HWUGAU+S16
60477       IF (BB.NE.B) GOTO 1
60478       END
60479 CDECK  ID>, HWUIDT.
60480 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
60481 *-- Author :    Bryan Webber
60482 C-----------------------------------------------------------------------
60483       SUBROUTINE HWUIDT(IOPT,IPDG,IWIG,NWIG)
60484 C-----------------------------------------------------------------------
60485 C     TRANSLATES PARTICLE IDENTIFIERS:
60486 C     IPDG = PARTICLE DATA GROUP CODE
60487 C     IWIG = HERWIG IDENTITY CODE
60488 C     NWIG = HERWIG CHARACTER*8 NAME
60489 C
60490 C     IOPT= 1 GIVEN IPDG, RETURNS IWIG AND NWIG
60491 C     IOPT= 2 GIVEN IWIG, RETURNS IPDG AND NWIG
60492 C     IOPT= 3 GIVEN NWIG, RETURNS IPDG AND IWIG
60493 C-----------------------------------------------------------------------
60494       INCLUDE 'herwig65.inc'
60495       INTEGER IOPT,IPDG,IWIG,I
60496       CHARACTER*8 NWIG
60497       IF (IOPT.EQ.1) THEN
60498         DO 10 I=0,NRES
60499         IF (IDPDG(I).EQ.IPDG) THEN
60500           IWIG=I
60501           NWIG=RNAME(I)
60502           RETURN
60503         ENDIF
60504   10    CONTINUE
60505         WRITE(6,20) IPDG
60506   20    FORMAT(1X,'Particle not recognised, PDG code: ',I8)
60507         IWIG=20
60508         NWIG=RNAME(20)
60509         CALL HWWARN('HWUIDT',101)
60510         GOTO 999
60511       ELSEIF (IOPT.EQ.2) THEN
60512         IF (IWIG.LT.0.OR.IWIG.GT.NRES) THEN
60513           WRITE(6,30) IWIG
60514   30      FORMAT(1X,'Particle not recognised, HERWIG code: ',I3)
60515           IPDG=0
60516           NWIG=RNAME(20)
60517           CALL HWWARN('HWUIDT',102)
60518           GOTO 999
60519         ELSE
60520           IPDG=IDPDG(IWIG)
60521           NWIG=RNAME(IWIG)
60522           RETURN
60523         ENDIF
60524       ELSEIF (IOPT.EQ.3) THEN
60525         DO 40 I=0,NRES
60526         IF (RNAME(I).EQ.NWIG) THEN
60527           IWIG=I
60528           IPDG=IDPDG(I)
60529           RETURN
60530         ENDIF
60531   40    CONTINUE
60532         WRITE(6,50) NWIG
60533   50    FORMAT(1X,'Particle not recognised, HERWIG name: ',A8)
60534         IWIG=20
60535         IPDG=0
60536         CALL HWWARN('HWUIDT',103)
60537         GOTO 999
60538       ELSE
60539         CALL HWWARN('HWUIDT',404)
60540       ENDIF
60541  999  RETURN
60542       END
60543 CDECK  ID>, HWUINC.
60544 *CMZ :-        -12/10/01  09.56.07  by  Peter Richardson
60545 *-- Author :    Bryan Webber
60546 C-----------------------------------------------------------------------
60547       SUBROUTINE HWUINC
60548 C-----------------------------------------------------------------------
60549 C     COMPUTES CONSTANTS AND LOOKUP TABLES
60550 C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
60551 C-----------------------------------------------------------------------
60552       INCLUDE 'herwig65.inc'
60553       DOUBLE PRECISION HWBVMC,HWUALF,HWUPCM,XMIN,XMAX,XPOW,QR,DQKWT,
60554      & UQKWT,SQKWT,DIQWT,QMAX,PMAX,PTLIM,ETLIM,PGS,PTELM,X,QSCA,UPV,DNV,
60555      & USEA,DSEA,STR,CHM,BTM,TOP,GLU,VAL(20),CLMXPW,RCLPOW,TEST,RPM(2)
60556       INTEGER ISTOP,I,J,IQK,IDB,IDT,ISET,IOP1,IOP2,IP2,ID,IH,IV
60557       INTEGER LPROC,KPROC
60558       INTEGER IS,IP(3),IQ
60559       COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
60560       INTEGER      JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
60561       INTEGER ISQ1,ISQ2
60562       INTEGER IHLP,JHLP,KHLP,ISIGN,ITMP(8)
60563       LOGICAL FIRST,FSTPDF
60564       CHARACTER*20 PARM(20)
60565       EXTERNAL HWBVMC,HWUALF,HWUPCM
60566       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
60567       COMMON/W50516/FSTPDF
60568       CHARACTER*20 PARMSAVE
60569       DOUBLE PRECISION VALSAVE
60570       COMMON/HWSFSA/PARMSAVE
60571       COMMON/HWSFSB/VALSAVE
60572       SAVE ITMP
60573       DATA ITMP/0,12,-12,0,0,12,-12,0/
60574 C--read in the information frmo the Les Houches common block if needed
60575       IF(IPROC.LE.0) CALL HWIGUP
60576 C---MSSM Higgs processes: additional IDs to distinguish from SM-like ones.
60577       IMSSM=0
60578       IHIGGS=0
60579 C---Sets even parity of Higgs bosons (in the coupling to fermions) as default.
60580       PARITY=1
60581 C...define parity of Neutral MSSM Higgses.
60582       IP(1)=+1
60583       IP(2)=+1
60584       IP(3)=-1
60585 C---IPRO=9,11 (lepton-lepton); 31...38 (hadron-hadron) MSSM Higgs production.
60586       LPROC=MOD(IPROC,10000)
60587       IF((LPROC.LT.3100).OR.(LPROC.GE.3900))THEN
60588 C...add here MSSM Higgs processes in lepton-lepton collisions.
60589         IF((LPROC/100.NE.9).AND.(LPROC/100.NE.11))GOTO 666
60590       END IF
60591 C-----------------------------------------------------------------------
60592 C     HARD 2 LEPTON/PARTON -> HIGGS + X PROCESSES IN MSSM
60593 C     IH = 1   MSSM h^0     IV = 0 SM W+/-     IQ = 1,3,5 d,s,b-quark
60594 C        = 2   MSSM H^0        = 1 SM Z             2,4,6 u,c,t-quark
60595 C        = 3   MSSM A^0                        ID = IQ, IL
60596 C        = 4/5 MSSM H^+/-                      IL = 1,2,3 e,mu,tau-lepton
60597 C-----------------------------------------------------------------------
60598 C...leptonic processes.
60599       IF(LPROC/100.EQ.9)THEN
60600         IF(LPROC.EQ.955)THEN
60601           IMSSM=-1
60602           IHIGGS=206-201
60603         ELSE IF(LPROC.EQ.965)THEN
60604           IHIGGS=203-201
60605           IMSSM=-1
60606         ELSE IF(LPROC.EQ.975)THEN
60607           IHIGGS=204-201
60608           IMSSM=-1
60609         ELSE IF((LPROC.EQ.910).OR.(LPROC.EQ.920).OR.
60610      &          (LPROC.EQ.960).OR.(LPROC.EQ.970))THEN
60611           KPROC=MIN(951,LPROC)
60612           IV=MAX(KPROC-950,0)
60613           IF((IV.LT.0).OR.(IV.GT.1)) CALL HWWARN('HWUINC',627)
60614           IH=LPROC/10-90-5*IV
60615           IF((IH.LE.0).OR.(IH.GT.2)) CALL HWWARN('HWUINC',626)
60616           IF(LPROC.LE.920)IMSSM=LPROC-400
60617           IF(LPROC.GE.960)IMSSM=LPROC-300
60618 C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
60619           DO 545 I=10,10
60620             ENHANC(I  )=GHWWSS(IH)
60621             ENHANC(I+1)=GHZZSS(IH)
60622  545      CONTINUE
60623           IF(IH.EQ.1)IHIGGS=203-201
60624           IF(IH.EQ.2)IHIGGS=204-201
60625           IF(IH.EQ.3)IHIGGS=205-201
60626         ELSE
60627           CALL HWWARN('HWUINC',625)
60628         END IF
60629       ELSE IF(LPROC/100.EQ.11)THEN
60630         IMSSM=-1
60631         IF(LPROC.GE.1140)THEN
60632           IHIGGS=207-201
60633           PARITY=1
60634           GOTO 548
60635         END IF
60636         IF(LPROC.LT.1140)IH=3
60637         IF(LPROC.LT.1130)IH=2
60638         IF(LPROC.LT.1120)IH=1
60639         IF((IH.LE.0).OR.(IH.GT.3)) CALL HWWARN('HWUINC',624)
60640         IQ=LPROC-1100-10*IH
60641         IF((IQ.LE.0).OR.(IQ.GT.9)) CALL HWWARN('HWUINC',623)
60642 C...assign Neutral MSSM Higgs parity.
60643         PARITY=IP(IH)
60644 C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
60645         DO 546 I=1,5,2
60646           ENHANC(I  )=GHDDSS(IH)
60647           ENHANC(I+1)=GHUUSS(IH)
60648  546    CONTINUE
60649 C...assign enhancement for MSSM Higgs-LL couplings, L->D-type leptons.
60650         ENHANC(7)=GHDDSS(IH)
60651         ENHANC(8)=GHDDSS(IH)
60652         ENHANC(9)=GHDDSS(IH)
60653 C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
60654         DO 547 I=10,10
60655           ENHANC(I  )=GHWWSS(IH)
60656           ENHANC(I+1)=GHZZSS(IH)
60657  547    CONTINUE
60658         IF(IH.EQ.1)IHIGGS=203-201
60659         IF(IH.EQ.2)IHIGGS=204-201
60660         IF(IH.EQ.3)IHIGGS=205-201
60661  548    CONTINUE
60662 C...hadronic processes.
60663       ELSE IF((LPROC/100.EQ.31).OR.(LPROC/100.EQ.32))THEN
60664         IF(LPROC/100.EQ.31)THEN
60665           IF((LPROC.LE.3109).OR.
60666      &      ((LPROC.GE.3119).AND.(LPROC.LE.3139)).OR.
60667      &      ((LPROC.GE.3149).AND.(LPROC.LE.3169)).OR.
60668      &       (LPROC.GE.3179)) CALL HWWARN('HWUINC',622)
60669           IMSSM=-1
60670           IF(LPROC/100-LPROC/10*10.LE.4)IHIGGS=5
60671           IF(LPROC/100-LPROC/10*10.GE.5)IHIGGS=6
60672         ELSE IF(LPROC/100.EQ.32)THEN
60673           IF(LPROC.LE.3209) CALL HWWARN('HWUINC',621)
60674           IF(LPROC.EQ.3219) CALL HWWARN('HWUINC',620)
60675           IF(LPROC.EQ.3229) CALL HWWARN('HWUINC',619)
60676           IF(LPROC.EQ.3239) CALL HWWARN('HWUINC',618)
60677           IF(LPROC.EQ.3249) CALL HWWARN('HWUINC',617)
60678           IF(LPROC.EQ.3259) CALL HWWARN('HWUINC',616)
60679           IF(LPROC.EQ.3269) CALL HWWARN('HWUINC',615)
60680           IF(LPROC.EQ.3279) CALL HWWARN('HWUINC',614)
60681           IF(LPROC.EQ.3289) CALL HWWARN('HWUINC',613)
60682           IF(LPROC.GE.3299) CALL HWWARN('HWUINC',612)
60683           IMSSM=-1
60684           IF(LPROC.LT.3300)IHIGGS=4
60685           IF(LPROC.LT.3290)IHIGGS=3
60686           IF(LPROC.LT.3280)IHIGGS=2
60687           IF(LPROC.LT.3270)IHIGGS=4
60688           IF(LPROC.LT.3260)IHIGGS=3
60689           IF(LPROC.LT.3250)IHIGGS=2
60690           IF(LPROC.LT.3240)IHIGGS=4
60691           IF(LPROC.LT.3230)IHIGGS=3
60692           IF(LPROC.LT.3220)IHIGGS=2
60693         END IF
60694 C...assign squarks/Higgs-flavours.
60695         IF(LPROC/100.EQ.31)JHIGGS=1
60696         IF(LPROC/100.EQ.32)JHIGGS=IHIGGS-1
60697         IF(LPROC/100.EQ.31)ILBL=3100
60698         IF(LPROC/100.EQ.32)ILBL=3200
60699         IHLP=LPROC-ILBL-60-JHIGGS*10
60700         IF(LPROC.LT.ILBL+70)IHLP=LPROC-ILBL-30-JHIGGS*10
60701         IF(LPROC.LT.ILBL+40)IHLP=LPROC-ILBL   -JHIGGS*10
60702         IF(IHLP.LE.8)ISIGN=-1
60703         IF(IHLP.LE.4)ISIGN=+1
60704         JHLP=IHLP/5
60705         KHLP=IHLP/(3+4*JHLP)
60706         ISQ1=405+JHLP+12*KHLP
60707         IF(ILBL.EQ.3100)THEN
60708           ISQ2=ISQ1+ITMP(IHLP)+6+ISIGN
60709           IF(ISIGN.EQ.+1)JH=206
60710           IF(ISIGN.EQ.-1)JH=207
60711           IF(ISIGN.EQ.+1)JHIGGS=4
60712           IF(ISIGN.EQ.-1)JHIGGS=5
60713         ELSE IF(ILBL.EQ.3200)THEN
60714           ISQ2=ISQ1+ITMP(IHLP)+6
60715           IF(JHIGGS.EQ.1)JH=203
60716           IF(JHIGGS.EQ.2)JH=204
60717           IF(JHIGGS.EQ.3)JH=205
60718         END IF
60719         IF1MIN=ISQ1
60720         IF1MAX=ISQ1
60721         IF2MIN=ISQ2
60722         IF2MAX=ISQ2
60723         IF((LPROC.EQ.3110).OR.(LPROC.EQ.3210).OR.
60724      &     (LPROC.EQ.3220).OR.(LPROC.EQ.3230).OR.
60725      &     (LPROC.EQ.3140).OR.(LPROC.EQ.3240).OR.
60726      &     (LPROC.EQ.3250).OR.(LPROC.EQ.3260).OR.
60727      &     (LPROC.EQ.3170).OR.(LPROC.EQ.3270).OR.
60728      &     (LPROC.EQ.3280).OR.(LPROC.EQ.3290))THEN
60729           IF1MIN=405
60730           IF1MAX=418
60731           IF2MIN=411
60732           IF2MAX=424
60733         END IF
60734       ELSE IF(LPROC/100.EQ.33)THEN
60735         IF((LPROC.EQ.3350).OR.(LPROC.EQ.3355))THEN
60736           IMSSM=-1
60737           IHIGGS=206-201
60738         ELSE IF((LPROC.EQ.3310).OR.(LPROC.EQ.3320).OR.
60739      &          (LPROC.EQ.3360).OR.(LPROC.EQ.3370))THEN
60740           KPROC=MIN(3351,LPROC)
60741           IV=MAX(KPROC-3350,0)
60742           IF((IV.LT.0).OR.(IV.GT.1)) CALL HWWARN('HWUINC',611)
60743           IH=LPROC/10-330-5*IV
60744           IF((IH.LE.0).OR.(IH.GT.2)) CALL HWWARN('HWUINC',610)
60745           IF(LPROC.LE.3320)IMSSM=LPROC-2600
60746           IF(LPROC.GE.3360)IMSSM=LPROC-2700
60747 C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
60748           DO 555 I=10,10
60749             ENHANC(I  )=GHWWSS(IH)
60750             ENHANC(I+1)=GHZZSS(IH)
60751  555      CONTINUE
60752           IF(IH.EQ.1)IHIGGS=203-201
60753           IF(IH.EQ.2)IHIGGS=204-201
60754           IF(IH.EQ.3)IHIGGS=205-201
60755         ELSE IF((LPROC.EQ.3315).OR.(LPROC.EQ.3365))THEN
60756           IHIGGS=203-201
60757           IMSSM=-1
60758         ELSE IF((LPROC.EQ.3325).OR.(LPROC.EQ.3375))THEN
60759           IHIGGS=204-201
60760           IMSSM=-1
60761         ELSE IF(LPROC.EQ.3335)THEN
60762           IHIGGS=205-201
60763           IMSSM=-1
60764         ELSE
60765           CALL HWWARN('HWUINC',609)
60766         END IF
60767       ELSE IF(LPROC/100.EQ.34)THEN
60768         IMSSM=-1
60769         IF(LPROC.EQ.3410)IHIGGS=203-201
60770         IF(LPROC.EQ.3420)IHIGGS=204-201
60771         IF(LPROC.EQ.3430)IHIGGS=205-201
60772         IF(LPROC.EQ.3450)IHIGGS=206-201
60773         IF(IHIGGS.EQ.0) CALL HWWARN('HWUINC',608)
60774       ELSE IF(LPROC/100.EQ.35)THEN
60775         IMSSM=-1
60776         IHIGGS=206-201
60777       ELSE IF(LPROC/100.EQ.36)THEN
60778         IF((LPROC.NE.3610).AND.(LPROC.NE.3620).AND.
60779      &     (LPROC.NE.3630)) CALL HWWARN('HWUINC',607)
60780         IH=LPROC/10-360
60781         IF((IH.LE.0).OR.(IH.GT.3)) CALL HWWARN('HWUINC',606)
60782         ID=LPROC-3600-10*IH
60783         IF((ID.LT.0).OR.(ID.GT.9)) CALL HWWARN('HWUINC',605)
60784         IMSSM=LPROC-(1600+ID)
60785 C...assign Neutral MSSM Higgs parity.
60786         IF(IH.EQ.3)PARITY=-1
60787         DO 222 I=1,5,2
60788 C...assign enhancement for Neutral MSSM Higgs-QQ couplings, Q->U,D-type quarks.
60789           ENHANC(I)=GHDDSS(IH)
60790           ENHANC(I+1)=GHUUSS(IH)
60791  222    CONTINUE
60792 C...assign enhancement for Neutral MSSM Higgs-Q~Q~ couplings,
60793 C   Q~->U,D-type squarks.
60794         DO 223 I=1,6
60795           SENHNC(I   )=RMASS(198)*GHSQSS(IH,I,1,1)/RMASS(400+I)**2
60796           SENHNC(I+12)=RMASS(198)*GHSQSS(IH,I,2,2)/RMASS(412+I)**2
60797  223    CONTINUE
60798         IF(IH.EQ.1)IHIGGS=203-201
60799         IF(IH.EQ.2)IHIGGS=204-201
60800         IF(IH.EQ.3)IHIGGS=205-201
60801       ELSE IF(LPROC/100.EQ.37)THEN
60802         IH=LPROC/10-370
60803         IF((IH.LE.0).OR.(IH.GT.2)) CALL HWWARN('HWUINC',604)
60804         IMSSM=LPROC-1900
60805 C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
60806         DO 333 I=10,10
60807           ENHANC(I  )=GHWWSS(IH)
60808           ENHANC(I+1)=GHZZSS(IH)
60809  333    CONTINUE
60810         IF(IH.EQ.1)IHIGGS=203-201
60811         IF(IH.EQ.2)IHIGGS=204-201
60812         IF(IH.EQ.3)IHIGGS=205-201
60813       ELSE IF(LPROC/100.EQ.38)THEN
60814         IMSSM=-1
60815         IF((LPROC.EQ.3839).OR.(LPROC.EQ.3869).OR.(LPROC.EQ.3899))THEN
60816           IHIGGS=207-201
60817           PARITY=1
60818           GOTO 445
60819         END IF
60820         IF(LPROC.LT.4000)IS=6
60821         IF(LPROC.LT.3870)IS=3
60822         IF(LPROC.LT.3840)IS=0
60823         IH=LPROC/10-380-IS
60824         IF((IH.LE.0).OR.(IH.GT.3)) CALL HWWARN('HWUINC',603)
60825         IQ=LPROC-3800-10*(IH+IS)
60826         IF((IQ.LE.0).OR.(IQ.GT.6)) CALL HWWARN('HWUINC',602)
60827 C...assign Neutral MSSM Higgs parity.
60828         PARITY=IP(IH)
60829 C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
60830         DO 444 I=1,5,2
60831           ENHANC(I  )=GHDDSS(IH)
60832           ENHANC(I+1)=GHUUSS(IH)
60833  444    CONTINUE
60834         IF(IH.EQ.1)IHIGGS=203-201
60835         IF(IH.EQ.2)IHIGGS=204-201
60836         IF(IH.EQ.3)IHIGGS=205-201
60837  445    CONTINUE
60838       END IF
60839       IF((IMSSM.NE.-1).AND.(IPROC.GE.10000))IMSSM=IMSSM+10000
60840  666  CONTINUE
60841       IPRO=MOD(IPROC/100,100)
60842       IQK=MOD(IPROC,100)
60843 C---SET UP BEAMS
60844       CALL HWUIDT(3,IDB,IPART1,PART1)
60845       CALL HWUIDT(3,IDT,IPART2,PART2)
60846       EBEAM1=SQRT(PBEAM1**2+RMASS(IPART1)**2)
60847       EBEAM2=SQRT(PBEAM2**2+RMASS(IPART2)**2)
60848 C---PHOTON CUTOFF DEFAULTS TO ROOT S
60849       PTLIM=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
60850       ETLIM=TWO*PTLIM
60851       IF (VPCUT.GT.ETLIM) VPCUT=ETLIM
60852       IF (Q2MAX.GT.ETLIM**2) Q2MAX=ETLIM**2
60853 C---PRINT OUT MOST IMPORTANT INPUT PARAMETERS
60854       IF (IPRINT.EQ.0) GOTO 50
60855       WRITE (6,10) PART1,PBEAM1,PART2,PBEAM2,IPROC,
60856      & NFLAV,NSTRU,AZSPIN,AZSOFT,QCDLAM,(RMASS(I),I=1,6),RMASS(13)
60857       IF (ISPAC.LE.1) THEN
60858         WRITE (6,20) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
60859       ELSE
60860         WRITE (6,30) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
60861       ENDIF
60862 C--switch on three body matrix elements if doing spin correlations
60863       IF(SYSPIN) THREEB=.TRUE.
60864 C--output spin correlation options
60865       WRITE(6,35) SYSPIN,THREEB,FOURB
60866       IF (NOSPAC) WRITE (6,40)
60867   10  FORMAT(/10X,'INPUT CONDITIONS FOR THIS RUN'//
60868      &        10X,'BEAM 1 (',A8,') MOM. =',F10.2/
60869      &        10X,'BEAM 2 (',A8,') MOM. =',F10.2/
60870      &        10X,'PROCESS CODE (IPROC)   =',I8/
60871      &        10X,'NUMBER OF FLAVOURS     =',I5/
60872      &        10X,'STRUCTURE FUNCTION SET =',I5/
60873      &        10X,'AZIM SPIN CORRELATIONS =',L5/
60874      &        10X,'AZIM SOFT CORRELATIONS =',L5/
60875      &        10X,'QCD LAMBDA (GEV)       =',F10.4/
60876      &        10X,'DOWN     QUARK  MASS   =',F10.4/
60877      &        10X,'UP       QUARK  MASS   =',F10.4/
60878      &        10X,'STRANGE  QUARK  MASS   =',F10.4/
60879      &        10X,'CHARMED  QUARK  MASS   =',F10.4/
60880      &        10X,'BOTTOM   QUARK  MASS   =',F10.4/
60881      &        10X,'TOP      QUARK  MASS   =',F10.4/
60882      &        10X,'GLUON EFFECTIVE MASS   =',F10.4)
60883   20  FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
60884      &       10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
60885      &       10X,'PHOTON SHOWER CUTOFF   =',F10.4/
60886      &       10X,'CLUSTER MASS PARAMETER =',F10.4/
60887      &       10X,'SPACELIKE EVOLN CUTOFF =',F10.4/
60888      &       10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
60889   30  FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
60890      &       10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
60891      &       10X,'PHOTON SHOWER CUTOFF   =',F10.4/
60892      &       10X,'CLUSTER MASS PARAMETER =',F10.4/
60893      &       10X,'PDF FREEZING CUTOFF    =',F10.4/
60894      &       10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
60895   35  FORMAT(10X,'DECAY SPIN CORRELATIONS=',L5/
60896      &       10X,'SUSY THREE BODY ME     =',L5/
60897      &       10X,'SUSY FOUR  BODY ME     =',L5)
60898   40  FORMAT(10X,'NO SPACE-LIKE SHOWERS')
60899   50  ISTOP=0
60900 C---INITIALIZE ALPHA-STRONG
60901       IF (QLIM.GT.ETLIM) QLIM=ETLIM
60902       QR=HWUALF(0,QLIM)
60903 C---DO SOME SAFETY CHECKS ON INPUT PARAMETERS
60904 C Check beam order for point-like photon/QCD processes
60905       IF (IPRO.GE.50.AND.IPRO.LE.59.AND.
60906      &     IDB.NE.22.AND.ABS(IDB).NE.11.AND.ABS(IDB).NE.13) THEN
60907          WRITE(6,60)
60908   60     FORMAT(1X,'WARNING: require FIRST beam to be a photon/lepton')
60909          ISTOP=ISTOP+1
60910       ENDIF
60911       QG=HWBVMC(13)
60912       QR=QG/QCDL3
60913       IF (QR.GE.2.01) GOTO 80
60914       WRITE (6,70) QG,QCDLAM,QCDL3
60915   70  FORMAT(//10X,'SHOWER GLUON VIRTUAL MASS CUTOFF =',F8.5/
60916      &         10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
60917      &         10X,'CORRESPONDS TO  3-FLAV MC LAMBDA =',F8.5)
60918       ISTOP=ISTOP+1
60919   80  QV=MIN(HWBVMC(1),HWBVMC(2))
60920       IF (QV.GE.QG/(QR-1.)) GOTO 100
60921       ISTOP=ISTOP+1
60922       WRITE (6,90) QV,QCDLAM,QCDL3
60923   90  FORMAT(//10X,'SHOWER QUARK VIRTUAL MASS CUTOFF =',F8.5/
60924      &         10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
60925      &         10X,'CORRESPONDS TO  3-FLAV MC LAMBDA =',F8.5)
60926   100 IF (ISTOP.NE.0) THEN
60927         WRITE (6,110) ISTOP
60928   110   FORMAT(//10X,'EXECUTION PREVENTED BY',I2,
60929      &  ' ERRORS IN INPUT PARAMETERS.')
60930         STOP
60931       ENDIF
60932       DO 120 I=1,6
60933   120 RMASS(I+6)=RMASS(I)
60934       RMASS(199)=RMASS(198)
60935 C---A PRIORI WEIGHTS FOR QUARK AND DIQUARKS
60936       DQKWT=PWT(1)
60937       UQKWT=PWT(2)
60938       SQKWT=PWT(3)
60939       DIQWT=PWT(7)
60940       PWT(10)=PWT(4)
60941       PWT(11)=PWT(5)
60942       PWT(12)=PWT(6)
60943 C
60944       PWT(4)=UQKWT*UQKWT*DIQWT
60945       PWT(5)=UQKWT*DQKWT*DIQWT*HALF
60946       PWT(6)=DQKWT*DQKWT*DIQWT
60947       PWT(7)=UQKWT*SQKWT*DIQWT*HALF
60948       PWT(8)=DQKWT*SQKWT*DIQWT*HALF
60949       PWT(9)=SQKWT*SQKWT*DIQWT
60950       QMAX=MAX(PWT(1),PWT(2),PWT(3))
60951       PMAX=MAX(PWT(4),PWT(5),PWT(6),PWT(7),PWT(8),PWT(9),
60952      &         PWT(10),PWT(11),PWT(12),QMAX)
60953       PMAX=1./PMAX
60954       QMAX=1./QMAX
60955       DO 130 I=1,3
60956   130 QWT(I)=PWT(I)*QMAX
60957       DO 140 I=1,12
60958   140 PWT(I)=PWT(I)*PMAX
60959 C  MASSES OF DIQUARKS (ASSUME BINDING NEGLIGIBLE)
60960       RMASS(109)=RMASS(2)+RMASS(2)
60961       RMASS(110)=RMASS(1)+RMASS(2)
60962       RMASS(111)=RMASS(1)+RMASS(1)
60963       RMASS(112)=RMASS(2)+RMASS(3)
60964       RMASS(113)=RMASS(1)+RMASS(3)
60965       RMASS(114)=RMASS(3)+RMASS(3)
60966       DO 150 I=109,114
60967   150 RMASS(I+6)=RMASS(I)
60968 C  MASSES OF TOP HADRONS (ASSUME BINDING NEGLIGIBLE)
60969       RMASS(232)=RMASS(6)+RMASS(5)
60970       RMASS(233)=RMASS(6)+RMASS(1)
60971       RMASS(234)=RMASS(6)+RMASS(2)
60972       RMASS(235)=RMASS(6)+RMASS(3)
60973       RMASS(236)=RMASS(6)+RMASS(2)+RMASS(2)
60974       RMASS(237)=RMASS(6)+RMASS(1)+RMASS(2)
60975       RMASS(238)=RMASS(6)+RMASS(1)+RMASS(1)
60976       RMASS(239)=RMASS(6)+RMASS(2)+RMASS(3)
60977       RMASS(240)=RMASS(6)+RMASS(1)+RMASS(3)
60978       RMASS(241)=RMASS(6)+RMASS(3)+RMASS(3)
60979       RMASS(242)=RMASS(6)+RMASS(4)
60980       RMASS(243)=RMASS(6)+RMASS(5)
60981       RMASS(244)=RMASS(6)+RMASS(6)
60982       RMASS(232)=RMASS(243)
60983       DO 160 I=233,242
60984   160 RMASS(I+22)=RMASS(I)
60985 C Set up an array of cluster mass threholds
60986       CLMXPW=CLMAX**CLPOW
60987       RCLPOW=ONE/CLPOW
60988       CALL HWVZRO(144,CTHRPW(1,1))
60989       DO 170 I=1,6
60990       DO 170 J=1,6
60991       CTHRPW(I ,J  )=(CLMXPW+(RMASS(I    )+RMASS(J+6  ))**CLPOW)**RCLPOW
60992       CTHRPW(I ,J+6)=(CLMXPW+(RMASS(I    )+RMASS(J+108))**CLPOW)**RCLPOW
60993   170 CTHRPW(I+6,J )=(CLMXPW+(RMASS(I+114)+RMASS(J+6  ))**CLPOW)**RCLPOW
60994 C Decay length conversion factor GEV2MM hbar.c/e
60995       GEV2MM=1.D-15*SQRT(GEV2NB/10.)
60996 C Plank's constant/2pi (GeV.s)
60997       HBAR=GEV2MM/CSPEED
60998 C Check the SUSY DATA has been read in (if needed)
60999       IF((IPRO.EQ.7.OR.IPRO.EQ.8.OR.IPRO.EQ.9.OR.IPRO.EQ.11.OR.
61000      &   (IPRO.GE.30.AND.IPRO.LE.41)).AND..NOT.SUSYIN)
61001      &    CALL HWWARN('HWUINC',601)
61002 C---IMPORTANCE SAMPLING
61003       FIRST=.TRUE.
61004       XMIN=0
61005       XMAX=0
61006       XPOW=-1
61007       IF (IPRO.EQ.5) THEN
61008         IF (EMMAX.GT.ETLIM)  EMMAX=ETLIM
61009         IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
61010       ELSEIF (IPRO.EQ.13) THEN
61011         IF (EMMIN.EQ.ZERO)   EMMIN=10
61012         IF (EMMAX.GT.ETLIM)  EMMAX=ETLIM
61013         IF (IQK.GT.0.AND.IQK.LE.6) EMMIN=MAX(EMMIN,2*RMASS(IQK))
61014         XMIN=EMMIN
61015         XMAX=EMMAX
61016         XPOW=-EMPOW
61017       ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
61018      &    .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
61019      &    .OR.IPRO.EQ.51.OR.IPRO.EQ.53.OR.IPRO.EQ.55.OR.IPRO.EQ.60) THEN
61020         IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
61021         IF (IQK.NE.0.AND.IQK.LT.7.AND.IPRO.NE.23) THEN
61022           XMIN=2.*SQRT(PTMIN**2+RMASS(IQK)**2)
61023           XMAX=2.*SQRT(PTMAX**2+RMASS(IQK)**2)
61024           IF (XMAX.GT.ETLIM)  XMAX=ETLIM
61025         ELSE
61026           XMIN=2.*PTMIN
61027           XMAX=2.*PTMAX
61028         ENDIF
61029         XPOW=-PTPOW
61030 C--Gauge Boson pairs in hadron-hadron
61031       ELSEIF(IPRO.EQ.28) THEN
61032         IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
61033 C--Drell-Yan + 2 jets processes
61034       ELSEIF(IPRO.EQ.29) THEN
61035         IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
61036         IF(PTMAX.GT.ETLIM) PTMAX = ETLIM
61037 C--Cuts on the graviton to avoid unitarity violations
61038 C--If the width exceeds 0.1 times the mass this should be reset
61039       ELSEIF(IPRO.EQ.42) THEN
61040          EMMIN = 0.9D0*EMGRV
61041          EMMAX = 1.1D0*EMGRV
61042       ELSEIF (IPRO.EQ.52) THEN
61043         PTELM=PTLIM-RMASS(IQK)**2/(4.*PTLIM)
61044         IF (PTMAX.GT.PTELM) PTMAX=PTELM
61045         XMIN=PTMIN
61046         XMAX=PTMAX
61047         XPOW=-PTPOW
61048       ELSEIF (IPRO.EQ.30) THEN
61049         IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
61050         XMIN=2.*SQRT(PTMIN**2+RMMNSS**2)
61051         XMAX=2.*SQRT(PTMAX**2+RMMNSS**2)
61052         IF (XMAX.GT.ETLIM)  XMAX=ETLIM
61053         XPOW=-PTPOW
61054 C--PR MOD 7/7/99
61055       ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
61056         IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
61057           ID = MOD(IPROC,100)
61058           RPM(1) = RMMNSS
61059           RPM(2) = ZERO
61060           IF(ID.GE.10.AND.ID.LT.20) THEN
61061             RPM(1) = ABS(RMASS(450))
61062             IF(ID.GT.10) RPM(1) = ABS(RMASS(449+MOD(ID,10)))
61063           ELSEIF(ID.GE.20.AND.ID.LT.30) THEN
61064             RPM(1) = ABS(RMASS(454))
61065             IF(ID.GT.20) RPM(1) = ABS(RMASS(453+MOD(ID,20)))
61066           ELSEIF(ID.EQ.30) THEN
61067             RPM(1) = RMASS(449)
61068           ELSEIF(ID.EQ.40) THEN
61069             IF(IPRO.EQ.40) THEN
61070               RPM(1) = RMASS(425)
61071               DO I=1,5
61072                 RPM(1) = MIN(RPM(1),RMASS(425+I))
61073               ENDDO
61074             ELSE
61075               RPM(1) = MIN(RMASS(405),RMASS(406))
61076             ENDIF
61077             RPM(2) = RMASS(198)
61078           ELSEIF(ID.EQ.50) THEN
61079             IF(IPRO.EQ.40) THEN
61080               RPM(1) = RMASS(425)
61081               DO I=1,5
61082                 RPM(1) = MIN(RPM(1),RMASS(425+I))
61083               ENDDO
61084               DO I=1,3
61085                 RPM(2) = MIN(RPM(1),RMASS(433+2*I))
61086               ENDDO
61087               RPM(1) = MIN(RPM(1),RPM(2))
61088               RPM(2) = RMASS(203)
61089               DO I=1,2
61090                 RPM(2) = MIN(RPM(2),RMASS(204+I))
61091               ENDDO
61092             ELSE
61093               RPM(1) = RMASS(401)
61094               RPM(2) = RMASS(413)
61095               DO I=1,5
61096                 RPM(1) = MIN(RPM(1),RMASS(401+I))
61097                 RPM(2) = MIN(RPM(2),RMASS(413+I))
61098               ENDDO
61099               RPM(1) = MIN(RPM(1),RPM(2))
61100               RPM(2) = RMASS(203)
61101               DO I=1,2
61102                 RPM(2) = MIN(RPM(2),RMASS(204+I))
61103               ENDDO
61104             ENDIF
61105             RPM(2) = RMASS(203)
61106             DO I=1,2
61107               RPM(2) = MIN(RPM(2),RMASS(204+I))
61108             ENDDO
61109           ELSEIF(ID.GE.60) THEN
61110             RPM(1) = ZERO
61111           ENDIF
61112           RPM(1) = RPM(1)**2
61113           RPM(2) = RPM(2)**2
61114           XMIN = SQRT(RPM(1)+RPM(2)+TWO*(PTMIN**2+
61115      &           SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2))))
61116           XMAX = SQRT(RPM(1)+RPM(2)+TWO*(PTMAX**2+
61117      &           SQRT(RPM(1)*RPM(2)+PTMAX**2*(RPM(1)+RPM(2)+PTMAX**2))))
61118         IF (XMAX.GT.ETLIM)  XMAX=ETLIM
61119 C--end of mod
61120       ELSEIF (IPRO.EQ.90) THEN
61121         XMIN=SQRT(Q2MIN)
61122         XMAX=SQRT(Q2MAX)
61123         XPOW=1.-2.*Q2POW
61124       ELSEIF (IPRO.EQ.91) THEN
61125         IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
61126       ENDIF
61127 C---CALCULATE HIGGS WIDTH
61128       IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.10.OR.IPRO.EQ.16
61129      &.OR.IPRO.EQ.19.OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26
61130      &.OR.IPRO.EQ.27.OR.IPRO.EQ.95) THEN
61131         GAMH=RMASS(201)
61132         CALL HWDHIG(GAMH)
61133       ENDIF
61134 C---IF Q**2 CAN BE TOO SMALL, BREIT FRAME MAKES NO SENSE
61135       IF ((IPRO/10.EQ.9.AND.Q2MIN.LE.1.D-2).OR.
61136      &    (IPRO.EQ.91.AND.IQK.EQ.7)) BREIT=.FALSE.
61137       IF (IPRINT.NE.0) THEN
61138         IF (PBEAM1.NE.PBEAM2) WRITE (6,180) USECMF
61139         IF (IPRO.EQ.91.OR.IPRO.EQ.92)
61140      &      WRITE (6,190) PTMIN
61141         IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
61142      &      WRITE (6,200) Q2MIN,Q2MAX,BREIT
61143         IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
61144      &      WRITE (6,210) YBMIN,YBMAX
61145         IF (IPRO.EQ.91.AND.IQK.EQ.7)
61146      &      WRITE (6,220) Q2WWMN,Q2WWMX,BREIT,ZJMAX
61147         IF (IPROC/10.EQ.11) WRITE (6,230) THMAX
61148         IF (IPRO.EQ.13) WRITE (6,240) EMMIN,EMMAX
61149         IF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
61150      &  .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
61151      &  .OR.IPRO.EQ.51.OR.IPRO.EQ.52.OR.IPRO.EQ.53.OR.IPRO.EQ.55
61152      &  .OR.IPRO.EQ.60)
61153      &      WRITE (6,250) PTMIN,PTMAX
61154         IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.10.OR.IPRO.EQ.16
61155      &  .OR.IPRO.EQ.19.OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26
61156      &  .OR.IPRO.EQ.27.OR.IPRO.EQ.95)
61157      &      WRITE (6,260) RMASS(201),GAMH,
61158      &      GAMMAX,RMASS(201)+GAMMAX*GAMH,(BRHIG(I)*100,I=1,12)
61159         IF (IPRO.EQ.91) WRITE (6,270) BGSHAT,EMMIN,EMMAX
61160         IF (IPRO.EQ.5.AND.IQK.LT.50)
61161      &      WRITE (6,280) EMMIN,EMMAX,PTMIN,PTMAX,CTMAX
61162         IF (IPRO.EQ.5.AND.IQK.GE.50)
61163      &      WRITE (6,290) EMMIN,EMMAX,Q2MIN,Q2MAX,PTMIN
61164         IF (IPRO.GT.12.AND.
61165      &    (IPRO.LT.90.AND.(ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
61166      &                    (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) THEN
61167           WRITE (6,300) Q2WWMN,Q2WWMX,YWWMIN,YWWMAX
61168           IF (PHOMAS.GT.ZERO) WRITE (6,310) PHOMAS
61169         ENDIF
61170         IF (IPROC/10.EQ.10.OR.IPRO.EQ.90)
61171      &      WRITE (6,320) HARDME,SOFTME
61172 C  Check minimum mass threshold if ISR switched on
61173         IF ((IPRO.LE.3.OR.IPRO.EQ.6).AND.ZMXISR.GT.ZERO) THEN
61174           TEST=TWO*RMASS(IPART1)**2+ETLIM**2
61175           TEST=FOUR*RMASS(2)**2/TEST
61176           IF (TMNISR.LT.TEST) THEN
61177             WRITE(6,175) TMNISR,TEST
61178   175       FORMAT(10X,'Minimum invariant mass',F10.6,' too low'/
61179      &             10X,'increasing to  TMNISR=',F10.6)
61180             TMNISR=TEST
61181           ENDIF
61182           WRITE (6,330) TMNISR,ONE-ZMXISR
61183         ENDIF
61184         IF (WHMIN.GT.ZERO .AND. IPRO.GT.12.AND.(IPRO.EQ.90.OR.
61185      &       (ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
61186      &       (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) WRITE (6,340) WHMIN
61187   180   FORMAT(10X,'USE BEAM-TARGET C.M.F. =',L5)
61188   190   FORMAT(10X,'MIN P-T FOR O(AS) DILS =',F10.4)
61189   200   FORMAT(10X,'MIN ABS(Q**2) FOR DILS =',E10.4/
61190      &         10X,'MAX ABS(Q**2) FOR DILS =',E10.4/
61191      &         10X,'BREIT FRAME SHOWERING  =',L5)
61192   210   FORMAT(10X,'MIN BJORKEN Y FOR DILS =',F10.4/
61193      &         10X,'MAX BJORKEN Y FOR DILS =',F10.4)
61194   220   FORMAT(10X,'MIN ABS(Q**2) FOR J/PSI=',E10.4/
61195      &         10X,'MAX ABS(Q**2) FOR J/PSI=',E10.4/
61196      &         10X,'BREIT FRAME SHOWERING  =',L5/
61197      &         10X,'MAX Z FOR J/PSI        =',F10.4)
61198   230   FORMAT(10X,'MAX THRUST FOR 2->3    =',F10.4)
61199   240   FORMAT(10X,'MIN MASS FOR DRELL-YAN =',F10.4/
61200      &         10X,'MAX MASS FOR DRELL-YAN =',F10.4)
61201   250   FORMAT(10X,'MIN P-TRAN FOR 2->2    =',F10.4/
61202      &         10X,'MAX P-TRAN FOR 2->2    =',F10.4)
61203   260   FORMAT(10X,'HIGGS BOSON MASS       =',F10.4/
61204      &         10X,'HIGGS BOSON WIDTH      =',F10.4/
61205      &         10X,'CUTOFF = EMH +',F4.1,'*GAMH=',F10.4/
61206      &         10X,'HIGGS          D DBAR  =',F10.4/
61207      &         10X,'BRANCHING      U UBAR  =',F10.4/
61208      &         10X,'FRACTIONS      S SBAR  =',F10.4/
61209      &         10X,'(PER CENT)     C CBAR  =',F10.4/
61210      &         10X,'               B BBAR  =',F10.4/
61211      &         10X,'               T TBAR  =',F10.4/
61212      &         10X,'              E+ E-    =',F10.4/
61213      &         10X,'             MU+ MU-   =',F10.4/
61214      &         10X,'            TAU+ TAU-  =',F10.4/
61215      &         10X,'               W W     =',F10.4/
61216      &         10X,'               Z Z     =',F10.4/
61217      &         10X,'           GAMMA GAMMA =',F10.4)
61218   270   FORMAT(10X,'SCALE FOR BGF IS S-HAT =',L5/
61219      &         10X,'MIN MASS FOR BGF       =',F10.4/
61220      &         10X,'MAX MASS FOR BGF       =',F10.4)
61221   280   FORMAT(10X,'MIN MASS FOR 2 PHOTONS =',F10.4/
61222      &         10X,'MAX MASS FOR 2 PHOTONS =',F10.4/
61223      &         10X,'MIN PT OF 2 PHOTON CMF =',F10.4/
61224      &         10X,'MAX PT OF 2 PHOTON CMF =',F10.4/
61225      &         10X,'MAX COS THETA IN CMF   =',F10.4)
61226   290   FORMAT(10X,'MIN MASS FOR GAMMA + W =',F10.4/
61227      &         10X,'MAX MASS FOR GAMMA + W =',F10.4/
61228      &         10X,'MIN ABS(Q**2)          =',E10.4/
61229      &         10X,'MAX ABS(Q**2)          =',E10.4/
61230      &         10X,'MIN PT                 =',F10.4)
61231   300   FORMAT(10X,'MIN Q**2 FOR WW PHOTON =',F10.4/
61232      &         10X,'MAX Q**2 FOR WW PHOTON =',F10.4/
61233      &         10X,'MIN MOMENTUM FRACTION  =',F10.4/
61234      &         10X,'MAX MOMENTUM FRACTION  =',F10.4)
61235   310   FORMAT(10X,'GAMMA* S.F. MASS PARAM =',F10.4)
61236   320   FORMAT(10X,'HARD M.E. MATCHING     =',L5/
61237      &         10X,'SOFT M.E. MATCHING     =',L5)
61238   330   FORMAT(10X,'MIN MTM FRAC FOR ISR   =',1PE10.4/
61239      &         10X,'1-MAX MTM FRAC FOR ISR =',1PE10.4)
61240   340   FORMAT(10X,'MINIMUM HADRONIC MASS  =',F10.4)
61241         IF (LWEVT.LE.0) THEN
61242           WRITE (6,350)
61243         ELSE
61244           WRITE (6,360) LWEVT
61245         ENDIF
61246   350   FORMAT(/10X,'NO EVENTS WILL BE WRITTEN TO DISK')
61247   360   FORMAT(/10X,'EVENTS WILL BE OUTPUT ON UNIT',I4)
61248       ENDIF
61249 C Verify and print beam polarisations
61250       IF((IPRO.EQ.1.OR.IPRO.EQ.3).OR.
61251      &  ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.960)).OR.
61252      &  ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.970)))THEN
61253 C Set up transverse polarisation parameters for e+e-
61254         IF ((EPOLN(1)**2+EPOLN(2)**2)
61255      &     *(PPOLN(1)**2+PPOLN(2)**2).GT.ZERO) THEN
61256           TPOL=.TRUE.
61257           COSS=EPOLN(1)*PPOLN(1)-EPOLN(2)*PPOLN(2)
61258           SINS=EPOLN(2)*PPOLN(1)+EPOLN(1)*PPOLN(2)
61259         ELSE
61260           TPOL=.FALSE.
61261         ENDIF
61262 C print out lepton beam polarisation(s)
61263         IF (IPRINT.NE.0) THEN
61264           IF (IPART1.EQ.121) THEN
61265             WRITE (6,370) PART1,EPOLN,PART2,PPOLN
61266           ELSE
61267             WRITE (6,370) PART1,PPOLN,PART2,EPOLN
61268           ENDIF
61269  370      FORMAT(/10X,A8,'Beam polarisation=',3F10.4/
61270      &            10X,A8,'Beam polarisation=',3F10.4)
61271         ENDIF
61272       ELSEIF (IPRO.GE.90.AND.IPRO.LE.99) THEN
61273         IF (IDB.GE.11.AND.IDB.LE.16) THEN
61274           CALL HWVZRO(3,PPOLN)
61275 C Check neutrino polarisations for DIS
61276           IF (IDB.EQ. 12.OR.IDB.EQ. 14.OR.IDB.EQ. 16.AND.
61277      &        EPOLN(3).NE.-ONE) EPOLN(3)=-ONE
61278           IF (IPRINT.NE.0) WRITE(6,380) PART1,EPOLN(3)
61279         ELSE
61280           CALL HWVZRO(3,EPOLN)
61281 C Check anti-neutrino polarisations for DIS
61282           IF (IDB.EQ.-12.OR.IDB.EQ.-14.OR.IDB.EQ.-16.AND.
61283      &        PPOLN(3).NE.ONE) PPOLN(3)=ONE
61284           IF (IPRINT.NE.0) WRITE(6,380) PART1,PPOLN(3)
61285         ENDIF
61286  380    FORMAT(/10X,A8,1X,'Longitudinal beam polarisation=',F10.4/)
61287       ENDIF
61288       IF (IPRINT.NE.0) THEN
61289         IF (ZPRIME) THEN
61290           WRITE(6,390) RMASS(200),RMASS(202),GAMZ,GAMZP
61291           WRITE(6,400) (RNAME(I),VFCH(I,1),AFCH(I,1),VFCH(I,2),
61292      &                  AFCH(I,2),I=1,6)
61293           WRITE(6,400) (RNAME(110+I),VFCH(I,1),AFCH(I,1),
61294      &                  VFCH(I,2),AFCH(I,2),I=11,16)
61295   390     FORMAT(/10X,'MASSIVE NEUTRAL VECTOR BOSON PARAMS'/
61296      &            10X,'Z   MASS=',F10.4,7X,'Z-PRIME MASS=',F10.4/
61297      &            10X,'   WIDTH=',F10.4,7X,'       WIDTH=',F10.4/
61298      &            10X,'FERMION COUPLINGS: e.(V.1+A.G_5)G_mu'/
61299      &            10X,'FERMION:  VECTOR     AXIAL',6X,
61300      &                'VECTOR     AXIAL'/)
61301   400     FORMAT(10X,A8,2X,F10.4,1X,F10.4,1X,F10.4,1X,F10.4)
61302         ENDIF
61303         IF (MIXING) THEN
61304           WRITE(6,410) XMIX(2),YMIX(2),XMIX(1),YMIX(1)
61305   410     FORMAT(/10X,'B_d: Delt-M/Gam =',F6.4,
61306      &                ' Delt-Gam/2*Gam =',F6.4,/
61307      &            10X,'B_s: Delt-M/Gam =',F6.2,
61308      &                ' Delt-Gam/2*Gam =',F6.4)
61309         ENDIF
61310         IF (CLRECO) WRITE(6,420) PRECO,EXAG
61311   420   FORMAT(/10X,'Colour rearrangement ALLOWED, probability =',F6.4,/
61312      &          10x,'Weak boson life-time exaggeration factor =',F10.6)
61313 C---PDF STRUCTURE FUNCTIONS
61314         WRITE (6,'(1X)')
61315         DO 450 I=1,2
61316           IF (MODPDF(I).GE.0) THEN
61317             WRITE (6,430) I,MODPDF(I),AUTPDF(I)
61318           ELSE
61319             WRITE (6,440) I
61320           ENDIF
61321  430      FORMAT(10X,'PDFLIB USED FOR BEAM',I2,': SET',I3,' OF ',A20)
61322  440      FORMAT(10X,'PDFLIB NOT USED FOR BEAM',I2)
61323  450    CONTINUE
61324 C---GET THE UGLY INITIALISATION MESSAGES OVER AND DONE WITH NOW TOO
61325         DO 460 I=1,2
61326           IF (MODPDF(I).GE.0) THEN
61327             PARM(1)=AUTPDF(I)
61328             VAL(1)=FLOAT(MODPDF(I))
61329             PARMSAVE=PARM(1)
61330             VALSAVE=VAL(1)
61331             FSTPDF=.TRUE.
61332             X=0.5
61333             QSCA=10
61334 C---FIX TO CALL SCHULER-SJOSTRAND CODE
61335             IF (AUTPDF(I).EQ.'SaSph') THEN
61336               ISET=MOD(MODPDF(I),10)
61337               IOP1=MOD(MODPDF(I)/10,2)
61338               IOP2=MOD(MODPDF(I)/20,2)
61339               IP2=MODPDF(I)/100
61340               IF (ISET.EQ.1) THEN
61341                 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1D'
61342               ELSEIF (ISET.EQ.2) THEN
61343                 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1M'
61344               ELSEIF (ISET.EQ.3) THEN
61345                 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2D'
61346               ELSEIF (ISET.EQ.4) THEN
61347                 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2M'
61348               ELSE
61349                 WRITE (6,'(10X,A)')'UNKNOWN SCHULER-SJOSTRAND PDF SET'
61350                 CALL HWWARN('HWUINC',500)
61351               ENDIF
61352               IF (IOP1.EQ.1) THEN
61353                 WRITE (6,'(10X,A)') 'WITH DIRECT COMPONENT IN DIS'
61354                 IF (IPRO.NE.90) WRITE (6,'(10X,A)')
61355      $               'NOT RECOMMENDED FOR NON-DIS PROCESSES'
61356               ENDIF
61357               IF (IOP2.EQ.1) THEN
61358                 WRITE (6,'(10X,A)') 'WITH P**2 DEPENDENCE INCLUDED'
61359                 IF (PHOMAS.GT.ZERO)
61360      $          WRITE (6,'(10X,A)') 'NOT RECOMMENDED WITH PHOMAS.GT.0'
61361                 IF (IP2.GT.0)
61362      $          WRITE (6,'(10X,A,I2)') 'WITH IP2 OPTION EQUAL TO',IP2
61363               ENDIF
61364             ELSEIF (AUTPDF(I).EQ.'SSph') THEN
61365               WRITE (6,'(10X,A)') 'THE ACRONYM FOR SCHULER-SJOSTRAND'
61366               WRITE (6,'(10X,A)') 'HAS CHANGED TO SaSph ACCORDING TO'
61367               WRITE (6,'(10X,A)') 'THEIR WISHES.  SSph NO LONGER WORKS'
61368               STOP
61369             ELSE
61370               CALL PDFSET(PARM,VAL)
61371               CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
61372             ENDIF
61373           ENDIF
61374  460    CONTINUE
61375         WRITE (6,'(1X)')
61376       ENDIF
61377 C Set up neutral B meson mixing parameters
61378       IF (MIXING.AND..NOT.(RSTAB(223).AND.RSTAB(247))) THEN
61379         XMRCT(1)=XMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
61380         YMRCT(1)=YMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
61381       ENDIF
61382       IF (MIXING.AND..NOT.(RSTAB(221).AND.RSTAB(245))) THEN
61383         XMRCT(2)=XMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
61384         YMRCT(2)=YMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
61385       ENDIF
61386 C---B DECAY PACKAGE
61387       IF (BDECAY.EQ.'EURO') THEN
61388         IF (IPRINT.NE.0) WRITE (6,470) 'EURODEC'
61389       ELSEIF (BDECAY.EQ.'CLEO') THEN
61390         IF (IPRINT.NE.0) WRITE (6,470) 'CLEO'
61391       ELSE
61392         BDECAY='HERW'
61393       ENDIF
61394   470 FORMAT (10X,A,' B DECAY PACKAGE WILL BE USED')
61395 C---TAU DECAY PACKAGE
61396       IF(TAUDEC.EQ.'TAUOLA') THEN
61397         IF(IPRINT.NE.0) WRITE(6,475) 'TAUOLA'
61398         CALL HWDTAU(-1,0,0.0D0)
61399       ENDIF
61400   475 FORMAT(10X,A,' TAU DECAY PACKAGE WILL BE USED'/)
61401 C---COMPUTE PARTICLE PROPERTIES FOR HADRONIZATION
61402       CALL HWURES
61403 C Prepare internal decay tables and do diagnostic checks
61404       CALL HWUDKS
61405 C Convert ampersands to backslahes in particle LaTeX names
61406       CALL HWUATS
61407 C---MISCELLANEOUS DERIVED QUANTITIES
61408       TMTOP=2.*LOG(RMASS(6)/30.)
61409       PXRMS=PTRMS/SQRT(2.)
61410       ZBINM=0.25/ZBINM
61411       PSPLT(1)=1./PSPLT(1)
61412       PSPLT(2)=1./PSPLT(2)
61413       NDTRY=2*NCTRY
61414       NGSPL=0
61415       PGSMX=0.
61416       DO 480 I=1,4
61417       PGS=HWUPCM(RMASS(13),RMASS(I),RMASS(I))
61418       IF (PGS.GE.ZERO) NGSPL=I
61419       IF (PGS.GE.PGSMX) PGSMX=PGS
61420   480 PGSPL(I)=PGS
61421       CALL HWVZRO(6,PTINT)
61422       IF (IPRO.NE.80) THEN
61423 C---SET UP TABLES OF SUDAKOV FORM FACTORS, GIVING
61424 C   PROBABILITY DISTRIBUTION IN VARIABLE Q = E*SQRT(XI)
61425         NSUD=NFLAV
61426         CALL HWBSUD
61427 C---SET PARAMETERS FOR SPACELIKE BRANCHING
61428         DO 500 I=1,NSUD
61429         DO 490 J=2,NQEV
61430         IF (QEV(J,I).GT.QSPAC) GOTO 500
61431   490   CONTINUE
61432   500   NSPAC(I)=J-1
61433       ENDIF
61434       EVWGT=AVWGT
61435       ISTAT=1
61436 C--optimize the weights for the channels if needed
61437       CALL HWIPHS(2)
61438 C--perform the initialisation of the SUSY ME's
61439       IF(SYSPIN.OR.THREEB.OR.FOURB) THEN
61440         CALL HWISPN
61441         IF (IPRINT.NE.0) WRITE (6,510)
61442  510    FORMAT(/10X,'CHECKING SUSY DECAY MATRIX ELEMENTS')
61443       ENDIF
61444 C Print particle decay tables here
61445       IF (IPRINT.GE.2) CALL HWUDPR
61446 C--   initialise photos if needed
61447       IF ((TAUDEC.EQ.'TAUOLA'.AND.IFPHOT.EQ.1).OR.ITOPRD.EQ.1)
61448      &     CALL PHOINI
61449       END
61450 CDECK  ID>, HWUINE.
61451 *CMZ :-        -16/10/93  12.42.15  by  Mike Seymour
61452 *-- Author :    Bryan Webber
61453 C-----------------------------------------------------------------------
61454       SUBROUTINE HWUINE
61455 C-----------------------------------------------------------------------
61456 C     INITIALISES AN EVENT
61457 C-----------------------------------------------------------------------
61458       INCLUDE 'herwig65.inc'
61459       DOUBLE PRECISION HWRGEN,HWRGET,DUMMY
61460       REAL TL
61461       LOGICAL CALLED,HWRLOG
61462       EXTERNAL HWRGEN,HWRGET,HWRLOG
61463       COMMON/HWDBUG/CALLED
61464 C---CHECK THAT MAIN PROGRAM HAS BEEN MODIFIED CORRECTLY
61465       IF (NEVHEP.GT.0.AND..NOT.CALLED) THEN
61466         WRITE (6,10)
61467  10     FORMAT (1X,'A call to the subroutine HWUFNE should be added to',
61468      &      /,' the main program, immediately after the call to HWMEVT')
61469         CALL HWWARN('HWUINE',500)
61470       ENDIF
61471       CALLED=.FALSE.
61472 C---CHECK TIME LEFT
61473       CALL HWUTIM(TL)
61474       IF (TL.LT.TLOUT) CALL HWWARN('HWUINE',200)
61475 C---UPDATE RANDOM NUMBER SEED
61476       DUMMY = HWRGET(NRN)
61477       NEVHEP=NEVHEP+1
61478       IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV+1
61479       NHEP=0
61480       ISTAT=6
61481       IERROR=0
61482       EVWGT=AVWGT
61483       HVFCEN=.FALSE.
61484       ISLENT=1
61485       NQDK=0
61486 C---DECIDE WHETHER TO GENERATE SOFT UNDERLYING EVENT
61487       GENSOF=IPROC.GE.1300.AND.IPROC.LT.10000.AND.
61488      &      (IPROC.EQ.8000.OR.HWRLOG(PRSOF))
61489 C Zero arrays
61490       CALL HWVZRI(2*NMXHEP,JMOHEP)
61491       CALL HWVZRI(2*NMXHEP,JDAHEP)
61492       CALL HWVZRO(4*NMXHEP,VHEP)
61493       CALL HWVZRO(3*NMXHEP,RHOHEP)
61494       EMSCA=ZERO
61495       IF(SYSPIN) THEN
61496         NSPN = 0
61497         CALL HWVZRI(  NMXHEP,ISNHEP)
61498         CALL HWVZRI(  NMXSPN,JMOSPN)
61499         CALL HWVZRI(2*NMXSPN,JDASPN)
61500         CALL HWVZRI(  NMXSPN, IDSPN)
61501       ENDIF
61502       END
61503 CDECK  ID>, HWULB4.
61504 *CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
61505 *-- Author :    Adapted by Bryan Webber
61506 C-----------------------------------------------------------------------
61507       SUBROUTINE HWULB4(PS,PI,PF)
61508 C-----------------------------------------------------------------------
61509 C     TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
61510 C     N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
61511 C-----------------------------------------------------------------------
61512       IMPLICIT NONE
61513       DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
61514       IF (PS(4).EQ.PS(5)) THEN
61515         PF(1)= PI(1)
61516         PF(2)= PI(2)
61517         PF(3)= PI(3)
61518         PF(4)= PI(4)
61519       ELSE
61520         PF4  = (PI(1)*PS(1)+PI(2)*PS(2)
61521      &         +PI(3)*PS(3)+PI(4)*PS(4))/PS(5)
61522         FN   = (PF4+PI(4)) / (PS(4)+PS(5))
61523         PF(1)= PI(1) + FN*PS(1)
61524         PF(2)= PI(2) + FN*PS(2)
61525         PF(3)= PI(3) + FN*PS(3)
61526         PF(4)= PF4
61527       END IF
61528       END
61529 CDECK  ID>, HWULDO.
61530 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
61531 *-- Author :    Bryan Webber
61532 C----------------------------------------------------------------------
61533       FUNCTION HWULDO(P,Q)
61534 C----------------------------------------------------------------------
61535 C   LORENTZ 4-VECTOR DOT PRODUCT
61536 C----------------------------------------------------------------------
61537       IMPLICIT NONE
61538       DOUBLE PRECISION HWULDO,P(4),Q(4)
61539       HWULDO=P(4)*Q(4)-(P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3))
61540       END
61541 CDECK  ID>, HWULF4.
61542 *CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
61543 *-- Author :    Adapted by Bryan Webber
61544 C-----------------------------------------------------------------------
61545       SUBROUTINE HWULF4(PS,PI,PF)
61546 C-----------------------------------------------------------------------
61547 C     TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
61548 C     N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
61549 C-----------------------------------------------------------------------
61550       IMPLICIT NONE
61551       DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
61552       IF (PS(4).EQ.PS(5)) THEN
61553         PF(1)= PI(1)
61554         PF(2)= PI(2)
61555         PF(3)= PI(3)
61556         PF(4)= PI(4)
61557       ELSE
61558         PF4  = (PI(4)*PS(4)-PI(3)*PS(3)
61559      &         -PI(2)*PS(2)-PI(1)*PS(1))/PS(5)
61560         FN   = (PF4+PI(4)) / (PS(4)+PS(5))
61561         PF(1)= PI(1) - FN*PS(1)
61562         PF(2)= PI(2) - FN*PS(2)
61563         PF(3)= PI(3) - FN*PS(3)
61564         PF(4)= PF4
61565       END IF
61566       END
61567 CDECK  ID>, HWULI2.
61568 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
61569 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
61570 C-----------------------------------------------------------------------
61571       FUNCTION HWULI2(X)
61572 C-----------------------------------------------------------------------
61573 C     Complex dilogarithm function, Li_2 (Spence function)
61574 C-----------------------------------------------------------------------
61575       IMPLICIT NONE
61576       DOUBLE COMPLEX HWULI2,PROD,Y,Y2,X,Z
61577       DOUBLE PRECISION XR,XI,R2,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2,
61578      & ZERO,ONE,HALF
61579       PARAMETER (ZERO=0.0D0, ONE=1.0D0, HALF=0.5D0)
61580       SAVE A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2
61581       DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2/ -0.250000000000000D0,
61582      & -0.111111111111111D0,-0.010000000000000D0,-0.017006802721088D0,
61583      & -0.019444444444444D0,-0.020661157024793D0,-0.021417300648069D0,
61584      & -0.021948866377231D0,-0.022349233811171D0,-0.022663689135191D0,
61585      &  1.644934066848226D0/
61586       PROD(Y,Y2)=Y*(ONE+A1*Y*(ONE+A2*Y*(ONE+A3*Y2*(ONE+A4*Y2*(ONE+A5*Y2*
61587      & (ONE+A6*Y2*(ONE+A7*Y2*(ONE+A8*Y2*(ONE+A9*Y2*(ONE+A10*Y2))))))))))
61588       XR=DREAL(X)
61589       XI=DIMAG(X)
61590       R2=XR*XR+XI*XI
61591       IF (R2.GT.ONE.AND.(XR/R2).GT.HALF) THEN
61592          Z=-LOG(ONE/X)
61593          HWULI2=PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)+HALF*LOG(X)**2
61594       ELSEIF (R2.GT.ONE.AND.(XR/R2).LE.HALF) THEN
61595          Z=-LOG(ONE-ONE/X)
61596          HWULI2=-PROD(Z,Z*Z)-ZETA2-HALF*LOG(-X)**2
61597       ELSEIF (R2.EQ.ONE.AND.XI.EQ.ZERO) THEN
61598          HWULI2=ZETA2
61599       ELSEIF (R2.LE.ONE.AND.XR.GT.HALF) THEN
61600          Z=-LOG(X)
61601          HWULI2=-PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)
61602       ELSE
61603          Z=-LOG(ONE-X)
61604          HWULI2=PROD(Z,Z*Z)
61605       ENDIF
61606       END
61607 CDECK  ID>, HWULOB.
61608 *CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
61609 *-- Author :    Adapted by Bryan Webber
61610 C-----------------------------------------------------------------------
61611       SUBROUTINE HWULOB(PS,PI,PF)
61612 C-----------------------------------------------------------------------
61613 C     TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
61614 C     N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
61615 C-----------------------------------------------------------------------
61616       IMPLICIT NONE
61617       DOUBLE PRECISION PS(5),PI(5),PF(5)
61618       CALL HWULB4(PS,PI,PF)
61619       PF(5)= PI(5)
61620       END
61621 CDECK  ID>, HWULOF.
61622 *CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
61623 *-- Author :    Adapted by Bryan Webber
61624 C-----------------------------------------------------------------------
61625       SUBROUTINE HWULOF(PS,PI,PF)
61626 C-----------------------------------------------------------------------
61627 C     TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
61628 C     N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
61629 C-----------------------------------------------------------------------
61630       IMPLICIT NONE
61631       DOUBLE PRECISION PS(5),PI(5),PF(5)
61632       CALL HWULF4(PS,PI,PF)
61633       PF(5)= PI(5)
61634       END
61635 CDECK  ID>, HWULOR.
61636 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
61637 *-- Author :    Giovanni Abbiendi & Luca Stanco
61638 C-----------------------------------------------------------------------
61639       SUBROUTINE HWULOR (TRANSF,PI,PF)
61640 C-----------------------------------------------------------------------
61641 C     Makes the HWULOR transformation specified by TRANSF on the
61642 C     quadrivector PI(5), giving PF(5).
61643 C-----------------------------------------------------------------------
61644       IMPLICIT NONE
61645       DOUBLE PRECISION TRANSF(4,4),PI(5),PF(5)
61646       INTEGER I,J
61647       DO 1 I=1,5
61648         PF(I)=0.D0
61649     1 CONTINUE
61650       DO 3 I=1,4
61651        DO 2 J=1,4
61652          PF(I) = PF(I) + TRANSF(I,J) * PI(J)
61653     2  CONTINUE
61654     3 CONTINUE
61655       PF(5) = PI(5)
61656       END
61657 CDECK  ID>, HWUMAS.
61658 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
61659 *-- Author :    Bryan Webber
61660 C-----------------------------------------------------------------------
61661       SUBROUTINE HWUMAS(P)
61662 C-----------------------------------------------------------------------
61663 C     PUTS INVARIANT MASS IN 5TH COMPONENT OF VECTOR
61664 C     (NEGATIVE SIGN IF SPACELIKE)
61665 C-----------------------------------------------------------------------
61666       IMPLICIT NONE
61667       DOUBLE PRECISION HWUSQR,P(5)
61668       EXTERNAL HWUSQR
61669       P(5)=HWUSQR((P(4)+P(3))*(P(4)-P(3))-P(1)**2-P(2)**2)
61670       END
61671 CDECK  ID>, HWUMBW.
61672 *CMZ :-        -21/02/98  11.11.56  by  Bryan Webber
61673 *-- Author :    Bryan Webber
61674 C-----------------------------------------------------------------------
61675       FUNCTION HWUMBW(ID)
61676 C-----------------------------------------------------------------------
61677 C     CHOOSES MASS ACCORDING TO BREIT-WIGNER DISTRIBUTION
61678 C--BRW fix 27/8/04: changed from mass to mass-squared BW formula
61679 C-----------------------------------------------------------------------
61680       INCLUDE 'herwig65.inc'
61681       DOUBLE PRECISION HWUMBW,HWRGEN,WMX,TAU,GAM,T,TM
61682       INTEGER ID
61683 C--WMX IS MAX NUMBER OF WIDTHS FROM NOMINAL MASS
61684       WMX=GAMMAX
61685       HWUMBW=RMASS(ID)
61686       IF(ID.EQ.198.OR.ID.EQ.199) THEN
61687         TAU = HBAR/GAMW
61688       ELSEIF(ID.EQ.200) THEN
61689         TAU = HBAR/GAMZ
61690       ELSEIF(ID.EQ.201) THEN
61691         TAU = HBAR/GAMH
61692       ELSE
61693         TAU=RLTIM(ID)
61694       ENDIF
61695       IF (TAU.EQ.ZERO.OR.TAU.GT.1D-18) RETURN
61696       GAM=HBAR/TAU
61697  1    T=TAN(PIFAC*(HWRGEN(0)-HALF))
61698       TM=RMASS(ID)*(RMASS(ID)+GAM*T)
61699       IF(TM.LT.ZERO) GOTO 1
61700       TM=SQRT(TM)
61701       IF (ABS(TM-RMASS(ID)).GT.WMX*GAM) GOTO 1
61702       HWUMBW=TM
61703       END
61704 CDECK  ID>, HWUNST.
61705 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
61706 *-- Author :    Ian Knowles
61707 C-----------------------------------------------------------------------
61708       FUNCTION HWUNST(N)
61709 C-----------------------------------------------------------------------
61710 C     Creates a character string of length 7 equivalent to integer N
61711 C-----------------------------------------------------------------------
61712       IMPLICIT NONE
61713       INTEGER N,I,M,NN(7)
61714       CHARACTER*1 NCHAR(0:9)
61715       CHARACTER*7 HWUNST
61716       SAVE NCHAR
61717       DATA NCHAR/'0','1','2','3','4','5','6','7','8','9'/
61718       M=1
61719       DO 10 I=7,1,-1
61720       NN(I)=MOD(N/M,10)
61721   10  M=M*10
61722       WRITE(HWUNST,'(7A1)') (NCHAR(NN(I)),I=1,7)
61723       END
61724 CDECK  ID>, HWUPCM.
61725 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
61726 *-- Author :    Bryan Webber
61727 C-----------------------------------------------------------------------
61728       FUNCTION HWUPCM(EM0,EM1,EM2)
61729 C-----------------------------------------------------------------------
61730 C     C.M. MOMENTUM FOR DECAY MASSES EM0 -> EM1 + EM2
61731 C     SET TO -1 BELOW THRESHOLD
61732 C-----------------------------------------------------------------------
61733       IMPLICIT NONE
61734       DOUBLE PRECISION HWUPCM,EM0,EM1,EM2,EMS,EMD
61735       EMS=ABS(EM1+EM2)
61736       EMD=ABS(EM1-EM2)
61737       IF (EM0.LT.EMS.OR.EM0.LT.EMD) THEN
61738         HWUPCM=-1.
61739       ELSEIF (EM0.EQ.EMS.OR.EM0.EQ.EMD) THEN
61740         HWUPCM=0.
61741       ELSE
61742         HWUPCM=SQRT((EM0+EMD)*(EM0-EMD)*
61743      &              (EM0+EMS)*(EM0-EMS))*.5/EM0
61744       ENDIF
61745       END
61746 CDECK  ID>, HWURAP.
61747 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
61748 *-- Author :    Bryan Webber
61749 C-----------------------------------------------------------------------
61750       FUNCTION HWURAP(P)
61751 C-----------------------------------------------------------------------
61752 C     LONGITUDINAL RAPIDITY (SET TO +/-1000 IF TOO LARGE)
61753 C-----------------------------------------------------------------------
61754       IMPLICIT NONE
61755       DOUBLE PRECISION HWURAP,EMT2,P(5),ZERO
61756       PARAMETER (ZERO=0.D0)
61757       EMT2=P(1)**2+P(2)**2+P(5)**2
61758       IF (P(3).GT.ZERO) THEN
61759         IF (EMT2.EQ.ZERO) THEN
61760           HWURAP=1000.
61761         ELSE
61762           HWURAP= 0.5*LOG((P(3)+P(4))**2/EMT2)
61763         ENDIF
61764       ELSEIF (P(3).LT.ZERO) THEN
61765         IF (EMT2.EQ.ZERO) THEN
61766           HWURAP=-1000.
61767         ELSE
61768           HWURAP=-0.5*LOG((P(3)-P(4))**2/EMT2)
61769         ENDIF
61770       ELSE
61771           HWURAP=0.
61772       ENDIF
61773       END
61774 CDECK  ID>, HWUMPO.
61775 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
61776 *-- Author :  Kosuke Odagiri
61777 C-----------------------------------------------------------------------
61778       SUBROUTINE HWUMPO(P,M,PMM,MGAM,PPROJ,FPROP)
61779 C-----------------------------------------------------------------------
61780 C     RETURNS PROJECTION OPERATOR 1/(P-SLASH - M + I*MGAM) IN WEYL-BASIS
61781 C     USED IN SUBROUTINE HWH2QH
61782 C-----------------------------------------------------------------------
61783       IMPLICIT NONE
61784       DOUBLE PRECISION P(0:3),M,PMM,MGAM,ZERO,ONE
61785       DOUBLE COMPLEX PROP, PPROJ(4,4), CZERO
61786       LOGICAL FPROP
61787       PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),ONE=1.D0)
61788       IF (FPROP) THEN
61789        PROP=ONE/DCMPLX(PMM,MGAM)
61790       ELSE
61791        PROP=DCMPLX(ONE/PMM, ZERO)
61792       END IF
61793       PPROJ(1,1) =  M*PROP
61794       PPROJ(1,2) =  CZERO
61795       PPROJ(2,1) =  CZERO
61796       PPROJ(2,2) =  PPROJ(1,1)
61797       PPROJ(1,3) = (P(0)-P(3))*PROP
61798       PPROJ(1,4) =  DCMPLX(-P(1),P(2))*PROP
61799       PPROJ(2,3) =  DCMPLX(-P(1),-P(2))*PROP
61800       PPROJ(2,4) = (P(0)+P(3))*PROP
61801       PPROJ(3,1) =  PPROJ(2,4)
61802       PPROJ(3,2) = -PPROJ(1,4)
61803       PPROJ(4,1) = -PPROJ(2,3)
61804       PPROJ(4,2) =  PPROJ(1,3)
61805       PPROJ(3,3) =  PPROJ(1,1)
61806       PPROJ(3,4) =  CZERO
61807       PPROJ(4,3) =  CZERO
61808       PPROJ(4,4) =  PPROJ(1,1)
61809       END
61810 CDECK  ID>, HWUMPP.
61811 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
61812 *-- Author :  Kosuke Odagiri
61813 C-----------------------------------------------------------------------
61814       SUBROUTINE HWUMPP(M,GPM,PERM,U,UU,LR)
61815 C-----------------------------------------------------------------------
61816 C     APPLIES OPERATOR FROM HWUMPO ON SPINORS.
61817 C     SPINOR COMPONENTS CAN BE PERMUTATED (PERM) AND TRANSVERSED (LR)
61818 C-----------------------------------------------------------------------
61819       IMPLICIT NONE
61820       DOUBLE COMPLEX U(4), TEMP, A(4,4), M(16), UU(4), CZERO
61821       DOUBLE PRECISION GPM(2), FAC, ZERO, ONE, MONE
61822       INTEGER LR,TV(4,4,2),I,J, PERM(4), IZERO, GTOF(4)
61823       PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),IZERO=0)
61824       PARAMETER (ONE =1.D0,MONE = -1.D0)
61825       SAVE GTOF,TV
61826       DATA GTOF/1,1,2,2/
61827       DATA TV/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,
61828      &        1,5,9,13,2,6,10,14,3,7,11,15,4,8,12,16/
61829       DO I=1,4
61830        FAC = GPM(GTOF(I))
61831        IF ((PERM(I).EQ.IZERO).OR.(FAC.EQ.ZERO)) THEN
61832         DO J=1,4
61833          A(I,J)=CZERO
61834         END DO
61835        ELSE
61836         IF(FAC.EQ.ONE) THEN
61837          TEMP = U(PERM(I))
61838         ELSEIF(FAC.EQ.MONE) THEN
61839          TEMP = -U(PERM(I))
61840         ELSE
61841          TEMP = FAC*U(PERM(I))
61842         ENDIF
61843         IF(TEMP.NE.ZERO) THEN
61844          DO J=1,4
61845           IF(M(TV(I,J,LR)).NE.ZERO) THEN
61846            A(I,J)=TEMP*M(TV(I,J,LR))
61847           ELSE
61848            A(I,J)=ZERO
61849           ENDIF
61850          END DO
61851         ELSE
61852          DO J=1,4
61853           A(I,J)=ZERO
61854          END DO
61855         END IF
61856        END IF
61857       END DO
61858       DO J=1,4
61859        UU(J)=A(1,J)+A(2,J)+A(3,J)+A(4,J)
61860       END DO
61861       END
61862 CDECK  ID>, HWUPUP.
61863 *CMZ :-        -13/02/02  16.42.23  by  Peter Richardson
61864 *-- Author :    Bryan Webber
61865 C----------------------------------------------------------------------
61866       SUBROUTINE HWUPUP
61867 C----------------------------------------------------------------------
61868 C     Prints contents of the GUPI (Generic User Process Interface)
61869 C     common block HEPEUP
61870 C----------------------------------------------------------------------
61871       INCLUDE 'herwig65.inc'
61872       INTEGER MAXNUP
61873       PARAMETER (MAXNUP=500)
61874       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
61875       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
61876       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
61877      &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
61878      &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
61879      &              SPINUP(MAXNUP)
61880       INTEGER IUP,IWIG,I
61881       CHARACTER*8 NAME
61882       PRINT *
61883       PRINT *, ' I ISTUP IDUP NAME  MOTHUP ICOLUP     PUP'
61884       DO IUP=1,NUP
61885         CALL HWUIDT(1,IDUP(IUP),IWIG,NAME)
61886         PRINT 11,IUP,ISTUP(IUP),IDUP(IUP),NAME,MOTHUP(1,IUP),
61887      &  MOTHUP(2,IUP),ICOLUP(1,IUP),ICOLUP(2,IUP),(PUP(I,IUP),I=1,5)
61888       Enddo
61889  11   Format(2I3,I4,2X,A8,2I3,2I4,5F8.1)
61890       End
61891 CDECK  ID>, HWURES.
61892 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
61893 *-- Author :    Ian Knowles & Bryan Webber
61894 C-----------------------------------------------------------------------
61895       SUBROUTINE HWURES
61896 C-----------------------------------------------------------------------
61897 C     Using properties of particle I supplied in HWUDAT checks particles
61898 C     and antiparticles have compatible properties and sets   SWTEF(I) =
61899 C     ( rep. enhancement factor)^2  - used in cluster decays
61900 C     Finds iso-flavour hadrons and creates pointers for cluster decays.
61901 C     Sets CLDKWT(K) =(2J+1) spin weight normalizing largest value to 1.
61902 C-----------------------------------------------------------------------
61903       INCLUDE 'herwig65.inc'
61904       INTEGER NMXTMP
61905       PARAMETER (NMXTMP=20)
61906       DOUBLE PRECISION EPS,WTMX,REMMN,RWTMX,WTMP,RESTMP(91),WTMX2,
61907      & REMMN2,WT,CDWTMP(NMXTMP)
61908       INTEGER HWUANT,MAPF(89),MAPC(12,12),I,IANT,IABPDG,J,L,N,K,LTMP,
61909      & NCDKS,IMN,ITMP,LOCTMP(91),NTMP,NCDTMP(NMXTMP),IMN2
61910       EXTERNAL HWUANT
61911       PARAMETER (EPS=1.D-6)
61912       SAVE MAPF,MAPC
61913       DATA MAPF/21,31,41,51,61,12,32,42,52,62,13,23,43,53,63,14,24,34,
61914      & 44,54,64,15,25,35,45,55,65,16,26,36,46,56,66,111,112,113,122,123,
61915      & 133,222,223,233,333,-111,-112,-113,-122,-123,-133,-222,-223,-233,
61916      & -333,114,124,134,224,234,334,-114,-124,-134,-224,-234,-334,115,
61917      & 125,135,225,235,335,-115,-125,-135,-225,-235,-335,116,126,136,
61918      & 226,236,336,-116,-126,-136,-226,-236,-336/
61919       DATA MAPC/90,1,2,47,45,44,48,46,49,3,4,5,6,90,7,50,47,45,51,48,52,
61920      & 8,9,10,11,12,91,51,48,46,52,49,53,13,14,15,37,40,41,6*0,57,69,81,
61921      & 35,37,38,6*0,55,67,79,34,35,36,6*0,54,66,78,38,41,42,6*0,58,70,
61922      & 82,36,38,39,6*0,56,68,80,39,42,43,6*0,59,71,83,16,17,18,63,61,60,
61923      & 64,62,65,19,20,21,22,23,24,75,73,72,76,74,77,25,26,27,28,29,30,
61924      & 87,85,84,88,86,89,31,32,33/
61925 C Check particle/anti-particle properties are compatible
61926       WRITE(6,10)
61927   10  FORMAT(/10X,'Checking consistency of particle properties'/)
61928       DO 20 I=10,NRES
61929       IF (IDPDG(I).GT.0) THEN
61930         IANT=HWUANT(I)
61931         IF (IANT.EQ.20) GOTO 20
61932         IF (MOD(IDPDG(I)/1000,10).EQ.0.AND.
61933      &      MOD(IDPDG(I)/100 ,10).NE.0) THEN
61934           IF (MOD(IFLAV(I)/10-IFLAV(IANT),10).NE.0.OR.
61935      &        MOD(IFLAV(I)-IFLAV(IANT)/10,10).NE.0)
61936      &     WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
61937         ELSE
61938           IF (IFLAV(I)+IFLAV(IANT).NE.0)
61939      &     WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
61940         ENDIF
61941         IF (ICHRG(I)+ICHRG(IANT).NE.0)
61942      &   WRITE(6,40) RNAME(I),RNAME(IANT),ICHRG(I),ICHRG(IANT)
61943         IF (ABS(RMASS(I)-RMASS(IANT)).GT.EPS)
61944      &   WRITE(6,50) RNAME(I),RMASS(I),RMASS(IANT)
61945         IF (ABS(RLTIM(I)-RLTIM(IANT)).GT.EPS)
61946      &   WRITE(6,60) RNAME(I),RLTIM(I),RLTIM(IANT)
61947         IF (ABS(RSPIN(I)-RSPIN(IANT)).GT.EPS)
61948      &   WRITE(6,70) RNAME(I),RSPIN(I),RSPIN(IANT)
61949       ENDIF
61950   20  CONTINUE
61951   30  FORMAT(10X,A8,' flavour code=',I4,5X,' antiparticle=',I4)
61952   40  FORMAT(10X,2A8,' charge      =',I2,7X,' antiparticle=',I2)
61953   50  FORMAT(10X,A8,' mass        =',F7.3,2X,' antiparticle=',F7.3)
61954   60  FORMAT(10X,A8,' life time   =',E9.3,' antiparticle=',E9.3)
61955   70  FORMAT(10X,A8,' spin        =',F3.1,6X,' antiparticle=',F3.1)
61956 C Compute resonance properties
61957       DO 80 I=21,NRES
61958 C Compute representation weights for hadrons, used in cluster decays
61959       IABPDG=ABS(IDPDG(I))
61960       J=MOD(IABPDG,10)
61961       IF (J.EQ.2.AND.MOD(IABPDG/100,10).LT.MOD(IABPDG/10,10)) THEN
61962 C Singlet (Lambda-like) baryon
61963         SWTEF(I)=SNGWT**2
61964       ELSEIF (J.EQ.4) THEN
61965 C Decuplet baryon
61966         SWTEF(I)=DECWT**2
61967       ELSEIF(2*(J/2).NE.J) THEN
61968 C Mesons: identify by spin, angular momentum & radial excitation
61969         J=(J-1)/2
61970         L= MOD(IABPDG/10000 ,10)
61971         N= MOD(IABPDG/100000,10)
61972         IF (L.EQ.0.AND.J.EQ.0.AND.N.EQ.0.OR.
61973      &      L.GT.3.OR. J.GT.4.OR .N.GT.4) THEN
61974           SWTEF(I)=1.
61975         ELSE
61976           SWTEF(I)=REPWT(L,J,N)**2
61977         ENDIF
61978       ELSE
61979 C Not recognized
61980         SWTEF(I)=1.
61981       ENDIF
61982   80  CONTINUE
61983 C Prepare tables for cluster decays, except flavourless light mesons
61984       LTMP=1
61985       NCDKS=0
61986       DO 120 I=1,89
61987 C Store particles, flavour MAPF(I), noting highest spin and lowest mass
61988       WTMX=0.
61989       REMMN=1000.
61990       DO 90 J=21,NRES
61991       IF (VTOCDK(J).OR.IFLAV(J).NE.MAPF(I)) GOTO 90
61992       NCDKS=NCDKS+1
61993       IF (NCDKS.GT.NMXCDK) THEN
61994         CALL HWWARN('HWURES',101)
61995         GOTO 999
61996       ENDIF
61997       NCLDK(NCDKS)=J
61998       CLDKWT(NCDKS)=TWO*RSPIN(J)+ONE
61999       IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
62000       IF (RMASS(J).LT.REMMN) THEN
62001         REMMN=RMASS(J)
62002         IMN=NCDKS
62003       ENDIF
62004   90  CONTINUE
62005       IF (NCDKS+1-LTMP.EQ.0) THEN
62006         WRITE(6,100) MAPF(I)
62007   100   FORMAT(1X,'No particles exist for a cluster with flavour, ',I4,
62008      &            ' to decay into')
62009         CALL HWWARN('HWURES',51)
62010         GOTO 120
62011       ENDIF
62012 C Set scaled spin weights
62013       RWTMX=1./WTMX
62014       DO 110 J=LTMP,NCDKS
62015   110 CLDKWT(J)=CLDKWT(J)*RWTMX
62016 C Swap order if lightest hadron of given flavour not first
62017       IF (IMN.NE.LTMP) THEN
62018         ITMP=NCLDK(LTMP)
62019         WTMP=CLDKWT(LTMP)
62020         NCLDK(LTMP)=NCLDK(IMN)
62021         CLDKWT(LTMP)=CLDKWT(IMN)
62022         NCLDK(IMN)=ITMP
62023         CLDKWT(IMN)=WTMP
62024       ENDIF
62025 C Set pointers etc
62026       LOCTMP(I)=LTMP
62027       RESTMP(I)=FLOAT(NCDKS+1-LTMP)
62028       LTMP=NCDKS+1
62029   120 CONTINUE
62030 C Now do flavourless light mesons, allowing for mixing in weights
62031       WTMX=0.
62032       REMMN=1000.
62033       WTMX2=0.
62034       REMMN2=1000.
62035       NTMP=0
62036       DO 140 J=21,NRES
62037       IF (VTOCDK(J)) THEN
62038         GOTO 140
62039 C Calculate mixing weight for (|uubar>+|ddbar>)/sqrt(2) component
62040       ELSEIF (IFLAV(J).EQ.11) THEN
62041         WT=1.
62042       ELSEIF (IFLAV(J).EQ.33) THEN
62043 C eta - eta'
62044         IF     (J.EQ.22 ) THEN
62045           WT=COS(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62046         ELSEIF (J.EQ.25 ) THEN
62047           WT=SIN(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62048 C phi - omega
62049         ELSEIF (J.EQ.56 ) THEN
62050           WT=COS(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62051         ELSEIF (J.EQ.24 ) THEN
62052           WT=SIN(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62053 C f'_2 - f_2
62054         ELSEIF (J.EQ.58 ) THEN
62055           WT=COS(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62056         ELSEIF (J.EQ.26 ) THEN
62057           WT=SIN(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62058 C f_1(1420) - f_1(1285)
62059         ELSEIF (J.EQ.57 ) THEN
62060           WT=COS(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62061         ELSEIF (J.EQ.28 ) THEN
62062           WT=SIN(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62063 C h_1(1380) - h_1(1170)
62064         ELSEIF (J.EQ.289) THEN
62065           WT=COS(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62066         ELSEIF (J.EQ.288) THEN
62067           WT=SIN(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62068 C MISSING - f_0(1370)
62069         ELSEIF (J.EQ.294) THEN
62070           WT=SIN(F0MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62071 C phi_3 - omega_3
62072         ELSEIF (J.EQ.396) THEN
62073           WT=COS(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62074         ELSEIF (J.EQ.395) THEN
62075           WT=SIN(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62076 C eta_2(1645) - eta_2(1870)
62077         ELSEIF (J.EQ.397) THEN
62078           WT=COS(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62079         ELSEIF (J.EQ.398) THEN
62080           WT=SIN(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62081 C MISSING - omega(1600)
62082         ELSEIF (J.EQ.399) THEN
62083           WT=SIN(OMHMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62084         ELSE
62085           WT=1./3.
62086           WRITE(6,130) J
62087   130   FORMAT(1X,'Isoscalar particle ',I3,' not recognised,',
62088      &            ' no I=0 mixing assumed')
62089         ENDIF
62090       ELSE
62091         GOTO 140
62092       ENDIF
62093       IF (WT.GT.EPS) THEN
62094         NCDKS=NCDKS+1
62095         IF (NCDKS.GT.NMXCDK) THEN
62096           CALL HWWARN('HWURES',102)
62097           GOTO 999
62098         ENDIF
62099         NCLDK(NCDKS)=J
62100         CLDKWT(NCDKS)=WT*(TWO*RSPIN(J)+ONE)
62101         IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
62102         IF (RMASS(J).LT.REMMN) THEN
62103           REMMN=RMASS(J)
62104           IMN=NCDKS
62105         ENDIF
62106       ENDIF
62107       IF (ONE-WT.GT.EPS) THEN
62108         NTMP=NTMP+1
62109         IF (NTMP.GT.NMXTMP) THEN
62110           CALL HWWARN('HWURES',103)
62111           GOTO 999
62112         ENDIF
62113         NCDTMP(NTMP)=J
62114         CDWTMP(NTMP)=(ONE-WT)*(TWO*RSPIN(J)+ONE)
62115         IF (CDWTMP(NTMP).GT.WTMX2) WTMX2=CDWTMP(NTMP)
62116         IF (RMASS(J).LT.REMMN2) THEN
62117           REMMN2=RMASS(J)
62118           IMN2=NTMP
62119         ENDIF
62120       ENDIF
62121   140 CONTINUE
62122       IF (NCDKS+1-LTMP.EQ.0) THEN
62123         WRITE(6,100) 11
62124         CALL HWWARN('HWURES',52)
62125         GOTO 160
62126       ENDIF
62127 C Normalize scaled spin weights
62128       RWTMX=1./WTMX
62129       DO 150 I=LTMP,NCDKS
62130   150 CLDKWT(I)=CLDKWT(I)*RWTMX
62131 C Swap order if lightest hadron of flavour 11 not first
62132       IF (IMN.NE.LTMP) THEN
62133         ITMP=NCLDK(LTMP)
62134         WTMP=CLDKWT(LTMP)
62135         NCLDK(LTMP)=NCLDK(IMN)
62136         CLDKWT(LTMP)=CLDKWT(IMN)
62137         NCLDK(IMN)=ITMP
62138         CLDKWT(IMN)=WTMP
62139       ENDIF
62140   160 IF (NTMP.EQ.0) THEN
62141         WRITE(6,100) 33
62142         CALL HWWARN('HWURES',53)
62143         GOTO 180
62144       ENDIF
62145       IF (NCDKS+NTMP.GT.NMXCDK) THEN
62146         CALL HWWARN('HWURES',104)
62147         GOTO 999
62148       ENDIF
62149 C Store hadrons for |ssbar> channel and normalize their weights
62150       RWTMX=1./WTMX2
62151       DO 170 I=1,NTMP
62152       J=NCDKS+I
62153       NCLDK(J)=NCDTMP(I)
62154   170 CLDKWT(J)=CDWTMP(I)*RWTMX
62155 C Swap order if lightest hadron of flavour 33 not first
62156       IF (IMN2.NE.1) THEN
62157         ITMP=NCLDK(NCDKS+1)
62158         WTMP=CLDKWT(NCDKS+1)
62159         NCLDK(NCDKS+1)=NCLDK(NCDKS+IMN2)
62160         CLDKWT(NCDKS+1)=CLDKWT(NCDKS+IMN2)
62161         NCLDK(NCDKS+IMN2)=ITMP
62162         CLDKWT(NCDKS+IMN2)=WTMP
62163       ENDIF
62164 C Set pointers etc
62165   180 LOCTMP(90)=LTMP
62166       RESTMP(90)=FLOAT(NCDKS+1-LTMP)
62167       LOCTMP(91)=NCDKS+1
62168       RESTMP(91)=FLOAT(NTMP)
62169 C Set pointers to hadrons of given flavours for cluster decays
62170       DO 190 I=1,12
62171       DO 190 J=1,12
62172       K=MAPC(I,J)
62173       IF (K.EQ.0) THEN
62174         LOCN(I,J)=0
62175         RESN(I,J)=0
62176         RMIN(I,J)=MIN(RMASS(NCLDK(LOCN(I,1)))+RMASS(NCLDK(LOCN(1,J))),
62177      $       RMASS(NCLDK(LOCN(I,2)))+RMASS(NCLDK(LOCN(2,J))))+1.D-2
62178       ELSE
62179         LOCN(I,J)=LOCTMP(K)
62180         RESN(I,J)=RESTMP(K)
62181         RMIN(I,J)=RMASS(NCLDK(LOCN(I,J)))
62182       ENDIF
62183   190 CONTINUE
62184  999  RETURN
62185       END
62186 CDECK  ID>, HWUROB.
62187 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62188 *-- Author :    Bryan Webber
62189 C-----------------------------------------------------------------------
62190       SUBROUTINE HWUROB(R,P,Q)
62191 C-----------------------------------------------------------------------
62192 C     ROTATES VECTORS BY INVERSE OF ROTATION MATRIX R
62193 C-----------------------------------------------------------------------
62194       IMPLICIT NONE
62195       DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
62196       S1=P(1)*R(1,1)+P(2)*R(2,1)+P(3)*R(3,1)
62197       S2=P(1)*R(1,2)+P(2)*R(2,2)+P(3)*R(3,2)
62198       S3=P(1)*R(1,3)+P(2)*R(2,3)+P(3)*R(3,3)
62199       Q(1)=S1
62200       Q(2)=S2
62201       Q(3)=S3
62202       END
62203 CDECK  ID>, HWUROF.
62204 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62205 *-- Author :    Bryan Webber
62206 C-----------------------------------------------------------------------
62207       SUBROUTINE HWUROF(R,P,Q)
62208 C-----------------------------------------------------------------------
62209 C     ROTATES VECTORS BY ROTATION MATRIX R
62210 C-----------------------------------------------------------------------
62211       IMPLICIT NONE
62212       DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
62213       S1=R(1,1)*P(1)+R(1,2)*P(2)+R(1,3)*P(3)
62214       S2=R(2,1)*P(1)+R(2,2)*P(2)+R(2,3)*P(3)
62215       S3=R(3,1)*P(1)+R(3,2)*P(2)+R(3,3)*P(3)
62216       Q(1)=S1
62217       Q(2)=S2
62218       Q(3)=S3
62219       END
62220 CDECK  ID>, HWUROT.
62221 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62222 *-- Author :    Bryan Webber
62223 C-----------------------------------------------------------------------
62224       SUBROUTINE HWUROT(P,CP,SP,R)
62225 C-----------------------------------------------------------------------
62226 C     R IS ROTATION MATRIX TO GET FROM VECTOR P TO Z AXIS, FOLLOWED BY
62227 C     A ROTATION BY PSI ABOUT Z AXIS, WHERE CP = COS-PSI, SP = SIN-PSI
62228 C-----------------------------------------------------------------------
62229       IMPLICIT NONE
62230       DOUBLE PRECISION WN,CP,SP,PTCUT,PP,PT,CT,ST,CF,SF,P(3),R(3,3)
62231       SAVE WN,PTCUT
62232       DATA WN,PTCUT/1.D0,1.D-20/
62233       PT=P(1)**2+P(2)**2
62234       PP=P(3)**2+PT
62235       IF (PT.LE.PP*PTCUT) THEN
62236          CT=SIGN(WN,P(3))
62237          ST=0.
62238          CF=1.
62239          SF=0.
62240       ELSE
62241          PP=SQRT(PP)
62242          PT=SQRT(PT)
62243          CT=P(3)/PP
62244          ST=PT/PP
62245          CF=P(1)/PT
62246          SF=P(2)/PT
62247       END IF
62248       R(1,1)= CP*CF*CT+SP*SF
62249       R(1,2)= CP*SF*CT-SP*CF
62250       R(1,3)=-CP*ST
62251       R(2,1)=-CP*SF+SP*CF*CT
62252       R(2,2)= CP*CF+SP*SF*CT
62253       R(2,3)=-SP*ST
62254       R(3,1)= CF*ST
62255       R(3,2)= SF*ST
62256       R(3,3)= CT
62257       END
62258 CDECK  ID>, HWURQM.
62259 *CMZ :-        -17/07/03  11.11.56  by  Bryan Webber
62260 *-- Author :    Bryan Webber
62261 C----------------------------------------------------------------------
62262       SUBROUTINE HWURQM(SCALE,RQM)
62263 C-----------------------------------------------------------------------
62264 C     RUNNING QUARK MASSES (MSBAR, 2-LOOP, 5 FLAVOUR, NO THRESHOLDS)
62265 C     ASSUMING RMASS(IQ) IS POLE MASS
62266 C-----------------------------------------------------------------------
62267       INCLUDE 'herwig65.inc'
62268       DOUBLE PRECISION HWUALF,SCALE,ALFAS,P0,C1,CC,MHAT(6),RQM(6)
62269       INTEGER IQ
62270       LOGICAL FIRST
62271       SAVE P0,C1,MHAT,FIRST
62272       DATA FIRST/.TRUE./
62273       IF (FIRST) THEN
62274 C---INITIALIZE CONSTANTS
62275         P0=12./23.
62276         C1=3731./(3174.*PIFAC)
62277         CC=C1+4./(3.*PIFAC)
62278         DO IQ=1,6
62279            ALFAS=HWUALF(1,RMASS(IQ))
62280            IF (ALFAS.GT.ZERO) THEN
62281               MHAT(IQ)=RMASS(IQ)/(1.+CC*ALFAS)/ALFAS**P0
62282            ELSE
62283               CALL HWWARN('HWURQM',IQ)
62284               MHAT(IQ)=ZERO
62285            ENDIF
62286         ENDDO
62287         FIRST=.FALSE.
62288       ENDIF
62289       ALFAS=HWUALF(1,SCALE)
62290       CC=(1.+C1*ALFAS)*ALFAS**P0
62291       DO IQ=1,6
62292          RQM(IQ)=MHAT(IQ)*CC
62293       ENDDO
62294       END
62295 CDECK  ID>, HWUSOR.
62296 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62297 *-- Author :    Adapted by Bryan Webber
62298 C-----------------------------------------------------------------------
62299       SUBROUTINE HWUSOR(A,N,K,IOPT)
62300 C-----------------------------------------------------------------------
62301 C     Sort A(N) into ascending order
62302 C     IOPT = 1 : return sorted A and index array K
62303 C     IOPT = 2 : return index array K only
62304 C-----------------------------------------------------------------------
62305       IMPLICIT NONE
62306       INTEGER N,I,J,IOPT,K(N),IL(500),IR(500)
62307       DOUBLE PRECISION A(N),B(500)
62308       IF (N.GT.500) THEN
62309         CALL HWWARN('HWUSOR',100)
62310         GOTO 999
62311       ENDIF
62312       IL(1)=0
62313       IR(1)=0
62314       DO 10 I=2,N
62315       IL(I)=0
62316       IR(I)=0
62317       J=1
62318    2  IF(A(I).GT.A(J)) GOTO 5
62319       IF(IL(J).EQ.0) GOTO 4
62320       J=IL(J)
62321       GOTO 2
62322    4  IR(I)=-J
62323       IL(J)=I
62324       GOTO 10
62325    5  IF(IR(J).LE.0) GOTO 6
62326       J=IR(J)
62327       GOTO 2
62328    6  IR(I)=IR(J)
62329       IR(J)=I
62330   10  CONTINUE
62331       I=1
62332       J=1
62333       GOTO 8
62334   20  J=IL(J)
62335    8  IF(IL(J).GT.0) GOTO 20
62336    9  K(I)=J
62337       B(I)=A(J)
62338       I=I+1
62339 C---REMOVED OBSOLESCENT ARITHMETIC IF STATEMENT
62340 C$$$      IF(IR(J)) 12,30,13
62341       IF (IR(J).LT.0) THEN
62342         GOTO 12
62343       ELSEIF (IR(J).EQ.0) THEN
62344         GOTO 30
62345       ELSE
62346         GOTO 13
62347       ENDIF
62348 C---END OF REPLACEMENT ARITHMETIC IF STATEMENT
62349   13  J=IR(J)
62350       GOTO 8
62351   12  J=-IR(J)
62352       GOTO 9
62353   30  IF(IOPT.EQ.2) RETURN
62354       DO 31 I=1,N
62355   31  A(I)=B(I)
62356  999  RETURN
62357       END
62358 CDECK  ID>, HWUSPR.
62359 *CMZ :-        -17/10/01  13:59:28  by  Peter Richardson
62360 *-- Author :    Peter Richardson
62361 C-----------------------------------------------------------------------
62362       SUBROUTINE HWUSPR
62363 C-----------------------------------------------------------------------
62364 C  Subroutine to output the contents of the spin common block
62365 C-----------------------------------------------------------------------
62366       INCLUDE 'herwig65.inc'
62367       INTEGER I
62368 C--write out the header
62369       WRITE(6,1000)
62370       DO I=1,NSPN
62371         WRITE(6,1010) I,IDSPN(I),DECSPN(I),JMOSPN(I),JDASPN(1,I),
62372      &        JDASPN(2,I)
62373       ENDDO
62374  1000 FORMAT(/1X,'ISPN',1X,'IDSPN',1X,'DECS',1X,'JMOSPN',1X,' JDASPN '/)
62375  1010 FORMAT( 1X,  I4  ,1X, I5    ,1X,  L4  ,1X,  I6    ,1X, I3,2X,I3)
62376       END
62377 CDECK  ID>, HWUSQR.
62378 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62379 *-- Author :    Bryan Webber
62380 C-----------------------------------------------------------------------
62381       FUNCTION HWUSQR(X)
62382 C-----------------------------------------------------------------------
62383 C     SQUARE ROOT WITH SIGN RETENTION
62384 C-----------------------------------------------------------------------
62385       IMPLICIT NONE
62386       DOUBLE PRECISION HWUSQR,X
62387       HWUSQR=SIGN(SQRT(ABS(X)),X)
62388       END
62389 CDECK  ID>, HWUSTA.
62390 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
62391 *-- Author :    Bryan Webber
62392 C-----------------------------------------------------------------------
62393       SUBROUTINE HWUSTA(NAME)
62394 C-----------------------------------------------------------------------
62395 C     MAKES PARTICLE TYPE 'NAME' STABLE
62396 C-----------------------------------------------------------------------
62397       INCLUDE 'herwig65.inc'
62398       INTEGER IPDG,IWIG
62399       CHARACTER*8 NAME
62400       CALL HWUIDT(3,IPDG,IWIG,NAME)
62401       IF (IWIG.EQ.20) CALL HWWARN('HWUSTA',500)
62402       RSTAB(IWIG)=.TRUE.
62403       WRITE (6,10) IWIG,NAME
62404    10 FORMAT(/10X,'PARTICLE TYPE',I4,'=',A8,' SET STABLE')
62405       END
62406 CDECK  ID>, HWUTAB.
62407 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62408 *-- Author :    Adapted by Bryan Webber
62409 C-----------------------------------------------------------------------
62410       FUNCTION HWUTAB(F,A,NN,X,MM)
62411 C-----------------------------------------------------------------------
62412 C     MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
62413 C-----------------------------------------------------------------------
62414       IMPLICIT NONE
62415       INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
62416       DOUBLE PRECISION HWUTAB,SUM,X,F(NN),A(NN),T(20),D(20)
62417       LOGICAL EXTRA
62418       SAVE MMAX
62419       DATA MMAX/10/
62420       N=NN
62421       M=MIN(MM,MMAX,N-1)
62422       MPLUS=M+1
62423       IX=0
62424       IY=N+1
62425       IF (A(1).GT.A(N)) GOTO 4
62426     1 MID=(IX+IY)/2
62427       IF (X.GE.A(MID)) GOTO 2
62428       IY=MID
62429       GOTO 3
62430     2 IX=MID
62431     3 IF (IY-IX.GT.1) GOTO 1
62432       GOTO 7
62433     4 MID=(IX+IY)/2
62434       IF (X.LE.A(MID)) GOTO 5
62435       IY=MID
62436       GOTO 6
62437     5 IX=MID
62438     6 IF (IY-IX.GT.1) GOTO 4
62439     7 NPTS=M+2-MOD(M,2)
62440       IP=0
62441       L=0
62442       GOTO 9
62443     8 L=-L
62444       IF (L.GE.0) L=L+1
62445     9 ISUB=IX+L
62446       IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 10
62447       NPTS=MPLUS
62448       GOTO 11
62449    10 IP=IP+1
62450       T(IP)=A(ISUB)
62451       D(IP)=F(ISUB)
62452    11 IF (IP.LT.NPTS) GOTO 8
62453       EXTRA=NPTS.NE.MPLUS
62454       DO 14 L=1,M
62455       IF (.NOT.EXTRA) GOTO 12
62456       ISUB=MPLUS-L
62457       D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
62458    12 I=MPLUS
62459       DO 13 J=L,M
62460       ISUB=I-L
62461       D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
62462       I=I-1
62463    13 CONTINUE
62464    14 CONTINUE
62465       SUM=D(MPLUS)
62466       IF (EXTRA) SUM=0.5*(SUM+D(M+2))
62467       J=M
62468       DO 15 L=1,M
62469       SUM=D(J)+(X-T(J))*SUM
62470       J=J-1
62471    15 CONTINUE
62472       HWUTAB=SUM
62473       END
62474 CDECK  ID>, HWUTIM.
62475 *CMZ :-        -26/04/91  11.38.43  by  Federico Carminati
62476 *-- Author :    Federico Carminati
62477 C-----------------------------------------------------------------------
62478       SUBROUTINE HWUTIM(TRES)
62479 C-----------------------------------------------------------------------
62480       IMPLICIT NONE
62481       REAL TRES
62482       CALL TIMEL(TRES)
62483       END
62484 CDECK  ID>, HWVDIF.
62485 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62486 *-- Author :    Bryan Webber
62487 C-----------------------------------------------------------------------
62488       SUBROUTINE HWVDIF(N,P,Q,R)
62489 C-----------------------------------------------------------------------
62490 C     VECTOR DIFFERENCE
62491 C-----------------------------------------------------------------------
62492       IMPLICIT NONE
62493       INTEGER N,I
62494       DOUBLE PRECISION P(N),Q(N),R(N)
62495       DO 10 I=1,N
62496    10 R(I)=P(I)-Q(I)
62497       END
62498 CDECK  ID>, HWVDOT.
62499 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62500 *-- Author :    Bryan Webber
62501 C-----------------------------------------------------------------------
62502       FUNCTION HWVDOT(N,P,Q)
62503 C-----------------------------------------------------------------------
62504 C     VECTOR DOT PRODUCT
62505 C-----------------------------------------------------------------------
62506       IMPLICIT NONE
62507       INTEGER N,I
62508       DOUBLE PRECISION HWVDOT,PQ,P(N),Q(N)
62509       PQ=0.
62510       DO 10 I=1,N
62511    10 PQ=PQ+P(I)*Q(I)
62512       HWVDOT=PQ
62513       END
62514 CDECK  ID>, HWVEQU.
62515 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62516 *-- Author :    Bryan Webber
62517 C-----------------------------------------------------------------------
62518       SUBROUTINE HWVEQU(N,P,Q)
62519 C-----------------------------------------------------------------------
62520 C     VECTOR EQUALITY
62521 C-----------------------------------------------------------------------
62522       IMPLICIT NONE
62523       INTEGER N,I
62524       DOUBLE PRECISION P(N),Q(N)
62525       DO 10 I=1,N
62526    10 Q(I)=P(I)
62527       END
62528 CDECK  ID>, HWVSCA.
62529 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62530 *-- Author :    Bryan Webber
62531 C-----------------------------------------------------------------------
62532       SUBROUTINE HWVSCA(N,C,P,Q)
62533 C-----------------------------------------------------------------------
62534 C     VECTOR TIMES SCALAR
62535 C-----------------------------------------------------------------------
62536       IMPLICIT NONE
62537       INTEGER N,I
62538       DOUBLE PRECISION C,P(N),Q(N)
62539       DO 10 I=1,N
62540    10 Q(I)=C*P(I)
62541       END
62542 CDECK  ID>, HWVSUM.
62543 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62544 *-- Author :    Bryan Webber
62545 C-----------------------------------------------------------------------
62546       SUBROUTINE HWVSUM(N,P,Q,R)
62547 C-----------------------------------------------------------------------
62548 C    VECTOR SUM
62549 C-----------------------------------------------------------------------
62550       IMPLICIT NONE
62551       INTEGER N,I
62552       DOUBLE PRECISION P(N),Q(N),R(N)
62553       DO 10 I=1,N
62554    10 R(I)=P(I)+Q(I)
62555       END
62556 CDECK  ID>, HWVZRI.
62557 *CMZ :-        -05/02/98  11.11.56  by  Bryan Webber
62558 *-- Author :    Bryan Webber
62559 C-----------------------------------------------------------------------
62560       SUBROUTINE HWVZRI(N,IP)
62561 C-----------------------------------------------------------------------
62562 C     ZERO INTEGER VECTOR
62563 C-----------------------------------------------------------------------
62564       IMPLICIT NONE
62565       INTEGER N,IP(N),I
62566       DO 10 I=1,N
62567    10 IP(I)=0
62568       END
62569 CDECK  ID>, HWVZRO.
62570 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
62571 *-- Author :    Bryan Webber
62572 C-----------------------------------------------------------------------
62573       SUBROUTINE HWVZRO(N,P)
62574 C-----------------------------------------------------------------------
62575 C     ZERO VECTOR
62576 C-----------------------------------------------------------------------
62577       IMPLICIT NONE
62578       INTEGER N,I
62579       DOUBLE PRECISION P(N)
62580       DO 10 I=1,N
62581    10 P(I)=0D0
62582       END
62583 CDECK  ID>, HWWARN.
62584 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
62585 *-- Author :    Bryan Webber
62586 C-----------------------------------------------------------------------
62587       SUBROUTINE HWWARN(SUBRTN,ICODE)
62588 C-----------------------------------------------------------------------
62589 C     DEALS WITH ERRORS DURING EXECUTION
62590 C     SUBRTN = NAME OF CALLING SUBROUTINE
62591 C     ICODE  = ERROR CODE:    - -1 NONFATAL, KILL EVENT & PRINT NOTHING
62592 C                            0- 49 NONFATAL, PRINT WARNING & CONTINUE
62593 C                           50- 99 NONFATAL, PRINT WARNING & JUMP
62594 C                          100-199 NONFATAL, DUMP & KILL EVENT
62595 C                          200-299    FATAL, TERMINATE RUN
62596 C                          300-399    FATAL, DUMP EVENT & TERMINATE RUN
62597 C                          400-499    FATAL, DUMP EVENT & STOP DEAD
62598 C                          500-       FATAL, STOP DEAD WITH NO DUMP
62599 C-----------------------------------------------------------------------
62600       INCLUDE 'herwig65.inc'
62601       INTEGER ICODE
62602       CHARACTER*6 SUBRTN
62603       IF (ICODE.GE.0) WRITE (6,10) SUBRTN,ICODE
62604    10 FORMAT(/' HWWARN CALLED FROM SUBPROGRAM ',A6,': CODE =',I4)
62605       IF (ICODE.LT.0) THEN
62606          IERROR=ICODE
62607          RETURN
62608       ELSEIF (ICODE.LT.100) THEN
62609          WRITE (6,20) NEVHEP,NRN,EVWGT
62610    20    FORMAT(' EVENT',I8,':   SEEDS =',I11,' &',I11,
62611      &'  WEIGHT =',E11.4/' EVENT SURVIVES. EXECUTION CONTINUES')
62612          IF (ICODE.GT.49) RETURN
62613       ELSEIF (ICODE.LT.200) THEN
62614          WRITE (6,30) NEVHEP,NRN,EVWGT
62615    30    FORMAT(' EVENT',I8,':   SEEDS =',I11,' &',I11,
62616      &'  WEIGHT =',E11.4/' EVENT KILLED.   EXECUTION CONTINUES')
62617          IERROR=ICODE
62618          RETURN
62619       ELSEIF (ICODE.LT.300) THEN
62620          WRITE (6,40)
62621    40    FORMAT(' EVENT SURVIVES.  RUN ENDS GRACEFULLY')
62622          CALL HWEFIN
62623          STOP
62624       ELSEIF (ICODE.LT.400) THEN
62625          WRITE (6,50)
62626    50    FORMAT(' EVENT KILLED: DUMP FOLLOWS.  RUN ENDS GRACEFULLY')
62627          IERROR=ICODE
62628          CALL HWUEPR
62629          CALL HWUBPR
62630          CALL HWEFIN
62631          STOP
62632       ELSEIF (ICODE.LT.500) THEN
62633          WRITE (6,60)
62634    60    FORMAT(' EVENT KILLED: DUMP FOLLOWS.  RUN STOPS DEAD')
62635          IERROR=ICODE
62636          CALL HWUEPR
62637          CALL HWUBPR
62638          STOP
62639       ELSE
62640          WRITE (6,70)
62641    70    FORMAT(' RUN CANNOT CONTINUE')
62642          STOP
62643       ENDIF
62644       END
62645 CDECK  ID>, IEUPDG.
62646 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
62647 *-- Author :    Luca Stanco
62648 C-----------------------------------------------------------------------
62649       FUNCTION IEUPDG(I)
62650 C-----------------------------------------------------------------------
62651 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
62652 C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
62653 C-----------------------------------------------------------------------
62654       IMPLICIT NONE
62655       INTEGER IEUPDG,I
62656       WRITE (6,10)
62657    10 FORMAT(/10X,'IEUPDG CALLED BUT NOT LINKED')
62658       IEUPDG=0
62659       STOP
62660       END
62661 CDECK  ID>, IPDGEU.
62662 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
62663 *-- Author :    Luca Stanco
62664 C-----------------------------------------------------------------------
62665       FUNCTION IPDGEU(I)
62666 C-----------------------------------------------------------------------
62667 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
62668 C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
62669 C-----------------------------------------------------------------------
62670       IMPLICIT NONE
62671       INTEGER IPDGEU,I
62672       WRITE (6,10)
62673    10 FORMAT(/10X,'IPDGEU CALLED BUT NOT LINKED')
62674       IPDGEU=0
62675       STOP
62676       END
62677 CDECK  ID>, INIETC.
62678 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
62679 *-- Author :    Peter Richardson
62680 C-----------------------------------------------------------------------
62681       SUBROUTINE INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
62682 C-----------------------------------------------------------------------
62683 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62684 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62685 C-----------------------------------------------------------------------
62686       IMPLICIT NONE
62687       INTEGER JAK1,JAK2,ITDKRC,IFPHOT
62688       WRITE (6,10)
62689    10 FORMAT(/10X,'INIETC CALLED BUT NOT LINKED')
62690       STOP
62691       END
62692 CDECK  ID>, INIMAS.
62693 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
62694 *-- Author :    Peter Richardson
62695 C-----------------------------------------------------------------------
62696       SUBROUTINE INIMAS
62697 C-----------------------------------------------------------------------
62698 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62699 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62700 C-----------------------------------------------------------------------
62701       IMPLICIT NONE
62702       WRITE (6,10)
62703    10 FORMAT(/10X,'INIMAS CALLED BUT NOT LINKED')
62704       STOP
62705       END
62706 CDECK  ID>, INIPHX.
62707 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
62708 *-- Author :    Peter Richardson
62709 C-----------------------------------------------------------------------
62710       SUBROUTINE INIPHX(CUT)
62711 C-----------------------------------------------------------------------
62712 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62713 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62714 C-----------------------------------------------------------------------
62715       IMPLICIT NONE
62716       DOUBLE PRECISION CUT
62717       WRITE (6,10)
62718    10 FORMAT(/10X,'INIPHX CALLED BUT NOT LINKED')
62719       STOP
62720       END
62721 CDECK  ID>, INITDK.
62722 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
62723 *-- Author :    Peter Richardson
62724 C-----------------------------------------------------------------------
62725       SUBROUTINE INITDK
62726 C-----------------------------------------------------------------------
62727 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62728 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62729 C-----------------------------------------------------------------------
62730       IMPLICIT NONE
62731       WRITE (6,10)
62732    10 FORMAT(/10X,'INITDK CALLED BUT NOT LINKED')
62733       STOP
62734       END
62735 CDECK  ID>, PHOINI.
62736 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
62737 *-- Author :    Peter Richardson
62738 C-----------------------------------------------------------------------
62739       SUBROUTINE PHOINI
62740 C-----------------------------------------------------------------------
62741 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62742 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62743 C-----------------------------------------------------------------------
62744       IMPLICIT NONE
62745       WRITE (6,10)
62746    10 FORMAT(/10X,'PHOINI CALLED BUT NOT LINKED')
62747       STOP
62748       END
62749 CDECK  ID>, PHOTOS.
62750 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
62751 *-- Author :    Peter Richardson
62752 C-----------------------------------------------------------------------
62753       SUBROUTINE PHOTOS(IHEP)
62754 C-----------------------------------------------------------------------
62755 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62756 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62757 C-----------------------------------------------------------------------
62758       IMPLICIT NONE
62759       INTEGER IHEP
62760       WRITE (6,10)
62761    10 FORMAT(/10X,'PHOTOS CALLED BUT NOT LINKED')
62762       STOP
62763       END
62764 CDECK  ID>, QQINIT.
62765 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
62766 *-- Author :    Luca Stanco
62767 C-----------------------------------------------------------------------
62768       SUBROUTINE QQINIT(QQLERR)
62769 C-----------------------------------------------------------------------
62770 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
62771 C     IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
62772 C-----------------------------------------------------------------------
62773       IMPLICIT NONE
62774       LOGICAL QQLERR
62775       WRITE (6,10)
62776    10 FORMAT(/10X,'QQINIT CALLED BUT NOT LINKED')
62777       STOP
62778       END
62779 CDECK  ID>, QQLMAT.
62780 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
62781 *-- Author :    Luca Stanco
62782 C-----------------------------------------------------------------------
62783       INTEGER FUNCTION QQLMAT(IDL,NDIR)
62784 C-----------------------------------------------------------------------
62785 C. QQLMAT - Given a particle flavor (KF), converts it to QQ particle number
62786 C.          (KF = IDPDG code)
62787 C.
62788 C. Inputs    : IDL    (input  particle code)
62789 C              NDIR = 1   LUND --> QQ
62790 C              NDIR = 2   QQ   --> LUND
62791 C
62792 C. Outputs   : QQLMAT (output particle code)
62793 C.
62794 C-----------------------------------------------------------------------
62795       IMPLICIT NONE
62796 C-- Calling variable
62797       INTEGER IDL,NDIR
62798 C-- External declaration
62799 C-- Local variables
62800       INTEGER AKF(321),I
62801       SAVE AKF
62802       DATA (AKF(I), I=1,151) /
62803      +    0,    0,    0,    0,    0,    0,    0,   21,   -6,   -5,
62804      +   -4,   -3,   -1,   -2,    6,    5,    4,    3,    1,    2,
62805      +    0,
62806      +   22,   23,   24,  -24,   90,    0,   11,  -11,   12,  -12,
62807      +   13,  -13,   14,  -14,   15,  -15,   16,  -16,20313,-20313,
62808      +  211, -211,  321, -321,  311, -311,  421, -421,  411, -411,
62809      +  431, -431, -521,  521, -511,  511, -531,  531, -541,  541,
62810      +  621, -621,  611, -611,  631, -631,  641, -641,  651, -651,
62811      +  111,  221,  331,  441,20551,  661,  310,  130,10313,-10313,
62812      +  213, -213,  323, -323,  313, -313,  423, -423,  413, -413,
62813      +  433, -433, -523,  523, -513,  513, -533,  533, -543,  543,
62814      +  623, -623,  613, -613,  633, -633,  643, -643,  653, -653,
62815      +  113,  223,  333,  443,  553,  136,  20553, 30553, 40553, 551,
62816      +  10553, 555, 10551,70553,10555, 0, 20213, 20113, -20213, 10441,
62817      +  10443, 445, 8*0,
62818      +  3122, -3122, 4122, -4122, 4232, -4232, 4132, -4132, 3212, -3212/
62819       DATA (AKF(I), I=152,321) /
62820      +  4212, -4212, 4322, -4322, 4312, -4312, 2212, -2212, 3222, -3222,
62821      +  4222, -4222, 2112, -2112, 3112, -3112, 4112, -4112, 3322, -3322,
62822      +  3312, -3312, 4332, -4332, 6*0,
62823      +  3214, -3214, 4214, -4214, 4324, -4324, 4314, -4314, 2214, -2214,
62824      +  3224, -3224, 4224, -4224, 2114, -2114, 3114, -3114, 4114, -4114,
62825      +  3324, -3324, 3314, -3314, 4334, -4334, 4*0,
62826      +  0, 0,  2224, -2224, 1114, -1114, 3334, -3334, 0, 0,
62827      +  10323, -10323, 20323, -20323, 6*0,
62828      +  30443, 0, 0, 0, 70443, 50553, 60553, 80553, 20443, 0,
62829      +  10411, 20413, 10413, 415,
62830      + -10411,-20413,-10413,-415,
62831      +  10421, 20423, 10423, 425,
62832      + -10421,-20423,-10423,-425,
62833      +  10431, 20433, 10433, 435,
62834      + -10431,-20433,-10433,-435, 0,0,0,0,0,0,
62835      +  10111, 10211,-10211, 115, 215, -215,10221,10331,20223,20333,
62836      +  225, 335, 10223, 10333, 10113, 10213,-10213, 33*0 /
62837       IF(NDIR.EQ.1) THEN
62838         DO 10 I=1,321
62839         IF (IDL.EQ.AKF(I)) THEN
62840           QQLMAT=I-21
62841           RETURN
62842         ENDIF
62843   10    CONTINUE
62844         QQLMAT=0
62845         WRITE(6,20) IDL
62846   20    FORMAT(1X,'Lund code particle ',I6,' not recognized')
62847       ELSEIF(NDIR.EQ.2) THEN
62848         QQLMAT = AKF(IDL+21)
62849       ELSE
62850         QQLMAT=0
62851         WRITE(6,30)
62852   30    FORMAT(1X,'Unrecognized option in QQLMAT')
62853       ENDIF
62854       END
62855 C-----------------------------------------------------------------------
62856 C...SaSgam version 2 - parton distributions of the photon
62857 C...by Gerhard A. Schuler and Torbjorn Sjostrand
62858 C...For further information see Z. Phys. C68 (1995) 607
62859 C...and CERN-TH/96-04 and LU TP 96-2.
62860 C...Program last changed on 18 January 1996.
62861 C
62862 C!!!Note that one further call parameter - IP2 - has been added
62863 C!!!to the SASGAM argument list compared with version 1.
62864 C
62865 C...The user should only need to call the SASGAM routine,
62866 C...which in turn calls the auxiliary routines SASVMD, SASANO,
62867 C...SASBEH and SASDIR. The package is self-contained.
62868 C
62869 C...One particular aspect of these parametrizations is that F2 for
62870 C...the photon is not obtained just as the charge-squared-weighted
62871 C...sum of quark distributions, but differ in the treatment of
62872 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
62873 C...the kinematics range of heavy-flavour production, but the same
62874 C...kinematics is not relevant e.g. for jet production) and, for the
62875 C...'MSbar' fits, in the addition of a Cgamma term related to the
62876 C...separation of direct processes. Schematically:
62877 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
62878 C...F2  = VMD (rho, omega, phi) + anomalous (d, u, s) +
62879 C...      Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
62880 C...The J/psi and Upsilon states have not been included in the VMD sum,
62881 C...but low c and b masses in the other components should compensate
62882 C...for this in a duality sense.
62883 C
62884 C...The calling sequence is the following:
62885 C     CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
62886 C...with the following declaration statement:
62887 C     DIMENSION XPDFGM(-6:6)
62888 C...and, optionally, further information in:
62889 C     COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
62890 C    &XPDIR(-6:6)
62891 C     COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
62892 C...Input:  ISET = 1 : SaS set 1D ('DIS',   Q0 = 0.6 GeV)
62893 C                = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
62894 C                = 3 : SaS set 2D ('DIS',   Q0 =  2  GeV)
62895 C                = 4 : SaS set 2M ('MSbar', Q0 =  2  GeV)
62896 C           X : x value.
62897 C           Q2 : Q2 value.
62898 C           P2 : P2 value; should be = 0. for an on-shell photon.
62899 C           IP2 : scheme used to evaluate off-shell anomalous component.
62900 C               = 0 : recommended default, see = 7.
62901 C               = 1 : dipole dampening by integration; very time-consuming.
62902 C               = 2 : P_0^2 = max( Q_0^2, P^2 )
62903 C               = 3 : P'_0^2 = Q_0^2 + P^2.
62904 C               = 4 : P_{eff} that preserves momentum sum.
62905 C               = 5 : P_{int} that preserves momentum and average
62906 C                     evolution range.
62907 C               = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
62908 C               = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
62909 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
62910 C           XPFDGM :  x times parton distribution functions of the photon,
62911 C               with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
62912 C               6 = t (always empty!), - for antiquarks (result is same).
62913 C...The breakdown by component is stored in the commonblock SASCOM,
62914 C               with elements as above.
62915 C           XPVMD : rho, omega, phi VMD part only of output.
62916 C           XPANL : d, u, s anomalous part only of output.
62917 C           XPANH : c, b anomalous part only of output.
62918 C           XPBEH : c, b Bethe-Heitler part only of output.
62919 C           XPDIR : Cgamma (direct contribution) part only of output.
62920 C...The above arrays do not distinguish valence and sea contributions,
62921 C...although this information is available internally. The additional
62922 C...commonblock SASVAL provides the valence part only of the above
62923 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
62924 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
62925 C...and therefore not given doubly. VXPDGM gives the sum of valence
62926 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
62927 C...and so on, gives the sea part only.
62928 C
62929       SUBROUTINE SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
62930 C...Purpose: to construct the F2 and parton distributions of the photon
62931 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
62932 C...For F2, c and b are included by the Bethe-Heitler formula;
62933 C...in the 'MSbar' scheme additionally a Cgamma term is added.
62934       DIMENSION XPDFGM(-6:6)
62935       COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
62936      &XPDIR(-6:6)
62937       COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
62938       SAVE /SASCOM/,/SASVAL/
62939 C
62940 C...Temporary array.
62941       DIMENSION XPGA(-6:6), VXPGA(-6:6)
62942       SAVE PMC,PMB,AEM,AEM2PI,ALAM,FRACU,FRHO,FOMEGA,FPHI,PMRHO,PMPHI,
62943      $     NSTEP
62944 C...Charm and bottom masses (low to compensate for J/psi etc.).
62945       DATA PMC/1.3/, PMB/4.6/
62946 C...alpha_em and alpha_em/(2*pi).
62947       DATA AEM/0.007297/, AEM2PI/0.0011614/
62948 C...Lambda value for 4 flavours.
62949       DATA ALAM/0.20/
62950 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
62951       DATA FRACU/0.8/
62952 C...VMD couplings f_V**2/(4*pi).
62953       DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
62954 C...Masses for rho (=omega) and phi.
62955       DATA PMRHO/0.770/, PMPHI/1.020/
62956 C...Number of points in integration for IP2=1.
62957       DATA NSTEP/100/
62958 C
62959 C...Reset output.
62960       F2GM=0.
62961       DO 100 KFL=-6,6
62962       XPDFGM(KFL)=0.
62963       XPVMD(KFL)=0.
62964       XPANL(KFL)=0.
62965       XPANH(KFL)=0.
62966       XPBEH(KFL)=0.
62967       XPDIR(KFL)=0.
62968       VXPVMD(KFL)=0.
62969       VXPANL(KFL)=0.
62970       VXPANH(KFL)=0.
62971       VXPDGM(KFL)=0.
62972   100 CONTINUE
62973 C
62974 C...Check that input sensible.
62975       IF(ISET.LE.0.OR.ISET.GE.5) THEN
62976         WRITE(*,*) ' FATAL ERROR: SaSgam called for unknown set'
62977         WRITE(*,*) ' ISET = ',ISET
62978         STOP
62979       ENDIF
62980       IF(X.LE.0..OR.X.GT.1.) THEN
62981         WRITE(*,*) ' FATAL ERROR: SaSgam called for unphysical x'
62982         WRITE(*,*) ' X = ',X
62983         STOP
62984       ENDIF
62985 C
62986 C...Set Q0 cut-off parameter as function of set used.
62987       IF(ISET.LE.2) THEN
62988         Q0=0.6
62989       ELSE
62990         Q0=2.
62991       ENDIF
62992       Q02=Q0**2
62993 C
62994 C...Scale choice for off-shell photon; common factors.
62995       Q2A=Q2
62996       FACNOR=1.
62997       IF(IP2.EQ.1) THEN
62998         P2MX=P2+Q02
62999         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
63000         FACNOR=LOG(Q2/Q02)/NSTEP
63001       ELSEIF(IP2.EQ.2) THEN
63002         P2MX=MAX(P2,Q02)
63003       ELSEIF(IP2.EQ.3) THEN
63004         P2MX=P2+Q02
63005         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
63006       ELSEIF(IP2.EQ.4) THEN
63007         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
63008      &  ((Q2+P2)*(Q02+P2)))
63009       ELSEIF(IP2.EQ.5) THEN
63010         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
63011      &  ((Q2+P2)*(Q02+P2)))
63012         P2MX=Q0*SQRT(P2MXA)
63013         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
63014       ELSEIF(IP2.EQ.6) THEN
63015         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
63016      &  ((Q2+P2)*(Q02+P2)))
63017         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
63018       ELSE
63019         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
63020      &  ((Q2+P2)*(Q02+P2)))
63021         P2MX=Q0*SQRT(P2MXA)
63022         P2MXB=P2MX
63023         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
63024         P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
63025         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
63026       ENDIF
63027 C
63028 C...Call VMD parametrization for d quark and use to give rho, omega,
63029 C...phi. Note dipole dampening for off-shell photon.
63030       CALL SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
63031       XFVAL=VXPGA(1)
63032       XPGA(1)=XPGA(2)
63033       XPGA(-1)=XPGA(-2)
63034       FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
63035       FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
63036       DO 110 KFL=-5,5
63037       XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
63038   110 CONTINUE
63039       XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
63040       XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
63041       XPVMD(3)=XPVMD(3)+FACS*XFVAL
63042       XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
63043       XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
63044       XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
63045       VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
63046       VXPVMD(2)=FRACU*FACUD*XFVAL
63047       VXPVMD(3)=FACS*XFVAL
63048       VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
63049       VXPVMD(-2)=FRACU*FACUD*XFVAL
63050       VXPVMD(-3)=FACS*XFVAL
63051 C
63052       IF(IP2.NE.1) THEN
63053 C...Anomalous parametrizations for different strategies
63054 C...for off-shell photons; except full integration.
63055 C
63056 C...Call anomalous parametrization for d + u + s.
63057         CALL SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
63058         DO 120 KFL=-5,5
63059         XPANL(KFL)=FACNOR*XPGA(KFL)
63060         VXPANL(KFL)=FACNOR*VXPGA(KFL)
63061   120   CONTINUE
63062 C
63063 C...Call anomalous parametrization for c and b.
63064         CALL SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
63065         DO 130 KFL=-5,5
63066         XPANH(KFL)=FACNOR*XPGA(KFL)
63067         VXPANH(KFL)=FACNOR*VXPGA(KFL)
63068   130   CONTINUE
63069         CALL SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
63070         DO 140 KFL=-5,5
63071         XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
63072         VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
63073   140   CONTINUE
63074 C
63075       ELSE
63076 C...Special option: loop over flavours and integrate over k2.
63077         DO 170 KF=1,5
63078         DO 160 ISTEP=1,NSTEP
63079         Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
63080         IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
63081      &  (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
63082         CALL SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
63083         FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
63084         IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
63085         IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
63086         DO 150 KFL=-5,5
63087         IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
63088         IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
63089         IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
63090         IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
63091   150   CONTINUE
63092   160   CONTINUE
63093   170   CONTINUE
63094       ENDIF
63095 C
63096 C...Call Bethe-Heitler term expression for charm and bottom.
63097       CALL SASBEH(4,X,Q2,P2,PMC**2,XPBH)
63098       XPBEH(4)=XPBH
63099       XPBEH(-4)=XPBH
63100       CALL SASBEH(5,X,Q2,P2,PMB**2,XPBH)
63101       XPBEH(5)=XPBH
63102       XPBEH(-5)=XPBH
63103 C
63104 C...For MSbar subtraction call C^gamma term expression for d, u, s.
63105       IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
63106         CALL SASDIR(X,Q2,P2,Q02,XPGA)
63107         DO 180 KFL=-5,5
63108         XPDIR(KFL)=XPGA(KFL)
63109   180   CONTINUE
63110       ENDIF
63111 C
63112 C...Store result in output array.
63113       DO 190 KFL=-5,5
63114       CHSQ=1./9.
63115       IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
63116       XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
63117       IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
63118       XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
63119       VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
63120   190 CONTINUE
63121 C
63122       END
63123 C
63124 C*********************************************************************
63125 C
63126       SUBROUTINE SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
63127 C...Purpose: to evaluate the VMD parton distributions of a photon,
63128 C...evolved homogeneously from an initial scale P2 to Q2.
63129 C...Does not include dipole suppression factor.
63130 C...ISET is parton distribution set, see above;
63131 C...additionally ISET=0 is used for the evolution of an anomalous photon
63132 C...which branched at a scale P2 and then evolved homogeneously to Q2.
63133 C...ALAM is the 4-flavour Lambda, which is automatically converted
63134 C...to 3- and 5-flavour equivalents as needed.
63135       DIMENSION XPGA(-6:6), VXPGA(-6:6)
63136       SAVE PMC,PMB
63137       DATA PMC/1.3/, PMB/4.6/
63138 C
63139 C...Reset output.
63140       DO 100 KFL=-6,6
63141       XPGA(KFL)=0.
63142       VXPGA(KFL)=0.
63143   100 CONTINUE
63144       KFA=IABS(KF)
63145 C
63146 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
63147       ALAM3=ALAM*(PMC/ALAM)**(2./27.)
63148       ALAM5=ALAM*(ALAM/PMB)**(2./23.)
63149       P2EFF=MAX(P2,1.2*ALAM3**2)
63150       IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
63151       IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
63152       Q2EFF=MAX(Q2,P2EFF)
63153 C
63154 C...Find number of flavours at lower and upper scale.
63155       NFP=4
63156       IF(P2EFF.LT.PMC**2) NFP=3
63157       IF(P2EFF.GT.PMB**2) NFP=5
63158       NFQ=4
63159       IF(Q2EFF.LT.PMC**2) NFQ=3
63160       IF(Q2EFF.GT.PMB**2) NFQ=5
63161 C
63162 C...Find s as sum of 3-, 4- and 5-flavour parts.
63163       S=0.
63164       IF(NFP.EQ.3) THEN
63165         Q2DIV=PMC**2
63166         IF(NFQ.EQ.3) Q2DIV=Q2EFF
63167         S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
63168       ENDIF
63169       IF(NFP.LE.4.AND.NFQ.GE.4) THEN
63170         P2DIV=P2EFF
63171         IF(NFP.EQ.3) P2DIV=PMC**2
63172         Q2DIV=Q2EFF
63173         IF(NFQ.EQ.5) Q2DIV=PMB**2
63174         S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
63175       ENDIF
63176       IF(NFQ.EQ.5) THEN
63177         P2DIV=PMB**2
63178         IF(NFP.EQ.5) P2DIV=P2EFF
63179         S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
63180       ENDIF
63181 C
63182 C...Calculate frequent combinations of x and s.
63183       X1=1.-X
63184       XL=-LOG(X)
63185       S2=S**2
63186       S3=S**3
63187       S4=S**4
63188 C
63189 C...Evaluate homogeneous anomalous parton distributions below or
63190 C...above threshold.
63191       IF(ISET.EQ.0) THEN
63192       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63193      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63194         XVAL = X * 1.5 * (X**2+X1**2)
63195         XGLU = 0.
63196         XSEA = 0.
63197       ELSE
63198         XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
63199      &  (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
63200      &  X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
63201         XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
63202      &  X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
63203      &  ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
63204         XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
63205      &  X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
63206      &  ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
63207      &  (2.*X-1.)*X*XL**2)
63208       ENDIF
63209 C
63210 C...Evaluate set 1D parton distributions below or above threshold.
63211       ELSEIF(ISET.EQ.1) THEN
63212       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63213      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63214         XVAL = 1.294 * X**0.80 * X1**0.76
63215         XGLU = 1.273 * X**0.40 * X1**1.76
63216         XSEA = 0.100 * X1**3.76
63217       ELSE
63218         XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
63219      &  X1**(0.76+0.667*S) * XL**(2.*S)
63220         XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
63221      &  X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
63222      &  1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
63223         XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
63224      &  X**(-7.32*S2/(1.+10.3*S2)) *
63225      &  X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
63226         XSEA0 = 0.100 * X1**3.76
63227       ENDIF
63228 C
63229 C...Evaluate set 1M parton distributions below or above threshold.
63230       ELSEIF(ISET.EQ.2) THEN
63231       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63232      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63233         XVAL = 0.8477 * X**0.51 * X1**1.37
63234         XGLU = 3.42 * X**0.255 * X1**2.37
63235         XSEA = 0.
63236       ELSE
63237         XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
63238      &  * X1**1.37 * XL**(2.667*S)
63239         XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
63240      &  X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
63241      &  XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
63242      &  X1**(2.37+3.*S)
63243         XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
63244      &  X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
63245      &  XL**(2.8*S)
63246         XSEA0 = 0.
63247       ENDIF
63248 C
63249 C...Evaluate set 2D parton distributions below or above threshold.
63250       ELSEIF(ISET.EQ.3) THEN
63251       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63252      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63253         XVAL = X**0.46 * X1**0.64 + 0.76 * X
63254         XGLU = 1.925 * X1**2
63255         XSEA = 0.242 * X1**4
63256       ELSE
63257         XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
63258      &  * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
63259      &  (0.76+0.4*S) * X * X1**(2.667*S)
63260         XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
63261      &  EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
63262      &  * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
63263         XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
63264      &  X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
63265         XSEA0 = 0.242 * X1**4
63266       ENDIF
63267 C
63268 C...Evaluate set 2M parton distributions below or above threshold.
63269       ELSEIF(ISET.EQ.4) THEN
63270       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63271      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63272         XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
63273         XGLU = 1.808 * X1**2
63274         XSEA = 0.209 * X1**4
63275       ELSE
63276         XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
63277      &  X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
63278      &  X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
63279      &  (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
63280         XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
63281      &  X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
63282      &  X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
63283      &  XL**(10.9*S/(1.+2.5*S))
63284         XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
63285      &  X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
63286      &  X1**(4.+S) * XL**(0.45*S)
63287         XSEA0 = 0.209 * X1**4
63288       ENDIF
63289       ENDIF
63290 C
63291 C...Threshold factors for c and b sea.
63292       SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
63293       XCHM=0.
63294       IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
63295         SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
63296         IF(ISET.EQ.0) THEN
63297           XCHM=XSEA*(1.-(SCH/SLL)**2)
63298         ELSE
63299           XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
63300         ENDIF
63301       ENDIF
63302       XBOT=0.
63303       IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
63304         SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
63305         IF(ISET.EQ.0) THEN
63306           XBOT=XSEA*(1.-(SBT/SLL)**2)
63307         ELSE
63308           XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
63309         ENDIF
63310       ENDIF
63311 C
63312 C...Fill parton distributions.
63313       XPGA(0)=XGLU
63314       XPGA(1)=XSEA
63315       XPGA(2)=XSEA
63316       XPGA(3)=XSEA
63317       XPGA(4)=XCHM
63318       XPGA(5)=XBOT
63319       XPGA(KFA)=XPGA(KFA)+XVAL
63320       DO 110 KFL=1,5
63321       XPGA(-KFL)=XPGA(KFL)
63322   110 CONTINUE
63323       VXPGA(KFA)=XVAL
63324       VXPGA(-KFA)=XVAL
63325 C
63326       END
63327 C
63328 C*********************************************************************
63329 C
63330       SUBROUTINE SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
63331 C...Purpose: to evaluate the parton distributions of the anomalous
63332 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
63333 C...to Q2.
63334 C...KF=0 gives the sum over (up to) 5 flavours,
63335 C...KF<0 limits to flavours up to abs(KF),
63336 C...KF>0 is for flavour KF only.
63337 C...ALAM is the 4-flavour Lambda, which is automatically converted
63338 C...to 3- and 5-flavour equivalents as needed.
63339       DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
63340       SAVE PMC,PMB,AEM2PI
63341       DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
63342 C
63343 C...Reset output.
63344       DO 100 KFL=-6,6
63345       XPGA(KFL)=0.
63346       VXPGA(KFL)=0.
63347   100 CONTINUE
63348       IF(Q2.LE.P2) RETURN
63349       KFA=IABS(KF)
63350 C
63351 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
63352       ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
63353       ALAMSQ(4)=ALAM**2
63354       ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
63355       P2EFF=MAX(P2,1.2*ALAMSQ(3))
63356       IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
63357       IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
63358       Q2EFF=MAX(Q2,P2EFF)
63359       XL=-LOG(X)
63360 C
63361 C...Find number of flavours at lower and upper scale.
63362       NFP=4
63363       IF(P2EFF.LT.PMC**2) NFP=3
63364       IF(P2EFF.GT.PMB**2) NFP=5
63365       NFQ=4
63366       IF(Q2EFF.LT.PMC**2) NFQ=3
63367       IF(Q2EFF.GT.PMB**2) NFQ=5
63368 C
63369 C...Define range of flavour loop.
63370       IF(KF.EQ.0) THEN
63371         KFLMN=1
63372         KFLMX=5
63373       ELSEIF(KF.LT.0) THEN
63374         KFLMN=1
63375         KFLMX=KFA
63376       ELSE
63377         KFLMN=KFA
63378         KFLMX=KFA
63379       ENDIF
63380 C
63381 C...Loop over flavours the photon can branch into.
63382       DO 110 KFL=KFLMN,KFLMX
63383 C
63384 C...Light flavours: calculate t range and (approximate) s range.
63385       IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
63386         TDIFF=LOG(Q2EFF/P2EFF)
63387         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
63388      &  LOG(P2EFF/ALAMSQ(NFQ)))
63389         IF(NFQ.GT.NFP) THEN
63390           Q2DIV=PMB**2
63391           IF(NFQ.EQ.4) Q2DIV=PMC**2
63392           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
63393      &    LOG(P2EFF/ALAMSQ(NFQ)))
63394           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
63395      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
63396           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
63397         ENDIF
63398         IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
63399           Q2DIV=PMC**2
63400           SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
63401      &    LOG(P2EFF/ALAMSQ(4)))
63402           SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
63403      &    LOG(P2EFF/ALAMSQ(3)))
63404           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
63405         ENDIF
63406 C
63407 C...u and s quark do not need a separate treatment when d has been done.
63408       ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
63409 C
63410 C...Charm: as above, but only include range above c threshold.
63411       ELSEIF(KFL.EQ.4) THEN
63412         IF(Q2.LE.PMC**2) GOTO 110
63413         P2EFF=MAX(P2EFF,PMC**2)
63414         Q2EFF=MAX(Q2EFF,P2EFF)
63415         TDIFF=LOG(Q2EFF/P2EFF)
63416         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
63417      &  LOG(P2EFF/ALAMSQ(NFQ)))
63418         IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
63419           Q2DIV=PMB**2
63420           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
63421      &    LOG(P2EFF/ALAMSQ(NFQ)))
63422           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
63423      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
63424           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
63425         ENDIF
63426 C
63427 C...Bottom: as above, but only include range above b threshold.
63428       ELSEIF(KFL.EQ.5) THEN
63429         IF(Q2.LE.PMB**2) GOTO 110
63430         P2EFF=MAX(P2EFF,PMB**2)
63431         Q2EFF=MAX(Q2,P2EFF)
63432         TDIFF=LOG(Q2EFF/P2EFF)
63433         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
63434      &  LOG(P2EFF/ALAMSQ(NFQ)))
63435       ENDIF
63436 C
63437 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
63438       CHSQ=1./9.
63439       IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
63440       FAC=AEM2PI*2.*CHSQ*TDIFF
63441 C
63442 C...Evaluate parton distributions (normalized to unit momentum sum).
63443       IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
63444         XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
63445      &  (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
63446      &  1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
63447      &  X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
63448         XGLU= 2.*S/(1.+4.*S+7.*S**2) *
63449      &  X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
63450      &  ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
63451         XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
63452      &  X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
63453      &  ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
63454      &  (2.*X-1.)*X*XL**2)
63455 C
63456 C...Threshold factors for c and b sea.
63457         SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
63458         XCHM=0.
63459         IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
63460           SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
63461           XCHM=XSEA*(1.-(SCH/SLL)**3)
63462         ENDIF
63463         XBOT=0.
63464         IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
63465           SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
63466           XBOT=XSEA*(1.-(SBT/SLL)**3)
63467         ENDIF
63468       ENDIF
63469 C
63470 C...Add contribution of each valence flavour.
63471       XPGA(0)=XPGA(0)+FAC*XGLU
63472       XPGA(1)=XPGA(1)+FAC*XSEA
63473       XPGA(2)=XPGA(2)+FAC*XSEA
63474       XPGA(3)=XPGA(3)+FAC*XSEA
63475       XPGA(4)=XPGA(4)+FAC*XCHM
63476       XPGA(5)=XPGA(5)+FAC*XBOT
63477       XPGA(KFL)=XPGA(KFL)+FAC*XVAL
63478       VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
63479   110 CONTINUE
63480       DO 120 KFL=1,5
63481       XPGA(-KFL)=XPGA(KFL)
63482       VXPGA(-KFL)=VXPGA(KFL)
63483   120 CONTINUE
63484 C
63485       END
63486 C
63487 C*********************************************************************
63488 C
63489       SUBROUTINE SASBEH(KF,X,Q2,P2,PM2,XPBH)
63490 C...Purpose: to evaluate the Bethe-Heitler cross section for
63491 C...heavy flavour production.
63492       SAVE AEM2PI
63493       DATA AEM2PI/0.0011614/
63494 C
63495 C...Reset output.
63496       XPBH=0.
63497       SIGBH=0.
63498 C
63499 C...Check kinematics limits.
63500       IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
63501       W2=Q2*(1.-X)/X-P2
63502       BETA2=1.-4.*PM2/W2
63503       IF(BETA2.LT.1E-10) RETURN
63504       BETA=SQRT(BETA2)
63505       RMQ=4.*PM2/Q2
63506 C
63507 C...Simple case: P2 = 0.
63508       IF(P2.LT.1E-4) THEN
63509         IF(BETA.LT.0.99) THEN
63510           XBL=LOG((1.+BETA)/(1.-BETA))
63511         ELSE
63512           XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
63513         ENDIF
63514         SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
63515      &  XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
63516 C
63517 C...Complicated case: P2 > 0, based on approximation of
63518 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
63519       ELSE
63520         RPQ=1.-4.*X**2*P2/Q2
63521         IF(RPQ.GT.1E-10) THEN
63522           RPBE=SQRT(RPQ*BETA2)
63523           IF(RPBE.LT.0.99) THEN
63524             XBL=LOG((1.+RPBE)/(1.-RPBE))
63525             XBI=2.*RPBE/(1.-RPBE**2)
63526           ELSE
63527             RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
63528             XBL=LOG((1.+RPBE)**2/RPBESN)
63529             XBI=2.*RPBE/RPBESN
63530           ENDIF
63531           SIGBH=BETA*(6.*X*(1.-X)-1.)+
63532      &    XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
63533      &    XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
63534         ENDIF
63535       ENDIF
63536 C
63537 C...Multiply by charge-squared etc. to get parton distribution.
63538       CHSQ=1./9.
63539       IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
63540       XPBH=3.*CHSQ*AEM2PI*X*SIGBH
63541 C
63542       END
63543 C
63544 C*********************************************************************
63545 C
63546       SUBROUTINE SASDIR(X,Q2,P2,Q02,XPGA)
63547 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
63548 C...as needed in MSbar parametrizations.
63549       DIMENSION XPGA(-6:6)
63550       SAVE AEM2PI
63551       DATA AEM2PI/0.0011614/
63552 C
63553 C...Reset output.
63554       DO 100 KFL=-6,6
63555       XPGA(KFL)=0.
63556   100 CONTINUE
63557 C
63558 C...Evaluate common x-dependent expression.
63559       XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
63560       CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
63561 C
63562 C...d, u, s part by simple charge factor.
63563       XPGA(1)=(1./9.)*CGAM
63564       XPGA(2)=(4./9.)*CGAM
63565       XPGA(3)=(1./9.)*CGAM
63566 C
63567 C...Also fill for antiquarks.
63568       DO 110 KF=1,5
63569       XPGA(-KF)=XPGA(KF)
63570   110 CONTINUE
63571 C
63572       END
63573 C-----------------------------------------------------------------------
63574 CDECK  ID>,  TIMEL.
63575 *CMZ :-        -28/06/01  16.55.32  by  Bryan Webber
63576 *-- Author :    Bryan Webber
63577 C-----------------------------------------------------------------------
63578       SUBROUTINE TIMEL(TRES)
63579 C-----------------------------------------------------------------------
63580 C     DUMMY TIME SUBROUTINE: DELETE AND REPLACE BY SYSTEM
63581 C     ROUTINE GIVING TRES = CPU TIME REMAINING (SECONDS)
63582 C-----------------------------------------------------------------------
63583       IMPLICIT NONE
63584       REAL TRES
63585       LOGICAL FIRST
63586       SAVE FIRST
63587       DATA FIRST/.TRUE./
63588       IF (FIRST) THEN
63589       WRITE (6,10)
63590    10 FORMAT(/10X,'SUBROUTINE TIMEL CALLED BUT NOT LINKED.'/
63591      &        10X,'DUMMY TIMEL WILL BE USED. DELETE DUMMY'/
63592      &        10X,'AND LINK CERNLIB FOR CPU TIME REMAINING.')
63593       FIRST=.FALSE.
63594       ENDIF
63595       TRES=1E10
63596       END