pythiaeRHIC/pythia/pycttr.f

0001 C*********************************************************************
0002
0003 C...PYCTTR
0004 C...Adapted from PYPREP.
0005 C...Assigns LHA1 colour tags to coloured partons based on
0006 C...K(I,4) and K(I,5) colour connection record.
0007 C...KCS negative signifies that a previous tracing should be continued.
0008 C...(in case the tag to be continued is empty, the routine exits)
0009 C...Starts at I and ends at I or IEND.
0010 C...Special considerations for systems with junctions.
0011
0012       SUBROUTINE PYCTTR(I,KCS,IEND)
0013 C...Double precision and integer declarations.
0014       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
0015       INTEGER PYK,PYCHGE,PYCOMP
0016 C...Commonblocks.
0017       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
0018       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0019       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
0020       COMMON/PYINT1/MINT(400),VINT(400)
0021 C...The common block of colour tags.
0022       COMMON/PYCTAG/NCT,MCT(4000,2)
0023       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
0024       DATA NERRPR/0/
0025       SAVE NERRPR
0026
0027 C...Skip if parton not existing or does not have KCS
0028       IF (K(I,1).LE.0) GOTO 120
0029       KC=PYCOMP(K(I,2))
0030       IF (KC.EQ.0) GOTO 120
0031       KQ=KCHG(KC,2)
0032       IF (KQ.EQ.0) GOTO 120
0033       IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
0034      &    GOTO 120
0035
0036       IF (KCS.GT.0) THEN
0037         NCT=NCT+1
0038 C...Set colour tag of first parton.
0039         MCT(I,KCS-3)=NCT
0040         NCS=NCT
0041       ELSE
0042         KCS=-KCS
0043         NCS=MCT(I,KCS-3)
0044         IF (NCS.EQ.0) GOTO 120
0045       ENDIF
0046
0047       IA=I
0048       NSTP=0
0049   100 NSTP=NSTP+1
0050       IF(NSTP.GT.4*N) THEN
0051         CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
0052         GOTO 120
0053       ENDIF
0054
0055 C...Finished if reached final-state triplet.
0056       IF(K(IA,1).EQ.3) THEN
0057         IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
0058       ENDIF
0059
0060 C...Also finished if reached junction.
0061       IF(K(IA,1).EQ.42) THEN
0062         GOTO 120
0063       ENDIF
0064
0065 C...GOTO next parton in colour space.
0066   110 IB=IA
0067 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
0068       IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
0069      &     .NE.0) THEN
0070         IA=MOD(K(IB,KCS),MSTU(5))
0071         K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
0072         MREV=0
0073       ELSE
0074 C...If KCS mother traced or KCS mother nonexistent, switch colour.
0075         IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
0076      &       MSTU(5)).EQ.0) THEN
0077           KCS=9-KCS
0078           NCT=NCT+1
0079           NCS=NCT
0080 C...Assign new colour tag on other side of old parton.
0081           MCT(IB,KCS-3)=NCT
0082         ENDIF
0083 C...Goto (new) KCS mother, set mother traced tag
0084         IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
0085         K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
0086         MREV=1
0087       ENDIF
0088       IF(IA.LE.0.OR.IA.GT.N) THEN
0089         CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
0090         IF(NERRPR.LT.5) THEN
0091           write(*,*) 'began at ',I
0092           write(*,*) 'ended going from', IB, ' to', IA, '  KCS=',KCS,
0093      &        '  NCS=',NCS,'  MREV=',MREV
0094           CALL PYLIST(4)
0095           NERRPR=NERRPR+1
0096         ENDIF
0097         MINT(51)=1
0098         RETURN
0099       ENDIF
0100       IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
0101      &     MSTU(5)).EQ.IB) THEN
0102         IF(MREV.EQ.1) KCS=9-KCS
0103         IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
0104 C...Set KSC mother traced tag for IA
0105         K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
0106       ELSE
0107         IF(MREV.EQ.0) KCS=9-KCS
0108         IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
0109 C...Set KCS daughter traced tag for IA
0110         K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
0111       ENDIF
0112 C...Assign new colour tag
0113       MCT(IA,KCS-3)=NCS
0114       IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100
0115
0116   120 RETURN
0117       END