pythiaeRHIC/pythia/pyrvch.f

0001
0002 C*********************************************************************
0003
0004 C...PYRVCH
0005 C...Calculates R-violating chargino decay widths.
0006 C...P. Z. Skands
0007
0008       SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
0009
0010 C...Double precision and integer declarations.
0011       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
0012       IMPLICIT INTEGER(I-N)
0013 C...Parameter statement to help give large particle numbers.
0014       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
0015      &KEXCIT=4000000,KDIMEN=5000000)
0016 C...Commonblocks.
0017       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0018       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
0019       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
0020       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
0021      &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
0022       COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
0023 C...Local variables.
0024       DOUBLE PRECISION XLAM(0:400)
0025       INTEGER IDLAM(400,3), PYCOMP
0026 C...Information from main routine to PYRVGW
0027       COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
0028      &     ,DCMASS,KFR(3)
0029 C...Auxiliary variables needed for BV (RV Gauge STOre)
0030       COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
0031      &     ,RVLJKI,RVLJIK
0032 C...Running quark masses
0033       DOUBLE PRECISION RMQ(6)
0034 C...Decay product masses on/off
0035       LOGICAL DCMASS
0036       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
0037      &     /RVGSTO/
0038
0039
0040 C...IF R-VIOLATION ON.
0041       IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
0042         KFSM=KFIN-KSUSY1
0043         IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
0044 C...WHICH CHARGINO ?
0045           NCHI = 1
0046           IF (KFSM.EQ.37) NCHI = 2
0047
0048 C...Useful parameters for calculating the A and B constants.
0049 C...SIGN OF MASS (Opposite convention as HERWIG)
0050           ISM  = 1
0051           IF (SMW(NCHI).LT.0D0) ISM = -1
0052           WMASS   = PMAS(PYCOMP(24),1)
0053           COSB    = 1/(SQRT(1+RMSS(5)**2))
0054           SINB    = RMSS(5)/SQRT(1+RMSS(5)**2)
0055           GW2     = 4*PARU(103)*PARU(1)/PARU(102)
0056           C1U     = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
0057           C1V     = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
0058           C2      = UMIX(NCHI,1)
0059           C3      = VMIX(NCHI,1)
0060 C...Running masses at Q^2=MCHI^2.
0061           SQMCHI  = PMAS(PYCOMP(KFSM),1)**2
0062           DO 100 I=1,6
0063             RMQ(I)=PYMRUN(I,SQMCHI)
0064   100     CONTINUE
0065
0066 C... AB(x,y,z) coefficients:
0067 C       x=1-2  : A or B coefficient  (1:A ; 2:B)
0068 C       y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
0069 C                                    11-16:e,nu_e,mu,...)
0070 C       z=1-2  : Mass eigenstate number
0071           DO 110 I = 11,15,2
0072 C...Intermediate sleptons
0073             AB(1,I,1)   = 0D0
0074             AB(1,I,2)   = 0D0
0075             AB(2,I,1)   = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
0076      &           SFMIX(I,1)*C2
0077             AB(2,I,2)   = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
0078      &           SFMIX(I,3)*C2
0079 C...Intermediate sneutrinos
0080             AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
0081             AB(1,I+1,2) = 0D0
0082             AB(2,I+1,1) = ISM*C3
0083             AB(2,I+1,2) = 0D0
0084 C...Intermediate sdown
0085             J=I-10
0086             AB(1,J,1)   = -RMQ(J+1)*C1V*SFMIX(J,1)
0087             AB(1,J,2)   = -RMQ(J+1)*C1V*SFMIX(J,3)
0088             AB(2,J,1)   = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
0089             AB(2,J,2)   = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
0090 C...Intermediate sup
0091             J=J+1
0092             AB(1,J,1)   = -RMQ(J-1)*C1U*SFMIX(J,1)
0093             AB(1,J,2)   = -RMQ(J-1)*C1U*SFMIX(J,3)
0094             AB(2,J,1)   = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
0095             AB(2,J,2)   = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
0096   110     CONTINUE
0097
0098 C...LLE TYPE R-VIOLATION
0099           IF (IMSS(51).GE.1) THEN
0100 C...LOOP OVER DECAY MODES
0101             DO 140 ISC=0,26
0102
0103 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
0104               IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
0105                 LKNT = LKNT+1
0106                 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
0107                 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
0108                 IDLAM(LKNT,3) =  12 +2*MOD(ISC,3)
0109                 XLAM(LKNT)    =  0D0
0110 C...Set coupling, and decay product masses on/off
0111                 RVLAMC        = GW2 * 5D-1 *
0112      &               RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
0113      &               **2
0114                 DCMASS=.FALSE.
0115                 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
0116 C...Resonance KF codes (1=I,2=J,3=K).
0117                 KFR(1) = 0
0118                 KFR(2) = 0
0119                 KFR(3) = -IDLAM(LKNT,3)+1
0120 C...Calculate width.
0121                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0122      &               IDLAM(LKNT,3),XLAM(LKNT))
0123                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
0124 C...KINEMATICS CHECK
0125                 IF (XLAM(LKNT).EQ.0D0) THEN
0126                   LKNT=LKNT-1
0127                 ENDIF
0128
0129 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
0130   120           IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
0131                   LKNT = LKNT+1
0132                   IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
0133                   IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
0134                   IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
0135                   XLAM(LKNT)    = 0D0
0136 C...Set coupling, and decay product masses on/off
0137                   RVLAMC = GW2 * 5D-1 *
0138      &              RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
0139 C...I,J SYMMETRY => FACTOR 2
0140                   RVLAMC=2*RVLAMC
0141                   DCMASS=.FALSE.
0142                   IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
0143 C...Resonance KF codes (1=I,2=J,3=K)
0144                   KFR(1)=IDLAM(LKNT,1)-1
0145                   KFR(2)=IDLAM(LKNT,2)-1
0146                   KFR(3)=0
0147 C...Calculate width.
0148                   CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0149      &                 IDLAM(LKNT,3),XLAM(LKNT))
0150                  XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
0151 C...KINEMATICS CHECK
0152                   IF (XLAM(LKNT).EQ.0D0) THEN
0153                     LKNT=LKNT-1
0154                   ENDIF
0155   130           ENDIF
0156
0157 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
0158                 LKNT = LKNT+1
0159                 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
0160                 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
0161                 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
0162                 XLAM(LKNT)    = 0D0
0163 C...Set coupling, and decay product masses on/off
0164                 RVLAMC = GW2 * 5D-1 *
0165      &             RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
0166 C...I,J SYMMETRY => FACTOR 2
0167                 RVLAMC=2*RVLAMC
0168                 DCMASS=.FALSE.
0169                 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
0170      &               .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
0171 C...Resonance KF codes (1=I,2=J,3=K)
0172                 KFR(1) =-IDLAM(LKNT,1)+1
0173                 KFR(2) =-IDLAM(LKNT,2)+1
0174                 KFR(3) = 0
0175 C...Calculate width.
0176                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0177      &               IDLAM(LKNT,3),XLAM(LKNT))
0178                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
0179 C...KINEMATICS CHECK
0180                 IF (XLAM(LKNT).EQ.0D0) THEN
0181                   LKNT=LKNT-1
0182                 ENDIF
0183               ENDIF
0184   140       CONTINUE
0185           ENDIF
0186
0187 C...LQD TYPE R-VIOLATION
0188           IF (IMSS(52).GE.1) THEN
0189 C...LOOP OVER DECAY MODES
0190             DO 180 ISC=0,26
0191
0192 C...CHI+ -> NUBAR_I + DBAR_J + U_K
0193               LKNT = LKNT+1
0194               IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
0195               IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
0196               IDLAM(LKNT,3) =  2 +2*MOD(ISC,3)
0197               XLAM(LKNT)    =  0D0
0198 C...Set coupling, and decay product masses on/off
0199               RVLAMC = 3. * GW2 * 5D-1 *
0200      &           RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
0201               DCMASS=.FALSE.
0202               IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
0203      &             DCMASS = .TRUE.
0204 C...Resonance KF codes (1=I,2=J,3=K)
0205               KFR(1)=0
0206               KFR(2)=0
0207               KFR(3)=-IDLAM(LKNT,3)+1
0208 C...Calculate width.
0209               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
0210      &             ,XLAM(LKNT))
0211               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
0212 C...KINEMATICS CHECK
0213               IF (XLAM(LKNT).EQ.0D0) THEN
0214                 LKNT=LKNT-1
0215               ENDIF
0216
0217 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
0218   150         LKNT = LKNT+1
0219               IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
0220               IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
0221               IDLAM(LKNT,3) =  2 +2*MOD(ISC,3)
0222               XLAM(LKNT)    =  0D0
0223 C...Set coupling, and decay product masses on/off
0224               RVLAMC = 3. * GW2 * 5D-1 *
0225      &             RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
0226               DCMASS=.FALSE.
0227               IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
0228      &             .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
0229 C...Resonance KF codes (1=I,2=J,3=K)
0230               KFR(1)=0
0231               KFR(2)=0
0232               KFR(3)=-IDLAM(LKNT,3)+1
0233 C...Calculate width.
0234               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
0235      &             ,XLAM(LKNT))
0236               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
0237 C...KINEMATICS CHECK
0238               IF (XLAM(LKNT).EQ.0D0) THEN
0239                 LKNT=LKNT-1
0240               ENDIF
0241
0242 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
0243   160         LKNT = LKNT+1
0244               IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
0245               IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
0246               IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
0247               XLAM(LKNT)    =  0D0
0248 C...Set coupling, and decay product masses on/off
0249               RVLAMC = 3. * GW2 * 5D-1 *
0250      &             RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
0251               DCMASS = .FALSE.
0252               IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
0253      &             .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
0254 C...Resonance KF codes (1=I,2=J,3=K)
0255               KFR(1)=-IDLAM(LKNT,1)+1
0256               KFR(2)=-IDLAM(LKNT,2)+1
0257               KFR(3)=0
0258 C...Calculate width.
0259               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
0260      &             ,XLAM(LKNT))
0261               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
0262 C...KINEMATICS CHECK
0263               IF (XLAM(LKNT).EQ.0D0) THEN
0264                 LKNT=LKNT-1
0265               ENDIF
0266
0267 C * CHI+ -> NU_I + U_J + DBAR_K.
0268   170         LKNT = LKNT+1
0269               IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
0270               IDLAM(LKNT,2) =  2 +2*MOD(ISC/3,3)
0271               IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
0272               XLAM(LKNT)    =  0D0
0273 C...Set coupling, and decay product masses on/off
0274               DCMASS = .FALSE.
0275               RVLAMC = 3. * GW2 * 5D-1 *
0276      &             RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
0277               IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
0278      &             DCMASS = .TRUE.
0279 C...Resonance KF codes (1=I,2=J,3=K)
0280               KFR(1)=IDLAM(LKNT,1)-1
0281               KFR(2)=IDLAM(LKNT,2)-1
0282               KFR(3)=0
0283 C...Calculate width.
0284               CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
0285      &             ,XLAM(LKNT))
0286               XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
0287 C...KINEMATICS CHECK
0288               IF (XLAM(LKNT).EQ.0D0) THEN
0289                 LKNT=LKNT-1
0290               ENDIF
0291
0292   180       CONTINUE
0293           ENDIF
0294
0295 C...UDD TYPE R-VIOLATION
0296 C...These decays need special treatment since more than one BV coupling
0297 C...contributes (with interference). Consider e.g. (symbolically)
0298 C      |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
0299 C             +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
0300 C             +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
0301 C...The problem is that a single call to PYRVGW would evaluate all
0302 C...these terms and sum them, but without the different couplings. The
0303 C...way out is to call PYRVGW three times, once for the first line, once
0304 C...for the second line, and then once for all the lines (it is
0305 C...impossible to get just the last line out) without multiplying by
0306 C...couplings. The last line is then obtained as the result of the third
0307 C...call minus the results of the two first calls. Each term is then
0308 C...multiplied by its respective coupling before the whole thing is
0309 C...summed up in XLAM.
0310 C...Note that with three interfering resonances, this procedure becomes
0311 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
0312
0313           IF (IMSS(53).GE.1) THEN
0314 C...LOOP OVER DECAY MODES
0315             DO 190 ISC=1,25
0316
0317 C...CHI+ -> U_I + U_J + D_K
0318 C...Decay mode I<->J symmetric.
0319               IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
0320                 LKNT = LKNT+1
0321                 IDLAM(LKNT,1) =  2 +2*MOD(ISC/9,3)
0322                 IDLAM(LKNT,2) =  2 +2*MOD(ISC/3,3)
0323                 IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
0324                 XLAM(LKNT)    =  0D0
0325 C...Set coupling, and decay product masses on/off
0326                 RVLAMC= 6. * GW2 * 5D-1
0327                 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
0328      &               +1)
0329                 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
0330      &               +1)
0331                 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
0332      &               * RVLAMC
0333                 DCMASS=.FALSE.
0334                 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
0335      &               .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
0336 C...Resonance KF codes (1=I,2=J,3=K)
0337                 KFR(1) = -IDLAM(LKNT,1)+1
0338                 KFR(2) = 0
0339                 KFR(3) = 0
0340 C...Calculate width.
0341                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0342      &               IDLAM(LKNT,3),XRESI)
0343 C...Resonance KF codes (1=I,2=J,3=K)
0344                 KFR(1) = 0
0345                 KFR(2) = -IDLAM(LKNT,2)+1
0346                 KFR(3) = 0
0347 C...Calculate width.
0348                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0349      &               IDLAM(LKNT,3),XRESJ)
0350 C...Resonance KF codes (1=I,2=J,3=K)
0351                 KFR(1) = -IDLAM(LKNT,1)+1
0352                 KFR(2) = -IDLAM(LKNT,2)+1
0353                 KFR(3) = 0
0354 C...Calculate width.
0355                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0356      &               IDLAM(LKNT,3),XRESIJ)
0357                 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
0358                   XRESIJ = XRESIJ-XRESI-XRESJ
0359                 ELSE
0360                   XRESIJ = 0D0
0361                 ENDIF
0362 C...CALCULATE TOTAL WIDTH
0363                 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
0364      &               + RVLJIK*RVLIJK * XRESIJ
0365                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
0366 C...KINEMATICS CHECK
0367                 IF (XLAM(LKNT).EQ.0D0) THEN
0368                   LKNT=LKNT-1
0369                 ENDIF
0370               ENDIF
0371 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
0372 C...Symmetry I<->J<->K.
0373               IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
0374      &             .MOD(ISC,3)).AND.ISC.NE.13) THEN
0375                 LKNT = LKNT+1
0376                 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
0377                 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
0378                 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
0379                 XLAM(LKNT)    =  0D0
0380 C...Set coupling, and decay product masses on/off
0381                 RVLAMC = 6. * GW2 * 5D-1
0382                 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
0383      &               +1)
0384                 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
0385      &               +1)
0386                 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
0387      &               +1)
0388                 DCMASS = .FALSE.
0389                 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
0390      &               .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
0391 C...Collect symmetry factors
0392                 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
0393      &               .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
0394      &               RVLAMC = 5D-1 * RVLAMC
0395 C...Resonance KF codes (1=I,2=J,3=K)
0396                 KFR(1) = IDLAM(LKNT,1)-1
0397                 KFR(2) = 0
0398                 KFR(3) = 0
0399 C...Calculate width.
0400                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0401      &               IDLAM(LKNT,3),XRESI)
0402 C...Resonance KF codes (1=I,2=J,3=K)
0403                 KFR(1) = 0
0404                 KFR(2) = IDLAM(LKNT,2)-1
0405                 KFR(3) = 0
0406 C...Calculate width.
0407                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0408      &               IDLAM(LKNT,3),XRESJ)
0409 C...Resonance KF codes (1=I,2=J,3=K)
0410                 KFR(1) = 0
0411                 KFR(2) = 0
0412                 KFR(3) = IDLAM(LKNT,3)-1
0413 C...Calculate width.
0414                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0415      &               IDLAM(LKNT,3),XRESK)
0416 C...Resonance KF codes (1=I,2=J,3=K)
0417                 KFR(1) = IDLAM(LKNT,1)-1
0418                 KFR(2) = IDLAM(LKNT,2)-1
0419                 KFR(3) = 0
0420 C...Calculate width.
0421                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0422      &               IDLAM(LKNT,3),XRESIJ)
0423                 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
0424                   XRESIJ = XRESI+XRESJ-XRESIJ
0425                 ELSE
0426                   XRESIJ = 0D0
0427                 ENDIF
0428 C...Resonance KF codes (1=I,2=J,3=K)
0429                 KFR(1) = 0
0430                 KFR(2) = IDLAM(LKNT,2)-1
0431                 KFR(3) = IDLAM(LKNT,3)-1
0432 C...Calculate width.
0433                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0434      &               IDLAM(LKNT,3),XRESJK)
0435                 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
0436                   XRESJK = XRESJ+XRESK-XRESJK
0437                 ELSE
0438                   XRESJK = 0D0
0439                 ENDIF
0440 C...Resonance KF codes (1=I,2=J,3=K)
0441                 KFR(1) = IDLAM(LKNT,1)-1
0442                 KFR(2) = 0
0443                 KFR(3) = IDLAM(LKNT,3)-1
0444 C...Calculate width.
0445                 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
0446      &               IDLAM(LKNT,3),XRESIK)
0447                 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
0448                   XRESIK = XRESI+XRESK-XRESIK
0449                 ELSE
0450                   XRESIK = 0D0
0451                 ENDIF
0452 C...CALCULATE TOTAL WIDTH
0453                 XLAM(LKNT) =
0454      &                 RVLIJK**2 * XRESI
0455      &               + RVLJKI**2 * XRESJ
0456      &               + RVLKIJ**2 * XRESK
0457      &               + RVLIJK*RVLJKI * XRESIJ
0458      &               + RVLIJK*RVLKIJ * XRESIK
0459      &               + RVLJKI*RVLKIJ * XRESJK
0460                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
0461 C...KINEMATICS CHECK
0462                 IF (XLAM(LKNT).EQ.0D0) THEN
0463                   LKNT=LKNT-1
0464                 ENDIF
0465               ENDIF
0466   190       CONTINUE
0467           ENDIF
0468         ENDIF
0469       ENDIF
0470
0471       RETURN
0472       END