PROGRAM CRCKIN C---------------------------------------------------------------------- C! Color reconnection for Kingal generators C C This file reads the cards file specified with the environment C variable CRCKINCARDS or if not specified the file crckin.cards. C Accepted cards are described in the sample cards file. The FILI C card reads a Kingal generated EPIO file. The event generation C shall have a call to DUMPCRC just before the LUEXEC call. DUMPCRC C will then create 2 extra banks KLJE and KCRH at the Kingal level. C KLJE basically holds the LUJETS common before fragmentation. That C means simply initial particles and 2 strings. KCRH holds the 2 C strings start and end positions and (optionally) the RANMAR seeds C at the point of the call to DUMPCRC. This is mainly used for test C purposes so that CRCKIN can establish the exact state that Kingal C where in before fragmentation. CRCKIN will then determine C whether Color Reconnection shall occur. If so then it will C rearrange redo the strings and make another fragmentation. If C there were no color reconnection, then the output will just have C the old KINE banks. In the cards file there is an option to C allways re-fragment even though there were no color reconnection. C Also there is an option that saves/deletes the KLJE and KCRH C banks. Color reconnection is only applicable in 4 quark final C states, so that all other final states can be discarded. However, C a switch in the cards file makes it possible to decide whether C those other final states should be on the output or not. C C Features: C The output file have new KINE, VERT and RUNE banks C C Bugs: (known) C C If the KLJE and KCRH banks are dropped then there are is no way C to tell that the events in the file has been color reconnected. C Maybe I should set a flag in a bank somewhere... C C Anders Waananen - April 1997 C C $Id: crckin.F,v 1.1 1997/04/15 20:20:28 waananen Exp waananen $ C---------------------------------------------------------------------- IMPLICIT NONE C INTEGER I,IER,MREC INTEGER INEVT,IKLJE INTEGER IREVT,ISEVT,RAN(3) INTEGER JNEVT,JDEBU,JKLJE,JKCRC,JGCRC,JKCRH,JVERT,JEVEH,JRUNH INTEGER JKEVH,JNREF,NREF,NREF0,NREF1,LBAS INTEGER JPART,JKLIN,LLUGE,LLUAL,KFCOD,KCODE PARAMETER (LLUGE=52,LLUAL=315) REAL TLIF CHARACTER FNAME*120 REAL VTX(4) INTEGER NVRT,NTRK INTEGER IMODE,ISNFQ,IKCRB,IFRFR,IRURN,ISAVE CHARACTER*1 OLIST INTEGER LPDEC,MXDEC PARAMETER (LPDEC = 48) INTEGER NODEC(LPDEC) INTEGER JUNIDB,MDARD,NLINK,NAMIND,KNODEC,LUCOMP,ALRUNE EXTERNAL JUNIDB,MDARD,NLINK,NAMIND,KNODEC,LUCOMP,ALRUNE #include "inout.h" #include "sjkhcr.h" #include "partjj.h" #include "vertjj.h" #include "kevhjj.h" #include "evehjj.h" #include "ludat1.h" #include "ludat2.h" #include "ludat3.h" #include "bcs.h" #include "bmacrod.h" #include "bmacro.h" C C Initialise BOS C CALL BNAMES(MXBNK) CALL BOS(IW,LQBOS) C LCARD = 5 LOUTP = 6 IW(4) = 1 IW(5) = LCARD IW(6) = LOUTP #if defined(DEBUG) OPEN(UNIT=92,FORM='UNFORMATTED') #endif C C Read CARDS file C FNAME = ' ' CALL GETENVF ('CRCKINCARDS',FNAME) IF (FNAME.EQ.' ') FNAME = 'crckin.cards' CALL AOPEN (LCARD,FNAME,'CARD','DISK',IER) IF (IER.EQ.0)THEN CALL BREADC ELSE STOP ENDIF C IKLJE = 0 MREC = 0 C C Open DATABASE C LBAS = JUNIDB(0) CALL AOPDBS (' ',IER) IF (IER.NE.0) THEN WRITE(LOUTP,'(1X,''CRCKIN: NO data base (AOPDBS) - STOP'')') STOP ENDIF C C Look if Production mode ( NREF card ) or not ( no NREF card) C JNREF = IW(NAMIND('NREF')) NREF = 1999 NREF0 = 0 NREF1 = 0 IF (JNREF.GT.0) THEN NREF = IW(JNREF+1) IF (NREF.GE.96 .AND.NREF.LT.200) NREF = NREF*100 C Look if multiple read necessary IF (NREF.GE.9600) NREF1 = MOD(NREF,100) NREF0 = 100*(NREF/100) C Get KREF bank from the DAF WRITE(LOUTP,200) NREF C NREF0 IF (NREF1.NE .0) then IER=MDARD(IW,LBAS,'KREF',NREF0) IF (IER.EQ.0) THEN WRITE(LOUTP,210) NREF0,'Failure' STOP ELSE WRITE(LOUTP,210) NREF0,'Success' ENDIF CALL BCALLC(IW,'KREF',NREF0) ENDIF C NREF IF (NREF.NE.0) then IER=MDARD(IW,LBAS,'KREF',NREF) IF (IER.EQ.0) THEN WRITE(LOUTP,210) NREF,'Failure' STOP ELSE WRITE(LOUTP,210) NREF,'Success' ENDIF CALL BCALLC(IW,'KREF',NREF) ENDIF ENDIF C Set LUND banks from NREF card IF ( NREF.GE.96 .AND.NREF.LT.200) NREF = NREF*100 CALL KXL7CO(IER) C Set LUND banks from cards file CALL BREADC CALL BCALLC(IW,'KCAR',0) CALL KXL7CO(IER) C C NEVT flag C INEVT = 999999999 JNEVT = NLINK('NEVT',0) IF (JNEVT.NE.0) THEN IF (IW(JNEVT).EQ.1) THEN INEVT = IW(JNEVT+1) ENDIF ENDIF C C Debug flag : DEBU C IDEBU = 0 JDEBU = NLINK('DEBU',0) IF (JDEBU.NE.0) THEN IF (IW(JDEBU).EQ.1) THEN IDEBU = IW(JDEBU+1) ENDIF ENDIF C C Color reconnection mode : KCRC C IMODE = 0 ISNFQ = 1 IKCRB = 0 IFRFR = 0 IRURN = 0 JKCRC = NLINK('KCRC',0) IF (JKCRC.NE.0) THEN IF (IW(JKCRC).EQ.5) THEN IMODE = IW(JKCRC+1) ISNFQ = IW(JKCRC+2) IKCRB = IW(JKCRC+3) IFRFR = IW(JKCRC+4) IRURN = IW(JKCRC+5) IF (IMODE.LT.0.OR.IMODE.GT.8) THEN WRITE(LOUTP,*) 'INVALID CRC MODE' STOP ENDIF IF (IMODE.GT.0.AND.IMODE.LT.5) THEN WRITE(LOUTP,*) & 'SORRY COLOR RECONNECTION MODE 1-4 NOT IMPLEMENTED YET' STOP ENDIF ELSE WRITE(LOUTP,*) 'THE LENGTH OF THE KCRC CARD SHOULD BE 5' STOP ENDIF ELSE WRITE(LOUTP,*) 'WARNING: NO KCRC CARD PROVIDED - USING DEFAULTS' ENDIF C C Advanced Color reconnection : GCRC C JGCRC = NLINK('GCRC',0) IF (JGCRC.NE.0) THEN IF (IW(JGCRC).EQ.3) THEN TFRAG = DBLE(RW(JGCRC+1)) RHAD = DBLE(RW(JGCRC+2)) RPROB = DBLE(RW(JGCRC+3)) ELSE WRITE(LOUTP,*) 'THE LENGTH OF THE GCRC CARD SHOULD BE 3' STOP ENDIF ELSE TFRAG = 1.5D0 RHAD = 0.7D0 RPROB = 0.6D0 ENDIF C C Banner + Info C WRITE(LOUTP,110) WRITE(LOUTP,120) ' C O L O R R E C O N N E C T O R ' WRITE(LOUTP,100) WRITE(LOUTP,120) ' Anders Waananen - April 1997 ' WRITE(LOUTP,100) WRITE(LOUTP,120) ' Parameters: ' WRITE(LOUTP,130) 'TFRAG ',TFRAG,' ' WRITE(LOUTP,130) 'RHAD ',RHAD, ' ' WRITE(LOUTP,130) 'RPROB ',RPROB,' ' WRITE(LOUTP,100) WRITE(LOUTP,140) IMODE WRITE(LOUTP,150) (ISNFQ.GT.0) WRITE(LOUTP,160) (IKCRB.GT.0) WRITE(LOUTP,170) (IFRFR.GT.0) WRITE(LOUTP,180) (IRURN.GT.0) WRITE(LOUTP,100) WRITE(LOUTP,100) WRITE(LOUTP,120) ' Reference: ' WRITE(LOUTP,120) ' T. Sjostrand, V.A.Khoze: ' WRITE(LOUTP,120) ' Z. Phys. C62 (1994),281-309 ' WRITE(LOUTP,100) WRITE(LOUTP,120) ' Contact person: ' WRITE(LOUTP,120) ' Anders Waananen ' WRITE(LOUTP,110) 100 FORMAT(1X,'| |') 110 FORMAT(1X,'+--------------------------------------+') 120 FORMAT(1X,'|',A38,'|') 130 FORMAT(1X,'|',4X,A10,' : ',F6.3,A4,10X,' |') 140 FORMAT(1X,'|',4X,'Color Reconnection mode : ',I1,5X,' |') 150 FORMAT(1X,'|',4X,'Keep non 4-quark events : ',L1,5X,' |') 160 FORMAT(1X,'|',4X,'Keep color reconn. banks : ',L1,5X,' |') 170 FORMAT(1X,'|',4X,'Force Re-Fragmentation : ',L1,5X,' |') 180 FORMAT(1X,'|',4X,'Re-Use Random numbers : ',L1,5X,' |') C C Initialise random generator C I = 12345 CALL RDMIN(I) C C Read input file C IREVT = 0 ISEVT = 0 10 CALL ABRSEL('E',' ',IER) CALL BGARB(IW) ISAVE = 0 OLIST='E' IF (IER.EQ.1) IREVT = IREVT + 1 IF (IER.EQ.2) THEN ISAVE = 1 OLIST = 'C' C C Get masses and widths from PART bank C JPART = NLINK('PART',0) JKLIN = NLINK('KLIN',0) DO I = 1, LLUAL+LLUGE KFCOD = IABS(ITABL(JKLIN,I,1)) IF (KFCOD.GT.6) THEN KCODE = LUCOMP(KFCOD) IF (KCODE.GT.0) THEN PMAS(KCODE,1) = RTABL(JPART,I,JPARMA) PMAS(KCODE,2) = RTABL(JPART,I,JPARMW) TLIF = RTABL(JPART,I,JPARLT) IF (TLIF.NE.1.E15) PMAS(KCODE,4) = TLIF/3.33E-12 ENDIF ENDIF ENDDO C C Inhibit decays C MXDEC=KNODEC(NODEC,LPDEC) MXDEC=MIN(MXDEC,LPDEC) IF (MXDEC.GT.0) THEN DO I=1,MXDEC IF (NODEC(I).GT.0) THEN IER = NLINK('MDC1',NODEC(I)) IF (IER .EQ. 0) MDCY(LUCOMP(NODEC(I)),1) = 0 ENDIF ENDDO ENDIF C CALL LULIST(12) C CALL LULIST(13) ENDIF C C Examine event C IF (IER.LT.6.AND.IREVT.LE.INEVT) THEN JEVEH=NLINK('EVEH',0) IF (IDEBU.GT.0) THEN IF (JEVEH.GT.0) & WRITE(LOUTP,*) 'RUN EVT',IW(JEVEH+JEVERN),IW(JEVEH+JEVEEV) ENDIF IF (IDEBU.GT.1) THEN WRITE(LOUTP,*) & '==================================================' IF (IER.EQ.3) WRITE(LOUTP,*) 'UNKNOWN RECORD' CALL AUBLIS(OLIST) CALL AUBLIS('S') CALL AUBLIS('T') ENDIF IF (IER.EQ.3) GOTO 10 IF (ISNFQ.GT.0) ISAVE = 1 JKLJE=NLINK('KLJE',0) JKCRH=NLINK('KCRH',0) IF (JKLJE.GT.0.OR.JKCRH.GT.0) THEN IF (JKLJE.LE.0.OR.JKCRH.LE.0) THEN WRITE (LOUTP,*) 'I did not find both of the banks:' WRITE (LOUTP,*) 'JKLJE,JKCRH',JKLJE,JKCRH STOP ENDIF ISAVE = 1 IKLJE = IKLJE + 1 IF (IDEBU.GT.0) & WRITE(LOUTP,*) 'COLOR RECONNECTION BANKS EXISTS' IF (IMODE.GT.0.OR.IFRFR.GT.0) THEN CALL DOCRC(IMODE,MREC) ELSE IF (IDEBU.GT.0) WRITE(LOUTP,*) 'DO NOTHING' ENDIF IF (IFRFR.GT.0) MREC = 1 C C Fragment strings (Normally only in the case of Color Reconnection) C IF (MREC.GT.0) THEN C C Restore random generator C IF (JKCRH.GT.0.AND.IRURN.GT.0) THEN RAN(1) = ITABL(JKCRH,1,5) RAN(2) = ITABL(JKCRH,1,6) RAN(3) = ITABL(JKCRH,1,7) #if defined(DEBUG) READ(92) RAN(1),RAN(2),RAN(3) #endif CALL RMARIN(RAN(1),RAN(2),RAN(3)) ENDIF C C Fragment C CALL LUEXEC IF (IDEBU.GT.3) CALL LULIST(2) C C Get primary vertex C JVERT = NLINK('VERT',1) IF (JVERT.GT.0) THEN VTX(1) = RW(JVERT+3+JVERVX) VTX(2) = RW(JVERT+3+JVERVY) VTX(3) = RW(JVERT+3+JVERVZ) VTX(4) = RW(JVERT+3+JVERTI) ELSE WRITE(LOUTP,*) 'No primary vertex found' STOP ENDIF C C Create new KHIS, KINE and VERT banks C CALL BDROP(IW,'KHISKINEVERT') CALL KXL7AL(VTX,IER,NVRT,NTRK) IF (IER.NE.0) THEN WRITE(LOUTP,*) 'KXL7AL Failed' STOP ENDIF CALL KIBPRS ('VERTKINE') C C Refill KEVH bank with new values C JKEVH = NLINK('KEVH',0) IW(JKEVH+2+JKEVNT) = NTRK IW(JKEVH+2+JKEVNV) = NVRT CALL RMARUT( & IW(JKEVH+2+JKEVRN), & IW(JKEVH+2+JKEVSR), & IW(JKEVH+2+JKEVTR)) C CALL RRESET ENDIF IF (IDEBU.GT.2) CALL PRKINE ENDIF IF (IKCRB.EQ.0) THEN CALL BDROP(IW,'KLJEKCRH') ENDIF IF (ISAVE.GT.0) THEN IF (JEVEH.GT.0) ISEVT = ISEVT + 1 CALL BGARB(IW) CALL ABWSEL(OLIST) ENDIF GOTO 10 ENDIF CALL BGARB(IW) C C Create and write a new RUNE bank C JRUNH = IW(NAMIND('RUNH')) IER = ALRUNE(IW(JRUNH+2),IW(JRUNH+1),IW(JRUNH+3),ISEVT) CALL BLIST(IW,'C=','RUNE') CALL ABWSEL('C') C C Close output file C CALL ABWEND IF (IDEBU.GT.0) CALL BOSIO CALL ACLOSE(0,IER) C C Summary C WRITE(LOUTP,110) WRITE(LOUTP,100) WRITE(LOUTP,120) ' C O L O R R E C O N N E C T O R ' WRITE(LOUTP,100) WRITE(LOUTP,120) ' S U M M A R Y ' WRITE(LOUTP,100) WRITE(LOUTP,220) IREVT WRITE(LOUTP,230) IKLJE WRITE(LOUTP,240) ISEVT WRITE(LOUTP,100) WRITE(LOUTP,110) 220 FORMAT(1X,'| Number of events read : ',I7,' |') 230 FORMAT(1X,'| Number CRC banks found : ',I7,' |') 240 FORMAT(1X,'| Number of events written : ',I7,' |') 200 FORMAT(1X,'CRCKIN - Accessing Data Base for KREF NR = ',I5) 210 FORMAT(1X,'CRCKIN - Accessing NREF ',I4,2X,A7) END SUBROUTINE DOCRC(IMODE,MREC) C---------------------------------------------------------------------- C! Do the Color reconnection C---------------------------------------------------------------------- IMPLICIT NONE C INTEGER IMODE,MREC,I,J,S DOUBLE PRECISION WM,WW INTEGER LUJ11,LUJ12,LUJ21,LUJ22 INTEGER LUJ1(2),LUJ2(2) DOUBLE PRECISION B1(5),B2(5) INTEGER JKLJE,JKCRH INTEGER NLINK EXTERNAL NLINK REAL MAX,SQRT #include "inout.h" #include "bcs.h" #include "lujets.h" #include "ludat1.h" #include "ludat2.h" #include "ludatr.h" #include "bmacrod.h" #include "bmacro.h" C WM = DBLE(PMAS(23,1)) WW = DBLE(PMAS(23,2)) C JKLJE=NLINK('KLJE',0) JKCRH=NLINK('KCRH',0) IF (JKLJE.LE.0) THEN WRITE(LOUTP,*) 'Error no KLJE bank' RETURN ENDIF C LUJ1(1) = 0 LUJ1(2) = 0 LUJ2(1) = 0 LUJ2(2) = 0 C C Read LUND bank C N = LROWS(JKLJE) S = 0 DO I = 1, N DO J = 1,5 K(I,J) = ITABL(JKLJE,I,J) P(I,J) = RTABL(JKLJE,I,J+5) V(I,J) = RTABL(JKLJE,I,J+10) ENDDO #if defined (DEBUG) READ(92) (K(I,J),P(I,J),V(I,J),J=1,5) #endif C C If no KCRH banks was found, then try to construct it C IF (JKCRH.LE.0) THEN C Start of string IF (K(I,1).EQ.2.AND.S.EQ.0) THEN IF (LUJ11.EQ.0) THEN LUJ11 = I S = 1 ELSE LUJ21 = I S = 2 ENDIF ENDIF C End of string IF (K(I,1).EQ.1.AND.S.GT.0) THEN IF (S.EQ.1) LUJ12 = I IF (S.EQ.2) LUJ22 = I S = 0 ENDIF IF(LUJ11.EQ.0.OR.LUJ12.EQ.0.OR. & LUJ21.EQ.0.OR.LUJ21.EQ.0.OR. & LUJ11.GE.LUJ12.OR.LUJ11.GE.LUJ12) THEN WRITE(LOUTP,*) 'Error : Could not find string start/end' CALL LULIST(2) WRITE(LOUTP,*) 'LUJ11 LUJ12',LUJ11,LUJ12 WRITE(LOUTP,*) 'LUJ21 LUJ22',LUJ21,LUJ22 STOP ENDIF ENDIF ENDDO C IF (JKCRH.LE.0) THEN C String Masses B1(5)=0.0D0 B2(5)=0.0D0 DO I = 1, 4 B1(I) = DBLE(P(LUJ11,I)+P(LUJ12,I)) B2(I) = DBLE(P(LUJ21,I)+P(LUJ22,I)) IF (I.NE.4) THEN B1(5) = B1(5) + B1(I)*B1(I) B2(5) = B2(5) + B2(I)*B2(I) ENDIF ENDDO ENDIF C C READ KCRH bank C IF (JKCRH.GT.0) THEN LUJ11 = ITABL(JKCRH,1,1) LUJ12 = ITABL(JKCRH,1,2) LUJ21 = ITABL(JKCRH,1,3) LUJ22 = ITABL(JKCRH,1,4) #if defined(DEBUG) READ(92) LUJ11,LUJ12,LUJ21,LUJ22 #endif C C Find masses of the two strings C B1(5)=0.0D0 B2(5)=0.0D0 DO I = 1, 4 B1(I) = DBLE(P(LUJ11,I)+P(LUJ12,I)) B2(I) = DBLE(P(LUJ21,I)+P(LUJ22,I)) IF (I.LE.4) THEN B1(5) = B1(5) + B1(I)*B1(I) B2(5) = B2(5) + B2(I)*B2(I) ENDIF ENDDO B1(5) = SQRT(MAX(0.0D0,B1(4)*B1(4)-B1(5))) B2(5) = SQRT(MAX(0.0D0,B2(4)*B2(4)-B2(5))) ENDIF C IF (IDEBU.GT.3) CALL LULIST(2) LUJ1(1) = LUJ11 LUJ1(2) = LUJ12 LUJ2(1) = LUJ21 LUJ2(2) = LUJ22 IF (IMODE.EQ.5) CALL SJOST2(1,B1,B2,WM,WW,LUJ1,LUJ2,MREC) IF (IMODE.EQ.6) CALL SJOST2(2,B1,B2,WM,WW,LUJ1,LUJ2,MREC) IF (IMODE.EQ.7) CALL SJOST3(1,B1,B2,WM,WW,LUJ1,LUJ2,MREC) IF (IMODE.EQ.8) CALL SJOST3(2,B1,B2,WM,WW,LUJ1,LUJ2,MREC) C C Remove shower C IF (MREC.GT.0) THEN I=MSTJ(14) MSTJ(14)=-1 CALL LUPREP(0) MSTJ(14)=I IF (IDEBU.GT.0) WRITE(LOUTP,*)'MREC =',MREC C Offset original partons so that they are not removed by LUEDIT. K(LUJ11,1)=K(LUJ11,1)-20 K(LUJ12,1)=K(LUJ12,1)-20 K(LUJ21,1)=K(LUJ21,1)-20 K(LUJ22,1)=K(LUJ22,1)-20 CALL LUEDIT(12) CALL LUEDIT(14) K(LUJ11,1)=K(LUJ11,1)+20 K(LUJ12,1)=K(LUJ12,1)+20 K(LUJ21,1)=K(LUJ21,1)+20 K(LUJ22,1)=K(LUJ22,1)+20 ENDIF IF (IDEBU.GT.3) CALL LULIST(2) C RETURN END