*-- Author : R. Henderson
SUBROUTINE FPSGRF
**: FPSGRF.......SM. Bug fix. Protect against small Chisq for PROB.
**----------------------------------------------------------------------
C---------------------------------------------------------------
C
C routine checks the connectivity of the found segments
C and returns an optimized non-connected solution in MASKSG
C 0 = accept segment , -1 = reject segment
C
C---------------------------------------------------------------
C---
*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---
*KEND.
C---
*KEEP,FPLSEG.
C---
COMMON /FPLSEG / PW(12,MAXSEG,3) , PWC(12,MAXSEG,3) ,
1 PRCHI(MAXSEG,3) , NFSEG(3) ,
2 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
3 ZSEG(2,MAXSEG,3) ,
4 ASEGIN(MAXSEG,3) , ISEGIN(5,MAXSEG,3) ,
5 MASKSG(MAXSEG,3) , IDGISG(12,MAXSEG,3)
C---
*KEND.
C---
*KEEP,FPCLUS.
COMMON /FPCLUS/ TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
2 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
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)
LOGICAL DRMASK
COMMON /H1WORK/
C-- *KEEP,FPCSEG.
C---
3 TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU) ,
4 SMLS(4,2,LIMSTO,3) ,
C---
C-- *KEEP,FPDIGI.
5 DRSTO(MSEGLM,4),NDRSTO(4),
6 IDIGST(4,MSEGLM),
7 SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
8 IDCELL(MSEGLM,4),
9 NSGTAB(MSEGLM),ASGTAB(MSEGLM),
A RESSTO(MSEGLM,4) ,
C---
C-- *KEEP,FPDGI.
B IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
C ,RCHI(MAXSEG,3) ,
C---
C-- *KEEP,FPSTID.
D IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
E IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C-- *interface to real data
F NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
G DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
G DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
H IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
C---
C---
C--- Local variables
C---
C--- ISGTAB (I,J) = segment number of Jth node connected to Ith node
C--- KSGTAB (I) = number of segments connected to Ith node
C--- MXLIS = list of nodes with maximum connectivity
C--- CHLIS = weight asscociated with each node listed in MXLIS
C
DIMENSION KSGTAB(MAXSEG) , FSGTAB(MAXSEG) , ISGTAB(MAXSEG,MAXCON)
DIMENSION MXLIS(MAXSEG) , CHLIS(MAXSEG)
C
C--- input
C
C ASEGIN(SEG,SUPERMODULE) = chisquare of segment
C
C ISEGIN(1,SEG,SUPERMODULE) = 1st cluster-plane for segment
C ISEGIN(2,SEG,SUPERMODULE) = 2nd cluster-plane for segment
C ISEGIN(3,SEG,SUPERMODULE) = 3rd cluster-plane for segment
C ISEGIN(4,SEG,SUPERMODULE) = number of degree of freedom for segmen
C
C NFSEG(SUPERMODULE) = number of found segments per supermodu
C
C--- output
C
C MASKSG(SEG,SUPERMODULE) = 0 if allowed
C = -1 if lost
C
C
C--- loop over supermodules
C
DO 10 ISM = 1,3
C
C--- zero ksgtab
C
DO 50 I = 1,MAXSEG
KSGTAB(I) = 0
50 CONTINUE
C
C--- construct connectivity table
C
C
C--- 1st loop over segments
C
DO 20 ISEG = 1,NFSEG(ISM)
DO 21 KSEG = 1,NFSEG(ISM)
C
C--- remove if segs the same
C
IF(ISEG.EQ.KSEG)GO TO 21
C
C--- search to see if any cluster planes in common
C
DO 30 ID1 = 1,3
ICP1 = ISEGIN(ID1,ISEG,ISM)
DO 31 ID2 = 1,3
ICP2 = ISEGIN(ID2,KSEG,ISM)
IF(ICP1 .NE. ICP2) GO TO 31
C
C--- found one in common , increment counter , store connection
C
KSGTAB(ISEG) = KSGTAB(ISEG) + 1
C
C--- trap out of bounds. has been known to happen in MC!
C
IF(KSGTAB(ISEG) .GT. MAXCON) THEN
GO TO 999
ENDIF
ISGTAB(ISEG,KSGTAB(ISEG)) = KSEG
C
C--- connection found skip furthur search of KSEG segment
C
GO TO 21
31 CONTINUE
30 CONTINUE
21 CONTINUE
20 CONTINUE
C
C
C
C--- Start to remove connectivity
C
C
C--- Find the highest multiplicity
C
500 CONTINUE
IF( NFSEG(ISM) .GT. 0)THEN
CALL VFLOAT(KSGTAB,FSGTAB,NFSEG(ISM))
MXSEG = LVMAX(FSGTAB,NFSEG(ISM))
IVMXSG = KSGTAB(MXSEG)
ELSE
IVMXSG = 0
ENDIF
IF(IVMXSG .EQ. 0) GO TO 600
C
C--- Loop over all segments and find those with same multiplicity
C
NMXSG = 0
DO 510 ISEG = 1,NFSEG(ISM)
C IF(KSGTAB(ISEG) .LT. (IVMXSG-2)
IF(KSGTAB(ISEG) .LT. (IVMXSG)
1 .OR. KSGTAB(ISEG) .LE. 0) GO TO 510
NMXSG = NMXSG + 1
MXLIS(NMXSG) = ISEG
510 CONTINUE
C
C--- Find which segment contributes most to chisquare
C
DO 520 IMX = 1 , NMXSG
MXSEG = MXLIS(IMX)
C
C--- Find probablility of link segments
C
CHISUM = 0.0
NDFSUM = 0
DO 521 LSEG = 1,KSGTAB(MXSEG)
CHISUM = CHISUM + ASEGIN(ISGTAB(MXSEG,LSEG),ISM)
NDFSUM = NDFSUM + ISEGIN(4,ISGTAB(MXSEG,LSEG),ISM)
521 CONTINUE
C
C--- Store probability of links less own prob
C
* Fix for v.small chisq...
IF(CHISUM .LT. 0.001) THEN
PROB1 = 0.99999
ELSE
PROB1 = PROB(CHISUM,NDFSUM)
ENDIF
IF(ASEGIN(MXSEG,ISM) .LT. 0.001) THEN
PROB2 = 0.99999
ELSE
PROB2 = PROB(ASEGIN(MXSEG,ISM),ISEGIN(4,MXSEG,ISM))
ENDIF
CHLIS(IMX) = PROB1 - PROB2
* CHLIS(IMX) = PROB(CHISUM,NDFSUM) -
* 1 PROB(ASEGIN(MXSEG,ISM),ISEGIN(4,MXSEG,ISM))
520 CONTINUE
C
C
C--- Find the segment with largest positive contribution
C
MXPSEG = LVMAX(CHLIS,NMXSG)
IWSEG = MXLIS(MXPSEG)
C
C--- Remove all reference to this segment from connectivity table
C
KSGTAB(IWSEG) = -1
DO 530 IS = 1, NFSEG(ISM)
IF( KSGTAB(IS) .LT. 1)GO TO 530
DO 531 ILS = 1, KSGTAB(IS)
IF(ISGTAB(IS,ILS) .NE. IWSEG) GO TO 531
ISGTAB(IS,ILS) = ISGTAB(IS,KSGTAB(IS))
KSGTAB(IS) = KSGTAB(IS) - 1
531 CONTINUE
530 CONTINUE
C
C
C--- Repeat proceedure on remaining nodes
C
GO TO 500
C
C
C--- No connectivity remaining
C
600 CONTINUE
C---
C---
C
C--- Write output bank
C
DO 650 I = 1,NFSEG(ISM)
MASKSG(I,ISM) = KSGTAB(I)
650 CONTINUE
10 CONTINUE
RETURN
C
C--- Something horrible has happened - kill event!
C
999 CONTINUE
CALL ERRLOG(212,'W:FPSGRF: Too much confusion! Planar data off')
DO 888 ISM = 1,3
NFSEG(ISM) = 0
888 CONTINUE
RETURN
END
*