*-- Author : R. Henderson 24/10/94 SUBROUTINE FPSSGF(LSECSG) C--------------------------------------------------------------- C C Routine checks the connectivity of the found C C SECONDARY and TERTIARY segments C C and returns an optimized non-connected solution in MASKSG C 0 = accept segment , -1 = reject segment C C the difference between this routine and FPSGRF is that it C cannot assume that clusters are disconnected a priori 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--- *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--- *KEEP,FPSTSG. COMMON/FPSTSG/ NSTC(9),NFSSEG(3),NFTSEG(3) C--- *KEND. C 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) LOGICAL LSECSG,LFIRST DATA LFIRST/.TRUE./ 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 IF (LFIRST) THEN LFIRST = .FALSE. CALL FPPBIN ENDIF C C--- loop over supermodules C DO 10 ISM = 1,3 C C--- define where secondary segments start depending on whether C--- called from Secondary or tertiary segment finder. C IF(LSECSG)THEN NGSEG = NFSEG(ISM) - NFSSEG(ISM) NSTSSG = NGSEG + 1 ELSE NGSEG = NFSEG(ISM) - NFTSEG(ISM) NSTSSG = NGSEG + 1 ENDIF 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 = NSTSSG,NFSEG(ISM) DO 21 KSEG = NSTSSG,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) C C--- decode cluster planes C * IP1 = MOD(ICP1,10) ICL1 = ICP1/10 IP1 = ICP1 - ICL1*10 C--- DO 31 ID2 = 1,3 ICP2 = ISEGIN(ID2,KSEG,ISM) C C--- decode cluster planes C * IP2 = MOD(ICP2,10) ICL2 = ICP2/10 IP2 = ICP2 - ICL2*10 C C--- if planes the same loop over wires to see if same digits used C IF(IP1 .EQ. IP2 .AND. ICL1.NE.0 .AND. ICL2.NE.0)THEN IP = IP1 DO 33 IWW = 1,4 C C--- if digits are the same (and not 0) then build connection C * IF(ICL1 .EQ. 0 .OR. ICL2 .EQ. 0)GO TO 33 C IF(IABS(IDGISM(IWW,IP,ICL1)) .EQ. 0)GO TO 33 C IF(IABS(IDGISM(IWW,IP,ICL1)) .NE. 1 IABS(IDGISM(IWW,IP,ICL2)))GO TO 33 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 C 33 CONTINUE ENDIF 31 CONTINUE 30 CONTINUE 21 CONTINUE 20 CONTINUE C 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 = NSTSSG,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 = FPPROB(CHISUM,NDFSUM) C PROB1 = PROB(CHISUM,NDFSUM) ENDIF IF(ASEGIN(MXSEG,ISM) .LT. 0.001) THEN PROB2 = 0.99999 ELSE PROB2 = FPPROB(ASEGIN(MXSEG,ISM),ISEGIN(4,MXSEG,ISM)) C 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 = NSTSSG, 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 DO 530 ILLS = 1, KSGTAB(IWSEG) IS = ISGTAB(IWSEG,ILLS) 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 GOTO 530 531 CONTINUE 530 CONTINUE KSGTAB(IWSEG) = -1 C C C--- Repeat proceedure on remaining nodes C C GO TO 500 C C C--- No connectivity remaining C 600 CONTINUE C--- C C--- Write output bank C DO 650 I = NSTSSG,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(217,'W:FPSSGF: Too much confusion! Planar data off') DO 888 ISM = 1,3 NFSEG(ISM) = 0 888 CONTINUE RETURN END *