pythiaeRHIC/pythia/pymihg.f

0001
0002 *********************************************************************
0003
0004 C...PYMIHG
0005 C...Collapse JCP1 and connecting tags to JCG1.
0006 C...Collapse JCP2 and connecting tags to JCG2.
0007
0008       SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
0009 C...Double precision and integer declarations.
0010       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
0011       IMPLICIT INTEGER(I-N)
0012       INTEGER PYK,PYCHGE,PYCOMP
0013 C...The event record
0014       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
0015 C...Parameters
0016       COMMON/PYINT1/MINT(400),VINT(400)
0017       SAVE /PYJETS/,/PYINT1/
0018 C...Local variables
0019       COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
0020       COMMON /PYCTAG/NCT,MCT(4000,2)
0021       SAVE /PYCBLS/,/PYCTAG/
0022
0023 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
0024 C...in temporary tag collapse array JCCN. Only break up one connection.
0025       MACCPT=1
0026       MCLPS=0
0027       DO 100 ICC=1,NCC
0028         JCCN(ICC,1)=JCCO(ICC,1)
0029         JCCN(ICC,2)=JCCO(ICC,2)
0030 C...If there was a mother, it was previously connected to JCP1.
0031 C...Should be changed to JCP2.
0032         IF (MCLPS.EQ.0) THEN
0033           IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
0034      &         ,JCP2)) THEN
0035             JCCN(ICC,1)=MAX(JCG2,JCP2)
0036             JCCN(ICC,2)=MIN(JCG2,JCP2)
0037             MCLPS=1
0038           ENDIF
0039         ENDIF
0040   100 CONTINUE
0041 C...Also collapse colours on JCP1 side of JCG1
0042       IF (JCP1.NE.0) THEN
0043         JCCN(NCC+1,1)=MAX(JCP1,JCG1)
0044         JCCN(NCC+1,2)=MIN(JCP1,JCG1)
0045       ELSE
0046         JCCN(NCC+1,1)=MAX(JCP2,JCG2)
0047         JCCN(NCC+1,2)=MIN(JCP2,JCG2)
0048       ENDIF
0049
0050 C...Initialize event record colour tag array MCT array to MCO.
0051        DO 110 I=MINT(84)+1,N
0052         MCT(I,1)=MCO(I,1)
0053         MCT(I,2)=MCO(I,2)
0054   110 CONTINUE
0055
0056 C...Collapse tags:
0057 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
0058 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
0059 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
0060 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
0061       DO 160 IS=1,4
0062 C...Skip if junction.
0063         IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
0064 C...Define starting point in tag space.
0065 C...JCA = previous tag
0066 C...JCO = present tag
0067 C...JCN = new tag
0068         IF (MOD(IS,2).EQ.1) THEN
0069           JCO=JCP1
0070           JCN=JCG1
0071           JCALL=JCG1
0072         ELSEIF (MOD(IS,2).EQ.0) THEN
0073           JCO=JCP2
0074           JCN=JCG2
0075           JCALL=JCG2
0076         ENDIF
0077         ITRACE=0
0078   120   ITRACE=ITRACE+1
0079         IF (ITRACE.GT.1000) THEN
0080 C...NB: Proper error message should be defined here.
0081           CALL PYERRM(14
0082      &         ,'(PYMIHG:) Inf loop when collapsing colours.')
0083           MINT(57)=MINT(57)+1
0084           MINT(51)=1
0085           RETURN
0086         ENDIF
0087 C...Collapse all JCN tags to JCALL
0088         DO 130 I=MINT(84)+1,N
0089           IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
0090           IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
0091   130   CONTINUE
0092 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
0093         IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
0094           JCA=JCN
0095           JCN=JCO
0096         ELSE
0097           JCA=JCO
0098           JCO=JCN
0099         ENDIF
0100 C...If possible, step from JCO to new tag JCN not equal to JCA.
0101         DO 140 ICC=1,NCC+1
0102           IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
0103      &         JCCN(ICC,2)
0104           IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
0105      &         JCCN(ICC,1)
0106   140   CONTINUE
0107 C...Iterate if new colour was arrived at, but don't go in circles.
0108         IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
0109 C...Change all JCN tags in MCO to JCALL in MCT.
0110         DO 150 I=MINT(84)+1,N
0111           IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
0112           IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
0113 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
0114           IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
0115      &         .NE.0) MACCPT=0
0116   150   CONTINUE
0117   160 CONTINUE
0118
0119       DO 200 JCL=NCT,1,-1
0120         JCA=0
0121         JCN=JCL
0122   170   JCO=JCN
0123         DO 180 ICC=1,NCC+1
0124           IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
0125      &         =JCCN(ICC,2)
0126           IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
0127      &         =JCCN(ICC,1)
0128   180   CONTINUE
0129 C...Overpaint all JCN with JCL
0130         IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
0131           DO 190 I=MINT(84)+1,N
0132             IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
0133             IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
0134 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
0135             IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
0136      &           .NE.0) MACCPT=0
0137   190     CONTINUE
0138           JCA=JCO
0139           GOTO 170
0140         ENDIF
0141   200 CONTINUE
0142
0143       RETURN
0144       END