* * $Id: hwmevt.F,v 1.1.1.1 1996/03/08 17:02:16 mclareni Exp $ * * $Log: hwmevt.F,v $ * Revision 1.1.1.1 1996/03/08 17:02:16 mclareni * Herwig58 * * *CMZ : 29/08/94 11.51.48 by Unknown *-- Author : CDECK ID>, HWMEVT. *CMZ :- -26/04/91 14.28.59 by Federico Carminati *-- Author : Bryan Webber C------------------------------------------------------------------------ SUBROUTINE HWMEVT C IPROC = 1000,... ADDS SOFT UNDERLYING EVENT C = 8000: CREATES MINIMUM-BIAS EVENT C SUPPRESSED BY ADDING 10000 TO IPROC C------------------------------------------------------------------------ #include "herwig58/herwig58.inc" DOUBLE PRECISION HWREXP,ENFAC,TECM,SECM,SUMM,EMCL,BMP(5),BMR(3,3) INTEGER HWRINT,NETC,IBT,IDBT,ID1,ID2,ID3,KHEP,LHEP,NTRY,ICMS, & NPPBAR,NCL,MCHT,JCL,JD1,JD2,JD3,ICH,MODC,NCHT,INHEP(2), & INID(2,2),JBT IF (IERROR.NE.0) RETURN IF (.NOT.GENSOF) GO TO 990 IF (IPROC.EQ.8000) THEN C---SET UP BEAM AND TARGET CLUSTERS 5 NETC=0 DO 10 IBT=1,2 JBT=IBT IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT) IDBT=IDHW(JBT) IF (IDBT.EQ.73.OR.IDBT.EQ.75) THEN INID(1,IBT)=HWRINT(1,2) INID(2,IBT)=110 ELSEIF (IDBT.EQ.91.OR.IDBT.EQ.93) THEN INID(1,IBT)=116 INID(2,IBT)=HWRINT(7,8) ELSEIF (IDBT.EQ.30) THEN INID(1,IBT)=HWRINT(1,2) INID(2,IBT)=8 ELSEIF (IDBT.EQ.38) THEN INID(1,IBT)=2 INID(2,IBT)=HWRINT(7,8) ELSEIF (IDBT.EQ.34) THEN INID(1,IBT)=3 INID(2,IBT)=HWRINT(7,8) ELSEIF (IDBT.EQ.46) THEN INID(1,IBT)=HWRINT(1,2) INID(2,IBT)=9 ELSEIF (IDBT.EQ.59) THEN INID(1,IBT)=HWRINT(1,2) INID(2,IBT)=HWRINT(7,8) ELSE CALL HWWARN('HWMEVT',100,*999) ENDIF NETC=NETC+ICHRG(IDBT) & -(ICHRG(INID(1,IBT))+ICHRG(INID(2,IBT)))/3 ENFAC=1. IDHW(NHEP+IBT)=19 IDHEP(NHEP+IBT)=91 ISTHEP(NHEP+IBT)=163+IBT JMOHEP(1,NHEP+IBT)=JBT 10 CONTINUE IF (NETC.EQ.0) THEN ID3=HWRINT(1,2) ELSEIF (NETC.EQ.-1) THEN ID3=1 ELSEIF (NETC.EQ.1) THEN ID3=2 ELSE GO TO 5 ENDIF DO 12 IBT=1,2 NHEP=NHEP+1 JBT=IBT IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT) CALL HWVEQU(5,PHEP(1,JBT),PHEP(1,NHEP)) 12 INHEP(IBT)=NHEP ELSE C---FIND BEAM AND TARGET CLUSTERS DO 20 IBT=1,2 DO 15 KHEP=1,NHEP IF (ISTHEP(KHEP).EQ.163+IBT) THEN INHEP(IBT)=KHEP INID(1,IBT)=IDHW(JMOHEP(1,KHEP)) INID(2,IBT)=IDHW(JMOHEP(2,KHEP)) GO TO 20 ENDIF 15 CONTINUE C---COULDN'T FIND ONE INHEP(IBT)=0 20 CONTINUE JCL=-1 C---TEST FOR BOTH FOUND IF (INHEP(1).EQ.0) JCL=INHEP(2) IF (INHEP(2).EQ.0) JCL=INHEP(1) IF (JCL.EQ.0) CALL HWWARN('HWMEVT',101,*999) IF (JCL.GT.0) THEN ISTHEP(JCL)=163 CALL HWCFOR CALL HWCDEC CALL HWDHAD GO TO 90 ENDIF ID3=HWRINT(1,2) ENFAC=ENSOF NETC=0 ENDIF C---FIND SOFT CM MOMENTUM AND MULTIPLICITY NTRY=0 NHEP=NHEP+1 IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',102,*999) ICMS=NHEP IDHW(NHEP)=16 IDHEP(NHEP)=0 ISTHEP(NHEP)=170 CALL HWVSUM(4,PHEP(1,INHEP(1)),PHEP(1,INHEP(2)),PHEP(1,NHEP)) CALL HWUMAS(PHEP(1,NHEP)) TECM=PHEP(5,NHEP) IF (IPROC/1000.EQ.9.OR.IPROC/1000.EQ.5) THEN SECM=TECM*ENFAC ELSE SECM=PHEP(5,3)*ENFAC ENDIF C---CHOOSE MULTIPLICITY 25 CALL HWMULT(SECM,NPPBAR) 30 NCL=0 MCHT=0 IERROR=0 NHEP =ICMS SUMM=0. NTRY=NTRY+1 C---CREATE CLUSTERS 35 NCL=NCL+1 NHEP=NHEP+1 IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',103,*999) JCL=NHEP IDHW(JCL)=19 IDHEP(JCL)=91 IF (NCL.LT.3) THEN ISTHEP(JCL)=170+NCL ID1=INID(1,NCL) ID2=INID(2,NCL) ELSE ID1=ID2-6 IF (NCL.EQ.3) ID1=ID3 ID2=HWRINT(7,8) ISTHEP(JCL)=173 ENDIF JMOHEP(1,JCL)=ICMS JMOHEP(2,JCL)=0 CALL HWVZRO(3,PHEP(1,JCL)) PHEP(4,JCL)=RMASS(ID1)+RMASS(ID2)+0.4+HWREXP( ONE) PHEP(5,JCL)=PHEP(4,JCL) C---HADRONIZE AND DECAY CLUSTERS CALL HWCFLA(ID1,ID2,JD1,JD2) CALL HWCHAD(JCL,JD1,JD2,JD3) IF (IERROR.NE.0) RETURN IF (JD3.EQ.0) THEN EMCL=RMASS(IDHW(NHEP)) IF (PHEP(4,JCL).NE.EMCL) THEN PHEP(4,JCL)=EMCL PHEP(5,JCL)=EMCL PHEP(4,NHEP)=EMCL PHEP(5,NHEP)=EMCL ENDIF ELSE EMCL=PHEP(5,JCL) ENDIF IDPAR(NCL)=JD3 PPAR(5,NCL)=EMCL SUMM=SUMM +EMCL CALL HWDHAD IF (IERROR.NE.0) RETURN C---CHECK CHARGED MULTIPLICITY MODC=0 DO 50 KHEP=JCL,NHEP IF (ISTHEP(KHEP).EQ.1) THEN ICH=ICHRG(IDHW(KHEP)) IF (ICH.NE.0) THEN MCHT=MCHT+ABS(ICH) MODC=MODC+ICH ENDIF ENDIF 50 CONTINUE IF (NCL.EQ.1) THEN NCHT=NPPBAR+NETC+ABS(MODC) GO TO 35 ELSEIF (NCL.EQ.2) THEN NCHT=NCHT+ABS(MODC) IF (NCHT.LT.0) NCHT=NCHT+2 ENDIF IF (MCHT.LT.NCHT) THEN GO TO 35 ELSEIF (MCHT.GT.NCHT) THEN IF (MOD(NTRY,50).EQ.0) GO TO 25 IF (NTRY.LT.NSTRY) GO TO 30 C---NO PHASE SPACE FOR SOFT EVENT NHEP=ICMS-1 IF (IPROC.EQ.8000) THEN C---MINIMUM BIAS: RELABEL BEAM AND TARGET CLUSTERS DO 60 IBT=1,2 KHEP=INHEP(IBT) LHEP=JMOHEP(1,KHEP) ISTHEP(KHEP)=1 IDHEP(KHEP)=IDHEP(LHEP) IDHW(KHEP)=IDHW(LHEP) 60 CONTINUE ELSE C---UNDERLYING EVENT: DECAY THEM ISTHEP(INHEP(1))=163 ISTHEP(INHEP(2))=163 CALL HWCFOR CALL HWCDEC CALL HWDHAD ENDIF GO TO 90 ENDIF C---GENERATE CLUSTER MOMENTA IN CLUSTER CM C FRAME. N.B. SECOND CLUSTER IS TARGET IF (SUMM.GT.TECM) GO TO 25 CALL HWMLPS(NCL,TECM) IF (NCL.EQ.0) GO TO 25 JCL=0 C---ROTATE & BOOST CLUSTERS & DECAY PRODUCTS CALL HWULOF(PHEP(1,ICMS),PHEP(1,INHEP(1)),BMP) CALL HWUROT(BMP, ONE,ZERO,BMR) C---BMR PUTS BEAM ALONG Z AXIS (WE WANT INVERSE) DO 70 KHEP=ICMS+1,NHEP IF (ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190) THEN ISTHEP(KHEP)=ISTHEP(KHEP)+3 LHEP=KHEP JCL=JCL+1 CALL HWUROB(BMR,PPAR(1,JCL),PPAR(1,JCL)) CALL HWULOB(PHEP(1,ICMS),PPAR(1,JCL),PPAR(1,JCL)) C---NOW PPAR(*,JCL) IS LAB MOMENTUM OF JTH CLUSTER ENDIF CALL HWULOB(PPAR(1,JCL),PHEP(1,KHEP),PHEP(1,KHEP)) 70 CONTINUE ISTHEP(INHEP(1))=167 ISTHEP(INHEP(2))=168 JMOHEP(1,ICMS)=INHEP(1) JMOHEP(2,ICMS)=INHEP(2) JDAHEP(1,INHEP(1))=ICMS JDAHEP(2,INHEP(1))=0 JDAHEP(1,INHEP(2))=ICMS JDAHEP(2,INHEP(2))=0 JDAHEP(1,ICMS)=ICMS+1 JDAHEP(2,ICMS)=LHEP 90 CONTINUE C---DO SOFT HEAVY FLAVOUR DECAYS (IF ANY) CALL HWDHVY 990 ISTAT=100 999 END