C   20/03/97 703202232  MEMBER NAME  JEOSUM1  (PATRECSR)    SHELTRAN
C   20/02/81 107091035  MEMBER NAME  BACKTR   (PATRECSR)    SHELTRAN
      SUBROUTINE BACKTR
C
C     BACKTRACING VERSION 5 (MAR 2,79)
C     MAIN PROGRAM FOR BACKTRACING
C
      IMPLICIT INTEGER*2 (H)
C
C
#include "cjdrch.for"
#include "cworkmx.for"
#include "cdsmax.for"
#include "cworkpr.for"
#include "clbpgm.for"
#include "cpatlm.for"
      DIMENSION HORD(200),HTEMP(10)
      DIMENSION LSTCL(3),LFTCL(3),NCELL(3),TANDEL(3)
      EQUIVALENCE (IBCK(1),LSTCL(1)),(IBCK(4),LFTCL(1))
      EQUIVALENCE (IBCK(7),NCELL(1)),(DBCK(1),TANDEL(1))
      EQUIVALENCE (ADWRK(486),HTEMP(1)),(ADWRK(491),HORD(1))
      DATA HPST/'PS'/
      DATA MSKCR1,MSKCR2,MSKZEN /Z100,Z200,Z80/,MSKERA/ZFFFFBFFF/
      DATA MSKLR0/Z1000/,MSKKIL/Z20000/,MSKLRA/ZFFFFEFFF/
      DATA MSKDSP,MSKERR,MSKSKP/Z2000,Z4000,Z8000/
C
C
C     PRINT 3462, (IPCL(I),I=1,HNTR)
C     PRINT 3463, (NRHT(I),I=1,HNTR)
C     PRINT 3464, (NWR1(I),I=1,HNTR)
C     PRINT 3460, (DS1(I),I=1,HNTR)
C     PRINT 3465, (SL1(I),I=1,HNTR)
C     PRINT 3466, (NWR2(I),I=1,HNTR)
C     PRINT 3467, (DS2(I),I=1,HNTR)
C     PRINT 3468, (SL2(I),I=1,HNTR)
C     PRINT 3469, (LBL(I),I=1,HNTR)
C3462  FORMAT(' CELL#',30I4)
C3463  FORMAT(' NO OF HITS',30I4)
C3464  FORMAT(' WIRE1',30I4)
C3466  FORMAT(' WIRE2',30I4)
C3469  FORMAT(' LBL  ',20(1X,Z4))
C3460  FORMAT(' DRIFT1',10F7.3)
C3465  FORMAT(' SLOPE1',10F7.3)
C3467  FORMAT(' DRIFT2',10F7.3)
C3468  FORMAT(' SLOPE2',10F7.3)
      LBPGM(10)=1
      IF(HNTR.LE.0.OR.HPRO.NE.HPST) RETURN
      FOR I=1,HNTR
      HORD(I)=I
      CFOR
      IF HNTR.GT.1
      THEN
      INR=HNTR-1
      FOR IBK=1,INR
      IBC=IBK+1
      IF IPCL(IBK).EQ.IPCL(IBC)
      THEN
      IF NWR2(IBK).GT.NWR2(IBC).AND.NWR1(IBK).GT.NWR1(IBC)
      THEN
      TEMP=HORD(IBK)
      HORD(IBK)=HORD(IBC)
      HORD(IBC)=TEMP
C     PRINT 563,HORD(IBK),HORD(IBC),IBK
C 563  FORMAT(' ((((((((',3I5)
      CIF
      CIF
      CFOR
      CIF
      IBFIT=0
      ISP=0
      ITOL1=2
      IS=0
      ZERO=0
N     INIT TRACK ELEMENT ARRAYS
      CALL SETSL(HUSE(1),0,400,ZERO)
      CALL SETSL(NTR,0,2004,ZERO)
      FOR I=1,HNTR
      IF(LAND(LBL(I),MSKKIL).NE.0) HUSE(I)=1
      CFOR
N     GET AN INITIAL TRACK STARTING IN CELL 96
      FOR ITRL=1,HNTR
N     K IS THE CURRENT TRACK POINTER
      K=HNTR-ITRL+1
      K=HORD(K)
N     HAS IT BEEN USED YET?
      IF HUSE(K).EQ.0
      THEN
      IF NTR.LT.100
      THEN
N     CONTINUATION COUNTER
      ICNT = 0
N     EXTRACT CELL NO
      ICL=IPCL(K)
      IJFLG=0
      LRING=1
N     NORMAL TOLERANCES
      ITOL=1
N     CALCULATE RING NO
      IF(ICL.GT.NCELL(1)) LRING=2
      IF(ICL.GT.NCELL(2)+NCELL(1)) LRING=3
N     ENTER ONCE FOR LRING=2
      IF LRING.LE.ITOL1
N     AND ONCE FOR LRING=1
      THEN
N     INCOMPLETE TRACKS?
      IF IS.GT.0
      THEN
N     FLAG TO INCREASE NORMAL TOLERANCES
N     ITOL NE 1 MEANS TOLERANCES HAVE BEEN INCREASED
      ITOL=2
N     REMEMBER RING,TRACK POINTERS
      INTR=NTR
      IIK=K
N     DECREASE ITOL1 COUNTER
      ITOL1=ITOL1-1
      ILRNG=LRING
N     FIX NO. OF INCOMPLETE TRACKS TO BE TRIED
      IS1=IS
N     RESET COUNTER FOR NO. OF INCOMPLETE TRACKS
      IS=0
C     PRINT 662
C 662  FORMAT('0************* LOOSER TOLERANCES *********** ')
N     LOOP OVER INCOMPLETE TRACKS
      FOR IU=1,IS1
N     EXTRACT TRACK NO.
      NTR=HSP1(IU)
N     EXTRACT TRACK ELEMENT NO.
      K=HISTR(HNREL(NTR),NTR)
      LR=1
      IF(K.LT.0) LR=-1
      K=IABS(K)
N     TURN OFF ERROR BIT
      LBL(K)=LAND(LBL(K),MSKERA)
C     CALL CHKX(2,NTR,LR,K)
N     EXTRACT CELL NO.
      ICL=IPCL(K)
N     CALCULATE RING NO
      LRING=1
      IF(ICL.GT.NCELL(1)) LRING=2
      IF(ICL.GT.NCELL(2)+NCELL(1)) LRING=3
      KRING=LRING
      IPST=1
      IJFLG=0
N     IF A PREVIOUS CONNECTION ACROSS BOUNDARY
      ITMP=HISTR(1,NTR)
N     THEN SET IPST=0
      ITMP=IABS(ITMP)
      ITMP=IPCL(ITMP)
      IF(ICL.NE.ITMP) IPST=0
C     CALL CHKX(3,ICL,ITMP,IPST)
C     PRINT 4458,NTR,K,ICL,KRING
N     DOES THIS TRACK HAVE LR=0 BIT SET?
      IF LAND(LBL(K),MSKLR0).NE.0
      THEN
      ITMP=HNREL(NTR)
N     RESET LR=0 BIT FOR THE WHOLE TRACK
      FOR IX=1,ITMP
      IJ=HISTR(IX,NTR)
      IJ=IABS(IJ)
      LBL(IJ)=LAND(LBL(IJ),MSKLRA)
      CFOR
N     IF ONLY ONE TRACK ELEMENT
      IF ITMP.EQ.1
      THEN
      LR=0
      ELSE
N     FOR MORE THAN ONE ELEMENT IN THE TRACK
      IJFLG=1
      CIF
      CIF
      PERFORM CONT1
      CFOR
      NTR=INTR
N     RESET FLAGS
      ICNT=0
      IJFLG=0
      ITOL=1
      K=IIK
      LRING=ILRNG
C     PRINT 662
      CIF
      CIF
N     IS THIS TRACK STILL UNUSED?
      IF HUSE(K).EQ.0
      THEN
N     EXTRACT CELL NO
      ICL=IPCL(K)
      KRING=LRING
N     INCREMENT TRACK NUMBER
      NTR = NTR + 1
C     PRINT 4458,NTR,K,ICL,KRING
C 4458 FORMAT('0NTR=',I4,' TRACK=',I4,' CELL=',I4,' RING=',I4)
N     GET READY TO STORE AWAY TRACK
      IKX=K
N     DETERMINE LEFT-RIGHT SOLN
      CALL LFRT(LR2)
      LR=LR2
N     IF IT IS UNKNOWN THEN SET IT TEMPORARILY
      IF(LR.EQ.0) LR=1
N     STORE THIS TRACK AWAY
      CALL BSTORE
N     RESET LR IN CASE IT WAS ZERO BEFORE
      LR=LR2
N     TRY TO FIND A CONTINUATION OF THIS TRACK
      PERFORM CONT1
      CIF
      CIF
      CIF
      CFOR
      FOR KTR=1,NTR
      ITMP=HNREL(KTR)
N     CHECK FOR DISCREPANCY BETWEEN
N     LR FROM LBL AND FROM BACKTR
      PERFORM CELLFL
      IF(KMP1.EQ.KMP2) LBL(ITKEL)=LOR(LBL(ITKEL),MSKLR0)
      IF(KMP1.EQ.KMP2) LBL(ITKEL1)=LOR(LBL(ITKEL1),MSKLR0)
C     IF(KMP1.EQ.KMP2) PRINT 457
C 457  FORMAT(' ++++++++++ LR=0 +++++++++++++++')
      FOR MG=1,ITMP
      JK=HISTR(MG,KTR)
      IKX=IABS(JK)
      CALL LFRT(LR2)
N     SET BIT 18 FOR DISCREPANCY
      IF JK*LR2.LT.0
      THEN
      IF IBKK(20).NE.0.AND.NRHT(IKX).GE.IBKK(19)
      THEN
C     HISTR(MG,KTR)=-HISTR(MG,KTR)
C     PRINT 209,IKX,KTR
C209   FORMAT('  TRACKEL ',I5,'    FROM TRACK',I5,'  FORCED LR ')
      ELSE
      LBL(IKX)=LOR(LBL(IKX),MSKDSP)
C     PRINT 453,IKX
      CIF
      CIF
C 453  FORMAT(' ====== WRONG LR FLAG ,TRACK===================== ',I4)
      CFOR
      CFOR
C     PRINT 3456,NTR
C     PRINT 3457,(HNREL(III),III=1,NTR)
C     PRINT 3458,((HISTR(KK,III),KK=1,6),III=1,NTR)
C3456  FORMAT('0NTR ',I10)
C3457  FORMAT(' NREL ',30I4)
C3458  FORMAT(' HISTR ',30I4)
C     PRINT 3469, (LBL(I),I=1,HNTR)
      IF NTR.GT.1
      THEN
      FOR KTR=1,NTR
      PERFORM CELLFL
      IR1=1
      IR2=1
      IF(KMP1.GT.NCELL(1)) IR1=2
      IF(KMP1.GT.NCELL(1)+NCELL(2)) IR1=3
      IF(KMP2.GT.NCELL(1)) IR2=2
      IF(KMP2.GT.NCELL(1)+NCELL(2)) IR2=3
      IF(IR2.EQ.1.AND.IR1.EQ.3.AND.LAND(MSKSKP,LBL(ITKEL)).EQ.0)
     *  HORD(KTR)=1
      IF(IR2.EQ.1.AND.IR1.EQ.2) HORD(KTR)=6
      IF(LAND(MSKSKP,LBL(ITKEL)).NE.0) HORD(KTR)=2
      IF(IR2.EQ.2.AND.IR1.EQ.3) HORD(KTR)=3
      IF IR1.EQ.IR2
      THEN
      IF(IR1.EQ.3) HORD(KTR)=5
      IF(IR1.EQ.2) HORD(KTR)=4
      IF(IR1.EQ.1) HORD(KTR)=7
      CIF
      CFOR
C     PRINT 286,(HORD(IO),IO=1,NTR)
C286  FORMAT(' ',30I3)
      INR=NTR-1
      FOR IBK=1,INR
      IUP=IBK+1
      FOR IBC=IUP,NTR
      IF HORD(IBC).LT.HORD(IBK)
      THEN
      CALL MVC(HTEMP(1),0,HISTR(1,IBC),0,18)
      CALL MVC(HISTR(1,IBC),0,HISTR(1,IBK),0,18)
      CALL MVC(HISTR(1,IBK),0,HTEMP(1),0,18)
      TEMP=HNREL(IBC)
      HNREL(IBC)=HNREL(IBK)
      HNREL(IBK)=TEMP
      TEMP=HORD(IBC)
      HORD(IBC)=HORD(IBK)
      HORD(IBK)=TEMP
      CIF
      CFOR
      CFOR
C     PRINT 3457,(HNREL(III),III=1,NTR)
C     PRINT 3458,((HISTR(KK,III),KK=1,6),III=1,NTR)
      IF IYBKK(11).NE.0
      THEN
      HPFRE0=HPFREE
      IMOSS=99
      CALL BAKPAK(IMOSS)
      HPFREE=HPFRE0
      CIF
      IF IYBKK(15).NE.0
      THEN
      HPFRE0=HPFREE
      IMOSS=0
      CALL BAKPAK(IMOSS)
      HPFREE=HPFRE0
      CIF
      IP0=0
N     SEARCH FOR TRACKS WITH NO ELS
      FOR I=1,100
      IF HNREL(I).EQ.0
      THEN
      IP0=I
      XFOR
      CIF
      CFOR
      IF IP0.NE.0
      THEN
N     COMPRESS BACKTR ARRAY
      FOR I=1,100
      IF IP0.LT.I
      THEN
      IF HNREL(I).NE.0
      THEN
      HNREL(IP0)=HNREL(I)
      HNREL(I)=0
      FOR J=1,9
      HISTR(J,IP0)=HISTR(J,I)
      HISTR(J,I)=0
      CFOR
      IP0=IP0+1
      CIF
      CIF
      CFOR
      CIF
      ICOUNT=0
N      HOW MANY TRACKS
      FOR I=1,100
      IF(HNREL(I).NE.0) ICOUNT=ICOUNT+1
      CFOR
N     UPDATE NTR
      NTR=ICOUNT
      CIF
      RETURN
C
C    *********************************************************
C
      PROC CONT1
C
C   THIS PROCEDURE CALLS CONT FOR EACH RING
C
      PERFORM CONT
N     IF WE WERE SUCCESSFUL THEN TRY AGAIN
      IF KRING.GT.0.AND.IRIFLG.NE.0
      THEN
      PERFORM CONT
N     TRY FOR A MATCH INTO THE LAST RING
      IF KRING.GT.0.AND.IRIFLG.NE.0
      THEN
      PERFORM CONT
      CIF
      CIF
      CPROC
C
C    *********************************************************
C
      PROC CONT
C
C   THIS PROCEDURE FINDS FIRST MATCHING TRACK IN NEXT RING,
C      CORRECTLY STORING ANY TRACKS GOING OUT THROUGH THE SIDE WALL
C
N     INCREMENT CONT COUNTER
      ICNT = ICNT + 1
N     CHECK FOR TRACK GOING THROUGH SIDEWALL(IN AN OUTWARD SENSE)
      IF ICNT.EQ.1.AND.ITOL.EQ.1
      THEN
      IUDFLG=3
      ILIM=ILOUT
      KY=K
      ICY=ICL
      IDUM=0
      WHILE IDUM.EQ.0
C     PRINT 2345,K
C2345 FORMAT(' PERFORM SIDOUT TRACK=',I4)
      ISTREL=HNREL(NTR)+1
N     TRY SIDE CONNECTION
      CALL BSIDE
      IF IRIFLG.NE.1
      THEN
      XWHILE
      CIF
      INTFLG=0
      IF HNTCEL(ICX+1)-HNTCEL(ICX).GT.1
      THEN
N     WITH A TRACK ELEMENT IN THE UPPER
      NTRLX1=HNTCEL(ICX)
N     HALF OF THE CELL
      NTRLX2=HNTCEL(ICX+1)-1
      IBFIT=-2
N     LOOP OVER ALL TRACK ELS IN THIS CELL
      FOR KK=NTRLX1,NTRLX2
N     WITH LOWER TRACK EL FIXED AT KX
      IF HUSE(KK).EQ.0
      THEN
      IW=NWR1(KK)
      IF IW.GE.ILBOT
      THEN
N     TRY CONNECTION WITHIN A CELL
      CALL  INTJN1(KK,KT,INTFLG,DT)
      IF INTFLG.NE.0
      THEN
      IKX=KK
      LR3=1
      IF(INTFLG.EQ.-1.OR.(LAND(LBL(KT),MSKCR1).NE.0.AND.LAND(LBL(IKX),
     * MSKCR1).EQ.0)) LR3=-1
      LRR=LR
      LR=-LR
      PERFORM INCRSS
      LR=LR2
      CALL BSTORE
      K=IKX
      PERFORM SRTREL
      ICL=ICX
      LR=LRR
      XFOR
      CIF
      CIF
      CIF
      CFOR
      IBFIT=0
      CIF
      IF INTFLG.EQ.0
      THEN
      PERFORM SRTREL
      XWHILE
      CIF
      CWHILE
      ICL=ICY
      K=KY
      PERFORM CROSS
      CIF
N     STARTING WIRE NR
      IW = NWR1(K)
      IUDFLG=6
      IF IW.GE.ILBOT
      THEN
N     TRY JOINING TRACK ELS WITHIN A CELL
      PERFORM INTJN
      CIF
N     CHECK FOR TRACK GOING THROUGH SIDEWALL(IN AN INWARD DIRECTION)
      ILIM=-ILIN
      IDUM=0
      WHILE IDUM.EQ.0
C     PRINT 2346,K
C2346 FORMAT(' PERFORM SIDIN TRACK=',I4)
N     TRY SIDE CONNECTION
      CALL BSIDE
N     UPDATE CELL AND TRACK POINTERS AFTER SUCCESSFUL MATCH
N     FOR INWARD GOING TRACKS ONLY
      ICL=ICX
      K=KT
      IF IRIFLG.EQ.0
      THEN
      XWHILE
      CIF
      PERFORM CROSS
N     STARTING WIRE NR
      IW = NWR1(K)
      IF IW.GE.ILBOT
      THEN
N     TRY JOINING TRACK ELS WITHIN A CELL
      PERFORM INTJN
      IF ISUFLG.EQ.0
      THEN
      XWHILE
      CIF
      ELSE
      XWHILE
      CIF
      CWHILE
N     RING CONTINUATION FLAGS PRESET
      IRIFLG = 0
      IUDFLG=0
      IF KRING.GT.1
N     CONNECT TRACK THROUGH RINGS
      THEN
      CALL RINCON
      PERFORM CROSS
      CIF
      IF IRIFLG.EQ.0
      THEN
      IF LRING.NE.1.AND.KRING.NE.LRING
      THEN
N     POSSIBLE BACKTR ERROR
      LBL(K)=LOR(LBL(K),MSKERR)
C     PRINT 6543,K
C6543 FORMAT(' ==================POSSIBLE ERROR=============,TRACK=',I5)
N     STORE AWAY INCOMPLETE TRACK NO.
      IF IS.LT.20
      THEN
      IS=IS+1
      HSP1(IS)=NTR
C     CALL CHKX(1,IS,HSP1(IS),NTR)
      CIF
      CIF
      IF IJFLG.EQ.1
      THEN
N     SEARCH TO SEE IF AMBIGUITY
      PERFORM SEAR
N     SHOULD BE REVERSED
      CIF
      IF KRING.EQ.2.AND.ITOL.EQ.1
N     STORE AWAY FOR POSSIBLE JOINING WITH
      THEN
N     AN ELEMENT IN RING 1(SKIP A RING)
      IF ISP.LT.10
      THEN
      ISP=ISP+1
      ISKP(ISP)=NTR
C     CALL CHKX(37,ISP,ISKP(ISP),NTR)
      CIF
      CIF
      IF LR.EQ.0
      THEN
C     PRINT 456
C456  FORMAT(' ========================= LR=0 =====================')
N     SET BIT 19 FOR UNDETERMINED AMBIGUITY
      LBL(K)=LOR(LBL(K),MSKLR0)
      CIF
      CIF
      IF LRING.EQ.1.AND.IRIFLG.EQ.0
      THEN
N     POSSIBLY ABLE TO JOIN AN EL
      IF LAND(LBL(K),MSKZEN).EQ.0.AND.ICNT.EQ.1.AND.ISP.GT.0
N     IN  RING 1 WITH ONE IN RING 3
      THEN
N     (I.E. NO HITS IN RING 2)
C     PRINT 893
C893  FORMAT('  $$$$$$$$$ SKIP A RING $$$$$$$$')
      JTRK=HISTR(1,NTR)
      JTRK=IABS(JTRK)
      IC1=2*IPCL(JTRK)+47
      INM=HNREL(NTR)
      INTR=NTR
C     CALL CHKX(84,JTRK,IC1,NTR)
      FOR I=1,ISP
N     ISKP(I) CONTAINS TRACK NO OF POSSIBLE
      IJ=ISKP(I)
N     TRACK IN RING 3
      IK=HISTR(HNREL(IJ),IJ)
      IC=IABS(IK)
      IK=IPCL(IC)
N     IS THE CELL CORRECT
      IF IK.EQ.IC1.OR.IK.EQ.IC1+1
N     WE HAVE A MATCH
      THEN
      IF LAND(LBL(IC),MSKERR).NE.0
      THEN
C     CALL CHKX(97,JTRK,IC,IK)
      IF ABS(ABS(SL1(IC))-ABS(SL2(JTRK))).LT.BKK(10).AND.ABS(SL1(IC))
     * .LT.BKK(11).AND. ABS(SL2(JTRK)).LT.BKK(11)
      THEN
      IXYB=0
      IF IYBKK(1).NE.0
      THEN
      PERFORM SKPFIT
      CIF
      IF IXYB.EQ.0
      THEN
      NTR=IJ
      PERFORM SETSKP
      INM=HNREL(NTR)
      FOR JZ=1,INM
      IK=HISTR(JZ,NTR)
      IK=IABS(IK)
      LBL(IK)=LOR(LBL(IK),MSKSKP)
      LBL(IK)=LAND(LBL(IK),MSKLRA)
      CFOR
      LBL(IC)=LAND(LBL(IC),MSKERA)
      HNREL(INTR)=0
      NTR=INTR-1
      XFOR
      CIF
      CIF
      CIF
      CIF
      CFOR
      CIF
      CIF
      CPROC
C
C    *************************************************************
C
C
      PROC INTJN
C
C     THIS PROC JOINS INCOMPLETE TRACK ELEMENTS WITHIN ONE CELL
C     THE CODING ASSUMES THAT THE FIRST TRACK ELEMENT FOUND
C     IS ALWAYS THE OUTERMOST ONE
C
      ISUFLG=0
N     MORE THAN ONE EL IN CELL
      IF HNTCEL(ICL+1)-HNTCEL(ICL).GT.1
      THEN
N     ZERO ITK ARRAY
      NTRLX1=HNTCEL(ICL)
      NTRLX2=HNTCEL(ICL+1)-1
      WHILE IW.GE.ILBOT
      IRL=0
      KK=K
      CALL SETSL(ITK(1,1),0,160,ZERO)
      FOR KX=NTRLX1,NTRLX2
      IF HUSE(KX).EQ.0
      THEN
N     ATTEMPT CONNECTION WITHIN CELL
      CALL INTJN1(KK,KX,INTFLG,DTMP)
      IF INTFLG.NE.0
      THEN
      PERFORM AWY
      CIF
      CIF
      CFOR
N     IF SUCCESSFUL SEE IF THERE EXISTS A
      IF IRL.GT.0
N     BETTER CONNECTION IN THIS CELL
      THEN
      IBFIT=-3
N     AT LEAST THREE ELS IN THIS CELL
      IF HNTCEL(ICL+1)-HNTCEL(ICL).GT.2
      THEN
      IRT=IRL
N     FOR EACH CONNECTION TRY ANOTHER
      FOR JK=1,IRT
N     CONNECTION WITH ALL THE OTHER ELS
      KX=ITK(JK,1)
N     IN THIS CELL
      FOR KK=NTRLX1,NTRLX2
      IF HUSE(KK).EQ.0
      THEN
      IW=NWR1(KK)
      IF IW.GE.ILBOT
      THEN
      CALL INTJN1(KK,KX,INTFLG,DTMP)
      IF INTFLG.NE.0
      THEN
      PERFORM AWY
      CIF
      CIF
      CIF
      CFOR
      CFOR
      CIF
      IBFIT=0
      CIF
      IF IRL.GT.1
      THEN
      CALL CHOOSE
      CIF
      IW=-100
      IF ITK(1,4).EQ.K
      THEN
      IKX=ITK(1,1)
N     LR3=-1 MEANS PARENT AND CANDIDATE HAVE DIFFERENT AMBIGUITIES
      LR3=1
      IF(ITK(1,3).EQ.-1.OR.(LAND(LBL(IKX),MSKCR1).NE.0
     * .AND.LAND(LBL(K),MSKCR1).EQ.0)) LR3=-1
      PERFORM INCRSS
      LR=LR2
      IPST=1
      KTR=NTR
      PERFORM CELLFL
      IF(KMP1.NE.KMP2) IPST=0
      CALL BSTORE
      K=IKX
      IW=NWR1(K)
      ISUFLG=1
      CIF
      CWHILE
      CIF
      CPROC
C
C     *******************************************************
C
      PROC AWY
C
C     THIS PROC PUTS INTERNAL TRACK EL
C     CONNECTION INFORMATION INTO THE
C     ITK ARRAY
C
      IF IRL.LT.10
      THEN
N     IRL COUNTS THE NUMBER OF CONNECTIONS
      IRL=IRL+1
N     CANDIDATE(I.E. TRACK EL IN LOWER PART OF CELL)
      ITK(IRL,1)=KX
N     WHEN -VE THIS MEANS OPP SIDES OF WIRE
      ITK(IRL,3)=INTFLG
N     PARENT(I.E. TRACK EL IN UPPER PART OF CELL)
      ITK(IRL,4)=KK
N     GOODNESS OF JOIN
      DTEMP(IRL)=DTMP
      ELSE
C     PRINT 5923
C5923 FORMAT(' TOO MANY CHOICES ')
      CIF
      CPROC
C
C     *******************************************************
C
      PROC INCRSS
C
C     THIS PROC DETERMINES WHETHER CANDIDATE AND PARENT HAVE
C     DIFFERENT AMBIGUITY
C
      CALL LFRT(LR2)
N     DETERMINE LR OF CANDIDATE AND STORE IN LR2
      IF LR2.EQ.0
      THEN
      IF LR.NE.0
      THEN
      LR2=LR*LR3
      ELSE
      LR2=LR3
      IJFLG=1
      IPST=1
      CIF
      ELSE
      IF LR.EQ.0
      THEN
      IF(LR2*LR3.EQ.-1) HISTR(1,NTR)=-HISTR(1,NTR)
      ELSE
      IF LR2.NE.LR*LR3
      THEN
C     IF(IJFLG.EQ.1) CALL COREC
C     IF(HNREL(NTR).EQ.1) HISTR(1,NTR)=-HISTR(1,NTR)
      LR2=-LR2
      CIF
      CIF
      CIF
      CPROC
C
C    *************************************************************
C
      PROC CROSS
C
C     THIS PROC CORRECTS LR FLAG WHEN A TRACK
C     CROSSES THE WIRE PLANE
C
      IF IRIFLG.EQ.1
      THEN
N     CORRECT LR FLAG FOR SUCCESSFUL SIDE CONNECTION
      IF(IUDFLG.EQ.6) LR=-LR
      IF LAND(LBL(K),MSKCR1).NE.0.AND.LAND(LBL(K),MSKCR2).EQ.0
      THEN
N     CHANGE THE CURRENT LR FLAG
      LR=-LR
N     CHANGE THE AMBIGUITY OF PREVIOUSLY STORED TRACK
      HISTR(HNREL(NTR),NTR)=-HISTR(HNREL(NTR),NTR)
C     PRINT 2231,K
C2231 FORMAT(' CHANGE AMBIGUITY OF TRACK BECAUSE OF WIRE CROSSING',I4)
      CIF
      CIF
      CPROC
C
C     *************************************************************
C
      PROC SEAR
C
C     THIS PROC IS CALLED AT THE END OF
C     CONNECTING A TRACK AND IT REMAINS WITH IJFLG=1
C     (I.E. THE AMBIGUITY HAS NOT BEEN RESOLVED AND
C     AND THE TRACK HAS BEEN STORED AWAY WITH ARBITRARY
C     AMBIGUITY) (E.G. LR=0 IN RING 2 AND THEN CONNECTED
C     TO ATRACK IN IN RING 1)
C     IT SEARCHES THROUGH THE STORED ELEMENTS
C     OF THIS TRACK AND IF IT FINDS
C     A DISCREPANCY BETWEEN THE STORED AMBIGUITY
C     AND THE ONE FROM WIRE STAGGERING IT REVERSES
C     THE AMBIGUITY FOR ALL STORED ELS AND RETURNS
C
      ITMP=HNREL(NTR)
      FOR I=1,ITMP
      JK=HISTR(I,NTR)
      IKX=IABS(JK)
      CALL LFRT(LR2)
      IF LR2.NE.0
      THEN
N     REVERSED STORED AMBIGUITIES
      IF(LR2*JK.LT.0) CALL COREC
      XFOR
      CIF
      CFOR
C     PRINT 97
C97   FORMAT(' &&&&&&&&&&&& LR=0 &&&&&&&&&&&&')
      FOR I=1,ITMP
N     ALL THE STORED ELS ARE ZERO SO SET BIT 19
      JK=HISTR(I,NTR)
      IKX=IABS(JK)
      LBL(IKX)=LOR(LBL(IKX),MSKLR0)
      CFOR
      CPROC
C
C     *******************************************************
C
      PROC SRTREL
C
C
      I9=HNREL(NTR)
      FOR IO=ISTREL,I9
      ITEM=HISTR(IO,NTR)
      J9=IO-2+1
      FOR JO=1,J9
      HISTR(IO-JO+1,NTR)=HISTR(IO-JO,NTR)
      CFOR
      HISTR(1,NTR)=ITEM
      CFOR
      CPROC
C
      PROC CELLFL
C
C
C
      KMP1=HISTR(1,KTR)
      KMP1=IABS(KMP1)
      ITKEL1=KMP1
      KMP1=IPCL(KMP1)
      KMP2=HISTR(HNREL(KTR),KTR)
      KMP2=IABS(KMP2)
      ITKEL=KMP2
      KMP2=IPCL(KMP2)
      CPROC
C
      PROC SKPFIT
C
C
C
      IXYB=0
      NTR=IJ
      IBCD=HNREL(NTR)
      CALL MVC(HTEMP(1),0,HISTR(1,NTR),0,18)
      PERFORM SETSKP
C     PRINT 36
C36   FORMAT('0  SKIP-RING FIT  ')
      IAB=HNREL(NTR)
C     PRINT 37,NTR,(HISTR(IR,NTR),IR=1,IAB)
C37   FORMAT(' NTR, HISTR ',11I5)
C     PRINT 38,(HTEMP(IR),IR=1,9)
C38   FORMAT(' OLD HISTR ',9I5)
      CALL BAKFIT(IXYB,4)
      CALL MVC(HISTR(1,NTR),0,HTEMP(1),0,18)
      HNREL(NTR)=IBCD
      NTR=INTR
      CPROC
C
      PROC SETSKP
C
C
      IJLR=LR
      FOR JZ=1,INM
      IKX=HISTR(JZ,INTR)
      IF IJLR.EQ.0.OR.IJFLG.NE.0
      THEN
      LR=1
      IF(LAND(IK,1).EQ.1) LR=-1
C     CALL CHKX(91,LR,IK,LR2)
      ELSE
      LR=ISIGN(1,IKX)
      CIF
      IKX=IABS(IKX)
      CALL BSTORE
      CFOR
      LR=IJLR
      CPROC
      END
C   30/10/79 107101038  MEMBER NAME  BAKFIT1  (PATRECSR)    SHELTRAN
      SUBROUTINE BAKFIT(IB,ITYP)
C
C       ITYP=1 FOR INT JOIN
C       ITYP=2 FOR RING CON
C       ITYP=3 FOR SIDE CON
C       ITYP=4 FOR SKIP-RING CON
C
      IMPLICIT INTEGER*2 (H)
C
#include "cpatlm.for"
#include "cworkeq.for"
#include "cworkpr.for"
C
       DIMENSION CHITR(9),HITIN(10)
       EQUIVALENCE (ADWRK(91),CHITR(1)),(HITIN(1),ADWRK(86))
C
       IB=0
       IREM=IXYF(1)
       IXYF(1)=LOR(IXYF(1),9)
       HPOLD=HPFREE
       IBTRK=NTR
       CALL FXYZ(IBTRK)
       HPTR0=HPFREE
       HPTR9=HPTR0+49
       HLDTR=50
      HPFREE=HPTR9+1
      IF HPFREE.LE.HPLAST
      THEN
      CALL XYFIT
      RES=CHITR(HNREL(NTR))
      RMS=WRK(HPTR0+22)
      NTOT=IWRK(HPTR0+23)
      NHT=HITIN(HNREL(NTR))
      IF(NHT.GT.0) RES=RES/FLOAT(NHT)
      IF(ITYP.EQ.1.AND.(RMS.GT.YBKK(2).OR.RES.GT.YBKK(3))) IB=-1
      IF(ITYP.EQ.2.AND.(RMS.GT.YBKK(4).OR.RES.GT.YBKK(5))) IB=-1
      IF(ITYP.EQ.3.AND.(RMS.GT.YBKK(6).OR.RES.GT.YBKK(7))) IB=-1
      IF(ITYP.EQ.4.AND.RMS.GT.YBKK(8)) IB=-1
C     IF(ITYP.EQ.4) PRINT 389,RMS,RES,NTOT
C389  FORMAT('0  RMS(ALL HITS)',F10.5,'  RES(TRACKEL) ',F10.5,'  HITS
C     USED IN FIT ',I5)
C     CALL PCWORK(0,0,0,1,0)
      ELSE
      PRINT 33
 33   FORMAT(' +++++++++  NOT ENOUGH SPACE IN CWORK  +++++++')
      CIF
      IXYF(1)=IREM
      HPFREE=HPOLD
      RETURN
      END
C   08/04/81 107101020  MEMBER NAME  BAKPAK1  (PATRECSR)    SHELTRAN
      SUBROUTINE BAKPAK(ICHNG)
C
C     THIS SUB LOOPS OVER BACKTRACE TRACKS TRYING ALL POSSIBLE
C     CONNECTIONS IF TRACKS BEGIN AND END CLOSE TO ONE ANOTHER
C     THE CONNECTION IS ACCEPTED IF THE RMS IS LT RMSLIM.
C     CONNECTIONS WHERE THE RMS IS BETWEEN RMSLI1 AND RMSLI2
C     ARE MARKED AND THIS PARENT TRACK IS TRIED AGAIN AT THE
C     END (EXCEPT ON THE FIRST ENTRY TO BAKPAK).
C
C     FIRST ENTRY TO BAKPAK IS SIGNALLED BY ICHNG=99
C     SUBSEQUENT ENTRIES BY ICHNG=0
C
      IMPLICIT INTEGER*2 (H)
C
      LOGICAL DEADCL
C
#include "cpatlm.for"
#include "cdata.for"
#include "cworkeq.for"
#include "cworkpr.for"
      COMMON/CHEADR/HEAD(17),HRUN,HEV
      COMMON/CADMIN/IEVTP,NREC,NRWRIT,NRERR
C     HTRK IS TRACK NO IN PATR BANK OF CORRESPONDING BACKTR TRACK
C     COMMON/CBKPAT/HTRK(100)
C
N      HREP STORES PARENT TRACK NO TO TRY AGAIN
       DIMENSION HTEMP(9),MAXC(3),HREP(10)
       EQUIVALENCE (RMSLI1,XBKK(33)),(IDLIM,IYBKK(10))
       EQUIVALENCE (JJPR,IXBKK(38))
       DATA MSKLRL /ZFFFFEFFF/,MAXC/24,24,48/
C
C     IPPATR=IDATA(IBLN('PATR'))
      CALL SETSL(HREP(1),0,20,0)
      RMSLI2=XBKK(34)
      IENTER=ICHNG
      IF(ICHNG.EQ.99) RMSLI2=0.
C     LDTRK=IDATA(IPPATR+3)
C     IPPATR=IDATA(IPPATR+1)+IPPATR
      IREM=IXYF(1)
      IXYF(1)=9 + 32
      ICHNG=0
      ILT=0
      IRPKNT=0
      RMSLIM=RMSLI1
      FOR JKREP=1,2
      IKXKTR=0
      REPEAT
N     EXTRACT PARENT TRACK NO
      IKXKTR=IKXKTR+1
      KTR=IKXKTR
      IF JKREP.EQ.2
      THEN
N     FOR SECOND PASS TRACK NOS ARE IN HREP
      ILT=ILT+1
      IF ILT.LE.ITREP
      THEN
      KTR=HREP(ILT)
      ELSE
      XREPEAT
      CIF
      CIF
      IF HNREL(KTR).NE.0
      THEN
       INUM=HNREL(KTR)
      IXX=KTR
      PERFORM CELLAN
      IF IR1.GT.1.OR.IR2.LT.3
      THEN
N     RING NO OF INNER MOST TRACKEL
      IRNG1=IR1
N     RING NO OF OUTER MOST TRACKEL
      IRNG2=IR2
      ICL1=KMP2
      LR1=0
N     IF TRACK IS IN MORE THAN ONE CELL FREEZE LR
      IF(KMP1.NE.KMP2) LR1=1
C     IF(LAND(JJPR,64).NE.0)WRITE(6,98) KTR,KMP1,KMP2,IR1
C98   FORMAT('0TRACK NO',I5,' CELL 1  CELL 2',2I5,'   ENDS IN RING',I5)
      RMSOLD=9999.
N     LOOP OVER CAND TRACKS
      FOR JTR=1,100
      IF HNREL(JTR).NE.0.AND.JTR.NE.KTR
      THEN
      IXX=JTR
      PERFORM CELLAN
N     TRY CONNECTION IF CAND IS IN NEXT RING OR IS IS IN
      IF IR2.LT.IRNG1.OR.KMP1.NE.KMP2.AND.IR2.LE.IRNG1
N     SAME RING BUT HAS MORE THAN ONE CELL
      THEN
      IPTRK=HISTR(1,JTR)
      IPTRK=IABS(IPTRK)
      ISPEC=0
      IF(HNREL(JTR).EQ.1.AND.NRHT(IPTRK).LT.5.AND.IR2.EQ.1) ISPEC=1
N     DUMMY
      IF HNREL(JTR).GT.1.OR.NRHT(IPTRK).GT.0.OR.IR2.GT.1
      THEN
C     IF(LAND(JJPR,64).NE.0)WRITE(6,99) JTR,KMP1,KMP2,IR2
C99   FORMAT(' CAND TRACK',I5,' CELL 1 CELL 2',2I5,' BEGINS IN RING',I5)
      ICL2=KMP1
      IF(IRNG1.EQ.3) ICL=(ICL1+1)/2
      IF(IRNG1.EQ.2) ICL=ICL1-24
      IF(IRNG1.EQ.3.AND.IR2.EQ.1) ICL=ICL-24
      IF(IR2.EQ.IRNG1) ICL=ICL1
N     COMPUTE CELL DIF BETWEEN CAND AND PARENT
      IDIF=IABS(ICL-ICL2)
      IF IDIF.GT.MAXC(IR2)/2
      THEN
      IF ICL.GT.ICL2
      THEN
       ICL=ICL-MAXC(IR2)
      IDIF=IABS(ICL-ICL2)
      ELSE
       ICL2=ICL2-MAXC(IR2)
      IDIF=IABS(ICL-ICL2)
      CIF
      CIF
N     REFUSE SKIP RING CONN FOR LT 8 HITS IN FIRST PASS
      IF(IENTER.EQ.99.AND.IABS(IR2-IRNG1).GT.1.AND.IXBKK(35).EQ.0
N     UNLESS CALL PATROL FLAG IS ON
     % .AND.HNREL(JTR).EQ.1.AND.NRHT(IPTRK).LT.8) IDIF=99
      LR2=0
      IF(KMP1.NE.KMP2) LR2=1
C     IF(LAND(JJPR,64).NE.0)WRITE(6,97) ICL1,ICL,ICL2,IDIF
C 97  FORMAT(' PAR CELL',I5,'  EX CELL',I5,' CAND CELL',I5,'DIFF',I5)
      IF IDIF.LE.IDLIM
      THEN
      IAB=HNREL(JTR)
      CALL MVC(HTEMP(1),0,HISTR(1,KTR),0,18)
C     IF(LAND(JJPR,64).NE.0)WRITE(6,96) (HISTR(IP,KTR),IP=1,9)
C96   FORMAT('  ORIG HISTR',9I5)
C     IF(LAND(JJPR,64).NE.0)WRITE(6,89) (HISTR(IP,JTR),IP=1,9)
C89   FORMAT('   CAND HISTR  ',9I5)
      LRP=1
      LRD=1
      FOR IKOUNT=1,4
      IF IKOUNT.GE.2
      THEN
      IF(LR1.NE.0.AND.LR2.NE.0) XFOR
      IF LR1.NE.0.AND.LR2.EQ.0
      THEN
      IF IKOUNT.EQ.2
      THEN
      LRD=-LRD
      ELSE
      XFOR
      CIF
      CIF
      IF LR1.EQ.0.AND.LR2.NE.0
      THEN
      IF IKOUNT.EQ.2
      THEN
      LRP=-1
      ELSE
      XFOR
      CIF
      CIF
      IF LR1.EQ.0.AND.LR2.EQ.0
      THEN
      IF(IKOUNT.EQ.2) LRD=-LRD
      IF(IKOUNT.EQ.3) LRP=-LRP
      IF(IKOUNT.EQ.4) LRD=-LRD
      CIF
      CIF
C     IF(LAND(JJPR,64).NE.0)WRITE(6,95) LRP,LRD
C 95  FORMAT('  LR (PARENT) ',I5,'    LR (DAUGHTER)   ',I5)
      FOR JJ=1,INUM
      HISTR(JJ,KTR)=HISTR(JJ,KTR)*LRP
      CFOR
      PERFORM ADD
C     IF(LAND(JJPR,64).NE.0)WRITE(6,93) (HISTR(IP,KTR),IP=1,9)
C93   FORMAT('  NEW HISTR',9I5)
C     IAB=HNREL(NTR)
C     IF(IXXB.NE.0) PRINT 37,KX,NTR,(HISTR(IR,NTR),IR=1,IAB)
C     IF(IXXB.NE.0) PRINT 38,(HTEMP(IR),IR=1,9)
C37   FORMAT(' KX, NTR,HISTR :',11I5)
C38   FORMAT(' OLD HISTR :',9I5)
      IF IEXIT.EQ.99.OR.IEXIT.EQ.98
      THEN
      CALL MVC(HISTR(1,KTR),0,HTEMP(1),0,18)
C     IF(LAND(JJPR,64).NE.0) WRITE(6,78) KTR,JTR
C78   FORMAT('  *** EXIT TOO MANY ELEMENTS, TRACKS',2I5)
      XFOR
      CIF
N     IF CAND AND PARENT OVERLAP IN ONE RING AND HAD NO
      IF JCOUNT.EQ.INUM+IAB.AND.IR2.EQ.IRNG1
N     TRCAKELS IN COMMON , CHECK NO OF LAYERS BETWEEN BEGINING
      THEN
N     OF ONE TRACK AND END OF THE OTHER
      ML1=INUM
      ML1=HISTR(ML1,KTR)
      ML1=IABS(ML1)
      ML1=NWR1(ML1)
      ML2=HISTR(1,JTR)
      ML2=IABS(ML2)
      ML2=NWR2(ML2)
      IF ML2-ML1.GE.IBKK(7)
      THEN
      CALL MVC(HISTR(1,KTR),0,HTEMP(1),0,18)
      IF(LAND(JJPR,64).NE.0) PRINT 295,ML1,ML2
 295  FORMAT('   LAYER DIFFERENCE IS TOO LARGE',2I5)
      XFOR
      CIF
      CIF
       HPOLD=HPFREE
       CALL FXYZ(KTR)
       HPTR0=HPFREE
       HPTR9=HPTR0+49
       HLDTR=50
      HPFREE=HPTR9+1
      IF HPFREE.LE.HPLAST
      THEN
      CALL XYFIT
      RMS=WRK(HPTR0+22)
C     IF(LAND(JJPR,64).NE.0)WRITE(6,92) RMS
C92   FORMAT('  ******* RMS  *********',F10.5)
N     ON FIRST PASS MARK PARENT TRACKS WHICH HAVE A CONNECTION
      IF RMS.LT.RMSLI2.AND.RMS.GT.RMSLIM.AND.JKREP.EQ.1.AND.ISPEC.EQ.0
N    BETWEEN RMSLI1 AND RMSLI2
     & .AND.(HREP(IRPKNT).NE.KTR.AND.IRPKNT.GT.0.OR.IRPKNT.EQ.0)
     * .AND.IENTER.NE.99
      THEN
      IF IRPKNT.LT.10
      THEN
      IRPKNT=IRPKNT+1
      HREP(IRPKNT)=KTR
C     IF(LAND(JJPR,64).NE.0) WRITE(6,843) KTR
C843  FORMAT('  UNLESS THIS TRACK IS SUCCESSFUL MUST GO AGAINSTARTING
C     WITH TRACK',I5)
      CIF
      CIF
C     IF RMS.LT.1.8.AND.RMS.GT.RMSLI2.AND.JKREP.EQ.1.AND.IDIF.EQ.0
C    % .AND.IR2.EQ.IRNG1.AND.(IRNG1.NE.IR1.OR.IRNG2.NE.IR2)
C     THEN
C     PRINT 385,(HISTR(IP,KTR),IP=1,9)
C     PRINT 385,(HISTR(IP,JTR),IP=1,9)
C385  FORMAT('   ',9I5)
C     IPTRK1=HTRK(KTR)
C     PRINT 624,IPTRK1
C624  FORMAT('   TRACK NO IN TRACK BANK ',I5)
C     IF(IPTRK1.NE.IDATA(IPPATR+LDTRK*(IPTRK1-1)+1))WRITE(6,765)
C765  FORMAT(' @@@@@@ ERROR IN TRACK BANK LOCATION')
C     IPTRK1=IPPATR+LDTRK*(IPTRK1-1)
C     CRV1=ADATA(IPTRK1+25)
C     RMS1=ADATA(IPTRK1+23)
C     IPTRK2=HTRK(JTR)
C     PRINT 624,IPTRK2
C     IF(IPTRK2.NE.IDATA(IPPATR+LDTRK*(IPTRK2-1)+1))WRITE(6,765)
C     IPTRK2=IPPATR+LDTRK*(IPTRK2-1)
C     CRV2=ADATA(IPTRK2+25)
C     RMS2=ADATA(IPTRK2+23)
C     PRINT 913,CRV1,CRV2,RMS1,RMS2
C913  FORMAT('  CRV   RMS  ',4F10.7)
C     CIF
N     SKIP RING CONNECTION
      IF IRNG1.EQ.3.AND.IR2.EQ.1.AND.IXBKK(35).NE.0
     % .AND.RMS.LT.RMSLIM.AND.RMS.LT.RMSOLD
      THEN
      IPREM1=IGFP(1)
      IPREM2=IGFP(6)
      IPREM3=IGFP(9)
       PREM4=GFP(2)
       PREM5=GFP(14)
      IGFP(6)=17
      IGFP(9)=0
      GFP(2)=999999.
      GFP(14)=999999.
      IGFP(1)=LOR(IGFP(1),1)
      RMIN=150.
      RMAX=850.
      CALL PATROL(RMIN,RMAX)
C     CALL PCWORK(0,0,0,1,0)
      IFOUND=0
      FOR ICNT=HPHT0,HPHT9,HLDHT
      IF(IWRK(ICNT+10).LT.2.AND.IWRK(ICNT+12).EQ.2) IFOUND=IFOUND+1
      CFOR
C     WRITE(6,206) IFOUND
C206  FORMAT('  PATROL FOUND ',I5,'       HITS')
C     WRITE(6,93) (HISTR(IP,KTR),IP=1,9)
      IC1=ICL2+24
      IC2=(ICL1+1)/2
      NRUN=HRUN
C     WRITE(6,773) NRUN,RMS
C773  FORMAT(' RUN ,RMS ',I10,F10.5)
C     WRITE(6,298) IDIF,ICL,ICL1,ICL2,IC1,IC2
C298  FORMAT(' IDIF,ICL,ICL1,ICL2,IC1,IC2 ',6I5)
      NCL1=HNTCEL(IC1+1)-HNTCEL(IC1)
      NCL2=HNTCEL(IC2+1)-HNTCEL(IC2)
      IF(IDIF.EQ.0.AND.IFOUND.LT.IYBKK(9).AND..NOT.(DEADCL(IC1,NRUN)
     $.AND.NCL1.EQ.0.OR.DEADCL(IC2,NRUN).AND.NCL2.EQ.0)) RMS=99.
C     IF(IDIF.EQ.0.AND.IFOUND.LT.IYBKK(9).AND.(DEADCL(IC1,NRUN)
C    $.AND.NCL1.EQ.0.OR.DEADCL(IC2,NRUN).AND.NCL2.EQ.0)) WRITE(6,65)
      IF(IDIF.EQ.1.AND.IFOUND.LT.IYBKK(16).AND..NOT.(DEADCL(IC1,NRUN)
     $.AND.NCL1.EQ.0.OR.DEADCL(IC2,NRUN).AND.NCL2.EQ.0)) RMS=99.
C     IF(IDIF.EQ.1.AND.IFOUND.LT.IYBKK(16).AND.(DEADCL(IC1,NRUN)
C    $.AND.NCL1.EQ.0.OR.DEADCL(IC2,NRUN).AND.NCL2.EQ.0)) WRITE(6,65)
C 65  FORMAT('   &&&&&&&&^^^^^^^^^^^ DIFF')
      IGFP(1)=IPREM1
      IGFP(6)=IPREM2
      IGFP(9)=IPREM3
       GFP(2)=PREM4
       GFP(14)=PREM5
      CIF
      IF RMS.LT.RMSLIM.AND.RMS.LT.RMSOLD
      THEN
      IF ISPEC.EQ.0.OR.ISPEC.EQ.1.AND.RMS.LT.RMSLI1
      THEN
      RMSOLD=RMS
      ITRACK=JTR
      LRDFIN=LRD
      LRPFIN=LRP
C     WRITE(6,91)
C91   FORMAT('  %%%%%%%% SUCCESS  %%%%%%%%%%%')
      CIF
      CIF
      ELSE
      PRINT 33,HRUN,HEV,NREC,KTR,JTR
 33   FORMAT(' +++++++++  NOT ENOUGH SPACE IN CWORK  +++++++(BAKPAK)',
     & 5I10)
      CIF
      HPFREE=HPOLD
      CALL MVC(HISTR(1,KTR),0,HTEMP(1),0,18)
      CFOR
      HNREL(KTR)=INUM
      CIF
      CIF
      CIF
      CIF
      CFOR
      IF RMSOLD.NE.9999.
      THEN
      FOR JJ=1,INUM
      HISTR(JJ,KTR)=HISTR(JJ,KTR)*LRPFIN
      CFOR
N     CANCEL NEED TO REPEAT WITH THIS TRACK
      IF HREP(IRPKNT).EQ.KTR.AND.JKREP.EQ.1
      THEN
      IKXKTR=IKXKTR-1
      HREP(IRPKNT)=0
      IRPKNT=IRPKNT-1
      CIF
      IAB=HNREL(ITRACK)
      JTR=ITRACK
      LRD=LRDFIN
      PERFORM ADD
      FOR IY=1,JCOUNT
      ITC=HISTR(IY,KTR)
      ITC=IABS(ITC)
      LBL(ITC)=LAND(LBL(ITC),MSKLRL)
      CFOR
      IF(IEXIT.EQ.99.OR.IEXIT.EQ.98) WRITE(6,769)
 769  FORMAT('  ********* ERROR IN BAKPAK  EXIT ****** ')
      HNREL(ITRACK)=0
      ICHNG=1
C     IF(LAND(JJPR,64).NE.0)WRITE(6,57) KTR
C57   FORMAT('     FINAL SELECTION     TRACK',I5)
C     IF(LAND(JJPR,64).NE.0)WRITE(6,56) RMSOLD,ITRACK,LRPFIN,LRDFIN
C56   FORMAT('  RMS ',F10.5,'  TRACK ',I5,'  LRP,LRD  ',2I5)
C     IF(LAND(JJPR,64).NE.0)WRITE(6,55)(HISTR(IP,KTR),IP=1,9),HNREL(KTR)
C55   FORMAT(' SELECTED HISTR ',9I5,' NO OF ELS',I5)
      CIF
      CIF
      CIF
      UNTIL IKXKTR.GE.100
      IF HREP(1).EQ.0
      THEN
      XFOR
      ELSE
      ITREP=IRPKNT
      RMSLIM=RMSLI2
C     IF(LAND(JJPR,64).NE.0) WRITE(6,265) ITREP,HREP
C265  FORMAT('0  START AGAIN &&&&&&&&&&& WITH',I5,'  TRACKS=',10I5)
      CIF
      CFOR
      IXYF(1)=IREM
      IBTRK=NTR
      NTR=100
C     CALL TRLORD
      NTR=IBTRK
      RETURN
      PROC CELLAN
      IR1=1
      IR2=1
      KMP1=HISTR(1,IXX)
      KMP1=IABS(KMP1)
      KMP1=IPCL(KMP1)
      KMP2=HISTR(HNREL(IXX),IXX)
      KMP2=IABS(KMP2)
      KMP2=IPCL(KMP2)
      IF(KMP2.GT.24) IR1=2
      IF(KMP2.GT.48) IR1=3
      IF(KMP1.GT.24) IR2=2
      IF(KMP1.GT.48) IR2=3
      CPROC
      PROC ADD
C
C     THIS PROC ADDS TWO BACKTR ARRAYS TOGETHER
C     DELETING COMMON TRACK ELS
C
      IEXIT=0
      JCOUNT=INUM
      FOR KK=1,IAB
      ISIG=0
      ITP2=HISTR(KK,JTR)
      ITP2=IABS(ITP2)
      FOR IJT=1,INUM
      ITP1=HISTR(IJT,KTR)
      IF IABS(ITP1).EQ.ITP2
      THEN
      ISIG=1
      XFOR
      CIF
      CFOR
      IF ISIG.EQ.0
      THEN
      JCOUNT=JCOUNT+1
      IF JCOUNT.LE.9
      THEN
      HISTR(JCOUNT,KTR)=HISTR(KK,JTR)*LRD
      ELSE
      IEXIT=99
      XFOR
      CIF
      CIF
      CFOR
C     IF(LAND(JJPR,64).NE.0.AND.JCOUNT.NE.INUM+IAB)WRITE(6,387)
C    & JTR,KTR
C 387 FORMAT('  ********* SOME TRACKELS DELETED IN JOINING TRACKS',2I5)
      HNREL(KTR)=JCOUNT
      IF JCOUNT.EQ.INUM.OR.JCOUNT.EQ.IAB
      THEN
      IEXIT=98
C     IF(LAND(JJPR,64).NE.0) WRITE(6,774)
C 774 FORMAT('  %%%% PHONY FIT')
      CIF
      CPROC
      END
C   30/10/79 107101023  MEMBER NAME  BSIDE1   (PATRECSR)    SHELTRAN
      SUBROUTINE BSIDE
C
C     BACKTRACING VERSION 5 (MAR 2,79)
C   THIS PROCEDURE MATCHES AND STORES TRACKS GOING
C       THROUGH THE CELL SIDEWALLS
C
      IMPLICIT INTEGER*2 (H)
C
#include "cworkpr.for"
#include "cjdrch.for"
#include "cdsmax.for"
#include "cpatlm.for"
#include "cworkmx.for"
      DIMENSION LSTCL(3),LFTCL(3),NCELL(3),TANDEL(3)
      EQUIVALENCE (IBCK(1),LSTCL(1)),(IBCK(4),LFTCL(1))
      EQUIVALENCE (IBCK(7),NCELL(1)),(DBCK(1),TANDEL(1))
      DATA MSKCR1 /Z100/
C
C
      LRCORN=0
N     TEMPORARY TRACK NUMBER
      KT=K
      IRIFLG=0
      IWT=ILIM-1
N     REMEMBER CURRENT CELL
      ICX=ICL
C     CALL CHKX(58,KT,IWT,ICX)
N     'WHILE' ALLOWS FOR POSSIBILITY OF SEVERAL TRACKS
N     IN SUCCESSION PASSING THROUGH SIDEWALL
      WHILE IWT.LT.ILIM
N     DRIFT SPACE
      DS=TRKAR(KT,10-IUDFLG)
      IW=ITRKAR(KT,9-IUDFLG)
      IKX=0
N     SLOPE
      A=TRKAR(KT,11-IUDFLG)
C     CALL CHKX(27,KT,IW,IW)
C     CALL CHKX(-27,DS,A,A)
      PERFORM PAR
N     TRY A SOLN ON RIGHT SIDE
N     GET CELL OF CANDIDATE TRACK
      ICT=ICX+1
      IF(ICT.GT.LSTCL(KRING)) ICT=ICT-NCELL(KRING)
C     CALL CHKX(57,IPER,ICT,ICX)
C     CALL CHKX(58,NCELL(1),NCELL(2),NCELL(3))
C     CALL CHKX(59,LSTCL(1),LSTCL(2),LSTCL(3))
      LR1=2
      IF IPER.GE.0
      THEN
C     PRINT 6677
C6677 FORMAT(' TRY A SOLN ON RIGHT SIDE')
N     TRACKS IN THIS CELL?
      IF HNTCEL(ICT+1)-HNTCEL(ICT).GT.0
      THEN
      PERFORM SIDCEL
      IF LR.EQ.1.OR.IMARK.EQ.0.OR.LR.EQ.0
      THEN
      CALL SIDE1
      ELSE
      IWT=ILIM
      CIF
      ELSE
      IWT=ILIM
      CIF
      ELSE
      IWT=ILIM
C     PRINT 589,KT
C589  FORMAT('  RIGHT SOLN REFUSED FOR TRACK',I5)
      CIF
N     A SUCCESSFUL CONNECTION
      IF IKX.NE.0
      THEN
      IF LR.EQ.-1
      THEN
N     CORRECT STORED TRACK
      CALL COREC
      CIF
N     SET CORRECT LR FLAG
      LR=-1
N     RESET IWT
      IWT=HMCH(ITRKAR(IKX,9-IUDFLG)+1,KRING,2)
      IF(IUDFLG.EQ.6) IWT=-IWT
N     STORE IT AWAY
      CALL BSTORE
      IPST=0
N     RESET FOR ANOTHER GO
      LR=1
      IJFLG=0
      CIF
N     TRY SOLN FOR LR=-1 (IF NO PREVIOUUS LR=1 SOLN)
      IF IKX.EQ.0
      THEN
N     GET CELL NUMBER OF CANDIDATE TRACK
      ICT=ICX-1
      IF(ICT.LT.LFTCL(KRING)) ICT=ICT+NCELL(KRING)
      LR1=1
      IF IPER.LE.0
      THEN
C     PRINT 6678
C6678 FORMAT(' TRY A SOLN ON LEFT SIDE')
N     TRACKS IN THIS CELL?
      IF HNTCEL(ICT+1)-HNTCEL(ICT).GT.0
      THEN
      PERFORM SIDCEL
      IF LR.EQ.-1.OR.IMARK.EQ.0.OR.LR.EQ.0
      THEN
      CALL SIDE1
      ELSE
      IWT=ILIM
      CIF
      ELSE
      IWT=ILIM
      CIF
      ELSE
      IWT=ILIM
C     PRINT 588,KT
C588  FORMAT('  LEFT SOLN REFUSED FOR TRACK',I5)
      CIF
N     A SUCCESSFUL CONNECTION
      IF IKX.NE.0
      THEN
      IF LR.EQ.0
      THEN
N     CORRECT THE LR FLAG FOR THE FIRST TRACK STORED
      HISTR(1,NTR)=-HISTR(1,NTR)
      CIF
      IF LR.EQ.1
      THEN
N      CORRECT STORED TRACKS
      CALL COREC
      CIF
      LR=1
N     RESET IWT
      IWT=HMCH(ITRKAR(IKX,9-IUDFLG)+1,KRING,1)
      IF(IUDFLG.EQ.6) IWT=-IWT
N     STORE THE MATCHING TRACK AWAY
      CALL BSTORE
      IPST=0
      IJFLG=0
N    RESET FOR ANOTHER GO
      LR=-1
      CIF
      ELSE
N     FAILURE
      IWT=ILIM
      CIF
      CWHILE
      RETURN
C
C
C    **********************************************************
C
C
      PROC SIDCEL
C
C     THIS PROC SETS IMARK=1 IF TRACK CROSSES
C     FROM RING 3 TO 2 OR IF CROSSES CORNER
C
C
      IMARK=0
      KC1=HISTR(1,NTR)
      KC1=IPCL(IABS(KC1))
      KC2=HISTR(HNREL(NTR),NTR)
      KC2=IPCL(IABS(KC2))
C     CALL CHKX(38,KC1,KC2,KC2)
      IF KC1.NE.KC2
      THEN
      IF KC1.LE.48
      THEN
      IF(KC1-KC2.NE.24) IMARK=1
      ELSE
      IMARK=1
      CIF
      CIF
      CPROC
C
C     **********************************************************
C
      PROC PAR
C
C     THIS PROC DETERMINES WHICH SIDCON FOR TRACK KT IS CONSISTENT
C     WITH LR FLAG IN MIDOUT
C     IPER=0   :   BOTH
C     IPER=1   :   RIGHT
C     IPER=-1  :   LEFT
C
      IPER=0
      IF IBKK(20).NE.0.AND.LR.NE.0.AND.NRHT(KT).GE.IBKK(19)
      THEN
      IPER=LR
      IF(LAND(MSKCR1,LBL(KT)).NE.0.AND.IUDFLG.EQ.3) IPER=-IPER
      CIF
      CPROC
      END
C   30/10/79 107101030  MEMBER NAME  BSTORE1  (PATRECSR)    SHELTRAN
      SUBROUTINE BSTORE
C
C     THIS SUB STORES FOUND TRACK
C
      IMPLICIT INTEGER*2 (H)
#include "cworkpr.for"
#include "cworkmx.for"
#include "cpatlm.for"
      IF(HNREL(NTR).EQ.9) RETURN
      HNREL(NTR) = HNREL(NTR) + 1
      KR = HNREL(NTR)
      HISTR(KR,NTR) = IKX*LR
      HUSE(IKX) = 1
      RETURN
      END
      FUNCTION SLCOR(SL,LRS)
C
C     THIS SUB TRANSFORMS SLOPES BECAUSE OF LORENTZ ANGLE
C
      IMPLICIT INTEGER*2 (H)
#include "cjdrch.for"
C     LEFT SOLN
      IF(LRS.EQ.-1)SLCOR=DRICOS*SL/(1.+SL*DRISIN)
C     RIGHT SOLN
      IF(LRS.EQ.1) SLCOR=DRICOS*SL/(1.-SL*DRISIN)
      RETURN
      END
      SUBROUTINE CHOOSE
C
C     THIS SUB CHOOSES BEST SOLN WHEN MORE THAN
C     ONE REMAINS AFTER COMPARING SLOPES AND DRIFT TIME
C     IT CHOOSES THE SOLN WITH THE BEST QUANTITY
C     'DTEMP' THAT ALSO HAS TRACK K AS ITS PARENT
C
      IMPLICIT INTEGER*2 (H)
#include "cworkmx.for"
#include "cpatlm.for"
#include "cworkpr.for"
C     PRINT 2228,(ITK(I,1),ITK(I,2),ITK(I,3),ITK(I,4),DTEMP(I),I=1,IRL)
C2228 FORMAT(' MORE THAN ONE SOLN ',4I4,F10.7)
N     ICHOOS IS A DUMMY VARIABLE FOR THE WHILE LOOP
      ICHOOS=1
      IT=IRL-1
      WHILE ICHOOS.EQ.1
      FOR I=1,IT
N     SORT THE ITK ARRAY BASED ON DTEMP
      ITMP=I+1
      FOR J=ITMP,IRL
      IF DTEMP(I).GT.DTEMP(J)
      THEN
      TEMP=DTEMP(I)
      DTEMP(I)=DTEMP(J)
      DTEMP(J)=TEMP
      FOR JK=1,4
      TEMP=ITK(I,JK)
      ITK(I,JK)=ITK(J,JK)
      ITK(J,JK)=TEMP
      CFOR
      CIF
      CFOR
      CFOR
N     PARENT TRACK EL NO. FOR BEST SOLUTION
      IP=ITK(1,4)
N     CANDIDATE TRACK EL NO. FOR BEST SOLUTION
      IC=ITK(1,1)
      IF DTEMP(1).NE.100.
      THEN
N     DOES THE BEST CHOICE HAVE K AS PARENT
      IF IP.NE.K
N     NO, THEN CANCEL ALL TRACKS HAVING THIS
      THEN
N     PARENT OR THIS CANDIDATE
      FOR J=1,IRL
      IF DTEMP(J).NE.100.
      THEN
      IF(ITK(J,4).EQ.IP.OR.ITK(J,1).EQ.IC) DTEMP(J)=100.
      CIF
      CFOR
      ELSE
N     SUCCESS
      XWHILE
      CIF
      ELSE
N     FAILURE
      XWHILE
      CIF
      CWHILE
      IF DTEMP(1).NE.100.
      THEN
N      DUMMY STATEMENTS
      ITWO=2
      ITHREE=ITWO+1
N     SUCCESS
C     PRINT 2230,ITK(1,1),ITK(1,2),ITK(1,3),ITK(1,4)
C2230 FORMAT(' CHOOSE TRACK ',I4,' LR(PARENT)',I4,' LR(CANDIDATE)',
C    * I4,' PARENT TRACK',I4)
      ELSE
N     FAILURE
      IRIFLG=0
C     PRINT 6543
C6543 FORMAT (' REJECT THE BEST CHOICE FOR THIS TRACK')
      CIF
      RETURN
      END
      SUBROUTINE INTJN1(KK,KX,INTFLG,DTMP)
C
C     THIS SUB JOINS TWO TRACK ELS IN ONE CELL
C     PARENT(OR THE TRACK EL IN THE UPPER PART OF THE CELL)
C     IS KK, CANDIDATE(OR THE TRACK EL IN THE LOWER PART
C     OF THE CELL) IS KX,IW IS NWR1(KK),INTFLG IS RETURNED=1
C     FOR SUCCESS AND 0 FOR FAILURE,DTMP RETURNS A QUANTITY
C     PROPORTIONAL TO THE QUALITY OF THE JOIN.
C
      IMPLICIT INTEGER*2 (H)
C
#include "cpatlm.for"
#include "cworkpr.for"
#include "cworkmx.for"
#include "cjdrch.for"
C
      DIMENSION HTEMP(9)
      DATA MSKCR1 /Z100/,MSKFIT/Z20000/,MSKAIT/ZFFFDFFFF/
      MAMB=0
      IF(NRHT(KK).GE.IBKK(19).AND.NRHT(KX).GE.IBKK(19)
     & .AND.IBKK(20).NE.0) MAMB=1
      INTFLG=0
      IWX=ITRKAR(KX,6)
      IOL=IBKK(1)-1
      IGAP=IBKK(2)+1
N     MATCHING OF FIRST AND LAST WIRES HIT
      IF IWX.LE.IW+IOL.AND.IWX.GE.IW-IGAP
      THEN
      ICROSS=1
      SLA=SL1(KK)/RINCR(KRING)
      SLB=SL2(KX)/RINCR(KRING)
      JT=IKX
      IKX=KX
      CALL LFRT(LRA)
      IKX=KK
      CALL LFRT(LR2)
      IKX=JT
      IF(IUDFLG.EQ.3.AND.LR.NE.0.AND.LRA.EQ.0) LRA=LR
      IF(IUDFLG.EQ.6.AND.LR.NE.0.AND.LR2.EQ.0) LR2=LR
      IDIW=IW-IWX
      IF(IDIW.LT.0) IDIW=0
      IF MAMB.NE.0.AND.LAND(MSKCR1,LBL(KK)).EQ.0.AND.
      LAND(MSKCR1,LBL(KX)).EQ.0
      THEN
      IF(LRA.NE.LR2) ICROSS=-1
      IF(LRA.EQ.0.OR.LR2.EQ.0) ICROSS=0
C     PRINT 289,KK,KX
C289  FORMAT(' OPP SIDES OF THE WIRE PLANE FOR TRACKS',2I5)
      CIF
      DSEX=TRKAR(KK,4)-SL1(KK)*IDIW
      DX=DSEX-TRKAR(KX,7)
      IF MAMB.EQ.0.OR.ICROSS.EQ.0
      THEN
      IF(SL2(KX).LT.0..AND.SL1(KK).GT.0..AND.LAND(LBL(KK),MSKCR1).EQ.0
     * .AND.LAND(LBL(KX),MSKCR1).EQ.0.AND.(DS1(KK).LT.BKK(5)
      .OR.DS2(KX).LT.BKK(5))) ICROSS=-1
      CIF
      IF ICROSS.EQ.-1
      THEN
      SLA=-SLA
      DX=TRKAR(KX,7)+DSEX
      CIF
      IF LAND(LBL(KK),MSKCR1).NE.0.AND.LAND(LBL(KX),MSKCR1).NE.0
       THEN
      DX=TRKAR(KX,7)+DSEX
N     OPPOSITE SIDES OF THE WIRE PLANE
      SLA=-SLA
C      CALL CHKX(-88,SLA,DSEX,DX)
      IF(MAMB.NE.0.AND.LRA*LR2.LT.0) DX=1000000.
      CIF
      IF(ICROSS.EQ.0) ICROSS=1
      IF(LAND(MSKCR1,LBL(KK)).EQ.0.AND.LAND(MSKCR1,LBL(KX)).NE.0
     & .AND.LRA*LR2.GT.0.AND.MAMB.NE.0) DX=10000000.
      IF(LAND(MSKCR1,LBL(KX)).EQ.0.AND.LAND(MSKCR1,LBL(KK)).NE.0
     & .AND.LRA*LR2.LT.0.AND.MAMB.NE.0) DX=10000000.
N     ARE DRIFT SPACES SIMILAR?
      IF ABS(DX).LT.DCELL
      THEN
C     PRINT 6378,KK,KX,IWX,IW,DX
C6378 FORMAT(' JOIN TWO TKELS',2I4,' WIRE NOS. ',2I4,'  DX=',F7.3)
N     SET UP SLOPE LIMIT
      SLOLIM=(ABS(SLA)+ABS(SLB))/2.*BKK(14)+BKK(15)
N     COMPARE SLOPES
      DTMP=ABS(SLA-SLB)
C     PRINT 211,DTMP,SLOLIM
C 211 FORMAT(' SLOPE (CAND.-PARENT)',F10.5,'SLOLIM',F10.5)
N     SUCCESS
      IF DTMP.LT.SLOLIM
      THEN
      IB=0
      IF IBKK(16).NE.0.AND.IBFIT.EQ.0
      THEN
      PERFORM INTFIT
      CIF
      IF IB.EQ.0
      THEN
      INTFLG=ICROSS
      DTMP=ABS(DTMP*DX)
      CIF
      CIF
      KMP1=HISTR(1,NTR)
      KMP1=IABS(KMP1)
      KMP1=IPCL(KMP1)
      IF(KMP1.EQ.IPCL(KX).AND.IBKK(20).NE.0.AND.MAMB.EQ.0) IJFLG=1
      CIF
      CIF
      RETURN
C
C     *********************************************
C
      PROC INTFIT
C
C
C
      IB=0
      IF HNREL(NTR).LT.9
      THEN
      CALL MVC(HTEMP(1),0,HISTR(1,NTR),0,18)
      IKST=IPST
      IKFLG=IJFLG
      IBJ=IKX
      IKX=KX
      LR3=1
      IF(ICROSS.EQ.-1.OR.(LAND(LBL(KX),MSKCR1).NE.0.AND.
     & LAND(LBL(KK),MSKCR1).EQ.0)) LR3=-1
      PERFORM INCRSS
      HNREL(NTR)=HNREL(NTR)+1
      LRC=LR2
      HISTR(HNREL(NTR),NTR)=LRC*KX
C     LBL(KX)=LOR(LBL(KX),MSKFIT)
      CALL BAKFIT(IB,1)
C     IF(IB.NE.0) PRINT 36
C36   FORMAT('   INTJ  FIT    ')
      IAB=HNREL(NTR)
C     IF(IB.NE.0) PRINT 37,KX,NTR,(HISTR(IR,NTR),IR=1,IAB)
C     IF(IB.NE.0) PRINT 38,(HTEMP(IR),IR=1,9)
C37   FORMAT(' KX, NTR,HISTR :',11I5)
C38   FORMAT(' OLD HISTR :',9I5)
      HNREL(NTR)=HNREL(NTR)-1
C     LBL(KX)=LAND(LBL(KX),MSKAIT)
      CALL MVC(HISTR(1,NTR),0,HTEMP(1),0,18)
      IKX=IBJ
      IJFLG=IKFLG
      IPST=IKST
      CIF
      CPROC
      PROC INCRSS
C
C     THIS PROC DETERMINES WHETHER CANDIDATE AND PARENT HAVE
C     DIFFERENT AMBIGUITY
C
      CALL LFRT(LR2)
N     DETERMINE LR OF CANDIDATE AND STORE IN LR2
      IF LR2.EQ.0
      THEN
      IF LR.NE.0
      THEN
      LR2=LR*LR3
      ELSE
      LR2=LR3
      IJFLG=1
      IPST=1
      CIF
      ELSE
      IF LR.EQ.0
      THEN
      IF(LR2*LR3.EQ.-1) HISTR(1,NTR)=-HISTR(1,NTR)
      ELSE
      IF LR2.NE.LR*LR3
      THEN
C     IF(IJFLG.EQ.1) CALL COREC
C     IF(HNREL(NTR).EQ.1) HISTR(1,NTR)=-HISTR(1,NTR)
      LR2=-LR2
      CIF
      CIF
      CIF
      CPROC
      END
      SUBROUTINE COREC
C
C     THIS SUB CORRECTS L-R AMBIGUITY OF PREVIOUSLY
C     STORED TRACKS WHEN THEY HAVE BEEN STORED AWAY WITH AN
C     ARBITRARILY SET AMBIGUITY(IJFLG=1) AND A TEST OF
C     THE AMBIGUITY FROM WIRE STAGGERING INDICATES
C     A DISCREPANCY
C
      IMPLICIT INTEGER*2 (H)
#include "cworkmx.for"
#include "cpatlm.for"
#include "cworkpr.for"
      ITMP=HNREL(NTR)
      FOR I=1,ITMP
      HISTR(I,NTR)=-HISTR(I,NTR)
      CFOR
      IJFLG=0
C     PRINT 666
C666  FORMAT('  COREC================')
      RETURN
      END
      SUBROUTINE SIDE1
C
C     THIS SUB PRESETS CERTAIN QUANTITIES FOR
C     THE PROC SIDCN1 WHERE THE CONNECTION ACROSS
C     CELL SIDEWALLS IS ATTEMPTED
C
      IMPLICIT INTEGER*2 (H)
#include "cworkpr.for"
#include "cworkmx.for"
#include "cpatlm.for"
#include "cdsmax.for"
#include "cjdrch.for"
      DIMENSION LSTCL(3),LFTCL(3),NCELL(3),TANDEL(3)
      EQUIVALENCE (IBCK(1),LSTCL(1)),(IBCK(4),LFTCL(1))
      EQUIVALENCE (IBCK(7),NCELL(1)),(DBCK(1),TANDEL(1))
      DIMENSION HTEMP(9)
      DATA MSKCR1 /Z100/,MSKFIT/Z20000/,MSKAIT/ZFFFDFFFF/
N     IIWW IS THE FIRST WIRE THAT IS NOT HIT
      IIWW=IW+1
      IF(IIWW.GT.16) IIWW=16
      IF(IIWW.LT.1) IIWW=1
N     DSMX IS THE MAX DRIFT SPACE FOR THIS WIRE,CELL,AMBIGUITY
      BSL=A
N     CHECK IF DRIFT SPACE IS MAX
      IF(IUDFLG.EQ.6) BSL=-BSL
      DRIFT=DS+.5*BSL
      IRT=LR1
      IM1=6
      IM2=3
      PERFORM SIDCX
      IWEX=HMCH(IIWW,KRING,LR1)+1
      IF(IWEX.GT.16) IWEX=16
      IF(IWEX.LT.1) IWEX=1
C     CALL CHKX(70,IIWW,IIWW,IWEX)
C     CALL CHKX(-70,DTMP,DTMP,DTMP)
C     ELSE
C     DTMP=100.
C     PRINT 6654,SLWALL,BSL
C6654 FORMAT(' WRONG SLOPE FOR SIDCON  ',2F10.5)
C     CIF
      IF DTMP.LT.2.*CLIM.OR.DTMP.LT.2.
      THEN
C     PRINT 2216,DS,A,DSMX,DTMP
C2216 FORMAT(' CELSID   DS=',F7.3,'A=',F7.3,'DSMX=',F7.3,'DIFF=',F7.3)
C     PRINT 2218
C2218 FORMAT(' CELSID   SUCCEEDS')
N     TRY A SIDE CONNECTION
      PERFORM SIDCN1
N     IS IT SUCCESSFUL?
      IF IKX.GT.0
      THEN
      IF LRCORN.EQ.0
      THEN
N     RESET THINGS FOR ANOTHER GO
      ICX=ICT
      IRIFLG=1
      KT=IKX
      CIF
N     FAILURE
      ELSE
      IWT=ILIM
      CIF
      ELSE
C     PRINT 2217
C2217 FORMAT(' CELSID   FAILS')
      IWT=ILIM
      CIF
      RETURN
C
C   *************************************************************
C
      PROC SIDCN1
C
C  THIS PROC FINDS A MATCH THROUGH SIDEWALL OF ONE RING
C
N     IKX WILL CONTAIN MATHING TRACK NO. IF SUCCESSFUL
      IKX=0
      ICNFLG=0
N     PRESET COUNTERS IN CASE MORE THAN ONE SOLN IS FOUND
      IF(LRCORN.EQ.0) IRL=0
N     TRACK ELEMENTS IN NEIGHBOR CELL ?
      NTRLX1 = HNTCEL(ICT)
      NTRLX2 = HNTCEL(ICT+1)-1
C     PRINT 2219,ICT,NTRLX1,NTRLX2
C2219 FORMAT(' TRY SIDCON     CELL=',I4,' TRACKS=',2I4)
N     EXPECTED WIRE NO. IN NEIGHBOUR CELL DEPENDS ON L-R SIDE
N     ADD 1 OR SUBTRACT 1 TO EXPECTED WIRE NO.
N     DEPENDING ON WHETHER TRACK IS GOING OUT OR IN
N     LOOP TRACK ELEMENTS IN NEIGHBOR CELL
      FOR KX = NTRLX1,NTRLX2
N     CHECK THAT IT HASN'T BEEN USED YET
      IF HUSE(KX).EQ.0
      THEN
      IPER=0
      IF IBKK(20).NE.0.AND.NRHT(KX).GE.IBKK(19)
      THEN
      JT=IKX
      IKX=KX
      CALL LFRT(LK)
      IKX=JT
      IF(LAND(MSKCR1,LBL(KX)).NE.0.AND.IUDFLG.EQ.6) LK=-LK
      IF(LK.NE.3-2*LR1) IPER=1
      IF(LK.EQ.0) IPER=0
      CIF
      IF IPER.EQ.0
      THEN
N     WIRE NO. OF CANDIDATE TRACK
      IIWW= ITRKAR(KX,IUDFLG)+1
      IF(IIWW.GT.16) IIWW=16
      IF(IIWW.LT.1) IIWW=1
N     DSMX IS THE MAX DRIFT SPACE FOR THIS WIRE,CELL,AMBIGUITY
      BSL=TRKAR(KX,IUDFLG+2)
N     CHECK IF DRIFT SPACE IS MAX
      IF(IUDFLG.EQ.3) BSL=-BSL
      DRIFT=TRKAR(KX,IUDFLG+1)+.5*BSL
      IRT=3-LR1
      IM1=3
      IM2=6
      PERFORM SIDCX
      IWX=IIWW
C     CALL CHKX(70,IIWW,IWX,IWEX)
C     PRINT 2220,DTMP,IWEX,IWX
C2220 FORMAT(' DSX-DSMAX=',F7.3,'EXPECTED WIRE=',I4,' ACTUAL WIRE=',I4)
N     DOES CANDIDATE TRACK HAVE A MAX DRIFT SPACE?
C     ELSE
C     DTMP=100.
C     PRINT 6654,SLWALL,BSL
C     CIF
      IF DTMP.LT.2.*CLIM.OR.DTMP.LT.2.
N     COMPARE SLOPES
      THEN
      IF IABS(IWX-IWEX).LE.IBKK(6)-1
      THEN
C
C     THIS PROC CALCULATES SLOPE OF PARENT TRACK
C     IN THE CANDIDATE TRACKS CELL
      LRS=2*LR1-3
      SLB=A/RINCR(KRING)
N     COMPENSATE FOR LORENTZ ANGLE
      SL=SLCOR(SLB,LRS)
N     ROTATE TO NEIGHBOUR CELL CO-ORDINATE SYSTEM
      T=TANDEL(KRING)
N     EXPECTED SLOPE
      SLEX=(T-SL)/(1.+SL*T)
C     CALL CHKX(-62,SL,T,SLEX)
      LRS=-LRS
N     GET CANDIDATE SLOPE
      SLE=TRKAR(KX,IUDFLG+2)/RINCR(KRING)
N     COMPENSATE LORENTZ ANGLE
      SLC=SLCOR(SLE,LRS)
C     CALL CHKX(-63,SLE,SLC,SLC)
N     TOLERANCE ON SLOPE MATCHING
C     SLOLIM=ABS(SLEX)*FACTSL+CONSL
C     IF(SLOLIM.LE..1) SLOLIM=.045
C     IF(SLOLIM.GT..1) SLOLIM=.5
      SLOLIM=(ABS(SLE)+ABS(SLB))/2.*BKK(12)+BKK(13)
      DTMP=SLEX-SLC
C     PRINT 2229,KX,DTMP,SLOLIM
C2229 FORMAT(' COMP SLOPES, TRACK=',I4,' SLEX-SL ',F7.3,' SLOLIM',F7.3)
      IF ABS(DTMP).LT.SLOLIM
N     SUCCESS SO STORE IT AWAY
      THEN
      IF LRCORN.NE.0
      THEN
      IKX=KX
C     PRINT 2221,IKX
      XFOR
      CIF
      IB=0
      IF IBKK(17).NE.0.AND.IBFIT.EQ.0
      THEN
      PERFORM SIDFIT
      CIF
      IF IB.EQ.0
      THEN
      IRL=IRL+1
      DTEMP(IRL)=ABS(DTMP)
      ITK(IRL,1)=KX
      ITK(IRL,4)=KT
      ICNFLG=1
      ELSE
N     FAILURE
      ICNFLG=0
      CIF
      ELSE
N     FAILURE
      ICNFLG=0
      CIF
      IF(IRL.GT.0.AND.LRCORN.EQ.0) ICNFLG=1
      CIF
      CIF
      ELSE
C     PRINT 59,KX
C59   FORMAT('   TRACK',I5,'   REFUSED AS CAND IN SIDCON')
      CIF
      CIF
      CFOR
N     HAVE WE AT LEAST ONE MATCH?
      IF ICNFLG.EQ.1
      THEN
N     IF MORE THAN ONE THEN WE MUST CHOOSE WHICH TO TAKE
      IF IRL.GT.1
      THEN
      CALL CHOOSE
      CIF
N     PUT AWAY THE MATCHING TRACK NUMBER
      IKX=ITK(1,1)
C     PRINT 2221,IKX
C2221 FORMAT(' SUCCESS IN SIDCON,TRACK=',I4)
      CIF
      CPROC
C
C     ********************************************************
C
      PROC SIDCX
C
C
C
      CLIM=.5*BSL
      DXNEW=DSMAX(IIWW,KRING,IRT)-DRIFT
      DXOLD=9999.
C     SLWALL=DSMAX(2,KRING,LR1)-DSMAX(1,KRING,LR1)
C     IF BSL.GT.SLWALL
C     THEN
      WHILE DXNEW.GT.CLIM
      IF IIWW.EQ.16.OR.IIWW.EQ.1
      THEN
C     PRINT 432
C 432 FORMAT(' WIRE NO. OUT OF RANGE  ')
      XWHILE
      CIF
      DRIFT=DRIFT+BSL
      IF(IUDFLG.EQ.IM1) IIWW=IIWW-1
      IF(IUDFLG.EQ.IM2) IIWW=IIWW+1
      DSMX=DSMAX(IIWW,KRING,IRT)
      DXNEW=DSMX-DRIFT
      IF ABS(DXNEW).GT.ABS(DXOLD)
      THEN
C     PRINT 902
C902  FORMAT( '  DIVERGENCE  ')
      DTMP=100.
      XWHILE
      CIF
C     CALL CHKX(69,IIWW,IUDFLG,IIWW)
C     CALL CHKX(-69,DXNEW,DXOLD,DRIFT)
      IF DXNEW.LT.1.
      THEN
      XWHILE
      ELSE
      DXOLD=DXNEW
      CIF
      CWHILE
      DTMP=DXNEW
      CPROC
C
C     *******************************************************
C
      PROC SIDFIT
C
C
C
      IB=0
      IF HNREL(NTR).LT.9
      THEN
      IKFLG=IJFLG
      CALL MVC(HTEMP(1),0,HISTR(1,NTR),0,18)
      IF(LR.EQ.-1.AND.LR1.EQ.2.OR.LR.EQ.1.AND.LR1.EQ.1) CALL COREC
      IF(LR.EQ.0.AND.LR1.EQ.1) HISTR(1,NTR)=-HISTR(1,NTR)
      HNREL(NTR)=HNREL(NTR)+1
      IF(LR1.EQ.2) LRC=-1
      IF(LR1.EQ.1) LRC=1
      IF(LAND(LBL(KX),MSKCR1).NE.0.AND.IUDFLG.EQ.6) LRC=-LRC
      IKRA=HISTR(1,NTR)
      IKRA=IABS(IKRA)
      IF(IKRA.EQ.KT.AND.IUDFLG.EQ.3.AND.LAND(MSKCR1,LBL(KT)).NE.0)
     * CALL COREC
      HISTR(HNREL(NTR),NTR)=KX*LRC
C     LBL(KX)=LOR(LBL(KX),MSKFIT)
      IAB=HNREL(NTR)
      CALL BAKFIT(IB,3)
C     IF(IB.NE.0) PRINT 36
C36   FORMAT('   SIDE  FIT    ')
C     IF(IB.NE.0) PRINT 37,KX,NTR,(HISTR(IR,NTR),IR=1,IAB)
C     IF(IB.NE.0) PRINT 38,(HTEMP(IR),IR=1,9)
C37   FORMAT(' KX, NTR,HISTR :',11I5)
C38   FORMAT(' OLD HISTR :',9I5)
      HNREL(NTR)=HNREL(NTR)-1
C     LBL(KX)=LAND(LBL(KX),MSKAIT)
      CALL MVC(HISTR(1,NTR),0,HTEMP(1),0,18)
      IJFLG=IKFLG
      CIF
      CPROC
      END
      SUBROUTINE LFRT(LR2)
C
C     THIS SUB EXTRACTS LEFT-RIGHT SOLN BASED
C     ON THE LABEL IN MIDOUT(WIRE STAGGERING)
C
      IMPLICIT INTEGER*2 (H)
#include "cworkmx.for"
#include "cworkpr.for"
#include "cpatlm.for"
      DATA MSKLFT,MSKRT/Z400,Z800/
      LR2=0
      IPST=0
      I1=LAND(LBL(IKX),MSKLFT)
      I2=LAND(LBL(IKX),MSKRT)
C     LEFT SOLN
      IF(I1.NE.0) LR2=-1
C     RIGHT SOLN
      IF(I2.NE.0) LR2=1
C     CAN'T TELL
      IF(I1*I2.NE.0) LR2=0
      IF(LR2.NE.0) IPST=1
      RETURN
      END
C   28/01/80 104011107  MEMBER NAME  CBTREL   (PATRECSR)    SHELTRAN
      SUBROUTINE CBTREL(IPR1,IPR2)
C
      IMPLICIT INTEGER*2 (H)
      LOGICAL TBIT
C
C     SUBROUTINE TO COMBINE TRACK ELEMENTS
C     AUTHOR: P. STEFFEN(78/11/21)
C
C
#include "cworkpr.for"
#include "cworkeq.for"
C
N     POINTER TO ADJACENT CELLS
      DIMENSION IPC(12), IAUX(8),RAUX(8),HAUX(2,8)
      EQUIVALENCE (IAUX(1),HAUX(1,1))
C
N     I2-I4 CONVERSION:
      INTEGER*2 HZW(2)
      EQUIVALENCE (HZW(1),IZW,HZW1) , (HZW(2),HZW2)
C
N     LIMITS FOR CONNECTIONS OF TRELS
      COMMON /CPTSLM/ BKTRLM(20)
                      INTEGER LMBKTR(20)
                      REAL CBTRLM(10)
                      EQUIVALENCE (BKTRLM(11),LMBKTR(11),CBTRLM(1))
C
      IPTR0 = HPTE0
      IPTR9 = HPTE9
      LDTRK = HLDTE
      NPR  = 0
      NPR9 = MIN0(IPR2,100)
      IF(IPR1.EQ.0) NPR9 = 0
C
N     LOOP OVER ALL TREL'S
      FOR IPTR = IPTR0,IPTR9,LDTRK
N       CELL #
        ICELL = IWRK(IPTR   )
        LBTREL= IWRK(IPTR+19)
C
N       GET POINTERS TO ADJACENT CELLS
        PERFORM PNTADJ
C
N       SEARCH FOR CONNECTION OUTWARDS
        RMSMIN = 1000.
        ALGHT1 = 0.
        ALGHT2 = 200.
        PERFORM CNOUTW
C
N       CHECK IF GOOD COMB. FOR 1. RING
        IF RMSMIN.GT.CBTRLM(4)
        THEN
N         NO GOOD COMB.: TRY R1-R3 COMB.
          IPC( 5) = 0
          IPC( 6) = 0
          IPC( 7) = 0
          IPC( 8) = 0
          IPC( 9) = IPC( 1)
          IPC(10) = IPC( 2)
          IPC(11) = IPC( 3)
          IPC(12) = IPC( 4)
          ALGHT2 = 400.
          PERFORM CNOUTW
        CIF
C
      CFOR
C
N     ORDER MULT. CONNECTIONS
N     CLOSEST CONNECT. FIRST
      PERFORM ORDER
C
      RETURN
C
C
N      *****  P N T A D J  *****
C
N      GET POINTERS TO ADJACENT CELLS
       PROC PNTADJ
C
        IF ICELL.LE.24
N       RING 1
        THEN
C
          IF ICELL.EQ.1
N         SPECIAL FOR CELL 1
          THEN
            IPC( 5) = IPTR0
            IPC( 6) = IPTR0 + (HNTCEL( 3)-2)*LDTRK
            IPC( 7) = IPTR0 + (HNTCEL(24)-1)*LDTRK
            IPC( 8) = IPTR0 + (HNTCEL(25)-2)*LDTRK
            IPC( 9) = IPTR0 + (HNTCEL(25)-1)*LDTRK
            IPC(10) = IPTR0 + (HNTCEL(27)-2)*LDTRK
            IPC(11) = IPTR0 + (HNTCEL(48)-1)*LDTRK
            IPC(12) = IPTR0 + (HNTCEL(49)-2)*LDTRK
            IPC( 1) = IPTR0 + (HNTCEL(49)-1)*LDTRK
            IPC( 2) = IPTR0 + (HNTCEL(53)-2)*LDTRK
            IPC( 3) = IPTR0 + (HNTCEL(95)-1)*LDTRK
            IPC( 4) = IPTR0 + (HNTCEL(97)-2)*LDTRK
          ELSE
          IF ICELL.LT.24
N         CELL 2 - 23
          THEN
            IPC( 5) = IPTR0 + (HNTCEL(ICELL- 1)-1)*LDTRK
            IPC( 6) = IPTR0 + (HNTCEL(ICELL+ 2)-2)*LDTRK
            IPC( 7) = 0
            IPC( 8) = 0
            IPC( 9) = IPTR0 + (HNTCEL(ICELL+23)-1)*LDTRK
            IPC(10) = IPTR0 + (HNTCEL(ICELL+26)-2)*LDTRK
            IPC(11) = 0
            IPC(12) = 0
            ICLL3 = ICELL*2 + 46
            IPC( 1) = IPTR0 + (HNTCEL(ICLL3-1)-1)*LDTRK
            IPC( 2) = IPTR0 + (HNTCEL(ICLL3+5)-2)*LDTRK
            IPC( 3) = 0
            IPC( 4) = 0
N         SPECIAL FOR CELL 24
          ELSE
            IPC( 5) = IPTR0 + (HNTCEL(23)-1)*LDTRK
            IPC( 6) = IPTR0 + (HNTCEL(25)-2)*LDTRK
            IPC( 7) = IPTR0
            IPC( 8) = IPTR0 + (HNTCEL( 2)-2)*LDTRK
            IPC( 9) = IPTR0 + (HNTCEL(47)-1)*LDTRK
            IPC(10) = IPTR0 + (HNTCEL(49)-2)*LDTRK
            IPC(11) = IPTR0 + (HNTCEL(25)-1)*LDTRK
            IPC(12) = IPTR0 + (HNTCEL(26)-2)*LDTRK
            IPC( 1) = IPTR0 + (HNTCEL(93)-1)*LDTRK
            IPC( 2) = IPTR0 + (HNTCEL(97)-2)*LDTRK
            IPC( 3) = IPTR0 + (HNTCEL(49)-1)*LDTRK
            IPC( 4) = IPTR0 + (HNTCEL(51)-2)*LDTRK
          CIF
          CIF
C
        ELSE
        IF ICELL.LE.48
N       RING2
        THEN
C
          IF ICELL.EQ.25
N         SPECIAL FOR CELL 25
          THEN
            IPC( 1) = IPTR0
            IPC( 2) = IPTR0 + (HNTCEL( 3)-2)*LDTRK
            IPC( 3) = IPTR0 + (HNTCEL(24)-1)*LDTRK
            IPC( 4) = IPTR0 + (HNTCEL(25)-2)*LDTRK
            IPC( 5) = IPTR0 + (HNTCEL(25)-1)*LDTRK
            IPC( 6) = IPTR0 + (HNTCEL(27)-2)*LDTRK
            IPC( 7) = IPTR0 + (HNTCEL(48)-1)*LDTRK
            IPC( 8) = IPTR0 + (HNTCEL(49)-2)*LDTRK
            IPC( 9) = IPTR0 + (HNTCEL(49)-1)*LDTRK
            IPC(10) = IPTR0 + (HNTCEL(53)-2)*LDTRK
            IPC(11) = IPTR0 + (HNTCEL(95)-1)*LDTRK
            IPC(12) = IPTR0 + (HNTCEL(97)-2)*LDTRK
          ELSE
          IF ICELL.LT.48
N         CELLS 25 - 47
          THEN
            IPC( 1) = IPTR0 + (HNTCEL(ICELL-25)-1)*LDTRK
            IPC( 2) = IPTR0 + (HNTCEL(ICELL-22)-2)*LDTRK
            IPC( 3) = 0
            IPC( 4) = 0
            IPC( 5) = IPTR0 + (HNTCEL(ICELL- 1)-1)*LDTRK
            IPC( 6) = IPTR0 + (HNTCEL(ICELL+ 2)-2)*LDTRK
            IPC( 7) = 0
            IPC( 8) = 0
            ICLL3 = (ICELL-24)*2 + 46
            IPC( 9) = IPTR0 + (HNTCEL(ICLL3-1)-1)*LDTRK
            IPC(10) = IPTR0 + (HNTCEL(ICLL3+5)-2)*LDTRK
            IPC(11) = 0
            IPC(12) = 0
          ELSE
N         SPECIAL FOR CELL 48
            IPC( 1) = IPTR0 + (HNTCEL(23)-1)*LDTRK
            IPC( 2) = IPTR0 + (HNTCEL(25)-2)*LDTRK
            IPC( 3) = IPTR0
            IPC( 4) = IPTR0 + (HNTCEL( 2)-2)*LDTRK
            IPC( 5) = IPTR0 + (HNTCEL(47)-1)*LDTRK
            IPC( 6) = IPTR0 + (HNTCEL(49)-2)*LDTRK
            IPC( 7) = IPTR0 + (HNTCEL(25)-1)*LDTRK
            IPC( 8) = IPTR0 + (HNTCEL(26)-2)*LDTRK
            IPC( 9) = IPTR0 + (HNTCEL(93)-1)*LDTRK
            IPC(10) = IPTR0 + (HNTCEL(97)-2)*LDTRK
            IPC(11) = IPTR0 + (HNTCEL(49)-1)*LDTRK
            IPC(12) = IPTR0 + (HNTCEL(51)-2)*LDTRK
          CIF
          CIF
C
N       RING 3
        ELSE
C
          IPC( 9) = 0
          IPC(10) = 0
          IPC(11) = 0
          IPC(12) = 0
C
          IF ICELL.EQ.49
N         SPECIAL FOR CELL 49
          THEN
            IPC( 1) = IPTR0 + (HNTCEL(48)-1)*LDTRK
            IPC( 2) = IPTR0 + (HNTCEL(49)-2)*LDTRK
            IPC( 3) = IPTR0 + (HNTCEL(25)-1)*LDTRK
            IPC( 4) = IPTR0 + (HNTCEL(26)-2)*LDTRK
            IPC( 5) = IPTR0 + (HNTCEL(49)-1)*LDTRK
            IPC( 6) = IPTR0 + (HNTCEL(51)-2)*LDTRK
            IPC( 7) = IPTR0 + (HNTCEL(96)-1)*LDTRK
            IPC( 8) = IPTR0 + (HNTCEL(97)-2)*LDTRK
          ELSE
          IF ICELL.LT.96
N         CELLS 50 - 95
          THEN
            ICLL2 = (ICELL-50)/2 + 25
            IPC( 1) = IPTR0 + (HNTCEL(ICLL2   )-1)*LDTRK
            IPC( 2) = IPTR0 + (HNTCEL(ICLL2+ 2)-2)*LDTRK
            IPC( 3) = 0
            IPC( 4) = 0
            IPC( 5) = IPTR0 + (HNTCEL(ICELL- 1)-1)*LDTRK
            IPC( 6) = IPTR0 + (HNTCEL(ICELL+ 2)-2)*LDTRK
            IPC( 7) = 0
            IPC( 8) = 0
          ELSE
N         SPECIAL FOR CELL 96
            IPC( 1) = IPTR0 + (HNTCEL(48)-1)*LDTRK
            IPC( 2) = IPTR0 + (HNTCEL(49)-2)*LDTRK
            IPC( 3) = IPTR0 + (HNTCEL(25)-1)*LDTRK
            IPC( 4) = IPTR0 + (HNTCEL(26)-2)*LDTRK
            IPC( 5) = IPTR0 + (HNTCEL(95)-1)*LDTRK
            IPC( 6) = IPTR0 + (HNTCEL(97)-2)*LDTRK
            IPC( 7) = IPTR0 + (HNTCEL(49)-1)*LDTRK
            IPC( 8) = IPTR0 + (HNTCEL(50)-2)*LDTRK
          CIF
          CIF
C
        CIF
        CIF
C
N       ZERO POINTERS IF NO TREL'S IN CELLS
        IF(IPC( 1).GT.IPC( 2)) IPC( 1) = 0
        IF(IPC( 3).GT.IPC( 4)) IPC( 3) = 0
        IF(IPC( 5).EQ.IPC( 6)) IPC( 5) = 0
        IF(IPC( 7).GT.IPC( 8)) IPC( 7) = 0
        IF(IPC( 9).GT.IPC(10)) IPC( 9) = 0
        IF(IPC(11).GT.IPC(12)) IPC(11) = 0
C
      CPROC
C
C
N     *****  C N O U T W  *****
C
N     CONNECT TREL OUTWARDS
      PROC CNOUTW
C
N       JPTRI = INNER TREL
N       JPTRO = OUTER TREL
        JPTRI = IPTR
        LRFLGI = SHFTR(LBTREL,10)
        LRFLGI = LAND(LRFLGI,3)
        XXIM = AMIN1(ABS(WRK(JPTRI+11)),ABS(WRK(JPTRI+15)))
        YYIM = AMIN1(ABS(WRK(JPTRI+12)),ABS(WRK(JPTRI+16)))
N       LOOP OVER ALL ADJACENT CELLS
        ICLOOP = 5
        REPEAT
          IF IPC(ICLOOP).GT.0
          THEN
            JPTRO = IPC(ICLOOP  )
            JPTR9 = IPC(ICLOOP+1)
            WHILE JPTRO.LE.JPTR9
              IF JPTRO.NE.JPTRI
              THEN
C
N               CHECK IF TRELS OVERLAP
                NCAND = 255
                IF ABS(XXIM).GT.ABS(YYIM)
                THEN
                  XXOM = AMAX1(ABS(WRK(JPTRO+ 3)),ABS(WRK(JPTRO+ 7)))
                  IF(XXOM-XXIM .GT. CBTRLM(1)) NCAND=0
                ELSE
                  YYOM = AMAX1(ABS(WRK(JPTRO+ 4)),ABS(WRK(JPTRO+ 8)))
                  IF(YYOM-YYIM .GT. CBTRLM(1)) NCAND=0
                CIF
                IF NCAND.EQ.0
                THEN
C
N                 # OF COMBINATIONS OF 2 TRELS
                  NCOMB = 0
N                 SET LIMITS FOR STRAIGHT/CROSS CONNECT.
                  JCLLI = IWRK(JPTRI)
                  IF(JCLLI.GT.48) JCLLI = SHFTR(JCLLI-46,1)
                  IF(JCLLI.GT.24) JCLLI = JCLLI - 24
                  JCLLO = IWRK(JPTRO)
                  IF(JCLLO.GT.48) JCLLO = SHFTR(JCLLO-46,1)
                  IF(JCLLO.GT.24) JCLLO = JCLLO - 24
                  IF IABS(JCLLO-JCLLI).EQ.0
                  THEN
                    DRLIM = CBTRLM(2)
                    DANGL = CBTRLM(3)
                  ELSE
                    DRLIM = CBTRLM(6)
                    DANGL = CBTRLM(7)
                  CIF
N                 SET AVER. LENGTH OF TRACK
                  ALGHT0 = ALGHT1
                  IF(ICLOOP.GE.9) ALGHT0 = ALGHT2
N                 SELECT L/R-COMB. FROM /CMDOUT/
                  LRFLGO = SHFTR(IWRK(JPTRO+19),10)
                  LRFLGO = LAND(LRFLGO,3)
                  LRFLIO = LRFLGI + LRFLGO*4
                  LBLR = 0
                  RMSMZW = 1000.
                  SELECT LRFLIO
N                 L - L
                  CASE 5
                    LRFLAG = 1
                    PERFORM CKCIRC
                    LBLR = 1
N                 R - L
                  CASE 6
                    LRFLAG = 2
                    PERFORM CKCIRC
                    LBLR = 2
N                 ? - L
                  CASE 7
                    LRFLAG = 1
                    PERFORM CKCIRC
                    LRFLAG = 2
                    PERFORM CKCIRC
                    LBLR = 3
N                 L - R
                  CASE 9
                    LRFLAG = 3
                    PERFORM CKCIRC
                    LBLR = 4
N                 R - R
                  CASE 10
                    LRFLAG = 4
                    PERFORM CKCIRC
                    LBLR = 8
N                 ? - R
                  CASE 11
                    LRFLAG = 3
                    PERFORM CKCIRC
                    LRFLAG = 4
                    PERFORM CKCIRC
                    LBLR = 12
N                 L - ?
                  CASE 13
                    LRFLAG = 1
                    PERFORM CKCIRC
                    LRFLAG = 3
                    PERFORM CKCIRC
                    LBLR = 5
N                 R - ?
                  CASE 14
                    LRFLAG = 2
                    PERFORM CKCIRC
                    LRFLAG = 4
                    PERFORM CKCIRC
                    LBLR = 10
                  OTHER
                  CSELECT
C
N                 TRY ALL REMAINING COMB. IF NO GOOD ONE FOUND
                  IF RMSMZW.GT.CBTRLM(4)
                  THEN
N                   KEEP NOT TOO BAD PREVIOUS COMB.
                    IF(RMSMZW.LE.CBTRLM(5)) NCOMB = 0
N                   TRY REMAINING COMB.
                    IF LAND(LBLR,1).EQ.0
                    THEN
                      LRFLAG = 1
                      PERFORM CKCIRC
                    CIF
                    IF LAND(LBLR,2).EQ.0
                    THEN
                      LRFLAG = 2
                      PERFORM CKCIRC
                    CIF
                    IF LAND(LBLR,4).EQ.0
                    THEN
                      LRFLAG = 3
                      PERFORM CKCIRC
                    CIF
                    IF LAND(LBLR,8).EQ.0
                    THEN
                      LRFLAG = 4
                      PERFORM CKCIRC
                    CIF
                  CIF
              IF(RMSMZW.LT.RMSMIN) RMSMIN = RMSMZW
N                 KEEP SMALLEST CHISQ
C
                CIF
C
              CIF
              JPTRO = JPTRO + LDTRK
            CWHILE
C
          CIF
          ICLOOP = ICLOOP + 2
        UNTIL ICLOOP.GE.12
C
      CPROC
C
C
N     *****  C K C I R C  *****
C
N     CONNECT TREL OUTWARDS
      PROC CKCIRC
C
N       GET POINTERS FOR L/R-COMBINATION
        SELECT LRFLAG
N       L - L
        CASE 1
          JPTII = JPTRI+3
          JPTIO = JPTRI+11
          JPTOI = JPTRO+3
          JPTOO = JPTRO+11

N       R - L
        CASE 2
          JPTII = JPTRI+7
          JPTIO = JPTRI+15
          JPTOI = JPTRO+3
          JPTOO = JPTRO+11
N       L - R
        CASE 3
          JPTII = JPTRI+3
          JPTIO = JPTRI+11
          JPTOI = JPTRO+7
          JPTOO = JPTRO+15
N      R - R
        CASE 4
          JPTII = JPTRI+7
          JPTIO = JPTRI+15
          JPTOI = JPTRO+7
          JPTOO = JPTRO+15
        OTHER
        CSELECT
C
N       SET END POINTS + SLOPES
        XXII = WRK(JPTII   )
        YYII = WRK(JPTII+ 1)
        DXII = WRK(JPTII+ 2)
        DYII = WRK(JPTII+ 3)
        XXOI = WRK(JPTOI   )
        YYOI = WRK(JPTOI+ 1)
        DXOI = WRK(JPTOI+ 2)
        DYOI = WRK(JPTOI+ 3)
        XXIO = WRK(JPTIO   )
        YYIO = WRK(JPTIO+ 1)
        DXIO = WRK(JPTIO+ 2)
        DYIO = WRK(JPTIO+ 3)
        XXOO = WRK(JPTOO   )
        YYOO = WRK(JPTOO+ 1)
        DXOO = WRK(JPTOO+ 2)
        DYOO = WRK(JPTOO+ 3)
C
N       CHECK CONNECTION
C
        REPEAT
C
N         CHECK IF OUTWARD CONNECTION
          ZW1 = (XXII-XXOI)**2 + (YYII-YYOI)**2
          ZW2 = (XXOO-XXIO)**2 + (YYOO-YYIO)**2
          ZW0 = (XXII-XXOO)**2 + (YYII-YYOO)**2
          IF(ZW1.GT.ZW0 .OR. ZW2.GT.ZW0) XREPEAT
C
N         CALCULATE CIRCLE FROM3 POINTS
C
C
N         1. + LAST POINT + AVERAGE
          XOA = ( XXII + XXOO ) *.5
          YOA = ( YYII + YYOO ) *.5
N         DIRECTIONS FOR TRANSFORMATION
          COSTH = XXOO - XXII
          SINTH = YYOO - YYII
          ZWZ = SQRT(COSTH**2+SINTH**2)
          COSTH = COSTH / ZWZ
          SINTH = SINTH / ZWZ
N         TRANSFORMATIONS OF POINTS
C
          XX = XXII - XOA
          YY = YYII - YOA
          YT1 = 0.
          XT1 =-.5*ZWZ
          XX = XXIO - XOA
          YY = YYIO - YOA
          YT2 = YY * COSTH - XX * SINTH
          XT2 = XX * COSTH + YY * SINTH
          XX = XXOI - XOA
          YY = YYOI - YOA
          YT3 = YY * COSTH - XX * SINTH
          XT3 = XX * COSTH + YY * SINTH
          XX = XXOO - XOA
          YY = YYOO - YOA
          YT4 = 0.
          XT4 =-XT1
C
N       SELECT CENTRAL POINT
          IF ABS(XT2).LT.ABS(XT3)
          THEN
            X1 = XT1
            Y1 = YT1
            X2 = XT2
            XC = XT2
            Y2 = YT2
            YC = YT2
            XL = XT3
            YL = YT3
          ELSE
            X1 = XT3
            XC = XT3
            Y1 = YT3
            YC = YT3
            X2 = XT4
            Y2 = YT4
            XL = XT2
            YL = YT2
          CIF
N         INTERSECT WITH Y-AXIS
          X0 = 0.
          Y0 = 1000000.
          DY = Y2 - Y1
          IF(ABS(DY).GT..01)
     *       Y0 = ((X2-X1)*(X2+X1)/DY + Y2+Y1)*.5
          T  = Y0 - YC
          R0 = ABS(T)
          CHARGE = SIGN(1.,T)
          R0 = .5*(R0 + ((Y0-YC)**2+XC**2) / R0)
          DR0 = (XL**2-XC**2 + (Y0-YL)**2-(Y0-YC)**2)*.5/R0
          DSQ = .75*DR0**2
          XCIRC = X0*COSTH - Y0*SINTH + XOA
          YCIRC = Y0*COSTH + X0*SINTH + YOA
N         LENGTH/R RATIO
          ALGHT = ABS(XT1)*2.
          ALRAT = AMAX1(ALGHT,ALGHT0) / R0
N         WIDEN LIMIT FOR LOW ENERGY TRACKS
          DRLIM1 = AMAX1(ALRAT,1.)*CBTRLM(4) + DRLIM
C2002 FORMAT(' COMBA.:',3I6,F8.2,F8.5,5F8.3)
C2005 FORMAT(' COMBR:',10F10.1,/,7X,10F10.1)
      IF(JPTRI.GE.IPR1) NPR = NPR + 1
C     IF(JPTRI.GE.IPR1 .AND. NPR.LE.NPR9)
C    ,PRINT 2005, X1,Y1,X2,Y2,XC,YC,X0,Y0,T,R0,DR0,DSQ
C    ,           ,XCIRC,YCIRC ,DRLIM,DRLIM1,ALGHT,ALRAT
C
N         CHECK IF GOOD CONNECTION
          IF(ABS(DR0).GT.DRLIM1) XREPEAT
          NCAND = 2
C
N         CALC. TANGENTIAL ANGLES
          IF ABS(XXIO-XCIRC).LT.ABS(YYIO-YCIRC)
          THEN
            TG1  = DYII / DXII
            TGC1 =-(XXII-XCIRC) / (YYII-YCIRC)
            TG2  = DYIO / DXIO
            TGC2 =-(XXIO-XCIRC) / (YYIO-YCIRC)
            TG3  = DYOI / DXOI
            TGC3 =-(XXOI-XCIRC) / (YYOI-YCIRC)
            TG4  = DYOO / DXOO
            TGC4 =-(XXOO-XCIRC) / (YYOO-YCIRC)
          ELSE
            TG1  = DXII / DYII
            TGC1 =-(YYII-YCIRC) / (XXII-XCIRC)
            TG2  = DXIO / DYIO
            TGC2 =-(YYIO-YCIRC) / (XXIO-XCIRC)
            TG3  = DXOI / DYOI
            TGC3 =-(YYOI-YCIRC) / (XXOI-XCIRC)
            TG4  = DXOO / DYOO
            TGC4 =-(YYOO-YCIRC) / (XXOO-XCIRC)
          CIF
N         DIFF. OF ANGLES
          DLTS1 = (TG1-TGC1) / (1.+TG1*TGC1)
          DLTS2 = (TG2-TGC2) / (1.+TG2*TGC2)
          DLTS3 = (TG3-TGC3) / (1.+TG3*TGC3)
          DLTS4 = (TG4-TGC4) / (1.+TG4*TGC4)
          DLTSQ1 = DLTS1**2
          DLTSQ2 = DLTS2**2
          DLTSQ3 = DLTS3**2
          DLTSQ4 = DLTS4**2
          DELTSQ = DLTSQ1 + DLTSQ2 + DLTSQ3 + DLTSQ4
C     IF(JPTRI.GE.IPR1 .AND. NPR.LE.NPR9)
C    ,PRINT 2002, JPTRI,JPTRO,LRFLAG,DSQ,DELTSQ,
C    ,    DLTS1,DLTS2,DLTS3,DLTS4,DANGL
          IF(AMAX1(DLTSQ1,DLTSQ2,DLTSQ3,DLTSQ4).GT.DANGL) XREPEAT
          RMS = (DSQ/.06 + DELTSQ/.0020) * .2
          IF(RMS.LT.RMSMZW) RMSMZW = RMS
          NCAND = RMS
          IF(NCAND.GE.256) NCAND = 255
C
N         CHECK IF SPACE FOR NEW COMB.
          IF IWRK(JPTRO+20).LT.8 .AND.
     ?       IWRK(JPTRI+21).LT.8 .AND. NCOMB.LT.2
          THEN
C     PRINT 2990, JPTRI,JPTRO,LRFLAG,NCAND,IWRK(JPTRI+21),IWRK(JPTRO+20)
C2990 FORMAT(' COMB:',20I6)
C
N           KEEP ADDRESS OF GOOD CONNECTION
N           COUNT COMBINATION
            NCOMB = NCOMB + 1
            HZW(1) = JPTRO
            HZW(2) = LRFLAG - 1 + NCAND*16
            NCNTRI = IWRK(JPTRI+21) + 1
            IWRK(JPTRI+NCNTRI+29) = IZW
            IWRK(JPTRI+21) = NCNTRI
            HZW(1) = JPTRI
            NCNTRO = IWRK(JPTRO+20) + 1
            IWRK(JPTRO+NCNTRO+21) = IZW
            IWRK(JPTRO+20) = NCNTRO
          CIF
        UNTIL .TRUE.
      CPROC
C
N     ***************************
N     *      O R D E R          *
N     ***************************
C
N     ORDER MULT. CONNECTIONS
N     CLOSEST CONNECT. FIRST
C
      PROC ORDER
C
N       LOOP OVER ALL CONNECTIONS
        IPTR = HPTE0
        REPEAT
N         CHECK IF >1 DOWN-CONNECTION
          NCNT= IWRK(IPTR+20)
          IP0 = IPTR+22
          IF NCNT.GT.1
          THEN
            ORFACT =-1.
            PERFORM ORDCNT
          CIF
N         CHECK IF >1 UP-CONNECTION
          NCNT= IWRK(IPTR+21)
          IP0 = IPTR+30
          IF NCNT.GT.1
          THEN
            ORFACT =+1.
            PERFORM ORDCNT
          CIF
        IPTR = IPTR + HLDTE
        UNTIL IPTR.GT.HPTE9
      CPROC
C
N     ***************************
N     *      O R D C N T        *
N     ***************************
C
N     ORDER MULT. CONNECTIONS
C
      PROC ORDCNT
C
N     STORE CONNECT. IN IAUX-ARRAY
      CALL MVC(IAUX(1),0,IWRK(IP0),0,32)
N     LOOP OVER DOWN CONNECT.
      LBORD = 0
      FOR I=1,NCNT
        IZW = IAUX(I)
        IPCN = HZW1
        IF LAND(IZW,2).EQ.0
        THEN
          RSQ = WRK(IPCN+11)**2 + WRK(IPCN+12)**2
        ELSE
          RSQ = WRK(IPCN+15)**2 + WRK(IPCN+16)**2
        CIF
        RAUX(I) = RSQ
        IF(I.GT.1 .AND. (RSQ-RAUX(I-1))*ORFACT.LT.0) LBORD = 1
      CFOR
C
N     CHECK IF CONNECT. TO BE REORDERED
      IF LBORD.NE.0
      THEN
N       CHECK IF ONLY 2 CONNECT.
        IF NCNT.EQ.2
        THEN
            IWRK(IP0  ) = IAUX(2)
            IWRK(IP0+1) = IAUX(1)
        ELSE
N         COMPARE ALL COMB. WITH EACH OTHER
          LBORD = 0
          NCNT9 = NCNT - 1
          FOR I1=1,NCNT9
            NCNT1 = I1 + 1
            FOR I2=NCNT1,NCNT
N             CHECK LOWEST R FIRST
              IF (RAUX(I2)-RAUX(I1))*ORFACT .LT. 0.
              THEN
N               INTERCHANGE COMB.
                IZW = IAUX(I2)
                IAUX(I2) = IAUX(I1)
                IAUX(I1) = IZW
                ZW  = RAUX(I2)
                RAUX(I2) = RAUX(I1)
                RAUX(I1) = ZW
              CIF
            CFOR
          CFOR
C
N         FINAL INTERCHANGE
          CALL MVC(IWRK(IP0),0,IAUX(1),0,32)
        CIF
      CIF
      CPROC
C
      END
C   10/02/80 102191151  MEMBER NAME  CIRCCK   (PATRECSR)    SHELTRAN
      SUBROUTINE CIRCCK(MTREL0,IATREL,RSLT)
C
      IMPLICIT INTEGER*2 (H)
      LOGICAL TBIT
C
C     SUBROUTINE TO ELIMINATE DOUBLE CONNECT. OF TRELS
C     AUTHOR: P. STEFFEN(78/11/21)
C
C     INPUT : IATREL(1) = # OF TRELS
C             IATREL(2) = POINTER TO 1. TREL
C             IATREL(3) = POINTER TO 2. TREL
C
C     OUTPUT: RSLT(1) = R
C             RSLT(2) = XCIRC
C             RSLT(3) = YCIRC
C             RSLT(4) = SIGMA
C             RSLT(5) = DEG. OF FREEDOM
C             RSLT(6) = LENGTH / R
C             RSLT(7) = SIGMA(DIRECTIONS)
C             RSLT(8) = #(CELLS)*200 / R
C
      DIMENSION IATREL(1),RSLT(6),HATREL(24)
C
#include "cpatlm.for"
C
#include "cworkpr.for"
#include "cworkeq.for"
      EQUIVALENCE
     ,           (ICELL ,IDWRK(1)),(NHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
     ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
C
N     COORDINATE ARRAYS FOR CIRCLE FIT
      DIMENSION XO(20),YO(20), XT(20),YT(20)
C
N     FUNCTION
      FPAR (X) = (PAR1 *X + PAR2 )*X + PAR3
C
C2000 FORMAT('0FXYZPS:',12(I7,I3))
C2001 FORMAT('     XO:',I6,2F8.3,/,(8X,I6,2F8.3))
C2002 FORMAT('     XT:',I6,2F8.1,/,(8X,I6,2F8.1))
C2003   FORMAT(' CIRCLE:',10E12.5,/,(8X,10E12.5))
C2004     FORMAT(' LOOP(TILT):',I3,3F10.2,5E13.5)
C2005   FORMAT(' TILT + DX:',5E13.5)
C2006     FORMAT(' LOOP(SAG):',I3,3F10.2,5E13.5)
C2007   FORMAT(' B + DSAG:',5E13.5)
C2008     FORMAT(' RESIDUALS:',I3,5F10.2,3E13.5)
C2009   FORMAT(' AVERAGE + SIGMA:',9E13.5)
C2010   FORMAT(' SAG.CORR:', 8E13.5)
C2902 FORMAT('0PARABEL FIT',4F12.5,4F12.2,F8.2)
C2991 FORMAT(1X,3F10.1,F8.2,F3.0,F8.3)
C
        DATA NPR /0/
        NPR = NPR + 1
C
N     # OF TREL
      MTREL = IABS(MTREL0)
C
N     SAVE MAX(SIGMA)
      SIGDV0 = RSLT(4)
C     LBPR = IATREL(1)
C     LBPR = SHFTR(IPPR,16)
C
C
N     ***************************
N     *      F X Y Z            *
N     ***************************
C
N     GET COORDINATES OF TRELS
C
C     LBPR = 0
      IP = 0
      ITREL = MTREL
      REPEAT
N       POINTER TO COORDINATE ARRAY
        JPTREL = IATREL(ITREL)
        IPTREL = SHFTR(JPTREL,16)
C       IF(IPTREL.EQ.2817 .OR. IPTREL.EQ.1905) LBPR = LBPR + 1
N       CHECK IF LEFT /RIGHT SOLUTION
        IF LAND(JPTREL,1).EQ.0
        THEN
          XO(IP+1) = WRK(IPTREL+ 3)
          XO(IP+2) = WRK(IPTREL+11)
          YO(IP+1) = WRK(IPTREL+ 4)
          YO(IP+2) = WRK(IPTREL+12)
        ELSE
          XO(IP+1) = WRK(IPTREL+ 7)
          XO(IP+2) = WRK(IPTREL+15)
          YO(IP+1) = WRK(IPTREL+ 8)
          YO(IP+2) = WRK(IPTREL+16)
        CIF
C
N       CHECK IF BOTH POINTS GOOD
        IF LAND(JPTREL,12).EQ.0
        THEN
N         BOTH POINTS
N         CHECK IF POINTS TO BE REVERSED
          IF MTREL0.LT.0
          THEN
            ZWZ = XO(IP+1)
            XO(IP+1) = XO(IP+2)
            XO(IP+2) = ZWZ
            ZWZ = YO(IP+1)
            YO(IP+1) = YO(IP+2)
            YO(IP+2) = ZWZ
          CIF
          IP = IP + 2
        ELSE
N         ONLY 1 POINT GOOD
          IF LAND(JPTREL, 4).NE.0
          THEN
N           1. POINT BAD
            XO(IP+1) = XO(IP+2)
            YO(IP+1) = YO(IP+2)
          CIF
          IP = IP + 1
        CIF
      ITREL = ITREL - 1
      UNTIL ITREL.EQ.0
      IP9 = IP
      IP8 = IP - 1
C     IF(MTREL.NE.2) LBPR = 0
C     IF(LBPR.EQ.2)
C    ,PRINT 2001, (I1,XO(I1),YO(I1),I1=1,IP9)
C
C
N     ***************************
N     *      T R A N S F        *
N     ***************************
C
N     TRANSFORM COORDINATES
C
N       1. + LAST POINT + AVERAGE
        X1 = XO(  1)
        X2 = XO(IP9)
        Y1 = YO(  1)
        Y2 = YO(IP9)
        XOA = ( X1 + X2 ) / 2
        YOA = ( Y1 + Y2 ) / 2
N       DIRECTIONS FOR TRANSFORMATION
        COSTH = X2 - X1
        SINTH = Y2 - Y1
        SUMX = 1.0 / SQRT(COSTH**2+SINTH**2)
        COSTH = COSTH * SUMX
        SINTH = SINTH * SUMX
N       TRANSFORMATIONS OF POINTS
N       + SEARCH FOR CENTRAL POINT
        DMIN = 1000000.
        FOR IP=1,IP9
          XX = XO(IP) - XOA
          YY = YO(IP) - YOA
          YT(IP) = YY * COSTH - XX * SINTH
          XT(IP) = XX * COSTH + YY * SINTH
          DX = ABS(XT(IP))
          IF DX.LT.DMIN
          THEN
            DMIN = DX
            IPA = IP
          CIF
        CFOR
N       CENTRAL POINT
        XC = XT(IPA)
        YC = YT(IPA)
C     IF(LBPR.EQ.2)
C    ,PRINT 2002, (I1,XT(I1),YT(I1),I1=1,IP9)
C
C
N     ***************************
N     *      P A R A B          *
N     ***************************
N         DO PARABOLA FIT
C
C
N     GET EQUATIONS
      S1 = 0.
      S2 = 0.
      S3 = 0.
      S4 = 0.
      S5 = 0.
      S6 = 0.
      S7 = 0.
      FOR IP = 1,IP9
        X = XT(IP)
        Y = YT(IP)
        X2 = X**2
        S1 = S1 + X
        S2 = S2 + X2
        S3 = S3 + X*X2
        S4 = S4 + X2**2
        S5 = S5 + Y*X2
        S6 = S6 + Y*X
        S7 = S7 + Y
      CFOR
      S0 = IP9
N     SOLVE EQUATIONS FOR PARABOLA FIT
      F1 = 1. / S4
      XX12 = S3*F1
      XX13 = S2*F1
      YY1  = S5*F1
      XX22 = S2 - S3*XX12
      XX23 = S1 - S3*XX13
      YY2  = S6 - S3*YY1
      XX32 = S1 - S2*XX12
      XX33 = S0 - S2*XX13
      YY3  = S7 - S2*YY1
      IF XX22.GT.XX32
      THEN
        XX23 = XX23 / XX22
        YY2  = YY2  / XX22
        PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
        PAR2 = YY2 - XX23*PAR3
      ELSE
        XX33 = XX33 / XX32
        YY3  = YY3  / XX32
        PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
        PAR2 = YY3 - XX33*PAR3
      CIF
      PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
C
N     CALC. CIRCLE PARAMETERS
      XCIRC =-.5 * PAR2 / PAR1
      YZW   = FPAR(XCIRC)
      R0 = SIGN(1.E6,PAR1)
      IF(ABS(PAR1).GT..5E-6) R0 = .5 / PAR1
      YCIRC = R0 + YZW
      R0 = ABS(R0)
C     IF(LBPR.EQ.2) PRINT 2902, PAR1,PAR2,PAR3,XCIRC,YZW,YCIRC,R0,SIG
C
C
N     CHECK IF R > 2000 MM
      IF R0.GT.2000.
      THEN
C
N       ===================================
N       =  R > 2000 ... PARABOLA IS GOOD  =
N       ===================================
C
C
N       CALC. ERROR
        SUM2 = 0.
        ZW1 = R0**2
        ZW2 = .5/R0
        FOR IP=1,IP9
          F = FPAR(XT(IP))
          DR = YT(IP) - F
          SUM2 = SUM2 + DR**2
        CFOR
N       AVERAGE + SIGMA
        SIG = SQRT(SUM2/(IP9-3))
        DX = 0.
C     IF(LBPR.EQ.2) PRINT 2902, PAR1,PAR2,PAR3,XCIRC,YZW,YCIRC,R0,SIG
      ELSE
C
N       ===================================
N       =   R < 2000 ... TRY CIRCLE FIT   =
N       ===================================
C
C
N       ***************************
N       *      C I R C L 1        *
N       ***************************
C
N       CALC. CIRCLE FROM 3 POINTS
N
N       SELECT 1. OR 2. BRANCH
        IF XC.LT.0.
        THEN
          X2 = XC
          Y2 = YC
          X1 = XT(  1)
          Y1 = YT(  1)
        ELSE
          X1 = XC
          Y1 = YC
          X2 = XT(IP9)
          Y2 = YT(IP9)
        CIF
N       INTERSECT WITH Y-AXIS
        XCIRC = 0.
        YCIRC = 100000.
        DY = Y2 - Y1
        IF(ABS(DY).GT..01)
     *     YCIRC = ((X2-X1)*(X2+X1)/DY + Y2+Y1)*.5
        IF(ABS(YCIRC).GT.100000.) YCIRC = SIGN(100000.,YCIRC)
        T  = YCIRC - YC
        R0 = ABS(T)
        CHARGE = SIGN(1.,T)
        R0 = .5*(R0 + ((YCIRC-YC)**2+XC**2) / R0)
C     IF(LBPR.EQ.2)
C    ,PRINT 2003, X1,Y1,X2,Y2,XC,YC,XCIRC,YCIRC,T,R0
C
N     **********************************
N     *  2 TRIALS IF CHANGE OF CHARGE  *
N     **********************************
C
      NTRIAL = 0
      REPEAT
      NTRIAL = NTRIAL + 1
C
N     ***************************
N     *      T I L T C R        *
N     ***************************
C
N     TILT CORRECTION
C
N       CALCULATE AVERAGE TILT
        SUM1 = 0.
        SUM2 = 0.
        SUM3 = 0.
        SUM4 = 0.
        ZW1 = R0**2
        ZW2 = .5/R0
        FOR IP=1,IP9
          XZW = XT(IP)
          YZW = (XZW**2+(YT(IP)-YCIRC)**2 - ZW1) * ZW2
          SUM1 = SUM1 + XZW
          SUM2 = SUM2 + XZW**2
          SUM3 = SUM3 + XZW*YZW
          SUM4 = SUM4 + YZW
C     IF(LBPR.EQ.2)
C    ,PRINT 2004, IP,XT(IP),YT(IP),YZW,SUM1,SUM2,SUM3,SUM4
        CFOR
N       AVERAGE TILT
        TILT = (SUM3*IP9-SUM1*SUM4) / (SUM2*IP9-SUM1**2)
        DR0  = (SUM4 - TILT*SUM1)/IP9
N       MODIFY RADIUS
        R0 = R0 + DR0
        DX =-TILT*R0
C     IF(LBPR.EQ.2)
C    ,PRINT 2005, TILT,DR0,DX
C
C
N     ***************************
N     *      R A D C R          *
N     ***************************
C
N     RADIAL CORRECTION
C
N       DET. CHANGE OF SAGITTA BY PARABOLA FIT
N       DR = DSAG/2 + B*X**2
        SUM1 = 0.
        SUM2 = 0.
        SUM3 = 0.
        SUM4 = 0.
        ZW1 = R0**2
        ZW2 = .5/R0
        FOR IP=1,IP9
N         APPLY TILT CORRECTION
          XT(IP) = XT(IP) + DX
          XZW = XT(IP)**2
          YZW = (XZW+(YT(IP)-YCIRC)**2 - ZW1) * ZW2
          SUM1 = SUM1 + XZW
          SUM2 = SUM2 + XZW**2
          SUM3 = SUM3 + XZW*YZW
          SUM4 = SUM4 + YZW
C     IF(LBPR.EQ.2)
C    ,PRINT 2006, IP,XT(IP),YT(IP),YZW,SUM1,SUM2,SUM3,SUM4
        CFOR
N       PARAMETER
        B = (SUM3*IP9-SUM1*SUM4) / (SUM2*IP9-SUM1**2)
        DSAG = (SUM4 - B*SUM1)*2. / IP9
C     IF(LBPR.EQ.2)
C    ,PRINT 2007, B,DSAG
N       CHANGE YCIRC ACCORDINGLY
        SAG = (XT(IP9)-XT(1))**2 * .125/R0
        DR0 =-R0*DSAG/SAG
N       SET DRO=0. IF DSAG/SAG > 0.2
        IF(ABS(DSAG/SAG) .GT. 0.2) DR0 = 0.
        R0ZW  = DR0 + R0
        YCZW  = CHARGE*DR0 + YCIRC
N       CHECK IF CHANGE OF CHARGE
        IF ABS(YCZW).LT.100000. .AND. ABS(DR0).LT.100000.
        THEN
          YCIRC = YCZW
          R0    = R0ZW
          LBCHCH= 0
        ELSE
          LBCHCH= 1
        CIF
C     IF(LBPR.EQ.2)
C    ,PRINT 2010, SAG,YCIRC,R0,DR0
C
N     ***************************
N     *      R M S C A L        *
N     ***************************
C
N     CALCULATIONS OF RMS
C
N       CALCULATE AVERAGE + SIGMA
        SUM1 = 0.
        SUM2 = 0.
        ZW1 = R0**2
        ZW2 = .5/R0
        FOR IP=1,IP9
          DR = ((XT(IP)-XCIRC)**2+(YT(IP)-YCIRC)**2 - ZW1) * ZW2
          SUM1 = SUM1 + DR
          SUM2 = SUM2 + DR**2
C     IF(LBPR.EQ.2)
C    ,PRINT 2008, IP,XT(IP),YT(IP),DR,SUM1,SUM2,R0,ZW1,ZW2
        CFOR
N       AVERAGE + SIGMA
        DR0 = SUM1 / IP9
        R0 = R0 + DR0
        YCIRC = YCIRC + DR0*CHARGE
        SIG = 0.
        IF(IP9.GT.3) SIG = SQRT(ABS(SUM2/IP9 - DR0**2)*IP9/(IP9-3))
        SIG0= SQRT(SUM2/IP9)
C
N       CHECK IF CHANGE OF CHARGE
        IF(LBCHCH.EQ.0) XREPEAT
N       STOP AFTER 2. TRIAL
        IF(NTRIAL.GT.1) XREPEAT
C
N       SAVE CIRCLE PARAMETERS OF 1. TRIAL1
        YCSAV = YCIRC
        DXSAV = DX
        SGSAV = SIG0
        R0SAV = R0
        CHSAV = CHARGE
C
N       SET NEW START PARAMETERS
        YCIRC  = -YCIRC
        R0     = ABS(YCIRC)
        CHARGE =-CHARGE
        FOR IP=1,IP9
          XT(IP) = XT(IP) - DX
        CFOR
      UNTIL .FALSE.
C
N     SELECT RESULTS IF 2 TRIALS
      IF NTRIAL.GT.1 .AND. SIG0.GT.SGSAV
      THEN
N       RESTORE CIRCLE PARAMETERS OF 1. TRIAL1
        YCIRC  = YCSAV
        DX     = DXSAV
        SIG0   = SGSAV
        R0     = R0SAV
        CHARGE = CHSAVE
      CIF
C
      CIF
C
N     TRANSFORM BACK TO INPUT SYSTEM
      XX = XCIRC - DX
      YY = YCIRC
      X0 = XX * COSTH - YY * SINTH + XOA
      Y0 = YY * COSTH + XX * SINTH + YOA
N     L/R RATIO
      RATLR = ABS(XT(1)*2. / R0)
C
N     ***************************
N     *      S I G A N G        *
N     ***************************
C
N     CALC. SIGMA(DIRECTIONS OF TRELS)
C
N     INITIALIZE SIGMA
      SGANG  = 0.
      RATCR  = 0.
C
N     CHECK IF REASONABLE FIT
      IF SIG.LE.SIGDV0
      THEN
N       GOOD FIT: GET DIRECTIONS OF TRELS
        NCLL  = 0
        ICLL0 = 0
        IP = 0
        ITREL = MTREL
        REPEAT
N         POINTER TO COORDINATE ARRAY
          JPTREL = IATREL(ITREL)
          IPTREL = SHFTR(JPTREL,16)
N         COUNT # OF CELLS
          ICLL = IWRK(IPTREL)
          IF(ICLL.NE.ICLL0) NCLL = NCLL + 1
C     IF(NPR.LE.5) PRINT 2901,ICLL0,ICLL,NCLL,IPTREL
          ICLL0 = ICLL
N         CHECK IF LEFT /RIGHT SOLUTION
          IF LAND(JPTREL,1).EQ.0
          THEN
            XO(IP+1) = WRK(IPTREL+ 3)
            XO(IP+2) = WRK(IPTREL+11)
            YO(IP+1) = WRK(IPTREL+ 4)
            YO(IP+2) = WRK(IPTREL+12)
            XT(IP+1) = WRK(IPTREL+ 5)
            XT(IP+2) = WRK(IPTREL+13)
            YT(IP+1) = WRK(IPTREL+ 6)
            YT(IP+2) = WRK(IPTREL+14)
          ELSE
            XO(IP+1) = WRK(IPTREL+ 7)
            XO(IP+2) = WRK(IPTREL+15)
            YO(IP+1) = WRK(IPTREL+ 8)
            YO(IP+2) = WRK(IPTREL+16)
            XT(IP+1) = WRK(IPTREL+ 9)
            XT(IP+2) = WRK(IPTREL+17)
            YT(IP+1) = WRK(IPTREL+10)
            YT(IP+2) = WRK(IPTREL+18)
          CIF
C
C         CHECK IF BOTH POINTS GOOD
          IF LAND(JPTREL,12).EQ.0
          THEN
N           BOTH POINTS GOOD; CHECK IF >5 HITS ON TREL
            IF IABS(IWRK(IPTREL+2)).GT.5
            THEN
N             USE BOTH SLOPES
              IP = IP + 2
            ELSE
N             SHORT TREL: USE AVERAGE SLOPE ONLY
              XT(IP+1) = (XT(IP+1)+XT(IP+2)) * .5
              YT(IP+1) = (YT(IP+1)+YT(IP+2)) * .5
              XO(IP+1) = (XO(IP+1)+XO(IP+2)) * .5
              YO(IP+1) = (YO(IP+1)+YO(IP+2)) * .5
              IP = IP + 1
            CIF
          ELSE
N           ONLY 1 POINT GOOD
            IF LAND(JPTREL, 4).NE.0
            THEN
N             1. POINT BAD
              XT(IP+1) = XT(IP+2)
              YT(IP+1) = YT(IP+2)
            CIF
            IP = IP + 1
          CIF
        ITREL = ITREL - 1
        UNTIL ITREL.EQ.0
        IP9 = IP
        IP8 = IP - 1
C     IF(NPR.LT.40)
C    ,PRINT 2001, (I1,XO(I1),YO(I1),I1=1,IP9)
C     IF(NPR.LT.40)
C    ,PRINT 2001, (I1,XT(I1),YT(I1),I1=1,IP9)
C
N       CALC. SIGMA(DIRECTIONS)
        FOR IP=1,IP9
          DX = XT(IP)
          DY = YT(IP)
          XX = XO(IP)
          YY = YO(IP)
C
N         CALC. TANGENTIAL ANGLES
          IF ABS(XX-X0).LT.ABS(YY-Y0)
          THEN
            TG1  = DY / DX
            TGC1 =-(XX-X0) / (YY-Y0)
          ELSE
            TG1  = DX / DY
            TGC1 =-(YY-Y0) / (XX-X0)
          CIF
N         DIFF. OF ANGLES
          DLTS1 = ABS((TG1-TGC1) / (1.+TG1*TGC1))
          SGANG  = DLTS1**2 + SGANG
        CFOR
        SGANG  = SQRT(SGANG/FLOAT(IP9))
        RATCR  = NCLL*200. / R0
      CIF
C
N     ***************************
N     *    STORE   RESULTS      *
N     ***************************
      RSLT(1) = R0
      RSLT(2) = X0
      RSLT(3) = Y0
      RSLT(4) = SIG
      RSLT(5) = IP9 - 3
      RSLT(6) = RATLR
      RSLT(7) = SGANG
      RSLT(8) = RATCR
C     IF(LBPR.EQ.2)
C    ,PRINT 2009, DR0,SIG,SIG0,XCIRC,YCIRC,R0
C     IF(LBPR.EQ.2)
C    ,PRINT 2991, RSLT
C
      RETURN
C
      END
C   29/07/80 102191150  MEMBER NAME  CKTRKO   (PATRECSR)    SHELTRAN
      SUBROUTINE CKTRKO(LBTRCK,LBCELL)
C
C        CHECK TRACK FROM ORIGIN
C        P. STEFFEN                    29/07/80
C
      IMPLICIT INTEGER*2 (H)
C
#include "cdata.for"
#include "ccycp.for"
C
#include "cworkpr.for"
#include "cworkeq.for"
C
      EQUIVALENCE
     ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
     ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
     ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
C
#include "cpatlm.for"
C
#include "cjdrch.for"
#include "cdsmax.for"
C
N     MASKS FOR HITS IN LAYERS OF JETC
      INTEGER MKLY(16) /1,2,4,8,16,32,64,128,256,512,1024,2048,
     ,                  Z1000,Z2000,Z4000,Z8000/
C
N     MASKS FOR DEAD CELL BITS
      INTEGER MKDDCL(3) /Z01,Z02,Z04/, LBDDCL /ZFFFF/
C
N     MASK FOR TRACKS AT CELL WALL
      INTEGER MKBDCL(3) /Z10,Z20,Z40/
C
N     ROAD LIMITS
      REAL RDLIM(5,2) / -2.0, -1.0, 1.0, 2.0, 8.5,
     ,                  -3.0, -2.0, 2.0, 3.0, 8.5/
C
N     INITIALIZE INDEX FOR ROAD LIMITS
      DATA INDLM /-1/
C
      DIMENSION  LBHT(15)
C
C2001 FORMAT('0ROAD LIMITS:',I2,5F6.1)
C2003 FORMAT(' CKTRK:',3I3,5X,5(1X,Z4),5X,5(1X,Z4),5X,5(1X,Z4))
C2005 FORMAT('0TRACK:',I6,/,(1X,3I6,4F8.1,I4,F6.2,2I4,F8.3,I6,F8.1))
C
N     INITIALIZE RETURN LABEL
      LBTRCK = 0
C
N     INITIALIZE LABELS
      CALL SETS(LBHT(1),0,60,0)
C
N     LOOP OVER ALL HITS + SET BITS FOR HITS IN LAYERS
N     PREVIOUS RING #
      JRING0 = 0
      FOR IP = HPCO0,HPCO9,HLDCO
        ILAY   = IWRK(IP   )
        JRING  = IWRK(IP+12)
        LBGOOD = IWRK(IP+ 7)
        DF     = WRK (IP+13)*IWRK(IP+2)
C
N       CHECK IF RING # CHANGES
        IF JRING.NE.JRING0
        THEN
          JRING0 = JRING
N         SET INDEX FPOR ROAD LIMITS
          INDLM1 = 1
          IF(LAND(MKBDCL(JRING),LBCELL).NE.0) INDLM1 = 2
N         CHANG LIMITS IF NEW INDEX
          IF INDLM1.NE.INDLM
          THEN
            INDLM = INDLM1
            RDLM1 = RDLIM(1,INDLM)
            RDLM2 = RDLIM(2,INDLM)
            RDLM3 = RDLIM(3,INDLM)
            RDLM4 = RDLIM(4,INDLM)
            RDLM5 = RDLIM(5,INDLM)
C     PRINT 2001, INDLM,RDLM1,RDLM2,RDLM3,RDLM4,RDLM5
          CIF
        CIF
C
N       EXCLUDE DOUBLE HITS FROM L/R AMB.
        IF LBGOOD .NE. 16
        THEN
N         SET LBGOOD
          LBGOOD = 1
          IF(DF.LE. RDLM1 .OR.  DF.GE. RDLM5) LBGOOD = 5
          IF(DF.GE. RDLM1 .AND. DF.LT. RDLM2) LBGOOD = 2
          IF(DF.GE. RDLM3 .AND. DF.LT. RDLM4) LBGOOD = 3
          IF(DF.GE. RDLM4 .AND. DF.LT. RDLM5) LBGOOD = 4
          INDEX = JRING*5 - 5 + LBGOOD
          LBHT(INDEX) = LOR(LBHT(INDEX),MKLY(ILAY+1))
        CIF
      CFOR
C
N
      LMGAP = 3
      MGAP  = 0
      MGAP1 = 0
      MGAPM = 0
      MCON  = 0
      ILAYR = 0
      ILLST = 0
      NHGD  = 0
N     LABEL FOR BIG GAP AT CELL BOUND
      LBOUND = 0
C
N     LOOP OVER ALL RINGS + LAYERS
      JRING = 0
      REPEAT
      JRING = JRING + 1
        INDEX = JRING*5 - 5
        NHGC  = 0
        NHTRC = 0
        LB1   = LBHT(INDEX + 1)
N       COVER SINGLE MISSING GOOD HITS
        PERFORM CKGDHT
C
        LB2   = LBHT(INDEX + 2)
        LB3   = LBHT(INDEX + 3)
C
N       LABEL FOR COVERED HITS
        LB4   = LBHT(INDEX + 4)
N       SET BITS FOR COVERED HITS IF DEAD CELL
        IF(LAND(MKDDCL(JRING),LBCELL).NE.0) LB4 = LBDDCL
C
        LB5   = LBHT(INDEX + 5)
        LBCV  = LOR(  LB3,  LB4)
C
N       CONSISTENCY CHECK OF COVERED HITS
        IF LBCV.NE.0
        THEN
          PERFORM CKCVHT
        CIF
C
        LBGC  = LOR( LBCV,  LB1)
        LBTRC = LOR( LBGC,  LB2)
        LBHIT = LOR(LBTRC,  LB4)
C
        IL = 0
        WHILE IL.LT.16
        IL    = IL    + 1
        ILAYR = ILAYR + 1
          MKLY1 = MKLY(IL)
          IF LAND(LBGC,MKLY1).EQ.0
          THEN
N           COUNT GAPS EXCEPT LAYERS 1,2,15,16
            IF IL.GT.2 .AND. IL.LT.15
            THEN
              MGAP  = MGAP  + 1
              MGAP1 = MGAP1+ 1
              MCON  = 0
            CIF
          ELSE
            NHGC  = NHGC + 1
            MCON  = MCON + 1
            IF MCON.GE.2 .OR. MGAP1.EQ.1
            THEN
              MGAP  = 0
              MGAPM = 0
              ILLST = ILAYR
              IF(MCON.EQ.4) LBOUND = 0
            CIF
            MGAPM = MAX0(MGAPM,MGAP1)
            MGAP1 = 0
          CIF
          IF(LAND(LBTRC,MKLY1).NE.0) NHTRC = NHTRC + 1
          IF(LAND(LB1  ,MKLY1).NE.0) NHGD  = NHGD  + 1
          IF MGAPM.GE.4 .OR. MGAP.GE.6
          THEN
N           CHECK IF GAP AT CELL BOUND
            LBACC = 0
            IF(LAND(MKBDCL(JRING),LBCELL).NE.0 .AND. MGAPM.LE.6
     ?         .AND. MGAP.LE.7) LBACC = 1
C           IF(IL.GE.15 .OR. IL.LE.5) LBACC = 1
            IF LBACC.NE.0
            THEN
              LBOUND = 1
              ILLSTB = ILLST
            ELSE
              LBTRCK = ILLST
              XREPEAT
            CIF
          CIF
        CWHILE
C
N       CHECK # OF HITS
C       IF NHTRC.LT.10
C       THEN
C         LBTRCK =-JRING*100
C         XREPEAT
C       CIF
      UNTIL JRING.EQ.3
C
      IF(LBTRCK.EQ. 0) LBTRCK = ILLST
      IF(LBOUND.NE. 0) LBTRCK = ILLSTB
      IF(NHGD  .LT. 8 .AND. LBTRCK.GT.0) LBTRCK =-LBTRCK
C     IF(LBTRCK.LE.16) PRINT 2005, ICELL,(WRK(I),I=HPCO0,HPCO9)
C     PRINT 2003, ICELL,LBTRCK,NHGD, LBHT
C
      RETURN
C
C
N     *************************
N     *      M K G D H T      *
N     *************************
C
C
N     ALLOW SINGEL MISSING HIT BETWEEN GOOD ONES
      PROC CKGDHT
C
N       SHIFT LABEL BY 1 BIT
        LBGD2 = SHFTL(LB1 ,1)
C
N       LOOP OVER HITS + DELETE SINGLES
        MKGD1 = 7
        MKGD2 = 5
        MKGD3 = 2
        FOR IL=1,16
          LBZW  = LAND(LBGD2,MKGD1)
          IF LBZW.EQ.MKGD2
          THEN
            LBGD2 = LOR(MKGD3,LBGD2)
          CIF
          MKGD1 = SHFTL(MKGD1,1)
          MKGD2 = SHFTL(MKGD2,1)
          MKGD3 = SHFTL(MKGD3,1)
        CFOR
        LBPR = SHFTR(LBGD2,1)
        LB1  = SHFTR(LBGD2,1)
C
      CPROC
C
C
N     *************************
N     *      C K C V H T      *
N     *************************
C
C
N     CHECK BITS FOR COVERED HITS
      PROC CKCVHT
C
N       SHIFT LABEL BY 1 BIT
        LBCV2 = SHFTL(LBCV,1)
C
N       LOOP OVER HITS + DELETE SINGLES
        MKCV1 = 7
        MKCV2 = 2
        FOR IL=1,16
          LBZW  = LAND(LBCV2,MKCV1)
          IF LBZW.EQ.MKCV2
          THEN
            LBCV2 = LAND(LCOMPL(MKCV2),LBCV2)
          CIF
          MKCV1 = SHFTL(MKCV1,1)
          MKCV2 = SHFTL(MKCV2,1)
        CFOR
        LBCV = SHFTR(LBCV2,1)
C
      CPROC
C
      END
C   12/01/81 102191149  MEMBER NAME  CRTREL   (PATRECSR)    SHELTRAN
      SUBROUTINE CRTREL(IPHT,IERRFL)
C
C     SUBROUTINE FOR CREATION OF 1-HIT TREL
C     PETER STEFFEN  10/ 8/79
C
      IMPLICIT INTEGER*2 (H)
      LOGICAL TBIT
C
#include "cdata.for"
#include "ccycp.for"
C
#include "cworkpr.for"
#include "cworkeq.for"
C
      EQUIVALENCE
     ,           (ICELL ,IDWRK(1)),(NHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
     ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
     ,         , (ITR   ,IDWRK(7)),(ITRNG ,IDWRK(8))
C
N     MASKS TO DELETE TRACK NO. IN HIT LABEL
      DATA MKATR / ZFF01/
N     L/R BIT IN HIT LABEL
      INTEGER  MKLRHT(3) / Z800, Z0, Z900/
C
C2003 FORMAT(1H0,A4,I6,2(/,1X,24I4),/,1X,50I2,
C    ,       90(/,1X,2I6,I3,2F10.3,I3,2F10.3,1X,Z4,2I3))
C2004 FORMAT(1H0,'BACKTR:',5X,20I6)
C2005 FORMAT(1H ,12X,20I6)
C2008 FORMAT(' HIT LABEL OF TRELS:',2I6,/,(12X,20(2X,Z4)))
C
N     PRINTOUT
C     I9 = HNTR
C     PRINT 2003, HPRO,HNTR,HNTCEL,((TRKAR(I1,I2),I2=1,11),I1=1,I9)
C     PRINT 2005, (HRES(I1),I1=1,I9)
C     I0 = HPHL0
C     I9 = HPHL9
C     PRINT 2008, I0,I9,(HWRK(I1),I1=I0,I9)
C
N     CHECK IF ENOUGH SPACE
      IF HNTR.GE.200
      THEN
        IERRFL = -1
        RETURN
      CIF
C
      LBLR = 1
      IF(IPHT.LT.0) LBLR =-1
      IPHT = IABS(IPHT)
      IWIR = HDATA(IPHT)
      IWIR = SHFTR(IWIR,3)
      ICLL = SHFTR(IWIR,4)
      ILAY = LAND(IWIR,15)
      IPTR = HNTCEL(ICLL+2)
      IRNG = ICLL / 24 + 1
      IF(IRNG.GT.3) IRNG = 3
C     PRINT 2005, LBLR,IPHT,IWIR,ICLL,ILAY,IPTR,IRNG
C
N     GET BIGGEST TREL#
      IC1 =  1
      IC9 = 24
      IF(ICLL.GE.24) IC1 = 25
      IF(ICLL.GE.24) IC9 = 48
      IF(ICLL.GE.48) IC1 = 49
      IF(ICLL.GE.48) IC9 = 96
      IP1  = HNTCEL(IC1  )
      IP9  = HNTCEL(IC9+1) - 1
      JTRELM = 1
      IF(IP1.LE.IP9) JTRELM = NTREL(IP9) + 1
C
N     CHECK IF TREL# <128
      IF JTRELM.GE.128
      THEN
        IERRFL = -1
        RETURN
      CIF
C
N     GET TREL #
      NTRL = 1
      IF IPTR.GT.1
      THEN
        NTRL = NTREL(IPTR-1) + 1
        IRNG1 = (IPCL(IPTR-1)-1)/24 + 1
        IF(IRNG1.GT.3) IRNG1 = 3
        IF(IRNG1.NE.IRNG) NTRL = 1
      CIF
C     PRINT 2005, ICLL,IC9,NTRL,JTRELM,IRNG1
C
N     INCREASE REMAINING TREL# IN RING
      IF IPTR.LE.IP9
      THEN
        FOR IP=IPTR,IP9
          NTREL(IP) = NTREL(IP) + 1
        CFOR
C
N       INCREASE TREL# IN HIT LABEL ARRAY
        IPHT0 = (HPTSEC(ICLL+1)-HPTSEC(1))/2 + HPHL0
        IPHT9 = (HPTSEC(IC9 +1)-HPTSEC(1))/2 + HPHL0 - 1
        FOR IP=IPHT0,IPHT9
          LBHIT = HWRK(IP  )
          NTR1 = SHFTR(LBHIT,1)
          NTR1 = LAND(NTR1,127)
          IF(NTR1.GE.NTRL) NTR1 = NTR1 + 1
          LBHIT = LAND(MKATR,LBHIT)
          LBHIT = LOR(LBHIT,SHFTL(NTR1,1))
          HWRK(IP  ) = LBHIT
        CFOR
      CIF
C
N     INCREASE CELL POINTERS
      IC0 = ICLL + 1
      FOR IC=IC0,96
        HNTCEL(IC+1) = HNTCEL(IC+1) + 1
      CFOR
C
N     INCREASE # OF TRELS
      HNTR = HNTR + 1
C
N     MOVE ARRAYS
      IF IPTR.NE.HNTR
      THEN
        IP = HNTR - 1
        REPEAT
          TRKAR(IP+1, 1) = TRKAR(IP, 1)
          TRKAR(IP+1, 2) = TRKAR(IP, 2)
          TRKAR(IP+1, 3) = TRKAR(IP, 3)
          TRKAR(IP+1, 4) = TRKAR(IP, 4)
          TRKAR(IP+1, 5) = TRKAR(IP, 5)
          TRKAR(IP+1, 6) = TRKAR(IP, 6)
          TRKAR(IP+1, 7) = TRKAR(IP, 7)
          TRKAR(IP+1, 8) = TRKAR(IP, 8)
          TRKAR(IP+1, 9) = TRKAR(IP, 9)
          TRKAR(IP+1,10) = TRKAR(IP,10)
          TRKAR(IP+1,11) = TRKAR(IP,11)
          HRES(IP+1) = HRES(IP)
          IP = IP - 1
        UNTIL IP.LT.IPTR
C
N         INCREASE TREL# IN BACKTRACE ARRAY
C
        IF NTR.GT.0
        THEN
C         PRINT 2004,NTR, (HNREL(I1),I1=1,NTR)
C         FOR ITR=1,NTR
C           NELM = HNREL(ITR)
C           PRINT 2005, (HISTR(I1,ITR),I1=1,NELM)
C         CFOR
          FOR ITR=1,NTR
            NELM = HNREL(ITR)
            FOR I=1,NELM
              IELM = HISTR(I,ITR)
              INCR = ISIGN(1,IELM)
              IF(IABS(IELM).GE.IPTR) HISTR(I,ITR) = IELM + INCR
            CFOR
          CFOR
C         PRINT 2004,NTR, (HNREL(I1),I1=1,NTR)
C         FOR ITR=1,NTR
C           NELM = HNREL(ITR)
C           PRINT 2005, (HISTR(I1,ITR),I1=1,NELM)
C         CFOR
        CIF
      CIF
C
N     CREATE TREL
      ITRKAR(IPTR, 1) = IC0
      ITRKAR(IPTR, 2) = 1
      ITRKAR(IPTR, 3) = ILAY
      ITRKAR(IPTR, 4) = 0
      ITRKAR(IPTR, 5) = 0
      ITRKAR(IPTR, 6) = ILAY
      ITRKAR(IPTR, 7) = 0
      ITRKAR(IPTR, 8) = 0
      ITRKAR(IPTR, 9) = 0
      ITRKAR(IPTR,10) = NTRL
      ITRKAR(IPTR,11) = 0
      HRES(IPTR) = 0
C
N     PRINTOUT
C     I9 = HNTR
C     PRINT 2003, HPRO,HNTR,HNTCEL,((TRKAR(I1,I2),I2=1,11),I1=1,I9)
C     PRINT 2005, (HRES(I1),I1=1,I9)
C
N     CHANGE HIT LABEL
      IPLBHT = (IPHT - HPTSEC(1))/2 + HPHL0
      LBHIT = NTRL*2
      LBHIT = LOR(LBHIT,MKLRHT(LBLR+2))
      HWRK(IPLBHT+1) = HWRK(IPLBHT)
      HWRK(IPLBHT  ) = LBHIT
C
N     PRINTOUT
C     I0 = HPHL0
C     I9 = HPHL9
C     PRINT 2008, I0,I9,(HWRK(I1),I1=I0,I9)
C
      IERRFL = 0
      IPHT = IPTR
      RETURN
C
      END
C   28/09/79 102191155  MEMBER NAME  FLINEL   (PATRECSR)    SHELTRAN
      SUBROUTINE FLINEL
C
C        FIND LINE ELEMENTS IN ONE CELL: P.STEFFEN(78/11/78)
C
      IMPLICIT INTEGER*2 (H)
C
#include "cworkpr.for"
#include "cworkeq.for"
C
      EQUIVALENCE
     ,           (ICELL ,IDWRK(1)),(NHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
     ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
C
#include "cpatlm.for"
C
C2000 FORMAT(1H0,'ERROR CODE:',I4, ', ICELL:',I3,', TRACKS:',I9)
C2001 FORMAT(1X,/,(1X,2I6,2F6.2,2X,Z4,6I6,F6.2))
C     PRINT 2000, IERRCD, ICELL, IPPATR
C     IF(ICELL.EQ.20)PRINT 2001, (WRK(I1),I1=HPHT0,HPHT9)
C
N     LOOP OVER ALL HITS: TOP-DOWN
      I9 = HPHL0 + 39
      IP1 = HPHT0
      IP9 = HPHT9
      IPD = HLDHT
      IP8 = IP9 - IPD
      IP7 = IP8 - IPD
      IP  = IP1 - IPD
      WHILE IP.LT.IP7
      IP = IP + IPD
N     CHECK IF HIT ALREADY FOUND
      IF IWRK(IP+7).EQ.0
      THEN
N       LAYER NO.
        ILAY0 = IWRK(IP)
N       DRIFT SPACE
        DS0 = WRK(IP+2)
C
N       SEARCH FOR CLOSE HITS IN UPPER LAYERS
        PERFORM CLHTUP
      CIF
      CWHILE
C
C     CHECK ONE TO ONE CORRESPONDENCE OF POINTERS
C     AND LABEL POINTS OF DIVERGENCE
C
      PERFORM LBCHCK
C     IF(ICELL.EQ.20)PRINT 2001, (WRK(I1),I1=HPHT0,HPHT9)
C
      RETURN
C
C
N     ***************************
N     *      C L H T U P        *
N     ***************************
C
N     SEARCH FOR CLOSE HITS IN UPPER LAYERS
      PROC CLHTUP
C
        IPHT = IP
        IPA = IP
        IPALST = 0
        WHILE IPA.LT.IP8
        IPA = IPA + IPD
          IDLAYR = IWRK(IPA) - ILAY0
          DS = WRK(IPA+2)
          IF IDLAYR.EQ.2
          THEN
            IF IPALST.EQ.0
            THEN
              IF(IWRK(IPHT+7).EQ.0) IWRK(IPHT+7) = -1
              XWHILE
            CIF
            IPHT = IPALST
            IF IWRK(IPHT+7).GT.0
            THEN
              XWHILE
            CIF
            IPA = IPHT + IPD
            ILAY0 = IWRK(IPHT)
            DS0 = WRK(IPHT+2)
            IDLAYR = IWRK(IPA) - ILAY0
            DS = WRK(IPA+2)
            IPALST = 0
          CIF
N         STOP IF NOT SAME/ADJACENT LAYER OR DISTANT HIT
          IF IDLAYR.GT.1
          THEN
            XWHILE
          CIF
C
N         CHECK IF CLOSE HIT
          DDS = DS-DS0
          IF ABS(DDS).LT.FLINLM(1)
          THEN
            IF IDLAYR.EQ.1
N           CLOSE HIT IN ADJ. LAYR
            THEN
N             CHECK IF 1. CLOSE HIT
              IF IWRK(IPHT+7).LE.0
              THEN
                WRK (IPHT+10) = DDS
                IWRK(IPHT+ 7) = IPA
                IPALST = IPA
N             OTHER CLOSE HIT EXISTS: CHOSE CLOSEST
              ELSE
                IWRK(IPHT+4) = LOR(IWRK(IPHT+4),32)
                IF ABS(DDS).LT.ABS(WRK(IPHT+10))
                THEN
                  WRK (IPHT+10) = DDS
                  IWRK(IPHT+ 7) = IPA
                  IPALST = IPA
                CIF
              CIF
N             CHECK IF 1. CLOSE HIT
              IF IWRK(IPA+5).EQ.0
              THEN
                IWRK(IPA+ 5) = IPHT
                WRK (IPA+ 8) = DDS
N             OTHER CLOSE HIT EXISTS: CHOSE CLOSEST
              ELSE
                IWRK(IPA +4) = LOR(IWRK(IPA +4), 8)
                IF ABS(DDS).LT.ABS(WRK(IPA+ 8))
                THEN
                  IWRK(IPA+ 5) = IPHT
                  WRK (IPA+ 8) = DDS
                CIF
              CIF
C
N           CLOSE HIT IN SAME LAYER
            ELSE
N             CHECK IF 1. CLOSE HIT
              IF IWRK(IPHT+6).EQ.0
              THEN
                IWRK(IPHT+ 6) = IPA
                WRK (IPHT+ 9) = DDS
N             OTHER CLOSE HIT EXISTS: CHOSE CLOSEST
              ELSE
                IF ABS(DDS).LT.ABS(WRK(IPHT+ 9))
                THEN
                  IWRK(IPHT+ 6) = IPA
                  WRK (IPHT+ 9) = DDS
                CIF
              CIF
N             CHECK IF 1. CLOSE HIT
              IF IWRK(IPA+6).EQ.0
              THEN
                IWRK(IPA+ 6) = IPHT
                WRK (IPA+ 9) = DDS
N             OTHER CLOSE HIT EXISTS: CHOSE CLOSEST
              ELSE
                IF ABS(DDS).LT.ABS(WRK(IPA+ 9))
                THEN
                  IWRK(IPA+ 6) = IPHT
                  WRK (IPA+ 9) = DDS
                CIF
              CIF
            CIF
          CIF
        CWHILE
C
      CPROC
C
N     ***************************
N     *      L B C H C K        *
N     ***************************
C
N     CHECK ONE TO ONE CONNECTIONS + LABEL HITS
      PROC LBCHCK
C
N     FIND STRAIGHTEST LINEL IN MULT. CONNECTS.
      IPHT = IP1
      REPEAT
N       CHECK IF >1 LINEL POSSIBLE
        IF LAND(IWRK(IPHT+4),40).NE.0
        THEN
N         SEARCH FOR STRAIGHTEST LINEL
          PERFORM STRLIN
        CIF
      IPHT = IPHT + IPD
      UNTIL IPHT.GT.IP9
C
      FOR IPHT = IP1,IP9,IPD
N       POINTER DOWN
        IPAL = IWRK(IPHT+5)
N       POINTER UP
        IPAH = IWRK(IPHT+7)
N       CALCULATE PARAMETERS + LABEL
        DDS = 100000.
        IF IPAH.GT.0
        THEN
          IF IPAL.GT.0
          THEN
            SL = WRK(IPAH+2) - WRK(IPAL+2)
            DDS= WRK(IPAH+2)+WRK(IPAL+2) - WRK(IPHT+2)*2
N           SET LABEL
            LB = 3
            IF(ABS(DDS).LE.FLINLM(2)) LB = 7
          ELSE
            SL = (WRK(IPAH+2) - WRK(IPHT+2)) * 2
            LB = 2
          CIF
        ELSE
          IF(IPAH.LT.0) IWRK(IPHT+7) = 0
          IF IPAL.GT.0
          THEN
            SL = (WRK(IPHT+2) - WRK(IPAL+2)) * 2
            LB = 1
          ELSE
            SL = 0
            LB = 0
          CIF
        CIF
N       SET BIT FOR CLOSE HIT IN SAME LAYER
        IF(IWRK(IPHT+6).NE.0) LB = LOR(LB,16)
N       FILL HIT ARRAY
        WRK (IPHT+ 3) = SL
        IWRK(IPHT+ 4) = LOR(IWRK(IPHT+4),LB)
        WRK (IPHT+ 8) = 0
        WRK (IPHT+ 9) = 0
        WRK (IPHT+10) = 0
        WRK (IPHT+11) = DDS
C
      CFOR
C
N       CHECK ONE TO ONE CORRESP.
C
      FOR IPHT = IP1,IP9,IPD
N       POINTER DOWN
        IPAL = IWRK(IPHT+5)
N       POINTER UP
        IPAH = IWRK(IPHT+7)
        LB   = IWRK(IPHT+4)
        IF IPAL.GT.0
        THEN
N         POINTER UP
          IPALH = IWRK(IPAL+7)
N         CHECK ONE TO ONE CORRESPONDENCE
          IF IPALH.NE.IPHT
N         LABEL POINTS OF DIVERGENCE
          THEN
            LB = LOR(LB, 256)
            IWRK(IPALH+4) = LOR(IWRK(IPALH+4), 512)
            IWRK(IPAL +4) = LOR(IWRK(IPAL +4),1024)
          CIF
        CIF
        IF IPAH.GT.0
        THEN
N         POINTER DOWN
          IPAHL = IWRK(IPAH+5)
N         CHECK ONE TO ONE CORRESPONDENCE
          IF IPAHL.NE.IPHT
N         LABEL POINTS OF DIVERGENCE
          THEN
            LB = LOR(LB, 256)
            IWRK(IPAHL+4) = LOR(IWRK(IPAHL+4), 512)
            IWRK(IPAH +4) = LOR(IWRK(IPAH +4),1024)
          CIF
        CIF
        IWRK(IPHT +4) = LB
C
      CFOR
C
      CPROC
C
N     ***************************
N     *      S T R L I N        *
N     ***************************
C
N     SEARCH FOR STRAIGHTESTT LINEL
      PROC STRLIN
C
        IPAL = IWRK(IPHT+5)
        IPAH = IWRK(IPHT+7)
        IF IPAH.GT.0 .AND. IPAL.GT.0
        THEN
        DDS = WRK(IPHT+10) - WRK(IPHT+ 8)
N       CHECK IF KINKED LINEL
        IF ABS(DDS).GT.FLINLM(2)
        THEN
          ILAY0 = IWRK(IPHT)
          DS0 = WRK(IPHT+2)
          DSLM = 100000.
N         SELECT UP CONNECTION
          IPUP = IPHT
          WHILE IPUP.LT.IP8
          IPUP = IPUP + IPD
            IF IWRK(IPUP)-ILAY0.GT.0
            THEN
              IF IWRK(IPUP)-ILAY0.GT.1
              THEN
                XWHILE
              CIF
              SLH = WRK(IPUP+2) - DS0
N             SELECT DOWN CONNECTION
              IPDW = IPHT
              WHILE IPDW.GT.IP1
              IPDW = IPDW - IPD
                IF ILAY0-IWRK(IPDW).GT.0
                THEN
                  IF ILAY0-IWRK(IPDW).GT.1
                  THEN
                    XWHILE
                  CIF
                  SLL = DS0 - WRK(IPDW+2)
                  DSL = ABS(SLH-SLL)
                  IF DSL.LT.DSLM
                  THEN
N                   SET STRAIGHTEST SLOPE PARAMETERS
                    DSLM = DSL
                    IPAL = IPDW
                    IPAH = IPUP
                  CIF
                CIF
              CWHILE
            CIF
          CWHILE
          IWRK(IPHT+ 5) = IPAL
          IWRK(IPHT+ 7) = IPAH
          WRK (IPHT+ 8) = DS0 - WRK(IPAL+2)
          WRK (IPHT+10) = WRK(IPAH+2) - DS0
          IF(IWRK(IPAL+ 7).LE.0)  WRK(IPAL+10) = WRK(IPHT+ 8)
          IF(IWRK(IPAL+ 7).LE.0) IWRK(IPAL+ 7) = IPHT
          IF(IWRK(IPAH+ 5).LE.0)  WRK(IPAH+ 8) = WRK(IPHT+10)
          IF(IWRK(IPAH+ 5).LE.0) IWRK(IPAH+ 5) = IPHT
          DATA IPR /0/
          IPR = IPR + 1
C         IF IPR.LE.10
C         THEN
C2006   FORMAT(1H0,'IPHT:',I4, ', IPAL:',I3,', IPAH:',I4,', DDS =',F6.2)
C     IF(ICELL.EQ.20)PRINT 2006, IPHT,IPAL,IPAH,DDS
C     IF(ICELL.EQ.20)PRINT 2001, (WRK(I1),I1=HPHT0,HPHT9)
C         CIF
        CIF
        CIF
      CPROC
C
      END
C   03/10/80 102191156  MEMBER NAME  FTRELO   (PATRECSR)    SHELTRAN
      SUBROUTINE FTRELO
C
C        FIND TRACK ELEMENTS FROM LINE ELEMENTS: P.STEFFEN(80/06/27)
C                   HISTOGRAM METHOD USING INTERACTION POINT
C                   NO STOP AT POINT OF DIVERGENCE
C
      IMPLICIT INTEGER*2 (H)
      LOGICAL TBIT
C
#include "cheadr.for"
      EQUIVALENCE (HRUN,HHEADR(18)) , (HEV,HHEADR(19))
C
#include "cworkpr.for"
#include "cworkeq.for"
C
      EQUIVALENCE
     ,           (ICELL ,IDWRK(1)),(MHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
     ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
C
#include "cpatlm.for"
C
#include "cjdrch.for"
#include "cdsmax.for"
C
      DIMENSION HPBAK(16),HLYAR(16),HLBAR(16),DSPAR(16),
     ,          XTRAR(16),YTRAR(16),RESAR(16)
      DIMENSION HST( 80), HSTL(5),HSTR(5)
C
N     AVERAGE RADIUS FOR PAIR CONVERSION IN BEAM PIPE OR TANK
      DATA XCV /152.7/
C
N     MASK FOR GOOD LINEL
C     DATA MKGDLN / Z107/
N     MASK FOR DIVERGING LINEL
C     DATA MKDIVL / Z100/
C
N     LABEL FOR NO CONTINUATION OF TREL
C     DATA LBNOCN / Z1/
N     LABEL FOR KINK AT END POINT OF TREL
C     DATA LBKINK / Z2/
C
N     SIGMA(CURV) FOR HITS IN 3 RINGS
      REAL SGCRV(3) /.000062,.000035,.000025/
C
C     IF(ICELL.NE.40 .AND. ICELL.NE.58) RETURN
C2001 FORMAT(' L/R DET.:',10F8.3)
C2006 FORMAT(1X,I6,5F8.2,F12.1,5F8.2)
C2013 FORMAT('0FIT:',I3,F5.2,F5.1,F10.6,F7.3,F5.1,F7.4,F6.1,F5.2)
C2014 FORMAT(' X,Y,ZW1,ZW2,CRV0,CRV,IBNL:',6F10.5,I10)
C2100 FORMAT(' LINEL ',4I6,2F6.2,I4)
C2101 FORMAT('0HISTOGRAM:',20I2,2X,20I2,/,(11X,20I2,2X,20I2))
C2102 FORMAT(' PEAK =', 7I6,6F10.5)
C2103 FORMAT(' TREL:',2I6,3(/,1X,16I7),3(/,1X,16F7.2))
C2900 FORMAT(1H0,'ERROR CODE:',I4, ', ICELL:',I3,', TRACKS:',I4)
C2901 FORMAT(1X,/,(1X,2I6,2F6.2,2X,Z4,4F7.1,2I6,F6.2))
C
N     POINTER TO CURRENT TRKEL
      ITRK = 0
C
N     CALCULATE X,Y COORDINATES
      DR =  RINCR(IRING)
      R0 = FSENSW(IRING)
N     RADIUS AROUND WIRE FOR CORR. OF DRIFTSPACE
      DRC = RINCR(1)*.5 * DRICOS
C
      FOR IP = HPHT0,HPHT9,HLDHT
        ILAY = IWRK(IP  )
        Y    = SWDEPL
        IF(LAND(ILAY,1).NE.0) Y =-Y
        X    = ILAY * DR + R0
        DS   =  WRK(IP+2)
        IF DS.LE.DRC
        THEN
          DX   = 0.
          DY   = DS
        ELSE
          DX   =-(DS-DRC)*DRISIN
          DY   = (DS-DRC)*DRICOS + DRC
        CIF
        WRK(IP+5) = X - DX
        WRK(IP+7) = X + DX
        WRK(IP+6) = Y - DY
        WRK(IP+8) = Y + DY
      CFOR
C     PRINT 2900, IRING, ICELL, NTRCNT
C     IF(ICELL.LE.47) PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
C
N     LOOP OVER HITS + SEARCH FOR LINE ELEMENT
      IPHT1 = HPHT9 - HLDHT + 1
      REPEAT
N       1. HIT
        IL1 = IWRK(IPHT1  )
        IF(IL1.LT. 2) XREPEAT
N       CHECK IF UNUSED
        DSP1 =  WRK(IPHT1+2)
        IF DSP1.GT.0.7 .AND. IWRK(IPHT1+9).LE.0
        THEN
          IL2 =  IL1 - 1
          IL3 =  IL2 - 1
C
N         SEARCH STRAIGHTEST LINEL
          DSLM = 1000.
C
N         SEARCH FOR 2. HIT
          IPHT2 = IPHT1 - HLDHT
          WHILE IPHT2.GE.HPHT0 .AND. IWRK(IPHT2).GE.IL2
N           CHECK IF NEXT LAYER + UNUSED HIT
            DSP2 = WRK(IPHT2+2)
            IF DSP2.GT.0.7.AND.IWRK(IPHT2).EQ.IL2.AND.IWRK(IPHT2+9).LE.0
            THEN
              IF ABS(DSP2-DSP1).LE.12.5
              THEN
C
N               SEARCH FOR 3. HIT
                IPHT3 = IPHT2 - HLDHT
                WHILE IPHT3.GE.HPHT0 .AND. IWRK(IPHT3).GE.IL3
N                 CHECK IF NEXT LAYER + UNUSED HIT
                  DSP3 = WRK(IPHT3+2)
                  IF DSP3.GT.0.7 .AND.
     ?               IWRK(IPHT3).EQ.IL3 .AND. IWRK(IPHT3+9).LE.0
                  THEN
N                   SEARCH FOR SRAIGHTEST LINEL
                    DSL = DSP2*2.-DSP3-DSP1
                    IF ABS(DSL).LT.DSLM .AND. DSP1+DSP2+DSP3.GT.3.0
                    THEN
                      IF IWRK(IPHT1+9).EQ.0 .OR. IWRK(IPHT2+9).EQ.0
     ?                   .OR. IWRK(IPHT3+9).EQ.0
                      THEN
                        DSLM  = ABS(DSL)
                        SDSLM = DSL
                        MP1 = IPHT1
                        MP2 = IPHT2
                        MP3 = IPHT3
                      CIF
                    CIF
                  CIF
                IPHT3 = IPHT3 - HLDHT
                CWHILE
              CIF
            CIF
          IPHT2 = IPHT2 - HLDHT
          CWHILE
C
N         'XREPEAT' = STOP ANALYSIS
          REPEAT



N           CHECK IF GOOD LINEL
            LBLRLE = LAND(IL2,1)*2 - 1
            IF(SDSLM.LT.0) LBLRLE =-LBLRLE
C     IF(ICELL.LE.47)PRINT 2100, IL1,MP1,MP2,MP3,DSLM,SDSLM,LBLRLE
            IF(DSLM.GE.2.0) XREPEAT
C
N           GOOD LINEL, FETCH OTHER HITS
            LBLRLE = LAND(IL2,1)*2 - 1
            IF(SDSLM.LT.0) LBLRLE =-LBLRLE
            PERFORM CVHIST
C
N           LOOP OVER L/R SOL. TRY BEST ONE FIRST
            LRLOOP = 1
            SIGLM = .250
            SIG0 = 1000.
            WHILE LRLOOP.LE.2
C
N             FETCH HITS CONTRIBUTING TO HISTOGRAM PEAK
              PERFORM FETHST
C
N             CHECK IF AT LEAST 4 HITS
              IF(NHTTR.LT.4) XWHILE
C
N             FIT PARABOLA THROUGH ORIGIN
              WGHT0 = 0.01
              Y0    = 0.
              PERFORM FPARA0
N             CHECK IF DIST. TO ORIGIN ACCEPTABLE
              IF ABS(PAR3).GT.3.0
              THEN
                WGHT0 = 0.1
                IF PAR1*PAR3.LE.0.
                THEN
                  Y0 =-SIGN(2.,PAR1)
                  PERFORM FPARA0
                ELSE
                  DORMX = XCV**2*PAR1 + SIGN(2.,PAR1)
                  IF ABS(PAR3).GT.ABS(DORMX)
                  THEN
N                   TOO BIG DIST., REPEAT FIT WITH RESTRICTION
                    Y0 = DORMX
                    PERFORM FPARA0
                  CIF
                CIF
              CIF
C
N             CHECK IF REASONABLE FIT
              SIGLM = .50
              IF SIG.GT.SIGLM
              THEN
N               BAD FIT, CHECK IF ONLY 1 BAD HIT
                SIG1 = (SIG*DEG - DCHIM1**2) / (DEG-1.)
                IF(SIG1.GT.SIGLM .AND. LRLOOP.EQ.1) XREPEAT
              CIF
C
N             FETCH HITS
              FETLIM = 0.65
              PERFORM FETHIT
              WGHT0 = .01
              IF NHTTR.GE.4
              THEN
N               FIT PARABOLA THROUGH ORIGIN
                PERFORM FPARA0
C
N               CHECK IF DIST. TO ORIGIN ACCEPTABLE
                IF ABS(PAR3).GT.3.0
                THEN
                  WGHT0 = 0.1
                  IF PAR1*PAR3.LE.0.
                  THEN
                    Y0 =-SIGN(2.,PAR1)
                    PERFORM FPARA0
                  ELSE
                    DORMX = XCV**2*PAR1 + SIGN(2.,PAR1)
                    IF ABS(PAR3).GT.ABS(DORMX)
                    THEN
N                     TOO BIG DIST., REPEAT FIT WITH RESTRICTION
                      Y0 = DORMX
                      PERFORM FPARA0
                    CIF
                  CIF
                CIF
              CIF
N             CHECK IF REASONABLE FIT
              IF SIG.GT.SIGLM
              THEN
N               BAD FIT, CHECK IF ONLY 1 BAD HIT
                SIG1 = (SIG*DEG - DCHIM1**2) / (DEG-1.)
                IF(SIG1.GT.SIGLM .AND. LRLOOP.EQ.1) XREPEAT
              CIF
C
N             DET. CORRECTED SIGMA
              SIGCOR = SIG
              IF LRLOOP.EQ.2
              THEN
                DDSTG = DSTAG - DSTAG0
                SIGCOR = SIG - (DEG-DEG0)*.01 + DDSTG*.1 + .01
C     IF(ICELL.LE.47)PRINT 2001, SIG,SIGCOR,SIG0,DEG,DEG0,DSTAG,DSTAG0
              CIF
C
N             STORE BEST SOLUTION
              IF SIGCOR .LT. SIG0
              THEN
                LBLR0 = LBLRTR
                SIG0  = SIG
                SIGLM0= SIGLM
                PAR10 = PAR1
                PAR20 = PAR2
                PAR30 = PAR3
                DSTAG0= DSTAG
                DEG0  = DEG
N               STOP IF GOOD FIT
                IF(SIG.LT..08) XWHILE
              CIF
            LBLRTR =-LBLRTR
            LRLOOP = LRLOOP + 1
            CWHILE
C
N           CHECK IF GOOD SOL. FOUND
            IF(SIG0.GT..25) XREPEAT
C
N           RESTORE PARAMETERS
            LBLRTR = LBLR0
            SIG    = SIG0
            PAR1   = PAR10
            PAR2   = PAR20
            PAR3   = PAR30
C
N           LABEL HITS
            ITRK = ITRK + 1
            ALBLM1 = 0.7
            ALBLM2 = 2.0
            PERFORM LABEL
C
N           CHECK IF GOOD SOLUTION IN R2
            IF(SIG0.GT..10 .AND. ICELL.LE.48) XREPEAT
C
N           CHECK IF CURV.(>200MEV)
            IF(ABS(PAR1).GT..00040 .OR. NHTGD.LT.4) XREPEAT
C
N           TRACE TRACK THROUGH ORIGIN
            HPFRE1 = HPFREE
            CALL TRACEO(ITRK,PAR1,PAR2,PAR3)
            HPFREE = HPFRE1
C
          UNTIL .TRUE.
C
        CIF
      IPHT1 = IPHT1 - HLDHT
      UNTIL IPHT1.LT.HPHT0
C
N     SET POINTER TO END OF TRACK ARRAY
C
N     SET NUMBER OF TRKELS
C
C     IF(ICELL.LE.47)PRINT 2900, IERRCD, ICELL, NTRCNT
C     IF(ICELL.LE.47)PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
      RETURN
C
N     *************************
N     *      C V H I S T      *
N     *************************
N     HISTOGRAM OF CURVATURES
      PROC CVHIST
C
N     ZERO HISTOGRAM
      CALL SETS(HST(1),0,160,0)
      DCRV =  SGCRV(IRING)
      CRV1 = -DCRV*20.
      IW1 = IL2
C
N     LOOP OVER L/R SOLUTIONS
      ILRSOL =-3
      REPEAT
      ILRSOL = ILRSOL + 2
        IF ILRSOL.LT.0
        THEN
N         LEFT SOLUTION
          ZW1L = (WRK(MP1+5)+WRK(MP2+5)+WRK(MP3+5)) / 3.
          ZW2L = (WRK(MP1+6)+WRK(MP2+6)+WRK(MP3+6)) / (ZW1L*3.)
          ZW1  = ZW1L
          ZW2  = ZW2L
          X    = WRK(MP1+5)
          Y    = WRK(MP1+6)
          CV1  = (ZW2*X - Y) / ((ZW1-X)*X)
          X    = WRK(MP3+5)
          Y    = WRK(MP3+6)
          CV3  = (ZW2*X - Y) / ((ZW1-X)*X)
          CRVL = (CV1 + CV3) * .5 + CRV1
          CRV0 = CRVL
        ELSE
N         RIGHT SOLUTION
          ZW1R = (WRK(MP1+7)+WRK(MP2+7)+WRK(MP3+7)) / 3.
          ZW2R = (WRK(MP1+8)+WRK(MP2+8)+WRK(MP3+8)) / (ZW1R*3.)
          ZW1  = ZW1R
          ZW2  = ZW2R
          X    = WRK(MP1+7)
          Y    = WRK(MP1+8)
          CV1  = (ZW2*X - Y) / ((ZW1-X)*X)
          X    = WRK(MP3+7)
          Y    = WRK(MP3+8)
          CV3  = (ZW2*X - Y) / ((ZW1-X)*X)
          CRVR = (CV1 + CV3) * .5 + CRV1
          CRV0 = CRVR
        CIF
        CALL SETS(HST(1),0,160,0)
        FOR IP0 = HPHT0,HPHT9,HLDHT
          IF IWRK(IP0).NE.IW1
          THEN
            X    = WRK(IP0+5)
            Y    = WRK(IP0+6)
            DX   = ZW1 - X
            IBNL = 1000
            IBNR = 1000
            IF ABS(DX).GT.5.0
            THEN
              CRV = (ZW2*X - Y) / (DX*X)
              IBNL = (CRV-CRV0) / DCRV + 1
C     IF(MP1.EQ.994)PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNL
            CIF
            X   = WRK(IP0+7)
            Y   = WRK(IP0+8)
            DX  = ZW1 - X
            IF ABS(DX).GT.5.0
            THEN
              CRV = (ZW2*X - Y) / (DX*X)
              IBNR = (CRV-CRV0) / DCRV + 1
C     IF(MP1.EQ.994)PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNR
            CIF
            IF IABS(IBNL-IBNR).GT.3
            THEN
              IF(IBNL.GT.0 .AND. IBNL.LE.40) HST(IBNL) = HST(IBNL) + 1
              IF(IBNR.GT.0 .AND. IBNR.LE.40) HST(IBNR) = HST(IBNR) + 1
            CIF
          CIF
        CFOR
C
C     IF(ICELL.LE.47)PRINT 2101, HST
        MHST = 0
        IMAX = 0
        FOR I=19,22
          NHST = HST(I-1) + HST(I  ) + HST(I+1)
          IF NHST.GE.MHST
          THEN
            MHST = NHST
            IMAX = I
          CIF
        CFOR
C     IF(ICELL.LE.47)PRINT 2102, IMAX,MHST,NHST
C
N       STORE PEAK FOR L/R SOLUTION
        IF ILRSOL.LT.0
        THEN
          MHSTL = MHST
          IMAXL = IMAX
          CALL MVC(HSTL(1),0,HST(IMAX-2),0,10)
        ELSE
          MHSTR = MHST
          IMAXR = IMAX
          CALL MVC(HSTR(1),0,HST(IMAX-2),0,10)
        CIF
      UNTIL ILRSOL.EQ.1
C
N     SELECT L/R SOLUTION ACCORD. TO HIST.-PEAK
      LBLRTR = 1
      IF(MHSTL.GT.MHSTR) LBLRTR =-1
N     IF AMBIGUOUS L/R SOL. USE LINEL
      IF(IABS(MHSTL-MHSTR).LE.1 .AND. LBLRTR.NE.LBLRLE) LBLRTR=-LBLRTR
C
      CPROC
C
N     *************************
N     *      F E T H S T      *
N     *************************
C
C
N     FETCH HITS CONTRIBUTING TO HISTOGRAM PEAK
      PROC FETHST
C
C
N     EVALUATE PEAK
      IF LBLRTR.LT.0
      THEN
        MHST = MHSTL
        IMAX = IMAXL
        CALL MVC(HST(1),0,HSTL(1),0,10)
        ZW1 = ZW1L
        ZW2 = ZW2L
        CRV0 = CRVL
      ELSE
        MHST = MHSTR
        IMAX = IMAXR
        CALL MVC(HST(1),0,HSTR(1),0,10)
        ZW1 = ZW1R
        ZW2 = ZW2R
        CRV0 = CRVR
      CIF
C
N     CORRECT FOR DOUBLE PEAK
      IF IMAX.EQ.19 .AND.
     ?   HST(1).GT.0 .AND. HST(1).GT.HST(2) .AND. HST(5).NE.0
      THEN
        IMAX = IMAX + 1
      CIF
      IF IMAX.EQ.22 .AND.
     ?   HST(5).GT.0 .AND. HST(5).GT.HST(4) .AND. HST(1).NE.0
      THEN
        IMAX = IMAX - 1
      CIF
      IM1 = IMAX - 1
      IM3 = IMAX + 1
      NHST  = HST(2) + HST(3) + HST(4)
      NHTTR = 0
      IF NHST.GE.3
      THEN
C     IF(ICELL.LE.47)PRINT 2102,IMAX,MHST,LBLRTR,IM1,IM3,MHSTL,MHSTR
C
N       FETCH HITS OF PEAK IN HISTOGRAM
        IHIT = 0
        ILAYL = -1
        LBHDEL = 0
        CALL SETS(HLBAR(1),0,32,0)
        FOR IP0 = HPHT0,HPHT9,HLDHT
          IBNL = -1000
          IBNR = -1000
          IF IABS(IWRK(IP0)-IW1).LE.1
          THEN
            IF LBLRTR.LT.0
            THEN
              IF(IP0.EQ.MP1.OR.IP0.EQ.MP2.OR.IP0.EQ.MP3) IBNL = IMAX
            ELSE
              IF(IP0.EQ.MP1.OR.IP0.EQ.MP2.OR.IP0.EQ.MP3) IBNR = IMAX
            CIF
          ELSE
            X   = WRK(IP0+5)
            Y   = WRK(IP0+6)
            DX  = ZW1 - X
            IF ABS(DX).GT.5.0
            THEN
              CRV = (ZW2*X - Y) / (DX*X)
              IBNL = (CRV-CRV0) / DCRV + 1
C     IF(MP1.EQ.994) PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNL
            CIF
            X   = WRK(IP0+7)
            Y   = WRK(IP0+8)
            DX  = ZW1 - X
            IF ABS(DX).GT.5.0
            THEN
              CRV = (ZW2*X - Y) / (DX*X)
              IBNR = (CRV-CRV0) / DCRV + 1
C     IF(MP1.EQ.994) PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNR
            CIF
          CIF
          IF IABS(IBNL-IBNR).GT.3
          THEN
            ILAY = IWRK(IP0)
            IF IBNL.GE.IM1 .AND. IBNL.LE.IM3
            THEN
              IF ILAY.EQ.ILAYL
              THEN
N               ELIMINATE 2 HITS IN 1 LAYER
                IF(LBHDEL.EQ.0) IHIT = IHIT - 1
                LBHDEL = 1
              ELSE
                IHIT = IHIT + 1
                HPBAK(IHIT  ) = IP0
                HLYAR(IHIT  ) = ILAY
                HLBAR(IHIT  ) =   1
                DSPAR(IHIT  ) = WRK(IP0+2)
                XTRAR(IHIT  ) = WRK(IP0+5)
                YTRAR(IHIT  ) = WRK(IP0+6)
                ILAYL = ILAY
                LBHDEL = 0
              CIF
            ELSE
            IF IBNR.GE.IM1 .AND. IBNR.LE.IM3
            THEN
              IF ILAY.EQ.ILAYL
              THEN
N               ELIMINATE 2 HITS IN 1 LAYER
                IF(LBHDEL.EQ.0) IHIT = IHIT - 1
                LBHDEL = 1
              ELSE
                IHIT = IHIT + 1
                HPBAK(IHIT  ) = IP0
                HLYAR(IHIT  ) = ILAY
                HLBAR(IHIT  ) =   1
                DSPAR(IHIT  ) = WRK(IP0+2)
                XTRAR(IHIT  ) = WRK(IP0+7)
                YTRAR(IHIT  ) = WRK(IP0+8)
                ILAYL = ILAY
                LBHDEL = 0
              CIF
            CIF
            CIF
          CIF
        CFOR
        NHTTR = IHIT
C     IF(ICELL.LE.47)
C    ,PRINT 2103, IPHT1,NHTTR,HPBAK,HLBAR,HLYAR,XTRAR,YTRAR,DSPAR
      CIF
C
      CPROC
C
N     *************************
N     *      F E T H I T      *
N     *************************
C
C
N     FETCH HITS
      PROC FETHIT
C
        IHIT = 0
        IWL  =-1
        CALL SETS(HLBAR(1),0,32,0)
        FOR IP0 = HPHT0,HPHT9,HLDHT
          IW0 = IWRK(IP0)
          X   = WRK(IP0+5)
          Y   = WRK(IP0+6)
          F   = (PAR1 *X + PAR2 )*X + PAR3
          DFL = F - Y
          IF ABS(DFL).LT.FETLIM
          THEN
            IF IWL.EQ.IW0
            THEN
N             ELIMINATE HIT IF 2 HITS IN SAME LAYER
              IHIT = IHIT - 1
            ELSE
              IHIT = IHIT + 1
              HPBAK(IHIT  ) = IP0
              HLYAR(IHIT  ) = IW0
              HLBAR(IHIT  ) =   1
              DSPAR(IHIT  ) = WRK(IP0+2)
              XTRAR(IHIT  ) = WRK(IP0+5)
              YTRAR(IHIT  ) =   Y
              IWL = IW0
            CIF
          CIF
          X   = WRK(IP0+7)
          Y   = WRK(IP0+8)
          F   = (PAR1 *X + PAR2 )*X + PAR3
          DF  = F - Y
          IF ABS(DF).LT.FETLIM
          THEN
            IF IWL.EQ.IW0
            THEN
N             ELIMINATE HIT IF 2 HITS IN SAME LAYER
              IHIT = IHIT - 1
            ELSE
              IHIT = IHIT + 1
              HPBAK(IHIT  ) = IP0
              HLYAR(IHIT  ) = IW0
              HLBAR(IHIT  ) =   1
              DSPAR(IHIT  ) = WRK(IP0+2)
              XTRAR(IHIT  ) = WRK(IP0+7)
              YTRAR(IHIT  ) =   Y
              IWL = IW0
            CIF
          CIF
        CFOR
        NHTTR = IHIT
C     IF(ICELL.LE.47)
C    ,PRINT 2103, IPHT1,NHTTR,HPBAK,HLBAR,HLYAR,XTRAR,YTRAR,DSPAR
C
      CPROC
C
N     *************************
N     *      F P A R A 0      *
N     *************************
C
C
N     PARABOLA FIT THROUG ORIGIN
      PROC FPARA0
C
N     GET EQUATIONS
N     WEIGHT ORIGIN AS POINT OF PARABOLA
      S0 = WGHT0
      S1 = 0.
      S2 = 0.
      S3 = 0.
      S4 = 0.
      S5 = 0.
      S6 = 0.
      S7 = Y0 * WGHT0
      FOR IHIT = 1,NHTTR
          X = XTRAR(IHIT)
          Y = YTRAR(IHIT)
          X2 = X**2
          S1 = S1 + X
          S2 = S2 + X2
          S3 = S3 + X*X2
          S4 = S4 + X2**2
          S5 = S5 + Y*X2
          S6 = S6 + Y*X
          S7 = S7 + Y
          S0 = S0 + 1.
      CFOR
      MHIT = S0
C
N     SOLVE EQUATIONS FOR PARABOLA FIT
      F1 = 1. / S4
      XX12 = S3*F1
      XX13 = S2*F1
      YY1  = S5*F1
      XX22 = S2 - S3*XX12
      XX23 = S1 - S3*XX13
      YY2  = S6 - S3*YY1
      XX32 = S1 - S2*XX12
      XX33 = S0 - S2*XX13
      YY3  = S7 - S2*YY1
      IF XX22.GT.XX32
      THEN
        XX23 = XX23 / XX22
        YY2  = YY2  / XX22
        PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
        PAR2 = YY2 - XX23*PAR3
      ELSE
        XX33 = XX33 / XX32
        YY3  = YY3  / XX32
        PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
        PAR2 = YY3 - XX33*PAR3
      CIF
      PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
      DEG = S0 - WGHT0 - 2.
C
N     CALC. CHISQ + SOLVE L/R AMBIGUITY
      CHISQ = 0.
      DCHIM1 = 0.
      IHITM1 = 0
N     L/R AMB. FROM STAGGERING
      NEVN   = 0
      CHEVN  = 0.
      NUNE   = 0
      CHUNE  = 0.
      IHSTRT = 0
      FOR IHIT = 1,NHTTR
          IF(IHSTRT.EQ.0) IHSTRT = IHIT
          IHEND = IHIT
          X = XTRAR(IHIT)
          Y = YTRAR(IHIT)
          F   = (PAR1 *X + PAR2 )*X + PAR3
          DCHI = Y - F
          RESAR(IHIT) = DCHI
N         SUM FOR RMS
          CHISQ = CHISQ + DCHI**2
N         KEEP BIGGEST RMS
          IF ABS(DCHI).GE.DCHIM1
          THEN
            DCHIM1 = ABS(DCHI)
            IHITM1 = IHIT
          CIF
          ILAY = HLYAR(IHIT)
          IF ABS(DCHI).LT. 0.6
          THEN
            IF LAND(ILAY,1).EQ.0
            THEN
              NEVN  = NEVN  + 1
              CHEVN = CHEVN + DCHI
            ELSE
              NUNE  = NUNE  + 1
              CHUNE = CHUNE + DCHI
            CIF
          CIF
C     IF(ICELL.LE.47)PRINT 2006, ILAY,X,Y,F,DCHI,CHISQ,XTRAR(IHIT)
      CFOR
      SIG    =      CHISQ  / DEG
      DSTAG = -1000.
      IF(NEVN.GT.1.AND. NUNE.GT.1) DSTAG = ABS(CHEVN/NEVN - CHUNE/NUNE)
C
N     LIMIT OF SIGMA
      SIGLM = .25
C
C     IF(ICELL.LE.47)PRINT 2013,NHTTR,SIG,DEG,PAR1,PAR2,PAR3,WGHT0,Y0
C
      CPROC
C
N     *************************
N     *      L A B E L        *
N     *************************
C
C
N     LABEL USED HITS
      PROC LABEL
C
        NHTGD  = 0
        FOR IP0 = HPHT0,HPHT9,HLDHT
          IW0 = IWRK(IP0)
          X   = WRK(IP0+5)
          Y   = WRK(IP0+6)
          F   = (PAR1 *X + PAR2 )*X + PAR3
          DFL = F - Y
          X   = WRK(IP0+7)
          Y   = WRK(IP0+8)
          F   = (PAR1 *X + PAR2 )*X + PAR3
          DFR = F - Y
N         SELECT CLOSEST HIT
          DF  = DFL
          IF(ABS(DFR).LT.ABS(DFL)) DF = DFR
          IF ABS(DF).LT.ALBLM2
          THEN
C
N           CLOSE HIT
            ILBLR = 1
            IF(DF.EQ.DFR) ILBLR = 2
            IF ABS(DF).LT.ALBLM1
            THEN
N             HIT BELONGS TO TRACK
              NHTGD  = NHTGD + 1
              IF(IWRK(IP0+ 9).LT.0) IWRK(IP0+ 9) = 0
              IF(IWRK(IP0+10).LT.0) IWRK(IP0+10) = 0
              IWRK(IP0+10) = IWRK(IP0+9)
              IWRK(IP0+ 9) = ITRK
              IF IWRK(IP0+10).NE.0
              THEN
                LB2 = LAND(IWRK(IP0+4),    3)*4
              ELSE
                LB2 = 0
              CIF
              LB1 = LAND(IWRK(IP0+4),MKLR1)
              LB1 = LOR(LB1,LB2)
              IWRK(IP0+4) = LOR(LB1,ILBLR)
            ELSE
N             HIT MAY BELONG TO TRACK
              IF IWRK(IP0+ 9).LE.0
              THEN
                IWRK(IP0+10) = IWRK(IP0+9)
                IWRK(IP0+ 9) =-ITRK
                IF IWRK(IP0+10).NE.0
                THEN
                  LB2 = LAND(IWRK(IP0+4),    3)*4
                ELSE
                  LB2 = 0
                CIF
                LB1 = LAND(IWRK(IP0+4),MKLR1)
                LB1 = LOR(LB1,LB2)
                IWRK(IP0+4) = LOR(LB1,ILBLR)
              CIF
            CIF
          CIF
        CFOR
C
      CPROC
C
      END
C   14/01/82 201151105  MEMBER NAME  FTRKEL   (PATRECSR)    SHELTRAN
C   18/01/80 201131458  MEMBER NAME  ORFTRKEL (JADESR)      SHELTRAN
C   18/01/80 001181139  MEMBER NAME  ORFTRKEL (JADESR)      SHELTRAN
      SUBROUTINE FTRKEL
C
C        FIND TRACK ELEMENTS FROM LINE ELEMENTS: P.STEFFEN(79/02/06)
C                   MIN. DRIFTSPACE REQUIRED
C                   NO STOP AT POINT OF DIVERGENCE
C
      IMPLICIT INTEGER*2 (H)
C
#include "cworkpr.for"
#include "cworkeq.for"
C
      EQUIVALENCE
     ,           (ICELL ,IDWRK(1)),(MHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
     ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
C
#include "cpatlm.for"
C
#include "cjdrch.for"
#include "cdsmax.for"
C
      DIMENSION HPBAK(16),HLYAR(16),HLBAR(16),DSPAR(16),RESAR(16)
C
N     MASK FOR GOOD LINEL
      DATA MKGDLN / Z107/
N     MASK FOR DIVERGING LINEL
      DATA MKDIVL / Z100/
C
N     LABEL FOR NO CONTINUATION OF TREL
      DATA LBNOCN / Z1/
N     LABEL FOR KINK AT END POINT OF TREL
      DATA LBKINK / Z2/
N     LABEL FOR WALL AT END POINT OF TREL
      DATA LBWALL / Z4/
N     LABEL FOR WIRE PLANE AT END POINT OF TREL
      DATA LBWIRE / Z8/
N     LABEL FOR GOOD TREL
      DATA LBTREL /Z1000/
N     LEFT/RIGHT LABEL OF TREL
      INTEGER LBLFRT(3) /Z10000,Z30000,Z20000/
C
N     FUNCTIONS
      FPAR0(X) = (PAR10*X + PAR20)*X + PAR30
      FPAR (X) = (PAR1 *X + PAR2 )*X + PAR3
C
C     PRINT 2900, IERRCD, ICELL, NTRCNT
C     IF(ICELL.GT. 0) PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
C2001 FORMAT(1H0,9I6)
C2002 FORMAT(1X,3I6,10F8.2)
C2004 FORMAT('0********** UNDETERMINED L/R AMB. *********',I6,3F8.2)
C2005 FORMAT(' 0-TREL-CAND.:',I6,10F8.2)
C2006 FORMAT(1X,I6,F6.0,3F8.2,F12.1,5F8.2)
C2007 FORMAT(' TRELAN:',3I6,10F10.4)
C2008 FORMAT(' CUT   :',15I6)
C2009 FORMAT(1X,I6,F6.0,9F8.2)
C2010 FORMAT(' NEWCUT:',I6,F8.2,I6,F8.2)
C2011 FORMAT(1X,3I6,F8.2)
C2012 FORMAT(1X,I6,10F8.2)
C2900 FORMAT(1H0,'ERROR CODE:',I4, ', ICELL:',I3,', TRACKS:',I4)
C2901 FORMAT(1X,/,(1X,2I6,2F6.2,2X,Z4,6I6,F6.2))
C2902 FORMAT(/,(1X,3I6,4F8.5,I3,2F6.2,I3,2F6.2,2X,Z4,2X,Z4,2X,Z5,F6.2))
C
N     PRESET COUNTER OF TRKELS
      MTRK = 0
N     PRESET COUNTER OF ZERO APPROACH. LINELS
N     POINTER TO START OF TRELS + LENGTH OF TREL
      HPTR0= HPFREE
      HLDTR= 17
N     POINTER TO CURRENT TRKEL
      IPTR = HPTR0
C
N     LOOP OVER ALL LINE ELEMENTS
      IP=HPHT0
      REPEAT
        LB = LAND(IWRK(IP+4),MKGDLN)
        IFREEU = IWRK(IP+5)
        IF(IFREEU.GT.0) IFREEU = IWRK(IFREEU+9)
        IFREED = IWRK(IP+7)
        IF(IFREED.GT.0) IFREED = IWRK(IFREED+9)
        IF IWRK(IP+8).EQ.0 .AND. LB.EQ.7
     .     .AND. ABS(WRK(IP+11)).GT..1
     .     .AND. IFREEU.EQ.0 .AND. IFREED.EQ.0
N       ONLY GOOD + UNUSED LINEL WITH L/R DIFF.
        THEN
          DS0 = WRK(IP+2)
          SL0 = WRK(IP+3)
N         COUNTER FOR LINELS
          NLINEL = 1
N         OFFSET FOR STAGGERING
          DDSOFF = SIGN(TRELLM(1),WRK(IP+11))
          IF(LAND(IWRK(IP),1).NE.0) DDSOFF =-DDSOFF
N         SEARCH FOR END OF TRKEL IN LOWER LAYERS
          INEXT = 5
          PERFORM SREND
          LBSTRT = LBEND
          IPL = IWRK(IPH+5)
          IWRK(IPH+8) = 1
C
N         SEARCH FOR END OF TRKEL IN HIGHER LAYERS
          INEXT = 7
          PERFORM SREND
          IPH = IWRK(IPH+7)
C     PRINT 2001, IP,IPL,IPH,NLINEL
C
N         CHECK IF TRKEL. (>3 HITS)
          IF NLINEL+2.GE.LMTREL(13)
N         *****  THIS MIGHT BE A TRACK ELEMENT  *****
          THEN
C
N           CHECK FOR KINKS,
N           CALCULATE TRACK PARAMETERS,
N           STORE RESULTS IN TRKEL BANK
            PERFORM TRCHCK
C     PRINT 2001, IP,IPL,IPH,NLINEL
          CIF
        CIF
      IP = IP + HLDHT
      UNTIL IP.GT.HPHT9
C
N     SET POINTER TO END OF TRACK ARRAY
      HPFREE= IPTR
      HPTR9 = IPTR - 1
C
N     SET NUMBER OF TRKELS
      NTRKEL = MTRK
C
C     IF(ICELL.GT. 0) PRINT 2900, IERRCD, ICELL, NTRCNT
C     IF(ICELL.GT. 36) PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
C     IF(ICELL.GT. 36) PRINT 2902, (WRK(I1),I1=HPTR0,HPTR9)
      RETURN
N     *************************
N     *      S R E N D        *
N     *************************
N     SEARCH FOR END OF TRKEL
      PROC SREND
C
N         POINTER TO LAST LINEL
          IPH   = IP
N         POINTER
          IPA   = IWRK(IP+INEXT)
N         PRESET END LABEL
          LBEND = 0
            WHILE IPA.GT.0
              IPNXT = IWRK(IPA+INEXT)
C
N             CHECK IF COMPLETE LINEL
              IF IPNXT.LE.0
              THEN
                LBEND = LBNOCN
                XWHILE
              CIF
C
N             CHECK IF 'POINT OF DIVERGENCE'
              IF IWRK(IPNXT+8).NE.0 .OR. LAND(IWRK(IPA+4),MKDIVL).NE.0
              THEN
                LBEND = LBKINK
                XWHILE
              CIF
C
              NLINEL = NLINEL + 1
              IPH    = IPA
N             GET POINTER TO NEXT LINEL.
              IPA    = IPNXT
            CWHILE
      CPROC
C
N     *************************
N     *      T R C H C K      *
N     *************************
N      CHECK TREL FOR KINKS + CALC. PARAMETERS
      PROC TRCHCK
C
N       SET UP ARRAYS: HPBACK,HLYAR,HLBAR,DSPAR
        IHIT = 0
        IPA = IPL
        REPEAT
N         LABEL USED HITS
          IWRK(IPA+8) = 1
          IHIT = IHIT + 1
          HPBAK(IHIT  ) = IPA
          HLYAR(IHIT  ) = IWRK(IPA  )
          DSPAR(IHIT) =  WRK(IPA+2)
C     PRINT 2011, IPA,IHIT ,HLYAR(IHIT ),DSPAR(IHIT )
        IPA = IWRK(IPA+ 7)
        UNTIL IPA.GE.IPH
N       LAST POINT IN ARRAYS
        IWRK(IPA+8) = 1
        HPBAK(IHIT+1) = IPA
        HLYAR(IHIT+1) = IWRK(IPA  )
        DSPAR(IHIT+1) =  WRK(IPA+2)
N       POINTER TO 1. + LAST HIT
        JHIT0 = 1
        JHIT9 = IHIT + 1
        IHIT9 = JHIT9
        IHIT0 = 1
        MHIT = IHIT9 - IHIT0 + 1
C     PRINT 2011, IPA,IHIT9,HLYAR(IHIT9),DSPAR(IHIT9)
N       MARKER FOR CUT OF TREL-CAND
        MKCUT = 0
C
        WHILE MHIT.GE.LMTREL(13)
C
N         TREL ANALYSIS WITH PARABOLA FIT
          DSTAG0 = 0.
          NITER = LMTREL(6)
          PERFORM TRELAN
C
          IF STAGSG.LE.SIGLM .AND. YPMIN.GE.TRELLM(10)
          THEN
C
N           DET L/R
            DSIGLR = ABS(SIGL-SIGR)
            IF DSIGLR.GT.TRELLM(19) .AND.
     ?         (MHIT.GT.6 .OR. STAGSG.LE.TRELLM(14)**2)
            THEN
              LBLR =-1
              IF(SIGR.LT.SIGL) LBLR = 1
            ELSE
              LBLR = 0
            CIF
N           STORE TRACK PARAMETERS
            PERFORM TRKPAR
            MHIT = 0
C
N         BAD FIT: CUT + CONT. WITH 1. BRANCH
          ELSE
            PERFORM CUTREL
            MHIT = IHIT9 - IHIT0 + 1
          CIF
C
N         FETCH LEFT OVER BRANCH IF NOT ENOUGH HITS LEFT
          IF MKCUT.NE.0 .AND. MHIT.LT.LMTREL(13)
          THEN
            IHIT0 = JHIT0
            IHIT9 = JHIT9
            MKCUT = 0
            MHIT = IHIT9 - IHIT0 + 1
          CIF
        CWHILE
      CPROC
C
N     *************************
N     *      C U T R E L      *
N     *************************
N     CUT TREL
      PROC CUTREL
C
        IHITM1 = IHITM0
        IHITM2 = IHITM0
        MHIT = IHIT9 - IHIT0 + 1
C
N       SELECT DIFFERENT CUT PROCEDURES
        REPEAT
C
N         0-XING AT SMALL ANGLE
          IF YPMIN.LT.TRELLM(10) .AND. STAGSG.LE.SIGLM
N         CUT 0-XING TRACK AT MIN(PARABOLA)
          THEN
N           FIND HIT CLOSE TO MIN(PARABOLA)
            HLYMIN = XPMIN
            FOR IHIT=IHIT0,IHIT9
              IF(HLYAR(IHIT).LE.HLYMIN) IHITM1 = IHIT
            CFOR
            IHITM2 = IHITM1 + 1
C     PRINT 2003, IHITM1,IHITM2,XPMIN,YPMIN
C2003 FORMAT(' CUTMIN:',2I6,2F10.1)
            XREPEAT
          CIF
C
N         0-XING AT BIG ANGLE
          IF YPMIN.LT.10. .AND. MHIT.GE.5
          THEN
N           CUT 0-XING TRACK AT MIN(DRIFTSP.)
            IHMIN  = IHIT0
            DSMIN  = 100000.
N           FIND HIT CLOSE TO MIN(PARABOLA)
            FOR IHIT=IHIT0,IHIT9
              IF DSPAR(IHIT).LT.DSMIN
              THEN
                DSMIN = DSPAR(IHIT)
                IHMIN = IHIT
              CIF
            CFOR
N           SAVE FOUND MIN.
            IHMINS = IHMIN
C
N           0-XING: HIT BELOW MIN.
N           INITIALIZE D(DRIFTSP.) OF ADJACENT HITS
            DDSP   = 1000.
            IF IHMIN.EQ.IHIT9
            THEN
N             MIN AT LAST HIT
              IHMIN = IHMIN - 1
            ELSE
              IF IHMIN.GT.IHIT0
              THEN
                DDSP = DSPAR(IHMIN+1) - DSPAR(IHMIN-1)
                IF(DDSP.GT.0) IHMIN = IHMIN - 1
              CIF
            CIF
N           CHECK SLOPE
            LBCUT = 0
            IF IHMIN-2.LT.IHIT0
            THEN
              IF(DSPAR(IHMIN+3)-DSPAR(IHMIN+1).GT.2.0) LBCUT = 1
            ELSE
              IF IHMIN+3.GT.IHIT9
              THEN
                IF(DSPAR(IHMIN-2)-DSPAR(IHMIN  ).GT.2.0) LBCUT = 1
              ELSE
                ZSL1 = DSPAR(IHMIN-2) - DSPAR(IHMIN  )
                ZSL2 = DSPAR(IHMIN+3) - DSPAR(IHMIN+1)
                IF(ZSL1.GT.2.0 .OR. ZSL2.GT.2.0) LBCUT = 1
              CIF
            CIF
            IF LBCUT.NE.0
            THEN
N             CHECK IF CLEAR MIN.
              IF ABS(DDSP).GT..6 .AND. DSMIN.GT..6
              THEN
                IHITM1 = IHMIN
                IHITM2 = IHMIN + 1
              ELSE
                IHITM1 = IHMINS - 1
                IHITM2 = IHMINS + 1
              CIF
              XREPEAT
            CIF
          CIF
C
N         KINK OR DISCONTINUITY
          IF MHIT.GE.6
          THEN
            DRES1 = 0.
            DRES2 = 0.
            IHMX1 =-1
            IHMX2 =-1
            DSL0  = PAR10*8.
N           LOOP OVER ALL HITS
            IHIT4 = IHIT0+4
            FOR IHIT = IHIT0,IHIT9
              X = HLYAR(IHIT)
              Y = DSPAR(IHIT)
              F = FPAR0(X)
              DCHI = F - Y
              RESAR(IHIT) = DCHI
C
N             FIND MAX.GAP + MAX.KINK
              IF IHIT.GT.IHIT0
              THEN
C
N               GAP:
                DDRES1 = ABS(DCHI-DCHI1)
                IF DDRES1.GT.DRES1
                THEN
                  DRES1 = DDRES1
                  IHMX1 = IHIT
                CIF
C
                IF IHIT.GE.IHIT4
                THEN
N                 KINK:
C                 DDRES2 = ABS(2.*RESAR(IHIT-2) - RESAR(IHIT-4) - DCHI)
                  DDRES2 = ABS(2.*DSPAR(IHIT-2)-DSPAR(IHIT-4)-Y + DSL0)
                  IF DDRES2.GT.DRES2
                  THEN
                    DRES2 = DDRES2
                    IHMX2 = IHIT-2
                  CIF
                CIF
              CIF
C     IF(ICELL.GT. 36)
C    ,PRINT 2009, IHIT,X,Y,F,DCHI,DRES1,DRES2,DDRES1,DDRES2
C
              DCHI1 = DCHI
            CFOR
N           SCALE UP DDRES1 (COMPARABLE TO DDRES2)
            DRES1 = DRES1 * 1.5
C
C     IF(ICELL.GT. 36) PRINT 2010, IHMX1,DRES1,IHMX2,DRES2
C
N           CHECK IF REAL CUT FOUND
            DRES0 = TRELLM(16)*2.5
            IF DRES0.LT.DRES2 .OR. DRES0.LT.DRES1
            THEN
C
N             SELECT GAP OR KINK CUT
              IF DRES1-DRES2 .LT. TRELLM(14)*1.4
N             KINK CUT SELECTED
              THEN
C
N               CHECK IF 0-XING
                IF DSPAR(IHMX2).LT.TRELLM(10)
                THEN
N                 0-XING: SELECT CUT
                  IF DSPAR(IHMX2-1).LT.DSPAR(IHMX2+1)
                  THEN
                    IHITM2 = IHMX2
                    IHITM1 = IHMX2 - 1
                  ELSE
                    IHITM1 = IHMX2
                    IHITM2 = IHMX2 + 1
                  CIF
                ELSE
N                 NOT 0-XING: SELECT CUT
                  IF DRES2.GT.TRELLM(14)*5.
                  THEN
                    IHITM1 = IHMX2
                    IHITM2 = IHMX2
                  ELSE
                    IHITM1 = IHMX2 - 1
                    IHITM2 = IHMX2 + 1
                  CIF
                CIF
C
N             GAP CUT SELECTED
              ELSE
                IHITM1 = IHMX1 - 1
                IHITM2 = IHMX1
              CIF
            CIF
          CIF
        UNTIL .TRUE.
C
N       SELECT 1. BRANCH FOR CONT.
C     IF(ICELL.GT. 36)
C    ,PRINT 2008, IHIT0,IHIT9,MKCUT,JHIT0,JHIT9,IHITM1,IHITM2
        IF MKCUT.EQ.2  .OR.
     ?     ((IHITM1-IHIT0).GE.(IHIT9-IHITM2) .AND. MKCUT.EQ.0)
        THEN
N         SELECT 1. BRANCH
          IF IHITM1.GT.IHIT0
          THEN
            IF(IHITM1.EQ.IHIT9) IHITM1 = IHITM1 - 1
            IHIT9 = IHITM1
            IF(MKCUT.NE.1) JHIT0 = MIN0(IHITM2,JHIT9)
            MKCUT = 2
          ELSE
            IHIT9 = JHIT9
            IHIT0 = IHIT0+1
            JHIT0 = IHIT0
            MKCUT = 0
          CIF
        ELSE
N       SELECT 2. BRANCH
          IF IHITM2.LT.IHIT9
          THEN
            IF(IHITM2.EQ.IHIT0) IHITM2 = IHITM2 + 1
            IHIT0 = IHITM2
            IF(MKCUT.NE.2) JHIT9 = MAX0(IHITM1,JHIT0)
            MKCUT = 1
          ELSE
            IHIT0 = JHIT0
            IHIT9 = IHIT9-1
            JHIT9 = IHIT9
            MKCUT = 0
          CIF
        CIF
      CPROC
C
N     *************************
N     *      T R K P A R      *
N     *************************
N     GET TREL PARAMETERS
      PROC TRKPAR
C
N       FINAL FIT WITH STAGGERING CORRECTION
        DSTAG0 = SWDEPL*LBLR
        NITER = 0
        PERFORM TRELAN
C
N       CHECK # OF HITS
        IF MHIT.GE.LMTREL(13)
        THEN
C
N         LABEL HITS OF TREL / FIND POINTER TO 1. + LAST HIT
          FOR IHIT = IHIT0,IHIT9
            IF HLBAR(IHIT).EQ.0
            THEN
              IPA = HPBAK(IHIT)
              IWRK(IPA+10) = IWRK(IPA+9)
              IWRK(IPA+ 9) = IPTR
            CIF
          CFOR
C
C
N         SET LABELS FOR START + END POINT
          LRIND = SHFTR(LBLR+3,1)
          IF(DSMAX(ILAY0+1,IRING,LRIND)-5. .LT. DS0)
     ?      LBSTRT = LOR(LBSTRT,LBWALL)
          IF(DS0.LT.1.5) LBSTRT = LOR(LBSTRT,LBWIRE)
          IF(DSMAX(ILAY9+1,IRING,LRIND)-5. .LT. DS9)
     ?      LBEND  = LOR(LBEND ,LBWALL)
          IF(DS9.LT.1.5) LBEND  = LOR(LBEND ,LBWIRE)
C
N         SET TRACK LABEL
          LBTR = LOR(SHFTL(LBEND,4),LBSTRT)
          LBTR = LOR(LBTR,LBTREL)
N         SET L/R BIT
          LBTR = LOR(LBTR,LBLFRT(LBLR+2))
C
N         SET BANK OF TREL
          IWRK(IPTR   ) = IPHIT0
          IWRK(IPTR+ 1) = IPHIT9
          IWRK(IPTR+ 2) = MHIT
          WRK (IPTR+ 3) = PAR1
          WRK (IPTR+ 4) = PAR2
          WRK (IPTR+ 5) = PAR3
          WRK (IPTR+ 6) = SQRT(SIG)
          IWRK(IPTR+ 7) = ILAY0
          WRK (IPTR+ 8) = DS0
          WRK (IPTR+ 9) = SLOP0
          IWRK(IPTR+10) = ILAY9
          WRK (IPTR+11) = DS9
          WRK (IPTR+12) = SLOP9
          IWRK(IPTR+13) = LBSTRT
          IWRK(IPTR+14) = LBEND
          IWRK(IPTR+15) = LBTR
          I9 = IPTR + HLDTR - 1
          MTRK = MTRK + 1
          IPTR = IPTR + HLDTR
        CIF
      CPROC
C
N     *************************
N     *      T R E L A N      *
N     *************************
C
C
N     TREL ANALYSIS WITH PARABOLA FIT
      PROC TRELAN
C
N     ITERATE UNTIL GOOD PARABOLA FIT
      ITER = 0
C
N     IF 1. HIT CLOSE TO ZERO +  2. HIT NOT:
N     IGNORE 1. HIT
      IF(DSPAR(IHIT0).LT.1.5 .AND. DSPAR(IHIT0+1).GT.5.) IHIT0 = IHIT0+1
      IF(DSPAR(IHIT9).LT.1.5 .AND. DSPAR(IHIT9-1).GT.5.) IHIT9 = IHIT9-1
N     INITIALIZE LABEL OF BAD HITS
      IF NITER.GT.0
      THEN
        FOR IHIT=IHIT0,IHIT9
          HLBAR(IHIT) = 0
        CFOR
      CIF
C
      REPEAT
C
N       FIT PARABOLA
        PERFORM FPARAB
C
N       CHECK IF ENOUGH HITS
        IF MHIT.LT.LMTREL(13)
        THEN
          STAGSG = 10000000.
          IHITM0 = IHIT0 + 1
          XREPEAT
        CIF
C
N       CALC. CHISQ + SOLVE L/R AMBIGUITY
        CHISQ = 0.
        STAGS1 = 0.
        STGSL1 = 0.
        STGSL2 = 0.
        STGSR1 = 0.
        STGSR2 = 0.
        DCHIM1 = 0.
        IHITM1 = 0
        FOR IHIT = IHIT0,IHIT9
N         CHECK IF NOT REJECTED HIT
          IF HLBAR(IHIT).EQ.0
          THEN
            X = HLYAR(IHIT)
            DSTAG = DSTAG0
            IF(LAND(HLYAR(IHIT),1).NE.0) DSTAG =-DSTAG0
            Y = DSPAR(IHIT) + DSTAG
            F = FPAR(X)
            DCHI = Y - F
            RESAR(IHIT) = DCHI
N           SUM FOR RMS
            CHISQ = CHISQ + DCHI**2
N           KEEP BIGGEST RMS
            IF ABS(DCHI).GE.DCHIM1
            THEN
              DCHIM1 = ABS(DCHI)
              IHITM1 = IHIT
            CIF
N           SUM FOR RMS WITH CORRECTION OF STAGG.
            IF LAND(HLYAR(IHIT),1).NE.0
            THEN
              STAGS1 = STAGS1 + DCHI
              DCHIL = DCHI + SWDEPL
              DCHIR = DCHI - SWDEPL
            ELSE
              STAGS1 = STAGS1 - DCHI
              DCHIL = DCHI - SWDEPL
              DCHIR = DCHI + SWDEPL
            CIF
            STGSL1 = STGSL1 + DCHIL
            STGSL2 = STGSL2 + DCHIL**2
            STGSR1 = STGSR1 + DCHIR
            STGSR2 = STGSR2 + DCHIR**2
C     IF(ICELL.GT. 36)
C    ,PRINT 2006, IHIT,X,Y,F,DCHI,CHISQ,STAGS1,DCHIL,DCHIR,DSTAG0,SWDEPL
          CIF
        CFOR
        SIG    =      CHISQ  / DEG
        SIGL   = STGSL2 / DEG
        SIGR   = STGSR2 / DEG
        STAGSG = AMIN1(SIGL,SIGR)
        STAGAV = STAGS1 / S0
C
N       SAVE PAR. OF 0-TH ITER.
        IF ITER.EQ.0
        THEN
          PAR10 = PAR1
          PAR20 = PAR2
          PAR30 = PAR3
          IHITM0 = IHITM1
        CIF
C
N       CALC. MIN(PARABOLA)
        YPMIN = 1000.
        XPMIN = 1000.
        IF(PAR1.NE.0.) XPMIN = -.5 * PAR2 / PAR1
        IF(XPMIN.GT.HLYAR(IHIT0) .AND. XPMIN.LT.HLYAR(IHIT9))
     ?    YPMIN = FPAR(XPMIN)
C     IF(ICELL.GT. 36)
C    ,PRINT 2007, MHIT,IHIT0,IHIT9,PAR1,PAR2,PAR3,SIGLM,SIG,SIGL,SIGR
C    ,          ,XPMIN,YPMIN
C
N       GOOD FIT .OR. TOO SMALL # OF HITS: STOP
        IF(STAGSG.LE.SIGLM .OR. MHIT.LE.LMTREL(13)) XREPEAT
N       BAD FIT, <7 HITS, HIGH CURV: STOP
        IF(MHIT.LE.6 .AND. ABS(PAR1).GT.TRELLM(9)) XREPEAT
N       MIN(PARABOLA) CLOSE TO ZERO: STOP
        IF(YPMIN.LT.      100.) XREPEAT
C
N       INCREASE LIMIT FOR STRAIGHT DISTORTED TRACKS
        IF MHIT.GE.6.AND.ABS(PAR1).LT..010.AND.STAGSG.LT.TRELLM(14)*1.5
        THEN
          DCHI = RESAR(IHITM1)
N         CORRECTION OF STAGG.
          IF LAND(HLYAR(IHITM1),1).NE.0
          THEN
            DCHIL = DCHI + SWDEPL
            DCHIR = DCHI - SWDEPL
          ELSE
            DCHIL = DCHI - SWDEPL
            DCHIR = DCHI + SWDEPL
          CIF
          DCHI = DCHIL
          IF(SIGR.GT.SIGL) DCHI = DCHIR
          IF DCHI**2*.33 .LT. STAGSG
          THEN
            SIGLM = AMAX1(STAGSG*1.01,SIGLM)
            XREPEAT
          CIF
        CIF
C
N       CHECK WORST POINT
        IDHITM = IABS(IHITM1-IHITM0)
        DDCHIM = DCHIM1
        IF(IHITM1.NE.IHIT0 .AND. IHITM1.NE.IHIT9)
     ?  DDCHIM = ABS(RESAR(IHITM1)-(RESAR(IHITM1-1)+RESAR(IHITM1+1))*.5)
        IF(IDHITM.EQ.1) XREPEAT
        IF(DDCHIM**2.LT.SIGLM*4.0) XREPEAT
C
N       LABEL WORST POINT + TRY AGAIN
        IF IHITM1-IHIT0 .EQ. 1
        THEN
N         2. HIT BAD: CHECK IF NOT 1. HIT
          SL0   = HLYAR(IHITM1)*PAR1*2. + PAR2
          DDSP1 = ABS(DSPAR(IHIT0+1)+SL0    - DSPAR(IHIT0+2))
          DDSP2 = ABS(DSPAR(IHIT0  )+SL0*2. - DSPAR(IHIT0+2))
          IF(DDSP1 .LT. DDSP2) IHITM1 = IHIT0
C     PRINT 2012,IHITM1,SL0,DSP0,DDSP1,DDSP2,RESAR(IHIT0),RESAR(IHIT0+1)
        ELSE
          IF IHIT9-IHITM1 .EQ. 1
          THEN
N           LAST BUT ONE HIT BAD: CHECK IF NOT LAST HIT
            SL0   = HLYAR(IHITM1)*PAR1*2. + PAR2
            DDSP1 = ABS(DSPAR(IHIT9-1)-SL0    - DSPAR(IHIT9-2))
            DDSP2 = ABS(DSPAR(IHIT9  )-SL0*2. - DSPAR(IHIT9-2))
            IF(DDSP1 .LT. DDSP2) IHITM1 = IHIT9
C     PRINT 2012,IHITM1,SL0,DSP0,DDSP1,DDSP2,RESAR(IHIT9),RESAR(IHIT9-1)
          CIF
        CIF
        IF(ITER.NE.NITER) HLBAR(IHITM1) = 1
        ITER = ITER + 1
      UNTIL ITER.GT.NITER
C
N     RESET LABEL OF BAD HITS
      IF ITER.GT.0 .AND. STAGSG.LE.SIGLM
      THEN
N       REDUCE RANGE IF WORST POINTS AT END
        IF(HLBAR(IHIT0).NE.0) IHIT0 = IHIT0 + 1
        IF(HLBAR(IHIT0).NE.0) IHIT0 = IHIT0 + 1
        IF(HLBAR(IHIT9).NE.0) IHIT9 = IHIT9 - 1
        IF(HLBAR(IHIT9).NE.0) IHIT9 = IHIT9 - 1
        IF(IHIT9.LT.JHIT0) JHIT0 = IHIT9
        IF(IHIT0.GT.JHIT9) JHIT9 = IHIT0
      CIF
C
      CPROC
C
N     *************************
N     *      F P A R A B      *
N     *************************
C
C
N     PARABOLA FIT TO TREL-CAND
      PROC FPARAB
C
N     GET EQUATIONS
      S0 = 0.
      S1 = 0.
      S2 = 0.
      S3 = 0.
      S4 = 0.
      S5 = 0.
      S6 = 0.
      S7 = 0.
      FOR IHIT = IHIT0,IHIT9
N       SELECT UNREJECTED HITS ONLY
        IF HLBAR(IHIT).EQ.0
        THEN
          IX = HLYAR(IHIT)
          X  = IX
          DSTAG = DSTAG0
          IF(LAND(IX,1).NE.0) DSTAG =-DSTAG0
          Y = DSPAR(IHIT) + DSTAG
          X2 = X**2
          S1 = S1 + X
          S2 = S2 + X2
          S3 = S3 + X*X2
          S4 = S4 + X2**2
          S5 = S5 + Y*X2
          S6 = S6 + Y*X
          S7 = S7 + Y
          S0 = S0 + 1.
        CIF
      CFOR
      MHIT = S0 + .5
C
N     CHECK IF <3 HITS
      IF MHIT.LT.3
      THEN
        SIG = TRELLM(12)**2
        PAR1 = 0.
        PAR2 = 0.
        PAR3 = 0.
        DEG = 1.
        S0  = 1.
      ELSE
        IF MHIT.LE.4
N       STRAIGHT LINE FIT IF 3 - 4 HITS
        THEN
          ZW1  = (S6*S0 - S1*S7)
          ZW2  = (S2*S0 - S1**2)
          PAR1   = 0.
          PAR2   = ZW1 / ZW2
          PAR3   =(S7 - PAR2*S1) / S0
          DEG = S0 - 2.
        ELSE
N         SOLVE EQUATIONS FOR PARABOLA FIT
          F1 = 1. / S4
          XX12 = S3*F1
          XX13 = S2*F1
          YY1  = S5*F1
          XX22 = S2 - S3*XX12
          XX23 = S1 - S3*XX13
          YY2  = S6 - S3*YY1
          XX32 = S1 - S2*XX12
          XX33 = S0 - S2*XX13
          YY3  = S7 - S2*YY1
          IF XX22.GT.XX32
          THEN
            XX23 = XX23 / XX22
            YY2  = YY2  / XX22
            PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
            PAR2 = YY2 - XX23*PAR3
          ELSE
            XX33 = XX33 / XX32
            YY3  = YY3  / XX32
            PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
            PAR2 = YY3 - XX33*PAR3
          CIF
          PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
          DEG = S0 - 3.
C
          IF MHIT.LT.6 .AND. ABS(PAR1).GT.TRELLM(9)
N         STRAIGHT LINE FIT IF <6 HITS + TOO BIG CURV.
          THEN
            ZW1  = (S6*S0 - S1*S7)
            ZW2  = (S2*S0 - S1**2)
            PAR1   = 0.
            PAR2   = ZW1 / ZW2
            PAR3   =(S7 - PAR2*S1) / S0
            DEG = S0 - 2.
          CIF
        CIF
C
      CIF
C
N       CALC. START + END POINT PARAM.
        ILAY0 = HLYAR(IHIT0)
        WR0   = ILAY0
        DS0   = FPAR(WR0)
        SLOP0 = WR0*PAR1*2. + PAR2
        ILAY9 = HLYAR(IHIT9)
        WR9   = ILAY9
        DS9   = FPAR(WR9)
        SLOP9 = WR9*PAR1*2. + PAR2
C
N       DETERMINE LIMIT OF SIGMA
        MDHIT = IHIT9-IHIT0 + 1 - MHIT
        IF ABS(PAR1).GT..05 .OR. (MHIT.LT.6 .AND. MDHIT.GT.0)
        THEN
N         CURVED TRACK
          SIGLM = TRELLM(16)**2
        ELSE
N         STRAIGHT TRACK
          SIG1 = TRELLM(16)
          SIG2 = 0.
          SIG3 = 0.
N         INCREASE LIMIT FOR TRACKS AT WALL
          IF(DSMAX(ILAY0+1,IRING,1)-5. .LT. DS0) SIG2 = TRELLM(17)
N         INCREASE LIMIT FOR TRACKS AT WIRE PLANE
          IF(DS0.LT.1.5) SIG3 = TRELLM(18)
          IF(DSMAX(ILAY9+1,IRING,1)-5. .LT. DS9) SIG2 = SIG2+TRELLM(17)
          IF(DS9.LT.1.5) SIG3 = SIG3 + TRELLM(18)
          SIGLM = SIG1**2 + SIG2**2 + SIG3**2
        CIF
C
N       SPECIAL LIMIT FOR RATHER STRAIGHT TRELS
N       WITH BIG SLOPE
        SIGSL = 0.
        SLRAT =  AMIN1(ABS(SLOP0+SLOP9)*.1, 1.0)
        IF(ABS(PAR1).LT..5 .AND. SLRAT .GT. 0.2)
     ?  SIGSL = (SLRAT*TRELLM(17))**2 + TRELLM(16)**2
        IF(SIGSL.GT.SIGLM) SIGLM = SIGSL
C
      CPROC
C
      END
C   03/09/79 706261839  MEMBER NAME  INPATC   (S)           SHELTRAN
      SUBROUTINE INPATC
      IMPLICIT INTEGER*2 (H)
C
C-----------------------------------------------------------------------
C        INITIALIZE CONSTANTS USED BY PATTERN RECOGNITION PROGRAMS
C        ADDED CALL TO ADPATR     26/06/87     E ELSEN
C-----------------------------------------------------------------------
C
#include "cdata.for"
#include "cdsmax.for"
#include "cjdrch.for"
C
C   CHANGED TO CHECK RUN NUMBER AND TO RETURN IF NO NEW RUN NUMBER
C
      DATA HHHRUN /-1/
C
      IPHE = IDATA(IBLN('HEAD'))
      HHRUN = HDATA(2*IPHE+10)
      IF(HHRUN.EQ.HHHRUN) RETURN
      HHHRUN = HHRUN
C
C                                           CHANGED 26/06/87
      NRUN = HHRUN
      CALL ADPATR( NRUN )
C
C---------------------------
C     ANGLES OF CELL BOUNDS
C---------------------------
      DFI0 = 3.1415927 / 12.
      DFI1 = 3.1415927 / 24.
      DFI3 = 3.1415927 / 48.
C-------------------------------------------
C    WIRE PLANE DIRECTIONS FOR RINGS 1 AND 2
C-------------------------------------------
      FI = DFI1
      FOR I=1,6
        DX = COS(FI)
        DY = SIN(FI)
        DIRWR1(I   ,1) = DX
        DIRWR1(I   ,2) = DY
        DIRWR1(I+ 6,1) =-DY
        DIRWR1(I+ 6,2) = DX
        DIRWR1(I+12,1) =-DX
        DIRWR1(I+12,2) =-DY
        DIRWR1(I+18,1) = DY
        DIRWR1(I+18,2) =-DX
        FI = FI + DFI0
      CFOR
C------------------------------------
C    WIRE PLANE DIRECTIONS FOR RING 3
C------------------------------------
      FI = DFI3
      FOR I=1,12
        DX = COS(FI)
        DY = SIN(FI)
        DIRWR3(I   ,1) = DX
        DIRWR3(I   ,2) = DY
        DIRWR3(I+12,1) =-DY
        DIRWR3(I+12,2) = DX
        DIRWR3(I+24,1) =-DX
        DIRWR3(I+24,2) =-DY
        DIRWR3(I+36,1) = DY
        DIRWR3(I+36,2) =-DX
        FI = FI + DFI1
      CFOR
C---------------------------------
C    DRIFT SPACE DIRECTIONS
C---------------------------------
      FOR I=1,96
C     GET WIRE PLANE DIRECTION
      K = I
      IF(K.GT.24) K=K-24
      IF I.LE.48
      THEN
      DX=DIRWR1(K,1)
      DY=DIRWR1(K,2)
      ELSE
      DX=DIRWR3(K-24,1)
      DY=DIRWR3(K-24,2)
      CIF
C     FORM DRIFT DIRECTION TRANSFORMATION MATRIX
C       TRMATS(CELL,L/R)
        TRMATS(I,1) = -( DY * COSDRI(I,1) + DX * SINDRI(I,1) )
        TRMATS(I,2) = -( DY * COSDRI(I,2) + DX * SINDRI(I,2) )
        TRMATC(I,1) =  ( DX * COSDRI(I,1) - DY * SINDRI(I,1) )
        TRMATC(I,2) =  ( DX * COSDRI(I,2) - DY * SINDRI(I,2) )
      CFOR
C-------------------------------
C     INITIALIZE MAX. DRIFTSPACE
C-------------------------------
      FACTL1 = SIN(DFI1) / COS(DFI1+DRIDEV)
      FACTR1 = SIN(DFI1) / COS(DFI1-DRIDEV)
      FACTL3 = SIN(DFI3) / COS(DFI3+DRIDEV)
      FACTR3 = SIN(DFI3) / COS(DFI3-DRIDEV)
      R1 = FSENSW(1)
      R2 = FSENSW(2)
      R3 = FSENSW(3)
      FOR ILAY=1,16
C       DSMAX(LAYER,RING,L/R)
        DSMAX(ILAY,1,1) = R1 * FACTL1
        DSMAX(ILAY,2,1) = R2 * FACTL1
        DSMAX(ILAY,3,1) = R3 * FACTL3
        DSMAX(ILAY,1,2) = R1 * FACTR1
        DSMAX(ILAY,2,2) = R2 * FACTR1
        DSMAX(ILAY,3,2) = R3 * FACTR3
        R1 = R1 + RINCR(1)
        R2 = R2 + RINCR(2)
        R3 = R3 + RINCR(3)
      CFOR
      CALL INBACK
      RETURN
      END
C
C    ***************************************
C
      SUBROUTINE INBACK
      IMPLICIT INTEGER*2 (H)
C--------------------------------------------
C      INITIALIZATION OF CONSTANTS FOR BACKTR
C--------------------------------------------
#include "cdsmax.for"
#include "cjdrch.for"
C
       DIMENSION LFTCL(3),LSTCL(3),NCELL(3),TANDEL(3)
       EQUIVALENCE (IBCK(1),LSTCL(1)),(IBCK(4),LFTCL(1))
       EQUIVALENCE (IBCK(7),NCELL(1)),(DBCK(1),TANDEL(1))

      DIMENSION GB(3)
      DATA GB/376.,586.,797./
C
      NCELL(1)=24
      NCELL(2)=24
      NCELL(3)=48
      LSTCL(1)=24
      LSTCL(2)=48
      LSTCL(3)=96
      LFTCL(1)=1
      LFTCL(2)=25
      LFTCL(3)=49
      DEL=3.141593/48.
      DBCK(4)=COS(DEL-DRIDEV)
      DBCK(5)=COS(DEL+DRIDEV)
      DBCK(6)=TAN(DEL)
      DBCK(7)=TAN(DEL+3.141593/24.)
      DBCK(8)=SIN(DEL)
      DBCK(9)=-DBCK(8)
      DEL=DEL+3.141593/24.
      DBCK(10)=COS(DEL-DRIDEV)
      DBCK(11)=COS(DEL+DRIDEV)
      DBCK(12)=SIN(DEL)
      DBCK(13)=-DBCK(12)
      DEL=6.283185/24.
      DBCK(14)=COS(DEL-DRIDEV)
      DBCK(15)=COS(DEL+DRIDEV)
      DBCK(16)=SIN(DEL)
      DBCK(17)=-DBCK(16)
      DEL=DEL+3.141593/48.
      DBCK(18)=COS(DEL-DRIDEV)
      DBCK(19)=COS(DEL+DRIDEV)
      DBCK(20)=SIN(DEL)
      DBCK(21)=-DBCK(20)
      DBCK(22)=TAN(3.141593/12.+3.141593/48.)
N     INITIALIZE DHALF AND HMCH ARRAYS
      FOR KRING=1,3
      DEL=3.141593/NCELL(KRING)
      TANDEL(KRING)=TAN(DEL*2.)
      FOR IW=1,16
      DSMX=DSMAX(IW,KRING,1)
      IF(KRING.EQ.3) DSMSP=DSMAX(IW,2,1)
      ALSIN=-DRISIN
      AL=-DRIDEV
      PERFORM INIT
      HMCH(IW,KRING,1)=IK
      DHALF(IW,KRING,1)=DT
      DTWICE(IW,KRING,1)=DTW
      DSMX=DSMAX(IW,KRING,2)
      IF(KRING.EQ.3) DSMSP=DSMAX(IW,2,2)
      ALSIN=DRISIN
      AL=DRIDEV
      PERFORM INIT
      HMCH(IW,KRING,2)=IK
      DHALF(IW,KRING,2)=DT
      DTWICE(IW,KRING,2)=DTW
      CFOR
      CFOR
      RETURN
C
C *********************
C
      PROC INIT
C
C     THIS PROC CALCULATES QUANTITIES FOR HMCH AND DHALF ARRAYS
C     DHALF ARRAY CONTAINS 'HALF' THE MAX DRIFT DISTANCE FOR EACH WIRE
C     AND IS USED IN MATCHING TRACKS FROM RING 3 TO RING 2.
C     HMCH ARRAY CONTAINS THE WIRE NO. WHICH WILL FIRE IN THE
C     NEIGHBOURING CELL IF THE TRACK GOES THROUGH THE CELL
C     SIDEWALL.
C     THE CONVENTION IS THAT 1 IS LEFT AND 2 IS RIGHT.
C
      W=FSENSW(KRING)+FLOAT(IW-1)*RINCR(KRING)
      X=SQRT(W**2+DSMX**2-2.*W*DSMX*ALSIN)
      DTW=1.-TAN(DEL)*TAN(DEL-AL)
      DTW=2.*DSMX/DTW
      IF KRING.EQ.2
      THEN
      DTW=1.-TAN(DEL*.5)*TAN(DEL-AL)
      DTW=DSMX*(1.+TAN(DEL*.5)/TAN(DEL))/DTW
      CIF
      IF KRING.EQ.3
      THEN
      DTW=1.-TAN(DEL*1.5)*TAN(DEL-AL)
      DTW=DSMSP*(1.+TAN(DEL*1.5)/TAN(DEL))/DTW
      CIF
      DT=TAN(DEL*0.5)*TAN(DEL*0.5-AL)
N     DT IS DHALF
      DT=DSMX*0.5*(1.-DT)
N     NOW CALCULATE MCH ARRAY
      IF X.LT.GB(KRING)
      THEN
      IK=-5
      E=X*COS(AL+DEL)/DRICOS
      E=E-FSENSW(KRING)
      IF(E.GE.-5.) IK=(E+5.)/RINCR(KRING)
      IF(IK.GT.15) IK=20
      ELSE
      IK=20
      CIF
      CPROC
      END
C   03/09/79 C9091401   MEMBER NAME  INPATC   (PATRECS9)    SHELTRAN
      SUBROUTINE INPATC
      IMPLICIT INTEGER*2 (H)
C
C-----------------------------------------------------------------------
C        INITIALIZE CONSTANTS USED BY PATTERN RECOGNITION PROGRAMS
C-----------------------------------------------------------------------
C
#include "cdsmax.for"
#include "cjdrch.for"
C---------------------------
C     ANGLES OF CELL BOUNDS
C---------------------------
      DFI0 = 3.1415927 / 12.
      DFI1 = 3.1415927 / 24.
      DFI3 = 3.1415927 / 48.
C-------------------------------------------
C    WIRE PLANE DIRECTIONS FOR RINGS 1 AND 2
C-------------------------------------------
      FI = DFI1
      FOR I=1,6
        DX = COS(FI)
        DY = SIN(FI)
        DIRWR1(I   ,1) = DX
        DIRWR1(I   ,2) = DY
        DIRWR1(I+ 6,1) =-DY
        DIRWR1(I+ 6,2) = DX
        DIRWR1(I+12,1) =-DX
        DIRWR1(I+12,2) =-DY
        DIRWR1(I+18,1) = DY
        DIRWR1(I+18,2) =-DX
        FI = FI + DFI0
      CFOR
C------------------------------------
C    WIRE PLANE DIRECTIONS FOR RING 3
C------------------------------------
      FI = DFI3
      FOR I=1,12
        DX = COS(FI)
        DY = SIN(FI)
        DIRWR3(I   ,1) = DX
        DIRWR3(I   ,2) = DY
        DIRWR3(I+12,1) =-DY
        DIRWR3(I+12,2) = DX
        DIRWR3(I+24,1) =-DX
        DIRWR3(I+24,2) =-DY
        DIRWR3(I+36,1) = DY
        DIRWR3(I+36,2) =-DX
        FI = FI + DFI1
      CFOR
C---------------------------------
C    DRIFT SPACE DIRECTIONS
C---------------------------------
      FOR I=1,96
C     GET WIRE PLANE DIRECTION
      K = I
      IF(K.GT.24) K=K-24
      IF I.LE.48
      THEN
      DX=DIRWR1(K,1)
      DY=DIRWR1(K,2)
      ELSE
      DX=DIRWR3(K-24,1)
      DY=DIRWR3(K-24,2)
      CIF
C     FORM DRIFT DIRECTION TRANSFORMATION MATRIX
C       TRMATS(CELL,L/R)
        TRMATS(I,1) = -( DY * COSDRI(I,1) + DX * SINDRI(I,1) )
        TRMATS(I,2) = -( DY * COSDRI(I,2) + DX * SINDRI(I,2) )
        TRMATC(I,1) =  ( DX * COSDRI(I,1) - DY * SINDRI(I,1) )
        TRMATC(I,2) =  ( DX * COSDRI(I,2) - DY * SINDRI(I,2) )
      CFOR
C-------------------------------
C     INITIALIZE MAX. DRIFTSPACE
C-------------------------------
      FACTL1 = SIN(DFI1) / COS(DFI1+DRIDEV)
      FACTR1 = SIN(DFI1) / COS(DFI1-DRIDEV)
      FACTL3 = SIN(DFI3) / COS(DFI3+DRIDEV)
      FACTR3 = SIN(DFI3) / COS(DFI3-DRIDEV)
      R1 = FSENSW(1)
      R2 = FSENSW(2)
      R3 = FSENSW(3)
      FOR ILAY=1,16
C       DSMAX(LAYER,RING,L/R)
        DSMAX(ILAY,1,1) = R1 * FACTL1
        DSMAX(ILAY,2,1) = R2 * FACTL1
        DSMAX(ILAY,3,1) = R3 * FACTL3
        DSMAX(ILAY,1,2) = R1 * FACTR1
        DSMAX(ILAY,2,2) = R2 * FACTR1
        DSMAX(ILAY,3,2) = R3 * FACTR3
        R1 = R1 + RINCR(1)
        R2 = R2 + RINCR(2)
        R3 = R3 + RINCR(3)
      CFOR
      CALL INBACK
      RETURN
      END
C
C    ***************************************
C
      SUBROUTINE INBACK
      IMPLICIT INTEGER*2 (H)
C--------------------------------------------
C      INITIALIZATION OF CONSTANTS FOR BACKTR
C--------------------------------------------
#include "cdsmax.for"
#include "cjdrch.for"
C
       DIMENSION LFTCL(3),LSTCL(3),NCELL(3),TANDEL(3)
       EQUIVALENCE (IBCK(1),LSTCL(1)),(IBCK(4),LFTCL(1))
       EQUIVALENCE (IBCK(7),NCELL(1)),(DBCK(1),TANDEL(1))

      DIMENSION GB(3)
      DATA GB/376.,586.,797./
C
      NCELL(1)=24
      NCELL(2)=24
      NCELL(3)=48
      LSTCL(1)=24
      LSTCL(2)=48
      LSTCL(3)=96
      LFTCL(1)=1
      LFTCL(2)=25
      LFTCL(3)=49
      DEL=3.141593/48.
      DBCK(4)=COS(DEL-DRIDEV)
      DBCK(5)=COS(DEL+DRIDEV)
      DBCK(6)=TAN(DEL)
      DBCK(7)=TAN(DEL+3.141593/24.)
      DBCK(8)=SIN(DEL)
      DBCK(9)=-DBCK(8)
      DEL=DEL+3.141593/24.
      DBCK(10)=COS(DEL-DRIDEV)
      DBCK(11)=COS(DEL+DRIDEV)
      DBCK(12)=SIN(DEL)
      DBCK(13)=-DBCK(12)
      DEL=6.283185/24.
      DBCK(14)=COS(DEL-DRIDEV)
      DBCK(15)=COS(DEL+DRIDEV)
      DBCK(16)=SIN(DEL)
      DBCK(17)=-DBCK(16)
      DEL=DEL+3.141593/48.
      DBCK(18)=COS(DEL-DRIDEV)
      DBCK(19)=COS(DEL+DRIDEV)
      DBCK(20)=SIN(DEL)
      DBCK(21)=-DBCK(20)
      DBCK(22)=TAN(3.141593/12.+3.141593/48.)
N     INITIALIZE DHALF AND HMCH ARRAYS
      FOR KRING=1,3
      DEL=3.141593/NCELL(KRING)
      TANDEL(KRING)=TAN(DEL*2.)
      FOR IW=1,16
      DSMX=DSMAX(IW,KRING,1)
      IF(KRING.EQ.3) DSMSP=DSMAX(IW,2,1)
      ALSIN=-DRISIN
      AL=-DRIDEV
      PERFORM INIT
      HMCH(IW,KRING,1)=IK
      DHALF(IW,KRING,1)=DT
      DTWICE(IW,KRING,1)=DTW
      DSMX=DSMAX(IW,KRING,2)
      IF(KRING.EQ.3) DSMSP=DSMAX(IW,2,2)
      ALSIN=DRISIN
      AL=DRIDEV
      PERFORM INIT
      HMCH(IW,KRING,2)=IK
      DHALF(IW,KRING,2)=DT
      DTWICE(IW,KRING,2)=DTW
      CFOR
      CFOR
      RETURN
C
C *********************
C
      PROC INIT
C
C     THIS PROC CALCULATES QUANTITIES FOR HMCH AND DHALF ARRAYS
C     DHALF ARRAY CONTAINS 'HALF' THE MAX DRIFT DISTANCE FOR EACH WIRE
C     AND IS USED IN MATCHING TRACKS FROM RING 3 TO RING 2.
C     HMCH ARRAY CONTAINS THE WIRE NO. WHICH WILL FIRE IN THE
C     NEIGHBOURING CELL IF THE TRACK GOES THROUGH THE CELL
C     SIDEWALL.
C     THE CONVENTION IS THAT 1 IS LEFT AND 2 IS RIGHT.
C
      W=FSENSW(KRING)+FLOAT(IW-1)*RINCR(KRING)
      X=SQRT(W**2+DSMX**2-2.*W*DSMX*ALSIN)
      DTW=1.-TAN(DEL)*TAN(DEL-AL)
      DTW=2.*DSMX/DTW
      IF KRING.EQ.2
      THEN
      DTW=1.-TAN(DEL*.5)*TAN(DEL-AL)
      DTW=DSMX*(1.+TAN(DEL*.5)/TAN(DEL))/DTW
      CIF
      IF KRING.EQ.3
      THEN
      DTW=1.-TAN(DEL*1.5)*TAN(DEL-AL)
      DTW=DSMSP*(1.+TAN(DEL*1.5)/TAN(DEL))/DTW
      CIF
      DT=TAN(DEL*0.5)*TAN(DEL*0.5-AL)
N     DT IS DHALF
      DT=DSMX*0.5*(1.-DT)
N     NOW CALCULATE MCH ARRAY
      IF X.LT.GB(KRING)
      THEN
      IK=-5
      E=X*COS(AL+DEL)/DRICOS
      E=E-FSENSW(KRING)
      IF(E.GE.-5.) IK=(E+5.)/RINCR(KRING)
      IF(IK.GT.15) IK=20
      ELSE
      IK=20
      CIF
      CPROC
      END
C   03/09/79 504150529  MEMBER NAME  INPATC8  (JADENEWS)    SHELTRAN
      SUBROUTINE INPATC
      IMPLICIT INTEGER*2 (H)
C
C-----------------------------------------------------------------------
C        INITIALIZE CONSTANTS USED BY PATTERN RECOGNITION PROGRAMS
C-----------------------------------------------------------------------
C
#include "cdata.for"
#include "cdsmax.for"
#include "cjdrch.for"
C
C   CHANGED TO CHECK RUN NUMBER AND TO RETURN IF NO NEW RUN NUMBER
C
      DATA HHHRUN /-1/
C
      IPHE = IDATA(IBLN('HEAD'))
      HHRUN = HDATA(2*IPHE+10)
      IF(HHRUN.EQ.HHHRUN) RETURN
      HHHRUN = HHRUN
C
C---------------------------
C     ANGLES OF CELL BOUNDS
C---------------------------
      DFI0 = 3.1415927 / 12.
      DFI1 = 3.1415927 / 24.
      DFI3 = 3.1415927 / 48.
C-------------------------------------------
C    WIRE PLANE DIRECTIONS FOR RINGS 1 AND 2
C-------------------------------------------
      FI = DFI1
      FOR I=1,6
        DX = COS(FI)
        DY = SIN(FI)
        DIRWR1(I   ,1) = DX
        DIRWR1(I   ,2) = DY
        DIRWR1(I+ 6,1) =-DY
        DIRWR1(I+ 6,2) = DX
        DIRWR1(I+12,1) =-DX
        DIRWR1(I+12,2) =-DY
        DIRWR1(I+18,1) = DY
        DIRWR1(I+18,2) =-DX
        FI = FI + DFI0
      CFOR
C------------------------------------
C    WIRE PLANE DIRECTIONS FOR RING 3
C------------------------------------
      FI = DFI3
      FOR I=1,12
        DX = COS(FI)
        DY = SIN(FI)
        DIRWR3(I   ,1) = DX
        DIRWR3(I   ,2) = DY
        DIRWR3(I+12,1) =-DY
        DIRWR3(I+12,2) = DX
        DIRWR3(I+24,1) =-DX
        DIRWR3(I+24,2) =-DY
        DIRWR3(I+36,1) = DY
        DIRWR3(I+36,2) =-DX
        FI = FI + DFI1
      CFOR
C---------------------------------
C    DRIFT SPACE DIRECTIONS
C---------------------------------
      FOR I=1,96
C     GET WIRE PLANE DIRECTION
      K = I
      IF(K.GT.24) K=K-24
      IF I.LE.48
      THEN
      DX=DIRWR1(K,1)
      DY=DIRWR1(K,2)
      ELSE
      DX=DIRWR3(K-24,1)
      DY=DIRWR3(K-24,2)
      CIF
C     FORM DRIFT DIRECTION TRANSFORMATION MATRIX
C       TRMATS(CELL,L/R)
        TRMATS(I,1) = -( DY * COSDRI(I,1) + DX * SINDRI(I,1) )
        TRMATS(I,2) = -( DY * COSDRI(I,2) + DX * SINDRI(I,2) )
        TRMATC(I,1) =  ( DX * COSDRI(I,1) - DY * SINDRI(I,1) )
        TRMATC(I,2) =  ( DX * COSDRI(I,2) - DY * SINDRI(I,2) )
      CFOR
C-------------------------------
C     INITIALIZE MAX. DRIFTSPACE
C-------------------------------
      FACTL1 = SIN(DFI1) / COS(DFI1+DRIDEV)
      FACTR1 = SIN(DFI1) / COS(DFI1-DRIDEV)
      FACTL3 = SIN(DFI3) / COS(DFI3+DRIDEV)
      FACTR3 = SIN(DFI3) / COS(DFI3-DRIDEV)
      R1 = FSENSW(1)
      R2 = FSENSW(2)
      R3 = FSENSW(3)
      FOR ILAY=1,16
C       DSMAX(LAYER,RING,L/R)
        DSMAX(ILAY,1,1) = R1 * FACTL1
        DSMAX(ILAY,2,1) = R2 * FACTL1
        DSMAX(ILAY,3,1) = R3 * FACTL3
        DSMAX(ILAY,1,2) = R1 * FACTR1
        DSMAX(ILAY,2,2) = R2 * FACTR1
        DSMAX(ILAY,3,2) = R3 * FACTR3
        R1 = R1 + RINCR(1)
        R2 = R2 + RINCR(2)
        R3 = R3 + RINCR(3)
      CFOR
      CALL INBACK
      RETURN
      END
C
C    ***************************************
C
      SUBROUTINE INBACK
      IMPLICIT INTEGER*2 (H)
C--------------------------------------------
C      INITIALIZATION OF CONSTANTS FOR BACKTR
C--------------------------------------------
#include "cdsmax.for"
#include "cjdrch.for"
C
       DIMENSION LFTCL(3),LSTCL(3),NCELL(3),TANDEL(3)
       EQUIVALENCE (IBCK(1),LSTCL(1)),(IBCK(4),LFTCL(1))
       EQUIVALENCE (IBCK(7),NCELL(1)),(DBCK(1),TANDEL(1))

      DIMENSION GB(3)
      DATA GB/376.,586.,797./
C
      NCELL(1)=24
      NCELL(2)=24
      NCELL(3)=48
      LSTCL(1)=24
      LSTCL(2)=48
      LSTCL(3)=96
      LFTCL(1)=1
      LFTCL(2)=25
      LFTCL(3)=49
      DEL=3.141593/48.
      DBCK(4)=COS(DEL-DRIDEV)
      DBCK(5)=COS(DEL+DRIDEV)
      DBCK(6)=TAN(DEL)
      DBCK(7)=TAN(DEL+3.141593/24.)
      DBCK(8)=SIN(DEL)
      DBCK(9)=-DBCK(8)
      DEL=DEL+3.141593/24.
      DBCK(10)=COS(DEL-DRIDEV)
      DBCK(11)=COS(DEL+DRIDEV)
      DBCK(12)=SIN(DEL)
      DBCK(13)=-DBCK(12)
      DEL=6.283185/24.
      DBCK(14)=COS(DEL-DRIDEV)
      DBCK(15)=COS(DEL+DRIDEV)
      DBCK(16)=SIN(DEL)
      DBCK(17)=-DBCK(16)
      DEL=DEL+3.141593/48.
      DBCK(18)=COS(DEL-DRIDEV)
      DBCK(19)=COS(DEL+DRIDEV)
      DBCK(20)=SIN(DEL)
      DBCK(21)=-DBCK(20)
      DBCK(22)=TAN(3.141593/12.+3.141593/48.)
N     INITIALIZE DHALF AND HMCH ARRAYS
      FOR KRING=1,3
      DEL=3.141593/NCELL(KRING)
      TANDEL(KRING)=TAN(DEL*2.)
      FOR IW=1,16
      DSMX=DSMAX(IW,KRING,1)
      IF(KRING.EQ.3) DSMSP=DSMAX(IW,2,1)
      ALSIN=-DRISIN
      AL=-DRIDEV
      PERFORM INIT
      HMCH(IW,KRING,1)=IK
      DHALF(IW,KRING,1)=DT
      DTWICE(IW,KRING,1)=DTW
      DSMX=DSMAX(IW,KRING,2)
      IF(KRING.EQ.3) DSMSP=DSMAX(IW,2,2)
      ALSIN=DRISIN
      AL=DRIDEV
      PERFORM INIT
      HMCH(IW,KRING,2)=IK
      DHALF(IW,KRING,2)=DT
      DTWICE(IW,KRING,2)=DTW
      CFOR
      CFOR
      RETURN
C
C *********************
C
      PROC INIT
C
C     THIS PROC CALCULATES QUANTITIES FOR HMCH AND DHALF ARRAYS
C     DHALF ARRAY CONTAINS 'HALF' THE MAX DRIFT DISTANCE FOR EACH WIRE
C     AND IS USED IN MATCHING TRACKS FROM RING 3 TO RING 2.
C     HMCH ARRAY CONTAINS THE WIRE NO. WHICH WILL FIRE IN THE
C     NEIGHBOURING CELL IF THE TRACK GOES THROUGH THE CELL
C     SIDEWALL.
C     THE CONVENTION IS THAT 1 IS LEFT AND 2 IS RIGHT.
C
      W=FSENSW(KRING)+FLOAT(IW-1)*RINCR(KRING)
      X=SQRT(W**2+DSMX**2-2.*W*DSMX*ALSIN)
      DTW=1.-TAN(DEL)*TAN(DEL-AL)
      DTW=2.*DSMX/DTW
      IF KRING.EQ.2
      THEN
      DTW=1.-TAN(DEL*.5)*TAN(DEL-AL)
      DTW=DSMX*(1.+TAN(DEL*.5)/TAN(DEL))/DTW
      CIF
      IF KRING.EQ.3
      THEN
      DTW=1.-TAN(DEL*1.5)*TAN(DEL-AL)
      DTW=DSMSP*(1.+TAN(DEL*1.5)/TAN(DEL))/DTW
      CIF
      DT=TAN(DEL*0.5)*TAN(DEL*0.5-AL)
N     DT IS DHALF
      DT=DSMX*0.5*(1.-DT)
N     NOW CALCULATE MCH ARRAY
      IF X.LT.GB(KRING)
      THEN
      IK=-5
      E=X*COS(AL+DEL)/DRICOS
      E=E-FSENSW(KRING)
      IF(E.GE.-5.) IK=(E+5.)/RINCR(KRING)
      IF(IK.GT.15) IK=20
      ELSE
      IK=20
      CIF
      CPROC
      END
C   06/02/81 308301443  MEMBER NAME  KNTREL   (PATRECSR)    SHELTRAN
      SUBROUTINE KNTREL(HEARR,NUMTRK)
C
C     CALLS FITTING ROUTINES AND PATROL AND FILLS PATR AND JHTL BANKS
C     RESULTS OF XYFIT AND PATROL ARE USED TO CORRECT BACKTRACE ARRAYS
C
C     IMCERT=1  MEANS BACKTR ARRAYS ARE NOT CORRECTED BY THE RESULTS
C               OF XYFIT AND PATROL
C
C     IMCERT=0   MEANS 'FULL' EDITING WITH TRACK ELS ALSO
C                BEING DELETED
      IMPLICIT INTEGER*2 (H)
      COMMON/CHEADR/HEAD(17),HRUN,HEV
      COMMON/CADMIN/IEVTP,NREC,NRWRIT,NRERR
      COMMON/CBKPAT/HTRK(100)
#include "cdata.for"
#include "ccycp.for"
#include "cworkpr.for"
#include "cworkeq.for"
      EQUIVALENCE (ICELL ,IDWRK(1)),(NHIT  ,IDWRK(2))
      DIMENSION HEARR(1)
#include "cpatlm.for"
      EQUIVALENCE (IXBKK(40),IXITER),(IXBKK(39),MAXITR),(JJPR,IXBKK(38))
      EQUIVALENCE (IXBKK(37),MINHIT),(IXBKK(36),ICUT)
C
      INTEGER DATE(5), IDAY /0/
C
      DIMENSION NCNT1(127),NCNT2(127),IXREF0(127)
      DIMENSION JCLLA(20),NCLLA(20)
C
C2001 FORMAT(1H0,2I3,I8,2(I4,3F6.1,3F6.3),
C    ,     /,14X,I3,4E13.5,F6.2,I3,4E13.5,
C    ,     /,14X,I3,2F8.3,F6.1,I3,10X,6I3,8I6,2X,Z4)
C2002 FORMAT(1H0,40I3,/,1X,40I3,/,1X,40I3,/,1X,7I3)
C2003 FORMAT(1H0,A4,3I6,2(/,1X,24I4),/,1X,50I2,
C    ,       90(/,1X,2I6,I3,2F10.3,I3,2F10.3,1X,Z4,2I3))
C2004 FORMAT(1H0,'BACKTR:',5X,20I6)
C2005 FORMAT(1H ,12X,20I6)
C2008 FORMAT(' JHTL-BANK:',2I6,/,(12X,20(2X,Z4)))
C
C
C
C        MINHIT IS THE MINIMUM NO OF UNUSED HITS
C        LEFT ON A TRACKEL FOR IT TO BE BROUGHT
C        BACK AT THE END AS AS A SEPARATE TRACK
C
C     ICUT IS THE MAX NO OF HITS LEFT UNCORRELATED
C     BY PATROL BEFORE THE TRACKEL IS ASSIGNED TO THE TRACK
C
      DATA MSKTR1/Z7F/
      DATA MSKDSP/Z2000/
      DATA MAXTRK/100/
      DATA MKBDHT /Z600/
C
 458  FORMAT(' ',20(X,Z4))
 675  FORMAT('  ***** HIT LABEL MAY BE ZEROED **********')
 754            FORMAT('  HPFREE , HPLAST ',2I10)
 97           FORMAT(1X,30('+'),' KNTREL ERROR',I2,4I7)
 674  FORMAT('  **** NOT ENOUGH SPACE IN CWORK TO MOVE HIT LABEL *******
     $ , HPFREE, HPLAST , NO OF WORDS ',3I7)
C
N     INITIALISE DATE + POINTER
      IF IDAY.EQ.0
      THEN
        CALL DAY2(DATE)
        IDAY = DATE(1)*1000 + DATE(2)
        IQJHTL = IBLN('JHTL')
        IQPATR = IBLN('PATR')
      CIF
C
C     CALL PRPATR
N     POINTER TO 'JHTL'-BANK
      IPJHTL = IDATA(IQJHTL)
N     NUMBER OF HITS
      NHITT = (HPTSEC(97) - HPTSEC(1)) / 4
N     POINTER TO 'PATR'-BANK
      IPPATR = IDATA(IQPATR)
N     CURRENT NUMBER OF TRACKS
      NTR0  = IDATA(IPPATR+2)
      ITRBK = NTR0
N     LENGTH OF TRACK BANK
      LTRBK = IDATA(IPPATR+3)
N     POINTER TO NEXT TRACK BANK - 1
      IPTRBK = IPPATR + IDATA(IPPATR+1) + ITRBK*LTRBK
N     MEMORIZE 1. FREE LOC. IN CWORK
      HPFRE0 = HPFREE
C
N     ZERO XREF: TRACK#(PATR) - TRACK#(BACKTR)
      CALL SETSL(IXREF0(1),0,508,0)
C
      IF NTR.GT.0 .AND. NUMTRK.GT.0
      THEN
C
N     PRINTOUT
C       I9 = HNTR
C       PRINT 2003, HPRO,HNTR,NTR,NUMTRK,
C    ,              HNTCEL, ((TRKAR(I1,I2),I2=1,11),I1=1,I9)
C
C       I0 = HPHL0
C       I9 = HPHL9
C       PRINT 2008, I0,I9,(HWRK(I1),I1=I0,I9)
C
C         PRINT 2004,NTR, (HNREL(I1),I1=1,NTR)
C         FOR ITR=1,NTR
C           NELM = HNREL(ITR)
C           PRINT 2005, (HISTR(I1,ITR),I1=1,NELM)
C         CFOR
C
N       LOOP OVER ALL TRACKS AND FIT
        LBEVTR = 0
        IEDTK  = 0
        ITR    = 0
        MAXTR0 = MIN0(MAXTRK,NUMTRK)
        WHILE IEDTK.LT.MAXTR0
N       COUNTER FOR HEARR
        IEDTK=IEDTK+1
C
N         EXTRACT TRACK NO
          ITR=HEARR(IEDTK)
C
N         TRACK ARRAY SATURATED ?
          IF(ITRBK.GT.MAXTRK .OR. ITR.GT.MAXTRK) XWHILE
C
          IF HNREL(ITR).GT.0
          THEN
            HPFREE = HPFRE0
            CALL FXYZ(ITR)
            NHIT = (HPHT9-HPHT0+1) / HLDHT
N           MORE THAN THREE HITS
            IF NHIT.GT.3
            THEN
N             POINTER TO RESULTS OF TRACK FITS
              HPTR0 = HPFREE
              HPTR9 = HPTR0 + 49
              HLDTR = 50
              HPFREE= HPTR9 + 1
              IF HPFREE.LE.HPLAST
              THEN
                IWRK(HPTR0+47)=0
                CALL XYFIT
                IF WRK(HPTR0+22).LT.GFP(2)
                THEN
C
N                 SET RADIUS LIMITS FOR PATROL
                  RMIN = 150.
                  RMAX = 850.
                  IF NTRLM.GT.0
                  THEN
                    FOR I=1,NTRLM
                      IF LMRTR(1,I).EQ.ITR
                      THEN
                        RMIN = RLMTR(2,I)
                        RMAX = RLMTR(3,I)
                        XFOR
                      CIF
                    CFOR
                  CIF
                  CALL PATROL(RMIN,RMAX)
                CIF
C
                RMSFIT = WRK(HPTR0+22)
                IF RMSFIT.GE.1000. .OR.
     ?             IWRK(HPTR0+23).LT.5 .AND. IMCERT.EQ.0
                THEN
                  HNREL(ITR) = 0
                ELSE
                  NHGDZ = 0
                  IDHTLB=IPJHTL*2-HPHL0+3
                  FOR IIP=HPHT0,HPHT9,HLDHT
                    IPHTLB=IWRK(IIP+2)
                    IPHTL=HDATA(IPHTLB+IDHTLB)
                IF(LAND(IPHTL,MKBDHT).EQ.0.AND.IPHTL.NE.0) IWRK(IIP+7)=8
                    IF(IWRK(IIP+7).LT.8) NHGDZ = NHGDZ + 1
                  CFOR
C
N                 CHECK IF <3 GOOD Z-HITS
                  IF NHGDZ.LT.3
                  THEN
                    HNREL(ITR) = 0
                  ELSE
N                   >2 GOOD Z-HITS
                    CALL ZRFIT
C
N                   DELETE BACKGROUND TRACK
                    CRV  = ABS(WRK(HPTR0+24))
                    ZINT = ABS(WRK(HPTR0+30))
                    IF IYBKK(14).NE.0 .AND. CRV.GT.YBKK(12) .AND.
     ?                 ZINT.GT.YBKK(15)
                    THEN
                      KP=HPTR0
                      CSTH=WRK(KP+4)*WRK(KP+7)+WRK(KP+5)*WRK(KP+8)

                      CSTH=CSTH/SQRT((WRK(KP+4)**2+WRK(KP+5)**2)*
     *                          (WRK(KP+7)**2+WRK(KP+8)**2))
                      IF(CSTH.LT.YBKK(13)) HNREL(ITR) = 0
                    CIF
C
                    IF HNREL(ITR).GT.0
                    THEN
C
N                     INCREASE TRACK BANK # + ANALYSE TRACK
                      ITRBK = ITRBK + 1
                      IXREF0(ITRBK) = ITR
                      PERFORM TRKBNK
C
N                     DELETE TRACK IF <5 HITS REGISTERED
                      IF NHTREG.LT.5
                      THEN
                        ITRBK  = ITRBK  - 1
                        IPTRBK = IPTRBK - LTRBK
                      CIF
                    CIF
C
                  CIF
                CIF
              ELSE
C               KERROR 2 .. NOT ENOUGH SPACE IN CWORK
                KERROR = 2
                PRINT97,KERROR,NREC,HRUN,HEV,ITR
                PRINT 754,HPFREE,HPLAST
                XWHILE
              CIF
            ELSE
C             KERROR 1 .. NOT ENOUGH HITS ON TRACK
              KERROR = 1
              PRINT97,KERROR,NREC,HRUN,HEV,ITR
              HNREL(ITR)=0
            CIF
          CIF
        CWHILE
C
      HPFREE=HPFRE0
      CIF
C
N     READJUST RECORD LENGTH + # OF TRACKS
      NDIFF = IPTRBK - IPPATR - IDATA(IPPATR)
      CALL BCHM(IPPATR,NDIFF,IRET)
      IDATA(IPPATR+2) = ITRBK
C
N     ELIMINATE BAD + COVERED TRACKS IF IMCERT = 0
      IF IMCERT.EQ.0 .AND. ITRBK.GT.0
      THEN
C
N       COUNT CORRELATED + UNCORRELATED HITS
C       I0 = IPJHTL*2 + 1
C       I9 = (IDATA(IPJHTL)+IPJHTL)*2
C       PRINT 2008, I0,I9,(HDATA(I1),I1=I0,I9)
        PERFORM CNTHIT
C       PRINT 2008, I0,I9,(HDATA(I1),I1=I0,I9)
C
        IDATA(IPPATR+4)=LBEVTR
        IDATA(IPPATR+ 6) = NHITUC
      CIF
C
N     ELIMINATE TRACKS WITH 0 TRELS
      ITR = 0
      WHILE ITR.LT.NTR
      ITR = ITR + 1
        NELM = HNREL(ITR)
        IF NELM.LE.0
        THEN
          NBYTE = (NTR-ITR)*2
          NTR = NTR - 1
          IF NBYTE.GT.0
          THEN
            CALL MVCL(HNREL(ITR),0,HNREL(ITR+1),0,NBYTE)
            NBYTE = NBYTE * 9
            CALL MVCL(HISTR(1,ITR),0,HISTR(1,ITR+1),0,NBYTE)
          CIF
          ITR = ITR - 1
        CIF
      CWHILE
C
C
      RETURN
C
C
N     ***************************
N     *      T R K B N K        *
N     ***************************
C
N     SET TRACK BANK IN /CDATA/
      PROC TRKBNK
C
      JP     = HPTR0
      LBTRCK = 0
C
      IR1=0
      IR2=0
      IR3=0
      NTRKEL=HNREL(ITR)
      FOR ITN=1,NTRKEL
        ITH=HISTR(ITN,ITR)
        ITH=IABS(ITH)
        IF(LAND(LBL(ITH),MSKDSP).NE.0)LBTRCK=LOR(LBTRCK,2048)
        ITH=IPCL(ITH)
        IF ITH.LE.24
        THEN
          IR1=1
        ELSE
          IF ITH.GT.48
          THEN
            IR3=1
          ELSE
            IR2=1
          CIF
        CIF
      CFOR
      IF(IR1.EQ.0)LBTRCK=LOR(LBTRCK,512)
      IF(IR1.NE.0.AND.IR3.NE.0.AND.IR2.EQ.0) LBTRCK=LOR(LBTRCK,1024)
      IF(CRV.GT..002) LBTRCK=LOR(LBTRCK,64)
C
C     I0 = JP
C     I9 = JP+47
C     PRINT 2001,(WRK(I1),I1=I0,I9)
      TGTH       = WRK(JP+29)
      Z0         = WRK(JP+30)
      CSTH       = 1. / SQRT(TGTH**2+1.)
      SNTH       = CSTH * TGTH
      WRK(JP+ 6) = WRK(JP+ 6)*TGTH + Z0
      WRK(JP+13) = WRK(JP+13)*TGTH + Z0
      WRK(JP+ 7) = WRK(JP+ 7) * CSTH
      WRK(JP+ 8) = WRK(JP+ 8) * CSTH
      WRK(JP+ 9) = SNTH
      WRK(JP+14) = WRK(JP+14) * CSTH
      WRK(JP+15) = WRK(JP+15) * CSTH
      WRK(JP+16) = SNTH
      LBEVTR=LOR(LBEVTR,LBTRCK)
C     PRINT 2001,(WRK(I1),I1=I0,I9)
C
N     INCREASE TRACK BANK COUNTER
      HTRK(ITR)=ITRBK
      IP0 = IPTRBK + 1
      IP9 = IPTRBK + LTRBK
      FOR IP = IP0,IP9
        IDATA(IP) = 0
      CFOR
      IDATA(IPTRBK+ 1) = ITRBK
      IDATA(IPTRBK+ 2) = IPFAST+1
      IDATA(IPTRBK+ 3) = IDAY
C
N     RESULTS FROM X-Y-FIT + ZRFIT
      IP1 = HPTR0+3
      IP9 = IP1+29
      JP  = IPTRBK + 3
      FOR IP=IP1,IP9
        JP = JP + 1
        IDATA(JP) = IWRK(IP)
      CFOR
      IDATA(IPTRBK+47)=IWRK(HPTR0+46)
      IDATA(IPTRBK+48)=LBTRCK
C
N     POINTER TO FIRST CELL -1
      NPCLL  = 0
N     INITIALIZE CELL #
      ICELL0 = -1
N     COUNTER OF REGISTERED HITS
      NHTREG = 0
C
N     SET HIT LABELS
N     LOOP OVER ALL HITS
      IDHTLB = IPJHTL*2-HPHL0+3
      IP     = HPHT0
      REPEAT
N       SELECT ONLY ACCEPTED HITS
        IF IWRK(IP+10).GE.0 .AND. IWRK(IP+10).LE.2
        THEN
N         UPPER BITS
          LBBDHT = IWRK(IP+10)
          LBBDHT=LAND(LBBDHT,3)
          LBBDHT = SHFTL(LBBDHT,9)
N         POINTER TO HIT LABEL IN CWORK
          IPHTLB = IWRK(IP+ 2)
N         ORIGINAL HIT LABEL
          LBHIT0 = HWRK(IPHTLB)
          LBHIT1 = HWRK(IPHTLB+1)
N         TKEL NO
          ITREL = IABS(IWRK(IP+ 8))
N         TKEL NO WITHIN RING
          JTREL = NTREL(ITREL)*2
N         TRACK NO
N         SET TRACK #
          LBHIT = ITRBK*2
N         SET L/R BIT
          IF(IWRK(IP+8).GT.0) LBHIT = LOR(LBHIT,256)
N         FETCH HIT LABEL OF TRACK
          IPHTL1 = IPHTLB + IDHTLB
          IPHTL2 = IPHTLB + IDHTLB +1
N         HIT LABEL IN CDATA
          LBHIT1 = HDATA(IPHTL1)
          LBHIT2 = HDATA(IPHTL1+1)
          RES=WRK(IP+13)
          RES=ABS(RES)/.2
          IRES=IFIX(RES)
          IF(IRES.GT.31) IRES=31
          IRES=SHFTL(IRES,11)
          LBHIT=LBHIT+IRES
N         LABEL FOR REGISTERED HIT
          LBREG = 0
C
          IF LAND(MSKTR1,SHFTR(LBHIT1,1)).NE.ITRBK
           .OR.LAND(LBHIT1,MKBDHT).NE.0
          THEN
          IF LAND(LBHIT1,MKBDHT).NE.0
          THEN
N           PRIOR HIT IS BAD(XYFIT)
            IF LBBDHT.EQ.0
             THEN
N             THIS HIT IS GOOD
              LBREG = 1
              LBHIT1 = LBHIT
N             SET BIT FOR GOOD  Z-COORDINATE
              IF(IWRK(IP+7).EQ.0) LBHIT1 = LOR(LBHIT1,1)
            ELSE
N             NEW HIT IS ALSO BAD
              ITLND=LAND(LBHIT1,MKBDHT)
              IF LBBDHT.LT.ITLND
              THEN
                LBHIT1 = LOR(LBHIT,LBBDHT)
                LBREG = 1
N               SET BIT FOR GOOD  Z-COORDINATE
                IF(IWRK(IP+7).EQ.0) LBHIT1 = LOR(LBHIT1,1)
              CIF
            CIF
          ELSE
N           NO BAD PRIOR HIT
            IF LBHIT1.EQ.0
N           FIRST TRACK FOR THIS HIT NOW
            THEN
              LBHIT1 = LOR(LBHIT,LBBDHT)
              LBREG = 1
N             SET BIT FOR GOOD  Z-COORDINATE
              IF(IWRK(IP+7).EQ.0) LBHIT1 = LOR(LBHIT1,1)
N             SECOND TRACK FOR THIS HIT NOW
            ELSE
              IF LBBDHT.EQ.0 .AND. LBHIT2.EQ.0
              THEN
                LBHIT2 = LOR(LBHIT,LBBDHT)
                LBREG = 1
N               SET BIT FOR GOOD  Z-COORDINATE
                IF(IWRK(IP+7).EQ.0) LBHIT2 = LOR(LBHIT2,1)
              CIF
            CIF
          CIF
          HDATA(IPHTL1) = LBHIT1
          HDATA(IPHTL2) = LBHIT2
N         COUNT REGISTERED HIT
          NHTREG = NHTREG + 1
N         CHECK IF NEW CELL
          ICELL = IWRK(IP+9)
          IF LBREG.NE.0
          THEN
            IF ICELL.EQ.ICELL0
            THEN
              NCLLA(JPCLL) = NCLLA(JPCLL) + 1
            ELSE
              ICELL0 = ICELL
              JPCLL = 0
              IF NPCLL.GT.1
              THEN
                FOR I1=1,NPCLL
                  IF(ICELL.EQ.JCLLA(I1)) JPCLL = I1
                CFOR
              CIF
              IF JPCLL.EQ.0
              THEN
                NPCLL        = NPCLL + 1
                JPCLL        = NPCLL
                JCLLA(JPCLL) = ICELL
                NCLLA(JPCLL) = 1
              ELSE
                NCLLA(JPCLL) = NCLLA(JPCLL) + 1
              CIF
            CIF
          CIF
        CIF
        CIF
      IP = IP + HLDHT
      UNTIL IP.GT.HPHT9
C
N     REDUCE # OF CELLS TO 6
      WHILE NPCLL.GT.6
        NHTMIN = 99999
        FOR I1=1,NPCLL
          IF NCLLA(I1).LT.NHTMIN
          THEN
            NHTMIN = NCLLA(I1)
            JPCLL = I1
          CIF
        CFOR
        JCLLA(JPCLL) = JCLLA(NPCLL)
        NCLLA(JPCLL) = NCLLA(NPCLL)
        NPCLL = NPCLL - 1
      CWHILE
C
N     STORE CELLS IN TRACK BANK
      IPCLL  = IPTRBK + 33
      FOR I1 = 1,NPCLL
        IPCLL  = IPCLL + 1
        IDATA(IPCLL) = JCLLA(I1)
      CFOR
C
N     INCREASE POINTER TO TRACK BANK
      IPTRBK = IPTRBK + LTRBK
C
      CPROC
C
C
N     ***************************
N     *      C N T H I T        *
N     ***************************
C
N     COUNT CORRELATED + UNCORRELATED HITS
      PROC CNTHIT
C
C
N     NO CHECK IF NO TRACKS
      NTR1  = ITRBK
      LPATR = IDATA(IPPATR)
C
      IPHL0 = IPJHTL*2 + 3
      ILDHL = IDATA(IPJHTL)*2 - 2
      IPHL9 = ILDHL + IPHL0 - 1
C
N     COUNT HITS OF TRACK
      CALL SETSL(NCNT1(1),0,1016,0)
      NHITUC = 0
      FOR I=IPHL0,IPHL9,2
        IZW1  = HDATA(I  )
        ITRK1 = LAND(SHFTR(IZW1,1),127)
        IF ITRK1.GT.0
        THEN
          IZW2  = HDATA(I+1)
          ITRK2 = LAND(SHFTR(IZW2,1),127)
          IF ITRK2.LE.0
          THEN
            NCNT1(ITRK1) = NCNT1(ITRK1) + 1
          ELSE
            NCNT2(ITRK1) = NCNT2(ITRK1) + 1
            NCNT2(ITRK2) = NCNT2(ITRK2) + 1
          CIF
        ELSE
          NHITUC = NHITUC + 1
        CIF
      CFOR
C
N     ELIMINATE COVERED OR TOO SHORT TRACKS
C     PRINT 2002, NCNT1,NCNT2,IXREF0
C     CALL PRPATR
      MTR = 0
      LTRBK = IDATA(IPPATR+3)
      IPTR0 = IPPATR + IDATA(IPPATR+1)
      IPTR9 = (NTR1-1)*LTRBK + IPTR0
      FOR ITR=1,NTR1
        IF NCNT1(ITR).GE.5 .AND. NCNT1(ITR)+NCNT2(ITR).LT.LMPATR(1)
        THEN
N         CHECK IF TRACKS LEAVES IN Z DIRECT.
          IPTR1 = 0
          JTR = MTR + 1
          FOR IP=IPTR0,IPTR9,LTRBK
            IF IDATA(IP+1).EQ.JTR
            THEN
              IPTR1 = IP
              XFOR
            CIF
          CFOR
          IF(IPTR1.NE.0 .AND.ABS(ADATA(IPTR1+14)).LT.1000.)NCNT1(ITR)=1
        CIF
        IF NCNT1(ITR).LT.5
        THEN
          PERFORM ELIMTR
          NCNT1(ITR) =-NCNT1(ITR)
          JTR = IXREF0(ITR)
          HNREL(JTR) = 0
C     PRINT 2002, NCNT1,NCNT2
        ELSE
N         COUNT REMAINING TRACKS
          MTR = MTR + 1
        CIF
      CFOR
C
C
      IDATA(IPPATR+2) = MTR
C     PRINT 2002, NCNT1,NCNT2,MTR
C
N     READJUST RECORD LENGTH + # OF TRACKS
      LENG  = IDATA(IPPATR+2)*IDATA(IPPATR+3) + IDATA(IPPATR+1)
      NDIFF = LENG - IDATA(IPPATR)
      IF(NDIFF.NE.0) CALL BCHM(IPPATR,NDIFF,IRET)
C
      CPROC
C
C
N     ***************************
N     *      E L I M T R        *
N     ***************************
C
N     ELIMINATE TRACK ITR
      PROC ELIMTR
C
N       LOOP OVER HIT LABEL ARRAY
        JTR = MTR + 1
        ITRDIF = ITR - JTR
        FOR I=IPHL0,IPHL9,2
          IZW1  = HDATA(I  )
          ITRK1 = LAND(SHFTR(IZW1,1),127)
          IZW2  = HDATA(I+1)
          ITRK2 = LAND(SHFTR(IZW2,1),127)
          IF ITRK2.EQ.JTR
          THEN
            HDATA(I+1) = 0
            ITRK2 = 0
            IND1  = ITRK1 + ITRDIF
            NCNT1(IND1) = NCNT1(IND1) + 1
            NCNT2(IND1) = NCNT2(IND1) - 1
C     DATA NPREL /0/
C     NPREL = NPREL + 1
          CIF
          IF ITRK1.EQ.JTR
          THEN
            HDATA(I ) = HDATA(I+1)
            HDATA(I+1) = 0
            ITRK1 = ITRK2
            ITRK2 = 0
            IF ITRK1.GT.0
            THEN
              IND1  = ITRK1 + ITRDIF
              NCNT1(IND1) = NCNT1(IND1) + 1
              NCNT2(IND1) = NCNT2(IND1) - 1
            CIF
          CIF
C         DECREASE TRACK # FOR HIGHER TRACK #'S
          IF(ITRK1.GT.JTR) HDATA(I  ) = HDATA(I  )-2
          IF(ITRK2.GT.JTR) HDATA(I+1) = HDATA(I+1)-2
        CFOR
C     PRINT 2002, NCNT1,NCNT2
C
N       ELIMINATE TRACK IN PATR-BANK
        FOR IP=IPTR0,IPTR9,LTRBK
          IF IDATA(IP+1).EQ.JTR
          THEN
            IPTR1 = IP
            XFOR
          CIF
        CFOR
C
        IF IPTR1.GT.0
        THEN
          IPTR2 = IPTR1 + LTRBK
          NBYTE = (IPTR9 -IPTR2 + LTRBK) * 4
          IPTR9 = IPTR9 - LTRBK
          IF NBYTE.GT.0
          THEN
            CALL MVCL(IDATA(IPTR1+1),0,IDATA(IPTR2+1),0,NBYTE)
            FOR IP=IPTR1,IPTR9,LTRBK
              IDATA(IP+1) = IDATA(IP+1) - 1
            CFOR
          CIF
        CIF
C
      CPROC
C
      END
C   16/01/80 102191159  MEMBER NAME  KOMPAT   (PATRECSR)    SHELTRAN
      SUBROUTINE KOMPAT
C
      IMPLICIT INTEGER*2 (H)
C
C
C     KOMPAT COMPARES TWO PATR BANKS
C
C     MONTE CARLO TRACKS ARE MATCHED ONE BY ONE TO
C     TRACKS IN THE MOST RECENT PATR BANK
C
C     EACH MONTE CARLO TRACK IS EXTRAPOLATED TO THE POINT OF
C     CLOSEST APPROACH TO THE 'REAL' TRACKS. AT THIS POINT
C     X,Y COORDINATES , DIRECTION COSINES (IN THE X,Y PLANE),
C     RAD OF CURVATURE , AND NUMBER OF HITS  ARE COMPARED.
C
C     THE NUMBER OF UNMATCHED MC TRACKS IS STORED IN IMCNMX
C      AND THE NUMBER OF UNMATCHED 'REAL' TRACKS IN IRLNMX.
C
C
C
      COMMON /CWORK/ HMC(100),HRL(100)
#include "cdata.for"
      COMMON /COMPAT/ RADLI1,RADLI2,NHTLI1,DHTLI2,DXLIM1,DYLIM1,
     & DXLIM2,DYLIM2,DIRXL1,DIRYL1,DIRXL2,DIRYL2,IPRINT,CRVLOW,
     & IMCNMX,IRLNMX
      CALL SETSL(HMC(1),0,400,0)
      IREAL=IBLN('PATR')
      IREAL=IDATA(IREAL)
      IF(IREAL.LE.0) WRITE(6,468)
 468  FORMAT('  **** NO PATR BANK FROM PATTERN RECOGNITION')
      IF(IREAL.LE.0) RETURN
      CALL CLOC(IMC,'PATR',12)
      IF(IMC.LE.0) WRITE(6,469)
 469  FORMAT('  **** NO MONTE CARLO PATR BANK ')
      IF(IMC.LE.0) RETURN
      NUMMC=IDATA(IMC+2)
      NUMRL=IDATA(IREAL+2)
      LNGRL=IDATA(IREAL+3)
      IPTRL=IDATA(IREAL+1)+IREAL+1
      LNGMC=IDATA(IMC+3)
      IPTMC=IDATA(IMC+1)+IMC+1
N     LOOP OVER MC TRACKS
      FOR JMC=1,NUMMC
      IF HMC(JMC).GE.0
      THEN
      IF(IPRINT.GT.1) WRITE(6,382) JMC
  382   FORMAT('0 MC TRACK NO',I5)
      RAD=1./ADATA(IPTMC+18)
N     RMC IS DISTANCE TO CENTER OF CURV
      RMC=ADATA(IPTMC+19)+ABS(RAD)
      NHITMC=IDATA(IPTMC+23)
      CRVMC=ADATA(IPTMC+26)
      THETA=ADATA(IPTMC+20)
      XMCB=ADATA(IPTMC+4)
      YMCB=ADATA(IPTMC+5)
      ZMCP1=ADATA(IPTMC+29)
      ZMCP2=ADATA(IPTMC+30)
N     X,Y COORDINATES OF CENTER OF CURV
      XRMC=RMC*COS(THETA)
      YRMC=RMC*SIN(THETA)
      IF(IPRINT.GT.2) WRITE(6,298) RAD,RMC,XRMC,YRMC
298   FORMAT('  RAD,RMC,XRMC,YRMC',4F10.3)
      IPTRL=IDATA(IREAL+1)+IREAL+1
      CHIOLD=9999.
N     LOOP OVER PATREC TRACKS
      FOR IRL=1,NUMRL
      IF HRL(IRL).GE.0
      THEN
      IF(IPRINT.GT.2) WRITE(6,383) IRL
 383   FORMAT('0 RL TRACK NO',I5)
      XRLB=ADATA(IPTRL+4)
      YRLB=ADATA(IPTRL+5)
      ZRLB=ADATA(IPTRL+6)
      NHITRL=IDATA(IPTRL+23)
      NHTDIF=IABS(NHITRL-NHITMC)
      NLIM1=NHTLI1
      NLIM2=IFIX(DHTLI2*NHITMC)
N     REQUIREMENT ON MATCHING NUMBER OF HITS WILL
      IF ABS(CRVMC).GT..0015.AND.NHITMC.GT.30
N     BE RELEASED FOR A LONG LOW MOM MC TRACK
      THEN
      IF(IPRINT.GT.2)  WRITE(6,303) IRL
303   FORMAT('   HIT RESTRICTION RELEASED,TRACK ',I10)
      NHTDIF=0
      CIF
N     HIT DIFFERENCE SMALL ENOUGH ?
      IF NHTDIF.LT.NLIM1.OR.NHTDIF.LT.NLIM2
      THEN
N     VECTOR FROM CENTER OF CURV TO BEGINING OF REAL TRACK
      XD=XRLB-XRMC
      YD=YRLB-YRMC
      DI=SQRT(YD**2+XD**2)
N     XEXP,YEXP ARE COORDINATES OF THE POINT ON THE
      XEXP=XRMC+XD*ABS(RAD)/DI
N     EXTRAPOLATED MC TRACK CLOSEST TO THE BEGINNING OF THE
      YEXP=YRMC+YD*ABS(RAD)/DI
N     REAL TRACK
      REXP=SQRT(XEXP**2+YEXP**2)
      ZEXP=ZMCP1+REXP*ZMCP2
      IF(IPRINT.GT.2) WRITE(6,195) XEXP,YEXP,ZEXP,XRLB,YRLB,ZRLB
 195  FORMAT(' XEXP,YEXP,ZEXP',6F10.3)
      DIFX=ABS(XEXP-XRLB)
      DIFY=ABS(YEXP-YRLB)
N     ANEXP IS UNORMALIZED ANGLE THROUGH WHICH EXTRAPOLATION
      ANEXP=XMCB*XEXP+YMCB*YEXP
N     IS MADE
      IF ANEXP.LT.0.
      THEN
      DIFX=999.
      DIFY=999.
      IF(IPRINT.GT.2) WRITE(6,775) IRL
  775 FORMAT('  EXTRAPOLATION TOO FAR , TRACK ',I5)
      CIF
N     LIMITS FOR MATCHING START POINT OF TRACKS
      DXLIM=DXLIM1+ADATA(IPTMC+18)*1000.*DXLIM2
      DYLIM=DYLIM1+ADATA(IPTMC+18)*1000.*DYLIM2
      IF DIFX.LT.DXLIM.AND.DIFY.LT.DYLIM
      THEN
      IF(IPRNT.GT.1) WRITE(6,196) DIFX,DIFY,DXLIM,DYLIM
 196  FORMAT('  DIFX,DIFY,DXLIM,DYLIM',4F10.5)
      IF(IPRNT.GT.1) WRITE(6,212) IRL
 212  FORMAT('   SUCCESSFUL MATCH FOUND TO STARTING POIINT FOR TRACK',I5
     & )
N     NORMALIZE THE VECTOR
      XD=XD/DI
      YD=YD/DI
N     DIR COSINES AT EXTRAPOLATED PT OF MC TRACK
      DXNEW=YD
N     ARE PERP TO (XD,YD) VECTOR
      DYNEW=-XD
N     MAKE SURE THEY ALWAYS POINT TO ORIGIN
      CS=DXNEW*XEXP+DYNEW*YEXP
      IF CS.LT.0.
      THEN
      IF(IPRINT.GT.2) WRITE(6,386)
 386  FORMAT('  DIRECTION COSINES REVERSED')
      DXNEW=-DXNEW
      DYNEW=-DYNEW
      CIF
N     DIR COSINES
      DXRL=ADATA(IPTRL+7)
      DYRL=ADATA(IPTRL+8)
      DXY=SQRT(DXRL**2+DYRL**2)
N     NORMALIZE TO X,Y PLANE
      DXRL=DXRL/DXY
      DYRL=DYRL/DXY
      IF(IPRINT.GT.2) WRITE(6,295) DXNEW,DYNEW,DXRL,DYRL
 295  FORMAT(' DXNEW,DYNEW,DXRL,DYRL',4F10.7)
      DIFDX=ABS(DXNEW-DXRL)
      DIFDY=ABS(DYNEW-DYRL)
N     LIMITS FOR DIR COSINES
      DIRXL=DIRXL1+DIRXL2*1000.*ADATA(IPTMC+18)
      DIRYL=DIRYL1+DIRYL2*1000.*ADATA(IPTMC+18)
      IF DIFDX.LT.DIRXL.AND.DIFDY.LT.DIRYL
      THEN
      IF(IPRINT.GT.1) WRITE(6,838) DIFDX,DIFDY,DIRXL,DIRYL
 838  FORMAT(' SUCCESSFUL MATCH TO DIRECTION COSINES,DIFX,Y',4F10.7)
      CRVRL=ADATA(IPTRL+26)
      RADRL=1./ADATA(IPTRL+26)
      CRVMC=ADATA(IPTMC+26)
      RADMC=1./ADATA(IPTMC+26)
C     DIFCRV=ABS(CRVRL-CRVMC)
      DIFRAD=ABS(RADRL-RADMC)
N     ARE CHARGES SAME ?
      IF(CRVRL*CRVMC.LT.0.) DIFCRV=9999.
N     LIMITS ON RADIUS
      DRADL=RADLI1+RADLI2*ABS(RADMC)
      IF DIFRAD.LT.DRADL
      THEN
      IF(IPRINT.GT.1) WRITE(6,393) DIFRAD,DRADL
 393  FORMAT('  SUCCESSFUL RAD MATCH ,DIFRAD ,LIMIT ',2F10.2)
      CHI=DIFDX/DIRXL+DIFDY/DIRYL+DIFX/DXLIM+DIFY/DYLIM+DIFRAD/DRADL
      + FLOAT(NHTDIF/(NHTLI1+NHTLI2)/2)
      IF(IPRINT.GT.1.AND.CHIOLD.NE.9999.) WRITE(6,777) CHI,CHIOLD
 777  FORMAT('  TWO MATCHES FOUND NEW,OLD',2F10.5)
      IF CHI.LT.CHIOLD.AND.CHI.LT.4.
      THEN
      CHIOLD=CHI
      HMC(JMC)=IRL
      IF(IPRINT.GT.1) WRITE(6,934) CHI
 934  FORMAT('  ********** MATCH FOUND,CHI=',F10.5)
      CIF
      CIF
      CIF
      CIF
      CIF
      CIF
      IPTRL=IPTRL+LNGRL
      CFOR
      ITR=HMC(JMC)
      HRL(ITR)=-JMC
      CIF
      IPTMC=IPTMC+LNGMC
      CFOR
      IPTMC=IDATA(IMC+1)+IMC+1
      IMCNMX=0
      FOR IMC=1,NUMMC
      IF(HMC(IMC).GT.0.AND.IPRINT.GT.0) WRITE(6,192) IMC,HMC(IMC)
 192  FORMAT('  MC TRACK ',I5,'   MATCHED WITH TRACK',I5)
      IF HMC(IMC).EQ.0
      THEN
      CRVMC=ADATA(IPTMC+26)
      IF ABS(CRVMC).GT.CRVLOW
      THEN
      IF(IPRINT.GT.0) WRITE(6,104) IMC
 104  FORMAT('  MC TRACK',I5,'   MOMENTUM TOO LOW')
      HMC(IMC)=999
      ELSE
      ITYP=IDATA(IPTMC+3)
      IF ITYP.EQ.3
      THEN
      IF(IPRNT.GT.0) WRITE(6,735) IMC
 735  FORMAT(' KINK DAUGHTER NOT FOUND, MC TRACK',I5)
      HMC(IMC)=999
      ELSE
      IF IMC.LT.NUMMC
      THEN
      ITYPNX=IDATA(IPTMC+LNGMC+3)
      IF ITYPNX.EQ.3.AND.HMC(IMC+1).GT.0
      THEN
      HMC(IMC)=999
      IF(IPRNT.GT.0) WRITE(6,727) IMC
 727  FORMAT(' KINK PARENT NOT FOUND BUT DAUGHTER HAS BEEN,MC TRACK',I5)
      CIF
      CIF
      CIF
      CIF
      IF(HMC(IMC).EQ.0.AND.IPRINT.GT.0) WRITE(6,736) IMC
 736  FORMAT(' MC TRACK',I5,'  NOT MATCHED')
      IF(HMC(IMC).EQ.0) IMCNMX=IMCNMX+1
      CIF
      IPTMC=IPTMC+LNGMC
      CFOR
      IPTRL=IDATA(IREAL+1)+IREAL+1
      IRLNMX=0
      FOR IRL=1,NUMRL
      CRVRL=ADATA(IPTRL+26)
      IF ABS(CRVRL).GT.CRVLOW
      THEN
      IF(IPRINT.GT.0) WRITE(6,695) IRL
 695  FORMAT('  REAL TRACK',I5,'   MOMENTUM TOO LOW')
      HRL(IRL)=999
      CIF
      IF(HRL(IRL).EQ.0.AND.IPRINT.GT.0) WRITE(6,385) IRL
 385  FORMAT('  REAL TRACK',I5,'   NOT MATCHED')
      IF(HRL(IRL).EQ.0) IRLNMX=IRLNMX+1
      IPTRL=IPTRL+LNGRL
      CFOR
      IF(IPRINT.GT.0) WRITE(6,738) IMCNMX
 738  FORMAT('0 ',I5,'     MONTE CARLO TRACKS NOT MATCHED')
      IF(IPRINT.GT.0) WRITE(6,730) IRLNMX
 730  FORMAT('  ',I5,'     PATTERN RECOGNIZED TRACKS NOT MATCHED')
      RETURN
      END
      BLOCK DATA
C
C
C-------------------------------------------------------------------
C
C       DESCRIPTION OF LIMITS IN COMMON COMPAT
C
C
C
C
C       THE LIMIT ON THE MATCHING OF THE RAD OF CURVS
C       IS :  RADLI1 + RADLI2 * (RAD OF CRV OF MC TRACK)
C
C        THE LIMIT ON MATCHING NO OF HITS IS:
C        NHTLI1 + DHTLI2 * (NO. OF HITS ON MC TRACK)
C
C        THE LIMITS ON THE X,Y START POSITION OF REAL TRACK
C        AND EXTRAPOLATED POINT ON MC TRACK ARE:
C        DXLIM1 + 1000. * DXLIM2 *( CRV OF MC TRACK)
C
C        THE LIMITS ON DIR COSINE MATCHING ARE:
C        DIRXL1 + 1000. * DIRXL2 *( CRV OF MC TRACK)
C
C        ANY TRACKS WITH CRV HIGHER THAN CRVLOW ARE NOT
C        COUNTED AS BEING MISMATCHED
C        IPRINT = 0,1,2  GIVES PROGRESSIVELY MORE PRINT
C
C----------------------------------------------------------------
C
      IMPLICIT INTEGER*2 (H)
C
      COMMON /COMPAT/ RADLI1,RADLI2,NHTLI1,DHTLI2,DXLIM1,DYLIM1,
     & DXLIM2,DYLIM2,DIRXL1,DIRYL1,DIRXL2,DIRYL2,IPRINT,CRVLOW,
     & IMCNMX,IRLNMX
      DATA CRVLOW/.0015/,IPRINT/1/
      DATA RADLI1,RADLI2/400.,.15/
      DATA NHTLI1,DHTLI2/10,.5/
      DATA DXLIM1,DYLIM1/3.0,3.0/
      DATA DXLIM2,DYLIM2/3.5,3.5/
      DATA DIRXL1,DIRYL1/.04,.04/
      DATA DIRXL2,DIRYL2/.05,.05/
      END
C   25/07/80 102191159  MEMBER NAME  LBHTRO   (PATRECSR)    SHELTRAN
      SUBROUTINE LBHTRO(ITRK,PAR1,PAR2,PAR3,INDPAR)
C
C        LABEL GOOD HITS OF TRACK TROUGH ORIGIN
C                   HISTOGRAM METHOD USING INTERACTION POINT
C                   OR        DIRECTION AT CONVERSION IN PIPE OR TANK
C
      IMPLICIT INTEGER*2 (H)
C
#include "cworkpr.for"
#include "cworkeq.for"
C
      EQUIVALENCE
     ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
     ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
     ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
C
#include "cpatlm.for"
C
#include "cjdrch.for"
#include "cdsmax.for"
C
      DIMENSION HST( 80)
C
N     AVERAGE RADIUS FOR PAIR CONVERSION IN BEAM PIPE OR TANK
      DATA XCV /152.7/
C
C2101 FORMAT('0HISTOGRAM:',20I2,2X,20I2,/,(11X,20I2,2X,20I2))
C2102 FORMAT(' PEAK =',10I6,6F10.5)
C2103 FORMAT(' SAMPL.:',3F6.1,3F10.5,I5,  5X,F10.1,2F10.5,I5)
C
C
N     ZERO HISTOGRAM
      CALL SETS(HST(1),0,160,0)
      DCRV =  .000010
      CRV1 = -DCRV*20.
      X0   = FSENSW(IRING) + RINCR(IRING)*7.5
      Y0   = (PAR1*X0 + PAR2)*X0 + PAR3
      S0   = PAR1*X0*2. + PAR2
      CRV0 = (S0*X0 - Y0) / X0**2
      CRV0 = CRV0 + CRV1
      CVP0 = (S0*X0 - Y0) / (X0**2 - XCV**2)
      CVP0 = CVP0 + CRV1
      ZW1  = X0
      ZW2  = Y0 / X0
      ZW3  = XCV**2
C
N     LOOP OVER ALL HITS
        FOR IP = HPCO0,HPCO9,HLDCO
          X   = WRK(IP+3)
          Y   = WRK(IP+4)
          IF ABS(X-X0) .GT. 25.
          THEN
            CV1 = ZW2*X - Y
            CV2 = (ZW1-X)*X
            CRV = CV1 / CV2
            IBN = (CRV-CRV0) / DCRV + 1
            IF(IBN.GT.0 .AND. IBN.LE.40) HST(IBN   ) = HST(IBN   ) + 1
            CVP = CV1 / ((X/ZW1-1.)*ZW3 + CV2)
            IBM = (CVP-CVP0) / DCRV + 1
            IF(IBM.GT.0 .AND. IBM.LE.40) HST(IBM+40) = HST(IBM+40) + 1
C     PRINT 2103, X,Y,ZW1,ZW2,CRV0,CRV,IBN,ZW3,CVP0,CVP,IBM
          CIF
        CFOR
C
C     PRINT 2101, HST
C
N     FIND PEAK IN HISTOGRAMS
C
C
N     HISTOGRAM (TRACKS THROUGH ORIGIN)
      MHST = 0
      IMAX = 0
      FOR I=19,22
        NHST = HST(I-1) + HST(I  ) + HST(I+1)
        IF NHST.GE.MHST
        THEN
          MHST = NHST
          IMAX = I
        CIF
      CFOR
C
N     HISTOGRAM (TRACKS FROM PAIR CONV.IN PIPE OR TANK)
      MHSTP = 0
      IMAXP = 0
      FOR I=59,62
        NHST = HST(I-1) + HST(I  ) + HST(I+1)
        IF NHST.GE.MHSTP
        THEN
          MHSTP = NHST
          IMAXP = I
        CIF
      CFOR
C     PRINT 2102, IMAX,MHST,IMAXP,MHSTP
C
N     SELECT HISTOGRAM
      IF MHSTP.LT.IRING*8 .OR. MHSTP-5.LT.MHST
      THEN
N       TRACK THROUGH ORIGIN
        INDPAR = 0
      ELSE
N       TRACK FROM PAIR CONVERSION
        INDPAR = 1
        MHST = MHSTP
        IMAX = IMAXP - 40
        CALL MVC(HST(1),0,HST(2),0,80)
        CRV0 = CVP0
        PAR1 = CVP0 - CRV1
        PAR3 = PAR1 * ZW3
      CIF
C
N     EVALUATE PEAK
      NH0 = HST(IMAX-2)
      NH1 = HST(IMAX-1)
      NH2 = HST(IMAX  )
      NH3 = HST(IMAX+1)
      NH4 = HST(IMAX+2)
C
N     CORRECT FOR DOUBLE PEAK
      IF IMAX.EQ.19 .AND.
     ?   NH0.GT.0 .AND. NH0.GT.NH1 .AND. NH4.NE.0
      THEN
        IMAX = IMAX + 1
      CIF
      IF IMAX.EQ.22 .AND.
     ?   NH4.GT.0 .AND. NH4.GT.NH3 .AND. NH0.NE.0
      THEN
        IMAX = IMAX - 1
      CIF
      IM1 = IMAX - 1
      IM3 = IMAX + 1
      IF(NH1.LE.2 .AND. NH3-NH1.GT.2) IM1 = IM1 + 1
      IF(NH3.LE.2 .AND. NH1-NH3.GT.2) IM3 = IM3 - 1
      NHST  = NH1 + NH2 + NH3
      NHTTR = 0
      IF NHST.GE.3
      THEN
C     PRINT 2102,IMAX,MHST,LBLR,NH1,NH2,NH3,IM1,IM3,MHSTL,MHSTR,ZW1,ZW2
C
N       FETCH HITS OF PEAK IN HISTOGRAM
        IHIT = 0
        IPHT = HPHT0
        FOR IP = HPCO0,HPCO9,HLDCO
          X   = WRK(IP+3)
          Y   = WRK(IP+4)
          IF ABS(X-X0) .GT. 25.
          THEN
            CV1 = ZW2*X - Y
            CV2 = (ZW1-X)*X
            IF INDPAR.EQ.0
            THEN
              CRV = CV1 / CV2
            ELSE
              CRV = CV1 / ((X/ZW1-1.)*ZW3 + CV2)
            CIF
            IBN = (CRV-CRV0) / DCRV + 1
C     PRINT 2103, X,Y,ZW1,ZW2,CRV0,CRV,IBN
            IF IBN.GE.IM1 .AND. IBN.LE.IM3
            THEN
N             CHECK IF HIT OF TREL
              IF IWRK(IP+ 9).EQ.ICELL
              THEN
                LBGOOD = 4
                PERFORM CKORHT
              ELSE
                LBGOOD = 0
              CIF
            ELSE
              LBGOOD = 8
N             CHECK IF NO ORIGINAL HIT OF TRACK
              PERFORM CKORHT
            CIF
          ELSE
            LBGOOD = 1
N           CHECK IF NO ORIGINAL HIT OF TRACK
            PERFORM CKORHT
          CIF
          IWRK(IP+7) = LBGOOD
          IF(LBGOOD.EQ.0) IHIT = IHIT + 1
        CFOR
        NHTTR = IHIT
      CIF
C
      RETURN
C
C
N     *************************
N     *      C K O R H T      *
N     *************************
C
C
N     CHECK IF NO ORIGINAL HIT OF TREL
      PROC CKORHT
C
N     CHECK IF ANY TREL
      IF ITRK.GT.0
      THEN
C
        JCELL = IWRK(IP+ 9)
N       CHECK IF SAME CELL
        IF JCELL.EQ.ICELL
        THEN
          IPBACK = IWRK(IP+ 1)
          WHILE IPHT.LT.HPHT9
            IF IWRK(IPHT+1).EQ.IPBACK
            THEN
              IF(IWRK(IPHT+9).EQ.ITRK .OR. IWRK(IPHT+10).EQ.ITRK)
     ?          LBGOOD = 0
              XWHILE
            CIF
            IF(IWRK(IPHT+1).GT.IPBACK) XWHILE
          IPHT = IPHT + HLDHT
          CWHILE
        CIF
      CIF
      CPROC
C
      END
