CDECK ID>, EZUSER. CDECK ID>, ZUINIT. Subroutine ZUINIT * ================= IMPLICIT NONE INTEGER Nwds_HBOOK PARAMETER (Nwds_HBOOK=5000000) REAL HMEM COMMON/PAWC/ HMEM(Nwds_HBOOK) integer FEVT common/count/FEVT integer ndx1,istat parameter(ndx1= 28) real xt(ndx1) character*8 tags(ndx1) data tags /'nrun','nevt','ehad','xhad','yhad', & 'zhad','etot','xtot','ytot','ztot', & 'vtx','vty','vtz','xepos','yepos', & 'zepos','efcal','xda','q2da','q2jb', & 'yjb','yelec','epz','eene','ethe', & 'ephi','ncz','elf'/ integer NKIN parameter(NKIN=12) real AKIN(NKIN) character*8 KTAG(NKIN) data KTAG/'xelec','yelec','q2elec', + 'xjb','yjb','q2jb', + 'xda','yda','q2da', + 'xmix','ymix','q2mix'/ INTEGER IEVT,ldmp,ndbg COMMON/USER/IEVT,ldmp,ndbg CALL HLIMIT(-Nwds_HBOOK) call hropen(88,'ntup','evtsel.rz','n',1024,istat) call hbookn(100,'All Var',ndx1,'ntup',1000,tags) CALL HBOOKN(200,'Kin Var',NKIN,'ntup',1000,KTAG) IEVT = 0 LDMP = 71 NDbg = 5 FEVT = 0 return end CDECK ID>, ZUANAL. Subroutine ZUANAL(IWant) * ======================= IMPLICIT NONE CHARACTER*4 GENKEY INTEGER IEVT,NDZ,cntl,ndq,ndp,nq,ng,ngb parameter(NDQ=50,ndp=200,NDZ=500) INTEGER IWANT,LDMP,NDBG,NCZ,NRUN,NEVT,i,j,iend REAL pq(4,ndq),pg(4,ndp),pe(4),pgb(4,ndp),PZ(4,NDZ),EZ(4) COMMON/USER/IEVT,ldmp,ndbg Real EnergyCuts(10) Integer NrCond, IErr Character*8 Class Logical Ifirst,lerr Save Ifirst DATA Ifirst /.TRUE./ real ele_ene,ele_phi,ele_theta,ejet(4),etot(4), & vx(3),epos(3),efcal,xreco1,qreco1,q2jb,yjb,yel,aempz integer selcal,ibox,firstefinder C real cellnr,Cellclr1(45000),Cellclr2(45000) common/cellclr/cellclr1(45000),cellclr2(45000) integer ndx1 parameter(ndx1=28) real xt(ndx1) REAL calcut,emax,tmcut,halvar,chisq,imuon ! for global vetos INTEGER muflag,isiflag,itake,haloflag C C system-defined parameters for the Table Package Programmer C INTEGER MINC,MAXC,NEXT,INULL,IANY,INS,REP,ORD,UNO,AND,OR,DIF,HOR, + VER,ALL,ID,ALLCOL, + COUTAB,COUSEL,GETIND,GETSEL,GETPRO,GETDFL,GETTDF,SPATAB, + CHKTAP,MAKTAB REAL RNULL,RANY CHARACTER*4 CNULL,CANY LOGICAL BELSEL,BELTAB,CHKREL,CHKTAB,CHKWIN C C MINC and MAXC for cursors operation C PARAMETER (MINC=1, MAXC=2147483647) C C null values C PARAMETER (INULL=2147483647, RNULL= 699050*16.0**26, CNULL='====') C C ANY values C PARAMETER (IANY=-INULL, RANY=-RNULL, CANY='!@)(') C C NEXT for insertion C PARAMETER (NEXT=INULL) C C Modes C PARAMETER (INS = 1, REP = 2, + ORD = 1, UNO = 2, + AND = 1, OR = 2, DIF=3, + HOR = 1, VER = 2) C C Indices C PARAMETER (ALL = 1-INULL , ID = INULL-1, ALLCOL = 1-INULL) INTEGER ZDSKEY,ZDSKEY_9999 INTEGER ZDSKEY_ID,ZDSKEY_Nr1,ZDSKEY_Nr2,ZDSKEY_TStam11, + ZDSKEY_TStam12,ZDSKEY_TStam21,ZDSKEY_TStam22 CHARACTER*4 ZDSKEY_GAFTyp CHARACTER*32 ZDSKEY_DflNAM COMMON/ZDSKEY/ZDSKEY,ZDSKEY_ID,ZDSKEY_GAFTyp,ZDSKEY_Nr1, + ZDSKEY_Nr2,ZDSKEY_TStam11,ZDSKEY_TStam12,ZDSKEY_TStam21, + ZDSKEY_TStam22,ZDSKEY_DflNAM,ZDSKEY_9999 INTEGER FMCRun,FMCRun_9999 INTEGER FMCRun_ID,FMCRun_Date,FMCRun_Generator_ CHARACTER*16 FMCRun_GenerName,FMCRun_Institute,FMCRun_Generator COMMON/FMCRun/FMCRun,FMCRun_ID,FMCRun_GenerName,FMCRun_Institute, + FMCRun_Date(2),FMCRun_Generator,FMCRun_Generator_,FMCRun_9999 INTEGER FMCEvt,FMCEvt_9999 INTEGER FMCEvt_ID,FMCEvt_EvtNum,FMCEvt_MozRNDM,FMCEvt_Generator_ CHARACTER*16 FMCEvt_Generator REAL FMCEvt_Weight COMMON/FMCEvt/FMCEvt,FMCEvt_ID,FMCEvt_EvtNum,FMCEvt_MozRNDM(2), + FMCEvt_Weight,FMCEvt_Generator,FMCEvt_Generator_,FMCEvt_9999 INTEGER ZREVT,ZREVT_9999 INTEGER ZREVT_ID,ZREVT_RunNr,ZREVT_EvtNr,ZREVT_Time,ZREVT_TrgMsk, + ZREVT_SelMsk COMMON/ZREVT/ZREVT,ZREVT_ID,ZREVT_RunNr,ZREVT_EvtNr(3), + ZREVT_Time(2),ZREVT_TrgMsk(3),ZREVT_SelMsk(3),ZREVT_9999 INTEGER XWTPH,XWTPH_9999 INTEGER XWTPH_ID,XWTPH_Quality,XWTPH_XJetEt,XWTPH_XMIPEt,XWTPH_Num REAL XWTPH_E,XWTPH_PH,XWTPH_XYZin,XWTPH_XYZout COMMON/XWTPH/XWTPH,XWTPH_ID,XWTPH_Num,XWTPH_E,XWTPH_PH(2), + XWTPH_Quality(2),XWTPH_XYZin(3),XWTPH_XYZout(3),XWTPH_XJetEt, + XWTPH_XMIPEt,XWTPH_9999 INTEGER Nwds_HBOOK PARAMETER (Nwds_HBOOK=5000000) REAL HMEM COMMON/PAWC/ HMEM(Nwds_HBOOK) INTEGER CConSa,CConSa_9999 INTEGER CConSa_ID,CConSa_NcEmc,CConSa_NcHac1,CConSa_NcHac2, + CConSa_Cidclu CHARACTER*8 CConSa_class REAL CConSa_x,CConSa_y,CConSa_z,CConSa_E,CConSa_radius,CConSa_cx, + CConSa_cy,CConSa_cz,CConSa_Eemc,CConSa_Cemc,CConSa_Ehac1, + CConSa_Chac1,CConSa_Ehac2,CConSa_Chac2 COMMON/CConSa/CConSa,CConSa_ID,CConSa_class,CConSa_x,CConSa_y, + CConSa_z,CConSa_E,CConSa_radius,CConSa_cx,CConSa_cy,CConSa_cz, + CConSa_Eemc,CConSa_Cemc(3),CConSa_Ehac1,CConSa_Chac1(3), + CConSa_Ehac2,CConSa_Chac2(3),CConSa_NcEmc,CConSa_NcHac1, + CConSa_NcHac2,CConSa_Cidclu,CConSa_9999 INTEGER Caltru,Caltru_9999 INTEGER Caltru_ID,Caltru_CConSa,Caltru_CuPaOb,Caltru_Cellnr REAL Caltru_E,Caltru_imbal,Caltru_t COMMON/Caltru/Caltru,Caltru_ID,Caltru_Cellnr,Caltru_E, + Caltru_imbal,Caltru_t(2),Caltru_CConSa,Caltru_CuPaOb, + Caltru_9999 integer FEVT common/count/FEVT INTEGER LMEB,LMEB_9999 INTEGER LMEB_ID,LMEB_ADCge,LMEB_EnFla,LMEB_Rgxy,LMEB_Rexy COMMON/LMEB/LMEB,LMEB_ID,LMEB_ADCge,LMEB_EnFla,LMEB_Rgxy(8), + LMEB_Rexy(8),LMEB_9999 INTEGER LMEBRE,LMEBRE_9999 INTEGER LMEBRE_ID REAL LMEBRE_Enrg,LMEBRE_Denrg,LMEBRE_Enre,LMEBRE_Denre COMMON/LMEBRE/LMEBRE,LMEBRE_ID,LMEBRE_Enrg,LMEBRE_Denrg, + LMEBRE_Enre,LMEBRE_Denre,LMEBRE_9999 IWANT = 1 IEVT = IEVT + 1 If(Ifirst) then ! Initialisation Ifirst=.FALSE. call ccgeom(IErr) write(6,*) ' ccgeom reports: IErr= ',IErr End If if(MOD(IEVT,100).EQ.1)WRITE(6,*)'# of input Evt ========> ',IEVT CALL DEFGEN(GENKEY) IF(GENKEY.EQ.'DATA') THEN WRITE(6,*) 'We think this is real data' ELSE WRITE(6,*) 'We think this is MC data' ENDIF iend = coutab(FMCRun) ! Get run# and Evt# if(iend.ne.0) then call fettab(FMCevt,id,1) call fettab(FMCrun,id,1) nrun = FMCRun_Date(1) nevt = FMCevt_EvtNum else iend = coutab(ZREVt) if(iend.ne.0) then call fettab(ZREVt,id,1) nrun = ZREVt_runnr nevt = ZREVt_evtNR(3) else write(6,*)'We dont know how to get Run # EVT #' return endif endif nrun = ZDSKEY_Nr1 nevt = ZDSKEY_Nr2 C G L O B A L V E T O S call mutrig(calcut,emax,tmcut,halvar,chisq,imuon,muflag) if(muflag.ge.50) then write(6,*) 'COSMIC MUON BY MUTRIG -- reject',muflag return end if call isitamu(isiflag) if (isiflag.eq.2) then write(6,*) 'REJECTED BY ISITAMU -- reject',isiflag return endif call RMSPARK(Itake) if(Itake.ne.0) then write(6,*) 'SPARK FOUND by RMSPARK -- reject',itake return end if call alhalo2(haloflag) if(muflag.ge.10) then write(6,*) 'REJECTED BY alhalo2 -- reject',haloflag return end if C P A R T O N :: G E N E R A T O R L E V E L cntl=100*LDMP + MAX(9,NDBG)*10 + 7 if(coutab(FMCRun).ne.0) then call getgen(cntl,ndq,ndp,nq,pq,ng,pg,pe,ngb,pgb) endif iend = coutab(CConSa) ! Make ConSa if there is not. if(iend.le.0) then call vfill(EnergyCuts,10,-1.) call PCCnds(EnergyCuts,NrCond,IErr) do i=1,NrCond call fettab(CConSa,id,i) call PCIdCo (CConSa_ID,Class,IErr) end do end if C Z E P H Y R L E V E L C Condensate level selcal=1 C Cell level selcal=2 C box-cut ibox=1 C no box-cut ibox=0 C ++++++++++++++++++++++++++++++++ selcal = 2 ibox = 1 C ++++++++++++++++++++++++++++++++ call GETZEP(selcal,ibox,NDz,NCz,Pz,Ez,ejet,etot,vx,epos,efcal, + xreco1,qreco1,q2jb,yjb,yel,aempz, + ele_ene,ele_phi,ele_theta,firstefinder) If(ncz.GT.0) THEN FEVT = FEVT + 1 write(97,*) nrun,nevt write(70,*)nrun,nevt,selcal,ibox,ejet,etot,vx,epos,efcal, & xreco1,qreco1,q2jb,yjb,yel,aempz write(70,*)nq,((pq(i,j),i=1,4),j=1,nq) write(70,*)ng,((pg(i,j),i=1,4),j=1,ng),(pe(i),i=1,4) write(70,*)ncz,((pz(i,j),i=1,4),j=1,ncz),(ez(i),i=1,4) xt(27) = NCZ ENDIF xt(1) = nrun xt(2) = nevt xt(3) = ejet(1) xt(4) = ejet(2) xt(5) = ejet(3) xt(6) = ejet(4) xt(7) = etot(1) xt(8) = etot(2) xt(9) = etot(3) xt(10)= etot(4) xt(11)= vx(1) xt(12)= vx(2) xt(13)= vx(3) xt(14)= epos(1) xt(15)= epos(2) xt(16)= epos(3) xt(17)= efcal xt(18)= xreco1 xt(19)= qreco1 xt(20)= q2jb xt(21)= yjb xt(22)= yel xt(23)= aempz xt(24)= ele_ene xt(25)= ele_theta xt(26)= ele_phi xt(28)= firstefinder call hfn(100,xt) 99999 Return End CDECK ID>, ZUTERM. Subroutine ZUTERM * ================= implicit none integer FEVT common/count/FEVT INTEGER Nwds_HBOOK PARAMETER (Nwds_HBOOK=5000000) REAL HMEM COMMON/PAWC/ HMEM(Nwds_HBOOK) INTEGER icycle INTEGER IEVT,ldmp,ndbg COMMON/USER/IEVT,ldmp,ndbg WRITE(6,*)'# of input Evt: ',IEVT WRITE(6,*)'# of final Evt: ',FEVT icycle=1 call hldir(' ',' ') call hrout(0,icycle,' ') call hrend('ntup') return end CDECK ID>, GETGEN. SUBROUTINE GETGEN( ICNTL, NQ, NP, 1 NQUARK, PQUARK, NIDEAL, PIDEAL, PELGEN, NGENBP, PGENBP) C C system-defined parameters for the Table Package Programmer C INTEGER MINC,MAXC,NEXT,INULL,IANY,INS,REP,ORD,UNO,AND,OR,DIF,HOR, + VER,ALL,ID,ALLCOL, + COUTAB,COUSEL,GETIND,GETSEL,GETPRO,GETDFL,GETTDF,SPATAB, + CHKTAP,MAKTAB REAL RNULL,RANY CHARACTER*4 CNULL,CANY LOGICAL BELSEL,BELTAB,CHKREL,CHKTAB,CHKWIN C C MINC and MAXC for cursors operation C PARAMETER (MINC=1, MAXC=2147483647) C C null values C PARAMETER (INULL=2147483647, RNULL= 699050*16.0**26, CNULL='====') C C ANY values C PARAMETER (IANY=-INULL, RANY=-RNULL, CANY='!@)(') C C NEXT for insertion C PARAMETER (NEXT=INULL) C C Modes C PARAMETER (INS = 1, REP = 2, + ORD = 1, UNO = 2, + AND = 1, OR = 2, DIF=3, + HOR = 1, VER = 2) C C Indices C PARAMETER (ALL = 1-INULL , ID = INULL-1, ALLCOL = 1-INULL) INTEGER ZDSKEY,ZDSKEY_9999 INTEGER ZDSKEY_ID,ZDSKEY_Nr1,ZDSKEY_Nr2,ZDSKEY_TStam11, + ZDSKEY_TStam12,ZDSKEY_TStam21,ZDSKEY_TStam22 CHARACTER*4 ZDSKEY_GAFTyp CHARACTER*32 ZDSKEY_DflNAM COMMON/ZDSKEY/ZDSKEY,ZDSKEY_ID,ZDSKEY_GAFTyp,ZDSKEY_Nr1, + ZDSKEY_Nr2,ZDSKEY_TStam11,ZDSKEY_TStam12,ZDSKEY_TStam21, + ZDSKEY_TStam22,ZDSKEY_DflNAM,ZDSKEY_9999 INTEGER XWTPH,XWTPH_9999 INTEGER XWTPH_ID,XWTPH_Quality,XWTPH_XJetEt,XWTPH_XMIPEt,XWTPH_Num REAL XWTPH_E,XWTPH_PH,XWTPH_XYZin,XWTPH_XYZout COMMON/XWTPH/XWTPH,XWTPH_ID,XWTPH_Num,XWTPH_E,XWTPH_PH(2), + XWTPH_Quality(2),XWTPH_XYZin(3),XWTPH_XYZout(3),XWTPH_XJetEt, + XWTPH_XMIPEt,XWTPH_9999 INTEGER FMCKin,FMCKin_9999 INTEGER FMCKin_ID,FMCKin_ISTHEP,FMCKin_DaughterOf,FMCKin_FMCPrt, + FMCKin_PRoducedAt REAL FMCKin_P LOGICAL FMCKin_Decay COMMON/FMCKin/FMCKin,FMCKin_ID,FMCKin_P(5),FMCKin_Decay, + FMCKin_ISTHEP,FMCKin_DaughterOf,FMCKin_FMCPrt, + FMCKin_PRoducedAt,FMCKin_9999 REAL FMCKin_PX EQUIVALENCE (FMCKin_PX, + FMCKin_P(1)) REAL FMCKin_PY EQUIVALENCE (FMCKin_PY, + FMCKin_P(2)) REAL FMCKin_PZ EQUIVALENCE (FMCKin_PZ, + FMCKin_P(3)) REAL FMCKin_Energy EQUIVALENCE (FMCKin_Energy, + FMCKin_P(4)) REAL FMCKin_Mass EQUIVALENCE (FMCKin_Mass, + FMCKin_P(5)) INTEGER FMCPrt,FMCPrt_9999 INTEGER FMCPrt_ID CHARACTER*16 FMCPrt_Name REAL FMCPrt_Mass,FMCPrt_Charge,FMCPrt_LifeTime COMMON/FMCPrt/FMCPrt,FMCPrt_ID,FMCPrt_Name,FMCPrt_Mass, + FMCPrt_Charge,FMCPrt_LifeTime,FMCPrt_9999 INTEGER FMCEvt,FMCEvt_9999 INTEGER FMCEvt_ID,FMCEvt_EvtNum,FMCEvt_MozRNDM,FMCEvt_Generator_ CHARACTER*16 FMCEvt_Generator REAL FMCEvt_Weight COMMON/FMCEvt/FMCEvt,FMCEvt_ID,FMCEvt_EvtNum,FMCEvt_MozRNDM(2), + FMCEvt_Weight,FMCEvt_Generator,FMCEvt_Generator_,FMCEvt_9999 INTEGER FMCRun,FMCRun_9999 INTEGER FMCRun_ID,FMCRun_Date,FMCRun_Generator_ CHARACTER*16 FMCRun_GenerName,FMCRun_Institute,FMCRun_Generator COMMON/FMCRun/FMCRun,FMCRun_ID,FMCRun_GenerName,FMCRun_Institute, + FMCRun_Date(2),FMCRun_Generator,FMCRun_Generator_,FMCRun_9999 INTEGER LPTRun,LPTRun_9999 INTEGER LPTRun_ID,LPTRun_LST,LPTRun_MST CHARACTER*16 LPTRun_Comment REAL LPTRun_PARL,LPTRun_CUT,LPTRun_PAR COMMON/LPTRun/LPTRun,LPTRun_ID,LPTRun_Comment(5),LPTRun_LST(20), + LPTRun_PARL(20),LPTRun_CUT(14),LPTRun_MST(40),LPTRun_PAR(80), + LPTRun_9999 INTEGER LPTEvt,LPTEvt_9999 INTEGER LPTEvt_ID,LPTEvt_NTracks,LPTEvt_QCDFlag,LPTEvt_SF, + LPTEvt_Target,LPTEvt_Current,LPTEvt_SubProc,LPTEvt_FlavStr, + LPTEvt_HadExtra,LPTEvt_HelLep REAL LPTEvt_x,LPTEvt_y,LPTEvt_W2,LPTEvt_Q2,LPTEvt_nu,LPTEvt_s, + LPTEvt_CrosSect,LPTEvt_Alphas,LPTEvt_Lambda COMMON/LPTEvt/LPTEvt,LPTEvt_ID,LPTEvt_NTracks,LPTEvt_x,LPTEvt_y, + LPTEvt_W2,LPTEvt_Q2,LPTEvt_nu,LPTEvt_s,LPTEvt_QCDFlag, + LPTEvt_SF,LPTEvt_Target,LPTEvt_Current,LPTEvt_SubProc, + LPTEvt_FlavStr,LPTEvt_HadExtra,LPTEvt_HelLep,LPTEvt_CrosSect, + LPTEvt_Alphas,LPTEvt_Lambda,LPTEvt_9999 PARAMETER (PI =3.141592653589793238) DIMENSION PQUARK(4,NQ),PIDEAL(4,NP),PGENBP(4,NP) DIMENSION PELGEN(4) LOGICAL*1 efirst LOGICAL*1 gluon INTEGER*4 NGEVNT /0/ efirst = .TRUE. gluon = .false. DO K=1, 4 DO I=1, NQ PQUARK(K,I) = 0. ENDDO DO I=1, NP PIDEAL(K,I) = 0. PGENBP(K,I) = 0. ENDDO PELGEN(K) = 0. c PQTOT(K) = 0. c PITOT(K) = 0. c PGTOT(K) = 0. ENDDO NOELEC = 0 NQUARK = 0 NIDEAL = 0 NGENBP = 0 NGEVNT = NGEVNT + 1 LDMP = ICNTL/100 NDBG = ( ICNTL - LDMP*100 ) / 10 NOUT = ICNTL - LDMP*100 - NDBG*10 C.. FMCRUN CALL fettab(FMCRun,id,1) IF(NGEVNT .LE. NDBG) WRITE(LDMP,*) 1 'FMCRun',FMCRun_genername,FMCRun_institute,FMCRun_date IF(NGEVNT .LE. NDBG) 1 WRITE(LDMP,*) 'Accepted Event # =',NGEVNT,' ************' C.. GET X,Y FROM GENERATOR IROW = COUTAB(LPTEVT) IF(IROW.NE.0) THEN CALL FETTAB(LPTEVT,ID,1) IF(NGEVNT .LE. NDBG) THEN WRITE(LDMP,*) 'LPTEVT Ntracks x y W2 Q2 ' WRITE(LDMP,*) LPTEVT_Ntracks,LPTEVT_x,LPTEVT_y,LPTEVT_W2,LPTEVT_Q2 WRITE(LDMP,*) 'LPTEVT nu s ' WRITE(LDMP,*) LPTEVT_nu,LPTEVT_s WRITE(LDMP,*) 'LPTEVT QCDFlag SF Current SubProc', & ' FlavStr Alphas Lambda' WRITE(LDMP,*) LPTEVT_QCDFlag,LPTEVT_SF,LPTEVT_Current, & LPTEVT_SubProc,LPTEVT_FlavStr,LPTEVT_Alphas,LPTEVT_Lambda ENDIF IF(LPTEVT_s .le. 1.0) THEN LPTEVT_s = LPTEVT_Q2 / LPTEVT_x / LPTEVT_y WRITE(LDMP,*) 'LPTEVT_s here : ',LPTEVT_s ENDIF IQCD = LPTEVT_QCDFLAG ELSE IQCD = -1 ENDIF C.. FMCKIN IROW = COUTAB(FMCKin) 1241 format(2x,2i4,5f9.4,2x,L2,2i11,i5,a10,i5,2xa16) DO I=1, IROW CALL FETTAB(FMCKin,ID,I) CALL FETTAB(FMCPrt,ID,FMCKin_FMCPrt) IF(NGEVNT .LE. NDBG) WRITE(LDMP,1241) i,FMCKin_id,FMCKin_p, 1 FMCKin_decay,FMCKin_daughterof,FMCKin_isthep, 2 FMCKin_FMCPrt,FMCPrt_Name,FMCKin_producedat C.. Quark level IF( NOUT - NOUT/2*2 .EQ. 1 ) THEN IF(LPTEVT_QCDFlag .LT. 1) THEN !ME IF(FMCKIN_daughterof .lt. 0) THEN NQUARK = NQUARK + 1 DO J = 1, 4 PQUARK(J,NQUARK) = FMCKin_p(J) c PQTOT(J) = PQTOT(J) + FMCKin_p(J) ENDDO ENDIF ELSE IF(FMCKIN_daughterof .lt. 0) THEN NQUARK = NQUARK + 1 DO J = 1, 4 PQUARK(J,NQUARK) = FMCKin_p(J) c PQTOT(J) = PQTOT(J) + FMCKin_p(J) ENDDO c gluon = .true. ENDIF ENDIF ENDIF IF(FMCKIN_DECAY) GOTO 130 IF(FMCKIN_daughterof.GT. 100000 ) GOTO 130 C.. See if we have a electron or not, if not, just throw away this event. IF(FMCKin_FMCPrt.eq.23 .AND. efirst) THEN DO J = 1, 4 PELGEN(J) = FMCKin_p(J) ENDDO THEEGEN = ATAN2(SQRT(FMCKin_p(2)**2+FMCKin_p(1)**2),FMCKin_p(3)) IF(ABS(THEEGEN).LT.(2.3/180.*PI).OR. 1 ABS(THEEGEN).GT.(176.5/180.*PI)) THEN NOELEC = NOELEC + 1 C RETURN ENDIF IF(NGEVNT.LE.NDBG)WRITE(LDMP,*)'ELECTRON --->',I,PELGEN(4),THEEGEN efirst = .false. GOTO 130 ENDIF C C.. Generator level with ideal detector C XT = ATAN2(SQRT(FMCKin_p(2)**2+FMCKin_p(1)**2),FMCKin_p(3)) NIDEAL = NIDEAL + 1 DO J = 1, 4 PIDEAL(J,NIDEAL) = FMCKin_p(J) c PITOT(J) = PITOT(J) + FMCKin_p(J) ENDDO C.. Generator level with beam pipe cut IF( NOUT/4 .EQ. 1 ) THEN D XT = ATAN2(SQRT(FMCKin_p(2)**2+FMCKin_p(1)**2),FMCKin_p(3)) IF(ABS(XT).LT.(2.3/180.*PI).OR.ABS(XT).GT.(176.5/180.*PI)) GOTO 130 NGENBP = NGENBP + 1 DO J = 1, 4 PGENBP(J,NGEN) = FMCKin_p(J) c PGTOT(J) = PGTOT(J) + FMCKin_p(J) ENDDO IF(NGEVNT .LE. NDBG) WRITE(LDMP,*) '^^^',NGENBP, & i,(PGENBP(J,NGENBP),J=1,4) ENDIF 130 ENDDO RETURN END CDECK ID>, GETZEP. Subroutine GETZEP(selcal,ibox,ND,NC,PC,PE,ejet,etot,vx, & expos,efcal,xda,q2da,q2jb,yjb,yelec,aempz, & ele_ene,ele_phi,ele_theta,firstefinder) IMPLICIT NONE C C system-defined parameters for the Table Package Programmer C INTEGER MINC,MAXC,NEXT,INULL,IANY,INS,REP,ORD,UNO,AND,OR,DIF,HOR, + VER,ALL,ID,ALLCOL, + COUTAB,COUSEL,GETIND,GETSEL,GETPRO,GETDFL,GETTDF,SPATAB, + CHKTAP,MAKTAB REAL RNULL,RANY CHARACTER*4 CNULL,CANY LOGICAL BELSEL,BELTAB,CHKREL,CHKTAB,CHKWIN C C MINC and MAXC for cursors operation C PARAMETER (MINC=1, MAXC=2147483647) C C null values C PARAMETER (INULL=2147483647, RNULL= 699050*16.0**26, CNULL='====') C C ANY values C PARAMETER (IANY=-INULL, RANY=-RNULL, CANY='!@)(') C C NEXT for insertion C PARAMETER (NEXT=INULL) C C Modes C PARAMETER (INS = 1, REP = 2, + ORD = 1, UNO = 2, + AND = 1, OR = 2, DIF=3, + HOR = 1, VER = 2) C C Indices C PARAMETER (ALL = 1-INULL , ID = INULL-1, ALLCOL = 1-INULL) INTEGER CcGHit,CcGHit_9999 INTEGER CcGHit_ID,CcGHit_Component_,CcGHit_FMCKin,CcGHit_CPMnr CHARACTER*16 CcGHit_Component REAL CcGHit_EScinDep,CcGHit_EWlsDep,CcGHit_TimeDep COMMON/CcGHit/CcGHit,CcGHit_ID,CcGHit_CPMnr,CcGHit_EScinDep, + CcGHit_EWlsDep,CcGHit_TimeDep,CcGHit_Component, + CcGHit_Component_,CcGHit_FMCKin,CcGHit_9999 INTEGER CConSa,CConSa_9999 INTEGER CConSa_ID,CConSa_NcEmc,CConSa_NcHac1,CConSa_NcHac2, + CConSa_Cidclu CHARACTER*8 CConSa_class REAL CConSa_x,CConSa_y,CConSa_z,CConSa_E,CConSa_radius,CConSa_cx, + CConSa_cy,CConSa_cz,CConSa_Eemc,CConSa_Cemc,CConSa_Ehac1, + CConSa_Chac1,CConSa_Ehac2,CConSa_Chac2 COMMON/CConSa/CConSa,CConSa_ID,CConSa_class,CConSa_x,CConSa_y, + CConSa_z,CConSa_E,CConSa_radius,CConSa_cx,CConSa_cy,CConSa_cz, + CConSa_Eemc,CConSa_Cemc(3),CConSa_Ehac1,CConSa_Chac1(3), + CConSa_Ehac2,CConSa_Chac2(3),CConSa_NcEmc,CConSa_NcHac1, + CConSa_NcHac2,CConSa_Cidclu,CConSa_9999 INTEGER Cidclu,Cidclu_9999 INTEGER Cidclu_ID,Cidclu_CR1obj CHARACTER*8 Cidclu_class REAL Cidclu_x,Cidclu_y,Cidclu_z,Cidclu_E,Cidclu_radius,Cidclu_cx, + Cidclu_cy,Cidclu_cz,Cidclu_Eemc,Cidclu_Cemc,Cidclu_Ehac1, + Cidclu_Chac1,Cidclu_Ehac2,Cidclu_Chac2 COMMON/Cidclu/Cidclu,Cidclu_ID,Cidclu_class,Cidclu_x,Cidclu_y, + Cidclu_z,Cidclu_E,Cidclu_radius,Cidclu_cx,Cidclu_cy,Cidclu_cz, + Cidclu_Eemc,Cidclu_Cemc(3),Cidclu_Ehac1,Cidclu_Chac1(3), + Cidclu_Ehac2,Cidclu_Chac2(3),Cidclu_CR1obj,Cidclu_9999 INTEGER Caltru,Caltru_9999 INTEGER Caltru_ID,Caltru_CConSa,Caltru_CuPaOb,Caltru_Cellnr REAL Caltru_E,Caltru_imbal,Caltru_t COMMON/Caltru/Caltru,Caltru_ID,Caltru_Cellnr,Caltru_E, + Caltru_imbal,Caltru_t(2),Caltru_CConSa,Caltru_CuPaOb, + Caltru_9999 INTEGER XJetEt,XJetEt_9999 INTEGER XJetEt_ID,XJetEt_NHitXY,XJetEt_XEntit,XJetEt_XMCSEt, + XJetEt_XMatEt REAL XJetEt_XYZCOG,XJetEt_XYZCov,XJetEt_JAxCos,XJetEt_YZCov, + XJetEt_XEnDep,XJetEt_DEnDep COMMON/XJetEt/XJetEt,XJetEt_ID,XJetEt_XYZCOG(3), + XJetEt_XYZCov(3,3),XJetEt_JAxCos(3),XJetEt_YZCov(2,2), + XJetEt_XEnDep,XJetEt_DEnDep,XJetEt_NHitXY,XJetEt_XEntit, + XJetEt_XMCSEt,XJetEt_XMatEt,XJetEt_9999 *--------------------------------------------------------------- * The information on the cells above the energy threshold cut *--------------------------------------------------------------- integer n_cell(4),cell_p(2000,4) real cell_e(2000,4),cell_i(2000,4),e_tot real cell_t(2000,4),cell_a(2000,4),cell_time(2000,4) real cell_x(2000,4),cell_y(2000,4),cell_z(2000,4) common/eecell/n_cell,cell_p,cell_e,cell_i,cell_t,cell_a, > cell_x,cell_y,cell_z,cell_time,e_tot *--------------------------------------------------------------- * The information on the candidate characteristics *--------------------------------------------------------------- integer n_cand integer pmt_max(20),fir_max(20),elec_pmt(10,100) real e_max(20),imb_max(20),the_max(20),phi_max(20),pmax(10) real pro_e(20),radius(20),e_ring(20),e_out(20),e_hac(20,4), > x_ring(20),y_ring(20),z_ring(20),phi_ring(20),the_ring(20), > x_max(20),y_max(20),z_max(20),time_ring(20) * common/eeelec/radius,e_ring,e_out,e_hac, > x_ring,y_ring,z_ring,phi_ring,the_ring, > x_max,y_max,z_max,time_ring,pro_e,n_cand, > elec_pmt common/eeneigh/e_max,pmt_max,imb_max,the_max,phi_max,fir_max *---------------------------------------------------------------------- * local variables *---------------------------------------------------------------------- integer iend,ierr integer i1,i2,i3,i4,i5,i6,i7,i8,i9,i10 integer i_pmt,i_cal,i_mod,i_tow,i_cel,i_sec,i_sid integer i_pos,i_chimney,vector(5) integer i_remove(20) integer i_cal_c,i_mod_c,i_tow_c,i_cel_c,i_sec_c integer d_mod,d_cel,d_tow real r1,r2,r3,r4,r5,r6,r7,r8,r9 real energy,dist,imb,pro_max(20,4) real e_lef,e_rig,t_lef,t_rig,tim_nom(3) C&&& made compatible with PHANTOM routines 28.4.93 NPA C&& + ,zcor,phicor real x_cand(10),y_cand(10),z_cand(10),ene_cand(10), > the_cand(10),phi_cand(10),p_cand(3,10),time_cand(10), > pro_cand(10) integer nfound,i_cand(10) common/eepass/x_cand,y_cand,z_cand,ene_cand,the_cand,phi_cand, > p_cand,time_cand,pro_cand,i_cand,nfound real vtx_in(3) logical eedebug *---------------------------------------------------------------------- * Cuts to guide program *---------------------------------------------------------------------- integer n_max data n_max/10/ real e_cut(5),dist_cut(0:5),pro_adj(3),pro_cut * * e_cut: 1 : min E required in both L & R for a cell * 2 : min E of L+R to be considered a candidate * 3 : min total E to be considered a candidate * 4 : removed * 5 : for timing calculations data e_cut/0.04,1.,2.,10.,0.2/ * dist_cut 0 : cone in which lower E neighbors are rejected * 1 : cone to get e_ring,radius * 2 : cone to get e_out * 3 : cone to get e_hac(i1,1) and e_hac(i1,2) * 4 : cone around fcal beampipe : not used for * e_out,e_hac, special pt (vector and sum) * 5 : cone to get e_hac(i1,3),e_hac(i1,4) * * data dist_cut/.209,0.25,0.4,0.3,.175,.5/ * Note: dist_cut(0) must be at least as large as largest cone for * summing energy or it will be double counted (necessary but * not sufficient condition. Also check for double counting later). * AC 11/11/92 (thanks to M.Brikc) * data dist_cut/.4,0.25,0.4,0.3,.175,.5/ * * * pro_adj 1 : probability adjustment for FCAL * 2 : BCAL * 3 : RCAL data pro_adj/0.01,0.01,1./ * * pro_cut Minimum probability for candidate * data pro_cut/1.e-8/ * ========================================================== INTEGER ZDSKEY,ZDSKEY_9999 INTEGER ZDSKEY_ID,ZDSKEY_Nr1,ZDSKEY_Nr2,ZDSKEY_TStam11, + ZDSKEY_TStam12,ZDSKEY_TStam21,ZDSKEY_TStam22 CHARACTER*4 ZDSKEY_GAFTyp CHARACTER*32 ZDSKEY_DflNAM COMMON/ZDSKEY/ZDSKEY,ZDSKEY_ID,ZDSKEY_GAFTyp,ZDSKEY_Nr1, + ZDSKEY_Nr2,ZDSKEY_TStam11,ZDSKEY_TStam12,ZDSKEY_TStam21, + ZDSKEY_TStam22,ZDSKEY_DflNAM,ZDSKEY_9999 real sreco , qreco , yreco , xreco , + Jet_theta , Jet_energy , El_init common / styx / sreco , qreco , yreco , xreco , + Jet_theta , Jet_energy , El_init integer jre common/select/jre INTEGER Nwds_HBOOK PARAMETER (Nwds_HBOOK=5000000) REAL HMEM COMMON/PAWC/ HMEM(Nwds_HBOOK) COMMON / SIDAT / Ncand, EmPz, EtotEvn, CANDAT, POSDAT, & doHESCLU, doCLUMAT INTEGER Ncand, POSDAT(53,100) REAL EmPz, EtotEvn, CANDAT(20,100) LOGICAL doHESCLU, doCLUMAT c ------------------------------------------------------------- INTEGER ND,NC REAL PC(4,nd),PE(4) INTEGER I,IL1,LENDAT,iel,ntrku,NrCond,ndf REAL VX(3),PB(3),the,phi,r,chi2 integer firstefinder,elect5save,localsave CHARACTER*4 GENKEY real xt(28),ele_ene,ele_theta,ele_phi Real eemax,exyz(3),dexyz(3),rad,theta Real efcal,ebcal,ercal,aempz,epz,px,py,pt2 Real xpos,ypos,zpos,x,y,z,ex,ey,ez,q2da,yda Real xq,jeten,jetth,xe,eenda,ethda,yelec,yjb,q2jb,xda Integer ican,nrcells,celllist(100),ierror,Cellnr * Real Cellclr1(45000),Cellclr2(45000) common/cellclr/cellclr1(45000),cellclr2(45000) Logical Lerr real EnergyCuts(10),ejet(4),etot(4),expos(3),xreco1,qreco1 real vxx(3) C+ integer iout,icut,imc,iver,idis,idiscut ! Discut integer NKIN ! Ntuple for Kinematic Variables from hades parameter(NKIN=12) real AKIN(NKIN) REAL XKIN(4),Q2KIN(4),YKIN(4) ! For hades Routine logical lfirst,lsecond,mfirst INTEGER IELEFIND,ibox,selcal REAL ECUT(2),SUMENERGY,MOMENTUM(3) ! FOR NOISESUP INTEGER NCELLS LOGICAL ISLFL,DELFL nc=0 call vzero(ejet,4) call vzero(etot,4) call vzero(pe,4) call vzero(vx,3) if(selcal.eq.1.and.ibox.eq.1) then ! condensate & jet box cut lfirst = .true. lsecond = .false. ! e-cell removed in mypccn mfirst = .true. elseif(selcal.eq.1.and.ibox.eq.0) then ! condensate & no jet box cut lfirst = .true. lsecond = .false. mfirst = .false. elseif(selcal.eq.2.and.ibox.eq.1) then !cell & box cut:flag as -energy lfirst = .true. C++ lsecond = .false. lsecond = .true. ! remove e-cell by using deltab mfirst = .false. ! - energy flagging in box region elseif(selcal.eq.2.and.ibox.eq.0) then ! cell & no box cut lfirst = .true. lsecond = .false. else write(6,*) 'SELCAL error occured::Try 1 or 2',selcal endif C V E R T E X R Q U I R E M E N T call vtxfind(2,vx,chi2,ntrku,ndf) ! vc vertex if(ntrku.le.0.or.chi2.lt.-0.001) then ! no vertex case call vtxfind(1,vx,chi2,ntrku,ndf) ! Global vertex else goto 123 endif if(ntrku.le.0.or.chi2.lt.-0.001) then print *,'No vertex found by vtxfind-->reject' return endif 123 continue do i=1,3 vxx(i) = vx(i) enddo C E L E C T R O N F I N D E R S call elect5finder(vxx,elect5save) call localfinder(vxx,localsave) If(elect5save.eq.1.or.localsave.eq.1) then firstefinder = 1 else firstefinder = 0 endif C+ D I S -- C U T C O N D I T I O N C+ IF(GENKEY.EQ.'DATA') THEN C+ imc = 0 C+ ELSE C+ imc = 1 C+ ENDIF C+ C+ iver = 3 C+ call discut(iout,icut,vxx,iver,imc,ierr) C+ if(ierr.gt.0) then C+ write(6,*) 'Error in DISCUT -- reject',ierr C+ return C+ endif C+ if(iout.eq.0) then C+ write(6,*) 'Reject By DISCUT',iout,icut C+ return C+ endif C F I N A L E L E C T R O N F I N D E R S C exotic e-finder IELEFIND=1 for 1993 data C sinistra e-finder IELEFIND=2 for 1994 data C ++++++++++++++++++++++++++ IELEFIND = 2 C ++++++++++++++++++++++++++ IF(IELEFIND.EQ.1) THEN call EEXOTIC(Vxx,.false.) if(nfound.le.0) then return endif ican=0 eemax=0. do i=1,nfound if (ene_cand(i_cand(i)).gt.eemax) then !pick candidate w max energy eemax=ene_cand(i_cand(i)) ican=i_cand(i) endif end do if (nfound.gt.0) then call vzero(celllist,100) ! the new position finder nrcells=fir_max(ican) do i=1,nrcells celllist(i)=elec_pmt(ican,i) end do call elecpo(vx,-1*nrcells,celllist,exyz,dexyz,ierror) if (ierror.lt.0) then call vfill(exyz,3,-999.) else call CccApo(exyz(1),exyz(2),(exyz(3)-vx(3)),rad,theta,phi) endif endif pe(1) = ene_cand(ican) * SIN(Theta)*COS(Phi) pe(2) = ene_cand(ican) * SIN(Theta)*SIN(Phi) pe(3) = ene_cand(ican) * COS(Theta) pe(4) = ene_cand(ican) ele_ene = ene_cand(ican) ele_theta= theta ele_phi = phi C E L E C T R O N C E L L F L A G G I N G A S -1. Call Vzero(CellClr1,45000) Do 100 I = 1, fir_max(ican) CellNr = elec_pmt(ican,i)-mod(elec_pmt(ican,i),2) CellClr1(CellNr) = -1. 100 Continue ENDIF IF(IELEFIND.EQ.2) THEN ! sinistra electron finder call vzero(celllist,100) CALL SIRA(VXX,-0.4,IERR) IF(IERR.NE.0) THEN PRINT *,'ERROR from Sinistra -- reject',IERR RETURN ENDIF IF(NCAND.LE.0) THEN PRINT *, 'Electron not found by sinistra -- reject' RETURN ELSEIF(NCAND.GT.0) THEN ican = 0 eemax = 0. do i = 1, ncand ! GET CANDIDATE WITH MAXIMUM ENERGY if(candat(2,i) .gt. eemax) then eemax = candat(2,i) ican = i endif enddo ENDIF nrcells = posdat(3,ican) DO I = 1, nrcells cellList(i) = posdat(3+i,ican) ENDDO call elecpo(vx,-1*nrcells,celllist,exyz,dexyz,ierror) if (ierror.lt.0) then call vfill(exyz,3,-999.) else call CccApo(exyz(1),exyz(2),(exyz(3)-vx(3)),rad,theta,phi) endif pe(1) = candat(2,ican) * SIN(Theta)*COS(Phi) pe(2) = candat(2,ican) * SIN(Theta)*SIN(Phi) pe(3) = candat(2,ican) * COS(Theta) pe(4) = candat(2,ican) ele_ene = candat(2,ican) ele_theta = theta ele_phi = phi C E L E C T R O N C E L L F L A G G I N G A S -1. CALL VZERO(CELLCLR1,45000) DO I = 1, NRCELLS CELLNR = CELLLIST(I) - MOD(CELLLIST(I),2) CELLCLR1(CELLNR) = -1. ENDDO ENDIF C C E L L F L A G G I N G INSIDE B O X- C U T R E G I O N Call vzero(CellClr2, 45000) Do 221 I=1,coutab(Caltru) call fettab(caltru,id,i) icut = 0 CellNr = Caltru_CellNr call boxbox(CellNr, icut) if(icut.eq.1) then Cellclr2(CellNr)=-1. endif 221 continue if(lfirst)then ! create selector call cresel(caltru,jre,'SelEl') lfirst=.false. endif call clesel(caltru,jre) Do i = 1, coutab(Caltru) call fettab(caltru,id,i) call cccxyz(caltru_cellnr,x,y,z,ierror) if(cellclr1(caltru_cellnr).lt.0.)then call inssel(caltru,jre) endif enddo C Calculate Kinematic variables for calling hades routine lendat=coutab(Caltru) efcal = 0. ebcal = 0. ercal = 0. aempz = 0. epz = 0. px = 0. py =0. pt2=0. Do 125 i = 1, lendat Call Fettab(caltru,id,i) If(caltru_cellnr.ge.106.and.caltru_cellnr.le.11535) then efcal = efcal + caltru_E End If If(caltru_cellnr.ge.16388.and.caltru_cellnr.le.32479) then ebcal = ebcal + caltru_E End If If(caltru_cellnr.ge.32874.and.caltru_cellnr.le.44301) then ercal = ercal + caltru_E End If call cccxyz(caltru_cellnr,x,y,z,Lerr) If(Lerr) goto 125 xpos = x - vx(1) ypos = y - vx(2) zpos = z - vx(3) call cccapo(xpos,ypos,zpos,rad,theta,phi) ez = caltru_e*cos(theta) ey = caltru_e*sin(theta)*cos(phi) ex = caltru_e*sin(theta)*sin(phi) etot(1) = etot(1) + caltru_e etot(2) = etot(2) + ex etot(3) = etot(3) + ey etot(4) = etot(4) + ez aempz = aempz + caltru_e - ez ! e-pz of all particles If(CellClr1(Caltru_cellnr).lt.0.0) Then ! e-cell skip goto 125 Endif ejet(1) = ejet(1) + caltru_e ejet(2) = ejet(2) + ex ejet(3) = ejet(3) + ey ejet(4) = ejet(4) + ez epz = epz +caltru_e - ez ! e-pz of hadrons px = px + ex py = py + ey 125 Continue pt2 = px**2 + py**2 DO I = 1,4 CALL hades(26.6,ele_ene,ele_theta,epz,pt2,I,IERR) ! hades IF(IERR.EQ.0) THEN XKIN(I) = xreco YKIN(I) = yreco Q2KIN(I)= qreco ENDIF ENDDO yelec = YKIN(1) yjb = YKIN(2) q2jb = Q2KIN(2) xda = XKIN(3) yda = YKIN(3) q2da = Q2KIN(3) AKIN(1) = XKIN(1) AKIN(2) = YKIN(1) AKIN(3) = Q2KIN(1) AKIN(4) = XKIN(2) AKIN(5) = YKIN(2) AKIN(6) = Q2KIN(2) AKIN(7) = XKIN(3) AKIN(8) = YKIN(3) AKIN(9) = Q2KIN(3) AKIN(10) = XKIN(4) AKIN(11) = YKIN(4) AKIN(12) = Q2KIN(4) CALL HFN(200,AKIN) do i=coutab(caltru),1,-1 ! Remove electron cells call fettab(caltru,id,i) if(lsecond) then if(cellclr1(caltru_cellnr).lt.0.0) then call deltab(caltru) endif endif if(mfirst) then ! Remove cells inside box-cut regions icut=0 Cellnr = Caltru_Cellnr call boxbox(Cellnr,icut) if(icut.eq.1) then call deltab(caltru) endif endif enddo IF(selcal.eq.1) THEN ! Rebuild condensate table in condensate level ierr=0 call vfill(EnergyCuts,10,-1.) call mypccn (EnergyCuts,Nrcond,Ierr) nc = 0 LENDAT=COUTAB(CCONsa) DO 108 IL1=1,LENDAT nc = nc + 1 if(nc.gt.nd) then write(6,*)'ZPAR:# of par >mx dim',nc,nd return endif C CALL FETTAB(CCONsa,ID,IL1) pb(1) = CCONsa_x pb(2) = CCONsa_y pb(3) = CCONsa_z r = sqrt((pb(1)-vx(1))**2+(pb(2)-vx(2))**2+ & (pb(3)-vx(3))**2) pc(1,nc) = cconsa_E*(pb(1)-vx(1))/r pc(2,nc) = cconsa_E*(pb(2)-vx(2))/r pc(3,nc) = cconsa_E*(pb(3)-vx(3))/r pc(4,nc) = cconsa_E call cccapo((pb(1)-vx(1)),(pb(2)-vx(2)),(pb(3)-vx(3)), & rad,theta,phi) 108 continue ELSEIF(selcal.eq.2) THEN C NOISE SUPPRESSION:REMOVE ISOLATED CELLS BELOW A GIVEN ENERGY CUT ECUT(1) = 0.1 !EMC ENERGY THRESHOLD=100 MeV ECUT(2) = 0.2 !HAC ENERGY THRESHOLD=200 MeV ISLFL = .FALSE. !CONDENSATE ALGORITHM .FALSE.,ISLANDS .TRUE. DELFL = .TRUE. !REMOVE NOISE CELLS FROM CALTRUE .TRUE. DO I = 1, 3 VXX(I) = VX(I) ENDDO CALL NOISESUP2(ECUT,VXX,ISLFL,DELFL,NCELLS 1 ,SUMENERGY,MOMENTUM,IERR) IF(IERR.NE.0.AND.IERR.EQ.-1) THEN WRITE(6,*)'NOISEUP2 ERROR',IERR ELSEIF(IERR.NE.0.AND.IERR.EQ.1) THEN WRITE(6,*)'NOISEUP ERROR:CALTRU TABLE EMPTY',IERR ENDIF do 127 il1 = 1,coutab(Caltru) CALL FETTAB(Caltru,ID,IL1) call cccxyz(caltru_cellnr,x,y,z,Lerr) If(Lerr) goto 127 if(Cellclr1(caltru_cellnr).lt.0.0) then goto 127 endif nc = nc + 1 call cccxyz(caltru_cellnr,x,y,z,Lerr) xpos = x - vx(1) ypos = y - vx(2) zpos = z - vx(3) r =sqrt(xpos**2 + ypos**2 + zpos**2) call cccapo(xpos,ypos,zpos,rad,theta,phi) if(Cellclr2(caltru_cellnr).lt.0.0) then pc(1,nc) = caltru_e*sin(theta)*cos(phi) pc(2,nc) = caltru_e*sin(theta)*sin(phi) pc(3,nc) = caltru_e*cos(theta) pc(4,nc) = -caltru_e else pc(1,nc) = caltru_e*sin(theta)*cos(phi) pc(2,nc) = caltru_e*sin(theta)*sin(phi) pc(3,nc) = caltru_e*cos(theta) pc(4,nc) = caltru_e endif 127 continue ELSE print *,'selcal error' ENDIF C F I N A L D A T A S E L E C T I O N C O N D I T I O N C =========================================================== IF(IELEFIND.EQ.1) THEN ! exotic :: 16x16 cm box-cut expos(1) = x_cand(ican) expos(2) = y_cand(ican) expos(3) = z_cand(ican) ELSEIF(IELEFIND.EQ.2) THEN ! sinistra EXPOS(1) = candat(3,ican) EXPOS(2) = candat(4,ican) EXPOS(3) = candat(5,ican) ENDIF if(abs(expos(1)).lt.16..and.abs(expos(2)).lt.16.) then nc = 0 print*,'Rejected by 16x16cm box-cut',expos(1),expos(2) goto 99999 endif IF(IELEFIND.EQ.1) THEN ! exotic finder :: Ee If(ENE_CAND(ICAN).lt.10.0) Then nc=0 ENDIF ENDIF IF(IELEFIND.EQ.2) THEN ! sinistra finder IF(CANDAT(2,ICAN).LT.10.0) THEN NC = 0 print*,'Rejected by sinistra finder',candat(2,ican) goto 99999 ENDIF EndIf If(efcal.lt.1.0) Then ! fcal energy nc=0 print*,'Rejected by fcal energy',efcal goto 99999 End If If(aempz.lt.35.0.or.aempz.gt.60.) Then ! e-pz nc=0 print*,'Rejected by epz',aempz goto 99999 End If If(yelec.gt.0.95.or.yelec.lt.0.0) Then ! yelec nc=0 print*,'Rejected by yelec',yelec goto 99999 End If If(yjb.lt.0.1.or.yjb.gt.1.0) Then ! yjb nc=0 print*,'Rejected by yjb',yjb goto 99999 End If C If(qreco.lt.100..or.qreco.gt.1000.) Then ! q2da C nc=0 C End If If(xda.lt.0.01.or.xda.gt.1.0) Then ! xda nc=0 print*,'Rejected by xda',xda goto 99999 End If If(sqrt(vx(1)**2+vx(2)**2).gt.10.) Then ! r-vertex nc=0 print*,'Rejected by r-vertex',sqrt(vx(1)**2+vx(2)**2) goto 99999 End If print*,' This is the one of final Evts in the sample' 99999 Return End CDECK ID>, ELECT5FI. subroutine ELECT5FINDER(vtx_in,elect5save) implicit none integer i_run,i_evt integer n_found,i_cand,n_cand,i_calor(10) integer pmt_max(20),fir_max(20) integer n_cell(4),cell_p(2000,4),elec_pmt(10,100) integer pmt_spark integer e_i_cal real e_max(20),imb_max(20),the_max(20),phi_max(20) real ene_cand(2,10),the_cand(2,10),phi_cand(2,10), > p_cand(2,3,10),e_prob(10),x_max(20),y_max(20),z_max(20) C& 27.4.93 real pro_max(20,4) real pro_e(20),radius(20),e_ring(20),e_out(20),e_hac(20,4) real e_tot,e_con,p_tot(5),p_con(5),n_tot(2), > circ,circ_2,circ_3 real p_cen(5),p_fix(5) real vtx_in(3) real cell_e(2000,4),cell_i(2000,4) real cell_t(2000,4),cell_a(2000,4),cell_u(2000,4) real cell_x(2000,4),cell_y(2000,4),cell_z(2000,4) real cal_sum(3,4),cal_tim(3),rcal_pl real x_cand(10),y_cand(10),z_cand(10),u_cand(10) real e_spark,i_spark,t_spark real e_e_scat,e_theta_scat,e_phi_scat,e_x_scat, > e_y_scat,e_z_scat C& new 27.4.93 real disol(20,3) real p_t_had(20,2),e_t_had(20,2) common/cal_sum/cal_sum,cal_tim,rcal_pl common/cell/n_cell,cell_p,cell_e,cell_i,cell_t,cell_a, > cell_x,cell_y,cell_z,cell_u common/elec_par/pro_e,radius,e_ring,e_out,e_hac common/elec_pmt/elec_pmt common/elec_inf/n_found,i_cand,ene_cand,phi_cand, > the_cand,p_cand,u_cand,e_prob common/deben/e_e_scat,e_theta_scat,e_phi_scat,e_x_scat, > e_y_scat,e_z_scat,e_i_cal common/impact/x_cand,y_cand,z_cand,i_calor common/neigh/n_cand,e_max,pmt_max,imb_max,the_max,phi_max, > fir_max,x_max,y_max,z_max common/run_par/i_run,i_evt common/shape/e_tot,e_con,p_tot,p_con,n_tot, > circ,circ_2,circ_3 common/shape1/p_cen,p_fix common/spark/e_spark,i_spark,t_spark,pmt_spark C& new 27.4.93 common/probS/pro_max common/isol/disol common/trigs/p_t_had,e_t_had *-------------------------------------------------------------------- C The parameters to guide the program Integer Ncand_max,Nclu_max,Ncell_max Parameter (Ncand_max=50,Nclu_max=100,Ncell_max=50) C The parameters of the clusters Integer C_found,C_index(Ncand_max),C_Ncells(Ncand_max), & C_cells(NCell_Max,Ncand_max),C_calor(Ncand_max) Real C_energy(4,Ncand_max),C_Etot(Ncand_max), & C_coord(3,Ncand_max),C_angle(2,Ncand_max), & C_time(2,Ncand_max),C_prob(Ncand_max) Common/Clocal/ C_found,C_index,C_Ncells,C_cells,C_calor, & C_energy,C_Etot,C_coord,C_angle,C_time,C_prob C C The cuts (note that the maximum number of cells in a cluster is defined C above as Ncell_max C * %%% NPA 8.7.93 ( make cuts available to user !) Integer Ncell_min Real Eclu_min,Prob_cut common /CLOCUT/ Eclu_min, Prob_cut, Ncell_min C--------------------------------------------------------------------------- * ========================================================== integer ELECT5SAVE ELECT5SAVE = 0 call elect5(vtx_in,0) if(n_found.lt.1) then ! first selection criteria - electron elect5save =0 else elect5save =1 endif RETURN END CDECK ID>, LOCALFIN. subroutine localfinder(vtx_in,LOCALSAVE) IMPLICIT NONE C The parameters to guide the program Integer Ncand_max,Nclu_max,Ncell_max Parameter (Ncand_max=50,Nclu_max=100,Ncell_max=50) C The parameters of the clusters Integer C_found,C_index(Ncand_max),C_Ncells(Ncand_max), & C_cells(NCell_Max,Ncand_max),C_calor(Ncand_max) Real C_energy(4,Ncand_max),C_Etot(Ncand_max), & C_coord(3,Ncand_max),C_angle(2,Ncand_max), & C_time(2,Ncand_max),C_prob(Ncand_max) Common/Clocal/ C_found,C_index,C_Ncells,C_cells,C_calor, & C_energy,C_Etot,C_coord,C_angle,C_time,C_prob C C The cuts (note that the maximum number of cells in a cluster is defined C above as Ncell_max C * %%% NPA 8.7.93 ( make cuts available to user !) Integer Ncell_min Real Eclu_min,Prob_cut common /CLOCUT/ Eclu_min, Prob_cut, Ncell_min C--------------------------------------------------------------------------- * ========================================================== real vtx_in(3) integer ierr,LOCALSAVE LOCALSAVE = 0 call LOCAL(vtx_in,.false.,ierr) if(ierr.ne.0) then write(6,*)'Error in local finder',ierr return endif if(c_found.eq.0) then localsave =0 else localsave =1 endif return end CDECK ID>, DISCUT. Subroutine DISCUT(iout,icut,vtx,iver,imc,ierr) implicit none C C system-defined parameters for the Table Package Programmer C INTEGER MINC,MAXC,NEXT,INULL,IANY,INS,REP,ORD,UNO,AND,OR,DIF,HOR, + VER,ALL,ID,ALLCOL, + COUTAB,COUSEL,GETIND,GETSEL,GETPRO,GETDFL,GETTDF,SPATAB, + CHKTAP,MAKTAB REAL RNULL,RANY CHARACTER*4 CNULL,CANY LOGICAL BELSEL,BELTAB,CHKREL,CHKTAB,CHKWIN C C MINC and MAXC for cursors operation C PARAMETER (MINC=1, MAXC=2147483647) C C null values C PARAMETER (INULL=2147483647, RNULL= 699050*16.0**26, CNULL='====') C C ANY values C PARAMETER (IANY=-INULL, RANY=-RNULL, CANY='!@)(') C C NEXT for insertion C PARAMETER (NEXT=INULL) C C Modes C PARAMETER (INS = 1, REP = 2, + ORD = 1, UNO = 2, + AND = 1, OR = 2, DIF=3, + HOR = 1, VER = 2) C C Indices C PARAMETER (ALL = 1-INULL , ID = INULL-1, ALLCOL = 1-INULL) INTEGER ZDSKEY,ZDSKEY_9999 INTEGER ZDSKEY_ID,ZDSKEY_Nr1,ZDSKEY_Nr2,ZDSKEY_TStam11, + ZDSKEY_TStam12,ZDSKEY_TStam21,ZDSKEY_TStam22 CHARACTER*4 ZDSKEY_GAFTyp CHARACTER*32 ZDSKEY_DflNAM COMMON/ZDSKEY/ZDSKEY,ZDSKEY_ID,ZDSKEY_GAFTyp,ZDSKEY_Nr1, + ZDSKEY_Nr2,ZDSKEY_TStam11,ZDSKEY_TStam12,ZDSKEY_TStam21, + ZDSKEY_TStam22,ZDSKEY_DflNAM,ZDSKEY_9999 INTEGER RECVTX,RECVTX_9999 INTEGER RECVTX_ID,RECVTX_NDF REAL RECVTX_V,RECVTX_Cov,RECVTX_Chi2 COMMON/RECVTX/RECVTX,RECVTX_ID,RECVTX_V(3),RECVTX_Cov(6), + RECVTX_Chi2,RECVTX_NDF,RECVTX_9999 INTEGER VCTVTX,VCTVTX_9999 INTEGER VCTVTX_ID,VCTVTX_NDF REAL VCTVTX_V,VCTVTX_Cov,VCTVTX_Chi2 COMMON/VCTVTX/VCTVTX,VCTVTX_ID,VCTVTX_V(3),VCTVTX_Cov(6), + VCTVTX_Chi2,VCTVTX_NDF,VCTVTX_9999 INTEGER Caltru,Caltru_9999 INTEGER Caltru_ID,Caltru_CConSa,Caltru_CuPaOb,Caltru_Cellnr REAL Caltru_E,Caltru_imbal,Caltru_t COMMON/Caltru/Caltru,Caltru_ID,Caltru_Cellnr,Caltru_E, + Caltru_imbal,Caltru_t(2),Caltru_CConSa,Caltru_CuPaOb, + Caltru_9999 INTEGER RECPAR,RECPAR_9999 INTEGER RECPAR_ID,RECPAR_DaughterOf,RECPAR_PRoducedAt REAL RECPAR_Par,RECPAR_Cov,RECPAR_Chi2,RECPAR_D0 COMMON/RECPAR/RECPAR,RECPAR_ID,RECPAR_Par(3),RECPAR_Cov(6), + RECPAR_Chi2,RECPAR_D0,RECPAR_DaughterOf,RECPAR_PRoducedAt, + RECPAR_9999 INTEGER CTime2,CTime2_9999 INTEGER CTime2_ID CHARACTER*4 CTime2_version REAL CTime2_avtime,CTime2_ertime,CTime2_chisq,CTime2_npmt, + CTime2_prob,CTime2_Esum,CTime2_Eminpmt,CTime2_Imbalcut, + CTime2_zint,CTime2_tint COMMON/CTime2/CTime2,CTime2_ID,CTime2_avtime(5),CTime2_ertime(5), + CTime2_chisq(5),CTime2_npmt(5),CTime2_prob(5),CTime2_Esum(5), + CTime2_Eminpmt,CTime2_Imbalcut,CTime2_zint,CTime2_tint, + CTime2_version,CTime2_9999 Real Vtxz,DVtxz,Chisq,EcutVx,C5(4) Integer Icnt,Ierr,iver,imc INTEGER O1TrgTyp, O1TstTyp, O1Ambig,itrgtyp integer nvx_1, nvx_2, nvx_3,i,icut,iout,iwant real vertex(7),vtx(3),vxcut, tcut PARAMETER(VXCUT=50,TCUT=4) iout = 1 ierr = 0 Icut = 0 Do i=1,7 Vertex(i) = 0.0 EndDo Do i=1,3 Vtx(i) = 0.0 EndDo if (iver.ne.2.and.iver.ne.3) then ierr=1 goto 999 endif if (imc.ne.1.and.imc.ne.0) then ierr=2 goto 999 endif if (imc.eq.0) then ! check begin of run etc. CALL O1TTyp ( O1TrgTyp, O1TstTyp, O1Ambig) IF(O1TrgTyp.ne.0.and.o1tsttyp.ne.2) THEN icut = 1 c goto 950 ENDIF endif if (imc.eq.0) then ! check evtake Call Evtake(IWant) if (IWant.ne.1) then icut = 2 Goto 950 endif endif nvx_1 = COUTAB(VCTVTX) ! Get Vertex from VCTVTX If (nvx_1.gt.0) Then Call FETTAB(VCTVTX,ID,1) vertex(3) = VCTVTX_V(3) vertex(2) = VCTVTX_V(2) vertex(1) = VCTVTX_V(1) EndIf nvx_2 = COUTAB(RECVTX) ! Get Vertex from RECVTX If (nvx_2.gt.0.and.nvx_1.eq.0.) Then Call FETTAB(RECVTX,ID,1) vertex(6) = RECVTX_V(3) vertex(5) = RECVTX_V(2) vertex(4) = RECVTX_V(1) EndIf if (nvx_1.eq.0.and.nvx_2.eq.0.and.imc.eq.0) then ! V from CALORIMETER Call CALTVTX(Vtxz,DVtxz,Chisq,EcutVx,Icnt,C5,Ierr) If (Ierr.ne.0) Then ierr=-ierr nvx_3 = 0 Else nvx_3 = 1 EndIf vertex(7) = Vtxz endif C Final Vertex Definition If (nvx_3.gt.0) Then Vtx(3) = vertex(7) Vtx(2) = 0 Vtx(1) = 0 EndIf If (nvx_2.gt.0) Then Vtx(3) = vertex(6) Vtx(2) = vertex(5) Vtx(1) = vertex(4) EndIf If (nvx_1.gt.0) Then Vtx(3) = vertex(3) Vtx(2) = vertex(2) Vtx(1) = vertex(1) EndIf If (Vtx(3).gt.vxcut.or.Vtx(3).lt.-vxcut) Then icut = 3 GoTo 950 EndIf if (imc.eq.0) then ierr=0 call c5rep(ierr) If (Ierr.ne.0) Then ierr=-ierr endif if (iver.ge.3) then If (Ctime2_avtime(3).lt.-60) then icut = 4 goto 999 endif if (CTime2_esum(3).lt.5) then ! E RCAL < 5 GeV icut = 4 goto 999 endif endif c | TRCAL | < 4 ns If (CTime2_avtime(3).gt.tcut.or.CTime2_avtime(3).lt.-tcut) Then icut = 4 GoTo 950 EndIf endif goto 999 950 continue iout=0 999 continue End CDECK ID>, MYPCCN. SubRoutine MyPCCn (EnergyCuts,NrCond,IErr) Implicit None INTEGER Caltru,Caltru_9999 INTEGER Caltru_ID,Caltru_CConSa,Caltru_CuPaOb,Caltru_Cellnr REAL Caltru_E,Caltru_imbal,Caltru_t COMMON/Caltru/Caltru,Caltru_ID,Caltru_Cellnr,Caltru_E, + Caltru_imbal,Caltru_t(2),Caltru_CConSa,Caltru_CuPaOb, + Caltru_9999 INTEGER CConSa,CConSa_9999 INTEGER CConSa_ID,CConSa_NcEmc,CConSa_NcHac1,CConSa_NcHac2, + CConSa_Cidclu CHARACTER*8 CConSa_class REAL CConSa_x,CConSa_y,CConSa_z,CConSa_E,CConSa_radius,CConSa_cx, + CConSa_cy,CConSa_cz,CConSa_Eemc,CConSa_Cemc,CConSa_Ehac1, + CConSa_Chac1,CConSa_Ehac2,CConSa_Chac2 COMMON/CConSa/CConSa,CConSa_ID,CConSa_class,CConSa_x,CConSa_y, + CConSa_z,CConSa_E,CConSa_radius,CConSa_cx,CConSa_cy,CConSa_cz, + CConSa_Eemc,CConSa_Cemc(3),CConSa_Ehac1,CConSa_Chac1(3), + CConSa_Ehac2,CConSa_Chac2(3),CConSa_NcEmc,CConSa_NcHac1, + CConSa_NcHac2,CConSa_Cidclu,CConSa_9999 INTEGER CUCELL,CUCELL_9999 INTEGER CUCELL_ID,CUCELL_Volu,CUCELL_rotm,CUCELL_tmed,CUCELL_Nr REAL CUCELL_x,CUCELL_y,CUCELL_z COMMON/CUCELL/CUCELL,CUCELL_ID,CUCELL_Nr,CUCELL_x,CUCELL_y, + CUCELL_z,CUCELL_Volu,CUCELL_rotm,CUCELL_tmed,CUCELL_9999 INTEGER CCAdJa,CCAdJa_9999 INTEGER CCAdJa_ID,CCAdJa_No,CCAdJa_par COMMON/CCAdJa/CCAdJa,CCAdJa_ID,CCAdJa_No,CCAdJa_par(30), + CCAdJa_9999 * * .. Calorimeter common for condensates finding steering. * Real Ccemcc,Cchacc,Cconec,Cconhc,Cconmc * Common/ComCsa/Ccemcc,Cchacc,Cconec,Cconhc,Cconmc C. C C system-defined parameters for the Table Package Programmer C INTEGER MINC,MAXC,NEXT,INULL,IANY,INS,REP,ORD,UNO,AND,OR,DIF,HOR, + VER,ALL,ID,ALLCOL, + COUTAB,COUSEL,GETIND,GETSEL,GETPRO,GETDFL,GETTDF,SPATAB, + CHKTAP,MAKTAB REAL RNULL,RANY CHARACTER*4 CNULL,CANY LOGICAL BELSEL,BELTAB,CHKREL,CHKTAB,CHKWIN C C MINC and MAXC for cursors operation C PARAMETER (MINC=1, MAXC=2147483647) C C null values C PARAMETER (INULL=2147483647, RNULL= 699050*16.0**26, CNULL='====') C C ANY values C PARAMETER (IANY=-INULL, RANY=-RNULL, CANY='!@)(') C C NEXT for insertion C PARAMETER (NEXT=INULL) C C Modes C PARAMETER (INS = 1, REP = 2, + ORD = 1, UNO = 2, + AND = 1, OR = 2, DIF=3, + HOR = 1, VER = 2) C C Indices C PARAMETER (ALL = 1-INULL , ID = INULL-1, ALLCOL = 1-INULL) integer jre common/select/jre Integer I, NrCond, IErr Real EnergyCuts(10) Logical OK, Lprint Data Lprint /.TRUE./ C C Check geometry C NrCond = 0 IErr = 0 If (CouTab(CUCELL).LT.5900.OR.CouTab(CCAdJa).LE.0) Then IErr = 1 Write (6,*) ' MYPCCn reports: no CAL geometry ' Return Endif C C Overrule energy cuts C If (EnergyCuts(1).GE.0.) Ccemcc = EnergyCuts(1) If (EnergyCuts(2).GE.0.) Cchacc = EnergyCuts(2) If (EnergyCuts(3).GE.0.) Cconec = EnergyCuts(3) If (EnergyCuts(4).GE.0.) Cconhc = EnergyCuts(4) If (EnergyCuts(5).GE.0.) Cconmc = EnergyCuts(5) C C .. Protect against absolute zero C If (Ccemcc.LE.0.) Ccemcc = 0.0001 If (Cchacc.LE.0.) Cchacc = 0.0001 If (Cconec.LE.0.) Cconec = 0.0001 If (Cconhc.LE.0.) Cconhc = 0.0001 If (Cconmc.LE.0.) Cconmc = 0.0001 C C Clear up before start C Do 100 I=1,CouTab(Caltru) Call FetTab (Caltru,ID,I) Call NatRel (Caltru,Caltru_CConSa,CConSa,OK) If (OK) Call DelRel (Caltru,Caltru_CConSa,CConSa) 100 Continue Call CleTab (CConSa) C C First time: print some info C If (Lprint) Then Lprint = .FALSE. Write(6,1000) Write(6,1001) Ccemcc, Cchacc, Cconec, Cconhc, Cconmc Endif C C And go ahead C c rename the routine to make condensates - SRM c Call MyCreC (NrCond,IErr) Return 1000 Format(////, , 7X,' MYPCCN searches for condensates',/, , 7X,'---------------------------------',/) 1001 Format(/, , 6X,'The following energy cuts are applied: ',/, , 6X,'EMC cell energy cut ..................[GeV]',F8.3,/, , 6X,'HAC cell energy cut ..................[GeV]',F8.3,/, , 6X,'Pure EMC condensate energy cut .......[GeV]',F8.3,/, , 6X,'Pure HAC condensate energy cut .......[GeV]',F8.3,/, , 6X,'Mixed condensate energy cut ..........[GeV]',F8.3) End CDECK ID>, MYCREC. SubRoutine MyCreC (NrCond,IErr) Implicit None INTEGER CCAdJa,CCAdJa_9999 INTEGER CCAdJa_ID,CCAdJa_No,CCAdJa_par COMMON/CCAdJa/CCAdJa,CCAdJa_ID,CCAdJa_No,CCAdJa_par(30), + CCAdJa_9999 INTEGER CUCELL,CUCELL_9999 INTEGER CUCELL_ID,CUCELL_Volu,CUCELL_rotm,CUCELL_tmed,CUCELL_Nr REAL CUCELL_x,CUCELL_y,CUCELL_z COMMON/CUCELL/CUCELL,CUCELL_ID,CUCELL_Nr,CUCELL_x,CUCELL_y, + CUCELL_z,CUCELL_Volu,CUCELL_rotm,CUCELL_tmed,CUCELL_9999 INTEGER CUAdCl,CUAdCl_9999 INTEGER CUAdCl_ID,CUAdCl_CCAdJa,CUAdCl_CUCELL COMMON/CUAdCl/CUAdCl,CUAdCl_ID,CUAdCl_CCAdJa,CUAdCl_CUCELL, + CUAdCl_9999 INTEGER Caltru,Caltru_9999 INTEGER Caltru_ID,Caltru_CConSa,Caltru_CuPaOb,Caltru_Cellnr REAL Caltru_E,Caltru_imbal,Caltru_t COMMON/Caltru/Caltru,Caltru_ID,Caltru_Cellnr,Caltru_E, + Caltru_imbal,Caltru_t(2),Caltru_CConSa,Caltru_CuPaOb, + Caltru_9999 INTEGER CConSa,CConSa_9999 INTEGER CConSa_ID,CConSa_NcEmc,CConSa_NcHac1,CConSa_NcHac2, + CConSa_Cidclu CHARACTER*8 CConSa_class REAL CConSa_x,CConSa_y,CConSa_z,CConSa_E,CConSa_radius,CConSa_cx, + CConSa_cy,CConSa_cz,CConSa_Eemc,CConSa_Cemc,CConSa_Ehac1, + CConSa_Chac1,CConSa_Ehac2,CConSa_Chac2 COMMON/CConSa/CConSa,CConSa_ID,CConSa_class,CConSa_x,CConSa_y, + CConSa_z,CConSa_E,CConSa_radius,CConSa_cx,CConSa_cy,CConSa_cz, + CConSa_Eemc,CConSa_Cemc(3),CConSa_Ehac1,CConSa_Chac1(3), + CConSa_Ehac2,CConSa_Chac2(3),CConSa_NcEmc,CConSa_NcHac1, + CConSa_NcHac2,CConSa_Cidclu,CConSa_9999 * * .. Calorimeter common for condensates finding steering. * Real Ccemcc,Cchacc,Cconec,Cconhc,Cconmc * Common/ComCsa/Ccemcc,Cchacc,Cconec,Cconhc,Cconmc C. C C .. Fast and dirty common block for speedup. C Integer PMaxc Parameter (PMaxc = 50000) Real CPosit(PMaxc,6) C Common/CQuick/CPosit C. * *.. Parameter specifications for logical unit numbers * Integer Lp, Lgeom, Lout, Lin, Lcards, LHBook, Lanal, Lpdst Parameter (Lp=6) Parameter (Lgeom=8) Parameter (Lout=9) Parameter (Lcards=7) Parameter (LHBook=51) Parameter (Lpdst=6) Parameter (Lanal=88) * *.. Common to handle the Units specified by Adamo * Common/ ZRUNIT / Lin C C system-defined parameters for the Table Package Programmer C INTEGER MINC,MAXC,NEXT,INULL,IANY,INS,REP,ORD,UNO,AND,OR,DIF,HOR, + VER,ALL,ID,ALLCOL, + COUTAB,COUSEL,GETIND,GETSEL,GETPRO,GETDFL,GETTDF,SPATAB, + CHKTAP,MAKTAB REAL RNULL,RANY CHARACTER*4 CNULL,CANY LOGICAL BELSEL,BELTAB,CHKREL,CHKTAB,CHKWIN C C MINC and MAXC for cursors operation C PARAMETER (MINC=1, MAXC=2147483647) C C null values C PARAMETER (INULL=2147483647, RNULL= 699050*16.0**26, CNULL='====') C C ANY values C PARAMETER (IANY=-INULL, RANY=-RNULL, CANY='!@)(') C C NEXT for insertion C PARAMETER (NEXT=INULL) C C Modes C PARAMETER (INS = 1, REP = 2, + ORD = 1, UNO = 2, + AND = 1, OR = 2, DIF=3, + HOR = 1, VER = 2) C C Indices C PARAMETER (ALL = 1-INULL , ID = INULL-1, ALLCOL = 1-INULL) integer jre common/select/jre Logical First, Error, OK Integer Vector(5), IErr, NrCond, Idum, Iused, Itbd, Irel Integer Ic1,Ic2,ICE,ICAN,ICON,ICNO,ICCE,Irow,ICurNo,I,J Integer Nrem,Nrh1,Nrh2,Nrto Real Eemc,Eha1,Eha2,Etot,Remc,Rha1,Rha2,Rtot,Xem,Xh1,Xh2 Real Xto,Yem,Yh1,Yh2,Yto,Zem,Zh1,Zh2,Zto,Xha,Yha,Zha,Dsq Real ConRad Character*5 Kind Real P1(3),P2(3),Cx,Cy,Cz,Etmp Data First /.TRUE./ Call ModIn ('MyCreC', Idum) C If (First) Then ICE = GetInd (Caltru,'E') ICAN = GetInd (Caltru,'Cellnr') ICON = GetInd (Caltru,'CConSa') ICNO = GetInd (CUCELL,'Nr') ICCE = GetInd (CUAdCl,'CUCELL') c c Create a selector for cells already used to form a condensate. c Call CreSel(Caltru,Iused,'UsedCells') c c Create a selector for cells whose neighbours remain to be scanned. c Call CreSel(Caltru,Itbd,'Tobedone') First = .FALSE. Endif C Call CleSel(Caltru,Iused) Call CleSel(Caltru,Itbd) Call CleTab(CConSa) Call NulWin(CConSa) IErr=0 c c .. Begin loop c Irow = CouTab(Caltru) 10 If (CouSel(Caltru,Iused).EQ.CouTab(Caltru)) GoTo 200 20 Call FetTab(Caltru,ICE,Irow) If (BelSel(Caltru,jre)) Then Irow=Irow-1 If (Irow.LT.1) GoTo 200 GoTo 20 Endif c If (BelSel(Caltru,jrb)) Then c Irow=Irow -1 c if(Irow.LT.1) GoTo 200 c Goto 20 c Endif If (BelSel(Caltru,Iused)) Then Irow=Irow-1 If (Irow.LT.1) GoTo 200 GoTo 20 Endif c c .. Check energy c Call CcWhat(Caltru_Cellnr,Kind,Vector,Error) If (((Kind(2:4).EQ.'EMC'.AND.Caltru_E.LT.Ccemcc).OR. . (Kind(2:4).EQ.'HAC'.AND.Caltru_E.LT.Cchacc)).OR. . Caltru_E.LE.0.) Then Irow=Irow-1 If (Irow.LT.1) GoTo 200 Call InsSel (Caltru,Iused) GoTo 20 Endif c c .. Start a new condensate from this cell. c Call CccXyz(Caltru_Cellnr,Cx,Cy,Cz,Error) CConSa_ID=NEXT CConSa_x=Cx CConSa_y=Cy CConSa_z=Cz CConSa_E = Caltru_E If (Kind(2:4).EQ.'EMC') Then CConSa_Eemc=Caltru_E CConSa_NcEmc=1 CConSa_Ehac1=0. CConSa_NcHac1=0 CConSa_Ehac2=0. CConSa_NcHac2=0 Else if (Kind(2:5).EQ.'HAC0'.OR.Kind(2:5).EQ.'HAC1') Then CConSa_Eemc=0. CConSa_NcEmc=0 CConSa_Ehac1=Caltru_E CConSa_NcHac1=1 CConSa_Ehac2=0. CConSa_NcHac2=0 Else if (Kind(2:5).EQ.'HAC2') Then CConSa_Eemc=0. CConSa_NcEmc=0 CConSa_Ehac1=0. CConSa_NcHac1=0 CConSa_Ehac2=Caltru_E CConSa_NcHac2=1 Else Call MoSetC ('CreCon : Unknown cell!',1.,1) Write (Lp,1001) Caltru_Cellnr Endif Call InsEnt (CConSa) Call InsRel (Caltru,Caltru_CConSa,CConSa) Call InsSel (Caltru,Iused) Call InsSel (Caltru,Itbd) c c .. Start looking around in the neighbourhood. c If (CouSel(Caltru,Itbd).LT.1) GoTo 150 50 Call FetTab (Caltru,Itbd,1) ICurNo = Caltru_Cellnr CCAdJa_ID = Int(CPosit(Caltru_Cellnr,4)) c CUCELL_Nr = Caltru_Cellnr c Call SelTab (CUCELL,ICNO,IC1,IC2) c If (IC1.NE.IC2) Write(Lp,1000) ICurNo If (CCAdJa_ID.LE.0) Write(Lp,1000) ICurNo If (.NOT.BelTab(CCAdJa)) Write(Lp,1002) Call GetTab(CCAdJa) c Call NafRel (CUCELL,CUAdCl_CUCELL,CUAdCl,ICCE,IC1,IC2) c If (IC1.NE.IC2) Write(Lp,1002) c Call NatRel (CUAdCl,CUAdCl_CCAdJa,CCAdJa,OK) c c .. These are all neighbouring cells of the current one. c Do 100 J=1,CCAdJa_No Caltru_Cellnr = ICurNo + CCAdJa_par(J) Call SelTab (Caltru,ICAN,Ic1,Ic2) If (Ic1.GT.Ic2) GoTo 100 If (Ic1.LT.Ic2) Write (Lp,1003) Caltru_Cellnr If (BelSel(Caltru,Iused)) GoTo 100 c c .. Check the energy again. c Call CcWhat(Caltru_Cellnr,Kind,Vector,Error) If (((Kind(2:4).EQ.'EMC'.AND.Caltru_E.LT.Ccemcc).OR. . (Kind(2:4).EQ.'HAC'.AND.Caltru_E.LT.Cchacc)).OR. . Caltru_E.LE.0.) Then Call InsSel (Caltru,Iused) GoTo 100 Endif c c .. This one is OK, add it to the condensate c Call CccXyz(Caltru_Cellnr,Cx,Cy,Cz,Error) Etmp=CConSa_E+Caltru_E CConSa_x=(CConSa_x*CConSa_E+Cx*Caltru_E)/Etmp CConSa_y=(CConSa_y*CConSa_E+Cy*Caltru_E)/Etmp CConSa_z=(CConSa_z*CConSa_E+Cz*Caltru_E)/Etmp CConSa_E=Etmp If (Kind(2:4).EQ.'EMC') Then CConSa_Eemc=CConSa_Eemc+Caltru_E CConSa_NcEmc=CConSa_NcEmc+1 Else if (Kind(2:5).EQ.'HAC0'.OR.Kind(2:5).EQ.'HAC1') Then CConSa_Ehac1=CConSa_Ehac1+Caltru_E CConSa_NcHac1=CConSa_NcHac1+1 Else if (Kind(2:5).EQ.'HAC2') Then CConSa_Ehac2=CConSa_Ehac2+Caltru_E CConSa_NcHac2=CConSa_NcHac2+1 Else Call MoSetC ('CreCon : Unknown cell!',1.,1) Write (Lp,1001) Caltru_Cellnr Endif Call RepEnt (CConSa) Call InsRel (Caltru,Caltru_CConSa,CConSa) Call InsSel (Caltru,Iused) Call InsSel (Caltru,Itbd) 100 Continue c c .. We're finished with this cell. c Caltru_Cellnr = ICurNo Call SelTab (Caltru,ICAN,Ic1,Ic2) Call DelSel (Caltru,Itbd) If (CouSel(Caltru,Itbd).GT.0) GoTo 50 150 If (CouSel(Caltru,Iused).NE.CouTab(Caltru)) GoTo 10 c c 200 Call DroSel (Caltru,Iused) c Call DroSel (Caltru,Itbd) c c .. Finally, make a cut on the energy of the monster c 200 Do 300 I=CouTab(CConSa),1,-1 Call FetTab (CConSa,ID,I) If (CConSa_E.LE.0.) GoTo 270 If (CConSa_NcHac1.EQ.0.AND.CConSa_NcHac2.EQ.0) Then If (CConSa_E.GE.Cconec) GoTo 300 Else If (CConSa_NcEmc.EQ.0) Then If (CConSa_E.GE.Cconhc) GoTo 300 Else If (CConSa_E.GE.Cconmc) GoTo 300 Endif 270 Call NafRel (CConSa,Caltru_CConSa,Caltru,ICON,Ic1,Ic2) Do 250 J=Ic2,Ic1,-1 Call FetTab (Caltru,ICON,J) Call DelRel (Caltru,Caltru_CConSa,CConSa) 250 Continue Call DelTab (CConSa) 300 Continue c NrCond = CouTab (CConSa) c c .. And calculate the remaining attributes. c Do 400 I=1,CouTab(CConSa) Call FetTab (CConSa,ID,I) Call CoSect (CConSa_ID,'EMC',Eemc,Xem,Yem,Zem,Nrem) Call CoSect (CConSa_ID,'H01',Eha1,Xh1,Yh1,Zh1,Nrh1) Call CoSect (CConSa_ID,'HA2',Eha2,Xh2,Yh2,Zh2,Nrh2) Call CoSect (CConSa_ID,'ALL',Etot,Xto,Yto,Zto,Nrto) CConSa_radius = ConRad(CConSa_ID,'ALL',Xto,Yto,Zto) CConSa_Eemc = Eemc If (Eemc.GT.0.) Then CConSa_Cemc(1) = Xem CConSa_Cemc(2) = Yem CConSa_Cemc(3) = Zem Else CConSa_Cemc(1) = RNULL CConSa_Cemc(2) = RNULL CConSa_Cemc(3) = RNULL Endif CConSa_Ehac1 = Eha1 If (Eha1.GT.0.) Then CConSa_Chac1(1) = Xh1 CConSa_Chac1(2) = Yh1 CConSa_Chac1(3) = Zh1 Else CConSa_Chac1(1) = RNULL CConSa_Chac1(2) = RNULL CConSa_Chac1(3) = RNULL Endif If (CConSa_z.GT.-145.) Then CConSa_Ehac2 = Eha2 Else CConSa_Ehac2 = RNULL Endif If (Eha2.GT.0.) Then CConSa_Chac2(1) = Xh2 CConSa_Chac2(2) = Yh2 CConSa_Chac2(3) = Zh2 Else CConSa_Chac2(1) = RNULL CConSa_Chac2(2) = RNULL CConSa_Chac2(3) = RNULL Endif If (((Eha1.GT.0.).OR.(Eha2.GT.0.)).AND.(Eemc.GT.0.)) Then Xha = (Xh1*Eha1 + Xh2*Eha2)/(Eha1+Eha2) Yha = (Yh1*Eha1 + Yh2*Eha2)/(Eha1+Eha2) Zha = (Zh1*Eha1 + Zh2*Eha2)/(Eha1+Eha2) Dsq = (Xha-Xem)**2+(Yha-Yem)**2+(Zha-Zem)**2 CConSa_cx = (Xha-Xem)/Sqrt(Dsq) CConSa_cy = (Yha-Yem)/Sqrt(Dsq) CConSa_cz = (Zha-Zem)/Sqrt(Dsq) Else CConSa_cx = RNULL CConSa_cy = RNULL CConSa_cz = RNULL Endif Call RepEnt (CConSa) 400 Continue c Call ModOut ('MyCreC') 1000 Format(' No entry in CUCELL for cell number ',I8) 1001 Format(' Unknown cell is hit : ',I8) 1002 Format(' Corrupt link CUAdCl - CUCELL') 1003 Format(' MyCreC: Double entry in Caltru: ',I8) Return End CDECK ID>, BOXBOX. subroutine boxbox(n,icut) implicit none integer icut integer n,ical,imod,itow,icel,icell,isid,ierr icut=0 ical=0 itow=0 imod=0 ierr=0 call ccmtcs(n,ical,imod,itow,icel,icell,isid,ierr) if (ierr.eq.0) then if (ical.eq.1.or.ical.eq.3) then ! fcal or rcal if (imod.eq.11.or.imod.eq.12.or.imod.eq.13) then ! modules 11,12,13 if (itow.eq.11.or.itow.eq.12.or.itow.eq.13) then ! tower 11,12,13 icut=1 endif endif endif endif return end CDECK ID>, NOISESU2. SUBROUTINE NOISESUP2(ECUT,VTX,ISLFL,DELFL,NCELLS + ,SUMENERGY,MOMENTUM,IERR) IMPLICIT NONE C C system-defined parameters for the Table Package Programmer C INTEGER MINC,MAXC,NEXT,INULL,IANY,INS,REP,ORD,UNO,AND,OR,DIF,HOR, + VER,ALL,ID,ALLCOL, + COUTAB,COUSEL,GETIND,GETSEL,GETPRO,GETDFL,GETTDF,SPATAB, + CHKTAP,MAKTAB REAL RNULL,RANY CHARACTER*4 CNULL,CANY LOGICAL BELSEL,BELTAB,CHKREL,CHKTAB,CHKWIN C C MINC and MAXC for cursors operation C PARAMETER (MINC=1, MAXC=2147483647) C C null values C PARAMETER (INULL=2147483647, RNULL= 699050*16.0**26, CNULL='====') C C ANY values C PARAMETER (IANY=-INULL, RANY=-RNULL, CANY='!@)(') C C NEXT for insertion C PARAMETER (NEXT=INULL) C C Modes C PARAMETER (INS = 1, REP = 2, + ORD = 1, UNO = 2, + AND = 1, OR = 2, DIF=3, + HOR = 1, VER = 2) C C Indices C PARAMETER (ALL = 1-INULL , ID = INULL-1, ALLCOL = 1-INULL) INTEGER Caltru,Caltru_9999 INTEGER Caltru_ID,Caltru_CConSa,Caltru_CuPaOb,Caltru_Cellnr REAL Caltru_E,Caltru_imbal,Caltru_t COMMON/Caltru/Caltru,Caltru_ID,Caltru_Cellnr,Caltru_E, + Caltru_imbal,Caltru_t(2),Caltru_CConSa,Caltru_CuPaOb, + Caltru_9999 INTEGER CConSa,CConSa_9999 INTEGER CConSa_ID,CConSa_NcEmc,CConSa_NcHac1,CConSa_NcHac2, + CConSa_Cidclu CHARACTER*8 CConSa_class REAL CConSa_x,CConSa_y,CConSa_z,CConSa_E,CConSa_radius,CConSa_cx, + CConSa_cy,CConSa_cz,CConSa_Eemc,CConSa_Cemc,CConSa_Ehac1, + CConSa_Chac1,CConSa_Ehac2,CConSa_Chac2 COMMON/CConSa/CConSa,CConSa_ID,CConSa_class,CConSa_x,CConSa_y, + CConSa_z,CConSa_E,CConSa_radius,CConSa_cx,CConSa_cy,CConSa_cz, + CConSa_Eemc,CConSa_Cemc(3),CConSa_Ehac1,CConSa_Chac1(3), + CConSa_Ehac2,CConSa_Chac2(3),CConSa_NcEmc,CConSa_NcHac1, + CConSa_NcHac2,CConSa_Cidclu,CConSa_9999 INTEGER MAXIMUMID PARAMETER (MAXIMUMID=100) INTEGER NOISEID(MAXIMUMID) COMMON /NOISECM/ NOISEID REAL ECUT(2), VTX, SUMENERGY, MOMENTUM(3) INTEGER NCELLS, IERR LOGICAL ISLFL, DELFL REAL DEFAULTCUT(2) DATA DEFAULTCUT /0.08, 0.14/ INTEGER I, J, NUM, SEC, EMC, HAC PARAMETER (EMC=1, HAC=2) LOGICAL IER, FIRST DATA FIRST /.TRUE./ REAL X, Y, Z, THETA, PHI INTEGER NCELLMAX, NISLANDMAX PARAMETER (NCELLMAX=600, NISLANDMAX=200) INTEGER NISLAND, CELNUM, ERRIS, ISLAND(NCELLMAX), & POSERNR(NCELLMAX), NUM_CELLS(NISLANDMAX) REAL E_CELL(NCELLMAX) LOGICAL CHECK IERR = 0 NCELLS = 0 SUMENERGY = 0. CALL VZERO(NUM_CELLS,NISLANDMAX) CALL VZERO(NOISEID,MAXIMUMID) CALL VZERO(MOMENTUM,3) DO I = EMC, HAC IF (ECUT(I).LT.0.) ECUT(I) = DEFAULTCUT(I) ENDDO IF (FIRST) THEN FIRST = .FALSE. WRITE(*,'(A20)') ' ********************************** ' WRITE(*,'(A20)') ' NOISE SUPPRESSION ' WRITE(*,'(A20,F6.3)') ' ENERGYCUT EMC ', ECUT(1) WRITE(*,'(A20,F6.3)') ' ENERGYCUT HAC ', ECUT(2) WRITE(*,'(A20,L5)') ' ISLAND FLAG ', ISLFL WRITE(*,'(A20,L5)') ' DELETE FLAG ', DELFL WRITE(*,'(A20)') ' ********************************** ' ENDIF IF (COUTAB(CALTRU).EQ.0) THEN IERR = 1 RETURN ENDIF IF (ISLFL) THEN IF (COUTAB(CALTRU).GT.NCELLMAX) THEN WRITE(*,'(A50)') + ' WARNING: TOO MUCH CELLS FOR THE ISLAND ALGORITHM' WRITE(*,'(A12,I3,A16)') + ' ONLY FIRST ', NCELLMAX, ' CELLS ACCEPTED ' ENDIF CELNUM = MIN(COUTAB(CALTRU),NCELLMAX) DO I = 1, CELNUM CALL FETTAB(CALTRU,ID,I) POSERNR(I) = CALTRU_CELLNR E_CELL(I) = CALTRU_E ENDDO CALL ISLANDS(NISLAND,ISLAND,POSERNR,E_CELL,CELNUM,ERRIS) IF (ERRIS.GT.0) PRINT*, 'WARNING: ERROR IN SUBROUTINE ISLANDS' DO I = 1, CELNUM NUM_CELLS(ISLAND(I)) = NUM_CELLS(ISLAND(I)) + 1 ENDDO ENDIF DO I = COUTAB(CALTRU), 1, -1 CALL FETTAB(CALTRU,ID,I) CHECK = .TRUE. IF (ISLFL) THEN DO J = 1, NISLAND IF (NUM_CELLS(J).GT.1) THEN IF (ISLAND(I).EQ.J) CHECK =.FALSE. ENDIF ENDDO ENDIF IF ((CALTRU_CCONSA.EQ.INULL).AND.CHECK) THEN NUM = ISHFT(IAND(CALTRU_CELLNR,15),-1) IF (NUM.EQ.0) THEN IERR = -1 RETURN ELSE IF (NUM.LE.4) THEN SEC = EMC ELSE IF (NUM.LE.7) THEN SEC = HAC ENDIF IF (CALTRU_E.LT.ECUT(SEC)) THEN NCELLS = NCELLS + 1 SUMENERGY = SUMENERGY + CALTRU_E CALL CCCXYZ(CALTRU_CELLNR,X,Y,Z,IER) THETA = ATAN2(SQRT(X**2+Y**2),(Z-VTX)) PHI = ATAN2(Y,X) MOMENTUM(1) = MOMENTUM(1) + CALTRU_E*SIN(THETA)*COS(PHI) MOMENTUM(2) = MOMENTUM(2) + CALTRU_E*SIN(THETA)*SIN(PHI) MOMENTUM(3) = MOMENTUM(3) + CALTRU_E*COS(THETA) IF (DELFL) THEN CALL DELTAB(CALTRU) ELSE IF (NCELLS.LT.MAXIMUMID) THEN NOISEID(NCELLS) = CALTRU_ID ELSE WRITE(*,'(A28)') ' TOO MANY NOISE CELLS FOUND ' ENDIF ENDIF ENDIF ENDIF ENDDO END C =================== E N D O F F I L E =============