*-- Author : I. O. Skillicorn 16/11/92
SUBROUTINE FPPJN3
c fpphit called to check link in phi
c ie check momentum consistency
**: FPPJN3 40000 IS. New linking code.
**----------------------------------------------------------------------
**: FPPJN3 30907 RP. Farm changes.
**----------------------------------------------------------------------
C JOIN 3 PLANAR MODULES
C 1MM ERRORS USED IN CHI .
*KEEP,FRDIMS.
PARAMETER (MAXHTS=200)
PARAMETER (NUMWPL=36)
PARAMETER (MAXTRK=200)
PARAMETER (MXTTRK=900)
PARAMETER (MAXTR3=200)
PARAMETER (MAXHPW=2)
PARAMETER (MAXDIG=2000)
PARAMETER (NUMRWR=1727)
PARAMETER (NUMPWR=1151)
*KEEP,FPPRAM.
C
C--- MAXSEG is maximum number of segments per supermodule
C--- MAXCON is maximum number of amibiguous segments associatable with
C--- one segment
C--- LIMSTO is maximum number of 2 cluster planes intersections to be
C--- stored per supermodule
C--- MSEGLM is maximum number of clusters that can be found before
C--- connectivity considered
C--- MAXCLU is maximum number of clusters that can be found after
C--- forming non-connected set MUST BE 50 IF RUN WITH OLD RCW
C--- (cluster = 3/4 digits found in a straight line in one
C--- 4-wire orientation)
C
PARAMETER (MAXSEG = 200)
PARAMETER (MAXCON = 100)
PARAMETER (LIMSTO = 5000)
PARAMETER (MSEGLM = 150)
PARAMETER (MAXCLU = 50)
C---
*KEEP,FH1WORK.
COMMON/FGMIOS/
* Planar geometry
+ ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
* Radial geometry
+ ZP(36),PHW(36),WS(36)
*
COMMON/H1WORK/
* Radial data...
+ WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
+ NDP(36), NW(MAXHTS,36), DWS(MAXHTS,36),
*
* Planar Data
+ NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
+ DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
+ WWP(MAXHTS,NUMWPL),
+ IPHOLE(MAXHTS,NUMWPL),
*
* Pointers into DIGI bank for IOS labelled hits
+ IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
+ IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
* Track segment data
+ NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
* Fit data
+ PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
+ DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
+ DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
+ RPCOSG(MAXTRK),RPSING(MAXTRK),
+ PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
+ IRADG(36,MAXTRK),PHIG(36,MAXTRK),
+ IG,SDRADG(36,MAXTRK),
+ R1,Z1,RFIT(MAXTRK,3),
+ CHG(MAXTRK),
+ PPA(MAXTRK,3), ZZA(MAXTRK,3),
+ GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FPFVTX.
COMMON/VERTFF/ZFF,XFF,YFF
*
*KEEP,FPJPAR.
COMMON/FPJPAR/
+ RRCUT1, RRCUT2, RRCUT3,
+ PLCC3, PLCC12, PLCC23, PLCC13
*KEND.
COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
1 SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)
COMMON/FTPLNK/LINK,CHIL(100),LNK(3,100),IUS(100,3)
COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
COMMON/FKLOC/KLOC(100)
COMMON/FEVSAT/IEVSAT
COMMON/fsegtp/iseg(100,3)
DIMENSION PSS(100),PIS(100),RSS(100),RIS(100)
DIMENSION TH(50),XX(50),YY(50),ZZ(50),WP(50),WPP(50)
DIMENSION ICM(100),RRR(3),RRZ(3),PPP(3),FNR(3),PZZ(50),IPZ(50)
DIMENSION WDP(50),CH(100)
PI2=6.283185307
LINK=0
* RRCUT=5.0
DO 20 I=1,36
DO 20 J=1,100
IPP(I,J)=0
20 CONTINUE
NPP=0
DO 10 I=1,3
DO 10 J=1,50
10 IUS(J,I)=0
DO 100 I=1,NS(1)
Z1=ZPP(6)
X1=SPAR(3,I,1)*Z1+SPAR(4,I,1)
Y1=SPAR(1,I,1)*Z1+SPAR(2,I,1)
DO 200 J=1,NS(2)
Z2=ZPP(18)
X2=SPAR(3,J,2)*Z2+SPAR(4,J,2)
Y2=SPAR(1,J,2)*Z2+SPAR(2,J,2)
ZM=0.5*(Z1+Z2)
X1M=SPAR(3,I,1)*ZM+SPAR(4,I,1)
Y1M=SPAR(1,I,1)*ZM+SPAR(2,I,1)
X2M=SPAR(3,J,2)*ZM+SPAR(4,J,2)
Y2M=SPAR(1,J,2)*ZM+SPAR(2,J,2)
C PLANAR SEGMENTS ARE JOINED BY PROJECTING THE SEGMENTS TO A
C PLANE MIDWAY BETWEEN THE SEGMENTS. THE DISTANCE**2 BETWEEN
C THE PROJECTIONS,RR, ON THIS PLANE IS USED AS A MEASURE OF
C THE GOODNESS OF LINKAGE. IF RR IS LESS THAN RCUT THE
C LINK IS ACCEPTED.
RR=(X1M-X2M)**2+(Y1M-Y2M)**2
IF (ABS(Y1M-Y2M).LT.2.0) CALL SHS(907,0,X1M-X2M)
IF (ABS(X1M-X2M).LT.2.0) CALL SHS(908,0,Y1M-Y2M)
CALL SHS(904,0,RR)
RRCUT=RRCUT1
If( iseg(i,1).gt.1
+ .or. iseg(j,2).gt.1 )RRCUT=RRCUT2
If( iseg(i,1).gt.2
+ .or. iseg(j,2).gt.2 )RRCUT=RRCUT3
IF(RR.GT.RRCUT)GOTO200
c plots to check link consistency in phi
call fpphit(1,2,i,j,iflag)
if(iflag.eq.1)goto200
DO 300 K=1,NS(3)
Z3=ZPP(30)
X3=SPAR(3,K,3)*Z3+SPAR(4,K,3)
Y3=SPAR(1,K,3)*Z3+SPAR(2,K,3)
ZM=0.5*(Z2+Z3)
X2M=SPAR(3,J,2)*ZM+SPAR(4,J,2)
Y2M=SPAR(1,J,2)*ZM+SPAR(2,J,2)
X3M=SPAR(3,K,3)*ZM+SPAR(4,K,3)
Y3M=SPAR(1,K,3)*ZM+SPAR(2,K,3)
RR=(X3M-X2M)**2+(Y3M-Y2M)**2
CALL SHS(905,0,RR)
RRCUT=RRCUT1
If( iseg(i,1).gt.1
+ .or. iseg(j,2).gt.1
+ .or. iseg(k,3).gt.1 )RRCUT=RRCUT2
If( iseg(i,1).gt.2
+ .or. iseg(j,2).gt.2
+ .or. iseg(k,3).gt.2 )RRCUT=RRCUT3
IF(RR.GT.RRCUT)GOTO300
call fpphit(1,2,i,j,iflag)
if(iflag.eq.1)goto300
C POTENTIAL LINK - CALCULATE CHI BETWEEN PARABOLA AND
C FITTED LINE SEGMENTS
C PARABOLA IS THRU CENTRE OF SEGMENTS
CHI=0.
IBAD=0
IC=0
ICC=0
DO 310 IL=1,3
RRR(IL)=0.
RRZ(IL)=0.
PPP(IL)=0.
FNR(IL)=0.
310 CONTINUE
DO 400 L=1,3
IF(L.EQ.1)II=I
IF(L.EQ.2)II=J
IF(L.EQ.3)II=K
DO 410 LL=1,12
IP=(L-1)*12+LL
ZA=ZPP(IP)
JJ=IPT(LL,II,L)
IF(JJ.NE.0)THEN
SGNN=SGN(LL,II,L)
ICC=ICC+1
C DRIFT COORDS FOR PLANARS
WDP(ICC)=SGNN*DRIW(JJ,IP)+DW(JJ,IP)
PZZ(ICC)=ZA
IPZ(ICC)=IP
ENDIF
XP=FPARAB(ZA,X1,X2,X3,Z1,Z2,Z3)
XF=SPAR(3,II,L)*ZA+SPAR(4,II,L)
* CHI=CHI+(XF-XP)**2/(0.10)**2
YP=FPARAB(ZA,Y1,Y2,Y3,Z1,Z2,Z3)
YF=SPAR(1,II,L)*ZA+SPAR(2,II,L)
* CHI=CHI+(YF-YP)**2/(0.10)**2
IC=IC+1
XX(IC)=ZA
YY(IC)=ATAN2(YF,XF)
ZZ(IC)=SQRT(XF**2+YF**2)
IF(YY(IC).LT.0.0)YY(IC)=YY(IC)+PI2
WP(IC)=1./(0.10/ZZ(IC))
WPP(IC)=1.0
ICM(IC)=L
RRZ(L)=RRZ(L)+ZA
RRR(L)=RRR(L)+ZZ(IC)
FNR(L)=FNR(L)+1.0
410 CONTINUE
IF(FNR(L).NE.0.)RRZ(L)=RRZ(L)/FNR(L)
IF(FNR(L).NE.0.)RRR(L)=RRR(L)/FNR(L)
400 CONTINUE
IF(IC .GT. 1)THEN
DO 600 JJ=2,IC
DP = YY(JJ)-YY(JJ-1)
IF(DP.GT.0.) THEN
IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
ELSE
IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
ENDIF
600 CONTINUE
ENDIF
******ADDED IOS 16/11/93**************************************
C CALCULATE MEAN PHI FOR PARABOLA
FNR(1)=0
FNR(2)=0
FNR(3)=0
DO 610 JJ=1,IC
L=ICM(JJ)
PPP(L)=PPP(L)+YY(JJ)
FNR(L)=FNR(L)+1.
610 CONTINUE
IF(FNR(1).NE.0.)PPP(1)=PPP(1)/FNR(1)
IF(FNR(2).NE.0.)PPP(2)=PPP(2)/FNR(2)
IF(FNR(3).NE.0.)PPP(3)=PPP(3)/FNR(3)
******END ADD 16/11/93*******************************************
C FIT PHI-Z
CALL FTLFTW(XX,YY,WP,IC,0,2,PS,PI,D1,D2,D3,D4)
C FIT R-Z
CALL FTLFTW(XX,ZZ,WPP,IC,0,2,RS,RI,D1,D2,D3,D4)
CHIP=0.
DO 700 JJ=1,IC
CHIP=CHIP+(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2
DIFF=YY(JJ)-PS*XX(JJ)-PI
C PRINT1002,JJ,(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2,YY(JJ),DIFF
1002 FORMAT(' ',I3, F10.2,2F10.4)
700 CONTINUE
CHIP=CHIP/36.
CALL SHS(500,0,CHIP)
C CHI FOR DRIFT RELATIVE TO PARABOLAE IN PHI-Z , R-Z
CHID=0.
DO 710 JJ=1,ICC
ZED=PZZ(JJ)
PHI=FPARAB(ZED,PPP(1),PPP(2),PPP(3),
1 RRZ(1),RRZ(2),RRZ(3))
RRP=FPARAB(ZED,RRR(1),RRR(2),RRR(3),
1 RRZ(1),RRZ(2),RRZ(3))
THETA=ATAN2(S(IPZ(JJ)),C(IPZ(JJ)))
WE=RRP*SIN(PHI-THETA)
CHID=CHID+(WE-WDP(JJ))**2/(0.04)**2
710 CONTINUE
CHID=CHID/FLOAT(ICC)
CALL SHS(571,0,CHID)
* Remove Links with poor Chisq... 18/11/93
IF(CHID.GT.PLCC3)GOTO300
*
LINK=LINK+1
IF(LINK.GT.100)LINK=100
PSS(LINK)=PS
PIS(LINK)=PI
RSS(LINK)=RS
RIS(LINK)=RI
CHIL(LINK)=CHI
CH(LINK)=CHID
LNK(1,LINK)=I
LNK(2,LINK)=J
LNK(3,LINK)=K
* II=LINK
C PRINT 1001,II,LNK(1,II),LNK(2,II),LNK(3,II),CHIL(II)
1001 FORMAT(' PJN3I',I3,2X,3I3,F10.2)
C CALCULATE A CURVATURE IN THE X,Y PLANE HENCE MOMENTUM
C SS=SAGITTA SQUARED USE R=L**2/(8*S)
C WORKS OK 1 GEV AND ABOVE. BELOW OVERESTIMATES P DUE TO
C WRONG SLOPE PROBABLY
* SS=(X2-0.5*(X1+X3))**2+(Y2-0.5*(Y1+Y3))**2
* RAD=((X3-X1)**2+(Y3-Y1)**2)/(8.0*SQRT(SS))
* TANT=(SQRT(X2**2+Y2**2)-SQRT(X1**2+Y1**2))/(Z2-Z1)
* THET=ATAN(TANT)
* TH(LINK)=THET
* RAD=RAD/SIN(THET)
* PP=12.*0.0002998*RAD
* PH1=ATAN2(Y1,X1)
* PH2=ATAN2(Y2,X2)
* IF(PH1.LT.0.0)PH1=PH1+PI2
* IF(PH2.LT.0.0)PH2=PH2+PI2
* SIGN=1.0
* DIFF=PH2-PH1
* IF(DIFF.LT.-3.14)DIFF=DIFF+PI2
* IF(DIFF.GT.3.14)DIFF=DIFF-PI2
* IF(DIFF.GT.0.)SIGN=-1.
* PP=PP*SIGN
C IF(ABS(PP).LT.1.0)THEN
C WRITE(*,*)' PP XYZ 123 ',PP ,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3
C WRITE(*,*)' SS LL**2 ',SQRT(SS),(X3-X1)**2+(Y3-Y1)**2
C ENDIF
* PPP(LINK)=PP
300 CONTINUE
200 CONTINUE
100 CONTINUE
C NEW COMPARE SECTION
LLL=LINK
DO 500 LOOP=1,LLL
CHB=100000.
KB=0
C SELECT BEST
DO 510 K=1,LLL
IF(CH(K).LT.0.0)GOTO 510
IF(LNK(1,K).EQ.0)GOTO 510
IF(LNK(2,K).EQ.0)GOTO 510
IF(LNK(3,K).EQ.0)GOTO 510
* WRITE(*,*)' K ,CHI ',K,CH(K),LNK(1,K),LNK(2,K),LNK(3,K)
IF(CH(K).LT.CHB)THEN
CHB=CH(K)
KB=K
ENDIF
510 CONTINUE
* WRITE(*,*)' KB,CHIB ',KB,CHB
IF(KB.EQ.0)GOTO 545
C COMPARE BEST WITH REMAINDER
DO 520 K=1,LLL
IF(K.EQ.KB)GOTO520
IF(LNK(1,K).EQ.0)GOTO520
IF(LNK(2,K).EQ.0)GOTO520
IF(LNK(3,K).EQ.0)GOTO520
IF(LNK(1,K).EQ.LNK(1,KB))GOTO530
IF(LNK(2,K).EQ.LNK(2,KB))GOTO530
IF(LNK(3,K).EQ.LNK(3,KB))GOTO530
GOTO 520
C REMOVE LINK
530 LNK(1,K)=0
LNK(2,K)=0
LNK(3,K)=0
* WRITE(*,*)' REMOVE ',K
520 CONTINUE
C COMPARE FINISHED , MARK BEST SEGMENT USED
CH(KB)=-CH(KB)
500 CONTINUE
C RESET CHI WHEN COMPARE FINISHED
545 DO 540 LOOP=1,LLL
IF(CH(LOOP).LT.0.0)CH(LOOP)=-CH(LOOP)
540 CONTINUE
C
C
C
DO 550 I=1,LINK
IF(LNK(1,I).EQ.0)GOTO550
NPP=NPP+1
IF(NPP.GT.100) THEN
NPP = 100
IEVSAT = 1
ENDIF
KLOC(NPP) = 1
C SET USED FLAG
C PRINT 1000,I,LNK(1,I),LNK(2,I),LNK(3,I),CHIL(I)
L1=LNK(1,I)
L2=LNK(2,I)
L3=LNK(3,I)
LP(1,NPP)=L1
LP(2,NPP)=L2
LP(3,NPP)=L3
PSSS(NPP)=PSS(I)
PISS(NPP)=PIS(I)
RSSS(NPP)=RSS(I)
RISS(NPP)=RIS(I)
C PRINT 1000,I,(IPT(III,L1,1),III=1,12)
C 1,(IPT(III,L2,2),III=1,12)
C 1,(IPT(III,L3,3),III=1,12),CHIL(I)
1000 FORMAT(' PJN3 ',I3,1X,3(1X,12I2),F6.2,F7.2)
1200 FORMAT(' ',12I3)
DO 551 KK=1,12
IPP(KK,NPP)=IPT(KK,L1,1)
IPP(KK+12,NPP)=IPT(KK,L2,2)
IPP(KK+24,NPP)=IPT(KK,L3,3)
551 CONTINUE
CHPP(NPP)=CH(I)
IUS(LNK(1,I),1)=1
IUS(LNK(2,I),2)=1
IUS(LNK(3,I),3)=1
PROD=PROB(CH(I)*36.,36)
CALL SHS(575,0,PROD )
CALL SHS(550,0,2.001)
CALL SHS(550,0,10.001)
550 CONTINUE
CIOS CALL PLAFIT(TH)
RETURN
END
*