HERWIG/herwig6507.f

   1 C-----------------------------------------------------------------------
   2 C                           H E R W I G
   3 C
   4 C            a Monte Carlo event generator for simulating
   5 C        +---------------------------------------------------+
   6 C        | Hadron Emission Reactions With Interfering Gluons |
   7 C        +---------------------------------------------------+
   8 C I.G. Knowles(*), G. Marchesini(+), M.H.Seymour($,&) and B.R. Webber(#)
   9 C-----------------------------------------------------------------------
  10 C with Minimal Supersymmetric Standard Model Matrix Elements by
  11 C                  S. Moretti(") and K. Odagiri(^)
  12 C-----------------------------------------------------------------------
  13 C R parity violating Supersymmetric Decays and Matrix Elements by
  14 C                          P. Richardson(X)
  15 C-----------------------------------------------------------------------
  16 C matrix element corrections to top decay and Drell-Yan type processes
  17 C                         by G. Corcella(&)
  18 C-----------------------------------------------------------------------
  19 C Deep Inelastic Scattering and Heavy Flavour Electroproduction by
  20 C                  G. Abbiendi(@) and L. Stanco(%)
  21 C-----------------------------------------------------------------------
  22 C and Jet Photoproduction in Lepton-Hadron Collisions by J. Chyla(~)
  23 C-----------------------------------------------------------------------
  24 C(*)  Department of Physics & Astronomy, University of Edinburgh
  25 C(+)  Dipartimento di Fisica, Universita di Milano-Bicocca
  26 C($)  Department of Physics & Astronomy, University of Manchester
  27 C(&)  Theory Division, CERN
  28 C(#)  Cavendish Laboratory, Cambridge
  29 C(")  School of Physics & Astronomy, Southampton
  30 C(^)  Academia Sinica, Taiwan
  31 C(X)  Institute of Particle Physics Phenomenology, University of Durham
  32 C(@)  Dipartimento di Fisica, Universita di Bologna
  33 C(%)  Dipartimento di Fisica, Universita di Padova
  34 C(~)  Institute of Physics, Prague
  35 C-----------------------------------------------------------------------
  36 C                  Version 6.507 - 8th March 2005
  37 C-----------------------------------------------------------------------
  38 C Main references:
  39 C
  40 C    G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti, K.Odagiri,
  41 C    P.Richardson, M.H.Seymour and B.R.Webber, JHEP 0101 (2001) 010
  42 C
  43 C    G.Marchesini,  B.R.Webber,  G.Abbiendi,  I.G.Knowles,  M.H.Seymour,
  44 C    and L.Stanco, Computer Physics Communications 67 (1992) 465.
  45 C-----------------------------------------------------------------------
  46 C Please see the official HERWIG information page:
  47 C    http://hepwww.rl.ac.uk/theory/seymour/herwig/
  48 C-----------------------------------------------------------------------
  49 CDECK  ID>, CIRCEE.
  50 *CMZ :-        -03/07/01  17.07.47  by  Bryan Webber
  51 *-- Author :    Bryan Webber
  52 C-----------------------------------------------------------------------
  53       FUNCTION CIRCEE (X1, X2)
  54 C-----------------------------------------------------------------------
  55 C     DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
  56 C     IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
  57 C-----------------------------------------------------------------------
  58       DOUBLE PRECISION CIRCEE, X1, X2
  59       WRITE (6,10)
  60    10 FORMAT(/10X,'CIRCEE CALLED BUT NOT LINKED')
  61       CIRCEE = 0.0D0
  62       STOP
  63       END
  64 CDECK  ID>, CIRCES.
  65 *CMZ :-        -03/07/01  17.07.47  by  Bryan Webber
  66 *-- Author :    Bryan Webber
  67 C-----------------------------------------------------------------------
  68       SUBROUTINE CIRCES (XX1M, XX2M, XROOTS, XACC, XVER, XREV, XCHAT)
  69 C-----------------------------------------------------------------------
  70 C     DUMMY SUBROUTINE: DELETE AND SET CIRCOP NON-ZERO
  71 C     IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
  72 C-----------------------------------------------------------------------
  73       DOUBLE PRECISION XX1M, XX2M, XROOTS
  74       INTEGER XACC, XVER, XREV, XCHAT
  75       WRITE (6,10)
  76    10 FORMAT(/10X,'CIRCES CALLED BUT NOT LINKED')
  77       STOP
  78       END
  79 CDECK  ID>, CIRCGG.
  80 *CMZ :-        -03/07/01  17.07.47  by  Bryan Webber
  81 *-- Author :    Bryan Webber
  82 C-----------------------------------------------------------------------
  83       FUNCTION CIRCGG (X1, X2)
  84 C-----------------------------------------------------------------------
  85 C     DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
  86 C     IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
  87 C-----------------------------------------------------------------------
  88       DOUBLE PRECISION CIRCGG, X1, X2
  89       WRITE (6,10)
  90    10 FORMAT(/10X,'CIRCGG CALLED BUT NOT LINKED')
  91       CIRCGG = 0.0D0
  92       STOP
  93       END
  94 CDECK  ID>, DECADD.
  95 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
  96 *-- Author :    Luca Stanco
  97 C-----------------------------------------------------------------------
  98       SUBROUTINE DECADD(LOGI)
  99 C-----------------------------------------------------------------------
 100 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
 101 C     IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
 102 C-----------------------------------------------------------------------
 103       LOGICAL LOGI
 104       WRITE (6,10)
 105    10 FORMAT(/10X,'DECADD CALLED BUT NOT LINKED')
 106       STOP
 107       END
 108 CDECK  ID>, DEXAY.
 109 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
 110 *-- Author :    Peter Richardson
 111 C-----------------------------------------------------------------------
 112       SUBROUTINE DEXAY(IMODE,POL)
 113 C-----------------------------------------------------------------------
 114 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
 115 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
 116 C-----------------------------------------------------------------------
 117       IMPLICIT NONE
 118       INTEGER IMODE
 119       REAL POL(4)
 120       WRITE (6,10)
 121    10 FORMAT(/10X,'DEXAY CALLED BUT NOT LINKED')
 122       STOP
 123       END
 124 CDECK  ID>, EUDINI.
 125 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
 126 *-- Author :    Luca Stanco
 127 C-----------------------------------------------------------------------
 128       SUBROUTINE EUDINI
 129 C-----------------------------------------------------------------------
 130 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
 131 C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
 132 C-----------------------------------------------------------------------
 133       WRITE (6,10)
 134    10 FORMAT(/10X,'EUDINI CALLED BUT NOT LINKED')
 135       STOP
 136       END
 137 CDECK  ID>, FILHEP.
 138 *CMZ :-        -17/10/01  09:42:21  by  Peter Richardson
 139 *-- Author :    Martin W. Gruenewald
 140 C-----------------------------------------------------------------------
 141       SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
 142 C ----------------------------------------------------------------------
 143 C this subroutine fills one entry into the HEPEVT common
 144 C and updates the information for affected mother entries
 145 C used by TAUOLA
 146 C
 147 C written by Martin W. Gruenewald (91/01/28)
 148 C ----------------------------------------------------------------------
 149       INCLUDE 'HERWIG65.INC'
 150       LOGICAL QEDRAD
 151       COMMON /PHORAD/ QEDRAD(NMXHEP)
 152       INTEGER N,IHEP,IST,ID,JMO1,JMO2,JDA1,JDA2,I,IP
 153       REAL PINV
 154       LOGICAL PHFLAG
 155       REAL*4 P4(4)
 156 C
 157 C check address mode
 158       IF (N.EQ.0) THEN
 159 C append mode
 160         IHEP=NHEP+1
 161       ELSE IF (N.GT.0) THEN
 162 C absolute position
 163         IHEP=N
 164       ELSE
 165 C relative position
 166         IHEP=NHEP+N
 167       END IF
 168 C check on IHEP
 169       IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
 170 C add entry
 171       NHEP=IHEP
 172       ISTHEP(IHEP)=IST
 173       IDHEP(IHEP)=ID
 174       JMOHEP(1,IHEP)=JMO1
 175       IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
 176       JMOHEP(2,IHEP)=JMO2
 177       IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
 178       JDAHEP(1,IHEP)=JDA1
 179       JDAHEP(2,IHEP)=JDA2
 180       DO I=1,4
 181         PHEP(I,IHEP)=P4(I)
 182 C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
 183         VHEP(I,IHEP)=0.0
 184       END DO
 185       PHEP(5,IHEP)=PINV
 186 C FLAG FOR PHOTOS...
 187       QEDRAD(IHEP)=PHFLAG
 188 C update process:
 189       DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
 190         IF(IP.GT.0)THEN
 191 C if there is a daughter at IHEP, mother entry at IP has decayed
 192           IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
 193 C and daughter pointers of mother entry must be updated
 194           IF(JDAHEP(1,IP).EQ.0)THEN
 195             JDAHEP(1,IP)=IHEP
 196             JDAHEP(2,IP)=IHEP
 197           ELSE
 198             JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
 199           END IF
 200         END IF
 201       END DO
 202       RETURN
 203       END
 204 CDECK  ID>, FRAGMT.
 205 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
 206 *-- Author :    Luca Stanco
 207 C-----------------------------------------------------------------------
 208       SUBROUTINE FRAGMT(I,J,K)
 209 C-----------------------------------------------------------------------
 210 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
 211 C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
 212 C-----------------------------------------------------------------------
 213       INTEGER I,J,K
 214       WRITE (6,10)
 215    10 FORMAT(/10X,'FRAGMT CALLED BUT NOT LINKED')
 216       STOP
 217       END
 218 CDECK  ID>, HVCBVI.
 219 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
 220 *-- Author :    Mike Seymour
 221 C-----------------------------------------------------------------------
 222       SUBROUTINE HVCBVI
 223 C-----------------------------------------------------------------------
 224 C     DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
 225 C-----------------------------------------------------------------------
 226       WRITE (6,10)
 227    10 FORMAT(/10X,'HVCBVI CALLED BUT NOT LINKED')
 228       STOP
 229       END
 230 CDECK  ID>, HVHBVI.
 231 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
 232 *-- Author :    Mike Seymour
 233 C-----------------------------------------------------------------------
 234       SUBROUTINE HVHBVI
 235 C-----------------------------------------------------------------------
 236 C     DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
 237 C-----------------------------------------------------------------------
 238       WRITE (6,10)
 239    10 FORMAT(/10X,'HERBVI CALLED BUT NOT LINKED')
 240       STOP
 241       END
 242 CDECK  ID>, HWBAZF.
 243 *CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
 244 *-- Author :    Ian Knowles
 245 C-----------------------------------------------------------------------
 246       SUBROUTINE HWBAZF(IPAR,JPAR,VEC1,VEC2,VEC3,VEC)
 247 C-----------------------------------------------------------------------
 248 C     Azimuthal correlation functions for Collins' algorithm,
 249 C     see I.G.Knowles, Comp. Phys. Comm. 58 (90) 271 for notation.
 250 C-----------------------------------------------------------------------
 251       INCLUDE 'HERWIG65.INC'
 252       DOUBLE PRECISION Z1,Z2,DOT12,DOT23,DOT31,TR,FN(7),VEC1(2),VEC2(2),
 253      & VEC3(2),VEC(2)
 254       INTEGER IPAR,JPAR
 255       LOGICAL GLUI,GLUJ
 256       IF (.NOT.AZSPIN) RETURN
 257       Z1=PPAR(4,JPAR)/PPAR(4,IPAR)
 258       Z2=1.-Z1
 259       GLUI=IDPAR(IPAR).EQ.13
 260       GLUJ=IDPAR(JPAR).EQ.13
 261       IF (GLUI) THEN
 262          IF (GLUJ) THEN
 263 C           Branching: g--->gg
 264             FN(2)=Z2/Z1
 265             FN(3)=1./FN(2)
 266             FN(4)=Z1*Z2
 267             FN(1)=FN(2)+FN(3)+FN(4)
 268             FN(5)=FN(2)+2.*Z1
 269             FN(6)=FN(3)+2.*Z2
 270             FN(7)=FN(4)-2.
 271          ELSE
 272 C           Branching: g--->qqbar
 273             FN(1)=(Z1*Z1+Z2*Z2)/2.
 274             FN(2)=0.
 275             FN(3)=0.
 276             FN(4)=-Z1*Z2
 277             FN(5)=-(2.*Z1-1.)/2.
 278             FN(6)=-FN(5)
 279             FN(7)=FN(1)
 280          ENDIF
 281       ELSE
 282          IF (GLUJ) THEN
 283 C           Branching: q--->gq
 284             FN(1)=(1.+Z2*Z2)/(2.*Z1)
 285             FN(2)=Z2/Z1
 286             FN(3)=0.
 287             FN(4)=0.
 288             FN(5)=FN(1)
 289             FN(6)=(1.+Z2)/2.
 290             FN(7)=-FN(6)
 291          ELSE
 292 C           Branching: q--->qg
 293             FN(1)=(1.+Z1*Z1)/(2.*Z2)
 294             FN(2)=0.
 295             FN(3)=Z1/Z2
 296             FN(4)=0.
 297             FN(5)=(1.+Z1)/2.
 298             FN(6)=FN(1)
 299             FN(7)=-FN(5)
 300          ENDIF
 301       ENDIF
 302       DOT12=VEC1(1)*VEC2(1)+VEC1(2)*VEC2(2)
 303       DOT23=VEC2(1)*VEC3(1)+VEC2(2)*VEC3(2)
 304       DOT31=VEC3(1)*VEC1(1)+VEC3(2)*VEC1(2)
 305       TR=1./(FN(1)+FN(2)*DOT23+FN(3)*DOT31+FN(4)*DOT12)
 306       VEC(1)=((FN(2)+FN(5)*DOT23)*VEC1(1)
 307      &       +(FN(3)+FN(6)*DOT31)*VEC2(1)
 308      &       +(FN(4)+FN(7)*DOT12)*VEC3(1))*TR
 309       VEC(2)=((FN(2)+FN(5)*DOT23)*VEC1(2)
 310      &       +(FN(3)+FN(6)*DOT31)*VEC2(2)
 311      &       +(FN(4)+FN(7)*DOT12)*VEC3(2))*TR
 312       END
 313 CDECK  ID>, HWBCON.
 314 *CMZ :-        -11/10/01  12.01.52  by  Peter Richardson
 315 *-- Author :    Bryan Webber
 316 C-----------------------------------------------------------------------
 317       SUBROUTINE HWBCON
 318 C-----------------------------------------------------------------------
 319 C     MAKES COLOUR CONNECTIONS BETWEEN JETS
 320 C     MODIFIED 12/10/97 BY BRW FOR SUSY PROCESSES
 321 C     MODIFIED 11/01/01 BY PR  FOR SPIN CORRELATIONS(PROBLEM WITH ORDER
 322 C                                                    OF DECAYS)
 323 C     NEW VARAIBLE BACK TO ALLOW CODE TO SEARCH DOWN CHAIN
 324 C-----------------------------------------------------------------------
 325       INCLUDE 'HERWIG65.INC'
 326       INTEGER IHEP,IST,ID,JC,KC,JD,JHEP,LHEP,ID2,NTRY,KHEP
 327       LOGICAL BACK
 328       IF (IERROR.NE.0) RETURN
 329       IF(.NOT.RPARTY) THEN
 330         CALL HWBRCN
 331         RETURN
 332       ENDIF
 333       DO 20 IHEP=1,NHEP
 334       BACK = .FALSE.
 335       IST=ISTHEP(IHEP)
 336 C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
 337       IF (IST.LT.145.OR.IST.GT.152) GOTO 20
 338  51   IF (JMOHEP(2,IHEP).EQ.0.OR.BACK.OR.
 339      &     ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
 340 C---FIND COLOUR-CONNECTED PARTON
 341         IF(BACK) GOTO 52
 342         IF(JMOHEP(2,IHEP).EQ.0) THEN
 343           JC=JMOHEP(1,IHEP)
 344           IF (IST.NE.152) JC=JMOHEP(1,JC)
 345           JC =JMOHEP(2,JC)
 346         ELSE
 347           JC = JMOHEP(2,IHEP)
 348           JHEP = JC
 349         ENDIF
 350         IF (JC.EQ.0) CALL HWWARN('HWBCON',51,*20)
 351 C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
 352  52       IF (ISTHEP(JC).EQ.155.OR.BACK) THEN
 353           IF (IDHEP(JMOHEP(1,JC)).EQ.94.OR.BACK) THEN
 354 C---DECAYED BEFORE HADRONIZING
 355             IF(BACK.OR.(JMOHEP(2,IHEP).NE.0.AND.
 356      &                  ISTHEP(JMOHEP(2,IHEP)).EQ.155)) GOTO 53
 357             JHEP=JMOHEP(2,JC)
 358 C--new bit to try and fix the problems for spin correlations
 359 C--move one step further up the tree and hope this helps
 360             IF (JHEP.EQ.0) THEN
 361               NTRY = 0
 362  1            NTRY = NTRY+1
 363               JC   = JMOHEP(1,JC)
 364               JHEP = JMOHEP(2,JC)
 365               IF(JHEP.NE.0.AND.ISTHEP(JHEP).EQ.155)
 366      &             JHEP = JMOHEP(2,JHEP)
 367               IF(JHEP.EQ.0.AND.NTRY.LT.NHEP) GOTO 1
 368               IF(NHEP.EQ.NTRY) GOTO 20
 369             ENDIF
 370  53         ID=IDHW(JHEP)
 371             IF (ISTHEP(JHEP).EQ.155) THEN
 372 C---SPECIAL FOR GLUINO DECAYS
 373               IF (ID.EQ.449) THEN
 374                 ID=IDHW(JC)
 375 C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
 376                 IF (ID.EQ.449.OR.ID.EQ.13.OR.
 377      &             (ID.GE.401.AND.ID.LE.406).OR.
 378      &             (ID.GE.413.AND.ID.LE.418).OR.
 379      &             ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
 380 C---LOOK FOR ANTI(S)QUARK OR GLUON
 381                   DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
 382                     ID=IDHW(KC)
 383                     IF ((ID.GE.  7.AND.ID.LE. 13).OR.
 384      &                  (ID.GE.407.AND.ID.LE.412).OR.
 385      &                  (ID.GE.419.AND.ID.LE.424)) GOTO 5
 386                   ENDDO
 387                 ELSE
 388 C---LOOK FOR (S)QUARK OR GLUON
 389                   DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
 390                     ID=IDHW(KC)
 391                     IF (ID.LE.  6.OR. ID.EQ. 13.OR.
 392      &                 (ID.GE.401.AND.ID.LE.406).OR.
 393      &                 (ID.GE.413.AND.ID.LE.418)) GOTO 5
 394                   ENDDO
 395                 ENDIF
 396 C---COULDNT FIND ONE
 397                 CALL HWWARN('HWBCON',101,*999)
 398     5           JC=KC
 399               ELSE
 400 C--PR MOD 30/6/99 should fix HWCFOR 104 errors
 401                 ID2 = IDHW(IHEP)
 402                 IF(IDHW(JDAHEP(1,JHEP)).EQ.449.AND.
 403      &             (ID2.LE.6.OR.(ID2.GE.115.AND.ID2.LE.120).OR.
 404      &             (ID2.GE.401.AND.ID2.LE.406).OR.ID2.EQ.13.OR.
 405      &             (ID2.GE.413.AND.ID2.LE.418).OR.ID2.EQ.449)) THEN
 406                   JC = JDAHEP(1,JHEP)
 407                 ELSE
 408 C--modifcation for top ME correction (modified for additional photon radiation)
 409                   IF(IDHW(JHEP).EQ.6) THEN
 410                     JC = JDAHEP(1,JHEP)+1
 411                   ELSE
 412                     JC = JDAHEP(1,JHEP)+1
 413                     IF(IDHW(JDAHEP(1,JHEP)+2).EQ.13) JC=JC+1
 414                   ENDIF
 415                 ENDIF
 416               ENDIF
 417             ELSEIF (ID.EQ.6.OR.ID.EQ.12.OR.
 418      &      (ID.GE.209.AND.ID.LE.218).OR.
 419      &      (ID.GE.401.AND.ID.LE.424).OR.ID.EQ.449) THEN
 420 C Wait for partner heavy quark to decay
 421 C              RETURN
 422 C---N.B. MAY BE A PROBLEM HERE
 423               GOTO 20
 424             ELSE
 425               JMOHEP(2,IHEP)=JHEP
 426               JDAHEP(2,JHEP)=IHEP
 427               GOTO 20
 428             ENDIF
 429           ELSE
 430             JC=JMOHEP(2,JC)
 431           ENDIF
 432         ENDIF
 433         JC=JDAHEP(1,JC)
 434         JD=JDAHEP(2,JC)
 435 C---SEARCH IN CORRESPONDING JET
 436         IF (JD.LT.JC) JD=JC
 437         LHEP=0
 438         DO 10 JHEP=JC,JD
 439         IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 10
 440         IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
 441         IF (JDAHEP(2,JHEP).NE.0) GOTO 10
 442 C---JOIN IHEP AND JHEP
 443         ID=IDHW(JHEP)
 444         JMOHEP(2,IHEP)=JHEP
 445         JDAHEP(2,JHEP)=IHEP
 446         GOTO 20
 447    10   CONTINUE
 448         IF (LHEP.NE.0) THEN
 449           JMOHEP(2,IHEP)=LHEP
 450         ELSE
 451 C--search down the tree
 452           DO 50 KHEP=JC,JD
 453           IF(ISTHEP(KHEP).EQ.3.AND.ISTHEP(JDAHEP(1,KHEP)).EQ.155) THEN
 454             JHEP = JDAHEP(1,KHEP)
 455             BACK = .TRUE.
 456             GOTO 51
 457           ENDIF
 458  50       CONTINUE
 459 C---DIDN'T FIND PARTNER OF IHEP YET
 460 C          CALL HWWARN('HWBCON',52,*20)
 461         ENDIF
 462       ENDIF
 463   20  CONTINUE
 464 C---BREAK COLOUR CONNECTIONS WITH PHOTONS
 465       IHEP=1
 466   30  IF (IHEP.LE.NHEP) THEN
 467         IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149) THEN
 468 C  BRW FIX 13/03/99
 469           IF (JMOHEP(2,IHEP).NE.0) THEN
 470             IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
 471      &        JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
 472           ENDIF
 473 C  END FIX
 474           IF (JDAHEP(2,IHEP).NE.0) THEN
 475             IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
 476      &        JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
 477           ENDIF
 478           JMOHEP(2,IHEP)=IHEP
 479           JDAHEP(2,IHEP)=IHEP
 480         ENDIF
 481         IHEP=IHEP+1
 482         GOTO 30
 483       ENDIF
 484   999 END
 485 CDECK  ID>, HWBDED.
 486 *CMZ :-        -22/04/96  13.54.08  by  Mike Seymour
 487 *-- Author :    Mike Seymour
 488 C-----------------------------------------------------------------------
 489       SUBROUTINE HWBDED(IOPT)
 490 C     FILL MISSING AREA OF DALITZ PLOT WITH 3-JET AND 2-JET+GAMMA EVENTS
 491 C     IF (IOPT.EQ.1) SET UP EVENT RECORD
 492 C     IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
 493 C
 494 C********MODIFIED 13/11/00 BY BRW TO ALLOW MULTIPLE APPLICATION IN
 495 C*******SAME EVENT (FOR WW AND ZZ) N.B. NO CLEANUP CALLS FOR THESE!
 496 C-----------------------------------------------------------------------
 497       INCLUDE 'HERWIG65.INC'
 498       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,WMAX,WSUM,
 499      & X1MIN,X1MAX,X2MIN,X2MAX,QSCALE,GAMFAC,GLUFAC,R(3,3),CS,SN,M(3),
 500      & E(3),LAMBDA,A,B,C,PTSQ,EM,P1(5),P2(5),PVRT(4),EPS,MASDEP
 501       INTEGER ID,ID3,EMIT,NOEMIT,IEVT,IHEP,JHEP,KHEP,ICMF,IOPT,IEDT(3),
 502      & I,NDEL,LHEP,IP,JP,KP,IDUN
 503       EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
 504       SAVE X,WMAX,P1,P2
 505       DATA WSUM,WMAX,X1MIN,X1MAX,EMIT,ICMF,IEVT
 506      & /0.994651D0,1.84096D0,0.0D0,0.773459D0,3*0.0D0/
 507       LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
 508       IF (IOPT.EQ.1) THEN
 509 C---FIND AN UNTREATED CMF
 510         IF (IEVT.EQ.NEVHEP+NWGTS) RETURN
 511         IEVT=0
 512         ICMF=0
 513  5      IDUN=ICMF
 514         DO 10 IHEP=IDUN+1,NHEP
 515  10       IF (ICMF.EQ.IDUN .AND. ISTHEP(IHEP).EQ.110 .AND.
 516      &    JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
 517         IF (ICMF.EQ.IDUN) RETURN
 518         EM=PHEP(5,ICMF)
 519         IF (EM.LT.2*HWBVMC(1)) GOTO 5
 520 C---ONLY APPLY THE CORRECTION TO HADRONIC DECAYS
 521         IF (IDHW(JDAHEP(1,ICMF)).GT.12) GOTO 5
 522 C---GENERATE X1,X2 ACCORDING TO 1/((1-X1)*(1-X2))
 523  100    CONTINUE
 524 C---CHOOSE X1
 525         X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(0)
 526 C---CHOOSE X2
 527         X2MIN=MAX(X(1),1-X(1))
 528         X2MAX=(4*X(1)-3+2*DREAL(  DCMPLX(  X(1)**3+135*(X(1)-1)**3,
 529      &    3*HWUSQR(3*(128*X(1)**4-368*X(1)**3+405*X(1)**2-216*X(1)+54))*
 530      &    (X(1)-1)  )**(1./3)  ))/3
 531         IF (X2MAX.GE.ONE.OR.X2MIN.GE.ONE.OR.X2MAX.LE.X2MIN) GOTO 100
 532         X(2)=1-(1-X2MAX)*((1-X2MIN)/(1-X2MAX))**HWRGEN(1)
 533 C---CALCULATE WEIGHT
 534         W=2 * LOG((1-X1MIN)/(1-X1MAX))*LOG((1-X2MIN)/(1-X2MAX)) *
 535      &    (X(1)**2+X(2)**2)
 536 C---GENERATE UNWEIGHTED (X1,X2) PAIRS (EFFICIENCY IS ~50%)
 537         IF (WMAX*HWRGEN(2).GT.W) GOTO 100
 538 C---SYMMETRIZE X1,X2
 539         X(3)=2-X(1)-X(2)
 540         IF (HWRGEN(5).GT.HALF) THEN
 541           X(1)=X(2)
 542           X(2)=2-X(3)-X(1)
 543         ENDIF
 544 C---CHOOSE WHICH PARTON WILL EMIT
 545         EMIT=1
 546         IF (HWRGEN(6).LT.X(1)**2/(X(1)**2+X(2)**2)) EMIT=2
 547         NOEMIT=3-EMIT
 548         IHEP=JDAHEP(  EMIT,ICMF)
 549         JHEP=JDAHEP(NOEMIT,ICMF)
 550 C---PREFACTORS FOR GAMMA AND GLUON CASES
 551         QSCALE=HWUSQR((1-X(1))*(1-X(2))*(1-X(3)))*EM/X(NOEMIT)
 552         ID=IDHW(JDAHEP(1,ICMF))
 553         GAMFAC=ALPFAC*ALPHEM*ICHRG(ID)**2/(18*PIFAC)
 554         GLUFAC=0
 555         IF (QSCALE.GT.HWBVMC(13))
 556      &    GLUFAC=CFFAC/(2*PIFAC)*HWUALF(1,QSCALE)
 557 C---SWITCH OFF PHOTON EMISSION IN W DECAYS (THE M-E DOES NOT FACTORIZE)
 558         IF (ICHRG(IDHW(ICMF)).NE.0) GAMFAC=0
 559 C---IN FRACTION FAC*WSUM OF EVENTS ADD A GAMMA/GLUON
 560         IF     (GAMFAC*WSUM .GT. HWRGEN(3)) THEN
 561           ID3=59
 562         ELSEIF (GLUFAC*WSUM .GT. HWRGEN(4)) THEN
 563           ID3=13
 564         ELSE
 565           EMIT=0
 566           GOTO 5
 567         ENDIF
 568 C---CHECK INFRA-RED CUT-OFF FOR GAMMA/GLUON
 569         M(EMIT)=PHEP(5,IHEP)+VQCUT
 570         M(NOEMIT)=PHEP(5,JHEP)+VQCUT
 571         M(3)=HWBVMC(ID3)
 572         E(1)=HALF*EM*(X(1)+(M(1)**2-M(2)**2-M(3)**2)/EM**2)
 573         E(2)=HALF*EM*(X(2)+(M(2)**2-M(3)**2-M(1)**2)/EM**2)
 574         E(3)=EM-E(1)-E(2)
 575         PTSQ=-LAMBDA(E(NOEMIT)**2-M(NOEMIT)**2,E(3)**2-M(3)**2,
 576      &    E(EMIT)**2-M(EMIT)**2)
 577         IF (PTSQ.LE.ZERO .OR.
 578      $       E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3)) THEN
 579           EMIT=0
 580           GOTO 5
 581         ENDIF
 582 C---CALCULATE MASS-DEPENDENT SUPRESSION
 583         IF (MOD(IPROC,10).GT.0) THEN
 584           EPS=(RMASS(ID)/EM)**2
 585           MASDEP=X(1)**2+X(2)**2
 586      $         -4*EPS*X(3)-2*EPS*((1-X(2))/(1-X(1))+(1-X(1))/(1-X(2)))
 587      $         -4*EPS**2*X(3)**2/((1-X(1))*(1-X(2)))
 588           IF (MASDEP.LT.HWRGEN(7)*(X(1)**2+X(2)**2)) THEN
 589             EMIT=0
 590             GOTO 5
 591           ENDIF
 592         ENDIF
 593 C---STORE OLD MOMENTA
 594         CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P1)
 595         CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P2)
 596 C---GET THE NON-EMITTING PARTON'S CMF DIRECTION
 597         CALL HWULOF(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
 598         CALL HWRAZM(ONE,CS,SN)
 599         CALL HWUROT(PHEP(1,JHEP),CS,SN,R)
 600         M(EMIT)=PHEP(5,IHEP)
 601         M(NOEMIT)=PHEP(5,JHEP)
 602         M(3)=RMASS(ID3)
 603         KHEP=JDAHEP(2,ICMF)
 604         LHEP=KHEP+1
 605         IF (NHEP.GT.KHEP) THEN
 606 C---MOVE UP REST OF EVENT
 607            DO IP=NHEP,LHEP,-1
 608               JP=IP+1
 609               ISTHEP(JP)= ISTHEP(IP)
 610               IDHW(JP)=IDHW(IP)
 611               IDHEP(JP)=IDHEP(IP)
 612               KP=JMOHEP(1,IP)
 613               IF (KP.GT.KHEP) THEN
 614                  KP=KP+1
 615               ELSE
 616                  IF (JDAHEP(1,KP).EQ.IP) JDAHEP(1,KP)=JP
 617                  IF (JDAHEP(2,KP).EQ.IP) JDAHEP(2,KP)=JP
 618               ENDIF
 619               JMOHEP(1,JP)=KP
 620               KP=JMOHEP(2,IP)
 621               IF (KP.GT.KHEP) KP=KP+1
 622               JMOHEP(2,JP)=KP
 623               KP=JDAHEP(1,IP)
 624               IF (KP.GT.KHEP) KP=KP+1
 625               JDAHEP(1,JP)=KP
 626               KP=JDAHEP(2,IP)
 627               IF (KP.GT.KHEP) KP=KP+1
 628               JDAHEP(2,JP)=KP
 629               CALL HWVEQU(5,PHEP(1,IP),PHEP(1,JP))
 630               CALL HWVEQU(4,VHEP(1,IP),VHEP(1,JP))
 631            ENDDO
 632         ENDIF
 633 C---REORDER ENTRIES: IHEP=EMITTER, JHEP=NON-EMITTER, KHEP=EMITTED
 634         NHEP=NHEP+1
 635         IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
 636           IHEP=JDAHEP(1,ICMF)
 637           JHEP=LHEP
 638         ELSE
 639           IHEP=LHEP
 640           JHEP=JDAHEP(1,ICMF)
 641         ENDIF
 642 C---SET UP MOMENTA
 643         PHEP(5,JHEP)=M(NOEMIT)
 644         PHEP(5,IHEP)=M(EMIT)
 645         PHEP(5,KHEP)=M(3)
 646         PHEP(4,JHEP)=HALF*EM*(X(NOEMIT)+
 647      &                  (M(NOEMIT)**2-M(EMIT)**2-M(3)**2)/EM**2)
 648         PHEP(4,IHEP)=HALF*EM*(X(EMIT)+
 649      &                  (M(EMIT)**2-M(NOEMIT)**2-M(3)**2)/EM**2)
 650         PHEP(4,KHEP)=EM-PHEP(4,IHEP)-PHEP(4,JHEP)
 651         PHEP(3,JHEP)=HWUSQR(PHEP(4,JHEP)**2-PHEP(5,JHEP)**2)
 652         PHEP(3,IHEP)=( (PHEP(4,KHEP)**2-PHEP(5,KHEP)**2) -
 653      &    (PHEP(4,IHEP)**2-PHEP(5,IHEP)**2) -
 654      &    (PHEP(3,JHEP)**2) )*HALF/PHEP(3,JHEP)
 655         PHEP(3,KHEP)=-PHEP(3,IHEP)-PHEP(3,JHEP)
 656         PHEP(2,JHEP)=0
 657         PHEP(2,IHEP)=0
 658         PHEP(2,KHEP)=0
 659         PHEP(1,JHEP)=0
 660         PHEP(1,IHEP)=HWUSQR(PHEP(4,IHEP)**2-
 661      &    PHEP(3,IHEP)**2-PHEP(5,IHEP)**2)
 662         PHEP(1,KHEP)=-PHEP(1,IHEP)
 663 C---ORIENT IN CMF, THEN BOOST TO LAB
 664         CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
 665         CALL HWUROB(R,PHEP(1,JHEP),PHEP(1,JHEP))
 666         CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
 667         CALL HWULOB(PHEP(1,ICMF),PHEP(1,IHEP),PHEP(1,IHEP))
 668         CALL HWULOB(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
 669         CALL HWULOB(PHEP(1,ICMF),PHEP(1,KHEP),PHEP(1,KHEP))
 670 C---CALCULATE PRODUCTION VERTICES
 671         CALL HWVZRO(4,VHEP(1,JHEP))
 672         CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PVRT)
 673         CALL HWUDKL(ID,PVRT,VHEP(1,KHEP))
 674         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,IHEP))
 675 C---REORDER ENTRIES: IHEP=QUARK, JHEP=ANTI-QUARK, KHEP=EMITTED
 676         IF (IHEP.EQ.LHEP) THEN
 677           IHEP=JHEP
 678           JHEP=LHEP
 679         ENDIF
 680 C---STATUS, ID AND POINTERS
 681         ISTHEP(JHEP)=114
 682         IDHW(JHEP)=IDHW(KHEP)
 683         IDHEP(JHEP)=IDHEP(KHEP)
 684         IDHW(KHEP)=ID3
 685         IDHEP(KHEP)=IDPDG(ID3)
 686         JDAHEP(2,ICMF)=JHEP
 687         JMOHEP(1,JHEP)=ICMF
 688         JDAHEP(1,JHEP)=0
 689 C---COLOUR CONNECTIONS AND GLUON POLARIZATION
 690         JMOHEP(2,JHEP)=IHEP
 691         JDAHEP(2,IHEP)=JHEP
 692         IF (ID3.EQ.13) THEN
 693           JMOHEP(2,IHEP)=KHEP
 694           JMOHEP(2,KHEP)=JHEP
 695           JDAHEP(2,JHEP)=KHEP
 696           JDAHEP(2,KHEP)=IHEP
 697           GPOLN=((1-X(1))**2+(1-X(2))**2)/(4*(1-X(3)))
 698           GPOLN=1/(1+GPOLN)
 699         ELSE
 700           JMOHEP(2,IHEP)=JHEP
 701           JMOHEP(2,KHEP)=KHEP
 702           JDAHEP(2,JHEP)=IHEP
 703           JDAHEP(2,KHEP)=KHEP
 704         ENDIF
 705         IEVT=NEVHEP+NWGTS
 706         GOTO 5
 707       ELSEIF (IOPT.EQ.2) THEN
 708 C---MAKE THREE-JET EVENTS FROM THE `DEAD-ZONE' LOOK LIKE TWO-JET EVENTS
 709         IF (EMIT.EQ.0.OR.IEVT.NE.NEVHEP+NWGTS) THEN
 710           RETURN
 711         ELSEIF (EMIT.EQ.1) THEN
 712           IHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
 713           JHEP=JDAHEP(1,JDAHEP(1,ICMF))
 714         ELSE
 715           IHEP=JDAHEP(1,JDAHEP(2,ICMF))
 716           JHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
 717           JDAHEP(1,JDAHEP(2,ICMF))=JHEP
 718           IDHW(JHEP)=IDHW(IHEP)
 719           IF (ISTHEP(IHEP+1).EQ.100 .AND. ISTHEP(JHEP+1).EQ.100)
 720      &      CALL HWVEQU(5,PHEP(1,IHEP+1),PHEP(1,JHEP+1))
 721         ENDIF
 722         JMOHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
 723         JDAHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
 724         JMOHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
 725         JDAHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
 726         CALL HWVEQU(5,P1,PHEP(1,JDAHEP(1,ICMF)))
 727         CALL HWVEQU(5,P2,PHEP(1,JDAHEP(2,ICMF)))
 728         CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,JHEP))
 729         CALL HWUMAS(PHEP(1,JHEP))
 730         JDAHEP(2,JHEP)=JDAHEP(2,IHEP)
 731         IEDT(1)=JDAHEP(1,ICMF)+1
 732         IEDT(2)=IHEP
 733         IEDT(3)=IHEP+1
 734         NDEL=3
 735         IF (ISTHEP(IHEP+1).NE.100) NDEL=2
 736         CALL HWUEDT(NDEL,IEDT)
 737         DO 410 I=1,2
 738           IHEP=JDAHEP(1,JDAHEP(I,ICMF))
 739           JMOHEP(1,IHEP)=JDAHEP(I,ICMF)
 740           IF (ISTHEP(IHEP+1).EQ.100) THEN
 741             JMOHEP(1,IHEP+1)=JMOHEP(1,IHEP)
 742             JMOHEP(2,IHEP+1)=JMOHEP(2,JMOHEP(1,IHEP))
 743           ENDIF
 744           DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
 745             JMOHEP(1,JHEP)=IHEP
 746  400      CONTINUE
 747           CALL HWVZRO(4,VHEP(1,JDAHEP(I,ICMF)))
 748           CALL HWVZRO(4,VHEP(1,IHEP))
 749           IF (ISTHEP(IHEP+1).EQ.100) CALL HWVZRO(4,VHEP(1,IHEP+1))
 750  410    CONTINUE
 751         EMIT=0
 752         IEVT=0
 753       ELSE
 754         CALL HWWARN('HWBDED',500,*999)
 755       ENDIF
 756  999  END
 757 CDECK  ID>, HWBDIS.
 758 *CMZ :-        -17/05/94  09.33.08  by  Mike Seymour
 759 *-- Author :    Mike Seymour
 760 C-----------------------------------------------------------------------
 761       SUBROUTINE HWBDIS(IOPT)
 762 C-----------------------------------------------------------------------
 763 C     FILL MISSING AREA OF DIS PHASE-SPACE WITH 2+1-JET EVENTS
 764 C     IF (IOPT.EQ.1) SET UP EVENT RECORD
 765 C     IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
 766 C-----------------------------------------------------------------------
 767       INCLUDE 'HERWIG65.INC'
 768       DOUBLE PRECISION HWRGEN,HWBVMC,HWUALF,HWULDO,P1(5),P2(5),P3(5),
 769      & PCMF(5),L(5),R(3,3),Q,XBJ,RN,XPMIN,XPMAX,XP,ZPMIN,ZPMAX,ZP,FAC,
 770      & X1,X2,XTSQ,XT,PTSQ,SIN1,SIN2,W1,W2,CFAC,PDFOLD(13),PDFNEW(13),
 771      & PHI,SCALE,Q1(5),Q2(5),DIR1,DIR2,DIR,PM(5),POLD,PNEW,COMINT,
 772      & BGFINT,COMWGT,C1,C2,CM,B1,B2,BM,PVRT(4)
 773       INTEGER IOPT,EMIT,ICMF,IHEP,JHEP,IIN,IOUT,ILEP,IHAD,ID,IDNEW,
 774      & IEDT(3),NDEL,NTRY,ITEMP
 775       LOGICAL BGF
 776       EXTERNAL HWRGEN,HWBVMC,HWUALF,HWULDO
 777       SAVE BGF,IIN,IOUT,ICMF,ID,Q1,Q2,XP,XBJ
 778       DATA EMIT,COMINT,BGFINT,COMWGT/0D0,3.9827D0,1.2462D0,0.3D0/
 779       DATA C1,C2,CM,B1,B2,BM/0.56D0,0.20D0,10D0,0.667D0,0.167D0,3D0/
 780       IF (IERROR.NE.0) RETURN
 781       IF (IOPT.EQ.1) THEN
 782 C---FIND AN UNTREATED CMF
 783         IF (EMIT.EQ.NEVHEP+NWGTS) RETURN
 784         ICMF=0
 785         DO 10 IHEP=1,NHEP
 786  10       IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110 .AND.
 787      &    JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
 788         IF (ICMF.EQ.0) RETURN
 789         IIN=JMOHEP(2,ICMF)
 790         IOUT=JDAHEP(2,ICMF)
 791         ILEP=JMOHEP(1,ICMF)
 792         CALL HWVEQU(5,PHEP(1,IIN),P1)
 793         CALL HWVEQU(5,PHEP(1,IOUT),P2)
 794         CALL HWVEQU(5,PHEP(1,ILEP),L)
 795         IHAD=2
 796         IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
 797         ID=IDHW(IIN)
 798 C---STORE OLD MOMENTA
 799         CALL HWVEQU(5,P1,Q1)
 800         CALL HWVEQU(5,P2,Q2)
 801 C---BOOST AND ROTATE THE MOMENTA TO THE BREIT FRAME
 802         CALL HWVDIF(4,P2,P1,PCMF)
 803         CALL HWUMAS(PCMF)
 804         CALL HWVEQU(5,PHEP(1,IHAD),PM)
 805         Q=-PCMF(5)
 806         XBJ=HALF*Q**2/HWULDO(PM,PCMF)
 807         CALL HWVSCA(4,HALF/XBJ,PCMF,PCMF)
 808         CALL HWVSUM(4,PM,PCMF,PCMF)
 809         CALL HWUMAS(PCMF)
 810         CALL HWULOF(PCMF,L,L)
 811         CALL HWULOF(PCMF,PM,PM)
 812         CALL HWUROT(PM,ONE,ZERO,R)
 813         CALL HWUROF(R,L,L)
 814         PHI=ATAN2(L(2),L(1))
 815         CALL HWUROT(PM,COS(PHI),SIN(PHI),R)
 816 C---CHOOSE THE HADRONIC-PLANE CONFIGURATION, XP,ZP
 817         IF (HWRGEN(0).LT.COMWGT) THEN
 818 C-----CONSIDER GENERATING A QCD COMPTON EVENT
 819           BGF=.FALSE.
 820           P3(5)=RMASS(13)
 821  100      RN=HWRGEN(1)
 822           IF (RN.LT.C1) THEN
 823             ZP=HWRGEN(2)
 824             XPMAX=MIN(ZP,1-ZP)
 825             XP=HWRGEN(3)*XPMAX
 826             FAC=1/C1*2*XPMAX/((1-XP)*(1-ZP))*
 827      $           (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 828             IF (HWRGEN(4).LT.HALF) THEN
 829               ZPMAX=ZP
 830               ZP=XP
 831               XP=ZPMAX
 832             ENDIF
 833           ELSEIF (RN.LT.C1+C2) THEN
 834             XPMAX=0.83
 835             XP=XPMAX*HWRGEN(2)
 836             ZPMIN=MAX(XP,1-XP)
 837             ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
 838      $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
 839      $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
 840             ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
 841             FAC=1/C2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))/(1-XP)*
 842      $           (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 843           ELSE
 844             ZPMAX=0.85
 845             ZP=ZPMAX*HWRGEN(2)
 846             XPMIN=MAX(ZP,1-ZP)
 847             XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
 848             XP=1-((1-XPMIN)/(1-XPMAX))**HWRGEN(4)*(1-XPMAX)
 849             FAC=1/(1-C1-C2)*ZPMAX*LOG((1-XPMIN)/(1-XPMAX))/(1-ZP)*
 850      $           (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 851           ENDIF
 852           XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
 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           IF (XP.GT.XPMAX.OR.ZP.GT.ZPMAX.OR.CM*HWRGEN(4).GT.FAC)
 857      $         GOTO 100
 858         ELSE
 859 C-----CONSIDER GENERATING A BGF EVENT
 860           BGF=.TRUE.
 861           P3(5)=P1(5)
 862           P1(5)=RMASS(13)
 863  110      RN=HWRGEN(1)
 864           IF (RN.LT.B1) THEN
 865             ZP=HWRGEN(2)
 866             XPMAX=MIN(ZP,1-ZP)
 867             XP=HWRGEN(3)*XPMAX
 868             FAC=1/B1*2*XPMAX/(1-ZP)*
 869      $           ((  XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
 870      $           +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 871             IF (HWRGEN(4).LT.HALF) XP=1-XP
 872           ELSEIF (RN.LT.B1+B2) THEN
 873             XPMAX=0.83
 874             XP=XPMAX*HWRGEN(2)
 875             ZPMIN=MAX(XP,1-XP)
 876             ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
 877      $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
 878      $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
 879             ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
 880             FAC=1/B2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))*
 881      $           ((  XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
 882      $           +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 883           ELSE
 884             XPMAX=0.83
 885             XP=XPMAX*HWRGEN(2)
 886             ZPMAX=MIN(XP,1-XP)
 887             ZPMIN=2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
 888      $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
 889      $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
 890             ZP=(ZPMAX-ZPMIN)*HWRGEN(4)+ZPMIN
 891             FAC=1/(1-B1-B2)*XPMAX*(ZPMAX-ZPMIN)/(1-ZP)*
 892      $           ((  XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
 893      $           +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
 894           ENDIF
 895           ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
 896      $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
 897      $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
 898           IF (ZP.GT.ZPMAX.OR.ZP.LT.ONE-ZPMAX.OR.BM*HWRGEN(4).GT.FAC)
 899      $         GOTO 110
 900         ENDIF
 901 C---CALCULATE THE ADDITIONAL FACTORS IN THE WEIGHT
 902         IF (BGF) THEN
 903           IDNEW=13
 904           CFAC=1./2
 905           FAC=BGFINT/(1-COMWGT)
 906         ELSE
 907           IDNEW=ID
 908           CFAC=4./3
 909           FAC=COMINT/COMWGT
 910         ENDIF
 911         SCALE=Q*SQRT((1-XP)*(1-ZP)*ZP/XP+1)
 912         ITEMP=ISTAT
 913         ISTAT=7
 914         CALL HWSFUN(XBJ,Q,IDHW(IHAD),NSTRU,PDFOLD,2)
 915         ISTAT=ITEMP
 916         IF (PDFOLD(ID).LE.ZERO) CALL HWWARN('HWBDIS',100,*999)
 917         IF (XP.GT.XBJ) THEN
 918           CALL HWSFUN(XBJ/XP,SCALE,IDHW(IHAD),NSTRU,PDFNEW,2)
 919           FAC=CFAC/(2*PIFAC) * HWUALF(1,SCALE) * FAC *
 920      $         PDFNEW(IDNEW)/PDFOLD(ID)
 921         ELSE
 922           FAC=0
 923         ENDIF
 924 C---FOR PHOTON BEAMS, INCLUDE DIRECT PHOTON COUPLING
 925         IF (IDHW(IHAD).EQ.59) THEN
 926           ZPMIN=2./3.*XBJ*(1+DREAL( DCMPLX(10-45*XBJ+18*XBJ**2,3*SQRT(
 927      $         3*(9+66*XBJ-93*XBJ**2+12*XBJ**3-8*XBJ**4+24*XBJ**5
 928      $         -8*XBJ**6)))**(1./3.)*DCMPLX(0.5D0,0.86602540378444D0) ))
 929           ZPMAX=1-ZPMIN
 930           DIR1=(XBJ**2+(1-XBJ)**2)*(LOG(ZPMAX/ZPMIN)-(ZPMAX-ZPMIN))
 931           DIR2=4*XBJ*(1-XBJ)*(ZPMAX-ZPMIN)
 932           DIR=QFCH(MOD(ID-1,6)+1)**2*ALPHEM/(2*PIFAC*PDFOLD(ID))*XBJ
 933      $         *(DIR1+DIR2)
 934         ELSE
 935           DIR=0
 936         ENDIF
 937 C---DECIDE WHETHER TO MAKE AN EVENT HERE
 938         IF (HWRGEN(4).GT.FAC+DIR) RETURN
 939 C---FOR DIRECT COUPLING, CHOOSE ZP VALUE
 940         IF ((FAC+DIR)*HWRGEN(8).GT.FAC) THEN
 941           IF ((DIR1+DIR2)*HWRGEN(9).LT.DIR1) THEN
 942             NTRY=0
 943  120        NTRY=NTRY+2
 944             ZP=1-(ZPMAX/ZPMIN)**HWRGEN(NTRY+1)*ZPMIN
 945             IF ((ZPMIN**2+(1-ZPMIN)**2)*HWRGEN(NTRY).GT.ZP**2+(1-ZP)**2)
 946      $           GOTO 120
 947           ELSE
 948             ZP=SQRT((ZPMAX-ZPMIN)*HWRGEN(10)+ZPMIN**2)
 949           ENDIF
 950           XP=XBJ
 951           BGF=.TRUE.
 952           P3(5)=P2(5)
 953           P1(5)=0
 954         ENDIF
 955         X1=1-   ZP /XP
 956         X2=1-(1-ZP)/XP
 957         XTSQ=4*(1-XP)*(1-ZP)*ZP/XP
 958         XT=SQRT(XTSQ)
 959         SIN1=XT/SQRT(X1**2+XTSQ)
 960         SIN2=XT/SQRT(X2**2+XTSQ)
 961 C---CHOOSE THE AZIMUTH BETWEEN THE TWO PLANES
 962         IF (BGF) THEN
 963           W1=XP**2*(X1**2+1.5*XTSQ)
 964         ELSE
 965           W1=1
 966         ENDIF
 967         W2=XP**2*(X2**2+1.5*XTSQ)
 968         IF (HWRGEN(5)*(W1+W2).GT.W2) THEN
 969           IF (BGF) THEN
 970 C-----WEIGHTED BY (1+SIN1*COS(PHI))**2
 971  200        PHI=(2*HWRGEN(6)-1)*PIFAC
 972             IF (HWRGEN(7)*(1+SIN1)**2.GT.(1+SIN1*COS(PHI))**2) GOTO 200
 973           ELSE
 974 C-----UNIFORMLY
 975             PHI=(2*HWRGEN(6)-1)*PIFAC
 976           ENDIF
 977         ELSE
 978 C-----WEIGHTED BY (1-SIN2*COS(PHI))**2
 979  210      PHI=(2*HWRGEN(6)-1)*PIFAC
 980           IF (HWRGEN(7)*(1+SIN2)**2.GT.(1-SIN2*COS(PHI))**2) GOTO 210
 981         ENDIF
 982 C---RECONSTRUCT MOMENTA AND BOOST BACK TO LAB
 983         P1(1)=0
 984         P1(2)=0
 985         P1(3)=HALF*Q/XP
 986         P1(4)=SQRT(P1(3)**2+P1(5)**2)
 987         PTSQ=((ZP*Q*(P1(4)+P1(3)-Q)-P2(5)**2)*(P1(4)-P1(3)+(1-ZP)*Q)
 988      $       -P3(5)**2*ZP*Q)/(P1(4)-P1(3)+Q)
 989 C---CHECK INFRARED CUTOFF FOR THIS PARTON TYPE
 990         IF (PTSQ.LT.MAX(HWBVMC(ID),HWBVMC(IDHW(IOUT)))**2) RETURN
 991         P2(1)=SQRT(PTSQ)*COS(PHI)
 992         P2(2)=SQRT(PTSQ)*SIN(PHI)
 993         P2(3)=-0.5*(ZP*Q-(PTSQ+P2(5)**2)/(ZP*Q))
 994         P2(4)= 0.5*(ZP*Q+(PTSQ+P2(5)**2)/(ZP*Q))
 995         P3(1)=P1(1)-P2(1)
 996         P3(2)=P1(2)-P2(2)
 997         P3(3)=P1(3)-P2(3)-Q
 998         P3(4)=P1(4)-P2(4)
 999         CALL HWUROB(R,P1,P1)
1000         CALL HWUROB(R,P2,P2)
1001         CALL HWUROB(R,P3,P3)
1002         CALL HWULOB(PCMF,P1,P1)
1003         CALL HWULOB(PCMF,P2,P2)
1004         CALL HWULOB(PCMF,P3,P3)
1005 C---SPECIAL CASE FOR DIRECT PHOTON - COPY THE EXACT BEAM MOMENTUM
1006 C---SHARE THE MISMATCH EQUALLY BETWEEN THE OUTGOING PARTONS
1007 C---AND PUT THEM BACK ON SHELL
1008         IF (XP.EQ.XBJ) THEN
1009           CALL HWVDIF(4,PHEP(1,IHAD),P1,PM)
1010           CALL HWVSCA(4,HALF,PM,PM)
1011           CALL HWVSUM(4,PM,P2,P2)
1012           CALL HWVSUM(4,PM,P3,P3)
1013           CALL HWUMAS(P2)
1014           CALL HWUMAS(P3)
1015           CALL HWVEQU(5,PHEP(1,IHAD),P1)
1016           CALL HWVSUM(4,P2,P3,PCMF)
1017           CALL HWUMAS(PCMF)
1018           POLD=HWULDO(P2,PCMF)**2/PCMF(5)**2-SIGN(P2(5)**2,P2(5))
1019           PNEW=PCMF(5)**2/4-RMASS(ID)**2
1020           IF (PCMF(5).LE.ZERO.OR.POLD.LE.ZERO.OR.PNEW.LE.ZERO) RETURN
1021           CALL HWVSCA(4,SQRT(PNEW/POLD),P2,P2)
1022           CALL HWVSCA(4,HALF-HWULDO(P2,PCMF)/PCMF(5)**2,PCMF,PM)
1023           CALL HWVSUM(4,PM,P2,P2)
1024           CALL HWUMAS(P2)
1025           CALL HWVDIF(4,PCMF,P2,P3)
1026           CALL HWUMAS(P3)
1027         ENDIF
1028         NHEP=NHEP+1
1029         CALL HWVEQU(5,P1,PHEP(1,IIN))
1030         IF (BGF.AND.ID.GT.6.OR..NOT.BGF.AND.ID.LT.7) THEN
1031           CALL HWVEQU(5,P2,PHEP(1,IOUT))
1032           CALL HWVEQU(5,P3,PHEP(1,NHEP))
1033         ELSE
1034           CALL HWVEQU(5,P3,PHEP(1,IOUT))
1035           CALL HWVEQU(5,P2,PHEP(1,NHEP))
1036         ENDIF
1037         CALL HWVSUM(4,PHEP(1,ILEP),PHEP(1,IIN),PHEP(1,ICMF))
1038         CALL HWUMAS(PHEP(1,ICMF))
1039 C Decide which quark radiated and assign production vertices
1040         IF (BGF) THEN
1041 C Boson-Gluon fusion case
1042           IF (1-ZP.LT.HWRGEN(0)) THEN
1043 C Gluon splitting to quark
1044             CALL HWVZRO(4,VHEP(1,NHEP-1))
1045             CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
1046             CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1047             CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
1048           ELSE
1049 C Gluon splitting to antiquark
1050             CALL HWVZRO(4,VHEP(1,NHEP))
1051             CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
1052             CALL HWUDKL(ID,PVRT,VHEP(1,NHEP-1))
1053             CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
1054           ENDIF
1055         ELSE
1056 C QCD Compton case
1057           IF (1.LT.HWRGEN(0)*(1+(1-XP-ZP)**2+6*XP*(1-XP)*ZP*(1-ZP)))THEN
1058 C Incoming quark radiated the gluon
1059             CALL HWVZRO(4,VHEP(1,NHEP-1))
1060             CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
1061             CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1062             CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
1063           ELSE
1064 C Outgoing quark radiated the gluon
1065             CALL HWVZRO(4,VHEP(1,NHEP-4))
1066             CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
1067             CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1068             CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
1069           ENDIF
1070         ENDIF
1071 C---STATUS, ID AND POINTERS
1072         ISTHEP(NHEP)=114
1073         IF (BGF) THEN
1074           IF (XP.EQ.XBJ) THEN
1075             IDHW(IIN)=59
1076             IDHEP(IIN)=IDPDG(59)
1077           ELSE
1078             IDHW(IIN)=13
1079             IDHEP(IIN)=IDPDG(13)
1080           ENDIF
1081           IF (ID.LT.7) THEN
1082             IDHW(NHEP)=IDHW(IOUT)
1083             IDHEP(NHEP)=IDHEP(IOUT)
1084             IDHW(IOUT)=MOD(ID,6)+6
1085             IDHEP(IOUT)=IDPDG(IDHW(IOUT))
1086           ELSE
1087             IDHW(NHEP)=MOD(ID,6)
1088             IDHEP(NHEP)=IDPDG(IDHW(NHEP))
1089           ENDIF
1090         ELSEIF (ID.LT.7) THEN
1091           IDHW(NHEP)=13
1092           IDHEP(NHEP)=IDPDG(13)
1093         ELSE
1094           IDHW(NHEP)=IDHW(IOUT)
1095           IDHEP(NHEP)=IDHEP(IOUT)
1096           IDHW(IOUT)=13
1097           IDHEP(IOUT)=IDPDG(13)
1098         ENDIF
1099         JDAHEP(2,ICMF)=NHEP
1100         JMOHEP(1,NHEP)=ICMF
1101 C---COLOUR CONNECTIONS
1102         IF (XP.EQ.XBJ) THEN
1103           JMOHEP(2,IIN)=IIN
1104           JDAHEP(2,IIN)=IIN
1105           JMOHEP(2,IOUT)=NHEP
1106           JDAHEP(2,IOUT)=NHEP
1107           JMOHEP(2,NHEP)=IOUT
1108           JDAHEP(2,NHEP)=IOUT
1109         ELSE
1110           JDAHEP(2,IIN)=NHEP
1111           JDAHEP(2,NHEP)=IOUT
1112           JMOHEP(2,IOUT)=NHEP
1113           JMOHEP(2,NHEP)=IIN
1114         ENDIF
1115 C---FACTORISATION SCALE
1116         EMSCA=SCALE
1117         EMIT=NEVHEP+NWGTS
1118       ELSEIF (IOPT.EQ.2) THEN
1119 C---MAKE TWO-JET EVENTS LOOK LIKE ONE-JET EVENTS
1120         IF (EMIT.NE.NEVHEP+NWGTS .OR. XP.EQ.XBJ) RETURN
1121         IF (.NOT.BGF) THEN
1122           CALL HWVEQU(5,Q1,PHEP(1,IIN))
1123           CALL HWVEQU(5,Q2,PHEP(1,IOUT))
1124           JMOHEP(2,IIN)=IOUT
1125           JDAHEP(2,IIN)=IOUT
1126           JMOHEP(2,IOUT)=IIN
1127           JDAHEP(2,IOUT)=IIN
1128           JDAHEP(2,ICMF)=IOUT
1129           IHEP=JDAHEP(1,IOUT)
1130           JHEP=JDAHEP(1,IOUT+1)
1131           CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1132           CALL HWUMAS(PHEP(1,IHEP))
1133           JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
1134           IEDT(1)=IOUT+1
1135           IEDT(2)=JHEP
1136           IEDT(3)=JHEP+1
1137           NDEL=3
1138           IF (ISTHEP(JHEP+1).NE.100) NDEL=2
1139           IHEP=JDAHEP(1,IOUT)
1140           JMOHEP(1,IHEP)=IOUT
1141           IF (ISTHEP(IHEP+1).EQ.100) THEN
1142             JMOHEP(1,IHEP+1)=IOUT
1143             JMOHEP(2,IHEP+1)=IIN
1144           ENDIF
1145           DO 300 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1146             JMOHEP(1,JHEP)=IHEP
1147  300      CONTINUE
1148           IF (IDHW(IOUT).EQ.13) IDHW(IOUT)=IDHW(IOUT+1)
1149           IDHEP(IOUT)=IDPDG(IDHW(IOUT))
1150           IDHW(IHEP)=IDHW(IOUT)
1151           CALL HWUEDT(NDEL,IEDT)
1152         ELSEIF (ID.LT.7) THEN
1153           CALL HWVEQU(5,Q1,PHEP(1,IIN))
1154           CALL HWVEQU(5,Q2,PHEP(1,IOUT+1))
1155           JMOHEP(2,IIN)=IOUT+1
1156           JDAHEP(2,IIN)=IOUT+1
1157           JMOHEP(2,IOUT+1)=IIN
1158           JDAHEP(2,IOUT+1)=IIN
1159           JDAHEP(2,ICMF)=IOUT+1
1160           IHEP=JDAHEP(1,IIN)
1161           JHEP=JDAHEP(1,IOUT)
1162           CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1163           CALL HWUMAS(PHEP(1,IHEP))
1164           CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
1165           CALL HWUMAS(PHEP(1,ICMF))
1166           CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
1167      $         JDAHEP(1,JHEP),JDAHEP(2,IHEP))
1168           JHEP=JDAHEP(1,IOUT)
1169           JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
1170           IEDT(1)=IOUT
1171           IEDT(2)=JHEP
1172           IEDT(3)=JHEP+1
1173           NDEL=3
1174           IF (ISTHEP(JHEP+1).NE.100) NDEL=2
1175           CALL HWUEDT(NDEL,IEDT)
1176           IHEP=JDAHEP(1,IIN)
1177           DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1178             JMOHEP(1,JHEP)=IHEP
1179  400      CONTINUE
1180           IDHW(IIN)=ID
1181           IDHEP(IIN)=IDPDG(ID)
1182           IDHW(IHEP)=ID
1183         ELSE
1184           CALL HWVEQU(5,Q1,PHEP(1,IIN))
1185           CALL HWVEQU(5,Q2,PHEP(1,IOUT))
1186           JMOHEP(2,IIN)=IOUT
1187           JDAHEP(2,IIN)=IOUT
1188           JMOHEP(2,IOUT)=IIN
1189           JDAHEP(2,IOUT)=IIN
1190           JDAHEP(2,ICMF)=IOUT
1191           IHEP=JDAHEP(1,IIN)
1192           JHEP=JDAHEP(1,IOUT+1)
1193           CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1194           CALL HWUMAS(PHEP(1,IHEP))
1195           CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
1196           CALL HWUMAS(PHEP(1,ICMF))
1197           CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
1198      $         JDAHEP(1,JHEP),JDAHEP(1,IHEP)-1)
1199           JHEP=JDAHEP(1,IOUT+1)
1200           JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
1201           IEDT(1)=IOUT+1
1202           IEDT(2)=JHEP
1203           IEDT(3)=JHEP+1
1204           NDEL=3
1205           IF (ISTHEP(JHEP+1).NE.100.OR.JHEP.EQ.NHEP) NDEL=2
1206           CALL HWUEDT(NDEL,IEDT)
1207           IHEP=JDAHEP(1,IIN)
1208           DO 500 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1209             JMOHEP(1,JHEP)=IHEP
1210  500      CONTINUE
1211           IDHW(IIN)=ID
1212           IDHEP(IIN)=IDPDG(ID)
1213           IDHW(IHEP)=ID
1214         ENDIF
1215         CALL HWVZRO(4,VHEP(1,IIN))
1216         CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)))
1217         IF (ISTHEP(JDAHEP(1,IIN)+1).EQ.100)
1218      $       CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)+1))
1219         CALL HWVZRO(4,VHEP(1,IOUT))
1220         CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)))
1221         IF (ISTHEP(JDAHEP(1,IOUT)+1).EQ.100)
1222      $       CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)+1))
1223         EMIT=0
1224       ELSE
1225         CALL HWWARN('HWBDIS',500,*999)
1226       ENDIF
1227  999  END
1228 CDECK  ID>, HWBDYP.
1229 *CMZ :-        -26/10/99  17.46.56  by  Mike Seymour
1230 *-- Author :    Gennaro Corcella
1231 C-----------------------------------------------------------------------
1232       SUBROUTINE HWBDYP(IOPT)
1233 C     MATRIX ELEMENT CORRECTIONS TO DRELL-YAN PROCESSES
1234 C-----------------------------------------------------------------------
1235       INCLUDE 'HERWIG65.INC'
1236       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,PMODK,AZ,CZ,
1237      & T,U,S,EM,TMIN,TMAX,PMOD2,GLUFAC,SMIN,SMAX,SZ,TEST,
1238      & JAC,M(3),W1,W,PMOD3,SCAPR,CPHI,SPHI,SCALE,XI1,XI2,
1239      & PDFOLD1(13),PDFOLD2(13),PDFNEW1(13),PDFNEW2(13),ETA1,ETA2,Y,
1240      & COMWGT1,COMWGT2,WW,COS3,MODP,RN,BETA1,SIN3,R3(3,3),CTH,STH,M1,
1241      & M2,M3,GAMMA1,R5(3,3),CW,SW,R4(3,3),SCALE1,X1,X2,X3,MM,
1242      & PHAD1(5),PHAD2(5),P1(5),P2(5),P3(5),P4(5),PF(5),PV(5),PK(5),
1243      & PR(5),PNE(5),PE(5),PP1(5),PP2(5),PZ(5),PS(5),PD(5),P2N(5),
1244      & PBOS(5),PLAB(5),PTOT(5),P3N(5),SVNTN
1245       LOGICAL GLUIN,GP
1246       INTEGER EMIT,NOEMIT,IHEP,JHEP,KHEP,ICMF,IOPT,CHEP,
1247      & ID2,ID1,K,ID4,ID5,IDBOS,IHAD1,IHAD2,NTMP
1248       EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
1249       SAVE PS,PF,ICMF,ID4,ID5
1250       DATA EMIT,NTMP/2*0/
1251       IF (IOPT.EQ.1) THEN
1252         EMIT=0
1253         NTMP=0
1254 C-----CHOOSE WEIGHTS
1255         COMWGT1=0.1
1256         COMWGT2=0.55
1257 C---FIND AN UNTREATED CMF
1258         ICMF=0
1259         DO 10 IHEP=1,NHEP
1260  10     IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110.AND.
1261      &         JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
1262         IF (ICMF.EQ.0) RETURN
1263         EM=PHEP(5,ICMF)
1264 C-----SET THE VECTOR BOSON RAPIDITY
1265         Y=HALF*LOG((PHEP(4,ICMF)+PHEP(3,ICMF))/
1266      &       (PHEP(4,ICMF)-PHEP(3,ICMF)))
1267 C------SET PARTICLE IDENTIES
1268 c------ID1=QUARK, ID2=ANTIQUARK, IDBOS=VECTOR BOSON, ID4-5 BOSON DECAY
1269         IDBOS=IDHW(ICMF)
1270         ID1=IDHW(JMOHEP(1,ICMF))
1271         ID2=IDHW(JMOHEP(2,ICMF))
1272         ID4=IDHW(JDAHEP(1,ICMF))
1273         ID5=IDHW(JDAHEP(2,ICMF))
1274         M1=RMASS(ID1)
1275         M2=RMASS(ID2)
1276         M3=RMASS(13)
1277 C---STORE OLD MOMENTA
1278 C------VECTOR BOSON MOMENTUM
1279         CALL HWVEQU(5,PHEP(1,ICMF),PBOS)
1280 C----QUARK MOMENTUM
1281         CALL HWVEQU(5,PHEP(1,JMOHEP(1,ICMF)),P1)
1282 C------ANTIQUARK MOMENTUM
1283         CALL HWVEQU(5,PHEP(1,JMOHEP(2,ICMF)),P2)
1284 C-------VECTOR DECAY (LEPTON) PRODUCT MOMENTA
1285         CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P3)
1286         CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P4)
1287 C------LEPTON MOMENTA IN THE BOSON REST FRAME
1288         CALL HWULOF(PHEP(1,ICMF),P2,P2N)
1289         CALL HWULOF(PHEP(1,ICMF),P3,P3N)
1290 C------AZ=AZIMUTHAL ANGLE OF P3N
1291         AZ=ATAN2(P3N(2),P3N(1))
1292         CZ=COS(AZ)
1293         SZ=SIN(AZ)
1294 C------PHI=ANGLE BETWEEN P2N AND P3N
1295         SCAPR=P2N(1)*P3N(1)+P2N(2)*P3N(2)+P2N(3)*P3N(3)
1296         PMOD2=SQRT(P2N(1)**2+P2N(2)**2+P2N(3)**2)
1297         PMOD3=SQRT(P3N(1)**2+P3N(2)**2+P3N(3)**2)
1298         CPHI=SCAPR/(PMOD3*PMOD2)
1299         SPHI=SQRT(1-CPHI**2)
1300 C------HADRON MOMENTA
1301         IHAD1=1
1302         IHAD2=2
1303         IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
1304         IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
1305         CALL HWVEQU(5,PHEP(1,IHAD1),PHAD1)
1306         CALL HWVEQU(5,PHEP(1,IHAD2),PHAD2)
1307         CALL HWVSUM(4,PHAD1,PHAD2,PTOT)
1308         CALL HWUMAS(PTOT)
1309 C------ Q - QBAR ENERGY FRACTIONS (BORN PROCESS)
1310 c---minorimprovement---mhs---4/8/04---include mass effects correctly
1311         ETA1=(P1(4)+P1(3))/(PHAD1(4)+PHAD1(3))
1312         ETA2=(P2(4)-P2(3))/(PHAD2(4)-PHAD2(3))
1313 C------ PDFs FOR THE BORN PROCESS
1314         CALL HWSFUN(ETA1,EM,IDHW(IHAD1),NSTRU,PDFOLD1,1)
1315         CALL HWSFUN(ETA2,EM,IDHW(IHAD2),NSTRU,PDFOLD2,2)
1316 C-------CONSIDER Q(QBAR) IN THE INITIAL STATE
1317         RN=HWRGEN(9)
1318         IF (RN.LT.COMWGT1) THEN
1319 C-------NO GLUON IN THE INITIAL STATE
1320           GLUIN=.FALSE.
1321 C---CHOOSE S ACCORDING TO 1/S**2
1322           SVNTN=17
1323           SMIN=HALF*EM**2*(7-SQRT(SVNTN))
1324           SMAX=PTOT(5)**2
1325           IF (SMAX.LE.SMIN) RETURN
1326           S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
1327           JAC=S**2*(1/SMIN-1/SMAX)
1328 C---CHOOSE T ACCORDING TO (S-EM**2)/(T*U)=1/T+1/U
1329           TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
1330           TMIN=EM**2-S-TMAX
1331           IF (TMAX.LE.TMIN) RETURN
1332           T=TMAX*(TMIN/TMAX)**HWRGEN(1)
1333           IF (HWRGEN(2).GT.HALF) T=EM**2-S-T
1334           U=EM**2-S-T
1335           JAC=JAC*2*T*U/(S-EM**2)*LOG(TMIN/TMAX)
1336           SCALE=SQRT(U*T/S)
1337           SCALE1=SQRT(U*T/S+EM**2)
1338           GLUFAC=0
1339           IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
1340 C----Q-QBAR ENERGY FRACTIONS FOR Q QBAR-> VG
1341           XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
1342           XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1343 c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1344           IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
1345           IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN
1346 C-----PDFs WITH AN EMITTED GLUON
1347           CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1348           CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1349 C------CALCULATE WEIGHT
1350           W=JAC*((EM**2-T)**2+(EM**2-U)**2)/(S**2*T*U)
1351           W1=(GLUFAC/COMWGT1)*W*PDFNEW1(ID1)*PDFNEW2(ID2)/(PDFOLD1(ID1)*
1352      &         PDFOLD2(ID2))*(CFFAC*ETA1*ETA2/(XI1*XI2))
1353 C-------CHOOSE WHICH PARTON WILL EMIT
1354           EMIT=1
1355           IF (HWRGEN(6).LT.(EM**2-U)**2/((EM**2-U)**2+(EM**2-T)**2))
1356      &         EMIT=2
1357           NOEMIT=3-EMIT
1358         ELSE
1359 C--------GLUON IN THE INITIAL STATE
1360           GLUIN=.TRUE.
1361 C---CHOOSE S ACCORDING TO 1/S**2
1362           SMIN=EM**2
1363           SMAX=PTOT(5)**2
1364           IF (SMAX.LE.SMIN) RETURN
1365           S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
1366           JAC=S**2*(1/SMIN-1/SMAX)
1367 C---CHOOSE T ACCORDING TO 1/T
1368           TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
1369           TMIN=EM**2-S
1370           IF (TMAX.LE.TMIN) RETURN
1371           T=TMAX*(TMIN/TMAX)**HWRGEN(1)
1372           JAC=JAC*T*LOG(TMAX/TMIN)
1373           U=EM**2-S-T
1374           SCALE=SQRT(U*T/S)
1375           SCALE1=SQRT(U*T/S+EM**2)
1376           GLUFAC=0
1377           IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
1378 C--------INITIAL STATE GLUON COMING FROM HADRON 1
1379           IF (RN.LE.COMWGT2) THEN
1380             GP=.TRUE.
1381 C--------ENERGY FRACTIONS and PDFs
1382 c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
1383             XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
1384             XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1385 c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1386             IF ((1-XI1)*SCALE.LT.HWBVMC(13)) RETURN
1387             IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN
1388             CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1389             CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1390             WW=PDFNEW1(13)*PDFNEW2(ID2)/((COMWGT2-COMWGT1)*
1391      &           PDFOLD1(ID1)*PDFOLD2(ID2))
1392           ELSE
1393 C-------INITIAL STATE GLUON COMING FROM HADRON 2
1394             GP=.FALSE.
1395 C-------ENERGY FRACTIONS AND PDFs
1396 c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
1397             XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+U)/(S+T))
1398             XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1399 c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1400             IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
1401             IF ((1-XI2)*SCALE.LT.HWBVMC(13)) RETURN
1402             CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1403             CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1404             WW=PDFNEW1(ID1)*PDFNEW2(13)/((1-COMWGT2)*
1405      &           PDFOLD1(ID1)*PDFOLD2(ID2))
1406           ENDIF
1407           W=-HALF*JAC*((EM**2-T)**2+(EM**2-S)**2)/(S**3*T)
1408 C-------CHOOSE WHICH PARTON WILL EMIT
1409 c---bug fix---mhs---4/8/04---swap emitter and nonemitter
1410           EMIT=2
1411           IF (HWRGEN(10).LT.(EM**2-S)**2/((EM**2-S)**2+(EM**2-T)**2))
1412      &         EMIT=1
1413           NOEMIT=3-EMIT
1414 C-------FINAL WEIGHT FOR ALL THE CONSIDERED OPTIONS
1415           W1=GLUFAC*W*WW*ETA1*ETA2/(XI1*XI2)
1416         ENDIF
1417 C--------ADD ONE MORE GLUON
1418         IF (W1.GT.HWRGEN(4)) THEN
1419           NTMP=NEVHEP+NWGTS
1420         ELSE
1421           RETURN
1422         ENDIF
1423 C---------INCLUDE MASSES
1424         S=S+M1**2+M2**2+M3**2
1425         IF (.NOT.GLUIN) THEN
1426           TEST=((S+M1**2-M2**2)*(S+M3**2-EM**2)-2*S*(M1**2+M3**2-T))**2
1427      $         -((S-M1**2-M2**2)**2-4*M1**2*M2**2)*
1428      $         ((S-M3**2-EM**2)**2-4*M3**2*EM**2)
1429         ELSEIF (GP) THEN
1430           TEST=((S+M3**2-M2**2)*(S+M1**2-EM**2)-2*S*(M3**2+M1**2-T))**2
1431      $         -((S-M3**2-M2**2)**2-4*M3**2*M2**2)*
1432      $         ((S-M1**2-EM**2)**2-4*M1**2*EM**2)
1433         ELSE
1434           TEST=((S+M3**2-M1**2)*(S+M2**2-EM**2)-2*S*(M3**2+M2**2-T))**2
1435      $         -((S-M3**2-M1**2)**2-4*M3**2*M1**2)*
1436      $         ((S-M2**2-EM**2)**2-4*M2**2*EM**2)
1437         ENDIF
1438         IF (TEST.GE.0) THEN
1439           EMIT=0
1440           RETURN
1441         ENDIF
1442         M(1)=M1
1443         M(2)=M2
1444         M(3)=M3
1445 C----MOMENTA IN THE V-REST FRAME WITH NON EMITTER ALONG THE Z AXIS
1446 C----V=BOSON,K=GLUON,E=EMITTER,NE=NON-EMITTER
1447         PV(1)=0
1448         PV(2)=0
1449         PV(3)=0
1450         PV(4)=EM
1451         PV(5)=EM
1452         PNE(2)=0
1453         PNE(1)=0
1454         IF (.NOT.GLUIN) THEN
1455           PK(4)=(S-M(3)**2-EM**2)/(2*EM)
1456           PMODK=SQRT(PK(4)**2-M(3)**2)
1457           IF (EMIT.EQ.1) THEN
1458             MM=M(1)
1459             X1=T
1460             X2=U
1461             X3=-1
1462           ELSE
1463             MM=M(2)
1464             X1=U
1465             X2=T
1466             X3=+1
1467           ENDIF
1468           PNE(4)=(EM**2+MM**2-X1)/(2*EM)
1469           PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1470           COS3=HALF*(X2-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1471         ELSE
1472           PK(4)=(EM**2+M(3)**2-U)/(2*EM)
1473           PMODK=SQRT(PK(4)**2-M(3)**2)
1474           IF (EMIT.EQ.1) THEN
1475             IF (GP) THEN
1476               MM=M(1)
1477               X3=+1
1478             ELSE
1479               MM=M(2)
1480               X3=-1
1481             ENDIF
1482             PNE(4)=(S-MM**2-EM**2)/(2*EM)
1483             PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1484             COS3=HALF*(T-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1485           ELSE
1486             IF (GP) THEN
1487               MM=M(2)
1488               X3=-1
1489             ELSE
1490               MM=M(1)
1491               X3=+1
1492             ENDIF
1493             PNE(4)=(EM**2+MM**2-T)/(2*EM)
1494             PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1495             COS3=HALF*(MM**2+M(3)**2-S+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1496           ENDIF
1497         ENDIF
1498         CALL HWUMAS(PNE)
1499         SIN3=SQRT(1-COS3**2)
1500 C---------DEFINE A RANDOM ROTATION AROUND THE Z-AXIS
1501         CALL HWRAZM(PMODK*SIN3,PK(1),PK(2))
1502         PK(3)=PMODK*COS3
1503         CALL HWUMAS(PK)
1504         DO K=1,4
1505           IF (.NOT.GLUIN) THEN
1506             PE(K)=PV(K)+PK(K)-PNE(K)
1507           ELSE
1508             IF (EMIT.EQ.1) THEN
1509               PE(K)=PV(K)+PNE(K)-PK(K)
1510             ELSE
1511               PE(K)=PNE(K)+PK(K)-PV(K)
1512             ENDIF
1513           ENDIF
1514         ENDDO
1515         CALL HWUMAS(PE)
1516 c------LEPTON MOMENTA IN THE BOSON REST FRAME, WITH THE DIRECTION
1517 C------TAKEN FROM THE BORN PROCESS
1518         PS(5)=P3(5)
1519         PS(4)=(EM**2+P3(5)**2-P4(5)**2)/(2*EM)
1520         PS(3)=-SQRT(PS(4)**2-P3(5)**2)*CPHI
1521         PS(2)=SQRT(PS(4)**2-P3(5)**2)*SPHI*SZ
1522         PS(1)=SQRT(PS(4)**2-P3(5)**2)*SPHI*CZ
1523         PF(5)=P4(5)
1524         PF(4)=(EM**2+P4(5)**2-P3(5)**2)/(2*EM)
1525         PF(3)=-PS(3)
1526         PF(2)=-PS(2)
1527         PF(1)=-PS(1)
1528 C----FIND A STATIONARY VECTOR PLAB IN THE LAB FRAME
1529         IF (.NOT.GLUIN) THEN
1530           IF (EMIT.EQ.1) THEN
1531             CALL HWVEQU(5,PE,PP1)
1532             CALL HWVEQU(5,PNE,PP2)
1533           ELSE
1534             CALL HWVEQU(5,PNE,PP1)
1535             CALL HWVEQU(5,PE,PP2)
1536           ENDIF
1537         ELSE
1538           IF (GP) THEN
1539             CALL HWVEQU(5,PK,PP1)
1540             IF (EMIT.EQ.1) THEN
1541               CALL HWVEQU(5,PE,PP2)
1542             ELSE
1543               CALL HWVEQU(5,PNE,PP2)
1544             ENDIF
1545           ELSE
1546             CALL HWVEQU(5,PK,PP2)
1547             IF (EMIT.EQ.1) THEN
1548               CALL HWVEQU(5,PE,PP1)
1549             ELSE
1550               CALL HWVEQU(5,PNE,PP1)
1551             ENDIF
1552           ENDIF
1553         ENDIF
1554         CALL HWVSCA(4,1/XI1,PP1,PP1)
1555         CALL HWVSCA(4,1/XI2,PP2,PP2)
1556         CALL HWVSUM(4,PP1,PP2,PLAB)
1557         CALL HWUMAS(PLAB)
1558 C------BOOST TO PLAB REST FRAME
1559         CALL HWULOF(PLAB,PE,PE)
1560         CALL HWULOF(PLAB,PNE,PNE)
1561         CALL HWULOF(PLAB,PK,PK)
1562         CALL HWULOF(PLAB,PS,PS)
1563         CALL HWULOF(PLAB,PF,PF)
1564         CALL HWULOF(PLAB,PV,PV)
1565 C----PUT THE INITIAL PARTON BELONGING TO HADRON 1 ON THE Z-AXIS
1566         IF (.NOT.GLUIN) THEN
1567           IF (EMIT.EQ.1) THEN
1568             CALL HWVEQU(5,PE,PZ)
1569           ELSE
1570             CALL HWVEQU(5,PNE,PZ)
1571           ENDIF
1572         ELSE
1573           IF (GP) THEN
1574             CALL HWVEQU(5,PK,PZ)
1575           ELSE
1576             IF (EMIT.EQ.1) THEN
1577               CALL HWVEQU(5,PE,PZ)
1578             ELSE
1579               CALL HWVEQU(5,PNE,PZ)
1580             ENDIF
1581           ENDIF
1582         ENDIF
1583         MODP=SQRT(PZ(1)**2+PZ(2)**2)
1584         CTH=PZ(1)/MODP
1585         STH=PZ(2)/MODP
1586         CALL HWUROT(PZ,CTH,STH,R3)
1587 C-----ROTATE EVERYTHING BY R3
1588         CALL HWUROF(R3,PE,PE)
1589         CALL HWUROF(R3,PNE,PNE)
1590         CALL HWUROF(R3,PV,PV)
1591         CALL HWUROF(R3,PK,PK)
1592         CALL HWUROF(R3,PS,PS)
1593         CALL HWUROF(R3,PF,PF)
1594 C--REORDER ENTRIES:--IHEP=EMITTER,JHEP=NON-EMITTER,KHEP=EMITTED
1595         IF (.NOT.GLUIN) THEN
1596           IHEP=JMOHEP(EMIT,ICMF)
1597           JHEP=JMOHEP(NOEMIT,ICMF)
1598         ENDIF
1599         CHEP=ICMF
1600         IDHW(CHEP)=15
1601         IDHEP(CHEP)=IDPDG(15)
1602         ICMF=ICMF+1
1603         IDHW(ICMF)=IDBOS
1604         IDHEP(ICMF)=IDPDG(IDBOS)
1605 C-----NO GLUON IN THE INITIAL STATE: JUST ADD IT AFTER THE VECTOR BOSON
1606         IF (.NOT.GLUIN) THEN
1607           KHEP=ICMF+1
1608           ISTHEP(KHEP)=114
1609 C---STATUS OF EMITTER/NON EMITTER
1610           ISTHEP(IHEP)=110+EMIT
1611           ISTHEP(JHEP)=110+NOEMIT
1612         ELSE
1613 C-----GLUON COMING FROM THE 1ST HADRON
1614           IF (GP) THEN
1615             KHEP=CHEP-2
1616             ISTHEP(KHEP)=111
1617 C----EMIT=1
1618             IF (EMIT.EQ.1) THEN
1619               IHEP=KHEP+1
1620               ISTHEP(IHEP)=112
1621               JHEP=ICMF+1
1622               ISTHEP(JHEP)=114
1623               IDHW(IHEP)=ID2
1624               IF (ID1.LE.6) THEN
1625                 IDHW(JHEP)=ID1+6
1626               ELSE
1627                 IDHW(JHEP)=ID1-6
1628               ENDIF
1629             ELSE
1630 C-------EMIT=2
1631               JHEP=KHEP+1
1632               ISTHEP(JHEP)=112
1633               IDHW(JHEP)=ID2
1634               IHEP=ICMF+1
1635               ISTHEP(IHEP)=114
1636               IF (ID1.LE.6) THEN
1637                 IDHW(IHEP)=ID1+6
1638               ELSE
1639                 IDHW(IHEP)=ID1-6
1640               ENDIF
1641             ENDIF
1642           ENDIF
1643 C------GLUON COMING FROM THE HADRON 2
1644           IF (.NOT.GP) THEN
1645             KHEP=CHEP-1
1646             ISTHEP(KHEP)=112
1647 C-------EMIT=1
1648             IF (EMIT.EQ.1) THEN
1649               IHEP=KHEP-1
1650               ISTHEP(IHEP)=111
1651               IDHW(IHEP)=ID1
1652               JHEP=ICMF+1
1653               ISTHEP(JHEP)=114
1654               IF (ID2.LE.6) THEN
1655                 IDHW(JHEP)=ID2+6
1656               ELSE
1657                 IDHW(JHEP)=ID2-6
1658               ENDIF
1659             ELSE
1660 C-------EMIT=2
1661               JHEP=KHEP-1
1662               ISTHEP(JHEP)=111
1663               IDHW(JHEP)=ID1
1664               IHEP=ICMF+1
1665               ISTHEP(IHEP)=114
1666               IF (ID2.LE.6) THEN
1667                 IDHW(IHEP)=ID2+6
1668               ELSE
1669                 IDHW(IHEP)=ID2-6
1670               ENDIF
1671             ENDIF
1672           ENDIF
1673         ENDIF
1674         IDHEP(IHEP)=IDPDG(IDHW(IHEP))
1675         IDHEP(JHEP)=IDPDG(IDHW(JHEP))
1676         ISTHEP(ICMF)=113
1677         ISTHEP(CHEP)=110
1678         IDHW(KHEP)=13
1679         IDHEP(KHEP)=IDPDG(13)
1680 C---------DEFINE MOMENTA IN THE LAB FRAME
1681         CALL HWVEQU(5,PV,PHEP(1,ICMF))
1682         CALL HWVEQU(5,PK,PHEP(1,KHEP))
1683         CALL HWVEQU(5,PNE,PHEP(1,JHEP))
1684         CALL HWVEQU(5,PE,PHEP(1,IHEP))
1685         IF (.NOT.GLUIN) THEN
1686           CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,CHEP))
1687         ELSE
1688           IF (EMIT.EQ.1) THEN
1689             CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,CHEP))
1690           ELSE
1691             CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PHEP(1,CHEP))
1692           ENDIF
1693         ENDIF
1694         CALL HWUMAS(PHEP(1,CHEP))
1695         IF (.NOT.GLUIN) THEN
1696           JMOHEP(1,JHEP)=CHEP
1697           JMOHEP(1,IHEP)=CHEP
1698           JDAHEP(1,JHEP)=CHEP
1699           JDAHEP(1,IHEP)=CHEP
1700           JMOHEP(1,KHEP)=CHEP
1701           JDAHEP(1,KHEP)=0
1702           JMOHEP(1,ICMF)=CHEP
1703           JMOHEP(2,ICMF)=ICMF
1704           JDAHEP(1,ICMF)=0
1705           JDAHEP(2,ICMF)=ICMF
1706         ENDIF
1707         IF (GLUIN) THEN
1708           JMOHEP(2,ICMF)=ICMF
1709           JDAHEP(2,ICMF)=ICMF
1710           JMOHEP(1,KHEP)=CHEP
1711           JDAHEP(1,KHEP)=CHEP
1712           JMOHEP(1,IHEP)=CHEP
1713           JMOHEP(1,JHEP)=CHEP
1714           IF (EMIT.EQ.1) THEN
1715             JDAHEP(1,IHEP)=CHEP
1716             JDAHEP(1,JHEP)=0
1717           ELSE
1718             JDAHEP(1,JHEP)=CHEP
1719             JDAHEP(1,IHEP)=0
1720           ENDIF
1721         ENDIF
1722 C---COLOUR CONNECTIONS
1723         IF (.NOT.GLUIN) THEN
1724           IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
1725             JMOHEP(2,KHEP)=IHEP
1726             JDAHEP(2,KHEP)=JHEP
1727             JMOHEP(2,IHEP)=JHEP
1728             JDAHEP(2,IHEP)=KHEP
1729             JDAHEP(2,JHEP)=IHEP
1730             JMOHEP(2,JHEP)=KHEP
1731           ELSE
1732             JMOHEP(2,KHEP)=JHEP
1733             JDAHEP(2,KHEP)=IHEP
1734             JMOHEP(2,JHEP)=IHEP
1735             JDAHEP(2,JHEP)=KHEP
1736             JDAHEP(2,IHEP)=JHEP
1737             JMOHEP(2,IHEP)=KHEP
1738           ENDIF
1739         ENDIF
1740         IF (GLUIN) THEN
1741           IF (EMIT.EQ.1) THEN
1742             IF (IDHEP(IHEP).GT.0) THEN
1743               JMOHEP(2,IHEP)=JHEP
1744               JDAHEP(2,IHEP)=KHEP
1745               JMOHEP(2,JHEP)=KHEP
1746               JDAHEP(2,JHEP)=IHEP
1747               JMOHEP(2,KHEP)=IHEP
1748               JDAHEP(2,KHEP)=JHEP
1749             ELSE
1750               JMOHEP(2,IHEP)=KHEP
1751               JDAHEP(2,IHEP)=JHEP
1752               JMOHEP(2,JHEP)=IHEP
1753               JDAHEP(2,JHEP)=KHEP
1754               JMOHEP(2,KHEP)=JHEP
1755               JDAHEP(2,KHEP)=IHEP
1756             ENDIF
1757           ELSE
1758             IF (IDHEP(JHEP).GT.0) THEN
1759               JMOHEP(2,JHEP)=IHEP
1760               JDAHEP(2,JHEP)=KHEP
1761               JMOHEP(2,IHEP)=KHEP
1762               JDAHEP(2,IHEP)=JHEP
1763               JMOHEP(2,KHEP)=JHEP
1764               JDAHEP(2,KHEP)=IHEP
1765             ELSE
1766               JMOHEP(2,JHEP)=KHEP
1767               JDAHEP(2,JHEP)=IHEP
1768               JMOHEP(2,IHEP)=JHEP
1769               JDAHEP(2,IHEP)=KHEP
1770               JMOHEP(2,KHEP)=IHEP
1771               JDAHEP(2,KHEP)=JHEP
1772             ENDIF
1773           ENDIF
1774         ENDIF
1775         EMSCA=SQRT(EM**2+PHEP(1,ICMF)**2+PHEP(2,ICMF)**2)
1776 C--------SET STATUS AND LEPTON MOMENTA AFTER THE PARTON SHOWER
1777       ELSEIF (IOPT.EQ.2) THEN
1778         IF (EMIT.EQ.0.OR.NEVHEP+NWGTS.NE.NTMP) RETURN
1779         ISTHEP(JDAHEP(1,ICMF))=195
1780         IDHW(NHEP+1)=ID4
1781         IDHW(NHEP+2)=ID5
1782         IDHEP(NHEP+1)=IDPDG(ID4)
1783         IDHEP(NHEP+2)=IDPDG(ID5)
1784         ISTHEP(NHEP+1)=113
1785         ISTHEP(NHEP+2)=114
1786         CW=PHEP(3,ICMF)/SQRT(PHEP(1,ICMF)**2+PHEP(2,ICMF)**2+
1787      &       PHEP(3,ICMF)**2)
1788         SW=SQRT(1-CW**2)
1789         CALL HWUROT(PHEP(1,ICMF),CW,SW,R4)
1790         CALL HWUROF(R4,PHEP(1,ICMF),PR)
1791         PR(4)=PHEP(4,ICMF)
1792         CALL HWUMAS(PR)
1793         CALL HWUROF(R4,PS,PS)
1794         CALL HWUROF(R4,PF,PF)
1795         CALL HWUMAS(PS)
1796         CALL HWUMAS(PF)
1797         CALL HWUROT(PHEP(1,JDAHEP(1,ICMF)),CW,SW,R5)
1798         CALL HWUROF(R5,PHEP(1,JDAHEP(1,ICMF)),PD)
1799         PD(4)=PHEP(4,JDAHEP(1,ICMF))
1800         CALL HWUMAS(PD)
1801         BETA1=(PR(4)*PR(3)-SQRT(PR(4)**2*PD(3)**2-PR(3)**2*PD(3)**2+
1802      &       PD(3)**4))/(PD(3)**2+PR(4)**2)
1803         GAMMA1=1/SQRT(1-BETA1**2)
1804         PHEP(4,NHEP+1)=GAMMA1*PS(4)-BETA1*GAMMA1*PS(3)
1805         PHEP(3,NHEP+1)=-BETA1*GAMMA1*PS(4)+GAMMA1*PS(3)
1806         PHEP(4,NHEP+2)=GAMMA1*PF(4)-BETA1*GAMMA1*PF(3)
1807         PHEP(3,NHEP+2)=-BETA1*GAMMA1*PF(4)+GAMMA1*PF(3)
1808         PHEP(1,NHEP+1)=PS(1)
1809         PHEP(2,NHEP+1)=PS(2)
1810         PHEP(1,NHEP+2)=PF(1)
1811         PHEP(2,NHEP+2)=PF(2)
1812         CALL HWUMAS(PHEP(1,NHEP+1))
1813         CALL HWUMAS(PHEP(1,NHEP+2))
1814         CALL HWUROB(R5,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
1815         CALL HWUROB(R5,PHEP(1,NHEP+2),PHEP(1,NHEP+2))
1816         JDAHEP(1,JDAHEP(1,ICMF))=NHEP+1
1817         JDAHEP(2,JDAHEP(1,ICMF))=NHEP+2
1818         JMOHEP(1,NHEP+1)=JDAHEP(1,ICMF)
1819         JMOHEP(1,NHEP+2)=JDAHEP(1,ICMF)
1820         JMOHEP(2,NHEP+1)=NHEP+2
1821         JDAHEP(2,NHEP+1)=NHEP+2
1822         JMOHEP(2,NHEP+2)=NHEP+1
1823         JDAHEP(2,NHEP+2)=NHEP+1
1824 C--special for spin correlations(relabel in spin common block)
1825         IF(SYSPIN.AND.NSPN.NE.0) THEN
1826           IDSPN(2) = NHEP+1
1827           IDSPN(3) = NHEP+2
1828           ISNHEP(NHEP+1) = 2
1829           ISNHEP(NHEP+2) = 3
1830         ENDIF
1831         NHEP=NHEP+2
1832         EMIT=0
1833       ENDIF
1834       END
1835 CDECK  ID>, HWBFIN.
1836 *CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
1837 *-- Author :    Bryan Webber
1838 C-----------------------------------------------------------------------
1839       SUBROUTINE HWBFIN(IHEP)
1840 C-----------------------------------------------------------------------
1841 C     DELETES INTERNAL LINES FROM SHOWER, MAKES COLOUR CONNECTION INDEX
1842 C     AND COPIES INTO /HEPEVT/ IN COLOUR ORDER.
1843 C-----------------------------------------------------------------------
1844       INCLUDE 'HERWIG65.INC'
1845       INTEGER IHEP,ID,IJET,KHEP,IPAR,JPAR,NXPAR,IP,JP
1846       IF (IERROR.NE.0) RETURN
1847 C---SAVE VIRTUAL PARTON DATA
1848       NHEP=NHEP+1
1849       IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',100,*999)
1850       ID=IDPAR(2)
1851       IDHW(NHEP)=ID
1852       IDHEP(NHEP)=IDPDG(ID)
1853       ISTHEP(NHEP)=ISTHEP(IHEP)+20
1854       JMOHEP(1,NHEP)=IHEP
1855       JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
1856       JDAHEP(1,IHEP)=NHEP
1857       JDAHEP(1,NHEP)=0
1858       JDAHEP(2,NHEP)=0
1859       CALL HWVEQU(5,PPAR(1,2),PHEP(1,NHEP))
1860       CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
1861 C---FINISHED FOR SPECTATOR OR NON-PARTON JETS
1862       IF (ISTHEP(NHEP).GT.136) RETURN
1863       IF (ID.GT.13.AND.ID.LT.209 .AND. ID.NE.59) RETURN
1864       IF (ID.GT.220.AND.ABS(IDPDG(ID)).LT.1000000) RETURN
1865       IF (ID.GT.424.AND.ID.NE.449) RETURN
1866       IF (.NOT.TMPAR(2).AND.ID.EQ.59) RETURN
1867       IDHEP(NHEP)=94
1868       IJET=NHEP
1869       IF (NPAR.GT.2) THEN
1870 C---SAVE CONE DATA
1871         NHEP=NHEP+1
1872         IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',101,*999)
1873         IDHW(NHEP)=IDPAR(1)
1874         IDHEP(NHEP)=0
1875         ISTHEP(NHEP)=100
1876         JMOHEP(1,NHEP)=IHEP
1877         JMOHEP(2,NHEP)=JCOPAR(1,1)
1878         JDAHEP(1,NHEP)=0
1879         JDAHEP(2,NHEP)=0
1880         CALL HWVEQU(5,PPAR,PHEP(1,NHEP))
1881         CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
1882       ENDIF
1883       KHEP=NHEP
1884 C---START WITH ANTICOLOUR DAUGHTER OF HARDEST PARTON
1885       IPAR=2
1886       JPAR=JCOPAR(4,IPAR)
1887       NXPAR=NPAR/2
1888       DO 20 IP=1,NXPAR
1889       DO 10 JP=1,NXPAR
1890       IF (JPAR.EQ.0) GOTO 15
1891       IF (JCOPAR(2,JPAR).EQ.IPAR) THEN
1892         IPAR=JPAR
1893         JPAR=JCOPAR(4,IPAR)
1894       ELSE
1895         IPAR=JPAR
1896         JPAR=JCOPAR(1,IPAR)
1897       ENDIF
1898    10 CONTINUE
1899 C---COULDN'T FIND COLOUR PARTNER
1900       CALL HWWARN('HWBFIN',1,*999)
1901    15 JPAR=JCOPAR(1,IPAR)
1902       KHEP=KHEP+1
1903       IF(KHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',102,*999)
1904       ID=IDPAR(IPAR)
1905       IF (TMPAR(IPAR)) THEN
1906         IF (ID.LT.14) THEN
1907           ISTHEP(KHEP)=139
1908         ELSEIF (ID.EQ.59) THEN
1909           ISTHEP(KHEP)=139
1910         ELSEIF (ID.LT.109) THEN
1911           ISTHEP(KHEP)=130
1912         ELSEIF (ID.LT.120) THEN
1913           ISTHEP(KHEP)=139
1914         ELSEIF (ABS(IDPDG(ID)).LT.1000000) THEN
1915           ISTHEP(KHEP)=130
1916         ELSEIF (ID.LT.425) THEN
1917           ISTHEP(KHEP)=139
1918         ELSEIF (ID.EQ.449) THEN
1919           ISTHEP(KHEP)=139
1920         ELSE
1921           ISTHEP(KHEP)=130
1922         ENDIF
1923       ELSE
1924         ISTHEP(KHEP)=ISTHEP(IHEP)+24
1925       ENDIF
1926       IDHW(KHEP)=ID
1927       IDHEP(KHEP)=IDPDG(ID)
1928       CALL HWVEQU(5,PPAR(1,IPAR),PHEP(1,KHEP))
1929       CALL HWVEQU(4,VPAR(1,IPAR),VHEP(1,KHEP))
1930       JMOHEP(1,KHEP)=IJET
1931       JMOHEP(2,KHEP)=KHEP+1
1932       JDAHEP(1,KHEP)=0
1933       JDAHEP(2,KHEP)=KHEP-1
1934    20 CONTINUE
1935       JMOHEP(2,KHEP)=0
1936       JDAHEP(2,NHEP+1)=0
1937       JDAHEP(1,IJET)=NHEP+1
1938       JDAHEP(2,IJET)=KHEP
1939       NHEP=KHEP
1940   999 END
1941 CDECK  ID>, HWBGEN.
1942 *CMZ :-        -14/10/99  18.04.56  by  Mike Seymour
1943 *-- Author :    Bryan Webber
1944 C-----------------------------------------------------------------------
1945       SUBROUTINE HWBGEN
1946 C-----------------------------------------------------------------------
1947 C     BRANCHING GENERATOR WITH INTERFERING GLUONS
1948 C     HWBGEN EVOLVES QCD JETS ACCORDING TO THE METHOD OF
1949 C     G.MARCHESINI & B.R.WEBBER, NUCL. PHYS. B238(1984)1
1950 C-----------------------------------------------------------------------
1951       INCLUDE 'HERWIG65.INC'
1952       DOUBLE PRECISION HWULDO,HWRGAU,EINHEP,ERTXI,RTXI,XF
1953       INTEGER NTRY,LASHEP,IHEP,NRHEP,ID,IST,JHEP,KPAR,I,J,IRHEP(NMXJET),
1954      & IRST(NMXJET),JPR
1955       LOGICAL HWRLOG
1956       EXTERNAL HWULDO,HWRGAU
1957       IF (IERROR.NE.0) RETURN
1958       IF (IPRO.EQ.80) RETURN
1959 C---CHECK THAT EMSCA IS SET
1960       IF (EMSCA.LE.ZERO) CALL HWWARN('HWBGEN',200,*999)
1961       IF (HARDME) THEN
1962 C---FORCE A BRANCH INTO THE `DEAD ZONE' IN E+E-
1963         JPR=IPROC/10
1964 C**********13/11/00 BRW FIX TO ALLOW ALSO WW AND ZZ
1965         IF (JPR.EQ.10.OR.JPR.EQ.20.OR.JPR.EQ.25) CALL HWBDED(1)
1966 C**********END FIX
1967 C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DIS
1968         IF (IPRO.EQ.90) CALL HWBDIS(1)
1969 C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DRELL-YAN PROCESSES
1970         IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(1)
1971 C---FORCE A BRANCH INTO THE `DEAD ZONE' IN TOP DECAYS
1972         CALL HWBTOP
1973       ENDIF
1974 C---GENERATE INTRINSIC PT ONCE AND FOR ALL
1975       DO 5 JNHAD=1,2
1976         IF (PTRMS.NE.0.) THEN
1977           PTINT(1,JNHAD)=HWRGAU(1,ZERO,PXRMS)
1978           PTINT(2,JNHAD)=HWRGAU(2,ZERO,PXRMS)
1979           PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
1980         ELSE
1981           CALL HWVZRO(3,PTINT(1,JNHAD))
1982         ENDIF
1983  5    CONTINUE
1984       NTRY=0
1985       LASHEP=NHEP
1986  10   NTRY=NTRY+1
1987       IF (NTRY.GT.NETRY) CALL HWWARN('HWBGEN',ISLENT*100,*999)
1988       NRHEP=0
1989       NHEP=LASHEP
1990       FROST=.FALSE.
1991       DO 100 IHEP=1,LASHEP
1992       IST=ISTHEP(IHEP)
1993       IF (IST.GE.111.AND.IST.LE.115) THEN
1994        NRHEP=NRHEP+1
1995        IRHEP(NRHEP)=IHEP
1996        IRST(NRHEP)=IST
1997        ID=IDHW(IHEP)
1998        IF (IST.NE.115) THEN
1999 C---FOUND A PARTON TO EVOLVE
2000         NEVPAR=IHEP
2001         NPAR=2
2002         IDPAR(1)=17
2003         IDPAR(2)=ID
2004         TMPAR(1)=.TRUE.
2005         PPAR(2,1)=0.
2006         PPAR(4,1)=1.
2007         DO 15 J=1,2
2008         DO 15 I=1,2
2009         JMOPAR(I,J)=0
2010  15     JCOPAR(I,J)=0
2011 C---SET UP EVOLUTION SCALE AND FRAME
2012         JHEP=JMOHEP(2,IHEP)
2013         IF (ID.EQ.13) THEN
2014           IF (HWRLOG(HALF)) JHEP=JDAHEP(2,IHEP)
2015         ELSEIF (IST.GT.112) THEN
2016           IF ((ID.GT.6.AND.ID.LT.13).OR.
2017      &        (ID.GT.214.AND.ID.LT.221)) JHEP=JDAHEP(2,IHEP)
2018         ELSE
2019           IF (ID.LT.7.OR.(ID.GT.208.AND.ID.LT.215)) JHEP=JDAHEP(2,IHEP)
2020         ENDIF
2021         IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN
2022           CALL HWWARN('HWBGEN',1,*999)
2023           JHEP=IHEP
2024         ENDIF
2025         JCOPAR(1,1)=JHEP
2026         EINHEP=PHEP(4,IHEP)
2027         ERTXI=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
2028         IF (ERTXI.LT.ZERO) ERTXI=0.
2029         IF (IST.LE.112.AND.IHEP.EQ.JHEP) ERTXI=0.
2030         IF (ISTHEP(JHEP).EQ.155) THEN
2031           ERTXI=ERTXI/PHEP(5,JHEP)
2032           RTXI=1.
2033         ELSE
2034           ERTXI=SQRT(ERTXI)
2035           RTXI=ERTXI/EINHEP
2036         ENDIF
2037         IF (RTXI.EQ.ZERO) THEN
2038           XF=1.
2039           PPAR(1,1)=0.
2040           PPAR(3,1)=1.
2041           PPAR(1,2)=EINHEP
2042           PPAR(2,2)=0.
2043           PPAR(4,2)=EINHEP
2044         ELSE
2045           XF=1./RTXI
2046           PPAR(1,1)=1.
2047           PPAR(3,1)=0.
2048           PPAR(1,2)=ERTXI
2049           PPAR(2,2)=1.
2050           PPAR(4,2)=ERTXI
2051         ENDIF
2052         IF (PPAR(4,2).LT.PHEP(5,IHEP)) PPAR(4,2)=PHEP(5,IHEP)
2053 C---STORE MASS
2054         PPAR(5,2)=PHEP(5,IHEP)
2055         CALL HWVZRO(4,VPAR(1,1))
2056         CALL HWVZRO(4,VPAR(1,2))
2057         IF (IST.GT.112) THEN
2058           TMPAR(2)=.TRUE.
2059           INHAD=0
2060           JNHAD=0
2061           XFACT=0.
2062         ELSE
2063           TMPAR(2)=.FALSE.
2064           JNHAD=IST-110
2065           INHAD=JNHAD
2066           IF (JDAHEP(1,JNHAD).NE.0) INHAD=JDAHEP(1,JNHAD)
2067           XFACT=XF/PHEP(4,INHAD)
2068           ANOMSC(1,JNHAD)=ZERO
2069           ANOMSC(2,JNHAD)=ZERO
2070         ENDIF
2071 C---FOR QUARKS IN A COLOUR SINGLET, ALLOW SOFT MATRIX-ELEMENT CORRECTION
2072         HARDST=PPAR(4,2)
2073         IF (SOFTME.AND.IDHW(IHEP).LT.13.AND.
2074      $       ((JMOHEP(2,JHEP).EQ.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP).OR.
2075      $       ISTHEP(JHEP).EQ.155)) HARDST=0
2076 C---CREATE BRANCHES AND COMPUTE ENERGIES
2077         DO 20 KPAR=2,NMXPAR
2078         IF (TMPAR(KPAR)) THEN
2079           CALL HWBRAN(KPAR)
2080         ELSE
2081           CALL HWSBRN(KPAR)
2082         ENDIF
2083         IF (IERROR.NE.0) RETURN
2084         IF (FROST) GOTO 100
2085         IF (KPAR.EQ.NPAR) GOTO 30
2086  20     CONTINUE
2087 C---COMPUTE MASSES AND 3-MOMENTA
2088  30     CONTINUE
2089         CALL HWBMAS
2090         IF (AZSPIN) CALL HWBSPN
2091         IF (TMPAR(2)) THEN
2092            CALL HWBTIM(2,1)
2093         ELSE
2094            CALL HWBSPA
2095         ENDIF
2096 C---ENTER PARTON JET IN /HEPEVT/
2097         CALL HWBFIN(IHEP)
2098        ELSE
2099 C---COPY SPECTATOR
2100         NHEP=NHEP+1
2101         IF (ID.GT.120.AND.ID.LT.133 .OR. ID.GE.198.AND.ID.LE.201) THEN
2102           ISTHEP(NHEP)=190
2103         ELSE
2104           ISTHEP(NHEP)=152
2105         ENDIF
2106         IDHW(NHEP)=ID
2107         IDHEP(NHEP)=IDPDG(ID)
2108         JMOHEP(1,NHEP)=IHEP
2109         JMOHEP(2,NHEP)=0
2110         JDAHEP(2,NHEP)=0
2111         JDAHEP(1,IHEP)=NHEP
2112         CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
2113        ENDIF
2114        ISTHEP(IHEP)=ISTHEP(IHEP)+10
2115       ENDIF
2116  100  CONTINUE
2117       IF (.NOT.FROST) THEN
2118 C---COMBINE JETS
2119         ISTAT=20
2120         CALL HWBJCO
2121       ENDIF
2122       IF (.NOT.FROST) THEN
2123 C---ATTACH SPECTATORS
2124         ISTAT=30
2125         CALL HWSSPC
2126       ENDIF
2127       IF (FROST) THEN
2128 C---BAD JET: RESTORE PARTONS AND RE-EVOLVE
2129          DO 120 I=1,NRHEP
2130  120     ISTHEP(IRHEP(I))=IRST(I)
2131          GOTO 10
2132       ENDIF
2133 C---CONNECT COLOURS
2134       CALL HWBCON
2135       ISTAT=40
2136       LASHEP=NHEP
2137       IF (HARDME) THEN
2138 C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN E+E-
2139         IF (IPROC/10.EQ.10) CALL HWBDED(2)
2140 C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DIS
2141         IF (IPRO.EQ.90) CALL HWBDIS(2)
2142 C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DRELL-YAN PROC
2143         IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(2)
2144       ENDIF
2145 C---IF THE CLEAN-UP OPERATION ADDED ANY PARTONS TO THE EVENT RECORD
2146 C   IT MIGHT NEED RESHOWERING
2147       IF (NHEP.GT.LASHEP) THEN
2148         LASHEP=NHEP
2149         GOTO 10
2150       ENDIF
2151  999  END
2152 CDECK  ID>, HWBGUP.
2153 *CMZ :-        -16/07/02  09.40.25  by  Peter Richardson
2154 *-- Author :    Peter Richardson
2155 C----------------------------------------------------------------------
2156       SUBROUTINE HWBGUP(ISTART,ICMF)
2157 C----------------------------------------------------------------------
2158 C     Makes the colour connections and performs the parton shower
2159 C     for events read in from the GUPI (Generic User Process Interface)
2160 C     event common block
2161 C----------------------------------------------------------------------
2162       INCLUDE 'HERWIG65.INC'
2163       INTEGER MAXNUP
2164       PARAMETER (MAXNUP=500)
2165       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
2166       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
2167       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
2168      &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
2169      &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
2170      &              SPINUP(MAXNUP)
2171 C--Local variables
2172       INTEGER ISTART,ICMF,J,K,I,JCOL,ICOL
2173       LOGICAL FOUND
2174       COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
2175       INTEGER ILOC,JLOC
2176 C--now we need to do the colour connections
2177  20   ISTART = ISTART+1
2178       IF(ISTART.GT.NHEP) GOTO 30
2179       IF(ISTART.EQ.ICMF) ISTART = ISTART+1
2180       IF(JMOHEP(2,ISTART).NE.0.AND.JDAHEP(2,ISTART).NE.0) GOTO 20
2181       K = ISTART
2182       J = ILOC(K)
2183       IF(ICOLUP(1,J).NE.0) THEN
2184         JCOL = 1
2185         ICOL = ICOLUP(1,J)
2186       ELSE
2187         JCOL = 2
2188         ICOL = ICOLUP(2,J)
2189       ENDIF
2190       IF(ICOL.EQ.0) THEN
2191         JMOHEP(2,K) = K
2192         JDAHEP(2,K) = K
2193         GOTO 20
2194       ENDIF
2195 C--now search for the partner
2196 C--first search for the flavour partner if not looking for colour partner
2197 C--search for the flavour partner of the particle
2198 C--this must be set or HERWIG won't work
2199  10   IF(JDAHEP(2,K).NE.0.AND.JMOHEP(2,K).NE.0) GOTO 20
2200       IF(ICOL.EQ.0) THEN
2201         FOUND = .FALSE.
2202 C--look for unpaired particle
2203         DO 15 I=1,NUP
2204           IF(JLOC(I).EQ.0) GOTO 15
2205           IF(IDUP(I).EQ.21.OR.IDUP(I).EQ.9) GOTO 15
2206           IF(JLOC(I).EQ.ISTART) GOTO 15
2207           IF(ICOLUP(1,I).EQ.0.AND.ICOLUP(2,I).EQ.0) GOTO 15
2208 C--antiflavour partner
2209           IF(JDAHEP(2,JLOC(I)).EQ.0) THEN
2210 C--pair incoming     particle with outgoing     particle
2211 C-- or  outgoing antiparticle with outgoing     particle
2212             IF(ISTUP(I).GT.0.AND.IDUP(I).GT.0.AND.
2213      &         ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
2214      &          (IDUP(J).LT.0.AND.ISTUP(J).GT.0 )))  THEN
2215               FOUND = .TRUE.
2216               JCOL = 1
2217 C--pair incoming     particle with incoming antiparticle
2218 C-- or  outgoing antiparticle with incoming antiparticle
2219             ELSEIF(IDUP(I).LT.0.AND.ISTUP(I).EQ.-1.AND.
2220      &             ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
2221      &              (IDUP(J).LT.0.AND.ISTUP(J).GT.0 ))) THEN
2222               FOUND = .TRUE.
2223               JCOL = 2
2224             ENDIF
2225 C--make the connection
2226             IF(FOUND) THEN
2227               JMOHEP(2,K)       = JLOC(I)
2228               JDAHEP(2,JLOC(I)) = K
2229             ENDIF
2230           ENDIF
2231 C--flavour partner
2232           IF(JMOHEP(2,JLOC(I)).EQ.0.AND.(.NOT.FOUND)) THEN
2233 C--pair incoming antiparticle with outgoing antiparticle
2234 C-- or  outgoing     particle with outgoing antiparticle
2235             IF(IDUP(I).LT.0.AND.ISTUP(I).GT.0.AND.
2236      &         ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
2237      &          (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
2238               FOUND = .TRUE.
2239               JCOL = 2
2240 C--pair incoming antiparticle with incoming     particle
2241 C-- or  outgoing     particle with incoming     particle
2242             ELSEIF(IDUP(I).GT.0.AND.ISTUP(I).EQ.-1.AND.
2243      &             ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
2244      &              (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
2245               FOUND = .TRUE.
2246               JCOL = 1
2247             ENDIF
2248 C--make the connection
2249             IF(FOUND) THEN
2250               JDAHEP(2,K) = JLOC(I)
2251               JMOHEP(2,JLOC(I)) = K
2252             ENDIF
2253           ENDIF
2254 C--set up the search for the next partner
2255           IF(FOUND) THEN
2256             FOUND = .FALSE.
2257             ICOL = ICOLUP(JCOL,I)
2258             K = JLOC(I)
2259             J = I
2260             GOTO 10
2261           ENDIF
2262  15     CONTINUE
2263 C--if no other choice then connect to the first particle in the loop
2264         IF(JDAHEP(2,K).EQ.0.AND.JMOHEP(2,ISTART).EQ.0) THEN
2265            JDAHEP(2,K) = ISTART
2266            JMOHEP(2,ISTART) = K
2267         ELSEIF(JDAHEP(2,ISTART).EQ.0.AND.JMOHEP(2,K).EQ.0) THEN
2268            JMOHEP(2,K) = ISTART
2269            JDAHEP(2,ISTART) = K
2270         ELSE
2271           CALL HWWARN('HWBGUP',100,*999)
2272         ENDIF
2273         GOTO 20
2274       ENDIF
2275 C--now the bit to find colour partners
2276       FOUND = .FALSE.
2277 C--special for particle from a decaying coloured particle
2278       IF(MOTHUP(1,J).NE.0) THEN
2279         IF(ISTUP(MOTHUP(1,J)).EQ.2.OR.ISTUP(MOTHUP(1,J)).EQ.3) THEN
2280           IF(IDUP(J).LT.0.AND.ICOL.EQ.ICOLUP(2,MOTHUP(1,J))) THEN
2281             JDAHEP(2,K) = JLOC(MOTHUP(1,J))
2282             JMOHEP(2,K) = JLOC(MOTHUP(1,J))
2283             GOTO 20
2284           ELSEIF(IDUP(J).GT.0.AND.ICOL.EQ.ICOLUP(1,MOTHUP(1,J))) THEN
2285             JDAHEP(2,K) = JLOC(MOTHUP(1,J))
2286             JMOHEP(2,K) = JLOC(MOTHUP(1,J))
2287             GOTO 20
2288           ENDIF
2289         ENDIF
2290       ENDIF
2291 C--search for the partner
2292       DO I=1,NUP
2293         IF(ICOLUP(1,I).EQ.ICOL.AND.I.NE.J) THEN
2294           IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GT.0).OR.
2295      &       (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).GE.0)) THEN
2296             JDAHEP(2,K)       = JLOC(I)
2297             JMOHEP(2,JLOC(I)) = K
2298             FOUND = .TRUE.
2299           ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1).OR.
2300      &          (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1)) THEN
2301             JMOHEP(2,K)       = JLOC(I)
2302             JDAHEP(2,JLOC(I)) = K
2303             FOUND = .TRUE.
2304           ENDIF
2305           IF(FOUND) JCOL = 2
2306         ELSEIF(ICOLUP(2,I).EQ.ICOL.AND.I.NE.J) THEN
2307           IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1).OR.
2308      &       (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1)) THEN
2309             JDAHEP(2,K) = JLOC(I)
2310             JMOHEP(2,JLOC(I)) = K
2311             FOUND = .TRUE.
2312           ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GE.0.AND.ISTUP(I).GE.0).OR.
2313      &           (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GE.0)) THEN
2314             JMOHEP(2,K) = JLOC(I)
2315             JDAHEP(2,JLOC(I)) = K
2316             FOUND = .TRUE.
2317           ENDIF
2318           IF(FOUND) JCOL = 1
2319         ENDIF
2320         IF(FOUND) THEN
2321           K = JLOC(I)
2322           J = I
2323           ICOL = ICOLUP(JCOL,I)
2324           GOTO 10
2325         ENDIF
2326       ENDDO
2327 C--special for self connected gluons
2328       IF(IDUP(J).EQ.21.OR.IDUP(J).EQ.9.AND.
2329      &     ICOLUP(1,J).EQ.ICOLUP(2,J)) THEN
2330         JMOHEP(2,K) = K
2331         JDAHEP(2,K) = K
2332 C--options for self connected gluons
2333         IF(LHGLSF) THEN
2334           CALL HWWARN('HWBGUP',1,*20)
2335         ELSE
2336           CALL HWWARN('HWBGUP',101,*999)
2337         ENDIF
2338         GOTO 20
2339       ENDIF
2340 C--perform the shower
2341  30   CALL HWBGEN
2342  999  END
2343 CDECK  ID>, HWBJCO.
2344 *CMZ :-        -30/09/02  09.19.58  by  Peter Richardson
2345 *-- Author :    Bryan Webber
2346 C-----------------------------------------------------------------------
2347       SUBROUTINE HWBJCO
2348 C-----------------------------------------------------------------------
2349 C     COMBINES JETS WITH REQUIRED KINEMATICS
2350 C-----------------------------------------------------------------------
2351       INCLUDE 'HERWIG65.INC'
2352       DOUBLE PRECISION HWULDO,EPS,PTX,PTY,PF,PTINF,PTCON,CN,CP,SP,PP0,
2353      & PM0,ET0,DET,ECM,EMJ,EMP,EMS,DMS,ES,DPF,ALF,AL(2),ET(2),PP(2),
2354      & PT(3),PA(5),PB(5),PC(5),PQ(5),PR(5),PS(5),RR(3,3),RS(3,3),ETC,
2355      & PJ(NMXJET),PM(NMXJET),PBR(5),RBR(3,3),DISP(4),PLAB(5)
2356       INTEGER LJET,IJ1,IST,IP,ICM,IP1,IP2,NP,IHEP,MHEP,JP,KP,LP,KHEP,
2357      & JHEP,NE,IJT,IEND(2),IJET(NMXJET),IPAR(NMXJET)
2358       LOGICAL AZCOR,JETRAD,DISPRO,DISLOW
2359       EXTERNAL HWULDO
2360       PARAMETER (EPS=1.D-4)
2361       IF (IERROR.NE.0) RETURN
2362       AZCOR=AZSOFT.OR.AZSPIN
2363       LJET=131
2364   10  IJET(1)=1
2365   20  IJ1=IJET(1)
2366       DO 40 IHEP=IJ1,NHEP
2367       IST=ISTHEP(IHEP)
2368       IF (IST.EQ.137.OR.IST.EQ.138) IST=133
2369       IF (IST.EQ.LJET) THEN
2370 C---FOUND AN UNBOOSTED JET - FIND PARTNERS
2371         IP=JMOHEP(1,IHEP)
2372         ICM=JMOHEP(1,IP)
2373         DISPRO=IPRO/10.EQ.9.AND.IDHW(ICM).EQ.15
2374         DISLOW=DISPRO.AND.JDAHEP(1,ICM).EQ.JDAHEP(2,ICM)-1
2375         IF (IST.EQ.131) THEN
2376           IP1=JMOHEP(1,ICM)
2377           IP2=JMOHEP(2,ICM)
2378         ELSE
2379           IP1=JDAHEP(1,ICM)
2380           IP2=JDAHEP(2,ICM)
2381         ENDIF
2382         IF (IP1.NE.IP) CALL HWWARN('HWBJCO',100,*999)
2383         NP=0
2384         DO 30 JHEP=IP1,IP2
2385         NP=NP+1
2386         IPAR(NP)=JHEP
2387   30    IJET(NP)=JDAHEP(1,JHEP)
2388         GOTO 50
2389       ENDIF
2390   40  CONTINUE
2391 C---NO MORE JETS?
2392       IF (LJET.EQ.131) THEN
2393         LJET=133
2394         GOTO 10
2395       ENDIF
2396       RETURN
2397   50  IF (LJET.EQ.131) THEN
2398 C---SPACELIKE JETS: FIND SPACELIKE PARTONS
2399         IF (NP.NE.2) CALL HWWARN('HWBJCO',103,*999)
2400 C---special for DIS: FIND BOOST AND ROTATION FROM LAB TO BREIT FRAME
2401         IF (DISPRO.AND.BREIT) THEN
2402           IP=2
2403           IF (JDAHEP(1,IP).NE.0) IP=JDAHEP(1,IP)
2404           CALL HWVDIF(4,PHEP(1,JMOHEP(1,ICM)),PHEP(1,JDAHEP(1,ICM)),PB)
2405           CALL HWUMAS(PB)
2406 C---IF Q**2<10**-2, SOMETHING MUST HAVE ALREADY GONE WRONG
2407           IF (PB(5)**2.LT.1.D-2) CALL HWWARN('HWBJCO',102,*999)
2408           CALL HWVSCA(4,PB(5)**2/HWULDO(PHEP(1,IP),PB),PHEP(1,IP),PBR)
2409           CALL HWVSUM(4,PB,PBR,PBR)
2410           CALL HWUMAS(PBR)
2411           CALL HWULOF(PBR,PB,PB)
2412           CALL HWUROT(PB,ONE,ZERO,RBR)
2413         ENDIF
2414         PTX=0.
2415         PTY=0.
2416         PF=1.D0
2417         DO 90 IP=1,2
2418         MHEP=IJET(IP)
2419         IF (JDAHEP(1,MHEP).EQ.0) THEN
2420 C---SPECIAL FOR NON-PARTON JETS
2421           IHEP=MHEP
2422           GOTO 70
2423         ELSE
2424           IST=134+IP
2425           DO 60 IHEP=MHEP,NHEP
2426   60      IF (ISTHEP(IHEP).EQ.IST) GOTO 70
2427 C---COULDN'T FIND SPACELIKE PARTON
2428           CALL HWWARN('HWBJCO',101,*999)
2429         ENDIF
2430   70    CALL HWVSCA(3,PF,PHEP(1,IHEP),PS)
2431         IF (PTINT(3,IP).GT.ZERO) THEN
2432 C---ADD INTRINSIC PT
2433           PT(1)=PTINT(1,IP)
2434           PT(2)=PTINT(2,IP)
2435           PT(3)=0.
2436           CALL HWUROT(PS, ONE,ZERO,RS)
2437           CALL HWUROB(RS,PT,PT)
2438           CALL HWVSUM(3,PS,PT,PS)
2439         ENDIF
2440         JP=IJET(IP)+1
2441         IF (AZCOR.AND.JP.LE.NHEP.AND.IDHW(JP).EQ.17) THEN
2442 C---ALIGN CONE WITH INTERFERING PARTON
2443           CALL HWUROT(PS, ONE,ZERO,RS)
2444           CALL HWUROF(RS,PHEP(1,JP),PR)
2445           PTCON=PR(1)**2+PR(2)**2
2446           KP=JMOHEP(2,JP)
2447           IF (KP.EQ.0) THEN
2448             CALL HWWARN('HWBJCO',1,*999)
2449             PTINF=0.
2450           ELSE
2451             CALL HWVEQU(4,PHEP(1,KP),PB)
2452             IF (DISPRO.AND.BREIT) THEN
2453               CALL HWULOF(PBR,PB,PB)
2454               CALL HWUROF(RBR,PB,PB)
2455             ENDIF
2456             PTINF=PB(1)**2+PB(2)**2
2457             IF (PTINF.LT.EPS) THEN
2458 C---COLLINEAR JETS: ALIGN CONES
2459               KP=JDAHEP(1,KP)+1
2460               IF (ISTHEP(KP).EQ.100.AND.(ISTHEP(KP-1)+9)/10.EQ.14) THEN
2461                 CALL HWVEQU(4,PHEP(1,KP),PB)
2462                 IF (DISPRO.AND.BREIT) THEN
2463                   CALL HWULOF(PBR,PB,PB)
2464                   CALL HWUROF(RBR,PB,PB)
2465                 ENDIF
2466                 PTINF=PB(1)**2+PB(2)**2
2467               ELSE
2468                 PTINF=0.
2469               ENDIF
2470             ENDIF
2471           ENDIF
2472           IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
2473             CN=1./SQRT(PTINF*PTCON)
2474             CP=CN*(PR(1)*PB(1)+PR(2)*PB(2))
2475             SP=CN*(PR(1)*PB(2)-PR(2)*PB(1))
2476           ELSE
2477             CALL HWRAZM( ONE,CP,SP)
2478           ENDIF
2479         ELSE
2480           CALL HWRAZM( ONE,CP,SP)
2481         ENDIF
2482 C---ROTATE SO SPACELIKE IS ALONG AXIS (APART FROM INTRINSIC PT)
2483         CALL HWUROT(PS,CP,SP,RS)
2484         IHEP=IJET(IP)
2485         KHEP=JDAHEP(2,IHEP)
2486         IF (KHEP.LT.IHEP) KHEP=IHEP
2487         IEND(IP)=KHEP
2488         DO 80 JHEP=IHEP,KHEP
2489         CALL HWUROF(RS,PHEP(1,JHEP),PHEP(1,JHEP))
2490   80    CALL HWUROF(RS,VHEP(1,JHEP),VHEP(1,JHEP))
2491         PP(IP)=PHEP(4,IHEP)+PF*PHEP(3,IHEP)
2492         ET(IP)=PHEP(1,IHEP)**2+PHEP(2,IHEP)**2-PHEP(5,IHEP)**2
2493 C---REDEFINE HARD CM
2494         PTX=PTX+PHEP(1,IHEP)
2495         PTY=PTY+PHEP(2,IHEP)
2496   90    PF=-PF
2497         PHEP(1,ICM)=PTX
2498         PHEP(2,ICM)=PTY
2499 C---special for DIS: keep lepton momenta fixed
2500         IF (DISPRO) THEN
2501           IP1=JMOHEP(1,ICM)
2502           IP2=JDAHEP(1,ICM)
2503           IJT=IJET(1)
2504 C---IJT will be used to store lepton momentum transfer
2505           CALL HWVDIF(4,PHEP(1,IP1),PHEP(1,IP2),PHEP(1,IJT))
2506           CALL HWUMAS(PHEP(1,IJT))
2507           IF (IDHEP(IP1).EQ.IDHEP(IP2)) THEN
2508             IDHW(IJT)=200
2509           ELSEIF (IDHEP(IP1).LT.IDHEP(IP2)) THEN
2510             IDHW(IJT)=199
2511           ELSE
2512             IDHW(IJT)=198
2513           ENDIF
2514           IDHEP(IJT)=IDPDG(IDHW(IJT))
2515           ISTHEP(IJT)=3
2516 C---calculate boost for struck parton
2517 C   PC is momentum of outgoing parton(s)
2518           IP2=JDAHEP(2,ICM)
2519           IF (.NOT.DISLOW) THEN
2520 C---FOR heavy QQbar PQ and PC are old and new QQbar momenta
2521             CALL HWVSUM(4,PHEP(1,IP2-1),PHEP(1,IP2),PQ)
2522             CALL HWUMAS(PQ)
2523             PC(5)=PQ(5)
2524           ELSE
2525             PC(5)=PHEP(5,JDAHEP(1,IP2))
2526           ENDIF
2527           CALL HWVSUM(2,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
2528           ET(1)=ET(2)
2529 C---USE BREIT FRAME BOSON MOMENTUM IF NECESSARY
2530           IF (BREIT) THEN
2531             ET(2)=ET(1)+PC(5)**2+PHEP(5,IJET(2))**2
2532             PM0=PHEP(5,IJT)
2533             PP0=-PM0
2534           ELSE
2535             ET(2)=PC(1)**2+PC(2)**2+PC(5)**2
2536             PP0=PHEP(4,IJT)+PHEP(3,IJT)
2537             PM0=PHEP(4,IJT)-PHEP(3,IJT)
2538           ENDIF
2539           ET0=(PP0*PM0)+ET(1)-ET(2)
2540           DET=ET0**2-4.*(PP0*PM0)*ET(1)
2541           IF (DET.LT.ZERO) THEN
2542             FROST=.TRUE.
2543             RETURN
2544           ENDIF
2545           ALF=(SQRT(DET)-ET0)/(2.*PP0*PP(2))
2546           PB(1)=0.
2547           PB(2)=0.
2548           PB(5)=2.D0
2549           PB(3)=ALF-(1./ALF)
2550           PB(4)=ALF+(1./ALF)
2551           DO 100 IHEP=IJET(2),IEND(2)
2552           CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2553           CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2554 C---BOOST FROM BREIT FRAME IF NECESSARY
2555           IF (BREIT) THEN
2556             CALL HWUROB(RBR,PHEP(1,IHEP),PHEP(1,IHEP))
2557             CALL HWULOB(PBR,PHEP(1,IHEP),PHEP(1,IHEP))
2558             CALL HWUROB(RBR,VHEP(1,IHEP),VHEP(1,IHEP))
2559             CALL HWULB4(PBR,VHEP(1,IHEP),VHEP(1,IHEP))
2560           ENDIF
2561   100     ISTHEP(IHEP)=ISTHEP(IHEP)+10
2562           CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJET(2)),DISP)
2563           DO 110 IHEP=IJET(2),IEND(2)
2564   110     CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2565           IF (IEND(2).GT.IJET(2)+1) ISTHEP(IJET(2)+1)=100
2566           CALL HWVSUM(4,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
2567           CALL HWVSUM(4,PHEP(1,IP1),PHEP(1,IJET(2)),PHEP(1,ICM))
2568           CALL HWUMAS(PHEP(1,ICM))
2569         ELSEIF (IPRO/10.EQ.5) THEN
2570 C Special to preserve photon momentum
2571            ETC=PTX**2+PTY**2+PHEP(5,ICM)**2
2572            ET0=ETC+ET(1)-ET(2)
2573            DET=ET0**2-4.*ETC*ET(1)
2574            IF (DET.LT.ZERO) THEN
2575               FROST=.TRUE.
2576               RETURN
2577            ENDIF
2578            ALF=(SQRT(DET)+ET0-2.*ET(1))/(2.*PP(1)*PP(2))
2579            PB(1)=0.
2580            PB(2)=0.
2581            PB(3)=ALF-1./ALF
2582            PB(4)=ALF+1./ALF
2583            PB(5)=2.
2584            IJT=IJET(2)
2585            DO 120 IHEP=IJT,IEND(2)
2586            CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2587            CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2588   120      ISTHEP(IHEP)=ISTHEP(IHEP)+10
2589            CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJT),DISP)
2590            DO 130 IHEP=IJT,IEND(2)
2591   130      CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2592            IF (IEND(2).GT.IJT+1) ISTHEP(IJT+1)=100
2593            ISTHEP(IJET(1))=ISTHEP(IJET(1))+10
2594            CALL HWVSUM(2,PHEP(3,IPAR(1)),PHEP(3,IJT),PHEP(3,ICM))
2595         ELSE
2596 C--change to preserve either long mom or rapidity rather than long mom
2597 C--by PR and BRW 30/9/02
2598           IF (PRESPL) THEN
2599 C--PRESERVE LONG MOM OF CMF
2600             PHEP(4,ICM)=
2601      &            SQRT(PTX**2+PTY**2+PHEP(3,ICM)**2+PHEP(5,ICM)**2)
2602           ELSE
2603 C--PRESERVE RAPIDITY OF CMF
2604             DET=SQRT(ONE+(PTX**2+PTY**2)/(PHEP(4,ICM)**2
2605      &                -PHEP(3,ICM)**2))
2606             CALL HWVSCA(2,DET,PHEP(3,ICM),PHEP(3,ICM))
2607           ENDIF
2608 C---NOW BOOST TO REQUIRED Q**2 AND X-F
2609           PP0=PHEP(4,ICM)+PHEP(3,ICM)
2610           PM0=PHEP(4,ICM)-PHEP(3,ICM)
2611           ET0=(PP0*PM0)+ET(1)-ET(2)
2612           DET=ET0**2-4.*(PP0*PM0)*ET(1)
2613           IF (DET.LT.ZERO) THEN
2614             FROST=.TRUE.
2615             RETURN
2616           ENDIF
2617           DET=SQRT(DET)+ET0
2618           AL(1)= 2.*PM0*PP(1)/DET
2619           AL(2)=(PM0/PP(2))*(1.-2.*ET(1)/DET)
2620           PB(1)=0.
2621           PB(2)=0.
2622           PB(5)=2.
2623           DO 160 IP=1,2
2624           PB(3)=AL(IP)-(1./AL(IP))
2625           PB(4)=AL(IP)+(1./AL(IP))
2626           IJT=IJET(IP)
2627           DO 140 IHEP=IJT,IEND(IP)
2628           CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2629           CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2630   140     ISTHEP(IHEP)=ISTHEP(IHEP)+10
2631           CALL HWVDIF(4,VHEP(1,IPAR(IP)),VHEP(1,IJT),DISP)
2632           DO 150 IHEP=IJT,IEND(IP)
2633   150     CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2634           IF (IEND(IP).GT.IJT+1) THEN
2635             ISTHEP(IJT+1)=100
2636           ELSEIF (IEND(IP).EQ.IJT) THEN
2637 C---NON-PARTON JET
2638             ISTHEP(IJT)=3
2639           ENDIF
2640   160     CONTINUE
2641         ENDIF
2642         ISTHEP(ICM)=120
2643       ELSE
2644 C---TIMELIKE JETS
2645 C---SPECIAL CASE: IF HARD PROCESS IS W/Z DECAY, PERFORM KINEMATIC
2646 C   RECONSTRUCTION IN ITS REST FRAME INSTEAD OF THE LAB FRAME
2647         IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
2648           CALL HWVEQU(5,PHEP(1,ICM),PLAB)
2649           CALL HWULOF(PLAB,PHEP(1,ICM),PHEP(1,ICM))
2650           CALL HWULF4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
2651           DO 165 IP=1,NP
2652             CALL HWULOF(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
2653             CALL HWULF4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
2654  165      CONTINUE
2655         ENDIF
2656 C   special for DIS: preserve outgoing lepton momentum
2657         IF (DISPRO) THEN
2658           CALL HWVEQU(5,PHEP(1,IPAR(1)),PHEP(1,IJET(1)))
2659           ISTHEP(IJET(1))=1
2660           LP=2
2661         ELSE
2662           CALL HWVEQU(5,PHEP(1,ICM),PC)
2663 C--- PQ AND PC ARE OLD AND NEW PARTON CM
2664           CALL HWVSUM(4,PHEP(1,IPAR(1)),PHEP(1,IPAR(2)),PQ)
2665           PQ(5)=PHEP(5,ICM)
2666           IF (NP.GT.2) THEN
2667             DO 170 KP=3,NP
2668   170       CALL HWVSUM(4,PHEP(1,IPAR(KP)),PQ,PQ)
2669           ENDIF
2670           LP=1
2671         ENDIF
2672         IF (.NOT.DISLOW) THEN
2673 C---FIND JET CM MOMENTA
2674           ECM=PQ(5)
2675           EMS=0.
2676           JETRAD=.FALSE.
2677           DO 180 KP=LP,NP
2678           EMJ=PHEP(5,IJET(KP))
2679           EMP=PHEP(5,IPAR(KP))
2680           JETRAD=JETRAD.OR.EMJ.NE.EMP
2681           EMS=EMS+EMJ
2682           PM(KP)= EMJ**2
2683 C---N.B. ROUNDING ERRORS HERE AT HIGH ENERGIES
2684           PJ(KP)=(HWULDO(PHEP(1,IPAR(KP)),PQ)/ECM)**2-EMP**2
2685           IF (PJ(KP).LE.ZERO) CALL HWWARN('HWBJCO',104,*999)
2686   180     CONTINUE
2687           PF=1.
2688           IF (JETRAD) THEN
2689 C---JETS DID RADIATE
2690             IF (EMS.GE.ECM) THEN
2691               FROST=.TRUE.
2692               GOTO 240
2693             ENDIF
2694             DO 200 NE=1,NETRY
2695             EMS=-ECM
2696             DMS=0.
2697             DO 190 KP=LP,NP
2698             ES=SQRT(PF*PJ(KP)+PM(KP))
2699             EMS=EMS+ES
2700   190       DMS=DMS+PJ(KP)/ES
2701             DPF=2.*EMS/DMS
2702             IF (DPF.GT.PF) DPF=0.9*PF
2703             PF=PF-DPF
2704   200       IF (ABS(DPF).LT.EPS) GOTO 210
2705             CALL HWWARN('HWBJCO',105,*999)
2706           ENDIF
2707   210     CONTINUE
2708         ENDIF
2709 C---BOOST PC AND PQ TO BREIT FRAME IF NECESSARY
2710         IF (DISPRO.AND.BREIT) THEN
2711           CALL HWULOF(PBR,PC,PC)
2712           CALL HWUROF(RBR,PC,PC)
2713           IF (.NOT.DISLOW) THEN
2714             CALL HWULOF(PBR,PQ,PQ)
2715             CALL HWUROF(RBR,PQ,PQ)
2716           ENDIF
2717         ENDIF
2718         DO 230 IP=LP,NP
2719 C---FIND CM ROTATION FOR JET IP
2720         IF (.NOT.DISLOW) THEN
2721           CALL HWVEQU(4,PHEP(1,IPAR(IP)),PR)
2722           IF (DISPRO.AND.BREIT) THEN
2723             CALL HWULOF(PBR,PR,PR)
2724             CALL HWUROF(RBR,PR,PR)
2725           ENDIF
2726           CALL HWULOF(PQ,PR,PR)
2727           CALL HWUROT(PR, ONE,ZERO,RR)
2728           PR(1)=ZERO
2729           PR(2)=ZERO
2730           PR(3)=SQRT(PF*PJ(IP))
2731           PR(4)=SQRT(PF*PJ(IP)+PM(IP))
2732           PR(5)=PHEP(5,IJET(IP))
2733           CALL HWUROB(RR,PR,PR)
2734 C--Modified by BRW 25/10/02 to do boost in 2 stages (long,trans)
2735           PA(1)=ZERO
2736           PA(2)=ZERO
2737           PA(3)=PC(3)
2738           PA(5)=PC(5)
2739           PA(4)=SQRT(PA(3)**2+PA(5)**2)
2740           CALL HWULOB(PA,PR,PR)
2741           PA(1)=PC(1)
2742           PA(2)=PC(2)
2743           PA(3)=ZERO
2744           PA(5)=PA(4)
2745           PA(4)=PC(4)
2746           CALL HWULOB(PA,PR,PR)
2747 C--End mod
2748         ELSE
2749           CALL HWVEQU(5,PC,PR)
2750         ENDIF
2751 C---NOW PR IS LAB/BREIT MOMENTUM OF JET IP
2752         KP=IJET(IP)+1
2753         IF (AZCOR.AND.KP.LE.NHEP.AND.IDHW(KP).EQ.17) THEN
2754 C---ALIGN CONE WITH INTERFERING PARTON
2755           CALL HWUROT(PR, ONE,ZERO,RS)
2756           JP=JMOHEP(2,KP)
2757           IF (JP.EQ.0) THEN
2758             CALL HWWARN('HWBJCO',2,*999)
2759             PTINF=0.
2760           ELSE
2761             CALL HWVEQU(4,PHEP(1,JP),PS)
2762             IF (DISPRO.AND.BREIT) THEN
2763               CALL HWULOF(PBR,PS,PS)
2764               CALL HWUROF(RBR,PS,PS)
2765             ENDIF
2766             CALL HWUROF(RS,PS,PS)
2767             PTINF=PS(1)**2+PS(2)**2
2768             IF (PTINF.LT.EPS) THEN
2769 C---COLLINEAR JETS: ALIGN CONES
2770               JP=JDAHEP(1,JP)+1
2771               IF (ISTHEP(JP).EQ.100.AND.(ISTHEP(JP-1)+9)/10.EQ.14) THEN
2772                 CALL HWVEQU(4,PHEP(1,JP),PS)
2773                 IF (DISPRO.AND.BREIT) THEN
2774                   CALL HWULOF(PBR,PS,PS)
2775                   CALL HWUROF(RBR,PS,PS)
2776                 ENDIF
2777                 CALL HWUROF(RS,PS,PS)
2778                 PTINF=PS(1)**2+PS(2)**2
2779               ELSE
2780                 PTINF=0.
2781               ENDIF
2782             ENDIF
2783           ENDIF
2784           CALL HWVEQU(4,PHEP(1,KP),PB)
2785           IF (DISPRO.AND.BREIT) THEN
2786             CALL HWULOF(PBR,PB,PB)
2787             CALL HWUROF(RBR,PB,PB)
2788           ENDIF
2789           PTCON=PB(1)**2+PB(2)**2
2790           IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
2791             CN=1./SQRT(PTINF*PTCON)
2792             CP=CN*(PS(1)*PB(1)+PS(2)*PB(2))
2793             SP=CN*(PS(1)*PB(2)-PS(2)*PB(1))
2794           ELSE
2795             CALL HWRAZM( ONE,CP,SP)
2796           ENDIF
2797         ELSE
2798           CALL HWRAZM( ONE,CP,SP)
2799         ENDIF
2800         CALL HWUROT(PR,CP,SP,RS)
2801 C---FIND BOOST FOR JET IP
2802         ALF=(PHEP(3,IJET(IP))+PHEP(4,IJET(IP)))/
2803      &      (PR(4)+SQRT((PR(4)+PR(5))*(PR(4)-PR(5))))
2804         PB(1)=0.
2805         PB(2)=0.
2806         PB(3)=ALF-(1./ALF)
2807         PB(4)=ALF+(1./ALF)
2808         PB(5)=2.
2809         IHEP=IJET(IP)
2810         KHEP=JDAHEP(2,IHEP)
2811         IF (KHEP.LT.IHEP) KHEP=IHEP
2812         DO 220 JHEP=IHEP,KHEP
2813         CALL HWULOF(PB,PHEP(1,JHEP),PHEP(1,JHEP))
2814         CALL HWUROB(RS,PHEP(1,JHEP),PHEP(1,JHEP))
2815         CALL HWULF4(PB,VHEP(1,JHEP),VHEP(1,JHEP))
2816         CALL HWUROB(RS,VHEP(1,JHEP),VHEP(1,JHEP))
2817 C---BOOST FROM BREIT FRAME IF NECESSARY
2818         IF (DISPRO.AND.BREIT) THEN
2819           CALL HWUROB(RBR,PHEP(1,JHEP),PHEP(1,JHEP))
2820           CALL HWULOB(PBR,PHEP(1,JHEP),PHEP(1,JHEP))
2821           CALL HWUROB(RBR,VHEP(1,JHEP),VHEP(1,JHEP))
2822           CALL HWULB4(PBR,VHEP(1,JHEP),VHEP(1,JHEP))
2823         ENDIF
2824         CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,IPAR(IP)),VHEP(1,JHEP))
2825 C--MHS FIX 07/03/05 FOR VERTEX POSITION OF LONG LIVED NON-PARTON JETS
2826         IF (KHEP.EQ.IHEP.AND.(IDHW(JHEP).GE.121.AND.IDHW(JHEP).LE.132
2827      $       .OR.IDHW(JHEP).EQ.59))
2828      $       CALL HWVSUM(4,VTXPIP,VHEP(1,JHEP),VHEP(1,JHEP))
2829 C--END FIX
2830   220   ISTHEP(JHEP)=ISTHEP(JHEP)+10
2831         IF (KHEP.GT.IHEP+1) THEN
2832           ISTHEP(IHEP+1)=100
2833         ELSEIF (KHEP.EQ.IHEP) THEN
2834 C---NON-PARTON JET
2835           ISTHEP(IHEP)=190
2836         ENDIF
2837   230   CONTINUE
2838         IF (ISTHEP(ICM).EQ.110) ISTHEP(ICM)=120
2839 C---SPECIAL CASE: FOR W/Z DECAY BOOST BACK TO THE LAB FRAME
2840  240    IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
2841           CALL HWULOB(PLAB,PHEP(1,ICM),PHEP(1,ICM))
2842           CALL HWULB4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
2843           DO 260 IP=1,NP
2844             CALL HWULOB(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
2845             CALL HWULB4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
2846             CALL HWULOB(PLAB,PHEP(1,IJET(IP)),PHEP(1,IJET(IP)))
2847 C--MHS FIX 07/03/05 - DO NOT REBOOST PRIMARY VERTEX
2848             IF (ISTHEP(IJET(IP)).EQ.190)
2849      $           CALL HWVDIF(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
2850             CALL HWULB4(PLAB,VHEP(1,IJET(IP)),VHEP(1,IJET(IP)))
2851             IF (ISTHEP(IJET(IP)).EQ.190)
2852      $           CALL HWVSUM(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
2853 C---END FIX
2854             IF (JDAHEP(1,IJET(IP)).GT.0) THEN
2855               IF (JDAHEP(2,IJET(IP)).GT.JDAHEP(1,IJET(IP))) THEN
2856                 CALL HWULOB(PLAB,PHEP(1,IJET(IP)+1),PHEP(1,IJET(IP)+1))
2857                 CALL HWULB4(PLAB,VHEP(1,IJET(IP)+1),VHEP(1,IJET(IP)+1))
2858               ENDIF
2859               DO 250 IHEP=JDAHEP(1,IJET(IP)),JDAHEP(2,IJET(IP))
2860                 CALL HWULOB(PLAB,PHEP(1,IHEP),PHEP(1,IHEP))
2861                 CALL HWULB4(PLAB,VHEP(1,IHEP),VHEP(1,IHEP))
2862  250          CONTINUE
2863             ENDIF
2864  260      CONTINUE
2865         ENDIF
2866         IF (FROST) RETURN
2867       ENDIF
2868       GOTO 20
2869   999 END
2870 CDECK  ID>, HWBMAS.
2871 *CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
2872 *-- Author :    Bryan Webber
2873 C-----------------------------------------------------------------------
2874       SUBROUTINE HWBMAS
2875 C-----------------------------------------------------------------------
2876 C     Passes  backwards through a  jet cascade  calculating the masses
2877 C     and magnitudes of the longitudinal and transverse three momenta.
2878 C     Components given relative to direction of parent for a time-like
2879 C     vertex and with respect to z-axis for space-like vertices.
2880 C
2881 C     On input PPAR(1-5,*) contains:
2882 C     (E*sqrt(Xi),Xi,3-mom (if external),E,M-sq (if external))
2883 C
2884 C     On output PPAR(1-5,*) (if TMPAR(*)), containts:
2885 C     (P-trans,Xi or Xilast,P-long,E,M)
2886 C-----------------------------------------------------------------------
2887       INCLUDE 'HERWIG65.INC'
2888       DOUBLE PRECISION HWUSQR,EXI,PISQ,PJPK,EJEK,PTSQ,Z,ZMIN,ZMAX,
2889      $     EMI,EMJ,EMK,C,NQ,HWBVMC,RHO,POLD,PNEW,EOLD,ENEW,A,B
2890       INTEGER IPAR,JPAR,KPAR,MPAR,I,J,K
2891       EXTERNAL HWUSQR
2892       IF (IERROR.NE.0) RETURN
2893       IF (NPAR.GT.2) THEN
2894         DO 30 MPAR=NPAR-1,3,-2
2895          JPAR=MPAR
2896 C Find parent and partner of this branch
2897          IPAR=JMOPAR(1,JPAR)
2898          KPAR=JPAR+1
2899 C Determine type of branching
2900          IF (TMPAR(IPAR)) THEN
2901 C Time-like branching
2902 C           Compute mass of parent
2903             EXI=PPAR(1,JPAR)*PPAR(1,KPAR)
2904             PPAR(5,IPAR)=PPAR(5,JPAR)+PPAR(5,KPAR)+2.*EXI
2905 C           Compute three momentum of parent
2906             PISQ=PPAR(4,IPAR)*PPAR(4,IPAR)-PPAR(5,IPAR)
2907             PPAR(3,IPAR)=HWUSQR(PISQ)
2908 C---SPECIAL FOR G-->QQBAR: READJUST ANGULAR DISTRIBUTION
2909             IF (IDPAR(IPAR).EQ.13 .AND. IDPAR(JPAR).LT.13) THEN
2910               Z=PPAR(4,JPAR)/PPAR(4,IPAR)
2911               ZMIN=HWBVMC(IDPAR(JPAR))/PPAR(1,JPAR)*Z
2912               RHO=(Z*(3-Z*(3-2*Z))-ZMIN*(3-ZMIN*(3-2*ZMIN)))
2913      $             /(2*(1-2*ZMIN)*(1-ZMIN*(1-ZMIN)))
2914               NQ=PPAR(3,IPAR)*(PPAR(3,IPAR)+PPAR(4,IPAR))
2915               EMI=PPAR(5,IPAR)
2916               EMJ=PPAR(5,JPAR)
2917               EMK=PPAR(5,KPAR)
2918               ZMIN=MAX((EMI+EMJ-EMK)/(2*(EMI+NQ)),
2919      $      (EMI+EMJ-EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI))
2920               ZMAX=1-MAX((EMI-EMJ+EMK)/(2*(EMI+NQ)),
2921      $      (EMI-EMJ+EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI))
2922               C=2*RMASS(IDPAR(JPAR))**2/EMI
2923               Z=(4*ZMIN*(1.5*(1+C-ZMIN)+ZMIN**2)*(1-RHO)
2924      $          +4*ZMAX*(1.5*(1+C-ZMAX)+ZMAX**2)*RHO-2-3*C)/(1+2*C)**1.5
2925               Z=SQRT(1+2*C)*SINH(LOG(Z+SQRT(Z**2+1))/3)+0.5
2926               Z=(Z*NQ+(EMI+EMJ-EMK)/2)/(NQ+EMI)
2927               PPAR(4,JPAR)=Z*PPAR(4,IPAR)
2928               PPAR(4,KPAR)=PPAR(4,IPAR)-PPAR(4,JPAR)
2929               PPAR(3,JPAR)=HWUSQR(PPAR(4,JPAR)**2-EMJ)
2930               PPAR(3,KPAR)=HWUSQR(PPAR(4,KPAR)**2-EMK)
2931               PPAR(2,JPAR)=EXI/(PPAR(4,JPAR)*PPAR(4,KPAR))
2932               IF(JDAPAR(2,JPAR).NE.0)PPAR(2,JDAPAR(2,JPAR))=PPAR(2,JPAR)
2933               IF(JDAPAR(2,KPAR).NE.0)PPAR(2,JDAPAR(2,KPAR))=PPAR(2,JPAR)
2934 C---FIND DESCENDENTS OF THIS SPLITTING AND READJUST THEIR MOMENTA TOO
2935               DO 20 J=JPAR+2,NPAR-1,2
2936                 I=J
2937  10             I=JMOPAR(1,I)
2938                 IF (I.GT.IPAR) GOTO 10
2939                 IF (I.EQ.IPAR) THEN
2940                   I=JMOPAR(1,J)
2941                   K=J+1
2942                   POLD=PPAR(3,J)+PPAR(3,K)
2943                   EOLD=PPAR(4,J)+PPAR(4,K)
2944                   PNEW=HWUSQR(PPAR(4,I)**2-PPAR(5,I))
2945                   ENEW=PPAR(4,I)
2946                   A=(ENEW*EOLD-PNEW*POLD)/PPAR(5,I)
2947                   B=(PNEW*EOLD-ENEW*POLD)/PPAR(5,I)
2948                   PPAR(3,J)=A*PPAR(3,J)+B*PPAR(4,J)
2949                   PPAR(4,J)=(PPAR(4,J)+B*PPAR(3,J))/A
2950                   PPAR(3,K)=PNEW-PPAR(3,J)
2951                   PPAR(4,K)=ENEW-PPAR(4,J)
2952                   PPAR(2,J)=1-(PPAR(3,J)*PPAR(3,K)+PPAR(1,J)*PPAR(1,K))
2953      $                 /(PPAR(4,J)*PPAR(4,K))
2954                   IF (JDAPAR(2,J).NE.0) PPAR(2,JDAPAR(2,J))=PPAR(2,J)
2955                   IF (JDAPAR(2,K).NE.0) PPAR(2,JDAPAR(2,K))=PPAR(2,J)
2956                 ENDIF
2957  20           CONTINUE
2958             ENDIF
2959 C           Compute daughter' transverse and longitudinal momenta
2960             PJPK=PPAR(3,JPAR)*PPAR(3,KPAR)
2961             EJEK=PPAR(4,JPAR)*PPAR(4,KPAR)-EXI
2962             PTSQ=(PJPK+EJEK)*(PJPK-EJEK)/PISQ
2963             PPAR(1,JPAR)=HWUSQR(PTSQ)
2964             PPAR(3,JPAR)=HWUSQR(PPAR(3,JPAR)*PPAR(3,JPAR)-PTSQ)
2965             PPAR(1,KPAR)=-PPAR(1,JPAR)
2966             PPAR(3,KPAR)= PPAR(3,IPAR)-PPAR(3,JPAR)
2967          ELSE
2968 C Space-like branching
2969 C           Re-arrange such that JPAR is time-like
2970             IF (TMPAR(KPAR)) THEN
2971                KPAR=JPAR
2972                JPAR=JPAR+1
2973             ENDIF
2974 C           Compute time-like branch
2975             PTSQ=(2.-PPAR(2,JPAR))*PPAR(1,JPAR)*PPAR(1,JPAR)
2976      &          -PPAR(5,JPAR)
2977             PPAR(1,JPAR)=HWUSQR(PTSQ)
2978             PPAR(3,JPAR)=(1.-PPAR(2,JPAR))*PPAR(4,JPAR)
2979             PPAR(3,IPAR)=PPAR(3,KPAR)-PPAR(3,JPAR)
2980             PPAR(5,IPAR)=0.
2981             PPAR(1,KPAR)=0.
2982          ENDIF
2983 C Reset Xi to Xilast
2984          PPAR(2,KPAR)=PPAR(2,IPAR)
2985  30    CONTINUE
2986       ENDIF
2987       DO 40 IPAR=2,NPAR
2988  40   PPAR(5,IPAR)=HWUSQR(PPAR(5,IPAR))
2989       PPAR(1,2)=0.
2990       PPAR(2,2)=0.
2991       END
2992 CDECK  ID>, HWBRAN.
2993 *CMZ :-        -14/10/99  18.04.56  by  Mike Seymour
2994 *-- Author :    Bryan Webber & Mike Seymour
2995 C-----------------------------------------------------------------------
2996       SUBROUTINE HWBRAN(KPAR)
2997 C-----------------------------------------------------------------------
2998 C     BRANCHES TIMELIKE PARTON KPAR INTO TWO, PUTS PRODUCTS
2999 C     INTO NPAR+1 AND NPAR+2, AND INCREASES NPAR BY TWO
3000 C-----------------------------------------------------------------------
3001       INCLUDE 'HERWIG65.INC'
3002       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,PMOM,
3003      & QNOW,QLST,QKTHR,RN,QQBAR,DQQ,QGTHR,SNOW,QSUD,ZMIN,ZMAX,ZRAT,WMIN,
3004      & QLAM,Z1,Z2,ETEST,ZTEST,ENOW,XI,XIPREV,EPREV,QMAX,QGAM,SLST,SFNL,
3005      & TARG,ALF,BETA0(3:6),BETAP(3:6),SQRK(4:6,5),REJFAC,Z,X1,X2,OTHXI,
3006      & OTHZ,X3,FF,AW,XCUT,CC,JJ,HWUSQR
3007       INTEGER HWRINT,KPAR,ID,JD,IS,NTRY,N,ID1,ID2,MPAR,ISUD(13),IHEP,
3008      & JHEP,M,NF,NN,IREJ,NREJ,ITOP
3009       EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,HWRINT,HWUSQR
3010       SAVE BETA0,BETAP,SQRK
3011       DATA ISUD,BETA0/2,2,3,4,5,6,2,2,3,4,5,6,1,4*ZERO/
3012       IF (IERROR.NE.0) RETURN
3013 C---SET SQRK(M,N) TO THE PROBABILITY THAT A GLUON WILL NOT PRODUCE A
3014 C   QUARK-ANTIQUARK PAIR BETWEEN SCALES RMASS(M) AND 2*HWBVMC(N)
3015       IF (SUDORD.NE.1.AND.BETA0(3).EQ.ZERO) THEN
3016         DO 100 M=3,6
3017           BETA0(M)=(11.*CAFAC-2.*M)*0.5
3018  100      BETAP(M)=(17.*CAFAC**2-(5.*CAFAC+3.*CFFAC)*M)
3019      &            /BETA0(M)*0.25/PIFAC
3020         DO 120 N=1,5
3021           DO 110 M=4,6
3022             IF (M.LE.N) THEN
3023               SQRK(M,N)=ONE
3024             ELSEIF (M.EQ.4.OR.M.EQ.N+1) THEN
3025               NF=M
3026               IF (2*HWBVMC(N).GT.RMASS(M)) NF=M+1
3027               SQRK(M,N)=((BETAP(NF-1)+1/HWUALF(1,2*HWBVMC(N)))/
3028      $             (BETAP(NF-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(NF-1))
3029             ELSE
3030               SQRK(M,N)=SQRK(M-1,N)*
3031      $             ((BETAP(M-1)+1/HWUALF(1,RMASS(M-1)))/
3032      $             (BETAP(M-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(M-1))
3033             ENDIF
3034  110      CONTINUE
3035  120    CONTINUE
3036       ENDIF
3037       ID=IDPAR(KPAR)
3038 C--TEST FOR PARTON TYPE
3039       IF (ID.LE.13) THEN
3040         JD=ID
3041         IS=ISUD(ID)
3042       ELSEIF (ID.GE.209.AND.ID.LE.220) THEN
3043         JD=ID-208
3044         IS=7
3045       ELSE
3046         IS=0
3047       END IF
3048       QNOW=-1.
3049       IF (IS.NE.0) THEN
3050 C--TIMELIKE PARTON BRANCHING
3051         ENOW=PPAR(4,KPAR)
3052         XIPREV=PPAR(2,KPAR)
3053         IF (JMOPAR(1,KPAR).EQ.0) THEN
3054           EPREV=PPAR(4,KPAR)
3055         ELSE
3056           EPREV=PPAR(4,JMOPAR(1,KPAR))
3057         ENDIF
3058 C--IF THIS IS CHARGED & PHOTONS ARE ALLOWED, ANGLES MIGHT NOT BE ORDERED
3059         QMAX=0
3060         QLST=PPAR(1,KPAR)
3061         IF (ICHRG(ID).NE.0 .AND. VPCUT.LT.PPAR(1,2)) THEN
3062 C--LOOK FOR A PREVIOUS G->QQBAR, IF ANY
3063           MPAR=KPAR
3064  1        IF (JMOPAR(1,MPAR).NE.0) THEN
3065             IF (IDPAR(JMOPAR(1,MPAR)).EQ.ID) THEN
3066               MPAR=JMOPAR(1,MPAR)
3067               GOTO 1
3068             ENDIF
3069           ENDIF
3070 C--IF CLIMBED TO THE TOP OF THE LIST, FIND QED INTERFERENCE PARTNER
3071           IF (MPAR.EQ.2) THEN
3072             JHEP=0
3073             IF (ID.LT.7) THEN
3074               IHEP=JDAHEP(2,JCOPAR(1,1))
3075               IF (IHEP.GT.0) JHEP=JDAHEP(2,IHEP)
3076             ELSE
3077               IHEP=JMOHEP(2,JCOPAR(1,1))
3078               IF (IHEP.GT.0) JHEP=JMOHEP(2,IHEP)
3079             ENDIF
3080             IF (IHEP.GT.0.AND.JHEP.GT.0) THEN
3081                QMAX=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
3082      &              *(ENOW/PPAR(4,2))**2
3083             ELSE
3084 C--FIX AT HARD PROCESS SCALE IF POINTER NOT YET SET
3085 C  (CAN HAPPEN IN SUSY EVENTS)
3086                QMAX=EMSCA**2
3087             ENDIF
3088           ELSE
3089             QMAX=ENOW**2*PPAR(2,MPAR)
3090           ENDIF
3091 C--IF PREVIOUS BRANCHING WAS Q->QGAMMA, LOOK FOR A QCD BRANCHING
3092           MPAR=KPAR
3093  2        IF (JMOPAR(1,MPAR).NE.0) THEN
3094             IF (IDPAR(JDAPAR(1,JMOPAR(1,MPAR))).EQ.59 .OR.
3095      &        IDPAR(JDAPAR(2,JMOPAR(1,MPAR))).EQ.59) THEN
3096               MPAR=JMOPAR(1,MPAR)
3097               GOTO 2
3098             ENDIF
3099           ENDIF
3100           QLST=ENOW**2*PPAR(2,MPAR)
3101           QMAX=SQRT(MAX(ZERO,MIN(
3102      &         QMAX , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV))))
3103           QLST=SQRT(MIN(
3104      &         QLST , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV)))
3105         ENDIF
3106         NTRY=0
3107     5   NTRY=NTRY+1
3108         IF (NTRY.GT.NBTRY) CALL HWWARN('HWBRAN',100,*999)
3109         IF (ID.EQ.13) THEN
3110 C--GLUON -> QUARK+ANTIQUARK OPTION
3111           IF (QLST.GT.QCDL3) THEN
3112             DO 8 N=1,NFLAV
3113             QKTHR=2.*HWBVMC(N)
3114             IF (QLST.GT.QKTHR) THEN
3115               RN=HWRGEN(N)
3116               IF (SUDORD.NE.1) THEN
3117 C---FIND IN WHICH FLAVOUR INTERVAL THE UPPER LIMIT LIES
3118                 NF=3
3119                 DO 200 M=MAX(3,N),NFLAV
3120  200              IF (QLST.GT.RMASS(M)) NF=M
3121 C---CALCULATE THE FORM FACTOR
3122                 IF (NF.EQ.MAX(3,N)) THEN
3123                   SFNL=((BETAP(NF)+1/HWUALF(1,QKTHR))/
3124      $                 (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
3125                   SLST=SFNL
3126                 ELSE
3127                   SFNL=((BETAP(NF)+1/HWUALF(1,RMASS(NF)))/
3128      $                 (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
3129                   SLST=SFNL*SQRK(NF,N)
3130                 ENDIF
3131               ENDIF
3132               IF (RN.GT.1.E-3) THEN
3133                 QQBAR=QCDL3*(QLST/QCDL3)**(RN**BETAF)
3134               ELSE
3135                 QQBAR=QCDL3
3136               ENDIF
3137               IF (SUDORD.NE.1) THEN
3138 C---FIND IN WHICH FLAVOUR INTERVAL THE SOLUTION LIES
3139                 IF (RN.GE.SFNL) THEN
3140                   NN=NF
3141                 ELSEIF (RN.GE.SLST) THEN
3142                   NN=MAX(3,N)
3143                   DO 210 M=MAX(3,N)+1,NF-1
3144  210                IF (RN.GE.SLST/SQRK(M,N)) NN=M
3145                 ELSE
3146                   NN=0
3147                   QQBAR=QCDL3
3148                 ENDIF
3149                 IF (NN.GT.0) THEN
3150                   IF (NN.EQ.NF) THEN
3151                     TARG=HWUALF(1,QLST)
3152                   ELSE
3153                     TARG=HWUALF(1,RMASS(NN+1))
3154                     RN=RN/SLST*SQRK(NN+1,N)
3155                   ENDIF
3156                   TARG=1/((BETAP(NN)+1/TARG)*RN**BETA0(NN)-BETAP(NN))
3157 C---NOW SOLVE HWUALF(1,QQBAR)=TARG FOR QQBAR ITERATIVELY
3158  7                QQBAR=MAX(QQBAR,HALF*QKTHR)
3159                   ALF=HWUALF(1,QQBAR)
3160                   IF (ABS(ALF-TARG).GT.ACCUR) THEN
3161                     NTRY=NTRY+1
3162                     IF (NTRY.GT.NBTRY) CALL HWWARN('HWBRAN',101,*999)
3163                     QQBAR=QQBAR*(1+3*PIFAC*(ALF-TARG)
3164      $                   /(BETA0(NN)*ALF**2*(1+BETAP(NN)*ALF)))
3165                     GOTO 7
3166                   ENDIF
3167                 ENDIF
3168               ENDIF
3169               IF (QQBAR.GT.QNOW.AND.QQBAR.GT.QKTHR) THEN
3170                 QNOW=QQBAR
3171                 ID2=N
3172               ENDIF
3173             ELSE
3174               GOTO 9
3175             ENDIF
3176     8       CONTINUE
3177           ENDIF
3178 C--GLUON->DIQUARKS OPTION
3179     9     IF (QLST.LT.QDIQK) THEN
3180             IF (PDIQK.NE.ZERO) THEN
3181               RN=HWRGEN(0)
3182               DQQ=QLST*EXP(-RN/PDIQK)
3183               IF (DQQ.GT.QNOW) THEN
3184                 IF (DQQ.GT.2.*RMASS(115)) THEN
3185                   QNOW=DQQ
3186                   ID2=115
3187                 ENDIF
3188               ENDIF
3189             ENDIF
3190           ENDIF
3191         ENDIF
3192 C--ENHANCE GLUON AND PHOTON EMISSION BY A FACTOR OF TWO IF THIS BRANCH
3193 C  IS CAPABLE OF BEING THE HARDEST SO FAR
3194         NREJ=1
3195         IF (TMPAR(2).AND.0.25*MAX(QLST,QMAX).GT.HARDST) NREJ=2
3196 C--BRANCHING ID->ID+GLUON
3197         QGTHR=HWBVMC(ID)+HWBVMC(13)
3198         IF (QLST.GT.QGTHR) THEN
3199          DO 300 IREJ=1,NREJ
3200           RN=HWRGEN(1)
3201           SLST=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,INTER)
3202           IF (RN.EQ.ZERO) THEN
3203             SNOW=2.
3204           ELSE
3205             SNOW=SLST/RN
3206           ENDIF
3207           IF (SNOW.LT.ONE) THEN
3208             QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,INTER)
3209 C---IF FORM FACTOR DID NOT GET INVERTED CORRECTLY TRY LINEAR INSTEAD
3210             IF (QSUD.GT.QLST) THEN
3211               SNOW=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,1)/RN
3212               QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,1)
3213               IF (QSUD.GT.QLST) THEN
3214                 CALL HWWARN('HWBRAN',1,*999)
3215                 QSUD=-1
3216               ENDIF
3217             ENDIF
3218             IF (QSUD.GT.QGTHR.AND.QSUD.GT.QNOW) THEN
3219               ID2=13
3220               QNOW=QSUD
3221             ENDIF
3222           ENDIF
3223  300     CONTINUE
3224         ENDIF
3225 C--BRANCHING ID->ID+PHOTON
3226         IF (ICHRG(ID).NE.0) THEN
3227           QGTHR=MAX(HWBVMC(ID)+HWBVMC(59),HWBVMC(59)*EXP(0.75))
3228           IF (QMAX.GT.QGTHR) THEN
3229            DO 400 IREJ=1,NREJ
3230             RN=HWRGEN(2)
3231             IF (RN.EQ.ZERO) THEN
3232               QGAM=0
3233             ELSE
3234               QGAM=(LOG(QMAX/HWBVMC(59))-0.75)**2
3235      &            +PIFAC*9/(ICHRG(ID)**2*ALPFAC*ALPHEM)*LOG(RN)
3236               IF (QGAM.GT.ZERO) THEN
3237                 QGAM=HWBVMC(59)*EXP(0.75+SQRT(QGAM))
3238               ELSE
3239                 QGAM=0
3240               ENDIF
3241             ENDIF
3242             IF (QGAM.GT.QGTHR.AND.QGAM.GT.QNOW) THEN
3243               ID2=59
3244               QNOW=QGAM
3245             ENDIF
3246  400       CONTINUE
3247           ENDIF
3248         ENDIF
3249         IF (QNOW.GT.ZERO) THEN
3250 C--BRANCHING HAS OCCURRED
3251           ZMIN=HWBVMC(ID2)/QNOW
3252           ZMAX=1.-ZMIN
3253           IF (ID.EQ.13) THEN
3254             IF (ID2.EQ.13) THEN
3255 C--GLUON -> GLUON + GLUON
3256               ID1=13
3257               WMIN=ZMIN*ZMAX
3258               ETEST=(1.-WMIN)**2*HWUALF(5-SUDORD*2,QNOW*WMIN)
3259               ZRAT=(ZMAX*(1-ZMIN))/(ZMIN*(1-ZMAX))
3260 C--CHOOSE Z1 DISTRIBUTED ON (ZMIN,ZMAX)
3261 C  ACCORDING TO GLUON BRANCHING FUNCTION
3262    10         Z1=ZMAX/(ZMAX+(1-ZMAX)*ZRAT**HWRGEN(0))
3263               Z2=1.-Z1
3264               ZTEST=(1.-(Z1*Z2))**2*HWUALF(5-SUDORD*2,QNOW*(Z1*Z2))
3265               IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 10
3266               Z=Z1
3267             ELSEIF (ID2.NE.115) THEN
3268 C--GLUON -> QUARKS
3269               ID1=ID2+6
3270               ETEST=ZMIN**2+ZMAX**2
3271    20         Z1=HWRUNI(0,ZMIN,ZMAX)
3272               Z2=1.-Z1
3273               ZTEST=Z1*Z1+Z2*Z2
3274               IF (ZTEST.LT.ETEST*HWRGEN(0)) GOTO 20
3275             ELSE
3276 C--GLUON -> DIQUARKS
3277               ID2=HWRINT(115,117)
3278               ID1=ID2-6
3279               Z1=HWRUNI(0,ZMIN,ZMAX)
3280               Z2=1.-Z1
3281             ENDIF
3282           ELSE
3283 C--QUARK OR ANTIQUARK BRANCHING
3284             IF (ID2.EQ.13) THEN
3285 C--TO GLUON
3286               ZMAX=1.-HWBVMC(ID)/QNOW
3287               WMIN=MIN(ZMIN*(1.-ZMIN),ZMAX*(1.-ZMAX))
3288               ETEST=(1.+ZMAX**2)*HWUALF(5-SUDORD*2,QNOW*WMIN)
3289               ZRAT=ZMAX/ZMIN
3290    30         Z1=ZMIN*ZRAT**HWRGEN(0)
3291               Z2=1.-Z1
3292               ZTEST=(1.+Z2*Z2)*HWUALF(5-SUDORD*2,QNOW*Z1*Z2)
3293               IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 30
3294             ELSE
3295 C--TO PHOTON
3296               ZMIN=  HWBVMC(59)/QNOW
3297               ZMAX=1-HWBVMC(ID)/QNOW
3298               ZRAT=ZMAX/ZMIN
3299               ETEST=1+(1-ZMIN)**2
3300    40         Z1=ZMIN*ZRAT**HWRGEN(0)
3301               Z2=1-Z1
3302               ZTEST=1+Z2*Z2
3303               IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 40
3304             ENDIF
3305 C--QUARKS EMIT ON LOWER SIDE, ANTIQUARKS ON UPPER SIDE
3306             Z=Z1
3307             IF (JD.LE.6) THEN
3308               Z1=Z2
3309               Z2=1.-Z2
3310               ID1=ID
3311             ELSE
3312               ID1=ID2
3313               ID2=ID
3314             ENDIF
3315           ENDIF
3316 C--UPDATE THIS BRANCH AND CREATE NEW BRANCHES
3317           XI=(QNOW/ENOW)**2
3318           IF (ID1.NE.59.AND.ID2.NE.59) THEN
3319             IF (ID.EQ.13.AND.ID1.NE.13) THEN
3320               QLAM=QNOW
3321             ELSE
3322               QLAM=QNOW*Z1*Z2
3323             ENDIF
3324             IF (SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
3325      &           (2.-XI)*(QNOW*Z1*Z2)**2.GT.EMSCA**2) THEN
3326 C--BRANCHING REJECTED: REDUCE Q AND REPEAT
3327                 QMAX=QNOW
3328                 QLST=QNOW
3329                 QNOW=-1.
3330                 GOTO 5
3331             ENDIF
3332           ENDIF
3333 C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
3334           IF (ID.NE.13.OR.ID1.EQ.13) THEN
3335             QLAM=QNOW*Z1*Z2
3336             REJFAC=1
3337             IF (TMPAR(2).AND.QLAM.GT.HARDST) THEN
3338 C----SOFT MATRIX-ELEMENT CORRECTION TO TOP DECAYS
3339               ITOP=JCOPAR(1,1)
3340               IF (ISTHEP(ITOP).EQ.155.AND.(IDHW(ITOP).EQ.6
3341      $             .OR.IDHW(ITOP).EQ.12)) THEN
3342                 AW=(PHEP(5,JDAHEP(1,ITOP))/PHEP(5,ITOP))**2
3343                 FF=0.5*(1-AW)*(1-2*AW+1/AW)
3344                 CC=0.25*(1-AW)**2
3345                 X1=1-2*CC*Z*(1-Z)*XI
3346                 X3=0.5*(1-AW+2*CC*Z*(1-Z)*XI-(1-2*Z)
3347      &               *HWUSQR(((1+AW-2*CC*Z*(1-Z)*XI)**2-4*AW)
3348      &               /(1-2*Z*(1-Z)*XI)))
3349 C-----JACOBIAN FACTOR
3350                 JJ=(1-X1)*(2-AW-X1-2*X3)*(1-2*Z*(1-Z)*XI)/(
3351      $               4*CC**2*((X1+AW)**2-4*AW)*Z**2*(1-Z)**2*(1-2*Z)*XI)
3352 C-----REJECTION FACTOR
3353                 XCUT=2*GCUTME/PHEP(5,ITOP)
3354                 IF (X3.GT.XCUT) REJFAC=FF*JJ
3355      &               *X3**2*(1-X1)*(1+(1-Z)**2)/(Z*XI)
3356      &               /((1+1/AW-2*AW)*((1-AW)*X3-(1-X1)
3357      &               *(1-X3)-X3**2)+(1+1/(2*AW))*X3*(X1+X3-1)**2
3358      &               +2*X3**2*(1-X1))
3359               ELSEIF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
3360 C---COLOUR PARTNER IS ALSO OUTGOING
3361                 X1=1-Z*(1-Z)*XI
3362                 X2=0.5*(1+Z*(1-Z)*XI +
3363      $               (1-Z*(1-Z)*XI)*(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
3364                 REJFAC=SQRT(2*X1-1)/(X1*Z*(1-Z))
3365      $               *(1+(1-Z)**2)/(Z*XI)
3366      $               *(1-X1)*(1-X2)/(X1**2+X2**2)
3367 C---CHECK WHETHER IT IS IN THE OVERLAP REGION
3368                 OTHXI=4*(1-X2)*X2**2/(X2**2-(2*X2-1)*(2*X1+X2-2)**2)
3369                 IF (OTHXI.LT.ONE) THEN
3370                   OTHZ=0.5*(1-SQRT(2*X2-1)/X2*(2*X1+X2-2))
3371                   REJFAC=REJFAC+SQRT(2*X2-1)/(X2*OTHZ*(1-OTHZ))
3372      $                 *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
3373      $                 *(1-X2)*(1-X1)/(X2**2+X1**2)
3374                 ENDIF
3375               ELSE
3376 C---COLOUR PARTNER IS INCOMING (X1=XP, X2=ZP)
3377                 X1=1/(1+Z*(1-Z)*XI)
3378                 X2=0.5*(1+(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
3379                 REJFAC=SQRT(3-2/X1)/(X1**2*Z*(1-Z))
3380      $               *(1+(1-Z)**2)/(Z*XI)
3381      $               *(1-X1)*(1-X2)/
3382      $               (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
3383 C---CHECK WHETHER IT IS IN THE OVERLAP REGION
3384                 OTHXI=(SQRT(X1+2*(1-X2)*(1-X2+X1*X2))-SQRT(X1))**2/
3385      $               (1+X1-X2-SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2))))
3386                 OTHZ=(SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2)))-X1)/(1-X2)
3387                 IF (OTHXI.LT.OTHZ**2) THEN
3388                   REJFAC=REJFAC+OTHZ**3*(1-X1-X2+2*X1*X2)
3389      $                 /(X1**2*(1-OTHZ)*(OTHZ+OTHXI*(1-OTHZ)))
3390      $                 *(1+OTHZ**2)/((1-OTHZ)*OTHXI)
3391      $                 *(1-X1)*(1-X2)/
3392      $                 (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
3393                 ENDIF
3394               ENDIF
3395             ENDIF
3396             IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
3397               QMAX=QNOW
3398               QLST=QNOW
3399               QNOW=-1.
3400               GOTO 5
3401             ENDIF
3402             IF (QLAM.GT.HARDST) HARDST=QLAM
3403           ENDIF
3404           MPAR=NPAR+1
3405           IDPAR(MPAR)=ID1
3406           TMPAR(MPAR)=.TRUE.
3407           PPAR(1,MPAR)=QNOW*Z1
3408           PPAR(2,MPAR)=XI
3409           PPAR(4,MPAR)=ENOW*Z1
3410           NPAR=NPAR+2
3411           IDPAR(NPAR)=ID2
3412           TMPAR(NPAR)=.TRUE.
3413           PPAR(1,NPAR)=QNOW*Z2
3414           PPAR(2,NPAR)=XI
3415           PPAR(4,NPAR)=ENOW*Z2
3416 C---NEW MOTHER-DAUGHTER RELATIONS
3417           JDAPAR(1,KPAR)=MPAR
3418           JDAPAR(2,KPAR)=NPAR
3419           JMOPAR(1,MPAR)=KPAR
3420           JMOPAR(1,NPAR)=KPAR
3421 C---NEW COLOUR CONNECTIONS
3422           JCOPAR(3,KPAR)=NPAR
3423           JCOPAR(4,KPAR)=MPAR
3424           JCOPAR(1,MPAR)=NPAR
3425           JCOPAR(2,MPAR)=KPAR
3426           JCOPAR(1,NPAR)=KPAR
3427           JCOPAR(2,NPAR)=MPAR
3428 C
3429         ENDIF
3430       ENDIF
3431       IF (QNOW.LT.ZERO) THEN
3432 C--BRANCHING STOPS
3433         IF (ID.EQ.IDPAR(2).AND.PPAR(5,2).GT.1D-6) THEN
3434           PPAR(5,KPAR)=PPAR(5,2)**2
3435         ELSE
3436           PPAR(5,KPAR)=RMASS(ID)**2
3437         ENDIF
3438         PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
3439         IF (PMOM.LT.-1E-6) CALL HWWARN('HWBRAN',104,*999)
3440         IF (PMOM.LT.ZERO) PMOM=ZERO
3441         PPAR(3,KPAR)=SQRT(PMOM)
3442         JDAPAR(1,KPAR)=0
3443         JDAPAR(2,KPAR)=0
3444         JCOPAR(3,KPAR)=0
3445         JCOPAR(4,KPAR)=0
3446       ENDIF
3447   999 END
3448 CDECK  ID>, HWBRCN.
3449 *CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
3450 *-- Author :    Peter Richardson
3451 C-----------------------------------------------------------------------
3452       SUBROUTINE HWBRCN
3453 C-----------------------------------------------------------------------
3454 C     SUBROUTINE TO REPLACE HWBCON IN RPARITY VIOLATING SUSY
3455 C     BASED ON HWBCON BY BRW
3456 C-----------------------------------------------------------------------
3457       INCLUDE 'HERWIG65.INC'
3458       INTEGER IHEP,IST,ID,JC,JD,JHEP,IDP,IDM,IDP2,IDM2,
3459      &        RHEP,IST2,ORG,ANTC,XHEP,IP,COLP
3460       LOGICAL BVVUSE,BVVHRD,BVDEC1,BVDEC2,COLRD,ACOLRD,BVHRD,BVHRD2,
3461      &        BVDEC3
3462 C--logical functions to decide if baryon number violating
3463 C--BVDEC1 DELTAB=+1
3464       BVDEC1(IP) = ((IDHW(IP).GE.419.AND.IDHW(IP).LE.424).OR.
3465      &              IDHW(IP).EQ.411.OR.IDHW(IP).EQ.412.OR.
3466      &              IDHW(IP).EQ.449).AND.IDHW(JDAHEP(1,IP)).LE.6.
3467      &              AND.IDHW(JDAHEP(1,IP)+1).LE.6.AND.
3468      &              IDHW(JDAHEP(2,IP)).LE.6
3469 C--BVDEC2 DELTAB=-1
3470       BVDEC2(IP) = ((IDHW(IP).GE.413.AND.IDHW(IP).LE.418).OR.
3471      &              IDHW(IP).EQ.405.OR.IDHW(IP).EQ.406.OR.
3472      &              IDHW(IP).EQ.449).AND.
3473      &    IDHW(JDAHEP(1,IP)).GE.7.AND.IDHW(JDAHEP(1,IP)).LE.12.AND.
3474      &    IDHW(JDAHEP(1,IP)+1).GE.7.AND.IDHW(JDAHEP(1,IP)+1).LE.12.AND.
3475      &    IDHW(JDAHEP(2,IP)).GE.7.AND.IDHW(JDAHEP(2,IP)).LE.12
3476 C--Neutralino and Chargino Decays
3477       BVDEC3(IP) = ((IDHW(IP).GE.450.AND.IDHW(IP).LE.457).AND.
3478      &   (IDHW(JDAHEP(1,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)+1).LE.12.
3479      &    .AND.IDHW(JDAHEP(2,IP)).LE.12))
3480 C--Now the hard vertices
3481       BVHRD(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
3482      &    AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).LE.12.
3483      &    AND.IDHW(JDAHEP(2,IP)).GE.449.AND.IDHW(JDAHEP(2,IP)).LE.457
3484       BVHRD2(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
3485      &    AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).GE.198.
3486      &    AND.IDHW(JDAHEP(1,IP)).LE.207.
3487      &    AND.ABS(IDHEP(JDAHEP(2,IP))).GT.1000000
3488 C--Those particles which are coloured
3489       COLRD(IP) = IP.LE.6.OR.IP.EQ.13.OR.IP.EQ.449.OR.
3490      &   (IP.GE.401.AND.IP.LE.406).OR.(IP.GE.413.AND.IP.LE.418).OR.
3491      &   (IP.GE.115.AND.IP.LE.120).OR.IP.EQ.59
3492 C--Those particles which are anticoloured
3493       ACOLRD(IP) = (IP.GE.7.AND.IP.LE.12).OR.IP.EQ.13.OR.IP.EQ.449.OR.
3494      & (IP.GE.407.AND.IP.LE.412).OR.(IP.GE.419.AND.IP.LE.424).OR.
3495      & (IP.GE.109.AND.IP.LE.114).OR.IP.EQ.59
3496       IF (IERROR.NE.0) RETURN
3497 C--Added 31/03/00 PR
3498       IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBRCN',101,*999)
3499       COLP = 0
3500       IF(COLUPD.AND.HRDCOL(1,3).NE.0) THEN
3501         JD = 0
3502         DO IHEP = HRDCOL(1,3),HRDCOL(1,3)+4
3503           JD = JD+1
3504           IF(JD.NE.3) THEN
3505             JMOHEP(2,IHEP) = HRDCOL(1,JD)
3506             JDAHEP(2,IHEP) = HRDCOL(2,JD)
3507           ENDIF
3508         ENDDO
3509         COLUPD=.FALSE.
3510         DO IHEP=1,5
3511           DO JHEP=1,2
3512             HRDCOL(JHEP,IHEP)=0
3513           ENDDO
3514         ENDDO
3515       ELSEIF(COLUPD) THEN
3516         RETURN
3517       ENDIF
3518       DO 110 IHEP=1,NHEP
3519       IST=ISTHEP(IHEP)
3520       JD =0
3521       BVVUSE = .FALSE.
3522       BVVHRD = .FALSE.
3523 C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
3524       IF ((IST.LT.145.OR.IST.GT.152).AND.IST.NE.155) GOTO 110
3525       IF (JMOHEP(2,IHEP).EQ.0) THEN
3526 C---FIND COLOUR-CONNECTED PARTON
3527         IF(IST.EQ.155.AND.ABS(IDHEP(IHEP)).EQ.6) THEN
3528           JC = JMOHEP(1,IHEP)
3529         ELSEIF(IST.EQ.155) THEN
3530           GOTO 110
3531         ELSE
3532           JC=JMOHEP(1,IHEP)
3533         ENDIF
3534         IF (IST.NE.152) JC=JMOHEP(1,JC)
3535 C--Correction for BV
3536         IF(HRDCOL(1,1).NE.0) THEN
3537           IDP = IDHW(HRDCOL(1,1))
3538           IDP2 = 0
3539         ELSE
3540           IDP  = 0
3541           IDP2 = 0
3542         ENDIF
3543         IDM = JMOHEP(1,JC)
3544         IF(BVDEC1(IDM).OR.BVDEC2(IDM)) THEN
3545           IF(IDHW(IDM).EQ.449.AND.JDAHEP(1,IDM).EQ.JC) THEN
3546             JC=JMOHEP(2,JC)
3547           ELSE
3548             JD = JMOHEP(2,JC)
3549             JC = IDM
3550             IF(JC.EQ.JD) JD= JDAHEP(2,JC-1)
3551             BVVUSE = .TRUE.
3552           ENDIF
3553 C--NEW FOR BV HARD PROCESS
3554         ELSEIF(BVHRD(IDM)) THEN
3555           IF(IDHW(JDAHEP(2,JMOHEP(1,JC))).EQ.449) THEN
3556             JD   = JMOHEP(2,JC)
3557             IDM2 = JDAHEP(2,HRDCOL(1,2))
3558             IF(JD.EQ.IDM2) JD = HRDCOL(1,1)
3559             IF(JC.EQ.JDAHEP(2,IDM2).AND.COLRD(IDHW(IHEP))) THEN
3560               JC = JMOHEP(2,JC)
3561             ELSEIF(JC.EQ.IDM2) THEN
3562               IF(JDAHEP(2,JMOHEP(2,JC)).EQ.JC) THEN
3563                 JC = JMOHEP(2,JC)
3564               ELSE
3565               JMOHEP(2,IHEP)=JMOHEP(2,JC)
3566               GOTO 110
3567               ENDIF
3568             ELSE
3569               JC = HRDCOL(1,1)
3570               BVVUSE = .TRUE.
3571               BVVHRD = .TRUE.
3572               IF(ACOLRD(IDHW(IHEP))) JC = JD
3573               IF(JC.EQ.IDM2) GOTO 110
3574             ENDIF
3575           ELSE
3576             JC =JMOHEP(2,JC)
3577             BVVUSE = .TRUE.
3578             BVVHRD = .TRUE.
3579           ENDIF
3580         ELSEIF(BVHRD2(IDM)) THEN
3581           JD = JMOHEP(2,JC)
3582             IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
3583               JMOHEP(2,IHEP)=JMOHEP(2,JC)
3584               GOTO 110
3585             ENDIF
3586           IF(JD.EQ.JDAHEP(2,HRDCOL(1,2))) JD = HRDCOL(1,1)
3587           BVVUSE=.TRUE.
3588           BVVHRD = .TRUE.
3589           IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
3590             JC = JMOHEP(2,JC)
3591           ELSE
3592             JC = HRDCOL(1,1)
3593           ENDIF
3594         ELSE
3595           JC =JMOHEP(2,JC)
3596         ENDIF
3597         IF (JC.EQ.0) CALL HWWARN('HWBCON',51,*110)
3598 C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
3599         IF (ISTHEP(JC).EQ.155) THEN
3600           IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
3601 C---DECAYED BEFORE HADRONIZING
3602             IF(BVVHRD) THEN
3603               JHEP = JC
3604             ELSEIF(BVVUSE) THEN
3605               JHEP=JDAHEP(2,JC-1)
3606             ELSE
3607               JHEP=JMOHEP(2,JC)
3608             ENDIF
3609             IF(JHEP.EQ.0.AND.ABS(IDHEP(JC)).EQ.6) THEN
3610               JHEP = JMOHEP(1,JMOHEP(1,JC))
3611               IF(BVDEC1(JMOHEP(1,JHEP)).OR.BVDEC2(JMOHEP(1,JHEP))) THEN
3612                 JC = JHEP
3613                 JHEP = JDAHEP(2,JC-1)
3614               ELSE
3615                 JHEP = 0
3616               ENDIF
3617             ENDIF
3618             IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
3619      &           ISTHEP(JHEP).NE.155.OR.JHEP.EQ.0) GOTO 110
3620             ID=IDHW(JHEP)
3621             IF (ISTHEP(JHEP).EQ.155) THEN
3622 C---SPECIAL FOR GLUINO DECAYS
3623               IF (ID.EQ.449) THEN
3624                 ID=IDHW(JC)
3625                 IF(BVVUSE) THEN
3626                   ID=IDHW(IHEP)
3627                   IF(ID.LE.6.OR.ID.EQ.13.OR.
3628      &               (ID.GE.115.AND.ID.LE.120)) THEN
3629                     ID = 7
3630                   ELSE
3631                     ID = 1
3632                   ENDIF
3633                 ENDIF
3634                 CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
3635                 IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
3636               ELSE
3637                 JC=JDAHEP(2,JHEP)
3638                 IF(COLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JHEP)).EQ.449)
3639      &             JC=JDAHEP(1,JHEP)
3640                 IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
3641               ENDIF
3642             ELSE
3643               IF(BVVUSE) THEN
3644                 IF(BVDEC2(JMOHEP(1,JHEP)).OR.JD.NE.JHEP.OR.
3645      &            BVHRD(JMOHEP(1,JHEP)).OR.BVHRD2(JMOHEP(1,JHEP))) THEN
3646                   JC = JD
3647                   GOTO 100
3648                 ELSE
3649                   JMOHEP(2,IHEP)=JHEP
3650                   ID = IDHW(JHEP)
3651                   IF((ID.GE.7.AND.ID.LE.12).OR.
3652      &               (ID.GE.109.AND.ID.LE.114)) JMOHEP(2,JHEP)=IHEP
3653                 ENDIF
3654               ELSE
3655 C--new for particles connected to BV
3656                 IDM = JMOHEP(1,JHEP)
3657                 IF(BVDEC1(IDM).OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
3658                   JC = JHEP
3659                   IF(ABS(IDHEP(IHEP)).LT.1000000) GOTO 100
3660                   JMOHEP(2,IHEP)=JHEP
3661                   GOTO 110
3662                 ENDIF
3663 C--new for top's from BV
3664                 ID = IDHW(JC)
3665                 IDP  = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
3666                 IF((ID.EQ.6.AND.(BVDEC1(IDP))).
3667      &              OR.(ID.EQ.12.AND.BVDEC2(IDP)).
3668      &              OR.((ID.EQ.12.OR.ID.EQ.449).AND.BVHRD(IDP))) THEN
3669                    JMOHEP(2,IHEP)=JHEP
3670                    IF(JDAHEP(2,JHEP).EQ.JC) JDAHEP(2,JHEP)=IHEP
3671                 ELSE
3672                   IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12.
3673      &               AND.IDHW(JHEP).GE.7.AND.IDHW(JHEP).LE.12).OR.
3674      &               (IDHW(IHEP).LE.6.AND.IDHW(JHEP).LE.6)) THEN
3675                     JMOHEP(2,IHEP)=JHEP
3676                   ELSE
3677                     JMOHEP(2,IHEP)=JHEP
3678                     IF((COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(JHEP))).OR.
3679      &                (.NOT.COLRD(IDHW(IHEP)).AND.
3680      &                .NOT.ACOLRD(IDHW(JHEP)))) THEN
3681                       IF(JDAHEP(2,JHEP).EQ.0) THEN
3682                         JDAHEP(2,JHEP)=IHEP
3683                       ELSEIF(JMOHEP(2,JDAHEP(2,JHEP)).NE.JHEP) THEN
3684                         JDAHEP(2,JHEP)=IHEP
3685                       ENDIF
3686                     ELSE
3687                       IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
3688                     ENDIF
3689                   ENDIF
3690                 ENDIF
3691               ENDIF
3692               GOTO 110
3693             ENDIF
3694           ELSE
3695             JC=JMOHEP(2,JC)
3696           ENDIF
3697         ENDIF
3698  100    CONTINUE
3699         IF(BVVUSE.AND.ABS(IDHEP(JC)).LT.1000000.AND.JC.NE.JD
3700      &     .AND.JD.NE.0.AND.JD.NE.JMOHEP(1,JC)) JC = JD
3701         IF(BVVUSE.AND.ABS(IDHEP(JC)).GT.1000000) THEN
3702           IF(COLRD(IDHW(IHEP)).AND..NOT.BVVHRD) GOTO 110
3703         ENDIF
3704         IF(BVVUSE.AND.ISTHEP(JC).EQ.149) JC=JMOHEP(1,JMOHEP(1,JC))
3705 C--SEARCH IN THE JET
3706         IF((ISTHEP(JC).GT.145.AND.ISTHEP(JC).LT.152).AND.
3707      &     ISTHEP(IHEP).EQ.155) THEN
3708           JMOHEP(2,IHEP) = JC
3709           GOTO 110
3710         ENDIF
3711         CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,BVVHRD)
3712         IF(COLP.NE.0) THEN
3713           JMOHEP(2,IHEP) = COLP
3714           IF(COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(COLP)).
3715      &       AND.JDAHEP(2,COLP).EQ.0)
3716      &      JDAHEP(2,COLP) = IHEP
3717           IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12).AND.
3718      &       (IDHW(COLP).GE.7.AND.IDHW(COLP).LE.12)) THEN
3719              IF(JMOHEP(2,COLP).EQ.0) JMOHEP(2,COLP) = IHEP
3720           ENDIF
3721         ENDIF
3722       ENDIF
3723   110 CONTINUE
3724 C---BREAK COLOUR CONNECTIONS WITH PHOTONS modified for Rslash
3725       IHEP=1
3726   130 IF (IHEP.LE.NHEP) THEN
3727         IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149.AND.
3728      &      (JMOHEP(2,IHEP).NE.IHEP.OR.JDAHEP(2,IHEP).NE.IHEP)) THEN
3729           IF(JMOHEP(2,IHEP).NE.0) THEN
3730           IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
3731      &      JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
3732           ENDIF
3733           IF (JDAHEP(2,IHEP).NE.0) THEN
3734             IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
3735      &        JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
3736           ENDIF
3737           DO RHEP=1,NHEP
3738             IST=ISTHEP(RHEP)
3739             IF((IST.GE.147.AND.IST.LE.149).AND.JDAHEP(2,RHEP).EQ.IHEP)
3740      &        JDAHEP(2,RHEP)=JMOHEP(2,IHEP)
3741           ENDDO
3742           DO RHEP=1,NHEP
3743             IST=ISTHEP(RHEP)
3744             IF((IST.GE.147.AND.IST.LE.149).AND.JMOHEP(2,RHEP).EQ.IHEP)
3745      &        JMOHEP(2,RHEP) = JDAHEP(2,IHEP)
3746           ENDDO
3747           JMOHEP(2,IHEP)=IHEP
3748           JDAHEP(2,IHEP)=IHEP
3749         ENDIF
3750         IHEP=IHEP+1
3751         GOTO 130
3752       ENDIF
3753 C--Update the BV anticolour corrections
3754       DO 210 IHEP=1,NHEP+1
3755       IF(IHEP.EQ.1) GOTO 210
3756       IST2 = 0
3757       IF(IHEP.EQ.NHEP+1) THEN
3758         ANTC = HRDCOL(1,1)
3759         IF(ANTC.EQ.0.OR.(IDHW(JMOHEP(1,HRDCOL(1,2))).LE.6)) GOTO 210
3760         IST=155
3761         XHEP=HRDCOL(1,2)
3762         IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
3763         IF(ANTC.NE.0.AND.JDAHEP(1,ANTC).NE.0) IST2=ISTHEP(ANTC)
3764       ELSE
3765         ANTC = JDAHEP(2,IHEP-1)
3766         IF(ANTC.NE.0) IST2=ISTHEP(ANTC)
3767         IST=ISTHEP(IHEP)
3768         IDM = IDHW(IHEP)
3769         XHEP=IHEP
3770       ENDIF
3771       JC = 0
3772       JHEP = 0
3773       JD = 0
3774       ORG = 0
3775       IF(IST.EQ.155.AND.IST2.EQ.155) THEN
3776         IDM = IDHW(XHEP)
3777         ORG = ANTC
3778         IF(BVDEC1(XHEP).OR.BVDEC2(XHEP).OR.BVHRD(XHEP).OR.
3779      &     BVHRD2(XHEP)) THEN
3780           JC=ANTC
3781           ID = IDHW(JC)
3782           JHEP = JC
3783           IF(BVDEC1(JC).OR.BVDEC2(JC)) THEN
3784             IF(IHEP.EQ.(NHEP+1)) ANTC=JDAHEP(1,JC)
3785             GOTO 200
3786           ENDIF
3787           IF (ID.EQ.449) THEN
3788 C--SPECIAL FOR GLUINO DECAYS
3789             ID=IDHW(XHEP)
3790             IF(IHEP.EQ.NHEP+1) ID = 407
3791             CALL HWBRC1(JC,ID,JHEP,.FALSE.,*999)
3792           ELSE
3793             IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
3794               JC=JDAHEP(1,JHEP)
3795             ELSE
3796               JC=JDAHEP(2,JHEP)
3797             ENDIF
3798           ENDIF
3799 C--SEARCH IN JET
3800           CALL HWBRC2(COLP,XHEP,JC,.FALSE.,BVVUSE,.FALSE.)
3801           ANTC = COLP
3802           IF(IHEP.LE.NHEP.AND.ACOLRD(IDHW(IHEP)).AND.
3803      &       COLRD(IDHW(COLP)).AND.JMOHEP(2,COLP).EQ.0) THEN
3804              JMOHEP(2,COLP) = IHEP
3805           ELSEIF(IHEP.LE.NHEP.AND.IDHW(IHEP).LE.6.AND.
3806      &       IDHW(COLP).LE.6.AND.JDAHEP(2,COLP).EQ.0) THEN
3807              JDAHEP(2,COLP) = IHEP
3808           ELSEIF(IHEP.GT.NHEP.AND.
3809      &       ((BVHRD(XHEP).AND.COLRD(JDAHEP(1,XHEP))).
3810      &       OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
3811      &       ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
3812             JDAHEP(2,COLP) = IHEP
3813           ENDIF
3814         ENDIF
3815       ENDIF
3816   200 CONTINUE
3817       IF(IHEP.EQ.NHEP+1) THEN
3818         IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) THEN
3819           HRDCOL(1,1)=ANTC
3820         IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
3821           IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
3822      &    AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
3823      &      THEN
3824             JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
3825           ELSE
3826             JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3827           ENDIF
3828         ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
3829           JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3830         ENDIF
3831         ENDIF
3832       ELSEIF(IHEP.NE.1) THEN
3833         IF(JDAHEP(2,IHEP-1).NE.ANTC.AND.ANTC.NE.0) JDAHEP(2,IHEP-1)=ANTC
3834       ENDIF
3835  210  CONTINUE
3836 C--Update BV decaying particles connections
3837       DO 310 IHEP=1,NHEP+1
3838       IF(IHEP.EQ.1) GOTO 310
3839       IF(IHEP.EQ.NHEP+1) THEN
3840         ANTC=HRDCOL(1,1)
3841         IF(ANTC.EQ.0.OR.IDHW(JDAHEP(1,HRDCOL(1,2))).LE.6) GOTO 310
3842         IST=155
3843         XHEP=HRDCOL(1,2)
3844         IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
3845       ELSE
3846         ANTC=JMOHEP(2,IHEP)
3847         IST=ISTHEP(IHEP)
3848         IDM = IDHW(IHEP)
3849         XHEP=IHEP
3850       ENDIF
3851       IST2 = 0
3852       JC = 0
3853       JD = 0
3854       IF(ANTC.NE.0.AND.IHEP.NE.NHEP+1) THEN
3855         IF(JDAHEP(1,ANTC).NE.0) IST2 = ISTHEP(ANTC)
3856       ELSEIF(ANTC.NE.0.AND.IHEP.EQ.NHEP+1) THEN
3857         IST2=ISTHEP(ANTC)
3858       ENDIF
3859       IF(IST.EQ.155.AND.IST2.EQ.155) THEN
3860         IF(BVDEC2(XHEP).OR.BVHRD(XHEP).OR.BVHRD2(XHEP)) THEN
3861 C--FIND COLOUR CONNECTED PARTON
3862           JC = ANTC
3863           ID=IDHW(JC)
3864           JHEP = JC
3865           IF(BVDEC2(JHEP)) THEN
3866              ANTC=JC
3867              GOTO 300
3868           ENDIF
3869           IF (ID.EQ.449) THEN
3870             ID=IDHW(XHEP)
3871             IF(IHEP.EQ.NHEP+1) ID = 401
3872 C--SPECIAL FOR GLUINO DECAYS
3873             CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
3874           ELSE
3875             IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
3876               JC=JDAHEP(1,JHEP)
3877             ELSE
3878               JC=JDAHEP(2,JHEP)
3879             ENDIF
3880           ENDIF
3881 C--SEARCH IN JET
3882           CALL HWBRC2(COLP,XHEP,JC,.TRUE.,BVVUSE,.FALSE.)
3883           ANTC = COLP
3884           IF(COLP.EQ.0) GOTO 300
3885           IF(IHEP.LE.NHEP) THEN
3886             IF(JDAHEP(2,COLP).EQ.0) THEN
3887               JDAHEP(2,COLP) = JDAHEP(2,IHEP)
3888             ELSEIF(JMOHEP(2,JDAHEP(2,COLP)).NE.COLP) THEN
3889               JDAHEP(2,COLP) = JDAHEP(2,IHEP)
3890             ENDIF
3891           ELSEIF(IHEP.GT.NHEP.AND.
3892      &       ((BVHRD(XHEP).AND.ACOLRD(JDAHEP(1,XHEP)).AND.
3893      &       IDHW(JDAHEP(2,XHEP)).EQ.449).
3894      &       OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
3895      &       ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
3896             JDAHEP(2,COLP) = IHEP
3897           ENDIF
3898         ENDIF
3899       ENDIF
3900   300 CONTINUE
3901       IF(IHEP.NE.NHEP+1.AND.IHEP.NE.1) THEN
3902         IF(JMOHEP(2,IHEP).NE.ANTC.AND.ANTC.NE.0) JMOHEP(2,IHEP)=ANTC
3903       ELSEIF(IHEP.GT.NHEP) THEN
3904         IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) HRDCOL(1,1)=ANTC
3905         IF(ANTC.EQ.0) GOTO 310
3906         IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
3907           IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
3908      &    AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
3909      &      THEN
3910             JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
3911           ELSE
3912             JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3913           ENDIF
3914         ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
3915           JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3916         ENDIF
3917       ENDIF
3918  310  CONTINUE
3919 C--Update partons connected to decaying SUSY particle
3920       DO 400 IHEP=1,NHEP
3921       IST=ISTHEP(IHEP)
3922 C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
3923       IF (IST.LT.145.OR.IST.GT.152) GOTO 400
3924       IF(JMOHEP(2,IHEP).EQ.0) GOTO 400
3925       IF(ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
3926 C--FIND THE COLOUR CONNECTED PARTON
3927         JC=JMOHEP(2,IHEP)
3928         ID=IDHW(JC)
3929         JHEP = JC
3930         IF(BVDEC2(JC).AND.IDHW(JC).NE.449) THEN
3931           IF(IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12)
3932      &          JMOHEP(2,IHEP)=JDAHEP(1,JC)
3933           GOTO 400
3934         ENDIF
3935         IF (ID.EQ.449) THEN
3936 C--SPECIAL FOR GLUINO DECAYS
3937           ID=IDHW(IHEP)
3938           CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
3939         ELSE
3940           ID=IDHW(IHEP)
3941           IF(COLRD(ID).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
3942             JC=JDAHEP(1,JHEP)
3943           ELSE
3944             JC=JDAHEP(2,JHEP)
3945             IF(IDHW(JHEP).EQ.6.AND.IDHW(JC).EQ.13) JC=JC-1
3946           ENDIF
3947         ENDIF
3948 C--SEARCH IN JET
3949         CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,.FALSE.)
3950         JMOHEP(2,IHEP) = COLP
3951       ENDIF
3952  400  CONTINUE
3953 C--Update partons connected to decaying SUSY particle
3954       DO 500 IHEP=1,NHEP
3955       IST=ISTHEP(IHEP)
3956 C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
3957       IF (IST.LT.145.OR.IST.GT.152) GOTO 500
3958       IF(JDAHEP(2,IHEP).EQ.0) GOTO 500
3959       IF(ISTHEP(JDAHEP(2,IHEP)).EQ.155) THEN
3960 C--FIND THE COLOUR CONNECTED PARTON
3961         JC=JDAHEP(2,IHEP)
3962         ID=IDHW(JC)
3963         ID=IDHW(JC)
3964         IF (ID.EQ.449) THEN
3965           ID=IDHW(IHEP)
3966 C--SPECIAL FOR GLUINO DECAYS
3967           JHEP = JC
3968           CALL  HWBRC1(JC,ID,JHEP,.FALSE.,*999)
3969         ELSE
3970           IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
3971             JC = JDAHEP(1,JC)
3972           ELSE
3973             JC=JDAHEP(2,JC)
3974           ENDIF
3975         ENDIF
3976 C--SEARCH IN THE JET
3977         CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
3978         IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
3979       ENDIF
3980  500  CONTINUE
3981 C--Flavour and anticolour connections in Rslash
3982       DO 610 IHEP=1,NHEP
3983         IST=ISTHEP(IHEP)
3984         IF(IST.LT.145.OR.IST.GT.152.OR.JDAHEP(2,IHEP).NE.0) GOTO 610
3985         JD = 0
3986         BVVUSE = .FALSE.
3987         JC = JMOHEP(1,IHEP)
3988         IF(IST.NE.152) JC = JMOHEP(1,JC)
3989         IF(JC.EQ.0) CALL HWWARN('HWBRCN',51,*610)
3990 C--For particles which came from a top decay
3991         IF(ABS(IDHEP(JMOHEP(1,JC))).EQ.6) THEN
3992           JD = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
3993 C--flavour connect to self if needed
3994           IF(JDAHEP(2,JMOHEP(1,JC)-1).EQ.JMOHEP(1,JC)) THEN
3995             JDAHEP(2,IHEP) = IHEP
3996             GOTO 610
3997           ELSEIF(JDAHEP(2,JMOHEP(1,JC)-1).NE.0) THEN
3998             JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
3999             GOTO 610
4000           ELSE
4001             JC = JD
4002           ENDIF
4003         ENDIF
4004 C--Decide if this came from a BV decay
4005         IDM = JMOHEP(1,JC)
4006         IF(BVDEC1(IDM).OR.BVDEC2(IDM).OR.BVDEC3(IDM).
4007      &     OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
4008 C--Do BV piece
4009           IF(JDAHEP(2,JC).EQ.JMOHEP(1,JC)) THEN
4010            IF(IDHW(JMOHEP(1,JC)).EQ.449.AND.
4011      &        JDAHEP(1,JMOHEP(1,JC)).EQ.JC) THEN
4012               JC = JDAHEP(2,JMOHEP(1,JC)-1)
4013             ELSE
4014               JC = JMOHEP(2,JMOHEP(1,JC))
4015             ENDIF
4016             IF(ABS(IDHEP(JC)).LT.1000000) THEN
4017               IF(JDAHEP(1,JC).EQ.0) THEN
4018                 JDAHEP(2,IHEP) = JC
4019                 GOTO 610
4020               ELSE
4021                 GOTO 600
4022               ENDIF
4023             ELSEIF(ABS(IDHEP(JC)).GT.1000000
4024      &        .AND.ISTHEP(JC).NE.155) THEN
4025               GOTO 610
4026             ENDIF
4027             IF(ISTHEP(JC).EQ.155.AND.ACOLRD(IDHW(IHEP))) THEN
4028               JC = JDAHEP(1,JC)
4029             ELSE
4030               IF(ISTHEP(JC).EQ.155.AND.IDHW(JDAHEP(1,JC)).NE.449) THEN
4031                 JC = JDAHEP(1,JC)
4032               ELSE
4033                 JC = JDAHEP(2,JC)
4034               ENDIF
4035             ENDIF
4036           ELSE
4037 C--For the hard process
4038             IF(IDHW(IDM).EQ.15.AND.JC.EQ.JDAHEP(2,JMOHEP(1,JC))) THEN
4039               JDAHEP(2,IHEP) = JDAHEP(2,JC)
4040               GOTO 610
4041             ELSEIF(IDHW(IDM).EQ.15.AND.IDHW(IHEP).NE.449) THEN
4042               JD=HRDCOL(1,1)
4043               IF(BVHRD(IDM).AND.IDHW(JDAHEP(2,IDM)).NE.449) THEN
4044                 JC = JDAHEP(2,JC)
4045                 GOTO 600
4046               ELSEIF(JMOHEP(1,JDAHEP(2,JC)).EQ.JD) THEN
4047                 JC=JDAHEP(2,JC)
4048                 GOTO 600
4049               ENDIF
4050               IF(JDAHEP(2,JC).EQ.8) JC = JD
4051             ELSE
4052               JD=JMOHEP(2,JMOHEP(1,JC))
4053             ENDIF
4054             IF(COLRD(IDHW(IHEP)).AND..NOT.ACOLRD(IDHW(IHEP)).AND.
4055      &      ABS(IDHEP(JD)).GT.1000000.AND.ISTHEP(JD).NE.155) THEN
4056               JDAHEP(2,IHEP) = JD
4057               IF(JDAHEP(2,JD).EQ.0) JDAHEP(2,JD) = IHEP
4058             ENDIF
4059             IF(ABS(IDHEP(JD)).GT.1000000
4060      &        .AND.ISTHEP(JD).NE.155) GOTO 610
4061             IF(ISTHEP(JC).EQ.149) THEN
4062               JDAHEP(2,IHEP)=JC
4063               GOTO 610
4064             ENDIF
4065           IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JC).EQ.449.AND.BVDEC2(JC)) THEN
4066               JC = JDAHEP(1,JC)
4067             ELSE
4068               JC = JDAHEP(2,JC)
4069             ENDIF
4070           ENDIF
4071 C--SEARCH IN THE JET
4072  600      CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4073           IF(COLP.NE.0) THEN
4074             IF(ABS(IDHEP(COLP)).EQ.6.AND.JDAHEP(1,COLP).NE.0) THEN
4075               IF(ISTHEP(COLP).EQ.155) THEN
4076                 JC = JDAHEP(2,COLP)
4077               ELSE
4078                 JC = JDAHEP(2,JDAHEP(2,COLP))
4079               ENDIF
4080               GOTO 600
4081             ENDIF
4082             JDAHEP(2,IHEP) = COLP
4083           ENDIF
4084         ELSE
4085 C--check if it came from a top
4086           IF(ABS(IDHEP(JC)).EQ.6) THEN
4087 C--start the analysis again
4088             JC = JMOHEP(1,IHEP)
4089             IF(IST.NE.152) JC = JMOHEP(1,JC)
4090             JC = JDAHEP(2,JC)
4091             IF(JC.EQ.0) CALL HWWARN('HWBRCN',52,*610)
4092               IF(ISTHEP(JC).EQ.155) THEN
4093                 IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
4094 C---DECAYED BEFORE HADRONIZING
4095                   JHEP=JDAHEP(2,JC-1)
4096                   IF (JHEP.EQ.0) GO TO 610
4097                   ID=IDHW(JHEP)
4098                   IF (ISTHEP(JHEP).EQ.155) THEN
4099 C---SPECIAL FOR GLUINO DECAYS
4100                     IF (ID.EQ.449) THEN
4101                       CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
4102                     ELSE
4103                       JC=JDAHEP(2,JHEP)
4104                     ENDIF
4105                   ELSE
4106                     IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
4107                     JDAHEP(2,IHEP) = JHEP
4108                     GOTO 610
4109                   ENDIF
4110                 ELSE
4111                   JC=JDAHEP(2,JC-1)
4112                 ENDIF
4113               ENDIF
4114 C--SEARCH IN JET
4115               CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4116               IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
4117           ELSE
4118             IF(ISTHEP(JMOHEP(1,JC)).EQ.155
4119      &            .AND.IDHW(JC).LE.6) THEN
4120                JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
4121                IF(JDAHEP(2,IHEP).NE.0) GOTO 610
4122             ENDIF
4123             CALL HWWARN('HWBRCN',100,*610)
4124           ENDIF
4125         ENDIF
4126  610  CONTINUE
4127  999  END
4128 CDECK  ID>, HWBRC1.
4129 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
4130 *-- Author :    PeterRichardson
4131 C-----------------------------------------------------------------------
4132       SUBROUTINE HWBRC1(JC,ID,JHEP,COL,*)
4133 C-----------------------------------------------------------------------
4134 C--Function to find the right daugther of a decaying gluino
4135 C-----------------------------------------------------------------------
4136       INCLUDE 'HERWIG65.INC'
4137       INTEGER ID,JHEP,KC,JC
4138       LOGICAL COL
4139 C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
4140 C--Rparity take the first daughther
4141       IF(IDHW(JDAHEP(1,JHEP)).LE.12.AND.IDHW(JDAHEP(1,JHEP)+1).LE.12
4142      &   .AND.IDHW(JDAHEP(2,JHEP)).LE.12) THEN
4143         KC = JDAHEP(1,JHEP)
4144         GOTO 20
4145       ELSEIF ((COL.AND.(ID.EQ.449.OR.ID.EQ.13)).OR.
4146      &        (ID.GE.401.AND.ID.LE.406).OR.
4147      &       (ID.GE.413.AND.ID.LE.418).OR.ID.LE.6.OR.
4148      &       (ID.GE.115.AND.ID.LE.120)) THEN
4149 C---LOOK FOR ANTI(S)QUARK OR GLUON
4150         DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
4151           ID=IDHW(KC)
4152           IF ((ID.GE.7.AND.ID.LE.13).OR.(ID.GE.407.AND.ID.LE.412).OR.
4153      &       (ID.GE.419.AND.ID.LE.424)) GOTO 20
4154         ENDDO
4155       ELSE
4156 C---LOOK FOR (S)QUARK OR GLUON
4157         DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
4158           ID=IDHW(KC)
4159           IF (ID.LE.  6.OR. ID.EQ. 13.OR.(ID.GE.401.AND.ID.LE.406).OR.
4160      &       (ID.GE.413.AND.ID.LE.418)) GOTO 20
4161         ENDDO
4162       ENDIF
4163 C---COULDNT FIND ONE
4164       CALL HWWARN('HWBRC1',100,*10)
4165  10   RETURN 1
4166  20   JC=KC
4167       END
4168 CDECK  ID>, HWBRC2.
4169 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
4170 *-- Author :    Peter Richardson
4171 C-----------------------------------------------------------------------
4172       SUBROUTINE HWBRC2(COLP,IHEP,JC,CON,BVVUSE,BVVHRD)
4173 C-----------------------------------------------------------------------
4174 C--Function to search in the jet for the particle
4175 C-----------------------------------------------------------------------
4176       INCLUDE 'HERWIG65.INC'
4177       INTEGER JC,JD,QHEP,LHEP,IHEP,JHEP,IDM,NCOUNT,ID,IP,IDM2,COLP
4178       LOGICAL CON,BVVUSE,FLA,AFLA,BVVHRD
4179       FLA(IP)  = (IP.LE.6.OR.(IP.GE.115.AND.IP.LE.120).
4180      &           OR.(IP.GE.401.AND.IP.LE.406).
4181      &           OR.(IP.GE.413.AND.IP.LE.418))
4182       AFLA(IP) = ((IP.LE.12.AND.IP.GE.7).OR.(IP.GE.109.AND.IP.LE.114).
4183      &           OR.(IP.GE.407.AND.IP.LE.412).
4184      &           OR.(IP.GE.419.AND.IP.LE.424))
4185       ID = IDHW(IHEP)
4186       COLP = 0
4187 C--begining and end of jet
4188       IF(JDAHEP(1,JC).NE.0) THEN
4189         JC=JDAHEP(1,JC)
4190         JD=JDAHEP(2,JC)
4191       ELSE
4192         COLP = JC
4193         RETURN
4194       ENDIF
4195       IF (JD.LT.JC) JD=JC
4196       LHEP=0
4197       IF(CON) THEN
4198 C--SEARCH FOR A COLOUR PARTNER
4199         DO 110 JHEP=JC,JD
4200           IDM = IDHW(JHEP)
4201         IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 110
4202         IF(AFLA(ID).AND.IDM.EQ.13) GOTO 110
4203         IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
4204         IF ((BVVUSE.AND.JMOHEP(2,JHEP).NE.0).OR.
4205      &      (.NOT.BVVUSE.AND.JDAHEP(2,JHEP).NE.0)) GOTO 110
4206         IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000) THEN
4207           IF(BVVHRD.AND.AFLA(ID)) THEN
4208             CONTINUE
4209           ELSE
4210             RETURN
4211           ENDIF
4212         ENDIF
4213         IF(BVVUSE.AND.(
4214      &      ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449).AND.AFLA(IDM)).
4215      &  OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449))))
4216      &     GOTO 110
4217         IF(AFLA(ID).AND.(IDM.EQ.59.OR.IDM.EQ.449.OR.IDM.EQ.13)) GOTO 110
4218 C---JOIN IHEP AND JHEP
4219         COLP=JHEP
4220         IF(BVVUSE.OR.(ID.GE.7.AND.ID.LE.12.
4221      &     AND.((IDM.GE.7.AND.IDM.LE.12)))) RETURN
4222         IF(IHEP.NE.HRDCOL(1,2).AND.
4223      &     (((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.59)
4224      &       .AND.(AFLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449.OR.IDM.EQ.59))
4225      &     .OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.59))))
4226      &    JDAHEP(2,JHEP)=IHEP
4227         RETURN
4228  110    CONTINUE
4229         IF (LHEP.NE.0) COLP=LHEP
4230 C--Additional Baryon number violating piece
4231         IF(COLP.EQ.0) THEN
4232           IDM2= IDHW(JC)
4233          IF(JMOHEP(1,JC).LT.6) THEN
4234            IF(IDM2.LE.6) THEN
4235              IDM2= IDM2+6
4236            ELSEIF(IDM2.GT.6) THEN
4237              IDM2=IDM2-6
4238            ENDIF
4239          ENDIF
4240           IF(IHEP.EQ.HRDCOL(1,2).OR.
4241      &     ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
4242      &       .AND.(AFLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.13))) THEN
4243               QHEP = JD+1
4244  12           QHEP = QHEP-1
4245               IF(IDHEP(QHEP).EQ.0) GOTO 12
4246               IF(IDHW(QHEP).EQ.59) THEN
4247               IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4248                 COLP = IHEP
4249                 RETURN
4250               ELSE
4251                 GOTO 12
4252               ENDIF
4253               ENDIF
4254               NCOUNT = 0
4255  11           IF(JDAHEP(2,QHEP).NE.0) THEN
4256                 IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP.AND.
4257      &             JDAHEP(2,QHEP).NE.QHEP) THEN
4258                  IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
4259                    QHEP = JDAHEP(2,QHEP)
4260                    NCOUNT = NCOUNT+1
4261                    IF(NCOUNT.LT.NHEP) GOTO 11
4262                  ENDIF
4263                 ENDIF
4264               ENDIF
4265             ELSE
4266             QHEP = JC
4267  13         QHEP = QHEP+1
4268             IF(IDHEP(QHEP).EQ.0) GOTO 13
4269             IF(IDHW(QHEP).EQ.59) THEN
4270               IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4271                 COLP = IHEP
4272                 RETURN
4273               ELSE
4274                 GOTO 13
4275               ENDIF
4276             ENDIF
4277             NCOUNT = 0
4278  9          IF(JMOHEP(2,QHEP).NE.0) THEN
4279             IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
4280      &         JMOHEP(2,QHEP).NE.QHEP) THEN
4281                IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
4282                  QHEP = JMOHEP(2,QHEP)
4283                  NCOUNT = NCOUNT+1
4284                  IF(NCOUNT.LT.NHEP) GOTO 9
4285                ENDIF
4286             ENDIF
4287             ENDIF
4288           ENDIF
4289           IF(ABS(IDHEP(QHEP)).LT.1000000) COLP=QHEP
4290         ENDIF
4291       ELSE
4292 C--Search for an anticolour partner
4293         DO 210 JHEP=JC,JD
4294         IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 210
4295         IF (JMOHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
4296         IF (JMOHEP(2,JHEP).NE.0) GOTO 210
4297 C---JOIN IHEP AND JHEP
4298         COLP=JHEP
4299         RETURN
4300  210   CONTINUE
4301        IF (LHEP.NE.0) COLP=LHEP
4302 C--New piece
4303        IF(COLP.EQ.0) THEN
4304          IDM2=IDHW(JC)
4305          IF(JMOHEP(1,JC).LT.6) THEN
4306            IF(IDM2.LE.6) THEN
4307              IDM2= IDM2+6
4308            ELSEIF(IDM2.GT.6) THEN
4309              IDM2=IDM2-6
4310            ENDIF
4311          ENDIF
4312 C--Additional Baryon number violating piece
4313         IF((FLA(ID).AND.AFLA(IDM2)).OR.
4314      & ((AFLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
4315      &    .AND.(FLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.449)
4316      &  .AND..NOT.(IDHW(JMOHEP(1,JC)).EQ.13.AND.
4317      &        IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.12.AND.
4318      &        ISTHEP(JMOHEP(1,JMOHEP(1,JC))).EQ.155)
4319      &        )) THEN
4320 C--special for gluino decay to gluon
4321          IF(ID.EQ.449.AND.IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.449.AND.
4322      &          IDHW(JMOHEP(1,JC)).EQ.13) RETURN
4323          QHEP = JC
4324  211     QHEP = QHEP+1
4325          IF(IDHEP(QHEP).EQ.0) GOTO 211
4326          IF(IDHW(QHEP).EQ.59) THEN
4327            IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4328              COLP = IHEP
4329              RETURN
4330            ELSE
4331              GOTO 211
4332            ENDIF
4333          ENDIF
4334          NCOUNT = 0
4335  209     IF(JMOHEP(2,QHEP).NE.0) THEN
4336            IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
4337      &        JMOHEP(2,QHEP).NE.QHEP) THEN
4338               IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
4339                 QHEP = JMOHEP(2,QHEP)
4340                 NCOUNT = NCOUNT+1
4341                 IF(NCOUNT.LT.NHEP) GOTO 209
4342               ENDIF
4343            ENDIF
4344          ENDIF
4345         IF(QHEP.NE.0) COLP=QHEP
4346         IF(JDAHEP(2,QHEP).EQ.0.AND.IHEP.NE.6) THEN
4347           IDM2= IDHW(QHEP)
4348           IF(FLA(IHEP).AND.FLA(QHEP).OR.
4349      &       ((AFLA(IHEP).OR.ID.EQ.13.OR.ID.EQ.449).AND.
4350      &        (AFLA(QHEP).OR.IDM2.EQ.13.OR.IDM2.EQ.449)))
4351      &        JDAHEP(2,QHEP)=IHEP
4352         ENDIF
4353         ELSE
4354          QHEP = JD+1
4355  220     QHEP = QHEP-1
4356          IF(IDHEP(QHEP).EQ.0) GOTO 220
4357          IF(IDHW(QHEP).EQ.59) THEN
4358            IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4359              COLP = IHEP
4360              RETURN
4361            ELSE
4362              GOTO 220
4363            ENDIF
4364          ENDIF
4365           NCOUNT = 0
4366  219       IF(JDAHEP(2,QHEP).NE.0) THEN
4367             IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP) THEN
4368               IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
4369                 QHEP = JDAHEP(2,QHEP)
4370                 NCOUNT = NCOUNT+1
4371                 IF(NCOUNT.LT.200) GOTO 219
4372               ENDIF
4373             ENDIF
4374           ENDIF
4375         IF(QHEP.NE.0) COLP=QHEP
4376         IDM2 = IDHW(QHEP)
4377         IF(JDAHEP(2,QHEP).EQ.0.AND.
4378      &     (((AFLA(ID).OR.ID.EQ.13).AND.(AFLA(IDM2).OR.IDM2.EQ.13)).OR.
4379      &     (FLA(ID).AND.FLA(IDM2)))) JDAHEP(2,QHEP)=IHEP
4380         ENDIF
4381        ENDIF
4382       ENDIF
4383       END
4384 CDECK  ID>, HWBSPA.
4385 *CMZ :-        -26/04/91  14.26.44  by  Federico Carminati
4386 *-- Author :    Ian Knowles
4387 C-----------------------------------------------------------------------
4388       SUBROUTINE HWBSPA
4389 C-----------------------------------------------------------------------
4390 C     Constructs time-like 4-momenta & production vertices in space-like
4391 C     jet started by parton no.2 interference partner 1 and spin density
4392 C     DECPAR(2). RHOPAR(2) gives the jet spin density matrix.
4393 C     See I.G. Knowles, Comp. Phys. Comm. 58 (90) 271.
4394 C-----------------------------------------------------------------------
4395       INCLUDE 'HERWIG65.INC'
4396       DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EISCR,EINUM,EIDEN1,EIDEN2,
4397      & WT,SPIN,Z1,Z2,TR,PRMAX,CX,SX,CAZ,ROHEP(3),RMAT(3,3),ZERO2(2)
4398       INTEGER IPAR,JPAR,KPAR,LPAR,MPAR,JSTR,LSTR,MSTR
4399       LOGICAL EICOR
4400       EXTERNAL HWRGEN
4401       DATA ZERO2,DMIN/2*0D0,1D-15/
4402       IF (IERROR.NE.0) RETURN
4403       JPAR=2
4404       KPAR=1
4405       IF (NPAR.EQ.2) THEN
4406          CALL HWVZRO(2,RHOPAR(1,2))
4407          RETURN
4408       ENDIF
4409 C Generate azimuthal angle of JPAR's branching using an M-function
4410 C     Find the daughters of JPAR, with LPAR time-like
4411   10  LPAR=JDAPAR(1,JPAR)
4412       IF (TMPAR(LPAR)) THEN
4413          MPAR=LPAR+1
4414       ELSE
4415          MPAR=LPAR
4416          LPAR=MPAR+1
4417       ENDIF
4418 C Soft correlations
4419       CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
4420       CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4421       PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
4422       EIKON=1.
4423       EICOR=AZSOFT.AND.IDPAR(LPAR).EQ.13
4424       IF (EICOR) THEN
4425          IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
4426            EISCR=ONE
4427          ELSE
4428            EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
4429      &           /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
4430          ENDIF
4431          EINUM=PPAR(4,KPAR)*PPAR(4,LPAR)*ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
4432          EIDEN1=PPAR(4,KPAR)*PPAR(4,LPAR)-ROHEP(3)*PPAR(3,LPAR)
4433          EIDEN2=PT*ABS(PPAR(1,LPAR))
4434          EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN),ZERO)
4435       ENDIF
4436 C Spin correlations
4437       WT=ZERO
4438       SPIN=ONE
4439       IF (AZSPIN.AND.IDPAR(JPAR).EQ.13) THEN
4440          Z1=PPAR(4,JPAR)/PPAR(4,MPAR)
4441          Z2=ONE-Z1
4442          IF (IDPAR(MPAR).EQ.13) THEN
4443             TR=Z1/Z2+Z2/Z1+Z1*Z2
4444          ELSEIF (IDPAR(MPAR).LT.13) THEN
4445             TR=(ONE+Z2**2)/(TWO*Z1)
4446          ENDIF
4447          WT=Z2/(Z1*TR)
4448       ENDIF
4449 C Assign the azimuthal angle
4450       PRMAX=(1.+ABS(WT))*EIKON
4451   50  CALL HWRAZM( ONE,CX,SX)
4452       CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
4453 C Determine the angle between the branching planes
4454       CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4455       CAZ=ROHEP(1)/PT
4456       PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
4457       PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
4458       IF (EICOR) EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN),ZERO)
4459       IF (AZSPIN) SPIN=1.+WT*(DECPAR(1,JPAR)*PHIPAR(1,JPAR)
4460      &                       +DECPAR(2,JPAR)*PHIPAR(2,JPAR))
4461       IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
4462 C Construct full 4-momentum of LPAR, sum P-trans of MPAR
4463       PPAR(2,LPAR)=ZERO
4464       PPAR(2,MPAR)=ZERO
4465       CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
4466       CALL HWVDIF(2,PPAR(1,2),PPAR(1,LPAR),PPAR(1,2))
4467 C Test for end of space-like branches
4468       IF (JDAPAR(1,MPAR).EQ.0) GOTO 60
4469 C     Generate new Decay matrix
4470       CALL HWBAZF(MPAR,JPAR,ZERO2,DECPAR(1,JPAR),
4471      &            PHIPAR(1,JPAR),DECPAR(1,MPAR))
4472 C     Advance along the space-like branch
4473       JPAR=MPAR
4474       KPAR=LPAR
4475       GOTO 10
4476 C Retreat along space-like line
4477 C     Assign initial spin density matrix
4478   60  CONTINUE
4479       CALL HWVEQU(2,ZERO2,RHOPAR(1,MPAR))
4480       CALL HWUMAS(PPAR(1,2))
4481       CALL HWVZRO(4,VPAR(1,MPAR))
4482       JSTR=JPAR
4483       LSTR=LPAR
4484       MSTR=MPAR
4485   70  JPAR=JSTR
4486       LPAR=LSTR
4487       MPAR=MSTR
4488       CALL HWVEQU(4,VPAR(1,MPAR),VPAR(1,LPAR))
4489       IF (MPAR.EQ.2) RETURN
4490 C Construct spin density matrix for time-like branch
4491       CALL HWBAZF(MPAR,JPAR,RHOPAR(1,MPAR),PHIPAR(1,JPAR),
4492      &                      DECPAR(1,JPAR),RHOPAR(1,LPAR))
4493 C Evolve time-like side branch
4494       CALL HWBTIM(LPAR,MPAR)
4495 C Construct spin density matrix for space-like branch
4496       CALL HWBAZF(MPAR,JPAR,PHIPAR(1,JPAR),RHOPAR(1,MPAR),
4497      &                      DECPAR(1,LPAR),RHOPAR(1,JPAR))
4498 C Assign production vertex to J
4499       CALL HWVDIF(4,PPAR(1,MPAR),PPAR(1,LPAR),PPAR(1,JPAR))
4500       CALL HWUDKL(IDPAR(JPAR),PPAR(1,JPAR),VPAR(1,JPAR))
4501       CALL HWVSUM(4,VPAR(1,MPAR),VPAR(1,JPAR),VPAR(1,JPAR))
4502 C Find parent and partner of MPAR
4503       MPAR=JPAR
4504       JPAR=JMOPAR(1,MPAR)
4505 C BRW modified here 19/06/01 to avoid compiler-dependent bug
4506 C (overwriting of JPAR etc.)
4507       IPAR=MPAR+1
4508       KPAR=JMOPAR(1,IPAR)
4509       IF (JPAR.EQ.KPAR) THEN
4510          LPAR=MPAR+1
4511       ELSE
4512          LPAR=MPAR-1
4513       ENDIF
4514       JSTR=JPAR
4515       LSTR=LPAR
4516       MSTR=MPAR
4517       GOTO 70
4518       END
4519 CDECK  ID>, HWBSPN.
4520 *CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
4521 *-- Author :    Ian Knowles
4522 C-----------------------------------------------------------------------
4523       SUBROUTINE HWBSPN
4524 C-----------------------------------------------------------------------
4525 C     Constructs appropriate spin density/decay matrix for parton
4526 C     in hard subprocess, otherwise zero. Assignments based upon
4527 C     Comp. Phys. Comm. 58 (1990) 271.
4528 C-----------------------------------------------------------------------
4529       INCLUDE 'HERWIG65.INC'
4530       DOUBLE PRECISION C,V12,V23,V13,TR,C1,C2,C3,R1(2),R2(2)
4531       INTEGER IST
4532       SAVE R1,R2,V12
4533       IF (IERROR.NE.0) RETURN
4534       IST=MOD(ISTHEP(NEVPAR),10)
4535 C Assumed partons processed in the order IST=1,2,3,4
4536       IF (IPROC.GE.100.AND.IPROC.LE.116) THEN
4537 C  An e+e- ---> qqbar g event
4538          IF (IDPAR(2).EQ.13) THEN
4539             RHOPAR(1,2)=GPOLN
4540             RHOPAR(2,2)=0.
4541             RETURN
4542          ENDIF
4543       ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17) THEN
4544          IF (IHPRO.EQ. 7.OR.IHPRO.EQ. 8.OR.
4545      &       IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
4546      &       IHPRO.EQ.15.OR.IHPRO.EQ.16.OR.
4547      &      (IHPRO.GE.21.AND.IHPRO.LE.31)) THEN
4548 C A hard 2 --- > 2 QCD subprocess involving gluons
4549             IF (IST.EQ.2) THEN
4550                CALL HWVEQU(2,RHOPAR(1,2),R1(1))
4551                C=GCOEF(2)/GCOEF(1)
4552                DECPAR(1,2)=C*R1(1)
4553                DECPAR(2,2)=C*R1(2)
4554                RETURN
4555             ELSEIF (IST.EQ.3) THEN
4556                CALL HWVEQU(2,RHOPAR(1,2),R2(1))
4557                V12=R1(1)*R2(1)+R1(2)*R2(2)
4558                TR=1./(GCOEF(1)+GCOEF(2)*V12)
4559                RHOPAR(1,2)= (GCOEF(3)*R1(1)+GCOEF(4)*R2(1))*TR
4560                RHOPAR(2,2)=-(GCOEF(3)*R1(2)+GCOEF(4)*R2(2))*TR
4561                RETURN
4562             ELSEIF (IST.EQ.4) THEN
4563                V13=R1(1)*DECPAR(1,2)+R1(2)*DECPAR(2,2)
4564                V23=R2(1)*DECPAR(1,2)+R2(2)*DECPAR(2,2)
4565                TR=1./(GCOEF(1)+GCOEF(2)*V12+GCOEF(3)*V13+GCOEF(4)*V23)
4566                C1=(GCOEF(2)+GCOEF(5))*TR
4567                C2=(GCOEF(3)+GCOEF(6))*TR
4568                C3=(GCOEF(4)+GCOEF(6))*TR
4569                RHOPAR(1,2)=C1*DECPAR(1,2)+C2*R2(1)+C3*R1(1)
4570                RHOPAR(2,2)=C1*DECPAR(2,2)-C2*R1(2)-C3*R2(2)
4571                RETURN
4572             ENDIF
4573          ENDIF
4574       ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN
4575 C A gluon fusion ---> Higgs event
4576          IF (IST.EQ.2) THEN
4577             IF (IHIGGS.NE.4) THEN
4578                DECPAR(1,2)=RHOPAR(1,2)
4579                DECPAR(2,2)=-RHOPAR(2,2)
4580             ELSE
4581                DECPAR(1,2)=-RHOPAR(1,2)
4582                DECPAR(2,2)=RHOPAR(2,2)
4583             END IF
4584             RETURN
4585          ENDIF
4586       ELSEIF (IPRO.EQ.42) THEN
4587 C A gluon fusion (or qq-bar annihilation) ---> graviton production event
4588          IF (IST.EQ.2) THEN
4589             DECPAR(1,2)=RHOPAR(1,2)
4590             DECPAR(2,2)=RHOPAR(2,2)
4591             RETURN
4592          ENDIF
4593       ENDIF
4594       CALL HWVZRO(2,RHOPAR(1,2))
4595       CALL HWVZRO(2,DECPAR(1,2))
4596       END
4597 CDECK  ID>, HWBSU1.
4598 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
4599 *-- Author :    Bryan Webber, modified by Mike Seymour
4600 C-----------------------------------------------------------------------
4601       FUNCTION HWBSU1(ZLOG)
4602 C-----------------------------------------------------------------------
4603 C     Z TIMES THE INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
4604 C     HWBSU1 IS FOR UPPER PART OF Z INTEGRATION REGION
4605 C-----------------------------------------------------------------------
4606       DOUBLE PRECISION HWBSU1,HWBSUL,Z,ZLOG,U
4607       EXTERNAL HWBSUL
4608       Z=EXP(ZLOG)
4609       U=1.-Z
4610       HWBSU1=HWBSUL(Z)*(1.+U*U)
4611       END
4612 CDECK  ID>, HWBSU2.
4613 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
4614 *-- Author :    Bryan Webber, modified by Mike Seymour
4615 C-----------------------------------------------------------------------
4616       FUNCTION HWBSU2(Z)
4617 C-----------------------------------------------------------------------
4618 C     INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
4619 C     HWBSU2 IS FOR LOWER PART OF Z INTEGRATION REGION
4620 C-----------------------------------------------------------------------
4621       DOUBLE PRECISION HWBSU2,HWBSUL,Z,U
4622       EXTERNAL HWBSUL
4623       U=1.-Z
4624       HWBSU2=HWBSUL(Z)*(1.+Z*Z)/U
4625       END
4626 CDECK  ID>, HWBSUD.
4627 *CMZ :-        -14/07/92  13.28.23  by  Mike Seymour
4628 *-- Author :    Bryan Webber
4629 C-----------------------------------------------------------------------
4630       SUBROUTINE HWBSUD
4631 C-----------------------------------------------------------------------
4632 C     COMPUTES (OR READS) TABLES OF SUDAKOV FORM FACTORS
4633 C-----------------------------------------------------------------------
4634       INCLUDE 'HERWIG65.INC'
4635       DOUBLE PRECISION HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2,G1,G2,QRAT,
4636      & QLAM,POWER,AFAC,QMIN,QFAC,QNOW,ZMIN,ZMAX,Q1,QCOLD,VGOLD,VQOLD,
4637      & RMOLD(6),ACOLD,ZLO,ZHI
4638       INTEGER IQ,IS,L1,L2,L,LL,I,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
4639       EXTERNAL HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2
4640       SAVE NQOLD,NSOLD,NCOLD,NFOLD,SDOLD,QCOLD,VGOLD,VQOLD,RMOLD,ACOLD,
4641      & INOLD
4642       COMMON/HWSINT/QRAT,QLAM
4643       IF (LRSUD.EQ.0) THEN
4644         POWER=1./FLOAT(NQEV-1)
4645         AFAC=6.*CAFAC/BETAF
4646         QMIN=QG+QG
4647         QFAC=(1.1*QLIM/QMIN)**POWER
4648         SUD(1,1)=1.
4649         QEV(1,1)=QMIN
4650 C--IS=1 FOR GLUON->GLUON+GLUON FORM FACTOR
4651         DO 10 IQ=2,NQEV
4652         QNOW=QFAC*QEV(IQ-1,1)
4653         QLAM=QNOW/QCDL3
4654         ZMIN=QG/QNOW
4655         QRAT=1./ZMIN
4656         G1=0
4657         DO 5 I=3,6
4658           ZLO=ZMIN
4659           ZHI=HALF
4660           IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
4661           IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
4662           IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSUG,LOG(ZLO),LOG(ZHI),ACCUR)
4663     5   CONTINUE
4664         SUD(IQ,1)=EXP(AFAC*G1)
4665    10   QEV(IQ,1)=QNOW
4666         AFAC=3.*CFFAC/BETAF
4667 C--QUARK FORM FACTORS.
4668 C--IS=2,3,4,5,6,7 FOR U/D,S,C,B,T,V
4669         DO 15 IS=2,NSUD
4670         Q1=HWBVMC(IS)
4671         IF (IS.EQ.7) Q1=HWBVMC(209)
4672         QMIN=Q1+QG
4673         IF (QMIN.GT.QLIM) GOTO 15
4674         QFAC=(1.1*QLIM/QMIN)**POWER
4675         SUD(1,IS)=1.
4676         QEV(1,IS)=QMIN
4677         DO 14 IQ=2,NQEV
4678         QNOW=QFAC*QEV(IQ-1,IS)
4679         QLAM=QNOW/QCDL3
4680         ZMIN=QG/QNOW
4681         QRAT=1./ZMIN
4682         ZMAX=QG/QMIN
4683         G1=0
4684         DO 12 I=3,6
4685           ZLO=ZMIN
4686           ZHI=ZMAX
4687           IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
4688           IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
4689           IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSU1,LOG(ZLO),LOG(ZHI),ACCUR)
4690    12   CONTINUE
4691         ZMIN=Q1/QNOW
4692         QRAT=1./ZMIN
4693         ZMAX=Q1/QMIN
4694         G2=0
4695         DO 13 I=3,6
4696           ZLO=ZMIN
4697           ZHI=ZMAX
4698           IF (I.NE.6) ZLO=MAX(ZLO,Q1/RMASS(I+1))
4699           IF (I.NE.3) ZHI=MIN(ZHI,Q1/RMASS(I))
4700           IF (ZHI.GT.ZLO) G2=G2+HWUGAU(HWBSU2,ZLO,ZHI,ACCUR)
4701    13   CONTINUE
4702         SUD(IQ,IS)=EXP(AFAC*(G1+G2))
4703    14   QEV(IQ,IS)=QNOW
4704    15   CONTINUE
4705         QCOLD=QCDLAM
4706         VGOLD=VGCUT
4707         VQOLD=VQCUT
4708         ACOLD=ACCUR
4709         INOLD=INTER
4710         NQOLD=NQEV
4711         NSOLD=NSUD
4712         NCOLD=NCOLO
4713         NFOLD=NFLAV
4714         SDOLD=SUDORD
4715         DO 16 IS=1,NSUD
4716    16   RMOLD(IS)=RMASS(IS)
4717       ELSE
4718         IF (LRSUD.GT.0) THEN
4719           IF (IPRINT.NE.0) WRITE (6,17) LRSUD
4720    17     FORMAT(/10X,'READING SUDAKOV TABLE ON UNIT',I4)
4721           OPEN(UNIT=LRSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
4722           READ(UNIT=LRSUD) QCOLD,VGOLD,VQOLD,RMOLD,
4723      &       ACOLD,QEV,SUD,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
4724           CLOSE(UNIT=LRSUD)
4725         ENDIF
4726 C---CHECK THAT RELEVANT PARAMETERS ARE UNCHANGED
4727         IF (QCDLAM.NE.QCOLD) CALL HWWARN('HWBSUD',501,*999)
4728         IF (VGCUT .NE.VGOLD) CALL HWWARN('HWBSUD',502,*999)
4729         IF (VQCUT .NE.VQOLD) CALL HWWARN('HWBSUD',503,*999)
4730         IF (ACCUR .NE.ACOLD) CALL HWWARN('HWBSUD',504,*999)
4731         IF (INTER .NE.INOLD) CALL HWWARN('HWBSUD',505,*999)
4732         IF (NQEV  .NE.NQOLD) CALL HWWARN('HWBSUD',506,*999)
4733         IF (NSUD  .NE.NSOLD) CALL HWWARN('HWBSUD',507,*999)
4734         IF (NCOLO .NE.NCOLD) CALL HWWARN('HWBSUD',508,*999)
4735         IF (NFLAV .NE.NFOLD) CALL HWWARN('HWBSUD',509,*999)
4736         IF (SUDORD.NE.SDOLD) CALL HWWARN('HWBSUD',510,*999)
4737 C---CHECK MASSES AND THAT TABLES ARE BIG ENOUGH FOR THIS RUN
4738         DO 18 IS=1,NSUD
4739           IF (RMASS(IS).NE.RMOLD(IS))
4740      &      CALL HWWARN('HWBSUD',510+IS,*999)
4741           IF (QEV(NQEV,IS).LT.QLIM.AND.HWBVMC(IS)+QG.LT.QLIM)
4742      &      CALL HWWARN('HWBSUD',500,*999)
4743    18   CONTINUE
4744       ENDIF
4745       IF (LWSUD.GT.0) THEN
4746         IF (IPRINT.NE.0) WRITE (6,19) LWSUD
4747    19   FORMAT(/10X,'WRITING SUDAKOV TABLE ON UNIT',I4)
4748         OPEN (UNIT=LWSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
4749         WRITE(UNIT=LWSUD)  QCDLAM,VGCUT,VQCUT,(RMASS(I),I=1,6),
4750      &     ACCUR,QEV,SUD,INTER,NQEV,NSUD,NCOLO,NFLAV,SUDORD
4751         CLOSE(UNIT=LWSUD)
4752       ENDIF
4753       IF (IPRINT.GT.2) THEN
4754 C--PRINT EXTRACTS FROM TABLES OF FORM FACTORS
4755         DO 40 IS=1,NSUD
4756         WRITE(6,20) IS,NQEV
4757    20   FORMAT(1H1//10X,'EXTRACT FROM TABLE OF SUDAKOV FORM FACTOR NO.',
4758      &  I2,' (',I5,' ACTUAL ENTRIES)'//10X,'SUD IS PROBABILITY THAT',
4759      &  ' PARTON WITH GIVEN UPPER LIMIT ON Q WILL REACH THRESHOLD',
4760      &  ' WITHOUT BRANCHING'///2X,8('      Q     SUD ')/)
4761         L2=NQEV/8
4762         L1=L2/32
4763         IF (L1.LT.1) L1=1
4764         DO 40 L=L1,L2,L1
4765         LL=L+7*L2
4766         WRITE(6,30) (QEV(I,IS),SUD(I,IS),I=L,LL,L2)
4767    30   FORMAT(2X,8(F9.2,F7.4))
4768    40   CONTINUE
4769         WRITE(6,50)
4770    50   FORMAT(1H1)
4771       ENDIF
4772   999 END
4773 CDECK  ID>, HWBSUG.
4774 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
4775 *-- Author :    Bryan Webber, modified by Mike Seymour
4776 C-----------------------------------------------------------------------
4777       FUNCTION HWBSUG(ZLOG)
4778 C-----------------------------------------------------------------------
4779 C     Z TIMES INTEGRAND IN EXPONENT OF GLUON SUDAKOV FORM FACTOR
4780 C-----------------------------------------------------------------------
4781       DOUBLE PRECISION HWBSUG,HWBSUL,Z,ZLOG,W
4782       EXTERNAL HWBSUL
4783       Z=EXP(ZLOG)
4784       W=Z*(1.-Z)
4785       HWBSUG=HWBSUL(Z)*(W-2.+1./W)*Z
4786       END
4787 CDECK  ID>, HWBSUL.
4788 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
4789 *-- Author :    Mike Seymour
4790 C-----------------------------------------------------------------------
4791       FUNCTION HWBSUL(Z)
4792 C-----------------------------------------------------------------------
4793 C     LOGARITHMIC PART OF INTEGRAND IN EXPONENT OF SUDAKOV FORM FACTOR.
4794 C     THE SECOND ORDER ALPHAS CASE COMES FROM CONVERTING INTEGRAL OVER
4795 C     Q^2 INTO ONE OVER ALPHAS, WITH FLAVOUR THRESHOLDS.
4796 C-----------------------------------------------------------------------
4797       INCLUDE 'HERWIG65.INC'
4798       DOUBLE PRECISION HWBSUL,HWUALF,Z,QRAT,QLAM,U,AL,BL,QNOW,QMIN,
4799      & BET(6),BEP(6),MUMI(6),MUMA(6),ALMI(6),ALMA(6),FINT(6),ALFINT,
4800      & MUMIN,MUMAX,ALMIN,ALMAX
4801       INTEGER NF
4802       LOGICAL FIRST
4803       EXTERNAL HWUALF
4804       SAVE FIRST,BET,BEP,MUMI,MUMA
4805       COMMON/HWSINT/QRAT,QLAM
4806       DATA FIRST/.TRUE./
4807       ALFINT(AL,BL)=1/BET(NF)*
4808      &        LOG(BL/(AL*(1+BEP(NF)*BL))*(1+BEP(NF)*AL))
4809       HWBSUL=0
4810       U=1.-Z
4811       IF (SUDORD.EQ.1) THEN
4812         AL=LOG(QRAT*Z)
4813         BL=LOG(QLAM*U*Z)
4814         HWBSUL=LOG(1.-AL/BL)
4815       ELSE
4816         IF (FIRST) THEN
4817           DO 10 NF=3,6
4818             BET(NF)=(11*CAFAC-2*NF)/(12*PIFAC)
4819             BEP(NF)=(17*CAFAC**2-(5*CAFAC+3*CFFAC)*NF)/(24*PIFAC**2)
4820      &              /BET(NF)
4821             IF (NF.EQ.3) THEN
4822               MUMI(3)=0
4823               ALMI(3)=1D30
4824             ELSE
4825               MUMI(NF)=RMASS(NF)
4826               ALMI(NF)=HWUALF(1,MUMI(NF))
4827             ENDIF
4828             IF (NF.EQ.6) THEN
4829               MUMA(NF)=1D30
4830               ALMA(NF)=0
4831             ELSE
4832               MUMA(NF)=RMASS(NF+1)
4833               ALMA(NF)=HWUALF(1,MUMA(NF))
4834             ENDIF
4835             IF (NF.NE.3.AND.NF.NE.6) FINT(NF)=ALFINT(ALMI(NF),ALMA(NF))
4836  10       CONTINUE
4837           FIRST=.FALSE.
4838         ENDIF
4839         QNOW=QLAM*QCDL3
4840         QMIN=QNOW/QRAT
4841         MUMIN=  U*QMIN
4842         MUMAX=Z*U*QNOW
4843         IF (MUMAX.LE.MUMIN) RETURN
4844         ALMIN=HWUALF(1,MUMIN)
4845         ALMAX=HWUALF(1,MUMAX)
4846         NF=3
4847  20     IF (MUMIN.GT.MUMA(NF)) THEN
4848           NF=NF+1
4849           GOTO 20
4850         ENDIF
4851         IF (MUMAX.LT.MUMA(NF)) THEN
4852           HWBSUL=ALFINT(ALMIN,ALMAX)
4853         ELSE
4854           HWBSUL=ALFINT(ALMIN,ALMA(NF))
4855           NF=NF+1
4856  30       IF (MUMAX.GT.MUMA(NF)) THEN
4857             HWBSUL=HWBSUL+FINT(NF)
4858             NF=NF+1
4859             GOTO 30
4860           ENDIF
4861           HWBSUL=HWBSUL+ALFINT(ALMI(NF),ALMAX)
4862         ENDIF
4863         HWBSUL=HWBSUL*BET(5)
4864       ENDIF
4865       END
4866 CDECK  ID>, HWBTIM.
4867 *CMZ :-        -26/04/91  14.27.17  by  Federico Carminati
4868 *-- Author :    Ian Knowles
4869 C-----------------------------------------------------------------------
4870       SUBROUTINE HWBTIM(INITBR,INTERF)
4871 C-----------------------------------------------------------------------
4872 C     Constructs full 4-momentum & production vertices in time-like jet
4873 C     initiated by INITBR, interference partner INTERF and spin density
4874 C     RHOPAR(INITBR). DECPAR(INITBR) returns jet's spin density matrix.
4875 C     Includes azimuthal angular correlations between branching planes
4876 C     due to spin (if AZSPIN) using the algorithm of Knowles & Collins.
4877 C     Ses Nucl. Phys. B304 (1988) 794 & Comp. Phys. Comm. 58 (1990) 271.
4878 C-----------------------------------------------------------------------
4879       INCLUDE 'HERWIG65.INC'
4880       DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EINUM,EIDEN1,EIDEN2,EISCR,
4881      & WT,SPIN,Z1,Z2,PRMAX,CAZ,CX,SX,ROHEP(3),RMAT(3,3),ZERO2(2)
4882       INTEGER INITBR,INTERF,IPAR,JPAR,KPAR,LPAR,MPAR,NTRY,JOLD
4883       LOGICAL EICOR,SWAP
4884       EXTERNAL HWRGEN
4885       DATA ZERO2,DMIN/ZERO,ZERO,1.D-15/
4886       IF (IERROR.NE.0) RETURN
4887       JPAR=INITBR
4888       KPAR=INTERF
4889       IF ((JDAPAR(1,JPAR).NE.0).OR.(IDPAR(JPAR).EQ.13)) GOTO 30
4890 C No branching, assign decay matrix
4891       CALL HWVZRO(2,DECPAR(1,JPAR))
4892       RETURN
4893 C Advance up the leader
4894 C     Find the parent and partner of J
4895   10  IPAR=JMOPAR(1,JPAR)
4896       KPAR=JPAR+1
4897 C Generate new Rho
4898       IF (JMOPAR(1,KPAR).EQ.IPAR) THEN
4899 C        Generate Rho'
4900          CALL HWBAZF(IPAR,JPAR,PHIPAR(1,IPAR),RHOPAR(1,IPAR),
4901      &                                   ZERO2,RHOPAR(1,JPAR))
4902       ELSE
4903          KPAR=JPAR-1
4904          IF (JMOPAR(1,KPAR).NE.IPAR)
4905      &   CALL HWWARN('HWBTIM',100,*999)
4906 C        Generate Rho''
4907          CALL HWBAZF(IPAR,KPAR,RHOPAR(1,IPAR),PHIPAR(1,IPAR),
4908      &                         DECPAR(1,KPAR),RHOPAR(1,JPAR))
4909       ENDIF
4910 C Generate azimuthal angle of J's branching
4911   30  IF (JDAPAR(1,JPAR).EQ.0) THEN
4912 C        Final state gluon
4913          CALL HWVZRO(2,DECPAR(1,JPAR))
4914          IF (JPAR.EQ.INITBR) RETURN
4915          GOTO 70
4916       ELSE
4917 C Assign an angle to a branching using an M-function
4918 C        Find the daughters of J
4919          LPAR=JDAPAR(1,JPAR)
4920          MPAR=JDAPAR(2,JPAR)
4921 C Soft correlations
4922          CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
4923          CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4924          PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
4925          EIKON=1.
4926          SWAP=.FALSE.
4927          EICOR=AZSOFT.AND.((IDPAR(LPAR).EQ.13).OR.(IDPAR(MPAR).EQ.13))
4928          IF (EICOR) THEN
4929 C           Rearrange s.t. LPAR is the (softest) gluon
4930             IF (IDPAR(MPAR).EQ.13) THEN
4931                IF (IDPAR(LPAR).NE.13.OR.
4932      &             PPAR(4,MPAR).LT.PPAR(4,LPAR)) THEN
4933                   SWAP=.TRUE.
4934                   LPAR=MPAR
4935                   MPAR=LPAR-1
4936                ENDIF
4937             ENDIF
4938             EINUM=(PPAR(4,KPAR)*PPAR(4,LPAR))
4939      &        *ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
4940             EIDEN1=(PPAR(4,KPAR)*PPAR(4,LPAR))-ROHEP(3)*PPAR(3,LPAR)
4941             EIDEN2=PT*ABS(PPAR(1,LPAR))
4942             IF (ABS(PPAR(2,MPAR)).LT.DMIN) THEN
4943               IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
4944                  EISCR=ONE
4945               ELSE
4946                  CALL HWWARN('HWBTIM',102,*999)
4947               ENDIF
4948             ELSE
4949               EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
4950      &              /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
4951             ENDIF
4952             EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN)
4953          ENDIF
4954 C Spin correlations
4955          WT=0.
4956          SPIN=1.
4957          IF (AZSPIN) THEN
4958             Z1=PPAR(4,LPAR)/PPAR(4,JPAR)
4959             Z2=1.-Z1
4960             IF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).EQ.13) THEN
4961                WT=Z1*Z2/(Z1/Z2+Z2/Z1+Z1*Z2)
4962             ELSEIF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).LT.13) THEN
4963                WT=-2.*Z1*Z2/(Z1*Z1+Z2*Z2)
4964             ENDIF
4965          ENDIF
4966 C Assign the azimuthal angle
4967          PRMAX=(1.+ABS(WT))*EIKON
4968          NTRY=0
4969    50    NTRY=NTRY+1
4970          IF (NTRY.GT.NBTRY) CALL HWWARN('HWBTIM',101,*999)
4971          CALL HWRAZM( ONE,CX,SX)
4972          CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
4973 C Determine the angle between the branching planes
4974          CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4975          CAZ=ROHEP(1)/PT
4976          PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
4977          PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
4978          IF (EICOR) EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN)
4979          IF (AZSPIN) SPIN=1.+WT*(RHOPAR(1,JPAR)*PHIPAR(1,JPAR)
4980      &                          +RHOPAR(2,JPAR)*PHIPAR(2,JPAR))
4981          IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
4982 C Construct full 4-momentum of L and M
4983          JOLD=JPAR
4984          IF (SWAP) THEN
4985            PPAR(1,LPAR)=-PPAR(1,LPAR)
4986            PPAR(1,MPAR)=-PPAR(1,MPAR)
4987            JPAR=MPAR
4988          ELSE
4989            JPAR=LPAR
4990          ENDIF
4991          PPAR(2,LPAR)=0.
4992          CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
4993          PPAR(2,MPAR)=0.
4994          CALL HWUROB(RMAT,PPAR(1,MPAR),PPAR(1,MPAR))
4995 C Assign production vertex to L and M
4996          CALL HWUDKL(IDPAR(JOLD),PPAR(1,JOLD),VPAR(1,LPAR))
4997          CALL HWVSUM(4,VPAR(1,JOLD),VPAR(1,LPAR),VPAR(1,LPAR))
4998          CALL HWVEQU(4,VPAR(1,LPAR),VPAR(1,MPAR))
4999       ENDIF
5000   60  IF (JDAPAR(1,JPAR).NE.0) GOTO 10
5001 C Assign decay matrix
5002       CALL HWVZRO(2,DECPAR(1,JPAR))
5003 C Backtrack down the leader
5004   70  IPAR=JMOPAR(1,JPAR)
5005       KPAR=JDAPAR(1,IPAR)
5006       IF (KPAR.EQ.JPAR) THEN
5007 C        Develop the side branch
5008          JPAR=JDAPAR(2,IPAR)
5009          GOTO 60
5010       ELSE
5011 C        Construct decay matrix
5012          CALL HWBAZF(IPAR,KPAR,DECPAR(1,JPAR),DECPAR(1,KPAR),
5013      &                         PHIPAR(1,IPAR),DECPAR(1,IPAR))
5014       ENDIF
5015       IF (IPAR.EQ.INITBR) RETURN
5016       JPAR=IPAR
5017       GOTO 70
5018   999 END
5019 CDECK  ID>, HWBTOP.
5020 *CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
5021 *-- Author :    Gennaro Corcella
5022 C-----------------------------------------------------------------------
5023       SUBROUTINE HWBTOP
5024 C-----------------------------------------------------------------------
5025       INCLUDE 'HERWIG65.INC'
5026       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,
5027      & X3MIN,X3MAX,X1MIN,X1MAX,QSCALE,GLUFAC,R(3,3),M(3),
5028      & E(3),AW,PTSQ,EM,EPS,MASDEP,A,B,C,GAMDEP,LAMBDA,
5029      & PW(5),PT(5),PW1(5),CS,SN,EPG,QQ,RR,CC
5030       INTEGER ID,ID3,IHEP,KHEP,WHEP,ICMF,K
5031       EXTERNAL HWBVMC,HWUALF,HWUSQR,HWRGEN
5032       LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
5033 C---FIND AN UNTREATED CMF
5034       ICMF=0
5035       DO 10 IHEP=1,NHEP
5036 C----FIND A DECAYING TOP QUARK
5037  10     IF (ISTHEP(IHEP).EQ.155.AND.ISTHEP(JDAHEP(1,IHEP)).EQ.113
5038      &       .AND.(IDHW(IHEP).EQ.6.OR.IDHW(IHEP).EQ.12))
5039      &       ICMF=IHEP
5040       IF (ICMF.EQ.0) RETURN
5041       EM=PHEP(5,ICMF)
5042       X3MIN=2*GCUTME/EM
5043 C---GENERATE X(1),X(3) ACCORDING TO 1/((1-X(1))*X(3)**2)
5044  100  CONTINUE
5045 C-----AW=(MW/MT)**2
5046       AW=(PHEP(5,JDAHEP(1,ICMF))/EM)**2
5047 C---CHOOSE X3
5048       X3MAX=1-AW
5049       X(3)=X3MIN*X3MAX/(X3MIN+(X3MAX-X3MIN)*HWRGEN(0))
5050 C--CC, QQ AND RR ARE THE VARIABLE DEFINED IN OUR PAPER
5051 C--IN ORDER TO SOLVE THE CUBIC EQUATION
5052       CC=(1-AW)**2/4
5053       QQ=(AW**2-4*(1-X(3))*(2-CC-X(3))-2*AW*(3+2*X(3)))/3
5054      &     -((3+2*AW-4*X(3))**2)/9
5055       RR=((3+2*AW-4*X(3))*(AW**2-4*(1-X(3))*(2-CC-X(3))
5056      &     -2*AW*(3+2*X(3)))-3*(AW*(4-AW)*(2-CC)+(1-CC)
5057      &     *(2*(1-X(3))-AW)**2))/6-(ONE/27)*(3+2*AW-4*X(3))**3
5058 C---CHOOSE X1
5059       X1MAX=2*(-QQ**3)**(ONE/6)*COS(ACOS(RR/SQRT(-QQ**3))/3)
5060      &     -(3+2*AW-4*X(3))/3
5061       X1MIN=1-X(3)+(AW*X(3))/(1-X(3))
5062       IF (X1MAX.GE.1.OR.X1MIN.GE.1.OR.X1MAX.LE.X1MIN) GOTO 100
5063       X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(1)
5064 C---CALCULATE WEIGHT
5065       W=((1+1/AW-2*AW)*((1-AW)*X(3)-(1-X(1))*(1-X(3))-X(3)**2)
5066      &     +(1+1/(2*AW))*X(3)*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))
5067      &     *(1/X3MIN-1/X3MAX)*LOG((1-X1MIN)/(1-X1MAX))
5068 C---QSCALE=DURHAM-LIKE TRANSVERSE MOMENTUM OF THE GLUON
5069       QSCALE=EM*HWUSQR(X(3)*(1-X(1))/(2-X(1)-X(3)-AW))
5070 C---FACTOR FOR GLUON EMISSION
5071       ID=IDHW(JDAHEP(2,ICMF))
5072       GLUFAC=0
5073       IF (QSCALE.GT.HWBVMC(13)) GLUFAC=CFFAC*HWUALF(1,QSCALE)
5074      &     /(PIFAC*(1-AW)*(1-2*AW+1/AW))
5075 C---IN FRACTION GLUFAC*W OF EVENTS ADD A GLUON
5076       IF (GLUFAC*W.GT.HWRGEN(4)) THEN
5077         ID3=13
5078       ELSE
5079         GOTO 1000
5080       ENDIF
5081 C---CHECK INFRA-RED CUT-OFF FOR GLUON
5082       M(1)=PHEP(5,JDAHEP(1,ICMF))
5083       M(2)=HWBVMC(ID)
5084       M(3)=HWBVMC(ID3)
5085       E(1)=HALF*EM*(X(1)+AW+(-M(2)**2-M(3)**2)/EM**2)
5086       E(3)=HALF*EM*X(3)
5087       E(2)=EM-E(1)-E(3)
5088       PTSQ=-LAMBDA(E(1)**2-M(1)**2,E(3)**2-M(3)**2,
5089      &     E(2)**2-M(2)**2)
5090       IF (PTSQ.LE.0.OR.E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3))
5091      $     GOTO 1000
5092 C---CALCULATE MASS-DEPENDENT SUPPRESSION
5093       EPS=(RMASS(ID)/EM)**2
5094       EPG=(RMASS(ID3)/EM)**2
5095       GAMDEP=(1-AW)*(1+1/AW-2*AW)/(SQRT(1+AW**2+EPS**2
5096      &     -2*AW-2*EPS-2*AW*EPS)*(1+EPS+(1-EPS)**2/AW-2*AW))
5097       MASDEP=GAMDEP/(1-X(1))*((1+EPS+(1-EPS)**2/AW-2*AW)
5098      &     *((1-AW+EPS)*X(3)*(1-X(1))-(1-X(1))**2*(1-X(3))
5099      &     -X(3)**2*(1-X(1)+EPS))+(1+(1+EPS)/(2*AW))*X(3)
5100      &     *(1-X(1))*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1))**2)
5101       IF (MASDEP.LT.HWRGEN(7)*((1+1/AW-2*AW)*((1-AW)*X(3)
5102      &     -(1-X(1))*(1-X(3))-X(3)**2)+(1+1/(2*AW))*X(3)
5103      &     *(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))) GOTO 1000
5104 C---STORE OLD MOMENTA
5105 c---PT = TOP MOMENTUM, PW= W MOMENTUM
5106       CALL HWVEQU(5,PHEP(1,ICMF),PT)
5107       CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),PW)
5108 C--------GET THE NON-EMITTING PARTON CMF DIRECTION
5109       CALL HWULOF(PHEP(1,ICMF),PW,PW)
5110       CALL HWRAZM(ONE,CS,SN)
5111       CALL HWUROT(PW,CS,SN,R)
5112       CALL HWUROF(R,PW,PW)
5113       CALL HWUMAS(PW)
5114 C---REORDER ENTRIES: IHEP=EMITTER,  KHEP=EMITTED
5115       NHEP=NHEP+1
5116       IHEP=JDAHEP(2,ICMF)
5117       WHEP=JDAHEP(1,ICMF)
5118       KHEP=NHEP
5119 C---SET UP MOMENTA IN TOP REST FRAME
5120       PHEP(1,ICMF)=0
5121       PHEP(2,ICMF)=0
5122       PHEP(3,ICMF)=0
5123       PHEP(4,ICMF)=EM
5124       PHEP(5,ICMF)=EM
5125       PHEP(4,IHEP)=HALF*EM*(2-X(1)-X(3)+EPS-AW+EPG)
5126       PHEP(4,KHEP)=HALF*EM*X(3)
5127       PHEP(5,IHEP)=RMASS(ID)
5128       PHEP(5,KHEP)=RMASS(ID3)
5129       PHEP(3,KHEP)=HALF*EM*((X(1)+AW-EPS-EPG)*X(3)-2*(1+EPS-AW
5130      $     -EPG-(2+EPS+EPG-AW-X(1)-X(3))))/HWUSQR((X(1)+AW
5131      $     -EPS-EPG)**2-4*AW)
5132       PHEP(3,IHEP)=-PHEP(3,KHEP)-HALF*EM
5133      $     *HWUSQR((X(1)+AW-EPS-EPG)**2-4*AW)
5134       PHEP(2,IHEP)=0
5135       PHEP(1,KHEP)=HWUSQR(PHEP(4,KHEP)**2-PHEP(5,KHEP)**2
5136      $     -PHEP(3,KHEP)**2)
5137       PHEP(1,IHEP)=-PHEP(1,KHEP)
5138       PHEP(2,KHEP)=0
5139       CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PW1)
5140       CALL HWVDIF(4,PHEP(1,ICMF),PW1,PW1)
5141       CALL HWUMAS(PW1)
5142       DO K=1,5
5143         PHEP(K,WHEP)=PW1(K)
5144       ENDDO
5145 C---ORIENT IN CMF, THEN BOOST TO LAB
5146       CALL HWUROB(R,PHEP(1,ICMF),PHEP(1,ICMF))
5147       CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
5148       CALL HWUROB(R,PHEP(1,WHEP),PHEP(1,WHEP))
5149       CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
5150       CALL HWULOB(PT,PHEP(1,IHEP),PHEP(1,IHEP))
5151       CALL HWULOB(PT,PHEP(1,KHEP),PHEP(1,KHEP))
5152       CALL HWULOB(PT,PHEP(1,ICMF),PHEP(1,ICMF))
5153       CALL HWULOB(PT,PHEP(1,WHEP),PHEP(1,WHEP))
5154 C---STATUS AND COLOUR CONNECTION
5155 C--Bug fix 31/03/00 PR
5156       ISTHEP(KHEP)=114
5157       IDHW(KHEP)=ID3
5158       IDHEP(KHEP)=IDPDG(ID3)
5159       JMOHEP(1,KHEP)=ICMF
5160       JMOHEP(1,IHEP)=ICMF
5161       JDAHEP(1,KHEP)=0
5162       JDAHEP(2,ICMF)=KHEP
5163       IF(IDHW(ICMF).EQ.6) THEN
5164          JDAHEP(2,IHEP)=ICMF
5165          JDAHEP(2,KHEP)=IHEP
5166          JMOHEP(2,IHEP)=KHEP
5167          JMOHEP(2,KHEP)=ICMF
5168       ELSE
5169          JDAHEP(2,IHEP) = KHEP
5170          JDAHEP(2,KHEP) = ICMF
5171          JMOHEP(2,IHEP) = ICMF
5172          JMOHEP(2,KHEP) = IHEP
5173       ENDIF
5174 C--End of Fix
5175 C--modification to allow photon radiation via photos in top decay
5176  1000 IF(ITOPRD.EQ.1) CALL HWPHTP(ICMF)
5177  999  END
5178 CDECK  ID>, HWBVMC.
5179 *CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
5180 *-- Author :    Bryan Webber
5181 C-----------------------------------------------------------------------
5182       FUNCTION HWBVMC(ID)
5183 C-----------------------------------------------------------------------
5184 C     VIRTUAL MASS CUTOFF FOR PARTON TYPE ID
5185 C-----------------------------------------------------------------------
5186       INCLUDE 'HERWIG65.INC'
5187       DOUBLE PRECISION HWBVMC
5188       INTEGER ID
5189       IF (ID.EQ.13) THEN
5190         HWBVMC=RMASS(ID)+VGCUT
5191       ELSEIF (ID.LT.13) THEN
5192         HWBVMC=RMASS(ID)+VQCUT
5193       ELSEIF (ID.EQ.59) THEN
5194         HWBVMC=RMASS(ID)+VPCUT
5195       ELSE
5196         HWBVMC=RMASS(ID)
5197       ENDIF
5198       END
5199 CDECK  ID>, HWCBCT.
5200 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
5201 *-- Author :    Peter Richardson
5202 C-----------------------------------------------------------------------
5203       SUBROUTINE HWCBCT(JHEP,KHEP,THEP,PCL,SPLIT)
5204 C-----------------------------------------------------------------------
5205 C  Subroutine to split a baryonic cluster containing two heavy quarks
5206 C  Based on HWCCUT
5207 C-----------------------------------------------------------------------
5208       INCLUDE 'HERWIG65.INC'
5209       DOUBLE PRECISION HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,QM3,QM4,
5210      &                 PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),
5211      &                 VCLUS(4),DQM,EMX,EMY,SKAPPA,RKAPPA,VTMP(4),
5212      &                 DELTM,PDIQUK(5),AY(5)
5213       INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,THEP,ID1,ID2,ID3,ID4,NTRY,
5214      &        NTRYMX,J,IB
5215       LOGICAL SPLIT
5216       EXTERNAL HWUPCM,HWRGEN,HWVDOT
5217       PARAMETER(SKAPPA=1.,NTRYMX=100)
5218       IF(IERROR.NE.0) RETURN
5219       EMC=PCL(5)
5220       ID1=IDHW(JHEP)
5221       ID2=IDHW(KHEP)
5222       ID3=IDHW(THEP)
5223       QM1=RMASS(ID1)
5224       QM2=RMASS(ID2)
5225       QM3=RMASS(ID3)
5226       SPLIT = .FALSE.
5227       NTRY = 0
5228 C Decide if cluster contains a b-(anti)quark
5229       IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11.OR.
5230      &    ID3.EQ.5.OR.ID3.EQ.11) THEN
5231         IB=2
5232       ELSE
5233         IB=1
5234       ENDIF
5235 C-- Set the positon of the cluster to be that of the heavy quark
5236       CALL HWVEQU(4,VHEP(1,THEP),VCLUS)
5237 C--SPLIT THE BARYONIC CLUSTER INTO A HEAVY FLAVOUR MESON AND A HEAVY
5238 C--FLAVOUR BARYON
5239       PXY=EMC-QM1-QM2-QM3
5240  20   NTRY=NTRY+1
5241       IF(NTRY.GT.NTRYMX) RETURN
5242  30   EMX=QM1+QM2+PXY*HWRGEN(0)**PSPLT(IB)
5243       EMY=    QM3+PXY*HWRGEN(1)**PSPLT(IB)
5244       IF(EMX+EMY.GE.EMC) GOTO 30
5245 C--PULL A LIGHT QUARK PAIR OUT OF THE VACUUM
5246  40   ID4=HWRINT(1,3)
5247       IF(QWT(ID4).LT.HWRGEN(3)) GOTO 40
5248       QM4=RMASS(ID4)
5249 C--Now combine particles 3 & 4 into a diquark
5250 C--If three also heavy this diquark doesn't exist in HERWIG
5251 C--just assume mass is sum of quark masses,as for other diquarks
5252       DQM=QM3+QM4
5253 C--Now obtain the masses for the cluster splitting
5254       PCX=HWUPCM(EMX,QM1,DQM)
5255       IF(PCX.LT.ZERO) GOTO 20
5256       PCY=HWUPCM(EMY,QM2,QM4)
5257       IF(PCY.LT.ZERO) GOTO 20
5258       SPLIT=.TRUE.
5259 C--Now we've decided which light quark to pull out of the vacuum
5260 C--Find the direction of the second heavy quark
5261       CALL HWULOF(PCL,PHEP(1,THEP),AX)
5262       RCM=1./SQRT(HWVDOT(3,AX,AX))
5263       CALL HWVSCA(3,RCM,AX,AX)
5264 C--Construct the new CoM momenta(collinear)
5265       PXY=HWUPCM(EMC,EMX,EMY)
5266       CALL HWVSCA(3,PXY,AX,PC)
5267 C--pc is momenta of Y cluster along 2nd quark dirn in cluster frame
5268       PC(4)=SQRT(PXY**2+EMY**2)
5269       PC(5)=EMY
5270 C--pa is momenta of 2nd quark in Y frame
5271       CALL HWVSCA(3,PCY,AX,PA)
5272       PA(4)=SQRT(PCY**2+QM3**2)
5273       PA(5)=QM3
5274 C--pb is momenta of 2nd quark in cluster frame,pa now momenta of antiquark
5275       CALL HWULOB(PC,PA,PB)
5276       CALL HWVDIF(4,PC,PB,PA)
5277       PA(5)=QM4
5278       LHEP=NHEP+1
5279       MHEP=NHEP+2
5280 C--boost these momenta back to lab frame
5281       CALL HWULOB(PCL,PB,PHEP(1,THEP))
5282       CALL HWULOB(PCL,PA,PHEP(1,MHEP))
5283 C--pc now becomes momenta of X cluster in cluster frame
5284       CALL HWVSCA(3,-ONE,PC,PC)
5285       PC(4)=EMC-PC(4)
5286       PC(5)=EMX
5287 C--find the dirn of the 1st heavy quark in the X frame
5288 C--transform to cluster frame
5289       CALL HWULOF(PCL,PHEP(1,JHEP),AY)
5290 C--transform to X-frame
5291       CALL HWULOF(PC,AY,AY)
5292       RCM=1./SQRT(HWVDOT(3,AY,AY))
5293       CALL HWVSCA(3,RCM,AY,AY)
5294 C--pa now momenta of 1st havy quark along this dirn
5295       CALL HWVSCA(3,PCX,AY,PA)
5296       PA(4)=SQRT(PCX**2+QM1**2)
5297       PA(5)=QM1
5298 C--pb now momenta of 1st heavy quark in cluster frame then to lab
5299       CALL HWULOB(PC,PA,PB)
5300       CALL HWULOB(PCL,PB,PHEP(1,JHEP))
5301 C--now find the diquark momenta by momentum conservation
5302       DO 50 J=1,4
5303  50   PDIQUK(J)=PCL(J)-PHEP(J,THEP)-PHEP(J,MHEP)-PHEP(J,JHEP)
5304       PDIQUK(5)=DQM
5305 C--Now obtain the quark momenta from the diquark
5306       DO 60 J=1,3
5307  60   PA(J) = 0
5308       PA(4) = QM2
5309       PA(5) = QM2
5310       CALL HWULOB(PDIQUK,PA,PHEP(1,KHEP))
5311       CALL HWVDIF(4,PDIQUK,PHEP(1,KHEP),PHEP(1,LHEP))
5312 C--Construct new vertex positions
5313       RKAPPA=GEV2MM/SKAPPA
5314       CALL HWVSCA(3,RKAPPA,AX,AX)
5315       DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
5316       CALL HWVSCA(3,DELTM,AX,VTMP)
5317       VTMP(4)=(HALF*EMC-PXY)*RKAPPA
5318       CALL HWULB4(PCL,VTMP,VTMP)
5319       CALL HWVSUM(4,VTMP,VCLUS,VHEP(1,LHEP))
5320       CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5321 C--Relabel the colours of the quarks
5322       IDHEP(LHEP) = IDPDG(ID4)
5323       IDHEP(MHEP) = IDPDG(ID4)
5324       IF(IDHEP(JHEP).GT.0) THEN
5325         IDHW(LHEP)  = ID4+6
5326         IDHEP(LHEP) = -IDHEP(LHEP)
5327         IDHW(MHEP)  = ID4
5328         JDAHEP(2,LHEP) = JHEP
5329         JMOHEP(2,LHEP) = MHEP
5330         JMOHEP(2,MHEP) = JMOHEP(2,JHEP)
5331         JDAHEP(2,MHEP) = LHEP
5332         JMOHEP(2,JHEP) = LHEP
5333       ELSE
5334         IDHW(LHEP)  = ID4
5335         IDHW(MHEP)  = ID4+6
5336         IDHEP(MHEP) = -IDHEP(MHEP)
5337         JMOHEP(2,LHEP) = JHEP
5338         JDAHEP(2,MHEP) = JDAHEP(2,JHEP)
5339         JDAHEP(2,LHEP) = MHEP
5340         JMOHEP(2,MHEP) = LHEP
5341         JDAHEP(2,JHEP) = LHEP
5342       ENDIF
5343       ISTHEP(LHEP) = 151
5344       ISTHEP(MHEP) = 151
5345       JMOHEP(1,LHEP) = JMOHEP(1,KHEP)
5346       JDAHEP(1,LHEP) = 0
5347       JMOHEP(1,MHEP) = JMOHEP(1,JHEP)
5348       JDAHEP(1,MHEP) = 0
5349       NHEP = NHEP+2
5350  999  END
5351 CDECK  ID>, HWCBVI.
5352 *CMZ :-        -12/12/01  14:59:58  by  Peter Richardson
5353 *-- Author :    Mark Gibbs, modified by Peter Richardson
5354 C-----------------------------------------------------------------------
5355       SUBROUTINE HWCBVI
5356 C-----------------------------------------------------------------------
5357 C FINDS UNPAIRED PARTONS AFTER BARYON-NUMBER VIOLATION
5358 C  MODIFIED FOR RPARITY VIOLATING SUSY
5359 C-----------------------------------------------------------------------
5360       INCLUDE 'HERWIG65.INC'
5361       COMMON/HWBVIC/NBV,IBV(18)
5362       DOUBLE PRECISION HWRGEN,PDQ(5)
5363       INTEGER NBV,IBV,JBV,KBV,LBV,IHEP,IP1,IP2,IP3,JP1,JP2,JP3,
5364      & HWCBVT,NBR,MBV,IQ1,IQ2,IQ3,ID1,ID2,IDQ,IDIQK(3,3)
5365       LOGICAL SPLIT,DUNBV(18)
5366       DATA IDIQK/111,110,113,110,109,112,113,112,114/
5367 C---Check for errors
5368       IF (IERROR.NE.0)  RETURN
5369 C---Correct colour connections are gluon splitting
5370       CALL HWCCCC
5371 C---Reset bvi clustering flag
5372       HVFCEN = .FALSE.
5373 C---LIST PARTONS WITH WRONG COLOUR PARTNERS-QUARKS ONLY
5374     5 NBV=0
5375       DO 10 IHEP=1,NHEP
5376       IF (ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
5377         IF (QORQQB(IDHW(IHEP))) THEN
5378           IF (.NOT.QORQQB(IDHW(JMOHEP(2,IHEP))).
5379      &        AND.JMOHEP(2,IHEP).GT.6) GOTO 10
5380         ELSE
5381 C---Extra check for Gamma's
5382           IF (IDHW(IHEP).EQ.59) GO TO 10
5383 C---End of bug fix.
5384           IF (QORQQB(IDHW(JDAHEP(2,IHEP)))) GO TO 10
5385           GO TO 10
5386         ENDIF
5387         IF(JMOHEP(2,IHEP).LT.6.AND.
5388      &     .NOT.QBORQQ(IDHW(JMOHEP(2,IHEP)))) GOTO 10
5389 C--new for hard process
5390         NBV=NBV+1
5391         IF (NBV.GT.18) CALL HWWARN('HWCBVI',100,*999)
5392         IBV(NBV)=IHEP
5393         DUNBV(NBV)=.FALSE.
5394       ENDIF
5395    10 CONTINUE
5396 C--NOW FIND THE ANTIQUARKS WITH WRONG COLOUR CONNECTIONS
5397       DO 11 IHEP=1,NHEP
5398       IF(ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
5399         IF(QBORQQ(IDHW(IHEP))) THEN
5400           IF(.NOT.QBORQQ(IDHW(JDAHEP(2,IHEP))).AND.
5401      &        JDAHEP(2,IHEP).GT.6) GO TO 11
5402         ELSE
5403 C--Extra check for gamma's
5404           IF(IDHW(IHEP).EQ.59) GO TO 11
5405           IF(QBORQQ(IDHW(JMOHEP(2,IHEP)))) GO TO 11
5406           GO TO 11
5407         ENDIF
5408         IF(JDAHEP(2,IHEP).LT.6.AND.
5409      &    .NOT.QORQQB(IDHW(JDAHEP(2,IHEP)))) GOTO 11
5410         NBV=NBV+1
5411         IF(NBV.GT.18) CALL HWWARN('HWCBVI',100,*999)
5412         IBV(NBV)=IHEP
5413         DUNBV(NBV)=.FALSE.
5414       ENDIF
5415  11   CONTINUE
5416       IF (NBV.EQ.0) RETURN
5417       IF(MOD(NBV,3).NE.0) CALL HWWARN('HWCBVI',101,*999)
5418 C---PROCESS FOUND PARTONS, STARTING AT RANDOM POINT IN LIST
5419       NBR=NBV*HWRGEN(0)
5420       DO 100 MBV=1,NBV
5421       JBV=MBV+NBR
5422       IF (JBV.GT.NBV) JBV=JBV-NBV
5423       IF (.NOT.DUNBV(JBV)) THEN
5424         DUNBV(JBV)=.TRUE.
5425         IP1=IBV(JBV)
5426         JP1=HWCBVT(IP1)
5427 C---FIND ASSOCIATED PARTONS
5428         DO 20 KBV=1,NBV
5429         IF (.NOT.DUNBV(KBV)) THEN
5430           IP2=IBV(KBV)
5431           JP2=HWCBVT(IP2)
5432           IF (JP2.EQ.JP1) THEN
5433             DUNBV(KBV)=.TRUE.
5434             DO 15 LBV=1,NBV
5435             IF (.NOT.DUNBV(LBV)) THEN
5436               IP3=IBV(LBV)
5437               JP3=HWCBVT(IP3)
5438               IF (JP3.EQ.JP2) THEN
5439                 DUNBV(LBV)=.TRUE.
5440                 GO TO 25
5441               ENDIF
5442             ENDIF
5443    15       CONTINUE
5444           ENDIF
5445         ENDIF
5446    20   CONTINUE
5447         CALL HWWARN('HWCBVI',102,*999)
5448    25   IQ1=0
5449 C---LOOK FOR DIQUARK
5450         IF (ABS(IDHEP(IP1)).GT.100) THEN
5451           IQ1=IP1
5452           IQ2=IP2
5453           IQ3=IP3
5454         ELSEIF (ABS(IDHEP(IP2)).GT.100) THEN
5455           IQ1=IP2
5456           IQ2=IP3
5457           IQ3=IP1
5458         ELSEIF (ABS(IDHEP(IP3)).GT.100) THEN
5459           IQ1=IP3
5460           IQ2=IP1
5461           IQ3=IP2
5462         ENDIF
5463         IF (IQ1.EQ.0) THEN
5464 C---NO DIQUARKS: COMBINE TWO (ANTI)QUARKS
5465           IF (ABS(IDHEP(IP1)).GT.3) THEN
5466             IQ1=IP2
5467             IQ2=IP3
5468             IQ3=IP1
5469           ELSEIF (ABS(IDHEP(IP2)).GT.3) THEN
5470             IQ1=IP3
5471             IQ2=IP1
5472             IQ3=IP2
5473           ELSE
5474             IQ1=IP1
5475             IQ2=IP2
5476             IQ3=IP3
5477           ENDIF
5478           ID1=IDHEP(IQ1)
5479           ID2=IDHEP(IQ2)
5480 C---CHECK FLAVOURS
5481           IF (ID1.GT.0.AND.ID1.LT.4.AND.
5482      &        ID2.GT.0.AND.ID2.LT.4) THEN
5483             IDQ=IDIQK(ID1,ID2)
5484           ELSEIF (ID1.LT.0.AND.ID1.GT.-4.AND.
5485      &            ID1.LT.0.AND.ID2.GT.-4) THEN
5486             IDQ=IDIQK(-ID1,-ID2)+6
5487           ELSE
5488 C---CANT MAKE DIQUARKS WITH HEAVY QUARKS: TRY CLUSTER SPLITTING
5489             CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PDQ)
5490             CALL HWUMAS(PDQ)
5491 C--Use the original splitting procedure
5492             CALL HWCCUT(IQ1,IQ2,PDQ,.FALSE.,SPLIT)
5493             IF (IERROR.NE.0) RETURN
5494             IF(SPLIT) GOTO 5
5495 C--If it fails try the new procedure
5496             CALL HWVSUM(4,PDQ,PHEP(1,IQ3),PDQ)
5497             CALL HWUMAS(PDQ)
5498             IF(ABS(ID1).GT.3) THEN
5499               CALL HWCBCT(IQ3,IQ2,IQ1,PDQ,SPLIT)
5500             ELSEIF(ABS(ID2).GT.3) THEN
5501               CALL HWCBCT(IQ3,IQ1,IQ2,PDQ,SPLIT)
5502             ELSE
5503               CALL HWWARN('HWCBVI',100,*999)
5504             ENDIF
5505             IF (SPLIT) GO TO 5
5506 C---Unable to form cluster; dispose of event
5507             CALL HWWARN('HWCBVI',-3,*999)
5508           ENDIF
5509 C---OVERWRITE FIRST AND CANCEL SECOND
5510           IDHW(IQ1)=IDQ
5511           IDHEP(IQ1)=IDPDG(IDQ)
5512           CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PHEP(1,IQ1))
5513           CALL HWUMAS(PHEP(1,IQ1))
5514           ISTHEP(IQ2)=0
5515 C---REMAKE COLOUR CONNECTIONS
5516           IF (QORQQB(IDQ)) THEN
5517             JMOHEP(2,IQ1)=IQ3
5518             JDAHEP(2,IQ3)=IQ1
5519           ELSE
5520             JDAHEP(2,IQ1)=IQ3
5521             JMOHEP(2,IQ3)=IQ1
5522           ENDIF
5523         ELSE
5524 C---SPLIT A DIQUARK
5525           NHEP=NHEP+1
5526           CALL HWVSCA(5,HALF,PHEP(1,IQ1),PHEP(1,IQ1))
5527           CALL HWVEQU(5,PHEP(1,IQ1),PHEP(1,NHEP))
5528           ISTHEP(NHEP)=150
5529           JMOHEP(1,NHEP)=JMOHEP(1,IQ1)
5530           JDAHEP(1,NHEP)=0
5531 C---FIND FLAVOURS
5532           IDQ=IDHW(IQ1)
5533           DO 30 ID2=1,3
5534           DO 30 ID1=1,3
5535           IF (IDIQK(ID1,ID2).EQ.IDQ) THEN
5536             IDHW(IQ1)=ID1
5537             IDHW(NHEP)=ID2
5538 C---REMAKE COLOUR CONNECTIONS (DIQUARK)
5539             JMOHEP(2,IQ1)=IQ2
5540             JMOHEP(2,IQ2)=NHEP
5541             JMOHEP(2,IQ3)=IQ1
5542             JMOHEP(2,NHEP)=IQ3
5543             JDAHEP(2,IQ1)=IQ3
5544             JDAHEP(2,IQ2)=IQ1
5545             JDAHEP(2,IQ3)=NHEP
5546             JDAHEP(2,NHEP)=IQ2
5547             GO TO 35
5548           ELSEIF (IDIQK(ID1,ID2).EQ.IDQ-6) THEN
5549             IDHW(IQ1)=ID1+6
5550             IDHW(NHEP)=ID2+6
5551 C---REMAKE COLOUR CONNECTIONS (ANTIDIQUARK)
5552             JMOHEP(2,IQ1)=IQ3
5553             JMOHEP(2,IQ2)=IQ1
5554             JMOHEP(2,IQ3)=NHEP
5555             JMOHEP(2,NHEP)=IQ2
5556             JDAHEP(2,IQ1)=IQ2
5557             JDAHEP(2,IQ2)=NHEP
5558             JDAHEP(2,IQ3)=IQ1
5559             JDAHEP(2,NHEP)=IQ3
5560             GO TO 35
5561           ENDIF
5562    30     CONTINUE
5563           CALL HWWARN('HWCBVI',104,*999)
5564    35     IDHEP(IQ1)=IDPDG(IDHW(IQ1))
5565           IDHEP(NHEP)=IDPDG(IDHW(NHEP))
5566         ENDIF
5567       ENDIF
5568   100 CONTINUE
5569       RETURN
5570   999 END
5571 CDECK  ID>, HWCBVT.
5572 *CMZ :-
5573 *-- Author :    Peter Richardson
5574 C-----------------------------------------------------------------------
5575       FUNCTION HWCBVT(IP)
5576 C-----------------------------------------------------------------------
5577 C  Function to find the baryon number violating vertex a parton came from
5578 C-----------------------------------------------------------------------
5579       INCLUDE 'HERWIG65.INC'
5580       INTEGER HWCBVT,IP,JP(2),KP,I,J,ID,TYPE,IDM,IDM2,IDM3,IDM4
5581       JP(1) = IP
5582       ID = IDHW(IP)
5583       IF(ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
5584         JP(2) = JMOHEP(2,IP)
5585       ELSE
5586         JP(2) = JDAHEP(2,IP)
5587       ENDIF
5588       DO I=1,2
5589         IDM = JMOHEP(1,JMOHEP(1,JMOHEP(1,JMOHEP(1,JP(I)))))
5590         IF(IDHW(IDM).EQ.6.OR.IDHW(IDM).EQ.12) THEN
5591           JP(I)=IDM
5592         ENDIF
5593       ENDDO
5594       DO J=1,7
5595         DO I=1,2
5596           KP = JMOHEP(1,JP(I))
5597           IDM = IDHW(KP)
5598           IDM2 = IDHW(JDAHEP(1,KP))
5599           IDM3 = IDHW(JDAHEP(2,KP))
5600           IDM4 = IDHW(JDAHEP(1,KP)+1)
5601           IF((ISTHEP(KP).EQ.155.AND.
5602      &      ((IDM.GE.449.AND.IDM.LE.457.AND.IDM2.LE.12.AND.
5603      &       IDM3.LE.12.AND.IDM4.LE.12).OR.
5604      &      (((IDM.GE.411.AND.IDM.LE.424).OR.IDM.EQ.405.OR.IDM.EQ.406)
5605      &      .AND.IDM2.LE.12.AND.IDM3.LE.12)))
5606      &        .OR.(IDM.EQ.15.AND.IDM2.LE.12.AND.
5607      &       IDHW(JMOHEP(1,KP)).LE.12.AND.
5608      &       IDHW(JMOHEP(2,KP)).LE.12.AND.IDM3.GE.449.AND.
5609      &       IDM3.LE.457).OR.
5610      &         (IDM.EQ.15.AND.IDM2.GE.198.AND.IDM2.LE.200.
5611      &          AND.ABS(IDPDG(IDM3)).GT.1000000)) THEN
5612             IF(IDHW(KP).EQ.449.AND.JDAHEP(1,KP).EQ.JP(I)) THEN
5613               KP = JMOHEP(1,KP)
5614             ELSEIF(IDHW(KP).EQ.15) THEN
5615               TYPE=IDHW(JDAHEP(1,KP))
5616               IF(TYPE.GE.7.AND.TYPE.LE.12.AND.
5617      &           JMOHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
5618                 KP=IP
5619               ELSEIF(TYPE.LE.6.AND.
5620      &           JDAHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
5621                 KP=IP
5622               ELSE
5623                 HWCBVT = KP
5624                 RETURN
5625               ENDIF
5626             ELSE
5627               HWCBVT = KP
5628               RETURN
5629             ENDIF
5630           ENDIF
5631           JP(I) =KP
5632         ENDDO
5633       ENDDO
5634       HWCBVT = 0
5635  999  END
5636 CDECK  ID>, HWCCCC.
5637 *CMZ :-
5638 *-- Author :    Peter Richardson
5639 C-----------------------------------------------------------------------
5640       SUBROUTINE HWCCCC
5641 C-----------------------------------------------------------------------
5642 C  Subroutine to correct colour connections after the gluon splitting
5643 C-----------------------------------------------------------------------
5644       INCLUDE 'HERWIG65.INC'
5645       INTEGER IHEP,STFSPT,LHEP,MHEP,RHEP
5646       IF(IERROR.NE.0) RETURN
5647 C--Find the first particle in the event record with status 150
5648       DO IHEP=1,NHEP
5649         IF(ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154) THEN
5650           STFSPT = IHEP
5651           GOTO 10
5652         ENDIF
5653       ENDDO
5654  10   CONTINUE
5655 C--Now find any that are colour connected to earlier particles
5656 C--in the event record
5657       DO IHEP=STFSPT,NHEP
5658 C--First the quarks and antidiquarks
5659         IF(IDHW(IHEP).LT.6.OR.
5660      &     (IDHW(IHEP).GE.115.AND.IDHW(IHEP).LE.120)) THEN
5661           IF(JMOHEP(2,IHEP).LT.STFSPT) THEN
5662             LHEP = IHEP
5663             MHEP = JMOHEP(2,IHEP)
5664             RHEP = MHEP
5665             IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
5666 C--As from Rparity connect to particle not to antiparticle
5667             IF(IDHW(MHEP).NE.13) THEN
5668               JMOHEP(2,LHEP) = RHEP
5669             ELSE
5670               RHEP = RHEP+1
5671               JMOHEP(2,LHEP) = RHEP
5672             ENDIF
5673           ENDIF
5674         ENDIF
5675 C--Now the antiquarks
5676         IF((IDHW(IHEP).GT.6.AND.IDHW(IHEP).LE.12).OR.
5677      &     (IDHW(IHEP).GE.109.AND.IDHW(IHEP).LE.114)) THEN
5678           IF(JDAHEP(2,IHEP).LT.STFSPT) THEN
5679             LHEP = IHEP
5680             MHEP = JDAHEP(2,IHEP)
5681             RHEP = MHEP
5682             IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
5683 C--As from Rparity connect to antiparticle not particle
5684             IF(IDHW(MHEP).NE.13) THEN
5685               JDAHEP(2,LHEP) = RHEP
5686             ELSE
5687               JDAHEP(2,LHEP) = RHEP
5688             ENDIF
5689           ENDIF
5690         ENDIF
5691       ENDDO
5692       END
5693 CDECK  ID>, HWCCUT.
5694 *CMZ :-        -26/04/91  14.29.39  by  Federico Carminati
5695 *-- Author :    Bryan Webber
5696 C-----------------------------------------------------------------------
5697       SUBROUTINE HWCCUT(JHEP,KHEP,PCL,BTCLUS,SPLIT)
5698 C-----------------------------------------------------------------------
5699 C     Cuts into 2 the cluster, momentum PCL, made of partons JHEP & KHEP
5700 C-----------------------------------------------------------------------
5701       INCLUDE 'HERWIG65.INC'
5702       DOUBLE PRECISION HWREXQ,HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,EMX,EMY,
5703      & QM3,PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),SKAPPA,DELTM,
5704      & VSCA,VTMP(4),RKAPPA,VCLUS
5705       INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,ID1,ID2,ID3,NTRY,NTRYMX,J,IB
5706       LOGICAL BTCLUS,SPLIT
5707       EXTERNAL HWREXQ,HWUPCM,HWRGEN,HWVDOT,HWRINT
5708       COMMON/HWCFRM/VCLUS(4,NMXHEP)
5709       PARAMETER (SKAPPA=1.,NTRYMX=100)
5710       IF (IERROR.NE.0) RETURN
5711       EMC=PCL(5)
5712       ID1=IDHW(JHEP)
5713       ID2=IDHW(KHEP)
5714       QM1=RMASS(ID1)
5715       QM2=RMASS(ID2)
5716       SPLIT=.FALSE.
5717       NTRY=0
5718 C Decide if cluster contains a b-(anti)quark
5719       IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11) THEN
5720         IB=2
5721       ELSE
5722         IB=1
5723       ENDIF
5724       IF (BTCLUS) THEN
5725 C Split beam and target clusters as soft clusters
5726 C Both (remnant) children treated like soft clusters if IOPREM=0(1)
5727   10    ID3=HWRINT(1,2)
5728         QM3=RMASS(ID3)
5729         IF (EMC.LE.QM1+QM2+2.*QM3) THEN
5730           ID3=3-ID3
5731           QM3=RMASS(ID3)
5732           IF (EMC.LE.QM1+QM2+2.*QM3) RETURN
5733         ENDIF
5734         PXY=EMC-QM1-QM2-TWO*QM3
5735         IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(JHEP).EQ.154.OR.
5736      &      IOPREM.EQ.0) THEN
5737           EMX=QM1+QM3+HWREXQ(BTCLM,PXY)
5738         ELSE
5739           EMX=QM1+QM3+PXY*HWRGEN(0)**PSPLT(IB)
5740         ENDIF
5741         IF (ISTHEP(KHEP).EQ.153.OR.ISTHEP(KHEP).EQ.154.OR.
5742      &      IOPREM.EQ.0) THEN
5743           EMY=QM2+QM3+HWREXQ(BTCLM,PXY)
5744         ELSE
5745           EMY=QM2+QM3+PXY*HWRGEN(1)**PSPLT(IB)
5746         ENDIF
5747         IF (EMX+EMY.GE.EMC) THEN
5748           NTRY=NTRY+1
5749           IF (NTRY.GT.NTRYMX) RETURN
5750           GOTO 10
5751         ENDIF
5752         PCX=HWUPCM(EMX,QM1,QM3)
5753         PCY=HWUPCM(EMY,QM2,QM3)
5754       ELSE
5755 C Choose fragment masses for ordinary cluster
5756         PXY=EMC-QM1-QM2
5757   20    NTRY=NTRY+1
5758         IF (NTRY.GT.NTRYMX) RETURN
5759   30    EMX=QM1+PXY*HWRGEN(0)**PSPLT(IB)
5760         EMY=QM2+PXY*HWRGEN(1)**PSPLT(IB)
5761         IF (EMX+EMY.GE.EMC) GOTO 30
5762 C u,d,s pair production with weights QWT
5763   40    ID3=HWRINT(1,3)
5764         IF (QWT(ID3).LT.HWRGEN(3)) GOTO 40
5765         QM3=RMASS(ID3)
5766         PCX=HWUPCM(EMX,QM1,QM3)
5767         IF (PCX.LT.ZERO) GOTO 20
5768         PCY=HWUPCM(EMY,QM2,QM3)
5769         IF (PCY.LT.ZERO) GOTO 20
5770         SPLIT=.TRUE.
5771       ENDIF
5772 C Boost antiquark to CoM frame to find axis
5773       CALL HWULOF(PCL,PHEP(1,KHEP),AX)
5774       RCM=1./SQRT(HWVDOT(3,AX,AX))
5775       CALL HWVSCA(3,RCM,AX,AX)
5776 C Construct new CoM momenta (collinear)
5777       PXY=HWUPCM(EMC,EMX,EMY)
5778       CALL HWVSCA(3,PXY,AX,PC)
5779       PC(4)=SQRT(PXY**2+EMY**2)
5780       PC(5)=EMY
5781       CALL HWVSCA(3,PCY,AX,PA)
5782       PA(4)=SQRT(PCY**2+QM2**2)
5783       PA(5)=QM2
5784       CALL HWULOB(PC,PA,PB)
5785       CALL HWVDIF(4,PC,PB,PA)
5786       PA(5)=QM3
5787       LHEP=NHEP+1
5788       MHEP=NHEP+2
5789       IF (MHEP.GT.NMXHEP) CALL HWWARN('HWCCUT',100,*999)
5790       CALL HWULOB(PCL,PB,PHEP(1,KHEP))
5791       CALL HWULOB(PCL,PA,PHEP(1,MHEP))
5792       CALL HWVSCA(3,-ONE,PC,PC)
5793       PC(4)=EMC-PC(4)
5794       PC(5)=EMX
5795       CALL HWVSCA(3,PCX,AX,PA)
5796       PA(4)=SQRT(PCX**2+QM3**2)
5797       CALL HWULOB(PC,PA,PB)
5798       CALL HWULOB(PCL,PB,PHEP(1,LHEP))
5799       DO 50 J=1,4
5800   50  PHEP(J,JHEP)=PCL(J)-PHEP(J,KHEP)-PHEP(J,LHEP)-PHEP(J,MHEP)
5801       PHEP(5,JHEP)=QM1
5802       CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5803 C Construct new vertex positions
5804       RKAPPA=GEV2MM/SKAPPA
5805       CALL HWVSCA(3,RKAPPA,AX,AX)
5806       DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
5807       CALL HWVSCA(3,DELTM,AX,VTMP)
5808       VTMP(4)=(HALF*EMC-PXY)*RKAPPA
5809       CALL HWULB4(PCL,VTMP,VTMP)
5810       CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VHEP(1,LHEP))
5811       CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5812       VSCA=0.25*EMC+HALF*(PXY+DELTM)
5813       CALL HWVSCA(3,VSCA,AX,VTMP)
5814       VTMP(4)=(EMC-VSCA)*RKAPPA
5815       CALL HWULB4(PCL,VTMP,VTMP)
5816       CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,MHEP))
5817       VSCA=-0.25*EMC+HALF*(DELTM-PXY)
5818       CALL HWVSCA(3,VSCA,AX,VTMP)
5819       VTMP(4)=(EMC+VSCA)*RKAPPA
5820       CALL HWULB4(PCL,VTMP,VTMP)
5821       CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,JHEP))
5822 C (Re-)label quarks
5823       IDHW(LHEP)=ID3+6
5824       IDHW(MHEP)=ID3
5825       IDHEP(MHEP)= IDPDG(ID3)
5826       IDHEP(LHEP)=-IDPDG(ID3)
5827       ISTHEP(LHEP)=151
5828       ISTHEP(MHEP)=151
5829       JMOHEP(2,JHEP)=LHEP
5830       JDAHEP(2,KHEP)=MHEP
5831       JMOHEP(1,LHEP)=JMOHEP(1,KHEP)
5832       JMOHEP(2,LHEP)=MHEP
5833       JDAHEP(1,LHEP)=0
5834       JDAHEP(2,LHEP)=JHEP
5835       JMOHEP(1,MHEP)=JMOHEP(1,JHEP)
5836       JMOHEP(2,MHEP)=KHEP
5837       JDAHEP(1,MHEP)=0
5838       JDAHEP(2,MHEP)=LHEP
5839       NHEP=NHEP+2
5840   999 END
5841 CDECK  ID>, HWCDEC.
5842 *CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
5843 *-- Author :    Bryan Webber
5844 C-----------------------------------------------------------------------
5845       SUBROUTINE HWCDEC
5846 C-----------------------------------------------------------------------
5847 C     DECAYS CLUSTERS INTO PRIMARY HADRONS
5848 C-----------------------------------------------------------------------
5849       INCLUDE 'HERWIG65.INC'
5850       INTEGER JCL,KCL,IP,JP,KP,IST,ID1,ID2,ID3
5851       IF (IERROR.NE.0) RETURN
5852       IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN
5853 C---RELABEL CLUSTER CONNECTED TO REMNANT IN DIS
5854         DO 10 JCL=2,NHEP
5855         IF (ISTHEP(JCL).EQ.164) GOTO 20
5856         IF (ISTHEP(JCL).EQ.165) THEN
5857           IP=JMOHEP(1,JCL)
5858           JP=JMOHEP(2,JCL)
5859           KP=IP
5860           IF (ISTHEP(IP).EQ.162) THEN
5861             KP=JP
5862             JP=IP
5863           ENDIF
5864           IF (JMOHEP(2,KP).NE.JP) THEN
5865             IP=JMOHEP(2,KP)
5866           ELSE
5867             IP=JDAHEP(2,KP)
5868           ENDIF
5869           KCL=JDAHEP(1,IP)
5870           IF (ISTHEP(KCL)/10.NE.16) CALL HWWARN('HWCDEC',100,*999)
5871           ISTHEP(KCL)=164
5872           GOTO 20
5873         ENDIF
5874    10   CONTINUE
5875       ENDIF
5876    20 CONTINUE
5877       DO 30 JCL=1,NHEP
5878       IST=ISTHEP(JCL)
5879       IF (IST.GT.162.AND.IST.LT.166) THEN
5880 C---DON'T HADRONIZE BEAM/TARGET CLUSTERS
5881         IF (IST.EQ.163.OR..NOT.GENSOF) THEN
5882 C---SET UP FLAVOURS FOR CLUSTER DECAY
5883           CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
5884           CALL HWCHAD(JCL,ID1,ID3,ID2)
5885         ENDIF
5886       ENDIF
5887    30 CONTINUE
5888       ISTAT=50
5889   999 END
5890 CDECK  ID>, HWCFLA.
5891 *CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
5892 *-- Author :    Bryan Webber
5893 C-----------------------------------------------------------------------
5894       SUBROUTINE HWCFLA(JD1,JD2,ID1,ID2)
5895 C-----------------------------------------------------------------------
5896 C     SETS UP FLAVOURS FOR CLUSTER DECAY
5897 C-----------------------------------------------------------------------
5898       INTEGER JD1,JD2,ID1,ID2,JD,JDEC(12)
5899       DATA JDEC/1,2,3,10,11,12,4,5,6,7,8,9/
5900       JD=JD1
5901       IF (JD.GT.12) JD=JD-108
5902       ID1=JDEC(JD)
5903       JD=JD2
5904       IF (JD.GT.12) JD=JD-96
5905       ID2=JDEC(JD-6)
5906       END
5907 CDECK  ID>, HWCFOR.
5908 *CMZ :-        -26/04/91  14.15.56  by  Federico Carminati
5909 *-- Author :    Bryan Webber
5910 C-----------------------------------------------------------------------
5911       SUBROUTINE HWCFOR
5912 C-----------------------------------------------------------------------
5913 C     Converts colour-connected quark-antiquark pairs into clusters
5914 C     Modified by IGK to include BRW's colour rearrangement and
5915 C     MHS's cluster vertices
5916 C     MODIFIED 16/10/97 BY BRW FOR SUSY PROCESSES
5917 C-----------------------------------------------------------------------
5918       INCLUDE 'HERWIG65.INC'
5919       DOUBLE PRECISION HWULDO,HWVDOT,HWRGEN,HWUPCM,DCL0,DCL(4),DCL1,
5920      & DFAC,DISP1(4),DISP2(4),DMAX,PCL(5),DOT1,DOT2,FAC,VCLUS,SCA1,SCA2,
5921      & EM0,EM1,EM2,PC0,PC1
5922       INTEGER HWRINT,MAP(120),IBHEP,IBCL,JBHEP,JHEP,
5923      & KHEP,LHEP,LCL,IHEP,MCL,I,ISTJ,ISTK,JCL,ID1,ID3,L
5924       LOGICAL HWRLOG,SPLIT
5925       EXTERNAL HWULDO,HWVDOT,HWRGEN,HWUPCM,HWRINT
5926       COMMON/HWCFRM/VCLUS(4,NMXHEP)
5927       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,
5928      & 12/
5929       IF (IERROR.NE.0) RETURN
5930 C Split gluons
5931       CALL HWCGSP
5932 C Find colour partners after baryon number violating event
5933       IF (HVFCEN) THEN
5934         IF(RPARTY) THEN
5935           CALL HVCBVI
5936         ELSE
5937           CALL HWCBVI
5938         ENDIF
5939       ENDIF
5940       IF (IERROR.NE.0) RETURN
5941 C Look for partons to cluster
5942       DO 10 IBHEP=1,NHEP
5943   10  IF (ISTHEP(IBHEP).GE.150.AND.ISTHEP(IBHEP).LE.154) GOTO 20
5944       IBCL=1
5945       GOTO 130
5946   20  CONTINUE
5947 C--Final check for colour disconnections
5948       DO 25 JHEP=IBHEP,NHEP
5949         IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
5950      &      QORQQB(IDHW(JHEP))) THEN
5951           KHEP=JMOHEP(2,JHEP)
5952 C BRW FIX 13/03/99
5953           IF (KHEP.EQ.0.OR..NOT.(
5954      &      ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
5955      &      QBORQQ(IDHW(KHEP)))) THEN
5956             DO KHEP=IBHEP,NHEP
5957               IF (ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154
5958      &        .AND.QBORQQ(IDHW(KHEP))) THEN
5959                 LHEP=JDAHEP(2,KHEP)
5960                 IF (LHEP.EQ.0.OR..NOT.(
5961      &          ISTHEP(LHEP).GE.150.AND.ISTHEP(LHEP).LE.154.AND.
5962      &          QORQQB(IDHW(LHEP)))) THEN
5963                   JMOHEP(2,JHEP)=KHEP
5964                   JDAHEP(2,KHEP)=JHEP
5965                   GOTO 25
5966                 ENDIF
5967               ENDIF
5968             ENDDO
5969 C END FIX
5970             CALL HWWARN('HWCFOR',100,*999)
5971           ENDIF
5972         ENDIF
5973   25  CONTINUE
5974       IF (CLRECO) THEN
5975 C Allow for colour rearrangement of primary clusters
5976         NRECO=0
5977 C Randomize starting point
5978         JBHEP=HWRINT(IBHEP,NHEP)
5979         JHEP=JBHEP
5980   30    JHEP=JHEP+1
5981         IF (JHEP.GT.NHEP) JHEP=IBHEP
5982         IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
5983      &      QORQQB(IDHW(JHEP))) THEN
5984 C Find colour connected antiquark or diquark
5985           KHEP=JMOHEP(2,JHEP)
5986 C Find partner antiquark or diquark
5987           LHEP=JDAHEP(2,JHEP)
5988 C Find closest antiquark or diquark
5989           DCL0=1.D15
5990           LCL=0
5991           DO 40 IHEP=IBHEP,NHEP
5992           IF (ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154.AND.
5993      &        QBORQQ(IDHW(IHEP))) THEN
5994 C Check whether already reconnected
5995             IF (JDAHEP(2,IHEP).GT.0.AND.IHEP.NE.LHEP) THEN
5996               CALL HWVDIF(4,VHEP(1,IHEP),VHEP(1,JHEP),DCL)
5997               DCL1=ABS(HWULDO(DCL,DCL))
5998               IF (DCL1.LT.DCL0) THEN
5999                 DCL0=DCL1
6000                 LCL=IHEP
6001               ENDIF
6002             ENDIF
6003           ENDIF
6004   40      CONTINUE
6005           IF (LCL.NE.0.AND.LCL.NE.KHEP) THEN
6006             MCL=JDAHEP(2,LCL)
6007             IF (JDAHEP(2,MCL).NE.KHEP) THEN
6008 C Pairwise reconnection is possible
6009               CALL HWVDIF(4,VHEP(1,KHEP),VHEP(1,MCL ),DCL)
6010               DCL0=DCL0+ABS(HWULDO(DCL,DCL))
6011               CALL HWVDIF(4,VHEP(1,JHEP),VHEP(1,KHEP),DCL)
6012               DCL1=ABS(HWULDO(DCL,DCL))
6013               CALL HWVDIF(4,VHEP(1,LCL ),VHEP(1,MCL ),DCL)
6014               DCL1=DCL1+ABS(HWULDO(DCL,DCL))
6015               IF (DCL0.LT.DCL1.AND.HWRLOG(PRECO)) THEN
6016 C Reconnection occurs
6017                 JMOHEP(2,JHEP)= LCL
6018                 JDAHEP(2,LCL )=-JHEP
6019                 JMOHEP(2,MCL) = KHEP
6020                 JDAHEP(2,KHEP)=-MCL
6021                 NRECO=NRECO+1
6022               ENDIF
6023             ENDIF
6024           ENDIF
6025         ENDIF
6026         IF (JHEP.NE.JBHEP) GOTO 30
6027         IF (NRECO.NE.0) THEN
6028           DO 50 IHEP=IBHEP,NHEP
6029   50      JDAHEP(2,IHEP)=ABS(JDAHEP(2,IHEP))
6030         ENDIF
6031       ENDIF
6032 C Find (adjusted) cluster positions using MHS prescription
6033       DFAC=ONE
6034       DMAX=1D-10
6035       DO 70 JHEP=IBHEP,NHEP
6036       IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6037      &    QORQQB(IDHW(JHEP))) THEN
6038         KHEP=JMOHEP(2,JHEP)
6039         CALL HWUDKL(IDHW(JHEP),PHEP(1,JHEP),DISP1)
6040         CALL HWVSCA(4,DFAC,DISP1,DISP1)
6041         CALL HWUDKL(IDHW(KHEP),PHEP(1,KHEP),DISP2)
6042         CALL HWVSCA(4,DFAC,DISP2,DISP2)
6043 C Rescale the lengths of DISP1,DISP2 if too long
6044         DOT1=HWVDOT(3,DISP1,DISP1)
6045         DOT2=HWVDOT(3,DISP2,DISP2)
6046         IF (MAX(DOT1,DOT2).GT.DMAX**2) THEN
6047           CALL HWVSCA(4,DMAX/SQRT(DOT1),DISP1,DISP1)
6048           CALL HWVSCA(4,DMAX/SQRT(DOT2),DISP2,DISP2)
6049         ENDIF
6050         CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6051         DOT1=HWVDOT(3,DISP1,PCL)
6052         DOT2=HWVDOT(3,DISP2,PCL)
6053 C If PCL > 90^o from either quark, use a vector which isn't
6054         IF (DOT1.LE.ZERO.OR. DOT2.LE.ZERO) THEN
6055           CALL HWVSUM(4,DISP1,DISP2,PCL)
6056           DOT1=HWVDOT(3,DISP1,PCL)
6057           DOT2=HWVDOT(3,DISP2,PCL)
6058         ENDIF
6059 C If vectors are exactly opposite each other this method cannot work
6060         IF (DOT1.EQ.ZERO.OR.DOT2.EQ.ZERO) THEN
6061 C So use midpoint of quark constituents
6062           CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,KHEP),VCLUS(1,JHEP))
6063           CALL HWVSCA(4,HALF,VCLUS(1,JHEP),VCLUS(1,JHEP))
6064           GOTO 70
6065         ENDIF
6066 C Rescale DISP1 or DISP2 to give equal components in the PCL direction
6067         FAC=DOT1/DOT2
6068         IF (FAC.GT.ONE) THEN
6069           CALL HWVSCA(4,    FAC,DISP2,DISP2)
6070           DOT2=DOT1
6071         ELSE
6072           CALL HWVSCA(4,ONE/FAC,DISP1,DISP1)
6073           DOT1=DOT2
6074         ENDIF
6075 C Shift VHEP(1,JHEP) or VHEP(1,KHEP) s.t. their line is perp to PCL
6076         FAC=(HWVDOT(3,PCL,VHEP(1,KHEP))
6077      &      -HWVDOT(3,PCL,VHEP(1,JHEP)))/DOT1
6078         SCA1=MAX(ONE,ONE+FAC)
6079         SCA2=MAX(ONE,ONE-FAC)
6080         DO 60 I=1,4
6081   60    VCLUS(I,JHEP)=.5*(VHEP(I,JHEP)+VHEP(I,KHEP)
6082      &                   +SCA1*DISP1(I)+SCA2*DISP2(I))
6083       ENDIF
6084   70  CONTINUE
6085 C First chop up beam/target clusters
6086       DO 80 JHEP=IBHEP,NHEP
6087       KHEP=JMOHEP(2,JHEP)
6088       ISTJ=ISTHEP(JHEP)
6089       ISTK=ISTHEP(KHEP)
6090 C--PR MOD here 8/7/99
6091       IF (QORQQB(IDHW(JHEP)).AND.
6092      &   (((ISTJ.EQ.153.OR.ISTJ.EQ.154).AND.ISTK.NE.151.AND.ISTK.NE.0)
6093      &   .OR.((ISTK.EQ.153.OR.ISTK.EQ.154).
6094      &   AND.ISTJ.NE.151.AND.ISTJ.NE.0))) THEN
6095 C--end
6096         CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6097         CALL HWUMAS(PCL)
6098         CALL HWCCUT(JHEP,KHEP,PCL,.TRUE.,SPLIT)
6099         IF (IERROR.NE.0) RETURN
6100       ENDIF
6101   80  CONTINUE
6102 C Second chop up massive pairs
6103       DO 100 JHEP=IBHEP,NMXHEP
6104       IF (JHEP.GT.NHEP) GOTO 110
6105       IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6106      &    QORQQB(IDHW(JHEP))) THEN
6107   90    KHEP=JMOHEP(2,JHEP)
6108         CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6109         CALL HWUMAS(PCL)
6110         IF (PCL(5).GT.CTHRPW(MAP(IDHW(JHEP)),MAP(IDHW(KHEP)))) THEN
6111           CALL HWCCUT(JHEP,KHEP,PCL,.FALSE.,SPLIT)
6112           IF (IERROR.NE.0) RETURN
6113           IF (SPLIT) GOTO 90
6114         ENDIF
6115       ENDIF
6116   100 CONTINUE
6117 C Third create clusters and store production vertex
6118   110 IBCL=NHEP+1
6119       JCL=NHEP
6120       DO 120 JHEP=IBHEP,NHEP
6121       IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6122      &    QORQQB(IDHW(JHEP))) THEN
6123         JCL=JCL+1
6124         IF(JCL.GT.NMXHEP) CALL HWWARN('HWCFOR',105,*999)
6125         IDHW(JCL)=19
6126         IDHEP(JCL)=91
6127         KHEP=JMOHEP(2,JHEP)
6128         IF (KHEP.EQ.0.OR..NOT.(
6129      &    ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
6130      &    QBORQQ(IDHW(KHEP)))) CALL HWWARN('HWCFOR',104,*999)
6131         CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PHEP(1,JCL))
6132         CALL HWUMAS(PHEP(1,JCL))
6133         IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(KHEP).EQ.153) THEN
6134           ISTHEP(JCL)=164
6135         ELSEIF (ISTHEP(JHEP).EQ.154.OR.ISTHEP(KHEP).EQ.154) THEN
6136           ISTHEP(JCL)=165
6137         ELSE
6138           ISTHEP(JCL)=163
6139         ENDIF
6140         JMOHEP(1,JCL)=JHEP
6141         JMOHEP(2,JCL)=KHEP
6142         JDAHEP(1,JCL)=0
6143         JDAHEP(2,JCL)=0
6144         JDAHEP(1,JHEP)=JCL
6145         JDAHEP(1,KHEP)=JCL
6146         ISTHEP(JHEP)=ISTHEP(JHEP)+8
6147         ISTHEP(KHEP)=ISTHEP(KHEP)+8
6148         CALL HWVEQU(4,VCLUS(1,JHEP),VHEP(1,JCL))
6149       ENDIF
6150   120 CONTINUE
6151       NHEP=JCL
6152 C Fix up momenta for single-hadron clusters
6153   130 DO 150 JCL=IBCL,NHEP
6154 C Don't hadronize beam/target clusters
6155       IF (ISTHEP(JCL).LT.163.OR.ISTHEP(JCL).GT.165) GOTO 150
6156       IF (ISTHEP(JCL).NE.163.AND.GENSOF) GOTO 150
6157 C Set up flavours for cluster decay
6158       CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
6159       EM0=PHEP(5,JCL)
6160       IF ((B1LIM.EQ.ZERO).OR.(ID1.NE.11.AND.ID3.NE.11)) THEN
6161         IF (EM0.GT.MIN(RMIN(ID1,1)+RMIN(1,ID3),
6162      $       RMIN(ID1,2)+RMIN(2,ID3))) GOTO 150
6163       ELSE
6164 C Special for b clusters: allow 1-hadron decay above threshold
6165         IF (B1LIM*HWRGEN(1).LT.EM0/(MIN(RMIN(ID1,1)+RMIN(1,ID3),
6166      $       RMIN(ID1,2)+RMIN(2,ID3)))-1.)
6167      &   GOTO 150
6168       ENDIF
6169       EM1=RMIN(ID1,ID3)
6170       IF (ABS(EM0-EM1).LT.1.D-5) GOTO 150
6171 C Decide to go backward or forward to transfer 4-momentum
6172       L=1-TWO*INT(HALF+HWRGEN(2))
6173       MCL=NHEP-IBCL+1
6174       LCL=JCL
6175       DO 140 I=1,MCL
6176       LCL=LCL+L
6177       IF (LCL.LT.IBCL) LCL=LCL+MCL
6178       IF (LCL.GT.NHEP) LCL=LCL-MCL
6179       IF (LCL.EQ.JCL) THEN
6180         IF (EM0.GE.EM1+RMIN(1,1)) GOTO 150
6181         CALL HWWARN('HWCFOR',101,*999)
6182       ENDIF
6183       IF (ISTHEP(LCL).LT.163.OR.ISTHEP(LCL).GT.165) GOTO 140
6184 C Rescale momenta in 2-cluster CoM
6185       CALL HWVSUM(4,PHEP(1,JCL),PHEP(1,LCL),PCL)
6186       CALL HWUMAS(PCL)
6187       EM2=PHEP(5,LCL)
6188       PC0=HWUPCM(PCL(5),EM0,EM2)
6189       PC1=HWUPCM(PCL(5),EM1,EM2)
6190       IF (PC1.LT.ZERO) THEN
6191 C Need to rescale other mass as well
6192         CALL HWCFLA(IDHW(JMOHEP(1,LCL)),IDHW(JMOHEP(2,LCL)),ID1,ID3)
6193         EM2=RMIN(ID1,ID3)
6194         PC1=HWUPCM(PCL(5),EM1,EM2)
6195         IF (PC1.LT.ZERO) GOTO 140
6196         PHEP(5,LCL)=EM2
6197       ENDIF
6198       IF (PC0.GT.ZERO) THEN
6199         PC0=PC1/PC0
6200         CALL HWULOF(PCL,PHEP(1,JCL),PHEP(1,JCL))
6201         CALL HWVSCA(3,PC0,PHEP(1,JCL),PHEP(1,JCL))
6202         PHEP(4,JCL)=SQRT(PC1**2+EM1**2)
6203         PHEP(5,JCL)=EM1
6204         CALL HWULOB(PCL,PHEP(1,JCL),PHEP(1,JCL))
6205         CALL HWVDIF(4,PCL,PHEP(1,JCL),PHEP(1,LCL))
6206         GOTO 150
6207       ELSEIF (PC0.EQ.ZERO) THEN
6208         PHEP(5,JCL)=EM1
6209         CALL HWDTWO(PCL,PHEP(1,JCL),PHEP(1,LCL),PC1,TWO,.TRUE.)
6210         GOTO 150
6211       ELSE
6212         CALL HWWARN('HWCFOR',102,*999)
6213       ENDIF
6214   140 CONTINUE
6215       CALL HWWARN('HWCFOR',103,*999)
6216   150 CONTINUE
6217       ISTAT=60
6218 C Non-partons labelled as partons (ie photons) should get copied
6219       DO 160 IHEP=1,NHEP
6220       IF (ISTHEP(IHEP).EQ.150) THEN
6221         NHEP=NHEP+1
6222         JDAHEP(1,IHEP)=NHEP
6223         ISTHEP(IHEP)=157
6224         ISTHEP(NHEP)=190
6225         IDHW(NHEP)=IDHW(IHEP)
6226         IDHEP(NHEP)=IDPDG(IDHW(IHEP))
6227         CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
6228 C--MHS FIX 07/03/05 - VERTEX SHOULD BE RELATIVE TO FIXED AXES
6229         CALL HWVSUM(4,VTXPIP,VHEP(1,IHEP),VHEP(1,NHEP))
6230 C--END FIXES
6231         JMOHEP(1,NHEP)=IHEP
6232         JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
6233         JDAHEP(1,NHEP)=0
6234         JDAHEP(2,NHEP)=0
6235       ENDIF
6236   160 CONTINUE
6237   999 END
6238 CDECK  ID>, HWCGSP.
6239 *CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
6240 *-- Author :    Bryan Webber
6241 C-----------------------------------------------------------------------
6242       SUBROUTINE HWCGSP
6243 C-----------------------------------------------------------------------
6244 C     SPLITS ANY TIMELIKE GLUONS REMAINING AFTER PERTURBATIVE
6245 C     BRANCHING INTO LIGHT (I.E. U OR D) Q-QBAR PAIRS
6246 C-----------------------------------------------------------------------
6247       INCLUDE 'HERWIG65.INC'
6248       DOUBLE PRECISION HWRGEN,PF
6249       INTEGER HWRINT,IHEP,JHEP,KHEP,LHEP,MHEP,ID,J,IST
6250       EXTERNAL HWRGEN,HWRINT
6251       IF (NGSPL.EQ.0) CALL HWWARN('HWCGSP',400,*999)
6252       LHEP=NHEP-1
6253       MHEP=NHEP
6254       DO 100 IHEP=1,NHEP
6255       IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.149) THEN
6256         JHEP=JMOHEP(2,IHEP)
6257 C BRW FIX 12/03/99
6258         IF (JHEP.LE.0) THEN
6259           KHEP=0
6260           DO JHEP=1,NHEP
6261             IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
6262      &      .AND.JDAHEP(2,JHEP).LE.0) THEN
6263               KHEP=KHEP+1
6264               JMOHEP(2,IHEP)=JHEP
6265               JDAHEP(2,JHEP)=IHEP
6266             ENDIF
6267           ENDDO
6268           IF (KHEP.EQ.0) CALL HWWARN('HWCGSP',102,*999)
6269           IF (KHEP.NE.1) CALL HWWARN('HWCGSP',103,*999)
6270         ENDIF
6271 C END FIX
6272 C---CHECK FOR DECAYED HEAVY ANTIQUARKS
6273         IF (ISTHEP(JHEP).EQ.155) THEN
6274           JHEP=JDAHEP(1,JDAHEP(2,JHEP))
6275           DO 10 J=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
6276   10      IF (ISTHEP(J).EQ.149.AND.JDAHEP(2,J).EQ.0) GOTO 20
6277           CALL HWWARN('HWCGSP',100,*999)
6278   20      JHEP=J
6279         ENDIF
6280         KHEP=JDAHEP(2,IHEP)
6281 C BRW FIX 12/03/99
6282         IF (KHEP.LE.0) THEN
6283           KHEP=0
6284           DO JHEP=1,NHEP
6285             IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
6286      &      .AND.JMOHEP(2,JHEP).LE.0) THEN
6287               KHEP=KHEP+1
6288               JDAHEP(2,IHEP)=JHEP
6289               JMOHEP(2,JHEP)=IHEP
6290             ENDIF
6291           ENDDO
6292           IF (KHEP.EQ.0) CALL HWWARN('HWCGSP',104,*999)
6293           IF (KHEP.NE.1) CALL HWWARN('HWCGSP',105,*999)
6294           KHEP=JDAHEP(2,IHEP)
6295         ENDIF
6296 C END FIX
6297 C---CHECK FOR DECAYED HEAVY QUARKS
6298         IF (ISTHEP(KHEP).EQ.155)  CALL HWWARN('HWCGSP',101,*999)
6299         IF (IDHW(IHEP).EQ.13) THEN
6300 C---SPLIT A GLUON
6301           LHEP=LHEP+2
6302           MHEP=MHEP+2
6303           IF(MHEP.GT.NMXHEP) CALL HWWARN('HWCGSP',106,*999)
6304   30      ID=HWRINT(1,NGSPL)
6305           IF (PGSPL(ID).LT.PGSMX*HWRGEN(0)) GOTO 30
6306           PHEP(5,LHEP)=RMASS(ID)
6307           PHEP(5,MHEP)=RMASS(ID)
6308 C---ASSUME ISOTROPIC ANGULAR DISTRIBUTION
6309           IF (PHEP(5,IHEP).GT.PHEP(5,LHEP)+PHEP(5,MHEP)) THEN
6310             CALL HWDTWO(PHEP(1,IHEP),PHEP(1,LHEP),
6311      &                  PHEP(1,MHEP),PGSPL(ID),TWO,.TRUE.)
6312           ELSE
6313             PF=HWRGEN(1)
6314             CALL HWVSCA(4,PF,PHEP(1,IHEP),PHEP(1,LHEP))
6315             CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,LHEP),PHEP(1,MHEP))
6316             PHEP(5,LHEP)=PF*PHEP(5,IHEP)
6317             PHEP(5,MHEP)=PHEP(5,IHEP)-PHEP(5,LHEP)
6318           ENDIF
6319           CALL HWUDKL(13,PHEP(1,IHEP),VHEP(1,LHEP))
6320           CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,LHEP),VHEP(1,LHEP))
6321           CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
6322           IDHW(LHEP)=ID+6
6323           IDHW(MHEP)=ID
6324           IDHEP(MHEP)= IDPDG(ID)
6325           IDHEP(LHEP)=-IDPDG(ID)
6326           ISTHEP(IHEP)=2
6327           ISTHEP(LHEP)=150
6328           ISTHEP(MHEP)=150
6329 C---NEW COLOUR CONNECTIONS
6330           IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP) JMOHEP(2,KHEP)=LHEP
6331           IF(RPARTY.OR.JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=MHEP
6332           JMOHEP(1,LHEP)=JMOHEP(1,IHEP)
6333           JMOHEP(2,LHEP)=MHEP
6334           JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
6335           JMOHEP(2,MHEP)=JHEP
6336           JDAHEP(1,LHEP)=0
6337           JDAHEP(2,LHEP)=KHEP
6338           JDAHEP(1,MHEP)=0
6339           JDAHEP(2,MHEP)=LHEP
6340           JDAHEP(1,IHEP)=LHEP
6341           JDAHEP(2,IHEP)=MHEP
6342         ELSE
6343 C---COPY A NON-GLUON
6344           LHEP=LHEP+1
6345           MHEP=MHEP+1
6346           IF(MHEP.GT.NMXHEP) CALL HWWARN('HWCGSP',107,*999)
6347           CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
6348           CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,MHEP))
6349           IDHW(MHEP)=IDHW(IHEP)
6350           IDHEP(MHEP)=IDHEP(IHEP)
6351           IST=ISTHEP(IHEP)
6352           ISTHEP(IHEP)=2
6353           IF (IST.EQ.149) THEN
6354             ISTHEP(MHEP)=150
6355           ELSE
6356             ISTHEP(MHEP)=IST+6
6357           ENDIF
6358 C---NEW COLOUR CONNECTIONS
6359           IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP)
6360      &      JMOHEP(2,KHEP)=MHEP
6361           IF(RPARTY.OR.(JHEP.NE.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP))
6362      &      JDAHEP(2,JHEP)=MHEP
6363           JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
6364           JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
6365           JDAHEP(1,MHEP)=0
6366           JDAHEP(2,MHEP)=JDAHEP(2,IHEP)
6367           JDAHEP(1,IHEP)=MHEP
6368         ENDIF
6369       ENDIF
6370   100 CONTINUE
6371       NHEP=MHEP
6372   999 END
6373 CDECK  ID>, HWCHAD.
6374 *CMZ :-        -26/04/91  14.00.57  by  Federico Carminati
6375 *-- Author :    Bryan Webber
6376 C-----------------------------------------------------------------------
6377       SUBROUTINE HWCHAD(JCL,ID1,ID3,ID2)
6378 C-----------------------------------------------------------------------
6379 C     HADRONIZES CLUSTER JCL, CONSISTING OF PARTONS ID1,ID3
6380 C     ID2 RETURNS PARTON-ANTIPARTON PAIR CREATED
6381 C     (IN SPECIAL CLUSTER CODE - SEE HWCFLA)
6382 C
6383 C MODIFIED 15/11/99 TO SMEAR POSITIONS OF HADRONS BY 1/(CLUSTER MASS)
6384 C-----------------------------------------------------------------------
6385       INCLUDE 'HERWIG65.INC'
6386       DOUBLE PRECISION HWRGEN,HWRGAU,HWVDOT,EM0,EM1,EM2,EMADU,EMSQ,
6387      & PCMAX,PCM,PTEST,PCQK,PP(5),EMLOW,RMAT(3,3),CT,ST,CX,SX,HPSMR
6388       INTEGER HWRINT,JCL,ID1,ID2,ID3,ID,IR1,IR2,NTRY,IDMIN,IMAX,I,MHEP,
6389      & IM,JM,KM,IB
6390       LOGICAL DIQK
6391       EXTERNAL HWRGEN,HWRINT
6392       DIQK(ID)=ID.GT.3.AND.ID.LT.10
6393       IF (IERROR.NE.0) RETURN
6394       ID2=0
6395       EM0=PHEP(5,JCL)
6396       IF (LOCN(ID1,ID3).LE.0) CALL HWWARN('HWCHAD',104,*999)
6397       IR1=NCLDK(LOCN(ID1,ID3))
6398       EM1=RMIN(ID1,ID3)
6399       IF (ABS(EM0-EM1).LT.0.001) THEN
6400 C---SINGLE-HADRON CLUSTER
6401         NHEP=NHEP+1
6402         IF (NHEP.GT.NMXHEP) CALL HWWARN('HWCHAD',100,*999)
6403         IDHW(NHEP)=IR1
6404         IDHEP(NHEP)=IDPDG(IR1)
6405         ISTHEP(NHEP)=191
6406         JDAHEP(1,JCL)=NHEP
6407         JDAHEP(2,JCL)=NHEP
6408         CALL HWVEQU(5,PHEP(1,JCL),PHEP(1,NHEP))
6409         CALL HWVSUM(4,VHEP(1,JCL),VTXPIP,VHEP(1,NHEP))
6410       ELSE
6411         NTRY=0
6412         IDMIN=1
6413         EMLOW=RMIN(ID1,1)+RMIN(1,ID3)
6414         EMADU=RMIN(ID1,2)+RMIN(2,ID3)
6415         IF (EMADU.LT.EMLOW) THEN
6416           IDMIN=2
6417           EMLOW=EMADU
6418         ENDIF
6419         EMSQ=EM0**2
6420         PCMAX=EMSQ-EMLOW**2
6421         IF (PCMAX.GE.ZERO) THEN
6422 C---SET UP TWO QUARK-ANTIQUARK PAIRS OR A
6423 C   QUARK-DIQUARK AND AN ANTIDIQUARK-ANTIQUARK
6424           PCMAX=PCMAX*(EMSQ-(RMIN(ID1,IDMIN)-RMIN(IDMIN,ID3))**2)
6425           IMAX=12
6426           IF (DIQK(ID1).OR.DIQK(ID3)) IMAX=3
6427           DO 10 I=3,IMAX
6428           IF (EM0.LT.RMIN(ID1,I)+RMIN(I,ID3)) GOTO 20
6429   10      CONTINUE
6430           I=IMAX+1
6431   20      ID2=HWRINT(1,I-1)
6432           IF (PWT(ID2).NE.ONE) THEN
6433             IF (PWT(ID2).LT.HWRGEN(1)) GOTO 20
6434           ENDIF
6435 C---PICK TWO PARTICLES WITH THESE QUANTUM NUMBERS
6436           NTRY=NTRY+1
6437   30      IR1=LOCN(ID1,ID2)+INT(RESN(ID1,ID2)*HWRGEN(2))
6438           IF (CLDKWT(IR1).LT.HWRGEN(3)) GOTO 30
6439           IR1=NCLDK(IR1)
6440   40      IR2=LOCN(ID2,ID3)+INT(RESN(ID2,ID3)*HWRGEN(4))
6441           IF (CLDKWT(IR2).LT.HWRGEN(5)) GOTO 40
6442           IR2=NCLDK(IR2)
6443           EM1=RMASS(IR1)
6444           EM2=RMASS(IR2)
6445           PCM=EMSQ-(EM1+EM2)**2
6446           IF (PCM.GT.ZERO) GOTO 70
6447   50      IF (NTRY.LE.NDTRY) GOTO 20
6448 C---CAN'T FIND A DECAY MODE - CHOOSE LIGHTEST
6449   60      ID2=HWRINT(1,2)
6450           IR1=NCLDK(LOCN(ID1,ID2))
6451           IR2=NCLDK(LOCN(ID2,ID3))
6452           EM1=RMASS(IR1)
6453           EM2=RMASS(IR2)
6454           PCM=EMSQ-(EM1+EM2)**2
6455           IF (PCM.GT.ZERO) GOTO 70
6456           NTRY=NTRY+1
6457           IF (NTRY.LE.NDTRY+50) GOTO 60
6458           CALL HWWARN('HWCHAD',101,*999)
6459 C---DECAY IS ALLOWED
6460   70      PCM=PCM*(EMSQ-(EM1-EM2)**2)
6461           IF (NTRY.GT.NCTRY) GOTO 80
6462           PTEST=PCM*SWTEF(IR1)*SWTEF(IR2)
6463           IF (PTEST.LT.PCMAX*HWRGEN(0)**2) GOTO 20
6464         ELSE
6465 C---ALLOW DECAY BY PI0 EMISSION IF ONLY POSSIBILITY
6466           ID2=1
6467           IR2=NCLDK(LOCN(1,1))
6468           EM2=RMASS(IR2)
6469           PCM=(EMSQ-(EM1+EM2)**2)*(EMSQ-(EM1-EM2)**2)
6470         ENDIF
6471 C---DECAY IS CHOSEN.  GENERATE DECAY MOMENTA
6472 C   AND PUT PARTICLES IN /HEPEVT/
6473   80    IF (PCM.LT.ZERO) CALL HWWARN('HWCHAD',102,*999)
6474         PCM=0.5*SQRT(PCM)/EM0
6475         MHEP=NHEP+1
6476         NHEP=NHEP+2
6477         IF (NHEP.GT.NMXHEP) CALL HWWARN('HWCHAD',103,*999)
6478         PHEP(5,MHEP)=EM1
6479         PHEP(5,NHEP)=EM2
6480 C Decide if cluster contains a b-(anti)quark or not
6481         IF (ID1.EQ.11.OR.ID2.EQ.11.OR.ID3.EQ.11) THEN
6482           IB=2
6483         ELSE
6484           IB=1
6485         ENDIF
6486         IF (CLDIR(IB).NE.0) THEN
6487           DO 110 IM=1,2
6488             JM=JMOHEP(IM,JCL)
6489             IF (JM.EQ.0) GOTO 110
6490             IF (ISTHEP(JM).NE.158) GOTO 110
6491 C   LOOK FOR PARENT PARTON
6492             DO 100 KM=JMOHEP(1,JM)+1,JM
6493               IF (ISTHEP(KM).EQ.2) THEN
6494                 IF (JDAHEP(1,KM).EQ.JM) THEN
6495 C   FOUND PARENT PARTON
6496                   IF (IDHW(KM).NE.13) THEN
6497 C   FIND ITS DIRECTION IN CLUSTER CMF
6498                    CALL HWULOF(PHEP(1,JCL),PHEP(1,KM),PP)
6499                    PCQK=PP(1)**2+PP(2)**2+PP(3)**2
6500                    IF (PCQK.GT.ZERO) THEN
6501                     PCQK=SQRT(PCQK)
6502                     IF (CLSMR(IB).GT.ZERO) THEN
6503 C   DO GAUSSIAN SMEARING OF DIRECTION
6504   90                 CT=ONE+CLSMR(IB)*LOG(HWRGEN(0))
6505                      IF (CT.LT.-ONE) GOTO 90
6506                      ST=ONE-CT*CT
6507                      IF (ST.GT.ZERO) ST=SQRT(ST)
6508                      CALL HWRAZM( ONE,CX,SX)
6509                      CALL HWUROT(PP,CX,SX,RMAT)
6510                      PP(1)=ZERO
6511                      PP(2)=PCQK*ST
6512                      PP(3)=PCQK*CT
6513                      CALL HWUROB(RMAT,PP,PP)
6514                     ENDIF
6515                     PCQK=PCM/PCQK
6516                     IF (IM.EQ.2) PCQK=-PCQK
6517                     CALL HWVSCA(3,PCQK,PP,PHEP(1,MHEP))
6518                     PHEP(4,MHEP)=SQRT(PHEP(5,MHEP)**2+PCM**2)
6519                     CALL HWULOB(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,MHEP))
6520                     CALL HWVDIF(4,PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP))
6521                     GOTO 130
6522                    ENDIF
6523                   ENDIF
6524                   GOTO 120
6525                 ENDIF
6526               ELSEIF (ISTHEP(KM).GT.140) THEN
6527 C   FINISHED THIS JET
6528                 GOTO 110
6529               ENDIF
6530  100        CONTINUE
6531  110      CONTINUE
6532         ENDIF
6533  120    CALL HWDTWO(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP),
6534      &              PCM,TWO,.TRUE.)
6535  130    IDHW(MHEP)=IR1
6536         IDHW(NHEP)=IR2
6537         IDHEP(MHEP)=IDPDG(IR1)
6538         IDHEP(NHEP)=IDPDG(IR2)
6539         ISTHEP(MHEP)=192
6540         ISTHEP(NHEP)=192
6541         JMOHEP(1,MHEP)=JCL
6542 C---SECOND MOTHER OF HADRON IS JET
6543         JMOHEP(2,MHEP)=JMOHEP(1,JMOHEP(1,JCL))
6544         JDAHEP(1,JCL)=MHEP
6545         JDAHEP(2,JCL)=NHEP
6546 C---SMEAR HADRON POSITIONS
6547         HPSMR=GEV2MM/PHEP(5,JCL)
6548         DO I=1,4
6549           VHEP(I,MHEP)=HWRGAU(I,ZERO,HPSMR)
6550         ENDDO
6551         VHEP(4,MHEP)=ABS(VHEP(4,MHEP))
6552      &           +SQRT(HWVDOT(3,VHEP(1,MHEP),VHEP(1,MHEP)))
6553         CALL HWULB4(PHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
6554         CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
6555         CALL HWVSUM(4,VTXPIP,VHEP(1,MHEP),VHEP(1,MHEP))
6556         DO I=1,4
6557           VHEP(I,NHEP)=HWRGAU(I,ZERO,HPSMR)
6558         ENDDO
6559         VHEP(4,NHEP)=ABS(VHEP(4,NHEP))
6560      &           +SQRT(HWVDOT(3,VHEP(1,NHEP),VHEP(1,NHEP)))
6561         CALL HWULB4(PHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
6562         CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
6563         CALL HWVSUM(4,VTXPIP,VHEP(1,NHEP),VHEP(1,NHEP))
6564       ENDIF
6565       ISTHEP(JCL)=180+MOD(ISTHEP(JCL),10)
6566       JMOHEP(1,NHEP)=JCL
6567       JMOHEP(2,NHEP)=JMOHEP(1,JMOHEP(1,JCL))
6568   999 END
6569 CDECK  ID>, HWD2ME.
6570 *CMZ :-        -09/04/02  13:37:38  by  Peter Richardson
6571 *-- Author :    Peter Richardson
6572 C-----------------------------------------------------------------------
6573       SUBROUTINE HWD2ME(IMODE)
6574 C-----------------------------------------------------------------------
6575 C     Computes the width and maximum weight for a two body mode
6576 C-----------------------------------------------------------------------
6577       INCLUDE 'HERWIG65.INC'
6578       INTEGER IMODE,I
6579       DOUBLE PRECISION A(2),M(3),PCM,E1,E2,HWUPCM,PHS,WGT,MWGT,PCM2,
6580      &     M2(3),E,G
6581       EXTERNAL HWUPCM
6582 C--couplings
6583       E = SQRT(FOUR*PIFAC/128.0D0)
6584       G = E/SQRT(SWEIN)
6585 C--set up the masses and couplings
6586       M(1) = RMASS(IDK(ID2PRT(IMODE)))
6587       DO 1 I=1,2
6588       A(I)   = A2MODE(I,IMODE)
6589  1    M(I+1) = RMASS(IDKPRD(I,ID2PRT(IMODE)))
6590       DO 2 I=1,3
6591  2    M2(I)  = M(I)**2
6592 C--first compute the masses etc
6593       PCM = HWUPCM(M(1),M(2),M(3))
6594       PCM2 = PCM**2
6595       PHS = PCM/M2(1)/8.0D0/PIFAC
6596 C--now compute the width and max weight
6597 C--first the fermion --> fermion scalar diagrams
6598       IF(I2DRTP(IMODE).EQ.1) THEN
6599         WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(2)-M2(3))
6600      &              +FOUR*A(1)*A(2)*M(1)*M(2))
6601         E1 = SQRT(M2(2)+PCM2)
6602         E2 = SQRT(M2(3)+PCM2)
6603         MWGT = HALF*M2(1)/(E1+E2)*(E1+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6604 C--next the fermion --> scalar fermion   diagrams
6605       ELSEIF(I2DRTP(IMODE).EQ.2) THEN
6606         WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6607      &              +FOUR*A(1)*A(2)*M(1)*M(3))
6608         E1 = SQRT(M2(2)+PCM2)
6609         E2 = SQRT(M2(3)+PCM2)
6610         MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6611 C--next the fermion --> scalar antifermion   diagrams
6612       ELSEIF(I2DRTP(IMODE).EQ.3) THEN
6613         WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6614      &              +FOUR*A(1)*A(2)*M(1)*M(3))
6615         E1 = SQRT(M2(2)+PCM2)
6616         E2 = SQRT(M2(3)+PCM2)
6617         MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6618 C--next the fermion --> fermion gauge boson diagrams
6619       ELSEIF(I2DRTP(IMODE).EQ.4) THEN
6620         WGT = 2.0D0*(M2(1)-M2(2))**2
6621         MWGT = WGT
6622 C--next the scalar --> fermion antifermion diagrams
6623       ELSEIF(I2DRTP(IMODE).EQ.5) THEN
6624         WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6625      &        -FOUR*M(2)*M(3)*A(1)*A(2)
6626         MWGT = WGT
6627 C--next the scalar --> fermion fermion diagrams
6628       ELSEIF(I2DRTP(IMODE).EQ.6) THEN
6629         WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6630      &        -FOUR*M(2)*M(3)*A(1)*A(2)
6631         MWGT = WGT
6632 C--next the fermion --> fermion pion diagrams
6633       ELSEIF(I2DRTP(IMODE).EQ.7) THEN
6634         WGT = HALF/FOUR/RMASS(198)**4*(
6635      &        (A(1)**2+A(2)**2)*((M2(1)-M2(2))**2-M2(3)*(M2(1)+M2(2)))
6636      &         +FOUR*M(1)*M(2)*M2(3)*A(1)*A(2))
6637         E1 = SQRT(M2(2)+PCM2)
6638         E2 = SQRT(M2(3)+PCM2)
6639         MWGT =ONE/8.0D0/RMASS(198)**4*ABS(A(1)**2-A(2)**2)*
6640      &        M(1)*(M(1)*M2(3)+(M2(1)-M2(2)+M2(3))*(E2+PCM))+WGT
6641 C--next scalar --> antifermion fermion diagrams
6642       ELSEIF(I2DRTP(IMODE).EQ.8) THEN
6643         WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6644      &        -FOUR*M(2)*M(3)*A(1)*A(2)
6645         MWGT = WGT
6646 C--next fermion --> gravitino photon
6647       ELSEIF(I2DRTP(IMODE).EQ.9) THEN
6648         WGT = 8.0D0*M2(1)**3
6649         MWGT = WGT
6650 C--next fermion --> gravitino scalar
6651       ELSEIF(I2DRTP(IMODE).EQ.10) THEN
6652         WGT = HALF*(M2(1)-M2(3))**3
6653         E1 = SQRT(M2(2)+PCM2)
6654         E2 = SQRT(M2(3)+PCM2)
6655         MWGT = TWO*M2(1)/(E1+E2)*(E1+PCM)*(M2(1)-M2(3))**2 +WGT
6656 C--next sfermion --> fermion gravitino
6657       ELSEIF(I2DRTP(IMODE).EQ.11) THEN
6658         WGT = (M2(1)-M2(2))**3
6659         MWGT = WGT
6660 C--next antisfermion --> fermion gravitino
6661       ELSEIF(I2DRTP(IMODE).EQ.12) THEN
6662         WGT = (M2(1)-M2(2))**3
6663         MWGT = WGT
6664 C--next the scalar --> antifermion antifermion diagrams
6665       ELSEIF(I2DRTP(IMODE).EQ.13) THEN
6666         WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6667      &        -FOUR*M(2)*M(3)*A(1)*A(2)
6668         MWGT = WGT
6669 C--next the antifermion --> scalar antifermion diagrams
6670       ELSEIF(I2DRTP(IMODE).EQ.14) THEN
6671         WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6672      &              +FOUR*A(1)*A(2)*M(1)*M(3))
6673         E1 = SQRT(M2(2)+PCM2)
6674         E2 = SQRT(M2(3)+PCM2)
6675         MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6676 C--unrecognised issue warning
6677       ELSE
6678         CALL HWWARN('HWITWO',500,*999)
6679       ENDIF
6680       WGT  =       P2MODE(IMODE)* WGT*PHS
6681       MWGT = 1.1D0*P2MODE(IMODE)*MWGT*PHS
6682 C--put the information in the common block
6683       WT2MAX(IMODE) = MWGT
6684 C--output the information
6685       IF(IPRINT.EQ.2) THEN
6686         WRITE(*,3010) WGT
6687         WRITE(*,3020) MWGT
6688         WRITE(*,3030) WGT/HBAR/BRFRAC(ID2PRT(IMODE))*
6689      &       RLTIM(IDK(ID2PRT(IMODE)))
6690       ENDIF
6691       RETURN
6692 C--format statements
6693  3010 FORMAT('            PARTIAL WIDTH  = ',G12.4)
6694  3020 FORMAT('            MAXIMUM WEIGHT = ',E12.4)
6695  3030 FORMAT('     RATIO TO ISAJET VALUE = ',G12.4)
6696  999  END
6697 CDECK  ID>, HWD3ME.
6698 *CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
6699 *-- Author :    Peter Richardson
6700 C-----------------------------------------------------------------------
6701       SUBROUTINE HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
6702 C-----------------------------------------------------------------------
6703 C     Subroutine to perform the three body decays for spin correlations
6704 C     and SUSY three body modes
6705 C-----------------------------------------------------------------------
6706       INCLUDE 'HERWIG65.INC'
6707       INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE,NDIA,ID1,ID2,
6708      &     DRTYPE(NDIAGR),NTRY,IDSPIN,NCTHRE,DRCF(NDIAGR)
6709       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,M342,HWRUNI,
6710      &     HWUPCM,M232,M242,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,
6711      &     BRW(6),BRZ(12),P(5,4),PM(5,4),WGTM,CFTHRE(NCFMAX,NCFMAX)
6712       DOUBLE COMPLEX S,D,RHOIN(2,2),F0(2,2,8),F3(2,2,8),F1(2,2,8),
6713      &     F2(2,2,8),F0M(2,2,8),F1M(2,2,8),F01(2,2,8,8)
6714       EXTERNAL HWRUNI,HWUPCM,HWRGEN
6715       COMMON/HWHEWS/S(8,8,2),D(8,8)
6716       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
6717      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
6718      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
6719       DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
6720       DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
6721      &         0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
6722 C--compute the masses of external particles for the decay mode
6723 C--first for true three body decay modes
6724       IF(ITYPE.EQ.0) THEN
6725 C--initalisation for the diagrams
6726         WTMAX  = WT3MAX(IMODE)
6727         PRE    = P3MODE(IMODE)
6728         NCTHRE = N3NCFL(IMODE)
6729         NDIA   = NDI3BY(IMODE)
6730         IDP(1) = IDK(ID3PRT(IMODE))
6731         DO 1 I=1,3
6732  1      IDP(I+1) = IDKPRD(I,ID3PRT(IMODE))
6733         DO 2 I=1,NCTHRE
6734         DO 2 J=1,NCTHRE
6735  2      CFTHRE(I,J) = SPN3CF(I,J,IMODE)
6736 C--enter the couplings for the diagrams
6737         DO 3 I=1,NDI3BY(IMODE)
6738         DRTYPE(I) = I3DRTP(I,IMODE)
6739         DRCF  (I) = I3DRCF(I,IMODE)
6740         DO 3 J=1,2
6741         A(J,I) = A3MODE(J,I,IMODE)
6742  3      B(J,I) = B3MODE(J,I,IMODE)
6743 C--enter the intermediate masses for the diagrams
6744         DO 4 I=1,NDI3BY(IMODE)
6745         IDP(I+4) = I3MODE(I,IMODE)
6746         MR(I)  = RMASS(I3MODE(I,IMODE))
6747         MS(I)  = MR(I)**2
6748         IF(I3MODE(I,IMODE).GT.200) THEN
6749           MWD(I) = RMASS(I3MODE(I,IMODE))*HBAR/RLTIM(I3MODE(I,IMODE))
6750         ELSEIF(I3MODE(I,IMODE).EQ.200) THEN
6751           MWD(I) = RMASS(200)*GAMZ
6752         ELSEIF(I3MODE(I,IMODE).EQ.198.OR.I3MODE(I,IMODE).EQ.199) THEN
6753           MWD(I) = RMASS(198)*GAMW
6754         ELSEIF(I3MODE(I,IMODE).EQ.59) THEN
6755           MWD(I) = 0.0D0
6756         ENDIF
6757  4      CONTINUE
6758 C--reorder for top quark decay modes(b first then W products)
6759         IF(IDP(1).EQ.6.OR.IDP(1).EQ.12) THEN
6760           I = IDP(2)
6761           IDP(2) = IDP(4)
6762           IDP(4) = IDP(3)
6763           IDP(3) = I
6764         ENDIF
6765 C--reorder if fermion not first
6766         IF(IDP(3).GT.IDP(4).AND.((IDP(1).EQ.6.OR.IDP(1).EQ.12).OR.
6767      &     IDP(2).GE.400)) THEN
6768           I = IDP(3)
6769           IDP(3) = IDP(4)
6770           IDP(4) = I
6771         ENDIF
6772 C--then for two body modes to gauge bosons including boson decays
6773       ELSE
6774 C--initalisation for the diagram
6775         WTMAX       = WTBMAX(ITYPE,IMODE)
6776         NDIA        = 1
6777         PRE         = PBMODE(ITYPE,IMODE)
6778         DRTYPE(1)   = IBDRTP(IMODE)
6779         DRCF  (1)   = 1
6780         NCTHRE      = 1
6781         CFTHRE(1,1) = ONE
6782 C--particles in decay
6783         IDP(1) = IDK(IDBPRT(IMODE))
6784         IDP(2) = IDKPRD(1,IDBPRT(IMODE))
6785         IF(IDP(2).GE.198.AND.IDP(2).LE.200)
6786      &       IDP(2) = IDKPRD(2,IDBPRT(IMODE))
6787         IDP(5) = IBMODE(IMODE)
6788 C--masses of virtual particles and couplings
6789         MR(1) = RMASS(IBMODE(IMODE))
6790         MS(1) = MR(1)**2
6791         DO J=1,2
6792           A(J,1) = ABMODE(J,IMODE)
6793           B(J,1) = BBMODE(J,ITYPE,IMODE)
6794         ENDDO
6795         IF(IBMODE(IMODE).EQ.200) THEN
6796           MWD(1) = RMASS(200)*GAMZ
6797         ELSE
6798           MWD(1) = RMASS(198)*GAMW
6799         ENDIF
6800 C--particles from boson decay
6801         IF(IBMODE(IMODE).EQ.200) THEN
6802           ID1 = ITYPE
6803           IF(ITYPE.GT.6) ID1 = ID1+114
6804           ID2 = ID1+6
6805         ELSE
6806           ID1 = 2*ITYPE-1
6807           IF(ITYPE.GT.3) ID1 = ID1+114
6808           ID2 = ID1+7
6809           IF(IBMODE(IMODE).EQ.198) THEN
6810             I   = ID1+6
6811             ID1 = ID2-6
6812             ID2 = I
6813           ENDIF
6814         ENDIF
6815         IDP(3) = ID1
6816         IDP(4) = ID2
6817 C--only do the decay if possible for an on-shell boson
6818         IF(RMASS(ID1)+RMASS(ID2).GT.MR(1)) RETURN
6819         IF(IPRINT.EQ.2.AND..NOT.GENEV)
6820      &        WRITE(6,3000) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4))
6821         MA(3) = RMASS(IDP(3))
6822         MA(4) = RMASS(IDP(4))
6823         DO 5 I=1,4
6824  5      MA2(I) = MA(I)**2
6825       ENDIF
6826 C--set up the masses MA OFF SHELL MB ON SHELL
6827       DO 6 I=1,4
6828         MB(I) = RMASS(IDP(I))
6829         MB2(I) = MB(I)**2
6830         IF(.NOT.GENEV) THEN
6831           MA (I) = MB (I)
6832           MA2(I) = MB2(I)
6833         ENDIF
6834  6    CONTINUE
6835       IF(MA(1).LT.MA(2)+MA(3)+MA(4)) RETURN
6836 C--compute the width and maximum weight if initialising
6837       IF(.NOT.GENEV) THEN
6838 C--search for maximum weight
6839         WMAX  = ZERO
6840         WSUM  = ZERO
6841         WSSUM = ZERO
6842         DO 7 I=1,NSEARCH
6843           CALL HWD3M0(1,NDIA,WGT,WGTM,RHOIN,IDSPIN)
6844           WGT = WGT*PRE
6845           WGTM=WGTM*PRE
6846           IF(WGTM.GT.WMAX) WMAX = WGTM
6847           WSUM = WSUM+WGT
6848           WSSUM = WSSUM+WGT**2
6849           IF(WGT.LT.ZERO) CALL HWWARN('HWD3ME',500,*999)
6850  7      CONTINUE
6851 C--compute width and maximum weight
6852         WSUM = WSUM/DBLE(NSEARCH)
6853         WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
6854         WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
6855 C--if required output results
6856         IF(IPRINT.EQ.2) THEN
6857           WRITE(6,3010) WSUM,WSSUM
6858           WRITE(6,3020) WMAX
6859           IF(ITYPE.EQ.0) THEN
6860             TEMP = BRFRAC(ID3PRT(IMODE))*HBAR/RLTIM(IDK(ID3PRT(IMODE)))
6861           ELSE
6862             IF(IBMODE(IMODE).EQ.200) THEN
6863               TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
6864      &              RLTIM(IDK(IDBPRT(IMODE)))*BRZ(ITYPE)
6865             ELSE
6866               TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
6867      &              RLTIM(IDK(IDBPRT(IMODE)))*BRW(ITYPE)
6868             ENDIF
6869           ENDIF
6870           WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
6871         ENDIF
6872 C--set up the maximum weight
6873         IF(ITYPE.EQ.0) THEN
6874           WT3MAX(IMODE)       = 1.1D0*WMAX
6875         ELSE
6876           WTBMAX(ITYPE,IMODE) = 1.1D0*WMAX
6877         ENDIF
6878 C--if not initialising generate the momenta
6879       ELSE
6880 C--generate a configuation
6881         NTRY = 0
6882  100    NTRY = NTRY+1
6883         CALL HWD3M0(ID,NDIA,WGT,WGTM,RHOIN,IDSPIN)
6884         WGT = WGT*PRE
6885 C--check maximum isn't violated, increase and issue warning if it is
6886         IF(WGT.GT.WTMAX) THEN
6887           CALL HWWARN('HWD3ME',1,*50)
6888           IF(ITYPE.EQ.0) THEN
6889             WRITE(6,3040) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(3)),
6890      &            RNAME(IDP(4)),WTMAX,WGT*1.1D0
6891           ELSE
6892             WRITE(6,3050) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(5))
6893             WRITE(6,3060) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4)),
6894      &           WTMAX,WGT*1.1D0
6895           ENDIF
6896           WTMAX = WGT*1.1D0
6897           IF(ITYPE.EQ.0) THEN
6898             WT3MAX(IMODE) = WTMAX
6899           ELSE
6900             WTBMAX(ITYPE,IMODE) = WTMAX
6901           ENDIF
6902         ENDIF
6903  50     IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
6904         IF(NTRY.GE.NSNTRY) CALL HWWARN('HWD3ME',100,*999)
6905       ENDIF
6906       RETURN
6907 C--format statements for the outputs
6908  3000 FORMAT(/'  FOLLOWED BY ',A8,' --> ',A8,' ',A8)
6909  3010 FORMAT('            PARTIAL WIDTH  = ',G12.4,' +/- ',G12.4)
6910  3020 FORMAT('            MAXIMUM WEIGHT = ',E12.4)
6911  3030 FORMAT('     RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
6912  3040 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8,' ',A8,
6913      &     'EXCEEDS MAX',
6914      &       /10X,'    MAXIMUM WEIGHT =',1PG24.16,
6915      &       /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
6916  3050 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8)
6917  3060 FORMAT(/'  FOLLOWED BY ',A8,' --> ',A8,' ',A8,' EXCEEDS MAX',
6918      &       /10X,'    MAXIMUM WEIGHT =',1PG24.16,
6919      &       /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
6920  999  END
6921 CDECK  ID>, HWD3M0.
6922 *CMZ :-        -09/04/02  13:46:07  by  Peter Richardson
6923 *-- Author :    Peter Richardson
6924 C-----------------------------------------------------------------------
6925       SUBROUTINE HWD3M0(ID,NDIA,WGT,MWGT,RHOIN,IDSPIN)
6926 C-----------------------------------------------------------------------
6927 C     Subroutine to calculate the matrix element for a given mode
6928 C-----------------------------------------------------------------------
6929       INCLUDE 'HERWIG65.INC'
6930       INTEGER I,J,P0,P1,P2,P3,P0P,IB,ID,IDP(4+NDIAGR),IDSPIN,NDIA,
6931      &     DRTYPE(NDIAGR),NCTHRE,DRCF(NDIAGR)
6932       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,FJAC,M342,HWRUNI,
6933      &     M34,PCMA,PCMB,HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,PTMP(5),
6934      &     M232,M242,PRE,PLAB,PRW,XMASS,PCM,P(5,4),PM(5,4),MR,PREF(5),
6935      &     MMIN,MMAX,MWGT,CFTHRE(NCFMAX,NCFMAX),WGTB(NCFMAX),WGTC,
6936      &     HWRGEN,A02,A2
6937       DOUBLE COMPLEX S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F01(2,2,8,8),
6938      &     RHOIN(2,2),F0(2,2,8),F1(2,2,8),F2(2,2,8),F0M(2,2,8),
6939      &     RHOB(2,2),F1M(2,2,8),F3(2,2,8)
6940       EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRGEN
6941       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
6942       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
6943      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
6944      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
6945       DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
6946       COMMON/HWHEWS/S(8,8,2),D(8,8)
6947       PARAMETER(EPS=1D-10)
6948 C--select the momenta of the particles
6949 C--first see if there is a boson mode
6950       IB = -1
6951       DO 1 I=1,NDIA
6952         IF(DRTYPE(I).EQ.1.OR.DRTYPE(I).EQ.5.OR.DRTYPE(I).EQ.6.OR.
6953      &     DRTYPE(I).EQ.7) IB = IDP(I+4)
6954  1    CONTINUE
6955 C--compute the mass of the 34 subsystem flat if no boson otherwise Breit-Wigner
6956       MMIN = (MA(3)+MA(4))**2
6957       MMAX = (MA(1)-MA(2))**2
6958       IF(IB.GT.0.AND.IB.NE.59) THEN
6959         CALL HWHGB1(1,2,IB,FJAC,M342,MMAX,MMIN)
6960       ELSEIF(IB.EQ.59) THEN
6961          M342 = HWRUNI(1,LOG(MMIN),LOG(MMAX))
6962          M342 = EXP(M342)
6963          FJAC = (LOG(MMAX)-LOG(MMIN))*M342
6964       ELSEIF((DRTYPE(1).EQ.2.OR.DRTYPE(1).EQ.17).AND.
6965      &        IDP(5).EQ.206.OR.IDP(5).EQ.207) THEN
6966         A02   = ATAN((MMIN-MS(1))/MWD(1))
6967         A2    = ATAN((MMAX-MS(1))/MWD(1))-A02
6968         M342  = MS(1)+MWD(1)*TAN(A02+A2*HWRGEN(1))
6969         FJAC  = A2*((M342-MS(1))**2+MWD(1)**2)/MWD(1)
6970       ELSE
6971         FJAC = MMAX-MMIN
6972         M342 = HWRUNI(1,MMIN,MMAX)
6973       ENDIF
6974       M34 = SQRT(M342)
6975       FJAC = HALF*FJAC/M34
6976 C--copy the momentum of the decaying particle into the internal common block
6977       CALL HWVEQU(5,PHEP(1,ID),P(1,1))
6978       DO 2 I=2,4
6979  2    P(5,I) = MA(I)
6980 C--perform the decay 1---> 2+34
6981       PCMA = HWUPCM(MA(1),MA(2),M34)
6982       PLAB(5,1) = M34
6983       CALL HWDTWO(P(1,1),PLAB(1,1),P(1,2),PCMA,2.0D0,.TRUE.)
6984 C--perform the decay 34 --> 3+4
6985       PCMB = HWUPCM(M34,MA(3),MA(4))
6986       CALL HWDTWO(PLAB(1,1),P(1,3),P(1,4),PCMB,2.0D0,.TRUE.)
6987 C--compute the phase sapce factors
6988       PHS = PCMA*PCMB*FJAC/32.0D0/PIFAC**3/MA2(1)
6989 C--compute the other possible masses for the propagator
6990       M232 = MA2(2)+MA2(3)+TWO*HWULDO(P(1,2),P(1,3))
6991       M242 = MA2(2)+MA2(4)+TWO*HWULDO(P(1,2),P(1,4))
6992 C--compute the vectors for the helicity amplitudes
6993       DO 3 I=1,4
6994 C--compute the references vectors
6995 C--not important if SM particle which can't have spin measured
6996 C--ie anything other the top and tau
6997 C--also not important if particle is approx massless
6998 C--first the SM particles other than top and tau
6999       IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
7000      &                .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
7001         CALL HWVEQU(5,PREF,PLAB(1,I+4))
7002 C--all other particles
7003       ELSE
7004         PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
7005         CALL HWVSCA(3,ONE/PP,P(1,I),N)
7006         PLAB(4,I+4) = HALF*(P(4,I)-PP)
7007         PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
7008         CALL HWVSCA(3,PP,N,PLAB(1,I+4))
7009         CALL HWUMAS(PLAB(1,I+4))
7010         PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
7011 C--fix to avoid problems if approx massless due to energy
7012         IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
7013       ENDIF
7014 C--now the massless vectors
7015       PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
7016       DO 4 J=1,4
7017  4    PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
7018  3    CALL HWUMAS(PLAB(1,I))
7019 C--change order of momenta for call to HE code
7020       DO 5 I=1,4
7021       PM(1,I) = P(3,I)
7022       PM(2,I) = P(1,I)
7023       PM(3,I) = P(2,I)
7024       PM(4,I) = P(4,I)
7025  5    PM(5,I) = P(5,I)
7026       DO 6 I=1,8
7027       PCM(1,I)=PLAB(3,I)
7028       PCM(2,I)=PLAB(1,I)
7029       PCM(3,I)=PLAB(2,I)
7030       PCM(4,I)=PLAB(4,I)
7031  6    PCM(5,I)=PLAB(5,I)
7032 C--compute the S functions
7033       CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
7034       DO 7 I=1,8
7035       DO 7 J=1,8
7036       S(I,J,2) = -S(I,J,2)
7037  7    D(I,J)   = TWO*D(I,J)
7038 C--compute the F functions
7039       CALL HWVSUM(5,PM(1,1),PM(1,2),PTMP)
7040       CALL HWUMAS(PTMP)
7041       CALL HWH2F2(8,F0 ,5,PM(1,1), MA(1))
7042       CALL HWH2F1(8,F1 ,6,PM(1,2), MA(2))
7043       CALL HWH2F1(8,F2 ,7,PM(1,3), MA(3))
7044       CALL HWH2F1(8,F3 ,8,PM(1,4), MA(4))
7045       CALL HWH2F1(8,F0M,5,PM(1,1),-MA(1))
7046       CALL HWH2F2(8,F1M,6,PM(1,2),-MA(2))
7047       CALL HWH2F3(8,F01,PTMP,ZERO)
7048 C--now find the prefactor for all the diagrams
7049       PRE = HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2))*
7050      &      HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
7051       PRE = ONE/SQRT(PRE)
7052 C--zero the matrix element
7053       DO 8 P0=1,2
7054       DO 8 P1=1,2
7055       DO 8 P2=1,2
7056       DO 8 P3=1,2
7057       DO 8 I =1,NCTHRE
7058  8    ME(P0,P1,P2,P3,I) = (0.0D0,0.0D0)
7059 C--now call the subroutines to compute the individual diagrams
7060       DO 9 I=1,NDIA
7061 C--vector boson exchange diagram
7062       IF(DRTYPE(I).EQ.1) THEN
7063         CALL HWD3M1(I,MED)
7064 C--Higgs boson exchange diagram
7065       ELSEIF(DRTYPE(I).EQ.2) THEN
7066         CALL HWD3M2(I,MED)
7067 C--antisfermion exchange diagram
7068       ELSEIF(DRTYPE(I).EQ.3) THEN
7069         CALL HWD3M3(I,MED)
7070 C--sfermion exchange diagram
7071       ELSEIF(DRTYPE(I).EQ.4) THEN
7072         CALL HWD3M4(I,MED)
7073 C--antifermion vector boson exchange diagram
7074       ELSEIF(DRTYPE(I).EQ.5) THEN
7075         CALL HWD3M5(I,MED)
7076 C--scalar vector boson exchange diagram
7077       ELSEIF(DRTYPE(I).EQ.6) THEN
7078         CALL HWD3M6(I,MED)
7079 C--gravitino fermion fermion
7080       ELSEIF(DRTYPE(I).EQ.7) THEN
7081         CALL HWD3M7(I,MED)
7082 C--fermion RPV1
7083       ELSEIF(DRTYPE(I).EQ.8) THEN
7084         CALL HWD3M8(I,MED)
7085 C--fermion RPV2
7086       ELSEIF(DRTYPE(I).EQ.9) THEN
7087         CALL HWD3M9(I,MED)
7088 C--fermion RPV3
7089       ELSEIF(DRTYPE(I).EQ.10) THEN
7090         CALL HWD3MA(I,MED)
7091 C--fermion --> 3 fermions 1
7092       ELSEIF(DRTYPE(I).EQ.11) THEN
7093         CALL HWD3MB(I,MED)
7094 C--fermion --> 3 fermions 2
7095       ELSEIF(DRTYPE(I).EQ.12) THEN
7096         CALL HWD3MC(I,MED)
7097 C--fermion --> 3 fermions 3
7098       ELSEIF(DRTYPE(I).EQ.13) THEN
7099         CALL HWD3MD(I,MED)
7100 C--fermion --> 3 antifermions 1
7101       ELSEIF(DRTYPE(I).EQ.14) THEN
7102         CALL HWD3MF(I,MED)
7103 C--fermion --> 3 antifermions 2
7104       ELSEIF(DRTYPE(I).EQ.15) THEN
7105         CALL HWD3MG(I,MED)
7106 C--fermion --> 3 antifermions 3
7107       ELSEIF(DRTYPE(I).EQ.16) THEN
7108         CALL HWD3MH(I,MED)
7109 C--antifermion --> antifermion fermion fermion
7110       ELSEIF(DRTYPE(I).EQ.17) THEN
7111         CALL HWD3MI(I,MED)
7112 C--error not known
7113       ELSE
7114         CALL HWWARN('HWD3M0',501,*999)
7115       ENDIF
7116 C--add up the matrix elements
7117       DO 10 P0=1,2
7118       DO 10 P1=1,2
7119       DO 10 P2=1,2
7120       DO 10 P3=1,2
7121  10   ME(P0,P1,P2,P3,DRCF(I)) = ME(P0,P1,P2,P3,DRCF(I))
7122      &                           +MED(P0,P1,P2,P3)
7123  9    CONTINUE
7124 C--preform the final normalisation
7125       DO 15 P0=1,2
7126       DO 15 P1=1,2
7127       DO 15 P2=1,2
7128       DO 15 P3=1,2
7129       DO 15 I =1,NCTHRE
7130  15   ME(P0,P1,P2,P3,I) = PRE*ME(P0,P1,P2,P3,I)
7131 C--compute the unnormalised spin density matrix
7132       DO 35 P0 =1,2
7133       DO 35 P0P=1,2
7134       RHOB(P0,P0P) = (0.0D0,0.0D0)
7135       DO 35 P1=1,2
7136       DO 35 P2=1,2
7137       DO 35 P3=1,2
7138       DO 35 I =1,NCTHRE
7139       DO 35 J =1,NCTHRE
7140  35   RHOB(P0,P0P)=RHOB(P0,P0P)+CFTHRE(I,J)*ME(P0,P1,P2,P3,I)*
7141      &             DCONJG(ME(P0P,P1,P2,P3,J))
7142 C--compute the weight
7143       WGT = ZERO
7144       DO 45 P0=1,2
7145       DO 45 P0P=1,2
7146  45   WGT = WGT+RHOIN(P0,P0P)*RHOB(P0,P0P)
7147 C--normalise this for phase space
7148       WGT = WGT*PHS
7149 C--if initialising select the max weight
7150       IF(SYSPIN.OR.THREEB)
7151      &        MWGT = PHS*(MAX(DBLE(RHOB(1,1)),DBLE(RHOB(2,2)))
7152      &               +ABS(DBLE(RHOB(1,2)))+ABS(DIMAG(RHOB(1,2))))
7153 C--if generating the event put the information in the common block
7154       IF(GENEV) THEN
7155 C--put the matrix element into the spin common block
7156         IF(SYSPIN) THEN
7157           DO 25 P0=1,2
7158           DO 25 P1=1,2
7159           DO 25 P2=1,2
7160           DO 25 P3=1,2
7161           DO 25 I =1,NCTHRE
7162  25       MESPN(P0,P1,P2,P3,I,IDSPIN) = ME(P0,P1,P2,P3,I)
7163           NCFL(IDSPIN) = NCTHRE
7164         ENDIF
7165 C--if more than one colour flow pick the flow
7166         IF(SPCOPT.EQ.2.AND.NCTHRE.NE.1) THEN
7167 C--contstruct the matrix elements for the colour flows
7168           WGTC = ZERO
7169           DO 50 I=1,NCTHRE
7170           WGTB(I) = ZERO
7171           DO 55 P0=1,2
7172           DO 55 P0P=1,2
7173           DO 55 P1=1,2
7174           DO 55 P2=1,2
7175           DO 55 P3=1,2
7176  55       WGTB(I) = WGTB(I)+CFTHRE(I,I)*
7177      &    RHOIN(P0,P0P)*ME(P0 ,P1,P2,P3,I)*DCONJG(ME(P0P,P1,P2,P3,I))
7178           WGTB(I) = WGTB(I)*PHS
7179  50       WGTC    = WGTC+WGTB(I)
7180           WGTC    = WGT/WGTC
7181           DO 60 I=1,NCTHRE
7182  60       WGTB(I) = WGTB(I)*WGTC
7183 C--select the colour flow
7184           WGTC    = HWRGEN(1)*WGT
7185           DO 70 I=1,NCTHRE
7186           IF(WGTB(I).GE.WGTC) THEN
7187             NCFL(IDSPIN) = I
7188             RETURN
7189           ENDIF
7190  70       WGTC = WGTC-WGTB(I)
7191 C--otherwise if wrong options set issue warning
7192         ELSEIF(NCTHRE.NE.1) THEN
7193           WRITE(6,1000)
7194           CALL HWWARN('HWD3M0',500,*999)
7195         ENDIF
7196       ENDIF
7197  1000 FORMAT(/'MULTIPLE COLOUR FLOWS IN DECAY'/'SPCOPT=2 MUST BE USED')
7198  999  END
7199 CDECK  ID>, HWD3M1.
7200 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7201 *-- Author :    Peter Richardson
7202 C-----------------------------------------------------------------------
7203       SUBROUTINE HWD3M1(ID,ME)
7204 C-----------------------------------------------------------------------
7205 C  Subroutine to calculate the helicity amplitudes for the three body
7206 C  gauge boson exchange diagram
7207 C-----------------------------------------------------------------------
7208       INCLUDE 'HERWIG65.INC'
7209       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7210      &     F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
7211      &     AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8)
7212       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,
7213      &     MR,P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7214       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7215      &     DRCF(NDIAGR)
7216       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7217      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7218      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7219       PARAMETER(ZI=(0.0D0,1.0D0))
7220       COMMON/HWHEWS/S(8,8,2),D(8,8)
7221       DATA O/2,1/
7222 C--compute the propagator factor
7223       PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7224       CN = -ONE/MS(ID)
7225 C--compute the C and D functions
7226       DO 10 P1=1,2
7227       DO 10 P2=1,2
7228         IF(P1.EQ.P2) THEN
7229 C--the A functions
7230           APP(P1,P2) =  B(  P2 ,ID)*S(7,3,O(P1))*S(4,8,  P1 )
7231           APM(P1,P2) = 0.0D0
7232           AMP(P1,P2) = 0.0D0
7233           AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7234 C--the C and E functions
7235           C(P1,P2) = A(  P1 ,ID)*( MA2(1)*S(6,2,O(P2))*S(2,5,  P2 )
7236      &                            -MA2(2)*S(6,1,O(P2))*S(1,5,  P2 ))
7237      &          +A(O(P1),ID)*MA(1)*MA(2)*( S(6,1,O(P2))*S(1,5,  P2 )
7238      &                                    -S(6,2,O(P2))*S(2,5,  P2 ))
7239           E(P1,P2) =CN*(B(  P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8,  P1 )
7240      &                               +MA2(4)*S(7,3,O(P1))*S(3,8,  P1 ))
7241      &         -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8,  P1 )
7242      &                                   +S(7,4,O(P1))*S(4,8,  P1 )))
7243         ELSE
7244 C--the A functions
7245           APP(P1,P2) = 0.0D0
7246           APM(P1,P2) = B(  P2 ,ID)*MA(3)*S(4,8,O(P1))
7247           AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7248           AMM(P1,P2) = 0.0D0
7249 C--the C and D functions
7250           C(P1,P2) = A(  P1 ,ID)*MA(2)*( MA2(1)*S(6,5,O(P2))
7251      &                   -S(6,2,O(P2))*S(2,1,  P2 )*S(1,5,O(P2)))
7252      &              +A(O(P1),ID)*MA(1)*(-MA2(2)*S(6,5,O(P2))
7253      &                   +S(6,2,O(P2))*S(2,1,  P2 )*S(1,5,O(P2)))
7254           E(P1,P2) =CN*( B(  P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7255      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
7256      &                  -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7257      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
7258         ENDIF
7259  10   CONTINUE
7260 C--compute the matrix element
7261       DO 20 P0=1,2
7262       DO 20 P1=1,2
7263       DO 20 P2=1,2
7264       DO 20 P3=1,2
7265         ME(P0,P1,P2,P3) =
7266      &     APP(P2,P3)*( A(O(P2),ID)*F1(O(P1),  P2 ,4)*F0(  P2 ,O(P0),3)
7267      &                 +A(  P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),4))
7268      &    +APM(P2,P3)*( A(  P2 ,ID)*F1(O(P1),O(P2),4)*F0(O(P2),O(P0),7)
7269      &                 +A(O(P2),ID)*F1(O(P1),  P2 ,7)*F0(  P2 ,O(P0),4))
7270      &    +AMP(P2,P3)*( A(O(P2),ID)*F1(O(P1),  P2 ,8)*F0(  P2 ,O(P0),3)
7271      &                 +A(  P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),8))
7272      &    +AMM(P2,P3)*( A(  P2 ,ID)*F1(O(P1),O(P2),8)*F0(O(P2),O(P0),7)
7273      &                 +A(O(P2),ID)*F1(O(P1),  P2 ,7)*F0(  P2 ,O(P0),8))
7274  20         ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
7275       END
7276 CDECK  ID>, HWD3M2.
7277 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7278 *-- Author :    Peter Richardson
7279 C-----------------------------------------------------------------------
7280       SUBROUTINE HWD3M2(ID,ME)
7281 C-----------------------------------------------------------------------
7282 C  Subroutine to calculate the helicity amplitudes for the three body
7283 C  Higgs boson exchange diagram
7284 C-----------------------------------------------------------------------
7285       INCLUDE 'HERWIG65.INC'
7286       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7287      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7288      &     F3(2,2,8)
7289       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7290      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7291       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7292      &     DRCF(NDIAGR)
7293       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7294      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7295      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7296       DATA O/2,1/
7297       COMMON/HWHEWS/S(8,8,2),D(8,8)
7298       PARAMETER(ZI=(0.0D0,1.0D0))
7299 C--decide whether to do the diagram
7300       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
7301      &     IDP(4+ID).NE.206) THEN
7302         DO 5 P0=1,2
7303         DO 5 P1=1,2
7304         DO 5 P2=1,2
7305         DO 5 P3=1,2
7306  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7307         RETURN
7308       ENDIF
7309 C--calculate the propagator factor
7310       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7311 C--calculate the vertex functions
7312       DO 10 P1=1,2
7313       DO 10 P2=1,2
7314          V1(P1,P2) = PRE*( A(  P1 ,ID)*F1(O(P2),  P1 ,1)*S(1,5,P1)
7315      &                    +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
7316  10      V2(P1,P2) =       B(  P2 ,ID)*F2(O(P1),  P2 ,4)*S(4,8,P2)
7317      &                    -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
7318 C--calculate the matrix element
7319       DO 20 P0=1,2
7320       DO 20 P1=1,2
7321       DO 20 P2=1,2
7322       DO 20 P3=1,2
7323  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7324       END
7325 CDECK  ID>, HWD3M3.
7326 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7327 *-- Author :    Peter Richardson
7328 C-----------------------------------------------------------------------
7329       SUBROUTINE HWD3M3(ID,ME)
7330 C-----------------------------------------------------------------------
7331 C  Subroutine to calculate the helicity amplitudes for the three body
7332 C  antisfermion exchange diagram
7333 C-----------------------------------------------------------------------
7334       INCLUDE 'HERWIG65.INC'
7335       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7336      &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7337      &     F3(2,2,8)
7338       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7339      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7340       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7341      &     DRCF(NDIAGR)
7342       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7343      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7344      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7345       DATA O/2,1/
7346       COMMON/HWHEWS/S(8,8,2),D(8,8)
7347       PARAMETER(ZI=(0.0D0,1.0D0))
7348 C--decide whether to do the diagram
7349       IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7350         DO 5 P0=1,2
7351         DO 5 P1=1,2
7352         DO 5 P2=1,2
7353         DO 5 P3=1,2
7354  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7355         RETURN
7356       ENDIF
7357 C--compute the propagator factor
7358       PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7359 C--compute the vertex factors
7360       DO 10 P1=1,2
7361       DO 10 P2=1,2
7362          V1(P1,P2) = PRE*( A(  P1 ,ID)*F2(O(P2),  P1 ,1)*S(1,5,P1)
7363      &                    +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
7364  10      V2(P1,P2) = B(  P2 ,ID)*F1(O(P1),  P2 ,4)*S(4,8,P2)
7365      &              -B(O(P2),ID)*F1(O(P1),O(P2),8)*MA(4)
7366 C--compute the matrix element
7367       DO 20 P0=1,2
7368       DO 20 P1=1,2
7369       DO 20 P2=1,2
7370       DO 20 P3=1,2
7371  20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7372       END
7373 CDECK  ID>, HWD3M4.
7374 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7375 *-- Author :    Peter Richardson
7376 C-----------------------------------------------------------------------
7377       SUBROUTINE HWD3M4(ID,ME)
7378 C-----------------------------------------------------------------------
7379 C  Subroutine to calculate the helicity amplitudes for the three body
7380 C  sfermion exchange diagram
7381 C-----------------------------------------------------------------------
7382       INCLUDE 'HERWIG65.INC'
7383       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7384      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7385      &     F3(2,2,8)
7386       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7387      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7388       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7389      &     DRCF(NDIAGR)
7390       COMMON/HWHEWS/S(8,8,2),D(8,8)
7391       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7392      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7393      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7394       PARAMETER(ZI=(0.0D0,1.0D0))
7395       DATA O/2,1/
7396 C--decide whether to do the diagram
7397       IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7398         DO 5 P0=1,2
7399         DO 5 P1=1,2
7400         DO 5 P2=1,2
7401         DO 5 P3=1,2
7402  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7403         RETURN
7404       ENDIF
7405 C--compute the propagator factor
7406       PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7407 C--compute the factors for the two vertices
7408       DO 10 P1=1,2
7409       DO 10 P2=1,2
7410          V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,4)*S(4,8,  P2 )
7411      &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),8)*MA(4))
7412  10      V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
7413      &              -B(  P1 ,ID)*F2 (O(P2),  P1 ,6)*MA(2)
7414 C--now compute the matrix element
7415       DO 20 P0=1,2
7416       DO 20 P1=1,2
7417       DO 20 P2=1,2
7418       DO 20 P3=1,2
7419  20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7420       END
7421 CDECK  ID>, HWD3M5.
7422 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7423 *-- Author :    Peter Richardson
7424 C-----------------------------------------------------------------------
7425       SUBROUTINE HWD3M5(ID,ME)
7426 C-----------------------------------------------------------------------
7427 C  Subroutine to calculate the helicity amplitudes for the three body
7428 C  gauge boson exchange diagram (antiparticle decay)
7429 C-----------------------------------------------------------------------
7430       INCLUDE 'HERWIG65.INC'
7431       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
7432      &     F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
7433      &     AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
7434       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
7435      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7436       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7437      &     DRCF(NDIAGR)
7438       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7439      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7440      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7441       PARAMETER(ZI=(0.0D0,1.0D0))
7442       COMMON/HWHEWS/S(8,8,2),D(8,8)
7443       DATA O/2,1/
7444 C--compute the propagator factor
7445       PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7446       CN = -ONE/MS(ID)
7447 C--compute the C and D functions
7448       DO 10 P1=1,2
7449       DO 10 P2=1,2
7450         IF(P1.EQ.P2) THEN
7451 C--the A functions
7452           APP(P1,P2) =  B(  P2 ,ID)*S(7,3,O(P1))*S(4,8,  P1 )
7453           APM(P1,P2) = 0.0D0
7454           AMP(P1,P2) = 0.0D0
7455           AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7456 C--the C and E functions
7457           C(P1,P2) = A(  P2 ,ID)*( MA2(1)*S(5,2,O(P1))*S(2,6,  P1 )
7458      &                            -MA2(2)*S(5,1,O(P1))*S(1,6,  P1 ))
7459      &          +A(O(P2),ID)*MA(1)*MA(2)*( S(5,1,O(P1))*S(1,6,  P1 )
7460      &                                    -S(5,2,O(P1))*S(2,6,  P1 ))
7461           E(P1,P2) =CN*(B(  P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8,  P1 )
7462      &                               +MA2(4)*S(7,3,O(P1))*S(3,8,  P1 ))
7463      &         -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8,  P1 )
7464      &                                   +S(7,4,O(P1))*S(4,8,  P1 )))
7465         ELSE
7466 C--the A functions
7467           APP(P1,P2) = 0.0D0
7468           APM(P1,P2) = B(  P2 ,ID)*MA(3)*S(4,8,O(P1))
7469           AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7470           AMM(P1,P2) = 0.0D0
7471 C--the C and D functions
7472           C(P1,P2) = A(  P2 ,ID)*MA(1)*( MA2(2)*S(5,6,O(P1))
7473      &                   -S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1)))
7474      &              +A(O(P2),ID)*MA(2)*(-MA2(1)*S(5,6,O(P1))
7475      &                   +S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1)))
7476           E(P1,P2) =CN*( B(  P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7477      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
7478      &                  -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7479      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
7480         ENDIF
7481  10   CONTINUE
7482 C--compute the matrix element
7483       DO 20 P0=1,2
7484       DO 20 P1=1,2
7485       DO 20 P2=1,2
7486       DO 20 P3=1,2
7487       ME(P0,P1,P2,P3) =
7488      &   APP(P2,P3)*( A(O(P2),ID)*F0M(O(P0),  P2 ,4)*F1M(  P2 ,O(P1),3)
7489      &               +A(  P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),4))
7490      &  +APM(P2,P3)*( A(  P2 ,ID)*F0M(O(P0),O(P2),4)*F1M(O(P2),O(P1),7)
7491      &               +A(O(P2),ID)*F0M(O(P0),  P2 ,7)*F1M(  P2 ,O(P1),4))
7492      &  +AMP(P2,P3)*( A(O(P2),ID)*F0M(O(P0),  P2 ,8)*F1M(  P2 ,O(P1),3)
7493      &               +A(  P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),8))
7494      &  +AMM(P2,P3)*( A(  P2 ,ID)*F0M(O(P0),O(P2),8)*F1M(O(P2),O(P1),7)
7495      &               +A(O(P2),ID)*F0M(O(P0),  P2 ,7)*F1M(  P2 ,O(P1),8))
7496  20   ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
7497       END
7498 CDECK  ID>, HWD3M6.
7499 *CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
7500 *-- Author :    Peter Richardson
7501 C-----------------------------------------------------------------------
7502       SUBROUTINE HWD3M6(ID,ME)
7503 C-----------------------------------------------------------------------
7504 C  Subroutine to calculate the helicity amplitudes for the three body
7505 C  gauge boson exchange diagram
7506 C-----------------------------------------------------------------------
7507       INCLUDE 'HERWIG65.INC'
7508       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
7509      &     F0M(2,2,8),F2(2,2,8),PRE,C(2,2),ZI,APP(2,2),APM(2,2),
7510      &     AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
7511       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
7512      &     P(5,4),DOT,HWULDO,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7513       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7514      &     DRCF(NDIAGR)
7515       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7516      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7517      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7518       DOUBLE PRECISION XMASS,PLAB,PRW,PCM
7519       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7520       PARAMETER(ZI=(0.0D0,1.0D0))
7521       COMMON/HWHEWS/S(8,8,2),D(8,8)
7522       DATA O/2,1/
7523       EXTERNAL HWULDO
7524 C--compute the propagator factor
7525       PRE = SQRT(HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2)))
7526       PRE = -HALF*PRE*A(1,ID)/(M342-MS(ID)+ZI*MWD(ID))
7527       CN = -ONE/MS(ID)
7528       DOT = HWULDO(P(1,1),P(1,3))+HWULDO(P(1,1),P(1,4))
7529      &     +HWULDO(P(1,2),P(1,3))+HWULDO(P(1,2),P(1,4))
7530 C--compute the C and D functions
7531       DO 10 P1=1,2
7532       DO 10 P2=1,2
7533         IF(P1.EQ.P2) THEN
7534 C--the A functions
7535           APP(P1,P2) =  B(  P2 ,ID)*S(7,3,O(P1))*S(4,8,  P1 )
7536           APM(P1,P2) = 0.0D0
7537           AMP(P1,P2) = 0.0D0
7538           AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7539 C--the C function
7540           C(P1,P2) =CN*(B(  P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8,  P1 )
7541      &                               +MA2(4)*S(7,3,O(P1))*S(3,8,  P1 ))
7542      &         -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8,  P1 )
7543      &                                   +S(7,4,O(P1))*S(4,8,  P1 )))
7544         ELSE
7545 C--the A functions
7546           APP(P1,P2) = 0.0D0
7547           APM(P1,P2) = B(  P2 ,ID)*MA(3)*S(4,8,O(P1))
7548           AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7549           AMM(P1,P2) = 0.0D0
7550 C--the C functions
7551           C(P1,P2) =CN*( B(  P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7552      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
7553      &                  -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7554      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
7555         ENDIF
7556  10   CONTINUE
7557 C--compute the matrix element
7558       DO 15 P0=1,2
7559       DO 15 P1=1,2
7560       DO 15 P2=1,2
7561       DO 15 P3=1,2
7562  15   ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7563       DO 20 P2=1,2
7564       DO 20 P3=1,2
7565  20   ME(1,1,P2,P3) = PRE*(DOT*C(P2,P3)
7566      & +APP(P2,P3)*F01(  P2 ,  P2 ,3,4)+APM(P2,P3)*F01(O(P2),O(P2),7,4)
7567      & +AMP(P2,P3)*F01(  P2 ,  P2 ,3,8)+AMM(P2,P3)*F01(O(P2),O(P2),7,8))
7568       END
7569 CDECK  ID>, HWD3M7.
7570 *CMZ :-        -13/03/02  14:19:47  by  Peter Richardson
7571 *-- Author :    Peter Richardson
7572 C-----------------------------------------------------------------------
7573       SUBROUTINE HWD3M7(ID,ME)
7574 C-----------------------------------------------------------------------
7575 C  Subroutine to calculate the helicity amplitudes for the three body
7576 C  decay fermion --> gravitino fermion antifermion (via gauge boson)
7577 C-----------------------------------------------------------------------
7578       INCLUDE 'HERWIG65.INC'
7579       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7580      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,F1M(2,2,8),F3(2,2,8)
7581       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7582      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX),HWULDO,DL(2,2)
7583       INTEGER P0,P1,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7584      &     DRCF(NDIAGR)
7585       COMMON/HWHEWS/S(8,8,2),D(8,8)
7586       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7587      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7588      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7589       PARAMETER(ZI=(0.0D0,1.0D0))
7590       DOUBLE PRECISION XMASS,PLAB,PRW,PCM
7591       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7592       DATA O/2,1/
7593       DATA DL/1.0D0,0.0D0,0.0D0,1.0D0/
7594       EXTERNAL HWULDO
7595 C--compute the propagator factor
7596       PRE = HALF*HWULDO(PCM(1,6),PM(1,2))*
7597      &      HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
7598       PRE = SQRT(PRE)
7599       PRE = PRE/(M342-MS(ID)+ZI*MWD(ID))
7600       DO 10 P0=1,2
7601       DO 10 P1=1,2
7602       ME(P0,P1,  P1 ,  P1 ) = PRE*B(  P1 ,ID)*(
7603      &   A(1,ID)*S(2,3,P1)*S(3,4,O(P1))*S(3,2,  P1 )*F0(O(P1),O(P0),2)
7604      &  +A(2,ID)* DL(P1,1)*S(2,3,  P1 )*S(4,2,O(P1))*F0(  1  ,O(P0),2))
7605       ME(P0,P1,O(P1),O(P1)) = PRE*B(O(P1),ID)*(
7606      &   A(1,ID)*S(2,4,P1)*S(4,3,O(P1))*S(4,2,  P1 )*F0(O(P1),O(P0),2)
7607      &  +A(2,ID)* DL(P1,1)*S(2,4,  P1 )*S(3,2,O(P1))*F0(  1  ,O(P0),2))
7608       ME(P0,P1,O(P1),  P1 ) = (0.0D0,0.0D0)
7609  10   ME(P0,P1,  P1 ,O(P1)) = (0.0D0,0.0D0)
7610       END
7611 CDECK  ID>, HWD3M8.
7612 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7613 *-- Author :    Peter Richardson
7614 C-----------------------------------------------------------------------
7615       SUBROUTINE HWD3M8(ID,ME)
7616 C-----------------------------------------------------------------------
7617 C  Subroutine to calculate the helicity amplitudes for 1st 3 body RPV
7618 C  diagram f--> fbar fbar f
7619 C-----------------------------------------------------------------------
7620       INCLUDE 'HERWIG65.INC'
7621       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7622      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7623      &     F3(2,2,8)
7624       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7625      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7626       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7627      &     DRCF(NDIAGR)
7628       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7629      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7630      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7631       DATA O/2,1/
7632       COMMON/HWHEWS/S(8,8,2),D(8,8)
7633       PARAMETER(ZI=(0.0D0,1.0D0))
7634 C--decide whether to do the diagram
7635       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7636         DO 5 P0=1,2
7637         DO 5 P1=1,2
7638         DO 5 P2=1,2
7639         DO 5 P3=1,2
7640  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7641         RETURN
7642       ENDIF
7643 C--calculate the propagator factor
7644       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7645 C--calculate the vertex functions
7646       DO 10 P1=1,2
7647       DO 10 P2=1,2
7648       V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,2)*S(2,6,  P2)
7649      &                 -A(O(P2),ID)*F0M(  P1 ,O(P2),6)*MA(2))
7650  10   V2(P1,P2) =       B(  P1 ,ID)*F3 (O(P2),  P1 ,3)*S(3,7,P1)
7651      &                 -B(O(P1),ID)*F3 (O(P2),O(P1),7)*MA(3)
7652 C--calculate the matrix element
7653       DO 20 P0=1,2
7654       DO 20 P1=1,2
7655       DO 20 P2=1,2
7656       DO 20 P3=1,2
7657  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7658       END
7659 CDECK  ID>, HWD3M9.
7660 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7661 *-- Author :    Peter Richardson
7662 C-----------------------------------------------------------------------
7663       SUBROUTINE HWD3M9(ID,ME)
7664 C-----------------------------------------------------------------------
7665 C  Subroutine to calculate the helicity amplitudes for 2nd 3 body RPV
7666 C  diagram f --> fbar fbar f
7667 C-----------------------------------------------------------------------
7668       INCLUDE 'HERWIG65.INC'
7669       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7670      &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7671      &     F3(2,2,8)
7672       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7673      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7674       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7675      &     DRCF(NDIAGR)
7676       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7677      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7678      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7679       DATA O/2,1/
7680       COMMON/HWHEWS/S(8,8,2),D(8,8)
7681       PARAMETER(ZI=(0.0D0,1.0D0))
7682 C--decide whether to do the diagram
7683       IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7684         DO 5 P0=1,2
7685         DO 5 P1=1,2
7686         DO 5 P2=1,2
7687         DO 5 P3=1,2
7688  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7689         RETURN
7690       ENDIF
7691 C--compute the propagator factor
7692       PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7693 C--compute the vertex factors
7694       DO 10 P1=1,2
7695       DO 10 P2=1,2
7696       V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,3)*S(3,7,P2)
7697      &                 -A(O(P2),ID)*F0M(  P1 ,O(P2),7)*MA(3))
7698  10   V2(P1,P2) =       B(  P1 ,ID)*F3 (O(P2),  P1 ,2)*S(2,6,P1)
7699      &                 -B(O(P1),ID)*F3 (O(P2),O(P1),6)*MA(2)
7700 C--compute the matrix element
7701       DO 20 P0=1,2
7702       DO 20 P1=1,2
7703       DO 20 P2=1,2
7704       DO 20 P3=1,2
7705  20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7706       END
7707 CDECK  ID>, HWD3MA.
7708 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7709 *-- Author :    Peter Richardson
7710 C-----------------------------------------------------------------------
7711       SUBROUTINE HWD3MA(ID,ME)
7712 C-----------------------------------------------------------------------
7713 C  Subroutine to calculate the helicity amplitudes for 3rd 3 body RPV
7714 C  diagram f --> fbar fbar f
7715 C-----------------------------------------------------------------------
7716       INCLUDE 'HERWIG65.INC'
7717       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7718      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7719      &     F3(2,2,8)
7720       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7721      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7722       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7723      &     DRCF(NDIAGR)
7724       COMMON/HWHEWS/S(8,8,2),D(8,8)
7725       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7726      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7727      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7728       PARAMETER(ZI=(0.0D0,1.0D0))
7729       DATA O/2,1/
7730 C--decide whether to do the diagram
7731       IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7732         DO 5 P0=1,2
7733         DO 5 P1=1,2
7734         DO 5 P2=1,2
7735         DO 5 P3=1,2
7736  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7737         RETURN
7738       ENDIF
7739 C--compute the propagator factor
7740       PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7741 C--compute the factors for the two vertices
7742       DO 10 P1=1,2
7743       DO 10 P2=1,2
7744       V1(P1,P2) = PRE*( A(  P1 ,ID)*F3(O(P2),  P1 ,1)*S(1,5,P1)
7745      &                 +A(O(P1),ID)*F3(O(P2),O(P1),5)*MA(1))
7746  10   V2(P1,P2) =       B(  P2 ,ID)*F1(  P1 ,  P2 ,3)*S(3,7,P2)
7747      &                 -B(O(P2),ID)*F1(  P1 ,O(P2),7)*MA(3)
7748 C--now compute the matrix element
7749       DO 20 P0=1,2
7750       DO 20 P1=1,2
7751       DO 20 P2=1,2
7752       DO 20 P3=1,2
7753  20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7754       END
7755 CDECK  ID>, HWD3MB.
7756 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7757 *-- Author :    Peter Richardson
7758 C-----------------------------------------------------------------------
7759       SUBROUTINE HWD3MB(ID,ME)
7760 C-----------------------------------------------------------------------
7761 C  Subroutine to calculate the helicity amplitudes for 4th 3 body RPV
7762 C  diagram f --> f f f
7763 C-----------------------------------------------------------------------
7764       INCLUDE 'HERWIG65.INC'
7765       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7766      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7767      &     F3(2,2,8)
7768       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7769      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7770       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7771      &     DRCF(NDIAGR)
7772       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7773      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7774      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7775       DATA O/2,1/
7776       COMMON/HWHEWS/S(8,8,2),D(8,8)
7777       PARAMETER(ZI=(0.0D0,1.0D0))
7778 C--decide whether to do the diagram
7779       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7780         DO 5 P0=1,2
7781         DO 5 P1=1,2
7782         DO 5 P2=1,2
7783         DO 5 P3=1,2
7784  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7785         RETURN
7786       ENDIF
7787 C--calculate the propagator factor
7788       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7789 C--calculate the vertex functions
7790       DO 10 P1=1,2
7791       DO 10 P2=1,2
7792          V1(P1,P2) = PRE*( A(  P1 ,ID)*F1(O(P2),  P1 ,1)*S(1,5,P1)
7793      &                    +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
7794  10      V2(P1,P2) =       B(O(P2),ID)*F2(O(P1),O(P2),4)*S(4,8,O(P2))
7795      &                    -B(  P2 ,ID)*F2(O(P1),  P2 ,8)*MA(4)
7796 C--calculate the matrix element
7797       DO 20 P0=1,2
7798       DO 20 P1=1,2
7799       DO 20 P2=1,2
7800       DO 20 P3=1,2
7801  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7802       END
7803 CDECK  ID>, HWD3MC.
7804 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7805 *-- Author :    Peter Richardson
7806 C-----------------------------------------------------------------------
7807       SUBROUTINE HWD3MC(ID,ME)
7808 C-----------------------------------------------------------------------
7809 C  Subroutine to calculate the helicity amplitudes for 5th 3 body RPV
7810 C  diagram f --> f f f
7811 C-----------------------------------------------------------------------
7812       INCLUDE 'HERWIG65.INC'
7813       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7814      &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7815      &     F3(2,2,8)
7816       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7817      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7818       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7819      &     DRCF(NDIAGR)
7820       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7821      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7822      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7823       DATA O/2,1/
7824       COMMON/HWHEWS/S(8,8,2),D(8,8)
7825       PARAMETER(ZI=(0.0D0,1.0D0))
7826 C--decide whether to do the diagram
7827       IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7828         DO 5 P0=1,2
7829         DO 5 P1=1,2
7830         DO 5 P2=1,2
7831         DO 5 P3=1,2
7832  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7833         RETURN
7834       ENDIF
7835 C--compute the propagator factor
7836       PRE =-0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7837 C--compute the vertex factors
7838       DO 10 P1=1,2
7839       DO 10 P2=1,2
7840          V1(P1,P2) = PRE*( A(  P1 ,ID)*F2(O(P2),  P1 ,1)*S(1,5,P1)
7841      &                    +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
7842  10      V2(P1,P2) = B(O(P2),ID)*F1(O(P1),O(P2),4)*S(4,8,O(P2))
7843      &              -B(  P2 ,ID)*F1(O(P1),  P2 ,8)*MA(4)
7844 C--compute the matrix element
7845       DO 20 P0=1,2
7846       DO 20 P1=1,2
7847       DO 20 P2=1,2
7848       DO 20 P3=1,2
7849  20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7850       END
7851 CDECK  ID>, HWD3MD.
7852 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7853 *-- Author :    Peter Richardson
7854 C-----------------------------------------------------------------------
7855       SUBROUTINE HWD3MD(ID,ME)
7856 C-----------------------------------------------------------------------
7857 C  Subroutine to calculate the helicity amplitudes for 6th 3 body RPV
7858 C  diagram f --> f f f
7859 C-----------------------------------------------------------------------
7860       INCLUDE 'HERWIG65.INC'
7861       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7862      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7863      &     F3(2,2,8)
7864       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7865      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7866       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7867      &     DRCF(NDIAGR)
7868       COMMON/HWHEWS/S(8,8,2),D(8,8)
7869       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7870      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7871      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7872       PARAMETER(ZI=(0.0D0,1.0D0))
7873       DATA O/2,1/
7874 C--decide whether to do the diagram
7875       IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7876         DO 5 P0=1,2
7877         DO 5 P1=1,2
7878         DO 5 P2=1,2
7879         DO 5 P3=1,2
7880  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7881         RETURN
7882       ENDIF
7883 C--compute the propagator factor
7884       PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7885 C--compute the factors for the two vertices
7886       DO 10 P1=1,2
7887       DO 10 P2=1,2
7888          V1(P1,P2) = PRE*( A(O(P2),ID)*F0M(  P1 ,O(P2),4)*S(4,8,O(P2))
7889      &                    -A(  P2 ,ID)*F0M(  P1 ,  P2 ,8)*MA(4))
7890  10      V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
7891      &              -B(  P1 ,ID)*F2 (O(P2),  P1 ,6)*MA(2)
7892 C--now compute the matrix element
7893       DO 20 P0=1,2
7894       DO 20 P1=1,2
7895       DO 20 P2=1,2
7896       DO 20 P3=1,2
7897  20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7898       END
7899 CDECK  ID>, HWD3MF.
7900 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7901 *-- Author :    Peter Richardson
7902 C-----------------------------------------------------------------------
7903       SUBROUTINE HWD3MF(ID,ME)
7904 C-----------------------------------------------------------------------
7905 C  Subroutine to calculate the helicity amplitudes for 7th 3 body RPV
7906 C  diagram f --> fbar fbar fbar
7907 C-----------------------------------------------------------------------
7908       INCLUDE 'HERWIG65.INC'
7909       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7910      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7911      &     F3(2,2,8)
7912       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7913      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7914       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7915      &     DRCF(NDIAGR)
7916       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7917      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7918      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7919       DATA O/2,1/
7920       COMMON/HWHEWS/S(8,8,2),D(8,8)
7921       PARAMETER(ZI=(0.0D0,1.0D0))
7922 C--decide whether to do the diagram
7923       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7924         DO 5 P0=1,2
7925         DO 5 P1=1,2
7926         DO 5 P2=1,2
7927         DO 5 P3=1,2
7928  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7929         RETURN
7930       ENDIF
7931 C--calculate the propagator factor
7932       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7933 C--calculate the vertex functions
7934       DO 10 P1=1,2
7935       DO 10 P2=1,2
7936          V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,2)*S(2,6,P2)
7937      &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),6)*MA(2))
7938  10      V2(P1,P2) =       B(  P2 ,ID)*F2(  P1 ,  P2 ,4)*S(4,8,P2)
7939      &                    -B(O(P2),ID)*F2(  P1 ,O(P2),8)*MA(4)
7940 C--calculate the matrix element
7941       DO 20 P0=1,2
7942       DO 20 P1=1,2
7943       DO 20 P2=1,2
7944       DO 20 P3=1,2
7945  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7946       END
7947 CDECK  ID>, HWD3MG.
7948 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7949 *-- Author :    Peter Richardson
7950 C-----------------------------------------------------------------------
7951       SUBROUTINE HWD3MG(ID,ME)
7952 C-----------------------------------------------------------------------
7953 C  Subroutine to calculate the helicity amplitudes for 8th 3 body RPV
7954 C  diagram f --> fbar fbar fbar
7955 C-----------------------------------------------------------------------
7956       INCLUDE 'HERWIG65.INC'
7957       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7958      &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7959      &     F3(2,2,8)
7960       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7961      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7962       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7963      &     DRCF(NDIAGR)
7964       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7965      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7966      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7967       DATA O/2,1/
7968       COMMON/HWHEWS/S(8,8,2),D(8,8)
7969       PARAMETER(ZI=(0.0D0,1.0D0))
7970 C--decide whether to do the diagram
7971       IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7972         DO 5 P0=1,2
7973         DO 5 P1=1,2
7974         DO 5 P2=1,2
7975         DO 5 P3=1,2
7976  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7977         RETURN
7978       ENDIF
7979 C--compute the propagator factor
7980       PRE = 0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7981 C--compute the vertex factors
7982       DO 10 P1=1,2
7983       DO 10 P2=1,2
7984          V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,3)*S(3,7,  P2 )
7985      &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),7)*MA(3))
7986  10      V2(P1,P2) =       B(  P1 ,ID)*F3 (  P2 ,  P1 ,2)*S(2,6,  P1 )
7987      &                    -B(O(P1),ID)*F3 (  P2 ,O(P1),6)*MA(2)
7988 C--compute the matrix element
7989       DO 20 P0=1,2
7990       DO 20 P1=1,2
7991       DO 20 P2=1,2
7992       DO 20 P3=1,2
7993  20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7994       END
7995 CDECK  ID>, HWD3MH.
7996 *CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
7997 *-- Author :    Peter Richardson
7998 C-----------------------------------------------------------------------
7999       SUBROUTINE HWD3MH(ID,ME)
8000 C-----------------------------------------------------------------------
8001 C  Subroutine to calculate the helicity amplitudes for 9th 3 body RPV
8002 C  diagram f --> fbar fbar fbar
8003 C-----------------------------------------------------------------------
8004       INCLUDE 'HERWIG65.INC'
8005       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8006      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8007      &     F3(2,2,8)
8008       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8009      &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8010       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8011      &     DRCF(NDIAGR)
8012       COMMON/HWHEWS/S(8,8,2),D(8,8)
8013       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8014      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8015      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8016       PARAMETER(ZI=(0.0D0,1.0D0))
8017       DATA O/2,1/
8018 C--decide whether to do the diagram
8019       IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
8020         DO 5 P0=1,2
8021         DO 5 P1=1,2
8022         DO 5 P2=1,2
8023         DO 5 P3=1,2
8024  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8025         RETURN
8026       ENDIF
8027 C--compute the propagator factor
8028       PRE = -0.25D0/(M232-MS(ID)+ZI*MWD(ID))
8029 C--compute the factors for the two vertices
8030       DO 10 P1=1,2
8031       DO 10 P2=1,2
8032          V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,4)*S(4,8,P2)
8033      &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),8)*MA(4))
8034  10      V2(P1,P2) =       B(  P1 ,ID)*F2 (  P2 ,  P1 ,2)*S(2,6,P1)
8035      &                    -B(O(P1),ID)*F2 (  P2 ,O(P1),6)*MA(2)
8036 C--now compute the matrix element
8037       DO 20 P0=1,2
8038       DO 20 P1=1,2
8039       DO 20 P2=1,2
8040       DO 20 P3=1,2
8041  20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
8042       END
8043 CDECK  ID>, HWD3MI.
8044 *CMZ :-        -09/04/02  13:37:38  by  Peter Richardson
8045 *-- Author :    Peter Richardson
8046 C-----------------------------------------------------------------------
8047       SUBROUTINE HWD3MI(ID,ME)
8048 C-----------------------------------------------------------------------
8049 C  Subroutine to calculate the helicity amplitudes for the three body
8050 C  Higgs boson exchange diagram antifermion decay
8051 C-----------------------------------------------------------------------
8052       INCLUDE 'HERWIG65.INC'
8053       DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8054      &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8055      &     F3(2,2,8)
8056       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8057      &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8058       INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8059      &     DRCF(NDIAGR)
8060       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8061      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8062      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8063       DATA O/2,1/
8064       COMMON/HWHEWS/S(8,8,2),D(8,8)
8065       PARAMETER(ZI=(0.0D0,1.0D0))
8066 C--decide whether to do the diagram
8067       IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
8068      &   IDP(4+ID).NE.207) THEN
8069         DO 5 P0=1,2
8070         DO 5 P1=1,2
8071         DO 5 P2=1,2
8072         DO 5 P3=1,2
8073  5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8074         RETURN
8075       ENDIF
8076 C--calculate the propagator factor
8077       PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
8078 C--calculate the vertex functions
8079       DO 10 P1=1,2
8080       DO 10 P2=1,2
8081       V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(O(P1),  P2 ,2)*S(2,6,P2)
8082      &                 -A(O(P2),ID)*F0M(O(P1),O(P2),6)*MA(2))
8083  10   V2(P1,P2) =       B(  P2 ,ID)*F2(O(P1),  P2 ,4)*S(4,8,P2)
8084      &                 -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
8085 C--calculate the matrix element
8086       DO 20 P0=1,2
8087       DO 20 P1=1,2
8088       DO 20 P2=1,2
8089       DO 20 P3=1,2
8090  20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
8091       END
8092 CDECK  ID>, HWD4ME.
8093 *CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
8094 *-- Author :    Peter Richardson
8095 C-----------------------------------------------------------------------
8096       SUBROUTINE HWD4ME(ID,ITYPE1,ITYPE2,IMODE)
8097 C-----------------------------------------------------------------------
8098 C     Subroutine to perform the four body Higgs decays
8099 C-----------------------------------------------------------------------
8100       INCLUDE 'HERWIG65.INC'
8101       INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE(2),NTRY,ITYPE1,ITYPE2
8102       DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,BRW(6),BRZ(12),
8103      &     HWUPCM,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,P(5,5)
8104       EXTERNAL HWRUNI,HWUPCM,HWRGEN
8105       COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
8106       DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
8107       DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8108      &         0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
8109       ITYPE(1) = ITYPE1
8110       ITYPE(2) = ITYPE2
8111       WTMAX = WT4MAX(ITYPE(1),ITYPE(2),IMODE)
8112       PRE=P4MODE(ITYPE(1),ITYPE(2),IMODE)
8113 C--compute the masses of external particles for the decay mode
8114       DO I=1,2
8115 C--couplings and masses of the internal particles
8116         A(I) = A4MODE(I,ITYPE1,IMODE)
8117         B(I) = B4MODE(I,ITYPE2,IMODE)
8118         MR(I)  = RMASS(I4MODE(I,IMODE))
8119         MS(I)  = MR(I)**2
8120         IF(I4MODE(I,IMODE).EQ.200) THEN
8121           MWD(I) = MR(I)*GAMZ
8122         ELSE
8123           MWD(I) = MR(I)*GAMW
8124         ENDIF
8125         IDP(5+I) = I4MODE(I,IMODE)
8126 C--id's of outgoing particles
8127         IF(I4MODE(I,IMODE).EQ.200) THEN
8128           IDP(2*I  ) = ITYPE(I)
8129           IF(ITYPE(I).GT.6) IDP(2*I) = IDP(2*I)+114
8130           IDP(2*I+1) = IDP(2*I)+6
8131         ELSE
8132           IDP(2*I  ) = 2*ITYPE(I)-1
8133           IF(ITYPE(I).GT.3) IDP(2*I) = IDP(2*I)+114
8134           IDP(2*I+1) = IDP(2*I)+7
8135           IF(I4MODE(I,IMODE).EQ.198) THEN
8136             J          = IDP(2*I  )+6
8137             IDP(2*I) = IDP(2*I+1)-6
8138             IDP(2*I+1) = J
8139           ENDIF
8140         ENDIF
8141       ENDDO
8142       IDP(1) = IDK(ID4PRT(IMODE))
8143       DO 1 I=1,5
8144       M(I) = RMASS(IDP(I))
8145  1    M2(I) = M(I)**2
8146       IF(M(1).LT.M(2)+M(3)+M(4)+M(5).OR.MR(1).LT.M(2)+M(3).OR.
8147      &     MR(2).LT.M(4)+M(5)) RETURN
8148       IF(IPRINT.EQ.2.AND..NOT.GENEV)
8149      &        WRITE(6,3000) RNAME(IDP(6)),RNAME(IDP(2)),RNAME(IDP(3)),
8150      &                      RNAME(IDP(7)),RNAME(IDP(4)),RNAME(IDP(5))
8151 C--compute the width and maximum weight if initialising
8152       IF(.NOT.GENEV) THEN
8153         WMAX  = ZERO
8154         WSUM  = ZERO
8155         WSSUM = ZERO
8156         DO I=1,NSEARCH
8157           CALL HWD4M0(1,WGT)
8158           WGT = WGT*PRE
8159           IF(WGT.GT.WMAX) WMAX = WGT
8160           WSUM = WSUM+WGT
8161           WSSUM = WSSUM+WGT**2
8162           IF(WGT.LT.ZERO) CALL HWWARN('HWD4ME',500,*999)
8163         ENDDO
8164         WSUM = WSUM/DBLE(NSEARCH)
8165         WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
8166         WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
8167         IF(IPRINT.EQ.2) WRITE(6,3010) WSUM,WSSUM
8168         IF(IPRINT.EQ.2) WRITE(6,3020) WMAX
8169         TEMP = BRFRAC(ID4PRT(IMODE))*HBAR/RLTIM(IDK(ID4PRT(IMODE)))
8170         DO J=1,2
8171           IF(I4MODE(J,IMODE).EQ.200) THEN
8172             TEMP = TEMP*BRZ(ITYPE(J))
8173           ELSE
8174             TEMP = TEMP*BRW(ITYPE(J))
8175           ENDIF
8176         ENDDO
8177         IF(IPRINT.EQ.2) WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
8178 C--set up the maximum weight
8179         WT4MAX(ITYPE(1),ITYPE(2),IMODE) = WMAX
8180       ELSE
8181 C--generate a configuation
8182         NTRY = 0
8183         IF(SYSPIN.AND.NSPN.NE.0) CALL HWWARN('HWD4ME',501,*999)
8184  100    NTRY = NTRY+1
8185         CALL HWD4M0(ID,WGT)
8186         WGT = WGT*PRE
8187         IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
8188         IF(NTRY.GE.NSNTRY) CALL HWWARN('HWD4ME',100,*999)
8189       ENDIF
8190  3000 FORMAT(/'  FOLLOWED BY ',A8,' --> ',A8,' ',A8,' AND ',
8191      &                         A8,' --> ',A8,' ',A8)
8192  3010 FORMAT('            PARTIAL WIDTH  = ',G12.4,' +/- ',G12.4)
8193  3020 FORMAT('            MAXIMUM WEIGHT = ',E12.4)
8194  3030 FORMAT('     RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
8195  999  END
8196 CDECK  ID>, HWD4M0.
8197 *CMZ :-        -11/10/01  12:32:39  by  Peter Richardson
8198 *-- Author :    Peter Richardson
8199 C-----------------------------------------------------------------------
8200       SUBROUTINE HWD4M0(ID,WGT)
8201 C-----------------------------------------------------------------------
8202 C     Subroutine to calculate the matrix element for a given four body
8203 C     decay mode
8204 C-----------------------------------------------------------------------
8205       INCLUDE 'HERWIG65.INC'
8206       INTEGER I,J,P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),II,P4
8207       DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,
8208      &     M23,PCMA,PCMB(2),HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,
8209      &     M232,PRE,PLAB,PRW,XMASS,PCM,P(5,5),PM(5,5),MR,PREF(5),
8210      &     M45,M452,MJAC(2),PTMP(5,2),CN(2),DOT
8211       DOUBLE COMPLEX S,D,ME(2,2,2,2),APP(2,2),AMP(2,2),APM(2,2),
8212      &     AMM(2,2),BPP(2,2),BPM(2,2),BMP(2,2),BMM(2,2),ZI,
8213      &     F45(2,2,8,8),F23(2,2,8,8),C(2,2),E(2,2)
8214       LOGICAL HWRLOG
8215       EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRLOG
8216       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
8217       COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
8218       DATA O/2,1/
8219       DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
8220       COMMON/HWHEWS/S(8,8,2),D(8,8)
8221       PARAMETER(EPS=1D-20,ZI=(0.0D0,1.0D0))
8222 C--select the masses of the gauge bosons and compute Jacobians
8223       IF(HWRLOG(HALF)) THEN
8224         CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M(4)-M(5))**2,
8225      &                                             (M(2)+M(3))**2)
8226         M23 = SQRT(M232)
8227         CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,
8228      &       (M(1)-M23)**2,(M(4)+M(5))**2)
8229         M45 = SQRT(M452)
8230       ELSE
8231         CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,(M(1)-M(2)-M(3))**2,
8232      &                                            (M(4)+M(5))**2)
8233         M45 = SQRT(M452)
8234         CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M45)**2,
8235      &       (M(2)+M(3))**2)
8236         M23 = SQRT(M232)
8237       ENDIF
8238       MJAC(1) = MJAC(1)/((M232-MS(1))**2+MWD(1)**2)
8239       MJAC(2) = MJAC(2)/((M452-MS(2))**2+MWD(2)**2)
8240       DO 1 I=2,5
8241  1    P(5,I) = M(I)
8242       DO 2 I=1,2
8243  2    CN(I) = -ONE/MS(I)
8244 C--now perform the decay of the Higgs to the bosons
8245       PCMA = HWUPCM(M(1),M23,M45)
8246       PLAB(5,1) = M23
8247       PLAB(5,2) = M45
8248       CALL HWVEQU(5,PHEP(1,ID),P(1,1))
8249       CALL HWDTWO(P(1,1),PLAB(1,1),PLAB(1,2),PCMA,2.0D0,.TRUE.)
8250       PCMB(1) = HWUPCM(M23,M(2),M(3))
8251       CALL HWDTWO(PLAB(1,1),P(1,2),P(1,3),PCMB(1),2.0D0,.TRUE.)
8252       PCMB(2) = HWUPCM(M45,M(4),M(5))
8253       CALL HWDTWO(PLAB(1,2),P(1,4),P(1,5),PCMB(2),2.0D0,.TRUE.)
8254       DOT = HWULDO(PLAB(1,1),PLAB(1,2))
8255 C--compute the phase sapce factors
8256       PHS = PCMA*PCMB(1)*PCMB(2)*MJAC(1)*MJAC(2)/512.0D0/PIFAC**5/
8257      &        M2(1)/M23/M45
8258 C--compute the vectors for the helicity amplitudes
8259       DO 3 I=1,4
8260       II=I+1
8261 C--compute the references vectors
8262 C--not important if SM particle which can't have spin measured
8263 C--ie anything other the top and tau
8264 C--also not important if particle is approx massless
8265 C--first the SM particles other than top and tau
8266       IF(IDP(II).LT.400.AND.(IDP(II).NE.6.AND.IDP(II).NE.12
8267      &                 .AND.IDP(II).NE.125.AND.IDP(II).NE.131)) THEN
8268         CALL HWVEQU(5,PREF,PLAB(1,I+4))
8269 C--all other particles
8270       ELSE
8271         PP = SQRT(HWVDOT(3,P(1,II),P(1,II)))
8272         CALL HWVSCA(3,ONE/PP,P(1,II),N)
8273         PLAB(4,I+4) = HALF*(P(4,II)-PP)
8274         PP = HALF*(PP-M(II)-PP**2/(M(II)+P(4,II)))
8275         CALL HWVSCA(3,PP,N,PLAB(1,I+4))
8276         CALL HWUMAS(PLAB(1,I+4))
8277         PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
8278 C--fix to avoid problems if approx massless due to energy
8279         IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
8280       ENDIF
8281 C--now the massless vectors
8282       PP = HALF*M2(II)/HWULDO(PLAB(1,I+4),P(1,II))
8283       DO 4 J=1,4
8284  4    PLAB(J,I) = P(J,II)-PP*PLAB(J,I+4)
8285  3    CALL HWUMAS(PLAB(1,I))
8286 C--change ordr of momenta for call to HE code
8287       DO 5 I=1,5
8288       PM(1,I) = P(3,I)
8289       PM(2,I) = P(1,I)
8290       PM(3,I) = P(2,I)
8291       PM(4,I) = P(4,I)
8292  5    PM(5,I) = P(5,I)
8293       DO 6 I=1,8
8294       PCM(1,I)=PLAB(3,I)
8295       PCM(2,I)=PLAB(1,I)
8296       PCM(3,I)=PLAB(2,I)
8297       PCM(4,I)=PLAB(4,I)
8298  6    PCM(5,I)=PLAB(5,I)
8299 C--compute the S functions
8300       CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
8301       DO 7 I=1,8
8302       DO 7 J=1,8
8303       S(I,J,2) = -S(I,J,2)
8304  7    D(I,J)   = TWO*D(I,J)
8305       CALL HWVSUM(4,PM(1,2),PM(1,3),PTMP(1,1))
8306       CALL HWVSUM(4,PM(1,4),PM(1,5),PTMP(1,2))
8307       CALL HWUMAS(PTMP(1,1))
8308       CALL HWUMAS(PTMP(1,2))
8309 C--compute the F functions
8310       CALL HWH2F3(8,F23,PTMP(1,1),ZERO)
8311       CALL HWH2F3(8,F45,PTMP(1,2),ZERO)
8312 C--now find the prefactor for all the diagrams
8313       PRE = HWULDO(PCM(1,5),PM(1,2))*HWULDO(PCM(1,6),PM(1,3))*
8314      &      HWULDO(PCM(1,7),PM(1,4))*HWULDO(PCM(1,8),PM(1,5))
8315       PRE = 0.25D0/SQRT(PRE)
8316 C--zero the matrix element
8317       DO 8 P0=1,2
8318       DO 8 P1=1,2
8319       DO 8 P2=1,2
8320       DO 8 P3=1,2
8321  8    ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8322 C--compute the A, B, C and E functions
8323       DO 9 P1=1,2
8324       DO 9 P2=1,2
8325         IF(P1.EQ.P2) THEN
8326 C--the A and B functions
8327           APP(P1,P2) =  A(  P2 )*S(5,1,O(P1))*S(2,6,  P1 )
8328           APM(P1,P2) = 0.0D0
8329           AMP(P1,P2) = 0.0D0
8330           AMM(P1,P2) = -A(O(P2))*M(2)*M(3)
8331           BPP(P1,P2) =  B(  P2 )*S(7,3,O(P1))*S(4,8,  P1 )
8332           BPM(P1,P2) = 0.0D0
8333           BMP(P1,P2) = 0.0D0
8334           BMM(P1,P2) = -B(O(P2))*M(4)*M(5)
8335 C--the C and E functions
8336           C(P1,P2) =CN(1)*(A(  P2 )*( M2(2)*S(5,2,O(P1))*S(2,6,  P1 )
8337      &                               +M2(3)*S(5,1,O(P1))*S(1,6,  P1 ))
8338      &         -A(O(P2))*M(2)*M(3)*( S(5,1,O(P1))*S(1,6,  P1 )
8339      &                              +S(5,2,O(P1))*S(2,6,  P1 )))
8340           E(P1,P2) =CN(2)*(B(  P2 )*( M2(4)*S(7,4,O(P1))*S(4,8,  P1 )
8341      &                               +M2(5)*S(7,3,O(P1))*S(3,8,  P1 ))
8342      &         -B(O(P2))*M(4)*M(5)*( S(7,3,O(P1))*S(3,8,  P1 )
8343      &                              +S(7,4,O(P1))*S(4,8,  P1 )))
8344         ELSE
8345 C--the A functions
8346           APP(P1,P2) = 0.0D0
8347           APM(P1,P2) = A(  P2 )*M(2)*S(2,6,O(P1))
8348           AMP(P1,P2) =-A(O(P2))*M(3)*S(5,1,O(P1))
8349           AMM(P1,P2) = 0.0D0
8350           BPP(P1,P2) = 0.0D0
8351           BPM(P1,P2) = B(  P2 )*M(4)*S(4,8,O(P1))
8352           BMP(P1,P2) =-B(O(P2))*M(5)*S(7,3,O(P1))
8353           BMM(P1,P2) = 0.0D0
8354 C--the C and D functions
8355           C(P1,P2) =CN(1)*( A(  P2 )*M(2)*( M2(3)*S(5,6,O(P1))
8356      &                      +S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1)))
8357      &                     -A(O(P2))*M(3)*( M2(2)*S(5,6,O(P1))
8358      &                      +S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1))))
8359           E(P1,P2) =CN(2)*( B(  P2 )*M(4)*( M2(5)*S(7,8,O(P1))
8360      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
8361      &                     -B(O(P2))*M(5)*( M2(4)*S(7,8,O(P1))
8362      &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
8363         ENDIF
8364  9    CONTINUE
8365 C--now put the whole thing together to give the matrix element
8366       DO 10 P1=1,2
8367       DO 10 P2=1,2
8368       DO 10 P3=1,2
8369       DO 10 P4=1,2
8370         P0=O(P1)
8371         IF(P1.EQ.P3) THEN
8372           ME(P1,P2,P3,P4) =
8373      & APP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,2,P0)+BMP(P3,P4)*S(8,2,P0))
8374      &           +S(7,2,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
8375      &+APM(P1,P2)*(S(5,7,P0)*(BPM(P3,P4)*S(4,2,P1)+BMM(P3,P4)*S(8,2,P1))
8376      &           +S(3,2,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0)))
8377      &+AMP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,6,P0)+BMP(P3,P4)*S(8,6,P0))
8378      &           +S(7,6,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
8379      &+AMM(P1,P2)*(S(3,6,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0))
8380      &           +S(5,7,P0)*(BPM(P3,P4)*S(4,6,P1)+BMM(P3,P4)*S(8,6,P1)))
8381         ELSE
8382           ME(P1,P2,P3,P4) =
8383      & APP(P1,P2)*(S(3,2,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P4)*S(1,8,P1))
8384      &           +S(1,7,P1)*(BPM(P3,P4)*S(4,2,P0)+BMM(P3,P4)*S(8,2,P0)))
8385      &+APM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,2,P1)+BMP(P3,P4)*S(8,2,P1))
8386      &           +S(7,2,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
8387      &+AMP(P1,P2)*(S(3,6,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P3)*S(1,8,P1))
8388      &           +S(1,7,P1)*(BPM(P3,P4)*S(4,6,P0)+BMM(P3,P4)*S(8,6,P0)))
8389      &+AMM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,6,P1)+BMP(P3,P4)*S(8,6,P1))
8390      &           +S(7,6,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
8391         ENDIF
8392       ME(P1,P2,P3,P4) = TWO*ME(P1,P2,P3,P4)
8393      &      +C(P1,P2)*(
8394      &        BPP(P3,P4)*F23(P3,P3,3,4)+BPM(P3,P4)*F23(O(P3),O(P3),7,4)
8395      &       +BMP(P3,P4)*F23(P3,P3,3,8)+BMM(P3,P4)*F23(O(P3),O(P3),7,8))
8396      &      +E(P3,P4)*(
8397      &        APP(P1,P2)*F45(P1,P1,1,2)+APM(P1,P2)*F45(P0,P0,5,2)
8398      &       +AMP(P1,P2)*F45(P1,P1,1,6)+AMM(P1,P2)*F45(P0,P0,5,6))
8399      &       +DOT*C(P1,P2)*E(P3,P4)
8400  10   ME(P1,P2,P3,P4) = PRE*ME(P1,P2,P3,P4)
8401 C--compute the weight
8402       WGT = ZERO
8403       DO 40 P1=1,2
8404       DO 40 P2=1,2
8405       DO 40 P3=1,2
8406       DO 40 P4=1,2
8407  40   WGT = WGT+ME(P1,P2,P3,P4)*DCONJG(ME(P1,P2,P3,P4))
8408 C--normalise this for phase space
8409       WGT = WGT*PHS
8410 C--enter the matrix element into the spin common block
8411       IF(GENEV.AND.SYSPIN) THEN
8412         NSPN = 5
8413         DO 11 P1=1,2
8414         DO 11 P2=1,2
8415         DO 11 P3=1,2
8416         DO 11 P4=1,2
8417  11     MESPN(P1,P2,P3,P4,1,1) = ME(P1,P2,P3,P4)
8418         SPNCFC(1,1,1) = ONE
8419         NCFL(1) = 1
8420       ENDIF
8421  999  END
8422 CDECK  ID>, HWDBOS.
8423 *CMZ :-        -23/05/96  18.34.17  by  Mike Seymour
8424 *-- Author :    Mike Seymour
8425 C-----------------------------------------------------------------------
8426       SUBROUTINE HWDBOS(IBOSON)
8427 C-----------------------------------------------------------------------
8428 C     DECAY GAUGE BOSONS (ALREADY FOUND BY HWDHAD)
8429 C     USES SPIN DENSITY MATRIX IN RHOHEP (1ST CMPT=>-VE,2=>LONG,3=>+VE)
8430 C     IF BOSON CAME FROM HIGGS DECAY, GIVE BOTH THE SAME HELICITY (EPR)
8431 C     IF BOSON CAME FROM W+1JET, GIVE IT THE CORRECT DECAY CORRELATIONS
8432 C--BRW FIX 20/07/04: ADD FULL DECAY CORRELATIONS FOR W/Z+HIGGS
8433 C-----------------------------------------------------------------------
8434       INCLUDE 'HERWIG65.INC'
8435       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWULDO,R(3,3),CV,CA,BR,PCM,
8436      & PBOS(5),PMAX,PROB,RRLL,RLLR
8437       INTEGER HWRINT,IBOS,IBOSON,IPAIR,ICMF,IOPT,IHEL,IMOTH,
8438      & I,IQRK,IANT,ID,IQ
8439       LOGICAL QUARKS
8440       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWULDO,HWRINT
8441       IBOS=IBOSON
8442       IF (IDHW(IBOS).LT.198.OR.IDHW(IBOS).GT.200)
8443      &  CALL HWWARN('HWDBOS',101,*999)
8444       QUARKS=.FALSE.
8445 C---SEE IF IT IS PART OF A PAIR
8446       IMOTH=JMOHEP(1,IBOS)
8447       IPAIR=JMOHEP(2,IBOS)
8448       ICMF=JMOHEP(1,IBOS)
8449 C--BRW FIX 17/07/03
8450       IF (IPAIR.EQ.IBOS) THEN
8451         IOPT=0
8452         IF (IPRO.EQ.26.OR.IPRO.EQ.27) ICMF=JMOHEP(1,IMOTH)
8453       ELSE
8454         IF (IDHW(ICMF).EQ.IDHW(IBOS).AND.ISTHEP(ICMF)/10.EQ.12) THEN
8455           IPAIR=JMOHEP(2,ICMF)
8456           IF (IPAIR.NE.0) THEN
8457             IPAIR=JDAHEP(1,IPAIR)
8458             IF (IPAIR.NE.0) JMOHEP(2,IPAIR)=IBOS
8459           ENDIF
8460           ICMF=JMOHEP(1,ICMF)
8461         ENDIF
8462         IOPT=0
8463         IF (IPAIR.NE.0) THEN
8464           IF (JMOHEP(2,IPAIR).NE.IBOS.OR.
8465      &        IDHW(IPAIR).LT.198.OR.IDHW(IPAIR).GT.200) IPAIR=0
8466         ENDIF
8467         IF (IPAIR.GT.0.AND.IPAIR.NE.IBOS) IOPT=1
8468       ENDIF
8469 C--END FIX
8470 C---SELECT DECAY PRODUCTS
8471    10 CALL HWDBOZ(IDHW(IBOS),IDN(1),IDN(2),CV,CA,BR,IOPT)
8472 C---V + 1JET, V+HIGGS DECAYS ARE NOW HANDLED HERE !
8473       IF (IPRO.EQ.21.OR.IPRO.EQ.26.OR.IPRO.EQ.27) THEN
8474         IQRK=IDHW(JMOHEP(1,ICMF))
8475         IANT=IDHW(JMOHEP(2,ICMF))
8476         IF (IQRK.EQ.13 .AND. IANT.LE.6) THEN
8477           IQRK=JMOHEP(2,ICMF)
8478           IANT=JDAHEP(2,ICMF)
8479         ELSEIF (IQRK.EQ.13) THEN
8480           IQRK=JDAHEP(2,ICMF)
8481           IANT=JMOHEP(2,ICMF)
8482         ELSEIF (IANT.EQ.13 .AND. IQRK.LE.6) THEN
8483           IQRK=JMOHEP(1,ICMF)
8484           IANT=JDAHEP(2,ICMF)
8485         ELSEIF (IANT.EQ.13) THEN
8486           IQRK=JDAHEP(2,ICMF)
8487           IANT=JMOHEP(1,ICMF)
8488         ELSEIF (IQRK.GT.IANT) THEN
8489           IQRK=JMOHEP(2,ICMF)
8490           IANT=JMOHEP(1,ICMF)
8491         ELSE
8492           IQRK=JMOHEP(1,ICMF)
8493           IANT=JMOHEP(2,ICMF)
8494         ENDIF
8495         PHEP(5,NHEP+1)=RMASS(IDN(1))
8496         PHEP(5,NHEP+2)=RMASS(IDN(2))
8497         PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
8498         IF (PCM.LT.ZERO) CALL HWWARN('HWDBOS',103,*999)
8499         IF (IDHW(IBOS).EQ.200) THEN
8500           ID=IDN(1)
8501           IF (ID.GT.120) ID=ID-110
8502           IQ=IDHW(IQRK)
8503           IF (IQ.GT.6) IQ=IQ-6
8504           RRLL=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
8505      $         (VFCH(ID,1)**2+AFCH(ID,1)**2)
8506      $         +4*VFCH(IQ,1)*AFCH(IQ,1)*
8507      $         VFCH(ID,1)*AFCH(ID,1)
8508           RLLR=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
8509      $         (VFCH(ID,1)**2+AFCH(ID,1)**2)
8510      $         -4*VFCH(IQ,1)*AFCH(IQ,1)*
8511      $         VFCH(ID,1)*AFCH(ID,1)
8512         ELSE
8513           RRLL=ONE
8514           RLLR=ZERO
8515         ENDIF
8516         IF (IPRO.EQ.21) THEN
8517            PMAX=(RRLL+RLLR)*(HWULDO(PHEP(1,IANT),PHEP(1,IBOS))**2+
8518      &                       HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))**2)
8519         ELSE
8520            PMAX=(RRLL+RLLR)* HWULDO(PHEP(1,IANT),PHEP(1,IBOS))*
8521      &                       HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))
8522         ENDIF
8523  1         CALL HWDTWO(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
8524      &                 PCM,TWO,.TRUE.)
8525         IF (IPRO.EQ.21) THEN
8526            PROB=RRLL*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))**2+
8527      &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))**2)+
8528      &          RLLR*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))**2+
8529      &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))**2)
8530         ELSE
8531            PROB=RRLL* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))*
8532      &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))+
8533      &          RLLR* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))*
8534      &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))
8535         ENDIF
8536         IF (PROB.GT.PMAX.OR.PROB.LT.ZERO)
8537      &   CALL HWWARN('HWDBOS',104,*999)
8538         IF (PMAX*HWRGEN(0).GT.PROB) GOTO 1
8539       ELSE
8540 C---SELECT HELICITY, UNLESS IT IS THE SECOND OF A HIGGS DECAY (EPR)
8541       IF (IPAIR.NE.IBOS .OR. IDHW(ICMF).NE.201) THEN
8542       IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).LE.ZERO) THEN
8543 C---COPY PARENT HELICITY IF IT WAS A GAUGE BOSON
8544         IF (IDHW(IMOTH).GE.198.AND.IDHW(IMOTH).LE.200) THEN
8545           CALL HWVEQU(3,RHOHEP(1,IMOTH),RHOHEP(1,IBOS))
8546           IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).GT.ZERO)
8547      &    GOTO 20
8548 C---MAY BE FROM A SUSY DECAY
8549         ELSEIF (ABS(IDHEP(IMOTH)).LT.1000000) THEN
8550           CALL HWWARN('HWDBOS',1,*999)
8551         ENDIF
8552         RHOHEP(1,IBOS)=1.
8553         RHOHEP(2,IBOS)=1.
8554         RHOHEP(3,IBOS)=1.
8555       ENDIF
8556  20   IHEL=HWRINT(1,3)
8557       IF (HWRGEN(0).GT.RHOHEP(IHEL,IBOS)) GOTO 20
8558       ENDIF
8559 C---SELECT DIRECTION OF FERMION
8560  30   COSTH=HWRUNI(0,-ONE,ONE)
8561       IF (IHEL.EQ.1 .AND. (ONE+COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
8562       IF (IHEL.EQ.2 .AND. (ONE-COSTH**2).LT.HWRGEN(0)     ) GOTO 30
8563       IF (IHEL.EQ.3 .AND. (ONE-COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
8564 C---GENERATE DECAY RELATIVE TO Z-AXIS
8565       PHEP(5,NHEP+1)=RMASS(IDN(1))
8566       PHEP(5,NHEP+2)=RMASS(IDN(2))
8567       PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
8568       IF (PCM.LT.ZERO) CALL HWWARN('HWDBOS',102,*999)
8569       CALL HWRAZM(PCM*SQRT(1-COSTH**2),PHEP(1,NHEP+1),PHEP(2,NHEP+1))
8570       PHEP(3,NHEP+1)=PCM*COSTH
8571       PHEP(4,NHEP+1)=SQRT(PHEP(5,NHEP+1)**2+PCM**2)
8572 C---ROTATE SO THAT Z-AXIS BECOMES BOSON'S DIRECTION IN ORIGINAL CM FRAME
8573       CALL HWULOF(PHEP(1,ICMF),PHEP(1,IBOS),PBOS)
8574       CALL HWUROT(PBOS, ONE,ZERO,R)
8575       CALL HWUROB(R,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
8576 C---BOOST BACK TO LAB
8577       CALL HWULOB(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+1))
8578       CALL HWVDIF(4,PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
8579       ENDIF
8580 C---STATUS, IDs AND POINTERS
8581       ISTHEP(IBOS)=195
8582       DO 50 I=1,2
8583         ISTHEP(NHEP+I)=193
8584         IDHW(NHEP+I)=IDN(I)
8585         IDHEP(NHEP+I)=IDPDG(IDN(I))
8586         JDAHEP(I,IBOS)=NHEP+I
8587         JMOHEP(1,NHEP+I)=IBOS
8588         JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
8589  50   CONTINUE
8590       NHEP=NHEP+2
8591       IF (IDN(1).LE.12) THEN
8592         ISTHEP(NHEP-1)=113
8593         ISTHEP(NHEP)=114
8594         JMOHEP(2,NHEP)=NHEP-1
8595         JDAHEP(2,NHEP)=NHEP-1
8596         JMOHEP(2,NHEP-1)=NHEP
8597         JDAHEP(2,NHEP-1)=NHEP
8598         QUARKS=.TRUE.
8599       ELSE
8600 C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS
8601         CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
8602         CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
8603 C--END FIX
8604       ENDIF
8605 C---IF FIRST OF A PAIR, DO SECOND DECAY
8606       IF (IPAIR.NE.0 .AND. IPAIR.NE.IBOS) THEN
8607         IBOS=IPAIR
8608         GOTO 10
8609       ENDIF
8610 C---IF QUARK DECAY, HADRONIZE
8611       IF (QUARKS) THEN
8612         EMSCA=PHEP(5,IBOS)
8613         CALL HWBGEN
8614         CALL HWDHOB
8615         CALL HWCFOR
8616         CALL HWCDEC
8617       ENDIF
8618  999  END
8619 CDECK  ID>, HWDBOZ.
8620 *CMZ :-        -29/04/91  18.00.03  by  Federico Carminati
8621 *-- Author :    Mike Seymour
8622 C-----------------------------------------------------------------------
8623       SUBROUTINE HWDBOZ(IDBOS,IFER,IANT,CV,CA,BR,IOPT)
8624 C-----------------------------------------------------------------------
8625 C     CHOOSE DECAY MODE OF BOSON
8626 C     IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
8627 C-----------------------------------------------------------------------
8628       INCLUDE 'HERWIG65.INC'
8629       DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
8630      & FACW
8631       INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
8632      & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER
8633       LOGICAL GENLST
8634       EXTERNAL HWRGEN,HWRINT
8635       SAVE FACW,FACZ,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
8636       DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
8637 C---STORE THE DECAY MODES (FERMION FIRST)
8638       DATA IDMODE/  2,  7,  4,  9,  6, 11,  2,  9,  4,  7,
8639      &            122,127,124,129,126,131,8*0,
8640      &              1,  8,  3, 10,  5, 12,  3,  8,  1, 10,
8641      &            121,128,123,130,125,132,8*0,
8642      &              1,  7,  2,  8,  3,  9,  4, 10,  5, 11,  6, 12,
8643      &            121,127,123,129,125,131,122,128,124,130,126,132/
8644 C---STORE THE BRANCHING RATIOS TO THESE MODES
8645       DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8646      &            0.108D0,0.108D0,4*0.0D0,
8647      &            0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8648      &            0.108D0,0.108D0,4*0.0D0,
8649      &            0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8650      &            0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
8651 C---FACTORS FOR CV AND CA FOR W AND Z
8652       DATA FACW,FACZ/2*0.0D0/
8653       IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
8654       IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
8655       IF (IDBOS.LT.198.OR.IDBOS.GT.200) CALL HWWARN('HWDBOZ',101,*999)
8656 C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
8657       IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
8658         NPAIR=0
8659         NUMDEC=0
8660         NWGLST=NWGTS
8661         GENLST=GENEV
8662         IF (IOPT.EQ.2) RETURN
8663       ENDIF
8664       NUMDEC=NUMDEC+1
8665       IF (NUMDEC.GT.MODMAX) CALL HWWARN('HWDBOZ',102,*999)
8666 C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
8667       IF (IOPT.EQ.1) THEN
8668         IF (NUMDEC.GT.MODMAX-1) CALL HWWARN('HWDBOZ',103,*999)
8669         IF (NPAIR.EQ.0) THEN
8670           IF (HWRGEN(1).GT.HALF) THEN
8671             MODTMP=MODBOS(NUMDEC+1)
8672             MODBOS(NUMDEC+1)=MODBOS(NUMDEC)
8673             MODBOS(NUMDEC)=MODTMP
8674           ENDIF
8675           NPAIR=NUMDEC
8676         ELSE
8677           NPAIR=0
8678         ENDIF
8679       ENDIF
8680 C---SELECT USER'S CHOICE
8681       IF (IDBOS.EQ.200) THEN
8682         IF (MODBOS(NUMDEC).EQ.1) THEN
8683           I1=1
8684           I2=6
8685         ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8686           I1=7
8687           I2=7
8688         ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8689           I1=8
8690           I2=8
8691         ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8692           I1=9
8693           I2=9
8694         ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8695           I1=7
8696           I2=8
8697         ELSEIF (MODBOS(NUMDEC).EQ.6) THEN
8698           I1=10
8699           I2=12
8700         ELSEIF (MODBOS(NUMDEC).EQ.7) THEN
8701           I1=5
8702           I2=5
8703         ELSE
8704           I1=1
8705           I2=12
8706         ENDIF
8707       ELSE
8708         IF (MODBOS(NUMDEC).EQ.1) THEN
8709           I1=1
8710           I2=5
8711         ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8712           I1=6
8713           I2=6
8714         ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8715           I1=7
8716           I2=7
8717         ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8718           I1=8
8719           I2=8
8720         ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8721           I1=6
8722           I2=7
8723         ELSE
8724           I1=1
8725           I2=8
8726         ENDIF
8727       ENDIF
8728  10   IDEC=HWRINT(I1,I2)
8729       IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
8730       IFER=IDMODE(1,IDEC,IDBOS-197)
8731       IANT=IDMODE(2,IDEC,IDBOS-197)
8732 C---CALCULATE BRANCHING RATIO
8733 C   (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
8734       BR=0
8735       DO 20 IDEC=I1,I2
8736  20     BR=BR+BRMODE(IDEC,IDBOS-197)
8737       IF (IOPT.EQ.1) THEN
8738         IF (NPAIR.NE.0) THEN
8739           I1LST=I1
8740           I2LST=I2
8741           BRLST=BR
8742         ELSE
8743           BRCOM=0
8744           DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
8745  30         BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
8746           BR=2*BR*BRLST - BRCOM**2
8747         ENDIF
8748       ENDIF
8749 C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
8750 C   CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
8751       IF (IDBOS.EQ.200) THEN
8752         IF (IFER.LE.6) THEN
8753 C Quark couplings
8754            CV=VFCH(IFER,1)
8755            CA=AFCH(IFER,1)
8756         ELSE
8757 C lepton couplings
8758            JFER=IFER-110
8759            CV=VFCH(JFER,1)
8760            CA=AFCH(JFER,1)
8761         ENDIF
8762         CV=CV * FACZ
8763         CA=CA * FACZ
8764       ELSE
8765         CV=FACW
8766         CA=FACW
8767       ENDIF
8768  999  END
8769 CDECK  ID>, HWDBZ2.
8770 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
8771 *-- Author :    Peter Richardson based on Mike Seymour's HWDBOZ
8772 C-----------------------------------------------------------------------
8773       SUBROUTINE HWDBZ2(IDBOS,IFER,IANT,CV,CA,BR,IOPT,MASS)
8774 C-----------------------------------------------------------------------
8775 C     CHOOSE DECAY MODE OF BOSON
8776 C     IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
8777 C     IDENTICAL TO HWDBOZ BUT REQUIRES DECAY MODE ACCESSIBLE FOR GIVEN
8778 C     MASS
8779 C-----------------------------------------------------------------------
8780       INCLUDE 'HERWIG65.INC'
8781       DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
8782      & FACW,MSMODE(12,3),MASS
8783       INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
8784      & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER,NTRY
8785       LOGICAL GENLST
8786       EXTERNAL HWRGEN,HWRINT
8787       SAVE FACW,FACZ,MSMODE,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
8788       DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
8789 C---STORE THE DECAY MODES (FERMION FIRST)
8790       DATA IDMODE/  2,  7,  4,  9,  6, 11,  2,  9,  4,  7,
8791      &            122,127,124,129,126,131,8*0,
8792      &              1,  8,  3, 10,  5, 12,  3,  8,  1, 10,
8793      &            121,128,123,130,125,132,8*0,
8794      &              1,  7,  2,  8,  3,  9,  4, 10,  5, 11,  6, 12,
8795      &            121,127,123,129,125,131,122,128,124,130,126,132/
8796 C---STORE THE BRANCHING RATIOS TO THESE MODES
8797       DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8798      &            0.108D0,0.108D0,4*0.0D0,
8799      &            0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8800      &            0.108D0,0.108D0,4*0.0D0,
8801      &            0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8802      &            0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
8803       DATA MSMODE/36*0.0D0/
8804 C---FACTORS FOR CV AND CA FOR W AND Z
8805       DATA FACW,FACZ/2*0.0D0/
8806       IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
8807       IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
8808       IF (IDBOS.LT.198.OR.IDBOS.GT.200) CALL HWWARN('HWDBZ2',101,*999)
8809       IF(MSMODE(1,1).EQ.ZERO) THEN
8810         DO I1=1,12
8811           DO I2=1,3
8812             MSMODE(I1,I2)=RMASS(IDMODE(1,I1,I2))+RMASS(IDMODE(2,I1,I2))
8813           ENDDO
8814         ENDDO
8815       ENDIF
8816 C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
8817       IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
8818         NPAIR=0
8819         NUMDEC=0
8820         NWGLST=NWGTS
8821         GENLST=GENEV
8822         IF (IOPT.EQ.2) RETURN
8823       ENDIF
8824       NUMDEC=NUMDEC+1
8825       IF (NUMDEC.GT.MODMAX) CALL HWWARN('HWDBZ2',102,*999)
8826 C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
8827       IF (IOPT.EQ.1) THEN
8828         IF (NUMDEC.GT.MODMAX-1) CALL HWWARN('HWDBZ2',103,*999)
8829         IF (NPAIR.EQ.0) THEN
8830           IF (HWRGEN(1).GT.HALF) THEN
8831             MODTMP=MODBOS(NUMDEC+1)
8832             MODBOS(NUMDEC+1)=MODBOS(NUMDEC)
8833             MODBOS(NUMDEC)=MODTMP
8834           ENDIF
8835           NPAIR=NUMDEC
8836         ELSE
8837           NPAIR=0
8838         ENDIF
8839       ENDIF
8840 C---SELECT USER'S CHOICE
8841       IF (IDBOS.EQ.200) THEN
8842         IF (MODBOS(NUMDEC).EQ.1) THEN
8843           I1=1
8844           I2=6
8845         ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8846           I1=7
8847           I2=7
8848         ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8849           I1=8
8850           I2=8
8851         ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8852           I1=9
8853           I2=9
8854         ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8855           I1=7
8856           I2=8
8857         ELSEIF (MODBOS(NUMDEC).EQ.6) THEN
8858           I1=10
8859           I2=12
8860         ELSEIF (MODBOS(NUMDEC).EQ.7) THEN
8861           I1=5
8862           I2=5
8863         ELSE
8864           I1=1
8865           I2=12
8866         ENDIF
8867       ELSE
8868         IF (MODBOS(NUMDEC).EQ.1) THEN
8869           I1=1
8870           I2=5
8871         ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8872           I1=6
8873           I2=6
8874         ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8875           I1=7
8876           I2=7
8877         ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8878           I1=8
8879           I2=8
8880         ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8881           I1=6
8882           I2=7
8883         ELSE
8884           I1=1
8885           I2=8
8886         ENDIF
8887       ENDIF
8888       NTRY = 0
8889  10   IDEC=HWRINT(I1,I2)
8890       NTRY = NTRY+1
8891       IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
8892       IF(MASS.LT.MSMODE(IDEC,IDBOS-197).AND.NTRY.LT.NBTRY) GOTO 10
8893       IF(NTRY.GE.NBTRY) THEN
8894         BR = ZERO
8895         RETURN
8896       ENDIF
8897       IFER=IDMODE(1,IDEC,IDBOS-197)
8898       IANT=IDMODE(2,IDEC,IDBOS-197)
8899 C---CALCULATE BRANCHING RATIO
8900 C   (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
8901       BR=0
8902       DO 20 IDEC=I1,I2
8903  20     IF(MSMODE(IDEC,IDBOS-197).LT.MASS) BR=BR+BRMODE(IDEC,IDBOS-197)
8904       IF (IOPT.EQ.1) THEN
8905         IF (NPAIR.NE.0) THEN
8906           I1LST=I1
8907           I2LST=I2
8908           BRLST=BR
8909         ELSE
8910           BRCOM=0
8911           DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
8912  30         IF(MSMODE(IDEC,IDBOS-197).LT.MASS)
8913      &            BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
8914           BR=2*BR*BRLST - BRCOM**2
8915         ENDIF
8916       ENDIF
8917 C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
8918 C   CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
8919       IF (IDBOS.EQ.200) THEN
8920         IF (IFER.LE.6) THEN
8921 C Quark couplings
8922            CV=VFCH(IFER,1)
8923            CA=AFCH(IFER,1)
8924         ELSE
8925 C lepton couplings
8926            JFER=IFER-110
8927            CV=VFCH(JFER,1)
8928            CA=AFCH(JFER,1)
8929         ENDIF
8930         CV=CV * FACZ
8931         CA=CA * FACZ
8932       ELSE
8933         CV=FACW
8934         CA=FACW
8935       ENDIF
8936  999  END
8937 CDECK  ID>, HWDCHK.
8938 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
8939 *-- Author :    Ian Knowles
8940 C-----------------------------------------------------------------------
8941       SUBROUTINE HWDCHK(IDKY,L,*)
8942 C-----------------------------------------------------------------------
8943 C     Checks line L of decay table is compatible with decay of particle
8944 C     IDKY, tidies up the line and sets NPRODS.
8945 C-----------------------------------------------------------------------
8946       INCLUDE 'HERWIG65.INC'
8947       DOUBLE PRECISION EPS,QS,Q,DM
8948       INTEGER IDKY,L,IFAULT,I,ID,J
8949       PARAMETER (EPS=1.D-6)
8950       IF (VTOCDK(IDKY).AND.VTORDK(IDKY)) RETURN 1
8951       IFAULT=0
8952       QS=FLOAT(ICHRG(IDKY))
8953       IF (IDKY.LE.12.OR.(IDKY.GE.109.AND.IDKY.LE.120)
8954      &              .OR.(IDKY.GE.209.AND.IDKY.LE.220)
8955      &              .OR.(IDKY.GE.401.AND.IDKY.LE.424)) QS=QS/3.
8956       DM=RMASS(IDKY)
8957       NPRODS(L)=0
8958       DO 10 I=1,5
8959       ID=IDKPRD(I,L)
8960       IF (ID.LT.0.OR.ID.EQ.20.OR.ID.GT.NRES) THEN
8961         WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5)
8962         IFAULT=IFAULT+1
8963       ELSEIF (ID.NE.0) THEN
8964         IF (VTORDK(ID)) THEN
8965           WRITE(6,30) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5),RNAME(ID)
8966           IFAULT=IFAULT+1
8967         ENDIF
8968         NPRODS(L)=NPRODS(L)+1
8969         IDKPRD(NPRODS(L),L)=ID
8970         Q=FLOAT(ICHRG(ID))
8971         IF (ID.LE.12.OR.(ID.GE.109.AND.ID.LE.120)
8972      &              .OR.(ID.GE.209.AND.ID.LE.220)
8973      &              .OR.(ID.GE.401.AND.ID.LE.424)) Q=Q/3.
8974         QS=QS-Q
8975         DM=DM-RMASS(ID)
8976       ENDIF
8977   10  CONTINUE
8978 C print any warnings
8979       IF (NPRODS(L).EQ.0) THEN
8980         WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5)
8981         IFAULT=IFAULT+1
8982       ELSE
8983         IF (ABS(QS).GT.EPS) THEN
8984           WRITE(6,40) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),QS
8985           IFAULT=IFAULT+1
8986         ENDIF
8987 C--modification so doesn't remove H --> W*W* Z*Z* modes
8988         IF (DM.LT.ZERO.AND..NOT.
8989      &        (FOURB.AND.IDK(L).GE.203.AND.IDK(L).LE.205.AND.
8990      &         IDKPRD(1,L).GE.198.AND.IDKPRD(2,L).LE.200.AND.
8991      &         IDKPRD(2,L).GE.198.AND.IDKPRD(2,L).LE.200)) THEN
8992           WRITE(6,50) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),DM
8993           IFAULT=IFAULT+1
8994         ENDIF
8995       ENDIF
8996   20  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
8997      &       1X,'contains no or unrecognised decay product(s)')
8998   30  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
8999      &       1X,'contains decay product ',A8,' which is vetoed')
9000   40  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9001      &       1X,'violates charge conservation, Qin-Qout= ',F6.3)
9002   50  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9003      &       1X,'is kinematically not allowed, Min-Mout= ',F10.3)
9004       IF (IFAULT.NE.0) THEN
9005         RETURN 1
9006       ELSE
9007         RETURN
9008       ENDIF
9009       END
9010 CDECK  ID>, HWDCLE.
9011 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
9012 *-- Author :    Luca Stanco
9013 C-----------------------------------------------------------------------
9014       SUBROUTINE HWDCLE(IHEP)
9015 C-----------------------------------------------------------------------
9016 C INTERFACE TO QQ-CLEO MONTE CARLO (LS 11/12/91)
9017 C-----------------------------------------------------------------------
9018       INCLUDE 'HERWIG65.INC'
9019       INTEGER IHEP,IIHEP,NHEPHF,QQLMAT
9020       LOGICAL QQLERR
9021       CHARACTER*8 NAME
9022       EXTERNAL QQLMAT
9023 C---QQ-CLEO COMMON'S
9024 C***                 MCPARS.INC
9025       INTEGER MCTRK, NTRKS, MCVRTX, NVTXS, MCHANS, MCDTRS, MPOLQQ
9026       INTEGER MCNUM, MCSTBL, MCSTAB, MCTLQQ, MDECQQ
9027       INTEGER MHLPRB, MHLLST, MHLANG, MCPLST, MFDECA
9028       PARAMETER (MCTRK = 512)
9029       PARAMETER (NTRKS = MCTRK)
9030       PARAMETER (MCVRTX = 256)
9031       PARAMETER (NVTXS = MCVRTX)
9032       PARAMETER (MCHANS = 4000)
9033       PARAMETER (MCDTRS = 8000)
9034       PARAMETER (MPOLQQ = 300)
9035       PARAMETER (MCNUM = 500)
9036       PARAMETER (MCSTBL = 40)
9037       PARAMETER (MCSTAB = 512)
9038       PARAMETER (MCTLQQ = 100)
9039       PARAMETER (MDECQQ = 300)
9040       PARAMETER (MHLPRB = 500)
9041       PARAMETER (MHLLST = 1000)
9042       PARAMETER (MHLANG = 500)
9043       PARAMETER (MCPLST = 200)
9044       PARAMETER (MFDECA = 5)
9045 C***                 MCPROP.INC
9046       REAL AMASS, CHARGE, CTAU, SPIN, RWIDTH, RMASMN, RMASMX
9047       REAL RMIXPP, RCPMIX
9048       INTEGER NPMNQQ, NPMXQQ, IDMC, INVMC, LPARTY, CPARTY
9049       INTEGER IMIXPP, ICPMIX
9050       COMMON/MCMAS1/
9051      *       NPMNQQ, NPMXQQ,
9052      *       AMASS(-20:MCNUM), CHARGE(-20:MCNUM), CTAU(-20:MCNUM),
9053      *       IDMC(-20:MCNUM), SPIN(-20:MCNUM),
9054      *       RWIDTH(-20:MCNUM), RMASMN(-20:MCNUM), RMASMX(-20:MCNUM),
9055      *       LPARTY(-20:MCNUM), CPARTY(-20:MCNUM),
9056      *       IMIXPP(-20:MCNUM), RMIXPP(-20:MCNUM),
9057      *       ICPMIX(-20:MCNUM), RCPMIX(-20:MCNUM),
9058      *       INVMC(0:MCSTBL)
9059 C
9060       INTEGER NPOLQQ, IPOLQQ
9061       COMMON/MCPOL1/
9062      *       NPOLQQ, IPOLQQ(5,MPOLQQ)
9063 C
9064       CHARACTER QNAME*10, PNAME*10
9065       COMMON/MCNAMS/
9066      *       QNAME(37), PNAME(-20:MCNUM)
9067 C
9068 C***                 MCCOMS.INC
9069       INTEGER NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ
9070       INTEGER IEVTQQ, IRUNQQ, IBMRAD
9071       INTEGER NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ
9072       INTEGER IRANQQ, IRANMC, IRANCC, IRS2QQ
9073       INTEGER IPFTQQ, IPCDQQ, IPRNTV, ITYPEV, IDECSV, IDAUTV
9074       INTEGER ISTBMC, NDAUTV
9075       INTEGER IVPROD, IVDECA
9076       REAL BFLDQQ
9077       REAL ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ
9078       REAL BPOSQQ, BSIZQQ
9079       REAL ECM, P4CMQQ, P4PHQQ, ENERNW, BEAMNW, BEAMP, BEAMN
9080       REAL PSAV, P4QQ, HELCQQ
9081       CHARACTER DATEQQ*20, TIMEQQ*20, FOUTQQ*80, FCTLQQ*80, FDECQQ*80
9082       CHARACTER FGEOQQ*80
9083       CHARACTER CCTLQQ*80, CDECQQ*80
9084 C
9085       COMMON/MCCM1A/
9086      *   NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ(3), BFLDQQ,
9087      *   ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ,
9088      *   BPOSQQ(3), BSIZQQ(3),
9089      *   IEVTQQ, IRUNQQ,
9090      *   IBMRAD, ECM, P4CMQQ(4), P4PHQQ(4),
9091      *   ENERNW, BEAMNW, BEAMP, BEAMN,
9092      *   NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ,
9093      *   IRANQQ(2), IRANMC(2), IRANCC(2), IRS2QQ(5),
9094      *   IPFTQQ(MCTRK), IPCDQQ(MCTRK), IPRNTV(MCTRK), ITYPEV(MCTRK,2),
9095      *   IDECSV(MCTRK), IDAUTV(MCTRK), ISTBMC(MCTRK), NDAUTV(MCTRK),
9096      *   IVPROD(MCTRK), IVDECA(MCTRK),
9097      *   PSAV(MCTRK,4), HELCQQ(MCTRK), P4QQ(4,MCTRK)
9098 C
9099       COMMON/MCCM1B/
9100      *   DATEQQ, TIMEQQ, FOUTQQ, FCTLQQ, FDECQQ, FGEOQQ,
9101      *   CCTLQQ(MCTLQQ), CDECQQ(MDECQQ)
9102       INTEGER IDSTBL
9103       COMMON/MCCM1C/
9104      *   IDSTBL(MCSTAB)
9105 C
9106       INTEGER IFINAL(MCTRK), IFINSV(MCSTAB), NFINAL
9107       EQUIVALENCE (IFINAL,ISTBMC), (IFINSV,IDSTBL), (NFINAL,NSTBMC)
9108 C
9109       INTEGER NVRTX, ITRKIN, NTRKOU, ITRKOU, IVKODE
9110       REAL XVTX, TVTX, RVTX
9111       COMMON/MCCM2/
9112      *   NVRTX, XVTX(MCVRTX,3), TVTX(MCVRTX), RVTX(MCVRTX),
9113      *   ITRKIN(MCVRTX), NTRKOU(MCVRTX), ITRKOU(MCVRTX),
9114      *   IVKODE(MCVRTX)
9115 C***                 MCGEN.INC
9116       INTEGER QQIST,QQIFR,QQN,QQK,QQMESO,QQNC,QQKC,QQLASTN
9117       REAL QQPUD,QQPS1,QQSIGM,QQMAS,QQPAR,QQCMIX,QQCND,QQBSPI,QQBSYM,QQP
9118       REAL QQPC,QQCZF
9119 C
9120       COMMON/DATA1/QQIST,QQIFR,QQPUD,QQPS1,QQSIGM,QQMAS(15),QQPAR(25)
9121       COMMON/DATA2/QQCZF(15),QQMESO(36),QQCMIX(6,2)
9122       COMMON/DATA3/QQCND(3)
9123       COMMON/DATA5/QQBSPI(5),QQBSYM(3)
9124       COMMON/JET/QQN,QQK(250,2),QQP(250,5),QQNC,QQKC(10),QQPC(10,4),
9125      *  QQLASTN
9126 C---
9127       IF(FSTEVT) THEN
9128 C---INITIALIZE QQ-CLEO
9129         CALL QQINIT(QQLERR)
9130         IF(QQLERR) CALL HWWARN('HWDEUR',500,*999)
9131       ENDIF
9132 C---CONSTRUCT THE HADRON FOR QQ-CLEO
9133 C NOTE: THE IDPDG CODE IS PROVIDED THROUGH THE QQLMAT ROUTINE
9134 C       FROM THE CLEO PACKAGE (QQ-CLEO <--> IDPDG CODE TRANSFORMATION)
9135       QQN=1
9136       IDHEP(IHEP)=IDPDG(IDHW(IHEP))
9137       QQK(1,1)=0
9138       QQK(1,2)=QQLMAT(IDHEP(IHEP),1)
9139       QQP(1,1)=PHEP(1,IHEP)
9140       QQP(1,2)=PHEP(2,IHEP)
9141       QQP(1,3)=PHEP(3,IHEP)
9142       QQP(1,5)=AMASS(QQK(1,2))
9143       QQP(1,4)=SQRT(QQP(1,5)**2+QQP(1,1)**2+QQP(1,2)**2+QQP(1,3)**2)
9144 C---LET QQ-CLEO DO THE JOB
9145       QQNTRK=0
9146       NVRTX=0
9147       CALL DECADD(.FALSE.)
9148 C---UPDATE THE HERWIG TABLE : LOOP OVER QQN-CLEO FINAL PARTICLES
9149       DO 40 IIHEP=1,QQN
9150       NHEP=NHEP+1
9151       ISTHEP(NHEP)=198
9152       IF(ITYPEV(IIHEP,2).GE.0) ISTHEP(NHEP)=1
9153       IDHEP(NHEP)=QQLMAT(ITYPEV(IIHEP,1),2)
9154       CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
9155       IF(IIHEP.EQ.1) THEN
9156         ISTHEP(IHEP)=199
9157         JDAHEP(1,IHEP)=NHEP
9158         JDAHEP(2,IHEP)=NHEP
9159         ISTHEP(NHEP)=199
9160         NHEPHF=NHEP
9161         JMOHEP(1,NHEP)=IHEP
9162         JMOHEP(2,NHEP)=IHEP
9163       ELSE
9164         JMOHEP(1,NHEP)=IPRNTV(IIHEP)+NHEPHF-1
9165         JMOHEP(2,NHEP)=NHEPHF
9166       ENDIF
9167       JDAHEP(1,NHEP)=0
9168       JDAHEP(2,NHEP)=0
9169       IF(NDAUTV(IIHEP).GT.0) THEN
9170         JDAHEP(1,NHEP)=IDAUTV(IIHEP)+NHEPHF-1
9171         JDAHEP(2,NHEP)=JDAHEP(1,NHEP)+NDAUTV(IIHEP)-1
9172       ENDIF
9173       PHEP(1,NHEP)=QQP(IIHEP,1)
9174       PHEP(2,NHEP)=QQP(IIHEP,2)
9175       PHEP(3,NHEP)=QQP(IIHEP,3)
9176       PHEP(4,NHEP)=QQP(IIHEP,4)
9177       PHEP(5,NHEP)=QQP(IIHEP,5)
9178       VHEP(1,NHEP)=XVTX(IVPROD(IIHEP),1)
9179       VHEP(2,NHEP)=XVTX(IVPROD(IIHEP),2)
9180       VHEP(3,NHEP)=XVTX(IVPROD(IIHEP),3)
9181       VHEP(4,NHEP)=0.
9182    40 CONTINUE
9183   999 END
9184 CDECK  ID>, HWDEUR.
9185 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
9186 *-- Author :    Luca Stanco
9187 C-----------------------------------------------------------------------
9188       SUBROUTINE HWDEUR(IHEP)
9189 C-----------------------------------------------------------------------
9190 C INTERFACE TO EURODEC PACKAGE (LS 10/29/91)
9191 C-----------------------------------------------------------------------
9192       INCLUDE 'HERWIG65.INC'
9193       INTEGER IHEP,IIHEP,NHEPHF,IEUPDG,IPDGEU
9194       CHARACTER*8 NAME
9195 C---EURODEC COMMON'S : INITIAL INPUT
9196       INTEGER EULUN0,EULUN1,EULUN2,EURUN,EUEVNT
9197       CHARACTER*4 EUDATD,EUTIT
9198       REAL AMINIE(12),EUWEI
9199       COMMON/INPOUT/EULUN0,EULUN1,EULUN2
9200       COMMON/FILNAM/EUDATD,EUTIT
9201       COMMON/HVYINI/AMINIE
9202       COMMON/RUNINF/EURUN,EUEVNT,EUWEI
9203 C---EURODEC WORKING COMMON'S
9204       INTEGER NPMAX,NTMAX
9205       PARAMETER (NPMAX=18,NTMAX=2000)
9206       INTEGER EUNP,EUIP(NPMAX),EUPHEL(NPMAX),EUTEIL,EUINDX(NTMAX),
9207      &    EUORIG(NTMAX),EUDCAY(NTMAX),EUTHEL(NTMAX)
9208       REAL EUAPM(NPMAX),EUPCM(5,NPMAX),EUPVTX(3,NPMAX),EUPTEI(5,NTMAX),
9209      &    EUSECV(3,NTMAX)
9210       COMMON/MOMGEN/EUNP,EUIP,EUAPM,EUPCM,EUPHEL,EUPVTX
9211       COMMON/RESULT/EUTEIL,EUPTEI,EUINDX,EUORIG,EUDCAY,EUTHEL,EUSECV
9212 C---EURODEC COMMON'S FOR DECAY PROPERTIES
9213       INTEGER NGMAX,NCMAX
9214       PARAMETER (NGMAX=400,NCMAX=9000)
9215       INTEGER EUNPA,EUIPC(NGMAX),EUIPDG(NGMAX),EUIDP(NGMAX),
9216      &     EUCONV(NCMAX)
9217       REAL EUPM(NGMAX),EUPLT(NGMAX)
9218       COMMON/PCTABL/EUNPA,EUIPC,EUIPDG,EUPM,EUPLT,EUIDP
9219       COMMON/CONVRT/EUCONV
9220 C---
9221       IF(FSTEVT) THEN
9222 C---CHANGE HERE THE DEFAULT VALUES OF EURODEC COMMON'S
9223 C
9224 C---INITIALIZE EURODEC COMMON'S
9225 CC        CALL EUDCIN
9226 C---INITIALIZE EURODEC
9227         CALL EUDINI
9228       ENDIF
9229 C---CONSTRUCT THE HADRON FOR EURODEC FROM ID1,ID2
9230       EUNP=1
9231       IDHEP(IHEP)=IDPDG(IDHW(IHEP))
9232       EUIP(1)=IPDGEU(IDHEP(IHEP))
9233       EUAPM(1)=EUPM(EUCONV(IABS(EUIP(1))))
9234       EUPCM(1,1)=PHEP(1,IHEP)
9235       EUPCM(2,1)=PHEP(2,IHEP)
9236       EUPCM(3,1)=PHEP(3,IHEP)
9237       EUPCM(5,1)=SQRT(PHEP(1,IHEP)**2+PHEP(2,IHEP)**2+PHEP(3,IHEP)**2)
9238       EUPCM(4,1)=SQRT(EUPCM(5,1)**2+EUAPM(1)**2)
9239 C NOT POLARIZED HADRONS
9240       EUPHEL(1)=0
9241 C HADRONS START FROM PRIMARY VERTEX
9242       EUPVTX(1,1)=0.
9243       EUPVTX(2,1)=0.
9244       EUPVTX(3,1)=0.
9245 C---LET EURODEC DO THE JOB
9246       EUTEIL=0
9247       CALL FRAGMT(1,1,0)
9248 C---UPDATE THE HERWIG TABLE : LOOP OVER N-EURODEC FINAL PARTICLES
9249       DO 40 IIHEP=1,EUTEIL
9250       NHEP=NHEP+1
9251       ISTHEP(NHEP)=198
9252       IF(EUDCAY(IIHEP).EQ.0) ISTHEP(NHEP)=1
9253       IDHEP(NHEP)=IEUPDG(EUINDX(IIHEP))
9254       CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
9255       IF(IIHEP.EQ.1) THEN
9256         ISTHEP(IHEP)=199
9257         JDAHEP(1,IHEP)=NHEP
9258         JDAHEP(2,IHEP)=NHEP
9259         ISTHEP(NHEP)=199
9260         NHEPHF=NHEP
9261         JMOHEP(1,NHEP)=IHEP
9262         JMOHEP(2,NHEP)=IHEP
9263         JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
9264         JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
9265       ELSE
9266         JMOHEP(1,NHEP)=MOD(EUORIG(IIHEP),10000)+NHEPHF-1
9267         JMOHEP(2,NHEP)=NHEPHF
9268         JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
9269         JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
9270       ENDIF
9271       PHEP(1,NHEP)=EUPTEI(1,IIHEP)
9272       PHEP(2,NHEP)=EUPTEI(2,IIHEP)
9273       PHEP(3,NHEP)=EUPTEI(3,IIHEP)
9274       PHEP(4,NHEP)=EUPTEI(4,IIHEP)
9275       PHEP(5,NHEP)=EUPTEI(5,IIHEP)
9276       VHEP(1,NHEP)=EUSECV(1,IIHEP)
9277       VHEP(2,NHEP)=EUSECV(2,IIHEP)
9278       VHEP(3,NHEP)=EUSECV(3,IIHEP)
9279       VHEP(4,NHEP)=0.
9280       IF (IIHEP.GT.NTMAX) CALL HWWARN('HWDEUR',99,*999)
9281    40 CONTINUE
9282   999 END
9283 CDECK  ID>, HWDFOR.
9284 *CMZ :-        -01/04/99  19.52.44  by  Mike Seymour
9285 *-- Author :    Ian Knowles
9286 C-----------------------------------------------------------------------
9287       SUBROUTINE HWDFOR(P0,P1,P2,P3,P4)
9288 C-----------------------------------------------------------------------
9289 C     Generates 4-body decay 0->1+2+3+4 using pure phase space
9290 C-----------------------------------------------------------------------
9291       IMPLICIT NONE
9292       DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),B,C,AA,BB,
9293      & CC,DD,EE,TT,S1,RS1,FF,S2,PP,QQ,RR,P1CM,P234(5),P2CM,P34(5),P3CM
9294       DOUBLE PRECISION TWO
9295       PARAMETER (TWO=2.D0)
9296       EXTERNAL HWRGEN
9297       B=P0(5)-P1(5)
9298       C=P2(5)+P3(5)+P4(5)
9299       IF (B.LT.C) CALL HWWARN('HWDFOR',100,*999)
9300       AA=(P0(5)+P1(5))**2
9301       BB=B**2
9302       CC=C**2
9303       DD=(P3(5)+P4(5))**2
9304       EE=(P3(5)-P4(5))**2
9305       TT=(B-C)*P0(5)**7/16
9306 C Select squared masses S1 and S2 of 234 and 34 subsystems
9307   10  S1=BB+HWRGEN(1)*(CC-BB)
9308       RS1=SQRT(S1)
9309       FF=(RS1-P2(5))**2
9310       S2=DD+HWRGEN(2)*(FF-DD)
9311       PP=(AA-S1)*(BB-S1)
9312       QQ=((RS1+P2(5))**2-S2)*(FF-S2)/S1
9313       RR=(S2-DD)*(S2-EE)/S2
9314       IF (PP*QQ*RR*(FF-DD)**2.LT.TT*S1*S2*HWRGEN(3)**2) GOTO 10
9315 C Do two body decays: 0-->1+234, 234-->2+34 and 34-->3+4
9316       P1CM=SQRT(PP/4)/P0(5)
9317       P234(5)=RS1
9318       P2CM=SQRT(QQ/4)
9319       P34(5)=SQRT(S2)
9320       P3CM=SQRT(RR/4)
9321       CALL HWDTWO(P0  ,P1,P234,P1CM,TWO,.TRUE.)
9322       CALL HWDTWO(P234,P2,P34 ,P2CM,TWO,.TRUE.)
9323       CALL HWDTWO(P34 ,P3,P4  ,P3CM,TWO,.TRUE.)
9324   999 END
9325 CDECK  ID>, HWDFIV.
9326 *CMZ :-        -01/04/99  19.52.44  by  Mike Seymour
9327 *-- Author :    Ian Knowles
9328 C-----------------------------------------------------------------------
9329       SUBROUTINE HWDFIV(P0,P1,P2,P3,P4,P5)
9330 C-----------------------------------------------------------------------
9331 C     Generates 5-body decay 0->1+2+3+4+5 using pure phase space
9332 C-----------------------------------------------------------------------
9333       IMPLICIT NONE
9334       DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),P5(5),B,C,
9335      & AA,BB,CC,DD,EE,FF,TT,S1,RS1,GG,S2,RS2,HH,S3,PP,QQ,RR,SS,P1CM,
9336      & P2345(5),P2CM,P345(5),P3CM,P45(5),P4CM
9337       DOUBLE PRECISION TWO
9338       PARAMETER (TWO=2.D0)
9339       EXTERNAL HWRGEN
9340       B=P0(5)-P1(5)
9341       C=P2(5)+P3(5)+P4(5)+P5(5)
9342       IF (B.LT.C) CALL HWWARN('HWDFIV',100,*999)
9343       AA=(P0(5)+P1(5))**2
9344       BB=B**2
9345       CC=C**2
9346       DD=(P3(5)+P4(5)+P5(5))**2
9347       EE=(P4(5)+P5(5))**2
9348       FF=(P4(5)-P5(5))**2
9349       TT=(B-C)*P0(5)**11/729
9350 C Select squared masses S1, S2 and S3 of 2345, 345 and 45 subsystems
9351   10  S1=BB+HWRGEN(1)*(CC-BB)
9352       RS1=SQRT(S1)
9353       GG=(RS1-P2(5))**2
9354       S2=DD+HWRGEN(2)*(GG-DD)
9355       RS2=SQRT(S2)
9356       HH=(RS2-P3(5))**2
9357       S3=EE+HWRGEN(3)*(HH-EE)
9358       PP=(AA-S1)*(BB-S1)
9359       QQ=((RS1+P2(5))**2-S2)*(GG-S2)/S1
9360       RR=((RS2+P3(5))**2-S3)*(HH-S3)/S2
9361       SS=(S3-EE)*(S3-FF)/S3
9362       IF (PP*QQ*RR*SS*((GG-DD)*(HH-EE))**2.LT.TT*S1*S2*S3*HWRGEN(4)**2)
9363      & GOTO 10
9364 C Do two body decays: 0-->1+2345, 2345-->2+345, 345-->3+45 and 45-->4+5
9365       P1CM=SQRT(PP/4)/P0(5)
9366       P2345(5)=RS1
9367       P2CM=SQRT(QQ/4)
9368       P345(5)=RS2
9369       P3CM=SQRT(RR/4)
9370       P45(5)=SQRT(S3)
9371       P4CM=SQRT(SS/4)
9372       CALL HWDTWO(P0   ,P1,P2345,P1CM,TWO,.TRUE.)
9373       CALL HWDTWO(P2345,P2,P345 ,P2CM,TWO,.TRUE.)
9374       CALL HWDTWO(P345 ,P3,P45  ,P3CM,TWO,.TRUE.)
9375       CALL HWDTWO(P45  ,P4,P5   ,P4CM,TWO,.TRUE.)
9376   999 END
9377 CDECK  ID>, HWDHAD.
9378 *CMZ :-        -26/04/91  11.11.54  by  Peter Richardson
9379 *-- Author :    Ian Knowles, Bryan Webber & Mike Seymour
9380 C-----------------------------------------------------------------------
9381       SUBROUTINE HWDHAD
9382 C-----------------------------------------------------------------------
9383 C     GENERATES DECAYS OF UNSTABLE HADRONS AND LEPTONS
9384 C     Modified for TAUOLA interface 16/10/01 PR
9385 C-----------------------------------------------------------------------
9386       INCLUDE 'HERWIG65.INC'
9387       COMMON/FFS/TB,BT
9388       COMMON/SFF/IT1,IB1,IT2,IB2
9389       DOUBLE PRECISION TB,BT
9390       INTEGER IT1,IB1,IT2,IB2
9391       DOUBLE PRECISION HWRGEN,HWULDO,RN,BF,COSANG,RSUM,DIST(4),VERTX(4),
9392      & PMIX,WTMX,WTMX2,XS,DOT1,DOT2,HWDPWT,HWDWWT,HWDHWT,XXX,YYY
9393       INTEGER IHEP,ID,MHEP,IDM,I,IDS,IM,MO,IPDG
9394       LOGICAL STABLE
9395       EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT,HWULDO
9396       IF (IERROR.NE.0) RETURN
9397       DO 100 IHEP=1,NMXHEP
9398       IF (IHEP.GT.NHEP) THEN
9399         ISTAT=90
9400         RETURN
9401       ELSEIF (ISTHEP(IHEP).EQ.120 .AND.
9402      &  JDAHEP(1,IHEP).EQ.IHEP.AND.JDAHEP(2,IHEP).EQ.IHEP) THEN
9403 C---COPY COLOUR SINGLET CMF
9404         NHEP=NHEP+1
9405         IF (NHEP.GT.NMXHEP) CALL HWWARN('HWDHAD',100,*999)
9406         CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
9407         CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
9408         IDHW(NHEP)=IDHW(IHEP)
9409         IDHEP(NHEP)=IDHEP(IHEP)
9410         ISTHEP(NHEP)=190
9411         JMOHEP(1,NHEP)=IHEP
9412         JMOHEP(2,NHEP)=NHEP
9413         JDAHEP(2,NHEP)=NHEP
9414         JDAHEP(1,IHEP)=NHEP
9415         JDAHEP(2,IHEP)=NHEP
9416       ELSEIF (ISTHEP(IHEP).GE.190.AND.ISTHEP(IHEP).LE.193) THEN
9417 C---FIRST CHECK FOR STABILITY
9418         ID=IDHW(IHEP)
9419         IF (RSTAB(ID)) THEN
9420           ISTHEP(IHEP)=1
9421           JDAHEP(1,IHEP)=0
9422           JDAHEP(2,IHEP)=0
9423 C---SPECIAL FOR GAUGE BOSON DECAY
9424           IF (ID.GE.198.AND.ID.LE.200) CALL HWDBOS(IHEP)
9425 C---SPECIAL FOR HIGGS BOSON DECAY
9426           IF (ID.EQ.201) CALL HWDHIG(ZERO)
9427         ELSE
9428 C---UNSTABLE.
9429 C Calculate position of decay vertex
9430           IF (DKLTM(ID).EQ.ZERO) THEN
9431             CALL HWVEQU(4,VHEP(1,IHEP),VERTX)
9432             MHEP=IHEP
9433             IDM=ID
9434           ELSE
9435             CALL HWUDKL(ID,PHEP(1,IHEP),DIST)
9436             CALL HWVSUM(4,VHEP(1,IHEP),DIST,VERTX)
9437             IF (MAXDKL) THEN
9438               CALL HWDXLM(VERTX,STABLE)
9439               IF (STABLE) THEN
9440                 ISTHEP(IHEP)=1
9441                 JDAHEP(1,IHEP)=0
9442                 JDAHEP(2,IHEP)=0
9443                 GOTO 100
9444               ENDIF
9445             ENDIF
9446             IF (MIXING.AND.(ID.EQ.221.OR.ID.EQ.223.OR.
9447      &                      ID.EQ.245.OR.ID.EQ.247)) THEN
9448 C Select flavour of decaying b-meson allowing for flavour oscillation
9449               IDS=MOD(ID,3)
9450               XXX=XMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
9451               YYY=YMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
9452               IF (ABS(YYY).LT.10) THEN
9453                 PMIX=HALF*(ONE-COS(XXX)/COSH(YYY))
9454               ELSE
9455                 PMIX=HALF
9456               ENDIF
9457               IF (HWRGEN(1).LE.PMIX) THEN
9458                 IF (ID.LE.223) THEN
9459                   IDM=ID+24
9460                 ELSE
9461                   IDM=ID-24
9462                 ENDIF
9463               ELSE
9464                 IDM=ID
9465               ENDIF
9466 C Introduce a decaying neutral b-meson
9467               IF (NHEP+1.GT.NMXHEP) CALL HWWARN('HWDHAD',101,*999)
9468               MHEP=NHEP+1
9469               ISTHEP(MHEP)=ISTHEP(IHEP)
9470               ISTHEP(IHEP)=200
9471               JDAHEP(1,IHEP)=MHEP
9472               JDAHEP(2,IHEP)=MHEP
9473               IDHW(MHEP)=IDM
9474               IDHEP(MHEP)=IDPDG(IDM)
9475               JMOHEP(1,MHEP)=IHEP
9476               JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
9477               CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
9478               CALL HWVEQU(4,VERTX,VHEP(1,MHEP))
9479               NHEP=NHEP+1
9480             ELSE
9481               MHEP=IHEP
9482               IDM=ID
9483             ENDIF
9484           ENDIF
9485 C Use CLEO/EURODEC packages for b-hadrons if requested
9486           IF ((IDM.GE.221.AND.IDM.LE.231).OR.
9487      &        (IDM.GE.245.AND.IDM.LE.254)) THEN
9488             IF (BDECAY.EQ.'CLEO') THEN
9489               CALL HWDCLE(MHEP)
9490               GOTO 100
9491             ELSEIF (BDECAY.EQ.'EURO') THEN
9492               CALL HWDEUR(MHEP)
9493               GOTO 100
9494             ENDIF
9495           ENDIF
9496 C Use TAUOLA package for tau decays if requested
9497           IF((IDM.EQ.125.OR.IDM.EQ.131).AND.TAUDEC.EQ.'TAUOLA') THEN
9498             CALL HWDTAU(1,MHEP,0.0D0)
9499             GOTO 100
9500           ENDIF
9501 C Choose decay mode
9502           ISTHEP(MHEP)=ISTHEP(MHEP)+5
9503           RN=HWRGEN(2)
9504           BF=0.
9505           IM=LSTRT(IDM)
9506           DO 10 I=1,NMODES(IDM)
9507           BF=BF+BRFRAC(IM)
9508           IF (BF.GE.RN) GOTO 20
9509   10      IM=LNEXT(IM)
9510           CALL HWWARN('HWDHAD',50,*20)
9511   20      IF ((IDKPRD(1,IM).GE.1.AND.IDKPRD(1,IM).LE.13).OR.
9512      &        (IDKPRD(3,IM).GE.1.AND.IDKPRD(3,IM).LE.13)) THEN
9513 C Partonic decay of a heavy-(b,c)-hadron, store details
9514             NQDK=NQDK+1
9515             IF (NQDK.GT.NMXQDK) CALL HWWARN('HWDHAD',102,*999)
9516             LOCQ(NQDK)=MHEP
9517             IMQDK(NQDK)=IM
9518             CALL HWVEQU(4,VERTX,VTXQDK(1,NQDK))
9519             GOTO 100
9520           ELSE
9521 C Exclusive decay, add decay products to event record
9522             IF (NHEP+NPRODS(IM).GT.NMXHEP)
9523      &        CALL HWWARN('HWDHAD',103,*999)
9524             JDAHEP(1,MHEP)=NHEP+1
9525             DO 30 I=1,NPRODS(IM)
9526             NHEP=NHEP+1
9527             IDHW(NHEP)=IDKPRD(I,IM)
9528             IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
9529             ISTHEP(NHEP)=193
9530             JMOHEP(1,NHEP)=MHEP
9531             JMOHEP(2,NHEP)=JMOHEP(2,MHEP)
9532             PHEP(5,NHEP)=RMASS(IDKPRD(I,IM))
9533   30        CALL HWVEQU(4,VERTX,VHEP(1,NHEP))
9534             JDAHEP(2,MHEP)=NHEP
9535           ENDIF
9536 C Next choose momenta:
9537           IF (NPRODS(IM).EQ.1) THEN
9538 C 1-body decay: K0(BR) --> K0S,K0L
9539             CALL HWVEQU(4,PHEP(1,MHEP),PHEP(1,NHEP))
9540           ELSEIF (NPRODS(IM).EQ.2) THEN
9541 C 2-body decay
9542 C---SPECIAL TREATMENT OF POLARIZED MESONS
9543             COSANG=TWO
9544             IF (ID.EQ.IDHW(JMOHEP(1,MHEP))) THEN
9545               MO=JMOHEP(1,MHEP)
9546               RSUM=0
9547               DO 40 I=1,3
9548   40          RSUM=RSUM+RHOHEP(I,MO)
9549               IF (RSUM.GT.ZERO) THEN
9550                 RSUM=RSUM*HWRGEN(3)
9551                 IF (RSUM.LT.RHOHEP(1,MO)) THEN
9552 C---(1+COSANG)**2
9553                   COSANG=MAX(HWRGEN(4),HWRGEN(5),HWRGEN(6))*TWO-ONE
9554                 ELSEIF (RSUM.LT.RHOHEP(1,MO)+RHOHEP(2,MO)) THEN
9555 C---1-COSANG**2
9556                   COSANG=2*COS((ACOS(HWRGEN(7)*TWO-ONE)+PIFAC)/THREE)
9557                 ELSE
9558 C---(1-COSANG)**2
9559                   COSANG=MIN(HWRGEN(8),HWRGEN(9),HWRGEN(10))*TWO-ONE
9560                 ENDIF
9561               ENDIF
9562             ENDIF
9563             CALL HWDTWO(PHEP(1,MHEP),PHEP(1,NHEP-1),
9564      &                  PHEP(1,NHEP),CMMOM(IM),COSANG,.FALSE.)
9565           ELSEIF (NPRODS(IM).EQ.3) THEN
9566 C 3-body decay
9567             IF (NME(IM).EQ.100) THEN
9568 C  Use free massless (V-A)*(V-A) Matrix Element
9569               CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
9570      &                    PHEP(1,NHEP),HWDWWT)
9571             ELSEIF (NME(IM).EQ.101) THEN
9572 C  Use bound massless (V-A)*(V-A) Matrix Element
9573               WTMX=((PHEP(5,MHEP)-PHEP(5,NHEP))
9574      &             *(PHEP(5,MHEP)+PHEP(5,NHEP))
9575      &             +(PHEP(5,NHEP-1)-PHEP(5,NHEP-2))
9576      &             *(PHEP(5,NHEP-1)+PHEP(5,NHEP-2)))/TWO
9577               WTMX2=WTMX**2
9578               IPDG=ABS(IDHEP(MHEP))
9579               XS=ONE-MAX(RMASS(MOD(IPDG/1000,10)),
9580      &                   RMASS(MOD(IPDG/100,10)),RMASS(MOD(IPDG/10,10)))
9581      &              /(RMASS(MOD(IPDG/1000,10))+RMASS(MOD(IPDG/100,10))
9582      &               +RMASS(MOD(IPDG/10,10)))
9583   50          CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
9584      &                    PHEP(1,NHEP),HWDWWT)
9585               DOT1=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-1))
9586               DOT2=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-2))
9587               IF (DOT1*(WTMX-DOT1-XS*DOT2).LT.HWRGEN(11)*WTMX2) GOTO 50
9588             ELSE IF (NME(IM).EQ.200) THEN
9589 C Use free massless ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) Matrix Element
9590 C sort tan(beta)
9591               IF((IDK(IM).EQ.  2).OR.(IDK(IM).EQ.  4).OR.
9592      &           (IDK(IM).EQ.  6).OR.(IDK(IM).EQ.  8).OR.
9593      &           (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
9594      &           (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
9595      &           (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
9596      &           (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
9597                 TB=TANB
9598               ELSE
9599                 TB=1./TANB
9600               END IF
9601               IF((IDKPRD(1,IM).EQ.  2).OR.(IDKPRD(1,IM).EQ.  4).OR.
9602      &           (IDKPRD(1,IM).EQ.  6).OR.(IDKPRD(1,IM).EQ.  8).OR.
9603      &           (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
9604      &           (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
9605      &           (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
9606      &           (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
9607                 BT=TANB
9608               ELSE
9609                 BT=1./TANB
9610               END IF
9611               IT1=IDK(IM)
9612               IB1=IDKPRD(3,IM)
9613               IT2=IDKPRD(1,IM)
9614               IB2=IDKPRD(2,IM)
9615               CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP),PHEP(1,NHEP-2),
9616      &                    PHEP(1,NHEP-1),HWDHWT)
9617             ELSE
9618               CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-2),PHEP(1,NHEP-1),
9619      &                    PHEP(1,NHEP),HWDPWT)
9620             ENDIF
9621           ELSEIF (NPRODS(IM).EQ.4) THEN
9622 C 4-body decay
9623             CALL HWDFOR(PHEP(1,MHEP  ),PHEP(1,NHEP-3),PHEP(1,NHEP-2),
9624      &                  PHEP(1,NHEP-1),PHEP(1,NHEP))
9625           ELSEIF (NPRODS(IM).EQ.5) THEN
9626 C 5-body decay
9627             CALL HWDFIV(PHEP(1,MHEP  ),PHEP(1,NHEP-4),PHEP(1,NHEP-3),
9628      &                  PHEP(1,NHEP-2),PHEP(1,NHEP-1),PHEP(1,NHEP))
9629           ELSE
9630             CALL HWWARN('HWDHAD',104,*999)
9631           ENDIF
9632         ENDIF
9633       ENDIF
9634   100 CONTINUE
9635 C---MAY HAVE OVERFLOWED /HEPEVT/
9636       CALL HWWARN('HWDHAD',105,*999)
9637   999 END
9638 CDECK  ID>, HWDHGC.
9639 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
9640 *-- Author :    Mike Seymour
9641 C-----------------------------------------------------------------------
9642       SUBROUTINE HWDHGC(TAU,FNREAL,FNIMAG)
9643 C-----------------------------------------------------------------------
9644 C  CALCULATE THE COMPLEX FUNCTION F OF HHG eq 2.18
9645 C  FOR USE IN H-->GAMMGAMM DECAYS
9646 C-----------------------------------------------------------------------
9647       INCLUDE 'HERWIG65.INC'
9648       DOUBLE PRECISION TAU,FNREAL,FNIMAG,FNLOG,FNSQR
9649       IF (TAU.GT.ONE) THEN
9650         FNREAL=(ASIN(1/SQRT(TAU)))**2
9651         FNIMAG=0
9652       ELSEIF (TAU.LT.ONE) THEN
9653         FNSQR=SQRT(1-TAU)
9654         FNLOG=LOG((1+FNSQR)/(1-FNSQR))
9655         FNREAL=-0.25 * (FNLOG**2 - PIFAC**2)
9656         FNIMAG= 0.5  * PIFAC*FNLOG
9657       ELSE
9658         FNREAL=0.25*PIFAC**2
9659         FNIMAG=0
9660       ENDIF
9661       END
9662 CDECK  ID>, HWDHGF.
9663 *CMZ :-        -02/05/91  11.11.45  by  Federico Carminati
9664 *-- Author :    Mike Seymour
9665 C-----------------------------------------------------------------------
9666       FUNCTION HWDHGF(X,Y)
9667 C-----------------------------------------------------------------------
9668 C  CALCULATE THE DOUBLE BREIT-WIGNER INTEGRAL
9669 C  X=(EMV/EMH)**2 , Y=EMV*GAMV/EMH**2
9670 C-----------------------------------------------------------------------
9671       INCLUDE 'HERWIG65.INC'
9672       DOUBLE PRECISION HWDHGF,X,Y,CHANGE,X1,X2,FAC1,FAC2,TH1,TH2,TH1HI,
9673      & TH1LO,TH2HI,TH2LO,X2MAX,SQFAC
9674       INTEGER NBIN,IBIN1,IBIN2
9675 C  CHANGE IS THE POINT WHERE DIRECT INTEGRATION BEGINS TO CONVERGE
9676 C  FASTER THAN STANDARD BREIT-WIGNER SUBSTITUTION
9677       DATA CHANGE,NBIN/0.425D0,25/
9678       HWDHGF=0
9679       IF (Y.LT.ZERO) RETURN
9680       IF (X.GT.CHANGE) THEN
9681 C---DIRECT INTEGRATION
9682         FAC1=0.25 / NBIN
9683         DO 200 IBIN1=1,NBIN
9684           X1=(IBIN1-0.5) * FAC1
9685           FAC2=( (1-SQRT(X1))**2-X1 ) / NBIN
9686           DO 100 IBIN2=1,NBIN
9687             X2=(IBIN2-0.5) * FAC2 + X1
9688             SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
9689             IF (SQFAC.LT.ZERO) GOTO 100
9690             HWDHGF=HWDHGF + 2.
9691      &        * ((1-X1-X2)**2+8*X1*X2)
9692      &        * SQRT(SQFAC)
9693      &        / ((X1-X)**2+Y**2) *Y
9694      &        / ((X2-X)**2+Y**2) *Y
9695      &        * FAC1*FAC2
9696  100      CONTINUE
9697  200    CONTINUE
9698       ELSE
9699 C---INTEGRATION USING TAN THETA SUBSTITUTIONS
9700         TH1LO=ATAN((0-X)/Y)
9701         TH1HI=ATAN((1-X)/Y)
9702         FAC1=(TH1HI-TH1LO) / NBIN
9703         DO 400 IBIN1=1,NBIN
9704           TH1=(IBIN1-0.5) * FAC1 + TH1LO
9705           X1=Y*TAN(TH1) + X
9706           X2MAX=MIN(X1,(1-SQRT(X1))**2)
9707           TH2LO=ATAN((0-X)/Y)
9708           TH2HI=ATAN((X2MAX-X)/Y)
9709           FAC2=(TH2HI-TH2LO) / NBIN
9710           DO 300 IBIN2=1,NBIN
9711             TH2=(IBIN2-0.5) * FAC2 + TH2LO
9712             X2=Y*TAN(TH2) + X
9713             SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
9714             IF (SQFAC.LT.ZERO) GOTO 300
9715             HWDHGF=HWDHGF + 2.
9716      &        * ((1-X1-X2)**2+8*X1*X2)
9717      &        * SQRT(SQFAC)
9718      &        * FAC1 * FAC2
9719  300      CONTINUE
9720  400    CONTINUE
9721       ENDIF
9722       HWDHGF=HWDHGF/(PIFAC*PIFAC)
9723       END
9724 CDECK  ID>, HWDHIG.
9725 *CMZ :-        -24/04/92  14.23.44  by  Mike Seymour
9726 *-- Author :    Mike Seymour
9727 C-----------------------------------------------------------------------
9728       SUBROUTINE HWDHIG(GAMINP)
9729 C-----------------------------------------------------------------------
9730 C     HIGGS DECAY ROUTINE
9731 C     A) FOR GAMinp=0 FIND AND DECAY HIGGS
9732 C     B) FOR GAMinp>0 CALCULATE TOTAL HIGGS WIDTH
9733 C                     FOR EMH=GAMINP. STORE RESULT IN GAMINP.
9734 C-----------------------------------------------------------------------
9735       INCLUDE 'HERWIG65.INC'
9736       DOUBLE PRECISION HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,GAMINP,EMH,
9737      & EMF,COLFAC,ENF,K1,K0,BET0,BET1,GAM0,GAM1,SCLOG,CFAC,XF,EM,GAMLIM,
9738      & GAM,XW,EMW,XZ,EMZ,YW,YZ,EMI,TAUT,TAUW,WIDHIG,VECDEC,EMB,GAMB,
9739      & TMIN,TMAX1,EM1,TMAX2,EM2,X1,X2,PROB,PCM,SUMR,SUMI,TAUTR,TAUTI,
9740      & TAUWR,TAUWI,GFACTR
9741       INTEGER HWRINT,IHIG,I,IFERM,NLOOK,I1,I2,IPART,IMODE,IDEC,MMAX
9742       LOGICAL HWRLOG
9743       EXTERNAL HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,HWRINT,HWRLOG
9744       SAVE GAM,EM,VECDEC
9745       PARAMETER (NLOOK=100)
9746       DIMENSION VECDEC(2,0:NLOOK)
9747       EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
9748       DATA GAMLIM,GAM,EM/10D0,2*0D0/
9749 C---IF DECAY, FIND HIGGS (HWDHAD WILL HAVE GIVEN IT STATUS=1)
9750       IF (GAMINP.EQ.ZERO) THEN
9751         IHIG=0
9752         DO 10 I=1,NHEP
9753  10       IF (IHIG.EQ.0.AND.IDHW(I).EQ.201.AND.ISTHEP(I).EQ.1) IHIG=I
9754         IF (IHIG.EQ.0) CALL HWWARN('HWDHIG',101,*999)
9755         EMH=PHEP(5,IHIG)
9756         IF (EMH.LE.ZERO) CALL HWWARN('HWDHIG',102,*999)
9757         EMSCA=EMH
9758       ELSE
9759         EMH=GAMINP
9760         IF (EMH.LE.ZERO) THEN
9761           GAMINP=0
9762           RETURN
9763         ENDIF
9764       ENDIF
9765 C---CALCULATE BRANCHING FRACTIONS
9766 C---FERMIONS
9767 C---NLL CORRECTION TO QUARK DECAY RATE (HHG eq 2.6-9)
9768       ENF=0
9769       DO 1 I=1,6
9770  1      IF (2*RMASS(I).LT.EMH) ENF=ENF+1
9771       K1=5/PIFAC**2
9772       K0=3/(4*PIFAC**2)
9773       BET0=(11*CAFAC-2*ENF)/3
9774       BET1=(34*CAFAC**2-(10*CAFAC+6*CFFAC)*ENF)/3
9775       GAM0=-8
9776       GAM1=-404./3+40*ENF/9
9777       SCLOG=LOG(EMH**2/QCDLAM**2)
9778       CFAC=1 + ( K1/K0 - 2*GAM0 + GAM0*BET1/BET0**2*LOG(SCLOG)
9779      &       +   (GAM0*BET1-GAM1*BET0)/BET0**2) / (BET0*SCLOG)
9780       DO 100 IFERM=1,9
9781         IF (IFERM.LE.6) THEN
9782           EMF=RMASS(IFERM)
9783           XF=(EMF/EMH)**2
9784           COLFAC=FLOAT(NCOLO)
9785           IF (EMF.GT.QCDLAM)
9786      &      EMF=EMF*(LOG(EMH/QCDLAM)/LOG(EMF/QCDLAM))**(GAM0/(2*BET0))
9787         ELSE
9788           EMF=RMASS(107+IFERM*2)
9789           XF=(EMF/EMH)**2
9790           COLFAC=1
9791           CFAC=1
9792         ENDIF
9793         IF (FOUR*XF.LT.ONE) THEN
9794         GFACTR=ALPHEM/(8.*SWEIN*EMW**2)
9795           BRHIG(IFERM)=COLFAC*GFACTR*EMH*EMF**2 * (1-4*XF)**1.5 * CFAC
9796         ELSE
9797           BRHIG(IFERM)=0
9798         ENDIF
9799  100  CONTINUE
9800 C---W*W*/Z*Z*
9801       IF (ABS(EM-EMH).GE.GAMLIM*GAM) THEN
9802 C---OFF EDGE OF LOOK-UP TABLE
9803         XW=(EMW/EMH)**2
9804         XZ=(EMZ/EMH)**2
9805         YW=EMW*GAMW/EMH**2
9806         YZ=EMZ*GAMZ/EMH**2
9807         BRHIG(10)=.50*GFACTR * EMH**3 * HWDHGF(XW,YW)
9808         BRHIG(11)=.25*GFACTR * EMH**3 * HWDHGF(XZ,YZ)
9809       ELSE
9810 C---LOOK IT UP
9811         EMI=((EMH-EM)/(GAM*GAMLIM)+1)*NLOOK/2.0
9812         I1=INT(EMI)
9813         I2=INT(EMI+1)
9814         BRHIG(10)=.50*GFACTR * EMH**3 * ( VECDEC(1,I1)*(I2-EMI) +
9815      &                                    VECDEC(1,I2)*(EMI-I1) )
9816         BRHIG(11)=.25*GFACTR * EMH**3 * ( VECDEC(2,I1)*(I2-EMI) +
9817      &                                    VECDEC(2,I2)*(EMI-I1) )
9818       ENDIF
9819 C---GAMMAGAMMA
9820       TAUT=(2*RMASS(6)/EMH)**2
9821       TAUW=(2*EMW/EMH)**2
9822       CALL HWDHGC(TAUT,TAUTR,TAUTI)
9823       CALL HWDHGC(TAUW,TAUWR,TAUWI)
9824       SUMR=4./3*(  - 2*TAUT*( 1 + (1-TAUT)*TAUTR ) ) * ENHANC(6)
9825      &         +(2 + 3*TAUW*( 1 + (2-TAUW)*TAUWR ) ) * ENHANC(10)
9826       SUMI=4./3*(  - 2*TAUT*(     (1-TAUT)*TAUTI ) ) * ENHANC(6)
9827      &         +(    3*TAUW*(     (2-TAUW)*TAUWI ) ) * ENHANC(10)
9828       BRHIG(12)=GFACTR*.03125*(ALPHEM/PIFAC)**2
9829      &         *EMH**3 * (SUMR**2 + SUMI**2)
9830       WIDHIG=0
9831       DO 200 IPART=1, 12
9832         IF (IPART.LT.12) BRHIG(IPART)=BRHIG(IPART)*ENHANC(IPART)**2
9833  200    WIDHIG=WIDHIG+BRHIG(IPART)
9834       IF (WIDHIG.EQ.ZERO) CALL HWWARN('HWDHIG',103,*999)
9835       DO 300 IPART=1, 12
9836  300    BRHIG(IPART)=BRHIG(IPART)/WIDHIG
9837       IF (EM.NE.RMASS(201)) THEN
9838 C---SET UP W*W*/Z*Z* LOOKUP TABLES
9839         EM=EMH
9840         GAM=WIDHIG
9841         GAMLIM=MAX(GAMLIM,GAMMAX)
9842         DO 400 I=0,NLOOK
9843           EMH=(I*2.0/NLOOK-1)*GAM*GAMLIM+EM
9844           XW=(EMW/EMH)**2
9845           XZ=(EMZ/EMH)**2
9846           YW=EMW*GAMW/EMH**2
9847           YZ=EMZ*GAMZ/EMH**2
9848           VECDEC(1,I)=HWDHGF(XW,YW)
9849           VECDEC(2,I)=HWDHGF(XZ,YZ)
9850  400    CONTINUE
9851         EMH=EM
9852       ENDIF
9853       IF (GAMINP.GT.ZERO) THEN
9854         GAMINP=WIDHIG
9855         RETURN
9856       ENDIF
9857 C---SEE IF USER SPECIFIED A DECAY MODE
9858       IMODE=MOD(ABS(IPROC),100)
9859 C---IF NOT, CHOOSE ONE
9860       IF (IMODE.LT.1.OR.IMODE.GT.12) THEN
9861         MMAX=12
9862         IF (IMODE.LT.1) MMAX=6
9863  500    IMODE=HWRINT(1,MMAX)
9864         IF (BRHIG(IMODE).LT.HWRGEN(0)) GOTO 500
9865       ENDIF
9866 C---SEE IF SPECIFIED DECAY IS POSSIBLE
9867       IF (BRHIG(IMODE).EQ.ZERO) CALL HWWARN('HWDHIG',104,*999)
9868       IF (IMODE.LE.6) THEN
9869         IDEC=IMODE
9870       ELSEIF (IMODE.LE.9) THEN
9871         IDEC=107+IMODE*2
9872       ELSEIF (IMODE.EQ.10) THEN
9873         IDEC=198
9874       ELSEIF (IMODE.EQ.11) THEN
9875         IDEC=200
9876       ELSEIF (IMODE.EQ.12) THEN
9877         IDEC=59
9878       ENDIF
9879 C---STATUS, IDs AND POINTERS
9880       ISTHEP(IHIG)=195
9881       DO 600 I=1,2
9882         ISTHEP(NHEP+I)=193
9883         IDHW(NHEP+I)=IDEC
9884         IDHEP(NHEP+I)=IDPDG(IDEC)
9885         JDAHEP(I,IHIG)=NHEP+I
9886         JMOHEP(1,NHEP+I)=IHIG
9887         JMOHEP(2,NHEP+I)=NHEP+(3-I)
9888         JDAHEP(2,NHEP+I)=NHEP+(3-I)
9889         PHEP(5,NHEP+I)=RMASS(IDEC)
9890         IDEC=IDEC+6
9891         IF (IDEC.EQ.204) IDEC=199
9892         IF (IDEC.EQ.206) IDEC=200
9893         IF (IDEC.EQ. 65) IDEC= 59
9894  600  CONTINUE
9895 C---ALLOW W/Z TO BE OFF-SHELL
9896       IF (IMODE.EQ.10.OR.IMODE.EQ.11) THEN
9897         IF (IMODE.EQ.10) THEN
9898           EMB=EMW
9899           GAMB=GAMW
9900         ELSE
9901           EMB=EMZ
9902           GAMB=GAMZ
9903         ENDIF
9904 C---STANDARD MASS DISTRIBUTION
9905  700    TMIN=ATAN(-EMB/GAMB)
9906         TMAX1=ATAN((EMH**2/EMB-EMB)/GAMB)
9907         EM1=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX1))+EMB))
9908         TMAX2=ATAN(((EMH-EM1)**2/EMB-EMB)/GAMB)
9909         EM2=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX2))+EMB))
9910         X1=(EM1/EMH)**2
9911         X2=(EM2/EMH)**2
9912 C---CORRECT MASS DISTRIBUTION
9913         PROB=HWUSQR(1+X1**2+X2**2-2*X1-2*X2-2*X1*X2)
9914      &        * ((X1+X2-1)**2 + 8*X1*X2)
9915         IF (.NOT.HWRLOG(PROB)) GOTO 700
9916 C---CALCULATE SPIN DENSITY MATRIX
9917         RHOHEP(1,NHEP+1)=4*X1*X2      / (8*X1*X2 + (X1+X2-1)**2)
9918         RHOHEP(2,NHEP+1)=(X1+X2-1)**2 / (8*X1*X2 + (X1+X2-1)**2)
9919         RHOHEP(3,NHEP+1)=RHOHEP(1,NHEP+1)
9920 C---SYMMETRIZE DISTRIBUTIONS IN PARTICLES 1,2
9921         IF (HWRLOG(HALF)) THEN
9922           PHEP(5,NHEP+1)=EM1
9923           PHEP(5,NHEP+2)=EM2
9924         ELSE
9925           PHEP(5,NHEP+1)=EM2
9926           PHEP(5,NHEP+2)=EM1
9927         ENDIF
9928       ENDIF
9929 C---DO DECAY
9930       PCM=HWUPCM(EMH,PHEP(5,NHEP+1),PHEP(5,NHEP+2))
9931       IF (PCM.LT.ZERO) CALL HWWARN('HWDHIG',105,*999)
9932       CALL HWDTWO(PHEP(1,IHIG),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
9933      &            PCM,TWO,.TRUE.)
9934       NHEP=NHEP+2
9935 C---IF QUARK DECAY, HADRONIZE
9936       IF (IMODE.LE.6) THEN
9937         ISTHEP(NHEP-1)=113
9938         ISTHEP(NHEP)=114
9939         CALL HWBGEN
9940         CALL HWDHOB
9941         CALL HWCFOR
9942         CALL HWCDEC
9943 C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS OR PHOTONS
9944       ELSEIF (IMODE.LE.9.OR.IMODE.EQ.12) THEN
9945         CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
9946         CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
9947 C--END FIX
9948       ENDIF
9949   999 END
9950 CDECK  ID>, HWDHOB.
9951 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
9952 *-- Author :    Ian Knowles & Bryan Webber
9953 C-----------------------------------------------------------------------
9954       SUBROUTINE HWDHOB
9955 C-----------------------------------------------------------------------
9956 C   Performs decays of heavy objects (heavy quarks & SUSY particles)
9957 C   MODIFIED TO INCLUDE R-PARITY VIOLATING SUSY PR 9/4/99
9958 C   MODIFIED TO CALL A NUMBER OF ROUTINES TO DO THE VARIOUS BITS OF
9959 C   THE PROCESS
9960 C-----------------------------------------------------------------------
9961       INCLUDE 'HERWIG65.INC'
9962       DOUBLE PRECISION PW(5)
9963       INTEGER IHEP,IS,ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2),NHEPST
9964       LOGICAL FOUND
9965       SAVE NHEPST
9966       IF (IERROR.NE.0) RETURN
9967   10  FOUND=.FALSE.
9968       NHEPST = NHEP
9969       CLSAVE(1) = 0
9970       CLSAVE(2) = 0
9971       DO 60 IHEP=1,NMXHEP
9972       IS=ISTHEP(IHEP)
9973       ID=IDHW(IHEP)
9974       IF(SYSPIN.AND.NSPN.NE.0) CALL HWDSIN(CLSAVE)
9975       IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
9976      & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
9977      & ((IS.EQ.120.AND.JDAHEP(1,IHEP).EQ.IHEP).OR.
9978      & IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
9979         FOUND=.TRUE.
9980 C--select the decay mode and enter the decay products in the event record
9981         CALL  HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
9982         IF (IERROR.NE.0) RETURN
9983 C--select the momenta of the decay products
9984         CALL HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
9985         IF (IERROR.NE.0) RETURN
9986 C--make the colour connections
9987         CALL HWDHO3(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
9988         IF (IERROR.NE.0) RETURN
9989 C--perform the parton-showers
9990         CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
9991         IF (IERROR.NE.0) RETURN
9992       ENDIF
9993 C--perform the colour corrections for RPV
9994       CALL HWDHO5(IHEP,MHEP,LHEP,CLSAVE)
9995       IF(IERROR.NE.0) RETURN
9996       IF (IHEP.EQ.NHEP) GOTO 70
9997   60  CONTINUE
9998   70  IF(SYSPIN.AND.NHEP.NE.NHEPST) FOUND=.TRUE.
9999       IF (FOUND) THEN
10000 C--final check for colour disconnection
10001         CALL HWDHO6
10002 C Go back to check for further heavy decay products
10003         GOTO 10
10004       ENDIF
10005   999 END
10006 CDECK  ID>, HWDHO1.
10007 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
10008 *-- Author :    Ian Knowles & Bryan Webber
10009 C-----------------------------------------------------------------------
10010       SUBROUTINE HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
10011 C-----------------------------------------------------------------------
10012 C   Subroutine to perform the first part of the heavy object decays
10013 C   IE to select the decay mode
10014 C   was part of HWDHOB
10015 C-----------------------------------------------------------------------
10016       INCLUDE 'HERWIG65.INC'
10017       DOUBLE PRECISION HWUMBW,HWRGEN,SDKM,RN,BF
10018       INTEGER IST(3),IHEP,ID,IM,I,JHEP,LHEP,MHEP,NPR,MTRY,NTRY,IS
10019       EXTERNAL HWRGEN
10020       DATA IST/113,114,114/
10021       IF (IERROR.NE.0) RETURN
10022       IF(.NOT.RPARTY) THEN
10023         NHEP = NHEP+1
10024         ISTHEP(NHEP) = 3
10025         IDHW(NHEP) = 20
10026         IDHEP(NHEP) = 0
10027         CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
10028         CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
10029         JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
10030         JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
10031         JDAHEP(1,NHEP)=JDAHEP(1,IHEP)
10032         JDAHEP(2,NHEP)=JDAHEP(2,IHEP)
10033       ENDIF
10034 C Make a copy of decaying object
10035       NHEP=NHEP+1
10036       ISTHEP(NHEP)=155
10037       IDHW(NHEP)=IDHW(IHEP)
10038       IDHEP(NHEP)=IDHEP(IHEP)
10039       CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
10040       CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
10041       JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
10042       JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
10043 C--copy the location of the particle in the spin block
10044       IF(SYSPIN.AND.NSPN.NE.0) THEN
10045          IF(ISNHEP(IHEP).EQ.0) THEN
10046            IS = IHEP
10047            MTRY = 0
10048  5         MTRY = MTRY+1
10049            IS = JMOHEP(1,IS)
10050            IF(ISNHEP(IS).EQ.0.AND.MTRY.LE.NETRY) GOTO 5
10051            IF(MTRY.GT.NETRY) CALL HWWARN('HWDHO1',102,*999)
10052            ISNHEP(IHEP) = ISNHEP(IS)
10053          ENDIF
10054          ISNHEP(NHEP) = ISNHEP(JMOHEP(1,NHEP))
10055       ENDIF
10056       MTRY=0
10057  15   MTRY=MTRY+1
10058 C Select decay mode
10059       RN=HWRGEN(0)
10060       BF=0.
10061       IM=LSTRT(ID)
10062       DO 20 I=1,NMODES(ID)
10063       BF=BF+BRFRAC(IM)
10064       IF (BF.GE.RN) GOTO 30
10065   20  IM=LNEXT(IM)
10066       CALL HWWARN('HWDHO1',50,*30)
10067   30  IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWDHO1',100,*999)
10068       NPR=NPRODS(IM)
10069       JDAHEP(1,NHEP)=NHEP+1
10070       JDAHEP(2,NHEP)=NHEP+NPR
10071 C Reset colour pointers (if set)
10072       JHEP=JMOHEP(2,IHEP)
10073       IF (JHEP.GT.0) THEN
10074         IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
10075         IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
10076      &    .AND.ABS(IDHEP(JHEP)).GT.1000000
10077      &    .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
10078       ENDIF
10079       JHEP=JDAHEP(2,IHEP)
10080       IF (JHEP.GT.0) THEN
10081         IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
10082         IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
10083      &    .AND.ABS(IDHEP(JHEP)).GT.1000000
10084      &    .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
10085       ENDIF
10086 C--Reset colour pointers if baryon number violated
10087       IF(.NOT.RPARTY) THEN
10088         DO JHEP=1,NHEP
10089           IF(ISTHEP(JHEP).EQ.155
10090      &       .AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
10091      &       JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1)= NHEP
10092           IF(JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
10093           IF(JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
10094         ENDDO
10095         IF(HRDCOL(1,1).EQ.IHEP) HRDCOL(1,1)=NHEP
10096       ENDIF
10097 C Relabel original track
10098       IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3
10099       JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
10100       JDAHEP(1,IHEP)=NHEP
10101       JDAHEP(2,IHEP)=NHEP
10102 C Label decay products and choose masses
10103       LHEP=NHEP
10104       MHEP=LHEP+1
10105       NTRY=0
10106  35   NTRY=NTRY+1
10107       SDKM=PHEP(5,NHEP)
10108       DO 40 I=1,NPR
10109       NHEP=NHEP+1
10110       IDHW(NHEP)=IDKPRD(I,IM)
10111       IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
10112       ISTHEP(NHEP)=IST(I)
10113       JMOHEP(1,NHEP)=LHEP
10114       JDAHEP(1,NHEP)=0
10115       PHEP(5,NHEP)=HWUMBW(IDKPRD(I,IM))
10116  40   SDKM=SDKM-PHEP(5,NHEP)
10117       IF (SDKM.LT.ZERO) THEN
10118         NHEP=NHEP-NPR
10119         IF (NTRY.LE.NETRY) GO TO 35
10120         CALL HWWARN('HWDHO1',1,*45)
10121  45     IF (MTRY.LE.NETRY) GO TO 15
10122         CALL HWWARN('HWDHO1',101,*999)
10123       ENDIF
10124 C Assign production vertices to decay products
10125       CALL HWUDKL(ID,PHEP(1,IHEP),VHEP(1,MHEP))
10126       CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,MHEP),VHEP(1,MHEP))
10127       CALL HWVEQU(4,VHEP(1,MHEP),VHEP(1,NHEP))
10128  999  END
10129 CDECK  ID>, HWDH02.
10130 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
10131 *-- Author :    Ian Knowles & Bryan Webber
10132 C-----------------------------------------------------------------------
10133       SUBROUTINE HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
10134 C-----------------------------------------------------------------------
10135 C   Subroutine to perform the second part of the heavy object decays
10136 C   IE generate the kinematics for the decay
10137 C   was part of HWDHOB
10138 C-----------------------------------------------------------------------
10139       INCLUDE 'HERWIG65.INC'
10140       COMMON/FFS/TB,BT
10141       COMMON/SFF/IT1,IB1,IT2,IB2
10142       DOUBLE PRECISION TB,BT
10143       INTEGER IT1,IB1,IT2,IB2,ISP
10144       DOUBLE PRECISION GAMHPM
10145       DOUBLE PRECISION HWUPCM,HWRGEN,PCM,
10146      & EMMX,EMWSQ,GMWSQ,EMLIM,PW(5),EMTST,HWDPWT,HWDWWT,HWULDO,HWDHWT
10147       DOUBLE COMPLEX RHOIN(2,2,2)
10148       INTEGER IHEP,IM,KHEP,LHEP,MHEP,NPR,RHEP
10149       EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT
10150       DATA RHOIN/(1.0D0,0.0D0),(0.0D0,0.0D0),
10151      &           (0.0D0,0.0D0),(0.0D0,0.0D0),
10152      &           (0.5D0,0.0D0),(0.0D0,0.0D0),
10153      &           (0.0D0,0.0D0),(0.5D0,0.0D0)/
10154       ISP = INT(2*RSPIN(IDHW(IHEP)))+1
10155       IF (IERROR.NE.0) RETURN
10156       IF (NPR.EQ.2) THEN
10157 C Two body decay: LHEP -> MHEP + NHEP
10158         IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
10159 C--generate a two body decay to a gauge boson as a three body decay
10160           CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,RHOIN(1,1,ISP),1)
10161 C--generate a two body decay of a Higgs to two gauge bosons
10162         ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
10163           CALL HWDSM4(1,IHEP,MHEP,NHEP,NME(IM)-40000)
10164 C--if spin correlations call the routine to set-up the matrix element
10165         ELSEIF(SYSPIN.AND.NME(IM).GE.30000.AND.NME(IM).LE.40000) THEN
10166           CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,RHOIN(1,1,ISP),1)
10167         ELSE
10168           PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
10169           CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
10170      &                PHEP(1,NHEP),PCM,TWO,.FALSE.)
10171         ENDIF
10172       ELSEIF (NPR.EQ.3) THEN
10173 C Three body decay: LHEP -> KHEP + MHEP + NHEP
10174         KHEP=MHEP
10175         MHEP=MHEP+1
10176 C Provisional colour self-connection of KHEP
10177         JMOHEP(2,KHEP)=KHEP
10178         JDAHEP(2,KHEP)=KHEP
10179         IF (NME(IM).EQ.100) THEN
10180 C Generate decay momenta using full (V-A)*(V-A) matrix element
10181           EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
10182           EMWSQ=RMASS(198)**2
10183           GMWSQ=(RMASS(198)*GAMW)**2
10184           EMLIM=GMWSQ
10185           IF (EMMX.LT.RMASS(198)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
10186   50      CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
10187      &                PHEP(1,KHEP),PHEP(1,NHEP),HWDWWT)
10188           CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10189           PW(5)=HWULDO(PW,PW)
10190           EMTST=(EMWSQ-PW(5))**2
10191           IF ((EMTST+GMWSQ)*HWRGEN(1).GT.EMLIM) GOTO 50
10192           PW(5)=SQRT(PW(5))
10193 C Assign production vertices to 1 and 2
10194           CALL HWUDKL(198,PW,VHEP(1,KHEP))
10195           CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
10196         ELSE IF (NME(IM).EQ.200) THEN
10197 C Generate decay momenta using full
10198 C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
10199           GAMHPM=RMASS(206)/DKLTM(206)
10200 C sort tan(beta)
10201           IF((IDK(IM).EQ.  2).OR.(IDK(IM).EQ.  4).OR.
10202      &       (IDK(IM).EQ.  6).OR.(IDK(IM).EQ.  8).OR.
10203      &       (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
10204      &       (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
10205      &       (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
10206      &       (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
10207             TB=TANB
10208           ELSE
10209             TB=1./TANB
10210           END IF
10211           IF((IDKPRD(1,IM).EQ.  2).OR.(IDKPRD(1,IM).EQ.  4).OR.
10212      &       (IDKPRD(1,IM).EQ.  6).OR.(IDKPRD(1,IM).EQ.  8).OR.
10213      &       (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
10214      &       (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
10215      &       (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
10216      &       (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
10217             BT=TANB
10218           ELSE
10219             BT=1./TANB
10220           END IF
10221           IT1=IDK(IM)
10222           IB1=IDKPRD(3,IM)
10223           IT2=IDKPRD(1,IM)
10224           IB2=IDKPRD(2,IM)
10225           EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
10226           EMWSQ=RMASS(206)**2
10227           GMWSQ=(RMASS(206)*GAMHPM)**2
10228           EMLIM=GMWSQ
10229           IF (EMMX.LT.RMASS(206)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
10230   55      CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP),
10231      &                PHEP(1,KHEP),PHEP(1,MHEP),HWDHWT)
10232           CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10233           PW(5)=HWULDO(PW,PW)
10234           EMTST=(EMWSQ-PW(5))**2
10235           IF ((EMTST+GMWSQ)*HWRGEN(2).GT.EMLIM) GOTO 55
10236           PW(5)=SQRT(PW(5))
10237 C Assign production vertices to 1 and 2
10238           CALL HWUDKL(206,PW,VHEP(1,KHEP))
10239           CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
10240         ELSEIF(NME(IM).EQ.300) THEN
10241 C Generate momenta using 3-body RPV matrix element
10242           CALL HWDRME(LHEP,KHEP)
10243 C--Three body SUSY decay
10244         ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
10245           CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
10246      &                RHOIN(1,1,ISP),1)
10247 C--special for top decay
10248           IF(ABS(IDHEP(IHEP)).EQ.6) THEN
10249             CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10250             CALL HWUMAS(PW)
10251           ENDIF
10252         ELSE
10253 C Three body phase space decay
10254           CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
10255      &                PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
10256         ENDIF
10257         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
10258       ELSEIF(NPR.EQ.4) THEN
10259 C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
10260         KHEP = MHEP
10261         RHEP = MHEP+1
10262         MHEP = MHEP+2
10263         ISTHEP(NHEP) = 114
10264 C Provisional colour connections of KHEP and RHEP
10265         JMOHEP(2,KHEP)=RHEP
10266         JDAHEP(2,KHEP)=RHEP
10267         JMOHEP(2,RHEP)=KHEP
10268         JDAHEP(2,RHEP)=KHEP
10269 C Four body phase space decay
10270         CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
10271      &                PHEP(1,MHEP),PHEP(1,NHEP))
10272         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
10273         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
10274       ELSE
10275         CALL HWWARN('HWDHO2',100,*999)
10276       ENDIF
10277  999  END
10278 CDECK  ID>, HWDHO3.
10279 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
10280 *-- Author :    Ian Knowles & Bryan Webber
10281 C-----------------------------------------------------------------------
10282       SUBROUTINE HWDHO3(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
10283 C-----------------------------------------------------------------------
10284 C   Subroutine to perform the third part of the heavy object decays
10285 C   IE setup the colour connections
10286 C   was part of HWDHOB
10287 C-----------------------------------------------------------------------
10288       INCLUDE 'HERWIG65.INC'
10289       INTEGER IHEP,ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2)
10290       IF (IERROR.NE.0) RETURN
10291 C Colour connections
10292       IF (ID.EQ.6.OR.ID.EQ.12.OR.(ID.GE.209.AND.ID.LE.212)
10293      &                       .OR.(ID.GE.215.AND.ID.LE.218)) THEN
10294         IF ((NPR.EQ.3.AND.NME(IM).EQ.100).OR.
10295      &      ((SYSPIN.OR.THREEB).AND.NPR.EQ.3.AND.
10296      &        NME(IM).GE.10000.AND.NME(IM).LE.20000)) THEN
10297 C usual heavy quark decay
10298           JMOHEP(2,KHEP)=MHEP
10299           JDAHEP(2,KHEP)=MHEP
10300           JMOHEP(2,MHEP)=KHEP
10301           JDAHEP(2,MHEP)=KHEP
10302           JMOHEP(2,NHEP)=LHEP
10303           JDAHEP(2,NHEP)=LHEP
10304         ELSEIF (ABS(IDHEP(MHEP)).EQ.37) THEN
10305 C heavy quark to charged Higgs 2->2
10306           JMOHEP(2,MHEP)=MHEP
10307           JDAHEP(2,MHEP)=MHEP
10308           JMOHEP(2,NHEP)=LHEP
10309           JDAHEP(2,NHEP)=LHEP
10310         ELSEIF (ABS(IDHEP(NHEP)).EQ.37) THEN
10311 C heavy quark to charged Higgs 2->2
10312           JMOHEP(2,MHEP)=LHEP
10313           JDAHEP(2,MHEP)=LHEP
10314           JMOHEP(2,NHEP)=NHEP
10315           JDAHEP(2,NHEP)=NHEP
10316         ELSE IF (NPR.EQ.3.AND.NME(IM).EQ.200) THEN
10317 C heavy quark to charged Higgs 2->3
10318           JMOHEP(2,KHEP)=MHEP
10319           JDAHEP(2,KHEP)=MHEP
10320           JMOHEP(2,MHEP)=KHEP
10321           JDAHEP(2,MHEP)=KHEP
10322           JMOHEP(2,NHEP)=LHEP
10323           JDAHEP(2,NHEP)=LHEP
10324         ELSE
10325           CALL HWWARN('HWDHO3',100,*999)
10326         ENDIF
10327       ELSE
10328         IF(.NOT.RPARTY.AND.
10329      &     ((NPR.EQ.2.AND.ID.GE.401.AND.ID.LT.448.AND.
10330      &         IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132)
10331      &     .OR.(NPR.EQ.3.AND.ID.GE.449.AND.ID.LE.457.AND.
10332      &         IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132.AND.
10333      &         IDHW(MHEP-1).LE.132))) THEN
10334 C R-parity violating SUSY decays
10335           IF(NPR.EQ.2) THEN
10336 C--Rparity slepton colour connections
10337             IF(ID.GE.425.AND.ID.LE.448) THEN
10338               IF(IDHW(MHEP).GT.12) THEN
10339                 JMOHEP(2,MHEP) = MHEP
10340                 JDAHEP(2,MHEP) = MHEP
10341                 JMOHEP(2,NHEP) = NHEP
10342                 JDAHEP(2,NHEP) = NHEP
10343               ELSE
10344                 JMOHEP(2,MHEP) = NHEP
10345                 JDAHEP(2,MHEP) = NHEP
10346                 JMOHEP(2,NHEP) = MHEP
10347                 JDAHEP(2,NHEP) = MHEP
10348               ENDIF
10349 C--Rparity squark colour connections
10350             ELSE
10351               IF(IDHEP(LHEP).GT.0) THEN
10352 C--LQD decay colour connections
10353                 IF(IDHW(MHEP).GT.12) THEN
10354                   JMOHEP(2,MHEP) = MHEP
10355                   JDAHEP(2,MHEP) = MHEP
10356                   JMOHEP(2,NHEP) = LHEP
10357                   JDAHEP(2,NHEP) = LHEP
10358                 ELSE
10359 C--UDD decay colour connections
10360                   HVFCEN = .TRUE.
10361                   CALL HWDRCL(LHEP,MHEP,CLSAVE)
10362                 ENDIF
10363               ELSE
10364 C--Antisquark connections
10365                 IF(IDHW(MHEP).GT.12) THEN
10366                   JMOHEP(2,MHEP) = MHEP
10367                   JDAHEP(2,MHEP) = MHEP
10368                   JMOHEP(2,NHEP) = LHEP
10369                   JDAHEP(2,NHEP) = LHEP
10370                 ELSE
10371                   HVFCEN = .TRUE.
10372                  CALL HWDRCL(LHEP,MHEP,CLSAVE)
10373                 ENDIF
10374               ENDIF
10375             ENDIF
10376           ELSE
10377             IF(ID.GE.450.AND.ID.LE.457) THEN
10378 C--Rparity Neutralino/Chargino colour connection
10379               IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
10380      &               AND.IDHW(NHEP).LE.12) THEN
10381                 HVFCEN = .TRUE.
10382                 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10383               ELSE
10384                 JMOHEP(2,MHEP) = NHEP
10385                 JDAHEP(2,MHEP) = NHEP
10386                 JMOHEP(2,NHEP) = MHEP
10387                 JDAHEP(2,NHEP) = MHEP
10388               ENDIF
10389 C--Rparity gluino colour connections
10390             ELSEIF(ID.EQ.449) THEN
10391               IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
10392      &               AND.IDHW(NHEP).LE.12) THEN
10393                 HVFCEN = .TRUE.
10394                 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10395 C--Now the lepton number violating decay
10396               ELSE
10397                 IF(IDHW(MHEP).LE.6) THEN
10398                   JMOHEP(2,MHEP) = LHEP
10399                   JDAHEP(2,MHEP) = NHEP
10400                   JMOHEP(2,NHEP) = MHEP
10401                   JDAHEP(2,NHEP) = LHEP
10402                 ELSE
10403                   JMOHEP(2,MHEP) = NHEP
10404                   JDAHEP(2,MHEP) = LHEP
10405                   JMOHEP(2,NHEP) = LHEP
10406                   JDAHEP(2,NHEP) = MHEP
10407                 ENDIF
10408               ENDIF
10409             ELSE
10410               CALL HWWARN('HWDHO3',101,*999)
10411             ENDIF
10412           ENDIF
10413         ELSE
10414 C Normal SUSY decays
10415           IF (ID.LE.448.AND.ID.GT.207) THEN
10416 C Squark (or slepton)
10417             IF (IDHW(MHEP).EQ.449) THEN
10418               IF (IDHEP(LHEP).GT.0) THEN
10419                 JMOHEP(2,MHEP)=LHEP
10420                 JDAHEP(2,MHEP)=NHEP
10421                 JMOHEP(2,NHEP)=MHEP
10422                 JDAHEP(2,NHEP)=LHEP
10423               ELSE
10424                 JMOHEP(2,MHEP)=NHEP
10425                 JDAHEP(2,MHEP)=LHEP
10426                 JMOHEP(2,NHEP)=LHEP
10427                 JDAHEP(2,NHEP)=MHEP
10428               ENDIF
10429             ELSE
10430               IF(NPR.EQ.3.AND.IDHW(MHEP).LE.12) THEN
10431                 JMOHEP(2,MHEP)=NHEP
10432                 JDAHEP(2,MHEP)=NHEP
10433                 JMOHEP(2,NHEP)=MHEP
10434                 JDAHEP(2,NHEP)=MHEP
10435               ELSE
10436                 JMOHEP(2,MHEP)=MHEP
10437                 JDAHEP(2,MHEP)=MHEP
10438                 JMOHEP(2,NHEP)=LHEP
10439                 JDAHEP(2,NHEP)=LHEP
10440               ENDIF
10441             ENDIF
10442           ELSEIF (ID.EQ.449) THEN
10443 C Gluino
10444             IF (IDHW(NHEP).EQ.13) THEN
10445               JMOHEP(2,MHEP)=MHEP
10446               JDAHEP(2,MHEP)=MHEP
10447               JMOHEP(2,NHEP)=LHEP
10448               JDAHEP(2,NHEP)=LHEP
10449             ELSEIF (IDHEP(MHEP).GT.0) THEN
10450               JMOHEP(2,MHEP)=LHEP
10451               JDAHEP(2,MHEP)=NHEP
10452               JMOHEP(2,NHEP)=MHEP
10453               JDAHEP(2,NHEP)=LHEP
10454             ELSE
10455               JMOHEP(2,MHEP)=NHEP
10456               JDAHEP(2,MHEP)=LHEP
10457               JMOHEP(2,NHEP)=LHEP
10458               JDAHEP(2,NHEP)=MHEP
10459             ENDIF
10460           ELSE
10461 C Gaugino or Higgs
10462             JMOHEP(2,MHEP)=NHEP
10463             JDAHEP(2,MHEP)=NHEP
10464             JMOHEP(2,NHEP)=MHEP
10465             JDAHEP(2,NHEP)=MHEP
10466           ENDIF
10467         ENDIF
10468       ENDIF
10469  999  END
10470 CDECK  ID>, HWDHO4.
10471 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
10472 *-- Author :    Ian Knowles & Bryan Webber
10473 C-----------------------------------------------------------------------
10474       SUBROUTINE HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
10475 C-----------------------------------------------------------------------
10476 C   Subroutine to perform the fourth part of the heavy object decays
10477 C   IE parton-showers with special treatment for top
10478 C   was part of HWDHOB
10479 C-----------------------------------------------------------------------
10480       INCLUDE 'HERWIG65.INC'
10481       DOUBLE PRECISION PW(5),PDW(5,3)
10482       INTEGER IHEP,ID,IM,I,KHEP,LHEP,MHEP,NPR,NTRY,WHEP,SHEP
10483       DOUBLE COMPLEX RHOIN(2,2)
10484       DATA RHOIN/(0.5D0,0.0D0),(0.0D0,0.0D0),
10485      &           (0.0D0,0.0D0),(0.5D0,0.0D0)/
10486       IF (IERROR.NE.0) RETURN
10487       SHEP = NHEP
10488 C---SPECIAL CASE FOR THREE-BODY TOP DECAYS:
10489 C   RELABEL THEM AS TWO TWO-BODY DECAYS FOR PARTON SHOWERING
10490       IF ((ID.EQ.6.OR.ID.EQ.12).AND.NPR.EQ.3.AND.
10491      &     (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.
10492      &     (NME(IM).GT.10000.AND.NME(IM).LE.20000.AND.
10493      &     (SYSPIN.OR.THREEB)))) THEN
10494 C---STORE W/H DECAY PRODUCTS
10495         CALL HWVEQU(10,PHEP(1,KHEP),PDW)
10496 C---BOOST THEM INTO W/H REST FRAME
10497         CALL HWULOF(PW,PDW(1,1),PDW(1,3))
10498 C---REPLACE THEM BY W/H
10499         CALL HWVEQU(5,PW,PHEP(1,KHEP))
10500         WHEP=KHEP
10501         IF (NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
10502      &      NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB)))IDHW(KHEP)=198
10503         IF((NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
10504      &      NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB))).AND.(ID.EQ.12))
10505      &       IDHW(KHEP)=199
10506         IF (NME(IM).EQ.200)IDHW(KHEP)=206
10507         IF((NME(IM).EQ.200).AND.(ID.EQ.12))IDHW(KHEP)=207
10508         IDHEP(KHEP)=IDPDG(IDHW(KHEP))
10509         JMOHEP(2,KHEP)=KHEP
10510         JDAHEP(2,KHEP)=KHEP
10511         CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,KHEP))
10512 C---AND MOVE B UP
10513         CALL HWVEQU(5,PHEP(1,NHEP),PHEP(1,MHEP))
10514         IDHW(MHEP)=IDHW(NHEP)
10515         IDHEP(MHEP)=IDHEP(NHEP)
10516         JDAHEP(2,LHEP)=MHEP
10517         JMOHEP(2,MHEP)=JMOHEP(2,NHEP)
10518         JDAHEP(2,MHEP)=JDAHEP(2,NHEP)
10519         CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,MHEP))
10520         NHEP=MHEP
10521 C---DO PARTON SHOWER
10522         EMSCA=PHEP(5,IHEP)
10523         CALL HWBGEN
10524         IF (IERROR.NE.0) RETURN
10525 C---FIND BOOSTED W/H MOMENTUM
10526         NTRY=0
10527  41     NTRY=NTRY+1
10528         IF (NTRY.GT.NHEP.OR.WHEP.LE.0.OR.WHEP.GT.NHEP)
10529      $       CALL HWWARN('HWDHO4',100,*999)
10530         WHEP=JDAHEP(1,WHEP)
10531         IF (ISTHEP(WHEP).NE.190) GOTO 41
10532 C---AND HENCE ITS CHILDRENS MOMENTA
10533         CALL HWULOB(PHEP(1,WHEP),PDW(1,3),PHEP(1,NHEP+1))
10534         CALL HWVDIF(4,PHEP(1,WHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
10535         PHEP(5,NHEP+2)=PDW(5,2)
10536 C---LABEL THEM
10537         ISTHEP(WHEP)=195
10538         DO 51 I=1,2
10539           IDHW(NHEP+I)=IDKPRD(I,IM)
10540           IDHEP(NHEP+I)=IDPDG(IDHW(NHEP+I))
10541           ISTHEP(NHEP+I)=112+I
10542           JDAHEP(I,WHEP)=NHEP+I
10543           JMOHEP(1,NHEP+I)=WHEP
10544           JMOHEP(2,NHEP+I)=NHEP+3-I
10545           JDAHEP(2,NHEP+I)=NHEP+3-I
10546  51     CONTINUE
10547         NHEP=NHEP+2
10548 C---ASSIGN PRODUCTION VERTICES TO 1 AND 2
10549         IF(NME(IM).EQ.100)CALL HWUDKL(198,PW,VHEP(1,NHEP))
10550         IF(NME(IM).EQ.200)CALL HWUDKL(206,PW,VHEP(1,NHEP))
10551         CALL HWVSUM(4,VHEP(1,WHEP),VHEP(1,NHEP),VHEP(1,NHEP))
10552         CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
10553 C---DO PARTON SHOWERS
10554         EMSCA=PW(5)
10555 C--modification to use photos in top decays
10556         IF(ITOPRD.EQ.1) CALL HWPHTP(WHEP)
10557 C--end of modification
10558         CALL HWBGEN
10559         IF (IERROR.NE.0) RETURN
10560       ELSE
10561 C Do parton showers
10562         EMSCA=PHEP(5,IHEP)
10563         CALL HWBGEN
10564         IF (IERROR.NE.0) RETURN
10565 C--special for gauge boson decay modes of gauginos and four body higgs
10566 C--call routine to add decay products and generate parton shower
10567         IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
10568           CALL HWDSM3(-1,IHEP,MHEP,SHEP,0,NME(IM)-20000,RHOIN,
10569      &       ISNHEP(IHEP))
10570         ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
10571           CALL HWDSM4(2,IHEP,MHEP,SHEP,NME(IM)-40000)
10572         ENDIF
10573         IF (IERROR.NE.0) RETURN
10574       ENDIF
10575  999  END
10576 CDECK  ID>, HWDHO5.
10577 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
10578 *-- Author :    Ian Knowles & Bryan Webber
10579 C-----------------------------------------------------------------------
10580       SUBROUTINE HWDHO5(IHEP,MHEP,LHEP,CLSAVE)
10581 C-----------------------------------------------------------------------
10582 C   Subroutine to perform the fifth part of the heavy object decays
10583 C   IE sort out RPV colour connections
10584 C   was part of HWDHOB
10585 C-----------------------------------------------------------------------
10586       INCLUDE 'HERWIG65.INC'
10587       INTEGER IHEP,ID,LHEP,MHEP,IDM,IDM2,THEP,CLSAVE(2)
10588       IF (IERROR.NE.0) RETURN
10589 C--New to correct colour connections in Rslash
10590       IF(CLSAVE(1).NE.0) THEN
10591         THEP = MHEP+1
10592         ID   = IDHW(CLSAVE(1))
10593         IDM  = IDHW(JMOHEP(1,CLSAVE(1)))
10594         IDM2 = IDHW(LHEP)
10595         IF(IDM.EQ.15) ID=IDHW(JMOHEP(1,JMOHEP(1,CLSAVE(1))))
10596         IF((ID.LE.6.AND.((IDM.GE.419.AND.IDM.LE.424).OR.IDM.EQ.411.OR.
10597      &      IDM.EQ.412).
10598      &     AND.((IDM2.GE.413.AND.IDM2.LE.418)
10599      &     .OR.IDM2.EQ.449).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
10600      &     .OR.(ID.LE.6.AND.IDM.EQ.449.AND.
10601      &    (((IDM2.GE.413.AND.IDM2.LE.418).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
10602      &     .OR.IDM2.EQ.449)).OR.
10603      &    (IDM.EQ.15.AND.ID.LE.12.AND.ID.GE.7.AND.((IDM2.GE.413.AND.
10604      &     IDM2.LE.418).OR.IDM2.EQ.449.OR.IDM2.
10605      &     EQ.405.OR.IDM2.EQ.406))) THEN
10606           IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
10607             IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
10608      &                       JMOHEP(2,CLSAVE(2)) = THEP
10609             JDAHEP(2,MHEP) = CLSAVE(1)
10610             JDAHEP(2,THEP) = CLSAVE(2)
10611           ELSE
10612             IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
10613      &                       JMOHEP(2,CLSAVE(2)) = MHEP
10614             JDAHEP(2,MHEP) = CLSAVE(2)
10615             JDAHEP(2,THEP) = CLSAVE(1)
10616           ENDIF
10617         ELSEIF((ID.GT.6.AND.ID.LE.12.
10618      &     AND.((IDM.GE.413.AND.IDM.LE.418).OR.IDM.EQ.405.OR.
10619      &     IDM.EQ.406).AND.
10620      &      ((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
10621      &      IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
10622      &        (ID.GT.6.AND.ID.LE.12.AND.IDM.EQ.449.
10623      &   AND.((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
10624      &       IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
10625      &    (IDM.EQ.15.AND.ID.LE.6.AND.((IDM2.GE.419.AND.
10626      &     IDM2.LE.424).OR.IDM2.EQ.449.OR.IDM2.EQ.411.OR.
10627      &     IDM2.EQ.412))) THEN
10628           IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
10629             JDAHEP(2,CLSAVE(2))=THEP
10630             JMOHEP(2,MHEP)=CLSAVE(1)
10631             JMOHEP(2,THEP)=CLSAVE(2)
10632           ELSE
10633             JDAHEP(2,CLSAVE(2))=MHEP
10634             JMOHEP(2,MHEP)=CLSAVE(2)
10635             JMOHEP(2,THEP)=CLSAVE(1)
10636           ENDIF
10637         ENDIF
10638         COLUPD = .FALSE.
10639         CALL HWBCON
10640       ENDIF
10641  999  END
10642 CDECK  ID>, HWDHO6.
10643 *CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
10644 *-- Author :    Ian Knowles & Bryan Webber
10645 C-----------------------------------------------------------------------
10646       SUBROUTINE HWDHO6
10647 C-----------------------------------------------------------------------
10648 C   Subroutine to perform the final part of the heavy object decays
10649 C   IE sort out any colour connection problems
10650 C-----------------------------------------------------------------------
10651       INCLUDE 'HERWIG65.INC'
10652       INTEGER IHEP,IM,JHEP,ISM,JCM
10653       IF (IERROR.NE.0) RETURN
10654 C Fix any SUSY colour disconnections
10655       DO 80 IHEP=1,NHEP
10656         IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.151
10657      &    .AND.JDAHEP(2,IHEP).EQ.0) THEN
10658           IM=JMOHEP(1,IHEP)
10659 C Chase connection back through SUSY decays
10660   75      IM=JMOHEP(1,IM)
10661           ISM=ISTHEP(IM)
10662           IF (ISM.EQ.120) GOTO 80
10663           IF (ISM.NE.123.AND.ISM.NE.124.AND.ISM.NE.155) GOTO 75
10664 C Look for unclustered parton to connect
10665           DO JHEP=1,NHEP
10666             IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.151) THEN
10667               JCM=JMOHEP(2,JHEP)
10668               IF (JCM.EQ.IM) THEN
10669 C Found it: connect
10670                 JMOHEP(2,JHEP)=IHEP
10671                 JDAHEP(2,IHEP)=JHEP
10672                 GOTO 80
10673               ENDIF
10674             ENDIF
10675           ENDDO
10676 C Not found: need to go further back
10677           GOTO 75
10678         ENDIF
10679    80 CONTINUE
10680  999  END
10681 CDECK  ID>, HWDHVY.
10682 *CMZ :-        -26/04/91  12.19.24  by  Federico Carminati
10683 *-- Author :    Ian Knowles & Bryan Webber
10684 C-----------------------------------------------------------------------
10685       SUBROUTINE HWDHVY
10686 C-----------------------------------------------------------------------
10687 C     Performs partonic decays of hadrons containing heavy quark(s):
10688 C     either, meson/baryon spectator model weak decays;
10689 C     or, quarkonia -> 2-gluons, q-qbar, 3-gluons, or 2-gluons + photon.
10690 C-----------------------------------------------------------------------
10691       INCLUDE 'HERWIG65.INC'
10692       COMMON/FFS/TB,BT
10693       COMMON/SFF/IT1,IB1,IT2,IB2
10694       DOUBLE PRECISION TB,BT
10695       INTEGER IT1,IB1,IT2,IB2
10696       DOUBLE PRECISION GAMHPM
10697       DOUBLE PRECISION HWULDO,HWRGEN,XS,XB,EMWSQ,GMWSQ,EMLIM,PW(4),
10698      & EMTST,X1,X2,X3,TEST,HWDWWT,HWDHWT,HWDPWT
10699       INTEGER IST(3),I,IHEP,IM,ID,IDQ,IQ,IS,J
10700       EXTERNAL HWRGEN,HWDWWT,HWDHWT,HWDPWT,HWULDO
10701       DATA IST/113,114,114/
10702       IF (IERROR.NE.0) RETURN
10703       DO 100 I=1,NMXQDK
10704       IF (I.GT.NQDK) THEN
10705         NQDK=0
10706         RETURN
10707       ENDIF
10708       IHEP=LOCQ(I)
10709       IF (ISTHEP(IHEP).EQ.199) GOTO 100
10710       IM=IMQDK(I)
10711       IF (NHEP+NPRODS(IM).GT.NMXHEP) CALL HWWARN('HWDHVY',100,*999)
10712       IF (IDKPRD(4,IM).NE.0) THEN
10713 C Weak decay of meson or baryon
10714 C Idenitify decaying heavy quark and spectator
10715         ID=IDHW(IHEP)
10716         IF (ID.EQ.136.OR.ID.EQ.140.OR.ID.EQ.144.OR.
10717      &      ID.EQ.150.OR.ID.EQ.155.OR.ID.EQ.158.OR.ID.EQ.161.OR.
10718      &     (ID.EQ.254.AND.IDKPRD(4,IM).EQ.11)) THEN
10719 C c hadron or c decay of B_c+
10720           IDQ=4
10721           IQ=NHEP+1
10722           IS=NHEP+2
10723         ELSEIF (ID.EQ.171.OR.ID.EQ.175.OR.ID.EQ.179.OR.
10724      &          ID.EQ.185.OR.ID.EQ.190.OR.ID.EQ.194.OR.ID.EQ.196.OR.
10725      &         (ID.EQ.230.AND.IDKPRD(4,IM).EQ.5)) THEN
10726 C cbar hadron or cbar decay of B_c-
10727           IDQ=10
10728           IS=NHEP+1
10729           IQ=NHEP+2
10730         ELSEIF ((ID.GE.221.AND.ID.LE.229).OR.
10731      &          (ID.EQ.230.AND.IDKPRD(4,IM).EQ.10)) THEN
10732 C b hadron or b decay of B_c-
10733           IDQ=5
10734           IQ=NHEP+1
10735           IS=NHEP+2
10736         ELSEIF ((ID.GE.245.AND.ID.LE.253).OR.
10737      &          (ID.EQ.254.AND.IDKPRD(4,IM).EQ.4)) THEN
10738 C bbar hadron or bbar decay of B_c+
10739           IDQ=11
10740           IS=NHEP+1
10741           IQ=NHEP+2
10742         ELSE
10743 C Decay not recognized
10744           CALL HWWARN('HWDHVY',101,*999)
10745         ENDIF
10746 C Label constituents
10747         IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWDHVY',102,*999)
10748         ISTHEP(IHEP)=199
10749         JDAHEP(1,IHEP)=NHEP+1
10750         JDAHEP(2,IHEP)=NHEP+2
10751         IDHW(IQ)=IDQ
10752         IDHW(IS)=IDKPRD(4,IM)
10753         IDHEP(IQ)=IDPDG(IDQ)
10754         IDHEP(IS)=IDPDG(IDKPRD(4,IM))
10755         ISTHEP(IQ)=155
10756         ISTHEP(IS)=115
10757         JMOHEP(1,IQ)=IHEP
10758         JMOHEP(2,IQ)=IS
10759         JDAHEP(1,IQ)=NHEP+3
10760         JDAHEP(2,IQ)=NHEP+5
10761         JMOHEP(1,IS)=IHEP
10762         JMOHEP(2,IS)=NHEP+5
10763         JDAHEP(1,IS)=0
10764         JDAHEP(2,IS)=NHEP+5
10765         NHEP=NHEP+2
10766 C and weak decay product jets
10767         DO 10 J=1,3
10768         NHEP=NHEP+1
10769         IDHW(NHEP)=IDKPRD(J,IM)
10770         IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
10771         ISTHEP(NHEP)=IST(J)
10772         JMOHEP(1,NHEP)=IQ
10773         JDAHEP(1,NHEP)=0
10774   10    PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
10775         JMOHEP(2,NHEP-2)=NHEP-1
10776         JDAHEP(2,NHEP-2)=NHEP-1
10777         JMOHEP(2,NHEP-1)=NHEP-2
10778         JDAHEP(2,NHEP-1)=NHEP-2
10779         JMOHEP(2,NHEP  )=IQ
10780         JDAHEP(2,NHEP  )=IQ
10781 C Share momenta in ratio of masses, preserving specator mass
10782         XS=RMASS(IDHW(IS))/PHEP(5,IHEP)
10783         XB=ONE-XS
10784         CALL HWVSCA(5,XB,PHEP(1,IHEP),PHEP(1,IQ))
10785         CALL HWVSCA(5,XS,PHEP(1,IHEP),PHEP(1,IS))
10786         IF (NME(IM).EQ.100) THEN
10787 C Generate decay momenta using full (V-A)*(V-A) matrix element
10788           EMWSQ=RMASS(198)**2
10789           GMWSQ=(RMASS(198)*GAMW)**2
10790           EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
10791   20      CALL HWDTHR(PHEP(1,IQ  ),PHEP(1,NHEP-1),
10792      &                PHEP(1,NHEP-2),PHEP(1,NHEP),HWDWWT)
10793           CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
10794           EMTST=(HWULDO(PW,PW)-EMWSQ)**2
10795           IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 20
10796         ELSEIF (NME(IM).EQ.200) THEN
10797 C Generate decay momenta using full
10798 C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
10799           GAMHPM=RMASS(206)/DKLTM(206)
10800 C sort tan(beta)
10801           IF((IQ.EQ.  2).OR.(IQ.EQ.  4).OR.
10802      &       (IQ.EQ.  6).OR.(IQ.EQ.  8).OR.
10803      &       (IQ.EQ. 10).OR.(IQ.EQ. 12).OR.
10804      &       (IQ.EQ.122).OR.(IQ.EQ.124).OR.
10805      &       (IQ.EQ.126).OR.(IQ.EQ.128).OR.
10806      &       (IQ.EQ.130).OR.(IQ.EQ.132))THEN
10807             TB=TANB
10808           ELSE
10809             TB=1./TANB
10810           END IF
10811           IF((IDKPRD(1,IM).EQ.  2).OR.(IDKPRD(1,IM).EQ.  4).OR.
10812      &       (IDKPRD(1,IM).EQ.  6).OR.(IDKPRD(1,IM).EQ.  8).OR.
10813      &       (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
10814      &       (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
10815      &       (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
10816      &       (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
10817             BT=TANB
10818           ELSE
10819             BT=1./TANB
10820           END IF
10821           IT1=IQ
10822           IB1=IDKPRD(3,IM)
10823           IT2=IDKPRD(1,IM)
10824           IB2=IDKPRD(2,IM)
10825           EMWSQ=RMASS(206)**2
10826           GMWSQ=(RMASS(206)*GAMHPM)**2
10827           EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
10828   25      CALL HWDTHR(PHEP(1,IQ  ),PHEP(1,NHEP),
10829      &                PHEP(1,NHEP-2),PHEP(1,NHEP-1),HWDHWT)
10830           CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
10831           EMTST=(HWULDO(PW,PW)-EMWSQ)**2
10832           IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 25
10833         ELSE
10834 C Use phase space
10835           CALL HWDTHR(PHEP(1,IQ  ),PHEP(1,NHEP-2),
10836      &                PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
10837           CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
10838         ENDIF
10839 C Set up production vertices
10840         CALL HWVZRO(4,VHEP(1,IQ))
10841         CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,IS))
10842         CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,NHEP))
10843         CALL HWUDKL(198,PW,VHEP(1,NHEP-2))
10844         CALL HWVSUM(4,VHEP(1,IQ),VHEP(1,NHEP-2),VHEP(1,NHEP-2))
10845         CALL HWVEQU(4,VHEP(1,NHEP-2),VHEP(1,NHEP-1))
10846         EMSCA=PHEP(5,IQ)
10847       ELSE
10848 C Quarkonium decay
10849 C Label products
10850         ISTHEP(IHEP)=199
10851         JDAHEP(1,IHEP)=NHEP+1
10852         DO 30 J=1,NPRODS(IM)
10853         NHEP=NHEP+1
10854         IDHW(NHEP)=IDKPRD(J,IM)
10855         IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
10856         ISTHEP(NHEP)=IST(J)
10857         JMOHEP(1,NHEP)=IHEP
10858         JDAHEP(1,NHEP)=0
10859         PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
10860   30    CALL HWVZRO(4,VHEP(1,NHEP))
10861         JDAHEP(2,IHEP)=NHEP
10862 C Establish colour connections and select momentum configuration
10863         IF (NPRODS(IM).EQ.3) THEN
10864           IF (IDKPRD(3,IM).EQ.13) THEN
10865 C 3-gluon decay
10866             JMOHEP(2,NHEP-2)=NHEP
10867             JMOHEP(2,NHEP-1)=NHEP-2
10868             JMOHEP(2,NHEP  )=NHEP-1
10869             JDAHEP(2,NHEP-2)=NHEP-1
10870             JDAHEP(2,NHEP-1)=NHEP
10871             JDAHEP(2,NHEP  )=NHEP-2
10872           ELSE
10873 C or 2-gluon + photon decay
10874             JMOHEP(2,NHEP-2)=NHEP-1
10875             JMOHEP(2,NHEP-1)=NHEP-2
10876             JMOHEP(2,NHEP  )=NHEP
10877             JDAHEP(2,NHEP-2)=NHEP-1
10878             JDAHEP(2,NHEP-1)=NHEP-2
10879             JDAHEP(2,NHEP  )=NHEP
10880           ENDIF
10881           IF (NME(IM).EQ.130) THEN
10882 C Use Ore & Powell orthopositronium matrix element
10883   40        CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
10884      &                               PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
10885             X1=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-2))/PHEP(5,IHEP)**2
10886             X2=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-1))/PHEP(5,IHEP)**2
10887             X3=TWO-X1-X2
10888             TEST=((X1*(ONE-X1))**2+(X2*(ONE-X2))**2+(X3*(ONE-X3))**2)
10889      &          /(X1*X2*X3)**2
10890             IF (TEST.LT.TWO*HWRGEN(0)) GOTO 40
10891           ELSE
10892 C Use phase space
10893             CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
10894      &                               PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
10895           ENDIF
10896         ELSE
10897 C Parapositronium 2-gluon or q-qbar decay
10898           JMOHEP(2,NHEP-1)=NHEP
10899           JMOHEP(2,NHEP  )=NHEP-1
10900           JDAHEP(2,NHEP-1)=NHEP
10901           JDAHEP(2,NHEP  )=NHEP-1
10902           CALL HWDTWO(PHEP(1,IHEP),PHEP(1,NHEP-1),
10903      &                             PHEP(1,NHEP),CMMOM(IM),TWO,.FALSE.)
10904         ENDIF
10905         EMSCA=PHEP(5,IHEP)
10906       ENDIF
10907 C Process this new hard scatter
10908       CALL HWVEQU(4,VTXQDK(1,I),VTXPIP)
10909       CALL HWBGEN
10910       CALL HWCFOR
10911       CALL HWCDEC
10912       CALL HWDHAD
10913   100 CONTINUE
10914       NQDK=0
10915   999 END
10916 CDECK  ID>, HWDRCL.
10917 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
10918 *-- Author :    Peter Richardson
10919 C-----------------------------------------------------------------------
10920       SUBROUTINE HWDRCL(IHEP,MHEP,CLSAVE)
10921 C-----------------------------------------------------------------------
10922 C     Sets the colour connections in Baryon number violating decays
10923 C-----------------------------------------------------------------------
10924       INCLUDE 'HERWIG65.INC'
10925       INTEGER IHEP,MHEP,ID,ID2,IDM2,IDM3,COLCON(2,2,3),FLACON(2,3),JHEP,
10926      &        DECAY,COLANT,KHEP,IDM,IDMB,IDMB2,IDMB3,IDMB4,QHEP,IDM4,
10927      &        CLSAVE(2),XHEP,I,HWRINT,THEP
10928       LOGICAL CONBV
10929 C--Colour connections for the decays
10930       DATA COLCON/-1,1,-1,-2,-2,1,-3,-1,-1,1,-2,-1/
10931       DATA FLACON/1,-1,1,-1,-1,0/
10932 C--identify the decay
10933       IF(IERROR.NE.0) RETURN
10934       ID = IDHW(IHEP)
10935       ID2 = IDHW(MHEP)
10936       IF(ID.GE.450.AND.ID.LE.457) THEN
10937         DECAY = 1
10938       ELSEIF(ID.EQ.449) THEN
10939         DECAY = 2
10940       ELSEIF((ID.GE.411.AND.ID.LE.424).OR.ID.EQ.405.OR.ID.EQ.406) THEN
10941         DECAY = 3
10942       ELSE
10943 C--UNKNOWN DECAY
10944         CALL HWWARN('HWDRCL',100,*999)
10945       ENDIF
10946       COLANT = 1
10947 C--identify the colour partner
10948       IF(DECAY.GT.1.AND.ID2.LE.6) THEN
10949 C--colour partner
10950         COLANT = 2
10951         KHEP = JDAHEP(2,IHEP-1)
10952       ELSEIF(DECAY.GT.1.AND.ID2.GE.7) THEN
10953 C--anticolour partner
10954         COLANT = 3
10955         KHEP = JMOHEP(2,IHEP)
10956       ELSE
10957         KHEP=IHEP
10958       ENDIF
10959       IDM   = IDHW(JMOHEP(1,KHEP))
10960       IF(ABS(IDPDG(IDM)).GT.1000000.OR.IDM.EQ.15) THEN
10961         IDM2  = IDHW(JDAHEP(1,JMOHEP(1,KHEP)))
10962         IDM3  = IDHW(JDAHEP(2,JMOHEP(1,KHEP)))
10963         IDM4  = IDHW(JDAHEP(2,JMOHEP(1,KHEP))-1)
10964         QHEP  = JMOHEP(1,KHEP)
10965         IDMB  = IDHW(JMOHEP(1,QHEP))
10966         IDMB2 = IDHW(JMOHEP(2,QHEP))
10967         IDMB3 = IDHW(JDAHEP(1,QHEP))
10968         IDMB4 = IDHW(JDAHEP(2,QHEP))
10969       ENDIF
10970 C--Now decide if the colour partner decayed via BV
10971       IF(COLANT.EQ.2.AND.((((IDM.GE.413.AND.IDM.LE.418).OR.
10972      &                     IDM.EQ.449.OR.IDM.EQ.405.OR.IDM.EQ.406).AND.
10973      &                       (IDM2.GE.7.AND.IDM2.LE.12.AND.
10974      &                       IDM3.GE.7.AND.IDM3.LE.12.AND.
10975      &                       IDM4.GE.7.AND.IDM4.LE.12)).OR.
10976      &             (IDM.EQ.15.AND.IDMB.LE.6.AND.IDMB2.LE.6.AND.
10977      &              ((IDMB3.GE.7.AND.IDMB4.GE.12.AND.IDMB4.EQ.449).OR.
10978      &               (IDMB3.GE.198.AND.IDMB3.LE.207.AND.
10979      &                ABS(IDPDG(IDMB4)).GT.1000000))))) THEN
10980         CONBV = .TRUE.
10981         COLUPD = .TRUE.
10982         HVFCEN = .FALSE.
10983         XHEP = JMOHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
10984       ELSEIF(COLANT.EQ.3.AND.((((IDM.GE.419.AND.IDM.LE.424).OR.
10985      &                   IDM.EQ.449.OR.IDM.EQ.411.OR.IDM.EQ.412).AND.
10986      &                    (IDM2.LE.6.AND.IDM3.LE.6.AND.IDM4.LE.6)).OR.
10987      &               (IDM.EQ.15.AND.IDMB.GE.7.AND.IDMB.LE.12.AND.
10988      &                IDMB2.GE.7.AND.IDMB2.LE.12.AND.((IDMB3.LE.6.AND.
10989      &                IDMB4.EQ.449).OR.(ABS(IDPDG(IDMB4)).GT.1000000
10990      &                .AND.IDMB3.GE.198.AND.IDMB3.LE.207))))) THEN
10991         CONBV = .TRUE.
10992         COLUPD = .TRUE.
10993         HVFCEN = .FALSE.
10994         XHEP = JDAHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
10995       ELSE
10996         CONBV = .FALSE.
10997         COLUPD = .FALSE.
10998         XHEP = 0
10999       ENDIF
11000       IF(CONBV) THEN
11001         IF(IDM.NE.15) THEN
11002           CLSAVE(1) = JDAHEP(2,JMOHEP(1,KHEP))-1
11003           CLSAVE(2) = CLSAVE(1)+1
11004         ELSE
11005           IF(IDMB4.EQ.449) THEN
11006             DO I=1,2
11007               CLSAVE(I) = JMOHEP(I,JMOHEP(1,KHEP))
11008               IF(CLSAVE(I).EQ.XHEP) CLSAVE(I)=JDAHEP(1,JMOHEP(1,KHEP))
11009             ENDDO
11010           ELSE
11011             CLSAVE(1) = JMOHEP(1,JMOHEP(1,KHEP))
11012             CLSAVE(2) = JMOHEP(2,JMOHEP(1,KHEP))
11013           ENDIF
11014         ENDIF
11015       ELSE
11016         CLSAVE(1)=0
11017         CLSAVE(2)=0
11018       ENDIF
11019 C--Now set the colours for angular ordering
11020       THEP = MHEP-1
11021       IF(DECAY.EQ.1) THEN
11022         IF(ID2.LE.6) THEN
11023           JMOHEP(2,THEP) = THEP+HWRINT(1,2)
11024           JDAHEP(2,THEP) = THEP
11025         ELSE
11026           JMOHEP(2,THEP) = THEP
11027           JDAHEP(2,THEP) = THEP+HWRINT(1,2)
11028         ENDIF
11029       ELSEIF(DECAY.EQ.2) THEN
11030         IF(ID2.LE.6) THEN
11031           JMOHEP(2,THEP) = IHEP
11032           JDAHEP(2,THEP) = THEP
11033         ELSE
11034           JMOHEP(2,THEP) = THEP
11035           JDAHEP(2,THEP) = IHEP
11036         ENDIF
11037       ENDIF
11038 C--Colour of the second two
11039       DO JHEP=1,2
11040         IF(ID2.LE.6) THEN
11041           JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
11042      &                           COLCON(HWRINT(1,2),JHEP,DECAY)
11043           JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
11044         ELSE
11045           JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
11046      &                           COLCON(HWRINT(1,2),JHEP,DECAY)
11047           JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
11048         ENDIF
11049       ENDDO
11050 C--Now set the colours of the colour partner
11051       IF(DECAY.GT.1.AND..NOT.CONBV) THEN
11052         IF(ID2.LE.6) JMOHEP(2,KHEP) = MHEP+HWRINT(0,1)
11053         IF(ID2.GE.7) JDAHEP(2,KHEP) = MHEP+HWRINT(0,1)
11054       ELSEIF(CONBV) THEN
11055         IF(ID2.GT.6) THEN
11056           JMOHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
11057           IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
11058             JMOHEP(2,CLSAVE(2)) = MHEP+1
11059           ELSE
11060             JMOHEP(2,CLSAVE(2)) = MHEP
11061           ENDIF
11062         ELSE
11063           JDAHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
11064           IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
11065             JDAHEP(2,CLSAVE(2)) = MHEP+1
11066           ELSE
11067             JDAHEP(2,CLSAVE(2)) = MHEP
11068           ENDIF
11069         ENDIF
11070       ENDIF
11071  999  END
11072 CDECK  ID>, HWDRME.
11073 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
11074 *-- Author :    Peter Richardson
11075 C-----------------------------------------------------------------------
11076       SUBROUTINE HWDRME(LHEP,MHEP)
11077 C-----------------------------------------------------------------------
11078 C     SUBROUTINE TO IMPLEMENT ALL RPARITY DECAY MATRIX ELEMENTS
11079 C-----------------------------------------------------------------------
11080       INCLUDE 'HERWIG65.INC'
11081       DOUBLE PRECISION SM(6),SW(6),HWULDO,INFCOL,AM, M12SQ,M23SQ,MSGN,
11082      &                 M13SQ,A(6),B(6),SWEAK,MW,DECMOM(5),TEST(3),EPS,
11083      &                 M12SQT(6),M23SQT(6),M13SQT(6),LIMIT,M(4),RAND,
11084      &                 MC(2),MX2(6),MX(6),HWDPWT,HWRGEN,HWDRM1,LAMD(3),
11085      &                 TEST2
11086       EXTERNAL         HWDRM1,HWULDO,HWDPWT,HWRGEN
11087       INTEGER K,SN(3),LHEP,CSP,I,SB(3),J,ND,LTRY,MHEP,NSP,ID(3),IG,
11088      &        IDHWTP,IDHPTP,MTRY
11089       PARAMETER(EPS=1D-20)
11090       IF(IERROR.NE.0) RETURN
11091 C--Electroweak parameters, etc
11092       SWEAK = SQRT(SWEIN)
11093       MW    = RMASS(198)
11094       M(4)  = PHEP(5,LHEP)
11095       IG    = IDHW(LHEP)
11096 C--Find the masses of the final state and zero parameters
11097       DO K=1,3
11098         ID(K) = IDHW(MHEP+K-1)
11099         IF(ID(K).LE.12) THEN
11100           SN(K)=ID(K)
11101         ELSE
11102           SN(K)=ID(K)-120
11103         ENDIF
11104         IF(SN(K).GT.6) SN(K)=SN(K)-6
11105         M(K) = PHEP(5,LHEP+K)
11106         SB(K)=SN(K)
11107         LAMD(K) = ZERO
11108       ENDDO
11109       DO J=1,6
11110         MX2(J) = ZERO
11111         MX(J)  = ZERO
11112         M13SQT(J) = ZERO
11113         M23SQT(J) = ZERO
11114         M12SQT(J) = ZERO
11115       ENDDO
11116 C--Evaluate the coefficents for the mode we want
11117       IF(IG.GE.450.AND.IG.LE.453) THEN
11118 C--NEUTRALINO
11119         NSP = IG-449
11120         AM = RMASS(IG)
11121         MSGN = ZSGNSS(NSP)
11122         MC(1) =  ZMIXSS(NSP,3)/(2*MW*COSB*SWEAK)
11123         MC(2) =  ZMIXSS(NSP,4)/(2*MW*SINB*SWEAK)
11124 C--Calculate the combinations of couplings needed
11125         IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11126 C--first for the UDD modes
11127           DO J=1,2
11128             A(J) = M(1)*MC(2)*QMIXSS(SN(1),2,J)
11129      &             +SLFCH(SN(1),NSP)*QMIXSS(SN(1),1,J)
11130             B(J) = MSGN*(M(1)*MC(2)*QMIXSS(SN(1),1,J)
11131      &             +SRFCH(SN(1),NSP)*QMIXSS(SN(1),2,J))
11132             MX2(J) = QMIXSS(SN(1),2,J)
11133             A(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
11134      &               +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11135             B(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
11136      &               +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11137             MX2(J+2) = QMIXSS(SN(2),2,J)
11138             A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11139      &              +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11140             B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11141      &              +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11142             MX2(J+2) = QMIXSS(SN(3),2,J)
11143           ENDDO
11144           DO K=1,3
11145             SN(K) = SN(K)+400
11146             SB(K) = SB(K)+412
11147           ENDDO
11148         ELSEIF(ID(1).GE.121.AND.ID(2).GE.121.AND.ID(3).GE.121) THEN
11149 C--Now for the LLE modes
11150           DO J=1,2
11151             A(J)  = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
11152      &              +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
11153             B(J)  = M(1)*MC(1)*LMIXSS(SN(1),2,J)
11154      &              +SLFCH(10+SN(1),NSP)*LMIXSS(SN(2),1,J)
11155             MX2(J)= LMIXSS(SN(1),1,J)
11156             A(J+2) = ZERO
11157             B(J+2) = SLFCH(10+SN(2),NSP)*LMIXSS(SN(2),1,J)
11158             MX2(J+2) =  LMIXSS(SN(2),1,J)
11159             A(J+4) = M(3)*MC(1)*LMIXSS(SN(3),2,J)
11160      &      +SLFCH(10+SN(3),NSP)*LMIXSS(SN(3),1,J)
11161             B(J+4) = MSGN*(M(3)*MC(1)*LMIXSS(SN(3),1,J)
11162      &      +SRFCH(10+SN(3),NSP)*LMIXSS(SN(3),2,J))
11163             MX2(4+J) = LMIXSS(SN(3),2,J)
11164           ENDDO
11165           DO J=1,3
11166             SN(J) = SN(J) + 424
11167             SB(J) = SB(J) + 436
11168           ENDDO
11169         ELSE
11170 C--Now for both types of LQD modes
11171           IF(MOD(SN(1),2).EQ.0) THEN
11172 C--First the neutrino,down,antidown mode
11173             DO J=1,2
11174               A(J) = ZERO
11175               B(J) = SLFCH(10+SN(1),NSP)*
11176      &               LMIXSS(SN(1),1,J)
11177               MX2(J) = LMIXSS(SN(1),1,J)
11178               A(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
11179      &        +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11180               B(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
11181      &        +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11182               MX2(2+J) = QMIXSS(SN(2),1,J)
11183               A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11184      &        +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11185               B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11186      &        +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11187               MX2(J+4) = QMIXSS(SN(3),2,J)
11188             ENDDO
11189           ELSE
11190 C--Now the charged lepton, antiup,down modes
11191             DO J=1,2
11192               A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
11193      &        +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
11194               B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J)
11195      &        +SLFCH(10+SN(1),NSP)*LMIXSS(SN(1),1,J)
11196               MX2(J) = LMIXSS(SN(1),1,J)
11197               A(J+2) =MSGN*(M(2)*MC(2)*QMIXSS(SN(2),1,J)
11198      &        +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11199               B(J+2) = M(2)*MC(2)*QMIXSS(SN(2),2,J)
11200      &        +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11201               MX2(2+J) = QMIXSS(SN(2),1,J)
11202               A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11203      &        +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11204               B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11205      &        +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11206               MX2(J+4) = QMIXSS(SN(3),2,J)
11207             ENDDO
11208           ENDIF
11209           SN(1) = SN(1) + 424
11210           SB(1) = SB(1) + 436
11211           DO J=2,3
11212             SN(J) = SN(J) + 400
11213             SB(J) = SB(J) + 412
11214           ENDDO
11215         ENDIF
11216         DO K=1,3
11217           SM(2*K-1) = RMASS(SN(K))
11218           SM(2*K)   = RMASS(SB(K))
11219           SW(2*K-1) = HBAR/RLTIM(SN(K))
11220           SW(2*K)   = HBAR/RLTIM(SB(K))
11221         ENDDO
11222         ND = 3
11223         DO K=1,3
11224           LAMD(K) = ONE
11225         ENDDO
11226         INFCOL = ONE
11227       ELSEIF(IG.EQ.449) THEN
11228 C--GLUINO
11229 C--First obtian the masses and widths needed
11230         AM  = RMASS(IG)
11231         ND = 3
11232 C--Calculate the combinations of couplings needed
11233         IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11234 C--first for the UDD modes
11235           INFCOL = -0.5D0
11236 C--Couplings
11237           DO I=1,3
11238             DO J=1,2
11239               A(2*I-2+J)  = -QMIXSS(SN(I),1,J)
11240               B(2*I-2+J)  =  QMIXSS(SN(I),2,J)
11241               MX2(2*I-2+J) =  QMIXSS(SN(I),2,J)
11242             ENDDO
11243             SN(I) = SN(I)+400
11244             SB(I) = SB(I)+412
11245           ENDDO
11246         ELSE
11247           INFCOL = ONE
11248 C--Now for both types of LQD modes
11249           IF(MOD(SN(1),2).EQ.0) THEN
11250 C--First the neutrino,down,antidown mode
11251             DO J=1,2
11252               A(J)  = ZERO
11253               B(J)  = ZERO
11254               MX2(J) = ZERO
11255               A(J+2)   =  QMIXSS(SN(2),2,J)
11256               B(J+2)   = -QMIXSS(SN(2),1,J)
11257               MX2(J+2) =  QMIXSS(SN(2),1,J)
11258               A(J+4)   = -QMIXSS(SN(3),1,J)
11259               B(J+4)   =  QMIXSS(SN(3),2,J)
11260               MX2(4+J) =  QMIXSS(SN(3),2,J)
11261             ENDDO
11262           ELSEIF(MOD(SN(1),2).EQ.1) THEN
11263 C--Now the charged lepton, antiup,down modes
11264             DO J=1,2
11265               A(J)  = ZERO
11266               B(J)  = ZERO
11267               MX2(J) = ZERO
11268               A(J+2)   =  QMIXSS(SN(2),2,J)
11269               B(J+2)   = -QMIXSS(SN(2),1,J)
11270               MX2(J+2) =  QMIXSS(SN(2),1,J)
11271               A(J+4)     = -QMIXSS(SN(3),1,J)
11272               B(J+4)   =  QMIXSS(SN(3),2,J)
11273               MX2(J+4) =  QMIXSS(SN(3),2,J)
11274             ENDDO
11275           ENDIF
11276           SN(1) = SN(1) + 424
11277           SB(1) = SB(1) + 436
11278           DO K=2,3
11279             SN(K) = SN(K) + 400
11280             SB(K) = SB(K) + 412
11281           ENDDO
11282         ENDIF
11283         DO K=1,3
11284           SM(2*K-1) = RMASS(SN(K))
11285           SM(2*K)   = RMASS(SB(K))
11286           SW(2*K-1) = HBAR/RLTIM(SN(K))
11287           SW(2*K)   = HBAR/RLTIM(SB(K))
11288         ENDDO
11289         DO K=1,3
11290           LAMD(K) = ONE
11291         ENDDO
11292       ELSEIF(IG.GE.454.AND.IG.LE.457) THEN
11293 C--CHARGINO
11294         CSP = IG-453
11295         IF(CSP.GT.2) CSP = CSP-2
11296         AM  = RMASS(IG)
11297         INFCOL = -ONE
11298         MSGN = WSGNSS(CSP)
11299         MC(1) =  ONE/(SQRT(2.0D0)*MW*COSB)
11300         MC(2) =  ONE/(SQRT(2.0D0)*MW*SINB)
11301 C--Calculate the combinations of the couplings needed
11302         IF(ID(1).GT.120.AND.ID(2).GT.120.AND.ID(3).GT.120) THEN
11303 C--first for the LLE modes, three modes
11304           IF(MOD(SN(1),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
11305 C--the one diagram mode nubar,positron, nu
11306             DO J=1,2
11307               A(J+4) = LMIXSS(SN(3)-1,1,J)*WMXUSS(CSP,1)
11308      & -RMASS(SN(3)+119)*MC(1)*LMIXSS(SN(3)-1,2,J)*WMXUSS(CSP,2)
11309               B(J+4) = ZERO
11310               MX2(J+4) = LMIXSS(SN(3)-1,2,J)
11311             ENDDO
11312             ND = 1
11313             SN(3) = SN(3)+423
11314             SB(3) = SB(3)+435
11315           ELSEIF(MOD(SN(1),2).EQ.0.AND.MOD(SN(2),2).EQ.0) THEN
11316 C--the first two diagram mode nu, nu, positron
11317             DO J=1,2
11318               A(J)   = ZERO
11319               B(J)   = LMIXSS(SN(1)-1,1,J)*WMXUSS(CSP,1)
11320      & -RMASS(SN(1)+119)*MC(1)*LMIXSS(SN(1)-1,2,J)*WMXUSS(CSP,2)
11321               A(J+2) = ZERO
11322               B(J+2) = LMIXSS(SN(2)-1,1,J)*WMXUSS(CSP,1)
11323      & -RMASS(SN(2)+119)*MC(1)*LMIXSS(SN(2)-1,2,J)*WMXUSS(CSP,2)
11324               MX2(J)   = LMIXSS(SN(1)-1,1,J)
11325               MX2(J+2) = LMIXSS(SN(2)-1,1,J)
11326             ENDDO
11327             ND = 2
11328             DO J=1,2
11329               SN(J) = SN(J)+423
11330               SB(J) = SB(J)+435
11331             ENDDO
11332           ELSE
11333 C--the second two diagram mode positron, positron, electron
11334             DO J=1,2
11335               A(J)   = -M(1)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(1)+1,1,J)
11336               B(J)   = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(1)+1,1,J)
11337               A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(2)+1,1,J)
11338               B(J+2) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
11339               MX2(J)   = LMIXSS(SN(1)+1,1,J)
11340               MX2(J+2) = LMIXSS(SN(2)+1,1,J)
11341             ENDDO
11342             DO J=1,2
11343               SN(J) = SN(J)+425
11344               SB(J) = SB(J)+437
11345             ENDDO
11346             ND = 2
11347           ENDIF
11348           DO K=1,3
11349             LAMD(K) = ONE
11350           ENDDO
11351         ELSEIF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11352 C--now for the UDD
11353           IF(MOD(SN(1),2).EQ.0) THEN
11354 C--two diagram mode
11355             LAMD(1) = LAMDA3(SN(2)/2,SN(1)/2,(SN(3)+1)/2)
11356             LAMD(2) = LAMDA3(SN(1)/2,SN(2)/2,(SN(3)+1)/2)
11357             DO J=1,2
11358               A(J)   = WMXUSS(CSP,1)*QMIXSS(SN(1)-1,1,J)
11359      & -RMASS(SN(1)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(1)-1,2,J)
11360               B(J)   = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(1)-1,1,J)
11361               A(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
11362      & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
11363               B(J+2) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)-1,1,J)
11364               MX2(J)   = QMIXSS(SN(1)-1,2,J)
11365               MX2(J+2) = QMIXSS(SN(2)-1,2,J)
11366             ENDDO
11367             DO J=1,2
11368               SN(J) = SN(J) + 399
11369               SB(J) = SB(J) + 411
11370             ENDDO
11371             ND = 2
11372           ELSE
11373 C--three diagram mode
11374             LAMD(1) = LAMDA3((SN(1)+1)/2,(SN(2)+1)/2,(SN(3)+1)/2)
11375             LAMD(2) = LAMDA3((SN(2)+1)/2,(SN(1)+1)/2,(SN(3)+1)/2)
11376             LAMD(3) = LAMDA3((SN(3)+1)/2,(SN(2)+1)/2,(SN(1)+1)/2)
11377             DO I=1,3
11378               DO J=1,2
11379                 A(J+2*I-2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(I)+1,1,J)
11380      & -RMASS(SN(I)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(I)+1,2,J))
11381                 B(J+2*I-2) = -M(I)*MC(1)*WMXUSS(CSP,2)
11382      &                       *QMIXSS(SN(I)+1,1,J)
11383                 MX2(J+2*I-2)   = QMIXSS(SN(I)+1,2,J)
11384               ENDDO
11385               SN(I) = SN(I) + 401
11386               SB(I) = SB(I) + 413
11387             ENDDO
11388             ND = 3
11389           ENDIF
11390         ELSE
11391 C--now for the LQD modes
11392           IF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.0) THEN
11393 C--first one diagram mode nubar, dbar, up
11394             DO J=1,2
11395               A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
11396      &                  QMIXSS(SN(3)-1,1,J)
11397               B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
11398      &        -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
11399               MX2(J+4)   = QMIXSS(SN(3)-1,2,J)
11400             ENDDO
11401             SN(3) = SN(3) + 399
11402             SB(3) = SB(3) + 411
11403             ND = 1
11404           ELSEIF(MOD(SN(2),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
11405 C--second one diagram mode positron, ubar, up
11406             DO J=1,2
11407               A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
11408      &                  QMIXSS(SN(3)-1,1,J)
11409               B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
11410      &   -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
11411               MX2(J+4)   = QMIXSS(SN(3)-1,2,J)
11412             ENDDO
11413             SN(3) = SN(3) + 399
11414             SB(3) = SB(3) + 411
11415             ND = 1
11416           ELSEIF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.1) THEN
11417 C--first two diagram mode positron, dbar, down
11418             DO J=1,2
11419               A(J)   = -M(1)*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)+1,1,J)
11420               B(J)   = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
11421               A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*QMIXSS(SN(2)+1,1,J)
11422               B(J+2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(2)+1,1,J)
11423      &   -RMASS(SN(2)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)+1,2,J))
11424               MX2(J)   = LMIXSS(SN(1)+1,1,J)
11425               MX2(J+2) = QMIXSS(SN(2)+1,1,J)
11426             ENDDO
11427             SN(1) = SN(1) + 425
11428             SB(1) = SB(1) + 437
11429             SN(2) = SN(2) + 401
11430             SB(2) = SB(2) + 413
11431             ND = 2
11432           ELSE
11433 C--second two diagram mode nu, up, dbar
11434             DO J=1,2
11435               A(J)   = ZERO
11436               B(J)   = WMXUSS(CSP,1)*LMIXSS(SN(1)-1,1,J)
11437      &   -RMASS(119+SN(1))*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)-1,2,J)
11438               A(J+2) = -MSGN*M(2)*MC(2)*WMXVSS(CSP,2)*
11439      &                 QMIXSS(SN(2)-1,1,J)
11440               B(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
11441      &   -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
11442               MX2(J)   = LMIXSS(SN(1)-1,1,J)
11443               MX2(J+2) = QMIXSS(SN(2)-1,1,J)
11444             ENDDO
11445             SN(1) = SN(1) + 423
11446             SB(1) = SB(1) + 435
11447             SN(2) = SN(2) + 399
11448             SB(2) = SB(2) + 411
11449             ND = 2
11450           ENDIF
11451           DO K=1,3
11452             LAMD(K) = ONE
11453           ENDDO
11454         ENDIF
11455         IF(ND.EQ.1) THEN
11456           DO K=1,2
11457             SM(2*K-1) = 0.0D0
11458             SM(2*K)   = 0.0D0
11459             SW(2*K-1) = 0.0D0
11460             SW(2*K)   = 0.0D0
11461           ENDDO
11462           SM(5) = RMASS(SN(3))
11463           SM(6)   = RMASS(SB(3))
11464           SW(5) = HBAR/RLTIM(SN(3))
11465           SW(6)   = HBAR/RLTIM(SB(3))
11466         ELSE
11467           DO K=1,2
11468             SM(2*K-1) = RMASS(SN(K))
11469             SM(2*K)   = RMASS(SB(K))
11470             SW(2*K-1) = HBAR/RLTIM(SN(K))
11471             SW(2*K)   = HBAR/RLTIM(SB(K))
11472             SM(4+K)   = ZERO
11473             SW(4+K)   = ZERO
11474           ENDDO
11475         ENDIF
11476       ELSE
11477 C--UNKNOWN
11478         CALL HWWARN('HWDRME',500,*999)
11479       ENDIF
11480 C--Set mixing to zero if diagram not available
11481       IF((AM.LT.(ABS(SM(1))+M(1)).OR.ABS(SM(1)).LT.(M(2)+M(3)))
11482      &   .AND.ABS(MX2(1)).GT.ZERO.AND.ND.NE.1) MX(1) = MX2(1)*LAMD(1)
11483         IF((AM.LT.(ABS(SM(2))+M(1)).OR.ABS(SM(2)).LT.(M(2)+M(3)))
11484      &   .AND.ABS(MX2(2)).GT.ZERO.AND.ND.NE.1) MX(2) = MX2(2)*LAMD(1)
11485         IF((AM.LT.(ABS(SM(3))+M(2)).OR.ABS(SM(3)).LT.(M(1)+M(3)))
11486      &   .AND.ABS(MX2(3)).GT.ZERO.AND.ND.NE.1) MX(3) = MX2(3)*LAMD(2)
11487         IF((AM.LT.(ABS(SM(4))+M(2)).OR.ABS(SM(4)).LT.(M(1)+M(3)))
11488      &   .AND.ABS(MX2(4)).GT.ZERO.AND.ND.NE.1) MX(4) = MX2(4)*LAMD(2)
11489         IF((AM.LT.(ABS(SM(5))+M(3)).OR.ABS(SM(5)).LT.(M(1)+M(2)))
11490      &   .AND.ABS(MX2(5)).GT.ZERO.AND.ND.NE.2) MX(5) = MX2(5)*LAMD(3)
11491         IF((AM.LT.(ABS(SM(6))+M(3)).OR.ABS(SM(6)).LT.(M(1)+M(2)))
11492      &   .AND.ABS(MX2(6)).GT.ZERO.AND.ND.NE.2) MX(6) = MX2(6)*LAMD(3)
11493 C--Calculate the limiting points
11494       DO J=1,2
11495         IF(ND.NE.1) THEN
11496           IF(ABS(MX(J)).GT.EPS) CALL HWDRM5(M23SQT(J),M13SQT(J),
11497      &      M12SQT(J),A(J),B(J),M(2),M(3),M(1),M(4),SM(J),SW(J))
11498           IF(ABS(MX(J+2)).GT.EPS) CALL HWDRM5(M13SQT(2+J),M23SQT(2+J),
11499      &    M12SQT(2+J),A(2+J),B(2+J),M(1),M(3),M(2),M(4),SM(2+J),SW(2+J))
11500         ENDIF
11501         IF(ND.NE.2) THEN
11502           IF(ABS(MX(J+4)).GT.EPS) CALL HWDRM5(M12SQT(4+J),M23SQT(4+J),
11503      &    M13SQT(4+J),A(4+J),B(4+J),M(1),M(2),M(3),M(4),SM(4+J),SW(4+J))
11504         ENDIF
11505       ENDDO
11506 C--Now evaluate the limit using these points
11507       LIMIT = ZERO
11508       DO 100 I=1,6
11509         IF(ABS(MX(I)).LT.EPS) GOTO 100
11510         LIMIT = LIMIT+HWDRM1(TEST,M12SQT(I),M13SQT(I),M23SQT(I),A,B,MX,
11511      &                       M,SM,SW,INFCOL,AM,0,ND)
11512  100  CONTINUE
11513       LIMIT = TWO*LIMIT
11514 C--Now evaluate at a random point
11515       MTRY = 0
11516  25   MTRY = MTRY+1
11517       LTRY = 0
11518  35   LTRY = LTRY+1
11519       CALL HWDTHR(PHEP(1,LHEP),PHEP(1,MHEP),
11520      &                  PHEP(1,MHEP+1),PHEP(1,MHEP+2),HWDPWT)
11521 C--Now calculate the m12sq etc for the actual point
11522       M12SQ = M(1)**2+M(2)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+1))
11523       M13SQ = M(1)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+2))
11524       M23SQ = M(2)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP+1),PHEP(1,MHEP+2))
11525 C--Now calulate the matrix element
11526       TEST2 = HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,
11527      &                       M,SM,SW,INFCOL,AM,1,ND)
11528 C--Now test the value againest the limit
11529       RAND = HWRGEN(0)*LIMIT
11530       IF(TEST2.GT.LIMIT) THEN
11531         LIMIT = 1.1D0*TEST2
11532         CALL HWWARN('HWDRME',51,*150)
11533       ENDIF
11534  150  IF(TEST2.LT.RAND.AND.LTRY.LT.NETRY) THEN
11535         GOTO 35
11536       ELSEIF(LTRY.GE.NETRY) THEN
11537         IF(MTRY.LE.NETRY) THEN
11538           LIMIT = LIMIT*0.9D0
11539           CALL HWWARN('HWDRME',52,*25)
11540         ELSE
11541           CALL HWWARN('HWDRME',100,*999)
11542         ENDIF
11543       ENDIF
11544 C--Reorder the particles in gluino decay to get angular ordering right
11545       IF(IG.EQ.449.AND.ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11546         DO LTRY=1,3
11547           IF(TEST(LTRY).GT.RAND) THEN
11548             IF(LTRY.EQ.2) THEN
11549               IDHWTP        = IDHW(MHEP)
11550               IDHW(MHEP)    = IDHW(MHEP+1)
11551               IDHW(MHEP+1)  = IDHWTP
11552               IDHPTP        = IDHEP(MHEP)
11553               IDHEP(MHEP)   = IDHEP(MHEP+1)
11554               IDHEP(MHEP+1) = IDHPTP
11555               CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
11556               CALL HWVEQU(5,PHEP(1,MHEP+1),PHEP(1,MHEP))
11557               CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+1))
11558             ELSEIF(LTRY.EQ.3) THEN
11559               IDHWTP        = IDHW(MHEP)
11560               IDHW(MHEP)    = IDHW(MHEP+2)
11561               IDHW(MHEP+2)    = IDHWTP
11562               IDHPTP        = IDHEP(MHEP)
11563               IDHEP(MHEP)   = IDHEP(MHEP+2)
11564               IDHEP(MHEP+2)   = IDHPTP
11565               DO I=1,5
11566               CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
11567               CALL HWVEQU(5,PHEP(1,MHEP+2),PHEP(1,MHEP))
11568               CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+2))
11569               ENDDO
11570             ENDIF
11571             GOTO 52
11572           ENDIF
11573           RAND=RAND-TEST(LTRY)
11574         ENDDO
11575       ENDIF
11576  52   CONTINUE
11577  999  END
11578 CDECK  ID>, HWDRM1.
11579 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
11580 *-- Author :    Peter Richardson
11581 C-----------------------------------------------------------------------
11582       FUNCTION HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,M,SM,SW
11583      &                ,INFCOL,AM,LM,ND)
11584 C-----------------------------------------------------------------------
11585 C     FUNCTION TO GIVE THE R-PARITY VIOLATING MATRIX ELEMENT AT A GIVEN
11586 C     PHASE-SPACE POINT
11587 C-----------------------------------------------------------------------
11588       IMPLICIT NONE
11589       DOUBLE PRECISION M12SQ,M13SQ,M23SQ,MX(6),A(6),B(6),SM(6),SW(6),
11590      &                 INFCOL,AM,TERM(21),TEST(3),PLN,NPLN,ZERO,
11591      &                 M(4),HWDRM1,HWDRM2,HWDRM3,HWDRM4
11592       PARAMETER (ZERO=0)
11593       EXTERNAL HWDRM2,HWDRM3,HWDRM4
11594       INTEGER LM,K,ND
11595 C--Zero the array
11596         DO K=1,21
11597           TERM(K) = 0.0D0
11598         ENDDO
11599         HWDRM1 = 0.0D0
11600 C--The amplitude
11601       IF(ABS(MX(1)).GT.ZERO.AND.ND.NE.1) THEN
11602         TERM(1) = MX(1)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(1),
11603      &            SW(1),A(1),B(1))
11604         IF(ABS(MX(2)).GT.ZERO) TERM(7)= MX(1)*MX(2)*HWDRM3(M23SQ,M(2),
11605      &   M(3),M(1),M(4),SM(1),SM(2),SW(1),SW(2),A(1),A(2),B(1),B(2))
11606         IF(ABS(MX(3)).GT.ZERO) TERM(10)=-MX(1)*MX(3)*HWDRM4(M13SQ,M23SQ,
11607      &  M(1),M(3),M(2),M(4),SM(3),SM(1),SW(3),SW(1),A(1),A(3),B(1),B(3))
11608         IF(ABS(MX(4)).GT.ZERO) TERM(11)=-MX(1)*MX(4)*HWDRM4(M13SQ,M23SQ,
11609      &  M(1),M(3),M(2),M(4),SM(4),SM(1),SW(4),SW(1),A(1),A(4),B(1),B(4))
11610         IF(ABS(MX(5)).GT.ZERO) TERM(12)=-MX(1)*MX(5)*HWDRM4(M23SQ,M12SQ,
11611      &  M(3),M(2),M(1),M(4),SM(1),SM(5),SW(1),SW(5),A(5),A(1),B(5),B(1))
11612         IF(ABS(MX(6)).GT.ZERO) TERM(13)=-MX(1)*MX(6)*HWDRM4(M23SQ,M12SQ,
11613      &  M(3),M(2),M(1),M(4),SM(1),SM(6),SW(1),SW(6),A(6),A(1),B(6),B(1))
11614       ENDIF
11615       IF(ABS(MX(2)).GT.ZERO.AND.ND.NE.1) THEN
11616         TERM(2) = MX(2)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(2),
11617      &            SW(2),A(2),B(2))
11618         IF(ABS(MX(3)).GT.ZERO) TERM(14)=-MX(2)*MX(3)*HWDRM4(M13SQ,M23SQ,
11619      &  M(1),M(3),M(2),M(4),SM(3),SM(2),SW(3),SW(2),A(2),A(3),B(2),B(3))
11620         IF(ABS(MX(4)).GT.ZERO) TERM(15)=-MX(2)*MX(4)*HWDRM4(M13SQ,M23SQ,
11621      &  M(1),M(3),M(2),M(4),SM(4),SM(2),SW(4),SW(2),A(2),A(4),B(2),B(4))
11622         IF(ABS(MX(5)).GT.ZERO) TERM(16)=-MX(2)*MX(5)*HWDRM4(M23SQ,M12SQ,
11623      &  M(3),M(2),M(1),M(4),SM(2),SM(5),SW(2),SW(5),A(5),A(2),B(5),B(2))
11624         IF(ABS(MX(6)).GT.ZERO) TERM(17)=-MX(2)*MX(6)*HWDRM4(M23SQ,M12SQ,
11625      &  M(3),M(2),M(1),M(4),SM(2),SM(6),SW(2),SW(6),A(6),A(2),B(6),B(2))
11626       ENDIF
11627       IF(ABS(MX(3)).GT.ZERO.AND.ND.NE.1) THEN
11628         TERM(3) = MX(3)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(3),
11629      &            SW(3),A(3),B(3))
11630         IF(ABS(MX(4)).GT.ZERO) TERM(8)= MX(3)*MX(4)*HWDRM3(M13SQ,M(1),
11631      &   M(3),M(2),M(4),SM(3),SM(4),SW(3),SW(4),A(3),A(4),B(3),B(4))
11632         IF(ABS(MX(5)).GT.ZERO) TERM(18)=-MX(3)*MX(5)*HWDRM4(M12SQ,M13SQ,
11633      &  M(2),M(1),M(3),M(4),SM(5),SM(3),SW(5),SW(3),A(3),A(5),B(3),B(5))
11634         IF(ABS(MX(6)).GT.ZERO) TERM(19)=-MX(3)*MX(6)*HWDRM4(M12SQ,M13SQ,
11635      &  M(2),M(1),M(3),M(4),SM(6),SM(3),SW(6),SW(3),A(3),A(6),B(3),B(6))
11636       ENDIF
11637       IF(ABS(MX(4)).GT.ZERO.AND.ND.NE.1) THEN
11638         TERM(4) = MX(4)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(4),
11639      &            SW(4),A(4),B(4))
11640         IF(ABS(MX(5)).GT.ZERO) TERM(20)=-MX(4)*MX(5)*HWDRM4(M12SQ,M13SQ,
11641      &  M(2),M(1),M(3),M(4),SM(5),SM(4),SW(5),SW(4),A(4),A(5),B(4),B(5))
11642         IF(ABS(MX(6)).GT.ZERO) TERM(21)=-MX(4)*MX(6)*HWDRM4(M12SQ,M13SQ,
11643      &  M(2),M(1),M(3),M(4),SM(6),SM(4),SW(6),SW(4),A(4),A(6),B(4),B(6))
11644       ENDIF
11645       IF(ABS(MX(5)).GT.ZERO.AND.ND.NE.2) THEN
11646         TERM(5) = MX(5)**2*HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(5),
11647      &            SW(5),A(5),B(5))
11648         IF(ABS(MX(6)).GT.ZERO) TERM(9)= MX(5)*MX(6)*HWDRM3(M12SQ,M(1),
11649      &     M(2),M(3),M(4),SM(5),SM(6),SW(5),SW(6),A(5),A(6),B(5),B(6))
11650       ENDIF
11651       IF(ABS(MX(6)).GT.ZERO.AND.ND.NE.2) TERM(6) = MX(6)**2*
11652      &    HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(6),SW(6),A(6),B(6))
11653       DO K=10,21
11654         TERM(K)=TERM(K)*INFCOL
11655       ENDDO
11656 C--Add them up
11657       DO K=1,21
11658         HWDRM1 = HWDRM1+TERM(K)
11659       ENDDO
11660 C--Different colour flows for the gluino
11661       IF(LM.NE.0) THEN
11662         NPLN = 0.0D0
11663         PLN = 0.0D0
11664         DO K=1,9
11665           PLN = PLN+TERM(K)
11666         ENDDO
11667         DO K=10,21
11668           NPLN= NPLN+TERM(K)
11669         ENDDO
11670         DO K=1,3
11671           TEST(K) = (TERM(2*K-1)+TERM(2*K)+TERM(6+K))*(1+NPLN/PLN)
11672         ENDDO
11673       ELSE
11674         DO K=1,3
11675           TEST(K) = 0.0D0
11676         ENDDO
11677       ENDIF
11678       IF(HWDRM1.LT.ZERO) CALL HWWARN('HWDRM1',50,*999)
11679  999  END
11680 CDECK  ID>, HWDRM2.
11681 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
11682 *-- Author :    Peter Richardson
11683 C-----------------------------------------------------------------------
11684       FUNCTION HWDRM2(X,MA,MB,MC,MD,MR1,GAM1,A,B)
11685 C-----------------------------------------------------------------------
11686 C     Function to compute the matrix element squared part of a 3-body
11687 C     R-parity decay
11688 C-----------------------------------------------------------------------
11689       IMPLICIT NONE
11690       DOUBLE PRECISION X,MA,MB,MC,MD,A,B,HWDRM2,MR1,GAM1
11691       HWDRM2  = (X - MA**2 - MB**2)*(4*A*B*MC*MD +
11692      &    (A**2 + B**2)*(-X + MC**2 + MD**2))/
11693      &     ((X-MR1**2)**2+GAM1**2*MR1**2)
11694       END
11695 CDECK  ID>, HWDRM3.
11696 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
11697 *-- Author :    Peter Richardson
11698 C-----------------------------------------------------------------------
11699       FUNCTION HWDRM3(X,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
11700 C-----------------------------------------------------------------------
11701 C     Function to compute the light/heavy interference part of a 3-body
11702 C     R-parity decay
11703 C-----------------------------------------------------------------------
11704       IMPLICIT NONE
11705       DOUBLE PRECISION X,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM3,MR1,MR2,GAM1
11706      &                 ,GAM2
11707 C
11708       HWDRM3  = 2*(X - MA**2 - MB**2)*(2*(A2*B1 + A1*B2)*MC*MD +
11709      &    (A1*A2 + B1*B2)*(-X + MC**2 + MD**2))*
11710      &  (GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(X - MR2**2))/
11711      &  (((X-MR1**2)**2+GAM1**2*MR1**2)*((X-MR2**2)**2+GAM2**2*MR2**2))
11712       END
11713 CDECK  ID>, HWDRM4.
11714 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
11715 *-- Author :    Peter Richardson
11716 C-----------------------------------------------------------------------
11717       FUNCTION HWDRM4(X,Y,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
11718 C-----------------------------------------------------------------------
11719 C     Function to compute the interference part of a 3-body
11720 C     R-parity decay
11721 C-----------------------------------------------------------------------
11722       IMPLICIT NONE
11723       DOUBLE PRECISION X,Y,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM4,MR1,MR2,GAM1
11724      &                 ,GAM2
11725 C
11726       HWDRM4  = 2*((GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(Y - MR2**2))*
11727      &    (A2*B1*MC*MD*(X - MA**2 - MB**2) +
11728      &      A1*A2*MA*MC*(X + Y - MA**2 - MC**2) +
11729      &      A1*B2*MA*MD*(Y - MB**2 - MC**2) +
11730      &      B1*B2*(X*Y - MA**2*MC**2 - MB**2*MD**2)))/
11731      &  (((X-MR1**2)**2+GAM1**2*MR1**2)*((Y-MR2**2)**2+GAM2**2*MR2**2))
11732       END
11733 CDECK  ID>, HWDRM5.
11734 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
11735 *-- Author :    Peter Richardson
11736 C-----------------------------------------------------------------------
11737       SUBROUTINE HWDRM5(X,Y,Z,A,B,MA,MB,MC,MD,MR,GAM)
11738 C-----------------------------------------------------------------------
11739 C     Subroutine to find the maximum of the ME
11740 C-----------------------------------------------------------------------
11741       IMPLICIT NONE
11742       DOUBLE PRECISION X,Y,Z,MA,MB,MC,MD,MR,GAM,RES(3),A,B,C,D,
11743      &                 E2S,E3S,E2M,E3M,LOW,UPP,HWRUNI,EPS,ZERO
11744       EXTERNAL HWRUNI
11745       PARAMETER(EPS=1D-9,ZERO=0)
11746       C = A**2+B**2
11747       D = 4*A*B
11748       RES(1) = -D*(MA**2 + MB**2)*MC*MD +
11749      &          C*(GAM**2*MR**2 + MR**4 - MA**2*MC**2 - MB**2*MC**2 -
11750      &          MA**2*MD**2 - MB**2*MD**2)
11751       RES(2) = (GAM**2*MR**2 + (-MR**2 + MA**2 + MB**2)**2)*
11752      &          (D**2*MC**2*MD**2 +
11753      &          2*C*D*MC*MD*(-MR**2 + MC**2 + MD**2) +
11754      &          C**2*(GAM**2*MR**2 + (-MR**2 + MC**2 + MD**2)**2))
11755       RES(3) = -D*MC*MD+C*(2*MR**2-(MA**2+MB**2+MC**2+MD**2))
11756       IF(RES(2).GT.ZERO) THEN
11757         RES(2) = SQRT(RES(2))
11758       ELSE
11759         RES(2) = 0.0D0
11760       ENDIF
11761       IF((RES(1)+RES(2))/RES(3).GT.(MD-MC)**2.OR.
11762      &              (RES(1)+RES(2))/RES(3).LT.(MA+MB)**2) THEN
11763         X = (RES(1)-RES(2))/RES(3)
11764       ELSE
11765         X = (RES(1)+RES(2))/RES(3)
11766       ENDIF
11767       IF(X.GT.(MD-MC)**2) X = (MD-MC)**2
11768       IF(X.LT.(MA+MB)**2) X = (MA+MB)**2
11769       E2S = (X-MA**2+MB**2)/(2*SQRT(X))
11770       E3S = (MD**2-X-MC**2)/(2*SQRT(X))
11771       E2M = E2S**2-MB**2
11772       E3M = E3S**2-MC**2
11773       IF(E2M.LT.ZERO) THEN
11774         IF(ABS(E2M/E2S).GT.EPS) CALL HWWARN('HWDRM5',2,*10)
11775  10     E2M= 0.0D0
11776       ENDIF
11777       IF(E3M.LT.ZERO) THEN
11778         IF(ABS(E3M/E3S).GT.EPS) CALL HWWARN('HWDRM5',3,*20)
11779  20     E3M= 0.0D0
11780       ENDIF
11781       E2M = SQRT(E2M)
11782       E3M = SQRT(E3M)
11783       LOW = (E2S+E3S)**2-(E2M+E3M)**2
11784       UPP = (E2S+E3S)**2-(E2M-E3M)**2
11785       Y   = HWRUNI(1,LOW,UPP)
11786       Z   = MA**2+MB**2+MC**2+MD**2-X-Y
11787       END
11788 CDECK  ID>, HWDPWT.
11789 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
11790 *-- Author :    Bryan Webber
11791 C-----------------------------------------------------------------------
11792       FUNCTION HWDPWT(EMSQ,A,B,C)
11793 C-----------------------------------------------------------------------
11794 C     MATRIX ELEMENT SQUARED FOR PHASE SPACE DECAY
11795 C-----------------------------------------------------------------------
11796       DOUBLE PRECISION HWDPWT,EMSQ,A,B,C
11797       HWDPWT=1.
11798       END
11799 CDECK  ID>, HWDSIN.
11800 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
11801 *-- Author :    Peter Richardson
11802 C-----------------------------------------------------------------------
11803       SUBROUTINE HWDSIN(CLSAVE)
11804 C-----------------------------------------------------------------------
11805 C  Subroutine to perform decays including spin correlations
11806 C-----------------------------------------------------------------------
11807       INCLUDE 'HERWIG65.INC'
11808       DOUBLE PRECISION PW(5)
11809       INTEGER IDEC,IP,IS,IHEP,ID,IM,LHEP,MHEP,NPR,KHEP,CLSAVE(2),NTRY,
11810      &     ID1
11811       IF(IERROR.NE.0) RETURN
11812       NTRY = 0
11813       IDEC = 1
11814  1    NTRY = NTRY+1
11815 C--search the decay products and decide which one to decay next
11816       IF(.NOT.DECSPN(IDEC)) THEN
11817         CALL HWDSI1(IDEC,IP)
11818       ELSE
11819         IDEC = JMOSPN(IDEC)
11820         GOTO 1
11821       ENDIF
11822 C--first no more particles in this decay to develop so move up chain
11823       IF(IP.EQ.0) THEN
11824         IDEC = JMOSPN(IDEC)
11825 C--reached the end of this spin chain go back to HWDHOB
11826         IF(IDEC.EQ.0) THEN
11827           NSPN = 0
11828           RETURN
11829 C--otherwise keep going up the chain
11830         ELSE
11831           IF(NTRY.LE.NBTRY) THEN
11832             GOTO 1
11833           ELSE
11834             CALL HWWARN('HWDSIN',100,*999)
11835           ENDIF
11836         ENDIF
11837 C--special for tau decays call spin correlation in tau decay routine
11838       ELSEIF(ABS(IDHEP(IDSPN(IP))).EQ.15) THEN
11839         CALL HWDSI3(IP)
11840         IF(IERROR.NE.0) RETURN
11841         GOTO 1
11842       ENDIF
11843 C--work out where that particle is
11844       IHEP = IDSPN(IP)
11845 C--if particle has daughters
11846  10   IF(JDAHEP(1,IHEP).NE.0) THEN
11847         IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
11848           DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
11849             IF(IDHW(ID1).EQ.ID) IHEP=ID1
11850           ENDDO
11851         ELSE
11852           IHEP = JDAHEP(1,IHEP)
11853         ENDIF
11854       ENDIF
11855       IS=ISTHEP(IHEP)
11856       ID=IDHW(IHEP)
11857       NTRY = NTRY+1
11858       IF(NTRY.GE.NBTRY) CALL HWWARN('HWDSIN',101,*999)
11859       IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
11860      & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
11861      & (IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
11862         CALL HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
11863         IF(IERROR.NE.0) RETURN
11864       ELSE
11865         GOTO 10
11866       ENDIF
11867 C--perform the decay including spin correlations
11868       CALL HWDSI2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
11869       IF(IERROR.NE.0) RETURN
11870 C--make the colour connections
11871       CALL HWDHO3(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
11872       IF (IERROR.NE.0) RETURN
11873 C--perform the parton-showers
11874       CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
11875       IF(IERROR.NE.0) RETURN
11876 C--perform RPV colour connections
11877       CALL HWDHO5(IHEP,MHEP,LHEP,CLSAVE)
11878       IF(IERROR.NE.0) RETURN
11879 C--continue and perform the next decay
11880       IDEC = IP
11881       IF(NTRY.LE.NBTRY) THEN
11882         GOTO 1
11883       ELSE
11884         CALL HWWARN('HWDSIN',102,*999)
11885       ENDIF
11886  999  END
11887 CDECK  ID>, HWDSI1.
11888 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
11889 *-- Author :    Peter Richardson
11890 C-----------------------------------------------------------------------
11891       SUBROUTINE HWDSI1(IDEC,IP)
11892 C-----------------------------------------------------------------------
11893 C  Subroutine to check a vertex and decide which branch to treat
11894 C-----------------------------------------------------------------------
11895       INCLUDE 'HERWIG65.INC'
11896       INTEGER IDEC,I,IPICK(5),IP,HWRINT,P1,P2,P3,P4,P3P,P4P,NPR,P0,P0P,
11897      &     P1P,P2P,IF1,IF2,P5,P5P
11898       DOUBLE PRECISION NORM
11899       DOUBLE COMPLEX RHOLP(2,2),RHOPS(2,2)
11900       EXTERNAL HWRINT
11901 C--loop over the daughters and decide what to do
11902       IP = 0
11903 C--if daughters of particle the same issue warning
11904       IF(JDASPN(1,IDEC).EQ.JDASPN(2,IDEC))
11905      &     CALL HWWARN('HWDSI1',100,*999)
11906 C--loop over the decay products
11907       DO I=JDASPN(1,IDEC),JDASPN(2,IDEC)
11908         IF(.NOT.DECSPN(I)) THEN
11909 C--first SM particles other than tau and top and stable particles
11910           IF(RSTAB(IDHW(IDSPN(I)))
11911      &    .OR.(IDHW(IDSPN(I)).LE.12.AND.ABS(IDHEP(IDSPN(I))).NE.6)
11912      &    .OR.(IDHW(IDSPN(I)).GE.121.AND.IDHW(IDSPN(I)).LE.132.AND.
11913      &          ABS(IDHEP(IDSPN(I))).NE.15)) THEN
11914              DECSPN(I) = .TRUE.
11915              RHOSPN(1,1,I) = HALF
11916              RHOSPN(1,2,I) = ZERO
11917              RHOSPN(2,1,I) = ZERO
11918              RHOSPN(2,2,I) = HALF
11919 C--spinless particles
11920           ELSEIF(RSPIN(IDHW(IDSPN(I))).EQ.ZERO) THEN
11921              DECSPN(I) = .TRUE.
11922              RHOSPN(1,1,I) = ONE
11923              RHOSPN(1,2,I) = ZERO
11924              RHOSPN(2,1,I) = ZERO
11925              RHOSPN(2,2,I) = ZERO
11926           ELSE
11927 C--particle which needs development
11928             IP = IP+1
11929             IPICK(IP) = I
11930           ENDIF
11931         ENDIF
11932       ENDDO
11933 C--pick the particle to decay next
11934       IF(IP.EQ.0) THEN
11935         IF(JMOSPN(IDEC).EQ.0) RETURN
11936 C--done everything compute the decay matrix and move up
11937         DECSPN(IDEC) = .TRUE.
11938         NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
11939         DO 20 P0=1,2
11940         DO 20 P0P=1,2
11941  20     RHOSPN(P0,P0P,IDEC) = ZERO
11942 C--two body decay
11943         IF(NPR.EQ.2) THEN
11944           DO 21 P0 =1,2
11945           DO 21 P0P=1,2
11946           DO 21 P1 =1,2
11947           DO 21 P1P=1,2
11948           DO 21 P2 =1,2
11949           DO 21 P2P=1,2
11950  21       RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
11951      &              MESPN(P0 ,P1 ,P2 ,1,NCFL(IDEC),IDEC)*
11952      &       DCONJG(MESPN(P0P,P1P,P2P,1,NCFL(IDEC),IDEC))*
11953      &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(2,IDEC))
11954 C--three body decay
11955         ELSEIF(NPR.EQ.3) THEN
11956           DO 25 P0 =1,2
11957           DO 25 P0P=1,2
11958           DO 25 P1 =1,2
11959           DO 25 P1P=1,2
11960           DO 25 P2 =1,2
11961           DO 25 P2P=1,2
11962           DO 25 P3 =1,2
11963           DO 25 P3P=1,2
11964  25       RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
11965      &           MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
11966      &    DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
11967      &    RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
11968      &    RHOSPN(P3,P3P,JDASPN(2,IDEC))
11969 C--higher
11970         ELSE
11971           CALL HWWARN('HWDSI1',500,*999)
11972         ENDIF
11973 C--now normalise this
11974         NORM = DBLE(RHOSPN(1,1,IDEC))+DBLE(RHOSPN(2,2,IDEC))
11975         IF(NORM.GT.ZERO) THEN
11976           NORM = ONE/NORM
11977           DO 35 P0=1,2
11978           DO 35 P0P=1,2
11979  35       RHOSPN(P0,P0P,IDEC) = NORM*RHOSPN(P0,P0P,IDEC)
11980         ELSE
11981           CALL HWWARN('HWDSI1',101,*999)
11982         ENDIF
11983       ELSE
11984 C--pick the particle to be decayed
11985         IP = IPICK(HWRINT(1,IP))
11986 C--setup the spin density matrix for the decay
11987 C--special for the hard process
11988         IF(ISTHEP(IDSPN(IDEC)).EQ.120) THEN
11989           NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
11990 C--set up the spin density matrices for the incoming partons
11991 C--zero off diagonal elements
11992           RHOLP(2,1) = ZERO
11993           RHOLP(1,2) = ZERO
11994           RHOPS(2,1) = ZERO
11995           RHOPS(1,2) = ZERO
11996 C--set up for polarized incoming beams in lepton collisons
11997           IF(IDHW(JMOHEP(1,IDSPN(IDEC))).GE.121.AND.
11998      &       IDHW(JMOHEP(1,IDSPN(IDEC))).LE.132) THEN
11999             RHOLP(1,1) = HALF*(ONE+EPOLN(3))
12000             RHOLP(2,2) = HALF*(ONE-EPOLN(3))
12001             RHOPS(1,1) = HALF*(ONE-PPOLN(3))
12002             RHOPS(2,2) = HALF*(ONE+PPOLN(3))
12003 C--otherwise average
12004           ELSE
12005             RHOLP(1,1) = HALF
12006             RHOLP(2,2) = HALF
12007             RHOPS(1,1) = HALF
12008             RHOPS(2,2) = HALF
12009           ENDIF
12010 C--first decay product
12011           IF(NPR.EQ.2) THEN
12012            IF(IP.EQ.JDASPN(1,IDEC)) THEN
12013 C--if using first colour flow option
12014             IF(SPCOPT.EQ.1) THEN
12015               DO 5 P3 =1,2
12016               DO 5 P3P=1,2
12017               RHOSPN(P3,P3P,IP) = ZERO
12018               DO 5 IF1=1,NCFL(1)
12019               DO 5 IF2=1,NCFL(1)
12020               DO 5 P1 =1,2
12021               DO 5 P1P=1,2
12022               DO 5 P2 =1,2
12023               DO 5 P2P=1,2
12024               DO 5 P4 =1,2
12025               DO 5 P4P=1,2
12026  5            RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+SPNCFC(IF1,IF2,1)*
12027      &               MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
12028      &        DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
12029      &        RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
12030 C--if using second colour flow option
12031             ELSEIF(SPCOPT.EQ.2) THEN
12032               DO 6 P3 =1,2
12033               DO 6 P3P=1,2
12034               RHOSPN(P3,P3P,IP) = ZERO
12035               DO 6 P1 =1,2
12036               DO 6 P1P=1,2
12037               DO 6 P2 =1,2
12038               DO 6 P2P=1,2
12039               DO 6 P4 =1,2
12040               DO 6 P4P=1,2
12041  6            RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)
12042      &                +SPNCFC(NCFL(1),NCFL(1),1)*
12043      &               MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
12044      &        DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
12045      &        RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
12046 C--unknown option issue warning
12047             ELSE
12048               CALL HWWARN('HWDSI1',501,*999)
12049             ENDIF
12050 C--second decay product
12051            ELSE
12052             IF(SPCOPT.EQ.1) THEN
12053               DO 10 P4 =1,2
12054               DO 10 P4P=1,2
12055               RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12056               DO 10 IF1=1,NCFL(1)
12057               DO 10 IF2=1,NCFL(1)
12058               DO 10 P1 =1,2
12059               DO 10 P1P=1,2
12060               DO 10 P2 =1,2
12061               DO 10 P2P=1,2
12062               DO 10 P3 =1,2
12063               DO 10 P3P=1,2
12064  10           RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+SPNCFC(IF1,IF2,1)*
12065      &                 MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
12066      &          DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
12067      &          RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
12068             ELSEIF(SPCOPT.EQ.2) THEN
12069               DO 11 P4 =1,2
12070               DO 11 P4P=1,2
12071               RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12072               DO 11 P1 =1,2
12073               DO 11 P1P=1,2
12074               DO 11 P2 =1,2
12075               DO 11 P2P=1,2
12076               DO 11 P3 =1,2
12077               DO 11 P3P=1,2
12078  11           RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)
12079      &                +SPNCFC(NCFL(1),NCFL(1),1)*
12080      &                 MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
12081      &          DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
12082      &          RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
12083             ELSE
12084               CALL HWWARN('HWDSI1',502,*999)
12085             ENDIF
12086            ENDIF
12087 C--new for four body gauge boson pair processes
12088           ELSEIF(NPR.EQ.4) THEN
12089 C--first particle
12090            IF(IP.EQ.JDASPN(1,IDEC)) THEN
12091              DO 41 P1 =1,2
12092              DO 41 P1P=1,2
12093              RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12094              DO 41 P3 =1,2
12095              DO 41 P3P=1,2
12096              DO 41 P5 =1,2
12097              DO 41 P5P=1,2
12098  41          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12099      &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12100      &       RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12101      &       RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12102      &       RHOSPN(P3,P3P,JDASPN(2,IDEC))
12103 C--second particle
12104            ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12105              DO 42 P1 =1,2
12106              DO 42 P1P=1,2
12107              RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12108              DO 42 P3 =1,2
12109              DO 42 P3P=1,2
12110              DO 42 P5 =1,2
12111              DO 42 P5P=1,2
12112  42          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12113      &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12114      &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12115      &       RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12116      &       RHOSPN(P3,P3P,JDASPN(2,IDEC))
12117 C--third particle
12118            ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
12119              DO 43 P3 =1,2
12120              DO 43 P3P=1,2
12121              RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12122              DO 43 P1 =1,2
12123              DO 43 P1P=1,2
12124              DO 43 P5 =1,2
12125              DO 43 P5P=1,2
12126  43          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12127      &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12128      &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12129      &       RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12130      &       RHOSPN(P3,P3P,JDASPN(2,IDEC))
12131 C--fourth particle
12132            ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12133              DO 44 P3 =1,2
12134              DO 44 P3P=1,2
12135              RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12136              DO 44 P1 =1,2
12137              DO 44 P1P=1,2
12138              DO 44 P5 =1,2
12139              DO 44 P5P=1,2
12140  44          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12141      &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12142      &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12143      &       RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12144      &       RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
12145 C--unrecognized issue warning
12146            ELSE
12147              CALL HWWARN('(HWDSI1)',509,*999)
12148            ENDIF
12149 C--unrecognized issue warning
12150           ELSE
12151             CALL HWWARN('(HWDSI1)',508,*999)
12152           ENDIF
12153         ELSE
12154           NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
12155           DO 50 P1 =1,2
12156           DO 50 P1P=1,2
12157  50       RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12158 C--set-up matrix for 2-body decay
12159           IF(NPR.EQ.2) THEN
12160             IF(NCFL(IDEC).NE.1) CALL HWWARN('HWDSI1',503,*999)
12161             IF(IP.EQ.JDASPN(1,IDEC)) THEN
12162               DO 60 P0 =1,2
12163               DO 60 P0P=1,2
12164               DO 60 P1 =1,2
12165               DO 60 P1P=1,2
12166               DO 60 P2 =1,2
12167               DO 60 P2P=1,2
12168  60           RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
12169      &               MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
12170      &        DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
12171      &        RHOSPN(P2,P2P,JDASPN(2,IDEC))
12172             ELSE
12173               DO 70 P0 =1,2
12174               DO 70 P0P=1,2
12175               DO 70 P1 =1,2
12176               DO 70 P1P=1,2
12177               DO 70 P2 =1,2
12178               DO 70 P2P=1,2
12179  70           RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
12180      &               MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
12181      &        DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
12182      &        RHOSPN(P1,P1P,JDASPN(1,IDEC))
12183             ENDIF
12184 C--set-up matrix for 3-body decay
12185           ELSEIF(NPR.EQ.3) THEN
12186             IF(SPCOPT.NE.2.AND.NCFL(IDEC).NE.1)
12187      &        CALL HWWARN('HWDSI1',504,*999)
12188 C--first particle
12189             IF(IP.EQ.JDASPN(1,IDEC)) THEN
12190               DO 100 P0 =1,2
12191               DO 100 P0P=1,2
12192               DO 100 P1 =1,2
12193               DO 100 P1P=1,2
12194               DO 100 P2 =1,2
12195               DO 100 P2P=1,2
12196               DO 100 P3 =1,2
12197               DO 100 P3P=1,2
12198  100          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
12199      &               MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12200      &        DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12201      &        RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12202      &        RHOSPN(P3,P3P,JDASPN(2,IDEC))
12203 C--second particle
12204             ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12205               DO 105 P0 =1,2
12206               DO 105 P0P=1,2
12207               DO 105 P1 =1,2
12208               DO 105 P1P=1,2
12209               DO 105 P2 =1,2
12210               DO 105 P2P=1,2
12211               DO 105 P3 =1,2
12212               DO 105 P3P=1,2
12213  105          RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
12214      &               MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12215      &        DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12216      &        RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12217      &        RHOSPN(P3,P3P,JDASPN(2,IDEC))
12218 C--third particle
12219             ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12220               DO 110 P0 =1,2
12221               DO 110 P0P=1,2
12222               DO 110 P1 =1,2
12223               DO 110 P1P=1,2
12224               DO 110 P2 =1,2
12225               DO 110 P2P=1,2
12226               DO 110 P3 =1,2
12227               DO 110 P3P=1,2
12228  110          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+RHOSPN(P0,P0P,IDEC)*
12229      &               MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12230      &        DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12231      &        RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12232      &        RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)
12233 C--unrecognized
12234             ELSE
12235               CALL HWWARN('HWDSI1',102,*999)
12236             ENDIF
12237           ELSEIF(NPR.EQ.4) THEN
12238 C--first particle
12239             IF(IP.EQ.JDASPN(1,IDEC)) THEN
12240               DO 151 P1 =1,2
12241               DO 151 P1P=1,2
12242               RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12243               DO 151 P2 =1,2
12244               DO 151 P2P=1,2
12245               DO 151 P3 =1,2
12246               DO 151 P3P=1,2
12247               DO 151 P4 =1,2
12248               DO 151 P4P=1,2
12249  151          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12250      &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12251      &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12252      &           RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12253      &           RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12254      &           RHOSPN(P4,P4P,JDASPN(2,IDEC))
12255 C--second particle
12256             ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12257               DO 152 P2 =1,2
12258               DO 152 P2P=1,2
12259               RHOSPN(P2,P2P,IP) = (0.0D0,0.0D0)
12260               DO 152 P1 =1,2
12261               DO 152 P1P=1,2
12262               DO 152 P3 =1,2
12263               DO 152 P3P=1,2
12264               DO 152 P4 =1,2
12265               DO 152 P4P=1,2
12266  152             RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+
12267      &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12268      &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12269      &           RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12270      &           RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12271      &           RHOSPN(P4,P4P,JDASPN(2,IDEC))
12272 C--third particle
12273             ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
12274               DO 153 P3 =1,2
12275               DO 153 P3P=1,2
12276               RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12277               DO 153 P1 =1,2
12278               DO 153 P1P=1,2
12279               DO 153 P2 =1,2
12280               DO 153 P2P=1,2
12281               DO 153 P4 =1,2
12282               DO 153 P4P=1,2
12283  153          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12284      &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12285      &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12286      &           RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12287      &           RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12288      &           RHOSPN(P4,P4P,JDASPN(2,IDEC))
12289 C--fourth particle
12290             ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12291               DO 154 P4 =1,2
12292               DO 154 P4P=1,2
12293               RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12294               DO 154 P1 =1,2
12295               DO 154 P1P=1,2
12296               DO 154 P2 =1,2
12297               DO 154 P2P=1,2
12298               DO 154 P3 =1,2
12299               DO 154 P3P=1,2
12300  154          RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+
12301      &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12302      &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12303      &           RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12304      &           RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12305      &           RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
12306             ELSE
12307               CALL HWWARN('HWDSI1',505,*999)
12308             ENDIF
12309           ELSE
12310             CALL HWWARN('HWDSI1',506,*999)
12311           ENDIF
12312         ENDIF
12313 C--normalise the spin density matrix
12314         NORM = DBLE(RHOSPN(1,1,IP))+DBLE(RHOSPN(2,2,IP))
12315         IF(NORM.GT.ZERO) THEN
12316           NORM = ONE/NORM
12317           DO 15 P3=1,2
12318           DO 15 P3P=1,2
12319  15       RHOSPN(P3,P3P,IP) = NORM*RHOSPN(P3,P3P,IP)
12320         ELSE
12321           CALL HWWARN('HWDSI1',107,*999)
12322         ENDIF
12323       ENDIF
12324  999  END
12325 CDECK  ID>, HWDSI2.
12326 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
12327 *-- Author :    Peter Richardson
12328 C-----------------------------------------------------------------------
12329       SUBROUTINE HWDSI2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
12330 C-----------------------------------------------------------------------
12331 C   Subroutine to perform the second part of the heavy object decays
12332 C   IE generate the kinematics for the decay
12333 C   including spin correlations
12334 C   was part of HWDHOB
12335 C-----------------------------------------------------------------------
12336       INCLUDE 'HERWIG65.INC'
12337       DOUBLE PRECISION HWRGEN,PW(5),HWDPWT,HWDWWT,PCM,HWUPCM
12338       INTEGER IHEP,IM,KHEP,LHEP,MHEP,NPR,ISN,RHEP
12339       EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWUPCM
12340       IF (IERROR.NE.0) RETURN
12341       ISN = ISNHEP(IHEP)
12342       IF (NPR.EQ.2) THEN
12343 C Two body decay: LHEP -> MHEP + NHEP
12344         IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
12345 C--generate a two body decay to a gauge boson as a three body decay
12346           CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,
12347      &                 RHOSPN(1,1,ISN),ISN)
12348 C--two body decay
12349         ELSEIF(NME(IM).GT.30000.AND.NME(IM).LT.40000) THEN
12350           CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,
12351      &          RHOSPN(1,1,ISN),ISN)
12352 C--otherwise issue warning
12353 C--change by PR 9/30/02 to issue non-terminal warning and continue
12354         ELSE
12355           CALL HWWARN('HWDSI2',1,*999)
12356           PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
12357           CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
12358      &                PHEP(1,NHEP),PCM,TWO,.FALSE.)
12359           DECSPN(ISN) = .TRUE.
12360           IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12361             RHOSPN(1,1,ISN) = ONE
12362             RHOSPN(1,2,ISN) = ZERO
12363             RHOSPN(2,1,ISN) = ZERO
12364             RHOSPN(2,2,ISN) = ZERO
12365           ELSE
12366             RHOSPN(1,1,ISN) = HALF
12367             RHOSPN(1,2,ISN) = ZERO
12368             RHOSPN(2,1,ISN) = ZERO
12369             RHOSPN(2,2,ISN) = HALF
12370           ENDIF
12371         ENDIF
12372       ELSEIF (NPR.EQ.3) THEN
12373 C Three body decay: LHEP -> KHEP + MHEP + NHEP
12374         KHEP=MHEP
12375         MHEP=MHEP+1
12376 C Provisional colour self-connection of KHEP
12377         JMOHEP(2,KHEP)=KHEP
12378         JDAHEP(2,KHEP)=KHEP
12379 C--if old codes issue warning
12380         IF (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.NME(IM).EQ.300) THEN
12381           CALL HWWARN('HWDSI2',502,*999)
12382 C--three body spin matrix element
12383         ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
12384           CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
12385      &            RHOSPN(1,1,ISN),ISN)
12386 C--special for top decay
12387           IF(ABS(IDHEP(IHEP)).EQ.6) THEN
12388             CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
12389             CALL HWUMAS(PW)
12390           ENDIF
12391 C--unknown issue warning
12392         ELSE
12393           CALL HWWARN('HWDSI2',2,*999)
12394 C Three body phase space decay
12395           CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
12396      &                PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
12397           CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
12398           DECSPN(ISN) = .TRUE.
12399           IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12400             RHOSPN(1,1,ISN) = ONE
12401             RHOSPN(1,2,ISN) = ZERO
12402             RHOSPN(2,1,ISN) = ZERO
12403             RHOSPN(2,2,ISN) = ZERO
12404           ELSE
12405             RHOSPN(1,1,ISN) = HALF
12406             RHOSPN(1,2,ISN) = ZERO
12407             RHOSPN(2,1,ISN) = ZERO
12408             RHOSPN(2,2,ISN) = HALF
12409           ENDIF
12410         ENDIF
12411       ELSEIF(NPR.EQ.4) THEN
12412         CALL HWWARN('HWDSI2',3,*999)
12413 C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
12414         KHEP = MHEP
12415         RHEP = MHEP+1
12416         MHEP = MHEP+2
12417         ISTHEP(NHEP) = 114
12418 C Provisional colour connections of KHEP and RHEP
12419         JMOHEP(2,KHEP)=RHEP
12420         JDAHEP(2,KHEP)=RHEP
12421         JMOHEP(2,RHEP)=KHEP
12422         JDAHEP(2,RHEP)=KHEP
12423 C Four body phase space decay
12424         CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
12425      &                PHEP(1,MHEP),PHEP(1,NHEP))
12426         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
12427         CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
12428         DECSPN(ISN) = .TRUE.
12429         IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12430           RHOSPN(1,1,ISN) = ONE
12431           RHOSPN(1,2,ISN) = ZERO
12432           RHOSPN(2,1,ISN) = ZERO
12433           RHOSPN(2,2,ISN) = ZERO
12434         ELSE
12435           RHOSPN(1,1,ISN) = HALF
12436           RHOSPN(1,2,ISN) = ZERO
12437           RHOSPN(2,1,ISN) = ZERO
12438           RHOSPN(2,2,ISN) = HALF
12439         ENDIF
12440       ELSE
12441         CALL HWWARN('HWDSI2',100,*999)
12442       ENDIF
12443  999  END
12444 CDECK  ID>, HWDSI3.
12445 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
12446 *-- Author :    Peter Richardson
12447 C-----------------------------------------------------------------------
12448       SUBROUTINE HWDSI3(IP)
12449 C-----------------------------------------------------------------------
12450 C     Subroutine to handle spin correlations in tau decays
12451 C     averages spin if not using TAUOLA
12452 C     if using TAUOLA selects the spin and uses TAUOLA to perform the
12453 C     decay
12454 C-----------------------------------------------------------------------
12455       INCLUDE 'HERWIG65.INC'
12456       INTEGER IP,IHEP,ID1,ID,NTRY
12457       DOUBLE PRECISION PPOL,HWRGEN,POL
12458       EXTERNAL HWRGEN
12459 C--if HERWIG is performing tau decays average over spins and return
12460 C--spin averaged tau decay will be done later
12461       IF(TAUDEC.EQ.'HERWIG') THEN
12462         DECSPN(IP) = .TRUE.
12463         RHOSPN(1,1,IP) = HALF
12464         RHOSPN(2,1,IP) = ZERO
12465         RHOSPN(1,2,IP) = ZERO
12466         RHOSPN(2,2,IP) = HALF
12467 C--if using tauola select the polarization for the decay
12468       ELSEIF(TAUDEC.EQ.'TAUOLA') THEN
12469 C--work out where that particle is
12470         IHEP = IDSPN(IP)
12471         NTRY = 0
12472  10     ID   = IDHW(IHEP)
12473         IF(JDAHEP(1,IHEP).NE.0) THEN
12474           IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
12475             DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
12476               IF(IDHW(ID1).EQ.ID) IHEP=ID1
12477             ENDDO
12478           ELSE
12479             IHEP = JDAHEP(1,IHEP)
12480           ENDIF
12481           NTRY = NTRY+1
12482           IF(NTRY.LT.NBTRY) THEN
12483             GOTO 10
12484           ELSE
12485             CALL HWWARN('HWDSI3',100,*999)
12486           ENDIF
12487         ENDIF
12488 C--select the tau polarization
12489         PPOL = DBLE(RHOSPN(1,1,IP))
12490         IF(PPOL.GE.HWRGEN(0)) THEN
12491           POL = 1.0D0
12492           RHOSPN(1,1,IP) =  ONE
12493           RHOSPN(2,1,IP) = ZERO
12494           RHOSPN(1,2,IP) = ZERO
12495           RHOSPN(2,2,IP) = ZERO
12496         ELSE
12497           POL =-1.0D0
12498           RHOSPN(1,1,IP) = ZERO
12499           RHOSPN(2,1,IP) = ZERO
12500           RHOSPN(1,2,IP) = ZERO
12501           RHOSPN(2,2,IP) =  ONE
12502         ENDIF
12503 C--decay the particle
12504         CALL HWDTAU(1,IHEP,POL)
12505         DECSPN(IP) = .TRUE.
12506       ELSE
12507         CALL HWWARN('HWDSI3',500,*999)
12508       ENDIF
12509  999  END
12510 CDECK  ID>, HWDSM2.
12511 *CMZ :-        -09/04/02  13:46:07  by  Peter Richardson
12512 *-- Author :    Peter Richardson
12513 C-----------------------------------------------------------------------
12514       SUBROUTINE HWDSM2(ID,IOUT1,IOUT2,IMODE,RHOIN,IDSPIN)
12515 C-----------------------------------------------------------------------
12516 C  Subroutine to calculate the two body matrix element for spin
12517 C  correlations
12518 C-----------------------------------------------------------------------
12519       INCLUDE 'HERWIG65.INC'
12520       INTEGER IOUT1,IOUT2,IMODE,IDSPIN,ID,I,J,IDP(3),P0,P1,P2,O(2),P0P,
12521      &     NTRY
12522       DOUBLE PRECISION XMASS,PLAB,PRW,PCM,PREF(5),P(5,3),PM(5,3),PCMA,
12523      &     HWUPCM,MA(3),MA2(3),HWULDO,PP,HWVDOT,N(3),EPS,PRE,PHS,A(2),
12524      &     WGT,WTMAX,HWRGEN
12525       DOUBLE COMPLEX RHOIN(2,2),S,D,ME(2,2,2),F1(2,2,8),F0(2,2,8),
12526      &     F2M(2,2,8),F1M(2,2,8),F1F(2,2,8),F2(2,2,8,8),F0B(2,2,8,8)
12527       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
12528       DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
12529       DATA O/2,1/
12530       COMMON/HWHEWS/S(8,8,2),D(8,8)
12531       PARAMETER(EPS=1D-20)
12532       EXTERNAL HWUPCM,HWULDO,HWVDOT,HWRGEN
12533 C--first setup if this is the start of a new spin chain
12534       IF(NSPN.EQ.0) THEN
12535 C--zero the elements of the array
12536         CALL HWVZRI(  NMXHEP,ISNHEP)
12537         CALL HWVZRI(  NMXSPN,JMOSPN)
12538         CALL HWVZRI(2*NMXSPN,JDASPN)
12539         CALL HWVZRI(  NMXSPN, IDSPN)
12540         NSPN = NSPN+1
12541         JMOSPN(NSPN) = 0
12542         IDSPN (NSPN) = ID
12543         DECSPN(NSPN) = .FALSE.
12544         IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
12545           RHOSPN(1,1,NSPN) = ONE
12546           RHOSPN(2,1,NSPN) = ZERO
12547           RHOSPN(1,2,NSPN) = ZERO
12548           RHOSPN(2,2,NSPN) = ZERO
12549         ELSE
12550           RHOSPN(1,1,NSPN) = HALF
12551           RHOSPN(2,1,NSPN) = ZERO
12552           RHOSPN(1,2,NSPN) = ZERO
12553           RHOSPN(2,2,NSPN) = HALF
12554         ENDIF
12555         ISNHEP(ID)    = NSPN
12556       ENDIF
12557 C--MA is mass for this decay (OFF-SHELL)
12558 C--generate the momenta for a two body decay
12559       P(5,1) = PHEP(5,   ID)
12560       P(5,2) = PHEP(5,IOUT1)
12561       P(5,3) = PHEP(5,IOUT2)
12562       IDP(1) = IDHW(ID)
12563       IDP(2) = IDHW(IOUT1)
12564       IDP(3) = IDHW(IOUT2)
12565       DO 1 I=1,3
12566       MA(I)  = P(5,I)
12567  1    MA2(I) = MA(I)**2
12568       PCMA   = HWUPCM(P(5,1),P(5,2),P(5,3))
12569 C--setup the couplings
12570       DO 2 I=1,2
12571  2    A(I) = A2MODE(I,IMODE)
12572 C--phase space factor
12573       PHS = PCMA/MA2(1)/8.0D0/PIFAC
12574 C--maximum weight
12575       WTMAX = WT2MAX(IMODE)
12576       NTRY = 0
12577  1000 NTRY = NTRY+1
12578       CALL HWVEQU(5,PHEP(1,ID),P(1,1))
12579       CALL HWDTWO(P(1,1),P(1,2),P(1,3),PCMA,2.0D0,.TRUE.)
12580       DO 3 I=1,3
12581 C--compute the references vectors
12582 C--not important if SM particle which can't have spin measured
12583 C--ie anything other the top and tau
12584 C--also not important if particle is approx massless
12585 C--first the SM particles other than top and tau
12586       IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
12587      &                .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
12588         CALL HWVEQU(5,PREF,PLAB(1,I+3))
12589 C--all other particles
12590       ELSE
12591         PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
12592         CALL HWVSCA(3,ONE/PP,P(1,I),N)
12593         PLAB(4,I+3) = HALF*(P(4,I)-PP)
12594         PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
12595         CALL HWVSCA(3,PP,N,PLAB(1,I+3))
12596         CALL HWUMAS(PLAB(1,I+3))
12597         PP = HWVDOT(3,PLAB(1,I+3),PLAB(1,I+3))
12598 C--fix to avoid problems if approx massless due to energy
12599         IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+3))
12600       ENDIF
12601 C--now the massless vectors
12602       PP = HALF*P(5,I)**2/HWULDO(PLAB(1,I+3),P(1,I))
12603       DO 4 J=1,4
12604  4    PLAB(J,I) = P(J,I)-PP*PLAB(J,I+3)
12605  3    CALL HWUMAS(PLAB(1,I))
12606 C--change order of momenta for call to HE code
12607       DO 5 I=1,3
12608       PM(1,I) = P(3,I)
12609       PM(2,I) = P(1,I)
12610       PM(3,I) = P(2,I)
12611       PM(4,I) = P(4,I)
12612  5    PM(5,I) = P(5,I)
12613       DO 6 I=1,6
12614       PCM(1,I)=PLAB(3,I)
12615       PCM(2,I)=PLAB(1,I)
12616       PCM(3,I)=PLAB(2,I)
12617       PCM(4,I)=PLAB(4,I)
12618  6    PCM(5,I)=PLAB(5,I)
12619 C--compute the S functions
12620       CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
12621       DO 7 I=1,6
12622       DO 7 J=1,6
12623       S(I,J,2) = -S(I,J,2)
12624  7    D(I,J)   = TWO*D(I,J)
12625 C--now compute the F functions needed
12626       CALL HWH2F2(6,F1 ,5,PM(1,2), MA(2))
12627       CALL HWH2F2(6,F0 ,4,PM(1,1), MA(1))
12628       CALL HWH2F2(6,F1M,5,PM(1,2),-MA(2))
12629       CALL HWH2F2(6,F2M,6,PM(1,3),-MA(3))
12630       CALL HWH2F1(6,F1F,5,PM(1,2), MA(2))
12631       CALL HWH2F3(6,F2   ,PM(1,3),ZERO  )
12632       CALL HWH2F3(6,F0B  ,PM(1,1),ZERO  )
12633 C--now compute the diagrams
12634 C--fermion --> fermion scalar
12635       IF(I2DRTP(IMODE).EQ.1) THEN
12636         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
12637         PRE = HALF/SQRT(PRE)
12638         DO 10 P0=1,2
12639         DO 10 P1=1,2
12640         ME(P0,P1,2) = (0.0D0,0.0D0)
12641  10     ME(P0,P1,1) = PRE*( A(O(P1))*S(5,2,O(P1))*F0(  P1 ,O(P0),2)
12642      &                     +A(  P1 )*MA(2)*       F0(O(P1),O(P0),5))
12643 C--fermion --> scalar fermion   diagrams
12644       ELSEIF(I2DRTP(IMODE).EQ.2) THEN
12645         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
12646         PRE = HALF/SQRT(PRE)
12647         DO 20 P0=1,2
12648         DO 20 P2=1,2
12649         ME(P0,2,P2) = (0.0D0,0.0D0)
12650  20     ME(P0,1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F0(  P2 ,O(P0),3)
12651      &                     +A(  P2 )*MA(3)*       F0(O(P2),O(P0),6))
12652 C--fermion --> scalar antifermion
12653       ELSEIF(I2DRTP(IMODE).EQ.3) THEN
12654         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
12655         PRE =-HALF/SQRT(PRE)
12656         DO 30 P0=1,2
12657         DO 30 P2=1,2
12658         ME(P0,2,P2) = (0.0D0,0.0D0)
12659  30     ME(P0,1,P2) = PRE*( A(  P0 )*S(4,1,P0)*F2M(O(P0),O(P2),1)
12660      &                     -A(O(P0))*MA(1)    *F2M(  P0 ,O(P2),4))
12661 C--fermion --> fermion gauge boson
12662       ELSEIF(I2DRTP(IMODE).EQ.4) THEN
12663         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))*
12664      &        HWULDO(PM(1,3),PCM(1,6))
12665         PRE = HALF/SQRT(PRE)
12666         DO 40 P0=1,2
12667         DO 40 P1=1,2
12668         ME(P0,P1,1) =-PRE*A(1)*F1F(O(P1),2,3)*S(3,6,2)*F0(1,O(P0),3)
12669  40     ME(P0,P1,2) = PRE*     F1F(O(P1),1,3)*S(3,6,1)*F0(2,O(P0),3)
12670 C--scalar  --> fermion antifermion
12671       ELSEIF(I2DRTP(IMODE).EQ.5) THEN
12672         PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
12673         PRE =-HALF/SQRT(PRE)
12674         DO 50 P1=1,2
12675         DO 50 P2=1,2
12676         ME(2,P1,P2) = (0.0D0,0.0D0)
12677  50     ME(1,P1,P2) = PRE*( A(O(P1))*S(5,2,O(P1))*F2M(  P1 ,O(P2),2)
12678      &                     +A(  P1 )*MA(2)*       F2M(O(P1),O(P2),5))
12679 C--scalar --> fermion fermion
12680       ELSEIF(I2DRTP(IMODE).EQ.6) THEN
12681         PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
12682         PRE = HALF/SQRT(PRE)
12683         DO 60 P1=1,2
12684         DO 60 P2=1,2
12685         ME(2,P1,P2) = (0.0D0,0.0D0)
12686  60     ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M(  P2 ,P1,3)
12687      &                     +A(  P2 )*MA(3)*       F1M(O(P2),P1,6))
12688 C--fermion --> fermion pion
12689       ELSEIF(I2DRTP(IMODE).EQ.7) THEN
12690         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
12691         PRE = 0.25D0/SQRT(PRE)/RMASS(198)**2
12692         DO 70 P0=1,2
12693         DO 70 P1=1,2
12694         ME(P0,P1,2) = (0.0D0,0.0D0)
12695  70     ME(P0,P1,1) =PRE*(
12696      &              MA(1)*A(O(P0))*( S(5,2,O(P1))*F2(  P1 ,O(P0),2,4)
12697      &                                     +MA(2)*F2(O(P1),O(P0),5,4))
12698      &            +A(P0)*S(1,4,P0)*( S(5,2,O(P1))*F2(  P1 ,  P0 ,2,1)
12699      &                                     +MA(2)*F2(O(P1),  P0 ,5,1)))
12700 C--scalar  --> antifermion fermion
12701       ELSEIF(I2DRTP(IMODE).EQ.8) THEN
12702         PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
12703         PRE =-HALF/SQRT(PRE)
12704         DO 80 P1=1,2
12705         DO 80 P2=1,2
12706         ME(2,P1,P2) = (0.0D0,0.0D0)
12707  80     ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M(  P2 ,O(P1),3)
12708      &                     +A(  P2 )*MA(3)*       F1M(O(P2),O(P1),6))
12709 C--neutralino --> gravitino photon
12710       ELSEIF(I2DRTP(IMODE).EQ.9) THEN
12711         PRE = TWO*HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
12712         PRE = TWO/SQRT(PRE)
12713         DO 90 P1=1,2
12714         DO 90 P2=1,2
12715         ME(P1,P2,O(P2)) = (0.0D0,0.0D0)
12716  90     ME(P1,P2,  P2 ) = PRE*S(2,3,P2)*S(3,6,O(P2))*
12717      &       S(3,2,P2)*F0(O(P2),P1,2)
12718 C--neutralino --> gravitino scalar
12719       ELSEIF(I2DRTP(IMODE).EQ.10) THEN
12720         PRE = TWO*HWULDO(PM(1,1),PCM(1,4))
12721         PRE = ONE/SQRT(PRE)
12722         DO 100 P1=1,2
12723         DO 100 P2=1,2
12724         ME(P1,P2,2) = (0.0D0,0.0D0)
12725  100    ME(P1,P2,1) = PRE*F2(P2,1,2,2)*F0(1,O(P1),2)
12726 C--sfermion --> fermion gravitino
12727       ELSEIF(I2DRTP(IMODE).EQ.11) THEN
12728         PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
12729         PRE = ONE/SQRT(PRE)
12730         DO 110 P1=1,2
12731         DO 110 P2=1,2
12732         ME(2,P1,P2) = (0.0D0,0.0D0)
12733  110    ME(1,P1,P2) = PRE*A(O(P2))*F1M(O(P1),P2,3)*F0B(P2,P2,3,3)
12734 C--antisfermion --> antifermion gravitino
12735       ELSEIF(I2DRTP(IMODE).EQ.12) THEN
12736         PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
12737         PRE = ONE/SQRT(PRE)
12738         DO 120 P1=1,2
12739         DO 120 P2=1,2
12740         ME(2,P1,P2) = (0.0D0,0.0D0)
12741  120    ME(1,P1,P2) = PRE*A(O(P2))*F0B(P2,P2,3,3)*F1(P2,O(P1),3)
12742 C--scalar --> antifermion antifermion
12743       ELSEIF(I2DRTP(IMODE).EQ.13) THEN
12744         PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
12745         PRE = HALF/SQRT(PRE)
12746         DO 130 P1=1,2
12747         DO 130 P2=1,2
12748         ME(2,P1,P2) = (0.0D0,0.0D0)
12749  130    ME(1,P1,P2) = PRE*( A(  P1 )*S(5,2,  P1 )*F2M(O(P1),O(P2),2)
12750      &                     +A(O(P1))*MA(2)       *F2M(  P1 ,O(P2),5))
12751 C--antifermion --> scalar antifermion
12752       ELSEIF(I2DRTP(IMODE).EQ.14) THEN
12753         PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
12754         PRE = HALF/SQRT(PRE)
12755         DO 140 P0=1,2
12756         DO 140 P2=1,2
12757         ME(P0,2,P2) = (0.0D0,0.0D0)
12758  140    ME(P0,1,P2) = PRE*( A(O(P0))*S(4,1,O(P0))*F2M(  P0 ,O(P2),1)
12759      &                     -A(  P0 )*MA(1)       *F2M(O(P0),O(P2),4))
12760 C--unrecognized type of diagram
12761       ELSE
12762         CALL HWWARN('HWDSM2',500,*999)
12763       ENDIF
12764 C--now compute the weight
12765       WGT = ZERO
12766       DO 500 P0 =1,2
12767       DO 500 P0P=1,2
12768       DO 500 P1 =1,2
12769       DO 500 P2 =1,2
12770  500  WGT = WGT+PHS*P2MODE(IMODE)*ME(P0,P1,P2)*DCONJG(ME(P0P,P1,P2))*
12771      &          RHOIN(P0,P0P)
12772       IF(I2DRTP(IMODE).EQ.5.OR.I2DRTP(IMODE).EQ.6.OR.
12773      &   I2DRTP(IMODE).EQ.8.OR.I2DRTP(IMODE).EQ.13) GOTO 300
12774 C--issue warning if greater than maximum
12775       IF(WGT.GT.WTMAX) THEN
12776         CALL HWWARN('HWDSM2',1,*200)
12777         WRITE(6,2000) RNAME(IDK(ID2PRT(IMODE))),
12778      &   RNAME(IDKPRD(1,ID2PRT(IMODE))),RNAME(IDKPRD(2,ID2PRT(IMODE))),
12779      &   WTMAX,1.1D0*WGT
12780         WT2MAX(IMODE) = 1.1D0*WGT
12781         WTMAX         = WT2MAX(IMODE)
12782       ENDIF
12783  200  IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 1000
12784       IF(NTRY.GE.NSNTRY) CALL HWWARN('HWDSM2',100,*999)
12785 C--now enter the momenta in the common block
12786  300  CALL HWVEQU(5,P(1,2),PHEP(1,IOUT1))
12787       CALL HWVEQU(5,P(1,3),PHEP(1,IOUT2))
12788 C--set up the spin information
12789 C--setup for all decays
12790       JMOSPN(NSPN+1) = IDSPIN
12791       JMOSPN(NSPN+2) = IDSPIN
12792       JDASPN(1,IDSPIN) = NSPN+1
12793       JDASPN(2,IDSPIN) = NSPN+2
12794       IDSPN(NSPN+1) = IOUT1
12795       IDSPN(NSPN+2) = IOUT2
12796       DO 11 I=1,2
12797       DECSPN(NSPN+I) = .FALSE.
12798       DO 11 J=1,2
12799  11   JDASPN(I,NSPN+J) = 0
12800       ISNHEP(IOUT1) = NSPN+1
12801       ISNHEP(IOUT2) = NSPN+2
12802       DO 12 I=1,2
12803         IF(RSPIN(IDHW(IDSPN(NSPN+I))).EQ.ZERO) THEN
12804           RHOSPN(1,1,NSPN+I) = ONE
12805           RHOSPN(2,1,NSPN+I) = ZERO
12806           RHOSPN(1,2,NSPN+I) = ZERO
12807           RHOSPN(2,2,NSPN+I) = ZERO
12808         ELSE
12809           RHOSPN(1,1,NSPN+I) = HALF
12810           RHOSPN(2,1,NSPN+I) = ZERO
12811           RHOSPN(1,2,NSPN+I) = ZERO
12812           RHOSPN(2,2,NSPN+I) = HALF
12813         ENDIF
12814  12   CONTINUE
12815       NSPN = NSPN+2
12816 C--now enter the matrix element
12817       DO 150 P0=1,2
12818       DO 150 P1=1,2
12819       DO 150 P2=1,2
12820       MESPN(P0,P1,P2,2,1,IDSPIN) = (0.0D0,0.0D0)
12821  150  MESPN(P0,P1,P2,1,1,IDSPIN) = ME(P0,P1,P2)
12822       SPNCFC(1,1,IDSPIN) = ONE
12823       NCFL(IDSPIN) = 1
12824       RETURN
12825 C--format statements
12826  2000 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8, 'EXCEEDS MAX',
12827      &       /10X,'    MAXIMUM WEIGHT =',1PG24.16,
12828      &       /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
12829  999  END
12830 CDECK  ID>, HWDSM3.
12831 *CMZ :-        -09/04/02  13:46:07  by  Peter Richardson
12832 *-- Author :    Peter Richardson
12833 C-----------------------------------------------------------------------
12834       SUBROUTINE HWDSM3(NPR,ID,IOUT1,IOUT2,IOUT3,IMODE,RHOIN,IDSPIN)
12835 C-----------------------------------------------------------------------
12836 C     Master subroutine for three body SUSY and spin ME's
12837 C     Uses HWD3ME to generate the momenta etc
12838 C-----------------------------------------------------------------------
12839       INCLUDE 'HERWIG65.INC'
12840       DOUBLE COMPLEX F0(2,2,8),F1(2,2,8),F1M(2,2,8),F3(2,2,8),
12841      &     F0M(2,2,8),F2(2,2,8),RHOIN(2,2),F01(2,2,8,8)
12842       DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
12843      &  P(5,4),PZ(5),HWRGEN,CV,CA,BR,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
12844       INTEGER ID,IDP(4+NDIAGR),NPR,ITYPE,I,IB,ID1,ID2,IDSPIN,
12845      &     DRTYPE(NDIAGR),IOUT(3),IMODE,IOUT1,IOUT2,IOUT3,J,NCTHRE,
12846      &     DRCF(NDIAGR)
12847       COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
12848      &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
12849      &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
12850       EXTERNAL HWRGEN
12851       SAVE PZ,IOUT,ITYPE,ID1,ID2
12852 C--calculate the matrix element for a three body decay
12853       IF(NPR.EQ.3) THEN
12854 C--set up the decay products, if a SUSY decay the SUSY particle
12855 C--must be the first decay product
12856         IF(ABS(IDHEP(IOUT1)).GT.1000000) THEN
12857           IOUT(1) = IOUT1
12858           IOUT(2) = IOUT2
12859           IOUT(3) = IOUT3
12860         ELSEIF(ABS(IDHEP(IOUT2)).GT.1000000) THEN
12861           IOUT(1) = IOUT2
12862           IOUT(2) = IOUT1
12863           IOUT(3) = IOUT3
12864         ELSEIF(ABS(IDHEP(IOUT3)).GT.1000000) THEN
12865           IOUT(1) = IOUT3
12866           IOUT(2) = IOUT1
12867           IOUT(3) = IOUT3
12868 C--special for top decay (bottom must be first)
12869         ELSEIF(ABS(IDHEP(ID)).EQ.6) THEN
12870           IOUT(1) = IOUT3
12871           IOUT(2) = IOUT1
12872           IOUT(3) = IOUT2
12873         ELSE
12874           IOUT(1) = IOUT2
12875           IOUT(2) = IOUT1
12876           IOUT(3) = IOUT3
12877         ENDIF
12878 C--fermion must be second and antifermion third
12879         IF(IDHEP(IOUT(2)).LT.0.AND.
12880      &    (ABS(IDHEP(IOUT(1))).GT.1000000.OR.ABS(IDHEP(ID)).EQ.6)) THEN
12881           I = IOUT(2)
12882           IOUT(2) = IOUT(3)
12883           IOUT(3) = I
12884         ENDIF
12885 C--setup the OFF SHELL MASSES
12886         MA(1) = PHEP(5,ID)
12887         DO 1 I=1,3
12888  1      MA(I+1) = PHEP(5,IOUT(I))
12889         DO 2 I=1,4
12890  2      MA2(I) = MA(I)**2
12891 C--call to ME code
12892         CALL HWD3ME(ID,0,IMODE,RHOIN,IDSPIN)
12893         IF(IERROR.NE.0) RETURN
12894 C--juggle the momenta for the RPV BV gluino if needed
12895         IF(SPCOPT.EQ.2.AND.N3NCFL(IMODE).EQ.3) THEN
12896           IF(NCFL(IDSPIN).EQ.2) THEN
12897             IOUT(1) = IOUT1
12898             IOUT(2) = IOUT2
12899             IOUT(3) = IOUT3
12900           ELSEIF(NCFL(IDSPIN).EQ.3) THEN
12901             IOUT(1) = IOUT3
12902             IOUT(2) = IOUT2
12903             IOUT(3) = IOUT1
12904           ENDIF
12905           DO I=1,3
12906             IDHW(IOUT(I)) = IDP(I+1)
12907           ENDDO
12908         ENDIF
12909 C--copy momenta into event record
12910         DO 3 I=1,3
12911  3      CALL HWVEQU(5,P(1,1+I),PHEP(1,IOUT(I)))
12912 C--enter the spin information in the common block
12913         IF(SYSPIN) THEN
12914 C--set up if start of new spin chain
12915           IF(NSPN.EQ.0) THEN
12916 C--zero the elements
12917             CALL HWVZRI(  NMXHEP,ISNHEP)
12918             CALL HWVZRI(  NMXSPN,JMOSPN)
12919             CALL HWVZRI(2*NMXSPN,JDASPN)
12920             CALL HWVZRI(  NMXSPN, IDSPN)
12921             NSPN = NSPN+1
12922             JMOSPN(NSPN) = 0
12923             IDSPN (NSPN) = ID
12924             DECSPN(NSPN) = .FALSE.
12925 C--set up spin density matrix for particle
12926             IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
12927               RHOSPN(1,1,NSPN) = ONE
12928               RHOSPN(2,1,NSPN) = ZERO
12929               RHOSPN(1,2,NSPN) = ZERO
12930               RHOSPN(2,2,NSPN) = ZERO
12931             ELSE
12932               RHOSPN(1,1,NSPN) = HALF
12933               RHOSPN(2,1,NSPN) = ZERO
12934               RHOSPN(1,2,NSPN) = ZERO
12935               RHOSPN(2,2,NSPN) = HALF
12936             ENDIF
12937             ISNHEP(ID)    = NSPN
12938           ENDIF
12939 C--enter the decay products
12940           JDASPN(1,IDSPIN) = NSPN+1
12941           JDASPN(2,IDSPIN) = NSPN+3
12942           DO 7 I=1,3
12943           JMOSPN(NSPN+I  ) = IDSPIN
12944           IDSPN (NSPN+I  ) = IOUT(I)
12945           DECSPN(NSPN+I  ) = .FALSE.
12946           ISNHEP(IOUT(I) ) = NSPN+I
12947           IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
12948             RHOSPN(1,1,NSPN+I) = ONE
12949             RHOSPN(2,1,NSPN+I) = ZERO
12950             RHOSPN(1,2,NSPN+I) = ZERO
12951             RHOSPN(2,2,NSPN+I) = ZERO
12952           ELSE
12953             RHOSPN(1,1,NSPN+I) = HALF
12954             RHOSPN(2,1,NSPN+I) = ZERO
12955             RHOSPN(1,2,NSPN+I) = ZERO
12956             RHOSPN(2,2,NSPN+I) = HALF
12957           ENDIF
12958           DO 7 J=1,2
12959  7        JDASPN(J,NSPN+I) = 0
12960           NSPN = NSPN+3
12961         ENDIF
12962 C--select the decay mode and generate the decay for a two body mode
12963       ELSEIF(NPR.EQ.2) THEN
12964         IF(IDHW(IOUT2).GE.198.AND.IDHW(IOUT2).LE.200) THEN
12965           IB = IDHW(IOUT2)
12966           IOUT(1) = IOUT1
12967           IOUT(2) = IOUT2
12968         ELSEIF(IDHW(IOUT1).GE.198.AND.IDHW(IOUT1).LE.200) THEN
12969           IB = IDHW(IOUT1)
12970           IOUT(1) = IOUT2
12971           IOUT(2) = IOUT1
12972         ELSE
12973           CALL HWWARN('HWDSM3',501,*999)
12974         ENDIF
12975 C--setup the off shell masses and particle ids for me code
12976         MA(1) = PHEP(5,ID)
12977         MA(2) = PHEP(5,IOUT(1))
12978         CALL HWDBOZ(IB,ID1,ID2,CV,CA,BR,0)
12979         ITYPE = ID1
12980         IF(IB.EQ.199) ITYPE = ITYPE+1
12981         IF(ITYPE.GT.120) ITYPE = ITYPE-114
12982         IF(IB.NE.200) ITYPE = ITYPE/2
12983 C--generate momenta of decay products
12984         CALL HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
12985         CALL HWVEQU(5,P(1,2),PHEP(1,IOUT(1)))
12986         CALL HWVSUM(4,P(1,3),P(1,4),PZ)
12987         CALL HWUMAS(PZ)
12988         CALL HWVEQU(5,PZ,PHEP(1,IOUT(2)))
12989 C--enter the spin information in the common block if starting new chain
12990         IF(SYSPIN.AND.NSPN.EQ.0) THEN
12991 C--zero elements of common block
12992           CALL HWVZRI(  NMXHEP,ISNHEP)
12993           CALL HWVZRI(  NMXSPN,JMOSPN)
12994           CALL HWVZRI(2*NMXSPN,JDASPN)
12995           CALL HWVZRI(  NMXSPN, IDSPN)
12996           NSPN = NSPN+1
12997           JMOSPN(NSPN) = 0
12998           IDSPN (NSPN) = ID
12999           DECSPN(NSPN) = .FALSE.
13000           IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
13001             RHOSPN(1,1,NSPN) = ONE
13002             RHOSPN(2,1,NSPN) = ZERO
13003             RHOSPN(1,2,NSPN) = ZERO
13004             RHOSPN(2,2,NSPN) = ZERO
13005           ELSE
13006             RHOSPN(1,1,NSPN) = HALF
13007             RHOSPN(2,1,NSPN) = ZERO
13008             RHOSPN(1,2,NSPN) = ZERO
13009             RHOSPN(2,2,NSPN) = HALF
13010           ENDIF
13011           ISNHEP(ID)    = NSPN
13012         ENDIF
13013         IF(SYSPIN) THEN
13014           IDSPN (NSPN+1  ) = IOUT(1)
13015           ISNHEP(IOUT(1))  = NSPN+1
13016         ENDIF
13017 C--put the boson decay products into the event record for a two body mode
13018       ELSEIF(NPR.EQ.-1) THEN
13019         IOUT(1) = JDAHEP(1,IOUT(2))
13020         IOUT(2) = NHEP+1
13021         IOUT(3) = NHEP+2
13022 C--set up the status of the particles
13023         ISTHEP(IOUT(1)) = 195
13024         JDAHEP(1,IOUT(1)) = NHEP+1
13025         JDAHEP(2,IOUT(1)) = NHEP+2
13026 C--find the ID's of the particles
13027         IF(IDHW(IOUT(1)).EQ.200) THEN
13028           ID1 = ITYPE
13029           IF(ITYPE.GT.6) ID1 = ID1+114
13030           ID2 = ID1+6
13031         ELSE
13032           ID1 = 2*ITYPE-1
13033           IF(ITYPE.GT.3) ID1 = ID1+114
13034           ID2 = ID1+7
13035           IF(IDHW(IOUT(1)).EQ.198) THEN
13036             I   = ID1+6
13037             ID1 = ID2-6
13038             ID2 = I
13039           ENDIF
13040         ENDIF
13041 C--put id's of decay products into the event record
13042         IDHW(NHEP+1)  = ID1
13043         IDHW(NHEP+2)  = ID2
13044         IDHEP(NHEP+1) = IDPDG(ID1)
13045         IDHEP(NHEP+2) = IDPDG(ID2)
13046 C--boost decay products momenta to rest frame of boson
13047         CALL HWULOF(PZ,P(1,3),P(1,3))
13048         CALL HWULOF(PZ,P(1,4),P(1,4))
13049 C--boost back to lab using new boson
13050         CALL HWULOB(PHEP(1,IOUT(1)),P(1,3),PHEP(1,NHEP+1))
13051         CALL HWULOB(PHEP(1,IOUT(1)),P(1,4),PHEP(1,NHEP+2))
13052 C--setup for decay to quarks
13053         IF(ID1.LE.12) THEN
13054           ISTHEP(NHEP+1) = 113
13055           ISTHEP(NHEP+2) = 114
13056           JMOHEP(2,NHEP+1) = NHEP+2
13057           JDAHEP(2,NHEP+1) = NHEP+2
13058           JMOHEP(2,NHEP+2) = NHEP+1
13059           JDAHEP(2,NHEP+2) = NHEP+1
13060           JMOHEP(1,NHEP+1) = IOUT(1)
13061           JMOHEP(1,NHEP+2) = IOUT(1)
13062 C--setup for decay to leptons
13063         ELSE
13064           ISTHEP(NHEP+1) = 193
13065           ISTHEP(NHEP+2) = 193
13066           JMOHEP(1,NHEP+1) = IOUT(1)
13067           JMOHEP(1,NHEP+2) = IOUT(1)
13068           JMOHEP(2,NHEP+1) = JMOHEP(1,IOUT(1))
13069           JMOHEP(2,NHEP+2) = JMOHEP(1,IOUT(1))
13070           JDAHEP(1,NHEP+1) = 0
13071           JDAHEP(1,NHEP+2) = 0
13072           JDAHEP(2,NHEP+1) = 0
13073           JDAHEP(2,NHEP+2) = 0
13074         ENDIF
13075         NHEP=NHEP+2
13076 C--finish entering the spin information in the common block
13077         IF(SYSPIN) THEN
13078           JDASPN(1,IDSPIN) = NSPN+1
13079           JDASPN(2,IDSPIN) = NSPN+3
13080           DO 6 I=1,3
13081           JMOSPN(NSPN+I  ) = IDSPIN
13082           DECSPN(NSPN+I  ) = .FALSE.
13083           IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
13084             RHOSPN(1,1,NSPN+I) = ONE
13085             RHOSPN(2,1,NSPN+I) = ZERO
13086             RHOSPN(1,2,NSPN+I) = ZERO
13087             RHOSPN(2,2,NSPN+I) = ZERO
13088           ELSE
13089             RHOSPN(1,1,NSPN+I) = HALF
13090             RHOSPN(2,1,NSPN+I) = ZERO
13091             RHOSPN(1,2,NSPN+I) = ZERO
13092             RHOSPN(2,2,NSPN+I) = HALF
13093           ENDIF
13094           DO 6 J=1,2
13095  6        JDASPN(J,NSPN+I) =0
13096           NSPN = NSPN+3
13097           IDSPN (NSPN-1) = NHEP-1
13098           IDSPN (NSPN  ) = NHEP
13099           ISNHEP(NHEP-1) = NSPN-1
13100           ISNHEP(NHEP  ) = NSPN
13101         ENDIF
13102 C--perform the parton shower for the decay products of the gauge boson
13103         IF(ID1.LE.12) CALL HWBGEN
13104 C--error issue warning
13105       ELSE
13106         CALL HWWARN('HWDSM3',500,*999)
13107       ENDIF
13108  999  END
13109 CDECK  ID>, HWDSM4.
13110 *CMZ :-        -11/10/01  14:03:42  by  Peter Richardson
13111 *-- Author :    Peter Richardson
13112 C-----------------------------------------------------------------------
13113       SUBROUTINE HWDSM4(IOPT,ID,IOUT1,IOUT2,IMODE)
13114 C-----------------------------------------------------------------------
13115 C     Subroutine to perform the four body decays
13116 C     IOPT = 1 select decay mode and generate momenta
13117 C     IOPT = 2 enter first decays and perform parton shower
13118 C-----------------------------------------------------------------------
13119       INCLUDE 'HERWIG65.INC'
13120       INTEGER IOPT,ID,IOUT1,IOUT2,IB(2),I,IDF(4),ITYPE(2),IMODE,
13121      &     IDP(4+NDIAGR),ID1,ID2,J
13122       DOUBLE PRECISION CV,CA,A,B,MS,MWD,MR,M,M2,P(5,5),PW(5,2),BR
13123       COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
13124       SAVE PW,ITYPE
13125 C--generate the decay
13126       IF(IOPT.EQ.1) THEN
13127         IB(1) = IDHW(IOUT1)
13128         IB(2) = IDHW(IOUT2)
13129 C--select the decays of the bosons
13130         DO 1 I=1,2
13131         CALL HWDBOZ(IB(I),IDF(2*I-1),IDF(2*I),CV,CA,BR,1)
13132         ITYPE(I) = IDF(2*I-1)
13133         IF(IB(I).EQ.199) ITYPE(I)    = ITYPE(I)+1
13134         IF(ITYPE(I).GT.120) ITYPE(I) = ITYPE(I)-114
13135  1      IF(IB(I).NE.200) ITYPE(I)    = ITYPE(I)/2
13136 C--generate the momenta of the decay products
13137         CALL HWD4ME(ID,ITYPE(1),ITYPE(2),IMODE)
13138         DO 2 I=1,2
13139         CALL HWVSUM(4,P(1,2*I),P(1,2*I+1),PW(1,I))
13140  2      CALL HWUMAS(PW(1,I))
13141         CALL HWVEQU(5,PW(1,1),PHEP(1,IOUT1))
13142         CALL HWVEQU(5,PW(1,2),PHEP(1,IOUT2))
13143         IF(SYSPIN) THEN
13144           IDSPN(1)     = JDAHEP(1,ID)
13145           DECSPN(1)    = .FALSE.
13146           ISNHEP(JDAHEP(1,ID)) = 1
13147           JDASPN(1,1)  = 2
13148           JDASPN(2,1)  = 5
13149           DO 4 I=2,5
13150           DECSPN(I) = .FALSE.
13151  4        JMOSPN(I) = 1
13152         ENDIF
13153       ELSEIF(IOPT.EQ.2) THEN
13154         IB(1) = JDAHEP(1,IOUT1)
13155         IB(2) = JDAHEP(1,IOUT2)
13156         DO 3 I=1,2
13157           ISTHEP(IB(I)) = 195
13158           JDAHEP(1,IB(I)) = NHEP+1
13159           JDAHEP(2,IB(I)) = NHEP+2
13160 C--find the ID's of the particles
13161           IF(IDHW(IB(I)).EQ.200) THEN
13162             ID1 = ITYPE(I)
13163             IF(ITYPE(I).GT.6) ID1 = ID1+114
13164             ID2 = ID1+6
13165           ELSE
13166             ID1 = 2*ITYPE(I)-1
13167             IF(ITYPE(I).GT.3) ID1 = ID1+114
13168             ID2 = ID1+7
13169             IF(IDHW(IB(I)).EQ.198) THEN
13170               J   = ID1+6
13171               ID1 = ID2-6
13172               ID2 = J
13173             ENDIF
13174           ENDIF
13175 C--put id's of decay products into the event record
13176           IDHW(NHEP+1)  = ID1
13177           IDHW(NHEP+2)  = ID2
13178           IDHEP(NHEP+1) = IDPDG(ID1)
13179           IDHEP(NHEP+2) = IDPDG(ID2)
13180 C--boost decay products momenta to rest frame of boson
13181           CALL HWULOF(PW(1,I),P(1,2*I  ),P(1,2*I  ))
13182           CALL HWULOF(PW(1,I),P(1,2*I+1),P(1,2*I+1))
13183 C--boost back to lab using new boson
13184           CALL HWULOB(PHEP(1,IB(I)),P(1,2*I  ),PHEP(1,NHEP+1))
13185           CALL HWULOB(PHEP(1,IB(I)),P(1,2*I+1),PHEP(1,NHEP+2))
13186 C--setup for decay to quarks
13187           IF(ID1.LE.12) THEN
13188             ISTHEP(NHEP+1) = 113
13189             ISTHEP(NHEP+2) = 114
13190             JMOHEP(2,NHEP+1) = NHEP+2
13191             JDAHEP(2,NHEP+1) = NHEP+2
13192             JMOHEP(2,NHEP+2) = NHEP+1
13193             JDAHEP(2,NHEP+2) = NHEP+1
13194             JMOHEP(1,NHEP+1) = IB(I)
13195             JMOHEP(1,NHEP+2) = IB(I)
13196 C--setup for decay to leptons
13197           ELSE
13198             ISTHEP(NHEP+1) = 193
13199             ISTHEP(NHEP+2) = 193
13200             JMOHEP(1,NHEP+1) = IB(I)
13201             JMOHEP(1,NHEP+2) = IB(I)
13202             JMOHEP(2,NHEP+1) = JMOHEP(1,IB(I))
13203             JMOHEP(2,NHEP+2) = JMOHEP(1,IB(I))
13204           ENDIF
13205 C--enter the information in the spin common block
13206           IF(SYSPIN) THEN
13207             IDSPN(2*I  ) = NHEP+1
13208             IDSPN(2*I+1) = NHEP+2
13209             ISNHEP(NHEP+1) = 2*I
13210             ISNHEP(NHEP+2) = 2*I+1
13211           ENDIF
13212           NHEP=NHEP+2
13213 C--perform the parton shower for the decay products of the gauge boson
13214           IF(ID1.LE.12) CALL HWBGEN
13215  3      CONTINUE
13216       ENDIF
13217  999  END
13218 CDECK  ID>, HWDTAU.
13219 *CMZ :-        -17/10/01  09:42:21  by  Peter Richardson
13220 *-- Author :    Peter Richardson
13221 C-----------------------------------------------------------------------
13222       SUBROUTINE HWDTAU(IOPT,IHEP,POL)
13223 C-----------------------------------------------------------------------
13224 C     HERWIG-TAUOLA interface to perform tau decays using TAUOLA rather
13225 C     than HERWIG
13226 C     IOPT = 0 initialises
13227 C     IOPT = 1 performs decay
13228 C     IOPT = 2 write outs final TAUOLA information
13229 C-----------------------------------------------------------------------
13230       INCLUDE 'HERWIG65.INC'
13231       INTEGER IOPT,IHEP,ID,ITAU,I,IMO,NHEPPO
13232       DOUBLE PRECISION POL,PLAB(4)
13233       REAL POL1(4)
13234       CHARACTER *8 DUMMY
13235       DATA PLAB/0.0D0,0.0D0,0.0D0,1.0D0/
13236 C--common block for PHOTOS
13237       LOGICAL QEDRAD
13238       COMMON /PHOQED/ QEDRAD(NMXHEP)
13239 C--common blocks for TAUOLA
13240       INTEGER NP1,NP2
13241       COMMON /TAUPOS/ NP1, NP2
13242       DOUBLE PRECISION Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
13243       COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
13244 C--initialisation
13245       IF(IOPT.EQ.-1) THEN
13246 C--initialise TAUOLA
13247         CALL INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
13248         CALL INIMAS
13249         CALL INIPHX(0.01d0)
13250         CALL INITDK
13251 C--generate a decay
13252       ELSEIF(IOPT.EQ.1) THEN
13253         ISTHEP(IHEP)=195
13254         ID = IDHW(IHEP)
13255         IMO = IHEP
13256  1      IMO = JMOHEP(1,IMO)
13257         IF(IDHW(IMO).EQ.ID) GOTO 1
13258 C--id of tau for tauola
13259         IF(ID.EQ.125) THEN
13260           ITAU = 2
13261           NP1 = IHEP
13262           NP2 = IHEP
13263         ELSEIF(ID.EQ.131) THEN
13264           ITAU = 1
13265           NP1 = IHEP
13266           NP2 = IHEP
13267         ELSE
13268           CALL HWWARN('HWDTAU',501,*999)
13269         ENDIF
13270 C--set up the tau polarization
13271         POL1(1) = 0.
13272         POL1(2) = 0.
13273         POL1(3) = REAL(POL)
13274         POL1(4) = 0.
13275 C--tau momentum
13276         DO I=1,4
13277           P1(I) = PHEP(I,IHEP)
13278           P2(I) = PHEP(I,IHEP)
13279 C--we measure tau spins in lab frame
13280           Q1(I) = PLAB(I)
13281         ENDDO
13282 C--perform the decay and generate QED radiation if needed
13283         NHEPPO=NHEP
13284         CALL DEXAY(ITAU,POL1)
13285         IF(IFPHOT.EQ.1) THEN
13286           IF(ID.EQ.1) THEN
13287             CALL PHOTOS(NP1)
13288           ELSE
13289             CALL PHOTOS(NP2)
13290           ENDIF
13291         ENDIF
13292         IF(NHEPPO.NE.NHEP) THEN
13293           DO 2 I=NHEPPO+1,NHEP
13294           CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
13295  2        CALL HWUIDT(1,IDHEP(I),IDHW(I),DUMMY)
13296         ENDIF
13297 C--write out info at end
13298       ELSEIF(IOPT.EQ.2) THEN
13299         CALL DEXAY(100,POL1)
13300 C--otherwise issue warning
13301       ELSE
13302         CALL HWWARN('HWDTAU',500,*999)
13303       ENDIF
13304  999  END
13305 CDECK  ID>, HWDTHR.
13306 *CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
13307 *-- Author :    Bryan Webber
13308 C-----------------------------------------------------------------------
13309       SUBROUTINE HWDTHR(P0,P1,P2,P3,WEIGHT)
13310 C-----------------------------------------------------------------------
13311 C     GENERATES THREE-BODY DECAY 0->1+2+3 DISTRIBUTED
13312 C     ACCORDING TO PHASE SPACE * WEIGHT
13313 C-----------------------------------------------------------------------
13314       DOUBLE PRECISION HWRGEN,HWRUNI,A,B,C,D,AA,BB,CC,DD,EE,FF,PP,QQ,WW,
13315      & RR,PCM1,PC23,WEIGHT,P0(5),P1(5),P2(5),P3(5),P23(5),TWO
13316       EXTERNAL HWRGEN,HWRUNI,WEIGHT
13317       PARAMETER (TWO=2.D0)
13318       A=P0(5)+P1(5)
13319       B=P0(5)-P1(5)
13320       C=P2(5)+P3(5)
13321       IF (B.LT.C) CALL HWWARN('HWDTHR',100,*999)
13322       D=ABS(P2(5)-P3(5))
13323       AA=A*A
13324       BB=B*B
13325       CC=C*C
13326       DD=D*D
13327       EE=(B-C)*(A-D)
13328       A=0.5*(AA+BB)
13329       B=0.5*(CC+DD)
13330       C=4./(A-B)**2
13331 C
13332 C  CHOOSE MASS OF SUBSYSTEM 23 WITH PRESCRIBED DISTRIBUTION
13333 C
13334    10 FF=HWRUNI(0,BB,CC)
13335       PP=(AA-FF)*(BB-FF)
13336       QQ=(CC-FF)*(DD-FF)
13337       WW=WEIGHT(FF,A,B,C)**2
13338       RR=EE*FF*HWRGEN(0)
13339       IF (PP*QQ*WW.LT.RR*RR) GOTO 10
13340 C
13341 C  FF IS MASS SQUARED OF SUBSYSTEM 23.
13342 C
13343 C  DO 2-BODY DECAYS 0->1+23, 23->2+3
13344 C
13345       P23(5)=SQRT(FF)
13346       PCM1=SQRT(PP)*0.5/P0(5)
13347       PC23=SQRT(QQ)*0.5/P23(5)
13348       CALL HWDTWO(P0,P1,P23,PCM1,TWO,.TRUE.)
13349       CALL HWDTWO(P23,P2,P3,PC23,TWO,.TRUE.)
13350   999 END
13351 CDECK  ID>, HWDTOP.
13352 *CMZ :-        -09/12/92  11.03.46  by  Bryan Webber
13353 *-- Author :    Bryan Webber
13354 C-----------------------------------------------------------------------
13355       SUBROUTINE HWDTOP(DECAY)
13356 C-----------------------------------------------------------------------
13357 C     DECIDES WHETHER TO DO TOP QUARK DECAY BEFORE HADRONIZATION
13358 C-----------------------------------------------------------------------
13359       INCLUDE 'HERWIG65.INC'
13360       LOGICAL DECAY
13361       DECAY=RMASS(6).GT.130D0
13362       END
13363 CDECK  ID>, HWDTWO.
13364 *CMZ :-        -27/01/94  17.38.49  by  Mike Seymour
13365 *-- Author :    Bryan Webber & Mike Seymour
13366 C-----------------------------------------------------------------------
13367       SUBROUTINE HWDTWO(P0,P1,P2,PCM,COSTH,ZAXIS)
13368 C-----------------------------------------------------------------------
13369 C     GENERATES DECAY 0 -> 1+2
13370 C
13371 C     PCM IS CM MOMENTUM
13372 C
13373 C     COSTH = COS THETA IN P0 REST FRAME (>1 FOR ISOTROPIC)
13374 C     IF ZAXIS=.TRUE., COS THETA IS MEASURED FROM THE ZAXIS
13375 C     IF .FALSE., IT IS MEASURED FROM P0'S DIRECTION
13376 C-----------------------------------------------------------------------
13377       DOUBLE PRECISION HWRUNI,ONE,ZERO,PCM,COSTH,C,S,P0(5),P1(5),P2(5),
13378      & PP(5),R(9)
13379       LOGICAL ZAXIS
13380       EXTERNAL HWRUNI
13381       PARAMETER (ZERO=0.D0, ONE=1.D0)
13382 C--CHOOSE C.M. ANGLES
13383       C=COSTH
13384       IF (C.GT.ONE) C=HWRUNI(0,-ONE,ONE)
13385       S=SQRT(ONE-C*C)
13386       CALL HWRAZM(PCM*S,PP(1),PP(2))
13387 C--PP IS MOMENTUM OF 2 IN C.M.
13388       PP(3)=-PCM*C
13389       PP(4)=SQRT(P2(5)**2+PCM**2)
13390       PP(5)=P2(5)
13391 C--ROTATE IF NECESSARY
13392       IF (COSTH.LE.ONE.AND..NOT.ZAXIS) THEN
13393         CALL HWUROT(P0,ONE,ZERO,R)
13394         CALL HWUROB(R,PP,PP)
13395       ENDIF
13396 C--BOOST FROM C.M. TO LAB FRAME
13397       CALL HWULOB(P0,PP,P2)
13398       CALL HWVDIF(4,P0,P2,P1)
13399       END
13400 CDECK  ID>, HWDWWT.
13401 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
13402 *-- Author :    Bryan Webber
13403 C-----------------------------------------------------------------------
13404       FUNCTION HWDWWT(EMSQ,A,B,C)
13405 C-----------------------------------------------------------------------
13406 C     MATRIX ELEMENT SQUARED FOR V-A WEAK DECAY
13407 C-----------------------------------------------------------------------
13408       DOUBLE PRECISION HWDWWT,EMSQ,A,B,C
13409       HWDWWT=(A-EMSQ)*(EMSQ-B)*C
13410       END
13411 CDECK  ID>, HWDHWT.
13412 *CMZ :-        -26/06/01  14.44.53  by  Stefano Moretti
13413 *-- Author :    Stefano Moretti
13414 C-----------------------------------------------------------------------
13415       FUNCTION HWDHWT(EMSQ,DUMMYA,DUMMYB,DUMMYC)
13416 C-----------------------------------------------------------------------
13417 C     MATRIX ELEMENT SQUARED FOR
13418 C     ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) WEAK DECAY
13419 C-----------------------------------------------------------------------
13420       INCLUDE 'HERWIG65.INC'
13421       COMMON/FFS/TB,BT
13422       COMMON/SFF/IT1,IB1,IT2,IB2
13423       DOUBLE PRECISION TB,BT
13424       INTEGER IT1,IB1,IT2,IB2
13425       DOUBLE PRECISION TBH,HBT,CB1,TB1,CB2,TB2
13426       DOUBLE PRECISION DUMMYA,DUMMYB,DUMMYC
13427       DOUBLE PRECISION HWDHWT,EMSQ
13428       CB1=RMASS(IT1)**2
13429       TB1=RMASS(IB1)**2
13430       CB2=RMASS(IT2)**2
13431       TB2=RMASS(IB2)**2
13432 C use formula (4.52) page 217 of `Higgs Hunter Guide'.
13433       TBH=(TB1+CB1-EMSQ)*(TB1*TB*TB+CB1/TB/TB)+4.*TB1*CB1
13434 C use formula (B. 1) page 411 of `Higgs Hunter Guide'.
13435       HBT=(EMSQ-TB2-CB2)*(TB2*BT*BT+CB2/BT/BT)-4.*TB2*CB2
13436       HWDHWT=TBH*HBT
13437       HWDHWT=ABS(HWDHWT)*SQRT(EMSQ)
13438       END
13439 CDECK  ID>, HWDXLM.
13440 *CMZ :-        -07/09/00  10:06:23  by  Peter Richardson
13441 *-- Author :    Ian Knowles
13442 C-----------------------------------------------------------------------
13443       SUBROUTINE HWDXLM(DKVRTX,STAB)
13444 C-----------------------------------------------------------------------
13445 C     Sets STAB=.TRUE. if DKVRTX lies outside the specified region.
13446 C  Revised 05/09/00 by BRW to put parameters in common
13447 C-----------------------------------------------------------------------
13448       INCLUDE 'HERWIG65.INC'
13449       DOUBLE PRECISION DKVRTX(4),RR
13450       LOGICAL STAB
13451       STAB=.FALSE.
13452       RR=DKVRTX(1)**2+DKVRTX(2)**2
13453       IF (IOPDKL.EQ.1) THEN
13454 C Cylindrical geometry
13455          IF (RR.GE.DXRCYL**2.OR.ABS(DKVRTX(3)).GE.DXZMAX) STAB=.TRUE.
13456       ELSEIF (IOPDKL.EQ.2) THEN
13457 C Spherical geometry
13458          RR=RR+DKVRTX(3)**2
13459          IF (RR.GE.DXRSPH**2) STAB=.TRUE.
13460       ELSE
13461 C User supplied geometry -- missing
13462          CALL HWWARN('HWDXLM',500,*999)
13463       ENDIF
13464   999 END
13465 CDECK  ID>, HWECIR.
13466 *CMZ :-        -11/05/01  15.44.55  by  Mike Seymour
13467 *-- Author :    Mike Seymour
13468 C-----------------------------------------------------------------------
13469       FUNCTION HWECIR(Y)
13470 C-----------------------------------------------------------------------
13471 C   INTEGRAND OF BEAMSTRAHLUNG FUNCTION INTEGRATION
13472 C   NOTE THAT THE JACOBIAN TRANSFORMATION (1-Z)^ETA HAS ETA HARDCODED
13473 C-----------------------------------------------------------------------
13474       IMPLICIT NONE
13475       DOUBLE PRECISION HWECIR,Y,Z,ETA,CIRCEE
13476       EXTERNAL CIRCEE
13477       ETA=0.6D0
13478       Z=1-Y**(1/(1-ETA))
13479       HWECIR=(1-Z)**ETA/(1-ETA)*CIRCEE(Z,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
13480       END
13481 CDECK  ID>, HWEFIN.
13482 *CMZ :-        -15/07/02  17.56.53  by  Peter Richardson
13483 *-- Author :    Bryan Webber
13484 C-----------------------------------------------------------------------
13485       SUBROUTINE HWEFIN
13486 C-----------------------------------------------------------------------
13487 C     TERMINAL CALCULATIONS ON ELEMENTARY PROCESS
13488 C     Modified 28/03/01 by BRW to handle negative weights
13489 C     Modified 15/07/02 by PR for Les Houches Accord
13490 C-----------------------------------------------------------------------
13491       INCLUDE 'HERWIG65.INC'
13492       INTEGER I
13493       DOUBLE PRECISION RNWGT,SPWGT,ERWGT
13494 C--Les Houches Common Block
13495       INTEGER MAXPUP
13496       PARAMETER(MAXPUP=100)
13497       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
13498       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
13499       COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
13500      &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
13501      &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
13502       IF(TAUDEC.EQ.'TAUOLA') CALL HWDTAU(2,0,0.0D0)
13503       IF (NWGTS.EQ.0) THEN
13504         WRITE (6,1)
13505         WRITE (6,10)
13506    10   FORMAT(10X,'NO WEIGHTS GENERATED')
13507         RETURN
13508       ENDIF
13509 C--output Les Houches common block information
13510       IF(IPROC.LE.0) THEN
13511 C--WRITE THE HEADER
13512         WRITE(6,13)
13513         WRITE(6,14)
13514 C--FOR THE FIRST WEIGHT OPTION CALCULATE THE CROSS SECTION
13515         IF(ABS(IDWTUP).EQ.1) THEN
13516           DO I=1,NPRUP
13517             RNWGT     = 1.0D0/DBLE(LHIWGT(I))
13518             LHXSCT(I) = LHWGT(I)*RNWGT
13519             LHXERR(I) = SQRT(MAX(LHWGTS(I)*RNWGT-LHXSCT(I)**2,ZERO))
13520             LHXERR(I) = LHXERR(I)*SQRT(RNWGT)
13521             LHXSCT(I) = LHXSCT(I)*1.0D3
13522             LHXERR(I) = LHXERR(I)*1.0D3
13523             LHXMAX(I) = LHXMAX(I)*1.0D3
13524           ENDDO
13525 C--FOR THE SECOND WEIGHT OPTION THIS WAS AN INPUT
13526         ELSEIF(ABS(IDWTUP).EQ.2) THEN
13527           DO I=1,NPRUP
13528             LHXMAX(I) = LHXMAX(I)*1.0D3
13529           ENDDO
13530         ENDIF
13531         IF(ABS(IDWTUP).LE.2) THEN
13532           AVWGT = ZERO
13533           ERWGT = ZERO
13534           DO I=1,NPRUP
13535             WRITE(6,15) LPRUP(I),LHXSCT(I),LHXERR(I),LHXMAX(I)*1.0D-3,
13536      &            LHNEVT(I)
13537             AVWGT = AVWGT+LHXSCT(I)
13538             ERWGT = ERWGT+LHXERR(I)**2
13539           ENDDO
13540           AVWGT = AVWGT*1.0D-3
13541           ERWGT = SQRT(ERWGT)*1.0D-3
13542         ELSE
13543           RNWGT=1./FLOAT(NWGTS)
13544           IF (NEGWTS) AVABW=ABWSUM*RNWGT
13545           AVWGT=WGTSUM*RNWGT
13546           SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
13547           ERWGT=SPWGT*SQRT(RNWGT)
13548           IF (.NOT.NOWGT) WGTMAX=AVWGT
13549           IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
13550         ENDIF
13551 C--STANDARD HERWIG OPTION
13552       ELSE
13553         RNWGT=1./FLOAT(NWGTS)
13554         IF (NEGWTS) AVABW=ABWSUM*RNWGT
13555         AVWGT=WGTSUM*RNWGT
13556         SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
13557         ERWGT=SPWGT*SQRT(RNWGT)
13558         IF (.NOT.NOWGT) WGTMAX=AVWGT
13559         IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
13560       ENDIF
13561 C--PRINT OUT THE INFO
13562       WRITE (6,1)
13563  1    FORMAT(/10X,'OUTPUT ON ELEMENTARY PROCESS'/)
13564       IF (NEGWTS) THEN
13565          WRITE (6,12) NEVHEP,NNEGEV,NWGTS,NNEGWT,AVWGT,SPWGT,
13566      &        AVABW,WBIGST,WGTMAX,IPROC,
13567      &        1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
13568       ELSE
13569          WRITE (6,11) NEVHEP,NWGTS,AVWGT,SPWGT,WBIGST,WGTMAX,
13570      &        IPROC,
13571      &        1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
13572       ENDIF
13573  11   FORMAT(1P,
13574      &     10X,'N.B. NEGATIVE WEIGHTS NOT ALLOWED'//
13575      &     10X,'NUMBER OF EVENTS   = ',I11/
13576      &     10X,'NUMBER OF WEIGHTS  = ',I11/
13577      &     10X,'MEAN VALUE OF WGT  =',E12.4/
13578      &     10X,'RMS SPREAD IN WGT  =',E12.4/
13579      &     10X,'ACTUAL MAX WEIGHT  =',E12.4/
13580      &     10X,'ASSUMED MAX WEIGHT =',E12.4//
13581      &     10X,'PROCESS CODE IPROC = ',I11/
13582      &     10X,'CROSS SECTION (PB) =',G12.4/
13583      &     10X,'ERROR IN C-S  (PB) =',G12.4/
13584      &     10X,'EFFICIENCY PERCENT =',G12.4)
13585  12   FORMAT(1P,
13586      &     10X,'N.B. NEGATIVE WEIGHTS ALLOWED'//
13587      &     10X,'NUMBER OF EVENTS   = ',I11/
13588      &     10X,'NEGATIVE  EVENTS   = ',I11/
13589      &     10X,'NUMBER OF WEIGHTS  = ',I11/
13590      &     10X,'NEGATIVE  WEIGHTS  = ',I11/
13591      &     10X,'MEAN VALUE OF WGT  =',E12.4/
13592      &     10X,'RMS SPREAD IN WGT  =',E12.4/
13593      &     10X,'MEAN ABS WEIGHT    =',E12.4/
13594      &     10X,'ACTUAL MAX ABS WGT =',E12.4/
13595      &     10X,'ASSUMED MAXABS WGT =',E12.4//
13596      &     10X,'PROCESS CODE IPROC = ',I11/
13597      &     10X,'CROSS SECTION (PB) =',G12.4/
13598      &     10X,'ERROR IN C-S  (PB) =',G12.4/
13599      &     10X,'EFFICIENCY PERCENT =',G12.4)
13600  13   FORMAT(/1P,10X,'OUTPUT ON LES HOUCHES EVENTS'/)
13601  14   FORMAT(/1P,5X,' PROC CODE',1X,' XSECT(pb)     ',1X,
13602      &     '  XERR(pb)  ',1X,'   Max wgt(nb)',1X,'No. of events'/)
13603  15   FORMAT(5X,I7,E15.5,1X,E15.5,1X,E15.5,2X,I7)
13604       END
13605 CDECK  ID>, HWEGAM.
13606 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
13607 *-- Author :    Bryan Webber & Luca Stanco
13608 C-----------------------------------------------------------------------
13609       SUBROUTINE HWEGAM(IHEP,ZMI,ZMA,WWA)
13610 C-----------------------------------------------------------------------
13611 C     GENERATES A PHOTON IN WEIZSACKER-WILLIAMS (WWA=.TRUE.) OR
13612 C     ELSE EQUIVALENT PHOTON APPROX FROM INCOMING E+, E-, MU+ OR MU-
13613 C-----------------------------------------------------------------------
13614       INCLUDE 'HERWIG65.INC'
13615       DOUBLE PRECISION HWRGEN,HWRUNI,EGMIN,ZMIN,ZMAX,ZGAM,SS,ZMI,ZMA,
13616      & PPL,PMI,QT2,Q2,QQMIN,QQMAX,S0,A
13617       INTEGER IHEP,IHADIS
13618       LOGICAL WWA
13619       EXTERNAL HWRGEN,HWRUNI
13620       DATA EGMIN/5.D0/
13621       IF (IERROR.NE.0)  RETURN
13622       IF (IHEP.LT.1.OR.IHEP.GT.2) CALL HWWARN('HWEGAM',500,*999)
13623       SS=PHEP(5,3)
13624       IF (IHEP.EQ.1) THEN
13625         IHADIS=2
13626       ELSE
13627         IHADIS=1
13628         IF (JDAHEP(1,IHADIS).NE.0) IHADIS=JDAHEP(1,IHADIS)
13629       ENDIF
13630 C---DEFINE LIMITS FOR GAMMA MOMENTUM FRACTION
13631       IF (ZMI.LE.ZERO .OR. ZMA.GT.ONE) THEN
13632         CALL HWEGAS(S0)
13633         IF (S0.GT.ZERO) THEN
13634           S0 = (SQRT(S0)+ABS(PHEP(5,IHADIS)))**2-PHEP(5,IHADIS)**2
13635           S0 = MAX(S0,WHMIN**2)
13636           ZMIN = S0 / (SS**2 - PHEP(5,IHEP)**2 - PHEP(5,IHADIS)**2)
13637           ZMAX = ONE
13638         ELSE
13639 C---UNKNOWN PROCESS: USE ENERGY CUTOFF, AND WARN USER
13640           IF (FSTWGT) CALL HWWARN('HWEGAM',1,*999)
13641           ZMIN = EGMIN / PHEP(4,IHEP)
13642           ZMAX = ONE
13643         ENDIF
13644       ELSE
13645         ZMIN=ZMI
13646         ZMAX=ZMA
13647       ENDIF
13648 C---APPLY USER DEFINED CUTS YWWMIN,YWWMAX AND INDIRECT LIMITS ON Z
13649       IF (.NOT.WWA) THEN
13650         ZMIN=MAX(ZMIN,YWWMIN,SQRT(Q2WWMN)/ABS(PHEP(3,IHEP)))
13651         ZMAX=MIN(ZMAX,YWWMAX)
13652       ELSE
13653         ZMAX=MIN(ZMAX,1-PHEP(5,IHEP)/PHEP(4,IHEP))
13654       ENDIF
13655       IF (ZMIN.GE.ZMAX) THEN
13656         GAMWT=ZERO
13657         RETURN
13658       ENDIF
13659 C---GENERATE GAMMA MOMENTUM FRACTION
13660       A=HALF
13661  10   IF (HWRGEN(2).LT.A) THEN
13662         ZGAM=(ZMIN/ZMAX)**HWRGEN(1)*ZMAX
13663       ELSE
13664         ZGAM=(ZMAX-ZMIN)*HWRGEN(1)+ZMIN
13665       ENDIF
13666       GAMWT = GAMWT * .5*ALPHEM/PIFAC *
13667      +     (1+(1-ZGAM)**2)/(A/LOG(ZMAX/ZMIN)+(1-A)/(ZMAX-ZMIN)*ZGAM)
13668       IF (WWA) THEN
13669         GAMWT = GAMWT * LOG((ONE-ZGAM)/ZGAM*(SS/PHEP(5,IHEP))**2)
13670       ELSE
13671 C---Q2WWMN AND Q2WWMX ARE USER-DEFINED LIMITS IN THE Q**2 INTEGRATION
13672         QQMAX=MIN(Q2WWMX,(ZGAM*PHEP(3,IHEP))**2)
13673         QQMIN=MAX(Q2WWMN,(PHEP(5,IHEP)*ZGAM)**2/(1.-ZGAM))
13674         IF (QQMIN.GT.QQMAX) CALL HWWARN('HWEGAM',50,*10)
13675         Q2=EXP(HWRUNI(0,LOG(QQMIN),LOG(QQMAX)))
13676         GAMWT = GAMWT * LOG(QQMAX/QQMIN)
13677       ENDIF
13678       IF (GAMWT.LT.ZERO) GAMWT=ZERO
13679 C---FILL PHOTON
13680       NHEP=NHEP+1
13681       IDHW(NHEP)=59
13682       ISTHEP(NHEP)=3
13683       IDHEP(NHEP)=22
13684       JMOHEP(1,NHEP)=IHEP
13685       JMOHEP(2,NHEP)=0
13686       JDAHEP(1,NHEP)=0
13687       JDAHEP(2,NHEP)=0
13688       JDAHEP(1,IHEP)=NHEP
13689       IF (WWA) THEN
13690 C---FOR COLLINEAR KINEMATICS, ZGAM IS THE ENERGY FRACTION
13691         PHEP(4,NHEP)=PHEP(4,IHEP)*ZGAM
13692         PHEP(3,NHEP)=PHEP(3,IHEP)-SIGN(SQRT(
13693      &     (PHEP(4,IHEP)-PHEP(4,NHEP))**2-PHEP(5,IHEP)**2),PHEP(3,IHEP))
13694         PHEP(2,NHEP)=0
13695         PHEP(1,NHEP)=0
13696         CALL HWUMAS(PHEP(1,NHEP))
13697       ELSE
13698 C---FOR EXACT KINEMATICS, ZGAM IS TAKEN TO BE FRACTION OF (E+PZ)
13699         PPL=ZGAM*(ABS(PHEP(3,IHEP))+PHEP(4,IHEP))
13700         QT2=(ONE-ZGAM)*Q2-(ZGAM*PHEP(5,IHEP))**2
13701         PMI=(QT2-Q2)/PPL
13702         PHEP(5,NHEP)=-SQRT(Q2)
13703         PHEP(4,NHEP)=(PPL+PMI)/TWO
13704         PHEP(3,NHEP)=SIGN((PPL-PMI)/TWO,PHEP(3,IHEP))
13705         CALL HWRAZM(SQRT(QT2),PHEP(1,NHEP),PHEP(2,NHEP))
13706       ENDIF
13707 C---UPDATE OVERALL CM FRAME
13708       JMOHEP(IHEP,3)=NHEP
13709       CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
13710       CALL HWVSUM(4,PHEP(1,NHEP),PHEP(1,3),PHEP(1,3))
13711       CALL HWUMAS(PHEP(1,3))
13712 C---FILL OUTGOING LEPTON
13713       NHEP=NHEP+1
13714       IDHW(NHEP)=IDHW(IHEP)
13715       ISTHEP(NHEP)=1
13716       IDHEP(NHEP)=IDHEP(IHEP)
13717       JMOHEP(1,NHEP)=IHEP
13718       JMOHEP(2,NHEP)=0
13719       JDAHEP(1,NHEP)=0
13720       JDAHEP(2,NHEP)=0
13721       JDAHEP(2,IHEP)=NHEP
13722       CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP-1),PHEP(1,NHEP))
13723       PHEP(5,NHEP)=PHEP(5,IHEP)
13724  999  END
13725 CDECK  ID>, HWEGAS.
13726 *CMZ :-        -18/04/04  10.45.55  by  Mike Seymour
13727 *-- Author :    Bryan Webber & Luca Stanco
13728 C-----------------------------------------------------------------------
13729       SUBROUTINE HWEGAS(S0)
13730 C-----------------------------------------------------------------------
13731 C     FIND MINIMUM INVARIANT MASS SQUARED NEEDED FOR HARD PROCESS, S0
13732 C-----------------------------------------------------------------------
13733       INCLUDE 'HERWIG65.INC'
13734       DOUBLE PRECISION S0,RPM(2)
13735       INTEGER HQ,I
13736       IF (IPRO.EQ.13.OR.IPRO.EQ.14) THEN
13737         S0 = EMMIN**2
13738       ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.18.OR.IPRO.EQ.22.OR.IPRO.EQ.24.OR.
13739      &       IPRO.EQ.50.OR.IPRO.EQ.53.OR.IPRO.EQ.55)THEN
13740         S0 = 4.D0*PTMIN**2
13741       ELSEIF (IPRO.EQ.17.OR.IPRO.EQ.51) THEN
13742         HQ = MOD(IPROC,100)
13743         S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
13744       ELSEIF (IPRO.EQ.16.OR.IPRO.EQ.19.OR.
13745      &       IPRO.EQ.25.OR.IPRO.EQ.26.OR.IPRO.EQ.27.OR.
13746      &       IPRO.EQ.95) THEN
13747         S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
13748       ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN
13749         S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
13750       ELSEIF (IPRO.EQ.33) THEN
13751         IF((MOD(IPROC,10000).EQ.3350).OR.
13752      &       (MOD(IPROC,10000).EQ.3355))THEN
13753           S0 = MAX(2*RMASS(1),RMASS(206))**2
13754         ELSEIF(MOD(IPROC,10000).EQ.3315)THEN
13755           S0 = MAX(2*RMASS(1),RMASS(206),RMASS(203))**2
13756         ELSEIF(MOD(IPROC,10000).EQ.3325)THEN
13757           S0 = MAX(2*RMASS(1),RMASS(206),RMASS(204))**2
13758         ELSEIF(MOD(IPROC,10000).EQ.3335)THEN
13759           S0 = MAX(2*RMASS(1),RMASS(206),RMASS(205))**2
13760         ELSEIF(MOD(IPROC,10000).EQ.3365)THEN
13761           S0 = MAX(2*RMASS(1),RMASS(205),RMASS(203))**2
13762         ELSEIF(MOD(IPROC,10000).EQ.3375)THEN
13763           S0 = MAX(2*RMASS(1),RMASS(205),RMASS(204))**2
13764         ELSE
13765           S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
13766         END IF
13767       ELSEIF ((IPRO.EQ.34).OR.(IPRO.EQ.35)) THEN
13768         S0 = MAX(RMASS(5),RMASS(201+IHIGGS))**2
13769       ELSEIF (IPRO.EQ.36.OR.IPRO.EQ.37) THEN
13770         S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
13771       ELSEIF (IPRO.EQ.38) THEN
13772         IF((MOD(IPROC,10000).EQ.3839).OR.
13773      &       (MOD(IPROC,10000).EQ.3869).OR.
13774      &       (MOD(IPROC,10000).EQ.3899))THEN
13775           S0 = MAX(RMASS(6),RMASS(206))**2
13776         ELSE
13777           S0 = RMASS(201+IHIGGS)**2
13778         END IF
13779       ELSEIF (IPRO.EQ.23) THEN
13780         S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
13781         S0 = (PTMIN+SQRT(PTMIN**2+S0))**2
13782       ELSEIF (IPRO.EQ.20) THEN
13783         S0 = RMASS(6)**2
13784       ELSEIF (IPRO.EQ.21) THEN
13785         S0 = (PTMIN+SQRT(PTMIN**2+RMASS(198)**2))**2
13786 C--PR MOD 7/7/99
13787       ELSEIF (IPRO.EQ.30) THEN
13788         S0 = 4.0D0*(PTMIN**2+RMMNSS**2)
13789       ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
13790         HQ = MOD(IPROC,100)
13791         RPM(1) = RMMNSS
13792         RPM(2) = ZERO
13793         IF(HQ.GE.10.AND.HQ.LT.20) THEN
13794           RPM(1) = ABS(RMASS(450))
13795           IF(HQ.GT.10) RPM(1) = ABS(RMASS(449+MOD(HQ,10)))
13796         ELSEIF(HQ.GE.20.AND.HQ.LT.30) THEN
13797           RPM(1) = ABS(RMASS(454))
13798           IF(HQ.GT.20) RPM(1) = ABS(RMASS(453+MOD(HQ,20)))
13799         ELSEIF(HQ.EQ.30) THEN
13800           RPM(1) = RMASS(449)
13801         ELSEIF(HQ.EQ.40) THEN
13802           IF(IPRO.EQ.40) THEN
13803             RPM(1) = RMASS(425)
13804             DO I=1,5
13805               RPM(1) = MIN(RPM(1),RMASS(425+I))
13806             ENDDO
13807           ELSE
13808             RPM(1) = MIN(RMASS(405),RMASS(406))
13809           ENDIF
13810           RPM(2) = RMASS(198)
13811         ELSEIF(HQ.EQ.50) THEN
13812           IF(IPRO.EQ.40) THEN
13813             RPM(1) = RMASS(425)
13814             DO I=1,5
13815               RPM(1) = MIN(RPM(1),RMASS(425+I))
13816             ENDDO
13817             DO I=1,3
13818               RPM(2) = MIN(RPM(1),RMASS(433+2*I))
13819             ENDDO
13820             RPM(1) = MIN(RPM(1),RPM(2))
13821             RPM(2) = RMASS(203)
13822             DO I=1,2
13823               RPM(2) = MIN(RPM(2),RMASS(204+I))
13824             ENDDO
13825           ELSE
13826             RPM(1) = RMASS(401)
13827             RPM(2) = RMASS(413)
13828             DO I=1,5
13829               RPM(1) = MIN(RPM(1),RMASS(401+I))
13830               RPM(2) = MIN(RPM(2),RMASS(413+I))
13831             ENDDO
13832             RPM(1) = MIN(RPM(1),RPM(2))
13833             RPM(2) = RMASS(203)
13834             DO I=1,2
13835               RPM(2) = MIN(RPM(2),RMASS(204+I))
13836             ENDDO
13837           ENDIF
13838           RPM(2) = RMASS(203)
13839           DO I=1,2
13840             RPM(2) = MIN(RPM(2),RMASS(204+I))
13841           ENDDO
13842         ELSEIF(HQ.GE.60) THEN
13843           RPM(1) = ZERO
13844         ENDIF
13845         RPM(1) = RPM(1)**2
13846         RPM(2) = RPM(2)**2
13847         S0 = RPM(1)+RPM(2)+TWO*(PTMIN**2+
13848      &       SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2)))
13849 C--end of mod
13850 C--PR MOD 9/9/00
13851       ELSEIF (IPRO.EQ.42) THEN
13852         S0 = EMMIN**2
13853       ELSEIF (IPRO.EQ.52) THEN
13854         HQ = MOD(IPROC,100)
13855         S0 = (PTMIN+SQRT(PTMIN**2+RMASS(HQ)**2))**2
13856       ELSEIF (IPRO.EQ.60) THEN
13857         HQ = MOD(IPROC,100)
13858         IF (HQ.EQ.0) THEN
13859           S0 = 4.D0*PTMIN**2
13860         ELSE
13861           IF (HQ.GT.6) HQ=2*HQ+107
13862           IF (HQ.EQ.127) HQ=198
13863           S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
13864         ENDIF
13865       ELSEIF (IPRO.EQ.80) THEN
13866         S0 = WHMIN**2
13867       ELSEIF (IPRO.EQ.90) THEN
13868         S0 = Q2MIN
13869       ELSEIF (IPRO.EQ.91.OR.IPRO.EQ.92) THEN
13870         S0 = Q2MIN+4.D0*PTMIN**2
13871         HQ = MOD(IPROC,100)
13872         IF (HQ.GT.0) S0 = S0+4.D0*RMASS(HQ)**2
13873         IF (IPRO.EQ.91) S0 = MAX(S0,EMMIN**2)
13874       ELSE
13875         S0 = 0
13876       ENDIF
13877       END
13878 CDECK  ID>, HWEINI.
13879 *CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
13880 *-- Author :    Bryan Webber
13881 C-----------------------------------------------------------------------
13882       SUBROUTINE HWEINI
13883 C-----------------------------------------------------------------------
13884 C     INITIALISES ELEMENTARY PROCESS
13885 C     Modified 28/03/01 by BRW to handle negative weights
13886 C-----------------------------------------------------------------------
13887       INCLUDE 'HERWIG65.INC'
13888       DOUBLE PRECISION HWRSET,DUMMY,SAFETY
13889       EXTERNAL HWRSET
13890       PARAMETER (SAFETY=1.001)
13891       INTEGER NBSH,I
13892 C---NO OF WEIGHT GENERATED
13893       NWGTS=0
13894       NNEGWT=0
13895 C---ACCUMULATED WEIGHTS
13896       WGTSUM=ZERO
13897       ABWSUM=ZERO
13898 C---ACCUMULATED WEIGHT-SQUARED
13899       WSQSUM=ZERO
13900 C---CURRENT MAX WEIGHT
13901       WBIGST=ZERO
13902 C---LAST VALUE OF SCALE
13903       EMLST=ZERO
13904 C---NUMBER OF ERRORS REPORTED
13905       NUMER=0
13906 C---NUMBER OF ERRORS UNREPORTED
13907       NUMERU=0
13908 C---FIND MAXIMUM ABSOLUTE WEIGHT IN CASES WHERE THIS IS REQUIRED
13909       IF (NOWGT) THEN
13910         IF (WGTMAX.EQ.ZERO.AND.IPROC.GT.0) THEN
13911           NBSH=IBSH
13912           DUMMY = HWRSET(IBRN)
13913           WRITE(6,10) IPROC,IBRN,NBSH
13914    10     FORMAT(/10X,'INITIAL SEARCH FOR MAX WEIGHT'//
13915      &            10X,'PROCESS CODE IPROC = ',I11/
13916      &            10X,'RANDOM NO. SEED 1  = ',I11/
13917      &            10X,'           SEED 2  = ',I11/
13918      &            10X,'NUMBER OF SHOTS    = ',I11)
13919           NEVHEP=0
13920           DO 11 I=1,NBSH
13921           CALL HWEPRO
13922    11     CONTINUE
13923           WRITE(6,20)
13924    20     FORMAT(/10X,'INITIAL SEARCH FINISHED')
13925           IF (WBIGST*NWGTS.LT.SAFETY*WGTSUM)
13926      &                 WGTMAX=SAFETY*WBIGST
13927           CALL HWEFIN
13928           NWGTS=0
13929           NNEGWT=0
13930           WGTSUM=ZERO
13931           WSQSUM=ZERO
13932           ABWSUM=ZERO
13933           WBIGST=ZERO
13934         ELSE
13935           WRITE(6,21) AVWGT,WGTMAX
13936    21     FORMAT(/1P,10X,'INPUT EVT WEIGHT   =',E12.4/
13937      &               10X,'INPUT MAX WEIGHT   =',E12.4)
13938         ENDIF
13939       ENDIF
13940 C---RESET RANDOM NUMBER
13941       DUMMY = HWRSET(NRN)
13942       ISTAT=5
13943   999 END
13944 CDECK  ID>, HWEISR.
13945 *CMZ :-        -01/04/99  19.55.17  by  Mike Seymour
13946 *-- Author :    Mike Seymour
13947 C-----------------------------------------------------------------------
13948       SUBROUTINE HWEISR(IHEP)
13949 C-----------------------------------------------------------------------
13950 C     GENERATES AN ISR PHOTON FROM INCOMING E+, E-, MU+ OR MU-
13951 C-----------------------------------------------------------------------
13952       INCLUDE 'HERWIG65.INC'
13953       DOUBLE PRECISION CIRCKP(2)
13954       COMMON /HWCIR2/CIRCKP
13955       DOUBLE PRECISION HWRGEN,QSQMAX,QSQMIN,A,B,B1,B2,B3,B4,B5,B6,B7,B8,
13956      $ R,AA,T0,T1,C1,C2,T,Z(2),QSQ(2),PHI(2),C,NWID,NMASS
13957       INTEGER IHEP,I,J
13958       EXTERNAL HWRGEN
13959       SAVE Z,QSQ,PHI
13960 C---IF ZMXISR IS ZERO, THERE CAN BE NO ISR
13961       IF (ZMXISR.EQ.ZERO.OR.(IPRO.GT.3.AND.IPRO.LT.6)
13962      &     .OR.IPRO.GT.12.OR.IPROC.EQ.850) RETURN
13963 C---CHECK CONSISTENCY OF TMNISR AND ZMXISR
13964       IF (ZMXISR**2.LT.TMNISR) CALL HWWARN('HWEISR',200,*999)
13965 C---CALCULATE VIRTUALITY LIMITS
13966       QSQMAX=4*PHEP(4,IHEP)**2
13967       QSQMIN=PHEP(5,IHEP)**2
13968 C---AND THEREFORE THE Z DEPENDENCE
13969       A=ALPHEM/PIFAC
13970       B=A*(LOG(QSQMAX/QSQMIN)-1)
13971 C---DECIDE HOW MUCH WEIGHT TO GIVE THE Z RESONANCE
13972       IF (IHEP.EQ.1) THEN
13973         IF (IPRO.EQ.1.OR.IPRO.EQ.6.OR.IPRO.EQ.8) THEN
13974           AA=10
13975         ELSEIF (IPRO.EQ.2) THEN
13976           AA=0
13977         ELSEIF (IPRO.EQ.3.OR.IPRO.EQ.7.OR.IPRO.EQ.10.OR.IPRO.EQ.11) THEN
13978           AA=1
13979         ELSEIF (IPRO.EQ.9) THEN
13980           AA=0
13981           IF((MOD(IPROC,10000).EQ.960).OR.
13982      &       (MOD(IPROC,10000).EQ.970))THEN
13983             AA=1
13984           ELSE
13985             CONTINUE
13986           ENDIF
13987         ELSE
13988           RETURN
13989         ENDIF
13990 C--set up the parameters for the resonance
13991         IF(IPRO.NE.8) THEN
13992 C--first the standard parameters if smoothing the Z resonance
13993           T0=RMASS(200)**2/QSQMAX
13994           T1=GAMZ*RMASS(200)/QSQMAX
13995         ELSE
13996 C--now the parameters for a resonant sneutrino in RPV
13997 C--uses the average of the muon and tau sneutrino mass and either the
13998 C--larger width or the difference in masses (whichever is larger)
13999           NMASS = HALF*(RMASS(428)+RMASS(430))
14000           NWID  = MAX(HBAR/RLTIM(428),HBAR/RLTIM(430))
14001           NWID  = MAX(NWID,ABS(RMASS(428)-RMASS(430)))
14002           T0    = NMASS**2/QSQMAX
14003           T1    = NWID*NMASS/QSQMAX
14004         ENDIF
14005         IF (T0.GT.ONE) THEN
14006           T0=0
14007           AA=0
14008         ENDIF
14009         AA=AA*(1-T0)
14010 C---GENERATE A T VALUE BETWEEN TMNISR AND 1 ACCORDING TO:
14011 C   ( b**2*log(zmxisr**2/t)/t + 2*b*(1-(1-zmxisr)**b)*((1-t)**(2*b-1)+1/t
14012 C     +(1-t0)**(2b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr**2-t)
14013 C  +( 2*b*(1-zmxisr)**b*((1-t)**(b-1)+1/t
14014 C     +(1-t0)**(b-1)*aa*t1/((t-t0)**2+t1**2))  ) *theta(zmxisr-t)
14015 C  +( (1-zmxisr)**(2*b)                        ) *delta(1-t)
14016         B1=(1-ZMXISR)**(2*B)
14017         B2=B1+2*(1-ZMXISR)**B*((1-TMNISR)**B-(1-ZMXISR)**B)
14018         B3=B2+2*B*(1-ZMXISR)**B*LOG(ZMXISR/TMNISR)
14019         B4=B3+2*B*(1-ZMXISR)**B*AA*(1-T0)**(B-1)
14020      $       *(ATAN((ZMXISR-T0)/T1)-ATAN((TMNISR-T0)/T1))
14021         B5=B4+(1-(1-ZMXISR)**B)*((1-TMNISR)**(2*B)-(1-ZMXISR**2)**(2*B))
14022         B6=B5+2*B*(1-(1-ZMXISR)**B)*LOG(ZMXISR**2/TMNISR)
14023         B7=B6+B**2*LOG(ZMXISR**2/TMNISR)**2/2
14024         B8=B7+2*B*(1-(1-ZMXISR)**B)*AA*(1-T0)**(2*B-1)
14025      $       *(ATAN((ZMXISR**2-T0)/T1)-ATAN((TMNISR-T0)/T1))
14026         R=B8*HWRGEN(0)
14027         IF (R.LE.B1) THEN
14028 C---NEITHER EMITS
14029           T=1
14030           GAMWT=GAMWT*B8/B1
14031           Z(1)=1
14032         ELSEIF (R.LE.B4) THEN
14033 C---ONE EMITS
14034           IF (R.LE.B2) THEN
14035             R=(R-B1)/(B2-B1)
14036             T=1-(1-TMNISR)*(1-R*(1-((1-ZMXISR)/(1-TMNISR))**B))**(1/B)
14037           ELSEIF (R.LE.B3) THEN
14038             R=(R-B2)/(B3-B2)
14039             T=(TMNISR/ZMXISR)**R*ZMXISR
14040           ELSE
14041             R=(R-B3)/(B4-B3)
14042             T=T0+T1*TAN(
14043      $           ATAN((ZMXISR-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
14044           ENDIF
14045           GAMWT=GAMWT*B8/(2*B*(1-ZMXISR)**B*((1-T)**(B-1)+1/T+
14046      $         (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
14047           Z(1)=1
14048           IF (HWRGEN(1).GT.HALF) Z(1)=T
14049           GAMWT=GAMWT*2
14050         ELSE
14051 C---BOTH EMIT
14052           IF (R.LE.B5) THEN
14053             R=(R-B4)/(B5-B4)
14054             T=1-(1-TMNISR)*
14055      $           (1-R*(1-((1-ZMXISR**2)/(1-TMNISR))**(2*B)))**(.5/B)
14056           ELSEIF (R.LE.B6) THEN
14057             R=(R-B5)/(B6-B5)
14058             T=(TMNISR/ZMXISR**2)**R*ZMXISR**2
14059           ELSEIF (R.LE.B7) THEN
14060             R=(R-B6)/(B7-B6)
14061             T=(TMNISR/ZMXISR**2)**SQRT(R)*ZMXISR**2
14062           ELSE
14063             R=(R-B7)/(B8-B7)
14064             T=T0+T1*TAN(
14065      $           ATAN((ZMXISR**2-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
14066           ENDIF
14067           GAMWT=GAMWT*B8/(B**2*LOG(ZMXISR**2/T)/T
14068      $         + 2*B*(1-(1-ZMXISR)**B)*((1-T)**(2*B-1)+1/T+
14069      $         (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
14070 C---GENERATE A Z VALUE BETWEEN T/ZMXISR AND ZMXISR ACCORDING TO:
14071 C   1/z+(1-z)**(b-1)+t/z**2*(1-t/z)**(b-1)
14072           C1=LOG(ZMXISR**2/T)
14073           C2=C1+2/B*((1-T/ZMXISR)**B-(1-ZMXISR)**B)
14074           IF (C2.GT.ZERO) THEN
14075             R=C2*HWRGEN(4)
14076             IF (R.LE.C1) THEN
14077               Z(1)=(T/ZMXISR**2)**HWRGEN(5)*ZMXISR
14078             ELSE
14079               Z(1)=1-(1-T/ZMXISR)*
14080      $             (1-HWRGEN(6)*(1-((1-ZMXISR)/(1-T/ZMXISR))**B))**(1/B)
14081               IF (2*R.LE.C2+C1) Z(1)=T/Z(1)
14082             ENDIF
14083           ELSE
14084             Z(1)=SQRT(T)
14085           ENDIF
14086           GAMWT=GAMWT*C2/Z(1)
14087      $         /(1/Z(1)+(1-Z(1))**(B-1)+T/Z(1)**2*(1-T/Z(1))**(B-1))
14088         ENDIF
14089 C---INCLUDE DISTRIBUTION FUNCTIONS
14090         Z(2)=T/Z(1)
14091         DO 10 I=1,2
14092           IF (Z(I).GT.ZMXISR) THEN
14093             Z(I)=1
14094             CIRCKP(I)=(1-ZMXISR)**B*EXP(3*B/4)*(1-B**2*PIFAC**2/12)
14095           ELSE
14096             CIRCKP(I)=(B*(1-Z(I))**(B-1)*(1+Z(I)**2)/2
14097      $           *EXP(B*Z(I)/2*(1+Z(I)/2))*(1-B**2*PIFAC**2/12)
14098      $           +B**2/8*((1+Z(I))*((1+Z(I))**2+3*LOG(Z(I)))
14099      $           -4*LOG(Z(I))/(1-Z(I))))
14100           ENDIF
14101           GAMWT=GAMWT*CIRCKP(I)
14102   10    CONTINUE
14103 C---CHOOSE BOTH QSQ VALUES
14104         DO 30 I=1,2
14105           IF (Z(I).GT.ZMXISR .OR. COLISR) THEN
14106             QSQ(I)=0
14107           ELSE
14108             J=3-I
14109 C---ACCORDING TO 1/(QSQ+QSQMIN) FROM 0 TO (1-Z)*(T/(Z+T))*QSQMAX
14110  20         QSQ(I)=(((1-Z(I))*(T/(Z(I)+T))
14111      $           *QSQMAX/QSQMIN+1)**HWRGEN(7)-1)*QSQMIN
14112 C---AND REJECT TO QSQ/(QSQ+QSQMIN)**2
14113             IF (HWRGEN(8)*(QSQ(I)+QSQMIN).GT.QSQ(I)) GOTO 20
14114           ENDIF
14115  30     CONTINUE
14116 C---CHOOSE BOTH AZIMUTHS
14117         PHI(1)=HWRGEN(9)*2*PIFAC
14118         PHI(2)=HWRGEN(10)*2*PIFAC
14119 C---USE S-HAT PRESCRIPTION TO MODIFY Z VALUES
14120         I=0
14121         IF ((1-Z(1))*QSQ(1).GT.(1-Z(2))*QSQ(2)) I=1
14122         IF ((1-Z(2))*QSQ(2).GT.(1-Z(1))*QSQ(1)) I=2
14123         IF (I.GT.0) THEN
14124           J=3-I
14125           Z(I)=Z(I)+QSQ(I)/QSQMAX
14126           IF (QSQ(J).GT.ZERO) THEN
14127             Z(J)=((QSQ(I)*QSQMAX+QSQ(J)*QSQMAX
14128      $           -QSQ(I)*QSQ(J))/QSQMAX**2+T)/Z(I)
14129             C=COS(PHI(1)-PHI(2))*SQRT(QSQ(1)*QSQ(2))/QSQMAX
14130             Z(J)=Z(J)+(-2*C**2*(1-Z(I))+2*C*SQRT((1-Z(I))
14131      $           *(C**2*(1-Z(I))+Z(I)**2*(1-Z(J)))))/Z(I)**2
14132           ENDIF
14133         ENDIF
14134       ELSEIF (IHEP.EQ.2) THEN
14135 C---EVERYTHING WAS GENERATED LAST TIME
14136       ELSE
14137 C---ROUTINE CALLED UNEXPECTEDLY
14138         CALL HWWARN('HWEISR',201,*999)
14139       ENDIF
14140 C---IF Z IS TOO LARGE THERE IS NO EMISSION
14141       IF (Z(IHEP).GT.ZMXISR) RETURN
14142 C---PUT NEW LEPTON IN EVENT RECORD
14143       NHEP=NHEP+1
14144       IDHW(NHEP)=IDHW(IHEP)
14145       IDHEP(NHEP)=IDHEP(IHEP)
14146       ISTHEP(NHEP)=3
14147       JMOHEP(1,NHEP)=IHEP
14148       JMOHEP(2,NHEP)=0
14149       JDAHEP(1,NHEP)=0
14150       JDAHEP(2,NHEP)=0
14151       JDAHEP(1,IHEP)=NHEP
14152 C---AND OUTGOING PHOTON
14153       NHEP=NHEP+1
14154       IDHW(NHEP)=59
14155       IDHEP(NHEP)=22
14156       ISTHEP(NHEP)=1
14157       JMOHEP(1,NHEP)=IHEP
14158       JMOHEP(2,NHEP)=0
14159       JDAHEP(1,NHEP)=0
14160       JDAHEP(2,NHEP)=0
14161       JDAHEP(2,IHEP)=NHEP
14162 C---RECONSTRUCT PHOTON KINEMATICS (Z IS LIGHT-CONE MOMENTUM FRACTION)
14163       PHEP(1,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*COS(PHI(IHEP))
14164       PHEP(2,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*SIN(PHI(IHEP))
14165       PHEP(3,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)-QSQ(IHEP)/(4*PHEP(4,IHEP))
14166       IF (IHEP.EQ.2) PHEP(3,NHEP)=-PHEP(3,NHEP)
14167       PHEP(4,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)+QSQ(IHEP)/(4*PHEP(4,IHEP))
14168       PHEP(5,NHEP)=0
14169 C---AND LEPTON
14170       CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP),PHEP(1,NHEP-1))
14171       CALL HWUMAS(PHEP(1,NHEP-1))
14172 C---UPDATE OVERALL CM FRAME
14173       JMOHEP(IHEP,3)=NHEP-1
14174       CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
14175       CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,3),PHEP(1,3))
14176       CALL HWUMAS(PHEP(1,3))
14177  999  END
14178 CDECK  ID>, HWEONE.
14179 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
14180 *-- Author :    Bryan Webber
14181 C-----------------------------------------------------------------------
14182       SUBROUTINE HWEONE
14183 C-----------------------------------------------------------------------
14184 C     SETS UP 2->1 (COLOUR SINGLET) HARD SUBPROCESS
14185 C-----------------------------------------------------------------------
14186       INCLUDE 'HERWIG65.INC'
14187       DOUBLE PRECISION PA
14188       INTEGER ICMF,I,IBM,IHEP
14189 C---INCOMING LINES
14190       ICMF=NHEP+3
14191       DO 15 I=1,2
14192       IBM=I
14193 C---FIND BEAM AND TARGET
14194       IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
14195       IHEP=NHEP+I
14196       IDHW(IHEP)=IDN(I)
14197       IDHEP(IHEP)=IDPDG(IDN(I))
14198       ISTHEP(IHEP)=110+I
14199       JMOHEP(1,IHEP)=ICMF
14200       JMOHEP(I,ICMF)=IHEP
14201       JDAHEP(1,IHEP)=ICMF
14202 C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
14203       IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
14204         CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
14205         IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
14206       ELSE
14207         PHEP(1,IHEP)=0.
14208         PHEP(2,IHEP)=0.
14209         PHEP(5,IHEP)=RMASS(IDN(I))
14210         PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
14211         PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
14212         PHEP(3,IHEP)=PA-PHEP(4,IHEP)
14213       ENDIF
14214  15   CONTINUE
14215       PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
14216 C---HARD CENTRE OF MASS
14217       IDHW(ICMF)=IDCMF
14218       IDHEP(ICMF)=IDPDG(IDCMF)
14219       ISTHEP(ICMF)=110
14220       CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
14221       CALL HWUMAS(PHEP(1,ICMF))
14222 C---SET UP COLOUR STRUCTURE LABELS
14223       JMOHEP(2,NHEP+1)=NHEP+2
14224       JDAHEP(2,NHEP+1)=NHEP+2
14225       JMOHEP(2,NHEP+2)=NHEP+1
14226       JDAHEP(2,NHEP+2)=NHEP+1
14227       JDAHEP(1,NHEP+3)=NHEP+3
14228       JDAHEP(2,NHEP+3)=NHEP+3
14229       NHEP=NHEP+3
14230   999 END
14231 CDECK  ID>, HWEPRO.
14232 *CMZ :-        -15/07/02  17.56.53  by  Peter Richardson
14233 *-- Author :    Bryan Webber
14234 C-----------------------------------------------------------------------
14235       SUBROUTINE HWEPRO
14236 C-----------------------------------------------------------------------
14237 C     WHEN NEVHEP=0, CHOOSES X VALUES AND FINDS WEIGHT FOR PROCESS IPROC
14238 C     OTHERWISE, CHOOSES AND LOADS ALL VARIABLES FOR HARD PROCESS
14239 C     modifications for Les Houches accord by PR (7/15/02)
14240 C-----------------------------------------------------------------------
14241       INCLUDE 'HERWIG65.INC'
14242       DOUBLE PRECISION CIRCKP(2)
14243       COMMON /HWCIR2/CIRCKP
14244       DOUBLE PRECISION Z1,Z2,C1,C2,B1,B2,CIRCEE,CIRCGG,RS,MISS,ETA,
14245      $     HWUGAU,HWECIR,QMX1,QMN1,QMX2,QMN2,TEST
14246       INTEGER IHAD
14247       SAVE MISS
14248       DOUBLE PRECISION HWRGEN
14249       EXTERNAL HWRGEN,HWECIR
14250 C--Les Houches Common Block
14251       INTEGER MAXPUP
14252       PARAMETER(MAXPUP=100)
14253       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
14254       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
14255       COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
14256      &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
14257      &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
14258       IF (IERROR.NE.0)  RETURN
14259 C--pick the type of event to generate if using Les Houches accord
14260 C--first choice according to maxiumum weight
14261       IF(IPROC.LT.0) THEN
14262         IF(ABS(IDWTUP).EQ.1) THEN
14263           IF(ITYPLH.EQ.0) THEN
14264             TEST = HWRGEN(1)*LHMXSM
14265             DO ITYPLH=1,NPRUP
14266               IF(TEST.LE.ABS(LHXMAX(ITYPLH))) GOTO 5
14267               TEST = TEST-ABS(LHXMAX(ITYPLH))
14268             ENDDO
14269  5          WGTMAX = ABS(LHXMAX(ITYPLH))
14270             WBIGST = ABS(LHXMAX(ITYPLH))
14271           ENDIF
14272 C--second choice according to cross section
14273         ELSEIF(ABS(IDWTUP).EQ.2) THEN
14274           IF(ITYPLH.EQ.0) THEN
14275             TEST = HWRGEN(1)*LHMXSM
14276             DO ITYPLH=1,NPRUP
14277               IF(TEST.LE.ABS(LHXSCT(ITYPLH))) GOTO 6
14278               TEST = TEST-ABS(LHXSCT(ITYPLH))
14279             ENDDO
14280  6          WGTMAX = ABS(LHXMAX(ITYPLH))
14281             WBIGST = ABS(LHXMAX(ITYPLH))
14282           ENDIF
14283         ELSE
14284           WGTMAX = 1.0D0
14285           WBIGST = 1.0D0
14286           ITYPLH = 1
14287         ENDIF
14288       ENDIF
14289 C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS NOT ACCEPTED
14290    10 GENEV=.FALSE.
14291 C---FSTWGT IS .TRUE. DURING FIRST CALL TO HARD PROCESS ROUTINE
14292       FSTWGT=NWGTS.EQ.0
14293 C---FSTEVT IS .TRUE. THROUGHOUT THE FIRST EVENT
14294       FSTEVT=NEVHEP.EQ.1
14295 C---SET COLOUR CORRECTION TO FALSE
14296       COLUPD = .FALSE.
14297       HRDCOL(1,1)=0
14298       HRDCOL(1,3)=0
14299 C---SET UP INITIAL STATE
14300       NHEP=1
14301       ISTHEP(NHEP)=101
14302       PHEP(1,NHEP)=0.
14303       PHEP(2,NHEP)=0.
14304       PHEP(3,NHEP)=PBEAM1
14305       PHEP(4,NHEP)=EBEAM1
14306       PHEP(5,NHEP)=RMASS(IPART1)
14307       JMOHEP(1,NHEP)=0
14308       JMOHEP(2,NHEP)=0
14309       JDAHEP(1,NHEP)=0
14310       JDAHEP(2,NHEP)=0
14311       IDHW(NHEP)=IPART1
14312       IDHEP(NHEP)=IDPDG(IPART1)
14313       NHEP=NHEP+1
14314       ISTHEP(NHEP)=102
14315       PHEP(1,NHEP)=0.
14316       PHEP(2,NHEP)=0.
14317       PHEP(3,NHEP)=-PBEAM2
14318       PHEP(4,NHEP)=EBEAM2
14319       PHEP(5,NHEP)=RMASS(IPART2)
14320       JMOHEP(1,NHEP)=0
14321       JMOHEP(2,NHEP)=0
14322       JDAHEP(1,NHEP)=0
14323       JDAHEP(2,NHEP)=0
14324       IDHW(NHEP)=IPART2
14325       IDHEP(NHEP)=IDPDG(IPART2)
14326 C---NEXT ENTRY IS OVERALL CM FRAME
14327       NHEP=NHEP+1
14328       IDHW(NHEP)=14
14329       IDHEP(NHEP)=0
14330       ISTHEP(NHEP)=103
14331       JMOHEP(1,NHEP)=NHEP-2
14332       JMOHEP(2,NHEP)=NHEP-1
14333       JDAHEP(1,NHEP)=0
14334       JDAHEP(2,NHEP)=0
14335       CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
14336       CALL HWUMAS(PHEP(1,NHEP))
14337 C Select a primary interaction point
14338       IF (PIPSMR) THEN
14339         CALL HWRPIP
14340       ELSE
14341         CALL HWVZRO(4,VTXPIP)
14342       ENDIF
14343       CALL HWVEQU(3,VTXPIP,VHEP(1,NHEP))
14344       VHEP(4,NHEP)=0.0
14345 C---GENERATE PHOTONS (WEIZSACKER-WILLIAMS APPROX)
14346 C   FOR HADRONIC PROCESSES WITH LEPTON BEAMS
14347       GAMWT=ONE
14348       IF (IPRO.GT.12.AND.IPRO.LT.90) THEN
14349         IF (CIRCOP.EQ.0) THEN
14350            IF (ABS(IDHEP(1)).EQ.11.OR.ABS(IDHEP(1)).EQ.13)
14351      &          CALL HWEGAM(1,ZERO, ONE,.FALSE.)
14352            IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
14353      &          CALL HWEGAM(2,ZERO, ONE,.FALSE.)
14354         ELSE
14355 C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
14356           IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
14357      $         'This version only works for e+e- annihilation'
14358           IF (FSTWGT) THEN
14359             RS=NINT(PHEP(5,3)*10)/1D1
14360             CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
14361           ENDIF
14362           CALL HWEGAM(1,ZERO, ONE,.TRUE.)
14363           CALL HWEGAM(2,ZERO, ONE,.TRUE.)
14364           Z1=PHEP(4,4)/PHEP(4,1)
14365           Z2=PHEP(4,6)/PHEP(4,2)
14366 C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
14367           C1=CIRCGG(Z1,-1D0)/SQRT(CIRCGG(-1D0,-1D0))
14368           C2=CIRCGG(-1D0,Z2)/SQRT(CIRCGG(-1D0,-1D0))
14369 C---REMOVE SPURIOUS WEIGHT GIVEN IN HWEGAM
14370           GAMWT=GAMWT/(.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*
14371      $         LOG((ONE-Z1)/Z1*4*PHEP(4,1)*PHEP(4,2)/PHEP(5,1)**2))
14372      $               /(.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*
14373      $         LOG((ONE-Z2)/Z2*4*PHEP(4,4)*PHEP(4,2)/PHEP(5,1)**2))
14374 C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
14375           QMX1=MIN(Q2WWMX,(Z1*PHEP(3,1))**2)
14376           QMN1=MAX(Q2WWMN,(PHEP(5,1)*Z1)**2/(1-Z1))
14377           QMX2=MIN(Q2WWMX,(Z2*PHEP(3,2))**2)
14378           QMN2=MAX(Q2WWMN,(PHEP(5,2)*Z2)**2/(1-Z2))
14379           B1=.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*LOG(QMX1/QMN1)
14380           B2=.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*LOG(QMX2/QMN2)
14381           IF (CIRCOP.EQ.1) THEN
14382             GAMWT=GAMWT*B1*B2
14383           ELSEIF (CIRCOP.EQ.2) THEN
14384             GAMWT=GAMWT*C1*C2
14385           ELSEIF (CIRCOP.EQ.3) THEN
14386             GAMWT=GAMWT*(C1+B1)*(C2+B2)
14387           ELSE
14388             STOP 'Illegal value of circop!'
14389           ENDIF
14390         ENDIF
14391       ELSEIF (IPRO.GE.90) THEN
14392         IF (CIRCOP.NE.0) STOP 'Circe not interfaced for DIS processes'
14393         IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
14394      &       CALL HWEGAM(2,ZERO, ONE,.FALSE.)
14395       ENDIF
14396 C---GENERATE ISR PHOTONS FOR LEPTONIC PROCESSES
14397       IF (IPRO.GT.0.AND.IPRO.LE.12) THEN
14398         IF (CIRCOP.EQ.0) THEN
14399            CALL HWEISR(1)
14400            CALL HWEISR(2)
14401         ELSE
14402 C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
14403           IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
14404      $         'This version only works for e+e- annihilation'
14405           IF (FSTWGT) THEN
14406             RS=NINT(PHEP(5,3)*10)/1D1
14407             CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
14408 C---PRECALCULATE THE PART OF THE SPECTRUM MISSED BETWEEN ZMXISR AND 1
14409             ETA=0.6D0
14410             MISS=HWUGAU(HWECIR,1D-15**(1-ETA),(1-ZMXISR)**(1-ETA),1D-12)
14411           ENDIF
14412           COLISR=.TRUE.
14413           CALL HWEISR(1)
14414           CALL HWEISR(2)
14415           IHAD=1
14416           IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
14417           Z1=PHEP(4,IHAD)/PHEP(4,1)
14418           IHAD=2
14419           IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
14420           Z2=PHEP(4,IHAD)/PHEP(4,2)
14421 C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
14422           C1=CIRCEE(Z1,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
14423           C2=CIRCEE(-1D0,Z2)/SQRT(CIRCEE(-1D0,-1D0))
14424           IF (Z1.EQ.ONE) C1=C1+MISS
14425           IF (Z2.EQ.ONE) C2=C2+MISS
14426 C---REMOVE WEIGHT GIVEN IN HWEISR
14427           B1=CIRCKP(1)
14428           B2=CIRCKP(2)
14429           GAMWT=GAMWT/(B1*B2)
14430 C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
14431           IF (CIRCOP.EQ.1) THEN
14432             GAMWT=GAMWT*B1*B2
14433           ELSEIF (CIRCOP.EQ.2) THEN
14434             GAMWT=GAMWT*C1*C2
14435           ELSEIF (CIRCOP.EQ.3) THEN
14436 C---IN THE APPROXIMATION OF DOMINANCE BY THE DELTA-FUNCTION TERM
14437             IF (Z1.EQ.ONE) C1=C1-1
14438             IF (Z2.EQ.ONE) C2=C2-1
14439 C---IF IT DOES NOT DOMINATE, ZMXISR SHOULD BE DECREASED
14440             IF (B1+C1.LT.ZERO) CALL HWWARN('HWEPRO',501,*999)
14441             IF (B2+C2.LT.ZERO) CALL HWWARN('HWEPRO',502,*999)
14442             GAMWT=GAMWT*(C1+B1)*(C2+B2)
14443           ELSE
14444             STOP 'Illegal value of circop!'
14445           ENDIF
14446         ENDIF
14447       ENDIF
14448 C---IF USER LIMITS WERE TOO TIGHT, MIGHT NOT BE ANY PHASE-SPACE
14449       IF (GAMWT.LE.ZERO) GOTO 30
14450 C---IF CMF HAS ACQUIRED A TRANSVERSE BOOST, OR USER REQUESTS IT ANYWAY,
14451 C   BOOST EVENT RECORD BACK TO CMF
14452       IF (PHEP(1,3)**2+PHEP(2,3)**2.GT.ZERO .OR. USECMF) CALL HWUBST(1)
14453 C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS ACCEPTED
14454    20 CONTINUE
14455       IPRO=MOD(IPROC/100,100)
14456 C---PROCESS GENERATED BY LES HOUCHES INTERFACE
14457       IF(IPRO.LE.0) THEN
14458         CALL HWHGUP
14459       ELSEIF (IPRO.EQ.1) THEN
14460         IF (IPROC.LT.110.OR.IPROC.GE.120) THEN
14461 C--- E+E- -> Q-QBAR OR L-LBAR
14462           CALL HWHEPA
14463         ELSE
14464 C--- E+E- -> Q-QBAR-GLUON
14465           CALL HWHEPG
14466         ENDIF
14467       ELSEIF (IPRO.EQ.2) THEN
14468 C--- E+E- -> W+ W-
14469         CALL HWHEWW
14470       ELSEIF (IPRO.EQ.3) THEN
14471 C---E+E- -> Z H
14472         CALL HWHIGZ
14473       ELSEIF (IPRO.EQ.4) THEN
14474 C---E+E- -> NUEB NUE H
14475         CALL HWHIGW
14476       ELSEIF (IPRO.EQ.5 .AND. IPROC.LT.550) THEN
14477 C---EE -> EE GAMGAM -> EE FFBAR/WW
14478         CALL HWHEGG
14479       ELSEIF (IPRO.EQ.5) THEN
14480 C---EE -> ENU GAMW -> ENU FF'BAR/WZ
14481         CALL HWHEGW
14482       ELSEIF (IPRO.EQ.6) THEN
14483 C---EE -> FOUR JETS
14484         CALL HWH4JT
14485       ELSEIF(IPRO.EQ.7) THEN
14486 C--EE -> SUSY PARTICLES(PAIR PRODUCTION)
14487         CALL HWHESP
14488       ELSEIF(IPRO.EQ.8) THEN
14489 C--EE -> RPV SUSY PARTICLE PRODUCTION
14490         CALL HWHREP
14491       ELSEIF (IPRO.EQ.9) THEN
14492         IF((MOD(IPROC,10000).EQ.955).OR.
14493      &     (MOD(IPROC,10000).EQ.965).OR.
14494      &     (MOD(IPROC,10000).EQ.975))THEN
14495 C---MSSM Higgs pair production in l+l-: H+ H- and A0 Higgs, Higgs=h0,H0.
14496           CALL HWHIHH
14497         ELSEIF((MOD(IPROC,10000).EQ.910).OR.
14498      &         (MOD(IPROC,10000).EQ.920))THEN
14499 C---MSSM scalar Higgs production from vector-vector fusion.
14500           CALL HWHIGW
14501         ELSEIF((MOD(IPROC,10000).EQ.960).OR.
14502      &         (MOD(IPROC,10000).EQ.970))THEN
14503 C---MSSM scalar Higgs production from Higgs-strahlung.
14504           CALL HWHIGZ
14505         END IF
14506       ELSEIF ((IPRO.EQ.10).OR.(IPRO.EQ.11)) THEN
14507 C---SM/MSSM Higgs production with heavy quark flavours via e+e-.
14508         CALL HWHIGE
14509       ELSEIF (IPRO.EQ.13) THEN
14510 C---GAMMA/Z0/Z' DRELL-YAN PROCESS
14511         CALL HWHDYP
14512       ELSEIF (IPRO.EQ.14) THEN
14513 C---W+/- PRODUCTION VIA DRELL-YAN PROCESS
14514         CALL HWHWPR
14515       ELSEIF (IPRO.EQ.15) THEN
14516 C---QCD HARD 2->2 PROCESSES
14517         CALL HWHQCD
14518       ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN
14519 C---SM/MSSM HIGGS PRODUCTION VIA QUARK/GLUON FUSION
14520         CALL HWHIGS
14521       ELSEIF (IPRO.EQ.17) THEN
14522 C---QCD HEAVY FLAVOUR PRODUCTION
14523         CALL HWHHVY
14524       ELSEIF (IPRO.EQ.18) THEN
14525 C---QCD DIRECT PHOTON + JET PRODUCTION
14526         CALL HWHPHO
14527       ELSEIF ((IPRO.EQ.19).OR.(IPRO.EQ.37)) THEN
14528 C---SM/MSSM HIGGS PRODUCTION VIA W/Z FUSION
14529         CALL HWHIGW
14530       ELSEIF (IPRO.EQ.20) THEN
14531 C---TOP PRODUCTION FROM W EXCHANGE
14532         CALL HWHWEX
14533       ELSEIF (IPRO.EQ.21) THEN
14534 C---VECTOR BOSON + JET PRODUCTION
14535         CALL HWHV1J
14536       ELSEIF (IPRO.EQ.22) THEN
14537 C QCD direct photon pair production
14538         CALL HWHPH2
14539       ELSEIF (IPRO.EQ.23) THEN
14540 C QCD Higgs plus jet production
14541         CALL HWHIGJ
14542       ELSEIF (IPRO.EQ.24) THEN
14543 C---COLOUR-SINGLET EXCHANGE
14544         CALL HWHSNG
14545       ELSEIF (IPRO.EQ.25) THEN
14546 C---SM Higgs production with heavy quark flavours via qq and gg.
14547         CALL HWHIGQ
14548       ELSEIF ((IPRO.EQ.26).OR.(IPRO.EQ.27)) THEN
14549 C---SM Higgs production with heavy gauge bosons via qq(').
14550         CALL HWHIGV
14551 C---Gauge boson pair in hadron hadron
14552       ELSEIF (IPRO.EQ.28) THEN
14553         IF (MOD(IPROC,10000).LT.2850) THEN
14554           CALL HWHGBP
14555         ELSE
14556           CALL HWHVVJ
14557         ENDIF
14558 C--Vector boson + two jets
14559       ELSEIF(IPRO.EQ.29) THEN
14560         CALL HWHV2J
14561       ELSEIF (IPRO.EQ.30) THEN
14562 C---HADRON-HADRON SUSY PROCESSES
14563         CALL HWHSSP
14564       ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN
14565 C---MSSM charged/neutral Higgs production in association with squarks.
14566         CALL HWHISQ
14567       ELSEIF (IPRO.EQ.33) THEN
14568         IF(MOD(IPROC,10000).EQ.3350)THEN
14569 C---MSSM charged Higgs production in association with W: W+H- + W-H+.
14570           CALL HWHIBK
14571         ELSEIF((MOD(IPROC,10000).EQ.3310).OR.
14572      &         (MOD(IPROC,10000).EQ.3320).OR.
14573      &         (MOD(IPROC,10000).EQ.3360).OR.
14574      &         (MOD(IPROC,10000).EQ.3370))THEN
14575 C---MSSM Higgs production with heavy gauge bosons via qq(').
14576           CALL HWHIGV
14577         ELSE
14578 C---MSSM charged/neutral Higgs pair production.
14579           CALL HWHIGH
14580         END IF
14581       ELSEIF (IPRO.EQ.34) THEN
14582 C---MSSM charged/neutral Higgs production via bg fusion.
14583         CALL HWHIBG
14584       ELSEIF (IPRO.EQ.35) THEN
14585 C---MSSM charged Higgs production via bq fusion.
14586         CALL HWHIBQ
14587       ELSEIF (IPRO.EQ.38) THEN
14588 C---MSSM charged/neutral Higgs production with heavy quarks via qq and gg.
14589         CALL HWHIGQ
14590       ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
14591 C---HADRON-HADRON R-PARITY VIOLATING SUSY PROCESSES
14592         CALL HWHRSP
14593       ELSEIF (IPRO.EQ.42) THEN
14594 C---SPIN-TWO RESONANCE
14595         CALL HWHGRV
14596       ELSEIF (IPRO.EQ.50) THEN
14597 C Point-like photon two-jet production
14598         CALL HWHPPT
14599       ELSEIF (IPRO.EQ.51) THEN
14600 C Point-like photon/QCD heavy flavour pair production
14601         CALL HWHPPH
14602       ELSEIF (IPRO.EQ.52) THEN
14603 C Point-like photon/QCD heavy flavour single excitation
14604         CALL HWHPPE
14605       ELSEIF (IPRO.EQ.53) THEN
14606 C Compton scattering of point-like photon and (anti)quark
14607         CALL HWHPQS
14608       ELSEIF (IPRO.EQ.55) THEN
14609 C Point-like photon/higher twist meson production
14610         CALL HWHPPM
14611       ELSEIF (IPRO.EQ.60) THEN
14612 C---QPM GAMMA-GAMMA-->QQBAR
14613         CALL HWHQPM
14614       ELSEIF (IPRO.GE.70.AND.IPRO.LE.79) THEN
14615 C---BARYON-NUMBER VIOLATION, AND OTHER MULTI-W PRODUCTION PROCESSES
14616         CALL HVHBVI
14617       ELSEIF (IPRO.EQ.80) THEN
14618 C---MINIMUM-BIAS: NO HARD SUBPROCESS
14619 C   FIND WEIGHT
14620         CALL HWMWGT
14621       ELSEIF (IPRO.EQ.90) THEN
14622 C---DEEP INELASTIC
14623         CALL HWHDIS
14624       ELSEIF(IPRO.EQ.91) THEN
14625 C---BOSON - GLUON(QUARK) FUSION -->  ANTIQUARK(GLUON) + QUARK
14626         CALL HWHBGF
14627       ELSEIF(IPRO.EQ.92) THEN
14628 C---DEEP INELASTIC WITH EXTRA JET: OBSOLETE PROCESS
14629         WRITE (6,40)
14630  40     FORMAT (1X,' IPROC=92** is no longer supported.'
14631      &         /1X,' Please use IPROC=91** instead.')
14632         CALL HWWARN('HWEPRO',500,*999)
14633       ELSEIF(IPRO.EQ.95) THEN
14634 C---HIGGS PRODUCTION VIA W FUSION IN E P
14635         CALL HWHIGW
14636       ELSE
14637 C---UNKNOWN PROCESS
14638         CALL HWWARN('HWEPRO',102,*999)
14639       ENDIF
14640  30   IF (GENEV) THEN
14641          IF (NOWGT) THEN
14642             IF (NEGWTS) THEN
14643                IF (EVWGT.LT.ZERO) THEN
14644                   EVWGT=-AVABW
14645                ELSE
14646                   EVWGT= AVABW
14647                ENDIF
14648             ELSE
14649                EVWGT=AVWGT
14650             ENDIF
14651          ENDIF
14652          ISTAT=10
14653 C--New call spin correlation code if needed
14654          IF(SYSPIN.AND.(IPRO.EQ. 1.OR.IPRO.EQ.13.OR.IPRO.EQ.14.OR.
14655      &                  IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.20.OR.
14656      &                  IPRO.EQ. 7.OR.IPRO.EQ.30.OR.IPRO.EQ.40.OR.
14657      &                  IPRO.EQ.41.OR.IPRO.EQ.8)) CALL HWHSPN
14658 C--generate additional photon radition in top production
14659          IF(ITOPRD.EQ.1.AND.MOD(IPROC,10000).EQ.1706) CALL HWPHTT
14660          RETURN
14661       ELSE
14662 C---IF AN EVENT IS CANCELLED BEFORE IT IS GENERATED, GIVE IT ZERO WEIGHT
14663         IF (IERROR.NE.0) THEN
14664           EVWGT=ZERO
14665           IERROR=0
14666         ENDIF
14667         EVWGT=EVWGT*GAMWT
14668         NWGTS=NWGTS+1
14669         ABWGT=ABS(EVWGT)
14670         IF (EVWGT.LT.ZERO) THEN
14671            IF (NEGWTS) THEN
14672               NNEGWT=NNEGWT+1
14673            ELSE
14674               IF (EVWGT.LT.-1.D-9) CALL HWWARN('HWEPRO',3,*999)
14675               EVWGT=ZERO
14676               ABWGT=ZERO
14677            ENDIF
14678         ENDIF
14679         WGTSUM=WGTSUM+EVWGT
14680         WSQSUM=WSQSUM+EVWGT**2
14681         ABWSUM=ABWSUM+ABWGT
14682 C--weight addition for Les Houches accord
14683         IF(IPROC.LE.0) THEN
14684           IF(ABS(IDWTUP).EQ.1) THEN
14685              LHWGT (ITYPLH) = LHWGT (ITYPLH)+EVWGT
14686              LHWGTS(ITYPLH) = LHWGTS(ITYPLH)+EVWGT**2
14687              LHIWGT(ITYPLH) = LHIWGT(ITYPLH)+1
14688           ENDIF
14689         ENDIF
14690         IF (ABWGT.GT.WBIGST) THEN
14691            WBIGST=ABWGT
14692            IF (NOWGT.AND.WBIGST.GT.WGTMAX) THEN
14693               IF (NEVHEP.NE.0) CALL HWWARN('HWEPRO',1,*999)
14694               WGTMAX=WBIGST*1.1
14695               WRITE (6,99) WGTMAX
14696 C--additional for Les Houche accord
14697               IF(IPROC.LE.0) THEN
14698                 IF(ABS(IDWTUP).EQ.1)
14699      &                LHMXSM = LHMXSM-LHXMAX(ITYPLH)+ABWGT
14700                 LHXMAX(ITYPLH) = EVWGT
14701               ENDIF
14702            ENDIF
14703         ENDIF
14704         IF (NEVHEP.NE.0) THEN
14705 C---LOW EFFICIENCY WARNINGS:
14706 C   WARN AT 10*EFFMIN, STOP AT EFFMIN
14707           IF (10*EFFMIN*NWGTS.GT.NEVHEP) THEN
14708             IF (EFFMIN*NWGTS.GT.NEVHEP) CALL HWWARN('HWEPRO',200,*999)
14709             IF (EFFMIN.GT.ZERO) THEN
14710               IF (MOD(NWGTS,INT(10/EFFMIN)).EQ.0) THEN
14711                 CALL HWWARN('HWEPRO',2,*999)
14712                 WRITE (6,98) WGTMAX
14713               ENDIF
14714             ENDIF
14715           ENDIF
14716           IF (NOWGT) THEN
14717             GENEV=ABWGT.GT.WGTMAX*HWRGEN(0)
14718           ELSE
14719             GENEV=ABWGT.NE.ZERO
14720           ENDIF
14721           IF (GENEV)  GOTO 20
14722           GOTO 10
14723         ENDIF
14724       ENDIF
14725  98   FORMAT(10X,'    MAXIMUM WEIGHT =',1PG24.16)
14726  99   FORMAT(10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
14727   999 END
14728 CDECK  ID>, HWETWO.
14729 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
14730 *-- Author :    Bryan Webber
14731 C-----------------------------------------------------------------------
14732       SUBROUTINE HWETWO(SMR3,SMR4)
14733 C-----------------------------------------------------------------------
14734 C     SETS UP 2->2 HARD SUBPROCESS
14735 c BRW change 18/8/04: BW smearing of mass i only if SMRi is true
14736 C-----------------------------------------------------------------------
14737       INCLUDE 'HERWIG65.INC'
14738       DOUBLE PRECISION HWUMBW,HWUPCM,PA,PCM
14739       INTEGER ICMF,IBM,I,J,K,IHEP,NTRY
14740       LOGICAL SMR3,SMR4
14741       EXTERNAL HWUPCM
14742 C---INCOMING LINES
14743       ICMF=NHEP+3
14744       DO 15 I=1,2
14745       IBM=I
14746 C---FIND BEAM AND TARGET
14747       IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
14748       IHEP=NHEP+I
14749       IDHW(IHEP)=IDN(I)
14750       IDHEP(IHEP)=IDPDG(IDN(I))
14751       ISTHEP(IHEP)=110+I
14752       JMOHEP(1,IHEP)=ICMF
14753       JMOHEP(I,ICMF)=IHEP
14754       JDAHEP(1,IHEP)=ICMF
14755 C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
14756       IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
14757         CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
14758         IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
14759       ELSE
14760         PHEP(1,IHEP)=0.
14761         PHEP(2,IHEP)=0.
14762         PHEP(5,IHEP)=RMASS(IDN(I))
14763         PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
14764         PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
14765         PHEP(3,IHEP)=PA-PHEP(4,IHEP)
14766       ENDIF
14767  15   CONTINUE
14768       PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
14769 C---HARD CENTRE OF MASS
14770       IDHW(ICMF)=IDCMF
14771       IDHEP(ICMF)=IDPDG(IDCMF)
14772       ISTHEP(ICMF)=110
14773       CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
14774       CALL HWUMAS(PHEP(1,ICMF))
14775 C---OUTGOING LINES
14776       NTRY=0
14777       DO 16 I=3,4
14778       IHEP=NHEP+I+1
14779       IDHW(IHEP)=IDN(I)
14780       IDHEP(IHEP)=IDPDG(IDN(I))
14781       ISTHEP(IHEP)=110+I
14782       JMOHEP(1,IHEP)=ICMF
14783  16   JDAHEP(I-2,ICMF)=IHEP
14784  19   CONTINUE
14785       IF (SMR3) THEN
14786          PHEP(5,NHEP+4)=HWUMBW(IDN(3))
14787       ELSE
14788          PHEP(5,NHEP+4)=RMASS(IDN(3))
14789       ENDIF
14790       IF (SMR4) THEN
14791          PHEP(5,NHEP+5)=HWUMBW(IDN(4))
14792       ELSE
14793          PHEP(5,NHEP+5)=RMASS(IDN(4))
14794       ENDIF
14795       PCM=HWUPCM(PHEP(5,NHEP+3),PHEP(5,NHEP+4),PHEP(5,NHEP+5))
14796       IF (PCM.LT.ZERO) THEN
14797         NTRY=NTRY+1
14798         IF (NTRY.LE.NETRY) GO TO 19
14799         CALL HWWARN('HWETWO',103,*999)
14800       ENDIF
14801       IHEP=NHEP+4
14802       PHEP(4,IHEP)=SQRT(PCM**2+PHEP(5,IHEP)**2)
14803       PHEP(3,IHEP)=PCM*COSTH
14804       PHEP(1,IHEP)=SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
14805       CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
14806       CALL HWULOB(PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,IHEP))
14807       CALL HWVDIF(4,PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,NHEP+5))
14808 C---SET UP COLOUR STRUCTURE LABELS
14809       DO 30 I=1,4
14810       J=I
14811       IF (J.GT.2) J=J+1
14812       K=ICO(I)
14813       IF (K.GT.2) K=K+1
14814       JMOHEP(2,NHEP+J)=NHEP+K
14815    30 JDAHEP(2,NHEP+K)=NHEP+J
14816       NHEP=NHEP+5
14817   999 END
14818 CDECK  ID>, HWH2BK.
14819 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
14820 *-- Author :  Stefano Moretti
14821 C-----------------------------------------------------------------------
14822       SUBROUTINE HWH2BK(P1,P2,P3,P4,RMW,RMH,RES,RESL,REST)
14823 C-----------------------------------------------------------------------
14824 C...Matrix element for q(1) + q-bar(2) -> W+/-(3) +  H-/+(4),
14825 C...all masses retained.
14826 C...It factorises (PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
14827 C
14828 C...First release:  1-APR-1998 by Stefano Moretti
14829 C-----------------------------------------------------------------------
14830       INCLUDE 'HERWIG65.INC'
14831       INTEGER I
14832       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
14833       DOUBLE PRECISION P(0:3)
14834       DOUBLE PRECISION RES,S,T,U,MB2,MT2,MW2,MHP2,MH02,MA02,MSH2,
14835      &                 MGAMH0,MGAMA0,MGAMSH,PT,NC,KT2,RESL,REST
14836       DOUBLE PRECISION TT,UU,KKT2,TL
14837       DOUBLE COMPLEX Z,PV,PA
14838       DOUBLE PRECISION RMB,RMT,RMW,RMH
14839       DOUBLE PRECISION RMH01,GAMH01,
14840      &                 RMH02,GAMH02,
14841      &                 RMH03,GAMH03
14842       DOUBLE PRECISION VP,CFC
14843       EQUIVALENCE (RMB  ,RMASS(  5)),(RMT  ,RMASS(  6))
14844       EQUIVALENCE (RMH01,RMASS(204)),
14845      &            (RMH02,RMASS(203)),
14846      &            (RMH03,RMASS(205))
14847       PARAMETER (Z=(0.,1.),NC=3.)
14848 C...Higgs widths.
14849       GAMH01=RMASS(204)/DKLTM(204)
14850       GAMH02=RMASS(203)/DKLTM(203)
14851       GAMH03=RMASS(205)/DKLTM(205)
14852 C...constant terms.
14853       MB2=RMB*RMB
14854       MT2=RMT*RMT
14855       MW2=RMW*RMW
14856       MHP2=RMH  *RMH
14857       MH02=RMH01*RMH01
14858       MA02=RMH03*RMH03
14859       MSH2=RMH02*RMH02
14860       MGAMH0=RMH01*GAMH01
14861       MGAMA0=RMH03*GAMH03
14862       MGAMSH=RMH02*GAMH02
14863 C...Mandelstam invariants.
14864       S=(P1(0)+P2(0))**2
14865       T=(P1(0)-P3(0))**2
14866       U=(P1(0)-P4(0))**2
14867         DO I=1,3
14868           S=S-(P1(I)+P2(I))**2
14869           T=T-(P1(I)-P3(I))**2
14870           U=U-(P1(I)-P4(I))**2
14871         END DO
14872 C...propagators and couplings.
14873       PV=(-SINA*COSBMA/(S-MSH2+Z*MGAMSH)
14874      &    -COSA*SINBMA/(S-MH02+Z*MGAMH0) )/COSB
14875       PA=         TANB/(S-MA02+Z*MGAMA0)
14876       PT=         1./(T-MT2)
14877       KT2=(U*T-MHP2*MW2)/S
14878 C...Total ME.
14879       RES=S/NC*( MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
14880      & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
14881      & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
14882      & PT**2*((MT2/TANB)**2*(2.*MW2+KT2)
14883      & +MB2*TANB**2*(2.*MW2*KT2+T**2)))
14884      & *2.
14885 C...Extracts spin dependence.
14886       VP=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
14887       CFC=P3(0)/VP
14888       DO I=1,3
14889         P(I)=P3(I)*CFC
14890       END DO
14891       P(0)=VP**2/P3(0)*CFC
14892       TT=(P1(0)-P(0))**2
14893       UU=(P2(0)-P(0))**2
14894       DO I=1,3
14895         TT=TT-(P1(I)-P(I))**2
14896         UU=UU-(P2(I)-P(I))**2
14897       END DO
14898       KKT2=((MW2+TT)*(MW2+UU)+(MW2+MHP2-T-U)*MW2)/S
14899       TL=((TT+MW2)*(UU+MW2)*((S+U-MW2)*(TT+MW2)/(UU+MW2)-T)
14900      &  +MW2*((MW2-T)*(MW2-U)-S*MW2))/S
14901 C...Longitudinal ME (along V direction).
14902       RESL=S/NC*(MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
14903      & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
14904      & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
14905      & PT**2*((MT2/TANB)**2*(KKT2)
14906      & +MB2*TANB**2*(TL)))
14907      & *2.
14908 C...Transverse ME (perpendicular to V direction).
14909       REST=RES-RESL
14910  999  RETURN
14911       END
14912 CDECK  ID>, HWH2DD.
14913 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
14914 *-- Author :    Peter Richardson
14915 C-----------------------------------------------------------------------
14916       FUNCTION HWH2DD(ND,I,J,K,L,Z1,Z2)
14917 C-----------------------------------------------------------------------
14918 C     Returns the coefficient D1-10 from Nucl. Phys. B262 (1985) 235-262
14919 C     N.B. THE STRONG COUPLING AND GV+/-GA ARE INCLUDED IN THE CROSS
14920 C     SECTION ROUTINE
14921 C     I-L are the particles (all outgoing)
14922 C     Z1 and Z2 are the decay products of the Z
14923 C-----------------------------------------------------------------------
14924       INCLUDE 'HERWIG65.INC'
14925       INTEGER ND,I,J,K,L,Z1,Z2
14926       DOUBLE COMPLEX HWH2DD,ZI,S,D,F
14927       PARAMETER(ZI=(0.0D0,1.0D0))
14928       COMMON/HWHEWS/S(8,8,2),D(8,8)
14929       COMMON/HWHZBB/F(8,8)
14930       IF(ND.EQ.1) THEN
14931         HWH2DD = ZI
14932       ELSEIF(ND.EQ.2) THEN
14933         HWH2DD =  ZI/F(J,K)/SQRT(TWO*D(I,K))
14934       ELSEIF(ND.EQ.3) THEN
14935         HWH2DD = -ZI/F(I,K)/SQRT(TWO*D(I,K))
14936       ELSEIF(ND.EQ.4) THEN
14937         HWH2DD = -ZI/F(K,L)/(F(Z1,I)+F(Z2,I)+F(Z1,Z2))
14938       ELSEIF(ND.EQ.5) THEN
14939         HWH2DD =  ZI/F(K,L)/(F(Z1,J)+F(Z2,J)+F(Z1,Z2))
14940       ELSEIF(ND.EQ.6) THEN
14941         HWH2DD =  ZI*HALF/F(J,L)/(F(J,L)+F(J,K)+F(K,L))/D(K,L)
14942       ELSEIF(ND.EQ.7) THEN
14943         HWH2DD = -ZI*HALF/F(I,K)/F(J,L)/D(K,L)
14944       ELSEIF(ND.EQ.8) THEN
14945         HWH2DD =  ZI*HALF/F(I,K)/(F(I,K)+F(I,L)+F(K,L))/D(K,L)
14946       ELSEIF(ND.EQ.9) THEN
14947         HWH2DD = -ZI/F(K,L)/(F(J,K)+F(J,L)+F(K,L))
14948       ELSEIF(ND.EQ.10) THEN
14949         HWH2DD =  ZI/F(K,L)/(F(I,K)+F(I,L)+F(K,L))
14950       ENDIF
14951       END
14952 CDECK  ID>, HWH2BH.
14953 *CMZ :-        -30/06/01  18.21.35  by  Stefano Moretti
14954 *-- Author :  Kosuke Odagiri & Stefano Moretti
14955 C-----------------------------------------------------------------------
14956       SUBROUTINE HWH2BH(P1,P2,P3,P4,P5,
14957      &                  EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,IFL,IRES,CKM,
14958      &                  GAMT,M2)
14959 C-----------------------------------------------------------------------
14960 C...Matrix element for b(1) + q(2) -> b(3) + q'(4) + H+/-(5) and C.C.,
14961 C...q(q') massless incoming(outgoing) quark, all other masses retained.
14962 C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW.
14963 C
14964 C...First release:  01-APR-1998 by Kosuke Odagiri
14965 C...First modified: 12-APR-1998 by Stefano Moretti
14966 C-----------------------------------------------------------------------
14967       INCLUDE 'HERWIG65.INC'
14968       INTEGER MU,IRES,IFL
14969       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
14970       DOUBLE PRECISION EMB,EMT,EMW,EMH,EMH01,EMH02,EMH03
14971       DOUBLE PRECISION GAMT,GAMWTMP,GAMH01,GAMH03,GAMH02,CKM
14972       DOUBLE PRECISION QW(0:3),QS(0:3)
14973       DOUBLE PRECISION N0,DOTHH,DOTSS,DOTWW,E1234
14974       DOUBLE PRECISION DOTTT,DOT12,DOT13,DOT14,DOT1H,DOT23
14975       DOUBLE PRECISION DOT24,DOT2H,DOT34,DOT3H,DOT4H
14976       DOUBLE PRECISION PT2,PV2,PA2,PTPV,PTPA,IMPTPV,IMPTPA
14977       DOUBLE PRECISION M2
14978       DOUBLE COMPLEX PV,PA,PT,PW,Z
14979       PARAMETER (GAMWTMP=0.D0,GAMH01=0.D0,GAMH03=0.D0,GAMH02=0.D0)
14980       PARAMETER (Z=(0.D0,1.D0))
14981       DOUBLE PRECISION SC,RICCI
14982       EXTERNAL SC,RICCI
14983 C
14984       DO 670 MU=0,3
14985          QW(MU)=P2(MU)-P4(MU)
14986          QS(MU)=P1(MU)-P3(MU)
14987  670  CONTINUE
14988 C
14989       DOTHH=EMH*EMH
14990       DOTSS=SC(QS,QS)
14991       DOTWW=SC(QW,QW)
14992       DOT13=EMB*EMB-DOTSS/2.D0
14993       DOT24=-DOTWW/2.D0
14994       DOT2H=SC(P2,P5)
14995       DOT4H=SC(P4,P5)
14996 C
14997       IF(IFL.EQ.1)THEN
14998         DOT12=SC(P1,P2)
14999         DOT14=SC(P1,P4)
15000         DOT1H=SC(P1,P5)
15001         DOT23=SC(P2,P3)
15002         DOT34=SC(P3,P4)
15003         DOT3H=SC(P3,P5)
15004         E1234=RICCI(P1,P2,P3,P4)
15005       ELSE IF(IFL.EQ.-1)THEN
15006         DOT12=-SC(P3,P2)
15007         DOT14=-SC(P3,P4)
15008         DOT1H=-SC(P3,P5)
15009         DOT23=-SC(P2,P1)
15010         DOT34=-SC(P1,P4)
15011         DOT3H=-SC(P1,P5)
15012         E1234=-RICCI(P1,P2,P3,P4)
15013       END IF
15014 C
15015       DOTTT=DOTHH+EMB*EMB+2.D0*DOT3H
15016 C
15017       PV=COSA*SINBMA/(DOTSS-EMH01*EMH01+Z*EMH01*GAMH01)+
15018      1   SINA*COSBMA/(DOTSS-EMH02*EMH02+Z*EMH02*GAMH02)
15019       PA=SINB/(DOTSS-EMH03*EMH03+Z*EMH03*GAMH03)
15020       PW=1./(DOTWW-EMW*EMW+Z*EMW*GAMWTMP)
15021 C REMOVE TOP DIAGRAM.
15022       IF(IRES.EQ.1)PT=1./(DOTTT-EMT*EMT+Z*EMT*GAMT)
15023       IF(IRES.EQ.0)PT=(0.D0,0.D0)
15024       PT=PT*CKM
15025       PT2 =DREAL(DCONJG(PT)*PT)
15026       PV2 =DREAL(DCONJG(PV)*PV)
15027       PA2 =DREAL(DCONJG(PA)*PA)
15028       PTPV=DREAL(DCONJG(PT)*PV)
15029       PTPA=DREAL(DCONJG(PT)*PA)
15030       IMPTPV=DIMAG(DCONJG(PT)*PV)
15031       IMPTPA=DIMAG(DCONJG(PT)*PA)
15032 C
15033       N0=ABS(PW)
15034 C
15035       M2=N0*N0* ( EMB*EMB/COSB/COSB*(PV2+PA2)*DOT13*
15036      &   (2.D0*DOT4H*DOT2H-DOT24*DOTHH)+
15037      T 2.D0*PT2*DOT12*
15038      O   (EMB*EMB*TANB*TANB*(2.D0*DOT3H*DOT4H-DOT34*DOTHH)+
15039      P    EMT*EMT/TANB/TANB*(EMT*EMT*DOT34))+
15040      & EMB*EMB*TANB/COSB*DREAL(PV+PA)*
15041      X   (DREAL(PT)*(4.D0*DOT4H*DOT12*DOT13-
15042      T    (2.D0*DOT4H+DOTHH)*(DOT12*DOT34+DOT13*DOT24-DOT14*DOT23))+
15043      M    DIMAG(PT)*(2.D0*DOT4H+DOTHH)*E1234) )
15044       RETURN
15045  999  END
15046 C
15047       DOUBLE PRECISION FUNCTION SC(A,B)
15048       DOUBLE PRECISION A(0:3),B(0:3)
15049       SC=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3)
15050       RETURN
15051       END
15052 C
15053       DOUBLE PRECISION FUNCTION RICCI(A,B,C,D)
15054       DOUBLE PRECISION A(0:3),B(0:3),C(0:3),D(0:3)
15055       RICCI=
15056      & A(0)*B(1)*C(2)*D(3)+A(0)*B(2)*C(3)*D(1)+A(0)*B(3)*C(1)*D(2)-
15057      & A(0)*B(3)*C(2)*D(1)-A(0)*B(1)*C(3)*D(2)-A(0)*B(2)*C(1)*D(3)+
15058      & A(1)*B(0)*C(3)*D(2)+A(1)*B(2)*C(0)*D(3)+A(1)*B(3)*C(2)*D(0)-
15059      & A(1)*B(2)*C(3)*D(0)-A(1)*B(3)*C(0)*D(2)-A(1)*B(0)*C(2)*D(3)+
15060      & A(2)*B(3)*C(0)*D(1)+A(2)*B(0)*C(1)*D(3)+A(2)*B(1)*C(3)*D(0)-
15061      & A(2)*B(1)*C(0)*D(3)-A(2)*B(3)*C(1)*D(0)-A(2)*B(0)*C(3)*D(1)+
15062      & A(3)*B(2)*C(1)*D(0)+A(3)*B(0)*C(2)*D(1)+A(3)*B(1)*C(0)*D(2)-
15063      & A(3)*B(0)*C(1)*D(2)-A(3)*B(1)*C(2)*D(0)-A(3)*B(2)*C(0)*D(1)
15064       RETURN
15065       END
15066 CDECK  ID>, HWH2F1
15067 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
15068 C-----------------------------------------------------------------------
15069       SUBROUTINE HWH2F1(NP,F,I,P,MQ)
15070 C-----------------------------------------------------------------------
15071 C     Subroutine to implement the F function of Eijk and Kliess
15072 C     fixed first momenta and all second momenta
15073 C-----------------------------------------------------------------------
15074       INCLUDE 'HERWIG65.INC'
15075       DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15076       DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
15077       INTEGER I,J,NP
15078       EXTERNAL HWULDO
15079       COMMON/HWHEWS/S(8,8,2),D(8,8)
15080       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15081       PARAMETER(EPS=1D-10)
15082 C--find the massless momentum we need
15083       PDOT = HWULDO(PCM(1,I),P)
15084       P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15085       IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15086          PDOT = HALF
15087       ELSE
15088          PDOT = HALF*P(5)/PDOT
15089       ENDIF
15090       DO J=1,4
15091         PM(J) = P(J)-PDOT*PCM(J,I)
15092       ENDDO
15093       IF(P(5).GT.ZERO) THEN
15094          P(5)=SQRT(P(5))
15095       ELSE
15096          P(5)=ZERO
15097       ENDIF
15098       PM(5) = ZERO
15099 C--calculate its spinor product with the fixed momentum
15100       CALL HWH2SS(SIP,PCM(1,I),PM)
15101 C--calculate the F functions
15102       DO J=1,NP
15103         CALL HWH2SS(SJP,PM,PCM(1,J))
15104         F(1,1,J) = SIP(1)*SJP(2)
15105         F(1,2,J) = MQ*S(I,J,1)
15106         F(2,1,J) = MQ*S(I,J,2)
15107         F(2,2,J) = SIP(2)*SJP(1)
15108       ENDDO
15109       END
15110 CDECK  ID>, HWH2F2
15111 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
15112 C-----------------------------------------------------------------------
15113       SUBROUTINE HWH2F2(NP,F,I,P,MQ)
15114 C-----------------------------------------------------------------------
15115 C     Subroutine to implement the F function of Eijk and Kliess
15116 C     fixed second momenta and all first momenta
15117 C-----------------------------------------------------------------------
15118       INCLUDE 'HERWIG65.INC'
15119       DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15120       DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
15121       INTEGER I,J,NP
15122       EXTERNAL HWULDO
15123       COMMON/HWHEWS/S(8,8,2),D(8,8)
15124       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15125       PARAMETER(EPS=1D-10)
15126 C--find the massless momentum we need
15127       PDOT = HWULDO(PCM(1,I),P)
15128       P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15129       IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15130          PDOT = HALF
15131       ELSE
15132          PDOT = HALF*P(5)/PDOT
15133       ENDIF
15134       DO J=1,4
15135         PM(J) = P(J)-PDOT*PCM(J,I)
15136       ENDDO
15137       IF(P(5).GT.ZERO) THEN
15138          P(5)=SQRT(P(5))
15139       ELSE
15140          P(5)=ZERO
15141       ENDIF
15142       PM(5) = ZERO
15143 C--calculate its spinor product with the fixed momentum
15144       CALL HWH2SS(SIP,PM,PCM(1,I))
15145 C--calculate the F functions
15146       DO J=1,NP
15147         CALL HWH2SS(SJP,PCM(1,J),PM)
15148         F(1,1,J) = SIP(2)*SJP(1)
15149         F(1,2,J) = MQ*S(J,I,1)
15150         F(2,1,J) = MQ*S(J,I,2)
15151         F(2,2,J) = SIP(1)*SJP(2)
15152       ENDDO
15153       END
15154 CDECK  ID>, HWH2F3
15155 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
15156 C-----------------------------------------------------------------------
15157       SUBROUTINE HWH2F3(NP,F,P,MQ)
15158 C-----------------------------------------------------------------------
15159 C     Subroutine to implement the F function of Eijk and Kliess
15160 C     All first and second momenta
15161 C-----------------------------------------------------------------------
15162       INCLUDE 'HERWIG65.INC'
15163       DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15164       DOUBLE COMPLEX F(2,2,8,8),SIP(2),SJP(2),S,D
15165       INTEGER I,J,NP
15166       COMMON/HWHEWS/S(8,8,2),D(8,8)
15167       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15168       EXTERNAL HWULDO
15169       PARAMETER(EPS=1D-10)
15170 C--find the massless momentum we need
15171       DO I=1,NP
15172         PDOT = HWULDO(PCM(1,I),P)
15173         P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15174         IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15175            PDOT = HALF
15176         ELSE
15177            PDOT = HALF*P(5)/PDOT
15178         ENDIF
15179         DO J=1,4
15180           PM(J) = P(J)-PDOT*PCM(J,I)
15181         ENDDO
15182         IF(P(5).GT.ZERO) THEN
15183            P(5)=SQRT(P(5))
15184         ELSE
15185            P(5)=ZERO
15186         ENDIF
15187         PM(5) = ZERO
15188 C--calculate its spinor product with the fixed momentum
15189         CALL HWH2SS(SIP,PCM(1,I),PM)
15190 C--calculate the F functions
15191         DO J=I,NP
15192           CALL HWH2SS(SJP,PM,PCM(1,J))
15193           F(1,1,I,J) = SIP(1)*SJP(2)
15194           F(1,2,I,J) = MQ*S(I,J,1)
15195           F(2,1,I,J) = MQ*S(I,J,2)
15196           F(2,2,I,J) = SIP(2)*SJP(1)
15197         ENDDO
15198       ENDDO
15199       DO I=1,NP
15200         DO J=I+1,NP
15201           F(1,1,J,I) =  F(2,2,I,J)
15202           F(1,2,J,I) = -F(1,2,I,J)
15203           F(2,1,J,I) = -F(2,1,I,J)
15204           F(2,2,J,I) =  F(1,1,I,J)
15205         ENDDO
15206       ENDDO
15207       END
15208 CDECK  ID>, HWH2HE.
15209 *CMZ :-        -13/10/02  09.43.05  by  Peter Richardson
15210 *-- Author :    Kosuke Odagiri and Stefano Moretti
15211 C-----------------------------------------------------------------------
15212       SUBROUTINE HWH2HE(FIRST,GAUGE,IFL,IH,HFC,HBC,
15213      & E,S2W,TANB,AL,RMW,S,Q3, P3,P4,P5,
15214      & RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
15215      & RML,GAML,RMH,GAMH,RMA,GAMA,
15216      & RMZ,GAMZ,CFAC,RES)
15217 C-----------------------------------------------------------------------
15218 C     MATRIX ELEMENT SQUARED FOR
15219 C     e-(1) e+(2) -> f(3) f(')bar(4) Higgs(5)
15220 C     (SAME QUARK MASSES IN YUKAWA AND KINEMATICS)
15221 C-----------------------------------------------------------------------
15222       IMPLICIT NONE
15223       LOGICAL FIRST,GAUGE
15224       DOUBLE PRECISION HFC,HBC
15225       DOUBLE PRECISION CFAC
15226       DOUBLE PRECISION E,S2W,TANB,AL,RMW,S,Q3,RES
15227       DOUBLE PRECISION P3(0:3),P4(0:3),P5(0:3)
15228       DOUBLE PRECISION RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,RMZ,GAMZ
15229       DOUBLE PRECISION RML,GAML,RMH,GAMH,RMA,GAMA,Q2
15230       DOUBLE PRECISION XW,GE(-1:1),G3(-1:1),G4(-1:1),G5(-1:1)
15231       DOUBLE PRECISION RM(-1:1),RN1(-1:1),RN2(-1:1),RN3
15232       DOUBLE PRECISION SQS,TWOSQS,HLFSQS,P34,M34,PREFAC
15233       DOUBLE PRECISION RLE,RLLE,EP3(-1:1),EP4(-1:1),ZERO,ONE,TWO,HLF
15234       DOUBLE PRECISION BE,DUMMY(0:3),SA,CA,SB,CB
15235       INTEGER I,LE,L,IFL,IH
15236       DOUBLE COMPLEX PROPZ,PROP3(-1:1),PROP4(-1:1),PROP5,PROP6
15237       DOUBLE COMPLEX PROP7(-1:1)
15238       DOUBLE COMPLEX PP(-1:1),MM(-1:1),QQ(-1:1),ZP3,ZP4,ZP5
15239       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,HLF=.5D0)
15240       SAVE XW,GE,G3,G4,G5,RM,PREFAC
15241 C QUANTITIES WHICH CAN BE COMPUTED ONLY ONCE
15242       IF(FIRST)THEN
15243 C SOME COMMON INITIALISATIONS
15244         DO I=-1,1
15245           RM(I)=ZERO
15246           RN1(I)=ZERO
15247           RN2(I)=ZERO
15248         END DO
15249         DO I=0,3
15250           DUMMY(I)=ZERO
15251         END DO
15252         RN3=ZERO
15253         XW=TWO*S2W
15254         GE( 0)=-ONE
15255         GE(+1)=-GE(0)*XW
15256         GE(-1)=-ONE+GE(1)
15257         IF(IH.LE.3)THEN
15258           G3( 0)=Q3
15259           G3(+1)=-G3(0)*XW
15260           G3(-1)=-ONE*(-Q3/ABS(Q3))+G3(1)
15261           G4( 0)=G3( 0)
15262           G4(+1)=G3(+1)
15263           G4(-1)=G3(-1)
15264           G5( 0)=ZERO
15265           G5(+1)=ONE
15266           G5(-1)=ONE
15267 C HIGGS ANGLES
15268           BE=ATAN(TANB)
15269           SA=SIN(AL)
15270           CA=COS(AL)
15271           SB=SIN(BE)
15272           CB=COS(BE)
15273 C MSSM SCALING FACTORS FOR COUPLINGS
15274           IF(IH.LE.2)THEN
15275             RM(-1)=+YM3/RMW*HFC
15276             RM(+1)=+YM4/RMW*HFC
15277           ELSE IF(IH.EQ.3)THEN
15278             RM(-1)=+YM3/RMW*HFC
15279             RM(+1)=-YM4/RMW*HFC
15280           END IF
15281           IF(IH.LE.2)THEN
15282             IF(IH.EQ.1)RN1(-1)=+YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15283      &                        *(-SQRT(ABS(ONE-HBC**2)))
15284             IF(IH.EQ.1)RN1(+1)=-YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15285      &                        *(-SQRT(ABS(ONE-HBC**2)))
15286             IF(IH.EQ.2)RN1(-1)=-YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15287      &                        *(+SQRT(ABS(ONE-HBC**2)))
15288             IF(IH.EQ.2)RN1(+1)=+YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15289      &                        *(+SQRT(ABS(ONE-HBC**2)))
15290             RN2(-1)=ZERO
15291             RN2(+1)=ZERO
15292             IF(IH.EQ.0)RN3=1.D0
15293             IF(IH.EQ.1)RN3=HBC
15294             IF(IH.EQ.2)RN3=HBC
15295           ELSE IF(IH.EQ.3)THEN
15296             RN1(-1)=+YM3/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
15297      &                      *COS(BE-AL)
15298             RN1(+1)=+YM4/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
15299      &                      *COS(BE-AL)
15300             RN2(-1)=+YM3/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
15301      &                      *SIN(BE-AL)
15302             RN2(+1)=+YM4/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
15303      &                      *SIN(BE-AL)
15304             RN3=ZERO
15305           END IF
15306           PREFAC=E**6/(XW*S)*CFAC/TWO
15307         ELSE
15308           G3( 0)=Q3
15309           G3(+1)=-G3(0)*XW
15310           G3(-1)=-ONE+G3(1)
15311           G4( 0)=ONE+G3(0)
15312           G4(+1)=-G4(0)*XW
15313           G4(-1)=ONE+G4(1)
15314           G5( 0)=ONE
15315           G5(+1)=ONE-XW
15316           G5(-1)=ONE-XW
15317           RM(-1)=YM3*TANB/RMW
15318           RM(+1)=YM4/TANB/RMW
15319           RN1(-1)=RM(-1)
15320           RN1(+1)=RM(+1)
15321           RN2(-1)=ZERO
15322           RN2(+1)=ZERO
15323           RN3=ZERO
15324           PREFAC=E**6/(XW*S)*CFAC
15325         END IF
15326         FIRST=.FALSE.
15327       END IF
15328 C SOME ENERGY CONSTANTS
15329       SQS=DSQRT(S)
15330       TWOSQS=TWO*SQS
15331       HLFSQS=HLF*SQS
15332       PROPZ=S/(XW*(TWO-XW)*DCMPLX(S-RMZ**2,-RMZ*GAMZ))
15333 C SOME KINEMATICS
15334       P34=P3(0)*P4(0)-P3(1)*P4(1)-P3(2)*P4(2)-P3(3)*P4(3)
15335       M34=RM3*RM4
15336       RES=ZERO
15337 C FF(')-BAR PROPAGATOR
15338       Q2=RM3**2+RM4**2+TWO*P34
15339 C CONSTRUCT AMPLITUDE
15340       DO LE=-1,1,2
15341         RLE=DFLOAT(LE)
15342         IF(IH.LE.2)THEN
15343           PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15344      &                 DCMPLX(Q2-RMA**2,-RMA*GAMA)
15345           PROP6=(0.D0,0.D0)
15346         ELSE IF(IH.EQ.3)THEN
15347           PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15348      &                 DCMPLX(Q2-RML**2,-RML*GAML)
15349           PROP6=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15350      &                 DCMPLX(Q2-RMH**2,-RMH*GAMH)
15351         ELSE
15352           PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15353      &                 DCMPLX(Q2-RM5**2,-RM5*GAM5)
15354         END IF
15355         ZP3=DCMPLX(P3(1),-RLE*P3(2))
15356         ZP4=DCMPLX(P4(1),-RLE*P4(2))
15357         ZP5=-ZP3-ZP4
15358         DO L=-1,1,2
15359           PROP3(L)=(GE(0)*G3(0)+GE(LE)*G3(L)*PROPZ)/
15360      &               DCMPLX(S-TWOSQS*P3(0),-RM3*GAM3)
15361           PROP4(L)=(GE(0)*G4(0)+GE(LE)*G4(L)*PROPZ)/
15362      &               DCMPLX(S-TWOSQS*P4(0),-RM4*GAM4)
15363           PROP7(L)=GE(LE)*G3(L)*PROPZ/DCMPLX(Q2-RMZ**2,-RMZ*GAMZ)
15364         END DO
15365         DO L=-1,1,2
15366           PP(L)=-RM(-L)*SQS*(PROP3(L)+PROP4(-L))
15367           MM(L)=RM3*RM(+L)*(PROP3(L)-PROP3(-L))
15368      &         +RM4*RM(-L)*(PROP4(L)-PROP4(-L))
15369      &         +TWO*RMZ**2/RMW*RN3*PROP7(L)
15370           IF(GAUGE)THEN
15371             ZP3=P3(0)-HLFSQS
15372             ZP4=P4(0)-HLFSQS
15373             ZP5=P5(0)-HLFSQS
15374             PP(L)=DCMPLX(ZERO,ZERO)
15375             MM(L)=MM(L)+PROPZ*GE(LE)*DFLOAT(L)/TWOSQS*
15376      &                           (RM3*RM(L)/ZP3-RM4*RM(-L)/ZP4)
15377           END IF
15378           QQ(L)=RM(L)*(PROP3(-L)*ZP3-PROP4(L)*ZP4)
15379      &         +RN1(L)*PROP5*ZP5
15380      &         -RN2(L)*PROP6*ZP5
15381      &         +RM3/RMW*RN3*(PROP7(L)-PROP7(-L))*ZP5
15382           RLLE=DFLOAT(L*LE)
15383           EP3(L)=P3(0)+RLLE*P3(3)
15384           EP4(L)=P4(0)+RLLE*P4(3)
15385         END DO
15386         DO L=-1,1,2
15387           RES=RES+DREAL(
15388      &      EP3(+L)*EP4(+L)*DCONJG(PP(+L))*PP(+L)+
15389      &      EP3(+L)*EP4(-L)*DCONJG(MM(+L))*MM(+L)-
15390      &      TWO*RM3*EP4(+L)*DCONJG(PP(+L))*MM(-L)-
15391      &      TWO*RM4*EP3(+L)*DCONJG(PP(+L))*MM(+L)+
15392      &      M34*(DCONJG(PP(-L))*PP(+L)+DCONJG(MM(-L))*MM(+L))
15393      &      +TWO*DCONJG(QQ(-L))
15394      &      *((RM3*MM(-L)-EP3(+L)*PP(+L))*ZP4-
15395      &        (RM4*MM(+L)-EP4(+L)*PP(+L))*ZP3+
15396      &        P34*QQ(-L)-M34*QQ(+L)))
15397         END DO
15398       END DO
15399       RES=PREFAC*RES
15400  999  END
15401 CDECK  ID>, HWH2M0.
15402 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
15403 *-- Author :    Peter Richardson
15404 C-----------------------------------------------------------------------
15405       SUBROUTINE HWH2M0(IQ,IDZ,MG,MQ)
15406 C-----------------------------------------------------------------------
15407 C     Massless matrix elements for gg-->qqZ and qq-->qqZ
15408 C     using the matrix elements given in Nucl. Phys. B262 (1985) 235-242
15409 C-----------------------------------------------------------------------
15410       INCLUDE 'HERWIG65.INC'
15411       INTEGER IQ,I,J,OZ(2,2),IDZ,P1,P2,P3,P4,IQI,ID(2),K
15412       DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),FLOW(3,3),CQFC,CQIFC,
15413      &     CGFC,CGIFC
15414       DOUBLE COMPLEX MQAMP(2),HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,
15415      &     HWH2T6,HWH2T7,HWH2T8,HWH2T9,HWH2T0,DCF(8),HWH2DD,
15416      &     MGAMP(2,2,2,2,2),TRPGL(2)
15417       EXTERNAL HWH2DD,HWH2T0,HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,HWH2T6,
15418      &         HWH2T7,HWH2T8,HWH2T9
15419       PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
15420      &          CGIFC=-2.0D0/3.0D0)
15421       COMMON /HWHZBC/G
15422       DATA OZ/6,5,5,6/
15423       DATA ID/1,2/
15424 C--flavour of the final-state quark (1 is down-type and 2 is up-type)
15425       IQI  = MOD(IQ,2)
15426       IF(IQI.EQ.0) IQI=2
15427 C--calculate qqbar---> q'q'barZ
15428       DCF(1) = HWH2DD(4,2,1,3,4,5,6)
15429       DCF(2) = HWH2DD(5,2,1,3,4,5,6)
15430       DCF(3) = HWH2DD(4,3,4,2,1,5,6)
15431       DCF(4) = HWH2DD(5,3,4,2,1,5,6)
15432       DCF(5) = HWH2DD(4,3,1,2,4,5,6)
15433       DCF(6) = HWH2DD(5,3,1,2,4,5,6)
15434       DCF(7) = HWH2DD(4,2,4,3,1,5,6)
15435       DCF(8) = HWH2DD(5,2,4,3,1,5,6)
15436       DO I=1,3
15437         DO J=1,3
15438           FLOW(I,J) = ZERO
15439         ENDDO
15440       ENDDO
15441       DO I=1,2
15442 C--calculate the matrix element, N.B. two possibe colour flows
15443        DO P1=1,2
15444         DO P2=1,2
15445          DO P3=1,2
15446             MQAMP(1)= G(IDZ,P3)*(
15447      &      G(ID(I),P1)*(DCF(1)*HWH2T4(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2)
15448      &                  +DCF(2)*HWH2T5(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2))
15449      &       +G(IQ,P2)*(DCF(3)*HWH2T4(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)
15450      &                 +DCF(4)*HWH2T5(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)))
15451           IF(ID(I).NE.IQI) THEN
15452             MQAMP(2)=ZERO
15453           ELSE
15454             MQAMP(2)= G(IDZ,P3)*(
15455      &        G(IQ,P1)*(DCF(5)*HWH2T4(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2)
15456      &                 +DCF(6)*HWH2T5(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2))
15457      &       +G(IQ,P2)*(DCF(7)*HWH2T4(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)
15458      &                 +DCF(8)*HWH2T5(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)))
15459           ENDIF
15460           FLOW(I,1) = FLOW(I,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
15461           FLOW(I,2) = ZERO
15462           FLOW(I,3) = ZERO
15463           IF(IQI.EQ.ID(I)) THEN
15464             FLOW(3,1) = FLOW(3,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
15465             FLOW(3,2) = FLOW(3,2)+DBLE(MQAMP(2)*DCONJG(MQAMP(2)))
15466             IF(P1.EQ.P2) FLOW(3,3) = FLOW(3,3)
15467      &                         -TWO*DBLE(MQAMP(1)*DCONJG(MQAMP(2)))
15468           ENDIF
15469          ENDDO
15470         ENDDO
15471        ENDDO
15472       ENDDO
15473       DO I=1,3
15474         FLOW(I,1) =  CQFC*FLOW(I,1)
15475         FLOW(I,2) =  CQFC*FLOW(I,2)
15476         FLOW(I,3) = CQIFC*FLOW(I,3)
15477       ENDDO
15478 C--now find the matrix elements
15479       DO I=1,5
15480         K = MOD(I,2)
15481         IF(K.EQ.0) K=2
15482         IF(I.EQ.IQ) K=3
15483         DO J=1,2
15484           IF(FLOW(K,J).NE.ZERO) MQ(J,I) = FLOW(K,J)*
15485      &                           (ONE+FLOW(K,3)/(FLOW(K,1)+FLOW(K,2)))
15486         ENDDO
15487       ENDDO
15488 C--calculate gg---> bbbarZ
15489 C--coefficients for the diagrams
15490       DCF(1) = HWH2DD( 6,3,4,1,2,5,6)
15491       DCF(2) = HWH2DD( 7,3,4,1,2,5,6)
15492       DCF(3) = HWH2DD( 8,3,4,1,2,5,6)
15493       DCF(4) = HWH2DD( 6,3,4,2,1,5,6)
15494       DCF(5) = HWH2DD( 7,3,4,2,1,5,6)
15495       DCF(6) = HWH2DD( 8,3,4,2,1,5,6)
15496       DCF(7) = HWH2DD( 9,3,4,1,2,5,6)
15497       DCF(8) = HWH2DD(10,3,4,1,2,5,6)
15498 C--helicity amplitudes
15499       DO P1=1,2
15500        DO P2=1,2
15501          DO P3=1,2
15502           DO P4=1,2
15503            TRPGL(1)=
15504      &            DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15505      &           +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15506            TRPGL(2)=
15507      &            DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
15508      &           +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
15509            MGAMP(1,P1,P2,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(
15510      &          TRPGL(1)
15511      &         +DCF(1)*HWH2T6(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15512      &         +DCF(2)*HWH2T7(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15513      &         +DCF(3)*HWH2T8(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15514      &          )
15515            MGAMP(2,P2,P1,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(-TRPGL(2)
15516      &         +DCF(4)*HWH2T6(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15517      &         +DCF(5)*HWH2T7(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15518      &         +DCF(6)*HWH2T8(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2))
15519          ENDDO
15520         ENDDO
15521        ENDDO
15522       ENDDO
15523 C--square to obtain the matrix element
15524       DO I=1,3
15525         FLOW(1,I) = ZERO
15526       ENDDO
15527       DO P1=1,2
15528         DO P2=1,2
15529           DO P3=1,2
15530             DO P4=1,2
15531              FLOW(1,1) = FLOW(1,1)+DBLE(MGAMP(1,P1,P2,P3,P4)*
15532      &                              DCONJG(MGAMP(1,P1,P2,P3,P4)))
15533              FLOW(1,2) = FLOW(1,2)+DBLE(MGAMP(2,P1,P2,P3,P4)*
15534      &                              DCONJG(MGAMP(2,P1,P2,P3,P4)))
15535              FLOW(1,3) = FLOW(1,3)+TWO*DBLE(MGAMP(1,P1,P2,P3,P4)*
15536      &                              DCONJG(MGAMP(2,P1,P2,P3,P4)))
15537             ENDDO
15538           ENDDO
15539         ENDDO
15540       ENDDO
15541       FLOW(1,1) = CGFC*FLOW(1,1)
15542       FLOW(1,2) = CGFC*FLOW(1,2)
15543       FLOW(1,3) = CGIFC*FLOW(1,3)
15544       DO I=1,2
15545         MG(I) = FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
15546       ENDDO
15547       END
15548 CDECK  ID>, HWH2MQ.
15549 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
15550 *-- Author :    Peter Richardson
15551 C-----------------------------------------------------------------------
15552       SUBROUTINE HWH2MQ(IQ,IDZ,MG,MQ)
15553 C-----------------------------------------------------------------------
15554 C     Massive matrix elements for gg --> qqbarZ and qqbar --> qqbarZ
15555 C-----------------------------------------------------------------------
15556       INCLUDE 'HERWIG65.INC'
15557       INTEGER IQ,I,IDZ,P1,P2,PL,PB,PBB,O(2),J,IQI
15558       DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),CQFC,CQIFC,CGFC,CGIFC,
15559      &     PTMP(5,10),XMASS,PLAB,PRW,PCM,HWULDO,QBL,QBBL,Q2B,Q1B,Q2BB,
15560      &     Q1BB,QM2,FLOW(3,3),PG,PBQB,PBBQBB,QM,PQ,Q1L,Q2L,
15561      &     Q1LB,Q2LB,MQB(2,3),QBB
15562       DOUBLE COMPLEX S,D,FBB(2,2,8),FBBB(2,2,8),FBLL(2,2,8,8),MQP(2),
15563      &     FBBLL(2,2,8,8),F1B(2,2,8,8),F1BB(2,2,8,8),F2B(2,2,8,8),
15564      &     F2BB(2,2,8,8),DL(2,2),DCF(8),MGAMP(3),MQAMP(3,2,2,2,2),
15565      &     MQQAMP(2,2,2,2,2),F1LL(2,2,8,8),F2LL(2,2,8,8)
15566       DATA DL/(1.0D0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
15567       DATA O   /2,1/
15568       COMMON/HWHZBC/G
15569       COMMON/HWHEWS/S(8,8,2),D(8,8)
15570       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15571       PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
15572      &          CGIFC=-2.0D0/3.0D0)
15573       EXTERNAL HWULDO
15574 C--mass of the final-state quark
15575       QM  = RMASS(IQ)
15576       QM2 = RMASS(IQ)**2
15577 C--first calculate the F functions we will need
15578       DO I=1,4
15579         PTMP(I,1)  =  PCM(I,9)+PCM(I,5)+PCM(I,6)
15580         PTMP(I,2)  = -PCM(I,10)-PCM(I,5)-PCM(I,6)
15581         PTMP(I,3)  =  PCM(I,9)-PCM(I,1)
15582         PTMP(I,4)  =  PCM(I,1)-PCM(I,10)
15583         PTMP(I,5)  =  PCM(I,9)-PCM(I,2)
15584         PTMP(I,6)  =  PCM(I,2)-PCM(I,10)
15585         PTMP(I,7)  =  PCM(I,9)
15586         PTMP(I,8)  = -PCM(I,10)
15587         PTMP(I,9)  = PCM(I,1)-PCM(I,5)-PCM(I,6)
15588         PTMP(I,10) =-PCM(I,2)+PCM(I,5)+PCM(I,6)
15589       ENDDO
15590       CALL HWH2F3(8,FBLL ,  PTMP(1, 1),QM)
15591       CALL HWH2F3(8,FBBLL,  PTMP(1, 2),QM)
15592       CALL HWH2F3(8,F1B  ,  PTMP(1, 3),QM)
15593       CALL HWH2F3(8,F1BB ,  PTMP(1, 4),QM)
15594       CALL HWH2F3(8,F2B  ,  PTMP(1, 5),QM)
15595       CALL HWH2F3(8,F2BB ,  PTMP(1, 6),QM)
15596       CALL HWH2F1(8,FBB  ,3,PTMP(1, 7),QM)
15597       CALL HWH2F2(8,FBBB ,4,PTMP(1, 8),QM)
15598       CALL HWH2F3(8,F1LL ,  PTMP(1, 9),QM)
15599       CALL HWH2F3(8,F2LL ,  PTMP(1,10),QM)
15600 C--calculate the momenta squared for the denominators
15601       QBB = HALF/(QM2+HWULDO(PCM(1,9),PCM(1,10)))
15602       QBL   = ONE/(HWULDO(PTMP(1,1),PTMP(1,1))-QM2)
15603       QBBL  = ONE/(HWULDO(PTMP(1,2),PTMP(1,2))-QM2)
15604       Q1B   = ONE/(HWULDO(PTMP(1,3),PTMP(1,3))-QM2)
15605       Q1BB  = ONE/(HWULDO(PTMP(1,4),PTMP(1,4))-QM2)
15606       Q2B   = ONE/(HWULDO(PTMP(1,5),PTMP(1,5))-QM2)
15607       Q2BB  = ONE/(HWULDO(PTMP(1,6),PTMP(1,6))-QM2)
15608       Q1L  = HWULDO(PTMP(1, 9),PTMP(1, 9))
15609       Q2L  = HWULDO(PTMP(1,10),PTMP(1,10))
15610       Q1LB = ONE/(Q1L-QM2)
15611       Q2LB = ONE/(Q2L-QM2)
15612       Q1L  = ONE/Q1L
15613       Q2L  = ONE/Q2L
15614 C--first construct the massless momenta
15615       PBQB   = HWULDO(PCM(1,3),PCM(1,9))
15616       PBBQBB = HWULDO(PCM(1,4),PCM(1,10))
15617 C--first gg  --> q qbar Z
15618 C--calculate the denominators due gluon polaizations and massive quarks
15619       PG   = 0.25D0/PBQB/PBBQBB/D(1,2)/D(1,2)
15620 C--and the denominators
15621       DCF(1) = FOUR*QBL*Q2BB
15622       DCF(2) = FOUR*QBL*Q1BB
15623       DCF(3) = FOUR*Q1B*Q2BB
15624       DCF(4) = FOUR*Q2B*Q1BB
15625       DCF(5) = FOUR*Q1B*QBBL
15626       DCF(6) = FOUR*Q2B*QBBL
15627       DCF(7) =  TWO*QBL/D(1,2)
15628       DCF(8) =  TWO*QBBL/D(1,2)
15629 C--now calculate the matrix elements we need
15630       DO I=1,3
15631         FLOW(1,I) = ZERO
15632       ENDDO
15633       DO P1=1,2
15634       DO P2=1,2
15635       DO PL=1,2
15636       DO PB=1,2
15637       DO PBB=1,2
15638 C--first amplitude from notes
15639         MGAMP(1) = DCF(1)*(
15640      &     ( G(IQ,O(PL))*FBB(PB,   PL,6)*FBLL(  PL ,P1,5,2)
15641      &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),P1,6,2))*
15642      &         (F2BB(  P1 ,  P2 ,1,1)*FBBB(  P2 ,PBB,2)+
15643      &          F2BB(  P1 ,O(P2),1,2)*FBBB(O(P2),PBB,1))
15644      &    +( G(IQ,O(PL))*FBB(PB,  PL ,6)*FBLL(   PL,O(P1),5,1)
15645      &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P1),6,1))*
15646      &         (F2BB(O(P1),  P2 ,2,1)*FBBB(  P2 ,PBB,2)+
15647      &          F2BB(O(P1),O(P2),2,2)*FBBB(O(P2),PBB,1)))
15648 C--second amplitude from notes (1st with gluons interchanged)
15649         MGAMP(2) = DCF(2)*(
15650      &     ( G(IQ,O(PL))*FBB(PB,  PL ,6)*FBLL(  PL ,  P2 ,5,1)
15651      &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),  P2 ,6,1))*
15652      &         (F1BB(  P2 ,  P1 ,2,2)*FBBB(  P1 ,PBB,1)+
15653      &          F1BB(  P2 ,O(P1),2,1)*FBBB(O(P1),PBB,2))
15654      &    +( G(IQ,O(PL))*FBB(PB,  PL ,6)*FBLL(  PL ,O(P2),5,2)
15655      &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P2),6,2))*
15656      &         (F1BB(O(P2),  P1 ,1,2)*FBBB(  P1 ,PBB,1)+
15657      &          F1BB(O(P2),O(P1),1,1)*FBBB(O(P1),PBB,2)))
15658 C--third amplitude from notes
15659         MGAMP(1) = MGAMP(1)+DCF(3)*(
15660      &     G(IQ,O(PL))*( FBB(PB,  P1 ,2)*F1B(  P1 ,  PL ,1,6)
15661      &                  +FBB(PB,O(P1),1)*F1B(O(P1),  PL ,2,6))*
15662      &         (F2BB(PL,  P2 ,5,1)*FBBB(  P2 ,PBB,2)+
15663      &          F2BB(PL,O(P2),5,2)*FBBB(O(P2),PBB,1))
15664      &    +G(IQ,  PL )*( FBB(PB,  P1 ,2)*F1B(  P1 ,O(PL),1,5)
15665      &                  +FBB(PB,O(P1),1)*F1B(O(P1),O(PL),2,5))*
15666      &         (F2BB(O(PL),  P2 ,6,1)*FBBB(  P2 ,PBB,2)+
15667      &          F2BB(O(PL),O(P2),6,2)*FBBB(O(P2),PBB,1)))
15668 C--fourth amplitude from notes (3rd with gluons interchanged)
15669         MGAMP(2) = MGAMP(2)+DCF(4)*(
15670      &     G(IQ,O(PL))*( FBB(PB,  P2 ,1)*F2B(  P2 ,  PL ,2,6)
15671      &                  +FBB(PB,O(P2),2)*F2B(O(P2),  PL ,1,6))*
15672      &         (F1BB(  PL ,  P1 ,5,2)*FBBB(  P1 ,PBB,1)+
15673      &          F1BB(  PL ,O(P1),5,1)*FBBB(O(P1),PBB,2))
15674      &    +G(IQ,  PL )*( FBB(PB,  P2 ,1)*F2B(  P2 ,O(PL),2,5)
15675      &                  +FBB(PB,O(P2),2)*F2B(O(P2),O(PL),1,5))*
15676      &         ( F1BB(O(PL),  P1 ,6,2)*FBBB(  P1 ,PBB,1)
15677      &          +F1BB(O(PL),O(P1),6,1)*FBBB(O(P1),PBB,2)))
15678 C--fifth amplitude from notes
15679         MGAMP(1) = MGAMP(1)+DCF(5)*(
15680      &     ( G(IQ,O(PL))*FBBLL(  P2 ,  PL ,2,6)*FBBB(  PL ,PBB,5)
15681      &      +G(IQ,  PL )*FBBLL(  P2 ,O(PL),2,5)*FBBB(O(PL),PBB,6))*
15682      &         ( FBB(PB,  P1 ,2)*F1B(  P1 ,  P2 ,1,1)
15683      &          +FBB(PB,O(P1),1)*F1B(O(P1),  P2 ,2,1))
15684      &    +( G(IQ,O(PL))*FBBLL(O(P2),  PL ,1,6)*FBBB(  PL ,PBB,5)
15685      &      +G(IQ,  PL )*FBBLL(O(P2),O(PL),1,5)*FBBB(O(PL),PBB,6))*
15686      &         ( FBB(PB,  P1 ,2)*F1B(  P1 ,O(P2),1,2)
15687      &          +FBB(PB,O(P1),1)*F1B(O(P1),O(P2),2,2)))
15688 C--sixth amplitude from notes (5th with gluons interchanged)
15689         MGAMP(2) = MGAMP(2)+DCF(6)*(
15690      &     ( G(IQ,O(PL))*FBBLL(  P1 ,  PL ,1,6)*FBBB(  PL ,PBB,5)
15691      &      +G(IQ,  PL )*FBBLL(  P1 ,O(PL),1,5)*FBBB(O(PL),PBB,6))*
15692      &         ( FBB(PB,  P2 ,1)*F2B(  P2 ,  P1 ,2,2)
15693      &          +FBB(PB,O(P2),2)*F2B(O(P2),  P1 ,1,2))
15694      &    +( G(IQ,O(PL))*FBBLL(O(P1),  PL ,2,6)*FBBB(  PL ,PBB,5)
15695      &      +G(IQ,  PL )*FBBLL(O(P1),O(PL),2,5)*FBBB(O(PL),PBB,6))*
15696      &         ( FBB(PB,  P2 ,1)*F2B(  P2 ,O(P1),2,1)
15697      &          +FBB(PB,O(P2),2)*F2B(O(P2),O(P1),1,1)))
15698 C--seventh amplitude from notes (first non-Abelian one)
15699         MGAMP(3) = DCF(7)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
15700      &         G(IQ,O(PL))*FBB(PB,  PL ,6)*
15701      &                   ( FBLL(  PL ,1,5,1)*FBBB(1,PBB,1)
15702      &                    +FBLL(  PL ,2,5,1)*FBBB(2,PBB,1)
15703      &                    -FBLL(  PL ,1,5,2)*FBBB(1,PBB,2)
15704      &                    -FBLL(  PL ,2,5,2)*FBBB(2,PBB,2))
15705      &        +G(IQ,  PL )*FBB(PB,O(PL),5)*
15706      &                   ( FBLL(O(PL),1,6,1)*FBBB(1,PBB,1)
15707      &                    +FBLL(O(PL),2,6,1)*FBBB(2,PBB,1)
15708      &                    -FBLL(O(PL),1,6,2)*FBBB(1,PBB,2)
15709      &                    -FBLL(O(PL),2,6,2)*FBBB(2,PBB,2)))
15710 C--eighth amplitude from notes (second non-Abelian one)
15711 C--bug fix 12/7/03 by PR (too many continuations for NAG)
15712         MGAMP(3) = MGAMP(3)
15713      &        + DCF(8)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
15714      &         G(IQ,O(PL))*FBBB(  PL ,PBB,5)*
15715      &                   ( FBB(PB,1,1)*FBBLL(1,PL,1,6)
15716      &                    +FBB(PB,2,1)*FBBLL(2,PL,1,6)
15717      &                    -FBB(PB,1,2)*FBBLL(1,PL,2,6)
15718      &                    -FBB(PB,2,2)*FBBLL(2,PL,2,6))
15719      &        +G(IQ,  PL )*FBBB(O(PL),PBB,6)*
15720      &                   ( FBB(PB,1,1)*FBBLL(1,O(PL),1,5)
15721      &                    +FBB(PB,2,1)*FBBLL(2,O(PL),1,5)
15722      &                    -FBB(PB,1,2)*FBBLL(1,O(PL),2,5)
15723      &                    -FBB(PB,2,2)*FBBLL(2,O(PL),2,5)))
15724         MGAMP(1) = G(IDZ,PL)*(MGAMP(1)+MGAMP(3))
15725         MGAMP(2) = G(IDZ,PL)*(MGAMP(2)-MGAMP(3))
15726 C--now square them
15727         FLOW(1,1) = FLOW(1,1)+DBLE(MGAMP(1)*DCONJG(MGAMP(1)))
15728         FLOW(1,2) = FLOW(1,2)+DBLE(MGAMP(2)*DCONJG(MGAMP(2)))
15729         FLOW(1,3) = FLOW(1,3)+TWO*DBLE(MGAMP(1)*DCONJG(MGAMP(2)))
15730       ENDDO
15731       ENDDO
15732       ENDDO
15733       ENDDO
15734       ENDDO
15735 C--add up the diagrams to obtain the amplitudes for the two colour flows
15736       FLOW(1,1) = CGFC*FLOW(1,1)
15737       FLOW(1,2) = CGFC*FLOW(1,2)
15738       FLOW(1,3) = CGIFC*FLOW(1,3)
15739       DO I=1,2
15740         IF(FLOW(1,3).NE.ZERO) THEN
15741           MG(I) = PG*FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
15742         ELSE
15743           MG(I) = PG*FLOW(1,I)
15744         ENDIF
15745       ENDDO
15746 C--now q qbar --> q qbar Z
15747 C--calculate the denominators
15748       DCF(1) = -TWO*QBL/D(1,2)
15749       DCF(2) = -TWO*QBBL/D(1,2)
15750       DCF(3) = -TWO*Q1L*QBB
15751       DCF(4) = +TWO*Q2L*QBB
15752       DCF(5) =  TWO*Q1LB*Q2BB
15753       DCF(6) = -TWO*Q2LB*Q1B
15754       DCF(7) =  TWO*QBL*Q2BB
15755       DCF(8) = -TWO*QBBL*Q1B
15756       PQ = ONE/PBQB/PBBQBB
15757       DO P1=1,2
15758       DO PL=1,2
15759       DO PB=1,2
15760       DO PBB=1,2
15761 C--first the amplitudes for q qbar --> q' q'bar Z
15762 C--the first two amplitudes have Z off the final state and therefore
15763 C--the flavour of the incoming quarks doesn't matter
15764 C--first amplitude from notes
15765         MQAMP(3,P1,PL,PB,PBB) = G(IDZ,PL)*(
15766      &     DCF(1)*(G(IQ,O(PL))*FBB(O(PB),  PL ,6)*
15767      &                ( FBLL(  PL ,  P1 ,5,1)*FBBB(  P1 ,O(PBB),2)
15768      &                 +FBLL(  PL ,O(P1),5,2)*FBBB(O(P1),O(PBB),1))
15769      &            +G(IQ,  PL )*FBB(O(PB),O(PL),5)*
15770      &                ( FBLL(O(PL),  P1 ,6,1)*FBBB(  P1 ,O(PBB),2)
15771      &                 +FBLL(O(PL),O(P1),6,2)*FBBB(O(P1),O(PBB),1)))
15772 C--second amplitide from notes
15773      &    +DCF(2)*(G(IQ,O(PL))*FBBB(  PL ,O(PBB),5)*
15774      &          ( FBB(O(PB),  P1 ,1)*FBBLL(  P1 ,  PL ,2,6)
15775      &           +FBB(O(PB),O(P1),2)*FBBLL(O(P1),  PL ,1,6))
15776      &    +G(IQ,  PL )*FBBB(O(PL),O(PBB),6)*
15777      &          ( FBB(O(PB),  P1 ,1)*FBBLL(  P1 ,O(PL),2,5)
15778      &           +FBB(O(PB),O(P1),2)*FBBLL(O(P1),O(PL),1,5))))
15779 C--third amplitide from notes
15780         DO I=1,2
15781            MQAMP(I,P1,PL,PB,PBB) =
15782      &     DCF(3)*(G(I,O(PL))*DL(P1,O(PL))*S(5,1,  PL )*(
15783      &          S(1,6,O(PL))*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
15784      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
15785      &         -S(5,6,O(PL))*( FBB(O(PB),  P1 ,5)*FBBB(  P1 ,O(PBB),2)
15786      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),5)))
15787      &    +G(I,  PL )*DL(P1,  PL )*S(6,1,O(PL))*(
15788      &          S(1,5,  PL )*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
15789      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
15790      &      -S(6,5,  PL )*( FBB(O(PB),  P1 ,6)*FBBB(  P1 ,O(PBB),2)
15791      &                     +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),6))))
15792 C--fourth amplitude from notes
15793            MQAMP(I,P1,PL,PB,PBB) = MQAMP(I,P1,PL,PB,PBB)
15794      &    +DCF(4)*(G(I,O(PL))*DL(P1,O(PL))*S(2,6,  P1 )*(
15795      &          S(5,2,  PL )*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
15796      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
15797      &         -S(5,6,  PL )*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),6)
15798      &                        +FBB(O(PB),O(P1),6)*FBBB(O(P1),O(PBB),1)))
15799      &    +G(I,  PL )*DL(P1,  PL )*S(2,5,  P1 )*(
15800      &          S(6,2,O(PL))*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
15801      &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
15802      &        -S(6,5,O(PL))*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),5)
15803      &                      +FBB(O(PB),O(P1),5)*FBBB(O(P1),O(PBB),1))))
15804            MQAMP(I,P1,PL,PB,PBB) = G(IDZ,PL)*MQAMP(I,P1,PL,PB,PBB)
15805         ENDDO
15806 C--now the extra amplitudes for q qbar --> q qbar Z
15807         DO P2=1,2
15808 C--first amplitude for notes
15809            MQQAMP(P1,P2,PL,PB,PBB) =
15810      &   DCF(5)*(DL(P2,PBB)*S(8,4,PBB)*(
15811      &          G(IQ,O(PL))*DL(P1,O(PL))*S(5,1,  PL )*
15812      &             ( FBB(O(PB),  PBB,8)*F1LL(  P2  ,  PL ,2,6)
15813      &              +FBB(O(PB),O(P2),2)*F1LL(O(PBB),  PL ,8,6))
15814      &         +G(IQ,  PL )*DL(P1,  PL )*S(6,1,O(PL))*
15815      &             ( FBB(O(PB),  PBB ,8)*F1LL(  P2  ,O(PL),2,5)
15816      &              +FBB(O(PB),O(P2) ,2)*F1LL(O(PBB),O(PL),8,5)))
15817      &      -QM*DL(P2,O(PBB))*(
15818      &          G(IQ,O(PL))*DL(P1,O(PL))*S(5,1,PL)*
15819      &             ( FBB(O(PB),O(PBB),8)*F1LL(  P2  ,  PL ,2,6)
15820      &              +FBB(O(PB),O(P2) ,2)*F1LL(  PBB ,  PL ,8,6))
15821      &         +G(IQ,  PL )*DL(P1,  PL )*S(6,1,O(PL))*
15822      &             ( FBB(O(PB),O(PBB),8)*F1LL(  P2  ,O(PL),2,5)
15823      &              +FBB(O(PB), O(P2),2)*F1LL(  PBB ,O(PL),8,5))))
15824 C--second amplitude from notes
15825            MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
15826      &  +DCF(6)*(DL(P1,PB)*S(3,7,O(PB))*(
15827      &          G(IQ,O(PL))*DL(P2,O(PL))*S(2,6,  P2 )*
15828      &             ( F2LL(  PL ,  P1 ,5,1)*FBBB(  PB ,O(PBB),7)
15829      &              +F2LL(  PL ,O(PB),5,7)*FBBB(O(P1),O(PBB),1))
15830      &         +G(IQ,  PL )*DL(P2,  PL )*S(2,5,  P2 )*
15831      &             ( F2LL(O(PL),  P1 ,6,1)*FBBB(  PB ,O(PBB),7)
15832      &              +F2LL(O(PL),O(PB),6,7)*FBBB(O(P1),O(PBB),1)))
15833      &     -QM*DL(P1,O(PB))*(
15834      &          G(IQ,O(PL))*DL(P2,O(PL))*S(2,6,  P2 )*
15835      &             ( F2LL(  PL ,  P1 ,5,1)*FBBB(O(PB),O(PBB),7)
15836      &              +F2LL(  PL ,  PB ,5,7)*FBBB(O(P1),O(PBB),1))
15837      &         +G(IQ,  PL )*DL(P2,  PL )*S(2,5,  P2 )*
15838      &             ( F2LL(O(PL),  P1 ,6,1)*FBBB(O(PB),O(PBB),7)
15839      &              +F2LL(O(PL),  PB ,6,7)*FBBB(O(P1),O(PBB),1))))
15840 C--third  amplitude from notes
15841            MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
15842      &  +DCF(7)*(DL(P2,PBB)*S(8,4,PBB)*(
15843      &          G(IQ,O(PL))*FBB(O(PB),  PL ,6)*
15844      &             ( DL(P2,O(P1) )*S(2,1,  P2  )*FBLL(  PL , PBB ,5,8)
15845      &              +DL(P1,PBB   )*S(8,1,O(PBB))*FBLL(  PL ,O(P2),5,2))
15846      &         +G(IQ,  PL )*FBB(O(PB),O(PL),5)*
15847      &             ( DL(P2,O(P1) )*S(2,1,  P2  )*FBLL(O(PL), PBB ,6,8)
15848      &              +DL(P1,PBB   )*S(8,1,O(PBB))*FBLL(O(PL),O(P2),6,2)))
15849      &      -QM*DL(P2,O(PBB))*(
15850      &          G(IQ,O(PL))*FBB(O(PB),PL,6)*
15851      &             ( DL(P2,O(P1) )*S(2,1,  P2  )*FBLL(  PL ,O(PBB),5,8)
15852      &              +DL(P1,O(PBB))*S(8,1,  PBB )*FBLL(  PL ,O(P2) ,5,2))
15853      &         +G(IQ,  PL )*FBB(O(PB),O(PB),5)*
15854      &           ( DL(P2,O(PL) )*S(2,1,  P2  )*FBLL(O(PL),O(PBB),6,8)
15855      &            +DL(P1,O(PBB))*S(8,1,  PBB )*FBLL(O(PL),O(P2) ,6,2))))
15856 C--fourth amplitude from notes
15857            MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
15858      &  +DCF(8)*(DL(P1,PB)*S(3,7,O(PB))*(
15859      &          DL(P1,O(P2))*S(2,1,P2)*
15860      &           ( G(IQ,O(PL))*FBBLL(PB,  PL ,7,6)*FBBB(  PL ,O(PBB),5)
15861      &            +G(IQ,  PL )*FBBLL(PB,O(PL),7,5)*FBBB(O(PL),O(PBB),6))
15862      &         +DL(P2,PB)*S(2,7,P2)*
15863      &     (G(IQ,O(PL))*FBBLL(O(P1),  PL ,1,6)*FBBB(  PL ,O(PBB),5)
15864      &     +G(IQ,   PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6)))
15865      &       +QM*DL(P1,O(PB))*(
15866      &          DL(P2,O(P1))*S(2,1,P2)*
15867      &        ( G(IQ,O(PL))*FBBLL(O(PB),  PL ,3,6)*FBBB(  PL ,O(PBB),5)
15868      &         +G(IQ,  PL )*FBBLL(O(PB),O(PL),3,5)*FBBB(O(PL),O(PBB),6))
15869      &          +DL(P2,O(PB))*S(2,3,P2)*
15870      &      ( G(IQ,O(PL))*FBBLL(O(P1),  PL ,1,6)*FBBB(  PL ,O(PBB),5)
15871      &      +G(IQ,  PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6))))
15872            MQQAMP(P1,P2,PL,PB,PBB) =  G(IDZ,PL)*MQQAMP(P1,P2,PL,PB,PBB)
15873         ENDDO
15874       ENDDO
15875       ENDDO
15876       ENDDO
15877       ENDDO
15878 C--now obtain the matrix elements squared for the quarks
15879       DO I=1,3
15880          DO J=1,3
15881             FLOW(I,J) = ZERO
15882          ENDDO
15883       ENDDO
15884       IF(MOD(IQ,2).EQ.1) THEN
15885         IQI = 1
15886       ELSE
15887         IQI = 2
15888       ENDIF
15889       DO P1=1,2
15890       DO PL=1,2
15891       DO PB=1,2
15892       DO PBB=1,2
15893 C--different quarks in inital and final states
15894          DO I=1,2
15895             MQP(I) = MQAMP(I,P1,PL,PB,PBB)+MQAMP(3,P1,PL,PB,PBB)
15896             FLOW(I,1) = FLOW(I,1)+DCONJG(MQP(I))*MQP(I)
15897          ENDDO
15898 C--same quark in inital and final state
15899          DO P2=1,2
15900             FLOW(3,2) = FLOW(3,2)+
15901      &           DCONJG(MQQAMP(P1,P2,PL,PB,PBB))*MQQAMP(P1,P2,PL,PB,PBB)
15902            IF(P1.EQ.P2) THEN
15903               FLOW(3,1) = FLOW(3,1)+
15904      &             DCONJG(MQP(IQI))*MQP(IQI)
15905               FLOW(3,3) = FLOW(3,3)-TWO*
15906      &           DCONJG(MQP(IQI))*MQQAMP(P1,P2,PL,PB,PBB)
15907            ENDIF
15908          ENDDO
15909       ENDDO
15910       ENDDO
15911       ENDDO
15912       ENDDO
15913 C--split up the non-planar pieces according to Kosuke's prescription
15914       DO I=1,3
15915       FLOW(I,1) =  CQFC*FLOW(I,1)
15916       FLOW(I,2) =  CQFC*FLOW(I,2)
15917       FLOW(I,3) = CQIFC*FLOW(I,3)
15918         DO J=1,2
15919           IF(FLOW(I,J).NE.ZERO) THEN
15920              MQB(J,I) = PQ*FLOW(I,J)*
15921      &                            (ONE+FLOW(I,3)/(FLOW(I,1)+FLOW(I,2)))
15922           ELSE
15923              MQB(J,I) = ZERO
15924           ENDIF
15925         ENDDO
15926       ENDDO
15927 C--now set them
15928       DO I=1,5
15929         IF(I.EQ.IQ) THEN
15930           DO J=1,2
15931             MQ(J,I) = MQB(J,3)
15932           ENDDO
15933         ELSEIF(MOD(I,2).EQ.1) THEN
15934           DO J=1,2
15935             MQ(J,I) = MQB(J,1)
15936           ENDDO
15937         ELSE
15938           DO J=1,2
15939             MQ(J,I) = MQB(J,2)
15940           ENDDO
15941         ENDIF
15942       ENDDO
15943       END
15944 CDECK  ID>, HWH2PS.
15945 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
15946 *-- Author :    Peter Richardson
15947 C-----------------------------------------------------------------------
15948       SUBROUTINE HWH2PS(WEIGHT,GEN,MQ,MQ2)
15949 C-----------------------------------------------------------------------
15950 C     Phase Space for vector boson plus 2 jets
15951 C-----------------------------------------------------------------------
15952       INCLUDE 'HERWIG65.INC'
15953       DOUBLE PRECISION WEIGHT,XMASS,PLAB,PRW,PCM,Y(3),Y35,Y34,Y45,RAND,
15954      &     HWRGEN,HWRUNI,M35,M35S,G(IMAXCH),DEM,MT(3),PT(3),MJAC,ETOT,
15955      &     STOT,MQ(3),MQ2(3),PS35,HWUPCM,TWOPI2,MT35,PTJ(3),MT2(3),A,C,
15956      &     PT2(3),YMIN,YMAX,EY(3),EY34,YJAC,YJJMAX,YJJMIN,EY35,PHI(3),
15957      &     MT45,PS45,EY45,M45,M45S,M34,PS34,M34S,MT34,XJAC,SJAC,PST,TAU,
15958      &     FLUX,ETMP,PZTMP,XT1,XT2,WI(IMAXCH)
15959       COMMON /HWPSOM/ WI
15960       INTEGER I,ICH,J
15961       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15962       LOGICAL GEN
15963       EXTERNAL HWRGEN,HWRUNI,HWUPCM
15964       PARAMETER(YJJMIN=-8.0D0,YJJMAX=8.0D0)
15965       IF(IERROR.NE.0) RETURN
15966       TWOPI2 = FOUR*PIFAC**2
15967       WEIGHT = ZERO
15968       IF(OPTM) THEN
15969         DO I=1,IMAXCH
15970           WI(I) = ZERO
15971         ENDDO
15972       ENDIF
15973       GEN = .FALSE.
15974 C--centre of mass energy
15975       ETOT = PHEP(5,3)
15976       STOT = ETOT**2
15977 C--first select the channel to be used
15978       RAND=HWRGEN(0)
15979       DO ICH=1,IMAXCH
15980         IF(CHON(ICH)) THEN
15981           IF(CHNPRB(ICH).GT.RAND) GOTO 10
15982           RAND = RAND-CHNPRB(ICH)
15983         ENDIF
15984       ENDDO
15985  10   CONTINUE
15986 C--generate the phase space according to the channel selected
15987 C--FIRST CHANNEL
15988       IF(ICH.EQ.1) THEN
15989 C--first generate the mass of 35
15990         CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
15991         M35 = SQRT(M35S)
15992         PS35 = HWUPCM(M35,MQ(1),MQ(3))
15993         MJAC = HALF*MJAC*PS35/M35/TWOPI2
15994 C--the generate the PT of 4
15995         CALL HWH2P2(2,PTJ(1),MT2(2),MQ2(2)+PTMAX**2,MQ2(2)+PTMIN**2)
15996         MT (2) = SQRT(MT2(2))
15997         PT2(2) = MT2(2)-MQ2(2)
15998         PT(2)  = SQRT(PT2(2))
15999         MT35   = SQRT(M35S+PT2(2))
16000 C--generate the rapidities of 4 and 35
16001         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
16002         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
16003         IF(YMAX.LT.YMIN) RETURN
16004         Y35   = HWRUNI(1,YMIN,YMAX)
16005         EY35  = EXP(Y35)
16006         YJAC  = (YMAX-YMIN)
16007         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
16008         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
16009         IF(YMAX.LT.YMIN) RETURN
16010         Y(2)  = HWRUNI(2,YMIN,YMAX)
16011         YJAC  = (YMAX-YMIN)*YJAC
16012         EY(2) = EXP(Y(2))
16013 C--generate the incoming quark momentum fractions
16014         XX(1) = (MT(2)*EY(2)+MT35*EY35)/ETOT
16015         XX(2) = (MT(2)/EY(2)+MT35/EY35)/ETOT
16016         STOT = XX(1)*XX(2)*STOT
16017 C--azimuthal angle of 4 and 35
16018         PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16019 C--construct the momenta of 4 and 35
16020         PLAB(1,4) = PT(2)*SIN(PHI(1))
16021         PLAB(2,4) = PT(2)*COS(PHI(1))
16022         PLAB(3,4) = HALF*MT(2)*(EY(2)-ONE/EY(2))
16023         PLAB(4,4) = HALF*MT(2)*(EY(2)+ONE/EY(2))
16024         PLAB(5,4) = MQ(2)
16025         PLAB(1,6) =-PT(2)*SIN(PHI(1))
16026         PLAB(2,6) =-PT(2)*COS(PHI(1))
16027         PLAB(3,6) = HALF*MT35*(EY35-ONE/EY35)
16028         PLAB(4,6) = HALF*MT35*(EY35+ONE/EY35)
16029         PLAB(5,6) = M35
16030 C--perform the decay 35 --> 3+5
16031         PLAB(5,3) = MQ(1)
16032         PLAB(5,5) = MQ(3)
16033         CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
16034 C--phase space weight
16035         FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16036 C--SECOND CHANNEL
16037       ELSEIF(ICH.EQ.2) THEN
16038 C--first generate the pt's and azimuthal angles of 3 and 4
16039         DO I=1,2
16040            CALL HWH2P2(2,PTJ(I),MT2(I),MQ2(I)+PTMAX**2,MQ2(I)+PTMIN**2)
16041            PT2(I) = MT2(I)-MQ2(I)
16042            MT(I) = SQRT(MT2(I))
16043            PT(I) = SQRT(PT2(I))
16044            PHI(I) = HWRUNI(I,ZERO,TWO*PIFAC)
16045         ENDDO
16046 C--find the pt and azimuth of 5 by conservation of transverse momentum
16047         A      = PT(1)*SIN(PHI(1))+PT(2)*SIN(PHI(2))
16048         C      = PT(1)*COS(PHI(1))+PT(2)*COS(PHI(2))
16049         PT(3)  = A**2+C**2
16050         MT(3)  = SQRT(PT(3)+MQ2(3))
16051         PT(3)  = SQRT(PT(3))
16052         PHI(3) = -ACOS(-C/PT(3))
16053         IF(A.LT.ZERO) PHI(3)=-PHI(3)
16054 C--generate the rapidities of 3,4 and 5
16055         XX(1) = ZERO
16056         XX(2) = ZERO
16057         YJAC  = ONE
16058         DO I=1,3
16059           YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XX(1))/MT(I)))
16060           YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XX(2))/MT(I)))
16061           IF(YMAX.LT.YMIN) RETURN
16062           Y(I)  = HWRUNI(I+2,YMIN,YMAX)
16063           EY(I) = EXP(Y(I))
16064           XX(1) = XX(1)+MT(I)*EY(I)
16065           XX(2) = XX(2)+MT(I)/EY(I)
16066           YJAC  = YJAC*(YMAX-YMIN)
16067         ENDDO
16068 C--generate the incoming quark momentum fractions
16069         XX(1) = XX(1)/PHEP(5,3)
16070         XX(2) = XX(2)/PHEP(5,3)
16071         IF(XX(1).GT.ONE.OR.XX(2).GT.ONE) RETURN
16072 C--Construct the 4-momenta of the outgoing particles
16073         DO I=1,3
16074           PLAB(1,I+2) = PT(I)*SIN(PHI(I))
16075           PLAB(2,I+2) = PT(I)*COS(PHI(I))
16076           PLAB(3,I+2) = HALF*MT(I)*(EY(I)-ONE/EY(I))
16077           PLAB(4,I+2) = HALF*MT(I)*(EY(I)+ONE/EY(I))
16078           PLAB(5,I+2) = MQ(I)
16079        ENDDO
16080 C--phase space weight
16081        STOT = XX(1)*XX(2)*STOT
16082        FLUX = YJAC*PTJ(1)*PTJ(2)/64.0D0/PIFAC/TWOPI2/STOT**2
16083 C--THIRD CHANNEL
16084       ELSEIF(ICH.EQ.3) THEN
16085 C--first generate the mass of 45
16086         CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16087         M45 = SQRT(M45S)
16088         PS45 = HWUPCM(M45,MQ(2),MQ(3))
16089         MJAC = HALF*MJAC*PS45/M45/TWOPI2
16090 C--the generate the PT of 4
16091         CALL HWH2P2(2,PTJ(1),MT2(1),MQ2(1)+PTMAX**2,MQ2(1)+PTMIN**2)
16092         MT (1) = SQRT(MT2(1))
16093         PT2(1) = MT2(1)-MQ2(1)
16094         PT(1)  = SQRT(PT2(1))
16095         MT45   = SQRT(M45S+PT2(1))
16096 C--generate the rapidities of 3 and 45
16097         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
16098         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
16099         IF(YMAX.LT.YMIN) RETURN
16100         Y45   = HWRUNI(1,YMIN,YMAX)
16101         EY45  = EXP(Y45)
16102         YJAC  = (YMAX-YMIN)
16103         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
16104         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
16105         IF(YMAX.LT.YMIN) RETURN
16106         Y(1)  = HWRUNI(2,YMIN,YMAX)
16107         YJAC  = (YMAX-YMIN)*YJAC
16108         EY(1) = EXP(Y(1))
16109 C--generate the incoming quark momentum fractions
16110         XX(1) = (MT(1)*EY(1)+MT45*EY45)/ETOT
16111         XX(2) = (MT(1)/EY(1)+MT45/EY45)/ETOT
16112         STOT = XX(1)*XX(2)*STOT
16113 C--azimuthal angle of 3 and 45
16114         PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16115 C--construct the momenta of 3 and 45
16116         PLAB(1,3) = PT(1)*SIN(PHI(1))
16117         PLAB(2,3) = PT(1)*COS(PHI(1))
16118         PLAB(3,3) = HALF*MT(1)*(EY(1)-ONE/EY(1))
16119         PLAB(4,3) = HALF*MT(1)*(EY(1)+ONE/EY(1))
16120         PLAB(5,3) = MQ(1)
16121         PLAB(1,6) =-PT(1)*SIN(PHI(1))
16122         PLAB(2,6) =-PT(1)*COS(PHI(1))
16123         PLAB(3,6) = HALF*MT45*(EY45-ONE/EY45)
16124         PLAB(4,6) = HALF*MT45*(EY45+ONE/EY45)
16125         PLAB(5,6) = M45
16126 C--perform the decay 45 --> 4+5
16127         PLAB(5,4) = MQ(2)
16128         PLAB(5,5) = MQ(3)
16129         CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
16130 C--phase space weight
16131         FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16132 C--FOURTH CHANNEL
16133       ELSEIF(ICH.EQ.4) THEN
16134 C--generate shat according to a power law
16135         CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
16136      &                                        (MQ(1)+MQ(2)+MQ(3))**2)
16137         ETOT = SQRT(STOT)
16138 C--generate x1
16139         TAU   = STOT/PHEP(5,3)**2
16140         XJAC  = -LOG(TAU)
16141         XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
16142         XX(2) = TAU/XX(1)
16143 C--generate m35
16144         CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,
16145      &                                               (MQ(1)+MQ(3))**2)
16146         M35 = SQRT(M35S)
16147         PS35 = HWUPCM(M35,MQ(1),MQ(3))
16148         MJAC = HALF*MJAC*PS35/M35/TWOPI2
16149 C--generate the momenta of 4 and 35
16150         PST = HWUPCM(ETOT,M35,MQ(2))
16151         PLAB(1,7) = ZERO
16152         PLAB(2,7) = ZERO
16153         PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
16154         PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
16155         PLAB(5,7) = ETOT
16156         PLAB(5,3) = MQ(1)
16157         PLAB(5,6) = M35
16158         PLAB(5,4) = MQ(2)
16159         CALL HWDTWO(PLAB(1,7),PLAB(1,4),PLAB(1,6),PST,TWO,.TRUE.)
16160 C--perform the decay 35 --> 3+5
16161         PLAB(5,4) = MQ(2)
16162         PLAB(5,5) = MQ(3)
16163         CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
16164 C--phase space weight
16165         FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
16166 C--FIFTH CHANNEL
16167       ELSEIF(ICH.EQ.5) THEN
16168 C--generate shat according to a power law
16169         CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
16170      &                                        (MQ(1)+MQ(2)+MQ(3))**2)
16171         ETOT = SQRT(STOT)
16172 C--generate x1
16173         TAU   = STOT/PHEP(5,3)**2
16174         XJAC  = -LOG(TAU)
16175         XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
16176         XX(2) = TAU/XX(1)
16177 C--generate m45
16178         CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16179         M45 = SQRT(M45S)
16180         PS45 = HWUPCM(M45,MQ(2),MQ(3))
16181         MJAC = HALF*MJAC*PS45/M45/TWOPI2
16182 C--generate the momenta of 4 and 35
16183         PST = HWUPCM(ETOT,M45,MQ(1))
16184         PLAB(1,7) = ZERO
16185         PLAB(2,7) = ZERO
16186         PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
16187         PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
16188         PLAB(5,7) = ETOT
16189         PLAB(5,3) = MQ(1)
16190         PLAB(5,6) = M45
16191         CALL HWDTWO(PLAB(1,7),PLAB(1,3),PLAB(1,6),PST,TWO,.TRUE.)
16192 C--perform the decay 45 --> 4+5
16193         PLAB(5,4) = MQ(2)
16194         PLAB(5,5) = MQ(3)
16195         CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
16196 C--phase space weight
16197         FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
16198 C--SIXTH CHANNEL
16199       ELSEIF(ICH.EQ.6) THEN
16200 C--first generate the mass of 34
16201         CALL HWH2P1(2,MJAC,ZERO,M34S,(ETOT-MQ(3))**2,MJJMIN**2)
16202         M34 = SQRT(M34S)
16203         PS34 = HWUPCM(M34,MQ(1),MQ(2))
16204         MJAC = HALF*MJAC*PS34/M34/TWOPI2
16205 C--the generate the PT of 5
16206         CALL HWH2P2(2,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
16207         MT (3) = SQRT(MT2(3))
16208         PT2(3) = MT2(3)-MQ2(3)
16209         PT(3)  = SQRT(PT2(3))
16210         MT34   = SQRT(M34S+PT2(3))
16211 C--generate the rapidities of 5 and 34
16212         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
16213         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
16214         IF(YMAX.LT.YMIN) RETURN
16215         Y34   = HWRUNI(1,YMIN,YMAX)
16216         EY34  = EXP(Y34)
16217         YJAC  = (YMAX-YMIN)
16218         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
16219         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
16220         IF(YMAX.LT.YMIN) RETURN
16221         Y(3)  = HWRUNI(2,YMIN,YMAX)
16222         YJAC  = (YMAX-YMIN)*YJAC
16223         EY(3) = EXP(Y(3))
16224 C--generate the incoming quark momentum fractions
16225         XX(1) = (MT(3)*EY(3)+MT34*EY34)/ETOT
16226         XX(2) = (MT(3)/EY(3)+MT34/EY34)/ETOT
16227         STOT = XX(1)*XX(2)*STOT
16228 C--azimuthal angle of 3 and 45
16229         PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16230 C--construct the momenta of 5 and 34
16231         PLAB(1,5) = PT(3)*SIN(PHI(1))
16232         PLAB(2,5) = PT(3)*COS(PHI(1))
16233         PLAB(3,5) = HALF*MT(3)*(EY(3)-ONE/EY(3))
16234         PLAB(4,5) = HALF*MT(3)*(EY(3)+ONE/EY(3))
16235         PLAB(5,5) = MQ(3)
16236         PLAB(1,6) =-PT(3)*SIN(PHI(1))
16237         PLAB(2,6) =-PT(3)*COS(PHI(1))
16238         PLAB(3,6) = HALF*MT34*(EY34-ONE/EY34)
16239         PLAB(4,6) = HALF*MT34*(EY34+ONE/EY34)
16240         PLAB(5,6) = M34
16241 C--perform the decay 34 --> 3+4
16242         PLAB(5,3) = MQ(1)
16243         PLAB(5,4) = MQ(2)
16244         CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,4),PS34,TWO,.TRUE.)
16245 C--phase space weight
16246         FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16247       ELSE
16248         CALL HWWARN('HWH2PS',500,*999)
16249       ENDIF
16250 C--calculate the variables we need for the smoothing functions
16251 C--pt,mt and y for outgoing particles
16252       DO I=1,3
16253         J=I+2
16254         PT2(I) = PLAB(1,J)**2+PLAB(2,J)**2
16255         PT(I)  = SQRT(PT2(I))
16256         MT2(I) = MQ2(I)+PT2(I)
16257         MT(I)  = SQRT(MT2(I))
16258         Y(I)   = HALF*LOG((PLAB(4,J)+PLAB(3,J))/(PLAB(4,J)-PLAB(3,J)))
16259         EY(I)  = EXP(Y(I))
16260         IF(I.LE.2.AND.(Y(I).LT.YJMIN.OR.Y(I).GT.YJMAX)) RETURN
16261       ENDDO
16262       IF(PT(1).LT.PTMIN.OR.PT(2).LT.PTMIN) RETURN
16263 C--masses of composite particles
16264       M34S = (PLAB(4,3)+PLAB(4,4))**2
16265       M45S = (PLAB(4,4)+PLAB(4,5))**2
16266       M35S = (PLAB(4,3)+PLAB(4,5))**2
16267       DO I=1,3
16268         M34S = M34S-(PLAB(I,3)+PLAB(I,4))**2
16269         M45S = M45S-(PLAB(I,4)+PLAB(I,5))**2
16270         M35S = M35S-(PLAB(I,3)+PLAB(I,5))**2
16271       ENDDO
16272       M34 = SQRT(M34S)
16273       M45 = SQRT(M45S)
16274       M35 = SQRT(M35S)
16275       IF(M34.LT.MJJMIN) RETURN
16276 C--tramsverse masses of the composite particles
16277       MT34 = ZERO
16278       MT35 = ZERO
16279       MT45 = ZERO
16280       DO I=1,2
16281         MT34 = MT34+(PLAB(I,3)+PLAB(I,4))**2
16282         MT35 = MT35+(PLAB(I,3)+PLAB(I,5))**2
16283         MT45 = MT45+(PLAB(I,4)+PLAB(I,5))**2
16284       ENDDO
16285       MT34 = SQRT(M34S+MT34)
16286       MT35 = SQRT(M35S+MT35)
16287       MT45 = SQRT(M45S+MT45)
16288 C--final the momenta
16289       PS34 = HWUPCM(M34,MQ(1),MQ(2))
16290       PS35 = HWUPCM(M35,MQ(1),MQ(3))
16291       PS45 = HWUPCM(M45,MQ(2),MQ(3))
16292 C--the rapidities of the composite particles
16293       ETMP  = PLAB(4,3)+PLAB(4,4)
16294       PZTMP = PLAB(3,3)+PLAB(3,4)
16295       Y34   = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16296       EY34  = EXP(Y34)
16297       ETMP  = PLAB(4,3)+PLAB(4,5)
16298       PZTMP = PLAB(3,3)+PLAB(3,5)
16299       Y35   = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16300       EY35  = EXP(Y35)
16301       ETMP  = PLAB(4,4)+PLAB(4,5)
16302       PZTMP = PLAB(3,4)+PLAB(3,5)
16303       Y45   = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16304       EY45  = EXP(Y45)
16305 C--find the pdf's and set the scale
16306       ETOT = SQRT(STOT)
16307       EMSCA = ETOT
16308       CALL HWSGEN(.FALSE.)
16309 C--construct the incoming momenta
16310       DO I=1,2
16311         PLAB(1,I) = ZERO
16312         PLAB(2,I) = ZERO
16313         PLAB(3,I) = HALF*XX(I)*PHEP(5,3)
16314         PLAB(4,I) = HALF*XX(I)*PHEP(5,3)
16315         PLAB(5,I) = ZERO
16316       ENDDO
16317       PLAB(3,2) = -PLAB(3,2)
16318       TAU   = XX(1)*XX(2)
16319 C--find the smoothing functions for the different channels
16320 C--function for first channel
16321       IF(CHON(1)) THEN
16322         CALL HWH2P1(1,MJAC,MQ2(1),M35S,(PHEP(5,3)-MQ(2))**2,
16323      &                                              (MQ(1)+MQ(3))**2)
16324         MJAC = MJAC/PS35*M35
16325         CALL HWH2P2(1,PTJ(1),MT2(2),PTMAX**2+MQ2(2),MQ2(2)+PTMIN**2)
16326         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
16327         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
16328         YJAC  = (YMAX-YMIN)
16329         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
16330         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
16331         YJAC  = (YMAX-YMIN)*YJAC
16332         G(1)  = 2.0D0*MJAC*PTJ(1)/YJAC
16333       ENDIF
16334 C--function for second channel
16335       IF(CHON(2)) THEN
16336         DO I=1,2
16337            CALL HWH2P2(1,PTJ(I),MT2(I),PTMAX**2+MQ2(I),MQ2(I)+PTMIN**2)
16338         ENDDO
16339         XT1 = ZERO
16340         XT2 = ZERO
16341         YJAC  = ONE
16342         DO I=1,3
16343           YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XT1)/MT(I)))
16344           YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XT2)/MT(I)))
16345           XT1  = XT1+MT(I)*EY(I)
16346           XT2  = XT2+MT(I)/EY(I)
16347           YJAC  = YJAC*(YMAX-YMIN)
16348         ENDDO
16349         G(2) = 4.0D0*PTJ(1)*PTJ(2)/YJAC
16350       ENDIF
16351 C--function for third channel
16352       IF(CHON(3)) THEN
16353         CALL HWH2P1(1,MJAC,MQ2(2),M45S,(PHEP(5,3)-MQ(1))**2,
16354      &                                            (MQ(2)+MQ(3))**2)
16355         MJAC = MJAC/PS45*M45
16356         CALL HWH2P2(1,PTJ(1),MT2(1),PTMAX**2+MQ2(1),MQ2(1)+PTMIN**2)
16357         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
16358         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
16359         YJAC  = (YMAX-YMIN)
16360         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
16361         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
16362         YJAC  = (YMAX-YMIN)*YJAC
16363         G(3)  = 2.0D0*MJAC*PTJ(1)/YJAC
16364       ENDIF
16365 C--function for fourth channel
16366       IF(CHON(4)) THEN
16367         CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
16368      &                                        (MQ(1)+MQ(2)+MQ(3))**2)
16369         XJAC  = -LOG(TAU)
16370         CALL HWH2P1(1,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
16371         M35 = SQRT(M35S)
16372         MJAC = MJAC/PS35*M35
16373         PST = HWUPCM(ETOT,M35,MQ(2))
16374         G(4) = SJAC*MJAC/XJAC*ETOT/PST
16375       ENDIF
16376 C--function for fifth channel
16377       IF(CHON(5)) THEN
16378         CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
16379      &                                        (MQ(1)+MQ(2)+MQ(3))**2)
16380         XJAC  = -LOG(TAU)
16381         CALL HWH2P1(1,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16382         MJAC = MJAC/PS45*M45
16383         PST = HWUPCM(ETOT,M45,MQ(1))
16384         G(5) = SJAC/XJAC*MJAC/PST*ETOT
16385       ENDIF
16386 C--function for sixth chaneel
16387       IF(CHON(6)) THEN
16388         CALL HWH2P1(1,MJAC,ZERO,M34S,(PHEP(5,3)-MQ(3))**2,MJJMIN**2)
16389         MJAC = MJAC/PS34*M34
16390         CALL HWH2P2(1,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
16391         YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
16392         YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
16393         YJAC  = (YMAX-YMIN)
16394         YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
16395         YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
16396         YJAC  = (YMAX-YMIN)*YJAC
16397         G(6)  = 2.0D0*MJAC/YJAC*PTJ(1)
16398       ENDIF
16399 C--add them all up
16400       DEM = ZERO
16401       DO I=1,IMAXCH
16402         IF(CHON(I)) DEM = DEM+CHNPRB(I)*G(I)
16403       ENDDO
16404 C--now the weight
16405       WEIGHT = FLUX*GEV2NB*G(ICH)/DEM
16406       GEN = .TRUE.
16407 C--compute the weights for the different channels if optimizing
16408       IF(OPTM) THEN
16409         DO I=1,IMAXCH
16410           IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
16411         ENDDO
16412       ENDIF
16413  999  END
16414 CDECK  ID>, HWH2P1.
16415 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
16416 *-- Author :    Peter Richardson
16417 C-----------------------------------------------------------------------
16418       SUBROUTINE HWH2P1(IOPT,FJAC,MQ2,M2,MMX,MMN)
16419 C-----------------------------------------------------------------------
16420 C     Subroutine to select virtual quark mass for HWH2PS
16421 C     IOPT=1 return the function at M2
16422 C     IOPT=2 calculate M2
16423 C-----------------------------------------------------------------------
16424       INCLUDE 'HERWIG65.INC'
16425       INTEGER IOPT
16426       DOUBLE PRECISION FJAC,MPOW,MMN,MQ2,M2,A1,A01,RPOW,QPOW,HWRGEN,MMX
16427       EXTERNAL HWRGEN
16428 C--smooth a powerlaw
16429       IF(EMPOW.EQ.TWO) THEN
16430         A01   = LOG(MMN-MQ2)
16431         A1    = LOG(MMX-MQ2)-A01
16432         IF(IOPT.EQ.1) THEN
16433           FJAC = ONE/(M2-MQ2)/A1
16434         ELSE
16435           M2 = EXP(A01+A1*HWRGEN(2))
16436           FJAC  = A1*M2
16437           M2 = M2+MQ2
16438         ENDIF
16439       ELSE
16440         MPOW = -EMPOW/TWO
16441         QPOW =  ONE+MPOW
16442         RPOW =  ONE/QPOW
16443         A01  =  (MMN-MQ2)**QPOW
16444         A1   =  (MMX-MQ2)**QPOW-A01
16445         IF(IOPT.EQ.1) THEN
16446           FJAC = QPOW*(M2-MQ2)**MPOW/A1
16447         ELSE
16448           M2 = (A01+A1*HWRGEN(2))**RPOW
16449           FJAC  = A1*RPOW/M2**MPOW
16450           M2 = M2+MQ2
16451         ENDIF
16452       ENDIF
16453  999  END
16454 CDECK  ID>, HWH2P2.
16455 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
16456 *-- Author :    Peter Richardson
16457 C-----------------------------------------------------------------------
16458       SUBROUTINE HWH2P2(IOPT,FJAC,PT2,PTMX2,PTMN2)
16459 C-----------------------------------------------------------------------
16460 C     Subroutine to select virtual quark mass for HWH2PS
16461 C     IOPT=1 return the function at M2
16462 C     IOPT=2 calculate M2
16463 C-----------------------------------------------------------------------
16464       INCLUDE 'HERWIG65.INC'
16465       INTEGER IOPT
16466       DOUBLE PRECISION FJAC,MPOW,A1,A01,RPOW,QPOW,HWRGEN,PT2,
16467      &     PPOW,PTMN2,PTMX2,Z
16468       EXTERNAL HWRGEN
16469 C--smooth a powerlaw
16470       PPOW = HALF*PTPOW
16471       IF(PPOW.EQ.ONE) THEN
16472         A01   = LOG(PTMN2)
16473         A1    = LOG(PTMX2)-A01
16474         IF(IOPT.EQ.1) THEN
16475           FJAC = ONE/PT2/A1
16476         ELSE
16477           PT2 = EXP(A01+A1*HWRGEN(2))
16478           FJAC  = A1*PT2
16479         ENDIF
16480       ELSE
16481         MPOW = -PPOW
16482         QPOW =  ONE+MPOW
16483         RPOW =  ONE/QPOW
16484         A01  =  PTMN2**QPOW
16485         A1   =  PTMX2**QPOW-A01
16486         IF(IOPT.EQ.1) THEN
16487           FJAC = QPOW*PT2**MPOW/A1
16488         ELSE
16489           Z    = A01+A1*HWRGEN(2)
16490           PT2  = Z**RPOW
16491           FJAC = A1*RPOW/Z*PT2
16492         ENDIF
16493       ENDIF
16494  999  END
16495 CDECK  ID>, HWH2QH.
16496 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
16497 *-- Author :  Kosuke Odagiri
16498 C-----------------------------------------------------------------------
16499       SUBROUTINE HWH2QH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,FACGPM,MGM3,
16500      & IGG,IQQ,GGQQHT,GGQQHU,GGQQHNP,QQQQH)
16501 C-----------------------------------------------------------------------
16502 C     MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> QQ(BAR) HIGGS
16503 C-----------------------------------------------------------------------
16504 C     NEEDS PREFACTOR G_S^4. COUPLINGS, E.G. FOR T(3)B(4)H-(5) ARE:
16505 C     FACGPM(1) = GW/SQRT(TWO) M_B / M_W * TANB
16506 C     FACGPM(2) = GW/SQRT(TWO) M_T / M_W / TANB
16507 C     MGM3 = (TOP MASS)*(TOP WIDTH)
16508 C     INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
16509 C     PREFACTORS:
16510 C     GGQQHTOT = (G_S**4)*(GGQQHT+GGQQHU-GGQQHNP/CAFAC**2)/(8.*CFFAC)
16511 C     QQQQHTOT = (G_S**4)*(QQQQH                         )*(1.-1./CAFAC**2)/4.
16512 C     N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
16513 C-----------------------------------------------------------------------
16514       IMPLICIT NONE
16515 C --- SUBPROCESS
16516       INTEGER IGG,IQQ
16517 C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS
16518       DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
16519       DOUBLE PRECISION K3(0:3),K4(0:3), Q3(0:3),Q4(0:3), R3(0:3),R4(0:3)
16520       DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4, TWOSQS
16521 C --- SPINORS
16522       DOUBLE COMPLEX U0(4), F3(4,2),F4(4,2), F3K(4,2),F4K(4,2)
16523       DOUBLE COMPLEX F3Q(4,2,2),F4Q(4,2,2), F3R(4,2,2),F4R(4,2,2)
16524 C --- MOMENTUM PROJECTION OPERATORS
16525       DOUBLE COMPLEX P3PROJ(4,4),P4PROJ(4,4),K3PROJ(4,4),K4PROJ(4,4)
16526       DOUBLE COMPLEX Q3PROJ(4,4),Q4PROJ(4,4),R3PROJ(4,4),R4PROJ(4,4)
16527 C --- SPINOR INDICES AND PERMUTATION MATRICES
16528       INTEGER I,J,K,L, PERM0(4), PL(4,2),PR(4,2), PERMU0(4)
16529 C --- CHIRALITY PROJECTION OPERATORS: 1 = - ,  2 = +
16530       DOUBLE PRECISION FACGPM(2),FACL(2,2),FACR(2,2),FAC0(2,2)
16531 C --- GG AMPLITUDES
16532       DOUBLE COMPLEX AMPS1(2,2),AMPS2(2,2)
16533       DOUBLE COMPLEX AMPT1(2,2,2,2),AMPT2(2,2,2,2),AMPT3(2,2,2,2)
16534       DOUBLE COMPLEX AMPU1(2,2,2,2),AMPU2(2,2,2,2),AMPU3(2,2,2,2)
16535       DOUBLE COMPLEX AMPS, AMPT, AMPU, AMPST, AMPSU, AMPTU
16536       DOUBLE PRECISION AMPST2, AMPSU2, AMPTU2
16537       DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
16538 C --- QQ AMPLITUDES
16539       DOUBLE PRECISION RM3452
16540       DOUBLE PRECISION S,PT32,PT42,PT52,GLAMBDA,LAMBDA,LAMBDAI,LA34,
16541      &                 PROP2,PROP3R,PROP3I,PROP4R,PROP4I,PROP34R,PT3452
16542       DOUBLE COMPLEX PROP3,PROP4,PROP
16543 C --- CONSTANTS
16544       DOUBLE PRECISION ZERO,ONE,TWO,MONE,FAC
16545       DOUBLE COMPLEX CZERO,CONE
16546       INTEGER LEFT,RIGHT
16547 C --- PARAMETER DEFINITIONS
16548       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,MONE=-ONE, LEFT=1,RIGHT=2)
16549       PARAMETER (CZERO=(0.D0,0.D0),CONE=(1.D0,0.D0))
16550       DATA MGM4,U0,FAC0   /ZERO, 4*CONE        ,   ONE,ZERO, ZERO, ONE /
16551       DATA PERM0  ,PERMU0 / 1,2, 3,4           ,   1,0, 0,4            /
16552       DATA PL     ,PR     / 0,3, 0,1,  4,0, 2,0,   4,0, 2,0,  0,3, 0,1 /
16553       DATA FACL   ,FACR   /MONE, ONE,  ONE,MONE,   ONE,MONE, MONE, ONE /
16554       SAVE MGM4,PERM0,PL,FACL,PR,FACR,PERMU0,FAC0,U0
16555 C --- INITIALIZE
16556       GGQQHT=ZERO
16557       GGQQHU=ZERO
16558       GGQQHNP=ZERO
16559       QQQQH=ZERO
16560 C --- GG ME.
16561       IF(IGG.EQ.0)GOTO 100
16562       TWOSQS = 0.5D0/SQS
16563       DO I = 0, 3
16564        Q3(I) = P3(I)-P1(I)
16565        Q4(I) = P4(I)-P2(I)
16566        R3(I) = P3(I)-P2(I)
16567        R4(I) = P4(I)-P1(I)
16568        K3(I) = P3(I)+P5(I)
16569        K4(I) = P4(I)+P5(I)
16570       END DO
16571       CALL HWUMPO(P3, RM3,     (P3(0)-P3(3))  ,ZERO,P3PROJ, .FALSE.)
16572       CALL HWUMPO(P4,-RM4,     (P4(0)+P4(3))  ,ZERO,P4PROJ, .FALSE.)
16573       CALL HWUMPO(Q3, RM3,-SQS*(P3(0)-P3(3))  ,ZERO,Q3PROJ, .FALSE.)
16574       CALL HWUMPO(Q4,-RM4,-SQS*(P4(0)+P4(3))  ,ZERO,Q4PROJ, .FALSE.)
16575       CALL HWUMPO(R3, RM3,-SQS*(P3(0)+P3(3))  ,ZERO,R3PROJ, .FALSE.)
16576       CALL HWUMPO(R4,-RM4,-SQS*(P4(0)-P4(3))  ,ZERO,R4PROJ, .FALSE.)
16577       CALL HWUMPO(K3, RM4,SQS*(SQS-2.D0*P4(0)),MGM4,K3PROJ, .TRUE.)
16578       CALL HWUMPO(K4,-RM3,SQS*(SQS-2.D0*P3(0)),MGM3,K4PROJ, .TRUE.)
16579       DO I=1,2
16580        CALL  HWUMPP(P3PROJ,FAC0(1,I),PERMU0 ,U0     ,F3(1,I)   , LEFT)
16581        CALL  HWUMPP(K3PROJ,FACGPM   ,PERM0  ,F3(1,I),F3K(1,I)  , LEFT)
16582        CALL  HWUMPP(P4PROJ,FAC0(1,I),PERMU0 ,U0     ,F4(1,I)   , RIGHT)
16583        CALL  HWUMPP(K4PROJ,FACGPM   ,PERM0  ,F4(1,I),F4K(1,I)  , RIGHT)
16584        DO J=1,2
16585         CALL HWUMPP(Q3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3Q(1,I,J), LEFT)
16586         CALL HWUMPP(R3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3R(1,I,J), LEFT)
16587         CALL HWUMPP(R4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4R(1,I,J), RIGHT)
16588         CALL HWUMPP(Q4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4Q(1,I,J), RIGHT)
16589        END DO
16590       END DO
16591       DO I=1,2
16592        DO J=1,2
16593         AMPS1(I,J)=( - F3K(1,I)* F4(3,J) + F3K(2,I)* F4(4,J)
16594      &               + F3K(3,I)* F4(1,J) - F3K(4,I)* F4(2,J) ) * TWOSQS
16595         AMPS2(I,J)=( -  F3(1,I)*F4K(3,J) +  F3(2,I)*F4K(4,J)
16596      &               +  F3(3,I)*F4K(1,J) -  F3(4,I)*F4K(2,J) ) * TWOSQS
16597         DO K=1,2
16598          AMPT1(1,K,I,J)= F3K(1,I)*F4Q(4,J,K)-F3K(3,I)*F4Q(2,J,K)
16599          AMPT1(2,K,I,J)=-F3K(2,I)*F4Q(3,J,K)+F3K(4,I)*F4Q(1,J,K)
16600          AMPT3(K,1,I,J)= F3Q(1,I,K)*F4K(4,J)-F3Q(3,I,K)*F4K(2,J)
16601          AMPT3(K,2,I,J)=-F3Q(2,I,K)*F4K(3,J)+F3Q(4,I,K)*F4K(1,J)
16602          AMPU1(K,1,I,J)= F3K(1,I)*F4R(4,J,K)-F3K(3,I)*F4R(2,J,K)
16603          AMPU1(K,2,I,J)=-F3K(2,I)*F4R(3,J,K)+F3K(4,I)*F4R(1,J,K)
16604          AMPU3(1,K,I,J)= F3R(1,I,K)*F4K(4,J)-F3R(3,I,K)*F4K(2,J)
16605          AMPU3(2,K,I,J)=-F3R(2,I,K)*F4K(3,J)+F3R(4,I,K)*F4K(1,J)
16606          DO L=1,2
16607           AMPT2(K,L,I,J)
16608      &    = FACGPM(1)*( F3Q(1,I,K)*F4Q(1,J,L)+F3Q(2,I,K)*F4Q(2,J,L) )
16609      &    + FACGPM(2)*( F3Q(3,I,K)*F4Q(3,J,L)+F3Q(4,I,K)*F4Q(4,J,L) )
16610           AMPU2(L,K,I,J)
16611      &    = FACGPM(1)*( F3R(1,I,K)*F4R(1,J,L)+F3R(2,I,K)*F4R(2,J,L) )
16612      &    + FACGPM(2)*( F3R(3,I,K)*F4R(3,J,L)+F3R(4,I,K)*F4R(4,J,L) )
16613          END DO
16614         END DO
16615        END DO
16616       END DO
16617       AMPST2 = ZERO
16618       AMPSU2 = ZERO
16619       AMPTU2 = ZERO
16620       DO I = 1, 2
16621        DO J = 1, 2
16622         DO K = 1, 2
16623          DO L = 1, 2
16624           IF (I.NE.J) THEN
16625            AMPS  = AMPS1(K,L) - AMPS2(K,L)
16626           ELSE
16627            AMPS  = CZERO
16628           END IF
16629           AMPT   = AMPT1(I,J,K,L)+AMPT2(I,J,K,L)+AMPT3(I,J,K,L)
16630           AMPU   = AMPU1(I,J,K,L)+AMPU2(I,J,K,L)+AMPU3(I,J,K,L)
16631           AMPST  = AMPS - AMPT
16632           AMPSU  = AMPS + AMPU
16633           AMPTU  = AMPT + AMPU
16634           AMPST2 = AMPST2 + DREAL(DCONJG(AMPST)*AMPST)
16635           AMPSU2 = AMPSU2 + DREAL(DCONJG(AMPSU)*AMPSU)
16636           AMPTU2 = AMPTU2 + DREAL(DCONJG(AMPTU)*AMPTU)
16637          END DO
16638         END DO
16639        END DO
16640       END DO
16641       FAC  = (P3(0)-P3(3))*(P4(0)+P4(3))
16642       GGQQHT  = FAC*AMPST2
16643       GGQQHU  = FAC*AMPSU2
16644       GGQQHNP = FAC*AMPTU2
16645  100  CONTINUE
16646 C --- QQ ME.
16647       IF(IQQ.EQ.0)GOTO 200
16648       S       = SQS**2
16649       PT32    = P3(1)**2+P3(2)**2
16650       PT42    = P4(1)**2+P4(2)**2
16651       PT52    = P5(1)**2+P5(2)**2
16652       PT3452  = (PT32+PT42-PT52)/TWO
16653       RM3452  = (RM3**2+RM4**2-RM5**2)/TWO
16654       GLAMBDA = FACGPM(1)**2+FACGPM(2)**2
16655       LAMBDA  = TWO*FACGPM(1)*FACGPM(2)/GLAMBDA
16656       LAMBDAI = (FACGPM(2)**2-FACGPM(1)**2)/GLAMBDA
16657       LA34    = S/TWO-SQS*P5(0)-RM3452-LAMBDA*RM3*RM4
16658       PROP3   = ONE/DCMPLX(SQS*(SQS-TWO*P4(0)),ZERO)
16659       PROP4   = ONE/DCMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
16660       PROP    = PROP3+PROP4
16661       PROP2   = DREAL(DCONJG(PROP)*PROP)
16662       PROP3R  = DREAL(DCONJG(PROP)*PROP3)
16663       PROP3I  = DIMAG(DCONJG(PROP)*PROP3)
16664       PROP4R  = DREAL(DCONJG(PROP)*PROP4)
16665       PROP4I  = DIMAG(DCONJG(PROP)*PROP4)
16666       PROP34R = DREAL(DCONJG(PROP3)*PROP4)
16667       QQQQH   = TWO*GLAMBDA/S*(S*PROP2*(PT3452+TWO*P3(0)*P4(0)-
16668      & LA34)+TWO*LA34*(PROP3R*PT42+PROP4R*PT32-PROP34R*PT52)-TWO*SQS*((
16669      & PROP3R*(P3(0)*PT42+P4(0)*PT3452)+PROP4R*(P4(0)*PT32+P3(0)*PT3452)
16670      & )-(PROP3I*P4(3)-PROP4I*P3(3))*LAMBDAI*(P3(1)*P4(2)-P3(2)*P4(1))))
16671  200  CONTINUE
16672       RETURN
16673       END
16674 CDECK  ID>, HWH2SH.
16675 *CMZ :-        -30/06/01  18.25.35  by  Stefano Moretti
16676 *-- Author :  Kosuke Odagiri & Stefano Moretti
16677 C-----------------------------------------------------------------------
16678       SUBROUTINE HWH2SH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,MGM3,MGM4,
16679      & IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
16680 C-----------------------------------------------------------------------
16681 C     MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> SQ SQ* HIGGS
16682 C-----------------------------------------------------------------------
16683 C     NEEDS PREFACTOR G_S^4 AND G_(HIGGS-SQ-SQ)^2
16684 C     MGM3, MGM4 = MASS * WIDTH
16685 C     INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
16686 C     PREFACTORS:
16687 C     GGSQHTOT =
16688 C     (G_S**4)*(G_HIGGS**2)*(GGSQHT+GGSQHU-GGSQHN/CAFAC**2)/(8.*CFFAC)
16689 C     QQSQHTOT =
16690 C     (G_S**4)*(G_HIGGS**2)*(QQSQH                        )*(1.-1./CAFAC**2)/4.
16691 C     N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
16692 C
16693 C...First release:  08-OCT-1999 by Kosuke Odagiri
16694 C...First modified: 12-NOV-1999 by Stefano Moretti
16695 C-----------------------------------------------------------------------
16696       IMPLICIT NONE
16697 C --- SUBPROCESS
16698       INTEGER IGG,IQQ
16699 C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS
16700       DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
16701       DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4
16702 C --- POLARISATION INDICES, PROPAGATORS AND GG AMPLITUDES
16703       INTEGER I,J
16704       DOUBLE PRECISION G14,G24,G23,G13,MSQS, GGSQHT,GGSQHU,GGSQHN
16705       DOUBLE COMPLEX G35,G45, AMPT,AMPU,AMPS,AMPC, AMPST,AMPSU,AMPTU
16706 C --- QQ AMPLITUDES
16707       DOUBLE PRECISION QQSQH
16708       DOUBLE PRECISION PT32,PT42,PT34
16709       DOUBLE COMPLEX PROP3,PROP4
16710 C --- CONSTANT PARAMETERS
16711       DOUBLE PRECISION ZERO,ONE,TWO,SQTWO,MSQTWO
16712       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0)
16713       SQTWO=SQRT(TWO)
16714       MSQTWO=-SQTWO/4.D0
16715       GGSQHT = ZERO
16716       GGSQHU = ZERO
16717       GGSQHN = ZERO
16718       QQSQH  = ZERO
16719       IF(IGG.EQ.0)GOTO 100
16720 C -- GG SCATTERING.
16721       MSQS = -SQTWO/SQS
16722       G13  = MSQS/(P3(0)-P3(3))
16723       G23  = MSQS/(P3(0)+P3(3))
16724       G14  = MSQS/(P4(0)-P4(3))
16725       G24  = MSQS/(P4(0)+P4(3))
16726       G35  = SQTWO/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
16727       G45  = SQTWO/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
16728       AMPS = 0.5D0*MSQS*(P4(3)*G35-P3(3)*G45)
16729       AMPC = MSQTWO*(G35+G45)
16730       DO 10 I = 1,2
16731        DO 20 J = 1,2
16732         AMPT=P3(I)*P4(J)*G24*G13-P4(I)*P4(J)*G24*G35-P3(I)*P3(J)*G13*G45
16733         AMPU=P4(I)*P3(J)*G14*G23-P4(I)*P4(J)*G14*G35-P3(I)*P3(J)*G23*G45
16734         IF (I.EQ.J) THEN
16735          AMPST = AMPT-AMPS+AMPC
16736          AMPSU = AMPU+AMPS+AMPC
16737         ELSE
16738          AMPST = AMPT
16739          AMPSU = AMPU
16740         END IF
16741         AMPTU  = AMPST+AMPSU
16742         GGSQHT = GGSQHT + DREAL(DCONJG(AMPST)*AMPST)
16743         GGSQHU = GGSQHU + DREAL(DCONJG(AMPSU)*AMPSU)
16744         GGSQHN = GGSQHN + DREAL(DCONJG(AMPTU)*AMPTU)
16745  20    CONTINUE
16746  10   CONTINUE
16747  100  CONTINUE
16748       IF(IQQ.EQ.0)GOTO 200
16749 C -- QQ SCATTERING.
16750       PT32  = P3(1)**2+P3(2)**2
16751       PT42  = P4(1)**2+P4(2)**2
16752       PT34  = P3(1)*P4(1)+P3(2)*P4(2)
16753       PROP3 = ONE/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
16754       PROP4 = ONE/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
16755       QQSQH = TWO/SQS**2*DREAL(PT32*DCONJG(PROP3)*PROP3+
16756      &            PT42*DCONJG(PROP4)*PROP4-TWO*PT34*DCONJG(PROP3)*PROP4)
16757  200  CONTINUE
16758       RETURN
16759       END
16760 CDECK  ID>, HWH2SS
16761 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
16762 C-----------------------------------------------------------------------
16763       SUBROUTINE HWH2SS(S,K,KK)
16764 C-----------------------------------------------------------------------
16765 C     Subroutine to calculate the spinor products in the notation of
16766 C     Kleiss and Strirling S(1) is S and S(2) is T
16767 C-----------------------------------------------------------------------
16768       INCLUDE 'HERWIG65.INC'
16769       DOUBLE PRECISION WRN(2),K(5),KK(5),P(5,2),Q1,Q2,EPS,QTI,PTI,
16770      &     PT,QT,DPM,DMP,QP,QM,P1,P2,PP,PM
16771       DOUBLE COMPLEX S(2),ZI,Z1,ZT,ZQ,ZQS,ZPS,ZP,ZDPM,ZDMP
16772       INTEGER I,II,JJ
16773       EPS=0.0000001
16774       ZI=DCMPLX(ZERO,ONE)
16775       Z1=DCMPLX(ONE,ZERO)
16776 C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
16777       DO I=1,4
16778         P(I,2) = K(I)
16779         P(I,1) = KK(I)
16780       ENDDO
16781       DO 2 II=1,2
16782       WRN(II)=ONE
16783       IF(P(4,II).LT.ZERO) WRN(II)=-ONE
16784       DO 2 JJ=1,4
16785       P(JJ,II)=WRN(II)*P(JJ,II)
16786     2 CONTINUE
16787 C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
16788 C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
16789       Q1=P(4,1)+P(1,1)
16790       QP=ZERO
16791       IF(Q1.GT.EPS) QP=SQRT(Q1)
16792       Q2=P(4,1)-P(1,1)
16793       QM=0.0
16794       IF(Q2.GT.EPS)QM=SQRT(Q2)
16795       P1=P(4,2)+P(1,2)
16796       PP=ZERO
16797       IF(P1.GT.EPS)PP=SQRT(P1)
16798       P2=P(4,2)-P(1,2)
16799       PM=ZERO
16800       IF(P2.GT.EPS)PM=SQRT(P2)
16801       DMP=PM*QP
16802       ZDMP=DCMPLX(DMP,ZERO)
16803       DPM=PP*QM
16804       ZDPM=DCMPLX(DPM,ZERO)
16805 C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
16806       PT=SQRT(P(2,2)**2+P(3,2)**2)
16807       QT=SQRT(P(2,1)**2+P(3,1)**2)
16808       IF(PT.GT.EPS) GOTO 99
16809       ZP=Z1
16810       GOTO 98
16811    99 PTI=ONE/PT
16812       ZP=DCMPLX(PTI*P(2,2),PTI*P(3,2))
16813    98 ZPS=DCONJG(ZP)
16814       IF(QT.GT.EPS) GOTO 89
16815       ZQ=Z1
16816       GOTO 88
16817    89 QTI=ONE/QT
16818       ZQ=DCMPLX(QTI*P(2,1),QTI*P(3,1))
16819    88 ZQS=DCONJG(ZQ)
16820       ZT=Z1
16821       IF(WRN(1).LT.ZERO) ZT=ZT*ZI
16822       IF(WRN(2).LT.ZERO) ZT=ZT*ZI
16823       S(2)=-(ZDMP*ZP-ZDPM*ZQ)*ZT
16824       S(1)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
16825       END
16826 CDECK  ID>, HWH2T1.
16827 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
16828 *-- Author :    Peter Richardson
16829 C-----------------------------------------------------------------------
16830       FUNCTION HWH2T1(I,J,K,L,Z1,Z2,P1)
16831 C-----------------------------------------------------------------------
16832 C     Returns the amplitude T1 from Nucl. Phys. B262 (1985) 235-262
16833 C     I-L are the particles
16834 C     Z1 and Z2 are the decay products of the Z
16835 C     P1 is the polarization of the line I,J
16836 C-----------------------------------------------------------------------
16837       INCLUDE 'HERWIG65.INC'
16838       DOUBLE COMPLEX HWH2T1,S,D
16839       INTEGER I,J,K,L,Z1,Z2,P1
16840       COMMON/HWHEWS/S(8,8,2),D(8,8)
16841       IF(P1.EQ.1) THEN
16842         HWH2T1 = TWO*S(I,Z2,1)*S(Z1,J,2)
16843       ELSEIF(P1.EQ.2) THEN
16844         HWH2T1 = TWO*S(I,Z1,2)*S(Z2,J,1)
16845       ELSE
16846         CALL HWWARN('HWH2T1',500,*999)
16847       ENDIF
16848  999  END
16849 CDECK  ID>, HWH2T2
16850 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
16851 *-- Author :    Peter Richardson
16852 C-----------------------------------------------------------------------
16853       FUNCTION HWH2T2(I,J,K,L,Z1,Z2,P1,P2)
16854 C-----------------------------------------------------------------------
16855 C     Returns the amplitude T2 from Nucl. Phys. B262 (1985) 235-262
16856 C     I-L are the particles
16857 C     Z1 and Z2 are the decay products of the Z
16858 C     P1 is the polarization of the line I,J
16859 C     P2 is the polarization of the gluon K
16860 C-----------------------------------------------------------------------
16861       INCLUDE 'HERWIG65.INC'
16862       DOUBLE COMPLEX HWH2T2,S,D
16863       INTEGER I,J,K,L,Z1,Z2,P1,P2
16864       DOUBLE PRECISION B(6)
16865       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16866       COMMON/HWHEWS/S(8,8,2),D(8,8)
16867       IF(P1.EQ.1.AND.P2.EQ.1) THEN
16868         HWH2T2 = FOUR*B(J)*S(I,Z2,1)*S(Z1,J,2)*S(J,K,1)*S(I,J,2)
16869       ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
16870         HWH2T2 = FOUR*S(I,Z2,1)*S(K,J,2)*(B(J)*S(Z1,J,2)*S(J,I,1)
16871      &                                +B(K)*S(Z1,K,2)*S(K,I,1))
16872       ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
16873         HWH2T2 = FOUR*S(I,Z1,2)*S(K,J,1)*(B(J)*S(Z2,J,1)*S(J,I,2)
16874      &                                +B(K)*S(Z2,K,1)*S(K,I,2))
16875       ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
16876         HWH2T2 = FOUR*B(J)*S(I,Z1,2)*S(Z2,J,1)*S(J,K,2)*S(I,J,1)
16877       ELSE
16878         CALL HWWARN('HWH2T2',500,*999)
16879       ENDIF
16880  999  END
16881 CDECK  ID>, HWH2T3.
16882 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
16883 *-- Author :    Peter Richardson
16884 C-----------------------------------------------------------------------
16885       FUNCTION HWH2T3(I,J,K,L,Z1,Z2,P1,P2)
16886 C-----------------------------------------------------------------------
16887 C     Returns the amplitude T3 from Nucl. Phys. B262 (1985) 235-262
16888 C     I-L are the particles
16889 C     Z1 and Z2 are the decay products of the Z
16890 C     P1 is the polarization of the line I,J
16891 C     P2 is the polarization of the gluon K
16892 C-----------------------------------------------------------------------
16893       INCLUDE 'HERWIG65.INC'
16894       DOUBLE COMPLEX HWH2T3,S,D
16895       INTEGER I,J,K,L,Z1,Z2,P1,P2
16896       DOUBLE PRECISION B(6)
16897       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16898       COMMON/HWHEWS/S(8,8,2),D(8,8)
16899       IF(P1.EQ.1.AND.P2.EQ.1) THEN
16900         HWH2T3 = FOUR*B(K)*S(I,K,1)*S(I,K,2)*S(K,Z2,1)*S(Z1,J,2)
16901       ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
16902         HWH2T3 = ZERO
16903       ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
16904         HWH2T3 = ZERO
16905       ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
16906         HWH2T3 = FOUR*B(K)*S(I,K,2)*S(I,K,1)*S(K,Z1,2)*S(Z2,J,1)
16907       ELSE
16908         CALL HWWARN('HWH2T3',500,*999)
16909       ENDIF
16910  999  END
16911 CDECK  ID>, HWH2T4
16912 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
16913 *-- Author :    Peter Richardson
16914 C-----------------------------------------------------------------------
16915       FUNCTION HWH2T4(I,J,K,L,Z1,Z2,P1,P2)
16916 C-----------------------------------------------------------------------
16917 C     Returns the amplitude T4 from Nucl. Phys. B262 (1985) 235-262
16918 C     I-L are the particles
16919 C     Z1 and Z2 are the decay products of the Z
16920 C     P1 is the polarization of the line I,J
16921 C     P2 is the polarization of the line K,L
16922 C-----------------------------------------------------------------------
16923       INCLUDE 'HERWIG65.INC'
16924       DOUBLE COMPLEX HWH2T4,AP,AM,S,D
16925       INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
16926       DOUBLE PRECISION B(6)
16927       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16928       COMMON/HWHEWS/S(8,8,2),D(8,8)
16929       AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
16930      &     (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
16931       AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
16932      &     (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
16933       IF(P1.EQ.1.AND.P2.EQ.1) THEN
16934         HWH2T4 = AP(I,J,K,L)
16935       ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
16936         HWH2T4 = AP(I,J,L,K)
16937       ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
16938         HWH2T4 = AM(I,J,L,K)
16939       ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
16940         HWH2T4 = AM(I,J,K,L)
16941       ELSE
16942         CALL HWWARN('HWH2T4',500,*999)
16943       ENDIF
16944  999  END
16945 CDECK  ID>, HWH2T5
16946 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
16947 *-- Author :    Peter Richardson
16948 C-----------------------------------------------------------------------
16949       FUNCTION HWH2T5(I,J,K,L,Z1,Z2,P1,P2)
16950 C-----------------------------------------------------------------------
16951 C     Returns the amplitude T5 from Nucl. Phys. B262 (1985) 235-262
16952 C     I-L are the particles
16953 C     Z1 and Z2 are the decay products of the Z
16954 C     P1 is the polarization of the line I,J
16955 C     P2 is the polarization of the line K,L
16956 C-----------------------------------------------------------------------
16957       INCLUDE 'HERWIG65.INC'
16958       DOUBLE COMPLEX HWH2T5,AP,AM,S,D
16959       INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
16960       DOUBLE PRECISION B(6)
16961       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16962       COMMON/HWHEWS/S(8,8,2),D(8,8)
16963       AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
16964      &     (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
16965       AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
16966      &     (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
16967       IF(P1.EQ.1.AND.P2.EQ.1) THEN
16968         HWH2T5 = AM(J,I,L,K)
16969       ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
16970         HWH2T5 = AM(J,I,K,L)
16971       ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
16972         HWH2T5 = AP(J,I,K,L)
16973       ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
16974         HWH2T5 = AP(J,I,L,K)
16975       ELSE
16976         CALL HWWARN('HWH2T5',500,*999)
16977       ENDIF
16978  999  END
16979 CDECK  ID>, HWH2T6
16980 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
16981 *-- Author :    Peter Richardson
16982 C-----------------------------------------------------------------------
16983       FUNCTION HWH2T6(I,J,K,L,Z1,Z2,P1,P2,P3)
16984 C-----------------------------------------------------------------------
16985 C     Returns the amplitude T6 from Nucl. Phys. B262 (1985) 235-262
16986 C     I-L are the particles
16987 C     Z1 and Z2 are the decay products of the Z
16988 C     P1 is the polarization of the line I,J
16989 C     P2 is the polarization of the gluon K
16990 C     P3 is the polarization of the gluon L
16991 C-----------------------------------------------------------------------
16992       INCLUDE 'HERWIG65.INC'
16993       DOUBLE COMPLEX HWH2T6,S,D
16994       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
16995       DOUBLE PRECISION B(6)
16996       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
16997       COMMON/HWHEWS/S(8,8,2),D(8,8)
16998       IF(P1.EQ.1) THEN
16999          J1 = Z1
17000          J2 = Z2
17001       ELSE
17002          J1 = Z2
17003          J2 = Z1
17004       ENDIF
17005       IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17006      &   (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17007         HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*D(L,J)*S(K,J,2)*
17008      &             (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17009       ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17010      &       (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17011         HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(L,J,2)*S(J,K,1)*S(L,J,2)*
17012      &            (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17013       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17014      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17015         HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(K,J,2)*S(J,L,1)*S(K,J,2)*
17016      &            (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
17017       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17018      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17019         HWH2T6 = 8.0D0*S(I,J2,1)*S(L,J,2)*(B(J)*D(K,J)+B(L)*D(K,L))*
17020      &             (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
17021       ELSE
17022         CALL HWWARN('HWH2T6',500,*999)
17023       ENDIF
17024       IF(P1.EQ.2) HWH2T6 = DCONJG(HWH2T6)
17025  999  END
17026 CDECK  ID>, HWH2T7
17027 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17028 *-- Author :    Peter Richardson
17029 C-----------------------------------------------------------------------
17030       FUNCTION HWH2T7(I,J,K,L,Z1,Z2,P1,P2,P3)
17031 C-----------------------------------------------------------------------
17032 C     Returns the amplitude T7 from Nucl. Phys. B262 (1985) 235-262
17033 C     I-L are the particles
17034 C     Z1 and Z2 are the decay products of the Z
17035 C     P1 is the polarization of the line I,J
17036 C     P2 is the polarization of the gluon K
17037 C     P3 is the polarization of the gluon L
17038 C-----------------------------------------------------------------------
17039       INCLUDE 'HERWIG65.INC'
17040       DOUBLE COMPLEX HWH2T7,S,D
17041       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17042       DOUBLE PRECISION B(6)
17043       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17044       COMMON/HWHEWS/S(8,8,2),D(8,8)
17045       IF(P1.EQ.1) THEN
17046         J1 = Z1
17047         J2 = Z2
17048       ELSE
17049         J1 = Z2
17050         J2 = Z1
17051       ENDIF
17052       IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17053      &   (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17054         HWH2T7 = 8.0D0*B(J)*S(I,K,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)*
17055      &                 (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17056       ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17057      &       (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17058         HWH2T7 = 8.0D0*S(I,K,1)*S(L,J,2)*
17059      &                (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))*
17060      &                (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17061       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17062      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17063         HWH2T7 = 8.0D0*B(I)*B(J)*S(I,L,1)*S(K,I,2)*
17064      &        S(I,J2,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)
17065       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17066      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17067         HWH2T7 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,J2,1)*S(L,J,2)*
17068      &                 (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17069       ELSE
17070         CALL HWWARN('HWH2T7',500,*999)
17071       ENDIF
17072       IF(P1.EQ.2) HWH2T7 = DCONJG(HWH2T7)
17073  999  END
17074 CDECK  ID>, HWH2T8
17075 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17076 *-- Author :    Peter Richardson
17077 C-----------------------------------------------------------------------
17078       FUNCTION HWH2T8(I,J,K,L,Z1,Z2,P1,P2,P3)
17079 C-----------------------------------------------------------------------
17080 C     Returns the amplitude T8 from Nucl. Phys. B262 (1985) 235-262
17081 C     I-L are the particles
17082 C     Z1 and Z2 are the decay products of the Z
17083 C     P1 is the polarization of the line I,J
17084 C     P2 is the polarization of the gluon K
17085 C     P3 is the polarization of the gluon L
17086 C-----------------------------------------------------------------------
17087       INCLUDE 'HERWIG65.INC'
17088       DOUBLE COMPLEX HWH2T8,S,D
17089       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17090       DOUBLE PRECISION B(6)
17091       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17092       COMMON/HWHEWS/S(8,8,2),D(8,8)
17093       IF(P1.EQ.1) THEN
17094         J1 = Z1
17095         J2 = Z2
17096       ELSE
17097         J1 = Z2
17098         J2 = Z1
17099       ENDIF
17100       IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17101      &   (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17102         HWH2T8 = 8.0D0*S(I,K,1)*S(J1,J,2)*(B(I)*D(L,I)+B(K)*D(L,K))*
17103      &                (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
17104       ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17105      &       (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17106         HWH2T8 = 8.0D0*B(I)*S(I,K,1)*S(L,I,2)*S(I,K,1)*S(J1,J,2)*
17107      &                 (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17108       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17109      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17110         HWH2T8 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,L,1)*S(J1,J,2)*
17111      &                 (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
17112       ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17113      &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17114         HWH2T8 = 8.0D0*B(I)*S(I,L,1)*D(I,K)*S(J1,J,2)*
17115      &                 (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17116       ELSE
17117         CALL HWWARN('HWH2T8',500,*999)
17118       ENDIF
17119       IF(P1.EQ.2) HWH2T8 = DCONJG(HWH2T8)
17120  999  END
17121 CDECK  ID>, HWH2T9
17122 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17123 *-- Author :    Peter Richardson
17124 C-----------------------------------------------------------------------
17125       FUNCTION HWH2T9(I,J,K,L,Z1,Z2,P1,P2,P3)
17126 C-----------------------------------------------------------------------
17127 C     Returns the amplitude T9 from Nucl. Phys. B262 (1985) 235-262
17128 C     N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
17129 C     I-L are the particles
17130 C     Z1 and Z2 are the decay products of the Z
17131 C     P1 is the polarization of the line I,J
17132 C     P2 is the polarization of the gluon K
17133 C     P3 is the polarization of the gluon L
17134 C-----------------------------------------------------------------------
17135       INCLUDE 'HERWIG65.INC'
17136       DOUBLE COMPLEX HWH2T9,S,D
17137       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17138       DOUBLE PRECISION B(6)
17139       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17140       COMMON/HWHEWS/S(8,8,2),D(8,8)
17141       IF(P2.NE.P3) THEN
17142          HWH2T9 = ZERO
17143       ELSE
17144         IF(P1.EQ.1) THEN
17145           J1 = Z1
17146           J2 = Z2
17147         ELSEIF(P1.EQ.2) THEN
17148           J1 = Z2
17149           J2 = Z1
17150         ENDIF
17151         HWH2T9 = TWO*S(I,J2,1)*(
17152      &           B(K)*S(K,J,2)*(B(J)*S(J1,J,2)*S(J,K,1)
17153      &                           +B(L)*S(J1,L,2)*S(L,K,1))
17154      &          -B(L)*S(L,J,2)*(B(J)*S(J1,J,2)*S(J,L,1)
17155      &                           +B(K)*S(J1,K,2)*S(K,L,1)))
17156         IF(P1.EQ.2) HWH2T9 = DCONJG(HWH2T9)
17157       ENDIF
17158  999  END
17159 CDECK  ID>, HWH2T0
17160 *CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
17161 *-- Author :    Peter Richardson
17162 C-----------------------------------------------------------------------
17163       FUNCTION HWH2T0(I,J,K,L,Z1,Z2,P1,P2,P3)
17164 C-----------------------------------------------------------------------
17165 C     Returns the amplitude T10 from Nucl. Phys. B262 (1985) 235-262
17166 C     N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
17167 C     I-L are the particles
17168 C     Z1 and Z2 are the decay products of the Z
17169 C     P1 is the polarization of the line I,J
17170 C     P2 is the polarization of the gluon K
17171 C     P3 is the polarization of the gluon L
17172 C-----------------------------------------------------------------------
17173       INCLUDE 'HERWIG65.INC'
17174       DOUBLE COMPLEX HWH2T0,S,D
17175       INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17176       DOUBLE PRECISION B(6)
17177       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17178       COMMON/HWHEWS/S(8,8,2),D(8,8)
17179       IF(P2.NE.P3) THEN
17180          HWH2T0 = ZERO
17181       ELSE
17182         IF(P1.EQ.1) THEN
17183           J1 = Z1
17184           J2 = Z2
17185         ELSEIF(P1.EQ.2) THEN
17186           J1 = Z2
17187           J2 = Z1
17188         ENDIF
17189         HWH2T0 = TWO*S(J1,J,2)*(
17190      &            B(K)*S(I,K,1)*(B(I)*S(K,I,2)*S(I,J2,1)
17191      &                           +B(L)*S(K,L,2)*S(L,J2,1))
17192      &           -B(L)*S(I,L,1)*(B(I)*S(L,I,2)*S(I,J2,1)
17193      &                           +B(K)*S(L,K,2)*S(K,J2,1)))
17194         IF(P1.EQ.2) HWH2T0 = DCONJG(HWH2T0)
17195       ENDIF
17196  999  END
17197 CDECK  ID>, HWH2VH.
17198 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
17199 *-- Author :  Stefano Moretti
17200 C-----------------------------------------------------------------------
17201       SUBROUTINE HWH2VH(P1,P2,P3,P4,RMV,RES,RESL,REST)
17202 C-----------------------------------------------------------------------
17203 C...Matrix element for q(1) + q(')-bar(2) -> V(3) + Higgs(4),
17204 C...V=Z(W+/-), all masses retained (but no Yukawa couplings to quarks).
17205 C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
17206 C...times:
17207 C...         (VQ*VQ+AQ*AQ)/(1.-SWEIN)/(1.-SWEIN)    if V=Z
17208 C...         VCKM(q,q')                             if V=W+/-
17209 C
17210 C...First release:  1-APR-1998 by Stefano Moretti
17211 C-----------------------------------------------------------------------
17212       IMPLICIT NONE
17213       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
17214       DOUBLE PRECISION P(0:3)
17215       DOUBLE PRECISION RMV,GAMV,RES,RESL,REST
17216       INTEGER I
17217       DOUBLE PRECISION S,S12,S13,S23
17218       DOUBLE PRECISION T,    T13,T23
17219       DOUBLE PRECISION PV,CFC
17220       PARAMETER (GAMV=0.D0)
17221       S=(P1(0)+P2(0))**2
17222       DO I=1,3
17223         S=S-(P1(I)+P2(I))**2
17224       END DO
17225       S12=P1(0)*P2(0)
17226       S13=P1(0)*P3(0)
17227       S23=P2(0)*P3(0)
17228       DO I=1,3
17229         S12=S12-P1(I)*P2(I)
17230         S13=S13-P1(I)*P3(I)
17231         S23=S23-P2(I)*P3(I)
17232       END DO
17233 C...Total ME.
17234       RES=(S12+2.D0/RMV/RMV*(S13*S23))
17235      &   /((S-RMV**2)**2+GAMV**2*RMV**2)
17236      &   /12.D0
17237 C...Extracts spin dependence.
17238       PV=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
17239       CFC=P3(0)/PV
17240       DO I=1,3
17241         P(I)=P3(I)*CFC
17242       END DO
17243       P(0)=PV**2/P3(0)*CFC
17244       T=P(0)**2
17245       DO I=1,3
17246         T=T-P(I)**2
17247       END DO
17248       T13=P1(0)*P(0)
17249       T23=P2(0)*P(0)
17250       DO I=1,3
17251         T13=T13-P1(I)*P(I)
17252         T23=T23-P2(I)*P(I)
17253       END DO
17254 C...Longitudinal ME (along V direction).
17255       RESL=(2.D0/RMV/RMV*(T13*T23)-S12*T/RMV/RMV)
17256      &    /((S-RMV**2)**2+GAMV**2*RMV**2)
17257      &    /12.D0
17258 C...Transverse ME (perpendicular to V direction).
17259       REST=RES-RESL
17260       RETURN
17261       END
17262 CDECK  ID>, HWH4JT.
17263 *CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
17264 *-- Author :    Ian Knowles
17265 C-----------------------------------------------------------------------
17266       SUBROUTINE HWH4JT
17267 C-----------------------------------------------------------------------
17268 C     Four jet production in e^+e^- annihilation: qqbar+gg & qqbar+qqbar
17269 C     IOP4JT controls the treatment of the colour flow interference term
17270 C     qqbar-gg case:
17271 C     IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
17272 C     qqbar-qqbar (identical quark flavour) case:
17273 C     IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
17274 C
17275 C     Matrix elements based on Ellis Ross & Terrano and Catani & Seymour
17276 C
17277 C     WARNING:  Phase space factor inaccurate for JADE y_cut > 0.14.
17278 C-----------------------------------------------------------------------
17279       INCLUDE 'HERWIG65.INC'
17280       INTEGER LM,LP,IQK,I,J,IDMN,IDMX,ID1,ID2,IST(4)
17281       DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,
17282      & HWH4J4,HWH4J5,HWH4J6,HWH4J7,QNOW,Q2NOW,QLST,SCUT,PSFAC,FACT,
17283      & X12,X13,X14,X23,X24,X34,
17284      & COLA,COLB,COLC,CLF(7,6),P12,P13,P14,P23,P24,P34,FACTR,EP1,EP2,
17285      & EP3,EP4,GG1,GG2,GG12,GG3,GG13,GG23,GGINT,WTGG,QQ,QP,QQINT,QQ1,
17286      & QQ2,WTQQ,WTQP,HCS,WTAB,WTBA,WTOT,RCS,YLST
17287      $     ,EF,QF,E(4)
17288       LOGICAL INCLQG(6),INCLQQ(6,6),ORIENT
17289       EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,HWH4J4,
17290      & HWH4J5,HWH4J6,HWH4J7
17291       SAVE HCS,QLST,WTQP,WTQQ,WTGG,FACTR,COLA,COLB,COLC,IDMN,IDMX,
17292      & CLF,GG1,GG2,GGINT,INCLQG,INCLQQ,LM,LP,QQ1,QQ2,QQINT,FACT,ORIENT,
17293      & Q2NOW,SCUT,YLST
17294       DATA QLST,YLST,IST/-1D0,-1D0,113,114,114,114/
17295 C
17296       IF (GENEV) THEN
17297         RCS=HCS*HWRGEN(0)
17298       ELSE
17299         IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWH4JT',100,*999)
17300         QNOW=PHEP(5,3)
17301         IF (QNOW.NE.QLST.OR.Y4JT.NE.YLST) THEN
17302           QLST=QNOW
17303           YLST=Y4JT
17304           Q2NOW=QNOW**2
17305           SCUT=Y4JT*Q2NOW
17306 C Calculate allowed fraction of Phase Space using parameterization
17307           IF (DURHAM) THEN
17308             PSFAC=(1.-6.*Y4JT)**5.50*(1.-173.3*Y4JT*(1.-247.3*Y4JT
17309      &                              *(1.+148.3*Y4JT*(1.+3.913*Y4JT))))
17310      &                              /(1.-8.352*Y4JT*(1.-1102.*Y4JT
17311      &                              *(1.+1603.*Y4JT*(1.+22.99*Y4JT))))
17312           ELSE
17313             PSFAC=(1.-6.*Y4JT)**4.62*(1.-44.72*Y4JT*(1.-176.0*Y4JT
17314      &                              *(1.+102.9*Y4JT*(1.-6.579*Y4JT))))
17315      &                              /(1.-3.392*Y4JT*(1.-946.5*Y4JT
17316      &                              *(1.+423.4*Y4JT*(1.-3.971*Y4JT))))
17317           ENDIF
17318           FACT=GEV2NB*HWUAEM(Q2NOW)**2*CFFAC*FLOAT(NCOLO)*PSFAC
17319      &        /(THREE*16*PIFAC)
17320           COLA=CFFAC
17321           COLB=CFFAC-HALF*CAFAC
17322           COLC=HALF
17323           LM=1
17324           IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
17325           LP=2
17326           IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
17327           IQK=MOD(IPROC,10)
17328           IF (IQK.NE.0) THEN
17329             IDMN=IQK
17330             IDMX=IQK
17331           ELSE
17332             IDMN=1
17333             IDMX=6
17334           ENDIF
17335           DO 10 I=1,6
17336           CALL HWUCFF(11,I,Q2NOW,CLF(1,I))
17337           IF (QNOW.GT.TWO*(RMASS(I)+RMASS(13))) THEN
17338             INCLQG(I)=.TRUE.
17339           ELSE
17340             INCLQG(I)=.FALSE.
17341           ENDIF
17342           DO 10 J=I,6
17343           IF (QNOW.GT.TWO*(RMASS(I)+RMASS(J ))) THEN
17344             INCLQQ(I,J)=.TRUE.
17345             INCLQQ(J,I)=.TRUE.
17346           ELSE
17347             INCLQQ(I,J)=.FALSE.
17348             INCLQQ(J,I)=.FALSE.
17349           ENDIF
17350   10      CONTINUE
17351           IF (MOD(IPROC/10,10).EQ.5) THEN
17352             ORIENT=.FALSE.
17353           ELSE
17354             ORIENT=.TRUE.
17355           ENDIF
17356         ENDIF
17357 C Generate phase space point and check it passes cuts
17358         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
17359         DO 20 I=2,5
17360   20    PHEP(5,NHEP+I)=0.
17361   30    CALL HWDFOR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3),
17362      &              PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17363         IF (DURHAM) THEN
17364           P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
17365           X12=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+3),
17366      &          PHEP(4,NHEP+3)/PHEP(4,NHEP+2))*P12
17367           IF (X12.GT.SCUT) THEN
17368             P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
17369             X13=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+4),
17370      &            PHEP(4,NHEP+4)/PHEP(4,NHEP+2))*P13
17371             IF (X13.GT.SCUT) THEN
17372               P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
17373               X14=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+5),
17374      &              PHEP(4,NHEP+5)/PHEP(4,NHEP+2))*P14
17375               IF (X14.GT.SCUT) THEN
17376                 P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
17377                 X23=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+4),
17378      &                PHEP(4,NHEP+4)/PHEP(4,NHEP+3))*P23
17379                 IF (X23.GT.SCUT) THEN
17380                   P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
17381                   X24=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+5),
17382      &                  PHEP(4,NHEP+5)/PHEP(4,NHEP+3))*P24
17383                   IF (X24.GT.SCUT) THEN
17384                     P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17385                     X34=MIN(PHEP(4,NHEP+4)/PHEP(4,NHEP+5),
17386      &                    PHEP(4,NHEP+5)/PHEP(4,NHEP+4))*P34
17387                     IF (X34.GT.SCUT) GOTO 40
17388                   ENDIF
17389                 ENDIF
17390               ENDIF
17391             ENDIF
17392           ENDIF
17393         ELSE
17394           P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
17395           IF (P12.GT.SCUT) THEN
17396             P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
17397             IF (P13.GT.SCUT) THEN
17398               P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
17399               IF (P14.GT.SCUT) THEN
17400                 P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
17401                 IF (P23.GT.SCUT) THEN
17402                   P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
17403                   IF (P24.GT.SCUT) THEN
17404                     P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17405                     IF (P34.GT.SCUT) GOTO 40
17406                   ENDIF
17407                 ENDIF
17408               ENDIF
17409             ENDIF
17410           ENDIF
17411         ENDIF
17412 C Failed cuts retry
17413         GOTO 30
17414 C Passed cuts: calculate contributions to Matrix Elements
17415   40    EMSCA=SQRT(MIN(P12,P13,P14,P23,P24,P34))
17416         IF (DURHAM) EMSCA=SQRT(MIN(X12,X13,X14,X23,X24,X34))
17417         IF (FIX4JT) EMSCA=SQRT(SCUT)
17418         FACTR=FACT*HWUALF(1,EMSCA)**2
17419         IF (ORIENT) THEN
17420           QF=HWULDO(PHEP(1,LP),PHEP(1,3))
17421           EF=Q2NOW/(2*SQRT(QF**2-HWULDO(PHEP(1,LP),PHEP(1,LP))*Q2NOW))
17422           QF=HALF-EF*QF/Q2NOW
17423           DO I=1,4
17424             E(I)=EF*PHEP(I,LP)+QF*PHEP(I,3)
17425           ENDDO
17426           EP1=HWULDO(E,PHEP(1,NHEP+2))
17427           EP2=HWULDO(E,PHEP(1,NHEP+3))
17428           EP3=HWULDO(E,PHEP(1,NHEP+4))
17429           EP4=HWULDO(E,PHEP(1,NHEP+5))
17430         ENDIF
17431 C q-qbar-g-g
17432         GG1=HWH4J1(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17433      &     +HWH4J1(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17434         GG2=HWH4J1(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17435      &     +HWH4J1(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17436         GG12=HWH4J2(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17437      &      +HWH4J2(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17438      &      +HWH4J2(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17439      &      +HWH4J2(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17440         GG3=HWH4J4(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17441      &     +HWH4J4(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17442         GG13=GG3+HWH4J5(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17443      &          +HWH4J5(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17444         GG23=GG3+HWH4J5(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17445      &          +HWH4J5(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17446 C Add up weights
17447         GG1  =COLA*(GG1 +GG13)
17448         GG2  =COLA*(GG2 +GG23)
17449         GGINT=COLB*(GG12-GG13-GG23)
17450         WTGG=FACTR*(GG1+GG2+GGINT)
17451 C q-qbar-q-qbar
17452         QP=HWH4J6(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
17453      &    +HWH4J6(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
17454      &    +HWH4J6(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
17455      &    +HWH4J6(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
17456         QQ=HWH4J6(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
17457      &    +HWH4J6(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
17458      &    +HWH4J6(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
17459      &    +HWH4J6(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
17460         QQINT=HWH4J7(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
17461      &       +HWH4J7(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
17462      &       +HWH4J7(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
17463      &       +HWH4J7(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
17464      &       +HWH4J7(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
17465      &       +HWH4J7(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
17466      &       +HWH4J7(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
17467      &       +HWH4J7(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
17468 C Add up weights
17469         WTQP=FACTR*COLC*QP/TWO
17470         QQ1  =COLC*QP
17471         QQ2  =COLC*QQ
17472         QQINT=COLB*QQINT
17473         WTQQ=FACTR*(QQ1+QQ2+QQINT)/2
17474       ENDIF
17475 C
17476       HCS=0.
17477       DO 60 ID1=IDMN,IDMX
17478       IF (INCLQG(ID1)) THEN
17479 C Gluon channel
17480         HCS=HCS+CLF(1,ID1)*WTGG
17481         IF (GENEV.AND.HCS.GT.RCS) THEN
17482 C Select colour flow
17483           WTAB=GG1
17484           WTBA=GG2
17485           IF (IOP4JT(1).EQ.1) THEN
17486             IF (GGINT.GE.ZERO) THEN
17487               WTAB=WTAB+GGINT
17488             ELSE
17489               WTBA=MAX(WTBA,WTBA+GGINT)
17490             ENDIF
17491           ELSEIF (IOP4JT(1).EQ.2) THEN
17492             IF (GGINT.GE.ZERO) THEN
17493               WTBA=WTBA+GGINT
17494             ELSE
17495               WTAB=MAX(WTAB,WTAB+GGINT)
17496             ENDIF
17497           ELSEIF (IOP4JT(1).NE.0) THEN
17498             CALL HWWARN('HWH4JT',101,*999)
17499           ENDIF
17500           WTOT=WTAB+WTBA
17501           IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
17502             CALL HWHQCP( 13, 13,3142,91,*99)
17503           ELSE
17504             CALL HWHQCP( 13, 13,4123,92,*99)
17505           ENDIF
17506         ENDIF
17507       ENDIF
17508 C Quark channels
17509       DO 50 ID2=1,6
17510 C Identical quark pairs
17511       IF (ID1.EQ.ID2.AND.INCLQQ(ID1,ID1)) THEN
17512         HCS=HCS+CLF(1,ID1)*WTQQ
17513         IF (GENEV.AND.HCS.GT.RCS) THEN
17514 C Select colour flow
17515           WTAB=QQ1
17516           WTBA=QQ2
17517           IF (IOP4JT(2).EQ.1) THEN
17518             IF (QQINT.GE.ZERO) THEN
17519               WTAB=WTAB+QQINT
17520             ELSE
17521               WTBA=MAX(WTBA,WTBA+QQINT)
17522             ENDIF
17523           ELSEIF (IOP4JT(2).EQ.2) THEN
17524             IF (QQINT.GE.ZERO) THEN
17525               WTBA=WTBA+QQINT
17526             ELSE
17527               WTAB=MAX(WTAB,WTAB+QQINT)
17528             ENDIF
17529           ELSEIF (IOP4JT(2).NE.0) THEN
17530             CALL HWWARN('HWH4JT',102,*999)
17531           ENDIF
17532           WTOT=WTAB+WTBA
17533           IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
17534             CALL HWHQCP(ID1,ID1+6,4123,93,*99)
17535           ELSE
17536             CALL HWHQCP(ID1,ID1+6,2143,94,*99)
17537           ENDIF
17538         ENDIF
17539 C Unlike quark pairs
17540       ELSEIF (INCLQQ(ID1,ID2)) THEN
17541         HCS=HCS+(CLF(1,ID1)+CLF(1,ID2))*WTQP
17542         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,ID2+6,4123,95,*99)
17543       ENDIF
17544   50  CONTINUE
17545   60  CONTINUE
17546       EVWGT=HCS
17547       RETURN
17548 C Set up labels for selected final state
17549   99  IDN(1)=ID1
17550       IDN(2)=ID1+6
17551       J=NHEP+1
17552       IDHW(J)=200
17553       IDHEP(J)=23
17554       ISTHEP(J)=110
17555       JMOHEP(1,J)=LM
17556       JMOHEP(2,J)=LP
17557       JDAHEP(1,J)=NHEP+2
17558       JDAHEP(2,J)=NHEP+5
17559       DO 100 I=1,4
17560       J=NHEP+1+I
17561       IDHW(J)=IDN(I)
17562       IDHEP(J)=IDPDG(IDN(I))
17563       ISTHEP(J)=IST(I)
17564       JMOHEP(1,J)=NHEP+1
17565   100 JDAHEP(1,J)=0
17566 C And colour structure pointers
17567       DO 110 I=1,4
17568       J=ICO(I)
17569       JMOHEP(2,NHEP+1+I)=NHEP+1+J
17570   110 JDAHEP(2,NHEP+1+J)=NHEP+1+I
17571       NHEP=NHEP+5
17572   999 END
17573 CDECK  ID>, HWH4J1.
17574 *CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
17575 *-- Author :    Ian Knowles
17576 C-----------------------------------------------------------------------
17577       FUNCTION HWH4J1(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17578 C-----------------------------------------------------------------------
17579 C     Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
17580 C-----------------------------------------------------------------------
17581       IMPLICIT NONE
17582       DOUBLE PRECISION HWH4J1,HWH4J2,HWH4J4,HWH4J5,HWH4J6,HWH4J7,
17583      & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4,
17584      & SUM
17585       LOGICAL ORIENT
17586       S123=S12+S13+S23
17587       S124=S12+S14+S24
17588       S134=S13+S14+S34
17589       S234=S23+S24+S34
17590       S=S12+S13+S14+S23+S24+S34
17591       HWH4J1=(S12*((S12+S14+S23+S34)**2+S13*(S12+S14-S24)+S24*(S12+S23))
17592      &       +(S14*S23-S12*S34-S13*S24)*(S14+S23+S34)/2)
17593      &       /(S13*S24*S134*S234)
17594      &      +((S12+S24)*(S13+S34)-S14*S23)/(S13*S134**2)
17595      &      +2*S23*(S-S13)/(S13*S134*S24) + S34/(2*S13*S24)
17596       IF (ORIENT) THEN
17597         HWH4J1=HWH4J1
17598      &  +4*((EP1*EP1*((S-S13)*(S23+S24)-S24*S34)
17599      &      -EP1*EP2*(S12*(S123+S124)+(S+S12)*(S14+S23)+2*S14*S23
17600      &               +S24*S134+S234*(S13+2*S234))
17601      &      +EP1*EP3*(S*(S24-S12)+S12*S13+(S14+2*S234-S34)*S24)
17602      &      -EP1*EP4*(S12*S124+S23*(S+S12+S14))
17603      &      +EP2*EP2*((S-S24)*(S13+S14)+2*(S13+S34)*S234-S13*S34)
17604      &      -EP2*EP3*((S+S23)*(S12+S14)+(S12+2*(S23+S234))*S234)
17605      &      +EP2*EP4*(S12*(S24-S)+S13*(S+S23-S34)+2*(S13+S34-S234)*S234)
17606      &      +EP3*EP3*(S14+2*S234)*S24
17607      &      +EP3*EP4*(-S234*(2*(S12+S23)+S134)+S12*S34-S13*S24-S14*S23)
17608      &      +EP4*EP4*S13*S23)*S134
17609      &      +EP2*(EP1+EP3+EP4)*2*S14*S24*S234)/(S*S13*S24*S134**2*S234)
17610       ELSE
17611         HWH4J1=2*HWH4J1/3
17612       ENDIF
17613       RETURN
17614 C-----------------------------------------------------------------------
17615       ENTRY HWH4J2(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17616 C-----------------------------------------------------------------------
17617       S123=S12+S13+S23
17618       S124=S12+S14+S24
17619       S134=S13+S14+S34
17620       S234=S23+S24+S34
17621       S=S12+S13+S14+S23+S24+S34
17622       HWH4J2=(S12*S14*(S24+S34)+S24*(S12*(S14+S34)+S13*(S14-S24)))
17623      &       /(S14*S23*S13*S134)
17624      &      +S12*(S+S34)*S124/(S24*S234*S14*S134)
17625      &      -(S13*(2*(S12+S24)+S23)+S14**2)/(S134*S13*S14)
17626      &      +S12*S123*S124/(2*S13*S24*S14*S23)
17627       IF (ORIENT) THEN
17628         HWH4J2=HWH4J2
17629      &  +4*((EP1*EP1*(S12*S134*S234-4*S23*S24*S34)
17630      &      +EP1*EP2*(2*(2*S13*S234+S14*S123)*S24-S12*S134*(S+S12+S34))
17631      &      +EP1*EP3*(S12*(4*S24*S34-S134*(S12+S14-S24))
17632      &               -4*(S13*S24-S14*S23)*S24)
17633      &      +EP1*EP4*(4*(S13+S14)*S23*S24-S12*S134*(S12+S13-S23))
17634      &      +EP2*EP2*(S12*S134-4*S13*S24)*S134
17635      &      +EP2*EP3*(4*S13*(S12+S23+S24)*S24-S12*S134*(S12-S14+S24))
17636      &      -EP2*EP4*(4*(S12*(S14+S134)+S13*(S134-S234))*S24
17637      &               +S12*(S12-S13+S23)*S134)
17638      &      -EP3*EP3*4*S12*S14*S24
17639      &      -EP3*EP4*2*S12*(2*S14*S24+S12*S134))*S234
17640      &      +(EP1*(EP1*(S23+S24)+EP2*(S134-2*S))
17641      &       -(EP1+EP2)*(EP3+EP4)*S12+EP2*EP2*(S13+S14))*2*S14*S24*S123)
17642      &    /(2*S*S13*S14*S234*S23*S24*S134)
17643       ELSE
17644         HWH4J2=2*HWH4J2/3
17645       ENDIF
17646       RETURN
17647 C-----------------------------------------------------------------------
17648       ENTRY HWH4J4(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17649 C-----------------------------------------------------------------------
17650       S134=S13+S14+S34
17651       S234=S23+S24+S34
17652       S=S12+S13+S14+S23+S24+S34
17653       HWH4J4=-(S12*(S34*(3*(S+S34)+S12)-S134*S234-2*(S13*S24+S14*S23))
17654      &        +(S14*S23-S13*S24)*(S13-S14+S24-S23))/(2*S134*S234*S34**2)
17655      &      -(S12*(S134**2/2+2*S13*S14+S34*(S13+S14-S34))
17656      &       +S34*((S13+S14)*(S23+S24)+S14*S24+S13*S23)
17657      &       +(S13*S24-S14*S23)*(S14-S13))/(S34*S134)**2
17658       IF (ORIENT) THEN
17659         HWH4J4=HWH4J4
17660      &  +4*((-EP1*EP1*2*(S23+S24)*S34
17661      &       -EP1*EP2*(S13*(S23+3*S24)+S14*(3*S23+S24)-(4*S12-S34)*S34)
17662      &       +EP1*EP3*((2*S12-S24)*S34-(S13-S14)*S24)
17663      &       +EP1*EP4*((2*S12-S23)*S34+(S13-S14)*S23)
17664      &       -EP2*EP2*2*(S13+S14)*S34
17665      &       +EP2*EP3*(2*S12*S34-S14*(S23-S24+S34))
17666      &       +EP2*EP4*(2*S12*S34+S13*(S23-S24-S34))
17667      &       +EP3*EP3*2*S14*S24
17668      &       +EP3*EP4*2*(S12*S34-S13*S24-S14*S23)
17669      &       +EP4*EP4*2*S13*S23)/(S*S134*S234*S34**2)
17670      &      +(EP1*EP2*(S134*(S134+2*S34)+4*(S13*S14-S34**2))
17671      &       +EP2*EP3*2*(2*S13*S34+S14*(S13-S14+S34))
17672      &       +EP2*EP4*2*(2*S14*S34-S13*(S13-S14-S34)))
17673      &  /(S*(S134*S34)**2))
17674       ELSE
17675         HWH4J4=2*HWH4J4/3
17676       ENDIF
17677       RETURN
17678 C-----------------------------------------------------------------------
17679       ENTRY HWH4J5(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17680 C-----------------------------------------------------------------------
17681       S123=S12+S13+S23
17682       S124=S12+S14+S24
17683       S134=S13+S14+S34
17684       S234=S23+S24+S34
17685       S=S12+S13+S14+S23+S24+S34
17686       HWH4J5=(3*S12*S34**2-3*S13*S24*S34+3*S12*S24*S34+3*S14*S23*S34-
17687      $     S13*S24**2-S12*S23*S34+6*S12*S14*S34+2*S12*S13*S34-
17688      $     2*S12**2*S34+S14*S23*S24-3*S13*S23*S24-2*S13*S14*S24+
17689      $     4*S12*S14*S24+2*S12*S13*S24+3*S14*S23**2+2*S14**2*S23+
17690      $     2*S14**2*S12+2*S12**2*S14+6*S12*S14*S23-2*S12*S13**2-
17691      $     2*S12**2*S13)/(2*S13*S134*S234*S34)+
17692      $     (2*S12*S34**2-2*S13*S24*S34+S12*S24*S34+4*S13*S23*S34+
17693      $     4*S12*S14*S34+2*S12*S13*S34+2*S12**2*S34-S13*S24**2+
17694      $     3*S14*S23*S24+4*S13*S23*S24-2*S13*S14*S24+4*S12*S14*S24+
17695      $     2*S12*S13*S24+2*S14*S23**2+4*S13*S23**2+2*S13*S14*S23+
17696      $     2*S12*S14*S23+4*S12*S13*S23+2*S12*S14**2+4*S12**2*S13+
17697      $     4*S12*S13*S14+2*S12**2*S14)/(2*S13*S134*S24*S34)-
17698      $     (S12*S34**2-2*S14*S24*S34-2*S13*S24*S34-S14*S23*S34+
17699      $     S13*S23*S34+S12*S14*S34+2*S12*S13*S34-2*S14**2*S24-
17700      $     4*S13*S14*S24-4*S13**2*S24-S14**2*S23-S13**2*S23+
17701      $     S12*S13*S14-S12*S13**2)/(S13*S34*S134**2)
17702       IF (ORIENT) THEN
17703         SUM=
17704      &    +EP1*EP1*((S13-S14+S23-3*S24)*S34+(S134+S14+2*S34)*S234)
17705      &            *S24*S134
17706      &    +EP1*EP2*((2*(S12-S24)+S34)*S134-S14*(4*S12+S14+3*S23)
17707      &             +S13*(S13+S23)+S24*S34 )*S24*S134
17708      &    -EP1*EP2*(((2*S12*S134+S13*(2*(S12+S14+S23)-S24+S34)
17709      &              +S14*(S14-S23)+(2*S14-S34)*S234)*S234)*S134
17710      &             + 4*S13**2*S24*S234)
17711      &    +EP1*EP3*(S12*(2*S13-S134)+S13*(S24+2*S234)+S14*(3*S24-S234)
17712      &             +S34*(S234-3*S24))*S24*S134
17713      &    +EP1*EP4*((S12*(S13-S14+3*S34)-S23*(S13+3*S14-S34))*S24
17714      &             -(S12*(S13+S134+2*S34)+2*S13*S24
17715      &              +(S13-2*S14)*S23)*S234)*S134
17716      &    +EP2*EP2*(S13*((2*S13+S34)*S234+S24*(S134-2*S34))
17717      &             +2*S14*S134*(S24+S234))*S134
17718         SUM=SUM
17719      &    -EP2*EP3*(((S12*(S13+2*S14-S34)+S14*(S+2*S23-S34))*S24
17720      &              +(S12*(S13+S134)+(S13+S24+2*S234)*S14
17721      &               +2*S13*(2*S23+S34))*S234)*S134
17722      &             +4*S13**2*S24*S234)
17723      &    +EP2*EP4*(((S12*(S13-2*S134)+S13*(S+2*S23-3*S34))*S24
17724      &              -((S-3*S13+S23+2*S24)*S13+2*S12*S14
17725      &                +2*S14*(S23+2*S24))*S234)*S134-4*S13**2*S24*S234)
17726      &    +EP3*EP3*2*(S13*S234+S14*S24)*S24*S134
17727      &    +EP3*EP4*(2*(S12*S34-S13*S24-S14*S23)*S24
17728      &             -(S12*S134+2*S13*S23)*S234)*S134
17729      &    +EP4*EP4*2*(S12*S234+S23*S24)*S13*S134
17730         HWH4J5=HWH4J5+4*SUM/(S*S234*S134**2*S13*S34*S24)
17731       ELSE
17732         HWH4J5=2*HWH4J5/3
17733       ENDIF
17734       RETURN
17735 C-----------------------------------------------------------------------
17736       ENTRY HWH4J6(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17737 C-----------------------------------------------------------------------
17738       S123=S12+S13+S23
17739       S124=S12+S14+S24
17740       S134=S13+S14+S34
17741       S234=S23+S24+S34
17742       S=S12+S13+S14+S23+S24+S34
17743       HWH4J6=(S23*(S123*S234-S*S23)+S12*(S123*S124-S*S12))/(S13*S123)**2
17744      &     -(S12*S34*(S234-2*S23)+S14*S23*(S234-2*S34)
17745      &      -S13*S24*(S234+S13))/(S13**2*S123*S134)
17746       IF (ORIENT) THEN
17747         HWH4J6=HWH4J6
17748      &  +4*(-EP1*EP1*2*S23*S34
17749      &      +EP1*EP2*((S12-S23)*S34-S13*(S24-S34))
17750      &      +(EP1*EP3+EP2*EP4)*2*(S12*S34-S13*S24+S14*S23)
17751      &      -EP1*EP4*(S13*S24-(3*(S13+S14)+S34)*S23)
17752      &      -(EP1+EP2+EP3)*EP4*2
17753      &       *(S12*(S13+S23)+(S12+S13)*S23)*S134/S123
17754      &      +EP2*EP2*S13*(S14+S34)
17755      &      +EP2*EP3*(S13*(S14-S24)-(S12-S23)*S14)
17756      &      -EP3*EP3*2*S12*S14
17757      &      -EP3*EP4*(S13*S24-(3*(S13+S34)+S14)*S12)
17758      &      +EP4*EP4*(S12+S23)*S13)/(S*S134*S123*S13**2)
17759       ELSE
17760         HWH4J6=2*HWH4J6/3
17761       ENDIF
17762       RETURN
17763 C-----------------------------------------------------------------------
17764       ENTRY HWH4J7(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17765 C-----------------------------------------------------------------------
17766       S123=S12+S13+S23
17767       S124=S12+S14+S24
17768       S134=S13+S14+S34
17769       S234=S23+S24+S34
17770       S=S12+S13+S14+S23+S24+S34
17771       HWH4J7=((S12*S34+S13*S24-S14*S23)*(S13+S14+S23+S24)-2*S12*S24*S34)
17772      &      /(S13*S134*S23*S123)
17773      &      -S12*(S12*S-S123*S124)/(S123**2*S13*S23)
17774      &      -(S13+S14)*(S23+S24)*S34/(S13*S134*S23*S234)
17775       IF (ORIENT) THEN
17776         HWH4J7=HWH4J7
17777      &  +4*(+2*(EP1+EP2)*(S23*EP1-S13*EP2)*S34*S134
17778      &      -EP1*EP2*2*S34**2*S123
17779      &      +EP1*EP3*(S123*(S23+S24)*S34+2*S134*(S13*S24-S14*S23))
17780      &      +EP1*EP4*(S123*(S23+S24)*S34+2*S12**2*S134*S234/S123
17781      &               +2*S134*(S24*(S13-S12)-S23*(S12+S14)))
17782      &      +EP2*EP3*(2*(S12*S34+S13*S24-S14*S23)*S134
17783      &               +S123*(S13+S14)*S34)
17784      &      +EP2*EP4*(S123*(S13+S14)*S34+2*S12**2*S234*S134/S123
17785      &               -2*S134*(S12*S234-S13*S24+S14*S23))
17786      &      -EP3*EP3*S12*(2*S24*S134+S123*S34)
17787      &      +EP3*EP4*2*S12*(S134*(S23-S24)-S34*S123+S12*S134*S234/S123)
17788      &      +EP4*EP4*S12*(2*S23*S134-S123*S34))
17789      &     /(S*S13*S23*S123*S134*S234)
17790       ELSE
17791         HWH4J7=2*HWH4J7/3
17792       ENDIF
17793       RETURN
17794       END
17795 CDECK  ID>, HWHBGF.
17796 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
17797 *-- Author :    Giovanni Abbiendi & Luca Stanco
17798 C-----------------------------------------------------------------------
17799       SUBROUTINE HWHBGF
17800 C-----------------------------------------------------------------------
17801 C     Order Alpha_s processes in charged lepton-hadron collisions
17802 C
17803 C       Process code IPROC has to be set in the Main Program
17804 C       the following codes IPROC may be selected
17805 C
17806 C                9100 : NC  BOSON-GLUON FUSION
17807 C                9100+IQK (IQK=1,...,6) :  produced flavour is IQK
17808 C                9107 : produced  J/psi + gluon
17809 C
17810 C                9110 : NC  QCD COMPTON
17811 C                9110+IQK (IQK=1,...,12) : struck parton is IQK
17812 C
17813 C                9130 : NC order alpha_s processes (9100+9110)
17814 C
17815 C       Select maximum and minimum generated flavour when IQK=0
17816 C       setting IFLMIN and IFLMAX in the Main Program
17817 C       (allowed values from 1 to 6), default are 1 and 5
17818 C       allowing d,u,s,c,b,dbar,ubar,sbar,cbar,bbar
17819 C
17820 C           CHARGED CURRENT Boson-Gluon Fusion processes
17821 C                9141 : CC  s cbar  (c sbar)
17822 C                9142 : CC  b cbar  (c bbar)
17823 C                9143 : CC  s tbar  (t cbar)
17824 C                9144 : CC  b tbar  (t bbar)
17825 C
17826 C       other inputs : Q2MIN,Q2MAX,YBMIN,YBMAX,PTMIN,EMMIN,EMMAX
17827 C       when IPROC=(1)9107 : as above but Q2WWMN, Q2WWMX substitute
17828 C                            Q2MIN and Q2MAX (EPA is used); ZJMAX cut
17829 C
17830 C      Add 10000 to suppress soft remnant fragmentation
17831 C
17832 C      Mean EVWGT = cross section in nanoBarn
17833 C
17834 C-----------------------------------------------------------------------
17835       INCLUDE 'HERWIG65.INC'
17836       DOUBLE PRECISION HWRGEN,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,
17837      & ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,FSIGMA(18),
17838      & SIGSUM,PROB,PRAN,PVRT(4),X
17839       INTEGER LEP
17840       INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,LEPFIN,ID1,ID2,I,IDD
17841       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
17842       EXTERNAL HWRGEN
17843       SAVE LEPFIN,ID1,ID2,FSIGMA,SIGSUM
17844       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
17845      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
17846      & IPROO,CHARGD,INCLUD,INSIDE
17847 C---Initialization
17848       IF (FSTWGT) THEN
17849 C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
17850         LEP=0
17851         IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
17852           LEP=1
17853         ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
17854           LEP=-1
17855         ENDIF
17856         IF (LEP.EQ.0) CALL HWWARN('HWHBGF',500,*999)
17857         IPROO=MOD(IPROC,100)/10
17858         IF (IPROO.EQ.0.OR.IPROO.EQ.4) THEN
17859           IQK=MOD(IPROC,10)
17860           IFL=IQK
17861           IF (IQK.EQ.7) IFL=164
17862           CHARGD=IPROO.EQ.4
17863         ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
17864           IQK=MOD(IPROC,100)-10
17865           IFL=IQK+6
17866           CHARGD=.FALSE.
17867         ELSEIF (IPROO.EQ.3) THEN
17868           IQK=0
17869           IFL=0
17870           CHARGD=.FALSE.
17871         ELSE
17872           CALL HWWARN('HWHBGF',501,*999)
17873         ENDIF
17874 C
17875         LEPFIN = IDHW(1)
17876         IF(CHARGD) THEN
17877           LEPFIN = IDHW(1)+1
17878           IF (IQK.EQ.1) THEN
17879             IFLAVU=4
17880             IFLAVD=3
17881             ID1  = 3
17882             ID2  = 10
17883           ELSEIF (IQK.EQ.2) THEN
17884             IFLAVU=4
17885             IFLAVD=5
17886             ID1  = 5
17887             ID2  = 10
17888           ELSEIF (IQK.EQ.3) THEN
17889             IFLAVU=6
17890             IFLAVD=3
17891             ID1  = 3
17892             ID2  =12
17893           ELSE
17894             IFLAVU=6
17895             IFLAVD=5
17896             ID1  = 5
17897             ID2  =12
17898           ENDIF
17899           IF (LEP.EQ.-1) THEN
17900             IDD=ID1
17901             ID1=ID2-6
17902             ID2=IDD+6
17903           ENDIF
17904         ENDIF
17905 C
17906         IF (IQK.EQ.0) THEN
17907           DO I=1,18
17908             INCLUD(I)=.TRUE.
17909           ENDDO
17910           IMIN=1
17911           IMAX=18
17912           DO I=1,6
17913             IF (I.LT.IFLMIN.OR.I.GT.IFLMAX) INCLUD(I)=.FALSE.
17914           ENDDO
17915           DO I=7,18
17916             IF (I.LE.12) THEN
17917               IF (I-6.LT.IFLMIN.OR.I-6.GT.IFLMAX) INCLUD(I)=.FALSE.
17918             ELSE
17919               IF (I-12.LT.IFLMIN.OR.I-12.GT.IFLMAX) INCLUD(I)=.FALSE.
17920             ENDIF
17921           ENDDO
17922           IF (IPROO.EQ.0) THEN
17923             DO I=7,18
17924               INCLUD(I)=.FALSE.
17925             ENDDO
17926             IMIN=IFLMIN
17927             IMAX=IFLMAX
17928           ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
17929             DO I=1,6
17930               INCLUD(I)=.FALSE.
17931             ENDDO
17932             IMIN=IFLMIN+6
17933             IMAX=IFLMAX+12
17934           ELSEIF (IPROO.EQ.3) THEN
17935             IMIN=IFLMIN
17936             IMAX=IFLMAX+12
17937           ENDIF
17938         ELSEIF (IQK.NE.0 .AND. (.NOT.CHARGD)) THEN
17939           DO I=1,18
17940             INCLUD(I)=.FALSE.
17941           ENDDO
17942           IF (IFL.LE.18) THEN
17943             INCLUD(IFL)=.TRUE.
17944             IMIN=IFL
17945             IMAX=IFL
17946           ELSEIF (IFL.EQ.164) THEN
17947             INCLUD(7)=.TRUE.
17948             IMIN=7
17949             IMAX=7
17950           ENDIF
17951         ENDIF
17952       ENDIF
17953 C---End of initialization
17954       IF(GENEV) THEN
17955       IF (.NOT.CHARGD) THEN
17956         IF (IQK.EQ.0) THEN
17957           PRAN= SIGSUM * HWRGEN(0)
17958           PROB=ZERO
17959           DO 10 IFL=IMIN,IMAX
17960             IF (.NOT.INSIDE(IFL)) GOTO 10
17961             PROB=PROB+FSIGMA(IFL)
17962             IF (PROB.GE.PRAN) GOTO 20
17963   10      CONTINUE
17964         ENDIF
17965 C---at this point the subprocess has been selected (IFL)
17966   20    CONTINUE
17967         IF (IFL.LE.6) THEN
17968 C---Boson-Gluon Fusion event
17969           IDHW(NHEP+1)=IDHW(1)
17970           IDHW(NHEP+2)=13
17971           IDHW(NHEP+3)=15
17972           IDHW(NHEP+4)=LEPFIN
17973           IDHW(NHEP+5)=IFL
17974           IDHW(NHEP+6)=IFL+6
17975         ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
17976 C---QCD_Compton event
17977           IDHW(NHEP+1)=IDHW(1)
17978           IDHW(NHEP+2)=IFL-6
17979           IDHW(NHEP+3)=15
17980           IDHW(NHEP+4)=LEPFIN
17981           IDHW(NHEP+5)=IFL-6
17982           IDHW(NHEP+6)=13
17983         ELSEIF (IFL.EQ.164) THEN
17984 C---gamma+gluon-->J/Psi+gluon
17985           IDHW(NHEP+1)=IDHW(1)
17986           IDHW(NHEP+2)=13
17987           IDHW(NHEP+3)=15
17988           IDHW(NHEP+4)=LEPFIN
17989           IDHW(NHEP+5)=164
17990           IDHW(NHEP+6)=13
17991         ELSE
17992           CALL HWWARN('HWHBGF',503,*999)
17993         ENDIF
17994       ELSE
17995 C---Charged current event of specified flavours
17996         IDHW(NHEP+1)=IDHW(1)
17997         IDHW(NHEP+2)=13
17998         IDHW(NHEP+3)=15
17999         IDHW(NHEP+4)=LEPFIN
18000         IDHW(NHEP+5)=ID1
18001         IDHW(NHEP+6)=ID2
18002       ENDIF
18003 C
18004       DO 1 I=NHEP+1,NHEP+6
18005     1 IDHEP(I)=IDPDG(IDHW(I))
18006 C
18007 C---Codes common for all processes
18008       ISTHEP(NHEP+1)=111
18009       ISTHEP(NHEP+2)=112
18010       ISTHEP(NHEP+3)=110
18011       ISTHEP(NHEP+4)=113
18012       ISTHEP(NHEP+5)=114
18013       ISTHEP(NHEP+6)=114
18014 C
18015       DO I=NHEP+1,NHEP+6
18016         JMOHEP(1,I)=NHEP+3
18017         JDAHEP(1,I)=0
18018       ENDDO
18019 C---Incoming lepton
18020       JMOHEP(2,NHEP+1)=NHEP+4
18021       JDAHEP(2,NHEP+1)=NHEP+4
18022 C---Hard Process C.M.
18023       JMOHEP(1,NHEP+3)=NHEP+1
18024       JMOHEP(2,NHEP+3)=NHEP+2
18025       JDAHEP(1,NHEP+3)=NHEP+4
18026       JDAHEP(2,NHEP+3)=NHEP+6
18027 C---Outgoing lepton
18028       JMOHEP(2,NHEP+4)=NHEP+1
18029       JDAHEP(2,NHEP+4)=NHEP+1
18030 C
18031       IF (IFL.LE.6 .OR. CHARGD) THEN
18032 C---Codes for boson-gluon fusion processes
18033 C---  Incoming gluon
18034         JMOHEP(2,NHEP+2)=NHEP+6
18035         JDAHEP(2,NHEP+2)=NHEP+5
18036 C---  Outgoing quark
18037         JMOHEP(2,NHEP+5)=NHEP+2
18038         JDAHEP(2,NHEP+5)=NHEP+6
18039 C---  Outgoing antiquark
18040         JMOHEP(2,NHEP+6)=NHEP+5
18041         JDAHEP(2,NHEP+6)=NHEP+2
18042       ELSEIF (IFL.GE.7 .AND. IFL.LE.12) THEN
18043 C---Codes for V+q --> q+g
18044 C---  Incoming quark
18045         JMOHEP(2,NHEP+2)=NHEP+5
18046         JDAHEP(2,NHEP+2)=NHEP+6
18047 C---  Outgoing quark
18048         JMOHEP(2,NHEP+5)=NHEP+6
18049         JDAHEP(2,NHEP+5)=NHEP+2
18050 C---  Outgoing gluon
18051         JMOHEP(2,NHEP+6)=NHEP+2
18052         JDAHEP(2,NHEP+6)=NHEP+5
18053       ELSEIF (IFL.GE.13 .AND. IFL.LE.18) THEN
18054 C---Codes for V+qbar --> qbar+g
18055 C---  Incoming antiquark
18056         JMOHEP(2,NHEP+2)=NHEP+6
18057         JDAHEP(2,NHEP+2)=NHEP+5
18058 C---  Outgoing antiquark
18059         JMOHEP(2,NHEP+5)=NHEP+2
18060         JDAHEP(2,NHEP+5)=NHEP+6
18061 C---  Outgoing gluon
18062         JMOHEP(2,NHEP+6)=NHEP+5
18063         JDAHEP(2,NHEP+6)=NHEP+2
18064       ELSEIF (IFL.EQ.164) THEN
18065 C---Codes for Gamma+gluon --> J/Psi+gluon
18066 C---  Incoming gluon
18067         JMOHEP(2,NHEP+2)=NHEP+6
18068         JDAHEP(2,NHEP+2)=NHEP+6
18069 C---  Outgoing J/Psi
18070         JMOHEP(2,NHEP+5)=NHEP+1
18071         JDAHEP(2,NHEP+5)=NHEP+1
18072 C---  Outgoing gluon
18073         JMOHEP(2,NHEP+6)=NHEP+2
18074         JDAHEP(2,NHEP+6)=NHEP+2
18075       ENDIF
18076 C---Computation of momenta in Laboratory frame of reference
18077       CALL HWHBKI
18078       NHEP=NHEP+6
18079 C Decide which quark radiated and assign production vertices
18080       IF (IFL.LE.6) THEN
18081 C Boson-Gluon fusion case
18082         IF (1-Z.LT.HWRGEN(0)) THEN
18083 C Gluon splitting to quark
18084           CALL HWVZRO(4,VHEP(1,NHEP-1))
18085           CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
18086           CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP))
18087           CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
18088         ELSE
18089 C Gluon splitting to antiquark
18090           CALL HWVZRO(4,VHEP(1,NHEP))
18091           CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
18092           CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP-1))
18093           CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
18094         ENDIF
18095       ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
18096 C QCD Compton case
18097         X=1/(1+SHAT/Q2)
18098         IF (1.LT.HWRGEN(0)*(1+(1-X-Z)**2+6*X*(1-X)*Z*(1-Z))) THEN
18099 C Incoming quark radiated the gluon
18100           CALL HWVZRO(4,VHEP(1,NHEP-1))
18101           CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
18102           CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
18103           CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
18104         ELSE
18105 C Outgoing quark radiated the gluon
18106           CALL HWVZRO(4,VHEP(1,NHEP-4))
18107           CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
18108           CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
18109           CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
18110         ENDIF
18111       ENDIF
18112 C---HERWIG gets confused if lepton momentum is different from beam
18113 C   momentum, which it can be if incoming hadron has negative virtuality
18114 C   As a temporary fix, simply copy the momentum.
18115 C   Momentum conservation somehow gets taken care of HWBGEN!
18116       call hwvequ(5,phep(1,1),phep(1,nhep-5))
18117       ELSE
18118         EVWGT=ZERO
18119 C---generation of the 5 variables Y,Q2,SHAT,Z,PHI and Jacobian computation
18120 C---in the largest phase space avalaible for selected processes and
18121 C---filling of logical vector INSIDE to tag contributing ones
18122         CALL HWHBRN (*999)
18123 C---calculate differential cross section corresponding to the chosen
18124 C---variables and the weight for MC generation
18125         IF (IQK.EQ.0) THEN
18126 C---many subprocesses included
18127           DO I=1,18
18128             FSIGMA(I)=ZERO
18129           ENDDO
18130           SIGSUM=ZERO
18131           DO I=IMIN,IMAX
18132             IF (INSIDE(I)) THEN
18133               IFL=I
18134               DSIGMA=ZERO
18135               CALL HWHBSG
18136               FSIGMA(I)=DSIGMA
18137               SIGSUM=SIGSUM+DSIGMA
18138             ENDIF
18139           ENDDO
18140           EVWGT=SIGSUM * AJACOB
18141         ELSE
18142 C---only one subprocess included
18143           CALL HWHBSG
18144           EVWGT= DSIGMA * AJACOB
18145         ENDIF
18146         IF (EVWGT.LT.ZERO) EVWGT=ZERO
18147       ENDIF
18148   999 END
18149 CDECK  ID>, HWHBKI.
18150 *CMZ :-        -26/04/91  13.19.32  by  Federico Carminati
18151 *-- Author :    Giovanni Abbiendi & Luca Stanco
18152 C----------------------------------------------------------------------
18153       SUBROUTINE HWHBKI
18154 C----------------------------------------------------------------------
18155 C     gives the fourmomenta in the laboratory system for the particles
18156 C     of the hard 2-->3 subprocess, to match with HERWIG routines of
18157 C     jet evolution.
18158 C----------------------------------------------------------------------
18159       INCLUDE 'HERWIG65.INC'
18160       DOUBLE PRECISION HWUECM,HWUPCM,HWUSQR,Y,Q2,SHAT,Z,PHI,AJACOB,
18161      & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18162      & PGAMMA(5),SG,MF1,MF2,EP,PP,EL,PL,E1,E2,Q1,COSBET,SINBET,COSTHE,
18163      & SINTHE,SINAZI,COSAZI,ROTAZI(3,3),EGAM,A,PPROT,MREMIN,PGAM,PEP(5),
18164      & COSPHI,SINPHI,ROT(3,3),EPROT,PROTON(5),MPART
18165       INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,IHAD,J,IS,ICMF,LEP
18166       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18167       EXTERNAL HWUECM,HWUPCM,HWUSQR
18168       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18169      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18170      & IPROO,CHARGD,INCLUD,INSIDE
18171 C
18172       IHAD=2
18173       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18174 C---Set masses
18175       IF (CHARGD) THEN
18176         MPART=ZERO
18177         MF1=RMASS(IDHW(NHEP+5))
18178         MF2=RMASS(IDHW(NHEP+6))
18179         MREMIN=MP
18180       ELSE
18181         IS = IFL
18182         IF (IFL.EQ.164) IS=IQK
18183         MPART=ZERO
18184         IF (IFL.GE.7.AND.IFL.LE.18) MPART=RMASS(IFL-6)
18185         MF1=MFIN1(IS)
18186         MF2=MFIN2(IS)
18187         MREMIN = MREMIF(IS)
18188       ENDIF
18189 C---Calculation of kinematical variables for the generated event
18190 C   in the center of mass frame of the incoming boson and parton
18191 C   with parton along +z
18192       EGAM = HWUECM (SHAT, -Q2, MPART**2)
18193       PGAM = SQRT( EGAM**2 + Q2 )
18194       EP = RSHAT-EGAM
18195       PP = PGAM
18196       A = (W2+Q2-MP**2)/TWO
18197       PPROT = (A*PGAM-EGAM*SQRT(A**2+MP**2*Q2))/Q2
18198       IF (PPROT.LT.ZERO) CALL HWWARN('HWHBKI',101,*999)
18199       EPROT = SQRT(PPROT**2+MP**2)
18200       IF ((EPROT+PPROT).LT.(EP+PP)) CALL HWWARN('HWHBKI',102,*999)
18201       EL = ( PGAM / PPROT * SMA - Q2 ) / TWO
18202      +     / (EGAM + PGAM / PPROT * EPROT)
18203       IF (EL.GT.ME) THEN
18204         PL = SQRT ( EL**2 - ME**2 )
18205       ELSE
18206         CALL HWWARN ('HWHBKI',103,*999)
18207       ENDIF
18208       COSBET = (TWO * EPROT * EL - SMA) / (TWO * PPROT * PL)
18209       IF ( ABS(COSBET) .GE. ONE ) THEN
18210         COSBET = SIGN (ONE,COSBET)
18211         SINBET = ZERO
18212       ELSE
18213         SINBET = SQRT (ONE - COSBET**2)
18214       ENDIF
18215       SG = ME**2 + MPART**2 + Q2 + TWO * RSHAT * EL
18216       IF (SG.LE.(RSHAT+ML)**2 .OR. SG.GE.(RS-MREMIN)**2)
18217      +    CALL HWWARN ('HWHBKI',104,*999)
18218       Q1 = HWUPCM( RSHAT, MF1, MF2)
18219       E1 = SQRT(Q1**2+MF1**2)
18220       E2 = SQRT(Q1**2+MF2**2)
18221       IF (Q1 .GT. ZERO) THEN
18222         COSTHE=(TWO*EP*E1 - Z*(SHAT+Q2))/(TWO*PP*Q1)
18223         IF (ABS(COSTHE) .GT. ONE) THEN
18224           COSTHE=SIGN(ONE,COSTHE)
18225           SINTHE=ZERO
18226         ELSE
18227           SINTHE=SQRT(ONE-COSTHE**2)
18228         ENDIF
18229       ELSE
18230         COSTHE=ZERO
18231         SINTHE=ONE
18232       ENDIF
18233 C---Initial lepton
18234       PHEP(1,NHEP+1)=PL*SINBET
18235       PHEP(2,NHEP+1)=ZERO
18236       PHEP(3,NHEP+1)=PL*COSBET
18237       PHEP(4,NHEP+1)=EL
18238       PHEP(5,NHEP+1)=RMASS(IDHW(1))
18239 C---Initial Hadron
18240       PROTON(1)=ZERO
18241       PROTON(2)=ZERO
18242       PROTON(3)=PPROT
18243       PROTON(4)=EPROT
18244       CALL HWUMAS (PROTON)
18245 C---Initial parton
18246       PHEP(1,NHEP+2)=ZERO
18247       PHEP(2,NHEP+2)=ZERO
18248       PHEP(3,NHEP+2)=PP
18249       PHEP(4,NHEP+2)=EP
18250       PHEP(5,NHEP+2)=MPART
18251 C---HARD SUBPROCESS 2-->3 CENTRE OF MASS
18252       PHEP(1,NHEP+3)=PHEP(1,NHEP+1)+PHEP(1,NHEP+2)
18253       PHEP(2,NHEP+3)=PHEP(2,NHEP+1)+PHEP(2,NHEP+2)
18254       PHEP(3,NHEP+3)=PHEP(3,NHEP+1)+PHEP(3,NHEP+2)
18255       PHEP(4,NHEP+3)=PHEP(4,NHEP+1)+PHEP(4,NHEP+2)
18256       CALL HWUMAS  ( PHEP(1,NHEP+3) )
18257 C---Virtual boson
18258       PGAMMA(1)=ZERO
18259       PGAMMA(2)=ZERO
18260       PGAMMA(3)=-PGAM
18261       PGAMMA(4)=EGAM
18262       PGAMMA(5)=HWUSQR(Q2)
18263 C---Scattered lepton
18264       PHEP(1,NHEP+4)=PHEP(1,NHEP+1)-PGAMMA(1)
18265       PHEP(2,NHEP+4)=PHEP(2,NHEP+1)-PGAMMA(2)
18266       PHEP(3,NHEP+4)=PHEP(3,NHEP+1)-PGAMMA(3)
18267       PHEP(4,NHEP+4)=PHEP(4,NHEP+1)-PGAMMA(4)
18268       PHEP(5,NHEP+4)=RMASS(IDHW(1))
18269       IF (CHARGD) PHEP(5,NHEP+4)=ZERO
18270 C---First Final parton:  quark (or J/psi) in Boson-Gluon Fusion
18271 C---                     quark or antiquark in QCD Compton
18272       PHEP(1,NHEP+5)=Q1*SINTHE*COS(PHI)
18273       PHEP(2,NHEP+5)=Q1*SINTHE*SIN(PHI)
18274       PHEP(3,NHEP+5)=Q1*COSTHE
18275       PHEP(4,NHEP+5)=E1
18276       PHEP(5,NHEP+5)=MF1
18277 C---Second Final parton: antiquark in Boson-Gluon Fusion
18278 C---                     gluon in QCD Compton
18279       PHEP(1,NHEP+6)=-PHEP(1,NHEP+5)
18280       PHEP(2,NHEP+6)=-PHEP(2,NHEP+5)
18281       PHEP(3,NHEP+6)=-PHEP(3,NHEP+5)
18282       PHEP(4,NHEP+6)=E2
18283       PHEP(5,NHEP+6)=MF2
18284 C---Boost to lepton-hadron CM frame
18285       PEP(1) = PHEP(1,NHEP+1)
18286       PEP(2) = PHEP(2,NHEP+1)
18287       PEP(3) = PHEP(3,NHEP+1) + PPROT
18288       PEP(4) = PHEP(4,NHEP+1) + EPROT
18289       CALL HWUMAS (PEP)
18290       DO I=1,6
18291         CALL HWULOF (PEP,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18292       ENDDO
18293       CALL HWULOF (PEP,PROTON,PROTON)
18294       CALL HWULOF (PEP,PGAMMA,PGAMMA)
18295 C---Rotation around y-axis to align lepton beam with z-axis
18296       COSPHI = PHEP(3,NHEP+1) /
18297      &           SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
18298       SINPHI = PHEP(1,NHEP+1) /
18299      &           SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
18300       DO I=1,3
18301       DO J=1,3
18302         ROT(I,J)=ZERO
18303       ENDDO
18304       ENDDO
18305         ROT(1,1) = COSPHI
18306         ROT(1,3) = -SINPHI
18307         ROT(2,2) = ONE
18308         ROT(3,1) = SINPHI
18309         ROT(3,3) = COSPHI
18310       DO I=1,6
18311         CALL HWUROF (ROT,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18312       ENDDO
18313       CALL HWUROF (ROT,PROTON,PROTON)
18314       CALL HWUROF (ROT,PGAMMA,PGAMMA)
18315 C---Boost to the LAB frame
18316       ICMF=3
18317       DO I=1,6
18318         CALL HWULOB (PHEP(1,ICMF),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18319       ENDDO
18320       CALL HWULOB (PHEP(1,ICMF),PROTON,PROTON)
18321       CALL HWULOB (PHEP(1,ICMF),PGAMMA,PGAMMA)
18322 C---Random azimuthal rotation
18323       CALL HWRAZM (ONE,COSAZI,SINAZI)
18324       DO I=1,3
18325       DO J=1,3
18326         ROTAZI(I,J)=ZERO
18327       ENDDO
18328       ENDDO
18329         ROTAZI(1,1) = COSAZI
18330         ROTAZI(1,2) = SINAZI
18331         ROTAZI(2,1) = -SINAZI
18332         ROTAZI(2,2) = COSAZI
18333         ROTAZI(3,3) = ONE
18334       DO I=1,6
18335         CALL HWUROF (ROTAZI,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18336       ENDDO
18337       CALL HWUROF (ROTAZI,PROTON,PROTON)
18338       CALL HWUROF (ROTAZI,PGAMMA,PGAMMA)
18339   999 END
18340 CDECK  ID>, HWHBRN.
18341 *CMZ :-        -03/07/95  19.02.12  by  Giovanni Abbiendi
18342 *-- Author :    Giovanni Abbiendi & Luca Stanco
18343 C-----------------------------------------------------------------------
18344       SUBROUTINE HWHBRN (*)
18345 C----------------------------------------------------------------------
18346 C     Returns a point in the phase space (Y,Q2,SHAT,Z,PHI) and the
18347 C     corresponding Jacobian factor AJACOB
18348 C     Fill the logical vector INSIDE to tag contributing subprocesses
18349 C     to the cross-section
18350 C-----------------------------------------------------------------------
18351       INCLUDE 'HERWIG65.INC'
18352       DOUBLE PRECISION HWRUNI,HWRGEN,HWUPCM,Y,Q2,SHAT,Z,PHI,AJACOB,
18353      & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18354      & MF1,MF2,YMIN,YMAX,YJAC,Q2INF,Q2SUP,Q2JAC,EMW2,ZMIN,ZMAX,ZJAC,
18355      & GAMMA2,LAMBDA,PHIJAC,ZINT,ZLMIN,ZL,EMW,TMIN,TMAX,EMLMIN,EMLMAX,
18356      & SHMIN,EMMIF(18),EMMAF(18),WMIF(18),WMIN,MREMIN,YMIF(18),Q1CM(18),
18357      & Q2MAF(18),EMMAWF(18),ZMIF(18),ZMAF(18),PLMAX,PINC,SHINF,SHSUP,
18358      & SHJAC,CTHLIM,Q1,DETDSH,SRY,SRY0,SRY1
18359       INTEGER LEP
18360       INTEGER IQK,IFLAVU,IFLAVD,I,IMIN,IMAX,IFL,IPROO,IHAD,NTRY,DEBUG
18361       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18362       EXTERNAL HWRUNI,HWRGEN,HWUPCM
18363       SAVE EMLMIN,EMLMAX,EMMIF,EMMAF,MREMIN,MF1,MF2,YMIF,
18364      &     YMIN,YMAX,WMIN,WMIF
18365       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18366      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18367      & IPROO,CHARGD,INCLUD,INSIDE
18368       EQUIVALENCE (EMW,RMASS(198))
18369 C
18370       IHAD=2
18371       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18372 C---Initialization
18373       IF (FSTWGT.OR.IHAD.NE.2) THEN
18374         ME = RMASS(IDHW(1))
18375         MP = RMASS(IDHW(IHAD))
18376         RS = PHEP(5,3)
18377         SMA = RS**2-ME**2-MP**2
18378         PINC = HWUPCM(RS,ME,MP)
18379 C---Charged current
18380         IF (CHARGD) THEN
18381           ML=RMASS(IDHW(1)+1)
18382           YMAX = ONE - TWO*ML*MP / SMA
18383           YMAX = MIN(YMAX,YBMAX)
18384           MREMIN=MP
18385           IF (LEP.EQ.1) THEN
18386             MF1=RMASS(IFLAVD)
18387             MF2=RMASS(IFLAVU)
18388           ELSE
18389             MF1=RMASS(IFLAVU)
18390             MF2=RMASS(IFLAVD)
18391           ENDIF
18392           SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
18393      +            TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
18394           EMLMIN=MAX(EMMIN,SQRT(SHMIN))
18395           EMLMAX=MIN(EMMAX,RS-ML-MREMIN)
18396           DEBUG=1
18397           IF (EMLMIN.GT.EMLMAX) GOTO 888
18398           WMIN=EMLMIN+MREMIN
18399           PLMAX=HWUPCM(RS,ML,WMIN)
18400           YMIN = ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
18401      +                    PINC*PLMAX)/SMA
18402           YMIN = MAX(YMIN,YBMIN)
18403           DEBUG=2
18404           IF (YMIN.GT.YMAX) GOTO 888
18405         ELSE
18406 C---Neutral current
18407           ML = ME
18408           YMAX = ONE - TWO*ML*MP / SMA
18409           YMAX = MIN(YMAX,YBMAX)
18410           DO I=1,18
18411             YMIF(I)=ZERO
18412             EMMIF(I)=ZERO
18413             EMMAF(I)=ZERO
18414             WMIF(I)=ZERO
18415             IF (I.LE.8) THEN
18416 C---Boson-Gluon Fusion (also J/Psi) and QCD Compton with struck u or d
18417               MREMIF(I)=MP
18418               IF (I.LE.6) THEN
18419                 MFIN1(I)=RMASS(I)
18420                 MFIN2(I)=RMASS(I+6)
18421               ELSE
18422                 MFIN1(I)=RMASS(I-6)
18423                 MFIN2(I)=ZERO
18424               ENDIF
18425             ELSE
18426 C---QCD Compton with struck non-valence parton
18427               MREMIF(I)=MP+RMASS(I-6)
18428               MFIN1(I)=RMASS(I-6)
18429               MFIN2(I)=ZERO
18430             ENDIF
18431           ENDDO
18432           IF (IFL.EQ.164) THEN
18433 C---J/Psi
18434             MFIN1(7)=RMASS(164)
18435             MFIN2(7)=ZERO
18436           ENDIF
18437 C---y boundaries for different flavours and processes
18438           DO 100 I=IMIN,IMAX
18439             IF (INCLUD(I)) THEN
18440               MF1=MFIN1(I)
18441               MF2=MFIN2(I)
18442               MREMIN=MREMIF(I)
18443               SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
18444      +              TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
18445               EMMIF(I) = MAX(EMMIN,SQRT(SHMIN))
18446               EMMAF(I) = MIN(EMMAX,RS-ML-MREMIN)
18447               IF (EMMIF(I).GT.EMMAF(I)) THEN
18448                 INCLUD(I)=.FALSE.
18449                 CALL HWWARN('HWHBRN',3,*999)
18450                 GOTO 100
18451               ENDIF
18452               WMIF(I) = EMMIF(I)+MREMIF(I)
18453               WMIN = WMIF(I)
18454               PLMAX = HWUPCM(RS,ML,WMIN)
18455               YMIF(I)=ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
18456      +                         PINC*PLMAX)/SMA
18457               IF (YMIF(I).GT.YMAX) THEN
18458                 INCLUD(I)=.FALSE.
18459                 CALL HWWARN('HWHBRN',4,*999)
18460                 GOTO 100
18461               ENDIF
18462             ENDIF
18463  100      CONTINUE
18464 C---considering the largest boundaries
18465           EMLMIN=EMMIF(IMIN)
18466           EMLMAX=EMMAF(IMIN)
18467           IF (IPROO.EQ.3) THEN
18468             EMLMIN=MIN(EMMIF(IMIN),EMMIF(IMIN+6))
18469             EMLMAX=MAX(EMMAF(IMIN),EMMAF(IMIN+6))
18470           ENDIF
18471           DEBUG=3
18472           IF (EMLMIN.GT.EMLMAX) GOTO 888
18473           YMIN=YMIF(IMIN)
18474           IF (IPROO.EQ.3) YMIN=MIN(YMIF(IMIN),YMIF(IMIN+6))
18475           YMIN = MAX(YMIN,YBMIN)
18476           DEBUG=4
18477           IF (YMIN.GT.YMAX) GOTO 888
18478           WMIN = WMIF(IMIN)
18479           MREMIN = MREMIF(IMIN)
18480           MF1=MFIN1(IMIN)
18481           MF2=MFIN2(IMIN)
18482           IF (IPROO.EQ.3) THEN
18483             WMIN = MIN(WMIF(IMIN),WMIF(IMIN+6))
18484             MREMIN = MIN(MREMIF(IMIN),MREMIF(IMIN+6))
18485           ENDIF
18486         ENDIF
18487       ENDIF
18488 C---Random generation in largest phase space
18489       Y=ZERO
18490       Q2=ZERO
18491       SHAT=ZERO
18492       Z=ZERO
18493       PHI=ZERO
18494       AJACOB=ZERO
18495 C---y generation
18496       IF (.NOT.CHARGD) THEN
18497         IF (IFL.LE.5.OR.(IFL.GE.7.AND.IFL.LE.18)) THEN
18498           SRY0 = SQRT(YMIN)
18499           SRY1 = SQRT(YMAX)
18500           SRY = HWRUNI(0,SRY0,SRY1)
18501           Y = SRY**2
18502           YJAC = TWO*SRY*(SRY1-SRY0)
18503         ELSEIF (IFL.EQ.6) THEN
18504           Y = SQRT(HWRUNI(0,YMIN**2,YMAX**2))
18505           YJAC = HALF * (YMAX**2-YMIN**2) / Y
18506         ELSEIF (IFL.EQ.164) THEN
18507 C---in J/psi photoproduction Y and Q2 are given by the Equivalent Photon
18508 C   Approximation
18509    10     NTRY=0
18510    20     NTRY=NTRY+1
18511           IF (NTRY.GT.NETRY) CALL HWWARN('HWHBRN',50,*10)
18512           Y = (YMIN/YMAX)**HWRGEN(1)*YMAX
18513           IF (ONE+(ONE-Y)**2.LT.TWO*HWRGEN(2)) GOTO 20
18514           YJAC=(TWO*LOG(YMAX/YMIN)-TWO*(YMAX-YMIN)
18515      &                            +HALF*(YMAX**2-YMIN**2))
18516         ENDIF
18517       ELSE
18518         IF (IPRO.EQ.5) THEN
18519           Y = EXP(HWRUNI(0,LOG(YMIN),LOG(YMAX)))
18520           YJAC = Y * LOG(YMAX/YMIN)
18521         ELSE
18522           Y = HWRUNI(0,YMIN,YMAX)
18523           YJAC = YMAX - YMIN
18524         ENDIF
18525       ENDIF
18526 C---Q**2 generation
18527       Q2INF = ME**2*Y**2 / (ONE-Y)
18528       Q2SUP = MP**2 + SMA*Y - WMIN**2
18529       IF (IFL.EQ.164) THEN
18530         Q2INF = MAX(Q2INF,Q2WWMN)
18531         Q2SUP = MIN(Q2SUP,Q2WWMX)
18532       ELSE
18533         Q2INF = MAX(Q2INF,Q2MIN)
18534         Q2SUP = MIN(Q2SUP,Q2MAX)
18535       ENDIF
18536       DEBUG=5
18537       IF (Q2INF .GT. Q2SUP) GOTO 888
18538 C
18539       IF (.NOT.CHARGD) THEN
18540         IF (IFL.EQ.164) THEN
18541           Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
18542           Q2JAC = LOG(Q2SUP/Q2INF)
18543         ELSEIF (Q2INF.LT.RMASS(4)**2) THEN
18544           Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
18545           Q2JAC = Q2 * LOG(Q2SUP/Q2INF)
18546         ELSE
18547           Q2 = Q2INF*Q2SUP/HWRUNI(0,Q2INF,Q2SUP)
18548           Q2JAC = Q2**2 * (Q2SUP-Q2INF)/(Q2SUP*Q2INF)
18549         ENDIF
18550       ELSE
18551         EMW2=EMW**2
18552         Q2=(Q2INF+EMW2)*(Q2SUP+EMW2)/(HWRUNI(0,Q2INF,Q2SUP)+EMW2)-EMW2
18553         Q2JAC=(Q2+EMW2)**2*(Q2SUP-Q2INF)/((Q2SUP+EMW2)*(Q2INF+EMW2))
18554       ENDIF
18555       W2 = MP**2 + SMA*Y - Q2
18556 C---s_hat generation
18557       SHINF = EMLMIN **2
18558       SHSUP = (MIN(SQRT(W2)-MREMIN,EMLMAX))**2
18559       DEBUG=6
18560       IF (SHINF .GT. SHSUP) GOTO 888
18561 C
18562       IF (IPRO.EQ.91) THEN
18563         IF (.NOT.CHARGD) THEN
18564           SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
18565           SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
18566         ELSE
18567           SHAT = EXP(HWRUNI(0,LOG(SHINF),LOG(SHSUP)))
18568           SHJAC = SHAT*(LOG(SHSUP/SHINF))
18569         ENDIF
18570       ELSE
18571         EMW2=EMW**2
18572         IF (SHINF.GT.EMW2+10*GAMW*EMW) THEN
18573           SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
18574           SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
18575         ELSEIF (SHSUP.LT.EMW2-10*EMW*GAMW) THEN
18576           SHAT = HWRUNI(0,SHINF,SHSUP)
18577           SHJAC = SHSUP-SHINF
18578         ELSE
18579           TMIN=ATAN((SHINF-EMW2)/(GAMW*EMW))
18580           TMAX=ATAN((SHSUP-EMW2)/(GAMW*EMW))
18581           SHAT = GAMW*EMW*TAN(HWRUNI(0,TMIN,TMAX))+EMW2
18582           SHJAC=((SHAT-EMW2)**2+(GAMW*EMW)**2)/(GAMW*EMW)*(TMAX-TMIN)
18583         ENDIF
18584       ENDIF
18585       DETDSH = ONE/SMA/Y
18586       SHJAC=SHJAC*DETDSH
18587       RSHAT = SQRT (SHAT)
18588 C--- z generation
18589       ZMIN = 10E10
18590       ZMAX = -ONE
18591       IF (.NOT.CHARGD) THEN
18592         DO I=1,18
18593           Q1CM(I) = ZERO
18594           ZMIF(I) = ZERO
18595           ZMAF(I) = ZERO
18596         ENDDO
18597         DO 150 I=IMIN,IMAX
18598           IF (INCLUD(I)) THEN
18599             Q1CM(I) = HWUPCM( RSHAT, MFIN1(I), MFIN2(I) )
18600             IF (Q1CM(I) .LT. PTMIN) THEN
18601               ZMAF(I)=-ONE
18602               GOTO 150
18603             ENDIF
18604             CTHLIM = SQRT(ONE - (PTMIN / Q1CM(I))**2)
18605             GAMMA2 = SHAT + MFIN1(I)**2 - MFIN2(I)**2
18606             LAMBDA = (SHAT-MFIN1(I)**2-MFIN2(I)**2)**2 -
18607      +                4.D0*MFIN1(I)**2*MFIN2(I)**2
18608             ZMIF(I) = (GAMMA2 - SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
18609             ZMIF(I) = MAX(ZMIF(I),ZERO)
18610             ZMAF(I) = (GAMMA2 + SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
18611             ZMAF(I) = MIN(ZMAF(I),ONE)
18612             ZMIN = MIN( ZMIN, ZMIF(I) )
18613             ZMAX = MAX( ZMAX, ZMAF(I) )
18614           ENDIF
18615  150    CONTINUE
18616         IF (IFL.EQ.164) ZMAX=MIN(ZMAX,ZJMAX)
18617       ELSE
18618         Q1 = HWUPCM(RSHAT,MF1,MF2)
18619         DEBUG=7
18620         IF (Q1.LT.PTMIN) GOTO 888
18621         CTHLIM = SQRT(ONE-(PTMIN/Q1)**2)
18622         GAMMA2 = SHAT+MF1**2-MF2**2
18623         LAMBDA = (SHAT-MF1**2-MF2**2)**2-4.D0*MF1**2*MF2**2
18624         ZMIN = (GAMMA2-SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
18625         ZMIN = MAX(ZMIN,1D-6)
18626         ZMAX = (GAMMA2+SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
18627         ZMAX = MIN(ZMAX,ONE-1D-6)
18628       ENDIF
18629       DEBUG=8
18630       IF (ZMIN .GT. ZMAX) GOTO 888
18631       ZLMIN = LOG(ZMIN/(ONE-ZMIN))
18632       ZINT = LOG(ZMAX/(ONE-ZMAX)) - LOG(ZMIN/(ONE-ZMIN))
18633       ZL = ZLMIN+HWRGEN(0)*ZINT
18634       Z = EXP(ZL)/(ONE+EXP(ZL))
18635       ZJAC = Z*(ONE-Z)*ZINT
18636 C
18637       DEBUG=9
18638       IF ((Y.LT.YMIN.OR.Y.GT.YMAX).OR.(Q2.LT.Q2INF.OR.Q2.GT.Q2SUP).OR.
18639      +   (SHAT.LT.SHINF.OR.SHAT.GT.SHSUP).OR.(Z.LT.ZMIN.OR.Z.GT.ZMAX))
18640      +     GOTO 888
18641 C---Phi generation
18642       PHI = HWRUNI(0,ZERO,2*PIFAC)
18643       PHIJAC = 2 * PIFAC
18644       IF (IFL.EQ.164) PHIJAC=ONE
18645 C
18646       AJACOB = YJAC * Q2JAC * SHJAC * ZJAC * PHIJAC
18647 C
18648       IF (IQK.NE.0.OR.IPRO.EQ.5) GOTO 999
18649 C---contributing subprocesses: filling of logical vector INSIDE
18650       DO I=1,18
18651         INSIDE(I)=.FALSE.
18652         Q2MAF(I)=ZERO
18653         EMMAWF(I)=ZERO
18654       ENDDO
18655       DO 200 I=IMIN,IMAX
18656       IF (INCLUD(I)) THEN
18657       IF ( Y.LT.YMIF(I) ) GOTO 200
18658 C
18659       Q2MAF(I) = MP**2 + SMA*Y - WMIF(I)**2
18660       Q2MAF(I) = MIN( Q2MAF(I), Q2MAX)
18661       IF (Q2INF .GT. Q2MAF(I)) GOTO 200
18662       IF (Q2.LT.Q2INF .OR. Q2.GT.Q2MAF(I)) GOTO 200
18663 C
18664       EMMAWF(I) = SQRT(W2) - MREMIF(I)
18665       EMMAWF(I) = MIN( EMMAWF(I), EMLMAX )
18666 C
18667       IF (EMMIF(I) .GT. EMMAWF(I)) GOTO 200
18668       IF (SHAT.LT.EMMIF(I)**2.OR.SHAT.GT.EMMAWF(I)**2) GOTO 200
18669 C
18670       IF (ZMIF(I) .GT. ZMAF(I)) GOTO 200
18671       IF (Z.LT.ZMIF(I) .OR. Z.GT.ZMAF(I)) GOTO 200
18672       INSIDE(I)=.TRUE.
18673       ENDIF
18674  200  CONTINUE
18675  999  RETURN
18676  888  EVWGT=ZERO
18677 C---UNCOMMENT THIS LINE TO GET A DEBUGGING WARNING FOR NO PHASE-SPACE
18678 C      CALL HWWARN('HWHBRN',DEBUG,*777)
18679  777  RETURN 1
18680       END
18681 CDECK  ID>, HWHBSG.
18682 *CMZ :-        -03/07/95  19.02.12  by  Giovanni Abbiendi
18683 *-- Author :    Giovanni Abbiendi & Luca Stanco
18684 C----------------------------------------------------------------------
18685       SUBROUTINE HWHBSG
18686 C----------------------------------------------------------------------
18687 C     Returns differential cross section DSIGMA in (Y,Q2,ETA,Z,PHI)
18688 C     Scale for structure functions and alpha_s selected by BGSHAT
18689 C----------------------------------------------------------------------
18690       INCLUDE 'HERWIG65.INC'
18691       DOUBLE PRECISION HWUALF,HWUAEM,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,
18692      & ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18693      & SFUN(13),ALPHA,LDSIG,DLQ(7),SG,XG,MF1,MF2,MSUM,MDIF,MPRO,FFUN,
18694      & GFUN,H43,H41,H11,H12,H14,H16,H21,H22,G11,G12,G1A,G1B,G21,G22,G3,
18695      & GC,A11,A12,A44,ALPHAS,PDENS,AFACT,BFACT,CFACT,DFACT,GAMMA,S,T,U,
18696      & MREMIN,POL,CCOL,ETA
18697       INTEGER LEP
18698       INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,IHAD,ILEPT,IQ,IS
18699       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18700       EXTERNAL HWUALF,HWUAEM
18701       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18702      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18703      & IPROO,CHARGD,INCLUD,INSIDE
18704 C
18705       IHAD=2
18706       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18707 C---set masses
18708       IF (CHARGD) THEN
18709         MREMIN=MP
18710         IF (LEP.EQ.1) THEN
18711           MF1=RMASS(IFLAVD)
18712           MF2=RMASS(IFLAVU)
18713         ELSE
18714           MF1=RMASS(IFLAVU)
18715           MF2=RMASS(IFLAVD)
18716         ENDIF
18717       ELSE
18718         IS=IFL
18719         IF (IFL.EQ.164) IS=IQK
18720         MREMIN = MREMIF(IS)
18721         MF1 = MFIN1(IS)
18722         MF2 = MFIN2(IS)
18723       ENDIF
18724 C---choose subprocess scale
18725       IF (BGSHAT) THEN
18726         EMSCA = RSHAT
18727       ELSE
18728         S=SHAT+Q2
18729         IF (IFL.GE.7.AND.IFL.LE.18) S=SHAT+Q2-MF1**2
18730         T=-S*Z
18731         U=-S-T
18732         IF (IFL.GE.7.AND.IFL.LE.18) U=-S-T-2*MF1**2
18733         EMSCA = SQRT(TWO*S*T*U/(S**2+T**2+U**2))
18734         IF (IFL.EQ.164) EMSCA=SQRT(-U)
18735       ENDIF
18736       ALPHAS = HWUALF(1,EMSCA)
18737       IF (ALPHAS.GE.ONE.OR.ALPHAS.LE.ZERO) CALL HWWARN('HWHBSG',51,*888)
18738 C---structure functions
18739       ETA = (SHAT+Q2)/SMA/Y
18740       IF (ETA.GT.ONE) ETA=ONE
18741       CALL HWSFUN (ETA,EMSCA,IDHW(IHAD),NSTRU,SFUN,2)
18742       XG = Q2/(SHAT + Q2)
18743       SG = ETA*SMA
18744       IF (SG.LE.(RSHAT+ML)**2.OR.SG.GE.(RS-MREMIN)**2) GOTO 888
18745 C
18746       IF (IFL.EQ.164) GOTO 200
18747 C
18748 C---Electroweak couplings
18749       ALPHA=HWUAEM(-Q2)
18750       IF (CHARGD) THEN
18751         POL = PPOLN(3) - EPOLN(3)
18752         DLQ(1)=.0625*VCKM(IFLAVU/2,(IFLAVD+1)/2)/SWEIN**2 *
18753      +         Q2**2/((Q2+RMASS(198)**2)**2+(RMASS(198)*GAMW)**2) *
18754      +         (ONE + POL)
18755         DLQ(2)=ZERO
18756         DLQ(3)=DLQ(1)
18757       ELSE
18758         IQ=MOD(IFL-1,6)+1
18759         ILEPT=MOD(IDHW(1)-121,6)+11
18760         CALL HWUCFF(ILEPT,IQ,-Q2,DLQ(1))
18761       ENDIF
18762 C
18763       IF (IFL.LE.6) THEN
18764 C---For Boson-Gluon Fusion
18765         PDENS = SFUN(13)/ETA
18766         CCOL = HALF
18767         MSUM = (MF1**2 + MF2**2) / (Y*SG)
18768         MDIF = (MF1**2 - MF2**2) / (Y*SG)
18769         MPRO = MF1*MF2 / (Y*SG)
18770 C
18771         FFUN = (1.D0-XG)*Z*(1.D0-Z) + (MDIF*(2.D0*Z-1.D0)-MSUM)/2.D0
18772         GFUN = (1.D0-XG)*(1.D0-Z) + XG*Z + MDIF
18773         IF ( FFUN .LT. ZERO ) FFUN = ZERO
18774         H43 = (8.D0*(2.D0*Z**2*XG-Z**2-2.D0*Z*XG+2.D0*Z*MDIF+Z-MDIF
18775      &         -MSUM)) / (Z*(1.D0-Z))**2
18776 C
18777         H41 = (8.D0*(Z**2-Z*XG+Z*MDIF-MDIF-MSUM)) / (Z**2*(1.D0-Z))
18778 C
18779         H11 = (4.D0*(2.D0*Z**4-4.D0*Z**3+2.D0*Z**2*MSUM*XG
18780      &         -2.D0*Z**2*MSUM+2.D0*Z**2*XG**2-2.D0*Z**2*XG+3.D0*Z**2
18781      &         +2.D0*Z*MDIF*MSUM+2.D0*Z*MDIF*XG-2.D0*Z*MSUM*XG
18782      &         +2.D0*Z*MSUM-2.D0*Z*XG**2+2.D0*Z*XG-Z-MDIF*MSUM-MDIF*XG
18783      &         -MSUM**2-MSUM*XG)) / (Z*(1.D0-Z))**2
18784 C
18785         H12 = (16.D0*(-Z*MDIF+Z*XG+MDIF+MSUM))/(Z**2*(1.D0-Z))
18786 C
18787         H14 = (16.D0*(-2.D0*Z**2*XG-2.D0*Z*MDIF+2.D0*Z*XG+MDIF+MSUM))
18788      &        / (Z*(1.D0-Z))**2
18789 C
18790         H16 = (32.D0*(Z*MDIF-Z*XG-MDIF-MSUM)) / (Z**2*(1.D0-Z))
18791 C
18792         H21 = (8.D0*MPRO*(-2.D0*Z**2*XG+2.D0*Z**2-2.D0*Z*MDIF+2.D0*Z*XG
18793      +         -2.D0*Z+MDIF+MSUM)) / (Z*(1.D0-Z))**2
18794 C
18795         H22 = (-32.D0*MPRO) / (Z*(1.D0-Z))
18796 C
18797         G11 = -2.D0*H11 + FFUN*H14
18798         G12 = 2.D0*XG*FFUN*H14 + H12 + GFUN * ( H16+GFUN*H14 )
18799         G1A = SQRT( XG*FFUN ) * ( H16 + 2.D0*GFUN*H14 )
18800         G1B = FFUN*H14
18801         G21 = -2.D0*H21
18802         G22 = H22
18803         G3  = H41 - GFUN*H43
18804         GC  = SQRT( XG*FFUN ) * (-2.D0*XG*H43 )
18805       ELSE
18806 C---for QCD Compton, massless matrix element
18807         PDENS = SFUN(IFL-6)/ETA
18808         CCOL = CFFAC
18809         FFUN = XG*(ONE-XG)*Z*(ONE-Z)
18810         GFUN = (ONE-XG)*(ONE-Z)+XG*Z
18811         G11 = 8.D0*((Z**2+XG**2)/(ONE-XG)/(ONE-Z)+TWO*(XG*Z+ONE))
18812         G12 = 64.D0*XG**2*Z+TWO*XG*G11
18813         G1A = 32.D0*XG*GFUN*SQRT(FFUN)/((ONE-XG)*(ONE-Z))
18814         G1B = 16.D0*XG*Z
18815         G3  = -16.D0*(ONE-XG)*(ONE-Z)+G11
18816         GC  = -16.D0*XG*SQRT(FFUN)*(ONE-Z-XG)/((ONE-XG)*(ONE-Z))
18817         G21 = ZERO
18818         G22 = ZERO
18819       ENDIF
18820 C
18821       A11 = XG * Y**2 * G11  +  (1.D0-Y) * G12
18822      &      - (2.D0-Y) * SQRT( 1.D0-Y ) * G1A  *  COS( PHI )
18823      &      + 2.D0 * XG * (1.D0-Y) * G1B  *  COS( 2.D0*PHI )
18824 C
18825       A12 = XG * Y**2 * G21  +  (1.D0-Y) * G22
18826 C
18827       A44 = XG * Y * (2.D0-Y) * G3
18828      &      - 2.D0 * Y * SQRT( 1.D0-Y ) * GC  *  COS( PHI )
18829 C
18830       IF ( Y*Q2**2 .LT. 1D-38 ) THEN
18831 C---prevent numerical uncertainties in DSIGMA computation
18832         DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL/(16.D0*PIFAC)
18833      &           *(DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
18834         IF ( DSIGMA .LE. ZERO ) GOTO 888
18835         LDSIG = LOG (DSIGMA) - LOG (Y) - 2.D0 * LOG (Q2)
18836         DSIGMA = EXP (LDSIG)
18837       ELSE
18838         DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL
18839      &         * (DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
18840      &         / (16.D0*PIFAC*Y*Q2**2)
18841       ENDIF
18842       IF (DSIGMA.LT.ZERO) GOTO 888
18843       RETURN
18844 C
18845   200 CONTINUE
18846 C--- J/psi production
18847       ALPHA = HWUAEM(-Q2)
18848       GAMMA = 4.8D-6
18849       PDENS = SFUN(13)/ETA
18850       AFACT = (8.D0*PIFAC*ALPHAS**2*RMASS(164)**3*GAMMA)/(3.D0*ALPHA)
18851       BFACT = ONE/(Y*SG*Z**2*((Z-ONE)*Y*SG-RMASS(164)**2)**2)
18852       CFACT = (RMASS(164)**2-Z*Y*SG)**2/(Y*SG*(ONE-XG)**2*
18853      &        ((ONE-XG)*Y*SG-RMASS(164)**2)**2*
18854      &        ((Z-ONE)*Y*SG-RMASS(164)**2)**2)
18855       DFACT = ((Z-ONE)*Y*SG)**2/(Y*SG*(ONE-XG)**2*
18856      &          ((ONE-XG)*Y*SG-RMASS(164)**2)**2*(Z*Y*SG)**2)
18857       DSIGMA = GEV2NB*ALPHA/(TWO*PIFAC)*AFACT*(BFACT+CFACT+DFACT)*PDENS
18858       IF (DSIGMA.LT.ZERO ) GOTO 888
18859       RETURN
18860  888  DSIGMA=ZERO
18861       END
18862 CDECK  ID>, HWHDIS.
18863 *CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
18864 *-- Author :    Giovanni Abbiendi & Luca Stanco
18865 C----------------------------------------------------------------------
18866       SUBROUTINE HWHDIS
18867 C----------------------------------------------------------------------
18868 C     DEEP INELASTIC LEPTON-HADRON SCATTERING: MEAN EVWGT = SIGMA IN NB
18869 C----------------------------------------------------------------------
18870       INCLUDE 'HERWIG65.INC'
18871       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,SAMP,SIG,Q2,
18872      & XBJ,Y,W,S,MLEP,MHAD,MLSCAT,YMIN,YMAX,XXMAX,Q2JAC,XXJAC,
18873      & JACOBI,A1,A2,A3,B1,B2,PCM,PCMEP,PCMLW,PCMEQ,PCMLQ,COSPHI,PA,
18874      & EQ,PZQ,SHAT,PROP,DLEFT,DRGHT,DUP,DWN,FACT,EFACT,OMY2,YPLUS,
18875      & YMNUS,SIGMA,AF(7,12),SMA,Q2SUP,HWUAEM,DCHRG,DNEUT
18876       INTEGER I,IQK,IQKIN,IQKOUT,IDSCAT,IHAD,ILEPT,LEP
18877       LOGICAL CHARGD
18878       EXTERNAL HWRGEN,HWRUNI,HWUPCM
18879       SAVE MLEP,MHAD,S,SMA,PCM,MLSCAT,A1,A2,A3,B1,B2,DLEFT,DRGHT,Q2,
18880      & AF,XBJ,Y,YPLUS,YMNUS,OMY2,FACT,EFACT,SIGMA,IDSCAT,CHARGD,
18881      & ILEPT,DCHRG,DNEUT,LEP
18882       IQK=MOD(IPROC,10)
18883       IHAD=2
18884       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18885       IF (FSTWGT.OR.IHAD.NE.2) THEN
18886 C---INITIALISE PROCESS (MUST BE DONE EVERY TIME IF S VARIES)
18887 C---LEPTON AND HADRON MASSES, INVARIANT MASS, MOMENTUM IN C.M. FRAME
18888         MLEP=PHEP(5,1)
18889         MHAD=PHEP(5,IHAD)
18890         S=PHEP(5,3)**2
18891         SMA=S-MLEP**2-MHAD**2
18892         PCM=HWUPCM(SQRT(S),MLEP,MHAD)
18893 C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
18894         IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
18895           LEP=1
18896         ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
18897           LEP=-1
18898         ELSE
18899           CALL HWWARN('HWHDIS',500,*999)
18900         ENDIF
18901         DCHRG=FLOAT(MOD(IDHW(1)  ,2))
18902         DNEUT=FLOAT(MOD(IDHW(1)+1,2))
18903         ILEPT=MOD(IDHW(1)-121,6)+11
18904 C---DLEFT,DRIGHT = 1,0 for leptons; = 0,1 for anti-leptons
18905         DLEFT=MAX(LEP,0)
18906         DRGHT=MAX(-LEP,0)
18907         CHARGD=MOD(IPROC,100)/10.EQ.1
18908 C---Evaluate constant factor in cross section and
18909 C   find and store scattered lepton identity
18910         IF (CHARGD) THEN
18911           IF ((EPOLN(3)-PPOLN(3)).EQ.ONE) THEN
18912              WRITE(6,5)
18913              CALL HWWARN('HWHDIS',501,*999)
18914   5          FORMAT(1X,'WARNING: Cross-section is zero for the',
18915      &                ' specified lepton helicity')
18916           ENDIF
18917           FACT=GEV2NB*(ONE-(EPOLN(3)-PPOLN(3)))*.25D0*PIFAC
18918      &        /(SWEIN*RMASS(198)**2)**2
18919           IDSCAT=IDHW(1)+NINT(DCHRG-DNEUT)
18920         ELSE
18921           FACT=GEV2NB*TWO*PIFAC
18922           IDSCAT=IDHW(1)
18923         ENDIF
18924         MLSCAT=RMASS(IDSCAT)
18925 C---PARAMETERS USED FOR THE WEIGHT GENERATION IN NEUTRAL CURRENT
18926 C   PROCESSES. ASSUME D(SIGMA)/D(Q**2) GOES LIKE A1+A2/Q**2+A3/Q**4
18927 C   AND D(SIGMA)/D(X) LIKE B1+B2/X
18928         A1=0.5
18929         A2=0.5
18930         A3=1.
18931         B1=0.1
18932         B2=1.
18933       ENDIF
18934       IF (GENEV) THEN
18935 C---GENERATE EVENT (KINEMATICAL VARIABLES AND STRUCTURE FUNCTION
18936 C   ALREADY FOUND)
18937         PRAN=SIGMA*HWRGEN(0)
18938         IF (CHARGD) THEN
18939 C---CHARGED CURRENT PROCESS
18940           IF (IQK.EQ.0) THEN
18941 C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
18942             PROB=ZERO
18943             DO 10 I=1,6
18944             DUP=MOD(I+1,2)
18945             DWN=MOD(I  ,2)
18946             PROB=PROB+EFACT*
18947      &          ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
18948      &           +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I  ,1)
18949      &          +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
18950      &           +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
18951             IF (PROB.GE.PRAN) GOTO 20
18952    10       CONTINUE
18953             I=6
18954    20       IQK=I
18955           ENDIF
18956           DUP=MOD(IQK+1,2)
18957           DWN=MOD(IQK  ,2)
18958           IQKIN=IQK
18959           IF ((LEP.EQ. 1.AND.MOD(IQK+IDHW(1),2).EQ.0)
18960      &    .OR.(LEP.EQ.-1.AND.MOD(IQK+IDHW(1),2).EQ.1)) IQKIN=IQK+6
18961 C---FIND FLAVOUR OF THE OUTGOING QUARK
18962           PRAN=HWRGEN(0)
18963           PROB=ZERO
18964           IF (DUP.EQ.ONE) THEN
18965             DO 30 I=1,3
18966             PROB=PROB+VCKM(IQK/2,I)
18967             IF (PROB.GE.PRAN) GOTO 40
18968    30       CONTINUE
18969             I=3
18970    40       IQKOUT=2*I-1
18971             IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
18972           ELSE
18973             DO 50 I=1,3
18974             PROB=PROB+VCKM(I,(IQK+1)/2)
18975             IF (PROB.GE.PRAN) GOTO 60
18976    50       CONTINUE
18977             I=3
18978    60       IQKOUT=2*I
18979             IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
18980           ENDIF
18981         ELSE
18982 C---NEUTRAL CURRENT PROCESS
18983           IF (IQK.NE.0) THEN
18984             IQKIN=IQK
18985             PROB=EFACT*(AF(1,IQK)*YPLUS*DISF(IQK,1)+
18986      &       FLOAT(LEP)*AF(3,IQK)*YMNUS*DISF(IQK,1))
18987             IF (PROB.LT.PRAN) IQKIN=IQK+6
18988           ELSE
18989 C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
18990             PROB=ZERO
18991             SIG=ONE
18992             DO 70 I=1,12
18993             IF (I.GT.6) SIG=-ONE
18994             PROB=PROB+EFACT*(AF(1,I)*YPLUS*DISF(I,1)+
18995      &        FLOAT(LEP)*SIG*AF(3,I)*YMNUS*DISF(I,1))
18996             IF (PROB.GE.PRAN) GOTO 80
18997    70       CONTINUE
18998             I=12
18999    80       IQKIN=I
19000           ENDIF
19001           IQKOUT=IQKIN
19002         ENDIF
19003         IDN(1)=IDHW(1)
19004         IDN(2)=IQKIN
19005         IDN(3)=IDSCAT
19006         IDN(4)=IQKOUT
19007         ICO(1)=1
19008         ICO(2)=4
19009         ICO(3)=3
19010         ICO(4)=2
19011         XX(1)=1.
19012         XX(2)=XBJ
19013 C---CHECK PHASE SPACE WITH THE SELECTED FLAVOUR. IF OUTSIDE THE
19014 C   EVENT IS KILLED.
19015         PA=XBJ*(PHEP(4,IHAD)+ABS(PHEP(3,IHAD)))
19016         EQ=HALF*(PA+RMASS(IDN(2))**2/PA)
19017         PZQ=-(PA-EQ)
19018         SHAT=(PHEP(4,1)+EQ)**2-(PHEP(3,1)+PZQ)**2
19019         PCMEQ=HWUPCM(SQRT(SHAT),MLEP,RMASS(IDN(2)))
19020         PCMLQ=HWUPCM(SQRT(SHAT),MLSCAT,RMASS(IDN(4)))
19021         IF (PCMLQ.LT.ZERO) THEN
19022           CALL HWWARN('HWHDIS',101,*999)
19023         ELSEIF (PCMLQ.EQ.ZERO) THEN
19024           COSTH=ZERO
19025         ELSE
19026           COSTH=(TWO*SQRT(PCMEQ**2+MLEP**2)*SQRT(PCMLQ**2+MLSCAT**2)
19027      &         -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEQ*PCMLQ)
19028         ENDIF
19029         IF (ABS(COSTH).GT.ONE) CALL HWWARN('HWHDIS',102,*999)
19030         IDCMF=15
19031         CALL HWETWO(.TRUE.,.TRUE.)
19032       ELSE
19033         EVWGT=ZERO
19034         IF (CHARGD) THEN
19035 C---CHOOSE X,Y (CC PROCESS)
19036           YMIN=MAX(YBMIN,Q2MIN/SMA)
19037           YMAX=MIN(YBMAX,ONE)
19038           IF (YMIN.GT.YMAX) GOTO 999
19039           Y=HWRUNI(0,YMIN,YMAX)
19040           XXMIN=Q2MIN/S/Y
19041           XXMAX=MIN(Q2MAX/SMA/Y,ONE)
19042           IF (XXMIN.GT.XXMAX) GOTO 999
19043           XBJ=HWRUNI(0,XXMIN,XXMAX)
19044           Q2=XBJ*Y*(S-MLEP**2-MHAD**2)
19045           JACOBI=(YMAX-YMIN)*(XXMAX-XXMIN)*(S-MLEP**2-MHAD**2)*XBJ
19046         ELSE
19047 C---CHOOSE X,Q**2 (NC PROCESS)
19048           Q2SUP=MIN(Q2MAX,SMA*YBMAX)
19049           IF (Q2MIN.GT.Q2SUP) GOTO 999
19050           SAMP=(A1+A2+A3)*HWRGEN(0)
19051           IF (SAMP.LE.A1) THEN
19052             Q2=HWRUNI(0,Q2MIN,Q2SUP)
19053           ELSEIF (SAMP.LE.(A1+A2)) THEN
19054             Q2=EXP(HWRUNI(0,LOG(Q2MIN),LOG(Q2SUP)))
19055           ELSE
19056             Q2=-ONE/HWRUNI(0,-ONE/Q2MIN,-ONE/Q2SUP)
19057           ENDIF
19058           Q2JAC=(A1+A2+A3)/
19059      &      (A1/(Q2SUP-Q2MIN)
19060      &      +A2/LOG(Q2SUP/Q2MIN)/Q2
19061      &      +A3*Q2MIN*Q2SUP/(Q2SUP-Q2MIN)/Q2**2)
19062           XXMIN=Q2/SMA/YBMAX
19063           XXMAX=ONE
19064           IF (YBMIN.GT.ZERO) XXMAX=MIN(Q2/SMA/YBMIN,ONE)
19065           IF (XXMIN.GT.XXMAX) GOTO 999
19066           SAMP=(B1+B2)*HWRGEN(0)
19067           IF (SAMP.LE.B1) THEN
19068             XBJ=HWRUNI(0,XXMIN,XXMAX)
19069           ELSE
19070             XBJ=EXP(HWRUNI(0,LOG(XXMIN),LOG(XXMAX)))
19071           ENDIF
19072           XXJAC=(B1+B2)/(B1/(XXMAX-XXMIN)+B2/LOG(XXMAX/XXMIN)/XBJ)
19073           Y=Q2/(S-MLEP**2-MHAD**2)/XBJ
19074           JACOBI=Q2JAC*XXJAC
19075         ENDIF
19076 C---CHECK IF THE GENERATED POINT IS INSIDE PHASE SPACE. IF NOT
19077 C   RETURN WITH WEIGHT EQUAL TO ZERO.
19078         W=SQRT(MHAD**2+Q2*(ONE-XBJ)/XBJ)
19079         IF (W.LT.WHMIN) RETURN
19080         PCMEP=PCM
19081         PCMLW=HWUPCM(SQRT(S),MLSCAT,W)
19082         IF (PCMLW.LT.ZERO) THEN
19083           EVWGT=ZERO
19084           RETURN
19085         ELSEIF (PCMLW.EQ.ZERO) THEN
19086           COSPHI=ZERO
19087         ELSE
19088           COSPHI=
19089      &    (TWO*SQRT(PCMEP**2+MLEP**2)*SQRT(PCMLW**2+MLSCAT**2)
19090      &    -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEP*PCMLW)
19091         ENDIF
19092         IF (ABS(COSPHI).GT.ONE) THEN
19093           EVWGT=ZERO
19094           RETURN
19095         ENDIF
19096 C---SET SCALE EQUAL Q. EVALUATE STRUCTURE FUNCTIONS.
19097         EMSCA=SQRT(Q2)
19098         CALL HWSFUN(XBJ,EMSCA,IDHW(IHAD),NSTRU,DISF,2)
19099 C---SWITCH OFF ANY FLAVOURS THAT ARE BELOW THRESHOLD
19100         DO 90 I=1,12
19101  90     IF (W.LT.2*RMASS(I)) DISF(I,1)=0
19102 C---EVALUATE DIFFERENTIAL CROSS SECTION
19103         IF (CHARGD) THEN
19104           PROP=RMASS(198)**2/(Q2+RMASS(198)**2)
19105           EFACT=FACT*(HWUAEM(-Q2)*PROP)**2/XBJ
19106           OMY2=(ONE-Y)**2
19107           SIGMA=ZERO
19108           DO 100 I=1,6
19109           DUP=MOD(I+1,2)
19110           DWN=MOD(I  ,2)
19111           IF (IQK.NE.0.AND.IQK.NE.I) GOTO 100
19112           SIGMA=SIGMA+EFACT*
19113      &        ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
19114      &         +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I  ,1)
19115      &        +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
19116      &         +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
19117   100     CONTINUE
19118         ELSE
19119           EFACT=FACT/XBJ*(HWUAEM(-Q2)/Q2)**2
19120           YPLUS=ONE+(ONE-Y)**2
19121           YMNUS=ONE-(ONE-Y)**2
19122           DO 110 I=1,6
19123           CALL HWUCFF(ILEPT,I,-Q2,AF(1,I))
19124           AF(1,I+6)=AF(1,I)
19125           AF(3,I+6)=AF(3,I)
19126   110     CONTINUE
19127           SIGMA=ZERO
19128           DO 200 I=1,6
19129           IF (IQK.NE.0.AND.IQK.NE.I) GOTO 200
19130           SIGMA=SIGMA+EFACT*(AF(1,I)*YPLUS*(DISF(I,1)+DISF(I+6,1))+
19131      &            FLOAT(LEP)*AF(3,I)*YMNUS*(DISF(I,1)-DISF(I+6,1)))
19132   200     CONTINUE
19133         ENDIF
19134 C---FIND WEIGHT: DIFFERENTIAL CROSS SECTION TIME THE JACOBIAN FACTOR
19135         EVWGT=SIGMA*JACOBI
19136         IF (EVWGT.LT.ZERO) EVWGT=ZERO
19137       ENDIF
19138   999 END
19139 CDECK  ID>, HWHDYP.
19140 *CMZ :-        -18/05/99  12.41.07  by  Mike Seymour
19141 *-- Author :    Bryan Webber, Ian Knowles and Mike Seymour
19142 C-----------------------------------------------------------------------
19143       SUBROUTINE HWHDYP
19144 C-----------------------------------------------------------------------
19145 C     Drell-Yan Production of fermion pairs via photon, Z0 & (if ZPRIME)
19146 C     Z' exchange. Lepton universality is assumed for photon and Z, and
19147 C     for Z' if no lepton flavour is specified.
19148 C     MEAN EVWGT = SIGMA IN NB
19149 C
19150 C     Modified 16/01/01 by BRW to implement Peter Richardson's
19151 C     fix for bug in lepton mass effects on branching ratio
19152 C-----------------------------------------------------------------------
19153       INCLUDE 'HERWIG65.INC'
19154       DOUBLE PRECISION HWRGEN,HWRUNI,HWUAEM,EPS,C1,C2,C3,EMSQZ,EMGMZ,
19155      & EMSQZP,EMGMZP,CQF(7,6,16),QPOW,RPOW,A01,A1,A02,A2,A03,A3,CRAN,
19156      & EMJ1,EMJ2,EMJ3,EMJAC,FACT,QSQ,HCS,FACTR,RCS,EXTRA,PMAX,PTHETA
19157       INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,IADD(2,2),ID1,ID2,
19158      & ID3,ID4,JF
19159       EXTERNAL HWRGEN,HWRUNI,HWUAEM
19160       SAVE HCS,JQMN,JQMX,JLMN,JLMX,C1,C2,C3,QPOW,RPOW,EMSQZ,EMGMZ,
19161      & A1,A01,A2,A02,A3,A03,EMSQZP,EMGMZP,FACT,CQF
19162       PARAMETER (EPS=1.D-9)
19163       DATA IADD/0,6,6,0/
19164       IF (GENEV) THEN
19165         RCS=HCS*HWRGEN(0)
19166       ELSE
19167         IF (FSTWGT) THEN
19168 C Set limits for which particles to include
19169           JLMN=1
19170           JLMX=0
19171           JQMN=1
19172           JQMX=0
19173           IMODE=MOD(IPROC,100)
19174           IF (IMODE.EQ.0) THEN
19175             JQMN=1
19176             JQMX=6
19177           ELSEIF (IMODE.LE.10) THEN
19178             JQMN=IMODE
19179             JQMX=IMODE
19180           ELSEIF (IMODE.EQ.50) THEN
19181             JLMN=11
19182             JLMX=16
19183           ELSEIF (IMODE.GE.50.AND.IMODE.LE.60) THEN
19184             JLMN=IMODE-40
19185             JLMX=IMODE-40
19186           ELSEIF (IMODE.EQ.99) THEN
19187             JQMN=1
19188             JQMX=6
19189             JLMN=11
19190             JLMX=16
19191           ELSE
19192             CALL HWWARN('HWHDYP',500,*999)
19193           ENDIF
19194 C Set up parameters for importance sampling:
19195 C sum of power law and two Breit-Wigners (relative weights C1,C2,C3)
19196           C1=ONE
19197           C2=ONE
19198           C3=ZERO
19199           IF (ZPRIME) C3=ONE
19200           IF (EMPOW.EQ.ONE) CALL HWWARN('HWHDYP',501,*999)
19201           IF (C2.EQ.ZERO) CALL HWWARN('HWHDYP',502,*999)
19202           IF (C3.EQ.ZERO.AND.ZPRIME) CALL HWWARN('HWHDYP',503,*999)
19203           QPOW=-EMPOW+1
19204           RPOW=1/QPOW
19205           EMSQZ=RMASS(200)**2
19206           EMGMZ=RMASS(200)*GAMZ
19207           A01=EMMIN**QPOW
19208           A1=(EMMAX**QPOW-A01)/C1
19209           A02=ATAN((EMMIN**2-EMSQZ)/EMGMZ)
19210           A2=(ATAN((EMMAX**2-EMSQZ)/EMGMZ)-A02)/C2
19211           IF (C3.GT.ZERO) THEN
19212             EMSQZP=RMASS(202)**2
19213             EMGMZP=RMASS(202)*GAMZP
19214             A03=ATAN((EMMIN**2-EMSQZP)/EMGMZP)
19215             A3=(ATAN((EMMAX**2-EMSQZP)/EMGMZP)-A03)/C3
19216           ENDIF
19217         ENDIF
19218         EVWGT=0.
19219 C Select a mass for the produced pair
19220         CRAN=(C1+C2+C3)*HWRGEN(1)
19221         IF (CRAN.LT.C1) THEN
19222 C Use power law
19223           EMSCA=(A01+A1*CRAN)**RPOW
19224           QSQ=EMSCA**2
19225         ELSEIF (CRAN.LT.C1+C2) THEN
19226 C Use Z Breit-Wigner
19227           CRAN=CRAN-C1
19228           QSQ=EMSQZ+EMGMZ*TAN(A02+A2*CRAN)
19229           EMSCA=SQRT(QSQ)
19230         ELSE
19231 C Use Z' Breit-Wigner
19232           CRAN=CRAN-C1-C2
19233           QSQ=EMSQZP+EMGMZP*TAN(A03+A3*CRAN)
19234           EMSCA=SQRT(QSQ)
19235         ENDIF
19236         EMJ1=EMSCA**EMPOW/(1-EMPOW)*A1
19237         EMJ2=((QSQ-EMSQZ)**2+EMGMZ**2)/(2*EMSCA*EMGMZ)*A2
19238         IF (C3.GT.ZERO) THEN
19239           EMJ3=((QSQ-EMSQZP)**2+EMGMZP**2)/(2*EMSCA*EMGMZP)*A3
19240           EMJAC=(C1+C2+C3)/(1/EMJ1+1/EMJ2+1/EMJ3)
19241         ELSE
19242           EMJAC=(C1+C2)/(1/EMJ1+1/EMJ2)
19243         ENDIF
19244 C Select initial momentum fractions
19245         XXMIN=QSQ/PHEP(5,3)**2
19246         XLMIN=LOG(XXMIN)
19247         CALL HWSGEN(.TRUE.)
19248         FACT=-GEV2NB*HWUAEM(QSQ)**2*PIFAC*8*EMJAC*XLMIN
19249      $       /(3*NCOLO*EMSCA**3)
19250 C Store cross-section coefficients
19251         DO 50 IQ=1,6
19252         DO 30 JQ=JQMN,JQMX
19253         IF (EMSCA.GT.2.*RMASS(JQ)) THEN
19254           CALL HWUCFF(IQ,JQ,QSQ,CQF(1,IQ,JQ))
19255         ELSE
19256           CALL HWVZRO(7,CQF(1,IQ,JQ))
19257         ENDIF
19258   30    CONTINUE
19259         DO 40 JL=JLMN,JLMX
19260         IF (EMSCA.GT.2.*RMASS(JL+110)) THEN
19261           CALL HWUCFF(IQ,JL,QSQ,CQF(1,IQ,JL))
19262         ELSE
19263           CALL HWVZRO(7,CQF(1,IQ,JL))
19264         ENDIF
19265   40    CONTINUE
19266   50    CONTINUE
19267       ENDIF
19268 C
19269       HCS=0.
19270       DO 90 I=1,2
19271 C I=1 quark first, I=2 anti-quark first
19272       DO 80 IQ=1,6
19273       ID1=IQ+IADD(1,I)
19274       ID2=IQ+IADD(2,I)
19275       IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
19276       FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
19277 C Quark final states
19278       DO 60 JQ=JQMN,JQMX
19279       ID3=JQ
19280       ID4=JQ+6
19281       IF (IQ.EQ.JQ) THEN
19282         HCS=HCS+FACTR*(CQF(1,IQ,JQ)*FLOAT(NCOLO)+3*HALF*QFCH(IQ)**4)
19283         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
19284       ELSE
19285         HCS=HCS+FACTR*CQF(1,IQ,JQ)*FLOAT(NCOLO)
19286         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
19287       ENDIF
19288   60  CONTINUE
19289 C Lepton final states
19290       DO 70 JL=JLMN,JLMX
19291       ID3=110+JL
19292       ID4=ID3+6
19293       HCS=HCS+FACTR*CQF(1,IQ,JL)
19294       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
19295   70  CONTINUE
19296   80  CONTINUE
19297   90  CONTINUE
19298       EVWGT=HCS
19299       RETURN
19300 C Generate event
19301   99  IDN(1)=ID1
19302       IDN(2)=ID2
19303       IDCMF=200
19304       IF (ID3.LE.6) THEN
19305         JF=JQ
19306       ELSE
19307         JF=JL
19308       ENDIF
19309 C Select polar angle from distribution:
19310 C CQF(1,IQ,JF)*(ONE+COSTH**2)+CQF(3,IQ,JF)*COSTH+EXTRA*(ONE+COSTH)
19311       IF (ID1.EQ.ID3.OR.ID2.EQ.ID3) THEN
19312         EXTRA=TWO*QFCH(ID3)**4/NCOLO
19313       ELSE
19314         EXTRA=0
19315       ENDIF
19316       PMAX=2.*(CQF(1,IQ,JF)+EXTRA)+ABS(CQF(3,IQ,JF))
19317   100 COSTH=HWRUNI(0,-ONE,ONE)
19318       PTHETA=CQF(1,IQ,JF)*(ONE+COSTH**2)+TWO*CQF(3,IQ,JF)*COSTH
19319      &      +EXTRA*(ONE+COSTH)
19320       IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 100
19321       IF (ID1.GT.ID2) COSTH=-COSTH
19322       IDCMF=200
19323       CALL HWETWO(.TRUE.,.TRUE.)
19324   999 END
19325 CDECK  ID>, HWHDYQ.
19326 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
19327 *-- Author :    Peter Richardson
19328 C-----------------------------------------------------------------------
19329       SUBROUTINE HWHDYQ(FSTCLL,HCS,IFLOW,IDP,ORD,IQ,MASS)
19330 C-----------------------------------------------------------------------
19331 C     Drell-Yan production with a q qbar pair
19332 C-----------------------------------------------------------------------
19333       INCLUDE 'HERWIG65.INC'
19334       INTEGER I,MAP(12),ORD,IFL,IDP(6),IFLOW,QCFL(2,2),GCFL(2),IDZ,IQ
19335       DOUBLE PRECISION HCS,RCS,MQ(2,5),HWRGEN,G(12,2),DIST(2),MG(2)
19336       LOGICAL FSTCLL,MASS
19337       EXTERNAL HWRGEN
19338       DATA MAP/1,2,3,4,5,6,11,12,13,14,15,16/
19339       DATA QCFL/2413,3142,4123,2341/
19340       DATA GCFL/2413,4123/
19341       COMMON/HWHZBC/G
19342       SAVE MQ,MG
19343       IF(GENEV) THEN
19344         RCS = HCS*HWRGEN(1)
19345       ELSE
19346 C--to the initalisation
19347         IF(FSTCLL) THEN
19348 C--G(I,1) is the right charge and G(I,2) is the left charge
19349           DO I=1,12
19350             G(I,1) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
19351             G(I,2) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
19352           ENDDO
19353           FSTCLL = .FALSE.
19354         ENDIF
19355 C--identify the Z decay product
19356         IDZ = IDP(5)
19357         IF(IDZ.GT.6) IDZ = IDZ-114
19358 C--calculate the matrix elements
19359         IF(MASS) THEN
19360 C--massive case
19361           CALL HWH2MQ(IQ,IDZ,MG,MQ)
19362         ELSE
19363 C--massless case
19364           CALL HWH2M0(IQ,IDZ,MG,MQ)
19365         ENDIF
19366       ENDIF
19367 C--multiply the matrix elements by the PDF's to obtain the cross section
19368       HCS = ZERO
19369       IDP(3) = IQ
19370       IDP(4) = IQ+6
19371 C--first the qqbar initial states
19372       DO I=1,5
19373         IDP(1) = I
19374         IDP(2) = IDP(1)+6
19375         DIST(1) = DISF(IDP(1),1)*DISF(IDP(2),2)
19376         DIST(2) = DISF(IDP(1),2)*DISF(IDP(2),1)
19377         DO ORD=1,2
19378           DO IFL=1,2
19379             IFLOW = QCFL(IFL,ORD)
19380             HCS = HCS+DIST(ORD)*MQ(IFL,IDP(1))/36.0D0
19381             IF(GENEV.AND.HCS.GT.RCS) RETURN
19382           ENDDO
19383         ENDDO
19384       ENDDO
19385 C--then the gluon gluon inital state
19386       IDP(1) = 13
19387       IDP(2) = 13
19388       DIST(1) = DISF(IDP(1),1)*DISF(IDP(1),2)
19389       DO IFL=1,2
19390         IFLOW = GCFL(IFL)
19391         HCS = HCS+DIST(1)*MG(IFL)/256.0D0
19392         IF(GENEV.AND.HCS.GT.RCS) RETURN
19393       ENDDO
19394  999  END
19395 CDECK  ID>, HWHEGG.
19396 *CMZ :-        -19/03/92  10.13.56  by  Mike Seymour
19397 *-- Author :    Mike Seymour
19398 C-----------------------------------------------------------------------
19399       SUBROUTINE HWHEGG
19400 C----------------------------------------------------------------------
19401 C     HARD PROCESS: EE --> EEGAMGAM --> EEFFBAR/WW
19402 C     MEAN EVENT WEIGHT = CROSS-SECTION IN NB
19403 C     AFTER CUTS ON PT AND MASS OF CENTRE-OF-MASS SYSTEM
19404 C     AND COS(THETA) IN CENTRE-OF-MASS SYSTEM
19405 C     AND TIMES BRANCHING FRACTION IF WW
19406 C-----------------------------------------------------------------------
19407       INCLUDE 'HERWIG65.INC'
19408       DOUBLE PRECISION HWRGEN,HWULDO,EMSQ,BETA,S,T,U,TMIN,TMAX,TRAT,
19409      & DSDT,PROB,X,Z(2),ZMIN,ZMAX,PCMIN,PCMAX,PCFAC,PLOGMI,PLOGMA,PTCMF,
19410      & Q,PC,BLOG,EMCMIN,EMCMAX,EMLMIN,EMLMAX,WGT(6),RWGT,CV,CA,BR,QT(2),
19411      & QX(2),QY(2),PX,PY,ROOTS,DOT,A,B,C,SHAT,PCF(2),PCM(2),PCMAC,ZZ(2),
19412      & COLFAC
19413       INTEGER I,IGAM,ID,IDL,ID1,ID2,IHEP,JHEP,NADD,NTRY,NQ,JGAM
19414       LOGICAL HWRLOG
19415       EXTERNAL HWRGEN,HWULDO,HWRLOG
19416       SAVE S,BETA,X,ID,NQ,WGT,EMLMIN,EMLMAX,PCFAC,PLOGMA,PLOGMI,SHAT,
19417      &  PCF,PCM,Z,PCMAC,NADD
19418       IF (IERROR.NE.0) RETURN
19419 C---INITIALIZE LOCAL COPIES OF EMMIN,EMMAX
19420       IF (FSTWGT) THEN
19421         EMLMIN=EMMIN
19422         EMLMAX=EMMAX
19423       ENDIF
19424       IF (.NOT.GENEV) THEN
19425 C---CHOOSE Z1,Z2 AND CALCULATE SUB-PROCESS CROSS-SECTION
19426         EVWGT=0
19427 C-----FIND FINAL STATE PARTICLES
19428         IHPRO=MOD(IPROC,100)
19429         IF (IHPRO.EQ.0) THEN
19430           ID=1
19431           NQ=6
19432           COLFAC=FLOAT(NCOLO)
19433           NADD=6
19434         ELSEIF (IHPRO.LE.6) THEN
19435           ID=IHPRO
19436           NQ=1
19437           COLFAC=FLOAT(NCOLO)
19438           NADD=6
19439           Q=QFCH(ID)
19440         ELSEIF (IHPRO.LE.9) THEN
19441           ID=119+2*(IHPRO-6)
19442           NQ=1
19443           COLFAC=1.
19444           NADD=6
19445           Q=QFCH(ID-110)
19446         ELSEIF (IHPRO.LE.10) THEN
19447           ID=198
19448           NQ=1
19449           NADD=1
19450         ELSE
19451           CALL HWWARN('HWHEGG',200,*999)
19452         ENDIF
19453 C-----SPLIT ELECTRONS TO PHOTONS
19454         NHEP=3
19455         GAMWT=1
19456         S=2*HWULDO(PHEP(1,1),PHEP(1,2))
19457         ROOTS=SQRT(S)
19458         EMCMIN=MAX(EMLMIN,MAX(2*RMASS(ID),PTMIN))
19459         EMCMAX=MIN(EMLMAX,ROOTS)
19460         IF (EMCMIN.GT.EMCMAX) RETURN
19461         ZMIN=EMCMIN**2/S
19462         ZMAX=1-PHEP(5,1)/PHEP(4,1)
19463         IF (ZMIN.GT.ZMAX) RETURN
19464         CALL HWEGAM(1,ZMIN,ZMAX,.TRUE.)
19465         Z(1)=PHEP(4,NHEP-1)/PHEP(4,1)
19466         ZMIN=EMCMIN**2/(Z(1)*S)
19467         ZMAX=MIN(EMCMAX**2/(Z(1)*S), ONE-PHEP(5,2)/PHEP(4,2))
19468         IF (ZMIN.GT.ZMAX) RETURN
19469         CALL HWEGAM(2,ZMIN,ZMAX,.TRUE.)
19470         Z(2)=PHEP(4,NHEP-1)/PHEP(4,2)
19471         EMSCA=PHEP(5,3)
19472         SHAT=EMSCA**2
19473 C-----REMOVE LOG TERMS FROM WEIGHT, CALCULATE NEW ONES FROM PT LIMITS
19474         GAMWT=GAMWT/(0.5*LOG((1-Z(1))*S/(Z(1)*PHEP(5,1)**2))
19475      &              *0.5*LOG((1-Z(2))*Z(1)*S/(Z(2)*PHEP(5,2)**2)))
19476         PCF(1)=Z(1)*PHEP(5,1)
19477         PCF(2)=Z(2)*PHEP(5,2)
19478         PCFAC=SQRT(PCF(1)*PCF(2))
19479         PCM(1)=(1-Z(1))*PHEP(4,1)
19480         PCM(2)=(1-Z(2))*PHEP(4,2)
19481         PCMAC=SQRT(PCM(1)*PCM(2))
19482         PCMIN=MAX(PTMIN,MAX(PCF(1),PCF(2)))
19483         PCMAX=MIN( MIN(PTMAX,PHEP(5,3)) , MIN(PCM(1),PCM(2)) )
19484         IF (PCMIN.GT.PCMAX) RETURN
19485         PLOGMI=(LOG(PCMIN/PCFAC))**2
19486         PLOGMA=(LOG(PCMAX/PCFAC))**2
19487         GAMWT=GAMWT*(PLOGMA-PLOGMI)
19488 C-----CALCULATE CROSS-SECTION
19489         DO 10 IDL=1,NQ
19490           WGT(IDL)=EVWGT
19491           IF (IHPRO.EQ.0) THEN
19492             ID=IDL
19493             Q=QFCH(ID)
19494           ENDIF
19495           EMSQ=RMASS(ID)**2
19496           X=4*EMSQ/SHAT
19497           IF (X.GT.ONE) GOTO 10
19498           BETA=SQRT(1-X)
19499           BLOG=LOG((1+BETA*CTMAX)/(1-BETA*CTMAX))/BETA
19500           IF (IHPRO.LE.9) THEN
19501             EVWGT=EVWGT+GEV2NB*4*PIFAC*COLFAC*Q**4*ALPHEM**2*BETA
19502      &           /SHAT * GAMWT * ( (1+X-0.5*X**2)*BLOG
19503      &                     - CTMAX*(1+X**2/(CTMAX**2*(X-1)+1)) )
19504             WGT(IDL)=EVWGT
19505           ELSE
19506             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
19507             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
19508             EVWGT=EVWGT + GEV2NB*6*PIFAC*ALPHEM**2*BETA/SHAT*BR
19509      &        * GAMWT * (-(  X-0.5*X**2)*BLOG
19510      &                     + CTMAX*(1+(X**2+16/3.)/(CTMAX**2*(X-1)+1)) )
19511           ENDIF
19512  10     CONTINUE
19513 C-----GAMWT MUST BE RESET TO ONE, SINCE IT IS REAPPLIED LATER!
19514         GAMWT=ONE
19515       ELSE
19516 C---GENERATE EVENT
19517 C-----CHOOSE PT OF THE CMF
19518         PTCMF=PCFAC*EXP(SQRT(HWRGEN(0)*(PLOGMA-PLOGMI)+PLOGMI))
19519 C-----CHOOSE WHICH PHOTON USUALLY HAS SMALLER PT
19520         NTRY=0
19521  20     IGAM=1
19522         IF (LOG(PCM(1)/PCF(1)).LT.HWRGEN(1)*2*LOG(PCMAC/PCFAC)) IGAM=2
19523         JGAM=3-IGAM
19524 C-----CHOOSE ITS PT
19525  30     NTRY=NTRY+1
19526         IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',100,*999)
19527         QT(IGAM)=(PCM(IGAM)/PCF(IGAM))**HWRGEN(2)
19528         PROB=(QT(IGAM)**2/(QT(IGAM)**2+1))**2
19529         QT(IGAM)=QT(IGAM)*PCF(IGAM)
19530         IF (HWRLOG(1-PROB)) GOTO 30
19531 C-----CHOOSE ITS DIRECTION
19532         CALL HWRAZM(QT(IGAM),QX(IGAM),QY(IGAM))
19533 C-----CALCULATE THE OTHER PHOTON'S PT
19534         QX(JGAM)=PTCMF-QX(IGAM)
19535         QY(JGAM)=     -QY(IGAM)
19536         QT(JGAM)=SQRT(QX(JGAM)**2+QY(JGAM)**2)
19537         IF (QT(JGAM).LT.PCF(JGAM).OR.QT(JGAM).GT.PCM(JGAM)) GOTO 20
19538 C-----APPLY A RANDOM ROTATION AROUND THE BEAM AXIS
19539         CALL HWRAZM(ONE,PX,PY)
19540         IF (PX.EQ.ZERO) PX=1D-20
19541         QX(1)=(QX(1)*PX   -QY(1)*PY)
19542         QY(1)=(QY(1)      +QX(1)*PY)/PX
19543         QX(2)=(QX(2)*PX   -QY(2)*PY)
19544         QY(2)=(QY(2)      +QX(2)*PY)/PX
19545 C-----RECONSTRUCT MOMENTA
19546         IF (QT(IGAM).GT.QT(JGAM)) THEN
19547           IGAM=3-IGAM
19548           JGAM=3-JGAM
19549         ENDIF
19550         DOT=-Z(JGAM)*S+SHAT+2*(QX(1)*QX(2)+QY(1)*QY(2))
19551 C-------SOLVE QUADRATIC IN Z(IGAM) TO FIND ELECTRON ENERGIES
19552         A=S*(S*Z(JGAM)+QT(JGAM)**2)
19553         B=S*DOT*(1+Z(JGAM))
19554         C=DOT**2+S*QT(IGAM)**2*(1-Z(JGAM))**2-4*QT(IGAM)**2*QT(JGAM)**2
19555         IF (B**2.LT.4*A*C) GOTO 20
19556         ZZ(IGAM)=(-B+SQRT(B**2-4*A*C))/(2*A)
19557         IF (ZZ(IGAM).LT.ZERO .OR. ZZ(IGAM).GT.ONE-Z(IGAM)) GOTO 20
19558         ZZ(JGAM)=1-Z(JGAM)
19559 C-------REJECT AGAINST PHOTON DISTRIBUTION FUNCTION
19560         PROB=((1+ZZ(IGAM)**2)/(1-ZZ(IGAM)))/((1+(1-Z(IGAM))**2)/Z(IGAM))
19561      &      *((1+ZZ(JGAM)**2)/(1-ZZ(JGAM)))/((1+(1-Z(JGAM))**2)/Z(JGAM))
19562         IF (HWRLOG(1-PROB)) GOTO 20
19563 C-------RECONSTRUCT ALL OTHER VARIABLES
19564         DO 40 I=1,2
19565           IGAM=2*I+3
19566           PHEP(1,IGAM)=QX(I)
19567           PHEP(2,IGAM)=QY(I)
19568           PHEP(4,IGAM)=ZZ(I)*PHEP(4,I)
19569           PHEP(5,IGAM)=RMASS(IDHW(IGAM))
19570 C---------IF MOMENTUM CANNOT BE CONSERVED TRY AGAIN
19571           IF (PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-QT(I)**2 .LT. 0) GOTO 20
19572           PHEP(3,IGAM)=SIGN(SQRT(PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-
19573      &      QT(I)**2),PHEP(3,IGAM))
19574           CALL HWVDIF(4,PHEP(1,I),PHEP(1,IGAM),PHEP(1,IGAM-1))
19575           CALL HWUMAS(PHEP(1,IGAM-1))
19576  40     CONTINUE
19577 C-----TIDY UP EVENT RECORD
19578         NHEP=NHEP+1
19579         IDHW(NHEP)=IDHW(3)
19580         IDHEP(NHEP)=IDHEP(3)
19581         ISTHEP(NHEP)=110
19582         CALL HWVSUM(4,PHEP(1,4),PHEP(1,6),PHEP(1,NHEP))
19583         CALL HWVSUM(4,PHEP(1,1),PHEP(1,2),PHEP(1,3))
19584         CALL HWUMAS(PHEP(1,NHEP))
19585         CALL HWUMAS(PHEP(1,3))
19586         JMOHEP(1,NHEP)=4
19587         JMOHEP(2,NHEP)=6
19588         JMOHEP(1,3)=0
19589         JMOHEP(2,3)=0
19590 C-----CHOOSE FINAL STATE QUARK
19591         IF (IHPRO.EQ.0) THEN
19592           RWGT=HWRGEN(2)*EVWGT
19593           ID=1
19594           DO 50 IDL=1,NQ
19595             IF (RWGT.GT.WGT(IDL)) ID=IDL+1
19596  50       CONTINUE
19597           EMSQ=RMASS(ID)**2
19598           X=4*EMSQ/SHAT
19599           BETA=SQRT(1-X)
19600         ENDIF
19601 C-----CHOOSE T (WHERE T = MANDELSTAM_T - EMSQ)
19602         TMIN=-SHAT/2
19603         TMAX=-SHAT/2*(1-BETA*CTMAX)
19604         TRAT=TMAX/TMIN
19605         NTRY=0
19606         IF (IHPRO.LE.9) THEN
19607 C-------FOR FFBAR, CHOOSE T ACCORDING TO -SHAT/T
19608  60       NTRY=NTRY+1
19609           IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',101,*999)
19610           T=TRAT**HWRGEN(3)*TMIN
19611           U=-T-SHAT
19612 C-------REWEIGHT TO CORRECT DISTRIBUTION
19613           DSDT=(T*U-2*EMSQ*(T+2*EMSQ))/T**2
19614      &        +( 2*EMSQ*(SHAT-4*EMSQ))/(T*U)
19615      &        +(T*U-2*EMSQ*(U+2*EMSQ))/U**2
19616           PROB=-DSDT*T/SHAT / (1 + 2*X - 2*X**2)
19617           IF (HWRLOG(1-PROB)) GOTO 60
19618         ELSE
19619 C-------FOR WW, CHOOSE T ACCORDING TO (SHAT/T)**2
19620  70       NTRY=NTRY+1
19621           IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',102,*999)
19622           T=TMAX/(1-(1-TRAT)*HWRGEN(4))
19623           U=-T-SHAT
19624 C-------REWEIGHT TO CORRECT DISTRIBUTION
19625           DSDT=( 3*(T*U)**2 - SHAT*T*U*(4*SHAT+6*EMSQ)
19626      &      + SHAT**2*(2*SHAT**2+6*EMSQ**2) ) / (T*U)**2
19627           PROB=DSDT*(T/SHAT)**2 / (4.75 - 1.5*X + 1.5*X**2)
19628           IF (HWRLOG(1-PROB)) GOTO 70
19629         ENDIF
19630 C-----SYMMETRIZE IN T,U
19631         IF (HWRLOG(HALF)) T=U
19632 C-----FILL EVENT RECORD
19633         COSTH=(1+2*T/SHAT)/BETA
19634         PC=0.5*BETA*PHEP(5,NHEP)
19635         PHEP(5,NHEP+1)=RMASS(ID)
19636         PHEP(5,NHEP+2)=RMASS(ID)
19637         CALL HWDTWO(PHEP(1,NHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
19638      &              PC,COSTH,.TRUE.)
19639         DO 80 I=1,2
19640           IHEP=NHEP+I
19641           JHEP=NHEP+3-I
19642           ISTHEP(IHEP)=190
19643           IF (IHPRO.LE.6) ISTHEP(IHEP)=112+I
19644           IDHW(IHEP)=ID+NADD*(I-1)
19645           IDHEP(IHEP)=IDPDG(IDHW(IHEP))
19646           JDAHEP(I,NHEP)=IHEP
19647           JMOHEP(1,IHEP)=NHEP
19648           JMOHEP(2,IHEP)=JHEP
19649           JDAHEP(2,IHEP)=JHEP
19650           IF (IHPRO.EQ.10) THEN
19651             RHOHEP(1,IHEP)=0.3333
19652             RHOHEP(2,IHEP)=0.3333
19653             RHOHEP(3,IHEP)=0.3333
19654           ENDIF
19655  80     CONTINUE
19656         NHEP=NHEP+2
19657       ENDIF
19658  999  END
19659 CDECK  ID>, HWHEGW.
19660 *CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
19661 *-- Author :    Mike Seymour
19662 C-----------------------------------------------------------------------
19663       SUBROUTINE HWHEGW
19664 C----------------------------------------------------------------------
19665 C     W + GAMMA --> FF'BAR :  MEAN EVWGT = CROSS SECTION IN NANOBARN
19666 C     BASED ON BOSON GLUON FUSION OF ABBIENDI AND STANCO
19667 C-----------------------------------------------------------------------
19668       INCLUDE 'HERWIG65.INC'
19669       DOUBLE PRECISION HWRGEN,GMASS,EV(3),RV,Y,Q2,SHAT,Z,PHI,AJACOB,
19670      & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT
19671       INTEGER LEP
19672       INTEGER LEPFIN,ID1,ID2,I,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO
19673       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
19674       EXTERNAL HWRGEN
19675       SAVE LEPFIN,ID1,ID2
19676       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
19677      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
19678      & IPROO,CHARGD,INCLUD,INSIDE
19679       IQK=MOD(IPROC,10)
19680       CHARGD=.TRUE.
19681       IF(GENEV) THEN
19682 C
19683         IDHW(4)=IDHW(1)
19684         IDHW(5)=59
19685         IDHW(6)=15
19686         IDHW(7)=LEPFIN
19687         IDHW(8)=ID1
19688         IDHW(9)=ID2
19689         DO 1 I=4,9
19690     1   IDHEP(I)=IDPDG(IDHW(I))
19691 C
19692         IFLAVD=ID1
19693         IFLAVU=ID2-6
19694 C
19695         ISTHEP(4)=111
19696         ISTHEP(5)=112
19697         ISTHEP(6)=110
19698         ISTHEP(7)=113
19699         ISTHEP(8)=114
19700         ISTHEP(9)=114
19701 C
19702         JMOHEP(1,4)=6
19703         JMOHEP(2,4)=7
19704         JMOHEP(1,5)=6
19705         JMOHEP(2,5)=5
19706         JMOHEP(1,6)=4
19707         JMOHEP(2,6)=5
19708         JMOHEP(1,7)=6
19709         JMOHEP(2,7)=4
19710         JMOHEP(1,8)=6
19711         JMOHEP(2,8)=9
19712         JMOHEP(1,9)=6
19713         JMOHEP(2,9)=8
19714         JDAHEP(1,4)=0
19715         JDAHEP(2,4)=7
19716         JDAHEP(1,5)=0
19717         JDAHEP(2,5)=5
19718         JDAHEP(1,6)=7
19719         JDAHEP(2,6)=9
19720         JDAHEP(1,7)=0
19721         JDAHEP(2,7)=4
19722         JDAHEP(1,8)=0
19723         JDAHEP(2,8)=9
19724         JDAHEP(1,9)=0
19725         JDAHEP(2,9)=8
19726 C---COMPUTATION OF MOMENTA IN LABORATORY FRAME OF REFERENCE
19727 C---Persuade HWHBKI that the gluon is actually a photon...
19728         GMASS=RMASS(13)
19729         RMASS(13)=0
19730         CALL HWHBKI
19731         RMASS(13)=GMASS
19732 C---put the other outgoing lepton in as well
19733         IDHW(10)=IDHW(2)
19734         IDHEP(10)=IDPDG(IDHW(10))
19735         ISTHEP(10)=1
19736         JMOHEP(1,10)=2
19737         JMOHEP(2,10)=0
19738         JDAHEP(1,10)=0
19739         JDAHEP(2,10)=0
19740         JDAHEP(1,2)=5
19741         JDAHEP(2,2)=10
19742         CALL HWVDIF(4,PHEP(1,2),PHEP(1,5),PHEP(1,10))
19743         CALL HWUMAS(PHEP(1,10))
19744         NHEP=10
19745 C
19746 C---if antilepton was first, do charge conjugation
19747         IF (LEP.EQ.-1) THEN
19748           DO 27 I=7,9
19749             IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
19750               IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
19751               IDHEP(I)=-IDHEP(I)
19752             ENDIF
19753  27       CONTINUE
19754         ENDIF
19755 C
19756 C---half the time, do charge conjugation and parity flip
19757         IF (HWRGEN(0).GT.HALF) THEN
19758           DO 2 I=4,10
19759             IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
19760               IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
19761               IDHEP(I)=-IDHEP(I)
19762             ENDIF
19763             PHEP(1,I)=-PHEP(1,I)
19764             PHEP(2,I)=-PHEP(2,I)
19765             PHEP(3,I)=-PHEP(3,I)
19766  2        CONTINUE
19767           JMOHEP(1,10)=3-JMOHEP(1,10)
19768         ENDIF
19769 C
19770       ELSE
19771 C
19772         EVWGT=ZERO
19773 C---LEP = 1 IF TRACK 1 IS A LEPTON, -1 FOR ANTILEPTON
19774         LEP=0
19775         IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
19776           LEP=1
19777         ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
19778           LEP=-1
19779         ENDIF
19780         IF (LEP.EQ.0) CALL HWWARN('HWHEGW',500,*999)
19781 C---program only works if beam and target are charge conjugates
19782         IF (LEP*(IDHW(2)-IDHW(1)).NE.6)
19783      &   CALL HWWARN('HWHEGW',501,*999)
19784 C---program only works for equal energy beams colliding
19785         IF (PHEP(3,3).NE.ZERO) CALL HWWARN('HWHEGW',503,*999)
19786 C
19787 C---FINAL STATE IS ALWAYS SET UP AS IF PARTICLE IS BEFORE ANTI-PARTICLE
19788 C   AND THEN INVERTED IF NECESSARY
19789         LEPFIN = MIN(IDHW(1),IDHW(2))+1
19790         IF (IQK.LE.2) THEN
19791           IFLAVU=2
19792           IFLAVD=1
19793           ID1  = 1
19794           ID2  = 8
19795         ELSEIF (IQK.LE.4) THEN
19796           IFLAVU=4
19797           IFLAVD=3
19798           ID1  = 3
19799           ID2  =10
19800         ELSEIF (IQK.LE.6) THEN
19801           IFLAVU=6
19802           IFLAVD=5
19803           ID1  = 5
19804           ID2  =12
19805         ELSEIF (IQK.EQ.7) THEN
19806           IFLAVU=122
19807           IFLAVD=121
19808           ID1  = 121
19809           ID2  = 128
19810 C---INTERFERENCE TERMS IN EE -> EE NUE NUEB  NEGLECTED: SIGMA UNRELIABLE
19811           IF (FSTWGT) CALL HWWARN('HWHEGW',1,*999)
19812         ELSEIF (IQK.EQ.8) THEN
19813           IFLAVU=124
19814           IFLAVD=123
19815           ID1  = 123
19816           ID2  = 130
19817         ELSEIF (IQK.EQ.9) THEN
19818           IFLAVU=126
19819           IFLAVD=125
19820           ID1  = 125
19821           ID2  = 132
19822         ELSE
19823           CALL HWWARN('HWHEGW',504,*999)
19824         ENDIF
19825         IF (IQK.GT.0) THEN
19826           IF (IQK.LE.6) IQK=0
19827           CALL HWHBRN(*999)
19828           CALL HWHEGX
19829           EVWGT = 2 * DSIGMA * AJACOB
19830           IF (EVWGT.LT.ZERO) EVWGT=ZERO
19831         ELSE
19832 C---SUM OVER QUARK FLAVOURS
19833           CALL HWHBRN(*999)
19834           DO 3 I=1,3
19835             IF (SHAT.GT.(RMASS(IFLAVD)+RMASS(IFLAVU))**2) THEN
19836               CALL HWHEGX
19837               EV(I) = 2 * DSIGMA * AJACOB
19838               IF (EV(I).LT.ZERO) EV(I)=ZERO
19839             ELSE
19840               EV(I)=ZERO
19841             ENDIF
19842             EVWGT=EVWGT+EV(I)
19843             EV(I)=EVWGT
19844             IFLAVU=IFLAVU+2
19845             IFLAVD=IFLAVD+2
19846  3        CONTINUE
19847 C---CHOOSE QUARK FLAVOUR
19848           RV=EV(3)*HWRGEN(1)
19849           IF (RV.LT.EV(1)) THEN
19850             ID1 = 1
19851             ID2 = 8
19852           ELSEIF (RV.LT.EV(2)) THEN
19853             ID1 = 3
19854             ID2 =10
19855           ELSE
19856             ID1 = 5
19857             ID2 =12
19858           ENDIF
19859         ENDIF
19860       ENDIF
19861   999 END
19862 CDECK  ID>, HWHEGX.
19863 *CMZ :-        -17/07/92  16.42.56  by  Mike Seymour
19864 *-- Author :    Mike Seymour
19865 C-----------------------------------------------------------------------
19866       SUBROUTINE HWHEGX
19867 C-----------------------------------------------------------------------
19868 C     COMPUTES DIFFERENTIAL CROSS SECTION DSIGMA IN (Y,Q2,ETA,Z,PHI)
19869 C-----------------------------------------------------------------------
19870       INCLUDE 'HERWIG65.INC'
19871       DOUBLE PRECISION TMAX,TMIN,A1,A2,B1,B2,I0,I1,I2,I3,I4,I5,MUSQ,
19872      & MDSQ,ETA,Q1,COSTHE,S,G,T,U,C1,C2,D1,D2,F1,F2,COSBET,WPROP,D(4,4),
19873      & C(4,4),QU,QD,QE,QW,PHOTON,EMWSQ,EMSSQ,CFAC,Y,Q2,SHAT,Z,PHI,
19874      & AJACOB,DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,
19875      & RSHAT
19876       INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,J,LEP
19877       LOGICAL CHARGD,INCLUD(18),INSIDE(18)
19878       COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
19879      & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
19880      & IPROO,CHARGD,INCLUD,INSIDE
19881 C---INPUT VARIABLES
19882       IF (IERROR.NE.0) RETURN
19883       DSIGMA=0
19884       IF (IFLAVU.LE.12) THEN
19885         QU=QFCH(MOD(IFLAVU-1,6)+1)
19886         QD=QFCH(MOD(IFLAVD-1,6)+1)
19887         CFAC=CAFAC
19888       ELSE
19889         QU=QFCH(MOD(IFLAVU-1,6)+11)
19890         QD=QFCH(MOD(IFLAVD-1,6)+11)
19891         CFAC=1
19892       ENDIF
19893       QE=QFCH(11)
19894       QW=+1
19895       EMWSQ=RMASS(198)**2
19896       EMSCA=PHEP(5,3)
19897       EMSSQ=EMSCA**2
19898       MUSQ=RMASS(IFLAVU)**2
19899       MDSQ=RMASS(IFLAVD)**2
19900       ETA=(SHAT+Q2)/EMSSQ/Y
19901       IF (ETA.GT.ONE) RETURN
19902 C---CALCULATE KINEMATIC TERMS
19903       G=0.5*(ETA*EMSSQ*Y-Q2) -0.5*(MUSQ+MDSQ)
19904       S=0.5*ETA*EMSSQ
19905       T=0.5*ETA*EMSSQ*(1-Y)
19906       U=0.5*Q2
19907       C1=0.5*ETA*EMSSQ*Y*Z
19908       C2=0.5*ETA*EMSSQ*Y*(1-Z)
19909       COSBET=(-ETA*EMSSQ*Y+Q2*(2-Y))/(Y*(ETA*EMSSQ-Q2))
19910       IF (SHAT.LE.(RMASS(IFLAVU)+RMASS(IFLAVD))**2) RETURN
19911       Q1=SQRT((SHAT**2+MUSQ**2+MDSQ**2
19912      &  -2*SHAT*MUSQ-2*SHAT*MDSQ-2*MUSQ*MDSQ)/SHAT**2)
19913       COSTHE=(1+(MDSQ-MUSQ)/SHAT-2*Z)/Q1
19914       IF (ABS(COSTHE).GE.ONE .OR. ABS(COSBET).GE.ONE) RETURN
19915       D1=0.25*(ETA*EMSSQ-Q2)*(1+(MDSQ-MUSQ)/SHAT-Q1*
19916      &     (COSTHE*COSBET+SQRT((1-COSTHE**2)*(1-COSBET**2))*COS(PHI)))
19917       D2=S-U-D1
19918       F1=D1+C1-G            -MDSQ
19919       F2=U+T-F1
19920 C---CALCULATE TRACE TERMS
19921       CALL HWVZRO(16,D)
19922       CALL HWVZRO(16,C)
19923       D(1,1)=2*F1*C2*S
19924       D(2,2)=2*C1*D2*T
19925       D(3,3)=-D1*(2*F2*G-D2*(F1+2*U))
19926      &       -D2*F1*(F2+U-D2+F1)
19927      &       +2*F1*F2*U
19928      &       -G*(-2*D1*(F1+F2+U)-F1*(D2+2*U)+2*D2*(U-F2)+2*U*(F2-U+G))
19929       D(4,4)=2*F1*C2*S
19930       D(1,2)=(D1+U-F2)*(D1*F2-F1*D2)-G*(D1*(F2+U)+U*(U-F2-G)+F1*D2)
19931       D(1,3)=D1*F2*(-2*F1+U-F2+D1)
19932      &      +F1*(F2*(D2-2*U)+F1*D2)
19933      &      +G*(-D1*(2*F1+F2+U)-F1*(D2+2*U)+U*(F2-U+G))
19934       D(1,4)=-2*F1*(D1+U)*(F2+G)
19935       D(2,3)=D1*(D2*(F1+2*(U-F2))+F2*(F2-U-D1))
19936      &      +F1*D2**2
19937      &      +G*(D1*(F2+U)+D2*(F1-2*(U-F2))+U*(U-F2-G))
19938       D(2,4)=-D1*F2*(U-F2+D1)
19939      &       -F1*D2*(U-D1-G-F2)
19940      &       -G*(U*(F2-U+G)-D1*(F2+U))
19941       D(3,4)=D1*(F1*(D2+2*F2)+F2*(F2-U-D1))
19942      &      +F1*(2*F2*U-D2*(U+F1))
19943      &      +G*(D1*(2*F1+F2+U)+U*(2*F1-F2+U-G))
19944 C---REGULATE PROPAGATORS
19945       TMAX=EMSSQ-2*G
19946       TMIN=PHEP(5,2)**2
19947       A1=2*C1+MDSQ*(G+U)/G
19948       A2=2*C2+MUSQ*(G+U)/G
19949       B1=(2*U+MUSQ)/(2*G+2*U)
19950       B2=(2*U+MDSQ)/(2*G+2*U)
19951       I0=LOG(TMAX/TMIN)
19952       I1=1/A1*(I0-LOG((A1+B1*TMAX)/(A1+B1*TMIN)))
19953       I2=1/A2*(I0-LOG((A2+B2*TMAX)/(A2+B2*TMIN)))
19954       I3=(B1*I1-B2*I2)/(B1*A2-B2*A1)
19955       I4=1/A1*(I1+1/(A1+B1*TMAX)-1/(A1+B1*TMIN))
19956       I5=1/A2*(I2+1/(A2+B2*TMAX)-1/(A2+B2*TMIN))
19957       WPROP=1/((2*G-EMWSQ)**2+GAMW**2*EMWSQ)
19958 C---CALCULATE COEFFICIENTS
19959       C(1,1)=    QU**2/(2*U+EMWSQ)**2                       *I5
19960       C(2,2)=    QD**2/(2*U+EMWSQ)**2                       *I4
19961       C(3,3)=    QW**2/(2*U+EMWSQ)**2    *WPROP             *I0
19962       C(4,4)=    QE**2/(2*S)**2          *WPROP             *I0
19963       C(1,2)=  2*QU*QD/(2*U+EMWSQ)**2                       *I3
19964       C(1,3)=  2*QW*QU/(2*U+EMWSQ)**2    *WPROP*(2*G-EMWSQ) *I2
19965       C(1,4)=  2*QU*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I2
19966       C(2,3)=  2*QW*QD/(2*U+EMWSQ)**2    *WPROP*(2*G-EMWSQ) *I1
19967       C(2,4)=  2*QD*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I1
19968       C(3,4)=  2*QW*QE/(2*S*(2*U+EMWSQ)) *WPROP             *I0
19969 C---CALCULATE PHOTON STRUCTURE FUNCTION
19970       PHOTON=ALPHEM * (1+(1-ETA)**2) / (2*PIFAC*ETA)
19971 C---SUM ALL TENSOR CONTRIBUTIONS
19972       DO 10 I=1,4
19973       DO 10 J=1,4
19974  10     DSIGMA=DSIGMA + C(I,J)*D(I,J)
19975 C---CALCULATE TOTAL SUMMED AND AVERAGED MATRIX ELEMENT SQUARED
19976       DSIGMA = DSIGMA * 2*CFAC*(4*PIFAC*ALPHEM)**3/SWEIN**2
19977 C---CALCULATE DIFFERENTIAL CROSS-SECTION
19978       DSIGMA = DSIGMA * GEV2NB*PHOTON/(512*PIFAC**4*ETA*EMSSQ)
19979  999  END
19980 CDECK  ID>, HWHEPA.
19981 *CMZ :-        -12/10/01  10.05.16  by  Peter Richardson
19982 *-- Author :    Bryan Webber and Ian Knowles
19983 C-----------------------------------------------------------------------
19984       SUBROUTINE HWHEPA
19985 C-----------------------------------------------------------------------
19986 C     (Initially polarised) e+e- --> ffbar (f=quark, mu or tau)
19987 C     If IPROC=107: --> gg, distributed as sum of light quarks.
19988 C     If fermion flavour specified mass effects fully included.
19989 C     EVWGT=sig(e+e- --> ffbar) in nb
19990 C-----------------------------------------------------------------------
19991       INCLUDE 'HERWIG65.INC'
19992       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUAEM,Q2NOW,Q2LST,FACTR,
19993      & VF2,VF,CLF(7),PRAN,PQWT,PMAX,PTHETA,SINTH2,CPHI,SPHI,C2PHI,S2PHI,
19994      & PPHI,SINTH,PCM,PP(5),EWGT
19995       INTEGER ID1,ID2,IDF,IQ,IQ1,I
19996       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUAEM
19997       SAVE Q2LST,FACTR,ID1,ID2,VF2,VF,CLF,EWGT
19998       DATA Q2LST/0.D0/
19999       IF (GENEV) THEN
20000         IF (ID2.EQ.0) THEN
20001 C Choose quark flavour
20002           PRAN=TQWT*HWRGEN(0)
20003           PQWT=0.
20004           DO 10 IQ=1,MAXFL
20005           PQWT=PQWT+CLQ(1,IQ)
20006           IF (PQWT.GT.PRAN) GOTO 11
20007    10     CONTINUE
20008           IQ=MAXFL
20009    11     IQ1=MAPQ(IQ)
20010           DO 20 I=1,7
20011    20     CLF(I)=CLQ(I,IQ)
20012         ELSE
20013           IQ1=ID1
20014         ENDIF
20015 C Label particles, assign outgoing particle masses
20016         IDHW(NHEP+1)=200
20017         IDHEP(NHEP+1)=23
20018         ISTHEP(NHEP+1)=110
20019         IF (ID1.EQ.7) THEN
20020           IDHW(NHEP+2)=13
20021           IDHW(NHEP+3)=13
20022           IDHEP(NHEP+2)=21
20023           IDHEP(NHEP+3)=21
20024           PHEP(5,NHEP+2)=RMASS(13)
20025           PHEP(5,NHEP+3)=RMASS(13)
20026         ELSE
20027           IDHW(NHEP+2)=IQ1
20028           IDHW(NHEP+3)=IQ1+6
20029           IDHEP(NHEP+2)=IDPDG(IQ1)
20030           IDHEP(NHEP+3)=-IDHEP(NHEP+2)
20031           PHEP(5,NHEP+2)=RMASS(IQ1)
20032           PHEP(5,NHEP+3)=RMASS(IQ1)
20033         ENDIF
20034         ISTHEP(NHEP+2)=113
20035         ISTHEP(NHEP+3)=114
20036         JMOHEP(1,NHEP+1)=1
20037         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20038         JMOHEP(2,NHEP+1)=2
20039         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20040         JMOHEP(1,NHEP+2)=NHEP+1
20041         JMOHEP(2,NHEP+2)=NHEP+3
20042         JMOHEP(1,NHEP+3)=NHEP+1
20043         JMOHEP(2,NHEP+3)=NHEP+2
20044         JDAHEP(1,NHEP+1)=NHEP+2
20045         JDAHEP(2,NHEP+1)=NHEP+3
20046         JDAHEP(1,NHEP+2)=0
20047         JDAHEP(2,NHEP+2)=NHEP+3
20048         JDAHEP(1,NHEP+3)=0
20049         JDAHEP(2,NHEP+3)=NHEP+2
20050 C Generate polar and azimuthal angular distributions:
20051 C  CLF(1)*(1+(VF*COSTH)**2)+CLF(2)*(1-VF**2)+CLF(3)*2.*VF*COSTH
20052 C +(VF*SINTH)**2*(CLF(4)*COS(2*PHI-PHI1-PHI2)
20053 C                +CLF(6)*SIN(2*PHI-PHI1-PHI2))
20054         PMAX=CLF(1)*(1.+VF2)+CLF(2)*(1.-VF2)+ABS(CLF(3))*2.*VF
20055   30    COSTH=HWRUNI(0,-ONE, ONE)
20056         PTHETA=CLF(1)*(1.+VF2*COSTH**2)+CLF(2)*(1.-VF2)
20057      &        +CLF(3)*2.*VF*COSTH
20058         IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 30
20059         IF (IDHW(1).GT.IDHW(2)) COSTH=-COSTH
20060         SINTH2=1.-COSTH**2
20061         IF (TPOL) THEN
20062           PMAX=PTHETA+VF2*SINTH2*SQRT(CLF(4)**2+CLF(6)**2)
20063   40      CALL HWRAZM(ONE,CPHI,SPHI)
20064           C2PHI=2.*CPHI**2-1.
20065           S2PHI=2.*CPHI*SPHI
20066           PPHI=PTHETA+(CLF(4)*(C2PHI*COSS+S2PHI*SINS)
20067      &                +CLF(6)*(S2PHI*COSS-C2PHI*SINS))*VF2*SINTH2
20068           IF (PPHI.LT.PMAX*HWRGEN(1)) GOTO 40
20069         ELSE
20070           CALL HWRAZM(ONE,CPHI,SPHI)
20071         ENDIF
20072 C Construct final state 4-mommenta
20073         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20074         PCM=HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20075 C PP is momentum of track NHEP+2 in CoM (track NHEP+1) frame
20076         SINTH=SQRT(SINTH2)
20077         PP(5)=PHEP(5,NHEP+2)
20078         PP(1)=PCM*SINTH*CPHI
20079         PP(2)=PCM*SINTH*SPHI
20080         PP(3)=PCM*COSTH
20081         PP(4)=SQRT(PCM**2+PP(5)**2)
20082         CALL HWULOB(PHEP(1,NHEP+1),PP(1),PHEP(1,NHEP+2))
20083         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
20084 C Set production vertices
20085         CALL HWVZRO(4,VHEP(1,NHEP+2))
20086         CALL HWVEQU(4,VHEP(1,NHEP+2),VHEP(1,NHEP+3))
20087         NHEP=NHEP+3
20088       ELSE
20089         EMSCA=PHEP(5,3)
20090         Q2NOW=EMSCA**2
20091         IF (Q2NOW.NE.Q2LST) THEN
20092 C Calculate coefficients for cross-section
20093           EMSCA=PHEP(5,3)
20094           Q2LST=Q2NOW
20095           FACTR=PIFAC*GEV2NB*HWUAEM(Q2NOW)**2/Q2NOW
20096           ID1=MOD(IPROC,10)
20097           ID2=MOD(ID1,7)
20098           IF (ID2.EQ.0) THEN
20099             CALL HWUEEC(1)
20100             VF2=1.
20101             VF=1.
20102             EWGT=FACTR*FLOAT(NCOLO)*TQWT*4./3.
20103           ELSE
20104             IF (IPROC.LT.150) THEN
20105               IDF=ID1
20106               FACTR=FACTR*FLOAT(NCOLO)
20107             ELSE
20108               ID1=2*ID1+119
20109               IDF=ID1-110
20110             ENDIF
20111             IF (EMSCA.LE.2.*RMASS(ID1)) then
20112               EWGT=0.
20113             ELSE
20114               CALL HWUCFF(11,IDF,Q2NOW,CLF(1))
20115               VF2=1.-4.*RMASS(ID1)**2/Q2NOW
20116               VF=SQRT(VF2)
20117               EWGT=FACTR*VF*(CLF(1)*(1.+VF2/3.)+CLF(2)*(1.-VF2))
20118             ENDIF
20119           ENDIF
20120         ENDIF
20121         EVWGT=EWGT
20122       ENDIF
20123   999 END
20124 CDECK  ID>, HWHEPG.
20125 *CMZ :-        -02/05/91  10.57.27  by  Federico Carminati
20126 *-- Author :    Bryan Webber and Ian Knowles
20127 C-----------------------------------------------------------------------
20128       SUBROUTINE HWHEPG
20129 C-----------------------------------------------------------------------
20130 C     (Initially polarised) e-e+ --> qqbar g with parton thrust < THMAX,
20131 C     equivalent to: maximum parton energy < THMAX*EMSCA/2; or a JADE E0
20132 c     scheme, y_cut=1.-THMAX.
20133 C     If flavour specified mass effects fully included.
20134 C     EVWGT=sig(e^-e^+ --> qqbar g) in nb
20135 C-----------------------------------------------------------------------
20136       INCLUDE 'HERWIG65.INC'
20137       DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT,Q2NOW,Q2LST,
20138      & PHASP,QGMAX,QGMIN,FACTR,QM2,CLF(7),ORDER,PRAN,PQWT,QQG,QBG,SUM,
20139      & RUT,QQLM,QQLP,QBLM,QBLP,DYN1,DYN2,DYN3,DYN4,DYN5,DYN6,XQ2,X2SUM,
20140      & PVRT(4)
20141       INTEGER ID1,IQ,I,LM,LP,IQ1
20142       LOGICAL MASS
20143       EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT
20144       SAVE Q2NOW,Q2LST,QGMAX,QGMIN,FACTR,ORDER,ID1,MASS,QM2,CLF,LM,LP,
20145      & IQ1,QQG,QBG,SUM
20146       DATA Q2LST/0.D0/
20147       IF (GENEV) THEN
20148 C Label produced partons and calculate gluon spin
20149         IDHW(NHEP+1)=200
20150         IDHW(NHEP+2)=IQ1
20151         IDHW(NHEP+3)=13
20152         IDHW(NHEP+4)=IQ1+6
20153         IDHEP(NHEP+1)=23
20154         IDHEP(NHEP+2)=IQ1
20155         IDHEP(NHEP+3)=21
20156         IDHEP(NHEP+4)=-IQ1
20157         ISTHEP(NHEP+1)=110
20158         ISTHEP(NHEP+2)=113
20159         ISTHEP(NHEP+3)=114
20160         ISTHEP(NHEP+4)=114
20161         JMOHEP(1,NHEP+1)=LM
20162         JMOHEP(2,NHEP+1)=LP
20163         JMOHEP(1,NHEP+2)=NHEP+1
20164         JMOHEP(2,NHEP+2)=NHEP+3
20165         JMOHEP(1,NHEP+3)=NHEP+1
20166         JMOHEP(2,NHEP+3)=NHEP+4
20167         JMOHEP(1,NHEP+4)=NHEP+1
20168         JMOHEP(2,NHEP+4)=NHEP+2
20169         JDAHEP(1,NHEP+1)=NHEP+2
20170         JDAHEP(2,NHEP+1)=NHEP+4
20171         JDAHEP(1,NHEP+2)=0
20172         JDAHEP(2,NHEP+2)=NHEP+4
20173         JDAHEP(1,NHEP+3)=0
20174         JDAHEP(2,NHEP+3)=NHEP+2
20175         JDAHEP(1,NHEP+4)=0
20176         JDAHEP(2,NHEP+4)=NHEP+3
20177 C Decide which quark radiated and assign production vertices
20178         XQ2=(Q2NOW-2.*QBG)**2
20179         X2SUM=XQ2+(Q2NOW-2.*QQG)**2
20180         IF (XQ2.LT.HWRGEN(0)*X2SUM) THEN
20181 C Quark radiated the gluon
20182           CALL HWVZRO(4,VHEP(1,NHEP+4))
20183           CALL HWVSUM(4,PHEP(1,NHEP+2),PHEP(1,NHEP+3),PVRT)
20184           CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
20185           CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+2))
20186         ELSE
20187 C Anti-quark radiated the gluon
20188           CALL HWVZRO(4,VHEP(1,NHEP+2))
20189           CALL HWVSUM(4,PHEP(1,NHEP+4),PHEP(1,NHEP+3),PVRT)
20190           CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
20191           CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+4))
20192         ENDIF
20193         IF (AZSPIN) THEN
20194 C  Calculate the transverse polarisation of the gluon
20195 C  Correlation with leptons presently neglected
20196            GPOLN=(QQG**2+QBG**2)/((Q2NOW-2.*SUM)*Q2NOW)
20197            GPOLN=2./(2.+GPOLN)
20198         ENDIF
20199         NHEP=NHEP+4
20200       ELSE
20201         EMSCA=PHEP(5,3)
20202         Q2NOW=EMSCA**2
20203         IF (Q2NOW.NE.Q2LST) THEN
20204           Q2LST=Q2NOW
20205           PHASP=3.*THMAX-2.
20206           IF (PHASP.LE.ZERO) CALL HWWARN('HWHEPG',400,*999)
20207           QGMAX=.5*Q2NOW*THMAX
20208           QGMIN=.5*Q2NOW*(1.-THMAX)
20209           FACTR=GEV2NB*FLOAT(NCOLO)*CFFAC*HWUALF(1,EMSCA)
20210      &         *.5*(HWUAEM(Q2NOW)*PHASP)**2/Q2NOW
20211           LM=1
20212           IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
20213           LP=2
20214           IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
20215           ORDER=1.
20216           IF (IDHW(1).GT.IDHW(2)) ORDER=-ORDER
20217           ID1=MOD(IPROC,10)
20218           IF (ID1.NE.0) THEN
20219              MASS=.TRUE.
20220              QM2=RMASS(ID1)**2
20221              CALL HWUCFF(11,ID1,Q2NOW,CLF(1))
20222              FACTR=FACTR*CLF(1)
20223           ELSE
20224              MASS=.FALSE.
20225              CALL HWUEEC(1)
20226              FACTR=FACTR*TQWT
20227           ENDIF
20228         ENDIF
20229         IF (ID1.EQ.0) THEN
20230 C Select quark flavour
20231           PRAN=TQWT*HWRGEN(1)
20232           PQWT=0.
20233           DO 10 IQ=1,MAXFL
20234           PQWT=PQWT+CLQ(1,IQ)
20235           IF (PQWT.GT.PRAN) GOTO 11
20236    10     CONTINUE
20237           IQ=MAXFL
20238    11     IQ1=MAPQ(IQ)
20239           DO 20 I=1,7
20240    20     CLF(I)=CLQ(I,IQ)
20241         ELSEIF (Q2NOW.GT.4*QM2/(2*THMAX-1)) THEN
20242           IQ1=ID1
20243         ELSE
20244           EVWGT=0.
20245           RETURN
20246         ENDIF
20247 C Select final state momentum configuration
20248         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20249         PHEP(5,NHEP+2)=RMASS(IQ1)
20250         PHEP(5,NHEP+3)=RMASS(13)
20251         PHEP(5,NHEP+4)=RMASS(IQ1)
20252    30   CALL HWDTHR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),
20253      &              PHEP(1,NHEP+3),PHEP(1,NHEP+4),HWDPWT)
20254         QQG=HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
20255         IF (QQG.LT.QGMIN) GOTO 30
20256         QBG=HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+3))
20257         SUM=QQG+QBG
20258         IF (QBG.LT.QGMIN.OR.SUM.GT.QGMAX) GOTO 30
20259         QQLM=HWULDO(PHEP(1,NHEP+2),PHEP(1,LM))
20260         QQLP=HWULDO(PHEP(1,NHEP+2),PHEP(1,LP))
20261         QBLM=HWULDO(PHEP(1,NHEP+4),PHEP(1,LM))
20262         QBLP=HWULDO(PHEP(1,NHEP+4),PHEP(1,LP))
20263         DYN1=QQLM**2+QQLP**2+QBLM**2+QBLP**2
20264         DYN2=0.
20265         DYN3=DYN1-2.*(QQLM**2+QBLP**2)
20266         IF (MASS) THEN
20267            RUT=1./QQG+1./QBG
20268            DYN1=DYN1+8.*QM2*(1.-.25*Q2NOW*RUT
20269      &         +QQLM*QQLP/(Q2NOW*QBG)+QBLM*QBLP/(Q2NOW*QQG))
20270            DYN2=QM2*(Q2NOW-SUM*(2.+QM2*RUT)
20271      &         -4.*HWULDO(PHEP(1,NHEP+3),PHEP(1,LM))
20272      &            *HWULDO(PHEP(1,NHEP+3),PHEP(1,LP))/Q2NOW)
20273            DYN3=DYN3+QM2*2.*RUT*(QBG*(QBLP-QBLM)-QQG*(QQLP-QQLM))
20274         ENDIF
20275         EVWGT=CLF(1)*DYN1+CLF(2)*DYN2+ORDER*CLF(3)*DYN3
20276         IF (TPOL) THEN
20277 C Include event plane azimuthal angle
20278            DYN4=.5*Q2NOW
20279            DYN5=DYN4
20280            DYN6=0.
20281            IF (MASS) THEN
20282               DYN4=DYN4-QM2*SUM/QBG
20283               DYN5=DYN5-QM2*SUM/QQG
20284               DYN6=QM2
20285            ENDIF
20286            EVWGT=EVWGT
20287      &     +(CLF(4)*COSS-CLF(6)*SINS)
20288      &      *(DYN4*(PHEP(1,NHEP+2)**2-PHEP(2,NHEP+2)**2)
20289      &       +DYN5*(PHEP(1,NHEP+4)**2-PHEP(2,NHEP+4)**2))
20290      &     +(CLF(4)*SINS+CLF(6)*COSS)*2.
20291      &      *(DYN4*PHEP(1,NHEP+2)*PHEP(2,NHEP+2)
20292      &       +DYN5*PHEP(1,NHEP+4)*PHEP(2,NHEP+4))
20293      &     +(CLF(5)*COSS-CLF(7)*SINS)*DYN6
20294      &      *(PHEP(1,NHEP+3)**2-PHEP(2,NHEP+3)**2)
20295      &     +(CLF(5)*SINS+CLF(7)*COSS)*DYN6*2.
20296      &      *PHEP(1,NHEP+3)*PHEP(2,NHEP+3)
20297         ENDIF
20298 C Assign event weight
20299         EVWGT=EVWGT*FACTR/(QQG*QBG*CLF(1))
20300       ENDIF
20301   999 END
20302 CDECK  ID>, HWHESL.
20303 *CMZ :-        -17/10/00  17:43:25  by  Peter Richardson
20304 *-- Author :    Kosuke Odagiri & Peter Richardson
20305 C-----------------------------------------------------------------------
20306       SUBROUTINE HWHESL
20307 C-----------------------------------------------------------------------
20308 C     SUSY E+E- -> 2 SLEPTON PROCESSES
20309 C-----------------------------------------------------------------------
20310       INCLUDE 'HERWIG65.INC'
20311       DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
20312      & FACTR,SN2TH,MZ,MW,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,T,SQPE
20313       INTEGER ID1,ID2,IL,IL1,IL2,I,J,IG,IG1,IHEP,NTRY,IDL,ILP,IDLR(2),
20314      & IDSLP(2)
20315       INTEGER SSNU, SSCH
20316       PARAMETER (SSNU = 449, SSCH = 453)
20317       EXTERNAL HWRGEN, HWUAEM,HWUMBW,HWUPCM,HWRUNI
20318       SAVE HCS,ME2,IDLR,IDSLP
20319       PARAMETER (EPS = 1.D-9)
20320       DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
20321       DOUBLE PRECISION F,FACT0
20322       PARAMETER (Z = (0.D0,1.D0))
20323       EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
20324 C
20325       S     = PHEP(5,3)**2
20326       EMSC2 = S
20327       EMSCA = SQRT(EMSC2)
20328       IF(FSTWGT) THEN
20329         IL = MOD((IPROC-740),5)
20330         IF(IPROC.EQ.700.OR.IPROC.EQ.740) THEN
20331           IDLR(1) = 0
20332           IDLR(2) = 0
20333           IDSLP(1) = 1
20334           IDSLP(2) = 6
20335         ELSE
20336           IF(IL.EQ.0) THEN
20337             IDLR(1) = 1
20338             IDLR(2) = 1
20339             IDSLP(1) = 2*(IPROC-740)/5
20340           ELSEIF(IL.EQ.1) THEN
20341             IDLR(1) = 0
20342             IDLR(2) = 0
20343             IDSLP(1) = 2*(IPROC-741)/5+1
20344           ELSEIF(IL.EQ.2) THEN
20345             IDLR(1) = 1
20346             IDLR(2) = 1
20347             IDSLP(1) = 2*(IPROC-742)/5+1
20348           ELSEIF(IL.EQ.3) THEN
20349             IDLR(1) = 1
20350             IDLR(2) = 2
20351             IDSLP(1) = 2*(IPROC-743)/5+1
20352           ELSEIF(IL.EQ.4) THEN
20353             IDLR(1) = 2
20354             IDLR(2) = 2
20355             IDSLP(1) = 2*(IPROC-744)/5+1
20356           ENDIF
20357           IDSLP(2) = IDSLP(1)
20358         ENDIF
20359       ENDIF
20360       IF (GENEV) THEN
20361         RCS = HCS*HWRGEN(0)
20362       ELSE
20363         IDL   = ABS(IDHEP(1))
20364         ILP   = IDL-10
20365         COSTH = HWRUNI(1,-ONE,ONE)
20366         SN2TH = 0.25D0 - 0.25D0*COSTH**2
20367         FACT0 = GEV2NB*PIFAC*HWUAEM(EMSC2)**2/S
20368         FACTR = FACT0*SN2TH
20369         GZ    = (S-MZ**2+Z*S*GAMZ/MZ)/S
20370 c             ~  ~*
20371 c    e+ e- -> l  l
20372 c
20373         DO IL=1,6
20374           DO I=1,2
20375             DO J=1,2
20376               ME2(I,J,IL) = ZERO
20377             ENDDO
20378           ENDDO
20379         ENDDO
20380         DO IL = IDSLP(1),IDSLP(2)
20381           DO I = 1,2
20382             DO J = 1,2
20383               IF ((I.EQ.2.OR.J.EQ.2).AND.(((IL/2)*2).EQ.IL).OR.
20384      &            (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
20385      &              .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
20386                 QPE = -1.
20387               ELSE
20388                 ID1 = 412 + I*12 + IL
20389                 ID2 = 412 + J*12 + IL
20390                 IL1 = IL + 10
20391                 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
20392               ENDIF
20393               IF (QPE.GT.ZERO) THEN
20394                 SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
20395                 PF = SQPE/S
20396                 IF ((IL.NE.ILP).OR.(I.EQ.J)) THEN
20397                   A  = QFCH(IL1)*QFCH(IDL)
20398                   BL = LFCH(IL1)/GZ
20399                   BR = RFCH(IL1)/GZ
20400                   CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
20401                   CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
20402                   D  = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR
20403                   E  = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR
20404                   IF (IL.EQ.ILP+1.OR.IL.EQ.ILP) THEN
20405                     F = ZERO
20406                     T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
20407                     IF (IL.EQ.ILP) THEN
20408                       IF (I.EQ.J) THEN
20409                         IF (I.EQ.1) THEN
20410                           DO IG = 1,4
20411                             IG1 = SSNU+IG
20412                             F   = F + SLFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
20413                           ENDDO
20414                           D = D + F*S
20415                         ELSE
20416                           DO IG=1,4
20417                             IG1 = SSNU+IG
20418                             F   = F +SRFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
20419                           ENDDO
20420                           E = E + F*S
20421                         ENDIF
20422                       ELSE
20423                       ENDIF
20424                     ELSE
20425                       DO IG = 1,2
20426                         IG1 = SSCH+IG
20427                         F   = F + WMXVSS(IG,1)**2/(T-RMASS(IG1)**2)
20428                       ENDDO
20429                       D = D + F*S/(TWO*SWEIN)
20430                     ENDIF
20431                   ENDIF
20432                   ME2(I,J,IL)=FACTR*PF**3*DREAL(
20433      &                  (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
20434      &                 +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E)
20435                 ELSE
20436                   F = ZERO
20437                   T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
20438                   DO IG = 1,4
20439                     IG1 = SSNU+IG
20440                     F   = F + SLFCH(IL1,IG)*SRFCH(IL1,IG)*
20441      &                    ZSGNSS(IG)*RMASS(IG1)/(T-RMASS(IG1)**2)
20442                   ENDDO
20443 C--production of el- er+
20444                   IF(I.EQ.1.AND.J.EQ.2) THEN
20445                     ME2(I,J,IL)=FACT0*PF*F**2*S*
20446      &                    (ONE-EPOLN(3))*(ONE-PPOLN(3))
20447                   ELSE
20448 C--production of er- el+
20449                     ME2(I,J,IL)=FACT0*PF*F**2*S*
20450      &                    (ONE+EPOLN(3))*(ONE+PPOLN(3))
20451                   ENDIF
20452                 ENDIF
20453               ELSE
20454                 ME2(I,J,IL)=ZERO
20455               ENDIF
20456             ENDDO
20457           ENDDO
20458         ENDDO
20459       ENDIF
20460       HCS = ZERO
20461 C
20462       DO IL = 1,6
20463          DO I = 1,2
20464             DO J = 1,2
20465                IL1 = IL+I*12+412
20466                IL2 = IL+J*12+418
20467                HCS = HCS + ME2(I,J,IL)
20468                IF (GENEV.AND.HCS.GT.RCS) GOTO 100
20469             ENDDO
20470          ENDDO
20471        ENDDO
20472 C---GENERATE EVENT
20473  100  IF(GENEV) THEN
20474 C--change sign of COSTH if antiparticle first
20475       IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
20476         IDHW(NHEP+1)     = 15
20477         IDHEP(NHEP+1)    = 0
20478         ISTHEP(NHEP+1)   = 110
20479         IDHW(NHEP+2)     = IL1
20480         IDHW(NHEP+3)     = IL2
20481         IDHEP(NHEP+2)    = IDPDG(IL1)
20482         IDHEP(NHEP+3)    = IDPDG(IL2)
20483 C--select the particle masses and momenta
20484         NTRY = 0
20485  110    NTRY = NTRY+1
20486         PHEP(5,NHEP+2)   = HWUMBW(IL1)
20487         PHEP(5,NHEP+3)   = HWUMBW(IL2)
20488         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20489         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20490         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
20491           GOTO 110
20492         ELSEIF(PCM.LT.ZERO) THEN
20493           CALL HWWARN('HWHESL',100,*999)
20494         ENDIF
20495 C--Set up the colours etc
20496         ISTHEP(NHEP+2)   = 113
20497         ISTHEP(NHEP+3)   = 114
20498         JMOHEP(1,NHEP+1) = 1
20499         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20500         JMOHEP(2,NHEP+1) = 2
20501         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20502         JMOHEP(1,NHEP+2) = NHEP+1
20503         JMOHEP(2,NHEP+2) = NHEP+2
20504         JMOHEP(1,NHEP+3) = NHEP+1
20505         JMOHEP(2,NHEP+3) = NHEP+3
20506         JDAHEP(1,NHEP+1) = NHEP+2
20507         JDAHEP(2,NHEP+1) = NHEP+3
20508         JDAHEP(1,NHEP+2) = 0
20509         JDAHEP(2,NHEP+2) = NHEP+2
20510         JDAHEP(1,NHEP+3) = 0
20511         JDAHEP(2,NHEP+3) = NHEP+3
20512 C--Set up the momenta
20513         IHEP  = NHEP+2
20514         IHEP  = NHEP+2
20515         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
20516         PHEP(3,IHEP) = PCM*COSTH
20517         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
20518         PHEP(2,IHEP) = ZERO
20519         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
20520         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
20521         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
20522         NHEP  = NHEP+3
20523       ELSE
20524         EVWGT = HCS
20525       ENDIF
20526  999  END
20527 CDECK  ID>, HWHESG.
20528 *CMZ :-        -18/10/00  13:46:47  by  Peter Richardson
20529 *-- Author :    Kosuke Odagiri & Peter Richardson
20530 C-----------------------------------------------------------------------
20531       SUBROUTINE HWHESG
20532 C-----------------------------------------------------------------------
20533 C     SUSY E+E- -> 2 GAUGINO PROCESSES
20534 C-----------------------------------------------------------------------
20535       INCLUDE 'HERWIG65.INC'
20536       DOUBLE PRECISION HWRGEN,HWUAEM,HCS,RCS,MNU(4),MNU2(4),HWRUNI,
20537      &                 FACA,M1(4,4),S2W,XA(4),XB(4),XC(4),XD(4),MSNU,
20538      &                 MW,MZ,HWHSS2,U,T,QPE,SQPE,MSL,MSL2,MSR,MSR2,
20539      &                 SGN,SN2TH,S,SM,DM,PF,PCM,HWUPCM,XW,S22W,SQXW,
20540      &                 MSNU2,MCH(2),MCH2(2),DAB,M2(2,2),HWUMBW
20541       INTEGER I,IQ1,IQ2,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,
20542      &        ISN,IDL,NTRY
20543       LOGICAL NEUT,CHAR
20544       SAVE HCS,M1,M2,NTID,ISL,ISR,ISN,IDL,CHID,NEUT,CHAR
20545       EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWHSS2,HWUPCM,HWUMBW
20546       DOUBLE COMPLEX Z, Z0, Z1, C1, C2, C3,GZ, CLL, CLR, CRL, CRR
20547       PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0), Z1 = (1.D0,0.D0))
20548       PARAMETER (SSNU=449,SSCH = 453)
20549       EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
20550       EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1))
20551       EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1))
20552       EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2))
20553       EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2))
20554       EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
20555       EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
20556       EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
20557       EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
20558 C--Start of the code
20559       IF(GENEV) THEN
20560         RCS = HCS*HWRGEN(0)
20561       ELSE
20562 C--Decide which processes to generate
20563         IF(FSTWGT) THEN
20564           NEUT = .TRUE.
20565           CHAR = .TRUE.
20566 C--neutralino pair production
20567           IF(IPROC.GE.710.AND.IPROC.LE.726) THEN
20568             CHAR = .FALSE.
20569             IF(IPROC.EQ.710) THEN
20570               NTID(1) = 0
20571               NTID(2) = 0
20572             ELSE
20573               NTID(1) = INT((IPROC-707)/4)
20574               NTID(2) = MOD((IPROC-711),4)+1
20575             ENDIF
20576 C--chargino pair production
20577           ELSEIF(IPROC.GE.730.AND.IPROC.LE.734) THEN
20578             NEUT = .FALSE.
20579             IF(IPROC.EQ.730) THEN
20580               CHID(1) = 0
20581               CHID(2) = 0
20582             ELSE
20583               CHID(1) = INT((IPROC-729)/2)
20584               CHID(2) = MOD((IPROC-731),2)+1
20585             ENDIF
20586           ELSEIF(IPROC.NE.700) THEN
20587             CALL HWWARN('HWHESG',500,*999)
20588           ENDIF
20589 C--check the particles in the beam
20590           IF(ABS(IDHEP(1)).EQ.11) THEN
20591 C--electron beams
20592             ISL = 425
20593             ISR = 437
20594             ISN = 426
20595           ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
20596 C--muon beams
20597             ISL = 427
20598             ISR = 439
20599             ISN = 428
20600           ELSE
20601             CALL HWWARN('HWHESG',501,*999)
20602           ENDIF
20603           IDL=ABS(IDHEP(1))
20604         ENDIF
20605         DO I=1,4
20606           MNU(I) = RMASS(SSNU+I)
20607           MNU2(I) = MNU(I)**2
20608         ENDDO
20609         DO IG1 = 1,2
20610           MCH(IG1)  = RMASS(IG1+SSCH)
20611           MCH2(IG1) = MCH(IG1)**2
20612         ENDDO
20613         COSTH = HWRUNI(1,-ONE,ONE)
20614         SN2TH = 0.25D0-0.25D0*COSTH**2
20615         XW    = TWO * SWEIN
20616         SQXW  = SQRT(XW)
20617         S22W  = XW * (TWO - XW)
20618         S2W   = SQRT(S22W)
20619         S     = PHEP(5,3)**2
20620         EMSCA = PHEP(5,3)
20621         FACA  = HWUAEM(S)**2
20622         GZ    = S-MZ**2+Z*S/MZ*GAMZ
20623         MSL   = RMASS(ISL)
20624         MSR   = RMASS(ISR)
20625         MSL2  = MSL**2
20626         MSR2  = MSR**2
20627         MSNU  = RMASS(ISN)
20628         MSNU2 = MSNU**2
20629 C--neutralino pair production
20630         IF(.NOT.NEUT) THEN
20631           DO IQ1=1,4
20632             DO IQ2=1,4
20633               M1(IQ1,IQ2) = ZERO
20634             ENDDO
20635           ENDDO
20636           GOTO 100
20637         ENDIF
20638         DO IQ1=1,4
20639           DO IQ2=1,4
20640             SM   = MNU(IQ1) + MNU(IQ2)
20641             QPE  = S - SM**2
20642             IF(QPE.GE.ZERO.AND.
20643      &           (NTID(1).EQ.0.OR.(IQ1.EQ.NTID(1).AND.IQ2.EQ.NTID(2))
20644      &           .OR.(IQ1.EQ.NTID(2).AND.IQ2.EQ.NTID(1)))) THEN
20645               DM   = MNU(IQ1) - MNU(IQ2)
20646               SQPE = SQRT(QPE*(S-DM**2))
20647               PF   = SQPE/S
20648               T    = HALF*(SQPE*COSTH - S + MNU2(IQ1) + MNU2(IQ2))
20649               U    = - T - S + MNU2(IQ1) + MNU2(IQ2)
20650               C1   = (XD(IQ1)*XD(IQ2)-XC(IQ1)*XC(IQ2))/S2W/GZ
20651               C2   = - C1
20652               SGN  = ZSGNSS(IQ1)*ZSGNSS(IQ2)
20653               CLL = LFCH(IDL)*C1+SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(U-MSL2)
20654               CLR = LFCH(IDL)*C2-SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(T-MSL2)
20655               CRL = RFCH(IDL)*C1-SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(T-MSR2)
20656               CRR = RFCH(IDL)*C2+SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(U-MSR2)
20657 C--modified to include beam polarization PR 10/10/01
20658               M1(IQ1,IQ2) = FACA*PF*GEV2NB*PIFAC/S*HALF*
20659      &          HWHSS2(S,T,U,MNU(IQ1),MNU(IQ2),SGN,CLL,CLR,CRL,CRR)
20660             ELSE
20661               M1(IQ1,IQ2) = ZERO
20662             ENDIF
20663           ENDDO
20664         ENDDO
20665 C--chargino pair production
20666  100    IF(.NOT.CHAR) THEN
20667           DO IG1=1,2
20668             DO IG2=1,2
20669               M2(IG1,IG2) = ZERO
20670             ENDDO
20671           ENDDO
20672           GOTO 200
20673         ENDIF
20674         DO IG1 = 1,2
20675           DO IG2 = 1,2
20676             SM  = MCH(IG1) + MCH(IG2)
20677             QPE = S - SM**2
20678             IF (QPE.GE.ZERO.AND.
20679      &           (CHID(1).EQ.0.OR.(CHID(1).EQ.IG1.AND.CHID(2).EQ.IG2)
20680      &            .OR.(CHID(1).EQ.IG2.AND.CHID(2).EQ.IG1))) THEN
20681               DM   = MCH(IG1) - MCH(IG2)
20682               SQPE = SQRT(QPE*(S-DM**2))
20683               PF   = SQPE/S
20684               T    = HALF*(SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2))
20685               U    = - T - S + MCH2(IG1) + MCH2(IG2)
20686               DAB  = ABS(FLOAT(IG1+IG2-3))
20687               C1   = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
20688               C2   = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
20689               SGN  = WSGNSS(IG1)*WSGNSS(IG2)
20690               C3   = -DAB*QFCH(IDL)/S
20691               CLL  = C3- LFCH(IDL)*C1
20692      &               +WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-MSNU2)*XW)
20693               CLR  = C3- LFCH(IDL)*C2
20694               CRL  = C3- RFCH(IDL)*C1
20695               CRR  = C3- RFCH(IDL)*C2
20696 C--modified to include beam polarization PR 10/10/01
20697               M2(IG1,IG2)=FACA*PF*GEV2NB*PIFAC/S*
20698      &             HWHSS2(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
20699             ELSE
20700               M2(IG1,IG2) = ZERO
20701             ENDIF
20702           ENDDO
20703         ENDDO
20704       ENDIF
20705 C--Add up the weights now
20706  200  HCS = ZERO
20707       IF(.NOT.NEUT) GOTO 250
20708       DO IQ1=1,4
20709         IG1 = SSNU+IQ1
20710         DO IQ2=1,4
20711           IG2 = SSNU+IQ2
20712           HCS = HCS+M1(IQ1,IQ2)
20713           IF(GENEV.AND.HCS.GT.RCS) GOTO 900
20714         ENDDO
20715       ENDDO
20716  250  IF(.NOT.CHAR) GOTO 900
20717       DO IQ1 = 1,2
20718         IG1 = SSCH+IQ1
20719         DO IQ2 = 1,2
20720           IG2 = SSCH+IQ2+2
20721           HCS = HCS + M2(IQ1,IQ2)
20722           IF (GENEV.AND.HCS.GT.RCS) GOTO 900
20723         ENDDO
20724       ENDDO
20725  900  IF(GENEV) THEN
20726 C--change sign of COSTH if antiparticle first
20727         IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
20728 C-Set up the particle types
20729         IDHW(NHEP+1)     = 15
20730         IDHEP(NHEP+1)    = 0
20731         ISTHEP(NHEP+1)   = 110
20732         IDHW(NHEP+2)     = IG1
20733         IDHW(NHEP+3)     = IG2
20734         IDHEP(NHEP+2)    = IDPDG(IG1)
20735         IDHEP(NHEP+3)    = IDPDG(IG2)
20736 C--select the particle masses and momenta
20737         NTRY = 0
20738  910    NTRY = NTRY+1
20739         PHEP(5,NHEP+2)   = HWUMBW(IG1)
20740         PHEP(5,NHEP+3)   = HWUMBW(IG2)
20741         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20742         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20743         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
20744           GOTO 910
20745         ELSEIF(PCM.LT.ZERO) THEN
20746           CALL HWWARN('HWHESG',100,*999)
20747         ENDIF
20748 C--Set up the colours etc
20749         ISTHEP(NHEP+2)   = 113
20750         ISTHEP(NHEP+3)   = 114
20751         JMOHEP(1,NHEP+1) = 1
20752 C--PR Bug fix 10/10/01
20753         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20754         JMOHEP(2,NHEP+1) = 2
20755         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20756         JMOHEP(1,NHEP+2) = NHEP+1
20757         JMOHEP(2,NHEP+2) = NHEP+2
20758         JMOHEP(1,NHEP+3) = NHEP+1
20759         JMOHEP(2,NHEP+3) = NHEP+3
20760         JDAHEP(1,NHEP+1) = NHEP+2
20761         JDAHEP(2,NHEP+1) = NHEP+3
20762         JDAHEP(1,NHEP+2) = 0
20763         JDAHEP(2,NHEP+2) = NHEP+3
20764         JDAHEP(1,NHEP+3) = 0
20765         JDAHEP(2,NHEP+3) = NHEP+2
20766 C--Set up the momenta
20767         IHEP  = NHEP+2
20768         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
20769         PHEP(3,IHEP) = PCM*COSTH
20770         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
20771         PHEP(2,IHEP) = ZERO
20772         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
20773         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
20774         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
20775         NHEP  = NHEP+3
20776       ELSE
20777         EVWGT = HCS
20778       ENDIF
20779  999  END
20780 CDECK  ID>, HWHESP.
20781 *CMZ :-        -18/10/00  13:46:47  by  Peter Richardson
20782 *-- Author :    Kosuke Odagiri & Peter Richardson
20783 C-----------------------------------------------------------------------
20784       SUBROUTINE HWHESP
20785 C-----------------------------------------------------------------------
20786 C     SUSY E+E- -> 2 SPARTICLE PROCESSES
20787 C-----------------------------------------------------------------------
20788       INCLUDE 'HERWIG65.INC'
20789       DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN
20790       EXTERNAL HWRGEN
20791       SAVE SAVWT
20792       IF(IPROC.EQ.700) THEN
20793         IF(GENEV) THEN
20794           RANWT    = SAVWT(3)*HWRGEN(0)
20795           IF(RANWT.LT.SAVWT(1)) THEN
20796             CALL HWHESG
20797           ELSEIF(RANWT.LT.SAVWT(2)) THEN
20798             CALL HWHESL
20799           ELSEIF(RANWT.LT.SAVWT(3)) THEN
20800             CALL HWHESQ
20801           ENDIF
20802         ELSE
20803           CALL HWHESG
20804           SAVWT(1) = EVWGT
20805           CALL HWHESL
20806           SAVWT(2) = SAVWT(1)+EVWGT
20807           CALL HWHESQ
20808           SAVWT(3) = SAVWT(2)+EVWGT
20809           EVWGT    = SAVWT(3)
20810         ENDIF
20811       ELSEIF(IPROC.LT.740) THEN
20812         CALL HWHESG
20813       ELSEIF(IPROC.LT.760) THEN
20814         CALL HWHESL
20815       ELSEIF(IPROC.LT.790) THEN
20816         CALL HWHESQ
20817       ELSE
20818 C---UNRECOGNIZED PROCESS
20819         CALL HWWARN('HWHESP',500,*999)
20820       ENDIF
20821  999  END
20822 CDECK  ID>, HWHESQ.
20823 *CMZ :-        -16/10/00  15:34:113  by  Peter Richardson
20824 *-- Author :    Kosuke Odagiri & Peter Richardson
20825 C-----------------------------------------------------------------------
20826       SUBROUTINE HWHESQ
20827 C-----------------------------------------------------------------------
20828 C     SUSY E+E- -> 2 SQUARK PROCESSES
20829 C-----------------------------------------------------------------------
20830       INCLUDE 'HERWIG65.INC'
20831       DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
20832      & FACTR,SN2TH,MZ,MW,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,SQPE
20833       INTEGER ID1,ID2,IQ,IQ1,IQ2,I,J,IHEP,IDL,IDLR(2),IDSQU(2),NTRY
20834       EXTERNAL HWRGEN,HWUAEM,HWUMBW,HWUPCM,HWRUNI
20835       SAVE HCS,ME2,IDLR,IDSQU
20836       PARAMETER (EPS = 1.D-9)
20837       DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
20838       PARAMETER (Z = (0.D0,1.D0))
20839       EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
20840 C
20841       S     = PHEP(5,3)**2
20842       EMSC2 = S
20843       EMSCA = SQRT(EMSC2)
20844       IF(FSTWGT) THEN
20845         IF(IPROC.EQ.700.OR.IPROC.EQ.760) THEN
20846            IDLR(1) = 0
20847            IDLR(2) = 0
20848            IDSQU(1) = 1
20849            IDSQU(2) = 6
20850         ELSEIF(IPROC.GT.760.AND.IPROC.LE.784) THEN
20851            IQ = MOD((IPROC-761),4)
20852            IF(IQ.EQ.0) THEN
20853               IDLR(1) = 0
20854               IDLR(2) = 0
20855            ELSEIF(IQ.EQ.1) THEN
20856               IDLR(1) = 1
20857               IDLR(2) = 1
20858            ELSEIF(IQ.EQ.2) THEN
20859               IDLR(1) = 1
20860               IDLR(2) = 2
20861            ELSEIF(IQ.EQ.3) THEN
20862               IDLR(1) = 2
20863               IDLR(2) = 2
20864            ENDIF
20865            IDSQU(1) = (IPROC-761)/4+1
20866            IDSQU(2) = IDSQU(1)
20867         ELSE
20868            CALL HWWARN('HWHESQ',500,*999)
20869         ENDIF
20870       ENDIF
20871       IF (GENEV) THEN
20872         RCS   = HCS*HWRGEN(0)
20873       ELSE
20874         COSTH = HWRUNI(1,-ONE,ONE)
20875         SN2TH = 0.25D0 - 0.25D0*COSTH**2
20876         FACTR = CAFAC*GEV2NB*PIFAC*HWUAEM(EMSC2)**2*SN2TH/S
20877         GZ    = (S-MZ**2+Z*S*GAMZ/MZ)/S
20878         IDL   = ABS(IDHEP(1))
20879 c             ~  ~*
20880 c    e+ e- -> q  q
20881 c
20882         DO IQ=1,6
20883           DO I=1,2
20884             DO J=1,2
20885               ME2(I,J,IQ) = ZERO
20886             ENDDO
20887           ENDDO
20888         ENDDO
20889         DO IQ = IDSQU(1),IDSQU(2)
20890           DO I = 1,2
20891             DO J = 1,2
20892               IF ((I.NE.J).AND.(IQ.LT.5).OR.
20893      &            (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
20894      &              .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
20895                 QPE = -1.
20896               ELSE
20897                 ID1 = 388 + I*12 + IQ
20898                 ID2 = 388 + J*12 + IQ
20899                 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
20900               ENDIF
20901               IF (QPE.GT.ZERO) THEN
20902                 SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
20903                 PF = SQPE/S
20904                 A  = QFCH(IQ)*QFCH(IDL)
20905                 BL = LFCH(IQ)/GZ
20906                 BR = RFCH(IQ)/GZ
20907                 CL = QMIXSS(IQ,1,I)*QMIXSS(IQ,1,J)
20908                 CR = QMIXSS(IQ,2,I)*QMIXSS(IQ,2,J)
20909                 D  = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR
20910                 E  = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR
20911                 ME2(I,J,IQ)=FACTR*PF**3*DREAL(
20912      &                  (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
20913      &                 +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E)
20914               ELSE
20915                 ME2(I,J,IQ)=ZERO
20916               ENDIF
20917             ENDDO
20918           ENDDO
20919         ENDDO
20920       ENDIF
20921       HCS = ZERO
20922 C
20923       DO IQ = 1,6
20924         DO I = 1,2
20925           DO J = 1,2
20926             IQ1 = IQ+I*12+388
20927             IQ2 = IQ+J*12+394
20928             HCS = HCS + ME2(I,J,IQ)
20929             IF (GENEV.AND.HCS.GT.RCS) GOTO 100
20930           ENDDO
20931         ENDDO
20932       ENDDO
20933 C---GENERATE EVENT
20934  100  IF(GENEV) THEN
20935         IDHW(NHEP+1)     = 15
20936         IDHEP(NHEP+1)    = 0
20937         ISTHEP(NHEP+1)   = 110
20938         IDHW(NHEP+2)     = IQ1
20939         IDHW(NHEP+3)     = IQ2
20940         IDHEP(NHEP+2)    = IDPDG(IQ1)
20941         IDHEP(NHEP+3)    = IDPDG(IQ2)
20942 C--Select the particle masses and momenta
20943  110    NTRY = NTRY+1
20944         PHEP(5,NHEP+2)   = HWUMBW(IQ1)
20945         PHEP(5,NHEP+3)   = HWUMBW(IQ2)
20946         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20947         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20948         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
20949           GOTO 110
20950         ELSEIF(PCM.LT.ZERO) THEN
20951           CALL HWWARN('HWHESQ',100,*999)
20952         ENDIF
20953 C--Set up the colours etc
20954         ISTHEP(NHEP+2)   = 113
20955         ISTHEP(NHEP+3)   = 114
20956         JMOHEP(1,NHEP+1) = 1
20957         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20958         JMOHEP(2,NHEP+1) = 2
20959         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20960         JMOHEP(1,NHEP+2) = NHEP+1
20961         JMOHEP(2,NHEP+2) = NHEP+3
20962         JMOHEP(1,NHEP+3) = NHEP+1
20963         JMOHEP(2,NHEP+3) = NHEP+2
20964         JDAHEP(1,NHEP+1) = NHEP+2
20965         JDAHEP(2,NHEP+1) = NHEP+3
20966         JDAHEP(1,NHEP+2) = 0
20967         JDAHEP(2,NHEP+2) = NHEP+3
20968         JDAHEP(1,NHEP+3) = 0
20969         JDAHEP(2,NHEP+3) = NHEP+2
20970 C--Set up the momenta
20971         IHEP  = NHEP+2
20972         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
20973         PHEP(3,IHEP) = PCM*COSTH
20974         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
20975         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
20976         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
20977         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
20978         NHEP  = NHEP+3
20979       ELSE
20980         EVWGT = HCS
20981       ENDIF
20982  999  END
20983 CDECK  ID>, HWHEW0.
20984 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
20985 *-- Author :    Zoltan Kunszt, modified by Bryan Webber & Mike Seymour
20986 C-----------------------------------------------------------------------
20987       SUBROUTINE HWHEW0(IP,ETOT,XM,PR,WEIGHT,CR)
20988 C-----------------------------------------------------------------------
20989       INCLUDE 'HERWIG65.INC'
20990       DOUBLE PRECISION HWRGEN,ETOT,XM(2),PR(5,2),WEIGHT,CR,XM1,XM2,S,
20991      & D1,PABS,D,CX,C,E,F,SC,G
20992       INTEGER IP,I
20993       EXTERNAL HWRGEN
20994       WEIGHT=ZERO
20995       XM1=XM(1)**2
20996       XM2=XM(2)**2
20997       S=ETOT*ETOT
20998       D1=S-XM1-XM2
20999       PABS=D1*D1-4.*XM1*XM2
21000       IF (PABS.LE.ZERO) RETURN
21001       PABS=SQRT(PABS)
21002       D=D1/PABS
21003       IF(IP.EQ.2)GOTO3
21004       CX=CR
21005       C=D-(D+CX)*((D-CR)/(D+CX))**HWRGEN(2)
21006       GOTO 4
21007 3     E=((D+ONE)/(D-ONE))*(TWO*HWRGEN(3)-ONE)
21008       C=D*((E-ONE)/(E+ONE))
21009 4     F=2D0*PIFAC*HWRGEN(4)
21010       SC=SQRT(ONE-C*C)
21011       PR(4,1)=(S+XM1-XM2)/(TWO*ETOT)
21012       PR(5,1)=PR(4,1)*PR(4,1)-XM1
21013       IF (PR(5,1).LE.ZERO) RETURN
21014       PR(5,1)=SQRT(PR(5,1))
21015       PR(4,2)=ETOT-PR(4,1)
21016       PR(3,1)=PR(5,1)*C
21017       PR(5,2)=PR(5,1)
21018       PR(2,1)=PR(5,1)*SC*COS(F)
21019       PR(1,1)=PR(5,1)*SC*SIN(F)
21020       DO 7 I=1,3
21021 7     PR(I,2)=-PR(I,1)
21022       G=0.
21023       IF(IP.EQ.1)G=(D-C)*LOG((D+CX)/(D-CR))
21024       IF(IP.EQ.2)G=(D*D-C*C)/D*LOG((D+ONE)/(D-ONE))
21025       WEIGHT=PIFAC*G*PR(5,1)/ETOT*HALF
21026       RETURN
21027       END
21028 CDECK  ID>, HWHEW1.
21029 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
21030 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21031 C-----------------------------------------------------------------------
21032       SUBROUTINE HWHEW1(NPART)
21033 C-----------------------------------------------------------------------
21034       IMPLICIT NONE
21035       DOUBLE PRECISION P(4,7),XMASS,PLAB,PRW,PCM
21036       INTEGER NPART,I,J,K
21037       COMMON/HWHEWP/ XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
21038       DO 10 I=1,NPART
21039       P(1,I)=PLAB(3,I)
21040       P(2,I)=PLAB(1,I)
21041       P(3,I)=PLAB(2,I)
21042       P(4,I)=PLAB(4,I)
21043   10  CONTINUE
21044       DO 20 J=1,4
21045       DO 30 K=1,(NPART-2)
21046   30  PCM(J,K)=P(J,K+2)
21047       PCM(J,NPART-1)=-P(J,1)
21048       PCM(J,NPART)=-P(J,2)
21049   20  CONTINUE
21050       END
21051 CDECK  ID>, HWHEW2.
21052 *CMZ :-        -26/04/91  13.22.25  by  Federico Carminati
21053 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21054 C-----------------------------------------------------------------------
21055       SUBROUTINE HWHEW2(NPART,PPCM,H,CH,D)
21056 C-----------------------------------------------------------------------
21057 C PCM SHOULD BE DEFINED SUCH THAT ALL 4-MOMENTA ARE OUTGOING.
21058 C CONVENTION FOR PCM AND P IS THAT DIRECTION 1 =BEAM, COMPONENT
21059 C 4 = ENERGY AND COMPONENT 2 AND 3 ARE TRANSVERSE COMPONENTS.
21060 C THUS INCOMING MOMENTA SHOULD CORRESPOND TO OUTGOING MOMENTA
21061 C OF NEGATIVE ENERGY.
21062 C PCM IS FILLED BY PHASE SPACE MONTE CARLO.
21063 C I1-I7 HERE REFER TO HOW PCM INDEXING IS MAPPED TO OUR STANDARD
21064 C 1-6=GLUON,GLUON,Q,QBAR,QP,QPBAR ORDERING `
21065 C-----------------------------------------------------------------------
21066       IMPLICIT NONE
21067       DOUBLE COMPLEX PT5,ZT,Z1,ZI,ZP,ZQ,ZD,ZPS,ZQS,ZDPM,ZDMP,H(8,8),
21068      & CH(8,8),D(8,8)
21069       DOUBLE PRECISION ZERO,ONE,PPCM(5,8),P(5,8),WRN(8),EPS,Q1,Q2,QP,QM,
21070      & P1,P2,PP,PM,DMP,DPM,PT,QT,PTI,QTI,HALF
21071       INTEGER J,L,IJ,II,JJ,I,NPART,IP1,IPP1
21072       PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
21073       EPS=0.0000001
21074       ZI=DCMPLX(ZERO,ONE)
21075       Z1=DCMPLX(ONE,ZERO)
21076 C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
21077       DO 1 L=1,NPART
21078       DO 1 IJ=1,4
21079 1     P(IJ,L)=PPCM(IJ,L)
21080       DO 2 II=1,8
21081       WRN(II)=ONE
21082       IF(P(4,II).LT.ZERO) WRN(II)=-ONE
21083       DO 2 JJ=1,4
21084       P(JJ,II)=WRN(II)*P(JJ,II)
21085     2 CONTINUE
21086 C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
21087 C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
21088       DO 11 I=1,NPART-1
21089       IP1=I+1
21090       DO 11 J=IP1,NPART
21091       Q1=P(4,I)+P(1,I)
21092       QP=0.0
21093       IF(Q1.GT.EPS)QP=SQRT(Q1)
21094       Q2=P(4,I)-P(1,I)
21095       QM=0.0
21096       IF(Q2.GT.EPS)QM=SQRT(Q2)
21097       P1=P(4,J)+P(1,J)
21098       PP=0.
21099       IF(P1.GT.EPS)PP=SQRT(P1)
21100       P2=P(4,J)-P(1,J)
21101       PM=0.
21102       IF(P2.GT.EPS)PM=SQRT(P2)
21103       DMP=PM*QP
21104       ZDMP=DCMPLX(DMP,ZERO)
21105       DPM=PP*QM
21106       ZDPM=DCMPLX(DPM,ZERO)
21107 C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
21108       PT=SQRT(P(2,J)**2+P(3,J)**2)
21109       QT=SQRT(P(2,I)**2+P(3,I)**2)
21110       IF(PT.GT.EPS) GOTO 99
21111       ZP=Z1
21112       GOTO 98
21113    99 PTI=ONE/PT
21114       ZP=DCMPLX(PTI*P(2,J),PTI*P(3,J))
21115    98 ZPS=DCONJG(ZP)
21116       IF(QT.GT.EPS) GOTO 89
21117       ZQ=Z1
21118       GOTO 88
21119    89 QTI=ONE/QT
21120       ZQ=DCMPLX(QTI*P(2,I),QTI*P(3,I))
21121    88 ZQS=DCONJG(ZQ)
21122       ZT=Z1
21123       IF(WRN(I).LT.ZERO) ZT=ZT*ZI
21124       IF(WRN(J).LT.ZERO) ZT=ZT*ZI
21125       H(J,I)=(ZDMP*ZP-ZDPM*ZQ)*ZT
21126       CH(J,I)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
21127       ZD=H(J,I)*CH(J,I)
21128       PT5=DCMPLX(HALF,ZERO)
21129       D(J,I)=PT5*ZD
21130    11 CONTINUE
21131       DO 60 I=1,NPART-1
21132       IPP1=I+1
21133       DO 60 J=IPP1,NPART
21134       H(I,J)=-H(J,I)
21135       CH(I,J)=-CH(J,I)
21136    60 D(I,J)=D(J,I)
21137       RETURN
21138       END
21139 CDECK  ID>, HWHEW3.
21140 *CMZ :-        -27/03/92  19.48.55  by  Mike Seymour
21141 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21142 C-----------------------------------------------------------------------
21143       SUBROUTINE HWHEW3(N1,N2,N3,N4,N5,N6,AMPWW)
21144 C-----------------------------------------------------------------------
21145 C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
21146 C OUTGOING ANTI-FERMIONS; 3,4 FOR W-, 5,6 FOR W+
21147 C
21148 C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
21149 C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
21150 C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
21151 C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
21152 C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
21153 C
21154 C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
21155 C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
21156 C FOR ON POLE APPROXIMATION AS DESIRED.
21157 C-----------------------------------------------------------------------
21158       INCLUDE 'HERWIG65.INC'
21159       DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMP1,ZAMP2,ZAMP3,DWW,CWW,BWW,AWW,
21160      & AWWM,AWWP,AMPTEM,ZTWO,ZHALF
21161       DOUBLE PRECISION XW,ZMASS,T3,EQ1,RR,RL,ZM2,AMP2,RKW,COLFAC(4),
21162      & AMPWW(4)
21163       INTEGER I,N1,N2,N3,N4,N5,N6
21164       EXTERNAL HWHEW4
21165       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21166       EQUIVALENCE (XW,SWEIN),(ZMASS,RMASS(200))
21167       DATA COLFAC/1.D0,3.D0,3.D0,9.D0/
21168       DATA ZTWO,ZHALF/(2.0D0,0.0D0),(0.5D0,0.0D0)/
21169       T3=-1.D0
21170       EQ1=-1.D0
21171       RR=-2.D0*EQ1*XW
21172       RL=T3+RR
21173       ZM2=ZMASS*ZMASS
21174       ZAMP1=DCMPLX(ZM2)/(ZTWO*ZD(N1,N2))
21175      &                /(ZTWO*ZD(N1,N2)+DCMPLX(-ZM2,GAMZ*ZMASS))
21176       ZAMP2=ZHALF/(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))
21177       ZAMP3=ZHALF/(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))
21178       DWW=DCMPLX(RL)*ZAMP1+T3/(ZTWO*ZD(N1,N2))
21179       CWW=DCMPLX(RR)*ZAMP1
21180       AWW=DWW
21181       BWW=DWW-ZAMP3
21182       AWWM=AWW*HWHEW4(N1,N2,N3,N4,N5,N6)-BWW*HWHEW4(N1,N2,N5,N6,N3,N4)
21183       AWWP=CWW*(HWHEW4(N2,N1,N5,N6,N3,N4)-HWHEW4(N2,N1,N3,N4,N5,N6))
21184       AMPTEM=AWWM*DCONJG(AWWM)+AWWP*DCONJG(AWWP)
21185       AMP2=DREAL(AMPTEM)
21186 C AMP2 DOES NOT INCLUDE COLOR OR FLAVOR SUMS OR AVERAGES YET
21187 C NOR DOES IT INCLUDE TO THIS POINT KWW**2
21188 C 1 LEPTON FLAVOR IF APPROPRIATE FOR NFINAL CHOICE
21189       RKW=0.25D0/XW**2
21190       DO 6 I=1,4
21191 6     AMPWW(I)=AMP2*COLFAC(I)*RKW*RKW
21192       RETURN
21193       END
21194 CDECK  ID>, HWHEW4.
21195 *CMZ :-        -26/04/91  10.18.57  by  Bryan Webber
21196 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21197 C-----------------------------------------------------------------------
21198       FUNCTION HWHEW4(N1,N2,N3,N4,N5,N6)
21199 C-----------------------------------------------------------------------
21200       IMPLICIT NONE
21201       DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD
21202       INTEGER N1,N2,N3,N4,N5,N6
21203       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21204       HWHEW4=4*ZH(N1,N3)*ZCH(N2,N6)*(ZH(N1,N5)*ZCH(N1,N4)
21205      X                              +ZH(N3,N5)*ZCH(N3,N4))
21206       RETURN
21207       END
21208 CDECK  ID>, HWHEW5.
21209 *CMZ :          20/08/91  22.09.33  by  Federico Carminati
21210 *-- Author :    Zoltan Kunszt, modified by Mike Seymour
21211 C-----------------------------------------------------------------------
21212       SUBROUTINE HWHEW5(N1,N2,N3,N4,N5,N6,HELSUM,HELCTY,ID1,ID2)
21213 C-----------------------------------------------------------------------
21214 C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
21215 C OUTGOING ANTI-FERMIONS; 3,4 FOR Z0, 5,6 FOR Z0
21216 C
21217 C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
21218 C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
21219 C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
21220 C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
21221 C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
21222 C
21223 C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
21224 C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
21225 C FOR ON POLE APPROXIMATION AS DESIRED.
21226 C
21227 C---SLIGHTLY MODIFIED BY MHS, SO THAT HELCTY REFERS TO THE FINAL STATE
21228 C   INDICATED BY ID1,ID2
21229 C-----------------------------------------------------------------------
21230       IMPLICIT NONE
21231       DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMM(8),ZS134,ZS156,ZS234,ZS256,
21232      & ZTWO
21233       DOUBLE PRECISION CPFAC,CPALL,HELSUM,HELCTY,AMM
21234       INTEGER N1,N2,N3,N4,N5,N6,ID1,ID2,I
21235       EXTERNAL HWHEW4
21236       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21237       COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
21238       DATA ZTWO/(2.0D0,0.0D0)/
21239 C THE MATRIX ELEMENT DEPENDS ON
21240       ZS134=(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))*ZTWO
21241       ZS156=(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))*ZTWO
21242       ZS234=(ZD(N2,N3)+ZD(N2,N4)+ZD(N3,N4))*ZTWO
21243       ZS256=(ZD(N2,N5)+ZD(N2,N6)+ZD(N5,N6))*ZTWO
21244       ZAMM(1)=HWHEW4(N1,N2,N3,N4,N5,N6)/ZS134+
21245      >        HWHEW4(N1,N2,N5,N6,N3,N4)/ZS156
21246       ZAMM(2)=HWHEW4(N1,N2,N4,N3,N5,N6)/ZS134+
21247      >        HWHEW4(N1,N2,N5,N6,N4,N3)/ZS156
21248       ZAMM(3)=HWHEW4(N1,N2,N3,N4,N6,N5)/ZS134+
21249      >        HWHEW4(N1,N2,N6,N5,N3,N4)/ZS156
21250       ZAMM(4)=HWHEW4(N1,N2,N4,N3,N6,N5)/ZS134+
21251      >        HWHEW4(N1,N2,N6,N5,N4,N3)/ZS156
21252       ZAMM(5)=HWHEW4(N2,N1,N3,N4,N5,N6)/ZS234+
21253      >        HWHEW4(N2,N1,N5,N6,N3,N4)/ZS256
21254       ZAMM(6)=HWHEW4(N2,N1,N4,N3,N5,N6)/ZS234+
21255      >        HWHEW4(N2,N1,N5,N6,N4,N3)/ZS256
21256       ZAMM(7)=HWHEW4(N2,N1,N3,N4,N6,N5)/ZS234+
21257      >        HWHEW4(N2,N1,N6,N5,N3,N4)/ZS256
21258       ZAMM(8)=HWHEW4(N2,N1,N4,N3,N6,N5)/ZS234+
21259      >        HWHEW4(N2,N1,N6,N5,N4,N3)/ZS256
21260       HELSUM=0.0
21261       HELCTY=0.0
21262       DO 1 I=1,8
21263         AMM=DREAL(ZAMM(I)*DCONJG(ZAMM(I)))
21264         HELSUM=HELSUM+CPALL(I)*AMM
21265         HELCTY=HELCTY+CPFAC(ID1,ID2,I)*AMM
21266  1    CONTINUE
21267       RETURN
21268       END
21269 CDECK  ID>, HWHEWW.
21270 *CMZ :-        -02/05/91  10.58.29  by  Federico Carminati
21271 *-- Author :    Zoltan Kunszt, modified by Bryan Webber
21272 C-----------------------------------------------------------------------
21273       SUBROUTINE HWHEWW
21274 C-----------------------------------------------------------------------
21275 C     E+E- -> W+W-/Z0Z0 (BASED ON ZOLTAN KUNSZT'S PROGRAM)
21276 C-----------------------------------------------------------------------
21277       INCLUDE 'HERWIG65.INC'
21278       DOUBLE COMPLEX ZH,ZCH,ZD
21279       DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,ETOT,STOT,FLUXW,GAMM,GIMM,
21280      & WM2,WXMIN,WX1MAX,WX2MAX,FJAC1,FJAC2,WX1,WX2,WMM1,WMM2,XXM,W2BO,
21281      & PST,WEIGHT,TOTSIG,WMASS,WWIDTH,ELST,CV,CA,BR,XMASS,PLAB,PRW,PCM,
21282      & AMPWW(4),CCC,HELSUM,HELCTY,BRZED(12),BRTOT,CPFAC,CPALL,RLL(12),
21283      & RRL(12),DIST(4)
21284       INTEGER IB,IBOS,I,ID1,ID2,NTRY,IDP(10),IDBOS(2),J1,J2,IPRC,ILST,
21285      & IDZOLT(16),MAP(12),NEWHEP
21286       LOGICAL EISBM1,HWRLOG
21287       EXTERNAL HWUAEM,HWRGEN,HWUPCM
21288       SAVE IDP,STOT,FLUXW,GAMM,GIMM,WM2,WXMIN,WX1MAX,FJAC1,ELST,ILST,
21289      & IDBOS,WMASS,WWIDTH,BRZED
21290       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
21291       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21292       COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
21293       DATA ELST,ILST/0.D0,0/
21294       DATA IDZOLT/4,3,8,7,12,11,4*0,2,1,6,5,10,9/
21295       DATA MAP/12,11,2,1,14,13,4,3,16,15,6,5/
21296       IF (IERROR.NE.0) RETURN
21297       EISBM1=IDHW(1).LT.IDHW(2)
21298       IF (GENEV) THEN
21299         NEWHEP=NHEP
21300         NHEP=NHEP+2
21301         DO 20 IB=1,2
21302         IBOS=IB+NEWHEP
21303         CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
21304         IF (EISBM1) PHEP(3,IBOS)=-PHEP(3,IBOS)
21305         CALL HWVZRO(4,VHEP(1,IBOS))
21306         CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
21307         CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
21308         IDHW(IBOS)=IDBOS(IB)
21309         IDHEP(IBOS)=IDPDG(IDBOS(IB))
21310         JMOHEP(1,IBOS)=1
21311         JMOHEP(2,IBOS)=2
21312         ISTHEP(IBOS)=110
21313         DO 10 I=1,2
21314           CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
21315           IF (EISBM1) PHEP(3,NHEP+I)=-PHEP(3,NHEP+I)
21316           CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
21317 C---STATUS, IDs AND POINTERS
21318           ISTHEP(NHEP+I)=112+I
21319           IDHW(NHEP+I)=IDP(2*IB+I)
21320           IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
21321           JDAHEP(I,IBOS)=NHEP+I
21322           JMOHEP(1,NHEP+I)=IBOS
21323           JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
21324  10     CONTINUE
21325         NHEP=NHEP+2
21326         JMOHEP(2,NHEP)=NHEP-1
21327         JDAHEP(2,NHEP)=NHEP-1
21328         JMOHEP(2,NHEP-1)=NHEP
21329         JDAHEP(2,NHEP-1)=NHEP
21330  20     CONTINUE
21331       ELSE
21332         EMSCA=PHEP(5,3)
21333         ETOT=EMSCA
21334         IPRC=MOD(IPROC,100)
21335         IF (ETOT.NE.ELST .OR. IPRC.NE.ILST) THEN
21336           STOT=ETOT*ETOT
21337           FLUXW=GEV2NB*.125*(HWUAEM(STOT)/PIFAC)**4/STOT
21338           IF (IPRC.EQ.0) THEN
21339             WMASS=RMASS(198)
21340             WWIDTH=GAMW
21341             IDBOS(1)=198
21342             IDBOS(2)=199
21343           ELSEIF (IPRC.EQ.50) THEN
21344             WMASS=RMASS(200)
21345             WWIDTH=GAMZ
21346             IDBOS(1)=200
21347             IDBOS(2)=200
21348 C---LOAD FERMION COUPLINGS TO Z
21349             DO 30 I=1,12
21350               RLL(I)=VFCH(MAP(I),1)+AFCH(MAP(I),1)
21351               RRL(I)=VFCH(MAP(I),1)-AFCH(MAP(I),1)
21352  30         CONTINUE
21353             RLL(11)=0
21354             RRL(11)=0
21355             BRTOT=0
21356             DO 60 J1=1,12
21357               BRZED(J1)=0
21358               DO 50 J2=1,12
21359                 CCC=1
21360                 IF (MOD(J1-1,4).GE.2) CCC=CCC*CAFAC
21361                 IF (MOD(J2-1,4).GE.2) CCC=CCC*CAFAC
21362                 CPFAC(J1,J2,1)=CCC*(RLL(2)**2*RLL(J1)*RLL(J2))**2
21363                 CPFAC(J1,J2,2)=CCC*(RLL(2)**2*RRL(J1)*RLL(J2))**2
21364                 CPFAC(J1,J2,3)=CCC*(RLL(2)**2*RLL(J1)*RRL(J2))**2
21365                 CPFAC(J1,J2,4)=CCC*(RLL(2)**2*RRL(J1)*RRL(J2))**2
21366                 CPFAC(J1,J2,5)=CCC*(RRL(2)**2*RLL(J1)*RLL(J2))**2
21367                 CPFAC(J1,J2,6)=CCC*(RRL(2)**2*RRL(J1)*RLL(J2))**2
21368                 CPFAC(J1,J2,7)=CCC*(RRL(2)**2*RLL(J1)*RRL(J2))**2
21369                 CPFAC(J1,J2,8)=CCC*(RRL(2)**2*RRL(J1)*RRL(J2))**2
21370                 DO 40 I=1,8
21371                   IF (J1.EQ.1.AND.J2.EQ.1) CPALL(I)=0
21372                   CPALL(I)=CPALL(I)+CPFAC(J1,J2,I)
21373                   BRZED(J1)=BRZED(J1)+CPFAC(J1,J2,I)
21374                   BRTOT=BRTOT+CPFAC(J1,J2,I)
21375  40             CONTINUE
21376  50           CONTINUE
21377  60         CONTINUE
21378             DO 70 I=1,12
21379  70           BRZED(I)=BRZED(I)/BRTOT
21380           ELSE
21381             CALL HWWARN('HWHEWW',500,*999)
21382           ENDIF
21383           GAMM=WMASS*WWIDTH
21384           GIMM=1.D0/GAMM
21385           WM2=WMASS*WMASS
21386           WXMIN=ATAN(-WMASS/WWIDTH)
21387           WX1MAX=ATAN((STOT-WM2)*GIMM)
21388           FJAC1=WX1MAX-WXMIN
21389           ILST=IPRC
21390           ELST=ETOT
21391         ENDIF
21392         EVWGT=0
21393 C---CHOOSE W MASSES
21394         WX1=WXMIN+FJAC1*HWRGEN(1)
21395         WMM1=GAMM*TAN(WX1)+WM2
21396         IF (WMM1.LE.0) RETURN
21397         XMASS(1)=SQRT(WMM1)
21398         WX2MAX=ATAN(((ETOT-XMASS(1))**2-WM2)*GIMM)
21399         FJAC2=WX2MAX-WXMIN
21400         WX2=WXMIN+FJAC2*HWRGEN(2)
21401         WMM2=GAMM*TAN(WX2)+WM2
21402         IF (WMM2.LE.0) RETURN
21403         XMASS(2)=SQRT(WMM2)
21404         IF (HWRLOG(HALF))THEN
21405          XXM=XMASS(1)
21406          XMASS(1)=XMASS(2)
21407          XMASS(2)=XXM
21408         ENDIF
21409 C---CTMAX=ANGULAR CUT ON COS W-ANGLE
21410         CALL HWHEW0(1,ETOT,XMASS(1),PRW(1,1),W2BO,CTMAX)
21411         IF (W2BO.EQ.ZERO) RETURN
21412 C---FOR ZZ EVENTS, FORCE BOSE STATISTICS, BY KILLING EVENTS WITH COS1<0
21413         IF (IPRC.NE.0) THEN
21414           IF (PRW(3,1).LT.ZERO) RETURN
21415 C---AND THEN SYMMETRIZE (THIS PROCEDURE VASTLY IMPROVES EFFICIENCY)
21416           IF (HWRLOG(HALF)) THEN
21417             PRW(3,1)=-PRW(3,1)
21418             PRW(3,2)=-PRW(3,2)
21419           ENDIF
21420         ENDIF
21421         PLAB(3,1)=0.5*ETOT
21422         PLAB(4,1)=PLAB(3,1)
21423         PLAB(3,2)=-PLAB(3,1)
21424         PLAB(4,2)=PLAB(3,1)
21425 C
21426 C---LET THE W BOSONS DECAY
21427         NTRY=0
21428  80     NTRY=NTRY+1
21429         DO 90 IB=1,2
21430         CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,1)
21431         PST=HWUPCM(XMASS(IB),RMASS(ID1),RMASS(ID2))
21432         IF (PST.LT.ZERO) THEN
21433           CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,2)
21434           IF (NTRY.LE.NBTRY) GOTO 80
21435 C          CALL HWWARN('HWHEWW',1,*999)
21436           RETURN
21437         ENDIF
21438         PRW(5,IB)=XMASS(IB)
21439         IDP(2*IB+1)=ID1
21440         IDP(2*IB+2)=ID2
21441         PLAB(5,2*IB+1)=RMASS(ID1)
21442         PLAB(5,2*IB+2)=RMASS(ID2)
21443         CALL HWDTWO(PRW(1,IB),PLAB(1,2*IB+1),PLAB(1,2*IB+2),
21444      &              PST,TWO,.TRUE.)
21445  90     CONTINUE
21446         WEIGHT=FLUXW*W2BO*FJAC1*FJAC2*(0.5D0*PIFAC*GIMM)**2
21447         CALL HWHEW1(6)
21448         CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
21449         IF (IPRC.EQ.0) THEN
21450           CALL HWHEW3(5,6,3,4,1,2,AMPWW)
21451           TOTSIG=9.*AMPWW(1)+6.*(AMPWW(2)+AMPWW(3))+4.*AMPWW(4)
21452           EVWGT=TOTSIG*WEIGHT*BR
21453         ELSE
21454           ID1=IDZOLT(IDPDG(IDP(3)))
21455           ID2=IDZOLT(IDPDG(IDP(5)))
21456           CALL HWHEW5(5,6,3,4,1,2,HELSUM,HELCTY,ID1,ID2)
21457           EVWGT=HELCTY*WEIGHT*BR/(BRZED(ID1)*BRZED(ID2))
21458         ENDIF
21459       ENDIF
21460  999  END
21461 CDECK  ID>, HWHGBP.
21462 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
21463 *-- Author :    Peter Richardson
21464 C-----------------------------------------------------------------------
21465       SUBROUTINE HWHGBP
21466 C-----------------------------------------------------------------------
21467 C     Hadron-Hadron to WW/WZ/ZZ (BASED ON ZOLTAN KUNSZT'S PROGRAM)
21468 C-----------------------------------------------------------------------
21469       INCLUDE 'HERWIG65.INC'
21470       DOUBLE COMPLEX ZH,ZCH,ZD
21471       DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,FLUXW,CSW,WMASS(2),XMASS,
21472      &     PLAB,PRW,PCM,HWRUNI,P(5,10),AMPWW,DIST(4),MW2,CFAC1,AMP,
21473      &     MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),FPI4
21474       INTEGER IB,IBOS,I,IDP,IDBOS,IPRC,NEWHEP,J,ICMF,IHEP,IBRAD,K,IOPT,
21475      &     MAP(4),IDRES
21476       LOGICAL PHOTON,GEN
21477       EXTERNAL HWUAEM,HWRGEN,HWUPCM,HWRUNI
21478       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21479       COMMON/HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
21480       COMMON /HWBOSN/XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
21481      &     IDRES,IDP(10),IOPT
21482       DATA MAP/1,2,11,12/
21483       SAVE WMASS,AMPWW,IPRC,PHOTON
21484       PARAMETER(FPI4=24936.72731D0)
21485       DOUBLE PRECISION WI(IMAXCH)
21486       COMMON /HWPSOM/ WI
21487       IF (IERROR.NE.0) RETURN
21488       IF (GENEV) THEN
21489         IF (IPRC.EQ.0) THEN
21490           CALL HWHGB2(AMPWW,IDP,PHOTON)
21491         ELSEIF(IPRC.EQ.10) THEN
21492           CALL HWHGB3(AMPWW,IDP,PHOTON)
21493         ELSEIF(IPRC.EQ.20) THEN
21494           CALL HWHGB4(AMPWW,IDP,PHOTON)
21495           IF((IDP(1).LE.6.AND.MOD(IDP(1),2).EQ.1).OR.
21496      &       (IDP(2).LE.6.AND.MOD(IDP(2),2).EQ.1)) THEN
21497             IDBOS(1)=199
21498             IDP(3) = IDP(3)+6
21499             IDP(4) = IDP(4)-6
21500           ENDIF
21501         ENDIF
21502 C--change the sign of the z component (in CMF) if particle first
21503         IF(IDP(1).LT.IDP(2)) THEN
21504           DO IB=1,2
21505             PRW(3,IB) = -PRW(3,IB)
21506             DO I=1,2
21507               PLAB(3,2*IB+I)=-PLAB(3,2*IB+I)
21508             ENDDO
21509           ENDDO
21510         ENDIF
21511 C--boost particles back to the lab frame from the centre of mass frame
21512         DO IB=1,2
21513           CALL HWULOB(PLAB(1,7),PRW(1,IB),PRW(1,IB))
21514         ENDDO
21515         DO I=1,6
21516           CALL HWULOB(PLAB(1,7),PLAB(1,I),PLAB(1,I))
21517         ENDDO
21518 C--put the particles in the event record
21519 C--first the incoming quarks
21520         ICMF = NHEP+3
21521         DO I=1,2
21522           IHEP = NHEP+I
21523           CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
21524           IDHW(IHEP) = IDP(I)
21525           IDHEP(IHEP)=IDPDG(IDP(I))
21526           ISTHEP(IHEP)=110+I
21527           JMOHEP(1,IHEP)=ICMF
21528           JMOHEP(I,ICMF)=IHEP
21529           JDAHEP(1,IHEP)=ICMF
21530         ENDDO
21531         JMOHEP(2,NHEP+1) = NHEP+2
21532         JMOHEP(2,NHEP+2) = NHEP+1
21533         JDAHEP(2,NHEP+1) = NHEP+2
21534         JDAHEP(2,NHEP+2) = NHEP+1
21535 C--Centre-of-mass energy
21536         ICMF = NHEP+3
21537 C--new for spin correlations
21538         IF(SYSPIN) THEN
21539           IDSPN(1) = ICMF
21540           ISNHEP(ICMF) = 1
21541           JMOSPN(1) = 0
21542           JDASPN(1,1) = 2
21543           JDASPN(2,1) = 5
21544           DECSPN(1) = .FALSE.
21545         ENDIF
21546         IDHW(ICMF)=15
21547         IDHEP(ICMF)=IDPDG(15)
21548         ISTHEP(ICMF)=110
21549         CALL HWVEQU(5,PLAB(1,7),PHEP(1,ICMF))
21550         CALL HWUMAS(PHEP(1,ICMF))
21551         JDAHEP(1,ICMF) = ICMF+1
21552         JDAHEP(2,ICMF) = ICMF+2
21553         NHEP   = NHEP+3
21554         NEWHEP = NHEP
21555         NHEP   = NHEP+2
21556 C--Now the bosons
21557         DO IB=1,2
21558           IBOS=IB+NEWHEP
21559           CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
21560           CALL HWVZRO(4,VHEP(1,IBOS))
21561           CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
21562           CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
21563           IDHW(IBOS)=IDBOS(IB)
21564           IDHEP(IBOS)=IDPDG(IDBOS(IB))
21565           JMOHEP(1,IBOS)=ICMF
21566           JMOHEP(2,IBOS)=ICMF
21567           JDAHEP(2,IBOS)=IBOS
21568           ISTHEP(IBOS)=112+IB
21569         ENDDO
21570 C--now generate the initial state shower
21571         CALL HWBGEN
21572         IF(IERROR.NE.0) RETURN
21573 C--now add the outgoing fermions to the event record
21574         DO 20 IB=1,2
21575         IBOS=IB+NEWHEP
21576         IBRAD = JDAHEP(1,IBOS)
21577         ISTHEP(IBRAD) = 195
21578         DO 10 I=1,2
21579           CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
21580           CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
21581 C--Boost the fermion momenta to the rest frame of the original W
21582           CALL HWULOF(PRW(1,IB),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
21583 C--Now boost back to the lab from rest frame of the W after radiation
21584           CALL HWULOB(PHEP(1,IBRAD),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
21585 C--Set the status and pointers
21586           ISTHEP(NHEP+I)=112+I
21587           IDHW(NHEP+I)=IDP(2*IB+I)
21588           IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
21589           JDAHEP(I,IBRAD)=NHEP+I
21590           JMOHEP(1,NHEP+I)=IBRAD
21591 C--New for spin correlations
21592           IF(SYSPIN) THEN
21593             ISNHEP(NHEP+I)   = 2*IB+I-1
21594             IDSPN(2*IB+I-1)  = NHEP+I
21595             JMOSPN(2*IB+I-1) = 1
21596             DECSPN(2*IB+I-1) = .FALSE.
21597             RHOSPN(1,1,2*IB+I-1) = HALF
21598             RHOSPN(1,2,2*IB+I-1) = ZERO
21599             RHOSPN(2,1,2*IB+I-1) = ZERO
21600             RHOSPN(2,2,2*IB+I-1) = HALF
21601             NSPN = NSPN+1
21602           ENDIF
21603  10     CONTINUE
21604         NHEP=NHEP+2
21605         JMOHEP(2,NHEP)=NHEP-1
21606         JDAHEP(2,NHEP)=NHEP-1
21607         JMOHEP(2,NHEP-1)=NHEP
21608         JDAHEP(2,NHEP-1)=NHEP
21609  20     CONTINUE
21610       ELSE
21611         IF(FSTWGT) THEN
21612           IPRC=MOD(IPROC,100)
21613           IF(MOD(IPRC,5).EQ.0.AND.MOD(IPRC,10).NE.0) THEN
21614             PHOTON = .FALSE.
21615             IPRC = IPRC-5
21616           ELSE
21617             PHOTON = .TRUE.
21618           ENDIF
21619           IOPT=1
21620           IF (IPRC.EQ.0) THEN
21621 C--WW production
21622             IDBOS(1)=199
21623             IDBOS(2)=198
21624             IDRES   =200
21625 C--ZZ production
21626           ELSEIF (IPRC.EQ.10) THEN
21627             IDBOS(1)=200
21628             IDBOS(2)=200
21629             IDRES   =200
21630           ELSEIF(IPRC.EQ.20) THEN
21631 C--WZ production
21632             IDBOS(1)=198
21633             IDBOS(2)=200
21634             IDRES   =198
21635             IOPT = 0
21636           ELSE
21637             CALL HWWARN('HWHGBP',500,*999)
21638           ENDIF
21639           DO I=1,2
21640             WMASS(I)=RMASS(IDBOS(I))
21641           ENDDO
21642 C--calculate the couplings etc
21643           MW2 = RMASS(198)**2
21644           GMW = RMASS(198)*GAMW
21645           MZ2 = RMASS(200)**2
21646           GMZ = RMASS(200)*GAMZ
21647 C--couplings to Z and photon
21648           DO I=1,4
21649             G(I,1) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
21650             G(I,2) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
21651             EE(I)  = QFCH(MAP(I))
21652           ENDDO
21653 C--elements of the CKM matrix for the various decay modes of the W
21654           DO I=1,3
21655             DO J=1,3
21656 C**Bug fix 2/7/01 by BRW (unsquare)
21657               CKM2(3*I-3+J) = VCKM(J,I)
21658 C**End bug fix
21659             ENDDO
21660             CKM2(9+I) = ONE
21661           ENDDO
21662 C--couplings of the up and down
21663           TAUI(1) = -ONE
21664           TAUI(2) =  ONE
21665           DO I=1,2
21666             RF(I)   = -TWO*QFCH(I)*SWEIN
21667             LF(I)   = TAUI(I)+RF(I)
21668           ENDDO
21669           CFAC1 = ONE/THREE
21670           CSW = SQRT((ONE-SWEIN)/SWEIN)
21671         ENDIF
21672         EVWGT=ZERO
21673 C--find the momenta and the phase space weight
21674         CALL HWHGBS(FLUXW,GEN)
21675         IF(.NOT.GEN) RETURN
21676 C--couplings
21677         AMP = FPI4*HWUAEM(EMSCA**2)**4
21678 C--copy the momenta and change the sign of the beam
21679         DO I=1,6
21680           P(1,I)=PLAB(3,I)
21681           P(2,I)=PLAB(1,I)
21682           P(3,I)=PLAB(2,I)
21683           P(4,I)=PLAB(4,I)
21684         ENDDO
21685         DO 120 J=1,4
21686         DO 130 K=3,6
21687   130   PCM(J,K)=P(J,K)
21688         PCM(J,1)=-P(J,1)
21689         PCM(J,2)=-P(J,2)
21690   120   CONTINUE
21691 C--use the e+e- code to calulate the spinor products
21692         CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
21693 C--calculate the matrix elements
21694        IF (IPRC.EQ.0) THEN
21695 C--WW matrix element
21696          CALL HWHGB2(AMPWW,IDP,PHOTON)
21697        ELSEIF(IPRC.EQ.10) THEN
21698 C--ZZ matrix element
21699          CALL HWHGB3(AMPWW,IDP,PHOTON)
21700        ELSEIF(IPRC.EQ.20) THEN
21701 C--WZ matrix element
21702          CALL HWHGB4(AMPWW,IDP,PHOTON)
21703        ENDIF
21704 C--Now calculate the cross section
21705        EVWGT = AMPWW*FLUXW*AMP
21706        IF(OPTM) THEN
21707          DO I=1,IMAXCH
21708            IF(CHON(I)) WI(I) = WI(I)*AMPWW**2*AMP**2
21709          ENDDO
21710        ENDIF
21711       ENDIF
21712  999  END
21713 CDECK  ID>, HWHGBS.
21714 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
21715 *-- Author :    Peter Richardson
21716 C-----------------------------------------------------------------------
21717       SUBROUTINE HWHGBS(WEIGHT,GEN)
21718 C-----------------------------------------------------------------------
21719 C     Multichannel phase space for gauge boson pair production
21720 C     ICH returns the channel used is OPTM=.FALSE.
21721 C     ICH specifies the channel to be used if OPTM=.TRUE.
21722 C     This is used in optimising the weights for the different channels
21723 C-----------------------------------------------------------------------
21724       INCLUDE 'HERWIG65.INC'
21725       INTEGER ICH,IDBOS,ISM(2,IMAXCH),I,J,IB(2),IDRES,IDP,IOPT,IPRC,ID1
21726       DOUBLE PRECISION XMASS,PLAB,PRW,PCM,RAND,HWRGEN,BMS2(2),TJAC,PLM,
21727      &     MJAC(2),TWOPI2,SJAC,STOT,THAT,UHAT,TMIN,TMAX,UMIN,UMAX,PS(2),
21728      &     ETOT,HWUPCM,PST,HWRUNI,TAU,XJAC,PHI,SINTH,SIG(2),CV,CA,BR(2),
21729      &     G(IMAXCH),XF,DEM,TN,UN,SN,S1,S2,MB1,MB2,WEIGHT,BRFAC,BRZ(12)
21730       LOGICAL HWRLOG,GEN
21731       COMMON /HWBOSN/ XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
21732      &     IDRES,IDP(10),IOPT
21733       EXTERNAL HWRGEN,HWRLOG,HWUPCM,HWRUNI
21734       SAVE ISM,IPRC
21735       PARAMETER(TWOPI2=39.4784176D0)
21736       DATA SIG/1.0D0,-1.0D0/
21737       DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
21738      &         0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
21739       DOUBLE PRECISION WI(IMAXCH)
21740       COMMON /HWPSOM/ WI
21741       IF(IERROR.NE.0) RETURN
21742       WEIGHT = ZERO
21743       IF(OPTM) THEN
21744         DO I=1,IMAXCH
21745           WI(I) = ZERO
21746         ENDDO
21747       ENDIF
21748       GEN = .FALSE.
21749 C--set the smoothing for the bosons in the various channels
21750       IF(FSTWGT) THEN
21751         IPRC = MOD(IPROC,100)
21752         DO I=1,2
21753           ISM(1,I) = 1
21754           DO J=1,2
21755             ISM(1,4*I-2+J  ) = 1
21756             ISM(1,4*I+J    ) = 2
21757             ISM(2,4*I+2*J-3) = 1
21758             ISM(2,4*I+2*J-2) = 2
21759           ENDDO
21760         ENDDO
21761         ISM(2,1) = 1
21762         ISM(2,2) = 2
21763       ENDIF
21764 C--select the channel to be used
21765       RAND=HWRGEN(0)
21766       DO ICH=1,IMAXCH
21767         IF(CHON(ICH)) THEN
21768           IF(CHNPRB(ICH).GT.RAND) GOTO 10
21769           RAND = RAND-CHNPRB(ICH)
21770         ENDIF
21771       ENDDO
21772  10   CONTINUE
21773 C--select the boson masses and compute that part of the denominator
21774 C--decide which boson to do first
21775       IF(HWRLOG(HALF)) THEN
21776         IB(1) = 1
21777         IB(2) = 2
21778       ELSE
21779         IB(1) = 2
21780         IB(2) = 1
21781       ENDIF
21782 C--find the boson masses
21783       CALL HWHGB1(ISM(IB(1),ICH),2,IDBOS(IB(1)),MJAC(IB(1)),BMS2(IB(1)),
21784      &     (PHEP(5,3)-EMMIN)**2,EMMIN**2)
21785       XMASS(IB(1)) = SQRT(BMS2(IB(1)))
21786       CALL HWHGB1(ISM(IB(2),ICH),2,IDBOS(IB(2)),MJAC(IB(2)),BMS2(IB(2)),
21787      &     (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
21788       XMASS(IB(2)) = SQRT(BMS2(IB(2)))
21789       DO I=1,2
21790         MJAC(I) = HALF*MJAC(I)/TWOPI2
21791       ENDDO
21792 C--now generate the values of s
21793 C--according to a Breit-Wigner for the first two
21794       IF(ICH.LE.2) THEN
21795         CALL HWHGB1(1,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
21796      &        (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
21797 C--according to a power law for the rest
21798       ELSE
21799         CALL HWHGB1(2,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
21800      &        (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
21801       ENDIF
21802       ETOT = SQRT(STOT)
21803 C--find the centre of mass momenta
21804       PST = HWUPCM(ETOT,XMASS(1),XMASS(2))
21805       IF(PST.LT.PTMIN) RETURN
21806       PRW(4,1) = SQRT(BMS2(1)+PST**2)
21807       PRW(4,2) = SQRT(BMS2(2)+PST**2)
21808 C--now generate the value of t and u
21809       PLM = SQRT(PST**2-PTMIN**2)
21810       TMIN   = BMS2(1)-ETOT*(PRW(4,1)+PLM)
21811       TMAX   = BMS2(1)-ETOT*(PRW(4,1)-PLM)
21812       UMIN   = BMS2(2)-ETOT*(PRW(4,2)+PLM)
21813       UMAX   = BMS2(2)-ETOT*(PRW(4,2)-PLM)
21814       SN     = ONE/(TMAX-TMIN)
21815 C--for the first two channels uniform in t
21816       IF(ICH.LE.2) THEN
21817         THAT = HWRUNI(1,TMIN,TMAX)
21818         UHAT = BMS2(1)+BMS2(2)-STOT-THAT
21819         TJAC = TMAX-TMIN
21820 C--for the next four channels generate t according to 1/t
21821       ELSEIF(ICH.LE.6) THEN
21822         CALL HWHGB5(2,TJAC,THAT,TMAX,TMIN)
21823         UHAT = BMS2(1)+BMS2(2)-STOT-THAT
21824 C--for the last four channels generate u according to 1/u
21825       ELSEIF(ICH.LE.10) THEN
21826         CALL HWHGB5(2,TJAC,UHAT,UMAX,UMIN)
21827         THAT = BMS2(1)+BMS2(2)-STOT-UHAT
21828       ELSE
21829         CALL HWWARN('HWHGPS',500,*999)
21830       ENDIF
21831       CALL HWHGB5(1,TN,THAT,TMAX,TMIN)
21832       CALL HWHGB5(1,UN,UHAT,UMAX,UMIN)
21833 C--generate the parton momentum fractions and find the pdf's
21834       TAU = STOT/PHEP(5,3)**2
21835       XX(1) = EXP(HWRUNI(3,LOG(TAU),ZERO))
21836       XX(2) = TAU/XX(1)
21837       XJAC = -LOG(TAU)*XX(1)
21838       XF   = ONE/XJAC
21839       EMSCA=ETOT
21840       CALL HWSGEN(.FALSE.)
21841 C--Centre of mass collison angle
21842       COSTH = (THAT-BMS2(1)+ETOT*PRW(4,1))/ETOT/PST
21843       PHI   = HWRUNI(4,ZERO,TWO*PIFAC)
21844       SINTH = SQRT(ONE-COSTH**2)
21845 C--incoming momenta in the centre of mass frame
21846       DO I=1,2
21847         PLAB(1,I) = ZERO
21848         PLAB(2,I) = ZERO
21849         PLAB(3,I) = HALF*ETOT
21850         PLAB(4,I) = HALF*ETOT
21851         PLAB(5,I) = ZERO
21852       ENDDO
21853       PLAB(3,2) = -PLAB(3,2)
21854 C--outgoing boson momenta in the centre of mass frame
21855       DO I=1,2
21856         PRW(1,I) = SIG(I)*SINTH*COS(PHI)*PST
21857         PRW(2,I) = SIG(I)*SINTH*SIN(PHI)*PST
21858         PRW(3,I) = SIG(I)*COSTH*PST
21859         PRW(5,I) = XMASS(I)
21860       ENDDO
21861 C--now find the boson decay products
21862 C--find the momenta of the boson decay products
21863       IF(IPRC.EQ.20) IDBOS(1)=198
21864       DO 90 I=1,2
21865         CALL HWDBZ2(IDBOS(I),IDP(2*I+1),IDP(2*I+2),CV,CA,BR(I),IOPT,
21866      &        XMASS(I))
21867         IF(BR(I).EQ.ZERO) RETURN
21868         PRW(5,I)=XMASS(I)
21869         PLAB(5,2*I+1) = ZERO
21870         PLAB(5,2*I+2) = ZERO
21871         PS(I) = HALF*XMASS(I)
21872         PLAB(5,2*I+1)=ZERO
21873         PLAB(5,2*I+2)=ZERO
21874         CALL HWDTWO(PRW(1,I),PLAB(1,2*I+1),PLAB(1,2*I+2),
21875      &              PS(I),TWO,.TRUE.)
21876  90   CONTINUE
21877       BRFAC = BR(2)
21878       IF(IOPT.EQ.0) BRFAC = BRFAC*BR(1)
21879       DO I=1,2
21880          IF(IDBOS(I).EQ.200) THEN
21881             ID1 = IDP(1+2*I)
21882             IF(ID1.GE.121) ID1 = ID1-114
21883             BRFAC = BRFAC/BRZ(ID1)
21884          ENDIF
21885       ENDDO
21886       DO I=1,2
21887         MJAC(I) = MJAC(I)*PS(I)/XMASS(I)
21888       ENDDO
21889 C--set up a vector with the centre of mass
21890       PLAB(1,7) = ZERO
21891       PLAB(2,7) = ZERO
21892       PLAB(3,7) = HALF*PHEP(5,3)*(XX(1)-XX(2))
21893       PLAB(4,7) = HALF*PHEP(5,3)*(XX(1)+XX(2))
21894       PLAB(5,7) = ETOT
21895 C--now find the denominator
21896       CALL HWHGB1(1,1,IDRES,S1,STOT,PHEP(5,3)**2,
21897      &     (XMASS(1)+XMASS(2))**2)
21898       CALL HWHGB1(2,1,IDRES,S2,STOT,PHEP(5,3)**2,
21899      &        (XMASS(1)+XMASS(2))**2)
21900       DEM = ZERO
21901       DO I=1,IMAXCH
21902         IF(CHON(I)) THEN
21903 C--factors due to the choice of s and t
21904           IF(I.LE.2) THEN
21905             G(I) = SN*S1
21906           ELSEIF(I.LE.6) THEN
21907             G(I) = TN*S2
21908           ELSE
21909             G(I) = UN*S2
21910           ENDIF
21911 C--factors due to the boson masses
21912           CALL HWHGB1(ISM(IB(1),I),1,IDBOS(IB(1)),MB1,BMS2(IB(1)),
21913      &         (PHEP(5,3)-EMMIN)**2,EMMIN**2)
21914           CALL HWHGB1(ISM(IB(2),I),1,IDBOS(IB(2)),MB2,BMS2(IB(2)),
21915      &         (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
21916           G(I)   = G(I)*MB1*MB2*XF
21917           DEM = DEM+CHNPRB(I)*G(I)
21918         ENDIF
21919       ENDDO
21920 C--now combine everything to get the weight
21921       WEIGHT = GEV2NB*TJAC*SJAC*G(ICH)/DEM/XX(1)*
21922      &     MJAC(1)*MJAC(2)*XJAC/64.0D0/PIFAC/STOT**3*BRFAC
21923       GEN = .TRUE.
21924 C--compute the weights for the different channels if optimizing
21925       IF(OPTM) THEN
21926         DO I=1,IMAXCH
21927           IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
21928         ENDDO
21929       ENDIF
21930  999  END
21931 CDECK  ID>, HWHGB1.
21932 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
21933 *-- Author :    Peter Richardson
21934 C-----------------------------------------------------------------------
21935       SUBROUTINE HWHGB1(ISM,IOPT,IDBOZ,FJAC,MBOS2,MMAX,MMIN)
21936 C-----------------------------------------------------------------------
21937 C     Subroutine to select gauge boson mass for HWHGBP
21938 C     ISM=1 select according to Breit-Wigner for IDBOZ
21939 C     ISM=2 select according to power law  for IDBOZ
21940 C     IOPT=1 return the function at MBOS2
21941 C     IOPT=2 calculate MBOS2
21942 C-----------------------------------------------------------------------
21943       INCLUDE 'HERWIG65.INC'
21944       INTEGER IDBOZ,ISM,IOPT
21945       DOUBLE PRECISION MBOZ,FJAC,GBOZ,GMBOZ,MPOW,MMIN,
21946      &     MBOS2,A1,A2,A01,A02,RPOW,QPOW,HWRGEN,MMAX,EMSQ
21947       EXTERNAL HWRGEN
21948 C--set the boson mass
21949       IF(IDBOZ.EQ.198.OR.IDBOZ.EQ.199) THEN
21950         MBOZ = RMASS(198)
21951         GBOZ = GAMW
21952       ELSEIF(IDBOZ.EQ.200) THEN
21953         MBOZ = RMASS(200)
21954         GBOZ = GAMZ
21955       ELSE
21956          CALL HWWARN('HWHGB1',500,*999)
21957       ENDIF
21958       EMSQ=MBOZ**2
21959       GMBOZ=MBOZ*GBOZ
21960 C--smooth a Breit-Wigner only
21961       IF(ISM.EQ.1) THEN
21962         A02   = ATAN((MMIN-EMSQ)/GMBOZ)
21963         A2    = ATAN((MMAX-EMSQ)/GMBOZ)-A02
21964         IF(IOPT.EQ.1) THEN
21965           FJAC = GMBOZ/((MBOS2-EMSQ)**2+GMBOZ**2)/A2
21966         ELSE
21967           MBOS2 = EMSQ+GMBOZ*TAN(A02+A2*HWRGEN(1))
21968           FJAC  = A2*((MBOS2-EMSQ)**2+GMBOZ**2)/GMBOZ
21969         ENDIF
21970 C--smooth a powerlaw only
21971       ELSEIF(ISM.EQ.2) THEN
21972         IF(EMPOW.EQ.TWO) THEN
21973           A01   = LOG(MMIN)
21974           A1    = LOG(MMAX)-A01
21975           IF(IOPT.EQ.1) THEN
21976             FJAC = ONE/MBOS2/A1
21977           ELSE
21978             MBOS2 = EXP(A01+A1*HWRGEN(2))
21979             FJAC  = A1*MBOS2
21980           ENDIF
21981         ELSE
21982           MPOW = -EMPOW/TWO
21983           QPOW =  ONE+MPOW
21984           RPOW =  ONE/QPOW
21985           A01  =  MMIN**QPOW
21986           A1   = (MMAX**QPOW-A01)
21987           IF(IOPT.EQ.1) THEN
21988             FJAC = QPOW*MBOS2**MPOW/A1
21989           ELSE
21990             MBOS2 = (A01+A1*HWRGEN(2))**RPOW
21991             FJAC  = A1*RPOW/MBOS2**MPOW
21992           ENDIF
21993         ENDIF
21994       ELSE
21995         CALL HWWARN('HWHGB1',501,*999)
21996       ENDIF
21997  999  END
21998 CDECK  ID>, HWHGB2.
21999 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22000 *-- Author :    Peter Richardson
22001 C-----------------------------------------------------------------------
22002       SUBROUTINE HWHGB2(HCS,IDP,PHOTON)
22003 C-----------------------------------------------------------------------
22004 C     WW cross section in hadron hadron
22005 C-----------------------------------------------------------------------
22006       INCLUDE 'HERWIG65.INC'
22007       DOUBLE PRECISION HCS,RCS,HWRGEN,DIST(2),CFAC,WAMP(2),S34,S56,KWW2,
22008      &     MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
22009      &     CSW,CFAC1
22010       DOUBLE COMPLEX ZH,ZCH,ZD,Z1,Z2,ZHF,P12,Z12,S134,S156,AWW,BWW,
22011      &     CWW,DWW,AWWM(2),AWWP(2),HWHEW4
22012       INTEGER IDP(10),I,I1,I2,MAPZ(4,3),P1,P2,P3,P4
22013       PARAMETER(Z1=(0.0D0,1.0D0),Z2=(2.0D0,0.0D0),
22014      &          ZHF=(0.5D0,0.0D0))
22015       LOGICAL PHOTON
22016       EXTERNAL HWRGEN,HWHEW4
22017       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22018       COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22019       DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
22020       SAVE WAMP,AWWM,AWWP
22021       IF(GENEV) THEN
22022         RCS = HCS*HWRGEN(1)
22023       ELSE
22024 C--Now calculate the matrix element
22025         Z12  = ONE/(Z2*ZD(1,2)-MZ2+Z1*GMZ)
22026         P12  = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/ZD(1,2)
22027         S134 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22028         S156 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22029         S34  = DBLE(Z2*ZD(3,4))
22030         S56  = DBLE(Z2*ZD(5,6))
22031         KWW2 = ONE/((S34-MW2)**2+GMW**2)/((S56-MW2)**2+GMW**2)
22032      &            /SWEIN**4/16.0D0
22033         DO I=1,2
22034           DWW     = LF(I)*Z12-RF(I)*P12
22035           CWW     = RF(I)*(Z12-P12)
22036           AWW     = DWW + ZHF*S134*(TAUI(I)+ONE)
22037           BWW     = DWW + ZHF*S156*(TAUI(I)-ONE)
22038           AWWM(I) = AWW*HWHEW4(1,2,3,4,5,6)-BWW*HWHEW4(1,2,5,6,3,4)
22039           AWWP(I) = CWW*(HWHEW4(2,1,5,6,3,4)-HWHEW4(2,1,3,4,5,6))
22040           WAMP(I) = KWW2*DBLE( AWWM(I)*DCONJG(AWWM(I))
22041      &                        +AWWP(I)*DCONJG(AWWP(I)))
22042         ENDDO
22043       ENDIF
22044       HCS = ZERO
22045       CFAC = CFAC1*81.0D0
22046       DO I=1,2
22047         DO I1=1,3
22048           IDP(1) = MAPZ(I,I1)
22049           IDP(2) = IDP(1)+6
22050           DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
22051           DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
22052           DO I2=1,2
22053             HCS = HCS+DIST(I2)*CFAC*WAMP(I)
22054             IF(GENEV.AND.HCS.GT.RCS) THEN
22055 C--new for spin correlations
22056               IF(SYSPIN) THEN
22057                 NSPN = 1
22058                 DO 10 P1=1,2
22059                 DO 10 P2=1,2
22060                 DO 10 P3=1,2
22061                 DO 10 P4=1,2
22062  10             MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
22063                 MESPN(1,2,2,1,1,1) = AWWP(I)
22064                 MESPN(2,2,2,1,1,1) = AWWM(I)
22065                 NCFL(1) = 1
22066                 SPNCFC(1,1,1) = ONE
22067               ENDIF
22068               GOTO 999
22069             ENDIF
22070             IDP(1) = IDP(1)+6
22071             IDP(2) = IDP(2)-6
22072           ENDDO
22073         ENDDO
22074       ENDDO
22075  999  END
22076 CDECK  ID>, HWHGB3.
22077 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22078 *-- Author :    Peter Richardson
22079 C-----------------------------------------------------------------------
22080       SUBROUTINE HWHGB3(HCS,IDP,PHOTON)
22081 C-----------------------------------------------------------------------
22082 C     ZZ cross section in hadron hadron
22083 C-----------------------------------------------------------------------
22084       INCLUDE 'HERWIG65.INC'
22085       DOUBLE PRECISION AMP(2),RCS,HCS,HWRGEN,DIST(2),S34,S56,CFAC,
22086      &     MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
22087      &     CSW,CFAC1
22088       DOUBLE COMPLEX ZH,ZCH,ZD,P34,P56,Z34,Z56,Z1,ZAMP(8),S134,S156,
22089      &        HWHEW4,TAMP,Z0,AMPT(2,2,2,2),CP
22090       INTEGER I,P1,P2,P3,IDP(10),I2,MAPZ(4,3),I1,ID(2),O(2)
22091       EXTERNAL HWHEW4,HWRGEN
22092       LOGICAL PHOTON
22093       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22094       COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22095       PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
22096       DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
22097       DATA O/2,1/
22098       SAVE AMP,ID,AMPT
22099 C--initialisation
22100       IF(GENEV) THEN
22101          RCS = HCS*HWRGEN(0)
22102       ELSE
22103 C--Identitiys of the decay prodcucts (d=1,u=2,e=3,nu=4)
22104         DO I=1,2
22105           ID(I) = IDP(1+2*I)
22106           IF(ID(I).GE.121) ID(I) = ID(I)-114
22107           ID(I) = MOD(ID(I)+1,2)+2*INT((ID(I)-1)/6)+1
22108         ENDDO
22109 C--the various propagators we need
22110         S34 = TWO*DBLE(ZD(3,4))
22111         S56 = TWO*DBLE(ZD(5,6))
22112         Z34 = ONE/(S34-MZ2+Z1*GMZ)
22113         Z56 = ONE/(S56-MZ2+Z1*GMZ)
22114         IF(PHOTON) THEN
22115           P34 = Z34*(S34-MZ2)/S34
22116           P56 = Z56*(S56-MZ2)/S56
22117         ELSE
22118           P34 = Z0
22119           P56 = Z0
22120         ENDIF
22121         S134 = HALF/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22122         S156 = HALF/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22123 C--Now calculate the amplitudes
22124         ZAMP(1)=HWHEW4(1,2,3,4,5,6)*S134+HWHEW4(1,2,5,6,3,4)*S156
22125         ZAMP(2)=HWHEW4(1,2,4,3,5,6)*S134+HWHEW4(1,2,5,6,4,3)*S156
22126         ZAMP(3)=HWHEW4(1,2,3,4,6,5)*S134+HWHEW4(1,2,6,5,3,4)*S156
22127         ZAMP(4)=HWHEW4(1,2,4,3,6,5)*S134+HWHEW4(1,2,6,5,4,3)*S156
22128         ZAMP(5)=HWHEW4(2,1,3,4,5,6)*S156+HWHEW4(2,1,5,6,3,4)*S134
22129         ZAMP(6)=HWHEW4(2,1,4,3,5,6)*S156+HWHEW4(2,1,5,6,4,3)*S134
22130         ZAMP(7)=HWHEW4(2,1,3,4,6,5)*S156+HWHEW4(2,1,6,5,3,4)*S134
22131         ZAMP(8)=HWHEW4(2,1,4,3,6,5)*S156+HWHEW4(2,1,6,5,4,3)*S134
22132 C--Now the amplitudes squared for the process
22133         DO I=1,2
22134           TAMP = Z0
22135           DO P1=1,2
22136             DO P2=1,2
22137               DO P3=1,2
22138                 IF(PHOTON) THEN
22139                   CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
22140      &                +G(I,P1)*EE(I)*G(ID(1),P2)*EE(ID(2))*Z34*P56
22141      &                +G(I,P1)*EE(I)*EE(ID(1))*G(ID(2),P3)*P34*Z56
22142      &                +EE(I)**2*EE(ID(1))*EE(ID(2))*P34*P56
22143                 ELSE
22144                   CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
22145                 ENDIF
22146                 AMPT(I,P1,P2,P3) = ZAMP(4*P1+2*P3+P2-6)*CP
22147                 TAMP = TAMP+AMPT(I,P1,P2,P3)*DCONJG(AMPT(I,P1,P2,P3))
22148               ENDDO
22149             ENDDO
22150           ENDDO
22151           AMP(I) = HALF*DBLE(TAMP)
22152         ENDDO
22153       ENDIF
22154 C--Now calculate the cross section
22155       HCS = 0.0D0
22156       CFAC = CFAC1
22157       IF(ID(1).LE.2) CFAC = CFAC*THREE
22158       IF(ID(2).LE.2) CFAC = CFAC*THREE
22159       DO I=1,2
22160         DO I1=1,3
22161           IDP(1) = MAPZ(I,I1)
22162           IDP(2) = MAPZ(I,I1)+6
22163           DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
22164           DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
22165           DO I2=1,2
22166             HCS = HCS+CFAC*DIST(I2)*AMP(I)
22167             IF(GENEV.AND.HCS.GT.RCS) THEN
22168 C--New for spin correlations
22169               IF(SYSPIN) THEN
22170                 NSPN = 1
22171                 DO 10 P1=1,2
22172                 DO 10 P2=1,2
22173                 DO 10 P3=1,2
22174                 MESPN(P1,P2,P3,1,1,1) = AMPT(I,O(P1),O(P2),O(P3))
22175  10             MESPN(P1,P2,P3,2,1,1) = (0.0D0,0.0D0)
22176                 NCFL(1) = 1
22177                 SPNCFC(1,1,1) = ONE
22178               ENDIF
22179               GOTO 999
22180             ENDIF
22181           ENDDO
22182           IDP(1) = IDP(1)+6
22183           IDP(2) = IDP(2)-6
22184         ENDDO
22185       ENDDO
22186  999  END
22187 CDECK  ID>, HWHGB4.
22188 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22189 *-- Author :    Peter Richardson
22190 C-----------------------------------------------------------------------
22191       SUBROUTINE HWHGB4(HCS,IDP,PHOTON)
22192 C-----------------------------------------------------------------------
22193 C     WZ cross section in hadron hadron
22194 C-----------------------------------------------------------------------
22195       INCLUDE 'HERWIG65.INC'
22196       DOUBLE PRECISION AMP(2),HCS,RCS,HWRGEN,W34,DIST(2),S34,S56,CFAC,
22197      &     TCS,S12,MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),
22198      &     TAUI(2),CSW,CFAC1
22199       DOUBLE COMPLEX ZH,ZCH,ZD,P56,Z56,Z1,Z0,S134,S156,HWHEW4,
22200      &     CP(4),W12,F(4),TAMP(2,2)
22201       INTEGER IDP(10),I,J,I1,I2,I3,ID,P1,P2,P3,P4
22202       LOGICAL PHOTON
22203       EXTERNAL HWRGEN,HWHEW4
22204       COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22205       COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22206       PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
22207       SAVE AMP,ID,TAMP
22208       IF(GENEV) THEN
22209         RCS = HCS*HWRGEN(1)
22210       ELSE
22211 C--identity of the Z decay product (d=1,u=2,e=3,nu=4)
22212         ID = IDP(5)
22213         IF(ID.GE.121) ID = ID-114
22214         ID = MOD(ID+1,2)+2*INT((ID-1)/6)+1
22215 C--the various propagators we need
22216         S12 = TWO*DBLE(ZD(1,2))
22217         S34 = TWO*DBLE(ZD(3,4))
22218         S56 = TWO*DBLE(ZD(5,6))
22219         Z56 = ONE/(S56-MZ2+Z1*GMZ)
22220         IF(PHOTON) THEN
22221           P56 = Z56*(S56-MZ2)/S56
22222         ELSE
22223           P56 = Z0
22224         ENDIF
22225         W12 = ONE/(S12-MW2+Z1*GMW)
22226         S134 = HALF*W12*(S12-MW2)/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22227         S156 = HALF*W12*(S12-MW2)/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22228         W34  = ONE/((S34-MW2)**2+GMW**2)/SWEIN**2/FOUR
22229 C--calculate the coefficents of the various amplitudes
22230         F(1)  = HWHEW4(1,2,3,4,5,6)
22231         F(2)  = HWHEW4(1,2,5,6,3,4)
22232         F(3)  = HWHEW4(1,2,3,4,6,5)
22233         F(4)  = HWHEW4(1,2,6,5,3,4)
22234         DO I=1,2
22235           IF(I.EQ.1) THEN
22236             J=2
22237           ELSE
22238             J=1
22239           ENDIF
22240           CP(1) = G(J,1)*S134-TAUI(I)*CSW*W12
22241           CP(2) = G(I,1)*S156+TAUI(I)*CSW*W12
22242           IF(PHOTON) THEN
22243             CP(3) = EE(J)*S134-TAUI(I)*W12
22244             CP(4) = EE(I)*S156+TAUI(I)*W12
22245           ELSE
22246             CP(3) = Z0
22247             CP(4) = Z0
22248           ENDIF
22249           TAMP(I,1)  = F(1)*(G(ID,1)*Z56*CP(1)+EE(ID)*P56*CP(3))
22250      &                +F(2)*(G(ID,1)*Z56*CP(2)+EE(ID)*P56*CP(4))
22251           TAMP(I,2)  = F(3)*(G(ID,2)*Z56*CP(1)+EE(ID)*P56*CP(3))
22252      &                +F(4)*(G(ID,2)*Z56*CP(2)+EE(ID)*P56*CP(4))
22253           AMP(I) = W34*DBLE( TAMP(I,1)*DCONJG(TAMP(I,1))
22254      &                      +TAMP(I,2)*DCONJG(TAMP(I,2)))
22255         ENDDO
22256       ENDIF
22257 C--Now calculate the cross section
22258       HCS  = ZERO
22259       CFAC = CFAC1*9.0D0
22260       IF(ID.LE.2) CFAC = CFAC*THREE
22261       DO I=1,2
22262         DO I1=1,3
22263           IF(I.EQ.1) THEN
22264             IDP(1) = 2*I1+5
22265             I3 = 1
22266           ELSE
22267             IDP(1) = 2*I1+6
22268             I3 = 0
22269           ENDIF
22270           DO J=1,3
22271             IF(I.EQ.1) THEN
22272               IDP(2) = 2*J
22273 C**Bug fix 2/7/01 by BRW (unsquare)
22274               TCS = VCKM(J,I1)
22275             ELSE
22276               IDP(2) = 2*J-1
22277               TCS = VCKM(I1,J)
22278 C**End bug fix
22279             ENDIF
22280             DIST(1) = TCS*DISF(IDP(1),1)*DISF(IDP(2),2)
22281             DIST(2) = TCS*DISF(IDP(2),1)*DISF(IDP(1),2)
22282             DO I2=1,2
22283               HCS = HCS+CFAC*DIST(I2)*AMP(I)
22284               IF(GENEV.AND.HCS.GT.RCS) GOTO 900
22285             ENDDO
22286           ENDDO
22287         ENDDO
22288       ENDDO
22289  900  IF(GENEV.AND.I2.EQ.2) THEN
22290         I1 = IDP(1)
22291         IDP(1) = IDP(2)
22292         IDP(2) = I1
22293       ENDIF
22294       IF(SYSPIN.AND.GENEV) THEN
22295         NSPN = 1
22296         DO 10 P1=1,2
22297         DO 10 P2=1,2
22298         DO 10 P3=1,2
22299         DO 10 P4=1,2
22300  10     MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
22301         MESPN(2 ,2 ,1 ,1 ,1,1) = TAMP(I,2)
22302         MESPN(2 ,2 ,2 ,1 ,1,1) = TAMP(I,1)
22303         NCFL(1) = 1
22304         SPNCFC(1,1,1) = ONE
22305       ENDIF
22306  999  END
22307 CDECK  ID>, HWHGB5.
22308 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
22309 *-- Author :    Peter Richardson
22310 C-----------------------------------------------------------------------
22311       SUBROUTINE HWHGB5(IOPT,FJAC,T,TMAX,TMIN)
22312 C-----------------------------------------------------------------------
22313 C     Subroutine to select t or u for HWHGBP
22314 C-----------------------------------------------------------------------
22315       INCLUDE 'HERWIG65.INC'
22316       INTEGER IOPT
22317       DOUBLE PRECISION FJAC,TPOW,TMIN,T,A1,A01,RPOW,QPOW,HWRGEN,TMAX,TN,
22318      &     TX,MT
22319       EXTERNAL HWRGEN
22320       TPOW = -1.0D0
22321       TX = -TMIN
22322       TN = -TMAX
22323       IF(TPOW.EQ.-ONE) THEN
22324          A1    = LOG(TX/TN)
22325         IF(IOPT.EQ.1) THEN
22326           FJAC =-ONE/T/A1
22327         ELSE
22328           T = -TN*EXP(A1*HWRGEN(2))
22329           FJAC  =-A1*T
22330         ENDIF
22331       ELSE
22332         QPOW = ONE+TPOW
22333         RPOW = ONE/QPOW
22334         A01   = TN**QPOW
22335         A1    = (TX**QPOW-A01)
22336         IF(IOPT.EQ.1) THEN
22337           MT = -T
22338           FJAC =QPOW*MT**TPOW/A1
22339         ELSE
22340           MT = (A01+A1*HWRGEN(2))**RPOW
22341           T = -MT
22342           FJAC  = A1*RPOW/MT**TPOW
22343         ENDIF
22344       ENDIF
22345  999  END
22346 CDECK  ID>, HWHGRV.
22347 *CMZ :-        -13/10/00  10:48:07  by  Peter Richardson
22348 *-- Author      Kosuke Odagiri
22349 C-----------------------------------------------------------------------
22350       SUBROUTINE HWHGRV
22351 C-----------------------------------------------------------------------
22352 C     Massive spin-2 resonance (massive graviton)
22353 C     Universal tensor coupling to the energy-momentum tensor is assumed
22354 C     viz L = - G(mu,nu) T(mu,nu) / GRVLAM
22355 C     If GAMGRV is zero, it is revaluated during the first run
22356 C     MEAN EVWGT = SIGMA IN NB
22357 C-----------------------------------------------------------------------
22358       INCLUDE 'HERWIG65.INC'
22359       DOUBLE PRECISION HWRGEN,HWRUNI,EPS,EMSQG,
22360      & EMGMG,S,CC,CC2,SS,SS2,M1(16),M2(16),M3,M4,M5(3),M6(3),
22361      & RNGLU,FACT,HCS,FACTR,RCS,A2,A02,QPE,SQPE,RGRV
22362       INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,ID1,ID2,ID3,ID4,
22363      & IADD(2,2)
22364       LOGICAL JGLU,JPHO,JW,JZ,JH
22365       EXTERNAL HWRGEN,HWRUNI
22366       SAVE HCS,JQMN,JQMX,JLMN,JLMX,JGLU,JPHO,JW,JZ,JH,EMSQG,EMGMG,
22367      & A2,A02,FACT,RNGLU,M1,M2,M3,M4,M5,M6
22368       PARAMETER (EPS=1.D-9)
22369       DATA IADD/0,6,6,0/
22370       IF (GENEV) THEN
22371        RCS=HCS*HWRGEN(0)
22372       ELSE
22373        IF (FSTWGT) THEN
22374 C Set limits for which particles to include
22375         JLMN=1
22376         JLMX=0
22377         JQMN=1
22378         JQMX=0
22379         JGLU=.FALSE.
22380         JPHO=.FALSE.
22381         JW  =.FALSE.
22382         JZ  =.FALSE.
22383         JH  =.FALSE.
22384         IMODE=MOD(IPROC,100)
22385         IF (IMODE.EQ.0) THEN
22386          JQMN=1
22387          JQMX=6
22388          JGLU=.TRUE.
22389          JLMN=11
22390          JLMX=16
22391          JPHO=.TRUE.
22392          JW  =.TRUE.
22393          JZ  =.TRUE.
22394          JH  =.TRUE.
22395         ELSEIF (IMODE.EQ.10) THEN
22396          JQMN=1
22397          JQMX=6
22398          JGLU=.TRUE.
22399         ELSEIF (IMODE.GT.10.AND.IMODE.LE.16) THEN
22400          JQMN=IMODE-10
22401          JQMX=IMODE-10
22402         ELSEIF (IMODE.EQ.20) THEN
22403          JGLU=.TRUE.
22404         ELSEIF (IMODE.EQ.50) THEN
22405          JLMN=11
22406          JLMX=16
22407          JPHO=.TRUE.
22408         ELSEIF (IMODE.GT.50.AND.IMODE.LE.56) THEN
22409          JLMN=IMODE-40
22410          JLMX=IMODE-40
22411         ELSEIF (IMODE.EQ.60) THEN
22412          JPHO=.TRUE.
22413         ELSEIF (IMODE.EQ.70) THEN
22414          JW  =.TRUE.
22415          JZ  =.TRUE.
22416          JH  =.TRUE.
22417         ELSEIF (IMODE.EQ.71) THEN
22418          JW  =.TRUE.
22419         ELSEIF (IMODE.EQ.72) THEN
22420          JZ  =.TRUE.
22421         ELSEIF (IMODE.EQ.73) THEN
22422          JH  =.TRUE.
22423         ELSE
22424          CALL HWWARN('HWHGRV',500,*999)
22425         ENDIF
22426         RNGLU=CAFAC**2-ONE
22427         IF (GAMGRV.EQ.ZERO) THEN
22428 C Calculate the width if GAMGRV=ZERO.
22429 C Quarks
22430          DO 10 JQ=1,6
22431           RGRV=(RMASS(JQ)/EMGRV)**2
22432           QPE=ONE-4.D0*RGRV
22433           IF (QPE.GT.ZERO) THEN
22434            SQPE=SQRT(QPE)
22435            GAMGRV=GAMGRV+CAFAC*SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
22436           END IF
22437   10     CONTINUE
22438 C Leptons
22439          DO 20 JL=121,126
22440           RGRV=(RMASS(JL)/EMGRV)**2
22441           QPE=ONE-4.D0*RGRV
22442           IF (QPE.GT.ZERO) THEN
22443            SQPE=SQRT(QPE)
22444            GAMGRV=GAMGRV+SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
22445           END IF
22446   20     CONTINUE
22447 C Photons
22448          GAMGRV=GAMGRV+HALF
22449 C gg
22450          GAMGRV=GAMGRV+HALF*RNGLU
22451 C ZZ
22452          RGRV=(RMASS(200)/EMGRV)**2
22453          QPE=ONE-4.D0*RGRV
22454          IF (QPE.GT.ZERO) THEN
22455           SQPE=SQRT(QPE)
22456           GAMGRV=GAMGRV+SQPE*
22457      &     (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)/TWO
22458          END IF
22459 C WW
22460          RGRV=(RMASS(198)/EMGRV)**2
22461          QPE=ONE-4.D0*RGRV
22462          IF (QPE.GT.ZERO) THEN
22463           SQPE=SQRT(QPE)
22464           GAMGRV=GAMGRV+SQPE*
22465      &     (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)
22466          END IF
22467 C HH
22468          RGRV=(RMASS(201)/EMGRV)**2
22469          QPE=ONE-4.D0*RGRV
22470          IF (QPE.GT.ZERO) THEN
22471           SQPE=SQRT(QPE)
22472           GAMGRV=GAMGRV+SQPE**5/12.D0/TWO
22473          END IF
22474          GAMGRV=GAMGRV*EMGRV**3/(GRVLAM**2*40.D0*PIFAC)
22475         END IF
22476         EMSQG=EMGRV**2
22477         EMGMG=EMGRV*GAMGRV
22478         A02=ATAN((EMMIN**2-EMSQG)/EMGMG)
22479         A2 =ATAN((EMMAX**2-EMSQG)/EMGMG)-A02
22480        ENDIF
22481        EVWGT=0.
22482 C Select a mass for the produced pair
22483        S=EMSQG+EMGMG*TAN(A02+A2*HWRGEN(1))
22484        EMSCA=SQRT(S)
22485 C Select initial momentum fractions
22486        XXMIN=S/PHEP(5,3)**2
22487        XLMIN=LOG(XXMIN)
22488        CALL HWSGEN(.TRUE.)
22489        COSTH=HWRUNI(0,-ONE,ONE)
22490 C
22491        FACT=-GEV2NB*A2*XLMIN*S**2/(GRVLAM**4*EMGMG*16.D0*PIFAC)
22492        CC = COSTH**2
22493        CC2= CC**2
22494        SS = ONE-CC
22495        SS2= SS**2
22496 C QQ,GG -> FF
22497        DO 110 I=1,6
22498          JQ=I
22499          JL=I+10
22500          QPE=ONE-4.D0*RMASS(JQ)**2/S
22501          IF (QPE.GT.ZERO) THEN
22502            SQPE=SQRT(QPE)
22503            M1(JQ)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
22504            M2(JQ)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
22505          ELSE
22506            M1(JQ)=ZERO
22507            M2(JQ)=ZERO
22508          END IF
22509          QPE=ONE-4.D0*RMASS(JL+110)**2/S
22510          IF (QPE.GT.ZERO) THEN
22511            SQPE=SQRT(QPE)
22512            M1(JL)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
22513            M2(JL)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
22514          ELSE
22515            M1(JL)=ZERO
22516            M2(JL)=ZERO
22517          END IF
22518   110  CONTINUE
22519 C QQ,GG -> BB (massless)
22520        M3=SS*(ONE+CC)/32.D0/CAFAC
22521        M4=(CC+SS2/8.D0)/4.D0/RNGLU
22522 C QQ,GG -> W,Z,H
22523        QPE=ONE-4.D0*RMASS(198)**2/S
22524        IF (QPE.GT.ZERO) THEN
22525        SQPE=SQRT(QPE)
22526        M5(1)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/8.D0/CAFAC
22527        M6(1)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/2.D0/RNGLU
22528        ELSE
22529        M5(1)=ZERO
22530        M6(1)=ZERO
22531        END IF
22532        QPE=ONE-4.D0*RMASS(200)**2/S
22533        IF (QPE.GT.ZERO) THEN
22534        SQPE=SQRT(QPE)
22535        M5(2)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/16.D0/CAFAC
22536        M6(2)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/4.D0/RNGLU
22537        ELSE
22538        M5(2)=ZERO
22539        M6(2)=ZERO
22540        END IF
22541        QPE=ONE-4.D0*RMASS(201)**2/S
22542        IF (QPE.GT.ZERO) THEN
22543        SQPE=SQRT(QPE)
22544        M5(3)=SQPE*(QPE**2*SS*CC)/64.D0/CAFAC
22545        M6(3)=SQPE*(QPE**2*SS2)/64.D0/RNGLU
22546        ELSE
22547        M5(3)=ZERO
22548        M6(3)=ZERO
22549        END IF
22550       END IF
22551       HCS=ZERO
22552       DO 90 I=1,2
22553 C I=1 quark first, I=2 anti-quark first
22554        DO 80 IQ=1,6
22555         ID1=IQ+IADD(1,I)
22556         ID2=IQ+IADD(2,I)
22557         IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
22558         FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
22559 C Quark final states
22560         DO 60 JQ=JQMN,JQMX
22561          ID3=JQ
22562          ID4=JQ+6
22563          HCS=HCS+FACTR*M1(JQ)*CAFAC
22564          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
22565   60    CONTINUE
22566 C Lepton final states
22567         DO 70 JL=JLMN,JLMX
22568          ID3=110+JL
22569          ID4=ID3+6
22570          HCS=HCS+FACTR*M1(JL)
22571          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22572   70    CONTINUE
22573 C Bosonic final states
22574         IF (JPHO) THEN
22575          ID3=59
22576          ID4=59
22577          HCS=HCS+FACTR*M3
22578          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22579         END IF
22580         IF (JW) THEN
22581          ID3=198
22582          ID4=199
22583          HCS=HCS+FACTR*M5(1)
22584          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22585         END IF
22586         IF (JZ) THEN
22587          ID3=200
22588          ID4=200
22589          HCS=HCS+FACTR*M5(2)
22590          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22591         END IF
22592         IF (JH) THEN
22593          ID3=201
22594          ID4=201
22595          HCS=HCS+FACTR*M5(3)
22596          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
22597         END IF
22598         IF (JGLU) THEN
22599          ID3=13
22600          ID4=13
22601          HCS=HCS+FACTR*M3*RNGLU
22602          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
22603         END IF
22604   80   CONTINUE
22605   90  CONTINUE
22606 C Gluon initial states
22607       ID1=13
22608       ID2=13
22609       IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
22610       FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
22611 C Quark final states
22612       DO 40 JQ=JQMN,JQMX
22613        ID3=JQ
22614        ID4=JQ+6
22615        HCS=HCS+FACTR*M2(JQ)*CAFAC
22616        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,51,*99)
22617   40  CONTINUE
22618 C Lepton final states
22619       DO 50 JL=JLMN,JLMX
22620        ID3=110+JL
22621        ID4=ID3+6
22622        HCS=HCS+FACTR*M2(JL)
22623        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22624   50  CONTINUE
22625 C Vector boson final states
22626       IF (JPHO) THEN
22627        ID3=59
22628        ID4=59
22629        HCS=HCS+FACTR*M4
22630        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22631       END IF
22632       IF (JW) THEN
22633        ID3=198
22634        ID4=199
22635        HCS=HCS+FACTR*M6(1)
22636        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22637       END IF
22638       IF (JZ) THEN
22639        ID3=200
22640        ID4=200
22641        HCS=HCS+FACTR*M6(2)
22642        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22643       END IF
22644       IF (JH) THEN
22645        ID3=201
22646        ID4=201
22647        HCS=HCS+FACTR*M6(3)
22648        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
22649       END IF
22650       IF (JGLU) THEN
22651        ID3=13
22652        ID4=13
22653        HCS=HCS+FACTR*M4*RNGLU
22654        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,51,*99)
22655       END IF
22656   30  CONTINUE
22657       EVWGT=HCS
22658       RETURN
22659 C Generate event
22660   99  IDN(1)=ID1
22661       IDN(2)=ID2
22662       IDCMF=208
22663       CALL HWETWO(.TRUE.,.TRUE.)
22664       IF (AZSPIN) THEN
22665 C Calculate coefficients for constructing spin density matrices
22666 C Set to zero for now
22667         CALL HWVZRO(7,GCOEF)
22668       END IF
22669   999 END
22670 CDECK  ID>, HWHGUP.
22671 *CMZ :-        -16/07/02  09.40.25  by  Peter Richardson
22672 *-- Author :    Peter Richardson
22673 C----------------------------------------------------------------------
22674       SUBROUTINE HWHGUP
22675 C----------------------------------------------------------------------
22676 C     Use the GUPI (Generic User Process Interface) event common block
22677 C     as the hard process for HERWIG
22678 C----------------------------------------------------------------------
22679       INCLUDE 'HERWIG65.INC'
22680 C--Les Houches Common Block
22681       INTEGER MAXPUP
22682       PARAMETER(MAXPUP=100)
22683       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
22684       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
22685       COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
22686      &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
22687      &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
22688       INTEGER MAXNUP
22689       PARAMETER (MAXNUP=500)
22690       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
22691       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
22692       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
22693      &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
22694      &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
22695      &              SPINUP(MAXNUP)
22696 C--Local variables
22697       COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
22698       INTEGER ILOC,JLOC,JHEP,ID
22699       INTEGER IHEP,IDIN(2),I,IDRES(2,MAXPUP),IRES,ICMF,ISTART,JRES,J
22700       DOUBLE PRECISION PTEMP(5)
22701       CHARACTER *8 DUMMY
22702       LOGICAL HWRLOG
22703       EXTERNAL HWRLOG
22704       IRES = 0
22705 C--zero the variables
22706       DO I=1,NUP
22707          JLOC(I) = 0
22708       ENDDO
22709       DO I=1,NMXHEP
22710          ILOC(I) = 0
22711       ENDDO
22712 c---generate hard subprocess
22713 C--now do the event selection bit
22714       IF(.NOT.GENEV) THEN
22715         IDPRUP = LPRUP(ITYPLH)
22716         CALL UPEVNT_GUP
22717         IF(ABS(IDWTUP).EQ.1.OR.ABS(IDWTUP).EQ.2.OR.
22718      &     ABS(IDWTUP).EQ.4) THEN
22719           EVWGT = XWGTUP*1.0D-3
22720         ELSEIF(ABS(IDWTUP).EQ.3) THEN
22721           EVWGT = SIGN(ONE,XWGTUP)
22722         ELSE
22723           CALL HWWARN('HWHGUP',510,*999)
22724         ENDIF
22725 C--check the sign of the weight
22726         IF(IDWTUP.GT.ZERO.AND.EVWGT.LT.ZERO)
22727      &       CALL HWWARN('HWHGUP',520,*999)
22728         RETURN
22729       ENDIF
22730 C--update the number of events
22731       LHNEVT(ITYPLH) = LHNEVT(ITYPLH)+1
22732       ITYPLH = 0
22733 C--first search to see if there are incoming beam particles in the record
22734       I = 0
22735       DO IHEP=1,NUP
22736         IF(ISTUP(IHEP).EQ.-9) THEN
22737           I=I+1
22738           IF(I.EQ.3) CALL HWWARN('HWHGUP',102,*999)
22739           IDIN(I) = IHEP
22740         ENDIF
22741       ENDDO
22742 C--put the beam particles in the record
22743 C--require the soft event
22744       GENSOF = LHSOFT.AND.HWRLOG(PRSOF)
22745 C--if given for event from event common block
22746       NHEP = 0
22747       IF(I.EQ.2) THEN
22748 C--otherwise from the process common block
22749       ELSEIF(I.EQ.0) THEN
22750         DO I=1,2
22751           CALL HWUIDT(1,IDBMUP(I),IDHW(I),DUMMY)
22752           PHEP(1,I) = ZERO
22753           PHEP(2,I) = ZERO
22754           PHEP(4,I) = EBMUP(I)
22755           PHEP(5,I) = RMASS(IDHW(I))
22756           PHEP(3,I) = SQRT(EBMUP(I)**2-RMASS(IDHW(I))**2)
22757           ISTHEP(I) = 100+I
22758         ENDDO
22759         PHEP(3,2) = -PHEP(3,2)
22760         NHEP = NHEP+2
22761 C--if not correct issue warning
22762       ELSE
22763         CALL HWWARN('HWHGUP',103,*999)
22764       ENDIF
22765 C--setup the centre-of-mass energy
22766       CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PHEP(1,NHEP+1))
22767       CALL HWUMAS(PHEP(1,NHEP+1))
22768       JMOHEP(1,NHEP+1) = NHEP-1
22769       JMOHEP(2,NHEP+1) = NHEP
22770       IDHW(3) = 14
22771       ISTHEP(3) = 103
22772       NHEP = NHEP+1
22773 C--search for the incoming particles in collision
22774       I = 0
22775       DO IHEP=1,NUP
22776         IF(ISTUP(IHEP).EQ.-1) THEN
22777           I = I+1
22778           IF(I.EQ.3) CALL HWWARN('HWHGUP',100,*999)
22779           IDIN(I) = IHEP
22780         ENDIF
22781       ENDDO
22782 C--require two incoming particles
22783       IF(I.NE.2) CALL HWWARN('HWHGUP',101,*999)
22784 C--Now write these particles into the event record
22785       DO I=1,2
22786         IDHEP(NHEP+I) = IDUP(IDIN(I))
22787         ISTHEP(NHEP+I) = 110+I
22788         CALL HWUIDT(1,IDUP(IDIN(I)),IDHW(NHEP+I),DUMMY)
22789         CALL HWVEQU(5,PUP(1,IDIN(I)),PHEP(1,NHEP+I))
22790         JMOHEP(1,NHEP+I) = NHEP+3
22791         ILOC(NHEP+I) = IDIN(I)
22792         JLOC(I) = NHEP+I
22793 C--special for pairtcles which are identical to the beam
22794         DO J=1,2
22795           IF(IDHEP(NHEP+I).EQ.IDHEP(J)) THEN
22796             JDAHEP(1,J) = NHEP+I
22797             JDAHEP(2,J) = NHEP+I
22798           ENDIF
22799         ENDDO
22800       ENDDO
22801       CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
22802       CALL HWUMAS(PHEP(1,NHEP+3))
22803 C--add the hard entry
22804       IDHW(NHEP+3) = 15
22805       ISTHEP(NHEP+3) = 110
22806       JMOHEP(1,NHEP+3) = NHEP+1
22807       JMOHEP(2,NHEP+3) = NHEP+2
22808       JDAHEP(1,NHEP+3) = NHEP+4
22809       NHEP = NHEP+3
22810       ICMF = NHEP
22811 C--now search for the outgoing particles and add them to the event record
22812       DO I=1,NUP
22813 C--normal outgoing particles
22814         IF(ISTUP(I).EQ.1.AND.
22815      &        (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
22816           NHEP = NHEP+1
22817           IDHEP(NHEP) = IDUP(I)
22818           CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
22819           CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
22820           JMOHEP(1,NHEP) = ICMF
22821           JMOHEP(2,NHEP) = 0
22822           JDAHEP(2,NHEP) = 0
22823           ILOC(NHEP) = I
22824           JLOC(I) = NHEP
22825 C--resonances which must have mass preserved and resonances
22826 C-- which don't have to have mass preserved
22827 C--for the time being we won't disguish between these two options
22828         ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
22829      &        (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
22830           NHEP = NHEP+1
22831           IDHEP(NHEP) = IDUP(I)
22832           CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
22833           CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
22834           IRES = IRES+1
22835           IDRES(1,IRES) = NHEP
22836           IDRES(2,IRES) = I
22837           JMOHEP(1,NHEP) = ICMF
22838           JMOHEP(2,NHEP) = 0
22839           JDAHEP(2,NHEP) = 0
22840           ILOC(NHEP) = I
22841           JLOC(I) = NHEP
22842         ELSEIF(ISTUP(I).NE.-9.AND.ISTUP(I).NE.-1.AND.ISTUP(I).NE.1.AND.
22843      &         ISTUP(I).NE.2.AND.ISTUP(I).NE.3) THEN
22844           CALL HWWARN('HWHGUP',500,*999)
22845         ENDIF
22846       ENDDO
22847 C--Modified 2/7/03 for 2->1 processes
22848       IF(ICMF+1.EQ.NHEP) THEN
22849          NHEP = NHEP-1
22850          IDHEP(NHEP) = IDHEP(NHEP+1)
22851          IDHEP(NHEP+1) = 0
22852          IDHW(NHEP) = IDHW(NHEP+1)
22853          IDHW(NHEP+1) = 0
22854          CALL HWVEQU(5,PHEP(1,NHEP+1),PHEP(1,NHEP))
22855          JMOHEP(1,NHEP+1) = 0
22856          JMOHEP(2,NHEP+1) = 0
22857          JDAHEP(1,NHEP+1) = 0
22858          JDAHEP(2,NHEP+1) = 0
22859          JDAHEP(1,NHEP  ) = NHEP
22860          JDAHEP(2,NHEP  ) = NHEP
22861          ILOC(NHEP) = ILOC(NHEP+1)
22862          ILOC(NHEP+1) = 0
22863          JLOC(ILOC(NHEP)) = NHEP
22864          JLOC(NHEP+1) = 0
22865          DO I=1,IRES
22866             IF(IDRES(1,IRES).EQ.NHEP+1) IDRES(1,IRES) = NHEP
22867          ENDDO
22868       ELSE
22869          JDAHEP(2,ICMF) = NHEP
22870 C--setup the status codes
22871          ISTHEP(ICMF+1) = 113
22872          DO IHEP=ICMF+2,NHEP
22873             ISTHEP(IHEP) = 114
22874          ENDDO
22875       ENDIF
22876 C--End mod
22877       ISTART = ICMF-3
22878       EMSCA = SCALUP
22879 C--generate parton shower
22880       CALL HWBGUP(ISTART,ICMF)
22881 C--now we need to sort out the resonances
22882       IF(IRES.EQ.0) RETURN
22883       JRES = 1
22884  35   ID = IDHEP(IDRES(1,JRES))
22885  36   IF(JDAHEP(1,IDRES(1,JRES)).NE.0.AND.
22886      &     JDAHEP(1,IDRES(1,JRES)).NE.IDRES(1,JRES)) THEN
22887         IF(IDHEP(IDRES(1,JRES)).EQ.94) THEN
22888           DO IHEP=JDAHEP(1,IDRES(1,JRES)),JDAHEP(2,IDRES(1,JRES))
22889             IF(IDHEP(IHEP).EQ.ID) THEN
22890               IDRES(1,JRES) = IHEP
22891               GOTO 36
22892             ENDIF
22893           ENDDO
22894         ELSE
22895           IDRES(1,JRES) = JDAHEP(1,IDRES(1,JRES))
22896         ENDIF
22897         GOTO 36
22898       ENDIF
22899 C--make a copy of this particle
22900       IHEP = IDRES(1,JRES)
22901       JMOHEP(1,NHEP+1) = JMOHEP(1,IDRES(1,JRES))
22902       JMOHEP(2,NHEP+1) = JMOHEP(2,IDRES(1,JRES))
22903       IDHEP(NHEP+1) = IDHEP(IDRES(1,JRES))
22904       IDHW(NHEP+1)  =  IDHW(IDRES(1,JRES))
22905       CALL HWVEQU(5,PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP+1))
22906       IDRES(1,JRES) = NHEP+1
22907       JLOC(IDRES(2,JRES)) = IDRES(1,JRES)
22908       ISTHEP(NHEP+1) = 155
22909       NHEP = NHEP+1
22910 C Reset colour pointers (if set)
22911       JHEP=JMOHEP(2,IHEP)
22912       IF (JHEP.GT.0) THEN
22913         IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
22914         IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
22915      &    .AND.ABS(IDHEP(JHEP)).GT.1000000
22916      &    .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
22917       ENDIF
22918       JHEP=JDAHEP(2,IHEP)
22919       IF (JHEP.GT.0) THEN
22920         IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
22921         IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
22922      &    .AND.ABS(IDHEP(JHEP)).GT.1000000
22923      &    .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
22924       ENDIF
22925 C Relabel original track
22926       IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3
22927       JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
22928       JDAHEP(1,IHEP)=NHEP
22929       JDAHEP(2,IHEP)=NHEP
22930 C--look for all the particles which have this as a mother
22931 C--now search for the outgoing particles and add them to the event record
22932       JDAHEP(1,NHEP) = NHEP+1
22933       ISTHEP(NHEP+1) = 113
22934       DO I=1,NUP
22935         IF(ISTUP(I).EQ.1.AND.MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
22936           NHEP = NHEP+1
22937           IDHEP(NHEP) = IDUP(I)
22938           CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
22939           CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
22940           CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
22941           JMOHEP(1,NHEP) = IDRES(1,JRES)
22942           JMOHEP(2,NHEP) = 0
22943           JDAHEP(2,NHEP) = 0
22944           ILOC(NHEP) = I
22945           JLOC(I) = NHEP
22946         ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
22947      &          MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
22948           NHEP = NHEP+1
22949           IDHEP(NHEP) = IDUP(I)
22950           CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
22951           CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
22952           CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
22953           IRES = IRES+1
22954           IDRES(1,IRES) = NHEP
22955           IDRES(2,IRES) = I
22956           JMOHEP(1,NHEP) = IDRES(1,JRES)
22957           JMOHEP(2,NHEP) = 0
22958           JDAHEP(2,NHEP) = 0
22959           ILOC(NHEP) = I
22960           JLOC(I) = NHEP
22961         ENDIF
22962       ENDDO
22963 C--special for top decays to ensure b is second and W is first, this seems
22964 C--to cause problems if the order is the other way around
22965       IF(ABS(IDHEP(IDRES(1,JRES))).EQ.6.AND.
22966      &     NHEP-IDRES(1,JRES).EQ.2) THEN
22967         IF(ABS(IDHEP(NHEP-1)).EQ.5) THEN
22968 C--swap momenta
22969            CALL HWVEQU(5,PHEP(1,NHEP),PTEMP)
22970            CALL HWVEQU(5,PHEP(1,NHEP-1),PHEP(1,NHEP))
22971            CALL HWVEQU(5,PTEMP,PHEP(1,NHEP-1))
22972 C--swap id's
22973            J = IDHW(NHEP)
22974            IDHW(NHEP) = IDHW(NHEP-1)
22975            IDHW(NHEP-1) = J
22976            J = IDHEP(NHEP)
22977            IDHEP(NHEP) = IDHEP(NHEP-1)
22978            IDHEP(NHEP-1) = J
22979 C--locations
22980            J = ILOC(NHEP)
22981            ILOC(NHEP) = ILOC(NHEP-1)
22982            ILOC(NHEP-1) = J
22983            JLOC(ILOC(NHEP-1)) = NHEP-1
22984            JLOC(ILOC(NHEP))   = NHEP
22985 C--resonances
22986            DO I=1,IRES
22987               IF(IDRES(1,I).EQ.NHEP) IDRES(1,I) = NHEP-1
22988            ENDDO
22989         ENDIF
22990       ENDIF
22991       DO IHEP=IDRES(1,JRES)+2,NHEP
22992         ISTHEP(IHEP) = 114
22993       ENDDO
22994       JDAHEP(2,IDRES(1,JRES)) = NHEP
22995       ISTART = IDRES(1,JRES)
22996       EMSCA = PHEP(4,IDRES(1,JRES))
22997       CALL HWBGUP(ISTART,0)
22998       IF(JRES.NE.IRES) THEN
22999         JRES = JRES+1
23000         GOTO 35
23001       ENDIF
23002  999  END
23003 CDECK  ID>, HWHHVY.
23004 *CMZ :-        -18/05/99  14.55.44  by  Kosuke Odagiri
23005 *-- Author :    Bryan Webber
23006 C-----------------------------------------------------------------------
23007       SUBROUTINE HWHHVY
23008 C-----------------------------------------------------------------------
23009 C     QCD HEAVY FLAVOUR PRODUCTION: MEAN EVWGT = SIGMA IN NB
23010 C-----------------------------------------------------------------------
23011       INCLUDE 'HERWIG65.INC'
23012       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,Z1,Z2,ET,EJ,
23013      & QM2,QPE,FACTR,S,T,U,ST,TU,US,TUS,UST,EN,RN,AF,ASTU,
23014      & AUST,CF,CN,CS,CSTU,CSUT,CTSU,CTUS,HCS,UT,SU,GT,DIST,KK,KK2,
23015      & YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
23016       INTEGER IQ1,IQ2,ID1,ID2
23017       LOGICAL HQ1,HQ2
23018       EXTERNAL HWRGEN,HWRUNI,HWUALF
23019       SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US
23020       PARAMETER (EPS=1.D-9)
23021       IF (GENEV) THEN
23022         RCS=HCS*HWRGEN(0)
23023       ELSE
23024         EVWGT=0.
23025         CALL HWRPOW(ET,EJ)
23026         KK = ET/PHEP(5,3)
23027         KK2=KK**2
23028         IF (KK.GE.ONE) RETURN
23029         YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
23030         YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
23031         IF (YJ1INF.GE.YJ1SUP) RETURN
23032         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
23033         YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
23034         YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
23035         IF (YJ2INF.GE.YJ2SUP) RETURN
23036         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
23037         XX(1)=HALF*(Z1+Z2)*KK
23038         IF (XX(1).GE.ONE) RETURN
23039         XX(2)=XX(1)/(Z1*Z2)
23040         IF (XX(2).GE.ONE) RETURN
23041         S=XX(1)*XX(2)*PHEP(5,3)**2
23042         IQ1=MOD(IPROC,100)
23043         QM2=RMASS(IQ1)**2
23044         QPE=S-4.*QM2
23045         IF (QPE.LE.ZERO) RETURN
23046         COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
23047         IF (ABS(COSTH).GT.ONE) RETURN
23048 C---REDEFINE S, T, U AS P1.P2, -P1.P3, -P1.P4
23049         S=HALF*S
23050         T=-HALF*(1.+Z2/Z1)*(HALF*ET)**2
23051         U=-S-T
23052 C---SET EMSCA TO HEAVY HARD PROCESS SCALE
23053         EMSCA=SQRT(4.*S*T*U/(S*S+T*T+U*U))
23054         FACTR = GEV2NB*.125*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
23055      &         *(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
23056         CALL HWSGEN(.FALSE.)
23057 C
23058         ST=S/T
23059         TU=T/U
23060         UT=U/T
23061         US=U/S
23062         SU=S/U
23063         TUS=US/ST
23064         UST=ST/TU
23065 C
23066         EN=CAFAC
23067         RN=CFFAC/EN
23068         AF=FACTR*RN
23069         ASTU=AF*(1.-2.*UST+QM2/T)
23070         AUST=AF*(1.-2.*TUS+QM2/S)
23071         CF=FACTR/(2.*CFFAC)
23072         CN=1./(EN*EN)
23073 C-----------------------------------------------------------------------
23074 C---Heavy flavour colour decomposition modifications below (KO)
23075 C-----------------------------------------------------------------------
23076         CS=(TU+UT-CN/TUS)*(HALF-TUS+QM2/S-QM2**2/U/T/TWO)
23077         CSTU=CF*CS/(ONE+TU**2)
23078         CSUT=CF*CS/(ONE+UT**2)
23079         CS=(SU+US-CN/UST)*(HALF-UST+QM2/T-QM2**2/U/S/TWO)
23080         CTSU=-FACTR*CS/(ONE+SU**2)
23081         CTUS=-FACTR*CS/(ONE+US**2)
23082 C-----------------------------------------------------------------------
23083 C       CS=HALF/TU-QM2/T-HALF*(QM2/T)**2
23084 C       CSTU=CF*(CS-   US**2-QM2/S - CN*(CS+QM2*QM2/(S*T)))
23085 C       CS=HALF*TU-QM2/U-HALF*(QM2/U)**2
23086 C       CSUT=CF*(CS-1./ST**2-QM2/S - CN*(CS+QM2*QM2/(S*U)))
23087 C       CS=HALF*US-QM2/S-HALF*(QM2/S)**2
23088 C       CTSU=-FACTR*(CS-1./TU**2-QM2/T - CN*(CS+QM2*QM2/(S*T)))
23089 C       CS=HALF/US-QM2/U-HALF*(QM2/U)**2
23090 C       CTUS=-FACTR*(CS-   ST**2-QM2/T - CN*(CS+QM2*QM2/(T*U)))
23091 C-----------------------------------------------------------------------
23092       ENDIF
23093 C
23094       HCS=0.
23095       IQ2=IQ1+6
23096       DO 6 ID1=1,13
23097       IF (DISF(ID1,1).LT.EPS) GOTO 6
23098       HQ1=ID1.EQ.IQ1.OR.ID1.EQ.IQ2
23099       DO 5 ID2=1,13
23100       IF (DISF(ID2,2).LT.EPS) GOTO 5
23101       HQ2=ID2.EQ.IQ1.OR.ID2.EQ.IQ2
23102       DIST=DISF(ID1,1)*DISF(ID2,2)
23103       IF (HQ1.OR.HQ2) THEN
23104 C---PROCESSES INVOLVING HEAVY CONSTITUENT
23105 C   N.B. NEGLECT CASE THAT BOTH ARE HEAVY
23106       IF (HQ1.AND.HQ2) GOTO 5
23107       IF (ID1.LT.7) THEN
23108 C---QUARK FIRST
23109        IF (ID2.LT.7) THEN
23110          HCS=HCS+ASTU*DIST
23111          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9)
23112        ELSEIF (ID2.NE.13) THEN
23113          HCS=HCS+ASTU*DIST
23114          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9)
23115        ELSE
23116          HCS=HCS+CTSU*DIST
23117          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9)
23118          HCS=HCS+CTUS*DIST
23119          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9)
23120        ENDIF
23121       ELSEIF (ID1.NE.13) THEN
23122 C---QBAR FIRST
23123        IF (ID2.LT.7) THEN
23124          HCS=HCS+ASTU*DIST
23125          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9)
23126        ELSEIF (ID2.NE.13) THEN
23127          HCS=HCS+ASTU*DIST
23128          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9)
23129        ELSE
23130          HCS=HCS+CTSU*DIST
23131          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9)
23132          HCS=HCS+CTUS*DIST
23133          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9)
23134        ENDIF
23135       ELSE
23136 C---GLUON FIRST
23137        IF (ID2.LT.7) THEN
23138          HCS=HCS+CTSU*DIST
23139          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9)
23140          HCS=HCS+CTUS*DIST
23141          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9)
23142        ELSEIF (ID2.LT.13) THEN
23143          HCS=HCS+CTSU*DIST
23144          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9)
23145          HCS=HCS+CTUS*DIST
23146          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9)
23147        ENDIF
23148       ENDIF
23149       ELSEIF (ID2.NE.13.AND.ID2.EQ.ID1+6) THEN
23150 C---LIGHT Q-QBAR ANNIHILATION
23151          HCS=HCS+AUST*DIST
23152          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413, 4,*9)
23153       ELSEIF (ID1.NE.13.AND.ID1.EQ.ID2+6) THEN
23154 C---LIGHT QBAR-Q ANNIHILATION
23155          HCS=HCS+AUST*DIST
23156          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ2,IQ1,3142,12,*9)
23157       ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN
23158 C---GLUON FUSION
23159          HCS=HCS+CSTU*DIST
23160          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413,27,*9)
23161          HCS=HCS+CSUT*DIST
23162          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,4123,28,*9)
23163       ENDIF
23164     5 CONTINUE
23165     6 CONTINUE
23166       EVWGT=HCS
23167       RETURN
23168 C---GENERATE EVENT
23169     9 IDN(1)=ID1
23170       IDN(2)=ID2
23171       IDCMF=15
23172       CALL HWETWO(.TRUE.,.TRUE.)
23173       IF (AZSPIN) THEN
23174 C Calculate coefficients for constructing spin density matrices
23175          IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
23176      &       IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
23177 C qqbar-->gg or qbarq-->gg
23178             UT=1./TU
23179             GCOEF(1)=UT+TU
23180             GCOEF(2)=-2.
23181             GCOEF(3)=0.
23182             GCOEF(4)=0.
23183             GCOEF(5)=GCOEF(1)
23184             GCOEF(6)=UT-TU
23185             GCOEF(7)=-GCOEF(6)
23186          ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
23187      &           IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
23188      &           IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
23189      &           IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
23190 C qg-->qg or qbarg-->qbarg or gq-->gq  or gqbar-->gqbar
23191             SU=1./US
23192             GCOEF(1)=-(SU+US)
23193             GCOEF(2)=0.
23194             GCOEF(3)=2.
23195             GCOEF(4)=0.
23196             GCOEF(5)=SU-US
23197             GCOEF(6)=GCOEF(1)
23198             GCOEF(7)=-GCOEF(5)
23199          ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
23200 C gg-->qqbar
23201             UT=1./TU
23202             GCOEF(1)=TU+UT
23203             GCOEF(2)=-2.
23204             GCOEF(3)=0.
23205             GCOEF(4)=0.
23206             GCOEF(5)=GCOEF(1)
23207             GCOEF(6)=TU-UT
23208             GCOEF(7)=-GCOEF(6)
23209          ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
23210      &                          IHPRO.EQ.31) THEN
23211 C gg-->gg
23212             GT=S*S+T*T+U*U
23213             GCOEF(2)=2.*U*U*T*T
23214             GCOEF(3)=2.*S*S*U*U
23215             GCOEF(4)=2.*S*S*T*T
23216             GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
23217             GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
23218             GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
23219             GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
23220          ELSE
23221             CALL HWVZRO(7,GCOEF)
23222          ENDIF
23223       ENDIF
23224   999 END
23225 CDECK  ID>, HWHIBG.
23226 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
23227 *-- Author :  Kosuke Odagiri & Stefano Moretti
23228 C-----------------------------------------------------------------------
23229 C...Generate completely differential cross section (EVWGT) in the variables
23230 C...X(I) with I=1,3 (see below) for the processes IPROC=3410,3420,3430,3450
23231 C...as described in the HERWIG 6 documentation file.
23232 C...It includes interface to PDFs and takes into account color connections
23233 C...among partons.
23234 C
23235 C...First release:  6-AUG-1999 by Kosuke Odagiri
23236 C...Last modified:  6-SEP-1999 by Stefano Moretti
23237 C
23238 C-----------------------------------------------------------------------
23239       SUBROUTINE HWHIBG
23240 C-----------------------------------------------------------------------
23241 C     HIGGS + HEAVY QUARK (BOTTOM & TOP) PRODUCTION (2HDM)
23242 C-----------------------------------------------------------------------
23243       INCLUDE 'HERWIG65.INC'
23244       DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS,
23245      & DIST, SM, DM, QPE, PF, SQPE, EMSC2, FACTR, S, T3, U4,
23246      & SN2TH, ME2(0:4), MW, XWEIN, PT2MIN, PT2, GQH(0:4), G1, RMMIN,
23247      & EMG, EMQ, EMH, EMG2, EMQ2, EMH2, EMHWT, ECM_MAX, X(3), XL(3),
23248      & XU(3), WEIGHT, ECM, SHAT, TAU, T, TL, TLMIN, TLMAX, TTMIN, TTMAX,
23249      & CTMP, PCM, PCM2, RCM, RCM2, FKLN
23250       INTEGER ID1, ID2, IH, IQ, I
23251       EXTERNAL HWRGEN, HWUALF, HWUAEM
23252       SAVE HCS,ME2,S,SHAT
23253       PARAMETER (EPS = 1.D-9)
23254       EQUIVALENCE (MW, RMASS(198))
23255       PARAMETER (EMG=0.,EMG2=0.)
23256 C...generate event.
23257       IF (GENEV) THEN
23258         RCS = HCS*HWRGEN(0)
23259       ELSE
23260         HCS = ZERO
23261         EVWGT = ZERO
23262 C...minimum transverse momentum.
23263         PTMIN = ZERO
23264         PT2MIN = PTMIN**2
23265 C...accompanying quark.
23266         IQ=5
23267         IF(IHIGGS.GE.5)IQ=6
23268         EMQ=RMASS(IQ)
23269         EMQ2=EMQ*EMQ
23270 C...on-shell Higgs.
23271         EMH=RMASS(201+IHIGGS)
23272         EMHWT=1.D0
23273         EMH2=EMH*EMH
23274         RMMIN=(EMQ+EMH)/2.
23275 C...energy at hadron level.
23276         ECM_MAX=PBEAM1+PBEAM2
23277         S=ECM_MAX*ECM_MAX
23278 C...phase space variables.
23279 C...IF IQ=5 -> X(1)=(LOG(|T|)-LOG(|TMIN|))/(LOG(|TMAX|)-LOG(|TMIN|),
23280 C...IF IQ=6 -> X(1)=COS(THETA_CM);
23281 C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+EMH)**2-1./ECM_MAX**2),
23282 C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
23283 C...phase space borders.
23284         IF(IQ.EQ.5)XL(1)=0.
23285         IF(IQ.EQ.6)XL(1)=-1.
23286         XU(1)=1.
23287         XL(2)=0.
23288         XU(2)=1.
23289         XL(3)=0.
23290         XU(3)=1.
23291 C...single phase space point.
23292  100    CONTINUE
23293         WEIGHT=1.
23294         DO I=1,3
23295           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
23296           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
23297         END DO
23298 C...energy at parton level.
23299         ECM=SQRT(1./(X(2)*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
23300      &                                    +1./ECM_MAX**2))
23301         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
23302         SHAT=ECM*ECM
23303         TAU=SHAT/S
23304 C...momentum fractions X1 and X2.
23305         XX(1)=EXP(LOG(TAU)*(1.-X(3)))
23306         XX(2)=TAU/XX(1)
23307 C...reconstruct polar angle.
23308         IF(IQ.EQ.5)THEN
23309           PCM2=((SHAT-EMQ2-EMG2)**2
23310      &        -(2.*EMQ*EMG)**2)/(4.*SHAT)
23311           PCM=SQRT(PCM2)
23312           RCM2=((SHAT-EMQ2-EMH2)**2
23313      &        -(2.*EMQ*EMH)**2)/(4.*SHAT)
23314           RCM=SQRT(RCM2)
23315           FKLN=SQRT((SHAT-(EMQ+EMG)**2)*(SHAT-(EMQ-EMG)**2))
23316      &        *SQRT((SHAT-(EMQ+EMH)**2)*(SHAT-(EMQ-EMH)**2))
23317           TTMAX=EMG2+EMQ2-0.5D0/ECM/ECM
23318      &        *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
23319      &    -FKLN)
23320           TTMIN=EMG2+EMQ2-0.5D0/ECM/ECM
23321      &        *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
23322      &    +FKLN)
23323           TLMAX=LOG(ABS(TTMIN))
23324           TLMIN=LOG(ABS(TTMAX))
23325           TL=X(1)*(TLMAX-TLMIN)+TLMIN
23326           T=EXP(TL)
23327           CTMP=-T-EMG2-EMQ2
23328      &       +2.*SQRT(PCM2+EMG2)*SQRT(RCM2+EMQ2)
23329           COSTH = CTMP/2./PCM/RCM
23330         ELSE IF(IQ.EQ.6)THEN
23331           COSTH = X(1)
23332         END IF
23333         SN2TH = 0.25D0 - 0.25D0*COSTH**2
23334         IF((0.25D0-RMMIN**2/SHAT).LT.0.)THEN
23335           EVWGT=0.
23336           RETURN
23337         END IF
23338         T3    = ( SQRT(0.25D0-RMMIN**2/SHAT) * COSTH - HALF ) * SHAT
23339         U4    = - T3 - SHAT
23340         EMSC2 = TWO*SHAT*T3*U4/(SHAT**2+T3**2+U4**2)
23341         EMSCA = SQRT( EMSC2 )
23342         CALL    HWSGEN(.FALSE.)
23343         EVWGT = ZERO
23344         XWEIN = TWO * SWEIN
23345         FACTR = GEV2NB*PIFAC*HWUAEM(EMSC2)/XWEIN/SHAT
23346      &                      *HWUALF(1,EMSCA)/TWO/CAFAC/2.
23347 C...Jacobians from COSTH to X(1).
23348         IF(IQ.EQ.5)THEN
23349           FACTR=FACTR*(TLMAX-TLMIN)/2./PCM/RCM*T
23350         ELSE
23351           CONTINUE
23352         END IF
23353 C...Jacobians from X1,X2 to X(2),X(3).
23354         FACTR=FACTR/S*(-LOG(TAU))*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
23355 C...CKM mixing top/bottom quark.
23356 c bug fix 20/05/01 SM.
23357         IF(IQ.EQ.6)FACTR=FACTR*VCKM(3,3)
23358 c end of bug fix.
23359 C...Higgs resonance.
23360         FACTR=FACTR*EMHWT
23361 C...constant weight.
23362         FACTR=FACTR*WEIGHT
23363 C...SM/MSSM couplings.
23364         IF (IHIGGS.EQ.0) THEN
23365           GQH(0)=(RMASS(5)/MW)**2/TWO
23366         ELSE
23367           G1     = (RMASS(5)/MW/COSB)**2/TWO
23368           GQH(1) = G1*SINA**2
23369           GQH(2) = G1*COSA**2
23370           GQH(3) = G1*SINB**2
23371           GQH(4) = GQH(3)+(RMASS(6)/MW/TANB)**2/TWO
23372         END IF
23373 C...Matrix elements.
23374         DO IH = 0,4
23375           ME2(IH) = ZERO
23376         END DO
23377 c
23378 c g b  -> Q  H
23379 c
23380         ID1 = 5
23381         IH=IHIGGS
23382         IF(IHIGGS.NE.0)IH=IHIGGS-1
23383         IF (IH.EQ.4) ID1 = 6
23384         ID2 = 201+IHIGGS
23385         SM   = RMASS(ID1)+RMASS(ID2)
23386         QPE  = SHAT-SM**2
23387         IF (QPE.GT.ZERO) THEN
23388           DM   = RMASS(ID1)-RMASS(ID2)
23389           QPE  = QPE*(SHAT-DM**2)/SHAT
23390         END IF
23391         PT2  = QPE*SN2TH
23392         IF (PT2.GT.PT2MIN) THEN
23393           SQPE = SQRT(QPE*SHAT)
23394           PF   = SQPE/SHAT
23395           T3   = (SQPE*COSTH - SHAT - SM*DM) / TWO
23396           U4   = - T3 - SHAT
23397           ME2(IH) = FACTR*PF * GQH(IH) *
23398      &     U4/SHAT/T3*(-U4+TWO*SM*DM/T3/U4*SHAT*PT2)
23399         ELSE
23400           ME2(IH) = ZERO
23401         END IF
23402       END IF
23403       HCS = ZERO
23404 c
23405 c     g b
23406       ID1 = 13
23407       ID2 = 5
23408       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23409         DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23410         DO IH = 0,3
23411           HCS = HCS + DIST*ME2(IH)
23412           IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(5,IHIGGS+201,2314,1,*9)
23413         END DO
23414         HCS = HCS + DIST*ME2(4)
23415         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(6,207,2314,1,*9)
23416       END IF
23417 c       _
23418 c     g b
23419       ID1 = 13
23420       ID2 = 11
23421       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23422         DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23423         DO IH = 0,3
23424           HCS = HCS + DIST*ME2(IH)
23425           IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(11,IHIGGS+201,3124,1,*9)
23426         END DO
23427         HCS = HCS + DIST*ME2(4)
23428         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(12,206,3124,1,*9)
23429       END IF
23430 c
23431 c     b g
23432       ID1 = 5
23433       ID2 = 13
23434       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23435         DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23436         DO IH = 0,3
23437           HCS = HCS + DIST*ME2(IH)
23438           IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IHIGGS+201,5,4132,1,*9)
23439         END DO
23440         HCS = HCS + DIST*ME2(4)
23441         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(207,6,4132,1,*9)
23442       END IF
23443 c     _
23444 c     b g
23445       ID1 = 11
23446       ID2 = 13
23447       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23448         DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23449         DO IH = 0,3
23450           HCS = HCS + DIST*ME2(IH)
23451           IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IHIGGS+201,11,2431,1,*9)
23452         END DO
23453         HCS = HCS + DIST*ME2(4)
23454         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(206,12,2431,1,*9)
23455       END IF
23456       EVWGT = HCS
23457       RETURN
23458 C---GENERATE EVENT
23459     9 IDN(1)=ID1
23460       IDN(2)=ID2
23461       IDCMF=15
23462       CALL HWETWO(.TRUE.,.TRUE.)
23463       IF (AZSPIN) THEN
23464 C Calculate coefficients for constructing spin density matrices
23465 C Set to zero for now
23466         CALL HWVZRO(7,GCOEF)
23467       END IF
23468   888 END
23469 CDECK  ID>, HWHIBK.
23470 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
23471 *-- Author :  Stefano Moretti
23472 C-----------------------------------------------------------------------
23473 C...Generate completely differential cross section (EVWGT) in the variables
23474 C...X(I) with I=1,4 (see below) for the process IPROC=3350, as described
23475 C...in the HERWIG 6 documentation file.
23476 C...It includes interface to PDFs and takes into account color connections
23477 C...among partons.
23478 C
23479 C...First release: 8-APR-1999 by Stefano Moretti
23480 C
23481       SUBROUTINE HWHIBK
23482 C-----------------------------------------------------------------------
23483 C     ASSOCIATE PRODUCTION W+H- FROM QUARK FUSION (2HDM)
23484 C-----------------------------------------------------------------------
23485       INCLUDE 'HERWIG65.INC'
23486       INTEGER I,J,IHEL
23487       DOUBLE PRECISION EMH,EMHWT,RMW,EMW
23488       DOUBLE PRECISION RMH01,RMH02,RMH03,RMH
23489       DOUBLE PRECISION X(4),XL(4),XU(4)
23490       DOUBLE PRECISION CT,ST
23491       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
23492       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
23493       DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
23494       DOUBLE PRECISION M2,M2L,M2T
23495       DOUBLE PRECISION ALPHA,EMSC2
23496       DOUBLE PRECISION HWRGEN,HWUAEM
23497       DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
23498       DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
23499       DOUBLE PRECISION WEIGHT
23500       DOUBLE PRECISION VSAVE
23501       SAVE EMH,EMW,HCS,M2,M2L,M2T,FACT,S,CT
23502       LOGICAL HWRLOG
23503       EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2BK,HWETWO,HWRLOG
23504       PARAMETER (EPS=1.D-9)
23505       EQUIVALENCE (RMW  ,RMASS(198))
23506       EQUIVALENCE (RMH01,RMASS(204)),
23507      &            (RMH02,RMASS(203)),
23508      &            (RMH03,RMASS(205)),
23509      &            (RMH  ,RMASS(206))
23510       IF(GENEV)THEN
23511         RCS=HCS*HWRGEN(0)
23512       ELSE
23513         HCS=0.
23514         EVWGT=0.
23515 C...assign final state masses.
23516         EMH=RMH
23517         EMHWT=1.D0
23518 C...energy at hadron level.
23519         ECM_MAX=PBEAM1+PBEAM2
23520         S=ECM_MAX*ECM_MAX
23521 C...phase space variables.
23522 C...X(1)=COS(THETA_CM),
23523 C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMW+EMH)**2-1./ECM_MAX**2),
23524 C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
23525 C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
23526 C...where THETA=ATAN((EMW*EMW-RMW*RMW)/RMW/GAMW);
23527 C...phase space borders.
23528         XL(1)=-1.
23529         XU(1)=1.
23530         XL(2)=0.
23531         XU(2)=1.
23532         XL(3)=0.
23533         XU(3)=1.
23534         XL(4)=0.
23535         XU(4)=1.
23536 C...single phase space point.
23537  100    CONTINUE
23538         WEIGHT=1.
23539         DO I=1,4
23540           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
23541           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
23542         END DO
23543 C...resonant boson mass (limits to -10*W-widths to improve efficiency).
23544         RNMIN=RMW-GAMMAX*GAMW
23545         THETA_MIN=ATAN((RNMIN*RNMIN-RMW*RMW)/RMW/GAMW)
23546         RNMAX=ECM_MAX-EMH
23547         THETA_MAX=ATAN((RNMAX*RNMAX-RMW*RMW)/RMW/GAMW)
23548         EMW=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
23549      &     *RMW*GAMW+RMW*RMW)
23550 C...energy at parton level.
23551         ECM=SQRT(1./(X(2)*(1./(EMW+EMH)**2-1./ECM_MAX**2)
23552      &                                    +1./ECM_MAX**2))
23553         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
23554         SHAT=ECM*ECM
23555         TAU=SHAT/S
23556 C...momentum fractions X1 and X2.
23557         XX(1)=EXP(LOG(TAU)*(1.-X(3)))
23558         XX(2)=TAU/XX(1)
23559 C...two particle kinematics.
23560         CT=X(1)
23561         IF(HWRLOG(HALF))THEN
23562           ST=+SQRT(1.-CT*CT)
23563         ELSE
23564           ST=-SQRT(1.-CT*CT)
23565         END IF
23566         RCM2=((SHAT-EMW*EMW-EMH*EMH)**2
23567      &      -(2.*EMW*EMH)**2)/(4.*SHAT)
23568         RCM=SQRT(RCM2)
23569         P3(0)=SQRT(RCM2+EMW*EMW)
23570         P3(1)=0.
23571         P3(2)=RCM*ST
23572         P3(3)=RCM*CT
23573         P4(0)=SQRT(RCM2+EMH*EMH)
23574         P4(1)=0.
23575         P4(2)=-RCM*ST
23576         P4(3)=-RCM*CT
23577 C...incoming parton: massless.
23578         EMIN=0.
23579 C...initial state momenta in the partonic CM.
23580         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
23581      &      -(2.*EMIN*EMIN)**2)/(4.*SHAT)
23582         PCM=SQRT(PCM2)
23583         P1(0)=SQRT(PCM2+EMIN*EMIN)
23584         P1(1)=0.
23585         P1(2)=0.
23586         P1(3)=PCM
23587         P2(0)=SQRT(PCM2+EMIN*EMIN)
23588         P2(1)=0.
23589         P2(2)=0.
23590         P2(3)=-PCM
23591 C...color structured ME summed/averaged over final/initial spins and colors.
23592         CALL HWH2BK(P1,P2,P3,P4,EMW,EMH,M2,M2L,M2T)
23593         IF(M2.LE.0.)RETURN
23594 C...charge conjugation.
23595         M2=M2*2.
23596         M2L=M2L*2.
23597         M2T=M2T*2.
23598 C...constant factors: phi along beam and conversion GeV^2->nb.
23599         FACT=2.*PIFAC*GEV2NB
23600 C...Jacobians from X1,X2 to X(2),X(3)
23601         FACT=FACT/S*(-LOG(TAU))*(1./(EMW+EMH)**2-1./ECM_MAX**2)
23602 C...phase space Jacobians, pi's and flux.
23603         FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
23604 C...hard scale.
23605         EMSCA=RMW+RMH
23606 C...EW couplings.
23607         EMSC2=EMSCA*EMSCA
23608         ALPHA=HWUAEM(EMSC2)
23609         FACT=FACT*(PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
23610 C...Higgs resonance.
23611         FACT=FACT*EMHWT
23612 C...vector boson resonance.
23613         FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
23614 C...constant weight.
23615         FACT=FACT*WEIGHT
23616       END IF
23617 C...set up PDFs.
23618       HCS=0.
23619       CALL HWSGEN(.FALSE.)
23620       DO I=5,11,6
23621         IF(DISF(I,1).LT.EPS)THEN
23622           GOTO 200
23623         END IF
23624         IF(I.LE.6)J=I+6
23625         IF(I.GE.7)J=I-6
23626         IF(DISF(J,2).LT.EPS)THEN
23627           GOTO 200
23628         END IF
23629         DIST=DISF(I,1)*DISF(J,2)*S
23630 C...no need to set up color connections.
23631         HCS=HCS+M2*DIST*FACT
23632         IF(GENEV.AND.HCS.GT.RCS)THEN
23633 C...generate event.
23634           IDN(1)=I
23635           IDN(2)=J
23636           IDN(3)=NINT(198.+HWRGEN(0))
23637           IF(IDN(3).EQ.198)IDN(4)=207
23638           IF(IDN(3).EQ.199)IDN(4)=206
23639 C...set up status and IDs: use HWETWO.
23640           COSTH=CT
23641           IDCMF=15
23642           ICO(1)=2
23643           ICO(2)=1
23644           ICO(3)=3
23645           ICO(4)=4
23646 C...trick HWETWO in using off-shell V mass
23647           VSAVE=RMASS(IDN(3))
23648           RMASS(IDN(3))=EMW
23649 C-- BRW fix 27/8/04: avoid double smearing of V mass
23650           CALL HWETWO(.FALSE.,.TRUE.)
23651           RMASS(IDN(3))=VSAVE
23652           IF(AZSPIN)THEN
23653 C...set to zero the coefficients of the spin density matrices.
23654             CALL HWVZRO(7,GCOEF)
23655           END IF
23656 C...calculates approximately polarized decay matrix of gauge boson.
23657           IF(IERROR.NE.0)RETURN
23658           IHEL=0
23659           IF(ICHRG(I)*ICHRG(IDN(3)).LT.0.D0)IHEL=1
23660           IF(M2L.LT.0.)M2L=0.
23661           IF(M2T.LT.0.)M2T=0.
23662           RHOHEP(2,NHEP-1)=M2L/M2
23663           RHOHEP(1,NHEP-1)=M2T/M2*(1-IHEL)
23664           RHOHEP(3,NHEP-1)=M2T/M2*(  IHEL)
23665           RETURN
23666         END IF
23667  200    CONTINUE
23668       END DO
23669       EVWGT=HCS
23670       RETURN
23671  999  END
23672 CDECK  ID>, HWHIG1.
23673 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
23674 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
23675 C-----------------------------------------------------------------------
23676       FUNCTION HWHIG1(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
23677 C-----------------------------------------------------------------------
23678 C     Basic matrix elements for Higgs + jet production; used in HWHIGA
23679 C-----------------------------------------------------------------------
23680       IMPLICIT NONE
23681       DOUBLE COMPLEX HWHIG1,HWHIG2,HWHIG5,BI(4),CI(7),DI(3)
23682       DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
23683       INTEGER I,J,K,I1,J1,K1
23684       COMMON/CINTS/BI,CI,DI
23685       PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
23686 C-----------------------------------------------------------------------
23687 C     +++ helicity amplitude for: g+g --> g+H
23688 C-----------------------------------------------------------------------
23689       S1=S-EH2
23690       T1=T-EH2
23691       U1=U-EH2
23692       HWHIG1=EQ2*FOUR*DSQRT(TWO*S*T*U)*(
23693      & -FOUR*(ONE/(U*T)+ONE/(U*U1)+ONE/(T*T1))
23694      & -FOUR*((TWO*S+T)*BI(K)/U1**2+(TWO*S+U)*BI(J)/T1**2)/S
23695      & -(S-FOUR*EQ2)*(S1*CI(I1)+(U-S)*CI(J1)+(T-S)*CI(K1))/(S*T*U)
23696      & -8.D0*EQ2*(CI(J1)/(T*T1)+CI(K1)/(U*U1))
23697      & +HALF*(S-FOUR*EQ2)*(S*T*DI(K)+U*S*DI(J)-U*T*DI(I))/(S*T*U)
23698      & +FOUR*EQ2*DI(I)/S
23699      & -TWO*(U*CI(K)+T*CI(J)+U1*CI(K1)+T1*CI(J1)-U*T*DI(I))/S**2 )
23700       RETURN
23701 C-----------------------------------------------------------------------
23702       ENTRY HWHIG2(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
23703 C-----------------------------------------------------------------------
23704 C     ++- helicity amplitude for: g+g --> g+H
23705 C-----------------------------------------------------------------------
23706       S1=S-EH2
23707       T1=T-EH2
23708       U1=U-EH2
23709       HWHIG2=EQ2*FOUR*DSQRT(TWO*S*T*U)*(FOUR*EH2
23710      & +(EH2-FOUR*EQ2)*(S1*CI(4)+T1*CI(5)+U1*CI(6))
23711      & -HALF*(EH2-FOUR*EQ2)*(S*T*DI(3)+U*S*DI(2)+U*T*DI(1)) )/(S*T*U)
23712       RETURN
23713 C-----------------------------------------------------------------------
23714       ENTRY HWHIG5(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
23715 C-----------------------------------------------------------------------
23716 C     Amplitude for: q+qbar --> g+H
23717 C-----------------------------------------------------------------------
23718       HWHIG5=DCMPLX(TWO)+DCMPLX(TWO*S/(S-EH2))*BI(I)
23719      &      +DCMPLX(FOUR*EQ2-U-T)*CI(K)
23720       RETURN
23721       END
23722 CDECK  ID>, HWHIBQ.
23723 *CMZ :-        -30/06/01  18.40.33  by  Stefano Moretti
23724 *-- Author :  Stefano Moretti
23725 C-----------------------------------------------------------------------
23726 C...Generate completely differential cross section (EVWGT) in the variables
23727 C...X(I) with I=1,6 (see below) for the process IPROC=3500, as described
23728 C...in the HERWIG 6 documentation file.
23729 C...It includes interface to PDFs and takes into account color connections
23730 C...among partons.
23731 C
23732 C...First release: 12-APR-2000 by Stefano Moretti
23733 C
23734 C-----------------------------------------------------------------------
23735       SUBROUTINE HWHIBQ
23736 C-----------------------------------------------------------------------
23737 C     PRODUCTION OF MSSM CHARGED HIGGSES FROM B-QUARK+LIGHT-QUARK FUSION
23738 C-----------------------------------------------------------------------
23739       INCLUDE 'HERWIG65.INC'
23740       INTEGER I,J,K,L,M,N
23741       INTEGER II,JJ,ITMP
23742       INTEGER IFL,IRES
23743       DOUBLE PRECISION EMQ,ENQ,EMQH,EMB,EMH,EMHWT,EMT,EMW
23744       DOUBLE PRECISION EMH01,EMH02,EMH03
23745       DOUBLE PRECISION WCKM,CKM,GAMT
23746       DOUBLE PRECISION X(6),XL(6),XU(6)
23747       DOUBLE PRECISION Q3(0:3),Q35(0:3)
23748       DOUBLE PRECISION Q1(5),Q2(5),H(5)
23749       DOUBLE PRECISION CT4,ST4,CT3,ST3,CF3,SF3,RQ42,RQ4,RQ32,RQ3,PQ3
23750       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
23751       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
23752       DOUBLE PRECISION XTMP
23753       DOUBLE PRECISION EMIN1,EMIN2,PCM2,PCM
23754       DOUBLE PRECISION M2B,M2BBAR
23755       DOUBLE PRECISION ALPHA,EMSC2
23756       DOUBLE PRECISION HWRGEN,HWUAEM
23757       DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
23758       DOUBLE PRECISION QAUX(0:3)
23759       DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
23760       DOUBLE PRECISION WEIGHT
23761       SAVE HCS,M2B,M2BBAR,FACT,S,WCKM,P3,P4,P5
23762       LOGICAL HWRLOG
23763       EXTERNAL HWRGEN,HWUAEM,HWH2BH,HWEONE,HWRLOG,
23764      &         HWUMAS,HWULOB
23765       EQUIVALENCE (EMB,RMASS(5)),(EMT,RMASS(6))
23766       EQUIVALENCE (EMW,RMASS(198))
23767       EQUIVALENCE (EMH01,RMASS(204)),
23768      &            (EMH02,RMASS(203)),
23769      &            (EMH03,RMASS(205))
23770       EQUIVALENCE (CKM,VCKM(3,3))
23771       PARAMETER (EPS=1.D-9)
23772       IF(GENEV)THEN
23773         RCS=HCS*HWRGEN(0)
23774       ELSE
23775         HCS=0.
23776         EVWGT=0.
23777 C...assign final state masses.
23778         EMQ=0.
23779         ENQ=0
23780         EMH=RMASS(206)
23781         EMHWT=1.
23782 C...assign top width.
23783         GAMT=HBAR/RLTIM(6)
23784 C...energy at hadron level.
23785         ECM_MAX=PBEAM1+PBEAM2
23786         S=ECM_MAX*ECM_MAX
23787 C...phase space variables.
23788 C...X(1)=(EMQH-EMQ-EMH)/(ECM-EMQ-ENQ-EMH),
23789 C...X(2)=1/[-(P2-P3)^2+MW^2],X(3)=COS(THETA4_CM_35),X(4)=FI4_CM_35,
23790 C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2),
23791 C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
23792 C...phase space borders.
23793         XL(1)=0.
23794         XU(1)=1.
23795 c...for XL(2),XU(2) see below (non constant).
23796         XL(3)=-1.
23797         XU(3)=1.
23798         XL(4)=0.
23799         XU(4)=2.*PIFAC
23800         XL(5)=0.
23801         XU(5)=1.
23802         XL(6)=0.
23803         XU(6)=1.
23804 C...single phase space point.
23805  100    CONTINUE
23806         WEIGHT=1.
23807         DO I=1,6
23808           IF(I.EQ.2)GOTO 125
23809           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
23810           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
23811  125      CONTINUE
23812         END DO
23813 C...energy at parton level.
23814         ECM=SQRT(1./(X(5)*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
23815      &                                        +1./ECM_MAX**2))
23816         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
23817         SHAT=ECM*ECM
23818         TAU=SHAT/S
23819 C...momentum fractions X1 and X2.
23820         XX(1)=EXP(LOG(TAU)*(1.-X(6)))
23821         XX(2)=TAU/XX(1)
23822 C...incoming partons massless.
23823         EMIN1=0.
23824         EMIN2=0.
23825 C...initial state momenta in the partonic CM.
23826         PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
23827      &         -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
23828         PCM=SQRT(PCM2)
23829 C...three particle kinematics.
23830         EMQH=X(1)*(ECM-EMQ-ENQ-EMH)+EMQ+EMH
23831         RQ42=((ECM*ECM-ENQ*ENQ-EMQH*EMQH)**2-(2.*ENQ*EMQH)**2)/
23832      &       (4.*ECM*ECM)
23833         IF(RQ42.LT.0.)THEN
23834           GOTO 100
23835         ELSE
23836           RQ4=SQRT(RQ42)
23837         ENDIF
23838 C...X(2): integrate over W propagator.
23839         XL(2)=1./(4.*SQRT(PCM2+EMIN2*EMIN2)*RQ4+EMW*EMW)
23840         XU(2)=1./(EMW*EMW)
23841         X(2)=XL(2)+(XU(2)-XL(2))*HWRGEN(0)
23842         WEIGHT=WEIGHT*ABS(XU(2)-XL(2))
23843         XTMP=1./X(2)
23844         XTMP=(XTMP-EMW*EMW)/2./SQRT(PCM2+EMIN2*EMIN2)
23845         CT4=1.-XTMP/((SHAT-EMQH*EMQH+2.*ENQ*ENQ)/(2.*ECM))
23846         IF(CT4.GT.+1.)CT4=+1.
23847         IF(CT4.LT.-1.)CT4=-1.
23848         IF(HWRLOG(HALF))THEN
23849           ST4=+SQRT(1.-CT4*CT4)
23850         ELSE
23851           ST4=-SQRT(1.-CT4*CT4)
23852         END IF
23853         CT3=X(3)
23854         ST3=SQRT(1.-CT3*CT3)
23855         CF3=COS(X(4))
23856         SF3=SIN(X(4))
23857         P4(1)=0.
23858         P4(2)=-RQ4*ST4
23859         P4(3)=-RQ4*CT4
23860         P4(0)=SQRT(RQ42+ENQ*ENQ)
23861         DO I=1,3
23862           Q35(I)=-P4(I)
23863         END DO
23864         Q35(0)=SQRT(RQ42+EMQH*EMQH)
23865         RQ32=((EMQH*EMQH-EMH*EMH-EMQ*EMQ)**2-(2.*EMH*EMQ)**2)/
23866      &      (4.*EMQH*EMQH)
23867         IF(RQ32.LT.0.)THEN
23868           GOTO 100
23869         ELSE
23870           RQ3=SQRT(RQ32)
23871         ENDIF
23872         Q3(1)=RQ3*ST3*CF3
23873         Q3(2)=RQ3*ST3*SF3
23874         Q3(3)=RQ3*CT3
23875         Q3(0)=SQRT(RQ32+EMQ*EMQ)
23876         PQ3=0.
23877         DO I=1,3
23878           PQ3=PQ3+Q35(I)*Q3(I)
23879         END DO
23880         P3(0)=(Q35(0)*Q3(0)+PQ3)/EMQH
23881         P5(0)=Q35(0)-P3(0)
23882         DO I=1,3
23883           P3(I)=Q3(I)+Q35(I)*(P3(0)+Q3(0))/(Q35(0)+EMQH)
23884           P5(I)=Q35(I)-P3(I)
23885         END DO
23886 C...initial state.
23887         P1(0)=SQRT(PCM2+EMIN1*EMIN1)
23888         P1(1)=0.
23889         P1(2)=0.
23890         P1(3)=PCM
23891         P2(0)=SQRT(PCM2+EMIN2*EMIN2)
23892         P2(1)=0.
23893         P2(2)=0.
23894         P2(3)=-PCM
23895 C...option: top diagram removed if can be resonant to avoid double counting.
23896         IRES=1
23897 C        IF((EMT-EMB-EMH).GE.0.)IRES=0
23898 C...color structured ME summed/averaged over final/initial spins and colors.
23899 C...IFL=+1 selects b.
23900         IFL=+1
23901         CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
23902      &              IFL,IRES,CKM,GAMT,M2B)
23903 C...IFL=-1 selects b-bar.
23904         IFL=-1
23905         CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
23906      &              IFL,IRES,CKM,GAMT,M2BBAR)
23907 C...constant factors: phi along beam and conversion GeV^2->nb.
23908         FACT=2.*PIFAC*GEV2NB
23909 C...Jacobians from X1,X2 to X(5),X(6)
23910         FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
23911 C...phase space Jacobians, pi's and flux.
23912         FACT=FACT*RQ3*RQ4/PCM/32./(2.*PIFAC)**5
23913      &      *(ECM-EMQ-ENQ-EMH)
23914         FACT=FACT/2./P2(0)/P4(0)
23915         FACT=FACT*(2.*P2(0)*P4(0)*(1.-CT4)+EMW*EMW)**2
23916 C...EW couplings.
23917         EMSCA=EMQ+ENQ+EMH
23918         EMSC2=EMSCA*EMSCA
23919         ALPHA=HWUAEM(EMSC2)
23920         FACT=FACT*64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
23921 C...Higgs resonance.
23922         FACT=FACT*EMHWT
23923 C...constant weight.
23924         FACT=FACT*WEIGHT
23925       END IF
23926 C...set up PDFs.
23927       HCS=0.
23928       CALL HWSGEN(.FALSE.)
23929       DO I=1,12
23930         IF(DISF(I,1).LT.EPS)THEN
23931           GOTO 200
23932         END IF
23933         DO J=1,12
23934           IF(DISF(J,2).LT.EPS)THEN
23935             GOTO 175
23936           END IF
23937           IF((I.NE.5).AND.(I.NE.11).AND.
23938      &       (J.NE.5).AND.(J.NE.11))THEN
23939             GOTO 150
23940           END IF
23941           II=J
23942           IF((I.NE.5).AND.(I.NE.11))II=I
23943           IF(II.GT.6)II=II-6
23944           ITMP=II
23945           II=(II+1)/2
23946           DIST=0.
23947           DO JJ=1,3
23948             WCKM=VCKM(II,JJ)
23949             IF((ITMP.EQ.5).AND.(II.EQ.3).AND.(JJ.EQ.3))WCKM=0.
23950             DIST=DIST+DISF(I,1)*DISF(J,2)*WCKM*S
23951           END DO
23952           IF((I.LE.6).AND.(J.LE.6))THEN
23953             HCS=HCS+M2B*DIST*FACT
23954           ELSE IF((I.LE.6).AND.(J.GE.7))THEN
23955             IF(J.NE.11)HCS=HCS+M2B*DIST*FACT
23956             IF(J.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
23957           ELSE IF((I.GE.7).AND.(J.LE.6))THEN
23958             IF(I.NE.11)HCS=HCS+M2B*DIST*FACT
23959             IF(I.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
23960           ELSE IF((I.GE.7).AND.(J.GE.7))THEN
23961             HCS=HCS+M2BBAR*DIST*FACT
23962           END IF
23963           IF(GENEV.AND.HCS.GT.RCS)THEN
23964 C...generate event.
23965             IDN(1)=I
23966             IDN(2)=J
23967             IF((I.EQ.5).OR.(I.EQ.11))THEN
23968               K=I
23969               L=J+(-1)**(J+1)
23970               IDN(3)=K
23971               IDN(4)=L
23972             ELSE
23973               L=I+(-1)**(J+1)
23974               K=J
23975               IDN(3)=L
23976               IDN(4)=K
23977             END IF
23978             IF(IDN(2).EQ.IDN(4))THEN
23979               IDN(5)=
23980      &        NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))-ICHRG(IDN(3))))
23981           ELSE
23982               IDN(5)=
23983      &        NINT(198.5-.1667*FLOAT(ICHRG(IDN(2))-ICHRG(IDN(4))))
23984             END IF
23985             IDN(5)=IDN(5)+8
23986 C...sets up incoming status and IDs only for 2->1: use HWEONE.
23987             IDCMF=15
23988             CALL HWEONE
23989             JDAHEP(1,NHEP)=NHEP+1
23990             JDAHEP(2,NHEP)=NHEP+3
23991             JMOHEP(1,NHEP+1)=NHEP
23992             JMOHEP(1,NHEP+2)=NHEP
23993             JMOHEP(1,NHEP+3)=NHEP
23994 C...randomly rotate final state momenta around beam axis.
23995             PHI=2.*PIFAC*HWRGEN(0)
23996             CPHI=COS(PHI)
23997             SPHI=SIN(PHI)
23998             ROT(1,1)=+CPHI
23999             ROT(1,2)=+SPHI
24000             ROT(1,3)=0.
24001             ROT(2,1)=-SPHI
24002             ROT(2,2)=+CPHI
24003             ROT(2,3)=0.
24004             ROT(3,1)=0.
24005             ROT(3,2)=0.
24006             ROT(3,3)=1.
24007             DO L=1,3
24008               DO M=1,3
24009                 QAUX(M)=0.
24010                 DO N=1,3
24011                   IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
24012                   IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
24013                   IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
24014                 END DO
24015               END DO
24016               DO M=1,3
24017                 IF(L.EQ.1)P3(M)=QAUX(M)
24018                 IF(L.EQ.2)P4(M)=QAUX(M)
24019                 IF(L.EQ.3)P5(M)=QAUX(M)
24020               END DO
24021             END DO
24022 C...outgoing momenta (give quark masses non covariantly!)
24023             DO M=1,3
24024               Q1(M)=P3(M)
24025               Q2(M)=P4(M)
24026               H( M)=P5(M)
24027             END DO
24028             Q1(4)=P3(0)
24029             Q2(4)=P4(0)
24030             H( 4)=P5(0)
24031             Q1(5)=RMASS(IDN(3))
24032             Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
24033             Q2(5)=RMASS(IDN(4))
24034             Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
24035             H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
24036             CALL HWUMAS(H)
24037             CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
24038             CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
24039             CALL HWULOB(PHEP(1,NHEP),H ,PHEP(1,NHEP+3))
24040 C...sets up outgoing status and IDs.
24041             ISTHEP(NHEP+1)=113
24042             ISTHEP(NHEP+2)=114
24043             ISTHEP(NHEP+3)=114
24044             IDHW(NHEP+1)=IDN(3)
24045             IDHEP(NHEP+1)=IDPDG(IDN(3))
24046             IDHW(NHEP+2)=IDN(4)
24047             IDHEP(NHEP+2)=IDPDG(IDN(4))
24048             IDHW(NHEP+3)=IDN(5)
24049             IDHEP(NHEP+3)=IDPDG(IDN(5))
24050 C...sets up colour connections.
24051             JMOHEP(2,NHEP+1)=NHEP-2
24052             JMOHEP(2,NHEP+2)=NHEP-1
24053             JMOHEP(2,NHEP-1)=NHEP+2
24054             JMOHEP(2,NHEP-2)=NHEP+1
24055             JMOHEP(2,NHEP+3)=NHEP+3
24056             JDAHEP(2,NHEP+1)=NHEP-2
24057             JDAHEP(2,NHEP+2)=NHEP-1
24058             JDAHEP(2,NHEP-1)=NHEP+2
24059             JDAHEP(2,NHEP-2)=NHEP+1
24060             JDAHEP(2,NHEP+3)=NHEP+3
24061             NHEP=NHEP+3
24062             IF(AZSPIN)THEN
24063 C...set to zero the coefficients of the spin density matrices.
24064               CALL HWVZRO(7,GCOEF)
24065             END IF
24066             RETURN
24067           END IF
24068  150      CONTINUE
24069  175      CONTINUE
24070         END DO
24071  200    CONTINUE
24072       END DO
24073       EVWGT=HCS
24074       RETURN
24075  999  END
24076 CDECK  ID>, HWHIGA.
24077 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
24078 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24079 C-----------------------------------------------------------------------
24080       SUBROUTINE HWHIGA(S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG)
24081 C-----------------------------------------------------------------------
24082 C     Gives amplitudes squared for q-qbar, q(bar)-g and gg -> Higgs +jet
24083 C     IAPHIG (set in HWIGIN)=0: zero mass approximation =1: exact result
24084 C                           =2: infinite mass limit.
24085 C     Only top loop included. A factor (alpha_s**3*alpha_W) is extracted
24086 C-----------------------------------------------------------------------
24087       INCLUDE 'HERWIG65.INC'
24088       DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2,BI(4),
24089      & CI(7),DI(3),EPSI,TAMP(7)
24090       DOUBLE PRECISION S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG,EMW2,RNGLU,RNQRK,
24091      & FLUXGG,FLUXGQ,FLUXQQ,EMQ2,TAMPI(7),TAMPR(7)
24092       INTEGER I
24093       LOGICAL NOMASS
24094       EXTERNAL HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2
24095       COMMON/SMALL/EPSI
24096       COMMON/CINTS/BI,CI,DI
24097       EPSI=DCMPLX(ZERO,-1.D-10)
24098       EMW2=RMASS(198)**2
24099 C Spin and colour flux factors plus enhancement factor
24100       RNGLU=1./FLOAT(NCOLO**2-1)
24101       RNQRK=1./FLOAT(NCOLO)
24102       FLUXGG=.25*RNGLU**2*ENHANC(6)**2
24103       FLUXGQ=.25*RNGLU*RNQRK*ENHANC(6)**2
24104       FLUXQQ=.25*RNQRK**2*ENHANC(6)**2
24105       IF (IAPHIG.EQ.2) THEN
24106 C Infinite mass limit in loops
24107          WTGG=(2./3.)**2*FLOAT(NCOLO*(NCOLO**2-1))
24108      &       *(EMH2**4+S**4+T**4+U**4)/(S*T*U*EMW2)*FLUXGG
24109          WTQQ= 16./9.*(U**2+T**2)/(S*EMW2)*FLUXQQ
24110          WTQG=-16./9.*(U**2+S**2)/(T*EMW2)*FLUXGQ
24111          WTGQ=-16./9.*(S**2+T**2)/(U*EMW2)*FLUXGQ
24112          RETURN
24113       ELSEIF (IAPHIG.EQ.1) THEN
24114 C Exact result for loops
24115          NOMASS=.FALSE.
24116       ELSEIF (IAPHIG.EQ.0) THEN
24117 C Small mass approximation in loops
24118          NOMASS=.TRUE.
24119       ELSE
24120          CALL HWWARN('HWHIGA',500,*999)
24121       ENDIF
24122 C Include only top quark contribution
24123       EMQ2=RMASS(6)**2
24124       BI(1)=HWHIGB(NOMASS,S,ZERO,ZERO,EMQ2)
24125       BI(2)=HWHIGB(NOMASS,T,ZERO,ZERO,EMQ2)
24126       BI(3)=HWHIGB(NOMASS,U,ZERO,ZERO,EMQ2)
24127       BI(4)=HWHIGB(NOMASS,EMH2,ZERO,ZERO,EMQ2)
24128       BI(1)=BI(1)-BI(4)
24129       BI(2)=BI(2)-BI(4)
24130       BI(3)=BI(3)-BI(4)
24131       CI(1)=HWHIGC(NOMASS,S,ZERO,ZERO,EMQ2)
24132       CI(2)=HWHIGC(NOMASS,T,ZERO,ZERO,EMQ2)
24133       CI(3)=HWHIGC(NOMASS,U,ZERO,ZERO,EMQ2)
24134       CI(7)=HWHIGC(NOMASS,EMH2,ZERO,ZERO,EMQ2)
24135       CI(4)=(S*CI(1)-EMH2*CI(7))/(S-EMH2)
24136       CI(5)=(T*CI(2)-EMH2*CI(7))/(T-EMH2)
24137       CI(6)=(U*CI(3)-EMH2*CI(7))/(U-EMH2)
24138       DI(1)=HWHIGD(NOMASS,U,T,EMH2,EMQ2)
24139       DI(2)=HWHIGD(NOMASS,S,U,EMH2,EMQ2)
24140       DI(3)=HWHIGD(NOMASS,S,T,EMH2,EMQ2)
24141 C Compute complex amplitudes
24142       TAMP(1)=HWHIG1(S,T,U,EMH2,EMQ2,1,2,3,4,5,6)
24143       TAMP(2)=HWHIG2(S,T,U,EMH2,EMQ2,1,2,3,0,0,0)
24144       TAMP(3)=HWHIG1(T,S,U,EMH2,EMQ2,2,1,3,5,4,6)
24145       TAMP(4)=HWHIG1(U,T,S,EMH2,EMQ2,3,2,1,6,5,4)
24146       TAMP(5)=HWHIG5(S,T,U,EMH2,EMQ2,1,0,4,0,0,0)
24147       TAMP(6)=HWHIG5(T,S,U,EMH2,EMQ2,2,0,5,0,0,0)
24148       TAMP(7)=HWHIG5(U,T,S,EMH2,EMQ2,3,0,6,0,0,0)
24149       DO 20 I=1,7
24150       TAMPI(I)= DREAL(TAMP(I))
24151   20  TAMPR(I)=-DIMAG(TAMP(I))
24152 C Square and add prefactors
24153       WTGG=0.03125*FLOAT(NCOLO*(NCOLO**2-1))/EMW2
24154      &    *(TAMPR(1)**2+TAMPI(1)**2+TAMPR(2)**2+TAMPI(2)**2
24155      &     +TAMPR(3)**2+TAMPI(3)**2+TAMPR(4)**2+TAMPI(4)**2)*FLUXGG
24156       WTQQ= 16.*(U**2+T**2)/(U+T)**2*EMQ2**2/(S*EMW2)
24157      &     *(TAMPR(5)**2+TAMPI(5)**2)*FLUXQQ
24158       WTQG=-16.*(U**2+S**2)/(U+S)**2*EMQ2**2/(T*EMW2)
24159      &     *(TAMPR(6)**2+TAMPI(6)**2)*FLUXGQ
24160       WTGQ=-16.*(S**2+T**2)/(S+T)**2*EMQ2**2/(U*EMW2)
24161      &     *(TAMPR(7)**2+TAMPI(7)**2)*FLUXGQ
24162  999  RETURN
24163       END
24164 CDECK  ID>, HWHIGB.
24165 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
24166 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24167 C-----------------------------------------------------------------------
24168       FUNCTION HWHIGB(NOMASS,S,T,EH2,EQ2)
24169 C-----------------------------------------------------------------------
24170 C     One loop scalar integrals, used in HWHIGJ.
24171 C     If NOMASS=.TRUE. use a small mass approx. for particle in loop.
24172 C-----------------------------------------------------------------------
24173       INCLUDE 'HERWIG65.INC'
24174       DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWUCI2,HWULI2,EPSI,PII,Z1,Z2
24175       DOUBLE PRECISION S,T,EQ2,EH2,RAT,COSH,DLS,DLT,DLM,RZ12,DL1,DL2,
24176      & ST,ROOT,XP,XM
24177       LOGICAL NOMASS
24178       EXTERNAL HWULI2,HWUCI2
24179       COMMON/SMALL/EPSI
24180 C-----------------------------------------------------------------------
24181 C     B_0(2p1.p2=S;mq,mq)
24182 C-----------------------------------------------------------------------
24183       PII=DCMPLX(ZERO,PIFAC)
24184       IF (NOMASS) THEN
24185          RAT=DABS(S/EQ2)
24186          HWHIGB=-DLOG(RAT)+TWO
24187          IF (S.GT.ZERO) HWHIGB=HWHIGB+PII
24188       ELSE
24189          RAT=S/(FOUR*EQ2)
24190          IF (S.LT.ZERO) THEN
24191             HWHIGB=TWO-TWO*DSQRT(ONE-ONE/RAT)
24192      &                    *DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))
24193          ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
24194             HWHIGB=TWO-TWO*DSQRT(ONE/RAT-ONE)*DASIN(DSQRT(RAT))
24195          ELSEIF (RAT.GT.ONE) THEN
24196             HWHIGB=TWO-DSQRT(ONE-ONE/RAT)
24197      &                *(TWO*DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))-PII)
24198          ENDIF
24199       ENDIF
24200       RETURN
24201 C-----------------------------------------------------------------------
24202       ENTRY HWHIGC(NOMASS,S,T,EH2,EQ2)
24203 C-----------------------------------------------------------------------
24204 C     C_0(p{1,2}^2=0,2p1.p2=S;mq,mq,mq)
24205 C-----------------------------------------------------------------------
24206       PII=DCMPLX(ZERO,PIFAC)
24207       IF (NOMASS) THEN
24208          RAT=DABS(S/EQ2)
24209          HWHIGC=HALF*DLOG(RAT)**2
24210          IF (S.GT.ZERO) HWHIGC=HWHIGC-HALF*PIFAC**2-PII*DLOG(RAT)
24211          HWHIGC=HWHIGC/S
24212       ELSE
24213          RAT=S/(FOUR*EQ2)
24214          IF (S.LT.ZERO) THEN
24215             HWHIGC=TWO*DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))**2/S
24216          ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
24217             HWHIGC=-TWO*(DASIN(DSQRT(RAT)))**2/S
24218          ELSEIF (RAT.GT.ONE) THEN
24219             COSH=DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))
24220             HWHIGC=TWO*(COSH**2-PIFAC**2/FOUR-PII*COSH)/S
24221          ENDIF
24222       ENDIF
24223       RETURN
24224 C-----------------------------------------------------------------------
24225       ENTRY HWHIGD(NOMASS,S,T,EH2,EQ2)
24226 C-----------------------------------------------------------------------
24227 C     D_0(p{1,2,3}^2=0,p4^2=EH2,2p1.p2=S,2p2.p3=T;mq,mq,mq,mq)
24228 C-----------------------------------------------------------------------
24229       PII=DCMPLX(ZERO,PIFAC)
24230       IF (NOMASS) THEN
24231          DLS=DLOG(DABS(S/EQ2))
24232          DLT=DLOG(DABS(T/EQ2))
24233          DLM=DLOG(DABS(EH2/EQ2))
24234          IF (S.GE.ZERO.AND.T.LE.ZERO) THEN
24235             DL1=DLOG((EH2-T)/S)
24236             Z1=T/(T-EH2)
24237             Z2=(S-EH2)/S
24238             HWHIGD=DLS**2+DLT**2-DLM**2+DL1**2
24239      &            +TWO*(DLOG(S/(EH2-T))*DLOG(-T/S)+HWULI2(Z1)-HWULI2(Z2)
24240      &                 +PII*DLOG(EH2/(EH2-T)))
24241          ELSEIF (S.LT.ZERO.AND.T.LT.ZERO) THEN
24242             Z1=(S-EH2)/S
24243             Z2=(T-EH2)/T
24244             RZ12=ONE/(Z1*Z2)
24245             DL1=DLOG((T-EH2)/(S-EH2))
24246             DL2=DLOG(RZ12)
24247             HWHIGD=DLS**2+DLT**2-DLM**2+TWO*PIFAC**2/THREE
24248      &            +TWO*DLOG(S/(T-EH2))*DLOG(ONE/DREAL(Z2))
24249      &            +TWO*DLOG(T/(S-EH2))*DLOG(ONE/DREAL(Z1))
24250      &            -DL1**2-DL2**2-TWO*(HWULI2(Z1)+HWULI2(Z2))
24251      &            +TWO*PII*DLOG(RZ12**2*EH2/EQ2)
24252          ENDIF
24253          HWHIGD=HWHIGD/(S*T)
24254       ELSE
24255          ST=S*T
24256          ROOT=DSQRT(ST**2-FOUR*ST*EQ2*(S+T-EH2))
24257          XP=HALF*(ST+ROOT)/ST
24258          XM=1-XP
24259          HWHIGD=TWO/ROOT*(-HWUCI2(EQ2,S,XP)-HWUCI2(EQ2,T,XP)
24260      &         +HWUCI2(EQ2,EH2,XP)+DLOG(-XM/XP)
24261      &         *(LOG(EQ2+EPSI)-LOG(EQ2+EPSI-S*XP*XM)
24262      &          +LOG(EQ2+EPSI-EH2*XP*XM)-LOG(EQ2+EPSI-T*XP*XM)))
24263       ENDIF
24264       RETURN
24265       END
24266 CDECK  ID>, HWHIGE.
24267 *CMZ :-        -13/10/02  09.43.05  by  Peter Richardson
24268 *-- Author :    Kosuke Odagiri and Stefano Moretti
24269 C-----------------------------------------------------------------------
24270 C...Generate completely differential cross section (EVWGT) in the variables
24271 C...X(I) with I=1,4 (see below) for the processes from IPROC=1000-1099 (SM),
24272 C...IPROC=1111-1139 (MSSM), as described in the HERWIG 6 documentation file.
24273 C...(For IPROC=1140-1145 it describes MSSM charged Higgs production.)
24274 C
24275 C...First release: 18-SEP-2002 by Stefano Moretti
24276 C
24277       SUBROUTINE HWHIGE
24278 C--------------------------------------------------------------------------
24279 C     LEPTOPRODUCTION OF MS(SM) HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
24280 C--------------------------------------------------------------------------
24281       INCLUDE 'HERWIG65.INC'
24282       INTEGER JHIGGS
24283       INTEGER I,L,M,N,NN
24284       INTEGER IH,IQ,JQ,IIQ,JJQ
24285       INTEGER IAD
24286       INTEGER IDEC,NC,FLIP
24287       INTEGER ID1,ID2
24288       DOUBLE PRECISION CV,CA,BR
24289       DOUBLE PRECISION BRHIGQ,EMQ,ENQ,GMQ,EMQQ,EMH,GMH,EMHWT,EMW
24290       DOUBLE PRECISION PTMMIN,PTNMIN
24291       DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
24292       DOUBLE PRECISION X(4),XL(4),XU(4)
24293       DOUBLE PRECISION Q4(0:3),Q34(0:3)
24294       DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
24295       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
24296       DOUBLE PRECISION F(0:3),G(0:3)
24297       DOUBLE PRECISION ECM,SHAT,S
24298       DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
24299       DOUBLE PRECISION HFC,HBC
24300       DOUBLE PRECISION M2EE
24301       DOUBLE PRECISION GRND,FACGPM(2)
24302       DOUBLE PRECISION ALPHA,EMSC2
24303       DOUBLE PRECISION HWRGEN,HWUAEM
24304       DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
24305       DOUBLE PRECISION QAUX(0:3)
24306       DOUBLE PRECISION EPS,HCS,RCS,FACT
24307       DOUBLE PRECISION WEIGHT
24308       INTEGER IFL,KHIGGS,JH,JFL
24309       LOGICAL FIRST,GAUGE
24310       DOUBLE PRECISION E,Q3,YM3,GAM3,YM4,GAM4,GAM5,COLOUR
24311       DOUBLE PRECISION RM3,RM4,RM5
24312       DOUBLE PRECISION S2W,RMW,RMZ
24313       DOUBLE PRECISION RMHL,GAMHL
24314       DOUBLE PRECISION RMHH,GAMHH
24315       DOUBLE PRECISION RMHA,GAMHA
24316       EQUIVALENCE (RMHL,RMASS(203)),(RMHH,RMASS(204)),(RMHA,RMASS(205))
24317       LOGICAL HWRLOG
24318       EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWHQCP,HWH2HE,HWEONE,HWRLOG
24319       PARAMETER (EPS=1.D-9)
24320       EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO)
24321       SAVE HCS,M2EE,FACT,S,SHAT,P3,P4,P5
24322       SAVE IIQ,JJQ,JHIGGS
24323 C...ASSIGN Q/Q'-FLAVOUR.
24324       IF(IPROC.GE.1140)THEN
24325         IH=4
24326         IF(IPROC.EQ.1140)IQ=2
24327         IF(IPROC.EQ.1141)IQ=4
24328         IF(IPROC.EQ.1142)IQ=6
24329         IF(IPROC.EQ.1143)IQ=7
24330         IF(IPROC.EQ.1144)IQ=8
24331         IF(IPROC.EQ.1145)IQ=9
24332         IAD=7
24333         JQ=IQ+5
24334         GMQ=ZERO
24335         IF(JQ.EQ.11)GMQ=HBAR/RLTIM(6)
24336       ELSE
24337         IF(IMSSM.EQ.0)THEN
24338           IH=0
24339           IQ=6
24340         ELSE
24341           IF(IPROC.LT.1140)IH=3
24342           IF(IPROC.LT.1130)IH=2
24343           IF(IPROC.LT.1120)IH=1
24344           IQ=IPROC-1100-10*IH
24345         END IF
24346         IAD=6
24347         JQ=IQ+6
24348         GMQ=ZERO
24349       END IF
24350 C...PROCESS EVENT.
24351       IF(GENEV)THEN
24352         RCS=HCS*HWRGEN(0)
24353       ELSE
24354         EVWGT=0.
24355         HCS=0.
24356 C...ASSIGN FINAL STATE MASSES.
24357         IF(IQ.LE.6)THEN
24358           EMQ=RMASS(IQ)
24359           ENQ=RMASS(JQ)
24360         ELSE
24361           EMQ=RMASS(2*IQ-7+114+IAD)
24362           ENQ=RMASS(2*IQ-7+114    )
24363         END IF
24364         EMH=RMASS(201+IHIGGS)
24365         GMH=HBAR/RLTIM(201+IHIGGS)
24366         EMHWT=1.
24367 C...ENERGY AT PARTON LEVEL.
24368         ECM=PBEAM1+PBEAM2
24369         S=ECM*ECM
24370         SHAT=S
24371         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
24372 C...PHASE SPACE VARIABLES.
24373 C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
24374 C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
24375 C...                X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34),
24376 C...HEAVY QUARKS -> X(2)=COS(THETA5_CM),
24377 C...                X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
24378 C...PHASE SPACE BORDERS.
24379         XL(1)=0.
24380         XU(1)=1.
24381         IF((IQ+JQ).EQ.18)THEN
24382           XL(2)=-1.
24383           XL(4)=0.
24384           XU(4)=2.*PIFAC
24385         ELSE
24386           XL(2)=0.
24387           XL(4)=-1.
24388           XU(4)=1.
24389         END IF
24390         XU(2)=1.
24391         XL(3)=-1.
24392         XU(3)=1.
24393 C...SINGLE PHASE SPACE POINT.
24394  100    CONTINUE
24395         WEIGHT=1.
24396         DO I=1,4
24397           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
24398           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
24399         END DO
24400 C...ENERGY AT PARTON LEVEL.
24401         PTMMIN=0.
24402         PTNMIN=0.
24403         IF(IMSSM.NE.0)THEN
24404           IF(IPROC.GE.1140)THEN
24405             PTNMIN=PTMIN
24406           ELSE
24407             IF((IQ.NE.6).AND.(IQ.NE.12).AND.
24408      &         (JQ.NE.6).AND.(JQ.NE.12))THEN
24409               PTMMIN=PTMIN
24410               PTNMIN=PTMIN
24411             ELSE
24412               CONTINUE
24413             END IF
24414           END IF
24415         END IF
24416 C...THREE PARTICLE KINEMATICS.
24417         EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
24418 C...INCOMING PARTONS: ALL MASSLESS.
24419         EMIN=0.
24420         IF((IQ+JQ).EQ.18)THEN
24421           CT5=X(2)
24422           CT4=X(3)
24423           ST4=SQRT(1.-CT4*CT4)
24424           CF4=COS(X(4))
24425           SF4=SIN(X(4))
24426         ELSE
24427           PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2
24428      &        -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM)
24429           PCM=SQRT(PCM2)
24430           RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2
24431      &        -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM)
24432           RCM=SQRT(RCM2)
24433           TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
24434      &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
24435      &    -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
24436      &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
24437           TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
24438      &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
24439      &    +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
24440      &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
24441           TLMIN=LOG(ABS(TTMAX))
24442           TLMAX=LOG(ABS(TTMIN))
24443           TL=X(2)*(TLMAX-TLMIN)+TLMIN
24444           T=EXP(ABS(TL))
24445           CTMP=-T-EMIN**2-EMQQ**2
24446      &       +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2)
24447           CT5=CTMP/2./PCM/RCM
24448           ST4=X(3)
24449           CT4=SQRT(1.-ST4*ST4)
24450           CF4=X(4)
24451           SF4=SQRT(1.-CF4*CF4)
24452         END IF
24453         IF(HWRLOG(HALF))THEN
24454           ST5=+SQRT(1.-CT5*CT5)
24455         ELSE
24456           ST5=-SQRT(1.-CT5*CT5)
24457         END IF
24458         RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/
24459      &     (4.*ECM*ECM)
24460         IF(RQ52.LT.0.)THEN
24461           GOTO 100
24462         ELSE
24463           RQ5=SQRT(RQ52)
24464         ENDIF
24465         P5(1)=0.
24466         P5(2)=RQ5*ST5
24467         P5(3)=RQ5*CT5
24468         P5(0)=SQRT(RQ52+EMH*EMH)
24469         DO I=1,3
24470           Q34(I)=-P5(I)
24471         END DO
24472         Q34(0)=SQRT(RQ52+EMQQ*EMQQ)
24473         RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/
24474      &     (4.*EMQQ*EMQQ)
24475         IF(RQ42.LT.0.)THEN
24476           GOTO 100
24477         ELSE
24478           RQ4=SQRT(RQ42)
24479         ENDIF
24480         Q4(1)=RQ4*ST4*CF4
24481         Q4(2)=RQ4*ST4*SF4
24482         Q4(3)=RQ4*CT4
24483         Q4(0)=SQRT(RQ42+ENQ*ENQ)
24484         PQ4=0.
24485         DO I=1,3
24486           PQ4=PQ4+Q34(I)*Q4(I)
24487         END DO
24488         P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ
24489         P3(0)=Q34(0)-P4(0)
24490         DO I=1,3
24491           P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ)
24492           P3(I)=Q34(I)-P4(I)
24493         END DO
24494         IF(IMSSM.NE.0)THEN
24495           IF(IPROC.GE.1140)THEN
24496             IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
24497           ELSE
24498             IF((IQ.NE.6).AND.(IQ.NE.12).AND.
24499      &         (JQ.NE.6).AND.(JQ.NE.12))THEN
24500               IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
24501               IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
24502             ELSE
24503               CONTINUE
24504             END IF
24505           END IF
24506         END IF
24507 C...INITIAL STATE MOMENTA IN THE PARTONIC CM.
24508         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
24509      &         -(2.*EMIN*EMIN)**2)/(4.*SHAT)
24510         PCM=SQRT(PCM2)
24511         P1(0)=SQRT(PCM2+EMIN*EMIN)
24512         P1(1)=0.
24513         P1(2)=0.
24514         P1(3)=PCM
24515         P2(0)=SQRT(PCM2+EMIN*EMIN)
24516         P2(1)=0.
24517         P2(2)=0.
24518         P2(3)=-PCM
24519 C...COLOR STRUCTURED ME SUMMED/AVERAGED OVER FINAL/INITIAL SPINS AND COLORS.
24520         IF(IPROC.GE.1140)THEN
24521           GRND=TANB
24522         ELSE
24523           IF(IMSSM.NE.0)THEN
24524             CONTINUE
24525           END IF
24526           GRND=ONE
24527         END IF
24528         FACGPM(1) = ENQ       *GRND
24529         FACGPM(2) = EMQ*PARITY/GRND
24530 C...EW AND QCD COUPLINGS.
24531         EMSCA=EMQ+ENQ+EMH
24532         EMSC2=EMSCA*EMSCA
24533         ALPHA=HWUAEM(EMSC2)
24534         FIRST=.TRUE.
24535         GAUGE=.FALSE.
24536         E=SQRT(4.D0*PIFAC*ALPHA)
24537         IF(IPROC.GE.1140)THEN
24538           IFL=IQ-1
24539           IF(IQ.EQ.7)IFL=IQ
24540           IF(IQ.EQ.8)IFL=IQ+1
24541           IF(IQ.EQ.9)IFL=IQ+2
24542           RM3=ENQ
24543           YM3=ENQ
24544           GAM3=0.D0
24545           RM4=EMQ
24546           YM4=EMQ
24547           GAM4=GMQ
24548 C...CHARGED HIGGSES
24549           Q3=-1.D0
24550           IF(IFL.LE.6)Q3=-1.D0/3.D0
24551           JFL=0
24552           JH=IH
24553 C...ASSIGN FERMION MOMENTA
24554           DO I=0,3
24555             F(I)=P4(I)
24556             G(I)=P3(I)
24557           END DO
24558         ELSE
24559           IFL=IQ
24560           IF(IQ.EQ.7)IFL=IQ
24561           IF(IQ.EQ.8)IFL=IQ+1
24562           IF(IQ.EQ.9)IFL=IQ+2
24563           RM3=EMQ
24564           YM3=EMQ
24565           GAM3=0.D0
24566           RM4=ENQ
24567           YM4=ENQ
24568           GAM4=0.D0
24569 C...NEUTRAL HIGGSES
24570           IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ.5 ))THEN
24571             Q3=-1.D0/3.D0
24572           ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6 ))THEN
24573             Q3=+2.D0/3.D0
24574           ELSEIF((IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
24575             Q3=-1.D0
24576           END IF
24577           IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ. 5).OR.
24578      &       (IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
24579             JFL=1
24580           ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6))THEN
24581             JFL=2
24582           END IF
24583           KHIGGS=IHIGGS
24584           IF(IHIGGS.NE.0)KHIGGS=IHIGGS-1
24585           JH=KHIGGS
24586 C...ASSIGN FERMION MOMENTA
24587           DO I=0,3
24588             F(I)=P3(I)
24589             G(I)=P4(I)
24590           END DO
24591         END IF
24592         RM5=EMH
24593         GAM5=GMH
24594         S2W=SWEIN
24595         RMW=RMASS(198)
24596         RMZ=RMASS(200)
24597         GAMHL=HBAR/RLTIM(203)
24598         GAMHH=HBAR/RLTIM(204)
24599         GAMHA=HBAR/RLTIM(205)
24600         COLOUR=1.D0
24601         IF(IFL.LE.6)COLOUR=3.D0
24602 C...MSSM COUPLINGS.
24603         IF(JH.LE.3)THEN
24604           HFC=ENHANC(IQ)
24605           HBC=ENHANC(10)
24606         ELSE
24607           HFC=ONE
24608           HBC=ONE
24609         END IF
24610 C...ME.
24611         CALL HWH2HE(FIRST,GAUGE,JFL,JH,HFC,HBC,
24612      &     E,S2W,TANB,ALPHAH,RMW,S,Q3,F,G,P5,
24613      &     RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
24614      &     RMHL,GAMHL,RMHH,GAMHH,RMHA,GAMHA,
24615      &     RMZ,GAMZ,COLOUR,M2EE)
24616 C...CONSTANT FACTORS: PHI ALONG BEAM AND CONVERSION GEV^2->NB.
24617         FACT=2.*PIFAC*GEV2NB
24618 C...PHASE SPACE JACOBIANS, PI'S AND FLUX.
24619         FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
24620      &      *((ECM-EMH)**2-(EMQ+ENQ)**2)
24621      &      /2./EMQQ/S
24622 C...JACOBIANS FROM CT5 TO X(2).
24623         IF((IQ+JQ).EQ.18)THEN
24624           CONTINUE
24625         ELSE
24626           FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
24627           FACT=FACT*2.*ABS(ST4/CT4/SF4)
24628         END IF
24629 C...CHARGE CONJUGATION.
24630         IF(IPROC.GE.1140)THEN
24631 C...YES FOR CHARGED HIGGS.
24632           FACT=FACT*2.
24633         ELSE
24634 C...NO FOR NEUTRAL HIGGSES.
24635           CONTINUE
24636         END IF
24637 C...HIGGS RESONANCE.
24638         FACT=FACT*EMHWT
24639 C...CONSTANT WEIGHT.
24640         FACT=FACT*WEIGHT
24641 C...INCLUDE BR OF HIGGS.
24642         IF(IMSSM.EQ.0)THEN
24643           IDEC=MOD(IPROC,100)
24644           IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
24645           IF (IDEC.EQ.0) THEN
24646             BRHIGQ=0.D0
24647             DO I=1,6
24648               BRHIGQ=BRHIGQ+BRHIG(I)
24649             END DO
24650             FACT=FACT*BRHIGQ
24651           ENDIF
24652           IF (IDEC.EQ.10) THEN
24653             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
24654             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
24655             FACT=FACT*BR
24656           ELSEIF (IDEC.EQ.11) THEN
24657             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
24658             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
24659             FACT=FACT*BR
24660           ENDIF
24661         END IF
24662       END IF
24663 C...SET UP FLAVOURS IN FINAL STATE.
24664       IF(IPROC.GE.1140)THEN
24665         IF(HWRGEN(0).LT.0.5)THEN
24666           JHIGGS=207-201
24667           IIQ=IQ
24668           JJQ=JQ
24669           FLIP=0
24670         ELSE
24671           JHIGGS=206-201
24672           IIQ=IQ-1
24673           JJQ=JQ+1
24674           FLIP=1
24675         END IF
24676       ELSE
24677         JHIGGS=IHIGGS
24678         IIQ=IQ
24679         JJQ=JQ
24680         FLIP=0
24681       END IF
24682       HCS=FACT*M2EE
24683       IF (GENEV.AND.HCS.GT.RCS) THEN
24684 C...GENERATE EVENT.
24685         IDN(1)=IDHW(1)
24686         IDN(2)=IDHW(2)
24687         IF(IIQ.LE.12.AND.JJQ.LE.12)THEN
24688           IDN(3)=IIQ
24689           IDN(4)=JJQ
24690         ELSE
24691           IDN(3)=2*IIQ-7+114
24692           IDN(4)=2*IIQ-7+114+IAD
24693         END IF
24694         IDN(5)=201+JHIGGS
24695 C...INCOMING PARTONS: NOW MASSIVE.
24696         EMIN1=RMASS(IDN(1))
24697         EMIN2=RMASS(IDN(2))
24698 C...REDO INITIAL STATE MOMENTA IN THE PARTONIC CM.
24699         PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
24700      &         -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
24701         PCM=SQRT(PCM2)
24702         P1(0)=SQRT(PCM2+EMIN1*EMIN1)
24703         P1(1)=0.
24704         P1(2)=0.
24705         P1(3)=PCM
24706         P2(0)=SQRT(PCM2+EMIN2*EMIN2)
24707         P2(1)=0.
24708         P2(2)=0.
24709         P2(3)=-PCM
24710 C...SETS UP INCOMING STATUS AND IDS ONLY FOR 2->1: USE HWEONE.
24711         IDCMF=15
24712         XX(1)=ONE
24713         XX(2)=ONE
24714         CALL HWEONE
24715         JDAHEP(1,NHEP  )=NHEP+1
24716         JDAHEP(2,NHEP  )=NHEP+3
24717         JMOHEP(1,NHEP+1)=NHEP
24718         JMOHEP(1,NHEP+2)=NHEP
24719         JMOHEP(1,NHEP+3)=NHEP
24720 C...RANDOMLY ROTATE FINAL STATE MOMENTA AROUND BEAM AXIS.
24721         PHI=2.*PIFAC*HWRGEN(0)
24722         CPHI=COS(PHI)
24723         SPHI=SIN(PHI)
24724         ROT(1,1)=+CPHI
24725         ROT(1,2)=+SPHI
24726         ROT(1,3)=0.
24727         ROT(2,1)=-SPHI
24728         ROT(2,2)=+CPHI
24729         ROT(2,3)=0.
24730         ROT(3,1)=0.
24731         ROT(3,2)=0.
24732         ROT(3,3)=1.
24733         DO L=1,3
24734           DO M=1,3
24735             QAUX(M)=0.
24736             DO N=1,3
24737               IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
24738               IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
24739               IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
24740             END DO
24741           END DO
24742           DO M=1,3
24743             IF(L.EQ.1)P3(M)=QAUX(M)
24744             IF(L.EQ.2)P4(M)=QAUX(M)
24745             IF(L.EQ.3)P5(M)=QAUX(M)
24746           END DO
24747         END DO
24748 C...DO REAL INCOMING, OUTGOING MOMENTA IN THE LAB FRAME.
24749         DO M=NHEP-2,NHEP+3
24750           IF(M.EQ.NHEP  )GO TO 888
24751           DO N=0,3
24752             NN=N
24753             IF(N.EQ.0)NN=4
24754             IF(M.EQ.NHEP-2)PHEP(NN,M)=P1(N)
24755             IF(M.EQ.NHEP-1)PHEP(NN,M)=P2(N)
24756             IF(M.EQ.NHEP+1)PHEP(NN,M)=P3(N)*(1-FLIP)+P4(N)*FLIP
24757             IF(M.EQ.NHEP+2)PHEP(NN,M)=P4(N)*(1-FLIP)+P3(N)*FLIP
24758             IF(M.EQ.NHEP+3)PHEP(NN,M)=P5(N)
24759           END DO
24760  888      CONTINUE
24761         END DO
24762 C...NEEDS TO SET ALL FINAL STATE MASSES.
24763         PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
24764      &                         -PHEP(3,NHEP+1)**2
24765      &                         -PHEP(2,NHEP+1)**2
24766      &                         -PHEP(1,NHEP+1)**2))
24767         PHEP(5,NHEP+2)=SQRT(ABS(PHEP(4,NHEP+2)**2
24768      &                         -PHEP(3,NHEP+2)**2
24769      &                         -PHEP(2,NHEP+2)**2
24770      &                         -PHEP(1,NHEP+2)**2))
24771         PHEP(5,NHEP+3)=SQRT(ABS(PHEP(4,NHEP+3)**2
24772      &                         -PHEP(3,NHEP+3)**2
24773      &                         -PHEP(2,NHEP+3)**2
24774      &                         -PHEP(1,NHEP+3)**2))
24775 C...SETS CMF.
24776         DO I=1,4
24777           PHEP(I,NHEP  )=PHEP(I,NHEP-2)+PHEP(I,NHEP-1)
24778         END DO
24779         PHEP(5,NHEP  )=SQRT(ABS(PHEP(4,NHEP  )**2
24780      &                         -PHEP(3,NHEP  )**2
24781      &                         -PHEP(2,NHEP  )**2
24782      &                         -PHEP(1,NHEP  )**2))
24783 C...SETS UP OUTGOING STATUS AND IDS.
24784         ISTHEP(NHEP+1)=113
24785         ISTHEP(NHEP+2)=114
24786         ISTHEP(NHEP+3)=114
24787         IDHW(NHEP+1)=IDN(3)
24788         IDHEP(NHEP+1)=IDPDG(IDN(3))
24789         IDHW(NHEP+2)=IDN(4)
24790         IDHEP(NHEP+2)=IDPDG(IDN(4))
24791         IDHW(NHEP+3)=IDN(5)
24792         IDHEP(NHEP+3)=IDPDG(IDN(5))
24793 C...SETS UP COLOUR CONNECTIONS.
24794         JMOHEP(2,NHEP+1)=NHEP+2
24795         JMOHEP(2,NHEP+2)=NHEP+1
24796         JMOHEP(2,NHEP-1)=NHEP-2
24797         JMOHEP(2,NHEP-2)=NHEP-1
24798         JMOHEP(2,NHEP+3)=NHEP+3
24799         JDAHEP(2,NHEP+1)=NHEP+2
24800         JDAHEP(2,NHEP+2)=NHEP+1
24801         JDAHEP(2,NHEP-1)=NHEP-1
24802         JDAHEP(2,NHEP-2)=NHEP-2
24803         JDAHEP(2,NHEP+3)=NHEP+3
24804         NHEP=NHEP+3
24805         IF(AZSPIN)THEN
24806 C...SET TO ZERO THE COEFFICIENTS OF THE SPIN DENSITY MATRICES.
24807           CALL HWVZRO(7,GCOEF)
24808         END IF
24809       END IF
24810 C...COLLECT WEIGHT.
24811       EVWGT=HCS
24812       RETURN
24813   999 END
24814 CDECK  ID>, HWHIGH.
24815 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
24816 *-- Author :  Kosuke Odagiri & Stefano Moretti
24817 C-----------------------------------------------------------------------
24818 C...Generate completely differential cross section (EVWGT) in the variables
24819 C...X(I) with I=1,3 (see below) for the processes IPROC=3315,3325,3335,3355,
24820 C...3365,3375 as described in the HERWIG 6 documentation file.
24821 C...It includes interface to PDFs and takes into account color connections
24822 C...among partons.
24823 C
24824 C...First release:  16-AUG-1999 by Kosuke Odagiri
24825 C...Last modified:  26-SEP-1999 by Stefano Moretti
24826 C-----------------------------------------------------------------------
24827       SUBROUTINE HWHIGH
24828 C-----------------------------------------------------------------------
24829 C     DRELL-YAN 2 PARTON -> 2 HIGGS PAIR (2HDM)
24830 C-----------------------------------------------------------------------
24831       INCLUDE 'HERWIG65.INC'
24832       DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
24833      & FACTR, SN2TH, MZ, MW, MNN(2,2), MCC(2), MCN(3), EMSC2, GW2, GZ2,
24834      & GHH(4), XWEIN, S2W, PT2MIN, ECM_MAX, X(3), XL(3),
24835      & XU(3), WEIGHT, ECM, SHAT, TAU, RMH1, RMH2, EMH1, EMH2,
24836      & EMHWT1, EMHWT2, EMHHWT
24837       INTEGER I, J, IQ, IQ1, IQ2, ID1, ID2, IH, JH, IH1, IH2
24838       EXTERNAL HWRGEN, HWUAEM
24839       SAVE HCS,MNN,MCC,MCN,EMHHWT,S,SHAT
24840       PARAMETER (EPS = 1.D-9)
24841       DOUBLE COMPLEX Z, GZ, A, D, E
24842       PARAMETER (Z = (0.D0,1.D0))
24843       EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
24844 C...process event.
24845       IF (GENEV) THEN
24846         RCS = HCS*HWRGEN(0)
24847       ELSE
24848         HCS = ZERO
24849         EVWGT = ZERO
24850 C...minimum transverse momentum.
24851         PTMIN = ZERO
24852         PT2MIN = PTMIN**2
24853 C...energy at hadron level.
24854         ECM_MAX=PBEAM1+PBEAM2
24855         S=ECM_MAX*ECM_MAX
24856 C...phase space variables.
24857 C...X(1)=COS(THETA_CM),
24858 C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMH1+EMH2)**2-1./ECM_MAX**2),
24859 C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
24860 C...phase space borders.
24861         XL(1)=-1.
24862         XU(1)=1.
24863         XL(2)=0.
24864         XU(2)=1.
24865         XL(3)=0.
24866         XU(3)=1.
24867 C...single phase space point.
24868  100    CONTINUE
24869         WEIGHT=1.
24870         DO I=1,3
24871           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
24872           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
24873         END DO
24874 C...final state masses.
24875         IF((MOD(IPROC,10000).EQ.3365).OR.
24876      &     (MOD(IPROC,10000).EQ.3375))THEN
24877           JH  = IHIGGS-1
24878           ID1 = 205
24879           ID2 = 202 + JH
24880         ELSE IF(MOD(IPROC,10000).EQ.3355)THEN
24881           JH  = 4
24882           ID1 = 206
24883           ID2 = 207
24884         ELSE IF((MOD(IPROC,10000).EQ.3315).OR.
24885      &          (MOD(IPROC,10000).EQ.3325).OR.
24886      &          (MOD(IPROC,10000).EQ.3335))THEN
24887           JH  = IHIGGS-1
24888           ID1 = 206
24889           ID2 = 202 + JH
24890         END IF
24891         RMH1=RMASS(ID1)
24892         RMH2=RMASS(ID2)
24893         EMH1=RMH1
24894         EMH2=RMH2
24895         EMHWT1=1.
24896         EMHWT2=1.
24897         EMHHWT=EMHWT1*EMHWT2
24898 C...energy at parton level.
24899         ECM=SQRT(1./(X(2)*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
24900      &                                      +1./ECM_MAX**2))
24901         IF((EMH1.LE.0.).OR.(EMH1.GE.ECM))RETURN
24902         IF((EMH2.LE.0.).OR.(EMH2.GE.ECM))RETURN
24903         SHAT=ECM*ECM
24904         TAU=SHAT/S
24905 C...momentum fractions X1 and X2.
24906         XX(1) = EXP(LOG(TAU)*(1.-X(3)))
24907         XX(2) = TAU/XX(1)
24908         COSTH = X(1)
24909         SN2TH = 0.25D0 - 0.25D0*COSTH**2
24910         EMSCA = EMH1+EMH2
24911         EMSC2 = EMSCA*EMSCA
24912         CALL    HWSGEN(.FALSE.)
24913         EVWGT = ZERO
24914         FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT/CAFAC*SN2TH/2.
24915 C...Jacobians from X1,X2 to X(2),X(3).
24916         FACTR = FACTR/S*(-LOG(TAU))*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
24917 C...constant weight.
24918         FACTR = FACTR*WEIGHT
24919 C...couplings and propagators.
24920         XWEIN = TWO*SWEIN
24921         S2W   = DSQRT(XWEIN*(TWO-XWEIN))
24922         GZ    = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT
24923         GZ2   = DREAL(DCONJG(GZ)*GZ)
24924         GW2   = ((ONE-MW**2/SHAT)**2+(GAMW/MW)**2)*XWEIN**2
24925 C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-.
24926         GHH(1)= COSBMA
24927         GHH(2)= SINBMA
24928         GHH(3)= ONE
24929         GHH(4)= ONE-XWEIN
24930 C...set to zero all MEs.
24931         DO I=1,2
24932           MCC(I)=ZERO
24933           MCN(I)=ZERO
24934           DO J=1,2
24935             MNN(I,J)=ZERO
24936           END DO
24937         END DO
24938         MCN(3)=ZERO
24939 C...start subprocesses.
24940         IF((MOD(IPROC,10000).EQ.3365).OR.
24941      &     (MOD(IPROC,10000).EQ.3375))THEN
24942 c
24943 c      _      o  o   o
24944 c    q q  -> A  h / H
24945 c
24946           DO IH = JH,JH
24947             QPE = SHAT-(EMH1+EMH2)**2
24948             IF (QPE.GT.ZERO) THEN
24949               PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
24950               DO IQ = 1,2
24951                 MNN(IH,IQ) =
24952      &          FACTR*PF**3*GHH(IH)**2*(LFCH(IQ)**2+RFCH(IQ)**2)/GZ2
24953               END DO
24954             ELSE
24955               CONTINUE
24956             END IF
24957           END DO
24958         ELSE IF(MOD(IPROC,10000).EQ.3355)THEN
24959 c
24960 c      _      +  -
24961 c    q q  -> H  H
24962 c
24963           IH = JH
24964           QPE = SHAT-(EMH1+EMH2)**2
24965           IF (QPE.GT.ZERO) THEN
24966             PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
24967             DO IQ = 1,2
24968               A = GHH(IH)/GZ
24969               D = QFCH(IQ)+A*LFCH(IQ)
24970               E = QFCH(IQ)+A*RFCH(IQ)
24971               MCC(IQ)=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
24972             END DO
24973           ELSE
24974             CONTINUE
24975           END IF
24976         ELSE IF((MOD(IPROC,10000).EQ.3315).OR.
24977      &          (MOD(IPROC,10000).EQ.3325).OR.
24978      &          (MOD(IPROC,10000).EQ.3335))THEN
24979 c
24980 c      _      +-  o   o   o
24981 c    q q' -> H   h / H / A
24982 c
24983           DO IH = JH,JH
24984             QPE = SHAT-(EMH1+EMH2)**2
24985             IF (QPE.GT.ZERO) THEN
24986               PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
24987               MCN(IH)=FACTR*PF**3/GW2*HALF*GHH(IH)**2
24988             ELSE
24989               CONTINUE
24990             END IF
24991           END DO
24992         END IF
24993       END IF
24994       HCS = 0.D0
24995 C...start PDFs.
24996       DO 1 ID1 = 1, 12
24997        IF (DISF(ID1,1).LT.EPS) GOTO 1
24998        IF (ID1.GT.6) THEN
24999         ID2 = ID1 - 6
25000        ELSE
25001         ID2 = ID1 + 6
25002        END IF
25003        IQ  = ID1 - ((ID1-1)/2)*2
25004        IF (DISF(ID2,2).LT.EPS) GOTO 1
25005        DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25006        IH1 = 205
25007        IH2 = 203
25008        HCS = HCS + DIST*EMHHWT*MNN(1,IQ)
25009        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,1,*9)
25010        IH2 = 204
25011        HCS = HCS + DIST*EMHHWT*MNN(2,IQ)
25012        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,2,*9)
25013        IH1 = 206
25014        IH2 = 207
25015        HCS = HCS + DIST*EMHHWT*MCC(IQ)
25016        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3,*9)
25017     1 CONTINUE
25018 c      _     _       _     _
25019 c     ud(+), ud(-), du(-), du(+)
25020 c
25021       DO 2 IQ1 = 1, 3
25022       DO IQ2 = 1, 3
25023       IF(VCKM(IQ1,IQ2).GT.EPS) THEN
25024 c      _
25025 c     ud (+)
25026 c
25027        ID1 = IQ1 * 2
25028        ID2 = IQ2 * 2 + 5
25029        IH1 = 206
25030        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25031         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25032         DO IH = 1,3
25033          IH2 = 202+IH
25034          HCS = HCS + DIST*EMHHWT*MCN(IH)
25035          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
25036         END DO
25037        END IF
25038 c     _
25039 c     du (+)
25040 c
25041        ID1 = IQ2 * 2 + 5
25042        ID2 = IQ1 * 2
25043        IH1 = 206
25044        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25045         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25046         DO IH = 1,3
25047          IH2 = 202+IH
25048          HCS = HCS + DIST*EMHHWT*MCN(IH)
25049          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
25050         END DO
25051        END IF
25052 c      _
25053 c     du (-)
25054 c
25055        ID1 = IQ2 * 2 - 1
25056        ID2 = IQ1 * 2 + 6
25057        IH1 = 207
25058        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25059         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25060         DO IH = 1,3
25061          IH2 = 202+IH
25062          HCS = HCS + DIST*EMHHWT*MCN(IH)
25063          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
25064         END DO
25065        END IF
25066 c     _
25067 c     ud (-)
25068 c
25069        ID1 = IQ1 * 2 + 6
25070        ID2 = IQ2 * 2 - 1
25071        IH1 = 207
25072        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25073         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25074         DO IH = 1,3
25075          IH2 = 202+IH
25076          HCS = HCS + DIST*EMHHWT*MCN(IH)
25077          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
25078         END DO
25079        END IF
25080       END IF
25081       END DO
25082     2 CONTINUE
25083       EVWGT = HCS
25084       RETURN
25085 C...generate event.
25086     9 IDN(1)=ID1
25087       IDN(2)=ID2
25088       IDCMF=15
25089       CALL HWETWO(.TRUE.,.TRUE.)
25090       IF (AZSPIN) THEN
25091         CALL HWVZRO(7,GCOEF)
25092       END IF
25093       END
25094 CDECK  ID>, HWHIGJ.
25095 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
25096 *-- Author :    Ian Knowles
25097 C-----------------------------------------------------------------------
25098       SUBROUTINE HWHIGJ
25099 C-----------------------------------------------------------------------
25100 C     QCD Higgs plus jet production; mean EVWGT = Sigma in nb*Higgs B.R.
25101 C     Adapted from the program of U. Baur and E.W.N. Glover
25102 C     See: Nucl. Phys. B339 (1990) 38
25103 C-----------------------------------------------------------------------
25104       INCLUDE 'HERWIG65.INC'
25105       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWUAEM,EPS,RCS,EMH,EMHWT,
25106      & EMHTMP,BR,CV,CA,EMH2,ET,EJ,PT,EMT,EMAX,YMAX,YHINF,YHSUP,EXYH,
25107      & YMIN,YJINF,YJSUP,EXYJ,S,T,U,FACT,AMPQQ,AMPQG,AMPGQ,AMPGG,HCS,
25108      & FACTR
25109       INTEGER I,IDEC,ID1,ID2
25110       EXTERNAL HWRGEN,HWRUNI,HWUALF,HWUAEM
25111       SAVE HCS,AMPGG,AMPGQ,AMPQG,AMPQQ,EMH,FACT
25112       PARAMETER (EPS=1.D-9)
25113       IF (GENEV) THEN
25114          RCS=HCS*HWRGEN(0)
25115       ELSE
25116          EVWGT=0.
25117 C Select a Higgs mass
25118          CALL HWHIGM(EMH,EMHWT)
25119          IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
25120 C Store branching ratio for specified Higgs deacy channel
25121          IDEC=MOD(IPROC,100)
25122          BR=1.
25123          IF (IDEC.EQ.0) THEN
25124             BR=0.
25125             DO 10 I=1,6
25126   10        BR=BR+BRHIG(I)
25127          ELSEIF (IDEC.EQ.10) THEN
25128             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25129             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25130             BR=BR*BRHIG(IDEC)
25131          ELSEIF (IDEC.EQ.11) THEN
25132             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25133             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25134             BR=BR*BRHIG(IDEC)
25135          ELSEIF (IDEC.LE.12) THEN
25136             BR=BRHIG(IDEC)
25137          ENDIF
25138 C Select subprocess kinematics
25139          EMH2=EMH**2
25140          CALL HWRPOW(ET,EJ)
25141          PT=.5*ET
25142          EMT=SQRT(PT**2+EMH2)
25143          EMAX=0.5*(PHEP(5,3)+EMH2/PHEP(5,3))
25144          IF (EMAX.LE.EMT) RETURN
25145          YMAX=LOG((EMAX+SQRT(EMAX**2-EMT**2))/EMT)
25146          YHINF=MAX(YJMIN,-YMAX)
25147          YHSUP=MIN(YJMAX, YMAX)
25148          IF (YHSUP.LE.YHINF) RETURN
25149          EXYH=EXP(HWRUNI(1,YHINF,YHSUP))
25150          YMIN=LOG(PT/(PHEP(5,3)-EMT/EXYH))
25151          YMAX=LOG((PHEP(5,3)-EMT*EXYH)/PT)
25152          YJINF=MAX(YJMIN,YMIN)
25153          YJSUP=MIN(YJMAX,YMAX)
25154          IF (YJSUP.LE.YJINF) RETURN
25155          EXYJ=EXP(HWRUNI(2,YJINF,YJSUP))
25156          XX(1)=(EMT*EXYH+PT*EXYJ)/PHEP(5,3)
25157          XX(2)=(EMT/EXYH+PT/EXYJ)/PHEP(5,3)
25158          S=XX(1)*XX(2)*PHEP(5,3)**2
25159          T=EMH2-XX(1)*EMT*PHEP(5,3)/EXYH
25160          U=EMH2-S-T
25161          COSTH=(S+2.*T-EMH2)/(S-EMH2)
25162 C Set subprocess scale
25163          EMSCA=EMT
25164          CALL HWSGEN(.FALSE.)
25165          FACT=GEV2NB*PT*EJ*(YHSUP-YHINF)*(YJSUP-YJINF)*BR*EMHWT
25166      &       *HWUALF(1,EMSCA)**3*HWUAEM(EMH2)/(SWEIN*16*PIFAC*S**2)
25167          CALL HWHIGA(S,T,U,EMH2,AMPQQ,AMPQG,AMPGQ,AMPGG)
25168       ENDIF
25169       HCS=0.
25170       DO 30 ID1=1,13
25171       IF (DISF(ID1,1).LT.EPS) GOTO 30
25172       FACTR=FACT*DISF(ID1,1)
25173       IF (ID1.LT.7) THEN
25174 C Quark first:
25175          ID2=ID1+6
25176          HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
25177          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,2314,81,*99)
25178          ID2=13
25179          HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
25180          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,201,3124,82,*99)
25181       ELSEIF (ID1.LT.13) THEN
25182 C Antiquark first:
25183          ID2=ID1-6
25184          HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
25185          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,3124,83,*99)
25186          ID2=13
25187          HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
25188          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,201,2314,84,*99)
25189       ELSE
25190 C Gluon first:
25191          DO 20 ID2=1,12
25192          IF (DISF(ID2,2).LT.EPS) GOTO 20
25193          IF (ID2.LT.7) THEN
25194             HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
25195             IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,201,2314,85,*99)
25196          ELSE
25197             HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
25198             IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,201,3124,86,*99)
25199          ENDIF
25200   20     CONTINUE
25201          HCS=HCS+FACTR*DISF(13,2)*AMPGG
25202          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,2314,87,*99)
25203       ENDIF
25204   30  CONTINUE
25205       EVWGT=HCS
25206       RETURN
25207 C Generate event
25208   99  IDN(1)=ID1
25209       IDN(2)=ID2
25210       IDCMF=15
25211 C Trick HWETWO into using off-shell Higgs mass
25212       EMHTMP=RMASS(IDN(4))
25213       RMASS(IDN(4))=EMH
25214 C-- BRW fix 27/8/04: avoid double smearing of H mass
25215       CALL HWETWO(.TRUE.,.FALSE.)
25216       RMASS(IDN(4))=EMHTMP
25217   999 END
25218 CDECK  ID>, HWHIGM.
25219 *CMZ :-        -02/05/91  11.17.14  by  Federico Carminati
25220 *-- Author :    Mike Seymour
25221 C-----------------------------------------------------------------------
25222       SUBROUTINE HWHIGM(EM,WEIGHT)
25223 C-----------------------------------------------------------------------
25224 C     CHOOSE HIGGS MASS:
25225 C     IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
25226 C       CHOOSE HIGGS MASS ACCORDING TO
25227 C       EM**4       /  (EM**2-EMH**2)**2 + (GAMH*EMH)**2
25228 C     ELSE
25229 C       CHOOSE HIGGS MASS ACCORDING TO
25230 C       EMH * GAMH  /  (EM**2-EMH**2)**2 + (GAMH*EMH)**2
25231 C     ENDIF
25232 C     IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.1) THEN
25233 C       SUPPLY WEIGHT FACTOR TO YIELD
25234 C       EM * GAM(EM)/  (EM**2-EMH**2)**2 + (GAM(EM)*EM)**2
25235 C     ELSE
25236 C       SUPPLY WEIGHT FACTOR TO YIELD
25237 C       EM*(EMH/EM)**4 * GAM(EM)
25238 C                   /  (EM**2-EMH**2)**2 + (GAM(EM)*EMH**2/EM)**2
25239 C       AS SUGGESTED IN M.H.SEYMOUR, PHYS.LETT.B354(1995)409.
25240 C     ENDIF
25241 C-----------------------------------------------------------------------
25242       INCLUDE 'HERWIG65.INC'
25243       DOUBLE PRECISION HWRUNI,EM,WEIGHT,EMH,DIF,FUN,THETA,T,EMHLST,W0,
25244      & W1,EMM,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,Z,F,GAMOFS
25245       INTEGER I
25246       EXTERNAL HWRUNI
25247       SAVE EMHLST,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,W0,W1
25248       EQUIVALENCE (EMH,RMASS(201))
25249       DATA EMHLST/0D0/
25250 C---SET UP INTEGRAND AND INDEFINITE INTEGRAL OF DISTRIBUTION
25251 C   THETA=ATAN((EM**2-EMH**2)/(GAMH*EMH)); T=TAN(THETA); T0=EMH/GAMH
25252       DIF(T,T0)=(T+T0)**2
25253       FUN(THETA,T,T0)=T + (T0*T0-1)*THETA + T0*LOG(1+T*T)
25254 C---SET UP CONSTANTS
25255       IF (EMH.NE.EMHLST .OR. FSTWGT) THEN
25256         EMHLST=EMH
25257         GAMEM=GAMH*EMH
25258         T0=EMH/GAMH
25259         TMIN=(MAX(ONE*1E-10,EMH-GAMMAX*GAMH))**2/GAMEM-T0
25260         TMAX=(              EMH+GAMMAX*GAMH )**2/GAMEM-T0
25261         THEMIN=ATAN(TMIN)
25262         THEMAX=ATAN(TMAX)
25263         ZMIN=FUN(THEMIN,TMIN,T0)
25264         ZMAX=FUN(THEMAX,TMAX,T0)
25265         W0=(ZMAX-ZMIN) / PIFAC * GAMEM
25266         W1=(THEMAX-THEMIN) / PIFAC
25267       ENDIF
25268 C---CHOOSE HIGGS MASS
25269       IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
25270  1      EM=0
25271         WEIGHT=0
25272         Z=HWRUNI(1,ZMIN,ZMAX)
25273 C---SOLVE FUN(THETA,TAN(THETA))=Z BY NEWTON'S METHOD
25274         THETA=MAX(THEMIN, MIN(THEMAX, Z/T0**2 ))
25275         I=1
25276         F=0
25277  10     IF (I.LE.20 .AND. ABS(1-F/Z).GT.1E-4) THEN
25278           I=I+1
25279           IF (2*ABS(THETA).GT.PIFAC) CALL HWWARN('HWHIGM',51,*999)
25280           T=TAN(THETA)
25281           F=FUN(THETA,T,T0)
25282           THETA=THETA-(F-Z)/DIF(T,T0)
25283           GOTO 10
25284         ENDIF
25285         IF (I.GT.20) CALL HWWARN('HWHIGM',1,*999)
25286       ELSE
25287         THETA=HWRUNI(0,THEMIN,THEMAX)
25288       ENDIF
25289       EM=SQRT(GAMEM*(T0+TAN(THETA)))
25290 C---NOW CALCULATE WEIGHT FACTOR FOR NON-CONSTANT HIGGS WIDTH
25291       GAMOFS=EM
25292       CALL HWDHIG(GAMOFS)
25293       IF (IOPHIG.EQ.0) THEN
25294         WEIGHT=W0*GAMOFS*EM /EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
25295      &                             /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
25296       ELSEIF (IOPHIG.EQ.1) THEN
25297         WEIGHT=W1*GAMOFS*EM /GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
25298      &                             /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
25299       ELSEIF (IOPHIG.EQ.2) THEN
25300         EMM=EM*(EMH/EM)**4
25301         WEIGHT=W0*GAMOFS*EMM/EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
25302      &                             /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
25303       ELSEIF (IOPHIG.EQ.3) THEN
25304         EMM=EM*(EMH/EM)**4
25305         WEIGHT=W1*GAMOFS*EMM/GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
25306      &                             /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
25307       ELSE
25308         CALL HWWARN('HWHIGM',500,*999)
25309       ENDIF
25310  999  END
25311 CDECK  ID>, HWHIGQ.
25312 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
25313 *-- Author :  Stefano Moretti
25314 C-----------------------------------------------------------------------
25315 C...Generate completely differential cross section (EVWGT) in the variables
25316 C...X(I) with I=1,6 (see below) for the processes from IPROC=2500-2599 (SM),
25317 C...IPROC=3811-3899, as described in the HERWIG 6 documentation file.
25318 C...(For IPROC=3839,3869,3899 it describes MSSM charged Higgs production.)
25319 C...It includes interface to PDFs and takes into account color connections
25320 C...among partons.
25321 C
25322 C...First release: 08-APR-1999 by Stefano Moretti
25323 C...Last modified: 28-JUN-2001 by Stefano Moretti
25324 C
25325       SUBROUTINE HWHIGQ
25326 C-----------------------------------------------------------------------
25327 C     PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
25328 C-----------------------------------------------------------------------
25329       INCLUDE 'HERWIG65.INC'
25330       INTEGER JHIGGS
25331       INTEGER I,J,K,L,M,N
25332       INTEGER IS,IH,IQ,JQ,IIQ,JJQ,IQMIN,IQMAX,IGG,IQQ
25333       INTEGER IDEC,NC,FLIP
25334       INTEGER ID1,ID2
25335       DOUBLE PRECISION CV,CA,BR
25336       DOUBLE PRECISION BRHIGQ,EMQ,ENQ,EMQQ,EMH,EMHWT,EMW
25337       DOUBLE PRECISION PTMMIN,PTNMIN
25338       DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
25339       DOUBLE PRECISION X(6),XL(6),XU(6)
25340       DOUBLE PRECISION Q4(0:3),Q34(0:3)
25341       DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
25342       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
25343       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
25344       DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
25345       DOUBLE PRECISION M2GG,M2GGPL,M2GGMN,M2QQ
25346       DOUBLE PRECISION GM,GRND,FACGPM(2)
25347       DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
25348       DOUBLE PRECISION ALPHA,ALPHAS,EMSC2
25349       DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF
25350       DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
25351       DOUBLE PRECISION VCOL,GCOL,QAUX(0:3)
25352       DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
25353       DOUBLE PRECISION WEIGHT
25354       SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5
25355       SAVE IIQ,JJQ,JHIGGS
25356       LOGICAL HWRLOG
25357       EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2QH,HWETWO,HWRLOG
25358       PARAMETER (EPS=1.D-9)
25359       EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO)
25360 C...assign Q/Q'-flavour.
25361       IF((MOD(IPROC,10000).EQ.3839).OR.
25362      &   (MOD(IPROC,10000).EQ.3869).OR.
25363      &   (MOD(IPROC,10000).EQ.3899))THEN
25364         IQ=6
25365         JQ=11
25366         GM=HBAR/RLTIM(6)*RMASS(6)
25367       ELSE
25368         IF(IMSSM.EQ.0)THEN
25369           IS=0
25370           IH=0
25371           IQ=6
25372         ELSE
25373           IF(MOD(IPROC,10000).LT.4000)IS=6
25374           IF(MOD(IPROC,10000).LT.3870)IS=3
25375           IF(MOD(IPROC,10000).LT.3840)IS=0
25376           IH=MOD(IPROC,10000)/10-380-IS
25377           IQ=MOD(IPROC,10000)-3800-10*(IH+IS)
25378         END IF
25379         JQ=IQ+6
25380         GM=ZERO
25381       END IF
25382 C...process event.
25383       IF(GENEV)THEN
25384         RCS=HCS*HWRGEN(0)
25385       ELSE
25386         EVWGT=0.
25387         HCS=0.
25388 C...assign final state masses.
25389         EMQ=RMASS(IQ)
25390         ENQ=RMASS(JQ)
25391         EMH=RMASS(201+IHIGGS)
25392         EMHWT=1.
25393         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
25394 C...energy at hadron level.
25395         ECM_MAX=PBEAM1+PBEAM2
25396         S=ECM_MAX*ECM_MAX
25397 C...phase space variables.
25398 C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
25399 C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
25400 C...                X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34),
25401 C...HEAVY QUARKS -> X(2)=COS(THETA5_CM),
25402 C...                X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
25403 C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2),
25404 C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
25405 C...phase space borders.
25406         XL(1)=0.
25407         XU(1)=1.
25408         IF((IQ+JQ).EQ.18)THEN
25409           XL(2)=-1.
25410           XL(4)=0.
25411           XU(4)=2.*PIFAC
25412         ELSE
25413           XL(2)=0.
25414           XL(4)=-1.
25415           XU(4)=1.
25416         END IF
25417         XU(2)=1.
25418         XL(3)=-1.
25419         XU(3)=1.
25420         XL(5)=0.
25421         XU(5)=1.
25422         XL(6)=0.
25423         XU(6)=1.
25424 C...single phase space point.
25425  100    CONTINUE
25426         WEIGHT=1.
25427         DO I=1,6
25428           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
25429           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
25430         END DO
25431 C...energy at parton level.
25432         PTMMIN=0.
25433         PTNMIN=0.
25434         IF(IMSSM.NE.0)THEN
25435           IF((MOD(IPROC,10000).EQ.3839).OR.
25436      &       (MOD(IPROC,10000).EQ.3869).OR.
25437      &       (MOD(IPROC,10000).EQ.3899))THEN
25438             PTNMIN=PTMIN
25439           ELSE
25440             IF((IQ.NE.6).AND.(IQ.NE.12).AND.
25441      &         (JQ.NE.6).AND.(JQ.NE.12))THEN
25442               PTMMIN=PTMIN
25443               PTNMIN=PTMIN
25444             ELSE
25445               CONTINUE
25446             END IF
25447           END IF
25448         END IF
25449         ECM=SQRT(1./(X(5)*(1./(SQRT(PTMMIN**2+EMQ**2)
25450      &                        +SQRT(PTNMIN**2+ENQ**2)+EMH)**2
25451      &                                         -1./ECM_MAX**2)
25452      &                                         +1./ECM_MAX**2))
25453         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
25454         SHAT=ECM*ECM
25455         TAU=SHAT/S
25456 C...momentum fractions X1 and X2.
25457         XX(1)=EXP(LOG(TAU)*(1.-X(6)))
25458         XX(2)=TAU/XX(1)
25459 C...three particle kinematics.
25460         EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
25461 C...incoming partons: all massless.
25462         EMIN=0.
25463         IF((IQ+JQ).EQ.18)THEN
25464           CT5=X(2)
25465           CT4=X(3)
25466           ST4=SQRT(1.-CT4*CT4)
25467           CF4=COS(X(4))
25468           SF4=SIN(X(4))
25469         ELSE
25470           PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2
25471      &        -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM)
25472           PCM=SQRT(PCM2)
25473           RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2
25474      &        -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM)
25475           RCM=SQRT(RCM2)
25476           TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
25477      &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
25478      &    -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
25479      &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
25480           TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
25481      &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
25482      &    +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
25483      &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
25484           TLMIN=LOG(ABS(TTMAX))
25485           TLMAX=LOG(ABS(TTMIN))
25486           TL=X(2)*(TLMAX-TLMIN)+TLMIN
25487           T=EXP(ABS(TL))
25488           CTMP=-T-EMIN**2-EMQQ**2
25489      &       +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2)
25490           CT5=CTMP/2./PCM/RCM
25491           ST4=X(3)
25492           CT4=SQRT(1.-ST4*ST4)
25493           IF (HWRLOG(HALF)) CT4=-CT4
25494           CF4=X(4)
25495           SF4=SQRT(1.-CF4*CF4)
25496           IF (HWRLOG(HALF)) SF4=-SF4
25497         END IF
25498         ST5=SQRT(1.-CT5*CT5)
25499         IF (HWRLOG(HALF)) ST5=-ST5
25500         RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/
25501      &     (4.*ECM*ECM)
25502         IF(RQ52.LT.0.)THEN
25503           GOTO 100
25504         ELSE
25505           RQ5=SQRT(RQ52)
25506         ENDIF
25507         P5(1)=0.
25508         P5(2)=RQ5*ST5
25509         P5(3)=RQ5*CT5
25510         P5(0)=SQRT(RQ52+EMH*EMH)
25511         DO I=1,3
25512           Q34(I)=-P5(I)
25513         END DO
25514         Q34(0)=SQRT(RQ52+EMQQ*EMQQ)
25515         RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/
25516      &     (4.*EMQQ*EMQQ)
25517         IF(RQ42.LT.0.)THEN
25518           GOTO 100
25519         ELSE
25520           RQ4=SQRT(RQ42)
25521         ENDIF
25522         Q4(1)=RQ4*ST4*CF4
25523         Q4(2)=RQ4*ST4*SF4
25524         Q4(3)=RQ4*CT4
25525         Q4(0)=SQRT(RQ42+ENQ*ENQ)
25526         PQ4=0.
25527         DO I=1,3
25528           PQ4=PQ4+Q34(I)*Q4(I)
25529         END DO
25530         P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ
25531         P3(0)=Q34(0)-P4(0)
25532         DO I=1,3
25533           P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ)
25534           P3(I)=Q34(I)-P4(I)
25535         END DO
25536         IF(IMSSM.NE.0)THEN
25537           IF((MOD(IPROC,10000).EQ.3839).OR.
25538      &       (MOD(IPROC,10000).EQ.3869).OR.
25539      &       (MOD(IPROC,10000).EQ.3899))THEN
25540             IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
25541           ELSE
25542             IF((IQ.NE.6).AND.(IQ.NE.12).AND.
25543      &         (JQ.NE.6).AND.(JQ.NE.12))THEN
25544               IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
25545               IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
25546             ELSE
25547               CONTINUE
25548             END IF
25549           END IF
25550         END IF
25551 C...initial state momenta in the partonic CM.
25552         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
25553      &         -(2.*EMIN*EMIN)**2)/(4.*SHAT)
25554         PCM=SQRT(PCM2)
25555         P1(0)=SQRT(PCM2+EMIN*EMIN)
25556         P1(1)=0.
25557         P1(2)=0.
25558         P1(3)=PCM
25559         P2(0)=SQRT(PCM2+EMIN*EMIN)
25560         P2(1)=0.
25561         P2(2)=0.
25562         P2(3)=-PCM
25563 C...color structured ME summed/averaged over final/initial spins and colors.
25564         IGG=1
25565         IQQ=1
25566         IF((MOD(IPROC,10000).EQ.3839).OR.
25567      &     (MOD(IPROC,10000).EQ.3869).OR.
25568      &     (MOD(IPROC,10000).EQ.3899))THEN
25569           IF(MOD(IPROC,10000).EQ.3869)IQQ=0
25570           IF(MOD(IPROC,10000).EQ.3899)IGG=0
25571           GRND=TANB
25572         ELSE
25573           IF(IMSSM.NE.0)THEN
25574             IF((MOD(IPROC,10000)/10-380).EQ.4)IQQ=0
25575             IF((MOD(IPROC,10000)/10-380).EQ.7)IGG=0
25576           END IF
25577           GRND=ONE
25578         END IF
25579         FACGPM(1) = ENQ       *GRND
25580         FACGPM(2) = EMQ*PARITY/GRND
25581         CALL HWH2QH(ECM,P1,P2,P3,P4,P5,EMQ,ENQ,EMH,FACGPM,GM,IGG,IQQ,
25582      &              GGQQHT,GGQQHU,GGQQHNP,QQQQH)
25583         M2GG=GGQQHNP/(8.*CFFAC)
25584         M2GGPL=GGQQHT/(8.*CFFAC)
25585         M2GGMN=GGQQHU/(8.*CFFAC)
25586         M2QQ=QQQQH*(1.-1./CAFAC**2)/4.
25587 C...constant factors: phi along beam and conversion GeV^2->nb.
25588         FACT=2.*PIFAC*GEV2NB
25589 C...Jacobians from X1,X2 to X(5),X(6)
25590         FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
25591 C...phase space Jacobians, pi's and flux.
25592         FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
25593      &      *((ECM-EMH)**2-(EMQ+ENQ)**2)
25594      &      /2./EMQQ
25595 C...Jacobians from CT5 to X(2).
25596         IF((IQ+JQ).EQ.18)THEN
25597           CONTINUE
25598         ELSE
25599           FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
25600           FACT=FACT*2.*ABS(ST4/CT4/SF4)
25601         END IF
25602 C...EW and QCD couplings.
25603         EMSCA=EMQ+ENQ+EMH
25604         EMSC2=EMSCA*EMSCA
25605         ALPHA=HWUAEM(EMSC2)
25606         ALPHAS=HWUALF(1,EMSCA)
25607         FACT=FACT*4.*PIFAC*ALPHA/4./SWEIN/EMW/EMW
25608         FACT=FACT*16.*PIFAC**2*ALPHAS**2
25609         IF((MOD(IPROC,10000).EQ.3839).OR.
25610      &     (MOD(IPROC,10000).EQ.3869).OR.
25611      &     (MOD(IPROC,10000).EQ.3899))THEN
25612 C...enhancement factor for coupling+c.c.
25613           FACT=FACT*4.*VCKM(3,3)
25614         ELSE
25615 C...enhancement factor for MSSM.
25616           FACT=FACT*ENHANC(IQ)*ENHANC(IQ)
25617         END IF
25618 C...Higgs resonance.
25619         FACT=FACT*EMHWT
25620 C...constant weight.
25621         FACT=FACT*WEIGHT
25622 C...include BR of Higgs.
25623         IF(IMSSM.EQ.0)THEN
25624           IDEC=MOD(IPROC,100)
25625           IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
25626           IF (IDEC.EQ.0) THEN
25627             BRHIGQ=0.D0
25628             DO I=1,6
25629               BRHIGQ=BRHIGQ+BRHIG(I)
25630             END DO
25631             FACT=FACT*BRHIGQ
25632           ENDIF
25633 c bug fix 11/10/02 SM.
25634           IF (IDEC.EQ.10) THEN
25635             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25636             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25637             FACT=FACT*BR
25638           ELSEIF (IDEC.EQ.11) THEN
25639             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25640             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25641             FACT=FACT*BR
25642           ENDIF
25643 c end of bug fix.
25644         END IF
25645       END IF
25646 C...set up flavours in final state.
25647       IF((MOD(IPROC,10000).EQ.3839).OR.
25648      &   (MOD(IPROC,10000).EQ.3869).OR.
25649      &   (MOD(IPROC,10000).EQ.3899))THEN
25650         IF(HWRGEN(0).LT.0.5)THEN
25651           JHIGGS=207-201
25652           IIQ=6
25653           JJQ=11
25654           FLIP=0
25655         ELSE
25656           JHIGGS=206-201
25657           IIQ=5
25658           JJQ=12
25659           FLIP=1
25660         END IF
25661       ELSE
25662         JHIGGS=IHIGGS
25663         IIQ=IQ
25664         JJQ=JQ
25665         FLIP=0
25666       END IF
25667 C...set up PDFs.
25668       HCS=0.
25669       CALL HWSGEN(.FALSE.)
25670       IQMAX=13
25671       IQMIN=1
25672       IF((MOD(IPROC,10000).EQ.3839).OR.
25673      &   (MOD(IPROC,10000).EQ.3869).OR.
25674      &   (MOD(IPROC,10000).EQ.3899))THEN
25675         IF(MOD(IPROC,10000).EQ.3869)IQMIN=13
25676         IF(MOD(IPROC,10000).EQ.3899)IQMAX=12
25677       ELSE
25678         IF(IMSSM.NE.0)THEN
25679 C...Some compilers don't like this statement.
25680 C   Since it does nothing, just comment it out.
25681 C         IF((MOD(IPROC,10000).GE.3811).AND.
25682 C    &       (MOD(IPROC,10000).LE.3836))CONTINUE
25683           IF((MOD(IPROC,10000).GE.3841).AND.
25684      &       (MOD(IPROC,10000).LE.3866))IQMIN=13
25685           IF((MOD(IPROC,10000).GE.3871).AND.
25686      &       (MOD(IPROC,10000).LE.3896))IQMAX=12
25687         END IF
25688       END IF
25689       DO I=IQMIN,IQMAX
25690         IF(DISF(I,1).LT.EPS)THEN
25691           GOTO 200
25692         END IF
25693         K=I/7
25694         L=+1-2*K
25695         IF(I.EQ.13)L=0
25696         J=I+L*6
25697         IF(DISF(J,2).LT.EPS)THEN
25698           GOTO 200
25699         END IF
25700         DIST=DISF(I,1)*DISF(J,2)*S
25701         IF(I.LT.13)THEN
25702 C...set up color connections: qq-scattering.
25703           IF(J.EQ.I+6)THEN
25704             HCS=HCS+M2QQ*DIST*FACT
25705             IF(GENEV.AND.HCS.GT.RCS)THEN
25706               CONTINUE
25707               CALL HWHQCP(IIQ,JJQ,2413, 4,*9)
25708             END IF
25709           ELSE IF(I.EQ.J+6)THEN
25710             HCS=HCS+M2QQ*DIST*FACT
25711             IF(GENEV.AND.HCS.GT.RCS)THEN
25712               FLIP=(2-2*FLIP)/2
25713               CALL HWHQCP(JJQ,IIQ,3142,12,*9)
25714             END IF
25715           END IF
25716         ELSE
25717 C...set up color connections: gg-scattering.
25718           HCS=HCS
25719      &   +(M2GGPL-M2GG*M2GGPL/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
25720           IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(IIQ,JJQ,2413,27,*9)
25721           HCS=HCS
25722      &   +(M2GGMN-M2GG*M2GGMN/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
25723           IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(IIQ,JJQ,4123,28,*9)
25724         END IF
25725  200    CONTINUE
25726       END DO
25727       EVWGT=HCS
25728       RETURN
25729 C...generate event.
25730     9 IDN(1)=I
25731       IDN(2)=J
25732       IDN(5)=201+JHIGGS
25733 C...incoming partons: now massive.
25734       EMIN1=RMASS(IDN(1))
25735       EMIN2=RMASS(IDN(2))
25736 C...redo initial state momenta in the partonic CM.
25737       PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
25738      &       -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
25739       PCM=SQRT(PCM2)
25740       P1(0)=SQRT(PCM2+EMIN1*EMIN1)
25741       P1(1)=0.
25742       P1(2)=0.
25743       P1(3)=PCM
25744       P2(0)=SQRT(PCM2+EMIN2*EMIN2)
25745       P2(1)=0.
25746       P2(2)=0.
25747       P2(3)=-PCM
25748 C...randomly rotate final state momenta around beam axis.
25749       PHI=2.*PIFAC*HWRGEN(0)
25750       CPHI=COS(PHI)
25751       SPHI=SIN(PHI)
25752       ROT(1,1)=+CPHI
25753       ROT(1,2)=+SPHI
25754       ROT(1,3)=0.
25755       ROT(2,1)=-SPHI
25756       ROT(2,2)=+CPHI
25757       ROT(2,3)=0.
25758       ROT(3,1)=0.
25759       ROT(3,2)=0.
25760       ROT(3,3)=1.
25761       DO L=1,3
25762         DO M=1,3
25763           QAUX(M)=0.
25764           DO N=1,3
25765             IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
25766             IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
25767             IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
25768           END DO
25769         END DO
25770         DO M=1,3
25771           IF(L.EQ.1)P3(M)=QAUX(M)
25772           IF(L.EQ.2)P4(M)=QAUX(M)
25773           IF(L.EQ.3)P5(M)=QAUX(M)
25774         END DO
25775       END DO
25776 C...use HWETWO only to set up status and IDs of quarks.
25777       COSTH=0.
25778       IDCMF=15
25779       CALL HWETWO(.TRUE.,.TRUE.)
25780 C...do real incoming, outgoing momenta in the lab frame.
25781       VCOL=(XX(1)-XX(2))/(XX(1)+XX(2))
25782       GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2))
25783       DO M=NHEP-4,NHEP+1
25784         IF(M.EQ.NHEP-2)GO TO 888
25785         DO N=0,3
25786           IF(M.EQ.NHEP-4)QAUX(N)=P1(N)
25787           IF(M.EQ.NHEP-3)QAUX(N)=P2(N)
25788           IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP
25789           IF(M.EQ.NHEP  )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP
25790           IF(M.EQ.NHEP+1)QAUX(N)=P5(N)
25791         END DO
25792 C...perform boost.
25793         PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3))
25794         PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0))
25795         PHEP(2,M)=QAUX(2)
25796         PHEP(1,M)=QAUX(1)
25797  888    CONTINUE
25798       END DO
25799 C...needs to set all final state masses.
25800       PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2
25801      &                       -PHEP(3,NHEP-1)**2
25802      &                       -PHEP(2,NHEP-1)**2
25803      &                       -PHEP(1,NHEP-1)**2))
25804       PHEP(5,NHEP  )=SQRT(ABS(PHEP(4,NHEP  )**2
25805      &                       -PHEP(3,NHEP  )**2
25806      &                       -PHEP(2,NHEP  )**2
25807      &                       -PHEP(1,NHEP  )**2))
25808       PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
25809      &                       -PHEP(3,NHEP+1)**2
25810      &                       -PHEP(2,NHEP+1)**2
25811      &                       -PHEP(1,NHEP+1)**2))
25812 C...sets CMF.
25813       DO I=1,4
25814         PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3)
25815       END DO
25816       PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2
25817      &                       -PHEP(3,NHEP-2)**2
25818      &                       -PHEP(2,NHEP-2)**2
25819      &                       -PHEP(1,NHEP-2)**2))
25820 C...status and IDs for Higgs.
25821       ISTHEP(NHEP+1)=114
25822       IDHW(NHEP+1)=IDN(5)
25823       IDHEP(NHEP+1)=IDPDG(IDN(5))
25824 C...Higgs colour (self-)connections.
25825       JMOHEP(1,NHEP+1)=NHEP-2
25826       JMOHEP(2,NHEP+1)=NHEP+1
25827       JDAHEP(2,NHEP+1)=NHEP+1
25828       JDAHEP(2,NHEP-2)=NHEP+1
25829       NHEP=NHEP+1
25830       IF(AZSPIN)THEN
25831 C...set to zero the coefficients of the spin density matrices.
25832         CALL HWVZRO(7,GCOEF)
25833       END IF
25834   999 END
25835 C-----------------------------------------------------------------------
25836 CDECK  ID>, HWHIGS.
25837 *CMZ :-        -02/04/98  14.52.22  by  Mike Seymour
25838 *-- Author :    Mike Seymour
25839 *-- Modified:   Stefano Moretti 04/05/98
25840 C-----------------------------------------------------------------------
25841       SUBROUTINE HWHIGS
25842 C-----------------------------------------------------------------------
25843 C     HIGGS PRODUCTION VIA GLUON OR QUARK FUSION
25844 C     MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
25845 C-----------------------------------------------------------------------
25846       INCLUDE 'HERWIG65.INC'
25847       DOUBLE PRECISION HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM,BRHIGQ,EMH,
25848      & CSFAC(13),EVSUM(13),EMFAC,CV,CA,BR,RWGT,E1,E2,EMQ,GFACTR,RQM(6)
25849       INTEGER IDEC,I,J,ID1,ID2
25850       EXTERNAL HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM
25851       SAVE CSFAC,BR,EVSUM
25852       IF (GENEV) THEN
25853         RWGT=HWRGEN(0)*EVSUM(13)
25854         IDN(1)=1
25855         DO 10 I=1,12
25856  10       IF (RWGT.GT.EVSUM(I)) IDN(1)=I+1
25857         IDN(2)=13
25858         IF (IDN(1).LE.12) IDN(2)=IDN(1)-6
25859         IF (IDN(1).LE. 6) IDN(2)=IDN(1)+6
25860         IDCMF=201+IHIGGS
25861         CALL HWEONE
25862       ELSE
25863         EVWGT=0.
25864         EMH=RMASS(201+IHIGGS)
25865         EMFAC=1.D0
25866         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
25867         IF (EMH.LE.0 .OR. EMH.GE.PHEP(5,3)) RETURN
25868         EMSCA=EMH
25869         IF (EMSCA.NE.EMLST) THEN
25870           EMLST=EMH
25871           XXMIN=(EMH/PHEP(5,3))**2
25872           XLMIN=LOG(XXMIN)
25873           GFACTR=GEV2NB*HWUAEM(EMH**2)/(576.*SWEIN*RMASS(198)**2)
25874 C--MOD BY BRW 16/07/03 TO USE RUNNING MASSES
25875           CALL HWURQM(EMH,RQM)
25876           DO 20 I=1,13
25877             IF (I.EQ.13) THEN
25878               CSFAC(I)=-GFACTR*HWHIGT(  EMH)*XLMIN
25879      &                        *HWUALF(1,EMH)**2*EMFAC
25880             ELSEIF (I.GT.6) THEN
25881               CSFAC(I)=CSFAC(I-6)
25882             ELSE
25883               EMQ=RQM(I)
25884               IF (EMQ.GT.ZERO.AND.EMH.GT.TWO*EMQ) THEN
25885                 CSFAC(I)=-GFACTR*96.*PIFAC**2 *(1-(TWO*EMQ/EMH)**2)
25886      &                *(EMQ/EMH)**2 *XLMIN *EMFAC*ENHANC(I)**2
25887               ELSE
25888                 CSFAC(I)=0
25889               ENDIF
25890             ENDIF
25891 C--END MOD
25892  20       CONTINUE
25893 C  INCLUDE BRANCHING RATIO OF HIGGS
25894           IDEC=MOD(IPROC,100)
25895           BR=1
25896           IF(IMSSM.EQ.0)THEN
25897 C SM case
25898             IF (IDEC.EQ.0) THEN
25899               BRHIGQ=0
25900               DO 30 I=1,6
25901  30             BRHIGQ=BRHIGQ+BRHIG(I)
25902               BR=BRHIGQ
25903             ELSEIF (IDEC.EQ.10) THEN
25904               CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25905               CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25906               BR=BR*BRHIG(IDEC)
25907             ELSEIF (IDEC.EQ.11) THEN
25908               CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25909               CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25910               BR=BR*BRHIG(IDEC)
25911             ELSEIF (IDEC.LE.12) THEN
25912               BR=BRHIG(IDEC)
25913             ENDIF
25914           ENDIF
25915         ENDIF
25916         CALL HWSGEN(.TRUE.)
25917         EVWGT=0
25918         E1=PHEP(4,MAX(1,JDAHEP(1,1)))
25919         E2=PHEP(4,MAX(2,JDAHEP(1,2)))
25920         DO 40 I=1,13
25921           EMQ=RMASS(I)
25922           IF (EMH.GT.2*EMQ) THEN
25923             J=13
25924             IF (I.LE.12) J=I-6
25925             IF (I.LE. 6) J=I+6
25926             IF (XX(1).LT.0.5*(1-EMQ/E1+HWUSQR(1-2*EMQ/E1)) .AND.
25927      &          XX(2).LT.0.5*(1-EMQ/E2+HWUSQR(1-2*EMQ/E2)))
25928      &          EVWGT=EVWGT+DISF(I,1)*DISF(J,2)*CSFAC(I)*BR
25929           ENDIF
25930           EVSUM(I)=EVWGT
25931  40     CONTINUE
25932       ENDIF
25933   999 END
25934 CDECK  ID>, HWHIGT.
25935 *CMZ :-        -02/04/98  15.00.39  by  Mike Seymour
25936 *-- Author :    Mike Seymour
25937 C-----------------------------------------------------------------------
25938       FUNCTION HWHIGT(EMH)
25939 C-----------------------------------------------------------------------
25940 C  CALCULATE MOD SQUARED I DEFINED AS IN BARGER & PHILLIPS p433
25941 C  WARNING: THIS IS A FACTOR OF 3 GREATER THAN EHLQ'S ETA FUNCTION
25942 C  PARITY=+1 FOR SCALAR AND -1 FOR PSEUDOSCALAR
25943 C-----------------------------------------------------------------------
25944       INCLUDE 'HERWIG65.INC'
25945       DOUBLE PRECISION HWHIGT,RATIO,RAT2,EMH,FREAL,FIMAG,ETALOG,AIREAL,
25946      & AIIMAG
25947       INTEGER I,J,K,L
25948       HWHIGT=0
25949       IF (ABS(PARITY).NE.1) CALL HWWARN('HWHIGT',500,*999)
25950       AIREAL=0
25951       AIIMAG=0
25952 C---CONTRIBUTION FROM QUARK LOOPS
25953       DO 100 I=1,NFLAV
25954         RATIO=RMASS(I)/EMH
25955         RAT2=RATIO**2
25956         IF     (RAT2.GT.0.25) THEN
25957           FREAL=-2.*ASIN(0.5/RATIO)**2
25958           FIMAG=0
25959         ELSEIF (RAT2.LT.0.25) THEN
25960           ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
25961           FREAL=0.5 * (ETALOG**2 - PIFAC**2)
25962           FIMAG=PIFAC * ETALOG
25963         ELSE
25964           FREAL=0.5 * (          - PIFAC**2)
25965           FIMAG=0
25966         ENDIF
25967         IF (PARITY.EQ.1) THEN
25968           AIREAL=AIREAL+3*RAT2*(2 + (4*RAT2-1)*FREAL)*ENHANC(I)
25969           AIIMAG=AIIMAG+3*RAT2*(    (4*RAT2-1)*FIMAG)*ENHANC(I)
25970         ELSE
25971           AIREAL=AIREAL-2*RAT2*(FREAL)*ENHANC(I)
25972           AIIMAG=AIIMAG-2*RAT2*(FIMAG)*ENHANC(I)
25973         ENDIF
25974  100  CONTINUE
25975 C---CONTRIBUTION FROM SQUARK LOOPS
25976       DO 200 I=1,12
25977         J=I/7
25978         K=6*J+I
25979         L=K
25980         IF(K.GT.6)L=K-12
25981         RATIO=RMASS(L)/EMH
25982         RAT2=RATIO**2
25983         IF     (RAT2.GT.0.25) THEN
25984           FREAL=-2.*ASIN(0.5/RATIO)**2
25985           FIMAG=0
25986         ELSEIF (RAT2.LT.0.25) THEN
25987           ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
25988           FREAL=0.5 * (ETALOG**2 - PIFAC**2)
25989           FIMAG=PIFAC * ETALOG
25990         ELSE
25991           FREAL=0.5 * (          - PIFAC**2)
25992           FIMAG=0
25993         ENDIF
25994         IF (PARITY.EQ.1) THEN
25995           AIREAL=AIREAL-3*RAT2*(1 + 2*RAT2*FREAL)*SENHNC(K)
25996           AIIMAG=AIIMAG-3*RAT2*(    2*RAT2*FIMAG)*SENHNC(K)
25997         ENDIF
25998  200  CONTINUE
25999 C---FUNCTION RETURNS MOD-SQUARED OF SUM
26000       HWHIGT=AIREAL**2 + AIIMAG**2
26001  999  END
26002 CDECK  ID>, HWHIGV.
26003 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
26004 *-- Author :  Stefano Moretti
26005 C-----------------------------------------------------------------------
26006 C...Generate completely differential cross section (EVWGT) in the variables
26007 C...X(I) with I=1,4 (see below) for the processes of ther series
26008 C...IPROC=2600,2700 as described in the HERWIG 6 documentation file.
26009 C...It includes interface to PDFs and takes into account color connections
26010 C...among partons.
26011 C
26012 C...First release: 8-APR-1999 by Stefano Moretti
26013 C
26014       SUBROUTINE HWHIGV
26015 C-----------------------------------------------------------------------
26016 C     MSSM NEUTRAL HIGGS PRODUCTION IN ASSOCIATION WITH GAUGE BOSON
26017 C--BRW fix 27/8/04: corrected off-shell gauge boson mass dependence
26018 C-----------------------------------------------------------------------
26019       INCLUDE 'HERWIG65.INC'
26020       INTEGER I,J,K,L,M,N
26021       INTEGER IV,IDEC
26022       INTEGER ID1,ID2
26023       DOUBLE PRECISION CV,CA,BR
26024       DOUBLE PRECISION BRHIGQ,EMH,EMHWT,EMV,RMV,GAMV,RMH
26025       DOUBLE PRECISION X(4),XL(4),XU(4)
26026       DOUBLE PRECISION CT,ST,CCT
26027       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
26028       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
26029       DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
26030       DOUBLE PRECISION QQV(12,12),C4W,VQ(12),AQ(12)
26031       DOUBLE PRECISION M2,M2L,M2T
26032       DOUBLE PRECISION ALPHA,EMSC2
26033       DOUBLE PRECISION HWRGEN,HWUAEM
26034       DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
26035       DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
26036       DOUBLE PRECISION WEIGHT
26037       DOUBLE PRECISION VSAVE,HSAVE,CFT,QR,QL
26038       SAVE EMH,EMV,HCS,M2,M2L,M2T,FACT,QQV,S,CT
26039       LOGICAL HWRLOG
26040       EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2VH,HWETWO,HWRLOG
26041       PARAMETER (EPS=1.D-9)
26042       IF(IMSSM.EQ.0)THEN
26043         IF(IPRO.EQ.26)IV=0
26044         IF(IPRO.EQ.27)IV=1
26045       ELSE
26046         IF((MOD(IPROC,10000).EQ.3310).OR.
26047      &     (MOD(IPROC,10000).EQ.3320))THEN
26048           IV=0
26049         ELSEIF((MOD(IPROC,10000).EQ.3360).OR.
26050      &         (MOD(IPROC,10000).EQ.3370))THEN
26051           IV=1
26052         END IF
26053       END IF
26054       IF(GENEV)THEN
26055         RCS=HCS*HWRGEN(0)
26056       ELSE
26057         HCS=0.
26058         EVWGT=0.
26059 C...assign final state masses.
26060         RMV=RMASS(198+2*IV)
26061         RMH=RMASS(201+IHIGGS)
26062         IF(IV.EQ.0)GAMV=GAMW
26063         IF(IV.EQ.1)GAMV=GAMZ
26064         EMH=RMH
26065         EMHWT=1.D0
26066         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
26067 C...energy at hadron level.
26068         ECM_MAX=PBEAM1+PBEAM2
26069         S=ECM_MAX*ECM_MAX
26070 C...phase space variables.
26071 C...X(1)=COS(THETA_CM),
26072 C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMV+EMH)**2-1./ECM_MAX**2),
26073 C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
26074 C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
26075 C...where THETA=ATAN((EMV*EMV-RMV*RMV)/RMV/GAMV);
26076 C...phase space borders.
26077         XL(1)=-1.
26078         XU(1)=1.
26079         XL(2)=0.
26080         XU(2)=1.
26081         XL(3)=0.
26082         XU(3)=1.
26083         XL(4)=0.
26084         XU(4)=1.
26085 C...single phase space point.
26086  100    CONTINUE
26087         WEIGHT=1.
26088         DO I=1,4
26089           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
26090           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
26091         END DO
26092 C...resonant boson mass.
26093         RNMIN=RMV-GAMMAX*GAMV
26094         THETA_MIN=ATAN((RNMIN*RNMIN-RMV*RMV)/RMV/GAMV)
26095         RNMAX=ECM_MAX-EMH
26096         THETA_MAX=ATAN((RNMAX*RNMAX-RMV*RMV)/RMV/GAMV)
26097         EMV=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
26098      &     *RMV*GAMV+RMV*RMV)
26099 C...energy at parton level.
26100         ECM=SQRT(1./(X(2)*(1./(EMV+EMH)**2-1./ECM_MAX**2)
26101      &                                    +1./ECM_MAX**2))
26102         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
26103         SHAT=ECM*ECM
26104         TAU=SHAT/S
26105 C...momentum fractions X1 and X2.
26106         XX(1)=EXP(LOG(TAU)*(1.-X(3)))
26107         XX(2)=TAU/XX(1)
26108 C...two particle kinematics.
26109         CT=X(1)
26110         IF(HWRLOG(HALF))THEN
26111           ST=+SQRT(1.-CT*CT)
26112         ELSE
26113           ST=-SQRT(1.-CT*CT)
26114         END IF
26115 C...single phase space point.
26116         RCM2=((SHAT-EMV*EMV-EMH*EMH)**2
26117      &      -(2.*EMV*EMH)**2)/(4.*SHAT)
26118         RCM=SQRT(RCM2)
26119         P3(0)=SQRT(RCM2+EMV*EMV)
26120         P3(1)=0.
26121         P3(2)=RCM*ST
26122         P3(3)=RCM*CT
26123         P4(0)=SQRT(RCM2+EMH*EMH)
26124         P4(1)=0.
26125         P4(2)=-RCM*ST
26126         P4(3)=-RCM*CT
26127 C...incoming partons: massless.
26128         EMIN=0.
26129 C...initial state momenta in the partonic CM.
26130         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
26131      &      -(2.*EMIN*EMIN)**2)/(4.*SHAT)
26132         PCM=SQRT(PCM2)
26133         P1(0)=SQRT(PCM2+EMIN*EMIN)
26134         P1(1)=0.
26135         P1(2)=0.
26136         P1(3)=PCM
26137         P2(0)=SQRT(PCM2+EMIN*EMIN)
26138         P2(1)=0.
26139         P2(2)=0.
26140         P2(3)=-PCM
26141 C...color structured ME summed/averaged over final/initial spins and colors.
26142         CALL HWH2VH(P1,P2,P3,P4,EMV,M2,M2L,M2T)
26143         IF(M2.LE.0.)RETURN
26144 C...vector-axial couplings of V to qq'/qq.
26145         IF(IV.EQ.0)THEN
26146           DO I=2,12,2
26147             K=I
26148             IF(I.GT.6)K=I-6
26149             M=K/2
26150             N=0
26151             DO J=1,11,2
26152               L=J
26153               IF(J.GT.6)L=J-6
26154               N=L-N
26155 c bug fix 20/05/01 SM.
26156               QQV(I,J)=VCKM(M,N)
26157 c end of bug fix.
26158               QQV(J,I)=QQV(I,J)
26159               IF(N.EQ.3)N=0
26160             END DO
26161           END DO
26162         ELSE IF(IV.EQ.1)THEN
26163           C4W=(1.-SWEIN)*(1.-SWEIN)
26164           DO I=1,11,2
26165             VQ(I)=2.*VFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26166             AQ(I)=2.*AFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26167             J=I+6
26168             IF(J.GT.12)J=J-12
26169             QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
26170           END DO
26171           DO I=2,12,2
26172             VQ(I)=2.*VFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26173             AQ(I)=2.*AFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26174             J=I+6
26175             IF(J.GT.12)J=J-12
26176             QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
26177           END DO
26178         END IF
26179 C...constant factors: phi along beam and conversion GeV^2->nb.
26180         FACT=2.*PIFAC*GEV2NB
26181 C...Jacobians from X1,X2 to X(2),X(3)
26182         FACT=FACT/S*(-LOG(TAU))*(1./(EMV+EMH)**2-1./ECM_MAX**2)
26183 C...phase space Jacobians, pi's and flux.
26184         FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
26185 C...EW couplings.
26186         EMSCA=RMV+RMH
26187         EMSC2=EMSCA*EMSCA
26188         ALPHA=HWUAEM(EMSC2)
26189 C--BRW fix 27/8/04: RMV*RMV --> EMV*EMV
26190         FACT=FACT*16.*PIFAC**2*ALPHA**2/SWEIN/SWEIN*EMV*EMV
26191 C...enhancement factor for MSSM.
26192         FACT=FACT*ENHANC(10+IV)*ENHANC(10+IV)
26193 C...Higgs resonance.
26194         FACT=FACT*EMHWT
26195 C...vector boson resonance.
26196         FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
26197 C...constant weight.
26198         FACT=FACT*WEIGHT
26199 C...include BR of Higgs.
26200         IF(IMSSM.EQ.0)THEN
26201           IDEC=MOD(IPROC,100)
26202           IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
26203           IF (IDEC.EQ.0) THEN
26204             BRHIGQ=0.D0
26205             DO I=1,6
26206               BRHIGQ=BRHIGQ+BRHIG(I)
26207             END DO
26208             FACT=FACT*BRHIGQ
26209           ENDIF
26210 c bug fix 11/10/02 SM.
26211           IF (IDEC.EQ.10) THEN
26212             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26213             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26214             FACT=FACT*BR
26215           ELSEIF (IDEC.EQ.11) THEN
26216             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26217             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26218             FACT=FACT*BR
26219           ENDIF
26220 c end of bug fix.
26221         END IF
26222       END IF
26223 C...set up PDFs.
26224       HCS=0.
26225       CALL HWSGEN(.FALSE.)
26226       DO I=1,12
26227         IF(DISF(I,1).LT.EPS)THEN
26228           GOTO 200
26229         END IF
26230         K=I/7
26231         L=+1-2*K
26232         IF(IV.EQ.0)THEN
26233           J=I+L*6+(-1)**(I+1)
26234         ELSE IF(IV.EQ.1)THEN
26235           J=I+L*6
26236         END IF
26237         IF(DISF(J,2).LT.EPS)THEN
26238           GOTO 200
26239         END IF
26240         DIST=DISF(I,1)*DISF(J,2)*S
26241 C...QQV vector and axial couplings.
26242         DIST=DIST*QQV(I,J)
26243 C...no need to set up color connections.
26244         HCS=HCS+M2*DIST*FACT
26245         IF(GENEV.AND.HCS.GT.RCS)THEN
26246 C...generate event.
26247           IDN(1)=I
26248           IDN(2)=J
26249           IF(IV.EQ.0)
26250      &    IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
26251           IF(IV.EQ.1)IDN(3)=200
26252           IDN(4)=201+IHIGGS
26253           COSTH=CT
26254           IDCMF=15
26255           ICO(1)=2
26256           ICO(2)=1
26257           ICO(3)=3
26258           ICO(4)=4
26259 C...trick HWETWO in using off-shell V and H masses.
26260           VSAVE=RMASS(IDN(3))
26261           HSAVE=RMASS(IDN(4))
26262           RMASS(IDN(3))=EMV
26263           RMASS(IDN(4))=EMH
26264 C-- BRW fix 27/8/04: avoid double smearing of W and H masses
26265           CALL HWETWO(.FALSE.,.FALSE.)
26266           RMASS(IDN(3))=VSAVE
26267           RMASS(IDN(4))=HSAVE
26268           IF(AZSPIN)THEN
26269 C...set to zero the coefficients of the spin density matrices.
26270             CALL HWVZRO(7,GCOEF)
26271           END IF
26272 C...calculates exactly polarized decay matrix of gauge boson.
26273           IF(IERROR.NE.0)RETURN
26274           CCT=CT
26275           IF(I.GT.6)CCT=-CT
26276           IF(M2L.LT.0.)M2L=0.
26277           IF(M2T.LT.0.)M2T=0.
26278           RHOHEP(2,NHEP-1)=M2L/M2
26279           CFT=(M2-M2L)/(1.+CCT**2)/2.
26280           IF(IV.EQ.0)THEN
26281             RHOHEP(1,NHEP-1)=CFT*(1.+CCT)**2/M2
26282             RHOHEP(3,NHEP-1)=CFT*(1.-CCT)**2/M2
26283           ELSE IF(IV.EQ.1)THEN
26284             QR=(VQ(I)-AQ(I))/2.
26285             QL=(VQ(I)+AQ(I))/2.
26286             RHOHEP(1,NHEP-1)=CFT*(QR**2*(1.-CCT)**2+QL**2*(1.+CCT)**2)
26287      &                      /(QR**2+QL**2)/M2
26288             RHOHEP(3,NHEP-1)=CFT*(QR**2*(1.+CCT)**2+QL**2*(1.-CCT)**2)
26289      &                    /(QR**2+QL**2)/M2
26290           END IF
26291         RETURN
26292         END IF
26293  200    CONTINUE
26294       END DO
26295       EVWGT=HCS
26296       RETURN
26297  999  END
26298 CDECK  ID>, HWHIGW.
26299 *CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
26300 *-- Author :    Mike Seymour, modified by Stefano Moretti
26301 C-----------------------------------------------------------------------
26302       SUBROUTINE HWHIGW
26303 C-----------------------------------------------------------------------
26304 C     HIGGS PRODUCTION VIA W/Z BOSON FUSION
26305 C     MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
26306 C-----------------------------------------------------------------------
26307       INCLUDE 'HERWIG65.INC'
26308       DOUBLE PRECISION HWULDO,HWRUNI,HWRGEN,HWUAEM,K1MAX2,K1MIN2,K12,
26309      & K2MAX2,K2MIN2,K22,EMW2,EMW,ROOTS,EMH2,EMH,ROOTS2,P1,PHI1,PHI2,
26310      & COSPHI,COSTH1,SINTH1,COSTH2,SINTH2,P2,WEIGHT,TAU,TAULN,CSFAC,
26311      & PSUM,PROB,Q1(5),Q2(5),H(5),A,B,C,TERM2,BRHIGQ,G1WW,G2WW,G1ZZ(6),
26312      & G2ZZ(6),AWW,AZZ(6),PWW,PZZ(6),EMZ,EMZ2,RSUM,GLUSQ,GRUSQ,GLDSQ,
26313      & GRDSQ,GLESQ,GRESQ,CW,CZ,EMFAC,CV,CA,BR,X2,ETA,P1JAC,FACTR,EH2
26314       INTEGER HWRINT,IDEC,I,ID1,ID2,IHAD
26315       LOGICAL EE,EP
26316       EXTERNAL HWULDO,HWRUNI,HWRGEN,HWUAEM,HWRINT
26317       SAVE EMW2,EMZ2,EE,GLUSQ,GRUSQ,GLDSQ,GRDSQ,GLESQ,GRESQ,G1ZZ,G2ZZ,
26318      & G1WW,G2WW,CW,CZ,PSUM,AWW,PWW,AZZ,PZZ,ROOTS,Q1,Q2,H,FACTR
26319       EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
26320       IHAD=2
26321       IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
26322       IF (FSTWGT) THEN
26323         EMW2=EMW**2
26324         EMZ2=EMZ**2
26325         GLUSQ=(VFCH(2,1)+AFCH(2,1))**2
26326         GRUSQ=(VFCH(2,1)-AFCH(2,1))**2
26327         GLDSQ=(VFCH(1,1)+AFCH(1,1))**2
26328         GRDSQ=(VFCH(1,1)-AFCH(1,1))**2
26329         GLESQ=(VFCH(11,1)+AFCH(11,1))**2
26330         GRESQ=(VFCH(11,1)-AFCH(11,1))**2
26331         G1ZZ(1)=GLUSQ*GLUSQ+GRUSQ*GRUSQ
26332         G2ZZ(1)=GLUSQ*GRUSQ+GRUSQ*GLUSQ
26333         G1ZZ(2)=GLUSQ*GLDSQ+GRUSQ*GRDSQ
26334         G2ZZ(2)=GLUSQ*GRDSQ+GRUSQ*GLDSQ
26335         G1ZZ(3)=GLDSQ*GLDSQ+GRDSQ*GRDSQ
26336         G2ZZ(3)=GLDSQ*GRDSQ+GRDSQ*GLDSQ
26337         G1ZZ(4)=GLESQ*GLESQ+GRESQ*GRESQ
26338         G2ZZ(4)=GLESQ*GRESQ+GRESQ*GLESQ
26339         G1ZZ(5)=GLESQ*GLUSQ+GRESQ*GRUSQ
26340         G2ZZ(5)=GLESQ*GRUSQ+GRESQ*GLUSQ
26341         G1ZZ(6)=GLESQ*GLDSQ+GRESQ*GRDSQ
26342         G2ZZ(6)=GLESQ*GRDSQ+GRESQ*GLDSQ
26343         G1WW=0.25
26344         G2WW=0
26345         FACTR=GEV2NB/(128.*PIFAC**3)
26346         EH2=RMASS(201+IHIGGS)**2
26347         CW=256*(PIFAC*HWUAEM(EH2)/SWEIN)**3*EMW2
26348         CZ=256.*(PIFAC*HWUAEM(EH2))**3*EMZ2/(SWEIN*(1.-SWEIN))
26349       ENDIF
26350       EE=IPRO.LE.12
26351       EP=IPRO.GE.90
26352       IF (.NOT.GENEV) THEN
26353 C---CHOOSE PARAMETERS
26354         EVWGT=0.
26355         EMH=RMASS(201+IHIGGS)
26356         EMFAC=ONE
26357         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
26358         IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
26359         EMSCA=EMH
26360         IF (EE) THEN
26361           ROOTS=PHEP(5,3)
26362         ELSE
26363           TAU=(EMH/PHEP(5,3))**2
26364           TAULN=LOG(TAU)
26365           ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,-1D-10,TAULN)))
26366         ENDIF
26367         EMH2=EMH**2
26368         ROOTS2=ROOTS**2
26369 C---CHOOSE P1 ACCORDING TO (1-ETA)*(ETA-X2)/ETA**2
26370 C   WHERE ETA=1-2P1/ROOTS AND X2=EMH**2/S
26371         X2=EMH2/ROOTS2
26372  1      ETA=X2**HWRGEN(0)
26373         IF (HWRGEN(0)*(1-EMH/ROOTS)**2*ETA.GT.(1-ETA)*(ETA-X2))GOTO 1
26374         P1JAC=0.5*ROOTS*ETA**2/((1-ETA)*(ETA-X2))
26375      &    *(-LOG(X2)*(1+X2)-2*(1-X2))
26376         P1=0.5*ROOTS*(1-ETA)
26377 C---CHOOSE PHI1,2 UNIFORMLY
26378         PHI1=2*PIFAC*HWRGEN(0)
26379         PHI2=2*PIFAC*HWRGEN(0)
26380         COSPHI=COS(PHI2-PHI1)
26381 C---CHOOSE K1^2, ON PROPAGATOR FACTOR
26382         K1MAX2=2*P1*ROOTS
26383         K1MIN2=0
26384         K12=EMW2-(EMW2+K1MAX2)*(EMW2+K1MIN2)/
26385      &           ((K1MAX2-K1MIN2)*HWRGEN(0)+(EMW2+K1MIN2))
26386 C---CALCULATE COSTH1 FROM K1^2
26387         COSTH1=1+K12/(P1*ROOTS)
26388         SINTH1=SQRT(1-COSTH1**2)
26389 C---CHOOSE K2^2
26390         K2MAX2=ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)*(ROOTS-P1-P1*COSTH1)
26391      &        /((ROOTS-P1)**2-(P1*COSTH1)**2-(P1*SINTH1*COSPHI)**2)
26392         K2MIN2=0
26393         K22=EMW2-(EMW2+K2MAX2)*(EMW2+K2MIN2)/
26394      &           ((K2MAX2-K2MIN2)*HWRGEN(0)+(EMW2+K2MIN2))
26395 C---CALCULATE A,B,C FACTORS, AND...
26396         A=-2*K22*P1*COSTH1 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
26397         B=-2*K22*P1*SINTH1*COSPHI
26398         C=+2*K22*P1 - 2*ROOTS*K22 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
26399 C---SOLVE A*COSTH2 + B*SINTH2 + C = 0 FOR COSTH2
26400         TERM2=B**2 + A**2 - C**2
26401         IF (TERM2.LT.ZERO) RETURN
26402         TERM2=B*SQRT(TERM2)
26403         IF (A.GE.ZERO) RETURN
26404         COSTH2=(-A*C + TERM2)/(A**2+B**2)
26405         SINTH2=SQRT(1-COSTH2**2)
26406 C---FINALLY, GET P2
26407         IF (COSTH2.EQ.-ONE) RETURN
26408         P2=-K22/(ROOTS*(1+COSTH2))
26409 C---LOAD UP CMF MOMENTA
26410         Q1(1)=P1*SINTH1*COS(PHI1)
26411         Q1(2)=P1*SINTH1*SIN(PHI1)
26412         Q1(3)=P1*COSTH1
26413         Q1(4)=P1
26414         Q1(5)=0
26415         Q2(1)=P2*SINTH2*COS(PHI2)
26416         Q2(2)=P2*SINTH2*SIN(PHI2)
26417         Q2(3)=P2*COSTH2
26418         Q2(4)=P2
26419         Q2(5)=0
26420         H(1)=-Q1(1)-Q2(1)
26421         H(2)=-Q1(2)-Q2(2)
26422         H(3)=-Q1(3)-Q2(3)
26423         H(4)=-Q1(4)-Q2(4)+ROOTS
26424         CALL HWUMAS(H)
26425 C---CALCULATE MATRIX ELEMENTS SQUARED
26426         AWW=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G1WW
26427      &         +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2WW)
26428         DO 10 I=1,6
26429           AZZ(I)=ENHANC(11)**2 * CZ*(ROOTS2/2*HWULDO(Q1,Q2)*G1ZZ(I)
26430      &               +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2ZZ(I))
26431      &          *((K12-EMW2)/(K12-EMZ2)*(K22-EMW2)/(K22-EMZ2))**2
26432  10     CONTINUE
26433 C---CALCULATE WEIGHT IN INTEGRAL
26434         WEIGHT=FACTR*P2*P1JAC/(ROOTS2**2*HWULDO(H,Q2))
26435      &              *(K1MAX2-K1MIN2)/((K1MAX2+EMW2)*(K1MIN2+EMW2))
26436      &              *(K2MAX2-K2MIN2)/((K2MAX2+EMW2)*(K2MIN2+EMW2))
26437      &              * EMFAC
26438         EMSCA=EMW
26439         XXMIN=(ROOTS/PHEP(5,3))**2
26440         XLMIN=LOG(XXMIN)
26441 C---INCLUDE BRANCHING RATIO OF HIGGS
26442         IF(IMSSM.EQ.0)THEN
26443           IDEC=MOD(IPROC,100)
26444           IF (IDEC.GT.0.AND.IDEC.LE.12) WEIGHT=WEIGHT*BRHIG(IDEC)
26445           IF (IDEC.EQ.0) THEN
26446             BRHIGQ=0
26447             DO 20 I=1,6
26448  20           BRHIGQ=BRHIGQ+BRHIG(I)
26449             WEIGHT=WEIGHT*BRHIGQ
26450           ENDIF
26451           IF (IDEC.EQ.10) THEN
26452             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26453             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26454             WEIGHT=WEIGHT*BR
26455           ELSEIF (IDEC.EQ.11) THEN
26456             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26457             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26458             WEIGHT=WEIGHT*BR
26459           ENDIF
26460         END IF
26461         IF (EE) THEN
26462           CSFAC=WEIGHT
26463           PSUM=AWW+AZZ(4)
26464           EVWGT=CSFAC*PSUM
26465         ELSEIF (EP) THEN
26466           CSFAC=-WEIGHT*TAULN
26467           XX(1)=ONE
26468           XX(2)=XXMIN
26469           CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD),NSTRU,DISF(1,2),2)
26470           IF (IDHW(1).LE.126) THEN
26471             PWW=(DISF(2,2)+DISF(4,2)+DISF(7,2)+DISF( 9,2))*AWW
26472           ELSE
26473             PWW=(DISF(1,2)+DISF(3,2)+DISF(8,2)+DISF(10,2))*AWW
26474           ENDIF
26475           PZZ(5)=(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2))*AZZ(5)
26476           PZZ(6)=(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF( 9,2))*AZZ(6)
26477           PSUM=PWW+PZZ(5)+PZZ(6)
26478           EVWGT=CSFAC*PSUM
26479         ELSE
26480           CSFAC=WEIGHT*TAULN*XLMIN
26481           CALL HWSGEN(.TRUE.)
26482           PWW=((DISF(2,1)+DISF(4, 1)+DISF(7,1)+DISF(9,1))
26483      &        *(DISF(8,2)+DISF(10,2)+DISF(1,2)+DISF(3,2))
26484      &        +(DISF(8,1)+DISF(10,1)+DISF(1,1)+DISF(3,1))
26485      &        *(DISF(2,2)+DISF(4, 2)+DISF(7,2)+DISF(9,2)))
26486      &        *AWW
26487           PZZ(1)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
26488      &           *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
26489      &           *AZZ(1)
26490           PZZ(2)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
26491      &           *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9, 2))
26492      &           +(DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9, 1))
26493      &           *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
26494      &           *AZZ(2)
26495           PZZ(3)=((DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9,1))
26496      &           *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9,2)))
26497      &           *AZZ(3)
26498           PSUM=PWW+PZZ(1)+PZZ(2)+PZZ(3)
26499 C---EVENT WEIGHT IS SUM OVER ALL COMBINATIONS
26500           EVWGT=CSFAC*PSUM
26501         ENDIF
26502       ELSE
26503 C---GENERATE EVENT
26504 C---CHOOSE EVENT TYPE
26505         RSUM=PSUM*HWRGEN(0)
26506 C---ELECTRON BEAMS?
26507         IF (EE) THEN
26508           IDN(1)=IDHW(1)
26509           IDN(2)=IDHW(2)
26510 C---WW FUSION?
26511           IF (RSUM.LT.AWW) THEN
26512             IDN(3)=IDN(1)+1
26513             IDN(4)=IDN(2)+1
26514 C---ZZ FUSION?
26515           ELSE
26516             IDN(3)=IDN(1)
26517             IDN(4)=IDN(2)
26518           ENDIF
26519 C---LEPTON-HADRON COLLISION?
26520         ELSEIF (EP) THEN
26521 C---WW FUSION?
26522           IDN(1)=IDHW(1)
26523           IF (RSUM.LT.PWW) THEN
26524  24         IDN(2)=HWRINT(1,8)
26525             IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
26526             IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 24
26527             PROB=DISF(IDN(2),2)*AWW/PWW
26528             IF (HWRGEN(0).GT.PROB) GOTO 24
26529             IDN(3)=IDN(1)+1
26530             IF (HWRGEN(0).GT.SCABI) THEN
26531               IDN(4)= 4*INT((IDN(2)-1)/2)-IDN(2)+3
26532             ELSE
26533               IDN(4)=12*INT((IDN(2)-1)/6)-IDN(2)+5
26534             ENDIF
26535 C---ZZ FUSION FROM U-TYPE QUARK?
26536           ELSEIF (RSUM.LT.PWW+PZZ(5)) THEN
26537  26         IDN(2)=2*HWRINT(1,4)
26538             IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
26539             PROB=DISF(IDN(2),2)*AZZ(5)/PZZ(5)
26540             IF (HWRGEN(0).GT.PROB) GOTO 26
26541             IDN(3)=IDN(1)
26542             IDN(4)=IDN(2)
26543 C---ZZ FUSION FROM D-TYPE QUARK?
26544           ELSE
26545  28         IDN(2)=2*HWRINT(1,4)-1
26546             IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
26547             PROB=DISF(IDN(2),2)*AZZ(6)/PZZ(6)
26548             IF (HWRGEN(0).GT.PROB) GOTO 28
26549             IDN(3)=IDN(1)
26550             IDN(4)=IDN(2)
26551           ENDIF
26552 C---HADRON BEAMS?
26553         ELSE
26554 C---WW FUSION?
26555           IF (RSUM.LT.PWW) THEN
26556  31         DO 32 I=1,2
26557               IDN(I)=HWRINT(1,8)
26558               IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
26559  32         CONTINUE
26560             IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 31
26561             PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW/PWW
26562             IF (HWRGEN(0).GT.PROB) GOTO 31
26563 C---CHOOSE OUTGOING QUARKS
26564             DO 33 I=1,2
26565               IF (HWRGEN(0).GT.SCABI) THEN
26566                 IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
26567               ELSE
26568                 IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
26569               ENDIF
26570  33         CONTINUE
26571 C---ZZ FUSION FROM U-TYPE QUARKS?
26572           ELSEIF (RSUM.LT.PWW+PZZ(1)) THEN
26573  41         DO 42 I=1,2
26574               IDN(I)=2*HWRINT(1,4)
26575               IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
26576  42         CONTINUE
26577             PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1)/PZZ(1)
26578             IF (HWRGEN(0).GT.PROB) GOTO 41
26579             IDN(3)=IDN(1)
26580             IDN(4)=IDN(2)
26581 C---ZZ FUSION FROM D-TYPE QUARKS?
26582           ELSEIF (RSUM.LT.PWW+PZZ(1)+PZZ(3)) THEN
26583  51         DO 52 I=1,2
26584               IDN(I)=2*HWRINT(1,4)-1
26585               IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
26586  52         CONTINUE
26587             PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(3)/PZZ(3)
26588             IF (HWRGEN(0).GT.PROB) GOTO 51
26589             IDN(3)=IDN(1)
26590             IDN(4)=IDN(2)
26591 C---ZZ FUSION FROM UD-TYPE PAIRS?
26592           ELSE
26593  61         IF (HWRGEN(0).GT.HALF) THEN
26594               IDN(1)=2*HWRINT(1,4)-1
26595               IDN(2)=2*HWRINT(1,4)
26596             ELSE
26597               IDN(1)=2*HWRINT(1,4)
26598               IDN(2)=2*HWRINT(1,4)-1
26599             ENDIF
26600             DO 62 I=1,2
26601  62           IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
26602             PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2)/PZZ(2)
26603             IF (HWRGEN(0).GT.PROB) GOTO 61
26604             IDN(3)=IDN(1)
26605             IDN(4)=IDN(2)
26606           ENDIF
26607         ENDIF
26608 C---NOW BOOST TO LAB, AND SET UP STATUS CODES etc
26609         IDCMF=15
26610 C---INCOMING
26611         IF (.NOT.EE) CALL HWEONE
26612 C---CMF POINTERS
26613         JDAHEP(1,NHEP)=NHEP+1
26614         JDAHEP(2,NHEP)=NHEP+3
26615         JMOHEP(1,NHEP+1)=NHEP
26616         JMOHEP(1,NHEP+2)=NHEP
26617         JMOHEP(1,NHEP+3)=NHEP
26618 C---OUTGOING MOMENTA (GIVE QUARKS MASS NON-COVARIANTLY!)
26619         Q1(5)=RMASS(IDN(1))
26620         Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
26621         Q2(5)=RMASS(IDN(2))
26622         Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
26623         H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
26624         CALL HWUMAS(H)
26625         CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
26626         CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
26627         CALL HWULOB(PHEP(1,NHEP),H,PHEP(1,NHEP+3))
26628 C---STATUS AND IDs
26629         ISTHEP(NHEP+1)=113
26630         ISTHEP(NHEP+2)=114
26631         ISTHEP(NHEP+3)=114
26632         IDHW(NHEP+1)=IDN(3)
26633         IDHEP(NHEP+1)=IDPDG(IDN(3))
26634         IDHW(NHEP+2)=IDN(4)
26635         IDHEP(NHEP+2)=IDPDG(IDN(4))
26636         IDHW(NHEP+3)=201+IHIGGS
26637         IDHEP(NHEP+3)=IDPDG(201+IHIGGS)
26638 C---COLOUR LABELS
26639         JMOHEP(2,NHEP+1)=NHEP-2
26640         JMOHEP(2,NHEP+2)=NHEP-1
26641         JMOHEP(2,NHEP-1)=NHEP+2
26642         JMOHEP(2,NHEP-2)=NHEP+1
26643         JMOHEP(2,NHEP+3)=NHEP+3
26644         JDAHEP(2,NHEP+1)=NHEP-2
26645         JDAHEP(2,NHEP+2)=NHEP-1
26646         JDAHEP(2,NHEP-1)=NHEP+2
26647         JDAHEP(2,NHEP-2)=NHEP+1
26648         JDAHEP(2,NHEP+3)=NHEP+3
26649         NHEP=NHEP+3
26650       ENDIF
26651   999 END
26652 CDECK  ID>, HWHIGY.
26653 *CMZ :-        -26/04/91  13.37.37  by  Federico Carminati
26654 *-- Author :    Mike Seymour
26655 C-----------------------------------------------------------------------
26656       FUNCTION HWHIGY(A,B,XP)
26657 C-----------------------------------------------------------------------
26658 C     CALCULATE THE INTEGRAL OF BERENDS AND KLEISS APPENDIX B
26659 C-----------------------------------------------------------------------
26660       IMPLICIT NONE
26661       DOUBLE COMPLEX XQ,Z1,Z2,Z3,Z4,C0,C1,C2,C3,C4,C5,C6,C7,C8,FUN,Z
26662       DOUBLE PRECISION HWHIGY,TWO,A,B,XP,Y
26663       PARAMETER (TWO=2.D0)
26664 C---DECLARE ALL THE STATEMENT-FUNCTION DEFINITIONS
26665       C0(Z,A)=(Z**2-A)**2*((Z**2+A)**2-24*Z*(Z**2+A)+8*Z**2*(A+6))/Z**4
26666       C1(Z,A)=A**4/(3*Z)
26667       C2(Z,A)=-A**3*(24*Z-A)/(2*Z**2)
26668       C3(Z,A)=A**2*(8*Z**2*(A+6)-24*A*Z+A**2)/Z**3
26669       C4(Z,A)=-A**2*(24*Z**3+8*Z**2*(A+6)-24*A*Z+A**2)/Z**4
26670       C5(Z,A)=Z**3-24*Z**2+8*Z*(A+6)+24*A
26671       C6(Z,A)=0.5*Z**2-12*Z+4*(A+6)
26672       C7(Z,A)=Z/3-8
26673       C8(Z,A)=0.25
26674       FUN(Z,Y,A)=C0(Z,A)*LOG(Y-Z)
26675      &          +C1(Z,A)/Y**3
26676      &          +C2(Z,A)/Y**2
26677      &          +C3(Z,A)/Y
26678      &          +C4(Z,A)*LOG(Y)
26679      &          +C5(Z,A)*Y
26680      &          +C6(Z,A)*Y**2
26681      &          +C7(Z,A)*Y**3
26682      &          +C8(Z,A)*Y**4
26683 C---NOW EVALUATE THE INTEGRAL
26684       HWHIGY=0
26685       IF (A.GT.4) RETURN
26686       XQ=DCMPLX(XP,B)
26687       Z1=XQ+SQRT(XQ**2-A)
26688       Z2=XQ-SQRT(XQ**2-A)
26689       Z3=FUN(Z1,TWO,A)-FUN(Z1,SQRT(A),A)
26690       Z4=FUN(Z2,TWO,A)-FUN(Z2,SQRT(A),A)
26691       HWHIGY=DIMAG((Z3-Z4)/(Z1-Z2))/(8*B)
26692       END
26693 CDECK  ID>, HWHIGZ.
26694 *CMZ :-        -02/05/91  11.18.44  by  Federico Carminati
26695 *-- Author :    Mike Seymour, modified by Stefano Moretti
26696 C-----------------------------------------------------------------------
26697       SUBROUTINE HWHIGZ
26698 C-----------------------------------------------------------------------
26699 C     HIGGS PRODUCTION VIA THE BJORKEN PROCESS: E+E- --> Z(*) --> Z(*)H
26700 C     WHERE ONE OR BOTH OF THE Zs IS OFF-SHELL
26701 C     USES ALGORITHM OF BERENDS AND KLEISS: NUCL.PHYS. B260(1985)32
26702 C
26703 C     MEAN EVWGT = CROSS-SECTION (IN NB) * HIGGS BRANCHING FRACTION
26704 C-----------------------------------------------------------------------
26705       INCLUDE 'HERWIG65.INC'
26706       DOUBLE PRECISION HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO,EMZ,CVE,CAE,
26707      & POL1,POL2,CE1,CE2,CE3,PMAX,EMZ2,S,B,FACTR,EMH,EMFAC,EMH2,A,XP,
26708      & CV,CA,BRHIGQ,BR,X1,X2,FAC1,FAC2,XPP,XPPSQ,COEF,X,XSQ,PROB,C1,C2,
26709      & CHIGG,PTHETA,SHIGG,C3,PHIMAX,CPHI,SPHI,C2PHI,S2PHI,PCM,ELST
26710       INTEGER IDEC,I,NLOOP,ICMF,IHIG,IZED,IFER,IANT,ID1,ID2,IN1,IN2
26711       EXTERNAL HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO
26712       SAVE CVE,CAE,CE1,CE2,CE3,PMAX,EMZ2,S,EMH,B,FACTR,A,EMH2
26713       EQUIVALENCE (EMZ,RMASS(200))
26714       DATA ELST/0/
26715 C---SET UP CONSTANTS
26716       IN1=1
26717       IF (JDAHEP(1,IN1).NE.0) IN1=JDAHEP(1,IN1)
26718       IN2=2
26719       IF (JDAHEP(1,IN2).NE.0) IN2=JDAHEP(1,IN2)
26720       IF (FSTWGT.OR.ELST.NE.PHEP(5,3)) THEN
26721         ELST=PHEP(5,3)
26722         CVE=VFCH(11,1)
26723         CAE=AFCH(11,1)
26724         POL1=1.-EPOLN(3)*PPOLN(3)
26725         POL2=EPOLN(3)-PPOLN(3)
26726         CE1=(POL1*(CVE**2+CAE**2)+POL2*2.*CVE*CAE)
26727         CE2=(POL1*2.*CVE*CAE+POL2*(CVE**2+CAE**2))
26728         IF ((IDHW(IN1).GT.IDHW(IN2).AND.PHEP(3,IN1).LT.ZERO).OR.
26729      &      (IDHW(IN2).GT.IDHW(IN1).AND.PHEP(3,IN2).LT.ZERO)) CE2=-CE2
26730         IF (TPOL) CE3=(CVE**2-CAE**2)
26731         PMAX=4
26732         EMZ2=EMZ**2
26733         S=PHEP(5,3)**2
26734         B=EMZ*GAMZ/S
26735         FACTR=GEV2NB*CE1*(HWUAEM(RMASS(201+IHIGGS)**2)*ENHANC(11))**2
26736      &       /(12.*S*SWEIN*(1.-SWEIN))*B/((1-EMZ2/S)**2+B**2)
26737       ENDIF
26738       IF (.NOT.GENEV) THEN
26739 C---CHOOSE HIGGS MASS, AND CALCULATE EVENT WEIGHT
26740         EVWGT=0D0
26741         EMH=RMASS(201+IHIGGS)
26742         EMFAC=ONE
26743         IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
26744         IF (EMH.LE.ZERO .OR. EMH.GT.PHEP(5,3)) RETURN
26745         EMSCA=EMH
26746         EMH2=EMH**2
26747         A=4*EMH2/S
26748         XP=1+(EMH2-EMZ2)/S
26749         EVWGT=FACTR*HWHIGY(A,B,XP)*EMFAC
26750 C---INCLUDE BRANCHING RATIO OF HIGGS
26751         IF(IMSSM.EQ.0)THEN
26752           IDEC=MOD(IPROC,100)
26753           IF (IDEC.GT.0.AND.IDEC.LE.12) EVWGT=EVWGT*BRHIG(IDEC)
26754           IF (IDEC.EQ.0) THEN
26755             BRHIGQ=0
26756             DO 10 I=1,6
26757  10           BRHIGQ=BRHIGQ+BRHIG(I)
26758             EVWGT=EVWGT*BRHIGQ
26759           ENDIF
26760 C Add Z branching fractions
26761           CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,0)
26762           EVWGT=EVWGT*BR
26763           IF (IDEC.EQ.10) THEN
26764             CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26765             CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26766             EVWGT=EVWGT*BR
26767           ELSEIF (IDEC.EQ.11) THEN
26768             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26769             CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26770             EVWGT=EVWGT*BR
26771           ENDIF
26772         END IF
26773       ELSE
26774 C---GENERATE EVENT
26775         ICMF=NHEP+1
26776         IHIG=NHEP+2
26777         IZED=NHEP+3
26778         IFER=NHEP+4
26779         IANT=NHEP+5
26780         CALL HWVEQU(5,PHEP(1,3),PHEP(1,ICMF))
26781         NHEP=NHEP+5
26782 C---CHOOSE ENERGY FRACTION OF HIGGS
26783         X1=SQRT(A)
26784         X2=1+0.25*A
26785         XP=1+(EMH2-EMZ2)/S
26786         FAC1=ATAN((X1-XP)/B)
26787         FAC2=ATAN((X2-XP)/B)
26788         XPP=MIN(X2,MAX(X1+B,XP))
26789         XPPSQ=XPP**2
26790         NLOOP=0
26791         COEF=1./((12+2*A-12*XPP+XPPSQ)*SQRT(XPPSQ-A))
26792  20       NLOOP=NLOOP+1
26793           IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',101,*999)
26794           X=XP+B*TAN(HWRUNI(1,FAC1,FAC2))
26795           XSQ=X**2
26796           PROB=COEF*((12+2*A-12*X+XSQ)*SQRT(XSQ-A))
26797           IF (PROB.GT.PMAX) THEN
26798             PMAX=1.1*PROB
26799             CALL HWWARN('HWHIGZ',1,*999)
26800             WRITE (6,21) PMAX
26801  21         FORMAT(7X,'NEW HWHIGZ MAX WEIGHT =',F8.4)
26802           ENDIF
26803         IF (PROB.LT.PMAX*HWRGEN(0)) GOTO 20
26804 C Choose Z decay mode
26805         CALL HWDBOZ(200,IDHW(IFER),IDHW(IANT),CV,CA,BR,0)
26806         C1=CE1*(CV**2+CA**2)
26807         C2=CE2*2.*CV*CA
26808 C---CHOOSE HIGGS DIRECTION
26809 C First polar angle
26810         NLOOP=0
26811         COEF=(XSQ-A)/(8.*(1.-X)+XSQ+A)
26812  30       NLOOP=NLOOP+1
26813           IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',102,*999)
26814           CHIGG=HWRUNI(2,-ONE, ONE)
26815           PTHETA=1-COEF*CHIGG**2
26816         IF (PTHETA.LT.HWRGEN(1)) GOTO 30
26817         SHIGG=SQRT(1-CHIGG**2)
26818 C Now azimuthal angle
26819         IF (TPOL) THEN
26820            C3=CE3*(CV*2+CA**2)
26821            COEF=COEF*SHIGG**2*C3/C1
26822            PHIMAX=PTHETA+ABS(COEF)
26823   40       CALL HWRAZM(ONE,CPHI,SPHI)
26824            C2PHI=2.*CPHI**2-1.
26825            S2PHI=2.*CPHI*SPHI
26826            PROB=PTHETA-COEF*(C2PHI*COSS+S2PHI*SINS)
26827            IF (PROB.LT.HWRGEN(1)*PHIMAX) GOTO 40
26828         ELSE
26829            CALL HWRAZM(ONE,CPHI,SPHI)
26830         ENDIF
26831 C Construct Higgs and Z momenta
26832         PHEP(5,IHIG)=EMH
26833         PHEP(4,IHIG)=X*PHEP(5,ICMF)/2
26834         PCM=SQRT(PHEP(4,IHIG)**2-EMH2)
26835         PHEP(3,IHIG)=CHIGG*PCM
26836         PHEP(1,IHIG)=SHIGG*PCM*CPHI
26837         PHEP(2,IHIG)=SHIGG*PCM*SPHI
26838         CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,IHIG),PHEP(1,IZED))
26839         CALL HWUMAS(PHEP(1,IZED))
26840 C Choose orientation of Z decay
26841         NLOOP=0
26842         COEF=2.*(C1+ABS(C2))*HWULDO(PHEP(1,IN1),PHEP(1,IZED))
26843      &                      *HWULDO(PHEP(1,IN2),PHEP(1,IZED))/S
26844         IF (TPOL) COEF=COEF*(C1+ABS(C2)+ABS(C3))/(C1+ABS(C2))
26845         PCM=PHEP(5,IZED)/2
26846         PHEP(5,IFER)=0
26847         PHEP(5,IANT)=0
26848  50     NLOOP=NLOOP+1
26849         IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',103,*999)
26850         CALL HWDTWO(PHEP(1,IZED),PHEP(1,IFER),PHEP(1,IANT),
26851      &              PCM,TWO,.TRUE.)
26852         PROB=C1*(PHEP(4,IFER)*PHEP(4,IANT)-PHEP(3,IFER)*PHEP(3,IANT))
26853      &      +C2*(PHEP(4,IFER)*PHEP(3,IANT)-PHEP(3,IFER)*PHEP(4,IANT))
26854         IF (TPOL) PROB=PROB+C3*
26855      &   (COSS*(PHEP(1,IFER)*PHEP(1,IANT)-PHEP(2,IFER)*PHEP(2,IANT))
26856      &   +SINS*(PHEP(1,IFER)*PHEP(2,IANT)+PHEP(2,IFER)*PHEP(1,IANT)))
26857         IF (PROB.LT.HWRGEN(2)*COEF) GOTO 50
26858 C---SET UP STATUS CODES,
26859         ISTHEP(ICMF)=120
26860         ISTHEP(IHIG)=190
26861         ISTHEP(IZED)=195
26862         ISTHEP(IFER)=113
26863         ISTHEP(IANT)=114
26864 C---COLOR CONNECTIONS,
26865         JMOHEP(1,ICMF)=1
26866         JMOHEP(2,ICMF)=2
26867         JDAHEP(1,ICMF)=IHIG
26868         JDAHEP(2,ICMF)=IZED
26869         JMOHEP(1,IHIG)=ICMF
26870         JMOHEP(1,IZED)=ICMF
26871         JMOHEP(1,IFER)=IZED
26872         JMOHEP(1,IANT)=IZED
26873         JMOHEP(2,IFER)=IANT
26874         JMOHEP(2,IANT)=IFER
26875         JDAHEP(1,IZED)=IFER
26876         JDAHEP(2,IZED)=IANT
26877         JDAHEP(2,IFER)=IANT
26878         JDAHEP(2,IANT)=IFER
26879 C---IDENTITY CODES
26880         IDHW(ICMF)=200
26881         IDHW(IHIG)=201+IHIGGS
26882         IDHW(IZED)=200
26883         IDHEP(ICMF)=IDPDG(IDHW(ICMF))
26884         IDHEP(IHIG)=IDPDG(IDHW(IHIG))
26885         IDHEP(IZED)=IDPDG(IDHW(IZED))
26886         IDHEP(IFER)=IDPDG(IDHW(IFER))
26887         IDHEP(IANT)=IDPDG(IDHW(IANT))
26888       ENDIF
26889  999  END
26890 CDECK  ID>, HWHIHH.
26891 *CMZ :-        -25/11/01  17.11.33  by  Stefano Moretti
26892 *-- Author :  Kosuke Odagiri, modified by Stefano Moretti
26893 C-----------------------------------------------------------------------
26894 C...Generate completely differential cross section (EVWGT) in the variable
26895 C...X(I) with I=1 (see below) for the processes IPROC=955,965,975 as
26896 C...described in the HERWIG 6 documentation file.
26897 C
26898 C...First release: 12-NOV-2001 by Stefano Moretti
26899 C
26900 C-----------------------------------------------------------------------
26901       SUBROUTINE HWHIHH
26902 C-----------------------------------------------------------------------
26903 C     PRODUCTION OF MSSM HIGGS PAIRS IN L+L- (L=E,MU)
26904 C-----------------------------------------------------------------------
26905       INCLUDE 'HERWIG65.INC'
26906       DOUBLE PRECISION HWRGEN, HWUAEM, HCS, RCS, S, PF, QPE,
26907      & FACTR, SN2TH, MZ, MNN(2), MCC, EMSC2, GZ2,
26908      & GHH(4), XWEIN, S2W, X(1), XL(1),
26909      & XU(1), WEIGHT, ECM, RMH1, RMH2, EMH1, EMH2,
26910      & EMHWT1, EMHWT2, EMHHWT, SHAT
26911       INTEGER I, ID1, ID2, IH1, IH2, IH, JH
26912       EXTERNAL HWRGEN, HWUAEM
26913       SAVE HCS,MNN,MCC,EMHHWT,S,SHAT
26914       DOUBLE COMPLEX Z, GZ, A, D, E
26915       PARAMETER (Z = (0.D0,1.D0))
26916       EQUIVALENCE (MZ, RMASS(200))
26917 C...process event.
26918       IF (GENEV) THEN
26919         RCS = HCS*HWRGEN(0)
26920       ELSE
26921         HCS = ZERO
26922         EVWGT = ZERO
26923 C...energy at parton level.
26924         ECM = PBEAM1+PBEAM2
26925         S = ECM*ECM
26926         SHAT = S
26927 C...phase space variables.
26928 C...X(1)=COS(THETA_CM),
26929 C...phase space borders.
26930         XL(1)= -1.
26931         XU(1)= 1.
26932 C...single phase space point.
26933  100    CONTINUE
26934         WEIGHT=1.
26935         DO I=1,1
26936           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
26937           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
26938         END DO
26939 C...final state masses.
26940         IF((MOD(IPROC,10000).EQ.965).OR.
26941      &     (MOD(IPROC,10000).EQ.975))THEN
26942           JH  = IHIGGS-1
26943           ID1 = 205
26944           ID2 = 202 + JH
26945         ELSE IF(MOD(IPROC,10000).EQ.955)THEN
26946           JH  = 4
26947           ID1 = 206
26948           ID2 = 207
26949         END IF
26950         RMH1=RMASS(ID1)
26951         RMH2=RMASS(ID2)
26952         EMH1=RMH1
26953         EMH2=RMH2
26954         EMHWT1=1.
26955         EMHWT2=1.
26956         EMHHWT=EMHWT1*EMHWT2
26957 C...polar angle.
26958         COSTH = X(1)
26959         SN2TH = 0.25D0 - 0.25D0*COSTH**2
26960         EMSCA = EMH1+EMH2
26961         EMSC2 = EMSCA*EMSCA
26962         EVWGT = ZERO
26963         FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT*SN2TH/2.
26964 C...constant weight.
26965         FACTR = FACTR*WEIGHT
26966 C...couplings and propagators.
26967         XWEIN = TWO*SWEIN
26968         S2W   = DSQRT(XWEIN*(TWO-XWEIN))
26969         GZ    = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT
26970         GZ2   = DREAL(DCONJG(GZ)*GZ)
26971 C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-.
26972         GHH(1)= COSBMA
26973         GHH(2)= SINBMA
26974         GHH(3)= ONE
26975         GHH(4)= ONE-XWEIN
26976 C...set to zero all MEs.
26977         DO I=1,2
26978           MNN(I)=ZERO
26979         END DO
26980         MCC=ZERO
26981 C...start subprocesses.
26982         IF((MOD(IPROC,10000).EQ.965).OR.
26983      &     (MOD(IPROC,10000).EQ.975))THEN
26984 c
26985 c   -  +      o  o   o
26986 c  l  l   -> A  h / H
26987 c
26988           DO IH = JH,JH
26989             QPE = SHAT-(EMH1+EMH2)**2
26990             IF (QPE.GT.ZERO) THEN
26991               PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
26992               MNN(IH) =
26993      &          FACTR*PF**3*GHH(IH)**2*(LFCH(11)**2+RFCH(11)**2)/GZ2
26994             ELSE
26995               CONTINUE
26996             END IF
26997           END DO
26998         ELSE IF(MOD(IPROC,10000).EQ.955)THEN
26999 c
27000 c   -  +     +  -
27001 c  l  l  -> H  H
27002 c
27003           IH = JH
27004           QPE = SHAT-(EMH1+EMH2)**2
27005           IF (QPE.GT.ZERO) THEN
27006             PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
27007             A = GHH(IH)/GZ
27008             D = QFCH(11)+A*LFCH(11)
27009             E = QFCH(11)+A*RFCH(11)
27010             MCC=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
27011           ELSE
27012             CONTINUE
27013           END IF
27014         END IF
27015       END IF
27016       HCS = ZERO
27017       IF(MOD(IPROC,10000).EQ.965)THEN
27018         IH1 = 205
27019         IH2 = 203
27020         HCS = HCS + EMHHWT*MNN(1)
27021       ELSE IF(MOD(IPROC,10000).EQ.975)THEN
27022         IH1 = 205
27023         IH2 = 204
27024         HCS = HCS + EMHHWT*MNN(2)
27025       ELSE IF(MOD(IPROC,10000).EQ.955)THEN
27026         IH1 = 206
27027         IH2 = 207
27028         HCS = HCS + EMHHWT*MCC
27029       END IF
27030       IF (GENEV.AND.HCS.GT.RCS) THEN
27031 C...generate event.
27032         IDN(1)=IDHW(1)
27033         IDN(2)=IDHW(2)
27034         IDN(3)=IH1
27035         IDN(4)=IH2
27036         IDCMF=15
27037         XX(1) = ONE
27038         XX(2) = ONE
27039         CALL HWETWO(.TRUE.,.TRUE.)
27040         IF (AZSPIN) THEN
27041           CALL HWVZRO(7,GCOEF)
27042         END IF
27043       END IF
27044       EVWGT = HCS
27045       RETURN
27046       END
27047 CDECK  ID>, HWHISQ.
27048 *CMZ :-        -30/06/01  18.41.23  by  Stefano Moretti
27049 *-- Author :  Stefano Moretti
27050 C-----------------------------------------------------------------------
27051 C...Generate completely differential cross section (EVWGT) in the variables
27052 C...X(I) with I=1,6 (see below) for the processes from IPROC=3110
27053 C...to IPROC=3298, as described in the HERWIG 6 documentation file.
27054 C...It includes interface to PDFs and takes into account color connections
27055 C...among partons.
27056 C
27057 C...First release: 08-APR-2000 by Stefano Moretti
27058 C...Last modified: 29-JUN-2001 by Stefano Moretti
27059 C
27060 C-----------------------------------------------------------------------
27061       SUBROUTINE HWHISQ
27062 C-----------------------------------------------------------------------
27063 C     PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH B,T-SQUARK PAIRS
27064 C-----------------------------------------------------------------------
27065       INCLUDE 'HERWIG65.INC'
27066       COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
27067       INTEGER      JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
27068       INTEGER I,J,K,L,M,N
27069       INTEGER IQMIN,IQMAX,IGG,IQQ,JPP
27070       INTEGER NC,FLIP
27071       INTEGER IF1,IF2
27072       INTEGER JHH,IMIX1,IMIX2
27073       INTEGER JSQ,JSQ1,JSQ2
27074       INTEGER IME,JME
27075       DOUBLE PRECISION EMSQ1,EMSQ2,GAMSQ1,GAMSQ2,EMSQQ,EMH,EMHWT,EMW
27076       DOUBLE PRECISION GSQ1,GSQ2
27077       DOUBLE PRECISION X(6),XL(6),XU(6)
27078       DOUBLE PRECISION Q4(0:3),Q34(0:3)
27079       DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
27080       DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
27081       DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
27082       DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
27083       DOUBLE PRECISION GGSQHT,GGSQHU,GGSQHN,QQSQH
27084       DOUBLE PRECISION M2GG(8),M2GGPL(8),M2GGMN(8),M2QQ(8)
27085       DOUBLE PRECISION ALPHA,ALPHAS,EMSC2
27086       DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF
27087       DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
27088       DOUBLE PRECISION VCOL,GCOL,QAUX(0:3)
27089       DOUBLE PRECISION EPS,HCS,RCS,GACT,FACT(8),DIST
27090       DOUBLE PRECISION WEIGHT
27091       SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5
27092       SAVE IME,JSQ1,JSQ2
27093       LOGICAL HWRLOG
27094       EXTERNAL HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2SH,HWETWO,HWRLOG
27095       PARAMETER (EPS=1.D-9)
27096       EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO)
27097 C...process the event.
27098       IF(GENEV)THEN
27099         RCS=HCS*HWRGEN(0)
27100       ELSE
27101         HCS=0.
27102         EVWGT=0.
27103 C...loop over final state flavours.
27104         IME=0
27105         DO I=1,8
27106           M2GG(I)=0.
27107           M2GGPL(I)=0.
27108           M2GGMN(I)=0.
27109           M2QQ(I)=0.
27110           FACT(I)=0.
27111         END DO
27112         DO 2 IF1=IF1MIN,IF1MAX
27113         IF((IF1.GE.407).AND.(IF1.LE.416))GOTO 2
27114         DO 1 IF2=IF2MIN,IF2MAX
27115         IF((IF2.GE.413).AND.(IF2.LE.422))GOTO 1
27116 C...assign squark flavour.
27117         JSQ1=IF1
27118         JSQ2=IF2
27119 C...check charge.
27120         IF((ICHRG(JSQ1)+ICHRG(JSQ2))/3.NE.-ICHRG(201+JHIGGS+1))GOTO 1
27121         IME=IME+1
27122         IF((IME.LE.0).OR.(IME.GT.8))CALL HWWARN('HWHISQ',100,*999)
27123 C...assign final state masses and widths.
27124         EMSQ1=RMASS(JSQ1)
27125         EMSQ2=RMASS(JSQ2)
27126         GAMSQ1=HBAR/RLTIM(JSQ1)
27127         GAMSQ2=HBAR/RLTIM(JSQ2)
27128         EMH=RMASS(201+JHIGGS+1)
27129         EMHWT=1.
27130 C...energy at hadron level.
27131         ECM_MAX=PBEAM1+PBEAM2
27132         S=ECM_MAX*ECM_MAX
27133 C...phase space variables.
27134 C...X(1)=(EMSQQ-EMSQ1-EMSQ2)/(ECM-EMSQ1-EMSQ2-EMH),
27135 C...X(2)=COS(THETA5_CM),X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
27136 C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2),
27137 C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
27138 C...phase space borders.
27139         XL(1)=0.
27140         XU(1)=1.
27141         XL(2)=-1.
27142         XU(2)=1.
27143         XL(3)=-1.
27144         XU(3)=1.
27145         XL(4)=0.
27146         XU(4)=2.*PIFAC
27147         XL(5)=0.
27148         XU(5)=1.
27149         XL(6)=0.
27150         XU(6)=1.
27151 C...single phase space point.
27152  100    CONTINUE
27153         WEIGHT=1.
27154         DO I=1,6
27155           X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
27156           WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
27157         END DO
27158 C...energy at parton level.
27159         ECM=SQRT(1./(X(5)*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2)
27160      &                                            +1./ECM_MAX**2))
27161         IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
27162         SHAT=ECM*ECM
27163         TAU=SHAT/S
27164 C...momentum fractions X1 and X2.
27165         XX(1)=EXP(LOG(TAU)*(1.-X(6)))
27166         XX(2)=TAU/XX(1)
27167 C...three particle kinematics.
27168         EMSQQ=X(1)*(ECM-EMSQ1-EMSQ2-EMH)+EMSQ1+EMSQ2
27169         CT5=X(2)
27170         IF(HWRLOG(HALF))THEN
27171           ST5=+SQRT(1.-CT5*CT5)
27172         ELSE
27173           ST5=-SQRT(1.-CT5*CT5)
27174         END IF
27175         CT4=X(3)
27176         ST4=SQRT(1.-CT4*CT4)
27177         CF4=COS(X(4))
27178         SF4=SIN(X(4))
27179         RQ52=((ECM*ECM-EMH*EMH-EMSQQ*EMSQQ)**2-(2.*EMH*EMSQQ)**2)/
27180      &     (4.*ECM*ECM)
27181         IF(RQ52.LT.0.)THEN
27182           GOTO 100
27183         ELSE
27184           RQ5=SQRT(RQ52)
27185         ENDIF
27186         P5(1)=0.
27187         P5(2)=RQ5*ST5
27188         P5(3)=RQ5*CT5
27189         P5(0)=SQRT(RQ52+EMH*EMH)
27190         DO I=1,3
27191           Q34(I)=-P5(I)
27192         END DO
27193         Q34(0)=SQRT(RQ52+EMSQQ*EMSQQ)
27194         RQ42=((EMSQQ*EMSQQ-EMSQ1*EMSQ1-EMSQ2*EMSQ2)**2
27195      &    -(2.*EMSQ1*EMSQ2)**2)/
27196      &     (4.*EMSQQ*EMSQQ)
27197         IF(RQ42.LT.0.)THEN
27198           GOTO 100
27199         ELSE
27200           RQ4=SQRT(RQ42)
27201         ENDIF
27202         Q4(1)=RQ4*ST4*CF4
27203         Q4(2)=RQ4*ST4*SF4
27204         Q4(3)=RQ4*CT4
27205         Q4(0)=SQRT(RQ42+EMSQ2*EMSQ2)
27206         PQ4=0.
27207         DO I=1,3
27208           PQ4=PQ4+Q34(I)*Q4(I)
27209         END DO
27210         P4(0)=(Q34(0)*Q4(0)+PQ4)/EMSQQ
27211         P3(0)=Q34(0)-P4(0)
27212         DO I=1,3
27213           P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMSQQ)
27214           P3(I)=Q34(I)-P4(I)
27215         END DO
27216 C...incoming partons: all massless.
27217         EMIN=0.
27218 C...initial state momenta in the partonic CM.
27219         PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
27220      &         -(2.*EMIN*EMIN)**2)/(4.*SHAT)
27221         PCM=SQRT(PCM2)
27222         P1(0)=SQRT(PCM2+EMIN*EMIN)
27223         P1(1)=0.
27224         P1(2)=0.
27225         P1(3)=PCM
27226         P2(0)=SQRT(PCM2+EMIN*EMIN)
27227         P2(1)=0.
27228         P2(2)=0.
27229         P2(3)=-PCM
27230 C...color structured ME summed/averaged over final/initial spins and colors.
27231         IGG=1
27232         IQQ=1
27233         JPP=(MOD(IPROC,10000)/10-ILBL/10)
27234         IF((JPP.EQ.4).OR.(JPP.EQ.5).OR.(JPP.EQ.6))IQQ=0
27235         IF((JPP.EQ.7).OR.(JPP.EQ.8).OR.(JPP.EQ.9))IGG=0
27236         GSQ1=GAMSQ1*EMSQ1
27237         GSQ2=GAMSQ2*EMSQ2
27238         CALL HWH2SH(ECM,P1,P2,P3,P4,P5,EMSQ1,EMSQ2,EMH,GSQ1,GSQ2,
27239      &              IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
27240         M2GG(IME)=GGSQHN/(8.*CFFAC)
27241         M2GGPL(IME)=GGSQHT/(8.*CFFAC)
27242         M2GGMN(IME)=GGSQHU/(8.*CFFAC)
27243         M2QQ(IME)=QQSQH*(1.-1./CAFAC**2)/4.
27244 C...constant factors: phi along beam and conversion GeV^2->nb.
27245         GACT=2.*PIFAC*GEV2NB
27246 C...Jacobians from X1,X2 to X(5),X(6)
27247         GACT=GACT/S*(-LOG(TAU))*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2)
27248 C...phase space Jacobians, pi's and flux.
27249         GACT=GACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
27250      &      *(ECM-EMSQ1-EMSQ2-EMH)
27251 C...EW and QCD couplings.
27252         EMSCA=EMSQ1+EMSQ2+EMH
27253         EMSC2=EMSCA*EMSCA
27254         ALPHA=HWUAEM(EMSC2)
27255         ALPHAS=HWUALF(1,EMSCA)
27256         GACT=GACT*4.*PIFAC*ALPHA/SWEIN
27257         GACT=GACT*16.*PIFAC**2*ALPHAS**2
27258 C...enhancement factor for MSSM.
27259         JHH=JHIGGS
27260         IF(JHIGGS.EQ.5)JHH=4
27261         JSQ=JSQ1-400
27262         IF(JSQ1.GT.412)JSQ=JSQ1-412
27263         IMIX1=1
27264         IMIX2=1
27265         IF(JSQ1.GT.412)IMIX1=2
27266         IF(JSQ2.GT.418)IMIX2=2
27267         SENHNC(JSQ)=GHSQSS(JHH,JSQ,IMIX1,IMIX2)
27268         GACT=GACT*SENHNC(JSQ)*SENHNC(JSQ)
27269 C...Higgs resonance.
27270         GACT=GACT*EMHWT
27271 C...constant weight.
27272         GACT=GACT*WEIGHT
27273 C...collects it.
27274         FACT(IME)=GACT
27275  1      CONTINUE
27276  2      CONTINUE
27277       END IF
27278 C...set up flavours in final state.
27279       FLIP=0
27280 C...set up PDFs.
27281       HCS=0.
27282       CALL HWSGEN(.FALSE.)
27283       IQMAX=13
27284       IF(MOD(IPROC,10000)-ILBL.GE.70)IQMAX=12
27285       IQMIN=1
27286       IF(MOD(IPROC,10000)-ILBL.GE.40)IQMIN=13
27287       IF(MOD(IPROC,10000)-ILBL.GE.70)IQMIN=1
27288       DO 3 JME=1,IME
27289       IF((M2GGPL(JME)+M2GGMN(JME)).EQ.0.)GOTO 3
27290       DO I=IQMIN,IQMAX
27291         IF(DISF(I,1).LT.EPS)THEN
27292           GOTO 200
27293         END IF
27294         K=I/7
27295         L=+1-2*K
27296         IF(I.EQ.13)L=0
27297         J=I+L*6
27298         IF(DISF(J,2).LT.EPS)THEN
27299           GOTO 200
27300         END IF
27301         DIST=DISF(I,1)*DISF(J,2)*S
27302         IF(I.LT.13)THEN
27303 C...set up color connections: qq-scattering.
27304           IF(J.EQ.I+6)THEN
27305             HCS=HCS+M2QQ(JME)*DIST*FACT(JME)
27306             IF(GENEV.AND.HCS.GT.RCS)THEN
27307               CONTINUE
27308               CALL HWHQCP(JSQ1,JSQ2,2413, 4,*9)
27309             END IF
27310           ELSE IF(I.EQ.J+6)THEN
27311             HCS=HCS+M2QQ(JME)*DIST*FACT(JME)
27312             IF(GENEV.AND.HCS.GT.RCS)THEN
27313               FLIP=1
27314               CALL HWHQCP(JSQ2,JSQ1,3142,12,*9)
27315             END IF
27316           END IF
27317         ELSE
27318 C...set up color connections: gg-scattering.
27319           HCS=HCS
27320      &   +(M2GGPL(JME)-M2GG(JME)*M2GGPL(JME)
27321      &   /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
27322           IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(JSQ1,JSQ2,2413,27,*9)
27323           HCS=HCS
27324      &   +(M2GGMN(JME)-M2GG(JME)*M2GGMN(JME)
27325      &   /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
27326           IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(JSQ1,JSQ2,4123,28,*9)
27327         END IF
27328  200    CONTINUE
27329       END DO
27330  3    CONTINUE
27331       EVWGT=HCS
27332       RETURN
27333 C...generate event.
27334     9 IDN(1)=I
27335       IDN(2)=J
27336       IDN(5)=JH
27337 C...incoming partons: now massive.
27338       EMIN1=RMASS(IDN(1))
27339       EMIN2=RMASS(IDN(2))
27340 C...redo initial state momenta in the partonic CM.
27341       PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
27342      &       -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
27343       PCM=SQRT(PCM2)
27344       P1(0)=SQRT(PCM2+EMIN1*EMIN1)
27345       P1(1)=0.
27346       P1(2)=0.
27347       P1(3)=PCM
27348       P2(0)=SQRT(PCM2+EMIN2*EMIN2)
27349       P2(1)=0.
27350       P2(2)=0.
27351       P2(3)=-PCM
27352 C...randomly rotate final state momenta around beam axis.
27353       PHI=2.*PIFAC*HWRGEN(0)
27354       CPHI=COS(PHI)
27355       SPHI=SIN(PHI)
27356       ROT(1,1)=+CPHI
27357       ROT(1,2)=+SPHI
27358       ROT(1,3)=0.
27359       ROT(2,1)=-SPHI
27360       ROT(2,2)=+CPHI
27361       ROT(2,3)=0.
27362       ROT(3,1)=0.
27363       ROT(3,2)=0.
27364       ROT(3,3)=1.
27365       DO L=1,3
27366         DO M=1,3
27367           QAUX(M)=0.
27368           DO N=1,3
27369             IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
27370             IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
27371             IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
27372           END DO
27373         END DO
27374         DO M=1,3
27375           IF(L.EQ.1)P3(M)=QAUX(M)
27376           IF(L.EQ.2)P4(M)=QAUX(M)
27377           IF(L.EQ.3)P5(M)=QAUX(M)
27378         END DO
27379       END DO
27380 C...use HWETWO only to set up status and IDs of (s)quarks.
27381       COSTH=0.
27382       IDCMF=15
27383       CALL HWETWO(.TRUE.,.TRUE.)
27384 C...do real incoming, outgoing momenta in the lab frame.
27385       VCOL=(XX(1)-XX(2))/(XX(1)+XX(2))
27386       GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2))
27387       DO M=NHEP-4,NHEP+1
27388         IF(M.EQ.NHEP-2)GO TO 888
27389         DO N=0,3
27390           IF(M.EQ.NHEP-4)QAUX(N)=P1(N)
27391           IF(M.EQ.NHEP-3)QAUX(N)=P2(N)
27392           IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP
27393           IF(M.EQ.NHEP  )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP
27394           IF(M.EQ.NHEP+1)QAUX(N)=P5(N)
27395         END DO
27396 C...perform boost.
27397         PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3))
27398         PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0))
27399         PHEP(2,M)=QAUX(2)
27400         PHEP(1,M)=QAUX(1)
27401  888    CONTINUE
27402       END DO
27403 C...needs to set all final state masses.
27404       PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2
27405      &                       -PHEP(3,NHEP-1)**2
27406      &                       -PHEP(2,NHEP-1)**2
27407      &                       -PHEP(1,NHEP-1)**2))
27408       PHEP(5,NHEP  )=SQRT(ABS(PHEP(4,NHEP  )**2
27409      &                       -PHEP(3,NHEP  )**2
27410      &                       -PHEP(2,NHEP  )**2
27411      &                       -PHEP(1,NHEP  )**2))
27412       PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
27413      &                       -PHEP(3,NHEP+1)**2
27414      &                       -PHEP(2,NHEP+1)**2
27415      &                       -PHEP(1,NHEP+1)**2))
27416 C...sets CMF.
27417       DO I=1,4
27418         PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3)
27419       END DO
27420       PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2
27421      &                       -PHEP(3,NHEP-2)**2
27422      &                       -PHEP(2,NHEP-2)**2
27423      &                       -PHEP(1,NHEP-2)**2))
27424 C...status and IDs for Higgs.
27425       ISTHEP(NHEP+1)=114
27426       IDHW(NHEP+1)=IDN(5)
27427       IDHEP(NHEP+1)=IDPDG(IDN(5))
27428 C...Higgs colour (self-)connections.
27429       JMOHEP(1,NHEP+1)=NHEP-2
27430       JMOHEP(2,NHEP+1)=NHEP+1
27431       JDAHEP(2,NHEP+1)=NHEP+1
27432       JDAHEP(2,NHEP-2)=NHEP+1
27433       NHEP=NHEP+1
27434       IF(AZSPIN)THEN
27435 C...set to zero the coefficients of the spin density matrices.
27436         CALL HWVZRO(7,GCOEF)
27437       END IF
27438   999 END
27439 CDECK  ID>, HWHPH2.
27440 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
27441 *-- Author :    Ian Knowles
27442 C-----------------------------------------------------------------------
27443       SUBROUTINE HWHPH2
27444 C-----------------------------------------------------------------------
27445 C     QQD direct photon pair production: mean EVWGT = sigma in nb
27446 C-----------------------------------------------------------------------
27447       INCLUDE 'HERWIG65.INC'
27448       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
27449      & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,RS,S,T,U,CSTU,TQSQ,
27450      & DSTU,HCS
27451       INTEGER ID,ID1,ID2
27452       EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
27453       SAVE HCS,CSTU,DSTU,FACT
27454       PARAMETER (EPS=1.D-9)
27455       IF (GENEV) THEN
27456         RCS=HCS*HWRGEN(0)
27457       ELSE
27458         EVWGT=0.
27459         CALL HWRPOW(ET,EJ)
27460         KK=ET/PHEP(5,3)
27461         KK2=KK**2
27462         IF (KK.GE.ONE) RETURN
27463         YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
27464         YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
27465         IF (YJ1INF.GE.YJ1SUP) RETURN
27466         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
27467         YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
27468         YJ2SUP=MIN( YJMAX ,  LOG(2./KK-Z1) )
27469         IF (YJ2INF.GE.YJ2SUP) RETURN
27470         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
27471         XX(1)=0.5*(Z1+Z2)*KK
27472         IF (XX(1).GE.ONE) RETURN
27473         XX(2)=XX(1)/(Z1*Z2)
27474         IF (XX(2).GE.ONE) RETURN
27475         COSTH=(Z1-Z2)/(Z1+Z2)
27476         S=XX(1)*XX(2)*PHEP(5,3)**2
27477         RS=0.5*SQRT(S)
27478         T=-0.5*S*(1.-COSTH)
27479         U=-S-T
27480         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
27481         FACT=GEV2NB*PIFAC*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
27482      &      *(ALPHEM/S)**2
27483         CALL HWSGEN(.FALSE.)
27484         CSTU=2.*(U/T+T/U)/CAFAC
27485         IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
27486            TQSQ=0.
27487            DO 10 ID=1,6
27488   10       IF (RMASS(ID).LT.RS) TQSQ=TQSQ+QFCH(ID)**2
27489            DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
27490      &         /64.*(HWUALF(1,EMSCA)*TQSQ/PIFAC)**2
27491         ELSE
27492            DSTU=0
27493         ENDIF
27494       ENDIF
27495       HCS=0.
27496       DO 30 ID=1,6
27497       FACTR=FACT*CSTU*QFCH(ID)**4
27498 C q+qbar ---> gamma+gamma
27499       ID1=ID
27500       ID2=ID+6
27501       IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 20
27502       HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
27503       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,61,*99)
27504 C qbar+q ---> gamma+gamma
27505   20  ID1=ID+6
27506       ID2=ID
27507       IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
27508       HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
27509       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,62,*99)
27510   30  CONTINUE
27511 C g+g ---> gamma+gamma
27512       ID1=13
27513       ID2=13
27514       HCS=HCS+DSTU
27515       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,63,*99)
27516       EVWGT=HCS
27517       RETURN
27518 C Generate event
27519   99  IDN(1)=ID1
27520       IDN(2)=ID2
27521       IDCMF=15
27522       CALL HWETWO(.TRUE.,.TRUE.)
27523   999 END
27524 CDECK  ID>, HWHPHO.
27525 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
27526 *-- Author :    Bryan Webber
27527 C-----------------------------------------------------------------------
27528       SUBROUTINE HWHPHO
27529 C-----------------------------------------------------------------------
27530 C     QCD DIRECT PHOTON + JET PRODUCTION: MEAN EVWGT = SIGMA IN NB
27531 C-----------------------------------------------------------------------
27532       INCLUDE 'HERWIG65.INC'
27533       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
27534      & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,FACTF,RS,S,T,U,CF,
27535      & AF,CSTU,CTSU,CUST,DSTU,HCS,TQCH
27536       INTEGER ID,ID1,ID2
27537       EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
27538       SAVE HCS
27539       PARAMETER (EPS=1.D-9)
27540       IF (GENEV) THEN
27541         RCS=HCS*HWRGEN(0)
27542       ELSE
27543         EVWGT=0.
27544         CALL HWRPOW(ET,EJ)
27545         KK=ET/PHEP(5,3)
27546         KK2=KK**2
27547         IF (KK.GE.ONE) RETURN
27548         YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
27549         YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
27550         IF (YJ1INF.GE.YJ1SUP) RETURN
27551         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
27552         YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
27553         YJ2SUP=MIN( YJMAX ,  LOG(2./KK-Z1) )
27554         IF (YJ2INF.GE.YJ2SUP) RETURN
27555         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
27556         XX(1)=0.5*(Z1+Z2)*KK
27557         IF (XX(1).GE.ONE) RETURN
27558         XX(2)=XX(1)/(Z1*Z2)
27559         IF (XX(2).GE.ONE) RETURN
27560         COSTH=(Z1-Z2)/(Z1+Z2)
27561         S=XX(1)*XX(2)*PHEP(5,3)**2
27562         RS=0.5*SQRT(S)
27563         T=-0.5*S*(1.-COSTH)
27564         U=-S-T
27565 C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
27566         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
27567         FACT=GEV2NB*PIFAC*0.5*ET*EJ*ALPHEM
27568      &      *HWUALF(1,EMSCA)*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)/S**2
27569         CALL HWSGEN(.FALSE.)
27570 C
27571         CF=2.*CFFAC/CAFAC
27572         AF=-1./CAFAC
27573         CSTU=CF*(U/T+T/U)
27574         CTSU=AF*(U/S+S/U)
27575         CUST=AF*(T/S+S/T)
27576         IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
27577            TQCH=0.
27578            DO 10 ID=1,6
27579   10       IF (RMASS(ID).LT.RS) TQCH=TQCH+QFCH(ID)
27580            DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
27581      &         *5./768.*(HWUALF(1,EMSCA)*TQCH/PIFAC)**2
27582         ELSE
27583            DSTU=0
27584         ENDIF
27585       ENDIF
27586 C
27587       HCS=0.
27588       DO 30 ID=1,6
27589       FACTR=FACT*QFCH(ID)**2
27590 C---QUARK FIRST
27591       ID1=ID
27592       IF (DISF(ID1,1).LT.EPS) GOTO 20
27593       ID2=ID1+6
27594       HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
27595       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,2314,41,*9)
27596       ID2=13
27597       HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
27598       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1, 59,3124,42,*9)
27599 C---QBAR FIRST
27600   20  ID1=ID+6
27601       IF (DISF(ID1,1).LT.EPS) GOTO 30
27602       ID2=ID
27603       HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
27604       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,3124,43,*9)
27605       ID2=13
27606       HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
27607       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1, 59,2314,44,*9)
27608   30  CONTINUE
27609 C---GLUON FIRST
27610       ID1=13
27611       FACTF=FACT*CUST*DISF(ID1,1)
27612       DO 50 ID=1,6
27613       FACTR=FACTF*QFCH(ID)**2
27614       ID2=ID
27615       IF (DISF(ID2,2).LT.EPS) GOTO 40
27616       HCS=HCS+FACTR*DISF(ID2,2)
27617       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2, 59,2314,45,*9)
27618   40  ID2=ID+6
27619       IF (DISF(ID2,2).LT.EPS) GOTO 50
27620       HCS=HCS+FACTR*DISF(ID2,2)
27621       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2, 59,3124,46,*9)
27622   50  CONTINUE
27623 C g+g ---> g+gamma
27624       ID2=13
27625       HCS=HCS+DSTU
27626       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,2314,47,*9)
27627       EVWGT=HCS
27628       RETURN
27629 C---GENERATE EVENT
27630     9 IDN(1)=ID1
27631       IDN(2)=ID2
27632       IDCMF=15
27633       CALL HWETWO(.TRUE.,.TRUE.)
27634   999 END
27635 CDECK  ID>, HWHPPB.
27636 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
27637 *-- Author :    Ian Knowles
27638 C-----------------------------------------------------------------------
27639       FUNCTION HWHPPB(S,T,U)
27640 C-----------------------------------------------------------------------
27641 C     Quark box diagram contribution to photon/gluon scattering
27642 C     Internal quark mass neglected: m_q << U,T,S
27643 C-----------------------------------------------------------------------
27644       IMPLICIT NONE
27645       DOUBLE PRECISION HWHPPB,S,T,U,S2,T2,U2,PI2,ALNTU,ALNST,ALNSU
27646       PI2=ACOS(-1.D0)**2
27647       S2=S**2
27648       T2=T**2
27649       U2=U**2
27650       ALNTU=LOG(T/U)
27651       ALNST=LOG(-S/T)
27652       ALNSU=ALNST+ALNTU
27653       HWHPPB=5.*4.
27654      & +((2.*S2+2.*(U2-T2)*ALNTU+(T2+U2)*(ALNTU**2+PI2))/S2)**2
27655      & +((2.*U2+2.*(T2-S2)*ALNST+(T2+S2)* ALNST**2     )/U2)**2
27656      & +((2.*T2+2.*(U2-S2)*ALNSU+(U2+S2)* ALNSU**2     )/T2)**2
27657      & +4.*PI2*(((T2-S2+(T2+S2)*ALNST)/U2)**2
27658      &         +((U2-S2+(U2+S2)*ALNSU)/T2)**2)
27659       END
27660 CDECK  ID>, HWHPPE.
27661 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
27662 *-- Author :    Ian Knowles
27663 C-----------------------------------------------------------------------
27664       SUBROUTINE HWHPPE
27665 C-----------------------------------------------------------------------
27666 C     point-like photon/QCD heavy flavour single excitation, using exact
27667 C     massive lightcone kinematics, mean EVWGT = sigma in nb.
27668 C-----------------------------------------------------------------------
27669       INCLUDE 'HERWIG65.INC'
27670       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,
27671      & PT,PJ,PT2,PTM,EXY,T,CC,EXY2,S,U,C,SIGE,HCS,RCS
27672       INTEGER IQ1,IQ2,ID1,ID2,IHAD1,IHAD2
27673       EXTERNAL HWRGEN,HWRUNI,HWUALF
27674       SAVE PP1,PP2,IQ1,IQ2,QM2,FACTR,SIGE,HCS
27675       PARAMETER (EPS=1.E-9)
27676       IHAD1=1
27677       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
27678       IHAD2=2
27679       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
27680       IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
27681          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
27682          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
27683          XX(1)=1.
27684          IQ1=MOD(IPROC,100)
27685          IQ2=IQ1+6
27686          QM2=RMASS(IQ1)**2
27687          FACTR=GEV2NB*(YJMAX-YJMIN)*4.*PIFAC*CFFAC*PP1
27688      &        *ALPHEM*QFCH(IQ1)**2
27689       ENDIF
27690       IF (GENEV) THEN
27691          RCS=HCS*HWRGEN(0)
27692       ELSE
27693          EVWGT=0.
27694          CALL HWRPOW(PT,PJ)
27695          PT2=PT**2
27696          PTM=SQRT(PT2+QM2)
27697          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
27698          T=-PP1*PT/EXY
27699          CC=T**2-4.*QM2*(PT2+T)
27700          IF (CC.LT.ZERO) RETURN
27701          EXY2=(2.*PT2+T-SQRT(CC))*PP1/(2.*T*PTM)
27702          IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
27703          XX(2)=(PT/EXY+PTM/EXY2)/PP2
27704          IF (XX(2).GT.ONE) RETURN
27705 C define: S=Shat-M**2, T=That ,U=Uhat-M**2 (2p.Q, -2p.g, -2p.Q')
27706          S=XX(2)*PP1*PP2
27707          U=-S-T
27708          COSTH=(1.+QM2/S)*(T-U)/S-QM2/S
27709 C Set hard process scale (Approx ET-jet)
27710          EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
27711          C=QM2*T/(U*S)
27712          SIGE=-FACTR*PT*PJ*HWUALF(1,EMSCA)*(S/U+U/S+4.*C*(1.-C))
27713      &       /(S**2*EXY2*PTM*(1-QM2/(XX(2)*PP2*EXY2)**2))
27714          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
27715       ENDIF
27716       HCS=0.
27717       ID1=59
27718 C photon+Q ---> g+Q
27719       ID2=IQ1
27720       IF (DISF(ID2,2).LT.EPS) GOTO 10
27721       HCS=HCS+SIGE*DISF(ID2,2)
27722       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13,ID2,1423,51,*99)
27723 C photon+Qbar ---> g+Qbar
27724   10  ID2=IQ2
27725       IF (DISF(ID2,2).LT.EPS) GOTO 20
27726       HCS=HCS+SIGE*DISF(ID2,2)
27727       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13,ID2,1342,52,*99)
27728   20  EVWGT=HCS
27729       RETURN
27730 C Generate event
27731   99  IDN(1)=ID1
27732       IDN(2)=ID2
27733       IDCMF=15
27734       CALL HWETWO(.TRUE.,.TRUE.)
27735   999 END
27736 CDECK  ID>, HWHPPH.
27737 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
27738 *-- Author :    Ian Knowles
27739 C-----------------------------------------------------------------------
27740       SUBROUTINE HWHPPH
27741 C-----------------------------------------------------------------------
27742 C     Point-like photon/gluon heavy flavour pair production, with
27743 C     exact lightcone massive kinematics, mean EVWGT = sigma in nb.
27744 C-----------------------------------------------------------------------
27745       INCLUDE 'HERWIG65.INC'
27746       DOUBLE PRECISION HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,ET,EJ,ET2,
27747      & EXY,EXY2,S,T,U,C
27748       INTEGER IQ1,IHAD1,IHAD2
27749       EXTERNAL HWRUNI,HWUALF
27750       SAVE PP1,PP2,IQ1,QM2,FACTR
27751       PARAMETER (EPS=1.E-9)
27752       IHAD1=1
27753       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
27754       IHAD2=2
27755       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
27756       IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
27757          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
27758          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
27759          XX(1)=1.
27760          IQ1=MOD(IPROC,100)
27761          QM2=RMASS(IQ1)**2
27762          IHPRO=53
27763          FACTR=-GEV2NB*(YJMAX-YJMIN)*.5*PIFAC*ALPHEM*QFCH(IQ1)**2
27764       ENDIF
27765       IF (GENEV) THEN
27766 C Generate event
27767          IDN(1)=59
27768          IDN(2)=13
27769          IDN(3)=IQ1
27770          IDN(4)=IQ1+6
27771          ICO(1)=1
27772          ICO(2)=4
27773          ICO(3)=2
27774          ICO(4)=3
27775          IDCMF=15
27776          CALL HWETWO(.TRUE.,.TRUE.)
27777       ELSE
27778 C Select kinematics
27779          EVWGT=0.
27780          CALL HWRPOW(ET,EJ)
27781          ET2=ET**2
27782          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
27783          EXY2=2.*PP1/ET-EXY
27784          IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
27785          XX(2)=.5*ET*(1./EXY+1./EXY2)/PP2
27786          IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
27787          S=XX(2)*PP1*PP2
27788          IF (S.LT.ET2) RETURN
27789 C define: S=Shat, T=That-M**2, U=Uhat-M**2 (2p.g, -2p.Q, -2p.QBar)
27790          T=-.5*PP1*ET/EXY
27791          U=-S-T
27792          COSTH=(T-U)/(S*SQRT(1.-4.*QM2/S))
27793          EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
27794          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
27795 C photon+g ---> Q+Qbar
27796          IF (DISF(13,2).LT.EPS) THEN
27797             EVWGT=0.
27798          ELSE
27799             C=QM2*S/(U*T)
27800             EVWGT=FACTR*EJ*ET*HWUALF(1,EMSCA)
27801      &           *DISF(13,2)*(T/U+U/T+4.*C*(1.-C))/(S*T)
27802          ENDIF
27803       ENDIF
27804   999 END
27805 CDECK  ID>, HWHPPM.
27806 *CMZ :-        -09/12/93  15.50.26  by  Mike Seymour
27807 *-- Author :    Ian Knowles & Mike Seymour
27808 C-----------------------------------------------------------------------
27809       SUBROUTINE HWHPPM
27810 C-----------------------------------------------------------------------
27811 C     Point-like photon/QCD direct meson production
27812 C     See M. Benayoun, et al., Nucl. Phys. B282 (1987) 653 for details.
27813 C     mean EVWGT = sigma in nb
27814 C-----------------------------------------------------------------------
27815       INCLUDE 'HERWIG65.INC'
27816       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,ET,EJ,EXY,EXY2,
27817      & FACT,FACTR,S,T,U,REDS,DELT(3,3),C1STU,C3STU,HCS,RCS,CMIX,SMIX,
27818      & C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1,FPI2,FETA2(3),FETAP2(3),
27819      7 FRHO2,FPHI2(3),FOMEG2(3)
27820       INTEGER MNAME(3,3,2),N4(3),I,J,ID2,ID4,I2,I4,M1,M2,IHAD1,IHAD2
27821       LOGICAL SPIN0,SPIN1
27822       EXTERNAL HWRGEN,HWRUNI,HWUALF
27823       SAVE FPI2,FETA2,FETAP2,FRHO2,FPHI2,FOMEG2,HCS,REDS,FACT,DELT,
27824      & C1STU,C3STU
27825       PARAMETER (EPS=1.D-20)
27826       DATA MNAME/21,38,42,30,21,34,50,46,0,23,39,43,31,23,35,51,47,0/
27827       DATA N4,SPIN0,SPIN1/3,3,2,.TRUE.,.TRUE./
27828       DATA C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1
27829      &     /1.D0,3*0.093D0,3*0.107D0/
27830       IF (FSTWGT) THEN
27831          FPI2=FPI**2
27832          CMIX=COS(ETAMIX*PIFAC/180.D0)
27833          SMIX=SIN(ETAMIX*PIFAC/180.D0)
27834          FETA2(1) =(+CMIX*FETA8/SQRT(TWO)-SMIX*FETA1)**2/THREE
27835          FETA2(2) =FETA2(1)
27836          FETA2(3) =(-CMIX*FETA8*SQRT(TWO)-SMIX*FETA1)**2/THREE
27837          FETAP2(1)=(+SMIX*FETA8/SQRT(TWO)+CMIX*FETA1)**2/THREE
27838          FETAP2(2)=FETAP2(1)
27839          FETAP2(3)=(-SMIX*FETA8*SQRT(TWO)+CMIX*FETA1)**2/THREE
27840          FRHO2=FRHO**2
27841          CMIX=COS(PHIMIX*PIFAC/180.D0)
27842          SMIX=SIN(PHIMIX*PIFAC/180.D0)
27843          FPHI2(1) =(+CMIX*FPHI8/SQRT(TWO)-SMIX*FPHI1)**2/THREE
27844          FPHI2(2) =FPHI2(1)
27845          FPHI2(3) =(-CMIX*FPHI8*SQRT(TWO)-SMIX*FPHI1)**2/THREE
27846          FOMEG2(1)=(+SMIX*FPHI8/SQRT(TWO)+CMIX*FPHI1)**2/THREE
27847          FOMEG2(2)=FOMEG2(1)
27848          FOMEG2(3)=(-SMIX*FPHI8*SQRT(TWO)+CMIX*FPHI1)**2/THREE
27849       ENDIF
27850       SPIN0=.NOT.(MOD(IPROC/10,10).EQ.2)
27851       SPIN1=.NOT.(MOD(IPROC/10,10).EQ.1)
27852       IF (GENEV) THEN
27853          RCS=HCS*HWRGEN(0)
27854       ELSE
27855          EVWGT=ZERO
27856          IHAD1=1
27857          IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
27858          IHAD2=2
27859          IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
27860          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
27861          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
27862          XX(1)=ONE
27863          CALL HWRPOW(ET,EJ)
27864          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
27865          EXY2=TWO*PP1/ET-EXY
27866          IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
27867          XX(2)=PP1/(PP2*EXY*EXY2)
27868          IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
27869          S=XX(2)*PP1*PP2
27870          REDS=SQRT(S-ET*SQRT(S))
27871          T=-HALF*PP1*ET/EXY
27872          U=-S-T
27873          COSTH=(T-U)/S
27874 C Set EMSCA to hard process scale (Approx ET-jet)
27875          EMSCA=SQRT(TWO*S*T*U/(S*S+T*T+U*U))
27876          FACT=-GEV2NB*ET*EJ*(YJMAX-YJMIN)*ALPHEM*CFFAC
27877      &       *(HWUALF(1,EMSCA)*PIFAC*C1WVFN)**2*32.D0/(THREE*S*T)
27878          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
27879          DO 10 I=1,3
27880          DO 10 J=1,3
27881  10      DELT(I,J)=(QFCH(I)*U+QFCH(J)*S)**2
27882          C1STU=-(S**2+U**2)/(T*S**2*U**2)
27883          C3STU=-8.D0*T/(S**2*U**2)
27884       ENDIF
27885       HCS=ZERO
27886       DO 50 I2=1,3
27887 C Quark initiated processes
27888       ID2=I2
27889       IF (DISF(ID2,2).LT.EPS) GOTO 30
27890       DO 20 ID4=1,N4(I2)
27891       M1=MNAME(ID2,ID4,1)
27892       FACTR=FACT*DELT(ID2,ID4)*DISF(ID2,2)
27893       IF (ID2.EQ.ID4) FACTR=HALF*FACTR
27894       IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
27895 C  photon+q --> meson_0+q'
27896          HCS=HCS+HALF*FACTR*C1STU*FPI2
27897          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M1,ID4,1432,71,*99)
27898       ENDIF
27899       M2=MNAME(ID2,ID4,2)
27900       IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
27901 C  photon+q --> meson_L+q'
27902          HCS=HCS+FACTR*C1STU*FRHO2
27903          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,72,*99)
27904 C  photon+q --> meson_T+q'
27905          HCS=HCS+FACTR*C3STU*FRHO2
27906          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,73,*99)
27907       ENDIF
27908   20  CONTINUE
27909       FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
27910       IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
27911 C  photon+q -->eta+q
27912          HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
27913          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(22,ID2,1432,71,*99)
27914       ENDIF
27915       IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
27916 C  photon+q -->eta'+q
27917          HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
27918          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(25,ID2,1432,71,*99)
27919       ENDIF
27920       IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
27921 C  photon+q -->phi_L+q
27922          HCS=HCS+FACTR*C1STU*FPHI2(I2)
27923          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,72,*99)
27924 C  photon+q -->phi_T+q
27925          HCS=HCS+FACTR*C3STU*FPHI2(I2)
27926          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,73,*99)
27927       ENDIF
27928       IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
27929 C  photon+q -->omega_L+q
27930          HCS=HCS+FACTR*C1STU*FOMEG2(I2)
27931          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,72,*99)
27932 C  photon+q -->omega_T+q
27933          HCS=HCS+FACTR*C3STU*FOMEG2(I2)
27934          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,73,*99)
27935       ENDIF
27936 C Anti-quark initiated processes
27937   30  ID2=I2+6
27938       IF (DISF(ID2,2).LT.EPS) GOTO 50
27939       DO 40 I4=1,N4(I2)
27940       ID4=I4+6
27941       FACTR=FACT*DELT(I2,I4)*DISF(ID2,2)
27942       IF (ID2.EQ.ID4) FACTR=HALF*FACTR
27943       M1=MNAME(I4,I2,1)
27944       IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
27945 C  photon+qbar --> meson_0+qbar'
27946          HCS=HCS+HALF*FACTR*C1STU*FPI2
27947          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M1,ID4,1432,74,*99)
27948       ENDIF
27949       M2=MNAME(I4,I2,2)
27950       IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
27951 C  photon+qbar --> meson_L+qbar'
27952          HCS=HCS+FACTR*C1STU*FRHO2
27953          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,75,*99)
27954 C  photon+qbar --> meson_T+qbar'
27955          HCS=HCS+FACTR*C3STU*FRHO2
27956          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,76,*99)
27957       ENDIF
27958   40  CONTINUE
27959       FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
27960       IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
27961 C  photon+qbar -->eta+qbar
27962          HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
27963          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(22,ID2,1432,74,*99)
27964       ENDIF
27965       IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
27966 C  photon+qbar -->eta'+qbar
27967          HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
27968          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(25,ID2,1432,74,*99)
27969       ENDIF
27970       IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
27971 C  photon+qbar -->phi_L+qbar
27972          HCS=HCS+FACTR*C1STU*FPHI2(I2)
27973          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,75,*99)
27974 C  photon+qbar -->phi_T+qbar
27975          HCS=HCS+FACTR*C3STU*FPHI2(I2)
27976          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,76,*99)
27977       ENDIF
27978       IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
27979 C  photon+qbar -->omega_L+qbar
27980          HCS=HCS+FACTR*C1STU*FOMEG2(I2)
27981          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,75,*99)
27982 C  photon+qbar -->omega_T+qbar
27983          HCS=HCS+FACTR*C3STU*FOMEG2(I2)
27984          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,76,*99)
27985       ENDIF
27986   50  CONTINUE
27987       EVWGT=HCS
27988       RETURN
27989 C Generate event
27990   99  IDN(1)=59
27991       IDN(2)=ID2
27992       IDCMF=15
27993       CALL HWETWO(.TRUE.,.TRUE.)
27994 C Set polarization vector
27995       IF (IHPRO.EQ.72.OR.IHPRO.EQ.75) THEN
27996         RHOHEP(2,NHEP-1)=ONE
27997       ELSEIF (IHPRO.EQ.73.OR.IHPRO.EQ.76) THEN
27998         RHOHEP(1,NHEP-1)=HALF
27999         RHOHEP(3,NHEP-1)=HALF
28000       ENDIF
28001   999 END
28002 CDECK  ID>, HWHPPT.
28003 *CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
28004 *-- Author :    Ian Knowles
28005 C-----------------------------------------------------------------------
28006       SUBROUTINE HWHPPT
28007 C-----------------------------------------------------------------------
28008 C     point-like photon/QCD di-jet production: mean EVWGT = sigma in nb
28009 C-----------------------------------------------------------------------
28010       INCLUDE 'HERWIG65.INC'
28011       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,PP1,PP2,ET,EJ,
28012      & EXY,EXY2,FACTR,RS,S,T,U,CSTU,CTSU,HCS
28013       INTEGER ID1,ID2,ID3,ID4,IHAD1,IHAD2
28014       EXTERNAL HWRGEN,HWRUNI,HWUALF
28015       SAVE CSTU,CTSU,HCS,FACTR,RS
28016       PARAMETER (EPS=1.E-9)
28017       IHAD1=1
28018       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28019       IHAD2=2
28020       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28021       IF (GENEV) THEN
28022          RCS=HCS*HWRGEN(0)
28023       ELSE
28024          EVWGT=0.
28025          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28026          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28027          XX(1)=1.
28028          CALL HWRPOW(ET,EJ)
28029          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28030          EXY2=2.*PP1/ET-EXY
28031          IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28032          XX(2)=PP1/(PP2*EXY*EXY2)
28033          IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28034          S=XX(2)*PP1*PP2
28035          RS=.5*SQRT(S)
28036          T=-PP1*0.5*ET/EXY
28037          U=-S-T
28038          COSTH=(T-U)/S
28039 C Set EMSCA to hard process scale (Approx ET-jet)
28040          EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28041          FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM
28042      &        *HWUALF(1,EMSCA)/(S*T)
28043          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28044          CSTU=U/T+T/U
28045          CTSU=-2.*CFFAC*(U/S+S/U)
28046       ENDIF
28047       HCS=0.
28048       ID1=59
28049       DO 20 ID2=1,13
28050       IF (DISF(ID2,2).LT.EPS) GOTO 20
28051       IF (ID2.LT.7) THEN
28052 C photon+q ---> g+q
28053          HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**2
28054          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13,ID2,1423,51,*99)
28055       ELSEIF (ID2.LT.13) THEN
28056 C photon+qbar ---> g+qbar
28057          HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**2
28058          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13,ID2,1342,52,*99)
28059       ELSE
28060 C photon+g ---> q+qbar
28061          DO 10 ID3=1,6
28062          IF (RS.GT.RMASS(ID3)) THEN
28063             ID4=ID3+6
28064             HCS=HCS+CSTU*DISF(ID2,2)*QFCH(ID3)**2
28065             IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,1423,53,*99)
28066          ENDIF
28067   10     CONTINUE
28068       ENDIF
28069   20  CONTINUE
28070       EVWGT=FACTR*HCS
28071       RETURN
28072 C Generate event
28073   99  IDN(1)=ID1
28074       IDN(2)=ID2
28075       IDCMF=15
28076       CALL HWETWO(.TRUE.,.TRUE.)
28077   999 END
28078 CDECK  ID>, HWHPQS.
28079 *CMZ :-        -27/03/95  13.27.22  by  Mike Seymour
28080 *-- Author :    Ian Knowles
28081 C-----------------------------------------------------------------------
28082       SUBROUTINE HWHPQS
28083 C-----------------------------------------------------------------------
28084 C     Compton scattering of point-like photon and (anti)quark
28085 C     mean EVWGT = sigma in nb
28086 C-----------------------------------------------------------------------
28087       INCLUDE 'HERWIG65.INC'
28088       DOUBLE PRECISION HWRGEN,HWRUNI,EPS,RCS,PP1,PP2,ET,EJ,EXY,EXY2,
28089      & FACTR,S,T,U,CTSU,HCS
28090       INTEGER ID1,ID2,IHAD1,IHAD2
28091       EXTERNAL HWRGEN,HWRUNI
28092       SAVE CTSU,HCS,FACTR
28093       PARAMETER (EPS=1.E-9)
28094       IHAD1=1
28095       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28096       IHAD2=2
28097       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28098       IF (GENEV) THEN
28099          RCS=HCS*HWRGEN(0)
28100       ELSE
28101          EVWGT=0.
28102          PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28103          PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28104          XX(1)=1.
28105          CALL HWRPOW(ET,EJ)
28106          EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28107          EXY2=2.*PP1/ET-EXY
28108          IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28109          XX(2)=PP1/(PP2*EXY*EXY2)
28110          IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28111          S=XX(2)*PP1*PP2
28112          T=-PP1*0.5*ET/EXY
28113          U=-S-T
28114          COSTH=(T-U)/S
28115 C Set EMSCA to hard process scale (Approx ET-jet)
28116          EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28117          FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM**2/(S*T)
28118          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28119          CTSU=-2.*(U/S+S/U)
28120       ENDIF
28121       HCS=0.
28122       ID1=59
28123       DO 20 ID2=1,12
28124       IF (DISF(ID2,2).LT.EPS) GOTO 20
28125       IF (ID2.LT.7) THEN
28126 C photon+q ---> photon+q
28127          HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**4
28128          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 59,ID2,1432,66,*99)
28129       ELSE
28130 C photon+qbar ---> photon+qbar
28131          HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**4
28132          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 59,ID2,1432,67,*99)
28133       ENDIF
28134   20  CONTINUE
28135       EVWGT=FACTR*HCS
28136       RETURN
28137 C Generate event
28138   99  IDN(1)=ID1
28139       IDN(2)=ID2
28140       IDCMF=15
28141       CALL HWETWO(.TRUE.,.TRUE.)
28142   999 END
28143 CDECK  ID>, HWHQCD.
28144 *CMZ :-        -20/05/99  12.39.45  by  Kosuke Odagiri
28145 *-- Author :    Bryan Webber
28146 C-----------------------------------------------------------------------
28147       SUBROUTINE HWHQCD
28148 C-----------------------------------------------------------------------
28149 C     QCD HARD 2->2 PROCESSES: MEAN EVWGT = SIGMA IN NB
28150 C-----------------------------------------------------------------------
28151       INCLUDE 'HERWIG65.INC'
28152       DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,RS,EPS,HF,RCS,Z1,Z2,ET,EJ,
28153      & FACTR,S,T,U,ST,TU,US,STU,TUS,UST,EN,RN,GFLA,AF,ASTU,ASUT,AUST,
28154      & BF,BSTU,BSUT,BUST,BUTS,CF,CSTU,CSUT,CTSU,CTUS,DF,DSTU,DTSU,DUTS,
28155      & DIST,HCS,UT,SU,GT,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
28156       INTEGER ID1,ID2,I
28157       EXTERNAL HWRGEN,HWRUNI,HWUALF
28158       SAVE HCS,ASTU,AUST,BSTU,BSUT,BUST,BUTS,CSTU,CSUT,CTSU,CTUS,
28159      & DSTU,DTSU,DUTS,GFLA,RCS,S,T,TU,U,US
28160       PARAMETER (EPS=1.E-9,HF=0.5)
28161       IF (GENEV) THEN
28162         RCS=HCS*HWRGEN(0)
28163       ELSE
28164         EVWGT=0.
28165         CALL HWRPOW(ET,EJ)
28166         KK = ET/PHEP(5,3)
28167         KK2=KK**2
28168         IF (KK.GE.ONE) RETURN
28169         YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
28170         YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
28171         IF (YJ1INF.GE.YJ1SUP) RETURN
28172         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
28173         YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
28174         YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
28175         IF (YJ2INF.GE.YJ2SUP) RETURN
28176         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
28177         XX(1)=.5*(Z1+Z2)*KK
28178         IF (XX(1).GE.ONE) RETURN
28179         XX(2)=XX(1)/(Z1*Z2)
28180         IF (XX(2).GE.ONE) RETURN
28181         COSTH=(Z1-Z2)/(Z1+Z2)
28182         S=XX(1)*XX(2)*PHEP(5,3)**2
28183         RS=HF*SQRT(S)
28184         DO 3 I=1,NFLAV
28185         IF (RS.LT.RMASS(I)) GOTO 4
28186     3   CONTINUE
28187         I=NFLAV+1
28188     4   MAXFL=I-1
28189         IF (MAXFL.EQ.0) CALL HWWARN('HWHQCD',100,*999)
28190 C
28191         T=-HF*S*(1.-COSTH)
28192         U=-S-T
28193 C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
28194         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28195         FACTR = GEV2NB*.5*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
28196      &        * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
28197         CALL HWSGEN(.FALSE.)
28198 C
28199         ST=S/T
28200         TU=T/U
28201         US=U/S
28202         STU=TU/US
28203         TUS=US/ST
28204         UST=ST/TU
28205 C
28206         EN=CAFAC
28207         RN=CFFAC/EN
28208         GFLA=HF*FLOAT(MAXFL)/(EN*RN)**2
28209         AF=FACTR*RN
28210         ASTU=AF*(1.-2.*UST)
28211         ASUT=AF*(1.-2.*STU)
28212         AUST=AF*(1.-2.*TUS)
28213 C-----------------------------------------------------------------------
28214 C---Colour decomposition modifications below (KO)
28215 C-----------------------------------------------------------------------
28216         BF=HF-AF/EN/TUS/(ASTU+ASUT)
28217         BSTU=BF*ASTU
28218         BSUT=BF*ASUT
28219         BF=ONE-TWO*AF/EN/STU/(AUST+ASTU)
28220         BUST=BF*AUST
28221         BUTS=BF*ASTU
28222 C-----------------------------------------------------------------------
28223 C       BF=2.*AF/EN
28224 C       BSTU=HF*(ASTU+BF*ST)
28225 C       BSUT=HF*(ASUT+BF/US)
28226 C       BUST=AUST+BF*US
28227 C       BUTS=ASTU+BF/TU
28228 C-----------------------------------------------------------------------
28229         CF=AF*EN
28230         CSTU=(CF*(RN-TUS))/TU
28231         CSUT=(CF*(RN-TUS))*TU
28232         CTSU=(FACTR*(UST-RN))*US
28233         CTUS=(FACTR*(UST-RN))/US
28234         DF=HF*FACTR/RN
28235         DSTU=DF*(1.+1./TUS-STU-UST)
28236         DTSU=DF*(1.+1./UST-STU-TUS)
28237         DUTS=DF*(1.+1./STU-UST-TUS)
28238       ENDIF
28239 C
28240       HCS=0.
28241       DO 6 ID1=1,13
28242       IF (DISF(ID1,1).LT.EPS) GOTO 6
28243       DO 5 ID2=1,13
28244       IF (DISF(ID2,2).LT.EPS) GOTO 5
28245       DIST=DISF(ID1,1)*DISF(ID2,2)
28246       IF (ID1.LT.7) THEN
28247 C---QUARK FIRST
28248        IF (ID2.LT.7) THEN
28249         IF (ID1.NE.ID2) THEN
28250          HCS=HCS+ASTU*DIST
28251          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9)
28252         ELSE
28253          HCS=HCS+BSTU*DIST
28254          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 1,*9)
28255          HCS=HCS+BSUT*DIST
28256          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312, 2,*9)
28257         ENDIF
28258        ELSEIF (ID2.NE.13) THEN
28259         IF (ID2.NE.ID1+6) THEN
28260          HCS=HCS+ASTU*DIST
28261          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9)
28262         ELSE
28263          HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
28264          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(-ID1, 0,2413, 4,*9)
28265          HCS=HCS+BUTS*DIST
28266          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 5,*9)
28267          HCS=HCS+BUST*DIST
28268          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413, 6,*9)
28269          HCS=HCS+CSTU*DIST
28270          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,2413, 7,*9)
28271          HCS=HCS+CSUT*DIST
28272          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,2341, 8,*9)
28273         ENDIF
28274        ELSE
28275          HCS=HCS+CTSU*DIST
28276          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9)
28277          HCS=HCS+CTUS*DIST
28278          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9)
28279        ENDIF
28280       ELSEIF (ID1.NE.13) THEN
28281 C---QBAR FIRST
28282        IF (ID2.LT.7) THEN
28283         IF (ID1.NE.ID2+6) THEN
28284          HCS=HCS+ASTU*DIST
28285          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9)
28286         ELSE
28287          HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
28288          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(-ID1, 0,3142,12,*9)
28289          HCS=HCS+BUTS*DIST
28290          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,13,*9)
28291          HCS=HCS+BUST*DIST
28292          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,14,*9)
28293          HCS=HCS+CSTU*DIST
28294          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,3142,15,*9)
28295          HCS=HCS+CSUT*DIST
28296          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,4123,16,*9)
28297         ENDIF
28298        ELSEIF (ID2.NE.13) THEN
28299         IF (ID1.NE.ID2) THEN
28300          HCS=HCS+ASTU*DIST
28301          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9)
28302         ELSE
28303          HCS=HCS+BSTU*DIST
28304          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,18,*9)
28305          HCS=HCS+BSUT*DIST
28306          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,19,*9)
28307         ENDIF
28308        ELSE
28309          HCS=HCS+CTSU*DIST
28310          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9)
28311          HCS=HCS+CTUS*DIST
28312          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9)
28313        ENDIF
28314       ELSE
28315 C---GLUON FIRST
28316        IF (ID2.LT.7) THEN
28317          HCS=HCS+CTSU*DIST
28318          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9)
28319          HCS=HCS+CTUS*DIST
28320          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9)
28321        ELSEIF (ID2.LT.13) THEN
28322          HCS=HCS+CTSU*DIST
28323          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9)
28324          HCS=HCS+CTUS*DIST
28325          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9)
28326        ELSE
28327          HCS=HCS+GFLA*CSTU*DIST
28328          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(  0,  0,2413,27,*9)
28329          HCS=HCS+GFLA*CSUT*DIST
28330          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(  0,  0,4123,28,*9)
28331          HCS=HCS+DTSU*DIST
28332          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2341,29,*9)
28333          HCS=HCS+DSTU*DIST
28334          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,30,*9)
28335          HCS=HCS+DUTS*DIST
28336          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,31,*9)
28337        ENDIF
28338       ENDIF
28339     5 CONTINUE
28340     6 CONTINUE
28341       EVWGT=HCS
28342       RETURN
28343 C---GENERATE EVENT
28344     9 IDN(1)=ID1
28345       IDN(2)=ID2
28346       IDCMF=15
28347       CALL HWETWO(.TRUE.,.TRUE.)
28348       IF (AZSPIN) THEN
28349 C Calculate coefficients for constructing spin density matrices
28350          IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
28351      &       IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
28352 C qqbar-->gg or qbarq-->gg
28353             UT=1./TU
28354             GCOEF(1)=UT+TU
28355             GCOEF(2)=-2.
28356             GCOEF(3)=0.
28357             GCOEF(4)=0.
28358             GCOEF(5)=GCOEF(1)
28359             GCOEF(6)=UT-TU
28360             GCOEF(7)=-GCOEF(6)
28361          ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
28362      &           IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
28363      &           IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
28364      &           IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
28365 C qg-->qg or qbarg-->qbarg or gq-->gq  or gqbar-->gqbar
28366             SU=1./US
28367             GCOEF(1)=-(SU+US)
28368             GCOEF(2)=0.
28369             GCOEF(3)=2.
28370             GCOEF(4)=0.
28371             GCOEF(5)=SU-US
28372             GCOEF(6)=GCOEF(1)
28373             GCOEF(7)=-GCOEF(5)
28374          ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
28375 C gg-->qqbar
28376             UT=1./TU
28377             GCOEF(1)=TU+UT
28378             GCOEF(2)=-2.
28379             GCOEF(3)=0.
28380             GCOEF(4)=0.
28381             GCOEF(5)=GCOEF(1)
28382             GCOEF(6)=TU-UT
28383             GCOEF(7)=-GCOEF(6)
28384          ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
28385      &                          IHPRO.EQ.31) THEN
28386 C gg-->gg
28387             GT=S*S+T*T+U*U
28388             GCOEF(2)=2.*U*U*T*T
28389             GCOEF(3)=2.*S*S*U*U
28390             GCOEF(4)=2.*S*S*T*T
28391             GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
28392             GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
28393             GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
28394             GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
28395          ELSE
28396             CALL HWVZRO(7,GCOEF)
28397          ENDIF
28398       ENDIF
28399   999 END
28400 CDECK  ID>, HWHQCP.
28401 *CMZ :-        -26/04/91  10.18.57  by  Bryan Webber
28402 *-- Author :    Bryan Webber
28403 C-----------------------------------------------------------------------
28404       SUBROUTINE HWHQCP(ID3,ID4,IPERM,IHPR,*)
28405 C-----------------------------------------------------------------------
28406 C     IDENTIFIES HARD SUBPROCESS
28407 C-----------------------------------------------------------------------
28408       INCLUDE 'HERWIG65.INC'
28409       INTEGER HWRINT,ID3,ID4,IPERM,IHPR,ND3
28410       EXTERNAL HWRINT
28411       IHPRO=IHPR
28412       IF (ID3.GT.0) THEN
28413         IDN(3)=ID3
28414         IDN(4)=ID4
28415       ELSE
28416         ND3=-ID3
28417         IF (ID3.GT.-7) THEN
28418     1     IDN(3)=HWRINT(1,MAXFL)
28419           IF (IDN(3).EQ.ND3) GOTO 1
28420           IDN(4)=IDN(3)+6
28421         ELSE
28422     2     IDN(3)=HWRINT(1,MAXFL)+6
28423           IF (IDN(3).EQ.ND3) GOTO 2
28424           IDN(4)=IDN(3)-6
28425         ENDIF
28426       ENDIF
28427       ICO(1)=IPERM/1000
28428       ICO(2)=IPERM/100-10*ICO(1)
28429       ICO(3)=IPERM/10 -10*(IPERM/100)
28430       ICO(4)=IPERM    -10*(IPERM/10)
28431       RETURN 1
28432       END
28433 CDECK  ID>, HWHQPM.
28434 *CMZ :-        -27/07/95  14.13.56  by  Mike Seymour
28435 *-- Author :    Mike Seymour
28436 C-----------------------------------------------------------------------
28437       SUBROUTINE HWHQPM
28438 C     HARD PROCESS: GAMGAM --> QQBAR/LLBAR/W+W-
28439 C     MEAN EVENT WEIGHT = CROSS-SECTION IN NB AFTER CUTS ON PT
28440 C-----------------------------------------------------------------------
28441       INCLUDE 'HERWIG65.INC'
28442       DOUBLE PRECISION RCS,HCS,RS,S,EMSQ,BE,TMIN,TMAX,T,U,FACTR,Q,CFAC,
28443      $     HWRGEN
28444       INTEGER IHAD1,IHAD2,HQ,ID3,ID4,I1,I2
28445       SAVE HCS,FACTR,HQ,RS
28446       IHAD1=1
28447       IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28448       IHAD2=2
28449       IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28450       IF (GENEV) THEN
28451         RCS=HCS*HWRGEN(0)
28452       ELSE
28453         EVWGT=0.
28454         RS=PHEP(5,3)
28455         S=RS**2
28456         HQ=MOD(IPROC,100)
28457         IF (HQ.EQ.0) THEN
28458           EMSQ=0
28459           BE=1
28460           CFAC=3
28461         ELSE
28462           IF (HQ.GT.6) HQ=2*HQ+107
28463           IF (HQ.EQ.127) HQ=198
28464           EMSQ=RMASS(HQ)**2
28465           BE=1-4*EMSQ/S
28466           IF (BE.LT.ZERO) RETURN
28467           BE=SQRT(BE)
28468           CFAC=1
28469           IF (HQ.LE.6) CFAC=3
28470         ENDIF
28471         TMIN=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMIN**2)/S,ZERO)))
28472         TMAX=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMAX**2)/S,ZERO)))
28473         IF (TMIN.GE.TMAX) RETURN
28474         T=-(TMAX/TMIN)**HWRGEN(1)*TMIN
28475         IF (HWRGEN(2).GT.HALF) T=-S-T
28476         U=-S-T
28477         COSTH=(T-U)/(BE*S)
28478         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28479         IF (HQ.NE.198) THEN
28480           FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
28481      $         *2*PIFAC*CFAC*ALPHEM**2/S**2
28482      $         *((U-4*EMSQ)/T+(T-4*EMSQ)/U-4*(EMSQ/T+EMSQ/U)**2)
28483         ELSE
28484           FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
28485      $         *6*PIFAC*CFAC*ALPHEM**2/S**2
28486      $         *(1-S/(T*U)*(4D0/3*S+2*EMSQ)
28487      $         +(S/(T*U))**2*(2D0/3*S**2+2*EMSQ**2))
28488         ENDIF
28489       ENDIF
28490       HCS=0.
28491       XX(1)=1.
28492       XX(2)=1.
28493       IF (HQ.EQ.0) THEN
28494         I1=1
28495         I2=6
28496       ELSE
28497         I1=HQ
28498         I2=HQ
28499       ENDIF
28500       DO 10 ID3=I1,I2
28501         IF (RS.GT.2*RMASS(ID3)) THEN
28502           Q=ICHRG(ID3)
28503           IF (HQ.LE.6) Q=Q/THREE
28504           ID4=ID3+6
28505           IF (HQ.EQ.198) ID4=199
28506           HCS=HCS+Q**4
28507           IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,1243,61,*99)
28508         ENDIF
28509  10   CONTINUE
28510       EVWGT=FACTR*HCS
28511       RETURN
28512  99   IDN(1)=59
28513       IDN(2)=59
28514       IDCMF=15
28515       CALL HWETWO(.TRUE.,.TRUE.)
28516       END
28517 CDECK  ID>, HWHRBB.
28518 *CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
28519 *-- Author :    Peter Richardson
28520 C-----------------------------------------------------------------------
28521       SUBROUTINE HWHRBB
28522 C-----------------------------------------------------------------------
28523 C  Subroutine for 2 parton -> 2 parton via UDD resonant squarks
28524 C-----------------------------------------------------------------------
28525       INCLUDE 'HERWIG65.INC'
28526       DOUBLE PRECISION HCS,S,RCS,HWRGEN,MQ1,MQ2,TAU,LOWTLM,UPPTLM,RTAB,
28527      &                 SQSH,MATELM,SCF(12),CHANPB(2),HWRUNI,PCM,MIX(12),
28528      &                 ME(2,3,3,3,3),WD,MS(12),SWD(12),RAND,TAUA,
28529      &                 CHAN(12),EPS,SH,FAC,TAUB,LAM(6,3,3,3,3),
28530      &                 XMIN,XMAX,XPOW,XUPP,MS2(12),MSWD(12)
28531       INTEGER I,J,K,L,I1,J1,K1,L1,N,THEP,CONECT(4,5),HWRINT,
28532      &        GENR,GN,MIG,MXG,GEN
28533       LOGICAL FIRST
28534       EXTERNAL HWRGEN,HWRUNI
28535       PARAMETER(EPS=1D-20)
28536       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
28537       SAVE HCS,ME,MS,SWD,CHAN,LAM,MIX,FAC,SH,SQSH,SCF,MS2,MSWD
28538       DATA CONECT/1,1,3,4,-1,-1,2,3,0,0,0,0,1,1,-2,-3,-1,-1,-3,-4/
28539       IF(GENEV) THEN
28540         RCS = HCS*HWRGEN(0)
28541       ELSE
28542         IF(FSTWGT) THEN
28543 C--Extract masses and width's needed
28544           DO I=1,3
28545             MS(2*I-1)  = RMASS(399+2*I)
28546             MS(2*I)    = RMASS(411+2*I)
28547             MS(2*I+5)  = RMASS(400+2*I)
28548             MS(2*I+6)  = RMASS(412+2*I)
28549             SWD(2*I-1) = HBAR/RLTIM(399+2*I)
28550             SWD(2*I)   = HBAR/RLTIM(411+2*I)
28551             SWD(2*I+5) = HBAR/RLTIM(400+2*I)
28552             SWD(2*I+6) = HBAR/RLTIM(412+2*I)
28553           ENDDO
28554           DO I=1,12
28555              MS2(I)  = MS(I)**2
28556              MSWD(I) = MS(I)*SWD(I)
28557           ENDDO
28558 C--Now set up the parmaters for multichannel integration
28559           RAND = ZERO
28560           DO K=1,3
28561             CHANPB(1) = ZERO
28562             CHANPB(2) = ZERO
28563             DO I=1,3
28564               DO J=1,3
28565                 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
28566                 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
28567               ENDDO
28568             ENDDO
28569             RAND=RAND+CHANPB(1)+CHANPB(2)
28570             DO J=1,2
28571               CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
28572               CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K  ,2,J)**2
28573               MIX(2*K-2+J) = QMIXSS(2*K-1,2,J)**2
28574               MIX(2*K+4+J) = QMIXSS(2*K,2,J)**2
28575             ENDDO
28576           ENDDO
28577           IF(RAND.GT.ZERO) THEN
28578             DO I=1,12
28579               CHAN(I)=CHAN(I)/RAND
28580             ENDDO
28581           ELSE
28582             HCS =ZERO
28583             CALL HWWARN('HWHRBB',500,*999)
28584           ENDIF
28585 C--find the couplings
28586           DO GN=1,3
28587             DO I=1,3
28588               DO J=1,3
28589                 DO K=1,3
28590                   DO L=1,3
28591                     LAM(GN,I,J,K,L)  =LAMDA3(I,J,GN)*LAMDA3(K,L,GN)
28592                     LAM(GN+3,I,J,K,L)=LAMDA3(GN,I,J)*LAMDA3(GN,K,L)
28593                   ENDDO
28594                 ENDDO
28595               ENDDO
28596             ENDDO
28597           ENDDO
28598         ENDIF
28599         EVWGT = ZERO
28600         S     = PHEP(5,3)**2
28601         COSTH = HWRUNI(0,-ONE,ONE)
28602 C--Generate the smoothing
28603         RAND=HWRUNI(0,ZERO,ONE)
28604         DO I=1,12
28605           IF(CHAN(I).GT.RAND) GOTO 20
28606           RAND=RAND-CHAN(I)
28607         ENDDO
28608  20     GENR=I
28609 C--Calculate hard scale and obtain parton distributions
28610         TAUA   = MS2(GENR)/S
28611         TAUB   = SWD(GENR)**2/S
28612         RTAB   = SQRT(TAUA*TAUB)
28613         XUPP = XMAX
28614         IF(XMAX**2.GT.S) XUPP = SQRT(S)
28615         LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
28616         UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
28617         TAU    = HWRUNI(0,LOWTLM,UPPTLM)
28618         TAU    = RTAB*TAN(RTAB*TAU)+TAUA
28619         SH     = S*TAU
28620         SQSH   = SQRT(SH)
28621         EMSCA  = SQSH
28622         XX(1)  = EXP(HWRUNI(0,ZERO,LOG(TAU)))
28623         XX(2)  = TAU/XX(1)
28624         CALL HWSGEN(.FALSE.)
28625 C--Calculate the prefactor due multichannel approach
28626         FAC = ZERO
28627         DO GN=1,12
28628          SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
28629          FAC=FAC+CHAN(GN)*SCF(GN)
28630         ENDDO
28631         FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
28632      &        /(24*PIFAC*SQSH*SH*TAU*FAC*S**2)
28633       ENDIF
28634 C--loop over the quarks
28635       HCS = ZERO
28636       DO GN=1,2
28637         IF(GN.EQ.1) THEN
28638           MIG = 1
28639           MXG = 6
28640         ELSE
28641           MIG = 7
28642           MXG = 12
28643         ENDIF
28644         DO K1=1,3
28645           DO 70 L1=1,3
28646             IF(GN.EQ.1) THEN
28647               K = 2*K1
28648               L = 2*L1-1
28649             ELSE
28650               K=2*K1-1
28651               L=2*L1-1
28652               IF(GN.EQ.2.AND.L1.GE.K1) GOTO 70
28653             ENDIF
28654             MQ1=RMASS(K)
28655             MQ2=RMASS(L)
28656             IF(SQSH.GT.(MQ1+MQ2)) THEN
28657               PCM=SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2)/(4*SH))
28658               WD = SH*(SH-MQ1**2-MQ2**2)*PCM
28659             ELSE
28660               GOTO 70
28661             ENDIF
28662             DO I1=1,3
28663               DO 60 J1=1,3
28664                 IF(GN.EQ.1) THEN
28665                   I = 2*I1
28666                   J = 2*J1-1
28667                 ELSE
28668                   I=2*I1-1
28669                   J=2*J1-1
28670                   IF(J1.GT.I1) GOTO 60
28671                 ENDIF
28672                 IF(GENEV) GOTO 50
28673                 MATELM = ZERO
28674                 DO 40 GEN=MIG,MXG
28675                   IF(ABS(MIX(GEN)).LT.EPS.OR.
28676      &             ABS(LAM(INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS) GOTO 40
28677                   DO 30 GENR=MIG,MXG
28678                     IF(ABS(LAM(INT((GENR+1)/2),I1,J1,K1,L1)).LT.EPS.
28679      &                OR.ABS(MIX(GENR)).LT.EPS) GOTO 30
28680                     MATELM =MATELM+SCF(GEN)*SCF(GENR)*WD*
28681      &                  ((SH-MS2(GEN))*(SH-MS2(GENR))+
28682      &                  MSWD(GEN)*MSWD(GENR))
28683      &                  *LAM(INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
28684      &                  *LAM(INT((GENR+1)/2),I1,J1,K1,L1)*MIX(GENR)
28685  30               CONTINUE
28686  40             CONTINUE
28687                 ME(GN,I1,J1,K1,L1) = MATELM*FAC
28688 C--Add up the term to get the cross-section
28689  50             HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I,1)*DISF(J,2)
28690                 IF(HCS.GT.RCS.AND.GENEV)
28691      &                           CALL HWHRSS(1,I,J,K,L,0,0,*100)
28692                 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J,1)*DISF(I,2)
28693                 IF(HCS.GT.RCS.AND.GENEV)
28694      &                           CALL HWHRSS(2,J,I,K,L,0,0,*100)
28695                 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I+6,1)*DISF(J+6,2)
28696                 IF(HCS.GT.RCS.AND.GENEV)
28697      &                           CALL HWHRSS(1,I,J,K,L,1,0,*100)
28698                 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J+6,1)*DISF(I+6,2)
28699                 IF(HCS.GT.RCS.AND.GENEV)
28700      &                           CALL HWHRSS(2,J,I,K,L,1,0,*100)
28701  60           CONTINUE
28702             ENDDO
28703  70       CONTINUE
28704         ENDDO
28705       ENDDO
28706  100  IF(GENEV) THEN
28707         CALL HWETWO(.TRUE.,.TRUE.)
28708 C--first stage of the colour connection corrections
28709         DO THEP=1,5
28710           IF(THEP.NE.3) THEN
28711             JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP+CONECT(HWRINT(1,4),THEP)
28712             JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
28713           ENDIF
28714         ENDDO
28715         THEP = NHEP-4
28716         IF(HWRINT(1,2).EQ.1) THEN
28717           HRDCOL(2,1) = THEP+3
28718           HRDCOL(2,2) = THEP+4
28719           HRDCOL(1,4) = THEP
28720           HRDCOL(1,5) = THEP+1
28721         ELSE
28722           HRDCOL(2,1) = THEP+4
28723           HRDCOL(2,2) = THEP+3
28724           HRDCOL(1,4) = THEP+1
28725           HRDCOL(1,5) = THEP
28726         ENDIF
28727         DO N=1,5
28728           IF(N.LE.2) THEN
28729             HRDCOL(1,N)=HRDCOL(2,N)
28730           ELSEIF(N.GE.4) THEN
28731             HRDCOL(2,N)=HRDCOL(1,N)
28732           ENDIF
28733         ENDDO
28734         HRDCOL(1,3) = 4
28735         COLUPD = .TRUE.
28736       ELSE
28737         EVWGT = HCS
28738       ENDIF
28739  999  END
28740 CDECK  ID>, HWHRBS.
28741 *CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
28742 *-- Author :    Peter Richardson
28743 C-----------------------------------------------------------------------
28744       SUBROUTINE HWHRBS
28745 C-----------------------------------------------------------------------
28746 C  Subroutine for 2 parton -> parton SUSY particle via UDD resonant
28747 C  squarks.
28748 C-----------------------------------------------------------------------
28749       INCLUDE 'HERWIG65.INC'
28750       DOUBLE PRECISION HCS,S,RCS,HWRGEN,ME(4),CW,MER(6),MZ,TAU,TAUA,
28751      &                 TAUB,LOWTLM,UPPTLM,HWRUNI,SH,SQSH,SCF(12),MW2,
28752      &                 LAMC(3),CHANPB(2),PCM,ECM,RAND,MEN(7,6,3,3),
28753      &                 MEC(2,6,3,3),RTAB,MS(12),SWD(12),AS,HWUALF,
28754      &                 MQ,MN,MQS,SIN2B,TH,UH,FAC,MX(14),CHAN(12),MC(2),
28755      &                 MNS,HWUAEM,SW,G,EC,MW,A(7,14),B(7,14),EPS,XUPP,
28756      &                 MEH(3,42),XMIN,XMAX,XPOW,FAC2,MH(4),ZSQU(2,2),
28757      &                 ZQRK(2),MZ2,GUU(4),GDD(4),ME2,MS2(12),MSWD(12)
28758       INTEGER I,J,K,I1,J1,GEN,THEP,HWRINT,L,GT,GU,GR,I2,
28759      &        CONECT(2,6,5),GN,GENR,SP,SPMN,SPMX,CON,CHARMN,CHARMX,
28760      &        CM,CN
28761       LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
28762       EXTERNAL HWRGEN,HWRUNI,HWUAEM,HWUALF,HWRINT
28763       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
28764       SAVE HCS,MS,SWD,MX,CHAN,A,B,SPMN,SPMX,RAD,MEN,MEC,HIGGS,
28765      &     CHARMN,CHARMX,NEUT,CHAR,SQSH,MEH,SW,CW,MW,MZ,MER,SH,MH,
28766      &     AS,EC,FAC,G,SCF,ZSQU,ZQRK,MW2,MZ2,MS2,MSWD,GUU,GDD
28767       PARAMETER(EPS=1D-20)
28768       DATA CONECT/ 4, 4, 2, 3, 0, 0, 1,-2,-1,-3,-4,-4,
28769      &             3, 4, 3, 3, 0, 0, 1,-3,-1,-4,-3,-3,
28770      &             1, 4,-1, 3, 0, 0, 1, 1,-3,-4,-1,-1,
28771      &             1, 3,-1, 2, 0, 0,-3,-2, 0, 0, 0, 0,
28772      &             1, 4,-1, 3, 0, 0,-3,-2,-1,-1,-1,-1/
28773       IF(GENEV) THEN
28774         RCS = HCS*HWRGEN(0)
28775       ELSE
28776         IF(FSTWGT) THEN
28777 C--Extract masses and width's needed
28778           DO I=1,3
28779             MS(2*I-1) = RMASS(399+2*I)
28780             MS(2*I)   = RMASS(411+2*I)
28781             MS(2*I+5) = RMASS(400+2*I)
28782             MS(2*I+6) = RMASS(412+2*I)
28783             SWD(2*I-1) = HBAR/RLTIM(399+2*I)
28784             SWD(2*I)   = HBAR/RLTIM(411+2*I)
28785             SWD(2*I+5) = HBAR/RLTIM(400+2*I)
28786             SWD(2*I+6) = HBAR/RLTIM(412+2*I)
28787           ENDDO
28788           DO I=1,12
28789              MS2(I)  = MS(I)**2
28790              MSWD(I) = MS(I)*SWD(I)
28791           ENDDO
28792 C--Electroweak parameters
28793           SW = SQRT(SWEIN)
28794           CW = SQRT(1-SWEIN)
28795           MW    = RMASS(198)
28796           MZ    = RMASS(200)
28797           MW2   = MW**2
28798           MZ2   = MZ**2
28799           SIN2B = TWO*SINB*COSB
28800 C--Now set up the parmaters for multichannel integration
28801           RAND = ZERO
28802           DO K=1,3
28803             CHANPB(1) = ZERO
28804             CHANPB(2) = ZERO
28805             DO I=1,3
28806               DO J=1,3
28807                 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
28808                 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
28809               ENDDO
28810             ENDDO
28811             RAND=RAND+CHANPB(1)+CHANPB(2)
28812             DO J=1,2
28813               CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
28814               CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K  ,2,J)**2
28815               MX(2*K-2+J) = QMIXSS(2*K-1,2,J)
28816               MX(2*K+4+J) = QMIXSS(2*K,2,J)
28817             ENDDO
28818             MX(13) = ZERO
28819             MX(14) = ZERO
28820           ENDDO
28821           IF(RAND.GT.ZERO) THEN
28822             DO I=1,12
28823               CHAN(I)=CHAN(I)/RAND
28824             ENDDO
28825           ELSE
28826             CALL HWWARN('HWHRBS',500,*999)
28827           ENDIF
28828 C--Couplings we need for the various processes
28829 C--Gluino
28830           DO I=1,3
28831             DO J=1,2
28832               A(1,2*I-2+J) =  QMIXSS(2*I-1,2,J)
28833               B(1,2*I-2+J) = -QMIXSS(2*I-1,1,J)
28834               A(1,2*I+4+J) =  QMIXSS(2*I,2,J)
28835               B(1,2*I+4+J) = -QMIXSS(2*I,1,J)
28836             ENDDO
28837           ENDDO
28838 C--Now the neutralinos
28839           DO L=1,4
28840             MC(1) =  ZMIXSS(L,3)/(2*MW*COSB*SW)
28841             MC(2) =  ZMIXSS(L,4)/(2*MW*SINB*SW)
28842             DO I=1,3
28843               DO J=1,2
28844                 A(L+1,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
28845      &                    RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
28846                 B(L+1,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
28847      &                    RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
28848                 A(L+1,2*I+4+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
28849      &                    RMASS(2*I)+SRFCH(2*I  ,L)*QMIXSS(2*I,2,J))
28850                 B(L+1,2*I+4+J) = MC(2)*QMIXSS(2*I,2,J)*
28851      &                    RMASS(2*I)+SLFCH(2*I,  L)*QMIXSS(2*I,1,J)
28852               ENDDO
28853             ENDDO
28854           ENDDO
28855 C--Now for the charginos
28856           DO L=1,2
28857             MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
28858             MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
28859             DO I=1,3
28860               DO J=1,2
28861                 A(5+L,2*I-2+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
28862      &                            RMASS(2*I)*QMIXSS(2*I-1,1,J)
28863                 B(5+L,2*I-2+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
28864      &              -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
28865                 A(5+L,2*I+4+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
28866      &                            *QMIXSS(2*I,1,J)
28867                 B(5+L,2*I+4+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
28868      &              -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
28869               ENDDO
28870             ENDDO
28871           ENDDO
28872 C--Zero couplings
28873           DO I=1,7
28874             A(I,13) = ZERO
28875             B(I,13) = ZERO
28876             A(I,14) = ZERO
28877             B(I,14) = ZERO
28878           ENDDO
28879 C--Couplings to the Z boson of squarks and right-handed quarks
28880           ZQRK(1)   = -SW**2/6.0D0/CW
28881           ZQRK(2)   =  SW**2/3.0D0/CW
28882           ZSQU(1,1) =  HALF*(QMIXSS(5,1,1)**2-2.0D0*SW**2/3.0D0)/CW
28883           ZSQU(1,2) =  HALF*QMIXSS(5,1,1)*QMIXSS(5,1,2)/CW
28884           ZSQU(2,1) = -HALF*(QMIXSS(6,1,1)**2-4.0D0*SW**2/3.0D0)/CW
28885           ZSQU(2,2) = -HALF*QMIXSS(6,1,1)*QMIXSS(6,1,2)/CW
28886 C--Higgs Masses
28887           DO I=1,4
28888             MH(I) = RMASS(202+I)
28889           ENDDO
28890 C--Higgs couplings to quarks
28891           DO I=1,3
28892             GUU(I) = GHUUSS(I)**2*HALF**2/MW2
28893             GDD(I) = GHDDSS(I)**2*HALF**2/MW2
28894           ENDDO
28895           GUU(4) = ONE/TANB**2/MW2/8.0D0
28896           GDD(4) = ONE*TANB**2/MW2/8.0D0
28897 C--decide which processes to generate from IPROC
28898           RAD   = .FALSE.
28899           NEUT  = .FALSE.
28900           CHAR  = .FALSE.
28901           HIGGS = .FALSE.
28902           SPMN = 1
28903           SPMX = 5
28904           CHARMN = 1
28905           CHARMX = 2
28906           IF(MOD(IPROC,10000).EQ.4100) THEN
28907             RAD   = .TRUE.
28908             NEUT  = .TRUE.
28909             CHAR  = .TRUE.
28910             HIGGS = .TRUE.
28911           ELSEIF(MOD(IPROC,10000).LT.4120) THEN
28912             SPMN = 2
28913             IF(MOD(IPROC,10000).NE.4110) THEN
28914               SPMN = MOD(IPROC,10)+1
28915               SPMX = SPMN
28916             ENDIF
28917             NEUT=.TRUE.
28918           ELSEIF(MOD(IPROC,10000).LT.4130) THEN
28919             IF(MOD(IPROC,10000).NE.4120) THEN
28920               CHARMN = MOD(IPROC,10)
28921               CHARMX=CHARMN
28922             ENDIF
28923             CHAR = .TRUE.
28924           ELSEIF(MOD(IPROC,10000).EQ.4130) THEN
28925             SPMX = 1
28926             NEUT=.TRUE.
28927           ELSEIF(MOD(IPROC,10000).EQ.4140) THEN
28928             RAD = .TRUE.
28929           ELSEIF(MOD(IPROC,10000).EQ.4150) THEN
28930             HIGGS = .TRUE.
28931           ELSE
28932             CALL HWWARN('HWHRBS',501,*999)
28933           ENDIF
28934         ENDIF
28935         EVWGT = ZERO
28936         S     = PHEP(5,3)**2
28937         COSTH = HWRUNI(0,-ONE,ONE)
28938 C--zero the array
28939         DO I=1,6
28940           DO J=1,3
28941             DO K=1,3
28942               DO L=1,7
28943                 MEN(L,I,J,K)=ZERO
28944               ENDDO
28945               DO L=1,2
28946                 MEC(L,I,J,K)=ZERO
28947               ENDDO
28948             ENDDO
28949           ENDDO
28950         ENDDO
28951 C--Multichannel peak
28952         RAND=HWRUNI(0,ZERO,ONE)
28953         DO I=1,12
28954           IF(CHAN(I).GT.RAND) GOTO 25
28955           RAND=RAND-CHAN(I)
28956         ENDDO
28957  25     GENR=I
28958 C--Calculate the hard scale and obtain parton distributions
28959         TAUA   = MS2(GENR)/S
28960         TAUB   = SWD(GENR)**2/S
28961         RTAB   = SQRT(TAUA*TAUB)
28962         XUPP = XMAX
28963         IF(XMAX**2.GT.S) XUPP = SQRT(S)
28964         LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
28965         UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
28966         TAU    = HWRUNI(0,LOWTLM,UPPTLM)
28967         TAU    = RTAB*TAN(RTAB*TAU)+TAUA
28968         SH   = S*TAU
28969         SQSH = SQRT(SH)
28970         EMSCA  = SQSH
28971         XX(1)  = EXP(HWRUNI(0,ZERO,LOG(TAU)))
28972         XX(2)  = TAU/XX(1)
28973         CALL HWSGEN(.FALSE.)
28974 C--Strong, EM coupling and weak couplings
28975         AS = HWUALF(1,EMSCA)
28976         EC = SQRT(4*PIFAC*HWUAEM(SH))
28977         G  = EC/SW
28978 C--Calculate the prefactor due multichannel approach
28979         FAC = ZERO
28980         DO GN=1,12
28981          SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
28982          FAC=FAC+CHAN(GN)*SCF(GN)
28983         ENDDO
28984         FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
28985      &        /(48*PIFAC*SQSH*SH*TAU*FAC*S**2)
28986       ENDIF
28987       HCS = ZERO
28988       IF(.NOT.NEUT) GOTO 200
28989       DO 140 GN=1,6
28990         GR=2*GN
28991         IF(CHAN(GR).LT.EPS) GOTO 140
28992         DO 130 L=SPMN,SPMX
28993           K = 2*GN+5
28994           IF(GN.GT.3) K = 2*GN
28995           MQ = RMASS(K)
28996           MN = ABS(RMASS(448+L))
28997           MQS = MQ**2
28998           MNS = MN**2
28999           IF(SQSH.LT.(MQ+MN)) GOTO 130
29000           PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
29001           ECM=SQRT(PCM**2+MQS)
29002           TH = MQS-SQSH*(ECM-PCM*COSTH)
29003           UH = MQS-SQSH*(ECM+PCM*COSTH)
29004           DO I=1,3
29005             DO 120 J=1,3
29006               IF(GN.LE.3) THEN
29007                 GU = 6+2*I
29008                 I1 = 2*I
29009                 LAMC(1) = LAMDA3(I,J,GN)**2
29010               ELSE
29011                 GU = 2*I
29012                 I1 = 2*I-1
29013                 LAMC(1) = LAMDA3(GN-3,I,J)**2
29014                 IF(J.GT.I) LAMC(1) = ZERO
29015               ENDIF
29016               GT = 2*J
29017               J1 = 2*J-1
29018 C--Now the matrix elements
29019               IF(LAMC(1).LT.EPS) GOTO 120
29020               IF(GENEV) GOTO 110
29021 C--S channel
29022               ME(3) = MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*(A(L,GR)**2+
29023      &                 B(L,GR)**2)-4*MQ*MN*A(L,GR)*B(L,GR))
29024               ME(4) =-TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*A(L,GU)
29025      &                 /(TH-MS2(GT))/(UH-MS2(GU))
29026      &               +TWO*MX(GR)*MX(GU)*(SH-MS2(GR))*SCF(GR)*SH*
29027      &                 A(L,GU)*(A(L,GR)*UH+B(L,GR)*MQ*MN)/(UH-MS2(GU))
29028      &               +TWO*MX(GR)*MX(GT)*(SH-MS2(GR))*SCF(GR)*SH*
29029      &                 A(L,GT)*(A(L,GR)*TH+B(L,GR)*MQ*MN)/(TH-MS2(GT))
29030 C--L/R s channel and interference
29031               IF(ABS(MX(GR-1)).GT.EPS) THEN
29032                 ME(3) = ME(3)+
29033      &             MX(GR-1)**2*SCF(GR-1)*SH*((SH-MQS-MNS)*(A(L,GR-1)**2
29034      &                +B(L,GR-1)**2)-4*MQ*MN*A(L,GR-1)*B(L,GR-1))
29035      &            +TWO*MX(GR)*MX(GR-1)*SCF(GR)*SCF(GR-1)*SH*
29036      &                ((SH-MS2(GR))*(SH-MS2(GR-1))+MSWD(GR)*MSWD(GR-1))*
29037      &                ((SH-MQS-MNS)*(A(L,GR)*A(L,GR-1)
29038      &                +B(L,GR)*B(L,GR-1))
29039      &                -TWO*MQ*MN*(A(L,GR)*B(L,GR-1)+A(L,GR-1)*B(L,GR)))
29040                ME(4) = ME(4)+TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))
29041      &           *SCF(GR-1)*A(L,GU)*SH*(A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)
29042      &            /(UH-MS2(GU))
29043      &          +TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*SH*
29044      &            A(L,GT)*(A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT))
29045                 IF(ABS(MX(GU-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
29046      &                MX(GU-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GU-1)*SH*(
29047      &                A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)/(UH-MS2(GU-1))
29048                 IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
29049      &                MX(GT-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GT-1)*SH*
29050      &                (A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT-1))
29051               ENDIF
29052 C--u channel and L/R mixing
29053               ME(1)= MX(GU)**2*(MQS-UH)*(MNS-UH)*
29054      &               (A(L,GU)**2+B(L,GU)**2)/(UH-MS2(GU))**2
29055               IF(ABS(MX(GU-1)).GT.EPS) THEN
29056                 ME(1) = ME(1)+MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
29057      &                   (A(L,GU-1)**2+B(L,GU-1)**2)/(UH-MS2(GU-1))**2
29058      &                 +TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
29059      &                   (A(L,GU)*A(L,GU-1)+B(L,GU)*B(L,GU-1))
29060      &                   /(UH-MS2(GU))/(UH-MS2(GU-1))
29061                 ME(4) =ME(4)+TWO*MX(GR)*MX(GU-1)*(SH-MS2(GR))*
29062      &                   SCF(GR)*A(L,GU-1)*SH*(A(L,GR)*UH+B(L,GR)*MQ*MN)
29063      &                   /(UH-MS2(GU-1))
29064      &                -2*MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*
29065      &                   A(L,GU-1)/(TH-MS2(GT))/(UH-MS2(GU-1))
29066                 IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)-2*MX(GU-1)*MX(GT-1)
29067      &               *(MQS*MNS-UH*TH)*A(L,GT-1)*A(L,GU-1)
29068      &               /(TH-MS2(GT-1))/(UH-MS2(GU-1))
29069               ENDIF
29070 C--t channel and t channel L/R mixing
29071               ME(2) = MX(GT)**2*(MQS-TH)*(MNS-TH)*
29072      &                  (A(L,GT)**2+B(L,GT)**2)/(TH-MS2(GT))**2
29073               IF(ABS(MX(GT-1)).GT.EPS) THEN
29074                 ME(2) = ME(2)+MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
29075      &                   (A(L,GT-1)**2+B(L,GT-1)**2)/(TH-MS2(GT-1))**2
29076      &                 +TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*(A(L,GT)*
29077      &                   A(L,GT-1)+ B(L,GT)*B(L,GT-1))
29078      &                   /(TH-MS2(GT))/(TH-MS2(GT-1))
29079                 ME(4)=ME(4)-TWO*MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*
29080      &                 A(L,GT-1)*A(L,GU)/(TH-MS2(GT-1))/(UH-MS2(GU))
29081      &               +TWO*MX(GR)*MX(GT-1)*(SH-MS2(GR))*SCF(GR)*
29082      &                 A(L,GT-1)*SH*(A(L,GR)*TH+B(L,GR)*MQ*MN)
29083      &                 /(TH-MS2(GT-1))
29084               ENDIF
29085 C--Angular ordering and the phase space factors
29086               IF(L.EQ.1) THEN
29087                ME(4)=-HALF*ME(4)/(ME(1)+ME(2)+ME(3))
29088                LAMC(1) = 32.0D0*LAMC(1)*AS*PIFAC/THREE
29089                DO GEN=1,3
29090                  MEN(GEN,GN,I,J) = FAC*PCM*LAMC(1)*ME(GEN)*(ONE+ME(4))
29091                ENDDO
29092               ELSE
29093                LAMC(1) = TWO*LAMC(1)*EC**2
29094                MEN(L+2,GN,I,J)=FAC*PCM*LAMC(1)*(ME(1)+ME(2)+ME(3)+ME(4))
29095               ENDIF
29096 C--Multiply by the pdf's
29097  110          IF(L.EQ.1) THEN
29098                 CM = 1
29099                 CN = 3
29100               ELSE
29101                 CM = L+2
29102                 CN = L+2
29103               ENDIF
29104               DO GEN=CM,CN
29105               CON = 4
29106               IF(GEN.LE.3) CON = GEN
29107            HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1,1)*DISF(J1,2)
29108            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,GEN,0,0,*900)
29109            HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1,1)*DISF(I1,2)
29110            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,GEN,0,0,*900)
29111            HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
29112            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,GEN,1,0,*900)
29113            HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
29114            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,GEN,1,0,*900)
29115               ENDDO
29116  120        CONTINUE
29117           ENDDO
29118  130    CONTINUE
29119  140  CONTINUE
29120 C--Now the chargino processes if wanted
29121  200  IF(.NOT.CHAR) GOTO 300
29122         DO 240 GN=1,6
29123           GR=2*GN
29124           IF(CHAN(GR).LT.EPS) GOTO 240
29125           DO 230 L=CHARMN,CHARMX
29126           SP =5+L
29127           K = 2*GN+6
29128           IF(GN.GT.3) K = 2*GN-1
29129           MQ = RMASS(K)
29130           MN = ABS(RMASS(453+L))
29131           MQS = MQ**2
29132           MNS = MN**2
29133           IF(SQSH.LT.(MQ+MN)) GOTO 230
29134           PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
29135           ECM=SQRT(PCM**2+MQS)
29136           TH = MQS-SQSH*(ECM-PCM*COSTH)
29137           UH = MQS-SQSH*(ECM+PCM*COSTH)
29138           DO I=1,3
29139             DO 220 J=1,3
29140               IF(GN.LE.3) THEN
29141                 GU = 2*I
29142                 GT = 14
29143                 I1 = 2*I
29144                 LAMC(1) = LAMDA3(I,J,GN)
29145                 LAMC(2) = LAMDA3(GN,I,J)
29146                 LAMC(3) = ZERO
29147               ELSE
29148                 GU = 6+2*I
29149                 GT = 6+2*J
29150                 I1 = 2*I-1
29151                 LAMC(1) = LAMDA3(GN-3,I,J)
29152                 LAMC(2) = LAMDA3(I,J,GN-3)
29153                 LAMC(3) = LAMDA3(J,GN-3,I)
29154                 IF(J.GT.I) LAMC(1) = ZERO
29155               ENDIF
29156               J1 = 2*J-1
29157               IF(ABS(LAMC(1)).LT.EPS) GOTO 220
29158               IF(GENEV) GOTO 210
29159 C--Matrix element
29160 C--S channel
29161               ME(1) = LAMC(1)**2*MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*
29162      &              (A(SP,GR)**2+B(SP,GR)**2)-4*MQ*MN*A(SP,GR)*B(SP,GR))
29163               IF(ABS(MX(GU)).GT.EPS) THEN
29164                 ME(1) = ME(1)+LAMC(2)**2*MX(GU)**2*(MQS-UH)*(MNS-UH)*
29165      &                       (A(SP,GU)**2+B(SP,GU)**2)/(UH-MS2(GU))**2
29166      &                 +LAMC(1)*LAMC(2)*TWO*MX(GR)*MX(GU)*
29167      &                       (SH-MS2(GR))*SCF(GR)*A(SP,GU)*SH*
29168      &                       (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU))
29169                 IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)-LAMC(2)*LAMC(3)*
29170      &                       TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*
29171      &                       A(SP,GU)/(TH-MS2(GT))/(UH-MS2(GU))
29172              ENDIF
29173              IF(ABS(MX(GT)).GT.EPS) THEN
29174                ME(1) = ME(1)+LAMC(3)**2*MX(GT)**2*(MQS-TH)*(MNS-TH)*
29175      &                       (A(SP,GT)**2+B(SP,GT)**2)/(TH-MS2(GT))**2
29176      &                +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT)*
29177      &                       (SH-MS2(GR))*SCF(GR)*A(SP,GT)*SH*
29178      &                       (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT))
29179              ENDIF
29180 c--L/R s channel and interference
29181               IF(ABS(MX(GR-1)).GT.EPS) THEN
29182                 ME(1) = ME(1)+LAMC(1)**2*MX(GR-1)**2*SCF(GR-1)*SH*
29183      &                       ((SH-MQS-MNS)*(A(SP,GR-1)**2+B(SP,GR-1)**2)
29184      &                       -4*MQ*MN*A(SP,GR-1)*B(SP,GR-1))
29185      &                 +LAMC(1)**2*TWO*MX(GR)*MX(GR-1)*SCF(GR)*
29186      &                       SCF(GR-1)*SH*
29187      &                       ((SH-MS2(GR))*(SH-MS2(GR-1))+
29188      &                       MSWD(GR)*MSWD(GR-1))*
29189      &                       ((SH-MQS-MNS)*(A(SP,GR)*A(SP,GR-1)+
29190      &                       B(SP,GR)*B(SP,GR-1))-TWO*MQ*MN*
29191      &                       (A(SP,GR)*B(SP,GR-1)+A(SP,GR-1)*B(SP,GR)))
29192                  IF(ABS(MX(GU)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(2)*
29193      &                   TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))*SCF(GR-1)*
29194      &                   A(SP,GU)*SH*(A(SP,GR-1)*UH+B(SP,GR-1)*MQ*MN)
29195      &                   /(UH-MS2(GU))
29196                  IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(3)*
29197      &                   TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*
29198      &                   A(SP,GT)*SH*(A(SP,GR-1)*TH+B(SP,GR-1)*MQ*MN)
29199      &                   /(TH-MS2(GT))
29200                  IF(ABS(MX(GU-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(2)*
29201      &                   TWO*MX(GR-1)*MX(GU-1)*(SH-MS2(GR-1))*
29202      &                   SCF(GR-1)*A(SP,GU-1)*SH*(A(SP,GR-1)*UH+
29203      &                   B(SP,GR-1)*MQ*MN)/(UH-MS2(GU-1))
29204                 IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(3)*
29205      &                   TWO*MX(GR-1)*MX(GT-1)*(SH-MS2(GR-1))*
29206      &                   SCF(GR-1)*A(SP,GT-1)*SH*(A(SP,GR-1)*TH+
29207      &                    B(SP,GR-1)*MQ*MN)/(TH-MS2(GT-1))
29208               ENDIF
29209 C--u channel and L/R mixing
29210               IF(ABS(MX(GU-1)).GT.EPS) THEN
29211                 ME(1) = ME(1)+LAMC(2)**2*MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
29212      &                 (A(SP,GU-1)**2+B(SP,GU-1)**2)/(UH-MS2(GU-1))**2
29213      &             +LAMC(2)**2*TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
29214      &                 (A(SP,GU)*A(SP,GU-1)+B(SP,GU)*B(SP,GU-1))
29215      &                 /(UH-MS2(GU))/(UH-MS2(GU-1))
29216      &             +TWO*LAMC(1)*LAMC(2)*MX(GR)*MX(GU-1)*
29217      &                 (SH-MS2(GR))*SCF(GR)*A(SP,GU-1)*SH*
29218      &                 (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU-1))
29219                 IF(ABS(MX(GT)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
29220      &               MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*A(SP,GU-1)
29221      &               /(TH-MS2(GT))/(UH-MS2(GU-1))
29222                 IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*
29223      &               TWO*MX(GU-1)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*
29224      &               A(SP,GU-1)/(TH-MS2(GT-1))/(UH-MS2(GU-1))
29225               ENDIF
29226 C--t channel and t channel L/R mixing
29227              IF(ABS(MX(GT-1)).GT.EPS) THEN
29228                 ME(1) = ME(1)+LAMC(3)**2*MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
29229      &                 (A(SP,GT-1)**2+B(SP,GT-1)**2)/(TH-MS2(GT-1))**2
29230      &              +LAMC(3)**2*TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*
29231      &                 (A(SP,GT)*A(SP,GT-1)+B(SP,GT)*B(SP,GT-1))
29232      &                 /(TH-MS2(GT))/(TH-MS2(GT-1))
29233      &              +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT-1)*
29234      &                 (SH-MS2(GR))*SCF(GR)*A(SP,GT-1)*SH*
29235      &                 (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT-1))
29236                 IF(ABS(MX(GU)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
29237      &               MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*A(SP,GU)
29238      &               /(TH-MS2(GT-1))/(UH-MS2(GU))
29239               ENDIF
29240 c--phase space factors
29241               MEC(L,GN,I,J) = G**2*FAC*ME(1)*PCM
29242  210       CON = 4
29243            I2 = SP+2
29244            IF(MOD(K,2).EQ.1) I2 =I2+2
29245            HCS=HCS+MEC(L,GN,I,J)*DISF(I1,1)*DISF(J1,2)
29246            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,I2,0,0,*900)
29247            HCS=HCS+MEC(L,GN,I,J)*DISF(J1,1)*DISF(I1,2)
29248            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,I2,0,0,*900)
29249            HCS=HCS+MEC(L,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
29250            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,I2+2,1,0,*900)
29251            HCS=HCS+MEC(L,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
29252            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,I2+2,1,0,*900)
29253  220       CONTINUE
29254           ENDDO
29255  230      CONTINUE
29256  240      CONTINUE
29257 C--Now the radiative decays, if possible
29258  300  IF(.NOT.RAD.OR.(CHAN(5).LT.EPS.AND.CHAN(11).LT.EPS)) GOTO 400
29259       IF(GENEV) GOTO 320
29260       DO 310 I=1,6
29261  310  MER(I)=ZERO
29262 C--stop to light stop and Z
29263       IF(SH.GT.(MZ+MS(11))**2) THEN
29264         PCM = SQRT((SH-(MZ+MS(11))**2)*(SH-(MZ-MS(11))**2))*HALF/SQSH
29265         ECM=SQRT(PCM**2+MZ2)
29266         TH = MZ2-SQSH*(ECM-PCM*COSTH)
29267         UH = MZ2-SQSH*(ECM+PCM*COSTH)
29268         MER(3) = SH**2*PCM**2*(SCF(11)*ZSQU(2,1)**2*QMIXSS(6,2,1)**2
29269      &             +SCF(12)*ZSQU(2,2)**2*QMIXSS(6,2,2)**2
29270      &             +TWO*SCF(11)*SCF(12)*QMIXSS(6,2,1)*QMIXSS(6,2,2)*
29271      &                ZSQU(2,1)*ZSQU(2,2)*((SH-MS2(11))*
29272      &                (SH-MS2(12))+MSWD(11)*MSWD(12)))
29273      &       +QMIXSS(6,2,1)**2/UH**2*ZQRK(1)**2*(
29274      &             TWO*MZ2*(UH*TH-MS2(11)*MZ2)+UH**2*SH)
29275      &       +QMIXSS(6,2,1)**2/TH**2*ZQRK(1)**2*(
29276      &             TWO*MZ2*(UH*TH-MS2(11)*MZ2)+TH**2*SH)
29277      &       +ZQRK(1)*SH*QMIXSS(6,2,1)*
29278      &            (QMIXSS(6,2,1)*ZSQU(2,1)*(SH-MS2(11))*SCF(11)
29279      &            +QMIXSS(6,2,2)*ZSQU(2,2)*(SH-MS2(12))*SCF(12))
29280      &            *((MZ2*(TWO*MS2(11)-TH)+TH*(SH-MS2(11)))/TH
29281      &             +(MZ2*(TWO*MS2(11)-UH)+UH*(SH-MS2(11)))/UH)
29282      &       -TWO*QMIXSS(6,2,1)**2/UH/TH*ZQRK(1)**2*
29283      &            (TWO*MZ2*(MS2(11)-UH)*(MS2(11)-TH)-SH*TH*UH)
29284         MER(3) = MER(3)*FOUR*PCM/MZ2
29285       ENDIF
29286 C--sbottom to light sbottom and Z
29287       IF(SH.GT.(MZ+MS(5))**2) THEN
29288         PCM = SQRT((SH-(MZ+MS(5))**2)*(SH-(MZ-MS(5))**2))*HALF/SQSH
29289         ECM=SQRT(PCM**2+MZ2)
29290         TH = MZ2-SQSH*(ECM-PCM*COSTH)
29291         UH = MZ2-SQSH*(ECM+PCM*COSTH)
29292         MER(6) = SH**2*PCM**2*(SCF(5)*QMIXSS(5,2,1)**2*ZSQU(1,1)**2
29293      &                +SCF(6)*QMIXSS(5,2,2)**2*ZSQU(1,2)**2
29294      &                +TWO*SCF(5)*SCF(6)*QMIXSS(5,2,1)*QMIXSS(5,2,2)*
29295      &                 ZSQU(1,1)*ZSQU(1,2)*((SH-MS2(5))*
29296      &                 (SH-MS2(6))+MSWD(5)*MSWD(6)))
29297      &       +QMIXSS(5,2,1)**2/UH**2*ZQRK(1)**2*
29298      &           (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+UH**2*SH)
29299      &       +QMIXSS(5,2,1)**2/TH**2*ZQRK(2)**2*
29300      &           (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+TH**2*SH)
29301      &       +QMIXSS(5,2,1)*SH*
29302      &           (QMIXSS(5,2,1)*ZSQU(1,1)*(SH-MS2(5))*SCF(5)
29303      &           +QMIXSS(5,2,2)*ZSQU(1,2)*(SH-MS2(6))*SCF(6))*
29304      &            (ZQRK(1)/UH*(MZ2*(TWO*MS2(5)-UH)+(SH-MS2(5))*UH)
29305      &            +ZQRK(2)/TH*(MZ2*(TWO*MS2(5)-TH)+(SH-MS2(5))*TH))
29306      &       -TWO*QMIXSS(5,2,1)**2*ZQRK(1)*ZQRK(2)/UH/TH*
29307      &            (TWO*MZ2*(MS2(5)-UH)*(MS2(5)-TH)-SH*TH*UH)
29308         MER(6) = MER(6)*FOUR*PCM/MZ2
29309       ENDIF
29310 C--stop to sbottom and W
29311       DO J=1,2
29312         IF(SH.GT.(MW+MS(4+J))**2) THEN
29313           PCM =SQRT((SH-(MW+MS(4+J))**2)*(SH-(MW-MS(4+J))**2))*HALF/SQSH
29314 C--diagram square pieces
29315           DO I=1,2
29316             MER(J)=MER(J)+SCF(10+I)*
29317      &             (QMIXSS(6,2,I)*QMIXSS(6,1,I)*QMIXSS(5,1,J))**2
29318           ENDDO
29319 C--light/heavy interference
29320           MER(J)=TWO*SH**2*PCM**3/MW2*(MER(J)+TWO*SCF(11)*SCF(12)*
29321      &          ((SH-MS2(11))*(SH-MS2(12))
29322      &          +MSWD(11)*MSWD(12))*QMIXSS(5,1,J)**2*
29323      &          QMIXSS(6,2,1)*QMIXSS(6,2,2)*QMIXSS(6,1,1)*QMIXSS(6,1,2))
29324         ENDIF
29325 C--sbottom to stop and W
29326         IF(SH.GT.(MW+MS(10+J))**2) THEN
29327          PCM=SQRT((SH-(MW+MS(10+J))**2)*(SH-(MW-MS(10+J))**2))*HALF/SQSH
29328 C--diagram square pieces
29329           DO I=1,2
29330             MER(J+3)=MER(J+3)+SCF(4+I)*
29331      &           (QMIXSS(5,2,I)*QMIXSS(5,1,I)*QMIXSS(6,1,J))**2
29332           ENDDO
29333 C--light/heavy interference
29334           MER(J+3)=TWO*SH**2*PCM**3/MW2*(MER(J+3)+TWO*SCF(5)*SCF(6)*
29335      &          ((SH-MS2(5))*(SH-MS2(6))+
29336      &          MSWD(5)*MSWD(6))*QMIXSS(6,1,J)**2*
29337      &          QMIXSS(5,2,1)*QMIXSS(5,2,2)*QMIXSS(5,1,1)*QMIXSS(5,1,2))
29338         ENDIF
29339       ENDDO
29340 C--Now multiply by the parton distributions and phase space factors
29341  320  DO J=1,3
29342         DO K=1,3
29343           CON = 5
29344 C--resonant stop's
29345           IF(ABS(LAMDA3(3,J,K)).GT.EPS.AND.J.LT.K) THEN
29346             FAC2 = LAMDA3(3,J,K)**2*FAC*G**2
29347             DO I=1,3
29348             I1=2*J-1
29349             J1=2*K-1
29350             ME2 = MER(I)*FAC2
29351             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29352             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,0,0,*900)
29353             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29354             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,0,0,*900)
29355             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29356             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,1,0,*900)
29357             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29358             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,1,0,*900)
29359             ENDDO
29360           ENDIF
29361 C--resonant sbottom's
29362           IF(ABS(LAMDA3(J,K,3)).GT.EPS) THEN
29363             FAC2 = LAMDA3(J,K,3)**2*FAC*G**2
29364             DO I=4,6
29365             I1=2*J
29366             J1=2*K-1
29367             ME2 = MER(I)*FAC2
29368             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29369             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,0,0,*900)
29370             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29371             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,0,0,*900)
29372             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29373             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,1,0,*900)
29374             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29375             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,1,0,*900)
29376             ENDDO
29377           ENDIF
29378         ENDDO
29379       ENDDO
29380 C--Now the Higgs decays if possible
29381  400  IF(.NOT.HIGGS) GOTO 900
29382       IF(GENEV) GOTO 490
29383       DO I=1,3
29384          DO 405 J=1,42
29385  405        MEH(I,J) = ZERO
29386       ENDDO
29387       DO I=1,3
29388         DO 420 J=1,3
29389 C--Neutral Higgs down type squark
29390         IF(SQSH.LT.MH(J)+MS(2*I-1)) GOTO 410
29391         PCM = SQRT((SH-(MH(J)+MS(2*I-1))**2)*
29392      &             (SH-(MH(J)-MS(2*I-1))**2))*HALF/SQSH
29393         ECM=SQRT(PCM**2+MH(J)**2)
29394         TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
29395         UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
29396         MEH(1,3*I-3+J) = PCM*SH*(
29397      &            QMIXSS(2*I-1,2,1)**2*SCF(2*I-1)*GHSQSS(J,2*I-1,1,1)**2
29398      &             +QMIXSS(2*I-1,2,2)**2*SCF(2*I)*GHSQSS(J,2*I-1,2,1)**2
29399      &              +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
29400      &               *SCF(2*I)*GHSQSS(J,2*I-1,1,1)*GHSQSS(J,2*I-1,2,1)*
29401      &            ((SH-MS2(2*I-1))*(SH-MS2(2*I))+MSWD(2*I-1)*MSWD(2*I)))
29402         MEH(2,3*I-3+J) = PCM*GUU(J)*QMIXSS(2*I,2,1)**2/TH**2*
29403      &                   (TH*UH-MH(J)**2*MS2(2*I-1))
29404         MEH(3,3*I-3+J) = PCM*GDD(J)*QMIXSS(2*I,2,1)**2/UH**2*
29405      &                   (TH*UH-MH(J)**2*MS2(2*I-1))
29406 C--Neutral Higgs up type squarks
29407  410    IF(SQSH.LT.MH(J)+MS(2*I+5)) GOTO 420
29408         PCM = SQRT((SH-(MH(J)+MS(2*I+5))**2)*
29409      &             (SH-(MH(J)-MS(2*I+5))**2))*HALF/SQSH
29410         ECM=SQRT(PCM**2+MH(J)**2)
29411         TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
29412         UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
29413         MEH(1,3*I+6+J) = PCM*SH*(
29414      &               QMIXSS(2*I,2,1)**2*SCF(2*I+5)*GHSQSS(J,2*I,1,1)**2
29415      &              +QMIXSS(2*I,2,2)**2*SCF(2*I+6)*GHSQSS(J,2*I,2,1)**2
29416      &              +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
29417      &               *SCF(2*I+6)*GHSQSS(J,2*I,1,1)*GHSQSS(J,2*I,2,1)*
29418      &              ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
29419      &               MSWD(2*I+5)*MSWD(2*I+6)))
29420         MEH(2,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/TH**2*
29421      &                   (TH*UH-MH(J)**2*MS2(2*I+5))
29422         MEH(3,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/UH**2*
29423      &                   (TH*UH-MH(J)**2*MS2(2*I+5))
29424  420    CONTINUE
29425 C--Charged Higgs up type squark
29426         DO 440 J=1,2
29427         IF(SQSH.LT.MH(4)+MS(2*I+4+J)) GOTO 430
29428         PCM = SQRT((SH-(MH(4)+MS(2*I+4+J))**2)*
29429      &             (SH-(MH(4)-MS(2*I+4+J))**2))*HALF/SQSH
29430         ECM=SQRT(PCM**2+MH(4)**2)
29431         TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
29432         UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
29433         MEH(1,4*I+14+J) = PCM*SH*(
29434      &              QMIXSS(2*I-1,2,1)**2*GHSQSS(4,2*I,J,1)**2*SCF(2*I-1)
29435      &             +QMIXSS(2*I-1,2,2)**2*GHSQSS(4,2*I,J,2)**2*SCF(2*I)
29436      &              +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
29437      &               *SCF(2*I)*GHSQSS(4,2*I,J,1)*GHSQSS(4,2*I,J,2)*
29438      &              ((SH-MS2(2*I-1))*(SH-MS2(2*I))+
29439      &                   MSWD(2*I-1)*MSWD(2*I)))
29440         MEH(2,4*I+14+J) = PCM*QMIXSS(2*I,2,J)**2*GDD(4)/TH**2*
29441      &                    (UH*TH-MS2(2*I+4+J)*MH(4)**2)
29442 C--Charged Higgs down type squark
29443  430    IF(SQSH.LT.MH(4)+MS(2*I-2+J)) GOTO 440
29444         PCM = SQRT((SH-(MH(4)+MS(2*I-2+J))**2)*
29445      &             (SH-(MH(4)-MS(2*I-2+J))**2))*HALF/SQSH
29446         ECM=SQRT(PCM**2+MH(4)**2)
29447         TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
29448         UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
29449         MEH(1,4*I+16+J) = PCM*SH*(
29450      &              QMIXSS(2*I,2,1)**2*GHSQSS(4,2*I-1,J,1)**2*SCF(2*I+5)
29451      &             +QMIXSS(2*I,2,2)**2*GHSQSS(4,2*I-1,J,2)**2*SCF(2*I+6)
29452      &              +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
29453      &              *SCF(2*I+6)*GHSQSS(4,2*I-1,J,1)*GHSQSS(4,2*I-1,J,2)*
29454      &              ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
29455      &              MSWD(2*I+5)*MSWD(2*I+6)))
29456         MEH(2,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/TH**2*
29457      &                    (UH*TH-MS2(2*I-2+J)*MH(4)**2)
29458         MEH(3,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/UH**2*
29459      &                    (UH*TH-MS2(2*I-2+J)*MH(4)**2)
29460  440    CONTINUE
29461       ENDDO
29462  490  DO I=1,3
29463       DO J=1,3
29464         DO K=1,3
29465           CON = 5
29466           DO L=1,3
29467           IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
29468 C--neutral higgs and sdown
29469             FAC2 = FAC*G**2*LAMDA3(J,K,I)**2
29470             I1=2*J
29471             J1=2*K-1
29472             ME2 = FAC2*(MEH(1,3*I-3+L)+RMASS(I1)**2*MEH(2,3*I-3+L)
29473      &                  +RMASS(J1)**2*MEH(3,3*I-3+L))
29474             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29475           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I-1,0,0,*900)
29476              HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29477           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I-1,0,0,*900)
29478             IF(I2.NE.200) I2=198
29479             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29480           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I-1,1,0,*900)
29481             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29482           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I-1,1,0,*900)
29483           ENDIF
29484           IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
29485             FAC2 = FAC*G**2*LAMDA3(I,J,K)**2
29486 C--neutral higgs and sup
29487             I1=2*J-1
29488             J1=2*K-1
29489             ME2 = FAC2*(MEH(1,3*I+6+L)+RMASS(I1)**2*MEH(2,3*I+6+L)
29490      &                  +RMASS(J1)**2*MEH(3,3*I+6+L))
29491             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29492           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I+5,0,0,*900)
29493             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29494           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I+5,0,0,*900)
29495             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29496           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I+5,1,0,*900)
29497             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29498           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I+5,1,0,*900)
29499           ENDIF
29500           ENDDO
29501           DO L=1,2
29502           IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
29503 C--charged higgs and sup
29504             I1=2*J
29505             J1=2*K-1
29506             FAC2 = FAC*G**2
29507             ME2 = FAC2*(LAMDA3(J,K,I)**2*MEH(1,4*I+L+14)
29508      &                 +LAMDA3(I,J,K)**2*RMASS(I1-1)**2*MEH(2,4*I+L+14))
29509             HCS= HCS+ME2*DISF(I1,1)*DISF(J1,2)
29510         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,4,2*I+4+L,0,0,*900)
29511             HCS= HCS+ME2*DISF(J1,1)*DISF(I1,2)
29512         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,4,2*I+4+L,0,0,*900)
29513             HCS= HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29514         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,5,2*I+4+L,1,0,*900)
29515             HCS= HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29516         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,5,2*I+4+L,1,0,*900)
29517            ENDIF
29518 C--charged higgs and sdown
29519           IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
29520             I1=2*J-1
29521             J1=2*K-1
29522             FAC2 = FAC*G**2
29523             ME2 = FAC2*(MEH(1,4*I+L+16)*LAMDA3(I,J,K)**2
29524      &                 +RMASS(I1+1)**2*LAMDA3(J,I,K)**2*MEH(2,4*I+L+16)
29525      &                 +RMASS(J1+1)**2*LAMDA3(K,I,J)**2*MEH(3,4*I+L+16))
29526             HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
29527         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,5,2*I-2+L,0,0,*900)
29528             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
29529         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,5,2*I-2+L,0,0,*900)
29530             HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
29531         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,4,2*I-2+L,1,0,*900)
29532             HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
29533         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,4,2*I-2+L,1,0,*900)
29534           ENDIF
29535           ENDDO
29536         ENDDO
29537       ENDDO
29538       ENDDO
29539 C--calculate of the matrix elements
29540  900  IF(GENEV) THEN
29541         CALL HWETWO(.TRUE.,.TRUE.)
29542         IF(IERROR.NE.0) RETURN
29543         HVFCEN = .TRUE.
29544 C--first stage of the colour connection corrections
29545         DO THEP=1,5
29546           IF(THEP.NE.3) THEN
29547             JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP
29548      &                       +CONECT(HWRINT(1,2),THEP,CON)
29549             JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
29550           ENDIF
29551         ENDDO
29552         IF(IDHEP(NHEP-4).LT.0) THEN
29553           JDAHEP(2,NHEP-4)=NHEP-1
29554           JDAHEP(2,NHEP-3)=NHEP-3
29555           JDAHEP(2,NHEP-1)=NHEP-4
29556           IF(CON.EQ.5) JDAHEP(2,NHEP-4)=NHEP
29557           JDAHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
29558         ELSE
29559           JMOHEP(2,NHEP-4)=NHEP-1
29560           JMOHEP(2,NHEP-3)=NHEP-3
29561           JMOHEP(2,NHEP-1)=NHEP-4
29562           IF(CON.EQ.5) JMOHEP(2,NHEP-4)=NHEP
29563           JMOHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
29564         ENDIF
29565         IF(CON.EQ.5) THEN
29566           SP=JDAHEP(2,NHEP)
29567           JDAHEP(2,NHEP) = JDAHEP(2,NHEP-1)
29568           JDAHEP(2,NHEP-1) = SP
29569           SP=JMOHEP(2,NHEP)
29570           JMOHEP(2,NHEP) = JMOHEP(2,NHEP-1)
29571           JMOHEP(2,NHEP-1) = SP
29572         ENDIF
29573         HRDCOL(1,1) = NHEP
29574         HRDCOL(1,2) = NHEP-2
29575       ELSE
29576         EVWGT = HCS
29577       ENDIF
29578  999  END
29579 CDECK  ID>, HWHREE.
29580 *CMZ :-        -05/04/02  15:40:41  by  Peter Richardson
29581 *-- Author :    Peter Richardson
29582 C-----------------------------------------------------------------------
29583       SUBROUTINE HWHREE
29584 C-----------------------------------------------------------------------
29585 C     SUSY E+E- --> SM PARTICLES VIA RPV
29586 C     MODIFIED TO INCLUDE BEAM POLARIZATION EFFECTS BY PETER RICHARDSON
29587 C-----------------------------------------------------------------------
29588       INCLUDE 'HERWIG65.INC'
29589       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM,HCS,RCS,FACA,
29590      &                 S,T,PCM,MQ1,MQ2,SP,TP,TPZ,TPN,TPN2,MSL2(3),MZ,
29591      &                 MZ2,MSU2(3,2),MWD(3),GL,GR,GLP,GRP,EC,EE,THTMIN,
29592      &                 MIX(3,2),CFAC,LAM(4,3,3,3,3,3),MET,ME(2,3,3)
29593       DOUBLE COMPLEX FSLL,FSLR,FSRL,FSRR,FTLL,FTLR,FTRL,FTRR,Z,Z0,GZ,
29594      &               SCF(3)
29595       INTEGER I,IHEP,RSID(2),IL,GN,J,K,L,GNMN,GNMX,K1,L1,NTRY,GNR,FID(2)
29596       SAVE HCS,MSL2,MWD,LAM,ME,GL,GR,MZ,MZ2,MSU2,MIX,GNMN,GNMX,IL,RSID,
29597      &     FID
29598       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM
29599       PARAMETER(Z=(0.D0,1.D0),Z0=(0.D0,0.D0))
29600 C--Start of the code
29601       IF(GENEV) THEN
29602         RCS = HCS*HWRGEN(0)
29603       ELSE
29604         IF(FSTWGT) THEN
29605 C--identify the beam particles
29606           IF(ABS(IDHEP(1)).EQ.11) THEN
29607 C--electron beams
29608             RSID(1) = 2
29609             IL = 1
29610           ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
29611 C--muon beams
29612             RSID(1) = 1
29613             IL = 2
29614 C--unrecognized beam particles issue warning
29615           ELSE
29616             CALL HWWARN('HWHREE',500,*999)
29617           ENDIF
29618           RSID(2) = 3
29619 C--masses of the sleptons
29620           DO I=1,3
29621             MSL2(I) = RMASS(424+2*I)
29622             MWD(I)  = MSL2(I)*HBAR/RLTIM(424+2*I)
29623             MSL2(I) = MSL2(I)**2
29624           ENDDO
29625 C--masses and mixings of the t channel squarks
29626           DO I=1,3
29627             MSU2(I,1) = RMASS(400+2*I)
29628             MSU2(I,2) = RMASS(412+2*I)
29629             DO J=1,2
29630               MIX(I,J)  = QMIXSS(2*I,1,J)**2
29631               MSU2(I,J) = MSU2(I,J)**2
29632             ENDDO
29633           ENDDO
29634 C--Z mass
29635           MZ = RMASS(200)
29636           MZ2 = MZ**2
29637 C--find the couplings
29638           DO GN=1,3
29639             DO I=1,3
29640               DO J=1,3
29641                 DO K=1,3
29642                   DO L=1,3
29643                     LAM(1,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA1(GN,K,L)
29644                     LAM(2,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA2(GN,K,L)
29645                     LAM(3,GN,I,J,K,L) = LAM(1,GN,I,J,K,L)
29646                     LAM(4,GN,I,J,K,L) = LAMDA2(I,GN,J)*LAMDA2(K,GN,L)
29647                   ENDDO
29648                 ENDDO
29649               ENDDO
29650             ENDDO
29651           ENDDO
29652 C--Z couplings
29653           GL = LFCH(11)
29654           GR = RFCH(11)
29655 C--select the process from the IPROC code
29656           IF(IPROC.EQ.860) THEN
29657             GNMN = 1
29658             GNMX = 2
29659             FID(1) = 0
29660             FID(2) = 0
29661           ELSEIF(IPROC.GE.870.AND.IPROC.LT.890) THEN
29662             J = MOD(IPROC,10)
29663             IF(MOD(IPROC,10).EQ.0) THEN
29664               FID(1) = 0
29665               FID(2) = 0
29666             ELSE
29667               FID(1) = MOD(J-1,3)+1
29668               FID(2) = INT((J-1)/3)+1
29669             ENDIF
29670             IF(IPROC.LT.880) THEN
29671               GNMN = 1
29672             ELSE
29673               GNMN = 2
29674             ENDIF
29675             GNMX = GNMN
29676           ELSE
29677             CALL HWWARN('HWHREE',501,*999)
29678           ENDIF
29679         ENDIF
29680 C--calculate the kinematic varibles
29681         EVWGT  = ZERO
29682         S      = PHEP(5,3)**2
29683         THTMIN = ONE-FOUR*PTMIN**2/S
29684         IF(THTMIN.LT.ZERO) CALL HWWARN('HWHREE',502,*999)
29685         THTMIN = SQRT(THTMIN)
29686         COSTH  = HWRUNI(0,-THTMIN,THTMIN)
29687         EMSCA  = PHEP(5,3)
29688         GZ     = ONE/(S-MZ**2+Z*MZ*GAMZ)
29689         EE     = HWUAEM(S)
29690         FACA   = GEV2NB*EE**2*PIFAC*S/FOUR
29691         EE     = 0.25D0/EE/PIFAC
29692         SP     = ONE/S
29693         T      = -HALF*S*(ONE-COSTH)
29694         TP     = ONE/T
29695         TPZ    = ONE/(T-MZ2)
29696 C--Calculate the prefactor due multichannel approach
29697         DO GN=1,3
29698           IF(GN.EQ.RSID(1).OR.GN.EQ.RSID(2)) THEN
29699             SCF(GN)= ONE/(S-MSL2(GN)+Z*MWD(GN))
29700           ELSE
29701             SCF(GN) = Z0
29702           ENDIF
29703         ENDDO
29704       ENDIF
29705 C--Now the loop to actually calculate the cross sections
29706       HCS = ZERO
29707       DO GN=GNMN,GNMX
29708         GNR = GN+2
29709         DO K1=1,3
29710           DO 80 L1=1,3
29711             IF(FID(1).NE.0.AND.(FID(1).NE.K1.OR.FID(2).NE.L1).AND.
29712      &         (FID(1).NE.L1.OR.FID(2).NE.K1)) GOTO 80
29713             IF(GN.EQ.1) THEN
29714               K = 119+2*K1
29715               L = 125+2*L1
29716               GLP = GL
29717               GRP = GR
29718               EC = ONE
29719               CFAC = ONE
29720             ELSEIF(GN.EQ.2) THEN
29721               K = 2*K1-1
29722               L = 2*L1+5
29723               GLP = LFCH(K)
29724               GRP = RFCH(K)
29725               EC = ONE/THREE
29726               CFAC = THREE
29727             ENDIF
29728             MQ1 = RMASS(K)
29729             MQ2 = RMASS(L)
29730             IF(EMSCA.LT.(MQ1+MQ2)) GOTO 80
29731             MET = ZERO
29732             IF(GENEV) GOTO 60
29733 C--calculate the matrix element
29734 C--set all coefficents to zero
29735             FSLL = Z0
29736             FSLR = Z0
29737             FSRL = Z0
29738             FSRR = Z0
29739             FTLL = Z0
29740             FTLR = Z0
29741             FTRL = Z0
29742             FTRR = Z0
29743 C--Standard Model terms
29744             IF(K1.EQ.L1) THEN
29745 C--first if same flavour pair production
29746               FSLL = EC*SP+GL*GRP*GZ
29747               FSLR = EC*SP+GL*GLP*GZ
29748               FSRL = EC*SP+GR*GRP*GZ
29749               FSRR = EC*SP+GR*GLP*GZ
29750 C--t channel terms if e+e- --> e+e-
29751               IF(K1.EQ.IL.AND.GN.EQ.1) THEN
29752                 FTLL = TP+GL*GR*TPZ
29753                 FTLR = TP+GL**2*TPZ
29754                 FTRL = TP+GR**2*TPZ
29755                 FTRR = TP+GL*GR*TPZ
29756               ENDIF
29757             ENDIF
29758 C--Now add the RPV terms
29759             DO I=1,3
29760               IF(GN.EQ.1) THEN
29761                 TPN  = ONE/(T-MSL2(I))
29762                 TPN2 = TPN
29763               ELSE
29764                 TPN  = MIX(I,1)/(T-MSU2(I,1))+ MIX(I,2)/(T-MSU2(I,2))
29765                 TPN2 = ZERO
29766               ENDIF
29767               FSLL = FSLL+HALF*LAM(GNR,I,IL,K1,IL,L1)*EE*TPN
29768               FSRR = FSRR+HALF*LAM(GNR,I,K1,IL,L1,IL)*EE*TPN2
29769               FTLL = FTLL+HALF*LAM(GN,I,IL,IL,K1,L1)*EE*SCF(I)
29770               FTRR = FTRR+HALF*LAM(GN,I,IL,IL,L1,K1)*EE*SCF(I)
29771             ENDDO
29772 C--now calculate the matrix element (including beam polarization)
29773             MET =(ONE+COSTH)**2*DREAL(
29774      &              DCONJG(FSLR)*FSLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
29775      &             +DCONJG(FSRL)*FSRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
29776      &             +DCONJG(FTLR)*FTLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
29777      &             +DCONJG(FTRL)*FTRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
29778      &             +TWO*FTLR*DCONJG(FSLR)*(ONE-EPOLN(3))*(ONE+PPOLN(3))
29779      &             +TWO*FTRL*DCONJG(FSRL)*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
29780      &          +(ONE-COSTH)**2*DREAL(
29781      &               DCONJG(FSLL)*FSLL*(ONE-EPOLN(3))*(ONE+PPOLN(3))
29782      &              +DCONJG(FSRR)*FSRR*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
29783      &          +FOUR*DREAL(
29784      &               DCONJG(FTLL)*FTLL*(ONE+EPOLN(3))*(ONE+PPOLN(3))
29785      &              +DCONJG(FTRR)*FTRR*(ONE-EPOLN(3))*(ONE-PPOLN(3)))
29786 C--final phase space factors
29787             ME(GN,K1,L1) = MET*CFAC*FACA*THTMIN
29788  60         HCS = HCS+ME(GN,K1,L1)
29789             IF(HCS.GT.RCS.AND.GENEV) GOTO 900
29790  80       CONTINUE
29791         ENDDO
29792       ENDDO
29793  900  IF(GENEV) THEN
29794 C--change sign of COSTH if antiparticle first
29795         IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
29796 C-Set up the particle types
29797         IDHW(NHEP+1)     = 15
29798         IDHEP(NHEP+1)    = 0
29799         ISTHEP(NHEP+1)   = 110
29800         IDHW(NHEP+2)     = K
29801         IDHW(NHEP+3)     = L
29802         IDHEP(NHEP+2)    = IDPDG(K)
29803         IDHEP(NHEP+3)    = IDPDG(L)
29804 C--Select the masses of the particles and the final-state momenta
29805  910    NTRY = NTRY+1
29806         PHEP(5,NHEP+2)   = HWUMBW(K)
29807         PHEP(5,NHEP+3)   = HWUMBW(L)
29808         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
29809         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
29810         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
29811           GOTO 910
29812         ELSEIF(PCM.LT.ZERO) THEN
29813           CALL HWWARN('HWHREE',100,*999)
29814         ENDIF
29815 C--Set up the colours etc
29816         ISTHEP(NHEP+2)   = 113
29817         ISTHEP(NHEP+3)   = 114
29818         JMOHEP(1,NHEP+1) = 1
29819         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
29820         JMOHEP(2,NHEP+1) = 2
29821         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
29822         JMOHEP(1,NHEP+2) = NHEP+1
29823         JMOHEP(2,NHEP+2) = NHEP+3
29824         JMOHEP(1,NHEP+3) = NHEP+1
29825         JMOHEP(2,NHEP+3) = NHEP+2
29826         JDAHEP(1,NHEP+1) = NHEP+2
29827         JDAHEP(2,NHEP+1) = NHEP+3
29828         JDAHEP(1,NHEP+2) = 0
29829         JDAHEP(2,NHEP+2) = NHEP+3
29830         JDAHEP(1,NHEP+3) = 0
29831         JDAHEP(2,NHEP+3) = NHEP+2
29832 C--Set up the momenta
29833         IHEP  = NHEP+2
29834         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
29835         PHEP(3,IHEP) = PCM*COSTH
29836         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
29837         PHEP(2,IHEP) = ZERO
29838         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
29839         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
29840         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
29841         NHEP  = NHEP+3
29842       ELSE
29843         EVWGT = HCS
29844       ENDIF
29845  999  END
29846 CDECK  ID>, HWHREM.
29847 *CMZ :-        -01/06/94  17.03.31  by  Mike Seymour
29848 *-- Author :    Mike Seymour
29849 C-----------------------------------------------------------------------
29850       SUBROUTINE HWHREM(IBEAM,ITARG)
29851 C-----------------------------------------------------------------------
29852 C     IDENTIFY THE REMNANTS OF THE HARD SCATTERING
29853 C     AND BREAK THEIR COLOUR CONNECTION IF NECESSARY
29854 C-----------------------------------------------------------------------
29855       INCLUDE 'HERWIG65.INC'
29856       DOUBLE PRECISION PCL(5),
29857      $     P1P2,P1SQ,P2SQ,S,M1SQ,M2SQ,TMP1,TMP2,A,B,C,D,PTOT(4),HWULDO
29858       INTEGER IBEAM,ITARG,IHEP,NTEMP,I,ICOL,IANT
29859       LOGICAL LTEMP,T,COL,ANT
29860       PARAMETER (T=.TRUE.)
29861       COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
29862       ANT(I)=I.EQ.13 .OR. I.GE.7.AND.I.LE.12.OR. I.GE.109.AND.I.LE.114
29863 C---LOOK FOR UNTREATED BEAM AND TARGET REMNANTS
29864       IBEAM=0
29865       ITARG=0
29866       DO 10 IHEP=1,NHEP
29867         IF (ISTHEP(IHEP).EQ.148) THEN
29868           IF (ITARG.NE.0) CALL HWWARN('HWHREM',100,*999)
29869           ITARG=IHEP
29870         ELSEIF (ISTHEP(IHEP).EQ.147) THEN
29871           IF (IBEAM.NE.0) CALL HWWARN('HWHREM',101,*999)
29872           IBEAM=IHEP
29873         ENDIF
29874   10  CONTINUE
29875       IF (ITARG.EQ.0) CALL HWWARN('HWHREM',102,*999)
29876       IF (IBEAM.EQ.0) CALL HWWARN('HWHREM',103,*999)
29877 C---MHS FIX TO PREVENT MOMENTUM VIOLATION DUE TO OFF-SHELL BEAM REMNANTS
29878 C---FIND REMNANT MOMENTA AND MASSES
29879       P1P2=HWULDO(PHEP(1,IBEAM),PHEP(1,ITARG))
29880       P1SQ=HWULDO(PHEP(1,IBEAM),PHEP(1,IBEAM))
29881       P2SQ=HWULDO(PHEP(1,ITARG),PHEP(1,ITARG))
29882       S=P1SQ+2*P1P2+P2SQ
29883       TMP1=P1P2**2-P1SQ*P2SQ
29884       IF (TMP1.LE.0) CALL HWWARN('HWHREM',104,*999)
29885       TMP1=SQRT(TMP1)
29886       M1SQ=RMASS(IDHW(IBEAM))**2
29887       M2SQ=RMASS(IDHW(ITARG))**2
29888       TMP2=(S-M1SQ-M2SQ)**2-4*M1SQ*M2SQ
29889       IF (TMP2.LE.0) CALL HWWARN('HWHREM',105,*999)
29890       TMP2=SQRT(TMP2)
29891 C---EXCHANGE A LITTLE MOMENTUM TO PUT THEM BOTH ON MASS-SHELL
29892       A=(1-(P1P2+P2SQ)/TMP1)/2
29893       B=(1-(P1P2+P1SQ)/TMP1)/2
29894       C=(S-M1SQ+M2SQ-TMP2)/(2*S)
29895       D=(S+M1SQ-M2SQ-TMP2)/(2*S)
29896       CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PTOT)
29897       CALL HWVSCA(4,(1-A)*(1-C)+A*D,PHEP(1,IBEAM),PHEP(1,IBEAM))
29898       CALL HWVSCA(4,B*(1-C)+(1-B)*D,PHEP(1,ITARG),PHEP(1,ITARG))
29899       CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PHEP(1,IBEAM))
29900       CALL HWVDIF(4,PTOT,PHEP(1,IBEAM),PHEP(1,ITARG))
29901       CALL HWUMAS(PHEP(1,IBEAM))
29902       CALL HWUMAS(PHEP(1,ITARG))
29903 C---END MHS FIX
29904 C---IF THEY ARE COLOUR CONNECTED, DISCONNECT THEM BY EMITTING A SOFT
29905 C   GLUON AND SPLITTING THAT GLUON TO LIGHT QUARKS
29906 C  (WHICH NORMALLY GETS DONE AS THE FIRST STAGE OF CLUSTER FORMATION)
29907 C---LOOP OVER COLOUR/ANTICOLOUR LINE
29908       DO 20 I=1,2
29909         IF (I.EQ.1) THEN
29910           ICOL=IBEAM
29911           IANT=ITARG
29912         ELSE
29913           ICOL=ITARG
29914           IANT=IBEAM
29915         ENDIF
29916         IF (COL(IDHW(ICOL)).AND.ANT(IDHW(IANT)).AND.
29917      $       JMOHEP(2,ICOL).EQ.IANT.AND.JDAHEP(2,IANT).EQ.ICOL) THEN
29918           CALL HWVSUM(4,PHEP(1,ICOL),PHEP(1,IANT),PCL)
29919           CALL HWUMAS(PCL)
29920           NTEMP=NHEP
29921           CALL HWCCUT(ICOL,IANT,PCL,T,LTEMP)
29922           IF (IERROR.NE.0) RETURN
29923 C---IF NOTHING WAS CREATED THEY MUST BE BELOW THRESHOLD, SO GIVE UP
29924           IF (NHEP.NE.NTEMP+2) RETURN
29925 C---RELABEL THEM AS PERTUBATIVE JUST TO NEATEN UP THE EVENT RECORD
29926           ISTHEP(NHEP-1)=149
29927           ISTHEP(NHEP)=149
29928         ENDIF
29929  20   CONTINUE
29930  999  END
29931 CDECK  ID>, HWHREP.
29932 *CMZ :-        -18/10/00  13:46:47  by  Peter Richardson
29933 *-- Author :    Peter Richardson
29934 C-----------------------------------------------------------------------
29935       SUBROUTINE HWHREP
29936 C-----------------------------------------------------------------------
29937 C     SUSY E+E- RPV PRODUCTION
29938 C-----------------------------------------------------------------------
29939       INCLUDE 'HERWIG65.INC'
29940       IF(IPROC.GE.800.AND.IPROC.LE.850) THEN
29941         CALL HWHRES
29942       ELSEIF(IPROC.GE.860.AND.IPROC.LT.890) THEN
29943         CALL HWHREE
29944 C---UNRECOGNIZED PROCESS
29945       ELSE
29946         CALL HWWARN('HWHREP',500,*999)
29947       ENDIF
29948  999  END
29949 CDECK  ID>, HWHRES.
29950 *CMZ :-        -07/04/02  10:38:51  by  Peter Richardson
29951 *-- Author :    Peter Richardson
29952 C-----------------------------------------------------------------------
29953       SUBROUTINE HWHRES
29954 C-----------------------------------------------------------------------
29955 C     SUSY E+E- --> RPV SINGLE SPARTICLE PRODUCTION
29956 C     POLARZATION EFFECTS ADDED 5/4/02 BY PETER RICHARDSON
29957 C-----------------------------------------------------------------------
29958       INCLUDE 'HERWIG65.INC'
29959       DOUBLE PRECISION HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW,HCS,RCS,FACA,
29960      &                 FACB,FACC,FACD,FACE,M1(4,4),M2(2,4),M3(8,2),
29961      &                 MW,MZ,MSCL(2,2),MSCL2(2,2),MZ2,MSL2,MSR2,MSNU2,
29962      &                 MW2,MCH(2),MCH2(2),MNU(4),MNU2(4),MLT(3),MLT2(3),
29963      &                 MNUT(2),MNUT2(2),RMNUT(2),S,U,T,QPE,SQPE,SM,DM,
29964      &                 PF,PCM,SCF(2),UP,TP,MH(4),MH2(4),THCOS(2),THTMIN,
29965      &                 A(6,4),B(6,4),SW,CW,MC,SIN2B,ZNU,RHO,HSL(2,2),
29966      &                 HL(4),M4(10,2),HNU(3)
29967       INTEGER I,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,NTRY,
29968      &        ISN,IDL,J,L,RSID(2),K,L2,IL,IDZ,RADID(2,8),GMIN,GMAX
29969       LOGICAL NEUT,CHAR,RAD,HIGGS,THSGN
29970       SAVE HCS,M1,M2,M3,M4,SW,CW,MW,MZ,MW2,MZ2,MLT,MLT2,MNUT,MNUT2,
29971      &     RMNUT,MNU,MNU2,MCH,MCH2,MSNU2,A,B,MSL2,MSR2,MSCL,
29972      &     MSCL2,ZNU,THCOS,HSL,HL,HNU,MH,MH2,GMIN,GMAX,
29973      &     RADID,NTID,ISL,ISR,ISN,IDL,CHID,RSID,IL,NEUT,CHAR,RAD,HIGGS
29974       EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW
29975       PARAMETER (SSNU=449,SSCH = 455)
29976 C--Start of the code
29977       IF(GENEV) THEN
29978         RCS = HCS*HWRGEN(0)
29979       ELSE
29980 C--Initialise the hard processes
29981         IF(FSTWGT) THEN
29982 C--Decide which processes to generate
29983           NEUT  = .FALSE.
29984           CHAR  = .FALSE.
29985           RAD   = .FALSE.
29986           HIGGS = .FALSE.
29987 C--all single sparticle production
29988           IF(IPROC.EQ.800) THEN
29989             NEUT  = .TRUE.
29990             CHAR  = .TRUE.
29991             RAD   = .TRUE.
29992             HIGGS = .TRUE.
29993             NTID(1) = 1
29994             NTID(2) = 4
29995             CHID(1) = 1
29996             CHID(2) = 2
29997             GMIN    = 1
29998             GMAX    = 6
29999 C--single neutralino production
30000           ELSEIF(IPROC.GE.810.AND.IPROC.LE.814) THEN
30001             NEUT = .TRUE.
30002             IF(IPROC.EQ.810) THEN
30003               NTID(1) = 1
30004               NTID(2) = 4
30005             ELSE
30006               NTID(1) = IPROC-810
30007               NTID(2) = NTID(1)
30008             ENDIF
30009 C--single chargino production
30010           ELSEIF(IPROC.GE.820.AND.IPROC.LE.822) THEN
30011             CHAR = .TRUE.
30012             IF(IPROC.EQ.820) THEN
30013               CHID(1) = 1
30014               CHID(2) = 2
30015             ELSE
30016               CHID(1) = IPROC-820
30017               CHID(2) = CHID(1)
30018             ENDIF
30019 C--single slepton production with gauge boson
30020           ELSEIF(IPROC.EQ.830) THEN
30021             RAD = .TRUE.
30022             GMIN    = 1
30023             GMAX    = 6
30024 C--single slepton production with Higgs boson
30025           ELSEIF(IPROC.EQ.840) THEN
30026             HIGGS = .TRUE.
30027 C--photon radiation processes
30028           ELSEIF(IPROC.EQ.850) THEN
30029             RAD = .TRUE.
30030             GMIN = 7
30031             GMAX = 8
30032 C--unrecognized process issue warning
30033           ELSE
30034             CALL HWWARN('HWHRES',500,*999)
30035           ENDIF
30036 C--check the particles in the beam
30037           RSID(2) = 3
30038           IF(ABS(IDHEP(1)).EQ.11) THEN
30039 C--electron beams
30040             ISL     = 425
30041             ISR     = 437
30042             ISN     = 426
30043             RSID(1) = 2
30044             IL      = 1
30045           ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
30046 C--muon beams
30047             ISL     = 427
30048             ISR     = 439
30049             ISN     = 428
30050             RSID(1) = 1
30051             IL      = 2
30052 C--unrecognised beam particles issue warning
30053           ELSE
30054             CALL HWWARN('HWHRES',501,*999)
30055           ENDIF
30056           IDL=ABS(IDHEP(1))
30057 C--masses and electroweak parameters
30058           SW  = SQRT(SWEIN)
30059           CW  = SQRT(1-SWEIN)
30060           MW  = RMASS(198)
30061           MZ  = RMASS(200)
30062           MW2 = MW**2
30063           MZ2 = MZ**2
30064           SIN2B = TWO*SINB*COSB
30065 C--neutralino and chargino masses
30066           DO I=1,4
30067             MNU(I)  = RMASS(SSNU+I)
30068             MNU2(I) = MNU(I)**2
30069           ENDDO
30070           DO I = 1,2
30071             MCH(I)  = RMASS(I+SSCH)
30072             MCH2(I) = MCH(I)**2
30073           ENDDO
30074 C--incoming lepton mass
30075           MLT(1) = RMASS(IDL+110)
30076 C--lepton masses in chargino production
30077           DO I=1,2
30078             MLT(I+1) = RMASS(119+2*RSID(I))
30079           ENDDO
30080           DO I=1,3
30081             MLT2(I) = MLT(I)**2
30082           ENDDO
30083 C--t-channel slepton masses
30084           MSL2  = RMASS(ISL)**2
30085           MSR2  = RMASS(ISR)**2
30086           MSNU2 = RMASS(ISN)**2
30087 C--resonant sneutrino masses and widths
30088           DO I=1,2
30089             MNUT(I)  = RMASS(424+2*RSID(I))
30090             MNUT2(I) = MNUT(I)**2
30091             RMNUT(I) = MNUT2(I)*HBAR**2/RLTIM(424+2*RSID(I))**2
30092           ENDDO
30093 C--now calculate the coefficients for the processes
30094 C--first neutralino production
30095           DO L=1,4
30096             MC = MLT(1)*ZMIXSS(L,3)/(TWO*MW*COSB*SW)
30097 C--first for the left slepton
30098             A(L,1) = SLFCH(IDL,L)
30099             B(L,1) = ZSGNSS(L)*MC
30100 C--then the right slepton
30101             A(L,2) = ZSGNSS(L)*SRFCH(IDL,L)
30102             B(L,2) = MC
30103 C--the resonant sneutrino
30104             DO I=1,2
30105               A(L,2+I) = SLFCH(10+2*RSID(I),L)
30106               B(L,2+I) = ZERO
30107             ENDDO
30108           ENDDO
30109 C--now chargino production
30110           DO L=1,2
30111             J=L+4
30112             MC = WMXUSS(L,2)/(SQRT(TWO)*MW*COSB*SW)
30113 C--first for the t channel sneutrino
30114             A(J,1) = WSGNSS(L)*WMXVSS(L,1)/SW
30115             B(J,1) = -MLT(1)*MC
30116 C--now for the resonant sneutrinos
30117             DO I=1,2
30118               A(J,I+1) = WSGNSS(L)*WMXVSS(L,1)/SW
30119               B(J,I+1) = -MLT(I+1)*MC
30120             ENDDO
30121           ENDDO
30122 C--coupling of the Z to the sneutrino
30123           ZNU = HALF/SW/CW
30124 C--now the masses and IDs of the slepton in the radiative processes
30125 C--IDs and masses of the charged sleptons
30126           DO I=1,2
30127             RADID(2,2*I-1) = 423+RSID(I)*2
30128             RADID(2,2*I  ) = 435+RSID(I)*2
30129             MSCL(I,1)      = RMASS(RADID(2,2*I-1))
30130             MSCL(I,2)      = RMASS(RADID(2,2*I))
30131             DO J=1,2
30132               MSCL2(I,J) = MSCL(I,J)**2
30133             ENDDO
30134           ENDDO
30135 C--ID of the W for charged slepton processes
30136           DO I=1,4
30137             RADID(1,I) = 198
30138           ENDDO
30139 C--ID's for the Z and gamma processes
30140           DO I=1,2
30141              RADID(1,I+4) = 200
30142              RADID(1,I+6) = 59
30143              RADID(2,I+4) = 424+RSID(I)*2
30144              RADID(2,I+6) = RADID(2,I+4)
30145           ENDDO
30146 C--couplings of the sleptons to the Higgs
30147           DO I=1,2
30148             DO J=1,2
30149               K = 2*RSID(I)-1
30150               L = 119+2*RSID(I)
30151               HSL(I,J) = LMIXSS(K,1,J)*(RMASS(L)**2*TANB-MW2*SIN2B)
30152      &                   +LMIXSS(K,2,J)*RMASS(L)*MUSS
30153               IF(RSID(I).EQ.3) HSL(I,J) = HSL(I,J)
30154      &          +LMIXSS(K,2,J)*RMASS(L)*ALSS*TANB
30155               HSL(I,J) = HSL(I,J)/SQRT(HALF)/MW
30156             ENDDO
30157           ENDDO
30158 C--coupling of the sneutrino to the Higgs
30159           HNU(1) =  HALF*MZ*SINBPA/CW
30160           HNU(2) = -HALF*MZ*COSBPA/CW
30161           HNU(3) = ZERO
30162 C--couplings of the leptons to the Higgs
30163           RHO   =  HALF*MLT(1)/MW
30164           HL(1) = -RHO*SINA/COSB
30165           HL(2) =  RHO*COSA/COSB
30166           HL(3) =  RHO*TANB
30167           HL(4) =  RHO*TANB/SQRT(HALF)
30168 C--Higgs Masses
30169           DO I=1,4
30170             MH(I)  = RMASS(202+I)
30171             MH2(I) = MH(I)**2
30172           ENDDO
30173         ENDIF
30174 C--Now calculate the weights
30175         COSTH    = HWRUNI(1,-ONE,ONE)
30176         S        = PHEP(5,3)**2
30177         EMSCA    = PHEP(5,3)
30178         FACA     = HWUAEM(S)*GEV2NB/S/8.0D0
30179         FACD     = HALF*FACA/SWEIN
30180         FACB     = HALF*FACD/MW2
30181         FACC     = HALF*FACA/MZ2
30182         FACE     = ALPHEM*GEV2NB/S/8.0D0
30183         DO I=1,2
30184           SCF(I) = ONE/((S-MNUT2(I))**2+RMNUT(I))
30185         ENDDO
30186 C--single neutralino production
30187         IF(.NOT.NEUT) THEN
30188           DO L=1,4
30189             DO J=1,4
30190               M1(L,J) = ZERO
30191             ENDDO
30192           ENDDO
30193           GOTO 100
30194         ENDIF
30195         DO L=NTID(1),NTID(2)
30196           DO J=1,2
30197             SQPE  = S - MNU2(L)
30198             K    = J+2
30199             IF(SQPE.GE.ZERO) THEN
30200               PF   = SQPE/S
30201               T    = HALF*(SQPE*COSTH-S+MNU2(L))
30202               U    = -T-S+MNU2(L)
30203               UP   = ONE/(U-MSL2)
30204               TP   = ONE/(T-MSR2)
30205 C--neutralino antineutrino production (including beam polarization)
30206               M1(L,J) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
30207      &                      A(L,K)**2*S*(S-MNU2(L))*SCF(J)
30208      &                     +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1)
30209      &                     +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2)
30210      &                     +TWO*U*T*UP*TP*A(L,1)*A(L,2))
30211      &           +U*(U-MNU2(L))*UP**2*(ONE-PPOLN(3))*
30212      &               (A(L,1)**2*(ONE-EPOLN(3))+B(L,1)**2*(ONE+EPOLN(3)))
30213      &           +T*(T-MNU2(L))*TP**2*(ONE-EPOLN(3))*
30214      &               (A(L,2)**2*(ONE-PPOLN(3))+B(L,2)**2*(ONE+PPOLN(3)))
30215 C--neutralino neutrino production (including beam polarization)
30216               M1(L,K) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
30217      &                      A(L,K)**2*S*(S-MNU2(L))*SCF(J)
30218      &                     +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1)
30219      &                     +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2)
30220      &                     +TWO*U*T*UP*TP*A(L,1)*A(L,2))
30221      &           +U*(U-MNU2(L))*UP**2*(ONE+PPOLN(3))*
30222      &               (A(L,1)**2*(ONE+EPOLN(3))+B(L,1)**2*(ONE-EPOLN(3)))
30223      &           +T*(T-MNU2(L))*TP**2*(ONE+EPOLN(3))*
30224      &               (A(L,2)**2*(ONE+PPOLN(3))+B(L,2)**2*(ONE-PPOLN(3)))
30225 C--final coefficients
30226               M1(L,J) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,J)
30227               M1(L,K) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,K)
30228             ELSE
30229               M1(L,J) = ZERO
30230               M1(L,K) = ZERO
30231             ENDIF
30232           ENDDO
30233         ENDDO
30234 C--single chargino production
30235  100    IF(.NOT.CHAR) THEN
30236           DO L=1,2
30237             DO J=1,4
30238               M2(L,J) = ZERO
30239             ENDDO
30240           ENDDO
30241           GOTO 200
30242         ENDIF
30243         DO L = CHID(1),CHID(2)
30244           DO J = 1,2
30245             K  = J+1
30246             L2 = L+4
30247             SM  = MCH(L) + MLT(K)
30248             QPE = S - SM**2
30249             IF (QPE.GE.ZERO) THEN
30250               DM   = MCH(L) - MLT(K)
30251               SQPE = SQRT(QPE*(S-DM**2))
30252               PF   = SQPE/S
30253               T    = HALF*(SQPE*COSTH-S+MCH2(L)+MLT2(K))
30254               U    = -T-S+MCH2(L)+MLT2(K)
30255               UP   = ONE/(U-MSNU2)
30256 C--chargino antilepton (including beam polarization)
30257               M2(L,J) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K)
30258      &                  +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))*
30259      &                    (ONE-EPOLN(3))*(ONE-PPOLN(3))
30260      &          +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE-PPOLN(3))*
30261      &             (A(L2,1)**2*(ONE-EPOLN(3))+B(L2,1)**2*(ONE+EPOLN(3)))
30262      &          -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE-EPOLN(3))*
30263      &             (ONE-PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
30264 C--chargino lepton (including beam polarization)
30265               M2(L,J+2) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K)
30266      &                  +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))*
30267      &                    (ONE+EPOLN(3))*(ONE+PPOLN(3))
30268      &          +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE+PPOLN(3))*
30269      &             (A(L2,1)**2*(ONE+EPOLN(3))+B(L2,1)**2*(ONE-EPOLN(3)))
30270      &          -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE+EPOLN(3))*
30271      &             (ONE+PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
30272 C--final coefficients
30273               M2(L,J)  =HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J)
30274               M2(L,J+2)=HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J+2)
30275             ELSE
30276               M2(L,J)   = ZERO
30277               M2(L,J+2) = ZERO
30278             ENDIF
30279           ENDDO
30280         ENDDO
30281 C--Radiative processes
30282  200    IF(.NOT.RAD) THEN
30283           DO I=1,8
30284             DO J=1,2
30285               M3(I,J) = ZERO
30286             ENDDO
30287           ENDDO
30288           GOTO 300
30289         ENDIF
30290         IF(GMAX.LT.7) THEN
30291 C--W charged slepton production
30292           DO I=1,2
30293             DO J=1,2
30294               QPE = S-(MW+MSCL(I,J))**2
30295               IF(QPE.GE.ZERO) THEN
30296                 DM   = MW-MSCL(I,J)
30297                 SQPE = SQRT(QPE*(S-DM**2))
30298                 PF   = SQPE/S
30299                 T    = HALF*(SQPE*COSTH-S+MW2+MSCL2(I,J))
30300                 U    = -T-S+MW2+MSCL2(I,J)
30301                 UP   = ONE/U
30302 C--W slepton
30303                 M3(2*I+J-2,1) = SCF(I)*S*SQPE**2
30304      &            +UP**2*(TWO*MW2*(U*T-MW2*MSCL2(I,J))+U**2*S)
30305      &            -TWO*UP*SCF(I)*(S-MNUT2(I))*S*(MW2*(TWO*MSCL2(I,J)-U)+
30306      &                  U*(S-MSCL2(I,J)))
30307                 M3(2*I+J-2,1) = LAMDA1(RSID(I),IL,IL)**2*FACB*PF
30308      &             *LMIXSS(2*RSID(I)-1,1,J)**2*M3(2*I+J-2,1)
30309 C--W- antislepton (including beam polarization)
30310                 M3(2*I+J-2,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*
30311      &                           M3(2*I+J-2,1)
30312 C--W+ antislepton (including beam polarization)
30313                 M3(2*I+J-2,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*
30314      &                           M3(2*I+J-2,1)
30315               ELSE
30316                 M3(2*I+J-2,1) = ZERO
30317                 M3(2*I+J-2,2) = ZERO
30318               ENDIF
30319             ENDDO
30320           ENDDO
30321 C--Z sneutrino production
30322           DO I=1,2
30323             QPE = S-(MZ+MNUT(I))**2
30324             IF(QPE.GE.ZERO) THEN
30325               DM    = MZ-MNUT(I)
30326               SQPE  = SQRT(QPE*(S-DM**2))
30327               PF    = SQPE/S
30328               T     = HALF*(SQPE*COSTH-S+MZ2+MNUT2(I))
30329               U     = -T-S+MZ2+MNUT2(I)
30330               UP    = ONE/U
30331               TP    = ONE/T
30332               IDZ   = 9+RSID(I)*2
30333 C--Z sneutrino production
30334               M3(I+4,1) = SCF(I)*S*SQPE**2*ZNU**2
30335      &           +TP**2*RFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*T**2)
30336      &           +UP**2*LFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*U**2)
30337      &           -TWO*ZNU*RFCH(IDZ)*TP*S*SCF(I)*(S-MNUT2(I))*
30338      &               (MZ2*(TWO*MNUT2(I)-T)+T*(S-MNUT2(I)))
30339      &           +TWO*ZNU*LFCH(IDZ)*UP*S*SCF(I)*(S-MNUT2(I))*
30340      &               (MZ2*(TWO*MNUT2(I)-U)+U*(S-MNUT2(I)))
30341      &           +TWO*LFCH(IDZ)*RFCH(IDZ)*UP*TP*
30342      &               (TWO*MZ2*(MNUT2(I)-T)*(MNUT2(I)-U)-S*U*T)
30343               M3(I+4,1) = LAMDA1(RSID(I),IL,IL)**2*FACC*PF*M3(I+4,1)
30344 C--Z antisneutrino (including beam polarization)
30345               M3(I+4,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*M3(I+4,1)
30346 C--Z sneutrino     (including beam polarization)
30347               M3(I+4,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*M3(I+4,1)
30348             ELSE
30349               M3(I+4,1) = ZERO
30350               M3(I+4,2) = ZERO
30351             ENDIF
30352           ENDDO
30353         ELSE
30354 C--gamma sneutrino production (includes Jacobian 1-costh**2)
30355 C--now includes polarization effects
30356           DO I=1,2
30357             SQPE = S-MNUT2(I)
30358             IF(SQPE.GE.ZERO) THEN
30359               PF       = SQPE/S
30360               PCM      = HALF*EMSCA*PF
30361               THTMIN   = PTMIN/PCM
30362               IF(THTMIN.GT.ONE) CALL HWWARN('HWHRES',502,*999)
30363               THTMIN   = ONE-THTMIN**2
30364               THTMIN   = HALF*LOG((1+THTMIN)/(1-THTMIN))
30365               RHO      = HWRUNI(2,-THTMIN,THTMIN)
30366               THCOS(I) = -TANH(RHO)
30367               T        = HALF*(SQPE*THCOS(I)-S+MNUT2(I))
30368               U        = -T-S+MNUT2(I)
30369               UP       = ONE/U
30370               TP       = ONE/T
30371               M3(I+6,1)  = U*TP+T*UP+TWO*UP*TP*(MNUT2(I)-U)*(MNUT2(I)-T)
30372               M3(I+6,1)  = LAMDA1(RSID(I),IL,IL)**2*FACE*PF*M3(I+6,1)*
30373      &                   (ONE-THCOS(I)**2)*THTMIN
30374               M3(I+6,2) = M3(I+6,1)*(ONE-EPOLN(3))*(ONE-PPOLN(3))
30375               M3(I+6,1) = M3(I+6,1)*(ONE+EPOLN(3))*(ONE+PPOLN(3))
30376             ELSE
30377               M3(I+6,1) = ZERO
30378               M3(I+6,2) = ZERO
30379             ENDIF
30380           ENDDO
30381         ENDIF
30382 C--Higgs processes
30383  300    IF(.NOT.HIGGS) THEN
30384           DO I=1,10
30385             DO J=1,2
30386               M4(I,J) = ZERO
30387             ENDDO
30388           ENDDO
30389           GOTO 500
30390         ENDIF
30391 C--Charged Higgs charged slepton production
30392         DO I=1,2
30393           DO J=1,2
30394             QPE = S-(MH(4)+MSCL(I,J))**2
30395             IF(QPE.GE.ZERO) THEN
30396               DM   = MH(4)-MSCL(I,J)
30397               SQPE = SQRT(QPE*(S-DM**2))
30398               PF   = SQPE/S
30399               T    = HALF*(SQPE*COSTH-S+MH2(4)+MSCL2(I,J))
30400               U    = -T-S+MH2(4)+MSCL2(I,J)
30401 C--charged Higgs antislepton
30402               M4(2*I+J-2,1) = HSL(I,J)**2*S*SCF(I)*
30403      &                          (ONE-EPOLN(3))*(ONE-PPOLN(3))
30404      &                     +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
30405      &                          *(U*T-MSCL2(I,J)*MH2(4))/U**2*
30406      &                          (ONE+EPOLN(3))*(ONE-PPOLN(3))
30407 C--charged Higgs slepton
30408               M4(2*I+J-2,2) = HSL(I,J)**2*S*SCF(I)*
30409      &                          (ONE+EPOLN(3))*(ONE+PPOLN(3))
30410      &                     +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
30411      &                          *(U*T-MSCL2(I,J)*MH2(4))/U**2*
30412      &                          (ONE-EPOLN(3))*(ONE+PPOLN(3))
30413 C--final coefficients
30414               M4(2*I+J-2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
30415      &                        M4(2*I+J-2,1)*PF
30416               M4(2*I+J-2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
30417      &                        M4(2*I+J-2,2)*PF
30418             ELSE
30419               M4(2*I+J-2,1) = ZERO
30420               M4(2*I+J-2,2) = ZERO
30421             ENDIF
30422           ENDDO
30423         ENDDO
30424 C--neutral higgs sneutrino production
30425         DO L=1,3
30426           DO I=1,2
30427             QPE = S-(MH(L)+MNUT(I))**2
30428             IF(QPE.GE.ZERO) THEN
30429               DM   = MH(L)-MNUT(I)
30430               SQPE = SQRT(QPE*(S-DM**2))
30431               PF   = SQPE/S
30432               T    = HALF*(SQPE*COSTH-S+MH2(L)+MNUT2(I))
30433               U    = -T-S+MH2(L)+MNUT2(I)
30434               IF(L.NE.3) THEN
30435 C--h0, H0 antisneutrino (including beam polarization)
30436                 M4(2*L+I+2,1) = HNU(L)**2*S*SCF(I)*
30437      &                         (ONE-EPOLN(3))*(ONE-PPOLN(3))
30438      &             +HL(L)**2*( ONE/T**2*(ONE+EPOLN(3))*(ONE-PPOLN(3))
30439      &                        +ONE/U**2*(ONE-EPOLN(3))*(ONE+PPOLN(3)))
30440      &                        *(U*T-MH2(L)*MNUT2(I))
30441 C--h0, H0 sneutrino (including beam polarization)
30442                 M4(2*L+I+2,2) = HNU(L)**2*S*SCF(I)*
30443      &                         (ONE+EPOLN(3))*(ONE+PPOLN(3))
30444      &             +HL(L)**2*( ONE/T**2*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30445      &                        +ONE/U**2*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
30446      &                        *(U*T-MH2(L)*MNUT2(I))
30447              ELSE
30448 C--A0 antisneutrino (including beam polarization)
30449                 M4(2*L+I+2,1) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
30450      &              HNU(L)**2*S*SCF(I)
30451      &             +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
30452 C--A0 sneutrino (including beam polarization)
30453                 M4(2*L+I+2,2) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
30454      &              HNU(L)**2*S*SCF(I)
30455      &             +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
30456              ENDIF
30457 C--final coefficients
30458               M4(2*L+I+2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
30459      &                        M4(2*L+I+2,1)*PF
30460               M4(2*L+I+2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
30461      &                        M4(2*L+I+2,2)*PF
30462             ELSE
30463               M4(2*L+I+2,1) = ZERO
30464               M4(2*L+I+2,2) = ZERO
30465             ENDIF
30466           ENDDO
30467         ENDDO
30468       ENDIF
30469 C--Add up the weights now
30470  500  HCS = ZERO
30471 C--single neutralino production
30472       IF(.NOT.NEUT) GOTO 550
30473       DO L=NTID(1),NTID(2)
30474         IG1= SSNU+L
30475         DO J=1,4
30476           IG2 = 126+2*RSID(MOD(J-1,2)+1)-6*INT((J-1)/2)
30477           HCS = HCS+M1(L,J)
30478           THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR.
30479      &            (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
30480           IF(GENEV.AND.HCS.GT.RCS) GOTO 900
30481         ENDDO
30482       ENDDO
30483 C--single chargino production
30484  550  IF(.NOT.CHAR) GOTO 600
30485       DO L=CHID(1),CHID(2)
30486         DO J=1,4
30487           IG1 = SSCH+L-2*INT((J-1)/2)
30488           IG2 = 125+2*RSID(MOD((J-1),2)+1)-6*INT((J-1)/2)
30489           HCS = HCS + M2(L,J)
30490           THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR.
30491      &            (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
30492           IF (GENEV.AND.HCS.GT.RCS) GOTO 900
30493         ENDDO
30494       ENDDO
30495 C--gauge boson slepton production
30496  600  IF(.NOT.RAD) GOTO 650
30497       DO I=GMIN,GMAX
30498         IG1 = RADID(1,I)
30499         IG2 = RADID(2,I)
30500         IF(I.GE.7) COSTH = THCOS(I-6)
30501         DO J=1,2
30502           HCS = HCS+M3(I,J)
30503           THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
30504      &            (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
30505           IF(GENEV.AND.HCS.GT.RCS) GOTO 900
30506           IF(I.LE.4) IG1 = IG1+1
30507           IG2 = IG2+6
30508         ENDDO
30509       ENDDO
30510 C--higgs slepton production
30511  650  IF(.NOT.HIGGS) GOTO 900
30512 C--charged Higgs slepton
30513       DO I=1,4
30514         IG1 = 207
30515         IG2 = RADID(2,I)+6
30516         DO J=1,2
30517           HCS=HCS+M4(I,J)
30518           THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
30519      &            (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
30520           IF(GENEV.AND.HCS.GT.RCS) GOTO 900
30521           IG1 = IG1-1
30522           IG2 = IG2-6
30523         ENDDO
30524       ENDDO
30525 C--Neutral Higgs sneutrino
30526       DO L=1,3
30527         DO I=1,2
30528           IG1 = 202+L
30529           IG2 = 430+2*RSID(I)
30530           DO J=1,2
30531             HCS = HCS+M4(2+2*L+I,J)
30532             THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
30533      &              (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
30534             IF(GENEV.AND.HCS.GT.RCS) GOTO 900
30535             IG2 = IG2-6
30536           ENDDO
30537         ENDDO
30538       ENDDO
30539  900  IF(GENEV) THEN
30540 C--change sign of COSTH if antiparticle first
30541         IF(THSGN) COSTH = -COSTH
30542 C-Set up the particle types
30543         IDHW(NHEP+1)     = 15
30544         IDHEP(NHEP+1)    = 0
30545         ISTHEP(NHEP+1)   = 110
30546         IDHW(NHEP+2)     = IG1
30547         IDHW(NHEP+3)     = IG2
30548         IDHEP(NHEP+2)    = IDPDG(IG1)
30549         IDHEP(NHEP+3)    = IDPDG(IG2)
30550 C--generate the particle masses and final-state momenta
30551         NTRY = 0
30552  910    NTRY = NTRY+1
30553         PHEP(5,NHEP+2)   = HWUMBW(IG1)
30554         PHEP(5,NHEP+3)   = HWUMBW(IG2)
30555 C--Set up the Centre-of-mass energy
30556         CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
30557         PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
30558         IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
30559           GOTO 910
30560         ELSEIF(PCM.LT.ZERO) THEN
30561           CALL HWWARN('HWHRES',100,*999)
30562         ENDIF
30563 C--Set up the colours etc
30564         ISTHEP(NHEP+2)   = 113
30565         ISTHEP(NHEP+3)   = 114
30566         JMOHEP(1,NHEP+1) = 1
30567         IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
30568         JMOHEP(2,NHEP+1) = 2
30569         IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
30570         JMOHEP(1,NHEP+2) = NHEP+1
30571         JMOHEP(2,NHEP+2) = NHEP+2
30572         JMOHEP(1,NHEP+3) = NHEP+1
30573         JMOHEP(2,NHEP+3) = NHEP+3
30574         JDAHEP(1,NHEP+1) = NHEP+2
30575         JDAHEP(2,NHEP+1) = NHEP+3
30576         JDAHEP(1,NHEP+2) = 0
30577         JDAHEP(2,NHEP+2) = NHEP+2
30578         JDAHEP(1,NHEP+3) = 0
30579         JDAHEP(2,NHEP+3) = NHEP+3
30580 C--set up the rest of the momenta
30581         IHEP  = NHEP+2
30582         PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
30583         PHEP(3,IHEP) = PCM*COSTH
30584         PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
30585         PHEP(2,IHEP) = ZERO
30586         CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
30587         CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
30588         CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
30589         NHEP  = NHEP+3
30590       ELSE
30591         EVWGT = HCS
30592       ENDIF
30593  999  END
30594 CDECK  ID>, HWHRLL.
30595 *CMZ :-        -08/04/02  09:00:27  by  Peter Richardson
30596 *-- Author :    Peter Richardson
30597 C-----------------------------------------------------------------------
30598       SUBROUTINE HWHRLL
30599 C-----------------------------------------------------------------------
30600 C  Subroutine for resonant sleptons to standard model particles
30601 C  slepton mass and mass*width added to save statement to
30602 C  avoid problems with Linux by Peter Richardson
30603 C-----------------------------------------------------------------------
30604       INCLUDE 'HERWIG65.INC'
30605       DOUBLE PRECISION HCS,S,RCS,HWRGEN,FAC,ECM,TH,PCM,CFAC,CHANPB,SH,
30606      &                 TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,MSL(12),
30607      &                 SQSH,MET(2),SCF(12),MIX(12),ME(4,3,3,3,3,2),
30608      &                 RAND,CHAN(12),LAM(2,7,3,3,3,3),SLWD(12),RTAB,
30609      &                 WD,MQ1,MQ2,EPS,XMIN,XMAX,XPOW,XUPP,MSL2(12),
30610      &                 MSWD(12)
30611       INTEGER I,J,K,L,I1,J1,K1,L1,GEN,GN,GR,GNMX,GNMN,MIG,MXG,CUP,CF
30612       LOGICAL FIRST
30613       EXTERNAL HWRGEN,HWRUNI
30614       PARAMETER(EPS=1D-20)
30615       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
30616       SAVE HCS,ME,MSL,SLWD,LAM,MIX,CHAN,GNMN,GNMX,SH,SQSH,FAC,SCF,MSL2,
30617      &     MSWD
30618       IF(GENEV) THEN
30619         RCS = HCS*HWRGEN(0)
30620       ELSE
30621         IF(FSTWGT) THEN
30622           DO I=1,3
30623             MSL(2*I-1)  = RMASS(423+2*I)
30624             MSL(2*I)    = RMASS(435+2*I)
30625             MSL(2*I+5)  = RMASS(424+2*I)
30626             MSL(2*I+6)  = RMASS(436+2*I)
30627             SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
30628             SLWD(2*I)   = HBAR/RLTIM(435+2*I)
30629             SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
30630             SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
30631           ENDDO
30632           DO I=1,12
30633              MSL2(I) = MSL(I)**2
30634              MSWD(I) = MSL(I)*SLWD(I)
30635           ENDDO
30636           RAND = ZERO
30637           DO I=1,3
30638             CHANPB=ZERO
30639             DO J=1,3
30640               DO K=1,3
30641                 CHANPB=CHANPB+LAMDA2(I,J,K)**4
30642               ENDDO
30643             ENDDO
30644             RAND=RAND+2*CHANPB
30645             DO J=1,2
30646               CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHANPB
30647               CHAN(2*I+4+J) = LMIXSS(2*I  ,1,J)**2*CHANPB
30648               MIX(2*I-2+J)  = LMIXSS(2*I-1,1,J)**2
30649               MIX(2*I+4+J)  = LMIXSS(2*I  ,1,J)**2
30650             ENDDO
30651           ENDDO
30652           IF(RAND.GT.ZERO) THEN
30653             DO I=1,12
30654               CHAN(I)=CHAN(I)/RAND
30655             ENDDO
30656           ELSE
30657             CALL HWWARN('HWHRLL',500,*999)
30658           ENDIF
30659 C--find the couplings
30660           DO GN=1,3
30661             DO I=1,3
30662               DO J=1,3
30663                 DO K=1,3
30664                   DO L=1,3
30665                     LAM(1,GN,I,J,K,L)  =LAMDA2(GN,I,J)*LAMDA1(GN,K,L)
30666                     LAM(2,GN,I,J,K,L)  =LAMDA2(GN,I,J)*LAMDA2(GN,K,L)
30667                     LAM(1,GN+3,I,J,K,L)=LAM(1,GN,I,J,K,L)
30668                     LAM(2,GN+3,I,J,K,L)=LAM(2,GN,I,J,K,L)
30669                   ENDDO
30670                 ENDDO
30671               ENDDO
30672             ENDDO
30673           ENDDO
30674 C--select the process from the IPROC code
30675           GNMN = 1
30676           GNMX = 4
30677           IF(MOD(IPROC,10000).EQ.4070) THEN
30678             GNMX = 2
30679           ELSEIF(MOD(IPROC,10000).EQ.4080) THEN
30680             GNMN = 3
30681           ENDIF
30682         ENDIF
30683         EVWGT = ZERO
30684         S     = PHEP(5,3)**2
30685         COSTH = HWRUNI(0,-ONE,ONE)
30686 C--Generate the smoothing
30687         RAND=HWRUNI(0,ZERO,ONE)
30688         DO I=1,12
30689           IF(CHAN(I).GT.RAND) GOTO 20
30690           RAND=RAND-CHAN(I)
30691         ENDDO
30692  20     GR = I
30693 C--Calculate hard scale and obtain parton distributions
30694         TAUA   = MSL2(GR)/S
30695         TAUB   = SLWD(GR)**2/S
30696         RTAB   = SQRT(TAUA*TAUB)
30697         XUPP = XMAX
30698         IF(XMAX**2.GT.S) XUPP = SQRT(S)
30699         LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
30700         UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
30701         TAU    = HWRUNI(0,LOWTLM,UPPTLM)
30702         TAU    = RTAB*TAN(RTAB*TAU)+TAUA
30703         SH     = S*TAU
30704         SQSH   = SQRT(SH)
30705         EMSCA  = SQSH
30706         XX(1)  = EXP(HWRUNI(0,ZERO,LOG(TAU)))
30707         XX(2)  = TAU/XX(1)
30708         CALL HWSGEN(.FALSE.)
30709 C--Calculate the prefactor due multichannel approach
30710         FAC = ZERO
30711         DO GN=1,12
30712          SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
30713          FAC=FAC+CHAN(GN)*SCF(GN)
30714         ENDDO
30715         FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
30716      &         /(96*PIFAC*SQSH*SH*TAU*FAC*S**2)
30717       ENDIF
30718 C--Now the loop to actually calculate the cross-sections
30719       HCS = ZERO
30720       DO GN=GNMN,GNMX
30721         IF(MOD(GN,2).EQ.1) THEN
30722           MIG = 1
30723           MXG = 6
30724         ELSE
30725           MIG = 7
30726           MXG = 12
30727         ENDIF
30728         IF(GN.LE.2) THEN
30729           CFAC = THREE*FAC
30730           CUP=2
30731         ELSE
30732           CFAC = FAC
30733           CUP=1
30734         ENDIF
30735         DO K1=1,3
30736           DO 80 L1=1,3
30737             IF(GN.EQ.1) THEN
30738               K = 2*K1
30739               L = 2*L1+5
30740             ELSEIF(GN.EQ.2) THEN
30741               K = 2*K1-1
30742               L = 2*L1+5
30743             ELSEIF(GN.EQ.3) THEN
30744               K = 120+2*K1
30745               L = 125+2*L1
30746             ELSEIF(GN.EQ.4) THEN
30747               K = 119+2*K1
30748               L = 125+2*L1
30749             ENDIF
30750             MQ1 = RMASS(K)
30751             MQ2 = RMASS(L)
30752             IF(SQSH.GT.(MQ1+MQ2)) THEN
30753               PCM = SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2))/(2*SQSH)
30754               WD = (SH-MQ1**2-MQ2**2)*SH*PCM
30755             ELSE
30756               GOTO 80
30757             ENDIF
30758             DO I1=1,3
30759               DO 70 J1=1,3
30760                 IF(MOD(GN,2).EQ.1) THEN
30761                   I=2*I1
30762                   J=2*J1+5
30763                 ELSE
30764                   I=2*I1-1
30765                   J=2*J1+5
30766                 ENDIF
30767                 DO GR =1,2
30768                   MET(GR) = ZERO
30769                 ENDDO
30770                 IF(GENEV) GOTO 60
30771                 DO 50 GEN=MIG,MXG
30772                   IF(ABS(LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS.
30773      &                OR.ABS(MIX(GEN)).LT.EPS) GOTO 50
30774                   DO GR=MIG,MXG
30775                     IF(ABS(LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)).GT.EPS.
30776      &                AND.ABS(MIX(GR)).GT.EPS) THEN
30777                       MET(1) =MET(1)+SCF(GEN)*SCF(GR)*WD*
30778      &                 ((SH-MSL2(GEN))*(SH-MSL2(GR))+MSWD(GEN)*MSWD(GR))
30779      &                 *LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
30780      &                 *LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)*MIX(GR)
30781                     ENDIF
30782                   ENDDO
30783 C--Now the t-channel diagrams if the s-channel particles is a sneutrino
30784                   IF(GN.EQ.2) THEN
30785                     ECM=SQRT(PCM**2+MQ1**2)
30786                     TH=MQ1**2-SQSH*(ECM-PCM*COSTH)
30787                     DO GR=MIG,MXG
30788                       MET(2)=MET(2)+(MQ1**2-TH)*(MQ2**2-TH)*PCM*
30789      &                       LAM(2,INT((GEN+1)/2),I1,K1,J1,L1)*MIX(GEN)*
30790      &                       LAM(2,INT((GR+1)/2),I1,K1,J1,L1)*MIX(GR)
30791      &                       /((TH-MSL2(GEN))*(TH-MSL2(GR)))
30792                     ENDDO
30793                    ENDIF
30794  50              CONTINUE
30795 C--final phase space factors
30796                 IF(MET(1).LT.EPS.AND.MET(2).LT.EPS) GOTO 70
30797                 DO GR = 1,2
30798                   ME(GN,I1,J1,K1,L1,GR) = MET(GR)*CFAC
30799                 ENDDO
30800  60             DO GR = 1,2
30801                   CF = GR
30802                   IF(CUP.EQ.1) CF=0
30803                   HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(I,1)*DISF(J,2)
30804                   IF(HCS.GT.RCS.AND.GENEV)
30805      &                           CALL HWHRSS(9,I,J,K,L,0,CF,*100)
30806                   HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(J,1)*DISF(I,2)
30807                   IF(HCS.GT.RCS.AND.GENEV)
30808      &                           CALL HWHRSS(10,J,I,K,L,0,CF,*100)
30809                   HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
30810      &                                       *DISF(I+6,1)*DISF(J-6,2)
30811                   IF(HCS.GT.RCS.AND.GENEV)
30812      &                           CALL HWHRSS(9,I,J,K,L,1,CF,*100)
30813                   HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
30814      &                                       *DISF(J-6,1)*DISF(I+6,2)
30815                   IF(HCS.GT.RCS.AND.GENEV)
30816      &                           CALL HWHRSS(10,J,I,K,L,1,CF,*100)
30817                 ENDDO
30818  70           CONTINUE
30819             ENDDO
30820  80       CONTINUE
30821         ENDDO
30822       ENDDO
30823  100  IF(GENEV) THEN
30824         CALL HWETWO(.TRUE.,.TRUE.)
30825       ELSE
30826         EVWGT = HCS
30827       ENDIF
30828  999  END
30829 CDECK  ID>, HWHRLS.
30830 *CMZ :-        -23/10/00  13:53:06  by  Peter Richardson
30831 *-- Author :    Peter Richardson
30832 C-----------------------------------------------------------------------
30833       SUBROUTINE HWHRLS
30834 C-----------------------------------------------------------------------
30835 C  Subroutine for 2 parton -> sparticle + X via LQD
30836 C-----------------------------------------------------------------------
30837       INCLUDE 'HERWIG65.INC'
30838       DOUBLE PRECISION HCS,A(6,12),B(6,12),S,RCS,HWRGEN,CW,FAC2,EC,ME2,
30839      &               MW,G,TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,SW,SQSH,LC,
30840      &               SH,MSL(12),MSU(12),MST(6),C(2,6,12),D(2,6,12),UH,
30841      &               TH,MEN(4,6,3,3),SCF(12),SLWD(12),MLT(6),MNT(4),PCM,
30842      &               MXS(12),MER(8),MCR(2),RTAB,H(18),MEH(3,18),MXT(12),
30843      &               CHAN(12),MXU(12),RAND,FAC,ECM,MC(2),MEC(2,6,3,3),
30844      &               MZ,CHPROB,EPS,HWUAEM,XMIN,XMAX,XPOW,SIN2B,GUU(4),
30845      &               ML,MN,MLS,MNS,XUPP,MW2,MZ2,ZSLP(2),ZQRK(2),GDD(4),
30846      &               MSL2(12),MH(4),MSWD(12)
30847       INTEGER I,J,K,L,J1,K1,GN,GR,SP,GU,GT,I2,I1,NEUTMN
30848      &        ,NEUTMX,CHARMN,CHARMX,P
30849       LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
30850       EXTERNAL HWRGEN,HWRUNI,HWUAEM
30851       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
30852       SAVE HCS,A,B,C,D,FAC,MER,MEC,MEN,MLT,MSL,MSU,MST,SLWD,MNT,MXT,MXU,
30853      &     SW,CW,MXS,H,MEH,CHAN,NEUTMN,NEUTMX,CHARMN,CHARMX,RAD,NEUT,
30854      &     CHAR,HIGGS,MW,MZ,MW2,MZ2,MCR,SH,SQSH,EC,G,SCF,ZSLP,ZQRK,GUU,
30855      &     GDD,MSL2,MH,MSWD
30856       PARAMETER(EPS=1D-20)
30857       IF(GENEV) THEN
30858         RCS = HCS*HWRGEN(0)
30859       ELSE
30860         IF(FSTWGT) THEN
30861 C--Calculate Electroweak parameters needed
30862           SW  = SQRT(SWEIN)
30863           CW  = SQRT(1-SWEIN)
30864           MW  = RMASS(198)
30865           MZ  = RMASS(200)
30866           MW2 = MW**2
30867           MZ2 = MZ**2
30868           SIN2B = TWO*SINB*COSB
30869 C--Masses and widths
30870           DO I=1,3
30871             MSL(2*I-1)  = RMASS(423+2*I)
30872             MSL(2*I)    = RMASS(435+2*I)
30873             MSL(2*I+5)  = RMASS(424+2*I)
30874             MSL(2*I+6)  = RMASS(436+2*I)
30875             SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
30876             SLWD(2*I)   = HBAR/RLTIM(435+2*I)
30877             SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
30878             SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
30879             MSU(2*I-1)  = RMASS(400+2*I)**2
30880             MSU(2*I)    = RMASS(412+2*I)**2
30881             MSU(2*I+5)  = RMASS(399+2*I)**2
30882             MSU(2*I+6)  = RMASS(411+2*I)**2
30883             MST(2*I-1)  = RMASS(399+2*I)**2
30884             MST(2*I)    = RMASS(411+2*I)**2
30885             MLT(2*I)    = ZERO
30886             MLT(2*I-1)  = RMASS(119+2*I)
30887           ENDDO
30888           DO I=1,12
30889              MSL2(I) = MSL(I)**2
30890              MSWD(I) = MSL(I)*SLWD(I)
30891           ENDDO
30892           DO I=1,4
30893             MNT(I)   = ABS(RMASS(449+I))
30894           ENDDO
30895           MCR(1) = ABS(RMASS(454))
30896           MCR(2) = ABS(RMASS(455))
30897 C--Couplings for the neutralinos
30898           DO L=1,4
30899             MC(1) =  ZMIXSS(L,3)/(2*MW*COSB*SW)
30900             MC(2) =  ZMIXSS(L,4)/(2*MW*SINB*SW)
30901             DO I=1,3
30902               DO J=1,2
30903 C--resonant charged sleptons
30904                 A(L,2*I-2+J) = MC(1)*MLT(2*I-1)*LMIXSS(2*I-1,2,J)
30905      &                         +SLFCH(9+2*I,L)*LMIXSS(2*I-1,1,J)
30906                 B(L,2*I-2+J) = ZSGNSS(L)*(MC(1)*MLT(2*I-1)*
30907      &            LMIXSS(2*I-1,1,J)+SRFCH(9+2*I,L)*LMIXSS(2*I-1,2,J))
30908 C--resonant sneutrinos
30909                 A(L,2*I+4+J) = SLFCH(10+2*I,L)*LMIXSS(2*I,1,J)
30910                 B(L,2*I+4+J) = ZERO
30911 C--u channel up type squarks
30912                 C(1,L,2*I-2+J) = MC(2)*QMIXSS(2*I,2,J)*
30913      &                    RMASS(2*I)+SLFCH(2*I,L)*QMIXSS(2*I,1,J)
30914                 D(1,L,2*I-2+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
30915      &                    RMASS(2*I)+SRFCH(2*I  ,L)*QMIXSS(2*I,2,J))
30916 C--u channel down type squarks
30917                 C(1,L,2*I+4+J) = MC(1)*QMIXSS(2*I-1,2,J)*
30918      &                    RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
30919                 D(1,L,2*I+4+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
30920      &                    RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
30921 C--t channel down type squarks
30922                 C(2,L,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
30923      &                    RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
30924                 D(2,L,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
30925      &                    RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
30926               ENDDO
30927             ENDDO
30928             DO I=1,6
30929               C(2,L,6+I) = C(2,L,I)
30930               D(2,L,6+I) = D(2,L,I)
30931             ENDDO
30932           ENDDO
30933 C--Couplings for charginos
30934           DO L=1,2
30935             MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
30936             MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
30937             SP=L+4
30938             DO I=1,3
30939               DO J=1,2
30940 C--resonant charged slepton
30941                 A(SP,2*I-2+J) = WMXUSS(L,1)*LMIXSS(2*I-1,1,J)
30942      &                          -LMIXSS(2*I-1,2,J)*WMXUSS(L,2)*
30943      &                             MLT(2*I-1)*MC(1)
30944                 B(SP,2*I-2+J) = ZERO
30945 C--resonant sneutrinos
30946                 A(SP,2*I+4+J) = WSGNSS(L)*WMXVSS(L,1)*LMIXSS(2*I,1,J)
30947                 B(SP,2*I+4+J) = -MLT(2*I-1)*WMXUSS(L,2)*LMIXSS(2*I,1,J)
30948      &                           *MC(1)
30949 C--u channel sup
30950                 C(1,SP,2*I-2+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
30951      &              -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
30952                 D(1,SP,2*I-2+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
30953      &                            *QMIXSS(2*I,1,J)
30954 C--u channel sdown
30955                 C(1,SP,2*I+4+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
30956      &              -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
30957                 D(1,SP,2*I+4+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
30958      &                            RMASS(2*I)*QMIXSS(2*I-1,1,J)
30959               ENDDO
30960             ENDDO
30961           ENDDO
30962 C--Couplings and massesfor Higgs
30963           DO I=1,4
30964              MH(I) = RMASS(202+I)
30965           ENDDO
30966 C--first the neutral Higgs
30967 C--fix to the sign of the A and mu term 31/03/00 PR
30968           DO I=1,3
30969             H(I)  = MLT(2*I-1)*HALF/MW/COSB*MUSS*COSA
30970             H(I+4) = MLT(2*I-1)*HALF/MW/COSB*MUSS*SINA
30971             H(I+8) =  -MLT(2*I-1)*HALF/MW*MUSS
30972           ENDDO
30973           H(3) = (H(3)+MLT(5)*HALF/MW/COSB*ALSS*SINA)*TWO*
30974      &           LMIXSS(5,2,1)*LMIXSS(5,1,1)
30975      &           -MZ*SINBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
30976      &           +SWEIN*LMIXSS(5,2,1)**2)+MLT(5)**2*SINA/MW/COSB
30977           H(4) = -MZ*SINBPA/CW*(LMIXSS(5,1,1)*LMIXSS(5,1,2)*(HALF-SWEIN)
30978      &            +SWEIN*LMIXSS(5,2,1)*LMIXSS(5,2,2))
30979      &            +MLT(5)*HALF/COSB/MW*(MUSS*COSA+ALSS*SINA)*
30980      &         (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
30981           H(7) = (H(7)-MLT(5)*HALF/MW/COSB*ALSS*COSA)*TWO*
30982      &            LMIXSS(5,2,1)*LMIXSS(5,1,1)
30983      &            +MZ*COSBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
30984      &            +LMIXSS(5,2,1)**2*SWEIN)-MLT(5)**2*COSA/MW/COSB
30985           H(8) = MZ*COSBPA/CW*(LMIXSS(5,1,2)*LMIXSS(5,1,1)*(HALF-SWEIN)
30986      &            +LMIXSS(5,2,2)*LMIXSS(5,2,1)*SWEIN)
30987      &            +MLT(5)*HALF/MW/COSB*(MUSS*SINA-ALSS*COSA)*
30988      &         (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
30989           H(12) = H(11)-MLT(5)*HALF/MW*ALSS*TANB
30990           H(11) = ZERO
30991 C--Now the charged Higgs
30992           DO J=1,2
30993             DO I=1,3
30994               H(10+2*I+J) = LMIXSS(2*I-1,1,J)*
30995      &                                  (MLT(2*I-1)**2*TANB-MW2*SIN2B)
30996      &                      +LMIXSS(2*I-1,2,J)*MLT(2*I-1)*MUSS
30997             ENDDO
30998             H(16+J) = H(16+J)+LMIXSS(5,2,J)*MLT(5)*ALSS*TANB
30999           ENDDO
31000 C--End of fix
31001 C--couplings of the Higgs to quarks
31002           DO I=1,3
31003              GUU(I) = GHUUSS(I)**2/MW2*HALF**2
31004              GDD(I) = GHDDSS(I)**2/MW2*HALF**2
31005           ENDDO
31006           GUU(4) = ONE/TANB**2/MW2/8.0D0
31007           GDD(4) = ONE*TANB**2/MW2/8.0D0
31008 C--Couplings of the Z to quarks, left up right down, and charged sleptons
31009           ZQRK(1) = -SW**2/6.0D0/CW
31010           ZQRK(2) =  (SW**2/3.0D0-HALF**2)/CW
31011           ZSLP(1) =  HALF*(LMIXSS(5,1,1)**2-2.0D0*SW**2)/CW
31012           ZSLP(2) =  HALF*LMIXSS(5,1,1)*LMIXSS(5,1,2)/CW
31013 C--parameters for multichannel integration
31014           RAND = ZERO
31015           DO I=1,3
31016             CHPROB = ZERO
31017             DO J=1,3
31018               DO K=1,3
31019                 CHPROB=CHPROB+LAMDA2(I,J,K)**2
31020               ENDDO
31021             ENDDO
31022             RAND = RAND+2*CHPROB
31023             DO J=1,2
31024               MXS(2*I-2+J)  = LMIXSS(2*I-1,1,J)
31025               MXS(2*I+4+J)  = LMIXSS(2*I,1,J)
31026               MXU(2*I-2+J)   = QMIXSS(2*I,1,J)
31027               MXU(2*I+4+J)   = QMIXSS(2*I-1,1,J)
31028               MXT(2*I-2+J)   = QMIXSS(2*I-1,2,J)
31029               MXT(2*I+4+J)   = QMIXSS(2*I-1,2,J)
31030               CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHPROB
31031               CHAN(2*I+4+J) = LMIXSS(2*I,1,J)**2*CHPROB
31032             ENDDO
31033           ENDDO
31034           IF(RAND.GT.ZERO) THEN
31035             DO I=1,12
31036               CHAN(I)=CHAN(I)/RAND
31037             ENDDO
31038           ELSE
31039             CALL HWWARN('HWHRLS',500,*999)
31040           ENDIF
31041 C--decide what processes to generate
31042           RAD   = .FALSE.
31043           NEUT  = .FALSE.
31044           CHAR  = .FALSE.
31045           HIGGS = .FALSE.
31046           NEUTMN= 1
31047           NEUTMX = 4
31048           CHARMN = 1
31049           CHARMX = 2
31050 C--Decide which process to generate
31051           IF(MOD(IPROC,10000).EQ.4000) THEN
31052             RAD   = .TRUE.
31053             NEUT  = .TRUE.
31054             CHAR  = .TRUE.
31055             HIGGS = .TRUE.
31056           ELSEIF(MOD(IPROC,10000).LT.4020) THEN
31057             IF(MOD(IPROC,10000).NE.4010) THEN
31058               NEUTMN = MOD(IPROC,10)
31059               NEUTMX = NEUTMN
31060             ENDIF
31061             NEUT=.TRUE.
31062           ELSEIF(MOD(IPROC,10000).LT.4030) THEN
31063             IF(MOD(IPROC,10000).NE.4020) THEN
31064               CHARMN = MOD(IPROC,10)
31065               CHARMX=CHARMN
31066             ENDIF
31067             CHAR  = .TRUE.
31068           ELSEIF(MOD(IPROC,10000).EQ.4040) THEN
31069             RAD   = .TRUE.
31070           ELSEIF(MOD(IPROC,10000).EQ.4050) THEN
31071             HIGGS = .TRUE.
31072           ENDIF
31073         ENDIF
31074 C--basic parameters
31075         EVWGT = ZERO
31076         S     = PHEP(5,3)**2
31077         COSTH = HWRUNI(0,-ONE,ONE)
31078         RAND  = HWRUNI(0,ZERO,ONE)
31079 C--zero arrays
31080         DO I=1,6
31081           DO J=1,3
31082             DO K=1,3
31083               DO L=1,2
31084                MEN(L,I,J,K)   = ZERO
31085                MEN(L+2,I,J,K) = ZERO
31086                MEC(L,I,J,K)   = ZERO
31087               ENDDO
31088             ENDDO
31089           ENDDO
31090         ENDDO
31091         DO I=1,8
31092           MER(I)=ZERO
31093         ENDDO
31094 C--Perform multichannel integration
31095         DO I=1,12
31096           IF(CHAN(I).GT.RAND) THEN
31097              GR=I
31098              GOTO 25
31099           ENDIF
31100           RAND=RAND-CHAN(I)
31101         ENDDO
31102 C--Calculate the hard scale and obtain parton distributions
31103  25     TAUA   = MSL2(GR)/S
31104         TAUB   = SLWD(GR)**2/S
31105         RTAB   = SQRT(TAUA*TAUB)
31106         XUPP = XMAX
31107         IF(XMAX**2.GT.S) XUPP = SQRT(S)
31108         LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
31109         UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
31110         TAU    = HWRUNI(0,LOWTLM,UPPTLM)
31111         TAU    = RTAB*TAN(RTAB*TAU)+TAUA
31112         SH   = S*TAU
31113         SQSH = SQRT(SH)
31114         EMSCA  = SQSH
31115         XX(1)  = EXP(HWRUNI(0,LOG(TAU),ZERO))
31116         XX(2)  = TAU/XX(1)
31117         CALL HWSGEN(.FALSE.)
31118 C--EM and Weak couplings
31119         EC = SQRT(4*PIFAC*HWUAEM(SH))
31120         G  = EC/SW
31121 C--Calculate the prefactor due multichannel approach
31122         FAC = ZERO
31123         DO GN=1,12
31124          SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
31125          FAC=FAC+CHAN(GN)*SCF(GN)
31126         ENDDO
31127         FAC=-(UPPTLM-LOWTLM)*GEV2NB*LOG(TAU)/
31128      &       (48*TAU*FAC*PIFAC*S**2*SH*SQSH)
31129       ENDIF
31130       HCS = ZERO
31131 C--First we do the neutralino production
31132       IF(.NOT.NEUT) GOTO 200
31133       DO 140 GN=1,6
31134       I=GN
31135       GR = 2*GN-1
31136       I1 = 2*GN-1
31137       IF(GN.GT.3) THEN
31138         I=I-3
31139         I1=I1-5
31140       ENDIF
31141       IF(CHAN(GR).LT.EPS) GOTO 140
31142         DO 130 L=NEUTMN,NEUTMX
31143         MN  = MNT(L)
31144         MNS = MN**2
31145         ML  = MLT(I1)
31146         MLS = ML**2
31147         IF((ML+MN).GT.SQSH) GOTO 130
31148 C--that and uhat
31149         PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
31150         ECM = SQRT(PCM**2+MLS)
31151         TH = MLS-SQSH*(ECM-PCM*COSTH)
31152         UH = MLS-SQSH*(ECM+PCM*COSTH)
31153         DO J=1,3
31154           DO 120 K=1,3
31155             IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 120
31156             J1 = 2*J
31157             K1 = 2*K+5
31158             IF(GN.GT.3) J1=J1-1
31159             IF(GENEV) GOTO 110
31160 C--squarks in u and t channels
31161             GU = 6*INT((GN-1)/3)+2*J-1
31162             GT = 2*K
31163 C--calulate the matrix element
31164             ME2=MXS(GR)**2*SCF(GR)*SH*((SH-MLS-MNS)*
31165      &            (A(L,GR)**2+B(L,GR)**2)-4*ML*MN*A(L,GR)*B(L,GR))
31166      &          +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
31167      &               (C(1,L,GU)**2+D(1,L,GU)**2)/(UH-MSU(GU))**2
31168      &          +MXT(GT)**2*(MLS-TH)*(MNS-TH)*
31169      &               (C(2,L,GT)**2+D(2,L,GT)**2)/(TH-MST(GT))**2
31170      &          -TWO*MXT(GT)*MXU(GU)*C(1,L,GU)*C(2,L,GT)*(MLS*MNS-UH*TH)
31171      &                 /(UH-MSU(GU))/(TH-MST(GT))
31172      &          +TWO*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,L,GU)*
31173      &                 SH*(UH*A(L,GR)+ML*MN*B(L,GR))/(UH-MSU(GU))
31174      &          +TWO*MXS(GR)*MXT(GT)*(SH-MSL2(GR))*SCF(GR)*C(2,L,GT)*
31175      &                 SH*(TH*A(L,GR)+ML*MN*B(L,GR))/(TH-MST(GT))
31176 C--s channel mixing L/R mixing
31177             IF(ABS(MXS(GR+1)).GT.EPS) THEN
31178               ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
31179      &               (A(L,GR+1)**2+B(L,GR+1)**2)
31180      &               -4*ML*MN*A(L,GR+1)*B(L,GR+1))
31181      &            +TWO*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
31182      &               ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
31183      &               MSWD(GR)*MSWD(GR+1))*SH*
31184      &               ((SH-MLS-MNS)*(A(L,GR)*A(L,GR+1)+B(L,GR)*B(L,GR+1))
31185      &               -2*ML*MN*(A(L,GR)*B(L,GR+1)+A(L,GR+1)*B(L,GR)))
31186      &            +TWO*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*
31187      &               SH*C(1,L,GU)*(UH*A(L,GR+1)+ML*MN*B(L,GR+1))
31188      &               /(UH-MSU(GU))
31189      &            +TWO*MXS(GR+1)*MXT(GT)*(SH-MSL2(GR+1))*SCF(GR+1)*
31190      &               SH*C(2,L,GT)*(TH*A(L,GR+1)+ML*MN*B(L,GR+1))
31191      &               /(TH-MST(GT))
31192               IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXU(GU+1)*
31193      &               (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(1,L,GU+1)*
31194      &               (UH*A(L,GR+1)+ML*MN*B(L,GR+1))/(UH-MSU(GU+1))
31195               IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXT(GT-1)*
31196      &               (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(2,L,GT-1)*
31197      &               (TH*A(L,GR+1)+ML*MN*B(L,GR+1))/(TH-MST(GT-1))
31198             ENDIF
31199 C--u channel L/R mixing
31200             IF(ABS(MXU(GU+1)).GT.EPS) THEN
31201               ME2=ME2+MXU(GU+1)**2*(MLS-UH)*(MNS-UH)*(C(1,L,GU+1)**2+
31202      &               D(1,L,GU+1)**2)/(UH-MSU(GU+1))**2
31203      &            +TWO*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
31204      &               (C(1,L,GU)*C(1,L,GU+1)+D(1,L,GU)*D(1,L,GU+1))
31205      &               /(UH-MSU(GU))/(UH-MSU(GU+1))
31206      &            -TWO*MXT(GT)*MXU(GU+1)*C(1,L,GU+1)*C(2,L,GT)*
31207      &               (MLS*MNS-UH*TH)/(UH-MSU(GU+1))/(TH-MST(GT))
31208      &            +TWO*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*
31209      &               SH*C(1,L,GU+1)*(UH*A(L,GR)+ML*MN*B(L,GR))
31210      &               /(UH-MSU(GU+1))
31211               IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2-TWO*MXT(GT-1)*MXU(GU+1)*
31212      &               C(1,L,GU+1)*C(2,L,GT-1)*(MLS*MNS-UH*TH)
31213      &               /(UH-MSU(GU+1))/(TH-MST(GT-1))
31214             ENDIF
31215 C--t channel L/R mixing
31216             IF(ABS(MXT(GT-1)).GT.EPS) THEN
31217               ME2=ME2+MXT(GT-1)**2*(MLS-TH)*(MNS-TH)*(C(2,L,GT-1)**2
31218      &                +D(2,L,GT-1)**2)/(TH-MST(GT-1))**2
31219      &            +TWO*MXT(GT)*MXT(GT-1)*(MLS-TH)*(MNS-TH)*
31220      &               (C(2,L,GT)*C(2,L,GT-1)+D(2,L,GT)*D(2,L,GT-1))
31221      &               /(TH-MST(GT))/(TH-MST(GT-1))
31222      &            -TWO*MXT(GT-1)*MXU(GU)*C(1,L,GU)*C(2,L,GT-1)*
31223      &               (MLS*MNS-UH*TH)/(UH-MSU(GU))/(TH-MST(GT-1))
31224      &            +TWO*MXS(GR)*MXT(GT-1)*(SH-MSL2(GR))*SCF(GR)*
31225      &               SH*C(2,L,GT-1)*(TH*A(L,GR)+ML*MN*B(L,GR))
31226      &               /(TH-MST(GT-1))
31227             ENDIF
31228 C--multiply by lamda and factors
31229             MEN(L,GN,J,K) = FAC*ME2*EC**2*LAMDA2(I,J,K)**2*PCM
31230  110        I2=I1+6
31231             HCS = HCS+MEN(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
31232             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,L,0,0,*500)
31233             HCS = HCS+MEN(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
31234             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,L,0,0,*500)
31235             HCS = HCS+MEN(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
31236             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,L,1,0,*500)
31237             HCS = HCS+MEN(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
31238             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,L,1,0,*500)
31239  120      CONTINUE
31240         ENDDO
31241  130    CONTINUE
31242  140  CONTINUE
31243  200  IF(.NOT.CHAR) GOTO 300
31244 C--Chargino production
31245       DO 240 GN=1,6
31246       GR=2*GN-1
31247       I=GN
31248       I1 = 2*GN
31249       IF(GN.GT.3) THEN
31250         I1=I1-7
31251         I=GN-3
31252       ENDIF
31253       IF(CHAN(GR).LT.EPS) GOTO 240
31254       DO 230 L=CHARMN,CHARMX
31255         MN  = MCR(L)
31256         MNS = MN**2
31257         ML  = MLT(I1)
31258         MLS = ML**2
31259         SP = L+4
31260         IF((ML+MN).GT.EMSCA) GOTO 230
31261         PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
31262         ECM = SQRT(PCM**2+MLS)
31263         TH = MLS-SQSH*(ECM-PCM*COSTH)
31264         UH = MLS-SQSH*(ECM+PCM*COSTH)
31265         DO J=1,3
31266           DO 220 K=1,3
31267             IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 220
31268             J1=2*J
31269             K1=2*K+5
31270             IF(GN.GT.3) J1=J1-1
31271             IF(GENEV) GOTO 210
31272             GU = 2*J-1
31273             IF(GN.LE.3) GU=GU+6
31274 C--Calculate the matrix element, s and u terms
31275              ME2 =MXS(GR)**2*SCF(GR)*SH*(
31276      &             (SH-MLS-MNS)*(A(SP,GR)**2+B(SP,GR)**2)
31277      &             -4*ML*MN*A(SP,GR)*B(SP,GR))
31278      &          +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
31279      &             (C(1,SP,GU)**2+D(1,SP,GU)**2)/(UH-MSU(GU))**2
31280      &          -2*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,SP,GU)*
31281      &             SH*(UH*A(SP,GR)+B(SP,GR)*ML*MN)/(UH-MSU(GU))
31282 C--s channel L/R mixing
31283             IF(ABS(MXS(GR+1)).GT.EPS) THEN
31284               ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
31285      &               (A(SP,GR+1)**2+B(SP,GR+1)**2)
31286      &                -4*ML*MN*A(SP,GR+1)*B(SP,GR+1))
31287      &           +2*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
31288      &               ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
31289      &               MSWD(GR)*MSWD(GR+1))*SH*
31290      &               ((SH-MLS-MNS)*(A(SP,GR)*A(SP,GR+1)
31291      &               +B(SP,GR)*B(SP,GR+1))-4*ML*MN*
31292      &               (A(SP,GR)*B(SP,GR+1)+B(SP,GR)*A(SP,GR+1)))
31293      &           -2*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*SH*
31294      &               C(1,SP,GU)*(UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)
31295      &               /(UH-MSU(GU))
31296               IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2-2*MXS(GR+1)*MXU(GU+1)*
31297      &               (SH-MSL2(GR+1))*SCF(GR+1)*C(1,SP,GU+1)*SH*
31298      &         (UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)/(UH-MSU(GU+1))
31299             ENDIF
31300 C--u channel L/R mixing
31301             IF(ABS(MXU(GU+1)).GT.EPS) ME2 = ME2+MXU(GU+1)**2*(MLS-UH)*
31302      &             (MNS-UH)*(C(1,SP,GU+1)**2+D(1,SP,GU+1)**2)
31303      &             /(UH-MSU(GU+1))**2
31304      &          +2*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
31305      &             (C(1,SP,GU)*C(1,SP,GU+1)+D(1,SP,GU)*D(1,SP,GU+1))
31306      &             /(UH-MSU(GU))/(UH-MSU(GU+1))
31307      &          -2*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*SH*
31308      &             C(1,SP,GU+1)*(UH*A(SP,GR)+B(SP,GR)*ML*MN)
31309      &             /(UH-MSU(GU+1))
31310             MEC(L,GN,J,K) = FAC*ME2*G**2*LAMDA2(I,J,K)**2*PCM*HALF
31311  210        I2 = I1+6
31312             P = L+4
31313             HCS = HCS+MEC(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
31314             IF(GN.GT.3) P = P+2
31315             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,P,0,0,*500)
31316             HCS = HCS+MEC(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
31317             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,P,0,0,*500)
31318             HCS = HCS+MEC(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
31319             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,P,1,0,*500)
31320             HCS = HCS+MEC(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
31321             IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,P,1,0,*500)
31322  220      CONTINUE
31323         ENDDO
31324  230  CONTINUE
31325  240  CONTINUE
31326  300   IF(.NOT.RAD) GOTO 400
31327 C--Radiative decays
31328        IF(GENEV) GOTO 320
31329        DO 310 GN=1,3
31330        I1= 2*GN+5
31331        I = 2*GN-1
31332 C--charged slepton to sneutrino W
31333        IF(SQSH.GT.(MW+MSL(I1))) THEN
31334        PCM = SQRT((SH-(MW+MSL(I1))**2)*(SH-(MW-MSL(I1))**2))*HALF/SQSH
31335        ECM = SQRT(PCM**2+MW2)
31336        TH = MW2-SQSH*(ECM-PCM*COSTH)
31337        UH = MW2-SQSH*(ECM+PCM*COSTH)
31338        ME2 = MXS(I)**4*SCF(I)*SH**2*PCM**2
31339      &       +HALF**2/TH**2*(TWO*MW2*(UH*TH-MSL2(I1)*MW2)+TH**2*SH)
31340      &       -HALF*MXS(I)**2*SH*(SH-MSL2(I))*SCF(I)/TH*
31341      &         (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
31342        IF(GN.EQ.3) ME2 = ME2+MXS(I+1)**4*SCF(I+1)*SH**2*PCM**2
31343      &     +2.0D0*MXS(I)**2*MXS(I+1)**2*SCF(I)*SCF(I+1)*SH**2*PCM**2
31344      &         *((SH-MSL2(I))*(SH-MSL2(I+1))+MSWD(I)*MSWD(I+1))
31345      &         -HALF*MXS(I+1)**2*SH*(SH-MSL2(I+1))*SCF(I+1)/TH*
31346      &         (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
31347        MER(GN) = ME2*PCM/MW2
31348        ENDIF
31349 C--sneutrino to charged slepton W
31350        IF(SQSH.GT.(MW+MSL(I))) THEN
31351        PCM = SQRT((SH-(MW+MSL(I))**2)*(SH-(MW-MSL(I))**2))*HALF/SQSH
31352        ECM = SQRT(PCM**2+MW2)
31353        TH = MW2-SQSH*(ECM-PCM*COSTH)
31354        UH = MW2-SQSH*(ECM+PCM*COSTH)
31355        ME2 = MXS(I)**2*SCF(I1)*SH**2*PCM**2
31356      &       +HALF**2*MXS(I)**2/TH**2*
31357      &                      (TWO*MW2*(UH*TH-MW2*MSL2(I))+TH**2*SH)
31358      &       -HALF*MXS(I)**2*SH*(SH-MSL2(I1))*SCF(I1)/TH*
31359      &        (MW2*(TWO*MSL2(I)-TH)+(SH-MSL2(I))*TH)
31360        MER(GN+4) = ME2*PCM/MW2
31361        ENDIF
31362  310   CONTINUE
31363 C--now the decay stau_2 to stau_1 Z
31364        IF(SQSH.GT.(MZ+MSL(5))) THEN
31365        PCM = SQRT((SH-(MZ+MSL(5))**2)*(SH-(MZ-MSL(5))**2))*HALF/SQSH
31366        ECM = SQRT(PCM**2+MZ2)
31367        TH = MZ2-SQSH*(ECM-PCM*COSTH)
31368        UH = MZ2-SQSH*(ECM+PCM*COSTH)
31369        ME2 = SH**2*PCM**2*(SCF(5)*MXS(5)**2*ZSLP(1)**2
31370      &              +SCF(6)*MXS(6)**2*ZSLP(2)**2+TWO*SCF(5)*SCF(6)*
31371      &              MXS(5)*MXS(6)*ZSLP(1)*ZSLP(2)*((SH-MSL2(5))*
31372      &              (SH-MSL2(6))+MSWD(5)*MSWD(6)))
31373      &      +MXS(5)**2*ZQRK(2)**2/TH**2*
31374      &              (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+TH**2*SH)
31375      &      +MXS(5)**2*ZQRK(1)**2/UH**2*
31376      &              (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+UH**2*SH)
31377      &      +MXS(5)*SH*(MXS(5)*SCF(5)*ZSLP(1)*(SH-MSL2(5))
31378      &              +MXS(6)*SCF(6)*ZSLP(2)*(SH-MSL2(6)))*
31379      &              (-ZQRK(2)/TH*(MZ2*(TWO*MSL2(5)-TH)+TH*(SH-MSL2(5)))
31380      &               +ZQRK(1)/UH*(MZ2*(TWO*MSL2(5)-UH)+UH*(SH-MSL2(5))))
31381      &      +TWO*MXS(5)**2*ZQRK(1)*ZQRK(2)/UH/TH*
31382      &               (TWO*MZ2*(MSL2(5)-UH)*(MSL2(5)-TH)-SH*UH*TH)
31383        MER(4) = TWO*ME2*PCM/MZ2
31384        ENDIF
31385 C--now the decay tau sneutrino to tau_2 W
31386        IF(SQSH.GT.(MW+MSL(6))) THEN
31387        PCM = SQRT((SH-(MW+MSL(6))**2)*(SH-(MW-MSL(6))**2))*HALF/SQSH
31388        ECM = SQRT(PCM**2+MW2)
31389        TH = MW2-SQSH*(ECM-PCM*COSTH)
31390        UH = MW2-SQSH*(ECM+PCM*COSTH)
31391        ME2 = MXS(6)**2*SCF(11)*SH**2*PCM**2
31392      &       +HALF**2*MXS(6)**2/TH**2*
31393      &                      (TWO*MW2*(UH*TH-MW2*MSL2(6))+TH**2*SH)
31394      &       -HALF*MXS(6)**2*SH*(SH-MSL2(11))*SCF(11)/TH*
31395      &        (MW2*(2*MSL2(6)-TH)+(SH-MSL2(6))*TH)
31396        MER(8) = ME2*PCM/MW2
31397        ENDIF
31398 C--Multiply by the parton distributions
31399  320   DO I=1,4
31400         DO J=1,3
31401          DO 330 K=1,3
31402          IF(I.LE.3) THEN
31403            LC = LAMDA2(I,J,K)**2
31404          ELSE
31405            LC = LAMDA2(3,J,K)**2
31406          ENDIF
31407          IF(LC.LT.EPS) GOTO 330
31408          FAC2 = G**2*LC*FAC
31409 C--radiative cross-sections
31410          J1=2*J
31411          K1=2*K+5
31412          ME2 = FAC2*MER(I)
31413          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31414          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I,I,0,0,*500)
31415          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31416          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I,I,0,0,*500)
31417          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31418          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I,I,1,0,*500)
31419          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31420          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I,I,1,0,*500)
31421          J1=2*J-1
31422          K1=2*K+5
31423          ME2 = FAC2*MER(I+4)
31424          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31425          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I+4,I+4,0,0,*500)
31426          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31427          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I+4,I+4,0,0,*500)
31428          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31429          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I+4,I+4,1,0,*500)
31430          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31431          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I+4,I+4,1,0,*500)
31432  330     CONTINUE
31433         ENDDO
31434        ENDDO
31435  400   IF(.NOT.HIGGS) GOTO 500
31436        IF(GENEV) GOTO 480
31437        DO I=1,3
31438           DO 405 J=1,18
31439  405      MEH(I,J) = ZERO
31440        ENDDO
31441 C--Neutral higgs charged slepton
31442        DO 420 L=1,3
31443          DO 410 I=1,2
31444 C--first two generations
31445            IF(SQSH.LT.MH(L)+MSL(2*I)) GOTO 410
31446            PCM = SQRT((SH-(MSL(2*I)+MH(L))**2)*
31447      &                (SH-(MSL(2*I)-MH(L))**2))*HALF/SQSH
31448            MEH(1,3*L-3+I) = PCM*SH*SCF(2*I-1)*H(4*L+I-4)**2
31449  410     CONTINUE
31450 C--third generation
31451          IF(SQSH.LT.MH(L)+MSL(5)) GOTO 420
31452          PCM = SQRT((SH-(MSL(5)+MH(L))**2)*
31453      &              (SH-(MSL(5)-MH(L))**2))*HALF/SQSH
31454          ECM = SQRT(PCM**2+MH(L)**2)
31455          TH = MH(L)**2-SQSH*(ECM-PCM*COSTH)
31456          UH = MH(L)**2-SQSH*(ECM+PCM*COSTH)
31457          MEH(1,3*L) = PCM*SH*(MXS(5)**2*SCF(5)*H(4*L-1)**2
31458      &                 +MXS(6)**2*SCF(6)*H(4*L)**2
31459      &                 +TWO*MXS(5)*MXS(6)*SCF(5)*SCF(6)*H(4*L-1)*
31460      &                 H(4*L)*((SH-MSL2(5))*(SH-MSL2(6))+
31461      &                 MSWD(5)*MSWD(6)) )
31462          ME2        = MXS(5)**2*PCM*(UH*TH-MSL2(5)*MH(L)**2)
31463          MEH(2,3*L) =ME2*GUU(L)/TH**2
31464          MEH(3,3*L) =ME2*GDD(L)/UH**2
31465  420     CONTINUE
31466 C--Charged higgs
31467         DO 440 I=1,3
31468 C--charged slepton charged Higgs
31469           DO 430 J=1,2
31470           IF(SQSH.LT.(MH(4)+MSL(2*I-2+J))) GOTO 430
31471           PCM = SQRT((SH-(MH(4)+MSL(2*I-2+J))**2)*
31472      &               (SH-(MH(4)-MSL(2*I-2+J))**2))*HALF/SQSH
31473           ECM = SQRT(PCM**2+MH(4)**2)
31474           TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
31475           UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
31476           MEH(1,2*I+J+7) = PCM*SH*HALF/MW2*H(2*I+J+10)**2*SCF(5+2*I)
31477           MEH(2,2*I+J+7) = PCM*GDD(4)*MXS(2*I-2+J)**2*
31478      &                      (UH*TH-MH(4)**2*MSL2(2*I-2+J))/TH**2
31479  430      CONTINUE
31480 C--Sneutrino Charged Higgs
31481           IF(SQSH.LT.(MH(4)+MSL(2*I+5))) GOTO 440
31482           PCM = SQRT((SH-(MH(4)+MSL(2*I+5))**2)*
31483      &               (SH-(MH(4)-MSL(2*I+5))**2))*HALF/SQSH
31484           ECM = SQRT(PCM**2+MH(4)**2)
31485           TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
31486           UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
31487           MEH(1,15+I) = PCM*SH*HALF/MW2*(
31488      &                MXS(2*I-1)**2*SCF(2*I-1)*H(11+2*I)**2
31489      &               +MXS(2*I)**2*SCF(2*I)*H(12+2*I)**2
31490      &               +TWO*MXS(2*I-1)*MXS(2*I)*SCF(2*I-1)*
31491      &                SCF(2*I)*H(11+2*I)*H(12+2*I)*
31492      &             ((SH-MSL2(2*I-1))*(SH-MSL2(2*I))+
31493      &              MSWD(2*I-1)*MSWD(2*I)))
31494           MEH(2,15+I) = PCM*GUU(4)*
31495      &                    (UH*TH-MH(4)**2*MSL2(2*I+5))/TH**2
31496  440    CONTINUE
31497 C--Multiply by the parton distributions
31498  480    DO I=1,3
31499         DO J=1,3
31500          DO 490 K=1,3
31501          IF(LAMDA2(I,J,K).LT.EPS) GOTO 490
31502 C--Higgs cross-sections
31503          J1=2*J
31504          K1=2*K+5
31505          FAC2 = G**2*LAMDA2(I,J,K)**2*FAC*HALF
31506          DO L=1,3
31507          ME2 = FAC2*(MEH(1,3*L-3+I)+RMASS(J1)**2*MEH(2,3*L-3+I)
31508      &            +RMASS(K1)**2*MEH(3,3*L-3+I))
31509          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31510          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,I,L,0,0,*500)
31511          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31512          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,I,L,0,0,*500)
31513          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31514          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,I,L,1,0,*500)
31515          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31516          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,I,L,1,0,*500)
31517          ENDDO
31518          ME2 = FAC2*(MEH(1,15+I)+RMASS(J1)**2*MEH(2,15+I))
31519          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31520          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,9+I,4,0,0,*500)
31521          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31522          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,9+I,4,0,0,*500)
31523          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31524          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,9+I,5,1,0,*500)
31525          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31526          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,9+I,5,1,0,*500)
31527          J1=2*J-1
31528          K1=2*K+5
31529          DO L=2,3
31530          ME2 = FAC2*(MEH(1,2*I+L+6)+RMASS(J1)**2*MEH(2,2*I+L+6))
31531          HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
31532          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,2*I+L,5,0,0,*500)
31533          HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
31534          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,2*I+L,5,0,0,*500)
31535          HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
31536          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,2*I+L,4,1,0,*500)
31537          HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
31538          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,2*I+L,4,1,0,*500)
31539          ENDDO
31540  490     CONTINUE
31541         ENDDO
31542        ENDDO
31543 C--Setup to generate the event
31544  500  IF(GENEV) THEN
31545         CALL HWETWO(.TRUE.,.TRUE.)
31546       ELSE
31547         EVWGT = HCS
31548       ENDIF
31549  999  END
31550 CDECK  ID>, HWHRSP.
31551 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
31552 *-- Author :    Peter Richardson
31553 C-----------------------------------------------------------------------
31554       SUBROUTINE HWHRSP
31555 C-----------------------------------------------------------------------
31556 C     Subroutine for all hadron-hadron Rparity violating processes
31557 C-----------------------------------------------------------------------
31558       INCLUDE 'HERWIG65.INC'
31559       IF(MOD(IPROC,10000).GE.4000.AND.MOD(IPROC,10000).LT.4060) THEN
31560 C--SINGLE SPARTICLE VIA LQD
31561         CALL HWHRLS
31562       ELSEIF(MOD(IPROC,10000).GE.4060.AND.MOD(IPROC,10000).LT.4100) THEN
31563 C--RESONANT SLEPTONS TO STANDARD MODEL VIA LQD
31564         CALL HWHRLL
31565       ELSEIF(MOD(IPROC,10000).GE.4100.AND.MOD(IPROC,10000).LT.4160) THEN
31566 C--SINGLE SPARTICLE VIA UDD
31567         CALL HWHRBS
31568 C--RESONANT SQUARKS TO STANDARD MODEL VIA UDD
31569       ELSEIF(MOD(IPROC,10000).EQ.4160) THEN
31570         CALL HWHRBB
31571       ELSE
31572 C--UNKNOWN PROCESS
31573         CALL HWWARN('HWHRSP',500,*999)
31574       ENDIF
31575  999  END
31576 CDECK  ID>, HWHRSS.
31577 *CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
31578 *-- Author :    Peter Richardson
31579 C-----------------------------------------------------------------------
31580       SUBROUTINE HWHRSS(TYPE,ID1,ID2,ID3,ID4,R4,IPERM,*)
31581 C-----------------------------------------------------------------------
31582 C     IDENTIDY HARD R-PARITY VIOLATING PROCESS
31583 C-----------------------------------------------------------------------
31584       INCLUDE 'HERWIG65.INC'
31585       INTEGER ID3, ID4, R4, IPERM,TYPE,ID1,ID2,NEUTD1(8),SLEPID(8),
31586      &        NEUTD2(13),SQUID(6),SGN,HWUANT,SQUID2(12),SLPID2(12),
31587      &        GAGID1(6),GAGID2(8)
31588       EXTERNAL HWUANT
31589       DATA NEUTD1 /450,451,452,453,454,455,456,457/
31590       DATA NEUTD2 /449,449,449,450,451,452,453,454,455,456,457,454,455/
31591       DATA SLEPID /432,434,436,435,431,433,435,447/
31592       DATA SQUID  /411,423,412,412,424,411/
31593       DATA SQUID2 /407,419,409,421,411,423,408,420,410,422,412,424/
31594       DATA SLPID2 /443,445,435,431,443,433,445,435,447,432,434,436/
31595       DATA GAGID1 /199,199,200,198,198,200/
31596       DATA GAGID2 /198,198,198,200,199,199,199,199/
31597       IDCMF = 15
31598       IF(IPERM.EQ.0) THEN
31599         ICO(1) = 2
31600         ICO(2) = 1
31601         ICO(3) = 3
31602         ICO(4) = 4
31603       ELSEIF(IPERM.EQ.1) THEN
31604         ICO(1) = 2
31605         ICO(2) = 1
31606         ICO(3) = 4
31607         ICO(4) = 3
31608       ELSEIF(IPERM.EQ.2) THEN
31609         ICO(1) = 3
31610         ICO(2) = 4
31611         ICO(3) = 1
31612         ICO(4) = 2
31613       ELSE
31614         CALL HWWARN('HWHRSS',100,*999)
31615       ENDIF
31616       IF(TYPE.LE.8) THEN
31617         IDN(1) = ID1+R4*6
31618         IDN(2) = ID2+R4*6
31619       ELSE
31620         SGN = 1
31621         IF(MOD(TYPE,2).EQ.0) SGN = -1
31622         IDN(1) = ID1+R4*6*SGN
31623         IDN(2) = ID2-R4*6*SGN
31624       ENDIF
31625       IF(TYPE.LE.2) THEN
31626         IDN(3) = ID3+6*R4
31627         IDN(4) = ID4+6*R4
31628       ELSEIF(TYPE.GE.3.AND.TYPE.LE.4) THEN
31629         IDN(3) = ID3-R4*6
31630         IDN(4) = NEUTD2(ID4)
31631       ELSEIF(TYPE.GE.5.AND.TYPE.LE.6) THEN
31632         IDN(3) = GAGID1(ID3)
31633         IDN(4) = SQUID(ID4)-R4*6
31634         IF(R4.EQ.1) IDN(3) = HWUANT(IDN(3))
31635       ELSEIF(TYPE.GE.7.AND.TYPE.LE.8) THEN
31636         IDN(3) =202+ID3
31637         IDN(4) =  SQUID2(ID4)-R4*6
31638       ELSEIF(TYPE.GE.9.AND.TYPE.LE.10) THEN
31639         IDN(3) = ID3+6*R4
31640         IDN(4) = ID4-6*R4
31641         IF(IPERM.EQ.2.AND.TYPE.EQ.10) THEN
31642           SGN=IDN(3)
31643           IDN(3) = IDN(4)
31644           IDN(4) = SGN
31645         ENDIF
31646       ELSEIF(TYPE.GE.11.AND.TYPE.LE.12) THEN
31647         IDN(3) = 120+ID3-R4*6
31648         IDN(4) = NEUTD1(ID4)
31649         IF(R4.EQ.1) IDN(4) = HWUANT(IDN(4))
31650       ELSEIF(TYPE.GE.13.AND.TYPE.LE.14) THEN
31651         IDN(3) = SLEPID(ID3)-R4*6
31652         IDN(4) = GAGID2(ID4)
31653         IF(R4.NE.0) IDN(4) = HWUANT(IDN(4))
31654       ELSEIF(TYPE.GE.15.AND.TYPE.LE.16) THEN
31655         IDN(3) = SLPID2(ID3)-R4*6
31656         IDN(4) = 202+ID4
31657       ENDIF
31658       IF(MOD(TYPE,2).EQ.0.AND.TYPE.NE.8) COSTH=-COSTH
31659       RETURN 1
31660  999  END
31661 CDECK  ID>, HWHSCT.
31662 *CMZ :-        -18/03/04  18.42.43  by  Mike Seymour
31663 *-- Author :    Mike Seymour
31664 C-----------------------------------------------------------------------
31665       SUBROUTINE HWHSCT(REPORT,FIRSTC,JMUEO,PTJIM)
31666 C-----------------------------------------------------------------------
31667 C     RELABEL THE EVENT RECORD FOR EXTRA HARD SCATTERING,
31668 C     DO THE SCATTERING, PARTON SHOWER IT, AND CLEAN UP THE EVENT RECORD
31669 C     REPORT RETURNS THE OUTCOME:
31670 C     0 = SUCCESSFUL
31671 C     1 = FAILED DUE TO ERROR IN HARD SCATTERING GENERATION
31672 C     2 = FAILED DUE TO ENERGY CONSERVATION IN HARD SCATTERING
31673 C     3 = FAILED DUE TO ERROR IN PARTON EVOLUTION
31674 C     4 = FAILED DUE TO ENERGY CONSERVATION IN PARTON EVOLUTION
31675 C     5 = COMPLETELY FAILED (IERROR IS ALSO NON-ZERO TO CANCEL EVENT)
31676 C     FIRSTC IS AN INPUT FLAG THAT SAYS THAT THIS IS THE FIRST CALL
31677 C     OF THE EVENT
31678 C     JMUEO IS THE UNDERLYING EVENT OPTION: 1=>VETO EVENTS WITH M
31679 C     SCATTERS ABOVE PTMIN WITH PROBABILITY 1/M
31680 C     PTJIM IS THE MINIMUM TRANSVERSE MOMENTUM FOR ADDITIONAL SCATTERS
31681 C-----------------------------------------------------------------------
31682       INCLUDE 'HERWIG65.INC'
31683       DOUBLE PRECISION HWRGEN,HWRGET,HWRSET,WGT,PBOOST(5),RBOOST(3,3),
31684      $     WJMAX,PT,PTJIM,DUMMY,HWUPCM
31685       INTEGER IHEP,IBM,ITG,IBMN,ITGN,IBMT,ITGT,I,REPORT,NHARD,
31686      $     MYRN(2),TMPRN,JMUEO
31687       LOGICAL COL,FIRSTC,TMPFLG
31688       INTEGER IPRTMP
31689       DATA WJMAX,MYRN,NHARD/0,004122,7679781,0/
31690       EXTERNAL HWRGEN,HWRGET,HWRSET,HWUPCM
31691       COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
31692       REPORT=5
31693       IF (IERROR.NE.0) RETURN
31694 C---RESET THE COUNTER FOR HARD SCATTERS ON THE FIRST CALL
31695       IF (FIRSTC) NHARD=0
31696 C---FIND BEAM AND TARGET REMNANTS
31697       CALL HWHREM(IBM,ITG)
31698       IF (IERROR.NE.0) RETURN
31699 C---RECALCULATE THEIR MASS CORRECTLY
31700       CALL HWUMAS(PHEP(1,IBM))
31701       CALL HWUMAS(PHEP(1,ITG))
31702 C---SET UP NEW ENTRIES IN THE EVENT RECORD
31703       NHEP=NHEP+1
31704       CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,NHEP))
31705       ISTHEP(NHEP)=3
31706       IBMN=NHEP
31707       IBMT=JDAHEP(1,1)
31708       IF (IBMT.EQ.0) THEN
31709         JMOHEP(1,NHEP)=1
31710         IDHW(NHEP)=72
31711       ELSE
31712         JMOHEP(1,NHEP)=IBMT
31713         IDHW(NHEP)=71
31714       ENDIF
31715       JMOHEP(2,NHEP)=0
31716       JDAHEP(1,NHEP)=0
31717       JDAHEP(2,NHEP)=0
31718       IDHEP(NHEP)=IDPDG(IDHW(NHEP))
31719       NHEP=NHEP+1
31720       CALL HWVEQU(5,PHEP(1,ITG),PHEP(1,NHEP))
31721       ISTHEP(NHEP)=3
31722       ITGN=NHEP
31723       ITGT=JDAHEP(1,2)
31724       IF (ITGT.EQ.0) THEN
31725         JMOHEP(1,NHEP)=2
31726         IDHW(NHEP)=72
31727       ELSE
31728         JMOHEP(1,NHEP)=ITGT
31729         IDHW(NHEP)=71
31730       ENDIF
31731       JMOHEP(2,NHEP)=0
31732       JDAHEP(1,NHEP)=0
31733       JDAHEP(2,NHEP)=0
31734       IDHEP(NHEP)=IDPDG(IDHW(NHEP))
31735 C---BOOST TO THEIR CENTRE-OF-MASS FRAME
31736       CALL HWVSUM(4,PHEP(1,IBMN),PHEP(1,ITGN),PBOOST)
31737       CALL HWUMAS(PBOOST)
31738       DO 100 IHEP=IBMN,NHEP
31739         CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
31740  100  CONTINUE
31741       CALL HWUROT(PHEP(1,IBMN),ONE,ZERO,RBOOST)
31742       DO 110 IHEP=IBMN,NHEP
31743         CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
31744  110  CONTINUE
31745 C---PERFORM A SEARCH FOR THE MAXIMUM WEIGHT, IF IT IS NOT YET FOUND
31746       IF (WJMAX.EQ.0) THEN
31747 C---USING LOCAL RANDOM NUMBER SEEDS
31748         DUMMY=HWRGET(TMPRN)
31749         DUMMY=HWRSET(MYRN)
31750         GENEV=.FALSE.
31751         DO I=1,IBSH
31752           CALL HWHSCU(WGT,PTJIM)
31753           WJMAX=MAX(WJMAX,WGT)
31754         ENDDO
31755         WRITE (6,'(A,G12.4)') ' Jimmy search for maximum weight=',WJMAX
31756         DUMMY=HWRGET(MYRN)
31757         DUMMY=HWRSET(TMPRN)
31758 C---BECAUSE OF THE ENERGY DEPENDENCE, LEAVE LOTS OF SAFETY MARGIN
31759         WJMAX=WJMAX*2
31760       ENDIF
31761 C---GENERATE A NEW HARD SCATTERING
31762  5    GENEV=.FALSE.
31763  10   CALL HWHSCU(WGT,PTJIM)
31764       IF (WGT.GT.WJMAX) THEN
31765         WRITE (6,'(A,G12.4/A,G12.4,A,G12.4)')
31766      $       ' Jimmy maximum weight exceeded!  SQRT(S)=',PHEP(5,3),
31767      $       ' Increasing from ',WJMAX,' to ',WGT*2
31768         WJMAX=WGT*2
31769       ENDIF
31770       IF (WGT.LE.WJMAX*HWRGEN(0)) GOTO 10
31771       GENEV=.TRUE.
31772       CALL HWHSCU(WGT,PTJIM)
31773 C---IF ADDING LOW PT SCATTERS TO HIGH PT EVENTS ADD AN EXTRA VETO ON
31774 C   SCATTERS THAT HAPPEN TO BE HIGH PT
31775       TMPFLG=.FALSE.
31776       IF (JMUEO.EQ.1) THEN
31777 C---FIRST RECONSTRUCT THE PT THAT WAS GENERATED IN THE SCATTERING
31778         PT=SQRT(PHEP(1,NHEP)**2+PHEP(2,NHEP)**2)*
31779      $       SQRT(XX(1)*XX(2))*PHEP(5,3)
31780      $       /(2*HWUPCM(PHEP(5,NHEP-2),PHEP(5,NHEP-1),PHEP(5,NHEP)))
31781 C---IF IT IS ABOVE THE TRIGGER THRESHOLD APPLY THE VETO
31782         IF (PT.GT.PTMIN) THEN
31783           IF ((NHARD+2)*HWRGEN(1).LT.1) THEN
31784             NHEP=IBMN-1
31785             GOTO 5
31786           ENDIF
31787           TMPFLG=.TRUE.
31788         ENDIF
31789       ENDIF
31790 C---IF MOMENTUM CANNOT BE CONSERVED, STOP GENERATING HARD SCATTERS
31791       IF (  PHEP(4,IBMN+2) .GT. PHEP(4,IBMN).OR.
31792      $      PHEP(4,ITGN+2) .GT. PHEP(4,ITGN).OR.
31793      $      PHEP(3,IBMN+2) .GT. PHEP(3,IBMN).OR.
31794      $     -PHEP(3,ITGN+2) .GT.-PHEP(3,ITGN).OR.IERROR.NE.0) THEN
31795         IF (IERROR.GT.0) THEN
31796           WRITE (6,'(A/A)')
31797      $       ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
31798      $       ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
31799           REPORT=1
31800         ELSE
31801           REPORT=2
31802         ENDIF
31803         NHEP=IBMN-1
31804         IERROR=0
31805         RETURN
31806       ENDIF
31807 C---RELABEL OUTGOING REMNANTS AS INCOMING HADRONS
31808       JDAHEP(1,1)=IBMN
31809       JDAHEP(1,2)=ITGN
31810 C---EVOLVE THEM
31811       ISLENT=-1
31812 C---SAVE THE CURRENT PROCESS TYPE, AND SWITCH TO
31813 C   QCD SCATTERING TO AVOID PROBLEMS WITH THE
31814 C   PARTON SHOWER.
31815       IPRTMP=IPRO
31816       IPRO=15
31817       CALL HWBGEN
31818       IPRO=IPRTMP
31819       ISLENT=1
31820 C---PUT THE LABELS BACK
31821       JDAHEP(1,1)=IBMT
31822       JDAHEP(1,2)=ITGT
31823 C---IF THERE WERE ANY PROBLEMS, STOP GENERATING HARD SCATTERS
31824       IF (IERROR.NE.0) THEN
31825         IF (IERROR.GT.0) THEN
31826           WRITE (6,'(A/A)')
31827      $       ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
31828      $       ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
31829           REPORT=3
31830         ELSE
31831           REPORT=4
31832         ENDIF
31833         NHEP=IBMN-1
31834         IERROR=0
31835         RETURN
31836       ENDIF
31837 C---UNDO THE LORENTZ BOOST
31838       DO 200 IHEP=IBMN,NHEP
31839         CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
31840         CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
31841  200  CONTINUE
31842 C---FIND THE NEW BEAM AND TARGET REMNANTS
31843       ISTHEP(IBM)=3
31844       ISTHEP(ITG)=3
31845       CALL HWHREM(IBMN,ITGN)
31846       IF (IERROR.NE.0) RETURN
31847 C---CONNECT UP THE COLOUR/FLAVOUR LINES OF THE TWO SCATTERS
31848       IDHW(IBMN)=IDHW(IBM)
31849       IDHEP(IBMN)=IDHEP(IBM)
31850       IF (COL(IDHW(IBM))) THEN
31851         JMOHEP(2,JDAHEP(2,IBMN))=JMOHEP(2,IBM)
31852         JDAHEP(2,JMOHEP(2,IBM))=JDAHEP(2,IBMN)
31853         JDAHEP(2,IBMN)=JDAHEP(2,IBM)
31854         JMOHEP(2,JDAHEP(2,IBM))=IBMN
31855       ELSE
31856         JDAHEP(2,JMOHEP(2,IBMN))=JDAHEP(2,IBM)
31857         JMOHEP(2,JDAHEP(2,IBM))=JMOHEP(2,IBMN)
31858         JMOHEP(2,IBMN)=JMOHEP(2,IBM)
31859         JDAHEP(2,JMOHEP(2,IBM))=IBMN
31860       ENDIF
31861       JMOHEP(2,IBM)=0
31862       JDAHEP(1,IBM)=IBMN
31863       JDAHEP(2,IBM)=0
31864       IDHW(ITGN)=IDHW(ITG)
31865       IDHEP(ITGN)=IDHEP(ITG)
31866       IF (COL(IDHW(ITG))) THEN
31867         JMOHEP(2,JDAHEP(2,ITGN))=JMOHEP(2,ITG)
31868         JDAHEP(2,JMOHEP(2,ITG))=JDAHEP(2,ITGN)
31869         JDAHEP(2,ITGN)=JDAHEP(2,ITG)
31870         JMOHEP(2,JDAHEP(2,ITG))=ITGN
31871       ELSE
31872         JDAHEP(2,JMOHEP(2,ITGN))=JDAHEP(2,ITG)
31873         JMOHEP(2,JDAHEP(2,ITG))=JMOHEP(2,ITGN)
31874         JMOHEP(2,ITGN)=JMOHEP(2,ITG)
31875         JDAHEP(2,JMOHEP(2,ITG))=ITGN
31876       ENDIF
31877       JMOHEP(2,ITG)=0
31878       JDAHEP(1,ITG)=ITGN
31879       JDAHEP(2,ITG)=0
31880 C---LOOK FOR COLOUR SINGLET GLUONS (A RARE BUT ANNOYING SPECIAL CASE)
31881       DO 20 IHEP=1,NHEP
31882         IF (IDHW(IHEP).EQ.13.AND.JMOHEP(2,IHEP).EQ.IHEP)
31883      $       CALL HWWARN('HWHSCT',120,*999)
31884  20   CONTINUE
31885       REPORT=0
31886       IF (TMPFLG) NHARD=NHARD+1
31887  999  END
31888 CDECK  ID>, HWHSCU
31889 *CMZ :-        -17/03/04  14.37.43  by  Mike Seymour
31890 *-- Author :    Mike Seymour
31891 C-----------------------------------------------------------------------
31892       SUBROUTINE HWHSCU(WGT,PTJIM)
31893 C-----------------------------------------------------------------------
31894 C     SWAP THE HARD PROCESS GENERATION PARAMETERS,
31895 C     CALL HWHQCD, AND SWAP BACK
31896 C     WGT IS THE OUTPUT EVENT WEIGHT
31897 C-----------------------------------------------------------------------
31898       INCLUDE 'HERWIG65.INC'
31899       DOUBLE PRECISION WGT,PTJIM,XMIN,XMAX,XPOW,
31900      $     TMPXMN,TMPXMX,TMPXPW,TMPWGT
31901       LOGICAL FIRST
31902       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
31903 C---STORE THE CURRENT VALUES
31904       TMPWGT=EVWGT
31905       TMPXMN=XMIN
31906       TMPXMX=XMAX
31907       TMPXPW=XPOW
31908 C---REPLACE BY NEW ONES
31909       XMIN=2*PTJIM
31910       XMAX=2*SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
31911       XPOW=-4D0
31912 C---AND ENSURE THAT HWRPOW GETS REINITIALIZED
31913       FIRST=.TRUE.
31914 C---GENERATE A PHASE SPACE POINT
31915       CALL HWHQCD
31916       IF (IERROR.NE.0.OR.EVWGT.LT.0) THEN
31917         IERROR=0
31918         EVWGT=0
31919       ENDIF
31920       WGT=EVWGT
31921 C---PUT THE OLD VALUES BACK
31922       EVWGT=TMPWGT
31923       XMIN=TMPXMN
31924       XMAX=TMPXMX
31925       XPOW=TMPXPW
31926 C---AND AGAIN ENSURE THAT HWRPOW GETS REINITIALIZED
31927       FIRST=.TRUE.
31928 C---INCLUDE GAMWT HERE
31929       WGT=WGT*GAMWT
31930       END
31931 CDECK  ID>, HWHSNG.
31932 *CMZ :-        -20/09/95  14.59.15  by  Mike Seymour
31933 *-- Author :    Mike Seymour
31934 C-----------------------------------------------------------------------
31935       SUBROUTINE HWHSNG
31936 C     PARTON-PARTON SCATTERING VIA COLOUR SINGLET
31937 C     MEAN EVWGT = SIGMA IN NB
31938 C     TREATS ALL PARTONS ON EQUAL FOOTING WITH HWHSNM(ID1,ID2,S,T)
31939 C     PROVIDING THE MATRIX ELEMENT SQUARED FOR PARTON TYPES ID1 AND ID2
31940 C-----------------------------------------------------------------------
31941       INCLUDE 'HERWIG65.INC'
31942       INTEGER ID1,ID2
31943       DOUBLE PRECISION HWRGEN,HWRUNI,HWHSNM,EPS,RCS,ET,EJ,KK,KK2,
31944      & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,S,T,U,HCS
31945       SAVE HCS,FACT,S,T
31946       PARAMETER (EPS=1.D-9)
31947       IF (GENEV) THEN
31948         RCS=HCS*HWRGEN(0)
31949       ELSE
31950         EVWGT=0.
31951         CALL HWRPOW(ET,EJ)
31952         KK=ET/PHEP(5,3)
31953         KK2=KK**2
31954         IF (KK.GE.ONE) RETURN
31955         YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
31956         YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
31957         IF (YJ1INF.GE.YJ1SUP) RETURN
31958         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
31959         YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
31960         YJ2SUP=MIN( YJMAX ,  LOG(2./KK-Z1) )
31961         IF (YJ2INF.GE.YJ2SUP) RETURN
31962         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
31963         XX(1)=0.5*(Z1+Z2)*KK
31964         IF (XX(1).GE.ONE) RETURN
31965         XX(2)=XX(1)/(Z1*Z2)
31966         IF (XX(2).GE.ONE) RETURN
31967         COSTH=(Z1-Z2)/(Z1+Z2)
31968         S=XX(1)*XX(2)*PHEP(5,3)**2
31969         T=-0.5*S*(1.-COSTH)
31970         U=-S-T
31971 C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
31972         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
31973         FACT=GEV2NB*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
31974      $      /(16*PIFAC*S**2)
31975         CALL HWSGEN(.FALSE.)
31976       ENDIF
31977 C
31978       HCS=0.
31979       DO 20 ID1=1,13
31980         IF (DISF(ID1,1).LT.EPS) GOTO 20
31981         DO 10 ID2=1,13
31982           IF (DISF(ID2,1).LT.EPS) GOTO 10
31983           HCS=HCS+FACT*DISF(ID1,1)*DISF(ID2,2)*HWHSNM(ID1,ID2,S,T)
31984           IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3412,90,*30)
31985  10     CONTINUE
31986  20   CONTINUE
31987       EVWGT=HCS
31988       RETURN
31989 C---GENERATE EVENT
31990  30   IDN(1)=ID1
31991       IDN(2)=ID2
31992       IDCMF=15
31993       CALL HWETWO(.TRUE.,.TRUE.)
31994  999  END
31995 CDECK  ID>, HWHSNM.
31996 *CMZ :-        -20/09/95  15.28.53  by  Mike Seymour
31997 *-- Author :    Mike Seymour
31998 C-----------------------------------------------------------------------
31999       FUNCTION HWHSNM(ID1,ID2,S,T)
32000 C     MATRIX ELEMENT SQUARED FOR COLOUR-SINGLET PARTON-PARTON SCATTERING
32001 C     INCLUDES SPIN AND COLOUR AVERAGES AND SUMS.
32002 C     FOR PHOTON EXCHANGE, INTERFERENCE WITH U-CHANNEL CONTRIBUTION IS
32003 C     INCLUDED FOR IDENTICAL QUARKS AND LIKEWISE S-CHANNEL CONTRIBUTION
32004 C     FOR IDENTICAL QUARK-ANTIQUARK PAIRS.
32005 C-----------------------------------------------------------------------
32006       INCLUDE 'HERWIG65.INC'
32007       DOUBLE PRECISION HWHSNM,HWUAEM,HWUALF,S,T,ASQ,AINU,AINS,Y,SOLD,
32008      $ TOLD,QQ(13,13),ZETA3
32009       INTEGER ID1,ID2
32010       LOGICAL PHOTON
32011 C---ZETA3=RIEMANN ZETA FUNCTION(3)
32012       PARAMETER (ZETA3=1.202056903159594D0)
32013 C---PHOTON=.TRUE. FOR PHOTON EXCHANGE, .FALSE. FOR MUELLER-TANG
32014       PHOTON=MOD(IPROC,100).GE.50
32015       DATA ASQ,AINU,AINS,SOLD,TOLD,QQ/5*0,169*-1/
32016 C---QQ CACHES THE KINEMATIC-INDEPENDENT FACTORS, TO MAKE IT RUN FASTER
32017 C  (BEARING IN MIND THAT THIS ROUTINE IS CALLED 169 TIMES PER EVENT)
32018       IF (QQ(ID1,ID2).LT.ZERO) THEN
32019         IF (PHOTON) THEN
32020           IF (ID1.EQ.13.OR.ID2.EQ.13) THEN
32021             QQ(ID1,ID2)=0
32022           ELSE
32023             QQ(ID1,ID2)=(QFCH(MOD(ID1-1,6)+1)*QFCH(MOD(ID2-1,6)+1))**2
32024      $           *(4*PIFAC)**2
32025           ENDIF
32026         ELSE
32027           IF (ID1.EQ.13.AND.ID2.EQ.13) THEN
32028             QQ(ID1,ID2)=CAFAC**4
32029           ELSEIF (ID1.EQ.13.OR.ID2.EQ.13) THEN
32030             QQ(ID1,ID2)=(CAFAC*CFFAC)**2
32031           ELSE
32032             QQ(ID1,ID2)=CFFAC**4
32033           ENDIF
32034           QQ(ID1,ID2)=QQ(ID1,ID2)*
32035      $         PIFAC**3/(4*(3.5*ASFIXD*CAFAC*ZETA3)**3)
32036      $         *(16*PIFAC)
32037         ENDIF
32038       ENDIF
32039 C---THE KINEMATIC-DEPENDENT PART IS ALSO CACHED
32040       IF (S.NE.SOLD.OR.T.NE.TOLD) THEN
32041         IF (PHOTON) THEN
32042           AINS=HWUAEM(T)**2
32043           ASQ=2*(S**2+(S+T)**2)/T**2*AINS
32044           AINU=-4*S/T*AINS/NCOLO
32045           AINS=4*AINS/NCOLO-AINU
32046         ELSE
32047           Y=LOG(S/(-T))+ONE
32048           ASQ=HWUALF(1,EMSCA)**4*(S/T)**2*EXP(2*OMEGA0*Y)/Y**3
32049           AINU=0
32050           AINS=0
32051         ENDIF
32052       ENDIF
32053 C---THE FINAL ANSWER IS JUST THEIR PRODUCT
32054       IF (ID1.EQ.ID2) THEN
32055         HWHSNM=QQ(ID1,ID2)*(ASQ+AINU)
32056       ELSEIF (ABS(ID1-ID2).EQ.6) THEN
32057         HWHSNM=QQ(ID1,ID2)*(ASQ+AINS)
32058       ELSE
32059         HWHSNM=QQ(ID1,ID2)*ASQ
32060       ENDIF
32061       END
32062 CDECK  ID>, HWHSPN.
32063 *CMZ :-        -01/10/01  19.41.18  by  Peter Richardson
32064 *-- Author :    Peter Richardson
32065 C-----------------------------------------------------------------------
32066       SUBROUTINE HWHSPN
32067 C-----------------------------------------------------------------------
32068 C     Calculates the spin correlations for the hard process
32069 C-----------------------------------------------------------------------
32070       INCLUDE 'HERWIG65.INC'
32071       INTEGER NDIAHD
32072       PARAMETER(NDIAHD=10)
32073       DOUBLE COMPLEX ZI,S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F3(2,2,8),
32074      &     F4(2,2,8),F3M(2,2,8),F4M(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
32075      &     FUP(2,2,8,8),FUM(2,2,8,8),FST(2,2,8)
32076       DOUBLE PRECISION P(5,4),A(2,NDIAHD),B(2,NDIAHD),XMASS,PLAB,
32077      &     PRW,PCM,MS(NDIAHD),MWD(NDIAHD),MR(NDIAHD),HWULDO,EE,
32078      &     PREF(5),EPS,N(3),HWVDOT,PP,PRE,SH,TH,UH,PM(5,4),DIJ(2,2),
32079      &     MA(4),MA2(4),PTMP(5),WGT,WGTB(NCFMAX),WGTC,HWRGEN
32080       INTEGER ICM,IHEP,IST,JHEP,KHEP,ID,LHEP,MHEP,IK,IL,IM,IJ,L1,L2,I,J,
32081      &     IDP(4+NDIAHD),DRTYPE(NDIAHD),NDIA,P1,P2,P3,P4,IFLOW(NDIAHD),
32082      &     ID1,ID2,III,JJJ,KKK,O(2),LLL,MMM
32083       DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
32084      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
32085      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
32086      &     HZZ(2),ZAB(12,2,2),HHB(2,3),HWUAEM
32087       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
32088      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
32089       LOGICAL SPIN,FIRST
32090       EXTERNAL HWUAEM
32091       PARAMETER(ZI=(0.0D0,1.0D0))
32092       COMMON/HWHEWS/S(8,8,2),D(8,8)
32093       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
32094      &     MA2,SH,TH,UH,IDP,DRTYPE
32095       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
32096       DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
32097       DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
32098       DATA O/2,1/
32099       DATA FIRST/.TRUE./
32100       PARAMETER(EPS=1D-20)
32101       EXTERNAL HWULDO,HWVDOT,HWRGEN
32102       SAVE FIRST
32103       IF(IERROR.NE.0) RETURN
32104       IF(FIRST) THEN
32105         CALL HWISPC
32106         FIRST = .FALSE.
32107       ENDIF
32108 C--search the event record for the hard process
32109       DO 1 IHEP=1,NHEP
32110       IST = ISTHEP(IHEP)
32111       IF(IST.EQ.110.OR.IST.EQ.120) THEN
32112         ICM = IHEP
32113         GOTO 2
32114       ENDIF
32115  1    CONTINUE
32116 C--now decide whether or not to perform spin correlation
32117  2    KHEP = JDAHEP(1,ICM)
32118       IK   = IDHW(KHEP)
32119       JHEP = JDAHEP(2,ICM)
32120       IJ   = IDHW(JHEP)
32121       IF(JHEP-KHEP+1.NE.2) CALL HWWARN('HWHSPN',500,*999)
32122       SPIN = .FALSE.
32123       DO 3 IHEP=KHEP,JHEP
32124         ID = IDHW(IHEP)
32125         IF(RSPIN(ID).EQ.0.5D0) SPIN=.TRUE.
32126  3    CONTINUE
32127       IF(.NOT.SPIN) RETURN
32128       IF((RSPIN(IDHW(KHEP)).EQ.ONE.AND.RSPIN(IDHW(JHEP)).EQ.ZERO).OR.
32129      &  (RSPIN(IDHW(KHEP)).EQ.ZERO.AND.RSPIN(IDHW(JHEP)).EQ.ONE)) RETURN
32130       LHEP = JMOHEP(1,ICM)
32131       MHEP = JMOHEP(2,ICM)
32132 C--now identify the hard process
32133 C--SM processes first
32134 C--fermion-antifermion production in lepton-lepton collisions
32135 C--or via Z/gamma in hadron-hadron collisions
32136       IF(IPRO.EQ.1.OR.IPRO.EQ.13) THEN
32137 C--only need spin correlations for top and tau production
32138         IF((IK.EQ.  6.AND.IJ.EQ. 12).OR.(IK.EQ. 12.AND.IJ.EQ.6  ).OR.
32139      &     (IK.EQ.125.AND.IJ.EQ.131).OR.(IK.EQ.131.AND.IJ.EQ.125)) THEN
32140 C--check fermion first and change order if not
32141           IF(IDHEP(LHEP).LT.0) THEN
32142             ID   = LHEP
32143             LHEP = MHEP
32144             MHEP = ID
32145           ENDIF
32146 C--Id's of the incoming and outgoing fermions
32147           IL  = IDHW(LHEP)
32148           ID1 = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
32149           ID2 = IK-6*INT((IK-1)/6)+10*INT((IK-1)/120)
32150 C--couplings for the diagrams
32151 C--first the photon exchange
32152           A(1,1) = -QFCH(ID1)
32153           A(2,1) = -QFCH(ID1)
32154           B(1,1) = -QFCH(ID2)
32155           B(2,1) = -QFCH(ID2)
32156           IDP(5) = 59
32157           DRTYPE(1) = 4
32158 C--then the Z exchange
32159           A(1,2) = -RFCH(ID1)
32160           A(2,2) = -LFCH(ID1)
32161           B(1,2) = -RFCH(ID2)
32162           B(2,2) = -LFCH(ID2)
32163           IDP(6) = 200
32164           DRTYPE(2) = 4
32165 C--setup the colour flow
32166           NDIA = 2
32167           NCFL(1) = 1
32168           SPNCFC(1,1,1) = ONE
32169           IFLOW(1) = 1
32170           IFLOW(2) = 1
32171         ELSE
32172           RETURN
32173         ENDIF
32174 C--fermion-antifermion via s-channel W in hadron-hadron
32175       ELSEIF(IPRO.EQ.14) THEN
32176         IF(IK.EQ.  6.OR.IK.EQ. 12.OR.IJ.EQ.  6.OR.IJ.EQ. 12.OR.
32177      &     IK.EQ.125.OR.IJ.EQ.131.OR.IK.EQ.131.OR.IJ.EQ.125) THEN
32178 C--check fermion first and reorder if not
32179           IF(IDHEP(LHEP).LT.0) THEN
32180             ID   = LHEP
32181             LHEP = MHEP
32182             MHEP = ID
32183           ENDIF
32184 C--couplings for the diagram
32185           A(1,1) = ZERO
32186           A(2,1) =-ORT/SW
32187           B(1,1) = ZERO
32188           B(2,1) =-ORT/SW
32189           IDP(5) = 198
32190           DRTYPE(1) = 4
32191           NDIA = 1
32192           NCFL(1) = 1
32193           SPNCFC(1,1,1) = ONE
32194           IFLOW(1) = 1
32195         ELSE
32196           RETURN
32197         ENDIF
32198 C--top quark production via QCD
32199       ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.17) THEN
32200         IF((IK.EQ.6.AND.IJ.EQ.12).OR.(IK.EQ.12.AND.IJ.EQ.6)) THEN
32201 C--check if the outgoing fermion is first and change order if not
32202           IF(IDHEP(KHEP).LT.0) THEN
32203             ID   = KHEP
32204             KHEP = JHEP
32205             JHEP = ID
32206           ENDIF
32207 C--quark-quark to t tbar
32208           IF(IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
32209 C--first check the incoming fermion is first and change order if not
32210             IF(IDHEP(LHEP).LT.0) THEN
32211               ID   = LHEP
32212               LHEP = MHEP
32213               MHEP = ID
32214             ENDIF
32215             IL   = IDHW(LHEP)
32216 C--couplings for the diagram
32217             A(1,1) =-ONE
32218             A(2,1) =-ONE
32219             B(1,1) =-ONE
32220             B(2,1) =-ONE
32221             IDP(5) = 13
32222             DRTYPE(1) = 4
32223             NDIA = 1
32224 C--setup the colour flow
32225             NCFL(1) = 1
32226             SPNCFC(1,1,1) = TWO/9.0D0
32227             IFLOW(1) = 1
32228 C--gluon-gluon to t tbar
32229           ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13) THEN
32230 C--setup the diagrams
32231             IDP(5) = 12
32232             IDP(6) = 12
32233             IDP(7) = 13
32234             IDP(8) = 13
32235             DRTYPE(1) = 5
32236             DRTYPE(2) = 6
32237             DRTYPE(3) = 7
32238             DRTYPE(4) = 7
32239             NDIA = 4
32240 C--setup the colour flow
32241             NCFL(1) = 2
32242             IFLOW(1) = 1
32243             IFLOW(2) = 2
32244             IFLOW(3) = 1
32245             IFLOW(4) = 2
32246             SPNCFC(1,1,1) = 0.25D0/THREE
32247             SPNCFC(2,2,1) = SPNCFC(1,1,1)
32248             SPNCFC(1,2,1) = ONE/THREE/32.0D0
32249             SPNCFC(2,1,1) = ONE/THREE/32.0D0
32250 C--incorrect initial state
32251           ELSE
32252             CALL HWWARN('HWHSPN',501,*999)
32253           ENDIF
32254 C--don't need spin correlations haven't produced top
32255         ELSE
32256           RETURN
32257         ENDIF
32258 C--single top quark production in hadron collisions
32259       ELSEIF(IPRO.EQ.20) THEN
32260 C--change order if b quark not first and identify incoming particles
32261         IF(ABS(IDHEP(LHEP)).NE.5) THEN
32262           ID   = LHEP
32263           LHEP = MHEP
32264           MHEP = ID
32265         ENDIF
32266         IL  = IDHEP(LHEP)
32267         IM  = IDHEP(MHEP)
32268 C--change order if t quark not first
32269         IF(ABS(IDHEP(KHEP)).NE.6) THEN
32270           ID   = KHEP
32271           KHEP = JHEP
32272           JHEP = ID
32273         ENDIF
32274 C--identify diagram type
32275 C--fermion fermion
32276         IF(IL.GT.0.AND.IM.GT.0) THEN
32277           DRTYPE(1) = 17
32278 C--fermion antifermion
32279         ELSEIF(IL.GT.0.AND.IM.LT.0) THEN
32280           DRTYPE(1) = 18
32281 C--antifermion fermion
32282         ELSEIF(IL.LT.0.AND.IM.GT.0) THEN
32283           DRTYPE(1) = 19
32284 C--antifermion antifermion
32285         ELSEIF(IL.LT.0.AND.IM.LT.0) THEN
32286           DRTYPE(1) = 20
32287 C--incorrect initial state
32288         ELSE
32289           CALL HWWARN('HWHSPN',502,*999)
32290         ENDIF
32291 C--couplings
32292         A(1,1) = ZERO
32293         A(2,1) = -ORT/SW
32294         B(1,1) = ZERO
32295         B(2,1) = -ORT/SW
32296 C--virtual particle etc
32297         IDP(5) = 198
32298         NDIA = 1
32299         NCFL(1) = 1
32300         SPNCFC(1,1,1) = ONE
32301         IFLOW(1) = 1
32302 C--SUSY particle production
32303       ELSEIF(IPRO.EQ.7.OR.IPRO.EQ.30) THEN
32304         IF(MOD(IPROC,10000).GT.3030) RETURN
32305 C--fermion-antifermion to neutralino neutralino
32306         IF(IK.GE.450.AND.IK.LE.453.AND.IJ.GE.450.AND.IJ.LE.453) THEN
32307 C--first check the fermion is first and change order if not
32308           IF(IDHEP(LHEP).LT.0) THEN
32309             ID   = LHEP
32310             LHEP = MHEP
32311             MHEP = ID
32312           ENDIF
32313           IL   = IDHW(LHEP)
32314           IM   = IDHW(MHEP)
32315 C--couplings of the various diagrams
32316           L1     = IK-449
32317           L2     = IJ-449
32318           ID     = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
32319 C--couplings for the Z exchange diagram
32320           A(1,1) = -RFCH(ID)
32321           A(2,1) = -LFCH(ID)
32322           B(2,1) = HALF*(-ZMIXSS(L1,3)*ZMIXSS(L2,3)
32323      &                   +ZMIXSS(L1,4)*ZMIXSS(L2,4))/SW/CW
32324           B(1,1) = -B(2,1)
32325           B(2,1) = B(2,1)*ZSGNSS(L1)*ZSGNSS(L2)
32326           DRTYPE(1) = 1
32327           IDP(5) = 200
32328 C--couplings for the t-channel diagrams
32329           A(1,2) = ZERO
32330           A(2,2) =-RT*SLFCH(ID,L1)
32331           B(1,2) =-RT*SLFCH(ID,L2)
32332           B(2,2) = ZERO
32333           IDP(6) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
32334           A(1,3) =-RT*SRFCH(ID,L1)*ZSGNSS(L1)
32335           A(2,3) = ZERO
32336           B(1,3) = ZERO
32337           B(2,3) =-RT*SRFCH(ID,L2)*ZSGNSS(L2)
32338           IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+412
32339           DRTYPE(2) = 2
32340           DRTYPE(3) = 2
32341 C--couplings for the u-channel diagrams
32342           A(1,4) = ZERO
32343           A(2,4) =-RT*SLFCH(ID,L2)*ZSGNSS(L2)
32344           B(1,4) =-RT*SLFCH(ID,L1)*ZSGNSS(L1)
32345           B(2,4) = ZERO
32346           IDP(8) = IDP(6)
32347           A(1,5) =-RT*SRFCH(ID,L2)
32348           A(2,5) = ZERO
32349           B(1,5) = ZERO
32350           B(2,5) =-RT*SRFCH(ID,L1)
32351           IDP(9) = IDP(7)
32352           DRTYPE(4) = 3
32353           DRTYPE(5) = 3
32354           NDIA=5
32355 C--setup the colour flow
32356           NCFL(1) = 1
32357           SPNCFC(1,1,1) = ONE
32358           IFLOW(1) = 1
32359           IFLOW(2) = 1
32360           IFLOW(3) = 1
32361           IFLOW(4) = 1
32362           IFLOW(5) = 1
32363 C--chargino pair production
32364         ELSEIF(IK.GE.454.AND.IK.LE.457.AND.IJ.GE.454.AND.IJ.LE.457) THEN
32365 C--first check the fermion is first and change order if not
32366           IF(IDHEP(LHEP).LT.0) THEN
32367             ID   = LHEP
32368             LHEP = MHEP
32369             MHEP = ID
32370           ENDIF
32371           IL   = IDHW(LHEP)
32372           IM   = IDHW(MHEP)
32373 C--couplings of the various diagrams
32374           L1     = IK-453-2*INT((IK-454)/2)
32375           L2     = IJ-453-2*INT((IJ-454)/2)
32376           ID     = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
32377 C--couplings for the s-channel photon exchange
32378           A(1,1) = -QFCH(ID)
32379           A(2,1) = -QFCH(ID)
32380           B(1,1) = -DIJ(L1,L2)
32381           B(2,1) = -DIJ(L1,L2)
32382           IDP(5) = 59
32383           DRTYPE(1) = 1
32384 C--couplings for the s-channel Z exchange
32385           A(1,2) = -RFCH(ID)
32386           A(2,2) = -LFCH(ID)
32387           B(1,2) =(-WMXUSS(L1,1)*WMXUSS(L2,1)
32388      &         -HALF*WMXUSS(L1,2)*WMXUSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
32389           B(2,2) =WSGNSS(L1)*WSGNSS(L2)*(-WMXVSS(L1,1)*WMXVSS(L2,1)
32390      &         -HALF*WMXVSS(L1,2)*WMXVSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
32391           IDP(6) = 200
32392           DRTYPE(2) = 1
32393 C--couplings for the t-channel diagram
32394           IF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).EQ.0) THEN
32395             A(1,3)    = ZERO
32396             A(2,3)    =-WMXUSS(L1,1)/SW
32397             B(1,3)    =-WMXUSS(L2,1)/SW
32398             B(2,3)    = ZERO
32399             DRTYPE(3) = 2
32400           ELSEIF(IDHEP(KHEP).LT.0.AND.MOD(IL,2).NE.0) THEN
32401             A(1,3)    =-WMXVSS(L1,1)*WSGNSS(L1)/SW
32402             A(2,3)    = ZERO
32403             B(1,3)    = ZERO
32404             B(2,3)    =-WMXVSS(L2,1)*WSGNSS(L2)/SW
32405             DRTYPE(3) = 2
32406           ELSEIF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).NE.0) THEN
32407             A(1,3)    = ZERO
32408             A(2,3)    =-WMXVSS(L2,1)*WSGNSS(L2)/SW
32409             B(1,3)    =-WMXVSS(L1,1)*WSGNSS(L1)/SW
32410             B(2,3)    = ZERO
32411             DRTYPE(3) = 3
32412           ELSE
32413             A(1,3)    =-WMXUSS(L2,1)/SW
32414             A(2,3)    = ZERO
32415             B(1,3)    = ZERO
32416             B(2,3)    =-WMXUSS(L1,1)/SW
32417             DRTYPE(3) = 3
32418           ENDIF
32419           IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
32420      &             +2*MOD(IL,2)-1
32421           NDIA = 3
32422 C--setup the colour flow
32423           NCFL(1) = 1
32424           SPNCFC(1,1,1) = ONE
32425           IFLOW(1) = 1
32426           IFLOW(2) = 1
32427           IFLOW(3) = 1
32428 C--chargino neutralino production
32429         ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.GE.450.AND.IJ.LE.453).OR.
32430      &       (IJ.GE.454.AND.IJ.LE.457.AND.IK.GE.450.AND.IK.LE.453)) THEN
32431 C--first check the fermion is first and change order if not
32432           IF(IDHEP(LHEP).LT.0) THEN
32433             ID   = LHEP
32434             LHEP = MHEP
32435             MHEP = ID
32436           ENDIF
32437 C--chargino first
32438           IF(IK.GT.453) THEN
32439 C--change order of outgoing particles if negative chargino
32440             IF(IDHEP(KHEP).LT.0) THEN
32441               ID =KHEP
32442               KHEP=JHEP
32443               JHEP=ID
32444             ENDIF
32445             L1 = IK-453-2*INT((IK-454)/2)
32446             L2 = IJ-449
32447 C--chargino second
32448           ELSE
32449             IF(IDHEP(JHEP).GT.0) THEN
32450               ID =KHEP
32451               KHEP=JHEP
32452               JHEP=ID
32453             ENDIF
32454             L1 = IJ-453-2*INT((IJ-454)/2)
32455             L2 = IK-449
32456           ENDIF
32457 C--first the W exchange diagram
32458           A(1,1) = ZERO
32459           A(2,1) =-ORT/SW
32460           B(1,1) =( ORT*ZMXNSS(L2,3)*WMXUSS(L1,2)
32461      &         +ZMXNSS(L2,2)*WMXUSS(L1,1))/SW
32462           B(2,1) =WSGNSS(L1)*ZSGNSS(L2)*(-ORT*ZMXNSS(L2,4)*WMXVSS(L1,2)
32463      &         +ZMXNSS(L2,2)*WMXVSS(L1,1))/SW
32464           IDP(5) = 198
32465           DRTYPE(1) = 1
32466 C--intermediate particles for the t and u channel diagrams
32467           IL = IDHW(LHEP)
32468           IM = IDHW(MHEP)
32469           IDP(6) = IM+394
32470           IDP(7) = IL+406
32471           IF(MOD(IL,2).EQ.0) THEN
32472             A(1,2) = ZERO
32473             A(2,2) =-WMXUSS(L1,1)/SW
32474             B(1,2) =-RT*SLFCH(IM-6,L2)
32475             B(2,2) = ZERO
32476             DRTYPE(2) = 2
32477             A(1,3) = ZERO
32478             A(2,3) =-RT*ZSGNSS(L2)*SLFCH(IL,L2)
32479             B(1,3) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
32480             B(2,3) = ZERO
32481             DRTYPE(3) = 3
32482           ELSE
32483             A(1,2) = ZERO
32484             A(2,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
32485             B(1,2) =-RT*ZSGNSS(L2)*SLFCH(IM-6,L2)
32486             B(2,2) = ZERO
32487             DRTYPE(2) = 3
32488             A(1,3) = ZERO
32489             A(2,3) =-RT*SLFCH(IL,L2)
32490             B(1,3) =-WMXUSS(L1,1)/SW
32491             B(2,3) = ZERO
32492             DRTYPE(3) = 2
32493           ENDIF
32494 C--setup the colour flow
32495           NDIA = 3
32496           NCFL(1) = 1
32497           SPNCFC(1,1,1) = ONE
32498           IFLOW(1) = 1
32499           IFLOW(2) = 1
32500           IFLOW(3) = 1
32501 C--neutralino gluino production
32502         ELSEIF((IK.EQ.449.AND.IJ.GE.450.AND.IJ.LE.453).OR.
32503      &         (IJ.EQ.449.AND.IK.GE.450.AND.IK.LE.453)) THEN
32504 C--first check the fermion is first and change order if not
32505           IF(IDHEP(LHEP).LT.0) THEN
32506             ID   = LHEP
32507             LHEP = MHEP
32508             MHEP = ID
32509           ENDIF
32510 C--check neutralino first and change order if not
32511           IF(IK.EQ.449) THEN
32512             L1 = IJ-449
32513             ID = KHEP
32514             KHEP = JHEP
32515             JHEP = ID
32516           ELSE
32517             L1 = IK-449
32518           ENDIF
32519           IL = IDHW(LHEP)
32520 C--coupling for the diagrams
32521 C--first t-channel squark exchange
32522           IDP(5) = 400+IL
32523           A(1,1) = ZERO
32524           A(2,1) =-RT*SLFCH(IL,L1)
32525           B(1,1) =-RT
32526           B(2,1) = ZERO
32527           DRTYPE(1) = 2
32528           IDP(6) = 412+IL
32529           A(1,2) =-RT*ZSGNSS(L1)*SRFCH(IL,L1)
32530           A(2,2) = ZERO
32531           B(1,2) = ZERO
32532           B(2,2) = RT
32533           DRTYPE(2) = 2
32534 C--then u-channel s squark exchange
32535           IDP(7) = 400+IL
32536           A(1,3) = ZERO
32537           A(2,3) =-RT
32538           B(1,3) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)
32539           B(2,3) = ZERO
32540           DRTYPE(3) = 3
32541           IDP(8) = 412+IL
32542           A(1,4) = RT
32543           A(2,4) = ZERO
32544           B(1,4) = ZERO
32545           B(2,4) =-RT*SRFCH(IL,L1)
32546           DRTYPE(4) = 3
32547 C--colour flow information
32548           NDIA = 4
32549           NCFL(1) = 1
32550           IFLOW(1) = 1
32551           IFLOW(2) = 1
32552           IFLOW(3) = 1
32553           IFLOW(4) = 1
32554           SPNCFC(1,1,1) = ONE
32555 C--chargino gluino production
32556         ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.EQ.449).OR.
32557      &         (IJ.GE.454.AND.IJ.LE.457.AND.IK.EQ.449)) THEN
32558 C--first check the fermion is first and change order if not
32559           IF(IDHEP(LHEP).LT.0) THEN
32560             ID   = LHEP
32561             LHEP = MHEP
32562             MHEP = ID
32563           ENDIF
32564 C--check chargino first and change order if not
32565           IF(IK.EQ.449) THEN
32566             L1 = IJ-453-2*INT((IJ-454)/2)
32567             ID = KHEP
32568             KHEP = JHEP
32569             JHEP = ID
32570           ELSE
32571             L1 = IK-453-2*INT((IK-454)/2)
32572           ENDIF
32573           IL = IDHW(LHEP)
32574           IM = IDHW(MHEP)
32575           IDP(5) = IM+394
32576           IDP(6) = IL+406
32577           IF(MOD(IL,2).EQ.0) THEN
32578             A(1,1) = ZERO
32579             A(2,1) =-WMXUSS(L1,1)/SW
32580             B(1,1) =-RT
32581             B(2,1) = ZERO
32582             DRTYPE(1) = 2
32583             A(1,2) = ZERO
32584             A(2,2) =-RT
32585             B(1,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
32586             B(2,2) = ZERO
32587             DRTYPE(2) = 3
32588           ELSE
32589             A(1,1) = ZERO
32590             A(2,1) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
32591             B(1,1) =-RT
32592             B(2,1) = ZERO
32593             DRTYPE(1) = 2
32594             A(1,2) = ZERO
32595             A(2,2) =-RT
32596             B(1,2) =-WMXUSS(L1,1)/SW
32597             B(2,2) = ZERO
32598             DRTYPE(2) = 3
32599           ENDIF
32600 C--setup the colour flow
32601           NDIA = 2
32602           NCFL(1) = 1
32603           SPNCFC(1,1,1) = ONE
32604           IFLOW(1) = 1
32605           IFLOW(2) = 1
32606 C--quark quark to gluino gluino
32607         ELSEIF(IJ.EQ.449.AND.IK.EQ.449.AND.
32608      &         IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
32609 C--change order if antiquark first
32610           IF(IDHEP(LHEP).LT.0) THEN
32611             ID   = LHEP
32612             LHEP = MHEP
32613             MHEP = ID
32614           ENDIF
32615           IL   = IDHW(LHEP)
32616 C--couplings of the various diagrams
32617           A(1,1) = ZERO
32618           A(2,1) =-RT
32619           B(1,1) =-RT
32620           B(2,1) = ZERO
32621           A(1,2) = RT
32622           A(2,2) = ZERO
32623           B(1,2) = ZERO
32624           B(2,2) = RT
32625           DO 4 I=1,2
32626           A(I,3) = A(I,1)
32627           B(I,3) = B(I,1)
32628           A(I,4) = A(I,2)
32629  4        B(I,4) = B(I,2)
32630           A(1,5) = ONE
32631           A(2,5) = ONE
32632           B(1,5) = ONE
32633           B(2,5) = ONE
32634           A(1,6) =-ONE
32635           A(2,6) =-ONE
32636           B(1,6) = ONE
32637           B(2,6) = ONE
32638 C--intermediate particles
32639           IDP(5) = 400+IL
32640           IDP(6) = 412+IL
32641           IDP(7) = 400+IL
32642           IDP(8) = 412+IL
32643           IDP(9)  = 13
32644           IDP(10) = 13
32645 C--types of diagram
32646           DRTYPE(1) = 2
32647           DRTYPE(2) = 2
32648           DRTYPE(3) = 3
32649           DRTYPE(4) = 3
32650           DRTYPE(5) = 1
32651           DRTYPE(6) = 1
32652           NDIA = 6
32653 C--setup the colour flow
32654           NCFL(1) = 2
32655           SPNCFC(1,1,1) = 8.0D0/27.0D0
32656           SPNCFC(2,2,1) = 8.0D0/27.0D0
32657           SPNCFC(1,2,1) =-ONE/27.0D0
32658           SPNCFC(2,1,1) =-ONE/27.0D0
32659           IFLOW(1) = 1
32660           IFLOW(2) = 1
32661           IFLOW(3) = 2
32662           IFLOW(4) = 2
32663           IFLOW(5) = 1
32664           IFLOW(6) = 2
32665 C--gluon gluon to gluino gluino
32666         ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13.AND.IJ.EQ.449
32667      &         .AND.IK.EQ.449) THEN
32668 C--setup the diagrams
32669           IDP(5) = 449
32670           IDP(6) = 449
32671           IDP(7) = 13
32672           IDP(8) = 13
32673           DRTYPE(1) = 14
32674           DRTYPE(2) = 15
32675           DRTYPE(3) = 16
32676           DRTYPE(4) = 16
32677           NDIA = 4
32678 C--setup the colour flow
32679           NCFL(1) = 2
32680           IFLOW(1) = 1
32681           IFLOW(2) = 2
32682           IFLOW(3) = 1
32683           IFLOW(4) = 2
32684           SPNCFC(1,1,1) = 9.0D0/16.0D0
32685           SPNCFC(2,2,1) = SPNCFC(1,1,1)
32686           SPNCFC(1,2,1) =-9.0D0/32.0D0
32687           SPNCFC(2,1,1) =-9.0D0/32.0D0
32688 C--neutralino squark production
32689         ELSEIF(    (IK.GE.450.AND.IK.LE.453.AND.
32690      &        ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
32691      &        .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
32692      &        ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
32693      &         THEN
32694 C--change order if gluon first
32695           IF(IDHW(LHEP).EQ.13) THEN
32696             ID   = LHEP
32697             LHEP = MHEP
32698             MHEP = ID
32699           ENDIF
32700 C--change order in squark first
32701           IF(IJ.GE.450) THEN
32702             ID = KHEP
32703             KHEP = JHEP
32704             JHEP = ID
32705             IK = IDHW(KHEP)
32706             IJ = IDHW(JHEP)
32707           ENDIF
32708           IL = IDHW(LHEP)
32709           L1 = IK-449
32710 C--left handed (lighter) squark
32711           IF(IJ.LT.412) THEN
32712             A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
32713             A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
32714 C--right handed (heavier) squark
32715           ELSEIF(IJ.GT.412) THEN
32716             A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
32717             A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
32718           ENDIF
32719           DO 5 I=1,2
32720  5        A(I,2) = A(I,1)
32721           IDP(5) = IJ
32722           IDP(6) = IL
32723 C--colour flow info
32724           DRTYPE(1) = 8
32725           DRTYPE(2) = 10
32726           NDIA = 2
32727           NCFL(1) = 1
32728           SPNCFC(1,1,1) = HALF/THREE
32729           IFLOW(1) = 1
32730           IFLOW(2) = 1
32731 C--neutralino antisquark production
32732         ELSEIF(    (IK.GE.450.AND.IK.LE.453.AND.
32733      &        ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
32734      &        .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
32735      &        ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
32736      &         THEN
32737 C--change order if gluon first
32738           IF(IDHW(LHEP).EQ.13) THEN
32739             ID   = LHEP
32740             LHEP = MHEP
32741             MHEP = ID
32742           ENDIF
32743 C--change order in squark first
32744           IF(IJ.GE.450) THEN
32745             ID = KHEP
32746             KHEP = JHEP
32747             JHEP = ID
32748             IK = IDHW(KHEP)
32749             IJ = IDHW(JHEP)
32750           ENDIF
32751           IL = IDHW(LHEP)-6
32752           L1 = IK-449
32753 C--left handed (lighter) squark
32754           IF(IJ.LE.412) THEN
32755             A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
32756             A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
32757 C--right handed (heavier) squark
32758           ELSEIF(IJ.GT.412) THEN
32759             A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
32760             A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
32761           ENDIF
32762           DO 6 I=1,2
32763  6        A(I,2) = A(I,1)
32764           IDP(5) = IJ
32765           IDP(6) = IL
32766 C--colour flow info
32767           DRTYPE(1) = 9
32768           DRTYPE(2) = 11
32769           NDIA = 2
32770           NCFL(1) = 1
32771           SPNCFC(1,1,1) = HALF/THREE
32772           IFLOW(1) = 1
32773           IFLOW(2) = 1
32774 C--chargino squark
32775         ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
32776      &         ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
32777      &         .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
32778      &        ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
32779      &         THEN
32780 C--change order if gluon first
32781           IF(IDHW(LHEP).EQ.13) THEN
32782             ID   = LHEP
32783             LHEP = MHEP
32784             MHEP = ID
32785           ENDIF
32786 C--change order if squark first
32787           IF(IJ.GE.454) THEN
32788             ID = KHEP
32789             KHEP = JHEP
32790             JHEP = ID
32791             IK = IDHW(KHEP)
32792             IJ = IDHW(JHEP)
32793           ENDIF
32794           IL = IDHW(LHEP)
32795           L1 = IK-453-2*INT((IK-454)/2)
32796 C--left handed (lighter) squark
32797           A(1,1) = ZERO
32798           IF(IJ.LE.412) THEN
32799             IF(MOD(IL,2).EQ.0) THEN
32800               A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
32801             ELSE
32802               A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
32803             ENDIF
32804 C--right handed (heavier) squark
32805           ELSEIF(IJ.GT.412) THEN
32806             IF(MOD(IL,2).EQ.0) THEN
32807               A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
32808             ELSE
32809               A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
32810             ENDIF
32811           ENDIF
32812           DO 7 I=1,2
32813  7        A(I,2) = A(I,1)
32814           IDP(5) = IJ
32815           IDP(6) = IL
32816 C--colour flow info
32817           DRTYPE(1) = 8
32818           DRTYPE(2) = 10
32819           NDIA = 2
32820           NCFL(1) = 1
32821           SPNCFC(1,1,1) = HALF/THREE
32822           IFLOW(1) = 1
32823           IFLOW(2) = 1
32824 C--chargino antisquark
32825         ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
32826      &         ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
32827      &         .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
32828      &        ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
32829      &         THEN
32830 C--change order if gluon first
32831           IF(IDHW(LHEP).EQ.13) THEN
32832             ID   = LHEP
32833             LHEP = MHEP
32834             MHEP = ID
32835           ENDIF
32836 C--change order in squark first
32837           IF(IJ.GE.454) THEN
32838             ID = KHEP
32839             KHEP = JHEP
32840             JHEP = ID
32841             IK = IDHW(KHEP)
32842             IJ = IDHW(JHEP)
32843           ENDIF
32844           IL = IDHW(LHEP)-6
32845           L1 = IK-453-2*INT((IK-454)/2)
32846 C--left handed (lighter) squark
32847           A(2,1) = ZERO
32848           IF(IJ.LE.412) THEN
32849             IF(MOD(IL,2).EQ.0) THEN
32850               A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
32851             ELSE
32852               A(1,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
32853             ENDIF
32854 C--right handed (heavier) squark
32855           ELSEIF(IJ.GT.412) THEN
32856             IF(MOD(IL,2).EQ.0) THEN
32857               A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
32858             ELSE
32859               A(1,1) = -WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
32860             ENDIF
32861           ENDIF
32862           DO 8 I=1,2
32863  8        A(I,2) = A(I,1)
32864           IDP(5) = IJ
32865           IDP(6) = IL
32866 C--colour flow info
32867           DRTYPE(1) = 9
32868           DRTYPE(2) = 11
32869           NDIA = 2
32870           NCFL(1) = 1
32871           SPNCFC(1,1,1) = ONE
32872           IFLOW(1) = 1
32873           IFLOW(2) = 1
32874 C--squark gluino production
32875         ELSEIF((IK.EQ.449.AND.((IJ.GE.401.AND.IJ.LE.406)
32876      &                         .OR.(IJ.GE.413.AND.IJ.LE.418)))
32877      &         .OR.(IJ.GE.449.AND.((IK.GE.401.AND.IK.LE.406)
32878      &                         .OR.(IK.GE.413.AND.IK.LE.418)))) THEN
32879 C--change order if gluon first
32880           IF(IDHW(LHEP).EQ.13) THEN
32881             ID   = LHEP
32882             LHEP = MHEP
32883             MHEP = ID
32884           ENDIF
32885           IL = IDHW(LHEP)
32886 C--change order in squark first
32887           IF(IJ.EQ.449) THEN
32888             ID = KHEP
32889             KHEP = JHEP
32890             JHEP = ID
32891             IJ = IDHW(JHEP)
32892           ENDIF
32893           ID = INT((IJ-401)/12)+1
32894           IF(ID.EQ.1) THEN
32895             A(1,1) = ZERO
32896             A(2,1) =-RT
32897           ELSE
32898             A(1,1) = RT
32899             A(2,1) = ZERO
32900           ENDIF
32901           DO 9 I=1,2
32902           A(I,2) =-A(I,1)
32903           A(I,3) = A(I,1)
32904  9        A(I,4) = A(I,1)
32905           DRTYPE(1) = 12
32906           DRTYPE(2) = 12
32907           DRTYPE(3) = 8
32908           DRTYPE(4) = 10
32909           IDP(5) = 449
32910           IDP(6) = 449
32911           IDP(7) = IJ
32912           IDP(8) = IL
32913 C--colour flows
32914           NDIA = 4
32915           NCFL(1) = 2
32916           IFLOW(1) = 1
32917           IFLOW(2) = 2
32918           IFLOW(3) = 1
32919           IFLOW(4) = 2
32920           SPNCFC(1,1,1) = 2.0D0/9.0D0
32921           SPNCFC(2,2,1) = 2.0D0/9.0D0
32922           SPNCFC(1,2,1) = -0.25D0/9.0D0
32923           SPNCFC(2,1,1) = -0.25D0/9.0D0
32924 C--antisquark gluino production
32925         ELSEIF((IK.GE.449..AND.((IJ.GE.407.AND.IJ.LE.412)
32926      &                          .OR.(IJ.GE.419.AND.IJ.LE.424)))
32927      &         .OR.(IJ.GE.449.AND.((IK.GE.407.AND.IK.LE.412)
32928      &                          .OR.(IK.GE.419.AND.IK.LE.424)))) THEN
32929 C--change order if gluon first
32930           IF(IDHW(LHEP).EQ.13) THEN
32931             ID   = LHEP
32932             LHEP = MHEP
32933             MHEP = ID
32934           ENDIF
32935           IL = IDHW(LHEP)
32936 C--change order in squark first
32937           IF(IJ.EQ.449) THEN
32938             ID = KHEP
32939             KHEP = JHEP
32940             JHEP = ID
32941             IJ = IDHW(JHEP)
32942           ENDIF
32943           ID = INT((IJ-401)/12)+1
32944           IF(ID.EQ.1) THEN
32945             A(1,1) =-RT
32946             A(2,1) = ZERO
32947           ELSE
32948             A(1,1) = ZERO
32949             A(2,1) = RT
32950           ENDIF
32951           DO 10 I=1,2
32952           A(I,2) =-A(I,1)
32953           A(I,3) = A(I,1)
32954  10       A(I,4) = A(I,1)
32955           DRTYPE(1) = 13
32956           DRTYPE(2) = 13
32957           DRTYPE(3) = 9
32958           DRTYPE(4) = 11
32959           IDP(5) = 449
32960           IDP(6) = 449
32961           IDP(7) = IJ
32962           IDP(8) = IL
32963 C--colour flows
32964           NDIA = 4
32965           NCFL(1) = 2
32966           IFLOW(1) = 1
32967           IFLOW(2) = 2
32968           IFLOW(3) = 1
32969           IFLOW(4) = 2
32970           SPNCFC(1,1,1) = 2.0D0/9.0D0
32971           SPNCFC(2,2,1) = 2.0D0/9.0D0
32972           SPNCFC(1,2,1) = -0.25D0/9.0D0
32973           SPNCFC(2,1,1) = -0.25D0/9.0D0
32974 C--unrecognised SUSY process
32975         ELSE
32976           CALL HWWARN('HWHSPN',503,*999)
32977         ENDIF
32978 C--LLE processes
32979       ELSEIF(IPRO.EQ.8) THEN
32980 C--neutralino antineutrino production
32981         IF(IK.GE.450.AND.IK.LE.453.AND.
32982      &     IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0) THEN
32983 C--ensure lepton first
32984           IF(IDHEP(LHEP).LT.0) THEN
32985             ID = LHEP
32986             LHEP = MHEP
32987             MHEP = ID
32988           ENDIF
32989 C--RPV indices
32990           III = (IJ-126)/2
32991           JJJ = (IDHW(LHEP)-119)/2
32992           KKK = (IDHW(MHEP)-125)/2
32993           L1  = IK-449
32994           IDP(5) = 424+2*III
32995           DO 11 I=1,2
32996           IDP(5+I) = 423+2*JJJ+(I-1)*12
32997  11       IDP(7+I) = 423+2*KKK+(I-1)*12
32998 C--types of diagram
32999           DRTYPE(1) = 21
33000           DRTYPE(2) = 22
33001           DRTYPE(3) = 22
33002           DRTYPE(4) = 23
33003           DRTYPE(5) = 23
33004 C--RPV couplings
33005           A(1,1) = ZERO
33006           A(2,1) = -LAMDA1(III,JJJ,KKK)
33007           DO 12 I=1,2
33008           B(1,I+1) = ZERO
33009           B(2,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
33010           A(1,I+3) = ZERO
33011  12       A(2,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
33012 C--MSSM couplings
33013           DO 13 J=1,2
33014           B(J,1) = AFN(O(J),2*III+6,1,L1)
33015           DO 13 I=1,2
33016           A(J,I+1) = AFN(O(J),2*JJJ+5,I,L1)
33017  13       B(J,I+3) = AFN(  J ,2*KKK+5,I,L1)
33018 C--colour flows
33019           NDIA = 5
33020           NCFL(1) = 1
33021           DO 14 I=1,5
33022  14       IFLOW(I) = 1
33023           SPNCFC(1,1,1) = ONE
33024 C--neutralino neutrino production
33025         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.
33026      &         IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0) THEN
33027 C--ensure lepton first
33028           IF(IDHEP(LHEP).LT.0) THEN
33029             ID = LHEP
33030             LHEP = MHEP
33031             MHEP = ID
33032           ENDIF
33033 C--RPV indices
33034           III = (IJ-120)/2
33035           JJJ = (IDHW(MHEP)-125)/2
33036           KKK = (IDHW(LHEP)-119)/2
33037           L1  = IK-449
33038           IDP(5) = 424+2*III
33039           DO 15 I=1,2
33040           IDP(5+I) = 423+2*JJJ+(I-1)*12
33041  15       IDP(7+I) = 423+2*KKK+(I-1)*12
33042 C--types of diagram
33043           DRTYPE(1) = 24
33044           DRTYPE(2) = 25
33045           DRTYPE(3) = 25
33046           DRTYPE(4) = 26
33047           DRTYPE(5) = 26
33048 C--RPV couplings
33049           A(1,1) = -LAMDA1(III,JJJ,KKK)
33050           A(2,1) = ZERO
33051           DO 16 I=1,2
33052           B(1,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
33053           B(2,I+1) = ZERO
33054           A(1,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
33055  16       A(2,I+3) = ZERO
33056 C--MSSM couplings
33057           DO 17 J=1,2
33058           B(J,1) = AFN(  J ,2*III+6,1,L1)
33059           DO 17 I=1,2
33060           A(J,I+1) = AFN(  J ,2*JJJ+5,I,L1)
33061  17       B(J,I+3) = AFN(O(J),2*KKK+5,I,L1)
33062 C--colour flows
33063           NDIA = 5
33064           NCFL(1) = 1
33065           DO 18 I=1,5
33066  18       IFLOW(I) = 1
33067           SPNCFC(1,1,1) = ONE
33068 C--chargino antilepton
33069         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.
33070      &         IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
33071 C--ensure lepton first
33072           IF(IDHEP(LHEP).LT.0) THEN
33073             ID = LHEP
33074             LHEP = MHEP
33075             MHEP = ID
33076           ENDIF
33077 C--RPV indices
33078           III = (IJ-125)/2
33079           JJJ = (IDHW(LHEP)-119)/2
33080           KKK = (IDHW(MHEP)-125)/2
33081           L1 = IK-455
33082           IDP(5) = 2*III+424
33083           IDP(6) = 2*JJJ+424
33084 C--RPV couplings
33085           A(1,1) = ZERO
33086           A(2,1) = LAMDA1(III,JJJ,KKK)
33087           B(1,2) = ZERO
33088           B(2,2) =-LAMDA1(III,JJJ,KKK)
33089 C--MSSM couplings
33090           DO 19 J=1,2
33091           B(J,1) = AFC(O(J),2*III+6,1,L1)
33092  19       A(J,2) = AFC(O(J),2*JJJ+6,1,L1)
33093 C--colour flows
33094           DRTYPE(1) = 21
33095           DRTYPE(2) = 22
33096           NDIA = 2
33097           NCFL(1) = 1
33098           DO 20 I=1,2
33099  20       IFLOW(I) = 1
33100           SPNCFC(1,1,1) = ONE
33101 C--chargino lepton
33102         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.
33103      &         IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
33104 C--ensure lepton first
33105           IF(IDHEP(LHEP).LT.0) THEN
33106             ID = LHEP
33107             LHEP = MHEP
33108             MHEP = ID
33109           ENDIF
33110 C--RPV indices
33111           III = (IJ-119)/2
33112           JJJ = (IDHW(MHEP)-125)/2
33113           KKK = (IDHW(LHEP)-119)/2
33114           L1 = IK-453
33115           IDP(5) = 2*III+424
33116           IDP(6) = 2*JJJ+424
33117 C--RPV couplings
33118           A(1,1) = LAMDA1(III,JJJ,KKK)
33119           A(2,1) = ZERO
33120           B(1,2) =-LAMDA1(III,JJJ,KKK)
33121           B(2,2) = ZERO
33122 C--MSSM couplings
33123           DO 21 J=1,2
33124           B(J,1) = AFC(J,2*III+6,1,L1)
33125  21       A(J,2) = AFC(J,2*JJJ+6,1,L1)
33126 C--colour flows
33127           DRTYPE(1) = 24
33128           DRTYPE(2) = 25
33129           NDIA = 2
33130           NCFL(1) = 1
33131           DO 22 I=1,2
33132  22       IFLOW(I) = 1
33133           SPNCFC(1,1,1) = ONE
33134 C--e+e- production
33135         ELSEIF(IK.GE.121.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
33136      &         IJ.GE.121.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
33137 C--ensure incoming lepton first
33138           IF(IDHEP(LHEP).LT.0) THEN
33139             ID = MHEP
33140             MHEP = LHEP
33141             LHEP = ID
33142           ENDIF
33143 C--ensure outgoing lepton first
33144           IF(IDHEP(KHEP).LT.0) THEN
33145             ID = IK
33146             IK = IJ
33147             IJ = ID
33148             ID = KHEP
33149             KHEP = JHEP
33150             JHEP = ID
33151           ENDIF
33152 C--only need the correlations for tau production
33153           IF(IK.NE.125.AND.IJ.NE.131) RETURN
33154 C--find the RPV indices
33155           III = (IDHW(LHEP)-119)/2
33156           KKK = (IK-119)/2
33157           LLL = (IJ-125)/2
33158           NDIA = 0
33159           EE = SQRT(HWUAEM(SH)*FOUR*PIFAC)
33160 C--s-channel photon and Z exchange if needed
33161           IF(KKK.EQ.LLL) THEN
33162             NDIA = 2
33163             ID1 = 9+2*III
33164             ID2 = 9+2*KKK
33165 C--photon first
33166             A(1,1) = -EE*QFCH(ID1)
33167             A(2,1) = -EE*QFCH(ID1)
33168             B(1,1) = -EE*QFCH(ID2)
33169             B(2,1) = -EE*QFCH(ID2)
33170             IDP(5) = 59
33171             DRTYPE(1) = 4
33172 C--then the Z exchange
33173             A(1,2) = -EE*RFCH(ID1)
33174             A(2,2) = -EE*LFCH(ID1)
33175             B(1,2) = -EE*RFCH(ID2)
33176             B(2,2) = -EE*LFCH(ID2)
33177             IDP(6) = 200
33178             DRTYPE(2) = 4
33179           ENDIF
33180           DO 23 JJJ=1,3
33181 C--s-channel sneutrino exchange
33182             IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(LLL,JJJ,KKK)).GT.EPS) THEN
33183               NDIA = NDIA+1
33184               DRTYPE(NDIA) = 21
33185               IDP(NDIA+4) = 424+2*JJJ
33186               A(1,NDIA)   = LAMDA1(III,JJJ,III)
33187               A(2,NDIA)   = ZERO
33188               B(1,NDIA)   = ZERO
33189               B(2,NDIA)   = LAMDA1(LLL,JJJ,KKK)
33190             ENDIF
33191 C--s-channel antisneutrino exchange
33192             IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(KKK,JJJ,LLL)).GT.EPS) THEN
33193               NDIA = NDIA+1
33194               DRTYPE(NDIA) = 21
33195               IDP(NDIA+4)  = 424+2*JJJ
33196               A(1,NDIA)    = ZERO
33197               A(2,NDIA)    = LAMDA1(III,JJJ,III)
33198               B(1,NDIA)    = LAMDA1(KKK,JJJ,LLL)
33199               B(2,NDIA)    = ZERO
33200             ENDIF
33201 C--t-channel sneutrino exchange
33202             IF(ABS(LAMDA1(KKK,JJJ,III)*LAMDA1(LLL,JJJ,III)).GT.EPS) THEN
33203               NDIA = NDIA+1
33204               DRTYPE(NDIA) = 22
33205               IDP(NDIA+4)  = 424+2*JJJ
33206               A(1,NDIA)    = LAMDA1(KKK,JJJ,III)
33207               A(2,NDIA)    = ZERO
33208               B(1,NDIA)    = ZERO
33209               B(2,NDIA)    = LAMDA1(LLL,JJJ,III)
33210             ENDIF
33211 C--t-channel antisneutrino exchange
33212             IF(ABS(LAMDA1(III,JJJ,KKK)*LAMDA1(III,JJJ,LLL)).GT.EPS) THEN
33213               NDIA = NDIA+1
33214               DRTYPE(NDIA) = 22
33215               IDP(NDIA+4)  = 424+2*JJJ
33216               A(1,NDIA)    = ZERO
33217               A(2,NDIA)    = LAMDA1(III,JJJ,KKK)
33218               B(1,NDIA)    = LAMDA1(III,JJJ,LLL)
33219               B(2,NDIA)    = ZERO
33220             ENDIF
33221  23       CONTINUE
33222 C--setup the colour flow
33223           NCFL(1) = 1
33224           SPNCFC(1,1,1) = ONE
33225           DO 24 I=1,NDIA
33226  24       IFLOW(I) = 1
33227 C--d dbar production
33228         ELSEIF(IK.LE.12.AND.IK.LE.12.AND.
33229      &         MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
33230 C--can't produce quark which decays before hadronization
33231           RETURN
33232 C--unrecognised process
33233         ELSE
33234           CALL HWWARN('HWHSPN',504,*999)
33235         ENDIF
33236 C--LQD processes
33237       ELSEIF(IPRO.EQ.40) THEN
33238 C--change outgoing order
33239         ID = IJ
33240         IJ = IK
33241         IK = ID
33242         ID = JHEP
33243         JHEP = KHEP
33244         KHEP = ID
33245 C--neutrino neutralino production
33246         IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
33247      &     IDPDG(IJ).GT.0) THEN
33248 C--change order if antiparticle first
33249           IF(IDHEP(LHEP).LT.0) THEN
33250             ID   = LHEP
33251             LHEP = MHEP
33252             MHEP = ID
33253           ENDIF
33254 C--indices for RPV coupling
33255           III = (IJ-120)/2
33256           JJJ = (IDHW(MHEP)-5)/2
33257           KKK = (IDHW(LHEP)+1)/2
33258           L1  = IK - 449
33259           IDP(5) = 424+2*III
33260           DO 25 I=1,2
33261           IDP(5+I) = 399+2*JJJ+(I-1)*12
33262  25       IDP(7+I) = 399+2*KKK+(I-1)*12
33263 C--types of diagram
33264           DRTYPE(1) = 24
33265           DRTYPE(2) = 25
33266           DRTYPE(3) = 25
33267           DRTYPE(4) = 26
33268           DRTYPE(5) = 26
33269 C--RPV couplings
33270           A(1,1) = -LAMDA2(III,JJJ,KKK)
33271           A(2,1) = ZERO
33272           DO 26 I=1,2
33273           B(1,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
33274           B(2,I+1) = ZERO
33275           A(1,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
33276  26       A(2,I+3) = ZERO
33277 C--MSSM couplings
33278           DO 27 J=1,2
33279           B(J,1) = AFN(  J ,2*III+6,1,L1)
33280           DO 27 I=1,2
33281           A(J,I+1) = AFN(  J ,2*JJJ-1,I,L1)
33282  27       B(J,I+3) = AFN(O(J),2*KKK-1,I,L1)
33283 C--colour flows
33284           NDIA = 5
33285           NCFL(1) = 1
33286           DO 28 I=1,5
33287  28       IFLOW(I) = 1
33288           SPNCFC(1,1,1) = ONE/THREE
33289 C--antineutrino neutralino production
33290         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
33291      &         IDPDG(IJ).LT.0) THEN
33292 C--change order if antiparticle first
33293           IF(IDHEP(LHEP).LT.0) THEN
33294             ID   = LHEP
33295             LHEP = MHEP
33296             MHEP = ID
33297           ENDIF
33298 C--indices for RPV coupling
33299           III = (IJ-126)/2
33300           JJJ = (IDHW(LHEP)+1)/2
33301           KKK = (IDHW(MHEP)-5)/2
33302           L1  = IK - 449
33303           IDP(5) = 424+2*III
33304           DO 29 I=1,2
33305           IDP(5+I) = 399+2*JJJ+(I-1)*12
33306  29       IDP(7+I) = 399+2*KKK+(I-1)*12
33307 C--types of diagram
33308           DRTYPE(1) = 21
33309           DRTYPE(2) = 22
33310           DRTYPE(3) = 22
33311           DRTYPE(4) = 23
33312           DRTYPE(5) = 23
33313 C--RPV couplings
33314           A(1,1) = ZERO
33315           A(2,1) = -LAMDA2(III,JJJ,KKK)
33316           DO 30 I=1,2
33317           B(1,I+1) = ZERO
33318           B(2,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
33319           A(1,I+3) = ZERO
33320  30       A(2,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
33321 C--MSSM couplings
33322           DO 31 J=1,2
33323           B(J,1) = AFN(O(J),2*III+6,1,L1)
33324           DO 31 I=1,2
33325           A(J,I+1) = AFN(O(J),2*JJJ-1,I,L1)
33326  31       B(J,I+3) = AFN(  J ,2*KKK-1,I,L1)
33327 C--colour flows
33328           NDIA = 5
33329           NCFL(1) = 1
33330           DO 32 I=1,5
33331  32       IFLOW(I) = 1
33332           SPNCFC(1,1,1) = ONE/THREE
33333 C--lepton neutralino production
33334         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
33335      &         IDPDG(IJ).GT.0) THEN
33336 C--change order if antiparticle first
33337           IF(IDHEP(LHEP).LT.0) THEN
33338             ID   = LHEP
33339             LHEP = MHEP
33340             MHEP = ID
33341           ENDIF
33342 C--indices for RPV coupling
33343           III = (IJ-119)/2
33344           JJJ = (IDHW(MHEP)-6)/2
33345           KKK = (IDHW(LHEP)+1)/2
33346           L1  = IK - 449
33347           DO 33 I=1,2
33348           IDP(4+I) = 423+2*III+(I-1)*12
33349           IDP(6+I) = 400+2*JJJ+(I-1)*12
33350  33       IDP(8+I) = 399+2*KKK+(I-1)*12
33351 C--types of diagram
33352           DRTYPE(1) = 24
33353           DRTYPE(2) = 24
33354           DRTYPE(3) = 25
33355           DRTYPE(4) = 25
33356           DRTYPE(5) = 26
33357           DRTYPE(6) = 26
33358 C--RPV couplings
33359           DO 34 I=1,2
33360           A(1,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
33361           A(2,I  ) = 0.0D0
33362           B(1,I+2) = QMIXSS(2*JJJ  ,1,I)*LAMDA2(III,JJJ,KKK)
33363           B(2,I+2) = 0.0D0
33364           A(1,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
33365           A(2,I+4) = 0.0D0
33366 C--MSSM couplings
33367           DO 34 J=1,2
33368           B(J,I  ) = AFN(  J ,2*III+5,I,L1)
33369           A(J,I+2) = AFN(  J ,2*JJJ  ,I,L1)
33370  34       B(J,I+4) = AFN(O(J),2*KKK-1,I,L1)
33371 C--colour flows
33372           NDIA = 6
33373           NCFL(1) = 1
33374           DO 35 I=1,6
33375  35       IFLOW(I) = 1
33376           SPNCFC(1,1,1) = ONE/THREE
33377 C--antilepton neutralino production
33378         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
33379      &         IDPDG(IJ).LT.0) THEN
33380 C--change order if antiparticle first
33381           IF(IDHEP(LHEP).LT.0) THEN
33382             ID   = LHEP
33383             LHEP = MHEP
33384             MHEP = ID
33385           ENDIF
33386 C--indices for RPV coupling
33387           III = (IJ-125)/2
33388           JJJ = IDHW(LHEP)/2
33389           KKK = (IDHW(MHEP)-5)/2
33390           L1  = IK - 449
33391           DO 36 I=1,2
33392           IDP(4+I) = 423+2*III+(I-1)*12
33393           IDP(6+I) = 400+2*JJJ+(I-1)*12
33394  36       IDP(8+I) = 399+2*KKK+(I-1)*12
33395 C--types of diagram
33396           DRTYPE(1) = 21
33397           DRTYPE(2) = 21
33398           DRTYPE(3) = 22
33399           DRTYPE(4) = 22
33400           DRTYPE(5) = 23
33401           DRTYPE(6) = 23
33402 C--RPV couplings
33403           DO 37 I=1,2
33404           A(1,I  ) = 0.0D0
33405           A(2,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
33406           B(1,I+2) = 0.0D0
33407           B(2,I+2) = QMIXSS(2*JJJ  ,1,I)*LAMDA2(III,JJJ,KKK)
33408           A(1,I+4) = 0.0D0
33409           A(2,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
33410 C--MSSM couplings
33411           DO 37 J=1,2
33412           B(J,I  ) = AFN(O(J),2*III+5,I,L1)
33413           A(J,I+2) = AFN(O(J),2*JJJ  ,I,L1)
33414  37       B(J,I+4) = AFN(  J ,2*KKK-1,I,L1)
33415 C--colour flows
33416           NDIA = 6
33417           NCFL(1) = 1
33418           DO 39 I=1,6
33419  39       IFLOW(I) = 1
33420           SPNCFC(1,1,1) = ONE/THREE
33421 C-- +ve chargino antineutrino
33422         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
33423 C--change order if antiparticle first
33424           IF(IDHEP(LHEP).LT.0) THEN
33425             ID   = LHEP
33426             LHEP = MHEP
33427             MHEP = ID
33428           ENDIF
33429 C--indices for RPV
33430           III = (IJ-126)/2
33431           JJJ =  IDHW(LHEP)/2
33432           KKK = (IDHW(MHEP)-5)/2
33433           L1 = IK-453
33434           DO 40 I=1,2
33435           IDP(4+I) = 423+2*III+(I-1)*12
33436  40       IDP(6+I) = 399+2*JJJ+(I-1)*12
33437 C--types of diagram
33438           DRTYPE(1) = 21
33439           DRTYPE(2) = 21
33440           DRTYPE(3) = 22
33441           DRTYPE(4) = 22
33442           DO 41 I=1,2
33443 C--RPV couplings
33444           A(1,I  ) = ZERO
33445           A(2,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
33446           B(1,I+2) = ZERO
33447           B(2,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
33448 C--MSSM couplings
33449           DO 41 J=1,2
33450           B(J,I  ) = AFC(O(J),2*III+5,I,L1)
33451  41       A(J,I+2) = AFC(O(J),2*JJJ-1,I,L1)
33452 C--colour flows
33453           NDIA = 4
33454           NCFL(1) = 1
33455           DO 42 I=1,4
33456  42       IFLOW(I) = 1
33457           SPNCFC(1,1,1) = ONE/THREE
33458 C-- -ve chargino neutrino
33459         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
33460 C--change order if antiparticle first
33461           IF(IDHEP(LHEP).LT.0) THEN
33462             ID   = LHEP
33463             LHEP = MHEP
33464             MHEP = ID
33465           ENDIF
33466 C--indices for RPV
33467           III = (IJ-120)/2
33468           JJJ = (IDHW(MHEP)-6)/2
33469           KKK = (IDHW(LHEP)+1)/2
33470           L1 = IK-455
33471           DO 43 I=1,2
33472           IDP(4+I) = 423+2*III+(I-1)*12
33473  43       IDP(6+I) = 399+2*JJJ+(I-1)*12
33474 C--types of diagram
33475           DRTYPE(1) = 24
33476           DRTYPE(2) = 24
33477           DRTYPE(3) = 25
33478           DRTYPE(4) = 25
33479           DO 44 I=1,2
33480 C--RPV couplings
33481           A(1,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
33482           A(2,I  ) = ZERO
33483           B(1,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
33484           B(2,I+2) = ZERO
33485 C--MSSM couplings
33486           DO 44 J=1,2
33487           B(J,I  ) = AFC(J,2*III+5,I,L1)
33488  44       A(J,I+2) = AFC(J,2*JJJ-1,I,L1)
33489 C--colour flows
33490           NDIA = 4
33491           NCFL(1) = 1
33492           DO 45 I=1,4
33493  45       IFLOW(I) = 1
33494           SPNCFC(1,1,1) = ONE/THREE
33495 C-- -ve chargino antilepton
33496         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
33497 C--change order if antiparticle first
33498           IF(IDHEP(LHEP).LT.0) THEN
33499             ID   = LHEP
33500             LHEP = MHEP
33501             MHEP = ID
33502           ENDIF
33503 C--indices for RPV
33504           III = (IJ-125)/2
33505           JJJ = (IDHW(LHEP)+1)/2
33506           KKK = (IDHW(MHEP)-5)/2
33507           L1 = IK-455
33508           IDP(5) = 424+2*III
33509           DO 46 I=1,2
33510  46       IDP(5+I) = 400+2*JJJ+(I-1)*12
33511 C--types of diagram
33512           DRTYPE(1) = 21
33513           DRTYPE(2) = 22
33514           DRTYPE(3) = 22
33515 C--RPV couplings
33516           A(1,1) = 0.0D0
33517           A(2,1) =-LAMDA2(III,JJJ,KKK)
33518           DO 47 I=1,2
33519           B(1,I+1) = 0.0D0
33520  47       B(2,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
33521 C--MSSM couplings
33522           DO 48 J=1,2
33523           B(J,1) = AFC(O(J),2*III+6,1,L1)
33524           DO 48 I=1,2
33525  48       A(J,I+1) = AFC(O(J),2*JJJ,I,L1)
33526 C--colour flows
33527           NDIA = 3
33528           NCFL(1) = 1
33529           DO 49 I=1,3
33530  49       IFLOW(I) = 1
33531           SPNCFC(1,1,1) = ONE/THREE
33532 C-- +ve chargino lepton
33533         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
33534 C--change order if antiparticle first
33535           IF(IDHEP(LHEP).LT.0) THEN
33536             ID   = LHEP
33537             LHEP = MHEP
33538             MHEP = ID
33539           ENDIF
33540 C--indices for RPV
33541           III = (IJ-119)/2
33542           JJJ = (IDHW(MHEP)-5)/2
33543           KKK = (IDHW(LHEP)+1)/2
33544           L1 = IK-453
33545           IDP(5) = 424+2*III
33546           DO 50 I=1,2
33547  50       IDP(5+I) = 400+2*JJJ+(I-1)*12
33548 C--types of diagram
33549           DRTYPE(1) = 24
33550           DRTYPE(2) = 25
33551           DRTYPE(3) = 25
33552 C--RPV couplings
33553           A(1,1) =-LAMDA2(III,JJJ,KKK)
33554           A(2,1) = 0.0D0
33555           DO 51 I=1,2
33556           B(1,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
33557  51       B(2,I+1) = 0.0D0
33558 C--MSSM couplings
33559           DO 52 J=1,2
33560           B(J,1) = AFC(J,2*III+6,1,L1)
33561           DO 52 I=1,2
33562  52       A(J,I+1) = AFC(J,2*JJJ,I,L1)
33563 C--colour flows
33564           NDIA = 3
33565           NCFL(1) = 1
33566           DO 53 I=1,3
33567  53       IFLOW(I) = 1
33568           SPNCFC(1,1,1) = ONE/THREE
33569 C--d dbar d dbar
33570         ELSEIF(IK.LE.12.AND.IJ.LE.12.AND.
33571      &         MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
33572 C--can't produce unstable quark (on hadronization timescale)
33573           RETURN
33574 C--u    dbar --> u    dbar
33575         ELSEIF((IJ.LE. 6.AND.MOD(IJ,2).EQ.0.AND.
33576      &          IK.LE.12.AND.MOD(IK,2).EQ.1).OR.
33577      &         (IK.LE.6 .AND.MOD(IK,2).EQ.0.AND.
33578      &          IJ.LE.12.AND.MOD(IJ,2).EQ.1)) THEN
33579 C--ensure u first (incoming)
33580           IF(MOD(IDHW(LHEP),2).EQ.1) THEN
33581             ID   = MHEP
33582             MHEP = LHEP
33583             LHEP = ID
33584           ENDIF
33585 C--ensure u first (outgoing)
33586           IF(MOD(IK,2).EQ.1) THEN
33587             ID = IJ
33588             IJ = IK
33589             IK = ID
33590             ID = JHEP
33591             JHEP = KHEP
33592             KHEP = ID
33593           ENDIF
33594 C--can't produce unstable quark (on hadronization timescale)
33595           IF(IK.NE.6) RETURN
33596 C--RPV indices
33597           JJJ = IDHW(LHEP)/2
33598           KKK = (IDHW(MHEP)-5)/2
33599           LLL = IK/2
33600           MMM = (IJ-5)/2
33601           NDIA = 0
33602           DO 54 III=1,3
33603           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
33604      &            GOTO 54
33605           DO 55 J=1,2
33606           IFLOW(NDIA+J) = 1
33607           IDP(4+NDIA+J) = 423+2*III+12*(J-1)
33608           A(1,NDIA+J) = ZERO
33609           A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
33610           B(1,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
33611           B(2,NDIA+J) = ZERO
33612  55       DRTYPE(NDIA+J) = 21
33613           NDIA = NDIA+2
33614  54       CONTINUE
33615           NCFL(1) = 1
33616           SPNCFC(1,1,1) = ONE
33617 C--ubar d    --> ubar d
33618         ELSEIF((IJ.LE.12.AND.MOD(IJ,2).EQ.0.AND.
33619      &          IK.LE. 6.AND.MOD(IK,2).EQ.1).OR.
33620      &         (IK.LE.12.AND.MOD(IK,2).EQ.0.AND.
33621      &          IJ.LE. 6.AND.MOD(IJ,2).EQ.1)) THEN
33622 C--ensure d first (incoming)
33623           IF(MOD(IDHW(LHEP),2).EQ.0) THEN
33624             ID   = MHEP
33625             MHEP = LHEP
33626             LHEP = ID
33627           ENDIF
33628 C--ensure d first (outgoing)
33629           IF(MOD(IK,2).EQ.0) THEN
33630             ID = IJ
33631             IJ = IK
33632             IK = ID
33633             ID = JHEP
33634             JHEP = KHEP
33635             KHEP = ID
33636           ENDIF
33637 C--can't produce unstable quark (on hadronization timescale)
33638           IF(IJ.NE.12) RETURN
33639 C--RPV indices
33640           JJJ = (IDHW(MHEP)-6)/2
33641           KKK = (IDHW(LHEP)+1)/2
33642           LLL = (IJ-6)/2
33643           MMM = (IK+1)/2
33644           NDIA = 0
33645           DO 56 III=1,3
33646           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
33647      &             GOTO 56
33648           DO 57 J=1,2
33649           IFLOW(NDIA+J) = 1
33650           IDP(4+NDIA+J) = 423+2*III+12*(J-1)
33651           A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
33652           A(2,NDIA+J) = ZERO
33653           B(1,NDIA+J) = ZERO
33654           B(2,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
33655  57       DRTYPE(NDIA+J) = 21
33656           NDIA = NDIA+2
33657  56       CONTINUE
33658           NCFL(1) = 1
33659           SPNCFC(1,1,1) = ONE
33660 C--d dbar --> ell- ell+
33661         ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
33662      &         IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
33663      &         IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
33664      &         IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
33665 C--change outgoing order
33666           ID = IK
33667           IK = IJ
33668           IJ = ID
33669           ID = JHEP
33670           JHEP = KHEP
33671           KHEP = ID
33672 C--change order if dbar first
33673           IF(IDHEP(LHEP).LT.0) THEN
33674             ID = LHEP
33675             LHEP = MHEP
33676             MHEP = ID
33677           ENDIF
33678 C--don't do correlations if no taus
33679           IF(IK.NE.125.AND.IJ.NE.131) RETURN
33680 C--RPV couplings
33681           JJJ = (IDHW(LHEP)+1)/2
33682           KKK = (IDHW(MHEP)-5)/2
33683           LLL = (IK-119)/2
33684           MMM = (IJ-125)/2
33685           NDIA = 0
33686           DO 58 III=1,3
33687           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
33688      &             GOTO 58
33689           NDIA = NDIA+1
33690           IFLOW(NDIA) = 1
33691           IDP(4+NDIA) = 424+2*III
33692           A(1,NDIA) = ZERO
33693           A(2,NDIA) = LAMDA2(III,JJJ,KKK)
33694           B(1,NDIA) = LAMDA1(III,LLL,MMM)
33695           B(2,NDIA) = ZERO
33696           DRTYPE(NDIA) = 21
33697  58       CONTINUE
33698           NCFL(1) = 1
33699           SPNCFC(1,1,1) = ONE/THREE
33700 C--dbar d --> ell+ ell-
33701         ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
33702      &         IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
33703      &         IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
33704      &         IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
33705 C--change order if dbar first
33706           IF(IDHEP(LHEP).LT.0) THEN
33707             ID = LHEP
33708             LHEP = MHEP
33709             MHEP = ID
33710           ENDIF
33711 C--don't do correlations if no taus
33712           IF(IK.NE.125.AND.IJ.NE.131) RETURN
33713 C--RPV couplings
33714           JJJ = (IDHW(MHEP)-5)/2
33715           KKK = (IDHW(LHEP)+1)/2
33716           LLL = (IJ-125)/2
33717           MMM = (IK-119)/2
33718           NDIA = 0
33719           DO 59 III=1,3
33720           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
33721      &             GOTO 59
33722           NDIA = NDIA+1
33723           IFLOW(NDIA) = 1
33724           IDP(4+NDIA) = 424+2*III
33725           A(1,NDIA) = LAMDA2(III,JJJ,KKK)
33726           A(2,NDIA) = ZERO
33727           B(1,NDIA) = ZERO
33728           B(2,NDIA) = LAMDA1(III,LLL,MMM)
33729           DRTYPE(NDIA) = 21
33730  59       CONTINUE
33731           NCFL(1) = 1
33732           SPNCFC(1,1,1) = ONE/THREE
33733 C--u dbar --> nu ell+
33734         ELSEIF((IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.0.AND.
33735      &          IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1).OR.
33736      &         (IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
33737      &          IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0)) THEN
33738 C--ensure u first
33739           IF(MOD(IDHW(LHEP),2).NE.0) THEN
33740             ID = LHEP
33741             LHEP = MHEP
33742             MHEP = ID
33743           ENDIF
33744 C--ensure nu first
33745           IF(MOD(IK,2).NE.0) THEN
33746             ID = IK
33747             IK = IJ
33748             IJ = ID
33749             ID = JHEP
33750             JHEP = KHEP
33751             KHEP = ID
33752           ENDIF
33753 C--only need correlations if tau
33754           IF(IJ.NE.131) RETURN
33755 C--RPV couplings
33756           JJJ = IDHW(LHEP)/2
33757           KKK = (IDHW(MHEP)-5)/2
33758           LLL = (IK-120)/2
33759           MMM = (IJ-125)/2
33760           NDIA = 0
33761           DO 60 III=1,3
33762           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
33763      &             GOTO 60
33764           DO 61 J=1,2
33765           IFLOW(NDIA+J) = 1
33766           IDP(4+NDIA+J) = 423+2*III+12*(J-1)
33767           A(1,NDIA+J) = ZERO
33768           A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
33769           B(1,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
33770           B(2,NDIA+J) = ZERO
33771  61       DRTYPE(NDIA+J) = 21
33772           NDIA = NDIA+2
33773  60       CONTINUE
33774           NCFL(1) = 1
33775           SPNCFC(1,1,1) = ONE/THREE
33776 C--ubar d --> ell nubar
33777         ELSEIF((IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.0.AND.
33778      &          IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1).OR.
33779      &         (IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
33780      &          IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0)) THEN
33781 C--ensure u second
33782           IF(MOD(IDHW(MHEP),2).NE.0) THEN
33783             ID = LHEP
33784             LHEP = MHEP
33785             MHEP = ID
33786           ENDIF
33787 C--   ensure nu second
33788           IF(MOD(IJ,2).NE.0) THEN
33789             ID = IK
33790             IK = IJ
33791             IJ = ID
33792             ID = JHEP
33793             JHEP = KHEP
33794             KHEP = ID
33795           ENDIF
33796 C--only need correlations if tau
33797           IF(IK.NE.125) RETURN
33798 C--RPV couplings
33799           JJJ = (IDHW(MHEP)-6)/2
33800           KKK = (IDHW(LHEP)+1)/2
33801           LLL = (IJ-126)/2
33802           MMM = (IK-119)/2
33803           NDIA = 0
33804           DO 62 III=1,3
33805           IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
33806      &             GOTO 62
33807           DO 63 J=1,2
33808           IFLOW(NDIA+J) = 1
33809           IDP(4+NDIA+J) = 423+2*III+12*(J-1)
33810           A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
33811           A(2,NDIA+J) = ZERO
33812           B(1,NDIA+J) = ZERO
33813           B(2,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
33814  63       DRTYPE(NDIA+J) = 21
33815           NDIA = NDIA+2
33816  62       CONTINUE
33817           NCFL(1) = 1
33818           SPNCFC(1,1,1) = ONE/THREE
33819 C--unrecognized process
33820         ELSE
33821           CALL HWWARN('HWHSPN',505,*999)
33822         ENDIF
33823 C--UDD processes
33824       ELSEIF(IPRO.EQ.41) THEN
33825 C--change outgoing order
33826         ID = IJ
33827         IJ = IK
33828         IK = ID
33829         ID = JHEP
33830         JHEP = KHEP
33831         KHEP = ID
33832 C--ubar neutralino
33833         IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
33834      &     IDPDG(IJ).LT.0) THEN
33835 C--indices for RPV
33836           III = (IJ-6)/2
33837           JJJ = (IDHW(LHEP)+1)/2
33838           KKK = (IDHW(MHEP)+1)/2
33839           L1  = IK - 449
33840 C--types of diagram
33841           DRTYPE(1) = 27
33842           DRTYPE(2) = 27
33843           DRTYPE(3) = 28
33844           DRTYPE(4) = 28
33845           DRTYPE(5) = 29
33846           DRTYPE(6) = 29
33847 C--RPV couplings
33848           DO 64 J=1,2
33849           A(1,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
33850           A(2,J  ) = ZERO
33851           B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
33852           B(2,J+2) = ZERO
33853           A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
33854           A(2,J+4) = ZERO
33855 C--particles
33856           IDP(4+J) = 400+2*III+12*(J-1)
33857           IDP(6+J) = 399+2*JJJ+12*(J-1)
33858           IDP(8+J) = 399+2*KKK+12*(J-1)
33859 C--MSSM couplings
33860           DO 64 I=1,2
33861           B(I,J)   = AFN(O(I),2*III,J,L1)
33862           A(I,J+2) = AFN(O(I),2*JJJ-1,J,L1)
33863  64       B(I,J+4) = AFN(O(I),2*KKK-1,J,L1)
33864 C--colour flows
33865           NDIA = 6
33866           NCFL(1) = 1
33867           DO 65 I=1,6
33868  65       IFLOW(I) = 1
33869           SPNCFC(1,1,1) = TWO/THREE
33870 C--u    neutralino
33871         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
33872      &         IDPDG(IJ).GT.0) THEN
33873 C--indices for RPV
33874           III = IJ/2
33875           JJJ = (IDHW(LHEP)-5)/2
33876           KKK = (IDHW(MHEP)-5)/2
33877           L1  = IK - 449
33878 C--types of diagram
33879           DRTYPE(1) = 30
33880           DRTYPE(2) = 30
33881           DRTYPE(3) = 31
33882           DRTYPE(4) = 31
33883           DRTYPE(5) = 32
33884           DRTYPE(6) = 32
33885 C--RPV couplings
33886           DO 66 J=1,2
33887           A(1,J  ) = ZERO
33888           A(2,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
33889           B(1,J+2) = ZERO
33890           B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
33891           A(1,J+4) = ZERO
33892           A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
33893 C--particles
33894           IDP(4+J) = 400+2*III+12*(J-1)
33895           IDP(6+J) = 399+2*JJJ+12*(J-1)
33896           IDP(8+J) = 399+2*KKK+12*(J-1)
33897 C--MSSM couplings
33898           DO 66 I=1,2
33899           B(I,J)   = AFN(I,2*III,J,L1)
33900           A(I,J+2) = AFN(I,2*JJJ-1,J,L1)
33901  66       B(I,J+4) = AFN(I,2*KKK-1,J,L1)
33902 C--colour flows
33903           NDIA = 6
33904           NCFL(1) = 1
33905           DO 67 I=1,6
33906  67       IFLOW(I) = 1
33907           SPNCFC(1,1,1) = TWO/THREE
33908 C--dbar neutralino
33909         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
33910      &         IDPDG(IJ).LT.0) THEN
33911 C--ensure u type first
33912           IF(MOD(IDHW(LHEP),2).NE.0) THEN
33913             ID   = LHEP
33914             LHEP = MHEP
33915             MHEP = ID
33916           ENDIF
33917 C--RPV indices
33918           III = IDHW(LHEP)/2
33919           JJJ = (IDHW(MHEP)+1)/2
33920           KKK = (IJ-5)/2
33921           L1  = IK - 449
33922 C--types of diagram
33923           DRTYPE(1) = 27
33924           DRTYPE(2) = 27
33925           DRTYPE(3) = 28
33926           DRTYPE(4) = 28
33927           DRTYPE(5) = 29
33928           DRTYPE(6) = 29
33929 C--RPV couplings
33930           DO 68 I=1,2
33931           A(1,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
33932           A(2,I  ) = ZERO
33933           B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
33934           B(2,I+2) = ZERO
33935           A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
33936           A(2,I+4) = ZERO
33937 C--particles
33938           IDP(4+I) = 399+2*KKK+12*(I-1)
33939           IDP(6+I) = 400+2*III+12*(I-1)
33940           IDP(8+I) = 399+2*JJJ+12*(I-1)
33941 C--MSSM couplings
33942           DO 68 J=1,2
33943           B(J,I  ) = AFN(O(J),2*KKK-1,I,L1)
33944           A(J,I+2) = AFN(O(J),2*III  ,I,L1)
33945  68       B(J,I+4) = AFN(O(J),2*JJJ-1,I,L1)
33946 C--colour flows
33947           NDIA = 6
33948           NCFL(1) = 1
33949           DO 69 I=1,6
33950  69       IFLOW(I) = 1
33951           SPNCFC(1,1,1) = TWO/THREE
33952 C--d    neutralino
33953         ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
33954      &         IDPDG(IJ).GT.0) THEN
33955 C--ensure u type first
33956           IF(MOD(IDHW(LHEP),2).NE.0) THEN
33957             ID   = LHEP
33958             LHEP = MHEP
33959             MHEP = ID
33960           ENDIF
33961 C--RPV indices
33962           III = (IDHW(LHEP)-6)/2
33963           JJJ = (IDHW(MHEP)-5)/2
33964           KKK = (IJ+1)/2
33965           L1  = IK - 449
33966 C--types of diagram
33967           DRTYPE(1) = 30
33968           DRTYPE(2) = 30
33969           DRTYPE(3) = 31
33970           DRTYPE(4) = 31
33971           DRTYPE(5) = 32
33972           DRTYPE(6) = 32
33973 C--RPV couplings
33974           DO 70 I=1,2
33975           A(1,I  ) = ZERO
33976           A(2,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
33977           B(1,I+2) = ZERO
33978           B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
33979           A(1,I+4) = ZERO
33980           A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
33981 C--particles
33982           IDP(4+I) = 399+2*KKK+12*(I-1)
33983           IDP(6+I) = 400+2*III+12*(I-1)
33984           IDP(8+I) = 399+2*JJJ+12*(I-1)
33985 C--MSSM couplings
33986           DO 70 J=1,2
33987           B(J,I  ) = AFN(J,2*KKK-1,I,L1)
33988           A(J,I+2) = AFN(J,2*III  ,I,L1)
33989  70       B(J,I+4) = AFN(J,2*JJJ-1,I,L1)
33990 C--colour flows
33991           NDIA = 6
33992           NCFL(1) = 1
33993           DO 71 I=1,6
33994  71       IFLOW(I) = 1
33995           SPNCFC(1,1,1) = TWO/THREE
33996 C--ubar gluino
33997         ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).LT.0) THEN
33998 C--indices for RPV
33999           III = (IJ-6)/2
34000           JJJ = (IDHW(LHEP)+1)/2
34001           KKK = (IDHW(MHEP)+1)/2
34002 C--types of diagram
34003           DRTYPE(1) = 27
34004           DRTYPE(2) = 27
34005           DRTYPE(3) = 28
34006           DRTYPE(4) = 28
34007           DRTYPE(5) = 29
34008           DRTYPE(6) = 29
34009 C--RPV couplings
34010           DO 72 J=1,2
34011           A(1,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
34012           A(2,J  ) = ZERO
34013           B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
34014           B(2,J+2) = ZERO
34015           A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
34016           A(2,J+4) = ZERO
34017 C--particles
34018           IDP(4+J) = 400+2*III+12*(J-1)
34019           IDP(6+J) = 399+2*JJJ+12*(J-1)
34020           IDP(8+J) = 399+2*KKK+12*(J-1)
34021 C--MSSM couplings
34022           DO 72 I=1,2
34023           B(I,J)   = AFG(O(I),2*III,J)
34024           A(I,J+2) = AFG(O(I),2*JJJ-1,J)
34025  72       B(I,J+4) = AFG(O(I),2*KKK-1,J)
34026 C--colour flows
34027           NDIA = 6
34028           NCFL(1) = 3
34029           DO 73 I=1,2
34030           IFLOW(I  ) = 1
34031           IFLOW(I+2) = 2
34032  73       IFLOW(I+4) = 3
34033           DO 74 I=1,3
34034           DO 74 J=1,3
34035           IF(I.EQ.J) THEN
34036             SPNCFC(I,J,1) = 8.0D0/9.0D0
34037           ELSE
34038             SPNCFC(I,J,1) =-4.0D0/9.0D0
34039           ENDIF
34040  74       CONTINUE
34041 C--u    gluino
34042         ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).GT.0) THEN
34043 C--indices for RPV
34044           III = IJ/2
34045           JJJ = (IDHW(LHEP)-5)/2
34046           KKK = (IDHW(MHEP)-5)/2
34047 C--types of diagram
34048           DRTYPE(1) = 30
34049           DRTYPE(2) = 30
34050           DRTYPE(3) = 31
34051           DRTYPE(4) = 31
34052           DRTYPE(5) = 32
34053           DRTYPE(6) = 32
34054 C--RPV couplings
34055           DO 75 J=1,2
34056           A(1,J  ) = ZERO
34057           A(2,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
34058           B(1,J+2) = ZERO
34059           B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
34060           A(1,J+4) = ZERO
34061           A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
34062 C--particles
34063           IDP(4+J) = 400+2*III+12*(J-1)
34064           IDP(6+J) = 399+2*JJJ+12*(J-1)
34065           IDP(8+J) = 399+2*KKK+12*(J-1)
34066 C--MSSM couplings
34067           DO 75 I=1,2
34068           B(I,J)   = AFG(I,2*III,J)
34069           A(I,J+2) = AFG(I,2*JJJ-1,J)
34070  75       B(I,J+4) = AFG(I,2*KKK-1,J)
34071 C--colour flows
34072           NDIA = 6
34073           NCFL(1) = 3
34074           DO 76 I=1,2
34075           IFLOW(I  ) = 1
34076           IFLOW(I+2) = 2
34077  76       IFLOW(I+4) = 3
34078           DO 77 I=1,3
34079           DO 77 J=1,3
34080           IF(I.EQ.J) THEN
34081             SPNCFC(I,J,1) = 8.0D0/9.0D0
34082           ELSE
34083             SPNCFC(I,J,1) =-4.0D0/9.0D0
34084           ENDIF
34085  77       CONTINUE
34086 C--dbar gluino
34087         ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).LT.0) THEN
34088 C--ensure u type first
34089           IF(MOD(IDHW(LHEP),2).NE.0) THEN
34090             ID   = LHEP
34091             LHEP = MHEP
34092             MHEP = ID
34093           ENDIF
34094 C--RPV indices
34095           III = IDHW(LHEP)/2
34096           JJJ = (IDHW(MHEP)+1)/2
34097           KKK = (IJ-5)/2
34098 C--types of diagram
34099           DRTYPE(1) = 27
34100           DRTYPE(2) = 27
34101           DRTYPE(3) = 28
34102           DRTYPE(4) = 28
34103           DRTYPE(5) = 29
34104           DRTYPE(6) = 29
34105 C--RPV couplings
34106           DO 78 I=1,2
34107           A(1,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
34108           A(2,I  ) = ZERO
34109           B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
34110           B(2,I+2) = ZERO
34111           A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
34112           A(2,I+4) = ZERO
34113 C--particles
34114           IDP(4+I) = 399+2*KKK+12*(I-1)
34115           IDP(6+I) = 400+2*III+12*(I-1)
34116           IDP(8+I) = 399+2*JJJ+12*(I-1)
34117 C--MSSM couplings
34118           DO 78 J=1,2
34119           B(J,I  ) = AFG(O(J),2*KKK-1,I)
34120           A(J,I+2) = AFG(O(J),2*III  ,I)
34121  78       B(J,I+4) = AFG(O(J),2*JJJ-1,I)
34122 C--colour flows
34123           NDIA = 6
34124           NCFL(1) = 3
34125           DO 79 I=1,2
34126           IFLOW(I  ) = 1
34127           IFLOW(I+2) = 2
34128  79       IFLOW(I+4) = 3
34129           DO 80 I=1,3
34130           DO 80 J=1,3
34131           IF(I.EQ.J) THEN
34132             SPNCFC(I,J,1) = 8.0D0/9.0D0
34133           ELSE
34134             SPNCFC(I,J,1) =-4.0D0/9.0D0
34135           ENDIF
34136  80       CONTINUE
34137 C--d    gluino
34138         ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).GT.0) THEN
34139 C--ensure u type first
34140           IF(MOD(IDHW(LHEP),2).NE.0) THEN
34141             ID   = LHEP
34142             LHEP = MHEP
34143             MHEP = ID
34144           ENDIF
34145 C--RPV indices
34146           III = (IDHW(LHEP)-6)/2
34147           JJJ = (IDHW(MHEP)-5)/2
34148           KKK = (IJ+1)/2
34149 C--types of diagram
34150           DRTYPE(1) = 30
34151           DRTYPE(2) = 30
34152           DRTYPE(3) = 31
34153           DRTYPE(4) = 31
34154           DRTYPE(5) = 32
34155           DRTYPE(6) = 32
34156 C--RPV couplings
34157           DO 81 I=1,2
34158           A(1,I  ) = ZERO
34159           A(2,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
34160           B(1,I+2) = ZERO
34161           B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
34162           A(1,I+4) = ZERO
34163           A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
34164 C--particles
34165           IDP(4+I) = 399+2*KKK+12*(I-1)
34166           IDP(6+I) = 400+2*III+12*(I-1)
34167           IDP(8+I) = 399+2*JJJ+12*(I-1)
34168 C--MSSM couplings
34169           DO 81 J=1,2
34170           B(J,I  ) = AFG(J,2*KKK-1,I)
34171           A(J,I+2) = AFG(J,2*III  ,I)
34172  81       B(J,I+4) = AFG(J,2*JJJ-1,I)
34173 C--colour flows
34174           NDIA = 6
34175           NCFL(1) = 3
34176           DO 82 I=1,2
34177           IFLOW(I  ) = 1
34178           IFLOW(I+2) = 2
34179  82       IFLOW(I+4) = 3
34180           DO 83 I=1,3
34181           DO 83 J=1,3
34182           IF(I.EQ.J) THEN
34183             SPNCFC(I,J,1) = 8.0D0/9.0D0
34184           ELSE
34185             SPNCFC(I,J,1) =-4.0D0/9.0D0
34186           ENDIF
34187  83       CONTINUE
34188 C--dbar -ve chargino
34189         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
34190 C--change order so highest generation first
34191           IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
34192             ID = MHEP
34193             MHEP = LHEP
34194             LHEP = ID
34195           ENDIF
34196 C--RPV indices
34197           III = (IJ-5)/2
34198           JJJ = (IDHW(LHEP)+1)/2
34199           KKK = (IDHW(MHEP)+1)/2
34200           L1  = IK-455
34201 C--types of diagram
34202           DRTYPE(1) = 27
34203           DRTYPE(2) = 27
34204           DRTYPE(3) = 28
34205           DRTYPE(4) = 28
34206           DRTYPE(5) = 29
34207           DRTYPE(6) = 29
34208 C--RPV couplings
34209           DO 84 I=1,2
34210           A(1,I  ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
34211           A(2,I  ) = ZERO
34212           B(1,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
34213           B(2,I+2) = ZERO
34214           A(1,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
34215           A(2,I+4) = ZERO
34216 C--particles
34217           IDP(4+I) = 400+2*III+12*(I-1)
34218           IDP(6+I) = 400+2*JJJ+12*(I-1)
34219           IDP(8+I) = 400+2*KKK+12*(I-1)
34220 C--MSSM couplings
34221           DO 84 J=1,2
34222           B(J,I  ) = AFC(O(J),2*III,I,L1)
34223           A(J,I+2) = AFC(O(J),2*JJJ,I,L1)
34224  84       B(J,I+4) = AFC(O(J),2*KKK,I,L1)
34225 C--colour flows
34226           NDIA = 6
34227           NCFL(1) = 1
34228           DO 85 I=1,6
34229  85       IFLOW(I) = 1
34230           SPNCFC(1,1,1) = TWO/THREE
34231 C--d    +ve chargino
34232         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
34233 C--change order so highest generation first
34234           IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
34235             ID = MHEP
34236             MHEP = LHEP
34237             LHEP = ID
34238           ENDIF
34239 C--RPV indices
34240           III = (IJ+1)/2
34241           JJJ = (IDHW(LHEP)-5)/2
34242           KKK = (IDHW(MHEP)-5)/2
34243           L1  = IK-453
34244 C--types of diagram
34245           DRTYPE(1) = 30
34246           DRTYPE(2) = 30
34247           DRTYPE(3) = 31
34248           DRTYPE(4) = 31
34249           DRTYPE(5) = 32
34250           DRTYPE(6) = 32
34251 C--RPV couplings
34252           DO 86 I=1,2
34253           A(1,I  ) = ZERO
34254           A(2,I  ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
34255           B(1,I+2) = ZERO
34256           B(2,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
34257           A(1,I+4) = ZERO
34258           A(2,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
34259 C--particles
34260           IDP(4+I) = 400+2*III+12*(I-1)
34261           IDP(6+I) = 400+2*JJJ+12*(I-1)
34262           IDP(8+I) = 400+2*KKK+12*(I-1)
34263 C--MSSM couplings
34264           DO 86 J=1,2
34265           B(J,I  ) = AFC(J,2*III,I,L1)
34266           A(J,I+2) = AFC(J,2*JJJ,I,L1)
34267  86       B(J,I+4) = AFC(J,2*KKK,I,L1)
34268 C--colour flows
34269           NDIA = 6
34270           NCFL(1) = 1
34271           DO 87 I=1,6
34272  87       IFLOW(I) = 1
34273           SPNCFC(1,1,1) = TWO/THREE
34274 C--ubar +ve chargino
34275         ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
34276 C--ensure u type first
34277           IF(MOD(IDHW(LHEP),2).NE.0) THEN
34278             ID   = LHEP
34279             LHEP = MHEP
34280             MHEP = ID
34281           ENDIF
34282 C--RPV indices
34283           III = IDHW(LHEP)/2
34284           JJJ = (IDHW(MHEP)+1)/2
34285           KKK = (IJ-6)/2
34286           L1  = IK-453
34287 C--types of diagram
34288           DRTYPE(1) = 27
34289           DRTYPE(2) = 27
34290           DRTYPE(3) = 28
34291           DRTYPE(4) = 28
34292 C--RPV couplings
34293           DO 88 I=1,2
34294           A(1,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
34295           A(2,I  ) = ZERO
34296           B(1,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
34297           B(2,I+2) = ZERO
34298 C--particles
34299           IDP(4+I) = 399+2*KKK+12*(I-1)
34300           IDP(6+I) = 399+2*III+12*(I-1)
34301 C--MSSM couplings
34302           DO 88 J=1,2
34303           B(J,I  ) = AFC(O(J),2*KKK-1,I,L1)
34304  88       A(J,I+2) = AFC(O(J),2*III-1,I,L1)
34305 C--colour flows
34306           NDIA = 4
34307           NCFL(1) = 1
34308           DO 89 I=1,4
34309  89       IFLOW(I) = 1
34310           SPNCFC(1,1,1) = TWO/THREE
34311 C--u    -ve chargino
34312         ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
34313 C--ensure u type first
34314           IF(MOD(IDHW(LHEP),2).NE.0) THEN
34315             ID   = LHEP
34316             LHEP = MHEP
34317             MHEP = ID
34318           ENDIF
34319 C--RPV indices
34320           III = (IDHW(LHEP)-6)/2
34321           JJJ = (IDHW(MHEP)-5)/2
34322           KKK = IJ/2
34323           L1  = IK-455
34324 C--types of diagram
34325           DRTYPE(1) = 30
34326           DRTYPE(2) = 30
34327           DRTYPE(3) = 31
34328           DRTYPE(4) = 31
34329 C--RPV couplings
34330           DO 90 I=1,2
34331           A(1,I  ) = ZERO
34332           A(2,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
34333           B(1,I+2) = ZERO
34334           B(2,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
34335 C--particles
34336           IDP(4+I) = 399+2*KKK+12*(I-1)
34337           IDP(6+I) = 399+2*III+12*(I-1)
34338 C--MSSM couplings
34339           DO 90 J=1,2
34340           B(J,I  ) = AFC(J,2*KKK-1,I,L1)
34341  90       A(J,I+2) = AFC(J,2*III-1,I,L1)
34342 C--colour flows
34343           NDIA = 4
34344           NCFL(1) = 1
34345           DO 91 I=1,4
34346  91       IFLOW(I) = 1
34347           SPNCFC(1,1,1) = TWO/THREE
34348 C--d d --> d d
34349         ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IK).GT.0.AND.
34350      &         MOD(IK,2).EQ.1.AND.MOD(IJ,2).EQ.1) THEN
34351 C--can't produce unstable quark on hadronisation timescale
34352           RETURN
34353 C--dbar dbar --> dbar dbar
34354         ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
34355      &         MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
34356 C--can't produce unstable quark on hadronisation timescale
34357           RETURN
34358 C--u d --> u d
34359         ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IJ).GT.0.AND.
34360      &         ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
34361      &          (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
34362 C--ensure u first (incoming)
34363           IF(MOD(IDHW(LHEP),2).EQ.1) THEN
34364             ID   = MHEP
34365             MHEP = LHEP
34366             LHEP = ID
34367           ENDIF
34368 C--ensure u first (outgoing)
34369           IF(MOD(IK,2).EQ.1) THEN
34370             ID = IJ
34371             IJ = IK
34372             IK = ID
34373             ID = JHEP
34374             JHEP = KHEP
34375             KHEP = ID
34376           ENDIF
34377 C--can't produce unstable quark on hadronisation timescale
34378           IF(IK.NE.6) RETURN
34379 C--RPV indices
34380           III = IDHW(LHEP)/2
34381           KKK = (IDHW(MHEP)+1)/2
34382           LLL = IK/2
34383           MMM = (IJ+1)/2
34384           NDIA = 0
34385           DO 92 JJJ=1,3
34386           IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
34387      &            GOTO 92
34388           DO 93 J=1,2
34389           IFLOW(NDIA+J) = 1
34390           IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
34391           A(1,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
34392           A(2,NDIA+J) = ZERO
34393           B(1,NDIA+J) = ZERO
34394           B(2,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
34395  93       DRTYPE(NDIA+J) = 33
34396           NDIA = NDIA+2
34397  92       CONTINUE
34398           NCFL(1) = 1
34399           SPNCFC(1,1,1) = ONE/THREE
34400 C--ubar dbar --> ubar dbar
34401         ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
34402      &         ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
34403      &          (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
34404 C--ensure u first (incoming)
34405           IF(MOD(IDHW(LHEP),2).EQ.1) THEN
34406             ID   = MHEP
34407             MHEP = LHEP
34408             LHEP = ID
34409           ENDIF
34410 C--ensure u first (outgoing)
34411           IF(MOD(IK,2).EQ.1) THEN
34412             ID = IJ
34413             IJ = IK
34414             IK = ID
34415             ID = JHEP
34416             JHEP = KHEP
34417             KHEP = ID
34418           ENDIF
34419 C--can't produce unstable quark on hadronisation timescale
34420           IF(IK.NE.6) RETURN
34421 C--RPV indices
34422           III = (IDHW(LHEP)-6)/2
34423           KKK = (IDHW(MHEP)-5)/2
34424           LLL = (IK-6)/2
34425           MMM = (IJ-5)/2
34426           NDIA = 0
34427           DO 94 JJJ=1,3
34428           IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
34429      &             GOTO 94
34430           DO 95 J=1,2
34431           IFLOW(NDIA+J) = 1
34432           IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
34433           A(1,NDIA+J) = ZERO
34434           A(2,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
34435           B(1,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
34436           B(2,NDIA+J) = ZERO
34437  95       DRTYPE(NDIA+J) = 34
34438           NDIA = NDIA+2
34439  94       CONTINUE
34440           NCFL(1) = 1
34441           SPNCFC(1,1,1) = ONE/THREE
34442 C--unrecognized process
34443         ELSE
34444           CALL HWWARN('HWHSPN',506,*999)
34445         ENDIF
34446 C--unrecognized process
34447       ELSE
34448         CALL HWWARN('HWHSPN',507,*999)
34449       ENDIF
34450 C--copy the momenta into the internal array
34451       CALL HWVEQU(5,PHEP(1,LHEP),P(1,1))
34452       CALL HWVEQU(5,PHEP(1,MHEP),P(1,2))
34453       CALL HWVEQU(5,PHEP(1,KHEP),P(1,3))
34454       CALL HWVEQU(5,PHEP(1,JHEP),P(1,4))
34455 C--now compute the masses etc for the diagrams
34456       IDP(1) = IDHW(LHEP)
34457       IDP(2) = IDHW(MHEP)
34458       IDP(3) = IDHW(KHEP)
34459       IDP(4) = IDHW(JHEP)
34460       DO 104 I=1,4
34461       MA (I) = P(5,I)
34462  104  MA2(I) = SIGN(MA(I)**2,MA(I))
34463       DO 105 I=1,NDIA
34464       MR(I) = RMASS(IDP(4+I))
34465       MS(I) = MR(I)**2
34466       IF(IDP(I+4).EQ.200) THEN
34467         MWD(I) = RMASS(200)*GAMZ
34468       ELSEIF(IDP(I+4).EQ.198.OR.IDP(I+4).EQ.199) THEN
34469         MWD(I) = RMASS(198)*GAMW
34470       ELSEIF(IDP(I+4).EQ.59.OR.IDP(I+4).EQ.13.OR.
34471      &  IDP(I+4).LE.5.OR.(IDP(I+4).GE.7.AND.IDP(I+4).LE.11)) THEN
34472         MR(I)  = ZERO
34473         MS(I)  = ZERO
34474         MWD(I) = ZERO
34475       ELSE
34476         MWD(I) = MR(I)*HBAR/RLTIM(IDP(I+4))
34477       ENDIF
34478  105  CONTINUE
34479 C--set up the mandelstam variables
34480       SH = TWO*HWULDO(P(1,1),P(1,2))
34481       CALL HWVSCA(4,-ONE,P(1,3),PLAB(1,2))
34482       CALL HWVSUM(5,P(1,1),PLAB(1,2),PLAB(1,1))
34483       TH = P(5,3)**2-TWO*HWULDO(P(1,1),P(1,3))
34484       UH = P(5,4)**2-TWO*HWULDO(P(1,1),P(1,4))
34485 C--copy the momenta into the common block for spinor computation
34486       DO 106 I=1,4
34487       IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
34488      &                .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
34489         CALL HWVEQU(5,PREF,PLAB(1,I+4))
34490 C--all other particles
34491       ELSE
34492         PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
34493         CALL HWVSCA(3,ONE/PP,P(1,I),N)
34494         PLAB(4,I+4) = HALF*(P(4,I)-PP)
34495         PP = HALF*(PP-P(5,I)-PP**2/(P(5,I)+P(4,I)))
34496         CALL HWVSCA(3,PP,N,PLAB(1,I+4))
34497         CALL HWUMAS(PLAB(1,I+4))
34498         PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
34499 C--fix to avoid problems if approx massless due to energy
34500         IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
34501       ENDIF
34502 C--now the massless vectors
34503       PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
34504       DO 107 J=1,4
34505  107  PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
34506  106  CALL HWUMAS(PLAB(1,I))
34507 C--change order of momenta for call to HE code
34508       DO 108 I=1,4
34509       PM(1,I) = P(3,I)
34510       PM(2,I) = P(1,I)
34511       PM(3,I) = P(2,I)
34512       PM(4,I) = P(4,I)
34513  108  PM(5,I) = P(5,I)
34514       DO 109 I=1,8
34515       PCM(1,I)=PLAB(3,I)
34516       PCM(2,I)=PLAB(1,I)
34517       PCM(3,I)=PLAB(2,I)
34518       PCM(4,I)=PLAB(4,I)
34519  109  PCM(5,I)=PLAB(5,I)
34520 C--compute the S functions
34521       CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
34522       DO 110 I=1,8
34523       DO 110 J=1,8
34524       S(I,J,2) = -S(I,J,2)
34525  110  D(I,J)   = TWO*D(I,J)
34526 C--compute the F functions
34527       CALL HWH2F1(8,F3 ,7,PM(1,3), MA(3))
34528       CALL HWH2F2(8,F4 ,8,PM(1,4),-MA(4))
34529       CALL HWH2F1(8,F4M,8,PM(1,4), MA(4))
34530       CALL HWH2F2(8,F3M,7,PM(1,3),-MA(3))
34531 C--t and u channel functions
34532 C--first the t channel ones
34533       CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
34534       CALL HWVSUM(4,PM(1,2),PTMP,PTMP)
34535       CALL HWUMAS(PTMP)
34536       CALL HWH2F3(8,FTP,PTMP, MR(1))
34537       CALL HWH2F3(8,FTM,PTMP,-MR(1))
34538 C--then the u-channel ones
34539       CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
34540       CALL HWVSUM(4,PM(1,1),PTMP,PTMP)
34541       CALL HWUMAS(PTMP)
34542       CALL HWH2F3(8,FUP,PTMP, MR(1))
34543       CALL HWH2F3(8,FUM,PTMP,-MR(1))
34544 C--function for t-channel scalar exchange
34545       CALL HWVSUM(4,PM(1,4),PM(1,4),PTMP)
34546       CALL HWUMAS(PTMP)
34547       CALL HWH2F1(8,FST,2,PTMP,ZERO)
34548 C--compute the prefactor for all diagrams
34549       PRE = HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
34550       PRE = ONE/SQRT(PRE)
34551 C--zero the matrix element
34552       DO 200 P1=1,2
34553       DO 200 P2=1,2
34554       DO 200 P3=1,2
34555       DO 200 P4=1,2
34556       DO 200 I=1,NCFL(1)
34557  200  ME(P1,P2,P3,P4,I) = (0.0D0,0.0D0)
34558 C--now call the subroutines to compute the individual diagrams
34559       DO 210 I=1,NDIA
34560 C--s-channel vector boson exchange diagram (f fbar to fermion fermion)
34561       IF(DRTYPE(I).EQ.1) THEN
34562         CALL HWHS01(I,MED)
34563 C--t-channel sfermion exchange diagram (f fbar to fermion fermion)
34564       ELSEIF(DRTYPE(I).EQ.2) THEN
34565         CALL HWHS02(I,MED)
34566 C--u-channel sfermion exchange diagram(f fbar to fermion fermion)
34567       ELSEIF(DRTYPE(I).EQ.3) THEN
34568         CALL HWHS03(I,MED)
34569 C--s-channel vector boson (f fbar to fermion antifermion)
34570       ELSEIF(DRTYPE(I).EQ.4) THEN
34571         CALL HWHS04(I,MED)
34572 C--t-channel fermion exchange (g g to fermion antifermion)
34573       ELSEIF(DRTYPE(I).EQ.5) THEN
34574         CALL HWHS05(I,MED)
34575 C--u-channel fermion exchange (g g to fermion antifermion)
34576       ELSEIF(DRTYPE(I).EQ.6) THEN
34577         CALL HWHS06(I,MED)
34578 C--s-channel gluon exchange (g g to fermion antifermion)
34579       ELSEIF(DRTYPE(I).EQ.7) THEN
34580         CALL HWHS07(I,MED)
34581 C--t-channel sfermion exchange (g q to fermion sfermion)
34582       ELSEIF(DRTYPE(I).EQ.8) THEN
34583         CALL HWHS08(I,MED)
34584 C--t-channel sfermion exchange  (g qbar to fermion antisfermion)
34585       ELSEIF(DRTYPE(I).EQ.9) THEN
34586         CALL HWHS09(I,MED)
34587 C--s-channel quark exchange     (g q to fermion antisfermion)
34588       ELSEIF(DRTYPE(I).EQ.10) THEN
34589         CALL HWHS10(I,MED)
34590 C--s-channel antiquark exchange (g qbar to fermion antisfermion)
34591       ELSEIF(DRTYPE(I).EQ.11) THEN
34592         CALL HWHS11(I,MED)
34593 C--u-channel gluino exchange (g q to fermion antisfermion)
34594       ELSEIF(DRTYPE(I).EQ.12) THEN
34595         CALL HWHS12(I,MED)
34596 C--u-channel gluino exchange (g qbar to fermion antisfermion)
34597       ELSEIF(DRTYPE(I).EQ.13) THEN
34598         CALL HWHS13(I,MED)
34599 C--t-channel fermion exchange (g g to fermion fermion)
34600       ELSEIF(DRTYPE(I).EQ.14) THEN
34601         CALL HWHS14(I,MED)
34602 C--u-channel fermion exchange (g g to fermion fermion)
34603       ELSEIF(DRTYPE(I).EQ.15) THEN
34604         CALL HWHS15(I,MED)
34605 C--s-channel gluon exchange (g g to fermion fermion)
34606       ELSEIF(DRTYPE(I).EQ.16) THEN
34607         CALL HWHS16(I,MED)
34608 C--t-channel gauge boson exchange (fermion fermion)
34609       ELSEIF(DRTYPE(I).EQ.17) THEN
34610         CALL HWHS17(I,MED)
34611 C--t-channel gauge boson exchange (fermion antifermion)
34612       ELSEIF(DRTYPE(I).EQ.18) THEN
34613         CALL HWHS18(I,MED)
34614 C--t-channel gauge boson exchange (antifermion fermion)
34615       ELSEIF(DRTYPE(I).EQ.19) THEN
34616         CALL HWHS19(I,MED)
34617 C--t-channel gauge boson exchange (antifermion antifermion)
34618       ELSEIF(DRTYPE(I).EQ.20) THEN
34619         CALL HWHS20(I,MED)
34620 C--s-channel scalar exchange (f fbar --> f fbar)
34621       ELSEIF(DRTYPE(I).EQ.21) THEN
34622         CALL HWHS21(I,MED)
34623 C--t-channel scalar exchange (f fbar --> f fbar)
34624       ELSEIF(DRTYPE(I).EQ.22) THEN
34625         CALL HWHS22(I,MED)
34626 C--u-channel scalar exchange (f fbar --> f fbar)
34627       ELSEIF(DRTYPE(I).EQ.23) THEN
34628         CALL HWHS23(I,MED)
34629 C--s-channel scalar exchange (fbar f --> f f)
34630       ELSEIF(DRTYPE(I).EQ.24) THEN
34631         CALL HWHS24(I,MED)
34632 C--t-channel scalar exchange (fbar f --> f f)
34633       ELSEIF(DRTYPE(I).EQ.25) THEN
34634         CALL HWHS25(I,MED)
34635 C--u-channel scalar exchange (fbar f --> f f)
34636       ELSEIF(DRTYPE(I).EQ.26) THEN
34637         CALL HWHS26(I,MED)
34638 C--s-channel scalar exchange (f f --> f fbar)
34639       ELSEIF(DRTYPE(I).EQ.27) THEN
34640         CALL HWHS27(I,MED)
34641 C--t-channel scalar exchange (f f --> f fbar)
34642       ELSEIF(DRTYPE(I).EQ.28) THEN
34643         CALL HWHS28(I,MED)
34644 C--u-channel scalar exchange (f f --> f fbar)
34645       ELSEIF(DRTYPE(I).EQ.29) THEN
34646         CALL HWHS29(I,MED)
34647 C--s-channel scalar exchange (fbar fbar --> f f)
34648       ELSEIF(DRTYPE(I).EQ.30) THEN
34649         CALL HWHS30(I,MED)
34650 C--t-channel scalar exchange (fbar fbar --> f f)
34651       ELSEIF(DRTYPE(I).EQ.31) THEN
34652         CALL HWHS31(I,MED)
34653 C--u-channel scalar exchange (fbar fbar --> f f)
34654       ELSEIF(DRTYPE(I).EQ.32) THEN
34655         CALL HWHS32(I,MED)
34656 C--s-channel scalar exchange (f f --> f f)
34657       ELSEIF(DRTYPE(I).EQ.33) THEN
34658         CALL HWHS33(I,MED)
34659 C--s-channel scalar exchange (fbar fbar --> fbar fbar)
34660       ELSEIF(DRTYPE(I).EQ.34) THEN
34661         CALL HWHS34(I,MED)
34662 C--error not known
34663       ELSE
34664         CALL HWWARN('HWHSPN',508,*999)
34665       ENDIF
34666 C--add up the matrix elements
34667       DO 210 P1=1,2
34668       DO 210 P2=1,2
34669       DO 210 P3=1,2
34670       DO 210 P4=1,2
34671  210  ME(P1,P2,P3,P4,IFLOW(I)) = ME(P1,P2,P3,P4,IFLOW(I))
34672      &                             +MED(P1,P2,P3,P4)
34673 C--preform the final normalisation
34674       DO 215 P1=1,2
34675       DO 215 P2=1,2
34676       DO 215 P3=1,2
34677       DO 215 P4=1,2
34678       DO 215 I=1,NCFL(1)
34679  215  ME(P1,P2,P3,P4,I) = PRE*ME(P1,P2,P3,P4,I)
34680 C--now enter the matrix element in the spin common block
34681       NSPN        = 1
34682       IDSPN(1)    = ICM
34683       ISNHEP(ICM) = 1
34684       JMOSPN(1)   = 0
34685       JDASPN(1,1) = 2
34686       JDASPN(2,1) = 3
34687       DECSPN(1) = .FALSE.
34688       DO 225 P1=1,2
34689       DO 225 P2=1,2
34690       DO 225 P3=1,2
34691       DO 225 P4=1,2
34692       DO 225 I=1,NCFL(1)
34693  225  MESPN(P1,P2,P3,P4,I,1) = ME(P1,P2,P3,P4,I)
34694 C--now enter the daughter particles
34695       NSPN         = NSPN+2
34696       IDSPN(2)     = KHEP
34697       ISNHEP(KHEP) = 2
34698       IDSPN(3)     = JHEP
34699       ISNHEP(JHEP) = 3
34700       JMOSPN(2)    = 1
34701       JMOSPN(3)    = 1
34702 C--spin density matrices for daughter particles
34703       DO 230 P1=1,2
34704       DO 230 P2=1,2
34705       DO 230 I=1,3
34706       RHOSPN(1,1,I) = HALF
34707       RHOSPN(1,2,I) = ZERO
34708       RHOSPN(2,1,I) = ZERO
34709  230  RHOSPN(2,2,I) = HALF
34710       DECSPN(2) = .FALSE.
34711       DECSPN(3) = .FALSE.
34712 C--select the colour flow if needed
34713       IF(SPCOPT.EQ.2.AND.NCFL(1).NE.1) THEN
34714         WGT = ZERO
34715 C--assume no incoming polarization, no processes with more than one
34716 C--colour flow in e+e-
34717         DO 335 I =1,NCFL(1)
34718         WGTB(I) = ZERO
34719         DO 335 P1=1,2
34720         DO 335 P2=1,2
34721         DO 335 P3=1,2
34722         DO 335 P4=1,2
34723         WGTB(I) = WGTB(I)+SPNCFC(I,I,1)*MESPN(P1,P2,P3,P4,I,1)*
34724      &                           DCONJG(MESPN(P1,P2,P3,P4,I,1))
34725         DO 335 J =1,NCFL(1)
34726  335    WGT = WGT+SPNCFC(I,J,1)*MESPN(P1,P2,P3,P4,I,1)*
34727      &                   DCONJG(MESPN(P1,P2,P3,P4,J,1))
34728         WGTC = ZERO
34729         DO 340 I=1,NCFL(1)
34730  340    WGTC = WGTC+WGTB(I)
34731         WGTC = WGT/WGTC
34732         DO 345 I=1,NCFL(1)
34733  345    WGTB(I) = WGTB(I)*WGTC
34734         WGTC = WGT*HWRGEN(0)
34735         DO 350 I=1,NCFL(1)
34736         IF(WGTB(I).GE.WGTC) THEN
34737           NCFL(1) = I
34738           RETURN
34739         ENDIF
34740  350    WGTC =WGTC-WGTB(I)
34741       ENDIF
34742  999  END
34743 CDECK  ID>, HWHS01.
34744 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
34745 *-- Author :    Peter Richardson
34746 C-----------------------------------------------------------------------
34747       SUBROUTINE HWHS01(ID,ME)
34748 C-----------------------------------------------------------------------
34749 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34750 C  section f fbar --> gauge boson --> fermion fermion
34751 C  This diagram 1 from DAMTP-2001-83 with opposite sign of P4
34752 C-----------------------------------------------------------------------
34753       INCLUDE 'HERWIG65.INC'
34754       INTEGER NDIAHD
34755       PARAMETER(NDIAHD=10)
34756       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34757      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34758      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34759       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34760      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34761       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34762       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34763      &     MA2,SH,TH,UH,IDP,DRTYPE
34764       PARAMETER(ZI=(0.0D0,1.0D0))
34765       COMMON/HWHEWS/S(8,8,2),D(8,8)
34766       DATA O/2,1/
34767 C--compute the propagator factor
34768       PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
34769       DO 10 P1=1,2
34770       DO 10 P2=1,2
34771       DO 10 P3=1,2
34772       DO 10 P4=1,2
34773         IF(P1.EQ.P2) THEN
34774           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
34775      &          B(O(P1),ID)*F3(O(P3),  P1 ,1)*F4(  P1 ,P4,2)
34776      &         +B(  P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),P4,1))
34777         ELSE
34778           ME(P1,P2,P3,P4) = ZERO
34779         ENDIF
34780  10   CONTINUE
34781       END
34782 CDECK  ID>, HWHS02.
34783 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
34784 *-- Author :    Peter Richardson
34785 C-----------------------------------------------------------------------
34786       SUBROUTINE HWHS02(ID,ME)
34787 C-----------------------------------------------------------------------
34788 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34789 C  section  f fbar ---> fermion fermion via t-channel scalar exchange
34790 C  This diagram 2 from DAMTP-2001-83 with opposite sign of P4
34791 C-----------------------------------------------------------------------
34792       INCLUDE 'HERWIG65.INC'
34793       INTEGER NDIAHD
34794       PARAMETER(NDIAHD=10)
34795       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
34796      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34797      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34798       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34799      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34800       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34801       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34802      &     MA2,SH,TH,UH,IDP,DRTYPE
34803       COMMON/HWHEWS/S(8,8,2),D(8,8)
34804       DATA O/2,1/
34805 C--compute the propagator factor
34806       PRE = -HALF/(TH-MS(ID))
34807       DO 10 P1=1,2
34808       DO 10 P2=1,2
34809       DO 10 P3=1,2
34810       DO 10 P4=1,2
34811  10   ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
34812      &        F3(O(P3),P1,1)*F4(P2,P4,2)
34813       END
34814 CDECK  ID>, HWHS03.
34815 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
34816 *-- Author :    Peter Richardson
34817 C-----------------------------------------------------------------------
34818       SUBROUTINE HWHS03(ID,ME)
34819 C-----------------------------------------------------------------------
34820 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34821 C  section  f fbar ---> fermion fermion via u-channel scalar exchange
34822 C  This diagram 3 from DAMTP-2001-83 with opposite sign of P4
34823 C-----------------------------------------------------------------------
34824       INCLUDE 'HERWIG65.INC'
34825       INTEGER NDIAHD
34826       PARAMETER(NDIAHD=10)
34827       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,
34828      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34829      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34830       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34831      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34832       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34833       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34834      &     MA2,SH,TH,UH,IDP,DRTYPE
34835       COMMON/HWHEWS/S(8,8,2),D(8,8)
34836       DATA O/2,1/
34837 C--compute the propagator factor
34838       PRE = HALF/(UH-MS(ID))
34839       DO 10 P1=1,2
34840       DO 10 P2=1,2
34841       DO 10 P3=1,2
34842       DO 10 P4=1,2
34843  10   ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
34844      &        F4M(O(P4),P1,1)*F3M(P2,P3,2)
34845       END
34846 CDECK  ID>, HWHS04.
34847 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
34848 *-- Author :    Peter Richardson
34849 C-----------------------------------------------------------------------
34850       SUBROUTINE HWHS04(ID,ME)
34851 C-----------------------------------------------------------------------
34852 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34853 C  section f fbar --> gauge boson --> fermion antifermion
34854 C  This diagram 1 from DAMTP-2001-83
34855 C-----------------------------------------------------------------------
34856       INCLUDE 'HERWIG65.INC'
34857       INTEGER NDIAHD
34858       PARAMETER(NDIAHD=10)
34859       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34860      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34861      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34862       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34863      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34864       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34865       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34866      &     MA2,SH,TH,UH,IDP,DRTYPE
34867       PARAMETER(ZI=(0.0D0,1.0D0))
34868       COMMON/HWHEWS/S(8,8,2),D(8,8)
34869       DATA O/2,1/
34870 C--compute the propagator factor
34871       PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
34872       DO 10 P1=1,2
34873       DO 10 P2=1,2
34874       DO 10 P3=1,2
34875       DO 10 P4=1,2
34876         IF(P1.EQ.P2) THEN
34877           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
34878      &          B(O(P1),ID)*F3(O(P3),  P1 ,1)*F4(  P1 ,O(P4),2)
34879      &         +B(  P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),O(P4),1))
34880         ELSE
34881           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
34882         ENDIF
34883  10   CONTINUE
34884       END
34885 CDECK  ID>, HWHS05.
34886 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
34887 *-- Author :    Peter Richardson
34888 C-----------------------------------------------------------------------
34889       SUBROUTINE HWHS05(ID,ME)
34890 C-----------------------------------------------------------------------
34891 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34892 C  section gluon gluon --> fermion antifermion (1st colour flow)
34893 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
34894 C  This diagram 4 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
34895 C-----------------------------------------------------------------------
34896       INCLUDE 'HERWIG65.INC'
34897       INTEGER NDIAHD
34898       PARAMETER(NDIAHD=10)
34899       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34900      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34901      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34902       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34903      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34904       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34905       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34906      &     MA2,SH,TH,UH,IDP,DRTYPE
34907       PARAMETER(ZI=(0.0D0,1.0D0))
34908       COMMON/HWHEWS/S(8,8,2),D(8,8)
34909       DATA O/2,1/
34910 C--compute the propagator factor
34911       PRE =+ONE/SH/(TH-MS(ID))
34912       DO 10 P1=1,2
34913       DO 10 P2=1,2
34914       DO 10 P3=1,2
34915       DO 10 P4=1,2
34916  10   ME(P1,P2,P3,P4) = PRE*(
34917      &  F3(O(P3),  P1 ,2)*( FTP(  P1 ,  P2 ,1,1)*F4(  P2 ,O(P4),2)
34918      &                     +FTP(  P1 ,O(P2),1,2)*F4(O(P2),O(P4),1))
34919      & +F3(O(P3),O(P1),1)*( FTP(O(P1),  P2 ,2,1)*F4(  P2 ,O(P4),2)
34920      &                     +FTP(O(P1),O(P2),2,2)*F4(O(P2),O(P4),1)))
34921       END
34922 CDECK  ID>, HWHS06.
34923 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
34924 *-- Author :    Peter Richardson
34925 C-----------------------------------------------------------------------
34926       SUBROUTINE HWHS06(ID,ME)
34927 C-----------------------------------------------------------------------
34928 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34929 C  section gluon gluon --> fermion antifermion (2st colour flow)
34930 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
34931 C  This diagram 5 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
34932 C-----------------------------------------------------------------------
34933       INCLUDE 'HERWIG65.INC'
34934       INTEGER NDIAHD
34935       PARAMETER(NDIAHD=10)
34936       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34937      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
34938      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34939       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34940      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34941       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34942       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34943      &     MA2,SH,TH,UH,IDP,DRTYPE
34944       PARAMETER(ZI=(0.0D0,1.0D0))
34945       COMMON/HWHEWS/S(8,8,2),D(8,8)
34946       DATA O/2,1/
34947 C--compute the propagator factor
34948       PRE =-ONE/SH/(UH-MS(ID))
34949       DO 10 P1=1,2
34950       DO 10 P2=1,2
34951       DO 10 P3=1,2
34952       DO 10 P4=1,2
34953  10   ME(P1,P2,P3,P4) = PRE*(
34954      &     F3(O(P3),  P2 ,1)*( FUP(  P2 ,  P1 ,2,2)*F4(  P1 ,O(P4),1)
34955      &                        +FUP(  P2 ,O(P1),2,1)*F4(O(P1),O(P4),2))
34956      &    +F3(O(P3),O(P2),2)*( FUP(O(P2),  P1 ,1,2)*F4(  P1 ,O(P4),1)
34957      &                        +FUP(O(P2),O(P1),1,1)*F4(O(P1),O(P4),2)))
34958       END
34959 CDECK  ID>, HWHS07.
34960 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
34961 *-- Author :    Peter Richardson
34962 C-----------------------------------------------------------------------
34963       SUBROUTINE HWHS07(ID,ME)
34964 C-----------------------------------------------------------------------
34965 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
34966 C  section gluon gluon --> fermion antifermion (triple gluon piece)
34967 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
34968 C  This diagram 6 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
34969 C-----------------------------------------------------------------------
34970       INCLUDE 'HERWIG65.INC'
34971       INTEGER NDIAHD
34972       PARAMETER(NDIAHD=10)
34973       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
34974      &     ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
34975      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
34976       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
34977      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
34978       INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
34979       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
34980      &     MA2,SH,TH,UH,IDP,DRTYPE
34981       PARAMETER(ZI=(0.0D0,1.0D0))
34982       COMMON/HWHEWS/S(8,8,2),D(8,8)
34983       DATA O/2,1/
34984 C--compute the propagator factor
34985       PRE = HALF/SH**2
34986       DO 10 P3=1,2
34987       DO 10 P4=1,2
34988       MET = (0.0D0,0.0D0)
34989       DO 5 I=1,2
34990  5    MET=MET+F3(O(P3),I,1)*F4(I,O(P4),1)-F3(O(P3),I,2)*F4(I,O(P4),2)
34991       DO 10 P1=1,2
34992       DO 10 P2=1,2
34993       IF(P1.EQ.P2) THEN
34994         ME(P1,P2,P3,P4) = PRE*S(1,2,P1)*S(1,2,O(P1))*MET
34995       ELSE
34996         ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
34997       ENDIF
34998  10   CONTINUE
34999       END
35000 CDECK  ID>, HWHS08.
35001 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35002 *-- Author :    Peter Richardson
35003 C-----------------------------------------------------------------------
35004       SUBROUTINE HWHS08(ID,ME)
35005 C-----------------------------------------------------------------------
35006 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35007 C  section quark gluon --> fermion sfermion
35008 C  This diagram 7 from DAMTP-2001-83 with the gauge choice L2=1
35009 C-----------------------------------------------------------------------
35010       INCLUDE 'HERWIG65.INC'
35011       INTEGER NDIAHD
35012       PARAMETER(NDIAHD=10)
35013       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35014      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35015      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35016       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35017      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35018       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35019       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35020      &     MA2,SH,TH,UH,IDP,DRTYPE
35021       PARAMETER(ZI=(0.0D0,1.0D0))
35022       COMMON/HWHEWS/S(8,8,2),D(8,8)
35023       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35024       DATA O/2,1/
35025       EXTERNAL HWULDO
35026 C--compute the propagator factor
35027       PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35028      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
35029      &        (TH-MS(ID))
35030       DO 10 P1=1,2
35031       DO 10 P2=1,2
35032       DO 10 P3=1,2
35033       ME(P1,P2,P3,2) = ZERO
35034  10   ME(P1,P2,P3,1) = A(P1,ID)*PRE*FST(P2,P2,1)*F3(O(P3),  P1,1)
35035       END
35036 CDECK  ID>, HWHS09.
35037 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35038 *-- Author :    Peter Richardson
35039 C-----------------------------------------------------------------------
35040       SUBROUTINE HWHS09(ID,ME)
35041 C-----------------------------------------------------------------------
35042 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35043 C  section antiquark gluon --> fermion antisfermion
35044 C  This diagram 10 from DAMTP-2001-83 with the gauge choice L2=1
35045 C-----------------------------------------------------------------------
35046       INCLUDE 'HERWIG65.INC'
35047       INTEGER NDIAHD
35048       PARAMETER(NDIAHD=10)
35049       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35050      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35051      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35052       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35053      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35054       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35055       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35056      &     MA2,SH,TH,UH,IDP,DRTYPE
35057       PARAMETER(ZI=(0.0D0,1.0D0))
35058       COMMON/HWHEWS/S(8,8,2),D(8,8)
35059       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35060       DATA O/2,1/
35061       EXTERNAL HWULDO
35062 C--compute the propagator factor
35063       PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35064      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
35065      &        (TH-MS(ID))
35066       DO 10 P1=1,2
35067       DO 10 P2=1,2
35068       DO 10 P3=1,2
35069       ME(P1,P2,P3,2) = ZERO
35070   10  ME(P1,P2,P3,1) = A(O(P1),ID)*PRE*FST(P2,P2,1)*F3M(P1,P3,1)
35071       END
35072 CDECK  ID>, HWHS10.
35073 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35074 *-- Author :    Peter Richardson
35075 C-----------------------------------------------------------------------
35076       SUBROUTINE HWHS10(ID,ME)
35077 C-----------------------------------------------------------------------
35078 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35079 C  section quark gluon --> fermion antisfermion (s-channel quark)
35080 C  This is diagram 8 from DAMTP-2001-83 with the gauge choice L2=1
35081 C-----------------------------------------------------------------------
35082       INCLUDE 'HERWIG65.INC'
35083       INTEGER NDIAHD
35084       PARAMETER(NDIAHD=10)
35085       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35086      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35087      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35088       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35089      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35090       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35091       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35092      &     MA2,SH,TH,UH,IDP,DRTYPE
35093       PARAMETER(ZI=(0.0D0,1.0D0))
35094       COMMON/HWHEWS/S(8,8,2),D(8,8)
35095       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35096       DATA O/2,1/
35097       EXTERNAL HWULDO
35098 C--compute the propagator factor
35099       PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35100      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
35101       DO 10 P1=1,2
35102       DO 10 P2=1,2
35103       DO 10 P3=1,2
35104       IF(P1.EQ.P2) THEN
35105         ME(p1,p2,p3,1) = PRE*A(  P2 ,ID)*F3(O(P3),  P2 ,1)*S(1,2,P2)*
35106      &        S(1,1,O(P2))
35107       ELSE
35108         ME(P1,P2,P3,1) = PRE*
35109      &      A(O(P2),ID)*( F3(O(P3),O(P2),1)*S(1,1,O(P2))
35110      &                   +F3(O(P3),O(P2),2)*S(2,1,O(P2)))*S(2,1,P2)
35111       ENDIF
35112  10   ME(P1,P2,P3,2) = ZERO
35113       END
35114 CDECK  ID>, HWHS11.
35115 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35116 *-- Author :    Peter Richardson
35117 C-----------------------------------------------------------------------
35118       SUBROUTINE HWHS11(ID,ME)
35119 C-----------------------------------------------------------------------
35120 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35121 C  section quark gluon --> fermion antisfermion (s-channel quark)
35122 C  This is diagram 11 from DAMTP-2001-83 with the gauge choice L2=1
35123 C-----------------------------------------------------------------------
35124       INCLUDE 'HERWIG65.INC'
35125       INTEGER NDIAHD
35126       PARAMETER(NDIAHD=10)
35127       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35128      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35129      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35130       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35131      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35132       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35133       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35134      &     MA2,SH,TH,UH,IDP,DRTYPE
35135       PARAMETER(ZI=(0.0D0,1.0D0))
35136       COMMON/HWHEWS/S(8,8,2),D(8,8)
35137       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35138       DATA O/2,1/
35139       EXTERNAL HWULDO
35140 C--compute the propagator factor
35141       PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35142      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
35143       DO 10 P1=1,2
35144       DO 10 P2=1,2
35145       DO 10 P3=1,2
35146       IF(P1.EQ.P2) THEN
35147         ME(P1,P2,P3,1) = PRE*A(O(P2),ID)*S(1,2,P1)*
35148      &        (S(1,1,O(P2))*F3M(P2,P3,1)+S(1,2,O(P2))*F3M(P2,P3,2))
35149       ELSE
35150         ME(P1,P2,P3,1)=PRE*A(P2,ID)*S(1,1,P1)*S(2,1,P2)*F3M(O(P2),P3,1)
35151       ENDIF
35152  10   ME(P1,P2,P3,2) = ZERO
35153       END
35154 CDECK  ID>, HWHS12.
35155 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35156 *-- Author :    Peter Richardson
35157 C-----------------------------------------------------------------------
35158       SUBROUTINE HWHS12(ID,ME)
35159 C-----------------------------------------------------------------------
35160 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35161 C  section quark gluon --> fermion antisfermion (s-channel quark)
35162 C  This is diagram 9 from DAMTP-2001-83 with the gauge choice L2=1
35163 C-----------------------------------------------------------------------
35164       INCLUDE 'HERWIG65.INC'
35165       INTEGER NDIAHD
35166       PARAMETER(NDIAHD=10)
35167       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35168      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35169      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35170       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35171      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35172       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35173       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35174      &     MA2,SH,TH,UH,IDP,DRTYPE
35175       PARAMETER(ZI=(0.0D0,1.0D0))
35176       COMMON/HWHEWS/S(8,8,2),D(8,8)
35177       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35178       DATA O/2,1/
35179       EXTERNAL HWULDO
35180 C--compute the propagator factor
35181       PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35182      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
35183       DO 10 P1=1,2
35184       DO 10 P2=1,2
35185       DO 10 P3=1,2
35186       ME(P1,P2,P3,1) = PRE*A(P1,ID)*(
35187      &                       F3(O(P3),  P2 ,1)*FUP(  P2 ,P1, 2,1)
35188      &                      +F3(O(P3),O(P2), 2)*FUP(O(P2),P1,1,1))
35189  10   ME(P1,P2,P3,2) = ZERO
35190       END
35191 CDECK  ID>, HWHS13.
35192 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35193 *-- Author :    Peter Richardson
35194 C-----------------------------------------------------------------------
35195       SUBROUTINE HWHS13(ID,ME)
35196 C-----------------------------------------------------------------------
35197 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35198 C  section quark gluon --> fermion antisfermion (s-channel quark)
35199 C  This is diagram 12 from DAMTP-2001-83 with the gauge choice L2=1
35200 C-----------------------------------------------------------------------
35201       INCLUDE 'HERWIG65.INC'
35202       INTEGER NDIAHD
35203       PARAMETER(NDIAHD=10)
35204       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35205      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35206      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35207       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35208      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35209       INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35210       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35211      &     MA2,SH,TH,UH,IDP,DRTYPE
35212       PARAMETER(ZI=(0.0D0,1.0D0))
35213       COMMON/HWHEWS/S(8,8,2),D(8,8)
35214       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35215       DATA O/2,1/
35216       EXTERNAL HWULDO
35217 C--compute the propagator factor
35218       PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
35219      &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
35220       DO 10 P1=1,2
35221       DO 10 P2=1,2
35222       DO 10 P3=1,2
35223       ME(P1,P2,P3,1) = PRE*A(O(P1),ID)*(
35224      &                       FUM(P1,  P2 ,1,1)*F3M(  P2 ,P3, 2)
35225      &                      +FUM(P1,O(P2),1, 2)*F3M(O(P2),P3,1))
35226  10   ME(P1,P2,P3,2) = ZERO
35227       END
35228 CDECK  ID>, HWHS14.
35229 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35230 *-- Author :    Peter Richardson
35231 C-----------------------------------------------------------------------
35232       SUBROUTINE HWHS14(ID,ME)
35233 C-----------------------------------------------------------------------
35234 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35235 C  section gluon gluon --> fermion antifermion (1st colour flow)
35236 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
35237 C  This diagram 4 from DAMTP-2001-83 with opposite helicity for 4
35238 C  and gauge choice L1=2 L2=1
35239 C-----------------------------------------------------------------------
35240       INCLUDE 'HERWIG65.INC'
35241       INTEGER NDIAHD
35242       PARAMETER(NDIAHD=10)
35243       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35244      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
35245      &     FUP(2,2,8,8),FUM(2,2,8,8)
35246       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35247      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35248       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35249       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35250      &     MA2,SH,TH,UH,IDP,DRTYPE
35251       PARAMETER(ZI=(0.0D0,1.0D0))
35252       COMMON/HWHEWS/S(8,8,2),D(8,8)
35253       DATA O/2,1/
35254 C--compute the propagator factor
35255       PRE =+ONE/(TH-MS(ID))/SH
35256 C--matrix element
35257       DO 10 P1=1,2
35258       DO 10 P2=1,2
35259       DO 10 P3=1,2
35260       DO 10 P4=1,2
35261  10   ME(P1,P2,P3,P4) = PRE*(
35262      &  F3(O(P3),  P1 ,2)*( FTP(  P1 ,  P2 , 1,1)*F4(  P2 ,P4,2)
35263      &                     +FTP(  P1 ,O(P2), 1,2)*F4(O(P2),P4,1))
35264      & +F3(O(P3),O(P1),1)*( FTP(O(P1),  P2 ,2,1)*F4(  P2 ,P4,2)
35265      &                     +FTP(O(P1),O(P2),2,2)*F4(O(P2),P4,1)))
35266       END
35267 CDECK  ID>, HWHS15.
35268 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35269 *-- Author :    Peter Richardson
35270 C-----------------------------------------------------------------------
35271       SUBROUTINE HWHS15(ID,ME)
35272 C-----------------------------------------------------------------------
35273 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35274 C  section gluon gluon --> fermion antifermion (2st colour flow)
35275 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
35276 C  This diagram 5 from DAMTP-2001-83 with opposite helicity for 4
35277 C  and gauge choice L1=2 L2=1
35278 C-----------------------------------------------------------------------
35279       INCLUDE 'HERWIG65.INC'
35280       INTEGER NDIAHD
35281       PARAMETER(NDIAHD=10)
35282       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35283      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
35284      &     FUP(2,2,8,8),FUM(2,2,8,8)
35285       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35286      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35287       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35288       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST, A,B,MS,MWD,MR,MA,
35289      &    MA2,SH,TH,UH,IDP,DRTYPE
35290       PARAMETER(ZI=(0.0D0,1.0D0))
35291       COMMON/HWHEWS/S(8,8,2),D(8,8)
35292       DATA O/2,1/
35293 C--compute the propagator factor
35294       PRE =-ONE/(UH-MS(ID))/SH
35295 C--matrix element
35296       DO 10 P1=1,2
35297       DO 10 P2=1,2
35298       DO 10 P3=1,2
35299       DO 10 P4=1,2
35300  10   ME(P1,P2,P3,P4) = PRE*(
35301      & F3(O(P3),  P2 ,1)*( FUP(  P2 ,  P1 ,2,2)*F4(  P1 ,P4,1)
35302      &                    +FUP(  P2 ,O(P1),2,1)*F4(O(P1),P4,2))
35303      &+F3(O(P3),O(P2),2)*( FUP(O(P2),  P1 ,1,2)*F4(  P1 ,P4,1)
35304      &                    +FUP(O(P2),O(P1),1,1)*F4(O(P1),P4,2)))
35305       END
35306 CDECK  ID>, HWHS16.
35307 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35308 *-- Author :    Peter Richardson
35309 C-----------------------------------------------------------------------
35310       SUBROUTINE HWHS16(ID,ME)
35311 C-----------------------------------------------------------------------
35312 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35313 C  section gluon gluon --> fermion antifermion (triple gluon piece)
35314 C  N.B. a gauge choice has been made to simplify the triple gluon vertex
35315 C  This diagram 6 from DAMTP-2001-83 with opposite helicity for 4
35316 C  and gauge choice L1=2 L2=1
35317 C-----------------------------------------------------------------------
35318       INCLUDE 'HERWIG65.INC'
35319       INTEGER NDIAHD
35320       PARAMETER(NDIAHD=10)
35321       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35322      &     ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
35323      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35324       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35325      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35326       INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35327       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35328      &     MA2,SH,TH,UH,IDP,DRTYPE
35329       PARAMETER(ZI=(0.0D0,1.0D0))
35330       COMMON/HWHEWS/S(8,8,2),D(8,8)
35331       DATA O/2,1/
35332 C--compute the propagator factor
35333       PRE = HALF/SH**2
35334 C--matrix element
35335       DO 10 P3=1,2
35336       DO 10 P4=1,2
35337       MET = (0.0D0,0.0D0)
35338       DO 5 I=1,2
35339  5    MET=MET+F3(O(P3),I,1)*F4(I,P4,1)-F3(O(P3),I,2)*F4(I,P4,2)
35340       DO 10 P1=1,2
35341       DO 10 P2=1,2
35342       IF(P1.EQ.P2) THEN
35343         ME(P1,P2,P3,P4) = PRE*MET*S(1,2,P1)*S(1,2,O(P1))
35344       ELSE
35345         ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35346       ENDIF
35347  10   CONTINUE
35348       END
35349 CDECK  ID>, HWHS17.
35350 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35351 *-- Author :    Peter Richardson
35352 C-----------------------------------------------------------------------
35353       SUBROUTINE HWHS17(ID,ME)
35354 C-----------------------------------------------------------------------
35355 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35356 C  section fermion fermion --> fermion fermion (t-channel boson)
35357 C  This diagram 13 from DAMTP-2001-83
35358 C-----------------------------------------------------------------------
35359       INCLUDE 'HERWIG65.INC'
35360       INTEGER NDIAHD
35361       PARAMETER(NDIAHD=10)
35362       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35363      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35364      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
35365       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35366      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35367       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35368       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35369      &     MA2,SH,TH,UH,IDP,DRTYPE
35370       PARAMETER(ZI=(0.0D0,1.0D0))
35371       COMMON/HWHEWS/S(8,8,2),D(8,8)
35372       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35373       DATA O/2,1/
35374       EXTERNAL HWULDO
35375       DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
35376 C--compute the propagator factor
35377       PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
35378       DO 10 P1=1,2
35379       DO 10 P2=1,2
35380       DO 10 P3=1,2
35381       DO 10 P4=1,2
35382         IF(P2.EQ.P4) THEN
35383           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
35384      &          ( DL(P1,O(P2))*F3(O(P3),  P2 ,2)*S(4,1,  P2 )
35385      &           +DL(P1,  P2 )*F3(O(P3),O(P2),4)*S(2,1,O(P2)))
35386         ELSE
35387           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35388         ENDIF
35389  10   CONTINUE
35390       END
35391 CDECK  ID>, HWHS18.
35392 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35393 *-- Author :    Peter Richardson
35394 C-----------------------------------------------------------------------
35395       SUBROUTINE HWHS18(ID,ME)
35396 C-----------------------------------------------------------------------
35397 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35398 C  section fermion antifermion --> fermion antifermion (t-channel boson)
35399 C  This diagram 14 from DAMTP-2001-83
35400 C-----------------------------------------------------------------------
35401       INCLUDE 'HERWIG65.INC'
35402       INTEGER NDIAHD
35403       PARAMETER(NDIAHD=10)
35404       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35405      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35406      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
35407       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35408      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35409       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35410       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35411      &     MA2,SH,TH,UH,IDP,DRTYPE
35412       PARAMETER(ZI=(0.0D0,1.0D0))
35413       COMMON/HWHEWS/S(8,8,2),D(8,8)
35414       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35415       DATA O/2,1/
35416       EXTERNAL HWULDO
35417       DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
35418 C--compute the propagator factor
35419       PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
35420       DO 10 P1=1,2
35421       DO 10 P2=1,2
35422       DO 10 P3=1,2
35423       DO 10 P4=1,2
35424         IF(P2.EQ.P4) THEN
35425           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
35426      &          ( DL(P1,O(P2))*F3(O(P3),  P2 ,4)*S(2,1,  P2 )
35427      &           +DL(P1,  P2 )*F3(O(P3),O(P2),2)*S(4,1,O(P2)))
35428         ELSE
35429           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35430         ENDIF
35431  10   CONTINUE
35432       END
35433 CDECK  ID>, HWHS19.
35434 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35435 *-- Author :    Peter Richardson
35436 C-----------------------------------------------------------------------
35437       SUBROUTINE HWHS19(ID,ME)
35438 C-----------------------------------------------------------------------
35439 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35440 C  section antifermion fermion --> antifermion fermion (t-channel boson)
35441 C  This diagram 15 from DAMTP-2001-83
35442 C-----------------------------------------------------------------------
35443       INCLUDE 'HERWIG65.INC'
35444       INTEGER NDIAHD
35445       PARAMETER(NDIAHD=10)
35446       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35447      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35448      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
35449       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35450      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35451       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35452       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35453      &     MA2,SH,TH,UH,IDP,DRTYPE
35454       PARAMETER(ZI=(0.0D0,1.0D0))
35455       COMMON/HWHEWS/S(8,8,2),D(8,8)
35456       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35457       DATA O/2,1/
35458       EXTERNAL HWULDO
35459       DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
35460 C--compute the propagator factor
35461       PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
35462       DO 10 P1=1,2
35463       DO 10 P2=1,2
35464       DO 10 P3=1,2
35465       DO 10 P4=1,2
35466         IF(P2.EQ.P4) THEN
35467           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
35468      &          ( DL(P1,O(P2))*S(1,2,  P1 )*F3M(  P2 ,O(P3),4)
35469      &           +DL(P1,  P2 )*S(1,4,  P1 )*F3M(O(P2),O(P3),2))
35470         ELSE
35471           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35472         ENDIF
35473  10   CONTINUE
35474       END
35475 CDECK  ID>, HWHS20.
35476 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35477 *-- Author :    Peter Richardson
35478 C-----------------------------------------------------------------------
35479       SUBROUTINE HWHS20(ID,ME)
35480 C-----------------------------------------------------------------------
35481 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35482 C  section antifermion fermion --> antifermion fermion (t-channel boson)
35483 C  This diagram 16 from DAMTP-2001-83
35484 C-----------------------------------------------------------------------
35485       INCLUDE 'HERWIG65.INC'
35486       INTEGER NDIAHD
35487       PARAMETER(NDIAHD=10)
35488       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
35489      &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35490      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
35491       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35492      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
35493       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35494       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35495      &     MA2,SH,TH,UH,IDP,DRTYPE
35496       PARAMETER(ZI=(0.0D0,1.0D0))
35497       COMMON/HWHEWS/S(8,8,2),D(8,8)
35498       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
35499       DATA O/2,1/
35500       EXTERNAL HWULDO
35501       DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
35502 C--compute the propagator factor
35503       PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
35504       DO 10 P1=1,2
35505       DO 10 P2=1,2
35506       DO 10 P3=1,2
35507       DO 10 P4=1,2
35508         IF(P2.EQ.P4) THEN
35509           ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
35510      &          ( DL(P1,O(P2))*S(1,4,  P1 )*F3M(  P2 ,O(P3),2)
35511      &           +DL(P1,  P2 )*S(1,2,  P1 )*F3M(O(P2),O(P3),4))
35512         ELSE
35513           ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
35514         ENDIF
35515  10   CONTINUE
35516       END
35517 CDECK  ID>, HWHS21.
35518 *CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
35519 *-- Author :    Peter Richardson
35520 C-----------------------------------------------------------------------
35521       SUBROUTINE HWHS21(ID,ME)
35522 C-----------------------------------------------------------------------
35523 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35524 C  section  f fbar ---> f fbar via s-channel scalar exchange
35525 C  This is diagram 1 from RPV notes
35526 C-----------------------------------------------------------------------
35527       INCLUDE 'HERWIG65.INC'
35528       INTEGER NDIAHD
35529       PARAMETER(NDIAHD=10)
35530       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35531      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35532      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35533       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35534      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35535       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35536       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35537      &     MA2,SH,TH,UH,IDP,DRTYPE
35538       COMMON/HWHEWS/S(8,8,2),D(8,8)
35539       DATA O/2,1/
35540       PARAMETER(ZI=(0.0D0,1.0D0))
35541 C--compute the propagator factor
35542       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35543       DO 10 P1=1,2
35544       DO 10 P3=1,2
35545       DO 10 P4=1,2
35546       ME(P1,  P1 ,P3,P4) = (0.0D0,0.0D0)
35547  10   ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
35548      &     ( B(  P4 ,ID)*F3(O(P3),  P4 ,4)*S(4,8,P4)
35549      &      -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
35550       END
35551 CDECK  ID>, HWHS22.
35552 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35553 *-- Author :    Peter Richardson
35554 C-----------------------------------------------------------------------
35555       SUBROUTINE HWHS22(ID,ME)
35556 C-----------------------------------------------------------------------
35557 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35558 C  section  f fbar ---> f fbar via t-channel scalar exchange
35559 C  This is diagram 2 from RPV notes
35560 C-----------------------------------------------------------------------
35561       INCLUDE 'HERWIG65.INC'
35562       INTEGER NDIAHD
35563       PARAMETER(NDIAHD=10)
35564       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35565      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35566      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35567       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35568      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35569       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35570       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35571      &     MA2,SH,TH,UH,IDP,DRTYPE
35572       COMMON/HWHEWS/S(8,8,2),D(8,8)
35573       DATA O/2,1/
35574 C--compute the propagator factor
35575       PRE = -HALF/(TH-MS(ID))
35576       DO 10 P1=1,2
35577       DO 10 P2=1,2
35578       DO 10 P3=1,2
35579       DO 10 P4=1,2
35580  10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(  P1 ,ID)*
35581      &                  F4(P2,O(P4),2)*F3(O(P3),P1,1)
35582       END
35583 CDECK  ID>, HWHS23.
35584 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35585 *-- Author :    Peter Richardson
35586 C-----------------------------------------------------------------------
35587       SUBROUTINE HWHS23(ID,ME)
35588 C-----------------------------------------------------------------------
35589 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35590 C  section  f fbar ---> fermion fermion via t-channel scalar exchange
35591 C  This is diagram 3 from RPV notes
35592 C-----------------------------------------------------------------------
35593       INCLUDE 'HERWIG65.INC'
35594       INTEGER NDIAHD
35595       PARAMETER(NDIAHD=10)
35596       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35597      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35598      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35599       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35600      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35601       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35602       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35603      &     MA2,SH,TH,UH,IDP,DRTYPE
35604       COMMON/HWHEWS/S(8,8,2),D(8,8)
35605       DATA O/2,1/
35606 C--compute the propagator factor
35607       PRE = HALF/(UH-MS(ID))
35608       DO 10 P1=1,2
35609       DO 10 P2=1,2
35610       DO 10 P3=1,2
35611       DO 10 P4=1,2
35612  10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(  P1 ,ID)*
35613      &                  F4M(P4,P1,1)*F3M(P2,P3,2)
35614       END
35615 CDECK  ID>, HWHS24.
35616 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35617 *-- Author :    Peter Richardson
35618 C-----------------------------------------------------------------------
35619       SUBROUTINE HWHS24(ID,ME)
35620 C-----------------------------------------------------------------------
35621 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35622 C  section  f fbar ---> f f via s-channel scalar exchange
35623 C  This is diagram 4 from RPV notes
35624 C-----------------------------------------------------------------------
35625       INCLUDE 'HERWIG65.INC'
35626       INTEGER NDIAHD
35627       PARAMETER(NDIAHD=10)
35628       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35629      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35630      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35631       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35632      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35633       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35634       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35635      &     MA2,SH,TH,UH,IDP,DRTYPE
35636       COMMON/HWHEWS/S(8,8,2),D(8,8)
35637       DATA O/2,1/
35638       PARAMETER(ZI=(0.0D0,1.0D0))
35639 C--compute the propagator factor
35640       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35641       DO 10 P1=1,2
35642       DO 10 P3=1,2
35643       DO 10 P4=1,2
35644       ME(P1,  P1 ,P3,P4) = (0.0D0,0.0D0)
35645  10   ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
35646      &                    ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
35647      &                     -B(  P3 ,ID)*F4M(O(P4),  P3 ,7)*MA(3))
35648       END
35649 CDECK  ID>, HWHS25.
35650 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35651 *-- Author :    Peter Richardson
35652 C-----------------------------------------------------------------------
35653       SUBROUTINE HWHS25(ID,ME)
35654 C-----------------------------------------------------------------------
35655 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35656 C  section  f fbar ---> f f via u-channel scalar exchange
35657 C  This is diagram 5 from RPV notes
35658 C-----------------------------------------------------------------------
35659       INCLUDE 'HERWIG65.INC'
35660       INTEGER NDIAHD
35661       PARAMETER(NDIAHD=10)
35662       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35663      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35664      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35665       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35666      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35667       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35668       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35669      &     MA2,SH,TH,UH,IDP,DRTYPE
35670       COMMON/HWHEWS/S(8,8,2),D(8,8)
35671       DATA O/2,1/
35672 C--compute the propagator factor
35673       PRE = -HALF/(UH-MS(ID))
35674       DO 10 P1=1,2
35675       DO 10 P2=1,2
35676       DO 10 P3=1,2
35677       DO 10 P4=1,2
35678  10   ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
35679      &                  F4M(O(P4),P1,1)*F3M(P2,P3,2)
35680       END
35681 CDECK  ID>, HWHS26.
35682 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35683 *-- Author :    Peter Richardson
35684 C-----------------------------------------------------------------------
35685       SUBROUTINE HWHS26(ID,ME)
35686 C-----------------------------------------------------------------------
35687 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35688 C  section  f fbar ---> f f via t-channel scalar exchange
35689 C  This is diagram 6 from RPV notes
35690 C-----------------------------------------------------------------------
35691       INCLUDE 'HERWIG65.INC'
35692       INTEGER NDIAHD
35693       PARAMETER(NDIAHD=10)
35694       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35695      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35696      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35697       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35698      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35699       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35700       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35701      &     MA2,SH,TH,UH,IDP,DRTYPE
35702       COMMON/HWHEWS/S(8,8,2),D(8,8)
35703       DATA O/2,1/
35704 C--compute the propagator factor
35705       PRE = HALF/(TH-MS(ID))
35706       DO 10 P1=1,2
35707       DO 10 P2=1,2
35708       DO 10 P3=1,2
35709       DO 10 P4=1,2
35710  10   ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
35711      &                  F4(P2,P4,2)*F3(O(P3),P1,1)
35712       END
35713 CDECK  ID>, HWHS27.
35714 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35715 *-- Author :    Peter Richardson
35716 C-----------------------------------------------------------------------
35717       SUBROUTINE HWHS27(ID,ME)
35718 C-----------------------------------------------------------------------
35719 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35720 C  section  f f ---> f fbar via s-channel scalar exchange
35721 C  This is diagram 7 from RPV notes
35722 C-----------------------------------------------------------------------
35723       INCLUDE 'HERWIG65.INC'
35724       INTEGER NDIAHD
35725       PARAMETER(NDIAHD=10)
35726       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35727      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35728      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35729       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35730      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35731       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35732       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35733      &     MA2,SH,TH,UH,IDP,DRTYPE
35734       COMMON/HWHEWS/S(8,8,2),D(8,8)
35735       DATA O/2,1/
35736       PARAMETER(ZI=(0.0D0,1.0D0))
35737 C--compute the propagator factor
35738       PRE =-HALF/(SH-MS(ID)+ZI*MWD(ID))
35739       DO 10 P1=1,2
35740       DO 10 P3=1,2
35741       DO 10 P4=1,2
35742       ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
35743  10   ME(P1,  P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
35744      &     ( B(  P4 ,ID)*F3(O(P3),  P4 ,4)*S(4,8,P4)
35745      &      -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
35746       END
35747 CDECK  ID>, HWHS28.
35748 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35749 *-- Author :    Peter Richardson
35750 C-----------------------------------------------------------------------
35751       SUBROUTINE HWHS28(ID,ME)
35752 C-----------------------------------------------------------------------
35753 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35754 C  section  f f ---> f fbar via t-channel scalar exchange
35755 C  This is diagram 8 from RPV notes
35756 C-----------------------------------------------------------------------
35757       INCLUDE 'HERWIG65.INC'
35758       INTEGER NDIAHD
35759       PARAMETER(NDIAHD=10)
35760       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35761      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35762      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35763       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35764      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35765       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35766       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35767      &     MA2,SH,TH,UH,IDP,DRTYPE
35768       COMMON/HWHEWS/S(8,8,2),D(8,8)
35769       DATA O/2,1/
35770       PARAMETER(ZI=(0.0D0,1.0D0))
35771 C--compute the propagator factor
35772       PRE = -HALF/(TH-MS(ID))
35773       DO 10 P1=1,2
35774       DO 10 P2=1,2
35775       DO 10 P3=1,2
35776       DO 10 P4=1,2
35777  10   ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A(  P1 ,ID)*
35778      &                  F4(O(P2),O(P4),2)*F3(O(P3),P1,1)
35779       END
35780 CDECK  ID>, HWHS29.
35781 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35782 *-- Author :    Peter Richardson
35783 C-----------------------------------------------------------------------
35784       SUBROUTINE HWHS29(ID,ME)
35785 C-----------------------------------------------------------------------
35786 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35787 C  section  f f ---> f fbar via u-channel scalar exchange
35788 C  This is diagram 9 from RPV notes
35789 C-----------------------------------------------------------------------
35790       INCLUDE 'HERWIG65.INC'
35791       INTEGER NDIAHD
35792       PARAMETER(NDIAHD=10)
35793       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35794      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35795      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35796       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35797      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35798       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35799       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35800      &     MA2,SH,TH,UH,IDP,DRTYPE
35801       COMMON/HWHEWS/S(8,8,2),D(8,8)
35802       DATA O/2,1/
35803       PARAMETER(ZI=(0.0D0,1.0D0))
35804 C--compute the propagator factor
35805       PRE = HALF/(UH-MS(ID))
35806       DO 10 P1=1,2
35807       DO 10 P2=1,2
35808       DO 10 P3=1,2
35809       DO 10 P4=1,2
35810  10   ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A(P1,ID)*
35811      &                  F3(O(P3),P2,2)*F4(O(P1),O(P4),1)
35812       END
35813 CDECK  ID>, HWHS30.
35814 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35815 *-- Author :    Peter Richardson
35816 C-----------------------------------------------------------------------
35817       SUBROUTINE HWHS30(ID,ME)
35818 C-----------------------------------------------------------------------
35819 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35820 C  section  fbar fbar ---> f f via s-channel scalar exchange
35821 C  This is diagram 10 from RPV notes
35822 C-----------------------------------------------------------------------
35823       INCLUDE 'HERWIG65.INC'
35824       INTEGER NDIAHD
35825       PARAMETER(NDIAHD=10)
35826       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35827      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35828      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35829       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35830      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35831       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35832       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35833      &     MA2,SH,TH,UH,IDP,DRTYPE
35834       COMMON/HWHEWS/S(8,8,2),D(8,8)
35835       DATA O/2,1/
35836       PARAMETER(ZI=(0.0D0,1.0D0))
35837 C--compute the propagator factor
35838       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35839       DO 10 P1=1,2
35840       DO 10 P3=1,2
35841       DO 10 P4=1,2
35842       ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
35843  10   ME(P1,  P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
35844      &                    ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
35845      &                     -B(  P3 ,ID)*F4M(O(P4),  P3 ,7)*MA(3))
35846       END
35847 CDECK  ID>, HWHS31.
35848 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35849 *-- Author :    Peter Richardson
35850 C-----------------------------------------------------------------------
35851       SUBROUTINE HWHS31(ID,ME)
35852 C-----------------------------------------------------------------------
35853 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35854 C  section  fbar fbar ---> f f via t-channel scalar exchange
35855 C  This is diagram 11 from RPV notes
35856 C-----------------------------------------------------------------------
35857       INCLUDE 'HERWIG65.INC'
35858       INTEGER NDIAHD
35859       PARAMETER(NDIAHD=10)
35860       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35861      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35862      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35863       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35864      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35865       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35866       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35867      &     MA2,SH,TH,UH,IDP,DRTYPE
35868       COMMON/HWHEWS/S(8,8,2),D(8,8)
35869       DATA O/2,1/
35870       PARAMETER(ZI=(0.0D0,1.0D0))
35871 C--compute the propagator factor
35872       PRE = HALF/(TH-MS(ID))
35873       DO 10 P1=1,2
35874       DO 10 P2=1,2
35875       DO 10 P3=1,2
35876       DO 10 P4=1,2
35877  10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
35878      &                  F4M(O(P4),O(P2),2)*F3M(P1,P3,1)
35879       END
35880 CDECK  ID>, HWHS32.
35881 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35882 *-- Author :    Peter Richardson
35883 C-----------------------------------------------------------------------
35884       SUBROUTINE HWHS32(ID,ME)
35885 C-----------------------------------------------------------------------
35886 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35887 C  section  fbar fbar ---> f f via u-channel scalar exchange
35888 C  This is diagram 12 from RPV notes
35889 C-----------------------------------------------------------------------
35890       INCLUDE 'HERWIG65.INC'
35891       INTEGER NDIAHD
35892       PARAMETER(NDIAHD=10)
35893       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35894      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35895      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35896       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35897      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35898       INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35899       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35900      &     MA2,SH,TH,UH,IDP,DRTYPE
35901       COMMON/HWHEWS/S(8,8,2),D(8,8)
35902       DATA O/2,1/
35903       PARAMETER(ZI=(0.0D0,1.0D0))
35904 C--compute the propagator factor
35905       PRE =-HALF/(UH-MS(ID))
35906       DO 10 P1=1,2
35907       DO 10 P2=1,2
35908       DO 10 P3=1,2
35909       DO 10 P4=1,2
35910  10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
35911      &                   F4M(O(P4),O(P1),1)*F3M(P2,P3,2)
35912       END
35913 CDECK  ID>, HWHS33.
35914 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35915 *-- Author :    Peter Richardson
35916 C-----------------------------------------------------------------------
35917       SUBROUTINE HWHS33(ID,ME)
35918 C-----------------------------------------------------------------------
35919 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35920 C  section  f f ---> f f via s-channel scalar exchange
35921 C  This is diagram 13 from RPV
35922 C-----------------------------------------------------------------------
35923       INCLUDE 'HERWIG65.INC'
35924       INTEGER NDIAHD
35925       PARAMETER(NDIAHD=10)
35926       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35927      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35928      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35929       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35930      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35931       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35932       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35933      &     MA2,SH,TH,UH,IDP,DRTYPE
35934       COMMON/HWHEWS/S(8,8,2),D(8,8)
35935       DATA O/2,1/
35936       PARAMETER(ZI=(0.0D0,1.0D0))
35937 C--compute the propagator factor
35938       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35939       DO 10 P1=1,2
35940       DO 10 P3=1,2
35941       DO 10 P4=1,2
35942       ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
35943  10   ME(P1,  P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
35944      &     ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
35945      &      -B(  P3 ,ID)*F4M(O(P4),  P3 ,7)*MA(3))
35946       END
35947 CDECK  ID>, HWHS34.
35948 *CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
35949 *-- Author :    Peter Richardson
35950 C-----------------------------------------------------------------------
35951       SUBROUTINE HWHS34(ID,ME)
35952 C-----------------------------------------------------------------------
35953 C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35954 C  section  fbar fbar ---> fbar fbar via t-channel scalar exchange
35955 C  This is diagram 14 from RPV notes
35956 C-----------------------------------------------------------------------
35957       INCLUDE 'HERWIG65.INC'
35958       INTEGER NDIAHD
35959       PARAMETER(NDIAHD=10)
35960       DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35961      &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
35962      &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35963       DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35964      &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35965       INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35966       COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35967      &     MA2,SH,TH,UH,IDP,DRTYPE
35968       COMMON/HWHEWS/S(8,8,2),D(8,8)
35969       DATA O/2,1/
35970       PARAMETER(ZI=(0.0D0,1.0D0))
35971 C--compute the propagator factor
35972       PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
35973       DO 10 P1=1,2
35974       DO 10 P3=1,2
35975       DO 10 P4=1,2
35976       ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
35977  10   ME(P1,  P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
35978      &     ( B(  P4 ,ID)*F3(P3,  P4 ,4)*S(4,8,P4)
35979      &      -B(O(P4),ID)*F3(P3,O(P4),8)*MA(4))
35980       END
35981 CDECK  ID>, HWHSS1.
35982 *CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
35983 *-- Author :    Kosuke Odagiri
35984 C-----------------------------------------------------------------------
35985       FUNCTION HWHSS1(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
35986 C-----------------------------------------------------------------------
35987 C     QQ(BAR) -> GAUGINOS
35988 C-----------------------------------------------------------------------
35989       IMPLICIT NONE
35990       DOUBLE PRECISION HWHSS1, S, T, U, M3, M4, SGN
35991       DOUBLE COMPLEX CLL, CLR, CRL, CRR
35992       HWHSS1 = DREAL(
35993      & (DCONJG(CLL)*CLL+DCONJG(CRR)*CRR)*(U-M3*M3)*(U-M4*M4)+
35994      & (DCONJG(CLR)*CLR+DCONJG(CRL)*CRL)*(T-M3*M3)*(T-M4*M4)+
35995      & (DCONJG(CLL)*CLR+DCONJG(CRL)*CRR)*2.*SGN*M3*M4*S )
35996       RETURN
35997       END
35998 CDECK  ID>, HWHSS2.
35999 *CMZ :-        -10/10/01  10:38:15  by  Peter Richardson
36000 *-- Author :    Kosuke Odagiri
36001 C-----------------------------------------------------------------------
36002       FUNCTION HWHSS2(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
36003 C-----------------------------------------------------------------------
36004 C     LL(BAR) -> GAUGINOS (including beam polarization)
36005 C-----------------------------------------------------------------------
36006       INCLUDE 'HERWIG65.INC'
36007       DOUBLE PRECISION HWHSS2, S, T, U, M3, M4, SGN
36008       DOUBLE COMPLEX CLL, CLR, CRL, CRR
36009       HWHSS2 =
36010 C--first the incoming left electron
36011      & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DREAL(
36012      & DCONJG(CLL)*CLL*(U-M3*M3)*(U-M4*M4)+
36013      & DCONJG(CLR)*CLR*(T-M3*M3)*(T-M4*M4)+
36014      & DCONJG(CLL)*CLR*2.*SGN*M3*M4*S )
36015 C--then the incoming right electron
36016      &+(ONE+EPOLN(3))*(ONE-PPOLN(3))*DREAL(
36017      & DCONJG(CRR)*CRR*(U-M3*M3)*(U-M4*M4)+
36018      & DCONJG(CRL)*CRL*(T-M3*M3)*(T-M4*M4)+
36019      & DCONJG(CRL)*CRR*2.*SGN*M3*M4*S )
36020       RETURN
36021       END
36022 CDECK  ID>, HWHSSG.
36023 *CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
36024 *-- Author :    Kosuke Odagiri
36025 C-----------------------------------------------------------------------
36026       SUBROUTINE HWHSSG
36027 C-----------------------------------------------------------------------
36028 C     SUSY 2 PARTON -> 2 GAUGINOS PROCESSES        (1 - 3)
36029 C                   -> GAUGINO + SPARTON PROCESSES (4 - 7)
36030 C-----------------------------------------------------------------------
36031       INCLUDE 'HERWIG65.INC'
36032       DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS, DIST,
36033      & ML(6), ML2(6), MR(6), MR2(6), MCH(2), MCH2(2), MNU(4), MNU2(4),
36034      & MSQK, MG, MG2, SM, DM, DAB, QPE, SGN, PF, SQPE, EMSC2,
36035      & FAC0, FACA, FACB, FACC, S, T, T3, U, U4, SN2TH
36036       DOUBLE PRECISION M1(2,2,6), M2(4,4,6), M3(2,4,6,6),
36037      & M4(4,6), M5(2,6,6), M6L(4,6), M6R(4,6), M7(2,2,6,6),
36038      & XA(4), XB(4), XC(4), XD(4), MZ, MW, XW, SQXW, S2W, S22W
36039       INTEGER I, IQ, IQ1, IQ2, IQ3, IQ4, IG1, IG2, IG3, IG4,
36040      & ID1, ID2, IGL, SSL, SSR, GLU, SSNU, SSCH, INU, ICH, IWD(6), IPB
36041       DOUBLE PRECISION DQD(6), DQU(6), HWHSS1
36042       EXTERNAL HWRGEN, HWUALF, HWUAEM, HWHSS1
36043       SAVE HCS, M1, M2, M3, M4, M5, M6L, M6R, M7
36044       PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
36045       PARAMETER (SSNU = 449, SSCH = 453, INU = 49, ICH = 53)
36046       DOUBLE COMPLEX Z, Z0, C1, C2, C3, GZ, GW, CLL, CLR, CRL, CRR
36047       PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0))
36048       EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198)), (MG, RMASS(GLU))
36049       EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1))
36050       EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1))
36051       EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2))
36052       EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2))
36053       EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
36054       EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
36055       EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
36056       EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
36057       DATA IWD/2,1,4,3,6,5/
36058       DATA DQD/ONE,ZERO,ONE,ZERO,ONE,ZERO/
36059       DATA DQU/ZERO,ONE,ZERO,ONE,ZERO,ONE/
36060 C
36061       CALL    HWSGEN(.FALSE.)
36062       IF (GENEV) THEN
36063         RCS = HCS*HWRGEN(0)
36064       ELSE
36065         SN2TH = 0.25D0 - 0.25D0*COSTH**2
36066         S=XX(1)*XX(2)*PHEP(5,3)**2
36067         EMSC2 = EMSCA**2
36068         FAC0  = FACTSS*HWUAEM(EMSC2)
36069 c       prefactor for pair production, includes 1/Nc colour factor
36070         FACA  = FAC0*HWUAEM(EMSC2) / CAFAC
36071 c       prefactor for qq -> gaugino + gluino, includes CF/Nc colour factor
36072         FACB  = FAC0*HWUALF(1,EMSCA) * CFFAC / CAFAC
36073 c       prefactor for qg -> gaugino + squark, includes 1/2Nc colour factor
36074         FACC  = FACB / CFFAC / TWO
36075         MG2   = MG**2
36076         GZ    = S-MZ**2+Z*S/MZ*GAMZ
36077         GW    = S-MW**2+Z*S/MW*GAMW
36078         DO IQ = 1,6
36079           IQ1     = SSL + IQ
36080           IQ2     = SSR + IQ
36081           ML(IQ)  = RMASS(IQ1)
36082           ML2(IQ) = ML(IQ)**2
36083           MR(IQ)  = RMASS(IQ2)
36084           MR2(IQ) = MR(IQ)**2
36085         END DO
36086         XW    =   TWO * SWEIN
36087         SQXW  =   SQRT(XW)
36088         S22W  =   XW * (TWO - XW)
36089         S2W   =   SQRT(S22W)
36090         DO IG1 = 1,4
36091           MNU(IG1)  = RMASS(IG1+SSNU)
36092           MNU2(IG1) = MNU(IG1)**2
36093         END DO
36094         DO IG1 = 1,2
36095           MCH(IG1)  = RMASS(IG1+SSCH)
36096           MCH2(IG1) = MCH(IG1)**2
36097         END DO
36098 c       _     ~+ ~-
36099 c (1) q q  -> X  X
36100 c              a  b
36101         DO IG1 = 1,2
36102           DO IG2 = 1,2
36103             SM  = MCH(IG1) + MCH(IG2)
36104             QPE = S - SM**2
36105             IF (QPE.GE.ZERO) THEN
36106               DM   = MCH(IG1) - MCH(IG2)
36107               SQPE = SQRT(QPE*(S-DM**2))
36108               PF   = SQPE/S
36109               T    = (SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2)) / TWO
36110               U    = - T - S + MCH2(IG1) + MCH2(IG2)
36111               DAB  = ABS(FLOAT(IG1+IG2-3))
36112               C1   = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
36113               C2   = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
36114               SGN = WSGNSS(IG1)*WSGNSS(IG2)
36115 C--PR bug fix 31/03/00
36116               DO IQ = 1,6
36117                 C3 = -DAB*QFCH(IQ)/S
36118                 CLL = C3 - LFCH(IQ)*C1 +
36119      &        DQD(IQ)*WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-ML2(IWD(IQ)))*XW)
36120                 CLR = C3 - LFCH(IQ)*C2 -
36121      &        DQU(IQ)*WMXUSS(IG1,1)*WMXUSS(IG2,1)/((T-ML2(IWD(IQ)))*XW)
36122                 CRL = C3 - RFCH(IQ)*C1
36123                 CRR = C3 - RFCH(IQ)*C2
36124                 M1(IG1,IG2,IQ)=FACA*PF*
36125      &            HWHSS1(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
36126               END DO
36127 C--End of Fix
36128             ELSE
36129               DO IQ = 1,6
36130                 M1(IG1,IG2,IQ) = ZERO
36131               END DO
36132             END IF
36133           END DO
36134         END DO
36135 c       _     ~o ~o
36136 c (2) q q  -> X  X
36137 c              i  j
36138         DO IG1 = 1,4
36139           DO IG2 = 1,4
36140             SM   = MNU(IG1) + MNU(IG2)
36141             QPE  = S - SM**2
36142             IF (QPE.GE.ZERO) THEN
36143               DM   = MNU(IG1) - MNU(IG2)
36144               SQPE = SQRT(QPE*(S-DM**2))
36145               PF   = SQPE/S
36146               T    = (SQPE*COSTH - S + MNU2(IG1) + MNU2(IG2)) / TWO
36147               U    = - T - S + MNU2(IG1) + MNU2(IG2)
36148               C1   = (XD(IG1)*XD(IG2)-XC(IG1)*XC(IG2))/S2W/GZ
36149               C2   = - C1
36150               SGN  = ZSGNSS(IG1)*ZSGNSS(IG2)
36151               DO IQ = 1,6
36152                 CLL =LFCH(IQ)*C1+SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(U-ML2(IQ))
36153                 CLR =LFCH(IQ)*C2-SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(T-ML2(IQ))
36154                 CRL =RFCH(IQ)*C1-SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(T-MR2(IQ))
36155                 CRR =RFCH(IQ)*C2+SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(U-MR2(IQ))
36156                 M2(IG1,IG2,IQ) = FACA*PF*HALF*
36157      &            HWHSS1(S,T,U,MNU(IG1),MNU(IG2),SGN,CLL,CLR,CRL,CRR)
36158               END DO
36159             ELSE
36160               DO IQ = 1,6
36161                 M2(IG1,IG2,IQ) = ZERO
36162               END DO
36163             END IF
36164           END DO
36165         END DO
36166 c       _     ~+ ~o
36167 c (3) U D  -> X  X
36168 c              a  i
36169         DO IG1 = 1,2
36170           DO IG2 = 1,4
36171             SM  = MCH(IG1) + MNU(IG2)
36172             QPE = S - SM**2
36173             IF (QPE.GE.ZERO) THEN
36174               DM   = MCH(IG1) - MNU(IG2)
36175               SQPE = SQRT(QPE*(S-DM**2))
36176               PF   = SQPE/S
36177               T    = (SQPE*COSTH - S + MCH2(IG1) + MNU2(IG2)) / TWO
36178               U    = - T - S + MCH2(IG1) + MNU2(IG2)
36179               C1   = XA(IG2)+S2W/XW*XB(IG2)
36180 c note the new s-channel signs below. (PR BUG FIX 3/9/01)
36181               C2   = (-XD(IG2)*WMXVSS(IG1,2)/SQXW+C1*WMXVSS(IG1,1))/GW
36182               C3   = ( XC(IG2)*WMXUSS(IG1,2)/SQXW+C1*WMXUSS(IG1,1))/GW
36183               SGN = WSGNSS(IG1)*ZSGNSS(IG2)
36184               DO IQ1 = 1,3
36185                 IQ3 = IQ1*2
36186                 DO IQ2 = 1,3
36187                   IQ4 = IQ2*2-1
36188                   CLL = C2+WMXVSS(IG1,1)*SLFCH(IQ3,IG2)/(U-ML2(IQ3))
36189                   CLR = C3-WMXUSS(IG1,1)*SLFCH(IQ4,IG2)/(T-ML2(IQ4))
36190                   M3(IG1,IG2,IQ1,IQ2) = FACA*PF*VCKM(IQ1,IQ2)/XW*
36191      &              HWHSS1(S,T,U,MCH(IG1),MNU(IG2),SGN,CLL,CLR,Z0,Z0)
36192                 END DO
36193               END DO
36194             ELSE
36195               DO IQ1 = 1,3
36196                 DO IQ2 = 1,3
36197                   M3(IG1,IG2,IQ1,IQ2) = ZERO
36198                 END DO
36199               END DO
36200             END IF
36201           END DO
36202         END DO
36203 c       _     ~o ~
36204 c (4) q q  -> X  g
36205 c              i
36206         DO IG1 = 1,4
36207           SM   = MNU(IG1) + MG
36208           QPE  = S - SM**2
36209           IF (QPE.GE.ZERO) THEN
36210             DM   = MNU(IG1) - MG
36211             SQPE = SQRT(QPE*(S-DM**2))
36212             PF   = SQPE/S
36213             T    = (SQPE*COSTH - S + MG2 + MNU2(IG1)) / TWO
36214             U    = - T - S + MG2 + MNU2(IG1)
36215             DO IQ = 1,6
36216               CLL =   SLFCH(IQ,IG1)/(U-ML2(IQ))
36217               CLR = - SLFCH(IQ,IG1)/(T-ML2(IQ))
36218               CRL = - SRFCH(IQ,IG1)/(T-MR2(IQ))
36219               CRR =   SRFCH(IQ,IG1)/(U-MR2(IQ))
36220               M4(IG1,IQ) = FACB*PF*
36221      &          HWHSS1(S,T,U,MNU(IG1),MG,ZSGNSS(IG1),CLL,CLR,CRL,CRR)
36222             END DO
36223           ELSE
36224             DO IQ = 1,6
36225               M4(IG1,IQ) = ZERO
36226             END DO
36227           END IF
36228         END DO
36229 c       _     ~+ ~
36230 c (5) U D  -> X  g
36231 c              a
36232         DO IG1 = 1,2
36233           SM   = MCH(IG1) + MG
36234           QPE  = S - SM**2
36235           IF (QPE.GE.ZERO) THEN
36236             DM   = MCH(IG1) - MG
36237             SQPE = SQRT(QPE*(S-DM**2))
36238             PF   = SQPE/S
36239             T    = (SQPE*COSTH - S + MCH2(IG1) + MG2) / TWO
36240             U    = - T - S + MCH2(IG1) + MG2
36241             DO IQ1 = 1,3
36242               IQ3 = IQ1*2
36243               DO IQ2 = 1,3
36244                 IQ4 = IQ2*2-1
36245                 CLL =   WMXVSS(IG1,1)/(U-ML2(IQ3))
36246                 CLR = - WMXUSS(IG1,1)/(T-ML2(IQ4))
36247                 M5(IG1,IQ1,IQ2) = FACB*PF*VCKM(IQ1,IQ2)/XW*
36248      &            HWHSS1(S,T,U,MCH(IG1),MG,WSGNSS(IG1),CLL,CLR,Z0,Z0)
36249               END DO
36250             END DO
36251           ELSE
36252             DO IQ1 = 1,3
36253               DO IQ2 = 1,3
36254                 M5(IG1,IQ1,IQ2) = ZERO
36255               END DO
36256             END DO
36257           END IF
36258         END DO
36259 c             ~o ~
36260 c (6) g q  -> X  q
36261 c              i  LR
36262         DO IG1 = 1,4
36263           DO IQ = 1,6
36264 c           left squarks
36265             SM   = MNU(IG1)+ML(IQ)
36266             QPE  = S - SM**2
36267             IF (QPE.GE.ZERO) THEN
36268               DM   = MNU(IG1)-ML(IQ)
36269               SQPE = SQRT(QPE*(S-DM**2))
36270               PF   = SQPE/S
36271               T3   = (SQPE*COSTH - S - SM*DM) / TWO
36272               U4   = - T3 - S
36273 C--KO bug fix 06/10/00
36274               M6L(IG1,IQ) = FACC*PF*((QMIXSS(IQ,1,1)*SLFCH(IQ,IG1))**2
36275      &          +(QMIXSS(IQ,2,1)*SRFCH(IQ,IG1))**2)*
36276      &         T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
36277             ELSE
36278               M6L(IG1,IQ) = ZERO
36279             END IF
36280 c           right squarks
36281             SM   = MNU(IG1)+MR(IQ)
36282             QPE  = S - SM**2
36283             IF (QPE.GE.ZERO) THEN
36284               DM   = MNU(IG1)-MR(IQ)
36285               SQPE = SQRT(QPE*(S-DM**2))
36286               PF   = SQPE/S
36287               T3   = (SQPE*COSTH - S - SM*DM) / TWO
36288               U4   = - T3 - S
36289 C--PR bug fix 28/08/01
36290               M6R(IG1,IQ) = FACC*PF * ((QMIXSS(IQ,1,2)*SLFCH(IQ,IG1))**2
36291      &         +(QMIXSS(IQ,2,2)*SRFCH(IQ,IG1))**2)*
36292      &         T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
36293             ELSE
36294               M6R(IG1,IQ) = ZERO
36295             END IF
36296           END DO
36297         END DO
36298 c             ~+-~
36299 c (7) g q  -> X  q'
36300 c              a  L
36301         DO IG1 = 1,2
36302           DO IQ1 = 1,3
36303            IQ3 = IQ1*2
36304            DO IQ2 = 1,3
36305             IQ4 = IQ2*2-1
36306             DO I = 1,2
36307 c             U initiated processes
36308               IF (I.EQ.1) THEN
36309                 MSQK = ML(IQ4)
36310               ELSE
36311                 MSQK = MR(IQ4)
36312               END IF
36313               SM  = MCH(IG1) + MSQK
36314               QPE = S - SM**2
36315               IF (((I.EQ.1).OR.(IQ2.EQ.3)).AND.(QPE.GE.ZERO)) THEN
36316                 DM   = MCH(IG1) - MSQK
36317                 SQPE = SQRT(QPE*(S-DM**2))
36318                 PF   = SQPE/S
36319                 T3   = (SQPE*COSTH - S - SM*DM) / TWO
36320                 U4   = - T3 - S
36321                 M7(I,IG1,IQ3,IQ4)=FACC*PF*WMXUSS(IG1,1)**2*VCKM(IQ1,IQ2)
36322      &            /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
36323      &            QMIXSS(IQ4,1,I)**2
36324               ELSE
36325                 M7(I,IG1,IQ3,IQ4) = ZERO
36326               END IF
36327 c             D initiated processes
36328               IF (I.EQ.1) THEN
36329                 MSQK = ML(IQ3)
36330               ELSE
36331                 MSQK = MR(IQ3)
36332               END IF
36333               SM  = MCH(IG1) + MSQK
36334               QPE = S - SM**2
36335               IF (((I.EQ.1).OR.(IQ1.EQ.3)).AND.(QPE.GE.ZERO)) THEN
36336                 DM   = MCH(IG1) - MSQK
36337                 SQPE = SQRT(QPE*(S-DM**2))
36338                 PF   = SQPE/S
36339                 T3   = (SQPE*COSTH - S - SM*DM) / TWO
36340                 U4   = - T3 - S
36341                 M7(I,IG1,IQ4,IQ3)=FACC*PF*WMXVSS(IG1,1)**2*VCKM(IQ1,IQ2)
36342      &            /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
36343      &            QMIXSS(IQ3,1,I)**2
36344               ELSE
36345                 M7(I,IG1,IQ4,IQ3) = ZERO
36346               END IF
36347             END DO
36348            END DO
36349           END DO
36350         END DO
36351       END IF
36352       HCS = 0.
36353 c       _    _       ~+ ~-   ~o ~o   ~o ~
36354 c     q q ,  q q  -> X  X ,  X  X ,  X  g
36355 c                     a  b    i  j    i
36356       DO 1 ID1 = 1,12
36357       IF (DISF(ID1,1).LT.EPS) GOTO 1
36358       IF (ID1.GT.6) THEN
36359        ID2 = ID1 - 6
36360        IQ  = ID2
36361        IPB = 4132
36362       ELSE
36363        ID2 = ID1 + 6
36364        IQ  = ID1
36365        IPB = 2431
36366       END IF
36367       IF (DISF(ID2,2).LT.EPS) GOTO 1
36368       DIST = DISF(ID1,1)*DISF(ID2,2)
36369       DO IG1 = 1,2
36370         IG3 = ICH+IG1
36371         DO IG2 = 1,2
36372           IG4 = ICH+IG2+2
36373           HCS = HCS + DIST*M1(IG1,IG2,IQ)
36374 C--PR bug fix 10/10/01
36375           IF (GENEV.AND.HCS.GT.RCS) THEN
36376             IF(ID2.LT.ID1) COSTH=-COSTH
36377             CALL HWHSSS(IG3,0,IG4,0,2134,21,*9)
36378           ENDIF
36379         END DO
36380       END DO
36381       DO IG1 = 1,4
36382         IG3 = INU+IG1
36383         DO IG2 = 1,4
36384           IG4 = INU+IG2
36385           IF (IG2.GE.IG1) HCS = HCS + DIST*M2(IG1,IG2,IQ)
36386 C--PR bug fix 10/10/01
36387           IF (GENEV.AND.HCS.GT.RCS) THEN
36388             IF(ID2.LT.ID1) COSTH=-COSTH
36389             CALL HWHSSS(IG3,0,IG4,0,2134,22,*9)
36390           ENDIF
36391         END DO
36392         HCS = HCS + DIST*M4(IG1,IQ)
36393 C--PR bug fix 10/10/01
36394         IF (GENEV.AND.HCS.GT.RCS) THEN
36395           IF(ID2.LT.ID1) COSTH=-COSTH
36396           CALL HWHSSS(IG3,0,IGL,0, IPB,24,*9)
36397         ENDIF
36398       END DO
36399     1 CONTINUE
36400 c       _    _       ~+-~o   ~+-~
36401 c     q q',  q q' -> X  X ,  X  g
36402 c                     a  i    a
36403 c
36404 c      _     _       _     _
36405 c     ud(+), ud(-), du(-), du(+)
36406       DO 2 IQ1 = 1, 3
36407       DO IQ2 = 1, 3
36408       IF(VCKM(IQ1,IQ2).GT.EPS) THEN
36409 c      _
36410 c     ud (+)
36411        ID1 = IQ1 * 2
36412        ID2 = IQ2 * 2 + 5
36413        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36414         DIST = DISF(ID1,1)*DISF(ID2,2)
36415         DO IG1 = 1,2
36416          IG3 = ICH+IG1
36417          DO IG2 = 1,4
36418           IG4 = INU+IG2
36419           HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
36420           IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,23,*9)
36421          END DO
36422          HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
36423          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0,2431,25,*9)
36424         END DO
36425        END IF
36426 c     _
36427 c     du (+)
36428        ID1 = IQ2 * 2 + 5
36429        ID2 = IQ1 * 2
36430        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36431         DIST = DISF(ID1,1)*DISF(ID2,2)
36432         DO IG1 = 1,2
36433          IG3 = ICH+IG1
36434          DO IG2 = 1,4
36435           IG4 = INU+IG2
36436           HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
36437           IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IG3,0,2134,23,*9)
36438          END DO
36439          HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
36440          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IG3,0,3124,25,*9)
36441         END DO
36442        END IF
36443 c      _
36444 c     du (-)
36445        ID1 = IQ2 * 2 - 1
36446        ID2 = IQ1 * 2 + 6
36447        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36448         DIST = DISF(ID1,1)*DISF(ID2,2)
36449         DO IG1 = 1,2
36450          IG3 = ICH+IG1+2
36451          DO IG2 = 1,4
36452           IG4 = INU+IG2
36453           HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
36454           IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IG3,0,2134,23,*9)
36455          END DO
36456          HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
36457          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IG3,0,2314,25,*9)
36458         END DO
36459        END IF
36460 c     _
36461 c     ud (-)
36462        ID1 = IQ1 * 2 + 6
36463        ID2 = IQ2 * 2 - 1
36464        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36465         DIST = DISF(ID1,1)*DISF(ID2,2)
36466         DO IG1 = 1,2
36467          IG3 = ICH+IG1+2
36468          DO IG2 = 1,4
36469           IG4 = INU+IG2
36470           HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
36471           IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,23,*9)
36472          END DO
36473          HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
36474          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0,4132,25,*9)
36475         END DO
36476        END IF
36477       END IF
36478       END DO
36479     2 CONTINUE
36480 c              _           _       ~o ~    ~+-~
36481 c     g q ,  g q ,  q g ,  q g  -> X  q ,  X  q'
36482 c                                   i  LR   a  L
36483 c     neutralino
36484       DO IQ1 = 1,6
36485 c
36486 c      gq
36487        ID1 = 13
36488        ID2 = IQ1
36489        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36490         DIST = DISF(ID1,1)*DISF(ID2,2)
36491         DO IG1 = 1,4
36492          IG3 = INU+IG1
36493          HCS = HCS + DIST*M6L(IG1,IQ1)
36494          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,0,2431,26,*9)
36495          HCS = HCS + DIST*M6R(IG1,IQ1)
36496          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,2,2431,26,*9)
36497         END DO
36498        END IF
36499 c       _
36500 c      gq
36501        ID1 = 13
36502        ID2 = IQ1 + 6
36503        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36504         DIST = DISF(ID1,1)*DISF(ID2,2)
36505         DO IG1 = 1,4
36506          IG3 = INU+IG1
36507          HCS = HCS + DIST*M6L(IG1,IQ1)
36508          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,0,4132,26,*9)
36509          HCS = HCS + DIST*M6R(IG1,IQ1)
36510          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,2,4132,26,*9)
36511         END DO
36512        END IF
36513 c
36514 c      qg
36515        ID1 = IQ1
36516        ID2 = 13
36517        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36518         DIST = DISF(ID1,1)*DISF(ID2,2)
36519         DO IG1 = 1,4
36520          IG3 = INU+IG1
36521          HCS = HCS + DIST*M6L(IG1,IQ1)
36522          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,0,IG3,0,3124,26,*9)
36523          HCS = HCS + DIST*M6R(IG1,IQ1)
36524          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,2,IG3,0,3124,26,*9)
36525         END DO
36526        END IF
36527 c      _
36528 c      qg
36529        ID1 = IQ1 + 6
36530        ID2 = 13
36531        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36532         DIST = DISF(ID1,1)*DISF(ID2,2)
36533         DO IG1 = 1,4
36534          IG3 = INU+IG1
36535          HCS = HCS + DIST*M6L(IG1,IQ1)
36536          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,0,IG3,0,2314,26,*9)
36537          HCS = HCS + DIST*M6R(IG1,IQ1)
36538          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,2,IG3,0,2314,26,*9)
36539         END DO
36540        END IF
36541       END DO
36542 c     chargino
36543       DO IQ1 = 1,3
36544        IQ3 = IQ1*2
36545        DO 3 IQ2 = 1,3
36546         IF (VCKM(IQ1,IQ2).LT.EPS) GOTO 3
36547         IQ4 = IQ2*2-1
36548         DO IG1 = 1,2
36549          IG3 = ICH+IG1
36550          IG4 = ICH+IG1+2
36551 c
36552 c        gq & qg
36553          ID1 = 13
36554          ID2 = IQ3
36555          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
36556          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ4,0,2431,27,*9)
36557          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
36558          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ4,2,2431,27,*9)
36559          ID2 = IQ4
36560          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
36561          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ3,0,2431,27,*9)
36562          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
36563          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ3,2,2431,27,*9)
36564          ID1 = IQ3
36565          ID2 = 13
36566          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
36567          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,0,IG3,0,3124,27,*9)
36568          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
36569          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,2,IG3,0,3124,27,*9)
36570          ID1 = IQ4
36571          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
36572          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,0,IG4,0,3124,27,*9)
36573          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
36574          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,2,IG4,0,3124,27,*9)
36575 c         _   _
36576 c        gq & qg
36577          ID1 = 13
36578          ID2 = IQ3 + 6
36579          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
36580          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ4,1,4132,27,*9)
36581          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
36582          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ4,3,4132,27,*9)
36583          ID2 = IQ4 + 6
36584          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
36585          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ3,1,4132,27,*9)
36586          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
36587          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ3,3,4132,27,*9)
36588          ID1 = IQ3 + 6
36589          ID2 = 13
36590          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
36591          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,1,IG4,0,2314,27,*9)
36592          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
36593          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,3,IG4,0,2314,27,*9)
36594          ID1 = IQ4 + 6
36595          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
36596          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,1,IG3,0,2314,27,*9)
36597          HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
36598          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,3,IG3,0,2314,27,*9)
36599         END DO
36600     3  CONTINUE
36601       END DO
36602       EVWGT = HCS
36603       RETURN
36604 C---GENERATE EVENT
36605     9 IDN(1)=ID1
36606       IDN(2)=ID2
36607       IDCMF=15
36608       CALL HWETWO(.TRUE.,.TRUE.)
36609       IF (AZSPIN) THEN
36610 C Calculate coefficients for constructing spin density matrices
36611 C Set to zero for now
36612         CALL HWVZRO(7,GCOEF)
36613       END IF
36614   888 END
36615 CDECK  ID>, HWHSSL.
36616 *CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
36617 *-- Author :    Kosuke Odagiri
36618 C-----------------------------------------------------------------------
36619       SUBROUTINE HWHSSL
36620 C-----------------------------------------------------------------------
36621 C     SUSY 2 PARTON -> 2 SLEPTON PROCESSES
36622 C-----------------------------------------------------------------------
36623       INCLUDE 'HERWIG65.INC'
36624       DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
36625      & FACTR, SN2TH, MZ, MW, ME2(2,2,6,2), ME2W(2,3), EMSC2, GW2
36626       INTEGER IQ, IQ1, IQ2, ID1, ID2, IL, IL1, IL2, I, J
36627       EXTERNAL HWRGEN, HWUAEM
36628       SAVE HCS, ME2, ME2W
36629       PARAMETER (EPS = 1.D-9)
36630       DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
36631       PARAMETER (Z = (0.D0,1.D0))
36632       EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
36633 C
36634       S     = XX(1)*XX(2)*PHEP(5,3)**2
36635       EMSC2 = S
36636       EMSCA = SQRT(EMSC2)
36637       CALL    HWSGEN(.FALSE.)
36638       IF (GENEV) THEN
36639         RCS = HCS*HWRGEN(0)
36640       ELSE
36641         SN2TH = 0.25D0 - 0.25D0*COSTH**2
36642         FACTR = FACTSS*HWUAEM(EMSC2)**2/CAFAC*SN2TH
36643         GZ    = (S-MZ**2+Z*S*GAMZ/MZ)/S
36644         GW2   = ((ONE-MW**2/S)**2+(GAMW/MW)**2)*(TWO*SWEIN)**2
36645 c      _     ~  ~*
36646 c    q q  -> l  l
36647 c
36648         DO IL = 1,6
36649           DO I = 1,2
36650             DO J = 1,2
36651               IF (((I.NE.J).AND.(IL.NE.5)).OR.
36652      &            ((I.EQ.2).AND.(((IL/2)*2).EQ.IL))) THEN
36653                 QPE = -1.
36654               ELSE
36655                 ID1 = 412 + I*12 + IL
36656                 ID2 = 412 + J*12 + IL
36657                 IL1 = IL + 10
36658                 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
36659               END IF
36660               IF (QPE.GT.ZERO) THEN
36661                 PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
36662                 DO IQ = 1,2
36663                  A = QFCH(IL1)*QFCH(IQ)
36664                  BL = LFCH(IL1)/GZ
36665                  BR = RFCH(IL1)/GZ
36666                  CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
36667                  CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
36668                  D = (A+BL*LFCH(IQ))*CL+(A+BR*LFCH(IQ))*CR
36669                  E = (A+BL*RFCH(IQ))*CL+(A+BR*RFCH(IQ))*CR
36670                  ME2(I,J,IL,IQ)=FACTR*PF**3
36671      $                *DREAL(DCONJG(D)*D+DCONJG(E)*E)
36672                 END DO
36673               ELSE
36674                 ME2(I,J,IL,1)=ZERO
36675                 ME2(I,J,IL,2)=ZERO
36676               END IF
36677             END DO
36678           END DO
36679         END DO
36680 c      _     ~  ~*
36681 c    q q' -> l  v
36682 c
36683         DO IL = 1,3
36684          DO I = 1,2
36685           IF ((IL.NE.3).AND.(I.EQ.2)) THEN
36686             QPE = -1.
36687           ELSE
36688             ID1 = 411 + IL*2 + I*12
36689             ID2 = 424 + IL*2
36690             QPE = S-(RMASS(ID1)+RMASS(ID2))**2
36691           END IF
36692           IF (QPE.GT.ZERO) THEN
36693             PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
36694             ME2W(I,IL)=FACTR*PF**3/GW2
36695             IF (IL.EQ.3) ME2W(I,3)=ME2W(I,3)*LMIXSS(5,1,I)**2
36696           ELSE
36697             ME2W(I,IL)=ZERO
36698           END IF
36699          END DO
36700         END DO
36701       END IF
36702       HCS = 0.
36703 C
36704       DO 1 ID1 = 1, 12
36705        IF (DISF(ID1,1).LT.EPS) GOTO 1
36706        IF (ID1.GT.6) THEN
36707         ID2 = ID1 - 6
36708        ELSE
36709         ID2 = ID1 + 6
36710        END IF
36711        IQ  = ID1 - ((ID1-1)/2)*2
36712        IF (DISF(ID2,2).LT.EPS) GOTO 1
36713        DIST = DISF(ID1,1)*DISF(ID2,2)
36714        DO IL = 1,6
36715         DO I = 1,2
36716          DO J = 1,2
36717           IL1 = IL+I*12
36718           IL2 = IL+J*12
36719           HCS = HCS + DIST*ME2(I,J,IL,IQ)
36720           IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,2,IL2,3,2134,30,*9)
36721          END DO
36722         END DO
36723        END DO
36724     1 CONTINUE
36725 c      _     _       _     _
36726 c     ud(+), ud(-), du(-), du(+)
36727       DO 2 IQ1 = 1, 3
36728       DO IQ2 = 1, 3
36729       IF(VCKM(IQ1,IQ2).GT.EPS) THEN
36730 c      _
36731 c     ud (+)
36732        ID1 = IQ1 * 2
36733        ID2 = IQ2 * 2 + 5
36734        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36735         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
36736         DO IL = 1,3
36737          IL1 = IL*2-1
36738          IL2 = IL1+1
36739          HCS = HCS + DIST*ME2W(1,IL)
36740          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,5,IL2,4,2134,30,*9)
36741         END DO
36742         HCS = HCS + DIST*ME2W(2,3)
36743         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,7,6,4,2134,30,*9)
36744        END IF
36745 c     _
36746 c     du (+)
36747        ID1 = IQ2 * 2 + 5
36748        ID2 = IQ1 * 2
36749        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36750         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
36751         DO IL = 1,3
36752          IL1 = IL*2-1
36753          IL2 = IL1+1
36754          HCS = HCS + DIST*ME2W(1,IL)
36755          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,5,IL2,4,2134,30,*9)
36756         END DO
36757         HCS = HCS + DIST*ME2W(2,3)
36758         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,7,6,4,2134,30,*9)
36759        END IF
36760 c      _
36761 c     du (-)
36762        ID1 = IQ2 * 2 - 1
36763        ID2 = IQ1 * 2 + 6
36764        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36765         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
36766         DO IL = 1,3
36767          IL1 = IL*2-1
36768          IL2 = IL1+1
36769          HCS = HCS + DIST*ME2W(1,IL)
36770          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,4,IL2,5,2134,30,*9)
36771         END DO
36772         HCS = HCS + DIST*ME2W(2,3)
36773         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,6,6,5,2134,30,*9)
36774        END IF
36775 c     _
36776 c     ud (-)
36777        ID1 = IQ1 * 2 + 6
36778        ID2 = IQ2 * 2 - 1
36779        IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
36780         DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
36781         DO IL = 1,3
36782          IL1 = IL*2-1
36783          IL2 = IL1+1
36784          HCS = HCS + DIST*ME2W(1,IL)
36785          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,4,IL2,5,2134,30,*9)
36786         END DO
36787         HCS = HCS + DIST*ME2W(2,3)
36788         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,6,6,5,2134,30,*9)
36789        END IF
36790       END IF
36791       END DO
36792     2 CONTINUE
36793       EVWGT = HCS
36794       RETURN
36795 C---GENERATE EVENT
36796     9 IDN(1)=ID1
36797       IDN(2)=ID2
36798       IDCMF=15
36799       CALL HWETWO(.TRUE.,.TRUE.)
36800       IF (AZSPIN) THEN
36801 C Calculate coefficients for constructing spin density matrices
36802 C Set to zero for now
36803         CALL HWVZRO(7,GCOEF)
36804       END IF
36805       END
36806 CDECK  ID>, HWHSSQ.
36807 *CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
36808 *-- Author :    Kosuke Odagiri
36809 C-----------------------------------------------------------------------
36810       SUBROUTINE HWHSSQ
36811 C-----------------------------------------------------------------------
36812 C     SUSY HARD 2 PARTON -> 2 SPARTON PROCESSES
36813 C-----------------------------------------------------------------------
36814       INCLUDE 'HERWIG65.INC'
36815       DOUBLE PRECISION HWRGEN, HWUALF, EPS, HCS, RCS, DIST, NC, NC2,
36816      & NC2C, ML2(6), ML4(6), MR2(6), MR4(6), MG2, SM, DM, QPE,
36817      & SQPE, FACTR, AFAC, AF, BONE, CFAC, CFC2, CFC3, CONE,
36818      & CONN, CONT, CONU, CONL, CONR, DFAC, DONE, PF, S,
36819      & S2, TT, TT2, TMG, TMG2, UU, UU2, UMG, UMG2,
36820      & L, L2, TTML, UUML, R, R2, TTMR, UUMR, SN2TH
36821       DOUBLE PRECISION
36822      & AUSTLL(6),   AUSTRR(6),
36823      & ASTULL(6,6), ASTURR(6,6), ASTULR(6,6), ASTURL(6,6),
36824      & AUTSLL(6,6), AUTSRR(6,6), AUTSLR(6,6), AUTSRL(6,6),
36825      & BSTULL(6),   BSTURR(6),   BSTULR(6),   BSTURL(6),
36826      & BSUTLL(6),   BSUTRR(6),   BSUTLR(6),   BSUTRL(6),
36827      & BUTSLL(6),   BUTSRR(6),   BUTSLR(6),   BUTSRL(6),
36828      & BUSTLL(6),   BUSTRR(6),   BUSTLR(6),   BUSTRL(6),
36829      & CSTU(6), CSUT(6), CSTUL(6), CSTUR(6), CSUTL(6), CSUTR(6),
36830      & CTSUL(6), CTSUR(6), CTUSL(6), CTUSR(6), DUTS, DTSU, DSTU
36831       INTEGER IQ, IQ1, IQ2, ID1, ID2, ID2MIN, IGL, SSL, SSR, GLU
36832       EXTERNAL HWRGEN, HWUALF
36833       SAVE HCS, AUSTLL, AUSTRR, ASTULL, ASTURR, ASTULR, ASTURL,
36834      & AUTSLL, AUTSRR, AUTSLR, AUTSRL, BSTULL, BSTURR, BSTULR,
36835      & BSTURL, BSUTLL, BSUTRR, BSUTLR, BSUTRL, BUTSLL, BUTSRR, BUTSLR,
36836      & BUTSRL, BUSTLL, BUSTRR, BUSTLR, BUSTRL, CSTU, CSUT, CSTUL, CSTUR,
36837      & CSUTL, CSUTR, CTSUL, CTSUR, CTUSL, CTUSR, DUTS, DTSU, DSTU
36838       PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
36839       CALL    HWSGEN(.FALSE.)
36840       IF (GENEV) THEN
36841         RCS = HCS*HWRGEN(0)
36842       ELSE
36843         SN2TH = 0.25D0 - 0.25D0*COSTH**2
36844         S     = XX(1)*XX(2)*PHEP(5,3)**2
36845         FACTR = FACTSS*HWUALF(1,EMSCA)**2
36846         NC    = CAFAC
36847         NC2   = NC**2
36848         NC2C  = ONE - ONE/NC2
36849         AFAC  = FACTR*NC2C/FOUR
36850         CFAC  = FACTR*CFFAC/FOUR
36851         CFC2  = FACTR/CFFAC/FOUR
36852         CFC3  = FACTR/FOUR
36853         DFAC  = FACTR/NC2C
36854         S2    = S**2
36855         MG2   = RMASS(GLU)**2
36856         DO 10 IQ = 1, 6
36857           IQ1     = SSL + IQ
36858           IQ2     = SSR + IQ
36859           ML2(IQ) = RMASS(IQ1)**2
36860           ML4(IQ) = ML2(IQ)**2
36861           MR2(IQ) = RMASS(IQ2)**2
36862           MR4(IQ) = MR2(IQ)**2
36863    10   CONTINUE
36864 c     gluino pair production
36865         QPE  = S - FOUR*MG2
36866         IF (QPE.GE.ZERO) THEN
36867           SQPE = SQRT(S*QPE)
36868           PF   = SQPE/S
36869           TT   = (SQPE*COSTH - S) / TWO
36870           TT2  = TT**2
36871           UU   = - S - TT
36872           UU2  = UU**2
36873 c            ~ ~
36874 c     g g -> g g
36875 c
36876           DONE =
36877      &     DFAC*PF/TWO*(UU2+TT2+FOUR*MG2*S*SQPE**2*SN2TH/TT/UU)/S2/TT/UU
36878           DUTS = DONE*UU2
36879           DTSU = DONE*TT2
36880           DSTU = DONE*S2
36881 c       _    ~ ~
36882 c     q q -> g g
36883 c
36884           DO 21 IQ = 1, 6
36885             L    = ML2(IQ)-MG2
36886             L2   = L**2
36887             TTML = TT-L
36888             UUML = UU-L
36889             R    = MR2(IQ)-MG2
36890             R2   = R**2
36891             TTMR = TT-R
36892             UUMR = UU-R
36893             CONE = TWO*PF**2*SN2TH
36894             CONL = CONE/UUML/TTML
36895             CONR = CONE/UUMR/TTMR
36896             CONT = (UU2-L2)*CONL+(UU2-R2)*CONR+L2/TTML**2+R2/TTMR**2
36897             CONU = (TT2-L2)*CONL+(TT2-R2)*CONR+L2/UUML**2+R2/UUMR**2
36898             CONN = CFAC*(PF-PF/NC2/(CONT+CONU)*( S2*(CONL+CONR)+
36899      &            L2*((TT-UU)*CONL/CONE)**2+R2*((TT-UU)*CONR/CONE)**2 ))
36900             CSTU(IQ) = CONT*CONN
36901             CSUT(IQ) = CONU*CONN
36902    21     CONTINUE
36903         ELSE
36904           DUTS = ZERO
36905           DTSU = ZERO
36906           DSTU = ZERO
36907           DO 23 IQ = 1, 6
36908             CSTU(IQ) = ZERO
36909             CSUT(IQ) = ZERO
36910    23     CONTINUE
36911         END IF
36912 c     left handed squark (identical flavour) pair production
36913         DO 22 IQ = 1, 6
36914           QPE = S - FOUR*ML2(IQ)
36915           IF (QPE.GE.ZERO) THEN
36916             SQPE = SQRT(S*QPE)
36917             PF   = SQPE/S
36918             TT   = (SQPE*COSTH - S) / TWO
36919             TT2  = TT**2
36920             UU   = - S - TT
36921             UU2  = UU**2
36922 c            ~ ~*
36923 c     g g -> q q
36924 c             L L
36925             CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+ML4(IQ))/TT2/UU2
36926             CONN = CONE-CONE*S2/(TT2+UU2)/NC2
36927             CSTUL(IQ)  = CONN*UU2
36928             CSUTL(IQ)  = CONN*TT2
36929 c            ~ ~
36930 c     q q -> q q
36931 c             L L
36932             TMG  = TT+ML2(IQ)-MG2
36933             TMG2 = TMG**2
36934             UMG  = UU+ML2(IQ)-MG2
36935             UMG2 = UMG**2
36936             BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
36937             BSTULL(IQ) = BONE/TMG2
36938             BSUTLL(IQ) = BONE/UMG2
36939 c       _    ~ ~*
36940 c     q q -> q q
36941 c             L L
36942             AF   = AFAC*PF*PF**2*SN2TH
36943             BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
36944             BUTSLL(IQ) = BONE*S2
36945             BUSTLL(IQ) = BONE*TWO*TMG2
36946 c       _     ~ ~*
36947 c     q q  -> q'q'       q =/= q'
36948 c              L L
36949             AUSTLL(IQ) = TWO*AF
36950           ELSE
36951             CSTUL(IQ)  = ZERO
36952             CSUTL(IQ)  = ZERO
36953             BSTULL(IQ) = ZERO
36954             BSUTLL(IQ) = ZERO
36955             BUTSLL(IQ) = ZERO
36956             BUSTLL(IQ) = ZERO
36957             AUSTLL(IQ) = ZERO
36958           END IF
36959 c     right handed squark (identical flavour) pair production
36960           QPE = S - FOUR*MR2(IQ)
36961           IF (QPE.GE.ZERO) THEN
36962             SQPE = SQRT(S*QPE)
36963             PF   = SQPE/S
36964             TT   = (SQPE*COSTH - S) / TWO
36965             TT2  = TT**2
36966             UU   = - S - TT
36967             UU2  = UU**2
36968 c            ~ ~*
36969 c     g g -> q q
36970 c             R R
36971             CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+MR4(IQ))/TT2/UU2
36972             CONN = CONE-CONE*S2/(TT2+UU2)/NC2
36973             CSTUR(IQ) = CONN*UU2
36974             CSUTR(IQ) = CONN*TT2
36975 c            ~ ~
36976 c     q q -> q q
36977 c             R R
36978             TMG  = TT+MR2(IQ)-MG2
36979             TMG2 = TMG**2
36980             UMG  = UU+MR2(IQ)-MG2
36981             UMG2 = UMG**2
36982             BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
36983             BSTURR(IQ) = BONE/TMG2
36984             BSUTRR(IQ) = BONE/UMG2
36985 c       _    ~ ~*
36986 c     q q -> q q
36987 c             R R
36988             AF = AFAC*PF*PF**2*SN2TH
36989             BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
36990             BUTSRR(IQ) = BONE*S2
36991             BUSTRR(IQ) = BONE*TWO*TMG2
36992 c       _     ~ ~*
36993 c     q q  -> q'q'       q =/= q'
36994 c              R R
36995             AUSTRR(IQ) = TWO*AF
36996           ELSE
36997             CSTUR(IQ)  = ZERO
36998             CSUTR(IQ)  = ZERO
36999             BSTURR(IQ) = ZERO
37000             BSUTRR(IQ) = ZERO
37001             BUTSRR(IQ) = ZERO
37002             BUSTRR(IQ) = ZERO
37003             AUSTRR(IQ) = ZERO
37004           END IF
37005 c     left and right handed squark (identical flavour) pair production
37006           IQ1  = SSL + IQ
37007           IQ2  = SSR + IQ
37008           SM   = RMASS(IQ1)+RMASS(IQ2)
37009           QPE  = S - SM**2
37010           IF (QPE.GE.ZERO) THEN
37011             DM   = RMASS(IQ1)-RMASS(IQ2)
37012             SQPE = SQRT( QPE*(S-DM**2) )
37013             PF   = SQPE/S
37014             AF   = AFAC*PF
37015             TT   = (SQPE*COSTH - S - SM*DM) / TWO
37016             UU   = - S - TT
37017             TMG  = TT + ML2(IQ) - MG2
37018             TMG2 = TMG**2
37019             UMG  = UU + MR2(IQ) - MG2
37020             UMG2 = UMG**2
37021 c            ~ ~
37022 c     q q -> q q
37023 c             L R
37024             BONE = AFAC*PF*SQPE**2*SN2TH
37025             BSTULR(IQ) = BONE/TMG2
37026             BSUTLR(IQ) = BONE/UMG2
37027 c       _    ~ ~*
37028 c     q q -> q q
37029 c             L R
37030             BUTSLR(IQ) = AFAC*PF*MG2*S/TMG2
37031             BUSTLR(IQ) = ZERO
37032             TT   = (SQPE*COSTH - S + SM*DM) / TWO
37033             UU   = - S - TT
37034             TMG  = TT + MR2(IQ) - MG2
37035             TMG2 = TMG**2
37036             UMG  = UU + ML2(IQ) - MG2
37037             UMG2 = UMG**2
37038 c            ~ ~
37039 c     q q -> q q
37040 c             R L
37041 c            BONE = AFAC*PF*SQPE**2*SN2TH
37042 c            BSTURL(IQ) = BONE/TMG2
37043 c            BSUTRL(IQ) = BONE/UMG2
37044             BSTURL(IQ) = ZERO
37045             BSUTRL(IQ) = ZERO
37046 c       _    ~ ~*
37047 c     q q -> q q
37048 c             R L
37049             BUTSRL(IQ) = AFAC*PF*MG2*S/TMG2
37050             BUSTRL(IQ) = ZERO
37051           ELSE
37052             BSTULR(IQ) = ZERO
37053             BSUTLR(IQ) = ZERO
37054             BUTSLR(IQ) = ZERO
37055             BUSTLR(IQ) = ZERO
37056             BSTURL(IQ) = ZERO
37057             BSUTRL(IQ) = ZERO
37058             BUTSRL(IQ) = ZERO
37059             BUSTRL(IQ) = ZERO
37060           END IF
37061    22   CONTINUE
37062 c     distinct flavours - gq, qq'
37063         DO 11 ID1 = 1, 6
37064           IQ1  = SSL + ID1
37065           SM   = RMASS(GLU)+RMASS(IQ1)
37066           QPE  = S - SM**2
37067           IF (QPE.GE.ZERO) THEN
37068             DM   = RMASS(GLU)-RMASS(IQ1)
37069             SQPE = SQRT( QPE*(S-DM**2) )
37070             PF   = SQPE/S
37071             TT   = (SQPE*COSTH - S - SM*DM) / TWO
37072             TT2  = TT**2
37073             UU   = - S - TT
37074             UU2  = UU**2
37075 c            ~ ~
37076 c     g q -> g q
37077 c               L
37078             CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+ML2(ID1)/UU))/S/TT/UU
37079             CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
37080             CTSUL(ID1) = CONN*UU2
37081             CTUSL(ID1) = CONN*S2
37082           ELSE
37083             CTSUL(ID1) = ZERO
37084             CTUSL(ID1) = ZERO
37085           END IF
37086           IQ2  = SSR + ID1
37087           SM   = RMASS(GLU)+RMASS(IQ2)
37088           QPE  = S - SM**2
37089           IF (QPE.GE.ZERO) THEN
37090             DM   = RMASS(GLU)-RMASS(IQ2)
37091             SQPE = SQRT( QPE*(S-DM**2) )
37092             PF   = SQPE/S
37093             TT   = (SQPE*COSTH - S - SM*DM) / TWO
37094             TT2  = TT**2
37095             UU   = - S - TT
37096             UU2  = UU**2
37097 c            ~ ~
37098 c     g q -> g q
37099 c               R
37100             CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+MR2(ID1)/UU))/S/TT/UU
37101             CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
37102             CTSUR(ID1) = CONN*UU2
37103             CTUSR(ID1) = CONN*S2
37104           ELSE
37105             CTSUR(ID1) = ZERO
37106             CTUSR(ID1) = ZERO
37107           END IF
37108           IF(ID1.EQ.6) GOTO 11
37109           ID2MIN = ID1+1
37110           DO 12 ID2 = ID2MIN, 6
37111             IQ1  = SSL + ID1
37112             IQ2  = SSL + ID2
37113             SM   = RMASS(IQ1)+RMASS(IQ2)
37114             QPE  = S - SM**2
37115             IF (QPE.GE.ZERO) THEN
37116               DM   = RMASS(IQ1)-RMASS(IQ2)
37117               SQPE = SQRT( QPE*(S-DM**2) )
37118               PF   = SQPE/S
37119               TT   = (SQPE*COSTH - S - SM*DM) / TWO
37120               UU   = - S - TT
37121               TMG  = TT+ML2(ID1)-MG2
37122               AF   = AFAC*PF/TMG/TMG
37123 c             ~ ~
37124 c     q q' -> q q'
37125 c              L L
37126               ASTULL(ID1,ID2) = AF*MG2*S
37127               ASTULL(ID2,ID1) = ASTULL(ID1,ID2)
37128 c       _     ~ ~*
37129 c     q q' -> q q'
37130 c              L L
37131               AUTSLL(ID1,ID2) = AF*SQPE**2*SN2TH
37132               AUTSLL(ID2,ID1) = AUTSLL(ID1,ID2)
37133             ELSE
37134               ASTULL(ID1,ID2) = ZERO
37135               ASTULL(ID2,ID1) = ZERO
37136               AUTSLL(ID1,ID2) = ZERO
37137               AUTSLL(ID2,ID1) = ZERO
37138             END IF
37139             IQ1  = SSR + ID1
37140             IQ2  = SSR + ID2
37141             SM   = RMASS(IQ1)+RMASS(IQ2)
37142             QPE  = S - SM**2
37143             IF (QPE.GE.ZERO) THEN
37144               DM   = RMASS(IQ1)-RMASS(IQ2)
37145               SQPE = SQRT( QPE*(S-DM**2) )
37146               PF   = SQPE/S
37147               TT   = (SQPE*COSTH - S - SM*DM) / TWO
37148               UU   = - S - TT
37149               TMG  = TT+MR2(ID1)-MG2
37150               AF   = AFAC*PF/TMG/TMG
37151 c             ~ ~
37152 c     q q' -> q q'
37153 c              R R
37154               ASTURR(ID1,ID2) = AF*MG2*S
37155               ASTURR(ID2,ID1) = ASTURR(ID1,ID2)
37156 c       _     ~ ~*
37157 c     q q' -> q q'
37158 c              R R
37159               AUTSRR(ID1,ID2) = AF*SQPE**2*SN2TH
37160               AUTSRR(ID2,ID1) = AUTSRR(ID1,ID2)
37161             ELSE
37162               ASTURR(ID1,ID2) = ZERO
37163               ASTURR(ID2,ID1) = ZERO
37164               AUTSRR(ID1,ID2) = ZERO
37165               AUTSRR(ID2,ID1) = ZERO
37166             END IF
37167             IQ1  = SSL + ID1
37168             IQ2  = SSR + ID2
37169             SM   = RMASS(IQ1)+RMASS(IQ2)
37170             QPE  = S - SM**2
37171             IF (QPE.GE.ZERO) THEN
37172               DM   = RMASS(IQ1)-RMASS(IQ2)
37173               SQPE = SQRT( QPE*(S-DM**2) )
37174               PF   = SQPE/S
37175               TT   = (SQPE*COSTH - S - SM*DM) / TWO
37176               UU   = - S - TT
37177               TMG  = TT+ML2(ID1)-MG2
37178               AF   = AFAC*PF/TMG/TMG
37179 c             ~ ~
37180 c     q q' -> q q'
37181 c              L R
37182               ASTULR(ID1,ID2) = AF*SQPE**2*SN2TH
37183               ASTULR(ID2,ID1) = ASTULR(ID1,ID2)
37184 c       _     ~ ~*
37185 c     q q' -> q q'
37186 c              L R
37187               AUTSLR(ID1,ID2) = AF*MG2*S
37188               AUTSLR(ID2,ID1) = AUTSLR(ID1,ID2)
37189               TT   = (SQPE*COSTH - S + SM*DM) / TWO
37190               UU   = - S - TT
37191               TMG    = TT+MR2(ID1)-MG2
37192               AF   = AFAC*PF/TMG/TMG
37193 c             ~ ~
37194 c     q q' -> q q'
37195 c              R L
37196               ASTURL(ID1,ID2) = AF*SQPE**2*SN2TH
37197               ASTURL(ID2,ID1) = ASTULR(ID1,ID2)
37198 c       _     ~ ~*
37199 c     q q' -> q q'
37200 c              R L
37201               AUTSRL(ID1,ID2) = AF*MG2*S
37202               AUTSRL(ID2,ID1) = AUTSLR(ID1,ID2)
37203             ELSE
37204               ASTULR(ID1,ID2) = ZERO
37205               ASTULR(ID2,ID1) = ZERO
37206               AUTSLR(ID1,ID2) = ZERO
37207               AUTSLR(ID2,ID1) = ZERO
37208               ASTURL(ID1,ID2) = ZERO
37209               ASTURL(ID2,ID1) = ZERO
37210               AUTSRL(ID1,ID2) = ZERO
37211               AUTSRL(ID2,ID1) = ZERO
37212             END IF
37213    12     CONTINUE
37214    11   CONTINUE
37215       END IF
37216       HCS = ZERO
37217       DO 6 ID1 = 1, 13
37218       IF (DISF(ID1,1).LT.EPS) GOTO 6
37219       DO 5 ID2 = 1, 13
37220       IF (DISF(ID2,2).LT.EPS) GOTO 5
37221       DIST = DISF(ID1,1)*DISF(ID2,2)
37222       IF (ID1.LT.7) THEN
37223        IQ1 = ID1
37224        IF (ID2.LT.7) THEN
37225         IQ2 = ID2
37226         IF (IQ1.NE.IQ2) THEN
37227 c        ~ ~
37228 c qq' -> q q'
37229          HCS = HCS + ASTULL(IQ1,IQ2)*DIST
37230          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37231          HCS = HCS + ASTURR(IQ1,IQ2)*DIST
37232          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,3421,10,*9)
37233          HCS = HCS + ASTULR(IQ1,IQ2)*DIST
37234          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
37235          HCS = HCS + ASTURL(IQ1,IQ2)*DIST
37236          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
37237         ELSE
37238 c        ~ ~
37239 c qq  -> q q
37240          HCS = HCS +     BSTULL(IQ1)*DIST
37241          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37242          HCS = HCS +     BSTURR(IQ1)*DIST
37243          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,3421,10,*9)
37244          HCS = HCS +     BSTULR(IQ1)*DIST
37245          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
37246          HCS = HCS +     BSTURL(IQ1)*DIST
37247          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
37248          HCS = HCS +     BSUTLL(IQ1)*DIST
37249          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,4312,10,*9)
37250          HCS = HCS +     BSUTRR(IQ1)*DIST
37251          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,4312,10,*9)
37252          HCS = HCS +     BSUTLR(IQ1)*DIST
37253          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,4312,10,*9)
37254          HCS = HCS +     BSUTRL(IQ1)*DIST
37255          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,4312,10,*9)
37256         END IF
37257        ELSEIF (ID2.NE.13) THEN
37258         IQ2 = ID2-6
37259         IF (IQ1.NE.IQ2) THEN
37260 c  _     ~ ~*
37261 c qq' -> q q'
37262          HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
37263          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
37264          HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
37265          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,3142,10,*9)
37266          HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
37267          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
37268          HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
37269          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,3142,10,*9)
37270         ELSE
37271 c  _     ~ ~*
37272 c qq  -> q'q'   (q =/= q')
37273          DO 30 IQ = 1, 6
37274          IF (IQ .EQ.IQ1) GOTO 30
37275          HCS = HCS +     AUSTLL(IQ )*DIST
37276          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,2413,10,*9)
37277          HCS = HCS +     AUSTRR(IQ )*DIST
37278          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,2413,10,*9)
37279   30     CONTINUE
37280 c  _     ~ ~*
37281 c qq  -> q q
37282          HCS = HCS +     BUTSLL(IQ1)*DIST
37283          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
37284          HCS = HCS +     BUTSRR(IQ1)*DIST
37285          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,3142,10,*9)
37286          HCS = HCS +     BUTSLR(IQ1)*DIST
37287          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
37288          HCS = HCS +     BUTSRL(IQ1)*DIST
37289          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,3142,10,*9)
37290          HCS = HCS +     BUSTLL(IQ1)*DIST
37291          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,2413,10,*9)
37292          HCS = HCS +     BUSTRR(IQ1)*DIST
37293          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,2413,10,*9)
37294          HCS = HCS +     BUSTLR(IQ1)*DIST
37295          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,2413,10,*9)
37296          HCS = HCS +     BUSTRL(IQ1)*DIST
37297          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,2413,10,*9)
37298          IQ  = IGL
37299 c  _     ~ ~
37300 c qq  -> g g
37301          HCS = HCS +       CSTU(IQ1)*DIST
37302          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,0,2413,10,*9)
37303          HCS = HCS +       CSUT(IQ1)*DIST
37304          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,0,2341,10,*9)
37305         END IF
37306        ELSE
37307          IQ2 = IGL
37308 c        ~ ~
37309 c qg  -> q g
37310          HCS = HCS +      CTSUL(IQ1)*DIST
37311          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3142,10,*9)
37312          HCS = HCS +      CTSUR(IQ1)*DIST
37313          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3142,10,*9)
37314          HCS = HCS +      CTUSL(IQ1)*DIST
37315          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37316          HCS = HCS +      CTUSR(IQ1)*DIST
37317          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
37318        END IF
37319       ELSEIF (ID1.NE.13) THEN
37320        IQ1 = ID1 - 6
37321        IF (ID2.LT.7) THEN
37322         IQ2 = ID2
37323         IF (IQ1.NE.IQ2) THEN
37324 c _      ~*~
37325 c qq' -> q q'
37326          HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
37327          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
37328          HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
37329          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,2413,10,*9)
37330          HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
37331          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,2413,10,*9)
37332          HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
37333          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
37334         ELSE
37335 c _      ~*~
37336 c qq  -> q'q'   (q =/= q')
37337          DO 31 IQ = 1, 6
37338          IF (IQ .EQ.IQ1) GOTO 31
37339          HCS = HCS +      AUSTLL(IQ)*DIST
37340          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,1,IQ ,0,3142,10,*9)
37341          HCS = HCS +      AUSTRR(IQ)*DIST
37342          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,3,IQ ,2,3142,10,*9)
37343    31    CONTINUE
37344 c _      ~*~
37345 c qq  -> q q
37346          HCS = HCS +     BUTSLL(IQ1)*DIST
37347          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
37348          HCS = HCS +     BUTSRR(IQ1)*DIST
37349          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,2413,10,*9)
37350          HCS = HCS +     BUTSLR(IQ1)*DIST
37351          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,2413,10,*9)
37352          HCS = HCS +     BUTSRL(IQ1)*DIST
37353          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
37354          HCS = HCS +     BUSTLL(IQ1)*DIST
37355          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,3142,10,*9)
37356          HCS = HCS +     BUSTRR(IQ1)*DIST
37357          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,3142,10,*9)
37358          HCS = HCS +     BUSTLR(IQ1)*DIST
37359          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,3142,10,*9)
37360          HCS = HCS +     BUSTRL(IQ1)*DIST
37361          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,3142,10,*9)
37362 c _      ~ ~
37363 c qq  -> g g
37364          HCS = HCS +       CSTU(IQ1)*DIST
37365          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IGL,0,3142,10,*9)
37366          HCS = HCS +       CSUT(IQ1)*DIST
37367          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IGL,0,4123,10,*9)
37368         END IF
37369        ELSEIF (ID2.NE.13) THEN
37370         IQ2 = ID2 - 6
37371         IF (IQ1.NE.IQ2) THEN
37372 c __     ~*~*
37373 c qq' -> q q'
37374          HCS = HCS + ASTULL(IQ1,IQ2)*DIST
37375          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,4312,10,*9)
37376          HCS = HCS + ASTURR(IQ1,IQ2)*DIST
37377          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,4312,10,*9)
37378          HCS = HCS + ASTULR(IQ1,IQ2)*DIST
37379          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,4312,10,*9)
37380          HCS = HCS + ASTURL(IQ1,IQ2)*DIST
37381          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,4312,10,*9)
37382         ELSE
37383 c __     ~*~*
37384 c qq  -> q q
37385          HCS = HCS +     BSTULL(IQ1)*DIST
37386          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,4312,10,*9)
37387          HCS = HCS +     BSTURR(IQ1)*DIST
37388          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,4312,10,*9)
37389          HCS = HCS +     BSTULR(IQ1)*DIST
37390          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,4312,10,*9)
37391          HCS = HCS +     BSTURL(IQ1)*DIST
37392          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,4312,10,*9)
37393          HCS = HCS +     BSUTLL(IQ1)*DIST
37394          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,3421,10,*9)
37395          HCS = HCS +     BSUTRR(IQ1)*DIST
37396          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,3421,10,*9)
37397          HCS = HCS +     BSUTLR(IQ1)*DIST
37398          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,3421,10,*9)
37399          HCS = HCS +     BSUTRL(IQ1)*DIST
37400          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,3421,10,*9)
37401         END IF
37402        ELSE
37403          IQ2 = IGL
37404 c _      ~*~
37405 c qg  -> q g
37406          HCS = HCS +      CTSUL(IQ1)*DIST
37407          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
37408          HCS = HCS +      CTSUR(IQ1)*DIST
37409          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
37410          HCS = HCS +      CTUSL(IQ1)*DIST
37411          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,4312,10,*9)
37412          HCS = HCS +      CTUSR(IQ1)*DIST
37413          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,4312,10,*9)
37414        END IF
37415       ELSE
37416        IQ1 = IGL
37417        IF (ID2.LT.7) THEN
37418          IQ2 = ID2
37419 c        ~ ~
37420 c gq  -> g q
37421          HCS = HCS +      CTSUL(IQ2)*DIST
37422          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2413,10,*9)
37423          HCS = HCS +      CTSUR(IQ2)*DIST
37424          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,2413,10,*9)
37425          HCS = HCS +      CTUSL(IQ2)*DIST
37426          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37427          HCS = HCS +      CTUSR(IQ2)*DIST
37428          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
37429        ELSEIF (ID2.LT.13) THEN
37430          IQ2 = ID2 - 6
37431 c  _     ~ ~*
37432 c gq  -> g q
37433          HCS = HCS +      CTSUL(IQ2)*DIST
37434          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
37435          HCS = HCS +      CTSUR(IQ2)*DIST
37436          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
37437          HCS = HCS +      CTUSL(IQ2)*DIST
37438          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,4312,10,*9)
37439          HCS = HCS +      CTUSR(IQ2)*DIST
37440          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,4312,10,*9)
37441        ELSE
37442          IQ2 = IGL
37443 c        ~ ~*
37444 c gg  -> q q
37445          DO 32 IQ = 1, 6
37446          HCS = HCS +       CSTUL(IQ)*DIST
37447          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,2413,10,*9)
37448          HCS = HCS +       CSTUR(IQ)*DIST
37449          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,2413,10,*9)
37450          HCS = HCS +       CSUTL(IQ)*DIST
37451          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,4123,10,*9)
37452          HCS = HCS +       CSUTR(IQ)*DIST
37453          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,4123,10,*9)
37454    32    CONTINUE
37455 c        ~ ~
37456 c gg  -> g g
37457          HCS = HCS +            DTSU*DIST
37458          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2341,10,*9)
37459          HCS = HCS +            DSTU*DIST
37460          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
37461          HCS = HCS +            DUTS*DIST
37462          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2413,10,*9)
37463        END IF
37464       END IF
37465     5 CONTINUE
37466     6 CONTINUE
37467       EVWGT = HCS
37468       RETURN
37469 C---GENERATE EVENT
37470     9 IDN(1)=ID1
37471       IDN(2)=ID2
37472       IDCMF=15
37473       CALL HWETWO(.TRUE.,.TRUE.)
37474       IF (AZSPIN) THEN
37475 C Calculate coefficients for constructing spin density matrices
37476 C Set to zero for now
37477         CALL HWVZRO(7,GCOEF)
37478       END IF
37479   999 END
37480 CDECK  ID>, HWHSSP.
37481 *CMZ :-        -25/06/99  20.33.45  by  Kosuke Odagiri
37482 *-- Author :    Kosuke Odagiri & Bryan Webber
37483 C-----------------------------------------------------------------------
37484       SUBROUTINE HWHSSP
37485 C-----------------------------------------------------------------------
37486 C     SUSY HARD 2 PARTON -> 2 SPARTON/GAUGINO/SLEPTON PROCESSES
37487 C-----------------------------------------------------------------------
37488       INCLUDE 'HERWIG65.INC'
37489       DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN,HWRUNI,Z1,Z2,ET,EJ,
37490      & QPE,S,T,U,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP,SVEMSC
37491       INTEGER ISP
37492       EXTERNAL HWRGEN,HWRUNI
37493       SAVE SAVWT,SVEMSC
37494       IF (.NOT.GENEV) THEN
37495         EVWGT=ZERO
37496         CALL HWRPOW(ET,EJ)
37497         KK = ET/PHEP(5,3)
37498         KK2=KK**2
37499         IF (KK.GE.ONE) RETURN
37500         YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
37501         YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
37502         IF (YJ1INF.GE.YJ1SUP) RETURN
37503         Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
37504         YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
37505         YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
37506         IF (YJ2INF.GE.YJ2SUP) RETURN
37507         Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
37508         XX(1)=HALF*(Z1+Z2)*KK
37509         IF (XX(1).GE.ONE) RETURN
37510         XX(2)=XX(1)/(Z1*Z2)
37511         IF (XX(2).GE.ONE) RETURN
37512         S=XX(1)*XX(2)*PHEP(5,3)**2
37513         QPE=S-(TWO*RMMNSS)**2
37514         IF (QPE.LE.ZERO) RETURN
37515         COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
37516         IF (ABS(COSTH).GT.ONE) RETURN
37517         T=-(ONE+Z2/Z1)*(HALF*ET)**2
37518         U=-S-T
37519 C---SET EMSCA TO HEAVY HARD PROCESS SCALE
37520         SVEMSC = SQRT(TWO*S*T*U/(S*S+T*T+U*U))
37521         FACTSS = GEV2NB*HALF*PIFAC*EJ*ET/S**2
37522      &         * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
37523      &         * SQRT(S/QPE)
37524       ENDIF
37525       EMSCA=SVEMSC
37526       ISP=MOD(IPROC,100)
37527       IF (ISP.EQ.0) THEN
37528         IF (GENEV) THEN
37529           RANWT=SAVWT(3)*HWRGEN(0)
37530           IF (RANWT.LT.SAVWT(1)) THEN
37531             CALL HWHSSQ
37532           ELSEIF (RANWT.LT.SAVWT(2)) THEN
37533             CALL HWHSSG
37534           ELSE
37535             CALL HWHSSL
37536           ENDIF
37537         ELSE
37538           CALL HWHSSQ
37539           SAVWT(1)=EVWGT
37540           CALL HWHSSG
37541           SAVWT(2)=SAVWT(1)+EVWGT
37542           CALL HWHSSL
37543           SAVWT(3)=SAVWT(2)+EVWGT
37544           EVWGT=SAVWT(3)
37545         ENDIF
37546       ELSEIF (ISP.EQ.10) THEN
37547         CALL HWHSSQ
37548       ELSEIF (ISP.EQ.20) THEN
37549         CALL HWHSSG
37550       ELSEIF (ISP.EQ.30) THEN
37551         CALL HWHSSL
37552       ELSE
37553 C---UNRECOGNIZED PROCESS
37554         CALL HWWARN('HWHSSP',500,*999)
37555       ENDIF
37556  999  END
37557 CDECK  ID>, HWHSSS.
37558 *CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
37559 *-- Author :    Kosuke Odagiri
37560 C-----------------------------------------------------------------------
37561       SUBROUTINE HWHSSS(ID3,R3,ID4,R4,IPERM,IHPR,*)
37562 C-----------------------------------------------------------------------
37563 C     IDENTIFIES HARD SUSY SUBPROCESS
37564 C-----------------------------------------------------------------------
37565       INCLUDE 'HERWIG65.INC'
37566       INTEGER ID3, R3, ID4, R4, IPERM, IHPR, SSL
37567       PARAMETER (SSL = 400)
37568        IHPRO  = 3000 + IHPR
37569        IDN(3) = SSL + ID3 + R3*6
37570        IDN(4) = SSL + ID4 + R4*6
37571        ICO(1) = IPERM/1000
37572        ICO(2) = IPERM/100 - 10*ICO(1)
37573        ICO(3) = IPERM/10  - 10*(IPERM/100)
37574        ICO(4) = IPERM     - 10*(IPERM/10)
37575       RETURN 1
37576       END
37577 CDECK  ID>, HWHV1J.
37578 *CMZ :-        -18/05/99  14.37.45  by  Mike Seymour
37579 *-- Author :    Mike Seymour
37580 C-----------------------------------------------------------------------
37581       SUBROUTINE HWHV1J
37582 C-----------------------------------------------------------------------
37583 C   V + 1 JET PRODUCTION, WHERE V=W (IHPRO.LT.5) OR Z (IHPRO.GE.5).
37584 C   USES CROSS-SECTIONS OF EHLQ FOR ANNIHILATION AND COMPTON SCATTERING
37585 C   IHPRO=0 FOR BOTH, 1 FOR ANNIHILATION, AND 2 FOR COMPTON.
37586 C-----------------------------------------------------------------------
37587       INCLUDE 'HERWIG65.INC'
37588       DOUBLE PRECISION HWRGEN,HWRUNI,DISFAC(2,12,2),EMV2,DISMAX,S,T,U,
37589      & SHAT,THAT,UHAT,Z,HWUALF,PT,EMT,GFACTR,SIGANN,SIGCOM(2),CSFAC,ET,
37590      & EJ,YMIN,YMAX,VYMIN,VYMAX,EMAX,CV,CA,BR,EMV,GAMV,HWUAEM,TMIN,TMAX
37591       INTEGER HWRINT,IDINIT(2,12,2),ICOFLO(4,2),I,J,K,L,M,ID1,ID2,
37592      $     IDV,IDI,IDM
37593       EXTERNAL HWRINT
37594       SAVE DISFAC,SHAT,THAT,EMV,EMV2,IDV,IDI
37595 C---IDINIT HOLDS THE INITIAL STATES FOR ANNIHILATION PROCESSES
37596       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,
37597      $            1,7,2,8,3,9,4,10,5,11,6,12,1,7,2,8,3,9,4,10,5,11,6,12/
37598 C---ICOFLO HOLDS THE COLOR FLOW FOR EACH PROCESS
37599 C---DISFAC HOLDS THE DISTRIBUTION FUNCTION*CROSS-SECTION FOR EACH
37600 C   POSSIBLE SUB-PROCESS.
37601 C   INDEX1=INITIAL STATE PERMUTATION (1=AS IDINIT/QG;2=OPPOSITE/GQ),
37602 C        2=QUARK (FOR ANNIHILATION, >6 IMPLIES CABIBBO ROTATED PAIR),
37603 C        3=PROCESS (1=ANNIHILATION, 2=COMPTON)
37604       DATA ICOFLO,DISFAC/2,4,3,1,4,1,3,2,48*0.D0/
37605       IF (GENEV) THEN
37606         DISMAX=0
37607         DO 110 I=1,2
37608         DO 110 J=1,12
37609         DO 110 K=1,2
37610  110      DISMAX=MAX(DISFAC(K,J,I),DISMAX)
37611  120    I=HWRINT(1,2)
37612         J=HWRINT(1,12)
37613         K=HWRINT(1,2)
37614         IF (HWRGEN(0)*DISMAX.GT.DISFAC(K,J,I)) GOTO 120
37615         IF (I.EQ.1) THEN
37616 C---ANNIHILATION
37617           IDN(1)=IDINIT(K,J,IDI)
37618           IDN(2)=IDINIT(3-K,J,IDI)
37619           IDN(4)=13
37620         ELSE
37621 C---COMPTON SCATTERING
37622           IDN(1)=J
37623           IDN(2)=13
37624           IF (IDV.EQ.200) THEN
37625             IDN(4)=J
37626           ELSE
37627             IF (J.EQ.5.OR.J.EQ.6.OR.J.GE.11.OR.HWRGEN(0).GT.SCABI) THEN
37628 C---CHANGE QUARKS (1->2,2->1,3->4,4->3,...)
37629               IDN(4)=4*INT((J-1)/2)-J+3
37630             ELSE
37631 C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,...)
37632               IDN(4)=12*INT((J-1)/6)-J+5
37633             ENDIF
37634           ENDIF
37635           IF ((SQRT(EMV2)+RMASS(IDN(4)))**2.GT.SHAT) GOTO 120
37636           IF (K.EQ.2) THEN
37637 C---SWAP INITIAL STATES
37638             IDN(3)=IDN(1)
37639             IDN(1)=IDN(2)
37640             IDN(2)=IDN(3)
37641           ENDIF
37642         ENDIF
37643         IF (IDV.EQ.200) THEN
37644           IDN(3)=200
37645         ELSE
37646 C---W+ OR W-? USE CHARGE CONSERVATION TO WORK OUT
37647           IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
37648         ENDIF
37649         M=K
37650         IF (I.EQ.2.AND.J.LE.6) M=3-K
37651         DO 130 L=1,4
37652  130      ICO(L)=ICOFLO(L,M)
37653         IDCMF=15
37654         COSTH=(SHAT+2*THAT-EMV2)/(SHAT-EMV2)
37655 C---TRICK HWETWO INTO USING THE OFF-SHELL V MASS
37656         RMASS(IDN(3))=SQRT(EMV2)
37657 C-- BRW fix 27/8/04: avoid double smearing of V mass
37658         CALL HWETWO(.FALSE.,.TRUE.)
37659         RMASS(IDN(3))=EMV
37660         RHOHEP(1,NHEP-1)=0.5
37661         RHOHEP(2,NHEP-1)=0.0
37662         RHOHEP(3,NHEP-1)=0.5
37663       ELSE
37664         EVWGT=0.
37665         IHPRO=MOD(IPROC,100)/10
37666         IF (IHPRO.LT.5) THEN
37667           IDV=198
37668           IDI=1
37669           IDM=10
37670           GAMV=GAMW
37671         ELSE
37672           IDV=200
37673           IDI=2
37674           IDM=6
37675           GAMV=GAMZ
37676           IHPRO=IHPRO-5
37677         ENDIF
37678         EMV=RMASS(IDV)
37679 c---mhs---implement cut on number of widths from nominal mass
37680         TMIN=-ATAN(2*GAMMAX-GAMV*GAMMAX**2/EMV)
37681         TMAX=ATAN(2*GAMMAX+GAMV*GAMMAX**2/EMV)
37682         EMV2=EMV*(EMV+GAMV*TAN(HWRUNI(0,TMIN,TMAX)))
37683         IF (EMV2.LE.ZERO) RETURN
37684         CALL HWRPOW(ET,EJ)
37685         PT=0.5*ET
37686         EMT=SQRT(PT**2+EMV2)
37687         EMAX=0.5*(PHEP(5,3)+EMV2/PHEP(5,3))
37688         IF (EMAX.LE.EMT) RETURN
37689         VYMAX=0.5*LOG((EMAX+SQRT(EMAX**2-EMT**2))
37690      &              /(EMAX-SQRT(EMAX**2-EMT**2)))
37691         VYMIN=-VYMAX
37692         IF (VYMAX.LE.VYMIN) RETURN
37693         Z=EXP(HWRUNI(0,VYMIN,VYMAX))
37694         S= PHEP(5,3)**2
37695         T=-PHEP(5,3)*EMT/Z+EMV2
37696         U=-PHEP(5,3)*EMT*Z+EMV2
37697         XXMIN=-U/(S+T-EMV2)
37698         IF (XXMIN.LT.ZERO.OR.XXMIN.GT.ONE) RETURN
37699         YMIN=MAX(LOG((XXMIN*PHEP(5,3)-EMT*Z)/PT),YJMIN)
37700         YMAX=MIN(LOG((PHEP(5,3)-EMT*Z)/PT),YJMAX)
37701         IF (YMAX.LE.YMIN) RETURN
37702         XX(1)=(Z*EMT+EXP(HWRUNI(2,YMIN,YMAX))*PT)/PHEP(5,3)
37703         IF (XX(1).LE.ZERO.OR.XX(1).GT.ONE) RETURN
37704         THAT =XX(1)*T+(1.-XX(1))*EMV2
37705         XX(2)=-THAT / (XX(1)*S+U-EMV2)
37706         IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
37707         UHAT =XX(2)*U+(1.-XX(2))*EMV2
37708         SHAT =XX(1)*XX(2)*S
37709         EMSCA=EMT
37710         CALL HWSGEN(.FALSE.)
37711 c---mhs minor improvement: replace thomson coupling by running coupling
37712 c---mhs bug fix: missing factor of m^2/m0^2, where m0 is nominal mass
37713         GFACTR=GEV2NB*2.*PIFAC*HWUAEM(EMV2)*HWUALF(1,EMSCA)/(9.*SWEIN)
37714      $       *EMV2/EMV**2
37715         SIGANN=GFACTR*((THAT-EMV2)**2+(UHAT-EMV2)**2)
37716      &               /(SHAT**2*THAT*UHAT)
37717         SIGCOM(2)=.375*GFACTR*(SHAT**2+UHAT**2+2*EMV2*THAT)
37718      &                       /(-UHAT*SHAT**3)
37719         SIGCOM(1)=.375*GFACTR*(SHAT**2+THAT**2+2*EMV2*UHAT)
37720      &                       /(-THAT*SHAT**3)
37721 C---IF USER SPECIFIED A SUB-PROCESS, ZERO THE OTHER
37722         IF (IHPRO.EQ.1) THEN
37723           SIGCOM(1)=0.
37724           SIGCOM(2)=0.
37725         ENDIF
37726         IF (IHPRO.EQ.2) SIGANN=0.
37727         DO 210 I=1,IDM
37728           IF (IDV.EQ.200) THEN
37729             J=I
37730             IF(I.GT.6) J=I-6
37731             DISFAC(1,I,1)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
37732           ELSE
37733             IF (I.LE.4) THEN
37734               DISFAC(1,I,1)=1-SCABI
37735             ELSEIF (I.GE.7) THEN
37736               DISFAC(1,I,1)=SCABI
37737             ELSE
37738               DISFAC(1,I,1)=1.
37739             ENDIF
37740           ENDIF
37741           DISFAC(2,I,1)=DISFAC(1,I,1) *
37742      &         SIGANN*DISF(IDINIT(1,I,IDI),2)*DISF(IDINIT(2,I,IDI),1)
37743           DISFAC(1,I,1)=DISFAC(1,I,1) *
37744      &         SIGANN*DISF(IDINIT(1,I,IDI),1)*DISF(IDINIT(2,I,IDI),2)
37745  210    CONTINUE
37746         DO 211 I=IDM+1,12
37747           DISFAC(1,I,1)=0
37748           DISFAC(2,I,1)=0
37749  211    CONTINUE
37750         DO 220 I=1,12
37751           IF (IDV.EQ.200) THEN
37752             J=I
37753             IF(I.GT.6) J=I-6
37754             DISFAC(1,I,2)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
37755           ELSE
37756             DISFAC(1,I,2)=1.
37757 c---mhs fix: switch off bg->Wt process since we neglect quark masses!
37758             IF (I.EQ.5.OR.I.EQ.11) DISFAC(1,I,2)=0
37759           ENDIF
37760           DISFAC(2,I,2)=DISFAC(1,I,2)*SIGCOM(2)*DISF(I,2)*DISF(13,1)
37761           DISFAC(1,I,2)=DISFAC(1,I,2)*SIGCOM(1)*DISF(I,1)*DISF(13,2)
37762  220    CONTINUE
37763         DO 230 I=1,2
37764         DO 230 J=1,12
37765         DO 230 K=1,2
37766  230      EVWGT=EVWGT+DISFAC(K,J,I)
37767         CSFAC=PT*EJ*(YMAX-YMIN)*(VYMAX-VYMIN)*(TMAX-TMIN)/PIFAC
37768 C---INCLUDE BRANCHING RATIO OF V
37769         CALL HWDBOZ(IDV,ID1,ID2,CV,CA,BR,0)
37770         EVWGT=EVWGT*CSFAC*BR
37771       ENDIF
37772  999  END
37773 CDECK  ID>, HWHV2J.
37774 *CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
37775 *-- Author :    Peter Richardson
37776 C-----------------------------------------------------------------------
37777       SUBROUTINE HWHV2J
37778 C-----------------------------------------------------------------------
37779 C     Vector Boson production with two hard jets
37780 C     Master subroutine for all vector boson + 2 jet processes
37781 C     Currently implemented qqbar Z only
37782 C-----------------------------------------------------------------------
37783       INCLUDE 'HERWIG65.INC'
37784       INTEGER I,J,K,IDBS,IPRC,IDP(6),ORD,IB,ICMF,IHEP,IFLOW,IZ,IBRAD,
37785      &     ICOL(5),IDZ,IQ
37786       DOUBLE PRECISION HWRGEN,HWRUNI,XMASS,PLAB,PRW,PCM,HWUAEM,BR,FLUX,
37787      &     MBOS,MBOS2,ME,DT(4),B(6),HWUPCM,CV,CA,PST,HWUALF,GMBS,FPI4,
37788      &     MQ(3),MQ2(3),MJAC,BRZED(12),PTP(5,2),PDOT(2),HWULDO,TWOPI2,
37789      &     AMP,WI(IMAXCH)
37790       DOUBLE COMPLEX S,D,F
37791       LOGICAL FSTCLL,MASS,GEN
37792       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUALF,HWUAEM,HWULDO
37793       COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
37794       COMMON/HWHEWS/S(8,8,2),D(8,8)
37795       COMMON/HWHZBB/F(8,8)
37796       COMMON /HWPSOM/ WI
37797       DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
37798       DATA BRZED/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
37799      &           0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
37800       SAVE ME,MBOS,MBOS2,GMBS,IDBS,IPRC,IDP,FSTCLL,MQ,MQ2,TWOPI2,FPI4,
37801      &     IQ,MASS
37802 C--generate the event
37803       IF(GENEV) THEN
37804 C--find the particles produced
37805         IF(IPRC.EQ.0) THEN
37806           WRITE(*,1000)
37807           STOP
37808         ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
37809           CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
37810         ELSE
37811           CALL HWWARN('HWHV2J',502,*999)
37812         ENDIF
37813         IF(ORD.EQ.2) THEN
37814           IB     = IDP(1)
37815           IDP(1) = IDP(2)
37816           IDP(2) = IB
37817           PRW(3,1) = -PRW(3,1)
37818           DO I=3,6
37819             PLAB(3,I)=-PLAB(3,I)
37820           ENDDO
37821         ENDIF
37822 C--enter the incoming particles
37823         ICMF = NHEP+3
37824         DO I=1,2
37825           IHEP = NHEP+I
37826           CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
37827           IDHW(IHEP) = IDP(I)
37828           IDHEP(IHEP)= IDPDG(IDP(I))
37829           ISTHEP(IHEP)=110+I
37830           JMOHEP(1,IHEP)=ICMF
37831           JMOHEP(I,ICMF)=IHEP
37832           JDAHEP(1,IHEP)=ICMF
37833         ENDDO
37834         IDHW(ICMF)=15
37835         IDHEP(ICMF)=IDPDG(15)
37836         ISTHEP(ICMF)=110
37837         CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
37838         CALL HWUMAS(PHEP(1,ICMF))
37839         JDAHEP(1,ICMF) = ICMF+1
37840         JDAHEP(2,ICMF) = ICMF+3
37841         NHEP = NHEP+3
37842 C--Now the outgoing jets
37843         DO 10 I=1,2
37844           CALL HWVEQU(5,PLAB(1,2+I),PHEP(1,NHEP+I))
37845 C--Set the status and pointers
37846           ISTHEP(NHEP+I)=113
37847           IDHW(NHEP+I)=IDP(2+I)
37848           IDHEP(NHEP+I)=IDPDG(IDP(2+I))
37849           JMOHEP(1,NHEP+I)=NHEP
37850  10     CONTINUE
37851         NHEP=NHEP+2
37852 C--Now sort out the colour connections
37853         ICOL(1)=IFLOW/1000
37854         ICOL(2)=IFLOW/100-10*ICOL(1)
37855         ICOL(3)=IFLOW/10 -10*(IFLOW/100)
37856         ICOL(4)=IFLOW    -10*(IFLOW/10)
37857         DO 30 I=1,4
37858         J=I
37859         IF (J.GT.2) J=J+1
37860         K=ICOL(I)
37861         IF (K.GT.2) K=K+1
37862         JMOHEP(2,NHEP-5+J)=NHEP+K-5
37863  30     JDAHEP(2,NHEP-5+K)=NHEP+J-5
37864 C--Now add the Z to the event record
37865         CALL HWVEQU(5,PRW(1,1),PHEP(1,NHEP+1))
37866         CALL HWVZRO(4,VHEP(1,NHEP+1))
37867         CALL HWUDKL(200,PHEP(1,NHEP+1),DT)
37868         CALL HWVSUM(4,VHEP(1,NHEP+1),DT,DT)
37869         IDHW(NHEP+1)=IDBS
37870         IDHEP(NHEP+1)=IDPDG(IDBS)
37871         JMOHEP(1,NHEP+1)=ICMF
37872         JMOHEP(2,NHEP+1)=ICMF
37873         ISTHEP(NHEP+1)=114
37874         NHEP = NHEP+1
37875         IBRAD = NHEP
37876 C--generate the inital-state shower
37877         CALL HWBGEN
37878 C--now add the decay products of the Z
37879         IZ = JDAHEP(1,IBRAD)
37880         ISTHEP(IZ) = 195
37881         JDAHEP(1,IZ) = NHEP+1
37882         JDAHEP(2,IZ) = NHEP+2
37883         IDHW(NHEP+1) = IDP(5)
37884         IDHW(NHEP+2) = IDP(6)
37885         ISTHEP(NHEP+1) = 113
37886         ISTHEP(NHEP+2) = 114
37887         IDHEP(NHEP+1) = IDPDG(IDP(5))
37888         IDHEP(NHEP+2) = IDPDG(IDP(6))
37889         JMOHEP(1,NHEP+1) = IZ
37890         JMOHEP(1,NHEP+2) = IZ
37891         JMOHEP(2,NHEP+1) = NHEP+2
37892         JDAHEP(2,NHEP+1) = NHEP+2
37893         JMOHEP(2,NHEP+2) = NHEP+1
37894         JDAHEP(2,NHEP+2) = NHEP+1
37895         CALL HWVEQU(5,PLAB(1,5),PHEP(1,NHEP+1))
37896         CALL HWVEQU(5,PLAB(1,6),PHEP(1,NHEP+2))
37897         DO IHEP=NHEP+1,NHEP+2
37898           CALL HWVEQU(4,DT,VHEP(1,IHEP))
37899 C--Boost the fermion momenta to the rest frame of the original Z
37900           CALL HWULOF(PRW(1,1),PHEP(1,IHEP),PHEP(1,IHEP))
37901 C--Now boost back to the lab from rest frame of the Z after radiation
37902           CALL HWULOB(PHEP(1,IZ),PHEP(1,IHEP),PHEP(1,IHEP))
37903         ENDDO
37904         NHEP = NHEP+2
37905       ELSE
37906 C--initialisation
37907         IF(FSTWGT) THEN
37908 C--for second option minimum invariant mass of the jet pair
37909 C--set the type of events to be generated
37910           TWOPI2= FOUR*PIFAC**2
37911           FPI4  = (FOUR*PIFAC)**4
37912           IPRC = MOD(IPROC,100)
37913           IF(IPRC.GE.0.AND.IPRC.LE.16) THEN
37914 C--Z + 2 jets
37915             MBOS  = RMASS(200)
37916             MBOS2 = MBOS**2
37917             GMBS  = MBOS2*GAMZ**2
37918             IDBS  = 200
37919             MQ(1) = ZERO
37920             MQ(2) = ZERO
37921             IF(IPRC.EQ.0) THEN
37922               IQ    = 0
37923             ELSEIF(IPRC.GT.0.AND.IPRC.LE.6) THEN
37924               IQ = IPRC
37925               IF(MJJMIN.LT.TWO*RMASS(IQ)) MJJMIN = TWO*RMASS(IQ)
37926             ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
37927               MASS = .TRUE.
37928               IQ = IPRC-10
37929               MQ(1) = RMASS(IQ)
37930               MQ(2) = RMASS(IQ)
37931               IF(MJJMIN.LT.(MQ(1)+MQ(2))) MJJMIN = MQ(1)+MQ(2)
37932             ELSE
37933               CALL HWWARN('HWHV2J',500,*999)
37934             ENDIF
37935             DO I=1,2
37936               MQ2(I) = MQ(I)**2
37937             ENDDO
37938           ELSE
37939             CALL HWWARN('HWHV2J',500,*999)
37940           ENDIF
37941           FSTCLL = .TRUE.
37942         ENDIF
37943 C--generate the weight
37944         EVWGT = ZERO
37945 C--find the mass of the gauge boson
37946         CALL HWHGB1(1,2,IDBS,MJAC,MQ2(3),(PHEP(5,3)-MQ(1)-MQ(2))**2,
37947      &                                                       EMMIN**2)
37948         MQ(3) = SQRT(MQ2(3))
37949         MJAC = MJAC/((MQ2(3)-MBOS2)**2+GMBS)
37950 C--do the phase space
37951         CALL HWH2PS(FLUX,GEN,MQ,MQ2)
37952         AMP = ONE
37953         IF(.NOT.GEN) RETURN
37954 C--copy the gauge boson momentum
37955         CALL HWVEQU(5,PLAB(1,5),PRW(1,1))
37956 C--select the decay mode of the boson
37957         CALL HWDBOZ(IDBS,IDP(5),IDP(6),CV,CA,BR,0)
37958         IDZ = IDP(5)
37959         IF(IDZ.GT.6) IDZ = IDZ-114
37960         BR = BR/BRZED(IDZ)
37961         IF(IDZ.LE.6) AMP = AMP*THREE
37962 C--Finds the momenta of the boson decay products
37963         PST=HWUPCM(PRW(5,1),ZERO,ZERO)
37964         PLAB(5,5)=ZERO
37965         PLAB(5,6)=ZERO
37966         IF(PRW(5,1).LT.(RMASS(IDP(5))+RMASS(IDP(6)))) RETURN
37967         CALL HWDTWO(PRW(1,1),PLAB(1,5),PLAB(1,6),PST,TWO,.FALSE.)
37968         MJAC = HALF*PST*MJAC/TWOPI2/MQ(3)
37969 C--copy the momenta, change order and boost to CMF
37970         PTP(1,1) = ZERO
37971         PTP(2,1) = ZERO
37972         PTP(3,1) = HALF*(XX(1)-XX(2))*PHEP(5,3)
37973         PTP(4,1) = HALF*(XX(1)+XX(2))*PHEP(5,3)
37974         PTP(5,1) = PHEP(5,3)*SQRT(XX(1)*XX(2))
37975         DO I=1,6
37976           CALL HWULOF(PTP(1,1),PLAB(1,I),PTP(1,2))
37977           PCM(1,I)=PTP(3,2)
37978           PCM(2,I)=PTP(1,2)
37979           PCM(3,I)=PTP(2,2)
37980           PCM(4,I)=PTP(4,2)
37981         ENDDO
37982         IF(MASS) THEN
37983 C--Massive momentum case
37984 C--reorder the products
37985 C--move b and bbar to 9 and 10
37986           DO I=3,4
37987             DO J=1,5
37988               PCM(J,I+6) = PCM(J,I)
37989             ENDDO
37990           ENDDO
37991 C--select the reference momenta for the b and bbar and put in 3,4
37992 C--the results is independent of this choice
37993           CALL HWVEQU(5,PCM(1,1),PCM(1,3))
37994           CALL HWVEQU(5,PCM(1,1),PCM(1,4))
37995 C--find the massless vectors for the b and bbar
37996           PDOT(1) = HALF*MQ2(1)/HWULDO(PCM(1,3),PCM(1, 9))
37997           PDOT(2) = HALF*MQ2(2)/HWULDO(PCM(1,4),PCM(1,10))
37998           DO I=1,4
37999             PCM(I,7) = PCM(I,9) -PDOT(1)*PCM(I,3)
38000             PCM(I,8) = PCM(I,10)-PDOT(2)*PCM(I,4)
38001           ENDDO
38002           PCM(5,7) = ZERO
38003           PCM(5,8) = ZERO
38004 C--use e+e- code to calculate the spinor products
38005           CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
38006           DO I=1,8
38007             DO J=1,8
38008               S(I,J,2) = -S(I,J,2)
38009               D(I,J)   = TWO*D(I,J)
38010             ENDDO
38011           ENDDO
38012         ELSE
38013 C--Massless case, use the e+e- code to calculate the spinor products
38014           CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
38015           DO I=1,6
38016             DO J=1,6
38017               D(I,J) = TWO*D(I,J)
38018               F(I,J) = B(I)*B(J)*D(I,J)
38019               S(I,J,2) = -S(I,J,2)
38020             ENDDO
38021           ENDDO
38022         ENDIF
38023 C--now call the code to calculate the matrix element*PDF
38024         IF(IPRC.EQ.0) THEN
38025           WRITE(*,1000)
38026           STOP
38027         ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
38028           CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
38029         ELSE
38030           CALL HWWARN('HWHV2J',501,*999)
38031         ENDIF
38032         AMP = AMP*MJAC*BR*FPI4*HWUAEM(EMSCA**2)**2*HWUALF(1,EMSCA)**2
38033         EVWGT = FLUX*ME*AMP
38034         IF(OPTM) THEN
38035           DO I=1,IMAXCH
38036             IF(CHON(I)) WI(I) = WI(I)*ME**2*AMP**2
38037           ENDDO
38038         ENDIF
38039       ENDIF
38040       RETURN
38041  1000 FORMAT('DRELL-YAN + 2 JETS NOT YET IMPLEMENTED')
38042  999  END
38043 CDECK  ID>, HWHVVJ.
38044 *CMZ :-        -11/05/01  09.19.45  by  Bryan Webber
38045 *-- Author :    Bryan Webber
38046 C-----------------------------------------------------------------------
38047       SUBROUTINE HWHVVJ
38048 C-----------------------------------------------------------------------
38049 C   VV + 1 JET PRODUCTION, WHERE VV=WW,ZZ,WZ FOR IPROC=2850,2860,2870
38050 C-----------------------------------------------------------------------
38051       PRINT *,'  VV + 1 JET CALLED BUT NOT YET IMPLEMENTED'
38052       CALL HWWARN('HWHVVJ',500,*999)
38053  999  END
38054 CDECK  ID>, HWHWEX.
38055 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
38056 *-- Author :    Mike Seymour
38057 C-----------------------------------------------------------------------
38058       SUBROUTINE HWHWEX
38059 C-----------------------------------------------------------------------
38060 C     TOP QUARK PRODUCTION VIA W EXCHANGE: MEAN EVWGT=TOP PROD C-S IN NB
38061 C     C-S IS SUM OF:
38062 C     UbarBbar, DBbar, DbarB, UB, CbarBbar, SBbar, SbarB, AND CB
38063 C     UNLESS USER SPECIFIES OTHERWISE BY MOD(IPROC,100)=1-8 RESPECTIVELY
38064 C---DSDCOS HOLDS THE CROSS-SECTIONS FOR THE PROCESSES LISTED ABOVE
38065 C   (1-8) ARE WITH B FROM BEAM 1, (9-16) ARE WITH B FROM BEAM 2.
38066 C-----------------------------------------------------------------------
38067       INCLUDE 'HERWIG65.INC'
38068       DOUBLE PRECISION HWRGEN,HWRUNI,DSDCOS(16),EMT2,EMT,EMW2,EMW,
38069      & CMFMIN,TAUMIN,TAUMLN,S,T,U,ROOTS,DSMAX
38070       INTEGER HWRINT,IDHWEX(2,16),I
38071       EXTERNAL HWRGEN,HWRUNI,HWRINT
38072       SAVE DSDCOS,DSMAX
38073       EQUIVALENCE (EMW,RMASS(198)),(EMT,RMASS(6))
38074 C---IDHWEX HOLDS THE IDs OF THE INCOMING PARTICLES FOR EACH SUB-PROCESS
38075       DATA IDHWEX/11,8,11,1,5,7,5,2,11,10,11,3,5,9,5,4,
38076      &            8,11,1,11,7,5,2,5,10,11,3,11,9,5,4,5/
38077       EMT2=EMT**2
38078       EMW2=EMW**2
38079       IF (GENEV) THEN
38080  300    IHPRO=HWRINT(1,16)
38081         IF (HWRGEN(0).GT.DSDCOS(IHPRO)/DSMAX) GOTO 300
38082         DO 10 I=1,2
38083           IDN(I)=IDHWEX(I,IHPRO)
38084           IF (IDN(I).EQ.5 .OR. IDN(I).EQ.11) THEN
38085 C---CHANGE B QUARK INTO T QUARK
38086             IDN(I+2)=IDN(I)+1
38087           ELSEIF (HWRGEN(0).GT.SCABI) THEN
38088 C---CHANGE QUARKS (1->2,2->1,3->4,4->3,7->8,8->7,...)
38089             IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
38090           ELSE
38091 C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,4->1,7->10,...)
38092             IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
38093           ENDIF
38094           ICO(I)=I+2
38095           ICO(I+2)=I
38096  10     CONTINUE
38097         IDCMF=15
38098         CALL HWETWO(.TRUE.,.TRUE.)
38099       ELSE
38100         EVWGT=0.
38101         CMFMIN=EMT
38102         TAUMIN=(CMFMIN/PHEP(5,3))**2
38103         TAUMLN=LOG(TAUMIN)
38104         ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,ZERO,TAUMLN)))
38105         XXMIN=(ROOTS/PHEP(5,3))**2
38106         XLMIN=LOG(XXMIN)
38107         COSTH=HWRUNI(0,-ONE, ONE)
38108         S=ROOTS**2
38109         T=-0.5*S*(1-COSTH)
38110         U=-0.5*S*(1+COSTH)
38111         EMSCA=SQRT(2*S*T*U/(S*S+T*T+U*U))
38112         DSDCOS(1)=GEV2NB*PIFAC*.125*(ALPHEM/SWEIN)**2
38113      &           *(S-EMT2)**2 / S / (EMW2 + 0.5*(S-EMT2)*(1-COSTH))**2
38114         DSDCOS(2)=DSDCOS(1) / 4
38115      &    * (1 + EMT2/S + 2*COSTH + (1-EMT2/S)*COSTH**2)
38116         DSDCOS(3)=DSDCOS(2)
38117         DSDCOS(4)=DSDCOS(1)
38118 C---IF USER SPECIFIED SUB-PROCESS THEN ZERO ALL THE OTHERS
38119         IHPRO=MOD(IPROC,100)
38120         IF (IHPRO.GT.8) THEN
38121           CALL HWWARN('HWHWEX',1,*999)
38122           IHPRO=0
38123         ENDIF
38124         DO 100 I=1,8
38125           IF (I.LE.4) DSDCOS(I+4)=DSDCOS(I)
38126           IF (IHPRO.NE.0 .AND. IHPRO.NE.I) DSDCOS(I)=0
38127           DSDCOS(I+8)=DSDCOS(I)
38128  100    CONTINUE
38129         CALL HWSGEN(.TRUE.)
38130         DSMAX=0
38131         DO 200 I=1,16
38132           DSDCOS(I)=DSDCOS(I)*DISF(IDHWEX(1,I),1)*DISF(IDHWEX(2,I),2)
38133           EVWGT=EVWGT + 2*TAUMLN*XLMIN*DSDCOS(I)
38134           IF (DSDCOS(I).GT.DSMAX) DSMAX=DSDCOS(I)
38135  200    CONTINUE
38136       ENDIF
38137  999  END
38138 CDECK  ID>, HWHWPR.
38139 *CMZ :-        -18/05/99  14.22.13  by  Mike Seymour
38140 *-- Author :    Bryan Webber
38141 C-----------------------------------------------------------------------
38142       SUBROUTINE HWHWPR
38143 C-----------------------------------------------------------------------
38144 C     W+/- PRODUCTION AND DECAY VIA DRELL-YAN PROCESS
38145 C     MEAN EVWGT IS SIG(W+/-)*(BRANCHING FRACTION) IN NB
38146 C-----------------------------------------------------------------------
38147       INCLUDE 'HERWIG65.INC'
38148       DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,COEF,CSFAC,EMW,
38149      & FTQK,PTOP,ETOP,EBOT,PMAX,FHAD,FTOT,BRAF,FLEP,TMIN,HWUAEM,TMAX
38150       INTEGER HWRINT,ICH,IC,IL,ID,IDEC,JDEC,IWP(2,16)
38151       LOGICAL HWRLOG
38152       EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWRINT,HWRLOG
38153       SAVE CSFAC,IDEC,FLEP,FTQK,ETOP,PTOP,EBOT,PMAX,PROB
38154       DATA IWP/2,7,1,8,7,2,8,1,4,9,3,10,9,4,10,3,
38155      &         2,9,3,8,9,2,8,3,4,7,1,10,7,4,10,1/
38156       IF (GENEV) THEN
38157 C---GENERATE EVENT (X'S AND STRUCTURE FUNCTIONS ALREADY FOUND)
38158         PRAN=PROB*HWRGEN(0)
38159 C---LOOP OVER PARTON FLAVOURS
38160         PROB=0.
38161         COEF=1.-SCABI
38162         DO 10 IC=1,16
38163           IF (IC.EQ.9) COEF=SCABI
38164           PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
38165           IF (PROB.GE.PRAN) GOTO 20
38166    10   CONTINUE
38167 C---STORE INCOMING PARTONS
38168    20   IDN(1)=IWP(1,IC)
38169         IDN(2)=IWP(2,IC)
38170         ICO(1)=2
38171         ICO(2)=1
38172 C---ICH=1/2 FOR W+/-
38173         ICH=2-MOD(IC,2)
38174         IF ((IDEC.GT.49.AND.IDEC.LT.54).OR.
38175      &      (IDEC.EQ.99.AND.HWRLOG(FLEP))) THEN
38176 C---LEPTONIC DECAY
38177           IL=IDEC-50
38178           IF (IL.EQ.0.OR.IL.GT.3) IL=HWRINT(1,3)
38179           IDN(3)=2*IL+121-ICH
38180           IDN(4)=2*IL+124+ICH
38181 C---W DECAY ANGLE (1+COSTH)**2
38182           COSTH=2.*HWRGEN(1)**0.3333-1.
38183         ELSEIF (IDEC.EQ.5.OR.IDEC.EQ.6.OR.
38184      &        ((IDEC.EQ.0.OR.IDEC.EQ.99).AND.HWRLOG(FTQK))) THEN
38185 C---W -> TOP + BOTTOM DECAY
38186           IDN(3)=7-ICH
38187           IDN(4)=10+ICH
38188    21     COSTH=HWRUNI(1,-ONE, ONE)
38189           IF ((ETOP+(PTOP*COSTH))*(EBOT+(PTOP*COSTH)).LT.
38190      &         PMAX*HWRGEN(1)) GOTO 21
38191         ELSE
38192 C---OTHER HADRONIC DECAY
38193    25     PROB=0.
38194           PRAN=2.*HWRGEN(2)
38195           COEF=1.-SCABI
38196           DO 30 ID=ICH,16,4
38197             IF (ID.GT.8) COEF=SCABI
38198             PROB=PROB+COEF
38199             IF (PROB.GE.PRAN) THEN
38200               IDN(3)=IWP(1,ID)
38201               IDN(4)=IWP(2,ID)
38202               GOTO 40
38203             ENDIF
38204    30     CONTINUE
38205    40     CONTINUE
38206           IF (IDEC.GT.0.AND.IDEC.LT.5) THEN
38207             JDEC=IDEC+6
38208             IF (IDN(3).NE.IDEC.AND.IDN(4).NE.IDEC
38209      &     .AND.IDN(3).NE.JDEC.AND.IDN(4).NE.JDEC) GOTO 25
38210           ENDIF
38211           COSTH=2.*HWRGEN(1)**0.3333-1.
38212         ENDIF
38213         IDCMF=197+ICH
38214         IF (IDN(1).GT.6) COSTH=-COSTH
38215         ICO(3)=4
38216         ICO(4)=3
38217         CALL HWETWO(.TRUE.,.TRUE.)
38218       ELSE
38219         IDEC=MOD(IPROC,100)
38220         IF (IDEC.EQ.5.OR.IDEC.EQ.6) THEN
38221           TMIN=ATAN((RMASS(6)**2-RMASS(199)**2)/(GAMW*RMASS(199)))
38222         ELSE
38223           TMIN=-ATAN(RMASS(199)/GAMW)
38224         ENDIF
38225         EVWGT=0.
38226 c---mhs---implement cut on number of widths from nominal mass
38227         TMIN=MAX(TMIN,-ATAN(2*GAMMAX-GAMW*GAMMAX**2/RMASS(199)))
38228         TMAX=ATAN(2*GAMMAX+GAMW*GAMMAX**2/RMASS(199))
38229         EMW=GAMW*TAN(HWRUNI(0,TMIN,TMAX))+RMASS(199)
38230         IF (EMW.LE.ZERO) RETURN
38231         EMW=SQRT(EMW*RMASS(199))
38232         IF (EMW.LE.QSPAC.OR.EMW.GE.PHEP(5,3)) RETURN
38233         EMSCA=EMW
38234         IF (EMLST.NE.EMW) THEN
38235           EMLST=EMW
38236           XXMIN=(EMW/PHEP(5,3))**2
38237           XLMIN=LOG(XXMIN)
38238           CSFAC=-GEV2NB*PIFAC**2*HWUAEM(EMSCA**2)
38239      &          /(3.*SWEIN*RMASS(199)**2)*XLMIN
38240 C---COMPUTE TOP AND LEPTONIC FRACTIONS
38241           FTQK=0.
38242           IF (NFLAV.GT.5) THEN
38243             PTOP=HWUPCM(EMW,RMASS(5),RMASS(6))
38244             IF (PTOP.GT.ZERO) THEN
38245               ETOP=SQRT(PTOP**2+RMASS(6)**2)
38246               EBOT=EMW-ETOP
38247               FTQK=2.*PTOP*(3.*ETOP*EBOT+PTOP**2)/EMW**3
38248               PMAX=(ETOP+PTOP)*(EBOT+PTOP)
38249             ENDIF
38250           ENDIF
38251           FHAD=FTQK+2.
38252           FTOT=FTQK+3.
38253 C---MULTIPLY WEIGHT BY BRANCHING FRACTION
38254           IF (IDEC.EQ.0) THEN
38255             BRAF=FHAD
38256           ELSEIF (IDEC.LT.5.OR.IDEC.EQ.50) THEN
38257             BRAF=1.
38258           ELSEIF (IDEC.LT.7) THEN
38259             BRAF=FTQK
38260           ELSEIF (IDEC.EQ.99) THEN
38261             BRAF=FTOT
38262           ELSE
38263             BRAF=1/THREE
38264           ENDIF
38265 c---mhs fix: normalization should be to on-shell total width
38266 c  (only different if chosen mass is above top threshold)
38267           CSFAC=CSFAC*BRAF/THREE*(TMAX-TMIN)/PIFAC
38268           FTQK=FTQK/FHAD
38269           FLEP=1./FTOT
38270         ENDIF
38271         CALL HWSGEN(.TRUE.)
38272 C---LOOP OVER PARTON FLAVOURS
38273         PROB=0.
38274         COEF=1.-SCABI
38275         DO 100 IC=1,16
38276           IF (IC.EQ.9) COEF=SCABI
38277           PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
38278   100   CONTINUE
38279         EVWGT=PROB*CSFAC
38280       ENDIF
38281   999 END
38282 CDECK  ID>, HWIODK.
38283 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
38284 *-- Author :    Ian Knowles
38285 C-----------------------------------------------------------------------
38286 c$$$      SUBROUTINE HWIODK(IUNIT,IOPT,IME)
38287       SUBROUTINE HWIODK(IOPT)
38288 C-----------------------------------------------------------------------
38289 C     If IUNIT > 0 writes out present HERWIG decay tables to unit IUNIT
38290 C              < 0 reads in decay tables from unit IUNIT
38291 C     The format used during the read/write is specified by IOPT
38292 C     =1 PDG; =2 HERWIG numeric; =3 HERWIG character name.
38293 C     When reading in if IME =1 matrix element codes >= 100 are accepted
38294 C                             0                            are set zero.
38295 C-----------------------------------------------------------------------
38296       INCLUDE 'HERWIG65.INC'
38297       INTEGER IUNIT,IOPT,IME,JUNIT,I,J,K,L,IDKY,ITMP(5),IDUM
38298       CHARACTER*8 CDK(NMXDKS),CDKPRD(5,NMXDKS),CDUM
38299 c$$$      JUNIT=ABS(IUNIT)
38300 c$$$c$$$      OPEN(UNIT=JUNIT,FORM='FORMATTED',STATUS='UNKNOWN')
38301 c$$$c$$$      IF (IUNIT.GT.0) THEN
38302 c$$$C Write out the decay table
38303         WRITE(*,100) NDKYS
38304 c$$$        IF (IOPT.EQ.1) THEN
38305 c$$$          DO 20 I=1,NRES
38306 c$$$             IF (NMODES(I).EQ.0) GOTO 20
38307 c$$$             K=LSTRT(I)
38308 c$$$             DO 10 J=1,NMODES(I)
38309 c$$$                WRITE(*,110) IDPDG(I),BRFRAC(K),NME(K),
38310 c$$$     &               (IDPDG(IDKPRD(L,K)),L=1,5)
38311 c$$$ 10             K=LNEXT(K)
38312 c$$$ 20          CONTINUE
38313
38314 c$$$        ELSEIF (IOPT.EQ.2) THEN
38315 c$$$          DO 40 I=1,NRES
38316 c$$$          IF (NMODES(I).EQ.0) GOTO 40
38317 c$$$          K=LSTRT(I)
38318 c$$$          DO 30 J=1,NMODES(I)
38319 c$$$          WRITE(*,120) I,BRFRAC(K),NME(K),(IDKPRD(L,K),L=1,5)
38320 c$$$  30      K=LNEXT(K)
38321 c$$$  40      CONTINUE
38322 c$$$        ELSEIF (IOPT.EQ.3) THEN
38323
38324           DO 60 I=1,NRES
38325           IF (NMODES(I).EQ.0) GOTO 60
38326           K=LSTRT(I)
38327           DO 50 J=1,NMODES(I)
38328           WRITE(*,130) K,IDPDG(I),RNAME(I),BRFRAC(K),NME(K),
38329      &                    (RNAME(IDKPRD(L,K)),L=1,5)
38330   50      K=LNEXT(K)
38331   60      CONTINUE
38332
38333 c$$$        ENDIF
38334 c$$$      ELSEIF (IUNIT.LT.0) THEN
38335 c$$$C Read in the decay table and convert to HERWIG numeric format
38336 c$$$        READ(JUNIT,100) NDKYS
38337 c$$$        IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWIODK',100,*999)
38338 c$$$        IF (IOPT.EQ.1) THEN
38339 c$$$          DO 70 I=1,NDKYS
38340 c$$$          READ(JUNIT,110) IDKY,BRFRAC(I),NME(I),ITMP
38341 c$$$          IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
38342 c$$$          CALL HWUIDT(1,IDKY,IDK(I),CDUM)
38343 c$$$          DO 70 J=1,5
38344 c$$$  70      CALL HWUIDT(1,ITMP(J),IDKPRD(J,I),CDUM)
38345 c$$$        ELSEIF (IOPT.EQ.2) THEN
38346 c$$$          DO 80 I=1,NDKYS
38347 c$$$          READ(JUNIT,120) IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5)
38348 c$$$          IF (IDK(I).LT.0.OR.IDK(I).GT.NRES) IDK(I)=20
38349 c$$$  80      IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
38350 c$$$        ELSEIF (IOPT.EQ.3) THEN
38351 c$$$          DO 90 I=1,NDKYS
38352 c$$$          READ(JUNIT,130) CDK(I),BRFRAC(I),NME(I),(CDKPRD(J,I),J=1,5)
38353 c$$$          IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
38354 c$$$          CALL HWUIDT(3,IDUM,IDK(I),CDK(I))
38355 c$$$          DO 90 J=1,5
38356 c$$$  90      CALL HWUIDT(3,IDUM,IDKPRD(J,I),CDKPRD(J,I))
38357 c$$$        ELSE
38358 c$$$          CALL HWWARN('HWIODK',101,*999)
38359 c$$$        ENDIF
38360 c$$$      ENDIF
38361 c$$$      CLOSE(UNIT=JUNIT)
38362   100 FORMAT(1X,I4)
38363   110 FORMAT(1X,I7,1X,F7.5,1X,I3,5(1X,I7))
38364   120 FORMAT(1X,I3,1X,F7.5,6(1X,I3))
38365   130 FORMAT(1X,I4,1X,I7,1X,A8,1X,F7.5,1X,I3,5(1X,A8))
38366   999 RETURN
38367       END
38368 CDECK  ID>, HWIGIN.
38369 *CMZ :-        -12/10/01  09.50.50  by  Peter Richardson
38370 *-- Author :    Bryan Webber
38371 C----------------------------------------------------------------------
38372       SUBROUTINE HWIGIN
38373 C-----------------------------------------------------------------------
38374 C     SETS INPUT PARAMETERS
38375 C----------------------------------------------------------------------
38376       INCLUDE 'HERWIG65.INC'
38377       DOUBLE PRECISION FAC,ANGLE
38378       INTEGER I,J,N,L
38379       CHARACTER*28 TITLE
38380       DATA TITLE/'HERWIG 6.507  8th March 2005'/
38381       WRITE (6,10) TITLE
38382   10  FORMAT(//10X,A28//,
38383      &         10X,'Please reference:  G. Marchesini, B.R. Webber,',/,
38384      &         10X,'G.Abbiendi, I.G.Knowles, M.H.Seymour & L.Stanco',/,
38385      &         10X,'Computer Physics Communications 67 (1992) 465',/,
38386      &         10X,'                   and',/,
38387      &         10X,'G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti,'
38388      & ,/,     10X,'K.Odagiri, P.Richardson, M.H.Seymour & B.R.Webber,'
38389      & ,/,     10X,'JHEP 0101 (2001) 010')
38390 C---PRINT OPTIONS:
38391 C     IPRINT=0     NO PRINTOUT
38392 C            1     PRINT SELECTED INPUT PARAMETERS
38393 C            2     1 + TABLE OF PARTICLE CODES AND PROPERTIES
38394 C            3     2 + TABLES OF SUDAKOV FORM FACTORS
38395       IPRINT=1
38396 C Format for track numbers in event listing
38397 C     PRNDEC=.TRUE.  use decimal
38398 C            .FALSE. use hexadecimal
38399       PRNDEC=(NMXHEP.LE.9999)
38400 C Number of significant figures to print out in event listing
38401 C NPRFMT (< 2) compact 80 character stout and A4-long tex output,
38402 C (= 2) 2 decimal places in stout, (> 2) - 5 decimal places in stout
38403       NPRFMT=1
38404 C Print out vertex information
38405       PRVTX=.TRUE.
38406 C Print out particle properties/event record to stout, tex or web
38407       PRNDEF=.TRUE.
38408       PRNTEX=.FALSE.
38409       PRNWEB=.FALSE.
38410 C---MAX NO OF EVENTS TO PRINT
38411       MAXPR=1
38412       EV1PR=0
38413       EV2PR=0
38414 C---UNIT FOR READING SUDAKOV FORM FACTORS (IF ZERO THEN COMPUTE THEM)
38415       LRSUD=0
38416 C---UNIT FOR WRITING SUDAKOV FORM FACTORS (IF ZERO THEN NOT WRITTEN)
38417       LWSUD=77
38418 C---UNIT FOR WRITING EVENT DATA IN HWANAL (IF ZERO THEN NOT WRITTEN)
38419       LWEVT=0
38420 C---SEEDS FOR RANDOM NUMBER GENERATOR (CALLED HWRGEN)
38421       NRN(1)= 17673
38422       NRN(2)= 63565
38423 C---ALLOW NEGATIVE WEIGHTS?
38424       NEGWTS=.FALSE.
38425 C---AZIMUTHAL CORRELATIONS?
38426 C   THESE INCLUDE SOFT GLUON (INSIDE CONE)
38427       AZSOFT=.TRUE.
38428 C   AND NEAREST-NEIGHBOUR SPIN CORRELATIONS
38429       AZSPIN=.TRUE.
38430 C---MATRIX-ELEMENT MATCHING FOR E+E-, DIS, DRELL-YAN AND TOP DECAY
38431 C---HARD EMISSION
38432       HARDME=.TRUE.
38433 C---SOFT EMISSION
38434       SOFTME=.TRUE.
38435 C---GLUON ENERGY CUT FOR TOP DECAY CASE
38436       GCUTME=2
38437 C Electromagnetic fine structure constant: Thomson limit
38438       ALPHEM=.0072993
38439 C---QCD LAMBDA: CORRESPONDS TO 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X ONLY
38440       QCDLAM=0.18
38441 C---NUMBER OF COLOURS
38442       NCOLO=3
38443 C---NUMBER OF FLAVOURS
38444       NFLAV=6
38445 C---QUARK, GLUON AND PHOTON VIRTUAL MASS CUTOFFS IN
38446 C   PARTON SHOWER (ADDED TO MASSES GIVEN BELOW)
38447       VQCUT=0.48
38448       VGCUT=0.10
38449       VPCUT=0.40
38450       ALPFAC=1
38451 C---D,U,S,C,B,T QUARK AND GLUON MASSES (IN THAT ORDER)
38452       RMASS(1)=0.32
38453       RMASS(2)=0.32
38454       RMASS(3)=0.5
38455       RMASS(4)=1.55
38456       RMASS(5)=4.95
38457       RMASS(6)=174.3
38458       RMASS(13)=0.75
38459 C---W+/- AND Z0 MASSES
38460       RMASS(198)=80.42
38461       RMASS(199)=80.42
38462       RMASS(200)=91.188
38463 C---HIGGS BOSON MASS
38464       RMASS(201)=115.
38465 C---WIDTHS OF W, Z, HIGGS
38466       GAMW=2.12
38467       GAMZ=2.495
38468 C SM Higgs width is actually recomputed by HWDHIG
38469 C but this value corresponds to RMASS(201)=115.
38470       GAMH=0.0037
38471 C Include additional neutral, massive vector boson (Z')
38472       ZPRIME=.FALSE.
38473 C Z' mass and width
38474       RMASS(202)=500.
38475       GAMZP=5.
38476 C Graviton properties
38477 C Graviton mass and width (default mass 1 TeV and calculated width)
38478       EMGRV  = 1000.0D0
38479       GAMGRV = ZERO
38480 C Graviton coupling (this has dimensions of mass)
38481       GRVLAM = 10000.0D0
38482 C Lepton (EPOLN) and anti-lepton (PPOLN) beam polarisations used in:
38483 C e+e- --> ffbar/qqbar g; and l/lbar N DIS.
38484 C Cpts. 1,2 Transverse polarisation; cpt. 3 longitudinal polarisation.
38485 C Note require POLN(1)**2+POLN(2)**2+POLN(3)**2 < 1.
38486       DO 20 I=1,3
38487       EPOLN(I)=0.
38488   20  PPOLN(I)=0.
38489 C-----------------------------------------------------------------------
38490 C     Specify couplings of weak vector bosons to fermions:
38491 C
38492 C     electric current:      QFCH(I)*e*G_mu       (electric charge, e>0)
38493 C     weak neutral current: [VFCH(I,J).1+AFCH(I,J).G_5]*e*G_mu
38494 C     weak charged current: SQRT(VCKM(K,L)/2.)*g*(1+G_5)*G_mu
38495 C
38496 C     I= 1- 6: d,u,s,c,b,t (quarks)
38497 C      =11-16: e,nu_e,mu,nu_mu,tau,nu_tau (leptons) (`I=IDHW-110')
38498 C     J=1 for minimal SM:
38499 C      =2 for Z' couplings (ZPRIME=.TRUE.)
38500 C     K=1,2,3 for u,c,t;    L=1,2,3 for d,s,b
38501 C-----------------------------------------------------------------------
38502 C Minimal standard model neutral vector boson couplings
38503 C VFCH(I,1)=(T3/2-Q*S^2_W)/(C_W*S_W);  AFCH(I,1)=T3/(2*C_W*S_W)
38504 C sin**2 Weinberg angle (PDG '94)
38505       SWEIN=.2319
38506       FAC=1./SQRT(SWEIN*(1.-SWEIN))
38507       DO 30 I=1,3
38508 C Down-type quarks
38509       J=2*I-1
38510       QFCH(J)=-1./3.
38511       VFCH(J,1)=(-0.25+SWEIN/3.)*FAC
38512       AFCH(J,1)= -0.25*FAC
38513 C Up-type quarks
38514       J=2*I
38515       QFCH(J)=+2./3.
38516       VFCH(J,1)=(+0.25-2.*SWEIN/3.)*FAC
38517       AFCH(J,1)= +0.25*FAC
38518 C Charged leptons
38519       J=2*I+9
38520       QFCH(J)=-1.
38521       VFCH(J,1)=(-0.25+SWEIN)*FAC
38522       AFCH(J,1)= -0.25*FAC
38523 C Neutrinos
38524       J=2*I+10
38525       QFCH(J)=0.
38526       VFCH(J,1)=+0.25*FAC
38527       AFCH(J,1)=+0.25*FAC
38528   30  CONTINUE
38529 C Additional Z' couplings (To be set by the user)
38530       IF (.NOT.ZPRIME) THEN
38531          DO 40 I=1,6
38532          AFCH(I,2)=0.
38533          AFCH(10+I,2)=0.
38534          VFCH(I,2)=0.
38535          VFCH(10+I,2)=0.
38536   40     CONTINUE
38537       ENDIF
38538 C--calculate left and right couplings of bosons for axial and vector ones
38539       DO 45 J=1,16
38540         IF(J.LE.6.OR.J.GE.11) THEN
38541           LFCH(J)=VFCH(J,1)+AFCH(J,1)
38542           RFCH(J)=VFCH(J,1)-AFCH(J,1)
38543         ENDIF
38544  45   CONTINUE
38545 C Cabibbo-Kobayashi-Maskawa matrix elements squared (PDG '92):
38546 C sin**2 of Cabibbo angle
38547       SCABI=.0488
38548 C u ---> d,s,b
38549       VCKM(1,1)=1.-SCABI
38550       VCKM(1,2)=SCABI
38551       VCKM(1,3)=0.0
38552 C c ---> d,s,b
38553       VCKM(2,1)=SCABI
38554       VCKM(2,2)=1.-SCABI-.002
38555       VCKM(2,3)=0.002
38556 C t ---> d,b,s
38557       VCKM(3,1)=0.0
38558       VCKM(3,2)=0.002
38559       VCKM(3,3)=0.998
38560 C---GAUGE BOSON DECAYS
38561       DO 50 I=1,12
38562       BRHIG(I)=1.D0/12
38563       ENHANC(I)=1.D0
38564  50   CONTINUE
38565       DO 55 I=1,MODMAX
38566       MODBOS(I)=0
38567  55   CONTINUE
38568 C
38569 C THE iTH GAUGE BOSON DECAY PER EVENT IS CONTROLLED BY MODBOS AS FOLLOWS
38570 C         MODBOS(i)     W DECAY        Z DECAY
38571 C             0           all            all
38572 C             1          qqbar          qqbar
38573 C             2           enu            e+e-
38574 C             3           munu          mu+mu-
38575 C             4          taunu         tau+tau-
38576 C             5        enu & munu      ee & mumu
38577 C             6           all            nunu
38578 C             7           all           bbbar
38579 C            >7           all            all
38580 C BOSON PAIRS (eg FROM HIGGS DECAY)ARE CHOSEN FROM MODBOS(i),MODBOS(i+1)
38581 C
38582 C---CONTROL OF LARGE EMH BEHAVIOUR (SEE HWHIGM FOR DETAILS)
38583       IOPHIG=3
38584       GAMMAX=10.
38585 C Specify approximation used in HWHIGA
38586       IAPHIG=1
38587 C---MASSES OF HYPOTHETICAL NEW QUARKS GO
38588 C   INTO 209-214 (ANTIQUARKS IN 215-220)
38589 C   ID = 209,210 ARE B',T' WITH DECAYS T'->B'->C
38590 C        211,212 ARE B',T' WITH DECAYS T'->B'->T
38591 C        215-218 ARE THEIR ANTIQUARKS
38592       RMASS(209)=200.
38593       RMASS(215)=200.
38594 C---MAXIMUM CLUSTER MASS PARAMETERS
38595 C   N.B. LIMIT FOR Q1-Q2BAR CLUSTER MASS
38596 C   IS (CLMAX**CLPOW + (QM1+QM2)**CLPOW)**(1/CLPOW)
38597       CLMAX=3.35
38598       CLPOW=2.0
38599 C   For PSPLT(I), CLDIR(I) & CLSMR(I): I=1 light u,d,s,c cluster
38600 C                                       =2 heavy b cluster
38601 C---MASS SPECTRUM OF PRODUCTS IN CLUSTER
38602 C   SPLITTING ABOVE CLMAX - FLAT IN M**PSPLT(*)
38603       PSPLT(1)=1.0
38604       PSPLT(2)=PSPLT(1)
38605 C---KINEMATIC TREATMENT OF CLUSTER DECAY
38606 C   0=ISOTROPIC, 1=REMEMBER DIRECTION OF PERTURBATIVELY PRODUCED QUARKS
38607       CLDIR(1)=1
38608       CLDIR(2)=CLDIR(1)
38609 C   IF CLDIR(*)=1, DO GAUSSIAN SMEARING OF DIRECTION:
38610 C   ACTUALLY EXPONENTIAL IN 1-COS(THETA) WITH MEAN CLSMR(*)
38611       CLSMR(1)=0.0
38612       CLSMR(2)=CLSMR(1)
38613 C---OPTION FOR TREATMENT OF REMNANT CLUSTERS:
38614 C   0=BOTH CHILDREN ARE SOFT, (EQUIVALENT TO PREVIOUS VERSIONS)
38615 C   1=REMNANT CHILD IS SOFT, BUT PERTURBATIVE CHILD IS NORMAL
38616       IOPREM=1
38617 C---TREATMENT OF LOWER LIMIT FOR SPACELIKE EVOLUTION
38618 C   0=EVOLUTION STOPS AT QSPAC, BUT STRUCT FUNS CAN GET CALLED AT
38619 C   SMALLER SCALES IN FORCED EMISSION (EQUIVALENT TO V5.7 AND EARLIER)
38620 C   1=EVOLUTION STOPS AT QSPAC, STRUCTURE FUNCTIONS FREEZE AT QSPAC
38621 C   2=EVOLUTION CONTINUES TO INFRARED CUT, BUT S.F.S FREEZE AT QSPAC
38622       ISPAC=0
38623 C---LOWER LIMIT FOR SPACELIKE EVOLUTION
38624       QSPAC=2.5
38625 C---SWITCH OFF SPACE-LIKE SHOWERS
38626       NOSPAC=.FALSE.
38627 C---INTRINSIC PT OF SPACELIKE PARTONS (RMS)
38628       PTRMS=0.0
38629 C---MASS PARAMETER IN REMNANT FRAGMENTATION
38630       BTCLM=1.0
38631 C---PARAMETERS CONTROLLING VERY SMALL-X BEHAVIOUR OF PDFS
38632       PDFX0=0
38633       PDFPOW=0
38634 C---STRUCTURE FUNCTION SET:
38635 C   SET MODPDF(I)=MODE AND AUTPDF='AUTHOR GROUP' TO USE CERN LIBRARY
38636 C   PDFLIB PACKAGE FOR STRUCTURE FUNCTIONS IN BEAM I
38637       MODPDF(1)=-1
38638       MODPDF(2)=-1
38639       AUTPDF(1)='MRS'
38640       AUTPDF(2)='MRS'
38641 C   OR SET MODPDF(I)=-1 TO USE BUILT-IN STRUCTURE FUNCTION SET:
38642 C   1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
38643 C   3,4 FOR EICHTEN+AL SETS 1,2 (NUCLEONS ONLY)
38644 C    5  FOR OWENS      SET  1.1 (SOFT GLUE ONLY)
38645 C    6  FOR MRST98LO   central alpha_s/gluon
38646 C    7  FOR MRST98LO   higher gluon
38647 C    8  FOR MRST98LO average of central and higher gluon (default)
38648       NSTRU=8
38649 C   PARAMETER FOR B CLUSTER DECAY TO 1 HADRON. IF MCL IS CLUSTER MASS
38650 C   AND MTH IS THRESHOLD FOR 2-HADRON DECAY, THEN PROBABILITY IS
38651 C   1 IF MCL<MTH, 0 IF MCL>(1+B1LIM)*MTH, WITH LINEAR INTERPOLATION,
38652       B1LIM=0.0
38653 C---B DECAY PACKAGE ('HERW'=>HERWIG, 'EURO'=>EURODEC, 'CLEO'=>CLEO)
38654       BDECAY='HERW'
38655 C---TAU DECAY PACKAGE ('HERWIG'=>HERWIG, 'TAUOLA'=> TAUOLA)
38656       TAUDEC='HERWIG'
38657 C--default options for TAUOLA (if used)
38658 C JAK=0 ALL MODES
38659 C JAK=1 ELECTRON MODE
38660 C JAK=2 MUON MODE
38661 C JAK=3 PION MODE
38662 C JAK=4 RHO MODE
38663 C JAK=5 A1 MODE
38664 C JAK=6 K MODE
38665 C JAK=7 K* MODE
38666 C JAK=8 nPI MODE
38667 C--tau decay modes (1 is tau+ and 2 is tau-)
38668       JAK1 = 0
38669       JAK2 = 0
38670 C--radiative corrections in tau decay (1 on/ 0 off)
38671       ITDKRC=1
38672 C--use PHOTOS in tau decays (1 PHOTOS/ 0 no PHOTOS)
38673       IFPHOT=1
38674 C--use PHOTOS in ttbar production and decay
38675       ITOPRD=0
38676 C---HARD SUBPROCESS SCALE TO BE USED IN 4-JET MATRIX ELEMENT OPTION
38677 C   IF (FIX4JT) THEN SCALE=C.M. ENERGY
38678 C   ELSE SCALE=2.*MIN(PI.PJ)
38679       FIX4JT=.FALSE.
38680 C---HARD SUBPROCESS SCALE TO BE USED IN BOSON-GLUON FUSION
38681 C   IF (BGSHAT) THEN SCALE=SHAT
38682 C   ELSE SCALE=2.*SHAT*THAT*UHAT/(SHAT**2+THAT**2+UHAT**2)
38683       BGSHAT=.FALSE.
38684 C---RECONSTRUCT DIS EVENTS IN BREIT FRAME
38685       BREIT=.TRUE.
38686 C---TREAT ALL EVENTS IN THEIR CMF (ELSE USE LAB FRAME)
38687       USECMF=.TRUE.
38688 C---TREAT W/Z DECAY IN ITS REST FRAME
38689       WZRFR=.TRUE.
38690 C---PROBABILITY OF UNDERLYING SOFT EVENT:
38691       PRSOF=ONE
38692 C---SOFT UNDERLYING OR MIN BIAS EVENT PARAMETERS
38693 C   DEFAULT VALUES ARE FROM UA5 COLLAB, NPB291(1987)445
38694 C   NCH_PPBAR(SQRT(S)) = PMBN1*S**PMBN2+PMBN3
38695       PMBN1= 9.11
38696       PMBN2= 0.115
38697       PMBN3=-9.50
38698 C   1/K (IN NEG BINOMIAL) = PMBK1*LN(S)+PMBK2
38699       PMBK1= 0.029
38700       PMBK2=-0.104
38701 C   SOFT CLUSTER MASS SPECTRUM (M-M1-M2-PMBM1)*EXP(-PMBM2*M)
38702       PMBM1= 0.4
38703       PMBM2= 2.0
38704 C   SOFT CLUSTER PT SPECTRUM PT*EXP(-B*SQRT(PT**2+M**2))
38705 C   B=PMBP1 FOR D,U, PMBP2 FOR S,C, PMBP3 FOR DIQUARKS
38706       PMBP1= 5.2
38707       PMBP2= 3.0
38708       PMBP3= 5.2
38709 C---MULTIPLICITY ENHANCEMENT FOR UNDERLYING SOFT EVENT:
38710 C   NCH = NCH_PPBAR(ENSOF*SQRT(S))
38711       ENSOF=1.
38712 C   PARAMETERS FOR MUELLER TANG FORMULA: IPROC=2400
38713 C---THE VALUE TO USE FOR FIXED ALPHA_S IN DENOMINATOR
38714       ASFIXD=0.25
38715 C---OMEGA0=12*LOG(2)*ALPHA_S/PI, BUT NOT NECESSARILY THE SAME ALPHA_S
38716       OMEGA0=0.3
38717 C---MIN AND MAX JET RAPIDITIES IN QCD 2->2,
38718 C   HEAVY FLAVOUR, SUSY AND DIRECT PHOTON PROCESSES
38719       YJMAX=8.
38720       YJMIN=-YJMAX
38721 C---MIN AND MAX PARTON TRANSVERSE MOMENTUM
38722 C   IN ELEMENTARY 2 -> 2 SUBPROCESSES
38723       PTMIN=1D1
38724       PTMAX=1D8
38725 C---UPPER LIMIT ON HARD PROCESS SCALE
38726       QLIM=1D8
38727 C---MAX PARTON THRUST IN 2->3 HARD PROCESSES
38728       THMAX=0.9
38729 C   Set parameters for 2->4 hard process
38730 C   Choose inter-jet metric (else JADE) and minimum y-cut
38731       DURHAM=.TRUE.
38732       Y4JT=0.01
38733 C---TREATMENT OF COLOUR INTERFERENCE IN E+E- -> 4 JETS:
38734 C     qqbar-gg case:
38735 C     IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
38736 C     qqbar-qqbar (identical quark flavour) case:
38737 C     IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
38738       IOP4JT(1)=0
38739       IOP4JT(2)=0
38740 C---MIN AND MAX DILEPTON INVARIANT MASS IN DRELL-YAN PROCESS
38741       EMMIN=0D0
38742       EMMAX=1D8
38743 C---MIN AND MAX ABS(Q**2) IN DEEP INELASTIC LEPTON SCATTERING
38744       Q2MIN=0D0
38745       Q2MAX=1D10
38746 C---MIN AND MAX ABS(Q**2) IN WEISZACKER-WILLIAMS APPROXIMATION
38747       Q2WWMN=0.
38748       Q2WWMX=4.
38749 C---MIN AND MAX ENERGY FRACTION IN WEISZACKER-WILLIAMS APPROXIMATION
38750       YWWMIN=0.
38751       YWWMAX=1.
38752 C---MINIMUM HADRONIC MASS FOR PHOTON-INDUCED PROCESSES (INCLUDING DIS)
38753       WHMIN=0.
38754 C---IF PHOMAS IS NON-ZERO, PARTON DISTRIBUTION FUNCTIONS FOR OFF-SHELL
38755 C   PHOTONS IS DAMPED, WITH MASS PARAMETER = PHOMAS
38756       PHOMAS=0.
38757 C---MIN AND MAX FLAVOURS GENERATED BY IPROC=9100,9110,9130
38758       IFLMIN=1
38759       IFLMAX=5
38760 C---MAX Z IN J/PSI PHOTO- AND ELECTRO- PRODUCTION
38761       ZJMAX=0.9
38762 C---MIN AND MAX BJORKEN-Y
38763       YBMIN=0.
38764       YBMAX=1.
38765 C---MIN jet-jet mass in Drell-Yan+2 jets
38766       MJJMIN = 10.0D0
38767 C---MAX COS(THETA) FOR W'S IN E+E- -> W+W-
38768       CTMAX=0.9999
38769 C   Minimum virtuality^2 of partons to use in calculating distances
38770       VMIN2=0.1
38771 C   Exageration factor for lifetimes of weakly decaying heavy particles
38772       EXAG=1.
38773 C   Include colour rearrangement in cluster formation
38774       CLRECO=.FALSE.
38775 C   Probability for colour rearrangement to occur
38776       PRECO=1./9.
38777 C   Minimum lifetime for particle to be considered stable
38778       PLTCUT=1.D-8
38779 C   Incude neutral B-meson mixing
38780       MIXING=.TRUE.
38781 C   Set B_s and B_d mixing parameters: X=Delta m/Gamma
38782       XMIX(1)=10.0
38783       XMIX(2)=0.70
38784 C   Y=Delta Gamma/2*Gamma
38785       YMIX(1)=0.2
38786       YMIX(2)=0.0
38787 C   Include a cut on particle decay lengths
38788       MAXDKL=.FALSE.
38789 C   Set option for decay length cut (see HWDXLM)
38790       IOPDKL=1
38791 C   Radius for cylindrical option (mm) (IOPDKL=1)
38792       DXRCYL=20.0D0
38793 C   Length for cylindrical option(IOPDKL=1)
38794       DXZMAX=500.0D0
38795 C   Radius for spherical option(IOPDKL=2)
38796       DXRSPH=100.0D0
38797 C   Smear the primary interaction vertex: see HWRPIP for details
38798       PIPSMR=.FALSE.
38799 C   Widths of Gaussian smearing in x,y,z (mm)
38800       VIPWID(1)=0.25D0
38801       VIPWID(2)=0.015D0
38802       VIPWID(3)=1.8D0
38803       DO 60 I=0,NMXRES
38804 C   Veto cluster decays into particle type I
38805       VTOCDK(I)=.FALSE.
38806 C   Veto unstable particle decays into modes involving particle type I
38807   60  VTORDK(I)=.FALSE.
38808 C   Veto f_0(980) and a_0(980) production in cluster decays
38809       VTOCDK(290)=.TRUE.
38810       VTOCDK(291)=.TRUE.
38811       VTOCDK(292)=.TRUE.
38812       VTOCDK(293)=.TRUE.
38813 C---MINIMUM AND MAXIMUM S-HAT/S RANGE FOR PHOTON ISR
38814       TMNISR=1D-4
38815       ZMXISR=1-1D-6
38816 C---COLISR IS .TRUE. TO MAKE ISR PHOTONS COLLINEAR WITH BEAMS
38817       COLISR=.FALSE.
38818 C A Priori weights for mesons w.r.t. pionic n=1, 0-(+) states:
38819 C old VECWT=REPWT(0,1,0) & TENWT=REPWT(0,2,0)
38820       DO 70 N=0,4
38821       DO 70 J=0,4
38822       DO 70 L=0,3
38823   70  REPWT(L,J,N)=1.
38824 C and singlet (Lambda-like) and decuplet barons
38825       SNGWT=1.
38826       DECWT=1.
38827 C---A PRIORI WEIGHTS FOR D,U,S,C,B,T QUARKS AND DIQUARKS (IN THAT ORDER)
38828       PWT(1)=1.
38829       PWT(2)=1.
38830       PWT(3)=1.
38831       PWT(4)=1.
38832       PWT(5)=1.
38833       PWT(6)=1.
38834       PWT(7)=1.
38835 C   Octet-Singlet isoscalar mixing angles in degrees
38836 C   (use ANGLE for ideal mixing, recommended for F0MIX & OMHMIX)
38837       ANGLE=ATAN(ONE/SQRT(TWO))*180./ACOS(-ONE)
38838 C     eta - eta'
38839       ETAMIX=-23.
38840 C     phi - omega
38841       PHIMIX=+36.
38842 C     h_1(1380) - h_1(1170)
38843       H1MIX=ANGLE
38844 C     MISSING - f_0(1370)
38845       F0MIX=ANGLE
38846 C     f_1(1420) - f_1(1285)
38847       F1MIX=ANGLE
38848 C     f'_2 - f_2
38849       F2MIX=+26.
38850 C     MISSING - omega(1600)
38851       OMHMIX=ANGLE
38852 C     eta_2(1645) - eta_2(1870)
38853       ET2MIX=ANGLE
38854 C     phi_3 - omega_3
38855       PH3MIX=+28.
38856 C---PARAMETERS FOR NON-PERTURBATIVE SPLITTING OF GLUONS INTO
38857 C   DIQUARK-ANTIDIQUARK PAIRS:
38858 C   SCALE AT WHICH GLUONS CAN BE SPLIT INTO DIQUARKS
38859 C   (0.0 FOR NO SPLITTING)
38860       QDIQK=0.0
38861 C   PROBABILITY (PER UNIT LOG SCALE) OF DIQUARK SPLITTING
38862       PDIQK=5.0
38863 C---PARAMETERS FOR IMPORTANCE SAMPLING
38864 C   ASSUME QCD 2->2 DSIG/DET FALLS LIKE ET**(-PTPOW)
38865 C   WHERE ET=SQRT(MQ**2+PT**2) FOR HEAVY FLAVOURS
38866       PTPOW=4.
38867 C   DEFAULT PTPOW=2 FOR SUSY PROCESSES
38868       IF (MOD(IPROC/100,100).EQ.30) PTPOW=2.
38869 C   ASSUME DRELL-YAN DSIG/DEM FALLS LIKE EM**(-EMPOW)
38870       EMPOW=4.
38871 C   ASSUME DEEP INELASTIC DSIG/DQ**2 FALLS LIKE (Q**2)**(-Q2POW)
38872       Q2POW=2.5
38873 C---GENERATE UNWEIGHTED EVENTS (EVWGT=AVWGT)?
38874       NOWGT=.TRUE.
38875 C---DEFAULT MEAN EVENT WEIGHT
38876       AVWGT=1.
38877 C---ASSUMED MAXIMUM WEIGHT (ZERO TO RECOMPUTE)
38878       WGTMAX=0.
38879 C---MINIMUM ACCEPTABLE EVENT GENERATION EFFICIENCY
38880       EFFMIN=1D-3
38881 C---MAX NO OF (CODE.GE.100) ERRORS
38882       MAXER=MAX(10,MAXEV/100)
38883 C---TIME (SEC) NEEDED TO TERMINATE GRACEFULLY
38884       TLOUT=5.
38885 C---CURRENT NO OF EVENTS
38886       NEVHEP=0
38887 C---CURRENT NO OF ENTRIES IN /HEPEVT/
38888       NHEP=0
38889 C---ISTAT IS STATUS OF EVENT (I.E. STAGE IN PROCESSING)
38890       ISTAT=0
38891 C---IERROR IS ERROR CODE
38892       IERROR=0
38893 C---MORE TECHNICAL PARAMETERS - SHOULDN'T NEED ADJUSTMENT
38894 C---PI
38895       PIFAC=ACOS(-1.D0)
38896 C Speed of light (mm/s)
38897       CSPEED=2.99792D11
38898 C Cross-section conversion factor (hbar.c/e)**2
38899       GEV2NB=389379.D0
38900 C---NUMBER OF SHOTS FOR INITIAL MAX WEIGHT SEARCH
38901       IBSH=10000
38902 C---RANDOM NO. SEEDS FOR INITIAL MAX WEIGHT SEARCH
38903       IBRN(1)=1246579
38904       IBRN(2)=8447766
38905 C--Number of shots and steps for the optimisation procedure
38906       IOPSH  = 1000
38907       IOPSTP = 10
38908 C---NUMBER OF ENTRIES IN LOOKUP TABLES OF SUDAKOV FORM FACTORS
38909       NQEV=1024
38910 C---MAXIMUM BIN SIZE IN Z FOR SPACELIKE BRANCHING
38911       ZBINM=0.05
38912 C---MAXIMUM NUMBER OF Z BINS FOR SPACELIKE BRANCHING
38913       NZBIN=100
38914 C---MAXIMUM NUMBER OF BRANCH REJECTIONS (TO AVOID INFINITE LOOPS)
38915       NBTRY=200
38916 C---MAXIMUM NUMBER OF TRIES TO GENERATE CLUSTER DECAY
38917       NCTRY=200
38918 C---MAXIMUM NUMBER OF TRIES TO GENERATE MASS REQUESTED
38919       NETRY=200
38920 C---MAXIMUM NUMBER OF TRIES TO GENERATE SOFT SUBPROCESS
38921       NSTRY=200
38922 C---MAXIMUM NUMBER OF TRIES TO GENERATE SPIN DECAYS
38923       NSNTRY=500
38924 C---PRECISION FOR GAUSSIAN INTEGRATION
38925       ACCUR=1.D-6
38926 C---ORDER OF INTERPOLATION IN SUDAKOV TABLES
38927       INTER=3
38928 C---ORDER TO USE FOR ALPHAS IN SUDAKOV TABLES
38929       SUDORD=1
38930 C---DEFAULT UNIT FOR THE SUSY DATA FILE
38931       LRSUSY = 66
38932 C---CONSERVATION OF RPARITY
38933       RPARTY = .TRUE.
38934 C---CHECK WHETHER SUSY DATA INPUTTED
38935       SUSYIN = .FALSE.
38936 C---SPIN CORRELATIONS IN TOP/TAU/SUSY DECAYS
38937       SYSPIN = .TRUE.
38938 C---THREE BODY SUSY MATRIX ELEMENTS
38939       THREEB = .TRUE.
38940 C---FOUR  BODY SUSY MATRIX ELEMENTS
38941       FOURB  = .FALSE.
38942 C---OPTION FOR DIFFERENT COLOUR FLOWS IN SPIN CORRELATION
38943 C---(1 is first  option in DAMTP-2001-83 only for SM/MSSM)
38944 C---(2 is second option in DAMTP-2001-83 needed for RPV)
38945       SPCOPT = 1
38946 C---number of weights for maximum search for 3/4 body MEs
38947       NSEARCH = 500
38948 C--unit to read three/four body decays from (if 0 computed)
38949       LRDEC = 0
38950 C--unit to write three/four body decays to (if 0 not written)
38951       LWDEC = 88
38952 C--WHETHER OR NOT TO OPTIMIZE THE WEIGHTS IN MULTICHANNEL PROCESSES
38953       OPTM = .FALSE.
38954 C--initializes the multichannel integrals
38955       CALL HWIPHS(1)
38956 C   CIRCE INTERFACE
38957 C---CIRCE IS CONTROLLED BY THESE NEW VARIABLES:
38958 C---CIRCOP = CIRCE OPTION: 0=NO CIRCE, STANDARD HERWIG
38959 C                          1=NO CIRCE, HERWIG WITH COLLINEAR KINEMATICS
38960 C                          2=BEAMSTRAHLUNG FROM CIRCE
38961 C                          3=BEAMSTRAHLUNG FROM CIRCE PLUS BREMSTRAHLUNG
38962 C   THEREFORE 0 SHOULD BE REGARDED AS OFF AND 3 AS ON.  THE OTHERS ARE
38963 C   MAINLY THERE FOR CROSS-CHECKING PURPOSES
38964       CIRCOP=0
38965 C---CIRCAC, CIRCVR, CIRCRV, CIRCCH = CIRCE INPUTS ACC, VER, REV AND CHAT
38966 C   EG CIRCAC=1=SBAND, CIRCAC=2=TESLA, CIRCAC=3=XBAND
38967       CIRCAC=2
38968       CIRCVR=7
38969       CIRCRV=9999 12 31
38970       CIRCCH=0
38971 C---END OF CIRCE VARIABLES
38972 C--options for Les Houches Accord
38973 C--allow self connected gluons (.TRUE.) or forbid (.FALSE.)
38974       LHGLSF = .FALSE.
38975 C--generate the soft event (.TRUE.) or don't (.FALSE.)
38976       LHSOFT = .TRUE.
38977 C--conserve longitudinal momentum (.true.) or rapidity of hard process
38978       PRESPL = .TRUE.
38979   999 END
38980 CDECK  ID>, HWIGUP.
38981 *CMZ :-        -15/07/02  16.42.23  by  Peter Richardson
38982 *-- Author :    Peter Richardson
38983 C----------------------------------------------------------------------
38984       SUBROUTINE HWIGUP
38985 C----------------------------------------------------------------------
38986 C     Use the GUPI (Generic User Process Interface) run common block
38987 C     to initialise HERWIG
38988 C----------------------------------------------------------------------
38989       INCLUDE 'HERWIG65.INC'
38990       INTEGER MAXPUP
38991       PARAMETER(MAXPUP=100)
38992       INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
38993       DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
38994       COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
38995      &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
38996      &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
38997       CHARACTER *8 DUMMY,PDFNUC(9),PDFPI(9),PDFPHT(9)
38998       DATA PDFNUC/ 'DO','DFLM','MRS','CTEQ','GRV','ABFOW','BM',
38999      &             '        ','         '/
39000       DATA PDFPI / 'OW-P','        ','SMRS-P','        ','GRV-P',
39001      &             'ABFKW-P','        ','        ','        '/
39002       DATA PDFPHT /'DO-G','DG-G','LAC-G','GS-G','GRV-G','ACG-G',
39003      &             '         ','WHIT-G','SaSph'/
39004       INTEGER I,IDB(2)
39005 C--call the user routine to do the initialisation
39006       CALL UPINIT_GUP
39007 C--setup the beam particles and momentum
39008       CALL HWUIDT(1,IDBMUP(1),IDB(1),DUMMY)
39009       PART1=DUMMY
39010       CALL HWUIDT(1,IDBMUP(2),IDB(2),DUMMY)
39011       PART2=DUMMY
39012       PBEAM1 = SQRT(EBMUP(1)**2-RMASS(IDB(1))**2)
39013       PBEAM2 = SQRT(EBMUP(2)**2-RMASS(IDB(2))**2)
39014 C--set up for PDFLIB if need
39015       DO I=1,2
39016         IF(PDFGUP(I).NE.-1) THEN
39017           IF(PDFGUP(I).LT.1.OR.PDFGUP(I).GT.9) then
39018                 print*,'bad value'
39019                CALL HWWARN('HWIGUP',500,*999)
39020           endif
39021           MODPDF(I) = PDFSUP(I)
39022 C--proton/neutron beams
39023           IF(ABS(IDBMUP(I)).EQ.2212.OR.ABS(IDBMUP(I)).EQ.2112) THEN
39024             AUTPDF(I) = PDFNUC(PDFGUP(I))
39025 C--photon beams
39026           ELSEIF(ABS(IDBMUP(I)).EQ.22) THEN
39027             AUTPDF(I) = PDFPHT(PDFGUP(I))
39028 C--pion beams
39029           ELSEIF(ABS(IDBMUP(I)).EQ.211) THEN
39030             AUTPDF(I) = PDFPI(PDFGUP(I))
39031 C--unknown beam type
39032           ELSE
39033             print*,'unknown beam type'
39034             CALL HWWARN('HWIGUP',500,*999)
39035           ENDIF
39036         ENDIF
39037       ENDDO
39038 C--decide what to do about the weights
39039       IF(ABS(IDWTUP).EQ.1) THEN
39040         WGTMAX = ZERO
39041         AVWGT  = ONE
39042         AVABW  = ONE
39043         NOWGT  = .TRUE.
39044 C--sum up the magnitudes of the maximum weight
39045         LHMXSM = ZERO
39046         DO I=1,NPRUP
39047           LHXMAX(I) = XMAXUP(I)*1.0D-3
39048           LHMXSM    = LHMXSM+ABS(LHXMAX(I))
39049         ENDDO
39050         ITYPLH = 0
39051       ELSEIF(ABS(IDWTUP).EQ.2) THEN
39052         WGTMAX = ZERO
39053         AVWGT  = ONE
39054         AVABW  = ONE
39055         NOWGT = .TRUE.
39056 C--sum the cross sections and obtain the total
39057         LHMXSM = ZERO
39058         DO I=1,NPRUP
39059           LHXSCT(I) = XSECUP(I)*1.0D-3
39060           LHXMAX(I) = XMAXUP(I)*1.0D-3
39061           LHMXSM = LHMXSM+ABS(LHXSCT(I))
39062         ENDDO
39063         ITYPLH = 0
39064       ELSEIF(ABS(IDWTUP).EQ.3) THEN
39065         WGTMAX = ONE
39066         AVWGT  = ONE
39067         AVABW  = ONE
39068         NOWGT = .TRUE.
39069       ELSEIF(ABS(IDWTUP).EQ.4) THEN
39070         WGTMAX = ONE
39071         AVWGT  = ONE
39072         NOWGT = .FALSE.
39073       ENDIF
39074       IF(IDWTUP.LT.0) NEGWTS = .TRUE.
39075 C--zero the weight
39076       DO I=1,NPRUP
39077         LHWGT (I) = ZERO
39078         LHWGTS(I) = ZERO
39079         LHIWGT(I) = 0
39080         LHNEVT(I) = 0
39081       ENDDO
39082  999  END
39083 CDECK  ID>, HWIMDE.
39084 *CMZ :-        -12/10/01  17.14.22  by  Peter Richardson
39085 *-- Author :    Peter Richardson
39086 C-----------------------------------------------------------------------
39087       SUBROUTINE HWIMDE
39088 C-----------------------------------------------------------------------
39089 C     Subroutine to merge Higgs WW/ZZ decay modes for four body ME
39090 C-----------------------------------------------------------------------
39091       INCLUDE 'HERWIG65.INC'
39092       INTEGER IH,I,NMODE,J,IMAX,K
39093       LOGICAL REMOVE
39094       DOUBLE PRECISION BR
39095       REMOVE = .FALSE.
39096 C--first identify the WW modes
39097       DO IH=203,204
39098         BR = ZERO
39099         NMODE = 0
39100         DO I=NDECSY,NDKYS
39101           IF(IDK(I).EQ.IH.AND.((IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
39102      &      .AND.(IDKPRD(1,I).EQ.198.OR.IDKPRD(1,I).EQ.199).AND.
39103      &          ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
39104      &           (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
39105      &            IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132)))
39106      &          .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
39107      &          (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
39108      &            (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
39109      &             IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
39110      &          .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).NE.0)
39111      &          .AND.
39112      &          (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
39113      &           (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
39114      &            IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
39115      &       .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).NE.0))))) THEN
39116             BR=BR+BRFRAC(I)
39117             NME(I) = -100
39118             NMODE=NMODE+1
39119           ENDIF
39120         ENDDO
39121 C--add the new mode to the event record
39122         IF(NMODE.GT.0) THEN
39123           REMOVE = .TRUE.
39124           NDKYS = NDKYS+1
39125           IDK(NDKYS) = IH
39126           BRFRAC(NDKYS) = BR
39127           NME(I) = 0
39128           IDKPRD(1,NDKYS) = 198
39129           IDKPRD(2,NDKYS) = 199
39130           DO I=3,5
39131             IDKPRD(I,NDKYS) = 0
39132           ENDDO
39133         ENDIF
39134       ENDDO
39135 C--now do the ZZ modes
39136       DO IH=203,204
39137         BR = ZERO
39138         NMODE = 0
39139         DO I=NDECSY,NDKYS
39140           IF(IDK(I).EQ.IH.AND.(IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
39141      &          .AND.IDKPRD(1,I).EQ.200.AND.
39142      &          ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
39143      &           (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
39144      &            IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132))
39145      &          .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
39146      &          (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
39147      &            (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
39148      &             IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
39149      &          .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).EQ.0)
39150      &          .AND.
39151      &          (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
39152      &           (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
39153      &            IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
39154      &     .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).EQ.0))))) THEN
39155             BR=BR+BRFRAC(I)
39156             NME(I) = -100
39157             NMODE=NMODE+1
39158           ENDIF
39159         ENDDO
39160 C--add the new mode to the event record
39161         IF(NMODE.GT.0) THEN
39162           REMOVE = .TRUE.
39163           NDKYS = NDKYS+1
39164           IDK(NDKYS) = IH
39165           BRFRAC(NDKYS) = BR
39166           NME(I) = 0
39167           IDKPRD(1,NDKYS) = 200
39168           IDKPRD(2,NDKYS) = 200
39169           DO I=3,5
39170             IDKPRD(I,NDKYS) = 0
39171           ENDDO
39172         ENDIF
39173       ENDDO
39174       IF(.NOT.REMOVE) RETURN
39175 C--now remove the modes we have marked
39176       IMAX = NDKYS
39177       I = 0
39178       DO J=NDECSY,NDKYS
39179  10     IF(NME(I+J).EQ.-100) I=I+1
39180         IDK(J) = IDK(J+I)
39181         BRFRAC(J)=BRFRAC(I+J)
39182         NME(J) = NME(I+J)
39183         DO K=1,5
39184           IDKPRD(K,J)=IDKPRD(K,I+J)
39185         ENDDO
39186         IF(NME(J).EQ.-100) GOTO 10
39187       ENDDO
39188 C--reset the number of modes
39189       NDKYS = NDKYS-I
39190       END
39191 CDECK  ID>, HWIPHS.
39192 *CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
39193 *-- Author :    Peter Richardson
39194 C-----------------------------------------------------------------------
39195       SUBROUTINE HWIPHS(IOPT)
39196 C-----------------------------------------------------------------------
39197 C     Subroutine to initialise the multichannel integration
39198 C     IOPT = 1 sets the weights for the different channels to their
39199 C              default values
39200 C     IOPT = 2 optimises the weights for the process selected
39201 C-----------------------------------------------------------------------
39202       INCLUDE 'HERWIG65.INC'
39203       INTEGER I,IPRC,ICH,IOPT,ISTP,IWGT,IFER,IANT,IGAU,IQRK
39204       LOGICAL CALLED,TEV,LHC
39205       DOUBLE PRECISION CHNPST(IMAXCH,IMAXOP),D(IMAXOP),CHWGTS(IMAXCH),
39206      &     TOTAL,DEM,DMIN,CV,CA,BR,WA(IMAXCH),WITOT,WI(IMAXCH),
39207      &     TEVGWT(10,5),LHCGWT(10,5),TEVQWT(6,6,2),LHCQWT(6,6,2)
39208       COMMON /HWPSOM/ WI
39209       DATA CALLED/.FALSE./
39210       DATA TEVGWT/0.19684D0,0.00403D0,0.63772D0,0.01209D0,0.01321D0,
39211      &            0.00054D0,0.12984D0,0.00257D0,0.00296D0,0.00019D0,
39212      &            0.24146D0,0.00944D0,0.33949D0,0.01430D0,0.01918D0,
39213      &            0.00169D0,0.33919D0,0.01433D0,0.01931D0,0.00161D0,
39214      &            0.22270D0,0.00004D0,0.38873D0,0.00007D0,0.00009D0,
39215      &            0.00000D0,0.38820D0,0.00007D0,0.00009D0,0.00000D0,
39216      &            0.03228D0,0.00629D0,0.43227D0,0.01147D0,0.00010D0,
39217      &            0.03685D0,0.43270D0,0.01193D0,0.00010D0,0.03602D0,
39218      &            0.05828D0,0.00018D0,0.46870D0,0.00033D0,0.00047D0,
39219      &            0.00092D0,0.46940D0,0.00033D0,0.00047D0,0.00094D0/
39220       DATA LHCGWT/0.10679D0,0.00075D0,0.50915D0,0.00105D0,0.00126D0,
39221      &            0.00039D0,0.37853D0,0.00080D0,0.00092D0,0.00037D0,
39222      &            0.18163D0,0.00456D0,0.38555D0,0.00906D0,0.01160D0,
39223      &            0.00095D0,0.38498D0,0.00920D0,0.01163D0,0.00084D0,
39224      &            0.16647D0,0.00003D0,0.41691D0,0.00007D0,0.00009D0,
39225      &            0.00000D0,0.41627D0,0.00007D0,0.00009D0,0.00000D0,
39226      &            0.01957D0,0.00578D0,0.42971D0,0.01087D0,0.00015D0,
39227      &            0.02305D0,0.47944D0,0.00750D0,0.00016D0,0.02377D0,
39228      &            0.03659D0,0.00027D0,0.45268D0,0.00041D0,0.00063D0,
39229      &            0.00062D0,0.50700D0,0.00045D0,0.00069D0,0.00066D0/
39230       DATA TEVQWT/0.37855D0,0.15212D0,0.38016D0,0.00048D0,0.00047D0,
39231      &            0.08822D0,0.37292D0,0.19051D0,0.36770D0,0.00178D0,
39232      &            0.00180D0,0.06529D0,0.37724D0,0.12202D0,0.37579D0,
39233      &            0.00013D0,0.00013D0,0.12470D0,0.36728D0,0.12100D0,
39234      &            0.36521D0,0.00014D0,0.00014D0,0.14622D0,0.37548D0,
39235      &            0.12144D0,0.37410D0,0.00013D0,0.00013D0,0.12873D0,
39236      &            0.08694D0,0.32633D0,0.07192D0,0.00000D0,0.00000D0,
39237      &            0.51481D0,0.37831D0,0.15131D0,0.38081D0,0.00079D0,
39238      &            0.00077D0,0.08801D0,0.37494D0,0.19012D0,0.36496D0,
39239      &            0.00243D0,0.00246D0,0.06509D0,0.37726D0,0.12071D0,
39240      &            0.37641D0,0.00031D0,0.00032D0,0.12499D0,0.36248D0,
39241      &            0.12007D0,0.36203D0,0.00242D0,0.00243D0,0.15057D0,
39242      &            0.31054D0,0.13065D0,0.30760D0,0.04158D0,0.04178D0,
39243      &            0.16785D0,0.04116D0,0.00125D0,0.04116D0,0.32149D0,
39244      &            0.32030D0,0.27465D0/
39245       DATA LHCQWT/0.45556D0,0.06337D0,0.45712D0,0.00022D0,0.00022D0,
39246      &            0.02351D0,0.43712D0,0.07332D0,0.45023D0,0.00021D0,
39247      &            0.00021D0,0.03890D0,0.44611D0,0.08021D0,0.44572D0,
39248      &            0.00176D0,0.00170D0,0.02450D0,0.47268D0,0.03728D0,
39249      &            0.46843D0,0.00004D0,0.00004D0,0.02152D0,0.45662D0,
39250      &            0.06644D0,0.45586D0,0.00065D0,0.00063D0,0.01980D0,
39251      &            0.18486D0,0.27252D0,0.19067D0,0.00000D0,0.00000D0,
39252      &            0.35195D0,0.45530D0,0.06307D0,0.45770D0,0.00037D0,
39253      &            0.00038D0,0.02318D0,0.43653D0,0.07295D0,0.45173D0,
39254      &            0.00036D0,0.00036D0,0.03807D0,0.47312D0,0.04168D0,
39255      &            0.46993D0,0.00010D0,0.00010D0,0.01506D0,0.47047D0,
39256      &            0.03721D0,0.46860D0,0.00101D0,0.00100D0,0.02172D0,
39257      &            0.44379D0,0.05231D0,0.45440D0,0.01608D0,0.01624D0,
39258      &            0.01717D0,0.25443D0,0.04115D0,0.25503D0,0.18346D0,
39259      &            0.18255D0,0.08337D0/
39260       SAVE CALLED,DEM
39261       IF(IERROR.NE.0) RETURN
39262 C--initialize for tevatron or LHC based on energy
39263       TEV = NINT(PBEAM1/1000.0D0).EQ.1
39264       LHC = NINT(PBEAM1/1000.0D0).EQ.7
39265 C--first the initalisation
39266       IF(IOPT.EQ.1) THEN
39267         IPRO = MOD(IPROC/100,100)
39268         IPRC=MOD(IPROC,100)
39269         DO I=1,20
39270           CHNPRB(I) = ZERO
39271           CHON(I) = .FALSE.
39272         ENDDO
39273 C--gauge boson pair production
39274         IF(IPRO.EQ.28.AND.IPRC.LT.50) THEN
39275           IF(MOD(IPRC,5).NE.0.OR.IPRC.EQ.5.OR.IPRC.GT.25)
39276      &          CALL HWWARN('HWIPHS',500,*999)
39277           DO I=1,10
39278              CHON(I) = .TRUE.
39279           ENDDO
39280 C--select the process
39281           IGAU = INT(IPRC/5)
39282           IF(IGAU.EQ.0) IGAU = IGAU+1
39283           IF(TEV) THEN
39284             DO I=1,10
39285               CHNPRB(I) = TEVGWT(I,IGAU)
39286             ENDDO
39287           ELSEIF(LHC) THEN
39288             DO I=1,10
39289               CHNPRB(I) = LHCGWT(I,IGAU)
39290             ENDDO
39291           ELSE
39292             DO I=1,10
39293               CHNPRB(I) = 0.1D0
39294             ENDDO
39295           ENDIF
39296           CALLED=.TRUE.
39297           DEM = ONE/DBLE(IOPSH)
39298 C--Drell Yan + 2 jet production
39299         ELSEIF(IPRO.EQ.29) THEN
39300           DO I=1,6
39301             CHON(I) = .TRUE.
39302           ENDDO
39303           IF(IPRC.LE.6) THEN
39304             IGAU = 1
39305           ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
39306             IGAU = 2
39307           ELSE
39308             CALL HWWARN('HWIPHS',502,*999)
39309           ENDIF
39310           IQRK = MOD(IPRC,10)
39311           IF(IQRK.EQ.0.OR.IQRK.GT.6) CALL HWWARN('HWIPHS',503,*999)
39312           IF(TEV) THEN
39313             DO I=1,6
39314               CHNPRB(I) = TEVQWT(I,IQRK,IGAU)
39315             ENDDO
39316           ELSEIF(LHC) THEN
39317             DO I=1,6
39318               CHNPRB(I) = LHCQWT(I,IQRK,IGAU)
39319             ENDDO
39320           ELSE
39321             DO I=1,6
39322               CHNPRB(I) = 1.0D0/6.0D0
39323             ENDDO
39324           ENDIF
39325           CALLED=.TRUE.
39326           DEM = ONE/DBLE(IOPSH)
39327         ELSE
39328           RETURN
39329         ENDIF
39330       ELSE
39331         IF(.NOT.CALLED) RETURN
39332         TOTAL = ZERO
39333         DO I=1,IMAXCH
39334           IF(CHON(I)) TOTAL = TOTAL+CHNPRB(I)
39335         ENDDO
39336         IF(TOTAL.EQ.ZERO) CALL HWWARN('HWIPHS',501,*999)
39337         IF(TOTAL.NE.ONE) THEN
39338           DO I=1,IMAXCH
39339             IF(CHON(I)) CHNPRB(I) = CHNPRB(I)/TOTAL
39340           ENDDO
39341         ENDIF
39342         IF(.NOT.OPTM) RETURN
39343         WRITE(*,50)
39344 C--optimise the weights
39345         FSTWGT=.TRUE.
39346 C---SET UP INITIAL STATE
39347         NHEP=1
39348         ISTHEP(NHEP)=101
39349         PHEP(1,NHEP)=0.
39350         PHEP(2,NHEP)=0.
39351         PHEP(3,NHEP)=PBEAM1
39352         PHEP(4,NHEP)=EBEAM1
39353         PHEP(5,NHEP)=RMASS(IPART1)
39354         JMOHEP(1,NHEP)=0
39355         JMOHEP(2,NHEP)=0
39356         JDAHEP(1,NHEP)=0
39357         JDAHEP(2,NHEP)=0
39358         IDHW(NHEP)=IPART1
39359         IDHEP(NHEP)=IDPDG(IPART1)
39360         NHEP=NHEP+1
39361         ISTHEP(NHEP)=102
39362         PHEP(1,NHEP)=0.
39363         PHEP(2,NHEP)=0.
39364         PHEP(3,NHEP)=-PBEAM2
39365         PHEP(4,NHEP)=EBEAM2
39366         PHEP(5,NHEP)=RMASS(IPART2)
39367         JMOHEP(1,NHEP)=0
39368         JMOHEP(2,NHEP)=0
39369         JDAHEP(1,NHEP)=0
39370         JDAHEP(2,NHEP)=0
39371         IDHW(NHEP)=IPART2
39372         IDHEP(NHEP)=IDPDG(IPART2)
39373 C---NEXT ENTRY IS OVERALL CM FRAME
39374         NHEP=NHEP+1
39375         IDHW(NHEP)=14
39376         IDHEP(NHEP)=0
39377         ISTHEP(NHEP)=103
39378         JMOHEP(1,NHEP)=NHEP-2
39379         JMOHEP(2,NHEP)=NHEP-1
39380         JDAHEP(1,NHEP)=0
39381         JDAHEP(2,NHEP)=0
39382         CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
39383         CALL HWUMAS(PHEP(1,NHEP))
39384         DO ISTP=1,IOPSTP
39385           WRITE(*,100) ISTP
39386           DO ICH=1,IMAXCH
39387             CHWGTS(ICH)  = ZERO
39388             CHNPST(ICH,ISTP) = CHNPRB(ICH)
39389             IF(CHON(ICH)) WRITE(*,200) ICH,CHNPRB(ICH)
39390           ENDDO
39391 C--compute the weights for the various channels
39392           DO I=1,IOPSH
39393              IF(IPRO.EQ.28) THEN
39394                CALL HWHGBP
39395                FSTWGT=.FALSE.
39396                CALL HWDBZ2(200,IFER,IANT,CV,CA,BR,2,ZERO)
39397              ELSEIF(IPRO.EQ.29) THEN
39398                CALL HWHV2J
39399                FSTWGT=.FALSE.
39400                CALL HWDBOZ(200,IFER,IANT,CV,CA,BR,2)
39401              ENDIF
39402              DO ICH=1,IMAXCH
39403              IF(CHON(ICH)) CHWGTS(ICH) = CHWGTS(ICH)+WI(ICH)
39404              ENDDO
39405           ENDDO
39406           WITOT = ZERO
39407           DO ICH=1,IMAXCH
39408             IF(CHON(ICH)) THEN
39409               WA(ICH)  = CHWGTS(ICH)*DEM
39410               WITOT = WITOT+WA(ICH)*CHNPRB(ICH)
39411             ENDIF
39412           ENDDO
39413 C--now pick the next set of probablities for the different channels
39414           TOTAL = ZERO
39415           DO ICH=1,IMAXCH
39416             IF(CHON(ICH)) THEN
39417               CHNPRB(ICH) = CHNPRB(ICH)*SQRT(WA(ICH))
39418               TOTAL = TOTAL+CHNPRB(ICH)
39419             ENDIF
39420           ENDDO
39421           DO ICH=1,IMAXCH
39422             CHNPRB(ICH)=CHNPRB(ICH)/TOTAL
39423           ENDDO
39424           D(ISTP) = ZERO
39425           DO ICH=1,IMAXCH
39426             IF(CHON(ICH)) THEN
39427               IF(D(ISTP).EQ.ZERO) THEN
39428                  D(ISTP) = ABS(WITOT-WA(ICH))
39429               ELSE
39430                  D(ISTP) = MAX(D(ISTP),ABS(WITOT-WA(ICH)))
39431               ENDIF
39432             ENDIF
39433           ENDDO
39434           WRITE(*,300) D(ISTP)
39435         ENDDO
39436 C--pick the best set of weights
39437         IWGT = 1
39438         DMIN = D(1)
39439         DO I=2,IOPSTP
39440           IF(D(I).LT.DMIN) THEN
39441             IWGT = I
39442             DMIN = D(I)
39443           ENDIF
39444         ENDDO
39445         WRITE(*,500) IWGT
39446         DO I=1,IMAXCH
39447           IF(CHON(I)) THEN
39448             CHNPRB(I)=CHNPST(I,IWGT)
39449             WRITE(*,200) I,CHNPRB(I)
39450           ENDIF
39451         ENDDO
39452         OPTM = .FALSE.
39453       ENDIF
39454       RETURN
39455  50   FORMAT(/10X,'OPTIMIZING THE WEIGHTS FOR MULTICHANNEL INTEGRATION')
39456  100  FORMAT(/10X,'PERFORMING ITERATION',I2,/10X)
39457  200  FORMAT( 12X,'CHNPRB(',I2,') = ',F7.5)
39458  300  FORMAT(/10X,'DIFFERENCE IN W BETWEEN CHANNELS',E15.5)
39459  500  FORMAT(/10X,'SELECTED ITERATION',I2)
39460  999  END
39461 CDECK  ID>, HWISPC.
39462 *CMZ :-        -27/07/99  16.38.25  by  Peter Richardson
39463 *-- Author :    Peter Richardson
39464 C-----------------------------------------------------------------------
39465       SUBROUTINE HWISPC
39466 C-----------------------------------------------------------------------
39467 C     Calculates the couplings for the SUSY decays for spin correlations
39468 C     and 3/4 body matrix elements
39469 C-----------------------------------------------------------------------
39470       INCLUDE 'HERWIG65.INC'
39471       DOUBLE PRECISION HWUALF,PRE,MCHAR(2),QIJPP(4,4),SIJPP(4,4),
39472      &     DIJ(2,2),QIJ(2,2),R(4,2),SIJ(2,2)
39473       INTEGER I,J,K,L,IH,IK,IL,IQ
39474       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
39475      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
39476       DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
39477      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
39478      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
39479      &     HZZ(2),ZAB(12,2,2),HHB(2,3)
39480       DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
39481       EXTERNAL HWUALF
39482       IF(IERROR.NE.0) RETURN
39483 C--coupling constants
39484       SW  = SQRT(SWEIN)
39485       CW  = SQRT(ONE-SWEIN)
39486       TW  = SW/CW
39487       E   = SQRT(FOUR*PIFAC/128.0D0)
39488       G   = E/SW
39489       RT  = SQRT(TWO)
39490       ORT = ONE/RT
39491       MW  = RMASS(198)
39492       MZ  = RMASS(200)
39493       IF(.NOT.SUSYIN) RETURN
39494       GS  = SQRT(HWUALF(3,RMASS(449))*FOUR*PIFAC)
39495 C--couplings of the neutralinos to the squarks
39496       DO 1 L=1,4
39497       MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
39498       MCHAR(2) = ORT*G*ZMIXSS(L,4)/MW/SINB
39499       DO 1 I=1,3
39500       J = 2*I-1
39501       DO 2 K=1,2
39502       AFN(1,J,K,L) =-MCHAR(1)*RMASS(J)*QMIXSS(J,2,K)
39503      &                    -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
39504  2    AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(J)*QMIXSS(J,1,K)
39505      &                          +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
39506       J = 2*I
39507       DO 1 K=1,2
39508       AFN(1,J,K,L) =-MCHAR(2)*RMASS(J)*QMIXSS(J,2,K)
39509      &                       -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
39510  1    AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(2)*RMASS(J)*QMIXSS(J,1,K)
39511      &                        +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
39512 C--couplings of the neutralinos to the sleptons
39513       DO 3 L=1,4
39514       MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
39515       DO 3 I=1,3
39516       J = 2*I-1
39517       IL = J+10
39518       IK = J+6
39519       DO 4 K=1,2
39520       AFN(1,IK,K,L) =-(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,2,K)
39521      &                        +RT*E*LMIXSS(J,1,K)*SLFCH(IL,L))
39522  4    AFN(2,IK,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,1,K)
39523      &                            +RT*E*LMIXSS(J,2,K)*SRFCH(IL,L))
39524       J = J+1
39525       IL = IL+1
39526       IK = IK+1
39527       DO 3 K=1,2
39528       AFN(1,IK,K,L) =-RT*E*LMIXSS(J,1,K)*SLFCH(IL,L)
39529  3    AFN(2,IK,K,L) = ZERO
39530 C--couplings of the gluinos to the squarks
39531       DO 5 I=1,6
39532       DO 5 K=1,2
39533       AFG(1,I,K) = -GS*RT*QMIXSS(I,1,K)
39534  5    AFG(2,I,K) = +GS*RT*QMIXSS(I,2,K)
39535 C--couplings of the charginos to the squarks
39536       DO 6 L=1,2
39537       MCHAR(1) =-WMXVSS(L,2)*ORT/MW/SINB
39538       MCHAR(2) =-WMXUSS(L,2)*ORT/MW/COSB
39539       DO 6 I=1,3
39540       J = 2*I-1
39541       DO 7 K=1,2
39542       AFC(1,J,K,L) = -G*( WMXUSS(L,1)*QMIXSS(J,1,K)
39543      &                   +MCHAR(2)*RMASS(J)*QMIXSS(J,2,K))
39544  7    AFC(2,J,K,L) = -G*WSGNSS(L)*MCHAR(1)*
39545      &              RMASS(J+1)*QMIXSS(J,1,K)
39546       J = 2*I
39547       DO 6 K=1,2
39548       AFC(1,J,K,L) = -G*WSGNSS(L)*( WMXVSS(L,1)*QMIXSS(J,1,K)
39549      &                           +MCHAR(1)*RMASS(J)*QMIXSS(J,2,K))
39550  6    AFC(2,J,K,L) = -G*MCHAR(2)*RMASS(J-1)*QMIXSS(J,1,K)
39551 C--couplings of the charginos to the sleptons
39552       DO 8 L=1,2
39553       MCHAR(1) = -WMXUSS(L,2)*ORT/MW/COSB
39554       DO 8 I=1,3
39555       J = 2*I-1
39556       IL = J+6
39557       DO 9 K=1,2
39558       AFC(1,IL,K,L) = -G*(WMXUSS(L,1)*LMIXSS(J,1,K)
39559      &                +RMASS(120+J)*MCHAR(1)*LMIXSS(J,2,K))
39560  9    AFC(2,IL,K,L) = ZERO
39561       J = J+1
39562       IL = IL+1
39563       DO 8 K=1,2
39564       AFC(1,IL,K,L) =-WSGNSS(L)*G*WMXVSS(L,1)
39565  8    AFC(2,IL,K,L) =-MCHAR(1)*G*RMASS(119+J)
39566 C--couplings of chargino-neutralino to the W
39567       DO 10 I=1,4
39568       DO 10 J=1,2
39569       OIJ(1,I,J) = G*( ORT*ZMXNSS(I,3)*WMXUSS(J,2)
39570      &                    +ZMXNSS(I,2)*WMXUSS(J,1))
39571  10   OIJ(2,I,J) = ZSGNSS(I)*WSGNSS(J)*G*(-ORT*ZMXNSS(I,4)*WMXVSS(J,2)
39572      &                                        +ZMXNSS(I,2)*WMXVSS(J,1))
39573 C--couplings of chargino-chargino to the Z
39574       PRE = G/CW
39575       DO 11 I=1,2
39576       DO 11 J=1,2
39577       OIJP(1,I,J) = PRE*(-WMXUSS(I,1)*WMXUSS(J,1)
39578      &             -HALF*WMXUSS(I,2)*WMXUSS(J,2)+DIJ(I,J)*SWEIN)
39579  11   OIJP(2,I,J) = WSGNSS(I)*WSGNSS(J)*PRE*(-WMXVSS(I,1)*WMXVSS(J,1)
39580      &             -HALF*WMXVSS(I,2)*WMXVSS(J,2)+DIJ(I,J)*SWEIN)
39581 C--couplings of neutralino-neutralino to the Z
39582       PRE = HALF*G/CW
39583       DO 12 I=1,4
39584       DO 12 J=1,4
39585       OIJPP(1,I,J) = PRE*(ZMIXSS(I,3)*ZMIXSS(J,3)
39586      &                           -ZMIXSS(I,4)*ZMIXSS(J,4))
39587  12   OIJPP(2,I,J) = -ZSGNSS(I)*ZSGNSS(J)*OIJPP(1,I,J)
39588 C--couplings of the neutralino-neutralino to the Higgs
39589       DO 13 I=1,4
39590       DO 13 J=1,4
39591       QIJPP(I,J) = HALF*ZSGNSS(I)*
39592      &                      (ZMXNSS(I,3)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
39593      &                      +ZMXNSS(J,3)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
39594  13   SIJPP(I,J) = HALF*ZSGNSS(I)*
39595      &                      (ZMXNSS(I,4)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
39596      &                      +ZMXNSS(J,4)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
39597       DO 14 I=1,4
39598       DO 14 J=1,4
39599       HNN(1,1,I,J) = G*(QIJPP(I,J)*SINA+SIJPP(I,J)*COSA)
39600       HNN(2,1,I,J) = G*(QIJPP(J,I)*SINA+SIJPP(J,I)*COSA)
39601       HNN(1,2,I,J) = G*(SIJPP(I,J)*SINA-QIJPP(I,J)*COSA)
39602       HNN(2,2,I,J) = G*(SIJPP(J,I)*SINA-QIJPP(J,I)*COSA)
39603       HNN(1,3,I,J) = G*(QIJPP(I,J)*SINB-SIJPP(I,J)*COSB)
39604  14   HNN(2,3,I,J) =-G*(QIJPP(J,I)*SINB-SIJPP(J,I)*COSB)
39605 C--couplings of chargino-chargino to the Higgs
39606       DO 15 I=1,2
39607       DO 15 J=1,2
39608       QIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,1)*WMXUSS(J,2)
39609  15   SIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,2)*WMXUSS(J,1)
39610       DO 16 I=1,2
39611       DO 16 J=1,2
39612       HCC(1,1,I,J) = G*(QIJ(I,J)*SINA-SIJ(I,J)*COSA)
39613       HCC(2,1,I,J) = G*(QIJ(J,I)*SINA-SIJ(J,I)*COSA)
39614       HCC(1,2,I,J) =-G*(QIJ(I,J)*COSA+SIJ(I,J)*SINA)
39615       HCC(2,2,I,J) =-G*(QIJ(J,I)*COSA+SIJ(J,I)*SINA)
39616       HCC(1,3,I,J) = G*(QIJ(I,J)*SINB+SIJ(I,J)*COSB)
39617  16   HCC(2,3,I,J) =-G*(QIJ(J,I)*SINB+SIJ(J,I)*COSB)
39618 C--couplings of chargino-neutralino to the Higgs
39619       DO 17 I=1,4
39620       DO 17 J=1,2
39621       HNC(1,I,J) =-G*ZSGNSS(I)*SINB*(ZMXNSS(I,3)*WMXUSS(J,1)
39622      &            -ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXUSS(J,2))
39623  17   HNC(2,I,J) =-G*WSGNSS(J)*COSB*(ZMXNSS(I,4)*WMXVSS(J,1)
39624      &            +ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXVSS(J,2))
39625 C--fermion couplings to the Higgs
39626       R(1,1) = HALF*G*SINA/MW/COSB
39627       R(1,2) =-HALF*G*COSA/MW/SINB
39628       R(2,1) =-HALF*G*COSA/MW/COSB
39629       R(2,2) =-HALF*G*SINA/MW/SINB
39630       R(3,1) = HALF*G*TANB/MW
39631       R(3,2) = HALF*G*COTB/MW
39632       R(4,1) = G*ORT*TANB/MW
39633       R(4,2) = G*ORT*COTB/MW
39634       DO 18 I=1,3
39635       J = 2*I-1
39636       K = 2*I
39637       IL = J+6
39638       IQ = K+6
39639       DO 19 IK=1,3
39640       DO 19 L=1,2
39641       HFF(L,IK,J ) = R(IK,1)*RMASS(J)
39642       HFF(L,IK,K ) = R(IK,2)*RMASS(K)
39643       HFF(L,IK,IL) = R(IK,1)*RMASS(114+IL)
39644  19   HFF(L,IK,IQ) = ZERO
39645       HFF(2,3,J )  = -HFF(2,3, J)
39646       HFF(2,3,K )  = -HFF(2,3, K)
39647       HFF(2,3,IL)  = -HFF(2,3,IL)
39648       HFF(1,4,I)   = RMASS(J)*R(4,1)
39649       HFF(2,4,I)   = RMASS(K)*R(4,2)
39650       HFF(1,4,I+3) = RMASS(114+IL)*R(4,1)
39651  18   HFF(2,4,I+3) = ZERO
39652 C--couplings of the Higgs to gauge boson pairs
39653       HWW(1) = G*MW*SINBMA
39654       HWW(2) = G*MW*COSBMA
39655       HZZ(1) = G*MZ*SINBMA/CW
39656       HZZ(2) = G*MZ*COSBMA/CW
39657 C--couplings of the Z to the sfermions
39658       DO 20 I=1,3
39659       IQ = 2*I-1
39660       IL = 2*I
39661       IK = 2*I+5
39662       IH = 2*I+6
39663       DO 20 J=1,2
39664       DO 20 K=1,2
39665       ZAB(IQ,J,K) = G/CW*HALF*( QMIXSS(IQ,1,J)*QMIXSS(IQ,1,K)
39666      &                         -TWO*DIJ(J,K) *SWEIN/THREE)
39667       ZAB(IL,J,K) = G/CW*HALF*(-QMIXSS(IL,1,J)*QMIXSS(IL,1,K)
39668      &                         -FOUR*DIJ(J,K)*SWEIN/THREE)
39669       ZAB(IK,J,K) = G/CW*HALF*( LMIXSS(IQ,1,J)*LMIXSS(IQ,1,K)
39670      &                         -TWO*DIJ(J,K)*SWEIN)
39671  20   ZAB(IH,J,K) =-G/CW*HALF*DIJ(J,1)*DIJ(K,1)
39672 C--couplings of the Higgs Higgs to the gauge bosons
39673       HHB(1,1) = HALF*G*COSBMA
39674       HHB(1,2) = HALF*G*SINBMA
39675       HHB(1,3) = HALF*G
39676       HHB(2,1) =-HALF*G*COSBMA/CW
39677       HHB(2,2) = HALF*G*SINBMA/CW
39678       HHB(2,3) = ZERO
39679       END
39680 CDECK  ID>, HWISPN.
39681 *CMZ :-        -12/10/01  17.22.48  by  Peter Richardson
39682 *-- Author :    Peter Richardson
39683 C-----------------------------------------------------------------------
39684       SUBROUTINE HWISPN
39685 C-----------------------------------------------------------------------
39686 C     Initialise all the decay modes for three/four body MEs and spin
39687 C     correlations
39688 C-----------------------------------------------------------------------
39689       INCLUDE 'HERWIG65.INC'
39690       INTEGER I,J,K,NDKYST
39691 C--set the number of two and three body modes to zero
39692       N2MODE = 0
39693       N3MODE = 0
39694       NBMODE = 0
39695       N4MODE = 0
39696 C--if not reading in decay info calculate it
39697       IF(LRDEC.EQ.0) THEN
39698 C--initialise the couplings for the various decay modes
39699         CALL HWISPC
39700 C--Top decays and SUSY three body decays (including SUSY gauge
39701 C--boson 2 body modes which are treated as three body)
39702         IF(THREEB) CALL HWISP3
39703         IF(IERROR.NE.0) RETURN
39704 C--then four body modes if needed
39705         IF(FOURB)  CALL HWISP4
39706         IF(IERROR.NE.0) RETURN
39707 C--Two body modes if needed for spin correlations
39708         IF(SYSPIN) CALL HWISP2
39709         IF(IERROR.NE.0) RETURN
39710 C--otherwise read it in
39711       ELSEIF(LRDEC.GT.0) THEN
39712 C--open the unit
39713         IF (IPRINT.NE.0) WRITE (6,1) LRDEC
39714    1    FORMAT(/10X,'READING MATRIX ELEMENT TABLE ON UNIT',I4)
39715         OPEN(UNIT=LRDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
39716 C--read  options
39717         READ(UNIT=LRDEC) NDKYST
39718         IF(NDKYS.NE.NDKYST) CALL HWWARN('HWISPN',501,*999)
39719         READ(UNIT=LRDEC) SYSPIN,THREEB,FOURB
39720 C--read two body decays
39721         IF(SYSPIN) THEN
39722           READ(UNIT=LRDEC) N2MODE
39723           DO 2 I=1,N2MODE
39724  2        READ(UNIT=LRDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
39725      &                     ID2PRT(I),I2DRTP(I)
39726         ENDIF
39727 C--read three body decays
39728         IF(SYSPIN.OR.THREEB) THEN
39729           READ(UNIT=LRDEC) N3MODE
39730           DO 3 I=1,N3MODE
39731           READ(UNIT=LRDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
39732      &            ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
39733           DO 3 J=1,NDI3BY(I)
39734  3        READ(UNIT=LRDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
39735      &                      I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
39736 C--read two body gauge boson modes
39737           READ(UNIT=LRDEC) NBMODE
39738           DO 4 I=1,NBMODE
39739  4        READ(UNIT=LRDEC) (ABMODE(J,I),J=1,2),
39740      &            ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
39741      &            (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
39742         ENDIF
39743 C--read four body decays
39744         IF(FOURB) THEN
39745           READ(UNIT=LRDEC) N4MODE
39746           DO 5 I=1,N4MODE
39747  5        READ(UNIT=LRDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
39748      &            ((B4MODE(J,K,I),J=1,2),K=1,12),
39749      &            ((P4MODE(J,K,I),J=1,12),K=1,12),
39750      &            ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
39751      &            (I4MODE(J,I),J=1,2)
39752         ENDIF
39753 C--finally read in the matrix element codes
39754         READ(UNIT=LRDEC) NME
39755       ELSE
39756         CALL HWWARN('HWISPN',500,*999)
39757       ENDIF
39758 C--write the decay information if needed
39759       IF(LWDEC.GT.0) THEN
39760 C--open the file
39761         IF (IPRINT.NE.0) WRITE (6,6) LWDEC
39762  6      FORMAT(/10X,'WRITING MATRIX ELEMENT TABLE ON UNIT',I4)
39763         OPEN(UNIT=LWDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
39764 C--write  options
39765         WRITE(UNIT=LWDEC) NDKYS
39766         WRITE(UNIT=LWDEC) SYSPIN,THREEB,FOURB
39767 C--write two body decays
39768         IF(SYSPIN) THEN
39769           WRITE(UNIT=LWDEC) N2MODE
39770           DO 7 I=1,N2MODE
39771  7        WRITE(UNIT=LWDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
39772      &                     ID2PRT(I),I2DRTP(I)
39773         ENDIF
39774 C--write three body decays
39775         IF(SYSPIN.OR.THREEB) THEN
39776           WRITE(UNIT=LWDEC) N3MODE
39777           DO 8 I=1,N3MODE
39778           WRITE(UNIT=LWDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
39779      &            ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
39780           DO 8 J=1,NDI3BY(I)
39781  8        WRITE(UNIT=LWDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
39782      &                      I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
39783 C--write two body gauge boson modes
39784           WRITE(UNIT=LWDEC) NBMODE
39785           DO 9 I=1,NBMODE
39786  9        WRITE(UNIT=LWDEC) (ABMODE(J,I),J=1,2),
39787      &            ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
39788      &            (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
39789         ENDIF
39790 C--write four body decays
39791         IF(FOURB) THEN
39792           WRITE(UNIT=LWDEC) N4MODE
39793           DO 10 I=1,N4MODE
39794  10       WRITE(UNIT=LWDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
39795      &            ((B4MODE(J,K,I),J=1,2),K=1,12),
39796      &            ((P4MODE(J,K,I),J=1,12),K=1,12),
39797      &            ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
39798      &            (I4MODE(J,I),J=1,2)
39799         ENDIF
39800 C--finally write the matrix element codes
39801         WRITE(UNIT=LWDEC) NME
39802       ENDIF
39803       RETURN
39804  999  END
39805 CDECK  ID>, HWISP2.
39806 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
39807 *-- Author :    Peter Richardson
39808 C-----------------------------------------------------------------------
39809       SUBROUTINE HWISP2
39810 C-----------------------------------------------------------------------
39811 C     Initialise the SUSY two body modes for spin correlations
39812 C-----------------------------------------------------------------------
39813       INCLUDE 'HERWIG65.INC'
39814       INTEGER I,J,IL,IH,L,L1,IM,O(2),II,JJ,III,JJJ,KKK
39815       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
39816      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
39817       DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
39818      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
39819      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
39820      &     HZZ(2),ZAB(12,2,2),HHB(2,3),FPI
39821       DATA O/2,1/
39822       DATA FPI/0.09298D0/
39823       IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
39824 C--now the two body modes for spin corrections
39825       DO 1000 JJ=1,NRES
39826       DO 1000 II=1,NMODES(JJ)
39827         IF(II.EQ.1) THEN
39828           I = LSTRT(JJ)
39829         ELSE
39830           I = LNEXT(I)
39831         ENDIF
39832         IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0.OR.
39833      &        (NME(I).GT.10000.AND.NME(I).LT.50000)) GOTO 1000
39834         L1 = IDK(I)-449
39835 C--two body top to charged higgs decay
39836         IF(IDK(I).EQ.6.AND.IDKPRD(1,I).EQ.206.AND.
39837      &                     IDKPRD(2,I).EQ.5) THEN
39838             N2MODE = N2MODE+1
39839             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',100,*999)
39840             NME(I) = 30000+N2MODE
39841             ID2PRT(N2MODE) = I
39842             I2DRTP(N2MODE) = 2
39843             P2MODE(N2MODE) = ONE
39844             DO 201 J=1,2
39845  201        A2MODE(J,N2MODE) = HFF(O(J),4,3)
39846 C--two body antitop to charged higgs
39847         ELSEIF(IDK(I).EQ.12.AND.IDKPRD(1,I).EQ.207.AND.
39848      &                          IDKPRD(2,I).EQ.11) THEN
39849             N2MODE = N2MODE+1
39850             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',101,*999)
39851             NME(I) = 30000+N2MODE
39852             ID2PRT(N2MODE) = I
39853             I2DRTP(N2MODE) = 14
39854             P2MODE(N2MODE) = ONE
39855             DO 202 J=1,2
39856  202        A2MODE(J,N2MODE) = HFF(  J ,4,3)
39857 C--two body modes of the gluino
39858         ELSEIF(L1.EQ.0) THEN
39859           L = IDKPRD(1,I)-449
39860 C--gluino to antisfermion fermion
39861           IF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
39862             N2MODE = N2MODE+1
39863             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',102,*999)
39864             NME(I) = 30000+N2MODE
39865             ID2PRT(N2MODE) = I
39866             I2DRTP(N2MODE) = 2
39867             P2MODE(N2MODE) = HALF
39868             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
39869             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
39870             DO 1 J=1,2
39871  1          A2MODE(J,N2MODE) = AFG(J,IL,IM)
39872 C--gluino to sfermion antifermion
39873           ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
39874             N2MODE = N2MODE+1
39875             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',103,*999)
39876             NME(I) = 30000+N2MODE
39877             ID2PRT(N2MODE) = I
39878             I2DRTP(N2MODE) = 3
39879             P2MODE(N2MODE) = HALF
39880             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
39881             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
39882             DO 2 J=1,2
39883  2          A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
39884 C--gluino to neutralino gluon
39885           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.13) THEN
39886             N2MODE = N2MODE+1
39887             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',104,*999)
39888             NME(I) = 30000+N2MODE
39889             ID2PRT(N2MODE) = I
39890             I2DRTP(N2MODE) = 4
39891             P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
39892      &           (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
39893      &           HBAR/RLTIM(IDK(I))*BRFRAC(I)
39894             A2MODE(1,N2MODE) = ZSGNSS(L)
39895 C--gluino to gravitino gluon
39896           ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.13) THEN
39897             N2MODE = N2MODE+1
39898             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',105,*999)
39899             NME(I) = 30000+N2MODE
39900             ID2PRT(N2MODE) = I
39901             I2DRTP(N2MODE) = 9
39902             P2MODE(N2MODE) = ONE/24.0D0
39903           ENDIF
39904 C--two body modes of the neutralinos
39905         ELSEIF(L1.GE.1.AND.L1.LE.4) THEN
39906           L  = IDKPRD(1,I)-449
39907           IH = IDKPRD(2,I)-202
39908 C--first the neutralino modes to neutralino Higgs
39909           IF(L.GE.1.AND.L.LE.4.AND.IH.GE.1.AND.IH.LE.3) THEN
39910             N2MODE = N2MODE+1
39911             IF(N2MODE.GE.NMODE2) CALL HWWARN('HWISP2',106,*999)
39912             NME(I) = 30000+N2MODE
39913             ID2PRT(N2MODE) = I
39914             I2DRTP(N2MODE) = 1
39915             P2MODE(N2MODE) = ONE
39916             DO 3 J=1,2
39917  3          A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
39918 C--neutralino to positive chargino negative Higgs
39919           ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IH.EQ.5) THEN
39920             L = L-4
39921             N2MODE = N2MODE+1
39922             IF(N2MODE.GE.NMODE2) CALL HWWARN('HWISP2',107,*999)
39923             NME(I) = 30000+N2MODE
39924             ID2PRT(N2MODE) = I
39925             I2DRTP(N2MODE) = 1
39926             P2MODE(N2MODE) = ONE
39927             DO 4 J=1,2
39928  4          A2MODE(J,N2MODE) = HNC(O(J),L1,L)
39929 C--neutralino to negative chargino positive Higgs
39930           ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IH.EQ.6) THEN
39931             L = L-6
39932             N2MODE = N2MODE+1
39933             IF(N2MODE.GE.NMODE2) CALL HWWARN('HWISP2',108,*999)
39934             NME(I) = 30000+N2MODE
39935             ID2PRT(N2MODE) = I
39936             I2DRTP(N2MODE) = 1
39937             P2MODE(N2MODE) = ONE
39938             DO 5 J=1,2
39939  5          A2MODE(J,N2MODE) = HNC(J,L1,L)
39940 C--neutralino to antisfermion sfermion
39941           ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
39942             N2MODE = N2MODE+1
39943             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',109,*999)
39944             NME(I) = 30000+N2MODE
39945             ID2PRT(N2MODE) = I
39946             I2DRTP(N2MODE) = 2
39947             P2MODE(N2MODE) = ONE
39948             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
39949             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
39950             IF(IL.LE.6) P2MODE(N2MODE) = THREE
39951             DO 6 J=1,2
39952  6          A2MODE(J,N2MODE) = AFN(J,IL,IM,L1)
39953 C--neutralino to sfermion antifermion
39954           ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
39955             N2MODE = N2MODE+1
39956             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',110,*999)
39957             NME(I) = 30000+N2MODE
39958             ID2PRT(N2MODE) = I
39959             I2DRTP(N2MODE) = 3
39960             P2MODE(N2MODE) = ONE
39961             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
39962             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
39963             IF(IL.LE.6) P2MODE(N2MODE) = THREE
39964             DO 7 J=1,2
39965  7          A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L1)
39966 C--neutralino to neutralino photon
39967           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.59) THEN
39968             N2MODE = N2MODE+1
39969             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',111,*999)
39970             NME(I) = 30000+N2MODE
39971             ID2PRT(N2MODE) = I
39972             I2DRTP(N2MODE) = 4
39973             P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
39974      &           (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
39975      &           HBAR/RLTIM(IDK(I))*BRFRAC(I)
39976             A2MODE(1,N2MODE) = ZSGNSS(L)*ZSGNSS(L1)
39977 C--neutralino to gravitino photon for GMSB
39978           ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.59) THEN
39979             N2MODE = N2MODE+1
39980             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',112,*999)
39981             NME(I) = 30000+N2MODE
39982             ID2PRT(N2MODE) = I
39983             I2DRTP(N2MODE) = 9
39984             P2MODE(N2MODE) = ZMIXSS(L1,1)**2/24.0D0
39985 C--neutralino to gravitino Higgs for GMSB
39986           ELSEIF(IDKPRD(1,I).EQ.458.AND.IH.GE.1.AND.IH.LE.3) THEN
39987             N2MODE = N2MODE+1
39988             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',113,*999)
39989             NME(I) = 30000+N2MODE
39990             ID2PRT(N2MODE) = I
39991             I2DRTP(N2MODE) = 10
39992             IF(IH.EQ.1) THEN
39993               P2MODE(N2MODE) = ZMIXSS(L1,3)*SINA-ZMIXSS(L1,4)*COSA
39994             ELSEIF(IH.EQ.2) THEN
39995               P2MODE(N2MODE) = ZMIXSS(L1,3)*COSA+ZMIXSS(L1,4)*SINA
39996             ELSE
39997               P2MODE(N2MODE) = ZMIXSS(L1,3)*SINB+ZMIXSS(L1,4)*COSB
39998             ENDIF
39999             P2MODE(N2MODE) = P2MODE(N2MODE)**2/3.0D0
40000           ELSE
40001             CALL HWWARN('HWISP2',1,*999)
40002           ENDIF
40003 C--two body modes of the positive charginos
40004         ELSEIF(L1.EQ.5.OR.L1.EQ.6) THEN
40005           L1 = L1-4
40006           L  = IDKPRD(1,I)-449
40007           IH = IDKPRD(2,I)-202
40008 C--first the chargino modes to chargino Higgs
40009           IF((L.EQ.5.OR.L.EQ.6).AND.IH.GE.1.AND.IH.LE.3) THEN
40010             L = L-4
40011             N2MODE = N2MODE+1
40012             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',114,*999)
40013             NME(I) = 30000+N2MODE
40014             ID2PRT(N2MODE) = I
40015             I2DRTP(N2MODE) = 1
40016             P2MODE(N2MODE) = ONE
40017             DO 8 J=1,2
40018  8          A2MODE(J,N2MODE) = HCC(J,IH,L,L1)
40019 C--then the chargino modes to neutralino Higgs
40020           ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.4) THEN
40021             N2MODE = N2MODE+1
40022             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',115,*999)
40023             NME(I) = 30000+N2MODE
40024             ID2PRT(N2MODE) = I
40025             I2DRTP(N2MODE) = 1
40026             P2MODE(N2MODE) = ONE
40027             DO 9 J=1,2
40028  9          A2MODE(J,N2MODE) = HNC(J,L,L1)
40029 C--chargino modes to antisfermion fermion
40030           ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
40031             N2MODE = N2MODE+1
40032             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',116,*999)
40033             NME(I) = 30000+N2MODE
40034             ID2PRT(N2MODE) = I
40035             I2DRTP(N2MODE) = 2
40036             P2MODE(N2MODE) = ONE
40037             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
40038             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
40039             IF(IL.LE.6) P2MODE(N2MODE) = THREE
40040             DO 10 J=1,2
40041  10         A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
40042 C--chargino modes to sfermion antifermion
40043           ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
40044             N2MODE = N2MODE+1
40045             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',117,*999)
40046             NME(I) = 30000+N2MODE
40047             ID2PRT(N2MODE) = I
40048             I2DRTP(N2MODE) = 3
40049             P2MODE(N2MODE) = ONE
40050             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
40051             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
40052             IF(IL.LE.6) P2MODE(N2MODE) = THREE
40053             DO 11 J=1,2
40054  11         A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
40055 C--chargino --> neutralino pi+
40056           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.38) THEN
40057             N2MODE = N2MODE+1
40058             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',118,*999)
40059             NME(I) = 30000+N2MODE
40060             ID2PRT(N2MODE) = I
40061             I2DRTP(N2MODE) = 7
40062             P2MODE(N2MODE) = FPI**2*G**2
40063             DO 12 J=1,2
40064  12         A2MODE(J,N2MODE) = OIJ(J,L,L1)
40065           ENDIF
40066 C--two body modes of the negative charginos
40067         ELSEIF(L1.EQ.7.OR.L1.EQ.8) THEN
40068           L1 = L1-6
40069           L  = IDKPRD(1,I)-449
40070           IH = IDKPRD(2,I)-202
40071 C--first the chargino modes to chargino Higgs
40072           IF((L.EQ.7.OR.L.EQ.8).AND.IH.GE.1.AND.IH.LE.3) THEN
40073             L = L-6
40074             N2MODE = N2MODE+1
40075             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',119,*999)
40076             NME(I) = 30000+N2MODE
40077             ID2PRT(N2MODE) = I
40078             I2DRTP(N2MODE) = 1
40079             P2MODE(N2MODE) = ONE
40080             DO 13 J=1,2
40081  13         A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
40082 C--then the chargino modes to neutralino Higgs
40083           ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.5) THEN
40084             N2MODE = N2MODE+1
40085             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',120,*999)
40086             NME(I) = 30000+N2MODE
40087             ID2PRT(N2MODE) = I
40088             I2DRTP(N2MODE) = 1
40089             P2MODE(N2MODE) = ONE
40090             DO 14 J=1,2
40091  14         A2MODE(J,N2MODE) = HNC(O(J),L,L1)
40092 C--chargino to antisfermion fermion
40093           ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
40094             N2MODE = N2MODE+1
40095             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',121,*999)
40096             NME(I) = 30000+N2MODE
40097             ID2PRT(N2MODE) = I
40098             I2DRTP(N2MODE) = 2
40099             P2MODE(N2MODE) = ONE
40100             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
40101             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
40102             IF(IL.LE.6) P2MODE(N2MODE) = THREE
40103             DO 15 J=1,2
40104  15         A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
40105 C--chargino to sfermion antifermion
40106           ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
40107             N2MODE = N2MODE+1
40108             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',122,*999)
40109             NME(I) = 30000+N2MODE
40110             ID2PRT(N2MODE) = I
40111             I2DRTP(N2MODE) = 3
40112             P2MODE(N2MODE) = ONE
40113             IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
40114             IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
40115             IF(IL.LE.6) P2MODE(N2MODE) = THREE
40116             DO 16 J=1,2
40117  16         A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
40118 C--chargino --> neutralino pi-
40119           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.30) THEN
40120             N2MODE = N2MODE+1
40121             IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',123,*999)
40122             NME(I) = 30000+N2MODE
40123             ID2PRT(N2MODE) = I
40124             I2DRTP(N2MODE) = 7
40125             P2MODE(N2MODE) = FPI**2*G**2
40126             DO 17 J=1,2
40127  17         A2MODE(J,N2MODE) =-OIJ(O(J),L,L1)
40128           ENDIF
40129         ELSEIF(L1.GE.-48.AND.L1.LT.0) THEN
40130 C--sfermion decay modes
40131           L = IDKPRD(1,I)-449
40132 C--first sfermion modes to gluinos
40133           IF(L.EQ.0) THEN
40134 C--first sfermion --> fermion gluino
40135             IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
40136               N2MODE = N2MODE+1
40137               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',124,*999)
40138               NME(I) = 30000+N2MODE
40139               ID2PRT(N2MODE) = I
40140               I2DRTP(N2MODE) = 6
40141               P2MODE(N2MODE) = FOUR/THREE
40142               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40143               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40144               DO 18 J=1,2
40145  18           A2MODE(J,N2MODE) = AFG(J,IL,IM)
40146 C--then antisfermion --> antifermion gluino
40147             ELSE
40148               N2MODE = N2MODE+1
40149               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',125,*999)
40150               NME(I) = 30000+N2MODE
40151               ID2PRT(N2MODE) = I
40152               I2DRTP(N2MODE) = 5
40153               P2MODE(N2MODE) = FOUR/THREE
40154               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40155               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40156               DO 19 J=1,2
40157  19           A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
40158             ENDIF
40159 C--then sfermion modes to neutralinos
40160           ELSEIF(L.GE.1.AND.L.LE.4) THEN
40161 C--first sfermion --> fermion neutralino
40162             IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
40163               N2MODE = N2MODE+1
40164               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',126,*999)
40165               NME(I) = 30000+N2MODE
40166               ID2PRT(N2MODE) = I
40167               I2DRTP(N2MODE) = 6
40168               P2MODE(N2MODE) = ONE
40169               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40170               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40171               DO 20 J=1,2
40172  20           A2MODE(J,N2MODE) = AFN(J,IL,IM,L)
40173 C--then antisfermion --> fermion neutralino
40174             ELSE
40175               N2MODE = N2MODE+1
40176               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',127,*999)
40177               NME(I) = 30000+N2MODE
40178               ID2PRT(N2MODE) = I
40179               I2DRTP(N2MODE) = 5
40180               P2MODE(N2MODE) = ONE
40181               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40182               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40183               DO 21 J=1,2
40184  21           A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L)
40185             ENDIF
40186 C--sfermion modes to charginos
40187           ELSEIF(L.GE.5.AND.L.LE.8) THEN
40188             L = MOD(L-5,2)+1
40189 C--first sfermion --> fermion chargino
40190             IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
40191               N2MODE = N2MODE+1
40192               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',128,*999)
40193               NME(I) = 30000+N2MODE
40194               ID2PRT(N2MODE) = I
40195               I2DRTP(N2MODE) = 6
40196               P2MODE(N2MODE) = ONE
40197               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40198               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40199               DO 22 J=1,2
40200  22           A2MODE(J,N2MODE) = AFC(J,IL,IM,L)
40201 C--then antisfermion --> fermion chargino
40202             ELSE
40203               N2MODE = N2MODE+1
40204               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',129,*999)
40205               NME(I) = 30000+N2MODE
40206               ID2PRT(N2MODE) = I
40207               I2DRTP(N2MODE) = 5
40208               P2MODE(N2MODE) = ONE
40209               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40210               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40211               DO 23 J=1,2
40212  23           A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L)
40213             ENDIF
40214 C--sfermion modes to  fermion gravitino
40215           ELSEIF(IDKPRD(2,I).EQ.458) THEN
40216             IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
40217               N2MODE = N2MODE+1
40218               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',130,*999)
40219               NME(I) = 30000+N2MODE
40220               ID2PRT(N2MODE) = I
40221               I2DRTP(N2MODE) = 11
40222               P2MODE(N2MODE) = ONE/THREE
40223               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40224               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40225               IF(IL.LE.6) THEN
40226                 DO 40 J=1,2
40227  40             A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
40228               ELSE
40229                 DO 41 J=1,2
40230  41             A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
40231               ENDIF
40232             ELSE
40233               N2MODE = N2MODE+1
40234               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',131,*999)
40235               NME(I) = 30000+N2MODE
40236               ID2PRT(N2MODE) = I
40237               I2DRTP(N2MODE) = 12
40238               P2MODE(N2MODE) = ONE/THREE
40239               IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
40240               IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
40241               IF(IL.LE.6) THEN
40242                 DO 42 J=1,2
40243  42             A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
40244               ELSE
40245                 DO 43 J=1,2
40246  43             A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
40247               ENDIF
40248             ENDIF
40249 C--R-parity violating decay modes
40250 C--LLE modes
40251           ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
40252      &           IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
40253      &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132) THEN
40254 C--charged slepton decays
40255             IF(MOD(IDK(I),2).EQ.1) THEN
40256 C--right slepton decay
40257               IF(IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I))).EQ.
40258      &           IDPDG(IDKPRD(2,I))/ABS(IDPDG(IDKPRD(2,I)))) THEN
40259 C--particle decay
40260                 N2MODE = N2MODE+1
40261                 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',132,*999)
40262                 NME(I) = 30000+N2MODE
40263                 ID2PRT(N2MODE) = I
40264                 P2MODE(N2MODE) = ONE
40265                 IF(IDPDG(IDK(I)).GT.0) THEN
40266                   KKK = (IDK(I)-423)/2
40267                   IF(KKK.GT.3) THEN
40268                      KKK = KKK-6
40269                      IM = 2
40270                   ELSE
40271                      IM = 1
40272                   ENDIF
40273                   IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
40274                     III = (IDKPRD(1,I)-120)/2
40275                     JJJ = (IDKPRD(2,I)-119)/2
40276                   ELSE
40277                     III = (IDKPRD(2,I)-120)/2
40278                     JJJ = (IDKPRD(1,I)-119)/2
40279                   ENDIF
40280                   I2DRTP(N2MODE) = 6
40281                   A2MODE(1,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
40282      &                 LAMDA1(III,JJJ,KKK)
40283                   A2MODE(2,N2MODE) = 0.0D0
40284                 ELSE
40285 C--antiparticle decay
40286                   KKK = (IDK(I)-429)/2
40287                   IF(KKK.GT.3) THEN
40288                      KKK = KKK-6
40289                      IM = 2
40290                   ELSE
40291                      IM = 1
40292                   ENDIF
40293                   IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
40294                     III = (IDKPRD(1,I)-126)/2
40295                     JJJ = (IDKPRD(2,I)-125)/2
40296                   ELSE
40297                     III = (IDKPRD(2,I)-126)/2
40298                     JJJ = (IDKPRD(1,I)-125)/2
40299                   ENDIF
40300                   I2DRTP(N2MODE) = 13
40301                   A2MODE(1,N2MODE) = 0.0D0
40302                   A2MODE(2,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
40303      &                 LAMDA1(III,JJJ,KKK)
40304                 ENDIF
40305 C--left slepton decay
40306               ELSE
40307                 N2MODE = N2MODE+1
40308                 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',133,*999)
40309                 NME(I) = 30000+N2MODE
40310                 ID2PRT(N2MODE) = I
40311                 P2MODE(N2MODE) = ONE
40312                 IF(IDPDG(IDK(I)).GT.0) THEN
40313                   JJJ = (IDK(I)-423)/2
40314                   IF(JJJ.GT.3) THEN
40315                     JJJ = JJJ-6
40316                     IM = 2
40317                   ELSE
40318                     IM = 1
40319                   ENDIF
40320                   IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
40321                     III = (IDKPRD(1,I)-126)/2
40322                     KKK = (IDKPRD(2,I)-119)/2
40323                     I2DRTP(N2MODE) = 8
40324                   ELSE
40325                     III = (IDKPRD(2,I)-126)/2
40326                     KKK = (IDKPRD(1,I)-119)/2
40327                     I2DRTP(N2MODE) = 5
40328                   ENDIF
40329                   A2MODE(1,N2MODE) = 0.0D0
40330                   A2MODE(2,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
40331      &                 LAMDA1(III,JJJ,KKK)
40332                 ELSE
40333                   JJJ = (IDK(I)-429)/2
40334                   IF(JJJ.GT.3) THEN
40335                     JJJ = JJJ-6
40336                     IM = 2
40337                   ELSE
40338                     IM = 1
40339                   ENDIF
40340                   IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
40341                     III = (IDKPRD(1,I)-120)/2
40342                     KKK = (IDKPRD(2,I)-125)/2
40343                     I2DRTP(N2MODE) = 5
40344                   ELSE
40345                     III = (IDKPRD(2,I)-120)/2
40346                     KKK = (IDKPRD(1,I)-125)/2
40347                     I2DRTP(N2MODE) = 8
40348                   ENDIF
40349                   A2MODE(1,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
40350      &                 LAMDA1(III,JJJ,KKK)
40351                   A2MODE(2,N2MODE) = 0.0D0
40352                 ENDIF
40353               ENDIF
40354 C--sneutrino decays
40355             ELSEIF(MOD(IDK(I),2).EQ.0.AND.IDK(I).LE.436) THEN
40356 C--sneutrino decay
40357               N2MODE = N2MODE+1
40358               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',134,*999)
40359               NME(I) = 30000+N2MODE
40360               ID2PRT(N2MODE) = I
40361               P2MODE(N2MODE) = ONE
40362               IF(IDPDG(IDK(I)).GT.0) THEN
40363                 III = (IDK(I)-424)/2
40364                 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
40365                   KKK = (IDKPRD(1,I)-119)/2
40366                   JJJ = (IDKPRD(2,I)-125)/2
40367                   I2DRTP(N2MODE) = 5
40368                 ELSE
40369                   JJJ = (IDKPRD(1,I)-125)/2
40370                   KKK = (IDKPRD(2,I)-119)/2
40371                   I2DRTP(N2MODE) = 8
40372                 ENDIF
40373                 A2MODE(1,N2MODE) = 0.0D0
40374                 A2MODE(2,N2MODE) = LAMDA1(III,JJJ,KKK)
40375 C--antisneutrino decay
40376               ELSE
40377                 III = (IDK(I)-430)/2
40378                 IF(IDPDG(IDKPRD(1,I)).LT.0) THEN
40379                   KKK = (IDKPRD(1,I)-125)/2
40380                   JJJ = (IDKPRD(2,I)-119)/2
40381                   I2DRTP(N2MODE) = 8
40382                 ELSE
40383                   JJJ = (IDKPRD(1,I)-119)/2
40384                   KKK = (IDKPRD(2,I)-125)/2
40385                   I2DRTP(N2MODE) = 5
40386                 ENDIF
40387                 A2MODE(1,N2MODE) = LAMDA1(III,JJJ,KKK)
40388                 A2MODE(2,N2MODE) = 0.0D0
40389               ENDIF
40390             ENDIF
40391 C--LQD modes
40392 C--squark decays
40393           ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
40394      &           IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
40395      &           IDKPRD(2,I).LE.12) THEN
40396 C--up type squark decay
40397             IF(MOD(IDK(I),2).EQ.0) THEN
40398               N2MODE = N2MODE+1
40399               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',135,*999)
40400               NME(I) = 30000+N2MODE
40401               ID2PRT(N2MODE) = I
40402               P2MODE(N2MODE) = ONE
40403               IF(IDPDG(IDK(I)).GT.0) THEN
40404                 JJJ = (IDK(I)-400)/2
40405                 IF(JJJ.GT.3) THEN
40406                   JJJ = JJJ-6
40407                   IM  = 2
40408                 ELSE
40409                   IM = 1
40410                 ENDIF
40411                 III = (IDKPRD(1,I)-125)/2
40412                 KKK = (IDKPRD(2,I)+1)/2
40413                 I2DRTP(N2MODE) = 8
40414                 A2MODE(1,N2MODE) = ZERO
40415                 A2MODE(2,N2MODE) = QMIXSS(2*JJJ,1,IM)*
40416      &                             LAMDA2(III,JJJ,KKK)
40417               ELSE
40418                 JJJ = (IDK(I)-406)/2
40419                 IF(JJJ.GT.3) THEN
40420                   JJJ = JJJ-6
40421                   IM  = 2
40422                 ELSE
40423                   IM = 1
40424                 ENDIF
40425                 III = (IDKPRD(1,I)-119)/2
40426                 KKK = (IDKPRD(2,I)-5)/2
40427                 I2DRTP(N2MODE) = 5
40428                 A2MODE(1,N2MODE) = QMIXSS(2*JJJ,1,IM)*
40429      &                             LAMDA2(III,JJJ,KKK)
40430                 A2MODE(2,N2MODE) = ZERO
40431               ENDIF
40432 C--down type squark to lepton up
40433             ELSEIF(MOD(IDK(I),2).EQ.1.AND.MOD(IDKPRD(1,I),2).EQ.1) THEN
40434               N2MODE = N2MODE+1
40435               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',136,*999)
40436               NME(I) = 30000+N2MODE
40437               ID2PRT(N2MODE) = I
40438               P2MODE(N2MODE) = ONE
40439 C--particle
40440               IF(IDPDG(IDK(I)).GT.0) THEN
40441                 KKK = (IDK(I)-399)/2
40442                 IF(KKK.GT.3) THEN
40443                   KKK = KKK-6
40444                   IM  = 2
40445                 ELSE
40446                   IM  = 1
40447                 ENDIF
40448                 III = (IDKPRD(1,I)-119)/2
40449                 JJJ = IDKPRD(2,I)/2
40450                 I2DRTP(N2MODE) = 6
40451                 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
40452      &                             LAMDA2(III,JJJ,KKK)
40453                 A2MODE(2,N2MODE) = ZERO
40454 C--antiparticle
40455               ELSE
40456                 KKK = (IDK(I)-405)/2
40457                 IF(KKK.GT.3) THEN
40458                   KKK = KKK-6
40459                   IM  = 2
40460                 ELSE
40461                   IM  = 1
40462                 ENDIF
40463                 III = (IDKPRD(1,I)-125)/2
40464                 JJJ = (IDKPRD(2,I)-6)/2
40465                 I2DRTP(N2MODE) = 13
40466                 A2MODE(1,N2MODE) = ZERO
40467                 A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
40468      &                             LAMDA2(III,JJJ,KKK)
40469               ENDIF
40470 C--down (left) squark --> nu d
40471             ELSEIF(MOD(IDK(I),2).EQ.1.AND.
40472      &           IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
40473      &          -IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
40474               N2MODE = N2MODE+1
40475               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',137,*999)
40476               NME(I) = 30000+N2MODE
40477               ID2PRT(N2MODE) = I
40478               P2MODE(N2MODE) = ONE
40479               IF(IDPDG(IDK(I)).GT.0) THEN
40480                 JJJ = (IDK(I)-399)/2
40481                 IF(JJJ.GT.3) THEN
40482                   JJJ = JJJ-6
40483                   IM  = 2
40484                 ELSE
40485                   IM  = 1
40486                 ENDIF
40487                 III = (IDKPRD(1,I)-126)/2
40488                 KKK = (IDKPRD(2,I)+1)/2
40489                 I2DRTP(N2MODE) = 8
40490                 A2MODE(1,N2MODE) = ZERO
40491                 A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
40492      &                             LAMDA2(III,JJJ,KKK)
40493               ELSE
40494                 JJJ = (IDK(I)-405)/2
40495                 IF(JJJ.GT.3) THEN
40496                   JJJ = JJJ-6
40497                   IM = 2
40498                 ELSE
40499                   IM = 1
40500                 ENDIF
40501                 III = (IDKPRD(1,I)-120)/2
40502                 KKK = (IDKPRD(2,I)-5)/2
40503                 I2DRTP(N2MODE) = 5
40504                 A2MODE(1,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
40505      &                             LAMDA2(III,JJJ,KKK)
40506                 A2MODE(2,N2MODE) = ZERO
40507               ENDIF
40508 C--down (right) squark --> nu d
40509             ELSEIF(MOD(IDK(I),2).EQ.1.AND.
40510      &           IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
40511      &           IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
40512               N2MODE = N2MODE+1
40513               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',138,*999)
40514               NME(I) = 30000+N2MODE
40515               ID2PRT(N2MODE) = I
40516               P2MODE(N2MODE) = ONE
40517               IF(IDPDG(IDK(I)).GT.0) THEN
40518                 KKK = (IDK(I)-399)/2
40519                 IF(KKK.GT.3) THEN
40520                   KKK = KKK-6
40521                   IM  = 2
40522                 ELSE
40523                   IM  = 1
40524                 ENDIF
40525                 III = (IDKPRD(1,I)-120)/2
40526                 JJJ = (IDKPRD(2,I)+1)/2
40527                 I2DRTP(N2MODE) = 6
40528                 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
40529      &                             LAMDA2(III,JJJ,KKK)
40530                 A2MODE(2,N2MODE) = ZERO
40531               ELSE
40532                 KKK = (IDK(I)-405)/2
40533                 IF(KKK.GT.3) THEN
40534                   KKK = KKK-6
40535                   IM  = 2
40536                 ELSE
40537                   IM  = 1
40538                 ENDIF
40539                 III = (IDKPRD(1,I)-126)/2
40540                 JJJ = (IDKPRD(2,I)-5)/2
40541                 I2DRTP(N2MODE) = 13
40542                 A2MODE(1,N2MODE) = ZERO
40543                 A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
40544      &                             LAMDA2(III,JJJ,KKK)
40545               ENDIF
40546             ELSE
40547               CALL HWWARN('HWISP2',2,*999)
40548             ENDIF
40549 C--slepton decays
40550           ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
40551      &           IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
40552 C--sneutrino decay
40553             IF(MOD(IDK(I),2).EQ.0) THEN
40554               N2MODE = N2MODE+1
40555               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',140,*999)
40556               NME(I) = 30000+N2MODE
40557               ID2PRT(N2MODE) = I
40558               P2MODE(N2MODE) = THREE
40559 C--particle
40560               IF(IDPDG(IDK(I)).GT.0) THEN
40561                 III = (IDK(I)-424)/2
40562                 JJJ = (IDKPRD(1,I)-5)/2
40563                 KKK = (IDKPRD(2,I)+1)/2
40564                 I2DRTP(N2MODE) = 8
40565                 A2MODE(1,N2MODE) = 0.0D0
40566                 A2MODE(2,N2MODE) = LAMDA2(III,JJJ,KKK)
40567 C--antiparticle
40568               ELSE
40569                 III = (IDK(I)-430)/2
40570                 JJJ = (IDKPRD(1,I)+1)/2
40571                 KKK = (IDKPRD(2,I)-5)/2
40572                 I2DRTP(N2MODE) = 5
40573                 A2MODE(1,N2MODE) = LAMDA2(III,JJJ,KKK)
40574                 A2MODE(2,N2MODE) = 0.0D0
40575               ENDIF
40576 C--slepton decay
40577             ELSEIF(MOD(IDK(I),2).EQ.1) THEN
40578               N2MODE = N2MODE+1
40579               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',141,*999)
40580               NME(I) = 30000+N2MODE
40581               ID2PRT(N2MODE) = I
40582               P2MODE(N2MODE) = THREE
40583 C--particle
40584               IF(IDPDG(IDK(I)).GT.0) THEN
40585                 III = (IDK(I)-423)/2
40586                 IF(III.GT.3) THEN
40587                    III = III -6
40588                    IM = 2
40589                 ELSE
40590                    IM = 1
40591                 ENDIF
40592                 JJJ = (IDKPRD(1,I)-6)/2
40593                 KKK = (IDKPRD(2,I)+1)/2
40594                 I2DRTP(N2MODE) = 8
40595                 A2MODE(1,N2MODE) = 0.0D0
40596                 A2MODE(2,N2MODE) = LMIXSS(2*III-1,1,IM)*
40597      &                             LAMDA2(III,JJJ,KKK)
40598 C--antiparticle
40599               ELSE
40600                 III = (IDK(I)-429)/2
40601                 IF(III.GT.3) THEN
40602                    III = III -6
40603                    IM = 2
40604                 ELSE
40605                    IM = 1
40606                 ENDIF
40607                 JJJ = IDKPRD(1,I)/2
40608                 KKK = (IDKPRD(2,I)-5)/2
40609                 I2DRTP(N2MODE) = 5
40610                 A2MODE(1,N2MODE) = LMIXSS(2*III-1,1,IM)*
40611      &                             LAMDA2(III,JJJ,KKK)
40612                 A2MODE(2,N2MODE) = 0.0D0
40613               ENDIF
40614             ELSE
40615               CALL HWWARN('HWISP2',3,*999)
40616             ENDIF
40617 C--UDD modes
40618           ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
40619      &           IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
40620 C--up type squark decay
40621             IF(MOD(IDK(I),2).EQ.0) THEN
40622               N2MODE = N2MODE+1
40623               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',143,*999)
40624               NME(I) = 30000+N2MODE
40625               ID2PRT(N2MODE) = I
40626               P2MODE(N2MODE) = 2.0D0
40627 C--squark decay
40628               IF(IDPDG(IDK(I)).GT.0) THEN
40629                 III = (IDK(I)-400)/2
40630                 IF(III.GT.3) THEN
40631                   III = III-6
40632                   IM = 2
40633                 ELSE
40634                   IM = 1
40635                 ENDIF
40636                 JJJ = (IDKPRD(1,I)-5)/2
40637                 KKK = (IDKPRD(2,I)-5)/2
40638                 I2DRTP(N2MODE) = 13
40639                 A2MODE(1,N2MODE)=QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
40640                 A2MODE(2,N2MODE)=0.0D0
40641 C--antisquark decay
40642               ELSE
40643                 III = (IDK(I)-406)/2
40644                 IF(III.GT.3) THEN
40645                   III = III-6
40646                   IM = 2
40647                 ELSE
40648                   IM = 1
40649                 ENDIF
40650                 JJJ = (IDKPRD(1,I)+1)/2
40651                 KKK = (IDKPRD(2,I)+1)/2
40652                 I2DRTP(N2MODE) = 6
40653                 A2MODE(1,N2MODE) =0.0D0
40654                 A2MODE(2,N2MODE) =QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
40655               ENDIF
40656             ELSE
40657 C--down type squark decay
40658               N2MODE = N2MODE+1
40659               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',144,*999)
40660               NME(I) = 30000+N2MODE
40661               ID2PRT(N2MODE) = I
40662               P2MODE(N2MODE) = 2.0D0
40663 C--squark decay
40664               IF(IDPDG(IDK(I)).GT.0) THEN
40665                 JJJ = (IDK(I)-399)/2
40666                 IF(JJJ.GT.3) THEN
40667                   JJJ = JJJ-6
40668                   IM = 2
40669                 ELSE
40670                   IM = 1
40671                 ENDIF
40672                 III = (IDKPRD(1,I)-6)/2
40673                 KKK = (IDKPRD(2,I)-5)/2
40674                 I2DRTP(N2MODE) = 13
40675                 A2MODE(1,N2MODE)= QMIXSS(2*JJJ-1,2,IM)*
40676      &                            LAMDA3(III,JJJ,KKK)
40677                 A2MODE(2,N2MODE)= 0.0D0
40678 C--antisquark decay
40679               ELSE
40680                 JJJ = (IDK(I)-405)/2
40681                 IF(JJJ.GT.3) THEN
40682                   JJJ = JJJ-6
40683                   IM = 2
40684                 ELSE
40685                   IM = 1
40686                 ENDIF
40687                 III = IDKPRD(1,I)/2
40688                 KKK = (IDKPRD(2,I)+1)/2
40689                 I2DRTP(N2MODE) = 6
40690                 A2MODE(1,N2MODE) = 0.0D0
40691                 A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,2,IM)*
40692      &                             LAMDA3(III,JJJ,KKK)
40693               ENDIF
40694             ENDIF
40695           ELSE
40696             IF(.NOT.(RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.
40697      &      RSPIN(IDKPRD(2,I)).EQ.ZERO)) CALL HWWARN('HWISP2',4,*999)
40698           ENDIF
40699         ELSEIF(IDK(I).GE.203.AND.IDK(I).LE.207) THEN
40700           IH = IDK(I)-202
40701           L  = IDKPRD(1,I)-449
40702           L1 = IDKPRD(2,I)-449
40703 C--Neutral Higgs decays
40704           IF(IH.GE.1.AND.IH.LE.3) THEN
40705 C--Higgs to neutralino neutralino
40706             IF(L.GE.1.AND.L.LE.4) THEN
40707               N2MODE = N2MODE+1
40708               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',146,*999)
40709               NME(I) = 30000+N2MODE
40710               ID2PRT(N2MODE) = I
40711               I2DRTP(N2MODE) = 6
40712               P2MODE(N2MODE) = ONE
40713               IF(L.EQ.L1) P2MODE(N2MODE) = HALF
40714               DO 24 J=1,2
40715  24           A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
40716 C--Higgs to chargino chargino
40717             ELSEIF(L.GE.5.AND.L.LE.8) THEN
40718               L  = MOD(L -5,2)+1
40719               L1 = MOD(L1-5,2)+1
40720               N2MODE = N2MODE+1
40721               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',147,*999)
40722               NME(I) = 30000+N2MODE
40723               ID2PRT(N2MODE) = I
40724               I2DRTP(N2MODE) = 6
40725               P2MODE(N2MODE) = ONE
40726               DO 25 J=1,2
40727               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
40728                 A2MODE(J,N2MODE) = HCC(  J ,IH,L,L1)
40729               ELSE
40730                 A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
40731               ENDIF
40732  25           CONTINUE
40733 C--Higgs to fermion antifermion
40734             ELSEIF((L.GE.-448.AND.L.LE.-437)
40735      &         .OR.(L.GE.-328.AND.L.LE.-317)) THEN
40736               N2MODE = N2MODE+1
40737               IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',148,*999)
40738               NME(I) = 30000+N2MODE
40739               ID2PRT(N2MODE) = I
40740               I2DRTP(N2MODE) = 5
40741               P2MODE(N2MODE) = ONE
40742               IL = IDKPRD(1,I)
40743               IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40744               IF(IL.LE.6) P2MODE(N2MODE) = THREE
40745               DO 26 J=1,2
40746  26           A2MODE(J,N2MODE) = HFF(J,IH,IL)
40747             ELSE
40748               IF(.NOT.
40749      &       (RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.RSPIN(IDKPRD(2,I)).EQ.ZERO)
40750      &        .AND..NOT.(IDKPRD(1,I).EQ.13.AND.IDKPRD(2,I).EQ.13)
40751      &        .AND..NOT.(IDKPRD(1,I).EQ.59.AND.IDKPRD(2,I).EQ.59)
40752      &        .AND..NOT.(IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
40753      &                   IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200))
40754      &        CALL HWWARN('HWISP2',5,*999)
40755             ENDIF
40756 C--charged Higgs decays
40757           ELSE
40758             IH = IDK(I)-205
40759             L  = IDKPRD(1,I)-449
40760             L1 = IDKPRD(2,I)-449
40761 C--positive Higgs decays
40762             IF(IH.EQ.1) THEN
40763 C--decay to chargino neutralino
40764               IF(L.EQ.5.OR.L.EQ.6) THEN
40765                 L = L-4
40766                 N2MODE = N2MODE+1
40767                 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',149,*999)
40768                 NME(I) = 30000+N2MODE
40769                 ID2PRT(N2MODE) = I
40770                 I2DRTP(N2MODE) = 6
40771                 P2MODE(N2MODE) = ONE
40772                 DO 27 J=1,2
40773  27             A2MODE(J,N2MODE) = HNC(O(J),L1,L)
40774 C--decay to neutralino chargino
40775               ELSEIF(L.GE.1.AND.L.LE.4) THEN
40776                 L1 = L1-4
40777                 N2MODE = N2MODE+1
40778                 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',150,*999)
40779                 NME(I) = 30000+N2MODE
40780                 ID2PRT(N2MODE) = I
40781                 I2DRTP(N2MODE) = 6
40782                 P2MODE(N2MODE) = ONE
40783                 DO 28 J=1,2
40784  28             A2MODE(J,N2MODE) = HNC(O(J),L1,L)
40785 C--fermion antifermion decay modes
40786               ELSEIF((L.GE.-448.AND.L.LE.-437)
40787      &               .OR.(L.GE.-328.AND.L.LE.-317)) THEN
40788                 N2MODE = N2MODE+1
40789                 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',151,*999)
40790                 NME(I) = 30000+N2MODE
40791                 ID2PRT(N2MODE) = I
40792                 I2DRTP(N2MODE) = 5
40793                 P2MODE(N2MODE) = ONE
40794                 IL = IDKPRD(1,I)
40795                 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40796                 IL = INT((IL+1)/2)
40797                 IF(IL.LE.3) P2MODE(N2MODE) = THREE
40798                 DO 29 J=1,2
40799  29             A2MODE(J,N2MODE) = HFF(J,4,IL)
40800               ELSE
40801                 IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(2,I)).NE.
40802      &           ZERO) CALL HWWARN('HWISP2',6,*999)
40803               ENDIF
40804 C--negative Higgs decays
40805             ELSE
40806 C--Higgs to chargino neutralino
40807               IF(L.EQ.7.OR.L.EQ.8) THEN
40808                 L = L-6
40809                 N2MODE = N2MODE+1
40810                 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',152,*999)
40811                 NME(I) = 30000+N2MODE
40812                 ID2PRT(N2MODE) = I
40813                 I2DRTP(N2MODE) = 6
40814                 P2MODE(N2MODE) = ONE
40815                 DO 30 J=1,2
40816  30             A2MODE(J,N2MODE) = HNC(J,L1,L)
40817 C--Higgs to neutralino chargino
40818               ELSEIF(L.GE.1.AND.L.LE.4) THEN
40819                 L1 = L1-6
40820                 N2MODE = N2MODE+1
40821                 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',153,*999)
40822                 NME(I) = 30000+N2MODE
40823                 ID2PRT(N2MODE) = I
40824                 I2DRTP(N2MODE) = 6
40825                 P2MODE(N2MODE) = ONE
40826                 DO 31 J=1,2
40827  31             A2MODE(J,N2MODE) = HNC(J,L1,L)
40828 C--fermion antifermion decay modes
40829               ELSEIF((L.GE.-448.AND.L.LE.-437)
40830      &               .OR.(L.GE.-328.AND.L.LE.-317)) THEN
40831                 N2MODE = N2MODE+1
40832                 IF(N2MODE.GT.NMODE2) CALL HWWARN('HWISP2',154,*999)
40833                 NME(I) = 30000+N2MODE
40834                 ID2PRT(N2MODE) = I
40835                 I2DRTP(N2MODE) = 8
40836                 P2MODE(N2MODE) = ONE
40837                 IL = IDKPRD(1,I)
40838                 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40839                 IL = INT((IL+1)/2)
40840                 IF(IL.LE.3) P2MODE(N2MODE) = THREE
40841                 DO 32 J=1,2
40842  32             A2MODE(J,N2MODE) = HFF(O(J),4,IL)
40843               ELSE
40844                 IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(1,I)).NE.
40845      &           ZERO) CALL HWWARN('HWISP2',7,*999)
40846               ENDIF
40847             ENDIF
40848           ENDIF
40849         ENDIF
40850  1000 CONTINUE
40851 C--now find the maximum weights and compute the decay rates
40852       DO 2000 I=1,N2MODE
40853       IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(ID2PRT(I))),
40854      &   RNAME(IDKPRD(1,ID2PRT(I))),RNAME(IDKPRD(2,ID2PRT(I)))
40855  2000 CALL HWD2ME(I)
40856       RETURN
40857  5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
40858      &     A8,' --> ',A8,' ',A8/)
40859  999  END
40860 CDECK  ID>, HWISP3.
40861 *CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
40862 *-- Author :    Peter Richardson
40863 C-----------------------------------------------------------------------
40864       SUBROUTINE HWISP3
40865 C-----------------------------------------------------------------------
40866 C     Initialise the top/SUSY three body decay modes
40867 C     gravitino and RPV modes added by Peter Richardson
40868 C-----------------------------------------------------------------------
40869       INCLUDE 'HERWIG65.INC'
40870       INTEGER I,J,K,L,L1,IL,IQ,IQ1,IQ2,IFR,SIFR,IH,IH1,IM,O(2),II,JJ,
40871      &     III,JJJ,KKK
40872       DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
40873      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
40874      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
40875      &     HZZ(2),ZAB(12,2,2),HHB(2,3)
40876       DOUBLE COMPLEX RHOIN(2,2)
40877       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
40878      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
40879       DATA O/2,1/
40880       IF(IERROR.NE.0) RETURN
40881 C--loop over the decays and find the top decays
40882       DO 1000 JJ=6,12,6
40883       DO 1000 II=1,NMODES(JJ)
40884         IF(II.EQ.1) THEN
40885           I = LSTRT(JJ)
40886         ELSE
40887           I = LNEXT(I)
40888         ENDIF
40889 C--top decay via W
40890         IF(IDK(I).EQ.6.AND.NME(I).EQ.100) THEN
40891           N3MODE = N3MODE+1
40892           IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',100,*999)
40893           P3MODE(N3MODE) = ONE
40894           IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
40895           SPN3CF(1,1,N3MODE) = ONE
40896           N3NCFL(N3MODE) = 1
40897           ID3PRT(N3MODE) = I
40898           NME(I)         = 10000+N3MODE
40899           NDI3BY(N3MODE)   = 1
40900           I3DRTP(1,N3MODE) = 1
40901           I3DRCF(1,N3MODE) = 1
40902           I3MODE(1,N3MODE) = 198
40903           A3MODE(1,1,N3MODE) = ZERO
40904           A3MODE(2,1,N3MODE) = -G*ORT
40905           B3MODE(1,1,N3MODE) = ZERO
40906           B3MODE(2,1,N3MODE) = -G*ORT
40907 C--antitop decay via W
40908         ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.100) THEN
40909           N3MODE = N3MODE+1
40910           IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',101,*999)
40911           P3MODE(N3MODE) = ONE
40912           IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
40913           SPN3CF(1,1,N3MODE) = ONE
40914           N3NCFL(N3MODE) = 1
40915           ID3PRT(N3MODE) = I
40916           NME(I) = 10000+N3MODE
40917           NDI3BY(N3MODE)   = 1
40918           I3DRTP(1,N3MODE) = 5
40919           I3DRCF(1,N3MODE) = 1
40920           I3MODE(1,N3MODE) = 199
40921           A3MODE(1,1,N3MODE) = ZERO
40922           A3MODE(2,1,N3MODE) = -G*ORT
40923           B3MODE(1,1,N3MODE) = ZERO
40924           B3MODE(2,1,N3MODE) = -G*ORT
40925 C--top decay via charged Higgs
40926         ELSEIF(IDK(I).EQ.6.AND.NME(I).EQ.200) THEN
40927           N3MODE = N3MODE+1
40928           IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',102,*999)
40929           P3MODE(N3MODE) = ONE
40930           IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
40931           SPN3CF(1,1,N3MODE) = ONE
40932           N3NCFL(N3MODE) = 1
40933           ID3PRT(N3MODE) = I
40934           NME(I) = 10000+N3MODE
40935           NDI3BY(N3MODE)   = 1
40936           I3DRTP(1,N3MODE) = 2
40937           I3DRCF(1,N3MODE) = 1
40938           I3MODE(1,N3MODE) = 206
40939           IL = IDKPRD(1,I)
40940           IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40941           IL = INT((IL+1)/2)
40942           DO 201 J=1,2
40943           A3MODE(J,1,N3MODE) = HFF(O(J),4,3)
40944  201      B3MODE(J,1,N3MODE) = HFF(  J ,4,IL)
40945 C--antitop decay via charged Higgs
40946         ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.200) THEN
40947           N3MODE = N3MODE+1
40948           IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',103,*999)
40949           P3MODE(N3MODE) = ONE
40950           IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
40951           SPN3CF(1,1,N3MODE) = ONE
40952           N3NCFL(N3MODE) = 1
40953           ID3PRT(N3MODE) = I
40954           NME(I) = 10000+N3MODE
40955           NDI3BY(N3MODE)   = 1
40956           I3DRTP(1,N3MODE) = 17
40957           I3DRCF(1,N3MODE) = 1
40958           I3MODE(1,N3MODE) = 207
40959           IL = IDKPRD(1,I)
40960           IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
40961           IL = INT((IL+1)/2)
40962           DO 202 J=1,2
40963           A3MODE(J,1,N3MODE) = HFF(  J ,4,3)
40964  202      B3MODE(J,1,N3MODE) = HFF(O(J),4,IL)
40965         ENDIF
40966  1000 CONTINUE
40967       IF(.NOT.SUSYIN) GOTO 2999
40968 C--loop over all the SUSY decay modes and find the ones we want
40969 C--first the true three body gaugino decays
40970       DO 2000 JJ=1,NRES
40971       DO 2000 II=1,NMODES(JJ)
40972         IF(II.EQ.1) THEN
40973           I = LSTRT(JJ)
40974         ELSE
40975           I = LNEXT(I)
40976         ENDIF
40977         L = IDKPRD(1,I)-449
40978         IF(IDKPRD(3,I).EQ.0.OR.IDKPRD(4,I).NE.0) GOTO 2500
40979 C--gluino modes first
40980         IF(IDK(I).EQ.449) THEN
40981 C--first the gluino modes to quark-antiquark neutralino
40982           IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
40983      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
40984             IQ = IDKPRD(2,I)
40985             IF(IQ.GT.6) IQ=IQ-6
40986             IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',200,*2000)
40987             N3MODE = N3MODE+1
40988             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',104,*999)
40989             P3MODE(N3MODE) = HALF
40990             SPN3CF(1,1,N3MODE) = ONE
40991             N3NCFL(N3MODE) = 1
40992             ID3PRT(N3MODE) = I
40993             NME(I) = 10000+N3MODE
40994             NDI3BY(N3MODE)   = 4
40995 C--only squark exchange diagrams
40996             DO 1 K=1,2
40997             I3DRTP(K  ,N3MODE) = 3
40998             I3DRCF(K  ,N3MODE) = 1
40999             I3DRTP(K+2,N3MODE) = 4
41000             I3DRCF(K+2,N3MODE) = 1
41001             I3MODE(K  ,N3MODE) = 12*(K-1)+400+IQ
41002             I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ
41003             DO 1 J=1,2
41004             A3MODE(J,K  ,N3MODE) = AFG(  J ,IQ,K)
41005             B3MODE(J,K  ,N3MODE) = AFN(O(J),IQ,K,L)
41006             A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ,K)
41007  1          B3MODE(J,K+2,N3MODE) = ZSGNSS(L)*AFN(  J ,IQ,K,L)
41008 C--then the gluino modes to quark-antiquark +ve chargino
41009           ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
41010      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41011             L = L-4
41012             IQ = IDKPRD(2,I)
41013             IF(IQ.GT.6) IQ=IQ-6
41014             IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',201,*2000)
41015             IQ = (IQ+MOD(IQ,2))/2
41016             IQ1 = 2*IQ-1
41017             IQ2 = 2*IQ
41018             N3MODE = N3MODE+1
41019             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',105,*999)
41020             P3MODE(N3MODE) = HALF
41021             SPN3CF(1,1,N3MODE) = ONE
41022             N3NCFL(N3MODE) = 1
41023             ID3PRT(N3MODE) = I
41024             NME(I) = 10000+N3MODE
41025             NDI3BY(N3MODE)   = 4
41026 C--only squark exchange diagrams
41027             DO 2 K=1,2
41028             I3DRTP(K  ,N3MODE) = 3
41029             I3DRCF(K  ,N3MODE) = 1
41030             I3DRTP(K+2,N3MODE) = 4
41031             I3DRCF(K+2,N3MODE) = 1
41032             I3MODE(K  ,N3MODE) = 12*(K-1)+400+IQ1
41033             I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
41034             DO 2 J=1,2
41035             A3MODE(J,K  ,N3MODE) = AFG(  J ,IQ1,K)
41036             B3MODE(J,K  ,N3MODE) = AFC(O(J),IQ1,K,L)
41037             A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
41038  2          B3MODE(J,K+2,N3MODE) = AFC(  J ,IQ2,K,L)
41039 C--then the gluino modes to quark-antiquark -ve chargino
41040           ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
41041      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41042             L = L-6
41043             IQ = IDKPRD(2,I)
41044             IF(IQ.GT.6) IQ=IQ-6
41045             IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',202,*2000)
41046             IQ = (IQ+MOD(IQ,2))/2
41047             IQ1 = 2*IQ
41048             IQ2 = 2*IQ-1
41049             N3MODE = N3MODE+1
41050             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',106,*999)
41051             P3MODE(N3MODE) = HALF
41052             SPN3CF(1,1,N3MODE) = ONE
41053             N3NCFL(N3MODE) = 1
41054             ID3PRT(N3MODE) = I
41055             NME(I) = 10000+N3MODE
41056             NDI3BY(N3MODE)   = 4
41057 C--only squark exchange diagrams
41058             DO 3 K=1,2
41059             I3DRTP(K  ,N3MODE) = 3
41060             I3DRCF(K  ,N3MODE) = 1
41061             I3DRTP(K+2,N3MODE) = 4
41062             I3DRCF(K+2,N3MODE) = 1
41063             I3MODE(K  ,N3MODE) = 12*(K-1)+400+IQ1
41064             I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
41065             DO 3 J=1,2
41066             A3MODE(J,K  ,N3MODE) = AFG(  J ,IQ1,K)
41067             B3MODE(J,K  ,N3MODE) = AFC(O(J),IQ1,K,L)
41068             A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
41069  3          B3MODE(J,K+2,N3MODE) = AFC(  J ,IQ2,K,L)
41070 C--RPV decay modes
41071 C--LQD first
41072           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41073      &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
41074             N3MODE = N3MODE+1
41075             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',107,*999)
41076             ID3PRT(N3MODE) = I
41077             NME(I) = 10000+N3MODE
41078             P3MODE(N3MODE) = HALF
41079             SPN3CF(1,1,N3MODE) = ONE
41080             N3NCFL(N3MODE) = 1
41081             NDI3BY(N3MODE) = 4
41082             DO 98 J=1,4
41083  98         I3DRCF(J,N3MODE) = 1
41084 C--first the neutrino mode
41085             IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41086 C--particle mode
41087               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41088                 III = (IDKPRD(1,I)-120)/2
41089                 JJJ = (IDKPRD(2,I)+1)/2
41090                 KKK = (IDKPRD(3,I)-5)/2
41091                 DO 99 K=1,2
41092                 I3DRTP(K  ,N3MODE) = 3
41093                 I3DRTP(K+2,N3MODE) = 4
41094                 I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
41095                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41096                 B3MODE(2,K  ,N3MODE) = 0.0D0
41097                 B3MODE(1,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41098      &                                 LAMDA2(III,JJJ,KKK)
41099                 B3MODE(2,K+2,N3MODE) = 0.0D0
41100                 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
41101      &                                 LAMDA2(III,JJJ,KKK)
41102                 DO 99 J=1,2
41103                 A3MODE(J,K  ,N3MODE) = AFG(  J ,2*JJJ-1,K)
41104  99             A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
41105 C--antiparticle mode
41106               ELSE
41107                 III = (IDKPRD(1,I)-126)/2
41108                 JJJ = (IDKPRD(2,I)-5)/2
41109                 KKK = (IDKPRD(3,I)+1)/2
41110                 DO 101 K=1,2
41111                 I3DRTP(K  ,N3MODE) = 9
41112                 I3DRTP(K+2,N3MODE) = 10
41113                 I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
41114                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41115                 B3MODE(1,K  ,N3MODE) = 0.0D0
41116                 B3MODE(2,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41117      &                                 LAMDA2(III,JJJ,KKK)
41118                 B3MODE(1,K+2,N3MODE) = 0.0D0
41119                 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
41120      &                                 LAMDA2(III,JJJ,KKK)
41121                 DO 101 J=1,2
41122                 A3MODE(J,K  ,N3MODE) = AFG(O(J),2*JJJ-1,K)
41123  101            A3MODE(J,K+2,N3MODE) = AFG(  J ,2*KKK-1,K)
41124               ENDIF
41125 C--then the charged lepton mode
41126             ELSE
41127 C--particle mode
41128               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41129                 III = (IDKPRD(1,I)-119)/2
41130                 JJJ = IDKPRD(2,I)/2
41131                 KKK = (IDKPRD(3,I)-5)/2
41132                 DO 102 K=1,2
41133                 I3DRTP(K  ,N3MODE) = 3
41134                 I3DRTP(K+2,N3MODE) = 4
41135                 I3MODE(K  ,N3MODE) = 400+2*JJJ+(K-1)*12
41136                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41137                 B3MODE(2,K  ,N3MODE) = 0.0D0
41138                 B3MODE(1,K  ,N3MODE) = QMIXSS(2*JJJ,1,K)*
41139      &                                 LAMDA2(III,JJJ,KKK)
41140                 B3MODE(2,K+2,N3MODE) = 0.0D0
41141                 B3MODE(1,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41142      &                                 LAMDA2(III,JJJ,KKK)
41143                 DO 102 J=1,2
41144                 A3MODE(J,K  ,N3MODE) = AFG(  J ,2*JJJ  ,K)
41145  102            A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
41146 C--antiparticle mode
41147               ELSE
41148                 III = (IDKPRD(1,I)-125)/2
41149                 JJJ = (IDKPRD(2,I)-6)/2
41150                 KKK = (IDKPRD(3,I)+1)/2
41151                 DO 103 K=1,2
41152                 I3DRTP(K  ,N3MODE) = 9
41153                 I3DRTP(K+2,N3MODE) = 10
41154                 I3MODE(K  ,N3MODE) = 400+2*JJJ+(K-1)*12
41155                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41156                 B3MODE(1,K  ,N3MODE) = 0.0D0
41157                 B3MODE(2,K  ,N3MODE) = QMIXSS(2*JJJ,1,K)*
41158      &                                 LAMDA2(III,JJJ,KKK)
41159                 B3MODE(1,K+2,N3MODE) = 0.0D0
41160                 B3MODE(2,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41161      &                                 LAMDA2(III,JJJ,KKK)
41162                 DO 103 J=1,2
41163                 A3MODE(J,K  ,N3MODE) = AFG(O(J),2*JJJ  ,K)
41164  103            A3MODE(J,K+2,N3MODE) = AFG(  J ,2*KKK-1,K)
41165               ENDIF
41166             ENDIF
41167 C--then UDD
41168           ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
41169      &           IDKPRD(3,I).LE.12) THEN
41170             N3MODE = N3MODE+1
41171             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',108,*999)
41172             P3MODE(N3MODE) = ONE
41173             N3NCFL(N3MODE) = 3
41174             ID3PRT(N3MODE) = I
41175             NME(I) = 10000+N3MODE
41176             NDI3BY(N3MODE)   = 6
41177             DO 70 J=1,3
41178             DO 70 K=1,3
41179               IF(J.NE.K) THEN
41180                 SPN3CF(J,K,N3MODE) = -HALF
41181               ELSE
41182                 SPN3CF(J,K,N3MODE) =  ONE
41183               ENDIF
41184  70         CONTINUE
41185 C--particle mode
41186             IF(IDKPRD(1,I).LE.6) THEN
41187 C--antiparticle mode
41188               III =  IDKPRD(1,I)/2
41189               JJJ = (IDKPRD(2,I)+1)/2
41190               KKK = (IDKPRD(3,I)+1)/2
41191               DO 71 K=1,2
41192               I3DRTP(K  ,N3MODE) = 11
41193               I3DRCF(K  ,N3MODE) = 1
41194               I3DRTP(K+2,N3MODE) = 12
41195               I3DRCF(K+2,N3MODE) = 2
41196               I3DRTP(K+4,N3MODE) = 13
41197               I3DRCF(K+4,N3MODE) = 3
41198               I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
41199               I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
41200               I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
41201               B3MODE(2,K  ,N3MODE) = QMIXSS(2*III,2,K)*
41202      &                               LAMDA3(III,JJJ,KKK)
41203               B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
41204      &                               LAMDA3(III,JJJ,KKK)
41205               B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41206      &                               LAMDA3(III,JJJ,KKK)
41207               B3MODE(1,K  ,N3MODE) = 0.0D0
41208               B3MODE(1,K+2,N3MODE) = 0.0D0
41209               B3MODE(1,K+4,N3MODE) = 0.0D0
41210               DO 71 J=1,2
41211               A3MODE(J,K  ,N3MODE) = AFG(J,2*III  ,K)
41212               A3MODE(J,K+2,N3MODE) = AFG(J,2*JJJ-1,K)
41213  71           A3MODE(J,K+4,N3MODE) = AFG(J,2*KKK-1,K)
41214             ELSE
41215               III = (IDKPRD(1,I)-6)/2
41216               JJJ = (IDKPRD(2,I)-5)/2
41217               KKK = (IDKPRD(3,I)-5)/2
41218               DO 72 K=1,2
41219               I3DRTP(K  ,N3MODE) = 14
41220               I3DRCF(K  ,N3MODE) = 1
41221               I3DRTP(K+2,N3MODE) = 15
41222               I3DRCF(K+2,N3MODE) = 2
41223               I3DRTP(K+4,N3MODE) = 16
41224               I3DRCF(K+4,N3MODE) = 3
41225               I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
41226               I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
41227               I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
41228               B3MODE(1,K  ,N3MODE) = QMIXSS(2*III,2,K)*
41229      &                               LAMDA3(III,JJJ,KKK)
41230               B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
41231      &                               LAMDA3(III,JJJ,KKK)
41232               B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41233      &                               LAMDA3(III,JJJ,KKK)
41234               B3MODE(2,K  ,N3MODE) = 0.0D0
41235               B3MODE(2,K+2,N3MODE) = 0.0D0
41236               B3MODE(2,K+4,N3MODE) = 0.0D0
41237               DO 72 J=1,2
41238               A3MODE(J,K  ,N3MODE) = AFG(O(J),2*III  ,K)
41239               A3MODE(J,K+2,N3MODE) = AFG(O(J),2*JJJ-1,K)
41240  72           A3MODE(J,K+4,N3MODE) = AFG(O(J),2*KKK-1,K)
41241             ENDIF
41242 C--unrecognized decay issue warning
41243           ELSE
41244             CALL HWWARN('HWISP3',1,*2000)
41245           ENDIF
41246         ELSEIF(IDK(I).GE.450.AND.IDK(I).LE.453) THEN
41247           L1 = IDK(I)-449
41248 C--neutralino modes next
41249           IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
41250      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41251 C--first the neutralino modes to fermion-antifermion neutralino
41252             IFR  = IDKPRD(2,I)
41253             J    = INT((IFR-1)/120)
41254             IFR  = IFR-6*INT((IFR-1)/6)+6*J
41255             IL   = IFR+4*J
41256             SIFR = IFR+18*J
41257             N3MODE = N3MODE+1
41258             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',109,*999)
41259             P3MODE(N3MODE) = ONE
41260             IF(IFR.LE.6) P3MODE(N3MODE)=THREE
41261             SPN3CF(1,1,N3MODE) = ONE
41262             N3NCFL(N3MODE) = 1
41263             ID3PRT(N3MODE) = I
41264             NME(I) = 10000+N3MODE
41265             NDI3BY(N3MODE) = 4
41266 C--sfermion exchange diagrams
41267             DO 4 K=1,2
41268             I3DRTP(K  ,N3MODE) = 3
41269             I3DRCF(K  ,N3MODE) = 1
41270             I3DRTP(K+2,N3MODE) = 4
41271             I3DRCF(K+2,N3MODE) = 1
41272             I3MODE(K  ,N3MODE) = 12*(K-1)+400+SIFR
41273             I3MODE(K+2,N3MODE) = 12*(K-1)+406+SIFR
41274             DO 4 J=1,2
41275             A3MODE(J,K  ,N3MODE) = AFN(  J ,IFR,K,L1)
41276             B3MODE(J,K  ,N3MODE) = AFN(O(J),IFR,K,L )
41277             A3MODE(J,K+2,N3MODE) = ZSGNSS(L1)*AFN(O(J),IFR,K,L1)
41278  4          B3MODE(J,K+2,N3MODE) = ZSGNSS(L )*AFN(  J ,IFR,K,L )
41279 C--now add higgs diagrams if third generation fermion, if Higgs off shell
41280             IF(IFR.EQ.5.OR.IFR.EQ.6.OR.IFR.EQ.11) THEN
41281               DO 5 J=1,3
41282                 IF(RMASS(IDK(I)).LT.
41283      &                RMASS(203+J)+RMASS(IDKPRD(1,I))) THEN
41284                   NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
41285                   I3DRTP(  NDI3BY(N3MODE),N3MODE) = 2
41286                   I3DRCF(  NDI3BY(N3MODE),N3MODE) = 1
41287                   I3MODE(  NDI3BY(N3MODE),N3MODE) = 203+J
41288                   DO 6 K=1,2
41289                   A3MODE(K,NDI3BY(N3MODE),N3MODE) = HNN(K,J,L,L1)
41290  6                B3MODE(K,NDI3BY(N3MODE),N3MODE) = HFF(K,J,IFR)
41291                 ENDIF
41292  5            CONTINUE
41293             ENDIF
41294 C-- and gauge boson diagrams if Z not on-shell
41295             IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
41296               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
41297               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
41298               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
41299               I3MODE(NDI3BY(N3MODE),N3MODE) = 200
41300               DO 7 J=1,2
41301  7            A3MODE(J,NDI3BY(N3MODE),N3MODE) =  OIJPP(J,L,L1)
41302               B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
41303               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
41304             ENDIF
41305           ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
41306      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41307 C--then  the neutralino modes to fermion-antifermion +ve chargino
41308 C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
41309             IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
41310             L = L-4
41311             N3MODE = N3MODE+1
41312             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',110,*999)
41313             ID3PRT(N3MODE) = I
41314             NME(I) = 10000+N3MODE
41315             NDI3BY(N3MODE) = 1
41316             P3MODE(N3MODE) = ONE
41317             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41318             SPN3CF(1,1,N3MODE) = ONE
41319             N3NCFL(N3MODE) = 1
41320 C--gauge boson diagram
41321             I3DRTP(1,N3MODE) = 1
41322             I3DRCF(1,N3MODE) = 1
41323             I3MODE(1,N3MODE) = 199
41324             DO 8 J=1,2
41325  8          A3MODE(J,1,N3MODE) = OIJ(J,L1,L)
41326             B3MODE(1,1,N3MODE) = ZERO
41327             B3MODE(2,1,N3MODE) = -G*ORT
41328           ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
41329      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41330 C--then  the neutralino modes to fermion-antifermion -ve chargino
41331 C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
41332             IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
41333             L = L-6
41334             N3MODE = N3MODE+1
41335             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',111,*999)
41336             ID3PRT(N3MODE) = I
41337             NME(I) = 10000+N3MODE
41338             NDI3BY(N3MODE) = 1
41339             P3MODE(N3MODE) = ONE
41340             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41341             SPN3CF(1,1,N3MODE) = ONE
41342             N3NCFL(N3MODE) = 1
41343 C--gauge boson diagram
41344             I3DRTP(1,N3MODE) = 1
41345             I3DRCF(1,N3MODE) = 1
41346             I3MODE(1,N3MODE) = 198
41347             DO 9 J=1,2
41348  9          A3MODE(J,1,N3MODE) =-OIJ(O(J),L1,L)
41349             B3MODE(1,1,N3MODE) = ZERO
41350             B3MODE(2,1,N3MODE) = -G*ORT
41351 C--gravitino E+e- modes
41352           ELSEIF(L.EQ.9.AND.(IDKPRD(2,I).LE.12.OR.
41353      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41354             IFR  = IDKPRD(2,I)
41355             J    = INT((IFR-1)/120)
41356             IFR  = IFR-6*INT((IFR-1)/6)+6*J
41357             IL   = IFR+4*J
41358             N3MODE = N3MODE+1
41359             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',112,*999)
41360             ID3PRT(N3MODE) = I
41361             NME(I) = 10000+N3MODE
41362             NDI3BY(N3MODE) = 1
41363             P3MODE(N3MODE) = ONE
41364             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41365             SPN3CF(1,1,N3MODE) = ONE
41366             N3NCFL(N3MODE) = 1
41367 C--diagram
41368             I3DRTP(1,N3MODE) = 7
41369             I3DRCF(1,N3MODE) = 1
41370             I3MODE(1,N3MODE) = 59
41371             A3MODE(1,1,N3MODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,1)
41372             A3MODE(2,1,N3MODE) = 0
41373             B3MODE(1,1,N3MODE) = -E*QFCH(IL)
41374             B3MODE(2,1,N3MODE) = -E*QFCH(IL)
41375 C--R-parity violating modes
41376 C--LLE modes
41377           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41378      &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
41379      &           IDKPRD(3,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
41380             N3MODE = N3MODE+1
41381             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',113,*999)
41382             ID3PRT(N3MODE) = I
41383             NME(I) = 10000+N3MODE
41384             NDI3BY(N3MODE) = 5
41385             P3MODE(N3MODE) = ONE
41386             SPN3CF(1,1,N3MODE) = ONE
41387             N3NCFL(N3MODE) = 1
41388 C--particle mode
41389             DO 53 J=1,6
41390  53         I3DRCF(J,N3MODE) = 1
41391             IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41392               III = (IDKPRD(1,I)-119)/2
41393               JJJ = (IDKPRD(2,I)-120)/2
41394               KKK = (IDKPRD(3,I)-125)/2
41395               DO 51 J=1,2
41396               I3DRTP(J  ,N3MODE) = 2
41397               I3DRTP(J+2,N3MODE) = 4
41398               I3MODE(J  ,N3MODE) = 423+2*III+(J-1)*12
41399               I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
41400               B3MODE(1,J  ,N3MODE) = LMIXSS(2*III-1,1,J)*
41401      &             LAMDA1(III,JJJ,KKK)
41402               B3MODE(2,J  ,N3MODE) = 0.0D0
41403               B3MODE(1,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
41404      &             LAMDA1(III,JJJ,KKK)
41405               B3MODE(2,J+2,N3MODE) = 0.0D0
41406               DO 51 K=1,2
41407               A3MODE(K,J  ,N3MODE) = AFN(  K ,5+2*III,J,L1)
41408  51           A3MODE(K,J+2,N3MODE) = AFN(O(K),5+2*KKK,J,L1)
41409               DO 48 K=1,2
41410  48           A3MODE(K,5,N3MODE) = AFN(  K ,6+2*JJJ,1,L1)
41411               I3DRTP(5,N3MODE) = 3
41412               I3MODE(5,N3MODE) = 430+2*JJJ
41413               B3MODE(1,5,N3MODE) = LAMDA1(III,JJJ,KKK)
41414               B3MODE(2,5,N3MODE) = 0.0D0
41415 C--antiparticle mode
41416             ELSE
41417               III = (IDKPRD(1,I)-125)/2
41418               JJJ = (IDKPRD(2,I)-126)/2
41419               KKK = (IDKPRD(3,I)-119)/2
41420               DO 52 J=1,2
41421               I3DRTP(J  ,N3MODE) = 8
41422               I3DRTP(J+2,N3MODE) = 10
41423               I3MODE(J  ,N3MODE) = 423+2*III+(J-1)*12
41424               I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
41425               B3MODE(2,J  ,N3MODE) = LMIXSS(2*III-1,1,J)*
41426      &             LAMDA1(III,JJJ,KKK)
41427               B3MODE(1,J  ,N3MODE) = 0.0D0
41428               B3MODE(2,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
41429      &             LAMDA1(III,JJJ,KKK)
41430               B3MODE(1,J+2,N3MODE) = 0.0D0
41431               DO 52 K=1,2
41432               A3MODE(K,J  ,N3MODE) = AFN(O(K),5+2*III,J,L1)
41433  52           A3MODE(K,J+2,N3MODE) = AFN(  K ,5+2*KKK,J,L1)
41434               DO 49 K=1,2
41435  49           A3MODE(K,5,N3MODE) = AFN(O(K),6+2*JJJ,1,L1)
41436               I3DRTP(5,N3MODE) = 9
41437               I3MODE(5,N3MODE) = 430+2*JJJ
41438               B3MODE(2,5,N3MODE) = LAMDA1(III,JJJ,KKK)
41439               B3MODE(1,5,N3MODE) = 0.0D0
41440             ENDIF
41441 C--LQD modes
41442           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41443      &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
41444             N3MODE = N3MODE+1
41445             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',114,*999)
41446             ID3PRT(N3MODE) = I
41447             NME(I) = 10000+N3MODE
41448             P3MODE(N3MODE) = 3.0D0
41449             SPN3CF(1,1,N3MODE) = ONE
41450             N3NCFL(N3MODE) = 1
41451             DO 81 J=1,6
41452  81         I3DRCF(J,N3MODE) = 1
41453 C--first the neutrino mode
41454             IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41455               NDI3BY(N3MODE) = 5
41456 C--particle mode
41457               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41458                 III = (IDKPRD(1,I)-120)/2
41459                 JJJ = (IDKPRD(2,I)+1)/2
41460                 KKK = (IDKPRD(3,I)-5)/2
41461                 DO 82 K=1,2
41462                 I3DRTP(K  ,N3MODE) = 3
41463                 I3DRTP(K+2,N3MODE) = 4
41464                 I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
41465                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41466                 B3MODE(2,K  ,N3MODE) = 0.0D0
41467                 B3MODE(1,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41468      &                                 LAMDA2(III,JJJ,KKK)
41469                 B3MODE(2,K+2,N3MODE) = 0.0D0
41470                 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
41471      &                                 LAMDA2(III,JJJ,KKK)
41472                 DO 82 J=1,2
41473                 A3MODE(J,K  ,N3MODE) = AFN(  J ,2*JJJ-1,K,L1)
41474  82             A3MODE(J,K+2,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
41475                 I3DRTP(5,N3MODE) = 2
41476                 I3MODE(5,N3MODE) = 424+2*III
41477                 B3MODE(2,5,N3MODE) = 0.0D0
41478                 B3MODE(1,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
41479                 DO 83 J=1,2
41480  83             A3MODE(J,5,N3MODE) = AFN(J,6+2*III,1,L1)
41481 C--antiparticle mode
41482               ELSE
41483                 III = (IDKPRD(1,I)-126)/2
41484                 JJJ = (IDKPRD(2,I)-5)/2
41485                 KKK = (IDKPRD(3,I)+1)/2
41486                 DO 84 K=1,2
41487                 I3DRTP(K  ,N3MODE) = 9
41488                 I3DRTP(K+2,N3MODE) = 10
41489                 I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
41490                 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
41491                 B3MODE(1,K  ,N3MODE) = 0.0D0
41492                 B3MODE(2,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41493      &                                 LAMDA2(III,JJJ,KKK)
41494                 B3MODE(1,K+2,N3MODE) = 0.0D0
41495                 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
41496      &                                 LAMDA2(III,JJJ,KKK)
41497                 DO 84 J=1,2
41498                 A3MODE(J,K  ,N3MODE) = AFN(O(J),2*JJJ-1,K,L1)
41499  84             A3MODE(J,K+2,N3MODE) = AFN(  J ,2*KKK-1,K,L1)
41500                 I3DRTP(5,N3MODE) = 8
41501                 I3MODE(5,N3MODE) = 424+2*III
41502                 B3MODE(1,5,N3MODE) = 0.0D0
41503                 B3MODE(2,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
41504                 DO 85 J=1,2
41505  85             A3MODE(J,5,N3MODE) = AFN(O(J),6+2*III,1,L1)
41506               ENDIF
41507 C--then the charged lepton mode
41508             ELSE
41509               NDI3BY(N3MODE) = 6
41510 C--particle mode
41511               IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41512                 III = (IDKPRD(1,I)-119)/2
41513                 JJJ = IDKPRD(2,I)/2
41514                 KKK = (IDKPRD(3,I)-5)/2
41515                 DO 86 K=1,2
41516                 I3DRTP(K  ,N3MODE) = 2
41517                 I3DRTP(K+2,N3MODE) = 3
41518                 I3DRTP(K+4,N3MODE) = 4
41519                 I3MODE(K  ,N3MODE) = 423+2*III+(K-1)*12
41520                 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
41521                 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
41522                 B3MODE(2,K  ,N3MODE) = 0.0D0
41523                 B3MODE(1,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
41524      &                                 LAMDA2(III,JJJ,KKK)
41525                 B3MODE(2,K+2,N3MODE) = 0.0D0
41526                 B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
41527      &                                 LAMDA2(III,JJJ,KKK)
41528                 B3MODE(2,K+4,N3MODE) = 0.0D0
41529                 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41530      &                                 LAMDA2(III,JJJ,KKK)
41531                 DO 86 J=1,2
41532                 A3MODE(J,K  ,N3MODE) = AFN(  J ,2*III+5,K,L1)
41533                 A3MODE(J,K+2,N3MODE) = AFN(  J ,2*JJJ  ,K,L1)
41534  86             A3MODE(J,K+4,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
41535 C--antiparticle mode
41536               ELSE
41537                 III = (IDKPRD(1,I)-125)/2
41538                 JJJ = (IDKPRD(2,I)-6)/2
41539                 KKK = (IDKPRD(3,I)+1)/2
41540                 DO 87 K=1,2
41541                 I3DRTP(K  ,N3MODE) = 8
41542                 I3DRTP(K+2,N3MODE) = 9
41543                 I3DRTP(K+4,N3MODE) = 10
41544                 I3MODE(K  ,N3MODE) = 423+2*III+(K-1)*12
41545                 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
41546                 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
41547                 B3MODE(1,K  ,N3MODE) = 0.0D0
41548                 B3MODE(2,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
41549      &                                 LAMDA2(III,JJJ,KKK)
41550                 B3MODE(1,K+2,N3MODE) = 0.0D0
41551                 B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
41552      &                                 LAMDA2(III,JJJ,KKK)
41553                 B3MODE(1,K+4,N3MODE) = 0.0D0
41554                 B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41555      &                                 LAMDA2(III,JJJ,KKK)
41556                 DO 87 J=1,2
41557                 A3MODE(J,K  ,N3MODE) = AFN(O(J),2*III+5,K,L1)
41558                 A3MODE(J,K+2,N3MODE) = AFN(O(J),2*JJJ  ,K,L1)
41559  87             A3MODE(J,K+4,N3MODE) = AFN(  J ,2*KKK-1,K,L1)
41560               ENDIF
41561             ENDIF
41562 C--UDD modes
41563           ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
41564      &           IDKPRD(3,I).LE.12) THEN
41565             N3MODE = N3MODE+1
41566             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',115,*999)
41567             ID3PRT(N3MODE) = I
41568             NME(I) = 10000+N3MODE
41569             NDI3BY(N3MODE) = 6
41570             P3MODE(N3MODE) = 6.0D0
41571             SPN3CF(1,1,N3MODE) = ONE
41572             N3NCFL(N3MODE) = 1
41573             DO 61 J=1,6
41574  61         I3DRCF(J,N3MODE) = 1
41575 C--particle mode
41576             IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41577               III = IDKPRD(1,I)/2
41578               JJJ = (IDKPRD(2,I)+1)/2
41579               KKK = (IDKPRD(3,I)+1)/2
41580               DO 62 J=1,2
41581               I3DRTP(J  ,N3MODE) = 11
41582               I3DRTP(J+2,N3MODE) = 12
41583               I3DRTP(J+4,N3MODE) = 13
41584               I3MODE(J  ,N3MODE) = 400+2*III+(J-1)*12
41585               I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
41586               I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
41587               B3MODE(2,J  ,N3MODE) = QMIXSS(2*III,2,J)*
41588      &                               LAMDA3(III,JJJ,KKK)
41589               B3MODE(2,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
41590      &                               LAMDA3(III,JJJ,KKK)
41591               B3MODE(2,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
41592      &                               LAMDA3(III,JJJ,KKK)
41593               B3MODE(1,J  ,N3MODE) = 0.0D0
41594               B3MODE(1,J+2,N3MODE) = 0.0D0
41595               B3MODE(1,J+4,N3MODE) = 0.0D0
41596               DO 62 K=1,2
41597               A3MODE(K,J  ,N3MODE) = AFN(K,2*III  ,J,L1)
41598               A3MODE(K,J+2,N3MODE) = AFN(K,2*JJJ-1,J,L1)
41599  62           A3MODE(K,J+4,N3MODE) = AFN(K,2*KKK-1,J,L1)
41600 C--antiparticle mode
41601             ELSE
41602               III = (IDKPRD(1,I)-6)/2
41603               JJJ = (IDKPRD(2,I)-5)/2
41604               KKK = (IDKPRD(3,I)-5)/2
41605               DO 63 J=1,2
41606               I3DRTP(J  ,N3MODE) = 14
41607               I3DRTP(J+2,N3MODE) = 15
41608               I3DRTP(J+4,N3MODE) = 16
41609               I3MODE(J  ,N3MODE) = 400+2*III+(J-1)*12
41610               I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
41611               I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
41612               B3MODE(2,J  ,N3MODE) = 0.0D0
41613               B3MODE(2,J+2,N3MODE) = 0.0D0
41614               B3MODE(2,J+4,N3MODE) = 0.0D0
41615               B3MODE(1,J  ,N3MODE) = QMIXSS(2*III,2,J)*
41616      &                               LAMDA3(III,JJJ,KKK)
41617               B3MODE(1,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
41618      &                               LAMDA3(III,JJJ,KKK)
41619               B3MODE(1,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
41620      &                               LAMDA3(III,JJJ,KKK)
41621               DO 63 K=1,2
41622               A3MODE(K,J  ,N3MODE) = AFN(O(K),2*III  ,J,L1)
41623               A3MODE(K,J+2,N3MODE) = AFN(O(K),2*JJJ-1,J,L1)
41624  63           A3MODE(K,J+4,N3MODE) = AFN(O(K),2*KKK-1,J,L1)
41625             ENDIF
41626 C--unrecognized decay issue warning
41627           ELSE
41628             CALL HWWARN('HWISP3',2,*2000)
41629           ENDIF
41630         ELSEIF(IDK(I).GE.454.AND.IDK(I).LE.455) THEN
41631 C--+ve chargino modes
41632 C--first the chargino modes to fermion-antifermion neutralino
41633           IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
41634      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41635             IFR = IDKPRD(2,I)
41636             IFR = IFR+MOD(IFR,2)
41637             J    = INT((IFR-1)/120)
41638             IFR  = IFR-6*INT((IFR-1)/6)+6*J
41639             IL   = IFR+4*J
41640             SIFR = IFR+18*J
41641             L1 = IDK(I)-453
41642             N3MODE = N3MODE+1
41643             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',116,*999)
41644             ID3PRT(N3MODE) = I
41645             NME(I) = 10000+N3MODE
41646             NDI3BY(N3MODE) = 4
41647             P3MODE(N3MODE) = ONE
41648             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41649             SPN3CF(1,1,N3MODE) = ONE
41650             N3NCFL(N3MODE) = 1
41651 C--sfermion exchange diagrams
41652             DO 10 K=1,2
41653             I3DRTP(K  ,N3MODE) = 3
41654             I3DRCF(K  ,N3MODE) = 1
41655             I3DRTP(K+2,N3MODE) = 4
41656             I3DRCF(K+2,N3MODE) = 1
41657             I3MODE(K  ,N3MODE) = 12*(K-1)+405+SIFR
41658             I3MODE(K+2,N3MODE) = 12*(K-1)+400+SIFR
41659             DO 10 J=1,2
41660             A3MODE(J,K  ,N3MODE) = AFC(  J ,IFR-1,K,L1)
41661             B3MODE(J,K  ,N3MODE) = AFN(O(J),IFR-1,K,L )
41662             A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR  ,K,L1)
41663  10         B3MODE(J,K+2,N3MODE) = AFN(  J ,IFR  ,K,L )
41664 C--gauge boson diagram
41665             IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
41666               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
41667               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
41668               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
41669               I3MODE(NDI3BY(N3MODE),N3MODE) = 198
41670               DO 11 J=1,2
41671  11           A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJ(J,L,L1)
41672               B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
41673               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
41674             ENDIF
41675 C--then  the chargino modes to fermion-antifermion chargino
41676           ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
41677      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
41678             L = L-4
41679             IFR = IDKPRD(2,I)
41680             J    = INT((IFR-1)/120)
41681             IFR  = IFR-6*INT((IFR-1)/6)+6*J
41682             IL   = IFR+4*J
41683             SIFR = IFR+18*J
41684             IF(MOD(IFR,2).EQ.0) THEN
41685               IFR = IFR-1
41686               SIFR = SIFR-1
41687             ELSE
41688               IFR = IFR+1
41689               SIFR = SIFR+1
41690             ENDIF
41691             L1 = IDK(I)-453
41692             N3MODE = N3MODE+1
41693             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',117,*999)
41694             ID3PRT(N3MODE) = I
41695             NME(I) = 10000+N3MODE
41696             NDI3BY(N3MODE) = 2
41697             P3MODE(N3MODE) = ONE
41698             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
41699             SPN3CF(1,1,N3MODE) = ONE
41700             N3NCFL(N3MODE) = 1
41701 C--sfermion exchange diagrams
41702             IF(MOD(IL,2).EQ.0) THEN
41703               DO 12 K=1,2
41704               I3DRTP(K,N3MODE) = 3
41705               I3DRCF(K,N3MODE) = 1
41706               I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
41707               DO 12 J=1,2
41708               A3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L1)
41709  12           B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
41710             ELSE
41711               DO 13 K=1,2
41712               I3DRTP(K,N3MODE) = 4
41713               I3DRCF(K,N3MODE) = 1
41714               I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
41715               DO 13 J=1,2
41716               A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
41717  13           B3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L )
41718             ENDIF
41719 C--gauge boson diagram
41720             IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
41721               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
41722               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
41723               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
41724               I3MODE(NDI3BY(N3MODE),N3MODE) = 200
41725               DO 14 J=1,2
41726  14           A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJP(J,L,L1)
41727               B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
41728               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
41729             ENDIF
41730 C--R-parity violating decays
41731 C--LLE first
41732           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41733      &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
41734      &           IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
41735             L1 = IDK(I)-453
41736 C--neutrino lepton neutrino
41737             IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
41738      &         MOD(IDKPRD(3,I),2).EQ.0) THEN
41739               N3MODE = N3MODE+1
41740               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',118,*999)
41741               ID3PRT(N3MODE) = I
41742               NME(I) = 10000+N3MODE
41743               NDI3BY(N3MODE) = 2
41744               P3MODE(N3MODE) = ONE
41745               N3NCFL(N3MODE) = 1
41746               SPN3CF(1,1,N3MODE) = ONE
41747               III = (IDKPRD(1,I)-126)/2
41748               JJJ = (IDKPRD(2,I)-125)/2
41749               KKK = (IDKPRD(3,I)-120)/2
41750               DO 54 K=1,2
41751               I3DRTP(K,N3MODE) = 10
41752               I3DRCF(K,N3MODE) = 1
41753               I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
41754               B3MODE(1,K,N3MODE) = 0.0D0
41755               B3MODE(2,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
41756               DO 54 J=1,2
41757  54           A3MODE(J,K,N3MODE) = AFC(J,5+2*KKK,K,L1)
41758 C--neutrino neutrino lepton
41759             ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
41760      &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
41761               N3MODE = N3MODE+1
41762               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',119,*999)
41763               ID3PRT(N3MODE) = I
41764               NME(I) = 10000+N3MODE
41765               NDI3BY(N3MODE) = 4
41766               P3MODE(N3MODE) = ONE
41767               N3NCFL(N3MODE) = 1
41768               SPN3CF(1,1,N3MODE) = ONE
41769               III = (IDKPRD(1,I)-120)/2
41770               JJJ = (IDKPRD(2,I)-120)/2
41771               KKK = (IDKPRD(3,I)-125)/2
41772               DO 55 K=1,2
41773               I3DRTP(K  ,N3MODE) = 2
41774               I3DRTP(K+2,N3MODE) = 3
41775               I3DRCF(K  ,N3MODE) = 1
41776               I3DRCF(K+2,N3MODE) = 1
41777               I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
41778               I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
41779               B3MODE(1,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
41780      &             LMIXSS(2*III-1,1,K)
41781               B3MODE(2,K,N3MODE) = 0.0D0
41782               B3MODE(1,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
41783      &             LMIXSS(2*JJJ-1,1,K)
41784               B3MODE(2,K+2,N3MODE) = 0.0D0
41785               DO 55 J=1,2
41786               A3MODE(J,K,N3MODE)   = AFC(J,5+2*III,K,L1)
41787  55           A3MODE(J,K+2,N3MODE) = AFC(J,5+2*JJJ,K,L1)
41788 C--lepton lepton lepton
41789             ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
41790      &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
41791               N3MODE = N3MODE+1
41792               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',120,*999)
41793               ID3PRT(N3MODE) = I
41794               NME(I) = 10000+N3MODE
41795               NDI3BY(N3MODE) = 2
41796               P3MODE(N3MODE) = ONE
41797               N3NCFL(N3MODE) = 1
41798               SPN3CF(1,1,N3MODE) = ONE
41799               III = (IDKPRD(1,I)-125)/2
41800               JJJ = (IDKPRD(2,I)-125)/2
41801               KKK = (IDKPRD(3,I)-119)/2
41802               I3DRTP(1,N3MODE) = 8
41803               I3DRTP(2,N3MODE) = 9
41804               I3DRCF(1,N3MODE) = 1
41805               I3DRCF(2,N3MODE) = 1
41806               I3MODE(1,N3MODE) = 424+2*III
41807               I3MODE(2,N3MODE) = 424+2*JJJ
41808               B3MODE(1,1,N3MODE) = 0.0D0
41809               B3MODE(2,1,N3MODE) = LAMDA1(III,JJJ,KKK)
41810               B3MODE(1,2,N3MODE) = 0.0D0
41811               B3MODE(2,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
41812               DO 56 J=1,2
41813               A3MODE(J,1,N3MODE) = AFC(O(J),6+2*III,1,L1)
41814  56           A3MODE(J,2,N3MODE) = AFC(O(J),6+2*JJJ,1,L1)
41815             ELSE
41816               CALL HWWARN('HWISP3',3,*2000)
41817             ENDIF
41818 C--LQD decays
41819           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41820      &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
41821             L1 = IDK(I)-453
41822 C--nubar dbar u
41823             IF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
41824               N3MODE = N3MODE+1
41825               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',121,*999)
41826               ID3PRT(N3MODE) = I
41827               NME(I) = 10000+N3MODE
41828               NDI3BY(N3MODE) = 2
41829               P3MODE(N3MODE) = THREE
41830               N3NCFL(N3MODE) = 1
41831               SPN3CF(1,1,N3MODE) = ONE
41832               III = (IDKPRD(1,I)-126)/2
41833               JJJ = (IDKPRD(2,I)-5)/2
41834               KKK = IDKPRD(3,I)/2
41835               DO 88 K=1,2
41836               I3DRTP(K,N3MODE) = 10
41837               I3DRCF(K,N3MODE) = 1
41838               I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
41839               B3MODE(1,K,N3MODE) = 0.0D0
41840               B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41841      &                             LAMDA2(III,JJJ,KKK)
41842               DO 88 J=1,2
41843  88           A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
41844 C--l+ ubar u
41845             ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
41846      &             MOD(IDKPRD(2,I),2).EQ.0) THEN
41847               N3MODE = N3MODE+1
41848               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',122,*999)
41849               ID3PRT(N3MODE) = I
41850               NME(I) = 10000+N3MODE
41851               NDI3BY(N3MODE) = 2
41852               P3MODE(N3MODE) = THREE
41853               N3NCFL(N3MODE) = 1
41854               SPN3CF(1,1,N3MODE) = ONE
41855               III = (IDKPRD(1,I)-125)/2
41856               JJJ = (IDKPRD(2,I)-6)/2
41857               KKK = IDKPRD(3,I)/2
41858               DO 89 K=1,2
41859               I3DRTP(K,N3MODE) = 10
41860               I3DRCF(K,N3MODE) = 1
41861               I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
41862               B3MODE(1,K,N3MODE) = 0.0D0
41863               B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
41864      &                             LAMDA2(III,JJJ,KKK)
41865               DO 89 J=1,2
41866  89           A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
41867 C--l+ dbar d
41868             ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
41869      &             MOD(IDKPRD(2,I),2).EQ.1) THEN
41870               N3MODE = N3MODE+1
41871               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',123,*999)
41872               ID3PRT(N3MODE) = I
41873               NME(I) = 10000+N3MODE
41874               NDI3BY(N3MODE) = 3
41875               P3MODE(N3MODE) = THREE
41876               N3NCFL(N3MODE) = 1
41877               SPN3CF(1,1,N3MODE) = ONE
41878               III = (IDKPRD(1,I)-125)/2
41879               JJJ = (IDKPRD(2,I)-5)/2
41880               KKK = (IDKPRD(3,I)+1)/2
41881               I3DRTP(1,N3MODE) = 8
41882               I3DRCF(1,N3MODE) = 1
41883               I3MODE(1,N3MODE) = 424+2*III
41884               B3MODE(1,1,N3MODE) = 0.0D0
41885               B3MODE(2,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
41886               DO 91 J=1,2
41887  91           A3MODE(J,1,N3MODE) = AFC(O(J),2*III+6,1,L1)
41888               DO 92 K=1,2
41889               I3DRTP(K+1,N3MODE) = 9
41890               I3DRCF(K+1,N3MODE) = 1
41891               I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
41892               B3MODE(1,K+1,N3MODE) = 0.0D0
41893               B3MODE(2,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
41894      &                               LAMDA2(III,JJJ,KKK)
41895               DO 92 J=1,2
41896  92           A3MODE(J,K+1,N3MODE) = AFC(O(J),2*JJJ,K,L1)
41897 C--nu u dbar
41898             ELSEIF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
41899               N3MODE = N3MODE+1
41900               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',124,*999)
41901               ID3PRT(N3MODE) = I
41902               NME(I) = 10000+N3MODE
41903               NDI3BY(N3MODE) = 4
41904               P3MODE(N3MODE) = THREE
41905               N3NCFL(N3MODE) = 1
41906               SPN3CF(1,1,N3MODE) = ONE
41907               III = (IDKPRD(1,I)-120)/2
41908               JJJ = IDKPRD(2,I)/2
41909               KKK = (IDKPRD(3,I)-5)/2
41910               DO 90 K=1,2
41911               I3DRTP(K  ,N3MODE) = 2
41912               I3DRTP(K+2,N3MODE) = 3
41913               I3DRCF(K  ,N3MODE) = 1
41914               I3DRCF(K+2,N3MODE) = 1
41915               I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
41916               I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
41917               B3MODE(1,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
41918      &                               LAMDA2(III,JJJ,KKK)
41919               B3MODE(2,K  ,N3MODE) = 0.0D0
41920               B3MODE(1,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
41921      &                               LAMDA2(III,JJJ,KKK)
41922               B3MODE(2,K+2,N3MODE) = 0.0D0
41923               DO 90 J=1,2
41924               A3MODE(J,K  ,N3MODE) = AFC(J,2*III+5,K,L1)
41925  90           A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
41926 C--unrecognised
41927             ELSE
41928               CALL HWWARN('HWISP3',4,*2000)
41929             ENDIF
41930 C--UDD decays
41931           ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
41932      &           IDKPRD(3,I).LE.12) THEN
41933              L1 = IDK(I)-453
41934 C--dbar dbar dbar mode
41935             IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
41936      &         MOD(IDKPRD(3,I),2).EQ.1) THEN
41937               N3MODE = N3MODE+1
41938               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',125,*999)
41939               ID3PRT(N3MODE) = I
41940               NME(I) = 10000+N3MODE
41941               NDI3BY(N3MODE) = 6
41942               N3NCFL(N3MODE) = 1
41943               SPN3CF(1,1,N3MODE) = ONE
41944               III = (IDKPRD(1,I)-5)/2
41945               JJJ = (IDKPRD(2,I)-5)/2
41946               KKK = (IDKPRD(3,I)-5)/2
41947               P3MODE(N3MODE) = ONE
41948               IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
41949               IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
41950               IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
41951               P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
41952               DO 66 K=1,6
41953  66           I3DRCF(K,N3MODE) = 1
41954               DO 65 K=1,2
41955               I3DRTP(K  ,N3MODE) = 14
41956               I3DRTP(K+2,N3MODE) = 15
41957               I3DRTP(K+4,N3MODE) = 16
41958               I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
41959               I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
41960               I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
41961               B3MODE(1,K  ,N3MODE) = QMIXSS(2*III,2,K)*
41962      &                               LAMDA3(III,JJJ,KKK)
41963               B3MODE(2,K  ,N3MODE) = 0.0D0
41964               B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
41965      &                               LAMDA3(JJJ,III,KKK)
41966               B3MODE(2,K+2,N3MODE) = 0.0D0
41967               B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
41968      &                               LAMDA3(KKK,III,JJJ)
41969               B3MODE(2,K+4,N3MODE) = 0.0D0
41970               DO 65 J=1,2
41971               A3MODE(J,K  ,N3MODE) = AFC(O(J),2*III,K,L1)
41972               A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ,K,L1)
41973  65           A3MODE(J,K+4,N3MODE) = AFC(O(J),2*KKK,K,L1)
41974 C--u u d mode
41975             ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
41976      &              .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
41977               N3MODE = N3MODE+1
41978               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',126,*999)
41979               ID3PRT(N3MODE) = I
41980               NME(I) = 10000+N3MODE
41981               NDI3BY(N3MODE) = 4
41982               P3MODE(N3MODE) = 6.0D0
41983               N3NCFL(N3MODE) = 1
41984               SPN3CF(1,1,N3MODE) = ONE
41985               III = IDKPRD(1,I)/2
41986               JJJ = IDKPRD(2,I)/2
41987               KKK = (IDKPRD(3,I)+1)/2
41988               IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
41989               DO 64 K=1,2
41990               I3DRTP(K  ,N3MODE) = 11
41991               I3DRTP(K+2,N3MODE) = 12
41992               I3DRCF(K  ,N3MODE) = 1
41993               I3DRCF(K+2,N3MODE) = 1
41994               I3MODE(K  ,N3MODE) = 399+2*III+(K-1)*12
41995               I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
41996               B3MODE(1,K  ,N3MODE) = 0.0D0
41997               B3MODE(2,K  ,N3MODE) = QMIXSS(2*III-1,2,K)*
41998      &                               LAMDA3(JJJ,III,KKK)
41999 c              B3MODE(2,K,N3MODE) = 0.0D0
42000               B3MODE(1,K+2,N3MODE) = 0.0D0
42001               B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
42002      &                               LAMDA3(III,JJJ,KKK)
42003               DO 64 J=1,2
42004               A3MODE(J,K  ,N3MODE) = AFC(J,2*III-1,K,L1)
42005  64           A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
42006 C--unrecognized decay issue warning
42007             ELSE
42008               CALL HWWARN('HWISP3',5,*2000)
42009             ENDIF
42010 C--unrecognized decay issue warning
42011           ELSE
42012             CALL HWWARN('HWISP3',6,*2000)
42013           ENDIF
42014         ELSEIF(IDK(I).GE.456.AND.IDK(I).LE.457) THEN
42015 C-- -ve chargino modes last
42016 C--first the chargino modes to fermion-antifermion neutralino
42017           IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
42018      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42019             IFR = IDKPRD(2,I)
42020             IFR = IFR+MOD(IFR,2)
42021             J    = INT((IFR-1)/120)
42022             IFR  = IFR-6*INT((IFR-1)/6)+6*J
42023             IL   = IFR+4*J
42024             SIFR = IFR+18*J
42025             L1 = IDK(I)-455
42026             N3MODE = N3MODE+1
42027             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',127,*999)
42028             ID3PRT(N3MODE) = I
42029             NME(I) = 10000+N3MODE
42030             NDI3BY(N3MODE) = 4
42031             P3MODE(N3MODE) = ONE
42032             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
42033             SPN3CF(1,1,N3MODE) = ONE
42034             N3NCFL(N3MODE) = 1
42035 C--sfermion exchange diagrams
42036             DO 15 K=1,2
42037             I3DRTP(K  ,N3MODE) = 3
42038             I3DRCF(K  ,N3MODE) = 1
42039             I3DRTP(K+2,N3MODE) = 4
42040             I3DRCF(K+2,N3MODE) = 1
42041             I3MODE(K  ,N3MODE) = 12*(K-1)+406+SIFR
42042             I3MODE(K+2,N3MODE) = 12*(K-1)+399+SIFR
42043             DO 15 J=1,2
42044             A3MODE(J,K  ,N3MODE) = AFC(  J ,IFR  ,K,L1)
42045             B3MODE(J,K  ,N3MODE) = AFN(O(J),IFR  ,K,L )
42046             A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR-1,K,L1)
42047  15         B3MODE(J,K+2,N3MODE) = AFN(  J ,IFR-1,K,L )
42048 C--gauge boson diagram
42049             IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
42050               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
42051               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
42052               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
42053               I3MODE(NDI3BY(N3MODE),N3MODE) = 199
42054               DO 16 J=1,2
42055  16           A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJ(O(J),L,L1)
42056               B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
42057               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
42058             ENDIF
42059 C--then  the chargino modes to fermion-antifermion chargino
42060           ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
42061      &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42062             L = L-6
42063             IFR = IDKPRD(2,I)
42064             J    = INT((IFR-1)/120)
42065             IFR  = IFR-6*INT((IFR-1)/6)+6*J
42066             IL   = IFR+4*J
42067             SIFR = IFR+18*J
42068             IF(MOD(IFR,2).EQ.0) THEN
42069               IFR = IFR-1
42070               SIFR = SIFR-1
42071             ELSE
42072               IFR = IFR+1
42073               SIFR = SIFR+1
42074             ENDIF
42075             L1 = IDK(I)-455
42076             N3MODE = N3MODE+1
42077             IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',128,*999)
42078             ID3PRT(N3MODE) = I
42079             NME(I) = 10000+N3MODE
42080             NDI3BY(N3MODE) = 2
42081             P3MODE(N3MODE) = ONE
42082             IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
42083             SPN3CF(1,1,N3MODE) = ONE
42084             N3NCFL(N3MODE) = 1
42085 C--sfermion exchange diagrams
42086             IF(MOD(IL,2).EQ.0) THEN
42087               DO 17 K=1,2
42088               I3DRTP(K,N3MODE) = 4
42089               I3DRCF(K,N3MODE) = 1
42090               I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
42091               DO 17 J=1,2
42092               A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
42093  17           B3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L )
42094             ELSE
42095               DO 18 K=1,2
42096               I3DRTP(K,N3MODE) = 3
42097               I3DRCF(K,N3MODE) = 1
42098               I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
42099               DO 18 J=1,2
42100               A3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L1)
42101  18           B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
42102             ENDIF
42103 C--gauge boson diagram
42104             IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
42105               NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
42106               I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
42107               I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
42108               I3MODE(NDI3BY(N3MODE),N3MODE) = 200
42109               DO 19 J=1,2
42110  19           A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJP(O(J),L,L1)
42111               B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
42112               B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
42113             ENDIF
42114 C--R-parity violating decays
42115 C--LLE first
42116           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
42117      &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
42118      &           IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
42119              L1 = IDK(I)-455
42120 C--neutrino lepton neutrino
42121             IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
42122      &         MOD(IDKPRD(3,I),2).EQ.0) THEN
42123               N3MODE = N3MODE+1
42124               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',129,*999)
42125               ID3PRT(N3MODE) = I
42126               NME(I) = 10000+N3MODE
42127               NDI3BY(N3MODE) = 2
42128               P3MODE(N3MODE) = ONE
42129               N3NCFL(N3MODE) = 1
42130               SPN3CF(1,1,N3MODE) = ONE
42131               III = (IDKPRD(1,I)-120)/2
42132               JJJ = (IDKPRD(2,I)-119)/2
42133               KKK = (IDKPRD(3,I)-126)/2
42134               DO 57 K=1,2
42135               I3DRTP(K,N3MODE) = 4
42136               I3DRCF(K,N3MODE) = 1
42137               I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
42138               B3MODE(2,K,N3MODE) = 0.0D0
42139               B3MODE(1,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
42140               DO 57 J=1,2
42141  57           A3MODE(J,K,N3MODE) = AFC(O(J),5+2*KKK,K,L1)
42142 C--neutrino neutrino lepton
42143             ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
42144      &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
42145               N3MODE = N3MODE+1
42146               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',130,*999)
42147               ID3PRT(N3MODE) = I
42148               NME(I) = 10000+N3MODE
42149               NDI3BY(N3MODE) = 4
42150               P3MODE(N3MODE) = ONE
42151               N3NCFL(N3MODE) = 1
42152               SPN3CF(1,1,N3MODE) = ONE
42153               III = (IDKPRD(1,I)-126)/2
42154               JJJ = (IDKPRD(2,I)-126)/2
42155               KKK = (IDKPRD(3,I)-119)/2
42156               DO 58 K=1,2
42157               I3DRTP(K  ,N3MODE) = 8
42158               I3DRTP(K+2,N3MODE) = 9
42159               I3DRCF(K  ,N3MODE) = 1
42160               I3DRCF(K+2,N3MODE) = 1
42161               I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
42162               I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
42163               B3MODE(2,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
42164      &             LMIXSS(2*III-1,1,K)
42165               B3MODE(1,K,N3MODE) = 0.0D0
42166               B3MODE(2,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
42167      &             LMIXSS(2*JJJ-1,1,K)
42168               B3MODE(1,K+2,N3MODE) = 0.0D0
42169               DO 58 J=1,2
42170               A3MODE(J,K,N3MODE)   = AFC(O(J),5+2*III,K,L1)
42171  58           A3MODE(J,K+2,N3MODE) = AFC(O(J),5+2*JJJ,K,L1)
42172 C--lepton lepton lepton
42173             ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
42174      &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
42175               N3MODE = N3MODE+1
42176               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',131,*999)
42177               ID3PRT(N3MODE) = I
42178               NME(I) = 10000+N3MODE
42179               NDI3BY(N3MODE) = 2
42180               P3MODE(N3MODE) = ONE
42181               N3NCFL(N3MODE) = 1
42182               SPN3CF(1,1,N3MODE) = ONE
42183               III = (IDKPRD(1,I)-119)/2
42184               JJJ = (IDKPRD(2,I)-119)/2
42185               KKK = (IDKPRD(3,I)-125)/2
42186               I3DRTP(1,N3MODE) = 2
42187               I3DRTP(2,N3MODE) = 3
42188               I3DRCF(1,N3MODE) = 1
42189               I3DRCF(2,N3MODE) = 1
42190               I3MODE(1,N3MODE) = 424+2*III
42191               I3MODE(2,N3MODE) = 424+2*JJJ
42192               B3MODE(1,1,N3MODE) = LAMDA1(III,JJJ,KKK)
42193               B3MODE(2,1,N3MODE) = 0.0D0
42194               B3MODE(1,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
42195               B3MODE(2,2,N3MODE) = 0.0D0
42196               DO 59 J=1,2
42197               A3MODE(J,1,N3MODE) = AFC(J,6+2*III,1,L1)
42198  59           A3MODE(J,2,N3MODE) = AFC(J,6+2*JJJ,1,L1)
42199             ELSE
42200               CALL HWWARN('HWISP3',7,*2000)
42201             ENDIF
42202 C--LQD decays
42203           ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
42204      &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
42205             L1 = IDK(I)-455
42206 C--nu d ubar
42207             IF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
42208               N3MODE = N3MODE+1
42209               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',132,*999)
42210               ID3PRT(N3MODE) = I
42211               NME(I) = 10000+N3MODE
42212               NDI3BY(N3MODE) = 2
42213               P3MODE(N3MODE) = THREE
42214               N3NCFL(N3MODE) = 1
42215               SPN3CF(1,1,N3MODE) = ONE
42216               III = (IDKPRD(1,I)-120)/2
42217               JJJ = (IDKPRD(2,I)+1)/2
42218               KKK = (IDKPRD(3,I)-6)/2
42219               DO 93 K=1,2
42220               I3DRTP(K,N3MODE) = 4
42221               I3DRCF(K,N3MODE) = 1
42222               I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
42223               B3MODE(2,K,N3MODE) = 0.0D0
42224               B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42225      &                             LAMDA2(III,JJJ,KKK)
42226               DO 93 J=1,2
42227  93           A3MODE(J,K,N3MODE) = AFC(O(J),2*KKK-1,K,L1)
42228 C--l- u ubar
42229             ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
42230      &             MOD(IDKPRD(2,I),2).EQ.0) THEN
42231               N3MODE = N3MODE+1
42232               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',133,*999)
42233               ID3PRT(N3MODE) = I
42234               NME(I) = 10000+N3MODE
42235               NDI3BY(N3MODE) = 2
42236               P3MODE(N3MODE) = THREE
42237               N3NCFL(N3MODE) = 1
42238               SPN3CF(1,1,N3MODE) = ONE
42239               III = (IDKPRD(1,I)-119)/2
42240               JJJ = IDKPRD(2,I)/2
42241               KKK = (IDKPRD(3,I)-6)/2
42242               DO 94 K=1,2
42243               I3DRTP(K,N3MODE) = 4
42244               I3DRCF(K,N3MODE) = 1
42245               I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
42246               B3MODE(2,K,N3MODE) = 0.0D0
42247               B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42248      &                             LAMDA2(III,JJJ,KKK)
42249               DO 94 J=1,2
42250  94           A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
42251 C--l- d dbar
42252             ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
42253      &             MOD(IDKPRD(2,I),2).EQ.1) THEN
42254               N3MODE = N3MODE+1
42255               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',134,*999)
42256               ID3PRT(N3MODE) = I
42257               NME(I) = 10000+N3MODE
42258               NDI3BY(N3MODE) = 3
42259               P3MODE(N3MODE) = THREE
42260               N3NCFL(N3MODE) = 1
42261               SPN3CF(1,1,N3MODE) = ONE
42262               III = (IDKPRD(1,I)-119)/2
42263               JJJ = (IDKPRD(2,I)+1)/2
42264               KKK = (IDKPRD(3,I)-5)/2
42265               I3DRTP(1,N3MODE) = 2
42266               I3DRCF(1,N3MODE) = 1
42267               I3MODE(1,N3MODE) = 424+2*III
42268               B3MODE(2,1,N3MODE) = 0.0D0
42269               B3MODE(1,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
42270               DO 95 J=1,2
42271  95           A3MODE(J,1,N3MODE) = AFC(J,2*III+6,1,L1)
42272               DO 96 K=1,2
42273               I3DRTP(K+1,N3MODE) = 3
42274               I3DRCF(K+1,N3MODE) = 1
42275               I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
42276               B3MODE(2,K+1,N3MODE) = 0.0D0
42277               B3MODE(1,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
42278      &                               LAMDA2(III,JJJ,KKK)
42279               DO 96 J=1,2
42280  96           A3MODE(J,K+1,N3MODE) = AFC(J,2*JJJ,K,L1)
42281 C--nubar ubar d
42282             ELSEIF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
42283               N3MODE = N3MODE+1
42284               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',135,*999)
42285               ID3PRT(N3MODE) = I
42286               NME(I) = 10000+N3MODE
42287               NDI3BY(N3MODE) = 4
42288               P3MODE(N3MODE) = THREE
42289               N3NCFL(N3MODE) = 1
42290               SPN3CF(1,1,N3MODE) = ONE
42291               III = (IDKPRD(1,I)-126)/2
42292               JJJ = (IDKPRD(2,I)-6)/2
42293               KKK = (IDKPRD(3,I)+1)/2
42294               DO 97 K=1,2
42295               I3DRTP(K  ,N3MODE) = 8
42296               I3DRTP(K+2,N3MODE) = 9
42297               I3DRCF(K  ,N3MODE) = 1
42298               I3DRCF(K+2,N3MODE) = 1
42299               I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
42300               I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
42301               B3MODE(2,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
42302      &                               LAMDA2(III,JJJ,KKK)
42303               B3MODE(1,K  ,N3MODE) = 0.0D0
42304               B3MODE(2,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
42305      &                               LAMDA2(III,JJJ,KKK)
42306               B3MODE(1,K+2,N3MODE) = 0.0D0
42307               DO 97 J=1,2
42308               A3MODE(J,K  ,N3MODE) = AFC(O(J),2*III+5,K,L1)
42309  97           A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
42310 C--unrecognised
42311             ELSE
42312               CALL HWWARN('HWISP3',8,*2000)
42313             ENDIF
42314 C-- UDD modes
42315           ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
42316      &           IDKPRD(3,I).LE.12) THEN
42317              L1 = IDK(I)-455
42318 C-- d d d mode
42319             IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
42320      &         MOD(IDKPRD(3,I),2).EQ.1) THEN
42321               N3MODE = N3MODE+1
42322               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',136,*999)
42323               ID3PRT(N3MODE) = I
42324               NME(I) = 10000+N3MODE
42325               NDI3BY(N3MODE) = 6
42326               N3NCFL(N3MODE) = 1
42327               SPN3CF(1,1,N3MODE) = ONE
42328               III = (IDKPRD(1,I)+1)/2
42329               JJJ = (IDKPRD(2,I)+1)/2
42330               KKK = (IDKPRD(3,I)+1)/2
42331               P3MODE(N3MODE) = ONE
42332               IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
42333               IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
42334               IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
42335               P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
42336               DO 68 K=1,6
42337  68           I3DRCF(K,N3MODE) = 1
42338               DO 67 K=1,2
42339               I3DRTP(K  ,N3MODE) = 12
42340               I3DRTP(K+2,N3MODE) = 13
42341               I3DRTP(K+4,N3MODE) = 14
42342               I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
42343               I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
42344               I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
42345               B3MODE(1,K  ,N3MODE) = 0.0D0
42346               B3MODE(1,K+2,N3MODE) = 0.0D0
42347               B3MODE(1,K+4,N3MODE) = 0.0D0
42348               B3MODE(2,K  ,N3MODE) = QMIXSS(2*III,2,K)*
42349      &                               LAMDA3(III,JJJ,KKK)
42350               B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
42351      &                               LAMDA3(JJJ,III,KKK)
42352               B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
42353      &                               LAMDA3(KKK,III,JJJ)
42354               DO 67 J=1,2
42355               A3MODE(J,K  ,N3MODE) = AFC(J,2*III,K,L1)
42356               A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ,K,L1)
42357  67           A3MODE(J,K+4,N3MODE) = AFC(J,2*KKK,K,L1)
42358 C--u u d mode
42359             ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
42360      &              .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
42361               N3MODE = N3MODE+1
42362               IF(N3MODE.GT.NMODE3) CALL HWWARN('HWISP3',137,*999)
42363               ID3PRT(N3MODE) = I
42364               NME(I) = 10000+N3MODE
42365               NDI3BY(N3MODE) = 4
42366               P3MODE(N3MODE) = 6.0D0
42367               N3NCFL(N3MODE) = 1
42368               SPN3CF(1,1,N3MODE) = ONE
42369               III = (IDKPRD(1,I)-6)/2
42370               JJJ = (IDKPRD(2,I)-6)/2
42371               KKK = (IDKPRD(3,I)-5)/2
42372               IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
42373               DO 69 K=1,2
42374               I3DRTP(K  ,N3MODE) = 11
42375               I3DRTP(K+2,N3MODE) = 12
42376               I3DRCF(K  ,N3MODE) = 1
42377               I3DRCF(K+2,N3MODE) = 1
42378               I3MODE(K  ,N3MODE) = 399+2*III+(K-1)*12
42379               I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
42380               B3MODE(1,K  ,N3MODE) = QMIXSS(2*III-1,2,K)*
42381      &                               LAMDA3(JJJ,III,KKK)
42382               B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
42383      &                               LAMDA3(III,JJJ,KKK)
42384               B3MODE(2,K+2,N3MODE) = 0.0D0
42385               B3MODE(2,K+2,N3MODE) = 0.0D0
42386               DO 69 J=1,2
42387               A3MODE(J,K  ,N3MODE) = AFC(O(J),2*III-1,K,L1)
42388  69           A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
42389 C--unrecognized decay issue warning
42390             ELSE
42391               CALL HWWARN('HWISP3',9,*2000)
42392             ENDIF
42393 C--unrecognized decay issue warning
42394           ELSE
42395             CALL HWWARN('HWISP3',10,*2000)
42396           ENDIF
42397         ENDIF
42398 C--NOW FIND THE TWO BODY MODES WE WILL TREAT AS THREE BODY
42399  2500   IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0) GOTO 2000
42400         L1  = IDK(I)-449
42401         IH1 = IDK(I)-202
42402         IH  = IDKPRD(1,I)-202
42403 C--first the neutralino decay modes
42404         IF(L1.GE.1.AND.L1.LE.4.AND.
42405      &     IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42406 C--neutralino --> neutralino Z
42407           IF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.200) THEN
42408             NBMODE = NBMODE+1
42409             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',138,*999)
42410             NME(I) = 20000+NBMODE
42411             IDBPRT(NBMODE) = I
42412             IBMODE(NBMODE) = 200
42413             IBDRTP(NBMODE) = 1
42414             DO 20 J=1,2
42415  20         ABMODE(J,NBMODE) = OIJPP(J,L,L1)
42416             DO 21 K=1,12
42417             IF(K.LE.6) THEN
42418               IL = K
42419               PBMODE(K,NBMODE) = THREE
42420             ELSE
42421               IL=K+4
42422               PBMODE(K,NBMODE) = ONE
42423             ENDIF
42424             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42425  21         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42426 C--neutralino --> chargino+ W-
42427           ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.199) THEN
42428             L = L-4
42429             NBMODE = NBMODE+1
42430             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',139,*999)
42431             NME(I) = 20000+NBMODE
42432             IDBPRT(NBMODE) = I
42433             IBMODE(NBMODE) = 199
42434             IBDRTP(NBMODE) = 1
42435             DO 22 J=1,2
42436  22         ABMODE(J,NBMODE) = OIJ(J,L1,L)
42437             DO 23 K=1,6
42438             PBMODE(K,NBMODE) = ONE
42439             IF(K.LE.3) PBMODE(K,NBMODE) = THREE
42440             BBMODE(1,K,NBMODE) = ZERO
42441  23         BBMODE(2,K,NBMODE) = -G*ORT
42442 C--neutralino --> chargino- W+
42443           ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.198) THEN
42444             L = L-6
42445             NBMODE = NBMODE+1
42446             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',140,*999)
42447             NME(I) = 20000+NBMODE
42448             IDBPRT(NBMODE) = I
42449             IBMODE(NBMODE) = 198
42450             IBDRTP(NBMODE) = 1
42451             DO 24 J=1,2
42452  24         ABMODE(J,NBMODE) =-OIJ(O(J),L1,L)
42453             DO 25 K=1,6
42454             PBMODE(K,NBMODE) = ONE
42455             IF(K.LE.3) PBMODE(K,NBMODE) = THREE
42456             BBMODE(1,K,NBMODE) = ZERO
42457  25         BBMODE(2,K,NBMODE) = -G*ORT
42458 C--gravitino Z modes
42459           ELSEIF(L.EQ.9.AND.IDKPRD(2,I).EQ.200) THEN
42460             NBMODE = NBMODE+1
42461             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',141,*999)
42462             NME(I) = 20000+NBMODE
42463             IDBPRT(NBMODE) = I
42464             IBMODE(NBMODE) = 200
42465             IBDRTP(NBMODE) = 7
42466             ABMODE(1,NBMODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,2)
42467             ABMODE(2,NBMODE) = 2.0D0/SQRT(6.0D0)*RMASS(200)*
42468      &                         (ZMIXSS(L1,3)*COSB-ZMIXSS(L1,4)*SINB)
42469             DO 41 K=1,12
42470             IF(K.LE.6) THEN
42471               IL = K
42472               PBMODE(K,NBMODE) = THREE
42473             ELSE
42474               IL=K+4
42475               PBMODE(K,NBMODE) = ONE
42476             ENDIF
42477             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42478  41         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42479 C--unrecognized decay issue warning
42480           ELSE
42481             CALL HWWARN('HWISP3',11,*2000)
42482           ENDIF
42483 C--then the +ve chargino decay modes
42484         ELSEIF((L1.EQ.5.OR.L1.EQ.6)
42485      &         .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42486           L1 = L1-4
42487 C--chargino --> chargino Z
42488           IF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.200) THEN
42489             L = L-4
42490             NBMODE = NBMODE+1
42491             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',142,*999)
42492             NME(I) = 20000+NBMODE
42493             IDBPRT(NBMODE) = I
42494             IBMODE(NBMODE) = 200
42495             IBDRTP(NBMODE) = 1
42496             DO 26 J=1,2
42497  26         ABMODE(J,NBMODE) = OIJP(J,L,L1)
42498             DO 27 K=1,12
42499             IF(K.LE.6) THEN
42500               IL = K
42501               PBMODE(K,NBMODE) = THREE
42502             ELSE
42503               IL=K+4
42504               PBMODE(K,NBMODE) = ONE
42505             ENDIF
42506             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42507  27         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42508 C--chargino --> neutralino W+
42509           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.198) THEN
42510             NBMODE = NBMODE+1
42511             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',143,*999)
42512             NME(I) = 20000+NBMODE
42513             IDBPRT(NBMODE) = I
42514             IBMODE(NBMODE) = 198
42515             IBDRTP(NBMODE) = 1
42516             DO 28 J=1,2
42517  28         ABMODE(J,NBMODE) = OIJ(J,L,L1)
42518             DO 29 K=1,6
42519             PBMODE(K,NBMODE) = ONE
42520             IF(K.LE.3) PBMODE(K,NBMODE) = THREE
42521             BBMODE(1,K,NBMODE) = ZERO
42522  29         BBMODE(2,K,NBMODE) = -G*ORT
42523 C--unrecognised decay issue warning
42524           ELSE
42525             CALL HWWARN('HWISP3',12,*2000)
42526           ENDIF
42527 C--then the -ve chargino decay modes
42528         ELSEIF((L1.EQ.7.OR.L1.EQ.8)
42529      &         .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42530           L1 = L1-6
42531 C--chargino --> chargino Z
42532           IF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.200) THEN
42533             L = L-6
42534             NBMODE = NBMODE+1
42535             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',144,*999)
42536             NME(I) = 20000+NBMODE
42537             IDBPRT(NBMODE) = I
42538             IBMODE(NBMODE) = 200
42539             IBDRTP(NBMODE) = 1
42540             DO 30 J=1,2
42541  30         ABMODE(J,NBMODE) =-OIJP(O(J),L,L1)
42542             DO 31 K=1,12
42543             IF(K.LE.6) THEN
42544               IL = K
42545               PBMODE(K,NBMODE) = THREE
42546             ELSE
42547               IL=K+4
42548               PBMODE(K,NBMODE) = ONE
42549             ENDIF
42550             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42551  31         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42552 C--chargino --> neutralino W-
42553           ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.199) THEN
42554             NBMODE = NBMODE+1
42555             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',145,*999)
42556             NME(I) = 20000+NBMODE
42557             IDBPRT(NBMODE) = I
42558             IBMODE(NBMODE) = 199
42559             IBDRTP(NBMODE) = 1
42560             DO 32 J=1,2
42561  32         ABMODE(J,NBMODE) =-OIJ(O(J),L,L1)
42562             DO 33 K=1,6
42563             PBMODE(K,NBMODE) = ONE
42564             IF(K.LE.3) PBMODE(K,NBMODE) = THREE
42565             BBMODE(1,K,NBMODE) = ZERO
42566  33         BBMODE(2,K,NBMODE) = -G*ORT
42567 C--unrecognised decay issue warning
42568           ELSE
42569             CALL HWWARN('HWISP3',13,*2000)
42570           ENDIF
42571 C--gauge boson decay modes of the Higgs
42572         ELSEIF(IH.GE.1.AND.IH.LE.5.AND.IH1.GE.1.AND.IH1.LE.5.AND.
42573      &         IDKPRD(1,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42574 C--decay of the A0 to scalar Higgs and Z boson
42575           IF(IH1.EQ.3.AND.IH.LE.2) THEN
42576             NBMODE = NBMODE+1
42577             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',146,*999)
42578             NME(I) = 20000+NBMODE
42579             IDBPRT(NBMODE) = I
42580             IBMODE(NBMODE) = 200
42581             IBDRTP(NBMODE) = 6
42582             ABMODE(1,NBMODE) =-HHB(2,IH)
42583             ABMODE(2,NBMODE) = ZERO
42584             DO 34 K=1,12
42585             IF(K.LE.6) THEN
42586               IL = K
42587               PBMODE(K,NBMODE) = 3.0D0
42588             ELSE
42589               IL=K+4
42590               PBMODE(K,NBMODE) = 1.0D0
42591             ENDIF
42592             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42593  34         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42594 C--decay of scalar Higgs to A0 and Z
42595           ELSEIF(IH.EQ.3.AND.IH1.LE.3) THEN
42596             NBMODE = NBMODE+1
42597             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',147,*999)
42598             NME(I) = 20000+NBMODE
42599             IDBPRT(NBMODE) = I
42600             IBMODE(NBMODE) = 200
42601             IBDRTP(NBMODE) = 6
42602             ABMODE(1,NBMODE) = HHB(2,IH1)
42603             ABMODE(2,NBMODE) = ZERO
42604             DO 35 K=1,12
42605             IF(K.LE.6) THEN
42606               IL = K
42607               PBMODE(K,NBMODE) = 3.0D0
42608             ELSE
42609               IL=K+4
42610               PBMODE(K,NBMODE) = 1.0D0
42611             ENDIF
42612             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42613  35         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42614 C--decay of the positively charged Higgs
42615           ELSEIF(IH1.EQ.4.AND.IH.LE.3) THEN
42616             NBMODE = NBMODE+1
42617             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',148,*999)
42618             NME(I) = 20000+NBMODE
42619             IDBPRT(NBMODE) = I
42620             IBMODE(NBMODE) = 198
42621             IBDRTP(NBMODE) = 6
42622             ABMODE(1,NBMODE) =-HHB(1,IH)
42623             ABMODE(2,NBMODE) = ZERO
42624             DO 36 K=1,6
42625             PBMODE(K,NBMODE) = 1.0D0
42626             IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
42627             BBMODE(1,K,NBMODE) = ZERO
42628  36         BBMODE(2,K,NBMODE) = -G*ORT
42629 C--decay of the negatively charged Higgs
42630           ELSEIF(IH1.EQ.5.AND.IH.LE.3) THEN
42631             NBMODE = NBMODE+1
42632             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',149,*999)
42633             NME(I) = 20000+NBMODE
42634             IDBPRT(NBMODE) = I
42635             IBMODE(NBMODE) = 199
42636             IBDRTP(NBMODE) = 6
42637             ABMODE(1,NBMODE) =-HHB(1,IH)
42638             ABMODE(2,NBMODE) = ZERO
42639             DO 37 K=1,6
42640             PBMODE(K,NBMODE) = 1.0D0
42641             IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
42642             BBMODE(1,K,NBMODE) = ZERO
42643  37         BBMODE(2,K,NBMODE) = -G*ORT
42644           ENDIF
42645 C--finally sfermion modes to gauge bosons
42646         ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.448.AND.
42647      &         IDKPRD(2,I).GE.401.AND.IDKPRD(2,I).LE.448.AND.
42648      &         IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200) THEN
42649 C--change the order of the decay products
42650           IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
42651           IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
42652           IH = MOD(INT((IDKPRD(2,I)-389)/12)+1,2)+1
42653           IQ = 6*INT((IDKPRD(2,I)-401)/24)+MOD(IDKPRD(2,I)-401,6)+1
42654 C--first the Z decay modes
42655           IF(IDKPRD(1,I).EQ.200) THEN
42656             NBMODE = NBMODE+1
42657             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',150,*999)
42658             NME(I) = 20000+NBMODE
42659             IDBPRT(NBMODE) = I
42660             IBMODE(NBMODE) = 200
42661             IBDRTP(NBMODE) = 6
42662             ABMODE(1,NBMODE) = ZAB(IL,IM,IH)
42663             ABMODE(2,NBMODE) = ZERO
42664             DO 38 K=1,12
42665             IF(K.LE.6) THEN
42666               IL = K
42667               PBMODE(K,NBMODE) = 3.0D0
42668             ELSE
42669               IL=K+4
42670               PBMODE(K,NBMODE) = 1.0D0
42671             ENDIF
42672             BBMODE(1,K,NBMODE) = -E*RFCH(IL)
42673  38         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
42674 C--then  the W+ decay modes
42675           ELSEIF(IDKPRD(1,I).EQ.198) THEN
42676             NBMODE = NBMODE+1
42677             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',151,*999)
42678             NME(I) = 20000+NBMODE
42679             IDBPRT(NBMODE) = I
42680             IBMODE(NBMODE) = 198
42681             IBDRTP(NBMODE) = 6
42682             IF(IL.LE.6) THEN
42683               ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
42684             ELSE
42685               ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
42686      &                                  LMIXSS(IQ-6,1,IH)
42687             ENDIF
42688             ABMODE(2,NBMODE) = ZERO
42689             DO 39 K=1,6
42690             PBMODE(K,NBMODE) = 1.0D0
42691             IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
42692             BBMODE(1,K,NBMODE) = ZERO
42693  39         BBMODE(2,K,NBMODE) = -G*ORT
42694           ELSEIF(IDKPRD(1,I).EQ.199) THEN
42695             NBMODE = NBMODE+1
42696             IF(NBMODE.GT.NMODEB) CALL HWWARN('HWISP3',152,*999)
42697             NME(I) = 20000+NBMODE
42698             IDBPRT(NBMODE) = I
42699             IBMODE(NBMODE) = 199
42700             IBDRTP(NBMODE) = 6
42701             IF(IL.LE.6) THEN
42702               ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
42703             ELSE
42704               ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
42705      &                                  LMIXSS(IQ-6,1,IH)
42706             ENDIF
42707             ABMODE(2,NBMODE) = ZERO
42708             DO 40 K=1,6
42709             PBMODE(K,NBMODE) = 1.0D0
42710             IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
42711             BBMODE(1,K,NBMODE) = ZERO
42712  40         BBMODE(2,K,NBMODE) = -G*ORT
42713           ENDIF
42714         ENDIF
42715  2000 CONTINUE
42716 C--now compute the maximum weights for the three body decays found
42717  2999 CONTINUE
42718       DO 3000 I=1,N3MODE
42719       IF(RSPIN(IDK(ID3PRT(I))).EQ.ZERO) THEN
42720         RHOIN(1,1) = ONE
42721         RHOIN(1,2) = ZERO
42722         RHOIN(2,1) = ZERO
42723         RHOIN(2,2) = ZERO
42724       ELSE
42725         RHOIN(1,1) = HALF
42726         RHOIN(1,2) = ZERO
42727         RHOIN(2,1) = ZERO
42728         RHOIN(2,2) = HALF
42729       ENDIF
42730       PHEP(5,1) = RMASS(IDK(ID3PRT(I)))
42731       PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
42732       PHEP(1,1) = 100.0D0
42733       PHEP(2,1) = 0.0D0
42734       PHEP(3,1) = 0.0D0
42735       IF(IPRINT.EQ.2) WRITE(6,5000) RNAME(IDK(ID3PRT(I))),
42736      &   RNAME(IDKPRD(1,ID3PRT(I))),RNAME(IDKPRD(2,ID3PRT(I))),
42737      &   RNAME(IDKPRD(3,ID3PRT(I)))
42738  3000 CALL HWD3ME(1,0,I,RHOIN,1)
42739       IF(.NOT.SUSYIN) RETURN
42740 C--and for the two body gauge boson modes
42741       DO 4000 I=1,NBMODE
42742       IF(RSPIN(IDK(IDBPRT(I))).EQ.ZERO) THEN
42743         RHOIN(1,1) = ONE
42744         RHOIN(1,2) = ZERO
42745         RHOIN(2,1) = ZERO
42746         RHOIN(2,2) = ZERO
42747       ELSE
42748         RHOIN(1,1) = HALF
42749         RHOIN(1,2) = ZERO
42750         RHOIN(2,1) = ZERO
42751         RHOIN(2,2) = HALF
42752       ENDIF
42753       PHEP(5,1) = RMASS(IDK(IDBPRT(I)))
42754       PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
42755       PHEP(1,1) = 100.0D0
42756       PHEP(2,1) = 0.0D0
42757       PHEP(3,1) = 0.0D0
42758       IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(IDBPRT(I))),
42759      & RNAME(IDKPRD(1,IDBPRT(I))),RNAME(IDKPRD(2,IDBPRT(I)))
42760       IL = 12
42761       IF(IBMODE(I).NE.200) IL = 6
42762       DO 4000 J=1,IL
42763  4000 CALL HWD3ME(1,J,I,RHOIN,1)
42764       RETURN
42765  5000 FORMAT(/'CALCULATING THREE BODY DECAY ',
42766      &     A8,' --> ',A8,' ',A8,' ',A8/)
42767  5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
42768      &     A8,' --> ',A8,' ',A8/)
42769  999  END
42770 CDECK  ID>, HWISP4.
42771 *CMZ :-        -12/10/01  12.04.54  by  Peter Richardson
42772 *-- Author :    Peter Richardson
42773 C-----------------------------------------------------------------------
42774       SUBROUTINE HWISP4
42775 C-----------------------------------------------------------------------
42776 C     Initialise the Higgs four body modes
42777 C-----------------------------------------------------------------------
42778       INCLUDE 'HERWIG65.INC'
42779       INTEGER I,J,K,IL,IH,II,JJ
42780       DOUBLE PRECISION COL(2),SW,CW,TW,E,G,RT,ORT,MW,MZ,AFN(2,12,2,4),
42781      &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
42782      &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
42783      &     HZZ(2),ZAB(12,2,2),HHB(2,3),GS
42784       COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
42785      &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
42786       IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
42787 C--four body Higgs modes via virtual WW and ZZ
42788       DO 1000 JJ=1,NRES
42789       DO 1000 II=1,NMODES(JJ)
42790         IF(II.EQ.1) THEN
42791           I = LSTRT(JJ)
42792         ELSE
42793           I = LNEXT(I)
42794         ENDIF
42795         IH=IDK(I)-202
42796         IF((IH.EQ.1.OR.IH.EQ.2).AND.IDKPRD(3,I).EQ.0.AND.
42797      &       IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
42798      &       IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
42799 C--first the WW modes
42800           IF(IDKPRD(1,I).NE.200) THEN
42801             N4MODE = N4MODE+1
42802             IF(N4MODE.GT.NMODE4) CALL HWWARN('HWISP4',100,*999)
42803             NME(I) = 40000+N4MODE
42804             ID4PRT(N4MODE) = I
42805             I4MODE(1,N4MODE) = 198
42806             I4MODE(2,N4MODE) = 199
42807             DO 1 K=1,6
42808             A4MODE(1,K,N4MODE) = ZERO
42809             A4MODE(2,K,N4MODE) =-G*ORT
42810             B4MODE(1,K,N4MODE) = ZERO
42811  1          B4MODE(2,K,N4MODE) =-G*ORT
42812 C--now the prefactors
42813             DO 2 J=1,6
42814             COL(1) = HWW(IH)**2
42815             IF(J.LE.3) COL(1) = THREE*COL(1)
42816             DO 2 K=1,6
42817             COL(2) = ONE
42818             IF(K.LE.3) COL(2) = THREE*COL(2)
42819  2          P4MODE(J,K,N4MODE) = COL(1)*COL(2)
42820 C--then the ZZ modes
42821           ELSE
42822             N4MODE = N4MODE+1
42823             IF(N4MODE.GT.NMODE4) CALL HWWARN('HWISP4',101,*999)
42824             NME(I) = 40000+N4MODE
42825             ID4PRT(N4MODE) = I
42826             I4MODE(1,N4MODE) = 200
42827             I4MODE(2,N4MODE) = 200
42828             DO 3 K=1,12
42829             IL = K
42830             IF(K.GT.6) IL=K+4
42831             A4MODE(1,K,N4MODE) =-E*RFCH(IL)
42832             A4MODE(2,K,N4MODE) =-E*LFCH(IL)
42833             B4MODE(1,K,N4MODE) =-E*RFCH(IL)
42834  3          B4MODE(2,K,N4MODE) =-E*LFCH(IL)
42835             DO 4 J=1,12
42836             COL(1) = HALF*HZZ(IH)**2
42837             IF(J.LE.6) COL(1)=THREE*COL(1)
42838             DO 4 K=1,12
42839             COL(2) = ONE
42840             IF(K.LE.6) COL(2) = THREE
42841  4          P4MODE(J,K,N4MODE) = COL(1)*COL(2)
42842           ENDIF
42843         ENDIF
42844  1000 CONTINUE
42845 C--compute the maximum weights
42846       IF(N4MODE.EQ.0) RETURN
42847       DO 2000 I=1,N4MODE
42848       PHEP(5,1) = RMASS(IDK(ID4PRT(I)))
42849       PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
42850       PHEP(1,1) = 100.0D0
42851       PHEP(2,1) = 0.0D0
42852       PHEP(3,1) = 0.0D0
42853       IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(ID4PRT(I))),
42854      &            RNAME(IDKPRD(1,ID4PRT(I))),RNAME(IDKPRD(2,ID4PRT(I)))
42855       IL = 12
42856       IF(I4MODE(1,I).NE.200) IL = 6
42857       DO 2000 J=1,IL
42858       DO 2000 K=1,IL
42859  2000 CALL HWD4ME(1,J,K,I)
42860       RETURN
42861  5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
42862      &     A8,' --> ',A8,' ',A8/)
42863  999  END
42864 CDECK  ID>, HWISSP.
42865 *CMZ :-        -12/10/01  09:41:43  by  Peter Richardson
42866 *-- Author :    Bryan Webber, modified by Kosuke Odagiri
42867 C-----------------------------------------------------------------------
42868       SUBROUTINE HWISSP
42869 C-----------------------------------------------------------------------
42870 C  Reads in SUSY particle properties and decays,
42871 C  in format generated by ISAWIG
42872 C-----------------------------------------------------------------------
42873       INCLUDE 'HERWIG65.INC'
42874       INTEGER I,J,K,IH,IHW,NSSP,NDEC,MDKYS
42875       DOUBLE PRECISION BETAH, WEINCOS,WEINSIN, MW,MZ, RMMAX
42876       DOUBLE PRECISION FTM,FTMUU(4),FTMDD(4),FTMTT(4),FTMBB(4),FTMU,FTMD
42877       DOUBLE PRECISION YTM,YTM1,DTERM(4), SQHF,SNBCSB,MZSW2
42878       LOGICAL FIRST
42879       EQUIVALENCE (MW,RMASS(198)), (MZ,RMASS(200))
42880       DATA FIRST/.TRUE./
42881       SAVE MDKYS
42882       IF (FIRST) THEN
42883         MDKYS=NDKYS
42884         FIRST=.FALSE.
42885       ELSE
42886         NDKYS=MDKYS
42887       ENDIF
42888 C--reset susy input flag
42889       IF (LRSUSY.LT.0) CALL HWWARN('HWISSP',500,*999)
42890       SUSYIN = .TRUE.
42891 C
42892 C  Input SUSY particle + top quark table
42893 C
42894       WRITE (6,9)       '                           '
42895   9   FORMAT(//10X,A28//,
42896      &         10X,'Since SUSY processes are called,'
42897      & ,/,     10X,'please also reference: S.Moretti, K.Odagiri,'
42898      & ,/,     10X,'P.Richardson, M.H.Seymour & B.R.Webber,'
42899      & ,/,     10X,'JHEP 0204 (2002) 028')
42900       WRITE (6,10) LRSUSY
42901  10   FORMAT (/10X,'Reading in SUSY data from unit',I3)
42902       READ (LRSUSY,'(I4)') NSSP
42903       IF (NSSP.LE.0) RETURN
42904       RMMAX=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
42905       RMMNSS=RMMAX
42906       DO I=1,NSSP
42907         READ (LRSUSY,1) IHW,RMASS(IHW),RLTIM(IHW)
42908 C  Negative gaugino mass means physical field is gamma_5*psi
42909 C  Store the signs
42910         IF ((IHW.GE.450).AND.(IHW.LE.457)) THEN
42911           IF (IHW.LE.453) THEN
42912             J=IHW-449
42913             ZSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
42914           ELSEIF (IHW.LE.455) THEN
42915             J=IHW-453
42916             WSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
42917           ENDIF
42918           RMASS(IHW)=ABS(RMASS(IHW))
42919         ENDIF
42920         IF (ABS(IDPDG(IHW)).GT.1000000.AND.(RMASS(IHW).NE.ZERO))
42921      &    RMMNSS=MIN(RMMNSS,RMASS(IHW))
42922         IF (IHW.GT.NRES) THEN
42923           IF (IHW.GT.NMXRES) CALL HWWARN('HWISSP',501,*999)
42924           NRES=IHW
42925         ENDIF
42926       ENDDO
42927       XLMNSS=TWO*LOG(RMMNSS/RMMAX)
42928     1 FORMAT(I5,F12.4,E15.5)
42929 C
42930 C  Input decay modes
42931 C
42932       NDECSY = NDKYS+1
42933       DO I=1,NSSP
42934         READ (LRSUSY,'(I4)') NDEC
42935         IF (NDEC.GT.0) THEN
42936           DO J=1,NDEC
42937             NDKYS=NDKYS+1
42938             IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWISSP',100,*999)
42939             READ (LRSUSY,11) IDK(NDKYS),BRFRAC(NDKYS),NME(NDKYS),
42940      &      (IDKPRD(K,NDKYS),K=1,5)
42941    11       FORMAT(I6,F16.8,6I6)
42942           ENDDO
42943         ENDIF
42944       ENDDO
42945 C
42946 C  Mixings and other SUSY parameters
42947 C
42948       READ (LRSUSY,'(2F16.8)') TANB,ALPHAH
42949       DO I=1,4
42950         READ (LRSUSY,13) ZMXNSS(I,1),ZMXNSS(I,2),ZMXNSS(I,3),ZMXNSS(I,4)
42951       END DO
42952       WEINSIN = SQRT(SWEIN)
42953       WEINCOS = SQRT(1.-SWEIN)
42954       DO I=1,4
42955         ZMIXSS(I,1) =  WEINCOS*ZMXNSS(I,1)+WEINSIN*ZMXNSS(I,2)
42956         ZMIXSS(I,2) = -WEINSIN*ZMXNSS(I,1)+WEINCOS*ZMXNSS(I,2)
42957         ZMIXSS(I,3) =  ZMXNSS(I,3)
42958         ZMIXSS(I,4) =  ZMXNSS(I,4)
42959       END DO
42960       DO J=1,16
42961         IF ((J.LE.6).OR.(J.GE.11)) THEN
42962 C--left and right couplings now computed in HWIGIN
42963           DO I=1,4
42964             SLFCH(J,I)= ZMIXSS(I,1)*QFCH(J)+ZMIXSS(I,2)*LFCH(J)
42965             SRFCH(J,I)=-ZMIXSS(I,1)*QFCH(J)-ZMIXSS(I,2)*RFCH(J)
42966           END DO
42967         ENDIF
42968       END DO
42969       READ (LRSUSY,13) WMXVSS(1,1),WMXVSS(1,2), WMXVSS(2,1),WMXVSS(2,2)
42970       READ (LRSUSY,13) WMXUSS(1,1),WMXUSS(1,2), WMXUSS(2,1),WMXUSS(2,2)
42971       READ (LRSUSY,'(3F16.8)') THETAT,THETAB,THETAL
42972       READ (LRSUSY,'(3F16.8)') ATSS,ABSS,ALSS
42973       READ (LRSUSY,'( F16.8)') MUSS
42974       DO I=1,6
42975         QMIXSS(I,1,1)=1.
42976         QMIXSS(I,1,2)=0.
42977         QMIXSS(I,2,1)=0.
42978         QMIXSS(I,2,2)=1.
42979         LMIXSS(I,1,1)=1.
42980         LMIXSS(I,1,2)=0.
42981         LMIXSS(I,2,1)=0.
42982         LMIXSS(I,2,2)=1.
42983       END DO
42984       QMIXSS(6,1,1)= COS(THETAT)
42985       QMIXSS(6,1,2)= SIN(THETAT)
42986       QMIXSS(6,2,1)=-QMIXSS(6,1,2)
42987       QMIXSS(6,2,2)= QMIXSS(6,1,1)
42988       QMIXSS(5,1,1)= COS(THETAB)
42989       QMIXSS(5,1,2)= SIN(THETAB)
42990       QMIXSS(5,2,1)=-QMIXSS(5,1,2)
42991       QMIXSS(5,2,2)= QMIXSS(5,1,1)
42992       LMIXSS(5,1,1)= COS(THETAL)
42993       LMIXSS(5,1,2)= SIN(THETAL)
42994       LMIXSS(5,2,1)=-LMIXSS(5,1,2)
42995       LMIXSS(5,2,2)= LMIXSS(5,1,1)
42996 C--Evaluating Higgs parameters and couplings
42997       BETAH=ATAN(TANB)
42998       COTB=ONE/TANB
42999       COSBPA=COS(BETAH+ALPHAH)
43000       SINBPA=SIN(BETAH+ALPHAH)
43001       COSBMA=COS(BETAH-ALPHAH)
43002       SINBMA=SIN(BETAH-ALPHAH)
43003       COSA=COS(ALPHAH)
43004       SINA=SIN(ALPHAH)
43005       COSB=COS(BETAH)
43006       SINB=SIN(BETAH)
43007       GHWWSS(1)=SINBMA
43008       GHWWSS(2)=COSBMA
43009       GHWWSS(3)=ZERO
43010       DO 30 I=1,3
43011         GHZZSS(I)=GHWWSS(I)
43012  30   CONTINUE
43013       GHDDSS(1)=-SINA/COSB
43014       GHDDSS(2)= COSA/COSB
43015       GHDDSS(3)= TANB
43016       GHUUSS(1)= COSA/SINB
43017       GHUUSS(2)= SINA/SINB
43018       GHUUSS(3)= COTB
43019       GHWHSS(1)= COSBMA
43020       GHWHSS(2)= SINBMA
43021       GHWHSS(3)= ONE
43022       MZSW2    = MZ**2 * SQRT(SWEIN*(ONE-SWEIN))
43023       DTERM(1) =-SINBPA*MZSW2
43024       DTERM(2) = COSBPA*MZSW2
43025       DTERM(3) = ZERO
43026       FTMUU(1) = MUSS*SINA/SINB
43027       FTMUU(2) =-MUSS*COSA/SINB
43028       FTMUU(3) =-MUSS
43029       FTMUU(4) =-MUSS
43030       FTMTT(1) = ATSS*COSA/SINB
43031       FTMTT(2) = ATSS*SINA/SINB
43032       FTMTT(3) =-ATSS*COTB
43033       FTMTT(4) =-ATSS*COTB
43034       FTMDD(1) =-MUSS*COSA/COSB
43035       FTMDD(2) =-MUSS*SINA/COSB
43036       FTMDD(3) =-MUSS
43037       FTMDD(4) =-MUSS
43038       FTMBB(1) =-ABSS*SINA/COSB
43039       FTMBB(2) = ABSS*COSA/COSB
43040       FTMBB(3) =-ABSS*TANB
43041       FTMBB(4) =-ABSS*TANB
43042       DO 40 IH=1,4
43043         FTMU=FTMUU(IH)
43044         FTMD=FTMDD(IH)
43045         DO 50 I=1,6
43046           IF (I.EQ.5) FTMU=FTMU+FTMTT(IH)
43047           IF (I.EQ.5) FTMD=FTMD+FTMBB(IH)
43048           IF (MOD(I,2).EQ.0) THEN
43049            YTM = GHUUSS(IH)
43050            FTM = FTMU
43051           ELSE
43052            YTM = GHDDSS(IH)
43053            FTM = FTMD
43054           END IF
43055           IF (IH.EQ.3) THEN
43056            GHSQSS(IH,I,1,1) = ZERO
43057            GHSQSS(IH,I,2,2) = ZERO
43058            GHSQSS(IH,I,1,2) = FTM*HALF*RMASS(I)/MW
43059            GHSQSS(IH,I,2,1) = - GHSQSS(IH,I,1,2)
43060            GOTO 50
43061           ELSEIF (IH.EQ.4) THEN
43062            SQHF=SQRT(HALF)
43063            SNBCSB=SINB*COSB
43064            DO 60 J=1,2
43065             DO 70 K=1,2
43066              IF (MOD(I,2).EQ.1) THEN
43067               GHSQSS(IH,I,J,K)=SQHF*(
43068      &          RMASS(I  )*FTMD*QMIXSS(I,2,J)*QMIXSS(I+1,1,K)
43069      &         +RMASS(I+1)*FTMU*QMIXSS(I,1,J)*QMIXSS(I+1,2,K)
43070      &         +( MW**2*TWO*SNBCSB-RMASS(I+1)**2*COTB
43071      &           -RMASS(I  )**2*TANB )*QMIXSS(I,1,J)*QMIXSS(I+1,1,K)
43072      &         -RMASS(I)*RMASS(I+1)/SNBCSB
43073      &          *QMIXSS(I,2,J)*QMIXSS(I+1,2,K) ) / MW
43074              ELSE
43075               GHSQSS(IH,I,J,K)=GHSQSS(IH,I-1,K,J)
43076              END IF
43077  70         END DO
43078  60        END DO
43079           ELSE
43080            DO 80 J=1,2
43081             DO 90 K=1,2
43082              YTM1=ZERO
43083              IF (J.EQ.K) YTM1=YTM*RMASS(I)**2
43084              GHSQSS(IH,I,J,K)=( YTM1
43085      &        +( LFCH(I)*QMIXSS(I,1,J)*QMIXSS(I,1,K)
43086      &          -RFCH(I)*QMIXSS(I,2,J)*QMIXSS(I,2,K) )*DTERM(IH)
43087      &        +FTM*HALF*RMASS(I)*(QMIXSS(I,1,J)*QMIXSS(I,2,K)
43088      &                           +QMIXSS(I,2,J)*QMIXSS(I,1,K)) ) / MW
43089  90         CONTINUE
43090  80        CONTINUE
43091           END IF
43092  50     CONTINUE
43093  40   CONTINUE
43094 C--Rparity violation
43095       READ (LRSUSY,'(L5)') RPARTY
43096       IF(.NOT.RPARTY) THEN
43097         READ(LRSUSY,20) (((LAMDA1(I,J,K),K=1,3),J=1,3),I=1,3)
43098         READ(LRSUSY,20) (((LAMDA2(I,J,K),K=1,3),J=1,3),I=1,3)
43099         READ(LRSUSY,20) (((LAMDA3(I,J,K),K=1,3),J=1,3),I=1,3)
43100       ENDIF
43101  13   FORMAT(4F16.8)
43102  20   FORMAT(27E16.8)
43103       CLOSE(LRSUSY)
43104       IF(FOURB) CALL HWIMDE
43105   999 END
43106 CDECK  ID>, HWMEVT.
43107 *CMZ :-        -04/05/99  14.28.59  by  Bryan Webber
43108 *-- Author :    Bryan Webber
43109 C-----------------------------------------------------------------------
43110       SUBROUTINE HWMEVT
43111 C-----------------------------------------------------------------------
43112 C     IPROC = 1000,... ADDS SOFT UNDERLYING EVENT
43113 C           = 8000:  CREATES MINIMUM-BIAS EVENT
43114 C     SUPPRESSED BY ADDING 10000 TO IPROC
43115 C-----------------------------------------------------------------------
43116       INCLUDE 'HERWIG65.INC'
43117       DOUBLE PRECISION HWREXP,ENFAC,TECM,SECM,SUMM,EMCL,BMP(5),BMR(3,3)
43118       INTEGER HWRINT,NETC,IBT,IDBT,ID1,ID2,ID3,KHEP,LHEP,NTRY,ICMS,
43119      & NPPBAR,MCHT,JCL,JD1,JD2,JD3,ICH,MODC,NCHT,INHEP(2),
43120      & INID(2,2),JBT
43121 C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
43122 C--RMS CLUSTER COORDINATES (GAUSSIAN) AND C*LIFETIME (IN MM)
43123       DOUBLE PRECISION VCLX,VCLY,VCLZ,VCLT,HWRGAU,HWRGEN
43124       DATA VCLX,VCLY,VCLZ,VCLT/4*1D-12/
43125       EXTERNAL HWREXP,HWRINT,HWRGAU,HWRGEN
43126 C--END FIX
43127       IF (IERROR.NE.0) RETURN
43128       IF (.NOT.GENSOF) GOTO 990
43129       IF (IPROC.EQ.8000) THEN
43130 C---SET UP BEAM AND TARGET CLUSTERS
43131     5   NETC=0
43132         DO 10 IBT=1,2
43133         JBT=IBT
43134         IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
43135         IDBT=IDHW(JBT)
43136         IF (IDBT.EQ.73.OR.IDBT.EQ.75) THEN
43137           INID(1,IBT)=HWRINT(1,2)
43138           INID(2,IBT)=110
43139         ELSEIF (IDBT.EQ.91.OR.IDBT.EQ.93) THEN
43140           INID(1,IBT)=116
43141           INID(2,IBT)=HWRINT(7,8)
43142         ELSEIF (IDBT.EQ.30) THEN
43143           INID(1,IBT)=HWRINT(1,2)
43144           INID(2,IBT)=8
43145         ELSEIF (IDBT.EQ.38) THEN
43146           INID(1,IBT)=2
43147           INID(2,IBT)=HWRINT(7,8)
43148         ELSEIF (IDBT.EQ.34) THEN
43149           INID(1,IBT)=3
43150           INID(2,IBT)=HWRINT(7,8)
43151         ELSEIF (IDBT.EQ.46) THEN
43152           INID(1,IBT)=HWRINT(1,2)
43153           INID(2,IBT)=9
43154         ELSEIF (IDBT.EQ.59) THEN
43155           INID(1,IBT)=HWRINT(1,2)
43156           INID(2,IBT)=HWRINT(7,8)
43157         ELSE
43158           CALL HWWARN('HWMEVT',100,*999)
43159         ENDIF
43160         NETC=NETC+ICHRG(IDBT)
43161      &    -(ICHRG(INID(1,IBT))+ICHRG(INID(2,IBT)))/3
43162         ENFAC=1.
43163         IDHW(NHEP+IBT)=19
43164         IDHEP(NHEP+IBT)=91
43165         ISTHEP(NHEP+IBT)=163+IBT
43166         JMOHEP(1,NHEP+IBT)=JBT
43167    10   CONTINUE
43168         IF (NETC.EQ.0) THEN
43169           ID3=HWRINT(1,2)
43170         ELSEIF (NETC.EQ.-1) THEN
43171           ID3=1
43172         ELSEIF (NETC.EQ.1) THEN
43173           ID3=2
43174         ELSE
43175           GOTO 5
43176         ENDIF
43177         DO 12 IBT=1,2
43178         NHEP=NHEP+1
43179         JBT=IBT
43180         IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
43181         CALL HWVEQU(5,PHEP(1,JBT),PHEP(1,NHEP))
43182    12   INHEP(IBT)=NHEP
43183       ELSE
43184 C---FIND BEAM AND TARGET CLUSTERS
43185         DO 20 IBT=1,2
43186         DO 15 KHEP=1,NHEP
43187         IF (ISTHEP(KHEP).EQ.163+IBT) THEN
43188           INHEP(IBT)=KHEP
43189           INID(1,IBT)=IDHW(JMOHEP(1,KHEP))
43190           INID(2,IBT)=IDHW(JMOHEP(2,KHEP))
43191           GOTO 20
43192         ENDIF
43193    15   CONTINUE
43194 C---COULDN'T FIND ONE
43195         INHEP(IBT)=0
43196    20   CONTINUE
43197         JCL=-1
43198 C---TEST FOR BOTH FOUND
43199         IF (INHEP(1).EQ.0) JCL=INHEP(2)
43200         IF (INHEP(2).EQ.0) JCL=INHEP(1)
43201         IF (JCL.EQ.0) CALL HWWARN('HWMEVT',101,*999)
43202         IF (JCL.GT.0) THEN
43203           ISTHEP(JCL)=163
43204           CALL HWCFOR
43205           CALL HWCDEC
43206           CALL HWDHAD
43207           CALL HWDHVY
43208           GOTO 90
43209         ENDIF
43210         ID3=HWRINT(1,2)
43211         ENFAC=ENSOF
43212         NETC=0
43213       ENDIF
43214 C---FIND SOFT CM MOMENTUM AND MULTIPLICITY
43215       NTRY=0
43216       NHEP=NHEP+1
43217       IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',102,*999)
43218       ICMS=NHEP
43219       IDHW(NHEP)=16
43220       IDHEP(NHEP)=0
43221 C--Bug Fix 31/03/00 PR
43222       JMOHEP(1,ICMS)=INHEP(1)
43223       JMOHEP(2,ICMS)=INHEP(2)
43224 C--End of Fix
43225       ISTHEP(NHEP)=170
43226       CALL HWVSUM(4,PHEP(1,INHEP(1)),PHEP(1,INHEP(2)),PHEP(1,NHEP))
43227       CALL HWUMAS(PHEP(1,NHEP))
43228       TECM=PHEP(5,NHEP)
43229       IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN
43230         SECM=TECM*ENFAC
43231       ELSE
43232         SECM=PHEP(5,3)*ENFAC
43233       ENDIF
43234 C---CHOOSE MULTIPLICITY
43235    25 CALL HWMULT(SECM,NPPBAR)
43236    30 NCL=0
43237       MCHT=0
43238       IERROR=0
43239       NHEP =ICMS
43240       SUMM=0.
43241       NTRY=NTRY+1
43242 C---CREATE CLUSTERS
43243    35 NCL=NCL+1
43244       NHEP=NHEP+1
43245       IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',103,*999)
43246       JCL=NHEP
43247       IDHW(JCL)=19
43248       IDHEP(JCL)=91
43249       IF (NCL.LT.3) THEN
43250         ISTHEP(JCL)=170+NCL
43251         ID1=INID(1,NCL)
43252         ID2=INID(2,NCL)
43253       ELSE
43254         ID1=ID2-6
43255         IF (NCL.EQ.3) ID1=ID3
43256         ID2=HWRINT(7,8)
43257         ISTHEP(JCL)=173
43258       ENDIF
43259       JMOHEP(1,JCL)=ICMS
43260       JMOHEP(2,JCL)=0
43261       CALL HWVZRO(3,PHEP(1,JCL))
43262       PHEP(4,JCL)=RMASS(ID1)+RMASS(ID2)+PMBM1+HWREXP(TWO/PMBM2)
43263       PHEP(5,JCL)=PHEP(4,JCL)
43264 C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
43265 C--VERTEX POSITION FOR CLUSTER FORMATION
43266       VHEP(1,JCL)=HWRGAU(1,ZERO,VCLX)
43267       VHEP(2,JCL)=HWRGAU(2,ZERO,VCLY)
43268       VHEP(3,JCL)=HWRGAU(3,ZERO,VCLZ)
43269       VHEP(4,JCL)=SQRT(VHEP(1,JCL)**2+VHEP(2,JCL)**2+VHEP(3,JCL)**2)
43270      &            -VCLT*LOG(HWRGEN(0))
43271 C--MHS FIX 07/03/05 - MEASURE DISPLACEMENTS RELATIVE TO SOFT CM
43272       CALL HWVZRO(4,VTXPIP)
43273 C--END FIXES
43274 C---HADRONIZE AND DECAY CLUSTERS
43275       CALL HWCFLA(ID1,ID2,JD1,JD2)
43276       CALL HWCHAD(JCL,JD1,JD2,JD3)
43277       IF (IERROR.NE.0) RETURN
43278       IF (JD3.EQ.0) THEN
43279         EMCL=RMASS(IDHW(NHEP))
43280         IF (PHEP(4,JCL).NE.EMCL) THEN
43281           PHEP(4,JCL)=EMCL
43282           PHEP(5,JCL)=EMCL
43283           PHEP(4,NHEP)=EMCL
43284           PHEP(5,NHEP)=EMCL
43285         ENDIF
43286       ELSE
43287         EMCL=PHEP(5,JCL)
43288       ENDIF
43289       IDCL(NCL)=JD3
43290       PPCL(5,NCL)=EMCL
43291       SUMM=SUMM +EMCL
43292       CALL HWDHAD
43293       CALL HWDHVY
43294       IF (IERROR.NE.0) RETURN
43295 C---CHECK CHARGED MULTIPLICITY
43296       MODC=0
43297       DO 50 KHEP=JCL,NHEP
43298       IF (ISTHEP(KHEP).EQ.1) THEN
43299          ICH=ICHRG(IDHW(KHEP))
43300          IF (ICH.NE.0) THEN
43301             MCHT=MCHT+ABS(ICH)
43302             MODC=MODC+ICH
43303          ENDIF
43304       ENDIF
43305    50 CONTINUE
43306       IF (NCL.EQ.1) THEN
43307          NCHT=NPPBAR+NETC+ABS(MODC)
43308          GOTO 35
43309       ELSEIF (NCL.EQ.2) THEN
43310          NCHT=NCHT+ABS(MODC)
43311          IF (NCHT.LT.0) NCHT=NCHT+2
43312       ENDIF
43313       IF (MCHT.LT.NCHT) THEN
43314         GOTO 35
43315       ELSEIF (MCHT.GT.NCHT) THEN
43316         IF (MOD(NTRY,50).EQ.0) GOTO 25
43317         IF (NTRY.LT.NSTRY) GOTO 30
43318 C---NO PHASE SPACE FOR SOFT EVENT
43319         NHEP=ICMS-1
43320         IF (IPROC.EQ.8000) THEN
43321 C---MINIMUM BIAS: RELABEL BEAM AND TARGET CLUSTERS
43322           DO 60 IBT=1,2
43323             KHEP=INHEP(IBT)
43324             LHEP=JMOHEP(1,KHEP)
43325             ISTHEP(KHEP)=1
43326             IDHEP(KHEP)=IDHEP(LHEP)
43327             IDHW(KHEP)=IDHW(LHEP)
43328    60     CONTINUE
43329         ELSE
43330 C---UNDERLYING EVENT: DECAY THEM
43331           ISTHEP(INHEP(1))=163
43332           ISTHEP(INHEP(2))=163
43333           CALL HWCFOR
43334           CALL HWCDEC
43335           CALL HWDHAD
43336           CALL HWDHVY
43337         ENDIF
43338         GOTO 90
43339       ENDIF
43340 C---GENERATE CLUSTER MOMENTA IN CLUSTER CM
43341 C   FRAME.   N.B. SECOND CLUSTER IS TARGET
43342       IF (SUMM.GT.TECM) GOTO 25
43343       CALL HWMLPS(TECM)
43344       IF (NCL.EQ.0) GOTO 25
43345       JCL=0
43346 C---ROTATE & BOOST CLUSTERS & DECAY PRODUCTS
43347       CALL HWULOF(PHEP(1,ICMS),PHEP(1,INHEP(1)),BMP)
43348       CALL HWUROT(BMP, ONE,ZERO,BMR)
43349 C---BMR PUTS BEAM ALONG Z AXIS (WE WANT INVERSE)
43350       DO 70 KHEP=ICMS+1,NHEP
43351       IF (ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
43352      $       .AND.JMOHEP(1,KHEP).EQ.ICMS) THEN
43353           ISTHEP(KHEP)=ISTHEP(KHEP)+3
43354           LHEP=KHEP
43355           JCL=JCL+1
43356           CALL HWUROB(BMR,PPCL(1,JCL),PPCL(1,JCL))
43357           CALL HWULOB(PHEP(1,ICMS),PPCL(1,JCL),PPCL(1,JCL))
43358 C---NOW PPCL(*,JCL) IS LAB MOMENTUM OF JTH CLUSTER
43359       ENDIF
43360       CALL HWULOB(PPCL(1,JCL),PHEP(1,KHEP),PHEP(1,KHEP))
43361 C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
43362       CALL HWULOB(PPCL(1,JCL),VHEP(1,KHEP),VHEP(1,KHEP))
43363 C--MHS FIX 07/03/05 - ASSUME THAT SOFT CM COINCIDES WITH PRIMARY IP
43364       IF (.NOT.(ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
43365      $       .AND.JMOHEP(1,KHEP).EQ.ICMS))
43366      $     CALL HWVSUM(4,VHEP(1,3),VHEP(1,KHEP),VHEP(1,KHEP))
43367 C--END FIXES
43368    70 CONTINUE
43369       ISTHEP(INHEP(1))=167
43370       ISTHEP(INHEP(2))=168
43371       JDAHEP(1,INHEP(1))=ICMS
43372       JDAHEP(2,INHEP(1))=0
43373       JDAHEP(1,INHEP(2))=ICMS
43374       JDAHEP(2,INHEP(2))=0
43375       JDAHEP(1,ICMS)=ICMS+1
43376       JDAHEP(2,ICMS)=LHEP
43377    90 CONTINUE
43378   990 ISTAT=100
43379   999 END
43380 CDECK  ID>, HWMLPS.
43381 *CMZ :-        -04/05/99  14.17.04  by  Bryan Webber
43382 *-- Author :    David Ward, modified by Bryan Webber
43383 C-----------------------------------------------------------------------
43384       SUBROUTINE HWMLPS(TECM)
43385 C-----------------------------------------------------------------------
43386 C     GENERATES CYLINDRICAL PHASE SPACE USING THE METHOD OF JADACH
43387 C     RETURNS WITH NCL=0 IF UNSUCCESSFUL
43388 C-----------------------------------------------------------------------
43389       INCLUDE 'HERWIG65.INC'
43390       DOUBLE PRECISION HWREXT,HWRUNG,HWUSQR,TECM,ESS,ALOGS,EPS,SUMX,
43391      & SUMY,PT,PX,PY,PT2,SUMPT2,SUMTM,XIMIN,XIMAX,YY,SUM1,SUM2,SUM3,
43392      & SUM4,EX,FY,DD,DYY,ZZ,E1,TM,SLOP,XI(NMXCL)
43393       INTEGER NTRY,I,NIT,IY(NMXCL),IDP
43394       EXTERNAL HWREXT,HWRUNG,HWUSQR
43395       IF (NCL.GT.NMXCL) THEN
43396         CALL HWWARN('HWMLPS',1,*999)
43397         NCL=NMXCL
43398       ENDIF
43399       ESS=TECM**2
43400       ALOGS=LOG(ESS)
43401       EPS=1D-10/NCL
43402       NTRY=0
43403   11  NTRY=NTRY+1
43404       IF (NTRY.GT.NSTRY) THEN
43405         NCL=0
43406         RETURN
43407       ENDIF
43408       SUMX=0.
43409       SUMY=0.
43410       DO 12 I=1,NCL
43411 C---Pt distribution of form exp(-b*Mt)
43412 C---Factors for pt slopes to fit data.  IDCL contains the type of
43413 C   q-qbar pair produced in this cluster (0 if 1-particle cluster).
43414       IDP=IDCL(I)
43415       IF (IDP.LE.2) THEN
43416         SLOP=PMBP1
43417       ELSEIF(IDP.EQ.3.OR.IDP.EQ.10) THEN
43418         SLOP=PMBP2
43419       ELSEIF(IDP.GT.3.AND.IDP.LE.9) THEN
43420         SLOP=PMBP3
43421       ELSE
43422         CALL HWWARN('HWMLPS',IDP,*999)
43423         SLOP=PMBP2
43424       ENDIF
43425       PT=HWREXT(PPCL(5,I),SLOP)
43426       PT=HWUSQR(PT**2-PPCL(5,I)**2)
43427       CALL HWRAZM(PT,PX,PY)
43428       PPCL(1,I)=PX
43429       PPCL(2,I)=PY
43430       SUMX=SUMX+PPCL(1,I)
43431   12  SUMY=SUMY+PPCL(2,I)
43432       SUMX=SUMX/NCL
43433       SUMY=SUMY/NCL
43434       SUMPT2=0.
43435       SUMTM=0.
43436       DO 13 I=1,NCL
43437       PPCL(1,I)=PPCL(1,I)-SUMX
43438       PPCL(2,I)=PPCL(2,I)-SUMY
43439       PT2=PPCL(1,I)**2+PPCL(2,I)**2
43440       SUMPT2=SUMPT2+PT2
43441 C---STORE TRANSVERSE MASS IN PPCL(3,I) TEMPORARILY
43442       PPCL(3,I)=SQRT(PT2+PPCL(5,I)**2)
43443   13  SUMTM=SUMTM+PPCL(3,I)
43444       IF (SUMTM.GT.TECM) GOTO 11
43445       DO 14 I=1,NCL
43446 C---Form of "reduced rapidity" distribution
43447       XI(I)=HWRUNG(0.6*ONE,ONE)
43448   14  CONTINUE
43449       CALL HWUSOR(XI,NCL,IY,1)
43450       XIMIN=XI(1)
43451       XIMAX=XI(NCL)-XI(1)
43452 C---N.B. TARGET CLUSTER IS SECOND
43453       XI(1)=0.
43454       DO 16 I=NCL-1,2,-1
43455       XI(I+1)=(XI(I)-XIMIN)/XIMAX
43456   16  CONTINUE
43457       XI(2)=1.
43458       YY=LOG(ESS/(PPCL(3,1)*PPCL(3,2)))
43459       DO 18 NIT=1,10
43460       SUM1=0.
43461       SUM2=0.
43462       SUM3=0.
43463       SUM4=0.
43464       DO 19 I=1,NCL
43465       TM=PPCL(3,I)
43466       EX=EXP(YY*XI(I))
43467       SUM1=SUM1+(TM*EX)
43468       SUM2=SUM2+(TM/EX)
43469       SUM3=SUM3+(TM*EX)*XI(I)
43470   19  SUM4=SUM4+(TM/EX)*XI(I)
43471       FY=ALOGS-LOG(SUM1*SUM2)
43472       DD=(SUM3*SUM2-SUM1*SUM4)/(SUM1*SUM2)
43473       DYY=FY/DD
43474       IF(ABS(DYY/YY).LT.EPS) GOTO 20
43475   18  YY=YY+DYY
43476 C---Y ITERATIONS EXCEEDED - TRY AGAIN
43477       IF (NTRY.LT.100) GOTO 11
43478       EPS=10.*EPS
43479       IF (EPS.GT.ONE) CALL HWWARN('HWMLPS',100,*999)
43480       CALL HWWARN('HWMLPS',50,*11)
43481    20 YY=YY+DYY
43482       ZZ=LOG(TECM/SUM1)
43483       DO 22 I=1,NCL
43484       TM=PPCL(3,I)
43485       E1=EXP(ZZ+YY*XI(I))
43486       PPCL(3,I)=(0.5*TM)*((1./E1)-E1)
43487       PPCL(4,I)=(0.5*TM)*((1./E1)+E1)
43488   22  CONTINUE
43489  999  END
43490 CDECK  ID>, HWMNBI.
43491 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
43492 *-- Author :    David Ward, modified by Bryan Webber
43493 C-----------------------------------------------------------------------
43494       FUNCTION HWMNBI(N,AVNCH,EK)
43495 C-----------------------------------------------------------------------
43496 C---Computes negative binomial probability
43497 C-----------------------------------------------------------------------
43498       DOUBLE PRECISION HWMNBI,AVNCH,EK,R
43499       INTEGER N,I
43500       IF(N.LE.0) THEN
43501        HWMNBI=0
43502       ELSE
43503        R=AVNCH/EK
43504        HWMNBI=(1.+R)**(-EK)
43505        R=R/(1.+R)
43506        DO 1 I=1,N
43507        HWMNBI=HWMNBI*R*(EK+I-1)/I
43508     1  CONTINUE
43509       ENDIF
43510       END
43511 CDECK  ID>, HWMODK.
43512 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
43513 *-- Author :    Ian Knowles
43514 C-----------------------------------------------------------------------
43515       SUBROUTINE HWMODK(IDKTMP,BRTMP,IMETMP,
43516      & IATMP,IBTMP,ICTMP,IDTMP,IETMP)
43517 C-----------------------------------------------------------------------
43518 C     Takes the decay, IDKTMP -> I-(A+B+C+D+E)-TMP, and simply stores it
43519 C     if internal pointers not set up (.NOT.DKPSET) else if pre-existing
43520 C     mode updates branching ratio BRTMP and matrix element code IMETMP,
43521 C     if -ve leaves as is. If a new mode adds to table and if consistent
43522 C     adjusts pointers,  sets CMMOM (for two-body mode) and resets RSTAB
43523 C     if necessary.  The branching ratios of any other IDKTMP decays are
43524 C     scaled by (1.-BRTMP)/(1.-BR_OLD)
43525 C-----------------------------------------------------------------------
43526       INCLUDE 'HERWIG65.INC'
43527       DOUBLE PRECISION HWUPCM,BRTMP,SCALE,EPS
43528       INTEGER IDKTMP,IMETMP,IATMP,IBTMP,ICTMP,IDTMP,IETMP,IDKY,ITMP(5),
43529      & L,I,J,K,JPREV
43530       LOGICAL MATCH(5)
43531       CHARACTER*8 CDUM
43532       EXTERNAL HWUPCM
43533       PARAMETER (EPS=1.D-6)
43534 C Convert to internal format
43535       CALL HWUIDT(1,IDKTMP,IDKY,CDUM)
43536       IF (IDKY.EQ.20) THEN
43537         WRITE(6,10) IDKTMP
43538   10    FORMAT(1X,'Particle decaying,',I7,', is not recognised')
43539         RETURN
43540       ENDIF
43541       CALL HWUIDT(1,IATMP,ITMP(1),CDUM)
43542       CALL HWUIDT(1,IBTMP,ITMP(2),CDUM)
43543       CALL HWUIDT(1,ICTMP,ITMP(3),CDUM)
43544       CALL HWUIDT(1,IDTMP,ITMP(4),CDUM)
43545       CALL HWUIDT(1,IETMP,ITMP(5),CDUM)
43546 C If internal pointers not yet set up simply store decay
43547       IF (.NOT.DKPSET) THEN
43548         NDKYS=NDKYS+1
43549         IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWMODK',100,*999)
43550         IDK(NDKYS)=IDKY
43551         BRFRAC(NDKYS)=BRTMP
43552         NME(NDKYS)=IMETMP
43553         DO 20 I=1,5
43554   20    IDKPRD(I,NDKYS)=ITMP(I)
43555       ELSE
43556         IF (NMODES(IDKY).GT.0) THEN
43557 C First search to see if mode pre-exists
43558           IF ((ITMP(2).GE.1.AND.ITMP(2).LE.13).OR.
43559      &        (ITMP(3).GE.1.AND.ITMP(3).LE.13)) THEN
43560 C Partonic respect order
43561             L=LSTRT(IDKY)
43562             DO 30 K=1,NMODES(IDKY)
43563                 IF (ITMP(1).EQ.IDKPRD(1,L).AND.
43564      &              ITMP(2).EQ.IDKPRD(2,L).AND.
43565      &              ITMP(3).EQ.IDKPRD(3,L).AND.
43566      &              ITMP(4).EQ.IDKPRD(4,L).AND.
43567      &              ITMP(5).EQ.IDKPRD(5,L)) GOTO 90
43568   30        L=LNEXT(L)
43569           ELSE
43570 C Allow for different order in matching
43571             L=LSTRT(IDKY)
43572             DO 70 I=1,NMODES(IDKY)
43573             DO 40 J=1,5
43574   40        MATCH(J)=.FALSE.
43575             DO 60 J=1,5
43576             DO 50 K=1,5
43577             IF (.NOT.MATCH(K).AND.ITMP(K).EQ.IDKPRD(J,L)) THEN
43578               MATCH(K)=.TRUE.
43579               GOTO 60
43580             ENDIF
43581   50        CONTINUE
43582   60        CONTINUE
43583             IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
43584      &          MATCH(4).AND.MATCH(5)) GOTO 90
43585   70        L=LNEXT(L)
43586           ENDIF
43587         ENDIF
43588 C A new mode put decay products in table
43589         NDKYS=NDKYS+1
43590         IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWMODK',101,*999)
43591         DO 80 I=1,5
43592   80    IDKPRD(I,NDKYS)=ITMP(I)
43593 C If decay consistent set up new pointers
43594         CALL HWDCHK(IDKY,NDKYS,*980)
43595         IF (NMODES(IDKY).EQ.0) THEN
43596           LSTRT(IDKY)=NDKYS
43597           IF (RLTIM(IDKY).LT.PLTCUT.AND.RMASS(IDKY).NE.ZERO) THEN
43598             RSTAB(IDKY)=.FALSE.
43599             DKLTM(IDKY)=RLTIM(IDKY)*RMASS(IDKY)/HBAR
43600           ELSE
43601             RSTAB(IDKY)=.TRUE.
43602           ENDIF
43603         ELSE
43604           LNEXT(L)=NDKYS
43605         ENDIF
43606         NMODES(IDKY)=NMODES(IDKY)+1
43607         LNEXT(NDKYS)=NDKYS
43608         L=NDKYS
43609 C Set CMMOM if two body decay
43610         IF (NPRODS(L).EQ.2) CMMOM(L)=
43611      &   HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,L)),RMASS(IDKPRD(2,L)))
43612 C A Pre-existing mode, line L, add/update ME code and BR, scaling all
43613 C other branching fractions
43614   90    IF (IMETMP.GT.0) NME(L)=IMETMP
43615         IF (ABS(BRTMP-1.).LT.EPS) THEN
43616 C This modes dominant: eliminate others
43617           NMODES(IDKY)=1
43618           LSTRT(IDKY)=L
43619           BRFRAC(L)=ONE
43620           LNEXT(L)=L
43621         ELSEIF (ABS(BRTMP).LT.EPS) THEN
43622 C This mode insignificant: eliminate it
43623           IF (NMODES(IDKY).EQ.1) THEN
43624             RSTAB(IDKY)=.TRUE.
43625           ELSE
43626             J=LSTRT(IDKY)
43627             IF (J.EQ.L) THEN
43628               LSTRT(IDKY)=LNEXT(J)
43629             ELSE
43630               JPREV=J
43631               DO 100 I=2,NMODES(IDKY)
43632               J=LNEXT(J)
43633               IF (J.EQ.L) LNEXT(JPREV)=LNEXT(J)
43634   100         JPREV=J
43635             ENDIF
43636 C           Rescale other modes
43637             SCALE=ONE/(ONE-BRFRAC(L))
43638             J=LSTRT(IDKY)
43639             DO 110 I=1,NMODES(IDKY)-1
43640             BRFRAC(J)=SCALE*BRFRAC(J)
43641   110       J=LNEXT(J)
43642           ENDIF
43643           NMODES(IDKY)=NMODES(IDKY)-1
43644         ELSE
43645 C Rescale all other modes
43646           IF (NMODES(IDKY).EQ.1) THEN
43647             BRFRAC(L)=ONE
43648           ELSE
43649             IF (L.EQ.NDKYS) THEN
43650               SCALE=ONE-BRTMP
43651             ELSE
43652               SCALE=(ONE-BRTMP)/(ONE-BRFRAC(L))
43653             ENDIF
43654             J=LSTRT(IDKY)
43655             DO 120 I=1,NMODES(IDKY)
43656             IF (J.NE.L) BRFRAC(J)=SCALE*BRFRAC(J)
43657   120       J=LNEXT(J)
43658             BRFRAC(L)=BRTMP
43659           ENDIF
43660         ENDIF
43661       ENDIF
43662       GOTO 999
43663   980 WRITE(6,990)
43664   990 FORMAT(1X,'Decay mode inconsistent, no modifications made')
43665   999 RETURN
43666       END
43667 CDECK  ID>, HWMULT.
43668 *CMZ :-        -04/05/99  11.11.55  by  Bryan Webber
43669 *-- Author :    David Ward, modified by Bryan Webber
43670 C-----------------------------------------------------------------------
43671       SUBROUTINE HWMULT(EPPBAR,NCHT)
43672 C-----------------------------------------------------------------------
43673 C     Chooses charged multiplicity NCHT at the p-pbar c.m. energy EPPBAR
43674 C-----------------------------------------------------------------------
43675       INCLUDE 'HERWIG65.INC'
43676       DOUBLE PRECISION HWMNBI,HWRGEN,EPPBAR,E0,ALOGS,RK,EK,AVN,SUM,R,
43677      & CUM(500)
43678       INTEGER NCHT,IMAX,I,N
43679       SAVE E0,CUM,IMAX
43680       EXTERNAL HWMNBI,HWRGEN
43681       DATA E0/0/
43682       IF (EPPBAR.NE.E0) THEN
43683          E0=EPPBAR
43684 C---Initialize
43685          ALOGS=2.*LOG(EPPBAR)
43686          RK=PMBK1*ALOGS+PMBK2
43687          IF (ABS(RK).GT.1000.) RK=1000.
43688          EK=1./RK
43689          AVN=PMBN1*EXP(PMBN2*ALOGS)+PMBN3
43690          IF (AVN.LT.ONE) AVN=1.
43691          SUM=0.
43692          IMAX=1
43693          DO 10 I=1,500
43694          N=2*I
43695          CUM(I)=HWMNBI(N,AVN,EK)
43696          IF (CUM(I).LT.1D-7*SUM) GOTO 11
43697          IMAX=I
43698          SUM=SUM+CUM(I)
43699          CUM(I)=SUM
43700   10     CONTINUE
43701   11     CONTINUE
43702          IF (IMAX.LE.1) THEN
43703             IMAX=1
43704             CUM(1)=1
43705          ELSEIF (IMAX.EQ.500) THEN
43706             E0=0
43707             CALL HWWARN('HWMULT',101,*999)
43708          ELSE
43709             DO 12 I=1,IMAX
43710   12        CUM(I)=CUM(I)/SUM
43711          ENDIF
43712       ENDIF
43713 C --- Select NCHT
43714       R=HWRGEN(0)
43715       DO 20 I=1,IMAX
43716       IF(R.GT.CUM(I)) GOTO 20
43717       NCHT=2*I
43718       RETURN
43719   20  CONTINUE
43720       CALL HWWARN('HWMULT',100,*999)
43721   999 END
43722 CDECK  ID>, HWMWGT.
43723 *CMZ :-        -02/11/93  11.11.55  by  Bryan Webber
43724 *-- Author :    Bryan Webber
43725 C-----------------------------------------------------------------------
43726       SUBROUTINE HWMWGT
43727 C-----------------------------------------------------------------------
43728 C COMPUTES WEIGHT FOR MINIMUM-BIAS EVENT
43729 C-----------------------------------------------------------------------
43730       INCLUDE 'HERWIG65.INC'
43731       DOUBLE PRECISION S,X,Y
43732       INTEGER IDB,IDT,IDBT
43733       IF (IERROR.NE.0) RETURN
43734       IDB=IDHW(1)
43735       IF (JDAHEP(1,1).NE.0) IDB=IDHW(JDAHEP(1,1))
43736       IDT=IDHW(2)
43737       IF (JDAHEP(1,2).NE.0) IDT=IDHW(JDAHEP(1,2))
43738       IDBT=100*IDB+IDT
43739       IF (IDT.GT.IDB) IDBT=100*IDT+IDB
43740 C---USE TOTAL CROSS SECTION FITS OF DONNACHIE & LANDSHOFF
43741 C   CERN-TH.6635/92
43742       IF (IDBT.EQ.9173) THEN
43743         X=21.70
43744         Y=98.39
43745       ELSEIF (IDBT.EQ.7373) THEN
43746         X=21.70
43747         Y=56.08
43748       ELSEIF (IDBT.EQ.7330) THEN
43749         X=13.63
43750         Y=36.02
43751       ELSEIF (IDBT.EQ.7338) THEN
43752         X=13.63
43753         Y=27.56
43754       ELSEIF (IDBT.EQ.7334) THEN
43755         X=11.82
43756         Y=26.36
43757       ELSEIF (IDBT.EQ.7346) THEN
43758         X=11.82
43759         Y= 8.15
43760       ELSEIF (IDBT.EQ.7359) THEN
43761         X=.0677
43762         Y=.1290
43763       ELSEIF (IDBT.EQ.9175) THEN
43764         X=21.70
43765         Y=92.71
43766       ELSEIF (IDBT.EQ.7573) THEN
43767         X=21.70
43768         Y=54.77
43769       ELSEIF (IDBT.EQ.5959) THEN
43770 C---FOR GAMMA-GAMMA ASSUME X AND Y FACTORIZE
43771         X=2.1E-4
43772         Y=3.0E-4
43773       ELSE
43774         PRINT *,' IDBT=',IDBT
43775         CALL HWWARN('HWMWGT',100,*999)
43776       ENDIF
43777       S=PHEP(5,3)**2
43778 C---EVWGT IS NON-DIFFRACTIVE CROSS SECTION IN NANOBARNS
43779 C   ASSUMING NON-DIFFRACTIVE = TOTAL*0.7
43780       EVWGT=.7E6*(X*S**.0808 + Y*S**(-.4525))
43781   999 END
43782 CDECK  ID>, HWPHTP.
43783 *CMZ :-        -11/08/03  15:30:25  by  Peter Richardson
43784 *-- Author :    Peter Richardson and Zbigniew Was
43785 C-----------------------------------------------------------------------
43786       SUBROUTINE HWPHTP(IHEP)
43787 C-----------------------------------------------------------------------
43788 C     subroutine for radiation in top decays
43789 C-----------------------------------------------------------------------
43790       INCLUDE 'HERWIG65.INC'
43791       INTEGER IHEP,KK,IPOS,NN,NHEP0,KK1,KK2,JMOH(NMXHEP)
43792       DOUBLE PRECISION HWDPWT
43793       EXTERNAL HWDPWT
43794 C--add an extra photon for top or W
43795       IF(IERROR.NE.0) RETURN
43796       IF(ABS(IDHEP(IHEP)).EQ.6.OR.ABS(IDHEP(IHEP)).EQ.24) THEN
43797         NHEP0=NHEP
43798         KK1=JDAHEP(1,IHEP)
43799         KK2=JDAHEP(2,IHEP)
43800 C--copy the colour mother infomation
43801         DO KK=KK1,KK2
43802           JMOH(KK)=JMOHEP(2,KK)
43803           JMOHEP(2,KK)=0
43804         ENDDO
43805 C--call photos
43806         IPOS=-IHEP
43807         CALL PHOTOS(IPOS)
43808 C--reset the colour mother infomation
43809         DO KK=KK1,KK2
43810           JMOHEP(2,KK)=JMOH(KK)
43811         ENDDO
43812 C--update the decaying particle
43813         JDAHEP(2,IHEP) = NHEP
43814 C--set up the additions photons in the record
43815         NN=NHEP-NHEP0
43816         NHEP=NHEP0
43817         IF(NN.GT.0) THEN
43818           DO KK=1,NN
43819 C--photon mass probably not needed
43820             PHEP(5,NHEP+1) = ZERO
43821 C--info on the photon
43822             ISTHEP(NHEP+1) = 114
43823             IDHW(NHEP+1) = 59
43824             IDHEP(NHEP+1) = 22
43825             JMOHEP(1,NHEP+1) = IHEP
43826             JMOHEP(2,NHEP+1) = NHEP+1
43827             JDAHEP(2,NHEP+1) = NHEP+1
43828             NHEP = NHEP+1
43829           ENDDO
43830         ENDIF
43831       ENDIF
43832       END
43833 CDECK  ID>, HWPHTT.
43834 *CMZ :-        -11/08/03  15:30:25  by  Peter Richardson
43835 *-- Author :    Peter Richardson and Zbigniew Was
43836 C-----------------------------------------------------------------------
43837       SUBROUTINE HWPHTT
43838 C-----------------------------------------------------------------------
43839 C     subroutine for radiation in top production
43840 C-----------------------------------------------------------------------
43841       INCLUDE 'HERWIG65.INC'
43842 C--local variables
43843       INTEGER IMO(10),IFOUND,JMO(2),I,J,K,L,NSTART,NHEPX,NHEP0
43844 C--initialisation
43845       IF(IERROR.NE.0) RETURN
43846       IFOUND=0
43847       DO K=1,10
43848         IMO(K)=0
43849       ENDDO
43850 C--loop to find mothers of any tops
43851       NSTART=1
43852       DO I=NSTART,NHEP
43853         IF (ABS(IDHEP(I)).EQ.6) THEN
43854           DO K=1,IFOUND
43855            IF(IMO(K).EQ.JMOHEP(1,I)) GOTO 10
43856           ENDDO
43857           IFOUND=IFOUND+1
43858           IMO(IFOUND)=JMOHEP(1,I)
43859         ENDIF
43860  10     CONTINUE
43861       ENDDO
43862 C--generate the radiation
43863       DO K=1,IFOUND
43864 C--save the colour mother pointers
43865         JMO(1)=JMOHEP(2,JDAHEP(1,IMO(K)))
43866         JMO(2)=JMOHEP(2,1+JDAHEP(1,IMO(K)))
43867 C--zero the second mothers
43868         NHEP0=NHEP
43869         JMOHEP(2,JDAHEP(1,IMO(K)))=0
43870         JMOHEP(2,JDAHEP(2,IMO(K)))=0
43871 C--call photos to generate radiation
43872         CALL PHOTOS(IMO(K))
43873         NHEPX=NHEP
43874         DO 11 J=NHEP,1,-1
43875           IF(IDHEP(J).EQ.22) THEN
43876             NHEPX=NHEPX-1
43877           ELSE
43878             GOTO 11
43879           ENDIF
43880  11     CONTINUE
43881 C--reset the colour pointers
43882         JMOHEP(2,  JDAHEP(1,IMO(K)))=JMO(1)
43883         JMOHEP(2,1+JDAHEP(1,IMO(K)))=JMO(2)
43884 C--setup the photons
43885         DO L=NHEPX+1,NHEP
43886           ISTHEP(L)=114
43887           JMOHEP(2,L) = L
43888           JDAHEP(2,L) = L
43889           IDHW(L) = 59
43890         ENDDO
43891       ENDDO
43892       END
43893 CDECK  ID>, HWRAZM.
43894 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
43895 *-- Author :    Bryan Webber
43896 C-----------------------------------------------------------------------
43897       SUBROUTINE HWRAZM(PT,PX,PY)
43898 C-----------------------------------------------------------------------
43899 C     RANDOMLY ROTATED 2-VECTOR (PX,PY) OF LENGTH PT
43900 C-----------------------------------------------------------------------
43901       DOUBLE PRECISION HWRGEN,PT,PX,PY,C,S,CS,QT,ONE,ZERO
43902       PARAMETER(ONE=1.0D0, ZERO=0.0D0)
43903       EXTERNAL HWRGEN
43904    10 C=2.*HWRGEN(1)-1.
43905       S=2.*HWRGEN(2)-1.
43906       CS=C*C+S*S
43907       IF (CS.GT.ONE .OR. CS.EQ.ZERO) GOTO 10
43908       QT=PT/CS
43909       PX=(C*C-S*S)*QT
43910       PY=2.*C*S*QT
43911       END
43912 CDECK  ID>, HWREXP.
43913 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
43914 *-- Author :    David Ward, modified by Bryan Webber
43915 C-----------------------------------------------------------------------
43916       FUNCTION HWREXP(AV)
43917 C-----------------------------------------------------------------------
43918 C     Random number from dN/d(x**2)=exp(-b*x) with mean AV
43919 C-----------------------------------------------------------------------
43920       DOUBLE PRECISION HWREXP,HWRGEN,AV,B,R1,R2
43921       EXTERNAL HWRGEN
43922       B=2./AV
43923       R1=HWRGEN(0)
43924       R2=HWRGEN(1)
43925       HWREXP=-LOG(R1*R2)/B
43926       END
43927 CDECK  ID>, HWREXQ.
43928 *CMZ :-        -02/06/94  11.02.47  by  Mike Seymour
43929 *-- Author :    David Ward, modified by Bryan Webber and Mike Seymour
43930 C-----------------------------------------------------------------------
43931       FUNCTION HWREXQ(AV,XMAX)
43932 C-----------------------------------------------------------------------
43933 C     Random number from dN/d(x**2)=EXQ(-b*x) with mean AV,
43934 C     But truncated at XMAX
43935 C-----------------------------------------------------------------------
43936       DOUBLE PRECISION HWREXQ,HWRGEN,AV,B,BXMAX,R1,R2,XMAX,R,RMIN
43937       EXTERNAL HWRGEN
43938       B=2./AV
43939       BXMAX=B*XMAX
43940       IF (BXMAX.LT.50) THEN
43941         RMIN=EXP(-BXMAX)
43942       ELSE
43943         RMIN=0
43944       ENDIF
43945  10   R1=HWRGEN(0)*(1-RMIN)+RMIN
43946       R2=HWRGEN(1)*(1-RMIN)+RMIN
43947       R=R1*R2
43948       IF (R.LT.RMIN) GOTO 10
43949       HWREXQ=-LOG(R)/B
43950       END
43951 CDECK  ID>, HWREXT.
43952 *CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
43953 *-- Author :    David Ward, modified by Bryan Webber
43954 C-----------------------------------------------------------------------
43955       FUNCTION HWREXT(AM0,B)
43956 C-----------------------------------------------------------------------
43957 C     Random number from dN/d(x**2)=exp(-B*TM) distribution, where
43958 C     TM = SQRT(X**2+AM0**2).  Uses Newton's method to solve F-R=0
43959 C-----------------------------------------------------------------------
43960       DOUBLE PRECISION HWREXT,HWRGEN,AM0,B,R,A,F,DF,DAM,AM
43961       INTEGER NIT
43962       EXTERNAL HWRGEN
43963       R=HWRGEN(0)
43964 C --- Starting value
43965       AM=AM0-LOG(R)/B
43966       DO 1 NIT=1,20
43967       A=EXP(-B*(AM-AM0))/(1.+B*AM0)
43968       F=(1.+B*AM)*A-R
43969       DF=-B**2*AM*A
43970       DAM=-F/DF
43971       AM=AM+DAM
43972       IF(AM.LT.AM0) AM=AM0+.001
43973       IF(ABS(DAM).LT..001) GOTO 2
43974    1  CONTINUE
43975       CALL HWWARN('HWREXT',1,*2)
43976    2  HWREXT=AM
43977       END
43978 CDECK  ID>, HWRGAU.
43979 *CMZ :-        -19/05/99  11.11.56  by  Mike Seymour
43980 *-- Author :    Mike Seymour
43981 C-----------------------------------------------------------------------
43982       FUNCTION HWRGAU(J,A,B)
43983 C-----------------------------------------------------------------------
43984 C     Gaussian random number, mean A, standard deviation B.
43985 C     Generates uncorrelated pairs and throws one of them away.
43986 C-----------------------------------------------------------------------
43987       INCLUDE 'HERWIG65.INC'
43988       DOUBLE PRECISION HWRGAU,HWRGEN,A,B,X,TRASH
43989       INTEGER J
43990       EXTERNAL HWRGEN
43991  10   X=HWRGEN(J)
43992       IF (X.LE.ZERO.OR.X.GT.ONE) GOTO 10
43993       X=SQRT(-TWO*LOG(X))
43994       CALL HWRAZM(X,X,TRASH)
43995       HWRGAU=A+B*X
43996       END
43997 CDECK  ID>, HWRGEN.
43998 *CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
43999 *-- Author :    F. James, modified by Mike Seymour
44000 C-----------------------------------------------------------------------
44001       FUNCTION HWRGEN(I)
44002 C-----------------------------------------------------------------------
44003 C     MAIN RANDOM NUMBER GENERATOR
44004 C     USES METHOD OF l'Ecuyer, (VIA F.JAMES, COMP PHYS COMM 60(1990)329)
44005 C-----------------------------------------------------------------------
44006       IMPLICIT NONE
44007       DOUBLE PRECISION HWRGEN,HWRSET,HWRGET
44008       INTEGER I,ISEED(2),K,IZ,JSEED(2)
44009       SAVE ISEED
44010       DATA ISEED/12345,67890/
44011       K=ISEED(1)/53668
44012       ISEED(1)=40014*(ISEED(1)-K*53668)-K*12211
44013       IF (ISEED(1).LT.0) ISEED(1)=ISEED(1)+2147483563
44014       K=ISEED(2)/52774
44015       ISEED(2)=40692*(ISEED(2)-K*52774)-K*3791
44016       IF (ISEED(2).LT.0) ISEED(2)=ISEED(2)+2147483399
44017       IZ=ISEED(1)-ISEED(2)
44018       IF (IZ.LT.1) IZ=IZ+2147483562
44019       HWRGEN=DBLE(IZ)*4.656613001013252D-10
44020 C--->                (4.656613001013252D-10 = 1.D0/2147483589)
44021       RETURN
44022 C-----------------------------------------------------------------------
44023       ENTRY HWRSET(JSEED)
44024 C-----------------------------------------------------------------------
44025       HWRSET=0.0D0
44026       IF (JSEED(1).EQ.0.OR.JSEED(2).EQ.0) CALL HWWARN('HWRSET',99,*999)
44027       ISEED(1)=JSEED(1)
44028       ISEED(2)=JSEED(2)
44029  999  RETURN
44030 C-----------------------------------------------------------------------
44031       ENTRY HWRGET(JSEED)
44032 C-----------------------------------------------------------------------
44033       JSEED(1)=ISEED(1)
44034       JSEED(2)=ISEED(2)
44035       HWRGET=0.0D0
44036       RETURN
44037       END
44038 CDECK  ID>, HWRINT.
44039 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
44040 *-- Author :    Bryan Webber
44041 C-----------------------------------------------------------------------
44042       FUNCTION HWRINT(IMIN,IMAX)
44043 C-----------------------------------------------------------------------
44044 C     RANDOM INTEGER IN [IMIN,IMAX]. N.B. ASSUMES IMAX.GE.IMIN
44045 C-----------------------------------------------------------------------
44046       DOUBLE PRECISION HWRGEN,RN,ONE
44047       INTEGER HWRINT,IMIN,IMAX
44048       EXTERNAL HWRGEN
44049       PARAMETER (ONE=1.0D0)
44050     1 RN=HWRGEN(0)
44051       IF (RN.EQ.ONE) GOTO 1
44052       RN=RN*(IMAX-IMIN+1)
44053       HWRINT=IMIN+INT(RN)
44054       END
44055 CDECK  ID>, HWRLOG.
44056 *CMZ :-        -26/04/91  14.15.56  by  Federico Carminati
44057 *-- Author :    Bryan Webber
44058 C-----------------------------------------------------------------------
44059       FUNCTION HWRLOG(A)
44060 C-----------------------------------------------------------------------
44061 C     Returns .TRUE. with probability A
44062 C-----------------------------------------------------------------------
44063       DOUBLE PRECISION HWRGEN,A,R
44064       LOGICAL HWRLOG
44065       EXTERNAL HWRGEN
44066       HWRLOG=.TRUE.
44067       R=HWRGEN(0)
44068       IF(R.GT.A) HWRLOG=.FALSE.
44069       END
44070 CDECK  ID>, HWRPIP.
44071 *CMZ :-        -07/09/00  10:06:23  by Peter Richardson
44072 *-- Author :    Ian Knowles
44073 C-----------------------------------------------------------------------
44074       SUBROUTINE HWRPIP
44075 C-----------------------------------------------------------------------
44076 C     Generates a random primary IP using a triple Gaussian distribution
44077 C-----------------------------------------------------------------------
44078       INCLUDE 'HERWIG65.INC'
44079       DOUBLE PRECISION HWRGAU
44080       INTEGER I
44081       EXTERNAL HWRGAU
44082       DO 10 I=1,3
44083   10  VTXPIP(I)=HWRGAU(I,ZERO,VIPWID(I))
44084       VTXPIP(4)=ZERO
44085       END
44086 CDECK  ID>, HWRPOW.
44087 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
44088 *-- Author :    Bryan Webber
44089 C-----------------------------------------------------------------------
44090       SUBROUTINE HWRPOW(XVAL,XJAC)
44091 C-----------------------------------------------------------------------
44092 C     RETURNS XVAL DISTRIBUTED ON (XMIN,XMAX) LIKE XVAL**XPOW
44093 C     AND CORRESPONDING JACOBIAN FACTOR XJAC
44094 C     SET FIRST=.TRUE. IF NEW XMIN,XMAX OR XPOW
44095 C-----------------------------------------------------------------------
44096       DOUBLE PRECISION HWRGEN,XVAL,XJAC,XMIN,XMAX,XPOW,P,Q,A,B,C,Z,ZERO
44097       LOGICAL FIRST
44098       PARAMETER(ZERO=0.0D0)
44099       EXTERNAL HWRGEN
44100       SAVE Q,A,B,C
44101       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
44102       IF (FIRST) THEN
44103         P=XPOW+1.
44104         IF (P.EQ.ZERO) CALL HWWARN('HWRPOW',500,*999)
44105         Q=1./P
44106         A=XMIN**P
44107         B=XMAX**P-A
44108         C=B*Q
44109         FIRST=.FALSE.
44110       ENDIF
44111       Z=A+B*HWRGEN(0)
44112       XVAL=Z**Q
44113       XJAC=XVAL*C/Z
44114   999 END
44115 CDECK  ID>, HWRUNG.
44116 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
44117 *-- Author :    David Ward, modified by Bryan Webber
44118 C-----------------------------------------------------------------------
44119       FUNCTION HWRUNG(A,B)
44120 C-----------------------------------------------------------------------
44121 C     Random number from distribution having flat top [-A,A] & gaussian
44122 C     tail of s.d. B
44123 C-----------------------------------------------------------------------
44124       DOUBLE PRECISION HWRUNG,HWRGAU,HWRUNI,A,B,PRUN,ZERO
44125       LOGICAL HWRLOG
44126       EXTERNAL HWRGAU,HWRUNI,HWRLOG
44127       PARAMETER (ZERO=0.D0)
44128       IF (A.EQ.ZERO) THEN
44129         PRUN=0
44130       ELSE
44131         PRUN=1./(1.+B*1.2533/A)
44132       ENDIF
44133       IF(HWRLOG(PRUN)) THEN
44134         HWRUNG=HWRUNI(0,-A,A)
44135       ELSE
44136         HWRUNG=HWRGAU(0,ZERO,B)
44137         HWRUNG=HWRUNG+SIGN(A,HWRUNG)
44138       ENDIF
44139       END
44140 CDECK  ID>, HWRUNI.
44141 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
44142 *-- Author :    Bryan Webber
44143 C-----------------------------------------------------------------------
44144       FUNCTION HWRUNI(I,A,B)
44145 C-----------------------------------------------------------------------
44146 C     Uniform random random number in range [A,B]
44147 C-----------------------------------------------------------------------
44148       DOUBLE PRECISION HWRUNI,HWRGEN,A,B,RN
44149       INTEGER I
44150       EXTERNAL HWRGEN
44151       RN=HWRGEN(I)
44152       HWRUNI=A+RN*(B-A)
44153       END
44154 CDECK  ID>, HWSBRN.
44155 *CMZ :-        -18/10/99  19.08.45  by  Mike Seymour
44156 *-- Author :    Bryan Webber
44157 C-----------------------------------------------------------------------
44158       SUBROUTINE HWSBRN(KPAR)
44159 C-----------------------------------------------------------------------
44160 C     DOES BRANCHING OF SPACELIKE PARTON KPAR
44161 C-----------------------------------------------------------------------
44162       INCLUDE 'HERWIG65.INC'
44163       DOUBLE PRECISION HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,
44164      & HWSSUD,XLAST,QNOW,QLST,QP,QMIN,QLAM,QSAV,SMAX,SLST,SNOW,RN,SUDA,
44165      & SUDB,ZZ,ENOW,XI,PMOM,DIST(13),DMIN,X1,X2,REJFAC,OTHXI,OTHZ,QTMP,
44166      & PTMP(2),JAC,OTHJAC,S,T,U,EMB2,PTMX
44167       INTEGER N0,IS,ID,ID1,ID2,IDHAD,N1,I,MQ,NTRY,NDEL,NA,NB,IW1,IW2,
44168      & KPAR,LPAR,MPAR,ISUD(13),IREJ,NREJ
44169       LOGICAL HWSVAL,FORCE,VALPAR,FTMP
44170       EXTERNAL HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,HWSSUD,
44171      & HWSVAL
44172       COMMON/HWTABC/XLAST,N0,IS,ID
44173       DATA ISUD,DMIN/2,2,3,4,5,6,2,2,3,4,5,6,1,1.D-15/
44174       IF (IERROR.NE.0) RETURN
44175       ID=IDPAR(KPAR)
44176 C--TEST FOR PARTON TYPE
44177       IF (ID.LE.13) THEN
44178         IS=ISUD(ID)
44179       ELSEIF (ID.GE.208) THEN
44180         IS=7
44181       ELSE
44182         IS=0
44183       END IF
44184       QNOW=-1.
44185       IF (IS.NE.0) THEN
44186 C--SPACELIKE PARTON BRANCHING
44187         QLST=PPAR(1,KPAR)
44188         IDHAD=IDHW(INHAD)
44189         VALPAR=HWSVAL(ID)
44190         QP=HWBVMC(ID)
44191         XLAST=XFACT*PPAR(4,KPAR)
44192         IF (XLAST.GE.ONE) CALL HWWARN('HWSBRN',107,*999)
44193 C--SET UP Q BOUNDARY
44194         IF (VALPAR) THEN
44195           QMIN=QG/(1.-XLAST)
44196         ELSEIF (ID.EQ.13) THEN
44197           QMIN=QV/(1.-XLAST)
44198         ELSE
44199           QMIN=.5*(QP+QV+SQRT((QP-QV)**2+4.*QP*QV*XLAST))/(1.-XLAST)
44200         ENDIF
44201         QSAV=QMIN
44202         IF (QMIN.LE.QSPAC.AND.ISPAC.LT.2) THEN
44203           QMIN=QSPAC
44204           N1=NSPAC(IS)
44205         ELSEIF (QMIN.LE.QEV(1,IS)) THEN
44206           QMIN=QEV(1,IS)
44207           N1=1
44208         ELSE
44209           DO 110 I=2,NQEV
44210           IF (QEV(I,IS).GT.QMIN) GOTO 120
44211   110     CONTINUE
44212   120     N1=I-1
44213         ENDIF
44214         N0=N1-1
44215         MQ=NQEV-N0
44216         NTRY=0
44217   125   NTRY=NTRY+1
44218         NREJ=1
44219         IF (QLST.GT.QMIN.AND..NOT.NOSPAC.OR..NOT.VALPAR) THEN
44220           IF (QLST.LE.QMIN) THEN
44221 C--CHECK PHASE SPACE FOR FORCED SPLITTING OF NON-VALENCE PARTON
44222             IF (QLST.LT.QSAV) CALL HWWARN('HWSBRN',ISLENT*105,*999)
44223             FORCE=.TRUE.
44224             QNOW=(QLST/QSAV)**HWRGEN(0)*QSAV
44225           ELSE
44226 C--ENHANCE EMISSION BY A FACTOR OF TWO IF THIS BRANCH
44227 C  IS CAPABLE OF BEING THE HARDEST SO FAR
44228            IF (QLST.GT.HARDST) NREJ=2
44229            QTMP=-1
44230            DO 300 IREJ=1,NREJ
44231 C--FIND NEW VALUE OF SUD/DIST
44232             CALL HWSFUN(XLAST,QMIN,IDHAD,NSTRU,DIST,JNHAD)
44233             IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QMIN)
44234             IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
44235             SMAX=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QMIN,INTER)/DIST(ID)
44236             CALL HWSFUN(XLAST,QLST,IDHAD,NSTRU,DIST,JNHAD)
44237             IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QLST)
44238             IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
44239             SLST=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QLST,INTER)/DIST(ID)
44240             RN=HWRGEN(0)
44241             IF (RN.EQ.ZERO) THEN
44242               SNOW=SLST*2.
44243             ELSE
44244               SNOW=SLST/RN
44245             ENDIF
44246             IF (VALPAR.AND.SNOW.GE.SMAX) GOTO 200
44247             IF (SNOW.LT.SMAX.AND..NOT.NOSPAC) THEN
44248               FORCE=.FALSE.
44249             ELSE
44250 C--FORCE SPLITTING OF NON-VALENCE PARTON
44251               FORCE=.TRUE.
44252               QNOW=(MIN(QLST,1.1*QMIN)/QSAV)**HWRGEN(0)*QSAV
44253             ENDIF
44254             IF (QNOW.LT.ZERO) THEN
44255 C--BRANCHING OCCURS. FIRST CHECK FOR MONOTONIC FORM FACTOR
44256               SUDA=SMAX
44257               NDEL=32
44258               NA=N1
44259   130         NB=NA+NDEL
44260               IF (NB.GT.NQEV) CALL HWWARN('HWSBRN',103,*999)
44261               CALL HWSFUN(XLAST,QEV(NB,IS),IDHAD,NSTRU,DIST,JNHAD)
44262               IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QEV(NB,IS))
44263               IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
44264               SUDB=SUD(NB,IS)/DIST(ID)
44265               IF (SUDB.GT.SUDA) THEN
44266                 SUDA=SUDB
44267                 NA=NB
44268                 GOTO 130
44269               ELSEIF (NA.NE.N1) THEN
44270                 IF (SUDB.LT.SNOW) THEN
44271                   NDEL=NDEL/2
44272                   IF (NDEL.EQ.0) CALL HWWARN('HWSBRN',100,*999)
44273                   GOTO 130
44274                 ENDIF
44275                 N1=NB
44276                 N0=N1-1
44277                 MQ=NQEV-N0
44278               ENDIF
44279 C--NOW FIND NEW Q
44280               QNOW=HWSTAB(QEV(N1,IS),HWSSUD,MQ,SNOW,INTER)
44281               IF (QNOW.LE.QMIN.OR.QNOW.GT.QLST) THEN
44282 C--INTERPOLATION PROBLEM: USE LINEAR INSTEAD
44283 C                CALL HWWARN('HWSBRN',1,*999)
44284                 QNOW=HWRUNI(0,QMIN,QLST)
44285               ENDIF
44286             ENDIF
44287  200        CONTINUE
44288             IF (QNOW.GT.QTMP) THEN
44289               QTMP=QNOW
44290               FTMP=FORCE
44291             ENDIF
44292             QNOW=-1
44293  300       CONTINUE
44294            QNOW=QTMP
44295            FORCE=FTMP
44296           ENDIF
44297           IF (QNOW.LT.ZERO) GOTO 210
44298 C--NOW FIND NEW X
44299           CALL HWSFBR(XLAST,QNOW,FORCE,ID,1,ID1,ID2,IW1,IW2,ZZ)
44300           IF (ID1.LT.0) THEN
44301 C--NO PHASE SPACE FOR BRANCHING
44302             FROST=.TRUE.
44303             RETURN
44304           ELSEIF (ID1.EQ.0) THEN
44305 C--BRANCHING REJECTED: REDUCE Q AND REPEAT
44306             IF (NTRY.GT.NBTRY.OR.IERROR.NE.0)
44307      $           CALL HWWARN('HWSBRN',102,*999)
44308             QLST=QNOW
44309             QNOW=-1.
44310             GOTO 125
44311           ELSEIF (ID1.EQ.59) THEN
44312 C--ANOMALOUS PHOTON SPLITTING: ADD PT TO INTRINSIC PT AND STOP BRANCHING
44313             IF (IDHAD.NE.59) CALL HWWARN('HWSBRN',109,*999)
44314             ENOW=PPAR(4,KPAR)/XLAST
44315             XI=(QNOW/ENOW)**2
44316             QLAM=QNOW*(1.-XLAST)
44317             IF ((2.-XI)*QLAM**2.GT.EMSCA**2) THEN
44318 C--BRANCHING REJECTED: REDUCE Q AND REPEAT
44319               IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',110,*999)
44320               QLST=QNOW
44321               QNOW=-1.
44322               GOTO 125
44323             ENDIF
44324             CALL HWRAZM(QNOW*(1.-XLAST),PTMP(1),PTMP(2))
44325             CALL HWVSUM(2,PTMP,PTINT(1,JNHAD),PTINT(1,JNHAD))
44326             PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
44327             ANOMSC(1,JNHAD)=QNOW
44328             ANOMSC(2,JNHAD)=QNOW*(1.-XLAST)
44329             QNOW=-1.
44330             QLST=QNOW
44331             GOTO 125
44332           ELSEIF (FORCE.AND..NOT.HWSVAL(ID1).AND.ID1.NE.13) THEN
44333 C--FORCED BRANCHING PRODUCED A NON-VALENCE PARTON: TRY AGAIN
44334             IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',108,*999)
44335             QLST=QNOW
44336             QNOW=-1.
44337             GOTO 125
44338           ENDIF
44339         ENDIF
44340   210   CONTINUE
44341         IF (QNOW.GT.ZERO) THEN
44342 C--BRANCHING HAS OCCURRED
44343           ENOW=PPAR(4,KPAR)/ZZ
44344           XI=(QNOW/ENOW)**2
44345           QLAM=QNOW*(1.-ZZ)
44346           IF ((SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
44347      &        (2.-XI)*QLAM**2.GT.EMSCA**2).AND..NOT.FORCE) THEN
44348 C--BRANCHING REJECTED: REDUCE Q AND REPEAT
44349               IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',104,*999)
44350               QLST=QNOW
44351               QNOW=-1.
44352               GOTO 125
44353           ENDIF
44354 C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
44355           IF (.NOT.FORCE) THEN
44356             REJFAC=1
44357             IF (QLAM.GT.HARDST .AND. ID.NE.13) THEN
44358               IF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
44359 C---COLOUR PARTNER IS OUTGOING (X1=XP, X2=ZP)
44360                 X2=SQRT((ZZ**2-(1-ZZ)*XI)**2+2*(ZZ*(1-ZZ))**2*XI*(2-XI))
44361                 X1=(ZZ**2+(1-ZZ)*XI-X2)/(2*(1-ZZ)*XI)
44362                 X2=(ZZ**2-(1-ZZ)*XI+X2)/(2*ZZ**2)
44363                 IF (ID2.EQ.13) THEN
44364 C---GLUON EMISSION
44365                   REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
44366      $                 /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
44367      $                 *(1+ZZ**2)/((1-ZZ)*XI)
44368      $                 *(1-X1)*(1-X2)/
44369      $                 (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
44370 C---CHECK WHETHER IT IS IN THE OVERLAP REGION
44371                   OTHXI=2*(1-X1)/(1-X1+2*(3*X1-2)*X2*(1-X2))
44372                   IF (OTHXI.LT.ONE) THEN
44373                     OTHZ=(1-(2*X2-1)*SQRT((3*X1-2)/X1))/2
44374                     REJFAC=REJFAC+SQRT(3-2/X1)/(X1**2*OTHZ*(1-OTHZ))
44375      $               *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
44376      $               *(1-X1)*(1-X2)/
44377      $               (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
44378                   ENDIF
44379                 ELSEIF (ID1.EQ.13) THEN
44380 C---GLUON SPLITTING
44381                   REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
44382      $                 /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
44383      $                 *(ZZ**2+(1-ZZ)**2)/XI
44384      $                 *(1-X2)/
44385      $                 ((  X1+X2-2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2
44386      $                 +(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
44387                 ENDIF
44388               ELSE
44389 C---COLOUR PARTNER IS ALSO INCOMING
44390                 T=-(1-ZZ)*XI/ZZ**2
44391                 S=2*(ZZ**2+(1-ZZ)*XI)/(ZZ**2*(2*ZZ+XI*(1-ZZ)))
44392                 U=1-S-T
44393                 JAC=-T*(1-T)/S**2*ZZ**5/(XI*(1-ZZ)**2*(ZZ+XI*(1-ZZ)))
44394                 IF (ID2.EQ.13) THEN
44395 C---GLUON EMISSION
44396                   REJFAC=(1+ZZ**2)/((1-ZZ)*ZZ*XI)
44397      &                 *JAC*S**2*T*U/((1-U)**2+(1-T)**2)
44398 C---CHECK WHETHER IT IS IN THE OVERLAPPING REGION
44399                   OTHZ=(1+SQRT(1-2*U*(1-U)/S))/U
44400                   OTHXI=2*(1-OTHZ+T/S)/(1-OTHZ)
44401                   IF (OTHXI.LT.OTHZ**2) THEN
44402                     OTHJAC=-U*(1-U)/S**2*OTHZ**5/(OTHXI*
44403      &                   (1-OTHZ)**2*(OTHZ+OTHXI*(1-OTHZ)))
44404                     REJFAC=REJFAC+(1+OTHZ**2)/((1-OTHZ)*OTHZ*OTHXI)
44405      &                   *OTHJAC*S**2*T*U/((1-U)**2+(1-T)**2)
44406                   ENDIF
44407                 ELSEIF (ID1.EQ.13) THEN
44408 C---GLUON SPLITTING
44409                   REJFAC=-((1-ZZ)**2+ZZ**2)/(ZZ*XI)
44410      &                 *JAC*S**3*T/((1-S)**2+(1-T)**2)
44411                 ENDIF
44412               ENDIF
44413             ENDIF
44414             IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
44415               QLST=QNOW
44416               QNOW=-1.
44417               GOTO 125
44418             ENDIF
44419             IF (QLAM.GT.HARDST) HARDST=QLAM
44420           ENDIF
44421           IF (IW2.GT.IW1) THEN
44422             LPAR=NPAR+1
44423             MPAR=NPAR+2
44424 C---NEW MOTHER-DAUGHTER RELATIONS
44425 C   N.B. DEFINED MOVING AWAY FROM HARD PROCESS
44426             JDAPAR(1,KPAR)=LPAR
44427             JDAPAR(2,KPAR)=MPAR
44428 C---NEW COLOUR CONNECTIONS
44429             JCOPAR(3,KPAR)=MPAR
44430             JCOPAR(4,KPAR)=LPAR
44431             JCOPAR(1,MPAR)=KPAR
44432             JCOPAR(2,MPAR)=LPAR
44433             JCOPAR(1,LPAR)=MPAR
44434             JCOPAR(2,LPAR)=KPAR
44435           ELSE
44436             MPAR=NPAR+1
44437             LPAR=NPAR+2
44438             JDAPAR(1,KPAR)=MPAR
44439             JDAPAR(2,KPAR)=LPAR
44440             JCOPAR(3,KPAR)=LPAR
44441             JCOPAR(4,KPAR)=MPAR
44442             JCOPAR(1,MPAR)=LPAR
44443             JCOPAR(2,MPAR)=KPAR
44444             JCOPAR(1,LPAR)=KPAR
44445             JCOPAR(2,LPAR)=MPAR
44446           ENDIF
44447           JMOPAR(1,LPAR)=KPAR
44448           JMOPAR(1,MPAR)=KPAR
44449           IDPAR(LPAR)=ID1
44450           IDPAR(MPAR)=ID2
44451           TMPAR(LPAR)=.FALSE.
44452           TMPAR(MPAR)=.TRUE.
44453           PPAR(1,LPAR)=QNOW
44454           PPAR(2,LPAR)=XI
44455           PPAR(4,LPAR)=ENOW
44456           PPAR(1,MPAR)=QNOW*(1.-ZZ)
44457           PPAR(2,MPAR)=XI
44458           PPAR(4,MPAR)=ENOW*(1.-ZZ)
44459           NPAR=NPAR+2
44460         ENDIF
44461       ENDIF
44462       IF (QNOW.LT.ZERO) THEN
44463 C--BRANCHING STOPS
44464         JDAPAR(1,KPAR)=0
44465         JDAPAR(2,KPAR)=0
44466         JCOPAR(3,KPAR)=0
44467         JCOPAR(4,KPAR)=0
44468         IF (ID.LE.13) THEN
44469 C---PUT SPECTATOR (APPROXIMATELY) ON-SHELL
44470           XLAST=XFACT*PPAR(4,KPAR)
44471           IF ((1-XLAST)**2.LT.(RMASS(ID)**2+PTINT(3,JNHAD))*XFACT**2)
44472      &         THEN
44473             FROST=.TRUE.
44474             RETURN
44475           ENDIF
44476 C---BRW MOD: INCLUDE HIGHER ORDER CORRECTION IN MASS CALCULATION
44477 c$$$          PPAR(5,KPAR)=-(RMASS(ID)**2*XLAST+PTINT(3,JNHAD))/(1.-XLAST)
44478 c$$$     &         +XLAST*SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
44479           PTMX=(RMASS(ID)**2+PTINT(3,JNHAD))/(ONE-XLAST)
44480           EMB2=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
44481           PPAR(5,KPAR)=-PTINT(3,JNHAD)-XLAST*(PTMX-EMB2)-0.25D0*
44482      $     ((PTMX-EMB2)**2+XLAST*(PTMX**2/(ONE-XLAST)-EMB2**2))*XFACT**2
44483 C---END BRW MOD
44484         ELSEIF (ID.EQ.IDHW(INHAD)) THEN
44485 C---IF INCOMING PARTON IS INCOMING BEAM, ALLOW IT TO BE OFF-SHELL
44486           PPAR(5,KPAR)=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
44487         ELSE
44488           PPAR(5,KPAR)=RMASS(ID)**2
44489         ENDIF
44490         PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
44491         IF (PMOM.LT.ZERO) THEN
44492           FROST=.TRUE.
44493           RETURN
44494         ENDIF
44495         PPAR(3,KPAR)=SQRT(PMOM)
44496       ENDIF
44497   999 END
44498 CDECK  ID>, HWSDGG.
44499 *CMZ :=        =26/04/91  12.47.48  by  Federico Carminati
44500 *-- Author :    Drees, Grassie, Charchula, modified by Bryan Webber
44501 C ===============================================================
44502 C  DREES & GRASSIE PARAMETRIZATION OF PHOTON STRUCTURE FUNCTION
44503 C
44504 C    HWSDGQ(X,Q2,NFL,NCH) - X*QUARK_IN_PHOTON/ALPHA  (!)
44505 C    HWSDGG(X,Q2,NFL)     - X*GLUON_IN_PHOTON/ALPHA  (!)
44506 C WHERE:
44507 C        (INTEGER) NCH - QUARK CHARGE: 1 FOR 1/3
44508 C                                      2 FOR 2/3
44509 C        (INTEGER) NFL - NUMBER OF QUARK FLAVOURS /3 OR 4/
44510 C                   Q2 - SQUARE OF MOMENTUM Q /IN GEV2/
44511 C                   X  - LONGITUDINAL FRACTION
44512 C  LAMBDA=0.4 GEV
44513 C
44514 C       NFL=3:     1 < Q2 < 50   GEV^2
44515 C       NFL=4:    20 < Q2 < 500  GEV^2
44516 C       NFL=5:   200 < Q2 < 10^4 GEV^2
44517 C
44518 C
44519 C  KRZYSZTOF CHARCHULA  /14.02.1989/
44520 C================================================================
44521 C
44522 C PS. Note that for the case of three flavors, one has to add
44523 C the QPM charm contribution for getting F2.
44524 C
44525 C================================================================
44526 C MODIFIED FOR HERWIG BY BRW 19/4/91
44527 C--- -----------------------------------------------
44528 C        GLUON PART OF THE PHOTON SF
44529 C--- -----------------------------------------------
44530       FUNCTION HWSDGG(X,Q2,NFL)
44531       IMPLICIT REAL (A-H,P-Z)
44532       INTEGER NFL
44533       DIMENSION A(3,4,3),AT(3)
44534       ALAM2=0.160
44535       T=LOG(Q2/ALAM2)
44536 C- ---  CHECK WHETHER NFL  HAVE RIGHT VALUES -----
44537       IF (.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5)))THEN
44538  130   WRITE(6,131)
44539  131   FORMAT(' NUMBER OF FLAVOURS(NFL) HAS NOT BEEN SET TO: 3,4 OR 5;'/
44540      *'          NFL=3 IS ASSUMED')
44541        NFL=3
44542       ELSEIF (T.LE.0) THEN
44543        WRITE(6,132)
44544  132   FORMAT(' HWSDGG CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
44545        HWSDGG=0
44546        RETURN
44547       ENDIF
44548 C ------ INITIALIZATION OF PARAMETERS ARRAY -----
44549       DATA(((A(I,J,K),I=1,3),J=1,4),K=1,3)/
44550      + -0.20700,-0.19870, 5.11900,
44551      +  0.61580, 0.62570,-0.27520,
44552      +  1.07400, 8.35200,-6.99300,
44553      +  0.00000, 5.02400, 2.29800,
44554      +    0.8926E-2, 0.05090,-0.23130,
44555      +    0.659400, 0.27740, 0.13820,
44556      +    0.476600,-0.39060, 6.54200,
44557      +    0.019750,-0.32120, 0.51620,
44558      +  0.031970, -0.618E-2, -0.1216,
44559      +  1.0180,    0.94760,  0.90470,
44560      +  0.24610,  -0.60940,  2.6530,
44561      +  0.027070, -0.010670, 0.2003E-2/
44562 C ------ Q2 DEPENDENCE -----------
44563       LF=NFL-2
44564       DO 20 I=1,3
44565         AT(I)=A(I,1,LF)*T**A(I,2,LF)+A(I,3,LF)*T**(-A(I,4,LF))
44566  20   CONTINUE
44567 C ------ GLUON DISTRIBUTION -------------
44568       HWSDGG=AT(1)*X**AT(2)*(1.0-X)**AT(3)/137.
44569       RETURN
44570       END
44571 CDECK  ID>, HWSDGQ.
44572 *CMZ :-        -26/04/91  13.04.45  by  Federico Carminati
44573 *-- Author :    Drees, Grassie, Charchula, modified by Bryan Webber
44574 C --------------------------------------
44575 C  QUARK PART OF THE PHOTON SF
44576 C --------------------------------------
44577       FUNCTION HWSDGQ(X,Q2,NFL,NCH)
44578       IMPLICIT REAL (A-H,P-Z)
44579       INTEGER NFL,NCH
44580       DIMENSION A(5,4,2,3),AT(5,2),XQPOM(2),E(2)
44581       COMMON/DG/F2
44582 C SQUARE OF LAMBDA=0.4 GEV
44583       ALAM2=0.160
44584       T=LOG(Q2/ALAM2)
44585 C
44586 C  CHECK WHETHER NFL AND NCH HAVE RIGHT VALUES
44587 C
44588       IF(.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5))) THEN
44589  110   WRITE(6,111)
44590  111   FORMAT('NUMBER OF FLAVOURS (NFL) HAS NOT BEEN SET TO: 3,4 OR 5'/
44591      *'          NFL=3 IS ASSUMED')
44592        NFL=3
44593       ELSEIF (T.LE.0) THEN
44594        WRITE(6,132)
44595  132   FORMAT(' HWSDGQ CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
44596        HWSDGQ=0
44597        RETURN
44598       ENDIF
44599       IF (.NOT.((NCH.EQ.1).OR.(NCH.EQ.2))) THEN
44600  120     WRITE(6,121)
44601  121     FORMAT(' QUARK CHARGE NUMBER (NCH) HAS NOT BEEN SET',
44602      *'           TO 1 OR 2;'/
44603      *'           NCH=1 IS ASSUMED')
44604          NCH=1
44605       ENDIF
44606 C ------ INITIALIZATION ------
44607       DATA(((A(I,J,K,1),I=1,5),J=1,4),K=1,2)/
44608      + 2.28500,  6.07300, -0.42020,-0.08080, 0.05530,
44609      +-0.01530, -0.81320,  0.01780, 0.63460, 1.13600,
44610      + 1.3300E3,-41.3100,   0.92160, 1.20800, 0.95120,
44611      + 4.21900,  3.16500,  0.18000, 0.20300, 0.01160,
44612      +16.6900,   0.17600, -0.02080,-0.01680,-0.19860,
44613      +-0.79160,  0.04790,  0.3386E-2,1.35300, 1.10000,
44614      + 1.0990E3,  1.04700,  4.85300, 1.42600, 1.13600,
44615      + 4.42800,  0.02500,  0.84040, 1.23900,-0.27790/
44616         DATA(((A(I,J,K,2),I=1,5),J=1,4),K=1,2)/
44617      +-0.37110,-0.17170, 0.087660,-0.89150,-0.18160,
44618      + 1.06100, 0.78150, 0.021970, 0.28570, 0.58660,
44619      + 4.75800, 1.53500, 0.109600, 2.97300, 2.42100,
44620      +-0.01500, 0.7067E-2,0.204000, 0.11850, 0.40590,
44621      +-0.12070,25.00000,-0.012300,-0.09190, 0.020150,
44622      + 1.07100,-1.64800, 1.162000, 0.79120, 0.98690,
44623      + 1.97700,-0.015630,0.482400, 0.63970,-0.070360,
44624      +-0.8625E-2,6.43800,-0.011000, 2.32700, 0.016940/
44625         DATA(((A(I,J,K,3),I=1,5),J=1,4),K=1,2)/
44626      +15.80,     2.7420,  0.029170,-0.03420, -0.023020,
44627      +-0.94640, -0.73320, 0.046570, 0.71960,  0.92290,
44628      +-0.50,     0.71480, 0.17850,  0.73380,  0.58730,
44629      +-0.21180,  3.2870,  0.048110, 0.081390,-0.79E-4,
44630      + 6.7340,  59.880,  -0.3226E-2,-0.03321,   0.10590,
44631      +-1.0080,  -2.9830,  0.84320,  0.94750,  0.69540,
44632      +-0.085940, 4.480,   0.36160, -0.31980, -0.66630,
44633      + 0.076250, 0.96860, 0.1383E-2, 0.021320, 0.36830/
44634       CF=10.0
44635 C ------- EVALUATION OF PARAMETERS IN Q2 ---------
44636       E(1)=1.0
44637       IF (NFL.EQ.3) THEN
44638         E(2)=9.0
44639         LF=1
44640       ELSEIF (NFL.EQ.4) THEN
44641         E(2)=10.0
44642         LF=2
44643       ELSEIF (NFL.EQ.5) THEN
44644         E(2)=55.0/6.0
44645         LF=3
44646       ENDIF
44647       DO 10 J=1,2
44648         DO 20 I=1,5
44649            ATP=A(I,1,J,LF)*T**A(I,2,J,LF)
44650            AT(I,J)=ATP+A(I,3,J,LF)*T**(-A(I,4,J,LF))
44651  20     CONTINUE
44652  10   CONTINUE
44653       DO 30 J=1,2
44654        POM1=X*(X*X+(1.0-X)**2)/(AT(1,J)-AT(2,J)*ALOG(1.0-X))
44655        POM2=AT(3,J)*X**AT(4,J)*(1.0-X)**AT(5,J)
44656        XQPOM(J)=E(J)*POM1+POM2
44657  30   CONTINUE
44658 C -------  QUARK DISTRIBUTIONS ----------
44659       HWSDGQ=0
44660       IF (NFL.EQ.3) THEN
44661          IF (NCH.EQ.2) THEN
44662            HWSDGQ=1.0/6.0*(XQPOM(2)+9.0*XQPOM(1))
44663          ELSEIF(NCH.EQ.1) THEN
44664            HWSDGQ=1.0/6.0*(XQPOM(2)-9.0/2.0*XQPOM(1))
44665          ENDIF
44666         F2=2.0/9.0*XQPOM(2)+XQPOM(1)
44667       ELSEIF (NFL.EQ.4) THEN
44668          IF (NCH.EQ.2) THEN
44669            HWSDGQ=1.0/8.0*(XQPOM(2)+6.0*XQPOM(1))
44670          ELSEIF(NCH.EQ.1) THEN
44671            HWSDGQ=1.0/8.0*(XQPOM(2)-6.0*XQPOM(1))
44672          ENDIF
44673         F2=5.0/18.0*XQPOM(2)+XQPOM(1)
44674       ELSEIF (NFL.EQ.5) THEN
44675          IF (NCH.EQ.2) THEN
44676            HWSDGQ=1.0/10.0*(XQPOM(2)+15.0/2.0*XQPOM(1))
44677          ELSEIF(NCH.EQ.1) THEN
44678            HWSDGQ=1.0/10.0*(XQPOM(2)-5.0*XQPOM(1))
44679          ENDIF
44680         F2=11.0/45.0*XQPOM(2)+XQPOM(1)
44681       ENDIF
44682       HWSDGQ=HWSDGQ/137.
44683       RETURN
44684       END
44685 CDECK  ID>, HWSFBR.
44686 *CMZ :-        -15/07/92  14.08.45  by  Mike Seymour
44687 *-- Author :    Bryan Webber
44688 C-----------------------------------------------------------------------
44689       SUBROUTINE HWSFBR(X,QQ,FORCED,ID,IW,ID1,ID2,IW1,IW2,Z)
44690 C-----------------------------------------------------------------------
44691 C     FINDS BRANCHING (ID1->ID+ID2) AND Z=X/X1 IN BACKWARD
44692 C     EVOLUTION AT ENERGY FRACTION X AND SCALE QQ
44693 C
44694 C     FORCED=.TRUE. FORCES SPLITTING OF NON-VALENCE PARTON
44695 C
44696 C     IW,IW1,IW2 ARE COLOUR CONNECTION WORDS
44697 C
44698 C     ID1.LT.0 ON RETURN MEANS NO PHASE SPACE
44699 C     ID1.EQ.0 ON RETURN FLAGS REJECTED BRANCHINGS
44700 C-----------------------------------------------------------------------
44701       INCLUDE 'HERWIG65.INC'
44702       DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUAEM,QP,X,QQ,Z,WQG,WQV,
44703      & WQP,XQV,ZMIN,ZMAX,YMIN,YMAX,DELY,YY,PSUM,EZ,WQN,WR,ZR,WZ,ZZ,AZ,
44704      & PVAL,EY,DIST(13),PROB(13,100),PPHO
44705       INTEGER ID,IW,ID1,ID2,IW1,IW2,NZ,IDHAD,IP,IZ
44706       LOGICAL HWRLOG,HWSVAL,FORCED,NONF,NONV,PHOTPR
44707       EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUAEM,HWRLOG,HWSVAL
44708       ID1=-1
44709       QP=HWBVMC(ID)
44710       WQG=1.-QG/QQ
44711       WQV=1.-QV/QQ
44712       WQP=1.-QP/QQ
44713       XQV=X/WQV
44714       NONV=.NOT.HWSVAL(ID)
44715       NONF=.NOT.FORCED
44716     5 IF (ID.EQ.13) THEN
44717         ZMIN=X
44718         IF (NONF) THEN
44719           ZMAX=WQG
44720         ELSE
44721           ZMAX=WQV
44722         ENDIF
44723       ELSE
44724         IF (NONV) THEN
44725           ZMIN=XQV
44726           IF (NONF) THEN
44727             ZMAX=WQG
44728           ELSE
44729             ZMAX=WQP
44730           ENDIF
44731         ELSE
44732           ZMIN=X
44733           ZMAX=MAX(WQG,WQP)
44734         ENDIF
44735       ENDIF
44736       IF (ZMIN.GE.ZMAX) RETURN
44737       ID1=0
44738 C---INTERPOLATION VARIABLE IS Y=LN(Z/(1-Z))
44739       YMIN=LOG(ZMIN/(1.-ZMIN))
44740       YMAX=LOG(ZMAX/(1.-ZMAX))
44741       DELY=YMAX-YMIN
44742       NZ=MIN(INT(ZBINM*DELY)+1,NZBIN)
44743       DELY=(YMAX-YMIN)/FLOAT(NZ)
44744       YY=YMIN+0.5*DELY
44745       PSUM=0.
44746       IDHAD=IDHW(INHAD)
44747 C---SET UP TABLES FOR CHOOSING BRANCHING
44748       DO 40 IZ=1,NZ
44749       EZ=EXP(YY)
44750       WR=1.+EZ
44751       ZR=WR/EZ
44752       WZ=1./WR
44753       ZZ=WZ*EZ
44754       AZ=WZ*ZZ*HWUALF(5-2*SUDORD,MAX(WZ*QQ,QG))
44755       CALL HWSFUN(X*ZR,QQ,IDHAD,NSTRU,DIST,JNHAD)
44756       IF (ID.NE.13) THEN
44757 C---SPLITTING INTO QUARK
44758         DO 10 IP=1,ID-1
44759    10   PROB(IP,IZ)=PSUM
44760         IF (NONF) PSUM=PSUM+DIST(ID)*AZ*CFFAC*(1.+ZZ*ZZ)*WR
44761         DO 20 IP=ID,12
44762    20   PROB(IP,IZ)=PSUM
44763         PSUM=PSUM+DIST(13)*AZ*0.5*(ZZ*ZZ+WZ*WZ)
44764         PROB(13,IZ)=PSUM
44765       ELSE
44766 C---SPLITTING INTO GLUON
44767         DO 30 IP=1,12
44768         PSUM=PSUM+DIST(IP)*AZ*CFFAC*(1.+WZ*WZ)*ZR
44769    30   PROB(IP,IZ)=PSUM
44770         IF (NONF) PSUM=PSUM+DIST(13)*AZ*2.*CAFAC*(WZ*ZR+ZZ*WR+WZ*ZZ)
44771         PROB(13,IZ)=PSUM
44772       ENDIF
44773    40 YY=YY+DELY
44774    50 PHOTPR=IDHAD.EQ.59.AND.ID.NE.13
44775       IF (PHOTPR) THEN
44776 C---ALLOW ANOMALOUS PHOTON SPLITTING
44777          PPHO=ZMIN*HWUAEM(-QQ*QQ)*CAFAC*(ZMIN**2+(1.-ZMIN)**2)
44778      &        *ICHRG(ID)**2/9D0
44779          IF (PPHO.GT.(PPHO+PSUM*DELY)*HWRGEN(2)) THEN
44780 C---ANOMALOUS PHOTON SPLITTING OCCURRED
44781            ID1=59
44782            RETURN
44783          ENDIF
44784        ENDIF
44785       IF (PSUM.LE.ZERO) RETURN
44786 C---CHOOSE Z
44787       PVAL=PSUM*HWRGEN(0)
44788       DO 60 IZ=1,NZ
44789       IF (PROB(13,IZ).GT.PVAL) GOTO 70
44790    60 CONTINUE
44791       IZ=NZ
44792    70 EY=EXP(YMIN+DELY*(FLOAT(IZ)-HWRGEN(1)))
44793       ZZ=EY/(1.+EY)
44794 C---CHOOSE BRANCHING
44795       DO 80 IP=1,13
44796       IF (PROB(IP,IZ).GT.PVAL) GOTO 90
44797    80 CONTINUE
44798       IP=13
44799 C---CHECK THAT Z IS INSIDE PHASE SPACE (RETURN IF NOT)
44800    90 CONTINUE
44801       IF (ID.NE.13) THEN
44802         IF (IP.EQ.ID) THEN
44803           IF ((NONV.AND.ZZ*WQP.LT.XQV).OR.ZZ.GT.WQG) THEN
44804             IF (PHOTPR) GOTO 50
44805             RETURN
44806           ENDIF
44807         ELSE
44808           IF (ZZ.LT.XQV.OR.ZZ.GT.WQP) THEN
44809             IF (PHOTPR) GOTO 50
44810             RETURN
44811           ENDIF
44812         ENDIF
44813       ELSE
44814         IF (IP.EQ.ID) THEN
44815           IF (ZZ.LT.XQV.OR.ZZ.GT.WQG) RETURN
44816         ELSEIF (.NOT.HWSVAL(IP)) THEN
44817           WQN=1.-HWBVMC(IP)/QQ
44818           IF (ZZ*WQN.LT.XQV.OR.ZZ.GT.WQN) RETURN
44819         ENDIF
44820       ENDIF
44821 C---EVERYTHING OK: LABEL NEW BRANCHES
44822       Z=ZZ
44823       ID1=IP
44824       IW1=IW*2
44825       IW2=IW1+1
44826       IF (ID.LE.6) THEN
44827         IF (ID1.EQ.13) THEN
44828           ID2=ID+6
44829         ELSE
44830           ID2=13
44831           IW2=IW1
44832         ENDIF
44833       ELSE IF (ID.NE.13) THEN
44834         IF (ID1.EQ.13) THEN
44835           ID2=ID-6
44836           IW2=IW1
44837         ELSE
44838           ID2=13
44839         ENDIF
44840       ELSE
44841         ID2=ID1
44842         IF (ID1.EQ.13) THEN
44843           IF (HWRLOG(HALF)) IW2=IW1
44844         ELSE IF (ID1.GT.6) THEN
44845           IW2=IW1
44846         END IF
44847       END IF
44848       IF (IW2.EQ.IW1) IW1=IW1+1
44849   999 END
44850 CDECK  ID>, HWSFUN.
44851 *CMZ :-        -02/05/91  11.30.51  by  Federico Carminati
44852 *-- Author :    Miscellaneous, combined by Bryan Webber
44853 C-----------------------------------------------------------------------
44854       SUBROUTINE HWSFUN(XIN,SCALE,IDHAD,NSET,DIST,IBEAM)
44855 C-----------------------------------------------------------------------
44856 C     NUCLEON AND PION STRUCTURE FUNCTIONS DIST=X*QRK(X,Q=SCALE)
44857 C
44858 C     IDHAD = TYPE OF HADRON:
44859 C     73=P  91=PBAR  75=N  93=NBAR  38=PI+  30=PI-  59=PHOTON
44860 C
44861 C     NEW SPECIAL CODES:
44862 C     71=`REMNANT PHOTON' 72=`REMNANT NUCLEON'
44863 C
44864 C     NSET = STRUCTURE FUNCTION SET
44865 C          = 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
44866 C          = 3,4 FOR EICHTEN ET AL SETS 1,2 (NUCLEON ONLY)
44867 C          = 5   FOR OWENS SET 1.1 (PREPRINT FSU-HEP-910606)
44868 C
44869 C     FOR PHOTON DREES+GRASSIE IS USED
44870 C
44871 C     N.B. IF IBEAM.GT.0.AND.MODPDF(IBEAM).GE.0 THEN NSET IS
44872 C     IGNORED AND CERN PDFLIB WITH AUTHOR GROUP=AUTPDF(IBEAM) AND
44873 C     SET=MODPDF(IBEAM) IS USED.  FOR COMPATABILITY WITH VERSIONS 3
44874 C     AND EARLIER, AUTPDF SHOULD BE SET TO 'MODE'
44875 C     NOTE THAT NO CONSISTENCY CHECK IS MADE, FOR EXAMPLE THAT THE
44876 C     REQUESTED SET FOR A PHOTON IS ACTUALLY A PHOTON SET
44877 C
44878 C     IF (ISPAC.GT.0) SCALE IS REPLACED BY MAX(SCALE,QSPAC)
44879 C
44880 C     IF (X.LT.PDFX0) REPLACE X*F(X) BY PDFX0*F(PDFX0)*(X/PDFX0)**PDFPOW
44881 C
44882 C     FOR PHOTON, IF (PHOMAS.GT.0) THEN QUARK DISTRIBUTIONS ARE
44883 C     SUPPRESSED BY      LOG((Q**2+PHOMAS**2)/(P**2+PHOMAS**2))
44884 C                    L = -------------------------------------- ,
44885 C                        LOG((Q**2+PHOMAS**2)/(     PHOMAS**2))
44886 C     WHILE GLUON DISTRIBUTIONS ARE SUPPRESSED BY L**2,
44887 C     WHERE Q=SCALE AND P=VIRTUALITY OF THE PHOTON
44888 C
44889 C   DUKE+OWENS = D.W.DUKE AND J.F.OWENS, PHYS. REV. D30 (1984) 49 (P/N)
44890 C              + J.F.OWENS, PHYS. REV. D30 (1984) 943 (PI+/-)
44891 C   WITH EXTRA SIGNIFICANT FIGURES VIA ED BERGER
44892 C   WARNING....MOMENTUM SUM RULE BADLY VIOLATED ABOVE 1 TEV
44893 C   DUKE+OWENS SETS 1,2 OBSOLETE. SET 1 UPDATED TO OWENS 1.1 (1991)
44894 C   PION NOT RELIABLE ABOVE SCALE = 50 GEV
44895 C
44896 C   EICHTEN ET AL = E.EICHTEN,I.HINCHLIFFE,K.LANE AND C.QUIGG,
44897 C                   REV. MOD. PHYS. 56 (1984) 579
44898 C   REVISED AS IN   REV. MOD. PHYS. 58 (1986) 1065
44899 C   RELIABLE RANGE : SQRT(5)GEV < SCALE < 10TEV, 1E-4 < X < 1
44900 C
44901 C   DREES+GRASSIE = M.DREES & K.GRASSIE, ZEIT. PHYS. C28 (1985) 451
44902 C   MODIFIED IN     M.DREES & C.S.KIM, DESY 91-039
44903 C                         AND C.S.KIM, DTP/91/16   FOR HEAVY QUARKS
44904 C
44905 C   FOR CERN PDFLIB DETAILS SEE PDFLIB DOC Q ON CERNVM OR
44906 C   CERN_ROOT:[DOC]PDFLIB.TXT ON VXCERN
44907 C-----------------------------------------------------------------------
44908 C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
44909 C-----------------------------------------------------------------------
44910       INCLUDE 'HERWIG65.INC'
44911       DOUBLE PRECISION HWSGAM,X,SCALE,XOLD,QOLD,XMWN,QSCA,SS,SMIN,S,T,
44912      & TMIN,TMAX,VX,AA,VT,WT,UPV,DNV,SEA,STR,CHM,BTM,TOP,GLU,WX,XQSUM,
44913      & DMIN,TPMIN,TPMAX,DIST(13),G(2),Q0(5),QL(5),F(5),A(6,5),
44914      & B(3,6,5,4),XQ(6),TX(6),TT(6),TB(6),NEHLQ(8,2),CEHLQ(6,6,2,8,2),
44915      & BB(4,6,5),VAL(20),USEA,DSEA,TOTAL,SCALEF,FAC,TBMIN(2),TTMIN(2)
44916       DOUBLE PRECISION XIN,PDFFAC
44917       REAL HWSDGG,HWSDGQ,XSP,Q2,P2,W2,EMB2,EMC2,ALAM2,XPGA(-6:6),F2GM,
44918      & XPVMD,XPANL,XPANH,XPBEH,XPDIR
44919       COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
44920      &     XPDIR(-6:6)
44921       LOGICAL PDFWRX(2,2),PDFWRQ(2,2)
44922       DOUBLE PRECISION PDFXMN,PDFXMX,PDFQMN,PDFQMX
44923       COMMON /W50513/PDFXMN,PDFXMX,PDFQMN,PDFQMX
44924       INTEGER IDHAD,NSET,IBEAM,IOLD,NOLD,IP,I,J,K,NX,IT,IX,IFL,NFL,
44925      & MPDF,IHAD,ISET,IOP1,IOP2,IP2
44926       CHARACTER*20 PARM(20)
44927       CHARACTER*20 PARMSAVE
44928       DOUBLE PRECISION VALSAVE
44929       COMMON/HWSFSA/PARMSAVE
44930       COMMON/HWSFSB/VALSAVE
44931       EXTERNAL HWSGAM,HWSDGG,HWSDGQ
44932       SAVE QOLD,IOLD,NOLD,XOLD,SS,S,T,TMIN,TMAX,G,A,TX,TT,TB,IP,NX
44933       DATA PDFWRX,PDFWRQ/8*.TRUE./
44934       DATA (((B(I,J,K,1),I=1,3),J=1,6),K=1,5)/
44935      &3.D0,0.D0,0.D0,.419D0,.004383D0,-.007412D0,
44936      &3.46D0,.72432D0,-.065998D0,4.4D0,-4.8644D0,1.3274D0,
44937      &6*0.D0,1.D0,
44938      &0.D0,0.D0,.763D0,-.23696D0,.025836D0,4.D0,.62664D0,-.019163D0,
44939      &0.D0,-.42068D0,.032809D0,6*0.D0,1.265D0,-1.1323D0,.29268D0,
44940      &0.D0,-.37162D0,-.028977D0,8.05D0,1.5877D0,-.15291D0,
44941      &0.D0,6.3059D0,-.27342D0,0.D0,-10.543D0,-3.1674D0,
44942      &0.D0,14.698D0,9.798D0,0.D0,.13479D0,-.074693D0,
44943      &-.0355D0,-.22237D0,-.057685D0,6.3494D0,3.2649D0,-.90945D0,
44944      &0.D0,-3.0331D0,1.5042D0,0.D0,17.431D0,-11.255D0,
44945      &0.D0,-17.861D0,15.571D0,1.564D0,-1.7112D0,.63751D0,
44946      &0.D0,-.94892D0,.32505D0,6.D0,1.4345D0,-1.0485D0,
44947      &9.D0,-7.1858D0,.25494D0,0.D0,-16.457D0,10.947D0,
44948      &0.D0,15.261D0,-10.085D0/
44949       DATA (((B(I,J,K,2),I=1,3),J=1,6),K=1,5)/
44950      &3.D0,0.D0,0.D0,.3743D0,.013946D0,-.00031695D0,
44951      &3.329D0,.75343D0,-.076125D0,6.032D0,-6.2153D0,1.5561D0,
44952      &6*0.D0,1.D0,0.D0,
44953      &0.D0,.7608D0,-.2317D0,.023232D0,3.83D0,.62746D0,-.019155D0,
44954      &0.D0,-.41843D0,.035972D0,6*0.D0,1.6714D0,-1.9168D0,.58175D0,
44955      &0.D0,-.27307D0,-.16392D0,9.145D0,.53045D0,-.76271D0,
44956      &0.D0,15.665D0,-2.8341D0,0.D0,-100.63D0,44.658D0,
44957      &0.D0,223.24D0,-116.76D0,0.D0,.067368D0,-.030574D0,
44958      &-.11989D0,-.23293D0,-.023273D0,3.5087D0,3.6554D0,-.45313D0,
44959      &0.D0,-.47369D0,.35793D0,0.D0,9.5041D0,-5.4303D0,
44960      &0.D0,-16.563D0,15.524D0,.8789D0,-.97093D0,.43388D0,
44961      &0.D0,-1.1612D0,.4759D0,4.D0,1.2271D0,-.25369D0,
44962      &9.D0,-5.6354D0,-.81747D0,0.D0,-7.5438D0,5.5034D0,
44963      &0.D0,-.59649D0,.12611D0/
44964       DATA (((B(I,J,K,3),I=1,3),J=1,6),K=1,5)/
44965      &1.D0,0.D0,0.D0,0.4D0,-0.06212D0,-0.007109D0,0.7D0,0.6478D0,
44966      &0.01335D0,27*0.D0,0.9D0,-0.2428D0,0.1386D0,0.D0,-0.2120D0,
44967      &0.003671D0,5.0D0,0.8673D0,0.04747D0,
44968      &0.D0,1.266D0,-2.215D0,0.D0,2.382D0,0.3482D0,3*0.D0,
44969      &0.D0,0.07928D0,-0.06134D0,-0.02212D0,-0.3785D0,-0.1088D0,2.894D0,
44970      &9.433D0,
44971      &-10.852D0,0.D0,5.248D0,-7.187D0,0.D0,8.388D0,-11.61D0,3*0.D0,
44972      &0.888D0,-1.802D0,1.812D0,0.D0,-1.576D0,1.20D0,3.11D0,-0.1317D0,
44973      &0.5068D0,6.0D0,2.801D0,-12.16D0,0.D0,-17.28D0,20.49D0,3*0.D0/
44974       DATA (((B(I,J,K,4),I=1,3),J=1,6),K=1,5)/
44975      &1.D0,0.D0,0.D0,0.4D0,-0.05909D0,-0.006524D0,0.628D0,0.6436D0,
44976      &0.01451D0,27*0.D0,
44977      &0.90D0,-0.1417D0,-0.1740D0,0.D0,-0.1697D0,-0.09623D0,5.0D0,
44978      &-2.474D0,1.575D0,
44979      &0.D0,-2.534D0,1.378D0,0.D0,0.5621D0,-0.2701D0,3*0.D0,
44980      &0.D0,0.06229D0,-0.04099D0,-0.0882D0,-0.2892D0,-0.1082D0,1.924D0,
44981      &0.2424D0,
44982      &2.036D0,0.D0,-4.463D0,5.209D0,0.D0,-0.8367D0,-0.04840D0,3*0.D0,
44983      &0.794D0,-0.9144D0,0.5966D0,0.D0,-1.237D0,0.6582D0,2.89D0,0.5966D0,
44984      &-0.2550D0,
44985      &6.0D0,-3.671D0,-2.304D0,0.D0,-8.191D0,7.758D0,3*0.D0/
44986 C---COEFFTS FOR NEW OWENS 1.1 SET
44987       DATA BB/3.D0,3*0.D0,.665D0,-.1097D0,-.002442D0,0.D0,
44988      &3.614D0,.8395D0,-.02186D0,0.D0,.8673D0,-1.6637D0,.342D0,0.D0,
44989      &0.D0,1.1049D0,-.2369D0,5*0.D0,1.D0,3*0.D0,
44990      &.8388D0,-.2092D0,.02657D0,0.D0,4.667D0,.7951D0,.1081D0,0.D0,
44991      &0.D0,-1.0232D0,.05799D0,0.D0,0.D0,.8616D0,.153D0,5*0.D0,
44992      &.909D0,-.4023D0,.006305D0,0.D0,
44993      &0.D0,-.3823D0,.02766D0,0.D0,7.278D0,-.7904D0,.8108D0,0.D0,
44994      &0.D0,-1.6629D0,.5719D0,0.D0,0.D0,-.01333D0,.5299D0,0.D0,
44995      &0.D0,.1211D0,-.1739D0,0.D0,0.D0,.09469D0,-.07066D0,.01236D0,
44996      &-.1447D0,-.402D0,.1533D0,-.06479D0,6.7599D0,1.6596D0,.6798D0,
44997      &-.8525D0,0.D0,-4.4559D0,3.3756D0,-.9468D0,
44998      &0.D0,7.862D0,-3.6591D0,.03672D0,0.D0,-.2472D0,-.751D0,.0487D0,
44999      &3.017D0,-4.7347D0,3.3594D0,-.9443D0,0.D0,-.9342D0,.5454D0,
45000      &-.1668D0,
45001      &5.304D0,1.4654D0,-1.4292D0,.7569D0,0.D0,-3.9141D0,2.8445D0,
45002      &-.8411D0,
45003      &0.D0,9.0176D0,-10.426D0,4.0983D0,0.D0,-5.9602D0,7.515D0,-2.7329D0/
45004 C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
45005 C...EICHTEN, HINCHLIFFE, LANE, QUIGG PROTON STRUCTURE FUNCTION
45006 C...POWERS OF 1-X IN DIFFERENT CASES
45007       DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
45008 C...EXPANSION COEFFICIENTS FOR UP VALENCE QUARK DISTRIBUTION
45009       DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
45010      1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
45011      2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
45012      3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
45013      4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
45014      5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
45015      6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
45016      1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
45017      2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
45018      3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
45019      4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
45020      5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
45021      6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
45022       DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
45023      1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
45024      2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
45025      3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
45026      4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
45027      5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
45028      6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
45029      1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
45030      2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
45031      3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
45032      4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
45033      5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
45034      6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
45035 C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION
45036       DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
45037      1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
45038      2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
45039      3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
45040      4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
45041      5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
45042      6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
45043      1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
45044      2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
45045      3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
45046      4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
45047      5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
45048      6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
45049       DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
45050      1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
45051      2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
45052      3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
45053      4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
45054      5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
45055      6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
45056      1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
45057      2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
45058      3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
45059      4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
45060      5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
45061      6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
45062 C...EXPANSION COEFFICIENTS FOR UP AND DOWN SEA QUARK DISTRIBUTIONS
45063       DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
45064      1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
45065      2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
45066      3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
45067      4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
45068      5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
45069      6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
45070      1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
45071      2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
45072      3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
45073      4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
45074      5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
45075      6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
45076       DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
45077      1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
45078      2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
45079      3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
45080      4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
45081      5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
45082      6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
45083      1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
45084      2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
45085      3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
45086      4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
45087      5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
45088      6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
45089 C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION
45090       DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
45091      1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
45092      2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
45093      3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
45094      4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
45095      5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
45096      6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
45097      1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
45098      2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
45099      3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
45100      4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
45101      5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
45102      6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
45103       DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
45104      1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
45105      2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
45106      3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
45107      4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
45108      5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
45109      6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
45110      1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
45111      2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
45112      3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
45113      4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
45114      5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
45115      6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
45116 C...EXPANSION COEFFICIENTS FOR STRANGE SEA QUARK DISTRIBUTION
45117       DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
45118      1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
45119      2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
45120      3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
45121      4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
45122      5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
45123      6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
45124      1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
45125      2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
45126      3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
45127      4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
45128      5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
45129      6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
45130       DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
45131      1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
45132      2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
45133      3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
45134      4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
45135      5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
45136      6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
45137      1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
45138      2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
45139      3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
45140      4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
45141      5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
45142      6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
45143 C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION
45144       DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
45145      1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
45146      2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
45147      3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
45148      4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
45149      5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
45150      6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
45151      1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
45152      2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
45153      3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
45154      4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
45155      5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
45156      6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
45157       DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
45158      1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
45159      2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
45160      3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
45161      4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
45162      5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
45163      6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
45164      1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
45165      2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
45166      3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
45167      4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
45168      5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
45169      6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
45170 C...EXPANSION COEFFICIENTS FOR BOTTOM SEA QUARK DISTRIBUTION
45171       DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
45172      1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
45173      2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
45174      3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
45175      4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
45176      5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
45177      6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
45178      1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
45179      2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
45180      3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
45181      4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
45182      5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
45183      6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
45184       DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
45185      1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
45186      2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
45187      3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
45188      4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
45189      5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
45190      6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
45191      1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
45192      2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
45193      3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
45194      4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
45195      5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
45196      6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
45197 C...EXPANSION COEFFICIENTS FOR TOP SEA QUARK DISTRIBUTION
45198       DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
45199      1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
45200      2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
45201      3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
45202      4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
45203      5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
45204      6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
45205      1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
45206      2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
45207      3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
45208      4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
45209      5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
45210      6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
45211       DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
45212      1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
45213      2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
45214      3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
45215      4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
45216      5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
45217      6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
45218      1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
45219      2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
45220      3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
45221      4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
45222      5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
45223      6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
45224       DATA TBMIN,TTMIN/8.1905D0,7.4474D0,11.5528D0,10.8097D0/
45225       DATA XOLD,QOLD,IOLD,NOLD/-1.D0,0.D0,0,0/
45226       DATA DMIN,Q0,QL/0.D0,2*2.D0,2*2.236D0,2.D0,.2D0,
45227      &                .4D0,.2D0,.29D0,.177D0/
45228 C---X IS EQUAL TO XIN, UNLESS IT IS LESS THAN PDFX0
45229       X=MAX(XIN,PDFX0)
45230       IF (X.LE.ZERO) CALL HWWARN('HWSFUN',100,*999)
45231       XMWN=ONE-X
45232       IF (XMWN.LE.ZERO) THEN
45233         DO 1 I=1,13
45234           DIST(I)=0
45235  1      CONTINUE
45236         RETURN
45237       ENDIF
45238 C---FREEZE THE SCALE IF REQUIRED
45239       SCALEF=SCALE
45240       IF (ISPAC.GT.0) SCALEF=MAX(SCALEF,QSPAC)
45241 C---CHECK IF PDFLIB REQUESTED
45242       IF (IBEAM.EQ.1.OR.IBEAM.EQ.2) THEN
45243         MPDF=MODPDF(IBEAM)
45244       ELSE
45245         MPDF=-1
45246       ENDIF
45247       QSCA=ABS(SCALEF)
45248       IF (IDHAD.EQ.59.OR.IDHAD.EQ.71) THEN
45249         IF (MPDF.GE.0) THEN
45250 C---USE PDFLIB PHOTON STRUCTURE FUNCTIONS
45251           PARM(1)=AUTPDF(IBEAM)
45252           VAL(1)=FLOAT(MPDF)
45253 C---FIX TO CALL SCHULER-SJOSTRAND CODE
45254           IF (AUTPDF(IBEAM).EQ.'SaSph') THEN
45255             XSP=X
45256             IF (    XSP.LE.ZERO) CALL HWWARN('HWSFUN',102,*999)
45257             IF (ONE-XSP.LE.ZERO) CALL HWWARN('HWSFUN',103,*999)
45258             Q2=QSCA**2
45259             ISET=MOD(MODPDF(IBEAM),10)
45260             IOP1=MOD(MODPDF(IBEAM)/10,2)
45261             IOP2=MOD(MODPDF(IBEAM)/20,2)
45262             IP2=MODPDF(IBEAM)/100
45263             IF (IOP2.EQ.0) THEN
45264               P2=0.
45265             ELSE
45266               IHAD=IBEAM
45267               IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
45268               P2=PHEP(5,IHAD)**2
45269             ENDIF
45270             CALL SASGAM(ISET,XSP,Q2,P2,IP2,F2GM,XPGA)
45271             IF (IOP1.EQ.1 .AND. ISTAT.LT.10) THEN
45272               DO 5 I=-6,6
45273  5            XPGA(I)=XPVMD(I)+XPANL(I)+XPBEH(I)+XPDIR(I)
45274             ENDIF
45275             UPV=XPGA(2)
45276             DNV=XPGA(1)
45277             USEA=XPGA(2)
45278             DSEA=XPGA(1)
45279             STR=XPGA(3)
45280             CHM=XPGA(4)
45281             BTM=XPGA(5)
45282             TOP=XPGA(6)
45283             GLU=XPGA(0)
45284           ELSE
45285             IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
45286               PARMSAVE=PARM(1)
45287               VALSAVE=VAL(1)
45288               CALL PDFSET(PARM,VAL)
45289             ENDIF
45290             IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
45291      &          X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
45292               CALL HWWARN('HWSFUN',2,*999)
45293               WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
45294      &             ' OUTSIDE ALLOWED RANGE!'
45295               WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
45296      &             ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
45297               WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45298               IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
45299               IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
45300             ENDIF
45301             IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
45302      &          QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
45303               CALL HWWARN('HWSFUN',3,*999)
45304               WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
45305      &             ' OUTSIDE ALLOWED RANGE!'
45306               WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
45307      &             ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
45308               WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45309               IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
45310               IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
45311             ENDIF
45312             CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
45313           ENDIF
45314           DIST(1)=DSEA
45315           DIST(2)=USEA
45316           DIST(7)=DSEA
45317           DIST(8)=USEA
45318         ELSE
45319           XSP=X
45320           IF (    XSP.LE.ZERO) CALL HWWARN('HWSFUN',102,*999)
45321           IF (ONE-XSP.LE.ZERO) CALL HWWARN('HWSFUN',103,*999)
45322           Q2=SCALEF**2
45323           W2=Q2*(1-X)/X
45324           EMC2=4*RMASS(4)**2
45325           EMB2=4*RMASS(5)**2
45326           ALAM2=0.160
45327           NFL=3
45328           IF (Q2.GT.50.) NFL=4
45329           IF (Q2.GT.500.) NFL=5
45330           STR=HWSDGQ(XSP,Q2,NFL,1)
45331           CHM=HWSDGQ(XSP,Q2,NFL,2)
45332           GLU=HWSDGG(XSP,Q2,NFL)
45333           DIST(1)=STR
45334           DIST(2)=CHM
45335           DIST(7)=STR
45336           DIST(8)=CHM
45337           IF (W2.GT.EMB2) THEN
45338             BTM=STR
45339             IF (W2*ALAM2.LT.Q2*EMB2)
45340      &          BTM=BTM*LOG(W2/EMB2)/LOG(Q2/ALAM2)
45341           ELSE
45342             BTM=0.
45343           ENDIF
45344           IF (W2.GT.EMC2) THEN
45345             IF (W2*ALAM2.LT.Q2*EMC2)
45346      &          CHM=CHM*LOG(W2/EMC2)/LOG(Q2/ALAM2)
45347           ELSE
45348             CHM=0.
45349           ENDIF
45350           TOP=0.
45351         ENDIF
45352 C---INCLUDE SUPPRESSION FROM PHOTON VIRTUALITY IF NECESSARY
45353         IF (PHOMAS.GT.ZERO.AND.(IBEAM.EQ.1.OR.IBEAM.EQ.2)) THEN
45354           IHAD=IBEAM
45355           IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
45356           IF (IDHW(IHAD).EQ.59) THEN
45357             FAC=LOG((QSCA**2+PHOMAS**2)/(PHEP(5,IHAD)**2+PHOMAS**2))/
45358      $          LOG((QSCA**2+PHOMAS**2)/(                PHOMAS**2))
45359             IF (FAC.LT.ZERO) FAC=ZERO
45360             DIST(1)=DIST(1)*FAC
45361             DIST(2)=DIST(2)*FAC
45362             DIST(7)=DIST(7)*FAC
45363             DIST(8)=DIST(8)*FAC
45364             STR=STR*FAC
45365             CHM=CHM*FAC
45366             BTM=BTM*FAC
45367             TOP=TOP*FAC
45368             GLU=GLU*FAC**2
45369           ELSE
45370             CALL HWWARN('HWSFUN',1,*999)
45371           ENDIF
45372         ENDIF
45373         GOTO 900
45374       ENDIF
45375       IF (MPDF.GE.0) THEN
45376 C---USE PDFLIB NUCLEON STRUCTURE FUNCTIONS
45377         PARM(1)=AUTPDF(IBEAM)
45378         VAL(1)=FLOAT(MPDF)
45379         IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
45380           PARMSAVE=PARM(1)
45381           VALSAVE=VAL(1)
45382           CALL PDFSET(PARM,VAL)
45383         ENDIF
45384         IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
45385      &      X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
45386           CALL HWWARN('HWSFUN',4,*999)
45387           WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
45388      &         ' OUTSIDE ALLOWED RANGE!'
45389           WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
45390      &         ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
45391           WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45392           IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
45393           IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
45394         ENDIF
45395         IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
45396      &      QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
45397           CALL HWWARN('HWSFUN',5,*999)
45398           WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
45399      &         ' OUTSIDE ALLOWED RANGE!'
45400           WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
45401      &         ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
45402           WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45403           IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
45404           IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
45405         ENDIF
45406         CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
45407 C--new MRST98 LO PDF's
45408       ELSEIF(NSET.GE.6.AND.NSET.LE.8) THEN
45409         CALL HWSMRS(X,SCALEF,NSET-5,UPV,DNV,USEA,DSEA,STR,CHM,BTM,GLU)
45410         TOP=ZERO
45411       ELSE
45412         IF (NSET.LT.1.OR.NSET.GT.5) CALL HWWARN('HWSFUN',400,*999)
45413         IF (QSCA.LT.Q0(NSET)) QSCA=Q0(NSET)
45414         IF (QSCA.NE.QOLD.OR.IDHAD.NE.IOLD.OR.NSET.NE.NOLD) THEN
45415 C---INITIALIZE
45416           QOLD=QSCA
45417           IOLD=IDHAD
45418           NOLD=NSET
45419           SS=LOG(QSCA/QL(NSET))
45420           SMIN=LOG(Q0(NSET)/QL(NSET))
45421           IF (NSET.LT.3.OR.NSET.EQ.5) THEN
45422             S=LOG(SS/SMIN)
45423           ELSE
45424             T=2.*SS
45425             TMIN=2.*SMIN
45426             TMAX=2.*LOG(1.E4/QL(NSET))
45427           ENDIF
45428           IF (IDHAD.GE.72) THEN
45429             IF (NSET.LT.3) THEN
45430               IP=NSET
45431               DO 10 I=1,5
45432               DO 10 J=1,6
45433    10         A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
45434               DO 20 K=1,2
45435               AA=ONE+A(2,K)+A(3,K)
45436    20         G(K)=HWSGAM(AA)/((ONE+A(2,K)*A(4,K)/AA)*HWSGAM(A(2,K))
45437      &            *HWSGAM(ONE+A(3,K)))
45438             ELSEIF (NSET.EQ.5) THEN
45439               DO 21 I=1,5
45440               DO 21 J=1,6
45441    21         A(J,I)=BB(1,J,I)+S*(BB(2,J,I)+S*(BB(3,J,I)+S*BB(4,J,I)))
45442               DO 22 K=1,2
45443               AA=ONE+A(2,K)+A(3,K)
45444    22         G(K)=HWSGAM(AA)/((ONE+A(2,K)/AA*(A(4,K)+
45445      &            (ONE+A(2,K))/(ONE+AA)*A(5,K)))*HWSGAM(A(2,K))
45446      &            *HWSGAM(ONE+A(3,K)))
45447             ELSE
45448               IP=NSET-2
45449               VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
45450               WT=VT*VT
45451 C...CHEBYSHEV POLYNOMIALS FOR T EXPANSION
45452               TT(1)=1.
45453               TT(2)=VT
45454               TT(3)=   2.*WT- 1.
45455               TT(4)=  (4.*WT- 3.)*VT
45456               TT(5)=  (8.*WT- 8.)*WT+1.
45457               TT(6)=((16.*WT-20.)*WT+5.)*VT
45458             ENDIF
45459           ELSEIF (NSET.LT.3) THEN
45460               IP=NSET+2
45461               DO 30 I=1,5
45462               DO 30 J=1,6
45463    30         A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
45464               AA=ONE+A(2,1)+A(3,1)
45465               G(1)=HWSGAM(AA)/(HWSGAM(A(2,1))*HWSGAM(ONE+A(3,1)))
45466               G(2)=0.
45467            ENDIF
45468         ENDIF
45469 C
45470         IF (NSET.LT.3.OR.NSET.EQ.5) THEN
45471           DO 50 I=1,5
45472    50     F(I)=A(1,I)*X**A(2,I)*XMWN**A(3,I)*(ONE+X*
45473      &        (A(4,I)+X*(A(5,I)  +  X*A(6,I))))
45474           F(1)=F(1)*G(1)
45475           F(2)=F(2)*G(2)
45476           UPV=F(1)-F(2)
45477           DNV=F(2)
45478           SEA=F(3)/6.
45479           STR=SEA
45480           CHM=F(4)
45481           BTM=ZERO
45482           TOP=ZERO
45483           GLU=F(5)
45484         ELSE
45485           IF (X.NE.XOLD) THEN
45486             XOLD=X
45487             IF (X.GT.0.1) THEN
45488               NX=1
45489               VX=(2.*X-1.1)/0.9
45490             ELSE
45491               NX=2
45492               VX=MAX(-ONE,(2.*LOG(X)+11.51293)/6.90776)
45493             ENDIF
45494             WX=VX*VX
45495             TX(1)=1.
45496             TX(2)=VX
45497             TX(3)=   2.*WX- 1.
45498             TX(4)=  (4.*WX- 3.)*VX
45499             TX(5)=  (8.*WX- 8.)*WX+1.
45500             TX(6)=((16.*WX-20.)*WX+5.)*VX
45501           ENDIF
45502 C...CALCULATE STRUCTURE FUNCTIONS
45503           DO 120 IFL=1,6
45504           XQSUM=0.
45505           DO 110 IT=1,6
45506           DO 110 IX=1,6
45507   110     XQSUM=XQSUM+CEHLQ(IX,IT,NX,IFL,IP)*TX(IX)*TT(IT)
45508   120     XQ(IFL)=XQSUM*XMWN**NEHLQ(IFL,IP)
45509           UPV=XQ(1)
45510           DNV=XQ(2)
45511           STR=XQ(5)
45512           CHM=XQ(6)
45513           SEA=XQ(3)
45514           GLU=XQ(4)
45515 C...SPECIAL EXPANSION FOR BOTTOM (THRESHOLD EFFECTS)
45516           IF (NFLAV.LT.5.OR.T.LE.TBMIN(IP)) THEN
45517             BTM=0.
45518           ELSE
45519             VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TBMIN(IP))/(TMAX-TBMIN(IP))))
45520             WT=VT*VT
45521             TB(1)=1.
45522             TB(2)=VT
45523             TB(3)=   2.*WT- 1.
45524             TB(4)=  (4.*WT- 3.)*VT
45525             TB(5)=  (8.*WT- 8.)*WT+1.
45526             TB(6)=((16.*WT-20.)*WT+5.)*VT
45527             XQSUM=0.
45528             DO 130 IT=1,6
45529             DO 130 IX=1,6
45530   130       XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,IP)*TX(IX)*TB(IT)
45531             BTM=XQSUM*XMWN**NEHLQ(7,IP)
45532           ENDIF
45533 C...SPECIAL EXPANSION FOR TOP (THRESHOLD EFFECTS)
45534           TPMIN=TTMIN(IP)+TMTOP
45535 C---TMTOP=2.*LOG(TOPMAS/30.)
45536           TPMAX=TMAX+TMTOP
45537           IF (NFLAV.LT.6.OR.T.LE.TPMIN) THEN
45538             TOP=0.
45539           ELSE
45540             VT=MAX(-ONE,MIN(ONE,(2.*T-TPMAX-TPMIN)/(TPMAX-TPMIN)))
45541             WT=VT*VT
45542             TB(1)=1.
45543             TB(2)=VT
45544             TB(3)=   2.*WT- 1.
45545             TB(4)=  (4.*WT- 3.)*VT
45546             TB(5)=  (8.*WT- 8.)*WT+1.
45547             TB(6)=((16.*WT-20.)*WT+5.)*VT
45548             XQSUM=0.
45549             DO 150 IT=1,6
45550             DO 150 IX=1,6
45551   150       XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,IP)*TX(IX)*TB(IT)
45552             TOP=XQSUM*XMWN**NEHLQ(8,IP)
45553           ENDIF
45554         ENDIF
45555       ENDIF
45556       IF (MPDF.LT.0.AND.NSET.LE.5) THEN
45557         USEA=SEA
45558         DSEA=USEA
45559       ENDIF
45560       IF(MPDF.LT.0.AND.NSET.GT.2.AND.(IDHAD.EQ.38.OR.IDHAD.EQ.30)) THEN
45561         WRITE(6,*) '     THIS SET OF PDFS DOES NOT SUPPORT PIONS'
45562         WRITE(6,*) 'EITHER USE SET NSTRU=1,2 OR A PION SET FROM PDFLIB'
45563         STOP
45564       ENDIF
45565       IF (IDHAD.EQ.73.OR.IDHAD.EQ.72) THEN
45566          DIST(1)=DSEA+DNV
45567          DIST(2)=USEA+UPV
45568          DIST(7)=DSEA
45569          DIST(8)=USEA
45570       ELSEIF (IDHAD.EQ.91) THEN
45571          DIST(1)=DSEA
45572          DIST(2)=USEA
45573          DIST(7)=DSEA+DNV
45574          DIST(8)=USEA+UPV
45575       ELSEIF (IDHAD.EQ.75) THEN
45576          DIST(1)=USEA+UPV
45577          DIST(2)=DSEA+DNV
45578          DIST(7)=USEA
45579          DIST(8)=DSEA
45580       ELSEIF (IDHAD.EQ.93) THEN
45581          DIST(1)=USEA
45582          DIST(2)=DSEA
45583          DIST(7)=USEA+UPV
45584          DIST(8)=DSEA+DNV
45585       ELSEIF (IDHAD.EQ.38) THEN
45586          DIST(1)=USEA
45587          DIST(2)=USEA+UPV
45588          DIST(7)=USEA+UPV
45589          DIST(8)=USEA
45590       ELSEIF (IDHAD.EQ.30) THEN
45591          DIST(1)=USEA+UPV
45592          DIST(2)=USEA
45593          DIST(7)=USEA
45594          DIST(8)=USEA+UPV
45595       ELSE
45596          PRINT *,' CALLED HWSFUN FOR IDHAD =',IDHAD
45597          CALL HWWARN('HWSFUN',400,*999)
45598       ENDIF
45599   900 DIST(3)=STR
45600       DIST(4)=CHM
45601       DIST(5)=BTM
45602       DIST(6)=TOP
45603       DIST(9)=STR
45604       DIST(10)=CHM
45605       DIST(11)=BTM
45606       DIST(12)=TOP
45607       DIST(13)=GLU
45608       DO 901 I=1,13
45609       IF (DIST(I).LT.DMIN) DIST(I)=DMIN
45610   901 CONTINUE
45611 C---FOR REMNANT NUCLEONS SWITCH OFF VALENCE QUARKS,
45612 C   WHILE MAINTAINING MOMENTUM SUM RULE
45613       IF (IDHAD.EQ.72) THEN
45614         TOTAL=0
45615         DO 910 I=1,13
45616           TOTAL=TOTAL+DIST(I)
45617  910    CONTINUE
45618         DIST(1)=DIST(1)-DNV
45619         DIST(2)=DIST(2)-UPV
45620         IF (TOTAL.GT.DNV+UPV) THEN
45621           DO 920 I=1,13
45622             DIST(I)=DIST(I)*TOTAL/(TOTAL-DNV-UPV)
45623  920      CONTINUE
45624         ENDIF
45625       ENDIF
45626 C---IF X HAS BEEN FROZEN USE A POWER LAW
45627       IF (XIN.LT.PDFX0) THEN
45628         PDFFAC=(XIN/PDFX0)**PDFPOW
45629         DO 930 I=1,13
45630           DIST(I)=DIST(I)*PDFFAC
45631  930    CONTINUE
45632       ENDIF
45633   999 END
45634 CDECK  ID>, HWSGAM.
45635 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
45636 *-- Author :    Adapted by Bryan Webber
45637 C-----------------------------------------------------------------------
45638       FUNCTION HWSGAM(ZINPUT)
45639 C-----------------------------------------------------------------------
45640 C   Gamma function computed by eq. 6.1.40, Abramowitz.
45641 C   B(M) = B2m/(2m *(2m-1)) where B2m is the 2m'th Bernoulli number.
45642 C   HLNTPI = .5*LOG(2.*PI)
45643 C-----------------------------------------------------------------------
45644       DOUBLE PRECISION HWSGAM,ZINPUT,B(10),HLNTPI,Z,SHIFT,G,T,RECZSQ
45645       INTEGER I
45646       DATA B/
45647      1       0.83333333333333333333D-01,   -0.27777777777777777778D-02,
45648      1       0.79365079365079365079D-03,   -0.59523809523809523810D-03,
45649      1       0.84175084175084175084D-03,   -0.19175269175269175269D-02,
45650      1       0.64102564102564102564D-02,   -0.29550653594771241830D-01,
45651      1       0.17964437236883057316D0  ,    -1.3924322169059011164D0  /
45652       DATA HLNTPI/0.91893853320467274178D0/
45653 C
45654 C   Shift argument to large value ( > 20 )
45655 C
45656       Z=ZINPUT
45657       SHIFT=1.
45658    10 IF (Z.LT.20.D0) THEN
45659          SHIFT = SHIFT*Z
45660          Z = Z + 1.D0
45661          GOTO 10
45662       ENDIF
45663 C
45664 C   Compute asymptotic formula
45665 C
45666       G = (Z-.5D0)*LOG(Z) - Z + HLNTPI
45667       T = 1.D0/Z
45668       RECZSQ = T**2
45669       DO 20 I = 1,10
45670          G = G + B(I)*T
45671          T = T*RECZSQ
45672    20 CONTINUE
45673       HWSGAM = EXP(G)/SHIFT
45674       END
45675 CDECK  ID>, HWSGEN.
45676 *CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
45677 *-- Author :    Bryan Webber
45678 C-----------------------------------------------------------------------
45679       SUBROUTINE HWSGEN(GENEX)
45680 C-----------------------------------------------------------------------
45681 C     GENERATES X VALUES (IF GENEX)
45682 C     EVALUATES STRUCTURE FUNCTIONS AND ENFORCES CUTOFFS ON X
45683 C-----------------------------------------------------------------------
45684       INCLUDE 'HERWIG65.INC'
45685       DOUBLE PRECISION HWBVMC,HWRUNI,X,QL
45686       INTEGER I,J
45687       LOGICAL GENEX
45688       EXTERNAL HWBVMC,HWRUNI
45689       IF (GENEX) THEN
45690         XX(1)=EXP(HWRUNI(0,ZERO,XLMIN))
45691         XX(2)=XXMIN/XX(1)
45692       ENDIF
45693       DO 10 I=1,2
45694         J=I
45695         IF (JDAHEP(1,I).NE.0) J=JDAHEP(1,I)
45696         X=XX(I)
45697         QL=(1.-X)*EMSCA
45698         CALL HWSFUN(X,EMSCA,IDHW(J),NSTRU,DISF(1,I),I)
45699       DO 10 J=1,13
45700         IF (QL.LT.HWBVMC(J)) DISF(J,I)=0.
45701    10 CONTINUE
45702       END
45703 CDECK  ID>, HWSGQQ.
45704 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
45705 *-- Author :    Bryan Webber
45706 C-----------------------------------------------------------------------
45707       FUNCTION HWSGQQ(QSCA)
45708 C-----------------------------------------------------------------------
45709 C     CORRECTION TO GLUON STRUCTURE FUNCTION FOR BACKWARD EVOLUTION:
45710 C     G->Q-QBAR PART OF FORM FACTOR
45711 C-----------------------------------------------------------------------
45712       INCLUDE 'HERWIG65.INC'
45713       DOUBLE PRECISION HWSGQQ,HWUALF,QSCA,GG
45714       EXTERNAL HWUALF
45715       GG=HWUALF(1,QSCA)**(-ONE/BETAF)
45716       IF (GG.LT.ONE) GG=ONE
45717       IF (QSCA.GT.RMASS(6)) THEN
45718         HWSGQQ=GG**6
45719       ELSEIF (QSCA.GT.RMASS(5)) THEN
45720         HWSGQQ=GG**5
45721       ELSEIF (QSCA.GT.RMASS(4)) THEN
45722         HWSGQQ=GG**4
45723       ELSE
45724         HWSGQQ=GG**3
45725       ENDIF
45726       END
45727 CDECK  ID>, HWSMRS.
45728 *CMZ :-        -26/04/01  10.00.16  by  Peter Richardson
45729 *-- Author :    Dick Roberts, modified by Peter Richardson
45730 C-----------------------------------------------------------------------
45731       SUBROUTINE HWSMRS(X,Q,MODE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU)
45732 C-----------------------------------------------------------------------
45733 C     MRST98 Leading order PDF's central and higher gluon + average
45734 C-----------------------------------------------------------------------
45735       INCLUDE 'HERWIG65.INC'
45736       DOUBLE PRECISION X,Q,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU,XMIN,XMAX,
45737      &     QSQMIN,QSQMAX,Q2,QQ(NQMRS),XXMRS(NXMRS),G(NPMRS),N0(NPMRS),
45738      &     XSAVE,Q2SAVE,XXX,A,B,FAC
45739       INTEGER MODE,INIT,NTENTH,N,M,I,J,K,ML,WARN(2)
45740       PARAMETER(NTENTH=23)
45741       DATA XMIN,XMAX,QSQMIN,QSQMAX/1D-5,1D0,1.25D0,1D7/
45742       DATA XXMRS/1d-5,2d-5,4d-5,6d-5,8d-5,
45743      &        1d-4,2d-4,4d-4,6d-4,8d-4,
45744      &        1d-3,2d-3,4d-3,6d-3,8d-3,
45745      &        1d-2,1.4d-2,2d-2,3d-2,4d-2,6d-2,8d-2,
45746      &     .1d0,.125d0,.15d0,.175d0,.2d0,.225d0,.25d0,.275d0,
45747      &     .3d0,.325d0,.35d0,.375d0,.4d0,.425d0,.45d0,.475d0,
45748      &     .5d0,.525d0,.55d0,.575d0,.6d0,.65d0,.7d0,.75d0,
45749      &     .8d0,.9d0,1d0/
45750       DATA QQ/1.25d0,1.5d0,2d0,2.5d0,3.2d0,4d0,5d0,6.4d0,8d0,1d1,
45751      &        1.2d1,1.8d1,2.6d1,4d1,6.4d1,1d2,
45752      &        1.6d2,2.4d2,4d2,6.4d2,1d3,1.8d3,3.2d3,5.6d3,1d4,
45753      &        1.8d4,3.2d4,5.6d4,1d5,1.8d5,3.2d5,5.6d5,1d6,
45754      &        1.8d6,3.2d6,5.6d6,1d7/
45755       DATA N0/3,4,5,9,9,9,9,9/
45756       DATA INIT,WARN/0,0,0/
45757       SAVE INIT,WARN,XMIN,XMAX,QSQMIN,QSQMAX,XXMRS,QQ,N0
45758       Q2=Q*Q
45759 C--issue warning if x or q out of range
45760       IF((Q2.LT.QSQMIN.OR.Q2.GT.QSQMAX).AND.WARN(1).EQ.0) THEN
45761         CALL HWWARN('HWSMRS',5,*98)
45762         WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH Q',
45763      &         ' OUTSIDE ALLOWED RANGE!'
45764         WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',Q,
45765      &         ', MINIMUM=',SQRT(QSQMIN),', MAXIMUM=',SQRT(QSQMAX)
45766         WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45767         WARN(1) = 1
45768       ENDIF
45769  98   IF((X.LT.XMIN.OR.X.GT.XMAX).AND.WARN(2).EQ.0) THEN
45770         CALL HWWARN('HWSMRS',4,*99)
45771         WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH X',
45772      &         ' OUTSIDE ALLOWED RANGE!'
45773         WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
45774      &         ', MINIMUM=',XMIN,', MAXIMUM=',XMAX
45775         WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
45776         WARN(2) = 1
45777       ENDIF
45778 C--now the evaluation
45779  99   XSAVE  = X
45780       Q2SAVE = Q2
45781 C--first the initialisation
45782       IF(INIT.NE.0) GOTO 10
45783       DO 15 ML=3,1,-1
45784       DO 20 N=1,NXMRS-1
45785       DO 20 M=1,NQMRS
45786       DO 20 I=1,NPMRS
45787 c notation: 1=uval 2=val 3=glue 4=usea 5=chm 6=str 7=btm 8=dsea
45788         IF(ML.LE.2) THEN
45789           FMRS(ML,I,N,M) = FMRS(ML,I,N,M)/(1.0D0-XXMRS(N))**N0(I)
45790         ELSE
45791           FMRS(ML,I,N,M) = 0.5D0*(FMRS(1,I,N,M)+FMRS(2,I,N,M))/
45792      &                              (1.0D0-XXMRS(N))**N0(I)
45793         ENDIF
45794  20   CONTINUE
45795       DO 31 J=1,NTENTH-1
45796       DO 31 I=1,8
45797       IF(I.EQ.5.OR.I.EQ.7) GOTO 31
45798       DO 30 K=1,NQMRS
45799  30   FMRS(ML,I,J,K)=DLOG10(FMRS(ML,I,J,K)/FMRS(ML,I,NTENTH,K))
45800      &                 +FMRS(ML,I,NTENTH,K)
45801  31   CONTINUE
45802       DO 40 I=1,NPMRS
45803       DO 40 M=1,NQMRS
45804  40   FMRS(ML,I,NXMRS,M)=0.0D0
45805  15   CONTINUE
45806       DO 32 J=1,NTENTH-1
45807  32   XXMRS(J)=DLOG10(XXMRS(J)/XXMRS(NTENTH))+XXMRS(NTENTH)
45808       INIT=1
45809  10   CONTINUE
45810 C--check x and q within range of set
45811       IF(X.LT.XMIN) X=XMIN
45812       IF(X.GT.XMAX) X=XMAX
45813       IF(Q2.LT.QSQMIN)  Q2=QSQMIN
45814       IF(Q2.GT.QSQMAX)  Q2=QSQMAX
45815 C--find X and Q
45816       XXX=X
45817       IF(X.LT.XXMRS(NTENTH)) XXX=DLOG10(X/XXMRS(NTENTH))+XXMRS(NTENTH)
45818       N = 0
45819  70   N=N+1
45820       IF(XXX.GT.XXMRS(N+1)) GOTO 70
45821       A=(XXX-XXMRS(N))/(XXMRS(N+1)-XXMRS(N))
45822       M=0
45823  80   M=M+1
45824       IF(Q2.GT.QQ(M+1)) GOTO 80
45825       B=(Q2-QQ(M))/(QQ(M+1)-QQ(M))
45826       DO 60 I=1,NPMRS
45827       G(I)= (1.0D0-A)*(1.0D0-B)*FMRS(MODE,I,N  ,M  )
45828      &     +(1.0D0-A)*       B *FMRS(MODE,I,N  ,M+1)
45829      &     +       A *(1.0D0-B)*FMRS(MODE,I,N+1,M  )
45830      &     +       A *       B *FMRS(MODE,I,N+1,M+1)
45831       IF(N.GE.NTENTH) GOTO 65
45832       IF(I.EQ.5.OR.I.EQ.7) GOTO 65
45833       FAC  = (1.0D0-B)*FMRS(MODE,I,NTENTH,M)+B*FMRS(MODE,I,NTENTH,M+1)
45834       G(I) = FAC*10.0d0**(G(I)-FAC)
45835   65  continue
45836       G(I)=G(I)*(1.0d0-X)**N0(I)
45837   60  continue
45838       UPV  = G(1)
45839       DNV  = G(2)
45840       USEA = G(4)
45841       DSEA = G(8)
45842       STR  = G(6)
45843       CHM  = G(5)
45844       GLU  = G(3)
45845       BOT  = G(7)
45846       X    = XSAVE
45847       Q2   = Q2SAVE
45848       RETURN
45849  999  END
45850 CDECK  ID>, HWSSPC.
45851 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
45852 *-- Author :    Bryan Webber
45853 C-----------------------------------------------------------------------
45854       SUBROUTINE HWSSPC
45855 C-----------------------------------------------------------------------
45856 C     REPLACES SPACELIKE PARTONS BY SPECTATORS
45857 C-----------------------------------------------------------------------
45858       INCLUDE 'HERWIG65.INC'
45859       DOUBLE PRECISION HWUSQR,EMSQ,EMTR,EPAR,XPAR,QSQ,PCL(5)
45860       INTEGER KHEP,IP,JP,IDH,IDP,ISP,IDSPC,JHEP
45861       EXTERNAL HWUSQR
45862       IF (IERROR.NE.0) RETURN
45863       DO 50 KHEP=1,NHEP
45864       IF (ISTHEP(KHEP).EQ.145.OR.ISTHEP(KHEP).EQ.146) THEN
45865         IP=ISTHEP(KHEP)-144
45866         JP=IP
45867         IF (JDAHEP(1,IP).NE.0) JP=JDAHEP(1,IP)
45868         IDH=IDHW(JP)
45869         IDP=IDHW(KHEP)
45870         IF (IDH.NE.IDP) THEN
45871           IF (IDH.EQ.59) THEN
45872 C---PHOTON CASE
45873             IF (IDP.LT.7) THEN
45874               IDSPC=IDP+6
45875             ELSEIF (IDP.LT.13) THEN
45876               IDSPC=IDP-6
45877             ELSE
45878               CALL HWWARN('HWSSPC',100,*999)
45879             ENDIF
45880 C---IDENTIFY SPECTATOR
45881 C   (1) QUARK CASE
45882           ELSEIF (IDP.LE.3) THEN
45883             DO 10 ISP=1,12
45884   10        IF (IDH.EQ.NCLDK(LOCN(IDP,ISP))) GOTO 20
45885             CALL HWWARN('HWSSPC',101,*999)
45886   20        IF (ISP.LE.3) THEN
45887               IDSPC=ISP+6
45888             ELSEIF (ISP.LE.9) THEN
45889               IDSPC=ISP+105
45890             ELSE
45891               IDSPC=ISP
45892             ENDIF
45893 C---(2) ANTIQUARK CASE
45894           ELSEIF (IDP.GT.6.AND.IDP.LE.9) THEN
45895             IDP=IDP-6
45896             DO 30 ISP=1,12
45897   30        IF (IDH.EQ.NCLDK(LOCN(ISP,IDP))) GOTO 40
45898             CALL HWWARN('HWSSPC',103,*999)
45899             RETURN
45900   40        IF (ISP.LE.3) THEN
45901               IDSPC=ISP
45902             ELSEIF (ISP.LE.9) THEN
45903               IDSPC=ISP+111
45904             ELSE
45905               IDSPC=ISP-6
45906             ENDIF
45907 C---SPECIAL CASE FOR REMNANT HADRON
45908           ELSEIF (IDH.EQ.71.OR.IDH.EQ.72) THEN
45909             IF (IDP.EQ.13) THEN
45910               IDSPC=IDP
45911             ELSE
45912               CALL HWWARN('HWSSPC',106,*999)
45913             ENDIF
45914           ELSE
45915             CALL HWWARN('HWSSPC',105,*999)
45916           ENDIF
45917 C---REPLACE PARTON BY SPECTATOR
45918           IDHW(KHEP)=IDSPC
45919           IDHEP(KHEP)=IDPDG(IDSPC)
45920           ISTHEP(KHEP)=146+IP
45921           EMSQ=SIGN(PHEP(5,KHEP)**2,PHEP(5,KHEP))
45922           EMTR=EMSQ+PHEP(1,KHEP)**2+PHEP(2,KHEP)**2
45923           EPAR=PHEP(4,KHEP)
45924           CALL HWVDIF(4,PHEP(1,JP),PHEP(1,KHEP),PHEP(1,KHEP))
45925           IF (EPAR**2.LT.10000.*ABS(EMTR)) THEN
45926             CALL HWUMAS(PHEP(1,KHEP))
45927           ELSE
45928 C---COMPUTE SPECTATOR MASS ELIMINATING ROUNDING ERRORS
45929             XPAR=EPAR/PHEP(4,JP)
45930             QSQ=SIGN(PHEP(5,JP)**2,PHEP(5,JP))
45931             PHEP(5,KHEP)=HWUSQR((1.-XPAR)*QSQ+EMSQ-EMTR/XPAR
45932      &                 -((QSQ*XPAR**2-EMTR)/(2*EPAR*XPAR**2))**2*XPAR)
45933           ENDIF
45934 C---CHECK FOR UNPHYSICAL SPECTATOR
45935           IF (PHEP(4,KHEP).LT.ZERO) FROST=.TRUE.
45936 C---FIND MASS OF CORRESPONDING CLUSTER, IF PARTNER IS IN THE SAME JET
45937           IF (QORQQB(IDHW(KHEP))) THEN
45938             JHEP=JMOHEP(2,KHEP)
45939           ELSEIF (QBORQQ(IDHW(KHEP))) THEN
45940             JHEP=JDAHEP(2,KHEP)
45941           ELSE
45942             JHEP=0
45943           ENDIF
45944           IF (JHEP.GT.0) THEN
45945             CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PCL)
45946             CALL HWUMAS(PCL)
45947 C---IF IT IS NEGATIVE, REJECT
45948             IF (PCL(5).LT.ZERO) FROST=.TRUE.
45949           ENDIF
45950         ENDIF
45951       ENDIF
45952   50  CONTINUE
45953   999 END
45954 CDECK  ID>, HWSSUD.
45955 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
45956 *-- Author :    Bryan Webber
45957 C-----------------------------------------------------------------------
45958       FUNCTION HWSSUD(I)
45959 C-----------------------------------------------------------------------
45960       INCLUDE 'HERWIG65.INC'
45961       DOUBLE PRECISION HWSSUD,HWSGQQ,DMIN,QSCA,XLAST,DIST(13)
45962       INTEGER I,N0,IS,ID
45963       EXTERNAL HWSGQQ
45964       COMMON/HWTABC/XLAST,N0,IS,ID
45965       DATA DMIN/1.D-15/
45966       QSCA=QEV(N0+I,IS)
45967       CALL HWSFUN(XLAST,QSCA,IDHW(INHAD),NSTRU,DIST,JNHAD)
45968       IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QSCA)
45969       IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
45970       HWSSUD=SUD(N0+I,IS)/DIST(ID)
45971       END
45972 CDECK  ID>, HWSTAB.
45973 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
45974 *-- Author :    Adapted by Bryan Webber
45975 C-----------------------------------------------------------------------
45976       FUNCTION HWSTAB(F,AFUN,NN,X,MM)
45977 C-----------------------------------------------------------------------
45978 C     MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
45979 C     LIKE HWUTAB BUT USES FUNCTION AFUN IN PLACE OF ARRAY A
45980 C-----------------------------------------------------------------------
45981       IMPLICIT NONE
45982       INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
45983       DOUBLE PRECISION HWSTAB,AFUN,SUM,X,F(NN),T(20),D(20)
45984       LOGICAL EXTRA
45985       EXTERNAL AFUN
45986       DATA MMAX/10/
45987       N=NN
45988       M=MIN(MM,MMAX,N-1)
45989       MPLUS=M+1
45990       IX=0
45991       IY=N+1
45992       IF (AFUN(1).GT.AFUN(N)) GOTO 94
45993    91 MID=(IX+IY)/2
45994       IF (X.GE.AFUN(MID)) GOTO 92
45995       IY=MID
45996       GOTO 93
45997    92 IX=MID
45998    93 IF (IY-IX.GT.1) GOTO 91
45999       GOTO 97
46000    94 MID=(IX+IY)/2
46001       IF (X.LE.AFUN(MID)) GOTO 95
46002       IY=MID
46003       GOTO 96
46004    95 IX=MID
46005    96 IF (IY-IX.GT.1) GOTO 94
46006    97 NPTS=M+2-MOD(M,2)
46007       IP=0
46008       L=0
46009       GOTO 99
46010    98 L=-L
46011       IF (L.GE.0) L=L+1
46012    99 ISUB=IX+L
46013       IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 100
46014       NPTS=MPLUS
46015       GOTO 101
46016   100 IP=IP+1
46017       T(IP)=AFUN(ISUB)
46018       D(IP)=F(ISUB)
46019   101 IF (IP.LT.NPTS) GOTO 98
46020       EXTRA=NPTS.NE.MPLUS
46021       DO 14 L=1,M
46022       IF (.NOT.EXTRA) GOTO 12
46023       ISUB=MPLUS-L
46024       D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
46025    12 I=MPLUS
46026       DO 13 J=L,M
46027       ISUB=I-L
46028       D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
46029       I=I-1
46030    13 CONTINUE
46031    14 CONTINUE
46032       SUM=D(MPLUS)
46033       IF (EXTRA) SUM=0.5*(SUM+D(M+2))
46034       J=M
46035       DO 15 L=1,M
46036       SUM=D(J)+(X-T(J))*SUM
46037       J=J-1
46038    15 CONTINUE
46039       HWSTAB=SUM
46040       END
46041 CDECK  ID>, HWSVAL.
46042 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
46043 *-- Author :    Bryan Webber
46044 C-----------------------------------------------------------------------
46045       FUNCTION HWSVAL(ID)
46046 C-----------------------------------------------------------------------
46047 C     TRUE FOR VALENCE PARTON ID IN INCOMING HADRON INHAD
46048 C-----------------------------------------------------------------------
46049       INCLUDE 'HERWIG65.INC'
46050       INTEGER ID,IDHAD
46051       LOGICAL HWSVAL
46052       HWSVAL=.FALSE.
46053       IDHAD=IDHW(INHAD)
46054       IF (IDHAD.EQ.73.OR.IDHAD.EQ.75) THEN
46055         IF (ID.EQ.1.OR.ID.EQ.2) HWSVAL=.TRUE.
46056       ELSEIF (IDHAD.EQ.91.OR.IDHAD.EQ.93) THEN
46057         IF (ID.EQ.7.OR.ID.EQ.8) HWSVAL=.TRUE.
46058       ELSEIF (IDHAD.EQ.30) THEN
46059         IF (ID.EQ.1.OR.ID.EQ.8) HWSVAL=.TRUE.
46060       ELSEIF (IDHAD.EQ.38) THEN
46061         IF (ID.EQ.2.OR.ID.EQ.7) HWSVAL=.TRUE.
46062       ELSEIF (IDHAD.EQ.59) THEN
46063         IF (ID.LT.6.OR.(ID.GT.6.AND.ID.LT.12)) HWSVAL=.TRUE.
46064       ELSEIF (IDHAD.EQ.71.OR.IDHAD.EQ.72) THEN
46065         IF (ID.EQ.13) HWSVAL=.TRUE.
46066       ELSE
46067         CALL HWWARN('HWSVAL',100,*999)
46068       ENDIF
46069   999 END
46070 CDECK  ID>, HWUAEM.
46071 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
46072 *-- Author :    Ian Knowles
46073 C-----------------------------------------------------------------------
46074       FUNCTION HWUAEM(Q2)
46075 C-----------------------------------------------------------------------
46076 C     Running electromagnetic coupling constant.
46077 C     See R. Kleiss et al.: CERN yellow report 89-08, vol.3 p.129
46078 C     Hadronic component from: H. Burkhardt et al.: Z. Phys C43 (89) 497
46079 C-----------------------------------------------------------------------
46080       INCLUDE 'HERWIG65.INC'
46081       DOUBLE PRECISION HWUAEM,HWUAER,Q2,EPS,A1,B1,C1,A2,B2,C2,A3,B3,C3,
46082      & A4,B4,C4,AEMPI,EEL2,EMU2,ETAU2,ETOP2,REPIGG,X
46083       LOGICAL FIRST
46084       EXTERNAL HWUAER
46085       SAVE FIRST,AEMPI,EEL2,EMU2,ETAU2,ETOP2
46086       PARAMETER (EPS=1.D-6)
46087       DATA A1,B1,C1/0.0    D0,0.00835D0,1.000D0/
46088       DATA A2,B2,C2/0.0    D0,0.00238D0,3.927D0/
46089       DATA A3,B3,C3/0.00165D0,0.00299D0,1.000D0/
46090       DATA A4,B4,C4/0.00221D0,0.00293D0,1.000D0/
46091       DATA FIRST/.TRUE./
46092       IF (FIRST) THEN
46093          AEMPI=ALPHEM/(THREE*PIFAC)
46094          EEL2 =RMASS(121)**2
46095          EMU2 =RMASS(123)**2
46096          ETAU2=RMASS(125)**2
46097          ETOP2=RMASS(6)**2
46098          FIRST=.FALSE.
46099       ENDIF
46100       IF (ABS(Q2).LT.EPS) THEN
46101           HWUAEM=ALPHEM
46102           RETURN
46103       ENDIF
46104 C Leptonic component
46105       REPIGG=AEMPI*(HWUAER(EEL2/Q2)+HWUAER(EMU2/Q2)+HWUAER(ETAU2/Q2))
46106 C Hadronic component from light quarks
46107       X=ABS(Q2)
46108       IF (X.LT.9.D-2) THEN
46109           REPIGG=REPIGG+A1+B1*LOG(ONE+C1*X)
46110       ELSEIF (X.LT.9.D0) THEN
46111           REPIGG=REPIGG+A2+B2*LOG(ONE+C2*X)
46112       ELSEIF (X.LT.1.D4) THEN
46113           REPIGG=REPIGG+A3+B3*LOG(ONE+C3*X)
46114       ELSE
46115           REPIGG=REPIGG+A4+B4*LOG(ONE+C4*X)
46116       ENDIF
46117 C Top Contribution
46118       REPIGG=REPIGG+AEMPI*HWUAER(ETOP2/Q2)
46119       HWUAEM=ALPHEM/(ONE-REPIGG)
46120       RETURN
46121       END
46122 CDECK  ID>, HWUAER.
46123 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
46124 *-- Author :    Ian Knowles
46125 C-----------------------------------------------------------------------
46126       FUNCTION HWUAER(R)
46127 C-----------------------------------------------------------------------
46128 C     Real part of photon self-energy: Pi_{gg}(R=M^2/Q^2)
46129 C-----------------------------------------------------------------------
46130       DOUBLE PRECISION HWUAER,R,ZERO,ONE,TWO,FOUR,FVTHR,THIRD,RMAX,BETA
46131       PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0,
46132      &           FVTHR=1.666666666666667D0, THIRD=.3333333333333333D0)
46133       PARAMETER (RMAX=1.D6)
46134       IF (ABS(R).LT.1.D-3) THEN
46135 C Use assymptotic formula
46136          HWUAER=-FVTHR-LOG(ABS(R))
46137       ELSEIF (ABS(R).GT.RMAX) THEN
46138          HWUAER=ZERO
46139       ELSEIF (FOUR*R.GT.ONE) THEN
46140          BETA=SQRT(FOUR*R-ONE)
46141          HWUAER=THIRD
46142      &         -(ONE+TWO*R)*(TWO-BETA*ACOS(ONE-ONE/(TWO*R)))
46143       ELSE
46144          BETA=SQRT(ONE-FOUR*R)
46145          HWUAER=THIRD
46146      &         -(ONE+TWO*R)*(TWO+BETA*LOG(ABS((BETA-ONE)/(BETA+ONE))))
46147       ENDIF
46148       RETURN
46149       END
46150 CDECK  ID>, HWUALF.
46151 *CMZ :-        -15/07/92  14.08.45  by  Mike Seymour
46152 *-- Author :    Bryan Webber
46153 C-----------------------------------------------------------------------
46154       FUNCTION HWUALF(IOPT,SCALE)
46155 C-----------------------------------------------------------------------
46156 C     STRONG COUPLING CONSTANT
46157 C     IOPT.EQ.0  INITIALIZES
46158 C         .EQ.1  TWO-LOOP, FLAVOUR THRESHOLDS
46159 C         .EQ.2  RATIO OF ABOVE TO ONE-LOOP
46160 C                WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
46161 C         .EQ.3  ONE-LOOP WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
46162 C-----------------------------------------------------------------------
46163       INCLUDE 'HERWIG65.INC'
46164       DOUBLE PRECISION HWUALF,SCALE,KAFAC,B3,B4,B5,B6,C3,C4,C5,C6,C35,
46165      & C45,C65,D35,RHO,RAT,RLF,DRH,EPS
46166       INTEGER IOPT,ITN
46167       SAVE B3,B4,B5,B6,C3,C4,C5,C6,C35,C45,C65,D35
46168       DATA EPS/1.D-6/
46169       IF (IOPT.EQ.0) THEN
46170 C---INITIALIZE CONSTANTS
46171         CAFAC=FLOAT(NCOLO)
46172         CFFAC=FLOAT(NCOLO**2-1)/(2.*CAFAC)
46173         B3=((11.*CAFAC)- 6.)/(12.*PIFAC)
46174         B4=((11.*CAFAC)- 8.)/(12.*PIFAC)
46175         B5=((11.*CAFAC)-10.)/(12.*PIFAC)
46176         B6=((11.*CAFAC)-12.)/(12.*PIFAC)
46177         BETAF=6.*PIFAC*B5
46178         C3=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*3.)/(24.*PIFAC**2)/B3**2
46179         C4=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*4.)/(24.*PIFAC**2)/B4**2
46180         C5=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*5.)/(24.*PIFAC**2)/B5**2
46181         C6=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*6.)/(24.*PIFAC**2)/B6**2
46182         KAFAC=CAFAC*(67./18.-PIFAC**2/6.)-25./9.
46183 C---QCDLAM IS 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X OR Z
46184 C---QCDL5  IS 5-FLAVOUR LAMBDA-MC
46185         QCDL5=QCDLAM*EXP(KAFAC/(4.*PIFAC*B5))/SQRT(2.D0)
46186 C---COMPUTE THRESHOLD MATCHING
46187         RHO=2.*LOG(RMASS(6)/QCDL5)
46188         RAT=LOG(RHO)/RHO
46189         C65=(B5/(1.-C5*RAT)-B6/(1.-C6*RAT))*RHO
46190         RHO=2.*LOG(RMASS(5)/QCDL5)
46191         RAT=LOG(RHO)/RHO
46192         C45=(B5/(1.-C5*RAT)-B4/(1.-C4*RAT))*RHO
46193         RHO=2.*LOG(RMASS(4)/QCDL5)
46194         RAT=LOG(RHO)/RHO
46195         C35=(B4/(1.-C4*RAT)-B3/(1.-C3*RAT))*RHO+C45
46196 C---FIND QCDL3
46197         D35=-1./(B3*C35)
46198         DO 10 ITN=1,100
46199           RAT=LOG(D35)/D35
46200           RLF=B3*D35/(1.-C3*RAT)
46201           DRH=B3*(RLF+C35)*D35**2/((1.-2.*C3*RAT+C3/D35)*RLF**2)
46202           D35=D35-DRH
46203           IF (ABS(DRH).LT.EPS*D35) GOTO 20
46204    10   CONTINUE
46205    20   QCDL3=QCDL5*EXP(0.5*D35)
46206       ENDIF
46207       IF (SCALE.LE.QCDL5) CALL HWWARN('HWUALF',51,*999)
46208       RHO=2.*LOG(SCALE/QCDL5)
46209       IF (IOPT.EQ.3) THEN
46210         IF (RHO.LE.D35) CALL HWWARN('HWUALF',52,*999)
46211         HWUALF=1./(B5*(RHO-D35))
46212         RETURN
46213       ENDIF
46214       RAT=LOG(RHO)/RHO
46215       IF (SCALE.GT.RMASS(6)) THEN
46216         RLF=B6*RHO/(1.-C6*RAT)+C65
46217       ELSEIF (SCALE.GT.RMASS(5)) THEN
46218         RLF=B5*RHO/(1.-C5*RAT)
46219       ELSEIF (SCALE.GT.RMASS(4)) THEN
46220         RLF=B4*RHO/(1.-C4*RAT)+C45
46221       ELSE
46222         RLF=B3*RHO/(1.-C3*RAT)+C35
46223       ENDIF
46224       IF (RLF.LE.ZERO) CALL HWWARN('HWUALF',53,*999)
46225       IF (IOPT.EQ.1) THEN
46226         HWUALF=1./RLF
46227       ELSE
46228         HWUALF=B5*(RHO-D35)/RLF
46229         IF (HWUALF.GT.ONE) CALL HWWARN('HWUALF',54,*999)
46230       ENDIF
46231       RETURN
46232  999  HWUALF=ZERO
46233       END
46234 CDECK  ID>, HWUANT.
46235 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
46236 *-- Author :    Ian Knowles
46237 C-----------------------------------------------------------------------
46238       FUNCTION HWUANT(IPART)
46239 C-----------------------------------------------------------------------
46240 C     Returns the antiparticle of IPART; uses HERWIG numbering
46241 C-----------------------------------------------------------------------
46242       INCLUDE 'HERWIG65.INC'
46243       INTEGER HWUANT,IPART,IPDG,IANTI,OLDERR
46244       CHARACTER*8 CDUM
46245       OLDERR=IERROR
46246       IPDG=IDPDG(IPART)
46247       IF (IPDG.EQ. 9.OR.IPDG.EQ.21.OR.IPDG.EQ.22.OR.IPDG.EQ.23.OR.
46248      &    IPDG.EQ.25.OR.IPDG.EQ.26.OR.IPDG.EQ.32.OR.IPDG.EQ.35.OR.
46249      &    IPDG.EQ.36.OR.IPDG.EQ.39.OR.IPDG.EQ.91.OR.IPDG.EQ.98.OR.
46250      &    IPDG.EQ.99.OR.IPDG.EQ.130.OR.IPDG.EQ.310.OR.
46251      &    IPDG.EQ.1000021.OR.IPDG.EQ.1000022.OR.IPDG.EQ.1000023.OR.
46252      &    IPDG.EQ.1000025.OR.IPDG.EQ.1000035.OR.IPDG.EQ.1000039.OR.
46253      &    (FLOAT(INT(RSPIN(IPART))).EQ.RSPIN(IPART).AND.
46254      &     MOD(IPDG/100,10).EQ.MOD(IPDG/10,10).AND.
46255      &     MOD(IPDG/10,10).NE.0)) THEN
46256 C Self-conjugate boson
46257         IANTI=IPART
46258       ELSEIF(IPART.EQ.211.OR.IPART.EQ.212) THEN
46259 C Fourth generation (anti-)quarks
46260         IANTI=IPART+6
46261       ELSEIF(IPART.EQ.217.OR.IPART.EQ.218) THEN
46262         IANTI=IPART-6
46263       ELSE
46264 C Non-zero charge particle
46265         CALL HWUIDT(1,-IPDG,IANTI,CDUM)
46266       ENDIF
46267       IF (IANTI.EQ.20) WRITE(6,10) RNAME(IPART)
46268   10  FORMAT(1X,A8,' has no antiparticle'/)
46269       HWUANT=IANTI
46270       IERROR=OLDERR
46271       END
46272 CDECK  ID>, HWUATS.
46273 *CMZ :-        -07/07/99  17.42.00  by  Kosuke Odagiri
46274 *-- Author :    Kosuke Odagiri
46275 C-----------------------------------------------------------------------
46276       SUBROUTINE HWUATS
46277 C-----------------------------------------------------------------------
46278 C     Replaces all &'s in TXNAME by backslashes
46279 C-----------------------------------------------------------------------
46280       INCLUDE 'HERWIG65.INC'
46281       INTEGER I,J,L
46282       CHARACTER*1 Z
46283       Z=CHAR(92)
46284       L=LEN(TXNAME(1,1))
46285       DO 1 I=0,NMXRES
46286         DO 2 J=1,L
46287           IF (TXNAME(1,I)(J:J).EQ.'&') TXNAME(1,I)(J:J)=Z
46288  2      CONTINUE
46289  1    CONTINUE
46290       END
46291 CDECK  ID>, HWUBPR.
46292 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
46293 *-- Author :    Bryan Webber
46294 C-----------------------------------------------------------------------
46295       SUBROUTINE HWUBPR
46296 C-----------------------------------------------------------------------
46297 C     PRINTS OUT DATA ON PARTON SHOWER
46298 C-----------------------------------------------------------------------
46299       INCLUDE 'HERWIG65.INC'
46300       INTEGER I,J
46301       IF (PRVTX) THEN
46302         WRITE(6,10) INHAD,XFACT
46303   10    FORMAT(///10X,'DATA ON LAST PARTON SHOWER:   INHAD =',I3,
46304      &  '    XFACT =',E11.3//'  IPAR ID     TM  DA1 CMO AMO CDA',
46305      &  ' ADA  P-X     P-Y     P-Z   ENERGY    MASS',
46306      &  '   V-X        V-Y        V-Z        V-C*T')
46307         DO 20 J=1,NPAR
46308   20    WRITE(6,30) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
46309      &   (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5),(VPAR(I,J),I=1,4)
46310   30    FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2,4E11.4)
46311       ELSE
46312         WRITE(6,40) INHAD,XFACT
46313   40    FORMAT(///10X,'DATA ON LAST PARTON SHOWER:   INHAD =',I3,
46314      &  '    XFACT =',E11.3//'  IPAR ID     TM  DA1 CMO AMO CDA',
46315      &  ' ADA  P-X     P-Y     P-Z   ENERGY    MASS')
46316         DO 50 J=1,NPAR
46317   50    WRITE(6,60) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
46318      &   (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5)
46319   60    FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2)
46320       ENDIF
46321       END
46322 CDECK  ID>, HWUBST.
46323 *CMZ :-        -18/10/93  10.21.56  by  Mike Seymour
46324 *-- Author :    Mike Seymour
46325 C-----------------------------------------------------------------------
46326       SUBROUTINE HWUBST(IOPT)
46327 C-----------------------------------------------------------------------
46328 C     BOOST THE ENTIRE EVENT RECORD TO (IOPT=1) OR FROM (IOPT=0) ITS
46329 C     CENTRE-OF-MASS FRAME, WITH INCOMING HADRONS ON Z-AXIS
46330 C-----------------------------------------------------------------------
46331       INCLUDE 'HERWIG65.INC'
46332       DOUBLE PRECISION PBOOST(5),RBOOST(3,3)
46333       INTEGER IOPT,IHEP,BOOSTD,IHAD
46334       SAVE BOOSTD,PBOOST,RBOOST
46335       DATA BOOSTD/-1/
46336       IF (IERROR.NE.0) RETURN
46337       IF (IOPT.EQ.1) THEN
46338 C---FIND FIRST INCOMING HADRON
46339         IHAD=1
46340         IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
46341 C---IF WE'RE ALREADY IN THE RIGHT FRAME, DON'T DO ANYTHING
46342         IF (PHEP(1,3)**2+PHEP(2,3)**2+PHEP(3,3)**2.EQ.ZERO .AND.
46343      &      PHEP(1,IHAD)**2+PHEP(2,IHAD)**2.EQ.ZERO) RETURN
46344 C---FIND AND APPLY BOOST
46345         CALL HWVEQU(5,PHEP(1,3),PBOOST)
46346         DO 100 IHEP=1,NHEP
46347           CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
46348           CALL HWULOF(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
46349  100    CONTINUE
46350         CALL HWULOF(PBOOST,VTXPIP,VTXPIP)
46351 C---FIND AND APPLY ROTATION TO PUT IT ON Z-AXIS
46352         CALL HWUROT(PHEP(1,IHAD),ONE,ZERO,RBOOST)
46353         DO 110 IHEP=1,NHEP
46354           CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
46355           CALL HWUROF(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
46356  110    CONTINUE
46357         CALL HWUROF(RBOOST,VTXPIP,VTXPIP)
46358 C---ENSURE THAT WE ONLY EVER UNBOOST THE SAME EVENT THAT WE BOOSTED
46359 C   (BEARING IN MIND THAT NWGTS IS UPDATED AFTER GENERATING THE WEIGHT)
46360         BOOSTD=NWGTS+1
46361       ELSEIF (IOPT.EQ.0) THEN
46362         IF (BOOSTD.NE.NWGTS) RETURN
46363 C---UNDO ROTATION AND BOOST
46364         DO 200 IHEP=1,NHEP
46365           CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
46366           CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
46367           CALL HWUROB(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
46368           CALL HWULB4(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
46369  200    CONTINUE
46370       ENDIF
46371       END
46372 CDECK  ID>, HWUCFF.
46373 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
46374 *-- Author :    Bryan Webber and Ian Knowles
46375 C-----------------------------------------------------------------------
46376       SUBROUTINE HWUCFF(I,J,QSQ,CLF)
46377 C-----------------------------------------------------------------------
46378 C     Calculates basic coefficients in cross-section formula for
46379 C     ffbar --> f'fbar', at virtuality QSQ, I labels initial, J
46380 C     labels final fermion; type given as:
46381 C        I,J= 1- 6: d,u,s,c,b,t
46382 C           =11-16: e,nu_e,mu,nu_mu,tau,nu_tau
46383 C-----------------------------------------------------------------------
46384       INCLUDE 'HERWIG65.INC'
46385       DOUBLE PRECISION QSQ,CLF(7),POL1,POL2,QIF,VI,AI,VF,AF,PG,DQM,PMW,
46386      & DEN,XRE,XIM,XSQ,VI2,AI2,VF2,AF2,PG2,PG12,DQM2,PMW2,DEN2,XRE2,
46387      & XIM2,XSQ2,XRE12,XIM12
46388       INTEGER I,J
46389 C Longitudinal Polarisation factors
46390       POL1=1.-EPOLN(3)*PPOLN(3)
46391       POL2=PPOLN(3)-EPOLN(3)
46392 C Standard model couplings
46393       QIF=QFCH(I)*QFCH(J)
46394       VI=VFCH(I,1)
46395       AI=AFCH(I,1)
46396       VF=VFCH(J,1)
46397       AF=AFCH(J,1)
46398       PG=POL1*(VI**2+AI**2)+POL2*2.*VI*AI
46399 C Z propagator factors
46400       DQM=QSQ-RMASS(200)**2
46401       PMW=GAMZ*RMASS(200)
46402       DEN=QSQ/(DQM**2+PMW**2)
46403       XRE=DEN*DQM
46404       XIM=DEN*PMW
46405       XSQ=DEN*QSQ
46406 C Calculate cross-section coefficients
46407       CLF(1)=POL1*QIF**2+XRE*2.*QIF*(POL1*VI+POL2*AI)*VF
46408      &      +XSQ*PG*(VF**2+AF**2)
46409       CLF(2)=CLF(1)-2.*XSQ*PG*AF**2
46410       CLF(3)=2.*(XRE*QIF*(POL1*AI+POL2*VI)*AF
46411      &      +XSQ*(POL1*2.*VI*AI+POL2*(VI**2+AI**2))*VF*AF)
46412       IF (TPOL) THEN
46413          CLF(4)=QIF**2+XRE*2.*QIF*VI*VF+XSQ*(VI**2-AI**2)*(VF**2+AF**2)
46414          CLF(5)=CLF(4)-2.*XSQ*(VI**2-AI**2)*AF**2
46415          CLF(6)=XIM*2.*QIF*AI*VF
46416          CLF(7)=CLF(6)
46417       ENDIF
46418       IF (ZPRIME) THEN
46419 C Z' couplings:
46420          VI2=VFCH(I,2)
46421          AI2=AFCH(I,2)
46422          VF2=VFCH(J,2)
46423          AF2=AFCH(J,2)
46424          PG2=POL1*(VI2**2+AI2**2)+POL2*2.*VI2*AI2
46425          PG12=POL1*(VI*VI2+AI*AI2)+POL2*(VI*AI2+AI+VI2)
46426 C Z' propagator factors
46427          DQM2=QSQ-RMASS(202)**2
46428          PMW2=RMASS(202)*GAMZP
46429          DEN2=QSQ/(DQM2**2+PMW2**2)
46430          XRE2=DEN2*DQM2
46431          XIM2=DEN2*PMW2
46432          XSQ2=DEN2*QSQ
46433          XRE12=DEN*DEN2*(DQM*DQM2+PMW*PMW2)
46434          XIM12=DEN*DEN2*(DQM*PMW2-DQM2*PMW)
46435 C Additional contributions to cross-section coefficients
46436          CLF(1)=CLF(1)+XRE2*2.*QIF*(POL1*VI2+POL2*AI2)*VF2
46437      &    +XSQ2*PG2*(VF2**2+AF2**2)+XRE12*2.*PG12*(VF*VF2+AF*AF2)
46438          CLF(2)=CLF(1)-2.*(XSQ2*PG2*AF2**2+XRE12*2.*PG12*AF*AF2)
46439          CLF(3)=CLF(3)+2.*(XRE2*QIF*(POL1*AI2+POL2*VI2)*AF2
46440      &    +XSQ2*(POL1*2.*VI2*AI2+POL2*(VI2**2+AI2**2))*VF2*AF2
46441      &    +XRE12*(POL1*(VI*AI2+AI*VI2)+POL1*(VI*VI2+AI*AI2))
46442      &    *(VF*VF2+AF*AF2))
46443          IF (TPOL) THEN
46444             CLF(4)=CLF(4)+XRE2*2.*QIF*VI2*VF2
46445      &       +XSQ2*(VI2**2-AI2**2)*(VF2**2+AF2**2)
46446      &       +XRE12*2.*(VI*VI2-AI*AI2)*(VF*VF2+AF*AF2)
46447             CLF(5)=CLF(4)-2*(XSQ2*(VI2**2-AI2**2)*AF2**2
46448      &       +XRE12*2.*(VI*VI2-AI*AI2)*AF*AF2)
46449             CLF(6)=CLF(6)+2.*(XIM2*QIF*AI2*VF2
46450      &       -XIM12*(VI*AI2-AI*VI2)*(VF*VF2+AF*AF2))
46451             CLF(7)=CLF(6)+4.*XIM12*(VI*AI2-AI*AI2)*AF*AF2
46452          ENDIF
46453       ENDIF
46454       RETURN
46455       END
46456 CDECK  ID>, HWUCI2.
46457 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
46458 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
46459 C-----------------------------------------------------------------------
46460       FUNCTION HWUCI2(A,B,Y0)
46461 C-----------------------------------------------------------------------
46462 C     Integral  LOG(A-EPSI-BY(1-Y))/(Y-Y0)
46463 C-----------------------------------------------------------------------
46464       IMPLICIT NONE
46465       DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
46466       DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
46467       EXTERNAL HWULI2
46468       COMMON/SMALL/EPSI
46469       PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
46470       IF(B.EQ.ZERO)THEN
46471          HWUCI2=DCMPLX(ZERO,ZERO)
46472       ELSE
46473          Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
46474          Y2=ONE-Y1
46475          Z1=Y0/(Y0-Y1)
46476          Z2=(Y0-ONE)/(Y0-Y1)
46477          Z3=Y0/(Y0-Y2)
46478          Z4=(Y0-ONE)/(Y0-Y2)
46479          HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
46480       ENDIF
46481       RETURN
46482       END
46483 CDECK  ID>, HWUDAT.
46484 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
46485 *-- Author :    Ian Knowles & Bryan Webber
46486 C-----------------------------------------------------------------------
46487       BLOCK DATA HWUDAT
46488 C-----------------------------------------------------------------------
46489 C     Loads common blocks with particle properties data; for particle I:
46490 C        RNAME(I) = Name
46491 C        IDPDG(I) = PDG code
46492 C        IFLAV(I) = HERWIG flavour code
46493 C        ICHRG(I) = Electric charge (|e-|)          (*3 for (di-)quarks)
46494 C        RMASS(I) = Mass (GeV/c^2)
46495 C        RLTIM(I) = Proper life time (s)
46496 C        RSPIN(I) = Spin
46497 C       QORQQB(I) = .TRUE. if it is a quark or an antidiquark
46498 C       QBORQQ(I) = .TRUE. if it is an antiquark or a diquark
46499 C     And stores the particle decay tables: call HWUDPR to print them
46500 C-----------------------------------------------------------------------
46501       INCLUDE 'HERWIG65.INC'
46502       INTEGER NLAST,NNEXT,NLEFT,NREST,I,J,MMWIDE,MMLONG,MMHOFF,MMVOFF
46503       COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
46504       PARAMETER (NLAST=458,NNEXT=458+1,NLEFT=NMXRES-458)
46505       PARAMETER (NREST=NMXRES-120)
46506       DATA NRES/458/
46507 C Don't forget to change the three occurances above as well
46508       DATA MMWIDE,MMLONG,MMHOFF,MMVOFF/190,280,-39,-35/
46509       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46510      &      RSPIN(I),I=0,16)/
46511      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46512      & 'DQRK    ',       1,   0,-1,0.3200D0,0.000D+00,0.5D0,
46513      & 'UQRK    ',       2,   0,+2,0.3200D0,0.000D+00,0.5D0,
46514      & 'SQRK    ',       3,   0,-1,0.5000D0,0.000D+00,0.5D0,
46515      & 'CQRK    ',       4,   0,+2,1.5500D0,0.000D+00,0.5D0,
46516      & 'BQRK    ',       5,   0,-1,4.9500D0,0.000D+00,0.5D0,
46517      & 'TQRK    ',       6,   0,+2,174.30D0,4.000D-25,0.5D0,
46518      & 'DBAR    ',      -1,   0,+1,0.3200D0,0.000D+00,0.5D0,
46519      & 'UBAR    ',      -2,   0,-2,0.3200D0,0.000D+00,0.5D0,
46520      & 'SBAR    ',      -3,   0,+1,0.5000D0,0.000D+00,0.5D0,
46521      & 'CBAR    ',      -4,   0,-2,1.5500D0,0.000D+00,0.5D0,
46522      & 'BBAR    ',      -5,   0,+1,4.9500D0,0.000D+00,0.5D0,
46523      & 'TBAR    ',      -6,   0,-2,174.30D0,4.000D-25,0.5D0,
46524      & 'GLUON   ',      21,   0, 0,0.7500D0,0.000D+00,1.0D0,
46525      & 'CMF     ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46526      & 'HARD    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46527      & 'SOFT    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0/
46528       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46529      &      RSPIN(I),I=17,32)/
46530      & 'CONE    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46531      & 'HEAVY   ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46532      & 'CLUS    ',      91,   0, 0,0.0000D0,0.000D+00,0.0D0,
46533      & '****    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46534      & 'PI0     ',     111,  11, 0,.13498D0,8.400D-17,0.0D0,
46535      & 'ETA     ',     221,  33, 0,.54730D0,0.000D+00,0.0D0,
46536      & 'RHO0    ',     113,  11, 0,.77000D0,0.000D+00,1.0D0,
46537      & 'OMEGA   ',     223,  33, 0,.78194D0,0.000D+00,1.0D0,
46538      & 'ETAP    ',     331,  33, 0,.95778D0,0.000D+00,0.0D0,
46539      & 'F_2     ',     225,  33, 0,1.2750D0,0.000D+00,2.0D0,
46540      & 'A_10    ',   20113,  11, 0,1.2300D0,0.000D+00,1.0D0,
46541      & 'FL_1    ',   20223,  33, 0,1.2819D0,0.000D+00,1.0D0,
46542      & 'A_20    ',     115,  11, 0,1.3181D0,0.000D+00,2.0D0,
46543      & 'PI-     ',    -211,  12,-1,.13957D0,2.603D-08,0.0D0,
46544      & 'RHO-    ',    -213,  12,-1,.77000D0,0.000D+00,1.0D0,
46545      & 'A_1-    ',  -20213,  12,-1,1.2300D0,0.000D+00,1.0D0/
46546       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46547      &      RSPIN(I),I=33,48)/
46548      & 'A_2-    ',    -215,  12,-1,1.3181D0,0.000D+00,2.0D0,
46549      & 'K-      ',    -321,  32,-1,.49368D0,1.237D-08,0.0D0,
46550      & 'K*-     ',    -323,  32,-1,.89166D0,0.000D+00,1.0D0,
46551      & 'KH_1-   ',  -20323,  32,-1,1.8500D0,0.000D+00,1.0D0,
46552      & 'K*_2-   ',    -325,  32,-1,1.4256D0,0.000D+00,2.0D0,
46553      & 'PI+     ',     211,  21,+1,.13957D0,2.603D-08,0.0D0,
46554      & 'RHO+    ',     213,  21,+1,.77000D0,0.000D+00,1.0D0,
46555      & 'A_1+    ',   20213,  21,+1,1.2300D0,0.000D+00,1.0D0,
46556      & 'A_2+    ',     215,  21,+1,1.3181D0,0.000D+00,2.0D0,
46557      & 'KBAR0   ',    -311,  31, 0,.49767D0,0.000D+00,0.0D0,
46558      & 'K*BAR0  ',    -313,  31, 0,.89610D0,0.000D+00,1.0D0,
46559      & 'KH_1BAR0',  -20313,  31, 0,1.8500D0,0.000D+00,1.0D0,
46560      & 'K*_2BAR0',    -315,  31, 0,1.4324D0,0.000D+00,2.0D0,
46561      & 'K+      ',     321,  23,+1,.49368D0,1.237D-08,0.0D0,
46562      & 'K*+     ',     323,  23,+1,.89166D0,0.000D+00,1.0D0,
46563      & 'KH_1+   ',   20323,  23,+1,1.8500D0,0.000D+00,1.0D0/
46564       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46565      &      RSPIN(I),I=49,64)/
46566      & 'K*_2+   ',     325,  23,+1,1.4256D0,0.000D+00,2.0D0,
46567      & 'K0      ',     311,  13, 0,.49767D0,0.000D+00,0.0D0,
46568      & 'K*0     ',     313,  13, 0,.89610D0,0.000D+00,1.0D0,
46569      & 'KH_10   ',   20313,  13, 0,1.8500D0,0.000D+00,1.0D0,
46570      & 'K*_20   ',     315,  13, 0,1.4324D0,0.000D+00,2.0D0,
46571      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46572      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46573      & 'PHI     ',     333,  33, 0,1.0194D0,0.000D+00,1.0D0,
46574      & 'FH_1    ',   20333,  33, 0,1.4262D0,0.000D+00,1.0D0,
46575      & 'FP_2    ',     335,  33, 0,1.5250D0,0.000D+00,2.0D0,
46576      & 'GAMMA   ',      22,   0, 0,0.0000D0,1.000D+30,1.0D0,
46577      & 'K_S0    ',     310,   0, 0,.49767D0,8.926D-11,0.0D0,
46578      & 'K_L0    ',     130,   0, 0,.49767D0,5.170D-08,0.0D0,
46579      & 'A_0(H)0 ',   10111,  11, 0,1.4740D0,0.000D+00,0.0D0,
46580      & 'A_0(H)+ ',   10211,  21,+1,1.4740D0,0.000D+00,0.0D0,
46581      & 'A_0(H)- ',  -10211,  12,-1,1.4740D0,0.000D+00,0.0D0/
46582       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46583      &      RSPIN(I),I=65,80)/
46584      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46585      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46586      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46587      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46588      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46589      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46590      & 'REMG    ',      98,   0, 0,0.0000D0,0.000D+00,0.0D0,
46591      & 'REMN    ',      99,   0, 0,0.0000D0,0.000D+00,0.0D0,
46592      & 'P       ',    2212, 122,+1,.93827D0,1.000D+30,0.5D0,
46593      & 'DELTA+  ',    2214, 122,+1,1.2320D0,0.000D+00,1.5D0,
46594      & 'N       ',    2112, 112, 0,.93957D0,8.870D+02,0.5D0,
46595      & 'DELTA0  ',    2114, 112, 0,1.2320D0,0.000D+00,1.5D0,
46596      & 'DELTA-  ',    1114, 111,-1,1.2320D0,0.000D+00,1.5D0,
46597      & 'LAMBDA  ',    3122, 123, 0,1.1157D0,2.632D-10,0.5D0,
46598      & 'SIGMA0  ',    3212, 123, 0,1.1926D0,7.400D-20,0.5D0,
46599      & 'SIGMA*0 ',    3214, 123, 0,1.3837D0,0.000D+00,1.5D0/
46600       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46601      &      RSPIN(I),I=81,96)/
46602      & 'SIGMA-  ',    3112, 113,-1,1.1974D0,1.479D-10,0.5D0,
46603      & 'SIGMA*- ',    3114, 113,-1,1.3872D0,0.000D+00,1.5D0,
46604      & 'XI-     ',    3312, 133,-1,1.3213D0,1.639D-10,0.5D0,
46605      & 'XI*-    ',    3314, 133,-1,1.5350D0,0.000D+00,1.5D0,
46606      & 'DELTA++ ',    2224, 222,+2,1.2320D0,0.000D+00,1.5D0,
46607      & 'SIGMA+  ',    3222, 223,+1,1.1894D0,7.990D-11,0.5D0,
46608      & 'SIGMA*+ ',    3224, 223,+1,1.3828D0,0.000D+00,1.5D0,
46609      & 'XI0     ',    3322, 233, 0,1.3149D0,2.900D-10,0.5D0,
46610      & 'XI*0    ',    3324, 233, 0,1.5318D0,0.000D+00,1.5D0,
46611      & 'OMEGA-  ',    3334, 333,-1,1.6725D0,8.220D-11,1.5D0,
46612      & 'PBAR    ',   -2212,-122,-1,.93827D0,1.000D+30,0.5D0,
46613      & 'DELTABR-',   -2214,-122,-1,1.2320D0,0.000D+00,1.5D0,
46614      & 'NBAR    ',   -2112,-112, 0,.93957D0,8.870D+02,0.5D0,
46615      & 'DELTABR0',   -2114,-112, 0,1.2320D0,0.000D+00,1.5D0,
46616      & 'DELTABR+',   -1114,-111,+1,1.2320D0,0.000D+00,1.5D0,
46617      & 'LAMBDABR',   -3122,-123, 0,1.1157D0,2.632D-10,0.5D0/
46618       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46619      &      RSPIN(I),I=97,112)/
46620      & 'SIGMABR0',   -3212,-123, 0,1.1926D0,7.400D-20,0.5D0,
46621      & 'SGMA*BR0',   -3214,-123, 0,1.3837D0,0.000D+00,1.5D0,
46622      & 'SIGMABR+',   -3112,-113,+1,1.1974D0,1.479D-10,0.5D0,
46623      & 'SGMA*BR+',   -3114,-113,+1,1.3872D0,0.000D+00,1.5D0,
46624      & 'XIBAR+  ',   -3312,-133,+1,1.3213D0,1.639D-10,0.5D0,
46625      & 'XI*BAR+ ',   -3314,-133,+1,1.5350D0,0.000D+00,1.5D0,
46626      & 'DLTABR--',   -2224,-222,-2,1.2320D0,0.000D+00,1.5D0,
46627      & 'SIGMABR-',   -3222,-223,-1,1.1894D0,7.990D-11,0.5D0,
46628      & 'SGMA*BR-',   -3224,-223,-1,1.3828D0,0.000D+00,1.5D0,
46629      & 'XIBAR0  ',   -3322,-233, 0,1.3149D0,2.900D-10,0.5D0,
46630      & 'XI*BAR  ',   -3324,-233, 0,1.5318D0,0.000D+00,1.5D0,
46631      & 'OMEGABR+',   -3334,-333,+1,1.6725D0,8.220D-11,1.5D0,
46632      & 'UU      ',    2203,   0,+4,0.6400D0,0.000D+00,0.0D0,
46633      & 'UD      ',    2101,   0,+1,0.6400D0,0.000D+00,0.0D0,
46634      & 'DD      ',    1103,   0,-2,0.6400D0,0.000D+00,0.0D0,
46635      & 'US      ',    3201,   0,+1,0.8200D0,0.000D+00,0.0D0/
46636       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46637      &      RSPIN(I),I=113,128)/
46638      & 'DS      ',    3101,   0,-2,0.8200D0,0.000D+00,0.0D0,
46639      & 'SS      ',    3303,   0,-2,1.0000D0,0.000D+00,0.0D0,
46640      & 'UBARUBAR',   -2203,   0,-4,0.6400D0,0.000D+00,0.0D0,
46641      & 'UBARDBAR',   -2101,   0,-1,0.6400D0,0.000D+00,0.0D0,
46642      & 'DBARDBAR',   -1103,   0,+2,0.6400D0,0.000D+00,0.0D0,
46643      & 'UBARSBAR',   -3201,   0,-1,0.8200D0,0.000D+00,0.0D0,
46644      & 'DBARSBAR',   -3101,   0,+2,0.8200D0,0.000D+00,0.0D0,
46645      & 'SBARSBAR',   -3303,   0,+2,1.0000D0,0.000D+00,0.0D0,
46646      & 'E-      ',      11,   0,-1,5.11D-04,1.000D+30,0.5D0,
46647      & 'NU_E    ',      12,   0, 0,0.0000D0,1.000D+30,0.5D0,
46648      & 'MU-     ',      13,   0,-1,.10566D0,2.197D-06,0.5D0,
46649      & 'NU_MU   ',      14,   0, 0,0.0000D0,1.000D+30,0.5D0,
46650      & 'TAU-    ',      15,   0,-1,1.7771D0,2.916D-13,0.5D0,
46651      & 'NU_TAU  ',      16,   0, 0,0.0000D0,1.000D+30,0.5D0,
46652      & 'E+      ',     -11,   0,+1,5.11D-04,1.000D+30,0.5D0,
46653      & 'NU_EBAR ',     -12,   0, 0,0.0000D0,1.000D+30,0.5D0/
46654       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46655      &      RSPIN(I),I=129,144)/
46656      & 'MU+     ',     -13,   0,+1,.10566D0,2.197D-06,0.5D0,
46657      & 'NU_MUBAR',     -14,   0, 0,0.0000D0,1.000D+30,0.5D0,
46658      & 'TAU+    ',     -15,   0,+1,1.7771D0,2.916D-13,0.5D0,
46659      & 'NU_TAUBR',     -16,   0, 0,0.0000D0,1.000D+30,0.5D0,
46660      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46661      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46662      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46663      & 'D+      ',     411,  41,+1,1.8693D0,1.057D-12,0.0D0,
46664      & 'D*+     ',     413,  41,+1,2.0100D0,0.000D+00,1.0D0,
46665      & 'DH_1+   ',   20413,  41,+1,2.4270D0,0.000D+00,1.0D0,
46666      & 'D*_2+   ',     415,  41,+1,2.4590D0,0.000D+00,2.0D0,
46667      & 'D0      ',     421,  42, 0,1.8646D0,4.150D-13,0.0D0,
46668      & 'D*0     ',     423,  42, 0,2.0067D0,0.000D+00,1.0D0,
46669      & 'DH_10   ',   20423,  42, 0,2.4222D0,0.000D+00,1.0D0,
46670      & 'D*_20   ',     425,  42, 0,2.4589D0,0.000D+00,2.0D0,
46671      & 'D_S+    ',     431,  43,+1,1.9685D0,4.670D-13,0.0D0/
46672       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46673      &      RSPIN(I),I=145,160)/
46674      & 'D*_S+   ',     433,  43,+1,2.1124D0,0.000D+00,1.0D0,
46675      & 'DH_S1+  ',   20433,  43,+1,2.5354D0,0.000D+00,1.0D0,
46676      & 'D*_S2+  ',     435,  43,+1,2.5735D0,0.000D+00,2.0D0,
46677      & 'SGMA_C++',    4222, 224,+2,2.4528D0,0.000D+00,0.5D0,
46678      & 'SGM*_C++',    4224, 224,+2,2.5194D0,0.000D+00,1.5D0,
46679      & 'LMBDA_C+',    4122, 124,+1,2.2849D0,2.060D-13,0.5D0,
46680      & 'SIGMA_C+',    4212, 124,+1,2.4536D0,0.000D+00,0.5D0,
46681      & 'SGMA*_C+',    4214, 124,+1,2.5185D0,0.000D+00,1.5D0,
46682      & 'SIGMA_C0',    4112, 114, 0,2.4522D0,0.000D+00,0.5D0,
46683      & 'SGMA*_C0',    4114, 114, 0,2.5175D0,0.000D+00,1.5D0,
46684      & 'XI_C+   ',    4232, 234,+1,2.4656D0,3.500D-13,0.5D0,
46685      & 'XIP_C+  ',    4322, 234,+1,2.5750D0,0.000D+00,0.5D0,
46686      & 'XI*_C+  ',    4324, 234,+1,2.6446D0,0.000D+00,1.5D0,
46687      & 'XI_C0   ',    4132, 134, 0,2.4703D0,9.800D-14,0.5D0,
46688      & 'XIP_C0  ',    4312, 134, 0,2.5800D0,0.000D+00,0.5D0,
46689      & 'XI*_C0  ',    4314, 134, 0,2.6438D0,0.000D+00,1.5D0/
46690       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46691      &      RSPIN(I),I=161,176)/
46692      & 'OMEGA_C0',    4332, 334, 0,2.7040D0,6.400D-14,0.5D0,
46693      & 'OMGA*_C0',    4334, 334, 0,2.7300D0,0.000D+00,1.5D0,
46694      & 'ETA_C   ',     441,  44, 0,2.9798D0,0.000D+00,0.0D0,
46695      & 'JPSI    ',     443,  44, 0,3.0969D0,0.000D+00,1.0D0,
46696      & 'CHI_C1  ',   10441,  44, 0,3.4173D0,0.000D+00,0.0D0,
46697      & 'PSI2S   ',  100443,  44, 0,3.6860D0,0.000D+00,1.0D0,
46698      & 'PSID    ',   30443,  44, 0,3.7699D0,0.000D+00,1.0D0,
46699      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46700      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46701      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46702      & 'D-      ',    -411,  14,-1,1.8693D0,1.057D-12,0.0D0,
46703      & 'D*-     ',    -413,  14,-1,2.0100D0,0.000D+00,1.0D0,
46704      & 'DH_1-   ',  -20413,  14,-1,2.4270D0,0.000D+00,1.0D0,
46705      & 'D*_2-   ',    -415,  14,-1,2.4590D0,0.000D+00,2.0D0,
46706      & 'DBAR0   ',    -421,  24, 0,1.8646D0,4.140D-13,0.0D0,
46707      & 'D*BAR0  ',    -423,  24, 0,2.0067D0,0.000D+00,1.0D0/
46708       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46709      &      RSPIN(I),I=177,192)/
46710      & 'DH_1BAR0',  -20423,  24, 0,2.4222D0,0.000D+00,1.0D0,
46711      & 'D*_2BAR0',    -425,  24, 0,2.4589D0,0.000D+00,2.0D0,
46712      & 'D_S-    ',    -431,  34,-1,1.9685D0,4.670D-13,0.0D0,
46713      & 'D*_S-   ',    -433,  34,-1,2.1124D0,0.000D+00,1.0D0,
46714      & 'DH_S1-  ',  -20433,  34,-1,2.5354D0,0.000D+00,1.0D0,
46715      & 'D*_S2-  ',    -435,  34,-1,2.5735D0,0.000D+00,2.0D0,
46716      & 'SGMA_C--',   -4222,-224,-2,2.4528D0,0.000D+00,0.5D0,
46717      & 'SGM*_C--',   -4224,-224,-2,2.5194D0,0.000D+00,1.5D0,
46718      & 'LMBDA_C-',   -4122,-124,-1,2.2849D0,2.060D-13,0.5D0,
46719      & 'SIGMA_C-',   -4212,-124,-1,2.4536D0,0.000D+00,0.5D0,
46720      & 'SGMA*_C-',   -4214,-124,-1,2.5185D0,0.000D+00,1.5D0,
46721      & 'SGM_CBR0',   -4112,-114, 0,2.4522D0,0.000D+00,0.5D0,
46722      & 'SG*_CBR0',   -4114,-114, 0,2.5175D0,0.000D+00,1.5D0,
46723      & 'XI_C-   ',   -4232,-234,-1,2.4656D0,3.500D-13,0.5D0,
46724      & 'XIP_C-  ',   -4322,-234,-1,2.5750D0,0.000D+00,0.5D0,
46725      & 'XI*_C-  ',   -4324,-234,-1,2.6446D0,0.000D+00,1.5D0/
46726       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46727      &      RSPIN(I),I=193,208)/
46728      & 'XI_CBAR0',   -4132,-134, 0,2.4703D0,9.800D-14,0.5D0,
46729      & 'XIP_CBR0',   -4312,-134, 0,2.5800D0,0.000D+00,0.5D0,
46730      & 'XI*_CBR0',   -4314,-134, 0,2.6438D0,0.000D+00,1.5D0,
46731      & 'OMG_CBR0',   -4332,-334, 0,2.7040D0,6.400D-14,0.5D0,
46732      & 'OM*_CBR0',   -4334,-334, 0,2.7300D0,0.000D+00,1.5D0,
46733      & 'W+      ',      24,   0,+1,80.420D0,0.000D+00,1.0D0,
46734      & 'W-      ',     -24,   0,-1,80.420D0,0.000D+00,1.0D0,
46735      & 'Z0/GAMA*',      23,   0, 0,91.188D0,0.000D+00,1.0D0,
46736      & 'HIGGS   ',      25,   0, 0,115.00D0,0.000D+00,0.0D0,
46737      & 'Z0P     ',      32,   0, 0,500.00D0,0.000D+00,1.0D0,
46738      & 'HIGGSL0 ',      26,   0, 0,0.0000D0,1.000D+30,0.0D0,
46739      & 'HIGGSH0 ',      35,   0, 0,0.0000D0,1.000D+30,0.0D0,
46740      & 'HIGGSA0 ',      36,   0, 0,0.0000D0,1.000D+30,0.0D0,
46741      & 'HIGGS+  ',      37,   0,+1,0.0000D0,1.000D+30,0.0D0,
46742      & 'HIGGS-  ',     -37,   0,-1,0.0000D0,1.000D+30,0.0D0,
46743      & 'GRAVITON',      39,   0, 0,0.0000D0,1.000D+30,2.0D0/
46744       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46745      &      RSPIN(I),I=209,224)/
46746      & 'VQRK    ',       7,   0,-1,200.00D0,0.000D+00,0.5D0,
46747      & 'AQRK    ',       8,   0,+2,400.00D0,0.000D+00,0.5D0,
46748      & 'HQRK    ',       7,   0,-1,400.00D0,0.000D+00,0.5D0,
46749      & 'HPQK    ',       8,   0,+2,600.00D0,0.000D+00,0.5D0,
46750      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46751      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46752      & 'VBAR    ',      -7,   0,+1,200.00D0,0.000D+00,0.5D0,
46753      & 'ABAR    ',      -8,   0,-2,400.00D0,0.000D+00,0.5D0,
46754      & 'HBAR    ',      -7,   0,+1,400.00D0,0.000D+00,0.5D0,
46755      & 'HPBR    ',      -8,   0,-2,600.00D0,0.000D+00,0.5D0,
46756      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46757      & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
46758      & 'B_DBAR0 ',    -511,  51, 0,5.2792D0,1.614D-12,0.0D0,
46759      & 'B-      ',    -521,  52,-1,5.2789D0,1.652D-12,0.0D0,
46760      & 'B_SBAR0 ',    -531,  53, 0,5.3693D0,1.540D-12,0.0D0,
46761      & 'SIGMA_B+',    5222, 225,+1,5.8200D0,1.070D-12,0.5D0/
46762       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46763      &      RSPIN(I),I=225,240)/
46764      & 'LMBDA_B0',    5122, 125, 0,5.6240D0,1.070D-12,0.5D0,
46765      & 'SIGMA_B-',    5112, 115,-1,5.8200D0,1.070D-12,0.5D0,
46766      & 'XI_B0   ',    5232, 235, 0,5.8000D0,1.070D-12,0.5D0,
46767      & 'XI_B-   ',    5132, 135,-1,5.8000D0,1.070D-12,0.5D0,
46768      & 'OMEGA_B-',    5332, 335,-1,6.0400D0,1.070D-12,0.5D0,
46769      & 'B_C-    ',    -541,  54,-1,6.2500D0,1.000D-12,0.5D0,
46770      & 'UPSLON1S',     553,  55, 0,9.4604D0,0.000D+00,1.0D0,
46771      & 'T_B-    ',    -651,  56,-1,0.0000D0,0.000D+00,0.0D0,
46772      & 'T+      ',     611,  61,+1,0.0000D0,0.000D+00,0.0D0,
46773      & 'T0      ',     621,  62, 0,0.0000D0,0.000D+00,0.0D0,
46774      & 'T_S+    ',     631,  63,+1,0.0000D0,0.000D+00,0.0D0,
46775      & 'SGMA_T++',    6222, 226,+2,0.0000D0,0.000D+00,0.5D0,
46776      & 'LMBDA_T0',    6122, 126,+1,0.0000D0,0.000D+00,0.5D0,
46777      & 'SIGMA_T0',    6112, 116, 0,0.0000D0,0.000D+00,0.5D0,
46778      & 'XI_T+   ',    6232, 236,+1,0.0000D0,0.000D+00,0.5D0,
46779      & 'XI_T0   ',    6132, 136, 0,0.0000D0,0.000D+00,0.5D0/
46780       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46781      &      RSPIN(I),I=241,256)/
46782      & 'OMEGA_T0',    6332, 336, 0,0.0000D0,0.000D+00,0.5D0,
46783      & 'T_C0    ',     641,  64, 0,0.0000D0,0.000D+00,0.0D0,
46784      & 'T_B+    ',     651,  65,+1,0.0000D0,0.000D+00,0.0D0,
46785      & 'TOPONIUM',     663,  66, 0,0.0000D0,0.000D+00,1.0D0,
46786      & 'B_D0    ',     511,  15, 0,5.2792D0,1.614D-12,0.0D0,
46787      & 'B+      ',     521,  25,+1,5.2789D0,1.652D-12,0.0D0,
46788      & 'B_S0    ',     531,  35, 0,5.3693D0,1.540D-12,0.0D0,
46789      & 'SGM_BBR-',   -5222,-225,-1,5.8200D0,1.070D-12,0.5D0,
46790      & 'LMD_BBR0',   -5122,-125, 0,5.6240D0,1.070D-12,0.5D0,
46791      & 'SGM_BBR+',   -5112,-115,+1,5.8200D0,1.070D-12,0.5D0,
46792      & 'XI_BBAR0',   -5232,-235, 0,5.8000D0,1.070D-12,0.5D0,
46793      & 'XI_B+   ',   -5132,-135,+1,5.8000D0,1.070D-12,0.5D0,
46794      & 'OMG_BBR+',   -5332,-335,+1,6.0400D0,1.070D-12,0.5D0,
46795      & 'B_C+    ',     541,  45,+1,6.2500D0,1.000D-12,0.5D0,
46796      & 'T-      ',    -611,  16,-1,0.0000D0,0.000D+00,0.0D0,
46797      & 'TBAR0   ',    -621,  26, 0,0.0000D0,0.000D+00,0.0D0/
46798       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46799      &      RSPIN(I),I=257,272)/
46800      & 'T_S-    ',    -631,  36,-1,0.0000D0,0.000D+00,0.0D0,
46801      & 'SGMA_T--',   -6222,-226,-2,0.0000D0,0.000D+00,0.5D0,
46802      & 'LAMDA_T-',   -6122,-126,-1,0.0000D0,0.000D+00,0.5D0,
46803      & 'SGM_TBR0',   -6112,-116, 0,0.0000D0,0.000D+00,0.5D0,
46804      & 'XI_T-   ',   -6232,-236,-1,0.0000D0,0.000D+00,0.5D0,
46805      & 'XI_TBAR0',   -6132,-136, 0,0.0000D0,0.000D+00,0.5D0,
46806      & 'OMG_TBR0',   -6332,-336, 0,0.0000D0,0.000D+00,0.5D0,
46807      & 'T_CBAR0 ',    -641,  46, 0,0.0000D0,0.000D+00,0.0D0,
46808      & 'B*BAR0  ',    -513,  51, 0,5.3249D0,0.000D+00,1.0D0,
46809      & 'B*-     ',    -523,  52,-1,5.3249D0,0.000D+00,1.0D0,
46810      & 'B*_SBAR0',    -533,  53, 0,5.4163D0,0.000D+00,1.0D0,
46811      & 'BH_1BAR0',  -20513,  51, 0,5.7600D0,0.000D+00,1.0D0,
46812      & 'BH_1-   ',  -20523,  52,-1,5.7600D0,0.000D+00,1.0D0,
46813      & 'BH_S1BR0',  -20533,  53, 0,5.8550D0,0.000D+00,1.0D0,
46814      & 'B*_2BAR0',    -515,  51, 0,5.7700D0,0.000D+00,2.0D0,
46815      & 'B*_2-   ',    -525,  52,-1,5.7700D0,0.000D+00,2.0D0/
46816       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46817      &      RSPIN(I),I=273,288)/
46818      & 'B*_S2BR0',    -535,  53, 0,5.8650D0,0.000D+00,2.0D0,
46819      & 'B*0     ',     513,  15, 0,5.3249D0,0.000D+00,1.0D0,
46820      & 'B*+     ',     523,  25,+1,5.3249D0,0.000D+00,1.0D0,
46821      & 'B*_S0   ',     533,  35, 0,5.4163D0,0.000D+00,1.0D0,
46822      & 'BH_10   ',   20513,  15, 0,5.7600D0,0.000D+00,1.0D0,
46823      & 'BH_1+   ',   20523,  25,+1,5.7600D0,0.000D+00,1.0D0,
46824      & 'BH_S10  ',   20533,  35, 0,5.8550D0,0.000D+00,1.0D0,
46825      & 'B*_20   ',     515,  15, 0,5.7700D0,0.000D+00,2.0D0,
46826      & 'B*_2+   ',     525,  25,+1,5.7700D0,0.000D+00,2.0D0,
46827      & 'B*_S20  ',     535,  35, 0,5.8650D0,0.000D+00,2.0D0,
46828      & '        ',       0,   0, 0,0.0000D0,0.000D+00,  0D0,
46829      & '        ',       0,   0, 0,0.0000D0,0.000D+00,  0D0,
46830      & 'B_10    ',   10113,  11, 0,1.2295D0,0.000D+00,1.0D0,
46831      & 'B_1+    ',   10213,  21,+1,1.2295D0,0.000D+00,1.0D0,
46832      & 'B_1-    ',  -10213,  12,-1,1.2295D0,0.000D+00,1.0D0,
46833      & 'HL_10   ',   10223,  33, 0,1.1700D0,0.000D+00,1.0D0/
46834       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46835      &      RSPIN(I),I=289,304)/
46836      & 'HH_10   ',   10333,  33, 0,1.3950D0,0.000D+00,1.0D0,
46837      & 'A_00    ', 9000111,  11, 0,.99600D0,0.000D+00,0.0D0,
46838      & 'A_0+    ', 9000211,  21,+1,.99600D0,0.000D+00,0.0D0,
46839      & 'A_0-    ',-9000211,  12,-1,.99600D0,0.000D+00,0.0D0,
46840      & 'F0P0    ', 9010221,  33, 0,.99600D0,0.000D+00,0.0D0,
46841      & 'FH_00   ',   10221,  33, 0,1.3500D0,0.000D+00,0.0D0,
46842      & 'B*_C+   ',     543,  45,+1,6.2950D0,0.000D+00,1.0D0,
46843      & 'B*_C-   ',    -543,  54,-1,6.2950D0,0.000D+00,1.0D0,
46844      & 'BH_C1+  ',   20543,  45,+1,6.7300D0,0.000D+00,1.0D0,
46845      & 'BH_C1-  ',  -20543,  54,-1,6.7300D0,0.000D+00,1.0D0,
46846      & 'B*_C2+  ',     545,  45,+1,6.7400D0,0.000D+00,2.0D0,
46847      & 'B*_C2-  ',    -545,  54,-1,6.7400D0,0.000D+00,2.0D0,
46848      & 'H_C     ',   10443,  44, 0,3.5261D0,0.000D+00,1.0D0,
46849      & 'CHI_C0  ',   20443,  44, 0,3.5105D0,0.000D+00,0.0D0,
46850      & 'CHI_C2  ',     445,  44, 0,3.5562D0,0.000D+00,2.0D0,
46851      & 'ETA_B   ',     551,  55, 0,9.0000D0,0.000D+00,0.0D0/
46852       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46853      &      RSPIN(I),I=305,320)/
46854      & 'H_B     ',   10553,  55, 0,9.8880D0,0.000D+00,1.0D0,
46855      & 'CHI_B0  ',   10551,  55, 0,9.8598D0,0.000D+00,0.0D0,
46856      & 'CHI_B1  ',   20553,  55, 0,9.8919D0,0.000D+00,1.0D0,
46857      & 'CHI_B2  ',     555,  55, 0,9.9132D0,0.000D+00,2.0D0,
46858      & 'KL_10   ',   10313,  13, 0,1.5700D0,0.000D+00,1.0D0,
46859      & 'KL_1+   ',   10323,  23,+1,1.5700D0,0.000D+00,1.0D0,
46860      & 'KL_1BAR0',  -10313,  31, 0,1.5700D0,0.000D+00,1.0D0,
46861      & 'KL_1-   ',  -10323,  32,-1,1.5700D0,0.000D+00,1.0D0,
46862      & 'DL_1+   ',   10413,  41,+1,2.4270D0,0.000D+00,1.0D0,
46863      & 'DL_10   ',   10423,  42, 0,2.4222D0,0.000D+00,1.0D0,
46864      & 'DL_S1+  ',   10433,  43,+1,2.5354D0,0.000D+00,1.0D0,
46865      & 'DL_1-   ',  -10413,  14,-1,2.4270D0,0.000D+00,1.0D0,
46866      & 'DL_1BAR0',  -10423,  24, 0,2.4222D0,0.000D+00,1.0D0,
46867      & 'DL_S1-  ',  -10433,  34,-1,2.5354D0,0.000D+00,1.0D0,
46868      & 'BL_10   ',   10513,  15, 0,5.7600D0,0.000D+00,1.0D0,
46869      & 'BL_1+   ',   10523,  25,+1,5.7600D0,0.000D+00,1.0D0/
46870       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46871      &      RSPIN(I),I=321,336)/
46872      & 'BL_S10  ',   10533,  35, 0,5.8530D0,0.000D+00,1.0D0,
46873      & 'BL_C1+  ',   10543,  45,+1,6.7300D0,0.000D+00,1.0D0,
46874      & 'BL_1BAR0',  -10513,  51, 0,5.7600D0,0.000D+00,1.0D0,
46875      & 'BL_1-   ',  -10523,  52,-1,5.7600D0,0.000D+00,1.0D0,
46876      & 'BL_S1BR0',  -10533,  53, 0,5.8530D0,0.000D+00,1.0D0,
46877      & 'BL_C1-  ',  -10543,  54,-1,6.7300D0,0.000D+00,1.0D0,
46878      & 'K*_0+   ',   10321,  23,+1,1.4290D0,0.000D+00,0.0D0,
46879      & 'K*_00   ',   10311,  13, 0,1.4290D0,0.000D+00,0.0D0,
46880      & 'K*_0BAR0',  -10311,  31, 0,1.4290D0,0.000D+00,0.0D0,
46881      & 'K*_0-   ',  -10321,  32,-1,1.4290D0,0.000D+00,0.0D0,
46882      & 'D*_0+   ',   10411,  41,+1,2.4230D0,0.000D+00,0.0D0,
46883      & 'D*_00   ',   10421,  42, 0,2.4230D0,0.000D+00,0.0D0,
46884      & 'D*_S0+  ',   10431,  43,+1,2.5250D0,0.000D+00,0.0D0,
46885      & 'D*_0-   ',  -10411,  14,-1,2.4230D0,0.000D+00,0.0D0,
46886      & 'D*_0BAR0',  -10421,  24, 0,2.4230D0,0.000D+00,0.0D0,
46887      & 'D*_S0-  ',  -10431,  34,-1,2.5250D0,0.000D+00,0.0D0/
46888       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46889      &      RSPIN(I),I=337,352)/
46890      & 'B*_00   ',   10511,  15, 0,5.7600D0,0.000D+00,0.0D0,
46891      & 'B*_0+   ',   10521,  25,+1,5.7600D0,0.000D+00,0.0D0,
46892      & 'B*_S00  ',   10531,  35, 0,5.8550D0,0.000D+00,0.0D0,
46893      & 'B*_C0+  ',   10541,  45,+1,6.7300D0,0.000D+00,0.0D0,
46894      & 'B*_0BAR0',  -10511,  51, 0,5.7600D0,0.000D+00,0.0D0,
46895      & 'B*_0-   ',  -10521,  52,-1,5.7600D0,0.000D+00,0.0D0,
46896      & 'B*_S0BR0',  -10531,  53, 0,5.8550D0,0.000D+00,0.0D0,
46897      & 'B*_C0-  ',  -10541,  54,-1,6.7300D0,0.000D+00,0.0D0,
46898      & 'SGMA*_B-',    5114, 115,-1,5.8400D0,0.000D+00,1.5D0,
46899      & 'SIGMA_B0',    5212, 125, 0,5.8200D0,0.000D+00,0.5D0,
46900      & 'SGMA*_B0',    5214, 125, 0,5.8400D0,0.000D+00,1.5D0,
46901      & 'SGMA*_B+',    5224, 225,+1,5.8400D0,0.000D+00,1.5D0,
46902      & 'XIP_B0  ',    5322, 235, 0,5.9450D0,0.000D+00,0.5D0,
46903      & 'XI*_B0  ',    5324, 235, 0,5.9450D0,0.000D+00,1.5D0,
46904      & 'XIP_B-  ',    5312, 135,-1,5.9450D0,0.000D+00,0.5D0,
46905      & 'XI*_B-  ',    5314, 135,-1,5.9450D0,0.000D+00,1.5D0/
46906       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46907      &      RSPIN(I),I=353,368)/
46908      & '0MGA*_B-',    5334, 335,-1,6.0600D0,0.000D+00,1.5D0,
46909      & 'SG*_BBR+',   -5114,-115,+1,5.8400D0,0.000D+00,1.5D0,
46910      & 'SGM_BBR0',   -5212,-125, 0,5.8200D0,0.000D+00,0.5D0,
46911      & 'SG*_BBR0',   -5214,-125, 0,5.8400D0,0.000D+00,1.5D0,
46912      & 'SG*_BBR-',   -5224,-225,-1,5.8400D0,0.000D+00,1.5D0,
46913      & 'XIP_BBR0',   -5322,-235, 0,5.9450D0,0.000D+00,0.5D0,
46914      & 'XI*_BBR0',   -5324,-235, 0,5.9450D0,0.000D+00,1.5D0,
46915      & 'XIP_B+  ',   -5312,-135,+1,5.9450D0,0.000D+00,0.5D0,
46916      & 'XI*_B+  ',   -5314,-135,+1,5.9450D0,0.000D+00,1.5D0,
46917      & '0MGA*_B+',   -5334,-335,+1,6.0600D0,0.000D+00,1.5D0,
46918      & 'KDL_2+  ',   10325,  23,+1,1.7730D0,0.000D+00,2.0D0,
46919      & 'KDL_20  ',   10315,  13, 0,1.7730D0,0.000D+00,2.0D0,
46920      & 'KDL_2BR0',  -10315,  31, 0,1.7730D0,0.000D+00,2.0D0,
46921      & 'KDL_2-  ',  -10325,  32,-1,1.7730D0,0.000D+00,2.0D0,
46922      & 'KD*+    ',   30323,  23,+1,1.7170D0,0.000D+00,1.0D0,
46923      & 'KD*0    ',   30313,  13, 0,1.7170D0,0.000D+00,1.0D0/
46924       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46925      &      RSPIN(I),I=369,384)/
46926      & 'KD*BAR0 ',  -30313,  31, 0,1.7170D0,0.000D+00,1.0D0,
46927      & 'KD*-    ',  -30323,  32,-1,1.7170D0,0.000D+00,1.0D0,
46928      & 'KDH_2+  ',   20325,  23,+1,1.8160D0,0.000D+00,2.0D0,
46929      & 'KDH_20  ',   20315,  13, 0,1.8160D0,0.000D+00,2.0D0,
46930      & 'KDH_2BR0',  -20315,  31, 0,1.8160D0,0.000D+00,2.0D0,
46931      & 'KDH_2-  ',  -20325,  32,-1,1.8160D0,0.000D+00,2.0D0,
46932      & 'KD_3+   ',     327,  23,+1,1.7730D0,0.000D+00,3.0D0,
46933      & 'KD_30   ',     317,  13, 0,1.7730D0,0.000D+00,3.0D0,
46934      & 'KD_3BAR0',    -317,  31, 0,1.7730D0,0.000D+00,3.0D0,
46935      & 'KD_3-   ',    -327,  32,-1,1.7730D0,0.000D+00,3.0D0,
46936      & 'PI_2+   ',   10215,  21,+1,1.6700D0,0.000D+00,2.0D0,
46937      & 'PI_20   ',   10115,  11, 0,1.6700D0,0.000D+00,2.0D0,
46938      & 'PI_2-   ',  -10215,  12,-1,1.6700D0,0.000D+00,2.0D0,
46939      & 'RHOD+   ',   30213,  21,+1,1.7000D0,0.000D+00,1.0D0,
46940      & 'RHOD0   ',   30113,  11, 0,1.7000D0,0.000D+00,1.0D0,
46941      & 'RHOD-   ',  -30213,  12,-1,1.7000D0,0.000D+00,1.0D0/
46942       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46943      &      RSPIN(I),I=385,400)/
46944      & 'RHO_3+  ',     217,  21,+1,1.6910D0,0.000D+00,3.0D0,
46945      & 'RHO_30  ',     117,  11, 0,1.6910D0,0.000D+00,3.0D0,
46946      & 'RHO_3-  ',    -217,  12,-1,1.6910D0,0.000D+00,3.0D0,
46947      & 'UPSLON2S',  100553,  55, 0,10.023D0,0.000D+00,1.0D0,
46948      & 'CHI2P_B0',  110551,  55, 0,10.232D0,0.000D+00,0.0D0,
46949      & 'CHI2P_B1',  120553,  55, 0,10.255D0,0.000D+00,1.0D0,
46950      & 'CHI2P_B2',  100555,  55, 0,10.269D0,0.000D+00,2.0D0,
46951      & 'UPSLON3S',  200553,  55, 0,10.355D0,0.000D+00,1.0D0,
46952      & 'UPSLON4S',  300553,  55, 0,10.580D0,0.000D+00,1.0D0,
46953      & '        ',       0,   0, 0,0.0   D0,  0.0D+00,  0D0,
46954      & 'OMEGA_3 ',     227,  33, 0,1.6670D0,0.000D+00,3.0D0,
46955      & 'PHI_3   ',     337,  33, 0,1.8540D0,0.000D+00,3.0D0,
46956      & 'ETA_2(L)',   10225,  33, 0,1.6320D0,0.000D+00,2.0D0,
46957      & 'ETA_2(H)',   10335,  33, 0,1.8540D0,0.000D+00,2.0D0,
46958      & 'OMEGA(H)',   30223,  33, 0,1.6490D0,0.000D+00,1.0D0,
46959      & '        ',       0,   0, 0,0.0   D0,0.0D+00  ,  0D0/
46960       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46961      &      RSPIN(I),I=401,416)/
46962      & 'SSDL    ', 1000001,   0,-1,0.00D0,1.000D+30,0.0D0,
46963      & 'SSUL    ', 1000002,   0,+2,0.00D0,1.000D+30,0.0D0,
46964      & 'SSSL    ', 1000003,   0,-1,0.00D0,1.000D+30,0.0D0,
46965      & 'SSCL    ', 1000004,   0,+2,0.00D0,1.000D+30,0.0D0,
46966      & 'SSB1    ', 1000005,   0,-1,0.00D0,1.000D+30,0.0D0,
46967      & 'SST1    ', 1000006,   0,+2,0.00D0,1.000D+30,0.0D0,
46968      & 'SSDLBR  ',-1000001,   0,+1,0.00D0,1.000D+30,0.0D0,
46969      & 'SSULBR  ',-1000002,   0,-2,0.00D0,1.000D+30,0.0D0,
46970      & 'SSSLBR  ',-1000003,   0,+1,0.00D0,1.000D+30,0.0D0,
46971      & 'SSCLBR  ',-1000004,   0,-2,0.00D0,1.000D+30,0.0D0,
46972      & 'SSB1BR  ',-1000005,   0,+1,0.00D0,1.000D+30,0.0D0,
46973      & 'SST1BR  ',-1000006,   0,-2,0.00D0,1.000D+30,0.0D0,
46974      & 'SSDR    ', 2000001,   0,-1,0.00D0,1.000D+30,0.0D0,
46975      & 'SSUR    ', 2000002,   0,+2,0.00D0,1.000D+30,0.0D0,
46976      & 'SSSR    ', 2000003,   0,-1,0.00D0,1.000D+30,0.0D0,
46977      & 'SSCR    ', 2000004,   0,+2,0.00D0,1.000D+30,0.0D0/
46978       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46979      &      RSPIN(I),I=417,432)/
46980      & 'SSB2    ', 2000005,   0,-1,0.00D0,1.000D+30,0.0D0,
46981      & 'SST2    ', 2000006,   0,+2,0.00D0,1.000D+30,0.0D0,
46982      & 'SSDRBR  ',-2000001,   0,+1,0.00D0,1.000D+30,0.0D0,
46983      & 'SSURBR  ',-2000002,   0,-2,0.00D0,1.000D+30,0.0D0,
46984      & 'SSSRBR  ',-2000003,   0,+1,0.00D0,1.000D+30,0.0D0,
46985      & 'SSCRBR  ',-2000004,   0,-2,0.00D0,1.000D+30,0.0D0,
46986      & 'SSB2BR  ',-2000005,   0,+1,0.00D0,1.000D+30,0.0D0,
46987      & 'SST2BR  ',-2000006,   0,-2,0.00D0,1.000D+30,0.0D0,
46988      & 'SSEL-   ', 1000011,   0,-1,0.00D0,1.000D+30,0.0D0,
46989      & 'SSNUEL  ', 1000012,   0, 0,0.00D0,1.000D+30,0.0D0,
46990      & 'SSMUL-  ', 1000013,   0,-1,0.00D0,1.000D+30,0.0D0,
46991      & 'SSNUMUL ', 1000014,   0, 0,0.00D0,1.000D+30,0.0D0,
46992      & 'SSTAU1- ', 1000015,   0,-1,0.00D0,1.000D+30,0.0D0,
46993      & 'SSNUTL  ', 1000016,   0, 0,0.00D0,1.000D+30,0.0D0,
46994      & 'SSEL+   ',-1000011,   0,+1,0.00D0,1.000D+30,0.0D0,
46995      & 'SSNUELBR',-1000012,   0, 0,0.00D0,1.000D+30,0.0D0/
46996       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
46997      &      RSPIN(I),I=433,448)/
46998      & 'SSMUL+  ',-1000013,   0,+1,0.00D0,1.000D+30,0.0D0,
46999      & 'SSNUMLBR',-1000014,   0, 0,0.00D0,1.000D+30,0.0D0,
47000      & 'SSTAU1+ ',-1000015,   0,+1,0.00D0,1.000D+30,0.0D0,
47001      & 'SSNUTLBR',-1000016,   0, 0,0.00D0,1.000D+30,0.0D0,
47002      & 'SSER-   ', 2000011,   0,-1,0.00D0,1.000D+30,0.0D0,
47003      & 'SSNUER  ', 2000012,   0, 0,0.00D0,1.000D+30,0.0D0,
47004      & 'SSMUR-  ', 2000013,   0,-1,0.00D0,1.000D+30,0.0D0,
47005      & 'SSNUMUR ', 2000014,   0, 0,0.00D0,1.000D+30,0.0D0,
47006      & 'SSTAU2- ', 2000015,   0,-1,0.00D0,1.000D+30,0.0D0,
47007      & 'SSNUTR  ', 2000016,   0, 0,0.00D0,1.000D+30,0.0D0,
47008      & 'SSER+   ',-2000011,   0,+1,0.00D0,1.000D+30,0.0D0,
47009      & 'SSNUERBR',-2000012,   0, 0,0.00D0,1.000D+30,0.0D0,
47010      & 'SSMUR+  ',-2000013,   0,+1,0.00D0,1.000D+30,0.0D0,
47011      & 'SSNUMRBR',-2000014,   0, 0,0.00D0,1.000D+30,0.0D0,
47012      & 'SSTAU2+ ',-2000015,   0,+1,0.00D0,1.000D+30,0.0D0,
47013      & 'SSNUTRBR',-2000016,   0, 0,0.00D0,1.000D+30,0.0D0/
47014       DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
47015      &      RSPIN(I),I=449,NLAST)/
47016      & 'GLUINO  ', 1000021,   0, 0,0.00D0,1.000D+30,0.5D0,
47017      & 'NTLINO1 ', 1000022,   0, 0,0.00D0,1.000D+30,0.5D0,
47018      & 'NTLINO2 ', 1000023,   0, 0,0.00D0,1.000D+30,0.5D0,
47019      & 'NTLINO3 ', 1000025,   0, 0,0.00D0,1.000D+30,0.5D0,
47020      & 'NTLINO4 ', 1000035,   0, 0,0.00D0,1.000D+30,0.5D0,
47021      & 'CHGINO1+', 1000024,   0,+1,0.00D0,1.000D+30,0.5D0,
47022      & 'CHGINO2+', 1000037,   0,+1,0.00D0,1.000D+30,0.5D0,
47023      & 'CHGINO1-',-1000024,   0,-1,0.00D0,1.000D+30,0.5D0,
47024      & 'CHGINO2-',-1000037,   0,-1,0.00D0,1.000D+30,0.5D0,
47025      & 'GRAVTINO', 1000039,   0, 0,0.00D0,1.000D+30,1.5D0/
47026 C
47027       DATA QORQQB/.FALSE.,
47028      & 6*.TRUE.,6*.FALSE.,96*.FALSE.,6*.FALSE.,6*.TRUE.,NREST*.FALSE./
47029       DATA QBORQQ/.FALSE.,
47030      & 6*.FALSE.,6*.TRUE.,96*.FALSE.,6*.TRUE.,6*.FALSE.,NREST*.FALSE./
47031 C
47032 C     In the character strings use an ampersand to represent a backslash
47033 C     to avoid compiler problems with the C escape character
47034       DATA ((TXNAME(J,I),J=1,2),I=0,8)/
47035      & '                                     ',
47036      & '                                     ',
47037      & '                                    d',
47038      & '                                    d',
47039      & '                                    u',
47040      & '                                    u',
47041      & '                                    s',
47042      & '                                    s',
47043      & '                                    c',
47044      & '                                    c',
47045      & '                                    b',
47046      & '                                    b',
47047      & '                                    t',
47048      & '                                    t',
47049      & '                        $&bar{&rm d}$',
47050      & '                                   -d',
47051      & '                        $&bar{&rm u}$',
47052      & '                                   -u'/
47053       DATA ((TXNAME(J,I),J=1,2),I=9,16)/
47054      & '                        $&bar{&rm s}$',
47055      & '                                   -s',
47056      & '                        $&bar{&rm c}$',
47057      & '                                   -c',
47058      & '                        $&bar{&rm b}$',
47059      & '                                   -b',
47060      & '                        $&bar{&rm t}$',
47061      & '                                   -t',
47062      & '                                  $g$',
47063      & '                                    g',
47064      & '                                  CoM',
47065      & '                                  CoM',
47066      & '                                 Hard',
47067      & '                                 Hard',
47068      & '                                 Soft',
47069      & '                                 Soft'/
47070       DATA ((TXNAME(J,I),J=1,2),I=17,24)/
47071      & '                                 Cone',
47072      & '                                 Cone',
47073      & '                                Heavy',
47074      & '                                Heavy',
47075      & '                              Cluster',
47076      & '                              Cluster',
47077      & '               $&star&star&star&star$',
47078      & '                                 ****',
47079      & '                              $&pi^0$',
47080      & '                       pi<SUP>0</SUP>',
47081      & '                               $&eta$',
47082      & '                                  eta',
47083      & '                             $&rho^0$',
47084      & '                      rho<SUP>0</SUP>',
47085      & '                             $&omega$',
47086      & '                                omega'/
47087       DATA ((TXNAME(J,I),J=1,2),I=25,32)/
47088      & '                        $&eta^&prime$',
47089      & '                      eta<SUP>''</SUP>',
47090      & '                                $f_2$',
47091      & '                        f<SUB>2</SUB>',
47092      & '                              $a^0_1$',
47093      & '            a<SUB>1</SUB><SUP>0</SUP>',
47094      & '                             $f_1(L)$',
47095      & '                     f<SUB>1</SUB>(L)',
47096      & '                              $a^0_2$',
47097      & '            a<SUB>2</SUB><SUP>0</SUP>',
47098      & '                              $&pi^-$',
47099      & '                       pi<SUP>-</SUP>',
47100      & '                             $&rho^-$',
47101      & '                      rho<SUP>-</SUP>',
47102      & '                              $a^-_1$',
47103      & '            a<SUB>1</SUB><SUP>-</SUP>'/
47104       DATA ((TXNAME(J,I),J=1,2),I=33,40)/
47105      & '                              $a^-_2$',
47106      & '            a<SUB>2</SUB><SUP>-</SUP>',
47107      & '                                K$^-$',
47108      & '                        K<SUP>-</SUP>',
47109      & '                         K$^{&star-}$',
47110      & '                       K<SUP>*-</SUP>',
47111      & '                           K$_1(H)^-$',
47112      & '         K<SUB>1</SUB>(H)<SUP>-</SUP>',
47113      & '                       K$^{&star-}_2$',
47114      & '           K<SUB>2</SUB><SUP>*-</SUP>',
47115      & '                              $&pi^+$',
47116      & '                       pi<SUP>+</SUP>',
47117      & '                             $&rho^+$',
47118      & '                      rho<SUP>+</SUP>',
47119      & '                              $a^+_1$',
47120      & '            a<SUB>1</SUB><SUP>+</SUP>'/
47121       DATA ((TXNAME(J,I),J=1,2),I=41,48)/
47122      & '                              $a^+_2$',
47123      & '            a<SUB>2</SUB><SUP>+</SUP>',
47124      & '                 $&overline{&rm K}^0$',
47125      & '                       -K<SUP>0</SUP>',
47126      & '          $&overline{&rm K}^{&star0}$',
47127      & '                      -K<SUP>*0</SUP>',
47128      & '            $&overline{&rm K}_1(H)^0$',
47129      & '        -K<SUB>1</SUB>(H)<SUP>0</SUP>',
47130      & '        $&overline{&rm K}^{&star0}_2$',
47131      & '          -K<SUB>2</SUB><SUP>*0</SUP>',
47132      & '                                K$^+$',
47133      & '                        K<SUP>+</SUP>',
47134      & '                         K$^{&star+}$',
47135      & '                       K<SUP>*+</SUP>',
47136      & '                           K$_1(H)^+$',
47137      & '         K<SUB>1</SUB>(H)<SUP>+</SUP>'/
47138       DATA ((TXNAME(J,I),J=1,2),I=49,56)/
47139      & '                       K$^{&star+}_2$',
47140      & '        K<SUB>2</SUB>(H)<SUP>*+</SUP>',
47141      & '                                K$^0$',
47142      & '                        K<SUP>0</SUP>',
47143      & '                         K$^{&star0}$',
47144      & '                       K<SUP>*-</SUP>',
47145      & '                           K$_1(H)^0$',
47146      & '         K<SUB>1</SUB>(H)<SUP>0</SUP>',
47147      & '                       K$^{&star0}_2$',
47148      & '           K<SUB>2</SUB><SUP>*0</SUP>',
47149      & '                                     ',
47150      & '                                     ',
47151      & '                                     ',
47152      & '                                     ',
47153      & '                               $&phi$',
47154      & '                                  phi'/
47155       DATA ((TXNAME(J,I),J=1,2),I=57,64)/
47156      & '                          $f_1(1420)$',
47157      & '                  f<SUB>1</SUB>(1420)',
47158      & '                         $f^&prime_2$',
47159      & '            f<SUP>''</SUP><SUB>2</SUB>',
47160      & '                             $&gamma$',
47161      & '                                gamma',
47162      & '                        K$^0_{&rm S}$',
47163      & '            K<SUB>S</SUB><SUP>0</SUP>',
47164      & '                        K$^0_{&rm L}$',
47165      & '            K<SUB>L</SUB><SUP>0</SUP>',
47166      & '                        $a_0(1450)^0$',
47167      & '      a<SUB>0</SUB>(1450)<SUP>0</SUP>',
47168      & '                        $a_0(1450)^+$',
47169      & '      a<SUB>0</SUB>(1450)<SUP>+</SUP>',
47170      & '                        $a_0(1450)^-$',
47171      & '      a<SUB>0</SUB>(1450)<SUP>-</SUP>'/
47172       DATA ((TXNAME(J,I),J=1,2),I=65,72)/
47173      & '                                     ',
47174      & '                                     ',
47175      & '                                     ',
47176      & '                                     ',
47177      & '                                     ',
47178      & '                                     ',
47179      & '                                     ',
47180      & '                                     ',
47181      & '                                     ',
47182      & '                                     ',
47183      & '                                     ',
47184      & '                                     ',
47185      & '                     $&gamma$-remnant',
47186      & '                        gamma-remnant',
47187      & '                          $N$-remnant',
47188      & '                            N-remnant'/
47189       DATA ((TXNAME(J,I),J=1,2),I=73,80)/
47190      & '                                    p',
47191      & '                                    p',
47192      & '                           $&Delta^+$',
47193      & '                    Delta<SUP>+</SUP>',
47194      & '                                    n',
47195      & '                                    n',
47196      & '                           $&Delta^0$',
47197      & '                    Delta<SUP>0</SUP>',
47198      & '                           $&Delta^-$',
47199      & '                    Delta<SUP>-</SUP>',
47200      & '                            $&Lambda$',
47201      & '                               Lambda',
47202      & '                           $&Sigma^0$',
47203      & '                    Sigma<SUP>0</SUP>',
47204      & '                    $&Sigma^{&star0}$',
47205      & '                   Sigma<SUP>*0</SUP>'/
47206       DATA ((TXNAME(J,I),J=1,2),I=81,88)/
47207      & '                           $&Sigma^-$',
47208      & '                    Sigma<SUP>-</SUP>',
47209      & '                    $&Sigma^{&star-}$',
47210      & '                   Sigma<SUP>*-</SUP>',
47211      & '                              $&Xi^-$',
47212      & '                       Xi<SUP>-</SUP>',
47213      & '                       $&Xi^{&star-}$',
47214      & '                      Xi<SUP>*-</SUP>',
47215      & '                        $&Delta^{++}$',
47216      & '                   Delta<SUP>++</SUP>',
47217      & '                           $&Sigma^+$',
47218      & '                    Sigma<SUP>+</SUP>',
47219      & '                    $&Sigma^{&star+}$',
47220      & '                   Sigma<SUP>*+</SUP>',
47221      & '                              $&Xi^0$',
47222      & '                       Xi<SUP>0</SUP>'/
47223       DATA ((TXNAME(J,I),J=1,2),I=89,96)/
47224      & '                       $&Xi^{&star0}$',
47225      & '                      Xi<SUP>*0</SUP>',
47226      & '                           $&Omega^-$',
47227      & '                    Omega<SUP>-</SUP>',
47228      & '                        $&bar{&rm p}$',
47229      & '                                   -p',
47230      & '                $&overline{&Delta}^-$',
47231      & '                   -Delta<SUP>-</SUP>',
47232      & '                        $&bar{&rm n}$',
47233      & '                                   -n',
47234      & '                $&overline{&Delta}^0$',
47235      & '                   -Delta<SUP>0</SUP>',
47236      & '                $&overline{&Delta}^+$',
47237      & '                   -Delta<SUP>+</SUP>',
47238      & '                 $&overline{&Lambda}$',
47239      & '                              -Lambda'/
47240       DATA ((TXNAME(J,I),J=1,2),I=97,104)/
47241      & '                $&overline{&Sigma}^0$',
47242      & '                   -Sigma<SUP>0</SUP>',
47243      & '         $&overline{&Sigma}^{&star0}$',
47244      & '                  -Sigma<SUP>*0</SUP>',
47245      & '                $&overline{&Sigma}^+$',
47246      & '                   -Sigma<SUP>+</SUP>',
47247      & '         $&overline{&Sigma}^{&star+}$',
47248      & '                  -Sigma<SUP>*+</SUP>',
47249      & '                   $&overline{&Xi}^+$',
47250      & '                      -Xi<SUP>+</SUP>',
47251      & '            $&overline{&Xi}^{&star+}$',
47252      & '                     -Xi<SUP>*+</SUP>',
47253      & '             $&overline{&Delta}^{--}$',
47254      & '                  -Delta<SUP>--</SUP>',
47255      & '                $&overline{&Sigma}^-$',
47256      & '                   -Sigma<SUP>-</SUP>'/
47257       DATA ((TXNAME(J,I),J=1,2),I=105,112)/
47258      & '         $&overline{&Sigma}^{&star-}$',
47259      & '                  -Sigma<SUP>*-</SUP>',
47260      & '                   $&overline{&Xi}^0$',
47261      & '                      -Xi<SUP>0</SUP>',
47262      & '              $&overline&Xi^{&star0}$',
47263      & '                     -Xi<SUP>*0</SUP>',
47264      & '                $&overline{&Omega}^+$',
47265      & '                   -Omega<SUP>+</SUP>',
47266      & '                                   uu',
47267      & '                                   uu',
47268      & '                                   ud',
47269      & '                                   ud',
47270      & '                                   dd',
47271      & '                                   dd',
47272      & '                                   us',
47273      & '                                   us'/
47274       DATA ((TXNAME(J,I),J=1,2),I=113,120)/
47275      & '                                   ds',
47276      & '                                   ds',
47277      & '                                   ss',
47278      & '                                   ss',
47279      & '             $&bar{&rm u}&bar{&rm u}$',
47280      & '                                  -uu',
47281      & '             $&bar{&rm u}&bar{&rm d}$',
47282      & '                                  -ud',
47283      & '             $&bar{&rm d}&bar{&rm d}$',
47284      & '                                  -dd',
47285      & '             $&bar{&rm u}&bar{&rm s}$',
47286      & '                                  -us',
47287      & '             $&bar{&rm d}&bar{&rm s}$',
47288      & '                                  -ds',
47289      & '             $&bar{&rm s}&bar{&rm s}$',
47290      & '                                  -ss'/
47291       DATA ((TXNAME(J,I),J=1,2),I=121,128)/
47292      & '                                e$^-$',
47293      & '                        e<SUP>-</SUP>',
47294      & '                        $&nu_{&rm e}$',
47295      & '                       nu<SUB>e</SUB>',
47296      & '                              $&mu^-$',
47297      & '                       mu<SUP>-</SUP>',
47298      & '                            $&nu_&mu$',
47299      & '                      nu<SUB>mu</SUB>',
47300      & '                             $&tau^-$',
47301      & '                      tau<SUP>-</SUP>',
47302      & '                           $&nu_&tau$',
47303      & '                     nu<SUB>tau</SUB>',
47304      & '                                e$^+$',
47305      & '                        e<SUP>+</SUP>',
47306      & '                  $&bar{&nu}_{&rm e}$',
47307      & '                      -nu<SUB>e</SUB>'/
47308       DATA ((TXNAME(J,I),J=1,2),I=129,136)/
47309      & '                              $&mu^+$',
47310      & '                       mu<SUP>+</SUP>',
47311      & '                      $&bar{&nu}_&mu$',
47312      & '                     -nu<SUB>mu</SUB>',
47313      & '                             $&tau^+$',
47314      & '                      tau<SUP>+</SUP>',
47315      & '                     $&bar{&nu}_&tau$',
47316      & '                    -nu<SUB>tau</SUB>',
47317      & '                                     ',
47318      & '                                     ',
47319      & '                                     ',
47320      & '                                     ',
47321      & '                                     ',
47322      & '                                     ',
47323      & '                                D$^+$',
47324      & '                        D<SUP>+</SUP>'/
47325       DATA ((TXNAME(J,I),J=1,2),I=137,144)/
47326      & '                         D$^{&star+}$',
47327      & '                       D<SUP>*+</SUP>',
47328      & '                           D$_1(H)^+$',
47329      & '         D<SUB>1</SUB>(H)<SUP>+</SUP>',
47330      & '                       D$_2^{&star+}$',
47331      & '           D<SUB>2</SUB><SUP>*+</SUP>',
47332      & '                                D$^0$',
47333      & '                        D<SUP>0</SUP>',
47334      & '                         D$^{&star0}$',
47335      & '                       D<SUP>*0</SUP>',
47336      & '                           D$_1(H)^0$',
47337      & '         D<SUB>1</SUB>(H)<SUP>0</SUP>',
47338      & '                       D$_2^{&star0}$',
47339      & '           D<SUB>2</SUB><SUP>*0</SUP>',
47340      & '                        D$_{&rm s}^+$',
47341      & '            D<SUB>s</SUB><SUP>+</SUP>'/
47342       DATA ((TXNAME(J,I),J=1,2),I=145,152)/
47343      & '                 D$_{&rm s}^{&star+}$',
47344      & '           D<SUB>s</SUB><SUP>*+</SUP>',
47345      & '                    D$_{&rm s1}(H)^+$',
47346      & '        D<SUB>s1</SUB>(H)<SUP>+</SUP>',
47347      & '                D$^{&star+}_{&rm s2}$',
47348      & '       D<SUB>s1</SUB>(H)<SUP>*+</SUP>',
47349      & '                $&Sigma_{&rm c}^{++}$',
47350      & '       Sigma<SUB>c</SUB><SUP>++</SUP>',
47351      & '           $&Sigma_{&rm c}^{&star++}$',
47352      & '      Sigma<SUB>c</SUB><SUP>*++</SUP>',
47353      & '                  $&Lambda_{&rm c}^+$',
47354      & '       Lambda<SUB>c</SUB><SUP>+</SUP>',
47355      & '                   $&Sigma_{&rm c}^+$',
47356      & '        Sigma<SUB>c</SUB><SUP>+</SUP>',
47357      & '            $&Sigma_{&rm c}^{&star+}$',
47358      & '       Sigma<SUB>c</SUB><SUP>*+</SUP>'/
47359       DATA ((TXNAME(J,I),J=1,2),I=153,160)/
47360      & '                   $&Sigma_{&rm c}^0$',
47361      & '        Sigma<SUB>c</SUB><SUP>0</SUP>',
47362      & '            $&Sigma_{&rm c}^{&star0}$',
47363      & '       Sigma<SUB>c</SUB><SUP>*0</SUP>',
47364      & '                      $&Xi_{&rm c}^+$',
47365      & '           Xi<SUB>c</SUB><SUP>+</SUP>',
47366      & '              $&Xi_{&rm c}^{&prime+}$',
47367      & '          Xi<SUB>c</SUB><SUP>''+</SUP>',
47368      & '               $&Xi_{&rm c}^{&star+}$',
47369      & '          Xi<SUB>c</SUB><SUP>*+</SUP>',
47370      & '                      $&Xi_{&rm c}^0$',
47371      & '           Xi<SUB>c</SUB><SUP>0</SUP>',
47372      & '              $&Xi_{&rm c}^{&prime0}$',
47373      & '          Xi<SUB>c</SUB><SUP>''0</SUP>',
47374      & '               $&Xi_{&rm c}^{&star0}$',
47375      & '          Xi<SUB>c</SUB><SUP>*0</SUP>'/
47376       DATA ((TXNAME(J,I),J=1,2),I=161,168)/
47377      & '                   $&Omega_{&rm c}^0$',
47378      & '        Omega<SUB>c</SUB><SUP>0</SUP>',
47379      & '            $&Omega_{&rm c}^{&star0}$',
47380      & '       Omega<SUB>c</SUB><SUP>*0</SUP>',
47381      & '                   $&eta_{&rm c}(1S)$',
47382      & '                  eta<SUB>c</SUB>(1S)',
47383      & '                             J/$&psi$',
47384      & '                                J/psi',
47385      & '                  $&chi_{&rm c0}(1P)$',
47386      & '                 chi<SUB>c0</SUB>(1P)',
47387      & '                           $&psi(2S)$',
47388      & '                              psi(2S)',
47389      & '                           $&psi(1D)$',
47390      & '                              psi(1D)',
47391      & '                                     ',
47392      & '                                     '/
47393       DATA ((TXNAME(J,I),J=1,2),I=169,176)/
47394      & '                                     ',
47395      & '                                     ',
47396      & '                                     ',
47397      & '                                     ',
47398      & '                                D$^-$',
47399      & '                        D<SUP>-</SUP>',
47400      & '                         D$^{&star-}$',
47401      & '                       D<SUP>*-</SUP>',
47402      & '                           D$_1(H)^-$',
47403      & '         D<SUB>1</SUB>(H)<SUP>-</SUP>',
47404      & '                       D$_2^{&star-}$',
47405      & '           D<SUB>2</SUB><SUP>*-</SUP>',
47406      & '                 $&overline{&rm D}^0$',
47407      & '                       -D<SUP>0</SUP>',
47408      & '          $&overline{&rm D}^{&star0}$',
47409      & '                      -D<SUP>*0</SUP>'/
47410       DATA ((TXNAME(J,I),J=1,2),I=177,184)/
47411      & '            $&overline{&rm D}_1(H)^0$',
47412      & '        -D<SUB>1</SUB>(H)<SUP>0</SUP>',
47413      & '        $&overline{&rm D}_2^{&star0}$',
47414      & '          -D<SUB>2</SUB><SUP>*0</SUP>',
47415      & '                        D$_{&rm s}^-$',
47416      & '            D<SUB>s</SUB><SUP>-</SUP>',
47417      & '                 D$_{&rm s}^{&star-}$',
47418      & '           D<SUB>s</SUB><SUP>*-</SUP>',
47419      & '                    D$_{&rm s1}(H)^-$',
47420      & '        D<SUB>s1</SUB>(H)<SUP>-</SUP>',
47421      & '                D$_{&rm s2}^{&star-}$',
47422      & '       D<SUB>s1</SUB>(H)<SUP>*-</SUP>',
47423      & '     $&overline{&Sigma}_{&rm c}^{--}$',
47424      & '      -Sigma<SUB>c</SUB><SUP>--</SUP>',
47425      & '$&overline{&Sigma}_{&rm c}^{&star--}$',
47426      & '     -Sigma<SUB>c</SUB><SUP>*--</SUP>'/
47427       DATA ((TXNAME(J,I),J=1,2),I=185,192)/
47428      & '       $&overline{&Lambda}_{&rm c}^-$',
47429      & '      -Lambda<SUB>c</SUB><SUP>-</SUP>',
47430      & '        $&overline{&Sigma}_{&rm c}^-$',
47431      & '       -Sigma<SUB>c</SUB><SUP>-</SUP>',
47432      & ' $&overline{&Sigma}_{&rm c}^{&star-}$',
47433      & '      -Sigma<SUB>c</SUB><SUP>*-</SUP>',
47434      & '        $&overline{&Sigma}_{&rm c}^0$',
47435      & '       -Sigma<SUB>c</SUB><SUP>0</SUP>',
47436      & ' $&overline{&Sigma}_{&rm c}^{&star0}$',
47437      & '      -Sigma<SUB>c</SUB><SUP>*0</SUP>',
47438      & '           $&overline{&Xi}_{&rm c}^-$',
47439      & '          -Xi<SUB>c</SUB><SUP>-</SUP>',
47440      & '   $&overline{&Xi}_{&rm c}^{&prime-}$',
47441      & '         -Xi<SUB>c</SUB><SUP>''-</SUP>',
47442      & '    $&overline{&Xi}_{&rm c}^{&star-}$',
47443      & '         -Xi<SUB>c</SUB><SUP>*-</SUP>'/
47444       DATA ((TXNAME(J,I),J=1,2),I=193,200)/
47445      & '           $&overline{&Xi}_{&rm c}^0$',
47446      & '          -Xi<SUB>c</SUB><SUP>0</SUP>',
47447      & '   $&overline{&Xi}_{&rm c}^{&prime0}$',
47448      & '         -Xi<SUB>c</SUB><SUP>''0</SUP>',
47449      & '    $&overline{&Xi}_{&rm c}^{&star0}$',
47450      & '         -Xi<SUB>c</SUB><SUP>*0</SUP>',
47451      & '        $&overline{&Omega}_{&rm c}^0$',
47452      & '       -Omega<SUB>c</SUB><SUP>0</SUP>',
47453      & ' $&overline{&Omega}_{&rm c}^{&star0}$',
47454      & '      -Omega<SUB>c</SUB><SUP>*0</SUP>',
47455      & '                                W$^+$',
47456      & '                        W<SUP>+</SUP>',
47457      & '                                W$^-$',
47458      & '                        W<SUP>-</SUP>',
47459      & '                   Z$^0/&gamma^&star$',
47460      & '      Z<SUP>0</SUP>/gamma<SUP>*</SUP>'/
47461       DATA ((TXNAME(J,I),J=1,2),I=201,208)/
47462      & '                       $H^0_{&rm SM}$',
47463      & '           H<SUP>0</SUP><SUB>SM</SUB>',
47464      & '                        Z$^{&prime0}$',
47465      & '                       Z<SUP>''0</SUP>',
47466      & '                                $h^0$',
47467      & '                        h<SUP>0</SUP>',
47468      & '                                $H^0$',
47469      & '                        H<SUP>0</SUP>',
47470      & '                                $A^0$',
47471      & '                        A<SUP>0</SUP>',
47472      & '                                $H^+$',
47473      & '                        H<SUP>+</SUP>',
47474      & '                                $H^-$',
47475      & '                        H<SUP>-</SUP>',
47476      & '                                  $G$',
47477      & '                                    G'/
47478       DATA ((TXNAME(J,I),J=1,2),I=209,216)/
47479      & '                              V-quark',
47480      & '                              V-quark',
47481      & '                              A-quark',
47482      & '                              A-quark',
47483      & '                              H-quark',
47484      & '                              H-quark',
47485      & '                     H$^&prime$-quark',
47486      & '                  H<SUP>''</SUP>-quark',
47487      & '                                     ',
47488      & '                                     ',
47489      & '                                     ',
47490      & '                                     ',
47491      & '             $&overline{&rm V}$-quark',
47492      & '                             -V-quark',
47493      & '             $&overline{&rm A}$-quark',
47494      & '                             -A-quark'/
47495       DATA ((TXNAME(J,I),J=1,2),I=217,224)/
47496      & '             $&overline{&rm H}$-quark',
47497      & '                             -H-quark',
47498      & '      $&overline{&rm H}^&prime$-quark',
47499      & '                 -H<SUP>''</SUP>-quark',
47500      & '                                     ',
47501      & '                                     ',
47502      & '                                     ',
47503      & '                                     ',
47504      & '         $&overline{&rm B}_{&rm d}^0$',
47505      & '           -B<SUB>d</SUB><SUP>0</SUP>',
47506      & '                                B$^-$',
47507      & '                        B<SUP>-</SUP>',
47508      & '         $&overline{&rm B}_{&rm s}^0$',
47509      & '           -B<SUB>s</SUB><SUP>0</SUP>',
47510      & '                   $&Sigma_{&rm b}^+$',
47511      & '        Sigma<SUB>b</SUB><SUP>+</SUP>'/
47512       DATA ((TXNAME(J,I),J=1,2),I=225,232)/
47513      & '                  $&Lambda_{&rm b}^0$',
47514      & '       Lambda<SUB>b</SUB><SUP>0</SUP>',
47515      & '                   $&Sigma_{&rm b}^-$',
47516      & '        Sigma<SUB>b</SUB><SUP>-</SUP>',
47517      & '                      $&Xi_{&rm b}^0$',
47518      & '           Xi<SUB>b</SUB><SUP>0</SUP>',
47519      & '                      $&Xi_{&rm b}^-$',
47520      & '           Xi<SUB>b</SUB><SUP>-</SUP>',
47521      & '                   $&Omega_{&rm b}^-$',
47522      & '        Omega<SUB>b</SUB><SUP>-</SUP>',
47523      & '                        B$_{&rm c}^-$',
47524      & '            B<SUB>c</SUB><SUP>-</SUP>',
47525      & '                       $&Upsilon(1S)$',
47526      & '                          Upsilon(1S)',
47527      & '                        T$_{&rm b}^-$',
47528      & '            T<SUB>b</SUB><SUP>-</SUP>'/
47529       DATA ((TXNAME(J,I),J=1,2),I=233,240)/
47530      & '                                T$^+$',
47531      & '                        T<SUP>+</SUP>',
47532      & '                                T$^0$',
47533      & '                        T<SUP>0</SUP>',
47534      & '                        T$_{&rm s}^+$',
47535      & '            T<SUB>s</SUB><SUP>+</SUP>',
47536      & '                $&Sigma_{&rm t}^{++}$',
47537      & '       Sigma<SUB>t</SUB><SUP>++</SUP>',
47538      & '                  $&Lambda_{&rm t}^0$',
47539      & '       Lambda<SUB>t</SUB><SUP>0</SUP>',
47540      & '                   $&Sigma_{&rm t}^0$',
47541      & '        Sigma<SUB>t</SUB><SUP>0</SUP>',
47542      & '                     $&chi_{&rm t}^+$',
47543      & '           Xi<SUB>t</SUB><SUP>+</SUP>',
47544      & '                     $&chi_{&rm t}^0$',
47545      & '           Xi<SUB>t</SUB><SUP>0</SUP>'/
47546       DATA ((TXNAME(J,I),J=1,2),I=241,248)/
47547      & '                   $&Omega_{&rm t}^0$',
47548      & '        Omega<SUB>t</SUB><SUP>0</SUP>',
47549      & '                        T$_{&rm c}^0$',
47550      & '            T<SUB>c</SUB><SUP>0</SUP>',
47551      & '                        T$_{&rm b}^+$',
47552      & '            T<SUB>b</SUB><SUP>+</SUP>',
47553      & '                             Toponium',
47554      & '                             Toponium',
47555      & '                        B$_{&rm d}^0$',
47556      & '            B<SUB>d</SUB><SUP>0</SUP>',
47557      & '                                B$^+$',
47558      & '                        B<SUP>+</SUP>',
47559      & '                        B$_{&rm s}^0$',
47560      & '            B<SUB>s</SUB><SUP>0</SUP>',
47561      & '        $&overline{&Sigma}_{&rm b}^-$',
47562      & '       -Sigma<SUB>b</SUB><SUP>-</SUP>'/
47563       DATA ((TXNAME(J,I),J=1,2),I=249,256)/
47564      & '       $&overline{&Lambda}_{&rm b}^-$',
47565      & '      -Lambda<SUB>b</SUB><SUP>-</SUP>',
47566      & '        $&overline{&Sigma}_{&rm b}^+$',
47567      & '       -Sigma<SUB>b</SUB><SUP>+</SUP>',
47568      & '           $&overline{&Xi}_{&rm b}^0$',
47569      & '          -Xi<SUB>b</SUB><SUP>0</SUP>',
47570      & '                      $&Xi_{&rm b}^+$',
47571      & '           Xi<SUB>b</SUB><SUP>+</SUP>',
47572      & '        $&overline{&Omega}_{&rm b}^+$',
47573      & '       -Omega<SUB>b</SUB><SUP>+</SUP>',
47574      & '                        B$_{&rm c}^+$',
47575      & '            B<SUB>c</SUB><SUP>+</SUP>',
47576      & '                                T$^-$',
47577      & '                        T<SUP>-</SUP>',
47578      & '                 $&overline{&rm T}^0$',
47579      & '                        T<SUP>0</SUP>'/
47580       DATA ((TXNAME(J,I),J=1,2),I=257,264)/
47581      & '                        T$_{&rm s}^-$',
47582      & '            T<SUB>s</SUB><SUP>-</SUP>',
47583      & '     $&overline{&Sigma}_{&rm t}^{--}$',
47584      & '       Sigma<SUB>t</SUB><SUP>--</SUP>',
47585      & '       $&overline{&Lambda}_{&rm t}^-$',
47586      & '      -Lambda<SUB>t</SUB><SUP>-</SUP>',
47587      & '        $&overline{&Sigma}_{&rm t}^0$',
47588      & '       -Sigma<SUB>t</SUB><SUP>0</SUP>',
47589      & '           $&overline{&Xi}_{&rm t}^-$',
47590      & '          -Xi<SUB>t</SUB><SUP>-</SUP>',
47591      & '           $&overline{&Xi}_{&rm t}^0$',
47592      & '          -Xi<SUB>t</SUB><SUP>0</SUP>',
47593      & '        $&overline{&Omega}_{&rm t}^0$',
47594      & '       -Omega<SUB>t</SUB><SUP>0</SUP>',
47595      & '         $&overline{&rm T}_{&rm c}^0$',
47596      & '            T<SUB>c</SUB><SUP>0</SUP>'/
47597       DATA ((TXNAME(J,I),J=1,2),I=265,272)/
47598      & '          $&overline{&rm B}^{&star0}$',
47599      & '                      -B<SUP>*0</SUP>',
47600      & '                         B$^{&star-}$',
47601      & '                       B<SUP>*-</SUP>',
47602      & '  $&overline{&rm B}_{&rm s}^{&star0}$',
47603      & '          -B<SUB>s</SUB><SUP>*0</SUP>',
47604      & '            $&overline{&rm B}_1(H)^0$',
47605      & '        -B<SUB>1</SUB>(H)<SUP>0</SUP>',
47606      & '                           B$_1(H)^-$',
47607      & '         B<SUB>1</SUB>(H)<SUP>-</SUP>',
47608      & '     $&overline{&rm B}_{&rm s1}(H)^0$',
47609      & '       -B<SUB>s1</SUB>(H)<SUP>0</SUP>',
47610      & '        $&overline{&rm B}_2^{&star0}$',
47611      & '          -B<SUB>2</SUB><SUP>*0</SUP>',
47612      & '                       B$_2^{&star-}$',
47613      & '           B<SUB>2</SUB><SUP>*-</SUP>'/
47614       DATA ((TXNAME(J,I),J=1,2),I=273,280)/
47615      & '                B$_{&rm s2}^{&star0}$',
47616      & '          B<SUB>s2</SUB><SUP>*0</SUP>',
47617      & '                         B$^{&star0}$',
47618      & '                       B<SUP>*0</SUP>',
47619      & '                         B$^{&star+}$',
47620      & '                       B<SUP>*+</SUP>',
47621      & '                 B$_{&rm s}^{&star0}$',
47622      & '           B<SUB>s</SUB><SUP>*0</SUP>',
47623      & '                           B$_1(H)^0$',
47624      & '         B<SUB>1</SUB>(H)<SUP>0</SUP>',
47625      & '                           B$_1(H)^+$',
47626      & '         B<SUB>1</SUB>(H)<SUP>+</SUP>',
47627      & '                    B$_{&rm s1}(H)^0$',
47628      & '        B<SUB>s1</SUB>(H)<SUP>0</SUP>',
47629      & '                       B$_2^{&star0}$',
47630      & '           B<SUB>2</SUB><SUP>*0</SUP>'/
47631       DATA ((TXNAME(J,I),J=1,2),I=281,288)/
47632      & '                       B$_2^{&star+}$',
47633      & '           B<SUB>2</SUB><SUP>*+</SUP>',
47634      & '                B$_{&rm s2}^{&star0}$',
47635      & '          B<SUB>s2</SUB><SUP>*0</SUP>',
47636      & '                                     ',
47637      & '                                     ',
47638      & '                                     ',
47639      & '                                     ',
47640      & '                              b$_1^0$',
47641      & '            b<SUB>1</SUB><SUP>0</SUP>',
47642      & '                              b$_1^+$',
47643      & '            b<SUB>1</SUB><SUP>+</SUP>',
47644      & '                              b$_1^-$',
47645      & '            b<SUB>1</SUB><SUP>-</SUP>',
47646      & '                           h$_1(L)^0$',
47647      & '         h<SUB>1</SUB>(L)<SUP>0</SUP>'/
47648       DATA ((TXNAME(J,I),J=1,2),I=289,296)/
47649      & '                           h$_1(H)^0$',
47650      & '         h<SUB>1</SUB>(H)<SUP>0</SUP>',
47651      & '                         a$_0(980)^0$',
47652      & '       a<SUB>0</SUB>(980)<SUP>0</SUP>',
47653      & '                         a$_0(980)^+$',
47654      & '       a<SUB>0</SUB>(980)<SUP>+</SUP>',
47655      & '                         a$_0(980)^-$',
47656      & '       a<SUB>0</SUB>(980)<SUP>-</SUP>',
47657      & '                           f$_0(980)$',
47658      & '                   f<SUB>0</SUB>(980)',
47659      & '                          f$_0(1370)$',
47660      & '                  f<SUB>0</SUB>(1370)',
47661      & '                 B$_{&rm c}^{&star+}$',
47662      & '           B<SUB>c</SUB><SUP>*+</SUP>',
47663      & '                 B$_{&rm c}^{&star-}$',
47664      & '           B<SUB>c</SUB><SUP>*-</SUP>'/
47665       DATA ((TXNAME(J,I),J=1,2),I=297,304)/
47666      & '                    B$_{&rm c1}(H)^+$',
47667      & '        B<SUB>c1</SUB>(H)<SUP>+</SUP>',
47668      & '                    B$_{&rm c1}(H)^-$',
47669      & '        B<SUB>c1</SUB>(H)<SUP>-</SUP>',
47670      & '                B$_{&rm c2}^{&star+}$',
47671      & '          B<SUB>c2</SUB><SUP>*+</SUP>',
47672      & '                B$_{&rm c2}^{&star-}$',
47673      & '          B<SUB>c2</SUB><SUP>*-</SUP>',
47674      & '                      h$_{&rm c}(1P)$',
47675      & '                    h<SUB>c</SUB>(1P)',
47676      & '                  $&chi_{&rm c0}(1P)$',
47677      & '                 chi<SUB>c0</SUB>(1P)',
47678      & '                  $&chi_{&rm c2}(1P)$',
47679      & '                 chi<SUB>c2</SUB>(1P)',
47680      & '                   $&eta_{&rm b}(1S)$',
47681      & '                  eta<SUB>b</SUB>(1S)'/
47682       DATA ((TXNAME(J,I),J=1,2),I=305,312)/
47683      & '                      h$_{&rm b}(1P)$',
47684      & '                    h<SUB>b</SUB>(1P)',
47685      & '                  $&chi_{&rm b0}(1P)$',
47686      & '                 chi<SUB>b0</SUB>(1P)',
47687      & '                  $&chi_{&rm b1}(1P)$',
47688      & '                 chi<SUB>b1</SUB>(1P)',
47689      & '                  $&chi_{&rm b2}(1P)$',
47690      & '                 chi<SUB>b2</SUB>(1P)',
47691      & '                           K$_1(L)^0$',
47692      & '         K<SUB>1</SUB>(L)<SUP>0</SUP>',
47693      & '                           K$_1(L)^+$',
47694      & '         K<SUB>1</SUB>(L)<SUP>+</SUP>',
47695      & '            $&overline{&rm K}_1(L)^0$',
47696      & '        -K<SUB>1</SUB>(L)<SUP>0</SUP>',
47697      & '                           K$_1(L)^-$',
47698      & '         K<SUB>1</SUB>(L)<SUP>-</SUP>'/
47699       DATA ((TXNAME(J,I),J=1,2),I=313,320)/
47700      & '                           D$_1(L)^+$',
47701      & '         D<SUB>1</SUB>(L)<SUP>+</SUP>',
47702      & '                           D$_1(L)^0$',
47703      & '         D<SUB>1</SUB>(L)<SUP>0</SUP>',
47704      & '                    D$_{&rm s1}(L)^+$',
47705      & '        D<SUB>s1</SUB>(L)<SUP>+</SUP>',
47706      & '                           D$_1(L)^-$',
47707      & '         D<SUB>1</SUB>(L)<SUP>-</SUP>',
47708      & '            $&overline{&rm D}_1(L)^0$',
47709      & '         D<SUB>1</SUB>(L)<SUP>0</SUP>',
47710      & '                    D$_{&rm s1}(L)^-$',
47711      & '        D<SUB>s1</SUB>(L)<SUP>-</SUP>',
47712      & '                           B$_1(L)^0$',
47713      & '         B<SUB>1</SUB>(L)<SUP>0</SUP>',
47714      & '                           B$_1(L)^+$',
47715      & '         B<SUB>1</SUB>(L)<SUP>+</SUP>'/
47716       DATA ((TXNAME(J,I),J=1,2),I=321,328)/
47717      & '                    B$_{&rm s1}(L)^0$',
47718      & '        B<SUB>s1</SUB>(L)<SUP>0</SUP>',
47719      & '                    B$_{&rm c1}(L)^+$',
47720      & '        B<SUB>c1</SUB>(L)<SUP>+</SUP>',
47721      & '            $&overline{&rm B}_1(L)^0$',
47722      & '        -B<SUB>1</SUB>(L)<SUP>0</SUP>',
47723      & '                           B$_1(L)^-$',
47724      & '         B<SUB>1</SUB>(L)<SUP>-</SUP>',
47725      & '     $&overline{&rm B}_{&rm s1}(L)^0$',
47726      & '       -B<SUB>s1</SUB>(L)<SUP>0</SUP>',
47727      & '                    B$_{&rm c1}(L)^-$',
47728      & '        B<SUB>c1</SUB>(L)<SUP>-</SUP>',
47729      & '                       K$_0^{&star+}$',
47730      & '           K<SUB>0</SUB><SUP>*+</SUP>',
47731      & '                       K$_0^{&star0}$',
47732      & '           K<SUB>0</SUB><SUP>*0</SUP>'/
47733       DATA ((TXNAME(J,I),J=1,2),I=329,336)/
47734      & '        $&overline{&rm K}_0^{&star0}$',
47735      & '          -K<SUB>0</SUB><SUP>*0</SUP>',
47736      & '                       K$_0^{&star-}$',
47737      & '           K<SUB>0</SUB><SUP>*-</SUP>',
47738      & '                       D$_0^{&star+}$',
47739      & '           D<SUB>0</SUB><SUP>*+</SUP>',
47740      & '                       D$_0^{&star0}$',
47741      & '           D<SUB>0</SUB><SUP>*0</SUP>',
47742      & '                D$_{&rm s0}^{&star+}$',
47743      & '          D<SUB>s0</SUB><SUP>*+</SUP>',
47744      & '                       D$_0^{&star-}$',
47745      & '           D<SUB>0</SUB><SUP>*-</SUP>',
47746      & '        $&overline{&rm D}_0^{&star0}$',
47747      & '          -D<SUB>0</SUB><SUP>*0</SUP>',
47748      & '                D$_{&rm s0}^{&star-}$',
47749      & '          D<SUB>s0</SUB><SUP>*-</SUP>'/
47750       DATA ((TXNAME(J,I),J=1,2),I=337,344)/
47751      & '                       B$_0^{&star0}$',
47752      & '           B<SUB>0</SUB><SUP>*0</SUP>',
47753      & '                       B$_0^{&star+}$',
47754      & '           B<SUB>0</SUB><SUP>*+</SUP>',
47755      & '                B$_{&rm s0}^{&star0}$',
47756      & '          B<SUB>s0</SUB><SUP>*0</SUP>',
47757      & '                B$_{&rm c0}^{&star+}$',
47758      & '          B<SUB>c0</SUB><SUP>*+</SUP>',
47759      & '        $&overline{&rm B}_0^{&star0}$',
47760      & '          -B<SUB>0</SUB><SUP>*0</SUP>',
47761      & '                       B$_0^{&star-}$',
47762      & '           B<SUB>0</SUB><SUP>*-</SUP>',
47763      & ' $&overline{&rm B}_{&rm s0}^{&star0}$',
47764      & '         -B<SUB>s0</SUB><SUP>*0</SUP>',
47765      & '                B$_{&rm c0}^{&star-}$',
47766      & '          B<SUB>c0</SUB><SUP>*-</SUP>'/
47767       DATA ((TXNAME(J,I),J=1,2),I=345,352)/
47768      & '                   $&Sigma_{&rm b}^0$',
47769      & '        Sigma<SUB>b</SUB><SUP>0</SUP>',
47770      & '            $&Sigma_{&rm b}^{&star-}$',
47771      & '       Sigma<SUB>b</SUB><SUP>*-</SUP>',
47772      & '            $&Sigma_{&rm b}^{&star0}$',
47773      & '       Sigma<SUB>b</SUB><SUP>*0</SUP>',
47774      & '            $&Sigma_{&rm b}^{&star+}$',
47775      & '       Sigma<SUB>b</SUB><SUP>*+</SUP>',
47776      & '              $&Xi_{&rm b}^{&prime0}$',
47777      & '          Xi<SUB>b</SUB><SUP>''0</SUP>',
47778      & '               $&Xi_{&rm b}^{&star0}$',
47779      & '          Xi<SUB>b</SUB><SUP>*0</SUP>',
47780      & '              $&Xi_{&rm b}^{&prime-}$',
47781      & '          Xi<SUB>b</SUB><SUP>''-</SUP>',
47782      & '               $&Xi_{&rm b}^{&star-}$',
47783      & '          Xi<SUB>b</SUB><SUP>*-</SUP>'/
47784       DATA ((TXNAME(J,I),J=1,2),I=353,360)/
47785      & '            $&Omega_{&rm b}^{&star-}$',
47786      & '      -Omega<SUB>b</SUB><SUP>*-</SUP>',
47787      & ' $&overline{&Sigma}_{&rm b}^{&star+}$',
47788      & '       Sigma<SUB>b</SUB><SUP>*+</SUP>',
47789      & '        $&overline{&Sigma}_{&rm b}^0$',
47790      & '       -Sigma<SUB>b</SUB><SUP>0</SUP>',
47791      & ' $&overline{&Sigma}_{&rm b}^{&star0}$',
47792      & '      -Sigma<SUB>b</SUB><SUP>*0</SUP>',
47793      & ' $&overline{&Sigma}_{&rm b}^{&star-}$',
47794      & '      -Sigma<SUB>b</SUB><SUP>*-</SUP>',
47795      & '   $&overline{&Xi}_{&rm b}^{&prime0}$',
47796      & '         -Xi<SUB>b</SUB><SUP>''0</SUP>',
47797      & '    $&overline{&Xi}_{&rm b}^{&star0}$',
47798      & '         -Xi<SUB>b</SUB><SUP>*0</SUP>',
47799      & '   $&overline{&Xi}_{&rm b}^{&prime+}$',
47800      & '         -Xi<SUB>b</SUB><SUP>''+</SUP>'/
47801       DATA ((TXNAME(J,I),J=1,2),I=361,368)/
47802      & '    $&overline{&Xi}_{&rm b}^{&star+}$',
47803      & '         -Xi<SUB>b</SUB><SUP>*+</SUP>',
47804      & '            $&Omega_{&rm b}^{&star+}$',
47805      & '       Omega<SUB>b</SUB><SUP>*+</SUP>',
47806      & '                          K$(DL)_2^+$',
47807      & '        K(DL)<SUB>2</SUB><SUP>+</SUP>',
47808      & '                          K$(DL)_2^0$',
47809      & '        K(DL)<SUB>2</SUB><SUP>0</SUP>',
47810      & '           $&overline{&rm K}(DL)_2^0$',
47811      & '       -K(DL)<SUB>2</SUB><SUP>0</SUP>',
47812      & '                          K$(DL)_2^-$',
47813      & '        K(DL)<SUB>2</SUB><SUP>-</SUP>',
47814      & '                      K$(D)^{&star+}$',
47815      & '                    K(D)<SUP>*+</SUP>',
47816      & '                      K$(D)^{&star0}$',
47817      & '                    K(D)<SUP>*0</SUP>'/
47818       DATA ((TXNAME(J,I),J=1,2),I=369,376)/
47819      & '      $&overline{&rm  K}(D)^{&star0}$',
47820      & '                   -K(D)<SUP>*0</SUP>',
47821      & '                      K$(D)^{&star-}$',
47822      & '                    K(D)<SUP>*-</SUP>',
47823      & '                          K$(DH)_2^+$',
47824      & '        K(DH)<SUB>2</SUB><SUP>+</SUP>',
47825      & '                          K$(DH)_2^0$',
47826      & '        K(DH)<SUB>2</SUB><SUP>0</SUP>',
47827      & '           $&overline{&rm K}(DH)_2^0$',
47828      & '       -K(DH)<SUB>2</SUB><SUP>0</SUP>',
47829      & '                          K$(DH)_2^-$',
47830      & '        K(DH)<SUB>2</SUB><SUP>-</SUP>',
47831      & '                           K$(D)_3^+$',
47832      & '         K(D)<SUB>3</SUB><SUP>+</SUP>',
47833      & '                           K$(D)_3^0$',
47834      & '         K(D)<SUB>3</SUB><SUP>0</SUP>'/
47835       DATA ((TXNAME(J,I),J=1,2),I=377,384)/
47836      & '            $&overline{&rm K}(D)_3^0$',
47837      & '        -K(D)<SUB>3</SUB><SUP>0</SUP>',
47838      & '                           K$(D)_3^-$',
47839      & '         K(D)<SUB>3</SUB><SUP>-</SUP>',
47840      & '                            $&pi_2^+$',
47841      & '           pi<SUB>2</SUB><SUP>+</SUP>',
47842      & '                            $&pi_2^0$',
47843      & '           pi<SUB>2</SUB><SUP>0</SUP>',
47844      & '                            $&pi_2^-$',
47845      & '           pi<SUB>2</SUB><SUP>-</SUP>',
47846      & '                          $&rho(D)^+$',
47847      & '                   rho(D)<SUP>+</SUP>',
47848      & '                          $&rho(D)^0$',
47849      & '                   rho(D)<SUP>0</SUP>',
47850      & '                          $&rho(D)^-$',
47851      & '                   rho(D)<SUP>-</SUP>'/
47852       DATA ((TXNAME(J,I),J=1,2),I=385,392)/
47853      & '                           $&rho_3^+$',
47854      & '          rho<SUB>3</SUB><SUP>+</SUP>',
47855      & '                           $&rho_3^0$',
47856      & '          rho<SUB>3</SUB><SUP>0</SUP>',
47857      & '                           $&rho_3^-$',
47858      & '          rho<SUB>3</SUB><SUP>-</SUP>',
47859      & '                       $&Upsilon(2S)$',
47860      & '                          Upsilon(2S)',
47861      & '                  $&chi_{&rm b0}(2P)$',
47862      & '                 Chi<SUB>b0</SUB>(2P)',
47863      & '                  $&chi_{&rm b1}(2P)$',
47864      & '                 Chi<SUB>b1</SUB>(2P)',
47865      & '                  $&chi_{&rm b2}(2P)$',
47866      & '                 Chi<SUB>b2</SUB>(2P)',
47867      & '                       $&Upsilon(3S)$',
47868      & '                          Upsilon(3S)'/
47869       DATA ((TXNAME(J,I),J=1,2),I=393,400)/
47870      & '                       $&Upsilon(4S)$',
47871      & '                          Upsilon(4S)',
47872      & '                                     ',
47873      & '                                     ',
47874      & '                           $&omega_3$',
47875      & '                    omega<SUB>3</SUB>',
47876      & '                             $&phi_3$',
47877      & '                      phi<SUB>3</SUB>',
47878      & '                          $&eta_2(L)$',
47879      & '                   eta<SUB>2</SUB>(L)',
47880      & '                          $&eta_2(H)$',
47881      & '                   eta<SUB>2</SUB>(H)',
47882      & '                          $&omega(H)$',
47883      & '                             omega(H)',
47884      & '                                     ',
47885      & '                                     '/
47886       DATA ((TXNAME(J,I),J=1,2),I=401,408)/
47887      & '              $&tilde{&rm d}_{&rm L}$',
47888      & '                       ~d<SUB>L</SUB>',
47889      & '              $&tilde{&rm u}_{&rm L}$',
47890      & '                       ~u<SUB>L</SUB>',
47891      & '              $&tilde{&rm s}_{&rm L}$',
47892      & '                       ~s<SUB>L</SUB>',
47893      & '              $&tilde{&rm c}_{&rm L}$',
47894      & '                       ~c<SUB>L</SUB>',
47895      & '                    $&tilde{&rm b}_1$',
47896      & '                       ~b<SUB>1</SUB>',
47897      & '                    $&tilde{&rm t}_1$',
47898      & '                       ~t<SUB>1</SUB>',
47899      & '   $&overline{&tilde{&rm d}}_{&rm L}$',
47900      & '                      -~d<SUB>L</SUB>',
47901      & '   $&overline{&tilde{&rm u}}_{&rm L}$',
47902      & '                      -~u<SUB>L</SUB>'/
47903       DATA ((TXNAME(J,I),J=1,2),I=409,416)/
47904      & '   $&overline{&tilde{&rm s}}_{&rm L}$',
47905      & '                      -~s<SUB>L</SUB>',
47906      & '   $&overline{&tilde{&rm c}}_{&rm L}$',
47907      & '                      -~c<SUB>L</SUB>',
47908      & '         $&overline{&tilde{&rm b}}_1$',
47909      & '                      -~b<SUB>1</SUB>',
47910      & '         $&overline{&tilde{&rm t}}_1$',
47911      & '                      -~t<SUB>1</SUB>',
47912      & '              $&tilde{&rm d}_{&rm R}$',
47913      & '                       ~d<SUB>R</SUB>',
47914      & '              $&tilde{&rm u}_{&rm R}$',
47915      & '                       ~u<SUB>R</SUB>',
47916      & '              $&tilde{&rm s}_{&rm R}$',
47917      & '                       ~s<SUB>R</SUB>',
47918      & '              $&tilde{&rm c}_{&rm R}$',
47919      & '                       ~c<SUB>R</SUB>'/
47920       DATA ((TXNAME(J,I),J=1,2),I=417,424)/
47921      & '                    $&tilde{&rm b}_2$',
47922      & '                       ~b<SUB>2</SUB>',
47923      & '                    $&tilde{&rm t}_2$',
47924      & '                       ~t<SUB>2</SUB>',
47925      & '   $&overline{&tilde{&rm d}}_{&rm R}$',
47926      & '                      -~d<SUB>R</SUB>',
47927      & '   $&overline{&tilde{&rm u}}_{&rm R}$',
47928      & '                      -~u<SUB>R</SUB>',
47929      & '   $&overline{&tilde{&rm s}}_{&rm R}$',
47930      & '                      -~s<SUB>R</SUB>',
47931      & '   $&overline{&tilde{&rm c}}_{&rm R}$',
47932      & '                      -~c<SUB>R</SUB>',
47933      & '         $&overline{&tilde{&rm b}}_2$',
47934      & '                      -~b<SUB>2</SUB>',
47935      & '         $&overline{&tilde{&rm t}}_2$',
47936      & '                      -~t<SUB>2</SUB>'/
47937       DATA ((TXNAME(J,I),J=1,2),I=425,432)/
47938      & '            $&tilde{&rm e}^-_{&rm L}$',
47939      & '           ~e<SUP>-</SUP><SUB>L</SUB>',
47940      & '                $&tilde{&nu}_{&rm e}$',
47941      & '                    ~nu<SUB>e L</SUB>',
47942      & '              $&tilde{&mu}^-_{&rm L}$',
47943      & '          ~mu<SUP>-</SUP><SUB>L</SUB>',
47944      & '                    $&tilde{&nu}_&mu$',
47945      & '                   ~nu<SUB>mu L</SUB>',
47946      & '                   $&tilde{&tau}^-_1$',
47947      & '         ~tau<SUP>-</SUP><SUB>1</SUB>',
47948      & '                   $&tilde{&nu}_&tau$',
47949      & '                  ~nu<SUB>tau L</SUB>',
47950      & '            $&tilde{&rm e}^+_{&rm L}$',
47951      & '           ~e<SUP>+</SUP><SUB>L</SUB>',
47952      & '    $&overline{&tilde{&nu}}_{&rm eL}$',
47953      & '                    -~nu<SUB>eL</SUB>'/
47954       DATA ((TXNAME(J,I),J=1,2),I=433,440)/
47955      & '              $&tilde{&mu}^+_{&rm L}$',
47956      & '          ~mu<SUP>+</SUP><SUB>L</SUB>',
47957      & '  $&overline{&tilde{&nu}}_{&rm&mu L}$',
47958      & '                  -~nu<SUB>mu L</SUB>',
47959      & '                   $&tilde{&tau}^+_1$',
47960      & '         ~tau<SUP>+</SUP><SUB>1</SUB>',
47961      & ' $&overline{&tilde{&nu}}_{&rm&tau L}$',
47962      & '                 -~nu<SUB>tau L</SUB>',
47963      & '            $&tilde{&rm e}^-_{&rm R}$',
47964      & '           ~e<SUP>-</SUP><SUB>R</SUB>',
47965      & '               $&tilde{&nu}_{&rm eR}$',
47966      & '                    ~nu<SUB>e R</SUB>',
47967      & '              $&tilde{&mu}^-_{&rm R}$',
47968      & '          ~mu<SUP>-</SUP><SUB>R</SUB>',
47969      & '           $&tilde{&nu}_{&mu{&rm R}}$',
47970      & '                   ~nu<SUB>mu R</SUB>'/
47971       DATA ((TXNAME(J,I),J=1,2),I=441,448)/
47972      & '                   $&tilde{&tau}^-_2$',
47973      & '         ~tau<SUP>-</SUP><SUB>2</SUB>',
47974      & '          $&tilde{&nu}_{&tau{&rm R}}$',
47975      & '                  ~nu<SUB>tau R</SUB>',
47976      & '            $&tilde{&rm e}^+_{&rm R}$',
47977      & '           ~e<SUP>+</SUP><SUB>R</SUB>',
47978      & '    $&overline{&tilde{&nu}}_{&rm eR}$',
47979      & '                   -~nu<SUB>e R</SUB>',
47980      & '              $&tilde{&mu}^+_{&rm R}$',
47981      & '          ~mu<SUP>+</SUP><SUB>R</SUB>',
47982      & '  $&overline{&tilde{&nu}}_{&rm&mu R}$',
47983      & '                  -~nu<SUB>mu R</SUB>',
47984      & '                   $&tilde{&tau}^+_2$',
47985      & '         ~tau<SUP>+</SUP><SUB>2</SUB>',
47986      & ' $&overline{&tilde{&nu}}_{&rm&tau R}$',
47987      & '                 -~nu<SUB>tau R</SUB>'/
47988       DATA ((TXNAME(J,I),J=1,2),I=449,456)/
47989      & '                          $&tilde{g}$',
47990      & '                                   ~g',
47991      & '                   $&tilde{&chi}^0_1$',
47992      & '         ~chi<SUP>0</SUP><SUB>1</SUB>',
47993      & '                   $&tilde{&chi}^0_2$',
47994      & '         ~chi<SUP>0</SUP><SUB>2</SUB>',
47995      & '                   $&tilde{&chi}^0_3$',
47996      & '         ~chi<SUP>0</SUP><SUB>3</SUB>',
47997      & '                   $&tilde{&chi}^0_4$',
47998      & '         ~chi<SUP>0</SUP><SUB>4</SUB>',
47999      & '                   $&tilde{&chi}^+_1$',
48000      & '         ~chi<SUP>+</SUP><SUB>1</SUB>',
48001      & '                   $&tilde{&chi}^+_2$',
48002      & '         ~chi<SUP>+</SUP><SUB>2</SUB>',
48003      & '                   $&tilde{&chi}^-_1$',
48004      & '         ~chi<SUP>-</SUP><SUB>1</SUB>'/
48005       DATA ((TXNAME(J,I),J=1,2),I=457,NLAST)/
48006      & '                   $&tilde{&chi}^-_2$',
48007      & '         ~chi<SUP>-</SUP><SUB>2</SUB>',
48008      & '                          $&tilde{G}$',
48009      & '                                   ~G'/
48010 C
48011       DATA (RNAME(I),I=NNEXT,NMXRES)/NLEFT*'        '/
48012       DATA (IDPDG(I),I=NNEXT,NMXRES)/NLEFT*0/
48013       DATA (IFLAV(I),I=NNEXT,NMXRES)/NLEFT*0/
48014       DATA (RMASS(I),I=NNEXT,NMXRES)/NLEFT*0.0000D0/
48015       DATA (RLTIM(I),I=NNEXT,NMXRES)/NLEFT*0.000D+00/
48016       DATA (RSPIN(I),I=NNEXT,NMXRES)/NLEFT*0.0D0/
48017       DATA (TXNAME(1,I),I=NNEXT,NMXRES)/
48018      & NLEFT*'                                    '/
48019       DATA (TXNAME(2,I),I=NNEXT,NMXRES)/
48020      & NLEFT*'                                    '/
48021 C
48022       DATA (RSTAB(I),I=1,NMXRES)/NMXRES*.FALSE./
48023       DATA DKPSET/.FALSE./
48024 C
48025       DATA NDKYS/2263/
48026       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=   1,  19)/
48027      &   6,0.334D0,100,  2,  7,  5,  0,  0,
48028      &   6,0.333D0,100,  4,  9,  5,  0,  0,
48029      &   6,0.111D0,100,122,127,  5,  0,  0,
48030      &   6,0.111D0,100,124,129,  5,  0,  0,
48031      &   6,0.111D0,100,126,131,  5,  0,  0,
48032      &  12,0.334D0,100,  8,  1, 11,  0,  0,
48033      &  12,0.333D0,100, 10,  3, 11,  0,  0,
48034      &  12,0.111D0,100,128,121, 11,  0,  0,
48035      &  12,0.111D0,100,130,123, 11,  0,  0,
48036      &  12,0.111D0,100,132,125, 11,  0,  0,
48037      &  21,0.988D0,  0, 59, 59,  0,  0,  0,
48038      &  21,0.012D0,  0,127,121, 59,  0,  0,
48039      &  22,0.388D0,  0, 59, 59,  0,  0,  0,
48040      &  22,0.319D0,  0, 21, 21, 21,  0,  0,
48041      &  22,0.001D0,  0, 21, 59, 59,  0,  0,
48042      &  22,0.236D0,  0, 38, 30, 21,  0,  0,
48043      &  22,0.049D0,  0, 38, 30, 59,  0,  0,
48044      &  22,0.005D0,  0,127,121, 59,  0,  0,
48045      &  22,0.002D0,  0, 38, 30,127,121,  0/
48046       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  20,  38)/
48047      &  23,0.989D0,  0, 38, 30,  0,  0,  0,
48048      &  23,0.010D0,  0, 38, 30, 59,  0,  0,
48049      &  23,0.001D0,  0, 21, 59,  0,  0,  0,
48050      &  24,0.888D0,  0, 38, 30, 21,  0,  0,
48051      &  24,0.085D0,  0, 21, 59,  0,  0,  0,
48052      &  24,0.022D0,  0, 38, 30,  0,  0,  0,
48053      &  24,0.001D0,  0, 22, 59,  0,  0,  0,
48054      &  24,0.001D0,  0, 21,127,121,  0,  0,
48055      &  24,0.003D0,  0, 38, 30, 21, 21,  0,
48056      &  25,0.437D0,  0, 38, 30, 22,  0,  0,
48057      &  25,0.302D0,  0, 23, 59,  0,  0,  0,
48058      &  25,0.208D0,  0, 21, 21, 22,  0,  0,
48059      &  25,0.030D0,  0, 24, 59,  0,  0,  0,
48060      &  25,0.021D0,  0, 59, 59,  0,  0,  0,
48061      &  25,0.002D0,  0, 21, 21, 21,  0,  0,
48062      &  26,0.566D0,  0, 38, 30,  0,  0,  0,
48063      &  26,0.283D0,  0, 21, 21,  0,  0,  0,
48064      &  26,0.069D0,  0, 38, 30, 21, 21,  0,
48065      &  26,0.023D0,  0, 46, 34,  0,  0,  0/
48066       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  39,  57)/
48067      &  26,0.023D0,  0, 50, 42,  0,  0,  0,
48068      &  26,0.028D0,  0, 38, 38, 30, 30,  0,
48069      &  26,0.005D0,  0, 22, 22,  0,  0,  0,
48070      &  26,0.003D0,  0, 21, 21, 21, 21,  0,
48071      &  27,0.499D0,  0, 39, 30,  0,  0,  0,
48072      &  27,0.499D0,  0, 31, 38,  0,  0,  0,
48073      &  27,0.002D0,  0, 21, 59, 59,  0,  0,
48074      &  28,0.148D0,  0, 21, 21, 38, 30,  0,
48075      &  28,0.148D0,  0, 23, 38, 30,  0,  0,
48076      &  28,0.147D0,  0,291, 30,  0,  0,  0,
48077      &  28,0.147D0,  0,290, 21,  0,  0,  0,
48078      &  28,0.147D0,  0,292, 38,  0,  0,  0,
48079      &  28,0.067D0,  0, 22, 38, 30,  0,  0,
48080      &  28,0.033D0,  0, 22, 21, 21,  0,  0,
48081      &  28,0.032D0,  0, 46, 42, 30,  0,  0,
48082      &  28,0.016D0,  0, 46, 34, 21,  0,  0,
48083      &  28,0.016D0,  0, 50, 42, 21,  0,  0,
48084      &  28,0.032D0,  0, 50, 34, 38,  0,  0,
48085      &  28,0.066D0,  0, 59, 23,  0,  0,  0/
48086       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  58,  76)/
48087      &  28,0.001D0,  0, 56, 59,  0,  0,  0,
48088      &  29,0.349D0,  0, 39, 30,  0,  0,  0,
48089      &  29,0.349D0,  0, 31, 38,  0,  0,  0,
48090      &  29,0.144D0,  0, 22, 21,  0,  0,  0,
48091      &  29,0.104D0,  0, 24, 38, 30,  0,  0,
48092      &  29,0.024D0,  0, 46, 34,  0,  0,  0,
48093      &  29,0.024D0,  0, 50, 42,  0,  0,  0,
48094      &  29,0.006D0,  0, 25, 21,  0,  0,  0,
48095      &  30,1.000D0,  0,123,130,  0,  0,  0,
48096      &  31,1.000D0,  0, 30, 21,  0,  0,  0,
48097      &  32,0.499D0,  0, 31, 21,  0,  0,  0,
48098      &  32,0.499D0,  0, 23, 30,  0,  0,  0,
48099      &  32,0.002D0,  0, 30, 59,  0,  0,  0,
48100      &  33,0.349D0,  0, 31, 21,  0,  0,  0,
48101      &  33,0.349D0,  0, 23, 30,  0,  0,  0,
48102      &  33,0.144D0,  0, 22, 30,  0,  0,  0,
48103      &  33,0.101D0,  0, 24, 30, 21,  0,  0,
48104      &  33,0.048D0,  0, 50, 34,  0,  0,  0,
48105      &  33,0.006D0,  0, 25, 30,  0,  0,  0/
48106       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  77,  95)/
48107      &  33,0.003D0,  0, 30, 59,  0,  0,  0,
48108      &  34,0.629D0,  0,123,130,  0,  0,  0,
48109      &  34,0.212D0,  0, 30, 21,  0,  0,  0,
48110      &  34,0.056D0,  0, 30, 38, 30,  0,  0,
48111      &  34,0.017D0,  0, 30, 21, 21,  0,  0,
48112      &  34,0.048D0,101,121,128, 21,  0,  0,
48113      &  34,0.032D0,101,123,130, 21,  0,  0,
48114      &  34,0.006D0,  0,123,130, 59,  0,  0,
48115      &  35,0.666D0,  0, 42, 30,  0,  0,  0,
48116      &  35,0.333D0,  0, 34, 21,  0,  0,  0,
48117      &  35,0.001D0,  0, 34, 59,  0,  0,  0,
48118      &  36,0.627D0,  0, 43, 30,  0,  0,  0,
48119      &  36,0.313D0,  0, 35, 21,  0,  0,  0,
48120      &  36,0.020D0,  0, 42, 31,  0,  0,  0,
48121      &  36,0.010D0,  0, 34, 23,  0,  0,  0,
48122      &  36,0.020D0,  0, 34,294,  0,  0,  0,
48123      &  36,0.010D0,  0, 34, 24,  0,  0,  0,
48124      &  37,0.331D0,  0, 42, 30,  0,  0,  0,
48125      &  37,0.166D0,  0, 34, 21,  0,  0,  0/
48126       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  96, 114)/
48127      &  37,0.168D0,  0, 43, 30,  0,  0,  0,
48128      &  37,0.084D0,  0, 35, 21,  0,  0,  0,
48129      &  37,0.087D0,  0, 35, 38, 30,  0,  0,
48130      &  37,0.044D0,  0, 35, 21, 21,  0,  0,
48131      &  37,0.059D0,  0, 42, 31,  0,  0,  0,
48132      &  37,0.029D0,  0, 34, 23,  0,  0,  0,
48133      &  37,0.029D0,  0, 34, 24,  0,  0,  0,
48134      &  37,0.002D0,  0, 34, 59,  0,  0,  0,
48135      &  37,0.001D0,  0, 34, 22,  0,  0,  0,
48136      &  38,1.000D0,  0,129,124,  0,  0,  0,
48137      &  39,1.000D0,  0, 38, 21,  0,  0,  0,
48138      &  40,0.499D0,  0, 39, 21,  0,  0,  0,
48139      &  40,0.499D0,  0, 23, 38,  0,  0,  0,
48140      &  40,0.002D0,  0, 38, 59,  0,  0,  0,
48141      &  41,0.349D0,  0, 39, 21,  0,  0,  0,
48142      &  41,0.349D0,  0, 23, 38,  0,  0,  0,
48143      &  41,0.144D0,  0, 22, 38,  0,  0,  0,
48144      &  41,0.101D0,  0, 24, 38, 21,  0,  0,
48145      &  41,0.048D0,  0, 46, 42,  0,  0,  0/
48146       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 115, 133)/
48147      &  41,0.006D0,  0, 25, 38,  0,  0,  0,
48148      &  41,0.003D0,  0, 38, 59,  0,  0,  0,
48149      &  42,0.500D0,  0, 60,  0,  0,  0,  0,
48150      &  42,0.500D0,  0, 61,  0,  0,  0,  0,
48151      &  43,0.665D0,  0, 34, 38,  0,  0,  0,
48152      &  43,0.333D0,  0, 42, 21,  0,  0,  0,
48153      &  43,0.002D0,  0, 42, 59,  0,  0,  0,
48154      &  44,0.627D0,  0, 35, 38,  0,  0,  0,
48155      &  44,0.313D0,  0, 43, 21,  0,  0,  0,
48156      &  44,0.020D0,  0, 34, 39,  0,  0,  0,
48157      &  44,0.010D0,  0, 42, 23,  0,  0,  0,
48158      &  44,0.020D0,  0, 42,294,  0,  0,  0,
48159      &  44,0.010D0,  0, 42, 24,  0,  0,  0,
48160      &  45,0.331D0,  0, 34, 38,  0,  0,  0,
48161      &  45,0.166D0,  0, 42, 21,  0,  0,  0,
48162      &  45,0.168D0,  0, 35, 38,  0,  0,  0,
48163      &  45,0.084D0,  0, 43, 21,  0,  0,  0,
48164      &  45,0.089D0,  0, 42, 38, 30,  0,  0,
48165      &  45,0.044D0,  0, 42, 21, 21,  0,  0/
48166       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 134, 152)/
48167      &  45,0.059D0,  0, 34, 39,  0,  0,  0,
48168      &  45,0.029D0,  0, 42, 23,  0,  0,  0,
48169      &  45,0.029D0,  0, 42, 24,  0,  0,  0,
48170      &  45,0.001D0,  0, 42, 22,  0,  0,  0,
48171      &  46,0.629D0,  0,129,124,  0,  0,  0,
48172      &  46,0.212D0,  0, 38, 21,  0,  0,  0,
48173      &  46,0.056D0,  0, 38, 38, 30,  0,  0,
48174      &  46,0.017D0,  0, 38, 21, 21,  0,  0,
48175      &  46,0.032D0,101,129,124, 21,  0,  0,
48176      &  46,0.048D0,101,127,122, 21,  0,  0,
48177      &  46,0.006D0,  0,129,124, 59,  0,  0,
48178      &  47,0.666D0,  0, 50, 38,  0,  0,  0,
48179      &  47,0.333D0,  0, 46, 21,  0,  0,  0,
48180      &  47,0.001D0,  0, 46, 59,  0,  0,  0,
48181      &  48,0.627D0,  0, 51, 38,  0,  0,  0,
48182      &  48,0.313D0,  0, 47, 21,  0,  0,  0,
48183      &  48,0.020D0,  0, 50, 39,  0,  0,  0,
48184      &  48,0.010D0,  0, 46, 23,  0,  0,  0,
48185      &  48,0.020D0,  0, 46,294,  0,  0,  0/
48186       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 153, 171)/
48187      &  48,0.010D0,  0, 46, 24,  0,  0,  0,
48188      &  49,0.331D0,  0, 50, 38,  0,  0,  0,
48189      &  49,0.166D0,  0, 46, 21,  0,  0,  0,
48190      &  49,0.168D0,  0, 51, 38,  0,  0,  0,
48191      &  49,0.084D0,  0, 47, 21,  0,  0,  0,
48192      &  49,0.087D0,  0, 47, 38, 30,  0,  0,
48193      &  49,0.044D0,  0, 47, 21, 21,  0,  0,
48194      &  49,0.059D0,  0, 50, 39,  0,  0,  0,
48195      &  49,0.029D0,  0, 46, 23,  0,  0,  0,
48196      &  49,0.029D0,  0, 46, 24,  0,  0,  0,
48197      &  49,0.002D0,  0, 46, 59,  0,  0,  0,
48198      &  49,0.001D0,  0, 46, 22,  0,  0,  0,
48199      &  50,0.500D0,  0, 60,  0,  0,  0,  0,
48200      &  50,0.500D0,  0, 61,  0,  0,  0,  0,
48201      &  51,0.665D0,  0, 46, 30,  0,  0,  0,
48202      &  51,0.333D0,  0, 50, 21,  0,  0,  0,
48203      &  51,0.002D0,  0, 50, 59,  0,  0,  0,
48204      &  52,0.627D0,  0, 47, 30,  0,  0,  0,
48205      &  52,0.313D0,  0, 51, 21,  0,  0,  0/
48206       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 172, 190)/
48207      &  52,0.020D0,  0, 46, 31,  0,  0,  0,
48208      &  52,0.010D0,  0, 50, 23,  0,  0,  0,
48209      &  52,0.020D0,  0, 50,294,  0,  0,  0,
48210      &  52,0.010D0,  0, 50, 24,  0,  0,  0,
48211      &  53,0.331D0,  0, 46, 30,  0,  0,  0,
48212      &  53,0.166D0,  0, 50, 21,  0,  0,  0,
48213      &  53,0.168D0,  0, 47, 30,  0,  0,  0,
48214      &  53,0.084D0,  0, 51, 21,  0,  0,  0,
48215      &  53,0.089D0,  0, 50, 38, 30,  0,  0,
48216      &  53,0.044D0,  0, 50, 21, 21,  0,  0,
48217      &  53,0.059D0,  0, 46, 31,  0,  0,  0,
48218      &  53,0.029D0,  0, 50, 23,  0,  0,  0,
48219      &  53,0.029D0,  0, 50, 24,  0,  0,  0,
48220      &  53,0.001D0,  0, 50, 22,  0,  0,  0,
48221      &  56,0.490D0,  0, 46, 34,  0,  0,  0,
48222      &  56,0.342D0,  0, 61, 60,  0,  0,  0,
48223      &  56,0.043D0,  0, 39, 30,  0,  0,  0,
48224      &  56,0.043D0,  0, 23, 21,  0,  0,  0,
48225      &  56,0.043D0,  0, 31, 38,  0,  0,  0/
48226       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 191, 209)/
48227      &  56,0.025D0,  0, 38, 30, 21,  0,  0,
48228      &  56,0.013D0,  0, 22, 59,  0,  0,  0,
48229      &  56,0.001D0,  0, 21, 59,  0,  0,  0,
48230      &  57,0.250D0,  0, 50, 43,  0,  0,  0,
48231      &  57,0.250D0,  0, 34, 47,  0,  0,  0,
48232      &  57,0.250D0,  0, 42, 51,  0,  0,  0,
48233      &  57,0.250D0,  0, 46, 35,  0,  0,  0,
48234      &  58,0.356D0,  0, 46, 34,  0,  0,  0,
48235      &  58,0.356D0,  0, 50, 42,  0,  0,  0,
48236      &  58,0.279D0,  0, 22, 22,  0,  0,  0,
48237      &  58,0.006D0,  0, 38, 30,  0,  0,  0,
48238      &  58,0.003D0,  0, 21, 21,  0,  0,  0,
48239      &  60,0.684D0,  0, 38, 30,  0,  0,  0,
48240      &  60,0.314D0,  0, 21, 21,  0,  0,  0,
48241      &  60,0.002D0,  0, 38, 30, 59,  0,  0,
48242      &  61,0.216D0,  0, 21, 21, 21,  0,  0,
48243      &  61,0.124D0,  0, 38, 30, 21,  0,  0,
48244      &  61,0.135D0,101,123,130, 38,  0,  0,
48245      &  61,0.135D0,101,124,129, 30,  0,  0/
48246       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 210, 228)/
48247      &  61,0.187D0,101,121,128, 38,  0,  0,
48248      &  61,0.187D0,101,122,127, 30,  0,  0,
48249      &  61,0.006D0,  0,121,128, 38, 59,  0,
48250      &  61,0.006D0,  0,122,127, 30, 59,  0,
48251      &  61,0.002D0,  0, 38, 30,  0,  0,  0,
48252      &  61,0.001D0,  0, 21, 21,  0,  0,  0,
48253      &  61,0.001D0,  0, 59, 59,  0,  0,  0,
48254      &  74,0.663D0,  0, 73, 21,  0,  0,  0,
48255      &  74,0.331D0,  0, 75, 38,  0,  0,  0,
48256      &  74,0.006D0,  0, 73, 59,  0,  0,  0,
48257      &  75,1.000D0,101,121,128, 73,  0,  0,
48258      &  76,0.663D0,  0, 75, 21,  0,  0,  0,
48259      &  76,0.331D0,  0, 73, 30,  0,  0,  0,
48260      &  76,0.006D0,  0, 75, 59,  0,  0,  0,
48261      &  77,1.000D0,  0, 75, 30,  0,  0,  0,
48262      &  78,0.638D0,  0, 73, 30,  0,  0,  0,
48263      &  78,0.358D0,  0, 75, 21,  0,  0,  0,
48264      &  78,0.002D0,  0, 75, 59,  0,  0,  0,
48265      &  78,0.001D0,  0, 73, 30, 59,  0,  0/
48266       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 229, 247)/
48267      &  78,0.001D0,101,121,128, 73,  0,  0,
48268      &  79,0.995D0,  0, 78, 59,  0,  0,  0,
48269      &  79,0.005D0,  0, 78,127,121,  0,  0,
48270      &  80,0.880D0,  0, 78, 21,  0,  0,  0,
48271      &  80,0.060D0,  0, 86, 30,  0,  0,  0,
48272      &  80,0.060D0,  0, 81, 38,  0,  0,  0,
48273      &  81,0.998D0,  0, 75, 30,  0,  0,  0,
48274      &  81,0.001D0,  0, 75, 30, 59,  0,  0,
48275      &  81,0.001D0,101,121,128, 75,  0,  0,
48276      &  82,0.880D0,  0, 78, 30,  0,  0,  0,
48277      &  82,0.060D0,  0, 79, 30,  0,  0,  0,
48278      &  82,0.060D0,  0, 81, 21,  0,  0,  0,
48279      &  83,0.999D0,  0, 78, 30,  0,  0,  0,
48280      &  83,0.001D0,101,121,128, 78,  0,  0,
48281      &  84,0.667D0,  0, 88, 30,  0,  0,  0,
48282      &  84,0.333D0,  0, 83, 21,  0,  0,  0,
48283      &  85,1.000D0,  0, 73, 38,  0,  0,  0,
48284      &  86,0.516D0,  0, 73, 21,  0,  0,  0,
48285      &  86,0.483D0,  0, 75, 38,  0,  0,  0/
48286       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 248, 266)/
48287      &  86,0.001D0,  0, 73, 59,  0,  0,  0,
48288      &  87,0.880D0,  0, 78, 38,  0,  0,  0,
48289      &  87,0.060D0,  0, 86, 21,  0,  0,  0,
48290      &  87,0.060D0,  0, 79, 38,  0,  0,  0,
48291      &  88,0.995D0,  0, 78, 21,  0,  0,  0,
48292      &  88,0.001D0,  0, 78, 59,  0,  0,  0,
48293      &  88,0.004D0,  0, 79, 59,  0,  0,  0,
48294      &  89,0.667D0,  0, 83, 38,  0,  0,  0,
48295      &  89,0.333D0,  0, 88, 21,  0,  0,  0,
48296      &  90,0.675D0,  0, 78, 34,  0,  0,  0,
48297      &  90,0.233D0,  0, 88, 30,  0,  0,  0,
48298      &  90,0.086D0,  0, 83, 21,  0,  0,  0,
48299      &  90,0.006D0,101,121,128, 88,  0,  0,
48300      &  92,0.663D0,  0, 91, 21,  0,  0,  0,
48301      &  92,0.331D0,  0, 93, 30,  0,  0,  0,
48302      &  92,0.006D0,  0, 91, 59,  0,  0,  0,
48303      &  93,1.000D0,101,127,122, 91,  0,  0,
48304      &  94,0.663D0,  0, 93, 21,  0,  0,  0,
48305      &  94,0.331D0,  0, 91, 38,  0,  0,  0/
48306       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 267, 285)/
48307      &  94,0.006D0,  0, 93, 59,  0,  0,  0,
48308      &  95,1.000D0,  0, 93, 38,  0,  0,  0,
48309      &  96,0.638D0,  0, 91, 38,  0,  0,  0,
48310      &  96,0.358D0,  0, 93, 21,  0,  0,  0,
48311      &  96,0.002D0,  0, 93, 59,  0,  0,  0,
48312      &  96,0.001D0,  0, 91, 38, 59,  0,  0,
48313      &  96,0.001D0,101,127,122, 91,  0,  0,
48314      &  97,0.995D0,  0, 96, 59,  0,  0,  0,
48315      &  97,0.005D0,  0, 96,127,121,  0,  0,
48316      &  98,0.880D0,  0, 96, 21,  0,  0,  0,
48317      &  98,0.060D0,  0,104, 38,  0,  0,  0,
48318      &  98,0.060D0,  0, 99, 30,  0,  0,  0,
48319      &  99,0.998D0,  0, 93, 38,  0,  0,  0,
48320      &  99,0.001D0,  0, 93, 38, 59,  0,  0,
48321      &  99,0.001D0,101,127,122, 93,  0,  0,
48322      & 100,0.880D0,  0, 96, 38,  0,  0,  0,
48323      & 100,0.060D0,  0, 97, 38,  0,  0,  0,
48324      & 100,0.060D0,  0, 99, 21,  0,  0,  0,
48325      & 101,0.999D0,  0, 96, 38,  0,  0,  0/
48326       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 286, 304)/
48327      & 101,0.001D0,101,127,122, 96,  0,  0,
48328      & 102,0.667D0,  0,106, 38,  0,  0,  0,
48329      & 102,0.333D0,  0,101, 21,  0,  0,  0,
48330      & 103,1.000D0,  0, 91, 30,  0,  0,  0,
48331      & 104,0.516D0,  0, 91, 21,  0,  0,  0,
48332      & 104,0.483D0,  0, 93, 30,  0,  0,  0,
48333      & 104,0.001D0,  0, 91, 59,  0,  0,  0,
48334      & 105,0.880D0,  0, 96, 30,  0,  0,  0,
48335      & 105,0.060D0,  0,104, 21,  0,  0,  0,
48336      & 105,0.060D0,  0, 97, 30,  0,  0,  0,
48337      & 106,0.995D0,  0, 96, 21,  0,  0,  0,
48338      & 106,0.001D0,  0, 96, 59,  0,  0,  0,
48339      & 106,0.004D0,  0, 97, 59,  0,  0,  0,
48340      & 107,0.667D0,  0,101, 30,  0,  0,  0,
48341      & 107,0.333D0,  0,106, 21,  0,  0,  0,
48342      & 108,0.675D0,  0, 96, 46,  0,  0,  0,
48343      & 108,0.233D0,  0,106, 38,  0,  0,  0,
48344      & 108,0.086D0,  0,101, 21,  0,  0,  0,
48345      & 108,0.006D0,101,127,122,106,  0,  0/
48346       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 305, 323)/
48347      & 123,0.986D0,100,121,128,124,  0,  0,
48348      & 123,0.014D0,  0,121,128,124, 59,  0,
48349      & 125,0.178D0,100,121,128,126,  0,  0,
48350      & 125,0.171D0,100,123,130,126,  0,  0,
48351      & 125,0.002D0,  0,123,130, 59,126,  0,
48352      & 125,0.111D0,  0, 30,126,  0,  0,  0,
48353      & 125,0.253D0,  0, 31,126,  0,  0,  0,
48354      & 125,0.181D0,  0, 32,126,  0,  0,  0,
48355      & 125,0.002D0,  0, 30, 22, 21,126,  0,
48356      & 125,0.018D0,  0, 30, 24,126,  0,  0,
48357      & 125,0.004D0,  0, 30, 24, 21,126,  0,
48358      & 125,0.015D0,  0, 31, 23,126,  0,  0,
48359      & 125,0.001D0,  0, 31, 24, 21,126,  0,
48360      & 125,0.024D0,  0, 32, 21,126,  0,  0,
48361      & 125,0.002D0,  0, 32, 38, 30,126,  0,
48362      & 125,0.007D0,  0, 34,126,  0,  0,  0,
48363      & 125,0.014D0,  0, 35,126,  0,  0,  0,
48364      & 125,0.003D0,  0, 35, 21,126,  0,  0,
48365      & 125,0.001D0,  0, 34, 38, 30,126,  0/
48366       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 324, 342)/
48367      & 125,0.004D0,  0, 30, 43,126,  0,  0,
48368      & 125,0.003D0,  0, 34, 50,126,  0,  0,
48369      & 125,0.003D0,  0, 34, 51,126,  0,  0,
48370      & 125,0.003D0,  0, 30, 50, 42,126,  0,
48371      & 129,0.986D0,100,127,122,130,  0,  0,
48372      & 129,0.014D0,  0,127,122,130, 59,  0,
48373      & 131,0.178D0,100,127,122,132,  0,  0,
48374      & 131,0.171D0,100,129,124,132,  0,  0,
48375      & 131,0.002D0,  0,129,124, 59,132,  0,
48376      & 131,0.111D0,  0, 38,132,  0,  0,  0,
48377      & 131,0.253D0,  0, 39,132,  0,  0,  0,
48378      & 131,0.181D0,  0, 40,132,  0,  0,  0,
48379      & 131,0.002D0,  0, 38, 22, 21,132,  0,
48380      & 131,0.018D0,  0, 38, 24,132,  0,  0,
48381      & 131,0.004D0,  0, 38, 24, 21,132,  0,
48382      & 131,0.015D0,  0, 39, 23,132,  0,  0,
48383      & 131,0.001D0,  0, 39, 24, 21,132,  0,
48384      & 131,0.024D0,  0, 40, 21,132,  0,  0,
48385      & 131,0.002D0,  0, 40, 38, 30,132,  0/
48386       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 343, 361)/
48387      & 131,0.007D0,  0, 46,132,  0,  0,  0,
48388      & 131,0.014D0,  0, 47,132,  0,  0,  0,
48389      & 131,0.003D0,  0, 47, 21,132,  0,  0,
48390      & 131,0.001D0,  0, 46, 38, 30,132,  0,
48391      & 131,0.004D0,  0, 38, 51,132,  0,  0,
48392      & 131,0.003D0,  0, 46, 42,132,  0,  0,
48393      & 131,0.003D0,  0, 46, 43,132,  0,  0,
48394      & 131,0.003D0,  0, 38, 50, 42,132,  0,
48395      & 136,0.067D0,101,122,127, 42,  0,  0,
48396      & 136,0.067D0,101,124,129, 42,  0,  0,
48397      & 136,0.048D0,101,122,127, 43,  0,  0,
48398      & 136,0.048D0,101,124,129, 43,  0,  0,
48399      & 136,0.003D0,  0, 34, 38,122,127,  0,
48400      & 136,0.003D0,  0, 34, 38,124,129,  0,
48401      & 136,0.006D0,101,122,127, 21,  0,  0,
48402      & 136,0.006D0,101,124,129, 21,  0,  0,
48403      & 136,0.002D0,101,122,127, 23,  0,  0,
48404      & 136,0.002D0,101,124,129, 23,  0,  0,
48405      & 136,0.055D0,  0, 34, 38, 38,  0,  0/
48406       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 362, 380)/
48407      & 136,0.031D0,  0, 34, 39, 38,  0,  0,
48408      & 136,0.042D0,  0, 34, 38, 38, 21, 21,
48409      & 136,0.002D0,  0, 34, 38, 38, 38, 31,
48410      & 136,0.021D0,  0, 35, 38, 38,  0,  0,
48411      & 136,0.027D0,  0, 42, 38,  0,  0,  0,
48412      & 136,0.066D0,  0, 42, 39,  0,  0,  0,
48413      & 136,0.081D0,  0, 42, 40,  0,  0,  0,
48414      & 136,0.024D0,  0, 42, 38, 21,  0,  0,
48415      & 136,0.004D0,  0, 42, 38, 23,  0,  0,
48416      & 136,0.069D0,  0, 42, 38, 38, 30, 21,
48417      & 136,0.001D0,  0, 42, 38, 38, 30, 23,
48418      & 136,0.022D0,  0, 43, 38,  0,  0,  0,
48419      & 136,0.021D0,  0, 43, 39,  0,  0,  0,
48420      & 136,0.042D0,  0, 43, 38, 21,  0,  0,
48421      & 136,0.008D0,  0, 43, 38, 23,  0,  0,
48422      & 136,0.010D0,  0, 43, 38, 38, 30,  0,
48423      & 136,0.050D0,  0,311, 38,  0,  0,  0,
48424      & 136,0.034D0,  0,329, 38,  0,  0,  0,
48425      & 136,0.010D0,  0,369, 38,  0,  0,  0/
48426       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 381, 399)/
48427      & 136,0.031D0,  0, 46, 42, 42,  0,  0,
48428      & 136,0.003D0,  0, 38, 21,  0,  0,  0,
48429      & 136,0.001D0,  0, 38, 23,  0,  0,  0,
48430      & 136,0.002D0,  0, 38, 38, 30,  0,  0,
48431      & 136,0.008D0,  0, 38, 22,  0,  0,  0,
48432      & 136,0.001D0,  0, 38, 38, 38, 30, 30,
48433      & 136,0.003D0,  0, 38, 38, 38, 30, 31,
48434      & 136,0.008D0,  0, 46, 42,  0,  0,  0,
48435      & 136,0.005D0,  0, 46, 43,  0,  0,  0,
48436      & 136,0.026D0,  0, 47, 43,  0,  0,  0,
48437      & 136,0.005D0,  0, 46, 34, 38,  0,  0,
48438      & 136,0.007D0,  0, 38, 56,  0,  0,  0,
48439      & 136,0.023D0,  0, 38, 56, 21,  0,  0,
48440      & 136,0.005D0,  0, 46, 46, 34,  0,  0,
48441      & 137,0.683D0,  0,140, 38,  0,  0,  0,
48442      & 137,0.306D0,  0,136, 21,  0,  0,  0,
48443      & 137,0.011D0,  0,136, 59,  0,  0,  0,
48444      & 138,0.667D0,  0,141, 38,  0,  0,  0,
48445      & 138,0.333D0,  0,137, 21,  0,  0,  0/
48446       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 400, 418)/
48447      & 139,0.220D0,  0,140, 38,  0,  0,  0,
48448      & 139,0.110D0,  0,136, 21,  0,  0,  0,
48449      & 139,0.380D0,  0,141, 38,  0,  0,  0,
48450      & 139,0.190D0,  0,137, 21,  0,  0,  0,
48451      & 139,0.004D0,  0,136, 22,  0,  0,  0,
48452      & 139,0.064D0,  0,141, 38, 21,  0,  0,
48453      & 139,0.032D0,  0,137, 38, 30,  0,  0,
48454      & 140,0.037D0,101,122,127, 34,  0,  0,
48455      & 140,0.037D0,101,124,129, 34,  0,  0,
48456      & 140,0.016D0,101,122,127, 35,  0,  0,
48457      & 140,0.016D0,101,124,129, 35,  0,  0,
48458      & 140,0.013D0,  0, 34, 21,122,127,  0,
48459      & 140,0.013D0,  0, 34, 21,124,129,  0,
48460      & 140,0.012D0,  0, 42, 30,122,127,  0,
48461      & 140,0.012D0,  0, 42, 30,124,129,  0,
48462      & 140,0.003D0,101,122,127, 30,  0,  0,
48463      & 140,0.003D0,101,124,129, 30,  0,  0,
48464      & 140,0.039D0,  0, 34, 38,  0,  0,  0,
48465      & 140,0.091D0,  0, 34, 39,  0,  0,  0/
48466       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 419, 437)/
48467      & 140,0.067D0,  0, 34, 40,  0,  0,  0,
48468      & 140,0.004D0,  0, 34, 38, 21,  0,  0,
48469      & 140,0.100D0,  0, 34, 38, 21, 21,  0,
48470      & 140,0.058D0,  0, 34, 38, 23,  0,  0,
48471      & 140,0.020D0,  0, 34, 38, 24,  0,  0,
48472      & 140,0.006D0,  0, 34, 38, 25,  0,  0,
48473      & 140,0.043D0,  0, 35, 38,  0,  0,  0,
48474      & 140,0.035D0,  0, 35, 39,  0,  0,  0,
48475      & 140,0.007D0,  0,312, 38,  0,  0,  0,
48476      & 140,0.007D0,  0,330, 38,  0,  0,  0,
48477      & 140,0.020D0,  0, 42, 21,  0,  0,  0,
48478      & 140,0.006D0,  0, 42, 22,  0,  0,  0,
48479      & 140,0.009D0,  0, 42, 23,  0,  0,  0,
48480      & 140,0.016D0,  0, 42, 24,  0,  0,  0,
48481      & 140,0.014D0,  0, 42, 25,  0,  0,  0,
48482      & 140,0.003D0,  0, 42,293,  0,  0,  0,
48483      & 140,0.007D0,  0, 42, 56,  0,  0,  0,
48484      & 140,0.003D0,  0, 42, 26,  0,  0,  0,
48485      & 140,0.004D0,  0, 42,294,  0,  0,  0/
48486       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 438, 456)/
48487      & 140,0.006D0,  0, 42, 21, 21,  0,  0,
48488      & 140,0.042D0,  0, 42, 38, 30, 21,  0,
48489      & 140,0.004D0,  0, 42, 38, 38, 30, 30,
48490      & 140,0.076D0,  0, 42, 38, 30, 21, 21,
48491      & 140,0.026D0,  0, 43, 21,  0,  0,  0,
48492      & 140,0.014D0,  0, 43, 22,  0,  0,  0,
48493      & 140,0.014D0,  0, 43, 23,  0,  0,  0,
48494      & 140,0.011D0,  0, 43, 24,  0,  0,  0,
48495      & 140,0.018D0,  0, 43, 38, 30,  0,  0,
48496      & 140,0.004D0,  0, 42, 46, 34,  0,  0,
48497      & 140,0.004D0,  0, 42, 46, 34, 21,  0,
48498      & 140,0.005D0,  0, 42, 42, 50,  0,  0,
48499      & 140,0.002D0,  0, 38, 30,  0,  0,  0,
48500      & 140,0.001D0,  0, 21, 21,  0,  0,  0,
48501      & 140,0.008D0,  0, 38, 30, 21,  0,  0,
48502      & 140,0.007D0,  0, 38, 38, 30, 30,  0,
48503      & 140,0.015D0,  0, 38, 38, 30, 30, 21,
48504      & 140,0.004D0,  0, 46, 34,  0,  0,  0,
48505      & 140,0.003D0,  0, 47, 34,  0,  0,  0/
48506       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 457, 475)/
48507      & 140,0.002D0,  0, 46, 35,  0,  0,  0,
48508      & 140,0.001D0,  0, 50, 42,  0,  0,  0,
48509      & 140,0.002D0,  0, 51, 43,  0,  0,  0,
48510      & 140,0.003D0,  0, 50, 34, 38,  0,  0,
48511      & 140,0.003D0,  0, 42, 46, 30,  0,  0,
48512      & 140,0.001D0,  0, 46, 34, 38, 30, 21,
48513      & 140,0.002D0,  0, 56, 23,  0,  0,  0,
48514      & 140,0.001D0,  0, 56, 38, 30,  0,  0,
48515      & 141,0.636D0,  0,140, 21,  0,  0,  0,
48516      & 141,0.364D0,  0,140, 59,  0,  0,  0,
48517      & 142,0.667D0,  0,137, 30,  0,  0,  0,
48518      & 142,0.333D0,  0,141, 21,  0,  0,  0,
48519      & 143,0.220D0,  0,136, 30,  0,  0,  0,
48520      & 143,0.110D0,  0,140, 21,  0,  0,  0,
48521      & 143,0.380D0,  0,137, 30,  0,  0,  0,
48522      & 143,0.190D0,  0,141, 21,  0,  0,  0,
48523      & 143,0.004D0,  0,140, 22,  0,  0,  0,
48524      & 143,0.064D0,  0,137, 30, 21,  0,  0,
48525      & 143,0.032D0,  0,141, 38, 30,  0,  0/
48526       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 476, 494)/
48527      & 144,0.009D0,  0,124,129,  0,  0,  0,
48528      & 144,0.019D0,101,122,127, 56,  0,  0,
48529      & 144,0.019D0,101,124,129, 56,  0,  0,
48530      & 144,0.025D0,101,122,127, 22,  0,  0,
48531      & 144,0.025D0,101,124,129, 22,  0,  0,
48532      & 144,0.009D0,101,122,127, 25,  0,  0,
48533      & 144,0.009D0,101,124,129, 25,  0,  0,
48534      & 144,0.036D0,  0, 46, 42,  0,  0,  0,
48535      & 144,0.034D0,  0, 46, 43,  0,  0,  0,
48536      & 144,0.007D0,  0, 46,329,  0,  0,  0,
48537      & 144,0.043D0,  0, 47, 42,  0,  0,  0,
48538      & 144,0.058D0,  0, 47, 43,  0,  0,  0,
48539      & 144,0.011D0,  0, 46, 34, 38,  0,  0,
48540      & 144,0.055D0,  0, 46, 34, 38, 21,  0,
48541      & 144,0.003D0,  0, 46, 34, 38, 38, 30,
48542      & 144,0.014D0,  0, 46, 42, 38, 30,  0,
48543      & 144,0.017D0,  0, 50, 34, 38, 38,  0,
48544      & 144,0.036D0,  0, 56, 38,  0,  0,  0,
48545      & 144,0.067D0,  0, 56, 39,  0,  0,  0/
48546       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 495, 513)/
48547      & 144,0.023D0,  0, 56, 38, 21,  0,  0,
48548      & 144,0.018D0,  0, 56, 38, 38, 30,  0,
48549      & 144,0.020D0,  0, 22, 38,  0,  0,  0,
48550      & 144,0.001D0,  0, 23, 38,  0,  0,  0,
48551      & 144,0.009D0,  0, 24, 38,  0,  0,  0,
48552      & 144,0.049D0,  0, 25, 38,  0,  0,  0,
48553      & 144,0.011D0,  0,293, 38,  0,  0,  0,
48554      & 144,0.015D0,  0, 22, 38, 21,  0,  0,
48555      & 144,0.016D0,  0, 25, 38, 21,  0,  0,
48556      & 144,0.103D0,  0, 22, 39,  0,  0,  0,
48557      & 144,0.120D0,  0, 25, 39,  0,  0,  0,
48558      & 144,0.010D0,  0, 38, 38, 30,  0,  0,
48559      & 144,0.046D0,  0, 38, 38, 30, 21,  0,
48560      & 144,0.003D0,  0, 38, 38, 38, 30, 30,
48561      & 144,0.042D0,  0, 38, 30, 30, 38, 39,
48562      & 144,0.001D0,  0, 46, 23,  0,  0,  0,
48563      & 144,0.005D0,  0, 46, 38, 30,  0,  0,
48564      & 144,0.001D0,  0, 46, 56,  0,  0,  0,
48565      & 144,0.004D0,  0, 50, 38,  0,  0,  0/
48566       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 514, 532)/
48567      & 144,0.007D0,  0, 51, 38,  0,  0,  0,
48568      & 145,0.900D0,  0,144, 59,  0,  0,  0,
48569      & 145,0.100D0,  0,144, 21,  0,  0,  0,
48570      & 146,0.500D0,  0,137, 50,  0,  0,  0,
48571      & 146,0.500D0,  0,141, 46,  0,  0,  0,
48572      & 147,0.440D0,  0,136, 50,  0,  0,  0,
48573      & 147,0.440D0,  0,140, 46,  0,  0,  0,
48574      & 147,0.055D0,  0,137, 50,  0,  0,  0,
48575      & 147,0.055D0,  0,141, 46,  0,  0,  0,
48576      & 147,0.010D0,  0,144, 22,  0,  0,  0,
48577      & 148,1.000D0,  0,150, 38,  0,  0,  0,
48578      & 149,1.000D0,  0,150, 38,  0,  0,  0,
48579      & 150,0.028D0,101,122,127, 78,  0,  0,
48580      & 150,0.010D0,101,122,127, 80,  0,  0,
48581      & 150,0.028D0,101,124,129, 78,  0,  0,
48582      & 150,0.010D0,101,124,129, 80,  0,  0,
48583      & 150,0.026D0,  0, 73, 42,  0,  0,  0,
48584      & 150,0.030D0,  0, 73, 42, 21,  0,  0,
48585      & 150,0.029D0,  0, 73, 42, 38, 30,  0/
48586       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 533, 551)/
48587      & 150,0.014D0,  0, 73, 42, 22,  0,  0,
48588      & 150,0.020D0,  0, 73, 43,  0,  0,  0,
48589      & 150,0.029D0,  0, 73, 34, 38,  0,  0,
48590      & 150,0.039D0,  0, 73, 34, 38, 21,  0,
48591      & 150,0.002D0,  0, 73, 34, 38, 38, 30,
48592      & 150,0.010D0,  0, 73, 34, 38, 21, 21,
48593      & 150,0.014D0,  0, 73, 35, 38,  0,  0,
48594      & 150,0.010D0,  0, 74, 42,  0,  0,  0,
48595      & 150,0.020D0,  0, 74, 43,  0,  0,  0,
48596      & 150,0.010D0,  0, 74, 43, 21,  0,  0,
48597      & 150,0.007D0,  0, 85, 34,  0,  0,  0,
48598      & 150,0.014D0,  0, 85, 35,  0,  0,  0,
48599      & 150,0.004D0,  0, 73,293,  0,  0,  0,
48600      & 150,0.003D0,  0, 73, 38, 30,  0,  0,
48601      & 150,0.003D0,  0, 73, 38, 30, 38, 30,
48602      & 150,0.001D0,  0, 73, 56,  0,  0,  0,
48603      & 150,0.002D0,  0, 73, 46, 34,  0,  0,
48604      & 150,0.010D0,  0, 78, 38,  0,  0,  0,
48605      & 150,0.020D0,  0, 78, 39,  0,  0,  0/
48606       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 552, 570)/
48607      & 150,0.030D0,  0, 78, 38, 21,  0,  0,
48608      & 150,0.010D0,  0, 78, 38, 22,  0,  0,
48609      & 150,0.020D0,  0, 78, 38, 24,  0,  0,
48610      & 150,0.035D0,  0, 78, 38, 38, 30,  0,
48611      & 150,0.020D0,  0, 78, 38, 21, 21,  0,
48612      & 150,0.010D0,  0, 78, 38, 38, 30, 21,
48613      & 150,0.010D0,  0, 78, 38, 21, 21, 21,
48614      & 150,0.007D0,  0, 78, 46, 42,  0,  0,
48615      & 150,0.011D0,  0, 79, 38,  0,  0,  0,
48616      & 150,0.022D0,  0, 79, 38, 21,  0,  0,
48617      & 150,0.013D0,  0, 79, 38, 38, 30,  0,
48618      & 150,0.010D0,  0, 79, 38, 21, 21,  0,
48619      & 150,0.007D0,  0, 79, 38, 38, 30, 21,
48620      & 150,0.005D0,  0, 79, 38, 21, 21, 21,
48621      & 150,0.005D0,  0, 80, 38,  0,  0,  0,
48622      & 150,0.015D0,  0, 80, 39,  0,  0,  0,
48623      & 150,0.011D0,  0, 86, 21,  0,  0,  0,
48624      & 150,0.007D0,  0, 86, 22,  0,  0,  0,
48625      & 150,0.010D0,  0, 86, 23,  0,  0,  0/
48626       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 571, 589)/
48627      & 150,0.031D0,  0, 86, 24,  0,  0,  0,
48628      & 150,0.010D0,  0, 86, 25,  0,  0,  0,
48629      & 150,0.004D0,  0, 86, 56,  0,  0,  0,
48630      & 150,0.026D0,  0, 86, 38, 30,  0,  0,
48631      & 150,0.005D0,  0, 86, 38, 38, 30, 30,
48632      & 150,0.005D0,  0, 86, 38, 30, 21, 21,
48633      & 150,0.005D0,  0, 87, 21,  0,  0,  0,
48634      & 150,0.006D0,  0, 87, 23,  0,  0,  0,
48635      & 150,0.004D0,  0, 86, 46, 34,  0,  0,
48636      & 150,0.002D0,  0, 86, 46, 30,  0,  0,
48637      & 150,0.001D0,  0, 86, 46, 30, 21,  0,
48638      & 150,0.016D0,  0, 81, 38, 38,  0,  0,
48639      & 150,0.003D0,  0, 88, 46,  0,  0,  0,
48640      & 150,0.002D0,  0, 89, 46,  0,  0,  0,
48641      & 150,0.003D0,  0, 83, 46, 38,  0,  0,
48642      & 150,0.040D0,  0, 75, 46, 21,  0,  0,
48643      & 150,0.040D0,  0, 75, 46, 38, 30,  0,
48644      & 150,0.020D0,  0, 75, 46, 21, 21,  0,
48645      & 150,0.010D0,  0, 75, 46, 38, 30, 21/
48646       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 590, 608)/
48647      & 150,0.010D0,  0, 75, 46, 21, 21, 21,
48648      & 150,0.020D0,  0, 75, 47, 21,  0,  0,
48649      & 150,0.040D0,  0, 75, 42, 38,  0,  0,
48650      & 150,0.020D0,  0, 75, 42, 39,  0,  0,
48651      & 150,0.010D0,  0, 75, 42, 38, 38, 30,
48652      & 150,0.010D0,  0, 75, 42, 38, 21, 21,
48653      & 150,0.006D0,  0, 75, 43, 38,  0,  0,
48654      & 151,1.000D0,  0,150, 21,  0,  0,  0,
48655      & 152,1.000D0,  0,150, 21,  0,  0,  0,
48656      & 153,1.000D0,  0,150, 30,  0,  0,  0,
48657      & 154,1.000D0,  0,150, 30,  0,  0,  0,
48658      & 155,0.045D0,101,122,127, 88,  0,  0,
48659      & 155,0.005D0,101,122,127, 89,  0,  0,
48660      & 155,0.045D0,101,124,129, 88,  0,  0,
48661      & 155,0.005D0,101,124,129, 89,  0,  0,
48662      & 155,0.021D0,  0, 86, 42,  0,  0,  0,
48663      & 155,0.032D0,  0, 87, 42,  0,  0,  0,
48664      & 155,0.032D0,  0, 79, 38, 42,  0,  0,
48665      & 155,0.045D0,  0, 86, 43,  0,  0,  0/
48666       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 609, 627)/
48667      & 155,0.065D0,  0, 87, 43,  0,  0,  0,
48668      & 155,0.065D0,  0, 79, 38, 43,  0,  0,
48669      & 155,0.055D0,  0, 88, 38,  0,  0,  0,
48670      & 155,0.160D0,  0, 88, 39,  0,  0,  0,
48671      & 155,0.105D0,  0, 89, 38,  0,  0,  0,
48672      & 155,0.320D0,  0, 89, 39,  0,  0,  0,
48673      & 156,1.000D0,  0,155, 59,  0,  0,  0,
48674      & 157,0.667D0,  0,158, 38,  0,  0,  0,
48675      & 157,0.333D0,  0,155, 21,  0,  0,  0,
48676      & 158,0.045D0,101,122,127, 83,  0,  0,
48677      & 158,0.045D0,101,124,129, 83,  0,  0,
48678      & 158,0.005D0,101,122,127, 84,  0,  0,
48679      & 158,0.005D0,101,124,129, 84,  0,  0,
48680      & 158,0.020D0,  0, 79, 42,  0,  0,  0,
48681      & 158,0.020D0,  0, 79, 21, 42,  0,  0,
48682      & 158,0.020D0,  0, 80, 42,  0,  0,  0,
48683      & 158,0.060D0,  0, 79, 43,  0,  0,  0,
48684      & 158,0.060D0,  0, 79, 21, 43,  0,  0,
48685      & 158,0.060D0,  0, 80, 43,  0,  0,  0/
48686       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 628, 646)/
48687      & 158,0.020D0,  0, 86, 34,  0,  0,  0,
48688      & 158,0.060D0,  0, 86, 35,  0,  0,  0,
48689      & 158,0.040D0,  0, 87, 34,  0,  0,  0,
48690      & 158,0.120D0,  0, 87, 35,  0,  0,  0,
48691      & 158,0.020D0,  0, 83, 38,  0,  0,  0,
48692      & 158,0.060D0,  0, 83, 39,  0,  0,  0,
48693      & 158,0.040D0,  0, 84, 38,  0,  0,  0,
48694      & 158,0.120D0,  0, 84, 39,  0,  0,  0,
48695      & 158,0.010D0,  0, 88, 21,  0,  0,  0,
48696      & 158,0.030D0,  0, 88, 23,  0,  0,  0,
48697      & 158,0.020D0,  0, 89, 21,  0,  0,  0,
48698      & 158,0.060D0,  0, 89, 23,  0,  0,  0,
48699      & 158,0.030D0,  0, 88, 56,  0,  0,  0,
48700      & 158,0.030D0,  0, 90, 46,  0,  0,  0,
48701      & 159,1.000D0,  0,158, 59,  0,  0,  0,
48702      & 160,0.670D0,  0,155, 30,  0,  0,  0,
48703      & 160,0.330D0,  0,158, 21,  0,  0,  0,
48704      & 161,0.050D0,101,122,127, 90,  0,  0,
48705      & 161,0.050D0,101,124,129, 90,  0,  0/
48706       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 647, 665)/
48707      & 161,0.075D0,  0, 88, 42,  0,  0,  0,
48708      & 161,0.225D0,  0, 88, 43,  0,  0,  0,
48709      & 161,0.150D0,  0, 89, 42,  0,  0,  0,
48710      & 161,0.450D0,  0, 89, 43,  0,  0,  0,
48711      & 162,1.000D0,  0,161, 59,  0,  0,  0,
48712      & 163,0.028D0,  0, 25, 38, 30,  0,  0,
48713      & 163,0.014D0,  0, 25, 21, 21,  0,  0,
48714      & 163,0.018D0,  0, 39, 31,  0,  0,  0,
48715      & 163,0.009D0,  0, 23, 23,  0,  0,  0,
48716      & 163,0.010D0,  0, 51, 34, 38,  0,  0,
48717      & 163,0.010D0,  0, 43, 47, 30,  0,  0,
48718      & 163,0.004D0,  0, 51, 43,  0,  0,  0,
48719      & 163,0.004D0,  0, 47, 35,  0,  0,  0,
48720      & 163,0.007D0,  0, 56, 56,  0,  0,  0,
48721      & 163,0.022D0,  0, 46, 42, 30,  0,  0,
48722      & 163,0.011D0,  0, 46, 34, 21,  0,  0,
48723      & 163,0.011D0,  0, 50, 42, 21,  0,  0,
48724      & 163,0.022D0,  0, 50, 34, 38,  0,  0,
48725      & 163,0.032D0,  0, 22, 38, 30,  0,  0/
48726       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 666, 684)/
48727      & 163,0.016D0,  0, 22, 21, 21,  0,  0,
48728      & 163,0.020D0,  0, 38, 30, 46, 34,  0,
48729      & 163,0.012D0,  0, 38, 30, 38, 30,  0,
48730      & 163,0.001D0,  0, 73, 91,  0,  0,  0,
48731      & 163,0.001D0,  0, 59, 59,  0,  0,  0,
48732      & 163,0.748D0,  0, 13, 13,  0,  0,  0,
48733      & 164,0.060D0,  0,121,127,  0,  0,  0,
48734      & 164,0.060D0,  0,123,129,  0,  0,  0,
48735      & 164,0.004D0,  0, 39, 30,  0,  0,  0,
48736      & 164,0.004D0,  0, 23, 21,  0,  0,  0,
48737      & 164,0.004D0,  0, 31, 38,  0,  0,  0,
48738      & 164,0.003D0,  0, 41, 31,  0,  0,  0,
48739      & 164,0.003D0,  0, 29, 23,  0,  0,  0,
48740      & 164,0.003D0,  0, 33, 39,  0,  0,  0,
48741      & 164,0.009D0,  0, 24, 38, 38, 30, 30,
48742      & 164,0.007D0,  0, 24, 38, 30,  0,  0,
48743      & 164,0.003D0,  0, 51, 45,  0,  0,  0,
48744      & 164,0.003D0,  0, 43, 53,  0,  0,  0,
48745      & 164,0.003D0,  0, 24, 51, 42,  0,  0/
48746       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 685, 703)/
48747      & 164,0.003D0,  0, 24, 43, 50,  0,  0,
48748      & 164,0.004D0,  0, 24, 26,  0,  0,  0,
48749      & 164,0.003D0,  0, 46, 35,  0,  0,  0,
48750      & 164,0.003D0,  0, 34, 47,  0,  0,  0,
48751      & 164,0.002D0,  0, 50, 43,  0,  0,  0,
48752      & 164,0.002D0,  0, 42, 51,  0,  0,  0,
48753      & 164,0.003D0,  0, 24, 21, 21,  0,  0,
48754      & 164,0.002D0,  0,286, 30,  0,  0,  0,
48755      & 164,0.002D0,  0,287, 38,  0,  0,  0,
48756      & 164,0.003D0,  0, 24, 46, 42, 30,  0,
48757      & 164,0.003D0,  0, 24, 34, 50, 38,  0,
48758      & 164,0.002D0,  0,285, 21,  0,  0,  0,
48759      & 164,0.001D0,  0, 56, 51, 42,  0,  0,
48760      & 164,0.001D0,  0, 56, 43, 50,  0,  0,
48761      & 164,0.001D0,  0, 24, 50, 42,  0,  0,
48762      & 164,0.001D0,  0, 24, 46, 34,  0,  0,
48763      & 164,0.002D0,  0, 56, 38, 30, 38, 30,
48764      & 164,0.002D0,  0, 85, 91, 30,  0,  0,
48765      & 164,0.002D0,  0,103, 73, 38,  0,  0/
48766       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 704, 722)/
48767      & 164,0.002D0,  0, 24, 22,  0,  0,  0,
48768      & 164,0.001D0,  0, 56, 50, 42,  0,  0,
48769      & 164,0.001D0,  0, 56, 46, 34,  0,  0,
48770      & 164,0.001D0,  0, 73, 91, 24,  0,  0,
48771      & 164,0.001D0,  0, 85,103,  0,  0,  0,
48772      & 164,0.001D0,  0, 82,100,  0,  0,  0,
48773      & 164,0.001D0,  0, 87,105,  0,  0,  0,
48774      & 164,0.001D0,  0, 73, 91, 25,  0,  0,
48775      & 164,0.001D0,  0, 56, 58,  0,  0,  0,
48776      & 164,0.001D0,  0, 56, 38, 30,  0,  0,
48777      & 164,0.001D0,  0, 56, 46, 42, 30,  0,
48778      & 164,0.001D0,  0, 56, 34, 50, 38,  0,
48779      & 164,0.001D0,  0, 56, 22,  0,  0,  0,
48780      & 164,0.001D0,  0, 84,102,  0,  0,  0,
48781      & 164,0.001D0,  0, 73, 34, 98,  0,  0,
48782      & 164,0.001D0,  0, 91, 46, 80,  0,  0,
48783      & 164,0.034D0,  0, 38, 38, 30, 30, 21,
48784      & 164,0.029D0,  0, 23, 23, 23, 21,  0,
48785      & 164,0.015D0,  0, 38, 30, 21,  0,  0/
48786       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 723, 741)/
48787      & 164,0.012D0,  0, 38, 30, 21, 34, 46,
48788      & 164,0.009D0,  0, 23, 23, 23, 24,  0,
48789      & 164,0.007D0,  0, 38, 30, 34, 46,  0,
48790      & 164,0.002D0,  0, 46, 42, 30,  0,  0,
48791      & 164,0.001D0,  0, 46, 34, 21,  0,  0,
48792      & 164,0.001D0,  0, 50, 42, 21,  0,  0,
48793      & 164,0.002D0,  0, 50, 34, 38,  0,  0,
48794      & 164,0.006D0,  0, 73, 91, 38, 30,  0,
48795      & 164,0.004D0,  0, 38, 30, 38, 30,  0,
48796      & 164,0.004D0,  0, 38, 30, 38, 30, 23,
48797      & 164,0.004D0,  0, 75, 93, 38, 30,  0,
48798      & 164,0.001D0,  0, 86,104,  0,  0,  0,
48799      & 164,0.001D0,  0, 79, 97,  0,  0,  0,
48800      & 164,0.001D0,  0, 81, 99,  0,  0,  0,
48801      & 164,0.003D0,  0, 23, 23, 34, 46,  0,
48802      & 164,0.002D0,  0, 73, 91, 38, 30, 21,
48803      & 164,0.002D0,  0, 73, 91,  0,  0,  0,
48804      & 164,0.002D0,  0, 73, 91, 22,  0,  0,
48805      & 164,0.002D0,  0, 73, 93, 30,  0,  0/
48806       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 742, 760)/
48807      & 164,0.002D0,  0, 75, 93,  0,  0,  0,
48808      & 164,0.001D0,  0, 83,102,  0,  0,  0,
48809      & 164,0.001D0,  0, 88,106,  0,  0,  0,
48810      & 164,0.001D0,  0, 78, 96,  0,  0,  0,
48811      & 164,0.001D0,  0, 73, 91, 21,  0,  0,
48812      & 164,0.001D0,  0, 78,104, 38,  0,  0,
48813      & 164,0.001D0,  0, 96, 86, 30,  0,  0,
48814      & 164,0.001D0,  0, 73, 34, 96,  0,  0,
48815      & 164,0.001D0,  0, 91, 46, 78,  0,  0,
48816      & 164,0.001D0,  0, 46, 34, 46, 34,  0,
48817      & 164,0.013D0,  0, 59,163,  0,  0,  0,
48818      & 164,0.008D0,  0, 59, 38, 30, 21, 21,
48819      & 164,0.004D0,  0, 59, 22, 38, 30,  0,
48820      & 164,0.002D0,  0, 59, 22, 21, 21,  0,
48821      & 164,0.003D0,  0, 59, 39, 31,  0,  0,
48822      & 164,0.002D0,  0, 59, 23, 23,  0,  0,
48823      & 164,0.004D0,  0, 59, 25,  0,  0,  0,
48824      & 164,0.003D0,  0, 59, 38, 30, 38, 30,
48825      & 164,0.002D0,  0, 59, 24, 24,  0,  0/
48826       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 761, 779)/
48827      & 164,0.001D0,  0, 59, 26,  0,  0,  0,
48828      & 164,0.001D0,  0, 59, 22,  0,  0,  0,
48829      & 164,0.001D0,  0, 59, 28,  0,  0,  0,
48830      & 164,0.001D0,  0, 59, 58,  0,  0,  0,
48831      & 164,0.020D0,  0,  1,  7,  0,  0,  0,
48832      & 164,0.080D0,  0,  2,  8,  0,  0,  0,
48833      & 164,0.020D0,  0,  3,  9,  0,  0,  0,
48834      & 164,0.364D0,130, 13, 13, 13,  0,  0,
48835      & 164,0.091D0,130, 13, 13, 59,  0,  0,
48836      & 165,0.037D0,  0, 38, 30, 38, 30,  0,
48837      & 165,0.030D0,  0, 38, 30, 46, 34,  0,
48838      & 165,0.016D0,  0, 23, 38, 30,  0,  0,
48839      & 165,0.015D0,  0, 23, 38, 30, 38, 30,
48840      & 165,0.004D0,  0, 46, 43, 30,  0,  0,
48841      & 165,0.002D0,  0, 46, 35, 21,  0,  0,
48842      & 165,0.002D0,  0, 51, 43, 21,  0,  0,
48843      & 165,0.004D0,  0, 51, 35, 38,  0,  0,
48844      & 165,0.008D0,  0, 38, 30,  0,  0,  0,
48845      & 165,0.007D0,  0, 46, 34,  0,  0,  0/
48846       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 780, 798)/
48847      & 165,0.005D0,  0, 38, 30, 73, 91,  0,
48848      & 165,0.003D0,  0, 21, 21,  0,  0,  0,
48849      & 165,0.003D0,  0, 22, 22,  0,  0,  0,
48850      & 165,0.007D0,  0, 59,164,  0,  0,  0,
48851      & 165,0.857D0,  0, 13, 13,  0,  0,  0,
48852      & 166,0.008D0,  0,121,127,  0,  0,  0,
48853      & 166,0.008D0,  0,123,129,  0,  0,  0,
48854      & 166,0.001D0,  0,125,131,  0,  0,  0,
48855      & 166,0.338D0,  0,164, 38, 30,  0,  0,
48856      & 166,0.169D0,  0,164, 21, 21,  0,  0,
48857      & 166,0.027D0,  0,164, 22,  0,  0,  0,
48858      & 166,0.001D0,  0,164, 21,  0,  0,  0,
48859      & 166,0.004D0,  0, 23, 23, 23, 21,  0,
48860      & 166,0.003D0,  0, 23, 23, 21,  0,  0,
48861      & 166,0.002D0,  0, 38, 30, 46, 34,  0,
48862      & 166,0.001D0,  0, 38, 30, 73, 91,  0,
48863      & 166,0.093D0,  0, 59,165,  0,  0,  0,
48864      & 166,0.087D0,  0, 59,302,  0,  0,  0,
48865      & 166,0.078D0,  0, 59,303,  0,  0,  0/
48866       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 799, 817)/
48867      & 166,0.003D0,  0, 59,163,  0,  0,  0,
48868      & 166,0.003D0,  0,  1,  7,  0,  0,  0,
48869      & 166,0.012D0,  0,  2,  8,  0,  0,  0,
48870      & 166,0.003D0,  0,  3,  9,  0,  0,  0,
48871      & 166,0.127D0,130, 13, 13, 13,  0,  0,
48872      & 166,0.032D0,130, 13, 13, 59,  0,  0,
48873      & 167,0.500D0,  0,136,171,  0,  0,  0,
48874      & 167,0.500D0,  0,140,175,  0,  0,  0,
48875      & 171,0.067D0,101,128,121, 50,  0,  0,
48876      & 171,0.067D0,101,130,123, 50,  0,  0,
48877      & 171,0.048D0,101,128,121, 51,  0,  0,
48878      & 171,0.048D0,101,130,123, 51,  0,  0,
48879      & 171,0.003D0,  0,128,121, 46, 30,  0,
48880      & 171,0.003D0,  0,130,123, 46, 30,  0,
48881      & 171,0.006D0,101,128,121, 21,  0,  0,
48882      & 171,0.006D0,101,130,123, 21,  0,  0,
48883      & 171,0.002D0,101,128,121, 23,  0,  0,
48884      & 171,0.002D0,101,130,123, 23,  0,  0,
48885      & 171,0.055D0,  0, 46, 30, 30,  0,  0/
48886       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 818, 836)/
48887      & 171,0.031D0,  0, 46, 31, 30,  0,  0,
48888      & 171,0.042D0,  0, 46, 30, 30, 21, 21,
48889      & 171,0.002D0,  0, 46, 30, 30, 30, 39,
48890      & 171,0.021D0,  0, 47, 30, 30,  0,  0,
48891      & 171,0.027D0,  0, 50, 30,  0,  0,  0,
48892      & 171,0.066D0,  0, 50, 31,  0,  0,  0,
48893      & 171,0.081D0,  0, 50, 32,  0,  0,  0,
48894      & 171,0.024D0,  0, 50, 30, 21,  0,  0,
48895      & 171,0.004D0,  0, 50, 30, 23,  0,  0,
48896      & 171,0.069D0,  0, 50, 30, 30, 38, 21,
48897      & 171,0.001D0,  0, 50, 30, 30, 38, 23,
48898      & 171,0.022D0,  0, 51, 30,  0,  0,  0,
48899      & 171,0.021D0,  0, 51, 31,  0,  0,  0,
48900      & 171,0.042D0,  0, 51, 30, 21,  0,  0,
48901      & 171,0.008D0,  0, 51, 30, 23,  0,  0,
48902      & 171,0.010D0,  0, 51, 30, 30, 38,  0,
48903      & 171,0.050D0,  0,309, 30,  0,  0,  0,
48904      & 171,0.034D0,  0,328, 30,  0,  0,  0,
48905      & 171,0.010D0,  0,368, 30,  0,  0,  0/
48906       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 837, 855)/
48907      & 171,0.031D0,  0, 34, 50, 50,  0,  0,
48908      & 171,0.003D0,  0, 30, 21,  0,  0,  0,
48909      & 171,0.001D0,  0, 30, 23,  0,  0,  0,
48910      & 171,0.002D0,  0, 30, 30, 38,  0,  0,
48911      & 171,0.008D0,  0, 30, 22,  0,  0,  0,
48912      & 171,0.001D0,  0, 30, 30, 30, 38, 38,
48913      & 171,0.003D0,  0, 30, 30, 30, 38, 39,
48914      & 171,0.008D0,  0, 34, 50,  0,  0,  0,
48915      & 171,0.005D0,  0, 34, 51,  0,  0,  0,
48916      & 171,0.026D0,  0, 35, 51,  0,  0,  0,
48917      & 171,0.005D0,  0, 34, 46, 30,  0,  0,
48918      & 171,0.007D0,  0, 30, 56,  0,  0,  0,
48919      & 171,0.023D0,  0, 30, 56, 21,  0,  0,
48920      & 171,0.005D0,  0, 34, 34, 46,  0,  0,
48921      & 172,0.683D0,  0,175, 30,  0,  0,  0,
48922      & 172,0.306D0,  0,171, 21,  0,  0,  0,
48923      & 172,0.011D0,  0,171, 59,  0,  0,  0,
48924      & 173,0.667D0,  0,176, 30,  0,  0,  0,
48925      & 173,0.333D0,  0,172, 21,  0,  0,  0/
48926       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 856, 874)/
48927      & 174,0.220D0,  0,175, 30,  0,  0,  0,
48928      & 174,0.110D0,  0,171, 21,  0,  0,  0,
48929      & 174,0.380D0,  0,176, 30,  0,  0,  0,
48930      & 174,0.190D0,  0,172, 21,  0,  0,  0,
48931      & 174,0.004D0,  0,171, 22,  0,  0,  0,
48932      & 174,0.064D0,  0,176, 30, 21,  0,  0,
48933      & 174,0.032D0,  0,172, 38, 30,  0,  0,
48934      & 175,0.037D0,101,128,121, 46,  0,  0,
48935      & 175,0.037D0,101,130,123, 46,  0,  0,
48936      & 175,0.016D0,101,128,121, 47,  0,  0,
48937      & 175,0.016D0,101,130,123, 47,  0,  0,
48938      & 175,0.013D0,  0,128,121, 46, 21,  0,
48939      & 175,0.013D0,  0,130,123, 46, 21,  0,
48940      & 175,0.012D0,  0,128,121, 50, 38,  0,
48941      & 175,0.012D0,  0,130,123, 50, 38,  0,
48942      & 175,0.003D0,101,128,121, 38,  0,  0,
48943      & 175,0.003D0,101,130,123, 38,  0,  0,
48944      & 175,0.039D0,  0, 46, 30,  0,  0,  0,
48945      & 175,0.091D0,  0, 46, 31,  0,  0,  0/
48946       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 875, 893)/
48947      & 175,0.067D0,  0, 46, 32,  0,  0,  0,
48948      & 175,0.004D0,  0, 46, 30, 21,  0,  0,
48949      & 175,0.100D0,  0, 46, 30, 21, 21,  0,
48950      & 175,0.058D0,  0, 46, 30, 23,  0,  0,
48951      & 175,0.020D0,  0, 46, 30, 24,  0,  0,
48952      & 175,0.006D0,  0, 46, 30, 25,  0,  0,
48953      & 175,0.043D0,  0, 47, 30,  0,  0,  0,
48954      & 175,0.035D0,  0, 47, 31,  0,  0,  0,
48955      & 175,0.007D0,  0,310, 30,  0,  0,  0,
48956      & 175,0.007D0,  0,327, 30,  0,  0,  0,
48957      & 175,0.020D0,  0, 50, 21,  0,  0,  0,
48958      & 175,0.006D0,  0, 50, 22,  0,  0,  0,
48959      & 175,0.009D0,  0, 50, 23,  0,  0,  0,
48960      & 175,0.016D0,  0, 50, 24,  0,  0,  0,
48961      & 175,0.014D0,  0, 50, 25,  0,  0,  0,
48962      & 175,0.003D0,  0, 50,293,  0,  0,  0,
48963      & 175,0.007D0,  0, 50, 56,  0,  0,  0,
48964      & 175,0.003D0,  0, 50, 26,  0,  0,  0,
48965      & 175,0.004D0,  0, 50,294,  0,  0,  0/
48966       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 894, 912)/
48967      & 175,0.006D0,  0, 50, 21, 21,  0,  0,
48968      & 175,0.042D0,  0, 50, 30, 38, 21,  0,
48969      & 175,0.004D0,  0, 50, 30, 30, 38, 38,
48970      & 175,0.076D0,  0, 50, 30, 38, 21, 21,
48971      & 175,0.026D0,  0, 51, 21,  0,  0,  0,
48972      & 175,0.014D0,  0, 51, 22,  0,  0,  0,
48973      & 175,0.014D0,  0, 51, 23,  0,  0,  0,
48974      & 175,0.011D0,  0, 51, 24,  0,  0,  0,
48975      & 175,0.018D0,  0, 51, 30, 38,  0,  0,
48976      & 175,0.004D0,  0, 50, 34, 46,  0,  0,
48977      & 175,0.004D0,  0, 50, 34, 46, 21,  0,
48978      & 175,0.005D0,  0, 50, 50, 42,  0,  0,
48979      & 175,0.002D0,  0, 30, 38,  0,  0,  0,
48980      & 175,0.001D0,  0, 21, 21,  0,  0,  0,
48981      & 175,0.008D0,  0, 30, 38, 21,  0,  0,
48982      & 175,0.007D0,  0, 30, 30, 38, 38,  0,
48983      & 175,0.015D0,  0, 30, 30, 38, 38, 21,
48984      & 175,0.004D0,  0, 34, 46,  0,  0,  0,
48985      & 175,0.003D0,  0, 35, 46,  0,  0,  0/
48986       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 913, 931)/
48987      & 175,0.002D0,  0, 34, 47,  0,  0,  0,
48988      & 175,0.001D0,  0, 42, 50,  0,  0,  0,
48989      & 175,0.002D0,  0, 43, 51,  0,  0,  0,
48990      & 175,0.003D0,  0, 42, 46, 30,  0,  0,
48991      & 175,0.003D0,  0, 50, 34, 38,  0,  0,
48992      & 175,0.001D0,  0, 34, 46, 30, 38, 21,
48993      & 175,0.002D0,  0, 56, 23,  0,  0,  0,
48994      & 175,0.001D0,  0, 56, 30, 38,  0,  0,
48995      & 176,0.636D0,  0,175, 21,  0,  0,  0,
48996      & 176,0.364D0,  0,175, 59,  0,  0,  0,
48997      & 177,0.667D0,  0,172, 38,  0,  0,  0,
48998      & 177,0.333D0,  0,176, 21,  0,  0,  0,
48999      & 178,0.220D0,  0,171, 38,  0,  0,  0,
49000      & 178,0.110D0,  0,175, 21,  0,  0,  0,
49001      & 178,0.380D0,  0,172, 38,  0,  0,  0,
49002      & 178,0.190D0,  0,176, 21,  0,  0,  0,
49003      & 178,0.004D0,  0,175, 22,  0,  0,  0,
49004      & 178,0.064D0,  0,172, 38, 21,  0,  0,
49005      & 178,0.032D0,  0,176, 38, 30,  0,  0/
49006       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 932, 950)/
49007      & 179,0.009D0,  0,130,123,  0,  0,  0,
49008      & 179,0.019D0,101,128,121, 56,  0,  0,
49009      & 179,0.019D0,101,130,123, 56,  0,  0,
49010      & 179,0.025D0,101,128,121, 22,  0,  0,
49011      & 179,0.025D0,101,130,123, 22,  0,  0,
49012      & 179,0.009D0,101,128,121, 25,  0,  0,
49013      & 179,0.009D0,101,130,123, 25,  0,  0,
49014      & 179,0.036D0,  0, 34, 50,  0,  0,  0,
49015      & 179,0.034D0,  0, 34, 51,  0,  0,  0,
49016      & 179,0.007D0,  0, 34,328,  0,  0,  0,
49017      & 179,0.043D0,  0, 35, 50,  0,  0,  0,
49018      & 179,0.058D0,  0, 35, 51,  0,  0,  0,
49019      & 179,0.011D0,  0, 34, 46, 30,  0,  0,
49020      & 179,0.055D0,  0, 34, 46, 30, 21,  0,
49021      & 179,0.003D0,  0, 34, 46, 30, 38, 30,
49022      & 179,0.014D0,  0, 34, 50, 38, 30,  0,
49023      & 179,0.017D0,  0, 42, 46, 30, 30,  0,
49024      & 179,0.036D0,  0, 56, 30,  0,  0,  0,
49025      & 179,0.067D0,  0, 56, 31,  0,  0,  0/
49026       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 951, 969)/
49027      & 179,0.023D0,  0, 56, 30, 21,  0,  0,
49028      & 179,0.018D0,  0, 56, 30, 38, 30,  0,
49029      & 179,0.020D0,  0, 22, 30,  0,  0,  0,
49030      & 179,0.001D0,  0, 23, 30,  0,  0,  0,
49031      & 179,0.009D0,  0, 24, 30,  0,  0,  0,
49032      & 179,0.049D0,  0, 25, 30,  0,  0,  0,
49033      & 179,0.011D0,  0,293, 30,  0,  0,  0,
49034      & 179,0.015D0,  0, 22, 30, 21,  0,  0,
49035      & 179,0.016D0,  0, 25, 30, 21,  0,  0,
49036      & 179,0.103D0,  0, 22, 31,  0,  0,  0,
49037      & 179,0.120D0,  0, 25, 31,  0,  0,  0,
49038      & 179,0.010D0,  0, 30, 38, 30,  0,  0,
49039      & 179,0.046D0,  0, 30, 38, 30, 21,  0,
49040      & 179,0.003D0,  0, 30, 38, 38, 30, 30,
49041      & 179,0.042D0,  0, 30, 38, 38, 30, 31,
49042      & 179,0.001D0,  0, 34, 23,  0,  0,  0,
49043      & 179,0.005D0,  0, 34, 38, 30,  0,  0,
49044      & 179,0.001D0,  0, 34, 56,  0,  0,  0,
49045      & 179,0.004D0,  0, 42, 30,  0,  0,  0/
49046       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 970, 988)/
49047      & 179,0.007D0,  0, 43, 30,  0,  0,  0,
49048      & 180,0.900D0,  0,179, 59,  0,  0,  0,
49049      & 180,0.100D0,  0,179, 21,  0,  0,  0,
49050      & 181,0.500D0,  0,172, 42,  0,  0,  0,
49051      & 181,0.500D0,  0,176, 34,  0,  0,  0,
49052      & 182,0.440D0,  0,171, 42,  0,  0,  0,
49053      & 182,0.440D0,  0,175, 34,  0,  0,  0,
49054      & 182,0.055D0,  0,172, 42,  0,  0,  0,
49055      & 182,0.055D0,  0,176, 34,  0,  0,  0,
49056      & 182,0.010D0,  0,179, 22,  0,  0,  0,
49057      & 183,1.000D0,  0,185, 30,  0,  0,  0,
49058      & 184,1.000D0,  0,185, 30,  0,  0,  0,
49059      & 185,0.028D0,101,128,121, 96,  0,  0,
49060      & 185,0.010D0,101,128,121, 98,  0,  0,
49061      & 185,0.028D0,101,130,123, 96,  0,  0,
49062      & 185,0.010D0,101,130,123, 98,  0,  0,
49063      & 185,0.026D0,  0, 91, 50,  0,  0,  0,
49064      & 185,0.030D0,  0, 91, 50, 21,  0,  0,
49065      & 185,0.029D0,  0, 91, 50, 38, 30,  0/
49066       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 989,1007)/
49067      & 185,0.014D0,  0, 91, 50, 22,  0,  0,
49068      & 185,0.020D0,  0, 91, 51,  0,  0,  0,
49069      & 185,0.029D0,  0, 91, 46, 30,  0,  0,
49070      & 185,0.039D0,  0, 91, 46, 30, 21,  0,
49071      & 185,0.002D0,  0, 91, 46, 30, 30, 38,
49072      & 185,0.010D0,  0, 91, 46, 30, 21, 21,
49073      & 185,0.014D0,  0, 91, 47, 30,  0,  0,
49074      & 185,0.010D0,  0, 92, 50,  0,  0,  0,
49075      & 185,0.020D0,  0, 92, 51,  0,  0,  0,
49076      & 185,0.010D0,  0, 92, 51, 21,  0,  0,
49077      & 185,0.007D0,  0,103, 46,  0,  0,  0,
49078      & 185,0.014D0,  0,103, 47,  0,  0,  0,
49079      & 185,0.004D0,  0, 91,293,  0,  0,  0,
49080      & 185,0.003D0,  0, 91, 38, 30,  0,  0,
49081      & 185,0.003D0,  0, 91, 38, 30, 38, 30,
49082      & 185,0.001D0,  0, 91, 56,  0,  0,  0,
49083      & 185,0.002D0,  0, 91, 46, 34,  0,  0,
49084      & 185,0.010D0,  0, 96, 30,  0,  0,  0,
49085      & 185,0.020D0,  0, 96, 31,  0,  0,  0/
49086       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1008,1026)/
49087      & 185,0.030D0,  0, 96, 30, 21,  0,  0,
49088      & 185,0.010D0,  0, 96, 30, 22,  0,  0,
49089      & 185,0.020D0,  0, 96, 30, 24,  0,  0,
49090      & 185,0.035D0,  0, 96, 30, 30, 38,  0,
49091      & 185,0.020D0,  0, 96, 30, 21, 21,  0,
49092      & 185,0.010D0,  0, 96, 30, 38, 30, 21,
49093      & 185,0.010D0,  0, 96, 30, 21, 21, 21,
49094      & 185,0.007D0,  0, 96, 34, 50,  0,  0,
49095      & 185,0.011D0,  0, 97, 30,  0,  0,  0,
49096      & 185,0.022D0,  0, 97, 30, 21,  0,  0,
49097      & 185,0.013D0,  0, 97, 30, 38, 30,  0,
49098      & 185,0.010D0,  0, 97, 30, 21, 21,  0,
49099      & 185,0.007D0,  0, 97, 30, 38, 30, 21,
49100      & 185,0.005D0,  0, 97, 30, 21, 21, 21,
49101      & 185,0.005D0,  0, 98, 30,  0,  0,  0,
49102      & 185,0.015D0,  0, 98, 31,  0,  0,  0,
49103      & 185,0.011D0,  0,104, 21,  0,  0,  0,
49104      & 185,0.007D0,  0,104, 22,  0,  0,  0,
49105      & 185,0.010D0,  0,104, 23,  0,  0,  0/
49106       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1027,1045)/
49107      & 185,0.031D0,  0,104, 24,  0,  0,  0,
49108      & 185,0.010D0,  0,104, 25,  0,  0,  0,
49109      & 185,0.004D0,  0,104, 56,  0,  0,  0,
49110      & 185,0.026D0,  0,104, 38, 30,  0,  0,
49111      & 185,0.005D0,  0,104, 38, 38, 30, 30,
49112      & 185,0.005D0,  0,104, 38, 30, 21, 21,
49113      & 185,0.005D0,  0,105, 21,  0,  0,  0,
49114      & 185,0.006D0,  0,105, 23,  0,  0,  0,
49115      & 185,0.004D0,  0,104, 46, 34,  0,  0,
49116      & 185,0.002D0,  0,104, 34, 38,  0,  0,
49117      & 185,0.001D0,  0,104, 34, 38, 21,  0,
49118      & 185,0.016D0,  0, 99, 30, 30,  0,  0,
49119      & 185,0.003D0,  0,106, 34,  0,  0,  0,
49120      & 185,0.002D0,  0,107, 34,  0,  0,  0,
49121      & 185,0.003D0,  0,101, 34, 30,  0,  0,
49122      & 185,0.040D0,  0, 93, 34, 21,  0,  0,
49123      & 185,0.040D0,  0, 93, 34, 38, 30,  0,
49124      & 185,0.020D0,  0, 93, 34, 21, 21,  0,
49125      & 185,0.010D0,  0, 93, 34, 38, 30, 21/
49126       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1046,1064)/
49127      & 185,0.010D0,  0, 93, 34, 21, 21, 21,
49128      & 185,0.020D0,  0, 93, 35, 21,  0,  0,
49129      & 185,0.040D0,  0, 93, 50, 30,  0,  0,
49130      & 185,0.020D0,  0, 93, 50, 31,  0,  0,
49131      & 185,0.010D0,  0, 93, 50, 30, 38, 30,
49132      & 185,0.010D0,  0, 93, 50, 30, 21, 21,
49133      & 185,0.006D0,  0, 93, 51, 30,  0,  0,
49134      & 186,1.000D0,  0,185, 21,  0,  0,  0,
49135      & 187,1.000D0,  0,185, 21,  0,  0,  0,
49136      & 188,1.000D0,  0,185, 38,  0,  0,  0,
49137      & 189,1.000D0,  0,185, 38,  0,  0,  0,
49138      & 190,0.045D0,101,128,121,106,  0,  0,
49139      & 190,0.005D0,101,128,121,107,  0,  0,
49140      & 190,0.045D0,101,130,123,106,  0,  0,
49141      & 190,0.005D0,101,130,123,107,  0,  0,
49142      & 190,0.021D0,  0,104, 50,  0,  0,  0,
49143      & 190,0.032D0,  0,105, 50,  0,  0,  0,
49144      & 190,0.032D0,  0, 97, 30, 50,  0,  0,
49145      & 190,0.045D0,  0,104, 51,  0,  0,  0/
49146       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1065,1083)/
49147      & 190,0.065D0,  0,105, 51,  0,  0,  0,
49148      & 190,0.065D0,  0, 97, 30, 51,  0,  0,
49149      & 190,0.055D0,  0,106, 30,  0,  0,  0,
49150      & 190,0.160D0,  0,106, 31,  0,  0,  0,
49151      & 190,0.105D0,  0,107, 30,  0,  0,  0,
49152      & 190,0.320D0,  0,107, 31,  0,  0,  0,
49153      & 191,1.000D0,  0,190, 59,  0,  0,  0,
49154      & 192,0.667D0,  0,193, 30,  0,  0,  0,
49155      & 192,0.333D0,  0,190, 21,  0,  0,  0,
49156      & 193,0.045D0,101,128,121,101,  0,  0,
49157      & 193,0.045D0,101,130,123,101,  0,  0,
49158      & 193,0.005D0,101,128,121,102,  0,  0,
49159      & 193,0.005D0,101,130,123,102,  0,  0,
49160      & 193,0.020D0,  0, 97, 50,  0,  0,  0,
49161      & 193,0.020D0,  0, 97, 21, 50,  0,  0,
49162      & 193,0.020D0,  0, 98, 50,  0,  0,  0,
49163      & 193,0.060D0,  0, 97, 51,  0,  0,  0,
49164      & 193,0.060D0,  0, 97, 21, 51,  0,  0,
49165      & 193,0.060D0,  0, 98, 51,  0,  0,  0/
49166       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1084,1102)/
49167      & 193,0.020D0,  0,104, 46,  0,  0,  0,
49168      & 193,0.060D0,  0,104, 47,  0,  0,  0,
49169      & 193,0.040D0,  0,105, 46,  0,  0,  0,
49170      & 193,0.120D0,  0,105, 47,  0,  0,  0,
49171      & 193,0.020D0,  0,101, 30,  0,  0,  0,
49172      & 193,0.060D0,  0,101, 31,  0,  0,  0,
49173      & 193,0.040D0,  0,102, 30,  0,  0,  0,
49174      & 193,0.120D0,  0,102, 31,  0,  0,  0,
49175      & 193,0.010D0,  0,106, 21,  0,  0,  0,
49176      & 193,0.030D0,  0,106, 23,  0,  0,  0,
49177      & 193,0.020D0,  0,107, 21,  0,  0,  0,
49178      & 193,0.060D0,  0,107, 23,  0,  0,  0,
49179      & 193,0.030D0,  0,106, 56,  0,  0,  0,
49180      & 193,0.030D0,  0,108, 34,  0,  0,  0,
49181      & 194,1.000D0,  0,193, 59,  0,  0,  0,
49182      & 195,0.670D0,  0,190, 38,  0,  0,  0,
49183      & 195,0.330D0,  0,193, 21,  0,  0,  0,
49184      & 196,0.050D0,101,128,121,108,  0,  0,
49185      & 196,0.050D0,101,130,123,108,  0,  0/
49186       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1103,1121)/
49187      & 196,0.075D0,  0,106, 50,  0,  0,  0,
49188      & 196,0.225D0,  0,106, 51,  0,  0,  0,
49189      & 196,0.150D0,  0,107, 50,  0,  0,  0,
49190      & 196,0.450D0,  0,107, 51,  0,  0,  0,
49191      & 197,1.000D0,  0,196, 59,  0,  0,  0,
49192      & 209,0.250D0,100,  1,  8,  4,  0,  0,
49193      & 209,0.250D0,100,  3, 10,  4,  0,  0,
49194      & 209,0.250D0,100,  5, 12,  4,  0,  0,
49195      & 209,0.085D0,100,121,128,  4,  0,  0,
49196      & 209,0.085D0,100,123,130,  4,  0,  0,
49197      & 209,0.080D0,100,125,132,  4,  0,  0,
49198      & 210,0.250D0,100,  2,  7,209,  0,  0,
49199      & 210,0.250D0,100,  4,  9,209,  0,  0,
49200      & 210,0.250D0,100,  6, 11,209,  0,  0,
49201      & 210,0.085D0,100,122,127,209,  0,  0,
49202      & 210,0.085D0,100,124,129,209,  0,  0,
49203      & 210,0.080D0,100,126,131,209,  0,  0,
49204      & 211,0.250D0,100,  1,  8,  6,  0,  0,
49205      & 211,0.250D0,100,  3, 10,  6,  0,  0/
49206       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1122,1140)/
49207      & 211,0.250D0,100,  5, 12,  6,  0,  0,
49208      & 211,0.085D0,100,121,128,  6,  0,  0,
49209      & 211,0.085D0,100,123,130,  6,  0,  0,
49210      & 211,0.080D0,100,125,132,  6,  0,  0,
49211      & 212,0.250D0,100,  2,  7,211,  0,  0,
49212      & 212,0.250D0,100,  4,  9,211,  0,  0,
49213      & 212,0.250D0,100,  6, 11,211,  0,  0,
49214      & 212,0.085D0,100,122,127,211,  0,  0,
49215      & 212,0.085D0,100,124,129,211,  0,  0,
49216      & 212,0.080D0,100,126,131,211,  0,  0,
49217      & 215,0.250D0,100,  7,  2, 10,  0,  0,
49218      & 215,0.250D0,100,  9,  4, 10,  0,  0,
49219      & 215,0.250D0,100, 11,  6, 10,  0,  0,
49220      & 215,0.085D0,100,127,122, 10,  0,  0,
49221      & 215,0.085D0,100,129,124, 10,  0,  0,
49222      & 215,0.080D0,100,131,126, 10,  0,  0,
49223      & 216,0.250D0,100,  8,  1,215,  0,  0,
49224      & 216,0.250D0,100, 10,  3,215,  0,  0,
49225      & 216,0.250D0,100, 12,  5,215,  0,  0/
49226       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1141,1159)/
49227      & 216,0.085D0,100,128,121,215,  0,  0,
49228      & 216,0.085D0,100,130,123,215,  0,  0,
49229      & 216,0.080D0,100,132,125,215,  0,  0,
49230      & 217,0.250D0,100,  7,  2, 12,  0,  0,
49231      & 217,0.250D0,100,  9,  4, 12,  0,  0,
49232      & 217,0.250D0,100, 11,  6, 12,  0,  0,
49233      & 217,0.085D0,100,127,122, 12,  0,  0,
49234      & 217,0.085D0,100,129,124, 12,  0,  0,
49235      & 217,0.080D0,100,131,126, 12,  0,  0,
49236      & 218,0.250D0,100,  8,  1,217,  0,  0,
49237      & 218,0.250D0,100, 10,  3,217,  0,  0,
49238      & 218,0.250D0,100, 12,  5,217,  0,  0,
49239      & 218,0.085D0,100,128,121,217,  0,  0,
49240      & 218,0.085D0,100,130,123,217,  0,  0,
49241      & 218,0.080D0,100,132,125,217,  0,  0,
49242      & 221,0.016D0,101,121,128,136,  0,  0,
49243      & 221,0.016D0,101,123,130,136,  0,  0,
49244      & 221,0.008D0,101,125,132,136,  0,  0,
49245      & 221,0.048D0,101,121,128,137,  0,  0/
49246       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1160,1178)/
49247      & 221,0.048D0,101,123,130,137,  0,  0,
49248      & 221,0.022D0,101,125,132,137,  0,  0,
49249      & 221,0.003D0,101,121,128,331,  0,  0,
49250      & 221,0.003D0,101,123,130,331,  0,  0,
49251      & 221,0.001D0,101,125,132,331,  0,  0,
49252      & 221,0.008D0,101,121,128,138,  0,  0,
49253      & 221,0.008D0,101,123,130,138,  0,  0,
49254      & 221,0.004D0,101,125,132,138,  0,  0,
49255      & 221,0.008D0,101,121,128,313,  0,  0,
49256      & 221,0.008D0,101,123,130,313,  0,  0,
49257      & 221,0.004D0,101,125,132,313,  0,  0,
49258      & 221,0.013D0,101,121,128,139,  0,  0,
49259      & 221,0.013D0,101,123,130,139,  0,  0,
49260      & 221,0.006D0,101,125,132,139,  0,  0,
49261      & 221,0.004D0,  0,136, 30,  0,  0,  0,
49262      & 221,0.010D0,  0,136, 31,  0,  0,  0,
49263      & 221,0.006D0,  0,136, 32,  0,  0,  0,
49264      & 221,0.003D0,  0,137, 30,  0,  0,  0,
49265      & 221,0.009D0,  0,137, 31,  0,  0,  0/
49266       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1179,1197)/
49267      & 221,0.017D0,  0,137, 32,  0,  0,  0,
49268      & 221,0.011D0,  0,136,179,  0,  0,  0,
49269      & 221,0.015D0,  0,136,180,  0,  0,  0,
49270      & 221,0.011D0,  0,137,179,  0,  0,  0,
49271      & 221,0.022D0,  0,137,180,  0,  0,  0,
49272      & 221,0.001D0,  0,164, 42,  0,  0,  0,
49273      & 221,0.002D0,  0,164, 43,  0,  0,  0,
49274      & 221,0.001D0,  0,165, 42,  0,  0,  0,
49275      & 221,0.001D0,  0,165, 43,  0,  0,  0,
49276      & 221,0.001D0,  0,166, 42,  0,  0,  0,
49277      & 221,0.001D0,  0,166, 43,  0,  0,  0,
49278      & 221,0.207D0,100,  1,  8,  4,  7,  0,
49279      & 221,0.207D0,100,  3, 10,  4,  7,  0,
49280      & 221,0.024D0,100,  1,  8,  2,  7,  0,
49281      & 221,0.024D0,100,  3, 10,  2,  7,  0,
49282      & 221,0.012D0,100,  3,  8,  4,  7,  0,
49283      & 221,0.012D0,100,  1, 10,  4,  7,  0,
49284      & 221,0.069D0,100,  4,  8,  1,  7,  0,
49285      & 221,0.069D0,100,  4, 10,  3,  7,  0/
49286       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1198,1216)/
49287      & 221,0.008D0,100,  2,  8,  1,  7,  0,
49288      & 221,0.008D0,100,  2, 10,  3,  7,  0,
49289      & 221,0.004D0,100,  4,  8,  3,  7,  0,
49290      & 221,0.004D0,100,  4, 10,  1,  7,  0,
49291      & 222,0.016D0,101,121,128,140,  0,  0,
49292      & 222,0.016D0,101,123,130,140,  0,  0,
49293      & 222,0.008D0,101,125,132,140,  0,  0,
49294      & 222,0.048D0,101,121,128,141,  0,  0,
49295      & 222,0.048D0,101,123,130,141,  0,  0,
49296      & 222,0.022D0,101,125,132,141,  0,  0,
49297      & 222,0.003D0,101,121,128,332,  0,  0,
49298      & 222,0.003D0,101,123,130,332,  0,  0,
49299      & 222,0.001D0,101,125,132,332,  0,  0,
49300      & 222,0.008D0,101,121,128,142,  0,  0,
49301      & 222,0.008D0,101,123,130,142,  0,  0,
49302      & 222,0.004D0,101,125,132,142,  0,  0,
49303      & 222,0.008D0,101,121,128,314,  0,  0,
49304      & 222,0.008D0,101,123,130,314,  0,  0,
49305      & 222,0.004D0,101,125,132,314,  0,  0/
49306       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1217,1235)/
49307      & 222,0.013D0,101,121,128,143,  0,  0,
49308      & 222,0.013D0,101,123,130,143,  0,  0,
49309      & 222,0.006D0,101,125,132,143,  0,  0,
49310      & 222,0.004D0,  0,140, 30,  0,  0,  0,
49311      & 222,0.010D0,  0,140, 31,  0,  0,  0,
49312      & 222,0.006D0,  0,140, 32,  0,  0,  0,
49313      & 222,0.003D0,  0,141, 30,  0,  0,  0,
49314      & 222,0.009D0,  0,141, 31,  0,  0,  0,
49315      & 222,0.017D0,  0,141, 32,  0,  0,  0,
49316      & 222,0.011D0,  0,140,179,  0,  0,  0,
49317      & 222,0.015D0,  0,140,180,  0,  0,  0,
49318      & 222,0.011D0,  0,141,179,  0,  0,  0,
49319      & 222,0.022D0,  0,141,180,  0,  0,  0,
49320      & 222,0.001D0,  0,164, 34,  0,  0,  0,
49321      & 222,0.002D0,  0,164, 35,  0,  0,  0,
49322      & 222,0.001D0,  0,165, 34,  0,  0,  0,
49323      & 222,0.001D0,  0,165, 35,  0,  0,  0,
49324      & 222,0.001D0,  0,166, 34,  0,  0,  0,
49325      & 222,0.001D0,  0,166, 35,  0,  0,  0/
49326       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1236,1254)/
49327      & 222,0.207D0,100,  1,  8,  4,  8,  0,
49328      & 222,0.207D0,100,  3, 10,  4,  8,  0,
49329      & 222,0.024D0,100,  1,  8,  2,  8,  0,
49330      & 222,0.024D0,100,  3, 10,  2,  8,  0,
49331      & 222,0.012D0,100,  3,  8,  4,  8,  0,
49332      & 222,0.012D0,100,  1, 10,  4,  8,  0,
49333      & 222,0.069D0,100,  4,  8,  1,  8,  0,
49334      & 222,0.069D0,100,  4, 10,  3,  8,  0,
49335      & 222,0.008D0,100,  2,  8,  1,  8,  0,
49336      & 222,0.008D0,100,  2, 10,  3,  8,  0,
49337      & 222,0.004D0,100,  4,  8,  3,  8,  0,
49338      & 222,0.004D0,100,  4, 10,  1,  8,  0,
49339      & 223,0.016D0,101,121,128,144,  0,  0,
49340      & 223,0.016D0,101,123,130,144,  0,  0,
49341      & 223,0.008D0,101,125,132,144,  0,  0,
49342      & 223,0.048D0,101,121,128,145,  0,  0,
49343      & 223,0.048D0,101,123,130,145,  0,  0,
49344      & 223,0.022D0,101,125,132,145,  0,  0,
49345      & 223,0.003D0,101,121,128,333,  0,  0/
49346       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1255,1273)/
49347      & 223,0.003D0,101,123,130,333,  0,  0,
49348      & 223,0.001D0,101,125,132,333,  0,  0,
49349      & 223,0.008D0,101,121,128,146,  0,  0,
49350      & 223,0.008D0,101,123,130,146,  0,  0,
49351      & 223,0.004D0,101,125,132,146,  0,  0,
49352      & 223,0.008D0,101,121,128,315,  0,  0,
49353      & 223,0.008D0,101,123,130,315,  0,  0,
49354      & 223,0.004D0,101,125,132,315,  0,  0,
49355      & 223,0.013D0,101,121,128,147,  0,  0,
49356      & 223,0.013D0,101,123,130,147,  0,  0,
49357      & 223,0.006D0,101,125,132,147,  0,  0,
49358      & 223,0.004D0,  0,144, 30,  0,  0,  0,
49359      & 223,0.010D0,  0,144, 31,  0,  0,  0,
49360      & 223,0.006D0,  0,144, 32,  0,  0,  0,
49361      & 223,0.003D0,  0,145, 30,  0,  0,  0,
49362      & 223,0.009D0,  0,145, 31,  0,  0,  0,
49363      & 223,0.017D0,  0,145, 32,  0,  0,  0,
49364      & 223,0.011D0,  0,144,179,  0,  0,  0,
49365      & 223,0.015D0,  0,144,180,  0,  0,  0/
49366       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1274,1292)/
49367      & 223,0.011D0,  0,145,179,  0,  0,  0,
49368      & 223,0.022D0,  0,145,180,  0,  0,  0,
49369      & 223,0.001D0,  0,164, 25,  0,  0,  0,
49370      & 223,0.002D0,  0,164, 56,  0,  0,  0,
49371      & 223,0.001D0,  0,165, 25,  0,  0,  0,
49372      & 223,0.001D0,  0,165, 56,  0,  0,  0,
49373      & 223,0.001D0,  0,166, 25,  0,  0,  0,
49374      & 223,0.001D0,  0,166, 56,  0,  0,  0,
49375      & 223,0.207D0,100,  1,  8,  4,  9,  0,
49376      & 223,0.207D0,100,  3, 10,  4,  9,  0,
49377      & 223,0.024D0,100,  1,  8,  2,  9,  0,
49378      & 223,0.024D0,100,  3, 10,  2,  9,  0,
49379      & 223,0.012D0,100,  3,  8,  4,  9,  0,
49380      & 223,0.012D0,100,  1, 10,  4,  9,  0,
49381      & 223,0.069D0,100,  4,  8,  1,  9,  0,
49382      & 223,0.069D0,100,  4, 10,  3,  9,  0,
49383      & 223,0.008D0,100,  2,  8,  1,  9,  0,
49384      & 223,0.008D0,100,  2, 10,  3,  9,  0,
49385      & 223,0.004D0,100,  4,  8,  3,  9,  0/
49386       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1293,1311)/
49387      & 223,0.004D0,100,  4, 10,  1,  9,  0,
49388      & 224,0.090D0,100,121,128,  4,109,  0,
49389      & 224,0.090D0,100,123,130,  4,109,  0,
49390      & 224,0.045D0,100,125,132,  4,109,  0,
49391      & 224,0.010D0,100,121,128,  2,109,  0,
49392      & 224,0.010D0,100,123,130,  2,109,  0,
49393      & 224,0.005D0,100,125,132,  2,109,  0,
49394      & 224,0.242D0,100,  1,  8,  4,109,  0,
49395      & 224,0.242D0,100,  3, 10,  4,109,  0,
49396      & 224,0.027D0,100,  1,  8,  2,109,  0,
49397      & 224,0.027D0,100,  3, 10,  2,109,  0,
49398      & 224,0.012D0,100,  3,  8,  4,109,  0,
49399      & 224,0.012D0,100,  1, 10,  4,109,  0,
49400      & 224,0.081D0,100,  4,  8,  1,109,  0,
49401      & 224,0.081D0,100,  4, 10,  3,109,  0,
49402      & 224,0.009D0,100,  2,  8,  1,109,  0,
49403      & 224,0.009D0,100,  2, 10,  3,109,  0,
49404      & 224,0.004D0,100,  4,  8,  3,109,  0,
49405      & 224,0.004D0,100,  4, 10,  1,109,  0/
49406       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1312,1330)/
49407      & 225,0.090D0,100,121,128,  4,110,  0,
49408      & 225,0.090D0,100,123,130,  4,110,  0,
49409      & 225,0.045D0,100,125,132,  4,110,  0,
49410      & 225,0.010D0,100,121,128,  2,110,  0,
49411      & 225,0.010D0,100,123,130,  2,110,  0,
49412      & 225,0.005D0,100,125,132,  2,110,  0,
49413      & 225,0.242D0,100,  1,  8,  4,110,  0,
49414      & 225,0.242D0,100,  3, 10,  4,110,  0,
49415      & 225,0.027D0,100,  1,  8,  2,110,  0,
49416      & 225,0.027D0,100,  3, 10,  2,110,  0,
49417      & 225,0.012D0,100,  3,  8,  4,110,  0,
49418      & 225,0.012D0,100,  1, 10,  4,110,  0,
49419      & 225,0.081D0,100,  4,  8,  1,110,  0,
49420      & 225,0.081D0,100,  4, 10,  3,110,  0,
49421      & 225,0.009D0,100,  2,  8,  1,110,  0,
49422      & 225,0.009D0,100,  2, 10,  3,110,  0,
49423      & 225,0.004D0,100,  4,  8,  3,110,  0,
49424      & 225,0.004D0,100,  4, 10,  1,110,  0,
49425      & 226,0.090D0,100,121,128,  4,111,  0/
49426       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1331,1349)/
49427      & 226,0.090D0,100,123,130,  4,111,  0,
49428      & 226,0.045D0,100,125,132,  4,111,  0,
49429      & 226,0.010D0,100,121,128,  2,111,  0,
49430      & 226,0.010D0,100,123,130,  2,111,  0,
49431      & 226,0.005D0,100,125,132,  2,111,  0,
49432      & 226,0.242D0,100,  1,  8,  4,111,  0,
49433      & 226,0.242D0,100,  3, 10,  4,111,  0,
49434      & 226,0.027D0,100,  1,  8,  2,111,  0,
49435      & 226,0.027D0,100,  3, 10,  2,111,  0,
49436      & 226,0.012D0,100,  3,  8,  4,111,  0,
49437      & 226,0.012D0,100,  1, 10,  4,111,  0,
49438      & 226,0.081D0,100,  4,  8,  1,111,  0,
49439      & 226,0.081D0,100,  4, 10,  3,111,  0,
49440      & 226,0.009D0,100,  2,  8,  1,111,  0,
49441      & 226,0.009D0,100,  2, 10,  3,111,  0,
49442      & 226,0.004D0,100,  4,  8,  3,111,  0,
49443      & 226,0.004D0,100,  4, 10,  1,111,  0,
49444      & 227,0.090D0,100,121,128,  4,112,  0,
49445      & 227,0.090D0,100,123,130,  4,112,  0/
49446       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1350,1368)/
49447      & 227,0.045D0,100,125,132,  4,112,  0,
49448      & 227,0.010D0,100,121,128,  2,112,  0,
49449      & 227,0.010D0,100,123,130,  2,112,  0,
49450      & 227,0.005D0,100,125,132,  2,112,  0,
49451      & 227,0.242D0,100,  1,  8,  4,112,  0,
49452      & 227,0.242D0,100,  3, 10,  4,112,  0,
49453      & 227,0.027D0,100,  1,  8,  2,112,  0,
49454      & 227,0.027D0,100,  3, 10,  2,112,  0,
49455      & 227,0.012D0,100,  3,  8,  4,112,  0,
49456      & 227,0.012D0,100,  1, 10,  4,112,  0,
49457      & 227,0.081D0,100,  4,  8,  1,112,  0,
49458      & 227,0.081D0,100,  4, 10,  3,112,  0,
49459      & 227,0.009D0,100,  2,  8,  1,112,  0,
49460      & 227,0.009D0,100,  2, 10,  3,112,  0,
49461      & 227,0.004D0,100,  4,  8,  3,112,  0,
49462      & 227,0.004D0,100,  4, 10,  1,112,  0,
49463      & 228,0.090D0,100,121,128,  4,113,  0,
49464      & 228,0.090D0,100,123,130,  4,113,  0,
49465      & 228,0.045D0,100,125,132,  4,113,  0/
49466       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1369,1387)/
49467      & 228,0.010D0,100,121,128,  2,113,  0,
49468      & 228,0.010D0,100,123,130,  2,113,  0,
49469      & 228,0.005D0,100,125,132,  2,113,  0,
49470      & 228,0.242D0,100,  1,  8,  4,113,  0,
49471      & 228,0.242D0,100,  3, 10,  4,113,  0,
49472      & 228,0.027D0,100,  1,  8,  2,113,  0,
49473      & 228,0.027D0,100,  3, 10,  2,113,  0,
49474      & 228,0.012D0,100,  3,  8,  4,113,  0,
49475      & 228,0.012D0,100,  1, 10,  4,113,  0,
49476      & 228,0.081D0,100,  4,  8,  1,113,  0,
49477      & 228,0.081D0,100,  4, 10,  3,113,  0,
49478      & 228,0.009D0,100,  2,  8,  1,113,  0,
49479      & 228,0.009D0,100,  2, 10,  3,113,  0,
49480      & 228,0.004D0,100,  4,  8,  3,113,  0,
49481      & 228,0.004D0,100,  4, 10,  1,113,  0,
49482      & 229,0.090D0,100,121,128,  4,114,  0,
49483      & 229,0.090D0,100,123,130,  4,114,  0,
49484      & 229,0.045D0,100,125,132,  4,114,  0,
49485      & 229,0.010D0,100,121,128,  2,114,  0/
49486       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1388,1406)/
49487      & 229,0.010D0,100,123,130,  2,114,  0,
49488      & 229,0.005D0,100,125,132,  2,114,  0,
49489      & 229,0.242D0,100,  1,  8,  4,114,  0,
49490      & 229,0.242D0,100,  3, 10,  4,114,  0,
49491      & 229,0.027D0,100,  1,  8,  2,114,  0,
49492      & 229,0.027D0,100,  3, 10,  2,114,  0,
49493      & 229,0.012D0,100,  3,  8,  4,114,  0,
49494      & 229,0.012D0,100,  1, 10,  4,114,  0,
49495      & 229,0.081D0,100,  4,  8,  1,114,  0,
49496      & 229,0.081D0,100,  4, 10,  3,114,  0,
49497      & 229,0.009D0,100,  2,  8,  1,114,  0,
49498      & 229,0.009D0,100,  2, 10,  3,114,  0,
49499      & 229,0.004D0,100,  4,  8,  3,114,  0,
49500      & 229,0.004D0,100,  4, 10,  1,114,  0,
49501      & 230,0.080D0,100,121,128,  4, 10,  0,
49502      & 230,0.080D0,100,123,130,  4, 10,  0,
49503      & 230,0.040D0,100,125,132,  4, 10,  0,
49504      & 230,0.080D0,100,121,128,  9,  5,  0,
49505      & 230,0.080D0,100,123,130,  9,  5,  0/
49506       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1407,1425)/
49507      & 230,0.228D0,100,  1,  8,  4, 10,  0,
49508      & 230,0.228D0,100,  3, 10,  4, 10,  0,
49509      & 230,0.012D0,100,  3,  8,  4, 10,  0,
49510      & 230,0.012D0,100,  1, 10,  4, 10,  0,
49511      & 230,0.076D0,100,  4,  8,  1, 10,  0,
49512      & 230,0.076D0,100,  4, 10,  3, 10,  0,
49513      & 230,0.004D0,100,  4,  8,  3, 10,  0,
49514      & 230,0.004D0,100,  4, 10,  1, 10,  0,
49515      & 231,0.025D0,  0,121,127,  0,  0,  0,
49516      & 231,0.025D0,  0,123,129,  0,  0,  0,
49517      & 231,0.025D0,  0,125,131,  0,  0,  0,
49518      & 231,0.008D0,  0,  1,  7,  0,  0,  0,
49519      & 231,0.033D0,  0,  2,  8,  0,  0,  0,
49520      & 231,0.008D0,  0,  3,  9,  0,  0,  0,
49521      & 231,0.033D0,  0,  4, 10,  0,  0,  0,
49522      & 231,0.801D0,130, 13, 13, 13,  0,  0,
49523      & 231,0.042D0,130, 13, 13, 59,  0,  0,
49524      & 245,0.016D0,101,127,122,171,  0,  0,
49525      & 245,0.016D0,101,129,124,171,  0,  0/
49526       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1426,1444)/
49527      & 245,0.008D0,101,131,126,171,  0,  0,
49528      & 245,0.048D0,101,127,122,172,  0,  0,
49529      & 245,0.048D0,101,129,124,172,  0,  0,
49530      & 245,0.022D0,101,131,126,172,  0,  0,
49531      & 245,0.003D0,101,127,122,334,  0,  0,
49532      & 245,0.003D0,101,129,124,334,  0,  0,
49533      & 245,0.001D0,101,131,126,334,  0,  0,
49534      & 245,0.008D0,101,127,122,173,  0,  0,
49535      & 245,0.008D0,101,129,124,173,  0,  0,
49536      & 245,0.004D0,101,131,126,173,  0,  0,
49537      & 245,0.008D0,101,127,122,316,  0,  0,
49538      & 245,0.008D0,101,129,124,316,  0,  0,
49539      & 245,0.004D0,101,131,126,316,  0,  0,
49540      & 245,0.013D0,101,127,122,174,  0,  0,
49541      & 245,0.013D0,101,129,124,174,  0,  0,
49542      & 245,0.006D0,101,131,126,174,  0,  0,
49543      & 245,0.004D0,  0,171, 38,  0,  0,  0,
49544      & 245,0.010D0,  0,171, 39,  0,  0,  0,
49545      & 245,0.006D0,  0,171, 40,  0,  0,  0/
49546       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1445,1463)/
49547      & 245,0.003D0,  0,172, 38,  0,  0,  0,
49548      & 245,0.009D0,  0,172, 39,  0,  0,  0,
49549      & 245,0.017D0,  0,172, 40,  0,  0,  0,
49550      & 245,0.011D0,  0,171,144,  0,  0,  0,
49551      & 245,0.015D0,  0,171,145,  0,  0,  0,
49552      & 245,0.011D0,  0,172,144,  0,  0,  0,
49553      & 245,0.022D0,  0,172,145,  0,  0,  0,
49554      & 245,0.001D0,  0,164, 50,  0,  0,  0,
49555      & 245,0.002D0,  0,164, 51,  0,  0,  0,
49556      & 245,0.001D0,  0,165, 50,  0,  0,  0,
49557      & 245,0.001D0,  0,165, 51,  0,  0,  0,
49558      & 245,0.001D0,  0,166, 50,  0,  0,  0,
49559      & 245,0.001D0,  0,166, 51,  0,  0,  0,
49560      & 245,0.207D0,100,  7,  2, 10,  1,  0,
49561      & 245,0.207D0,100,  9,  4, 10,  1,  0,
49562      & 245,0.024D0,100,  7,  2,  8,  1,  0,
49563      & 245,0.024D0,100,  9,  4,  8,  1,  0,
49564      & 245,0.012D0,100,  9,  2, 10,  1,  0,
49565      & 245,0.012D0,100,  7,  4, 10,  1,  0/
49566       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1464,1482)/
49567      & 245,0.069D0,100, 10,  2,  7,  1,  0,
49568      & 245,0.069D0,100, 10,  4,  9,  1,  0,
49569      & 245,0.008D0,100,  8,  2,  7,  1,  0,
49570      & 245,0.008D0,100,  8,  4,  9,  1,  0,
49571      & 245,0.004D0,100, 10,  2,  9,  1,  0,
49572      & 245,0.004D0,100, 10,  4,  7,  1,  0,
49573      & 246,0.016D0,101,127,122,175,  0,  0,
49574      & 246,0.016D0,101,129,124,175,  0,  0,
49575      & 246,0.008D0,101,131,126,175,  0,  0,
49576      & 246,0.048D0,101,127,122,176,  0,  0,
49577      & 246,0.048D0,101,129,124,176,  0,  0,
49578      & 246,0.022D0,101,131,126,176,  0,  0,
49579      & 246,0.003D0,101,127,122,335,  0,  0,
49580      & 246,0.003D0,101,129,124,335,  0,  0,
49581      & 246,0.001D0,101,131,126,335,  0,  0,
49582      & 246,0.008D0,101,127,122,177,  0,  0,
49583      & 246,0.008D0,101,129,124,177,  0,  0,
49584      & 246,0.004D0,101,131,126,177,  0,  0,
49585      & 246,0.008D0,101,127,122,317,  0,  0/
49586       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1483,1501)/
49587      & 246,0.008D0,101,129,124,317,  0,  0,
49588      & 246,0.004D0,101,131,126,317,  0,  0,
49589      & 246,0.013D0,101,127,122,178,  0,  0,
49590      & 246,0.013D0,101,129,124,178,  0,  0,
49591      & 246,0.006D0,101,131,126,178,  0,  0,
49592      & 246,0.004D0,  0,175, 38,  0,  0,  0,
49593      & 246,0.010D0,  0,175, 39,  0,  0,  0,
49594      & 246,0.006D0,  0,175, 40,  0,  0,  0,
49595      & 246,0.003D0,  0,176, 38,  0,  0,  0,
49596      & 246,0.009D0,  0,176, 39,  0,  0,  0,
49597      & 246,0.017D0,  0,176, 40,  0,  0,  0,
49598      & 246,0.011D0,  0,175,144,  0,  0,  0,
49599      & 246,0.015D0,  0,175,145,  0,  0,  0,
49600      & 246,0.011D0,  0,176,144,  0,  0,  0,
49601      & 246,0.022D0,  0,176,145,  0,  0,  0,
49602      & 246,0.001D0,  0,164, 46,  0,  0,  0,
49603      & 246,0.002D0,  0,164, 47,  0,  0,  0,
49604      & 246,0.001D0,  0,165, 46,  0,  0,  0,
49605      & 246,0.001D0,  0,165, 47,  0,  0,  0/
49606       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1502,1520)/
49607      & 246,0.001D0,  0,166, 46,  0,  0,  0,
49608      & 246,0.001D0,  0,166, 47,  0,  0,  0,
49609      & 246,0.207D0,100,  7,  2, 10,  2,  0,
49610      & 246,0.207D0,100,  9,  4, 10,  2,  0,
49611      & 246,0.024D0,100,  7,  2,  8,  2,  0,
49612      & 246,0.024D0,100,  9,  4,  8,  2,  0,
49613      & 246,0.012D0,100,  9,  2, 10,  2,  0,
49614      & 246,0.012D0,100,  7,  4, 10,  2,  0,
49615      & 246,0.069D0,100, 10,  2,  7,  2,  0,
49616      & 246,0.069D0,100, 10,  4,  9,  2,  0,
49617      & 246,0.008D0,100,  8,  2,  7,  2,  0,
49618      & 246,0.008D0,100,  8,  4,  9,  2,  0,
49619      & 246,0.004D0,100, 10,  2,  9,  2,  0,
49620      & 246,0.004D0,100, 10,  4,  7,  2,  0,
49621      & 247,0.016D0,101,127,122,179,  0,  0,
49622      & 247,0.016D0,101,129,124,179,  0,  0,
49623      & 247,0.008D0,101,131,126,179,  0,  0,
49624      & 247,0.048D0,101,127,122,180,  0,  0,
49625      & 247,0.048D0,101,129,124,180,  0,  0/
49626       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1521,1539)/
49627      & 247,0.022D0,101,131,126,180,  0,  0,
49628      & 247,0.003D0,101,127,122,336,  0,  0,
49629      & 247,0.003D0,101,129,124,336,  0,  0,
49630      & 247,0.001D0,101,131,126,336,  0,  0,
49631      & 247,0.008D0,101,127,122,181,  0,  0,
49632      & 247,0.008D0,101,129,124,181,  0,  0,
49633      & 247,0.004D0,101,131,126,181,  0,  0,
49634      & 247,0.008D0,101,127,122,318,  0,  0,
49635      & 247,0.008D0,101,129,124,318,  0,  0,
49636      & 247,0.004D0,101,131,126,318,  0,  0,
49637      & 247,0.013D0,101,127,122,182,  0,  0,
49638      & 247,0.013D0,101,129,124,182,  0,  0,
49639      & 247,0.006D0,101,131,126,182,  0,  0,
49640      & 247,0.004D0,  0,179, 38,  0,  0,  0,
49641      & 247,0.010D0,  0,179, 39,  0,  0,  0,
49642      & 247,0.006D0,  0,179, 40,  0,  0,  0,
49643      & 247,0.003D0,  0,180, 38,  0,  0,  0,
49644      & 247,0.009D0,  0,180, 39,  0,  0,  0,
49645      & 247,0.017D0,  0,180, 40,  0,  0,  0/
49646       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1540,1558)/
49647      & 247,0.011D0,  0,179,144,  0,  0,  0,
49648      & 247,0.015D0,  0,179,145,  0,  0,  0,
49649      & 247,0.011D0,  0,180,144,  0,  0,  0,
49650      & 247,0.022D0,  0,180,145,  0,  0,  0,
49651      & 247,0.001D0,  0,164, 25,  0,  0,  0,
49652      & 247,0.002D0,  0,164, 56,  0,  0,  0,
49653      & 247,0.001D0,  0,165, 25,  0,  0,  0,
49654      & 247,0.001D0,  0,165, 56,  0,  0,  0,
49655      & 247,0.001D0,  0,166, 25,  0,  0,  0,
49656      & 247,0.001D0,  0,166, 56,  0,  0,  0,
49657      & 247,0.207D0,100,  7,  2, 10,  3,  0,
49658      & 247,0.207D0,100,  9,  4, 10,  3,  0,
49659      & 247,0.024D0,100,  7,  2,  8,  3,  0,
49660      & 247,0.024D0,100,  9,  4,  8,  3,  0,
49661      & 247,0.012D0,100,  9,  2, 10,  3,  0,
49662      & 247,0.012D0,100,  7,  4, 10,  3,  0,
49663      & 247,0.069D0,100, 10,  2,  7,  3,  0,
49664      & 247,0.069D0,100, 10,  4,  9,  3,  0,
49665      & 247,0.008D0,100,  8,  2,  7,  3,  0/
49666       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1559,1577)/
49667      & 247,0.008D0,100,  8,  4,  9,  3,  0,
49668      & 247,0.004D0,100, 10,  2,  9,  3,  0,
49669      & 247,0.004D0,100, 10,  4,  7,  3,  0,
49670      & 248,0.090D0,100,127,122, 10,115,  0,
49671      & 248,0.090D0,100,129,124, 10,115,  0,
49672      & 248,0.045D0,100,131,126, 10,115,  0,
49673      & 248,0.010D0,100,127,122,  8,115,  0,
49674      & 248,0.010D0,100,129,124,  8,115,  0,
49675      & 248,0.005D0,100,131,126,  8,115,  0,
49676      & 248,0.242D0,100,  7,  2, 10,115,  0,
49677      & 248,0.242D0,100,  9,  4, 10,115,  0,
49678      & 248,0.027D0,100,  7,  2,  8,115,  0,
49679      & 248,0.027D0,100,  9,  4,  8,115,  0,
49680      & 248,0.012D0,100,  9,  2, 10,115,  0,
49681      & 248,0.012D0,100,  7,  4, 10,115,  0,
49682      & 248,0.081D0,100, 10,  2,  7,115,  0,
49683      & 248,0.081D0,100, 10,  4,  9,115,  0,
49684      & 248,0.009D0,100,  8,  2,  7,115,  0,
49685      & 248,0.009D0,100,  8,  4,  9,115,  0/
49686       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1578,1596)/
49687      & 248,0.004D0,100, 10,  2,  9,115,  0,
49688      & 248,0.004D0,100, 10,  4,  7,115,  0,
49689      & 249,0.090D0,100,127,122, 10,116,  0,
49690      & 249,0.090D0,100,129,124, 10,116,  0,
49691      & 249,0.045D0,100,131,126, 10,116,  0,
49692      & 249,0.010D0,100,127,122,  8,116,  0,
49693      & 249,0.010D0,100,129,124,  8,116,  0,
49694      & 249,0.005D0,100,131,126,  8,116,  0,
49695      & 249,0.242D0,100,  7,  2, 10,116,  0,
49696      & 249,0.242D0,100,  9,  4, 10,116,  0,
49697      & 249,0.027D0,100,  7,  2,  8,116,  0,
49698      & 249,0.027D0,100,  9,  4,  8,116,  0,
49699      & 249,0.012D0,100,  9,  2, 10,116,  0,
49700      & 249,0.012D0,100,  7,  4, 10,116,  0,
49701      & 249,0.081D0,100, 10,  2,  7,116,  0,
49702      & 249,0.081D0,100, 10,  4,  9,116,  0,
49703      & 249,0.009D0,100,  8,  2,  7,116,  0,
49704      & 249,0.009D0,100,  8,  4,  9,116,  0,
49705      & 249,0.004D0,100, 10,  2,  9,116,  0/
49706       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1597,1615)/
49707      & 249,0.004D0,100, 10,  4,  7,116,  0,
49708      & 250,0.090D0,100,127,122, 10,117,  0,
49709      & 250,0.090D0,100,129,124, 10,117,  0,
49710      & 250,0.045D0,100,131,126, 10,117,  0,
49711      & 250,0.010D0,100,127,122,  8,117,  0,
49712      & 250,0.010D0,100,129,124,  8,117,  0,
49713      & 250,0.005D0,100,131,126,  8,117,  0,
49714      & 250,0.242D0,100,  7,  2, 10,117,  0,
49715      & 250,0.242D0,100,  9,  4, 10,117,  0,
49716      & 250,0.027D0,100,  7,  2,  8,117,  0,
49717      & 250,0.027D0,100,  9,  4,  8,117,  0,
49718      & 250,0.012D0,100,  9,  2, 10,117,  0,
49719      & 250,0.012D0,100,  7,  4, 10,117,  0,
49720      & 250,0.081D0,100, 10,  2,  7,117,  0,
49721      & 250,0.081D0,100, 10,  4,  9,117,  0,
49722      & 250,0.009D0,100,  8,  2,  7,117,  0,
49723      & 250,0.009D0,100,  8,  4,  9,117,  0,
49724      & 250,0.004D0,100, 10,  2,  9,117,  0,
49725      & 250,0.004D0,100, 10,  4,  7,117,  0/
49726       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1616,1634)/
49727      & 251,0.090D0,100,127,122, 10,118,  0,
49728      & 251,0.090D0,100,129,124, 10,118,  0,
49729      & 251,0.045D0,100,131,126, 10,118,  0,
49730      & 251,0.010D0,100,127,122,  8,118,  0,
49731      & 251,0.010D0,100,129,124,  8,118,  0,
49732      & 251,0.005D0,100,131,126,  8,118,  0,
49733      & 251,0.242D0,100,  7,  2, 10,118,  0,
49734      & 251,0.242D0,100,  9,  4, 10,118,  0,
49735      & 251,0.027D0,100,  7,  2,  8,118,  0,
49736      & 251,0.027D0,100,  9,  4,  8,118,  0,
49737      & 251,0.012D0,100,  9,  2, 10,118,  0,
49738      & 251,0.012D0,100,  7,  4, 10,118,  0,
49739      & 251,0.081D0,100, 10,  2,  7,118,  0,
49740      & 251,0.081D0,100, 10,  4,  9,118,  0,
49741      & 251,0.009D0,100,  8,  2,  7,118,  0,
49742      & 251,0.009D0,100,  8,  4,  9,118,  0,
49743      & 251,0.004D0,100, 10,  2,  9,118,  0,
49744      & 251,0.004D0,100, 10,  4,  7,118,  0,
49745      & 252,0.090D0,100,127,122, 10,119,  0/
49746       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1635,1653)/
49747      & 252,0.090D0,100,129,124, 10,119,  0,
49748      & 252,0.045D0,100,131,126, 10,119,  0,
49749      & 252,0.010D0,100,127,122,  8,119,  0,
49750      & 252,0.010D0,100,129,124,  8,119,  0,
49751      & 252,0.005D0,100,131,126,  8,119,  0,
49752      & 252,0.242D0,100,  7,  2, 10,119,  0,
49753      & 252,0.242D0,100,  9,  4, 10,119,  0,
49754      & 252,0.027D0,100,  7,  2,  8,119,  0,
49755      & 252,0.027D0,100,  9,  4,  8,119,  0,
49756      & 252,0.012D0,100,  9,  2, 10,119,  0,
49757      & 252,0.012D0,100,  7,  4, 10,119,  0,
49758      & 252,0.081D0,100, 10,  2,  7,119,  0,
49759      & 252,0.081D0,100, 10,  4,  9,119,  0,
49760      & 252,0.009D0,100,  8,  2,  7,119,  0,
49761      & 252,0.009D0,100,  8,  4,  9,119,  0,
49762      & 252,0.004D0,100, 10,  2,  9,119,  0,
49763      & 252,0.004D0,100, 10,  4,  7,119,  0,
49764      & 253,0.090D0,100,127,122, 10,120,  0,
49765      & 253,0.090D0,100,129,124, 10,120,  0/
49766       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1654,1672)/
49767      & 253,0.045D0,100,131,126, 10,120,  0,
49768      & 253,0.010D0,100,127,122,  8,120,  0,
49769      & 253,0.010D0,100,129,124,  8,120,  0,
49770      & 253,0.005D0,100,131,126,  8,120,  0,
49771      & 253,0.242D0,100,  7,  2, 10,120,  0,
49772      & 253,0.242D0,100,  9,  4, 10,120,  0,
49773      & 253,0.027D0,100,  7,  2,  8,120,  0,
49774      & 253,0.027D0,100,  9,  4,  8,120,  0,
49775      & 253,0.012D0,100,  9,  2, 10,120,  0,
49776      & 253,0.012D0,100,  7,  4, 10,120,  0,
49777      & 253,0.081D0,100, 10,  2,  7,120,  0,
49778      & 253,0.081D0,100, 10,  4,  9,120,  0,
49779      & 253,0.009D0,100,  8,  2,  7,120,  0,
49780      & 253,0.009D0,100,  8,  4,  9,120,  0,
49781      & 253,0.004D0,100, 10,  2,  9,120,  0,
49782      & 253,0.004D0,100, 10,  4,  7,120,  0,
49783      & 254,0.080D0,100,127,122, 10,  4,  0,
49784      & 254,0.080D0,100,129,124, 10,  4,  0,
49785      & 254,0.040D0,100,131,126, 10,  4,  0/
49786       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1673,1691)/
49787      & 254,0.080D0,100,127,122,  3, 11,  0,
49788      & 254,0.080D0,100,129,124,  3, 11,  0,
49789      & 254,0.228D0,100,  7,  2, 10,  4,  0,
49790      & 254,0.228D0,100,  9,  4, 10,  4,  0,
49791      & 254,0.012D0,100,  9,  2, 10,  4,  0,
49792      & 254,0.012D0,100,  7,  4, 10,  4,  0,
49793      & 254,0.076D0,100, 10,  2,  7,  4,  0,
49794      & 254,0.076D0,100, 10,  4,  9,  4,  0,
49795      & 254,0.004D0,100, 10,  2,  9,  4,  0,
49796      & 254,0.004D0,100, 10,  4,  7,  4,  0,
49797      & 265,1.000D0,  0,221, 59,  0,  0,  0,
49798      & 266,1.000D0,  0,222, 59,  0,  0,  0,
49799      & 267,1.000D0,  0,223, 59,  0,  0,  0,
49800      & 268,0.667D0,  0,266, 38,  0,  0,  0,
49801      & 268,0.333D0,  0,265, 21,  0,  0,  0,
49802      & 269,0.667D0,  0,265, 30,  0,  0,  0,
49803      & 269,0.333D0,  0,266, 21,  0,  0,  0,
49804      & 270,0.500D0,  0,265, 50,  0,  0,  0,
49805      & 270,0.500D0,  0,266, 46,  0,  0,  0/
49806       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1692,1710)/
49807      & 271,0.290D0,  0,266, 38,  0,  0,  0,
49808      & 271,0.150D0,  0,265, 21,  0,  0,  0,
49809      & 271,0.290D0,  0,222, 38,  0,  0,  0,
49810      & 271,0.150D0,  0,221, 21,  0,  0,  0,
49811      & 271,0.060D0,  0,266, 38, 21,  0,  0,
49812      & 271,0.020D0,  0,265, 38, 30,  0,  0,
49813      & 271,0.010D0,  0,265, 21, 21,  0,  0,
49814      & 271,0.020D0,  0,222, 38, 21,  0,  0,
49815      & 271,0.010D0,  0,221, 38, 30,  0,  0,
49816      & 272,0.290D0,  0,265, 30,  0,  0,  0,
49817      & 272,0.150D0,  0,266, 21,  0,  0,  0,
49818      & 272,0.290D0,  0,221, 30,  0,  0,  0,
49819      & 272,0.150D0,  0,222, 21,  0,  0,  0,
49820      & 272,0.060D0,  0,265, 30, 21,  0,  0,
49821      & 272,0.020D0,  0,266, 38, 30,  0,  0,
49822      & 272,0.010D0,  0,266, 21, 21,  0,  0,
49823      & 272,0.020D0,  0,221, 30, 21,  0,  0,
49824      & 272,0.010D0,  0,222, 38, 30,  0,  0,
49825      & 273,0.350D0,  0,221, 50,  0,  0,  0/
49826       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1711,1729)/
49827      & 273,0.350D0,  0,222, 46,  0,  0,  0,
49828      & 273,0.150D0,  0,265, 50,  0,  0,  0,
49829      & 273,0.150D0,  0,266, 46,  0,  0,  0,
49830      & 274,1.000D0,  0,245, 59,  0,  0,  0,
49831      & 275,1.000D0,  0,246, 59,  0,  0,  0,
49832      & 276,1.000D0,  0,247, 59,  0,  0,  0,
49833      & 277,0.667D0,  0,275, 30,  0,  0,  0,
49834      & 277,0.333D0,  0,274, 21,  0,  0,  0,
49835      & 278,0.667D0,  0,274, 38,  0,  0,  0,
49836      & 278,0.333D0,  0,275, 21,  0,  0,  0,
49837      & 279,0.500D0,  0,274, 42,  0,  0,  0,
49838      & 279,0.500D0,  0,275, 34,  0,  0,  0,
49839      & 280,0.290D0,  0,275, 30,  0,  0,  0,
49840      & 280,0.150D0,  0,274, 21,  0,  0,  0,
49841      & 280,0.290D0,  0,246, 30,  0,  0,  0,
49842      & 280,0.150D0,  0,245, 21,  0,  0,  0,
49843      & 280,0.060D0,  0,275, 30, 21,  0,  0,
49844      & 280,0.020D0,  0,274, 38, 30,  0,  0,
49845      & 280,0.010D0,  0,274, 21, 21,  0,  0/
49846       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1730,1748)/
49847      & 280,0.020D0,  0,246, 30, 21,  0,  0,
49848      & 280,0.010D0,  0,245, 38, 30,  0,  0,
49849      & 281,0.290D0,  0,274, 38,  0,  0,  0,
49850      & 281,0.150D0,  0,275, 21,  0,  0,  0,
49851      & 281,0.290D0,  0,245, 38,  0,  0,  0,
49852      & 281,0.150D0,  0,246, 21,  0,  0,  0,
49853      & 281,0.060D0,  0,274, 38, 21,  0,  0,
49854      & 281,0.020D0,  0,275, 38, 30,  0,  0,
49855      & 281,0.010D0,  0,275, 21, 21,  0,  0,
49856      & 281,0.020D0,  0,245, 38, 21,  0,  0,
49857      & 281,0.010D0,  0,246, 38, 30,  0,  0,
49858      & 282,0.350D0,  0,245, 42,  0,  0,  0,
49859      & 282,0.350D0,  0,246, 34,  0,  0,  0,
49860      & 282,0.150D0,  0,274, 42,  0,  0,  0,
49861      & 282,0.150D0,  0,275, 34,  0,  0,  0,
49862      & 285,1.000D0,  0, 24, 21,  0,  0,  0,
49863      & 286,0.998D0,  0, 24, 38,  0,  0,  0,
49864      & 286,0.002D0,  0, 38, 59,  0,  0,  0,
49865      & 287,0.998D0,  0, 24, 30,  0,  0,  0/
49866       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1749,1767)/
49867      & 287,0.002D0,  0, 30, 59,  0,  0,  0,
49868      & 288,0.330D0,  0, 39, 30,  0,  0,  0,
49869      & 288,0.340D0,  0, 23, 21,  0,  0,  0,
49870      & 288,0.330D0,  0, 31, 38,  0,  0,  0,
49871      & 289,0.250D0,  0, 46, 35,  0,  0,  0,
49872      & 289,0.250D0,  0, 34, 47,  0,  0,  0,
49873      & 289,0.250D0,  0, 50, 43,  0,  0,  0,
49874      & 289,0.250D0,  0, 42, 51,  0,  0,  0,
49875      & 290,0.996D0,  0, 22, 21,  0,  0,  0,
49876      & 290,0.002D0,  0, 46, 34,  0,  0,  0,
49877      & 290,0.002D0,  0, 50, 42,  0,  0,  0,
49878      & 291,0.996D0,  0, 22, 38,  0,  0,  0,
49879      & 291,0.004D0,  0, 46, 42,  0,  0,  0,
49880      & 292,0.996D0,  0, 22, 30,  0,  0,  0,
49881      & 292,0.004D0,  0, 50, 34,  0,  0,  0,
49882      & 293,0.520D0,  0, 38, 30,  0,  0,  0,
49883      & 293,0.260D0,  0, 21, 21,  0,  0,  0,
49884      & 293,0.110D0,  0, 46, 34,  0,  0,  0,
49885      & 293,0.110D0,  0, 50, 42,  0,  0,  0/
49886       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1768,1786)/
49887      & 294,0.620D0,  0, 38, 30,  0,  0,  0,
49888      & 294,0.310D0,  0, 21, 21,  0,  0,  0,
49889      & 294,0.035D0,  0, 46, 34,  0,  0,  0,
49890      & 294,0.035D0,  0, 50, 42,  0,  0,  0,
49891      & 295,1.000D0,  0,254, 59,  0,  0,  0,
49892      & 296,1.000D0,  0,230, 59,  0,  0,  0,
49893      & 297,1.000D0,  0,254, 59,  0,  0,  0,
49894      & 298,1.000D0,  0,230, 59,  0,  0,  0,
49895      & 299,1.000D0,  0,254, 59,  0,  0,  0,
49896      & 300,1.000D0,  0,230, 59,  0,  0,  0,
49897      & 301,0.050D0,  0,121,127,  0,  0,  0,
49898      & 301,0.050D0,  0,123,129,  0,  0,  0,
49899      & 301,0.017D0,  0,  1,  7,  0,  0,  0,
49900      & 301,0.066D0,  0,  2,  8,  0,  0,  0,
49901      & 301,0.017D0,  0,  3,  9,  0,  0,  0,
49902      & 301,0.640D0,130, 13, 13, 13,  0,  0,
49903      & 301,0.160D0,130, 13, 13, 59,  0,  0,
49904      & 302,0.022D0,  0, 38, 30, 38, 30, 23,
49905      & 302,0.016D0,  0, 38, 30, 38, 30,  0/
49906       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1787,1805)/
49907      & 302,0.009D0,  0, 38, 30, 46, 34,  0,
49908      & 302,0.004D0,  0, 23, 38, 30,  0,  0,
49909      & 302,0.002D0,  0, 46, 43, 30,  0,  0,
49910      & 302,0.002D0,  0, 34, 51, 38,  0,  0,
49911      & 302,0.001D0,  0, 38, 30, 73, 91,  0,
49912      & 302,0.273D0,  0, 59,164,  0,  0,  0,
49913      & 302,0.671D0,  0, 13, 13,  0,  0,  0,
49914      & 303,0.022D0,  0, 38, 30, 38, 30,  0,
49915      & 303,0.019D0,  0, 38, 30, 46, 34,  0,
49916      & 303,0.012D0,  0, 38, 30, 38, 30, 23,
49917      & 303,0.007D0,  0, 23, 38, 30,  0,  0,
49918      & 303,0.002D0,  0, 46, 43, 30,  0,  0,
49919      & 303,0.002D0,  0, 34, 51, 38,  0,  0,
49920      & 303,0.003D0,  0, 38, 30, 73, 91,  0,
49921      & 303,0.002D0,  0, 38, 30,  0,  0,  0,
49922      & 303,0.002D0,  0, 46, 34,  0,  0,  0,
49923      & 303,0.001D0,  0, 21, 21,  0,  0,  0,
49924      & 303,0.135D0,  0, 59,164,  0,  0,  0,
49925      & 303,0.793D0,  0, 13, 13,  0,  0,  0/
49926       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1806,1824)/
49927      & 304,1.000D0,  0, 13, 13,  0,  0,  0,
49928      & 305,1.000D0,  0, 13, 13,  0,  0,  0,
49929      & 306,0.050D0,  0, 59,231,  0,  0,  0,
49930      & 306,0.950D0,  0, 13, 13,  0,  0,  0,
49931      & 307,0.350D0,  0, 59,231,  0,  0,  0,
49932      & 307,0.650D0,  0, 13, 13,  0,  0,  0,
49933      & 308,0.220D0,  0, 59,231,  0,  0,  0,
49934      & 308,0.780D0,  0, 13, 13,  0,  0,  0,
49935      & 309,0.280D0,  0, 46, 31,  0,  0,  0,
49936      & 309,0.140D0,  0, 50, 23,  0,  0,  0,
49937      & 309,0.187D0,  0,327, 30,  0,  0,  0,
49938      & 309,0.093D0,  0,328, 21,  0,  0,  0,
49939      & 309,0.110D0,  0, 50, 24,  0,  0,  0,
49940      & 309,0.107D0,  0, 47, 30,  0,  0,  0,
49941      & 309,0.053D0,  0, 51, 21,  0,  0,  0,
49942      & 309,0.030D0,  0, 50,293,  0,  0,  0,
49943      & 310,0.280D0,  0, 50, 39,  0,  0,  0,
49944      & 310,0.140D0,  0, 46, 23,  0,  0,  0,
49945      & 310,0.187D0,  0,328, 38,  0,  0,  0/
49946       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1825,1843)/
49947      & 310,0.093D0,  0,327, 21,  0,  0,  0,
49948      & 310,0.110D0,  0, 46, 24,  0,  0,  0,
49949      & 310,0.107D0,  0, 51, 38,  0,  0,  0,
49950      & 310,0.053D0,  0, 47, 21,  0,  0,  0,
49951      & 310,0.030D0,  0, 46,293,  0,  0,  0,
49952      & 311,0.280D0,  0, 34, 39,  0,  0,  0,
49953      & 311,0.140D0,  0, 42, 23,  0,  0,  0,
49954      & 311,0.187D0,  0,330, 38,  0,  0,  0,
49955      & 311,0.093D0,  0,329, 21,  0,  0,  0,
49956      & 311,0.110D0,  0, 42, 24,  0,  0,  0,
49957      & 311,0.107D0,  0, 35, 38,  0,  0,  0,
49958      & 311,0.053D0,  0, 43, 21,  0,  0,  0,
49959      & 311,0.030D0,  0, 42,293,  0,  0,  0,
49960      & 312,0.280D0,  0, 42, 31,  0,  0,  0,
49961      & 312,0.140D0,  0, 34, 23,  0,  0,  0,
49962      & 312,0.187D0,  0,329, 30,  0,  0,  0,
49963      & 312,0.093D0,  0,330, 21,  0,  0,  0,
49964      & 312,0.110D0,  0, 34, 24,  0,  0,  0,
49965      & 312,0.107D0,  0, 43, 30,  0,  0,  0/
49966       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1844,1862)/
49967      & 312,0.053D0,  0, 35, 21,  0,  0,  0,
49968      & 312,0.030D0,  0, 34,293,  0,  0,  0,
49969      & 313,0.430D0,  0,140, 38,  0,  0,  0,
49970      & 313,0.215D0,  0,136, 21,  0,  0,  0,
49971      & 313,0.235D0,  0,140, 38, 21,  0,  0,
49972      & 313,0.120D0,  0,136, 38, 30,  0,  0,
49973      & 314,0.430D0,  0,136, 30,  0,  0,  0,
49974      & 314,0.215D0,  0,140, 21,  0,  0,  0,
49975      & 314,0.235D0,  0,136, 30, 21,  0,  0,
49976      & 314,0.120D0,  0,140, 38, 30,  0,  0,
49977      & 315,0.480D0,  0,136, 50,  0,  0,  0,
49978      & 315,0.480D0,  0,140, 46,  0,  0,  0,
49979      & 315,0.040D0,  0,145, 59,  0,  0,  0,
49980      & 316,0.430D0,  0,175, 30,  0,  0,  0,
49981      & 316,0.215D0,  0,171, 21,  0,  0,  0,
49982      & 316,0.235D0,  0,175, 30, 21,  0,  0,
49983      & 316,0.120D0,  0,171, 38, 30,  0,  0,
49984      & 317,0.430D0,  0,171, 38,  0,  0,  0,
49985      & 317,0.215D0,  0,175, 21,  0,  0,  0/
49986       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1863,1881)/
49987      & 317,0.235D0,  0,171, 38, 21,  0,  0,
49988      & 317,0.120D0,  0,175, 38, 30,  0,  0,
49989      & 318,0.480D0,  0,171, 42,  0,  0,  0,
49990      & 318,0.480D0,  0,175, 34,  0,  0,  0,
49991      & 318,0.040D0,  0,180, 59,  0,  0,  0,
49992      & 319,0.540D0,  0,275, 30,  0,  0,  0,
49993      & 319,0.270D0,  0,274, 21,  0,  0,  0,
49994      & 319,0.030D0,  0,275, 30, 21,  0,  0,
49995      & 319,0.010D0,  0,274, 38, 30,  0,  0,
49996      & 319,0.010D0,  0,274, 21, 21,  0,  0,
49997      & 319,0.090D0,  0,246, 30, 21,  0,  0,
49998      & 319,0.030D0,  0,245, 38, 30,  0,  0,
49999      & 319,0.020D0,  0,245, 21, 21,  0,  0,
50000      & 320,0.540D0,  0,274, 38,  0,  0,  0,
50001      & 320,0.270D0,  0,275, 21,  0,  0,  0,
50002      & 320,0.030D0,  0,274, 38, 21,  0,  0,
50003      & 320,0.010D0,  0,275, 38, 30,  0,  0,
50004      & 320,0.010D0,  0,275, 21, 21,  0,  0,
50005      & 320,0.090D0,  0,245, 38, 21,  0,  0/
50006       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1882,1900)/
50007      & 320,0.030D0,  0,246, 38, 30,  0,  0,
50008      & 320,0.020D0,  0,246, 21, 21,  0,  0,
50009      & 321,0.500D0,  0,266, 46,  0,  0,  0,
50010      & 321,0.500D0,  0,265, 50,  0,  0,  0,
50011      & 322,1.000D0,  0,254, 59,  0,  0,  0,
50012      & 323,0.540D0,  0,266, 38,  0,  0,  0,
50013      & 323,0.270D0,  0,265, 21,  0,  0,  0,
50014      & 323,0.030D0,  0,266, 38, 21,  0,  0,
50015      & 323,0.010D0,  0,265, 38, 30,  0,  0,
50016      & 323,0.010D0,  0,265, 21, 21,  0,  0,
50017      & 323,0.090D0,  0,222, 38, 21,  0,  0,
50018      & 323,0.030D0,  0,221, 38, 30,  0,  0,
50019      & 323,0.020D0,  0,221, 21, 21,  0,  0,
50020      & 324,0.540D0,  0,265, 30,  0,  0,  0,
50021      & 324,0.270D0,  0,266, 21,  0,  0,  0,
50022      & 324,0.030D0,  0,265, 30, 21,  0,  0,
50023      & 324,0.010D0,  0,266, 38, 30,  0,  0,
50024      & 324,0.010D0,  0,266, 21, 21,  0,  0,
50025      & 324,0.090D0,  0,221, 30, 21,  0,  0/
50026       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1901,1919)/
50027      & 324,0.030D0,  0,222, 38, 30,  0,  0,
50028      & 324,0.020D0,  0,222, 21, 21,  0,  0,
50029      & 325,0.500D0,  0,275, 34,  0,  0,  0,
50030      & 325,0.500D0,  0,274, 42,  0,  0,  0,
50031      & 326,1.000D0,  0,230, 59,  0,  0,  0,
50032      & 327,0.667D0,  0, 50, 38,  0,  0,  0,
50033      & 327,0.333D0,  0, 46, 21,  0,  0,  0,
50034      & 328,0.667D0,  0, 46, 30,  0,  0,  0,
50035      & 328,0.333D0,  0, 50, 21,  0,  0,  0,
50036      & 329,0.667D0,  0, 34, 38,  0,  0,  0,
50037      & 329,0.333D0,  0, 42, 21,  0,  0,  0,
50038      & 330,0.667D0,  0, 42, 30,  0,  0,  0,
50039      & 330,0.333D0,  0, 34, 21,  0,  0,  0,
50040      & 331,0.667D0,  0,140, 38,  0,  0,  0,
50041      & 331,0.333D0,  0,136, 21,  0,  0,  0,
50042      & 332,0.667D0,  0,136, 30,  0,  0,  0,
50043      & 332,0.333D0,  0,140, 21,  0,  0,  0,
50044      & 333,0.500D0,  0,136, 50,  0,  0,  0,
50045      & 333,0.500D0,  0,140, 46,  0,  0,  0/
50046       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1920,1938)/
50047      & 334,0.667D0,  0,175, 30,  0,  0,  0,
50048      & 334,0.333D0,  0,171, 21,  0,  0,  0,
50049      & 335,0.667D0,  0,171, 38,  0,  0,  0,
50050      & 335,0.333D0,  0,175, 21,  0,  0,  0,
50051      & 336,0.500D0,  0,171, 42,  0,  0,  0,
50052      & 336,0.500D0,  0,175, 34,  0,  0,  0,
50053      & 337,0.667D0,  0,246, 30,  0,  0,  0,
50054      & 337,0.333D0,  0,245, 21,  0,  0,  0,
50055      & 338,0.667D0,  0,245, 38,  0,  0,  0,
50056      & 338,0.333D0,  0,246, 21,  0,  0,  0,
50057      & 339,0.500D0,  0,246, 34,  0,  0,  0,
50058      & 339,0.500D0,  0,245, 42,  0,  0,  0,
50059      & 340,1.000D0,  0,254, 59,  0,  0,  0,
50060      & 341,0.667D0,  0,222, 38,  0,  0,  0,
50061      & 341,0.333D0,  0,221, 21,  0,  0,  0,
50062      & 342,0.667D0,  0,221, 30,  0,  0,  0,
50063      & 342,0.333D0,  0,222, 21,  0,  0,  0,
50064      & 343,0.500D0,  0,222, 46,  0,  0,  0,
50065      & 343,0.500D0,  0,221, 50,  0,  0,  0/
50066       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1939,1957)/
50067      & 344,1.000D0,  0,230, 59,  0,  0,  0,
50068      & 345,1.000D0,  0,225, 30,  0,  0,  0,
50069      & 346,1.000D0,  0,225, 21,  0,  0,  0,
50070      & 347,1.000D0,  0,225, 21,  0,  0,  0,
50071      & 348,1.000D0,  0,225, 38,  0,  0,  0,
50072      & 349,0.600D0,  0,228, 38,  0,  0,  0,
50073      & 349,0.300D0,  0,227, 21,  0,  0,  0,
50074      & 349,0.100D0,  0,227, 59,  0,  0,  0,
50075      & 350,0.600D0,  0,228, 38,  0,  0,  0,
50076      & 350,0.300D0,  0,227, 21,  0,  0,  0,
50077      & 350,0.100D0,  0,227, 59,  0,  0,  0,
50078      & 351,0.600D0,  0,227, 30,  0,  0,  0,
50079      & 351,0.300D0,  0,228, 21,  0,  0,  0,
50080      & 351,0.100D0,  0,228, 59,  0,  0,  0,
50081      & 352,0.600D0,  0,227, 30,  0,  0,  0,
50082      & 352,0.300D0,  0,228, 21,  0,  0,  0,
50083      & 352,0.100D0,  0,228, 59,  0,  0,  0,
50084      & 353,1.000D0,  0,229, 59,  0,  0,  0,
50085      & 354,1.000D0,  0,249, 38,  0,  0,  0/
50086       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1958,1976)/
50087      & 355,1.000D0,  0,249, 21,  0,  0,  0,
50088      & 356,1.000D0,  0,249, 21,  0,  0,  0,
50089      & 357,1.000D0,  0,249, 30,  0,  0,  0,
50090      & 358,0.600D0,  0,252, 30,  0,  0,  0,
50091      & 358,0.300D0,  0,251, 21,  0,  0,  0,
50092      & 358,0.100D0,  0,251, 59,  0,  0,  0,
50093      & 359,0.600D0,  0,252, 30,  0,  0,  0,
50094      & 359,0.300D0,  0,251, 21,  0,  0,  0,
50095      & 359,0.100D0,  0,251, 59,  0,  0,  0,
50096      & 360,0.600D0,  0,251, 38,  0,  0,  0,
50097      & 360,0.300D0,  0,252, 21,  0,  0,  0,
50098      & 360,0.100D0,  0,252, 59,  0,  0,  0,
50099      & 361,0.600D0,  0,251, 38,  0,  0,  0,
50100      & 361,0.300D0,  0,252, 21,  0,  0,  0,
50101      & 361,0.100D0,  0,252, 59,  0,  0,  0,
50102      & 362,1.000D0,  0,253, 59,  0,  0,  0,
50103      & 363,0.400D0,  0, 53, 38,  0,  0,  0,
50104      & 363,0.200D0,  0, 49, 21,  0,  0,  0,
50105      & 363,0.100D0,  0, 51, 38,  0,  0,  0/
50106       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1977,1995)/
50107      & 363,0.050D0,  0, 47, 21,  0,  0,  0,
50108      & 363,0.150D0,  0, 46, 26,  0,  0,  0,
50109      & 363,0.050D0,  0, 46, 56,  0,  0,  0,
50110      & 363,0.050D0,  0, 46, 24,  0,  0,  0,
50111      & 364,0.400D0,  0, 49, 30,  0,  0,  0,
50112      & 364,0.200D0,  0, 53, 21,  0,  0,  0,
50113      & 364,0.100D0,  0, 47, 30,  0,  0,  0,
50114      & 364,0.050D0,  0, 51, 21,  0,  0,  0,
50115      & 364,0.150D0,  0, 50, 26,  0,  0,  0,
50116      & 364,0.050D0,  0, 50, 56,  0,  0,  0,
50117      & 364,0.050D0,  0, 50, 24,  0,  0,  0,
50118      & 365,0.400D0,  0, 37, 38,  0,  0,  0,
50119      & 365,0.200D0,  0, 45, 21,  0,  0,  0,
50120      & 365,0.100D0,  0, 35, 38,  0,  0,  0,
50121      & 365,0.050D0,  0, 43, 21,  0,  0,  0,
50122      & 365,0.150D0,  0, 42, 26,  0,  0,  0,
50123      & 365,0.050D0,  0, 42, 56,  0,  0,  0,
50124      & 365,0.050D0,  0, 42, 24,  0,  0,  0,
50125      & 366,0.400D0,  0, 45, 30,  0,  0,  0/
50126       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1996,2014)/
50127      & 366,0.200D0,  0, 37, 21,  0,  0,  0,
50128      & 366,0.100D0,  0, 43, 30,  0,  0,  0,
50129      & 366,0.050D0,  0, 35, 21,  0,  0,  0,
50130      & 366,0.150D0,  0, 34, 26,  0,  0,  0,
50131      & 366,0.050D0,  0, 34, 56,  0,  0,  0,
50132      & 366,0.050D0,  0, 34, 24,  0,  0,  0,
50133      & 367,0.258D0,  0, 50, 38,  0,  0,  0,
50134      & 367,0.129D0,  0, 46, 21,  0,  0,  0,
50135      & 367,0.209D0,  0, 50, 39,  0,  0,  0,
50136      & 367,0.105D0,  0, 46, 23,  0,  0,  0,
50137      & 367,0.199D0,  0, 51, 38,  0,  0,  0,
50138      & 367,0.100D0,  0, 47, 21,  0,  0,  0,
50139      & 368,0.258D0,  0, 46, 30,  0,  0,  0,
50140      & 368,0.129D0,  0, 50, 21,  0,  0,  0,
50141      & 368,0.209D0,  0, 46, 31,  0,  0,  0,
50142      & 368,0.105D0,  0, 50, 23,  0,  0,  0,
50143      & 368,0.199D0,  0, 47, 30,  0,  0,  0,
50144      & 368,0.100D0,  0, 51, 21,  0,  0,  0,
50145      & 369,0.258D0,  0, 34, 38,  0,  0,  0/
50146       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2015,2033)/
50147      & 369,0.129D0,  0, 42, 21,  0,  0,  0,
50148      & 369,0.209D0,  0, 34, 39,  0,  0,  0,
50149      & 369,0.105D0,  0, 42, 23,  0,  0,  0,
50150      & 369,0.199D0,  0, 35, 38,  0,  0,  0,
50151      & 369,0.100D0,  0, 43, 21,  0,  0,  0,
50152      & 370,0.258D0,  0, 42, 30,  0,  0,  0,
50153      & 370,0.129D0,  0, 34, 21,  0,  0,  0,
50154      & 370,0.209D0,  0, 42, 31,  0,  0,  0,
50155      & 370,0.105D0,  0, 34, 23,  0,  0,  0,
50156      & 370,0.199D0,  0, 43, 30,  0,  0,  0,
50157      & 370,0.100D0,  0, 35, 21,  0,  0,  0,
50158      & 371,0.400D0,  0, 53, 38,  0,  0,  0,
50159      & 371,0.200D0,  0, 49, 21,  0,  0,  0,
50160      & 371,0.100D0,  0, 51, 38,  0,  0,  0,
50161      & 371,0.050D0,  0, 47, 21,  0,  0,  0,
50162      & 371,0.150D0,  0, 46, 26,  0,  0,  0,
50163      & 371,0.050D0,  0, 46, 56,  0,  0,  0,
50164      & 371,0.050D0,  0, 46, 24,  0,  0,  0,
50165      & 372,0.400D0,  0, 49, 30,  0,  0,  0/
50166       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2034,2052)/
50167      & 372,0.200D0,  0, 53, 21,  0,  0,  0,
50168      & 372,0.100D0,  0, 47, 30,  0,  0,  0,
50169      & 372,0.050D0,  0, 51, 21,  0,  0,  0,
50170      & 372,0.150D0,  0, 50, 26,  0,  0,  0,
50171      & 372,0.050D0,  0, 50, 56,  0,  0,  0,
50172      & 372,0.050D0,  0, 50, 24,  0,  0,  0,
50173      & 373,0.400D0,  0, 37, 38,  0,  0,  0,
50174      & 373,0.200D0,  0, 45, 21,  0,  0,  0,
50175      & 373,0.100D0,  0, 35, 38,  0,  0,  0,
50176      & 373,0.050D0,  0, 43, 21,  0,  0,  0,
50177      & 373,0.150D0,  0, 42, 26,  0,  0,  0,
50178      & 373,0.050D0,  0, 42, 56,  0,  0,  0,
50179      & 373,0.050D0,  0, 42, 24,  0,  0,  0,
50180      & 374,0.400D0,  0, 45, 30,  0,  0,  0,
50181      & 374,0.200D0,  0, 37, 21,  0,  0,  0,
50182      & 374,0.100D0,  0, 43, 30,  0,  0,  0,
50183      & 374,0.050D0,  0, 35, 21,  0,  0,  0,
50184      & 374,0.150D0,  0, 34, 26,  0,  0,  0,
50185      & 374,0.050D0,  0, 34, 56,  0,  0,  0/
50186       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2053,2071)/
50187      & 374,0.050D0,  0, 34, 24,  0,  0,  0,
50188      & 375,0.208D0,  0, 50, 39,  0,  0,  0,
50189      & 375,0.104D0,  0, 46, 23,  0,  0,  0,
50190      & 375,0.134D0,  0, 51, 38,  0,  0,  0,
50191      & 375,0.067D0,  0, 47, 21,  0,  0,  0,
50192      & 375,0.124D0,  0, 50, 38,  0,  0,  0,
50193      & 375,0.062D0,  0, 46, 21,  0,  0,  0,
50194      & 375,0.301D0,  0, 46, 22,  0,  0,  0,
50195      & 376,0.208D0,  0, 46, 31,  0,  0,  0,
50196      & 376,0.104D0,  0, 50, 23,  0,  0,  0,
50197      & 376,0.134D0,  0, 47, 30,  0,  0,  0,
50198      & 376,0.067D0,  0, 51, 21,  0,  0,  0,
50199      & 376,0.124D0,  0, 46, 30,  0,  0,  0,
50200      & 376,0.062D0,  0, 50, 21,  0,  0,  0,
50201      & 376,0.301D0,  0, 50, 22,  0,  0,  0,
50202      & 377,0.208D0,  0, 34, 39,  0,  0,  0,
50203      & 377,0.104D0,  0, 42, 23,  0,  0,  0,
50204      & 377,0.134D0,  0, 35, 38,  0,  0,  0,
50205      & 377,0.067D0,  0, 43, 21,  0,  0,  0/
50206       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2072,2090)/
50207      & 377,0.124D0,  0, 34, 38,  0,  0,  0,
50208      & 377,0.062D0,  0, 42, 21,  0,  0,  0,
50209      & 377,0.301D0,  0, 42, 22,  0,  0,  0,
50210      & 378,0.208D0,  0, 42, 31,  0,  0,  0,
50211      & 378,0.104D0,  0, 34, 23,  0,  0,  0,
50212      & 378,0.134D0,  0, 43, 30,  0,  0,  0,
50213      & 378,0.067D0,  0, 35, 21,  0,  0,  0,
50214      & 378,0.124D0,  0, 42, 30,  0,  0,  0,
50215      & 378,0.062D0,  0, 34, 21,  0,  0,  0,
50216      & 378,0.301D0,  0, 34, 22,  0,  0,  0,
50217      & 379,0.562D0,  0, 26, 38,  0,  0,  0,
50218      & 379,0.155D0,  0, 39, 21,  0,  0,  0,
50219      & 379,0.155D0,  0, 23, 38,  0,  0,  0,
50220      & 379,0.088D0,  0,293, 38,  0,  0,  0,
50221      & 379,0.020D0,  0, 46, 43,  0,  0,  0,
50222      & 379,0.020D0,  0, 42, 47,  0,  0,  0,
50223      & 380,0.562D0,  0, 26, 21,  0,  0,  0,
50224      & 380,0.155D0,  0, 39, 30,  0,  0,  0,
50225      & 380,0.155D0,  0, 31, 38,  0,  0,  0/
50226       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2091,2109)/
50227      & 380,0.088D0,  0,293, 21,  0,  0,  0,
50228      & 380,0.010D0,  0, 46, 35,  0,  0,  0,
50229      & 380,0.010D0,  0, 50, 43,  0,  0,  0,
50230      & 380,0.010D0,  0, 34, 47,  0,  0,  0,
50231      & 380,0.010D0,  0, 42, 51,  0,  0,  0,
50232      & 381,0.562D0,  0, 26, 30,  0,  0,  0,
50233      & 381,0.155D0,  0, 31, 21,  0,  0,  0,
50234      & 381,0.155D0,  0, 23, 30,  0,  0,  0,
50235      & 381,0.088D0,  0,293, 30,  0,  0,  0,
50236      & 381,0.020D0,  0, 34, 51,  0,  0,  0,
50237      & 381,0.020D0,  0, 50, 35,  0,  0,  0,
50238      & 382,0.360D0,  0, 31, 38, 38,  0,  0,
50239      & 382,0.180D0,  0, 23, 38, 21,  0,  0,
50240      & 382,0.040D0,  0, 39, 21, 21,  0,  0,
50241      & 382,0.020D0,  0, 39, 38, 30,  0,  0,
50242      & 382,0.300D0,  0, 38, 21,  0,  0,  0,
50243      & 382,0.040D0,  0, 46, 43,  0,  0,  0,
50244      & 382,0.040D0,  0, 42, 47,  0,  0,  0,
50245      & 382,0.020D0,  0, 22, 39,  0,  0,  0/
50246       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2110,2128)/
50247      & 383,0.180D0,  0, 39, 30, 21,  0,  0,
50248      & 383,0.180D0,  0, 31, 38, 21,  0,  0,
50249      & 383,0.160D0,  0, 23, 21, 21,  0,  0,
50250      & 383,0.080D0,  0, 23, 38, 30,  0,  0,
50251      & 383,0.300D0,  0, 38, 30,  0,  0,  0,
50252      & 383,0.020D0,  0, 46, 35,  0,  0,  0,
50253      & 383,0.020D0,  0, 50, 43,  0,  0,  0,
50254      & 383,0.020D0,  0, 34, 47,  0,  0,  0,
50255      & 383,0.020D0,  0, 42, 51,  0,  0,  0,
50256      & 383,0.020D0,  0, 22, 23,  0,  0,  0,
50257      & 384,0.360D0,  0, 39, 30, 30,  0,  0,
50258      & 384,0.180D0,  0, 23, 30, 21,  0,  0,
50259      & 384,0.040D0,  0, 31, 21, 21,  0,  0,
50260      & 384,0.020D0,  0, 31, 30, 38,  0,  0,
50261      & 384,0.300D0,  0, 30, 21,  0,  0,  0,
50262      & 384,0.040D0,  0, 34, 51,  0,  0,  0,
50263      & 384,0.040D0,  0, 50, 35,  0,  0,  0,
50264      & 384,0.020D0,  0, 22, 31,  0,  0,  0,
50265      & 385,0.184D0,  0, 41, 21,  0,  0,  0/
50266       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2129,2147)/
50267      & 385,0.184D0,  0, 29, 38,  0,  0,  0,
50268      & 385,0.184D0,  0, 39, 23,  0,  0,  0,
50269      & 385,0.236D0,  0, 38, 21,  0,  0,  0,
50270      & 385,0.160D0,  0, 24, 38,  0,  0,  0,
50271      & 385,0.018D0,  0, 46, 43,  0,  0,  0,
50272      & 385,0.018D0,  0, 42, 47,  0,  0,  0,
50273      & 385,0.016D0,  0, 46, 42,  0,  0,  0,
50274      & 386,0.184D0,  0, 41, 30,  0,  0,  0,
50275      & 386,0.184D0,  0, 33, 38,  0,  0,  0,
50276      & 386,0.184D0,  0, 39, 31,  0,  0,  0,
50277      & 386,0.236D0,  0, 38, 30,  0,  0,  0,
50278      & 386,0.160D0,  0, 24, 21,  0,  0,  0,
50279      & 386,0.009D0,  0, 46, 35,  0,  0,  0,
50280      & 386,0.009D0,  0, 50, 43,  0,  0,  0,
50281      & 386,0.009D0,  0, 34, 47,  0,  0,  0,
50282      & 386,0.009D0,  0, 42, 51,  0,  0,  0,
50283      & 386,0.008D0,  0, 46, 34,  0,  0,  0,
50284      & 386,0.008D0,  0, 42, 50,  0,  0,  0,
50285      & 387,0.184D0,  0, 33, 21,  0,  0,  0/
50286       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2148,2166)/
50287      & 387,0.184D0,  0, 29, 30,  0,  0,  0,
50288      & 387,0.184D0,  0, 31, 23,  0,  0,  0,
50289      & 387,0.236D0,  0, 30, 21,  0,  0,  0,
50290      & 387,0.160D0,  0, 24, 30,  0,  0,  0,
50291      & 387,0.018D0,  0, 34, 51,  0,  0,  0,
50292      & 387,0.018D0,  0, 50, 35,  0,  0,  0,
50293      & 387,0.016D0,  0, 34, 50,  0,  0,  0,
50294      & 388,0.183D0,  0,231, 38, 30,  0,  0,
50295      & 388,0.091D0,  0,231, 21, 21,  0,  0,
50296      & 388,0.067D0,  0, 59,307,  0,  0,  0,
50297      & 388,0.066D0,  0, 59,308,  0,  0,  0,
50298      & 388,0.043D0,  0, 59,309,  0,  0,  0,
50299      & 388,0.446D0,130, 13, 13, 13,  0,  0,
50300      & 388,0.023D0,130, 13, 13, 59,  0,  0,
50301      & 388,0.013D0,  0,121,127,  0,  0,  0,
50302      & 388,0.013D0,  0,123,129,  0,  0,  0,
50303      & 388,0.013D0,  0,125,131,  0,  0,  0,
50304      & 388,0.004D0,  0,  1,  7,  0,  0,  0,
50305      & 388,0.017D0,  0,  2,  8,  0,  0,  0/
50306       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2167,2185)/
50307      & 388,0.004D0,  0,  3,  9,  0,  0,  0,
50308      & 388,0.017D0,  0,  4, 10,  0,  0,  0,
50309      & 389,0.046D0,  0, 59,388,  0,  0,  0,
50310      & 389,0.009D0,  0, 59,231,  0,  0,  0,
50311      & 389,0.755D0,  0, 13, 13,  0,  0,  0,
50312      & 389,0.030D0,  0,121,127,  0,  0,  0,
50313      & 389,0.030D0,  0,123,129,  0,  0,  0,
50314      & 389,0.030D0,  0,125,131,  0,  0,  0,
50315      & 389,0.010D0,  0,  1,  7,  0,  0,  0,
50316      & 389,0.040D0,  0,  2,  8,  0,  0,  0,
50317      & 389,0.010D0,  0,  3,  9,  0,  0,  0,
50318      & 389,0.040D0,  0,  4, 10,  0,  0,  0,
50319      & 390,0.210D0,  0, 59,388,  0,  0,  0,
50320      & 390,0.085D0,  0, 59,231,  0,  0,  0,
50321      & 390,0.565D0,  0, 13, 13,  0,  0,  0,
50322      & 390,0.022D0,  0,121,127,  0,  0,  0,
50323      & 390,0.022D0,  0,123,129,  0,  0,  0,
50324      & 390,0.022D0,  0,125,131,  0,  0,  0,
50325      & 390,0.007D0,  0,  1,  7,  0,  0,  0/
50326       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2186,2204)/
50327      & 390,0.030D0,  0,  2,  8,  0,  0,  0,
50328      & 390,0.007D0,  0,  3,  9,  0,  0,  0,
50329      & 390,0.030D0,  0,  4, 10,  0,  0,  0,
50330      & 391,0.162D0,  0, 59,388,  0,  0,  0,
50331      & 391,0.071D0,  0, 59,231,  0,  0,  0,
50332      & 391,0.615D0,  0, 13, 13,  0,  0,  0,
50333      & 391,0.024D0,  0,121,127,  0,  0,  0,
50334      & 391,0.024D0,  0,123,129,  0,  0,  0,
50335      & 391,0.024D0,  0,125,131,  0,  0,  0,
50336      & 391,0.008D0,  0,  1,  7,  0,  0,  0,
50337      & 391,0.032D0,  0,  2,  8,  0,  0,  0,
50338      & 391,0.008D0,  0,  3,  9,  0,  0,  0,
50339      & 391,0.032D0,  0,  4, 10,  0,  0,  0,
50340      & 392,0.034D0,  0,267, 38, 30,  0,  0,
50341      & 392,0.017D0,  0,267, 21, 21,  0,  0,
50342      & 392,0.044D0,  0,231, 38, 30,  0,  0,
50343      & 392,0.022D0,  0,231, 21, 21,  0,  0,
50344      & 392,0.050D0,  0,267, 59, 59,  0,  0,
50345      & 392,0.114D0,  0, 59,389,  0,  0,  0/
50346       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2205,2223)/
50347      & 392,0.113D0,  0, 59,390,  0,  0,  0,
50348      & 392,0.054D0,  0, 59,391,  0,  0,  0,
50349      & 392,0.403D0,130, 13, 13, 13,  0,  0,
50350      & 392,0.021D0,130, 13, 13, 59,  0,  0,
50351      & 392,0.020D0,  0,121,127,  0,  0,  0,
50352      & 392,0.020D0,  0,123,129,  0,  0,  0,
50353      & 392,0.020D0,  0,125,131,  0,  0,  0,
50354      & 392,0.007D0,  0,  1,  7,  0,  0,  0,
50355      & 392,0.027D0,  0,  2,  8,  0,  0,  0,
50356      & 392,0.007D0,  0,  3,  9,  0,  0,  0,
50357      & 392,0.027D0,  0,  4, 10,  0,  0,  0,
50358      & 393,0.250D0,  0,246,222,  0,  0,  0,
50359      & 393,0.250D0,  0,245,221,  0,  0,  0,
50360      & 393,0.385D0,130, 13, 13, 13,  0,  0,
50361      & 393,0.020D0,130, 13, 13, 59,  0,  0,
50362      & 393,0.015D0,  0,121,127,  0,  0,  0,
50363      & 393,0.015D0,  0,123,129,  0,  0,  0,
50364      & 393,0.015D0,  0,125,131,  0,  0,  0,
50365      & 393,0.005D0,  0,  1,  7,  0,  0,  0/
50366       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2224,2242)/
50367      & 393,0.020D0,  0,  2,  8,  0,  0,  0,
50368      & 393,0.005D0,  0,  3,  9,  0,  0,  0,
50369      & 393,0.020D0,  0,  4, 10,  0,  0,  0,
50370      & 395,0.195D0,  0, 39, 30,  0,  0,  0,
50371      & 395,0.195D0,  0, 23, 21,  0,  0,  0,
50372      & 395,0.195D0,  0, 31, 38,  0,  0,  0,
50373      & 395,0.105D0,  0,286, 30,  0,  0,  0,
50374      & 395,0.105D0,  0,285, 21,  0,  0,  0,
50375      & 395,0.105D0,  0,287, 38,  0,  0,  0,
50376      & 395,0.065D0,  0, 24, 38, 30,  0,  0,
50377      & 395,0.035D0,  0, 24, 21, 21,  0,  0,
50378      & 396,0.320D0,  0, 46, 34,  0,  0,  0,
50379      & 396,0.320D0,  0, 60, 61,  0,  0,  0,
50380      & 396,0.090D0,  0, 46, 35,  0,  0,  0,
50381      & 396,0.090D0,  0, 42, 51,  0,  0,  0,
50382      & 396,0.090D0,  0, 50, 43,  0,  0,  0,
50383      & 396,0.090D0,  0, 34, 47,  0,  0,  0,
50384      & 397,0.312D0,  0, 41, 30,  0,  0,  0,
50385      & 397,0.312D0,  0, 29, 21,  0,  0,  0/
50386       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2243,2261)/
50387      & 397,0.312D0,  0, 33, 38,  0,  0,  0,
50388      & 397,0.016D0,  0, 46, 35,  0,  0,  0,
50389      & 397,0.016D0,  0, 42, 51,  0,  0,  0,
50390      & 397,0.016D0,  0, 50, 43,  0,  0,  0,
50391      & 397,0.016D0,  0, 34, 47,  0,  0,  0,
50392      & 398,0.805D0,  0, 26, 22,  0,  0,  0,
50393      & 398,0.065D0,  0, 41, 30,  0,  0,  0,
50394      & 398,0.065D0,  0, 29, 21,  0,  0,  0,
50395      & 398,0.065D0,  0, 33, 38,  0,  0,  0,
50396      & 399,0.667D0,  0, 24, 38, 30,  0,  0,
50397      & 399,0.333D0,  0, 24, 21, 21,  0,  0,
50398      &  62,0.440D0,  0, 21, 22,  0,  0,  0,
50399      &  62,0.160D0,  0, 21, 25,  0,  0,  0,
50400      &  62,0.200D0,  0, 50, 42,  0,  0,  0,
50401      &  62,0.200D0,  0, 46, 34,  0,  0,  0,
50402      &  63,0.440D0,  0, 38, 22,  0,  0,  0,
50403      &  63,0.160D0,  0, 38, 25,  0,  0,  0,
50404      &  63,0.400D0,  0, 46, 42,  0,  0,  0,
50405      &  64,0.440D0,  0, 30, 22,  0,  0,  0/
50406       DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2262,2263)/
50407      &  64,0.160D0,  0, 30, 25,  0,  0,  0,
50408      &  64,0.400D0,  0, 50, 34,  0,  0,  0/
50409 C--data for MRST98 LO PDF's
50410       DATA (FMRS(1,1,I, 1),I=1,49)/
50411      &     0.01518D0,  0.01868D0,  0.02298D0,  0.02594D0,  0.02828D0,
50412      &     0.03023D0,  0.03724D0,  0.04592D0,  0.05197D0,  0.05679D0,
50413      &     0.06085D0,  0.07576D0,  0.09547D0,  0.11035D0,  0.12307D0,
50414      &     0.13453D0,  0.15525D0,  0.18319D0,  0.22542D0,  0.26441D0,
50415      &     0.33553D0,  0.39881D0,  0.45451D0,  0.51363D0,  0.56120D0,
50416      &     0.59755D0,  0.62324D0,  0.63889D0,  0.64529D0,  0.64295D0,
50417      &     0.63335D0,  0.61691D0,  0.59464D0,  0.56748D0,  0.53621D0,
50418      &     0.50180D0,  0.46495D0,  0.42660D0,  0.38735D0,  0.34791D0,
50419      &     0.30888D0,  0.27105D0,  0.23455D0,  0.16807D0,  0.11197D0,
50420      &     0.06774D0,  0.03566D0,  0.00443D0,  0.00000D0/
50421       DATA (FMRS(1,1,I, 2),I=1,49)/
50422      &     0.01534D0,  0.01889D0,  0.02325D0,  0.02625D0,  0.02862D0,
50423      &     0.03061D0,  0.03771D0,  0.04653D0,  0.05268D0,  0.05757D0,
50424      &     0.06171D0,  0.07691D0,  0.09707D0,  0.11230D0,  0.12533D0,
50425      &     0.13708D0,  0.15827D0,  0.18678D0,  0.22968D0,  0.26907D0,
50426      &     0.34038D0,  0.40321D0,  0.45801D0,  0.51556D0,  0.56122D0,
50427      &     0.59551D0,  0.61905D0,  0.63261D0,  0.63699D0,  0.63286D0,
50428      &     0.62162D0,  0.60381D0,  0.58043D0,  0.55244D0,  0.52060D0,
50429      &     0.48591D0,  0.44902D0,  0.41090D0,  0.37213D0,  0.33332D0,
50430      &     0.29514D0,  0.25827D0,  0.22283D0,  0.15873D0,  0.10506D0,
50431      &     0.06310D0,  0.03294D0,  0.00399D0,  0.00000D0/
50432       DATA (FMRS(1,1,I, 3),I=1,49)/
50433      &     0.01559D0,  0.01920D0,  0.02365D0,  0.02672D0,  0.02914D0,
50434      &     0.03116D0,  0.03842D0,  0.04744D0,  0.05374D0,  0.05876D0,
50435      &     0.06301D0,  0.07866D0,  0.09949D0,  0.11525D0,  0.12874D0,
50436      &     0.14090D0,  0.16278D0,  0.19212D0,  0.23598D0,  0.27589D0,
50437      &     0.34735D0,  0.40941D0,  0.46279D0,  0.51792D0,  0.56073D0,
50438      &     0.59195D0,  0.61237D0,  0.62289D0,  0.62439D0,  0.61773D0,
50439      &     0.60419D0,  0.58448D0,  0.55962D0,  0.53052D0,  0.49799D0,
50440      &     0.46298D0,  0.42617D0,  0.38844D0,  0.35048D0,  0.31268D0,
50441      &     0.27573D0,  0.24031D0,  0.20643D0,  0.14575D0,  0.09554D0,
50442      &     0.05679D0,  0.02927D0,  0.00342D0,  0.00000D0/
50443       DATA (FMRS(1,1,I, 4),I=1,49)/
50444      &     0.01577D0,  0.01944D0,  0.02395D0,  0.02707D0,  0.02952D0,
50445      &     0.03158D0,  0.03895D0,  0.04812D0,  0.05453D0,  0.05964D0,
50446      &     0.06398D0,  0.07996D0,  0.10128D0,  0.11743D0,  0.13126D0,
50447      &     0.14371D0,  0.16610D0,  0.19602D0,  0.24052D0,  0.28078D0,
50448      &     0.35225D0,  0.41367D0,  0.46596D0,  0.51926D0,  0.56000D0,
50449      &     0.58897D0,  0.60716D0,  0.61554D0,  0.61505D0,  0.60661D0,
50450      &     0.59150D0,  0.57049D0,  0.54465D0,  0.51484D0,  0.48194D0,
50451      &     0.44680D0,  0.41012D0,  0.37271D0,  0.33536D0,  0.29833D0,
50452      &     0.26227D0,  0.22791D0,  0.19519D0,  0.13692D0,  0.08913D0,
50453      &     0.05257D0,  0.02685D0,  0.00306D0,  0.00000D0/
50454       DATA (FMRS(1,1,I, 5),I=1,49)/
50455      &     0.01597D0,  0.01969D0,  0.02427D0,  0.02744D0,  0.02993D0,
50456      &     0.03202D0,  0.03952D0,  0.04885D0,  0.05537D0,  0.06058D0,
50457      &     0.06501D0,  0.08134D0,  0.10319D0,  0.11975D0,  0.13393D0,
50458      &     0.14669D0,  0.16958D0,  0.20009D0,  0.24521D0,  0.28578D0,
50459      &     0.35715D0,  0.41781D0,  0.46887D0,  0.52022D0,  0.55877D0,
50460      &     0.58539D0,  0.60126D0,  0.60744D0,  0.60489D0,  0.59469D0,
50461      &     0.57807D0,  0.55581D0,  0.52903D0,  0.49861D0,  0.46535D0,
50462      &     0.43012D0,  0.39368D0,  0.35672D0,  0.32002D0,  0.28380D0,
50463      &     0.24878D0,  0.21549D0,  0.18398D0,  0.12819D0,  0.08284D0,
50464      &     0.04845D0,  0.02451D0,  0.00272D0,  0.00000D0/
50465       DATA (FMRS(1,1,I, 6),I=1,49)/
50466      &     0.01613D0,  0.01990D0,  0.02455D0,  0.02776D0,  0.03029D0,
50467      &     0.03241D0,  0.04001D0,  0.04949D0,  0.05611D0,  0.06141D0,
50468      &     0.06592D0,  0.08256D0,  0.10485D0,  0.12178D0,  0.13626D0,
50469      &     0.14927D0,  0.17260D0,  0.20361D0,  0.24924D0,  0.29005D0,
50470      &     0.36128D0,  0.42124D0,  0.47121D0,  0.52086D0,  0.55750D0,
50471      &     0.58213D0,  0.59603D0,  0.60035D0,  0.59612D0,  0.58445D0,
50472      &     0.56659D0,  0.54334D0,  0.51581D0,  0.48493D0,  0.45142D0,
50473      &     0.41618D0,  0.37998D0,  0.34345D0,  0.30732D0,  0.27182D0,
50474      &     0.23768D0,  0.20532D0,  0.17482D0,  0.12110D0,  0.07777D0,
50475      &     0.04515D0,  0.02267D0,  0.00245D0,  0.00000D0/
50476       DATA (FMRS(1,1,I, 7),I=1,49)/
50477      &     0.01630D0,  0.02011D0,  0.02482D0,  0.02807D0,  0.03063D0,
50478      &     0.03278D0,  0.04049D0,  0.05010D0,  0.05683D0,  0.06221D0,
50479      &     0.06680D0,  0.08373D0,  0.10647D0,  0.12373D0,  0.13849D0,
50480      &     0.15175D0,  0.17549D0,  0.20695D0,  0.25304D0,  0.29403D0,
50481      &     0.36506D0,  0.42430D0,  0.47319D0,  0.52118D0,  0.55597D0,
50482      &     0.57870D0,  0.59079D0,  0.59337D0,  0.58760D0,  0.57458D0,
50483      &     0.55556D0,  0.53145D0,  0.50329D0,  0.47196D0,  0.43832D0,
50484      &     0.40316D0,  0.36719D0,  0.33110D0,  0.29555D0,  0.26076D0,
50485      &     0.22742D0,  0.19600D0,  0.16642D0,  0.11467D0,  0.07318D0,
50486      &     0.04221D0,  0.02103D0,  0.00223D0,  0.00000D0/
50487       DATA (FMRS(1,1,I, 8),I=1,49)/
50488      &     0.01647D0,  0.02033D0,  0.02511D0,  0.02840D0,  0.03100D0,
50489      &     0.03318D0,  0.04101D0,  0.05076D0,  0.05760D0,  0.06307D0,
50490      &     0.06774D0,  0.08499D0,  0.10819D0,  0.12581D0,  0.14088D0,
50491      &     0.15440D0,  0.17856D0,  0.21047D0,  0.25702D0,  0.29817D0,
50492      &     0.36893D0,  0.42735D0,  0.47507D0,  0.52128D0,  0.55411D0,
50493      &     0.57487D0,  0.58505D0,  0.58586D0,  0.57850D0,  0.56412D0,
50494      &     0.54397D0,  0.51898D0,  0.49021D0,  0.45851D0,  0.42474D0,
50495      &     0.38970D0,  0.35404D0,  0.31842D0,  0.28351D0,  0.24949D0,
50496      &     0.21700D0,  0.18654D0,  0.15795D0,  0.10821D0,  0.06861D0,
50497      &     0.03930D0,  0.01942D0,  0.00201D0,  0.00000D0/
50498       DATA (FMRS(1,1,I, 9),I=1,49)/
50499      &     0.01662D0,  0.02053D0,  0.02536D0,  0.02869D0,  0.03133D0,
50500      &     0.03353D0,  0.04146D0,  0.05135D0,  0.05828D0,  0.06382D0,
50501      &     0.06856D0,  0.08610D0,  0.10971D0,  0.12764D0,  0.14296D0,
50502      &     0.15670D0,  0.18121D0,  0.21352D0,  0.26045D0,  0.30172D0,
50503      &     0.37220D0,  0.42986D0,  0.47655D0,  0.52120D0,  0.55234D0,
50504      &     0.57141D0,  0.57995D0,  0.57927D0,  0.57058D0,  0.55506D0,
50505      &     0.53402D0,  0.50830D0,  0.47904D0,  0.44709D0,  0.41323D0,
50506      &     0.37832D0,  0.34296D0,  0.30776D0,  0.27344D0,  0.24008D0,
50507      &     0.20833D0,  0.17868D0,  0.15093D0,  0.10287D0,  0.06487D0,
50508      &     0.03693D0,  0.01812D0,  0.00183D0,  0.00000D0/
50509       DATA (FMRS(1,1,I,10),I=1,49)/
50510      &     0.01676D0,  0.02072D0,  0.02560D0,  0.02898D0,  0.03164D0,
50511      &     0.03388D0,  0.04190D0,  0.05191D0,  0.05894D0,  0.06456D0,
50512      &     0.06937D0,  0.08718D0,  0.11117D0,  0.12940D0,  0.14497D0,
50513      &     0.15892D0,  0.18377D0,  0.21643D0,  0.26368D0,  0.30503D0,
50514      &     0.37520D0,  0.43209D0,  0.47774D0,  0.52089D0,  0.55041D0,
50515      &     0.56787D0,  0.57486D0,  0.57280D0,  0.56285D0,  0.54631D0,
50516      &     0.52442D0,  0.49810D0,  0.46842D0,  0.43624D0,  0.40236D0,
50517      &     0.36762D0,  0.33255D0,  0.29778D0,  0.26402D0,  0.23132D0,
50518      &     0.20029D0,  0.17139D0,  0.14445D0,  0.09798D0,  0.06147D0,
50519      &     0.03479D0,  0.01695D0,  0.00168D0,  0.00000D0/
50520       DATA (FMRS(1,1,I,11),I=1,49)/
50521      &     0.01688D0,  0.02087D0,  0.02580D0,  0.02920D0,  0.03189D0,
50522      &     0.03415D0,  0.04225D0,  0.05236D0,  0.05946D0,  0.06515D0,
50523      &     0.07001D0,  0.08804D0,  0.11234D0,  0.13081D0,  0.14657D0,
50524      &     0.16068D0,  0.18579D0,  0.21873D0,  0.26622D0,  0.30762D0,
50525      &     0.37751D0,  0.43378D0,  0.47859D0,  0.52054D0,  0.54880D0,
50526      &     0.56500D0,  0.57079D0,  0.56765D0,  0.55675D0,  0.53942D0,
50527      &     0.51689D0,  0.49012D0,  0.46015D0,  0.42782D0,  0.39393D0,
50528      &     0.35936D0,  0.32453D0,  0.29009D0,  0.25678D0,  0.22461D0,
50529      &     0.19416D0,  0.16583D0,  0.13951D0,  0.09427D0,  0.05892D0,
50530      &     0.03318D0,  0.01609D0,  0.00157D0,  0.00000D0/
50531       DATA (FMRS(1,1,I,12),I=1,49)/
50532      &     0.01713D0,  0.02119D0,  0.02622D0,  0.02969D0,  0.03243D0,
50533      &     0.03474D0,  0.04300D0,  0.05334D0,  0.06060D0,  0.06641D0,
50534      &     0.07140D0,  0.08989D0,  0.11485D0,  0.13381D0,  0.14997D0,
50535      &     0.16442D0,  0.19008D0,  0.22357D0,  0.27152D0,  0.31299D0,
50536      &     0.38219D0,  0.43708D0,  0.48008D0,  0.51946D0,  0.54505D0,
50537      &     0.55859D0,  0.56192D0,  0.55654D0,  0.54370D0,  0.52483D0,
50538      &     0.50100D0,  0.47335D0,  0.44283D0,  0.41025D0,  0.37649D0,
50539      &     0.34225D0,  0.30799D0,  0.27433D0,  0.24202D0,  0.21092D0,
50540      &     0.18167D0,  0.15459D0,  0.12954D0,  0.08683D0,  0.05380D0,
50541      &     0.03001D0,  0.01438D0,  0.00136D0,  0.00000D0/
50542       DATA (FMRS(1,1,I,13),I=1,49)/
50543      &     0.01734D0,  0.02147D0,  0.02658D0,  0.03011D0,  0.03290D0,
50544      &     0.03525D0,  0.04366D0,  0.05419D0,  0.06158D0,  0.06752D0,
50545      &     0.07261D0,  0.09150D0,  0.11703D0,  0.13641D0,  0.15292D0,
50546      &     0.16765D0,  0.19375D0,  0.22769D0,  0.27599D0,  0.31747D0,
50547      &     0.38599D0,  0.43964D0,  0.48105D0,  0.51822D0,  0.54152D0,
50548      &     0.55284D0,  0.55412D0,  0.54689D0,  0.53251D0,  0.51240D0,
50549      &     0.48756D0,  0.45925D0,  0.42833D0,  0.39563D0,  0.36202D0,
50550      &     0.32809D0,  0.29438D0,  0.26143D0,  0.22998D0,  0.19977D0,
50551      &     0.17155D0,  0.14553D0,  0.12155D0,  0.08091D0,  0.04976D0,
50552      &     0.02753D0,  0.01306D0,  0.00120D0,  0.00000D0/
50553       DATA (FMRS(1,1,I,14),I=1,49)/
50554      &     0.01759D0,  0.02179D0,  0.02699D0,  0.03059D0,  0.03343D0,
50555      &     0.03582D0,  0.04441D0,  0.05515D0,  0.06270D0,  0.06876D0,
50556      &     0.07397D0,  0.09331D0,  0.11948D0,  0.13933D0,  0.15621D0,
50557      &     0.17125D0,  0.19782D0,  0.23224D0,  0.28086D0,  0.32228D0,
50558      &     0.38998D0,  0.44216D0,  0.48181D0,  0.51649D0,  0.53727D0,
50559      &     0.54619D0,  0.54525D0,  0.53606D0,  0.52007D0,  0.49864D0,
50560      &     0.47286D0,  0.44390D0,  0.41261D0,  0.37987D0,  0.34645D0,
50561      &     0.31295D0,  0.27985D0,  0.24773D0,  0.21718D0,  0.18802D0,
50562      &     0.16091D0,  0.13605D0,  0.11323D0,  0.07479D0,  0.04562D0,
50563      &     0.02500D0,  0.01174D0,  0.00105D0,  0.00000D0/
50564       DATA (FMRS(1,1,I,15),I=1,49)/
50565      &     0.01784D0,  0.02212D0,  0.02742D0,  0.03109D0,  0.03399D0,
50566      &     0.03643D0,  0.04519D0,  0.05616D0,  0.06388D0,  0.07007D0,
50567      &     0.07541D0,  0.09522D0,  0.12203D0,  0.14235D0,  0.15961D0,
50568      &     0.17496D0,  0.20199D0,  0.23684D0,  0.28574D0,  0.32703D0,
50569      &     0.39374D0,  0.44435D0,  0.48208D0,  0.51422D0,  0.53243D0,
50570      &     0.53888D0,  0.53581D0,  0.52470D0,  0.50714D0,  0.48444D0,
50571      &     0.45778D0,  0.42824D0,  0.39670D0,  0.36400D0,  0.33079D0,
50572      &     0.29784D0,  0.26546D0,  0.23422D0,  0.20462D0,  0.17657D0,
50573      &     0.15056D0,  0.12684D0,  0.10517D0,  0.06893D0,  0.04169D0,
50574      &     0.02264D0,  0.01051D0,  0.00091D0,  0.00000D0/
50575       DATA (FMRS(1,1,I,16),I=1,49)/
50576      &     0.01807D0,  0.02243D0,  0.02782D0,  0.03155D0,  0.03450D0,
50577      &     0.03698D0,  0.04591D0,  0.05708D0,  0.06495D0,  0.07127D0,
50578      &     0.07672D0,  0.09696D0,  0.12435D0,  0.14510D0,  0.16268D0,
50579      &     0.17830D0,  0.20573D0,  0.24094D0,  0.29002D0,  0.33115D0,
50580      &     0.39689D0,  0.44603D0,  0.48202D0,  0.51185D0,  0.52778D0,
50581      &     0.53213D0,  0.52713D0,  0.51440D0,  0.49550D0,  0.47182D0,
50582      &     0.44444D0,  0.41444D0,  0.38277D0,  0.35014D0,  0.31726D0,
50583      &     0.28479D0,  0.25306D0,  0.22258D0,  0.19389D0,  0.16682D0,
50584      &     0.14175D0,  0.11905D0,  0.09839D0,  0.06403D0,  0.03844D0,
50585      &     0.02069D0,  0.00951D0,  0.00080D0,  0.00000D0/
50586       DATA (FMRS(1,1,I,17),I=1,49)/
50587      &     0.01831D0,  0.02273D0,  0.02822D0,  0.03202D0,  0.03502D0,
50588      &     0.03755D0,  0.04663D0,  0.05802D0,  0.06604D0,  0.07249D0,
50589      &     0.07805D0,  0.09872D0,  0.12670D0,  0.14787D0,  0.16578D0,
50590      &     0.18165D0,  0.20947D0,  0.24500D0,  0.29423D0,  0.33515D0,
50591      &     0.39986D0,  0.44747D0,  0.48171D0,  0.50924D0,  0.52291D0,
50592      &     0.52522D0,  0.51836D0,  0.50409D0,  0.48395D0,  0.45934D0,
50593      &     0.43132D0,  0.40095D0,  0.36919D0,  0.33668D0,  0.30419D0,
50594      &     0.27223D0,  0.24118D0,  0.21147D0,  0.18368D0,  0.15756D0,
50595      &     0.13343D0,  0.11172D0,  0.09203D0,  0.05947D0,  0.03543D0,
50596      &     0.01891D0,  0.00861D0,  0.00070D0,  0.00000D0/
50597       DATA (FMRS(1,1,I,18),I=1,49)/
50598      &     0.01851D0,  0.02299D0,  0.02855D0,  0.03241D0,  0.03546D0,
50599      &     0.03802D0,  0.04724D0,  0.05881D0,  0.06696D0,  0.07351D0,
50600      &     0.07917D0,  0.10019D0,  0.12865D0,  0.15015D0,  0.16833D0,
50601      &     0.18440D0,  0.21252D0,  0.24831D0,  0.29761D0,  0.33832D0,
50602      &     0.40212D0,  0.44845D0,  0.48121D0,  0.50687D0,  0.51871D0,
50603      &     0.51934D0,  0.51104D0,  0.49556D0,  0.47446D0,  0.44911D0,
50604      &     0.42066D0,  0.39005D0,  0.35822D0,  0.32587D0,  0.29370D0,
50605      &     0.26224D0,  0.23174D0,  0.20270D0,  0.17561D0,  0.15023D0,
50606      &     0.12693D0,  0.10599D0,  0.08707D0,  0.05595D0,  0.03312D0,
50607      &     0.01756D0,  0.00793D0,  0.00063D0,  0.00000D0/
50608       DATA (FMRS(1,1,I,19),I=1,49)/
50609      &     0.01875D0,  0.02330D0,  0.02896D0,  0.03288D0,  0.03599D0,
50610      &     0.03859D0,  0.04798D0,  0.05977D0,  0.06807D0,  0.07475D0,
50611      &     0.08052D0,  0.10198D0,  0.13101D0,  0.15292D0,  0.17139D0,
50612      &     0.18771D0,  0.21617D0,  0.25222D0,  0.30155D0,  0.34198D0,
50613      &     0.40461D0,  0.44935D0,  0.48033D0,  0.50374D0,  0.51343D0,
50614      &     0.51210D0,  0.50212D0,  0.48526D0,  0.46307D0,  0.43693D0,
50615      &     0.40797D0,  0.37715D0,  0.34533D0,  0.31321D0,  0.28148D0,
50616      &     0.25058D0,  0.22080D0,  0.19255D0,  0.16635D0,  0.14187D0,
50617      &     0.11948D0,  0.09946D0,  0.08142D0,  0.05198D0,  0.03054D0,
50618      &     0.01606D0,  0.00718D0,  0.00056D0,  0.00000D0/
50619       DATA (FMRS(1,1,I,20),I=1,49)/
50620      &     0.01896D0,  0.02358D0,  0.02932D0,  0.03331D0,  0.03646D0,
50621      &     0.03911D0,  0.04864D0,  0.06062D0,  0.06906D0,  0.07585D0,
50622      &     0.08173D0,  0.10357D0,  0.13310D0,  0.15536D0,  0.17410D0,
50623      &     0.19062D0,  0.21937D0,  0.25563D0,  0.30495D0,  0.34510D0,
50624      &     0.40666D0,  0.44998D0,  0.47941D0,  0.50085D0,  0.50868D0,
50625      &     0.50571D0,  0.49430D0,  0.47628D0,  0.45320D0,  0.42642D0,
50626      &     0.39707D0,  0.36611D0,  0.33435D0,  0.30245D0,  0.27113D0,
50627      &     0.24074D0,  0.21159D0,  0.18404D0,  0.15862D0,  0.13491D0,
50628      &     0.11330D0,  0.09405D0,  0.07676D0,  0.04872D0,  0.02844D0,
50629      &     0.01484D0,  0.00658D0,  0.00050D0,  0.00000D0/
50630       DATA (FMRS(1,1,I,21),I=1,49)/
50631      &     0.01916D0,  0.02384D0,  0.02966D0,  0.03370D0,  0.03689D0,
50632      &     0.03958D0,  0.04926D0,  0.06141D0,  0.06998D0,  0.07687D0,
50633      &     0.08284D0,  0.10503D0,  0.13502D0,  0.15758D0,  0.17655D0,
50634      &     0.19325D0,  0.22223D0,  0.25866D0,  0.30794D0,  0.34779D0,
50635      &     0.40831D0,  0.45032D0,  0.47832D0,  0.49795D0,  0.50413D0,
50636      &     0.49968D0,  0.48705D0,  0.46802D0,  0.44417D0,  0.41690D0,
50637      &     0.38723D0,  0.35619D0,  0.32452D0,  0.29287D0,  0.26194D0,
50638      &     0.23205D0,  0.20344D0,  0.17655D0,  0.15180D0,  0.12880D0,
50639      &     0.10792D0,  0.08934D0,  0.07273D0,  0.04591D0,  0.02665D0,
50640      &     0.01381D0,  0.00607D0,  0.00045D0,  0.00000D0/
50641       DATA (FMRS(1,1,I,22),I=1,49)/
50642      &     0.01941D0,  0.02417D0,  0.03009D0,  0.03420D0,  0.03745D0,
50643      &     0.04018D0,  0.05003D0,  0.06241D0,  0.07114D0,  0.07817D0,
50644      &     0.08426D0,  0.10688D0,  0.13744D0,  0.16039D0,  0.17965D0,
50645      &     0.19656D0,  0.22582D0,  0.26244D0,  0.31163D0,  0.35107D0,
50646      &     0.41025D0,  0.45056D0,  0.47676D0,  0.49416D0,  0.49829D0,
50647      &     0.49204D0,  0.47792D0,  0.45768D0,  0.43295D0,  0.40511D0,
50648      &     0.37512D0,  0.34401D0,  0.31250D0,  0.28120D0,  0.25076D0,
50649      &     0.22150D0,  0.19361D0,  0.16754D0,  0.14361D0,  0.12149D0,
50650      &     0.10149D0,  0.08376D0,  0.06796D0,  0.04260D0,  0.02455D0,
50651      &     0.01262D0,  0.00549D0,  0.00039D0,  0.00000D0/
50652       DATA (FMRS(1,1,I,23),I=1,49)/
50653      &     0.01965D0,  0.02448D0,  0.03049D0,  0.03467D0,  0.03797D0,
50654      &     0.04075D0,  0.05077D0,  0.06336D0,  0.07225D0,  0.07940D0,
50655      &     0.08560D0,  0.10863D0,  0.13972D0,  0.16302D0,  0.18254D0,
50656      &     0.19964D0,  0.22916D0,  0.26592D0,  0.31498D0,  0.35400D0,
50657      &     0.41189D0,  0.45060D0,  0.47511D0,  0.49045D0,  0.49274D0,
50658      &     0.48487D0,  0.46938D0,  0.44808D0,  0.42260D0,  0.39428D0,
50659      &     0.36409D0,  0.33294D0,  0.30164D0,  0.27069D0,  0.24070D0,
50660      &     0.21203D0,  0.18488D0,  0.15951D0,  0.13633D0,  0.11502D0,
50661      &     0.09581D0,  0.07887D0,  0.06380D0,  0.03974D0,  0.02273D0,
50662      &     0.01159D0,  0.00500D0,  0.00035D0,  0.00000D0/
50663       DATA (FMRS(1,1,I,24),I=1,49)/
50664      &     0.01987D0,  0.02478D0,  0.03088D0,  0.03511D0,  0.03847D0,
50665      &     0.04129D0,  0.05147D0,  0.06426D0,  0.07329D0,  0.08055D0,
50666      &     0.08686D0,  0.11027D0,  0.14184D0,  0.16546D0,  0.18521D0,
50667      &     0.20248D0,  0.23220D0,  0.26906D0,  0.31795D0,  0.35654D0,
50668      &     0.41317D0,  0.45035D0,  0.47330D0,  0.48677D0,  0.48734D0,
50669      &     0.47799D0,  0.46135D0,  0.43917D0,  0.41301D0,  0.38430D0,
50670      &     0.35392D0,  0.32282D0,  0.29171D0,  0.26113D0,  0.23164D0,
50671      &     0.20355D0,  0.17701D0,  0.15231D0,  0.12990D0,  0.10928D0,
50672      &     0.09079D0,  0.07455D0,  0.06012D0,  0.03723D0,  0.02116D0,
50673      &     0.01072D0,  0.00459D0,  0.00031D0,  0.00000D0/
50674       DATA (FMRS(1,1,I,25),I=1,49)/
50675      &     0.02010D0,  0.02507D0,  0.03126D0,  0.03556D0,  0.03897D0,
50676      &     0.04183D0,  0.05216D0,  0.06515D0,  0.07433D0,  0.08171D0,
50677      &     0.08812D0,  0.11191D0,  0.14397D0,  0.16790D0,  0.18786D0,
50678      &     0.20530D0,  0.23522D0,  0.27216D0,  0.32085D0,  0.35900D0,
50679      &     0.41434D0,  0.45001D0,  0.47142D0,  0.48304D0,  0.48197D0,
50680      &     0.47120D0,  0.45346D0,  0.43043D0,  0.40367D0,  0.37460D0,
50681      &     0.34407D0,  0.31306D0,  0.28215D0,  0.25197D0,  0.22296D0,
50682      &     0.19546D0,  0.16953D0,  0.14549D0,  0.12381D0,  0.10387D0,
50683      &     0.08608D0,  0.07049D0,  0.05669D0,  0.03490D0,  0.01971D0,
50684      &     0.00991D0,  0.00421D0,  0.00028D0,  0.00000D0/
50685       DATA (FMRS(1,1,I,26),I=1,49)/
50686      &     0.02032D0,  0.02536D0,  0.03164D0,  0.03600D0,  0.03946D0,
50687      &     0.04236D0,  0.05285D0,  0.06604D0,  0.07535D0,  0.08285D0,
50688      &     0.08936D0,  0.11352D0,  0.14603D0,  0.17026D0,  0.19043D0,
50689      &     0.20801D0,  0.23810D0,  0.27509D0,  0.32355D0,  0.36123D0,
50690      &     0.41527D0,  0.44945D0,  0.46936D0,  0.47919D0,  0.47657D0,
50691      &     0.46453D0,  0.44572D0,  0.42188D0,  0.39463D0,  0.36526D0,
50692      &     0.33462D0,  0.30373D0,  0.27307D0,  0.24328D0,  0.21472D0,
50693      &     0.18782D0,  0.16253D0,  0.13914D0,  0.11811D0,  0.09886D0,
50694      &     0.08171D0,  0.06673D0,  0.05353D0,  0.03277D0,  0.01840D0,
50695      &     0.00919D0,  0.00387D0,  0.00025D0,  0.00000D0/
50696       DATA (FMRS(1,1,I,27),I=1,49)/
50697      &     0.02054D0,  0.02564D0,  0.03200D0,  0.03642D0,  0.03992D0,
50698      &     0.04287D0,  0.05350D0,  0.06688D0,  0.07633D0,  0.08394D0,
50699      &     0.09053D0,  0.11504D0,  0.14798D0,  0.17249D0,  0.19284D0,
50700      &     0.21055D0,  0.24079D0,  0.27781D0,  0.32602D0,  0.36325D0,
50701      &     0.41604D0,  0.44883D0,  0.46732D0,  0.47551D0,  0.47145D0,
50702      &     0.45823D0,  0.43846D0,  0.41392D0,  0.38625D0,  0.35664D0,
50703      &     0.32595D0,  0.29518D0,  0.26477D0,  0.23536D0,  0.20725D0,
50704      &     0.18088D0,  0.15618D0,  0.13340D0,  0.11297D0,  0.09435D0,
50705      &     0.07779D0,  0.06337D0,  0.05071D0,  0.03088D0,  0.01724D0,
50706      &     0.00855D0,  0.00357D0,  0.00023D0,  0.00000D0/
50707       DATA (FMRS(1,1,I,28),I=1,49)/
50708      &     0.02074D0,  0.02591D0,  0.03234D0,  0.03682D0,  0.04037D0,
50709      &     0.04335D0,  0.05412D0,  0.06768D0,  0.07725D0,  0.08496D0,
50710      &     0.09165D0,  0.11648D0,  0.14982D0,  0.17457D0,  0.19509D0,
50711      &     0.21292D0,  0.24327D0,  0.28031D0,  0.32827D0,  0.36504D0,
50712      &     0.41665D0,  0.44811D0,  0.46527D0,  0.47196D0,  0.46656D0,
50713      &     0.45228D0,  0.43165D0,  0.40650D0,  0.37846D0,  0.34867D0,
50714      &     0.31800D0,  0.28733D0,  0.25718D0,  0.22812D0,  0.20048D0,
50715      &     0.17458D0,  0.15043D0,  0.12823D0,  0.10834D0,  0.09029D0,
50716      &     0.07427D0,  0.06037D0,  0.04820D0,  0.02920D0,  0.01621D0,
50717      &     0.00800D0,  0.00332D0,  0.00021D0,  0.00000D0/
50718       DATA (FMRS(1,1,I,29),I=1,49)/
50719      &     0.02094D0,  0.02617D0,  0.03269D0,  0.03722D0,  0.04081D0,
50720      &     0.04383D0,  0.05475D0,  0.06848D0,  0.07818D0,  0.08599D0,
50721      &     0.09277D0,  0.11792D0,  0.15165D0,  0.17664D0,  0.19733D0,
50722      &     0.21527D0,  0.24574D0,  0.28277D0,  0.33045D0,  0.36674D0,
50723      &     0.41715D0,  0.44728D0,  0.46313D0,  0.46834D0,  0.46164D0,
50724      &     0.44631D0,  0.42488D0,  0.39917D0,  0.37077D0,  0.34082D0,
50725      &     0.31017D0,  0.27964D0,  0.24978D0,  0.22107D0,  0.19390D0,
50726      &     0.16849D0,  0.14488D0,  0.12325D0,  0.10390D0,  0.08640D0,
50727      &     0.07092D0,  0.05751D0,  0.04581D0,  0.02761D0,  0.01524D0,
50728      &     0.00748D0,  0.00308D0,  0.00019D0,  0.00000D0/
50729       DATA (FMRS(1,1,I,30),I=1,49)/
50730      &     0.02115D0,  0.02644D0,  0.03303D0,  0.03762D0,  0.04125D0,
50731      &     0.04431D0,  0.05536D0,  0.06927D0,  0.07910D0,  0.08701D0,
50732      &     0.09387D0,  0.11934D0,  0.15345D0,  0.17867D0,  0.19951D0,
50733      &     0.21755D0,  0.24811D0,  0.28512D0,  0.33251D0,  0.36831D0,
50734      &     0.41752D0,  0.44634D0,  0.46092D0,  0.46470D0,  0.45678D0,
50735      &     0.44042D0,  0.41827D0,  0.39206D0,  0.36329D0,  0.33323D0,
50736      &     0.30260D0,  0.27226D0,  0.24270D0,  0.21435D0,  0.18761D0,
50737      &     0.16271D0,  0.13963D0,  0.11853D0,  0.09974D0,  0.08276D0,
50738      &     0.06777D0,  0.05484D0,  0.04358D0,  0.02615D0,  0.01436D0,
50739      &     0.00700D0,  0.00286D0,  0.00017D0,  0.00000D0/
50740       DATA (FMRS(1,1,I,31),I=1,49)/
50741      &     0.02134D0,  0.02669D0,  0.03336D0,  0.03800D0,  0.04168D0,
50742      &     0.04477D0,  0.05595D0,  0.07003D0,  0.07997D0,  0.08798D0,
50743      &     0.09492D0,  0.12069D0,  0.15515D0,  0.18059D0,  0.20157D0,
50744      &     0.21970D0,  0.25034D0,  0.28732D0,  0.33440D0,  0.36974D0,
50745      &     0.41780D0,  0.44538D0,  0.45878D0,  0.46121D0,  0.45216D0,
50746      &     0.43488D0,  0.41206D0,  0.38539D0,  0.35634D0,  0.32619D0,
50747      &     0.29560D0,  0.26544D0,  0.23618D0,  0.20818D0,  0.18185D0,
50748      &     0.15743D0,  0.13483D0,  0.11423D0,  0.09594D0,  0.07945D0,
50749      &     0.06492D0,  0.05243D0,  0.04157D0,  0.02483D0,  0.01357D0,
50750      &     0.00658D0,  0.00267D0,  0.00016D0,  0.00000D0/
50751       DATA (FMRS(1,1,I,32),I=1,49)/
50752      &     0.02153D0,  0.02693D0,  0.03367D0,  0.03836D0,  0.04208D0,
50753      &     0.04521D0,  0.05651D0,  0.07075D0,  0.08080D0,  0.08890D0,
50754      &     0.09592D0,  0.12197D0,  0.15676D0,  0.18239D0,  0.20349D0,
50755      &     0.22170D0,  0.25240D0,  0.28933D0,  0.33609D0,  0.37098D0,
50756      &     0.41793D0,  0.44434D0,  0.45663D0,  0.45780D0,  0.44772D0,
50757      &     0.42965D0,  0.40618D0,  0.37910D0,  0.34986D0,  0.31963D0,
50758      &     0.28912D0,  0.25913D0,  0.23015D0,  0.20249D0,  0.17658D0,
50759      &     0.15257D0,  0.13044D0,  0.11030D0,  0.09247D0,  0.07643D0,
50760      &     0.06234D0,  0.05026D0,  0.03976D0,  0.02365D0,  0.01287D0,
50761      &     0.00620D0,  0.00250D0,  0.00014D0,  0.00000D0/
50762       DATA (FMRS(1,1,I,33),I=1,49)/
50763      &     0.02171D0,  0.02717D0,  0.03398D0,  0.03872D0,  0.04248D0,
50764      &     0.04565D0,  0.05708D0,  0.07147D0,  0.08164D0,  0.08983D0,
50765      &     0.09693D0,  0.12326D0,  0.15838D0,  0.18421D0,  0.20543D0,
50766      &     0.22371D0,  0.25448D0,  0.29136D0,  0.33779D0,  0.37222D0,
50767      &     0.41806D0,  0.44331D0,  0.45449D0,  0.45441D0,  0.44330D0,
50768      &     0.42446D0,  0.40038D0,  0.37291D0,  0.34349D0,  0.31319D0,
50769      &     0.28277D0,  0.25295D0,  0.22427D0,  0.19695D0,  0.17145D0,
50770      &     0.14785D0,  0.12618D0,  0.10650D0,  0.08912D0,  0.07353D0,
50771      &     0.05986D0,  0.04817D0,  0.03803D0,  0.02252D0,  0.01220D0,
50772      &     0.00585D0,  0.00235D0,  0.00013D0,  0.00000D0/
50773       DATA (FMRS(1,1,I,34),I=1,49)/
50774      &     0.02190D0,  0.02741D0,  0.03429D0,  0.03909D0,  0.04289D0,
50775      &     0.04609D0,  0.05764D0,  0.07219D0,  0.08247D0,  0.09075D0,
50776      &     0.09793D0,  0.12453D0,  0.15996D0,  0.18597D0,  0.20731D0,
50777      &     0.22565D0,  0.25646D0,  0.29325D0,  0.33935D0,  0.37330D0,
50778      &     0.41800D0,  0.44209D0,  0.45219D0,  0.45092D0,  0.43883D0,
50779      &     0.41923D0,  0.39461D0,  0.36679D0,  0.33718D0,  0.30687D0,
50780      &     0.27654D0,  0.24693D0,  0.21853D0,  0.19159D0,  0.16650D0,
50781      &     0.14332D0,  0.12207D0,  0.10288D0,  0.08593D0,  0.07076D0,
50782      &     0.05749D0,  0.04618D0,  0.03639D0,  0.02146D0,  0.01157D0,
50783      &     0.00552D0,  0.00220D0,  0.00012D0,  0.00000D0/
50784       DATA (FMRS(1,1,I,35),I=1,49)/
50785      &     0.02208D0,  0.02764D0,  0.03459D0,  0.03943D0,  0.04327D0,
50786      &     0.04650D0,  0.05818D0,  0.07288D0,  0.08327D0,  0.09162D0,
50787      &     0.09888D0,  0.12574D0,  0.16147D0,  0.18765D0,  0.20909D0,
50788      &     0.22750D0,  0.25834D0,  0.29505D0,  0.34083D0,  0.37432D0,
50789      &     0.41794D0,  0.44094D0,  0.45002D0,  0.44763D0,  0.43463D0,
50790      &     0.41432D0,  0.38921D0,  0.36108D0,  0.33130D0,  0.30099D0,
50791      &     0.27077D0,  0.24136D0,  0.21322D0,  0.18665D0,  0.16193D0,
50792      &     0.13915D0,  0.11830D0,  0.09955D0,  0.08301D0,  0.06823D0,
50793      &     0.05533D0,  0.04437D0,  0.03490D0,  0.02050D0,  0.01100D0,
50794      &     0.00523D0,  0.00207D0,  0.00011D0,  0.00000D0/
50795       DATA (FMRS(1,1,I,36),I=1,49)/
50796      &     0.02225D0,  0.02787D0,  0.03488D0,  0.03977D0,  0.04364D0,
50797      &     0.04690D0,  0.05869D0,  0.07354D0,  0.08402D0,  0.09246D0,
50798      &     0.09978D0,  0.12689D0,  0.16290D0,  0.18924D0,  0.21077D0,
50799      &     0.22923D0,  0.26010D0,  0.29672D0,  0.34217D0,  0.37521D0,
50800      &     0.41781D0,  0.43978D0,  0.44789D0,  0.44447D0,  0.43062D0,
50801      &     0.40968D0,  0.38412D0,  0.35571D0,  0.32579D0,  0.29550D0,
50802      &     0.26538D0,  0.23618D0,  0.20831D0,  0.18206D0,  0.15771D0,
50803      &     0.13531D0,  0.11485D0,  0.09649D0,  0.08034D0,  0.06592D0,
50804      &     0.05337D0,  0.04272D0,  0.03354D0,  0.01963D0,  0.01049D0,
50805      &     0.00496D0,  0.00196D0,  0.00011D0,  0.00000D0/
50806       DATA (FMRS(1,1,I,37),I=1,49)/
50807      &     0.02242D0,  0.02809D0,  0.03517D0,  0.04010D0,  0.04401D0,
50808      &     0.04731D0,  0.05921D0,  0.07420D0,  0.08479D0,  0.09331D0,
50809      &     0.10070D0,  0.12805D0,  0.16433D0,  0.19082D0,  0.21245D0,
50810      &     0.23095D0,  0.26184D0,  0.29836D0,  0.34345D0,  0.37604D0,
50811      &     0.41760D0,  0.43853D0,  0.44568D0,  0.44123D0,  0.42654D0,
50812      &     0.40499D0,  0.37899D0,  0.35034D0,  0.32029D0,  0.29001D0,
50813      &     0.26003D0,  0.23104D0,  0.20345D0,  0.17752D0,  0.15354D0,
50814      &     0.13153D0,  0.11147D0,  0.09348D0,  0.07771D0,  0.06366D0,
50815      &     0.05147D0,  0.04112D0,  0.03222D0,  0.01879D0,  0.01000D0,
50816      &     0.00471D0,  0.00185D0,  0.00010D0,  0.00000D0/
50817       DATA (FMRS(1,1,I,38),I=1,49)/
50818      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
50819      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
50820      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
50821      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
50822      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
50823      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
50824      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
50825      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
50826      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
50827      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
50828       DATA (FMRS(1,2,I, 1),I=1,49)/
50829      &     0.00513D0,  0.00648D0,  0.00818D0,  0.00938D0,  0.01034D0,
50830      &     0.01116D0,  0.01418D0,  0.01818D0,  0.02118D0,  0.02372D0,
50831      &     0.02613D0,  0.03576D0,  0.05040D0,  0.06228D0,  0.07266D0,
50832      &     0.08202D0,  0.09864D0,  0.12002D0,  0.14955D0,  0.17387D0,
50833      &     0.21184D0,  0.23954D0,  0.25956D0,  0.27606D0,  0.28502D0,
50834      &     0.28790D0,  0.28586D0,  0.27985D0,  0.27060D0,  0.25918D0,
50835      &     0.24535D0,  0.23028D0,  0.21416D0,  0.19735D0,  0.18044D0,
50836      &     0.16347D0,  0.14671D0,  0.13049D0,  0.11512D0,  0.10018D0,
50837      &     0.08630D0,  0.07360D0,  0.06172D0,  0.04171D0,  0.02610D0,
50838      &     0.01478D0,  0.00721D0,  0.00074D0,  0.00000D0/
50839       DATA (FMRS(1,2,I, 2),I=1,49)/
50840      &     0.00518D0,  0.00654D0,  0.00828D0,  0.00950D0,  0.01049D0,
50841      &     0.01133D0,  0.01443D0,  0.01854D0,  0.02162D0,  0.02423D0,
50842      &     0.02670D0,  0.03657D0,  0.05155D0,  0.06366D0,  0.07421D0,
50843      &     0.08371D0,  0.10052D0,  0.12206D0,  0.15163D0,  0.17583D0,
50844      &     0.21329D0,  0.24028D0,  0.25950D0,  0.27498D0,  0.28295D0,
50845      &     0.28491D0,  0.28206D0,  0.27535D0,  0.26555D0,  0.25365D0,
50846      &     0.23952D0,  0.22423D0,  0.20802D0,  0.19123D0,  0.17441D0,
50847      &     0.15763D0,  0.14114D0,  0.12520D0,  0.11019D0,  0.09565D0,
50848      &     0.08218D0,  0.06990D0,  0.05847D0,  0.03927D0,  0.02442D0,
50849      &     0.01373D0,  0.00665D0,  0.00066D0,  0.00000D0/
50850       DATA (FMRS(1,2,I, 3),I=1,49)/
50851      &     0.00524D0,  0.00664D0,  0.00843D0,  0.00970D0,  0.01072D0,
50852      &     0.01159D0,  0.01481D0,  0.01908D0,  0.02229D0,  0.02501D0,
50853      &     0.02757D0,  0.03781D0,  0.05328D0,  0.06572D0,  0.07653D0,
50854      &     0.08622D0,  0.10330D0,  0.12505D0,  0.15465D0,  0.17864D0,
50855      &     0.21528D0,  0.24119D0,  0.25922D0,  0.27320D0,  0.27971D0,
50856      &     0.28035D0,  0.27635D0,  0.26864D0,  0.25807D0,  0.24551D0,
50857      &     0.23101D0,  0.21544D0,  0.19911D0,  0.18240D0,  0.16578D0,
50858      &     0.14929D0,  0.13320D0,  0.11772D0,  0.10322D0,  0.08926D0,
50859      &     0.07639D0,  0.06473D0,  0.05394D0,  0.03591D0,  0.02212D0,
50860      &     0.01231D0,  0.00589D0,  0.00057D0,  0.00000D0/
50861       DATA (FMRS(1,2,I, 4),I=1,49)/
50862      &     0.00529D0,  0.00672D0,  0.00855D0,  0.00985D0,  0.01090D0,
50863      &     0.01179D0,  0.01510D0,  0.01949D0,  0.02279D0,  0.02558D0,
50864      &     0.02822D0,  0.03873D0,  0.05456D0,  0.06724D0,  0.07823D0,
50865      &     0.08806D0,  0.10532D0,  0.12720D0,  0.15680D0,  0.18061D0,
50866      &     0.21663D0,  0.24172D0,  0.25888D0,  0.27177D0,  0.27723D0,
50867      &     0.27696D0,  0.27213D0,  0.26373D0,  0.25262D0,  0.23966D0,
50868      &     0.22489D0,  0.20919D0,  0.19281D0,  0.17616D0,  0.15968D0,
50869      &     0.14345D0,  0.12763D0,  0.11250D0,  0.09838D0,  0.08485D0,
50870      &     0.07242D0,  0.06118D0,  0.05083D0,  0.03363D0,  0.02058D0,
50871      &     0.01136D0,  0.00539D0,  0.00050D0,  0.00000D0/
50872       DATA (FMRS(1,2,I, 5),I=1,49)/
50873      &     0.00534D0,  0.00680D0,  0.00868D0,  0.01001D0,  0.01108D0,
50874      &     0.01200D0,  0.01540D0,  0.01993D0,  0.02332D0,  0.02620D0,
50875      &     0.02891D0,  0.03971D0,  0.05590D0,  0.06884D0,  0.08000D0,
50876      &     0.08997D0,  0.10741D0,  0.12941D0,  0.15897D0,  0.18257D0,
50877      &     0.21790D0,  0.24212D0,  0.25836D0,  0.27010D0,  0.27446D0,
50878      &     0.27326D0,  0.26762D0,  0.25853D0,  0.24692D0,  0.23356D0,
50879      &     0.21851D0,  0.20270D0,  0.18633D0,  0.16975D0,  0.15345D0,
50880      &     0.13751D0,  0.12199D0,  0.10721D0,  0.09351D0,  0.08043D0,
50881      &     0.06843D0,  0.05765D0,  0.04775D0,  0.03138D0,  0.01907D0,
50882      &     0.01045D0,  0.00491D0,  0.00045D0,  0.00000D0/
50883       DATA (FMRS(1,2,I, 6),I=1,49)/
50884      &     0.00539D0,  0.00688D0,  0.00879D0,  0.01015D0,  0.01125D0,
50885      &     0.01219D0,  0.01567D0,  0.02031D0,  0.02379D0,  0.02674D0,
50886      &     0.02951D0,  0.04056D0,  0.05708D0,  0.07022D0,  0.08154D0,
50887      &     0.09162D0,  0.10921D0,  0.13130D0,  0.16082D0,  0.18422D0,
50888      &     0.21894D0,  0.24239D0,  0.25783D0,  0.26859D0,  0.27204D0,
50889      &     0.27005D0,  0.26373D0,  0.25409D0,  0.24206D0,  0.22838D0,
50890      &     0.21313D0,  0.19724D0,  0.18088D0,  0.16440D0,  0.14826D0,
50891      &     0.13257D0,  0.11731D0,  0.10284D0,  0.08950D0,  0.07679D0,
50892      &     0.06517D0,  0.05477D0,  0.04524D0,  0.02956D0,  0.01786D0,
50893      &     0.00972D0,  0.00453D0,  0.00040D0,  0.00000D0/
50894       DATA (FMRS(1,2,I, 7),I=1,49)/
50895      &     0.00544D0,  0.00695D0,  0.00890D0,  0.01029D0,  0.01141D0,
50896      &     0.01237D0,  0.01593D0,  0.02068D0,  0.02425D0,  0.02727D0,
50897      &     0.03010D0,  0.04138D0,  0.05820D0,  0.07155D0,  0.08301D0,
50898      &     0.09319D0,  0.11091D0,  0.13308D0,  0.16253D0,  0.18572D0,
50899      &     0.21983D0,  0.24255D0,  0.25721D0,  0.26706D0,  0.26966D0,
50900      &     0.26692D0,  0.25996D0,  0.24983D0,  0.23740D0,  0.22344D0,
50901      &     0.20806D0,  0.19209D0,  0.17575D0,  0.15940D0,  0.14342D0,
50902      &     0.12794D0,  0.11298D0,  0.09881D0,  0.08579D0,  0.07344D0,
50903      &     0.06219D0,  0.05213D0,  0.04295D0,  0.02791D0,  0.01677D0,
50904      &     0.00906D0,  0.00419D0,  0.00037D0,  0.00000D0/
50905       DATA (FMRS(1,2,I, 8),I=1,49)/
50906      &     0.00549D0,  0.00703D0,  0.00902D0,  0.01044D0,  0.01159D0,
50907      &     0.01257D0,  0.01622D0,  0.02109D0,  0.02474D0,  0.02783D0,
50908      &     0.03073D0,  0.04227D0,  0.05940D0,  0.07296D0,  0.08456D0,
50909      &     0.09485D0,  0.11270D0,  0.13493D0,  0.16429D0,  0.18726D0,
50910      &     0.22070D0,  0.24263D0,  0.25647D0,  0.26535D0,  0.26707D0,
50911      &     0.26357D0,  0.25596D0,  0.24532D0,  0.23250D0,  0.21829D0,
50912      &     0.20276D0,  0.18675D0,  0.17045D0,  0.15424D0,  0.13845D0,
50913      &     0.12321D0,  0.10855D0,  0.09470D0,  0.08203D0,  0.07005D0,
50914      &     0.05917D0,  0.04947D0,  0.04065D0,  0.02627D0,  0.01569D0,
50915      &     0.00842D0,  0.00386D0,  0.00033D0,  0.00000D0/
50916       DATA (FMRS(1,2,I, 9),I=1,49)/
50917      &     0.00553D0,  0.00711D0,  0.00913D0,  0.01057D0,  0.01174D0,
50918      &     0.01274D0,  0.01647D0,  0.02144D0,  0.02517D0,  0.02833D0,
50919      &     0.03129D0,  0.04304D0,  0.06045D0,  0.07418D0,  0.08591D0,
50920      &     0.09629D0,  0.11425D0,  0.13653D0,  0.16579D0,  0.18855D0,
50921      &     0.22139D0,  0.24264D0,  0.25577D0,  0.26380D0,  0.26479D0,
50922      &     0.26063D0,  0.25250D0,  0.24142D0,  0.22830D0,  0.21390D0,
50923      &     0.19824D0,  0.18222D0,  0.16597D0,  0.14988D0,  0.13426D0,
50924      &     0.11924D0,  0.10484D0,  0.09128D0,  0.07889D0,  0.06724D0,
50925      &     0.05666D0,  0.04727D0,  0.03875D0,  0.02492D0,  0.01480D0,
50926      &     0.00790D0,  0.00360D0,  0.00030D0,  0.00000D0/
50927       DATA (FMRS(1,2,I,10),I=1,49)/
50928      &     0.00558D0,  0.00718D0,  0.00923D0,  0.01071D0,  0.01190D0,
50929      &     0.01291D0,  0.01671D0,  0.02178D0,  0.02559D0,  0.02881D0,
50930      &     0.03183D0,  0.04379D0,  0.06146D0,  0.07536D0,  0.08720D0,
50931      &     0.09766D0,  0.11571D0,  0.13802D0,  0.16719D0,  0.18973D0,
50932      &     0.22198D0,  0.24256D0,  0.25502D0,  0.26225D0,  0.26252D0,
50933      &     0.25776D0,  0.24914D0,  0.23766D0,  0.22428D0,  0.20968D0,
50934      &     0.19393D0,  0.17791D0,  0.16173D0,  0.14575D0,  0.13032D0,
50935      &     0.11552D0,  0.10136D0,  0.08807D0,  0.07596D0,  0.06462D0,
50936      &     0.05433D0,  0.04524D0,  0.03701D0,  0.02369D0,  0.01400D0,
50937      &     0.00743D0,  0.00336D0,  0.00028D0,  0.00000D0/
50938       DATA (FMRS(1,2,I,11),I=1,49)/
50939      &     0.00562D0,  0.00723D0,  0.00932D0,  0.01081D0,  0.01202D0,
50940      &     0.01305D0,  0.01691D0,  0.02206D0,  0.02593D0,  0.02920D0,
50941      &     0.03226D0,  0.04438D0,  0.06226D0,  0.07629D0,  0.08822D0,
50942      &     0.09874D0,  0.11687D0,  0.13920D0,  0.16827D0,  0.19064D0,
50943      &     0.22242D0,  0.24246D0,  0.25439D0,  0.26100D0,  0.26071D0,
50944      &     0.25548D0,  0.24648D0,  0.23472D0,  0.22112D0,  0.20638D0,
50945      &     0.19059D0,  0.17454D0,  0.15845D0,  0.14257D0,  0.12728D0,
50946      &     0.11265D0,  0.09869D0,  0.08561D0,  0.07373D0,  0.06261D0,
50947      &     0.05256D0,  0.04369D0,  0.03568D0,  0.02275D0,  0.01339D0,
50948      &     0.00707D0,  0.00318D0,  0.00026D0,  0.00000D0/
50949       DATA (FMRS(1,2,I,12),I=1,49)/
50950      &     0.00570D0,  0.00736D0,  0.00950D0,  0.01104D0,  0.01228D0,
50951      &     0.01335D0,  0.01733D0,  0.02266D0,  0.02665D0,  0.03003D0,
50952      &     0.03319D0,  0.04566D0,  0.06397D0,  0.07827D0,  0.09038D0,
50953      &     0.10102D0,  0.11928D0,  0.14164D0,  0.17050D0,  0.19247D0,
50954      &     0.22321D0,  0.24211D0,  0.25293D0,  0.25822D0,  0.25677D0,
50955      &     0.25059D0,  0.24082D0,  0.22847D0,  0.21448D0,  0.19945D0,
50956      &     0.18361D0,  0.16759D0,  0.15163D0,  0.13598D0,  0.12100D0,
50957      &     0.10676D0,  0.09321D0,  0.08058D0,  0.06917D0,  0.05856D0,
50958      &     0.04898D0,  0.04057D0,  0.03301D0,  0.02089D0,  0.01219D0,
50959      &     0.00638D0,  0.00284D0,  0.00022D0,  0.00000D0/
50960       DATA (FMRS(1,2,I,13),I=1,49)/
50961      &     0.00578D0,  0.00747D0,  0.00966D0,  0.01124D0,  0.01252D0,
50962      &     0.01361D0,  0.01770D0,  0.02318D0,  0.02729D0,  0.03076D0,
50963      &     0.03400D0,  0.04677D0,  0.06545D0,  0.07997D0,  0.09223D0,
50964      &     0.10297D0,  0.12133D0,  0.14370D0,  0.17234D0,  0.19395D0,
50965      &     0.22379D0,  0.24170D0,  0.25156D0,  0.25575D0,  0.25334D0,
50966      &     0.24638D0,  0.23598D0,  0.22317D0,  0.20887D0,  0.19364D0,
50967      &     0.17776D0,  0.16180D0,  0.14597D0,  0.13054D0,  0.11583D0,
50968      &     0.10193D0,  0.08873D0,  0.07648D0,  0.06548D0,  0.05529D0,
50969      &     0.04609D0,  0.03806D0,  0.03088D0,  0.01941D0,  0.01124D0,
50970      &     0.00583D0,  0.00257D0,  0.00020D0,  0.00000D0/
50971       DATA (FMRS(1,2,I,14),I=1,49)/
50972      &     0.00586D0,  0.00760D0,  0.00985D0,  0.01147D0,  0.01278D0,
50973      &     0.01391D0,  0.01812D0,  0.02377D0,  0.02801D0,  0.03158D0,
50974      &     0.03491D0,  0.04802D0,  0.06710D0,  0.08186D0,  0.09428D0,
50975      &     0.10512D0,  0.12358D0,  0.14593D0,  0.17430D0,  0.19551D0,
50976      &     0.22431D0,  0.24113D0,  0.24990D0,  0.25292D0,  0.24948D0,
50977      &     0.24168D0,  0.23063D0,  0.21737D0,  0.20273D0,  0.18735D0,
50978      &     0.17142D0,  0.15550D0,  0.13986D0,  0.12470D0,  0.11033D0,
50979      &     0.09680D0,  0.08400D0,  0.07217D0,  0.06162D0,  0.05183D0,
50980      &     0.04308D0,  0.03546D0,  0.02866D0,  0.01788D0,  0.01027D0,
50981      &     0.00528D0,  0.00231D0,  0.00017D0,  0.00000D0/
50982       DATA (FMRS(1,2,I,15),I=1,49)/
50983      &     0.00596D0,  0.00773D0,  0.01005D0,  0.01171D0,  0.01307D0,
50984      &     0.01423D0,  0.01857D0,  0.02439D0,  0.02876D0,  0.03244D0,
50985      &     0.03586D0,  0.04932D0,  0.06880D0,  0.08380D0,  0.09637D0,
50986      &     0.10730D0,  0.12584D0,  0.14815D0,  0.17622D0,  0.19694D0,
50987      &     0.22466D0,  0.24034D0,  0.24804D0,  0.24983D0,  0.24536D0,
50988      &     0.23677D0,  0.22506D0,  0.21136D0,  0.19645D0,  0.18096D0,
50989      &     0.16500D0,  0.14922D0,  0.13378D0,  0.11890D0,  0.10488D0,
50990      &     0.09171D0,  0.07933D0,  0.06793D0,  0.05781D0,  0.04848D0,
50991      &     0.04016D0,  0.03293D0,  0.02652D0,  0.01642D0,  0.00936D0,
50992      &     0.00477D0,  0.00206D0,  0.00015D0,  0.00000D0/
50993       DATA (FMRS(1,2,I,16),I=1,49)/
50994      &     0.00604D0,  0.00786D0,  0.01023D0,  0.01194D0,  0.01333D0,
50995      &     0.01452D0,  0.01898D0,  0.02497D0,  0.02945D0,  0.03323D0,
50996      &     0.03674D0,  0.05050D0,  0.07034D0,  0.08554D0,  0.09824D0,
50997      &     0.10925D0,  0.12785D0,  0.15009D0,  0.17786D0,  0.19815D0,
50998      &     0.22486D0,  0.23952D0,  0.24625D0,  0.24698D0,  0.24163D0,
50999      &     0.23233D0,  0.22009D0,  0.20603D0,  0.19091D0,  0.17529D0,
51000      &     0.15938D0,  0.14374D0,  0.12849D0,  0.11388D0,  0.10016D0,
51001      &     0.08733D0,  0.07533D0,  0.06433D0,  0.05458D0,  0.04564D0,
51002      &     0.03769D0,  0.03082D0,  0.02473D0,  0.01521D0,  0.00860D0,
51003      &     0.00435D0,  0.00186D0,  0.00013D0,  0.00000D0/
51004       DATA (FMRS(1,2,I,17),I=1,49)/
51005      &     0.00614D0,  0.00799D0,  0.01042D0,  0.01217D0,  0.01359D0,
51006      &     0.01482D0,  0.01940D0,  0.02555D0,  0.03016D0,  0.03404D0,
51007      &     0.03763D0,  0.05170D0,  0.07188D0,  0.08729D0,  0.10010D0,
51008      &     0.11119D0,  0.12983D0,  0.15200D0,  0.17943D0,  0.19928D0,
51009      &     0.22497D0,  0.23860D0,  0.24438D0,  0.24406D0,  0.23786D0,
51010      &     0.22788D0,  0.21517D0,  0.20077D0,  0.18546D0,  0.16976D0,
51011      &     0.15392D0,  0.13841D0,  0.12338D0,  0.10905D0,  0.09563D0,
51012      &     0.08314D0,  0.07152D0,  0.06090D0,  0.05152D0,  0.04295D0,
51013      &     0.03537D0,  0.02883D0,  0.02306D0,  0.01409D0,  0.00791D0,
51014      &     0.00396D0,  0.00168D0,  0.00011D0,  0.00000D0/
51015       DATA (FMRS(1,2,I,18),I=1,49)/
51016      &     0.00621D0,  0.00810D0,  0.01058D0,  0.01236D0,  0.01382D0,
51017      &     0.01507D0,  0.01975D0,  0.02604D0,  0.03075D0,  0.03471D0,
51018      &     0.03837D0,  0.05269D0,  0.07316D0,  0.08872D0,  0.10163D0,
51019      &     0.11277D0,  0.13143D0,  0.15352D0,  0.18066D0,  0.20012D0,
51020      &     0.22496D0,  0.23774D0,  0.24276D0,  0.24159D0,  0.23471D0,
51021      &     0.22421D0,  0.21113D0,  0.19645D0,  0.18102D0,  0.16532D0,
51022      &     0.14952D0,  0.13412D0,  0.11930D0,  0.10519D0,  0.09201D0,
51023      &     0.07983D0,  0.06850D0,  0.05818D0,  0.04914D0,  0.04085D0,
51024      &     0.03356D0,  0.02728D0,  0.02176D0,  0.01322D0,  0.00738D0,
51025      &     0.00367D0,  0.00154D0,  0.00010D0,  0.00000D0/
51026       DATA (FMRS(1,2,I,19),I=1,49)/
51027      &     0.00631D0,  0.00824D0,  0.01077D0,  0.01261D0,  0.01410D0,
51028      &     0.01538D0,  0.02018D0,  0.02663D0,  0.03146D0,  0.03553D0,
51029      &     0.03927D0,  0.05390D0,  0.07469D0,  0.09044D0,  0.10345D0,
51030      &     0.11464D0,  0.13332D0,  0.15529D0,  0.18206D0,  0.20106D0,
51031      &     0.22486D0,  0.23661D0,  0.24071D0,  0.23855D0,  0.23089D0,
51032      &     0.21978D0,  0.20626D0,  0.19133D0,  0.17575D0,  0.16006D0,
51033      &     0.14433D0,  0.12911D0,  0.11452D0,  0.10069D0,  0.08783D0,
51034      &     0.07600D0,  0.06503D0,  0.05507D0,  0.04638D0,  0.03845D0,
51035      &     0.03149D0,  0.02552D0,  0.02030D0,  0.01225D0,  0.00679D0,
51036      &     0.00335D0,  0.00139D0,  0.00009D0,  0.00000D0/
51037       DATA (FMRS(1,2,I,20),I=1,49)/
51038      &     0.00640D0,  0.00837D0,  0.01095D0,  0.01282D0,  0.01434D0,
51039      &     0.01565D0,  0.02057D0,  0.02717D0,  0.03210D0,  0.03625D0,
51040      &     0.04007D0,  0.05496D0,  0.07605D0,  0.09195D0,  0.10504D0,
51041      &     0.11628D0,  0.13496D0,  0.15682D0,  0.18325D0,  0.20182D0,
51042      &     0.22471D0,  0.23557D0,  0.23887D0,  0.23587D0,  0.22753D0,
51043      &     0.21592D0,  0.20204D0,  0.18691D0,  0.17123D0,  0.15556D0,
51044      &     0.13990D0,  0.12485D0,  0.11047D0,  0.09690D0,  0.08432D0,
51045      &     0.07279D0,  0.06213D0,  0.05248D0,  0.04407D0,  0.03646D0,
51046      &     0.02978D0,  0.02408D0,  0.01910D0,  0.01145D0,  0.00631D0,
51047      &     0.00309D0,  0.00127D0,  0.00008D0,  0.00000D0/
51048       DATA (FMRS(1,2,I,21),I=1,49)/
51049      &     0.00648D0,  0.00848D0,  0.01111D0,  0.01302D0,  0.01457D0,
51050      &     0.01591D0,  0.02092D0,  0.02766D0,  0.03269D0,  0.03692D0,
51051      &     0.04081D0,  0.05593D0,  0.07728D0,  0.09331D0,  0.10647D0,
51052      &     0.11774D0,  0.13641D0,  0.15816D0,  0.18425D0,  0.20243D0,
51053      &     0.22446D0,  0.23452D0,  0.23710D0,  0.23336D0,  0.22443D0,
51054      &     0.21239D0,  0.19820D0,  0.18290D0,  0.16716D0,  0.15148D0,
51055      &     0.13595D0,  0.12104D0,  0.10685D0,  0.09353D0,  0.08121D0,
51056      &     0.06995D0,  0.05958D0,  0.05021D0,  0.04207D0,  0.03472D0,
51057      &     0.02829D0,  0.02282D0,  0.01806D0,  0.01077D0,  0.00590D0,
51058      &     0.00287D0,  0.00118D0,  0.00007D0,  0.00000D0/
51059       DATA (FMRS(1,2,I,22),I=1,49)/
51060      &     0.00659D0,  0.00863D0,  0.01133D0,  0.01328D0,  0.01487D0,
51061      &     0.01624D0,  0.02138D0,  0.02828D0,  0.03345D0,  0.03777D0,
51062      &     0.04174D0,  0.05717D0,  0.07882D0,  0.09501D0,  0.10826D0,
51063      &     0.11956D0,  0.13822D0,  0.15980D0,  0.18547D0,  0.20313D0,
51064      &     0.22408D0,  0.23313D0,  0.23482D0,  0.23017D0,  0.22053D0,
51065      &     0.20797D0,  0.19344D0,  0.17794D0,  0.16215D0,  0.14650D0,
51066      &     0.13110D0,  0.11639D0,  0.10245D0,  0.08944D0,  0.07745D0,
51067      &     0.06653D0,  0.05651D0,  0.04748D0,  0.03968D0,  0.03265D0,
51068      &     0.02652D0,  0.02133D0,  0.01682D0,  0.00997D0,  0.00542D0,
51069      &     0.00262D0,  0.00106D0,  0.00006D0,  0.00000D0/
51070       DATA (FMRS(1,2,I,23),I=1,49)/
51071      &     0.00669D0,  0.00878D0,  0.01153D0,  0.01352D0,  0.01515D0,
51072      &     0.01655D0,  0.02181D0,  0.02888D0,  0.03416D0,  0.03858D0,
51073      &     0.04263D0,  0.05833D0,  0.08027D0,  0.09661D0,  0.10992D0,
51074      &     0.12125D0,  0.13987D0,  0.16129D0,  0.18654D0,  0.20370D0,
51075      &     0.22365D0,  0.23178D0,  0.23266D0,  0.22717D0,  0.21689D0,
51076      &     0.20387D0,  0.18906D0,  0.17340D0,  0.15758D0,  0.14198D0,
51077      &     0.12670D0,  0.11220D0,  0.09851D0,  0.08577D0,  0.07408D0,
51078      &     0.06350D0,  0.05377D0,  0.04507D0,  0.03757D0,  0.03084D0,
51079      &     0.02497D0,  0.02003D0,  0.01574D0,  0.00927D0,  0.00500D0,
51080      &     0.00240D0,  0.00096D0,  0.00006D0,  0.00000D0/
51081       DATA (FMRS(1,2,I,24),I=1,49)/
51082      &     0.00679D0,  0.00892D0,  0.01172D0,  0.01376D0,  0.01542D0,
51083      &     0.01685D0,  0.02222D0,  0.02944D0,  0.03483D0,  0.03934D0,
51084      &     0.04345D0,  0.05941D0,  0.08161D0,  0.09806D0,  0.11144D0,
51085      &     0.12278D0,  0.14136D0,  0.16260D0,  0.18745D0,  0.20414D0,
51086      &     0.22314D0,  0.23041D0,  0.23054D0,  0.22429D0,  0.21345D0,
51087      &     0.20006D0,  0.18498D0,  0.16918D0,  0.15336D0,  0.13783D0,
51088      &     0.12271D0,  0.10840D0,  0.09494D0,  0.08246D0,  0.07106D0,
51089      &     0.06075D0,  0.05132D0,  0.04292D0,  0.03570D0,  0.02922D0,
51090      &     0.02361D0,  0.01888D0,  0.01480D0,  0.00867D0,  0.00465D0,
51091      &     0.00221D0,  0.00088D0,  0.00005D0,  0.00000D0/
51092       DATA (FMRS(1,2,I,25),I=1,49)/
51093      &     0.00689D0,  0.00906D0,  0.01192D0,  0.01399D0,  0.01569D0,
51094      &     0.01715D0,  0.02264D0,  0.03000D0,  0.03550D0,  0.04009D0,
51095      &     0.04429D0,  0.06049D0,  0.08294D0,  0.09952D0,  0.11294D0,
51096      &     0.12429D0,  0.14282D0,  0.16389D0,  0.18832D0,  0.20454D0,
51097      &     0.22261D0,  0.22902D0,  0.22843D0,  0.22145D0,  0.21007D0,
51098      &     0.19632D0,  0.18101D0,  0.16509D0,  0.14928D0,  0.13382D0,
51099      &     0.11886D0,  0.10475D0,  0.09153D0,  0.07931D0,  0.06819D0,
51100      &     0.05815D0,  0.04900D0,  0.04089D0,  0.03393D0,  0.02770D0,
51101      &     0.02232D0,  0.01781D0,  0.01392D0,  0.00811D0,  0.00432D0,
51102      &     0.00204D0,  0.00081D0,  0.00004D0,  0.00000D0/
51103       DATA (FMRS(1,2,I,26),I=1,49)/
51104      &     0.00699D0,  0.00920D0,  0.01211D0,  0.01423D0,  0.01596D0,
51105      &     0.01744D0,  0.02304D0,  0.03056D0,  0.03616D0,  0.04084D0,
51106      &     0.04510D0,  0.06154D0,  0.08423D0,  0.10091D0,  0.11437D0,
51107      &     0.12573D0,  0.14419D0,  0.16508D0,  0.18909D0,  0.20485D0,
51108      &     0.22201D0,  0.22760D0,  0.22631D0,  0.21867D0,  0.20676D0,
51109      &     0.19266D0,  0.17717D0,  0.16120D0,  0.14536D0,  0.12999D0,
51110      &     0.11520D0,  0.10128D0,  0.08831D0,  0.07633D0,  0.06548D0,
51111      &     0.05572D0,  0.04685D0,  0.03900D0,  0.03228D0,  0.02629D0,
51112      &     0.02113D0,  0.01682D0,  0.01311D0,  0.00760D0,  0.00403D0,
51113      &     0.00189D0,  0.00074D0,  0.00004D0,  0.00000D0/
51114       DATA (FMRS(1,2,I,27),I=1,49)/
51115      &     0.00708D0,  0.00933D0,  0.01230D0,  0.01445D0,  0.01621D0,
51116      &     0.01773D0,  0.02343D0,  0.03108D0,  0.03678D0,  0.04155D0,
51117      &     0.04587D0,  0.06253D0,  0.08544D0,  0.10221D0,  0.11571D0,
51118      &     0.12707D0,  0.14546D0,  0.16617D0,  0.18977D0,  0.20509D0,
51119      &     0.22139D0,  0.22623D0,  0.22430D0,  0.21604D0,  0.20367D0,
51120      &     0.18926D0,  0.17361D0,  0.15759D0,  0.14176D0,  0.12648D0,
51121      &     0.11185D0,  0.09812D0,  0.08537D0,  0.07364D0,  0.06303D0,
51122      &     0.05352D0,  0.04490D0,  0.03729D0,  0.03081D0,  0.02503D0,
51123      &     0.02007D0,  0.01594D0,  0.01240D0,  0.00714D0,  0.00376D0,
51124      &     0.00176D0,  0.00068D0,  0.00004D0,  0.00000D0/
51125       DATA (FMRS(1,2,I,28),I=1,49)/
51126      &     0.00718D0,  0.00946D0,  0.01247D0,  0.01467D0,  0.01646D0,
51127      &     0.01800D0,  0.02380D0,  0.03158D0,  0.03738D0,  0.04221D0,
51128      &     0.04660D0,  0.06346D0,  0.08657D0,  0.10342D0,  0.11695D0,
51129      &     0.12830D0,  0.14663D0,  0.16715D0,  0.19037D0,  0.20527D0,
51130      &     0.22075D0,  0.22489D0,  0.22237D0,  0.21353D0,  0.20079D0,
51131      &     0.18610D0,  0.17031D0,  0.15425D0,  0.13844D0,  0.12326D0,
51132      &     0.10877D0,  0.09523D0,  0.08268D0,  0.07119D0,  0.06080D0,
51133      &     0.05153D0,  0.04314D0,  0.03575D0,  0.02948D0,  0.02390D0,
51134      &     0.01913D0,  0.01516D0,  0.01177D0,  0.00675D0,  0.00353D0,
51135      &     0.00164D0,  0.00063D0,  0.00003D0,  0.00000D0/
51136       DATA (FMRS(1,2,I,29),I=1,49)/
51137      &     0.00727D0,  0.00959D0,  0.01265D0,  0.01488D0,  0.01670D0,
51138      &     0.01827D0,  0.02417D0,  0.03208D0,  0.03797D0,  0.04288D0,
51139      &     0.04733D0,  0.06440D0,  0.08769D0,  0.10463D0,  0.11818D0,
51140      &     0.12952D0,  0.14777D0,  0.16810D0,  0.19092D0,  0.20540D0,
51141      &     0.22008D0,  0.22352D0,  0.22043D0,  0.21103D0,  0.19791D0,
51142      &     0.18297D0,  0.16705D0,  0.15095D0,  0.13519D0,  0.12011D0,
51143      &     0.10577D0,  0.09241D0,  0.08008D0,  0.06881D0,  0.05866D0,
51144      &     0.04961D0,  0.04145D0,  0.03427D0,  0.02822D0,  0.02282D0,
51145      &     0.01822D0,  0.01441D0,  0.01116D0,  0.00637D0,  0.00332D0,
51146      &     0.00153D0,  0.00059D0,  0.00003D0,  0.00000D0/
51147       DATA (FMRS(1,2,I,30),I=1,49)/
51148      &     0.00737D0,  0.00972D0,  0.01283D0,  0.01510D0,  0.01695D0,
51149      &     0.01854D0,  0.02454D0,  0.03258D0,  0.03856D0,  0.04354D0,
51150      &     0.04805D0,  0.06532D0,  0.08879D0,  0.10580D0,  0.11936D0,
51151      &     0.13069D0,  0.14886D0,  0.16900D0,  0.19141D0,  0.20548D0,
51152      &     0.21937D0,  0.22213D0,  0.21850D0,  0.20855D0,  0.19507D0,
51153      &     0.17994D0,  0.16388D0,  0.14775D0,  0.13208D0,  0.11709D0,
51154      &     0.10291D0,  0.08973D0,  0.07760D0,  0.06655D0,  0.05664D0,
51155      &     0.04779D0,  0.03985D0,  0.03289D0,  0.02702D0,  0.02182D0,
51156      &     0.01738D0,  0.01372D0,  0.01060D0,  0.00602D0,  0.00312D0,
51157      &     0.00143D0,  0.00055D0,  0.00003D0,  0.00000D0/
51158       DATA (FMRS(1,2,I,31),I=1,49)/
51159      &     0.00746D0,  0.00985D0,  0.01300D0,  0.01530D0,  0.01718D0,
51160      &     0.01880D0,  0.02489D0,  0.03306D0,  0.03912D0,  0.04417D0,
51161      &     0.04873D0,  0.06619D0,  0.08983D0,  0.10690D0,  0.12048D0,
51162      &     0.13179D0,  0.14987D0,  0.16982D0,  0.19186D0,  0.20553D0,
51163      &     0.21868D0,  0.22081D0,  0.21666D0,  0.20623D0,  0.19242D0,
51164      &     0.17710D0,  0.16093D0,  0.14478D0,  0.12919D0,  0.11430D0,
51165      &     0.10026D0,  0.08726D0,  0.07533D0,  0.06447D0,  0.05479D0,
51166      &     0.04614D0,  0.03840D0,  0.03163D0,  0.02594D0,  0.02091D0,
51167      &     0.01662D0,  0.01309D0,  0.01009D0,  0.00571D0,  0.00295D0,
51168      &     0.00134D0,  0.00051D0,  0.00003D0,  0.00000D0/
51169       DATA (FMRS(1,2,I,32),I=1,49)/
51170      &     0.00755D0,  0.00997D0,  0.01317D0,  0.01550D0,  0.01741D0,
51171      &     0.01905D0,  0.02522D0,  0.03351D0,  0.03966D0,  0.04477D0,
51172      &     0.04938D0,  0.06700D0,  0.09079D0,  0.10792D0,  0.12151D0,
51173      &     0.13280D0,  0.15080D0,  0.17056D0,  0.19223D0,  0.20552D0,
51174      &     0.21797D0,  0.21951D0,  0.21489D0,  0.20403D0,  0.18991D0,
51175      &     0.17441D0,  0.15817D0,  0.14202D0,  0.12646D0,  0.11170D0,
51176      &     0.09780D0,  0.08498D0,  0.07322D0,  0.06257D0,  0.05306D0,
51177      &     0.04463D0,  0.03708D0,  0.03049D0,  0.02496D0,  0.02008D0,
51178      &     0.01594D0,  0.01252D0,  0.00963D0,  0.00542D0,  0.00279D0,
51179      &     0.00126D0,  0.00048D0,  0.00002D0,  0.00000D0/
51180       DATA (FMRS(1,2,I,33),I=1,49)/
51181      &     0.00764D0,  0.01009D0,  0.01333D0,  0.01570D0,  0.01763D0,
51182      &     0.01930D0,  0.02556D0,  0.03396D0,  0.04019D0,  0.04537D0,
51183      &     0.05004D0,  0.06783D0,  0.09177D0,  0.10895D0,  0.12254D0,
51184      &     0.13381D0,  0.15173D0,  0.17130D0,  0.19261D0,  0.20552D0,
51185      &     0.21726D0,  0.21822D0,  0.21313D0,  0.20185D0,  0.18743D0,
51186      &     0.17175D0,  0.15545D0,  0.13931D0,  0.12379D0,  0.10917D0,
51187      &     0.09540D0,  0.08276D0,  0.07118D0,  0.06072D0,  0.05139D0,
51188      &     0.04317D0,  0.03581D0,  0.02938D0,  0.02402D0,  0.01929D0,
51189      &     0.01528D0,  0.01198D0,  0.00920D0,  0.00516D0,  0.00264D0,
51190      &     0.00119D0,  0.00045D0,  0.00002D0,  0.00000D0/
51191       DATA (FMRS(1,2,I,34),I=1,49)/
51192      &     0.00773D0,  0.01021D0,  0.01350D0,  0.01590D0,  0.01786D0,
51193      &     0.01955D0,  0.02590D0,  0.03441D0,  0.04072D0,  0.04597D0,
51194      &     0.05068D0,  0.06863D0,  0.09272D0,  0.10994D0,  0.12353D0,
51195      &     0.13477D0,  0.15260D0,  0.17197D0,  0.19290D0,  0.20543D0,
51196      &     0.21649D0,  0.21688D0,  0.21134D0,  0.19965D0,  0.18497D0,
51197      &     0.16913D0,  0.15278D0,  0.13665D0,  0.12121D0,  0.10669D0,
51198      &     0.09308D0,  0.08060D0,  0.06921D0,  0.05894D0,  0.04980D0,
51199      &     0.04176D0,  0.03458D0,  0.02833D0,  0.02311D0,  0.01853D0,
51200      &     0.01465D0,  0.01147D0,  0.00879D0,  0.00491D0,  0.00250D0,
51201      &     0.00112D0,  0.00042D0,  0.00002D0,  0.00000D0/
51202       DATA (FMRS(1,2,I,35),I=1,49)/
51203      &     0.00781D0,  0.01033D0,  0.01366D0,  0.01609D0,  0.01808D0,
51204      &     0.01979D0,  0.02622D0,  0.03484D0,  0.04123D0,  0.04653D0,
51205      &     0.05129D0,  0.06941D0,  0.09362D0,  0.11088D0,  0.12448D0,
51206      &     0.13569D0,  0.15342D0,  0.17260D0,  0.19318D0,  0.20535D0,
51207      &     0.21576D0,  0.21562D0,  0.20966D0,  0.19759D0,  0.18266D0,
51208      &     0.16668D0,  0.15028D0,  0.13418D0,  0.11882D0,  0.10439D0,
51209      &     0.09094D0,  0.07861D0,  0.06739D0,  0.05729D0,  0.04834D0,
51210      &     0.04048D0,  0.03346D0,  0.02736D0,  0.02228D0,  0.01784D0,
51211      &     0.01408D0,  0.01100D0,  0.00842D0,  0.00468D0,  0.00237D0,
51212      &     0.00106D0,  0.00039D0,  0.00002D0,  0.00000D0/
51213       DATA (FMRS(1,2,I,36),I=1,49)/
51214      &     0.00790D0,  0.01044D0,  0.01382D0,  0.01628D0,  0.01829D0,
51215      &     0.02002D0,  0.02653D0,  0.03525D0,  0.04172D0,  0.04707D0,
51216      &     0.05188D0,  0.07013D0,  0.09447D0,  0.11177D0,  0.12535D0,
51217      &     0.13654D0,  0.15418D0,  0.17318D0,  0.19341D0,  0.20524D0,
51218      &     0.21505D0,  0.21440D0,  0.20805D0,  0.19563D0,  0.18048D0,
51219      &     0.16438D0,  0.14795D0,  0.13186D0,  0.11657D0,  0.10226D0,
51220      &     0.08894D0,  0.07676D0,  0.06571D0,  0.05578D0,  0.04700D0,
51221      &     0.03929D0,  0.03242D0,  0.02648D0,  0.02153D0,  0.01720D0,
51222      &     0.01356D0,  0.01058D0,  0.00808D0,  0.00448D0,  0.00226D0,
51223      &     0.00101D0,  0.00037D0,  0.00002D0,  0.00000D0/
51224       DATA (FMRS(1,2,I,37),I=1,49)/
51225      &     0.00798D0,  0.01056D0,  0.01397D0,  0.01646D0,  0.01850D0,
51226      &     0.02025D0,  0.02684D0,  0.03567D0,  0.04221D0,  0.04762D0,
51227      &     0.05247D0,  0.07087D0,  0.09532D0,  0.11265D0,  0.12622D0,
51228      &     0.13738D0,  0.15492D0,  0.17373D0,  0.19361D0,  0.20510D0,
51229      &     0.21429D0,  0.21315D0,  0.20641D0,  0.19365D0,  0.17829D0,
51230      &     0.16207D0,  0.14561D0,  0.12954D0,  0.11434D0,  0.10013D0,
51231      &     0.08696D0,  0.07493D0,  0.06406D0,  0.05429D0,  0.04567D0,
51232      &     0.03812D0,  0.03141D0,  0.02561D0,  0.02079D0,  0.01659D0,
51233      &     0.01305D0,  0.01017D0,  0.00775D0,  0.00428D0,  0.00215D0,
51234      &     0.00095D0,  0.00035D0,  0.00002D0,  0.00000D0/
51235       DATA (FMRS(1,2,I,38),I=1,49)/
51236      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51237      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51238      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51239      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51240      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51241      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51242      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51243      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51244      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51245      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51246       DATA (FMRS(1,3,I, 1),I=1,49)/
51247      &     3.68244D0,  3.61785D0,  3.55346D0,  3.51555D0,  3.48837D0,
51248      &     3.46702D0,  3.39811D0,  3.32177D0,  3.27072D0,  3.23000D0,
51249      &     3.19378D0,  3.05765D0,  2.86346D0,  2.71339D0,  2.58651D0,
51250      &     2.47572D0,  2.28777D0,  2.06245D0,  1.78178D0,  1.57726D0,
51251      &     1.30519D0,  1.14076D0,  1.03654D0,  0.95264D0,  0.89447D0,
51252      &     0.84663D0,  0.80090D0,  0.75325D0,  0.70217D0,  0.64784D0,
51253      &     0.59048D0,  0.53173D0,  0.47263D0,  0.41459D0,  0.35887D0,
51254      &     0.30634D0,  0.25757D0,  0.21335D0,  0.17415D0,  0.13936D0,
51255      &     0.10957D0,  0.08459D0,  0.06372D0,  0.03369D0,  0.01574D0,
51256      &     0.00625D0,  0.00195D0,  0.00005D0,  0.00000D0/
51257       DATA (FMRS(1,3,I, 2),I=1,49)/
51258      &     6.24307D0,  5.86376D0,  5.50631D0,  5.30646D0,  5.16844D0,
51259      &     5.06337D0,  4.74657D0,  4.44005D0,  4.26242D0,  4.13555D0,
51260      &     4.03502D0,  3.71094D0,  3.34882D0,  3.11051D0,  2.92600D0,
51261      &     2.77355D0,  2.52821D0,  2.24967D0,  1.91859D0,  1.68481D0,
51262      &     1.37946D0,  1.19535D0,  1.07673D0,  0.97819D0,  0.90750D0,
51263      &     0.84881D0,  0.79381D0,  0.73852D0,  0.68149D0,  0.62276D0,
51264      &     0.56254D0,  0.50226D0,  0.44285D0,  0.38548D0,  0.33123D0,
51265      &     0.28073D0,  0.23437D0,  0.19279D0,  0.15633D0,  0.12427D0,
51266      &     0.09707D0,  0.07445D0,  0.05572D0,  0.02906D0,  0.01339D0,
51267      &     0.00524D0,  0.00161D0,  0.00004D0,  0.00000D0/
51268       DATA (FMRS(1,3,I, 3),I=1,49)/
51269      &    11.05139D0,  9.94786D0,  8.95244D0,  8.41536D0,  8.05287D0,
51270      &     7.78166D0,  6.98996D0,  6.26416D0,  5.86369D0,  5.58758D0,
51271      &     5.37431D0,  4.72923D0,  4.08790D0,  3.70661D0,  3.43015D0,
51272      &     3.21204D0,  2.87740D0,  2.51734D0,  2.11023D0,  1.83283D0,
51273      &     1.47833D0,  1.26530D0,  1.12571D0,  1.00618D0,  0.91793D0,
51274      &     0.84442D0,  0.77712D0,  0.71204D0,  0.64770D0,  0.58389D0,
51275      &     0.52071D0,  0.45928D0,  0.40030D0,  0.34459D0,  0.29298D0,
51276      &     0.24576D0,  0.20309D0,  0.16540D0,  0.13284D0,  0.10462D0,
51277      &     0.08093D0,  0.06152D0,  0.04560D0,  0.02333D0,  0.01054D0,
51278      &     0.00404D0,  0.00122D0,  0.00003D0,  0.00000D0/
51279       DATA (FMRS(1,3,I, 4),I=1,49)/
51280      &    15.37825D0, 13.53065D0, 11.90193D0, 11.03924D0, 10.46378D0,
51281      &    10.03696D0,  8.81034D0,  7.71341D0,  7.12073D0,  6.71781D0,
51282      &     6.40918D0,  5.49848D0,  4.63276D0,  4.13943D0,  3.79203D0,
51283      &     3.52386D0,  3.12196D0,  2.70149D0,  2.23890D0,  1.93011D0,
51284      &     1.54059D0,  1.30714D0,  1.15286D0,  1.01886D0,  0.91881D0,
51285      &     0.83562D0,  0.76055D0,  0.68952D0,  0.62095D0,  0.55452D0,
51286      &     0.49011D0,  0.42861D0,  0.37052D0,  0.31647D0,  0.26702D0,
51287      &     0.22241D0,  0.18246D0,  0.14751D0,  0.11769D0,  0.09209D0,
51288      &     0.07074D0,  0.05343D0,  0.03933D0,  0.01985D0,  0.00885D0,
51289      &     0.00335D0,  0.00100D0,  0.00002D0,  0.00000D0/
51290       DATA (FMRS(1,3,I, 5),I=1,49)/
51291      &    20.54786D0, 17.73643D0, 15.30522D0, 14.03720D0, 13.19955D0,
51292      &    12.58273D0, 10.83264D0,  9.29877D0,  8.48369D0,  7.93560D0,
51293      &     7.51848D0,  6.31010D0,  5.19808D0,  4.58383D0,  4.16067D0,
51294      &     3.83948D0,  3.36690D0,  2.88348D0,  2.36367D0,  2.02276D0,
51295      &     1.59751D0,  1.34336D0,  1.17440D0,  1.02619D0,  0.91484D0,
51296      &     0.82260D0,  0.74049D0,  0.66431D0,  0.59227D0,  0.52387D0,
51297      &     0.45886D0,  0.39784D0,  0.34106D0,  0.28898D0,  0.24193D0,
51298      &     0.20003D0,  0.16291D0,  0.13075D0,  0.10361D0,  0.08049D0,
51299      &     0.06141D0,  0.04606D0,  0.03367D0,  0.01676D0,  0.00737D0,
51300      &     0.00275D0,  0.00081D0,  0.00002D0,  0.00000D0/
51301       DATA (FMRS(1,3,I, 6),I=1,49)/
51302      &    25.87997D0, 22.00579D0, 18.70564D0, 17.00514D0, 15.89031D0,
51303      &    15.07400D0, 12.78092D0, 10.80231D0,  9.76436D0,  9.07223D0,
51304      &     8.54820D0,  7.05063D0,  5.70461D0,  4.97765D0,  4.48471D0,
51305      &     4.11512D0,  3.57867D0,  3.03899D0,  2.46867D0,  2.09967D0,
51306      &     1.64344D0,  1.37152D0,  1.19009D0,  1.03003D0,  0.90944D0,
51307      &     0.81000D0,  0.72245D0,  0.64242D0,  0.56795D0,  0.49835D0,
51308      &     0.43318D0,  0.37285D0,  0.31739D0,  0.26712D0,  0.22217D0,
51309      &     0.18254D0,  0.14775D0,  0.11786D0,  0.09285D0,  0.07171D0,
51310      &     0.05439D0,  0.04056D0,  0.02948D0,  0.01450D0,  0.00631D0,
51311      &     0.00232D0,  0.00067D0,  0.00002D0,  0.00000D0/
51312       DATA (FMRS(1,3,I, 7),I=1,49)/
51313      &    31.48650D0, 26.43816D0, 22.19174D0, 20.02570D0, 18.61470D0,
51314      &    17.58636D0, 14.72161D0, 12.28168D0, 11.01532D0, 10.17669D0,
51315      &     9.54456D0,  7.75761D0,  6.18119D0,  5.34474D0,  4.78459D0,
51316      &     4.36861D0,  3.77149D0,  3.17878D0,  2.56125D0,  2.16614D0,
51317      &     1.68135D0,  1.39321D0,  1.20050D0,  1.02990D0,  0.90129D0,
51318      &     0.79577D0,  0.70378D0,  0.62075D0,  0.54457D0,  0.47435D0,
51319      &     0.40939D0,  0.34999D0,  0.29601D0,  0.24758D0,  0.20467D0,
51320      &     0.16718D0,  0.13453D0,  0.10670D0,  0.08361D0,  0.06425D0,
51321      &     0.04845D0,  0.03594D0,  0.02598D0,  0.01264D0,  0.00544D0,
51322      &     0.00198D0,  0.00057D0,  0.00001D0,  0.00000D0/
51323       DATA (FMRS(1,3,I, 8),I=1,49)/
51324      &    38.19562D0, 31.67731D0, 26.26192D0, 23.52700D0, 21.75654D0,
51325      &    20.47217D0, 16.92324D0, 13.93891D0, 12.40615D0, 11.39793D0,
51326      &    10.64140D0,  8.52490D0,  6.69053D0,  5.73328D0,  5.09966D0,
51327      &     4.63338D0,  3.97084D0,  3.32155D0,  2.65414D0,  2.23167D0,
51328      &     1.71719D0,  1.41235D0,  1.20819D0,  1.02708D0,  0.89064D0,
51329      &     0.77934D0,  0.68328D0,  0.59764D0,  0.52014D0,  0.44964D0,
51330      &     0.38523D0,  0.32704D0,  0.27476D0,  0.22832D0,  0.18758D0,
51331      &     0.15228D0,  0.12182D0,  0.09604D0,  0.07484D0,  0.05719D0,
51332      &     0.04288D0,  0.03164D0,  0.02275D0,  0.01095D0,  0.00466D0,
51333      &     0.00168D0,  0.00048D0,  0.00001D0,  0.00000D0/
51334       DATA (FMRS(1,3,I, 9),I=1,49)/
51335      &    44.69263D0, 36.69535D0, 30.11768D0, 26.82255D0, 24.70025D0,
51336      &    23.16639D0, 18.95601D0, 15.45187D0, 13.66736D0, 12.49995D0,
51337      &    11.62724D0,  9.20581D0,  7.13631D0,  6.07035D0,  5.37118D0,
51338      &     4.86033D0,  4.14011D0,  3.44140D0,  2.73081D0,  2.28485D0,
51339      &     1.74506D0,  1.42613D0,  1.21246D0,  1.02274D0,  0.88003D0,
51340      &     0.76424D0,  0.66513D0,  0.57765D0,  0.49935D0,  0.42889D0,
51341      &     0.36519D0,  0.30820D0,  0.25746D0,  0.21275D0,  0.17388D0,
51342      &     0.14043D0,  0.11178D0,  0.08767D0,  0.06799D0,  0.05171D0,
51343      &     0.03859D0,  0.02834D0,  0.02028D0,  0.00968D0,  0.00408D0,
51344      &     0.00146D0,  0.00041D0,  0.00001D0,  0.00000D0/
51345       DATA (FMRS(1,3,I,10),I=1,49)/
51346      &    51.42669D0, 41.84610D0, 34.03689D0, 30.15309D0, 27.66303D0,
51347      &    25.86942D0, 20.97504D0, 16.93923D0, 14.89954D0, 13.57172D0,
51348      &    12.58248D0,  9.85775D0,  7.55746D0,  6.38605D0,  5.62372D0,
51349      &     5.07013D0,  4.29501D0,  3.54959D0,  2.79853D0,  2.33075D0,
51350      &     1.76763D0,  1.43584D0,  1.21358D0,  1.01625D0,  0.86814D0,
51351      &     0.74860D0,  0.64707D0,  0.55827D0,  0.47958D0,  0.40941D0,
51352      &     0.34660D0,  0.29089D0,  0.24172D0,  0.19871D0,  0.16160D0,
51353      &     0.12988D0,  0.10289D0,  0.08032D0,  0.06202D0,  0.04695D0,
51354      &     0.03489D0,  0.02551D0,  0.01818D0,  0.00860D0,  0.00360D0,
51355      &     0.00128D0,  0.00036D0,  0.00001D0,  0.00000D0/
51356       DATA (FMRS(1,3,I,11),I=1,49)/
51357      &    57.20334D0, 46.22931D0, 37.34534D0, 32.95134D0, 30.14391D0,
51358      &    28.12686D0, 22.64741D0, 18.16087D0, 15.90648D0, 14.44434D0,
51359      &    13.35786D0, 10.38182D0,  7.89242D0,  6.63544D0,  5.82215D0,
51360      &     5.23423D0,  4.41529D0,  3.63279D0,  2.84983D0,  2.36499D0,
51361      &     1.78374D0,  1.44206D0,  1.21326D0,  1.01023D0,  0.85815D0,
51362      &     0.73593D0,  0.63273D0,  0.54312D0,  0.46430D0,  0.39449D0,
51363      &     0.33248D0,  0.27783D0,  0.22993D0,  0.18826D0,  0.15250D0,
51364      &     0.12212D0,  0.09637D0,  0.07495D0,  0.05770D0,  0.04352D0,
51365      &     0.03223D0,  0.02349D0,  0.01668D0,  0.00784D0,  0.00326D0,
51366      &     0.00115D0,  0.00032D0,  0.00001D0,  0.00000D0/
51367       DATA (FMRS(1,3,I,12),I=1,49)/
51368      &    70.62117D0, 56.29525D0, 44.85603D0, 39.26056D0, 35.71024D0,
51369      &    33.17249D0, 26.34026D0, 20.82458D0, 18.08508D0, 16.32156D0,
51370      &    15.01807D0, 11.48651D0,  8.58576D0,  7.14521D0,  6.22372D0,
51371      &     5.56345D0,  4.65284D0,  3.79371D0,  2.94559D0,  2.42633D0,
51372      &     1.80899D0,  1.44797D0,  1.20662D0,  0.99291D0,  0.83369D0,
51373      &     0.70687D0,  0.60112D0,  0.51056D0,  0.43209D0,  0.36357D0,
51374      &     0.30359D0,  0.25146D0,  0.20630D0,  0.16753D0,  0.13462D0,
51375      &     0.10696D0,  0.08376D0,  0.06466D0,  0.04944D0,  0.03702D0,
51376      &     0.02722D0,  0.01971D0,  0.01390D0,  0.00645D0,  0.00265D0,
51377      &     0.00093D0,  0.00026D0,  0.00001D0,  0.00000D0/
51378       DATA (FMRS(1,3,I,13),I=1,49)/
51379      &    83.50434D0, 65.82890D0, 51.87140D0, 45.10521D0, 40.83618D0,
51380      &    37.79736D0, 29.67546D0, 23.19327D0, 20.00393D0, 17.96325D0,
51381      &    16.46149D0, 12.42825D0,  9.16326D0,  7.56303D0,  6.54853D0,
51382      &     5.82663D0,  4.83880D0,  3.91602D0,  3.01472D0,  2.46779D0,
51383      &     1.82202D0,  1.44614D0,  1.19543D0,  0.97402D0,  0.80992D0,
51384      &     0.68027D0,  0.57325D0,  0.48262D0,  0.40504D0,  0.33808D0,
51385      &     0.28014D0,  0.23033D0,  0.18761D0,  0.15130D0,  0.12077D0,
51386      &     0.09534D0,  0.07419D0,  0.05692D0,  0.04326D0,  0.03220D0,
51387      &     0.02354D0,  0.01696D0,  0.01189D0,  0.00546D0,  0.00222D0,
51388      &     0.00077D0,  0.00021D0,  0.00001D0,  0.00000D0/
51389       DATA (FMRS(1,3,I,14),I=1,49)/
51390      &    99.26808D0, 77.34151D0, 60.22972D0, 52.01289D0, 46.85941D0,
51391      &    43.20707D0, 33.52017D0, 25.88194D0, 22.16110D0, 19.79557D0,
51392      &    18.06292D0, 13.45200D0,  9.77556D0,  7.99825D0,  6.88178D0,
51393      &     6.09288D0,  5.02224D0,  4.03207D0,  3.07569D0,  2.50055D0,
51394      &     1.82658D0,  1.43637D0,  1.17694D0,  0.94870D0,  0.78062D0,
51395      &     0.64903D0,  0.54156D0,  0.45166D0,  0.37564D0,  0.31084D0,
51396      &     0.25547D0,  0.20834D0,  0.16843D0,  0.13481D0,  0.10686D0,
51397      &     0.08378D0,  0.06476D0,  0.04934D0,  0.03727D0,  0.02756D0,
51398      &     0.02003D0,  0.01435D0,  0.01000D0,  0.00454D0,  0.00183D0,
51399      &     0.00063D0,  0.00017D0,  0.00000D0,  0.00000D0/
51400       DATA (FMRS(1,3,I,15),I=1,49)/
51401      &   117.13634D0, 90.22787D0, 69.46667D0, 59.58908D0, 53.42973D0,
51402      &    49.08310D0, 37.64029D0, 28.72286D0, 24.42074D0, 21.70264D0,
51403      &    19.72087D0, 14.49332D0, 10.38573D0,  8.42544D0,  7.20484D0,
51404      &     6.34818D0,  5.19436D0,  4.13748D0,  3.12707D0,  2.52493D0,
51405      &     1.82437D0,  1.42118D0,  1.15415D0,  0.92032D0,  0.74934D0,
51406      &     0.61673D0,  0.50955D0,  0.42103D0,  0.34703D0,  0.28471D0,
51407      &     0.23205D0,  0.18777D0,  0.15064D0,  0.11967D0,  0.09419D0,
51408      &     0.07336D0,  0.05631D0,  0.04263D0,  0.03201D0,  0.02354D0,
51409      &     0.01700D0,  0.01211D0,  0.00839D0,  0.00377D0,  0.00151D0,
51410      &     0.00052D0,  0.00014D0,  0.00000D0,  0.00000D0/
51411       DATA (FMRS(1,3,I,16),I=1,49)/
51412      &   134.87820D0,102.87527D0, 78.42588D0, 66.88609D0, 59.72612D0,
51413      &    54.69190D0, 41.52393D0, 31.36570D0, 26.50579D0, 23.45176D0,
51414      &    21.23395D0, 15.42784D0, 10.92244D0,  8.79593D0,  7.48170D0,
51415      &     6.56462D0,  5.33723D0,  4.22208D0,  3.16533D0,  2.54035D0,
51416      &     1.81781D0,  1.40424D0,  1.13142D0,  0.89365D0,  0.72095D0,
51417      &     0.58811D0,  0.48181D0,  0.39483D0,  0.32289D0,  0.26295D0,
51418      &     0.21278D0,  0.17100D0,  0.13629D0,  0.10758D0,  0.08415D0,
51419      &     0.06517D0,  0.04972D0,  0.03744D0,  0.02797D0,  0.02046D0,
51420      &     0.01470D0,  0.01042D0,  0.00719D0,  0.00321D0,  0.00127D0,
51421      &     0.00043D0,  0.00012D0,  0.00000D0,  0.00000D0/
51422       DATA (FMRS(1,3,I,17),I=1,49)/
51423      &   154.38010D0,116.63111D0, 88.06633D0, 74.68806D0, 66.42747D0,
51424      &    60.64011D0, 45.59593D0, 34.10384D0, 28.65021D0, 25.24085D0,
51425      &    22.77463D0, 16.36506D0, 11.45095D0,  9.15610D0,  7.74790D0,
51426      &     6.77064D0,  5.47057D0,  4.29852D0,  3.19720D0,  2.55058D0,
51427      &     1.80771D0,  1.38488D0,  1.10716D0,  0.86634D0,  0.69264D0,
51428      &     0.56014D0,  0.45511D0,  0.36997D0,  0.30026D0,  0.24276D0,
51429      &     0.19507D0,  0.15573D0,  0.12333D0,  0.09676D0,  0.07524D0,
51430      &     0.05794D0,  0.04395D0,  0.03292D0,  0.02447D0,  0.01781D0,
51431      &     0.01274D0,  0.00899D0,  0.00618D0,  0.00274D0,  0.00108D0,
51432      &     0.00037D0,  0.00010D0,  0.00000D0,  0.00000D0/
51433       DATA (FMRS(1,3,I,18),I=1,49)/
51434      &   171.60985D0,128.66806D0, 96.41977D0, 81.40891D0, 72.17590D0,
51435      &    65.72558D0, 49.04064D0, 36.39427D0, 30.43144D0, 26.71914D0,
51436      &    24.04215D0, 17.12464D0, 11.87120D0,  9.43856D0,  7.95410D0,
51437      &     6.92832D0,  5.57016D0,  4.35322D0,  3.21721D0,  2.55406D0,
51438      &     1.79608D0,  1.36671D0,  1.08575D0,  0.84319D0,  0.66925D0,
51439      &     0.53749D0,  0.43376D0,  0.35041D0,  0.28267D0,  0.22722D0,
51440      &     0.18154D0,  0.14418D0,  0.11359D0,  0.08871D0,  0.06865D0,
51441      &     0.05262D0,  0.03976D0,  0.02965D0,  0.02195D0,  0.01592D0,
51442      &     0.01135D0,  0.00798D0,  0.00547D0,  0.00241D0,  0.00095D0,
51443      &     0.00032D0,  0.00009D0,  0.00000D0,  0.00000D0/
51444       DATA (FMRS(1,3,I,19),I=1,49)/
51445      &   193.78899D0,144.01862D0,106.97157D0, 89.85031D0, 79.36631D0,
51446      &    72.06629D0, 53.29134D0, 39.18974D0, 32.59051D0, 28.50177D0,
51447      &    25.56394D0, 18.02311D0, 12.35926D0,  9.76179D0,  8.18702D0,
51448      &     7.10431D0,  5.67841D0,  4.40968D0,  3.23437D0,  2.55292D0,
51449      &     1.77867D0,  1.34261D0,  1.05865D0,  0.81484D0,  0.64125D0,
51450      &     0.51082D0,  0.40904D0,  0.32798D0,  0.26269D0,  0.20975D0,
51451      &     0.16651D0,  0.13145D0,  0.10293D0,  0.07994D0,  0.06153D0,
51452      &     0.04691D0,  0.03527D0,  0.02618D0,  0.01929D0,  0.01394D0,
51453      &     0.00989D0,  0.00693D0,  0.00473D0,  0.00207D0,  0.00081D0,
51454      &     0.00027D0,  0.00007D0,  0.00000D0,  0.00000D0/
51455       DATA (FMRS(1,3,I,20),I=1,49)/
51456      &   214.89481D0,158.49641D0,116.83355D0, 97.69725D0, 86.02460D0,
51457      &    77.91979D0, 57.17770D0, 41.71972D0, 34.53225D0, 30.09744D0,
51458      &    26.92084D0, 18.81368D0, 12.78187D0, 10.03830D0,  8.38419D0,
51459      &     7.25181D0,  5.76723D0,  4.45410D0,  3.24560D0,  2.54901D0,
51460      &     1.76164D0,  1.32048D0,  1.03446D0,  0.79010D0,  0.61721D0,
51461      &     0.48824D0,  0.38835D0,  0.30938D0,  0.24629D0,  0.19551D0,
51462      &     0.15438D0,  0.12122D0,  0.09444D0,  0.07299D0,  0.05594D0,
51463      &     0.04245D0,  0.03178D0,  0.02349D0,  0.01725D0,  0.01242D0,
51464      &     0.00879D0,  0.00614D0,  0.00418D0,  0.00182D0,  0.00071D0,
51465      &     0.00024D0,  0.00007D0,  0.00000D0,  0.00000D0/
51466       DATA (FMRS(1,3,I,21),I=1,49)/
51467      &   234.93695D0,172.12665D0,126.03609D0,104.98046D0, 92.18044D0,
51468      &    83.31506D0, 60.72429D0, 44.00365D0, 36.27307D0, 31.52044D0,
51469      &    28.12565D0, 19.50453D0, 13.14306D0, 10.27071D0,  8.54710D0,
51470      &     7.37140D0,  5.83642D0,  4.48556D0,  3.24949D0,  2.54059D0,
51471      &     1.74309D0,  1.29840D0,  1.01128D0,  0.76711D0,  0.59538D0,
51472      &     0.46805D0,  0.37012D0,  0.29319D0,  0.23219D0,  0.18337D0,
51473      &     0.14410D0,  0.11261D0,  0.08738D0,  0.06725D0,  0.05133D0,
51474      &     0.03881D0,  0.02895D0,  0.02133D0,  0.01562D0,  0.01121D0,
51475      &     0.00791D0,  0.00551D0,  0.00374D0,  0.00162D0,  0.00063D0,
51476      &     0.00021D0,  0.00006D0,  0.00000D0,  0.00000D0/
51477       DATA (FMRS(1,3,I,22),I=1,49)/
51478      &   261.98752D0,190.37146D0,138.25069D0,114.59908D0,100.28083D0,
51479      &    90.39440D0, 65.33586D0, 46.94503D0, 38.50155D0, 33.33386D0,
51480      &    29.65516D0, 20.37022D0, 13.58831D0, 10.55348D0,  8.74295D0,
51481      &     7.51340D0,  5.91633D0,  4.51953D0,  3.25037D0,  2.52703D0,
51482      &     1.71812D0,  1.26985D0,  0.98192D0,  0.73853D0,  0.56860D0,
51483      &     0.44359D0,  0.34825D0,  0.27396D0,  0.21556D0,  0.16918D0,
51484      &     0.13216D0,  0.10269D0,  0.07927D0,  0.06069D0,  0.04611D0,
51485      &     0.03471D0,  0.02577D0,  0.01891D0,  0.01380D0,  0.00987D0,
51486      &     0.00694D0,  0.00482D0,  0.00326D0,  0.00141D0,  0.00055D0,
51487      &     0.00018D0,  0.00005D0,  0.00000D0,  0.00000D0/
51488       DATA (FMRS(1,3,I,23),I=1,49)/
51489      &   289.01031D0,208.43709D0,150.23653D0,123.98669D0,108.15595D0,
51490      &    97.25583D0, 69.76177D0, 49.73855D0, 40.60409D0, 35.03629D0,
51491      &    31.08496D0, 21.16773D0, 13.99081D0, 10.80513D0,  8.91469D0,
51492      &     7.63597D0,  5.98282D0,  4.54504D0,  3.24687D0,  2.51128D0,
51493      &     1.69316D0,  1.24243D0,  0.95435D0,  0.71223D0,  0.54431D0,
51494      &     0.42170D0,  0.32889D0,  0.25710D0,  0.20110D0,  0.15697D0,
51495      &     0.12195D0,  0.09429D0,  0.07242D0,  0.05518D0,  0.04175D0,
51496      &     0.03132D0,  0.02316D0,  0.01693D0,  0.01232D0,  0.00878D0,
51497      &     0.00615D0,  0.00426D0,  0.00288D0,  0.00124D0,  0.00048D0,
51498      &     0.00016D0,  0.00004D0,  0.00000D0,  0.00000D0/
51499       DATA (FMRS(1,3,I,24),I=1,49)/
51500      &   315.12421D0,225.74153D0,161.61246D0,132.84715D0,115.55888D0,
51501      &   103.68510D0, 73.86555D0, 52.29894D0, 42.51674D0, 36.57598D0,
51502      &    32.37159D0, 21.87235D0, 14.33730D0, 11.01653D0,  9.05547D0,
51503      &     7.73389D0,  6.03187D0,  4.55934D0,  3.23736D0,  2.49207D0,
51504      &     1.66734D0,  1.21544D0,  0.92800D0,  0.68769D0,  0.52210D0,
51505      &     0.40197D0,  0.31164D0,  0.24228D0,  0.18850D0,  0.14640D0,
51506      &     0.11322D0,  0.08715D0,  0.06666D0,  0.05059D0,  0.03813D0,
51507      &     0.02850D0,  0.02101D0,  0.01531D0,  0.01111D0,  0.00790D0,
51508      &     0.00552D0,  0.00382D0,  0.00258D0,  0.00111D0,  0.00043D0,
51509      &     0.00014D0,  0.00004D0,  0.00000D0,  0.00000D0/
51510       DATA (FMRS(1,3,I,25),I=1,49)/
51511      &   342.80673D0,243.95296D0,173.49684D0,142.06322D0,123.23465D0,
51512      &   110.33495D0, 78.07693D0, 54.90473D0, 44.45325D0, 38.12883D0,
51513      &    33.66507D0, 22.57285D0, 14.67683D0, 11.22134D0,  9.19035D0,
51514      &     7.82660D0,  6.07682D0,  4.57070D0,  3.22605D0,  2.47181D0,
51515      &     1.64130D0,  1.18872D0,  0.90224D0,  0.66398D0,  0.50084D0,
51516      &     0.38326D0,  0.29541D0,  0.22842D0,  0.17680D0,  0.13666D0,
51517      &     0.10521D0,  0.08063D0,  0.06143D0,  0.04643D0,  0.03487D0,
51518      &     0.02598D0,  0.01909D0,  0.01388D0,  0.01004D0,  0.00712D0,
51519      &     0.00496D0,  0.00343D0,  0.00231D0,  0.00099D0,  0.00038D0,
51520      &     0.00013D0,  0.00004D0,  0.00000D0,  0.00000D0/
51521       DATA (FMRS(1,3,I,26),I=1,49)/
51522      &   370.71918D0,262.16998D0,185.28712D0,151.16048D0,130.78375D0,
51523      &   116.85600D0, 82.16776D0, 57.40948D0, 46.30192D0, 39.60334D0,
51524      &    34.88776D0, 23.22383D0, 14.98428D0, 11.40259D0,  9.30664D0,
51525      &     7.90402D0,  6.11093D0,  4.57472D0,  3.21035D0,  2.44880D0,
51526      &     1.61427D0,  1.16192D0,  0.87693D0,  0.64114D0,  0.48063D0,
51527      &     0.36570D0,  0.28035D0,  0.21566D0,  0.16615D0,  0.12784D0,
51528      &     0.09801D0,  0.07482D0,  0.05679D0,  0.04277D0,  0.03202D0,
51529      &     0.02378D0,  0.01743D0,  0.01263D0,  0.00912D0,  0.00645D0,
51530      &     0.00449D0,  0.00310D0,  0.00208D0,  0.00089D0,  0.00034D0,
51531      &     0.00012D0,  0.00003D0,  0.00000D0,  0.00000D0/
51532       DATA (FMRS(1,3,I,27),I=1,49)/
51533      &   398.31635D0,280.05777D0,196.78310D0,159.99336D0,138.09111D0,
51534      &   123.15311D0, 86.08746D0, 59.78946D0, 48.04917D0, 40.99130D0,
51535      &    36.03455D0, 23.82682D0, 15.26416D0, 11.56505D0,  9.40909D0,
51536      &     7.97073D0,  6.13825D0,  4.57511D0,  3.19349D0,  2.42581D0,
51537      &     1.58834D0,  1.13668D0,  0.85340D0,  0.62017D0,  0.46227D0,
51538      &     0.34987D0,  0.26689D0,  0.20435D0,  0.15674D0,  0.12011D0,
51539      &     0.09172D0,  0.06977D0,  0.05278D0,  0.03962D0,  0.02958D0,
51540      &     0.02190D0,  0.01601D0,  0.01157D0,  0.00834D0,  0.00589D0,
51541      &     0.00409D0,  0.00282D0,  0.00189D0,  0.00081D0,  0.00031D0,
51542      &     0.00010D0,  0.00003D0,  0.00000D0,  0.00000D0/
51543       DATA (FMRS(1,3,I,28),I=1,49)/
51544      &   425.10541D0,297.30496D0,207.79007D0,168.41481D0,145.03664D0,
51545      &   129.12375D0, 89.77434D0, 62.00834D0, 49.66874D0, 42.27205D0,
51546      &    37.08847D0, 24.37295D0, 15.51221D0, 11.70602D0,  9.49577D0,
51547      &     8.02523D0,  6.15776D0,  4.57120D0,  3.17506D0,  2.40249D0,
51548      &     1.56325D0,  1.11278D0,  0.83141D0,  0.60084D0,  0.44554D0,
51549      &     0.33559D0,  0.25483D0,  0.19432D0,  0.14844D0,  0.11333D0,
51550      &     0.08624D0,  0.06537D0,  0.04932D0,  0.03692D0,  0.02748D0,
51551      &     0.02030D0,  0.01481D0,  0.01068D0,  0.00768D0,  0.00541D0,
51552      &     0.00376D0,  0.00258D0,  0.00173D0,  0.00074D0,  0.00028D0,
51553      &     0.00010D0,  0.00003D0,  0.00000D0,  0.00000D0/
51554       DATA (FMRS(1,3,I,29),I=1,49)/
51555      &   452.96622D0,315.13217D0,219.09509D0,177.03108D0,152.12305D0,
51556      &   135.20210D0, 93.50108D0, 64.23380D0, 51.28493D0, 43.54515D0,
51557      &    38.13279D0, 24.90754D0, 15.75054D0, 11.83897D0,  9.57579D0,
51558      &     8.07414D0,  6.17308D0,  4.56436D0,  3.15482D0,  2.37807D0,
51559      &     1.53780D0,  1.08891D0,  0.80971D0,  0.58195D0,  0.42935D0,
51560      &     0.32187D0,  0.24333D0,  0.18479D0,  0.14060D0,  0.10697D0,
51561      &     0.08112D0,  0.06130D0,  0.04611D0,  0.03442D0,  0.02556D0,
51562      &     0.01884D0,  0.01371D0,  0.00987D0,  0.00709D0,  0.00499D0,
51563      &     0.00346D0,  0.00237D0,  0.00159D0,  0.00068D0,  0.00026D0,
51564      &     0.00009D0,  0.00002D0,  0.00000D0,  0.00000D0/
51565       DATA (FMRS(1,3,I,30),I=1,49)/
51566      &   481.05176D0,332.98895D0,230.34398D0,185.57016D0,159.12541D0,
51567      &   141.19426D0, 97.14677D0, 66.39220D0, 52.84356D0, 44.76743D0,
51568      &    39.13180D0, 25.41137D0, 15.96984D0, 11.95815D0,  9.64523D0,
51569      &     8.11468D0,  6.18265D0,  4.55389D0,  3.13269D0,  2.35270D0,
51570      &     1.51231D0,  1.06542D0,  0.78862D0,  0.56381D0,  0.41396D0,
51571      &     0.30893D0,  0.23257D0,  0.17592D0,  0.13335D0,  0.10111D0,
51572      &     0.07645D0,  0.05760D0,  0.04319D0,  0.03217D0,  0.02383D0,
51573      &     0.01753D0,  0.01273D0,  0.00915D0,  0.00656D0,  0.00461D0,
51574      &     0.00319D0,  0.00219D0,  0.00146D0,  0.00062D0,  0.00024D0,
51575      &     0.00008D0,  0.00002D0,  0.00000D0,  0.00000D0/
51576       DATA (FMRS(1,3,I,31),I=1,49)/
51577      &   508.69336D0,350.46606D0,241.29128D0,193.85184D0,165.89978D0,
51578      &   146.97998D0,100.64462D0, 68.44891D0, 54.32217D0, 45.92301D0,
51579      &    40.07352D0, 25.88124D0, 16.17098D0, 12.06571D0,  9.70659D0,
51580      &     8.14933D0,  6.18899D0,  4.54214D0,  3.11075D0,  2.32815D0,
51581      &     1.48813D0,  1.04340D0,  0.76902D0,  0.54710D0,  0.39988D0,
51582      &     0.29718D0,  0.22284D0,  0.16794D0,  0.12688D0,  0.09590D0,
51583      &     0.07230D0,  0.05433D0,  0.04063D0,  0.03020D0,  0.02232D0,
51584      &     0.01639D0,  0.01188D0,  0.00852D0,  0.00610D0,  0.00428D0,
51585      &     0.00296D0,  0.00203D0,  0.00136D0,  0.00057D0,  0.00022D0,
51586      &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
51587       DATA (FMRS(1,3,I,32),I=1,49)/
51588      &   535.18030D0,367.11212D0,251.65173D0,201.65910D0,172.26764D0,
51589      &   152.40591D0,103.89980D0, 70.34598D0, 55.67789D0, 46.97741D0,
51590      &    40.92907D0, 26.30087D0, 16.34517D0, 12.15570D0,  9.75539D0,
51591      &     8.17448D0,  6.18955D0,  4.52735D0,  3.08788D0,  2.30359D0,
51592      &     1.46475D0,  1.02248D0,  0.75063D0,  0.53161D0,  0.38695D0,
51593      &     0.28648D0,  0.21405D0,  0.16077D0,  0.12112D0,  0.09128D0,
51594      &     0.06863D0,  0.05145D0,  0.03839D0,  0.02847D0,  0.02101D0,
51595      &     0.01540D0,  0.01114D0,  0.00798D0,  0.00571D0,  0.00400D0,
51596      &     0.00276D0,  0.00189D0,  0.00126D0,  0.00054D0,  0.00020D0,
51597      &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
51598       DATA (FMRS(1,3,I,33),I=1,49)/
51599      &   563.08673D0,384.57391D0,262.47256D0,209.79239D0,178.88937D0,
51600      &   158.04028D0,107.26506D0, 72.29848D0, 57.06943D0, 48.05758D0,
51601      &    41.80413D0, 26.72791D0, 16.52149D0, 12.24650D0,  9.80451D0,
51602      &     8.19975D0,  6.19012D0,  4.51259D0,  3.06514D0,  2.27926D0,
51603      &     1.44171D0,  1.00196D0,  0.73265D0,  0.51654D0,  0.37443D0,
51604      &     0.27615D0,  0.20559D0,  0.15389D0,  0.11561D0,  0.08687D0,
51605      &     0.06514D0,  0.04872D0,  0.03627D0,  0.02685D0,  0.01977D0,
51606      &     0.01446D0,  0.01045D0,  0.00747D0,  0.00534D0,  0.00374D0,
51607      &     0.00258D0,  0.00176D0,  0.00118D0,  0.00050D0,  0.00019D0,
51608      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
51609       DATA (FMRS(1,3,I,34),I=1,49)/
51610      &   590.49207D0,401.61096D0,272.95639D0,217.63766D0,185.25558D0,
51611      &   163.44283D0,110.46277D0, 74.13376D0, 58.36747D0, 49.05885D0,
51612      &    42.61046D0, 27.11206D0, 16.67322D0, 12.31989D0,  9.84041D0,
51613      &     8.21457D0,  6.18338D0,  4.49312D0,  3.03982D0,  2.25340D0,
51614      &     1.41818D0,  0.98144D0,  0.71494D0,  0.50189D0,  0.36238D0,
51615      &     0.26631D0,  0.19763D0,  0.14748D0,  0.11046D0,  0.08279D0,
51616      &     0.06193D0,  0.04622D0,  0.03434D0,  0.02537D0,  0.01865D0,
51617      &     0.01362D0,  0.00983D0,  0.00702D0,  0.00501D0,  0.00351D0,
51618      &     0.00242D0,  0.00165D0,  0.00110D0,  0.00046D0,  0.00018D0,
51619      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
51620       DATA (FMRS(1,3,I,35),I=1,49)/
51621      &   617.67798D0,418.44214D0,283.27148D0,225.33791D0,191.49365D0,
51622      &   168.72942D0,113.57884D0, 75.91459D0, 59.62379D0, 50.02613D0,
51623      &    43.38823D0, 27.48080D0, 16.81807D0, 12.38969D0,  9.87443D0,
51624      &     8.22855D0,  6.17694D0,  4.47470D0,  3.01600D0,  2.22915D0,
51625      &     1.39622D0,  0.96237D0,  0.69854D0,  0.48839D0,  0.35132D0,
51626      &     0.25731D0,  0.19037D0,  0.14164D0,  0.10579D0,  0.07911D0,
51627      &     0.05904D0,  0.04396D0,  0.03261D0,  0.02405D0,  0.01765D0,
51628      &     0.01287D0,  0.00928D0,  0.00662D0,  0.00472D0,  0.00330D0,
51629      &     0.00227D0,  0.00155D0,  0.00103D0,  0.00044D0,  0.00017D0,
51630      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
51631       DATA (FMRS(1,3,I,36),I=1,49)/
51632      &   643.85529D0,434.56937D0,293.10349D0,232.65437D0,197.40677D0,
51633      &   173.73129D0,116.50865D0, 77.57690D0, 60.79072D0, 50.92106D0,
51634      &    44.10533D0, 27.81589D0, 16.94600D0, 12.44906D0,  9.90141D0,
51635      &     8.23759D0,  6.16791D0,  4.45540D0,  2.99242D0,  2.20560D0,
51636      &     1.37532D0,  0.94442D0,  0.68324D0,  0.47589D0,  0.34114D0,
51637      &     0.24908D0,  0.18375D0,  0.13636D0,  0.10159D0,  0.07580D0,
51638      &     0.05645D0,  0.04195D0,  0.03106D0,  0.02287D0,  0.01676D0,
51639      &     0.01221D0,  0.00879D0,  0.00626D0,  0.00446D0,  0.00311D0,
51640      &     0.00214D0,  0.00146D0,  0.00097D0,  0.00041D0,  0.00016D0,
51641      &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
51642       DATA (FMRS(1,3,I,37),I=1,49)/
51643      &   670.62598D0,450.98129D0,303.05762D0,240.03790D0,203.35986D0,
51644      &   178.75746D0,119.43383D0, 79.22430D0, 61.94125D0, 51.79964D0,
51645      &    44.80675D0, 28.13850D0, 17.06516D0, 12.50182D0,  9.92310D0,
51646      &     8.24227D0,  6.15572D0,  4.43398D0,  2.96756D0,  2.18122D0,
51647      &     1.35409D0,  0.92638D0,  0.66799D0,  0.46354D0,  0.33115D0,
51648      &     0.24105D0,  0.17731D0,  0.13125D0,  0.09756D0,  0.07262D0,
51649      &     0.05397D0,  0.04005D0,  0.02960D0,  0.02176D0,  0.01592D0,
51650      &     0.01159D0,  0.00833D0,  0.00593D0,  0.00422D0,  0.00294D0,
51651      &     0.00202D0,  0.00138D0,  0.00092D0,  0.00039D0,  0.00015D0,
51652      &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
51653       DATA (FMRS(1,3,I,38),I=1,49)/
51654      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51655      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51656      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51657      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51658      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51659      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51660      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51661      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51662      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
51663      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51664       DATA (FMRS(1,4,I, 1),I=1,49)/
51665      &     0.86800D0,  0.76598D0,  0.67520D0,  0.62675D0,  0.59428D0,
51666      &     0.57013D0,  0.50046D0,  0.43816D0,  0.40484D0,  0.38253D0,
51667      &     0.36613D0,  0.31874D0,  0.27654D0,  0.25397D0,  0.23882D0,
51668      &     0.22750D0,  0.21099D0,  0.19387D0,  0.17401D0,  0.15872D0,
51669      &     0.13363D0,  0.11222D0,  0.09356D0,  0.07392D0,  0.05824D0,
51670      &     0.04613D0,  0.03700D0,  0.03017D0,  0.02498D0,  0.02125D0,
51671      &     0.01786D0,  0.01513D0,  0.01268D0,  0.01040D0,  0.00852D0,
51672      &     0.00674D0,  0.00520D0,  0.00388D0,  0.00299D0,  0.00201D0,
51673      &     0.00134D0,  0.00094D0,  0.00051D0,  0.00021D0,  0.00007D0,
51674      &     0.00003D0, -0.00001D0,  0.00000D0,  0.00000D0/
51675       DATA (FMRS(1,4,I, 2),I=1,49)/
51676      &     0.88205D0,  0.77983D0,  0.68869D0,  0.63997D0,  0.60729D0,
51677      &     0.58296D0,  0.51264D0,  0.44961D0,  0.41580D0,  0.39312D0,
51678      &     0.37640D0,  0.32792D0,  0.28442D0,  0.26097D0,  0.24515D0,
51679      &     0.23328D0,  0.21590D0,  0.19782D0,  0.17683D0,  0.16077D0,
51680      &     0.13467D0,  0.11273D0,  0.09381D0,  0.07406D0,  0.05839D0,
51681      &     0.04632D0,  0.03722D0,  0.03037D0,  0.02516D0,  0.02135D0,
51682      &     0.01792D0,  0.01513D0,  0.01262D0,  0.01032D0,  0.00842D0,
51683      &     0.00664D0,  0.00510D0,  0.00380D0,  0.00291D0,  0.00197D0,
51684      &     0.00130D0,  0.00091D0,  0.00051D0,  0.00020D0,  0.00007D0,
51685      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
51686       DATA (FMRS(1,4,I, 3),I=1,49)/
51687      &     0.91886D0,  0.81356D0,  0.71953D0,  0.66920D0,  0.63541D0,
51688      &     0.61023D0,  0.53738D0,  0.47189D0,  0.43666D0,  0.41295D0,
51689      &     0.39539D0,  0.34428D0,  0.29794D0,  0.27277D0,  0.25567D0,
51690      &     0.24279D0,  0.22388D0,  0.20416D0,  0.18131D0,  0.16398D0,
51691      &     0.13630D0,  0.11352D0,  0.09418D0,  0.07425D0,  0.05857D0,
51692      &     0.04653D0,  0.03744D0,  0.03056D0,  0.02532D0,  0.02139D0,
51693      &     0.01791D0,  0.01504D0,  0.01246D0,  0.01016D0,  0.00822D0,
51694      &     0.00648D0,  0.00493D0,  0.00368D0,  0.00278D0,  0.00188D0,
51695      &     0.00124D0,  0.00086D0,  0.00051D0,  0.00020D0,  0.00006D0,
51696      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
51697       DATA (FMRS(1,4,I, 4),I=1,49)/
51698      &     0.95997D0,  0.84981D0,  0.75147D0,  0.69884D0,  0.66351D0,
51699      &     0.63718D0,  0.56100D0,  0.49247D0,  0.45556D0,  0.43069D0,
51700      &     0.41221D0,  0.35830D0,  0.30918D0,  0.28239D0,  0.26415D0,
51701      &     0.25039D0,  0.23017D0,  0.20908D0,  0.18474D0,  0.16642D0,
51702      &     0.13752D0,  0.11409D0,  0.09444D0,  0.07437D0,  0.05864D0,
51703      &     0.04662D0,  0.03752D0,  0.03063D0,  0.02535D0,  0.02135D0,
51704      &     0.01783D0,  0.01492D0,  0.01232D0,  0.01000D0,  0.00803D0,
51705      &     0.00631D0,  0.00479D0,  0.00358D0,  0.00268D0,  0.00180D0,
51706      &     0.00120D0,  0.00084D0,  0.00049D0,  0.00020D0,  0.00006D0,
51707      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51708       DATA (FMRS(1,4,I, 5),I=1,49)/
51709      &     1.02269D0,  0.90363D0,  0.79759D0,  0.74093D0,  0.70294D0,
51710      &     0.67465D0,  0.59289D0,  0.51944D0,  0.47990D0,  0.45324D0,
51711      &     0.43337D0,  0.37541D0,  0.32249D0,  0.29359D0,  0.27391D0,
51712      &     0.25907D0,  0.23726D0,  0.21456D0,  0.18851D0,  0.16906D0,
51713      &     0.13883D0,  0.11469D0,  0.09468D0,  0.07442D0,  0.05863D0,
51714      &     0.04662D0,  0.03753D0,  0.03061D0,  0.02531D0,  0.02124D0,
51715      &     0.01767D0,  0.01472D0,  0.01211D0,  0.00977D0,  0.00782D0,
51716      &     0.00614D0,  0.00464D0,  0.00341D0,  0.00257D0,  0.00173D0,
51717      &     0.00113D0,  0.00080D0,  0.00046D0,  0.00018D0,  0.00005D0,
51718      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
51719       DATA (FMRS(1,4,I, 6),I=1,49)/
51720      &     1.08763D0,  0.95875D0,  0.84428D0,  0.78326D0,  0.74239D0,
51721      &     0.71199D0,  0.62427D0,  0.54563D0,  0.50333D0,  0.47482D0,
51722      &     0.45353D0,  0.39146D0,  0.33478D0,  0.30385D0,  0.28279D0,
51723      &     0.26692D0,  0.24362D0,  0.21944D0,  0.19183D0,  0.17138D0,
51724      &     0.13995D0,  0.11519D0,  0.09486D0,  0.07444D0,  0.05860D0,
51725      &     0.04659D0,  0.03750D0,  0.03056D0,  0.02523D0,  0.02111D0,
51726      &     0.01751D0,  0.01454D0,  0.01191D0,  0.00957D0,  0.00764D0,
51727      &     0.00598D0,  0.00450D0,  0.00328D0,  0.00247D0,  0.00167D0,
51728      &     0.00107D0,  0.00076D0,  0.00044D0,  0.00016D0,  0.00005D0,
51729      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
51730       DATA (FMRS(1,4,I, 7),I=1,49)/
51731      &     1.16556D0,  1.02401D0,  0.89875D0,  0.83219D0,  0.78769D0,
51732      &     0.75465D0,  0.65951D0,  0.57450D0,  0.52889D0,  0.49818D0,
51733      &     0.47520D0,  0.40838D0,  0.34748D0,  0.31432D0,  0.29177D0,
51734      &     0.27481D0,  0.24995D0,  0.22424D0,  0.19505D0,  0.17361D0,
51735      &     0.14101D0,  0.11563D0,  0.09500D0,  0.07441D0,  0.05852D0,
51736      &     0.04652D0,  0.03740D0,  0.03045D0,  0.02509D0,  0.02093D0,
51737      &     0.01733D0,  0.01434D0,  0.01170D0,  0.00939D0,  0.00744D0,
51738      &     0.00582D0,  0.00436D0,  0.00318D0,  0.00238D0,  0.00161D0,
51739      &     0.00104D0,  0.00073D0,  0.00042D0,  0.00014D0,  0.00005D0,
51740      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
51741       DATA (FMRS(1,4,I, 8),I=1,49)/
51742      &     1.26306D0,  1.10484D0,  0.96554D0,  0.89180D0,  0.84263D0,
51743      &     0.80618D0,  0.70157D0,  0.60853D0,  0.55877D0,  0.52532D0,
51744      &     0.50028D0,  0.42768D0,  0.36175D0,  0.32597D0,  0.30171D0,
51745      &     0.28349D0,  0.25687D0,  0.22944D0,  0.19851D0,  0.17597D0,
51746      &     0.14210D0,  0.11607D0,  0.09509D0,  0.07433D0,  0.05839D0,
51747      &     0.04638D0,  0.03725D0,  0.03028D0,  0.02490D0,  0.02071D0,
51748      &     0.01710D0,  0.01411D0,  0.01147D0,  0.00917D0,  0.00724D0,
51749      &     0.00565D0,  0.00421D0,  0.00306D0,  0.00228D0,  0.00155D0,
51750      &     0.00101D0,  0.00070D0,  0.00040D0,  0.00013D0,  0.00005D0,
51751      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
51752       DATA (FMRS(1,4,I, 9),I=1,49)/
51753      &     1.36120D0,  1.18550D0,  1.03156D0,  0.95040D0,  0.89642D0,
51754      &     0.85647D0,  0.74219D0,  0.64102D0,  0.58710D0,  0.55092D0,
51755      &     0.52385D0,  0.44558D0,  0.37481D0,  0.33656D0,  0.31068D0,
51756      &     0.29130D0,  0.26304D0,  0.23405D0,  0.20153D0,  0.17803D0,
51757      &     0.14303D0,  0.11643D0,  0.09515D0,  0.07423D0,  0.05825D0,
51758      &     0.04622D0,  0.03709D0,  0.03010D0,  0.02471D0,  0.02052D0,
51759      &     0.01688D0,  0.01389D0,  0.01125D0,  0.00895D0,  0.00706D0,
51760      &     0.00550D0,  0.00409D0,  0.00295D0,  0.00220D0,  0.00150D0,
51761      &     0.00098D0,  0.00067D0,  0.00039D0,  0.00013D0,  0.00005D0,
51762      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
51763       DATA (FMRS(1,4,I,10),I=1,49)/
51764      &     1.47041D0,  1.27446D0,  1.10370D0,  1.01406D0,  0.95460D0,
51765      &     0.91068D0,  0.78549D0,  0.67526D0,  0.61674D0,  0.57757D0,
51766      &     0.54827D0,  0.46388D0,  0.38797D0,  0.34713D0,  0.31960D0,
51767      &     0.29901D0,  0.26910D0,  0.23853D0,  0.20444D0,  0.17998D0,
51768      &     0.14388D0,  0.11673D0,  0.09517D0,  0.07410D0,  0.05807D0,
51769      &     0.04602D0,  0.03690D0,  0.02989D0,  0.02450D0,  0.02029D0,
51770      &     0.01665D0,  0.01365D0,  0.01102D0,  0.00875D0,  0.00689D0,
51771      &     0.00534D0,  0.00396D0,  0.00285D0,  0.00213D0,  0.00144D0,
51772      &     0.00094D0,  0.00064D0,  0.00038D0,  0.00013D0,  0.00004D0,
51773      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
51774       DATA (FMRS(1,4,I,11),I=1,49)/
51775      &     1.56638D0,  1.35212D0,  1.16625D0,  1.06903D0,  1.00469D0,
51776      &     0.95725D0,  0.82240D0,  0.70420D0,  0.64167D0,  0.59990D0,
51777      &     0.56868D0,  0.47904D0,  0.39878D0,  0.35576D0,  0.32683D0,
51778      &     0.30525D0,  0.27397D0,  0.24210D0,  0.20674D0,  0.18151D0,
51779      &     0.14453D0,  0.11694D0,  0.09517D0,  0.07398D0,  0.05791D0,
51780      &     0.04585D0,  0.03673D0,  0.02971D0,  0.02433D0,  0.02010D0,
51781      &     0.01646D0,  0.01346D0,  0.01083D0,  0.00860D0,  0.00675D0,
51782      &     0.00520D0,  0.00385D0,  0.00277D0,  0.00207D0,  0.00139D0,
51783      &     0.00090D0,  0.00062D0,  0.00037D0,  0.00013D0,  0.00004D0,
51784      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
51785       DATA (FMRS(1,4,I,12),I=1,49)/
51786      &     1.80214D0,  1.54109D0,  1.31694D0,  1.20067D0,  1.12412D0,
51787      &     1.06789D0,  0.90916D0,  0.77146D0,  0.69919D0,  0.65116D0,
51788      &     0.61534D0,  0.51323D0,  0.42280D0,  0.37478D0,  0.34269D0,
51789      &     0.31886D0,  0.28449D0,  0.24976D0,  0.21162D0,  0.18471D0,
51790      &     0.14585D0,  0.11732D0,  0.09509D0,  0.07364D0,  0.05748D0,
51791      &     0.04542D0,  0.03629D0,  0.02928D0,  0.02389D0,  0.01964D0,
51792      &     0.01603D0,  0.01303D0,  0.01043D0,  0.00824D0,  0.00644D0,
51793      &     0.00493D0,  0.00365D0,  0.00261D0,  0.00193D0,  0.00129D0,
51794      &     0.00082D0,  0.00058D0,  0.00033D0,  0.00012D0,  0.00003D0,
51795      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51796       DATA (FMRS(1,4,I,13),I=1,49)/
51797      &     2.04055D0,  1.73004D0,  1.46588D0,  1.32988D0,  1.24076D0,
51798      &     1.17553D0,  0.99250D0,  0.83521D0,  0.75328D0,  0.69907D0,
51799      &     0.65875D0,  0.54456D0,  0.44445D0,  0.39176D0,  0.35673D0,
51800      &     0.33084D0,  0.29368D0,  0.25636D0,  0.21574D0,  0.18736D0,
51801      &     0.14688D0,  0.11755D0,  0.09493D0,  0.07328D0,  0.05705D0,
51802      &     0.04498D0,  0.03587D0,  0.02887D0,  0.02347D0,  0.01921D0,
51803      &     0.01564D0,  0.01265D0,  0.01010D0,  0.00793D0,  0.00617D0,
51804      &     0.00472D0,  0.00348D0,  0.00248D0,  0.00181D0,  0.00123D0,
51805      &     0.00077D0,  0.00054D0,  0.00031D0,  0.00011D0,  0.00003D0,
51806      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51807       DATA (FMRS(1,4,I,14),I=1,49)/
51808      &     2.34878D0,  1.97162D0,  1.65417D0,  1.49212D0,  1.38650D0,
51809      &     1.30951D0,  1.09500D0,  0.91263D0,  0.81846D0,  0.75649D0,
51810      &     0.71054D0,  0.58140D0,  0.46952D0,  0.41122D0,  0.37271D0,
51811      &     0.34438D0,  0.30396D0,  0.26367D0,  0.22023D0,  0.19019D0,
51812      &     0.14790D0,  0.11770D0,  0.09464D0,  0.07279D0,  0.05650D0,
51813      &     0.04444D0,  0.03534D0,  0.02838D0,  0.02299D0,  0.01873D0,
51814      &     0.01518D0,  0.01221D0,  0.00971D0,  0.00758D0,  0.00587D0,
51815      &     0.00448D0,  0.00329D0,  0.00233D0,  0.00171D0,  0.00117D0,
51816      &     0.00073D0,  0.00051D0,  0.00028D0,  0.00010D0,  0.00003D0,
51817      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51818       DATA (FMRS(1,4,I,15),I=1,49)/
51819      &     2.72076D0,  2.25974D0,  1.87603D0,  1.68193D0,  1.55614D0,
51820      &     1.46482D0,  1.21228D0,  1.00004D0,  0.89145D0,  0.82040D0,
51821      &     0.76790D0,  0.62156D0,  0.49638D0,  0.43184D0,  0.38951D0,
51822      &     0.35852D0,  0.31456D0,  0.27109D0,  0.22467D0,  0.19292D0,
51823      &     0.14878D0,  0.11770D0,  0.09423D0,  0.07216D0,  0.05583D0,
51824      &     0.04380D0,  0.03471D0,  0.02777D0,  0.02242D0,  0.01821D0,
51825      &     0.01468D0,  0.01176D0,  0.00931D0,  0.00721D0,  0.00560D0,
51826      &     0.00425D0,  0.00310D0,  0.00215D0,  0.00160D0,  0.00107D0,
51827      &     0.00067D0,  0.00046D0,  0.00026D0,  0.00009D0,  0.00003D0,
51828      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51829       DATA (FMRS(1,4,I,16),I=1,49)/
51830      &     3.10372D0,  2.55317D0,  2.09952D0,  1.87189D0,  1.72513D0,
51831      &     1.61899D0,  1.32738D0,  1.08482D0,  0.96174D0,  0.88163D0,
51832      &     0.82262D0,  0.65935D0,  0.52128D0,  0.45078D0,  0.40481D0,
51833      &     0.37132D0,  0.32407D0,  0.27766D0,  0.22852D0,  0.19522D0,
51834      &     0.14943D0,  0.11759D0,  0.09376D0,  0.07153D0,  0.05518D0,
51835      &     0.04316D0,  0.03411D0,  0.02721D0,  0.02189D0,  0.01771D0,
51836      &     0.01421D0,  0.01135D0,  0.00894D0,  0.00691D0,  0.00532D0,
51837      &     0.00403D0,  0.00292D0,  0.00202D0,  0.00150D0,  0.00098D0,
51838      &     0.00063D0,  0.00043D0,  0.00024D0,  0.00009D0,  0.00003D0,
51839      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51840       DATA (FMRS(1,4,I,17),I=1,49)/
51841      &     3.53791D0,  2.88253D0,  2.34786D0,  2.08172D0,  1.91099D0,
51842      &     1.78798D0,  1.45224D0,  1.17581D0,  1.03669D0,  0.94660D0,
51843      &     0.88048D0,  0.69881D0,  0.54694D0,  0.47011D0,  0.42034D0,
51844      &     0.38424D0,  0.33357D0,  0.28414D0,  0.23224D0,  0.19739D0,
51845      &     0.14997D0,  0.11738D0,  0.09322D0,  0.07083D0,  0.05448D0,
51846      &     0.04248D0,  0.03349D0,  0.02663D0,  0.02135D0,  0.01720D0,
51847      &     0.01373D0,  0.01094D0,  0.00857D0,  0.00662D0,  0.00504D0,
51848      &     0.00382D0,  0.00275D0,  0.00191D0,  0.00140D0,  0.00091D0,
51849      &     0.00060D0,  0.00040D0,  0.00021D0,  0.00008D0,  0.00002D0,
51850      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51851       DATA (FMRS(1,4,I,18),I=1,49)/
51852      &     3.93600D0,  3.18179D0,  2.57144D0,  2.26962D0,  2.07679D0,
51853      &     1.93828D0,  1.56224D0,  1.25519D0,  1.10169D0,  1.00271D0,
51854      &     0.93026D0,  0.73238D0,  0.56848D0,  0.48622D0,  0.43319D0,
51855      &     0.39487D0,  0.34131D0,  0.28936D0,  0.23517D0,  0.19905D0,
51856      &     0.15030D0,  0.11713D0,  0.09270D0,  0.07021D0,  0.05385D0,
51857      &     0.04190D0,  0.03295D0,  0.02612D0,  0.02087D0,  0.01677D0,
51858      &     0.01334D0,  0.01060D0,  0.00827D0,  0.00637D0,  0.00486D0,
51859      &     0.00366D0,  0.00263D0,  0.00181D0,  0.00134D0,  0.00088D0,
51860      &     0.00056D0,  0.00038D0,  0.00020D0,  0.00007D0,  0.00002D0,
51861      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51862       DATA (FMRS(1,4,I,19),I=1,49)/
51863      &     4.46512D0,  3.57604D0,  2.86339D0,  2.51369D0,  2.29136D0,
51864      &     2.13222D0,  1.70289D0,  1.35573D0,  1.18356D0,  1.07308D0,
51865      &     0.99248D0,  0.77387D0,  0.59477D0,  0.50571D0,  0.44864D0,
51866      &     0.40759D0,  0.35048D0,  0.29545D0,  0.23852D0,  0.20087D0,
51867      &     0.15057D0,  0.11671D0,  0.09200D0,  0.06939D0,  0.05304D0,
51868      &     0.04116D0,  0.03225D0,  0.02548D0,  0.02030D0,  0.01627D0,
51869      &     0.01289D0,  0.01018D0,  0.00793D0,  0.00608D0,  0.00462D0,
51870      &     0.00346D0,  0.00247D0,  0.00170D0,  0.00124D0,  0.00082D0,
51871      &     0.00052D0,  0.00036D0,  0.00020D0,  0.00007D0,  0.00002D0,
51872      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51873       DATA (FMRS(1,4,I,20),I=1,49)/
51874      &     4.98110D0,  3.95717D0,  3.14315D0,  2.74636D0,  2.49515D0,
51875      &     2.31589D0,  1.83490D0,  1.44924D0,  1.25928D0,  1.13790D0,
51876      &     1.04961D0,  0.81156D0,  0.61839D0,  0.52309D0,  0.46234D0,
51877      &     0.41880D0,  0.35851D0,  0.30072D0,  0.24136D0,  0.20237D0,
51878      &     0.15073D0,  0.11629D0,  0.09134D0,  0.06865D0,  0.05232D0,
51879      &     0.04048D0,  0.03163D0,  0.02492D0,  0.01980D0,  0.01582D0,
51880      &     0.01251D0,  0.00983D0,  0.00765D0,  0.00583D0,  0.00441D0,
51881      &     0.00330D0,  0.00234D0,  0.00161D0,  0.00116D0,  0.00076D0,
51882      &     0.00049D0,  0.00034D0,  0.00019D0,  0.00006D0,  0.00002D0,
51883      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51884       DATA (FMRS(1,4,I,21),I=1,49)/
51885      &     5.48855D0,  4.32906D0,  3.41400D0,  2.97058D0,  2.69088D0,
51886      &     2.49185D0,  1.96033D0,  1.53734D0,  1.33025D0,  1.19843D0,
51887      &     1.10279D0,  0.84628D0,  0.63987D0,  0.53877D0,  0.47461D0,
51888      &     0.42879D0,  0.36557D0,  0.30530D0,  0.24373D0,  0.20356D0,
51889      &     0.15074D0,  0.11580D0,  0.09065D0,  0.06792D0,  0.05161D0,
51890      &     0.03984D0,  0.03104D0,  0.02440D0,  0.01932D0,  0.01538D0,
51891      &     0.01214D0,  0.00950D0,  0.00738D0,  0.00561D0,  0.00423D0,
51892      &     0.00315D0,  0.00224D0,  0.00152D0,  0.00110D0,  0.00072D0,
51893      &     0.00045D0,  0.00032D0,  0.00018D0,  0.00006D0,  0.00002D0,
51894      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51895       DATA (FMRS(1,4,I,22),I=1,49)/
51896      &     6.18910D0,  4.83835D0,  3.78189D0,  3.27368D0,  2.95458D0,
51897      &     2.72828D0,  2.12748D0,  1.65375D0,  1.42355D0,  1.27771D0,
51898      &     1.17223D0,  0.89116D0,  0.66734D0,  0.55867D0,  0.49010D0,
51899      &     0.44134D0,  0.37438D0,  0.31092D0,  0.24658D0,  0.20493D0,
51900      &     0.15066D0,  0.11512D0,  0.08974D0,  0.06696D0,  0.05069D0,
51901      &     0.03901D0,  0.03030D0,  0.02374D0,  0.01874D0,  0.01485D0,
51902      &     0.01168D0,  0.00911D0,  0.00704D0,  0.00533D0,  0.00400D0,
51903      &     0.00297D0,  0.00211D0,  0.00142D0,  0.00104D0,  0.00068D0,
51904      &     0.00042D0,  0.00029D0,  0.00017D0,  0.00005D0,  0.00002D0,
51905      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51906       DATA (FMRS(1,4,I,23),I=1,49)/
51907      &     6.90776D0,  5.35634D0,  4.15288D0,  3.57780D0,  3.21822D0,
51908      &     2.96398D0,  2.29266D0,  1.76775D0,  1.51442D0,  1.35462D0,
51909      &     1.23937D0,  0.93411D0,  0.69332D0,  0.57734D0,  0.50454D0,
51910      &     0.45297D0,  0.38246D0,  0.31600D0,  0.24910D0,  0.20608D0,
51911      &     0.15048D0,  0.11442D0,  0.08886D0,  0.06603D0,  0.04982D0,
51912      &     0.03823D0,  0.02961D0,  0.02314D0,  0.01820D0,  0.01437D0,
51913      &     0.01125D0,  0.00875D0,  0.00671D0,  0.00507D0,  0.00380D0,
51914      &     0.00282D0,  0.00198D0,  0.00134D0,  0.00099D0,  0.00065D0,
51915      &     0.00039D0,  0.00026D0,  0.00015D0,  0.00005D0,  0.00002D0,
51916      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
51917       DATA (FMRS(1,4,I,24),I=1,49)/
51918      &     7.62426D0,  5.86871D0,  4.51692D0,  3.87481D0,  3.47482D0,
51919      &     3.19280D0,  2.45168D0,  1.87657D0,  1.60070D0,  1.42736D0,
51920      &     1.30266D0,  0.97414D0,  0.71722D0,  0.59437D0,  0.51760D0,
51921      &     0.46341D0,  0.38962D0,  0.32042D0,  0.25117D0,  0.20694D0,
51922      &     0.15017D0,  0.11367D0,  0.08795D0,  0.06511D0,  0.04897D0,
51923      &     0.03748D0,  0.02894D0,  0.02253D0,  0.01769D0,  0.01392D0,
51924      &     0.01087D0,  0.00842D0,  0.00645D0,  0.00484D0,  0.00362D0,
51925      &     0.00267D0,  0.00187D0,  0.00128D0,  0.00093D0,  0.00060D0,
51926      &     0.00037D0,  0.00024D0,  0.00014D0,  0.00004D0,  0.00002D0,
51927      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51928       DATA (FMRS(1,4,I,25),I=1,49)/
51929      &     8.39819D0,  6.41814D0,  4.90446D0,  4.18965D0,  3.74601D0,
51930      &     3.43405D0,  2.61811D0,  1.98959D0,  1.68991D0,  1.50231D0,
51931      &     1.36770D0,  1.01493D0,  0.74134D0,  0.61144D0,  0.53063D0,
51932      &     0.47380D0,  0.39668D0,  0.32474D0,  0.25316D0,  0.20772D0,
51933      &     0.14981D0,  0.11289D0,  0.08703D0,  0.06420D0,  0.04813D0,
51934      &     0.03673D0,  0.02828D0,  0.02194D0,  0.01719D0,  0.01349D0,
51935      &     0.01049D0,  0.00810D0,  0.00620D0,  0.00463D0,  0.00344D0,
51936      &     0.00252D0,  0.00177D0,  0.00122D0,  0.00086D0,  0.00056D0,
51937      &     0.00034D0,  0.00023D0,  0.00012D0,  0.00004D0,  0.00001D0,
51938      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51939       DATA (FMRS(1,4,I,26),I=1,49)/
51940      &     9.19912D0,  6.98269D0,  5.29980D0,  4.50945D0,  4.02062D0,
51941      &     3.67776D0,  2.78497D0,  2.10203D0,  1.77824D0,  1.57626D0,
51942      &     1.43169D0,  1.05466D0,  0.76454D0,  0.62772D0,  0.54298D0,
51943      &     0.48357D0,  0.40325D0,  0.32867D0,  0.25488D0,  0.20830D0,
51944      &     0.14936D0,  0.11205D0,  0.08608D0,  0.06328D0,  0.04729D0,
51945      &     0.03598D0,  0.02762D0,  0.02140D0,  0.01669D0,  0.01307D0,
51946      &     0.01014D0,  0.00780D0,  0.00595D0,  0.00443D0,  0.00330D0,
51947      &     0.00240D0,  0.00168D0,  0.00114D0,  0.00081D0,  0.00053D0,
51948      &     0.00032D0,  0.00022D0,  0.00012D0,  0.00004D0,  0.00001D0,
51949      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51950       DATA (FMRS(1,4,I,27),I=1,49)/
51951      &    10.00621D0,  7.54783D0,  5.69293D0,  4.82623D0,  4.29189D0,
51952      &     3.91798D0,  2.94832D0,  2.21133D0,  1.86373D0,  1.64761D0,
51953      &     1.49327D0,  1.09257D0,  0.78647D0,  0.64301D0,  0.55451D0,
51954      &     0.49265D0,  0.40930D0,  0.33223D0,  0.25638D0,  0.20876D0,
51955      &     0.14886D0,  0.11122D0,  0.08517D0,  0.06240D0,  0.04650D0,
51956      &     0.03528D0,  0.02702D0,  0.02089D0,  0.01623D0,  0.01267D0,
51957      &     0.00980D0,  0.00752D0,  0.00573D0,  0.00425D0,  0.00316D0,
51958      &     0.00230D0,  0.00159D0,  0.00107D0,  0.00077D0,  0.00050D0,
51959      &     0.00030D0,  0.00020D0,  0.00011D0,  0.00003D0,  0.00001D0,
51960      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51961       DATA (FMRS(1,4,I,28),I=1,49)/
51962      &    10.80590D0,  8.10435D0,  6.07766D0,  5.13510D0,  4.55568D0,
51963      &     4.15111D0,  3.10583D0,  2.31601D0,  1.94527D0,  1.71546D0,
51964      &     1.55167D0,  1.12822D0,  0.80689D0,  0.65715D0,  0.56511D0,
51965      &     0.50095D0,  0.41476D0,  0.33539D0,  0.25764D0,  0.20907D0,
51966      &     0.14833D0,  0.11039D0,  0.08428D0,  0.06155D0,  0.04576D0,
51967      &     0.03462D0,  0.02647D0,  0.02040D0,  0.01582D0,  0.01230D0,
51968      &     0.00949D0,  0.00726D0,  0.00551D0,  0.00409D0,  0.00302D0,
51969      &     0.00221D0,  0.00152D0,  0.00102D0,  0.00073D0,  0.00048D0,
51970      &     0.00029D0,  0.00019D0,  0.00010D0,  0.00004D0,  0.00001D0,
51971      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51972       DATA (FMRS(1,4,I,29),I=1,49)/
51973      &    11.65207D0,  8.68978D0,  6.48001D0,  5.45700D0,  4.82993D0,
51974      &     4.39300D0,  3.26826D0,  2.42329D0,  2.02852D0,  1.78454D0,
51975      &     1.61099D0,  1.16415D0,  0.82729D0,  0.67117D0,  0.57557D0,
51976      &     0.50910D0,  0.42008D0,  0.33842D0,  0.25880D0,  0.20930D0,
51977      &     0.14773D0,  0.10953D0,  0.08337D0,  0.06069D0,  0.04500D0,
51978      &     0.03397D0,  0.02591D0,  0.01991D0,  0.01541D0,  0.01194D0,
51979      &     0.00919D0,  0.00702D0,  0.00530D0,  0.00393D0,  0.00290D0,
51980      &     0.00211D0,  0.00145D0,  0.00096D0,  0.00070D0,  0.00045D0,
51981      &     0.00028D0,  0.00018D0,  0.00010D0,  0.00003D0,  0.00001D0,
51982      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51983       DATA (FMRS(1,4,I,30),I=1,49)/
51984      &    12.52131D0,  9.28774D0,  6.88859D0,  5.78276D0,  5.10678D0,
51985      &     4.63673D0,  3.43094D0,  2.53005D0,  2.11104D0,  1.85281D0,
51986      &     1.66948D0,  1.19929D0,  0.84705D0,  0.68466D0,  0.58556D0,
51987      &     0.51685D0,  0.42507D0,  0.34121D0,  0.25979D0,  0.20942D0,
51988      &     0.14709D0,  0.10866D0,  0.08245D0,  0.05983D0,  0.04425D0,
51989      &     0.03334D0,  0.02536D0,  0.01943D0,  0.01501D0,  0.01160D0,
51990      &     0.00891D0,  0.00678D0,  0.00511D0,  0.00378D0,  0.00279D0,
51991      &     0.00202D0,  0.00138D0,  0.00091D0,  0.00067D0,  0.00043D0,
51992      &     0.00026D0,  0.00018D0,  0.00010D0,  0.00003D0,  0.00001D0,
51993      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
51994       DATA (FMRS(1,4,I,31),I=1,49)/
51995      &    13.38978D0,  9.88200D0,  7.29246D0,  6.10376D0,  5.37897D0,
51996      &     4.87592D0,  3.58970D0,  2.63365D0,  2.19084D0,  1.91866D0,
51997      &     1.72578D0,  1.23288D0,  0.86578D0,  0.69738D0,  0.59494D0,
51998      &     0.52409D0,  0.42970D0,  0.34375D0,  0.26065D0,  0.20947D0,
51999      &     0.14644D0,  0.10781D0,  0.08158D0,  0.05902D0,  0.04354D0,
52000      &     0.03274D0,  0.02484D0,  0.01899D0,  0.01463D0,  0.01128D0,
52001      &     0.00865D0,  0.00657D0,  0.00493D0,  0.00364D0,  0.00268D0,
52002      &     0.00194D0,  0.00132D0,  0.00087D0,  0.00064D0,  0.00041D0,
52003      &     0.00025D0,  0.00017D0,  0.00009D0,  0.00003D0,  0.00001D0,
52004      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52005       DATA (FMRS(1,4,I,32),I=1,49)/
52006      &    14.23688D0, 10.45864D0,  7.68231D0,  6.41264D0,  5.64030D0,
52007      &     5.10517D0,  3.74102D0,  2.73180D0,  2.26617D0,  1.98065D0,
52008      &     1.77865D0,  1.26417D0,  0.88305D0,  0.70902D0,  0.60346D0,
52009      &     0.53062D0,  0.43382D0,  0.34595D0,  0.26134D0,  0.20941D0,
52010      &     0.14577D0,  0.10696D0,  0.08072D0,  0.05825D0,  0.04287D0,
52011      &     0.03215D0,  0.02436D0,  0.01857D0,  0.01428D0,  0.01098D0,
52012      &     0.00840D0,  0.00638D0,  0.00476D0,  0.00351D0,  0.00258D0,
52013      &     0.00187D0,  0.00127D0,  0.00083D0,  0.00061D0,  0.00039D0,
52014      &     0.00024D0,  0.00016D0,  0.00009D0,  0.00002D0,  0.00001D0,
52015      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52016       DATA (FMRS(1,4,I,33),I=1,49)/
52017      &    15.13941D0, 11.07021D0,  8.09390D0,  6.73786D0,  5.91493D0,
52018      &     5.34574D0,  3.89907D0,  2.83385D0,  2.34427D0,  2.04479D0,
52019      &     1.83327D0,  1.29634D0,  0.90070D0,  0.72088D0,  0.61213D0,
52020      &     0.53725D0,  0.43798D0,  0.34817D0,  0.26202D0,  0.20935D0,
52021      &     0.14510D0,  0.10612D0,  0.07988D0,  0.05749D0,  0.04221D0,
52022      &     0.03158D0,  0.02388D0,  0.01816D0,  0.01393D0,  0.01069D0,
52023      &     0.00816D0,  0.00620D0,  0.00459D0,  0.00338D0,  0.00248D0,
52024      &     0.00179D0,  0.00121D0,  0.00080D0,  0.00058D0,  0.00037D0,
52025      &     0.00022D0,  0.00014D0,  0.00008D0,  0.00002D0,  0.00001D0,
52026      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52027       DATA (FMRS(1,4,I,34),I=1,49)/
52028      &    16.04276D0, 11.67919D0,  8.50158D0,  7.05899D0,  6.18548D0,
52029      &     5.58230D0,  4.05359D0,  2.93300D0,  2.41985D0,  2.10667D0,
52030      &     1.88583D0,  1.32700D0,  0.91732D0,  0.73194D0,  0.62013D0,
52031      &     0.54331D0,  0.44171D0,  0.35007D0,  0.26248D0,  0.20913D0,
52032      &     0.14434D0,  0.10523D0,  0.07901D0,  0.05671D0,  0.04155D0,
52033      &     0.03102D0,  0.02340D0,  0.01777D0,  0.01360D0,  0.01042D0,
52034      &     0.00793D0,  0.00600D0,  0.00446D0,  0.00326D0,  0.00238D0,
52035      &     0.00173D0,  0.00118D0,  0.00076D0,  0.00055D0,  0.00036D0,
52036      &     0.00022D0,  0.00014D0,  0.00007D0,  0.00002D0,  0.00001D0,
52037      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52038       DATA (FMRS(1,4,I,35),I=1,49)/
52039      &    16.94849D0, 12.28721D0,  8.90688D0,  7.37746D0,  6.45332D0,
52040      &     5.81617D0,  4.20570D0,  3.03017D0,  2.49373D0,  2.16705D0,
52041      &     1.93704D0,  1.35674D0,  0.93336D0,  0.74257D0,  0.62781D0,
52042      &     0.54911D0,  0.44527D0,  0.35187D0,  0.26291D0,  0.20892D0,
52043      &     0.14363D0,  0.10440D0,  0.07819D0,  0.05599D0,  0.04092D0,
52044      &     0.03050D0,  0.02296D0,  0.01740D0,  0.01329D0,  0.01017D0,
52045      &     0.00772D0,  0.00583D0,  0.00433D0,  0.00315D0,  0.00229D0,
52046      &     0.00167D0,  0.00114D0,  0.00073D0,  0.00053D0,  0.00035D0,
52047      &     0.00021D0,  0.00013D0,  0.00007D0,  0.00002D0,  0.00001D0,
52048      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52049       DATA (FMRS(1,4,I,36),I=1,49)/
52050      &    17.83243D0, 12.87802D0,  9.29900D0,  7.68475D0,  6.71127D0,
52051      &     6.04107D0,  4.35129D0,  3.12272D0,  2.56388D0,  2.22424D0,
52052      &     1.98545D0,  1.38466D0,  0.94830D0,  0.75241D0,  0.63488D0,
52053      &     0.55441D0,  0.44848D0,  0.35346D0,  0.26323D0,  0.20867D0,
52054      &     0.14292D0,  0.10358D0,  0.07741D0,  0.05529D0,  0.04033D0,
52055      &     0.03000D0,  0.02255D0,  0.01705D0,  0.01300D0,  0.00993D0,
52056      &     0.00753D0,  0.00566D0,  0.00421D0,  0.00306D0,  0.00221D0,
52057      &     0.00161D0,  0.00110D0,  0.00071D0,  0.00051D0,  0.00034D0,
52058      &     0.00020D0,  0.00013D0,  0.00007D0,  0.00002D0,  0.00001D0,
52059      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52060       DATA (FMRS(1,4,I,37),I=1,49)/
52061      &    18.74867D0, 13.48785D0,  9.70200D0,  7.99976D0,  6.97522D0,
52062      &     6.27087D0,  4.49936D0,  3.21639D0,  2.63465D0,  2.28182D0,
52063      &     2.03408D0,  1.41252D0,  0.96307D0,  0.76207D0,  0.64176D0,
52064      &     0.55956D0,  0.45155D0,  0.35492D0,  0.26347D0,  0.20834D0,
52065      &     0.14216D0,  0.10274D0,  0.07660D0,  0.05459D0,  0.03974D0,
52066      &     0.02950D0,  0.02213D0,  0.01670D0,  0.01272D0,  0.00970D0,
52067      &     0.00733D0,  0.00550D0,  0.00408D0,  0.00297D0,  0.00214D0,
52068      &     0.00155D0,  0.00105D0,  0.00068D0,  0.00049D0,  0.00032D0,
52069      &     0.00018D0,  0.00012D0,  0.00007D0,  0.00002D0,  0.00001D0,
52070      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52071       DATA (FMRS(1,4,I,38),I=1,49)/
52072      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52073      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52074      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52075      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52076      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52077      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52078      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52079      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52080      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52081      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52082       DATA (FMRS(1,5,I, 1),I=1,49)/
52083      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52084      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52085      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52086      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52087      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52088      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52089      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52090      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52091      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52092      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52093       DATA (FMRS(1,5,I, 2),I=1,49)/
52094      &     0.00003D0,  0.00003D0,  0.00002D0,  0.00002D0,  0.00002D0,
52095      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
52096      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
52097      &     0.00002D0,  0.00002D0,  0.00001D0,  0.00001D0,  0.00001D0,
52098      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
52099      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
52100      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00000D0,  0.00000D0,
52101      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52102      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52103      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52104       DATA (FMRS(1,5,I, 3),I=1,49)/
52105      &     0.03227D0,  0.02900D0,  0.02605D0,  0.02445D0,  0.02338D0,
52106      &     0.02257D0,  0.02019D0,  0.01798D0,  0.01674D0,  0.01586D0,
52107      &     0.01516D0,  0.01302D0,  0.01084D0,  0.00956D0,  0.00865D0,
52108      &     0.00795D0,  0.00692D0,  0.00587D0,  0.00477D0,  0.00405D0,
52109      &     0.00317D0,  0.00263D0,  0.00225D0,  0.00190D0,  0.00163D0,
52110      &     0.00139D0,  0.00119D0,  0.00101D0,  0.00085D0,  0.00072D0,
52111      &     0.00059D0,  0.00048D0,  0.00039D0,  0.00031D0,  0.00025D0,
52112      &     0.00019D0,  0.00015D0,  0.00011D0,  0.00008D0,  0.00006D0,
52113      &     0.00004D0,  0.00003D0,  0.00002D0,  0.00001D0,  0.00000D0,
52114      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52115       DATA (FMRS(1,5,I, 4),I=1,49)/
52116      &     0.08412D0,  0.07493D0,  0.06672D0,  0.06231D0,  0.05935D0,
52117      &     0.05713D0,  0.05068D0,  0.04474D0,  0.04144D0,  0.03913D0,
52118      &     0.03731D0,  0.03177D0,  0.02623D0,  0.02303D0,  0.02077D0,
52119      &     0.01905D0,  0.01652D0,  0.01397D0,  0.01129D0,  0.00957D0,
52120      &     0.00745D0,  0.00615D0,  0.00525D0,  0.00441D0,  0.00375D0,
52121      &     0.00320D0,  0.00272D0,  0.00230D0,  0.00193D0,  0.00161D0,
52122      &     0.00132D0,  0.00108D0,  0.00087D0,  0.00069D0,  0.00054D0,
52123      &     0.00042D0,  0.00032D0,  0.00024D0,  0.00018D0,  0.00013D0,
52124      &     0.00009D0,  0.00006D0,  0.00004D0,  0.00001D0,  0.00000D0,
52125      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52126       DATA (FMRS(1,5,I, 5),I=1,49)/
52127      &     0.14877D0,  0.13082D0,  0.11499D0,  0.10659D0,  0.10097D0,
52128      &     0.09680D0,  0.08477D0,  0.07388D0,  0.06791D0,  0.06379D0,
52129      &     0.06056D0,  0.05091D0,  0.04152D0,  0.03619D0,  0.03249D0,
52130      &     0.02969D0,  0.02561D0,  0.02153D0,  0.01729D0,  0.01459D0,
52131      &     0.01127D0,  0.00925D0,  0.00785D0,  0.00655D0,  0.00553D0,
52132      &     0.00469D0,  0.00396D0,  0.00333D0,  0.00278D0,  0.00231D0,
52133      &     0.00189D0,  0.00153D0,  0.00123D0,  0.00097D0,  0.00076D0,
52134      &     0.00059D0,  0.00045D0,  0.00034D0,  0.00025D0,  0.00018D0,
52135      &     0.00012D0,  0.00009D0,  0.00006D0,  0.00001D0,  0.00000D0,
52136      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52137       DATA (FMRS(1,5,I, 6),I=1,49)/
52138      &     0.22202D0,  0.19306D0,  0.16779D0,  0.15452D0,  0.14570D0,
52139      &     0.13918D0,  0.12051D0,  0.10386D0,  0.09484D0,  0.08868D0,
52140      &     0.08388D0,  0.06972D0,  0.05624D0,  0.04872D0,  0.04355D0,
52141      &     0.03966D0,  0.03405D0,  0.02848D0,  0.02274D0,  0.01911D0,
52142      &     0.01466D0,  0.01197D0,  0.01011D0,  0.00838D0,  0.00703D0,
52143      &     0.00592D0,  0.00498D0,  0.00416D0,  0.00346D0,  0.00286D0,
52144      &     0.00233D0,  0.00188D0,  0.00150D0,  0.00118D0,  0.00092D0,
52145      &     0.00071D0,  0.00054D0,  0.00041D0,  0.00030D0,  0.00021D0,
52146      &     0.00015D0,  0.00010D0,  0.00007D0,  0.00001D0,  0.00000D0,
52147      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52148       DATA (FMRS(1,5,I, 7),I=1,49)/
52149      &     0.30272D0,  0.26063D0,  0.22430D0,  0.20535D0,  0.19284D0,
52150      &     0.18362D0,  0.15743D0,  0.13433D0,  0.12195D0,  0.11355D0,
52151      &     0.10705D0,  0.08808D0,  0.07034D0,  0.06058D0,  0.05394D0,
52152      &     0.04898D0,  0.04185D0,  0.03485D0,  0.02767D0,  0.02316D0,
52153      &     0.01766D0,  0.01434D0,  0.01204D0,  0.00992D0,  0.00828D0,
52154      &     0.00693D0,  0.00580D0,  0.00482D0,  0.00399D0,  0.00328D0,
52155      &     0.00266D0,  0.00214D0,  0.00170D0,  0.00133D0,  0.00104D0,
52156      &     0.00080D0,  0.00060D0,  0.00045D0,  0.00033D0,  0.00024D0,
52157      &     0.00016D0,  0.00011D0,  0.00007D0,  0.00001D0,  0.00000D0,
52158      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52159       DATA (FMRS(1,5,I, 8),I=1,49)/
52160      &     0.40640D0,  0.34641D0,  0.29514D0,  0.26863D0,  0.25121D0,
52161      &     0.23843D0,  0.20237D0,  0.17095D0,  0.15427D0,  0.14303D0,
52162      &     0.13440D0,  0.10944D0,  0.08650D0,  0.07407D0,  0.06568D0,
52163      &     0.05945D0,  0.05056D0,  0.04189D0,  0.03309D0,  0.02757D0,
52164      &     0.02089D0,  0.01686D0,  0.01408D0,  0.01153D0,  0.00956D0,
52165      &     0.00796D0,  0.00662D0,  0.00548D0,  0.00451D0,  0.00369D0,
52166      &     0.00298D0,  0.00239D0,  0.00189D0,  0.00148D0,  0.00114D0,
52167      &     0.00087D0,  0.00066D0,  0.00049D0,  0.00037D0,  0.00026D0,
52168      &     0.00018D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
52169      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52170       DATA (FMRS(1,5,I, 9),I=1,49)/
52171      &     0.51210D0,  0.43288D0,  0.36574D0,  0.33126D0,  0.30871D0,
52172      &     0.29222D0,  0.24594D0,  0.20601D0,  0.18499D0,  0.17091D0,
52173      &     0.16014D0,  0.12927D0,  0.10130D0,  0.08631D0,  0.07626D0,
52174      &     0.06885D0,  0.05833D0,  0.04813D0,  0.03783D0,  0.03141D0,
52175      &     0.02366D0,  0.01900D0,  0.01580D0,  0.01287D0,  0.01061D0,
52176      &     0.00880D0,  0.00728D0,  0.00600D0,  0.00491D0,  0.00401D0,
52177      &     0.00322D0,  0.00257D0,  0.00203D0,  0.00158D0,  0.00122D0,
52178      &     0.00093D0,  0.00070D0,  0.00052D0,  0.00039D0,  0.00028D0,
52179      &     0.00018D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
52180      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52181       DATA (FMRS(1,5,I,10),I=1,49)/
52182      &     0.62615D0,  0.52524D0,  0.44038D0,  0.39709D0,  0.36888D0,
52183      &     0.34831D0,  0.29091D0,  0.24179D0,  0.21613D0,  0.19903D0,
52184      &     0.18601D0,  0.14895D0,  0.11579D0,  0.09820D0,  0.08649D0,
52185      &     0.07789D0,  0.06575D0,  0.05404D0,  0.04228D0,  0.03498D0,
52186      &     0.02621D0,  0.02095D0,  0.01734D0,  0.01405D0,  0.01153D0,
52187      &     0.00952D0,  0.00784D0,  0.00644D0,  0.00525D0,  0.00426D0,
52188      &     0.00342D0,  0.00272D0,  0.00213D0,  0.00166D0,  0.00127D0,
52189      &     0.00097D0,  0.00073D0,  0.00054D0,  0.00040D0,  0.00029D0,
52190      &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
52191      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52192       DATA (FMRS(1,5,I,11),I=1,49)/
52193      &     0.72756D0,  0.60673D0,  0.50572D0,  0.45443D0,  0.42111D0,
52194      &     0.39687D0,  0.32951D0,  0.27226D0,  0.24251D0,  0.22276D0,
52195      &     0.20777D0,  0.16535D0,  0.12775D0,  0.10795D0,  0.09484D0,
52196      &     0.08524D0,  0.07175D0,  0.05879D0,  0.04583D0,  0.03782D0,
52197      &     0.02821D0,  0.02247D0,  0.01853D0,  0.01496D0,  0.01223D0,
52198      &     0.01005D0,  0.00826D0,  0.00676D0,  0.00549D0,  0.00445D0,
52199      &     0.00355D0,  0.00282D0,  0.00221D0,  0.00171D0,  0.00131D0,
52200      &     0.00099D0,  0.00074D0,  0.00055D0,  0.00041D0,  0.00029D0,
52201      &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
52202      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52203       DATA (FMRS(1,5,I,12),I=1,49)/
52204      &     0.97596D0,  0.80419D0,  0.66232D0,  0.59100D0,  0.54494D0,
52205      &     0.51159D0,  0.41968D0,  0.34257D0,  0.30297D0,  0.27688D0,
52206      &     0.25720D0,  0.20210D0,  0.15417D0,  0.12932D0,  0.11303D0,
52207      &     0.10119D0,  0.08465D0,  0.06892D0,  0.05333D0,  0.04376D0,
52208      &     0.03235D0,  0.02557D0,  0.02094D0,  0.01675D0,  0.01359D0,
52209      &     0.01109D0,  0.00904D0,  0.00734D0,  0.00594D0,  0.00477D0,
52210      &     0.00379D0,  0.00299D0,  0.00233D0,  0.00179D0,  0.00137D0,
52211      &     0.00103D0,  0.00077D0,  0.00057D0,  0.00042D0,  0.00030D0,
52212      &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
52213      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52214       DATA (FMRS(1,5,I,13),I=1,49)/
52215      &     1.22977D0,  1.00344D0,  0.81836D0,  0.72605D0,  0.66675D0,
52216      &     0.62396D0,  0.50684D0,  0.40963D0,  0.36016D0,  0.32776D0,
52217      &     0.30345D0,  0.23597D0,  0.17813D0,  0.14851D0,  0.12924D0,
52218      &     0.11531D0,  0.09599D0,  0.07773D0,  0.05977D0,  0.04882D0,
52219      &     0.03581D0,  0.02811D0,  0.02289D0,  0.01818D0,  0.01465D0,
52220      &     0.01187D0,  0.00963D0,  0.00777D0,  0.00625D0,  0.00500D0,
52221      &     0.00395D0,  0.00310D0,  0.00241D0,  0.00185D0,  0.00140D0,
52222      &     0.00105D0,  0.00078D0,  0.00058D0,  0.00043D0,  0.00031D0,
52223      &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
52224      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52225       DATA (FMRS(1,5,I,14),I=1,49)/
52226      &     1.55816D0,  1.25825D0,  1.01555D0,  0.89552D0,  0.81883D0,
52227      &     0.76371D0,  0.61389D0,  0.49095D0,  0.42897D0,  0.38864D0,
52228      &     0.35854D0,  0.27572D0,  0.20581D0,  0.17047D0,  0.14766D0,
52229      &     0.13128D0,  0.10869D0,  0.08751D0,  0.06683D0,  0.05430D0,
52230      &     0.03950D0,  0.03078D0,  0.02489D0,  0.01962D0,  0.01569D0,
52231      &     0.01264D0,  0.01018D0,  0.00817D0,  0.00653D0,  0.00519D0,
52232      &     0.00408D0,  0.00319D0,  0.00246D0,  0.00188D0,  0.00142D0,
52233      &     0.00106D0,  0.00078D0,  0.00058D0,  0.00043D0,  0.00031D0,
52234      &     0.00019D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
52235      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52236       DATA (FMRS(1,5,I,15),I=1,49)/
52237      &     1.94525D0,  1.55494D0,  1.24230D0,  1.08896D0,  0.99149D0,
52238      &     0.92172D0,  0.73335D0,  0.58046D0,  0.50409D0,  0.45471D0,
52239      &     0.41801D0,  0.31797D0,  0.23473D0,  0.19316D0,  0.16655D0,
52240      &     0.14754D0,  0.12149D0,  0.09725D0,  0.07376D0,  0.05961D0,
52241      &     0.04299D0,  0.03326D0,  0.02672D0,  0.02089D0,  0.01659D0,
52242      &     0.01327D0,  0.01061D0,  0.00847D0,  0.00673D0,  0.00532D0,
52243      &     0.00416D0,  0.00323D0,  0.00248D0,  0.00188D0,  0.00142D0,
52244      &     0.00105D0,  0.00077D0,  0.00057D0,  0.00042D0,  0.00031D0,
52245      &     0.00019D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
52246      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52247       DATA (FMRS(1,5,I,16),I=1,49)/
52248      &     2.34531D0,  1.85826D0,  1.47159D0,  1.28330D0,  1.16416D0,
52249      &     1.07915D0,  0.85101D0,  0.66758D0,  0.57668D0,  0.51821D0,
52250      &     0.47495D0,  0.35786D0,  0.26164D0,  0.21408D0,  0.18385D0,
52251      &     0.16236D0,  0.13305D0,  0.10596D0,  0.07987D0,  0.06425D0,
52252      &     0.04599D0,  0.03535D0,  0.02822D0,  0.02192D0,  0.01729D0,
52253      &     0.01375D0,  0.01093D0,  0.00867D0,  0.00685D0,  0.00540D0,
52254      &     0.00420D0,  0.00325D0,  0.00248D0,  0.00188D0,  0.00141D0,
52255      &     0.00104D0,  0.00076D0,  0.00056D0,  0.00041D0,  0.00030D0,
52256      &     0.00018D0,  0.00011D0,  0.00006D0,  0.00001D0,  0.00000D0,
52257      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52258       DATA (FMRS(1,5,I,17),I=1,49)/
52259      &     2.80142D0,  2.20072D0,  1.72790D0,  1.49927D0,  1.35523D0,
52260      &     1.25280D0,  0.97945D0,  0.76167D0,  0.65458D0,  0.58603D0,
52261      &     0.53553D0,  0.39978D0,  0.28955D0,  0.23561D0,  0.20153D0,
52262      &     0.17743D0,  0.14473D0,  0.11467D0,  0.08591D0,  0.06880D0,
52263      &     0.04888D0,  0.03733D0,  0.02963D0,  0.02285D0,  0.01791D0,
52264      &     0.01415D0,  0.01119D0,  0.00883D0,  0.00694D0,  0.00544D0,
52265      &     0.00421D0,  0.00324D0,  0.00247D0,  0.00186D0,  0.00139D0,
52266      &     0.00102D0,  0.00075D0,  0.00055D0,  0.00040D0,  0.00029D0,
52267      &     0.00018D0,  0.00011D0,  0.00006D0,  0.00001D0,  0.00000D0,
52268      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52269       DATA (FMRS(1,5,I,18),I=1,49)/
52270      &     3.21652D0,  2.50960D0,  1.95700D0,  1.69126D0,  1.52443D0,
52271      &     1.40610D0,  1.09176D0,  0.84313D0,  0.72161D0,  0.64414D0,
52272      &     0.58724D0,  0.43516D0,  0.31280D0,  0.25339D0,  0.21606D0,
52273      &     0.18974D0,  0.15419D0,  0.12166D0,  0.09071D0,  0.07236D0,
52274      &     0.05109D0,  0.03882D0,  0.03067D0,  0.02352D0,  0.01834D0,
52275      &     0.01442D0,  0.01135D0,  0.00892D0,  0.00699D0,  0.00545D0,
52276      &     0.00421D0,  0.00322D0,  0.00245D0,  0.00184D0,  0.00137D0,
52277      &     0.00100D0,  0.00073D0,  0.00053D0,  0.00039D0,  0.00029D0,
52278      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00001D0,  0.00000D0,
52279      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52280       DATA (FMRS(1,5,I,19),I=1,49)/
52281      &     3.76652D0,  2.91536D0,  2.25532D0,  1.93997D0,  1.74280D0,
52282      &     1.60338D0,  1.23496D0,  0.94601D0,  0.80577D0,  0.71678D0,
52283      &     0.65167D0,  0.47873D0,  0.34109D0,  0.27487D0,  0.23349D0,
52284      &     0.20445D0,  0.16541D0,  0.12988D0,  0.09628D0,  0.07646D0,
52285      &     0.05359D0,  0.04046D0,  0.03178D0,  0.02422D0,  0.01877D0,
52286      &     0.01467D0,  0.01149D0,  0.00898D0,  0.00700D0,  0.00543D0,
52287      &     0.00418D0,  0.00319D0,  0.00241D0,  0.00180D0,  0.00134D0,
52288      &     0.00098D0,  0.00071D0,  0.00052D0,  0.00038D0,  0.00028D0,
52289      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00001D0,  0.00000D0,
52290      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52291       DATA (FMRS(1,5,I,20),I=1,49)/
52292      &     4.30575D0,  3.30993D0,  2.54302D0,  2.17866D0,  1.95165D0,
52293      &     1.79153D0,  1.37036D0,  1.04242D0,  0.88422D0,  0.78423D0,
52294      &     0.71130D0,  0.51866D0,  0.36673D0,  0.29419D0,  0.24910D0,
52295      &     0.21757D0,  0.17534D0,  0.13711D0,  0.10112D0,  0.07999D0,
52296      &     0.05571D0,  0.04184D0,  0.03270D0,  0.02477D0,  0.01909D0,
52297      &     0.01486D0,  0.01158D0,  0.00901D0,  0.00699D0,  0.00541D0,
52298      &     0.00414D0,  0.00315D0,  0.00237D0,  0.00177D0,  0.00131D0,
52299      &     0.00095D0,  0.00069D0,  0.00050D0,  0.00037D0,  0.00027D0,
52300      &     0.00016D0,  0.00009D0,  0.00005D0,  0.00001D0,  0.00000D0,
52301      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52302       DATA (FMRS(1,5,I,21),I=1,49)/
52303      &     4.82956D0,  3.69021D0,  2.81808D0,  2.40576D0,  2.14966D0,
52304      &     1.96944D0,  1.49728D0,  1.13198D0,  0.95669D0,  0.84628D0,
52305      &     0.76597D0,  0.55486D0,  0.38968D0,  0.31136D0,  0.26288D0,
52306      &     0.22909D0,  0.18399D0,  0.14333D0,  0.10523D0,  0.08295D0,
52307      &     0.05744D0,  0.04293D0,  0.03340D0,  0.02518D0,  0.01931D0,
52308      &     0.01496D0,  0.01161D0,  0.00900D0,  0.00696D0,  0.00536D0,
52309      &     0.00409D0,  0.00310D0,  0.00233D0,  0.00173D0,  0.00128D0,
52310      &     0.00093D0,  0.00067D0,  0.00049D0,  0.00036D0,  0.00027D0,
52311      &     0.00015D0,  0.00009D0,  0.00005D0,  0.00001D0,  0.00000D0,
52312      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52313       DATA (FMRS(1,5,I,22),I=1,49)/
52314      &     5.55546D0,  4.21326D0,  3.19353D0,  2.71436D0,  2.41786D0,
52315      &     2.20981D0,  1.66741D0,  1.25104D0,  1.05255D0,  0.92807D0,
52316      &     0.83783D0,  0.60198D0,  0.41926D0,  0.33333D0,  0.28043D0,
52317      &     0.24370D0,  0.19489D0,  0.15111D0,  0.11032D0,  0.08657D0,
52318      &     0.05953D0,  0.04421D0,  0.03422D0,  0.02563D0,  0.01955D0,
52319      &     0.01506D0,  0.01163D0,  0.00897D0,  0.00690D0,  0.00529D0,
52320      &     0.00403D0,  0.00304D0,  0.00227D0,  0.00168D0,  0.00124D0,
52321      &     0.00090D0,  0.00064D0,  0.00047D0,  0.00035D0,  0.00026D0,
52322      &     0.00015D0,  0.00008D0,  0.00005D0,  0.00001D0,  0.00000D0,
52323      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52324       DATA (FMRS(1,5,I,23),I=1,49)/
52325      &     6.30033D0,  4.74567D0,  3.57260D0,  3.02443D0,  2.68642D0,
52326      &     2.44984D0,  1.83585D0,  1.36787D0,  1.14612D0,  1.00758D0,
52327      &     0.90746D0,  0.64718D0,  0.44730D0,  0.35401D0,  0.29686D0,
52328      &     0.25731D0,  0.20497D0,  0.15824D0,  0.11492D0,  0.08982D0,
52329      &     0.06136D0,  0.04532D0,  0.03489D0,  0.02598D0,  0.01971D0,
52330      &     0.01511D0,  0.01161D0,  0.00892D0,  0.00683D0,  0.00522D0,
52331      &     0.00395D0,  0.00297D0,  0.00222D0,  0.00163D0,  0.00120D0,
52332      &     0.00087D0,  0.00062D0,  0.00045D0,  0.00034D0,  0.00025D0,
52333      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00001D0,  0.00000D0,
52334      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52335       DATA (FMRS(1,5,I,24),I=1,49)/
52336      &     7.03684D0,  5.26796D0,  3.94145D0,  3.32468D0,  2.94556D0,
52337      &     2.68082D0,  1.99651D0,  1.47829D0,  1.23404D0,  1.08198D0,
52338      &     0.97239D0,  0.68884D0,  0.47281D0,  0.37266D0,  0.31157D0,
52339      &     0.26944D0,  0.21386D0,  0.16445D0,  0.11886D0,  0.09256D0,
52340      &     0.06285D0,  0.04618D0,  0.03539D0,  0.02621D0,  0.01979D0,
52341      &     0.01510D0,  0.01155D0,  0.00884D0,  0.00675D0,  0.00513D0,
52342      &     0.00387D0,  0.00290D0,  0.00216D0,  0.00159D0,  0.00116D0,
52343      &     0.00084D0,  0.00060D0,  0.00044D0,  0.00033D0,  0.00024D0,
52344      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52345      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52346       DATA (FMRS(1,5,I,25),I=1,49)/
52347      &     7.83575D0,  5.83079D0,  4.33631D0,  3.64485D0,  3.22112D0,
52348      &     2.92590D0,  2.16582D0,  1.59383D0,  1.32566D0,  1.15927D0,
52349      &     1.03966D0,  0.73165D0,  0.49881D0,  0.39156D0,  0.32642D0,
52350      &     0.28163D0,  0.22275D0,  0.17063D0,  0.12274D0,  0.09523D0,
52351      &     0.06428D0,  0.04699D0,  0.03585D0,  0.02642D0,  0.01984D0,
52352      &     0.01507D0,  0.01148D0,  0.00875D0,  0.00665D0,  0.00505D0,
52353      &     0.00380D0,  0.00284D0,  0.00210D0,  0.00154D0,  0.00112D0,
52354      &     0.00081D0,  0.00058D0,  0.00042D0,  0.00031D0,  0.00024D0,
52355      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52356      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52357       DATA (FMRS(1,5,I,26),I=1,49)/
52358      &     8.65815D0,  6.40607D0,  4.73699D0,  3.96832D0,  3.49865D0,
52359      &     3.17213D0,  2.33459D0,  1.70806D0,  1.41577D0,  1.23500D0,
52360      &     1.10538D0,  0.77305D0,  0.52365D0,  0.40947D0,  0.34040D0,
52361      &     0.29306D0,  0.23101D0,  0.17630D0,  0.12625D0,  0.09761D0,
52362      &     0.06550D0,  0.04766D0,  0.03620D0,  0.02654D0,  0.01984D0,
52363      &     0.01501D0,  0.01139D0,  0.00864D0,  0.00655D0,  0.00495D0,
52364      &     0.00371D0,  0.00276D0,  0.00204D0,  0.00149D0,  0.00108D0,
52365      &     0.00078D0,  0.00056D0,  0.00041D0,  0.00030D0,  0.00023D0,
52366      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52367      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52368       DATA (FMRS(1,5,I,27),I=1,49)/
52369      &     9.48773D0,  6.98283D0,  5.13620D0,  4.28942D0,  3.77342D0,
52370      &     3.41540D0,  2.50025D0,  1.81942D0,  1.50325D0,  1.30829D0,
52371      &     1.16884D0,  0.81270D0,  0.54722D0,  0.42638D0,  0.35354D0,
52372      &     0.30375D0,  0.23869D0,  0.18153D0,  0.12945D0,  0.09975D0,
52373      &     0.06658D0,  0.04823D0,  0.03648D0,  0.02662D0,  0.01982D0,
52374      &     0.01493D0,  0.01129D0,  0.00853D0,  0.00645D0,  0.00486D0,
52375      &     0.00363D0,  0.00270D0,  0.00199D0,  0.00145D0,  0.00105D0,
52376      &     0.00075D0,  0.00054D0,  0.00039D0,  0.00030D0,  0.00022D0,
52377      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52378      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52379       DATA (FMRS(1,5,I,28),I=1,49)/
52380      &    10.30763D0,  7.54945D0,  5.52601D0,  4.60181D0,  4.04004D0,
52381      &     3.65097D0,  2.65960D0,  1.92581D0,  1.58647D0,  1.37780D0,
52382      &     1.22885D0,  0.84989D0,  0.56911D0,  0.44198D0,  0.36560D0,
52383      &     0.31352D0,  0.24565D0,  0.18623D0,  0.13228D0,  0.10162D0,
52384      &     0.06750D0,  0.04868D0,  0.03669D0,  0.02666D0,  0.01976D0,
52385      &     0.01484D0,  0.01118D0,  0.00842D0,  0.00635D0,  0.00477D0,
52386      &     0.00355D0,  0.00263D0,  0.00193D0,  0.00141D0,  0.00102D0,
52387      &     0.00073D0,  0.00052D0,  0.00038D0,  0.00029D0,  0.00022D0,
52388      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52389      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52390       DATA (FMRS(1,5,I,29),I=1,49)/
52391      &    11.17527D0,  8.14579D0,  5.93397D0,  4.92768D0,  4.31749D0,
52392      &     3.89565D0,  2.82415D0,  2.03499D0,  1.67156D0,  1.44867D0,
52393      &     1.28991D0,  0.88743D0,  0.59103D0,  0.45751D0,  0.37756D0,
52394      &     0.32318D0,  0.25249D0,  0.19081D0,  0.13501D0,  0.10341D0,
52395      &     0.06835D0,  0.04909D0,  0.03686D0,  0.02667D0,  0.01969D0,
52396      &     0.01473D0,  0.01106D0,  0.00831D0,  0.00624D0,  0.00467D0,
52397      &     0.00347D0,  0.00257D0,  0.00188D0,  0.00136D0,  0.00099D0,
52398      &     0.00070D0,  0.00050D0,  0.00037D0,  0.00028D0,  0.00021D0,
52399      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52400      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52401       DATA (FMRS(1,5,I,30),I=1,49)/
52402      &    12.06456D0,  8.75358D0,  6.34740D0,  5.25678D0,  4.59701D0,
52403      &     4.14168D0,  2.98858D0,  2.14338D0,  1.75569D0,  1.51853D0,
52404      &     1.34994D0,  0.92405D0,  0.61221D0,  0.47241D0,  0.38898D0,
52405      &     0.33235D0,  0.25894D0,  0.19508D0,  0.13752D0,  0.10502D0,
52406      &     0.06908D0,  0.04942D0,  0.03697D0,  0.02664D0,  0.01960D0,
52407      &     0.01461D0,  0.01093D0,  0.00819D0,  0.00613D0,  0.00458D0,
52408      &     0.00339D0,  0.00250D0,  0.00183D0,  0.00132D0,  0.00095D0,
52409      &     0.00068D0,  0.00049D0,  0.00036D0,  0.00027D0,  0.00021D0,
52410      &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52411      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52412       DATA (FMRS(1,5,I,31),I=1,49)/
52413      &    12.95374D0,  9.35831D0,  6.75669D0,  5.58162D0,  4.87232D0,
52414      &     4.38360D0,  3.14942D0,  2.24882D0,  1.83726D0,  1.58610D0,
52415      &     1.40790D0,  0.95916D0,  0.63237D0,  0.48653D0,  0.39975D0,
52416      &     0.34099D0,  0.26498D0,  0.19905D0,  0.13983D0,  0.10648D0,
52417      &     0.06974D0,  0.04970D0,  0.03705D0,  0.02660D0,  0.01950D0,
52418      &     0.01449D0,  0.01081D0,  0.00807D0,  0.00603D0,  0.00449D0,
52419      &     0.00332D0,  0.00244D0,  0.00178D0,  0.00129D0,  0.00093D0,
52420      &     0.00066D0,  0.00047D0,  0.00035D0,  0.00026D0,  0.00020D0,
52421      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52422      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52423       DATA (FMRS(1,5,I,32),I=1,49)/
52424      &    13.81822D0,  9.94319D0,  7.15042D0,  5.89310D0,  5.13569D0,
52425      &     4.61461D0,  3.30209D0,  2.34827D0,  1.91389D0,  1.64940D0,
52426      &     1.46205D0,  0.99170D0,  0.65086D0,  0.49940D0,  0.40952D0,
52427      &     0.34877D0,  0.27037D0,  0.20256D0,  0.14182D0,  0.10773D0,
52428      &     0.07026D0,  0.04989D0,  0.03708D0,  0.02652D0,  0.01938D0,
52429      &     0.01436D0,  0.01068D0,  0.00795D0,  0.00592D0,  0.00440D0,
52430      &     0.00325D0,  0.00238D0,  0.00174D0,  0.00125D0,  0.00090D0,
52431      &     0.00064D0,  0.00046D0,  0.00034D0,  0.00026D0,  0.00020D0,
52432      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52433      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52434       DATA (FMRS(1,5,I,33),I=1,49)/
52435      &    14.74174D0, 10.56553D0,  7.56770D0,  6.22245D0,  5.41371D0,
52436      &     4.85814D0,  3.46239D0,  2.45228D0,  1.99384D0,  1.71531D0,
52437      &     1.51837D0,  1.02539D0,  0.66993D0,  0.51263D0,  0.41953D0,
52438      &     0.35674D0,  0.27589D0,  0.20614D0,  0.14386D0,  0.10899D0,
52439      &     0.07078D0,  0.05009D0,  0.03711D0,  0.02645D0,  0.01927D0,
52440      &     0.01422D0,  0.01055D0,  0.00784D0,  0.00582D0,  0.00432D0,
52441      &     0.00318D0,  0.00233D0,  0.00169D0,  0.00122D0,  0.00087D0,
52442      &     0.00062D0,  0.00044D0,  0.00033D0,  0.00025D0,  0.00020D0,
52443      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52444      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52445       DATA (FMRS(1,5,I,34),I=1,49)/
52446      &    15.66159D0, 11.18202D0,  7.97872D0,  6.54573D0,  5.68591D0,
52447      &     5.09611D0,  3.61802D0,  2.55254D0,  2.07056D0,  1.77835D0,
52448      &     1.57208D0,  1.05721D0,  0.68771D0,  0.52486D0,  0.42872D0,
52449      &     0.36401D0,  0.28085D0,  0.20931D0,  0.14560D0,  0.11004D0,
52450      &     0.07117D0,  0.05019D0,  0.03707D0,  0.02633D0,  0.01912D0,
52451      &     0.01408D0,  0.01041D0,  0.00771D0,  0.00572D0,  0.00423D0,
52452      &     0.00311D0,  0.00227D0,  0.00165D0,  0.00118D0,  0.00085D0,
52453      &     0.00060D0,  0.00043D0,  0.00032D0,  0.00025D0,  0.00020D0,
52454      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52455      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52456       DATA (FMRS(1,5,I,35),I=1,49)/
52457      &    16.58568D0, 11.79905D0,  8.38856D0,  6.86738D0,  5.95633D0,
52458      &     5.33223D0,  3.77185D0,  2.65127D0,  2.14594D0,  1.84019D0,
52459      &     1.62469D0,  1.08825D0,  0.70498D0,  0.53670D0,  0.43761D0,
52460      &     0.37103D0,  0.28563D0,  0.21235D0,  0.14727D0,  0.11103D0,
52461      &     0.07154D0,  0.05029D0,  0.03704D0,  0.02622D0,  0.01898D0,
52462      &     0.01394D0,  0.01028D0,  0.00760D0,  0.00562D0,  0.00415D0,
52463      &     0.00304D0,  0.00222D0,  0.00161D0,  0.00115D0,  0.00082D0,
52464      &     0.00058D0,  0.00042D0,  0.00031D0,  0.00024D0,  0.00019D0,
52465      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52466      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52467       DATA (FMRS(1,5,I,36),I=1,49)/
52468      &    17.48656D0, 12.39804D0,  8.78469D0,  7.17746D0,  6.21652D0,
52469      &     5.55909D0,  3.91895D0,  2.74520D0,  2.21743D0,  1.89869D0,
52470      &     1.67437D0,  1.11736D0,  0.72106D0,  0.54767D0,  0.44580D0,
52471      &     0.37747D0,  0.28999D0,  0.21509D0,  0.14875D0,  0.11190D0,
52472      &     0.07184D0,  0.05035D0,  0.03698D0,  0.02610D0,  0.01884D0,
52473      &     0.01380D0,  0.01016D0,  0.00749D0,  0.00553D0,  0.00407D0,
52474      &     0.00298D0,  0.00217D0,  0.00157D0,  0.00112D0,  0.00080D0,
52475      &     0.00057D0,  0.00041D0,  0.00031D0,  0.00024D0,  0.00019D0,
52476      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52477      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52478       DATA (FMRS(1,5,I,37),I=1,49)/
52479      &    18.41889D0, 13.01534D0,  9.19117D0,  7.49481D0,  6.48233D0,
52480      &     5.79049D0,  4.06828D0,  2.84006D0,  2.28940D0,  1.95745D0,
52481      &     1.72416D0,  1.14634D0,  0.73693D0,  0.55843D0,  0.45379D0,
52482      &     0.38373D0,  0.29419D0,  0.21770D0,  0.15013D0,  0.11269D0,
52483      &     0.07209D0,  0.05037D0,  0.03690D0,  0.02596D0,  0.01869D0,
52484      &     0.01365D0,  0.01003D0,  0.00738D0,  0.00543D0,  0.00399D0,
52485      &     0.00291D0,  0.00212D0,  0.00153D0,  0.00109D0,  0.00078D0,
52486      &     0.00055D0,  0.00040D0,  0.00030D0,  0.00023D0,  0.00019D0,
52487      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
52488      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52489       DATA (FMRS(1,5,I,38),I=1,49)/
52490      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52491      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52492      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52493      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52494      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52495      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52496      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52497      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52498      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52499      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52500       DATA (FMRS(1,6,I, 1),I=1,49)/
52501      &     0.44989D0,  0.39539D0,  0.34747D0,  0.32216D0,  0.30531D0,
52502      &     0.29285D0,  0.25722D0,  0.22578D0,  0.20909D0,  0.19792D0,
52503      &     0.18955D0,  0.16547D0,  0.14378D0,  0.13212D0,  0.12429D0,
52504      &     0.11845D0,  0.11003D0,  0.10150D0,  0.09208D0,  0.08532D0,
52505      &     0.07497D0,  0.06641D0,  0.05872D0,  0.04993D0,  0.04200D0,
52506      &     0.03492D0,  0.02867D0,  0.02327D0,  0.01867D0,  0.01463D0,
52507      &     0.01149D0,  0.00885D0,  0.00675D0,  0.00511D0,  0.00375D0,
52508      &     0.00275D0,  0.00200D0,  0.00140D0,  0.00092D0,  0.00067D0,
52509      &     0.00045D0,  0.00028D0,  0.00020D0,  0.00007D0,  0.00002D0,
52510      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52511       DATA (FMRS(1,6,I, 2),I=1,49)/
52512      &     0.46639D0,  0.41136D0,  0.36279D0,  0.33706D0,  0.31990D0,
52513      &     0.30719D0,  0.27073D0,  0.23840D0,  0.22115D0,  0.20956D0,
52514      &     0.20084D0,  0.17557D0,  0.15249D0,  0.13993D0,  0.13142D0,
52515      &     0.12504D0,  0.11578D0,  0.10635D0,  0.09591D0,  0.08845D0,
52516      &     0.07719D0,  0.06805D0,  0.05996D0,  0.05084D0,  0.04269D0,
52517      &     0.03544D0,  0.02909D0,  0.02361D0,  0.01895D0,  0.01488D0,
52518      &     0.01169D0,  0.00902D0,  0.00689D0,  0.00524D0,  0.00385D0,
52519      &     0.00283D0,  0.00206D0,  0.00146D0,  0.00096D0,  0.00071D0,
52520      &     0.00048D0,  0.00029D0,  0.00022D0,  0.00008D0,  0.00002D0,
52521      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52522       DATA (FMRS(1,6,I, 3),I=1,49)/
52523      &     0.50684D0,  0.44821D0,  0.39632D0,  0.36876D0,  0.35036D0,
52524      &     0.33670D0,  0.29743D0,  0.26242D0,  0.24363D0,  0.23094D0,
52525      &     0.22132D0,  0.19327D0,  0.16725D0,  0.15293D0,  0.14314D0,
52526      &     0.13576D0,  0.12501D0,  0.11402D0,  0.10188D0,  0.09328D0,
52527      &     0.08055D0,  0.07049D0,  0.06177D0,  0.05212D0,  0.04362D0,
52528      &     0.03613D0,  0.02960D0,  0.02400D0,  0.01926D0,  0.01513D0,
52529      &     0.01189D0,  0.00918D0,  0.00704D0,  0.00535D0,  0.00395D0,
52530      &     0.00290D0,  0.00211D0,  0.00152D0,  0.00101D0,  0.00074D0,
52531      &     0.00051D0,  0.00031D0,  0.00023D0,  0.00008D0,  0.00002D0,
52532      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52533       DATA (FMRS(1,6,I, 4),I=1,49)/
52534      &     0.55058D0,  0.48672D0,  0.43021D0,  0.40019D0,  0.38014D0,
52535      &     0.36526D0,  0.32246D0,  0.28426D0,  0.26371D0,  0.24981D0,
52536      &     0.23922D0,  0.20826D0,  0.17939D0,  0.16343D0,  0.15249D0,
52537      &     0.14425D0,  0.13221D0,  0.11993D0,  0.10640D0,  0.09689D0,
52538      &     0.08300D0,  0.07224D0,  0.06305D0,  0.05299D0,  0.04421D0,
52539      &     0.03653D0,  0.02989D0,  0.02420D0,  0.01939D0,  0.01523D0,
52540      &     0.01197D0,  0.00924D0,  0.00709D0,  0.00537D0,  0.00399D0,
52541      &     0.00293D0,  0.00213D0,  0.00154D0,  0.00102D0,  0.00074D0,
52542      &     0.00053D0,  0.00032D0,  0.00024D0,  0.00009D0,  0.00002D0,
52543      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52544       DATA (FMRS(1,6,I, 5),I=1,49)/
52545      &     0.61607D0,  0.54291D0,  0.47835D0,  0.44415D0,  0.42133D0,
52546      &     0.40441D0,  0.35583D0,  0.31254D0,  0.28927D0,  0.27353D0,
52547      &     0.26150D0,  0.22639D0,  0.19363D0,  0.17555D0,  0.16316D0,
52548      &     0.15384D0,  0.14026D0,  0.12643D0,  0.11130D0,  0.10077D0,
52549      &     0.08558D0,  0.07403D0,  0.06431D0,  0.05381D0,  0.04474D0,
52550      &     0.03686D0,  0.03008D0,  0.02432D0,  0.01945D0,  0.01528D0,
52551      &     0.01199D0,  0.00925D0,  0.00709D0,  0.00537D0,  0.00398D0,
52552      &     0.00293D0,  0.00214D0,  0.00154D0,  0.00103D0,  0.00074D0,
52553      &     0.00052D0,  0.00032D0,  0.00024D0,  0.00008D0,  0.00002D0,
52554      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52555       DATA (FMRS(1,6,I, 6),I=1,49)/
52556      &     0.68336D0,  0.60005D0,  0.52679D0,  0.48807D0,  0.46228D0,
52557      &     0.44318D0,  0.38846D0,  0.33984D0,  0.31375D0,  0.29611D0,
52558      &     0.28263D0,  0.24332D0,  0.20674D0,  0.18660D0,  0.17283D0,
52559      &     0.16249D0,  0.14745D0,  0.13219D0,  0.11560D0,  0.10414D0,
52560      &     0.08779D0,  0.07555D0,  0.06535D0,  0.05447D0,  0.04515D0,
52561      &     0.03709D0,  0.03021D0,  0.02439D0,  0.01946D0,  0.01528D0,
52562      &     0.01197D0,  0.00923D0,  0.00707D0,  0.00536D0,  0.00396D0,
52563      &     0.00291D0,  0.00213D0,  0.00154D0,  0.00103D0,  0.00073D0,
52564      &     0.00051D0,  0.00032D0,  0.00023D0,  0.00008D0,  0.00002D0,
52565      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52566       DATA (FMRS(1,6,I, 7),I=1,49)/
52567      &     0.76355D0,  0.66723D0,  0.58292D0,  0.53852D0,  0.50902D0,
52568      &     0.48721D0,  0.42490D0,  0.36978D0,  0.34030D0,  0.32042D0,
52569      &     0.30522D0,  0.26107D0,  0.22021D0,  0.19782D0,  0.18257D0,
52570      &     0.17114D0,  0.15457D0,  0.13784D0,  0.11976D0,  0.10736D0,
52571      &     0.08987D0,  0.07693D0,  0.06629D0,  0.05503D0,  0.04547D0,
52572      &     0.03726D0,  0.03027D0,  0.02439D0,  0.01942D0,  0.01523D0,
52573      &     0.01190D0,  0.00918D0,  0.00701D0,  0.00533D0,  0.00392D0,
52574      &     0.00287D0,  0.00209D0,  0.00153D0,  0.00101D0,  0.00073D0,
52575      &     0.00050D0,  0.00032D0,  0.00022D0,  0.00007D0,  0.00002D0,
52576      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52577       DATA (FMRS(1,6,I, 8),I=1,49)/
52578      &     0.86343D0,  0.75010D0,  0.65144D0,  0.59973D0,  0.56547D0,
52579      &     0.54018D0,  0.46822D0,  0.40492D0,  0.37123D0,  0.34856D0,
52580      &     0.33127D0,  0.28125D0,  0.23529D0,  0.21028D0,  0.19331D0,
52581      &     0.18063D0,  0.16233D0,  0.14394D0,  0.12420D0,  0.11077D0,
52582      &     0.09202D0,  0.07835D0,  0.06722D0,  0.05555D0,  0.04575D0,
52583      &     0.03737D0,  0.03028D0,  0.02434D0,  0.01934D0,  0.01514D0,
52584      &     0.01181D0,  0.00909D0,  0.00694D0,  0.00526D0,  0.00387D0,
52585      &     0.00282D0,  0.00206D0,  0.00150D0,  0.00100D0,  0.00072D0,
52586      &     0.00049D0,  0.00031D0,  0.00021D0,  0.00008D0,  0.00002D0,
52587      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52588       DATA (FMRS(1,6,I, 9),I=1,49)/
52589      &     0.96361D0,  0.83251D0,  0.71897D0,  0.65971D0,  0.62055D0,
52590      &     0.59171D0,  0.50993D0,  0.43838D0,  0.40047D0,  0.37504D0,
52591      &     0.35567D0,  0.29991D0,  0.24906D0,  0.22156D0,  0.20298D0,
52592      &     0.18914D0,  0.16924D0,  0.14933D0,  0.12809D0,  0.11373D0,
52593      &     0.09387D0,  0.07954D0,  0.06798D0,  0.05596D0,  0.04595D0,
52594      &     0.03743D0,  0.03026D0,  0.02427D0,  0.01926D0,  0.01505D0,
52595      &     0.01172D0,  0.00900D0,  0.00687D0,  0.00519D0,  0.00383D0,
52596      &     0.00278D0,  0.00203D0,  0.00148D0,  0.00098D0,  0.00071D0,
52597      &     0.00048D0,  0.00031D0,  0.00021D0,  0.00008D0,  0.00002D0,
52598      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52599       DATA (FMRS(1,6,I,10),I=1,49)/
52600      &     1.07479D0,  0.92315D0,  0.79255D0,  0.72469D0,  0.67997D0,
52601      &     0.64711D0,  0.55427D0,  0.47353D0,  0.43097D0,  0.40251D0,
52602      &     0.38089D0,  0.31894D0,  0.26290D0,  0.23280D0,  0.21256D0,
52603      &     0.19753D0,  0.17599D0,  0.15455D0,  0.13181D0,  0.11654D0,
52604      &     0.09559D0,  0.08062D0,  0.06865D0,  0.05629D0,  0.04608D0,
52605      &     0.03743D0,  0.03019D0,  0.02416D0,  0.01913D0,  0.01493D0,
52606      &     0.01161D0,  0.00890D0,  0.00677D0,  0.00511D0,  0.00377D0,
52607      &     0.00274D0,  0.00200D0,  0.00145D0,  0.00096D0,  0.00068D0,
52608      &     0.00046D0,  0.00030D0,  0.00020D0,  0.00008D0,  0.00002D0,
52609      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52610       DATA (FMRS(1,6,I,11),I=1,49)/
52611      &     1.17232D0,  1.00213D0,  0.85623D0,  0.78069D0,  0.73104D0,
52612      &     0.69461D0,  0.59200D0,  0.50321D0,  0.45658D0,  0.42550D0,
52613      &     0.40194D0,  0.33467D0,  0.27424D0,  0.24195D0,  0.22032D0,
52614      &     0.20431D0,  0.18142D0,  0.15872D0,  0.13477D0,  0.11875D0,
52615      &     0.09692D0,  0.08144D0,  0.06915D0,  0.05653D0,  0.04615D0,
52616      &     0.03741D0,  0.03011D0,  0.02406D0,  0.01902D0,  0.01482D0,
52617      &     0.01152D0,  0.00881D0,  0.00669D0,  0.00505D0,  0.00371D0,
52618      &     0.00270D0,  0.00197D0,  0.00143D0,  0.00094D0,  0.00066D0,
52619      &     0.00045D0,  0.00029D0,  0.00020D0,  0.00008D0,  0.00002D0,
52620      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52621       DATA (FMRS(1,6,I,12),I=1,49)/
52622      &     1.41135D0,  1.19389D0,  1.00931D0,  0.91452D0,  0.85253D0,
52623      &     0.80723D0,  0.68048D0,  0.57199D0,  0.51554D0,  0.47813D0,
52624      &     0.44992D0,  0.37007D0,  0.29939D0,  0.26209D0,  0.23729D0,
52625      &     0.21905D0,  0.19312D0,  0.16764D0,  0.14100D0,  0.12337D0,
52626      &     0.09965D0,  0.08309D0,  0.07010D0,  0.05694D0,  0.04624D0,
52627      &     0.03729D0,  0.02989D0,  0.02378D0,  0.01873D0,  0.01456D0,
52628      &     0.01128D0,  0.00861D0,  0.00651D0,  0.00490D0,  0.00360D0,
52629      &     0.00260D0,  0.00189D0,  0.00137D0,  0.00090D0,  0.00062D0,
52630      &     0.00043D0,  0.00028D0,  0.00019D0,  0.00007D0,  0.00002D0,
52631      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52632       DATA (FMRS(1,6,I,13),I=1,49)/
52633      &     1.65256D0,  1.38522D0,  1.16028D0,  1.04559D0,  0.97092D0,
52634      &     0.91653D0,  0.76529D0,  0.63704D0,  0.57085D0,  0.52722D0,
52635      &     0.49446D0,  0.40243D0,  0.32201D0,  0.28002D0,  0.25230D0,
52636      &     0.23200D0,  0.20332D0,  0.17533D0,  0.14629D0,  0.12724D0,
52637      &     0.10187D0,  0.08438D0,  0.07080D0,  0.05719D0,  0.04622D0,
52638      &     0.03712D0,  0.02965D0,  0.02350D0,  0.01845D0,  0.01430D0,
52639      &     0.01104D0,  0.00841D0,  0.00634D0,  0.00476D0,  0.00349D0,
52640      &     0.00251D0,  0.00182D0,  0.00132D0,  0.00086D0,  0.00060D0,
52641      &     0.00042D0,  0.00026D0,  0.00018D0,  0.00006D0,  0.00002D0,
52642      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52643       DATA (FMRS(1,6,I,14),I=1,49)/
52644      &     1.96387D0,  1.62942D0,  1.35081D0,  1.20988D0,  1.11860D0,
52645      &     1.05236D0,  0.86939D0,  0.71589D0,  0.63738D0,  0.58593D0,
52646      &     0.54750D0,  0.44041D0,  0.34815D0,  0.30054D0,  0.26935D0,
52647      &     0.24663D0,  0.21473D0,  0.18383D0,  0.15206D0,  0.13140D0,
52648      &     0.10419D0,  0.08567D0,  0.07145D0,  0.05736D0,  0.04609D0,
52649      &     0.03684D0,  0.02930D0,  0.02313D0,  0.01809D0,  0.01398D0,
52650      &     0.01074D0,  0.00816D0,  0.00615D0,  0.00459D0,  0.00334D0,
52651      &     0.00240D0,  0.00174D0,  0.00125D0,  0.00082D0,  0.00057D0,
52652      &     0.00038D0,  0.00024D0,  0.00016D0,  0.00006D0,  0.00002D0,
52653      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52654       DATA (FMRS(1,6,I,15),I=1,49)/
52655      &     2.33902D0,  1.92024D0,  1.57497D0,  1.40179D0,  1.29021D0,
52656      &     1.20956D0,  0.98833D0,  0.80477D0,  0.71175D0,  0.65116D0,
52657      &     0.60614D0,  0.48174D0,  0.37612D0,  0.32226D0,  0.28724D0,
52658      &     0.26188D0,  0.22649D0,  0.19248D0,  0.15783D0,  0.13549D0,
52659      &     0.10637D0,  0.08680D0,  0.07195D0,  0.05738D0,  0.04585D0,
52660      &     0.03646D0,  0.02886D0,  0.02269D0,  0.01768D0,  0.01360D0,
52661      &     0.01043D0,  0.00789D0,  0.00592D0,  0.00441D0,  0.00321D0,
52662      &     0.00230D0,  0.00166D0,  0.00118D0,  0.00078D0,  0.00054D0,
52663      &     0.00037D0,  0.00022D0,  0.00015D0,  0.00006D0,  0.00002D0,
52664      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52665       DATA (FMRS(1,6,I,16),I=1,49)/
52666      &     2.72482D0,  2.21608D0,  1.80052D0,  1.59364D0,  1.46096D0,
52667      &     1.36541D0,  1.10490D0,  0.89086D0,  0.78327D0,  0.71357D0,
52668      &     0.66200D0,  0.52058D0,  0.40200D0,  0.34217D0,  0.30354D0,
52669      &     0.27569D0,  0.23704D0,  0.20015D0,  0.16285D0,  0.13900D0,
52670      &     0.10817D0,  0.08767D0,  0.07227D0,  0.05729D0,  0.04554D0,
52671      &     0.03606D0,  0.02842D0,  0.02227D0,  0.01728D0,  0.01326D0,
52672      &     0.01012D0,  0.00763D0,  0.00571D0,  0.00425D0,  0.00307D0,
52673      &     0.00219D0,  0.00158D0,  0.00112D0,  0.00073D0,  0.00051D0,
52674      &     0.00035D0,  0.00021D0,  0.00014D0,  0.00005D0,  0.00002D0,
52675      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52676       DATA (FMRS(1,6,I,17),I=1,49)/
52677      &     3.16184D0,  2.54784D0,  2.05090D0,  1.80533D0,  1.64858D0,
52678      &     1.53608D0,  1.23122D0,  0.98314D0,  0.85944D0,  0.77972D0,
52679      &     0.72099D0,  0.56109D0,  0.42865D0,  0.36249D0,  0.32006D0,
52680      &     0.28962D0,  0.24759D0,  0.20774D0,  0.16775D0,  0.14236D0,
52681      &     0.10984D0,  0.08843D0,  0.07249D0,  0.05712D0,  0.04518D0,
52682      &     0.03560D0,  0.02794D0,  0.02182D0,  0.01686D0,  0.01291D0,
52683      &     0.00980D0,  0.00737D0,  0.00550D0,  0.00408D0,  0.00294D0,
52684      &     0.00209D0,  0.00150D0,  0.00107D0,  0.00069D0,  0.00049D0,
52685      &     0.00034D0,  0.00019D0,  0.00014D0,  0.00005D0,  0.00001D0,
52686      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52687       DATA (FMRS(1,6,I,18),I=1,49)/
52688      &     3.56226D0,  2.84906D0,  2.27616D0,  1.99475D0,  1.81581D0,
52689      &     1.68774D0,  1.34241D0,  1.06358D0,  0.92544D0,  0.83679D0,
52690      &     0.77171D0,  0.59551D0,  0.45100D0,  0.37940D0,  0.33372D0,
52691      &     0.30107D0,  0.25620D0,  0.21386D0,  0.17164D0,  0.14499D0,
52692      &     0.11108D0,  0.08895D0,  0.07258D0,  0.05692D0,  0.04483D0,
52693      &     0.03518D0,  0.02753D0,  0.02142D0,  0.01651D0,  0.01260D0,
52694      &     0.00954D0,  0.00717D0,  0.00532D0,  0.00393D0,  0.00284D0,
52695      &     0.00201D0,  0.00144D0,  0.00103D0,  0.00066D0,  0.00045D0,
52696      &     0.00032D0,  0.00018D0,  0.00013D0,  0.00004D0,  0.00001D0,
52697      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52698       DATA (FMRS(1,6,I,19),I=1,49)/
52699      &     4.09416D0,  3.24567D0,  2.57011D0,  2.24065D0,  2.03209D0,
52700      &     1.88332D0,  1.48448D0,  1.16540D0,  1.00850D0,  0.90831D0,
52701      &     0.83504D0,  0.63803D0,  0.47827D0,  0.39987D0,  0.35015D0,
52702      &     0.31478D0,  0.26640D0,  0.22104D0,  0.17612D0,  0.14797D0,
52703      &     0.11241D0,  0.08943D0,  0.07259D0,  0.05659D0,  0.04434D0,
52704      &     0.03464D0,  0.02699D0,  0.02092D0,  0.01606D0,  0.01221D0,
52705      &     0.00922D0,  0.00691D0,  0.00511D0,  0.00375D0,  0.00271D0,
52706      &     0.00191D0,  0.00136D0,  0.00097D0,  0.00063D0,  0.00043D0,
52707      &     0.00030D0,  0.00017D0,  0.00012D0,  0.00004D0,  0.00001D0,
52708      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52709       DATA (FMRS(1,6,I,20),I=1,49)/
52710      &     4.61257D0,  3.62885D0,  2.85161D0,  2.47491D0,  2.23738D0,
52711      &     2.06842D0,  1.61774D0,  1.26001D0,  1.08527D0,  0.97415D0,
52712      &     0.89315D0,  0.67662D0,  0.50274D0,  0.41811D0,  0.36471D0,
52713      &     0.32688D0,  0.27534D0,  0.22728D0,  0.17996D0,  0.15048D0,
52714      &     0.11349D0,  0.08979D0,  0.07253D0,  0.05626D0,  0.04389D0,
52715      &     0.03414D0,  0.02651D0,  0.02047D0,  0.01566D0,  0.01187D0,
52716      &     0.00894D0,  0.00668D0,  0.00493D0,  0.00361D0,  0.00261D0,
52717      &     0.00182D0,  0.00129D0,  0.00093D0,  0.00059D0,  0.00040D0,
52718      &     0.00028D0,  0.00016D0,  0.00011D0,  0.00004D0,  0.00001D0,
52719      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52720       DATA (FMRS(1,6,I,21),I=1,49)/
52721      &     5.12222D0,  4.00261D0,  3.12404D0,  2.70057D0,  2.43446D0,
52722      &     2.24566D0,  1.74429D0,  1.34911D0,  1.15718D0,  1.03559D0,
52723      &     0.94721D0,  0.71215D0,  0.52500D0,  0.43455D0,  0.37776D0,
52724      &     0.33766D0,  0.28323D0,  0.23271D0,  0.18324D0,  0.15257D0,
52725      &     0.11432D0,  0.08998D0,  0.07237D0,  0.05588D0,  0.04342D0,
52726      &     0.03365D0,  0.02604D0,  0.02004D0,  0.01529D0,  0.01156D0,
52727      &     0.00869D0,  0.00646D0,  0.00477D0,  0.00348D0,  0.00251D0,
52728      &     0.00175D0,  0.00124D0,  0.00088D0,  0.00057D0,  0.00038D0,
52729      &     0.00026D0,  0.00015D0,  0.00010D0,  0.00004D0,  0.00001D0,
52730      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52731       DATA (FMRS(1,6,I,22),I=1,49)/
52732      &     5.82554D0,  4.51423D0,  3.49391D0,  3.00548D0,  2.69986D0,
52733      &     2.48370D0,  1.91285D0,  1.46678D0,  1.25167D0,  1.11601D0,
52734      &     1.01775D0,  0.75806D0,  0.55345D0,  0.45543D0,  0.39424D0,
52735      &     0.35121D0,  0.29307D0,  0.23942D0,  0.18722D0,  0.15507D0,
52736      &     0.11526D0,  0.09014D0,  0.07211D0,  0.05536D0,  0.04279D0,
52737      &     0.03301D0,  0.02543D0,  0.01950D0,  0.01483D0,  0.01117D0,
52738      &     0.00837D0,  0.00620D0,  0.00456D0,  0.00332D0,  0.00238D0,
52739      &     0.00166D0,  0.00117D0,  0.00083D0,  0.00053D0,  0.00035D0,
52740      &     0.00024D0,  0.00015D0,  0.00010D0,  0.00003D0,  0.00001D0,
52741      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52742       DATA (FMRS(1,6,I,23),I=1,49)/
52743      &     6.54676D0,  5.03439D0,  3.86673D0,  3.31126D0,  2.96506D0,
52744      &     2.72090D0,  2.07933D0,  1.58195D0,  1.34364D0,  1.19398D0,
52745      &     1.08591D0,  0.80195D0,  0.58033D0,  0.47501D0,  0.40960D0,
52746      &     0.36377D0,  0.30212D0,  0.24551D0,  0.19078D0,  0.15726D0,
52747      &     0.11602D0,  0.09021D0,  0.07181D0,  0.05483D0,  0.04218D0,
52748      &     0.03240D0,  0.02486D0,  0.01900D0,  0.01440D0,  0.01081D0,
52749      &     0.00808D0,  0.00597D0,  0.00437D0,  0.00317D0,  0.00227D0,
52750      &     0.00157D0,  0.00111D0,  0.00080D0,  0.00050D0,  0.00034D0,
52751      &     0.00022D0,  0.00014D0,  0.00009D0,  0.00003D0,  0.00001D0,
52752      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52753       DATA (FMRS(1,6,I,24),I=1,49)/
52754      &     7.26565D0,  5.54876D0,  4.23247D0,  3.60982D0,  3.22311D0,
52755      &     2.95109D0,  2.23956D0,  1.69183D0,  1.43093D0,  1.26769D0,
52756      &     1.15015D0,  0.84286D0,  0.60508D0,  0.49288D0,  0.42351D0,
52757      &     0.37509D0,  0.31017D0,  0.25086D0,  0.19381D0,  0.15905D0,
52758      &     0.11655D0,  0.09013D0,  0.07142D0,  0.05426D0,  0.04157D0,
52759      &     0.03180D0,  0.02431D0,  0.01852D0,  0.01399D0,  0.01048D0,
52760      &     0.00780D0,  0.00574D0,  0.00419D0,  0.00304D0,  0.00217D0,
52761      &     0.00149D0,  0.00106D0,  0.00075D0,  0.00048D0,  0.00032D0,
52762      &     0.00021D0,  0.00013D0,  0.00009D0,  0.00003D0,  0.00001D0,
52763      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52764       DATA (FMRS(1,6,I,25),I=1,49)/
52765      &     8.04192D0,  6.10017D0,  4.62168D0,  3.92618D0,  3.49572D0,
52766      &     3.19370D0,  2.40717D0,  1.80591D0,  1.52114D0,  1.34361D0,
52767      &     1.21613D0,  0.88453D0,  0.63003D0,  0.51078D0,  0.43739D0,
52768      &     0.38633D0,  0.31813D0,  0.25609D0,  0.19674D0,  0.16076D0,
52769      &     0.11701D0,  0.09001D0,  0.07101D0,  0.05368D0,  0.04095D0,
52770      &     0.03121D0,  0.02377D0,  0.01805D0,  0.01359D0,  0.01015D0,
52771      &     0.00753D0,  0.00553D0,  0.00402D0,  0.00291D0,  0.00207D0,
52772      &     0.00142D0,  0.00101D0,  0.00071D0,  0.00045D0,  0.00030D0,
52773      &     0.00020D0,  0.00012D0,  0.00008D0,  0.00003D0,  0.00001D0,
52774      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52775       DATA (FMRS(1,6,I,26),I=1,49)/
52776      &     8.84513D0,  6.66663D0,  5.01863D0,  4.24745D0,  3.77171D0,
52777      &     3.43873D0,  2.57518D0,  1.91937D0,  1.61043D0,  1.41849D0,
52778      &     1.28102D0,  0.92509D0,  0.65405D0,  0.52788D0,  0.45056D0,
52779      &     0.39694D0,  0.32555D0,  0.26091D0,  0.19936D0,  0.16223D0,
52780      &     0.11732D0,  0.08979D0,  0.07053D0,  0.05307D0,  0.04031D0,
52781      &     0.03061D0,  0.02325D0,  0.01759D0,  0.01321D0,  0.00982D0,
52782      &     0.00728D0,  0.00532D0,  0.00387D0,  0.00279D0,  0.00197D0,
52783      &     0.00136D0,  0.00096D0,  0.00067D0,  0.00043D0,  0.00029D0,
52784      &     0.00019D0,  0.00011D0,  0.00007D0,  0.00003D0,  0.00001D0,
52785      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52786       DATA (FMRS(1,6,I,27),I=1,49)/
52787      &     9.65435D0,  7.23356D0,  5.41328D0,  4.56560D0,  4.04426D0,
52788      &     3.68017D0,  2.73960D0,  2.02962D0,  1.69683D0,  1.49072D0,
52789      &     1.34344D0,  0.96379D0,  0.67674D0,  0.54393D0,  0.46286D0,
52790      &     0.40680D0,  0.33241D0,  0.26531D0,  0.20171D0,  0.16351D0,
52791      &     0.11755D0,  0.08953D0,  0.07005D0,  0.05247D0,  0.03970D0,
52792      &     0.03004D0,  0.02275D0,  0.01715D0,  0.01284D0,  0.00953D0,
52793      &     0.00704D0,  0.00513D0,  0.00373D0,  0.00268D0,  0.00189D0,
52794      &     0.00130D0,  0.00092D0,  0.00064D0,  0.00040D0,  0.00027D0,
52795      &     0.00018D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
52796      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52797       DATA (FMRS(1,6,I,28),I=1,49)/
52798      &    10.45602D0,  7.79175D0,  5.79941D0,  4.87575D0,  4.30926D0,
52799      &     3.91444D0,  2.89810D0,  2.13519D0,  1.77921D0,  1.55938D0,
52800      &     1.40263D0,  1.00018D0,  0.69787D0,  0.55877D0,  0.47417D0,
52801      &     0.41582D0,  0.33862D0,  0.26925D0,  0.20376D0,  0.16459D0,
52802      &     0.11767D0,  0.08923D0,  0.06955D0,  0.05189D0,  0.03911D0,
52803      &     0.02950D0,  0.02227D0,  0.01675D0,  0.01249D0,  0.00926D0,
52804      &     0.00681D0,  0.00496D0,  0.00359D0,  0.00258D0,  0.00181D0,
52805      &     0.00125D0,  0.00088D0,  0.00062D0,  0.00038D0,  0.00026D0,
52806      &     0.00017D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
52807      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52808       DATA (FMRS(1,6,I,29),I=1,49)/
52809      &    11.30416D0,  8.37884D0,  6.20316D0,  5.19892D0,  4.58469D0,
52810      &     4.15747D0,  3.06152D0,  2.24335D0,  1.86330D0,  1.62927D0,
52811      &     1.46273D0,  1.03685D0,  0.71898D0,  0.57351D0,  0.48535D0,
52812      &     0.42471D0,  0.34469D0,  0.27305D0,  0.20570D0,  0.16558D0,
52813      &     0.11773D0,  0.08889D0,  0.06902D0,  0.05129D0,  0.03852D0,
52814      &     0.02896D0,  0.02179D0,  0.01634D0,  0.01216D0,  0.00899D0,
52815      &     0.00659D0,  0.00479D0,  0.00347D0,  0.00248D0,  0.00174D0,
52816      &     0.00119D0,  0.00084D0,  0.00059D0,  0.00036D0,  0.00024D0,
52817      &     0.00016D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
52818      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52819       DATA (FMRS(1,6,I,30),I=1,49)/
52820      &    12.17534D0,  8.97841D0,  6.61310D0,  5.52592D0,  4.86271D0,
52821      &     4.40230D0,  3.22516D0,  2.35097D0,  1.94663D0,  1.69833D0,
52822      &     1.52199D0,  1.07270D0,  0.73942D0,  0.58770D0,  0.49605D0,
52823      &     0.43317D0,  0.35042D0,  0.27659D0,  0.20745D0,  0.16642D0,
52824      &     0.11771D0,  0.08850D0,  0.06847D0,  0.05068D0,  0.03793D0,
52825      &     0.02842D0,  0.02132D0,  0.01595D0,  0.01184D0,  0.00872D0,
52826      &     0.00639D0,  0.00464D0,  0.00334D0,  0.00238D0,  0.00167D0,
52827      &     0.00115D0,  0.00081D0,  0.00056D0,  0.00034D0,  0.00023D0,
52828      &     0.00015D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00000D0,
52829      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52830       DATA (FMRS(1,6,I,31),I=1,49)/
52831      &    13.04562D0,  9.57419D0,  7.01826D0,  5.84808D0,  5.13599D0,
52832      &     4.64254D0,  3.38483D0,  2.45538D0,  2.02720D0,  1.76492D0,
52833      &     1.57901D0,  1.10697D0,  0.75881D0,  0.60107D0,  0.50610D0,
52834      &     0.44109D0,  0.35574D0,  0.27985D0,  0.20903D0,  0.16716D0,
52835      &     0.11764D0,  0.08810D0,  0.06793D0,  0.05010D0,  0.03737D0,
52836      &     0.02791D0,  0.02089D0,  0.01558D0,  0.01154D0,  0.00848D0,
52837      &     0.00620D0,  0.00450D0,  0.00323D0,  0.00230D0,  0.00160D0,
52838      &     0.00110D0,  0.00077D0,  0.00053D0,  0.00032D0,  0.00022D0,
52839      &     0.00015D0,  0.00008D0,  0.00006D0,  0.00002D0,  0.00000D0,
52840      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52841       DATA (FMRS(1,6,I,32),I=1,49)/
52842      &    13.89443D0, 10.15226D0,  7.40931D0,  6.15805D0,  5.39834D0,
52843      &     4.87276D0,  3.53699D0,  2.55429D0,  2.10325D0,  1.82761D0,
52844      &     1.63256D0,  1.13890D0,  0.77669D0,  0.61332D0,  0.51524D0,
52845      &     0.44825D0,  0.36050D0,  0.28271D0,  0.21036D0,  0.16773D0,
52846      &     0.11750D0,  0.08767D0,  0.06738D0,  0.04952D0,  0.03683D0,
52847      &     0.02743D0,  0.02048D0,  0.01524D0,  0.01125D0,  0.00826D0,
52848      &     0.00603D0,  0.00436D0,  0.00312D0,  0.00222D0,  0.00155D0,
52849      &     0.00106D0,  0.00074D0,  0.00051D0,  0.00031D0,  0.00021D0,
52850      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
52851      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52852       DATA (FMRS(1,6,I,33),I=1,49)/
52853      &    14.79866D0, 10.76526D0,  7.82209D0,  6.48437D0,  5.67399D0,
52854      &     5.11430D0,  3.69589D0,  2.65710D0,  2.18207D0,  1.89245D0,
52855      &     1.68785D0,  1.17170D0,  0.79496D0,  0.62581D0,  0.52453D0,
52856      &     0.45551D0,  0.36532D0,  0.28560D0,  0.21171D0,  0.16831D0,
52857      &     0.11736D0,  0.08724D0,  0.06684D0,  0.04896D0,  0.03630D0,
52858      &     0.02696D0,  0.02007D0,  0.01490D0,  0.01098D0,  0.00805D0,
52859      &     0.00586D0,  0.00423D0,  0.00302D0,  0.00214D0,  0.00150D0,
52860      &     0.00102D0,  0.00071D0,  0.00049D0,  0.00030D0,  0.00020D0,
52861      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
52862      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52863       DATA (FMRS(1,6,I,34),I=1,49)/
52864      &    15.70368D0, 11.37564D0,  8.23095D0,  6.80656D0,  5.94554D0,
52865      &     5.35181D0,  3.85123D0,  2.75698D0,  2.25835D0,  1.95501D0,
52866      &     1.74107D0,  1.20298D0,  0.81219D0,  0.63747D0,  0.53315D0,
52867      &     0.46219D0,  0.36968D0,  0.28814D0,  0.21281D0,  0.16870D0,
52868      &     0.11711D0,  0.08674D0,  0.06626D0,  0.04836D0,  0.03575D0,
52869      &     0.02649D0,  0.01967D0,  0.01456D0,  0.01071D0,  0.00784D0,
52870      &     0.00568D0,  0.00409D0,  0.00292D0,  0.00207D0,  0.00144D0,
52871      &     0.00098D0,  0.00068D0,  0.00047D0,  0.00029D0,  0.00019D0,
52872      &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
52873      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52874       DATA (FMRS(1,6,I,35),I=1,49)/
52875      &    16.61098D0, 11.98498D0,  8.63737D0,  7.12604D0,  6.21432D0,
52876      &     5.58657D0,  4.00413D0,  2.85486D0,  2.33290D0,  2.01603D0,
52877      &     1.79291D0,  1.23331D0,  0.82880D0,  0.64868D0,  0.54141D0,
52878      &     0.46858D0,  0.37384D0,  0.29056D0,  0.21385D0,  0.16907D0,
52879      &     0.11687D0,  0.08628D0,  0.06571D0,  0.04780D0,  0.03525D0,
52880      &     0.02604D0,  0.01929D0,  0.01425D0,  0.01046D0,  0.00764D0,
52881      &     0.00552D0,  0.00397D0,  0.00283D0,  0.00200D0,  0.00139D0,
52882      &     0.00095D0,  0.00066D0,  0.00045D0,  0.00028D0,  0.00019D0,
52883      &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
52884      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52885       DATA (FMRS(1,6,I,36),I=1,49)/
52886      &    17.49641D0, 12.57703D0,  9.03053D0,  7.43428D0,  6.47316D0,
52887      &     5.81232D0,  4.15045D0,  2.94807D0,  2.40367D0,  2.07383D0,
52888      &     1.84191D0,  1.26179D0,  0.84428D0,  0.65906D0,  0.54902D0,
52889      &     0.47444D0,  0.37762D0,  0.29271D0,  0.21474D0,  0.16935D0,
52890      &     0.11660D0,  0.08580D0,  0.06517D0,  0.04726D0,  0.03476D0,
52891      &     0.02562D0,  0.01894D0,  0.01396D0,  0.01022D0,  0.00745D0,
52892      &     0.00538D0,  0.00386D0,  0.00274D0,  0.00194D0,  0.00135D0,
52893      &     0.00092D0,  0.00063D0,  0.00044D0,  0.00027D0,  0.00018D0,
52894      &     0.00011D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
52895      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52896       DATA (FMRS(1,6,I,37),I=1,49)/
52897      &    18.41415D0, 13.18812D0,  9.43458D0,  7.75025D0,  6.73800D0,
52898      &     6.04297D0,  4.29926D0,  3.04240D0,  2.47507D0,  2.13202D0,
52899      &     1.89114D0,  1.29020D0,  0.85959D0,  0.66927D0,  0.55646D0,
52900      &     0.48015D0,  0.38126D0,  0.29476D0,  0.21554D0,  0.16955D0,
52901      &     0.11628D0,  0.08530D0,  0.06461D0,  0.04672D0,  0.03427D0,
52902      &     0.02520D0,  0.01858D0,  0.01367D0,  0.00999D0,  0.00727D0,
52903      &     0.00525D0,  0.00375D0,  0.00266D0,  0.00188D0,  0.00131D0,
52904      &     0.00088D0,  0.00061D0,  0.00042D0,  0.00026D0,  0.00017D0,
52905      &     0.00011D0,  0.00006D0,  0.00004D0,  0.00001D0,  0.00000D0,
52906      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52907       DATA (FMRS(1,6,I,38),I=1,49)/
52908      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52909      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52910      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52911      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52912      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52913      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52914      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52915      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52916      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52917      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52918       DATA (FMRS(1,7,I, 1),I=1,49)/
52919      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52920      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52921      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52922      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52923      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52924      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52925      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52926      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52927      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52928      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52929       DATA (FMRS(1,7,I, 2),I=1,49)/
52930      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52931      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52932      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52933      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52934      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52935      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52936      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52937      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52938      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52939      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52940       DATA (FMRS(1,7,I, 3),I=1,49)/
52941      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52942      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52943      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52944      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52945      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52946      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52947      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52948      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52949      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52950      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52951       DATA (FMRS(1,7,I, 4),I=1,49)/
52952      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52953      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52954      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52955      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52956      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52957      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52958      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52959      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52960      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52961      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52962       DATA (FMRS(1,7,I, 5),I=1,49)/
52963      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52964      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52965      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52966      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52967      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52968      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52969      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52970      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52971      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52972      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52973       DATA (FMRS(1,7,I, 6),I=1,49)/
52974      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52975      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52976      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52977      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52978      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52979      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52980      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52981      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52982      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52983      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52984       DATA (FMRS(1,7,I, 7),I=1,49)/
52985      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52986      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52987      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52988      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52989      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52990      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52991      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52992      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52993      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52994      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
52995       DATA (FMRS(1,7,I, 8),I=1,49)/
52996      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52997      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52998      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
52999      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53000      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53001      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53002      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53003      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53004      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53005      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53006       DATA (FMRS(1,7,I, 9),I=1,49)/
53007      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53008      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53009      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53010      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53011      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53012      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53013      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53014      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53015      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53016      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53017       DATA (FMRS(1,7,I,10),I=1,49)/
53018      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53019      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53020      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53021      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53022      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53023      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53024      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53025      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53026      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53027      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53028       DATA (FMRS(1,7,I,11),I=1,49)/
53029      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53030      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53031      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53032      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53033      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53034      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53035      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53036      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53037      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53038      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53039       DATA (FMRS(1,7,I,12),I=1,49)/
53040      &     0.00042D0,  0.00036D0,  0.00032D0,  0.00030D0,  0.00028D0,
53041      &     0.00027D0,  0.00023D0,  0.00020D0,  0.00019D0,  0.00018D0,
53042      &     0.00017D0,  0.00014D0,  0.00012D0,  0.00011D0,  0.00010D0,
53043      &     0.00009D0,  0.00008D0,  0.00007D0,  0.00006D0,  0.00005D0,
53044      &     0.00005D0,  0.00004D0,  0.00003D0,  0.00003D0,  0.00003D0,
53045      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00001D0,
53046      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
53047      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53048      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53049      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53050       DATA (FMRS(1,7,I,13),I=1,49)/
53051      &     0.21520D0,  0.16773D0,  0.13065D0,  0.11283D0,  0.10165D0,
53052      &     0.09372D0,  0.07266D0,  0.05600D0,  0.04786D0,  0.04266D0,
53053      &     0.03883D0,  0.02862D0,  0.02044D0,  0.01649D0,  0.01402D0,
53054      &     0.01228D0,  0.00994D0,  0.00781D0,  0.00579D0,  0.00460D0,
53055      &     0.00322D0,  0.00243D0,  0.00191D0,  0.00146D0,  0.00114D0,
53056      &     0.00089D0,  0.00070D0,  0.00055D0,  0.00043D0,  0.00034D0,
53057      &     0.00026D0,  0.00020D0,  0.00015D0,  0.00011D0,  0.00009D0,
53058      &     0.00006D0,  0.00005D0,  0.00003D0,  0.00002D0,  0.00001D0,
53059      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53060      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53061       DATA (FMRS(1,7,I,14),I=1,49)/
53062      &     0.62424D0,  0.48455D0,  0.37589D0,  0.32385D0,  0.29126D0,
53063      &     0.26818D0,  0.20706D0,  0.15892D0,  0.13546D0,  0.12053D0,
53064      &     0.10954D0,  0.08034D0,  0.05707D0,  0.04589D0,  0.03892D0,
53065      &     0.03403D0,  0.02747D0,  0.02151D0,  0.01589D0,  0.01258D0,
53066      &     0.00876D0,  0.00658D0,  0.00515D0,  0.00391D0,  0.00303D0,
53067      &     0.00236D0,  0.00185D0,  0.00144D0,  0.00112D0,  0.00088D0,
53068      &     0.00067D0,  0.00051D0,  0.00039D0,  0.00029D0,  0.00022D0,
53069      &     0.00016D0,  0.00011D0,  0.00008D0,  0.00006D0,  0.00004D0,
53070      &     0.00002D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53071      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53072       DATA (FMRS(1,7,I,15),I=1,49)/
53073      &     1.00765D0,  0.77678D0,  0.59844D0,  0.51350D0,  0.46049D0,
53074      &     0.42306D0,  0.32436D0,  0.24719D0,  0.20981D0,  0.18611D0,
53075      &     0.16874D0,  0.12279D0,  0.08652D0,  0.06923D0,  0.05850D0,
53076      &     0.05102D0,  0.04100D0,  0.03196D0,  0.02347D0,  0.01849D0,
53077      &     0.01279D0,  0.00955D0,  0.00743D0,  0.00560D0,  0.00430D0,
53078      &     0.00334D0,  0.00260D0,  0.00202D0,  0.00157D0,  0.00121D0,
53079      &     0.00093D0,  0.00071D0,  0.00053D0,  0.00040D0,  0.00029D0,
53080      &     0.00021D0,  0.00015D0,  0.00011D0,  0.00007D0,  0.00005D0,
53081      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53082      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53083       DATA (FMRS(1,7,I,16),I=1,49)/
53084      &     1.42250D0,  1.08981D0,  0.83442D0,  0.71339D0,  0.63810D0,
53085      &     0.58505D0,  0.44575D0,  0.33755D0,  0.28542D0,  0.25249D0,
53086      &     0.22841D0,  0.16506D0,  0.11545D0,  0.09197D0,  0.07747D0,
53087      &     0.06738D0,  0.05394D0,  0.04186D0,  0.03057D0,  0.02399D0,
53088      &     0.01648D0,  0.01223D0,  0.00946D0,  0.00708D0,  0.00541D0,
53089      &     0.00417D0,  0.00323D0,  0.00250D0,  0.00193D0,  0.00149D0,
53090      &     0.00113D0,  0.00086D0,  0.00064D0,  0.00048D0,  0.00035D0,
53091      &     0.00026D0,  0.00018D0,  0.00013D0,  0.00009D0,  0.00005D0,
53092      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53093      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53094       DATA (FMRS(1,7,I,17),I=1,49)/
53095      &     1.90329D0,  1.44918D0,  1.10274D0,  0.93938D0,  0.83807D0,
53096      &     0.76686D0,  0.58064D0,  0.43692D0,  0.36805D0,  0.32470D0,
53097      &     0.29309D0,  0.21032D0,  0.14604D0,  0.11582D0,  0.09725D0,
53098      &     0.08437D0,  0.06728D0,  0.05198D0,  0.03776D0,  0.02950D0,
53099      &     0.02012D0,  0.01485D0,  0.01142D0,  0.00850D0,  0.00645D0,
53100      &     0.00494D0,  0.00381D0,  0.00293D0,  0.00225D0,  0.00172D0,
53101      &     0.00131D0,  0.00098D0,  0.00073D0,  0.00054D0,  0.00040D0,
53102      &     0.00029D0,  0.00021D0,  0.00014D0,  0.00010D0,  0.00006D0,
53103      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53104      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53105       DATA (FMRS(1,7,I,18),I=1,49)/
53106      &     2.33137D0,  1.76616D0,  1.33713D0,  1.13567D0,  1.01106D0,
53107      &     0.92363D0,  0.69576D0,  0.52083D0,  0.43738D0,  0.38501D0,
53108      &     0.34690D0,  0.24753D0,  0.17085D0,  0.13502D0,  0.11307D0,
53109      &     0.09789D0,  0.07781D0,  0.05991D0,  0.04333D0,  0.03374D0,
53110      &     0.02288D0,  0.01680D0,  0.01286D0,  0.00952D0,  0.00719D0,
53111      &     0.00549D0,  0.00420D0,  0.00322D0,  0.00246D0,  0.00188D0,
53112      &     0.00142D0,  0.00107D0,  0.00079D0,  0.00059D0,  0.00043D0,
53113      &     0.00031D0,  0.00022D0,  0.00015D0,  0.00010D0,  0.00006D0,
53114      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53115      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53116       DATA (FMRS(1,7,I,19),I=1,49)/
53117      &     2.89798D0,  2.18213D0,  1.64207D0,  1.38971D0,  1.23410D0,
53118      &     1.12518D0,  0.84241D0,  0.62670D0,  0.52435D0,  0.46034D0,
53119      &     0.41389D0,  0.29333D0,  0.20103D0,  0.15819D0,  0.13206D0,
53120      &     0.11405D0,  0.09031D0,  0.06924D0,  0.04982D0,  0.03863D0,
53121      &     0.02602D0,  0.01899D0,  0.01446D0,  0.01064D0,  0.00798D0,
53122      &     0.00606D0,  0.00462D0,  0.00352D0,  0.00268D0,  0.00204D0,
53123      &     0.00153D0,  0.00115D0,  0.00085D0,  0.00062D0,  0.00046D0,
53124      &     0.00034D0,  0.00024D0,  0.00016D0,  0.00010D0,  0.00006D0,
53125      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53126      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53127       DATA (FMRS(1,7,I,20),I=1,49)/
53128      &     3.45978D0,  2.59142D0,  1.93977D0,  1.63658D0,  1.45012D0,
53129      &     1.31987D0,  0.98290D0,  0.72728D0,  0.60655D0,  0.53126D0,
53130      &     0.47676D0,  0.33590D0,  0.22879D0,  0.17936D0,  0.14933D0,
53131      &     0.12869D0,  0.10156D0,  0.07757D0,  0.05556D0,  0.04293D0,
53132      &     0.02875D0,  0.02087D0,  0.01582D0,  0.01157D0,  0.00864D0,
53133      &     0.00653D0,  0.00495D0,  0.00376D0,  0.00285D0,  0.00216D0,
53134      &     0.00162D0,  0.00120D0,  0.00089D0,  0.00065D0,  0.00048D0,
53135      &     0.00035D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
53136      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53137      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53138       DATA (FMRS(1,7,I,21),I=1,49)/
53139      &     3.99390D0,  2.97724D0,  2.21795D0,  1.86604D0,  1.65015D0,
53140      &     1.49961D0,  1.11138D0,  0.81834D0,  0.68051D0,  0.59480D0,
53141      &     0.53289D0,  0.37345D0,  0.25296D0,  0.19764D0,  0.16415D0,
53142      &     0.14119D0,  0.11109D0,  0.08457D0,  0.06032D0,  0.04645D0,
53143      &     0.03094D0,  0.02236D0,  0.01688D0,  0.01228D0,  0.00913D0,
53144      &     0.00687D0,  0.00519D0,  0.00392D0,  0.00296D0,  0.00223D0,
53145      &     0.00167D0,  0.00124D0,  0.00091D0,  0.00067D0,  0.00049D0,
53146      &     0.00036D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
53147      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53148      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53149       DATA (FMRS(1,7,I,22),I=1,49)/
53150      &     4.74104D0,  3.51318D0,  2.60162D0,  2.18119D0,  1.92405D0,
53151      &     1.74515D0,  1.28558D0,  0.94085D0,  0.77956D0,  0.67959D0,
53152      &     0.60758D0,  0.42298D0,  0.28453D0,  0.22138D0,  0.18331D0,
53153      &     0.15728D0,  0.12329D0,  0.09346D0,  0.06632D0,  0.05087D0,
53154      &     0.03366D0,  0.02418D0,  0.01815D0,  0.01313D0,  0.00971D0,
53155      &     0.00726D0,  0.00546D0,  0.00411D0,  0.00309D0,  0.00232D0,
53156      &     0.00172D0,  0.00128D0,  0.00094D0,  0.00068D0,  0.00049D0,
53157      &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
53158      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53159      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53160       DATA (FMRS(1,7,I,23),I=1,49)/
53161      &     5.50879D0,  4.05964D0,  2.98973D0,  2.49849D0,  2.19888D0,
53162      &     1.99086D0,  1.45844D0,  1.06135D0,  0.87646D0,  0.76222D0,
53163      &     0.68014D0,  0.47060D0,  0.31455D0,  0.24380D0,  0.20130D0,
53164      &     0.17233D0,  0.13462D0,  0.10166D0,  0.07179D0,  0.05486D0,
53165      &     0.03607D0,  0.02577D0,  0.01926D0,  0.01386D0,  0.01019D0,
53166      &     0.00758D0,  0.00568D0,  0.00425D0,  0.00318D0,  0.00238D0,
53167      &     0.00176D0,  0.00130D0,  0.00095D0,  0.00069D0,  0.00050D0,
53168      &     0.00037D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
53169      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53170      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53171       DATA (FMRS(1,7,I,24),I=1,49)/
53172      &     6.25919D0,  4.58931D0,  3.36270D0,  2.80183D0,  2.46064D0,
53173      &     2.22421D0,  1.62105D0,  1.17360D0,  0.96617D0,  0.83838D0,
53174      &     0.74677D0,  0.51381D0,  0.34143D0,  0.26369D0,  0.21716D0,
53175      &     0.18553D0,  0.14447D0,  0.10870D0,  0.07643D0,  0.05820D0,
53176      &     0.03805D0,  0.02705D0,  0.02012D0,  0.01441D0,  0.01054D0,
53177      &     0.00781D0,  0.00582D0,  0.00434D0,  0.00324D0,  0.00241D0,
53178      &     0.00178D0,  0.00131D0,  0.00095D0,  0.00069D0,  0.00050D0,
53179      &     0.00037D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
53180      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53181      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53182       DATA (FMRS(1,7,I,25),I=1,49)/
53183      &     7.07966D0,  5.16501D0,  3.76564D0,  3.12838D0,  2.74171D0,
53184      &     2.47426D0,  1.79422D0,  1.29235D0,  1.06071D0,  0.91840D0,
53185      &     0.81663D0,  0.55877D0,  0.36917D0,  0.28412D0,  0.23339D0,
53186      &     0.19900D0,  0.15447D0,  0.11582D0,  0.08108D0,  0.06153D0,
53187      &     0.03999D0,  0.02830D0,  0.02096D0,  0.01493D0,  0.01087D0,
53188      &     0.00803D0,  0.00595D0,  0.00442D0,  0.00329D0,  0.00244D0,
53189      &     0.00180D0,  0.00131D0,  0.00096D0,  0.00069D0,  0.00050D0,
53190      &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
53191      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53192      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53193       DATA (FMRS(1,7,I,26),I=1,49)/
53194      &     7.91829D0,  5.74916D0,  4.17141D0,  3.45573D0,  3.02255D0,
53195      &     2.72346D0,  1.96537D0,  1.40870D0,  1.15285D0,  0.99608D0,
53196      &     0.88421D0,  0.60182D0,  0.39541D0,  0.30330D0,  0.24854D0,
53197      &     0.21150D0,  0.16368D0,  0.12231D0,  0.08527D0,  0.06448D0,
53198      &     0.04169D0,  0.02937D0,  0.02165D0,  0.01535D0,  0.01113D0,
53199      &     0.00818D0,  0.00604D0,  0.00447D0,  0.00331D0,  0.00245D0,
53200      &     0.00180D0,  0.00131D0,  0.00095D0,  0.00068D0,  0.00049D0,
53201      &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
53202      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53203      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53204       DATA (FMRS(1,7,I,27),I=1,49)/
53205      &     8.76657D0,  6.33661D0,  4.57707D0,  3.78184D0,  3.30161D0,
53206      &     2.97059D0,  2.13403D0,  1.52261D0,  1.24269D0,  1.07161D0,
53207      &     0.94977D0,  0.64324D0,  0.42046D0,  0.32150D0,  0.26285D0,
53208      &     0.22328D0,  0.17230D0,  0.12835D0,  0.08912D0,  0.06719D0,
53209      &     0.04322D0,  0.03031D0,  0.02226D0,  0.01571D0,  0.01134D0,
53210      &     0.00830D0,  0.00611D0,  0.00451D0,  0.00333D0,  0.00245D0,
53211      &     0.00180D0,  0.00131D0,  0.00095D0,  0.00068D0,  0.00048D0,
53212      &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
53213      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53214      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53215       DATA (FMRS(1,7,I,28),I=1,49)/
53216      &     9.60252D0,  6.91204D0,  4.97199D0,  4.09813D0,  3.57154D0,
53217      &     3.20914D0,  2.29574D0,  1.63105D0,  1.32784D0,  1.14296D0,
53218      &     1.01154D0,  0.68194D0,  0.44362D0,  0.33823D0,  0.27595D0,
53219      &     0.23401D0,  0.18011D0,  0.13377D0,  0.09255D0,  0.06957D0,
53220      &     0.04454D0,  0.03111D0,  0.02277D0,  0.01600D0,  0.01150D0,
53221      &     0.00839D0,  0.00616D0,  0.00453D0,  0.00333D0,  0.00245D0,
53222      &     0.00179D0,  0.00130D0,  0.00094D0,  0.00067D0,  0.00048D0,
53223      &     0.00035D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
53224      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53225      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53226       DATA (FMRS(1,7,I,29),I=1,49)/
53227      &    10.48807D0,  7.51842D0,  5.38590D0,  4.42859D0,  3.85291D0,
53228      &     3.45734D0,  2.46302D0,  1.74255D0,  1.41507D0,  1.21586D0,
53229      &     1.07451D0,  0.72111D0,  0.46688D0,  0.35494D0,  0.28897D0,
53230      &     0.24464D0,  0.18781D0,  0.13908D0,  0.09587D0,  0.07187D0,
53231      &     0.04579D0,  0.03185D0,  0.02323D0,  0.01626D0,  0.01165D0,
53232      &     0.00847D0,  0.00619D0,  0.00454D0,  0.00333D0,  0.00244D0,
53233      &     0.00178D0,  0.00129D0,  0.00093D0,  0.00066D0,  0.00047D0,
53234      &     0.00035D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
53235      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53236      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53237       DATA (FMRS(1,7,I,30),I=1,49)/
53238      &    11.39334D0,  8.13482D0,  5.80422D0,  4.76138D0,  4.13555D0,
53239      &     3.70617D0,  2.62967D0,  1.85288D0,  1.50103D0,  1.28747D0,
53240      &     1.13621D0,  0.75917D0,  0.48927D0,  0.37093D0,  0.30137D0,
53241      &     0.25473D0,  0.19506D0,  0.14404D0,  0.09894D0,  0.07396D0,
53242      &     0.04691D0,  0.03251D0,  0.02363D0,  0.01647D0,  0.01175D0,
53243      &     0.00851D0,  0.00621D0,  0.00454D0,  0.00332D0,  0.00243D0,
53244      &     0.00176D0,  0.00127D0,  0.00091D0,  0.00065D0,  0.00046D0,
53245      &     0.00034D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
53246      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53247      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53248       DATA (FMRS(1,7,I,31),I=1,49)/
53249      &    12.30020D0,  8.74942D0,  6.21933D0,  5.09070D0,  4.41468D0,
53250      &     3.95152D0,  2.79315D0,  1.96055D0,  1.58465D0,  1.35697D0,
53251      &     1.19598D0,  0.79580D0,  0.51068D0,  0.38615D0,  0.31314D0,
53252      &     0.26427D0,  0.20189D0,  0.14868D0,  0.10179D0,  0.07589D0,
53253      &     0.04793D0,  0.03309D0,  0.02397D0,  0.01665D0,  0.01184D0,
53254      &     0.00855D0,  0.00621D0,  0.00453D0,  0.00330D0,  0.00241D0,
53255      &     0.00174D0,  0.00126D0,  0.00090D0,  0.00064D0,  0.00046D0,
53256      &     0.00034D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
53257      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53258      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53259       DATA (FMRS(1,7,I,32),I=1,49)/
53260      &    13.17835D0,  9.34137D0,  6.61692D0,  5.40505D0,  4.68045D0,
53261      &     4.18467D0,  2.94753D0,  2.06155D0,  1.66276D0,  1.42169D0,
53262      &     1.25150D0,  0.82954D0,  0.53019D0,  0.39993D0,  0.32374D0,
53263      &     0.27283D0,  0.20796D0,  0.15278D0,  0.10427D0,  0.07755D0,
53264      &     0.04878D0,  0.03356D0,  0.02424D0,  0.01677D0,  0.01189D0,
53265      &     0.00856D0,  0.00621D0,  0.00451D0,  0.00328D0,  0.00239D0,
53266      &     0.00173D0,  0.00124D0,  0.00089D0,  0.00063D0,  0.00045D0,
53267      &     0.00033D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
53268      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53269      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53270       DATA (FMRS(1,7,I,33),I=1,49)/
53271      &    14.12059D0,  9.97430D0,  7.04054D0,  5.73929D0,  4.96264D0,
53272      &     4.43195D0,  3.11069D0,  2.16791D0,  1.74484D0,  1.48959D0,
53273      &     1.30967D0,  0.86476D0,  0.55049D0,  0.41422D0,  0.33471D0,
53274      &     0.28168D0,  0.21423D0,  0.15699D0,  0.10682D0,  0.07925D0,
53275      &     0.04965D0,  0.03404D0,  0.02451D0,  0.01690D0,  0.01194D0,
53276      &     0.00857D0,  0.00620D0,  0.00449D0,  0.00326D0,  0.00237D0,
53277      &     0.00171D0,  0.00123D0,  0.00088D0,  0.00062D0,  0.00044D0,
53278      &     0.00032D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
53279      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53280      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53281       DATA (FMRS(1,7,I,34),I=1,49)/
53282      &    15.05309D0, 10.59701D0,  7.45476D0,  6.06488D0,  5.23678D0,
53283      &     4.67164D0,  3.26773D0,  2.26948D0,  1.82284D0,  1.55389D0,
53284      &     1.36460D0,  0.89767D0,  0.56921D0,  0.42730D0,  0.34468D0,
53285      &     0.28967D0,  0.21983D0,  0.16070D0,  0.10902D0,  0.08069D0,
53286      &     0.05036D0,  0.03441D0,  0.02470D0,  0.01698D0,  0.01196D0,
53287      &     0.00856D0,  0.00617D0,  0.00446D0,  0.00323D0,  0.00234D0,
53288      &     0.00168D0,  0.00121D0,  0.00086D0,  0.00061D0,  0.00043D0,
53289      &     0.00032D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
53290      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53291      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53292       DATA (FMRS(1,7,I,35),I=1,49)/
53293      &    15.99294D0, 11.22254D0,  7.86947D0,  6.39022D0,  5.51032D0,
53294      &     4.91055D0,  3.42373D0,  2.37005D0,  1.89992D0,  1.61733D0,
53295      &     1.41872D0,  0.92998D0,  0.58753D0,  0.44006D0,  0.35440D0,
53296      &     0.29744D0,  0.22527D0,  0.16430D0,  0.11114D0,  0.08207D0,
53297      &     0.05103D0,  0.03476D0,  0.02489D0,  0.01705D0,  0.01198D0,
53298      &     0.00855D0,  0.00615D0,  0.00444D0,  0.00321D0,  0.00232D0,
53299      &     0.00166D0,  0.00119D0,  0.00085D0,  0.00060D0,  0.00042D0,
53300      &     0.00031D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
53301      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53302      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53303       DATA (FMRS(1,7,I,36),I=1,49)/
53304      &    16.90825D0, 11.82917D0,  8.26989D0,  6.70353D0,  5.77324D0,
53305      &     5.13985D0,  3.57272D0,  2.46560D0,  1.97292D0,  1.67727D0,
53306      &     1.46976D0,  0.96025D0,  0.60456D0,  0.45187D0,  0.36334D0,
53307      &     0.30458D0,  0.23023D0,  0.16756D0,  0.11304D0,  0.08330D0,
53308      &     0.05162D0,  0.03506D0,  0.02503D0,  0.01710D0,  0.01198D0,
53309      &     0.00853D0,  0.00612D0,  0.00440D0,  0.00318D0,  0.00229D0,
53310      &     0.00164D0,  0.00117D0,  0.00083D0,  0.00059D0,  0.00042D0,
53311      &     0.00031D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
53312      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53313      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53314       DATA (FMRS(1,7,I,37),I=1,49)/
53315      &    17.85379D0, 12.45318D0,  8.67996D0,  7.02354D0,  6.04126D0,
53316      &     5.37323D0,  3.72362D0,  2.56187D0,  2.04622D0,  1.73730D0,
53317      &     1.52078D0,  0.99029D0,  0.62133D0,  0.46343D0,  0.37206D0,
53318      &     0.31151D0,  0.23502D0,  0.17068D0,  0.11483D0,  0.08444D0,
53319      &     0.05214D0,  0.03531D0,  0.02515D0,  0.01713D0,  0.01196D0,
53320      &     0.00850D0,  0.00608D0,  0.00437D0,  0.00315D0,  0.00226D0,
53321      &     0.00162D0,  0.00115D0,  0.00082D0,  0.00058D0,  0.00041D0,
53322      &     0.00030D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
53323      &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
53324      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53325       DATA (FMRS(1,7,I,38),I=1,49)/
53326      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53327      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53328      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53329      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53330      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53331      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53332      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53333      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53334      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53335      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53336       DATA (FMRS(1,8,I, 1),I=1,49)/
53337      &     0.88043D0,  0.77333D0,  0.67888D0,  0.62888D0,  0.59555D0,
53338      &     0.57086D0,  0.50019D0,  0.43775D0,  0.40464D0,  0.38254D0,
53339      &     0.36610D0,  0.31885D0,  0.27689D0,  0.25464D0,  0.23989D0,
53340      &     0.22903D0,  0.21364D0,  0.19859D0,  0.18303D0,  0.17273D0,
53341      &     0.15826D0,  0.14656D0,  0.13527D0,  0.12062D0,  0.10522D0,
53342      &     0.08955D0,  0.07420D0,  0.05981D0,  0.04692D0,  0.03554D0,
53343      &     0.02630D0,  0.01878D0,  0.01298D0,  0.00870D0,  0.00554D0,
53344      &     0.00339D0,  0.00198D0,  0.00110D0,  0.00049D0,  0.00026D0,
53345      &     0.00012D0,  0.00002D0,  0.00002D0,  0.00000D0, -0.00001D0,
53346      &    -0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
53347       DATA (FMRS(1,8,I, 2),I=1,49)/
53348      &     0.89442D0,  0.78714D0,  0.69235D0,  0.64208D0,  0.60853D0,
53349      &     0.58367D0,  0.51236D0,  0.44919D0,  0.41561D0,  0.39314D0,
53350      &     0.37639D0,  0.32808D0,  0.28485D0,  0.26176D0,  0.24637D0,
53351      &     0.23501D0,  0.21882D0,  0.20291D0,  0.18634D0,  0.17532D0,
53352      &     0.15979D0,  0.14730D0,  0.13538D0,  0.12014D0,  0.10435D0,
53353      &     0.08847D0,  0.07306D0,  0.05873D0,  0.04595D0,  0.03477D0,
53354      &     0.02571D0,  0.01837D0,  0.01273D0,  0.00855D0,  0.00550D0,
53355      &     0.00340D0,  0.00204D0,  0.00117D0,  0.00055D0,  0.00031D0,
53356      &     0.00017D0,  0.00006D0,  0.00005D0,  0.00001D0,  0.00000D0,
53357      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53358       DATA (FMRS(1,8,I, 3),I=1,49)/
53359      &     0.93116D0,  0.82082D0,  0.72315D0,  0.67127D0,  0.63662D0,
53360      &     0.61092D0,  0.53708D0,  0.47148D0,  0.43647D0,  0.41299D0,
53361      &     0.39541D0,  0.34450D0,  0.29850D0,  0.27374D0,  0.25714D0,
53362      &     0.24483D0,  0.22722D0,  0.20981D0,  0.19154D0,  0.17933D0,
53363      &     0.16210D0,  0.14837D0,  0.13550D0,  0.11937D0,  0.10300D0,
53364      &     0.08681D0,  0.07133D0,  0.05711D0,  0.04449D0,  0.03362D0,
53365      &     0.02480D0,  0.01774D0,  0.01234D0,  0.00831D0,  0.00539D0,
53366      &     0.00338D0,  0.00208D0,  0.00122D0,  0.00062D0,  0.00038D0,
53367      &     0.00022D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
53368      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53369       DATA (FMRS(1,8,I, 4),I=1,49)/
53370      &     0.97222D0,  0.85703D0,  0.75505D0,  0.70088D0,  0.66470D0,
53371      &     0.63785D0,  0.56070D0,  0.49207D0,  0.45539D0,  0.43075D0,
53372      &     0.41225D0,  0.35857D0,  0.30984D0,  0.28350D0,  0.26581D0,
53373      &     0.25266D0,  0.23382D0,  0.21514D0,  0.19549D0,  0.18234D0,
53374      &     0.16379D0,  0.14912D0,  0.13552D0,  0.11873D0,  0.10198D0,
53375      &     0.08556D0,  0.07005D0,  0.05591D0,  0.04344D0,  0.03278D0,
53376      &     0.02413D0,  0.01727D0,  0.01201D0,  0.00813D0,  0.00530D0,
53377      &     0.00334D0,  0.00207D0,  0.00123D0,  0.00065D0,  0.00042D0,
53378      &     0.00025D0,  0.00012D0,  0.00009D0,  0.00002D0,  0.00002D0,
53379      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53380       DATA (FMRS(1,8,I, 5),I=1,49)/
53381      &     1.03488D0,  0.91080D0,  0.80113D0,  0.74294D0,  0.70410D0,
53382      &     0.67529D0,  0.59258D0,  0.51904D0,  0.47974D0,  0.45332D0,
53383      &     0.43343D0,  0.37573D0,  0.32325D0,  0.29486D0,  0.27577D0,
53384      &     0.26158D0,  0.24123D0,  0.22104D0,  0.19979D0,  0.18555D0,
53385      &     0.16552D0,  0.14984D0,  0.13548D0,  0.11801D0,  0.10084D0,
53386      &     0.08422D0,  0.06865D0,  0.05459D0,  0.04229D0,  0.03183D0,
53387      &     0.02342D0,  0.01674D0,  0.01163D0,  0.00790D0,  0.00517D0,
53388      &     0.00326D0,  0.00204D0,  0.00126D0,  0.00069D0,  0.00044D0,
53389      &     0.00027D0,  0.00014D0,  0.00010D0,  0.00004D0,  0.00001D0,
53390      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53391       DATA (FMRS(1,8,I, 6),I=1,49)/
53392      &     1.09976D0,  0.96588D0,  0.84779D0,  0.78524D0,  0.74353D0,
53393      &     0.71261D0,  0.62395D0,  0.54523D0,  0.50318D0,  0.47492D0,
53394      &     0.45362D0,  0.39183D0,  0.33563D0,  0.30525D0,  0.28482D0,
53395      &     0.26964D0,  0.24787D0,  0.22628D0,  0.20357D0,  0.18835D0,
53396      &     0.16700D0,  0.15043D0,  0.13540D0,  0.11734D0,  0.09983D0,
53397      &     0.08303D0,  0.06744D0,  0.05346D0,  0.04131D0,  0.03103D0,
53398      &     0.02280D0,  0.01628D0,  0.01131D0,  0.00768D0,  0.00506D0,
53399      &     0.00319D0,  0.00201D0,  0.00126D0,  0.00071D0,  0.00044D0,
53400      &     0.00028D0,  0.00015D0,  0.00010D0,  0.00005D0,  0.00001D0,
53401      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53402       DATA (FMRS(1,8,I, 7),I=1,49)/
53403      &     1.17764D0,  1.03108D0,  0.90223D0,  0.83415D0,  0.78882D0,
53404      &     0.75526D0,  0.65918D0,  0.57411D0,  0.52875D0,  0.49829D0,
53405      &     0.47532D0,  0.40880D0,  0.34842D0,  0.31585D0,  0.29397D0,
53406      &     0.27773D0,  0.25447D0,  0.23144D0,  0.20722D0,  0.19102D0,
53407      &     0.16837D0,  0.15091D0,  0.13525D0,  0.11665D0,  0.09880D0,
53408      &     0.08184D0,  0.06625D0,  0.05236D0,  0.04036D0,  0.03026D0,
53409      &     0.02219D0,  0.01583D0,  0.01099D0,  0.00745D0,  0.00494D0,
53410      &     0.00313D0,  0.00199D0,  0.00124D0,  0.00071D0,  0.00044D0,
53411      &     0.00028D0,  0.00014D0,  0.00011D0,  0.00005D0,  0.00001D0,
53412      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53413       DATA (FMRS(1,8,I, 8),I=1,49)/
53414      &     1.27508D0,  1.11188D0,  0.96899D0,  0.89374D0,  0.84374D0,
53415      &     0.80677D0,  0.70124D0,  0.60814D0,  0.55864D0,  0.52545D0,
53416      &     0.50042D0,  0.42815D0,  0.36279D0,  0.32765D0,  0.30409D0,
53417      &     0.28664D0,  0.26167D0,  0.23701D0,  0.21111D0,  0.19383D0,
53418      &     0.16977D0,  0.15136D0,  0.13503D0,  0.11586D0,  0.09768D0,
53419      &     0.08056D0,  0.06499D0,  0.05119D0,  0.03935D0,  0.02943D0,
53420      &     0.02154D0,  0.01534D0,  0.01065D0,  0.00723D0,  0.00480D0,
53421      &     0.00305D0,  0.00194D0,  0.00121D0,  0.00071D0,  0.00043D0,
53422      &     0.00029D0,  0.00014D0,  0.00011D0,  0.00005D0,  0.00001D0,
53423      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53424       DATA (FMRS(1,8,I, 9),I=1,49)/
53425      &     1.37316D0,  1.19249D0,  1.03498D0,  0.95232D0,  0.89751D0,
53426      &     0.85705D0,  0.74185D0,  0.64064D0,  0.58699D0,  0.55108D0,
53427      &     0.52402D0,  0.44610D0,  0.37594D0,  0.33836D0,  0.31323D0,
53428      &     0.29464D0,  0.26809D0,  0.24193D0,  0.21452D0,  0.19627D0,
53429      &     0.17094D0,  0.15171D0,  0.13480D0,  0.11515D0,  0.09667D0,
53430      &     0.07946D0,  0.06388D0,  0.05018D0,  0.03847D0,  0.02871D0,
53431      &     0.02099D0,  0.01493D0,  0.01036D0,  0.00705D0,  0.00466D0,
53432      &     0.00297D0,  0.00189D0,  0.00119D0,  0.00071D0,  0.00043D0,
53433      &     0.00029D0,  0.00015D0,  0.00010D0,  0.00005D0,  0.00002D0,
53434      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53435       DATA (FMRS(1,8,I,10),I=1,49)/
53436      &     1.48232D0,  1.28141D0,  1.10710D0,  1.01596D0,  0.95567D0,
53437      &     0.91125D0,  0.78516D0,  0.67489D0,  0.61664D0,  0.57774D0,
53438      &     0.54846D0,  0.46445D0,  0.38919D0,  0.34906D0,  0.32230D0,
53439      &     0.30254D0,  0.27439D0,  0.24670D0,  0.21778D0,  0.19857D0,
53440      &     0.17201D0,  0.15198D0,  0.13451D0,  0.11441D0,  0.09567D0,
53441      &     0.07837D0,  0.06280D0,  0.04920D0,  0.03762D0,  0.02802D0,
53442      &     0.02045D0,  0.01454D0,  0.01009D0,  0.00685D0,  0.00453D0,
53443      &     0.00289D0,  0.00185D0,  0.00117D0,  0.00069D0,  0.00044D0,
53444      &     0.00029D0,  0.00015D0,  0.00011D0,  0.00004D0,  0.00002D0,
53445      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53446       DATA (FMRS(1,8,I,11),I=1,49)/
53447      &     1.57825D0,  1.35904D0,  1.16962D0,  1.07091D0,  1.00575D0,
53448      &     0.95780D0,  0.82207D0,  0.70384D0,  0.64159D0,  0.60009D0,
53449      &     0.56890D0,  0.47964D0,  0.40007D0,  0.35779D0,  0.32966D0,
53450      &     0.30893D0,  0.27945D0,  0.25052D0,  0.22036D0,  0.20038D0,
53451      &     0.17283D0,  0.15216D0,  0.13426D0,  0.11380D0,  0.09487D0,
53452      &     0.07750D0,  0.06195D0,  0.04843D0,  0.03696D0,  0.02748D0,
53453      &     0.02002D0,  0.01423D0,  0.00988D0,  0.00669D0,  0.00443D0,
53454      &     0.00283D0,  0.00181D0,  0.00116D0,  0.00068D0,  0.00044D0,
53455      &     0.00028D0,  0.00016D0,  0.00011D0,  0.00004D0,  0.00001D0,
53456      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53457       DATA (FMRS(1,8,I,12),I=1,49)/
53458      &     1.81391D0,  1.54794D0,  1.32027D0,  1.20251D0,  1.12515D0,
53459      &     1.06843D0,  0.90882D0,  0.77111D0,  0.69913D0,  0.65138D0,
53460      &     0.61560D0,  0.51392D0,  0.42424D0,  0.37702D0,  0.34578D0,
53461      &     0.32285D0,  0.29039D0,  0.25868D0,  0.22580D0,  0.20412D0,
53462      &     0.17445D0,  0.15244D0,  0.13361D0,  0.11242D0,  0.09312D0,
53463      &     0.07561D0,  0.06012D0,  0.04679D0,  0.03556D0,  0.02636D0,
53464      &     0.01913D0,  0.01356D0,  0.00940D0,  0.00637D0,  0.00422D0,
53465      &     0.00270D0,  0.00172D0,  0.00112D0,  0.00066D0,  0.00042D0,
53466      &     0.00027D0,  0.00016D0,  0.00011D0,  0.00004D0,  0.00001D0,
53467      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53468       DATA (FMRS(1,8,I,13),I=1,49)/
53469      &     2.05224D0,  1.73683D0,  1.46916D0,  1.33169D0,  1.24177D0,
53470      &     1.17604D0,  0.99216D0,  0.83488D0,  0.75325D0,  0.69933D0,
53471      &     0.65905D0,  0.54532D0,  0.44603D0,  0.39419D0,  0.36006D0,
53472      &     0.33511D0,  0.29992D0,  0.26571D0,  0.23041D0,  0.20724D0,
53473      &     0.17571D0,  0.15255D0,  0.13296D0,  0.11116D0,  0.09157D0,
53474      &     0.07397D0,  0.05855D0,  0.04538D0,  0.03436D0,  0.02540D0,
53475      &     0.01839D0,  0.01299D0,  0.00900D0,  0.00610D0,  0.00403D0,
53476      &     0.00259D0,  0.00165D0,  0.00107D0,  0.00064D0,  0.00040D0,
53477      &     0.00027D0,  0.00015D0,  0.00011D0,  0.00004D0,  0.00001D0,
53478      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53479       DATA (FMRS(1,8,I,14),I=1,49)/
53480      &     2.36037D0,  1.97834D0,  1.65740D0,  1.49390D0,  1.38749D0,
53481      &     1.31001D0,  1.09465D0,  0.91231D0,  0.81846D0,  0.75678D0,
53482      &     0.71089D0,  0.58224D0,  0.47125D0,  0.41385D0,  0.37630D0,
53483      &     0.34896D0,  0.31058D0,  0.27348D0,  0.23541D0,  0.21054D0,
53484      &     0.17694D0,  0.15252D0,  0.13212D0,  0.10968D0,  0.08980D0,
53485      &     0.07213D0,  0.05680D0,  0.04381D0,  0.03304D0,  0.02434D0,
53486      &     0.01758D0,  0.01241D0,  0.00857D0,  0.00582D0,  0.00382D0,
53487      &     0.00247D0,  0.00159D0,  0.00103D0,  0.00060D0,  0.00038D0,
53488      &     0.00026D0,  0.00014D0,  0.00011D0,  0.00004D0,  0.00001D0,
53489      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53490       DATA (FMRS(1,8,I,15),I=1,49)/
53491      &     2.73224D0,  2.26638D0,  1.87922D0,  1.68367D0,  1.55710D0,
53492      &     1.46530D0,  1.21194D0,  0.99975D0,  0.89148D0,  0.82073D0,
53493      &     0.76831D0,  0.62250D0,  0.49828D0,  0.43470D0,  0.39338D0,
53494      &     0.36342D0,  0.32158D0,  0.28138D0,  0.24036D0,  0.21374D0,
53495      &     0.17800D0,  0.15230D0,  0.13108D0,  0.10804D0,  0.08789D0,
53496      &     0.07017D0,  0.05499D0,  0.04222D0,  0.03170D0,  0.02325D0,
53497      &     0.01673D0,  0.01178D0,  0.00810D0,  0.00551D0,  0.00361D0,
53498      &     0.00232D0,  0.00150D0,  0.00098D0,  0.00058D0,  0.00036D0,
53499      &     0.00025D0,  0.00014D0,  0.00010D0,  0.00004D0,  0.00001D0,
53500      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53501       DATA (FMRS(1,8,I,16),I=1,49)/
53502      &     3.11511D0,  2.55975D0,  2.10267D0,  1.87361D0,  1.72607D0,
53503      &     1.61945D0,  1.32704D0,  1.08455D0,  0.96180D0,  0.88200D0,
53504      &     0.82308D0,  0.66038D0,  0.52333D0,  0.45384D0,  0.40893D0,
53505      &     0.37652D0,  0.33144D0,  0.28836D0,  0.24465D0,  0.21643D0,
53506      &     0.17877D0,  0.15196D0,  0.13002D0,  0.10649D0,  0.08613D0,
53507      &     0.06841D0,  0.05335D0,  0.04078D0,  0.03051D0,  0.02230D0,
53508      &     0.01601D0,  0.01123D0,  0.00772D0,  0.00522D0,  0.00344D0,
53509      &     0.00221D0,  0.00143D0,  0.00094D0,  0.00056D0,  0.00035D0,
53510      &     0.00023D0,  0.00014D0,  0.00009D0,  0.00004D0,  0.00001D0,
53511      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53512       DATA (FMRS(1,8,I,17),I=1,49)/
53513      &     3.54920D0,  2.88904D0,  2.35096D0,  2.08340D0,  1.91191D0,
53514      &     1.78843D0,  1.45191D0,  1.17555D0,  1.03678D0,  0.94701D0,
53515      &     0.88099D0,  0.69993D0,  0.54914D0,  0.47339D0,  0.42472D0,
53516      &     0.38973D0,  0.34130D0,  0.29525D0,  0.24881D0,  0.21897D0,
53517      &     0.17941D0,  0.15149D0,  0.12887D0,  0.10488D0,  0.08433D0,
53518      &     0.06664D0,  0.05172D0,  0.03936D0,  0.02933D0,  0.02138D0,
53519      &     0.01531D0,  0.01070D0,  0.00735D0,  0.00494D0,  0.00327D0,
53520      &     0.00210D0,  0.00135D0,  0.00089D0,  0.00053D0,  0.00034D0,
53521      &     0.00022D0,  0.00013D0,  0.00009D0,  0.00004D0,  0.00001D0,
53522      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53523       DATA (FMRS(1,8,I,18),I=1,49)/
53524      &     3.94722D0,  3.18825D0,  2.57451D0,  2.27128D0,  2.07769D0,
53525      &     1.93872D0,  1.56191D0,  1.25495D0,  1.10181D0,  1.00316D0,
53526      &     0.93081D0,  0.73357D0,  0.57081D0,  0.48966D0,  0.43777D0,
53527      &     0.40060D0,  0.34934D0,  0.30080D0,  0.25209D0,  0.22090D0,
53528      &     0.17980D0,  0.15100D0,  0.12785D0,  0.10349D0,  0.08283D0,
53529      &     0.06518D0,  0.05037D0,  0.03822D0,  0.02839D0,  0.02063D0,
53530      &     0.01472D0,  0.01026D0,  0.00705D0,  0.00475D0,  0.00313D0,
53531      &     0.00200D0,  0.00129D0,  0.00084D0,  0.00049D0,  0.00033D0,
53532      &     0.00020D0,  0.00013D0,  0.00009D0,  0.00003D0,  0.00001D0,
53533      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53534       DATA (FMRS(1,8,I,19),I=1,49)/
53535      &     4.47623D0,  3.58243D0,  2.86642D0,  2.51532D0,  2.29224D0,
53536      &     2.13264D0,  1.70256D0,  1.35552D0,  1.18371D0,  1.07357D0,
53537      &     0.99309D0,  0.77516D0,  0.59726D0,  0.50937D0,  0.45348D0,
53538      &     0.41360D0,  0.35886D0,  0.30730D0,  0.25582D0,  0.22304D0,
53539      &     0.18010D0,  0.15028D0,  0.12653D0,  0.10177D0,  0.08099D0,
53540      &     0.06341D0,  0.04879D0,  0.03686D0,  0.02728D0,  0.01973D0,
53541      &     0.01404D0,  0.00977D0,  0.00668D0,  0.00449D0,  0.00295D0,
53542      &     0.00189D0,  0.00122D0,  0.00079D0,  0.00046D0,  0.00031D0,
53543      &     0.00019D0,  0.00011D0,  0.00008D0,  0.00003D0,  0.00001D0,
53544      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53545       DATA (FMRS(1,8,I,20),I=1,49)/
53546      &     4.99213D0,  3.96349D0,  3.14614D0,  2.74797D0,  2.49601D0,
53547      &     2.31631D0,  1.83458D0,  1.44905D0,  1.25946D0,  1.13844D0,
53548      &     1.05027D0,  0.81294D0,  0.62102D0,  0.52694D0,  0.46740D0,
53549      &     0.42508D0,  0.36719D0,  0.31292D0,  0.25900D0,  0.22482D0,
53550      &     0.18028D0,  0.14958D0,  0.12531D0,  0.10024D0,  0.07938D0,
53551      &     0.06186D0,  0.04742D0,  0.03568D0,  0.02633D0,  0.01896D0,
53552      &     0.01347D0,  0.00937D0,  0.00636D0,  0.00427D0,  0.00280D0,
53553      &     0.00180D0,  0.00116D0,  0.00076D0,  0.00045D0,  0.00029D0,
53554      &     0.00019D0,  0.00009D0,  0.00007D0,  0.00003D0,  0.00001D0,
53555      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53556       DATA (FMRS(1,8,I,21),I=1,49)/
53557      &     5.49949D0,  4.33534D0,  3.41695D0,  2.97216D0,  2.69173D0,
53558      &     2.49225D0,  1.96002D0,  1.53717D0,  1.33047D0,  1.19901D0,
53559      &     1.10350D0,  0.84773D0,  0.64263D0,  0.54279D0,  0.47988D0,
53560      &     0.43530D0,  0.37453D0,  0.31778D0,  0.26166D0,  0.22622D0,
53561      &     0.18027D0,  0.14882D0,  0.12412D0,  0.09878D0,  0.07788D0,
53562      &     0.06045D0,  0.04618D0,  0.03463D0,  0.02546D0,  0.01831D0,
53563      &     0.01296D0,  0.00899D0,  0.00611D0,  0.00409D0,  0.00268D0,
53564      &     0.00172D0,  0.00111D0,  0.00073D0,  0.00045D0,  0.00028D0,
53565      &     0.00018D0,  0.00010D0,  0.00007D0,  0.00003D0,  0.00001D0,
53566      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53567       DATA (FMRS(1,8,I,22),I=1,49)/
53568      &     6.19994D0,  4.84455D0,  3.78480D0,  3.27524D0,  2.95541D0,
53569      &     2.72867D0,  2.12718D0,  1.65361D0,  1.42381D0,  1.27834D0,
53570      &     1.17300D0,  0.89272D0,  0.67027D0,  0.56291D0,  0.49563D0,
53571      &     0.44814D0,  0.38367D0,  0.32378D0,  0.26487D0,  0.22786D0,
53572      &     0.18016D0,  0.14778D0,  0.12256D0,  0.09693D0,  0.07601D0,
53573      &     0.05870D0,  0.04463D0,  0.03333D0,  0.02440D0,  0.01750D0,
53574      &     0.01234D0,  0.00854D0,  0.00580D0,  0.00388D0,  0.00253D0,
53575      &     0.00162D0,  0.00104D0,  0.00069D0,  0.00042D0,  0.00026D0,
53576      &     0.00018D0,  0.00010D0,  0.00006D0,  0.00003D0,  0.00001D0,
53577      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53578       DATA (FMRS(1,8,I,23),I=1,49)/
53579      &     6.91850D0,  5.36248D0,  4.15576D0,  3.57933D0,  3.21903D0,
53580      &     2.96436D0,  2.29236D0,  1.76765D0,  1.51472D0,  1.35530D0,
53581      &     1.24020D0,  0.93576D0,  0.69640D0,  0.58179D0,  0.51031D0,
53582      &     0.46004D0,  0.39207D0,  0.32922D0,  0.26771D0,  0.22925D0,
53583      &     0.17994D0,  0.14672D0,  0.12105D0,  0.09521D0,  0.07427D0,
53584      &     0.05708D0,  0.04320D0,  0.03213D0,  0.02345D0,  0.01676D0,
53585      &     0.01179D0,  0.00813D0,  0.00551D0,  0.00368D0,  0.00240D0,
53586      &     0.00152D0,  0.00099D0,  0.00064D0,  0.00039D0,  0.00024D0,
53587      &     0.00017D0,  0.00009D0,  0.00006D0,  0.00003D0,  0.00001D0,
53588      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53589       DATA (FMRS(1,8,I,24),I=1,49)/
53590      &     7.63491D0,  5.87479D0,  4.51976D0,  3.87632D0,  3.47562D0,
53591      &     3.19317D0,  2.45140D0,  1.87649D0,  1.60104D0,  1.42808D0,
53592      &     1.30355D0,  0.97589D0,  0.72045D0,  0.59900D0,  0.52360D0,
53593      &     0.47074D0,  0.39952D0,  0.33394D0,  0.27005D0,  0.23029D0,
53594      &     0.17956D0,  0.14561D0,  0.11956D0,  0.09355D0,  0.07262D0,
53595      &     0.05557D0,  0.04190D0,  0.03105D0,  0.02258D0,  0.01609D0,
53596      &     0.01128D0,  0.00777D0,  0.00525D0,  0.00350D0,  0.00227D0,
53597      &     0.00145D0,  0.00095D0,  0.00060D0,  0.00036D0,  0.00023D0,
53598      &     0.00015D0,  0.00008D0,  0.00006D0,  0.00003D0,  0.00001D0,
53599      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53600       DATA (FMRS(1,8,I,25),I=1,49)/
53601      &     8.40875D0,  6.42416D0,  4.90727D0,  4.19114D0,  3.74679D0,
53602      &     3.43441D0,  2.61784D0,  1.98954D0,  1.69029D0,  1.50308D0,
53603      &     1.36865D0,  1.01677D0,  0.74472D0,  0.61626D0,  0.53686D0,
53604      &     0.48138D0,  0.40687D0,  0.33856D0,  0.27230D0,  0.23124D0,
53605      &     0.17912D0,  0.14448D0,  0.11807D0,  0.09190D0,  0.07100D0,
53606      &     0.05410D0,  0.04063D0,  0.03001D0,  0.02174D0,  0.01545D0,
53607      &     0.01080D0,  0.00742D0,  0.00500D0,  0.00332D0,  0.00215D0,
53608      &     0.00138D0,  0.00091D0,  0.00056D0,  0.00034D0,  0.00022D0,
53609      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
53610      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53611       DATA (FMRS(1,8,I,26),I=1,49)/
53612      &     9.20959D0,  6.98865D0,  5.30257D0,  4.51092D0,  4.02140D0,
53613      &     3.67813D0,  2.78472D0,  2.10201D0,  1.77866D0,  1.57708D0,
53614      &     1.43269D0,  1.05659D0,  0.76808D0,  0.63273D0,  0.54942D0,
53615      &     0.49139D0,  0.41371D0,  0.34277D0,  0.27426D0,  0.23197D0,
53616      &     0.17855D0,  0.14327D0,  0.11656D0,  0.09025D0,  0.06944D0,
53617      &     0.05268D0,  0.03941D0,  0.02899D0,  0.02094D0,  0.01485D0,
53618      &     0.01035D0,  0.00708D0,  0.00476D0,  0.00316D0,  0.00205D0,
53619      &     0.00131D0,  0.00085D0,  0.00054D0,  0.00031D0,  0.00021D0,
53620      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
53621      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53622       DATA (FMRS(1,8,I,27),I=1,49)/
53623      &    10.01660D0,  7.55374D0,  5.69567D0,  4.82767D0,  4.29265D0,
53624      &     3.91834D0,  2.94808D0,  2.21134D0,  1.86419D0,  1.64848D0,
53625      &     1.49433D0,  1.09459D0,  0.79015D0,  0.64820D0,  0.56116D0,
53626      &     0.50070D0,  0.42001D0,  0.34660D0,  0.27598D0,  0.23256D0,
53627      &     0.17794D0,  0.14210D0,  0.11511D0,  0.08871D0,  0.06797D0,
53628      &     0.05137D0,  0.03829D0,  0.02806D0,  0.02022D0,  0.01430D0,
53629      &     0.00994D0,  0.00679D0,  0.00455D0,  0.00301D0,  0.00196D0,
53630      &     0.00124D0,  0.00081D0,  0.00052D0,  0.00030D0,  0.00020D0,
53631      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
53632      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53633       DATA (FMRS(1,8,I,28),I=1,49)/
53634      &    10.81622D0,  8.11020D0,  6.08037D0,  5.13653D0,  4.55643D0,
53635      &     4.15146D0,  3.10560D0,  2.31605D0,  1.94577D0,  1.71637D0,
53636      &     1.55278D0,  1.13032D0,  0.81070D0,  0.66250D0,  0.57195D0,
53637      &     0.50921D0,  0.42571D0,  0.35000D0,  0.27744D0,  0.23299D0,
53638      &     0.17730D0,  0.14094D0,  0.11373D0,  0.08726D0,  0.06658D0,
53639      &     0.05015D0,  0.03725D0,  0.02723D0,  0.01957D0,  0.01380D0,
53640      &     0.00957D0,  0.00653D0,  0.00437D0,  0.00288D0,  0.00188D0,
53641      &     0.00119D0,  0.00077D0,  0.00050D0,  0.00029D0,  0.00019D0,
53642      &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00001D0,
53643      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53644       DATA (FMRS(1,8,I,29),I=1,49)/
53645      &    11.66230D0,  8.69558D0,  6.48269D0,  5.45841D0,  4.83067D0,
53646      &     4.39335D0,  3.26805D0,  2.42336D0,  2.02906D0,  1.78549D0,
53647      &     1.61215D0,  1.16634D0,  0.83123D0,  0.67669D0,  0.58260D0,
53648      &     0.51757D0,  0.43126D0,  0.35327D0,  0.27879D0,  0.23332D0,
53649      &     0.17659D0,  0.13975D0,  0.11233D0,  0.08581D0,  0.06521D0,
53650      &     0.04895D0,  0.03623D0,  0.02642D0,  0.01893D0,  0.01332D0,
53651      &     0.00922D0,  0.00628D0,  0.00420D0,  0.00276D0,  0.00179D0,
53652      &     0.00113D0,  0.00073D0,  0.00048D0,  0.00028D0,  0.00018D0,
53653      &     0.00012D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00001D0,
53654      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53655       DATA (FMRS(1,8,I,30),I=1,49)/
53656      &    12.53147D0,  9.29349D0,  6.89124D0,  5.78416D0,  5.10752D0,
53657      &     4.63707D0,  3.43073D0,  2.53015D0,  2.11162D0,  1.85381D0,
53658      &     1.67070D0,  1.20157D0,  0.85112D0,  0.69035D0,  0.59278D0,
53659      &     0.52552D0,  0.43648D0,  0.35628D0,  0.27996D0,  0.23352D0,
53660      &     0.17581D0,  0.13853D0,  0.11093D0,  0.08439D0,  0.06389D0,
53661      &     0.04778D0,  0.03525D0,  0.02563D0,  0.01832D0,  0.01286D0,
53662      &     0.00888D0,  0.00603D0,  0.00403D0,  0.00265D0,  0.00171D0,
53663      &     0.00109D0,  0.00070D0,  0.00046D0,  0.00026D0,  0.00017D0,
53664      &     0.00011D0,  0.00006D0,  0.00004D0,  0.00001D0,  0.00000D0,
53665      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53666       DATA (FMRS(1,8,I,31),I=1,49)/
53667      &    13.39986D0,  9.88770D0,  7.29509D0,  6.10513D0,  5.37969D0,
53668      &     4.87627D0,  3.58951D0,  2.63377D0,  2.19145D0,  1.91971D0,
53669      &     1.72706D0,  1.23525D0,  0.86997D0,  0.70322D0,  0.60234D0,
53670      &     0.53296D0,  0.44131D0,  0.35903D0,  0.28099D0,  0.23364D0,
53671      &     0.17503D0,  0.13736D0,  0.10960D0,  0.08305D0,  0.06264D0,
53672      &     0.04669D0,  0.03435D0,  0.02491D0,  0.01775D0,  0.01244D0,
53673      &     0.00857D0,  0.00581D0,  0.00387D0,  0.00255D0,  0.00164D0,
53674      &     0.00105D0,  0.00067D0,  0.00044D0,  0.00025D0,  0.00016D0,
53675      &     0.00011D0,  0.00006D0,  0.00004D0,  0.00002D0,  0.00000D0,
53676      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53677       DATA (FMRS(1,8,I,32),I=1,49)/
53678      &    14.24690D0, 10.46430D0,  7.68491D0,  6.41400D0,  5.64102D0,
53679      &     5.10551D0,  3.74084D0,  2.73196D0,  2.26682D0,  1.98174D0,
53680      &     1.77998D0,  1.26662D0,  0.88736D0,  0.71501D0,  0.61103D0,
53681      &     0.53966D0,  0.44562D0,  0.36142D0,  0.28180D0,  0.23363D0,
53682      &     0.17423D0,  0.13620D0,  0.10832D0,  0.08177D0,  0.06147D0,
53683      &     0.04567D0,  0.03352D0,  0.02425D0,  0.01724D0,  0.01204D0,
53684      &     0.00828D0,  0.00559D0,  0.00373D0,  0.00245D0,  0.00158D0,
53685      &     0.00099D0,  0.00065D0,  0.00042D0,  0.00024D0,  0.00015D0,
53686      &     0.00010D0,  0.00006D0,  0.00004D0,  0.00002D0,  0.00000D0,
53687      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53688       DATA (FMRS(1,8,I,33),I=1,49)/
53689      &    15.14936D0, 11.07583D0,  8.09647D0,  6.73922D0,  5.91564D0,
53690      &     5.34608D0,  3.89891D0,  2.83403D0,  2.34496D0,  2.04593D0,
53691      &     1.83464D0,  1.29886D0,  0.90513D0,  0.72701D0,  0.61986D0,
53692      &     0.54647D0,  0.44998D0,  0.36383D0,  0.28262D0,  0.23362D0,
53693      &     0.17343D0,  0.13505D0,  0.10704D0,  0.08050D0,  0.06032D0,
53694      &     0.04468D0,  0.03270D0,  0.02360D0,  0.01675D0,  0.01165D0,
53695      &     0.00800D0,  0.00538D0,  0.00360D0,  0.00236D0,  0.00153D0,
53696      &     0.00094D0,  0.00062D0,  0.00040D0,  0.00024D0,  0.00014D0,
53697      &     0.00010D0,  0.00005D0,  0.00004D0,  0.00002D0,  0.00000D0,
53698      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53699       DATA (FMRS(1,8,I,34),I=1,49)/
53700      &    16.05264D0, 11.68476D0,  8.50413D0,  7.06033D0,  6.18619D0,
53701      &     5.58264D0,  4.05344D0,  2.93321D0,  2.42057D0,  2.10785D0,
53702      &     1.88726D0,  1.32960D0,  0.92187D0,  0.73821D0,  0.62802D0,
53703      &     0.55270D0,  0.45389D0,  0.36590D0,  0.28320D0,  0.23345D0,
53704      &     0.17251D0,  0.13385D0,  0.10575D0,  0.07924D0,  0.05918D0,
53705      &     0.04371D0,  0.03189D0,  0.02297D0,  0.01625D0,  0.01129D0,
53706      &     0.00773D0,  0.00520D0,  0.00346D0,  0.00227D0,  0.00146D0,
53707      &     0.00090D0,  0.00059D0,  0.00038D0,  0.00022D0,  0.00014D0,
53708      &     0.00009D0,  0.00005D0,  0.00004D0,  0.00001D0,  0.00000D0,
53709      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53710       DATA (FMRS(1,8,I,35),I=1,49)/
53711      &    16.95831D0, 12.29275D0,  8.90942D0,  7.37879D0,  6.45402D0,
53712      &     5.81651D0,  4.20556D0,  3.03041D0,  2.49449D0,  2.16827D0,
53713      &     1.93852D0,  1.35941D0,  0.93802D0,  0.74899D0,  0.63586D0,
53714      &     0.55868D0,  0.45763D0,  0.36787D0,  0.28375D0,  0.23328D0,
53715      &     0.17165D0,  0.13272D0,  0.10453D0,  0.07807D0,  0.05811D0,
53716      &     0.04281D0,  0.03114D0,  0.02238D0,  0.01579D0,  0.01096D0,
53717      &     0.00748D0,  0.00503D0,  0.00334D0,  0.00218D0,  0.00141D0,
53718      &     0.00087D0,  0.00056D0,  0.00036D0,  0.00021D0,  0.00013D0,
53719      &     0.00009D0,  0.00005D0,  0.00004D0,  0.00001D0,  0.00000D0,
53720      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53721       DATA (FMRS(1,8,I,36),I=1,49)/
53722      &    17.84218D0, 12.88352D0,  9.30151D0,  7.68607D0,  6.71197D0,
53723      &     6.04141D0,  4.35117D0,  3.12299D0,  2.56467D0,  2.22550D0,
53724      &     1.98697D0,  1.38741D0,  0.95307D0,  0.75895D0,  0.64306D0,
53725      &     0.56414D0,  0.46100D0,  0.36960D0,  0.28418D0,  0.23305D0,
53726      &     0.17079D0,  0.13162D0,  0.10337D0,  0.07695D0,  0.05711D0,
53727      &     0.04196D0,  0.03045D0,  0.02184D0,  0.01537D0,  0.01065D0,
53728      &     0.00725D0,  0.00488D0,  0.00323D0,  0.00211D0,  0.00135D0,
53729      &     0.00084D0,  0.00054D0,  0.00035D0,  0.00020D0,  0.00012D0,
53730      &     0.00009D0,  0.00005D0,  0.00003D0,  0.00001D0,  0.00000D0,
53731      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53732       DATA (FMRS(1,8,I,37),I=1,49)/
53733      &    18.75837D0, 13.49331D0,  9.70449D0,  8.00107D0,  6.97591D0,
53734      &     6.27121D0,  4.49926D0,  3.21668D0,  2.63548D0,  2.28312D0,
53735      &     2.03566D0,  1.41534D0,  0.96795D0,  0.76874D0,  0.65009D0,
53736      &     0.56943D0,  0.46423D0,  0.37122D0,  0.28450D0,  0.23274D0,
53737      &     0.16989D0,  0.13050D0,  0.10219D0,  0.07583D0,  0.05612D0,
53738      &     0.04112D0,  0.02978D0,  0.02129D0,  0.01496D0,  0.01035D0,
53739      &     0.00703D0,  0.00473D0,  0.00312D0,  0.00203D0,  0.00130D0,
53740      &     0.00081D0,  0.00052D0,  0.00034D0,  0.00019D0,  0.00012D0,
53741      &     0.00008D0,  0.00005D0,  0.00003D0,  0.00001D0,  0.00000D0,
53742      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53743       DATA (FMRS(1,8,I,38),I=1,49)/
53744      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53745      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53746      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53747      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53748      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53749      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53750      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53751      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53752      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
53753      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
53754       DATA (FMRS(2,1,I, 1),I=1,49)/
53755      &     0.01616D0,  0.01968D0,  0.02397D0,  0.02690D0,  0.02921D0,
53756      &     0.03113D0,  0.03797D0,  0.04639D0,  0.05222D0,  0.05685D0,
53757      &     0.06076D0,  0.07508D0,  0.09409D0,  0.10852D0,  0.12095D0,
53758      &     0.13220D0,  0.15265D0,  0.18041D0,  0.22265D0,  0.26180D0,
53759      &     0.33338D0,  0.39710D0,  0.45318D0,  0.51262D0,  0.56037D0,
53760      &     0.59685D0,  0.62256D0,  0.63820D0,  0.64458D0,  0.64218D0,
53761      &     0.63256D0,  0.61605D0,  0.59381D0,  0.56668D0,  0.53544D0,
53762      &     0.50113D0,  0.46441D0,  0.42608D0,  0.38703D0,  0.34764D0,
53763      &     0.30873D0,  0.27101D0,  0.23457D0,  0.16829D0,  0.11224D0,
53764      &     0.06802D0,  0.03588D0,  0.00449D0,  0.00000D0/
53765       DATA (FMRS(2,1,I, 2),I=1,49)/
53766      &     0.01632D0,  0.01989D0,  0.02423D0,  0.02721D0,  0.02954D0,
53767      &     0.03149D0,  0.03843D0,  0.04698D0,  0.05290D0,  0.05761D0,
53768      &     0.06159D0,  0.07621D0,  0.09566D0,  0.11046D0,  0.12320D0,
53769      &     0.13473D0,  0.15566D0,  0.18401D0,  0.22694D0,  0.26649D0,
53770      &     0.33826D0,  0.40154D0,  0.45671D0,  0.51456D0,  0.56041D0,
53771      &     0.59481D0,  0.61838D0,  0.63191D0,  0.63628D0,  0.63211D0,
53772      &     0.62085D0,  0.60298D0,  0.57964D0,  0.55165D0,  0.51988D0,
53773      &     0.48526D0,  0.44851D0,  0.41042D0,  0.37182D0,  0.33308D0,
53774      &     0.29500D0,  0.25823D0,  0.22287D0,  0.15893D0,  0.10532D0,
53775      &     0.06336D0,  0.03315D0,  0.00405D0,  0.00000D0/
53776       DATA (FMRS(2,1,I, 3),I=1,49)/
53777      &     0.01657D0,  0.02020D0,  0.02463D0,  0.02767D0,  0.03005D0,
53778      &     0.03204D0,  0.03912D0,  0.04786D0,  0.05393D0,  0.05876D0,
53779      &     0.06285D0,  0.07791D0,  0.09803D0,  0.11338D0,  0.12658D0,
53780      &     0.13853D0,  0.16018D0,  0.18937D0,  0.23326D0,  0.27335D0,
53781      &     0.34527D0,  0.40778D0,  0.46152D0,  0.51696D0,  0.55995D0,
53782      &     0.59126D0,  0.61170D0,  0.62221D0,  0.62369D0,  0.61697D0,
53783      &     0.60343D0,  0.58371D0,  0.55889D0,  0.52978D0,  0.49735D0,
53784      &     0.46237D0,  0.42568D0,  0.38804D0,  0.35014D0,  0.31246D0,
53785      &     0.27562D0,  0.24027D0,  0.20650D0,  0.14595D0,  0.09580D0,
53786      &     0.05701D0,  0.02946D0,  0.00347D0,  0.00000D0/
53787       DATA (FMRS(2,1,I, 4),I=1,49)/
53788      &     0.01676D0,  0.02044D0,  0.02493D0,  0.02801D0,  0.03042D0,
53789      &     0.03244D0,  0.03964D0,  0.04852D0,  0.05470D0,  0.05962D0,
53790      &     0.06379D0,  0.07918D0,  0.09980D0,  0.11554D0,  0.12909D0,
53791      &     0.14134D0,  0.16349D0,  0.19329D0,  0.23784D0,  0.27828D0,
53792      &     0.35023D0,  0.41207D0,  0.46471D0,  0.51833D0,  0.55923D0,
53793      &     0.58830D0,  0.60648D0,  0.61486D0,  0.61433D0,  0.60584D0,
53794      &     0.59072D0,  0.56980D0,  0.54398D0,  0.51418D0,  0.48131D0,
53795      &     0.44619D0,  0.40966D0,  0.37236D0,  0.33505D0,  0.29814D0,
53796      &     0.26220D0,  0.22791D0,  0.19528D0,  0.13713D0,  0.08936D0,
53797      &     0.05277D0,  0.02703D0,  0.00310D0,  0.00000D0/
53798       DATA (FMRS(2,1,I, 5),I=1,49)/
53799      &     0.01695D0,  0.02068D0,  0.02524D0,  0.02837D0,  0.03082D0,
53800      &     0.03287D0,  0.04018D0,  0.04922D0,  0.05552D0,  0.06053D0,
53801      &     0.06480D0,  0.08053D0,  0.10168D0,  0.11784D0,  0.13174D0,
53802      &     0.14430D0,  0.16698D0,  0.19737D0,  0.24257D0,  0.28331D0,
53803      &     0.35517D0,  0.41625D0,  0.46767D0,  0.51932D0,  0.55801D0,
53804      &     0.58472D0,  0.60061D0,  0.60677D0,  0.60420D0,  0.59394D0,
53805      &     0.57732D0,  0.55511D0,  0.52831D0,  0.49795D0,  0.46473D0,
53806      &     0.42958D0,  0.39324D0,  0.35636D0,  0.31976D0,  0.28363D0,
53807      &     0.24869D0,  0.21549D0,  0.18405D0,  0.12838D0,  0.08307D0,
53808      &     0.04866D0,  0.02468D0,  0.00276D0,  0.00000D0/
53809       DATA (FMRS(2,1,I, 6),I=1,49)/
53810      &     0.01712D0,  0.02090D0,  0.02552D0,  0.02868D0,  0.03117D0,
53811      &     0.03325D0,  0.04066D0,  0.04984D0,  0.05623D0,  0.06133D0,
53812      &     0.06568D0,  0.08172D0,  0.10333D0,  0.11984D0,  0.13405D0,
53813      &     0.14688D0,  0.17001D0,  0.20090D0,  0.24663D0,  0.28761D0,
53814      &     0.35934D0,  0.41972D0,  0.47004D0,  0.51998D0,  0.55675D0,
53815      &     0.58145D0,  0.59540D0,  0.59970D0,  0.59545D0,  0.58373D0,
53816      &     0.56587D0,  0.54263D0,  0.51509D0,  0.48426D0,  0.45082D0,
53817      &     0.41570D0,  0.37956D0,  0.34309D0,  0.30710D0,  0.27167D0,
53818      &     0.23758D0,  0.20532D0,  0.17488D0,  0.12129D0,  0.07799D0,
53819      &     0.04537D0,  0.02283D0,  0.00249D0,  0.00000D0/
53820       DATA (FMRS(2,1,I, 7),I=1,49)/
53821      &     0.01728D0,  0.02111D0,  0.02578D0,  0.02899D0,  0.03151D0,
53822      &     0.03361D0,  0.04113D0,  0.05044D0,  0.05693D0,  0.06211D0,
53823      &     0.06653D0,  0.08287D0,  0.10492D0,  0.12178D0,  0.13628D0,
53824      &     0.14936D0,  0.17290D0,  0.20425D0,  0.25045D0,  0.29164D0,
53825      &     0.36316D0,  0.42280D0,  0.47203D0,  0.52030D0,  0.55522D0,
53826      &     0.57804D0,  0.59016D0,  0.59271D0,  0.58692D0,  0.57390D0,
53827      &     0.55488D0,  0.53075D0,  0.50265D0,  0.47135D0,  0.43776D0,
53828      &     0.40267D0,  0.36679D0,  0.33078D0,  0.29535D0,  0.26064D0,
53829      &     0.22735D0,  0.19600D0,  0.16649D0,  0.11484D0,  0.07339D0,
53830      &     0.04241D0,  0.02117D0,  0.00226D0,  0.00000D0/
53831       DATA (FMRS(2,1,I, 8),I=1,49)/
53832      &     0.01745D0,  0.02133D0,  0.02606D0,  0.02931D0,  0.03187D0,
53833      &     0.03400D0,  0.04163D0,  0.05108D0,  0.05768D0,  0.06295D0,
53834      &     0.06745D0,  0.08411D0,  0.10662D0,  0.12385D0,  0.13865D0,
53835      &     0.15200D0,  0.17596D0,  0.20780D0,  0.25445D0,  0.29582D0,
53836      &     0.36707D0,  0.42589D0,  0.47392D0,  0.52041D0,  0.55338D0,
53837      &     0.57422D0,  0.58442D0,  0.58519D0,  0.57783D0,  0.56344D0,
53838      &     0.54329D0,  0.51831D0,  0.48960D0,  0.45793D0,  0.42423D0,
53839      &     0.38922D0,  0.35366D0,  0.31814D0,  0.28333D0,  0.24940D0,
53840      &     0.21696D0,  0.18656D0,  0.15803D0,  0.10837D0,  0.06882D0,
53841      &     0.03949D0,  0.01956D0,  0.00204D0,  0.00000D0/
53842       DATA (FMRS(2,1,I, 9),I=1,49)/
53843      &     0.01760D0,  0.02152D0,  0.02631D0,  0.02960D0,  0.03218D0,
53844      &     0.03434D0,  0.04207D0,  0.05164D0,  0.05833D0,  0.06368D0,
53845      &     0.06825D0,  0.08519D0,  0.10811D0,  0.12566D0,  0.14073D0,
53846      &     0.15430D0,  0.17863D0,  0.21087D0,  0.25789D0,  0.29938D0,
53847      &     0.37036D0,  0.42844D0,  0.47541D0,  0.52034D0,  0.55162D0,
53848      &     0.57077D0,  0.57932D0,  0.57861D0,  0.56993D0,  0.55438D0,
53849      &     0.53332D0,  0.50767D0,  0.47844D0,  0.44653D0,  0.41277D0,
53850      &     0.37787D0,  0.34261D0,  0.30753D0,  0.27327D0,  0.24001D0,
53851      &     0.20832D0,  0.17873D0,  0.15102D0,  0.10304D0,  0.06508D0,
53852      &     0.03712D0,  0.01826D0,  0.00186D0,  0.00000D0/
53853       DATA (FMRS(2,1,I,10),I=1,49)/
53854      &     0.01775D0,  0.02171D0,  0.02655D0,  0.02988D0,  0.03249D0,
53855      &     0.03468D0,  0.04249D0,  0.05219D0,  0.05897D0,  0.06440D0,
53856      &     0.06904D0,  0.08625D0,  0.10956D0,  0.12741D0,  0.14273D0,
53857      &     0.15651D0,  0.18119D0,  0.21379D0,  0.26115D0,  0.30273D0,
53858      &     0.37339D0,  0.43070D0,  0.47663D0,  0.52004D0,  0.54971D0,
53859      &     0.56723D0,  0.57424D0,  0.57214D0,  0.56221D0,  0.54564D0,
53860      &     0.52375D0,  0.49748D0,  0.46783D0,  0.43572D0,  0.40192D0,
53861      &     0.36718D0,  0.33221D0,  0.29755D0,  0.26385D0,  0.23124D0,
53862      &     0.20028D0,  0.17145D0,  0.14454D0,  0.09813D0,  0.06166D0,
53863      &     0.03497D0,  0.01708D0,  0.00171D0,  0.00000D0/
53864       DATA (FMRS(2,1,I,11),I=1,49)/
53865      &     0.01786D0,  0.02185D0,  0.02674D0,  0.03010D0,  0.03274D0,
53866      &     0.03494D0,  0.04284D0,  0.05263D0,  0.05949D0,  0.06497D0,
53867      &     0.06967D0,  0.08709D0,  0.11072D0,  0.12880D0,  0.14432D0,
53868      &     0.15827D0,  0.18322D0,  0.21609D0,  0.26371D0,  0.30535D0,
53869      &     0.37572D0,  0.43240D0,  0.47751D0,  0.51970D0,  0.54811D0,
53870      &     0.56435D0,  0.57017D0,  0.56701D0,  0.55612D0,  0.53878D0,
53871      &     0.51626D0,  0.48950D0,  0.45957D0,  0.42732D0,  0.39351D0,
53872      &     0.35893D0,  0.32420D0,  0.28986D0,  0.25663D0,  0.22452D0,
53873      &     0.19414D0,  0.16588D0,  0.13961D0,  0.09442D0,  0.05909D0,
53874      &     0.03336D0,  0.01621D0,  0.00160D0,  0.00000D0/
53875       DATA (FMRS(2,1,I,12),I=1,49)/
53876      &     0.01811D0,  0.02217D0,  0.02715D0,  0.03057D0,  0.03326D0,
53877      &     0.03551D0,  0.04357D0,  0.05358D0,  0.06059D0,  0.06620D0,
53878      &     0.07102D0,  0.08890D0,  0.11320D0,  0.13179D0,  0.14772D0,
53879      &     0.16201D0,  0.18751D0,  0.22095D0,  0.26905D0,  0.31076D0,
53880      &     0.38043D0,  0.43573D0,  0.47902D0,  0.51865D0,  0.54434D0,
53881      &     0.55794D0,  0.56131D0,  0.55592D0,  0.54308D0,  0.52418D0,
53882      &     0.50041D0,  0.47277D0,  0.44227D0,  0.40979D0,  0.37605D0,
53883      &     0.34185D0,  0.30765D0,  0.27411D0,  0.24188D0,  0.21085D0,
53884      &     0.18166D0,  0.15463D0,  0.12966D0,  0.08698D0,  0.05397D0,
53885      &     0.03017D0,  0.01449D0,  0.00138D0,  0.00000D0/
53886       DATA (FMRS(2,1,I,13),I=1,49)/
53887      &     0.01832D0,  0.02245D0,  0.02751D0,  0.03099D0,  0.03372D0,
53888      &     0.03601D0,  0.04421D0,  0.05440D0,  0.06155D0,  0.06727D0,
53889      &     0.07220D0,  0.09048D0,  0.11535D0,  0.13437D0,  0.15065D0,
53890      &     0.16524D0,  0.19119D0,  0.22510D0,  0.27356D0,  0.31528D0,
53891      &     0.38427D0,  0.43832D0,  0.48002D0,  0.51742D0,  0.54081D0,
53892      &     0.55220D0,  0.55352D0,  0.54629D0,  0.53189D0,  0.51174D0,
53893      &     0.48699D0,  0.45870D0,  0.42778D0,  0.39517D0,  0.36159D0,
53894      &     0.32774D0,  0.29406D0,  0.26124D0,  0.22984D0,  0.19975D0,
53895      &     0.17155D0,  0.14556D0,  0.12166D0,  0.08107D0,  0.04993D0,
53896      &     0.02767D0,  0.01316D0,  0.00122D0,  0.00000D0/
53897       DATA (FMRS(2,1,I,14),I=1,49)/
53898      &     0.01856D0,  0.02276D0,  0.02791D0,  0.03145D0,  0.03424D0,
53899      &     0.03657D0,  0.04493D0,  0.05533D0,  0.06263D0,  0.06849D0,
53900      &     0.07353D0,  0.09227D0,  0.11778D0,  0.13727D0,  0.15393D0,
53901      &     0.16884D0,  0.19528D0,  0.22966D0,  0.27847D0,  0.32014D0,
53902      &     0.38833D0,  0.44089D0,  0.48079D0,  0.51572D0,  0.53660D0,
53903      &     0.54555D0,  0.54466D0,  0.53550D0,  0.51948D0,  0.49806D0,
53904      &     0.47232D0,  0.44337D0,  0.41209D0,  0.37941D0,  0.34606D0,
53905      &     0.31264D0,  0.27962D0,  0.24761D0,  0.21707D0,  0.18804D0,
53906      &     0.16093D0,  0.13609D0,  0.11331D0,  0.07496D0,  0.04577D0,
53907      &     0.02513D0,  0.01183D0,  0.00106D0,  0.00000D0/
53908       DATA (FMRS(2,1,I,15),I=1,49)/
53909      &     0.01882D0,  0.02309D0,  0.02833D0,  0.03194D0,  0.03478D0,
53910      &     0.03716D0,  0.04569D0,  0.05632D0,  0.06378D0,  0.06977D0,
53911      &     0.07493D0,  0.09414D0,  0.12031D0,  0.14028D0,  0.15732D0,
53912      &     0.17254D0,  0.19946D0,  0.23430D0,  0.28337D0,  0.32492D0,
53913      &     0.39212D0,  0.44309D0,  0.48109D0,  0.51344D0,  0.53176D0,
53914      &     0.53830D0,  0.53520D0,  0.52410D0,  0.50654D0,  0.48389D0,
53915      &     0.45725D0,  0.42772D0,  0.39621D0,  0.36351D0,  0.33050D0,
53916      &     0.29757D0,  0.26525D0,  0.23404D0,  0.20451D0,  0.17653D0,
53917      &     0.15059D0,  0.12691D0,  0.10526D0,  0.06909D0,  0.04183D0,
53918      &     0.02276D0,  0.01059D0,  0.00092D0,  0.00000D0/
53919       DATA (FMRS(2,1,I,16),I=1,49)/
53920      &     0.01904D0,  0.02338D0,  0.02872D0,  0.03239D0,  0.03528D0,
53921      &     0.03770D0,  0.04639D0,  0.05722D0,  0.06483D0,  0.07094D0,
53922      &     0.07621D0,  0.09585D0,  0.12261D0,  0.14301D0,  0.16039D0,
53923      &     0.17588D0,  0.20321D0,  0.23842D0,  0.28769D0,  0.32908D0,
53924      &     0.39530D0,  0.44481D0,  0.48105D0,  0.51110D0,  0.52712D0,
53925      &     0.53155D0,  0.52655D0,  0.51382D0,  0.49491D0,  0.47126D0,
53926      &     0.44390D0,  0.41395D0,  0.38228D0,  0.34968D0,  0.31695D0,
53927      &     0.28453D0,  0.25288D0,  0.22245D0,  0.19380D0,  0.16677D0,
53928      &     0.14180D0,  0.11912D0,  0.09847D0,  0.06418D0,  0.03856D0,
53929      &     0.02081D0,  0.00959D0,  0.00081D0,  0.00000D0/
53930       DATA (FMRS(2,1,I,17),I=1,49)/
53931      &     0.01928D0,  0.02369D0,  0.02911D0,  0.03284D0,  0.03578D0,
53932      &     0.03825D0,  0.04709D0,  0.05813D0,  0.06589D0,  0.07213D0,
53933      &     0.07751D0,  0.09758D0,  0.12493D0,  0.14576D0,  0.16348D0,
53934      &     0.17924D0,  0.20696D0,  0.24251D0,  0.29193D0,  0.33312D0,
53935      &     0.39831D0,  0.44629D0,  0.48077D0,  0.50852D0,  0.52228D0,
53936      &     0.52463D0,  0.51781D0,  0.50355D0,  0.48335D0,  0.45879D0,
53937      &     0.43078D0,  0.40049D0,  0.36872D0,  0.33629D0,  0.30386D0,
53938      &     0.27197D0,  0.24101D0,  0.21137D0,  0.18360D0,  0.15751D0,
53939      &     0.13349D0,  0.11178D0,  0.09210D0,  0.05961D0,  0.03555D0,
53940      &     0.01901D0,  0.00868D0,  0.00071D0,  0.00000D0/
53941       DATA (FMRS(2,1,I,18),I=1,49)/
53942      &     0.01947D0,  0.02394D0,  0.02943D0,  0.03322D0,  0.03621D0,
53943      &     0.03871D0,  0.04769D0,  0.05889D0,  0.06678D0,  0.07312D0,
53944      &     0.07860D0,  0.09903D0,  0.12687D0,  0.14804D0,  0.16603D0,
53945      &     0.18199D0,  0.21002D0,  0.24583D0,  0.29534D0,  0.33632D0,
53946      &     0.40060D0,  0.44729D0,  0.48029D0,  0.50614D0,  0.51810D0,
53947      &     0.51876D0,  0.51049D0,  0.49502D0,  0.47387D0,  0.44861D0,
53948      &     0.42013D0,  0.38960D0,  0.35780D0,  0.32553D0,  0.29342D0,
53949      &     0.26197D0,  0.23158D0,  0.20258D0,  0.17557D0,  0.15022D0,
53950      &     0.12699D0,  0.10608D0,  0.08715D0,  0.05607D0,  0.03324D0,
53951      &     0.01765D0,  0.00799D0,  0.00064D0,  0.00000D0/
53952       DATA (FMRS(2,1,I,19),I=1,49)/
53953      &     0.01970D0,  0.02424D0,  0.02983D0,  0.03369D0,  0.03672D0,
53954      &     0.03927D0,  0.04841D0,  0.05983D0,  0.06787D0,  0.07433D0,
53955      &     0.07993D0,  0.10079D0,  0.12921D0,  0.15080D0,  0.16909D0,
53956      &     0.18531D0,  0.21368D0,  0.24977D0,  0.29932D0,  0.34002D0,
53957      &     0.40312D0,  0.44820D0,  0.47944D0,  0.50301D0,  0.51281D0,
53958      &     0.51154D0,  0.50156D0,  0.48470D0,  0.46252D0,  0.43645D0,
53959      &     0.40748D0,  0.37672D0,  0.34495D0,  0.31293D0,  0.28123D0,
53960      &     0.25036D0,  0.22064D0,  0.19244D0,  0.16630D0,  0.14187D0,
53961      &     0.11955D0,  0.09954D0,  0.08152D0,  0.05209D0,  0.03065D0,
53962      &     0.01614D0,  0.00723D0,  0.00056D0,  0.00000D0/
53963       DATA (FMRS(2,1,I,20),I=1,49)/
53964      &     0.01991D0,  0.02452D0,  0.03019D0,  0.03410D0,  0.03718D0,
53965      &     0.03977D0,  0.04905D0,  0.06066D0,  0.06884D0,  0.07541D0,
53966      &     0.08111D0,  0.10235D0,  0.13129D0,  0.15323D0,  0.17180D0,
53967      &     0.18822D0,  0.21689D0,  0.25320D0,  0.30276D0,  0.34318D0,
53968      &     0.40521D0,  0.44885D0,  0.47855D0,  0.50013D0,  0.50806D0,
53969      &     0.50515D0,  0.49374D0,  0.47571D0,  0.45269D0,  0.42596D0,
53970      &     0.39662D0,  0.36569D0,  0.33399D0,  0.30222D0,  0.27090D0,
53971      &     0.24056D0,  0.21144D0,  0.18393D0,  0.15855D0,  0.13491D0,
53972      &     0.11336D0,  0.09413D0,  0.07687D0,  0.04883D0,  0.02854D0,
53973      &     0.01493D0,  0.00663D0,  0.00051D0,  0.00000D0/
53974       DATA (FMRS(2,1,I,21),I=1,49)/
53975      &     0.02011D0,  0.02477D0,  0.03051D0,  0.03448D0,  0.03760D0,
53976      &     0.04023D0,  0.04965D0,  0.06143D0,  0.06973D0,  0.07641D0,
53977      &     0.08220D0,  0.10379D0,  0.13319D0,  0.15544D0,  0.17424D0,
53978      &     0.19085D0,  0.21976D0,  0.25625D0,  0.30577D0,  0.34590D0,
53979      &     0.40689D0,  0.44921D0,  0.47746D0,  0.49725D0,  0.50352D0,
53980      &     0.49914D0,  0.48649D0,  0.46748D0,  0.44367D0,  0.41645D0,
53981      &     0.38678D0,  0.35582D0,  0.32417D0,  0.29264D0,  0.26169D0,
53982      &     0.23187D0,  0.20335D0,  0.17646D0,  0.15176D0,  0.12881D0,
53983      &     0.10798D0,  0.08943D0,  0.07284D0,  0.04602D0,  0.02675D0,
53984      &     0.01389D0,  0.00613D0,  0.00046D0,  0.00000D0/
53985       DATA (FMRS(2,1,I,22),I=1,49)/
53986      &     0.02035D0,  0.02509D0,  0.03093D0,  0.03496D0,  0.03814D0,
53987      &     0.04081D0,  0.05040D0,  0.06241D0,  0.07087D0,  0.07768D0,
53988      &     0.08359D0,  0.10562D0,  0.13559D0,  0.15824D0,  0.17734D0,
53989      &     0.19417D0,  0.22338D0,  0.26006D0,  0.30949D0,  0.34920D0,
53990      &     0.40885D0,  0.44948D0,  0.47592D0,  0.49348D0,  0.49770D0,
53991      &     0.49152D0,  0.47736D0,  0.45716D0,  0.43246D0,  0.40467D0,
53992      &     0.37468D0,  0.34367D0,  0.31217D0,  0.28097D0,  0.25052D0,
53993      &     0.22133D0,  0.19355D0,  0.16747D0,  0.14359D0,  0.12150D0,
53994      &     0.10155D0,  0.08384D0,  0.06806D0,  0.04272D0,  0.02464D0,
53995      &     0.01269D0,  0.00554D0,  0.00040D0,  0.00000D0/
53996       DATA (FMRS(2,1,I,23),I=1,49)/
53997      &     0.02058D0,  0.02539D0,  0.03132D0,  0.03542D0,  0.03865D0,
53998      &     0.04137D0,  0.05112D0,  0.06333D0,  0.07195D0,  0.07888D0,
53999      &     0.08490D0,  0.10735D0,  0.13786D0,  0.16087D0,  0.18023D0,
54000      &     0.19726D0,  0.22673D0,  0.26356D0,  0.31287D0,  0.35216D0,
54001      &     0.41052D0,  0.44953D0,  0.47430D0,  0.48980D0,  0.49215D0,
54002      &     0.48435D0,  0.46885D0,  0.44758D0,  0.42215D0,  0.39387D0,
54003      &     0.36366D0,  0.33261D0,  0.30132D0,  0.27045D0,  0.24050D0,
54004      &     0.21190D0,  0.18476D0,  0.15947D0,  0.13635D0,  0.11504D0,
54005      &     0.09587D0,  0.07894D0,  0.06387D0,  0.03984D0,  0.02282D0,
54006      &     0.01167D0,  0.00505D0,  0.00036D0,  0.00000D0/
54007       DATA (FMRS(2,1,I,24),I=1,49)/
54008      &     0.02080D0,  0.02568D0,  0.03170D0,  0.03585D0,  0.03914D0,
54009      &     0.04189D0,  0.05180D0,  0.06421D0,  0.07296D0,  0.08001D0,
54010      &     0.08614D0,  0.10897D0,  0.13997D0,  0.16330D0,  0.18290D0,
54011      &     0.20010D0,  0.22978D0,  0.26672D0,  0.31586D0,  0.35473D0,
54012      &     0.41182D0,  0.44931D0,  0.47248D0,  0.48612D0,  0.48676D0,
54013      &     0.47750D0,  0.46081D0,  0.43866D0,  0.41258D0,  0.38389D0,
54014      &     0.35352D0,  0.32245D0,  0.29140D0,  0.26089D0,  0.23143D0,
54015      &     0.20340D0,  0.17690D0,  0.15229D0,  0.12990D0,  0.10931D0,
54016      &     0.09084D0,  0.07461D0,  0.06021D0,  0.03734D0,  0.02125D0,
54017      &     0.01078D0,  0.00462D0,  0.00032D0,  0.00000D0/
54018       DATA (FMRS(2,1,I,25),I=1,49)/
54019      &     0.02102D0,  0.02596D0,  0.03207D0,  0.03629D0,  0.03962D0,
54020      &     0.04242D0,  0.05248D0,  0.06508D0,  0.07398D0,  0.08115D0,
54021      &     0.08738D0,  0.11059D0,  0.14207D0,  0.16573D0,  0.18556D0,
54022      &     0.20292D0,  0.23281D0,  0.26985D0,  0.31879D0,  0.35722D0,
54023      &     0.41303D0,  0.44900D0,  0.47060D0,  0.48240D0,  0.48138D0,
54024      &     0.47074D0,  0.45292D0,  0.42993D0,  0.40324D0,  0.37421D0,
54025      &     0.34370D0,  0.31266D0,  0.28186D0,  0.25172D0,  0.22275D0,
54026      &     0.19528D0,  0.16943D0,  0.14547D0,  0.12379D0,  0.10391D0,
54027      &     0.08611D0,  0.07055D0,  0.05678D0,  0.03501D0,  0.01980D0,
54028      &     0.00997D0,  0.00424D0,  0.00029D0,  0.00000D0/
54029       DATA (FMRS(2,1,I,26),I=1,49)/
54030      &     0.02124D0,  0.02625D0,  0.03244D0,  0.03672D0,  0.04010D0,
54031      &     0.04294D0,  0.05315D0,  0.06595D0,  0.07499D0,  0.08227D0,
54032      &     0.08860D0,  0.11218D0,  0.14413D0,  0.16809D0,  0.18813D0,
54033      &     0.20564D0,  0.23571D0,  0.27281D0,  0.32152D0,  0.35948D0,
54034      &     0.41398D0,  0.44847D0,  0.46857D0,  0.47858D0,  0.47599D0,
54035      &     0.46404D0,  0.44519D0,  0.42139D0,  0.39420D0,  0.36490D0,
54036      &     0.33431D0,  0.30337D0,  0.27282D0,  0.24304D0,  0.21455D0,
54037      &     0.18765D0,  0.16244D0,  0.13911D0,  0.11808D0,  0.09890D0,
54038      &     0.08174D0,  0.06681D0,  0.05361D0,  0.03286D0,  0.01847D0,
54039      &     0.00924D0,  0.00390D0,  0.00026D0,  0.00000D0/
54040       DATA (FMRS(2,1,I,27),I=1,49)/
54041      &     0.02145D0,  0.02652D0,  0.03279D0,  0.03713D0,  0.04055D0,
54042      &     0.04343D0,  0.05378D0,  0.06677D0,  0.07594D0,  0.08333D0,
54043      &     0.08975D0,  0.11368D0,  0.14607D0,  0.17031D0,  0.19054D0,
54044      &     0.20819D0,  0.23841D0,  0.27555D0,  0.32402D0,  0.36153D0,
54045      &     0.41478D0,  0.44786D0,  0.46655D0,  0.47490D0,  0.47088D0,
54046      &     0.45773D0,  0.43795D0,  0.41346D0,  0.38583D0,  0.35628D0,
54047      &     0.32564D0,  0.29483D0,  0.26454D0,  0.23512D0,  0.20709D0,
54048      &     0.18074D0,  0.15610D0,  0.13337D0,  0.11295D0,  0.09439D0,
54049      &     0.07783D0,  0.06346D0,  0.05079D0,  0.03096D0,  0.01730D0,
54050      &     0.00860D0,  0.00360D0,  0.00023D0,  0.00000D0/
54051       DATA (FMRS(2,1,I,28),I=1,49)/
54052      &     0.02164D0,  0.02677D0,  0.03312D0,  0.03751D0,  0.04098D0,
54053      &     0.04390D0,  0.05439D0,  0.06755D0,  0.07684D0,  0.08433D0,
54054      &     0.09084D0,  0.11510D0,  0.14789D0,  0.17239D0,  0.19279D0,
54055      &     0.21056D0,  0.24091D0,  0.27806D0,  0.32630D0,  0.36334D0,
54056      &     0.41540D0,  0.44716D0,  0.46451D0,  0.47135D0,  0.46602D0,
54057      &     0.45177D0,  0.43117D0,  0.40606D0,  0.37805D0,  0.34829D0,
54058      &     0.31763D0,  0.28699D0,  0.25693D0,  0.22788D0,  0.20031D0,
54059      &     0.17447D0,  0.15036D0,  0.12818D0,  0.10834D0,  0.09032D0,
54060      &     0.07432D0,  0.06046D0,  0.04827D0,  0.02929D0,  0.01628D0,
54061      &     0.00804D0,  0.00334D0,  0.00021D0,  0.00000D0/
54062       DATA (FMRS(2,1,I,29),I=1,49)/
54063      &     0.02184D0,  0.02703D0,  0.03346D0,  0.03790D0,  0.04142D0,
54064      &     0.04437D0,  0.05500D0,  0.06833D0,  0.07775D0,  0.08534D0,
54065      &     0.09195D0,  0.11653D0,  0.14972D0,  0.17447D0,  0.19503D0,
54066      &     0.21292D0,  0.24339D0,  0.28054D0,  0.32851D0,  0.36507D0,
54067      &     0.41592D0,  0.44635D0,  0.46240D0,  0.46773D0,  0.46111D0,
54068      &     0.44581D0,  0.42442D0,  0.39875D0,  0.37037D0,  0.34044D0,
54069      &     0.30980D0,  0.27932D0,  0.24952D0,  0.22085D0,  0.19375D0,
54070      &     0.16840D0,  0.14482D0,  0.12320D0,  0.10392D0,  0.08643D0,
54071      &     0.07097D0,  0.05759D0,  0.04588D0,  0.02770D0,  0.01531D0,
54072      &     0.00752D0,  0.00311D0,  0.00019D0,  0.00000D0/
54073       DATA (FMRS(2,1,I,30),I=1,49)/
54074      &     0.02204D0,  0.02729D0,  0.03379D0,  0.03829D0,  0.04185D0,
54075      &     0.04484D0,  0.05560D0,  0.06911D0,  0.07865D0,  0.08634D0,
54076      &     0.09303D0,  0.11793D0,  0.15151D0,  0.17649D0,  0.19722D0,
54077      &     0.21521D0,  0.24577D0,  0.28291D0,  0.33057D0,  0.36667D0,
54078      &     0.41631D0,  0.44543D0,  0.46021D0,  0.46408D0,  0.45622D0,
54079      &     0.43995D0,  0.41780D0,  0.39163D0,  0.36293D0,  0.33287D0,
54080      &     0.30229D0,  0.27195D0,  0.24246D0,  0.21416D0,  0.18750D0,
54081      &     0.16265D0,  0.13957D0,  0.11850D0,  0.09976D0,  0.08278D0,
54082      &     0.06783D0,  0.05492D0,  0.04366D0,  0.02623D0,  0.01442D0,
54083      &     0.00705D0,  0.00289D0,  0.00017D0,  0.00000D0/
54084       DATA (FMRS(2,1,I,31),I=1,49)/
54085      &     0.02222D0,  0.02753D0,  0.03410D0,  0.03866D0,  0.04226D0,
54086      &     0.04528D0,  0.05617D0,  0.06985D0,  0.07951D0,  0.08729D0,
54087      &     0.09407D0,  0.11927D0,  0.15320D0,  0.17841D0,  0.19928D0,
54088      &     0.21737D0,  0.24802D0,  0.28513D0,  0.33249D0,  0.36812D0,
54089      &     0.41660D0,  0.44449D0,  0.45808D0,  0.46059D0,  0.45160D0,
54090      &     0.43442D0,  0.41159D0,  0.38497D0,  0.35599D0,  0.32584D0,
54091      &     0.29532D0,  0.26514D0,  0.23594D0,  0.20800D0,  0.18176D0,
54092      &     0.15738D0,  0.13478D0,  0.11421D0,  0.09597D0,  0.07947D0,
54093      &     0.06498D0,  0.05251D0,  0.04166D0,  0.02491D0,  0.01363D0,
54094      &     0.00662D0,  0.00270D0,  0.00016D0,  0.00000D0/
54095       DATA (FMRS(2,1,I,32),I=1,49)/
54096      &     0.02240D0,  0.02776D0,  0.03441D0,  0.03901D0,  0.04265D0,
54097      &     0.04571D0,  0.05672D0,  0.07055D0,  0.08032D0,  0.08819D0,
54098      &     0.09505D0,  0.12053D0,  0.15480D0,  0.18021D0,  0.20120D0,
54099      &     0.21937D0,  0.25009D0,  0.28716D0,  0.33421D0,  0.36938D0,
54100      &     0.41675D0,  0.44346D0,  0.45593D0,  0.45721D0,  0.44717D0,
54101      &     0.42917D0,  0.40572D0,  0.37869D0,  0.34947D0,  0.31928D0,
54102      &     0.28882D0,  0.25885D0,  0.22992D0,  0.20233D0,  0.17646D0,
54103      &     0.15252D0,  0.13038D0,  0.11028D0,  0.09251D0,  0.07647D0,
54104      &     0.06240D0,  0.05033D0,  0.03984D0,  0.02372D0,  0.01293D0,
54105      &     0.00625D0,  0.00253D0,  0.00015D0,  0.00000D0/
54106       DATA (FMRS(2,1,I,33),I=1,49)/
54107      &     0.02258D0,  0.02800D0,  0.03471D0,  0.03936D0,  0.04304D0,
54108      &     0.04613D0,  0.05727D0,  0.07126D0,  0.08114D0,  0.08911D0,
54109      &     0.09604D0,  0.12181D0,  0.15642D0,  0.18202D0,  0.20315D0,
54110      &     0.22140D0,  0.25219D0,  0.28920D0,  0.33594D0,  0.37065D0,
54111      &     0.41690D0,  0.44243D0,  0.45378D0,  0.45384D0,  0.44278D0,
54112      &     0.42397D0,  0.39993D0,  0.37250D0,  0.34307D0,  0.31283D0,
54113      &     0.28245D0,  0.25269D0,  0.22404D0,  0.19681D0,  0.17131D0,
54114      &     0.14780D0,  0.12613D0,  0.10648D0,  0.08918D0,  0.07357D0,
54115      &     0.05991D0,  0.04824D0,  0.03811D0,  0.02259D0,  0.01226D0,
54116      &     0.00589D0,  0.00237D0,  0.00014D0,  0.00000D0/
54117       DATA (FMRS(2,1,I,34),I=1,49)/
54118      &     0.02276D0,  0.02823D0,  0.03502D0,  0.03972D0,  0.04344D0,
54119      &     0.04656D0,  0.05782D0,  0.07197D0,  0.08196D0,  0.09001D0,
54120      &     0.09702D0,  0.12306D0,  0.15799D0,  0.18378D0,  0.20502D0,
54121      &     0.22334D0,  0.25418D0,  0.29111D0,  0.33751D0,  0.37174D0,
54122      &     0.41686D0,  0.44123D0,  0.45149D0,  0.45035D0,  0.43832D0,
54123      &     0.41874D0,  0.39416D0,  0.36638D0,  0.33679D0,  0.30651D0,
54124      &     0.27625D0,  0.24670D0,  0.21831D0,  0.19144D0,  0.16636D0,
54125      &     0.14329D0,  0.12204D0,  0.10286D0,  0.08597D0,  0.07080D0,
54126      &     0.05755D0,  0.04624D0,  0.03646D0,  0.02153D0,  0.01162D0,
54127      &     0.00556D0,  0.00222D0,  0.00012D0,  0.00000D0/
54128       DATA (FMRS(2,1,I,35),I=1,49)/
54129      &     0.02294D0,  0.02846D0,  0.03531D0,  0.04006D0,  0.04381D0,
54130      &     0.04697D0,  0.05834D0,  0.07264D0,  0.08274D0,  0.09087D0,
54131      &     0.09796D0,  0.12426D0,  0.15949D0,  0.18547D0,  0.20682D0,
54132      &     0.22520D0,  0.25608D0,  0.29293D0,  0.33900D0,  0.37277D0,
54133      &     0.41683D0,  0.44010D0,  0.44933D0,  0.44706D0,  0.43413D0,
54134      &     0.41383D0,  0.38877D0,  0.36068D0,  0.33093D0,  0.30063D0,
54135      &     0.27049D0,  0.24114D0,  0.21302D0,  0.18649D0,  0.16180D0,
54136      &     0.13914D0,  0.11828D0,  0.09955D0,  0.08303D0,  0.06826D0,
54137      &     0.05540D0,  0.04443D0,  0.03497D0,  0.02057D0,  0.01106D0,
54138      &     0.00526D0,  0.00209D0,  0.00012D0,  0.00000D0/
54139       DATA (FMRS(2,1,I,36),I=1,49)/
54140      &     0.02310D0,  0.02867D0,  0.03558D0,  0.04038D0,  0.04417D0,
54141      &     0.04736D0,  0.05885D0,  0.07328D0,  0.08348D0,  0.09170D0,
54142      &     0.09885D0,  0.12540D0,  0.16092D0,  0.18705D0,  0.20850D0,
54143      &     0.22693D0,  0.25784D0,  0.29461D0,  0.34036D0,  0.37368D0,
54144      &     0.41672D0,  0.43895D0,  0.44722D0,  0.44390D0,  0.43013D0,
54145      &     0.40920D0,  0.38369D0,  0.35531D0,  0.32545D0,  0.29515D0,
54146      &     0.26511D0,  0.23598D0,  0.20812D0,  0.18191D0,  0.15758D0,
54147      &     0.13530D0,  0.11483D0,  0.09649D0,  0.08034D0,  0.06595D0,
54148      &     0.05344D0,  0.04278D0,  0.03361D0,  0.01970D0,  0.01054D0,
54149      &     0.00499D0,  0.00197D0,  0.00011D0,  0.00000D0/
54150       DATA (FMRS(2,1,I,37),I=1,49)/
54151      &     0.02327D0,  0.02889D0,  0.03587D0,  0.04071D0,  0.04453D0,
54152      &     0.04775D0,  0.05935D0,  0.07393D0,  0.08423D0,  0.09253D0,
54153      &     0.09975D0,  0.12655D0,  0.16235D0,  0.18864D0,  0.21018D0,
54154      &     0.22866D0,  0.25959D0,  0.29626D0,  0.34166D0,  0.37452D0,
54155      &     0.41652D0,  0.43771D0,  0.44502D0,  0.44067D0,  0.42606D0,
54156      &     0.40453D0,  0.37859D0,  0.34994D0,  0.31996D0,  0.28968D0,
54157      &     0.25976D0,  0.23084D0,  0.20328D0,  0.17738D0,  0.15341D0,
54158      &     0.13150D0,  0.11145D0,  0.09348D0,  0.07773D0,  0.06369D0,
54159      &     0.05153D0,  0.04117D0,  0.03229D0,  0.01885D0,  0.01005D0,
54160      &     0.00474D0,  0.00186D0,  0.00010D0,  0.00000D0/
54161       DATA (FMRS(2,1,I,38),I=1,49)/
54162      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54163      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54164      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54165      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54166      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54167      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54168      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54169      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54170      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54171      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54172       DATA (FMRS(2,2,I, 1),I=1,49)/
54173      &     0.00683D0,  0.00832D0,  0.01013D0,  0.01138D0,  0.01237D0,
54174      &     0.01320D0,  0.01619D0,  0.02004D0,  0.02286D0,  0.02522D0,
54175      &     0.02744D0,  0.03623D0,  0.04952D0,  0.06032D0,  0.06982D0,
54176      &     0.07843D0,  0.09385D0,  0.11395D0,  0.14220D0,  0.16592D0,
54177      &     0.20382D0,  0.23228D0,  0.25344D0,  0.27158D0,  0.28216D0,
54178      &     0.28647D0,  0.28570D0,  0.28068D0,  0.27216D0,  0.26127D0,
54179      &     0.24773D0,  0.23281D0,  0.21663D0,  0.19968D0,  0.18252D0,
54180      &     0.16522D0,  0.14809D0,  0.13153D0,  0.11576D0,  0.10050D0,
54181      &     0.08631D0,  0.07335D0,  0.06127D0,  0.04098D0,  0.02531D0,
54182      &     0.01409D0,  0.00672D0,  0.00064D0,  0.00000D0/
54183       DATA (FMRS(2,2,I, 2),I=1,49)/
54184      &     0.00687D0,  0.00838D0,  0.01023D0,  0.01151D0,  0.01252D0,
54185      &     0.01336D0,  0.01643D0,  0.02037D0,  0.02327D0,  0.02569D0,
54186      &     0.02797D0,  0.03698D0,  0.05059D0,  0.06162D0,  0.07129D0,
54187      &     0.08004D0,  0.09567D0,  0.11595D0,  0.14429D0,  0.16793D0,
54188      &     0.20539D0,  0.23318D0,  0.25356D0,  0.27069D0,  0.28025D0,
54189      &     0.28363D0,  0.28200D0,  0.27624D0,  0.26713D0,  0.25572D0,
54190      &     0.24185D0,  0.22669D0,  0.21040D0,  0.19345D0,  0.17637D0,
54191      &     0.15928D0,  0.14242D0,  0.12615D0,  0.11076D0,  0.09591D0,
54192      &     0.08215D0,  0.06963D0,  0.05800D0,  0.03856D0,  0.02367D0,
54193      &     0.01309D0,  0.00619D0,  0.00057D0,  0.00000D0/
54194       DATA (FMRS(2,2,I, 3),I=1,49)/
54195      &     0.00693D0,  0.00848D0,  0.01038D0,  0.01170D0,  0.01274D0,
54196      &     0.01362D0,  0.01679D0,  0.02088D0,  0.02389D0,  0.02641D0,
54197      &     0.02877D0,  0.03812D0,  0.05220D0,  0.06356D0,  0.07349D0,
54198      &     0.08244D0,  0.09836D0,  0.11888D0,  0.14732D0,  0.17082D0,
54199      &     0.20757D0,  0.23434D0,  0.25356D0,  0.26918D0,  0.27725D0,
54200      &     0.27927D0,  0.27642D0,  0.26960D0,  0.25969D0,  0.24758D0,
54201      &     0.23327D0,  0.21778D0,  0.20136D0,  0.18446D0,  0.16756D0,
54202      &     0.15079D0,  0.13434D0,  0.11852D0,  0.10371D0,  0.08946D0,
54203      &     0.07631D0,  0.06442D0,  0.05345D0,  0.03522D0,  0.02142D0,
54204      &     0.01172D0,  0.00548D0,  0.00049D0,  0.00000D0/
54205       DATA (FMRS(2,2,I, 4),I=1,49)/
54206      &     0.00697D0,  0.00855D0,  0.01050D0,  0.01184D0,  0.01291D0,
54207      &     0.01380D0,  0.01706D0,  0.02126D0,  0.02435D0,  0.02694D0,
54208      &     0.02937D0,  0.03897D0,  0.05339D0,  0.06499D0,  0.07510D0,
54209      &     0.08419D0,  0.10031D0,  0.12100D0,  0.14949D0,  0.17285D0,
54210      &     0.20905D0,  0.23506D0,  0.25342D0,  0.26794D0,  0.27493D0,
54211      &     0.27599D0,  0.27230D0,  0.26475D0,  0.25426D0,  0.24171D0,
54212      &     0.22712D0,  0.21140D0,  0.19495D0,  0.17811D0,  0.16138D0,
54213      &     0.14485D0,  0.12869D0,  0.11323D0,  0.09881D0,  0.08500D0,
54214      &     0.07230D0,  0.06086D0,  0.05034D0,  0.03297D0,  0.01992D0,
54215      &     0.01081D0,  0.00501D0,  0.00044D0,  0.00000D0/
54216       DATA (FMRS(2,2,I, 5),I=1,49)/
54217      &     0.00702D0,  0.00863D0,  0.01062D0,  0.01200D0,  0.01309D0,
54218      &     0.01401D0,  0.01735D0,  0.02167D0,  0.02485D0,  0.02751D0,
54219      &     0.03001D0,  0.03988D0,  0.05465D0,  0.06649D0,  0.07678D0,
54220      &     0.08602D0,  0.10233D0,  0.12317D0,  0.15168D0,  0.17488D0,
54221      &     0.21046D0,  0.23564D0,  0.25309D0,  0.26645D0,  0.27234D0,
54222      &     0.27243D0,  0.26786D0,  0.25959D0,  0.24854D0,  0.23557D0,
54223      &     0.22068D0,  0.20486D0,  0.18841D0,  0.17163D0,  0.15506D0,
54224      &     0.13880D0,  0.12296D0,  0.10788D0,  0.09387D0,  0.08052D0,
54225      &     0.06829D0,  0.05730D0,  0.04726D0,  0.03074D0,  0.01844D0,
54226      &     0.00993D0,  0.00456D0,  0.00039D0,  0.00000D0/
54227       DATA (FMRS(2,2,I, 6),I=1,49)/
54228      &     0.00706D0,  0.00870D0,  0.01073D0,  0.01213D0,  0.01325D0,
54229      &     0.01419D0,  0.01761D0,  0.02203D0,  0.02528D0,  0.02801D0,
54230      &     0.03057D0,  0.04067D0,  0.05575D0,  0.06780D0,  0.07825D0,
54231      &     0.08760D0,  0.10408D0,  0.12504D0,  0.15354D0,  0.17659D0,
54232      &     0.21162D0,  0.23607D0,  0.25274D0,  0.26511D0,  0.27006D0,
54233      &     0.26933D0,  0.26403D0,  0.25518D0,  0.24367D0,  0.23035D0,
54234      &     0.21525D0,  0.19935D0,  0.18289D0,  0.16620D0,  0.14980D0,
54235      &     0.13377D0,  0.11822D0,  0.10346D0,  0.08981D0,  0.07685D0,
54236      &     0.06502D0,  0.05441D0,  0.04475D0,  0.02894D0,  0.01725D0,
54237      &     0.00923D0,  0.00420D0,  0.00035D0,  0.00000D0/
54238       DATA (FMRS(2,2,I, 7),I=1,49)/
54239      &     0.00711D0,  0.00877D0,  0.01083D0,  0.01227D0,  0.01340D0,
54240      &     0.01436D0,  0.01785D0,  0.02237D0,  0.02570D0,  0.02850D0,
54241      &     0.03112D0,  0.04143D0,  0.05680D0,  0.06905D0,  0.07964D0,
54242      &     0.08911D0,  0.10573D0,  0.12679D0,  0.15527D0,  0.17816D0,
54243      &     0.21263D0,  0.23638D0,  0.25229D0,  0.26373D0,  0.26781D0,
54244      &     0.26630D0,  0.26033D0,  0.25095D0,  0.23903D0,  0.22536D0,
54245      &     0.21011D0,  0.19416D0,  0.17766D0,  0.16111D0,  0.14488D0,
54246      &     0.12910D0,  0.11382D0,  0.09936D0,  0.08606D0,  0.07347D0,
54247      &     0.06201D0,  0.05178D0,  0.04247D0,  0.02732D0,  0.01619D0,
54248      &     0.00860D0,  0.00389D0,  0.00031D0,  0.00000D0/
54249       DATA (FMRS(2,2,I, 8),I=1,49)/
54250      &     0.00716D0,  0.00885D0,  0.01095D0,  0.01241D0,  0.01357D0,
54251      &     0.01455D0,  0.01812D0,  0.02275D0,  0.02616D0,  0.02902D0,
54252      &     0.03170D0,  0.04225D0,  0.05792D0,  0.07038D0,  0.08112D0,
54253      &     0.09070D0,  0.10747D0,  0.12863D0,  0.15707D0,  0.17976D0,
54254      &     0.21362D0,  0.23661D0,  0.25172D0,  0.26218D0,  0.26535D0,
54255      &     0.26303D0,  0.25640D0,  0.24647D0,  0.23413D0,  0.22018D0,
54256      &     0.20477D0,  0.18875D0,  0.17228D0,  0.15585D0,  0.13983D0,
54257      &     0.12430D0,  0.10932D0,  0.09519D0,  0.08225D0,  0.07005D0,
54258      &     0.05898D0,  0.04912D0,  0.04018D0,  0.02570D0,  0.01514D0,
54259      &     0.00799D0,  0.00358D0,  0.00028D0,  0.00000D0/
54260       DATA (FMRS(2,2,I, 9),I=1,49)/
54261      &     0.00720D0,  0.00891D0,  0.01105D0,  0.01254D0,  0.01372D0,
54262      &     0.01472D0,  0.01836D0,  0.02308D0,  0.02656D0,  0.02948D0,
54263      &     0.03221D0,  0.04297D0,  0.05891D0,  0.07154D0,  0.08241D0,
54264      &     0.09208D0,  0.10897D0,  0.13020D0,  0.15860D0,  0.18111D0,
54265      &     0.21443D0,  0.23674D0,  0.25116D0,  0.26078D0,  0.26316D0,
54266      &     0.26017D0,  0.25299D0,  0.24260D0,  0.22991D0,  0.21577D0,
54267      &     0.20023D0,  0.18414D0,  0.16776D0,  0.15141D0,  0.13557D0,
54268      &     0.12027D0,  0.10555D0,  0.09171D0,  0.07908D0,  0.06721D0,
54269      &     0.05646D0,  0.04691D0,  0.03829D0,  0.02437D0,  0.01428D0,
54270      &     0.00749D0,  0.00333D0,  0.00026D0,  0.00000D0/
54271       DATA (FMRS(2,2,I,10),I=1,49)/
54272      &     0.00724D0,  0.00898D0,  0.01115D0,  0.01266D0,  0.01386D0,
54273      &     0.01488D0,  0.01859D0,  0.02340D0,  0.02695D0,  0.02993D0,
54274      &     0.03271D0,  0.04366D0,  0.05985D0,  0.07265D0,  0.08364D0,
54275      &     0.09340D0,  0.11040D0,  0.13168D0,  0.16002D0,  0.18235D0,
54276      &     0.21512D0,  0.23679D0,  0.25054D0,  0.25935D0,  0.26099D0,
54277      &     0.25738D0,  0.24967D0,  0.23885D0,  0.22588D0,  0.21153D0,
54278      &     0.19588D0,  0.17977D0,  0.16345D0,  0.14723D0,  0.13156D0,
54279      &     0.11648D0,  0.10202D0,  0.08846D0,  0.07613D0,  0.06457D0,
54280      &     0.05413D0,  0.04488D0,  0.03655D0,  0.02315D0,  0.01349D0,
54281      &     0.00703D0,  0.00311D0,  0.00024D0,  0.00000D0/
54282       DATA (FMRS(2,2,I,11),I=1,49)/
54283      &     0.00727D0,  0.00904D0,  0.01123D0,  0.01276D0,  0.01398D0,
54284      &     0.01501D0,  0.01877D0,  0.02366D0,  0.02727D0,  0.03029D0,
54285      &     0.03311D0,  0.04422D0,  0.06061D0,  0.07353D0,  0.08461D0,
54286      &     0.09444D0,  0.11152D0,  0.13285D0,  0.16112D0,  0.18330D0,
54287      &     0.21564D0,  0.23680D0,  0.25001D0,  0.25818D0,  0.25925D0,
54288      &     0.25517D0,  0.24705D0,  0.23591D0,  0.22272D0,  0.20821D0,
54289      &     0.19248D0,  0.17638D0,  0.16011D0,  0.14399D0,  0.12847D0,
54290      &     0.11356D0,  0.09932D0,  0.08597D0,  0.07388D0,  0.06256D0,
54291      &     0.05235D0,  0.04334D0,  0.03522D0,  0.02223D0,  0.01290D0,
54292      &     0.00670D0,  0.00295D0,  0.00022D0,  0.00000D0/
54293       DATA (FMRS(2,2,I,12),I=1,49)/
54294      &     0.00735D0,  0.00915D0,  0.01141D0,  0.01298D0,  0.01423D0,
54295      &     0.01529D0,  0.01917D0,  0.02422D0,  0.02794D0,  0.03106D0,
54296      &     0.03397D0,  0.04541D0,  0.06221D0,  0.07541D0,  0.08668D0,
54297      &     0.09664D0,  0.11388D0,  0.13528D0,  0.16340D0,  0.18523D0,
54298      &     0.21662D0,  0.23667D0,  0.24876D0,  0.25560D0,  0.25550D0,
54299      &     0.25041D0,  0.24145D0,  0.22968D0,  0.21606D0,  0.20125D0,
54300      &     0.18540D0,  0.16932D0,  0.15319D0,  0.13731D0,  0.12210D0,
54301      &     0.10759D0,  0.09378D0,  0.08090D0,  0.06929D0,  0.05847D0,
54302      &     0.04874D0,  0.04022D0,  0.03256D0,  0.02039D0,  0.01173D0,
54303      &     0.00603D0,  0.00263D0,  0.00019D0,  0.00000D0/
54304       DATA (FMRS(2,2,I,13),I=1,49)/
54305      &     0.00742D0,  0.00926D0,  0.01156D0,  0.01317D0,  0.01446D0,
54306      &     0.01554D0,  0.01952D0,  0.02471D0,  0.02853D0,  0.03173D0,
54307      &     0.03472D0,  0.04644D0,  0.06360D0,  0.07703D0,  0.08845D0,
54308      &     0.09852D0,  0.11589D0,  0.13732D0,  0.16529D0,  0.18680D0,
54309      &     0.21735D0,  0.23643D0,  0.24757D0,  0.25329D0,  0.25220D0,
54310      &     0.24629D0,  0.23665D0,  0.22439D0,  0.21043D0,  0.19540D0,
54311      &     0.17949D0,  0.16343D0,  0.14746D0,  0.13180D0,  0.11686D0,
54312      &     0.10269D0,  0.08926D0,  0.07677D0,  0.06556D0,  0.05517D0,
54313      &     0.04584D0,  0.03772D0,  0.03044D0,  0.01893D0,  0.01082D0,
54314      &     0.00551D0,  0.00238D0,  0.00017D0,  0.00000D0/
54315       DATA (FMRS(2,2,I,14),I=1,49)/
54316      &     0.00750D0,  0.00938D0,  0.01173D0,  0.01339D0,  0.01471D0,
54317      &     0.01583D0,  0.01992D0,  0.02526D0,  0.02920D0,  0.03250D0,
54318      &     0.03557D0,  0.04761D0,  0.06516D0,  0.07882D0,  0.09041D0,
54319      &     0.10060D0,  0.11809D0,  0.13955D0,  0.16731D0,  0.18846D0,
54320      &     0.21802D0,  0.23605D0,  0.24613D0,  0.25062D0,  0.24846D0,
54321      &     0.24169D0,  0.23135D0,  0.21858D0,  0.20428D0,  0.18902D0,
54322      &     0.17309D0,  0.15708D0,  0.14130D0,  0.12590D0,  0.11127D0,
54323      &     0.09745D0,  0.08445D0,  0.07239D0,  0.06165D0,  0.05170D0,
54324      &     0.04281D0,  0.03511D0,  0.02824D0,  0.01743D0,  0.00988D0,
54325      &     0.00499D0,  0.00213D0,  0.00015D0,  0.00000D0/
54326       DATA (FMRS(2,2,I,15),I=1,49)/
54327      &     0.00758D0,  0.00950D0,  0.01192D0,  0.01362D0,  0.01498D0,
54328      &     0.01613D0,  0.02034D0,  0.02584D0,  0.02990D0,  0.03330D0,
54329      &     0.03646D0,  0.04882D0,  0.06676D0,  0.08067D0,  0.09242D0,
54330      &     0.10271D0,  0.12031D0,  0.14177D0,  0.16927D0,  0.19002D0,
54331      &     0.21855D0,  0.23546D0,  0.24445D0,  0.24771D0,  0.24448D0,
54332      &     0.23683D0,  0.22584D0,  0.21262D0,  0.19799D0,  0.18255D0,
54333      &     0.16661D0,  0.15073D0,  0.13511D0,  0.12003D0,  0.10571D0,
54334      &     0.09233D0,  0.07973D0,  0.06812D0,  0.05781D0,  0.04834D0,
54335      &     0.03990D0,  0.03259D0,  0.02612D0,  0.01599D0,  0.00899D0,
54336      &     0.00450D0,  0.00190D0,  0.00013D0,  0.00000D0/
54337       DATA (FMRS(2,2,I,16),I=1,49)/
54338      &     0.00766D0,  0.00962D0,  0.01210D0,  0.01384D0,  0.01522D0,
54339      &     0.01640D0,  0.02073D0,  0.02638D0,  0.03055D0,  0.03403D0,
54340      &     0.03728D0,  0.04992D0,  0.06822D0,  0.08234D0,  0.09422D0,
54341      &     0.10460D0,  0.12228D0,  0.14371D0,  0.17097D0,  0.19133D0,
54342      &     0.21891D0,  0.23481D0,  0.24283D0,  0.24499D0,  0.24085D0,
54343      &     0.23246D0,  0.22090D0,  0.20727D0,  0.19242D0,  0.17687D0,
54344      &     0.16094D0,  0.14517D0,  0.12974D0,  0.11493D0,  0.10094D0,
54345      &     0.08792D0,  0.07568D0,  0.06448D0,  0.05456D0,  0.04548D0,
54346      &     0.03743D0,  0.03047D0,  0.02435D0,  0.01480D0,  0.00826D0,
54347      &     0.00410D0,  0.00171D0,  0.00011D0,  0.00000D0/
54348       DATA (FMRS(2,2,I,17),I=1,49)/
54349      &     0.00775D0,  0.00975D0,  0.01228D0,  0.01406D0,  0.01548D0,
54350      &     0.01669D0,  0.02112D0,  0.02692D0,  0.03120D0,  0.03478D0,
54351      &     0.03810D0,  0.05104D0,  0.06968D0,  0.08400D0,  0.09602D0,
54352      &     0.10648D0,  0.12423D0,  0.14563D0,  0.17261D0,  0.19256D0,
54353      &     0.21918D0,  0.23405D0,  0.24112D0,  0.24221D0,  0.23719D0,
54354      &     0.22809D0,  0.21600D0,  0.20198D0,  0.18694D0,  0.17130D0,
54355      &     0.15541D0,  0.13976D0,  0.12455D0,  0.11000D0,  0.09636D0,
54356      &     0.08368D0,  0.07182D0,  0.06101D0,  0.05149D0,  0.04278D0,
54357      &     0.03510D0,  0.02849D0,  0.02269D0,  0.01370D0,  0.00759D0,
54358      &     0.00374D0,  0.00155D0,  0.00010D0,  0.00000D0/
54359       DATA (FMRS(2,2,I,18),I=1,49)/
54360      &     0.00782D0,  0.00985D0,  0.01243D0,  0.01424D0,  0.01569D0,
54361      &     0.01692D0,  0.02146D0,  0.02738D0,  0.03175D0,  0.03540D0,
54362      &     0.03879D0,  0.05197D0,  0.07089D0,  0.08537D0,  0.09749D0,
54363      &     0.10801D0,  0.12581D0,  0.14716D0,  0.17390D0,  0.19349D0,
54364      &     0.21930D0,  0.23333D0,  0.23963D0,  0.23986D0,  0.23413D0,
54365      &     0.22447D0,  0.21197D0,  0.19769D0,  0.18248D0,  0.16678D0,
54366      &     0.15094D0,  0.13543D0,  0.12040D0,  0.10608D0,  0.09270D0,
54367      &     0.08031D0,  0.06878D0,  0.05828D0,  0.04908D0,  0.04068D0,
54368      &     0.03329D0,  0.02694D0,  0.02140D0,  0.01285D0,  0.00708D0,
54369      &     0.00346D0,  0.00142D0,  0.00009D0,  0.00000D0/
54370       DATA (FMRS(2,2,I,19),I=1,49)/
54371      &     0.00791D0,  0.00998D0,  0.01261D0,  0.01447D0,  0.01595D0,
54372      &     0.01722D0,  0.02186D0,  0.02794D0,  0.03242D0,  0.03616D0,
54373      &     0.03963D0,  0.05310D0,  0.07234D0,  0.08702D0,  0.09924D0,
54374      &     0.10983D0,  0.12767D0,  0.14895D0,  0.17537D0,  0.19453D0,
54375      &     0.21933D0,  0.23238D0,  0.23773D0,  0.23696D0,  0.23039D0,
54376      &     0.22010D0,  0.20715D0,  0.19257D0,  0.17716D0,  0.16147D0,
54377      &     0.14570D0,  0.13034D0,  0.11556D0,  0.10152D0,  0.08847D0,
54378      &     0.07643D0,  0.06526D0,  0.05515D0,  0.04631D0,  0.03827D0,
54379      &     0.03122D0,  0.02519D0,  0.01995D0,  0.01190D0,  0.00650D0,
54380      &     0.00315D0,  0.00128D0,  0.00008D0,  0.00000D0/
54381       DATA (FMRS(2,2,I,20),I=1,49)/
54382      &     0.00799D0,  0.01010D0,  0.01278D0,  0.01467D0,  0.01619D0,
54383      &     0.01748D0,  0.02223D0,  0.02844D0,  0.03302D0,  0.03684D0,
54384      &     0.04038D0,  0.05409D0,  0.07362D0,  0.08846D0,  0.10078D0,
54385      &     0.11143D0,  0.12930D0,  0.15050D0,  0.17662D0,  0.19539D0,
54386      &     0.21931D0,  0.23148D0,  0.23602D0,  0.23438D0,  0.22712D0,
54387      &     0.21628D0,  0.20296D0,  0.18814D0,  0.17260D0,  0.15692D0,
54388      &     0.14124D0,  0.12600D0,  0.11146D0,  0.09768D0,  0.08490D0,
54389      &     0.07317D0,  0.06233D0,  0.05253D0,  0.04400D0,  0.03627D0,
54390      &     0.02950D0,  0.02375D0,  0.01875D0,  0.01112D0,  0.00604D0,
54391      &     0.00291D0,  0.00117D0,  0.00007D0,  0.00000D0/
54392       DATA (FMRS(2,2,I,21),I=1,49)/
54393      &     0.00806D0,  0.01021D0,  0.01293D0,  0.01486D0,  0.01641D0,
54394      &     0.01772D0,  0.02256D0,  0.02890D0,  0.03357D0,  0.03747D0,
54395      &     0.04106D0,  0.05501D0,  0.07479D0,  0.08976D0,  0.10217D0,
54396      &     0.11285D0,  0.13073D0,  0.15184D0,  0.17768D0,  0.19608D0,
54397      &     0.21918D0,  0.23055D0,  0.23436D0,  0.23195D0,  0.22407D0,
54398      &     0.21277D0,  0.19913D0,  0.18411D0,  0.16851D0,  0.15282D0,
54399      &     0.13724D0,  0.12215D0,  0.10780D0,  0.09426D0,  0.08175D0,
54400      &     0.07030D0,  0.05975D0,  0.05024D0,  0.04199D0,  0.03453D0,
54401      &     0.02802D0,  0.02251D0,  0.01772D0,  0.01045D0,  0.00564D0,
54402      &     0.00270D0,  0.00108D0,  0.00006D0,  0.00000D0/
54403       DATA (FMRS(2,2,I,22),I=1,49)/
54404      &     0.00816D0,  0.01035D0,  0.01313D0,  0.01511D0,  0.01669D0,
54405      &     0.01803D0,  0.02299D0,  0.02949D0,  0.03427D0,  0.03826D0,
54406      &     0.04194D0,  0.05616D0,  0.07626D0,  0.09141D0,  0.10390D0,
54407      &     0.11463D0,  0.13252D0,  0.15350D0,  0.17897D0,  0.19689D0,
54408      &     0.21895D0,  0.22932D0,  0.23223D0,  0.22887D0,  0.22024D0,
54409      &     0.20839D0,  0.19437D0,  0.17913D0,  0.16346D0,  0.14778D0,
54410      &     0.13233D0,  0.11744D0,  0.10335D0,  0.09011D0,  0.07794D0,
54411      &     0.06684D0,  0.05665D0,  0.04749D0,  0.03958D0,  0.03245D0,
54412      &     0.02625D0,  0.02103D0,  0.01650D0,  0.00967D0,  0.00518D0,
54413      &     0.00246D0,  0.00097D0,  0.00005D0,  0.00000D0/
54414       DATA (FMRS(2,2,I,23),I=1,49)/
54415      &     0.00826D0,  0.01049D0,  0.01333D0,  0.01534D0,  0.01695D0,
54416      &     0.01833D0,  0.02340D0,  0.03004D0,  0.03494D0,  0.03901D0,
54417      &     0.04276D0,  0.05725D0,  0.07764D0,  0.09293D0,  0.10551D0,
54418      &     0.11628D0,  0.13416D0,  0.15502D0,  0.18011D0,  0.19758D0,
54419      &     0.21867D0,  0.22812D0,  0.23018D0,  0.22598D0,  0.21667D0,
54420      &     0.20434D0,  0.19000D0,  0.17460D0,  0.15883D0,  0.14320D0,
54421      &     0.12787D0,  0.11321D0,  0.09934D0,  0.08640D0,  0.07454D0,
54422      &     0.06376D0,  0.05389D0,  0.04504D0,  0.03744D0,  0.03063D0,
54423      &     0.02471D0,  0.01973D0,  0.01544D0,  0.00899D0,  0.00479D0,
54424      &     0.00225D0,  0.00088D0,  0.00005D0,  0.00000D0/
54425       DATA (FMRS(2,2,I,24),I=1,49)/
54426      &     0.00835D0,  0.01062D0,  0.01351D0,  0.01556D0,  0.01721D0,
54427      &     0.01861D0,  0.02378D0,  0.03057D0,  0.03556D0,  0.03972D0,
54428      &     0.04354D0,  0.05827D0,  0.07891D0,  0.09434D0,  0.10698D0,
54429      &     0.11778D0,  0.13564D0,  0.15636D0,  0.18108D0,  0.19811D0,
54430      &     0.21829D0,  0.22687D0,  0.22819D0,  0.22319D0,  0.21330D0,
54431      &     0.20053D0,  0.18593D0,  0.17036D0,  0.15459D0,  0.13902D0,
54432      &     0.12383D0,  0.10936D0,  0.09573D0,  0.08306D0,  0.07149D0,
54433      &     0.06100D0,  0.05144D0,  0.04289D0,  0.03556D0,  0.02901D0,
54434      &     0.02335D0,  0.01859D0,  0.01451D0,  0.00840D0,  0.00444D0,
54435      &     0.00208D0,  0.00081D0,  0.00004D0,  0.00000D0/
54436       DATA (FMRS(2,2,I,25),I=1,49)/
54437      &     0.00844D0,  0.01075D0,  0.01369D0,  0.01578D0,  0.01746D0,
54438      &     0.01889D0,  0.02417D0,  0.03109D0,  0.03619D0,  0.04043D0,
54439      &     0.04431D0,  0.05929D0,  0.08018D0,  0.09573D0,  0.10844D0,
54440      &     0.11926D0,  0.13709D0,  0.15767D0,  0.18202D0,  0.19861D0,
54441      &     0.21788D0,  0.22561D0,  0.22620D0,  0.22044D0,  0.20998D0,
54442      &     0.19681D0,  0.18196D0,  0.16625D0,  0.15048D0,  0.13499D0,
54443      &     0.11994D0,  0.10567D0,  0.09228D0,  0.07987D0,  0.06858D0,
54444      &     0.05838D0,  0.04911D0,  0.04085D0,  0.03379D0,  0.02749D0,
54445      &     0.02207D0,  0.01753D0,  0.01364D0,  0.00785D0,  0.00413D0,
54446      &     0.00192D0,  0.00074D0,  0.00004D0,  0.00000D0/
54447       DATA (FMRS(2,2,I,26),I=1,49)/
54448      &     0.00853D0,  0.01088D0,  0.01388D0,  0.01600D0,  0.01772D0,
54449      &     0.01917D0,  0.02456D0,  0.03161D0,  0.03680D0,  0.04112D0,
54450      &     0.04508D0,  0.06028D0,  0.08140D0,  0.09707D0,  0.10983D0,
54451      &     0.12067D0,  0.13846D0,  0.15889D0,  0.18286D0,  0.19901D0,
54452      &     0.21739D0,  0.22430D0,  0.22419D0,  0.21773D0,  0.20672D0,
54453      &     0.19320D0,  0.17811D0,  0.16233D0,  0.14654D0,  0.13113D0,
54454      &     0.11622D0,  0.10216D0,  0.08901D0,  0.07686D0,  0.06584D0,
54455      &     0.05592D0,  0.04692D0,  0.03894D0,  0.03214D0,  0.02608D0,
54456      &     0.02089D0,  0.01655D0,  0.01285D0,  0.00735D0,  0.00384D0,
54457      &     0.00177D0,  0.00068D0,  0.00003D0,  0.00000D0/
54458       DATA (FMRS(2,2,I,27),I=1,49)/
54459      &     0.00862D0,  0.01100D0,  0.01405D0,  0.01622D0,  0.01796D0,
54460      &     0.01944D0,  0.02492D0,  0.03211D0,  0.03739D0,  0.04178D0,
54461      &     0.04580D0,  0.06121D0,  0.08256D0,  0.09833D0,  0.11114D0,
54462      &     0.12198D0,  0.13974D0,  0.16000D0,  0.18361D0,  0.19934D0,
54463      &     0.21688D0,  0.22303D0,  0.22227D0,  0.21516D0,  0.20368D0,
54464      &     0.18983D0,  0.17455D0,  0.15870D0,  0.14292D0,  0.12759D0,
54465      &     0.11282D0,  0.09895D0,  0.08604D0,  0.07413D0,  0.06336D0,
54466      &     0.05370D0,  0.04495D0,  0.03722D0,  0.03066D0,  0.02482D0,
54467      &     0.01983D0,  0.01568D0,  0.01214D0,  0.00691D0,  0.00359D0,
54468      &     0.00164D0,  0.00063D0,  0.00003D0,  0.00000D0/
54469       DATA (FMRS(2,2,I,28),I=1,49)/
54470      &     0.00871D0,  0.01113D0,  0.01422D0,  0.01642D0,  0.01819D0,
54471      &     0.01970D0,  0.02527D0,  0.03257D0,  0.03795D0,  0.04240D0,
54472      &     0.04648D0,  0.06209D0,  0.08364D0,  0.09950D0,  0.11235D0,
54473      &     0.12320D0,  0.14090D0,  0.16101D0,  0.18426D0,  0.19960D0,
54474      &     0.21635D0,  0.22178D0,  0.22043D0,  0.21273D0,  0.20082D0,
54475      &     0.18670D0,  0.17123D0,  0.15532D0,  0.13957D0,  0.12434D0,
54476      &     0.10972D0,  0.09602D0,  0.08332D0,  0.07164D0,  0.06111D0,
54477      &     0.05170D0,  0.04318D0,  0.03568D0,  0.02933D0,  0.02371D0,
54478      &     0.01889D0,  0.01491D0,  0.01151D0,  0.00652D0,  0.00337D0,
54479      &     0.00153D0,  0.00058D0,  0.00003D0,  0.00000D0/
54480       DATA (FMRS(2,2,I,29),I=1,49)/
54481      &     0.00880D0,  0.01125D0,  0.01439D0,  0.01662D0,  0.01842D0,
54482      &     0.01995D0,  0.02562D0,  0.03305D0,  0.03850D0,  0.04303D0,
54483      &     0.04716D0,  0.06297D0,  0.08471D0,  0.10067D0,  0.11354D0,
54484      &     0.12440D0,  0.14205D0,  0.16199D0,  0.18487D0,  0.19981D0,
54485      &     0.21577D0,  0.22050D0,  0.21856D0,  0.21030D0,  0.19797D0,
54486      &     0.18358D0,  0.16796D0,  0.15200D0,  0.13629D0,  0.12116D0,
54487      &     0.10670D0,  0.09318D0,  0.08069D0,  0.06924D0,  0.05894D0,
54488      &     0.04976D0,  0.04148D0,  0.03421D0,  0.02806D0,  0.02263D0,
54489      &     0.01799D0,  0.01417D0,  0.01091D0,  0.00615D0,  0.00316D0,
54490      &     0.00143D0,  0.00054D0,  0.00003D0,  0.00000D0/
54491       DATA (FMRS(2,2,I,30),I=1,49)/
54492      &     0.00889D0,  0.01137D0,  0.01456D0,  0.01683D0,  0.01865D0,
54493      &     0.02021D0,  0.02596D0,  0.03351D0,  0.03906D0,  0.04365D0,
54494      &     0.04784D0,  0.06384D0,  0.08576D0,  0.10180D0,  0.11470D0,
54495      &     0.12555D0,  0.14314D0,  0.16292D0,  0.18544D0,  0.19997D0,
54496      &     0.21516D0,  0.21921D0,  0.21670D0,  0.20790D0,  0.19518D0,
54497      &     0.18054D0,  0.16480D0,  0.14880D0,  0.13314D0,  0.11810D0,
54498      &     0.10380D0,  0.09048D0,  0.07819D0,  0.06696D0,  0.05688D0,
54499      &     0.04793D0,  0.03987D0,  0.03282D0,  0.02686D0,  0.02162D0,
54500      &     0.01715D0,  0.01347D0,  0.01036D0,  0.00581D0,  0.00297D0,
54501      &     0.00134D0,  0.00050D0,  0.00002D0,  0.00000D0/
54502       DATA (FMRS(2,2,I,31),I=1,49)/
54503      &     0.00897D0,  0.01149D0,  0.01472D0,  0.01702D0,  0.01887D0,
54504      &     0.02045D0,  0.02630D0,  0.03396D0,  0.03958D0,  0.04424D0,
54505      &     0.04848D0,  0.06466D0,  0.08676D0,  0.10286D0,  0.11579D0,
54506      &     0.12663D0,  0.14416D0,  0.16377D0,  0.18594D0,  0.20009D0,
54507      &     0.21455D0,  0.21797D0,  0.21493D0,  0.20563D0,  0.19256D0,
54508      &     0.17769D0,  0.16185D0,  0.14582D0,  0.13021D0,  0.11528D0,
54509      &     0.10112D0,  0.08798D0,  0.07588D0,  0.06486D0,  0.05500D0,
54510      &     0.04626D0,  0.03841D0,  0.03155D0,  0.02578D0,  0.02071D0,
54511      &     0.01640D0,  0.01285D0,  0.00986D0,  0.00551D0,  0.00280D0,
54512      &     0.00125D0,  0.00046D0,  0.00002D0,  0.00000D0/
54513       DATA (FMRS(2,2,I,32),I=1,49)/
54514      &     0.00905D0,  0.01160D0,  0.01487D0,  0.01721D0,  0.01909D0,
54515      &     0.02069D0,  0.02661D0,  0.03438D0,  0.04008D0,  0.04480D0,
54516      &     0.04909D0,  0.06543D0,  0.08768D0,  0.10385D0,  0.11679D0,
54517      &     0.12763D0,  0.14509D0,  0.16454D0,  0.18637D0,  0.20016D0,
54518      &     0.21393D0,  0.21676D0,  0.21323D0,  0.20346D0,  0.19008D0,
54519      &     0.17502D0,  0.15909D0,  0.14304D0,  0.12749D0,  0.11266D0,
54520      &     0.09863D0,  0.08567D0,  0.07376D0,  0.06293D0,  0.05328D0,
54521      &     0.04474D0,  0.03708D0,  0.03039D0,  0.02479D0,  0.01988D0,
54522      &     0.01572D0,  0.01229D0,  0.00941D0,  0.00524D0,  0.00265D0,
54523      &     0.00118D0,  0.00043D0,  0.00002D0,  0.00000D0/
54524       DATA (FMRS(2,2,I,33),I=1,49)/
54525      &     0.00914D0,  0.01172D0,  0.01503D0,  0.01740D0,  0.01930D0,
54526      &     0.02092D0,  0.02693D0,  0.03481D0,  0.04058D0,  0.04536D0,
54527      &     0.04970D0,  0.06621D0,  0.08862D0,  0.10485D0,  0.11781D0,
54528      &     0.12863D0,  0.14602D0,  0.16531D0,  0.18679D0,  0.20022D0,
54529      &     0.21330D0,  0.21555D0,  0.21154D0,  0.20131D0,  0.18763D0,
54530      &     0.17238D0,  0.15637D0,  0.14031D0,  0.12482D0,  0.11010D0,
54531      &     0.09620D0,  0.08342D0,  0.07168D0,  0.06106D0,  0.05161D0,
54532      &     0.04326D0,  0.03580D0,  0.02928D0,  0.02384D0,  0.01908D0,
54533      &     0.01506D0,  0.01176D0,  0.00899D0,  0.00498D0,  0.00251D0,
54534      &     0.00111D0,  0.00041D0,  0.00002D0,  0.00000D0/
54535       DATA (FMRS(2,2,I,34),I=1,49)/
54536      &     0.00922D0,  0.01183D0,  0.01519D0,  0.01758D0,  0.01951D0,
54537      &     0.02116D0,  0.02725D0,  0.03523D0,  0.04108D0,  0.04592D0,
54538      &     0.05030D0,  0.06698D0,  0.08953D0,  0.10581D0,  0.11878D0,
54539      &     0.12959D0,  0.14690D0,  0.16601D0,  0.18715D0,  0.20021D0,
54540      &     0.21262D0,  0.21429D0,  0.20982D0,  0.19916D0,  0.18519D0,
54541      &     0.16977D0,  0.15369D0,  0.13763D0,  0.12221D0,  0.10760D0,
54542      &     0.09385D0,  0.08123D0,  0.06969D0,  0.05926D0,  0.05001D0,
54543      &     0.04183D0,  0.03456D0,  0.02822D0,  0.02295D0,  0.01833D0,
54544      &     0.01444D0,  0.01126D0,  0.00858D0,  0.00473D0,  0.00238D0,
54545      &     0.00105D0,  0.00038D0,  0.00002D0,  0.00000D0/
54546       DATA (FMRS(2,2,I,35),I=1,49)/
54547      &     0.00930D0,  0.01194D0,  0.01534D0,  0.01777D0,  0.01972D0,
54548      &     0.02138D0,  0.02755D0,  0.03564D0,  0.04156D0,  0.04645D0,
54549      &     0.05088D0,  0.06771D0,  0.09039D0,  0.10673D0,  0.11970D0,
54550      &     0.13050D0,  0.14773D0,  0.16667D0,  0.18748D0,  0.20020D0,
54551      &     0.21197D0,  0.21309D0,  0.20820D0,  0.19714D0,  0.18290D0,
54552      &     0.16734D0,  0.15119D0,  0.13514D0,  0.11978D0,  0.10528D0,
54553      &     0.09167D0,  0.07922D0,  0.06786D0,  0.05760D0,  0.04853D0,
54554      &     0.04052D0,  0.03343D0,  0.02726D0,  0.02213D0,  0.01765D0,
54555      &     0.01387D0,  0.01080D0,  0.00822D0,  0.00451D0,  0.00226D0,
54556      &     0.00099D0,  0.00036D0,  0.00002D0,  0.00000D0/
54557       DATA (FMRS(2,2,I,36),I=1,49)/
54558      &     0.00938D0,  0.01205D0,  0.01549D0,  0.01794D0,  0.01992D0,
54559      &     0.02160D0,  0.02784D0,  0.03602D0,  0.04201D0,  0.04696D0,
54560      &     0.05143D0,  0.06840D0,  0.09121D0,  0.10758D0,  0.12056D0,
54561      &     0.13134D0,  0.14849D0,  0.16728D0,  0.18776D0,  0.20016D0,
54562      &     0.21132D0,  0.21194D0,  0.20664D0,  0.19522D0,  0.18074D0,
54563      &     0.16504D0,  0.14884D0,  0.13281D0,  0.11752D0,  0.10313D0,
54564      &     0.08965D0,  0.07735D0,  0.06616D0,  0.05608D0,  0.04717D0,
54565      &     0.03933D0,  0.03239D0,  0.02637D0,  0.02137D0,  0.01702D0,
54566      &     0.01336D0,  0.01038D0,  0.00788D0,  0.00431D0,  0.00215D0,
54567      &     0.00094D0,  0.00034D0,  0.00001D0,  0.00000D0/
54568       DATA (FMRS(2,2,I,37),I=1,49)/
54569      &     0.00946D0,  0.01216D0,  0.01563D0,  0.01812D0,  0.02011D0,
54570      &     0.02182D0,  0.02814D0,  0.03641D0,  0.04247D0,  0.04747D0,
54571      &     0.05199D0,  0.06909D0,  0.09202D0,  0.10844D0,  0.12142D0,
54572      &     0.13217D0,  0.14925D0,  0.16786D0,  0.18802D0,  0.20008D0,
54573      &     0.21063D0,  0.21075D0,  0.20506D0,  0.19327D0,  0.17856D0,
54574      &     0.16274D0,  0.14648D0,  0.13048D0,  0.11526D0,  0.10099D0,
54575      &     0.08766D0,  0.07551D0,  0.06448D0,  0.05458D0,  0.04583D0,
54576      &     0.03816D0,  0.03137D0,  0.02550D0,  0.02064D0,  0.01641D0,
54577      &     0.01285D0,  0.00997D0,  0.00756D0,  0.00412D0,  0.00204D0,
54578      &     0.00089D0,  0.00032D0,  0.00001D0,  0.00000D0/
54579       DATA (FMRS(2,2,I,38),I=1,49)/
54580      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54581      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54582      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54583      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54584      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54585      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54586      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54587      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54588      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
54589      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
54590       DATA (FMRS(2,3,I, 1),I=1,49)/
54591      &     2.49594D0,  2.59678D0,  2.70121D0,  2.76381D0,  2.80882D0,
54592      &     2.84400D0,  2.95410D0,  3.06293D0,  3.12376D0,  3.16433D0,
54593      &     3.19612D0,  3.26381D0,  3.24185D0,  3.15396D0,  3.04339D0,
54594      &     2.92461D0,  2.68378D0,  2.34265D0,  1.85814D0,  1.47710D0,
54595      &     0.96403D0,  0.68739D0,  0.56164D0,  0.53053D0,  0.57114D0,
54596      &     0.63752D0,  0.70266D0,  0.75190D0,  0.77864D0,  0.78165D0,
54597      &     0.76223D0,  0.72410D0,  0.67143D0,  0.60861D0,  0.54010D0,
54598      &     0.46946D0,  0.39966D0,  0.33340D0,  0.27271D0,  0.21796D0,
54599      &     0.17035D0,  0.13022D0,  0.09678D0,  0.04919D0,  0.02174D0,
54600      &     0.00799D0,  0.00226D0,  0.00004D0,  0.00000D0/
54601       DATA (FMRS(2,3,I, 2),I=1,49)/
54602      &     4.92533D0,  4.79050D0,  4.65910D0,  4.58370D0,  4.53079D0,
54603      &     4.49006D0,  4.36491D0,  4.24084D0,  4.16793D0,  4.11560D0,
54604      &     4.07957D0,  3.94076D0,  3.72768D0,  3.53640D0,  3.35786D0,
54605      &     3.19001D0,  2.88282D0,  2.48367D0,  1.95213D0,  1.55132D0,
54606      &     1.02835D0,  0.75268D0,  0.62744D0,  0.59181D0,  0.62218D0,
54607      &     0.67462D0,  0.72413D0,  0.75779D0,  0.77032D0,  0.76124D0,
54608      &     0.73236D0,  0.68747D0,  0.63069D0,  0.56612D0,  0.49789D0,
54609      &     0.42912D0,  0.36239D0,  0.29993D0,  0.24354D0,  0.19324D0,
54610      &     0.14994D0,  0.11382D0,  0.08400D0,  0.04209D0,  0.01833D0,
54611      &     0.00664D0,  0.00185D0,  0.00003D0,  0.00000D0/
54612       DATA (FMRS(2,3,I, 3),I=1,49)/
54613      &     9.56993D0,  8.80858D0,  8.10702D0,  7.72221D0,  7.45989D0,
54614      &     7.26226D0,  6.67868D0,  6.13604D0,  5.83460D0,  5.62657D0,
54615      &     5.47187D0,  4.98498D0,  4.45878D0,  4.10350D0,  3.81920D0,
54616      &     3.57625D0,  3.16921D0,  2.68460D0,  2.08542D0,  1.65674D0,
54617      &     1.11953D0,  0.84374D0,  0.71690D0,  0.67195D0,  0.68567D0,
54618      &     0.71718D0,  0.74433D0,  0.75653D0,  0.75014D0,  0.72558D0,
54619      &     0.68509D0,  0.63243D0,  0.57149D0,  0.50592D0,  0.43925D0,
54620      &     0.37400D0,  0.31223D0,  0.25550D0,  0.20529D0,  0.16120D0,
54621      &     0.12380D0,  0.09303D0,  0.06796D0,  0.03337D0,  0.01425D0,
54622      &     0.00506D0,  0.00138D0,  0.00002D0,  0.00000D0/
54623       DATA (FMRS(2,3,I, 4),I=1,49)/
54624      &    13.80940D0, 12.36505D0, 11.07010D0, 10.37511D0,  9.90777D0,
54625      &     9.55916D0,  8.54772D0,  7.63175D0,  7.13319D0,  6.79336D0,
54626      &     6.53831D0,  5.76591D0,  4.99154D0,  4.51033D0,  4.14636D0,
54627      &     3.84778D0,  3.36791D0,  2.82235D0,  2.17611D0,  1.72845D0,
54628      &     1.18134D0,  0.90432D0,  0.77478D0,  0.72147D0,  0.72239D0,
54629      &     0.73883D0,  0.75059D0,  0.74861D0,  0.73014D0,  0.69610D0,
54630      &     0.64889D0,  0.59216D0,  0.52949D0,  0.46423D0,  0.39938D0,
54631      &     0.33717D0,  0.27919D0,  0.22665D0,  0.18078D0,  0.14088D0,
54632      &     0.10742D0,  0.08015D0,  0.05814D0,  0.02814D0,  0.01185D0,
54633      &     0.00415D0,  0.00112D0,  0.00002D0,  0.00000D0/
54634       DATA (FMRS(2,3,I, 5),I=1,49)/
54635      &    18.88911D0, 16.54105D0, 14.48190D0, 13.39606D0, 12.67388D0,
54636      &    12.13950D0, 10.61083D0,  9.25560D0,  8.52999D0,  8.04031D0,
54637      &     7.67199D0,  6.58349D0,  5.54112D0,  4.92668D0,  4.47939D0,
54638      &     4.12305D0,  3.56848D0,  2.96102D0,  2.26733D0,  1.80038D0,
54639      &     1.24179D0,  0.96142D0,  0.82726D0,  0.76409D0,  0.75165D0,
54640      &     0.75317D0,  0.75022D0,  0.73504D0,  0.70570D0,  0.66340D0,
54641      &     0.61066D0,  0.55093D0,  0.48745D0,  0.42321D0,  0.36077D0,
54642      &     0.30193D0,  0.24792D0,  0.19962D0,  0.15797D0,  0.12220D0,
54643      &     0.09245D0,  0.06850D0,  0.04934D0,  0.02353D0,  0.00976D0,
54644      &     0.00337D0,  0.00090D0,  0.00002D0,  0.00000D0/
54645       DATA (FMRS(2,3,I, 6),I=1,49)/
54646      &    24.17862D0, 20.81157D0, 17.90894D0, 16.39907D0, 15.40344D0,
54647      &    14.67132D0, 12.59987D0, 10.79385D0,  9.83948D0,  9.20057D0,
54648      &     8.72036D0,  7.32519D0,  6.02998D0,  5.29291D0,  4.77007D0,
54649      &     4.36196D0,  3.74120D0,  3.07968D0,  2.34504D0,  1.86151D0,
54650      &     1.29269D0,  1.00884D0,  0.87005D0,  0.79769D0,  0.77342D0,
54651      &     0.76224D0,  0.74721D0,  0.72151D0,  0.68376D0,  0.63535D0,
54652      &     0.57871D0,  0.51714D0,  0.45352D0,  0.39051D0,  0.33033D0,
54653      &     0.27444D0,  0.22374D0,  0.17892D0,  0.14065D0,  0.10811D0,
54654      &     0.08127D0,  0.05985D0,  0.04284D0,  0.02018D0,  0.00827D0,
54655      &     0.00283D0,  0.00075D0,  0.00001D0,  0.00000D0/
54656       DATA (FMRS(2,3,I, 7),I=1,49)/
54657      &    29.73861D0, 25.23818D0, 21.41267D0, 19.44500D0, 18.15658D0,
54658      &    17.21404D0, 14.57125D0, 12.29875D0, 11.11092D0, 10.32111D0,
54659      &     9.72854D0,  8.02926D0,  6.48794D0,  5.63342D0,  5.03891D0,
54660      &     4.58210D0,  3.89945D0,  3.18799D0,  2.41570D0,  1.91680D0,
54661      &     1.33767D0,  1.04936D0,  0.90523D0,  0.82366D0,  0.78841D0,
54662      &     0.76591D0,  0.74039D0,  0.70578D0,  0.66114D0,  0.60793D0,
54663      &     0.54844D0,  0.48585D0,  0.42265D0,  0.36114D0,  0.30329D0,
54664      &     0.25030D0,  0.20271D0,  0.16106D0,  0.12587D0,  0.09616D0,
54665      &     0.07187D0,  0.05262D0,  0.03744D0,  0.01745D0,  0.00707D0,
54666      &     0.00239D0,  0.00063D0,  0.00001D0,  0.00000D0/
54667       DATA (FMRS(2,3,I, 8),I=1,49)/
54668      &    36.41777D0, 30.48425D0, 25.50925D0, 22.97827D0, 21.33235D0,
54669      &    20.13434D0, 16.80486D0, 13.98059D0, 12.52029D0, 11.55588D0,
54670      &    10.83420D0,  8.78991D0,  6.97511D0,  5.99232D0,  5.32046D0,
54671      &     4.81154D0,  4.06330D0,  3.29938D0,  2.48793D0,  1.97297D0,
54672      &     1.38262D0,  1.08896D0,  0.93866D0,  0.84707D0,  0.80034D0,
54673      &     0.76640D0,  0.73057D0,  0.68748D0,  0.63647D0,  0.57905D0,
54674      &     0.51730D0,  0.45416D0,  0.39180D0,  0.33216D0,  0.27689D0,
54675      &     0.22693D0,  0.18251D0,  0.14405D0,  0.11189D0,  0.08494D0,
54676      &     0.06310D0,  0.04592D0,  0.03248D0,  0.01496D0,  0.00600D0,
54677      &     0.00201D0,  0.00052D0,  0.00001D0,  0.00000D0/
54678       DATA (FMRS(2,3,I, 9),I=1,49)/
54679      &    42.89913D0, 35.51439D0, 29.39055D0, 26.30256D0, 24.30551D0,
54680      &    22.85784D0, 18.86316D0, 15.51177D0, 13.79420D0, 12.66617D0,
54681      &    11.82423D0,  9.46212D0,  7.39982D0,  6.30264D0,  5.56252D0,
54682      &     5.00794D0,  4.20275D0,  3.39360D0,  2.54868D0,  2.01994D0,
54683      &     1.41958D0,  1.12075D0,  0.96469D0,  0.86425D0,  0.80777D0,
54684      &     0.76439D0,  0.72030D0,  0.67061D0,  0.61480D0,  0.55436D0,
54685      &     0.49120D0,  0.42796D0,  0.36659D0,  0.30874D0,  0.25576D0,
54686      &     0.20835D0,  0.16660D0,  0.13075D0,  0.10101D0,  0.07629D0,
54687      &     0.05637D0,  0.04082D0,  0.02872D0,  0.01310D0,  0.00521D0,
54688      &     0.00173D0,  0.00045D0,  0.00001D0,  0.00000D0/
54689       DATA (FMRS(2,3,I,10),I=1,49)/
54690      &    49.61974D0, 40.67585D0, 33.33157D0, 29.65726D0, 27.29273D0,
54691      &    25.58490D0, 20.90223D0, 17.01226D0, 15.03449D0, 13.74211D0,
54692      &    12.78005D0, 10.10345D0,  7.80003D0,  6.59295D0,  5.78776D0,
54693      &     5.18997D0,  4.33113D0,  3.47979D0,  2.60379D0,  2.06215D0,
54694      &     1.45191D0,  1.14765D0,  0.98577D0,  0.87686D0,  0.81144D0,
54695      &     0.75966D0,  0.70838D0,  0.65310D0,  0.59339D0,  0.53065D0,
54696      &     0.46666D0,  0.40372D0,  0.34354D0,  0.28753D0,  0.23679D0,
54697      &     0.19183D0,  0.15254D0,  0.11910D0,  0.09155D0,  0.06880D0,
54698      &     0.05059D0,  0.03647D0,  0.02554D0,  0.01155D0,  0.00456D0,
54699      &     0.00150D0,  0.00039D0,  0.00001D0,  0.00000D0/
54700       DATA (FMRS(2,3,I,11),I=1,49)/
54701      &    55.39180D0, 45.07076D0, 36.65840D0, 32.47479D0, 29.79258D0,
54702      &    27.86062D0, 22.58892D0, 18.24235D0, 16.04583D0, 14.61602D0,
54703      &    13.55394D0, 10.61757D0,  8.11747D0,  6.82180D0,  5.96451D0,
54704      &     5.33234D0,  4.43100D0,  3.54652D0,  2.64619D0,  2.09446D0,
54705      &     1.47626D0,  1.16746D0,  1.00084D0,  0.88523D0,  0.81292D0,
54706      &     0.75482D0,  0.69824D0,  0.63893D0,  0.57653D0,  0.51229D0,
54707      &     0.44790D0,  0.38538D0,  0.32625D0,  0.27173D0,  0.22275D0,
54708      &     0.17969D0,  0.14226D0,  0.11063D0,  0.08472D0,  0.06341D0,
54709      &     0.04647D0,  0.03337D0,  0.02328D0,  0.01046D0,  0.00410D0,
54710      &     0.00135D0,  0.00035D0,  0.00001D0,  0.00000D0/
54711       DATA (FMRS(2,3,I,12),I=1,49)/
54712      &    68.81419D0, 55.16745D0, 44.20809D0, 38.82247D0, 35.39534D0,
54713      &    32.94036D0, 26.30577D0, 20.91710D0, 18.22705D0, 16.48958D0,
54714      &    15.20488D0, 11.69679D0,  8.77186D0,  7.28789D0,  6.32113D0,
54715      &     5.61724D0,  4.62839D0,  3.67636D0,  2.72714D0,  2.15522D0,
54716      &     1.52072D0,  1.20219D0,  1.02548D0,  0.89610D0,  0.81011D0,
54717      &     0.73981D0,  0.67337D0,  0.60686D0,  0.53995D0,  0.47362D0,
54718      &     0.40911D0,  0.34808D0,  0.29158D0,  0.24046D0,  0.19523D0,
54719      &     0.15609D0,  0.12251D0,  0.09445D0,  0.07178D0,  0.05329D0,
54720      &     0.03875D0,  0.02763D0,  0.01914D0,  0.00848D0,  0.00328D0,
54721      &     0.00107D0,  0.00027D0,  0.00001D0,  0.00000D0/
54722       DATA (FMRS(2,3,I,13),I=1,49)/
54723      &    81.72071D0, 64.73620D0, 51.25830D0, 44.69851D0, 40.54929D0,
54724      &    37.59021D0, 29.65526D0, 23.28836D0, 20.14139D0, 18.12166D0,
54725      &    16.63424D0, 12.61228D0,  9.31401D0,  7.66787D0,  6.60816D0,
54726      &     5.84402D0,  4.78269D0,  3.77556D0,  2.78721D0,  2.19932D0,
54727      &     1.55169D0,  1.22492D0,  1.03973D0,  0.89912D0,  0.80240D0,
54728      &     0.72291D0,  0.64937D0,  0.57800D0,  0.50838D0,  0.44121D0,
54729      &     0.37732D0,  0.31807D0,  0.26412D0,  0.21603D0,  0.17402D0,
54730      &     0.13809D0,  0.10760D0,  0.08235D0,  0.06220D0,  0.04588D0,
54731      &     0.03314D0,  0.02349D0,  0.01618D0,  0.00709D0,  0.00272D0,
54732      &     0.00088D0,  0.00022D0,  0.00001D0,  0.00000D0/
54733       DATA (FMRS(2,3,I,14),I=1,49)/
54734      &    97.52657D0, 76.29261D0, 59.65305D0, 51.63612D0, 46.59734D0,
54735      &    43.02061D0, 33.50751D0, 25.97167D0, 22.28590D0, 19.93624D0,
54736      &    18.21366D0, 13.60275D0,  9.88582D0,  8.06142D0,  6.90102D0,
54737      &     6.07241D0,  4.93443D0,  3.87015D0,  2.84210D0,  2.23830D0,
54738      &     1.57740D0,  1.24193D0,  1.04776D0,  0.89562D0,  0.78827D0,
54739      &     0.70003D0,  0.62012D0,  0.54473D0,  0.47326D0,  0.40608D0,
54740      &     0.34362D0,  0.28678D0,  0.23589D0,  0.19121D0,  0.15279D0,
54741      &     0.12024D0,  0.09296D0,  0.07060D0,  0.05295D0,  0.03880D0,
54742      &     0.02782D0,  0.01961D0,  0.01341D0,  0.00581D0,  0.00221D0,
54743      &     0.00071D0,  0.00018D0,  0.00000D0,  0.00000D0/
54744       DATA (FMRS(2,3,I,15),I=1,49)/
54745      &   115.42858D0, 89.21046D0, 68.91241D0, 59.22810D0, 53.17852D0,
54746      &    48.90368D0, 37.62299D0, 28.79719D0, 24.52433D0, 21.81818D0,
54747      &    19.84305D0, 14.60749D0, 10.45530D0,  8.44881D0,  7.18665D0,
54748      &     6.29326D0,  5.07912D0,  3.95881D0,  2.89174D0,  2.27205D0,
54749      &     1.59726D0,  1.25251D0,  1.04935D0,  0.88634D0,  0.76946D0,
54750      &     0.67380D0,  0.58880D0,  0.51059D0,  0.43833D0,  0.37190D0,
54751      &     0.31141D0,  0.25732D0,  0.20974D0,  0.16850D0,  0.13349D0,
54752      &     0.10422D0,  0.07994D0,  0.06028D0,  0.04489D0,  0.03267D0,
54753      &     0.02328D0,  0.01630D0,  0.01109D0,  0.00475D0,  0.00179D0,
54754      &     0.00057D0,  0.00015D0,  0.00000D0,  0.00000D0/
54755       DATA (FMRS(2,3,I,16),I=1,49)/
54756      &   133.20726D0,101.88441D0, 77.88580D0, 66.53202D0, 59.47687D0,
54757      &    54.51081D0, 41.49468D0, 31.41946D0, 26.58451D0, 23.53963D0,
54758      &    21.32609D0, 15.50695D0, 10.95547D0,  8.78473D0,  7.43186D0,
54759      &     6.48132D0,  5.20052D0,  4.03146D0,  2.93090D0,  2.29753D0,
54760      &     1.61041D0,  1.25744D0,  1.04659D0,  0.87462D0,  0.75027D0,
54761      &     0.64906D0,  0.56054D0,  0.48074D0,  0.40844D0,  0.34317D0,
54762      &     0.28476D0,  0.23329D0,  0.18860D0,  0.15037D0,  0.11827D0,
54763      &     0.09171D0,  0.06985D0,  0.05235D0,  0.03876D0,  0.02805D0,
54764      &     0.01988D0,  0.01385D0,  0.00937D0,  0.00398D0,  0.00150D0,
54765      &     0.00048D0,  0.00012D0,  0.00000D0,  0.00000D0/
54766       DATA (FMRS(2,3,I,17),I=1,49)/
54767      &   152.75288D0,115.66533D0, 87.53463D0, 74.33386D0, 66.17272D0,
54768      &    60.44971D0, 45.54741D0, 34.13087D0, 28.69873D0, 25.29647D0,
54769      &    22.83273D0, 16.40709D0, 11.44748D0,  9.11138D0,  7.66812D0,
54770      &     6.66113D0,  5.31487D0,  4.09842D0,  2.96558D0,  2.31899D0,
54771      &     1.61977D0,  1.25878D0,  1.04063D0,  0.86046D0,  0.72956D0,
54772      &     0.62377D0,  0.53260D0,  0.45191D0,  0.38010D0,  0.31636D0,
54773      &     0.26019D0,  0.21141D0,  0.16955D0,  0.13419D0,  0.10481D0,
54774      &     0.08073D0,  0.06109D0,  0.04550D0,  0.03350D0,  0.02411D0,
54775      &     0.01700D0,  0.01178D0,  0.00794D0,  0.00335D0,  0.00125D0,
54776      &     0.00040D0,  0.00010D0,  0.00000D0,  0.00000D0/
54777       DATA (FMRS(2,3,I,18),I=1,49)/
54778      &   170.01192D0,127.71370D0, 95.88535D0, 81.04548D0, 71.90795D0,
54779      &    65.51928D0, 48.96956D0, 36.39437D0, 30.45131D0, 26.74517D0,
54780      &    24.06967D0, 17.13549D0, 11.83889D0,  9.36824D0,  7.85201D0,
54781      &     6.79985D0,  5.40144D0,  4.14772D0,  2.98965D0,  2.33267D0,
54782      &     1.62383D0,  1.25653D0,  1.03280D0,  0.84662D0,  0.71111D0,
54783      &     0.60235D0,  0.50969D0,  0.42880D0,  0.35778D0,  0.29558D0,
54784      &     0.24138D0,  0.19483D0,  0.15529D0,  0.12217D0,  0.09488D0,
54785      &     0.07271D0,  0.05474D0,  0.04057D0,  0.02974D0,  0.02131D0,
54786      &     0.01497D0,  0.01034D0,  0.00694D0,  0.00291D0,  0.00108D0,
54787      &     0.00035D0,  0.00009D0,  0.00000D0,  0.00000D0/
54788       DATA (FMRS(2,3,I,19),I=1,49)/
54789      &   192.21783D0,143.06714D0,106.42301D0, 89.46533D0, 79.07272D0,
54790      &    71.83153D0, 53.18588D0, 39.15232D0, 32.57201D0, 28.48916D0,
54791      &    25.55252D0, 17.99626D0, 12.29353D0,  9.66291D0,  8.06074D0,
54792      &     6.95556D0,  5.49677D0,  4.20023D0,  3.01333D0,  2.34451D0,
54793      &     1.62470D0,  1.25025D0,  1.02039D0,  0.82787D0,  0.68779D0,
54794      &     0.57628D0,  0.48256D0,  0.40194D0,  0.33226D0,  0.27214D0,
54795      &     0.22041D0,  0.17653D0,  0.13970D0,  0.10915D0,  0.08422D0,
54796      &     0.06416D0,  0.04803D0,  0.03538D0,  0.02582D0,  0.01841D0,
54797      &     0.01287D0,  0.00885D0,  0.00592D0,  0.00247D0,  0.00092D0,
54798      &     0.00029D0,  0.00008D0,  0.00000D0,  0.00000D0/
54799       DATA (FMRS(2,3,I,20),I=1,49)/
54800      &   213.34880D0,157.54303D0,116.26574D0, 97.28644D0, 85.70139D0,
54801      &    77.65329D0, 57.03621D0, 41.64487D0, 34.47643D0, 30.04790D0,
54802      &    26.87277D0, 18.75275D0, 12.68704D0,  9.91527D0,  8.23788D0,
54803      &     7.08656D0,  5.57571D0,  4.24254D0,  3.03117D0,  2.35234D0,
54804      &     1.62325D0,  1.24282D0,  1.00799D0,  0.81051D0,  0.66705D0,
54805      &     0.55370D0,  0.45951D0,  0.37948D0,  0.31121D0,  0.25302D0,
54806      &     0.20347D0,  0.16190D0,  0.12732D0,  0.09891D0,  0.07590D0,
54807      &     0.05752D0,  0.04285D0,  0.03141D0,  0.02283D0,  0.01621D0,
54808      &     0.01129D0,  0.00774D0,  0.00517D0,  0.00215D0,  0.00079D0,
54809      &     0.00025D0,  0.00007D0,  0.00000D0,  0.00000D0/
54810       DATA (FMRS(2,3,I,21),I=1,49)/
54811      &   233.39284D0,171.15466D0,125.43786D0,104.53514D0, 91.82097D0,
54812      &    83.01126D0, 60.54451D0, 43.89167D0, 36.18145D0, 31.43626D0,
54813      &    28.04374D0, 19.41375D0, 13.02433D0, 10.12820D0,  8.38525D0,
54814      &     7.19405D0,  5.63853D0,  4.27419D0,  3.04230D0,  2.35510D0,
54815      &     1.61821D0,  1.23292D0,  0.99418D0,  0.79299D0,  0.64721D0,
54816      &     0.53284D0,  0.43872D0,  0.35966D0,  0.29291D0,  0.23658D0,
54817      &     0.18910D0,  0.14961D0,  0.11702D0,  0.09045D0,  0.06907D0,
54818      &     0.05212D0,  0.03865D0,  0.02823D0,  0.02044D0,  0.01446D0,
54819      &     0.01004D0,  0.00687D0,  0.00457D0,  0.00189D0,  0.00070D0,
54820      &     0.00022D0,  0.00006D0,  0.00000D0,  0.00000D0/
54821       DATA (FMRS(2,3,I,22),I=1,49)/
54822      &   260.44016D0,189.36696D0,137.60457D0,114.10131D0, 99.86725D0,
54823      &    90.03576D0, 65.10178D0, 46.78208D0, 38.36169D0, 33.20363D0,
54824      &    29.52871D0, 20.24143D0, 13.44020D0, 10.38777D0,  8.56307D0,
54825      &     7.32250D0,  5.71195D0,  4.30962D0,  3.05294D0,  2.35572D0,
54826      &     1.60960D0,  1.21865D0,  0.97551D0,  0.77034D0,  0.62226D0,
54827      &     0.50716D0,  0.41356D0,  0.33596D0,  0.27128D0,  0.21734D0,
54828      &     0.17244D0,  0.13547D0,  0.10527D0,  0.08085D0,  0.06139D0,
54829      &     0.04607D0,  0.03398D0,  0.02471D0,  0.01781D0,  0.01255D0,
54830      &     0.00868D0,  0.00593D0,  0.00393D0,  0.00162D0,  0.00060D0,
54831      &     0.00019D0,  0.00005D0,  0.00000D0,  0.00000D0/
54832       DATA (FMRS(2,3,I,23),I=1,49)/
54833      &   287.44696D0,207.38838D0,149.53354D0,123.42919D0,107.68206D0,
54834      &    96.83708D0, 69.47065D0, 49.52397D0, 40.41636D0, 34.86102D0,
54835      &    30.91543D0, 21.00356D0, 13.81644D0, 10.61949D0,  8.71986D0,
54836      &     7.43441D0,  5.77408D0,  4.33783D0,  3.05923D0,  2.35324D0,
54837      &     1.59919D0,  1.20346D0,  0.95679D0,  0.74861D0,  0.59903D0,
54838      &     0.48379D0,  0.39106D0,  0.31505D0,  0.25241D0,  0.20076D0,
54839      &     0.15822D0,  0.12352D0,  0.09541D0,  0.07286D0,  0.05504D0,
54840      &     0.04110D0,  0.03018D0,  0.02185D0,  0.01570D0,  0.01103D0,
54841      &     0.00760D0,  0.00518D0,  0.00342D0,  0.00141D0,  0.00052D0,
54842      &     0.00017D0,  0.00004D0,  0.00000D0,  0.00000D0/
54843       DATA (FMRS(2,3,I,24),I=1,49)/
54844      &   313.51825D0,224.63136D0,160.84229D0,132.22295D0,115.01953D0,
54845      &   103.20245D0, 73.51698D0, 52.03463D0, 42.28400D0, 36.35911D0,
54846      &    32.16307D0, 21.67765D0, 14.14149D0, 10.81558D0,  8.84983D0,
54847      &     7.52509D0,  5.82169D0,  4.35654D0,  3.05952D0,  2.34629D0,
54848      &     1.58590D0,  1.18656D0,  0.93734D0,  0.72724D0,  0.57702D0,
54849      &     0.46218D0,  0.37070D0,  0.29646D0,  0.23590D0,  0.18642D0,
54850      &     0.14603D0,  0.11337D0,  0.08712D0,  0.06621D0,  0.04979D0,
54851      &     0.03702D0,  0.02708D0,  0.01953D0,  0.01399D0,  0.00980D0,
54852      &     0.00674D0,  0.00458D0,  0.00302D0,  0.00124D0,  0.00046D0,
54853      &     0.00015D0,  0.00004D0,  0.00000D0,  0.00000D0/
54854       DATA (FMRS(2,3,I,25),I=1,49)/
54855      &   341.15173D0,242.77290D0,172.65150D0,141.36496D0,122.62321D0,
54856      &   109.78229D0, 77.66644D0, 54.58787D0, 44.17350D0, 37.86890D0,
54857      &    33.41642D0, 22.34751D0, 14.46016D0, 11.00588D0,  8.97477D0,
54858      &     7.61137D0,  5.86592D0,  4.37273D0,  3.05810D0,  2.33803D0,
54859      &     1.57177D0,  1.16920D0,  0.91780D0,  0.70620D0,  0.55570D0,
54860      &     0.44154D0,  0.35145D0,  0.27905D0,  0.22057D0,  0.17322D0,
54861      &     0.13490D0,  0.10417D0,  0.07964D0,  0.06025D0,  0.04510D0,
54862      &     0.03340D0,  0.02434D0,  0.01749D0,  0.01249D0,  0.00873D0,
54863      &     0.00599D0,  0.00406D0,  0.00268D0,  0.00110D0,  0.00041D0,
54864      &     0.00013D0,  0.00004D0,  0.00000D0,  0.00000D0/
54865       DATA (FMRS(2,3,I,26),I=1,49)/
54866      &   368.98822D0,260.90195D0,184.35516D0,150.38000D0,130.09390D0,
54867      &   116.22827D0, 81.69344D0, 57.04021D0, 45.97627D0, 39.30195D0,
54868      &    34.60083D0, 22.97047D0, 14.74975D0, 11.17543D0,  9.08370D0,
54869      &     7.68467D0,  5.90104D0,  4.38251D0,  3.05244D0,  2.32659D0,
54870      &     1.55551D0,  1.15047D0,  0.89759D0,  0.68521D0,  0.53495D0,
54871      &     0.42187D0,  0.33342D0,  0.26295D0,  0.20656D0,  0.16128D0,
54872      &     0.12493D0,  0.09597D0,  0.07303D0,  0.05500D0,  0.04100D0,
54873      &     0.03027D0,  0.02198D0,  0.01575D0,  0.01122D0,  0.00782D0,
54874      &     0.00536D0,  0.00363D0,  0.00239D0,  0.00098D0,  0.00036D0,
54875      &     0.00012D0,  0.00003D0,  0.00000D0,  0.00000D0/
54876       DATA (FMRS(2,3,I,27),I=1,49)/
54877      &   396.49847D0,278.69458D0,195.76036D0,159.12776D0,137.32101D0,
54878      &   122.44904D0, 85.54959D0, 59.36906D0, 47.67925D0, 40.65031D0,
54879      &    35.71157D0, 23.54779D0, 15.01388D0, 11.32784D0,  9.18018D0,
54880      &     7.74858D0,  5.93008D0,  4.38884D0,  3.04508D0,  2.31422D0,
54881      &     1.53913D0,  1.13220D0,  0.87829D0,  0.66558D0,  0.51586D0,
54882      &     0.40401D0,  0.31721D0,  0.24862D0,  0.19419D0,  0.15083D0,
54883      &     0.11625D0,  0.08889D0,  0.06736D0,  0.05053D0,  0.03753D0,
54884      &     0.02761D0,  0.01999D0,  0.01428D0,  0.01015D0,  0.00707D0,
54885      &     0.00483D0,  0.00327D0,  0.00215D0,  0.00088D0,  0.00033D0,
54886      &     0.00011D0,  0.00003D0,  0.00000D0,  0.00000D0/
54887       DATA (FMRS(2,3,I,28),I=1,49)/
54888      &   423.18488D0,295.83777D0,206.67247D0,167.46211D0,144.18538D0,
54889      &   128.34305D0, 89.17443D0, 61.53922D0, 49.25727D0, 41.89430D0,
54890      &    36.73269D0, 24.07136D0, 15.24876D0, 11.46075D0,  9.26257D0,
54891      &     7.80186D0,  5.95221D0,  4.39115D0,  3.03561D0,  2.30059D0,
54892      &     1.52239D0,  1.11417D0,  0.85969D0,  0.64709D0,  0.49822D0,
54893      &     0.38776D0,  0.30261D0,  0.23584D0,  0.18326D0,  0.14166D0,
54894      &     0.10869D0,  0.08277D0,  0.06247D0,  0.04670D0,  0.03458D0,
54895      &     0.02536D0,  0.01831D0,  0.01305D0,  0.00927D0,  0.00644D0,
54896      &     0.00439D0,  0.00297D0,  0.00195D0,  0.00080D0,  0.00030D0,
54897      &     0.00010D0,  0.00003D0,  0.00000D0,  0.00000D0/
54898       DATA (FMRS(2,3,I,29),I=1,49)/
54899      &   450.92862D0,313.54996D0,217.87523D0,175.98549D0,151.18591D0,
54900      &   134.34097D0, 92.83694D0, 63.71518D0, 50.83173D0, 43.13081D0,
54901      &    37.74429D0, 24.58404D0, 15.47489D0, 11.58672D0,  9.33925D0,
54902      &     7.85026D0,  5.97071D0,  4.39081D0,  3.02434D0,  2.28559D0,
54903      &     1.50481D0,  1.09565D0,  0.84093D0,  0.62877D0,  0.48096D0,
54904      &     0.37201D0,  0.28863D0,  0.22371D0,  0.17297D0,  0.13307D0,
54905      &     0.10166D0,  0.07711D0,  0.05798D0,  0.04320D0,  0.03189D0,
54906      &     0.02332D0,  0.01680D0,  0.01195D0,  0.00847D0,  0.00587D0,
54907      &     0.00400D0,  0.00270D0,  0.00178D0,  0.00073D0,  0.00027D0,
54908      &     0.00009D0,  0.00002D0,  0.00000D0,  0.00000D0/
54909       DATA (FMRS(2,3,I,30),I=1,49)/
54910      &   478.88074D0,331.28183D0,229.01660D0,184.42841D0,158.10007D0,
54911      &   140.25114D0, 96.41853D0, 65.82523D0, 52.35015D0, 44.31818D0,
54912      &    38.71195D0, 25.06767D0, 15.68364D0, 11.70050D0,  9.40671D0,
54913      &     7.89123D0,  5.98412D0,  4.38708D0,  3.01099D0,  2.26914D0,
54914      &     1.48646D0,  1.07684D0,  0.82225D0,  0.61085D0,  0.46437D0,
54915      &     0.35704D0,  0.27550D0,  0.21242D0,  0.16347D0,  0.12519D0,
54916      &     0.09525D0,  0.07197D0,  0.05394D0,  0.04005D0,  0.02949D0,
54917      &     0.02151D0,  0.01546D0,  0.01097D0,  0.00776D0,  0.00538D0,
54918      &     0.00366D0,  0.00247D0,  0.00162D0,  0.00067D0,  0.00025D0,
54919      &     0.00008D0,  0.00002D0,  0.00000D0,  0.00000D0/
54920       DATA (FMRS(2,3,I,31),I=1,49)/
54921      &   506.38092D0,348.62979D0,239.85460D0,192.61319D0,164.78622D0,
54922      &   145.95520D0, 99.85363D0, 67.83522D0, 53.79026D0, 45.44058D0,
54923      &    39.62410D0, 25.51892D0, 15.87554D0, 11.80362D0,  9.46678D0,
54924      &     7.92687D0,  5.99445D0,  4.38186D0,  2.99723D0,  2.25276D0,
54925      &     1.46868D0,  1.05889D0,  0.80464D0,  0.59419D0,  0.44909D0,
54926      &     0.34338D0,  0.26361D0,  0.20228D0,  0.15498D0,  0.11820D0,
54927      &     0.08960D0,  0.06746D0,  0.05040D0,  0.03731D0,  0.02741D0,
54928      &     0.01994D0,  0.01431D0,  0.01014D0,  0.00716D0,  0.00495D0,
54929      &     0.00337D0,  0.00227D0,  0.00149D0,  0.00061D0,  0.00023D0,
54930      &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
54931       DATA (FMRS(2,3,I,32),I=1,49)/
54932      &   532.71063D0,365.14023D0,250.10423D0,200.32385D0,171.06720D0,
54933      &   151.30153D0,103.04897D0, 69.68893D0, 55.11074D0, 46.46502D0,
54934      &    40.45333D0, 25.92270D0, 16.04272D0, 11.89083D0,  9.51556D0,
54935      &     7.95409D0,  5.99947D0,  4.37358D0,  2.98195D0,  2.23557D0,
54936      &     1.45083D0,  1.04132D0,  0.78773D0,  0.57848D0,  0.43489D0,
54937      &     0.33086D0,  0.25280D0,  0.19316D0,  0.14738D0,  0.11200D0,
54938      &     0.08461D0,  0.06352D0,  0.04732D0,  0.03494D0,  0.02560D0,
54939      &     0.01860D0,  0.01332D0,  0.00942D0,  0.00665D0,  0.00459D0,
54940      &     0.00312D0,  0.00210D0,  0.00138D0,  0.00057D0,  0.00021D0,
54941      &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
54942       DATA (FMRS(2,3,I,33),I=1,49)/
54943      &   560.44952D0,382.45715D0,260.80753D0,208.35481D0,177.59706D0,
54944      &   156.85155D0,106.35128D0, 71.59602D0, 56.46558D0, 47.51407D0,
54945      &    41.30114D0, 26.33344D0, 16.21190D0, 11.97881D0,  9.56466D0,
54946      &     7.98144D0,  6.00450D0,  4.36531D0,  2.96673D0,  2.21850D0,
54947      &     1.43317D0,  1.02401D0,  0.77116D0,  0.56317D0,  0.42112D0,
54948      &     0.31878D0,  0.24243D0,  0.18443D0,  0.14015D0,  0.10612D0,
54949      &     0.07989D0,  0.05980D0,  0.04442D0,  0.03272D0,  0.02392D0,
54950      &     0.01734D0,  0.01239D0,  0.00875D0,  0.00617D0,  0.00426D0,
54951      &     0.00289D0,  0.00195D0,  0.00128D0,  0.00052D0,  0.00020D0,
54952      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
54953       DATA (FMRS(2,3,I,34),I=1,49)/
54954      &   587.66711D0,399.34082D0,271.17145D0,216.09799D0,183.87283D0,
54955      &   162.17198D0,109.48943D0, 73.38959D0, 57.73061D0, 48.48780D0,
54956      &    42.08379D0, 26.70440D0, 16.35846D0, 12.05124D0,  9.60203D0,
54957      &     7.99942D0,  6.00308D0,  4.35260D0,  2.94870D0,  2.19937D0,
54958      &     1.41431D0,  1.00609D0,  0.75435D0,  0.54797D0,  0.40769D0,
54959      &     0.30718D0,  0.23257D0,  0.17622D0,  0.13341D0,  0.10068D0,
54960      &     0.07556D0,  0.05639D0,  0.04179D0,  0.03071D0,  0.02240D0,
54961      &     0.01621D0,  0.01157D0,  0.00816D0,  0.00575D0,  0.00396D0,
54962      &     0.00269D0,  0.00181D0,  0.00119D0,  0.00049D0,  0.00018D0,
54963      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
54964       DATA (FMRS(2,3,I,35),I=1,49)/
54965      &   614.66376D0,416.01791D0,281.36646D0,223.69629D0,190.02084D0,
54966      &   167.37685D0,112.54659D0, 75.12943D0, 58.95456D0, 49.42817D0,
54967      &    42.83852D0, 27.06040D0, 16.49837D0, 12.12015D0,  9.63748D0,
54968      &     8.01641D0,  6.00168D0,  4.34055D0,  2.93168D0,  2.18137D0,
54969      &     1.39666D0,  0.98938D0,  0.73876D0,  0.53395D0,  0.39535D0,
54970      &     0.29658D0,  0.22360D0,  0.16878D0,  0.12732D0,  0.09577D0,
54971      &     0.07167D0,  0.05334D0,  0.03944D0,  0.02892D0,  0.02106D0,
54972      &     0.01521D0,  0.01085D0,  0.00764D0,  0.00537D0,  0.00370D0,
54973      &     0.00251D0,  0.00169D0,  0.00111D0,  0.00046D0,  0.00017D0,
54974      &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
54975       DATA (FMRS(2,3,I,36),I=1,49)/
54976      &   640.64490D0,431.98953D0,291.07977D0,230.91319D0,195.84616D0,
54977      &   172.29993D0,115.42027D0, 76.75350D0, 60.09168D0, 50.29848D0,
54978      &    43.53482D0, 27.38445D0, 16.62263D0, 12.17943D0,  9.66642D0,
54979      &     8.02868D0,  5.99763D0,  4.32731D0,  2.91439D0,  2.16350D0,
54980      &     1.37952D0,  0.97339D0,  0.72400D0,  0.52085D0,  0.38394D0,
54981      &     0.28684D0,  0.21543D0,  0.16204D0,  0.12184D0,  0.09139D0,
54982      &     0.06820D0,  0.05064D0,  0.03736D0,  0.02734D0,  0.01987D0,
54983      &     0.01434D0,  0.01021D0,  0.00718D0,  0.00505D0,  0.00348D0,
54984      &     0.00236D0,  0.00159D0,  0.00104D0,  0.00043D0,  0.00016D0,
54985      &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
54986       DATA (FMRS(2,3,I,37),I=1,49)/
54987      &   667.19971D0,448.23413D0,300.90906D0,238.19307D0,201.70891D0,
54988      &   177.24495D0,118.28902D0, 78.36304D0, 61.21302D0, 51.15329D0,
54989      &    44.21644D0, 27.69705D0, 16.73916D0, 12.23290D0,  9.69072D0,
54990      &     8.03703D0,  5.99069D0,  4.31202D0,  2.89571D0,  2.14460D0,
54991      &     1.36178D0,  0.95706D0,  0.70912D0,  0.50779D0,  0.37268D0,
54992      &     0.27731D0,  0.20750D0,  0.15552D0,  0.11658D0,  0.08719D0,
54993      &     0.06491D0,  0.04808D0,  0.03540D0,  0.02586D0,  0.01877D0,
54994      &     0.01352D0,  0.00961D0,  0.00676D0,  0.00475D0,  0.00327D0,
54995      &     0.00222D0,  0.00149D0,  0.00098D0,  0.00040D0,  0.00015D0,
54996      &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
54997       DATA (FMRS(2,3,I,38),I=1,49)/
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,  0.00000D0,
55004      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
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/
55008       DATA (FMRS(2,4,I, 1),I=1,49)/
55009      &     0.96883D0,  0.83010D0,  0.71060D0,  0.64853D0,  0.60767D0,
55010      &     0.57770D0,  0.49346D0,  0.42161D0,  0.38501D0,  0.36146D0,
55011      &     0.34535D0,  0.30095D0,  0.26559D0,  0.24803D0,  0.23669D0,
55012      &     0.22831D0,  0.21597D0,  0.20255D0,  0.18524D0,  0.17029D0,
55013      &     0.14323D0,  0.11890D0,  0.09745D0,  0.07499D0,  0.05725D0,
55014      &     0.04365D0,  0.03351D0,  0.02602D0,  0.02043D0,  0.01653D0,
55015      &     0.01318D0,  0.01067D0,  0.00853D0,  0.00671D0,  0.00530D0,
55016      &     0.00405D0,  0.00296D0,  0.00217D0,  0.00162D0,  0.00103D0,
55017      &     0.00065D0,  0.00047D0,  0.00023D0,  0.00008D0,  0.00004D0,
55018      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55019       DATA (FMRS(2,4,I, 2),I=1,49)/
55020      &     0.97285D0,  0.83723D0,  0.71985D0,  0.65865D0,  0.61827D0,
55021      &     0.58859D0,  0.50491D0,  0.43319D0,  0.39649D0,  0.37279D0,
55022      &     0.35657D0,  0.31149D0,  0.27487D0,  0.25626D0,  0.24402D0,
55023      &     0.23487D0,  0.22125D0,  0.20637D0,  0.18739D0,  0.17135D0,
55024      &     0.14312D0,  0.11837D0,  0.09689D0,  0.07465D0,  0.05719D0,
55025      &     0.04386D0,  0.03391D0,  0.02652D0,  0.02098D0,  0.01703D0,
55026      &     0.01365D0,  0.01107D0,  0.00885D0,  0.00698D0,  0.00550D0,
55027      &     0.00421D0,  0.00309D0,  0.00226D0,  0.00169D0,  0.00108D0,
55028      &     0.00069D0,  0.00049D0,  0.00025D0,  0.00010D0,  0.00003D0,
55029      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
55030       DATA (FMRS(2,4,I, 3),I=1,49)/
55031      &     0.99630D0,  0.86193D0,  0.74498D0,  0.68373D0,  0.64319D0,
55032      &     0.61334D0,  0.52882D0,  0.45586D0,  0.41827D0,  0.39388D0,
55033      &     0.37707D0,  0.32984D0,  0.29034D0,  0.26968D0,  0.25582D0,
55034      &     0.24531D0,  0.22956D0,  0.21234D0,  0.19077D0,  0.17310D0,
55035      &     0.14315D0,  0.11778D0,  0.09624D0,  0.07426D0,  0.05716D0,
55036      &     0.04417D0,  0.03445D0,  0.02716D0,  0.02168D0,  0.01765D0,
55037      &     0.01422D0,  0.01151D0,  0.00919D0,  0.00726D0,  0.00569D0,
55038      &     0.00437D0,  0.00323D0,  0.00233D0,  0.00177D0,  0.00113D0,
55039      &     0.00072D0,  0.00052D0,  0.00028D0,  0.00011D0,  0.00003D0,
55040      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
55041       DATA (FMRS(2,4,I, 4),I=1,49)/
55042      &     1.02892D0,  0.89240D0,  0.77327D0,  0.71073D0,  0.66929D0,
55043      &     0.63873D0,  0.55202D0,  0.47687D0,  0.43798D0,  0.41263D0,
55044      &     0.39503D0,  0.34528D0,  0.30287D0,  0.28033D0,  0.26505D0,
55045      &     0.25342D0,  0.23594D0,  0.21688D0,  0.19336D0,  0.17449D0,
55046      &     0.14328D0,  0.11746D0,  0.09586D0,  0.07403D0,  0.05716D0,
55047      &     0.04437D0,  0.03479D0,  0.02755D0,  0.02207D0,  0.01800D0,
55048      &     0.01451D0,  0.01172D0,  0.00935D0,  0.00736D0,  0.00577D0,
55049      &     0.00444D0,  0.00328D0,  0.00236D0,  0.00178D0,  0.00114D0,
55050      &     0.00075D0,  0.00052D0,  0.00029D0,  0.00011D0,  0.00004D0,
55051      &     0.00003D0,  0.00000D0,  0.00000D0,  0.00000D0/
55052       DATA (FMRS(2,4,I, 5),I=1,49)/
55053      &     1.08451D0,  0.94133D0,  0.81630D0,  0.75061D0,  0.70706D0,
55054      &     0.67493D0,  0.58367D0,  0.50437D0,  0.46318D0,  0.43623D0,
55055      &     0.41737D0,  0.36373D0,  0.31732D0,  0.29240D0,  0.27539D0,
55056      &     0.26243D0,  0.24295D0,  0.22186D0,  0.19623D0,  0.17608D0,
55057      &     0.14355D0,  0.11725D0,  0.09556D0,  0.07384D0,  0.05715D0,
55058      &     0.04453D0,  0.03504D0,  0.02784D0,  0.02236D0,  0.01824D0,
55059      &     0.01470D0,  0.01187D0,  0.00949D0,  0.00742D0,  0.00580D0,
55060      &     0.00445D0,  0.00328D0,  0.00235D0,  0.00175D0,  0.00116D0,
55061      &     0.00074D0,  0.00053D0,  0.00029D0,  0.00011D0,  0.00004D0,
55062      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
55063       DATA (FMRS(2,4,I, 6),I=1,49)/
55064      &     1.14357D0,  0.99242D0,  0.86045D0,  0.79114D0,  0.74518D0,
55065      &     0.71127D0,  0.61492D0,  0.53108D0,  0.48742D0,  0.45878D0,
55066      &     0.43857D0,  0.38094D0,  0.33056D0,  0.30333D0,  0.28470D0,
55067      &     0.27048D0,  0.24918D0,  0.22626D0,  0.19875D0,  0.17749D0,
55068      &     0.14383D0,  0.11711D0,  0.09533D0,  0.07370D0,  0.05713D0,
55069      &     0.04464D0,  0.03521D0,  0.02805D0,  0.02256D0,  0.01839D0,
55070      &     0.01482D0,  0.01197D0,  0.00955D0,  0.00745D0,  0.00580D0,
55071      &     0.00443D0,  0.00326D0,  0.00233D0,  0.00174D0,  0.00116D0,
55072      &     0.00074D0,  0.00053D0,  0.00029D0,  0.00011D0,  0.00004D0,
55073      &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
55074       DATA (FMRS(2,4,I, 7),I=1,49)/
55075      &     1.21691D0,  1.05450D0,  0.91294D0,  0.83868D0,  0.78948D0,
55076      &     0.75319D0,  0.65015D0,  0.56049D0,  0.51374D0,  0.48302D0,
55077      &     0.46120D0,  0.39885D0,  0.34401D0,  0.31429D0,  0.29395D0,
55078      &     0.27845D0,  0.25529D0,  0.23055D0,  0.20123D0,  0.17890D0,
55079      &     0.14416D0,  0.11703D0,  0.09514D0,  0.07357D0,  0.05711D0,
55080      &     0.04471D0,  0.03532D0,  0.02818D0,  0.02268D0,  0.01846D0,
55081      &     0.01487D0,  0.01199D0,  0.00952D0,  0.00742D0,  0.00577D0,
55082      &     0.00441D0,  0.00322D0,  0.00229D0,  0.00172D0,  0.00114D0,
55083      &     0.00072D0,  0.00051D0,  0.00029D0,  0.00010D0,  0.00004D0,
55084      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55085       DATA (FMRS(2,4,I, 8),I=1,49)/
55086      &     1.31000D0,  1.13230D0,  0.97784D0,  0.89699D0,  0.84348D0,
55087      &     0.80406D0,  0.69226D0,  0.59511D0,  0.54444D0,  0.51110D0,
55088      &     0.48726D0,  0.41913D0,  0.35898D0,  0.32638D0,  0.30408D0,
55089      &     0.28713D0,  0.26192D0,  0.23518D0,  0.20389D0,  0.18042D0,
55090      &     0.14454D0,  0.11697D0,  0.09497D0,  0.07342D0,  0.05705D0,
55091      &     0.04474D0,  0.03539D0,  0.02827D0,  0.02275D0,  0.01851D0,
55092      &     0.01488D0,  0.01197D0,  0.00947D0,  0.00737D0,  0.00571D0,
55093      &     0.00437D0,  0.00318D0,  0.00224D0,  0.00169D0,  0.00111D0,
55094      &     0.00070D0,  0.00049D0,  0.00029D0,  0.00010D0,  0.00004D0,
55095      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55096       DATA (FMRS(2,4,I, 9),I=1,49)/
55097      &     1.40457D0,  1.21051D0,  1.04237D0,  0.95458D0,  0.89657D0,
55098      &     0.85387D0,  0.73299D0,  0.62815D0,  0.57350D0,  0.53752D0,
55099      &     0.51167D0,  0.43783D0,  0.37258D0,  0.33726D0,  0.31316D0,
55100      &     0.29488D0,  0.26778D0,  0.23925D0,  0.20624D0,  0.18177D0,
55101      &     0.14489D0,  0.11694D0,  0.09483D0,  0.07330D0,  0.05698D0,
55102      &     0.04474D0,  0.03543D0,  0.02831D0,  0.02277D0,  0.01852D0,
55103      &     0.01487D0,  0.01192D0,  0.00942D0,  0.00732D0,  0.00564D0,
55104      &     0.00433D0,  0.00313D0,  0.00219D0,  0.00166D0,  0.00109D0,
55105      &     0.00068D0,  0.00049D0,  0.00028D0,  0.00010D0,  0.00003D0,
55106      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55107       DATA (FMRS(2,4,I,10),I=1,49)/
55108      &     1.51092D0,  1.29750D0,  1.11331D0,  1.01744D0,  0.95421D0,
55109      &     0.90772D0,  0.77643D0,  0.66288D0,  0.60378D0,  0.56488D0,
55110      &     0.53682D0,  0.45681D0,  0.38616D0,  0.34803D0,  0.32208D0,
55111      &     0.30246D0,  0.27350D0,  0.24321D0,  0.20851D0,  0.18308D0,
55112      &     0.14525D0,  0.11692D0,  0.09469D0,  0.07316D0,  0.05689D0,
55113      &     0.04470D0,  0.03541D0,  0.02828D0,  0.02274D0,  0.01846D0,
55114      &     0.01479D0,  0.01184D0,  0.00933D0,  0.00722D0,  0.00556D0,
55115      &     0.00426D0,  0.00307D0,  0.00215D0,  0.00161D0,  0.00106D0,
55116      &     0.00067D0,  0.00048D0,  0.00027D0,  0.00010D0,  0.00003D0,
55117      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55118       DATA (FMRS(2,4,I,11),I=1,49)/
55119      &     1.60472D0,  1.37368D0,  1.17498D0,  1.07183D0,  1.00391D0,
55120      &     0.95405D0,  0.81348D0,  0.69224D0,  0.62923D0,  0.58777D0,
55121      &     0.55781D0,  0.47247D0,  0.39725D0,  0.35677D0,  0.32928D0,
55122      &     0.30856D0,  0.27807D0,  0.24637D0,  0.21032D0,  0.18413D0,
55123      &     0.14554D0,  0.11692D0,  0.09459D0,  0.07304D0,  0.05681D0,
55124      &     0.04465D0,  0.03537D0,  0.02823D0,  0.02270D0,  0.01839D0,
55125      &     0.01471D0,  0.01176D0,  0.00923D0,  0.00712D0,  0.00549D0,
55126      &     0.00419D0,  0.00301D0,  0.00213D0,  0.00157D0,  0.00105D0,
55127      &     0.00065D0,  0.00047D0,  0.00027D0,  0.00010D0,  0.00004D0,
55128      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55129       DATA (FMRS(2,4,I,12),I=1,49)/
55130      &     1.83637D0,  1.55987D0,  1.32404D0,  1.20242D0,  1.12267D0,
55131      &     1.06429D0,  0.90056D0,  0.76032D0,  0.68777D0,  0.64012D0,
55132      &     0.60555D0,  0.50757D0,  0.42172D0,  0.37588D0,  0.34496D0,
55133      &     0.32177D0,  0.28792D0,  0.25312D0,  0.21417D0,  0.18636D0,
55134      &     0.14617D0,  0.11691D0,  0.09435D0,  0.07276D0,  0.05658D0,
55135      &     0.04447D0,  0.03521D0,  0.02807D0,  0.02254D0,  0.01819D0,
55136      &     0.01452D0,  0.01154D0,  0.00905D0,  0.00695D0,  0.00533D0,
55137      &     0.00404D0,  0.00292D0,  0.00205D0,  0.00149D0,  0.00100D0,
55138      &     0.00062D0,  0.00045D0,  0.00024D0,  0.00010D0,  0.00003D0,
55139      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55140       DATA (FMRS(2,4,I,13),I=1,49)/
55141      &     2.07152D0,  1.74663D0,  1.47172D0,  1.33085D0,  1.23884D0,
55142      &     1.17167D0,  0.98420D0,  0.82476D0,  0.74268D0,  0.68890D0,
55143      &     0.64981D0,  0.53955D0,  0.44363D0,  0.39281D0,  0.35874D0,
55144      &     0.33333D0,  0.29647D0,  0.25893D0,  0.21746D0,  0.18826D0,
55145      &     0.14670D0,  0.11688D0,  0.09412D0,  0.07248D0,  0.05632D0,
55146      &     0.04424D0,  0.03500D0,  0.02787D0,  0.02234D0,  0.01798D0,
55147      &     0.01431D0,  0.01132D0,  0.00886D0,  0.00679D0,  0.00517D0,
55148      &     0.00390D0,  0.00284D0,  0.00195D0,  0.00143D0,  0.00095D0,
55149      &     0.00059D0,  0.00043D0,  0.00023D0,  0.00009D0,  0.00002D0,
55150      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55151       DATA (FMRS(2,4,I,14),I=1,49)/
55152      &     2.37643D0,  1.98603D0,  1.65879D0,  1.49235D0,  1.38415D0,
55153      &     1.30543D0,  1.08702D0,  0.90288D0,  0.80867D0,  0.74716D0,
55154      &     0.70240D0,  0.57696D0,  0.46881D0,  0.41209D0,  0.37432D0,
55155      &     0.34632D0,  0.30599D0,  0.26535D0,  0.22106D0,  0.19032D0,
55156      &     0.14723D0,  0.11682D0,  0.09381D0,  0.07211D0,  0.05596D0,
55157      &     0.04392D0,  0.03471D0,  0.02757D0,  0.02204D0,  0.01767D0,
55158      &     0.01400D0,  0.01105D0,  0.00862D0,  0.00657D0,  0.00496D0,
55159      &     0.00374D0,  0.00270D0,  0.00182D0,  0.00137D0,  0.00090D0,
55160      &     0.00057D0,  0.00039D0,  0.00023D0,  0.00007D0,  0.00002D0,
55161      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55162       DATA (FMRS(2,4,I,15),I=1,49)/
55163      &     2.74566D0,  2.27231D0,  1.87960D0,  1.68150D0,  1.55338D0,
55164      &     1.46052D0,  1.20454D0,  0.99082D0,  0.88227D0,  0.81170D0,
55165      &     0.76034D0,  0.61745D0,  0.49560D0,  0.43237D0,  0.39059D0,
55166      &     0.35980D0,  0.31580D0,  0.27191D0,  0.22470D0,  0.19238D0,
55167      &     0.14774D0,  0.11669D0,  0.09344D0,  0.07165D0,  0.05549D0,
55168      &     0.04347D0,  0.03429D0,  0.02720D0,  0.02166D0,  0.01729D0,
55169      &     0.01366D0,  0.01073D0,  0.00832D0,  0.00636D0,  0.00476D0,
55170      &     0.00357D0,  0.00255D0,  0.00175D0,  0.00131D0,  0.00086D0,
55171      &     0.00052D0,  0.00037D0,  0.00021D0,  0.00007D0,  0.00002D0,
55172      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55173       DATA (FMRS(2,4,I,16),I=1,49)/
55174      &     3.12622D0,  2.56414D0,  2.10216D0,  1.87087D0,  1.72199D0,
55175      &     1.61445D0,  1.31978D0,  1.07596D0,  0.95298D0,  0.87335D0,
55176      &     0.81544D0,  0.65540D0,  0.52031D0,  0.45090D0,  0.40535D0,
55177      &     0.37197D0,  0.32458D0,  0.27772D0,  0.22787D0,  0.19414D0,
55178      &     0.14813D0,  0.11651D0,  0.09303D0,  0.07117D0,  0.05501D0,
55179      &     0.04302D0,  0.03385D0,  0.02678D0,  0.02128D0,  0.01692D0,
55180      &     0.01332D0,  0.01043D0,  0.00806D0,  0.00611D0,  0.00459D0,
55181      &     0.00341D0,  0.00242D0,  0.00166D0,  0.00123D0,  0.00082D0,
55182      &     0.00050D0,  0.00034D0,  0.00020D0,  0.00006D0,  0.00003D0,
55183      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55184       DATA (FMRS(2,4,I,17),I=1,49)/
55185      &     3.55799D0,  2.89188D0,  2.34954D0,  2.08007D0,  1.90742D0,
55186      &     1.78316D0,  1.44470D0,  1.16721D0,  1.02825D0,  0.93863D0,
55187      &     0.87356D0,  0.69490D0,  0.54567D0,  0.46976D0,  0.42028D0,
55188      &     0.38422D0,  0.33334D0,  0.28346D0,  0.23097D0,  0.19583D0,
55189      &     0.14845D0,  0.11627D0,  0.09257D0,  0.07063D0,  0.05448D0,
55190      &     0.04252D0,  0.03337D0,  0.02631D0,  0.02087D0,  0.01652D0,
55191      &     0.01297D0,  0.01012D0,  0.00778D0,  0.00585D0,  0.00440D0,
55192      &     0.00326D0,  0.00231D0,  0.00157D0,  0.00115D0,  0.00076D0,
55193      &     0.00047D0,  0.00031D0,  0.00019D0,  0.00006D0,  0.00003D0,
55194      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55195       DATA (FMRS(2,4,I,18),I=1,49)/
55196      &     3.95423D0,  3.18985D0,  2.57232D0,  2.26740D0,  2.07281D0,
55197      &     1.93314D0,  1.55464D0,  1.24668D0,  1.09337D0,  0.99486D0,
55198      &     0.92342D0,  0.72838D0,  0.56689D0,  0.48541D0,  0.43260D0,
55199      &     0.39429D0,  0.34049D0,  0.28810D0,  0.23344D0,  0.19715D0,
55200      &     0.14866D0,  0.11602D0,  0.09214D0,  0.07013D0,  0.05399D0,
55201      &     0.04205D0,  0.03295D0,  0.02591D0,  0.02050D0,  0.01618D0,
55202      &     0.01266D0,  0.00984D0,  0.00753D0,  0.00565D0,  0.00424D0,
55203      &     0.00314D0,  0.00221D0,  0.00150D0,  0.00109D0,  0.00072D0,
55204      &     0.00043D0,  0.00030D0,  0.00018D0,  0.00006D0,  0.00002D0,
55205      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55206       DATA (FMRS(2,4,I,19),I=1,49)/
55207      &     4.48113D0,  3.58253D0,  2.86323D0,  2.51070D0,  2.28676D0,
55208      &     2.12659D0,  1.69508D0,  1.34718D0,  1.17523D0,  1.06522D0,
55209      &     0.98559D0,  0.76963D0,  0.59272D0,  0.50431D0,  0.44739D0,
55210      &     0.40630D0,  0.34895D0,  0.29355D0,  0.23628D0,  0.19863D0,
55211      &     0.14882D0,  0.11566D0,  0.09156D0,  0.06947D0,  0.05334D0,
55212      &     0.04144D0,  0.03238D0,  0.02540D0,  0.02000D0,  0.01574D0,
55213      &     0.01227D0,  0.00950D0,  0.00724D0,  0.00541D0,  0.00404D0,
55214      &     0.00298D0,  0.00211D0,  0.00142D0,  0.00103D0,  0.00067D0,
55215      &     0.00041D0,  0.00028D0,  0.00016D0,  0.00006D0,  0.00002D0,
55216      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55217       DATA (FMRS(2,4,I,20),I=1,49)/
55218      &     4.99499D0,  3.96212D0,  3.14196D0,  2.74258D0,  2.48991D0,
55219      &     2.30973D0,  1.82681D0,  1.44056D0,  1.25085D0,  1.12995D0,
55220      &     1.04258D0,  0.80704D0,  0.61586D0,  0.52113D0,  0.46048D0,
55221      &     0.41689D0,  0.35636D0,  0.29827D0,  0.23871D0,  0.19986D0,
55222      &     0.14892D0,  0.11531D0,  0.09101D0,  0.06887D0,  0.05276D0,
55223      &     0.04087D0,  0.03186D0,  0.02494D0,  0.01954D0,  0.01534D0,
55224      &     0.01192D0,  0.00921D0,  0.00699D0,  0.00520D0,  0.00387D0,
55225      &     0.00284D0,  0.00201D0,  0.00135D0,  0.00099D0,  0.00063D0,
55226      &     0.00039D0,  0.00027D0,  0.00014D0,  0.00005D0,  0.00002D0,
55227      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55228       DATA (FMRS(2,4,I,21),I=1,49)/
55229      &     5.50061D0,  4.33261D0,  3.41176D0,  2.96594D0,  2.68491D0,
55230      &     2.48503D0,  1.95181D0,  1.52837D0,  1.32157D0,  1.19023D0,
55231      &     1.09549D0,  0.84140D0,  0.63686D0,  0.53627D0,  0.47219D0,
55232      &     0.42632D0,  0.36291D0,  0.30239D0,  0.24078D0,  0.20086D0,
55233      &     0.14892D0,  0.11489D0,  0.09045D0,  0.06826D0,  0.05215D0,
55234      &     0.04031D0,  0.03135D0,  0.02446D0,  0.01914D0,  0.01497D0,
55235      &     0.01162D0,  0.00892D0,  0.00678D0,  0.00502D0,  0.00373D0,
55236      &     0.00273D0,  0.00191D0,  0.00128D0,  0.00093D0,  0.00060D0,
55237      &     0.00037D0,  0.00026D0,  0.00014D0,  0.00005D0,  0.00001D0,
55238      &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55239       DATA (FMRS(2,4,I,22),I=1,49)/
55240      &     6.19859D0,  4.83989D0,  3.77815D0,  3.26780D0,  2.94753D0,
55241      &     2.72049D0,  2.11828D0,  1.64429D0,  1.41443D0,  1.26909D0,
55242      &     1.16448D0,  0.88574D0,  0.66367D0,  0.55547D0,  0.48697D0,
55243      &     0.43816D0,  0.37106D0,  0.30748D0,  0.24329D0,  0.20204D0,
55244      &     0.14885D0,  0.11433D0,  0.08969D0,  0.06745D0,  0.05136D0,
55245      &     0.03959D0,  0.03069D0,  0.02386D0,  0.01861D0,  0.01451D0,
55246      &     0.01121D0,  0.00856D0,  0.00649D0,  0.00480D0,  0.00355D0,
55247      &     0.00258D0,  0.00180D0,  0.00120D0,  0.00087D0,  0.00057D0,
55248      &     0.00034D0,  0.00024D0,  0.00013D0,  0.00004D0,  0.00001D0,
55249      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55250       DATA (FMRS(2,4,I,23),I=1,49)/
55251      &     6.91462D0,  5.35579D0,  4.14753D0,  3.57056D0,  3.20996D0,
55252      &     2.95511D0,  2.28266D0,  1.75769D0,  1.50477D0,  1.34548D0,
55253      &     1.23109D0,  0.92809D0,  0.68898D0,  0.57345D0,  0.50073D0,
55254      &     0.44914D0,  0.37855D0,  0.31211D0,  0.24552D0,  0.20305D0,
55255      &     0.14871D0,  0.11376D0,  0.08894D0,  0.06666D0,  0.05060D0,
55256      &     0.03890D0,  0.03007D0,  0.02332D0,  0.01811D0,  0.01408D0,
55257      &     0.01081D0,  0.00824D0,  0.00620D0,  0.00458D0,  0.00337D0,
55258      &     0.00246D0,  0.00171D0,  0.00112D0,  0.00082D0,  0.00053D0,
55259      &     0.00032D0,  0.00022D0,  0.00013D0,  0.00004D0,  0.00001D0,
55260      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55261       DATA (FMRS(2,4,I,24),I=1,49)/
55262      &     7.62855D0,  5.86601D0,  4.50985D0,  3.86607D0,  3.46522D0,
55263      &     3.18268D0,  2.44073D0,  1.86575D0,  1.59038D0,  1.41758D0,
55264      &     1.29375D0,  0.96750D0,  0.71223D0,  0.58984D0,  0.51319D0,
55265      &     0.45902D0,  0.38523D0,  0.31616D0,  0.24739D0,  0.20383D0,
55266      &     0.14846D0,  0.11312D0,  0.08817D0,  0.06586D0,  0.04986D0,
55267      &     0.03821D0,  0.02946D0,  0.02275D0,  0.01763D0,  0.01365D0,
55268      &     0.01046D0,  0.00797D0,  0.00597D0,  0.00439D0,  0.00323D0,
55269      &     0.00235D0,  0.00162D0,  0.00107D0,  0.00078D0,  0.00051D0,
55270      &     0.00031D0,  0.00021D0,  0.00012D0,  0.00003D0,  0.00001D0,
55271      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55272       DATA (FMRS(2,4,I,25),I=1,49)/
55273      &     8.39955D0,  6.41302D0,  4.89545D0,  4.17923D0,  3.73489D0,
55274      &     3.42253D0,  2.60607D0,  1.97793D0,  1.67884D0,  1.49183D0,
55275      &     1.35810D0,  1.00761D0,  0.73567D0,  0.60627D0,  0.52562D0,
55276      &     0.46884D0,  0.39183D0,  0.32012D0,  0.24919D0,  0.20455D0,
55277      &     0.14818D0,  0.11246D0,  0.08739D0,  0.06506D0,  0.04911D0,
55278      &     0.03752D0,  0.02885D0,  0.02220D0,  0.01716D0,  0.01324D0,
55279      &     0.01012D0,  0.00771D0,  0.00575D0,  0.00422D0,  0.00309D0,
55280      &     0.00225D0,  0.00154D0,  0.00103D0,  0.00074D0,  0.00048D0,
55281      &     0.00030D0,  0.00020D0,  0.00010D0,  0.00002D0,  0.00001D0,
55282      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55283       DATA (FMRS(2,4,I,26),I=1,49)/
55284      &     9.19737D0,  6.97494D0,  5.28863D0,  4.49714D0,  4.00779D0,
55285      &     3.66466D0,  2.77170D0,  2.08938D0,  1.76629D0,  1.56497D0,
55286      &     1.42130D0,  1.04661D0,  0.75821D0,  0.62194D0,  0.53740D0,
55287      &     0.47810D0,  0.39797D0,  0.32376D0,  0.25078D0,  0.20510D0,
55288      &     0.14782D0,  0.11174D0,  0.08657D0,  0.06424D0,  0.04835D0,
55289      &     0.03684D0,  0.02824D0,  0.02168D0,  0.01670D0,  0.01284D0,
55290      &     0.00977D0,  0.00742D0,  0.00552D0,  0.00404D0,  0.00296D0,
55291      &     0.00214D0,  0.00146D0,  0.00097D0,  0.00071D0,  0.00044D0,
55292      &     0.00028D0,  0.00017D0,  0.00010D0,  0.00003D0,  0.00001D0,
55293      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55294       DATA (FMRS(2,4,I,27),I=1,49)/
55295      &    10.00116D0,  7.53729D0,  5.67949D0,  4.81192D0,  4.27724D0,
55296      &     3.90320D0,  2.93374D0,  2.19765D0,  1.85088D0,  1.63549D0,
55297      &     1.48207D0,  1.08380D0,  0.77950D0,  0.63664D0,  0.54841D0,
55298      &     0.48671D0,  0.40364D0,  0.32707D0,  0.25218D0,  0.20556D0,
55299      &     0.14742D0,  0.11104D0,  0.08576D0,  0.06344D0,  0.04762D0,
55300      &     0.03619D0,  0.02766D0,  0.02119D0,  0.01627D0,  0.01248D0,
55301      &     0.00947D0,  0.00716D0,  0.00532D0,  0.00389D0,  0.00284D0,
55302      &     0.00205D0,  0.00139D0,  0.00092D0,  0.00068D0,  0.00042D0,
55303      &     0.00026D0,  0.00016D0,  0.00009D0,  0.00003D0,  0.00001D0,
55304      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55305       DATA (FMRS(2,4,I,28),I=1,49)/
55306      &    10.79744D0,  8.09092D0,  6.06186D0,  5.11871D0,  4.53915D0,
55307      &     4.13458D0,  3.08987D0,  2.30126D0,  1.93148D0,  1.70248D0,
55308      &     1.53966D0,  1.11875D0,  0.79931D0,  0.65024D0,  0.55853D0,
55309      &     0.49459D0,  0.40879D0,  0.33003D0,  0.25337D0,  0.20589D0,
55310      &     0.14698D0,  0.11033D0,  0.08498D0,  0.06267D0,  0.04691D0,
55311      &     0.03557D0,  0.02711D0,  0.02071D0,  0.01586D0,  0.01214D0,
55312      &     0.00920D0,  0.00692D0,  0.00514D0,  0.00376D0,  0.00272D0,
55313      &     0.00196D0,  0.00133D0,  0.00087D0,  0.00064D0,  0.00040D0,
55314      &     0.00025D0,  0.00016D0,  0.00009D0,  0.00003D0,  0.00001D0,
55315      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55316       DATA (FMRS(2,4,I,29),I=1,49)/
55317      &    11.63983D0,  8.67317D0,  6.46161D0,  5.43834D0,  4.81133D0,
55318      &     4.37457D0,  3.25082D0,  2.40738D0,  2.01373D0,  1.77063D0,
55319      &     1.59811D0,  1.15395D0,  0.81909D0,  0.66374D0,  0.56853D0,
55320      &     0.50235D0,  0.41381D0,  0.33288D0,  0.25448D0,  0.20616D0,
55321      &     0.14650D0,  0.10959D0,  0.08417D0,  0.06189D0,  0.04620D0,
55322      &     0.03495D0,  0.02656D0,  0.02024D0,  0.01545D0,  0.01181D0,
55323      &     0.00893D0,  0.00670D0,  0.00496D0,  0.00362D0,  0.00261D0,
55324      &     0.00187D0,  0.00127D0,  0.00083D0,  0.00060D0,  0.00038D0,
55325      &     0.00023D0,  0.00015D0,  0.00008D0,  0.00003D0,  0.00001D0,
55326      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55327       DATA (FMRS(2,4,I,30),I=1,49)/
55328      &    12.50504D0,  9.26774D0,  6.86743D0,  5.76168D0,  5.08599D0,
55329      &     4.61626D0,  3.41191D0,  2.51292D0,  2.09519D0,  1.83795D0,
55330      &     1.65570D0,  1.18836D0,  0.83825D0,  0.67674D0,  0.57810D0,
55331      &     0.50972D0,  0.41855D0,  0.33552D0,  0.25546D0,  0.20633D0,
55332      &     0.14597D0,  0.10882D0,  0.08334D0,  0.06111D0,  0.04550D0,
55333      &     0.03432D0,  0.02602D0,  0.01977D0,  0.01507D0,  0.01148D0,
55334      &     0.00865D0,  0.00649D0,  0.00478D0,  0.00347D0,  0.00250D0,
55335      &     0.00177D0,  0.00121D0,  0.00078D0,  0.00056D0,  0.00036D0,
55336      &     0.00022D0,  0.00014D0,  0.00008D0,  0.00002D0,  0.00001D0,
55337      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55338       DATA (FMRS(2,4,I,31),I=1,49)/
55339      &    13.36928D0,  9.85846D0,  7.26844D0,  6.08018D0,  5.35592D0,
55340      &     4.85338D0,  3.56907D0,  2.61529D0,  2.17393D0,  1.90285D0,
55341      &     1.71111D0,  1.22123D0,  0.85642D0,  0.68899D0,  0.58709D0,
55342      &     0.51663D0,  0.42295D0,  0.33794D0,  0.25632D0,  0.20644D0,
55343      &     0.14544D0,  0.10808D0,  0.08256D0,  0.06036D0,  0.04483D0,
55344      &     0.03373D0,  0.02551D0,  0.01933D0,  0.01470D0,  0.01117D0,
55345      &     0.00840D0,  0.00629D0,  0.00462D0,  0.00334D0,  0.00240D0,
55346      &     0.00170D0,  0.00116D0,  0.00075D0,  0.00053D0,  0.00034D0,
55347      &     0.00021D0,  0.00014D0,  0.00007D0,  0.00002D0,  0.00001D0,
55348      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55349       DATA (FMRS(2,4,I,32),I=1,49)/
55350      &    14.21204D0, 10.43149D0,  7.65538D0,  6.38652D0,  5.61495D0,
55351      &     5.08051D0,  3.71876D0,  2.71221D0,  2.24821D0,  1.96390D0,
55352      &     1.76311D0,  1.25185D0,  0.87317D0,  0.70020D0,  0.59526D0,
55353      &     0.52288D0,  0.42687D0,  0.34005D0,  0.25702D0,  0.20645D0,
55354      &     0.14487D0,  0.10733D0,  0.08179D0,  0.05963D0,  0.04417D0,
55355      &     0.03317D0,  0.02503D0,  0.01893D0,  0.01436D0,  0.01089D0,
55356      &     0.00816D0,  0.00610D0,  0.00447D0,  0.00322D0,  0.00232D0,
55357      &     0.00164D0,  0.00111D0,  0.00072D0,  0.00051D0,  0.00033D0,
55358      &     0.00020D0,  0.00013D0,  0.00007D0,  0.00002D0,  0.00001D0,
55359      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55360       DATA (FMRS(2,4,I,33),I=1,49)/
55361      &    15.10980D0, 11.03912D0,  8.06381D0,  6.70901D0,  5.88712D0,
55362      &     5.31881D0,  3.87508D0,  2.81294D0,  2.32519D0,  2.02704D0,
55363      &     1.81681D0,  1.28330D0,  0.89029D0,  0.71163D0,  0.60357D0,
55364      &     0.52922D0,  0.43085D0,  0.34218D0,  0.25771D0,  0.20646D0,
55365      &     0.14430D0,  0.10659D0,  0.08103D0,  0.05890D0,  0.04353D0,
55366      &     0.03261D0,  0.02455D0,  0.01854D0,  0.01403D0,  0.01061D0,
55367      &     0.00794D0,  0.00591D0,  0.00432D0,  0.00310D0,  0.00224D0,
55368      &     0.00159D0,  0.00107D0,  0.00069D0,  0.00049D0,  0.00032D0,
55369      &     0.00019D0,  0.00012D0,  0.00006D0,  0.00002D0,  0.00001D0,
55370      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55371       DATA (FMRS(2,4,I,34),I=1,49)/
55372      &    16.00814D0, 11.64399D0,  8.46821D0,  7.02730D0,  6.15513D0,
55373      &     5.55303D0,  4.02783D0,  2.91076D0,  2.39965D0,  2.08793D0,
55374      &     1.86846D0,  1.31328D0,  0.90643D0,  0.72231D0,  0.61128D0,
55375      &     0.53505D0,  0.43443D0,  0.34403D0,  0.25822D0,  0.20634D0,
55376      &     0.14366D0,  0.10580D0,  0.08022D0,  0.05817D0,  0.04288D0,
55377      &     0.03206D0,  0.02408D0,  0.01814D0,  0.01369D0,  0.01034D0,
55378      &     0.00771D0,  0.00572D0,  0.00418D0,  0.00300D0,  0.00216D0,
55379      &     0.00152D0,  0.00103D0,  0.00065D0,  0.00048D0,  0.00031D0,
55380      &     0.00018D0,  0.00012D0,  0.00006D0,  0.00002D0,  0.00001D0,
55381      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55382       DATA (FMRS(2,4,I,35),I=1,49)/
55383      &    16.90871D0, 12.24779D0,  8.87019D0,  7.34290D0,  6.42039D0,
55384      &     5.78454D0,  4.17816D0,  3.00661D0,  2.47242D0,  2.14733D0,
55385      &     1.91876D0,  1.34235D0,  0.92199D0,  0.73258D0,  0.61867D0,
55386      &     0.54063D0,  0.43786D0,  0.34580D0,  0.25870D0,  0.20622D0,
55387      &     0.14305D0,  0.10506D0,  0.07947D0,  0.05749D0,  0.04228D0,
55388      &     0.03154D0,  0.02364D0,  0.01777D0,  0.01338D0,  0.01009D0,
55389      &     0.00750D0,  0.00555D0,  0.00406D0,  0.00290D0,  0.00208D0,
55390      &     0.00145D0,  0.00100D0,  0.00062D0,  0.00047D0,  0.00030D0,
55391      &     0.00017D0,  0.00012D0,  0.00005D0,  0.00002D0,  0.00000D0,
55392      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55393       DATA (FMRS(2,4,I,36),I=1,49)/
55394      &    17.78739D0, 12.83436D0,  9.25897D0,  7.64732D0,  6.67578D0,
55395      &     6.00710D0,  4.32199D0,  3.09786D0,  2.54148D0,  2.20357D0,
55396      &     1.96631D0,  1.36964D0,  0.93649D0,  0.74208D0,  0.62547D0,
55397      &     0.54573D0,  0.44096D0,  0.34736D0,  0.25907D0,  0.20605D0,
55398      &     0.14244D0,  0.10433D0,  0.07874D0,  0.05683D0,  0.04170D0,
55399      &     0.03105D0,  0.02321D0,  0.01741D0,  0.01309D0,  0.00985D0,
55400      &     0.00731D0,  0.00540D0,  0.00394D0,  0.00282D0,  0.00201D0,
55401      &     0.00140D0,  0.00096D0,  0.00060D0,  0.00045D0,  0.00029D0,
55402      &     0.00016D0,  0.00012D0,  0.00005D0,  0.00001D0,  0.00000D0,
55403      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55404       DATA (FMRS(2,4,I,37),I=1,49)/
55405      &    18.69798D0, 13.43965D0,  9.65843D0,  7.95932D0,  6.93703D0,
55406      &     6.23444D0,  4.46823D0,  3.19019D0,  2.61115D0,  2.26017D0,
55407      &     2.01407D0,  1.39688D0,  0.95084D0,  0.75143D0,  0.63213D0,
55408      &     0.55070D0,  0.44393D0,  0.34881D0,  0.25937D0,  0.20581D0,
55409      &     0.14178D0,  0.10356D0,  0.07799D0,  0.05614D0,  0.04110D0,
55410      &     0.03053D0,  0.02278D0,  0.01705D0,  0.01280D0,  0.00961D0,
55411      &     0.00713D0,  0.00525D0,  0.00382D0,  0.00273D0,  0.00195D0,
55412      &     0.00136D0,  0.00092D0,  0.00058D0,  0.00043D0,  0.00028D0,
55413      &     0.00015D0,  0.00011D0,  0.00005D0,  0.00001D0,  0.00000D0,
55414      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55415       DATA (FMRS(2,4,I,38),I=1,49)/
55416      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55417      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55418      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55419      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55420      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55421      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55422      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55423      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55424      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55425      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55426       DATA (FMRS(2,5,I, 1),I=1,49)/
55427      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55428      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55429      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55430      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55431      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55432      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55433      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55434      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55435      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55436      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55437       DATA (FMRS(2,5,I, 2),I=1,49)/
55438      &     0.00003D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
55439      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
55440      &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
55441      &     0.00002D0,  0.00002D0,  0.00001D0,  0.00001D0,  0.00001D0,
55442      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
55443      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
55444      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
55445      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55446      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55447      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55448       DATA (FMRS(2,5,I, 3),I=1,49)/
55449      &     0.02821D0,  0.02609D0,  0.02411D0,  0.02301D0,  0.02226D0,
55450      &     0.02169D0,  0.01996D0,  0.01827D0,  0.01727D0,  0.01654D0,
55451      &     0.01595D0,  0.01400D0,  0.01174D0,  0.01027D0,  0.00917D0,
55452      &     0.00829D0,  0.00696D0,  0.00558D0,  0.00415D0,  0.00329D0,
55453      &     0.00239D0,  0.00200D0,  0.00182D0,  0.00170D0,  0.00161D0,
55454      &     0.00151D0,  0.00140D0,  0.00127D0,  0.00113D0,  0.00099D0,
55455      &     0.00084D0,  0.00071D0,  0.00058D0,  0.00047D0,  0.00038D0,
55456      &     0.00029D0,  0.00023D0,  0.00017D0,  0.00013D0,  0.00009D0,
55457      &     0.00006D0,  0.00004D0,  0.00003D0,  0.00001D0,  0.00000D0,
55458      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55459       DATA (FMRS(2,5,I, 4),I=1,49)/
55460      &     0.07423D0,  0.06794D0,  0.06215D0,  0.05896D0,  0.05679D0,
55461      &     0.05514D0,  0.05023D0,  0.04550D0,  0.04276D0,  0.04079D0,
55462      &     0.03919D0,  0.03404D0,  0.02827D0,  0.02460D0,  0.02188D0,
55463      &     0.01974D0,  0.01650D0,  0.01320D0,  0.00980D0,  0.00778D0,
55464      &     0.00567D0,  0.00475D0,  0.00430D0,  0.00399D0,  0.00376D0,
55465      &     0.00351D0,  0.00322D0,  0.00290D0,  0.00256D0,  0.00223D0,
55466      &     0.00189D0,  0.00158D0,  0.00129D0,  0.00104D0,  0.00083D0,
55467      &     0.00064D0,  0.00049D0,  0.00037D0,  0.00027D0,  0.00020D0,
55468      &     0.00014D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00000D0,
55469      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55470       DATA (FMRS(2,5,I, 5),I=1,49)/
55471      &     0.13335D0,  0.12014D0,  0.10818D0,  0.10170D0,  0.09731D0,
55472      &     0.09401D0,  0.08430D0,  0.07519D0,  0.07001D0,  0.06635D0,
55473      &     0.06344D0,  0.05426D0,  0.04442D0,  0.03837D0,  0.03396D0,
55474      &     0.03053D0,  0.02541D0,  0.02025D0,  0.01501D0,  0.01192D0,
55475      &     0.00870D0,  0.00726D0,  0.00654D0,  0.00602D0,  0.00561D0,
55476      &     0.00519D0,  0.00472D0,  0.00422D0,  0.00370D0,  0.00319D0,
55477      &     0.00269D0,  0.00224D0,  0.00183D0,  0.00146D0,  0.00116D0,
55478      &     0.00089D0,  0.00068D0,  0.00051D0,  0.00038D0,  0.00027D0,
55479      &     0.00019D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00000D0,
55480      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55481       DATA (FMRS(2,5,I, 6),I=1,49)/
55482      &     0.20163D0,  0.17920D0,  0.15918D0,  0.14846D0,  0.14125D0,
55483      &     0.13587D0,  0.12018D0,  0.10574D0,  0.09768D0,  0.09205D0,
55484      &     0.08763D0,  0.07395D0,  0.05979D0,  0.05130D0,  0.04521D0,
55485      &     0.04052D0,  0.03360D0,  0.02669D0,  0.01976D0,  0.01569D0,
55486      &     0.01145D0,  0.00954D0,  0.00855D0,  0.00780D0,  0.00720D0,
55487      &     0.00661D0,  0.00597D0,  0.00530D0,  0.00461D0,  0.00396D0,
55488      &     0.00333D0,  0.00275D0,  0.00223D0,  0.00178D0,  0.00140D0,
55489      &     0.00108D0,  0.00082D0,  0.00061D0,  0.00045D0,  0.00032D0,
55490      &     0.00022D0,  0.00015D0,  0.00010D0,  0.00003D0,  0.00000D0,
55491      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55492       DATA (FMRS(2,5,I, 7),I=1,49)/
55493      &     0.27774D0,  0.24395D0,  0.21415D0,  0.19835D0,  0.18780D0,
55494      &     0.17996D0,  0.15730D0,  0.13677D0,  0.12547D0,  0.11766D0,
55495      &     0.11157D0,  0.09303D0,  0.07437D0,  0.06341D0,  0.05566D0,
55496      &     0.04974D0,  0.04109D0,  0.03255D0,  0.02405D0,  0.01909D0,
55497      &     0.01394D0,  0.01158D0,  0.01033D0,  0.00936D0,  0.00857D0,
55498      &     0.00780D0,  0.00699D0,  0.00616D0,  0.00533D0,  0.00455D0,
55499      &     0.00380D0,  0.00313D0,  0.00253D0,  0.00201D0,  0.00157D0,
55500      &     0.00121D0,  0.00091D0,  0.00068D0,  0.00050D0,  0.00036D0,
55501      &     0.00024D0,  0.00016D0,  0.00011D0,  0.00003D0,  0.00000D0,
55502      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55503       DATA (FMRS(2,5,I, 8),I=1,49)/
55504      &     0.37644D0,  0.32674D0,  0.28346D0,  0.26073D0,  0.24565D0,
55505      &     0.23449D0,  0.20256D0,  0.17404D0,  0.15854D0,  0.14793D0,
55506      &     0.13972D0,  0.11511D0,  0.09095D0,  0.07707D0,  0.06738D0,
55507      &     0.06004D0,  0.04941D0,  0.03901D0,  0.02877D0,  0.02283D0,
55508      &     0.01667D0,  0.01381D0,  0.01226D0,  0.01101D0,  0.01000D0,
55509      &     0.00902D0,  0.00803D0,  0.00703D0,  0.00604D0,  0.00513D0,
55510      &     0.00426D0,  0.00349D0,  0.00280D0,  0.00222D0,  0.00173D0,
55511      &     0.00132D0,  0.00099D0,  0.00074D0,  0.00054D0,  0.00039D0,
55512      &     0.00026D0,  0.00017D0,  0.00011D0,  0.00003D0,  0.00000D0,
55513      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55514       DATA (FMRS(2,5,I, 9),I=1,49)/
55515      &     0.47784D0,  0.41072D0,  0.35284D0,  0.32270D0,  0.30279D0,
55516      &     0.28813D0,  0.24646D0,  0.20968D0,  0.18991D0,  0.17647D0,
55517      &     0.16612D0,  0.13548D0,  0.10603D0,  0.08938D0,  0.07787D0,
55518      &     0.06921D0,  0.05678D0,  0.04472D0,  0.03292D0,  0.02612D0,
55519      &     0.01906D0,  0.01575D0,  0.01392D0,  0.01241D0,  0.01119D0,
55520      &     0.01003D0,  0.00887D0,  0.00772D0,  0.00660D0,  0.00557D0,
55521      &     0.00461D0,  0.00376D0,  0.00301D0,  0.00237D0,  0.00184D0,
55522      &     0.00140D0,  0.00105D0,  0.00077D0,  0.00057D0,  0.00041D0,
55523      &     0.00027D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
55524      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55525       DATA (FMRS(2,5,I,10),I=1,49)/
55526      &     0.58781D0,  0.50078D0,  0.42641D0,  0.38796D0,  0.36269D0,
55527      &     0.34414D0,  0.29176D0,  0.24601D0,  0.22164D0,  0.20518D0,
55528      &     0.19257D0,  0.15561D0,  0.12070D0,  0.10126D0,  0.08794D0,
55529      &     0.07799D0,  0.06379D0,  0.05011D0,  0.03684D0,  0.02922D0,
55530      &     0.02130D0,  0.01755D0,  0.01544D0,  0.01368D0,  0.01225D0,
55531      &     0.01090D0,  0.00959D0,  0.00830D0,  0.00706D0,  0.00594D0,
55532      &     0.00489D0,  0.00397D0,  0.00316D0,  0.00248D0,  0.00192D0,
55533      &     0.00146D0,  0.00109D0,  0.00080D0,  0.00059D0,  0.00042D0,
55534      &     0.00027D0,  0.00018D0,  0.00012D0,  0.00003D0,  0.00000D0,
55535      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55536       DATA (FMRS(2,5,I,11),I=1,49)/
55537      &     0.68602D0,  0.58051D0,  0.49095D0,  0.44491D0,  0.41476D0,
55538      &     0.39269D0,  0.33066D0,  0.27690D0,  0.24847D0,  0.22936D0,
55539      &     0.21477D0,  0.17232D0,  0.13275D0,  0.11095D0,  0.09613D0,
55540      &     0.08510D0,  0.06944D0,  0.05445D0,  0.03997D0,  0.03169D0,
55541      &     0.02308D0,  0.01898D0,  0.01663D0,  0.01466D0,  0.01306D0,
55542      &     0.01157D0,  0.01013D0,  0.00872D0,  0.00740D0,  0.00620D0,
55543      &     0.00508D0,  0.00411D0,  0.00327D0,  0.00256D0,  0.00197D0,
55544      &     0.00149D0,  0.00111D0,  0.00081D0,  0.00060D0,  0.00042D0,
55545      &     0.00028D0,  0.00018D0,  0.00012D0,  0.00003D0,  0.00000D0,
55546      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55547       DATA (FMRS(2,5,I,12),I=1,49)/
55548      &     0.92772D0,  0.77438D0,  0.64603D0,  0.58078D0,  0.53835D0,
55549      &     0.50746D0,  0.42147D0,  0.34811D0,  0.30983D0,  0.28433D0,
55550      &     0.26501D0,  0.20960D0,  0.15924D0,  0.13208D0,  0.11385D0,
55551      &     0.10043D0,  0.08155D0,  0.06370D0,  0.04663D0,  0.03692D0,
55552      &     0.02683D0,  0.02195D0,  0.01909D0,  0.01665D0,  0.01467D0,
55553      &     0.01287D0,  0.01115D0,  0.00952D0,  0.00801D0,  0.00666D0,
55554      &     0.00542D0,  0.00436D0,  0.00344D0,  0.00268D0,  0.00205D0,
55555      &     0.00155D0,  0.00115D0,  0.00083D0,  0.00061D0,  0.00043D0,
55556      &     0.00028D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
55557      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55558       DATA (FMRS(2,5,I,13),I=1,49)/
55559      &     1.17595D0,  0.97076D0,  0.80093D0,  0.71538D0,  0.66007D0,
55560      &     0.61997D0,  0.50921D0,  0.41588D0,  0.36771D0,  0.33586D0,
55561      &     0.31184D0,  0.24377D0,  0.18310D0,  0.15092D0,  0.12956D0,
55562      &     0.11394D0,  0.09216D0,  0.07174D0,  0.05238D0,  0.04143D0,
55563      &     0.03003D0,  0.02446D0,  0.02114D0,  0.01827D0,  0.01595D0,
55564      &     0.01387D0,  0.01193D0,  0.01011D0,  0.00845D0,  0.00698D0,
55565      &     0.00565D0,  0.00451D0,  0.00355D0,  0.00275D0,  0.00209D0,
55566      &     0.00157D0,  0.00116D0,  0.00084D0,  0.00061D0,  0.00043D0,
55567      &     0.00028D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
55568      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55569       DATA (FMRS(2,5,I,14),I=1,49)/
55570      &     1.49839D0,  1.22261D0,  0.99703D0,  0.88447D0,  0.81213D0,
55571      &     0.75993D0,  0.61688D0,  0.49791D0,  0.43718D0,  0.39731D0,
55572      &     0.36742D0,  0.28369D0,  0.21052D0,  0.17237D0,  0.14732D0,
55573      &     0.12915D0,  0.10402D0,  0.08067D0,  0.05873D0,  0.04638D0,
55574      &     0.03352D0,  0.02715D0,  0.02331D0,  0.01995D0,  0.01725D0,
55575      &     0.01486D0,  0.01267D0,  0.01065D0,  0.00884D0,  0.00725D0,
55576      &     0.00583D0,  0.00463D0,  0.00362D0,  0.00279D0,  0.00211D0,
55577      &     0.00158D0,  0.00116D0,  0.00083D0,  0.00061D0,  0.00043D0,
55578      &     0.00027D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
55579      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55580       DATA (FMRS(2,5,I,15),I=1,49)/
55581      &     1.87945D0,  1.51634D0,  1.22268D0,  1.07750D0,  0.98475D0,
55582      &     0.91809D0,  0.73686D0,  0.58798D0,  0.51279D0,  0.46377D0,
55583      &     0.42722D0,  0.32591D0,  0.23902D0,  0.19443D0,  0.16545D0,
55584      &     0.14459D0,  0.11596D0,  0.08960D0,  0.06503D0,  0.05127D0,
55585      &     0.03691D0,  0.02973D0,  0.02534D0,  0.02147D0,  0.01838D0,
55586      &     0.01569D0,  0.01327D0,  0.01107D0,  0.00912D0,  0.00743D0,
55587      &     0.00594D0,  0.00469D0,  0.00364D0,  0.00279D0,  0.00210D0,
55588      &     0.00156D0,  0.00114D0,  0.00082D0,  0.00059D0,  0.00041D0,
55589      &     0.00026D0,  0.00017D0,  0.00010D0,  0.00003D0,  0.00000D0,
55590      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55591       DATA (FMRS(2,5,I,16),I=1,49)/
55592      &     2.27429D0,  1.81716D0,  1.45106D0,  1.27151D0,  1.15736D0,
55593      &     1.07564D0,  0.85491D0,  0.67549D0,  0.58568D0,  0.52749D0,
55594      &     0.48429D0,  0.36563D0,  0.26542D0,  0.21469D0,  0.18200D0,
55595      &     0.15862D0,  0.12673D0,  0.09760D0,  0.07063D0,  0.05559D0,
55596      &     0.03988D0,  0.03195D0,  0.02705D0,  0.02273D0,  0.01930D0,
55597      &     0.01634D0,  0.01371D0,  0.01136D0,  0.00930D0,  0.00753D0,
55598      &     0.00599D0,  0.00470D0,  0.00364D0,  0.00277D0,  0.00208D0,
55599      &     0.00154D0,  0.00112D0,  0.00080D0,  0.00058D0,  0.00040D0,
55600      &     0.00025D0,  0.00016D0,  0.00010D0,  0.00003D0,  0.00000D0,
55601      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55602       DATA (FMRS(2,5,I,17),I=1,49)/
55603      &     2.72539D0,  2.15724D0,  1.70653D0,  1.48715D0,  1.34837D0,
55604      &     1.24937D0,  0.98364D0,  0.76983D0,  0.66373D0,  0.59537D0,
55605      &     0.54484D0,  0.40724D0,  0.29272D0,  0.23547D0,  0.19888D0,
55606      &     0.17287D0,  0.13761D0,  0.10564D0,  0.07622D0,  0.05987D0,
55607      &     0.04278D0,  0.03409D0,  0.02869D0,  0.02390D0,  0.02012D0,
55608      &     0.01691D0,  0.01408D0,  0.01159D0,  0.00943D0,  0.00759D0,
55609      &     0.00600D0,  0.00469D0,  0.00361D0,  0.00273D0,  0.00204D0,
55610      &     0.00151D0,  0.00109D0,  0.00078D0,  0.00056D0,  0.00039D0,
55611      &     0.00024D0,  0.00015D0,  0.00009D0,  0.00003D0,  0.00000D0,
55612      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55613       DATA (FMRS(2,5,I,18),I=1,49)/
55614      &     3.13641D0,  2.46418D0,  1.93488D0,  1.67881D0,  1.51744D0,
55615      &     1.40264D0,  1.09608D0,  0.85138D0,  0.73076D0,  0.65340D0,
55616      &     0.59642D0,  0.44225D0,  0.31539D0,  0.25259D0,  0.21272D0,
55617      &     0.18450D0,  0.14644D0,  0.11211D0,  0.08069D0,  0.06328D0,
55618      &     0.04506D0,  0.03575D0,  0.02993D0,  0.02476D0,  0.02070D0,
55619      &     0.01729D0,  0.01432D0,  0.01172D0,  0.00949D0,  0.00760D0,
55620      &     0.00598D0,  0.00466D0,  0.00357D0,  0.00269D0,  0.00201D0,
55621      &     0.00147D0,  0.00106D0,  0.00075D0,  0.00054D0,  0.00038D0,
55622      &     0.00023D0,  0.00015D0,  0.00009D0,  0.00003D0,  0.00000D0,
55623      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55624       DATA (FMRS(2,5,I,19),I=1,49)/
55625      &     3.68153D0,  2.86757D0,  2.23222D0,  1.92702D0,  1.73553D0,
55626      &     1.59976D0,  1.23927D0,  0.95419D0,  0.81477D0,  0.72581D0,
55627      &     0.66053D0,  0.48527D0,  0.34292D0,  0.27324D0,  0.22931D0,
55628      &     0.19839D0,  0.15691D0,  0.11975D0,  0.08593D0,  0.06725D0,
55629      &     0.04768D0,  0.03762D0,  0.03130D0,  0.02569D0,  0.02130D0,
55630      &     0.01766D0,  0.01453D0,  0.01182D0,  0.00951D0,  0.00757D0,
55631      &     0.00594D0,  0.00459D0,  0.00350D0,  0.00264D0,  0.00195D0,
55632      &     0.00143D0,  0.00103D0,  0.00072D0,  0.00052D0,  0.00036D0,
55633      &     0.00022D0,  0.00014D0,  0.00008D0,  0.00003D0,  0.00000D0,
55634      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55635       DATA (FMRS(2,5,I,20),I=1,49)/
55636      &     4.21665D0,  3.26014D0,  2.51906D0,  2.16522D0,  1.94405D0,
55637      &     1.78768D0,  1.37455D0,  1.05042D0,  0.89295D0,  0.79293D0,
55638      &     0.71977D0,  0.52460D0,  0.36780D0,  0.29178D0,  0.24415D0,
55639      &     0.21076D0,  0.16620D0,  0.12648D0,  0.09052D0,  0.07070D0,
55640      &     0.04993D0,  0.03920D0,  0.03244D0,  0.02644D0,  0.02178D0,
55641      &     0.01794D0,  0.01467D0,  0.01187D0,  0.00951D0,  0.00753D0,
55642      &     0.00588D0,  0.00453D0,  0.00344D0,  0.00258D0,  0.00191D0,
55643      &     0.00139D0,  0.00099D0,  0.00070D0,  0.00050D0,  0.00035D0,
55644      &     0.00021D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00000D0,
55645      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55646       DATA (FMRS(2,5,I,21),I=1,49)/
55647      &     4.73651D0,  3.63839D0,  2.79314D0,  2.39169D0,  2.14159D0,
55648      &     1.96521D0,  1.50121D0,  1.13968D0,  0.96506D0,  0.85456D0,
55649      &     0.77398D0,  0.56020D0,  0.39006D0,  0.30823D0,  0.25724D0,
55650      &     0.22164D0,  0.17431D0,  0.13232D0,  0.09445D0,  0.07364D0,
55651      &     0.05181D0,  0.04050D0,  0.03335D0,  0.02701D0,  0.02212D0,
55652      &     0.01812D0,  0.01474D0,  0.01187D0,  0.00946D0,  0.00747D0,
55653      &     0.00580D0,  0.00446D0,  0.00337D0,  0.00252D0,  0.00185D0,
55654      &     0.00135D0,  0.00096D0,  0.00068D0,  0.00049D0,  0.00034D0,
55655      &     0.00020D0,  0.00013D0,  0.00007D0,  0.00003D0,  0.00000D0,
55656      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55657       DATA (FMRS(2,5,I,22),I=1,49)/
55658      &     5.45753D0,  4.15887D0,  3.16726D0,  2.69936D0,  2.40907D0,
55659      &     2.20495D0,  1.67083D0,  1.25820D0,  1.06032D0,  0.93568D0,
55660      &     0.84511D0,  0.60646D0,  0.41869D0,  0.32928D0,  0.27391D0,
55661      &     0.23544D0,  0.18455D0,  0.13964D0,  0.09936D0,  0.07728D0,
55662      &     0.05411D0,  0.04206D0,  0.03442D0,  0.02766D0,  0.02248D0,
55663      &     0.01829D0,  0.01478D0,  0.01184D0,  0.00938D0,  0.00736D0,
55664      &     0.00570D0,  0.00435D0,  0.00328D0,  0.00244D0,  0.00179D0,
55665      &     0.00129D0,  0.00092D0,  0.00065D0,  0.00046D0,  0.00032D0,
55666      &     0.00019D0,  0.00012D0,  0.00007D0,  0.00003D0,  0.00000D0,
55667      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55668       DATA (FMRS(2,5,I,23),I=1,49)/
55669      &     6.19783D0,  4.68879D0,  3.54494D0,  3.00840D0,  2.67675D0,
55670      &     2.44420D0,  1.83862D0,  1.37436D0,  1.15316D0,  1.01443D0,
55671      &     0.91394D0,  0.65074D0,  0.44579D0,  0.34906D0,  0.28951D0,
55672      &     0.24830D0,  0.19403D0,  0.14639D0,  0.10384D0,  0.08058D0,
55673      &     0.05616D0,  0.04343D0,  0.03534D0,  0.02820D0,  0.02276D0,
55674      &     0.01841D0,  0.01478D0,  0.01177D0,  0.00929D0,  0.00725D0,
55675      &     0.00558D0,  0.00425D0,  0.00319D0,  0.00236D0,  0.00173D0,
55676      &     0.00124D0,  0.00088D0,  0.00062D0,  0.00044D0,  0.00031D0,
55677      &     0.00018D0,  0.00011D0,  0.00007D0,  0.00003D0,  0.00000D0,
55678      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55679       DATA (FMRS(2,5,I,24),I=1,49)/
55680      &     6.92966D0,  5.20839D0,  3.91218D0,  3.30740D0,  2.93482D0,
55681      &     2.67420D0,  1.99847D0,  1.48399D0,  1.24028D0,  1.08801D0,
55682      &     0.97803D0,  0.69152D0,  0.47043D0,  0.36691D0,  0.30350D0,
55683      &     0.25978D0,  0.20243D0,  0.15231D0,  0.10773D0,  0.08341D0,
55684      &     0.05788D0,  0.04454D0,  0.03605D0,  0.02858D0,  0.02293D0,
55685      &     0.01844D0,  0.01473D0,  0.01167D0,  0.00917D0,  0.00713D0,
55686      &     0.00547D0,  0.00415D0,  0.00310D0,  0.00229D0,  0.00167D0,
55687      &     0.00120D0,  0.00085D0,  0.00059D0,  0.00043D0,  0.00030D0,
55688      &     0.00017D0,  0.00011D0,  0.00006D0,  0.00003D0,  0.00000D0,
55689      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55690       DATA (FMRS(2,5,I,25),I=1,49)/
55691      &     7.72396D0,  5.76848D0,  4.30532D0,  3.62618D0,  3.20915D0,
55692      &     2.91815D0,  2.16681D0,  1.59861D0,  1.33097D0,  1.16435D0,
55693      &     1.04435D0,  0.73337D0,  0.49551D0,  0.38498D0,  0.31761D0,
55694      &     0.27133D0,  0.21084D0,  0.15821D0,  0.11158D0,  0.08620D0,
55695      &     0.05955D0,  0.04560D0,  0.03673D0,  0.02893D0,  0.02307D0,
55696      &     0.01845D0,  0.01466D0,  0.01156D0,  0.00904D0,  0.00700D0,
55697      &     0.00535D0,  0.00404D0,  0.00301D0,  0.00221D0,  0.00161D0,
55698      &     0.00115D0,  0.00081D0,  0.00057D0,  0.00041D0,  0.00028D0,
55699      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00003D0,  0.00000D0,
55700      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55701       DATA (FMRS(2,5,I,26),I=1,49)/
55702      &     8.54145D0,  6.34073D0,  4.70401D0,  3.94803D0,  3.48525D0,
55703      &     3.16305D0,  2.33446D0,  1.71181D0,  1.42007D0,  1.23908D0,
55704      &     1.10907D0,  0.77380D0,  0.51947D0,  0.40212D0,  0.33092D0,
55705      &     0.28218D0,  0.21869D0,  0.16367D0,  0.11510D0,  0.08871D0,
55706      &     0.06103D0,  0.04651D0,  0.03727D0,  0.02918D0,  0.02314D0,
55707      &     0.01840D0,  0.01456D0,  0.01142D0,  0.00889D0,  0.00686D0,
55708      &     0.00522D0,  0.00393D0,  0.00292D0,  0.00214D0,  0.00155D0,
55709      &     0.00111D0,  0.00078D0,  0.00054D0,  0.00039D0,  0.00027D0,
55710      &     0.00016D0,  0.00009D0,  0.00005D0,  0.00003D0,  0.00000D0,
55711      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55712       DATA (FMRS(2,5,I,27),I=1,49)/
55713      &     9.36625D0,  6.91445D0,  5.10115D0,  4.26741D0,  3.75848D0,
55714      &     3.40490D0,  2.49891D0,  1.82207D0,  1.50649D0,  1.31134D0,
55715      &     1.17150D0,  0.81249D0,  0.54219D0,  0.41829D0,  0.34343D0,
55716      &     0.29234D0,  0.22601D0,  0.16873D0,  0.11834D0,  0.09101D0,
55717      &     0.06235D0,  0.04731D0,  0.03774D0,  0.02938D0,  0.02318D0,
55718      &     0.01834D0,  0.01444D0,  0.01128D0,  0.00875D0,  0.00672D0,
55719      &     0.00510D0,  0.00383D0,  0.00283D0,  0.00207D0,  0.00150D0,
55720      &     0.00107D0,  0.00075D0,  0.00052D0,  0.00038D0,  0.00026D0,
55721      &     0.00015D0,  0.00009D0,  0.00005D0,  0.00003D0,  0.00000D0,
55722      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55723       DATA (FMRS(2,5,I,28),I=1,49)/
55724      &    10.18132D0,  7.47793D0,  5.48877D0,  4.57798D0,  4.02345D0,
55725      &     3.63894D0,  2.65699D0,  1.92733D0,  1.58864D0,  1.37981D0,
55726      &     1.23051D0,  0.84875D0,  0.56329D0,  0.43322D0,  0.35493D0,
55727      &     0.30165D0,  0.23267D0,  0.17330D0,  0.12123D0,  0.09305D0,
55728      &     0.06349D0,  0.04798D0,  0.03811D0,  0.02952D0,  0.02317D0,
55729      &     0.01825D0,  0.01431D0,  0.01114D0,  0.00861D0,  0.00659D0,
55730      &     0.00498D0,  0.00373D0,  0.00275D0,  0.00201D0,  0.00145D0,
55731      &     0.00103D0,  0.00072D0,  0.00050D0,  0.00036D0,  0.00026D0,
55732      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00003D0,  0.00000D0,
55733      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55734       DATA (FMRS(2,5,I,29),I=1,49)/
55735      &    11.04388D0,  8.07089D0,  5.89435D0,  4.90182D0,  4.29909D0,
55736      &     3.88193D0,  2.82014D0,  2.03528D0,  1.67258D0,  1.44958D0,
55737      &     1.29048D0,  0.88533D0,  0.58442D0,  0.44808D0,  0.36634D0,
55738      &     0.31085D0,  0.23922D0,  0.17778D0,  0.12404D0,  0.09501D0,
55739      &     0.06457D0,  0.04859D0,  0.03843D0,  0.02962D0,  0.02314D0,
55740      &     0.01814D0,  0.01416D0,  0.01098D0,  0.00846D0,  0.00645D0,
55741      &     0.00486D0,  0.00363D0,  0.00267D0,  0.00194D0,  0.00140D0,
55742      &     0.00099D0,  0.00069D0,  0.00048D0,  0.00035D0,  0.00025D0,
55743      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00003D0,  0.00000D0,
55744      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55745       DATA (FMRS(2,5,I,30),I=1,49)/
55746      &    11.92777D0,  8.67505D0,  6.30518D0,  5.22873D0,  4.57663D0,
55747      &     4.12613D0,  2.98306D0,  2.14237D0,  1.75551D0,  1.51831D0,
55748      &     1.34943D0,  0.92100D0,  0.60483D0,  0.46237D0,  0.37725D0,
55749      &     0.31962D0,  0.24543D0,  0.18198D0,  0.12665D0,  0.09681D0,
55750      &     0.06554D0,  0.04912D0,  0.03869D0,  0.02967D0,  0.02307D0,
55751      &     0.01801D0,  0.01401D0,  0.01082D0,  0.00830D0,  0.00632D0,
55752      &     0.00475D0,  0.00353D0,  0.00259D0,  0.00188D0,  0.00135D0,
55753      &     0.00095D0,  0.00066D0,  0.00047D0,  0.00034D0,  0.00024D0,
55754      &     0.00014D0,  0.00008D0,  0.00004D0,  0.00002D0,  0.00000D0,
55755      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55756       DATA (FMRS(2,5,I,31),I=1,49)/
55757      &    12.81161D0,  9.27611D0,  6.71181D0,  5.55130D0,  4.84990D0,
55758      &     4.36615D0,  3.14234D0,  2.24650D0,  1.83587D0,  1.58474D0,
55759      &     1.40629D0,  0.95519D0,  0.62425D0,  0.47590D0,  0.38756D0,
55760      &     0.32788D0,  0.25125D0,  0.18591D0,  0.12907D0,  0.09846D0,
55761      &     0.06642D0,  0.04959D0,  0.03891D0,  0.02970D0,  0.02299D0,
55762      &     0.01788D0,  0.01385D0,  0.01067D0,  0.00816D0,  0.00619D0,
55763      &     0.00464D0,  0.00344D0,  0.00252D0,  0.00182D0,  0.00130D0,
55764      &     0.00092D0,  0.00064D0,  0.00045D0,  0.00033D0,  0.00023D0,
55765      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
55766      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55767       DATA (FMRS(2,5,I,32),I=1,49)/
55768      &    13.67059D0,  9.85720D0,  7.10279D0,  5.86046D0,  5.11119D0,
55769      &     4.59523D0,  3.29346D0,  2.34466D0,  1.91134D0,  1.64694D0,
55770      &     1.45941D0,  0.98687D0,  0.64209D0,  0.48825D0,  0.39691D0,
55771      &     0.33535D0,  0.25648D0,  0.18940D0,  0.13119D0,  0.09990D0,
55772      &     0.06714D0,  0.04995D0,  0.03906D0,  0.02968D0,  0.02289D0,
55773      &     0.01773D0,  0.01369D0,  0.01051D0,  0.00801D0,  0.00606D0,
55774      &     0.00453D0,  0.00335D0,  0.00245D0,  0.00177D0,  0.00126D0,
55775      &     0.00089D0,  0.00062D0,  0.00043D0,  0.00032D0,  0.00023D0,
55776      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
55777      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55778       DATA (FMRS(2,5,I,33),I=1,49)/
55779      &    14.58850D0, 10.47558D0,  7.51716D0,  6.18731D0,  5.38695D0,
55780      &     4.83668D0,  3.45207D0,  2.44727D0,  1.99002D0,  1.71168D0,
55781      &     1.51462D0,  1.01965D0,  0.66046D0,  0.50094D0,  0.40651D0,
55782      &     0.34300D0,  0.26182D0,  0.19296D0,  0.13335D0,  0.10136D0,
55783      &     0.06788D0,  0.05032D0,  0.03921D0,  0.02967D0,  0.02278D0,
55784      &     0.01759D0,  0.01353D0,  0.01035D0,  0.00787D0,  0.00594D0,
55785      &     0.00443D0,  0.00327D0,  0.00238D0,  0.00172D0,  0.00122D0,
55786      &     0.00086D0,  0.00060D0,  0.00042D0,  0.00031D0,  0.00022D0,
55787      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
55788      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55789       DATA (FMRS(2,5,I,34),I=1,49)/
55790      &    15.50215D0, 11.08776D0,  7.92505D0,  6.50796D0,  5.65681D0,
55791      &     5.07248D0,  3.60600D0,  2.54615D0,  2.06552D0,  1.77359D0,
55792      &     1.56726D0,  1.05062D0,  0.67763D0,  0.51270D0,  0.41535D0,
55793      &     0.35001D0,  0.26666D0,  0.19615D0,  0.13524D0,  0.10260D0,
55794      &     0.06847D0,  0.05058D0,  0.03928D0,  0.02960D0,  0.02264D0,
55795      &     0.01742D0,  0.01336D0,  0.01019D0,  0.00772D0,  0.00581D0,
55796      &     0.00432D0,  0.00318D0,  0.00232D0,  0.00166D0,  0.00118D0,
55797      &     0.00083D0,  0.00058D0,  0.00041D0,  0.00030D0,  0.00022D0,
55798      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
55799      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55800       DATA (FMRS(2,5,I,35),I=1,49)/
55801      &    16.42021D0, 11.70052D0,  8.33176D0,  6.82695D0,  5.92484D0,
55802      &     5.30641D0,  3.75809D0,  2.64348D0,  2.13966D0,  1.83429D0,
55803      &     1.61881D0,  1.08081D0,  0.69429D0,  0.52409D0,  0.42389D0,
55804      &     0.35678D0,  0.27133D0,  0.19921D0,  0.13706D0,  0.10380D0,
55805      &     0.06904D0,  0.05083D0,  0.03934D0,  0.02953D0,  0.02251D0,
55806      &     0.01726D0,  0.01320D0,  0.01004D0,  0.00759D0,  0.00569D0,
55807      &     0.00422D0,  0.00310D0,  0.00225D0,  0.00162D0,  0.00115D0,
55808      &     0.00080D0,  0.00056D0,  0.00039D0,  0.00029D0,  0.00021D0,
55809      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
55810      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55811       DATA (FMRS(2,5,I,36),I=1,49)/
55812      &    17.31499D0, 12.29519D0,  8.72473D0,  7.13436D0,  6.18265D0,
55813      &     5.53107D0,  3.90347D0,  2.73604D0,  2.20994D0,  1.89170D0,
55814      &     1.66747D0,  1.10914D0,  0.70980D0,  0.53464D0,  0.43178D0,
55815      &     0.36300D0,  0.27560D0,  0.20200D0,  0.13869D0,  0.10485D0,
55816      &     0.06952D0,  0.05103D0,  0.03937D0,  0.02945D0,  0.02237D0,
55817      &     0.01710D0,  0.01303D0,  0.00989D0,  0.00746D0,  0.00558D0,
55818      &     0.00413D0,  0.00303D0,  0.00220D0,  0.00157D0,  0.00111D0,
55819      &     0.00078D0,  0.00054D0,  0.00038D0,  0.00028D0,  0.00021D0,
55820      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
55821      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55822       DATA (FMRS(2,5,I,37),I=1,49)/
55823      &    18.24071D0, 12.90782D0,  9.12782D0,  7.44886D0,  6.44591D0,
55824      &     5.76014D0,  4.05101D0,  2.82949D0,  2.28068D0,  1.94934D0,
55825      &     1.71624D0,  1.13734D0,  0.72513D0,  0.54501D0,  0.43949D0,
55826      &     0.36907D0,  0.27974D0,  0.20467D0,  0.14023D0,  0.10583D0,
55827      &     0.06996D0,  0.05118D0,  0.03937D0,  0.02934D0,  0.02221D0,
55828      &     0.01693D0,  0.01286D0,  0.00973D0,  0.00732D0,  0.00547D0,
55829      &     0.00404D0,  0.00296D0,  0.00214D0,  0.00153D0,  0.00108D0,
55830      &     0.00076D0,  0.00052D0,  0.00037D0,  0.00027D0,  0.00020D0,
55831      &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
55832      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55833       DATA (FMRS(2,5,I,38),I=1,49)/
55834      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55835      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55836      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55837      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55838      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55839      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55840      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55841      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55842      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
55843      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55844       DATA (FMRS(2,6,I, 1),I=1,49)/
55845      &     0.49855D0,  0.42587D0,  0.36389D0,  0.33197D0,  0.31109D0,
55846      &     0.29584D0,  0.25332D0,  0.21750D0,  0.19938D0,  0.18774D0,
55847      &     0.17961D0,  0.15726D0,  0.13904D0,  0.12982D0,  0.12379D0,
55848      &     0.11933D0,  0.11282D0,  0.10593D0,  0.09760D0,  0.09090D0,
55849      &     0.07946D0,  0.06933D0,  0.06013D0,  0.04980D0,  0.04078D0,
55850      &     0.03302D0,  0.02641D0,  0.02091D0,  0.01639D0,  0.01253D0,
55851      &     0.00964D0,  0.00728D0,  0.00545D0,  0.00406D0,  0.00291D0,
55852      &     0.00211D0,  0.00151D0,  0.00106D0,  0.00067D0,  0.00051D0,
55853      &     0.00036D0,  0.00020D0,  0.00015D0,  0.00005D0,  0.00001D0,
55854      &    -0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
55855       DATA (FMRS(2,6,I, 2),I=1,49)/
55856      &     0.50643D0,  0.43610D0,  0.37562D0,  0.34428D0,  0.32368D0,
55857      &     0.30859D0,  0.26628D0,  0.23029D0,  0.21194D0,  0.20007D0,
55858      &     0.19176D0,  0.16857D0,  0.14897D0,  0.13868D0,  0.13176D0,
55859      &     0.12655D0,  0.11883D0,  0.11060D0,  0.10078D0,  0.09314D0,
55860      &     0.08065D0,  0.07007D0,  0.06069D0,  0.05033D0,  0.04135D0,
55861      &     0.03363D0,  0.02706D0,  0.02157D0,  0.01702D0,  0.01315D0,
55862      &     0.01020D0,  0.00777D0,  0.00589D0,  0.00442D0,  0.00323D0,
55863      &     0.00236D0,  0.00171D0,  0.00122D0,  0.00079D0,  0.00059D0,
55864      &     0.00042D0,  0.00024D0,  0.00018D0,  0.00006D0,  0.00002D0,
55865      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55866       DATA (FMRS(2,6,I, 3),I=1,49)/
55867      &     0.53555D0,  0.46535D0,  0.40441D0,  0.37256D0,  0.35153D0,
55868      &     0.33606D0,  0.29238D0,  0.25475D0,  0.23531D0,  0.22262D0,
55869      &     0.21361D0,  0.18804D0,  0.16542D0,  0.15305D0,  0.14451D0,
55870      &     0.13799D0,  0.12824D0,  0.11785D0,  0.10571D0,  0.09664D0,
55871      &     0.08259D0,  0.07132D0,  0.06165D0,  0.05118D0,  0.04219D0,
55872      &     0.03449D0,  0.02794D0,  0.02243D0,  0.01784D0,  0.01392D0,
55873      &     0.01089D0,  0.00837D0,  0.00641D0,  0.00486D0,  0.00360D0,
55874      &     0.00265D0,  0.00193D0,  0.00138D0,  0.00092D0,  0.00067D0,
55875      &     0.00048D0,  0.00029D0,  0.00022D0,  0.00008D0,  0.00002D0,
55876      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55877       DATA (FMRS(2,6,I, 4),I=1,49)/
55878      &     0.57226D0,  0.49911D0,  0.43533D0,  0.40188D0,  0.37974D0,
55879      &     0.36342D0,  0.31717D0,  0.27704D0,  0.25615D0,  0.24242D0,
55880      &     0.23256D0,  0.20428D0,  0.17865D0,  0.16439D0,  0.15446D0,
55881      &     0.14683D0,  0.13543D0,  0.12334D0,  0.10944D0,  0.09929D0,
55882      &     0.08411D0,  0.07232D0,  0.06240D0,  0.05181D0,  0.04280D0,
55883      &     0.03507D0,  0.02851D0,  0.02298D0,  0.01835D0,  0.01437D0,
55884      &     0.01128D0,  0.00872D0,  0.00670D0,  0.00509D0,  0.00378D0,
55885      &     0.00278D0,  0.00204D0,  0.00149D0,  0.00099D0,  0.00072D0,
55886      &     0.00050D0,  0.00032D0,  0.00023D0,  0.00009D0,  0.00003D0,
55887      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55888       DATA (FMRS(2,6,I, 5),I=1,49)/
55889      &     0.63213D0,  0.55147D0,  0.48109D0,  0.44417D0,  0.41970D0,
55890      &     0.40166D0,  0.35046D0,  0.30587D0,  0.28254D0,  0.26712D0,
55891      &     0.25592D0,  0.22358D0,  0.19384D0,  0.17718D0,  0.16554D0,
55892      &     0.15661D0,  0.14330D0,  0.12931D0,  0.11348D0,  0.10220D0,
55893      &     0.08579D0,  0.07344D0,  0.06325D0,  0.05250D0,  0.04341D0,
55894      &     0.03561D0,  0.02901D0,  0.02344D0,  0.01875D0,  0.01473D0,
55895      &     0.01158D0,  0.00897D0,  0.00690D0,  0.00525D0,  0.00392D0,
55896      &     0.00287D0,  0.00212D0,  0.00153D0,  0.00104D0,  0.00075D0,
55897      &     0.00052D0,  0.00033D0,  0.00023D0,  0.00009D0,  0.00002D0,
55898      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55899       DATA (FMRS(2,6,I, 6),I=1,49)/
55900      &     0.69484D0,  0.60548D0,  0.52759D0,  0.48675D0,  0.45969D0,
55901      &     0.43974D0,  0.38311D0,  0.33372D0,  0.30779D0,  0.29059D0,
55902      &     0.27800D0,  0.24152D0,  0.20772D0,  0.18874D0,  0.17549D0,
55903      &     0.16535D0,  0.15028D0,  0.13457D0,  0.11704D0,  0.10475D0,
55904      &     0.08728D0,  0.07444D0,  0.06400D0,  0.05308D0,  0.04390D0,
55905      &     0.03605D0,  0.02939D0,  0.02378D0,  0.01903D0,  0.01499D0,
55906      &     0.01179D0,  0.00914D0,  0.00703D0,  0.00535D0,  0.00400D0,
55907      &     0.00293D0,  0.00217D0,  0.00156D0,  0.00107D0,  0.00077D0,
55908      &     0.00053D0,  0.00034D0,  0.00024D0,  0.00009D0,  0.00002D0,
55909      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55910       DATA (FMRS(2,6,I, 7),I=1,49)/
55911      &     0.77164D0,  0.67034D0,  0.58230D0,  0.53624D0,  0.50577D0,
55912      &     0.48332D0,  0.41966D0,  0.36421D0,  0.33508D0,  0.31572D0,
55913      &     0.30145D0,  0.26012D0,  0.22178D0,  0.20031D0,  0.18536D0,
55914      &     0.17396D0,  0.15711D0,  0.13969D0,  0.12049D0,  0.10724D0,
55915      &     0.08874D0,  0.07542D0,  0.06472D0,  0.05362D0,  0.04433D0,
55916      &     0.03642D0,  0.02969D0,  0.02403D0,  0.01923D0,  0.01516D0,
55917      &     0.01193D0,  0.00926D0,  0.00710D0,  0.00541D0,  0.00405D0,
55918      &     0.00297D0,  0.00219D0,  0.00158D0,  0.00108D0,  0.00077D0,
55919      &     0.00052D0,  0.00033D0,  0.00024D0,  0.00008D0,  0.00002D0,
55920      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55921       DATA (FMRS(2,6,I, 8),I=1,49)/
55922      &     0.86838D0,  0.75105D0,  0.64953D0,  0.59658D0,  0.56163D0,
55923      &     0.53592D0,  0.46317D0,  0.39995D0,  0.36678D0,  0.34473D0,
55924      &     0.32838D0,  0.28112D0,  0.23740D0,  0.21303D0,  0.19616D0,
55925      &     0.18334D0,  0.16450D0,  0.14520D0,  0.12419D0,  0.10991D0,
55926      &     0.09031D0,  0.07647D0,  0.06547D0,  0.05416D0,  0.04475D0,
55927      &     0.03674D0,  0.02994D0,  0.02423D0,  0.01939D0,  0.01529D0,
55928      &     0.01202D0,  0.00932D0,  0.00715D0,  0.00545D0,  0.00407D0,
55929      &     0.00298D0,  0.00220D0,  0.00159D0,  0.00108D0,  0.00077D0,
55930      &     0.00052D0,  0.00033D0,  0.00024D0,  0.00008D0,  0.00002D0,
55931      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55932       DATA (FMRS(2,6,I, 9),I=1,49)/
55933      &     0.96608D0,  0.83177D0,  0.71606D0,  0.65593D0,  0.61632D0,
55934      &     0.58722D0,  0.50510D0,  0.43397D0,  0.39671D0,  0.37195D0,
55935      &     0.35355D0,  0.30046D0,  0.25156D0,  0.22448D0,  0.20581D0,
55936      &     0.19169D0,  0.17103D0,  0.15004D0,  0.12743D0,  0.11224D0,
55937      &     0.09169D0,  0.07737D0,  0.06612D0,  0.05461D0,  0.04508D0,
55938      &     0.03697D0,  0.03013D0,  0.02435D0,  0.01949D0,  0.01536D0,
55939      &     0.01207D0,  0.00933D0,  0.00718D0,  0.00545D0,  0.00407D0,
55940      &     0.00298D0,  0.00219D0,  0.00159D0,  0.00106D0,  0.00076D0,
55941      &     0.00052D0,  0.00033D0,  0.00024D0,  0.00009D0,  0.00002D0,
55942      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55943       DATA (FMRS(2,6,I,10),I=1,49)/
55944      &     1.07543D0,  0.92116D0,  0.78892D0,  0.72047D0,  0.67548D0,
55945      &     0.64249D0,  0.54968D0,  0.46963D0,  0.42782D0,  0.40008D0,
55946      &     0.37941D0,  0.32003D0,  0.26568D0,  0.23578D0,  0.21528D0,
55947      &     0.19985D0,  0.17739D0,  0.15473D0,  0.13057D0,  0.11449D0,
55948      &     0.09302D0,  0.07823D0,  0.06672D0,  0.05501D0,  0.04535D0,
55949      &     0.03715D0,  0.03025D0,  0.02442D0,  0.01953D0,  0.01538D0,
55950      &     0.01207D0,  0.00932D0,  0.00717D0,  0.00543D0,  0.00405D0,
55951      &     0.00296D0,  0.00217D0,  0.00158D0,  0.00105D0,  0.00075D0,
55952      &     0.00051D0,  0.00033D0,  0.00023D0,  0.00008D0,  0.00002D0,
55953      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55954       DATA (FMRS(2,6,I,11),I=1,49)/
55955      &     1.17158D0,  0.99923D0,  0.85209D0,  0.77617D0,  0.72639D0,
55956      &     0.68993D0,  0.58762D0,  0.49971D0,  0.45391D0,  0.42357D0,
55957      &     0.40096D0,  0.33616D0,  0.27719D0,  0.24495D0,  0.22293D0,
55958      &     0.20642D0,  0.18248D0,  0.15848D0,  0.13306D0,  0.11628D0,
55959      &     0.09406D0,  0.07891D0,  0.06718D0,  0.05531D0,  0.04555D0,
55960      &     0.03727D0,  0.03032D0,  0.02446D0,  0.01953D0,  0.01537D0,
55961      &     0.01205D0,  0.00930D0,  0.00714D0,  0.00540D0,  0.00402D0,
55962      &     0.00294D0,  0.00214D0,  0.00155D0,  0.00104D0,  0.00074D0,
55963      &     0.00050D0,  0.00032D0,  0.00022D0,  0.00008D0,  0.00002D0,
55964      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55965       DATA (FMRS(2,6,I,12),I=1,49)/
55966      &     1.40820D0,  1.18938D0,  1.00430D0,  0.90953D0,  0.84767D0,
55967      &     0.80252D0,  0.67658D0,  0.56932D0,  0.51382D0,  0.47719D0,
55968      &     0.44989D0,  0.37226D0,  0.30256D0,  0.26497D0,  0.23955D0,
55969      &     0.22062D0,  0.19343D0,  0.16648D0,  0.13836D0,  0.12007D0,
55970      &     0.09626D0,  0.08032D0,  0.06811D0,  0.05588D0,  0.04588D0,
55971      &     0.03745D0,  0.03039D0,  0.02446D0,  0.01948D0,  0.01531D0,
55972      &     0.01197D0,  0.00921D0,  0.00706D0,  0.00532D0,  0.00395D0,
55973      &     0.00288D0,  0.00209D0,  0.00151D0,  0.00101D0,  0.00072D0,
55974      &     0.00049D0,  0.00031D0,  0.00021D0,  0.00008D0,  0.00002D0,
55975      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55976       DATA (FMRS(2,6,I,13),I=1,49)/
55977      &     1.64756D0,  1.37951D0,  1.15467D0,  1.04031D0,  0.96596D0,
55978      &     0.91188D0,  0.76181D0,  0.63505D0,  0.56988D0,  0.52704D0,
55979      &     0.49515D0,  0.40510D0,  0.32525D0,  0.28268D0,  0.25415D0,
55980      &     0.23303D0,  0.20292D0,  0.17336D0,  0.14288D0,  0.12329D0,
55981      &     0.09812D0,  0.08148D0,  0.06886D0,  0.05629D0,  0.04609D0,
55982      &     0.03753D0,  0.03037D0,  0.02438D0,  0.01937D0,  0.01519D0,
55983      &     0.01185D0,  0.00910D0,  0.00695D0,  0.00523D0,  0.00387D0,
55984      &     0.00281D0,  0.00204D0,  0.00147D0,  0.00097D0,  0.00069D0,
55985      &     0.00048D0,  0.00029D0,  0.00020D0,  0.00007D0,  0.00002D0,
55986      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55987       DATA (FMRS(2,6,I,14),I=1,49)/
55988      &     1.95709D0,  1.62260D0,  1.34467D0,  1.20438D0,  1.11362D0,
55989      &     1.04783D0,  0.86639D0,  0.71460D0,  0.63715D0,  0.58648D0,
55990      &     0.54885D0,  0.44345D0,  0.35130D0,  0.30283D0,  0.27064D0,
55991      &     0.24698D0,  0.21351D0,  0.18099D0,  0.14786D0,  0.12681D0,
55992      &     0.10011D0,  0.08269D0,  0.06959D0,  0.05666D0,  0.04624D0,
55993      &     0.03752D0,  0.03025D0,  0.02422D0,  0.01919D0,  0.01499D0,
55994      &     0.01165D0,  0.00893D0,  0.00678D0,  0.00510D0,  0.00375D0,
55995      &     0.00271D0,  0.00197D0,  0.00141D0,  0.00093D0,  0.00065D0,
55996      &     0.00045D0,  0.00028D0,  0.00019D0,  0.00007D0,  0.00002D0,
55997      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
55998       DATA (FMRS(2,6,I,15),I=1,49)/
55999      &     2.33106D0,  1.91266D0,  1.56849D0,  1.39616D0,  1.28524D0,
56000      &     1.20514D0,  0.98569D0,  0.80398D0,  0.71204D0,  0.65222D0,
56001      &     0.60792D0,  0.48491D0,  0.37897D0,  0.32402D0,  0.28785D0,
56002      &     0.26145D0,  0.22441D0,  0.18878D0,  0.15289D0,  0.13035D0,
56003      &     0.10206D0,  0.08383D0,  0.07023D0,  0.05691D0,  0.04625D0,
56004      &     0.03736D0,  0.03004D0,  0.02396D0,  0.01891D0,  0.01473D0,
56005      &     0.01139D0,  0.00872D0,  0.00659D0,  0.00494D0,  0.00362D0,
56006      &     0.00261D0,  0.00189D0,  0.00136D0,  0.00089D0,  0.00062D0,
56007      &     0.00043D0,  0.00026D0,  0.00018D0,  0.00006D0,  0.00002D0,
56008      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56009       DATA (FMRS(2,6,I,16),I=1,49)/
56010      &     2.71585D0,  2.20785D0,  1.79373D0,  1.58787D0,  1.45597D0,
56011      &     1.36104D0,  1.10250D0,  0.89041D0,  0.78391D0,  0.71494D0,
56012      &     0.66403D0,  0.52372D0,  0.40449D0,  0.34337D0,  0.30346D0,
56013      &     0.27452D0,  0.23417D0,  0.19570D0,  0.15732D0,  0.13343D0,
56014      &     0.10373D0,  0.08475D0,  0.07072D0,  0.05705D0,  0.04617D0,
56015      &     0.03716D0,  0.02977D0,  0.02366D0,  0.01861D0,  0.01445D0,
56016      &     0.01114D0,  0.00850D0,  0.00640D0,  0.00478D0,  0.00350D0,
56017      &     0.00251D0,  0.00181D0,  0.00130D0,  0.00086D0,  0.00058D0,
56018      &     0.00040D0,  0.00024D0,  0.00016D0,  0.00006D0,  0.00002D0,
56019      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56020       DATA (FMRS(2,6,I,17),I=1,49)/
56021      &     3.15180D0,  2.53892D0,  2.04375D0,  1.79938D0,  1.64351D0,
56022      &     1.53170D0,  1.22899D0,  0.98294D0,  0.86032D0,  0.78129D0,
56023      &     0.72315D0,  0.56409D0,  0.43066D0,  0.36305D0,  0.31926D0,
56024      &     0.28768D0,  0.24394D0,  0.20257D0,  0.16168D0,  0.13644D0,
56025      &     0.10531D0,  0.08560D0,  0.07112D0,  0.05711D0,  0.04602D0,
56026      &     0.03691D0,  0.02945D0,  0.02332D0,  0.01829D0,  0.01415D0,
56027      &     0.01087D0,  0.00826D0,  0.00621D0,  0.00462D0,  0.00337D0,
56028      &     0.00241D0,  0.00173D0,  0.00124D0,  0.00082D0,  0.00055D0,
56029      &     0.00038D0,  0.00023D0,  0.00015D0,  0.00005D0,  0.00002D0,
56030      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56031       DATA (FMRS(2,6,I,18),I=1,49)/
56032      &     3.55145D0,  2.83962D0,  2.26870D0,  1.98860D0,  1.81061D0,
56033      &     1.68328D0,  1.34021D0,  1.06346D0,  0.92638D0,  0.83839D0,
56034      &     0.77383D0,  0.59827D0,  0.45255D0,  0.37938D0,  0.33229D0,
56035      &     0.29849D0,  0.25191D0,  0.20813D0,  0.16517D0,  0.13882D0,
56036      &     0.10653D0,  0.08622D0,  0.07137D0,  0.05708D0,  0.04584D0,
56037      &     0.03664D0,  0.02914D0,  0.02300D0,  0.01798D0,  0.01388D0,
56038      &     0.01064D0,  0.00807D0,  0.00604D0,  0.00448D0,  0.00326D0,
56039      &     0.00232D0,  0.00166D0,  0.00119D0,  0.00077D0,  0.00053D0,
56040      &     0.00036D0,  0.00022D0,  0.00015D0,  0.00005D0,  0.00001D0,
56041      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56042       DATA (FMRS(2,6,I,19),I=1,49)/
56043      &     4.08243D0,  3.23554D0,  2.56218D0,  2.23414D0,  2.02661D0,
56044      &     1.87862D0,  1.48217D0,  1.16519D0,  1.00935D0,  0.90979D0,
56045      &     0.83697D0,  0.64037D0,  0.47917D0,  0.39910D0,  0.34794D0,
56046      &     0.31141D0,  0.26137D0,  0.21468D0,  0.16924D0,  0.14156D0,
56047      &     0.10788D0,  0.08686D0,  0.07159D0,  0.05697D0,  0.04554D0,
56048      &     0.03624D0,  0.02871D0,  0.02258D0,  0.01759D0,  0.01353D0,
56049      &     0.01034D0,  0.00780D0,  0.00582D0,  0.00431D0,  0.00313D0,
56050      &     0.00222D0,  0.00159D0,  0.00113D0,  0.00073D0,  0.00050D0,
56051      &     0.00034D0,  0.00021D0,  0.00014D0,  0.00005D0,  0.00001D0,
56052      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56053       DATA (FMRS(2,6,I,20),I=1,49)/
56054      &     4.59984D0,  3.61795D0,  2.84314D0,  2.46798D0,  2.23154D0,
56055      &     2.06341D0,  1.61522D0,  1.25965D0,  1.08594D0,  0.97542D0,
56056      &     0.89482D0,  0.67853D0,  0.50302D0,  0.41664D0,  0.36179D0,
56057      &     0.32280D0,  0.26966D0,  0.22039D0,  0.17274D0,  0.14391D0,
56058      &     0.10901D0,  0.08736D0,  0.07173D0,  0.05682D0,  0.04524D0,
56059      &     0.03586D0,  0.02831D0,  0.02220D0,  0.01723D0,  0.01322D0,
56060      &     0.01007D0,  0.00756D0,  0.00563D0,  0.00415D0,  0.00301D0,
56061      &     0.00213D0,  0.00152D0,  0.00108D0,  0.00071D0,  0.00046D0,
56062      &     0.00032D0,  0.00019D0,  0.00013D0,  0.00004D0,  0.00001D0,
56063      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56064       DATA (FMRS(2,6,I,21),I=1,49)/
56065      &     5.10866D0,  3.99099D0,  3.11497D0,  2.69310D0,  2.42814D0,
56066      &     2.24021D0,  1.74141D0,  1.34843D0,  1.15753D0,  1.03651D0,
56067      &     0.94850D0,  0.71355D0,  0.52465D0,  0.43244D0,  0.37419D0,
56068      &     0.33296D0,  0.27700D0,  0.22539D0,  0.17578D0,  0.14590D0,
56069      &     0.10992D0,  0.08772D0,  0.07175D0,  0.05660D0,  0.04490D0,
56070      &     0.03547D0,  0.02791D0,  0.02182D0,  0.01688D0,  0.01291D0,
56071      &     0.00980D0,  0.00735D0,  0.00546D0,  0.00401D0,  0.00289D0,
56072      &     0.00204D0,  0.00145D0,  0.00103D0,  0.00067D0,  0.00045D0,
56073      &     0.00030D0,  0.00018D0,  0.00012D0,  0.00004D0,  0.00001D0,
56074      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56075       DATA (FMRS(2,6,I,22),I=1,49)/
56076      &     5.81063D0,  4.50144D0,  3.48388D0,  2.99716D0,  2.69275D0,
56077      &     2.47752D0,  1.90937D0,  1.46556D0,  1.25149D0,  1.11639D0,
56078      &     1.01845D0,  0.75875D0,  0.55228D0,  0.45248D0,  0.38985D0,
56079      &     0.34573D0,  0.28616D0,  0.23159D0,  0.17950D0,  0.14831D0,
56080      &     0.11099D0,  0.08809D0,  0.07172D0,  0.05628D0,  0.04443D0,
56081      &     0.03495D0,  0.02738D0,  0.02132D0,  0.01642D0,  0.01252D0,
56082      &     0.00947D0,  0.00708D0,  0.00524D0,  0.00384D0,  0.00275D0,
56083      &     0.00194D0,  0.00137D0,  0.00097D0,  0.00062D0,  0.00042D0,
56084      &     0.00028D0,  0.00017D0,  0.00011D0,  0.00004D0,  0.00001D0,
56085      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56086       DATA (FMRS(2,6,I,23),I=1,49)/
56087      &     6.53035D0,  5.02028D0,  3.85558D0,  3.30194D0,  2.95702D0,
56088      &     2.71384D0,  2.07512D0,  1.58008D0,  1.34283D0,  1.19373D0,
56089      &     1.08596D0,  0.80189D0,  0.57834D0,  0.47125D0,  0.40444D0,
56090      &     0.35757D0,  0.29461D0,  0.23726D0,  0.18285D0,  0.15046D0,
56091      &     0.11188D0,  0.08836D0,  0.07162D0,  0.05593D0,  0.04396D0,
56092      &     0.03443D0,  0.02686D0,  0.02084D0,  0.01599D0,  0.01216D0,
56093      &     0.00917D0,  0.00683D0,  0.00504D0,  0.00368D0,  0.00262D0,
56094      &     0.00186D0,  0.00129D0,  0.00092D0,  0.00058D0,  0.00038D0,
56095      &     0.00026D0,  0.00015D0,  0.00010D0,  0.00004D0,  0.00001D0,
56096      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56097       DATA (FMRS(2,6,I,24),I=1,49)/
56098      &     7.24769D0,  5.53321D0,  4.22004D0,  3.59932D0,  3.21397D0,
56099      &     2.94299D0,  2.23445D0,  1.68918D0,  1.42937D0,  1.26671D0,
56100      &     1.14944D0,  0.84202D0,  0.60229D0,  0.48837D0,  0.41766D0,
56101      &     0.36826D0,  0.30216D0,  0.24227D0,  0.18575D0,  0.15227D0,
56102      &     0.11258D0,  0.08849D0,  0.07143D0,  0.05553D0,  0.04345D0,
56103      &     0.03390D0,  0.02636D0,  0.02037D0,  0.01559D0,  0.01181D0,
56104      &     0.00887D0,  0.00659D0,  0.00484D0,  0.00353D0,  0.00252D0,
56105      &     0.00176D0,  0.00124D0,  0.00088D0,  0.00055D0,  0.00037D0,
56106      &     0.00025D0,  0.00014D0,  0.00009D0,  0.00003D0,  0.00001D0,
56107      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56108       DATA (FMRS(2,6,I,25),I=1,49)/
56109      &     8.02203D0,  6.08288D0,  4.60775D0,  3.91431D0,  3.48531D0,
56110      &     3.18439D0,  2.40103D0,  1.80237D0,  1.51875D0,  1.34182D0,
56111      &     1.21461D0,  0.88286D0,  0.62643D0,  0.50552D0,  0.43085D0,
56112      &     0.37888D0,  0.30963D0,  0.24719D0,  0.18858D0,  0.15401D0,
56113      &     0.11322D0,  0.08857D0,  0.07120D0,  0.05510D0,  0.04294D0,
56114      &     0.03336D0,  0.02585D0,  0.01990D0,  0.01519D0,  0.01146D0,
56115      &     0.00858D0,  0.00636D0,  0.00466D0,  0.00338D0,  0.00242D0,
56116      &     0.00168D0,  0.00119D0,  0.00083D0,  0.00052D0,  0.00035D0,
56117      &     0.00023D0,  0.00013D0,  0.00009D0,  0.00003D0,  0.00001D0,
56118      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56119       DATA (FMRS(2,6,I,26),I=1,49)/
56120      &     8.82307D0,  6.64735D0,  5.00295D0,  4.23399D0,  3.75981D0,
56121      &     3.42801D0,  2.56785D0,  1.91480D0,  1.60708D0,  1.41578D0,
56122      &     1.27859D0,  0.92256D0,  0.64966D0,  0.52190D0,  0.44338D0,
56123      &     0.38892D0,  0.31662D0,  0.25175D0,  0.19114D0,  0.15555D0,
56124      &     0.11371D0,  0.08855D0,  0.07090D0,  0.05462D0,  0.04239D0,
56125      &     0.03281D0,  0.02532D0,  0.01944D0,  0.01478D0,  0.01112D0,
56126      &     0.00830D0,  0.00614D0,  0.00448D0,  0.00324D0,  0.00231D0,
56127      &     0.00160D0,  0.00113D0,  0.00079D0,  0.00049D0,  0.00033D0,
56128      &     0.00022D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00001D0,
56129      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56130       DATA (FMRS(2,6,I,27),I=1,49)/
56131      &     9.62987D0,  7.21210D0,  5.39571D0,  4.55043D0,  4.03076D0,
56132      &     3.66794D0,  2.73100D0,  2.02398D0,  1.69250D0,  1.48708D0,
56133      &     1.34010D0,  0.96040D0,  0.67159D0,  0.53727D0,  0.45509D0,
56134      &     0.39827D0,  0.32310D0,  0.25593D0,  0.19347D0,  0.15692D0,
56135      &     0.11411D0,  0.08848D0,  0.07058D0,  0.05414D0,  0.04185D0,
56136      &     0.03228D0,  0.02482D0,  0.01900D0,  0.01440D0,  0.01080D0,
56137      &     0.00804D0,  0.00593D0,  0.00431D0,  0.00312D0,  0.00222D0,
56138      &     0.00152D0,  0.00108D0,  0.00075D0,  0.00046D0,  0.00031D0,
56139      &     0.00020D0,  0.00012D0,  0.00008D0,  0.00003D0,  0.00001D0,
56140      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56141       DATA (FMRS(2,6,I,28),I=1,49)/
56142      &    10.42894D0,  7.76794D0,  5.77982D0,  4.85875D0,  4.29406D0,
56143      &     3.90061D0,  2.88817D0,  2.12844D0,  1.77387D0,  1.55479D0,
56144      &     1.39837D0,  0.99596D0,  0.69200D0,  0.55150D0,  0.46587D0,
56145      &     0.40684D0,  0.32899D0,  0.25970D0,  0.19552D0,  0.15809D0,
56146      &     0.11441D0,  0.08837D0,  0.07023D0,  0.05366D0,  0.04133D0,
56147      &     0.03176D0,  0.02435D0,  0.01859D0,  0.01405D0,  0.01051D0,
56148      &     0.00780D0,  0.00573D0,  0.00416D0,  0.00301D0,  0.00213D0,
56149      &     0.00146D0,  0.00103D0,  0.00071D0,  0.00045D0,  0.00029D0,
56150      &     0.00020D0,  0.00011D0,  0.00008D0,  0.00003D0,  0.00001D0,
56151      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56152       DATA (FMRS(2,6,I,29),I=1,49)/
56153      &    11.27410D0,  8.35239D0,  6.18132D0,  5.17989D0,  4.56762D0,
56154      &     4.14187D0,  3.05014D0,  2.23540D0,  1.85687D0,  1.62366D0,
56155      &     1.45750D0,  1.03178D0,  0.71238D0,  0.56563D0,  0.47653D0,
56156      &     0.41529D0,  0.33476D0,  0.26336D0,  0.19748D0,  0.15919D0,
56157      &     0.11465D0,  0.08820D0,  0.06985D0,  0.05316D0,  0.04080D0,
56158      &     0.03125D0,  0.02388D0,  0.01817D0,  0.01370D0,  0.01022D0,
56159      &     0.00757D0,  0.00554D0,  0.00401D0,  0.00290D0,  0.00205D0,
56160      &     0.00140D0,  0.00098D0,  0.00068D0,  0.00043D0,  0.00028D0,
56161      &     0.00019D0,  0.00011D0,  0.00007D0,  0.00002D0,  0.00001D0,
56162      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56163       DATA (FMRS(2,6,I,30),I=1,49)/
56164      &    12.14199D0,  8.94909D0,  6.58882D0,  5.50470D0,  4.84361D0,
56165      &     4.38480D0,  3.21222D0,  2.34175D0,  1.93908D0,  1.69167D0,
56166      &     1.51576D0,  1.06678D0,  0.73213D0,  0.57923D0,  0.48674D0,
56167      &     0.42334D0,  0.34023D0,  0.26678D0,  0.19927D0,  0.16016D0,
56168      &     0.11481D0,  0.08798D0,  0.06944D0,  0.05264D0,  0.04025D0,
56169      &     0.03073D0,  0.02343D0,  0.01777D0,  0.01335D0,  0.00994D0,
56170      &     0.00734D0,  0.00536D0,  0.00388D0,  0.00278D0,  0.00196D0,
56171      &     0.00135D0,  0.00094D0,  0.00065D0,  0.00041D0,  0.00027D0,
56172      &     0.00017D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
56173      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56174       DATA (FMRS(2,6,I,31),I=1,49)/
56175      &    13.00875D0,  9.54182D0,  6.99142D0,  5.82458D0,  5.11479D0,
56176      &     4.62308D0,  3.37031D0,  2.44489D0,  2.01852D0,  1.75723D0,
56177      &     1.57179D0,  1.10022D0,  0.75086D0,  0.59207D0,  0.49634D0,
56178      &     0.43089D0,  0.34532D0,  0.26994D0,  0.20090D0,  0.16103D0,
56179      &     0.11492D0,  0.08774D0,  0.06903D0,  0.05213D0,  0.03973D0,
56180      &     0.03024D0,  0.02300D0,  0.01739D0,  0.01303D0,  0.00968D0,
56181      &     0.00712D0,  0.00520D0,  0.00375D0,  0.00268D0,  0.00188D0,
56182      &     0.00130D0,  0.00090D0,  0.00063D0,  0.00039D0,  0.00025D0,
56183      &     0.00016D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
56184      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56185       DATA (FMRS(2,6,I,32),I=1,49)/
56186      &    13.85388D0, 10.11672D0,  7.37984D0,  6.13221D0,  5.37500D0,
56187      &     4.85130D0,  3.52087D0,  2.54252D0,  2.09344D0,  1.81889D0,
56188      &     1.62437D0,  1.13136D0,  0.76814D0,  0.60383D0,  0.50509D0,
56189      &     0.43774D0,  0.34990D0,  0.27275D0,  0.20231D0,  0.16173D0,
56190      &     0.11495D0,  0.08745D0,  0.06859D0,  0.05162D0,  0.03921D0,
56191      &     0.02977D0,  0.02256D0,  0.01702D0,  0.01273D0,  0.00943D0,
56192      &     0.00693D0,  0.00505D0,  0.00364D0,  0.00260D0,  0.00181D0,
56193      &     0.00125D0,  0.00086D0,  0.00060D0,  0.00037D0,  0.00024D0,
56194      &     0.00016D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
56195      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56196       DATA (FMRS(2,6,I,33),I=1,49)/
56197      &    14.75398D0, 10.72621D0,  7.78974D0,  6.45599D0,  5.64833D0,
56198      &     5.09068D0,  3.67806D0,  2.64398D0,  2.17108D0,  1.88265D0,
56199      &     1.67867D0,  1.16335D0,  0.78579D0,  0.61581D0,  0.51399D0,
56200      &     0.44470D0,  0.35453D0,  0.27558D0,  0.20373D0,  0.16245D0,
56201      &     0.11497D0,  0.08717D0,  0.06816D0,  0.05112D0,  0.03871D0,
56202      &     0.02930D0,  0.02213D0,  0.01666D0,  0.01243D0,  0.00919D0,
56203      &     0.00674D0,  0.00490D0,  0.00353D0,  0.00251D0,  0.00175D0,
56204      &     0.00120D0,  0.00083D0,  0.00058D0,  0.00036D0,  0.00023D0,
56205      &     0.00015D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
56206      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56207       DATA (FMRS(2,6,I,34),I=1,49)/
56208      &    15.65461D0, 11.33290D0,  8.19558D0,  6.77553D0,  5.91747D0,
56209      &     5.32596D0,  3.83165D0,  2.74249D0,  2.24617D0,  1.94414D0,
56210      &     1.73088D0,  1.19385D0,  0.80244D0,  0.62703D0,  0.52226D0,
56211      &     0.45111D0,  0.35875D0,  0.27811D0,  0.20493D0,  0.16299D0,
56212      &     0.11490D0,  0.08681D0,  0.06768D0,  0.05059D0,  0.03819D0,
56213      &     0.02883D0,  0.02172D0,  0.01631D0,  0.01213D0,  0.00895D0,
56214      &     0.00656D0,  0.00475D0,  0.00341D0,  0.00243D0,  0.00169D0,
56215      &     0.00116D0,  0.00080D0,  0.00055D0,  0.00034D0,  0.00022D0,
56216      &     0.00015D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
56217      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56218       DATA (FMRS(2,6,I,35),I=1,49)/
56219      &    16.55734D0, 11.93842D0,  8.59892D0,  7.09231D0,  6.18381D0,
56220      &     5.55847D0,  3.98278D0,  2.83900D0,  2.31954D0,  2.00411D0,
56221      &     1.78173D0,  1.22341D0,  0.81850D0,  0.63782D0,  0.53020D0,
56222      &     0.45726D0,  0.36278D0,  0.28052D0,  0.20606D0,  0.16351D0,
56223      &     0.11482D0,  0.08647D0,  0.06722D0,  0.05009D0,  0.03770D0,
56224      &     0.02838D0,  0.02133D0,  0.01598D0,  0.01187D0,  0.00873D0,
56225      &     0.00639D0,  0.00462D0,  0.00330D0,  0.00235D0,  0.00163D0,
56226      &     0.00111D0,  0.00077D0,  0.00053D0,  0.00033D0,  0.00021D0,
56227      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
56228      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56229       DATA (FMRS(2,6,I,36),I=1,49)/
56230      &    17.43806D0, 12.52661D0,  8.98898D0,  7.39784D0,  6.44021D0,
56231      &     5.78196D0,  4.12737D0,  2.93087D0,  2.38917D0,  2.06088D0,
56232      &     1.82979D0,  1.25117D0,  0.83346D0,  0.64781D0,  0.53752D0,
56233      &     0.46291D0,  0.36645D0,  0.28268D0,  0.20706D0,  0.16393D0,
56234      &     0.11470D0,  0.08612D0,  0.06676D0,  0.04960D0,  0.03723D0,
56235      &     0.02796D0,  0.02096D0,  0.01566D0,  0.01161D0,  0.00852D0,
56236      &     0.00623D0,  0.00449D0,  0.00321D0,  0.00227D0,  0.00158D0,
56237      &     0.00107D0,  0.00074D0,  0.00051D0,  0.00031D0,  0.00020D0,
56238      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
56239      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56240       DATA (FMRS(2,6,I,37),I=1,49)/
56241      &    18.35067D0, 13.13351D0,  9.38971D0,  7.71095D0,  6.70247D0,
56242      &     6.01024D0,  4.27436D0,  3.02381D0,  2.45940D0,  2.11802D0,
56243      &     1.87806D0,  1.27887D0,  0.84828D0,  0.65765D0,  0.54469D0,
56244      &     0.46841D0,  0.37001D0,  0.28475D0,  0.20797D0,  0.16429D0,
56245      &     0.11453D0,  0.08573D0,  0.06628D0,  0.04909D0,  0.03675D0,
56246      &     0.02752D0,  0.02059D0,  0.01535D0,  0.01135D0,  0.00831D0,
56247      &     0.00606D0,  0.00437D0,  0.00311D0,  0.00220D0,  0.00153D0,
56248      &     0.00103D0,  0.00072D0,  0.00049D0,  0.00030D0,  0.00019D0,
56249      &     0.00013D0,  0.00007D0,  0.00005D0,  0.00001D0,  0.00000D0,
56250      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56251       DATA (FMRS(2,6,I,38),I=1,49)/
56252      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56253      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56254      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56255      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56256      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56257      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56258      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56259      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56260      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56261      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56262       DATA (FMRS(2,7,I, 1),I=1,49)/
56263      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56264      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56265      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56266      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56267      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56268      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56269      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56270      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56271      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56272      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56273       DATA (FMRS(2,7,I, 2),I=1,49)/
56274      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56275      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56276      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56277      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56278      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56279      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56280      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56281      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56282      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56283      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56284       DATA (FMRS(2,7,I, 3),I=1,49)/
56285      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56286      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56287      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56288      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56289      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56290      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56291      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56292      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56293      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56294      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56295       DATA (FMRS(2,7,I, 4),I=1,49)/
56296      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56297      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56298      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56299      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56300      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56301      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56302      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56303      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56304      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56305      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56306       DATA (FMRS(2,7,I, 5),I=1,49)/
56307      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56308      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56309      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56310      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56311      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56312      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56313      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56314      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56315      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56316      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56317       DATA (FMRS(2,7,I, 6),I=1,49)/
56318      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56319      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56320      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56321      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56322      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56323      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56324      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56325      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56326      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56327      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56328       DATA (FMRS(2,7,I, 7),I=1,49)/
56329      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56330      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56331      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56332      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56333      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56334      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56335      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56336      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56337      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56338      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56339       DATA (FMRS(2,7,I, 8),I=1,49)/
56340      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56341      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56342      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56343      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56344      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56345      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56346      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56347      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56348      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56349      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56350       DATA (FMRS(2,7,I, 9),I=1,49)/
56351      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56352      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56353      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56354      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56355      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56356      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56357      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56358      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56359      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56360      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56361       DATA (FMRS(2,7,I,10),I=1,49)/
56362      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56363      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56364      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56365      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56366      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56367      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56368      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56369      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56370      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56371      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56372       DATA (FMRS(2,7,I,11),I=1,49)/
56373      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56374      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56375      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56376      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56377      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56378      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56379      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56380      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56381      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56382      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56383       DATA (FMRS(2,7,I,12),I=1,49)/
56384      &     0.00041D0,  0.00036D0,  0.00032D0,  0.00030D0,  0.00028D0,
56385      &     0.00027D0,  0.00023D0,  0.00021D0,  0.00019D0,  0.00018D0,
56386      &     0.00017D0,  0.00014D0,  0.00012D0,  0.00011D0,  0.00010D0,
56387      &     0.00009D0,  0.00008D0,  0.00007D0,  0.00006D0,  0.00005D0,
56388      &     0.00004D0,  0.00004D0,  0.00003D0,  0.00003D0,  0.00003D0,
56389      &     0.00003D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
56390      &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
56391      &     0.00001D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
56392      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56393      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56394       DATA (FMRS(2,7,I,13),I=1,49)/
56395      &     0.21131D0,  0.16558D0,  0.12967D0,  0.11232D0,  0.10141D0,
56396      &     0.09365D0,  0.07296D0,  0.05647D0,  0.04835D0,  0.04314D0,
56397      &     0.03929D0,  0.02893D0,  0.02049D0,  0.01636D0,  0.01376D0,
56398      &     0.01193D0,  0.00947D0,  0.00725D0,  0.00522D0,  0.00409D0,
56399      &     0.00289D0,  0.00226D0,  0.00187D0,  0.00153D0,  0.00127D0,
56400      &     0.00106D0,  0.00087D0,  0.00071D0,  0.00058D0,  0.00046D0,
56401      &     0.00037D0,  0.00028D0,  0.00022D0,  0.00016D0,  0.00012D0,
56402      &     0.00009D0,  0.00007D0,  0.00005D0,  0.00003D0,  0.00002D0,
56403      &     0.00001D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
56404      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56405       DATA (FMRS(2,7,I,14),I=1,49)/
56406      &     0.61374D0,  0.47881D0,  0.37330D0,  0.32254D0,  0.29066D0,
56407      &     0.26804D0,  0.20788D0,  0.16016D0,  0.13675D0,  0.12177D0,
56408      &     0.11072D0,  0.08109D0,  0.05711D0,  0.04545D0,  0.03813D0,
56409      &     0.03299D0,  0.02611D0,  0.01996D0,  0.01434D0,  0.01121D0,
56410      &     0.00789D0,  0.00617D0,  0.00509D0,  0.00414D0,  0.00341D0,
56411      &     0.00282D0,  0.00231D0,  0.00188D0,  0.00151D0,  0.00120D0,
56412      &     0.00094D0,  0.00073D0,  0.00056D0,  0.00042D0,  0.00031D0,
56413      &     0.00023D0,  0.00016D0,  0.00012D0,  0.00008D0,  0.00005D0,
56414      &     0.00003D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56415      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56416       DATA (FMRS(2,7,I,15),I=1,49)/
56417      &     0.99259D0,  0.76862D0,  0.59480D0,  0.51168D0,  0.45967D0,
56418      &     0.42287D0,  0.32549D0,  0.24886D0,  0.21152D0,  0.18775D0,
56419      &     0.17025D0,  0.12366D0,  0.08636D0,  0.06840D0,  0.05719D0,
56420      &     0.04937D0,  0.03895D0,  0.02967D0,  0.02125D0,  0.01657D0,
56421      &     0.01162D0,  0.00903D0,  0.00740D0,  0.00597D0,  0.00488D0,
56422      &     0.00399D0,  0.00325D0,  0.00263D0,  0.00210D0,  0.00166D0,
56423      &     0.00130D0,  0.00100D0,  0.00076D0,  0.00057D0,  0.00042D0,
56424      &     0.00031D0,  0.00022D0,  0.00015D0,  0.00011D0,  0.00007D0,
56425      &     0.00004D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56426      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56427       DATA (FMRS(2,7,I,16),I=1,49)/
56428      &     1.40334D0,  1.07950D0,  0.82983D0,  0.71109D0,  0.63704D0,
56429      &     0.58478D0,  0.44710D0,  0.33953D0,  0.28741D0,  0.25436D0,
56430      &     0.23011D0,  0.16589D0,  0.11498D0,  0.09067D0,  0.07559D0,
56431      &     0.06510D0,  0.05120D0,  0.03889D0,  0.02777D0,  0.02161D0,
56432      &     0.01509D0,  0.01166D0,  0.00950D0,  0.00760D0,  0.00617D0,
56433      &     0.00501D0,  0.00405D0,  0.00325D0,  0.00258D0,  0.00203D0,
56434      &     0.00158D0,  0.00121D0,  0.00091D0,  0.00068D0,  0.00050D0,
56435      &     0.00037D0,  0.00026D0,  0.00018D0,  0.00012D0,  0.00008D0,
56436      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56437      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56438       DATA (FMRS(2,7,I,17),I=1,49)/
56439      &     1.88020D0,  1.43681D0,  1.09723D0,  0.93659D0,  0.83676D0,
56440      &     0.76647D0,  0.58212D0,  0.43908D0,  0.37019D0,  0.32667D0,
56441      &     0.29484D0,  0.21099D0,  0.14515D0,  0.11396D0,  0.09473D0,
56442      &     0.08141D0,  0.06382D0,  0.04833D0,  0.03440D0,  0.02672D0,
56443      &     0.01856D0,  0.01428D0,  0.01156D0,  0.00918D0,  0.00739D0,
56444      &     0.00596D0,  0.00478D0,  0.00381D0,  0.00301D0,  0.00236D0,
56445      &     0.00181D0,  0.00138D0,  0.00104D0,  0.00077D0,  0.00057D0,
56446      &     0.00041D0,  0.00030D0,  0.00020D0,  0.00014D0,  0.00009D0,
56447      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56448      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56449       DATA (FMRS(2,7,I,18),I=1,49)/
56450      &     2.30534D0,  1.75221D0,  1.33088D0,  1.13244D0,  1.00946D0,
56451      &     0.92305D0,  0.69723D0,  0.52301D0,  0.43952D0,  0.38693D0,
56452      &     0.34856D0,  0.24795D0,  0.16954D0,  0.13265D0,  0.11000D0,
56453      &     0.09436D0,  0.07379D0,  0.05574D0,  0.03958D0,  0.03067D0,
56454      &     0.02123D0,  0.01626D0,  0.01309D0,  0.01033D0,  0.00826D0,
56455      &     0.00663D0,  0.00529D0,  0.00419D0,  0.00329D0,  0.00257D0,
56456      &     0.00197D0,  0.00150D0,  0.00112D0,  0.00083D0,  0.00061D0,
56457      &     0.00044D0,  0.00032D0,  0.00022D0,  0.00015D0,  0.00009D0,
56458      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56459      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56460       DATA (FMRS(2,7,I,19),I=1,49)/
56461      &     2.86856D0,  2.16633D0,  1.63487D0,  1.38587D0,  1.23207D0,
56462      &     1.12426D0,  0.84372D0,  0.62876D0,  0.52633D0,  0.46206D0,
56463      &     0.41530D0,  0.29334D0,  0.19914D0,  0.15517D0,  0.12832D0,
56464      &     0.10984D0,  0.08563D0,  0.06450D0,  0.04565D0,  0.03529D0,
56465      &     0.02431D0,  0.01851D0,  0.01482D0,  0.01161D0,  0.00922D0,
56466      &     0.00734D0,  0.00582D0,  0.00458D0,  0.00358D0,  0.00278D0,
56467      &     0.00212D0,  0.00160D0,  0.00119D0,  0.00088D0,  0.00064D0,
56468      &     0.00047D0,  0.00033D0,  0.00023D0,  0.00015D0,  0.00009D0,
56469      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56470      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56471       DATA (FMRS(2,7,I,20),I=1,49)/
56472      &     3.42748D0,  2.57399D0,  1.93167D0,  1.63211D0,  1.44759D0,
56473      &     1.31854D0,  0.98395D0,  0.72909D0,  0.60825D0,  0.53267D0,
56474      &     0.47783D0,  0.33544D0,  0.22632D0,  0.17572D0,  0.14495D0,
56475      &     0.12384D0,  0.09630D0,  0.07234D0,  0.05105D0,  0.03938D0,
56476      &     0.02701D0,  0.02047D0,  0.01631D0,  0.01268D0,  0.01001D0,
56477      &     0.00793D0,  0.00625D0,  0.00489D0,  0.00380D0,  0.00294D0,
56478      &     0.00223D0,  0.00168D0,  0.00125D0,  0.00091D0,  0.00066D0,
56479      &     0.00048D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
56480      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56481      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56482       DATA (FMRS(2,7,I,21),I=1,49)/
56483      &     3.95907D0,  2.95830D0,  2.20894D0,  1.86088D0,  1.64705D0,
56484      &     1.49778D0,  1.11204D0,  0.81980D0,  0.68185D0,  0.59583D0,
56485      &     0.53354D0,  0.37251D0,  0.24993D0,  0.19343D0,  0.15921D0,
56486      &     0.13581D0,  0.10535D0,  0.07895D0,  0.05557D0,  0.04278D0,
56487      &     0.02922D0,  0.02205D0,  0.01748D0,  0.01352D0,  0.01061D0,
56488      &     0.00835D0,  0.00655D0,  0.00511D0,  0.00395D0,  0.00304D0,
56489      &     0.00230D0,  0.00172D0,  0.00128D0,  0.00093D0,  0.00067D0,
56490      &     0.00049D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
56491      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56492      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56493       DATA (FMRS(2,7,I,22),I=1,49)/
56494      &     4.70301D0,  3.49223D0,  2.59131D0,  2.17500D0,  1.92006D0,
56495      &     1.74251D0,  1.28559D0,  0.94171D0,  0.78029D0,  0.68000D0,
56496      &     0.60759D0,  0.42132D0,  0.28074D0,  0.21641D0,  0.17764D0,
56497      &     0.15121D0,  0.11695D0,  0.08738D0,  0.06130D0,  0.04706D0,
56498      &     0.03198D0,  0.02400D0,  0.01891D0,  0.01452D0,  0.01131D0,
56499      &     0.00885D0,  0.00690D0,  0.00535D0,  0.00412D0,  0.00314D0,
56500      &     0.00237D0,  0.00177D0,  0.00130D0,  0.00095D0,  0.00068D0,
56501      &     0.00049D0,  0.00036D0,  0.00024D0,  0.00016D0,  0.00009D0,
56502      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56503      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56504       DATA (FMRS(2,7,I,23),I=1,49)/
56505      &     5.46775D0,  4.03669D0,  2.97803D0,  2.49113D0,  2.19384D0,
56506      &     1.98726D0,  1.45764D0,  1.06148D0,  0.87647D0,  0.76190D0,
56507      &     0.67941D0,  0.46817D0,  0.30998D0,  0.23809D0,  0.19493D0,
56508      &     0.16562D0,  0.12774D0,  0.09517D0,  0.06655D0,  0.05097D0,
56509      &     0.03446D0,  0.02573D0,  0.02017D0,  0.01538D0,  0.01190D0,
56510      &     0.00925D0,  0.00718D0,  0.00553D0,  0.00424D0,  0.00322D0,
56511      &     0.00242D0,  0.00179D0,  0.00132D0,  0.00095D0,  0.00069D0,
56512      &     0.00049D0,  0.00036D0,  0.00024D0,  0.00016D0,  0.00009D0,
56513      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56514      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56515       DATA (FMRS(2,7,I,24),I=1,49)/
56516      &     6.21519D0,  4.56429D0,  3.34948D0,  2.79317D0,  2.45443D0,
56517      &     2.21950D0,  1.61934D0,  1.17290D0,  0.96539D0,  0.83728D0,
56518      &     0.74526D0,  0.51062D0,  0.33614D0,  0.25732D0,  0.21020D0,
56519      &     0.17828D0,  0.13715D0,  0.10192D0,  0.07106D0,  0.05428D0,
56520      &     0.03653D0,  0.02714D0,  0.02117D0,  0.01604D0,  0.01234D0,
56521      &     0.00954D0,  0.00736D0,  0.00565D0,  0.00431D0,  0.00326D0,
56522      &     0.00243D0,  0.00180D0,  0.00132D0,  0.00095D0,  0.00068D0,
56523      &     0.00049D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
56524      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56525      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56526       DATA (FMRS(2,7,I,25),I=1,49)/
56527      &     7.03262D0,  5.13776D0,  3.75072D0,  3.11823D0,  2.73413D0,
56528      &     2.46827D0,  1.79141D0,  1.29068D0,  1.05901D0,  0.91641D0,
56529      &     0.81423D0,  0.55475D0,  0.36312D0,  0.27706D0,  0.22581D0,
56530      &     0.19119D0,  0.14672D0,  0.10875D0,  0.07559D0,  0.05760D0,
56531      &     0.03859D0,  0.02852D0,  0.02214D0,  0.01668D0,  0.01276D0,
56532      &     0.00981D0,  0.00753D0,  0.00575D0,  0.00436D0,  0.00329D0,
56533      &     0.00245D0,  0.00180D0,  0.00132D0,  0.00095D0,  0.00068D0,
56534      &     0.00048D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
56535      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56536      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56537       DATA (FMRS(2,7,I,26),I=1,49)/
56538      &     7.86804D0,  5.71947D0,  4.15459D0,  3.44391D0,  3.01342D0,
56539      &     2.71602D0,  1.96133D0,  1.40596D0,  1.15014D0,  0.99314D0,
56540      &     0.88088D0,  0.59694D0,  0.38863D0,  0.29560D0,  0.24039D0,
56541      &     0.20320D0,  0.15555D0,  0.11500D0,  0.07970D0,  0.06059D0,
56542      &     0.04040D0,  0.02973D0,  0.02296D0,  0.01720D0,  0.01308D0,
56543      &     0.01001D0,  0.00765D0,  0.00581D0,  0.00439D0,  0.00330D0,
56544      &     0.00245D0,  0.00180D0,  0.00131D0,  0.00094D0,  0.00067D0,
56545      &     0.00048D0,  0.00034D0,  0.00024D0,  0.00016D0,  0.00009D0,
56546      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56547      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56548       DATA (FMRS(2,7,I,27),I=1,49)/
56549      &     8.71308D0,  6.30440D0,  4.55822D0,  3.76823D0,  3.29083D0,
56550      &     2.96160D0,  2.12868D0,  1.51874D0,  1.23894D0,  1.06767D0,
56551      &     0.94548D0,  0.63752D0,  0.41296D0,  0.31319D0,  0.25418D0,
56552      &     0.21452D0,  0.16385D0,  0.12085D0,  0.08351D0,  0.06334D0,
56553      &     0.04205D0,  0.03081D0,  0.02369D0,  0.01765D0,  0.01336D0,
56554      &     0.01017D0,  0.00773D0,  0.00586D0,  0.00441D0,  0.00330D0,
56555      &     0.00244D0,  0.00178D0,  0.00129D0,  0.00092D0,  0.00066D0,
56556      &     0.00047D0,  0.00034D0,  0.00024D0,  0.00016D0,  0.00009D0,
56557      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56558      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56559       DATA (FMRS(2,7,I,28),I=1,49)/
56560      &     9.54571D0,  6.87720D0,  4.95101D0,  4.08263D0,  3.55902D0,
56561      &     3.19851D0,  2.28903D0,  1.62602D0,  1.32303D0,  1.13803D0,
56562      &     1.00630D0,  0.67540D0,  0.43546D0,  0.32936D0,  0.26680D0,
56563      &     0.22485D0,  0.17138D0,  0.12612D0,  0.08693D0,  0.06579D0,
56564      &     0.04350D0,  0.03173D0,  0.02430D0,  0.01801D0,  0.01357D0,
56565      &     0.01029D0,  0.00779D0,  0.00587D0,  0.00441D0,  0.00329D0,
56566      &     0.00242D0,  0.00177D0,  0.00128D0,  0.00091D0,  0.00065D0,
56567      &     0.00046D0,  0.00033D0,  0.00024D0,  0.00016D0,  0.00009D0,
56568      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56569      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56570       DATA (FMRS(2,7,I,29),I=1,49)/
56571      &    10.42768D0,  7.48069D0,  5.36257D0,  4.41099D0,  3.83846D0,
56572      &     3.44489D0,  2.45481D0,  1.73627D0,  1.40913D0,  1.20986D0,
56573      &     1.06825D0,  0.71372D0,  0.45804D0,  0.34552D0,  0.27937D0,
56574      &     0.23511D0,  0.17881D0,  0.13130D0,  0.09026D0,  0.06816D0,
56575      &     0.04488D0,  0.03260D0,  0.02487D0,  0.01834D0,  0.01375D0,
56576      &     0.01038D0,  0.00783D0,  0.00588D0,  0.00440D0,  0.00327D0,
56577      &     0.00240D0,  0.00175D0,  0.00126D0,  0.00090D0,  0.00063D0,
56578      &     0.00045D0,  0.00033D0,  0.00024D0,  0.00016D0,  0.00009D0,
56579      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56580      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56581       DATA (FMRS(2,7,I,30),I=1,49)/
56582      &    11.32906D0,  8.09395D0,  5.77834D0,  4.74153D0,  4.11903D0,
56583      &     3.69178D0,  2.61985D0,  1.84528D0,  1.49390D0,  1.28038D0,
56584      &     1.12893D0,  0.75094D0,  0.47979D0,  0.36099D0,  0.29135D0,
56585      &     0.24485D0,  0.18584D0,  0.13617D0,  0.09335D0,  0.07035D0,
56586      &     0.04613D0,  0.03338D0,  0.02536D0,  0.01861D0,  0.01389D0,
56587      &     0.01045D0,  0.00785D0,  0.00587D0,  0.00438D0,  0.00324D0,
56588      &     0.00237D0,  0.00172D0,  0.00124D0,  0.00088D0,  0.00062D0,
56589      &     0.00044D0,  0.00032D0,  0.00024D0,  0.00016D0,  0.00009D0,
56590      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56591      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56592       DATA (FMRS(2,7,I,31),I=1,49)/
56593      &    12.23197D0,  8.70533D0,  6.19083D0,  5.06852D0,  4.39601D0,
56594      &     3.93512D0,  2.78170D0,  1.95161D0,  1.57633D0,  1.34878D0,
56595      &     1.18767D0,  0.78675D0,  0.50057D0,  0.37571D0,  0.30272D0,
56596      &     0.25408D0,  0.19247D0,  0.14074D0,  0.09625D0,  0.07237D0,
56597      &     0.04728D0,  0.03408D0,  0.02579D0,  0.01885D0,  0.01401D0,
56598      &     0.01049D0,  0.00785D0,  0.00586D0,  0.00435D0,  0.00321D0,
56599      &     0.00235D0,  0.00170D0,  0.00122D0,  0.00086D0,  0.00061D0,
56600      &     0.00043D0,  0.00031D0,  0.00023D0,  0.00016D0,  0.00009D0,
56601      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56602      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56603       DATA (FMRS(2,7,I,32),I=1,49)/
56604      &    13.10605D0,  9.29397D0,  6.58574D0,  5.38050D0,  4.65963D0,
56605      &     4.16627D0,  2.93446D0,  2.05131D0,  1.65329D0,  1.41245D0,
56606      &     1.24220D0,  0.81972D0,  0.51953D0,  0.38906D0,  0.31298D0,
56607      &     0.26237D0,  0.19840D0,  0.14478D0,  0.09878D0,  0.07413D0,
56608      &     0.04825D0,  0.03465D0,  0.02614D0,  0.01902D0,  0.01408D0,
56609      &     0.01051D0,  0.00784D0,  0.00583D0,  0.00432D0,  0.00318D0,
56610      &     0.00232D0,  0.00167D0,  0.00120D0,  0.00085D0,  0.00060D0,
56611      &     0.00042D0,  0.00031D0,  0.00023D0,  0.00016D0,  0.00009D0,
56612      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56613      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56614       DATA (FMRS(2,7,I,33),I=1,49)/
56615      &    14.04396D0,  9.92333D0,  7.00645D0,  5.71217D0,  4.93947D0,
56616      &     4.41134D0,  3.09586D0,  2.15625D0,  1.73413D0,  1.47923D0,
56617      &     1.29933D0,  0.85413D0,  0.53923D0,  0.40291D0,  0.32360D0,
56618      &     0.27095D0,  0.20451D0,  0.14895D0,  0.10139D0,  0.07594D0,
56619      &     0.04925D0,  0.03524D0,  0.02649D0,  0.01920D0,  0.01416D0,
56620      &     0.01053D0,  0.00783D0,  0.00580D0,  0.00428D0,  0.00315D0,
56621      &     0.00229D0,  0.00165D0,  0.00118D0,  0.00083D0,  0.00058D0,
56622      &     0.00041D0,  0.00030D0,  0.00022D0,  0.00016D0,  0.00009D0,
56623      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56624      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56625       DATA (FMRS(2,7,I,34),I=1,49)/
56626      &    14.97171D0, 10.54223D0,  7.41762D0,  6.03510D0,  5.21118D0,
56627      &     4.64879D0,  3.25111D0,  2.25643D0,  1.81093D0,  1.54244D0,
56628      &     1.35325D0,  0.88628D0,  0.55744D0,  0.41560D0,  0.33329D0,
56629      &     0.27873D0,  0.21001D0,  0.15267D0,  0.10367D0,  0.07749D0,
56630      &     0.05007D0,  0.03571D0,  0.02675D0,  0.01931D0,  0.01419D0,
56631      &     0.01051D0,  0.00779D0,  0.00576D0,  0.00424D0,  0.00311D0,
56632      &     0.00225D0,  0.00162D0,  0.00115D0,  0.00081D0,  0.00057D0,
56633      &     0.00041D0,  0.00030D0,  0.00022D0,  0.00016D0,  0.00009D0,
56634      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56635      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56636       DATA (FMRS(2,7,I,35),I=1,49)/
56637      &    15.90678D0, 11.16388D0,  7.82922D0,  6.35772D0,  5.48225D0,
56638      &     4.88541D0,  3.40531D0,  2.35558D0,  1.88678D0,  1.60477D0,
56639      &     1.40636D0,  0.91783D0,  0.57524D0,  0.42799D0,  0.34272D0,
56640      &     0.28629D0,  0.21535D0,  0.15626D0,  0.10587D0,  0.07899D0,
56641      &     0.05087D0,  0.03616D0,  0.02700D0,  0.01941D0,  0.01421D0,
56642      &     0.01050D0,  0.00776D0,  0.00572D0,  0.00420D0,  0.00307D0,
56643      &     0.00222D0,  0.00159D0,  0.00113D0,  0.00080D0,  0.00056D0,
56644      &     0.00040D0,  0.00029D0,  0.00022D0,  0.00016D0,  0.00009D0,
56645      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56646      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56647       DATA (FMRS(2,7,I,36),I=1,49)/
56648      &    16.81722D0, 11.76659D0,  8.22652D0,  6.66831D0,  5.74271D0,
56649      &     5.11243D0,  3.55252D0,  2.44976D0,  1.95860D0,  1.66366D0,
56650      &     1.45643D0,  0.94739D0,  0.59179D0,  0.43945D0,  0.35142D0,
56651      &     0.29325D0,  0.22023D0,  0.15953D0,  0.10786D0,  0.08033D0,
56652      &     0.05156D0,  0.03654D0,  0.02720D0,  0.01949D0,  0.01422D0,
56653      &     0.01047D0,  0.00772D0,  0.00567D0,  0.00416D0,  0.00303D0,
56654      &     0.00219D0,  0.00157D0,  0.00111D0,  0.00078D0,  0.00055D0,
56655      &     0.00039D0,  0.00029D0,  0.00022D0,  0.00016D0,  0.00009D0,
56656      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56657      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56658       DATA (FMRS(2,7,I,37),I=1,49)/
56659      &    17.75747D0, 12.38637D0,  8.63327D0,  6.98544D0,  6.00814D0,
56660      &     5.34342D0,  3.70158D0,  2.54461D0,  2.03070D0,  1.72263D0,
56661      &     1.50647D0,  0.97674D0,  0.60811D0,  0.45069D0,  0.35992D0,
56662      &     0.30003D0,  0.22496D0,  0.16268D0,  0.10975D0,  0.08160D0,
56663      &     0.05220D0,  0.03687D0,  0.02737D0,  0.01954D0,  0.01421D0,
56664      &     0.01044D0,  0.00767D0,  0.00562D0,  0.00411D0,  0.00299D0,
56665      &     0.00215D0,  0.00154D0,  0.00109D0,  0.00077D0,  0.00053D0,
56666      &     0.00038D0,  0.00028D0,  0.00021D0,  0.00016D0,  0.00009D0,
56667      &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
56668      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56669       DATA (FMRS(2,7,I,38),I=1,49)/
56670      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56671      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56672      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56673      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56674      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56675      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56676      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56677      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56678      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
56679      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56680       DATA (FMRS(2,8,I, 1),I=1,49)/
56681      &     0.98494D0,  0.83942D0,  0.71517D0,  0.65113D0,  0.60921D0,
56682      &     0.57857D0,  0.49313D0,  0.42114D0,  0.38478D0,  0.36147D0,
56683      &     0.34532D0,  0.30109D0,  0.26601D0,  0.24883D0,  0.23797D0,
56684      &     0.23013D0,  0.21908D0,  0.20797D0,  0.19531D0,  0.18554D0,
56685      &     0.16898D0,  0.15367D0,  0.13862D0,  0.11992D0,  0.10161D0,
56686      &     0.08421D0,  0.06813D0,  0.05380D0,  0.04148D0,  0.03102D0,
56687      &     0.02276D0,  0.01618D0,  0.01125D0,  0.00763D0,  0.00500D0,
56688      &     0.00317D0,  0.00203D0,  0.00121D0,  0.00069D0,  0.00043D0,
56689      &     0.00027D0,  0.00012D0,  0.00011D0,  0.00003D0,  0.00000D0,
56690      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56691       DATA (FMRS(2,8,I, 2),I=1,49)/
56692      &     0.98889D0,  0.84649D0,  0.72438D0,  0.66122D0,  0.61978D0,
56693      &     0.58944D0,  0.50458D0,  0.43271D0,  0.39626D0,  0.37282D0,
56694      &     0.35655D0,  0.31168D0,  0.27538D0,  0.25719D0,  0.24547D0,
56695      &     0.23690D0,  0.22464D0,  0.21217D0,  0.19794D0,  0.18712D0,
56696      &     0.16930D0,  0.15330D0,  0.13787D0,  0.11894D0,  0.10059D0,
56697      &     0.08325D0,  0.06732D0,  0.05317D0,  0.04104D0,  0.03076D0,
56698      &     0.02264D0,  0.01619D0,  0.01134D0,  0.00776D0,  0.00516D0,
56699      &     0.00334D0,  0.00218D0,  0.00135D0,  0.00080D0,  0.00052D0,
56700      &     0.00034D0,  0.00018D0,  0.00014D0,  0.00004D0,  0.00001D0,
56701      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56702       DATA (FMRS(2,8,I, 3),I=1,49)/
56703      &     1.01222D0,  0.87111D0,  0.74946D0,  0.68626D0,  0.64467D0,
56704      &     0.61416D0,  0.52846D0,  0.45538D0,  0.41806D0,  0.39393D0,
56705      &     0.37708D0,  0.33010D0,  0.29099D0,  0.27082D0,  0.25752D0,
56706      &     0.24766D0,  0.23338D0,  0.21871D0,  0.20204D0,  0.18963D0,
56707      &     0.16990D0,  0.15288D0,  0.13686D0,  0.11759D0,  0.09914D0,
56708      &     0.08186D0,  0.06611D0,  0.05221D0,  0.04030D0,  0.03030D0,
56709      &     0.02237D0,  0.01612D0,  0.01138D0,  0.00788D0,  0.00532D0,
56710      &     0.00353D0,  0.00233D0,  0.00151D0,  0.00092D0,  0.00061D0,
56711      &     0.00042D0,  0.00024D0,  0.00016D0,  0.00005D0,  0.00002D0,
56712      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56713       DATA (FMRS(2,8,I, 4),I=1,49)/
56714      &     1.04476D0,  0.90153D0,  0.77771D0,  0.71324D0,  0.67074D0,
56715      &     0.63953D0,  0.55166D0,  0.47640D0,  0.43777D0,  0.41269D0,
56716      &     0.39507D0,  0.34558D0,  0.30362D0,  0.28161D0,  0.26695D0,
56717      &     0.25601D0,  0.24007D0,  0.22367D0,  0.20514D0,  0.19155D0,
56718      &     0.17043D0,  0.15264D0,  0.13620D0,  0.11664D0,  0.09810D0,
56719      &     0.08084D0,  0.06518D0,  0.05144D0,  0.03971D0,  0.02989D0,
56720      &     0.02211D0,  0.01600D0,  0.01135D0,  0.00790D0,  0.00539D0,
56721      &     0.00362D0,  0.00238D0,  0.00157D0,  0.00098D0,  0.00066D0,
56722      &     0.00045D0,  0.00026D0,  0.00018D0,  0.00006D0,  0.00003D0,
56723      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56724       DATA (FMRS(2,8,I, 5),I=1,49)/
56725      &     1.10026D0,  0.95040D0,  0.82069D0,  0.75308D0,  0.70848D0,
56726      &     0.67571D0,  0.58330D0,  0.50390D0,  0.46299D0,  0.43632D0,
56727      &     0.41743D0,  0.36409D0,  0.31818D0,  0.29384D0,  0.27750D0,
56728      &     0.26527D0,  0.24742D0,  0.22908D0,  0.20853D0,  0.19368D0,
56729      &     0.17108D0,  0.15248D0,  0.13556D0,  0.11567D0,  0.09702D0,
56730      &     0.07977D0,  0.06421D0,  0.05061D0,  0.03905D0,  0.02941D0,
56731      &     0.02179D0,  0.01578D0,  0.01121D0,  0.00787D0,  0.00539D0,
56732      &     0.00363D0,  0.00243D0,  0.00163D0,  0.00101D0,  0.00068D0,
56733      &     0.00046D0,  0.00028D0,  0.00020D0,  0.00007D0,  0.00002D0,
56734      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56735       DATA (FMRS(2,8,I, 6),I=1,49)/
56736      &     1.15923D0,  1.00143D0,  0.86481D0,  0.79358D0,  0.74658D0,
56737      &     0.71202D0,  0.61454D0,  0.53061D0,  0.48723D0,  0.45888D0,
56738      &     0.43867D0,  0.38135D0,  0.33152D0,  0.30491D0,  0.28699D0,
56739      &     0.27355D0,  0.25394D0,  0.23384D0,  0.21150D0,  0.19554D0,
56740      &     0.17166D0,  0.15236D0,  0.13502D0,  0.11484D0,  0.09608D0,
56741      &     0.07883D0,  0.06335D0,  0.04988D0,  0.03847D0,  0.02897D0,
56742      &     0.02148D0,  0.01557D0,  0.01108D0,  0.00781D0,  0.00536D0,
56743      &     0.00363D0,  0.00245D0,  0.00167D0,  0.00103D0,  0.00070D0,
56744      &     0.00046D0,  0.00029D0,  0.00021D0,  0.00007D0,  0.00002D0,
56745      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56746       DATA (FMRS(2,8,I, 7),I=1,49)/
56747      &     1.23248D0,  1.06345D0,  0.91726D0,  0.84109D0,  0.79085D0,
56748      &     0.75393D0,  0.64976D0,  0.56002D0,  0.51357D0,  0.48314D0,
56749      &     0.46132D0,  0.39931D0,  0.34507D0,  0.31602D0,  0.29642D0,
56750      &     0.28173D0,  0.26034D0,  0.23848D0,  0.21438D0,  0.19736D0,
56751      &     0.17224D0,  0.15227D0,  0.13452D0,  0.11404D0,  0.09516D0,
56752      &     0.07789D0,  0.06251D0,  0.04914D0,  0.03786D0,  0.02851D0,
56753      &     0.02113D0,  0.01532D0,  0.01096D0,  0.00772D0,  0.00530D0,
56754      &     0.00360D0,  0.00243D0,  0.00166D0,  0.00104D0,  0.00071D0,
56755      &     0.00048D0,  0.00030D0,  0.00020D0,  0.00008D0,  0.00002D0,
56756      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56757       DATA (FMRS(2,8,I, 8),I=1,49)/
56758      &     1.32548D0,  1.14118D0,  0.98212D0,  0.89937D0,  0.84484D0,
56759      &     0.80478D0,  0.69187D0,  0.59465D0,  0.54428D0,  0.51124D0,
56760      &     0.48741D0,  0.41964D0,  0.36014D0,  0.32825D0,  0.30675D0,
56761      &     0.29065D0,  0.26725D0,  0.24348D0,  0.21747D0,  0.19931D0,
56762      &     0.17288D0,  0.15217D0,  0.13398D0,  0.11319D0,  0.09418D0,
56763      &     0.07689D0,  0.06158D0,  0.04833D0,  0.03719D0,  0.02798D0,
56764      &     0.02073D0,  0.01504D0,  0.01077D0,  0.00760D0,  0.00523D0,
56765      &     0.00355D0,  0.00240D0,  0.00165D0,  0.00105D0,  0.00070D0,
56766      &     0.00048D0,  0.00029D0,  0.00020D0,  0.00007D0,  0.00002D0,
56767      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56768       DATA (FMRS(2,8,I, 9),I=1,49)/
56769      &     1.41996D0,  1.21934D0,  1.04662D0,  0.95694D0,  0.89790D0,
56770      &     0.85457D0,  0.73259D0,  0.62769D0,  0.57336D0,  0.53768D0,
56771      &     0.51185D0,  0.43840D0,  0.37384D0,  0.33927D0,  0.31599D0,
56772      &     0.29859D0,  0.27338D0,  0.24788D0,  0.22018D0,  0.20102D0,
56773      &     0.17344D0,  0.15210D0,  0.13351D0,  0.11246D0,  0.09333D0,
56774      &     0.07602D0,  0.06075D0,  0.04762D0,  0.03659D0,  0.02749D0,
56775      &     0.02036D0,  0.01479D0,  0.01057D0,  0.00748D0,  0.00516D0,
56776      &     0.00349D0,  0.00238D0,  0.00163D0,  0.00104D0,  0.00069D0,
56777      &     0.00047D0,  0.00028D0,  0.00019D0,  0.00006D0,  0.00002D0,
56778      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56779       DATA (FMRS(2,8,I,10),I=1,49)/
56780      &     1.52623D0,  1.30628D0,  1.11753D0,  1.01977D0,  0.95552D0,
56781      &     0.90841D0,  0.77603D0,  0.66243D0,  0.60365D0,  0.56506D0,
56782      &     0.53703D0,  0.45743D0,  0.38751D0,  0.35017D0,  0.32507D0,
56783      &     0.30636D0,  0.27933D0,  0.25214D0,  0.22280D0,  0.20266D0,
56784      &     0.17397D0,  0.15202D0,  0.13306D0,  0.11174D0,  0.09248D0,
56785      &     0.07516D0,  0.05994D0,  0.04691D0,  0.03600D0,  0.02702D0,
56786      &     0.02000D0,  0.01454D0,  0.01039D0,  0.00736D0,  0.00507D0,
56787      &     0.00344D0,  0.00235D0,  0.00162D0,  0.00103D0,  0.00069D0,
56788      &     0.00047D0,  0.00027D0,  0.00019D0,  0.00006D0,  0.00002D0,
56789      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56790       DATA (FMRS(2,8,I,11),I=1,49)/
56791      &     1.61996D0,  1.38242D0,  1.17917D0,  1.07414D0,  1.00521D0,
56792      &     0.95472D0,  0.81307D0,  0.69180D0,  0.62911D0,  0.58797D0,
56793      &     0.55803D0,  0.47313D0,  0.39867D0,  0.35901D0,  0.33241D0,
56794      &     0.31262D0,  0.28411D0,  0.25553D0,  0.22487D0,  0.20396D0,
56795      &     0.17439D0,  0.15196D0,  0.13270D0,  0.11116D0,  0.09180D0,
56796      &     0.07446D0,  0.05929D0,  0.04635D0,  0.03552D0,  0.02665D0,
56797      &     0.01972D0,  0.01433D0,  0.01024D0,  0.00726D0,  0.00500D0,
56798      &     0.00340D0,  0.00233D0,  0.00161D0,  0.00102D0,  0.00069D0,
56799      &     0.00047D0,  0.00027D0,  0.00019D0,  0.00006D0,  0.00002D0,
56800      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56801       DATA (FMRS(2,8,I,12),I=1,49)/
56802      &     1.85147D0,  1.56851D0,  1.32816D0,  1.20469D0,  1.12394D0,
56803      &     1.06494D0,  0.90014D0,  0.75989D0,  0.68768D0,  0.64036D0,
56804      &     0.60582D0,  0.50832D0,  0.42330D0,  0.37835D0,  0.34837D0,
56805      &     0.32616D0,  0.29437D0,  0.26278D0,  0.22928D0,  0.20671D0,
56806      &     0.17525D0,  0.15178D0,  0.13188D0,  0.10989D0,  0.09032D0,
56807      &     0.07294D0,  0.05789D0,  0.04511D0,  0.03448D0,  0.02582D0,
56808      &     0.01907D0,  0.01385D0,  0.00987D0,  0.00700D0,  0.00482D0,
56809      &     0.00328D0,  0.00224D0,  0.00154D0,  0.00100D0,  0.00066D0,
56810      &     0.00045D0,  0.00027D0,  0.00019D0,  0.00006D0,  0.00002D0,
56811      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56812       DATA (FMRS(2,8,I,13),I=1,49)/
56813      &     2.08649D0,  1.75519D0,  1.47580D0,  1.33308D0,  1.24007D0,
56814      &     1.17230D0,  0.98378D0,  0.82434D0,  0.74261D0,  0.68917D0,
56815      &     0.65012D0,  0.54038D0,  0.44535D0,  0.39548D0,  0.36240D0,
56816      &     0.33801D0,  0.30327D0,  0.26901D0,  0.23303D0,  0.20903D0,
56817      &     0.17595D0,  0.15158D0,  0.13113D0,  0.10875D0,  0.08901D0,
56818      &     0.07161D0,  0.05666D0,  0.04403D0,  0.03356D0,  0.02508D0,
56819      &     0.01848D0,  0.01341D0,  0.00954D0,  0.00676D0,  0.00467D0,
56820      &     0.00317D0,  0.00216D0,  0.00148D0,  0.00096D0,  0.00064D0,
56821      &     0.00043D0,  0.00027D0,  0.00018D0,  0.00006D0,  0.00002D0,
56822      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56823       DATA (FMRS(2,8,I,14),I=1,49)/
56824      &     2.39126D0,  1.99450D0,  1.66281D0,  1.49454D0,  1.38536D0,
56825      &     1.30604D0,  1.08660D0,  0.90248D0,  0.80863D0,  0.74747D0,
56826      &     0.70276D0,  0.57787D0,  0.47070D0,  0.41497D0,  0.37825D0,
56827      &     0.35132D0,  0.31319D0,  0.27591D0,  0.23714D0,  0.21153D0,
56828      &     0.17666D0,  0.15129D0,  0.13023D0,  0.10742D0,  0.08751D0,
56829      &     0.07010D0,  0.05525D0,  0.04280D0,  0.03250D0,  0.02426D0,
56830      &     0.01784D0,  0.01291D0,  0.00918D0,  0.00650D0,  0.00451D0,
56831      &     0.00308D0,  0.00210D0,  0.00146D0,  0.00091D0,  0.00061D0,
56832      &     0.00040D0,  0.00024D0,  0.00017D0,  0.00007D0,  0.00002D0,
56833      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56834       DATA (FMRS(2,8,I,15),I=1,49)/
56835      &     2.76033D0,  2.28068D0,  1.88356D0,  1.68366D0,  1.55456D0,
56836      &     1.46111D0,  1.20412D0,  0.99043D0,  0.88227D0,  0.81205D0,
56837      &     0.76076D0,  0.61847D0,  0.49766D0,  0.43549D0,  0.39480D0,
56838      &     0.36513D0,  0.32340D0,  0.28293D0,  0.24126D0,  0.21400D0,
56839      &     0.17728D0,  0.15089D0,  0.12922D0,  0.10598D0,  0.08590D0,
56840      &     0.06852D0,  0.05375D0,  0.04146D0,  0.03141D0,  0.02338D0,
56841      &     0.01716D0,  0.01238D0,  0.00882D0,  0.00618D0,  0.00431D0,
56842      &     0.00292D0,  0.00200D0,  0.00136D0,  0.00088D0,  0.00058D0,
56843      &     0.00038D0,  0.00023D0,  0.00015D0,  0.00006D0,  0.00002D0,
56844      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56845       DATA (FMRS(2,8,I,16),I=1,49)/
56846      &     3.14075D0,  2.57242D0,  2.10607D0,  1.87299D0,  1.72314D0,
56847      &     1.61501D0,  1.31935D0,  1.07560D0,  0.95301D0,  0.87374D0,
56848      &     0.81592D0,  0.65651D0,  0.52253D0,  0.45423D0,  0.40982D0,
56849      &     0.37760D0,  0.33254D0,  0.28915D0,  0.24485D0,  0.21612D0,
56850      &     0.17773D0,  0.15044D0,  0.12821D0,  0.10460D0,  0.08439D0,
56851      &     0.06702D0,  0.05238D0,  0.04027D0,  0.03041D0,  0.02258D0,
56852      &     0.01653D0,  0.01190D0,  0.00847D0,  0.00593D0,  0.00412D0,
56853      &     0.00279D0,  0.00191D0,  0.00129D0,  0.00084D0,  0.00056D0,
56854      &     0.00036D0,  0.00023D0,  0.00014D0,  0.00006D0,  0.00002D0,
56855      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56856       DATA (FMRS(2,8,I,17),I=1,49)/
56857      &     3.57238D0,  2.90007D0,  2.35339D0,  2.08215D0,  1.90855D0,
56858      &     1.78371D0,  1.44428D0,  1.16687D0,  1.02831D0,  0.93907D0,
56859      &     0.87409D0,  0.69611D0,  0.54805D0,  0.47331D0,  0.42502D0,
56860      &     0.39015D0,  0.34166D0,  0.29530D0,  0.24836D0,  0.21814D0,
56861      &     0.17810D0,  0.14991D0,  0.12715D0,  0.10317D0,  0.08284D0,
56862      &     0.06549D0,  0.05101D0,  0.03909D0,  0.02941D0,  0.02178D0,
56863      &     0.01590D0,  0.01142D0,  0.00811D0,  0.00570D0,  0.00393D0,
56864      &     0.00267D0,  0.00181D0,  0.00123D0,  0.00079D0,  0.00053D0,
56865      &     0.00034D0,  0.00022D0,  0.00013D0,  0.00006D0,  0.00001D0,
56866      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56867       DATA (FMRS(2,8,I,18),I=1,49)/
56868      &     3.96850D0,  3.19797D0,  2.57613D0,  2.26945D0,  2.07391D0,
56869      &     1.93368D0,  1.55423D0,  1.24636D0,  1.09346D0,  0.99533D0,
56870      &     0.92399D0,  0.72966D0,  0.56941D0,  0.48914D0,  0.43755D0,
56871      &     0.40046D0,  0.34910D0,  0.30027D0,  0.25115D0,  0.21971D0,
56872      &     0.17833D0,  0.14941D0,  0.12622D0,  0.10197D0,  0.08154D0,
56873      &     0.06423D0,  0.04986D0,  0.03809D0,  0.02858D0,  0.02112D0,
56874      &     0.01538D0,  0.01101D0,  0.00783D0,  0.00549D0,  0.00377D0,
56875      &     0.00256D0,  0.00173D0,  0.00118D0,  0.00076D0,  0.00050D0,
56876      &     0.00033D0,  0.00020D0,  0.00012D0,  0.00005D0,  0.00002D0,
56877      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56878       DATA (FMRS(2,8,I,19),I=1,49)/
56879      &     4.49525D0,  3.59055D0,  2.86699D0,  2.51271D0,  2.28784D0,
56880      &     2.12710D0,  1.69466D0,  1.34689D0,  1.17536D0,  1.06574D0,
56881      &     0.98622D0,  0.77102D0,  0.59540D0,  0.50826D0,  0.45260D0,
56882      &     0.41278D0,  0.35791D0,  0.30610D0,  0.25436D0,  0.22147D0,
56883      &     0.17849D0,  0.14870D0,  0.12502D0,  0.10045D0,  0.07994D0,
56884      &     0.06271D0,  0.04847D0,  0.03689D0,  0.02761D0,  0.02033D0,
56885      &     0.01477D0,  0.01056D0,  0.00749D0,  0.00523D0,  0.00359D0,
56886      &     0.00243D0,  0.00165D0,  0.00112D0,  0.00070D0,  0.00047D0,
56887      &     0.00031D0,  0.00018D0,  0.00012D0,  0.00004D0,  0.00002D0,
56888      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56889       DATA (FMRS(2,8,I,20),I=1,49)/
56890      &     5.00899D0,  3.97007D0,  3.14567D0,  2.74457D0,  2.49097D0,
56891      &     2.31023D0,  1.82640D0,  1.44029D0,  1.25101D0,  1.13051D0,
56892      &     1.04327D0,  0.80852D0,  0.61869D0,  0.52527D0,  0.46592D0,
56893      &     0.42363D0,  0.36563D0,  0.31116D0,  0.25711D0,  0.22294D0,
56894      &     0.17857D0,  0.14803D0,  0.12392D0,  0.09909D0,  0.07852D0,
56895      &     0.06137D0,  0.04727D0,  0.03584D0,  0.02676D0,  0.01965D0,
56896      &     0.01424D0,  0.01018D0,  0.00720D0,  0.00501D0,  0.00343D0,
56897      &     0.00232D0,  0.00157D0,  0.00107D0,  0.00066D0,  0.00045D0,
56898      &     0.00029D0,  0.00018D0,  0.00012D0,  0.00004D0,  0.00001D0,
56899      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56900       DATA (FMRS(2,8,I,21),I=1,49)/
56901      &     5.51448D0,  4.34048D0,  3.41543D0,  2.96790D0,  2.68596D0,
56902      &     2.48552D0,  1.95141D0,  1.52811D0,  1.32176D0,  1.19083D0,
56903      &     1.09623D0,  0.84295D0,  0.63982D0,  0.54059D0,  0.47785D0,
56904      &     0.43329D0,  0.37244D0,  0.31558D0,  0.25945D0,  0.22413D0,
56905      &     0.17852D0,  0.14733D0,  0.12285D0,  0.09781D0,  0.07721D0,
56906      &     0.06012D0,  0.04616D0,  0.03490D0,  0.02597D0,  0.01904D0,
56907      &     0.01376D0,  0.00981D0,  0.00692D0,  0.00481D0,  0.00330D0,
56908      &     0.00222D0,  0.00150D0,  0.00102D0,  0.00064D0,  0.00042D0,
56909      &     0.00028D0,  0.00017D0,  0.00011D0,  0.00004D0,  0.00001D0,
56910      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56911       DATA (FMRS(2,8,I,22),I=1,49)/
56912      &     6.21231D0,  4.84766D0,  3.78177D0,  3.26973D0,  2.94855D0,
56913      &     2.72097D0,  2.11789D0,  1.64406D0,  1.41467D0,  1.26974D0,
56914      &     1.16528D0,  0.88741D0,  0.66681D0,  0.56001D0,  0.49289D0,
56915      &     0.44543D0,  0.38094D0,  0.32104D0,  0.26228D0,  0.22553D0,
56916      &     0.17838D0,  0.14638D0,  0.12146D0,  0.09617D0,  0.07554D0,
56917      &     0.05855D0,  0.04477D0,  0.03372D0,  0.02502D0,  0.01828D0,
56918      &     0.01316D0,  0.00936D0,  0.00658D0,  0.00457D0,  0.00313D0,
56919      &     0.00210D0,  0.00142D0,  0.00097D0,  0.00060D0,  0.00039D0,
56920      &     0.00026D0,  0.00016D0,  0.00010D0,  0.00004D0,  0.00001D0,
56921      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56922       DATA (FMRS(2,8,I,23),I=1,49)/
56923      &     6.92819D0,  5.36347D0,  4.15110D0,  3.57245D0,  3.21096D0,
56924      &     2.95557D0,  2.28227D0,  1.75749D0,  1.50504D0,  1.34618D0,
56925      &     1.23195D0,  0.92986D0,  0.69228D0,  0.57821D0,  0.50690D0,
56926      &     0.45669D0,  0.38876D0,  0.32601D0,  0.26481D0,  0.22674D0,
56927      &     0.17816D0,  0.14541D0,  0.12011D0,  0.09461D0,  0.07396D0,
56928      &     0.05707D0,  0.04348D0,  0.03263D0,  0.02417D0,  0.01758D0,
56929      &     0.01264D0,  0.00894D0,  0.00628D0,  0.00436D0,  0.00298D0,
56930      &     0.00199D0,  0.00135D0,  0.00091D0,  0.00057D0,  0.00037D0,
56931      &     0.00024D0,  0.00015D0,  0.00010D0,  0.00004D0,  0.00001D0,
56932      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56933       DATA (FMRS(2,8,I,24),I=1,49)/
56934      &     7.64199D0,  5.87362D0,  4.51337D0,  3.86793D0,  3.46620D0,
56935      &     3.18314D0,  2.44035D0,  1.86558D0,  1.59069D0,  1.41834D0,
56936      &     1.29468D0,  0.96937D0,  0.71569D0,  0.59480D0,  0.51959D0,
56937      &     0.46683D0,  0.39572D0,  0.33035D0,  0.26693D0,  0.22767D0,
56938      &     0.17780D0,  0.14441D0,  0.11876D0,  0.09309D0,  0.07246D0,
56939      &     0.05571D0,  0.04226D0,  0.03164D0,  0.02333D0,  0.01693D0,
56940      &     0.01213D0,  0.00857D0,  0.00600D0,  0.00415D0,  0.00282D0,
56941      &     0.00189D0,  0.00128D0,  0.00086D0,  0.00054D0,  0.00035D0,
56942      &     0.00022D0,  0.00014D0,  0.00009D0,  0.00003D0,  0.00001D0,
56943      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56944       DATA (FMRS(2,8,I,25),I=1,49)/
56945      &     8.41285D0,  6.42055D0,  4.89893D0,  4.18106D0,  3.73585D0,
56946      &     3.42298D0,  2.60571D0,  1.97779D0,  1.67919D0,  1.49264D0,
56947      &     1.35909D0,  1.00958D0,  0.73928D0,  0.61142D0,  0.53225D0,
56948      &     0.47690D0,  0.40260D0,  0.33461D0,  0.26898D0,  0.22853D0,
56949      &     0.17741D0,  0.14339D0,  0.11741D0,  0.09159D0,  0.07099D0,
56950      &     0.05437D0,  0.04108D0,  0.03067D0,  0.02252D0,  0.01631D0,
56951      &     0.01165D0,  0.00822D0,  0.00574D0,  0.00396D0,  0.00268D0,
56952      &     0.00180D0,  0.00120D0,  0.00081D0,  0.00050D0,  0.00033D0,
56953      &     0.00021D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00001D0,
56954      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56955       DATA (FMRS(2,8,I,26),I=1,49)/
56956      &     9.21054D0,  6.98238D0,  5.29207D0,  4.49895D0,  4.00873D0,
56957      &     3.66510D0,  2.77134D0,  2.08927D0,  1.76669D0,  1.56583D0,
56958      &     1.42235D0,  1.04868D0,  0.76198D0,  0.62728D0,  0.54426D0,
56959      &     0.48640D0,  0.40901D0,  0.33853D0,  0.27078D0,  0.22922D0,
56960      &     0.17691D0,  0.14232D0,  0.11604D0,  0.09010D0,  0.06954D0,
56961      &     0.05305D0,  0.03996D0,  0.02972D0,  0.02176D0,  0.01572D0,
56962      &     0.01122D0,  0.00790D0,  0.00548D0,  0.00378D0,  0.00255D0,
56963      &     0.00171D0,  0.00115D0,  0.00078D0,  0.00048D0,  0.00031D0,
56964      &     0.00020D0,  0.00012D0,  0.00008D0,  0.00002D0,  0.00001D0,
56965      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56966       DATA (FMRS(2,8,I,27),I=1,49)/
56967      &    10.01421D0,  7.54466D0,  5.68289D0,  4.81371D0,  4.27818D0,
56968      &     3.90363D0,  2.93340D0,  2.19757D0,  1.85131D0,  1.63639D0,
56969      &     1.48318D0,  1.08596D0,  0.78341D0,  0.64217D0,  0.55547D0,
56970      &     0.49525D0,  0.41494D0,  0.34210D0,  0.27239D0,  0.22977D0,
56971      &     0.17638D0,  0.14126D0,  0.11473D0,  0.08869D0,  0.06818D0,
56972      &     0.05182D0,  0.03892D0,  0.02884D0,  0.02107D0,  0.01518D0,
56973      &     0.01082D0,  0.00760D0,  0.00526D0,  0.00363D0,  0.00244D0,
56974      &     0.00163D0,  0.00110D0,  0.00075D0,  0.00046D0,  0.00030D0,
56975      &     0.00019D0,  0.00012D0,  0.00007D0,  0.00002D0,  0.00001D0,
56976      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56977       DATA (FMRS(2,8,I,28),I=1,49)/
56978      &    10.81038D0,  8.09822D0,  6.06522D0,  5.12048D0,  4.54007D0,
56979      &     4.13500D0,  3.08954D0,  2.30121D0,  1.93196D0,  1.70343D0,
56980      &     1.54082D0,  1.12100D0,  0.80336D0,  0.65594D0,  0.56579D0,
56981      &     0.50334D0,  0.42032D0,  0.34528D0,  0.27377D0,  0.23019D0,
56982      &     0.17582D0,  0.14022D0,  0.11347D0,  0.08735D0,  0.06690D0,
56983      &     0.05067D0,  0.03795D0,  0.02804D0,  0.02043D0,  0.01468D0,
56984      &     0.01043D0,  0.00733D0,  0.00506D0,  0.00348D0,  0.00235D0,
56985      &     0.00155D0,  0.00105D0,  0.00071D0,  0.00043D0,  0.00029D0,
56986      &     0.00018D0,  0.00011D0,  0.00007D0,  0.00002D0,  0.00001D0,
56987      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56988       DATA (FMRS(2,8,I,29),I=1,49)/
56989      &    11.65265D0,  8.68040D0,  6.46494D0,  5.44008D0,  4.81224D0,
56990      &     4.37498D0,  3.25050D0,  2.40736D0,  2.01424D0,  1.77163D0,
56991      &     1.59933D0,  1.15629D0,  0.82328D0,  0.66961D0,  0.57598D0,
56992      &     0.51130D0,  0.42557D0,  0.34836D0,  0.27505D0,  0.23054D0,
56993      &     0.17519D0,  0.13914D0,  0.11219D0,  0.08600D0,  0.06563D0,
56994      &     0.04954D0,  0.03699D0,  0.02726D0,  0.01981D0,  0.01419D0,
56995      &     0.01006D0,  0.00705D0,  0.00487D0,  0.00334D0,  0.00225D0,
56996      &     0.00148D0,  0.00100D0,  0.00068D0,  0.00041D0,  0.00027D0,
56997      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00002D0,  0.00001D0,
56998      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
56999       DATA (FMRS(2,8,I,30),I=1,49)/
57000      &    12.51775D0,  9.27489D0,  6.87071D0,  5.76340D0,  5.08688D0,
57001      &     4.61667D0,  3.41161D0,  2.51293D0,  2.09575D0,  1.83900D0,
57002      &     1.65698D0,  1.19078D0,  0.84258D0,  0.68277D0,  0.58574D0,
57003      &     0.51889D0,  0.43052D0,  0.35121D0,  0.27618D0,  0.23078D0,
57004      &     0.17451D0,  0.13804D0,  0.11091D0,  0.08467D0,  0.06438D0,
57005      &     0.04844D0,  0.03605D0,  0.02651D0,  0.01920D0,  0.01373D0,
57006      &     0.00970D0,  0.00677D0,  0.00468D0,  0.00321D0,  0.00215D0,
57007      &     0.00142D0,  0.00096D0,  0.00064D0,  0.00040D0,  0.00026D0,
57008      &     0.00017D0,  0.00010D0,  0.00006D0,  0.00002D0,  0.00001D0,
57009      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57010       DATA (FMRS(2,8,I,31),I=1,49)/
57011      &    13.38188D0,  9.86555D0,  7.27170D0,  6.08188D0,  5.35680D0,
57012      &     4.85378D0,  3.56878D0,  2.61532D0,  2.17453D0,  1.90394D0,
57013      &     1.71244D0,  1.22374D0,  0.86087D0,  0.69518D0,  0.59491D0,
57014      &     0.52599D0,  0.43513D0,  0.35383D0,  0.27719D0,  0.23095D0,
57015      &     0.17383D0,  0.13697D0,  0.10968D0,  0.08342D0,  0.06322D0,
57016      &     0.04742D0,  0.03518D0,  0.02580D0,  0.01865D0,  0.01331D0,
57017      &     0.00937D0,  0.00652D0,  0.00451D0,  0.00308D0,  0.00206D0,
57018      &     0.00136D0,  0.00092D0,  0.00061D0,  0.00038D0,  0.00024D0,
57019      &     0.00016D0,  0.00010D0,  0.00006D0,  0.00002D0,  0.00001D0,
57020      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57021       DATA (FMRS(2,8,I,32),I=1,49)/
57022      &    14.22455D0, 10.43853D0,  7.65861D0,  6.38821D0,  5.61583D0,
57023      &     5.08091D0,  3.71848D0,  2.71227D0,  2.24884D0,  1.96503D0,
57024      &     1.76449D0,  1.25443D0,  0.87775D0,  0.70654D0,  0.60325D0,
57025      &     0.53242D0,  0.43925D0,  0.35613D0,  0.27800D0,  0.23100D0,
57026      &     0.17312D0,  0.13592D0,  0.10849D0,  0.08223D0,  0.06212D0,
57027      &     0.04645D0,  0.03438D0,  0.02514D0,  0.01814D0,  0.01292D0,
57028      &     0.00909D0,  0.00631D0,  0.00435D0,  0.00297D0,  0.00198D0,
57029      &     0.00130D0,  0.00088D0,  0.00059D0,  0.00036D0,  0.00023D0,
57030      &     0.00015D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00000D0,
57031      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57032       DATA (FMRS(2,8,I,33),I=1,49)/
57033      &    15.12220D0, 11.04609D0,  8.06700D0,  6.71068D0,  5.88799D0,
57034      &     5.31921D0,  3.87481D0,  2.81304D0,  2.32586D0,  2.02823D0,
57035      &     1.81825D0,  1.28597D0,  0.89499D0,  0.71812D0,  0.61173D0,
57036      &     0.53894D0,  0.44342D0,  0.35844D0,  0.27882D0,  0.23104D0,
57037      &     0.17241D0,  0.13488D0,  0.10730D0,  0.08105D0,  0.06103D0,
57038      &     0.04549D0,  0.03359D0,  0.02450D0,  0.01765D0,  0.01253D0,
57039      &     0.00880D0,  0.00610D0,  0.00420D0,  0.00286D0,  0.00191D0,
57040      &     0.00125D0,  0.00083D0,  0.00057D0,  0.00034D0,  0.00022D0,
57041      &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
57042      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57043       DATA (FMRS(2,8,I,34),I=1,49)/
57044      &    16.02044D0, 11.65091D0,  8.47137D0,  7.02895D0,  6.15599D0,
57045      &     5.55343D0,  4.02757D0,  2.91088D0,  2.40036D0,  2.08916D0,
57046      &     1.86995D0,  1.31603D0,  0.91125D0,  0.72894D0,  0.61960D0,
57047      &     0.54494D0,  0.44718D0,  0.36046D0,  0.27943D0,  0.23094D0,
57048      &     0.17160D0,  0.13377D0,  0.10610D0,  0.07985D0,  0.05994D0,
57049      &     0.04455D0,  0.03282D0,  0.02388D0,  0.01715D0,  0.01216D0,
57050      &     0.00853D0,  0.00590D0,  0.00405D0,  0.00275D0,  0.00184D0,
57051      &     0.00120D0,  0.00080D0,  0.00054D0,  0.00033D0,  0.00021D0,
57052      &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
57053      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57054       DATA (FMRS(2,8,I,35),I=1,49)/
57055      &    16.92092D0, 12.25466D0,  8.87333D0,  7.34454D0,  6.42124D0,
57056      &     5.78493D0,  4.17791D0,  3.00675D0,  2.47316D0,  2.14860D0,
57057      &     1.92031D0,  1.34518D0,  0.92693D0,  0.73935D0,  0.62715D0,
57058      &     0.55068D0,  0.45078D0,  0.36238D0,  0.28002D0,  0.23083D0,
57059      &     0.17082D0,  0.13273D0,  0.10496D0,  0.07873D0,  0.05891D0,
57060      &     0.04367D0,  0.03209D0,  0.02331D0,  0.01669D0,  0.01182D0,
57061      &     0.00827D0,  0.00571D0,  0.00391D0,  0.00265D0,  0.00178D0,
57062      &     0.00117D0,  0.00077D0,  0.00052D0,  0.00031D0,  0.00020D0,
57063      &     0.00012D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
57064      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57065       DATA (FMRS(2,8,I,36),I=1,49)/
57066      &    17.79951D0, 12.84117D0,  9.26208D0,  7.64895D0,  6.67663D0,
57067      &     6.00749D0,  4.32176D0,  3.09803D0,  2.54226D0,  2.20489D0,
57068      &     1.96790D0,  1.37254D0,  0.94153D0,  0.74899D0,  0.63410D0,
57069      &     0.55594D0,  0.45404D0,  0.36409D0,  0.28048D0,  0.23067D0,
57070      &     0.17006D0,  0.13172D0,  0.10387D0,  0.07767D0,  0.05796D0,
57071      &     0.04286D0,  0.03142D0,  0.02277D0,  0.01627D0,  0.01150D0,
57072      &     0.00803D0,  0.00554D0,  0.00379D0,  0.00256D0,  0.00172D0,
57073      &     0.00113D0,  0.00074D0,  0.00050D0,  0.00030D0,  0.00019D0,
57074      &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
57075      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57076       DATA (FMRS(2,8,I,37),I=1,49)/
57077      &    18.71000D0, 13.44641D0,  9.66151D0,  7.96092D0,  6.93787D0,
57078      &     6.23483D0,  4.46802D0,  3.19039D0,  2.61196D0,  2.26153D0,
57079      &     2.01571D0,  1.39986D0,  0.95599D0,  0.75847D0,  0.64090D0,
57080      &     0.56106D0,  0.45717D0,  0.36568D0,  0.28085D0,  0.23044D0,
57081      &     0.16924D0,  0.13067D0,  0.10276D0,  0.07660D0,  0.05700D0,
57082      &     0.04204D0,  0.03075D0,  0.02224D0,  0.01586D0,  0.01118D0,
57083      &     0.00780D0,  0.00537D0,  0.00367D0,  0.00247D0,  0.00167D0,
57084      &     0.00108D0,  0.00071D0,  0.00047D0,  0.00029D0,  0.00018D0,
57085      &     0.00011D0,  0.00006D0,  0.00004D0,  0.00002D0,  0.00000D0,
57086      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57087       DATA (FMRS(2,8,I,38),I=1,49)/
57088      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57089      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57090      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57091      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57092      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57093      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57094      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57095      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57096      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
57097      &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
57098       END
57099 CDECK  ID>, HWUDKL.
57100 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
57101 *-- Author :    Ian Knowles
57102 C-----------------------------------------------------------------------
57103       SUBROUTINE HWUDKL(ID,PMOM,DISP)
57104 C-----------------------------------------------------------------------
57105 C     Given a real or virtual particle, flavour ID and 4-momentum PMOM,
57106 C     returns DISP its distance travelled in mm.
57107 C
57108 C     Modified 16/01/01 by BRW to force particle on mass shell if
57109 C     p^2-m^2 < 10^-10 GeV^2 (rounding errors)
57110 C-----------------------------------------------------------------------
57111       INCLUDE 'HERWIG65.INC'
57112       DOUBLE PRECISION HWRGEN,PMOM(4),DISP(4),PMOM2,SCALE,OFFSH
57113       INTEGER ID
57114       EXTERNAL HWRGEN
57115       PMOM2=(PMOM(4)+PMOM(3))*(PMOM(4)-PMOM(3))-PMOM(1)**2-PMOM(2)**2
57116       OFFSH=PMOM2-RMASS(ID)**2
57117       IF (OFFSH.LT.1D-10) OFFSH=ZERO
57118       SCALE=-GEV2MM*LOG(HWRGEN(0))/SQRT(OFFSH**2+(PMOM2/DKLTM(ID))**2)
57119       IF (ID.GT.197.AND.ID.LT.203) SCALE=SCALE*EXAG
57120       CALL HWVSCA(4,SCALE,PMOM,DISP)
57121       END
57122 C-----------------------------------------------------------------------
57123 CDECK  ID>, HWUDKS.
57124 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
57125 *-- Author :    Ian Knowles
57126 C-----------------------------------------------------------------------
57127       SUBROUTINE HWUDKS
57128 C-----------------------------------------------------------------------
57129 C     Sets up internal pointers based on the decay table in HWUDAT or as
57130 C     supplied via HWIODK. Computes CoM momenta of two-body decay modes.
57131 C     Particles with long lifetimes or no allowed decay (excepting light
57132 C     b hadrons when CLEO/EURODEC decays requested) are set stable, else
57133 C     calculate DKLTM(I) = mass/width ( = mass * lifetime/hbar).
57134 C     Gives warnings if: a particle has no decay modes or antiparticle's
57135 C     modes are not the charge conjugates of the particles.
57136 C     (N.B. CP violation permits this).
57137 C-----------------------------------------------------------------------
57138       INCLUDE 'HERWIG65.INC'
57139       DOUBLE PRECISION HWUPCM,HWUAEM,HWUALF,BRSUM,EPS,SCALE,
57140      & BRTMP(NMXDKS),FN,X,W,Q,FAC
57141       INTEGER HWUANT,I,IDKY,LAST,LTMP(NMXMOD),J,L,K,M,N,INDX(NMXMOD),
57142      & IRES,IAPDG,IPART,LR,LP,KPRDLR
57143       LOGICAL BPDK,TOPDKS,MATCH(5),PMATCH(NMXMOD)
57144       CHARACTER*7 CVETO(2)
57145       CHARACTER*8 CDUM
57146       EXTERNAL HWUPCM,HWUAEM,HWUALF,HWUANT
57147       PARAMETER(EPS=1.E-6)
57148       FN(X,Q,W)=X**4/(((X*X-Q*Q)**2+W*W*(X*X+Q*Q)-2.*W**4)
57149      &               *SQRT(X**4+Q**4+W**4-2.*(X*X*Q*Q+X*X*W*W+Q*Q*W*W)))
57150       WRITE(6,10)
57151   10  FORMAT(/10X,'Checking consistency of decay tables'/)
57152       DKPSET=.TRUE.
57153 C First zero arrays
57154       DO 20 I=1,NMXRES
57155       LSTRT(I)=0
57156   20  NMODES(I)=0
57157       DO 30 I=1,NMXDKS
57158       NPRODS(I)=0
57159       LNEXT(I)=0
57160   30  CMMOM(I)=0
57161       BPDK=BDECAY.NE.'HERW'
57162       DO 180 I=1,NDKYS
57163 C Search for next decaying particle type
57164       IDKY=IDK(I)
57165 C Skip if particle is not recognised or already dealt with
57166       IF (IDKY.EQ.0.OR.IDKY.EQ.20) THEN
57167         WRITE(6,40) I
57168   40    FORMAT(1X,'Line ',I4,': decaying particle not recognised')
57169         GOTO 180
57170       ENDIF
57171       IF (NMODES(IDKY).GT.0) GOTO 180
57172 C Check and include first decay mode, storing a copy
57173       CALL HWDCHK(IDKY,I,*180)
57174       LSTRT(IDKY)=I
57175       NMODES(IDKY)=1
57176       BRSUM=BRFRAC(I)
57177       LTMP(1)=I
57178       BRTMP(1)=-BRFRAC(I)
57179       LAST=I
57180 C Sets CMMOM(IDKY) = CoM momentum for first 2-body decay mode I (else 0)
57181       IF (NPRODS(I).EQ.2) CMMOM(I)=
57182      & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,I)),RMASS(IDKPRD(2,I)))
57183 C Include any other decay modes of IDKY
57184       DO 120 J=I+1,NDKYS
57185       IF (IDK(J).EQ.IDKY) THEN
57186 C First see if it is a copy of the same decay channel
57187         IF ((IDKPRD(2,J).GE.1.AND.IDKPRD(2,J).LE.13).OR.
57188      &      (IDKPRD(3,J).GE.1.AND.IDKPRD(3,J).LE.13)) THEN
57189 C Partonic respect order
57190           L=LSTRT(IDKY)
57191           DO 50 K=1,NMODES(IDKY)
57192               IF (IDKPRD(1,L).EQ.IDKPRD(1,J).AND.
57193      &            IDKPRD(2,L).EQ.IDKPRD(2,J).AND.
57194      &            IDKPRD(3,L).EQ.IDKPRD(3,J).AND.
57195      &            IDKPRD(4,L).EQ.IDKPRD(4,J).AND.
57196      &            IDKPRD(5,L).EQ.IDKPRD(5,J)) GOTO 100
57197   50      L=LNEXT(L)
57198         ELSE
57199 C Allow for different order in matching
57200           L=LSTRT(IDKY)
57201           DO 90 K=1,NMODES(IDKY)
57202           DO 60 M=1,5
57203   60      MATCH(M)=.FALSE.
57204           DO 80 M=1,5
57205           DO 70 N=1,5
57206           IF (.NOT.MATCH(N).AND.IDKPRD(N,L).EQ.IDKPRD(M,J)) THEN
57207             MATCH(N)=.TRUE.
57208             GOTO 80
57209           ENDIF
57210   70      CONTINUE
57211   80      CONTINUE
57212           IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
57213      &        MATCH(4).AND.MATCH(5)) GOTO 100
57214   90      L=LNEXT(L)
57215         ENDIF
57216         CALL HWDCHK(IDKY,J,*120)
57217         NMODES(IDKY)=NMODES(IDKY)+1
57218         IF (NMODES(IDKY).GT.NMXMOD) CALL HWWARN('HWUDKS',100,*999)
57219         LNEXT(LAST)=J
57220         BRSUM=BRSUM+BRFRAC(J)
57221         LTMP(NMODES(IDKY))=J
57222         BRTMP(NMODES(IDKY))=-BRFRAC(J)
57223         LAST=J
57224 C Sets CMMOM(IDKY) = CoM momentum for next 2-body decay mode J (else 0)
57225         IF (NPRODS(J).EQ.2) CMMOM(J)=
57226      &   HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,J)),RMASS(IDKPRD(2,J)))
57227       ENDIF
57228       GOTO 120
57229   100 WRITE(6,110) L,J,BRFRAC(J),NME(J)
57230       BRSUM=BRSUM-BRFRAC(L)+BRFRAC(J)
57231       BRFRAC(L)=BRFRAC(J)
57232       BRTMP(L)=-BRFRAC(L)
57233       NME(L)=NME(J)
57234   110 FORMAT(1X,'Line ',I4,' is the same as line ',I4/
57235      &       1X,'Take BR ',F5.3,' and ME code ',I3,' from second entry')
57236   120 CONTINUE
57237 C Set sum of branching ratios to 1. if necessary
57238       IF (ABS(BRSUM-1.).GT.EPS) THEN
57239         WRITE(6,130) RNAME(IDKY),BRSUM
57240   130   FORMAT(1X,A8,': BR sum =',F8.5)
57241         IF (ABS(BRSUM).LT.EPS) THEN
57242           WRITE(6,140)
57243   140     FORMAT(1X,'Setting particle stable'/)
57244           NMODES(IDKY)=0
57245         ELSE
57246           WRITE(6,150)
57247   150     FORMAT(1X,'Rescaling to 1'/)
57248           SCALE=1./BRSUM
57249           K=LSTRT(IDKY)
57250           DO 160 J=1,NMODES(IDKY)
57251           BRFRAC(K)=SCALE*BRFRAC(K)
57252   160     K=LNEXT(K)
57253         ENDIF
57254       ENDIF
57255 C Sort branching ratios into descending order and rearrange pointers
57256       CALL HWUSOR(BRTMP,NMODES(IDKY),INDX,2)
57257       LSTRT(IDKY)=LTMP(INDX(1))
57258       LNEXT(LTMP(INDX(1)))=LTMP(INDX(1))
57259       DO 170 J=2,NMODES(IDKY)
57260       IF (ABS(BRFRAC(LTMP(INDX(J)))).LT.EPS) THEN
57261         NMODES(IDKY)=J-1
57262         GOTO 175
57263       ENDIF
57264   170 LNEXT(LTMP(INDX(J-1)))=LTMP(INDX(J))
57265   175 LNEXT(LTMP(INDX(NMODES(IDKY))))=LTMP(INDX(NMODES(IDKY)))
57266   180 CONTINUE
57267 C If not a short lived particle with a decay mode then set stable
57268       DO 190 I=1,NRES
57269       IF (.NOT.RSTAB(I).AND.RLTIM(I).LT.PLTCUT.AND.
57270      &    (NMODES(I).GT.0.OR.
57271      &     (BPDK.AND.((I.GE.221.AND.I.LE.231).OR.
57272      &                (I.GE.245.AND.I.LE.254))))) THEN
57273         DKLTM(I)=RLTIM(I)*RMASS(I)/HBAR
57274       ELSE
57275         RSTAB(I)=.TRUE.
57276       ENDIF
57277   190 CONTINUE
57278 C Set up DKLTM for light quarks
57279       DO 200 I=1,5
57280       DKLTM(I)=RMASS(I)**2/VMIN2
57281   200 DKLTM(I+6)=DKLTM(I)
57282 C gluon
57283       DKLTM(13)=RMASS(13)**2/VMIN2
57284 C and diquarks
57285       DO 210 I=109,114
57286       DKLTM(I)=RMASS(I)**2/VMIN2
57287   210 DKLTM(I+6)=DKLTM(I)
57288 C Set up DKLTM for weak bosons
57289       DKLTM(198)=RMASS(198)/GAMW
57290       DKLTM(199)=DKLTM(198)
57291       DKLTM(200)=RMASS(200)/GAMZ
57292       DKLTM(201)=RMASS(201)/GAMH
57293       DKLTM(202)=RMASS(202)/GAMZP
57294 C Set up DKTRM for massive quarks (plus check m_Q > M_W + m_q)
57295       FAC=SWEIN*(FOUR*RMASS(198))**2/HWUAEM(RMASS(198)**2)
57296       IF (.NOT.SUSYIN) THEN
57297         IF (RMASS(6).GT.RMASS(5)+RMASS(198)) THEN
57298           DKLTM(6)=FAC*FN(RMASS(6  ),RMASS(5  ),RMASS(198))
57299      &            /(1-HWUALF(1,RMASS(6))*2*(2*PIFAC**2/3-5/2)/(3*PIFAC))
57300           DKLTM(12)=DKLTM(6)
57301         ELSE
57302           WRITE(6,220) RNAME(6),RNAME(5),RNAME(198)
57303         ENDIF
57304       ENDIF
57305       IF (RMASS(209).GT.RMASS(4)+RMASS(198)) THEN
57306         DKLTM(209)=FAC*FN(RMASS(209),RMASS(4  ),RMASS(198))
57307         DKLTM(215)=DKLTM(209)
57308       ELSE
57309         WRITE(6,220) RNAME(209),RNAME(4),RNAME(198)
57310       ENDIF
57311       IF (RMASS(210).GT.RMASS(209)+RMASS(198)) THEN
57312         DKLTM(210)=FAC*FN(RMASS(210),RMASS(209),RMASS(198))
57313         DKLTM(216)=DKLTM(210)
57314       ELSE
57315         WRITE(6,220) RNAME(210),RNAME(209),RNAME(198)
57316       ENDIF
57317       IF (RMASS(211).GT.RMASS(6)+RMASS(198)) THEN
57318         DKLTM(211)=FAC*FN(RMASS(211),RMASS(6  ),RMASS(198))
57319         DKLTM(217)=DKLTM(211)
57320       ELSE
57321         WRITE(6,220) RNAME(211),RNAME(6),RNAME(198)
57322       ENDIF
57323       IF (RMASS(212).GT.RMASS(211)+RMASS(198)) THEN
57324         DKLTM(212)=FAC*FN(RMASS(212),RMASS(211),RMASS(198))
57325         DKLTM(218)=DKLTM(212)
57326       ELSE
57327         WRITE(6,220) RNAME(212),RNAME(211),RNAME(198)
57328       ENDIF
57329  220  FORMAT(1X,'W not real in the decay: ',A8,' --> ',A8,' + ',A8)
57330 C Now carry out diagnostic checks on decay table
57331       CALL HWDTOP(TOPDKS)
57332       DO 310 IRES=1,NRES
57333       IAPDG=ABS(IDPDG(IRES))
57334 C Do not check (di-)quarks, gauge bosons, higgses or special particles
57335       IF ((IAPDG.GE.1.AND.IAPDG.LE.9).OR.
57336      &    (MOD(IAPDG/10,10).EQ.0.AND.MOD(IAPDG/1000,10).NE.0).OR.
57337      &    (IAPDG.GE.21.AND.IAPDG.LE.26).OR.
57338      &    IAPDG.EQ.32.OR.
57339      &    (IAPDG.GE.35.AND.IAPDG.LE.37).OR.
57340      &    IAPDG.EQ.91.OR.
57341      &    IAPDG.EQ.98.OR.IAPDG.EQ.99) THEN
57342         GOTO 310
57343 C Ignore top hadrons if top decays
57344       ELSEIF(TOPDKS.AND.((IRES.GE.232.AND.IRES.LE.244).OR.
57345      &                   (IRES.GE.255.AND.IRES.LE.264))) THEN
57346         GOTO 310
57347 C Ignore particles not produced in cluster or particle decays
57348       ELSEIF(VTOCDK(IRES).AND.VTORDK(IRES)) THEN
57349         GOTO 310
57350 C Ignore B's if EURO or CLEO decay package used
57351       ELSEIF(((IRES.GE.221.AND.IRES.LE.223).OR.
57352      &        (IRES.GE.245.AND.IRES.LE.247)).AND.BDECAY.NE.'HERW') THEN
57353         WRITE(6,320) BDECAY,RNAME(IRES)
57354 C Check decay modes exist for massive, short lived particles
57355       ELSEIF (NMODES(IRES).EQ.0.AND.RMASS(IRES).NE.ZERO.AND.
57356      &        RLTIM(IRES).LT.PLTCUT) THEN
57357         IF (VTOCDK(IRES)) THEN
57358           CVETO(1)='VETOED '
57359         ELSE
57360           CVETO(1)='ALLOWED'
57361         ENDIF
57362         IF (VTORDK(IRES)) THEN
57363           CVETO(2)='VETOED '
57364         ELSE
57365           CVETO(2)='ALLOWED'
57366         ENDIF
57367         WRITE(6,330) RNAME(IRES),CVETO(1),CVETO(2)
57368 C ignore particles with no modes if massless or long lived
57369       ELSEIF (NMODES(IRES).EQ.0.AND.
57370      &        (RMASS(IRES).EQ.ZERO.OR.RLTIM(IRES).GT.PLTCUT)) THEN
57371         GOTO 310
57372       ELSEIF (IDPDG(IRES).LT.0) THEN
57373 C Antiparticle: check decays are charge conjugates of particle decays
57374         CALL HWUIDT(1,-IDPDG(IRES),IPART,CDUM)
57375         IF (NMODES(IPART).EQ.0) THEN
57376 C Nothing to compare to
57377           WRITE(6,340) RNAME(IPART),RNAME(IRES)
57378         ELSE
57379 C First initialize particle matching array
57380           DO 230 I=1,NMODES(IPART)
57381   230     PMATCH(I)=.FALSE.
57382 C Loop through antiparticle decay modes
57383           LR=LSTRT(IRES)
57384           DO 290 I=1,NMODES(IRES)
57385 C Search for conjugate mode allowing for different particle order
57386           LP=LSTRT(IPART)
57387           DO 270 J=1,NMODES(IPART)
57388           IF (PMATCH(J)) GOTO 270
57389           DO 240 K=1,5
57390   240     MATCH(K)=.FALSE.
57391           DO 260 K=1,5
57392           KPRDLR=HWUANT(IDKPRD(K,LR))
57393           DO 250 L=1,5
57394           IF (.NOT.MATCH(L).AND.KPRDLR.EQ.IDKPRD(L,LP) ) THEN
57395             MATCH(L)=.TRUE.
57396             GOTO 260
57397           ENDIF
57398   250     CONTINUE
57399   260     CONTINUE
57400           IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
57401      &        MATCH(4).AND.MATCH(5)) GOTO 280
57402   270     LP=LNEXT(LP)
57403 C No match found
57404           WRITE(6,350) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5)
57405           GOTO 290
57406 C Match found, check branching ratios and matrix element codes
57407   280     PMATCH(J)=.TRUE.
57408           IF (BRFRAC(LR).NE.BRFRAC(LP))
57409      &     WRITE(6,360) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
57410      &                  BRFRAC(LR),BRFRAC(LP)
57411           IF (NME(LR).NE.NME(LP))
57412      &     WRITE(6,370) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
57413      &                  NME(LR),NME(LP)
57414   290     LR=LNEXT(LR)
57415 C Check for unmatched modes of particle conjugate to antiparticle
57416           LP=LSTRT(IPART)
57417           DO 300 I=1,NMODES(IPART)
57418           IF (.NOT.PMATCH(I))
57419      &     WRITE(6,350) LP,RNAME(IPART),(RNAME(IDKPRD(J,LP)),J=1,5)
57420   300     LP=LNEXT(LP)
57421         ENDIF
57422       ENDIF
57423   310 CONTINUE
57424   320 FORMAT(1X,A8,' decay package to be used for particle ',A8)
57425   330 FORMAT(1X,'No decay modes available for particle ',A8/
57426      & 1X,'Production in cluster decays ',A7,' and particle decays ',A7)
57427   340 FORMAT(1X,A8,' has no modes conjugate to those of ',A8)
57428   350 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
57429      &       1X,'A charge conjugate decay mode does not exist')
57430   360 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
57431      &       1X,'BR ',F5.3,' unequal to that of conjugate mode ',F5.3)
57432   370 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
57433      &       1X,'ME code ',I3,' unequal to that of conjugate mode ',I3)
57434   999 RETURN
57435       END
57436 CDECK  ID>, HWUDPR.
57437 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
57438 *-- Author :    Ian Knowles, Bryan Webber & Kosuke Odagiri
57439 C-----------------------------------------------------------------------
57440       SUBROUTINE HWUDPR
57441 C-----------------------------------------------------------------------
57442 C     Prints out particle properies/decay tables in a number of formats:
57443 C     If (PRNDEF) ASCII to stout
57444 C     If (PRNTEX) LaTeX to the file HW_decays.tex
57445 C                 Paper size and offsets as set in HWUEPR
57446 C                 Uses the package longtable.sty
57447 C                 Designed to be printed as landscape
57448 C     If (PRNWEB) HTML  to the file HW_decays/index.html
57449 C                                            /PART0000001.html etc.
57450 C-----------------------------------------------------------------------
57451       INCLUDE 'HERWIG65.INC'
57452       INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,IUNITT,IUNTW1,IUNTW2,I,NM,J,K,
57453      & L,M
57454       CHARACTER*1  Z
57455       CHARACTER*2  ZZ,ACHRG
57456       CHARACTER*3  ASPIN(0:10)
57457       CHARACTER*6  BGCOLS(5),TBCOLS(3)
57458       CHARACTER*7  HWUNST,TMPNME
57459       CHARACTER*17 FNAMEP
57460       CHARACTER*33 FNAMEW
57461       COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
57462       EXTERNAL HWUNST
57463       DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
57464       DATA TBCOLS/'ccccff','9966ff','ffff00'/
57465       DATA ASPIN/' 0 ','1/2',' 1 ','3/2',' 2 ','5/2',' 3 ','7/2',
57466      &           ' 4 ','9/2',' 5 '/
57467 C
57468       Z=CHAR(92)
57469       ZZ=Z//Z
57470 C
57471       IUNITT=50
57472       IUNTW1=51
57473       IUNTW2=52
57474 C Open and write out file header information for index file
57475       IF (PRNDEF) THEN
57476         IF (NPRFMT.LE.1) THEN
57477           WRITE (6,10) NRES
57478         ELSE
57479           WRITE (6,20) NRES
57480         END IF
57481       END IF
57482       IF (PRNTEX) THEN
57483         OPEN(IUNITT,STATUS='UNKNOWN',FILE='HW_decays.tex')
57484         IF (NPRFMT.LE.1) THEN
57485           WRITE(IUNITT,30) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,
57486      &     Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,ZZ,Z,Z
57487         ELSE
57488           WRITE(IUNITT,40) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMHOFF,Z,MMVOFF,
57489      &     Z,Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,Z,ZZ,Z,Z
57490         END IF
57491       ENDIF
57492       IF (PRNWEB) THEN
57493         OPEN(IUNTW1,STATUS='UNKNOWN',FILE='HW_decays/index.html')
57494         WRITE(IUNTW1,50) BGCOLS,TBCOLS,NRES,((TBCOLS(I),I=2,3),J=1,7)
57495       ENDIF
57496    10 FORMAT(1H1//15X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'/)
57497    20 FORMAT(1H1//30X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'//
57498      & 5X,'Name        IDPDG   Mass   Chg Spn Lifetime Modes ',
57499      & ' Branching fractions ME codes and decay products')
57500    30 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
57501      & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
57502      & A1,'hoffset   ',I4,'mm ',A1,'voffset    ',I4,'mm'/
57503      & A1,'pagestyle{empty}'/A1,'begin{document}'/
57504      & A1,'begin{center}'/A1,'begin{longtable}{|r|c|r|r|r|r|r|r|}'/
57505      & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
57506      & '& Lifetime & Modes ',A2/A1,'hline'/
57507      & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
57508      & A1,'multicolumn{8}{|c|}{HERWIG 6.5: Table of properties',
57509      & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
57510      & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
57511      & 'Lifetime & Modes ',A2/A1,'hline'/A1,'endfirsthead')
57512    40 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
57513      & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
57514      & A1,'hoffset   ',I4,'mm ',A1,'voffset    ',I4,'mm'/
57515      & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}'/
57516      & A1,'begin{longtable}{|r|c|r|r|r|r|r|r|c|r|ccccc|}'/
57517      & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
57518      & '& Lifetime & Modes & B.R. & M.E. & ' /
57519      & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
57520      & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
57521      & A1,'multicolumn{15}{|c|}{HERWIG 6.5: Table of properties',
57522      & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
57523      & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
57524      & 'Lifetime & Modes & B.R. & M.E. & '/
57525      & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
57526      & A1,'endfirsthead')
57527    50 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
57528      & '<TITLE>HERWIG 6.5 Particle Properties</TITLE>'/'</HEAD>'/
57529      & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
57530      & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>'/
57531      & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>',
57532      & '<TR>'/'<TH COLSPAN=8 BGCOLOR=#',A6,' ALIGN="CENTER">',
57533      & '<A HREF=="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
57534      & 'HERWIG 6.5:</A><FONT COLOR=#',A6,'> Table of properties of',
57535      & ' the ',I3,' particles used</FONT></TH>'/'<TR>'/'<TH></TH>'/
57536      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
57537      & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,'>',
57538      & 'Id PDG</FONT></TH>'/
57539      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
57540      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
57541      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
57542      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
57543      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
57544      & '</TR>')
57545 C Loop through resonances
57546       DO 260 I=1,NRES
57547 C Skip particles that can't be produced or blank lines
57548       IF ((VTOCDK(I).AND.VTORDK(I)).OR.
57549      &    (RNAME(I).EQ.'        ')) GOTO 260
57550 C Open and write out header information for particle file
57551       IF (PRNWEB) THEN
57552         TMPNME = HWUNST(I)
57553         WRITE(FNAMEP,'(A5,A7,A5)') 'PART_',TMPNME,'.html'
57554         WRITE(FNAMEW,'(A,A17)') 'HW_decays/',FNAMEP
57555         OPEN(IUNTW2,STATUS='UNKNOWN',FILE=FNAMEW)
57556         WRITE(IUNTW2,60) RNAME(I),BGCOLS
57557         WRITE(IUNTW2,70) TBCOLS,((TBCOLS(L),L=2,3),M=1,6)
57558       ENDIF
57559    60 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
57560      & '<TITLE>HERWIG 6.5: ',A8,' properties</TITLE>'/'</HEAD>'/
57561      & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
57562      & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>')
57563    70 FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
57564      & '<TR>'/'<TH></TH>'/
57565      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
57566      & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,
57567      & '>Id PDG</FONT></TH>'/
57568      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
57569      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
57570      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
57571      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
57572      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
57573      & '</TR>')
57574 C Trick to output charge in fractions for di/s - quarks
57575       IF ((I.GE.  1.AND.I.LE. 12).OR.(I.GE.109.AND.I.LE.120).OR.
57576      &    (I.GE.209.AND.I.LE.218).OR.(I.GE.401.AND.I.LE.424)) THEN
57577         ACHRG='/3'
57578       ELSE
57579         ACHRG='  '
57580       ENDIF
57581 C Write out special particles with no decay modes
57582       IF (NMODES(I).EQ.0) THEN
57583         IF (PRNDEF) THEN
57584           IF (NPRFMT.LE.1) THEN
57585             WRITE(6,80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
57586      &                  ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
57587           ELSE
57588             WRITE(6,90) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
57589      &                  ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
57590           ENDIF
57591         ENDIF
57592 C Add particle to LaTeX file
57593         IF (PRNTEX) THEN
57594           IF (NPRFMT.LE.1) THEN
57595             WRITE(IUNITT,100) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
57596      &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,ZZ
57597           ELSE
57598             WRITE(IUNITT,110) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
57599      &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,Z,ZZ
57600           ENDIF
57601         ENDIF
57602         IF (PRNWEB) THEN
57603 C Add properties to Web index
57604           WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
57605      &                      IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
57606      &                      ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
57607 C Add properties to Web particle file
57608           WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),
57609      &                      IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
57610      &                      ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
57611         ENDIF
57612    80   FORMAT(/1X,I3,1X,A8,' IDPDG=',I8,', M=',F8.3,', Q=',I2,',  J=',
57613      &   A3,', T=',1P,E9.3,',',I3,' Modes')
57614    90   FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3)
57615   100   FORMAT(A1,'hline',I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,
57616      &   A2,'$ & ',A3,' & $',1P,E9.3,'$ & ',I3,' ',A2)
57617   110   FORMAT(A1,'cline{1-8}'/
57618      &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',A3,
57619      &   ' & $',1P,E9.3,'$ & ',I3,' & ',A1,'multicolumn{7}{|c|}{} ',A2)
57620   120   FORMAT('<TR>'/
57621      &   '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
57622      &   '</FONT></TD>'/
57623      &   '<TD ALIGN="CENTER"><A HREF="',A17,'">',A37,'</A></TD>'/
57624      &   '<TD ALIGN="RIGHT">',I8,'</TD>'/
57625      &   '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
57626      &   '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
57627      &   '<TD ALIGN="RIGHT">',A3,'</TD>'/
57628      &   '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
57629      &   '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>')
57630   130   FORMAT('<TR>'/
57631      &   '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
57632      &   '</FONT></TD>'/
57633      &   '<TD ALIGN="CENTER">',A37,'</TD>'/
57634      &   '<TD ALIGN="RIGHT">',I8,'</TD>'/
57635      &   '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
57636      &   '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
57637      &   '<TD ALIGN="RIGHT">',A3,'</TD>'/
57638      &   '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
57639      &   '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>'/'</TABLE>'/'<P>')
57640       ELSE
57641 C Particle with decay modes
57642         IF (RSTAB(I)) THEN
57643           NM=0
57644         ELSEIF (VTOCDK(I)) THEN
57645           NM=-NMODES(I)
57646         ELSE
57647           NM=NMODES(I)
57648         ENDIF
57649         K=LSTRT(I)
57650 C Write out properties and first decay mode
57651         IF (PRNDEF) THEN
57652           IF (NPRFMT.LE.1) THEN
57653             WRITE(6, 80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
57654      &       ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
57655             WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
57656           ELSE
57657             WRITE(6,150) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
57658      &       ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,BRFRAC(K),NME(K),
57659      &       (RNAME(IDKPRD(L,K)),L=1,5)
57660           ENDIF
57661         ENDIF
57662         IF (PRNTEX) THEN
57663           IF (NPRFMT.LE.1) THEN
57664             WRITE(IUNITT,160) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
57665      &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,ZZ,Z
57666             WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
57667      &       BRFRAC(K),Z,NME(K),ZZ
57668           ELSE
57669             WRITE(IUNITT,180) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
57670      &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,
57671      &       BRFRAC(K),NME(K),(TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ,Z
57672           ENDIF
57673         END IF
57674         IF (PRNWEB) THEN
57675 C Add properties to index
57676           WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
57677      &     IDPDG(I),RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),
57678      &     RLTIM(I),NM
57679 C Add properties to Web particle file
57680           WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),IDPDG(I),
57681      &     RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
57682           WRITE(IUNTW2,190) TBCOLS,TXNAME(2,I),
57683      &     ((TBCOLS(L),L=2,3),M=1,3)
57684           WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),1,BRFRAC(K),NME(K),
57685      &     (TXNAME(2,IDKPRD(L,K)),L=1,5)
57686         ENDIF
57687   140   FORMAT(5X,'BR[ -->',5(1X,A8),']=',F5.3,', ME code',I5)
57688   150   FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3,
57689      &   2X,F5.3,1X,I3,5(1X,A8))
57690   160   FORMAT(A1,'hline',
57691      &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
57692      &   A3,' & $',1P,E9.3,'$ & ',I3,' ',A2/A1,'cline{2-8}')
57693   170   FORMAT(' & & ',A1,'multicolumn{2}{l}{$',A1,'longrightarrow$'/
57694      &   5(A37,' '),'}'/' & ',A1,'multicolumn{2}{l}{BR = ',F5.3,'} & ',
57695      &   A1,'multicolumn{2}{l|}{ME code = ',I3,'} ',A2)
57696   180   FORMAT(A1,'hline'/
57697      &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
57698      &   A3,' & $',1P,E9.3,'$ & ',I3,' & ',F5.3,' & ',I3,
57699      &   5(' & ',A37), ' ',A2/A1,'cline{2-8}')
57700   190   FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/'<TR>'/
57701      &   '<TH COLSPAN=8 BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',A37,
57702      &   ' Decay Modes</FONT></TH>'/'</TR>'/'<TR>'/'<TH></TH>',
57703      &   '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>B.R.</FONT></TH>'/
57704      &   '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>M.E.</FONT></TH>'/
57705      &   '<TH BGCOLOR=#',A6,' ALIGN="CENTER" COLSPAN=5>',
57706      &   '<FONT COLOR=#',A6,'>Decay products</FONT></TH>'/'</TR>')
57707   200   FORMAT('<TR>'/
57708      &   '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',
57709      &   I3,'</FONT></TD>'/
57710      &   '<TD ALIGN="RIGHT">',F5.3,'</TD>'/
57711      &   '<TD ALIGN="RIGHT">',I3,'</TD>'/
57712      &   5('<TD ALIGN="CENTER">',A37,'</TD>'/),'</TR>')
57713 C Write out additional decay modes
57714         IF (NMODES(I).GE.2) THEN
57715           DO 210 J=2,NMODES(I)
57716           K=LNEXT(K)
57717           IF (PRNDEF) THEN
57718             IF (NPRFMT.LE.1) THEN
57719               WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
57720             ELSE
57721               WRITE(6,220) BRFRAC(K),NME(K),(RNAME(IDKPRD(L,K)),L=1,5)
57722             END IF
57723           END IF
57724           IF (PRNTEX) THEN
57725             IF (NPRFMT.LE.1) THEN
57726               WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
57727      &         BRFRAC(K),Z,NME(K),ZZ
57728             ELSE
57729               WRITE(IUNITT,230) Z,BRFRAC(K),NME(K),
57730      &         (TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ
57731             ENDIF
57732           ENDIF
57733           IF (PRNWEB) WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),J,
57734      &     BRFRAC(K),NME(K),(TXNAME(2,IDKPRD(L,K)),L=1,5)
57735   210     CONTINUE
57736           IF (PRNTEX.AND.NPRFMT.EQ.2.AND.NMODES(I+1).EQ.0)
57737      &     WRITE(IUNITT,240) Z
57738   220     FORMAT(54X,F5.3,1X,I3,5(1X,A8))
57739   230     FORMAT(' & ',A1,'multicolumn{7}{|c|}{} & ',F5.3,' & ',I3,
57740      &     5(' & ',A37),' ',A2)
57741   240     FORMAT(A1,'hline')
57742         ENDIF
57743       ENDIF
57744 C Close Web particle file
57745       IF (PRNWEB) THEN
57746         WRITE(IUNTW2,250)
57747         CLOSE(IUNTW2)
57748       ENDIF
57749   250 FORMAT('</TABLE>'/'</CENTER>'/'<P>'/
57750      & 'Main particle <A HREF="index.html">index</A>'/
57751      & '</BODY>'/'</HTML>')
57752   260 CONTINUE
57753 C Close the LaTeX file
57754       IF (PRNTEX) THEN
57755         WRITE(IUNITT,270) Z,Z,Z
57756         CLOSE(IUNITT)
57757       ENDIF
57758 C Close the index file
57759       IF (PRNWEB) THEN
57760         WRITE(IUNTW1,280)
57761         CLOSE(IUNTW1)
57762       ENDIF
57763   270 FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
57764   280 FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
57765       RETURN
57766       END
57767 CDECK  ID>, HWUECM.
57768 *CMZ :-        -29/01/93  11.11.55  by  Bryan Webber
57769 *-- Author :    Giovanni Abbiendi & Luca Stanco
57770 C---------------------------------------------------------------------
57771       FUNCTION HWUECM (S,M1QUAD,M2QUAD)
57772 C-----------------------------------------------------------------------
57773 C     C.M. ENERGY OF A PARTICLE IN 1-->2 BRANCH, MAY BE SPACELIKE
57774 C---------------------------------------------------------------------
57775       DOUBLE PRECISION HWUECM,S,M1QUAD,M2QUAD
57776       HWUECM = (S+M1QUAD-M2QUAD)/(2.D0*SQRT(S))
57777       END
57778 CDECK  ID>, HWUEDT.
57779 *CMZ :-        -09/12/91  12.07.08  by  Mike Seymour
57780 *-- Author :    Mike Seymour
57781 C-----------------------------------------------------------------------
57782       SUBROUTINE HWUEDT(N,IEDT)
57783 C-----------------------------------------------------------------------
57784 C     EDIT THE EVENT RECORD
57785 C     IF N>0 DELETE THE N ENTRIES IN IEDT FROM EVENT RECORD
57786 C     IF N<0 INSERT LINES AFTER THE -N ENTRIES IN IEDT
57787 C-----------------------------------------------------------------------
57788       INCLUDE 'HERWIG65.INC'
57789       INTEGER N,IEDT(*),IMAP(0:NMXHEP),IHEP,I,J,I1,I2
57790       COMMON /HWUMAP/IMAP
57791 C---MOVE ENTRIES AND CALCULATE MAPPING OF POINTERS
57792       IF (N.EQ.0) THEN
57793         RETURN
57794       ELSEIF (N.GT.0) THEN
57795         I=1
57796         I1=1
57797         I2=NHEP
57798       ELSE
57799         I=NHEP-N
57800         I1=NHEP
57801         I2=1
57802       ENDIF
57803       DO 110 IHEP=I1,I2,SIGN(1,I2-I1)
57804         IMAP(IHEP)=I
57805         DO 100 J=1,ABS(N)
57806           IF (IHEP.EQ.IEDT(J)) THEN
57807             IF (N.GT.0) IMAP(IHEP)=0
57808             I=I-1
57809             IF (N.LT.0) IMAP(IHEP)=I
57810           ENDIF
57811  100    CONTINUE
57812         IF (IMAP(IHEP).EQ.I .AND. IHEP.NE.I) THEN
57813           ISTHEP(I)=ISTHEP(IHEP)
57814           IDHW(I)=IDHW(IHEP)
57815           IDHEP(I)=IDHEP(IHEP)
57816           JMOHEP(1,I)=JMOHEP(1,IHEP)
57817           JMOHEP(2,I)=JMOHEP(2,IHEP)
57818           JDAHEP(1,I)=JDAHEP(1,IHEP)
57819           JDAHEP(2,I)=JDAHEP(2,IHEP)
57820           CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,I))
57821           CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
57822           ISTHEP(IHEP)=0
57823           IDHW(IHEP)=20
57824           IDHEP(IHEP)=0
57825           JMOHEP(1,IHEP)=0
57826           JMOHEP(2,IHEP)=0
57827           JDAHEP(1,IHEP)=0
57828           JDAHEP(2,IHEP)=0
57829           CALL HWVZRO(5,PHEP(1,IHEP))
57830           CALL HWVZRO(4,VHEP(1,IHEP))
57831         ENDIF
57832         I=I+SIGN(1,N)
57833  110  CONTINUE
57834       NHEP=NHEP-N
57835 C---RELABEL POINTERS, SETTING ANY WHICH WERE TO DELETED ENTRIES TO ZERO
57836       IMAP(0)=0
57837       DO 200 IHEP=1,NHEP
57838         JMOHEP(1,IHEP)=IMAP(JMOHEP(1,IHEP))
57839         JMOHEP(2,IHEP)=IMAP(JMOHEP(2,IHEP))
57840         JDAHEP(1,IHEP)=IMAP(JDAHEP(1,IHEP))
57841         JDAHEP(2,IHEP)=IMAP(JDAHEP(2,IHEP))
57842  200  CONTINUE
57843       END
57844 CDECK  ID>, HWUEEC.
57845 *CMZ :-        -26/04/91  14.22.30  by  Federico Carminati
57846 *-- Author :    Bryan Webber and Ian Knowles
57847 C-----------------------------------------------------------------------
57848       SUBROUTINE HWUEEC(IL)
57849 C-----------------------------------------------------------------------
57850 C     Loads cross-section coefficients, for kinematically open channels,
57851 C     in llbar-->qqbar; lepton label IL=1-6: e,nu_e,mu,nu_mu,tau,nu_tau.
57852 C-----------------------------------------------------------------------
57853       INCLUDE 'HERWIG65.INC'
57854       DOUBLE PRECISION Q2
57855       INTEGER IL,JL,IQ
57856       Q2=EMSCA**2
57857       JL=IL+10
57858       MAXFL=0
57859       TQWT=0.
57860       DO 10 IQ=1,NFLAV
57861       IF (EMSCA.GT.2.*RMASS(IQ)) THEN
57862          MAXFL=MAXFL+1
57863          MAPQ(MAXFL)=IQ
57864          CALL HWUCFF(JL,IQ,Q2,CLQ(1,MAXFL))
57865          TQWT=TQWT+CLQ(1,MAXFL)
57866       ENDIF
57867   10  CONTINUE
57868       IF (MAXFL.EQ.0) CALL HWWARN('HWUEEC',100,*999)
57869   999 END
57870 CDECK  ID>, HWUEMV.
57871 *CMZ :-        -30/06/94  19.31.08  by  Mike Seymour
57872 *-- Author :    Mike Seymour
57873 C-----------------------------------------------------------------------
57874       SUBROUTINE HWUEMV(N,IFROM,ITO)
57875 C-----------------------------------------------------------------------
57876 C     MOVE A BLOCK OF ENTRIES IN THE EVENT RECORD
57877 C     N ENTRIES IN HEPEVT STARTING AT IFROM ARE MOVED TO AFTER ITO
57878 C-----------------------------------------------------------------------
57879       INCLUDE 'HERWIG65.INC'
57880       INTEGER N,IFROM,ITO,IMAP(0:NMXHEP),LFROM,LTO,I,IEDT(NMXHEP),IHEP,
57881      $ JHEP,KHEP
57882       COMMON /HWUMAP/IMAP
57883       LFROM=IFROM
57884       LTO=ITO
57885       DO 100 I=1,N
57886  100  IEDT(I)=LTO
57887       CALL HWUEDT(-N,IEDT)
57888       DO 300 I=1,N
57889         IHEP=LTO+I
57890         JHEP=IMAP(LFROM+I-1)
57891         ISTHEP(IHEP)=ISTHEP(JHEP)
57892         IDHW(IHEP)=IDHW(JHEP)
57893         IDHEP(IHEP)=IDHEP(JHEP)
57894         JMOHEP(1,IHEP)=JMOHEP(1,JHEP)
57895         JMOHEP(2,IHEP)=JMOHEP(2,JHEP)
57896         JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
57897         JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
57898         CALL HWVEQU(5,PHEP(1,JHEP),PHEP(1,IHEP))
57899         CALL HWVEQU(4,VHEP(1,JHEP),VHEP(1,IHEP))
57900         DO 200 KHEP=1,NHEP
57901           IF (JMOHEP(1,KHEP).EQ.JHEP) JMOHEP(1,KHEP)=IHEP
57902           IF (JMOHEP(2,KHEP).EQ.JHEP) JMOHEP(2,KHEP)=IHEP
57903           IF (JDAHEP(1,KHEP).EQ.JHEP) JDAHEP(1,KHEP)=IHEP
57904           IF (JDAHEP(2,KHEP).EQ.JHEP) JDAHEP(2,KHEP)=IHEP
57905  200    CONTINUE
57906         IEDT(I)=JHEP
57907  300  CONTINUE
57908       CALL HWUEDT(N,IEDT)
57909  999  END
57910 CDECK  ID>, HWUEPR.
57911 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
57912 *-- Author :    Ian Knowles, Bryan Webber & Kosuke Odagiri
57913 C-----------------------------------------------------------------------
57914       SUBROUTINE HWUEPR
57915 C-----------------------------------------------------------------------
57916 C     Prints out event data in a number of possible formats:
57917 C     If (PRNDEF) ASCII to stout
57918 C     If (PRNTEX) LaTeX to the file HWEV_*******.tex
57919 C                 Please check paper size and offsets given in mm
57920 C                 Uses the package longtable.sty
57921 C                 If (PRVTX>OR.NPRFMT.EQ.2) designed to be printed
57922 C                 as landscape
57923 C     If (PRNWEB) HTML  to the file HWEV_*******.html
57924 C                 Call HWUDPR to create particle property files in
57925 C                 the subdirectory HW_decays/
57926 C     ******* gives the event number 0000001 etc.
57927 C-----------------------------------------------------------------------
57928       INCLUDE 'HERWIG65.INC'
57929       INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,I,IST,IS,ID,MS,J,K,IUNITW,
57930      & IUNITT
57931       CHARACTER*1 Z
57932       CHARACTER*2 ZZ
57933       CHARACTER*6 BGCOLS(5),TBCOLS(3),THEAD(17,3)
57934       CHARACTER*7 HWUNST,TMPNME
57935       CHARACTER*16 FNAMET
57936       CHARACTER*17 FNAMEW
57937       CHARACTER*27 FNAMEP
57938       CHARACTER*28 TITLE(11),SECTXT
57939       LOGICAL FIRST(11),NEWSEC
57940       COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
57941       EXTERNAL HWUNST
57942 C
57943       DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
57944       DATA TBCOLS/'ccccff','9966ff','ffff00'/
57945       DATA THEAD/ 17*'9966ff',17*'ffff00',
57946      &            'IHEP  ','  ID  ',' IDPDG',' IST  ',' MO1  ',' MO2  ',
57947      &            ' DA1  ',' DA2  ',' P-X  ',' P-Y  ',' P-Z  ','ENERGY',
57948      &            ' MASS ',' V-X  ',' V-Y  ',' V-Z  ',' V-C*T'/
57949       DATA TITLE/'     ---INITIAL STATE---    ',
57950      &           '    ---HARD SUBPROCESS---   ',
57951      &           '    ---PARTON SHOWERS---    ',
57952      &           '    ---GLUON SPLITTING---   ',
57953      &           '   ---CLUSTER FORMATION---  ',
57954      &           '    ---CLUSTER DECAYS---    ',
57955      &           ' ---STRONG HADRON DECAYS--- ',
57956      &           ' ---HEAVY PARTICLE DECAYS---',
57957      &           '  ---H/W/Z BOSON DECAYS---  ',
57958      &           ' ---SOFT UNDERLYING EVENT---',
57959      &           '  ---MULTIPLE SCATTERING--- '/
57960       Z=CHAR(92)
57961       ZZ=Z//Z
57962 C
57963       IUNITT=50
57964       IUNITW=51
57965 C Write out any required file header information
57966       TMPNME=HWUNST(NEVHEP)
57967       IF (PRNTEX) THEN
57968         WRITE(FNAMET,'(A5,A7,A4)') 'HWEV_',TMPNME,'.tex'
57969         OPEN(IUNITT,STATUS='UNKNOWN',FILE=FNAMET)
57970         IF (PRVTX.OR.NPRFMT.EQ.2) THEN
57971           WRITE(IUNITT,10) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMVOFF,Z,MMHOFF,Z,Z,Z
57972         ELSE
57973           WRITE(IUNITT,10) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,Z,Z,Z
57974         ENDIF
57975       ENDIF
57976       IF (PRNWEB) THEN
57977         WRITE(FNAMEW,'(A5,A7,A5)') 'HWEV_',TMPNME,'.html'
57978         OPEN(IUNITW,STATUS='UNKNOWN',FILE=FNAMEW)
57979         WRITE(IUNITW,20) BGCOLS
57980       ENDIF
57981    10 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
57982      & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
57983      & A1,'hoffset   ',I4,'mm ',A1,'voffset    ',I4,'mm'/
57984      & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}')
57985    20 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
57986      & '<TITLE>HERWIG Event Record</TITLE>'/'</HEAD>'/
57987      & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
57988      & ' ALINK=#',A6,' VLINK=#',A6,'>')
57989 C Write out event header details and set up tables
57990       IF (PRNDEF) THEN
57991         WRITE(6,30) NEVHEP,PBEAM1,PART1,PBEAM2,PART2,
57992      &   IPROC,NRN,ISTAT,IERROR,EVWGT
57993       ENDIF
57994       IF (PRNTEX) THEN
57995         WRITE(IUNITT,40) Z,Z,Z,ISTAT,ZZ,Z,
57996      &   IPROC,PBEAM1,PBEAM2,NRN(1),
57997      &   IERROR,ZZ,Z,Z,NEVHEP,TXNAME(1,IDHW(1)),TXNAME(1,IDHW(2)),
57998      &   NRN(2),EVWGT,ZZ,Z,Z,Z
57999         IF (PRVTX) THEN
58000           WRITE(IUNITT,50) Z,Z,Z,Z,Z
58001         ELSE
58002           WRITE(IUNITT,60) Z,Z,Z,Z,Z
58003         ENDIF
58004       ENDIF
58005       IF (PRNWEB) THEN
58006         WRITE(IUNITW,70) TBCOLS(1),TBCOLS(2),(TBCOLS(2),TBCOLS(3),
58007      &   I=1,4),ISTAT,TBCOLS(2),TBCOLS(3),
58008      &   IPROC,PBEAM1,PBEAM2,NRN(1),
58009      &   TBCOLS(2),TBCOLS(3),IERROR
58010         WRITE(IUNITW,71) TBCOLS(2),TBCOLS(3),NEVHEP,TXNAME(2,IDHW(1)),
58011      &   TXNAME(2,IDHW(2)),NRN(2),TBCOLS(2),TBCOLS(3),EVWGT,TBCOLS(1)
58012       ENDIF
58013    30 FORMAT(///1X,'EVENT ',I7,':',F8.2,' GEV/C ',A8,' ON ',F8.2,
58014      & ' GEV/C ',A8,' PROCESS:',I6/1X,'SEEDS: ',I11,' & ',I11,
58015      & '   STATUS: ',I4,' ERROR:',I4,'  WEIGHT: ',1P,E11.4/)
58016    40 FORMAT(A1,'begin{tabular}{|l|r|c|c|r|l|c|}'/A1,'hline'/
58017      & A1,'multicolumn{2}{|c|}{HERWIG 6.5} & Beam 1: & Beam 2: & ',
58018      & 'Seeds: & Status: & ',I4, ' ',A2/A1,'hline'/'Process: & ',I6,
58019      & ' & ',F8.2,'~GeV/c & ',F8.2,'~GeV/c',' & ',I11,' & Error: & ',
58020      & I4,' ',A2/A1,'cline{1-2} ',A1,'cline{6-7}'/'Event: & ',I7,' & ',
58021      & A37,' & ',A37,' & ',I11,' & Weight: & ',1P,E11.4,' ',A2/A1,
58022      & 'hline'/A1,'end{tabular}'/A1,'vskip 5mm')
58023    50 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|r|r|r|r|}'/
58024      & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
58025    60 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|}'/
58026      & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
58027    70 FORMAT(/'<CENTER>'/'<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
58028      & '<TR>'/'<TH BGCOLOR=#',A6,' COLSPAN=2>',
58029      & '<A HREF="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
58030      & 'HERWIG 6.5</A></TH>'/
58031      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 1:</FONT></TH>'/
58032      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 2:</FONT></TH>'/
58033      & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Seeds:</FONT></TH>'/
58034      & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
58035      & '>Status:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>'/
58036      & '<TR>'/
58037      & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
58038      & '>Process:</Th>'/'<TD>',I6,'</TD>'/
58039      & '<TD>',F8.2,' GeV/c</TD>'/'<TD>',F8.2,' GeV/c</TD>'/
58040      & '<TD ALIGN="RIGHT">',I11,'</TD>'/
58041      & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
58042      & '>Error:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>')
58043    71 FORMAT('<TR>'/
58044      & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
58045      & '>Event:</Th>'/'<TD ALIGN="RIGHT">',I7,'</TD>'/
58046      & '<TD ALIGN="CENTER">',A37,'</TD>'/
58047      & '<TD ALIGN="CENTER">',A37,'</TD>'/
58048      & '<TD ALIGN="RIGHT">',I11,'</TD>'/
58049      & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
58050      & '>Weight:</FONT></TH>'/'<TD>',1P,E11.4,'</TD>'/'</TR>'/
58051      & '</TABLE>'//'<P>'/
58052      & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>')
58053 C Initialize control flags
58054       DO 80 I=1,11
58055    80 FIRST(I)=.TRUE.
58056 C Loop through event record
58057       DO 410 I=1,NHEP
58058       NEWSEC=.FALSE.
58059 C First find start of new sections
58060       IST=ISTHEP(I)
58061       IS=IST/10
58062       ID=IDHW(I)
58063       IF (IST.EQ.101) THEN
58064         NEWSEC=.TRUE.
58065         SECTXT=TITLE(1)
58066       ELSEIF (FIRST(2).AND.IS.EQ.12) THEN
58067         NEWSEC=.TRUE.
58068         SECTXT=TITLE(2)
58069         FIRST(2)=.FALSE.
58070       ELSEIF (FIRST(3).AND.IS.EQ.14) THEN
58071         NEWSEC=.TRUE.
58072         SECTXT=TITLE(3)
58073         FIRST(3)=.FALSE.
58074         FIRST(8)=.TRUE.
58075         FIRST(9)=.TRUE.
58076         FIRST(11)=.TRUE.
58077       ELSEIF (FIRST(4).AND.IST.GE.158.AND.IST.NE.160
58078      &                .AND.IST.LE.162) THEN
58079         NEWSEC=.TRUE.
58080         SECTXT=TITLE(4)
58081         FIRST(4)=.FALSE.
58082       ELSEIF (FIRST(5).AND.(IS.EQ.16.OR.IS.EQ.18)
58083      &                .AND.IST.GT.162) THEN
58084         NEWSEC=.TRUE.
58085         SECTXT=TITLE(5)
58086         FIRST(5)=.FALSE.
58087       ELSEIF (IS.EQ.19.OR.IST.EQ.1.OR.IST.EQ.200) THEN
58088         MS=ISTHEP(JMOHEP(1,I))/10
58089         IF (MS.EQ.15.OR.MS.EQ.16.OR.MS.EQ.18) THEN
58090           IF (FIRST(6)) THEN
58091             NEWSEC=.TRUE.
58092             SECTXT=TITLE(6)
58093             FIRST(6)=.FALSE.
58094           ENDIF
58095         ELSEIF (FIRST(7).AND.(.NOT.FIRST(6))) THEN
58096           NEWSEC=.TRUE.
58097           SECTXT=TITLE(7)
58098           FIRST(7)=.FALSE.
58099         ENDIF
58100       ELSEIF (FIRST(8).AND.(IST.EQ.125.OR.IST.EQ.155.OR.
58101      &        (IST.EQ.123.AND.ISTHEP(JMOHEP(1,I)).EQ.199))) THEN
58102         NEWSEC=.TRUE.
58103         SECTXT=TITLE(8)
58104         FIRST(3)=.TRUE.
58105         FIRST(4)=.TRUE.
58106         FIRST(5)=.TRUE.
58107         FIRST(6)=.TRUE.
58108         FIRST(7)=.TRUE.
58109         FIRST(8)=.FALSE.
58110       ELSEIF (FIRST(9).AND.(IST.EQ.123.OR.IST.EQ.124)) THEN
58111         MS=ABS(IDHEP(JMOHEP(1,I)))
58112         IF (MS.EQ.23.OR.MS.EQ.24.OR.MS.EQ.25) THEN
58113           NEWSEC=.TRUE.
58114           SECTXT=TITLE(9)
58115           FIRST(3)=.TRUE.
58116           FIRST(4)=.TRUE.
58117           FIRST(5)=.TRUE.
58118           FIRST(6)=.TRUE.
58119           FIRST(7)=.TRUE.
58120           FIRST(8)=.TRUE.
58121           FIRST(9)=.FALSE.
58122         ENDIF
58123       ELSEIF (IST.EQ.170) THEN
58124         NEWSEC=.TRUE.
58125         SECTXT=TITLE(10)
58126         FIRST(6)=.FALSE.
58127         FIRST(7)=.FALSE.
58128         FIRST(8)=.FALSE.
58129       ELSEIF (FIRST(11).AND.(ID.EQ.71.OR.ID.EQ.72)) THEN
58130         NEWSEC=.TRUE.
58131         SECTXT=TITLE(11)
58132         FIRST(3)=.TRUE.
58133         FIRST(11)=.FALSE.
58134       ENDIF
58135 C Print out section heading
58136       IF (NEWSEC) THEN
58137         IF (PRVTX) THEN
58138           IF (PRNDEF) THEN
58139             IF (NPRFMT.EQ.1) THEN
58140               WRITE(6, 90) SECTXT,(THEAD(J,3),J=1,17)
58141             ELSE
58142               WRITE(6,100) SECTXT,(THEAD(J,3),J=1,17)
58143             ENDIF
58144           ENDIF
58145           IF (PRNTEX) WRITE(IUNITT,110) Z,Z,SECTXT,ZZ,Z,
58146      &     (Z,THEAD(J,3),J=1,17),ZZ,Z
58147           IF (PRNWEB) WRITE(IUNITW,120) TBCOLS(2),TBCOLS(3),
58148      &     SECTXT,((THEAD(K,J),J=1,3),K=1,17)
58149    90     FORMAT(/46X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5,
58150      &     4(4X,A6))
58151   100     FORMAT(/58X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5,
58152      &     4X,A6,2(5X,A6),6X,A6)
58153   110     FORMAT(A1,'hline'/A1,'multicolumn{17}{|c|}{',A28,'} ',A2/A1,
58154      &     'hline'/16(A1,'multicolumn{1}{|c|}{',A6,'} & '),
58155      &     A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
58156   120     FORMAT('<TR><TH COLSPAN=17 BGCOLOR=#',A6,'>',
58157      &     '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
58158      &     '<TR>',17(/,1X,'<TH BGCOLOR=#',A6,'>
58159      &     <FONT COLOR=',A6,'>',A6,'</FONT></TH>'),'</TR>')
58160         ELSE
58161           IF (PRNDEF) THEN
58162             IF (NPRFMT.EQ.1) THEN
58163               WRITE(6,130) SECTXT,(THEAD(J,3),J=1,13)
58164             ELSE
58165               WRITE(6,140) SECTXT,(THEAD(J,3),J=1,13)
58166             ENDIF
58167           END IF
58168           IF (PRNTEX) WRITE(IUNITT,150) Z,Z,SECTXT,ZZ,Z,
58169      &     (Z,THEAD(J,3),J=1,13),ZZ,Z
58170           IF (PRNWEB) WRITE(IUNITW,160) TBCOLS(2),TBCOLS(3),
58171      &     SECTXT,((THEAD(K,J),J=1,3),K=1,13)
58172   130     FORMAT(/26X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5)
58173   140     FORMAT(/36X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5)
58174   150     FORMAT(A1,'hline'/A1,'multicolumn{13}{|c|}{',A28,'} ',A2/A1,
58175      &     'hline'/12(A1,'multicolumn{1}{|c|}{',A6,'} & '),
58176      &     A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
58177   160     FORMAT('<TR><TH COLSPAN=13 BGCOLOR=#',A6,'>',
58178      &     '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
58179      &     '<TR>',13(/'<TH BGCOLOR=#',A6,'>',
58180      &     '<FONT COLOR=#',A6,'>',A6,'</FONT></TH>'),'</TR>')
58181         ENDIF
58182       ENDIF
58183 C Now print out the data line
58184       IF (PRVTX) THEN
58185 C     Include vertex information
58186         IF (PRNDEF) THEN
58187           IF (PRNDEC) THEN
58188             IF (NPRFMT.EQ.1) THEN
58189               WRITE(6,190) I,RNAME(IDHW(I)),IDHEP(I),IST,
58190      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58191      &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58192             ELSE
58193               WRITE(6,200) I,RNAME(IDHW(I)),IDHEP(I),IST,
58194      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58195      &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58196             ENDIF
58197           ELSE
58198             IF (NPRFMT.EQ.1) THEN
58199               WRITE(6,210) I,RNAME(IDHW(I)),IDHEP(I),IST,
58200      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58201      &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58202             ELSE
58203               WRITE(6,220) I,RNAME(IDHW(I)),IDHEP(I),IST,
58204      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58205      &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58206             ENDIF
58207           ENDIF
58208         ENDIF
58209         IF (PRNTEX) WRITE(IUNITT,230) I,TXNAME(1,IDHW(I)),IDHEP(I),
58210      &   IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58211      &   (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4),ZZ
58212         IF (PRNWEB) THEN
58213           WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
58214           IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
58215             WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
58216           ELSE
58217             TMPNME=HWUNST(IDHW(I))
58218             WRITE(FNAMEP,'(A15,A7,A5)')
58219      &       'HW_decays/PART_',TMPNME,'.html'
58220             WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
58221           ENDIF
58222           DO 170 J=1,2
58223             IF (JMOHEP(J,I).NE.0) THEN
58224               WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
58225             ELSE
58226               WRITE(IUNITW,280) JMOHEP(J,I)
58227             ENDIF
58228   170     CONTINUE
58229           DO 180 J=1,2
58230             IF (JDAHEP(J,I).NE.0) THEN
58231               WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
58232             ELSE
58233               WRITE(IUNITW,280) JDAHEP(J,I)
58234             ENDIF
58235   180     CONTINUE
58236           IF (NPRFMT.EQ.1) THEN
58237             WRITE(IUNITW,290) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58238           ELSE
58239             WRITE(IUNITW,300) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
58240           ENDIF
58241         ENDIF
58242   190   FORMAT(1X,I4,1X,A8,I8,5I4,   2F8.2,2F7.1,F8.2,1P,4E10.3)
58243   200   FORMAT(1X,I4,1X,A8,I8,5I4,   5F12.5,1P,4E11.4)
58244   210   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2,1P,4E10.3)
58245   220   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5,1P,4E11.4)
58246   230   FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
58247      &   5(' & $',F8.2,'$'),4(' & $',1P,E11.3,'$'),' ',A2)
58248   240   FORMAT('<TR>'/'<TD BGCOLOR=#',A6,' ALIGN="RIGHT">',
58249      &   '<FONT COLOR=#',A6,'><A NAME="',I4,'">',I4,'</A></FONT></TD>'/)
58250   250   FORMAT('<TD ALIGN="CENTER">',A37,'</TD>'/'<TD ALIGN="RIGHT">',
58251      &   I8,'</TD>'/'<TD ALIGN="RIGHT">',I4,'</TD>')
58252   260   FORMAT('<TD ALIGN="CENTER"><A HREF="',A27,'">',A37,'</A></TD>'/
58253      &   '<TD ALIGN="RIGHT">',I8,'</TD>'/
58254      &   '<TD ALIGN="RIGHT">',I4,'</TD>')
58255   270   FORMAT(/'<TD ALIGN="RIGHT"><A HREF="#',I4,'">',I4,'</A></TD>')
58256   280   FORMAT(/'<TD ALIGN="RIGHT">',I4,'</TD>')
58257   290   FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>'),1P,
58258      &   4(/'<TD ALIGN="RIGHT">',E10.3,'</TD>')/'</TR>')
58259   300   FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>'),1P,
58260      &   4(/'<TD ALIGN="RIGHT">',E11.4,'</TD>')/'</TR>')
58261       ELSE
58262 C     Do not include vertex information
58263         IF (PRNDEF) THEN
58264           IF (PRNDEC) THEN
58265             IF (NPRFMT.EQ.1) THEN
58266               WRITE(6,330) I,RNAME(IDHW(I)),IDHEP(I),IST,
58267      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58268      &         (PHEP(J,I),J=1,5)
58269             ELSE
58270               WRITE(6,340) I,RNAME(IDHW(I)),IDHEP(I),IST,
58271      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58272      &         (PHEP(J,I),J=1,5)
58273             ENDIF
58274           ELSE
58275             IF (NPRFMT.EQ.1) THEN
58276               WRITE(6,350) I,RNAME(IDHW(I)),IDHEP(I),IST,
58277      &          JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58278      &          (PHEP(J,I),J=1,5)
58279             ELSE
58280               WRITE(6,360) I,RNAME(IDHW(I)),IDHEP(I),IST,
58281      &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58282      &         (PHEP(J,I),J=1,5)
58283             ENDIF
58284           ENDIF
58285         ENDIF
58286         IF (PRNTEX) THEN
58287           IF (NPRFMT.EQ.1) THEN
58288             WRITE(IUNITT,370) I,TXNAME(1,IDHW(I)),IDHEP(I),
58289      &       IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58290      &       (PHEP(J,I),J=1,5),ZZ
58291           ELSE
58292             WRITE(IUNITT,380) I,TXNAME(1,IDHW(I)),IDHEP(I),
58293      &       IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
58294      &       (PHEP(J,I),J=1,5),ZZ
58295           ENDIF
58296         ENDIF
58297         IF (PRNWEB) THEN
58298           WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
58299           IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
58300             WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
58301           ELSE
58302             TMPNME = HWUNST(IDHW(I))
58303             WRITE(FNAMEP,'(A15,A7,A5)')
58304      &       'HW_decays/PART_',TMPNME,'.html'
58305             WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
58306           ENDIF
58307           DO 310 J=1,2
58308             IF (JMOHEP(J,I).NE.0) THEN
58309               WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
58310             ELSE
58311               WRITE(IUNITW,280) JMOHEP(J,I)
58312             ENDIF
58313   310     CONTINUE
58314           DO 320 J=1,2
58315             IF (JDAHEP(J,I).NE.0) THEN
58316               WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
58317             ELSE
58318               WRITE(IUNITW,280) JDAHEP(J,I)
58319             ENDIF
58320   320     CONTINUE
58321           IF (NPRFMT.EQ.1) THEN
58322             WRITE(IUNITW,390) (PHEP(J,I),J=1,5)
58323           ELSE
58324             WRITE(IUNITW,400) (PHEP(J,I),J=1,5)
58325           ENDIF
58326         ENDIF
58327   330   FORMAT(1X,I4,1X,A8,I8,5I4   ,2F8.2,2F7.1,F8.2)
58328   340   FORMAT(1X,I4,1X,A8,I8,5I4   ,5F12.5)
58329   350   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2)
58330   360   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5)
58331   370   FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
58332      &   5(' & $',F8.2,'$'),' ',A2)
58333   380   FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
58334      &   5(' & $',F12.5,'$'),' ',A2)
58335   390   FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>')/'</TR>')
58336   400   FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>')/'</TR>')
58337       ENDIF
58338   410 CONTINUE
58339 C Close the files
58340       IF (PRNTEX) THEN
58341         WRITE(IUNITT,420) Z,Z,Z
58342   420   FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
58343         CLOSE(IUNITT)
58344       ENDIF
58345       IF (PRNWEB) THEN
58346         WRITE(IUNITW,430)
58347   430   FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
58348         CLOSE(IUNITW)
58349       ENDIF
58350       RETURN
58351       END
58352 CDECK  ID>, HWUGUP.
58353 *CMZ :-        -13/02/02  07.20.46  by  Peter Richardson
58354 *-- Author :    Peter Richardson
58355 C-----------------------------------------------------------------------
58356       SUBROUTINE HWUGUP
58357 C-----------------------------------------------------------------------
58358 C     Subroutine to handle termination of HERWIG if reaches end of event
58359 C     file
58360 C-----------------------------------------------------------------------
58361       INCLUDE 'HERWIG65.INC'
58362 C--reset the number of events to the correct value
58363       NEVHEP = NEVHEP-1
58364 C--output information on the events
58365       CALL HWEFIN
58366 C--run users end code
58367 c$$$      CALL HWAEND
58368       STOP
58369       END
58370 CDECK  ID>, HWUFNE.
58371 *CMZ :-        -16/10/93  12.42.15  by  Mike Seymour
58372 *-- Author :    Mike Seymour
58373 C-----------------------------------------------------------------------
58374       SUBROUTINE HWUFNE
58375 C-----------------------------------------------------------------------
58376 C     FINALISES THE EVENT BY UNDOING THE LORENTZ BOOST IF THERE WAS ONE,
58377 C     CHECKING FOR ERRORS, AND PRINTING
58378 C-----------------------------------------------------------------------
58379       INCLUDE 'HERWIG65.INC'
58380       INTEGER IHEP
58381       LOGICAL CALLED
58382       COMMON/HWDBUG/CALLED
58383       CALLED=.TRUE.
58384 C---UNBOOST EVENT RECORD IF NECESSARY
58385       CALL HWUBST(0)
58386 C---CHECK FOR NEGATIVE ENERGY PARTICLES (REMNANT BUG?)
58387       DO IHEP=1,NHEP
58388          IF (ISTHEP(IHEP).EQ.1.AND.PHEP(4,IHEP).LT.ZERO)
58389      &       CALL HWWARN('HWUFNE',100,*99)
58390       ENDDO
58391  99   CONTINUE
58392 C---CHECK FOR FATAL ERROR
58393       IF (IERROR.NE.0) THEN
58394         IF (IERROR.GT.0) THEN
58395           NUMER=NUMER+1
58396         ELSE
58397           NUMERU=NUMERU+1
58398         ENDIF
58399         IF (NUMER.GT.MAXER) CALL HWWARN('HWUFNE',300,*999)
58400         NEVHEP=NEVHEP-1
58401         IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV-1
58402 C---PRINT FIRST MAXPR EVENTS
58403 !       ELSEIF (NEVHEP.LE.MAXPR) THEN
58404       ELSEIF (NEVHEP.GE.EV1PR.AND.NEVHEP.LE.EV2PR) THEN
58405         CALL HWUEPR
58406       END IF
58407   999 END
58408 CDECK  ID>, HWUGAU.
58409 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
58410 *-- Author :    Adapted by Bryan Webber
58411 C-----------------------------------------------------------------------
58412       FUNCTION HWUGAU(F,A,B,EPS)
58413 C-----------------------------------------------------------------------
58414 C     ADAPTIVE GAUSSIAN INTEGRATION OF FUNCTION F
58415 C     IN INTERVAL (A,B) WITH PRECISION EPS
58416 C     (MODIFIED CERN LIBRARY ROUTINE GAUSS)
58417 C-----------------------------------------------------------------------
58418       DOUBLE PRECISION HWUGAU,F,A,B,EPS,CONST,AA,BB,C1,C2,S8,U,S16,
58419      & W(12),X(12),ZERO
58420       INTEGER I
58421       EXTERNAL F
58422       PARAMETER (ZERO=0.0D0)
58423       DATA W/.1012285363D0,.2223810345D0,.3137066459D0,
58424      &       .3626837834D0,.0271524594D0,.0622535239D0,
58425      &       .0951585117D0,.1246289713D0,.1495959888D0,
58426      &       .1691565194D0,.1826034150D0,.1894506105D0/
58427       DATA X/.9602898565D0,.7966664774D0,.5255324099D0,
58428      &       .1834346425D0,.9894009350D0,.9445750231D0,
58429      &       .8656312024D0,.7554044084D0,.6178762444D0,
58430      &       .4580167777D0,.2816035508D0,.0950125098D0/
58431       HWUGAU=0.
58432       IF (A.EQ.B) RETURN
58433       CONST=.005/ABS(B-A)
58434       BB=A
58435     1 AA=BB
58436       BB=B
58437     2    C1=0.5*(BB+AA)
58438          C2=0.5*(BB-AA)
58439          S8=0.
58440          DO 3 I=1,4
58441             U=C2*X(I)
58442             S8=S8+W(I)*(F(C1+U)+F(C1-U))
58443     3    CONTINUE
58444          S8=C2*S8
58445          S16=0.
58446          DO 4 I=5,12
58447             U=C2*X(I)
58448             S16=S16+W(I)*(F(C1+U)+F(C1-U))
58449     4    CONTINUE
58450          S16=C2*S16
58451          IF (ABS(S16-S8).LE.EPS*(1.+ABS(S16))) GOTO 5
58452          BB=C1
58453          IF (CONST*ABS(C2).NE.ZERO) GOTO 2
58454 C---TOO HIGH ACCURACY REQUESTED
58455          CALL HWWARN('HWUGAU',500,*999)
58456     5 HWUGAU=HWUGAU+S16
58457       IF (BB.NE.B) GOTO 1
58458   999 END
58459 CDECK  ID>, HWUIDT.
58460 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
58461 *-- Author :    Bryan Webber
58462 C-----------------------------------------------------------------------
58463       SUBROUTINE HWUIDT(IOPT,IPDG,IWIG,NWIG)
58464 C-----------------------------------------------------------------------
58465 C     TRANSLATES PARTICLE IDENTIFIERS:
58466 C     IPDG = PARTICLE DATA GROUP CODE
58467 C     IWIG = HERWIG IDENTITY CODE
58468 C     NWIG = HERWIG CHARACTER*8 NAME
58469 C
58470 C     IOPT= 1 GIVEN IPDG, RETURNS IWIG AND NWIG
58471 C     IOPT= 2 GIVEN IWIG, RETURNS IPDG AND NWIG
58472 C     IOPT= 3 GIVEN NWIG, RETURNS IPDG AND IWIG
58473 C-----------------------------------------------------------------------
58474       INCLUDE 'HERWIG65.INC'
58475       INTEGER IOPT,IPDG,IWIG,I
58476       CHARACTER*8 NWIG
58477       IF (IOPT.EQ.1) THEN
58478         DO 10 I=0,NRES
58479         IF (IDPDG(I).EQ.IPDG) THEN
58480           IWIG=I
58481           NWIG=RNAME(I)
58482           RETURN
58483         ENDIF
58484   10    CONTINUE
58485         WRITE(6,20) IPDG
58486   20    FORMAT(1X,'Particle not recognised, PDG code: ',I8)
58487         IWIG=20
58488         NWIG=RNAME(20)
58489         CALL HWWARN('HWUIDT',101,*999)
58490       ELSEIF (IOPT.EQ.2) THEN
58491         IF (IWIG.LT.0.OR.IWIG.GT.NRES) THEN
58492           WRITE(6,30) IWIG
58493   30      FORMAT(1X,'Particle not recognised, HERWIG code: ',I3)
58494           IPDG=0
58495           NWIG=RNAME(20)
58496           CALL HWWARN('HWUIDT',102,*999)
58497         ELSE
58498           IPDG=IDPDG(IWIG)
58499           NWIG=RNAME(IWIG)
58500           RETURN
58501         ENDIF
58502       ELSEIF (IOPT.EQ.3) THEN
58503         DO 40 I=0,NRES
58504         IF (RNAME(I).EQ.NWIG) THEN
58505           IWIG=I
58506           IPDG=IDPDG(I)
58507           RETURN
58508         ENDIF
58509   40    CONTINUE
58510         WRITE(6,50) NWIG
58511   50    FORMAT(1X,'Particle not recognised, HERWIG name: ',A8)
58512         IWIG=20
58513         IPDG=0
58514         CALL HWWARN('HWUIDT',103,*999)
58515       ELSE
58516         CALL HWWARN('HWUIDT',404,*999)
58517       ENDIF
58518   999 END
58519 CDECK  ID>, HWUINC.
58520 *CMZ :-        -12/10/01  09.56.07  by  Peter Richardson
58521 *-- Author :    Bryan Webber
58522 C-----------------------------------------------------------------------
58523       SUBROUTINE HWUINC
58524 C-----------------------------------------------------------------------
58525 C     COMPUTES CONSTANTS AND LOOKUP TABLES
58526 C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
58527 C-----------------------------------------------------------------------
58528       INCLUDE 'HERWIG65.INC'
58529       DOUBLE PRECISION HWBVMC,HWUALF,HWUPCM,XMIN,XMAX,XPOW,QR,DQKWT,
58530      & UQKWT,SQKWT,DIQWT,QMAX,PMAX,PTLIM,ETLIM,PGS,PTELM,X,QSCA,UPV,DNV,
58531      & USEA,DSEA,STR,CHM,BTM,TOP,GLU,VAL(20),CLMXPW,RCLPOW,TEST,RPM(2)
58532       INTEGER ISTOP,I,J,IQK,IDB,IDT,ISET,IOP1,IOP2,IP2,ID,IH,IV
58533       INTEGER LPROC,KPROC
58534       INTEGER IS,IP(3),IQ
58535       COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
58536       INTEGER      JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
58537       INTEGER ISQ1,ISQ2
58538       INTEGER IHLP,JHLP,KHLP,ISIGN,ITMP(8)
58539       DATA ITMP/0,12,-12,0,0,12,-12,0/
58540       LOGICAL FIRST,FSTPDF
58541       CHARACTER*20 PARM(20)
58542       EXTERNAL HWBVMC,HWUALF,HWUPCM
58543       COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
58544       COMMON/W50516/FSTPDF
58545       CHARACTER*20 PARMSAVE
58546       DOUBLE PRECISION VALSAVE
58547       COMMON/HWSFSA/PARMSAVE
58548       COMMON/HWSFSB/VALSAVE
58549 C--read in the information frmo the Les Houches common block if needed
58550       IF(IPROC.LE.0) CALL HWIGUP
58551 C---MSSM Higgs processes: additional IDs to distinguish from SM-like ones.
58552       IMSSM=0
58553       IHIGGS=0
58554 C---Sets even parity of Higgs bosons (in the coupling to fermions) as default.
58555       PARITY=1
58556 C...define parity of Neutral MSSM Higgses.
58557       IP(1)=+1
58558       IP(2)=+1
58559       IP(3)=-1
58560 C---IPRO=9,11 (lepton-lepton); 31...38 (hadron-hadron) MSSM Higgs production.
58561       LPROC=MOD(IPROC,10000)
58562       IF((LPROC.LT.3100).OR.(LPROC.GE.3900))THEN
58563 C...add here MSSM Higgs processes in lepton-lepton collisions.
58564         IF((LPROC/100.NE.9).AND.(LPROC/100.NE.11))GOTO 666
58565       END IF
58566 C-----------------------------------------------------------------------
58567 C     HARD 2 LEPTON/PARTON -> HIGGS + X PROCESSES IN MSSM
58568 C     IH = 1   MSSM h^0     IV = 0 SM W+/-     IQ = 1,3,5 d,s,b-quark
58569 C        = 2   MSSM H^0        = 1 SM Z             2,4,6 u,c,t-quark
58570 C        = 3   MSSM A^0                        ID = IQ, IL
58571 C        = 4/5 MSSM H^+/-                      IL = 1,2,3 e,mu,tau-lepton
58572 C-----------------------------------------------------------------------
58573 C...leptonic processes.
58574       IF(LPROC/100.EQ.9)THEN
58575         IF(LPROC.EQ.955)THEN
58576           IMSSM=-1
58577           IHIGGS=206-201
58578         ELSE IF(LPROC.EQ.965)THEN
58579           IHIGGS=203-201
58580           IMSSM=-1
58581         ELSE IF(LPROC.EQ.975)THEN
58582           IHIGGS=204-201
58583           IMSSM=-1
58584         ELSE IF((LPROC.EQ.910).OR.(LPROC.EQ.920).OR.
58585      &          (LPROC.EQ.960).OR.(LPROC.EQ.970))THEN
58586           KPROC=MIN(951,LPROC)
58587           IV=MAX(KPROC-950,0)
58588           IF((IV.LT.0).OR.(IV.GT.1))CALL HWWARN('HWUINC',627,*999)
58589           IH=LPROC/10-90-5*IV
58590           IF((IH.LE.0).OR.(IH.GT.2))CALL HWWARN('HWUINC',626,*999)
58591           IF(LPROC.LE.920)IMSSM=LPROC-400
58592           IF(LPROC.GE.960)IMSSM=LPROC-300
58593 C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
58594           DO 545 I=10,10
58595             ENHANC(I  )=GHWWSS(IH)
58596             ENHANC(I+1)=GHZZSS(IH)
58597  545      CONTINUE
58598           IF(IH.EQ.1)IHIGGS=203-201
58599           IF(IH.EQ.2)IHIGGS=204-201
58600           IF(IH.EQ.3)IHIGGS=205-201
58601         ELSE
58602           CALL HWWARN('HWUINC',625,*999)
58603         END IF
58604       ELSE IF(LPROC/100.EQ.11)THEN
58605         IMSSM=-1
58606         IF(LPROC.GE.1140)THEN
58607           IHIGGS=207-201
58608           PARITY=1
58609           GOTO 548
58610         END IF
58611         IF(LPROC.LT.1140)IH=3
58612         IF(LPROC.LT.1130)IH=2
58613         IF(LPROC.LT.1120)IH=1
58614         IF((IH.LE.0).OR.(IH.GT.3))CALL HWWARN('HWUINC',624,*999)
58615         IQ=LPROC-1100-10*IH
58616         IF((IQ.LE.0).OR.(IQ.GT.9))CALL HWWARN('HWUINC',623,*999)
58617 C...assign Neutral MSSM Higgs parity.
58618         PARITY=IP(IH)
58619 C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
58620         DO 546 I=1,5,2
58621           ENHANC(I  )=GHDDSS(IH)
58622           ENHANC(I+1)=GHUUSS(IH)
58623  546    CONTINUE
58624 C...assign enhancement for MSSM Higgs-LL couplings, L->D-type leptons.
58625         ENHANC(7)=GHDDSS(IH)
58626         ENHANC(8)=GHDDSS(IH)
58627         ENHANC(9)=GHDDSS(IH)
58628 C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
58629         DO 547 I=10,10
58630           ENHANC(I  )=GHWWSS(IH)
58631           ENHANC(I+1)=GHZZSS(IH)
58632  547    CONTINUE
58633         IF(IH.EQ.1)IHIGGS=203-201
58634         IF(IH.EQ.2)IHIGGS=204-201
58635         IF(IH.EQ.3)IHIGGS=205-201
58636  548    CONTINUE
58637 C...hadronic processes.
58638       ELSE IF((LPROC/100.EQ.31).OR.(LPROC/100.EQ.32))THEN
58639         IF(LPROC/100.EQ.31)THEN
58640           IF((LPROC.LE.3109).OR.
58641      &      ((LPROC.GE.3119).AND.(LPROC.LE.3139)).OR.
58642      &      ((LPROC.GE.3149).AND.(LPROC.LE.3169)).OR.
58643      &       (LPROC.GE.3179))CALL HWWARN('HWUINC',622,*999)
58644           IMSSM=-1
58645           IF(LPROC/100-LPROC/10*10.LE.4)IHIGGS=5
58646           IF(LPROC/100-LPROC/10*10.GE.5)IHIGGS=6
58647         ELSE IF(LPROC/100.EQ.32)THEN
58648           IF(LPROC.LE.3209)CALL HWWARN('HWUINC',621,*999)
58649           IF(LPROC.EQ.3219)CALL HWWARN('HWUINC',620,*999)
58650           IF(LPROC.EQ.3229)CALL HWWARN('HWUINC',619,*999)
58651           IF(LPROC.EQ.3239)CALL HWWARN('HWUINC',618,*999)
58652           IF(LPROC.EQ.3249)CALL HWWARN('HWUINC',617,*999)
58653           IF(LPROC.EQ.3259)CALL HWWARN('HWUINC',616,*999)
58654           IF(LPROC.EQ.3269)CALL HWWARN('HWUINC',615,*999)
58655           IF(LPROC.EQ.3279)CALL HWWARN('HWUINC',614,*999)
58656           IF(LPROC.EQ.3289)CALL HWWARN('HWUINC',613,*999)
58657           IF(LPROC.GE.3299)CALL HWWARN('HWUINC',612,*999)
58658           IMSSM=-1
58659           IF(LPROC.LT.3300)IHIGGS=4
58660           IF(LPROC.LT.3290)IHIGGS=3
58661           IF(LPROC.LT.3280)IHIGGS=2
58662           IF(LPROC.LT.3270)IHIGGS=4
58663           IF(LPROC.LT.3260)IHIGGS=3
58664           IF(LPROC.LT.3250)IHIGGS=2
58665           IF(LPROC.LT.3240)IHIGGS=4
58666           IF(LPROC.LT.3230)IHIGGS=3
58667           IF(LPROC.LT.3220)IHIGGS=2
58668         END IF
58669 C...assign squarks/Higgs-flavours.
58670         IF(LPROC/100.EQ.31)JHIGGS=1
58671         IF(LPROC/100.EQ.32)JHIGGS=IHIGGS-1
58672         IF(LPROC/100.EQ.31)ILBL=3100
58673         IF(LPROC/100.EQ.32)ILBL=3200
58674         IHLP=LPROC-ILBL-60-JHIGGS*10
58675         IF(LPROC.LT.ILBL+70)IHLP=LPROC-ILBL-30-JHIGGS*10
58676         IF(LPROC.LT.ILBL+40)IHLP=LPROC-ILBL   -JHIGGS*10
58677         IF(IHLP.LE.8)ISIGN=-1
58678         IF(IHLP.LE.4)ISIGN=+1
58679         JHLP=IHLP/5
58680         KHLP=IHLP/(3+4*JHLP)
58681         ISQ1=405+JHLP+12*KHLP
58682         IF(ILBL.EQ.3100)THEN
58683           ISQ2=ISQ1+ITMP(IHLP)+6+ISIGN
58684           IF(ISIGN.EQ.+1)JH=206
58685           IF(ISIGN.EQ.-1)JH=207
58686           IF(ISIGN.EQ.+1)JHIGGS=4
58687           IF(ISIGN.EQ.-1)JHIGGS=5
58688         ELSE IF(ILBL.EQ.3200)THEN
58689           ISQ2=ISQ1+ITMP(IHLP)+6
58690           IF(JHIGGS.EQ.1)JH=203
58691           IF(JHIGGS.EQ.2)JH=204
58692           IF(JHIGGS.EQ.3)JH=205
58693         END IF
58694         IF1MIN=ISQ1
58695         IF1MAX=ISQ1
58696         IF2MIN=ISQ2
58697         IF2MAX=ISQ2
58698         IF((LPROC.EQ.3110).OR.(LPROC.EQ.3210).OR.
58699      &     (LPROC.EQ.3220).OR.(LPROC.EQ.3230).OR.
58700      &     (LPROC.EQ.3140).OR.(LPROC.EQ.3240).OR.
58701      &     (LPROC.EQ.3250).OR.(LPROC.EQ.3260).OR.
58702      &     (LPROC.EQ.3170).OR.(LPROC.EQ.3270).OR.
58703      &     (LPROC.EQ.3280).OR.(LPROC.EQ.3290))THEN
58704           IF1MIN=405
58705           IF1MAX=418
58706           IF2MIN=411
58707           IF2MAX=424
58708         END IF
58709       ELSE IF(LPROC/100.EQ.33)THEN
58710         IF((LPROC.EQ.3350).OR.(LPROC.EQ.3355))THEN
58711           IMSSM=-1
58712           IHIGGS=206-201
58713         ELSE IF((LPROC.EQ.3310).OR.(LPROC.EQ.3320).OR.
58714      &          (LPROC.EQ.3360).OR.(LPROC.EQ.3370))THEN
58715           KPROC=MIN(3351,LPROC)
58716           IV=MAX(KPROC-3350,0)
58717           IF((IV.LT.0).OR.(IV.GT.1))CALL HWWARN('HWUINC',611,*999)
58718           IH=LPROC/10-330-5*IV
58719           IF((IH.LE.0).OR.(IH.GT.2))CALL HWWARN('HWUINC',610,*999)
58720           IF(LPROC.LE.3320)IMSSM=LPROC-2600
58721           IF(LPROC.GE.3360)IMSSM=LPROC-2700
58722 C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
58723           DO 555 I=10,10
58724             ENHANC(I  )=GHWWSS(IH)
58725             ENHANC(I+1)=GHZZSS(IH)
58726  555      CONTINUE
58727           IF(IH.EQ.1)IHIGGS=203-201
58728           IF(IH.EQ.2)IHIGGS=204-201
58729           IF(IH.EQ.3)IHIGGS=205-201
58730         ELSE IF((LPROC.EQ.3315).OR.(LPROC.EQ.3365))THEN
58731           IHIGGS=203-201
58732           IMSSM=-1
58733         ELSE IF((LPROC.EQ.3325).OR.(LPROC.EQ.3375))THEN
58734           IHIGGS=204-201
58735           IMSSM=-1
58736         ELSE IF(LPROC.EQ.3335)THEN
58737           IHIGGS=205-201
58738           IMSSM=-1
58739         ELSE
58740           CALL HWWARN('HWUINC',609,*999)
58741         END IF
58742       ELSE IF(LPROC/100.EQ.34)THEN
58743         IMSSM=-1
58744         IF(LPROC.EQ.3410)IHIGGS=203-201
58745         IF(LPROC.EQ.3420)IHIGGS=204-201
58746         IF(LPROC.EQ.3430)IHIGGS=205-201
58747         IF(LPROC.EQ.3450)IHIGGS=206-201
58748         IF(IHIGGS.EQ.0)CALL HWWARN('HWUINC',608,*999)
58749       ELSE IF(LPROC/100.EQ.35)THEN
58750         IMSSM=-1
58751         IHIGGS=206-201
58752       ELSE IF(LPROC/100.EQ.36)THEN
58753         IF((LPROC.NE.3610).AND.(LPROC.NE.3620).AND.(LPROC.NE.3630))
58754      &  CALL HWWARN('HWUINC',607,*999)
58755         IH=LPROC/10-360
58756         IF((IH.LE.0).OR.(IH.GT.3))CALL HWWARN('HWUINC',606,*999)
58757         ID=LPROC-3600-10*IH
58758         IF((ID.LT.0).OR.(ID.GT.9))CALL HWWARN('HWUINC',605,*999)
58759         IMSSM=LPROC-(1600+ID)
58760 C...assign Neutral MSSM Higgs parity.
58761         IF(IH.EQ.3)PARITY=-1
58762         DO 222 I=1,5,2
58763 C...assign enhancement for Neutral MSSM Higgs-QQ couplings, Q->U,D-type quarks.
58764           ENHANC(I)=GHDDSS(IH)
58765           ENHANC(I+1)=GHUUSS(IH)
58766  222    CONTINUE
58767 C...assign enhancement for Neutral MSSM Higgs-Q~Q~ couplings,
58768 C   Q~->U,D-type squarks.
58769         DO 223 I=1,6
58770           SENHNC(I   )=RMASS(198)*GHSQSS(IH,I,1,1)/RMASS(400+I)**2
58771           SENHNC(I+12)=RMASS(198)*GHSQSS(IH,I,2,2)/RMASS(412+I)**2
58772  223    CONTINUE
58773         IF(IH.EQ.1)IHIGGS=203-201
58774         IF(IH.EQ.2)IHIGGS=204-201
58775         IF(IH.EQ.3)IHIGGS=205-201
58776       ELSE IF(LPROC/100.EQ.37)THEN
58777         IH=LPROC/10-370
58778         IF((IH.LE.0).OR.(IH.GT.2))CALL HWWARN('HWUINC',604,*999)
58779         IMSSM=LPROC-1900
58780 C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
58781         DO 333 I=10,10
58782           ENHANC(I  )=GHWWSS(IH)
58783           ENHANC(I+1)=GHZZSS(IH)
58784  333    CONTINUE
58785         IF(IH.EQ.1)IHIGGS=203-201
58786         IF(IH.EQ.2)IHIGGS=204-201
58787         IF(IH.EQ.3)IHIGGS=205-201
58788       ELSE IF(LPROC/100.EQ.38)THEN
58789         IMSSM=-1
58790         IF((LPROC.EQ.3839).OR.(LPROC.EQ.3869).OR.(LPROC.EQ.3899))THEN
58791           IHIGGS=207-201
58792           PARITY=1
58793           GOTO 445
58794         END IF
58795         IF(LPROC.LT.4000)IS=6
58796         IF(LPROC.LT.3870)IS=3
58797         IF(LPROC.LT.3840)IS=0
58798         IH=LPROC/10-380-IS
58799         IF((IH.LE.0).OR.(IH.GT.3))CALL HWWARN('HWUINC',603,*999)
58800         IQ=LPROC-3800-10*(IH+IS)
58801         IF((IQ.LE.0).OR.(IQ.GT.6))CALL HWWARN('HWUINC',602,*999)
58802 C...assign Neutral MSSM Higgs parity.
58803         PARITY=IP(IH)
58804 C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
58805         DO 444 I=1,5,2
58806           ENHANC(I  )=GHDDSS(IH)
58807           ENHANC(I+1)=GHUUSS(IH)
58808  444    CONTINUE
58809         IF(IH.EQ.1)IHIGGS=203-201
58810         IF(IH.EQ.2)IHIGGS=204-201
58811         IF(IH.EQ.3)IHIGGS=205-201
58812  445    CONTINUE
58813       END IF
58814       IF((IMSSM.NE.-1).AND.(IPROC.GE.10000))IMSSM=IMSSM+10000
58815  666  CONTINUE
58816       IPRO=MOD(IPROC/100,100)
58817       IQK=MOD(IPROC,100)
58818 C---SET UP BEAMS
58819       CALL HWUIDT(3,IDB,IPART1,PART1)
58820       CALL HWUIDT(3,IDT,IPART2,PART2)
58821       EBEAM1=SQRT(PBEAM1**2+RMASS(IPART1)**2)
58822       EBEAM2=SQRT(PBEAM2**2+RMASS(IPART2)**2)
58823 C---PHOTON CUTOFF DEFAULTS TO ROOT S
58824       PTLIM=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
58825       ETLIM=TWO*PTLIM
58826       IF (VPCUT.GT.ETLIM) VPCUT=ETLIM
58827       IF (Q2MAX.GT.ETLIM**2) Q2MAX=ETLIM**2
58828 C---PRINT OUT MOST IMPORTANT INPUT PARAMETERS
58829       IF (IPRINT.EQ.0) GOTO 50
58830       WRITE (6,10) PART1,PBEAM1,PART2,PBEAM2,IPROC,
58831      & NFLAV,NSTRU,AZSPIN,AZSOFT,QCDLAM,(RMASS(I),I=1,6),RMASS(13)
58832       IF (ISPAC.LE.1) THEN
58833         WRITE (6,20) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
58834       ELSE
58835         WRITE (6,30) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
58836       ENDIF
58837 C--switch on three body matrix elements if doing spin correlations
58838       IF(SYSPIN) THREEB=.TRUE.
58839 C--output spin correlation options
58840       WRITE(6,35) SYSPIN,THREEB,FOURB
58841       IF (NOSPAC) WRITE (6,40)
58842   10  FORMAT(/10X,'INPUT CONDITIONS FOR THIS RUN'//
58843      &        10X,'BEAM 1 (',A8,') MOM. =',F10.2/
58844      &        10X,'BEAM 2 (',A8,') MOM. =',F10.2/
58845      &        10X,'PROCESS CODE (IPROC)   =',I8/
58846      &        10X,'NUMBER OF FLAVOURS     =',I5/
58847      &        10X,'STRUCTURE FUNCTION SET =',I5/
58848      &        10X,'AZIM SPIN CORRELATIONS =',L5/
58849      &        10X,'AZIM SOFT CORRELATIONS =',L5/
58850      &        10X,'QCD LAMBDA (GEV)       =',F10.4/
58851      &        10X,'DOWN     QUARK  MASS   =',F10.4/
58852      &        10X,'UP       QUARK  MASS   =',F10.4/
58853      &        10X,'STRANGE  QUARK  MASS   =',F10.4/
58854      &        10X,'CHARMED  QUARK  MASS   =',F10.4/
58855      &        10X,'BOTTOM   QUARK  MASS   =',F10.4/
58856      &        10X,'TOP      QUARK  MASS   =',F10.4/
58857      &        10X,'GLUON EFFECTIVE MASS   =',F10.4)
58858   20  FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
58859      &       10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
58860      &       10X,'PHOTON SHOWER CUTOFF   =',F10.4/
58861      &       10X,'CLUSTER MASS PARAMETER =',F10.4/
58862      &       10X,'SPACELIKE EVOLN CUTOFF =',F10.4/
58863      &       10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
58864   30  FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
58865      &       10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
58866      &       10X,'PHOTON SHOWER CUTOFF   =',F10.4/
58867      &       10X,'CLUSTER MASS PARAMETER =',F10.4/
58868      &       10X,'PDF FREEZING CUTOFF    =',F10.4/
58869      &       10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
58870   35  FORMAT(10X,'DECAY SPIN CORRELATIONS=',L5/
58871      &       10X,'SUSY THREE BODY ME     =',L5/
58872      &       10X,'SUSY FOUR  BODY ME     =',L5)
58873   40  FORMAT(10X,'NO SPACE-LIKE SHOWERS')
58874   50  ISTOP=0
58875 C---INITIALIZE ALPHA-STRONG
58876       IF (QLIM.GT.ETLIM) QLIM=ETLIM
58877       QR=HWUALF(0,QLIM)
58878 C---DO SOME SAFETY CHECKS ON INPUT PARAMETERS
58879 C Check beam order for point-like photon/QCD processes
58880       IF (IPRO.GE.50.AND.IPRO.LE.59.AND.
58881      &     IDB.NE.22.AND.ABS(IDB).NE.11.AND.ABS(IDB).NE.13) THEN
58882          WRITE(6,60)
58883   60     FORMAT(1X,'WARNING: require FIRST beam to be a photon/lepton')
58884          ISTOP=ISTOP+1
58885       ENDIF
58886       QG=HWBVMC(13)
58887       QR=QG/QCDL3
58888       IF (QR.GE.2.01) GOTO 80
58889       WRITE (6,70) QG,QCDLAM,QCDL3
58890   70  FORMAT(//10X,'SHOWER GLUON VIRTUAL MASS CUTOFF =',F8.5/
58891      &         10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
58892      &         10X,'CORRESPONDS TO  3-FLAV MC LAMBDA =',F8.5)
58893       ISTOP=ISTOP+1
58894   80  QV=MIN(HWBVMC(1),HWBVMC(2))
58895       IF (QV.GE.QG/(QR-1.)) GOTO 100
58896       ISTOP=ISTOP+1
58897       WRITE (6,90) QV,QCDLAM,QCDL3
58898   90  FORMAT(//10X,'SHOWER QUARK VIRTUAL MASS CUTOFF =',F8.5/
58899      &         10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
58900      &         10X,'CORRESPONDS TO  3-FLAV MC LAMBDA =',F8.5)
58901   100 IF (ISTOP.NE.0) THEN
58902         WRITE (6,110) ISTOP
58903   110   FORMAT(//10X,'EXECUTION PREVENTED BY',I2,
58904      &  ' ERRORS IN INPUT PARAMETERS.')
58905         STOP
58906       ENDIF
58907       DO 120 I=1,6
58908   120 RMASS(I+6)=RMASS(I)
58909       RMASS(199)=RMASS(198)
58910 C---A PRIORI WEIGHTS FOR QUARK AND DIQUARKS
58911       DQKWT=PWT(1)
58912       UQKWT=PWT(2)
58913       SQKWT=PWT(3)
58914       DIQWT=PWT(7)
58915       PWT(10)=PWT(4)
58916       PWT(11)=PWT(5)
58917       PWT(12)=PWT(6)
58918 C
58919       PWT(4)=UQKWT*UQKWT*DIQWT
58920       PWT(5)=UQKWT*DQKWT*DIQWT*HALF
58921       PWT(6)=DQKWT*DQKWT*DIQWT
58922       PWT(7)=UQKWT*SQKWT*DIQWT*HALF
58923       PWT(8)=DQKWT*SQKWT*DIQWT*HALF
58924       PWT(9)=SQKWT*SQKWT*DIQWT
58925       QMAX=MAX(PWT(1),PWT(2),PWT(3))
58926       PMAX=MAX(PWT(4),PWT(5),PWT(6),PWT(7),PWT(8),PWT(9),
58927      &         PWT(10),PWT(11),PWT(12),QMAX)
58928       PMAX=1./PMAX
58929       QMAX=1./QMAX
58930       DO 130 I=1,3
58931   130 QWT(I)=PWT(I)*QMAX
58932       DO 140 I=1,12
58933   140 PWT(I)=PWT(I)*PMAX
58934 C  MASSES OF DIQUARKS (ASSUME BINDING NEGLIGIBLE)
58935       RMASS(109)=RMASS(2)+RMASS(2)
58936       RMASS(110)=RMASS(1)+RMASS(2)
58937       RMASS(111)=RMASS(1)+RMASS(1)
58938       RMASS(112)=RMASS(2)+RMASS(3)
58939       RMASS(113)=RMASS(1)+RMASS(3)
58940       RMASS(114)=RMASS(3)+RMASS(3)
58941       DO 150 I=109,114
58942   150 RMASS(I+6)=RMASS(I)
58943 C  MASSES OF TOP HADRONS (ASSUME BINDING NEGLIGIBLE)
58944       RMASS(232)=RMASS(6)+RMASS(5)
58945       RMASS(233)=RMASS(6)+RMASS(1)
58946       RMASS(234)=RMASS(6)+RMASS(2)
58947       RMASS(235)=RMASS(6)+RMASS(3)
58948       RMASS(236)=RMASS(6)+RMASS(2)+RMASS(2)
58949       RMASS(237)=RMASS(6)+RMASS(1)+RMASS(2)
58950       RMASS(238)=RMASS(6)+RMASS(1)+RMASS(1)
58951       RMASS(239)=RMASS(6)+RMASS(2)+RMASS(3)
58952       RMASS(240)=RMASS(6)+RMASS(1)+RMASS(3)
58953       RMASS(241)=RMASS(6)+RMASS(3)+RMASS(3)
58954       RMASS(242)=RMASS(6)+RMASS(4)
58955       RMASS(243)=RMASS(6)+RMASS(5)
58956       RMASS(244)=RMASS(6)+RMASS(6)
58957       RMASS(232)=RMASS(243)
58958       DO 160 I=233,242
58959   160 RMASS(I+22)=RMASS(I)
58960 C Set up an array of cluster mass threholds
58961       CLMXPW=CLMAX**CLPOW
58962       RCLPOW=ONE/CLPOW
58963       CALL HWVZRO(144,CTHRPW(1,1))
58964       DO 170 I=1,6
58965       DO 170 J=1,6
58966       CTHRPW(I ,J  )=(CLMXPW+(RMASS(I    )+RMASS(J+6  ))**CLPOW)**RCLPOW
58967       CTHRPW(I ,J+6)=(CLMXPW+(RMASS(I    )+RMASS(J+108))**CLPOW)**RCLPOW
58968   170 CTHRPW(I+6,J )=(CLMXPW+(RMASS(I+114)+RMASS(J+6  ))**CLPOW)**RCLPOW
58969 C Decay length conversion factor GEV2MM hbar.c/e
58970       GEV2MM=1.D-15*SQRT(GEV2NB/10.)
58971 C Plank's constant/2pi (GeV.s)
58972       HBAR=GEV2MM/CSPEED
58973 C Check the SUSY DATA has been read in (if needed)
58974       IF((IPRO.EQ.7.OR.IPRO.EQ.8.OR.IPRO.EQ.9.OR.IPRO.EQ.11.
58975      &OR.(IPRO.GE.30.AND.IPRO.LE.41)).AND..NOT.SUSYIN)
58976      &     CALL HWWARN('HWUINC',601,*999)
58977 C---IMPORTANCE SAMPLING
58978       FIRST=.TRUE.
58979       XMIN=0
58980       XMAX=0
58981       XPOW=-1
58982       IF (IPRO.EQ.5) THEN
58983         IF (EMMAX.GT.ETLIM)  EMMAX=ETLIM
58984         IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
58985       ELSEIF (IPRO.EQ.13) THEN
58986         IF (EMMIN.EQ.ZERO)   EMMIN=10
58987         IF (EMMAX.GT.ETLIM)  EMMAX=ETLIM
58988         IF (IQK.GT.0.AND.IQK.LE.6) EMMIN=MAX(EMMIN,2*RMASS(IQK))
58989         XMIN=EMMIN
58990         XMAX=EMMAX
58991         XPOW=-EMPOW
58992       ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
58993      &    .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
58994      &    .OR.IPRO.EQ.51.OR.IPRO.EQ.53.OR.IPRO.EQ.55.OR.IPRO.EQ.60) THEN
58995         IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
58996         IF (IQK.NE.0.AND.IQK.LT.7.AND.IPRO.NE.23) THEN
58997           XMIN=2.*SQRT(PTMIN**2+RMASS(IQK)**2)
58998           XMAX=2.*SQRT(PTMAX**2+RMASS(IQK)**2)
58999           IF (XMAX.GT.ETLIM)  XMAX=ETLIM
59000         ELSE
59001           XMIN=2.*PTMIN
59002           XMAX=2.*PTMAX
59003         ENDIF
59004         XPOW=-PTPOW
59005 C--Gauge Boson pairs in hadron-hadron
59006       ELSEIF(IPRO.EQ.28) THEN
59007         IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
59008 C--Drell-Yan + 2 jets processes
59009       ELSEIF(IPRO.EQ.29) THEN
59010         IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
59011         IF(PTMAX.GT.ETLIM) PTMAX = ETLIM
59012 C--Cuts on the graviton to avoid unitarity violations
59013 C--If the width exceeds 0.1 times the mass this should be reset
59014       ELSEIF(IPRO.EQ.42) THEN
59015          EMMIN = 0.9D0*EMGRV
59016          EMMAX = 1.1D0*EMGRV
59017       ELSEIF (IPRO.EQ.52) THEN
59018         PTELM=PTLIM-RMASS(IQK)**2/(4.*PTLIM)
59019         IF (PTMAX.GT.PTELM) PTMAX=PTELM
59020         XMIN=PTMIN
59021         XMAX=PTMAX
59022         XPOW=-PTPOW
59023       ELSEIF (IPRO.EQ.30) THEN
59024         IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
59025         XMIN=2.*SQRT(PTMIN**2+RMMNSS**2)
59026         XMAX=2.*SQRT(PTMAX**2+RMMNSS**2)
59027         IF (XMAX.GT.ETLIM)  XMAX=ETLIM
59028         XPOW=-PTPOW
59029 C--PR MOD 7/7/99
59030       ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
59031         IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
59032           ID = MOD(IPROC,100)
59033           RPM(1) = RMMNSS
59034           RPM(2) = ZERO
59035           IF(ID.GE.10.AND.ID.LT.20) THEN
59036             RPM(1) = ABS(RMASS(450))
59037             IF(ID.GT.10) RPM(1) = ABS(RMASS(449+MOD(ID,10)))
59038           ELSEIF(ID.GE.20.AND.ID.LT.30) THEN
59039             RPM(1) = ABS(RMASS(454))
59040             IF(ID.GT.20) RPM(1) = ABS(RMASS(453+MOD(ID,20)))
59041           ELSEIF(ID.EQ.30) THEN
59042             RPM(1) = RMASS(449)
59043           ELSEIF(ID.EQ.40) THEN
59044             IF(IPRO.EQ.40) THEN
59045               RPM(1) = RMASS(425)
59046               DO I=1,5
59047                 RPM(1) = MIN(RPM(1),RMASS(425+I))
59048               ENDDO
59049             ELSE
59050               RPM(1) = MIN(RMASS(405),RMASS(406))
59051             ENDIF
59052             RPM(2) = RMASS(198)
59053           ELSEIF(ID.EQ.50) THEN
59054             IF(IPRO.EQ.40) THEN
59055               RPM(1) = RMASS(425)
59056               DO I=1,5
59057                 RPM(1) = MIN(RPM(1),RMASS(425+I))
59058               ENDDO
59059               DO I=1,3
59060                 RPM(2) = MIN(RPM(1),RMASS(433+2*I))
59061               ENDDO
59062               RPM(1) = MIN(RPM(1),RPM(2))
59063               RPM(2) = RMASS(203)
59064               DO I=1,2
59065                 RPM(2) = MIN(RPM(2),RMASS(204+I))
59066               ENDDO
59067             ELSE
59068               RPM(1) = RMASS(401)
59069               RPM(2) = RMASS(413)
59070               DO I=1,5
59071                 RPM(1) = MIN(RPM(1),RMASS(401+I))
59072                 RPM(2) = MIN(RPM(2),RMASS(413+I))
59073               ENDDO
59074               RPM(1) = MIN(RPM(1),RPM(2))
59075               RPM(2) = RMASS(203)
59076               DO I=1,2
59077                 RPM(2) = MIN(RPM(2),RMASS(204+I))
59078               ENDDO
59079             ENDIF
59080             RPM(2) = RMASS(203)
59081             DO I=1,2
59082               RPM(2) = MIN(RPM(2),RMASS(204+I))
59083             ENDDO
59084           ELSEIF(ID.GE.60) THEN
59085             RPM(1) = ZERO
59086           ENDIF
59087           RPM(1) = RPM(1)**2
59088           RPM(2) = RPM(2)**2
59089           XMIN = SQRT(RPM(1)+RPM(2)+TWO*(PTMIN**2+
59090      &           SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2))))
59091           XMAX = SQRT(RPM(1)+RPM(2)+TWO*(PTMAX**2+
59092      &           SQRT(RPM(1)*RPM(2)+PTMAX**2*(RPM(1)+RPM(2)+PTMAX**2))))
59093         IF (XMAX.GT.ETLIM)  XMAX=ETLIM
59094 C--end of mod
59095       ELSEIF (IPRO.EQ.90) THEN
59096         XMIN=SQRT(Q2MIN)
59097         XMAX=SQRT(Q2MAX)
59098         XPOW=1.-2.*Q2POW
59099       ELSEIF (IPRO.EQ.91) THEN
59100         IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
59101       ENDIF
59102 C---CALCULATE HIGGS WIDTH
59103       IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.10.OR.IPRO.EQ.16
59104      &.OR.IPRO.EQ.19.OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26
59105      &.OR.IPRO.EQ.27.OR.IPRO.EQ.95) THEN
59106         GAMH=RMASS(201)
59107         CALL HWDHIG(GAMH)
59108       ENDIF
59109 C---IF Q**2 CAN BE TOO SMALL, BREIT FRAME MAKES NO SENSE
59110       IF ((IPRO/10.EQ.9.AND.Q2MIN.LE.1.D-2).OR.
59111      &    (IPRO.EQ.91.AND.IQK.EQ.7)) BREIT=.FALSE.
59112       IF (IPRINT.NE.0) THEN
59113         IF (PBEAM1.NE.PBEAM2) WRITE (6,180) USECMF
59114         IF (IPRO.EQ.91.OR.IPRO.EQ.92)
59115      &      WRITE (6,190) PTMIN
59116         IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
59117      &      WRITE (6,200) Q2MIN,Q2MAX,BREIT
59118         IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
59119      &      WRITE (6,210) YBMIN,YBMAX
59120         IF (IPRO.EQ.91.AND.IQK.EQ.7)
59121      &      WRITE (6,220) Q2WWMN,Q2WWMX,BREIT,ZJMAX
59122         IF (IPROC/10.EQ.11) WRITE (6,230) THMAX
59123         IF (IPRO.EQ.13) WRITE (6,240) EMMIN,EMMAX
59124         IF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
59125      &  .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
59126      &  .OR.IPRO.EQ.51.OR.IPRO.EQ.52.OR.IPRO.EQ.53.OR.IPRO.EQ.55
59127      &  .OR.IPRO.EQ.60)
59128      &      WRITE (6,250) PTMIN,PTMAX
59129         IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.10.OR.IPRO.EQ.16
59130      &  .OR.IPRO.EQ.19.OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26
59131      &  .OR.IPRO.EQ.27.OR.IPRO.EQ.95)
59132      &      WRITE (6,260) RMASS(201),GAMH,
59133      &      GAMMAX,RMASS(201)+GAMMAX*GAMH,(BRHIG(I)*100,I=1,12)
59134         IF (IPRO.EQ.91) WRITE (6,270) BGSHAT,EMMIN,EMMAX
59135         IF (IPRO.EQ.5.AND.IQK.LT.50)
59136      &      WRITE (6,280) EMMIN,EMMAX,PTMIN,PTMAX,CTMAX
59137         IF (IPRO.EQ.5.AND.IQK.GE.50)
59138      &      WRITE (6,290) EMMIN,EMMAX,Q2MIN,Q2MAX,PTMIN
59139         IF (IPRO.GT.12.AND.
59140      &    (IPRO.LT.90.AND.(ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
59141      &                    (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) THEN
59142           WRITE (6,300) Q2WWMN,Q2WWMX,YWWMIN,YWWMAX
59143           IF (PHOMAS.GT.ZERO) WRITE (6,310) PHOMAS
59144         ENDIF
59145         IF (IPROC/10.EQ.10.OR.IPRO.EQ.90)
59146      &      WRITE (6,320) HARDME,SOFTME
59147 C  Check minimum mass threshold if ISR switched on
59148         IF ((IPRO.LE.3.OR.IPRO.EQ.6).AND.ZMXISR.GT.ZERO) THEN
59149           TEST=TWO*RMASS(IPART1)**2+ETLIM**2
59150           TEST=FOUR*RMASS(2)**2/TEST
59151           IF (TMNISR.LT.TEST) THEN
59152             WRITE(6,175) TMNISR,TEST
59153   175       FORMAT(10X,'Minimum invariant mass',F10.6,' too low'/
59154      &             10X,'increasing to  TMNISR=',F10.6)
59155             TMNISR=TEST
59156           ENDIF
59157           WRITE (6,330) TMNISR,ONE-ZMXISR
59158         ENDIF
59159         IF (WHMIN.GT.ZERO .AND. IPRO.GT.12.AND.(IPRO.EQ.90.OR.
59160      &       (ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
59161      &       (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) WRITE (6,340) WHMIN
59162   180   FORMAT(10X,'USE BEAM-TARGET C.M.F. =',L5)
59163   190   FORMAT(10X,'MIN P-T FOR O(AS) DILS =',F10.4)
59164   200   FORMAT(10X,'MIN ABS(Q**2) FOR DILS =',E10.4/
59165      &         10X,'MAX ABS(Q**2) FOR DILS =',E10.4/
59166      &         10X,'BREIT FRAME SHOWERING  =',L5)
59167   210   FORMAT(10X,'MIN BJORKEN Y FOR DILS =',F10.4/
59168      &         10X,'MAX BJORKEN Y FOR DILS =',F10.4)
59169   220   FORMAT(10X,'MIN ABS(Q**2) FOR J/PSI=',E10.4/
59170      &         10X,'MAX ABS(Q**2) FOR J/PSI=',E10.4/
59171      &         10X,'BREIT FRAME SHOWERING  =',L5/
59172      &         10X,'MAX Z FOR J/PSI        =',F10.4)
59173   230   FORMAT(10X,'MAX THRUST FOR 2->3    =',F10.4)
59174   240   FORMAT(10X,'MIN MASS FOR DRELL-YAN =',F10.4/
59175      &         10X,'MAX MASS FOR DRELL-YAN =',F10.4)
59176   250   FORMAT(10X,'MIN P-TRAN FOR 2->2    =',F10.4/
59177      &         10X,'MAX P-TRAN FOR 2->2    =',F10.4)
59178   260   FORMAT(10X,'HIGGS BOSON MASS       =',F10.4/
59179      &         10X,'HIGGS BOSON WIDTH      =',F10.4/
59180      &         10X,'CUTOFF = EMH +',F4.1,'*GAMH=',F10.4/
59181      &         10X,'HIGGS          D DBAR  =',F10.4/
59182      &         10X,'BRANCHING      U UBAR  =',F10.4/
59183      &         10X,'FRACTIONS      S SBAR  =',F10.4/
59184      &         10X,'(PER CENT)     C CBAR  =',F10.4/
59185      &         10X,'               B BBAR  =',F10.4/
59186      &         10X,'               T TBAR  =',F10.4/
59187      &         10X,'              E+ E-    =',F10.4/
59188      &         10X,'             MU+ MU-   =',F10.4/
59189      &         10X,'            TAU+ TAU-  =',F10.4/
59190      &         10X,'               W W     =',F10.4/
59191      &         10X,'               Z Z     =',F10.4/
59192      &         10X,'           GAMMA GAMMA =',F10.4)
59193   270   FORMAT(10X,'SCALE FOR BGF IS S-HAT =',L5/
59194      &         10X,'MIN MASS FOR BGF       =',F10.4/
59195      &         10X,'MAX MASS FOR BGF       =',F10.4)
59196   280   FORMAT(10X,'MIN MASS FOR 2 PHOTONS =',F10.4/
59197      &         10X,'MAX MASS FOR 2 PHOTONS =',F10.4/
59198      &         10X,'MIN PT OF 2 PHOTON CMF =',F10.4/
59199      &         10X,'MAX PT OF 2 PHOTON CMF =',F10.4/
59200      &         10X,'MAX COS THETA IN CMF   =',F10.4)
59201   290   FORMAT(10X,'MIN MASS FOR GAMMA + W =',F10.4/
59202      &         10X,'MAX MASS FOR GAMMA + W =',F10.4/
59203      &         10X,'MIN ABS(Q**2)          =',E10.4/
59204      &         10X,'MAX ABS(Q**2)          =',E10.4/
59205      &         10X,'MIN PT                 =',F10.4)
59206   300   FORMAT(10X,'MIN Q**2 FOR WW PHOTON =',F10.4/
59207      &         10X,'MAX Q**2 FOR WW PHOTON =',F10.4/
59208      &         10X,'MIN MOMENTUM FRACTION  =',F10.4/
59209      &         10X,'MAX MOMENTUM FRACTION  =',F10.4)
59210   310   FORMAT(10X,'GAMMA* S.F. MASS PARAM =',F10.4)
59211   320   FORMAT(10X,'HARD M.E. MATCHING     =',L5/
59212      &         10X,'SOFT M.E. MATCHING     =',L5)
59213   330   FORMAT(10X,'MIN MTM FRAC FOR ISR   =',1PE10.4/
59214      &         10X,'1-MAX MTM FRAC FOR ISR =',1PE10.4)
59215   340   FORMAT(10X,'MINIMUM HADRONIC MASS  =',F10.4)
59216         IF (LWEVT.LE.0) THEN
59217           WRITE (6,350)
59218         ELSE
59219           WRITE (6,360) LWEVT
59220         ENDIF
59221   350   FORMAT(/10X,'NO EVENTS WILL BE WRITTEN TO DISK')
59222   360   FORMAT(/10X,'EVENTS WILL BE OUTPUT ON UNIT',I4)
59223       ENDIF
59224 C Verify and print beam polarisations
59225       IF((IPRO.EQ.1.OR.IPRO.EQ.3).OR.
59226      &  ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.960)).OR.
59227      &  ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.970)))THEN
59228 C Set up transverse polarisation parameters for e+e-
59229         IF ((EPOLN(1)**2+EPOLN(2)**2)
59230      &     *(PPOLN(1)**2+PPOLN(2)**2).GT.ZERO) THEN
59231           TPOL=.TRUE.
59232           COSS=EPOLN(1)*PPOLN(1)-EPOLN(2)*PPOLN(2)
59233           SINS=EPOLN(2)*PPOLN(1)+EPOLN(1)*PPOLN(2)
59234         ELSE
59235           TPOL=.FALSE.
59236         ENDIF
59237 C print out lepton beam polarisation(s)
59238         IF (IPRINT.NE.0) THEN
59239           IF (IPART1.EQ.121) THEN
59240             WRITE (6,370) PART1,EPOLN,PART2,PPOLN
59241           ELSE
59242             WRITE (6,370) PART1,PPOLN,PART2,EPOLN
59243           ENDIF
59244  370      FORMAT(/10X,A8,'Beam polarisation=',3F10.4/
59245      &            10X,A8,'Beam polarisation=',3F10.4)
59246         ENDIF
59247       ELSEIF (IPRO.GE.90.AND.IPRO.LE.99) THEN
59248         IF (IDB.GE.11.AND.IDB.LE.16) THEN
59249           CALL HWVZRO(3,PPOLN)
59250 C Check neutrino polarisations for DIS
59251           IF (IDB.EQ. 12.OR.IDB.EQ. 14.OR.IDB.EQ. 16.AND.
59252      &        EPOLN(3).NE.-ONE) EPOLN(3)=-ONE
59253           IF (IPRINT.NE.0) WRITE(6,380) PART1,EPOLN(3)
59254         ELSE
59255           CALL HWVZRO(3,EPOLN)
59256 C Check anti-neutrino polarisations for DIS
59257           IF (IDB.EQ.-12.OR.IDB.EQ.-14.OR.IDB.EQ.-16.AND.
59258      &        PPOLN(3).NE.ONE) PPOLN(3)=ONE
59259           IF (IPRINT.NE.0) WRITE(6,380) PART1,PPOLN(3)
59260         ENDIF
59261  380    FORMAT(/10X,A8,1X,'Longitudinal beam polarisation=',F10.4/)
59262       ENDIF
59263       IF (IPRINT.NE.0) THEN
59264         IF (ZPRIME) THEN
59265           WRITE(6,390) RMASS(200),RMASS(202),GAMZ,GAMZP
59266           WRITE(6,400) (RNAME(I),VFCH(I,1),AFCH(I,1),VFCH(I,2),
59267      &                  AFCH(I,2),I=1,6)
59268           WRITE(6,400) (RNAME(110+I),VFCH(I,1),AFCH(I,1),
59269      &                  VFCH(I,2),AFCH(I,2),I=11,16)
59270   390     FORMAT(/10X,'MASSIVE NEUTRAL VECTOR BOSON PARAMS'/
59271      &            10X,'Z   MASS=',F10.4,7X,'Z-PRIME MASS=',F10.4/
59272      &            10X,'   WIDTH=',F10.4,7X,'       WIDTH=',F10.4/
59273      &            10X,'FERMION COUPLINGS: e.(V.1+A.G_5)G_mu'/
59274      &            10X,'FERMION:  VECTOR     AXIAL',6X,
59275      &                'VECTOR     AXIAL'/)
59276   400     FORMAT(10X,A8,2X,F10.4,1X,F10.4,1X,F10.4,1X,F10.4)
59277         ENDIF
59278         IF (MIXING) THEN
59279           WRITE(6,410) XMIX(2),YMIX(2),XMIX(1),YMIX(1)
59280   410     FORMAT(/10X,'B_d: Delt-M/Gam =',F6.4,
59281      &                ' Delt-Gam/2*Gam =',F6.4,/
59282      &            10X,'B_s: Delt-M/Gam =',F6.2,
59283      &                ' Delt-Gam/2*Gam =',F6.4)
59284         ENDIF
59285         IF (CLRECO) WRITE(6,420) PRECO,EXAG
59286   420   FORMAT(/10X,'Colour rearrangement ALLOWED, probability =',F6.4,/
59287      &          10x,'Weak boson life-time exaggeration factor =',F10.6)
59288 C---PDF STRUCTURE FUNCTIONS
59289         WRITE (6,'(1X)')
59290         DO 450 I=1,2
59291           IF (MODPDF(I).GE.0) THEN
59292             WRITE (6,430) I,MODPDF(I),AUTPDF(I)
59293           ELSE
59294             WRITE (6,440) I
59295           ENDIF
59296  430      FORMAT(10X,'PDFLIB USED FOR BEAM',I2,': SET',I3,' OF ',A20)
59297  440      FORMAT(10X,'PDFLIB NOT USED FOR BEAM',I2)
59298  450    CONTINUE
59299 C---GET THE UGLY INITIALISATION MESSAGES OVER AND DONE WITH NOW TOO
59300         DO 460 I=1,2
59301           IF (MODPDF(I).GE.0) THEN
59302             PARM(1)=AUTPDF(I)
59303             VAL(1)=FLOAT(MODPDF(I))
59304             PARMSAVE=PARM(1)
59305             VALSAVE=VAL(1)
59306             FSTPDF=.TRUE.
59307             X=0.5
59308             QSCA=10
59309 C---FIX TO CALL SCHULER-SJOSTRAND CODE
59310             IF (AUTPDF(I).EQ.'SaSph') THEN
59311               ISET=MOD(MODPDF(I),10)
59312               IOP1=MOD(MODPDF(I)/10,2)
59313               IOP2=MOD(MODPDF(I)/20,2)
59314               IP2=MODPDF(I)/100
59315               IF (ISET.EQ.1) THEN
59316                 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1D'
59317               ELSEIF (ISET.EQ.2) THEN
59318                 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1M'
59319               ELSEIF (ISET.EQ.3) THEN
59320                 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2D'
59321               ELSEIF (ISET.EQ.4) THEN
59322                 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2M'
59323               ELSE
59324                 WRITE (6,'(10X,A)')'UNKNOWN SCHULER-SJOSTRAND PDF SET'
59325                 CALL HWWARN('HWUINC',500,*999)
59326               ENDIF
59327               IF (IOP1.EQ.1) THEN
59328                 WRITE (6,'(10X,A)') 'WITH DIRECT COMPONENT IN DIS'
59329                 IF (IPRO.NE.90) WRITE (6,'(10X,A)')
59330      $               'NOT RECOMMENDED FOR NON-DIS PROCESSES'
59331               ENDIF
59332               IF (IOP2.EQ.1) THEN
59333                 WRITE (6,'(10X,A)') 'WITH P**2 DEPENDENCE INCLUDED'
59334                 IF (PHOMAS.GT.ZERO)
59335      $          WRITE (6,'(10X,A)') 'NOT RECOMMENDED WITH PHOMAS.GT.0'
59336                 IF (IP2.GT.0)
59337      $          WRITE (6,'(10X,A,I2)') 'WITH IP2 OPTION EQUAL TO',IP2
59338               ENDIF
59339             ELSEIF (AUTPDF(I).EQ.'SSph') THEN
59340               WRITE (6,'(10X,A)') 'THE ACRONYM FOR SCHULER-SJOSTRAND'
59341               WRITE (6,'(10X,A)') 'HAS CHANGED TO SaSph ACCORDING TO'
59342               WRITE (6,'(10X,A)') 'THEIR WISHES.  SSph NO LONGER WORKS'
59343               STOP
59344             ELSE
59345               CALL PDFSET(PARM,VAL)
59346               CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
59347             ENDIF
59348           ENDIF
59349  460    CONTINUE
59350         WRITE (6,'(1X)')
59351       ENDIF
59352 C Set up neutral B meson mixing parameters
59353       IF (MIXING.AND..NOT.(RSTAB(223).AND.RSTAB(247))) THEN
59354         XMRCT(1)=XMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
59355         YMRCT(1)=YMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
59356       ENDIF
59357       IF (MIXING.AND..NOT.(RSTAB(221).AND.RSTAB(245))) THEN
59358         XMRCT(2)=XMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
59359         YMRCT(2)=YMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
59360       ENDIF
59361 C---B DECAY PACKAGE
59362       IF (BDECAY.EQ.'EURO') THEN
59363         IF (IPRINT.NE.0) WRITE (6,470) 'EURODEC'
59364       ELSEIF (BDECAY.EQ.'CLEO') THEN
59365         IF (IPRINT.NE.0) WRITE (6,470) 'CLEO'
59366       ELSE
59367         BDECAY='HERW'
59368       ENDIF
59369   470 FORMAT (10X,A,' B DECAY PACKAGE WILL BE USED')
59370 C---TAU DECAY PACKAGE
59371       IF(TAUDEC.EQ.'TAUOLA') THEN
59372         IF(IPRINT.NE.0) WRITE(6,475) 'TAUOLA'
59373         CALL HWDTAU(-1,0,0.0D0)
59374       ENDIF
59375   475 FORMAT(10X,A,' TAU DECAY PACKAGE WILL BE USED'/)
59376 C---COMPUTE PARTICLE PROPERTIES FOR HADRONIZATION
59377       CALL HWURES
59378 C Prepare internal decay tables and do diagnostic checks
59379       CALL HWUDKS
59380 C Convert ampersands to backslahes in particle LaTeX names
59381       CALL HWUATS
59382 C---MISCELLANEOUS DERIVED QUANTITIES
59383       TMTOP=2.*LOG(RMASS(6)/30.)
59384       PXRMS=PTRMS/SQRT(2.)
59385       ZBINM=0.25/ZBINM
59386       PSPLT(1)=1./PSPLT(1)
59387       PSPLT(2)=1./PSPLT(2)
59388       NDTRY=2*NCTRY
59389       NGSPL=0
59390       PGSMX=0.
59391       DO 480 I=1,4
59392       PGS=HWUPCM(RMASS(13),RMASS(I),RMASS(I))
59393       IF (PGS.GE.ZERO) NGSPL=I
59394       IF (PGS.GE.PGSMX) PGSMX=PGS
59395   480 PGSPL(I)=PGS
59396       CALL HWVZRO(6,PTINT)
59397       IF (IPRO.NE.80) THEN
59398 C---SET UP TABLES OF SUDAKOV FORM FACTORS, GIVING
59399 C   PROBABILITY DISTRIBUTION IN VARIABLE Q = E*SQRT(XI)
59400         NSUD=NFLAV
59401         CALL HWBSUD
59402 C---SET PARAMETERS FOR SPACELIKE BRANCHING
59403         DO 500 I=1,NSUD
59404         DO 490 J=2,NQEV
59405         IF (QEV(J,I).GT.QSPAC) GOTO 500
59406   490   CONTINUE
59407   500   NSPAC(I)=J-1
59408       ENDIF
59409       EVWGT=AVWGT
59410       ISTAT=1
59411 C--optimize the weights for the channels if needed
59412       CALL HWIPHS(2)
59413 C--perform the initialisation of the SUSY ME's
59414       IF(SYSPIN.OR.THREEB.OR.FOURB) THEN
59415         CALL HWISPN
59416         IF (IPRINT.NE.0) WRITE (6,510)
59417  510    FORMAT(/10X,'CHECKING SUSY DECAY MATRIX ELEMENTS')
59418       ENDIF
59419 C Print particle decay tables here
59420       IF (IPRINT.GE.2) CALL HWUDPR
59421 C--   initialise photos if needed
59422       IF ((TAUDEC.EQ.'TAUOLA'.AND.IFPHOT.EQ.1).OR.ITOPRD.EQ.1)
59423      &     CALL PHOINI
59424   999 END
59425 CDECK  ID>, HWUINE.
59426 *CMZ :-        -16/10/93  12.42.15  by  Mike Seymour
59427 *-- Author :    Bryan Webber
59428 C-----------------------------------------------------------------------
59429       SUBROUTINE HWUINE
59430 C-----------------------------------------------------------------------
59431 C     INITIALISES AN EVENT
59432 C-----------------------------------------------------------------------
59433       INCLUDE 'HERWIG65.INC'
59434       DOUBLE PRECISION HWRGEN,HWRGET,DUMMY
59435       REAL TL
59436       LOGICAL CALLED,HWRLOG
59437       EXTERNAL HWRGEN,HWRGET,HWRLOG
59438       COMMON/HWDBUG/CALLED
59439 C---CHECK THAT MAIN PROGRAM HAS BEEN MODIFIED CORRECTLY
59440       IF (NEVHEP.GT.0.AND..NOT.CALLED) THEN
59441         WRITE (6,10)
59442  10     FORMAT (1X,'A call to the subroutine HWUFNE should be added to',
59443      &      /,' the main program, immediately after the call to HWMEVT')
59444         CALL HWWARN('HWUINE',500,*999)
59445       ENDIF
59446       CALLED=.FALSE.
59447 C---CHECK TIME LEFT
59448       CALL HWUTIM(TL)
59449       IF (TL.LT.TLOUT) CALL HWWARN('HWUINE',200,*999)
59450 C---UPDATE RANDOM NUMBER SEED
59451       DUMMY = HWRGET(NRN)
59452       NEVHEP=NEVHEP+1
59453       IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV+1
59454       NHEP=0
59455       ISTAT=6
59456       IERROR=0
59457       EVWGT=AVWGT
59458       HVFCEN=.FALSE.
59459       ISLENT=1
59460       NQDK=0
59461 C---DECIDE WHETHER TO GENERATE SOFT UNDERLYING EVENT
59462       GENSOF=IPROC.GE.1300.AND.IPROC.LT.10000.AND.
59463      &      (IPROC.EQ.8000.OR.HWRLOG(PRSOF))
59464 C Zero arrays
59465       CALL HWVZRI(2*NMXHEP,JMOHEP)
59466       CALL HWVZRI(2*NMXHEP,JDAHEP)
59467       CALL HWVZRO(4*NMXHEP,VHEP)
59468       CALL HWVZRO(3*NMXHEP,RHOHEP)
59469       EMSCA=ZERO
59470       IF(SYSPIN) THEN
59471         NSPN = 0
59472         CALL HWVZRI(  NMXHEP,ISNHEP)
59473         CALL HWVZRI(  NMXSPN,JMOSPN)
59474         CALL HWVZRI(2*NMXSPN,JDASPN)
59475         CALL HWVZRI(  NMXSPN, IDSPN)
59476       ENDIF
59477   999 END
59478 CDECK  ID>, HWULB4.
59479 *CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
59480 *-- Author :    Adapted by Bryan Webber
59481 C-----------------------------------------------------------------------
59482       SUBROUTINE HWULB4(PS,PI,PF)
59483 C-----------------------------------------------------------------------
59484 C     TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
59485 C     N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
59486 C-----------------------------------------------------------------------
59487       DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
59488       IF (PS(4).EQ.PS(5)) THEN
59489         PF(1)= PI(1)
59490         PF(2)= PI(2)
59491         PF(3)= PI(3)
59492         PF(4)= PI(4)
59493       ELSE
59494         PF4  = (PI(1)*PS(1)+PI(2)*PS(2)
59495      &         +PI(3)*PS(3)+PI(4)*PS(4))/PS(5)
59496         FN   = (PF4+PI(4)) / (PS(4)+PS(5))
59497         PF(1)= PI(1) + FN*PS(1)
59498         PF(2)= PI(2) + FN*PS(2)
59499         PF(3)= PI(3) + FN*PS(3)
59500         PF(4)= PF4
59501       END IF
59502       END
59503 CDECK  ID>, HWULDO.
59504 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
59505 *-- Author :    Bryan Webber
59506 C----------------------------------------------------------------------
59507       FUNCTION HWULDO(P,Q)
59508 C----------------------------------------------------------------------
59509 C   LORENTZ 4-VECTOR DOT PRODUCT
59510 C----------------------------------------------------------------------
59511       DOUBLE PRECISION HWULDO,P(4),Q(4)
59512       HWULDO=P(4)*Q(4)-(P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3))
59513       END
59514 CDECK  ID>, HWULF4.
59515 *CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
59516 *-- Author :    Adapted by Bryan Webber
59517 C-----------------------------------------------------------------------
59518       SUBROUTINE HWULF4(PS,PI,PF)
59519 C-----------------------------------------------------------------------
59520 C     TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
59521 C     N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
59522 C-----------------------------------------------------------------------
59523       DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
59524       IF (PS(4).EQ.PS(5)) THEN
59525         PF(1)= PI(1)
59526         PF(2)= PI(2)
59527         PF(3)= PI(3)
59528         PF(4)= PI(4)
59529       ELSE
59530         PF4  = (PI(4)*PS(4)-PI(3)*PS(3)
59531      &         -PI(2)*PS(2)-PI(1)*PS(1))/PS(5)
59532         FN   = (PF4+PI(4)) / (PS(4)+PS(5))
59533         PF(1)= PI(1) - FN*PS(1)
59534         PF(2)= PI(2) - FN*PS(2)
59535         PF(3)= PI(3) - FN*PS(3)
59536         PF(4)= PF4
59537       END IF
59538       END
59539 CDECK  ID>, HWULI2.
59540 *CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
59541 *-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
59542 C-----------------------------------------------------------------------
59543       FUNCTION HWULI2(X)
59544 C-----------------------------------------------------------------------
59545 C     Complex dilogarithm function, Li_2 (Spence function)
59546 C-----------------------------------------------------------------------
59547       IMPLICIT NONE
59548       DOUBLE COMPLEX HWULI2,PROD,Y,Y2,X,Z
59549       DOUBLE PRECISION XR,XI,R2,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2,
59550      & ZERO,ONE,HALF
59551       PARAMETER (ZERO=0.0D0, ONE=1.0D0, HALF=0.5D0)
59552       DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2/ -0.250000000000000D0,
59553      & -0.111111111111111D0,-0.010000000000000D0,-0.017006802721088D0,
59554      & -0.019444444444444D0,-0.020661157024793D0,-0.021417300648069D0,
59555      & -0.021948866377231D0,-0.022349233811171D0,-0.022663689135191D0,
59556      &  1.644934066848226D0/
59557       PROD(Y,Y2)=Y*(ONE+A1*Y*(ONE+A2*Y*(ONE+A3*Y2*(ONE+A4*Y2*(ONE+A5*Y2*
59558      & (ONE+A6*Y2*(ONE+A7*Y2*(ONE+A8*Y2*(ONE+A9*Y2*(ONE+A10*Y2))))))))))
59559       XR=DREAL(X)
59560       XI=DIMAG(X)
59561       R2=XR*XR+XI*XI
59562       IF (R2.GT.ONE.AND.(XR/R2).GT.HALF) THEN
59563          Z=-LOG(ONE/X)
59564          HWULI2=PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)+HALF*LOG(X)**2
59565       ELSEIF (R2.GT.ONE.AND.(XR/R2).LE.HALF) THEN
59566          Z=-LOG(ONE-ONE/X)
59567          HWULI2=-PROD(Z,Z*Z)-ZETA2-HALF*LOG(-X)**2
59568       ELSEIF (R2.EQ.ONE.AND.XI.EQ.ZERO) THEN
59569          HWULI2=ZETA2
59570       ELSEIF (R2.LE.ONE.AND.XR.GT.HALF) THEN
59571          Z=-LOG(X)
59572          HWULI2=-PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)
59573       ELSE
59574          Z=-LOG(ONE-X)
59575          HWULI2=PROD(Z,Z*Z)
59576       ENDIF
59577       END
59578 CDECK  ID>, HWULOB.
59579 *CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
59580 *-- Author :    Adapted by Bryan Webber
59581 C-----------------------------------------------------------------------
59582       SUBROUTINE HWULOB(PS,PI,PF)
59583 C-----------------------------------------------------------------------
59584 C     TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
59585 C     N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
59586 C-----------------------------------------------------------------------
59587       DOUBLE PRECISION PS(5),PI(5),PF(5)
59588       CALL HWULB4(PS,PI,PF)
59589       PF(5)= PI(5)
59590       END
59591 CDECK  ID>, HWULOF.
59592 *CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
59593 *-- Author :    Adapted by Bryan Webber
59594 C-----------------------------------------------------------------------
59595       SUBROUTINE HWULOF(PS,PI,PF)
59596 C-----------------------------------------------------------------------
59597 C     TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
59598 C     N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
59599 C-----------------------------------------------------------------------
59600       DOUBLE PRECISION PS(5),PI(5),PF(5)
59601       CALL HWULF4(PS,PI,PF)
59602       PF(5)= PI(5)
59603       END
59604 CDECK  ID>, HWULOR.
59605 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
59606 *-- Author :    Giovanni Abbiendi & Luca Stanco
59607 C-----------------------------------------------------------------------
59608       SUBROUTINE HWULOR (TRANSF,PI,PF)
59609 C-----------------------------------------------------------------------
59610 C     Makes the HWULOR transformation specified by TRANSF on the
59611 C     quadrivector PI(5), giving PF(5).
59612 C-----------------------------------------------------------------------
59613       DOUBLE PRECISION TRANSF(4,4),PI(5),PF(5)
59614       INTEGER I,J
59615       DO 1 I=1,5
59616         PF(I)=0.D0
59617     1 CONTINUE
59618       DO 3 I=1,4
59619        DO 2 J=1,4
59620          PF(I) = PF(I) + TRANSF(I,J) * PI(J)
59621     2  CONTINUE
59622     3 CONTINUE
59623       PF(5) = PI(5)
59624       RETURN
59625       END
59626 CDECK  ID>, HWUMAS.
59627 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
59628 *-- Author :    Bryan Webber
59629 C-----------------------------------------------------------------------
59630       SUBROUTINE HWUMAS(P)
59631 C-----------------------------------------------------------------------
59632 C     PUTS INVARIANT MASS IN 5TH COMPONENT OF VECTOR
59633 C     (NEGATIVE SIGN IF SPACELIKE)
59634 C-----------------------------------------------------------------------
59635       DOUBLE PRECISION HWUSQR,P(5)
59636       EXTERNAL HWUSQR
59637       P(5)=HWUSQR((P(4)+P(3))*(P(4)-P(3))-P(1)**2-P(2)**2)
59638       END
59639 CDECK  ID>, HWUMBW.
59640 *CMZ :-        -21/02/98  11.11.56  by  Bryan Webber
59641 *-- Author :    Bryan Webber
59642 C-----------------------------------------------------------------------
59643       FUNCTION HWUMBW(ID)
59644 C-----------------------------------------------------------------------
59645 C     CHOOSES MASS ACCORDING TO BREIT-WIGNER DISTRIBUTION
59646 C--BRW fix 27/8/04: changed from mass to mass-squared BW formula
59647 C-----------------------------------------------------------------------
59648       INCLUDE 'HERWIG65.INC'
59649       DOUBLE PRECISION HWUMBW,HWRGEN,WMX,TAU,GAM,T,TM
59650       INTEGER ID
59651 C--WMX IS MAX NUMBER OF WIDTHS FROM NOMINAL MASS
59652       WMX=GAMMAX
59653       HWUMBW=RMASS(ID)
59654       IF(ID.EQ.198.OR.ID.EQ.199) THEN
59655         TAU = HBAR/GAMW
59656       ELSEIF(ID.EQ.200) THEN
59657         TAU = HBAR/GAMZ
59658       ELSEIF(ID.EQ.201) THEN
59659         TAU = HBAR/GAMH
59660       ELSE
59661         TAU=RLTIM(ID)
59662       ENDIF
59663       IF (TAU.EQ.ZERO.OR.TAU.GT.1D-18) RETURN
59664       GAM=HBAR/TAU
59665  1    T=TAN(PIFAC*(HWRGEN(0)-HALF))
59666       TM=RMASS(ID)*(RMASS(ID)+GAM*T)
59667       IF(TM.LT.ZERO) GOTO 1
59668       TM=SQRT(TM)
59669       IF (ABS(TM-RMASS(ID)).GT.WMX*GAM) GOTO 1
59670       HWUMBW=TM
59671       END
59672 CDECK  ID>, HWUNST.
59673 *CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
59674 *-- Author :    Ian Knowles
59675 C-----------------------------------------------------------------------
59676       FUNCTION HWUNST(N)
59677 C-----------------------------------------------------------------------
59678 C     Creates a character string of length 7 equivalent to integer N
59679 C-----------------------------------------------------------------------
59680       INTEGER N,I,M,NN(7)
59681       CHARACTER*1 NCHAR(0:9)
59682       CHARACTER*7 HWUNST
59683       DATA NCHAR/'0','1','2','3','4','5','6','7','8','9'/
59684       M=1
59685       DO 10 I=7,1,-1
59686       NN(I)=MOD(N/M,10)
59687   10  M=M*10
59688       WRITE(HWUNST,'(7A1)') (NCHAR(NN(I)),I=1,7)
59689       RETURN
59690       END
59691 CDECK  ID>, HWUPCM.
59692 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
59693 *-- Author :    Bryan Webber
59694 C-----------------------------------------------------------------------
59695       FUNCTION HWUPCM(EM0,EM1,EM2)
59696 C-----------------------------------------------------------------------
59697 C     C.M. MOMENTUM FOR DECAY MASSES EM0 -> EM1 + EM2
59698 C     SET TO -1 BELOW THRESHOLD
59699 C-----------------------------------------------------------------------
59700       DOUBLE PRECISION HWUPCM,EM0,EM1,EM2,EMS,EMD
59701       EMS=ABS(EM1+EM2)
59702       EMD=ABS(EM1-EM2)
59703       IF (EM0.LT.EMS.OR.EM0.LT.EMD) THEN
59704         HWUPCM=-1.
59705       ELSEIF (EM0.EQ.EMS.OR.EM0.EQ.EMD) THEN
59706         HWUPCM=0.
59707       ELSE
59708         HWUPCM=SQRT((EM0+EMD)*(EM0-EMD)*
59709      &              (EM0+EMS)*(EM0-EMS))*.5/EM0
59710       ENDIF
59711       END
59712 CDECK  ID>, HWURAP.
59713 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
59714 *-- Author :    Bryan Webber
59715 C-----------------------------------------------------------------------
59716       FUNCTION HWURAP(P)
59717 C-----------------------------------------------------------------------
59718 C     LONGITUDINAL RAPIDITY (SET TO +/-1000 IF TOO LARGE)
59719 C-----------------------------------------------------------------------
59720       DOUBLE PRECISION HWURAP,EMT2,P(5),ZERO
59721       PARAMETER (ZERO=0.D0)
59722       EMT2=P(1)**2+P(2)**2+P(5)**2
59723       IF (P(3).GT.ZERO) THEN
59724         IF (EMT2.EQ.ZERO) THEN
59725           HWURAP=1000.
59726         ELSE
59727           HWURAP= 0.5*LOG((P(3)+P(4))**2/EMT2)
59728         ENDIF
59729       ELSEIF (P(3).LT.ZERO) THEN
59730         IF (EMT2.EQ.ZERO) THEN
59731           HWURAP=-1000.
59732         ELSE
59733           HWURAP=-0.5*LOG((P(3)-P(4))**2/EMT2)
59734         ENDIF
59735       ELSE
59736           HWURAP=0.
59737       ENDIF
59738       END
59739 CDECK  ID>, HWUMPO.
59740 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
59741 *-- Author :  Kosuke Odagiri
59742 C-----------------------------------------------------------------------
59743       SUBROUTINE HWUMPO(P,M,PMM,MGAM,PPROJ,FPROP)
59744 C-----------------------------------------------------------------------
59745 C     RETURNS PROJECTION OPERATOR 1/(P-SLASH - M + I*MGAM) IN WEYL-BASIS
59746 C     USED IN SUBROUTINE HWH2QH
59747 C-----------------------------------------------------------------------
59748       DOUBLE PRECISION P(0:3),M,PMM,MGAM,ZERO,ONE
59749       DOUBLE COMPLEX PROP, PPROJ(4,4), CZERO
59750       LOGICAL FPROP
59751       PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),ONE=1.D0)
59752       IF (FPROP) THEN
59753        PROP=ONE/DCMPLX(PMM,MGAM)
59754       ELSE
59755        PROP=DCMPLX(ONE/PMM, ZERO)
59756       END IF
59757       PPROJ(1,1) =  M*PROP
59758       PPROJ(1,2) =  CZERO
59759       PPROJ(2,1) =  CZERO
59760       PPROJ(2,2) =  PPROJ(1,1)
59761       PPROJ(1,3) = (P(0)-P(3))*PROP
59762       PPROJ(1,4) =  DCMPLX(-P(1),P(2))*PROP
59763       PPROJ(2,3) =  DCMPLX(-P(1),-P(2))*PROP
59764       PPROJ(2,4) = (P(0)+P(3))*PROP
59765       PPROJ(3,1) =  PPROJ(2,4)
59766       PPROJ(3,2) = -PPROJ(1,4)
59767       PPROJ(4,1) = -PPROJ(2,3)
59768       PPROJ(4,2) =  PPROJ(1,3)
59769       PPROJ(3,3) =  PPROJ(1,1)
59770       PPROJ(3,4) =  CZERO
59771       PPROJ(4,3) =  CZERO
59772       PPROJ(4,4) =  PPROJ(1,1)
59773       RETURN
59774       END
59775 CDECK  ID>, HWUMPP.
59776 *CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
59777 *-- Author :  Kosuke Odagiri
59778 C-----------------------------------------------------------------------
59779       SUBROUTINE HWUMPP(M,GPM,PERM,U,UU,LR)
59780 C-----------------------------------------------------------------------
59781 C     APPLIES OPERATOR FROM HWUMPO ON SPINORS.
59782 C     SPINOR COMPONENTS CAN BE PERMUTATED (PERM) AND TRANSVERSED (LR)
59783 C-----------------------------------------------------------------------
59784       DOUBLE COMPLEX U(4), TEMP, A(4,4), M(16), UU(4), CZERO
59785       DOUBLE PRECISION GPM(2), FAC, ZERO, ONE, MONE
59786       INTEGER LR,TV(4,4,2),I,J, PERM(4), IZERO, GTOF(4)
59787       PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),IZERO=0)
59788       PARAMETER (ONE =1.D0,MONE = -1.D0)
59789       DATA GTOF/1,1,2,2/
59790       DATA TV/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,
59791      &        1,5,9,13,2,6,10,14,3,7,11,15,4,8,12,16/
59792       SAVE GTOF
59793       DO I=1,4
59794        FAC = GPM(GTOF(I))
59795        IF ((PERM(I).EQ.IZERO).OR.(FAC.EQ.ZERO)) THEN
59796         DO J=1,4
59797          A(I,J)=CZERO
59798         END DO
59799        ELSE
59800         IF(FAC.EQ.ONE) THEN
59801          TEMP = U(PERM(I))
59802         ELSEIF(FAC.EQ.MONE) THEN
59803          TEMP = -U(PERM(I))
59804         ELSE
59805          TEMP = FAC*U(PERM(I))
59806         ENDIF
59807         IF(TEMP.NE.ZERO) THEN
59808          DO J=1,4
59809           IF(M(TV(I,J,LR)).NE.ZERO) THEN
59810            A(I,J)=TEMP*M(TV(I,J,LR))
59811           ELSE
59812            A(I,J)=ZERO
59813           ENDIF
59814          END DO
59815         ELSE
59816          DO J=1,4
59817           A(I,J)=ZERO
59818          END DO
59819         END IF
59820        END IF
59821       END DO
59822       DO J=1,4
59823        UU(J)=A(1,J)+A(2,J)+A(3,J)+A(4,J)
59824       END DO
59825       RETURN
59826       END
59827 CDECK  ID>, HWUPUP.
59828 *CMZ :-        -13/02/02  16.42.23  by  Peter Richardson
59829 *-- Author :    Bryan Webber
59830 C----------------------------------------------------------------------
59831       SUBROUTINE HWUPUP
59832 C----------------------------------------------------------------------
59833 C     Prints contents of the GUPI (Generic User Process Interface)
59834 C     common block HEPEUP
59835 C----------------------------------------------------------------------
59836       INCLUDE 'HERWIG65.INC'
59837       INTEGER MAXNUP
59838       PARAMETER (MAXNUP=500)
59839       INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
59840       DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
59841       COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
59842      &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
59843      &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
59844      &              SPINUP(MAXNUP)
59845       INTEGER IUP,IWIG,I
59846       CHARACTER*8 NAME
59847       PRINT *
59848       PRINT *, ' I ISTUP IDUP NAME  MOTHUP ICOLUP     PUP'
59849       DO IUP=1,NUP
59850         CALL HWUIDT(1,IDUP(IUP),IWIG,NAME)
59851         PRINT 11,IUP,ISTUP(IUP),IDUP(IUP),NAME,MOTHUP(1,IUP),
59852      &  MOTHUP(2,IUP),ICOLUP(1,IUP),ICOLUP(2,IUP),(PUP(I,IUP),I=1,5)
59853       Enddo
59854  11   Format(2I3,I4,2X,A8,2I3,2I4,5F8.1)
59855       End
59856 CDECK  ID>, HWURES.
59857 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
59858 *-- Author :    Ian Knowles & Bryan Webber
59859 C-----------------------------------------------------------------------
59860       SUBROUTINE HWURES
59861 C-----------------------------------------------------------------------
59862 C     Using properties of particle I supplied in HWUDAT checks particles
59863 C     and antiparticles have compatible properties and sets   SWTEF(I) =
59864 C     ( rep. enhancement factor)^2  - used in cluster decays
59865 C     Finds iso-flavour hadrons and creates pointers for cluster decays.
59866 C     Sets CLDKWT(K) =(2J+1) spin weight normalizing largest value to 1.
59867 C-----------------------------------------------------------------------
59868       INCLUDE 'HERWIG65.INC'
59869       INTEGER NMXTMP
59870       PARAMETER (NMXTMP=20)
59871       DOUBLE PRECISION EPS,WTMX,REMMN,RWTMX,WTMP,RESTMP(91),WTMX2,
59872      & REMMN2,WT,CDWTMP(NMXTMP)
59873       INTEGER HWUANT,MAPF(89),MAPC(12,12),I,IANT,IABPDG,J,L,N,K,LTMP,
59874      & NCDKS,IMN,ITMP,LOCTMP(91),NTMP,NCDTMP(NMXTMP),IMN2
59875       EXTERNAL HWUANT
59876       PARAMETER (EPS=1.D-6)
59877       DATA MAPF/21,31,41,51,61,12,32,42,52,62,13,23,43,53,63,14,24,34,
59878      & 44,54,64,15,25,35,45,55,65,16,26,36,46,56,66,111,112,113,122,123,
59879      & 133,222,223,233,333,-111,-112,-113,-122,-123,-133,-222,-223,-233,
59880      & -333,114,124,134,224,234,334,-114,-124,-134,-224,-234,-334,115,
59881      & 125,135,225,235,335,-115,-125,-135,-225,-235,-335,116,126,136,
59882      & 226,236,336,-116,-126,-136,-226,-236,-336/
59883       DATA MAPC/90,1,2,47,45,44,48,46,49,3,4,5,6,90,7,50,47,45,51,48,52,
59884      & 8,9,10,11,12,91,51,48,46,52,49,53,13,14,15,37,40,41,6*0,57,69,81,
59885      & 35,37,38,6*0,55,67,79,34,35,36,6*0,54,66,78,38,41,42,6*0,58,70,
59886      & 82,36,38,39,6*0,56,68,80,39,42,43,6*0,59,71,83,16,17,18,63,61,60,
59887      & 64,62,65,19,20,21,22,23,24,75,73,72,76,74,77,25,26,27,28,29,30,
59888      & 87,85,84,88,86,89,31,32,33/
59889 C Check particle/anti-particle properties are compatible
59890       WRITE(6,10)
59891   10  FORMAT(/10X,'Checking consistency of particle properties'/)
59892       DO 20 I=10,NRES
59893       IF (IDPDG(I).GT.0) THEN
59894         IANT=HWUANT(I)
59895         IF (IANT.EQ.20) GOTO 20
59896         IF (MOD(IDPDG(I)/1000,10).EQ.0.AND.
59897      &      MOD(IDPDG(I)/100 ,10).NE.0) THEN
59898           IF (MOD(IFLAV(I)/10-IFLAV(IANT),10).NE.0.OR.
59899      &        MOD(IFLAV(I)-IFLAV(IANT)/10,10).NE.0)
59900      &     WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
59901         ELSE
59902           IF (IFLAV(I)+IFLAV(IANT).NE.0)
59903      &     WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
59904         ENDIF
59905         IF (ICHRG(I)+ICHRG(IANT).NE.0)
59906      &   WRITE(6,40) RNAME(I),RNAME(IANT),ICHRG(I),ICHRG(IANT)
59907         IF (ABS(RMASS(I)-RMASS(IANT)).GT.EPS)
59908      &   WRITE(6,50) RNAME(I),RMASS(I),RMASS(IANT)
59909         IF (ABS(RLTIM(I)-RLTIM(IANT)).GT.EPS)
59910      &   WRITE(6,60) RNAME(I),RLTIM(I),RLTIM(IANT)
59911         IF (ABS(RSPIN(I)-RSPIN(IANT)).GT.EPS)
59912      &   WRITE(6,70) RNAME(I),RSPIN(I),RSPIN(IANT)
59913       ENDIF
59914   20  CONTINUE
59915   30  FORMAT(10X,A8,' flavour code=',I4,5X,' antiparticle=',I4)
59916   40  FORMAT(10X,2A8,' charge      =',I2,7X,' antiparticle=',I2)
59917   50  FORMAT(10X,A8,' mass        =',F7.3,2X,' antiparticle=',F7.3)
59918   60  FORMAT(10X,A8,' life time   =',E9.3,' antiparticle=',E9.3)
59919   70  FORMAT(10X,A8,' spin        =',F3.1,6X,' antiparticle=',F3.1)
59920 C Compute resonance properties
59921       DO 80 I=21,NRES
59922 C Compute representation weights for hadrons, used in cluster decays
59923       IABPDG=ABS(IDPDG(I))
59924       J=MOD(IABPDG,10)
59925       IF (J.EQ.2.AND.MOD(IABPDG/100,10).LT.MOD(IABPDG/10,10)) THEN
59926 C Singlet (Lambda-like) baryon
59927         SWTEF(I)=SNGWT**2
59928       ELSEIF (J.EQ.4) THEN
59929 C Decuplet baryon
59930         SWTEF(I)=DECWT**2
59931       ELSEIF(2*(J/2).NE.J) THEN
59932 C Mesons: identify by spin, angular momentum & radial excitation
59933         J=(J-1)/2
59934         L= MOD(IABPDG/10000 ,10)
59935         N= MOD(IABPDG/100000,10)
59936         IF (L.EQ.0.AND.J.EQ.0.AND.N.EQ.0.OR.
59937      &      L.GT.3.OR. J.GT.4.OR .N.GT.4) THEN
59938           SWTEF(I)=1.
59939         ELSE
59940           SWTEF(I)=REPWT(L,J,N)**2
59941         ENDIF
59942       ELSE
59943 C Not recognized
59944         SWTEF(I)=1.
59945       ENDIF
59946   80  CONTINUE
59947 C Prepare tables for cluster decays, except flavourless light mesons
59948       LTMP=1
59949       NCDKS=0
59950       DO 120 I=1,89
59951 C Store particles, flavour MAPF(I), noting highest spin and lowest mass
59952       WTMX=0.
59953       REMMN=1000.
59954       DO 90 J=21,NRES
59955       IF (VTOCDK(J).OR.IFLAV(J).NE.MAPF(I)) GOTO 90
59956       NCDKS=NCDKS+1
59957       IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',101,*999)
59958       NCLDK(NCDKS)=J
59959       CLDKWT(NCDKS)=TWO*RSPIN(J)+ONE
59960       IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
59961       IF (RMASS(J).LT.REMMN) THEN
59962         REMMN=RMASS(J)
59963         IMN=NCDKS
59964       ENDIF
59965   90  CONTINUE
59966       IF (NCDKS+1-LTMP.EQ.0) THEN
59967         WRITE(6,100) MAPF(I)
59968   100   FORMAT(1X,'No particles exist for a cluster with flavour, ',I4,
59969      &            ' to decay into')
59970         CALL HWWARN('HWURES',51,*120)
59971       ENDIF
59972 C Set scaled spin weights
59973       RWTMX=1./WTMX
59974       DO 110 J=LTMP,NCDKS
59975   110 CLDKWT(J)=CLDKWT(J)*RWTMX
59976 C Swap order if lightest hadron of given flavour not first
59977       IF (IMN.NE.LTMP) THEN
59978         ITMP=NCLDK(LTMP)
59979         WTMP=CLDKWT(LTMP)
59980         NCLDK(LTMP)=NCLDK(IMN)
59981         CLDKWT(LTMP)=CLDKWT(IMN)
59982         NCLDK(IMN)=ITMP
59983         CLDKWT(IMN)=WTMP
59984       ENDIF
59985 C Set pointers etc
59986       LOCTMP(I)=LTMP
59987       RESTMP(I)=FLOAT(NCDKS+1-LTMP)
59988       LTMP=NCDKS+1
59989   120 CONTINUE
59990 C Now do flavourless light mesons, allowing for mixing in weights
59991       WTMX=0.
59992       REMMN=1000.
59993       WTMX2=0.
59994       REMMN2=1000.
59995       NTMP=0
59996       DO 140 J=21,NRES
59997       IF (VTOCDK(J)) THEN
59998         GOTO 140
59999 C Calculate mixing weight for (|uubar>+|ddbar>)/sqrt(2) component
60000       ELSEIF (IFLAV(J).EQ.11) THEN
60001         WT=1.
60002       ELSEIF (IFLAV(J).EQ.33) THEN
60003 C eta - eta'
60004         IF     (J.EQ.22 ) THEN
60005           WT=COS(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60006         ELSEIF (J.EQ.25 ) THEN
60007           WT=SIN(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60008 C phi - omega
60009         ELSEIF (J.EQ.56 ) THEN
60010           WT=COS(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60011         ELSEIF (J.EQ.24 ) THEN
60012           WT=SIN(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60013 C f'_2 - f_2
60014         ELSEIF (J.EQ.58 ) THEN
60015           WT=COS(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60016         ELSEIF (J.EQ.26 ) THEN
60017           WT=SIN(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60018 C f_1(1420) - f_1(1285)
60019         ELSEIF (J.EQ.57 ) THEN
60020           WT=COS(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60021         ELSEIF (J.EQ.28 ) THEN
60022           WT=SIN(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60023 C h_1(1380) - h_1(1170)
60024         ELSEIF (J.EQ.289) THEN
60025           WT=COS(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60026         ELSEIF (J.EQ.288) THEN
60027           WT=SIN(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60028 C MISSING - f_0(1370)
60029         ELSEIF (J.EQ.294) THEN
60030           WT=SIN(F0MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
60031 C phi_3 - omega_3
60032         ELSEIF (J.EQ.396) THEN
60033           WT=COS(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60034         ELSEIF (J.EQ.395) THEN
60035           WT=SIN(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60036 C eta_2(1645) - eta_2(1870)
60037         ELSEIF (J.EQ.397) THEN
60038           WT=COS(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60039         ELSEIF (J.EQ.398) THEN
60040           WT=SIN(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60041 C MISSING - omega(1600)
60042         ELSEIF (J.EQ.399) THEN
60043           WT=SIN(OMHMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
60044         ELSE
60045           WT=1./3.
60046           WRITE(6,130) J
60047   130   FORMAT(1X,'Isoscalar particle ',I3,' not recognised,',
60048      &            ' no I=0 mixing assumed')
60049         ENDIF
60050       ELSE
60051         GOTO 140
60052       ENDIF
60053       IF (WT.GT.EPS) THEN
60054         NCDKS=NCDKS+1
60055         IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',102,*999)
60056         NCLDK(NCDKS)=J
60057         CLDKWT(NCDKS)=WT*(TWO*RSPIN(J)+ONE)
60058         IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
60059         IF (RMASS(J).LT.REMMN) THEN
60060           REMMN=RMASS(J)
60061           IMN=NCDKS
60062         ENDIF
60063       ENDIF
60064       IF (ONE-WT.GT.EPS) THEN
60065         NTMP=NTMP+1
60066         IF (NTMP.GT.NMXTMP) CALL HWWARN('HWURES',103,*999)
60067         NCDTMP(NTMP)=J
60068         CDWTMP(NTMP)=(ONE-WT)*(TWO*RSPIN(J)+ONE)
60069         IF (CDWTMP(NTMP).GT.WTMX2) WTMX2=CDWTMP(NTMP)
60070         IF (RMASS(J).LT.REMMN2) THEN
60071           REMMN2=RMASS(J)
60072           IMN2=NTMP
60073         ENDIF
60074       ENDIF
60075   140 CONTINUE
60076       IF (NCDKS+1-LTMP.EQ.0) THEN
60077         WRITE(6,100) 11
60078         CALL HWWARN('HWURES',52,*160)
60079       ENDIF
60080 C Normalize scaled spin weights
60081       RWTMX=1./WTMX
60082       DO 150 I=LTMP,NCDKS
60083   150 CLDKWT(I)=CLDKWT(I)*RWTMX
60084 C Swap order if lightest hadron of flavour 11 not first
60085       IF (IMN.NE.LTMP) THEN
60086         ITMP=NCLDK(LTMP)
60087         WTMP=CLDKWT(LTMP)
60088         NCLDK(LTMP)=NCLDK(IMN)
60089         CLDKWT(LTMP)=CLDKWT(IMN)
60090         NCLDK(IMN)=ITMP
60091         CLDKWT(IMN)=WTMP
60092       ENDIF
60093   160 IF (NTMP.EQ.0) THEN
60094         WRITE(6,100) 33
60095         CALL HWWARN('HWURES',53,*180)
60096       ENDIF
60097       IF (NCDKS+NTMP.GT.NMXCDK) CALL HWWARN('HWURES',104,*999)
60098 C Store hadrons for |ssbar> channel and normalize their weights
60099       RWTMX=1./WTMX2
60100       DO 170 I=1,NTMP
60101       J=NCDKS+I
60102       NCLDK(J)=NCDTMP(I)
60103   170 CLDKWT(J)=CDWTMP(I)*RWTMX
60104 C Swap order if lightest hadron of flavour 33 not first
60105       IF (IMN2.NE.1) THEN
60106         ITMP=NCLDK(NCDKS+1)
60107         WTMP=CLDKWT(NCDKS+1)
60108         NCLDK(NCDKS+1)=NCLDK(NCDKS+IMN2)
60109         CLDKWT(NCDKS+1)=CLDKWT(NCDKS+IMN2)
60110         NCLDK(NCDKS+IMN2)=ITMP
60111         CLDKWT(NCDKS+IMN2)=WTMP
60112       ENDIF
60113 C Set pointers etc
60114   180 LOCTMP(90)=LTMP
60115       RESTMP(90)=FLOAT(NCDKS+1-LTMP)
60116       LOCTMP(91)=NCDKS+1
60117       RESTMP(91)=FLOAT(NTMP)
60118 C Set pointers to hadrons of given flavours for cluster decays
60119       DO 190 I=1,12
60120       DO 190 J=1,12
60121       K=MAPC(I,J)
60122       IF (K.EQ.0) THEN
60123         LOCN(I,J)=0
60124         RESN(I,J)=0
60125         RMIN(I,J)=MIN(RMASS(NCLDK(LOCN(I,1)))+RMASS(NCLDK(LOCN(1,J))),
60126      $       RMASS(NCLDK(LOCN(I,2)))+RMASS(NCLDK(LOCN(2,J))))+1.D-2
60127       ELSE
60128         LOCN(I,J)=LOCTMP(K)
60129         RESN(I,J)=RESTMP(K)
60130         RMIN(I,J)=RMASS(NCLDK(LOCN(I,J)))
60131       ENDIF
60132   190 CONTINUE
60133   999 END
60134 CDECK  ID>, HWUROB.
60135 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60136 *-- Author :    Bryan Webber
60137 C-----------------------------------------------------------------------
60138       SUBROUTINE HWUROB(R,P,Q)
60139 C-----------------------------------------------------------------------
60140 C     ROTATES VECTORS BY INVERSE OF ROTATION MATRIX R
60141 C-----------------------------------------------------------------------
60142       DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
60143       S1=P(1)*R(1,1)+P(2)*R(2,1)+P(3)*R(3,1)
60144       S2=P(1)*R(1,2)+P(2)*R(2,2)+P(3)*R(3,2)
60145       S3=P(1)*R(1,3)+P(2)*R(2,3)+P(3)*R(3,3)
60146       Q(1)=S1
60147       Q(2)=S2
60148       Q(3)=S3
60149       END
60150 CDECK  ID>, HWUROF.
60151 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60152 *-- Author :    Bryan Webber
60153 C-----------------------------------------------------------------------
60154       SUBROUTINE HWUROF(R,P,Q)
60155 C-----------------------------------------------------------------------
60156 C     ROTATES VECTORS BY ROTATION MATRIX R
60157 C-----------------------------------------------------------------------
60158       DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
60159       S1=R(1,1)*P(1)+R(1,2)*P(2)+R(1,3)*P(3)
60160       S2=R(2,1)*P(1)+R(2,2)*P(2)+R(2,3)*P(3)
60161       S3=R(3,1)*P(1)+R(3,2)*P(2)+R(3,3)*P(3)
60162       Q(1)=S1
60163       Q(2)=S2
60164       Q(3)=S3
60165       END
60166 CDECK  ID>, HWUROT.
60167 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60168 *-- Author :    Bryan Webber
60169 C-----------------------------------------------------------------------
60170       SUBROUTINE HWUROT(P,CP,SP,R)
60171 C-----------------------------------------------------------------------
60172 C     R IS ROTATION MATRIX TO GET FROM VECTOR P TO Z AXIS, FOLLOWED BY
60173 C     A ROTATION BY PSI ABOUT Z AXIS, WHERE CP = COS-PSI, SP = SIN-PSI
60174 C-----------------------------------------------------------------------
60175       DOUBLE PRECISION WN,CP,SP,PTCUT,PP,PT,CT,ST,CF,SF,P(3),R(3,3)
60176       DATA WN,PTCUT/1.D0,1.D-20/
60177       PT=P(1)**2+P(2)**2
60178       PP=P(3)**2+PT
60179       IF (PT.LE.PP*PTCUT) THEN
60180          CT=SIGN(WN,P(3))
60181          ST=0.
60182          CF=1.
60183          SF=0.
60184       ELSE
60185          PP=SQRT(PP)
60186          PT=SQRT(PT)
60187          CT=P(3)/PP
60188          ST=PT/PP
60189          CF=P(1)/PT
60190          SF=P(2)/PT
60191       END IF
60192       R(1,1)= CP*CF*CT+SP*SF
60193       R(1,2)= CP*SF*CT-SP*CF
60194       R(1,3)=-CP*ST
60195       R(2,1)=-CP*SF+SP*CF*CT
60196       R(2,2)= CP*CF+SP*SF*CT
60197       R(2,3)=-SP*ST
60198       R(3,1)= CF*ST
60199       R(3,2)= SF*ST
60200       R(3,3)= CT
60201       END
60202 CDECK  ID>, HWURQM.
60203 *CMZ :-        -17/07/03  11.11.56  by  Bryan Webber
60204 *-- Author :    Bryan Webber
60205 C----------------------------------------------------------------------
60206       SUBROUTINE HWURQM(SCALE,RQM)
60207 C-----------------------------------------------------------------------
60208 C     RUNNING QUARK MASSES (MSBAR, 2-LOOP, 5 FLAVOUR, NO THRESHOLDS)
60209 C     ASSUMING RMASS(IQ) IS POLE MASS
60210 C-----------------------------------------------------------------------
60211       INCLUDE 'HERWIG65.INC'
60212       DOUBLE PRECISION HWUALF,SCALE,ALFAS,P0,C1,CC,MHAT(6),RQM(6)
60213       INTEGER IQ
60214       LOGICAL FIRST
60215       SAVE P0,C1,MHAT,FIRST
60216       DATA FIRST/.TRUE./
60217       IF (FIRST) THEN
60218 C---INITIALIZE CONSTANTS
60219         P0=12./23.
60220         C1=3731./(3174.*PIFAC)
60221         CC=C1+4./(3.*PIFAC)
60222         DO IQ=1,6
60223            ALFAS=HWUALF(1,RMASS(IQ))
60224            IF (ALFAS.GT.ZERO) THEN
60225               MHAT(IQ)=RMASS(IQ)/(1.+CC*ALFAS)/ALFAS**P0
60226            ELSE
60227               CALL HWWARN('HWURQM',IQ,*1)
60228  1            MHAT(IQ)=ZERO
60229            ENDIF
60230         ENDDO
60231         FIRST=.FALSE.
60232       ENDIF
60233       ALFAS=HWUALF(1,SCALE)
60234       CC=(1.+C1*ALFAS)*ALFAS**P0
60235       DO IQ=1,6
60236          RQM(IQ)=MHAT(IQ)*CC
60237       ENDDO
60238       END
60239 CDECK  ID>, HWUSOR.
60240 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60241 *-- Author :    Adapted by Bryan Webber
60242 C-----------------------------------------------------------------------
60243       SUBROUTINE HWUSOR(A,N,K,IOPT)
60244 C-----------------------------------------------------------------------
60245 C     Sort A(N) into ascending order
60246 C     IOPT = 1 : return sorted A and index array K
60247 C     IOPT = 2 : return index array K only
60248 C-----------------------------------------------------------------------
60249       DOUBLE PRECISION A(N),B(500)
60250       INTEGER N,I,J,IOPT,K(N),IL(500),IR(500)
60251       IF (N.GT.500) CALL HWWARN('HWUSOR',100,*999)
60252       IL(1)=0
60253       IR(1)=0
60254       DO 10 I=2,N
60255       IL(I)=0
60256       IR(I)=0
60257       J=1
60258    2  IF(A(I).GT.A(J)) GOTO 5
60259    3  IF(IL(J).EQ.0) GOTO 4
60260       J=IL(J)
60261       GOTO 2
60262    4  IR(I)=-J
60263       IL(J)=I
60264       GOTO 10
60265    5  IF(IR(J).LE.0) GOTO 6
60266       J=IR(J)
60267       GOTO 2
60268    6  IR(I)=IR(J)
60269       IR(J)=I
60270   10  CONTINUE
60271       I=1
60272       J=1
60273       GOTO 8
60274   20  J=IL(J)
60275    8  IF(IL(J).GT.0) GOTO 20
60276    9  K(I)=J
60277       B(I)=A(J)
60278       I=I+1
60279       IF(IR(J)) 12,30,13
60280   13  J=IR(J)
60281       GOTO 8
60282   12  J=-IR(J)
60283       GOTO 9
60284   30  IF(IOPT.EQ.2) RETURN
60285       DO 31 I=1,N
60286   31  A(I)=B(I)
60287  999  END
60288 CDECK  ID>, HWUSPR.
60289 *CMZ :-        -17/10/01  13:59:28  by  Peter Richardson
60290 *-- Author :    Peter Richardson
60291 C-----------------------------------------------------------------------
60292       SUBROUTINE HWUSPR
60293 C-----------------------------------------------------------------------
60294 C  Subroutine to output the contents of the spin common block
60295 C-----------------------------------------------------------------------
60296       INCLUDE 'HERWIG65.INC'
60297       INTEGER I
60298 C--write out the header
60299       WRITE(6,1000)
60300       DO I=1,NSPN
60301         WRITE(6,1010) I,IDSPN(I),DECSPN(I),JMOSPN(I),JDASPN(1,I),
60302      &        JDASPN(2,I)
60303       ENDDO
60304  1000 FORMAT(/1X,'ISPN',1X,'IDSPN',1X,'DECS',1X,'JMOSPN',1X,' JDASPN '/)
60305  1010 FORMAT( 1X,  I4  ,1X, I5    ,1X,  L4  ,1X,  I6    ,1X, I3,2X,I3)
60306       END
60307 CDECK  ID>, HWUSQR.
60308 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60309 *-- Author :    Bryan Webber
60310 C-----------------------------------------------------------------------
60311       FUNCTION HWUSQR(X)
60312 C-----------------------------------------------------------------------
60313 C     SQUARE ROOT WITH SIGN RETENTION
60314 C-----------------------------------------------------------------------
60315       DOUBLE PRECISION HWUSQR,X
60316       HWUSQR=SIGN(SQRT(ABS(X)),X)
60317       END
60318 CDECK  ID>, HWUSTA.
60319 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
60320 *-- Author :    Bryan Webber
60321 C-----------------------------------------------------------------------
60322       SUBROUTINE HWUSTA(NAME)
60323 C-----------------------------------------------------------------------
60324 C     MAKES PARTICLE TYPE 'NAME' STABLE
60325 C-----------------------------------------------------------------------
60326       INCLUDE 'HERWIG65.INC'
60327       INTEGER IPDG,IWIG
60328       CHARACTER*8 NAME
60329       CALL HWUIDT(3,IPDG,IWIG,NAME)
60330       IF (IWIG.EQ.20) CALL HWWARN('HWUSTA',500,*999)
60331       RSTAB(IWIG)=.TRUE.
60332       WRITE (6,10) IWIG,NAME
60333    10 FORMAT(/10X,'PARTICLE TYPE',I4,'=',A8,' SET STABLE')
60334   999 END
60335 CDECK  ID>, HWUTAB.
60336 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60337 *-- Author :    Adapted by Bryan Webber
60338 C-----------------------------------------------------------------------
60339       FUNCTION HWUTAB(F,A,NN,X,MM)
60340 C-----------------------------------------------------------------------
60341 C     MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
60342 C-----------------------------------------------------------------------
60343       IMPLICIT NONE
60344       INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
60345       DOUBLE PRECISION HWUTAB,SUM,X,F(NN),A(NN),T(20),D(20)
60346       LOGICAL EXTRA
60347       DATA MMAX/10/
60348       N=NN
60349       M=MIN(MM,MMAX,N-1)
60350       MPLUS=M+1
60351       IX=0
60352       IY=N+1
60353       IF (A(1).GT.A(N)) GOTO 4
60354     1 MID=(IX+IY)/2
60355       IF (X.GE.A(MID)) GOTO 2
60356       IY=MID
60357       GOTO 3
60358     2 IX=MID
60359     3 IF (IY-IX.GT.1) GOTO 1
60360       GOTO 7
60361     4 MID=(IX+IY)/2
60362       IF (X.LE.A(MID)) GOTO 5
60363       IY=MID
60364       GOTO 6
60365     5 IX=MID
60366     6 IF (IY-IX.GT.1) GOTO 4
60367     7 NPTS=M+2-MOD(M,2)
60368       IP=0
60369       L=0
60370       GOTO 9
60371     8 L=-L
60372       IF (L.GE.0) L=L+1
60373     9 ISUB=IX+L
60374       IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 10
60375       NPTS=MPLUS
60376       GOTO 11
60377    10 IP=IP+1
60378       T(IP)=A(ISUB)
60379       D(IP)=F(ISUB)
60380    11 IF (IP.LT.NPTS) GOTO 8
60381       EXTRA=NPTS.NE.MPLUS
60382       DO 14 L=1,M
60383       IF (.NOT.EXTRA) GOTO 12
60384       ISUB=MPLUS-L
60385       D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
60386    12 I=MPLUS
60387       DO 13 J=L,M
60388       ISUB=I-L
60389       D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
60390       I=I-1
60391    13 CONTINUE
60392    14 CONTINUE
60393       SUM=D(MPLUS)
60394       IF (EXTRA) SUM=0.5*(SUM+D(M+2))
60395       J=M
60396       DO 15 L=1,M
60397       SUM=D(J)+(X-T(J))*SUM
60398       J=J-1
60399    15 CONTINUE
60400       HWUTAB=SUM
60401       END
60402 CDECK  ID>, HWUTIM.
60403 *CMZ :-        -26/04/91  11.38.43  by  Federico Carminati
60404 *-- Author :    Federico Carminati
60405 C-----------------------------------------------------------------------
60406       SUBROUTINE HWUTIM(TRES)
60407 C-----------------------------------------------------------------------
60408       CALL TIMEL(TRES)
60409       END
60410 CDECK  ID>, HWVDIF.
60411 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60412 *-- Author :    Bryan Webber
60413 C-----------------------------------------------------------------------
60414       SUBROUTINE HWVDIF(N,P,Q,R)
60415 C-----------------------------------------------------------------------
60416 C     VECTOR DIFFERENCE
60417 C-----------------------------------------------------------------------
60418       DOUBLE PRECISION P(N),Q(N),R(N)
60419       INTEGER N,I
60420       DO 10 I=1,N
60421    10 R(I)=P(I)-Q(I)
60422       END
60423 CDECK  ID>, HWVDOT.
60424 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60425 *-- Author :    Bryan Webber
60426 C-----------------------------------------------------------------------
60427       FUNCTION HWVDOT(N,P,Q)
60428 C-----------------------------------------------------------------------
60429 C     VECTOR DOT PRODUCT
60430 C-----------------------------------------------------------------------
60431       DOUBLE PRECISION HWVDOT,PQ,P(N),Q(N)
60432       INTEGER N,I
60433       PQ=0.
60434       DO 10 I=1,N
60435    10 PQ=PQ+P(I)*Q(I)
60436       HWVDOT=PQ
60437       END
60438 CDECK  ID>, HWVEQU.
60439 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60440 *-- Author :    Bryan Webber
60441 C-----------------------------------------------------------------------
60442       SUBROUTINE HWVEQU(N,P,Q)
60443 C-----------------------------------------------------------------------
60444 C     VECTOR EQUALITY
60445 C-----------------------------------------------------------------------
60446       DOUBLE PRECISION P(N),Q(N)
60447       INTEGER N,I
60448       DO 10 I=1,N
60449    10 Q(I)=P(I)
60450       END
60451 CDECK  ID>, HWVSCA.
60452 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60453 *-- Author :    Bryan Webber
60454 C-----------------------------------------------------------------------
60455       SUBROUTINE HWVSCA(N,C,P,Q)
60456 C-----------------------------------------------------------------------
60457 C     VECTOR TIMES SCALAR
60458 C-----------------------------------------------------------------------
60459       DOUBLE PRECISION C,P(N),Q(N)
60460       INTEGER N,I
60461       DO 10 I=1,N
60462    10 Q(I)=C*P(I)
60463       END
60464 CDECK  ID>, HWVSUM.
60465 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60466 *-- Author :    Bryan Webber
60467 C-----------------------------------------------------------------------
60468       SUBROUTINE HWVSUM(N,P,Q,R)
60469 C-----------------------------------------------------------------------
60470 C    VECTOR SUM
60471 C-----------------------------------------------------------------------
60472       DOUBLE PRECISION P(N),Q(N),R(N)
60473       INTEGER N,I
60474       DO 10 I=1,N
60475    10 R(I)=P(I)+Q(I)
60476       END
60477 CDECK  ID>, HWVZRI.
60478 *CMZ :-        -05/02/98  11.11.56  by  Bryan Webber
60479 *-- Author :    Bryan Webber
60480 C-----------------------------------------------------------------------
60481       SUBROUTINE HWVZRI(N,IP)
60482 C-----------------------------------------------------------------------
60483 C     ZERO INTEGER VECTOR
60484 C-----------------------------------------------------------------------
60485       INTEGER N,IP(N),I
60486       DO 10 I=1,N
60487    10 IP(I)=0
60488       END
60489 CDECK  ID>, HWVZRO.
60490 *CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
60491 *-- Author :    Bryan Webber
60492 C-----------------------------------------------------------------------
60493       SUBROUTINE HWVZRO(N,P)
60494 C-----------------------------------------------------------------------
60495 C     ZERO VECTOR
60496 C-----------------------------------------------------------------------
60497       DOUBLE PRECISION P(N)
60498       INTEGER N,I
60499       DO 10 I=1,N
60500    10 P(I)=0D0
60501       END
60502 CDECK  ID>, HWWARN.
60503 *CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
60504 *-- Author :    Bryan Webber
60505 C-----------------------------------------------------------------------
60506       SUBROUTINE HWWARN(SUBRTN,ICODE,*)
60507 C-----------------------------------------------------------------------
60508 C     DEALS WITH ERRORS DURING EXECUTION
60509 C     SUBRTN = NAME OF CALLING SUBROUTINE
60510 C     ICODE  = ERROR CODE:    - -1 NONFATAL, KILL EVENT & PRINT NOTHING
60511 C                            0- 49 NONFATAL, PRINT WARNING & CONTINUE
60512 C                           50- 99 NONFATAL, PRINT WARNING & JUMP
60513 C                          100-199 NONFATAL, DUMP & KILL EVENT
60514 C                          200-299    FATAL, TERMINATE RUN
60515 C                          300-399    FATAL, DUMP EVENT & TERMINATE RUN
60516 C                          400-499    FATAL, DUMP EVENT & STOP DEAD
60517 C                          500-       FATAL, STOP DEAD WITH NO DUMP
60518 C-----------------------------------------------------------------------
60519       INCLUDE 'HERWIG65.INC'
60520       INTEGER ICODE
60521       CHARACTER*6 SUBRTN
60522       IF (ICODE.GE.0) WRITE (6,10) SUBRTN,ICODE
60523    10 FORMAT(/' HWWARN CALLED FROM SUBPROGRAM ',A6,': CODE =',I4)
60524       IF (ICODE.LT.0) THEN
60525          IERROR=ICODE
60526          RETURN 1
60527       ELSEIF (ICODE.LT.100) THEN
60528          WRITE (6,20) NEVHEP,NRN,EVWGT
60529    20    FORMAT(' EVENT',I8,':   SEEDS =',I11,' &',I11,
60530      &'  WEIGHT =',E11.4/' EVENT SURVIVES. EXECUTION CONTINUES')
60531          IF (ICODE.GT.49) RETURN 1
60532       ELSEIF (ICODE.LT.200) THEN
60533          WRITE (6,30) NEVHEP,NRN,EVWGT
60534    30    FORMAT(' EVENT',I8,':   SEEDS =',I11,' &',I11,
60535      &'  WEIGHT =',E11.4/' EVENT KILLED.   EXECUTION CONTINUES')
60536          IERROR=ICODE
60537          RETURN 1
60538       ELSEIF (ICODE.LT.300) THEN
60539          WRITE (6,40)
60540    40    FORMAT(' EVENT SURVIVES.  RUN ENDS GRACEFULLY')
60541          CALL HWEFIN
60542 c$$$         CALL HWAEND
60543          STOP
60544       ELSEIF (ICODE.LT.400) THEN
60545          WRITE (6,50)
60546    50    FORMAT(' EVENT KILLED: DUMP FOLLOWS.  RUN ENDS GRACEFULLY')
60547          IERROR=ICODE
60548          CALL HWUEPR
60549          CALL HWUBPR
60550          CALL HWEFIN
60551 c$$$         CALL HWAEND
60552          STOP
60553       ELSEIF (ICODE.LT.500) THEN
60554          WRITE (6,60)
60555    60    FORMAT(' EVENT KILLED: DUMP FOLLOWS.  RUN STOPS DEAD')
60556          IERROR=ICODE
60557          CALL HWUEPR
60558          CALL HWUBPR
60559          STOP
60560       ELSE
60561          WRITE (6,70)
60562    70    FORMAT(' RUN CANNOT CONTINUE')
60563          STOP
60564       ENDIF
60565       END
60566 CDECK  ID>, IEUPDG.
60567 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
60568 *-- Author :    Luca Stanco
60569 C-----------------------------------------------------------------------
60570       FUNCTION IEUPDG(I)
60571 C-----------------------------------------------------------------------
60572 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
60573 C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
60574 C-----------------------------------------------------------------------
60575       INTEGER IEUPDG,I
60576       WRITE (6,10)
60577    10 FORMAT(/10X,'IEUPDG CALLED BUT NOT LINKED')
60578       IEUPDG=0
60579       STOP
60580       END
60581 CDECK  ID>, IPDGEU.
60582 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
60583 *-- Author :    Luca Stanco
60584 C-----------------------------------------------------------------------
60585       FUNCTION IPDGEU(I)
60586 C-----------------------------------------------------------------------
60587 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
60588 C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
60589 C-----------------------------------------------------------------------
60590       INTEGER IPDGEU,I
60591       WRITE (6,10)
60592    10 FORMAT(/10X,'IPDGEU CALLED BUT NOT LINKED')
60593       IPDGEU=0
60594       STOP
60595       END
60596 CDECK  ID>, INIETC.
60597 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
60598 *-- Author :    Peter Richardson
60599 C-----------------------------------------------------------------------
60600       SUBROUTINE INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
60601 C-----------------------------------------------------------------------
60602 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60603 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60604 C-----------------------------------------------------------------------
60605       IMPLICIT NONE
60606       INTEGER JAK1,JAK2,ITDKRC,IFPHOT
60607       WRITE (6,10)
60608    10 FORMAT(/10X,'INIETC CALLED BUT NOT LINKED')
60609       STOP
60610       END
60611 CDECK  ID>, INIMAS.
60612 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
60613 *-- Author :    Peter Richardson
60614 C-----------------------------------------------------------------------
60615       SUBROUTINE INIMAS
60616 C-----------------------------------------------------------------------
60617 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60618 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60619 C-----------------------------------------------------------------------
60620       IMPLICIT NONE
60621       WRITE (6,10)
60622    10 FORMAT(/10X,'INIMAS CALLED BUT NOT LINKED')
60623       STOP
60624       END
60625 CDECK  ID>, INIPHX.
60626 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
60627 *-- Author :    Peter Richardson
60628 C-----------------------------------------------------------------------
60629       SUBROUTINE INIPHX(CUT)
60630 C-----------------------------------------------------------------------
60631 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60632 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60633 C-----------------------------------------------------------------------
60634       IMPLICIT NONE
60635       DOUBLE PRECISION CUT
60636       WRITE (6,10)
60637    10 FORMAT(/10X,'INIPHX CALLED BUT NOT LINKED')
60638       STOP
60639       END
60640 CDECK  ID>, INITDK.
60641 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
60642 *-- Author :    Peter Richardson
60643 C-----------------------------------------------------------------------
60644       SUBROUTINE INITDK
60645 C-----------------------------------------------------------------------
60646 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60647 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60648 C-----------------------------------------------------------------------
60649       IMPLICIT NONE
60650       WRITE (6,10)
60651    10 FORMAT(/10X,'INITDK CALLED BUT NOT LINKED')
60652       STOP
60653       END
60654 CDECK  ID>, PHOINI.
60655 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
60656 *-- Author :    Peter Richardson
60657 C-----------------------------------------------------------------------
60658       SUBROUTINE PHOINI
60659 C-----------------------------------------------------------------------
60660 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60661 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60662 C-----------------------------------------------------------------------
60663       IMPLICIT NONE
60664       WRITE (6,10)
60665    10 FORMAT(/10X,'PHOINI CALLED BUT NOT LINKED')
60666       STOP
60667       END
60668 CDECK  ID>, PHOTOS.
60669 *CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
60670 *-- Author :    Peter Richardson
60671 C-----------------------------------------------------------------------
60672       SUBROUTINE PHOTOS(IHEP)
60673 C-----------------------------------------------------------------------
60674 C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
60675 C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
60676 C-----------------------------------------------------------------------
60677       IMPLICIT NONE
60678       INTEGER IHEP
60679       WRITE (6,10)
60680    10 FORMAT(/10X,'PHOTOS CALLED BUT NOT LINKED')
60681       STOP
60682       END
60683 CDECK  ID>, QQINIT.
60684 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
60685 *-- Author :    Luca Stanco
60686 C-----------------------------------------------------------------------
60687       SUBROUTINE QQINIT(QQLERR)
60688 C-----------------------------------------------------------------------
60689 C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
60690 C     IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
60691 C-----------------------------------------------------------------------
60692       LOGICAL QQLERR
60693       WRITE (6,10)
60694    10 FORMAT(/10X,'QQINIT CALLED BUT NOT LINKED')
60695       STOP
60696       END
60697 CDECK  ID>, QQLMAT.
60698 *CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
60699 *-- Author :    Luca Stanco
60700 C-----------------------------------------------------------------------
60701       INTEGER FUNCTION QQLMAT(IDL,NDIR)
60702 C-----------------------------------------------------------------------
60703 C. QQLMAT - Given a particle flavor (KF), converts it to QQ particle number
60704 C.          (KF = IDPDG code)
60705 C.
60706 C. Inputs    : IDL    (input  particle code)
60707 C              NDIR = 1   LUND --> QQ
60708 C              NDIR = 2   QQ   --> LUND
60709 C
60710 C. Outputs   : QQLMAT (output particle code)
60711 C.
60712 C-----------------------------------------------------------------------
60713       IMPLICIT NONE
60714 C-- Calling variable
60715       INTEGER IDL,NDIR
60716 C-- External declaration
60717 C-- Local variables
60718       INTEGER AKF(321),I
60719       DATA (AKF(I), I=1,151) /
60720      +    0,    0,    0,    0,    0,    0,    0,   21,   -6,   -5,
60721      +   -4,   -3,   -1,   -2,    6,    5,    4,    3,    1,    2,
60722      +    0,
60723      +   22,   23,   24,  -24,   90,    0,   11,  -11,   12,  -12,
60724      +   13,  -13,   14,  -14,   15,  -15,   16,  -16,20313,-20313,
60725      +  211, -211,  321, -321,  311, -311,  421, -421,  411, -411,
60726      +  431, -431, -521,  521, -511,  511, -531,  531, -541,  541,
60727      +  621, -621,  611, -611,  631, -631,  641, -641,  651, -651,
60728      +  111,  221,  331,  441,20551,  661,  310,  130,10313,-10313,
60729      +  213, -213,  323, -323,  313, -313,  423, -423,  413, -413,
60730      +  433, -433, -523,  523, -513,  513, -533,  533, -543,  543,
60731      +  623, -623,  613, -613,  633, -633,  643, -643,  653, -653,
60732      +  113,  223,  333,  443,  553,  136,  20553, 30553, 40553, 551,
60733      +  10553, 555, 10551,70553,10555, 0, 20213, 20113, -20213, 10441,
60734      +  10443, 445, 8*0,
60735      +  3122, -3122, 4122, -4122, 4232, -4232, 4132, -4132, 3212, -3212/
60736       DATA (AKF(I), I=152,321) /
60737      +  4212, -4212, 4322, -4322, 4312, -4312, 2212, -2212, 3222, -3222,
60738      +  4222, -4222, 2112, -2112, 3112, -3112, 4112, -4112, 3322, -3322,
60739      +  3312, -3312, 4332, -4332, 6*0,
60740      +  3214, -3214, 4214, -4214, 4324, -4324, 4314, -4314, 2214, -2214,
60741      +  3224, -3224, 4224, -4224, 2114, -2114, 3114, -3114, 4114, -4114,
60742      +  3324, -3324, 3314, -3314, 4334, -4334, 4*0,
60743      +  0, 0,  2224, -2224, 1114, -1114, 3334, -3334, 0, 0,
60744      +  10323, -10323, 20323, -20323, 6*0,
60745      +  30443, 0, 0, 0, 70443, 50553, 60553, 80553, 20443, 0,
60746      +  10411, 20413, 10413, 415,
60747      + -10411,-20413,-10413,-415,
60748      +  10421, 20423, 10423, 425,
60749      + -10421,-20423,-10423,-425,
60750      +  10431, 20433, 10433, 435,
60751      + -10431,-20433,-10433,-435, 0,0,0,0,0,0,
60752      +  10111, 10211,-10211, 115, 215, -215,10221,10331,20223,20333,
60753      +  225, 335, 10223, 10333, 10113, 10213,-10213, 33*0 /
60754       IF(NDIR.EQ.1) THEN
60755         DO 10 I=1,321
60756         IF (IDL.EQ.AKF(I)) THEN
60757           QQLMAT=I-21
60758           RETURN
60759         ENDIF
60760   10    CONTINUE
60761         QQLMAT=0
60762         WRITE(6,20) IDL
60763   20    FORMAT(1X,'Lund code particle ',I6,' not recognized')
60764       ELSEIF(NDIR.EQ.2) THEN
60765         QQLMAT = AKF(IDL+21)
60766       ELSE
60767         QQLMAT=0
60768         WRITE(6,30)
60769   30    FORMAT(1X,'Unrecognized option in QQLMAT')
60770       ENDIF
60771       RETURN
60772       END
60773 C-----------------------------------------------------------------------
60774 C...SaSgam version 2 - parton distributions of the photon
60775 C...by Gerhard A. Schuler and Torbjorn Sjostrand
60776 C...For further information see Z. Phys. C68 (1995) 607
60777 C...and CERN-TH/96-04 and LU TP 96-2.
60778 C...Program last changed on 18 January 1996.
60779 C
60780 C!!!Note that one further call parameter - IP2 - has been added
60781 C!!!to the SASGAM argument list compared with version 1.
60782 C
60783 C...The user should only need to call the SASGAM routine,
60784 C...which in turn calls the auxiliary routines SASVMD, SASANO,
60785 C...SASBEH and SASDIR. The package is self-contained.
60786 C
60787 C...One particular aspect of these parametrizations is that F2 for
60788 C...the photon is not obtained just as the charge-squared-weighted
60789 C...sum of quark distributions, but differ in the treatment of
60790 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
60791 C...the kinematics range of heavy-flavour production, but the same
60792 C...kinematics is not relevant e.g. for jet production) and, for the
60793 C...'MSbar' fits, in the addition of a Cgamma term related to the
60794 C...separation of direct processes. Schematically:
60795 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
60796 C...F2  = VMD (rho, omega, phi) + anomalous (d, u, s) +
60797 C...      Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
60798 C...The J/psi and Upsilon states have not been included in the VMD sum,
60799 C...but low c and b masses in the other components should compensate
60800 C...for this in a duality sense.
60801 C
60802 C...The calling sequence is the following:
60803 C     CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
60804 C...with the following declaration statement:
60805 C     DIMENSION XPDFGM(-6:6)
60806 C...and, optionally, further information in:
60807 C     COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60808 C    &XPDIR(-6:6)
60809 C     COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
60810 C...Input:  ISET = 1 : SaS set 1D ('DIS',   Q0 = 0.6 GeV)
60811 C                = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
60812 C                = 3 : SaS set 2D ('DIS',   Q0 =  2  GeV)
60813 C                = 4 : SaS set 2M ('MSbar', Q0 =  2  GeV)
60814 C           X : x value.
60815 C           Q2 : Q2 value.
60816 C           P2 : P2 value; should be = 0. for an on-shell photon.
60817 C           IP2 : scheme used to evaluate off-shell anomalous component.
60818 C               = 0 : recommended default, see = 7.
60819 C               = 1 : dipole dampening by integration; very time-consuming.
60820 C               = 2 : P_0^2 = max( Q_0^2, P^2 )
60821 C               = 3 : P'_0^2 = Q_0^2 + P^2.
60822 C               = 4 : P_{eff} that preserves momentum sum.
60823 C               = 5 : P_{int} that preserves momentum and average
60824 C                     evolution range.
60825 C               = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
60826 C               = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
60827 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
60828 C           XPFDGM :  x times parton distribution functions of the photon,
60829 C               with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
60830 C               6 = t (always empty!), - for antiquarks (result is same).
60831 C...The breakdown by component is stored in the commonblock SASCOM,
60832 C               with elements as above.
60833 C           XPVMD : rho, omega, phi VMD part only of output.
60834 C           XPANL : d, u, s anomalous part only of output.
60835 C           XPANH : c, b anomalous part only of output.
60836 C           XPBEH : c, b Bethe-Heitler part only of output.
60837 C           XPDIR : Cgamma (direct contribution) part only of output.
60838 C...The above arrays do not distinguish valence and sea contributions,
60839 C...although this information is available internally. The additional
60840 C...commonblock SASVAL provides the valence part only of the above
60841 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
60842 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
60843 C...and therefore not given doubly. VXPDGM gives the sum of valence
60844 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
60845 C...and so on, gives the sea part only.
60846 C
60847       SUBROUTINE SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
60848 C...Purpose: to construct the F2 and parton distributions of the photon
60849 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
60850 C...For F2, c and b are included by the Bethe-Heitler formula;
60851 C...in the 'MSbar' scheme additionally a Cgamma term is added.
60852       DIMENSION XPDFGM(-6:6)
60853       COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60854      &XPDIR(-6:6)
60855       COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
60856       SAVE /SASCOM/,/SASVAL/
60857 C
60858 C...Temporary array.
60859       DIMENSION XPGA(-6:6), VXPGA(-6:6)
60860 C...Charm and bottom masses (low to compensate for J/psi etc.).
60861       DATA PMC/1.3/, PMB/4.6/
60862 C...alpha_em and alpha_em/(2*pi).
60863       DATA AEM/0.007297/, AEM2PI/0.0011614/
60864 C...Lambda value for 4 flavours.
60865       DATA ALAM/0.20/
60866 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
60867       DATA FRACU/0.8/
60868 C...VMD couplings f_V**2/(4*pi).
60869       DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
60870 C...Masses for rho (=omega) and phi.
60871       DATA PMRHO/0.770/, PMPHI/1.020/
60872 C...Number of points in integration for IP2=1.
60873       DATA NSTEP/100/
60874 C
60875 C...Reset output.
60876       F2GM=0.
60877       DO 100 KFL=-6,6
60878       XPDFGM(KFL)=0.
60879       XPVMD(KFL)=0.
60880       XPANL(KFL)=0.
60881       XPANH(KFL)=0.
60882       XPBEH(KFL)=0.
60883       XPDIR(KFL)=0.
60884       VXPVMD(KFL)=0.
60885       VXPANL(KFL)=0.
60886       VXPANH(KFL)=0.
60887       VXPDGM(KFL)=0.
60888   100 CONTINUE
60889 C
60890 C...Check that input sensible.
60891       IF(ISET.LE.0.OR.ISET.GE.5) THEN
60892         WRITE(*,*) ' FATAL ERROR: SaSgam called for unknown set'
60893         WRITE(*,*) ' ISET = ',ISET
60894         STOP
60895       ENDIF
60896       IF(X.LE.0..OR.X.GT.1.) THEN
60897         WRITE(*,*) ' FATAL ERROR: SaSgam called for unphysical x'
60898         WRITE(*,*) ' X = ',X
60899         STOP
60900       ENDIF
60901 C
60902 C...Set Q0 cut-off parameter as function of set used.
60903       IF(ISET.LE.2) THEN
60904         Q0=0.6
60905       ELSE
60906         Q0=2.
60907       ENDIF
60908       Q02=Q0**2
60909 C
60910 C...Scale choice for off-shell photon; common factors.
60911       Q2A=Q2
60912       FACNOR=1.
60913       IF(IP2.EQ.1) THEN
60914         P2MX=P2+Q02
60915         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
60916         FACNOR=LOG(Q2/Q02)/NSTEP
60917       ELSEIF(IP2.EQ.2) THEN
60918         P2MX=MAX(P2,Q02)
60919       ELSEIF(IP2.EQ.3) THEN
60920         P2MX=P2+Q02
60921         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
60922       ELSEIF(IP2.EQ.4) THEN
60923         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
60924      &  ((Q2+P2)*(Q02+P2)))
60925       ELSEIF(IP2.EQ.5) THEN
60926         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
60927      &  ((Q2+P2)*(Q02+P2)))
60928         P2MX=Q0*SQRT(P2MXA)
60929         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
60930       ELSEIF(IP2.EQ.6) THEN
60931         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
60932      &  ((Q2+P2)*(Q02+P2)))
60933         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
60934       ELSE
60935         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
60936      &  ((Q2+P2)*(Q02+P2)))
60937         P2MX=Q0*SQRT(P2MXA)
60938         P2MXB=P2MX
60939         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
60940         P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
60941         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
60942       ENDIF
60943 C
60944 C...Call VMD parametrization for d quark and use to give rho, omega,
60945 C...phi. Note dipole dampening for off-shell photon.
60946       CALL SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
60947       XFVAL=VXPGA(1)
60948       XPGA(1)=XPGA(2)
60949       XPGA(-1)=XPGA(-2)
60950       FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
60951       FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
60952       DO 110 KFL=-5,5
60953       XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
60954   110 CONTINUE
60955       XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
60956       XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
60957       XPVMD(3)=XPVMD(3)+FACS*XFVAL
60958       XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
60959       XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
60960       XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
60961       VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
60962       VXPVMD(2)=FRACU*FACUD*XFVAL
60963       VXPVMD(3)=FACS*XFVAL
60964       VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
60965       VXPVMD(-2)=FRACU*FACUD*XFVAL
60966       VXPVMD(-3)=FACS*XFVAL
60967 C
60968       IF(IP2.NE.1) THEN
60969 C...Anomalous parametrizations for different strategies
60970 C...for off-shell photons; except full integration.
60971 C
60972 C...Call anomalous parametrization for d + u + s.
60973         CALL SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
60974         DO 120 KFL=-5,5
60975         XPANL(KFL)=FACNOR*XPGA(KFL)
60976         VXPANL(KFL)=FACNOR*VXPGA(KFL)
60977   120   CONTINUE
60978 C
60979 C...Call anomalous parametrization for c and b.
60980         CALL SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
60981         DO 130 KFL=-5,5
60982         XPANH(KFL)=FACNOR*XPGA(KFL)
60983         VXPANH(KFL)=FACNOR*VXPGA(KFL)
60984   130   CONTINUE
60985         CALL SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
60986         DO 140 KFL=-5,5
60987         XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
60988         VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
60989   140   CONTINUE
60990 C
60991       ELSE
60992 C...Special option: loop over flavours and integrate over k2.
60993         DO 170 KF=1,5
60994         DO 160 ISTEP=1,NSTEP
60995         Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
60996         IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
60997      &  (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
60998         CALL SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
60999         FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
61000         IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
61001         IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
61002         DO 150 KFL=-5,5
61003         IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
61004         IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
61005         IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
61006         IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
61007   150   CONTINUE
61008   160   CONTINUE
61009   170   CONTINUE
61010       ENDIF
61011 C
61012 C...Call Bethe-Heitler term expression for charm and bottom.
61013       CALL SASBEH(4,X,Q2,P2,PMC**2,XPBH)
61014       XPBEH(4)=XPBH
61015       XPBEH(-4)=XPBH
61016       CALL SASBEH(5,X,Q2,P2,PMB**2,XPBH)
61017       XPBEH(5)=XPBH
61018       XPBEH(-5)=XPBH
61019 C
61020 C...For MSbar subtraction call C^gamma term expression for d, u, s.
61021       IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
61022         CALL SASDIR(X,Q2,P2,Q02,XPGA)
61023         DO 180 KFL=-5,5
61024         XPDIR(KFL)=XPGA(KFL)
61025   180   CONTINUE
61026       ENDIF
61027 C
61028 C...Store result in output array.
61029       DO 190 KFL=-5,5
61030       CHSQ=1./9.
61031       IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
61032       XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
61033       IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
61034       XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
61035       VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
61036   190 CONTINUE
61037 C
61038       RETURN
61039       END
61040 C
61041 C*********************************************************************
61042 C
61043       SUBROUTINE SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
61044 C...Purpose: to evaluate the VMD parton distributions of a photon,
61045 C...evolved homogeneously from an initial scale P2 to Q2.
61046 C...Does not include dipole suppression factor.
61047 C...ISET is parton distribution set, see above;
61048 C...additionally ISET=0 is used for the evolution of an anomalous photon
61049 C...which branched at a scale P2 and then evolved homogeneously to Q2.
61050 C...ALAM is the 4-flavour Lambda, which is automatically converted
61051 C...to 3- and 5-flavour equivalents as needed.
61052       DIMENSION XPGA(-6:6), VXPGA(-6:6)
61053       DATA PMC/1.3/, PMB/4.6/
61054 C
61055 C...Reset output.
61056       DO 100 KFL=-6,6
61057       XPGA(KFL)=0.
61058       VXPGA(KFL)=0.
61059   100 CONTINUE
61060       KFA=IABS(KF)
61061 C
61062 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
61063       ALAM3=ALAM*(PMC/ALAM)**(2./27.)
61064       ALAM5=ALAM*(ALAM/PMB)**(2./23.)
61065       P2EFF=MAX(P2,1.2*ALAM3**2)
61066       IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
61067       IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
61068       Q2EFF=MAX(Q2,P2EFF)
61069 C
61070 C...Find number of flavours at lower and upper scale.
61071       NFP=4
61072       IF(P2EFF.LT.PMC**2) NFP=3
61073       IF(P2EFF.GT.PMB**2) NFP=5
61074       NFQ=4
61075       IF(Q2EFF.LT.PMC**2) NFQ=3
61076       IF(Q2EFF.GT.PMB**2) NFQ=5
61077 C
61078 C...Find s as sum of 3-, 4- and 5-flavour parts.
61079       S=0.
61080       IF(NFP.EQ.3) THEN
61081         Q2DIV=PMC**2
61082         IF(NFQ.EQ.3) Q2DIV=Q2EFF
61083         S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
61084       ENDIF
61085       IF(NFP.LE.4.AND.NFQ.GE.4) THEN
61086         P2DIV=P2EFF
61087         IF(NFP.EQ.3) P2DIV=PMC**2
61088         Q2DIV=Q2EFF
61089         IF(NFQ.EQ.5) Q2DIV=PMB**2
61090         S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
61091       ENDIF
61092       IF(NFQ.EQ.5) THEN
61093         P2DIV=PMB**2
61094         IF(NFP.EQ.5) P2DIV=P2EFF
61095         S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
61096       ENDIF
61097 C
61098 C...Calculate frequent combinations of x and s.
61099       X1=1.-X
61100       XL=-LOG(X)
61101       S2=S**2
61102       S3=S**3
61103       S4=S**4
61104 C
61105 C...Evaluate homogeneous anomalous parton distributions below or
61106 C...above threshold.
61107       IF(ISET.EQ.0) THEN
61108       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61109      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61110         XVAL = X * 1.5 * (X**2+X1**2)
61111         XGLU = 0.
61112         XSEA = 0.
61113       ELSE
61114         XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
61115      &  (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
61116      &  X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
61117         XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
61118      &  X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
61119      &  ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
61120         XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
61121      &  X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
61122      &  ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
61123      &  (2.*X-1.)*X*XL**2)
61124       ENDIF
61125 C
61126 C...Evaluate set 1D parton distributions below or above threshold.
61127       ELSEIF(ISET.EQ.1) THEN
61128       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61129      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61130         XVAL = 1.294 * X**0.80 * X1**0.76
61131         XGLU = 1.273 * X**0.40 * X1**1.76
61132         XSEA = 0.100 * X1**3.76
61133       ELSE
61134         XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
61135      &  X1**(0.76+0.667*S) * XL**(2.*S)
61136         XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
61137      &  X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
61138      &  1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
61139         XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
61140      &  X**(-7.32*S2/(1.+10.3*S2)) *
61141      &  X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
61142         XSEA0 = 0.100 * X1**3.76
61143       ENDIF
61144 C
61145 C...Evaluate set 1M parton distributions below or above threshold.
61146       ELSEIF(ISET.EQ.2) THEN
61147       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61148      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61149         XVAL = 0.8477 * X**0.51 * X1**1.37
61150         XGLU = 3.42 * X**0.255 * X1**2.37
61151         XSEA = 0.
61152       ELSE
61153         XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
61154      &  * X1**1.37 * XL**(2.667*S)
61155         XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
61156      &  X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
61157      &  XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
61158      &  X1**(2.37+3.*S)
61159         XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
61160      &  X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
61161      &  XL**(2.8*S)
61162         XSEA0 = 0.
61163       ENDIF
61164 C
61165 C...Evaluate set 2D parton distributions below or above threshold.
61166       ELSEIF(ISET.EQ.3) THEN
61167       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61168      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61169         XVAL = X**0.46 * X1**0.64 + 0.76 * X
61170         XGLU = 1.925 * X1**2
61171         XSEA = 0.242 * X1**4
61172       ELSE
61173         XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
61174      &  * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
61175      &  (0.76+0.4*S) * X * X1**(2.667*S)
61176         XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
61177      &  EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
61178      &  * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
61179         XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
61180      &  X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
61181         XSEA0 = 0.242 * X1**4
61182       ENDIF
61183 C
61184 C...Evaluate set 2M parton distributions below or above threshold.
61185       ELSEIF(ISET.EQ.4) THEN
61186       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
61187      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
61188         XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
61189         XGLU = 1.808 * X1**2
61190         XSEA = 0.209 * X1**4
61191       ELSE
61192         XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
61193      &  X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
61194      &  X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
61195      &  (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
61196         XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
61197      &  X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
61198      &  X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
61199      &  XL**(10.9*S/(1.+2.5*S))
61200         XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
61201      &  X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
61202      &  X1**(4.+S) * XL**(0.45*S)
61203         XSEA0 = 0.209 * X1**4
61204       ENDIF
61205       ENDIF
61206 C
61207 C...Threshold factors for c and b sea.
61208       SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
61209       XCHM=0.
61210       IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
61211         SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
61212         IF(ISET.EQ.0) THEN
61213           XCHM=XSEA*(1.-(SCH/SLL)**2)
61214         ELSE
61215           XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
61216         ENDIF
61217       ENDIF
61218       XBOT=0.
61219       IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
61220         SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
61221         IF(ISET.EQ.0) THEN
61222           XBOT=XSEA*(1.-(SBT/SLL)**2)
61223         ELSE
61224           XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
61225         ENDIF
61226       ENDIF
61227 C
61228 C...Fill parton distributions.
61229       XPGA(0)=XGLU
61230       XPGA(1)=XSEA
61231       XPGA(2)=XSEA
61232       XPGA(3)=XSEA
61233       XPGA(4)=XCHM
61234       XPGA(5)=XBOT
61235       XPGA(KFA)=XPGA(KFA)+XVAL
61236       DO 110 KFL=1,5
61237       XPGA(-KFL)=XPGA(KFL)
61238   110 CONTINUE
61239       VXPGA(KFA)=XVAL
61240       VXPGA(-KFA)=XVAL
61241 C
61242       RETURN
61243       END
61244 C
61245 C*********************************************************************
61246 C
61247       SUBROUTINE SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
61248 C...Purpose: to evaluate the parton distributions of the anomalous
61249 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
61250 C...to Q2.
61251 C...KF=0 gives the sum over (up to) 5 flavours,
61252 C...KF<0 limits to flavours up to abs(KF),
61253 C...KF>0 is for flavour KF only.
61254 C...ALAM is the 4-flavour Lambda, which is automatically converted
61255 C...to 3- and 5-flavour equivalents as needed.
61256       DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
61257       DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
61258 C
61259 C...Reset output.
61260       DO 100 KFL=-6,6
61261       XPGA(KFL)=0.
61262       VXPGA(KFL)=0.
61263   100 CONTINUE
61264       IF(Q2.LE.P2) RETURN
61265       KFA=IABS(KF)
61266 C
61267 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
61268       ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
61269       ALAMSQ(4)=ALAM**2
61270       ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
61271       P2EFF=MAX(P2,1.2*ALAMSQ(3))
61272       IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
61273       IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
61274       Q2EFF=MAX(Q2,P2EFF)
61275       XL=-LOG(X)
61276 C
61277 C...Find number of flavours at lower and upper scale.
61278       NFP=4
61279       IF(P2EFF.LT.PMC**2) NFP=3
61280       IF(P2EFF.GT.PMB**2) NFP=5
61281       NFQ=4
61282       IF(Q2EFF.LT.PMC**2) NFQ=3
61283       IF(Q2EFF.GT.PMB**2) NFQ=5
61284 C
61285 C...Define range of flavour loop.
61286       IF(KF.EQ.0) THEN
61287         KFLMN=1
61288         KFLMX=5
61289       ELSEIF(KF.LT.0) THEN
61290         KFLMN=1
61291         KFLMX=KFA
61292       ELSE
61293         KFLMN=KFA
61294         KFLMX=KFA
61295       ENDIF
61296 C
61297 C...Loop over flavours the photon can branch into.
61298       DO 110 KFL=KFLMN,KFLMX
61299 C
61300 C...Light flavours: calculate t range and (approximate) s range.
61301       IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
61302         TDIFF=LOG(Q2EFF/P2EFF)
61303         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
61304      &  LOG(P2EFF/ALAMSQ(NFQ)))
61305         IF(NFQ.GT.NFP) THEN
61306           Q2DIV=PMB**2
61307           IF(NFQ.EQ.4) Q2DIV=PMC**2
61308           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
61309      &    LOG(P2EFF/ALAMSQ(NFQ)))
61310           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
61311      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
61312           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
61313         ENDIF
61314         IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
61315           Q2DIV=PMC**2
61316           SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
61317      &    LOG(P2EFF/ALAMSQ(4)))
61318           SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
61319      &    LOG(P2EFF/ALAMSQ(3)))
61320           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
61321         ENDIF
61322 C
61323 C...u and s quark do not need a separate treatment when d has been done.
61324       ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
61325 C
61326 C...Charm: as above, but only include range above c threshold.
61327       ELSEIF(KFL.EQ.4) THEN
61328         IF(Q2.LE.PMC**2) GOTO 110
61329         P2EFF=MAX(P2EFF,PMC**2)
61330         Q2EFF=MAX(Q2EFF,P2EFF)
61331         TDIFF=LOG(Q2EFF/P2EFF)
61332         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
61333      &  LOG(P2EFF/ALAMSQ(NFQ)))
61334         IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
61335           Q2DIV=PMB**2
61336           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
61337      &    LOG(P2EFF/ALAMSQ(NFQ)))
61338           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
61339      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
61340           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
61341         ENDIF
61342 C
61343 C...Bottom: as above, but only include range above b threshold.
61344       ELSEIF(KFL.EQ.5) THEN
61345         IF(Q2.LE.PMB**2) GOTO 110
61346         P2EFF=MAX(P2EFF,PMB**2)
61347         Q2EFF=MAX(Q2,P2EFF)
61348         TDIFF=LOG(Q2EFF/P2EFF)
61349         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
61350      &  LOG(P2EFF/ALAMSQ(NFQ)))
61351       ENDIF
61352 C
61353 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
61354       CHSQ=1./9.
61355       IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
61356       FAC=AEM2PI*2.*CHSQ*TDIFF
61357 C
61358 C...Evaluate parton distributions (normalized to unit momentum sum).
61359       IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
61360         XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
61361      &  (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
61362      &  1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
61363      &  X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
61364         XGLU= 2.*S/(1.+4.*S+7.*S**2) *
61365      &  X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
61366      &  ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
61367         XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
61368      &  X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
61369      &  ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
61370      &  (2.*X-1.)*X*XL**2)
61371 C
61372 C...Threshold factors for c and b sea.
61373         SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
61374         XCHM=0.
61375         IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
61376           SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
61377           XCHM=XSEA*(1.-(SCH/SLL)**3)
61378         ENDIF
61379         XBOT=0.
61380         IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
61381           SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
61382           XBOT=XSEA*(1.-(SBT/SLL)**3)
61383         ENDIF
61384       ENDIF
61385 C
61386 C...Add contribution of each valence flavour.
61387       XPGA(0)=XPGA(0)+FAC*XGLU
61388       XPGA(1)=XPGA(1)+FAC*XSEA
61389       XPGA(2)=XPGA(2)+FAC*XSEA
61390       XPGA(3)=XPGA(3)+FAC*XSEA
61391       XPGA(4)=XPGA(4)+FAC*XCHM
61392       XPGA(5)=XPGA(5)+FAC*XBOT
61393       XPGA(KFL)=XPGA(KFL)+FAC*XVAL
61394       VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
61395   110 CONTINUE
61396       DO 120 KFL=1,5
61397       XPGA(-KFL)=XPGA(KFL)
61398       VXPGA(-KFL)=VXPGA(KFL)
61399   120 CONTINUE
61400 C
61401       RETURN
61402       END
61403 C
61404 C*********************************************************************
61405 C
61406       SUBROUTINE SASBEH(KF,X,Q2,P2,PM2,XPBH)
61407 C...Purpose: to evaluate the Bethe-Heitler cross section for
61408 C...heavy flavour production.
61409       DATA AEM2PI/0.0011614/
61410 C
61411 C...Reset output.
61412       XPBH=0.
61413       SIGBH=0.
61414 C
61415 C...Check kinematics limits.
61416       IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
61417       W2=Q2*(1.-X)/X-P2
61418       BETA2=1.-4.*PM2/W2
61419       IF(BETA2.LT.1E-10) RETURN
61420       BETA=SQRT(BETA2)
61421       RMQ=4.*PM2/Q2
61422 C
61423 C...Simple case: P2 = 0.
61424       IF(P2.LT.1E-4) THEN
61425         IF(BETA.LT.0.99) THEN
61426           XBL=LOG((1.+BETA)/(1.-BETA))
61427         ELSE
61428           XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
61429         ENDIF
61430         SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
61431      &  XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
61432 C
61433 C...Complicated case: P2 > 0, based on approximation of
61434 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
61435       ELSE
61436         RPQ=1.-4.*X**2*P2/Q2
61437         IF(RPQ.GT.1E-10) THEN
61438           RPBE=SQRT(RPQ*BETA2)
61439           IF(RPBE.LT.0.99) THEN
61440             XBL=LOG((1.+RPBE)/(1.-RPBE))
61441             XBI=2.*RPBE/(1.-RPBE**2)
61442           ELSE
61443             RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
61444             XBL=LOG((1.+RPBE)**2/RPBESN)
61445             XBI=2.*RPBE/RPBESN
61446           ENDIF
61447           SIGBH=BETA*(6.*X*(1.-X)-1.)+
61448      &    XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
61449      &    XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
61450         ENDIF
61451       ENDIF
61452 C
61453 C...Multiply by charge-squared etc. to get parton distribution.
61454       CHSQ=1./9.
61455       IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
61456       XPBH=3.*CHSQ*AEM2PI*X*SIGBH
61457 C
61458       RETURN
61459       END
61460 C
61461 C*********************************************************************
61462 C
61463       SUBROUTINE SASDIR(X,Q2,P2,Q02,XPGA)
61464 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
61465 C...as needed in MSbar parametrizations.
61466       DIMENSION XPGA(-6:6)
61467       DATA AEM2PI/0.0011614/
61468 C
61469 C...Reset output.
61470       DO 100 KFL=-6,6
61471       XPGA(KFL)=0.
61472   100 CONTINUE
61473 C
61474 C...Evaluate common x-dependent expression.
61475       XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
61476       CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
61477 C
61478 C...d, u, s part by simple charge factor.
61479       XPGA(1)=(1./9.)*CGAM
61480       XPGA(2)=(4./9.)*CGAM
61481       XPGA(3)=(1./9.)*CGAM
61482 C
61483 C...Also fill for antiquarks.
61484       DO 110 KF=1,5
61485       XPGA(-KF)=XPGA(KF)
61486   110 CONTINUE
61487 C
61488       RETURN
61489       END
61490 C-----------------------------------------------------------------------
61491 CDECK  ID>,  TIMEL.
61492 *CMZ :-        -28/06/01  16.55.32  by  Bryan Webber
61493 *-- Author :    Bryan Webber
61494 C-----------------------------------------------------------------------
61495       SUBROUTINE TIMEL(TRES)
61496 C-----------------------------------------------------------------------
61497 C     DUMMY TIME SUBROUTINE: DELETE AND REPLACE BY SYSTEM
61498 C     ROUTINE GIVING TRES = CPU TIME REMAINING (SECONDS)
61499 C-----------------------------------------------------------------------
61500       REAL TRES
61501       LOGICAL FIRST
61502       DATA FIRST/.TRUE./
61503       SAVE FIRST
61504       IF (FIRST) THEN
61505       WRITE (6,10)
61506    10 FORMAT(/10X,'SUBROUTINE TIMEL CALLED BUT NOT LINKED.'/
61507      &        10X,'DUMMY TIMEL WILL BE USED. DELETE DUMMY'/
61508      &        10X,'AND LINK CERNLIB FOR CPU TIME REMAINING.')
61509       FIRST=.FALSE.
61510       ENDIF
61511       TRES=1E10
61512       END