C   20/03/97 703202241  MEMBER NAME  JEOSUM3  (PATRECSR)    SHELTRAN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 00000    C   20/02/81 107091035  MEMBER NAME  BACKTR   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE BACKTR
 00002    C
 00003    C     BACKTRACING VERSION 5 (MAR 2,79)
 00004    C     MAIN PROGRAM FOR BACKTRACING
 00005    C
 00006   3      IMPLICIT INTEGER*2 (H)
 00007    C
 00008    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400   4      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
 00500         +                  RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,
 00510         +                  ZRESOL,ZNORM,ZAL,ZSCAL,DRIDEV,DRICOS,DRISIN,
 00600         +                  PEDES,TZERO(3),DRIROT(96,2),SINDRI(96,2),
 00701         +                  COSDRI(96,2),DRIVEL(96,2),T0FIX(3),
 00800         +                  ABERR(8), DUMJDC(20)
 00900    C
 01100    C      BLOCK DATA SET TO MC VALUES, KALIBR WILL SET REAL DATA VALUES
 01210    C--->  A CHANGE OF THIS COMMON MUST BE DONE SIMULTANEOUSLY WITH  <----
 01220    C--->  A CHANGE OF THE BLOCK DATA                                <----
 01230    C
 01300    C--------------------------- END OF MACRO CJDRCH -----------------------
 01400    C
 00000    C   30/10/79 910301050  MEMBER NAME  CWORKMX  (PATRECSR)    FORTRAN
 00100    C   16/09/79 C9092001   MEMBER NAME  CWORKMX  (UKSOR)       FORTRAN
 00200    C ==========MACRO CWORKMG =============================
 00300   5      EQUIVALENCE (ADWRK(291),HUSE(1)),(ADWRK(391),K),
 00400         * (ADWRK(392),ICL),(ADWRK(393),LRING),(ADWRK(394),KRING),
 00500         * (ADWRK(395),LR),(ADWRK(396),IRIFLG),(ADWRK(397),IUDFLG),
 00600         * (ADWRK(398),ILIM),(ADWRK(399),LR1),(ADWRK(400),IRL),
 00700         * (ADWRK(401),ITK(1,1)),(ADWRK(441),DTEMP(1)),
 00800         * (ADWRK(451),IPST),(ADWRK(452),IJFLG),(ADWRK(453),ICX),
 00900         * (ADWRK(454),KT),(ADWRK(455),ISDL),(ADWRK(456),IBFIT),
 01000         * (ADWRK(457),ISP),(ADWRK(458),ISKP(1)),(ADWRK(468),HSP1(1)),
 01100         * (ADWRK(478),ITOL),(ADWRK(479),IW),(ADWRK(480),A),
 01200         * (ADWRK(481),DS),(ADWRK(482),IWT),(ADWRK(483),ICT),
 01300         * (ADWRK(484),IKX),(ADWRK(485),LRCORN)
 01400   6      DIMENSION HUSE(200),DTEMP(10),ITK(10,4),ISKP(10),HSP1(20)
 01500   7      EQUIVALENCE (ILOUT,IBKK(3)),(ILIN,IBKK(4)),
 01600         * (ILBOT,IBKK(8)),(DCELL,BKK(9))
 01700    C ==========ENDMACRO CWORKMG==========================
          C----------------------------------------------------------------------
          C           MACRO CDSMAX .... PATTERN RECOGNITION CONSTANTS.
          C----------------------------------------------------------------------
         8      COMMON/CDSMAX/DSMAX(16,3,2),DIRWR1(24,2),DIRWR3(48,2)
               *             ,DHALF(16,3,2),DTWICE(16,3,2),HMCH(16,3,2)
               *             ,IBCK(9),DBCK(30),TRMATS(96,2),TRMATC(96,2)
          C------------------------ END OF MACRO CDSMAX -------------------------
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         9      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        10      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
        11      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        12      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        13      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        14      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        15      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
          C------------------------------------------
          C  MACRO CLBPGM ....
          C------------------------------------------
        16      COMMON /CLBPGM/ LBPGM(30)
          C--------- END OF MACRO CLBPGM ------------
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        17      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        18      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        19      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        20      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        21      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00015  22      DIMENSION HORD(200),HTEMP(10)
 00016  23      DIMENSION LSTCL(3),LFTCL(3),NCELL(3),TANDEL(3)
 00017  24      EQUIVALENCE (IBCK(1),LSTCL(1)),(IBCK(4),LFTCL(1))
 00018  25      EQUIVALENCE (IBCK(7),NCELL(1)),(DBCK(1),TANDEL(1))
 00019  26      EQUIVALENCE (ADWRK(486),HTEMP(1)),(ADWRK(491),HORD(1))
 00020  27      DATA HPST/'PS'/
 00021  28      DATA MSKCR1,MSKCR2,MSKZEN /Z100,Z200,Z80/,MSKERA/ZFFFFBFFF/
 00022  29      DATA MSKLR0/Z1000/,MSKKIL/Z20000/,MSKLRA/ZFFFFEFFF/
 00023  30      DATA MSKDSP,MSKERR,MSKSKP/Z2000,Z4000,Z8000/
 00024    C
 00025    C
 00026    C     PRINT 3462, (IPCL(I),I=1,HNTR)
 00027    C     PRINT 3463, (NRHT(I),I=1,HNTR)
 00028    C     PRINT 3464, (NWR1(I),I=1,HNTR)
 00029    C     PRINT 3460, (DS1(I),I=1,HNTR)
 00030    C     PRINT 3465, (SL1(I),I=1,HNTR)
 00031    C     PRINT 3466, (NWR2(I),I=1,HNTR)
 00032    C     PRINT 3467, (DS2(I),I=1,HNTR)
 00033    C     PRINT 3468, (SL2(I),I=1,HNTR)
 00034    C     PRINT 3469, (LBL(I),I=1,HNTR)
 00035    C3462  FORMAT(' CELL#',30I4)
 00036    C3463  FORMAT(' NO OF HITS',30I4)
 00037    C3464  FORMAT(' WIRE1',30I4)
 00038    C3466  FORMAT(' WIRE2',30I4)
 00039    C3469  FORMAT(' LBL  ',20(1X,Z4))
 00040    C3460  FORMAT(' DRIFT1',10F7.3)
 00041    C3465  FORMAT(' SLOPE1',10F7.3)
 00042    C3467  FORMAT(' DRIFT2',10F7.3)
 00043    C3468  FORMAT(' SLOPE2',10F7.3)
 00044  31      LBPGM(10)=1
 00045  32      IF(HNTR.LE.0.OR.HPRO.NE.HPST) RETURN
 00046  34      FOR I=1,HNTR
 00047  35         HORD(I)=I
 00048  36      CFOR
 00049  38      IF HNTR.GT.1
 00050  39      THEN
 00051  42         INR=HNTR-1
 00052  43         FOR IBK=1,INR
 00053  44            IBC=IBK+1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00054  45            IF IPCL(IBK).EQ.IPCL(IBC)
 00055  46            THEN
 00056  49               IF NWR2(IBK).GT.NWR2(IBC).AND.NWR1(IBK).GT.NWR1(IBC)
 00057  50               THEN
 00058  53                  TEMP=HORD(IBK)
 00059  54                  HORD(IBK)=HORD(IBC)
 00060  55                  HORD(IBC)=TEMP
 00061    C     PRINT 563,HORD(IBK),HORD(IBC),IBK
 00062    C 563  FORMAT(' ((((((((',3I5)
 00063  56               CIF
 00064  57            CIF
 00065  58         CFOR
 00066  60      CIF
 00067  61      IBFIT=0
 00068  62      ISP=0
 00069  63      ITOL1=2
 00070  64      IS=0
 00071  65      ZERO=0
 00073  66      CALL SETSL(HUSE(1),0,400,ZERO)                                     INIT TRACK ELEMENT ARRAYS
 00074  67      CALL SETSL(NTR,0,2004,ZERO)
 00075  68      FOR I=1,HNTR
 00076  69         IF(LAND(LBL(I),MSKKIL).NE.0) HUSE(I)=1
 00077  71      CFOR
 00079  73      FOR ITRL=1,HNTR                                                    GET AN INITIAL TRACK STARTING IN CELL 96
 00081  74         K=HNTR-ITRL+1                                                   K IS THE CURRENT TRACK POINTER
 00082  75         K=HORD(K)
 00084  76         IF HUSE(K).EQ.0                                                 HAS IT BEEN USED YET?
 00085  77         THEN
 00086  80            IF NTR.LT.100
 00087  81            THEN
 00089  84               ICNT = 0                                                  CONTINUATION COUNTER
 00091  85               ICL=IPCL(K)                                               EXTRACT CELL NO
 00092  86               IJFLG=0
 00093  87               LRING=1
 00095  88               ITOL=1                                                    NORMAL TOLERANCES
 00097  89               IF(ICL.GT.NCELL(1)) LRING=2                               CALCULATE RING NO
 00098  91               IF(ICL.GT.NCELL(2)+NCELL(1)) LRING=3
 00100  93               IF LRING.LE.ITOL1                                         ENTER ONCE FOR LRING=2
 00102  94               THEN                                                      AND ONCE FOR LRING=1
 00104  97                  IF IS.GT.0                                             INCOMPLETE TRACKS?
 00105  98                  THEN
 00106                                                                             FLAG TO INCREASE NORMAL TOLERANCES
 00108 101                     ITOL=2                                              ITOL NE 1 MEANS TOLERANCES HAVE BEEN INCREASED
 00110 102                     INTR=NTR                                            REMEMBER RING,TRACK POINTERS
 00111 103                     IIK=K
 00113 104                     ITOL1=ITOL1-1                                       DECREASE ITOL1 COUNTER
 00114 105                     ILRNG=LRING
 00116 106                     IS1=IS                                              FIX NO. OF INCOMPLETE TRACKS TO BE TRIED
 00118 107                     IS=0                                                RESET COUNTER FOR NO. OF INCOMPLETE TRACKS
 00119    C     PRINT 662
 00120    C 662  FORMAT('0************* LOOSER TOLERANCES *********** ')
 00122 108                     FOR IU=1,IS1                                        LOOP OVER INCOMPLETE TRACKS
 00124 109                        NTR=HSP1(IU)                                     EXTRACT TRACK NO.
 00126 110                        K=HISTR(HNREL(NTR),NTR)                          EXTRACT TRACK ELEMENT NO.
 00127 111                        LR=1
 00128 112                        IF(K.LT.0) LR=-1
 00129 114                        K=IABS(K)
 00131 115                        LBL(K)=LAND(LBL(K),MSKERA)                       TURN OFF ERROR BIT
 00132    C     CALL CHKX(2,NTR,LR,K)
 00134 116                        ICL=IPCL(K)                                      EXTRACT CELL NO.
 00136 117                        LRING=1                                          CALCULATE RING NO
 00137 118                        IF(ICL.GT.NCELL(1)) LRING=2
 00138 120                        IF(ICL.GT.NCELL(2)+NCELL(1)) LRING=3
 00139 122                        KRING=LRING
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00140 123                        IPST=1
 00141 124                        IJFLG=0
 00143 125                        ITMP=HISTR(1,NTR)                                IF A PREVIOUS CONNECTION ACROSS BOUNDARY
 00145 126                        ITMP=IABS(ITMP)                                  THEN SET IPST=0
 00146 127                        ITMP=IPCL(ITMP)
 00147 128                        IF(ICL.NE.ITMP) IPST=0
 00148    C     CALL CHKX(3,ICL,ITMP,IPST)
 00149    C     PRINT 4458,NTR,K,ICL,KRING
 00151 130                        IF LAND(LBL(K),MSKLR0).NE.0                      DOES THIS TRACK HAVE LR=0 BIT SET?
 00152 131                        THEN
 00153 134                           ITMP=HNREL(NTR)
 00155 135                           FOR IX=1,ITMP                                 RESET LR=0 BIT FOR THE WHOLE TRACK
 00156 136                              IJ=HISTR(IX,NTR)
 00157 137                              IJ=IABS(IJ)
 00158 138                              LBL(IJ)=LAND(LBL(IJ),MSKLRA)
 00159 139                           CFOR
 00161 141                           IF ITMP.EQ.1                                  IF ONLY ONE TRACK ELEMENT
 00162 142                           THEN
 00163 145                              LR=0
 00164 146                           ELSE
 00166 148                              IJFLG=1                                    FOR MORE THAN ONE ELEMENT IN THE TRACK
 00167 149                           CIF
 00168 150                        CIF
 00169 151                        PERFORM CONT1
 00170 154                     CFOR
 00171 156                     NTR=INTR
 00173 157                     ICNT=0                                              RESET FLAGS
 00174 158                     IJFLG=0
 00175 159                     ITOL=1
 00176 160                     K=IIK
 00177 161                     LRING=ILRNG
 00178    C     PRINT 662
 00179 162                  CIF
 00180 163               CIF
 00182 164               IF HUSE(K).EQ.0                                           IS THIS TRACK STILL UNUSED?
 00183 165               THEN
 00185 168                  ICL=IPCL(K)                                            EXTRACT CELL NO
 00186 169                  KRING=LRING
 00188 170                  NTR = NTR + 1                                          INCREMENT TRACK NUMBER
 00189    C     PRINT 4458,NTR,K,ICL,KRING
 00190    C 4458 FORMAT('0NTR=',I4,' TRACK=',I4,' CELL=',I4,' RING=',I4)
 00192 171                  IKX=K                                                  GET READY TO STORE AWAY TRACK
 00194 172                  CALL LFRT(LR2)                                         DETERMINE LEFT-RIGHT SOLN
 00195 173                  LR=LR2
 00197 174                  IF(LR.EQ.0) LR=1                                       IF IT IS UNKNOWN THEN SET IT TEMPORARILY
 00199 176                  CALL BSTORE                                            STORE THIS TRACK AWAY
 00201 177                  LR=LR2                                                 RESET LR IN CASE IT WAS ZERO BEFORE
 00203 178                  PERFORM CONT1                                          TRY TO FIND A CONTINUATION OF THIS TRACK
 00204 181               CIF
 00205 182            CIF
 00206 183         CIF
 00207 184      CFOR
 00208 186      FOR KTR=1,NTR
 00209 187         ITMP=HNREL(KTR)
 00210                                                                             CHECK FOR DISCREPANCY BETWEEN
 00212 188         PERFORM CELLFL                                                  LR FROM LBL AND FROM BACKTR
 00213 191         IF(KMP1.EQ.KMP2) LBL(ITKEL)=LOR(LBL(ITKEL),MSKLR0)
 00214 193         IF(KMP1.EQ.KMP2) LBL(ITKEL1)=LOR(LBL(ITKEL1),MSKLR0)
 00215    C     IF(KMP1.EQ.KMP2) PRINT 457
 00216    C 457  FORMAT(' ++++++++++ LR=0 +++++++++++++++')
 00217 195         FOR MG=1,ITMP
 00218 196            JK=HISTR(MG,KTR)
 00219 197            IKX=IABS(JK)
 00220 198            CALL LFRT(LR2)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00222 199            IF JK*LR2.LT.0                                               SET BIT 18 FOR DISCREPANCY
 00223 200            THEN
 00224 203               IF IBKK(20).NE.0.AND.NRHT(IKX).GE.IBKK(19)
 00225 204               THEN
 00226    C     HISTR(MG,KTR)=-HISTR(MG,KTR)
 00227    C     PRINT 209,IKX,KTR
 00228    C209   FORMAT('  TRACKEL ',I5,'    FROM TRACK',I5,'  FORCED LR ')
 00229 207               ELSE
 00230 209                  LBL(IKX)=LOR(LBL(IKX),MSKDSP)
 00231    C     PRINT 453,IKX
 00232 210               CIF
 00233 211            CIF
 00234    C 453  FORMAT(' ====== WRONG LR FLAG ,TRACK===================== ',I4)
 00235 212         CFOR
 00236 214      CFOR
 00237    C     PRINT 3456,NTR
 00238    C     PRINT 3457,(HNREL(III),III=1,NTR)
 00239    C     PRINT 3458,((HISTR(KK,III),KK=1,6),III=1,NTR)
 00240    C3456  FORMAT('0NTR ',I10)
 00241    C3457  FORMAT(' NREL ',30I4)
 00242    C3458  FORMAT(' HISTR ',30I4)
 00243    C     PRINT 3469, (LBL(I),I=1,HNTR)
 00244 216      IF NTR.GT.1
 00245 217      THEN
 00246 220         FOR KTR=1,NTR
 00247 221            PERFORM CELLFL
 00248 224            IR1=1
 00249 225            IR2=1
 00250 226            IF(KMP1.GT.NCELL(1)) IR1=2
 00251 228            IF(KMP1.GT.NCELL(1)+NCELL(2)) IR1=3
 00252 230            IF(KMP2.GT.NCELL(1)) IR2=2
 00253 232            IF(KMP2.GT.NCELL(1)+NCELL(2)) IR2=3
 00254 234            IF(IR2.EQ.1.AND.IR1.EQ.3.AND.LAND(MSKSKP,LBL(ITKEL)).EQ.0)
 00255         *      HORD(KTR)=1
 00256 236            IF(IR2.EQ.1.AND.IR1.EQ.2) HORD(KTR)=6
 00257 238            IF(LAND(MSKSKP,LBL(ITKEL)).NE.0) HORD(KTR)=2
 00258 240            IF(IR2.EQ.2.AND.IR1.EQ.3) HORD(KTR)=3
 00259 242            IF IR1.EQ.IR2
 00260 243            THEN
 00261 246               IF(IR1.EQ.3) HORD(KTR)=5
 00262 248               IF(IR1.EQ.2) HORD(KTR)=4
 00263 250               IF(IR1.EQ.1) HORD(KTR)=7
 00264 252            CIF
 00265 253         CFOR
 00266    C     PRINT 286,(HORD(IO),IO=1,NTR)
 00267    C286  FORMAT(' ',30I3)
 00268 255         INR=NTR-1
 00269 256         FOR IBK=1,INR
 00270 257            IUP=IBK+1
 00271 258            FOR IBC=IUP,NTR
 00272 259               IF HORD(IBC).LT.HORD(IBK)
 00273 260               THEN
 00274 263                  CALL MVC(HTEMP(1),0,HISTR(1,IBC),0,18)
 00275 264                  CALL MVC(HISTR(1,IBC),0,HISTR(1,IBK),0,18)
 00276 265                  CALL MVC(HISTR(1,IBK),0,HTEMP(1),0,18)
 00277 266                  TEMP=HNREL(IBC)
 00278 267                  HNREL(IBC)=HNREL(IBK)
 00279 268                  HNREL(IBK)=TEMP
 00280 269                  TEMP=HORD(IBC)
 00281 270                  HORD(IBC)=HORD(IBK)
 00282 271                  HORD(IBK)=TEMP
 00283 272               CIF
 00284 273            CFOR
 00285 275         CFOR
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00286    C     PRINT 3457,(HNREL(III),III=1,NTR)
 00287    C     PRINT 3458,((HISTR(KK,III),KK=1,6),III=1,NTR)
 00288 277         IF IYBKK(11).NE.0
 00289 278         THEN
 00290 281            HPFRE0=HPFREE
 00291 282            IMOSS=99
 00292 283            CALL BAKPAK(IMOSS)
 00293 284            HPFREE=HPFRE0
 00294 285         CIF
 00295 286         IF IYBKK(15).NE.0
 00296 287         THEN
 00297 290            HPFRE0=HPFREE
 00298 291            IMOSS=0
 00299 292            CALL BAKPAK(IMOSS)
 00300 293            HPFREE=HPFRE0
 00301 294         CIF
 00302 295         IP0=0
 00304 296         FOR I=1,100                                                     SEARCH FOR TRACKS WITH NO ELS
 00305 297            IF HNREL(I).EQ.0
 00306 298            THEN
 00307 301               IP0=I
 00308 302               XFOR
 00309 303            CIF
 00310 304         CFOR
 00311 306         IF IP0.NE.0
 00312 307         THEN
 00314 310            FOR I=1,100                                                  COMPRESS BACKTR ARRAY
 00315 311               IF IP0.LT.I
 00316 312               THEN
 00317 315                  IF HNREL(I).NE.0
 00318 316                  THEN
 00319 319                     HNREL(IP0)=HNREL(I)
 00320 320                     HNREL(I)=0
 00321 321                     FOR J=1,9
 00322 322                        HISTR(J,IP0)=HISTR(J,I)
 00323 323                        HISTR(J,I)=0
 00324 324                     CFOR
 00325 326                     IP0=IP0+1
 00326 327                  CIF
 00327 328               CIF
 00328 329            CFOR
 00329 331         CIF
 00330 332         ICOUNT=0
 00332 333         FOR I=1,100                                                     HOW MANY TRACKS
 00333 334            IF(HNREL(I).NE.0) ICOUNT=ICOUNT+1
 00334 336         CFOR
 00336 338         NTR=ICOUNT                                                      UPDATE NTR
 00337 339      CIF
 00338 340      RETURN
 00339    C
 00340    C    *********************************************************
 00341    C
 00342 341      PROC CONT1
 00343    C
 00344    C   THIS PROCEDURE CALLS CONT FOR EACH RING
 00345    C
 00346 342         PERFORM CONT
 00348 345         IF KRING.GT.0.AND.IRIFLG.NE.0                                   IF WE WERE SUCCESSFUL THEN TRY AGAIN
 00349 346         THEN
 00350 349            PERFORM CONT
 00352 352            IF KRING.GT.0.AND.IRIFLG.NE.0                                TRY FOR A MATCH INTO THE LAST RING
 00353 353            THEN
 00354 356               PERFORM CONT
 00355 359            CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 00356 360         CIF
 00357 361      CPROC
 00358    C
 00359    C    *********************************************************
 00360    C
 00361 363      PROC CONT
 00362    C
 00363    C   THIS PROCEDURE FINDS FIRST MATCHING TRACK IN NEXT RING,
 00364    C      CORRECTLY STORING ANY TRACKS GOING OUT THROUGH THE SIDE WALL
 00365    C
 00367 364         ICNT = ICNT + 1                                                 INCREMENT CONT COUNTER
 00369 365         IF ICNT.EQ.1.AND.ITOL.EQ.1                                      CHECK FOR TRACK GOING THROUGH SIDEWALL(IN AN OUTWA
 00370 366         THEN
 00371 369            IUDFLG=3
 00372 370            ILIM=ILOUT
 00373 371            KY=K
 00374 372            ICY=ICL
 00375 373            IDUM=0
 00376 374            WHILE IDUM.EQ.0
 00377    C     PRINT 2345,K
 00378    C2345 FORMAT(' PERFORM SIDOUT TRACK=',I4)
 00379 376               ISTREL=HNREL(NTR)+1
 00381 380               CALL BSIDE                                                TRY SIDE CONNECTION
 00382 381               IF IRIFLG.NE.1
 00383 382               THEN
 00384 385                  XWHILE
 00385 386               CIF
 00386 387               INTFLG=0
 00387 388               IF HNTCEL(ICX+1)-HNTCEL(ICX).GT.1
 00388 389               THEN
 00390 392                  NTRLX1=HNTCEL(ICX)                                     WITH A TRACK ELEMENT IN THE UPPER
 00392 393                  NTRLX2=HNTCEL(ICX+1)-1                                 HALF OF THE CELL
 00393 394                  IBFIT=-2
 00395 395                  FOR KK=NTRLX1,NTRLX2                                   LOOP OVER ALL TRACK ELS IN THIS CELL
 00397 396                     IF HUSE(KK).EQ.0                                    WITH LOWER TRACK EL FIXED AT KX
 00398 397                     THEN
 00399 400                        IW=NWR1(KK)
 00400 401                        IF IW.GE.ILBOT
 00401 402                        THEN
 00403 405                           CALL  INTJN1(KK,KT,INTFLG,DT)                 TRY CONNECTION WITHIN A CELL
 00404 406                           IF INTFLG.NE.0
 00405 407                           THEN
 00406 410                              IKX=KK
 00407 411                              LR3=1
 00408 412                              IF(INTFLG.EQ.-1.OR.(LAND(LBL(KT),MSKCR1).NE.0.AND.LAND(LBL(IKX),
 00409         *                        MSKCR1).EQ.0)) LR3=-1
 00410 414                              LRR=LR
 00411 415                              LR=-LR
 00412 416                              PERFORM INCRSS
 00413 419                              LR=LR2
 00414 420                              CALL BSTORE
 00415 421                              K=IKX
 00416 422                              PERFORM SRTREL
 00417 425                              ICL=ICX
 00418 426                              LR=LRR
 00419 427                              XFOR
 00420 428                           CIF
 00421 429                        CIF
 00422 430                     CIF
 00423 431                  CFOR
 00424 433                  IBFIT=0
 00425 434               CIF
 00426 435               IF INTFLG.EQ.0
 00427 436               THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 00428 439                  PERFORM SRTREL
 00429 442                  XWHILE
 00430 443               CIF
 00431 444            CWHILE
 00432 446            ICL=ICY
 00433 447            K=KY
 00434 448            PERFORM CROSS
 00435 451         CIF
 00437 452         IW = NWR1(K)                                                    STARTING WIRE NR
 00438 453         IUDFLG=6
 00439 454         IF IW.GE.ILBOT
 00440 455         THEN
 00442 458            PERFORM INTJN                                                TRY JOINING TRACK ELS WITHIN A CELL
 00443 461         CIF
 00445 462         ILIM=-ILIN                                                      CHECK FOR TRACK GOING THROUGH SIDEWALL(IN AN INWAR
 00446 463         IDUM=0
 00447 464         WHILE IDUM.EQ.0
 00448    C     PRINT 2346,K
 00449    C2346 FORMAT(' PERFORM SIDIN TRACK=',I4)
 00451 466            CALL BSIDE                                                   TRY SIDE CONNECTION
 00452                                                                             UPDATE CELL AND TRACK POINTERS AFTER SUCCESSFUL MA
 00454 470            ICL=ICX                                                      FOR INWARD GOING TRACKS ONLY
 00455 471            K=KT
 00456 472            IF IRIFLG.EQ.0
 00457 473            THEN
 00458 476               XWHILE
 00459 477            CIF
 00460 478            PERFORM CROSS
 00462 481            IW = NWR1(K)                                                 STARTING WIRE NR
 00463 482            IF IW.GE.ILBOT
 00464 483            THEN
 00466 486               PERFORM INTJN                                             TRY JOINING TRACK ELS WITHIN A CELL
 00467 489               IF ISUFLG.EQ.0
 00468 490               THEN
 00469 493                  XWHILE
 00470 494               CIF
 00471 495            ELSE
 00472 497               XWHILE
 00473 498            CIF
 00474 499         CWHILE
 00476 501         IRIFLG = 0                                                      RING CONTINUATION FLAGS PRESET
 00477 502         IUDFLG=0
 00478 503         IF KRING.GT.1
 00480 504         THEN                                                            CONNECT TRACK THROUGH RINGS
 00481 507            CALL RINCON
 00482 508            PERFORM CROSS
 00483 511         CIF
 00484 512         IF IRIFLG.EQ.0
 00485 513         THEN
 00486 516            IF LRING.NE.1.AND.KRING.NE.LRING
 00487 517            THEN
 00489 520               LBL(K)=LOR(LBL(K),MSKERR)                                 POSSIBLE BACKTR ERROR
 00490    C     PRINT 6543,K
 00491    C6543 FORMAT(' ==================POSSIBLE ERROR=============,TRACK=',I5)
 00493 521               IF IS.LT.20                                               STORE AWAY INCOMPLETE TRACK NO.
 00494 522               THEN
 00495 525                  IS=IS+1
 00496 526                  HSP1(IS)=NTR
 00497    C     CALL CHKX(1,IS,HSP1(IS),NTR)
 00498 527               CIF
 00499 528            CIF
 00500 529            IF IJFLG.EQ.1
 00501 530            THEN
 00503 533               PERFORM SEAR                                              SEARCH TO SEE IF AMBIGUITY
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 00505 536            CIF                                                          SHOULD BE REVERSED
 00506 537            IF KRING.EQ.2.AND.ITOL.EQ.1
 00508 538            THEN                                                         STORE AWAY FOR POSSIBLE JOINING WITH
 00510 541               IF ISP.LT.10                                              AN ELEMENT IN RING 1(SKIP A RING)
 00511 542               THEN
 00512 545                  ISP=ISP+1
 00513 546                  ISKP(ISP)=NTR
 00514    C     CALL CHKX(37,ISP,ISKP(ISP),NTR)
 00515 547               CIF
 00516 548            CIF
 00517 549            IF LR.EQ.0
 00518 550            THEN
 00519    C     PRINT 456
 00520    C456  FORMAT(' ========================= LR=0 =====================')
 00522 553               LBL(K)=LOR(LBL(K),MSKLR0)                                 SET BIT 19 FOR UNDETERMINED AMBIGUITY
 00523 554            CIF
 00524 555         CIF
 00525 556         IF LRING.EQ.1.AND.IRIFLG.EQ.0
 00526 557         THEN
 00528 560            IF LAND(LBL(K),MSKZEN).EQ.0.AND.ICNT.EQ.1.AND.ISP.GT.0       POSSIBLY ABLE TO JOIN AN EL
 00530 561            THEN                                                         IN  RING 1 WITH ONE IN RING 3
 00532    C     PRINT 893                                                          (I.E. NO HITS IN RING 2)
 00533    C893  FORMAT('  $$$$$$$$$ SKIP A RING $$$$$$$$')
 00534 564               JTRK=HISTR(1,NTR)
 00535 565               JTRK=IABS(JTRK)
 00536 566               IC1=2*IPCL(JTRK)+47
 00537 567               INM=HNREL(NTR)
 00538 568               INTR=NTR
 00539    C     CALL CHKX(84,JTRK,IC1,NTR)
 00540 569               FOR I=1,ISP
 00542 570                  IJ=ISKP(I)                                             ISKP(I) CONTAINS TRACK NO OF POSSIBLE
 00544 571                  IK=HISTR(HNREL(IJ),IJ)                                 TRACK IN RING 3
 00545 572                  IC=IABS(IK)
 00546 573                  IK=IPCL(IC)
 00548 574                  IF IK.EQ.IC1.OR.IK.EQ.IC1+1                            IS THE CELL CORRECT
 00550 575                  THEN                                                   WE HAVE A MATCH
 00551 578                     IF LAND(LBL(IC),MSKERR).NE.0
 00552 579                     THEN
 00553    C     CALL CHKX(97,JTRK,IC,IK)
 00554 582                        IF ABS(ABS(SL1(IC))-ABS(SL2(JTRK))).LT.BKK(10).AND.ABS(SL1(IC))
 00555         *                     .LT.BKK(11).AND. ABS(SL2(JTRK)).LT.BKK(11)
 00556 583                        THEN
 00557 586                           IXYB=0
 00558 587                           IF IYBKK(1).NE.0
 00559 588                           THEN
 00560 591                              PERFORM SKPFIT
 00561 594                           CIF
 00562 595                           IF IXYB.EQ.0
 00563 596                           THEN
 00564 599                              NTR=IJ
 00565 600                              PERFORM SETSKP
 00566 603                              INM=HNREL(NTR)
 00567 604                              FOR JZ=1,INM
 00568 605                                 IK=HISTR(JZ,NTR)
 00569 606                                 IK=IABS(IK)
 00570 607                                 LBL(IK)=LOR(LBL(IK),MSKSKP)
 00571 608                                 LBL(IK)=LAND(LBL(IK),MSKLRA)
 00572 609                              CFOR
 00573 611                              LBL(IC)=LAND(LBL(IC),MSKERA)
 00574 612                              HNREL(INTR)=0
 00575 613                              NTR=INTR-1
 00576 614                              XFOR
 00577 615                           CIF
 00578 616                        CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 00579 617                     CIF
 00580 618                  CIF
 00581 619               CFOR
 00582 621            CIF
 00583 622         CIF
 00584 623      CPROC
 00585    C
 00586    C    *************************************************************
 00587    C
 00588    C
 00589 625      PROC INTJN
 00590    C
 00591    C     THIS PROC JOINS INCOMPLETE TRACK ELEMENTS WITHIN ONE CELL
 00592    C     THE CODING ASSUMES THAT THE FIRST TRACK ELEMENT FOUND
 00593    C     IS ALWAYS THE OUTERMOST ONE
 00594    C
 00595 626         ISUFLG=0
 00597 627         IF HNTCEL(ICL+1)-HNTCEL(ICL).GT.1                               MORE THAN ONE EL IN CELL
 00598 628         THEN
 00600 631            NTRLX1=HNTCEL(ICL)                                           ZERO ITK ARRAY
 00601 632            NTRLX2=HNTCEL(ICL+1)-1
 00602 633            WHILE IW.GE.ILBOT
 00603 635               IRL=0
 00604 639               KK=K
 00605 640               CALL SETSL(ITK(1,1),0,160,ZERO)
 00606 641               FOR KX=NTRLX1,NTRLX2
 00607 642                  IF HUSE(KX).EQ.0
 00608 643                  THEN
 00610 646                     CALL INTJN1(KK,KX,INTFLG,DTMP)                      ATTEMPT CONNECTION WITHIN CELL
 00611 647                     IF INTFLG.NE.0
 00612 648                     THEN
 00613 651                        PERFORM AWY
 00614 654                     CIF
 00615 655                  CIF
 00616 656               CFOR
 00618 658               IF IRL.GT.0                                               IF SUCCESSFUL SEE IF THERE EXISTS A
 00620 659               THEN                                                      BETTER CONNECTION IN THIS CELL
 00621 662                  IBFIT=-3
 00623 663                  IF HNTCEL(ICL+1)-HNTCEL(ICL).GT.2                      AT LEAST THREE ELS IN THIS CELL
 00624 664                  THEN
 00625 667                     IRT=IRL
 00627 668                     FOR JK=1,IRT                                        FOR EACH CONNECTION TRY ANOTHER
 00629 669                        KX=ITK(JK,1)                                     CONNECTION WITH ALL THE OTHER ELS
 00631 670                        FOR KK=NTRLX1,NTRLX2                             IN THIS CELL
 00632 671                           IF HUSE(KK).EQ.0
 00633 672                           THEN
 00634 675                              IW=NWR1(KK)
 00635 676                              IF IW.GE.ILBOT
 00636 677                              THEN
 00637 680                                 CALL INTJN1(KK,KX,INTFLG,DTMP)
 00638 681                                 IF INTFLG.NE.0
 00639 682                                 THEN
 00640 685                                    PERFORM AWY
 00641 688                                 CIF
 00642 689                              CIF
 00643 690                           CIF
 00644 691                        CFOR
 00645 693                     CFOR
 00646 695                  CIF
 00647 696                  IBFIT=0
 00648 697               CIF
 00649 698               IF IRL.GT.1
 00650 699               THEN
 00651 702                  CALL CHOOSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 00652 703               CIF
 00653 704               IW=-100
 00654 705               IF ITK(1,4).EQ.K
 00655 706               THEN
 00656 709                  IKX=ITK(1,1)
 00658 710                  LR3=1                                                  LR3=-1 MEANS PARENT AND CANDIDATE HAVE DIFFERENT A
 00659 711                  IF(ITK(1,3).EQ.-1.OR.(LAND(LBL(IKX),MSKCR1).NE.0
 00660         *            .AND.LAND(LBL(K),MSKCR1).EQ.0)) LR3=-1
 00661 713                  PERFORM INCRSS
 00662 716                  LR=LR2
 00663 717                  IPST=1
 00664 718                  KTR=NTR
 00665 719                  PERFORM CELLFL
 00666 722                  IF(KMP1.NE.KMP2) IPST=0
 00667 724                  CALL BSTORE
 00668 725                  K=IKX
 00669 726                  IW=NWR1(K)
 00670 727                  ISUFLG=1
 00671 728               CIF
 00672 729            CWHILE
 00673 731         CIF
 00674 732      CPROC
 00675    C
 00676    C     *******************************************************
 00677    C
 00678 734      PROC AWY
 00679    C
 00680    C     THIS PROC PUTS INTERNAL TRACK EL
 00681    C     CONNECTION INFORMATION INTO THE
 00682    C     ITK ARRAY
 00683    C
 00684 735         IF IRL.LT.10
 00685 736         THEN
 00687 739            IRL=IRL+1                                                    IRL COUNTS THE NUMBER OF CONNECTIONS
 00689 740            ITK(IRL,1)=KX                                                CANDIDATE(I.E. TRACK EL IN LOWER PART OF CELL)
 00691 741            ITK(IRL,3)=INTFLG                                            WHEN -VE THIS MEANS OPP SIDES OF WIRE
 00693 742            ITK(IRL,4)=KK                                                PARENT(I.E. TRACK EL IN UPPER PART OF CELL)
 00695 743            DTEMP(IRL)=DTMP                                              GOODNESS OF JOIN
 00696 744         ELSE
 00697    C     PRINT 5923
 00698    C5923 FORMAT(' TOO MANY CHOICES ')
 00699 746         CIF
 00700 747      CPROC
 00701    C
 00702    C     *******************************************************
 00703    C
 00704 749      PROC INCRSS
 00705    C
 00706    C     THIS PROC DETERMINES WHETHER CANDIDATE AND PARENT HAVE
 00707    C     DIFFERENT AMBIGUITY
 00708    C
 00709 750         CALL LFRT(LR2)
 00711 751         IF LR2.EQ.0                                                     DETERMINE LR OF CANDIDATE AND STORE IN LR2
 00712 752         THEN
 00713 755            IF LR.NE.0
 00714 756            THEN
 00715 759               LR2=LR*LR3
 00716 760            ELSE
 00717 762               LR2=LR3
 00718 763               IJFLG=1
 00719 764               IPST=1
 00720 765            CIF
 00721 766         ELSE
 00722 768            IF LR.EQ.0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 12
0CARD TARGET
  NO  STM.NO
 
 00723 769            THEN
 00724 772               IF(LR2*LR3.EQ.-1) HISTR(1,NTR)=-HISTR(1,NTR)
 00725 774            ELSE
 00726 776               IF LR2.NE.LR*LR3
 00727 777               THEN
 00728    C     IF(IJFLG.EQ.1) CALL COREC
 00729    C     IF(HNREL(NTR).EQ.1) HISTR(1,NTR)=-HISTR(1,NTR)
 00730 780                  LR2=-LR2
 00731 781               CIF
 00732 782            CIF
 00733 783         CIF
 00734 784      CPROC
 00735    C
 00736    C    *************************************************************
 00737    C
 00738 786      PROC CROSS
 00739    C
 00740    C     THIS PROC CORRECTS LR FLAG WHEN A TRACK
 00741    C     CROSSES THE WIRE PLANE
 00742    C
 00743 787         IF IRIFLG.EQ.1
 00744 788         THEN
 00746 791            IF(IUDFLG.EQ.6) LR=-LR                                       CORRECT LR FLAG FOR SUCCESSFUL SIDE CONNECTION
 00747 793            IF LAND(LBL(K),MSKCR1).NE.0.AND.LAND(LBL(K),MSKCR2).EQ.0
 00748 794            THEN
 00750 797               LR=-LR                                                    CHANGE THE CURRENT LR FLAG
 00752 798               HISTR(HNREL(NTR),NTR)=-HISTR(HNREL(NTR),NTR)              CHANGE THE AMBIGUITY OF PREVIOUSLY STORED TRACK
 00753    C     PRINT 2231,K
 00754    C2231 FORMAT(' CHANGE AMBIGUITY OF TRACK BECAUSE OF WIRE CROSSING',I4)
 00755 799            CIF
 00756 800         CIF
 00757 801      CPROC
 00758    C
 00759    C     *************************************************************
 00760    C
 00761 803      PROC SEAR
 00762    C
 00763    C     THIS PROC IS CALLED AT THE END OF
 00764    C     CONNECTING A TRACK AND IT REMAINS WITH IJFLG=1
 00765    C     (I.E. THE AMBIGUITY HAS NOT BEEN RESOLVED AND
 00766    C     AND THE TRACK HAS BEEN STORED AWAY WITH ARBITRARY
 00767    C     AMBIGUITY) (E.G. LR=0 IN RING 2 AND THEN CONNECTED
 00768    C     TO ATRACK IN IN RING 1)
 00769    C     IT SEARCHES THROUGH THE STORED ELEMENTS
 00770    C     OF THIS TRACK AND IF IT FINDS
 00771    C     A DISCREPANCY BETWEEN THE STORED AMBIGUITY
 00772    C     AND THE ONE FROM WIRE STAGGERING IT REVERSES
 00773    C     THE AMBIGUITY FOR ALL STORED ELS AND RETURNS
 00774    C
 00775 804         ITMP=HNREL(NTR)
 00776 805         FOR I=1,ITMP
 00777 806            JK=HISTR(I,NTR)
 00778 807            IKX=IABS(JK)
 00779 808            CALL LFRT(LR2)
 00780 809            IF LR2.NE.0
 00781 810            THEN
 00783 813               IF(LR2*JK.LT.0) CALL COREC                                REVERSED STORED AMBIGUITIES
 00784 815               XFOR
 00785 816            CIF
 00786 817         CFOR
 00787    C     PRINT 97
 00788    C97   FORMAT(' &&&&&&&&&&&& LR=0 &&&&&&&&&&&&')
 00789 819         FOR I=1,ITMP
 00791 820            JK=HISTR(I,NTR)                                              ALL THE STORED ELS ARE ZERO SO SET BIT 19
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 13
0CARD TARGET
  NO  STM.NO
 
 00792 821            IKX=IABS(JK)
 00793 822            LBL(IKX)=LOR(LBL(IKX),MSKLR0)
 00794 823         CFOR
 00795 825      CPROC
 00796    C
 00797    C     *******************************************************
 00798    C
 00799 827      PROC SRTREL
 00800    C
 00801    C
 00802 828         I9=HNREL(NTR)
 00803 829         FOR IO=ISTREL,I9
 00804 830            ITEM=HISTR(IO,NTR)
 00805 831            J9=IO-2+1
 00806 832            FOR JO=1,J9
 00807 833               HISTR(IO-JO+1,NTR)=HISTR(IO-JO,NTR)
 00808 834            CFOR
 00809 836            HISTR(1,NTR)=ITEM
 00810 837         CFOR
 00811 839      CPROC
 00812    C
 00813 841      PROC CELLFL
 00814    C
 00815    C
 00816    C
 00817 842         KMP1=HISTR(1,KTR)
 00818 843         KMP1=IABS(KMP1)
 00819 844         ITKEL1=KMP1
 00820 845         KMP1=IPCL(KMP1)
 00821 846         KMP2=HISTR(HNREL(KTR),KTR)
 00822 847         KMP2=IABS(KMP2)
 00823 848         ITKEL=KMP2
 00824 849         KMP2=IPCL(KMP2)
 00825 850      CPROC
 00826    C
 00827 852      PROC SKPFIT
 00828    C
 00829    C
 00830    C
 00831 853         IXYB=0
 00832 854         NTR=IJ
 00833 855         IBCD=HNREL(NTR)
 00834 856         CALL MVC(HTEMP(1),0,HISTR(1,NTR),0,18)
 00835 857         PERFORM SETSKP
 00836    C     PRINT 36
 00837    C36   FORMAT('0  SKIP-RING FIT  ')
 00838 860         IAB=HNREL(NTR)
 00839    C     PRINT 37,NTR,(HISTR(IR,NTR),IR=1,IAB)
 00840    C37   FORMAT(' NTR, HISTR ',11I5)
 00841    C     PRINT 38,(HTEMP(IR),IR=1,9)
 00842    C38   FORMAT(' OLD HISTR ',9I5)
 00843 861         CALL BAKFIT(IXYB,4)
 00844 862         CALL MVC(HISTR(1,NTR),0,HTEMP(1),0,18)
 00845 863         HNREL(NTR)=IBCD
 00846 864         NTR=INTR
 00847 865      CPROC
 00848    C
 00849 867      PROC SETSKP
 00850    C
 00851    C
 00852 868         IJLR=LR
 00853 869         FOR JZ=1,INM
 00854 870            IKX=HISTR(JZ,INTR)
 00855 871            IF IJLR.EQ.0.OR.IJFLG.NE.0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 14
0CARD TARGET
  NO  STM.NO
 
 00856 872            THEN
 00857 875               LR=1
 00858 876               IF(LAND(IK,1).EQ.1) LR=-1
 00859    C     CALL CHKX(91,LR,IK,LR2)
 00860 878            ELSE
 00861 880               LR=ISIGN(1,IKX)
 00862 881            CIF
 00863 882            IKX=IABS(IKX)
 00864 883            CALL BSTORE
 00865 884         CFOR
 00866 886         LR=IJLR
 00867 887      CPROC
 00868 889      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         888 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         888 TARGET STATEMENTS
 00000    C   30/10/79 107101038  MEMBER NAME  BAKFIT1  (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE BAKFIT(IB,ITYP)
 00002    C
 00003    C       ITYP=1 FOR INT JOIN
 00004    C       ITYP=2 FOR RING CON
 00005    C       ITYP=3 FOR SIDE CON
 00006    C       ITYP=4 FOR SKIP-RING CON
 00007    C
 00008   3      IMPLICIT INTEGER*2 (H)
 00009    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
         4      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
         5      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
         6      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
         7      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
         8      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400   9      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        10      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        11      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        12      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        13      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        14      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        15      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        16      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00013    C
 00014  17      DIMENSION CHITR(9),HITIN(10)
 00015  18      EQUIVALENCE (ADWRK(91),CHITR(1)),(HITIN(1),ADWRK(86))
 00016    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00017  19      IB=0
 00018  20      IREM=IXYF(1)
 00019  21      IXYF(1)=LOR(IXYF(1),9)
 00020  22      HPOLD=HPFREE
 00021  23      IBTRK=NTR
 00022  24      CALL FXYZ(IBTRK)
 00023  25      HPTR0=HPFREE
 00024  26      HPTR9=HPTR0+49
 00025  27      HLDTR=50
 00026  28      HPFREE=HPTR9+1
 00027  29      IF HPFREE.LE.HPLAST
 00028  30      THEN
 00029  33         CALL XYFIT
 00030  34         RES=CHITR(HNREL(NTR))
 00031  35         RMS=WRK(HPTR0+22)
 00032  36         NTOT=IWRK(HPTR0+23)
 00033  37         NHT=HITIN(HNREL(NTR))
 00034  38         IF(NHT.GT.0) RES=RES/FLOAT(NHT)
 00035  40         IF(ITYP.EQ.1.AND.(RMS.GT.YBKK(2).OR.RES.GT.YBKK(3))) IB=-1
 00036  42         IF(ITYP.EQ.2.AND.(RMS.GT.YBKK(4).OR.RES.GT.YBKK(5))) IB=-1
 00037  44         IF(ITYP.EQ.3.AND.(RMS.GT.YBKK(6).OR.RES.GT.YBKK(7))) IB=-1
 00038  46         IF(ITYP.EQ.4.AND.RMS.GT.YBKK(8)) IB=-1
 00039    C     IF(ITYP.EQ.4) PRINT 389,RMS,RES,NTOT
 00040    C389  FORMAT('0  RMS(ALL HITS)',F10.5,'  RES(TRACKEL) ',F10.5,'  HITS
 00041    C     USED IN FIT ',I5)
 00042    C     CALL PCWORK(0,0,0,1,0)
 00043  48      ELSE
 00044  50         PRINT 33
 00045  51 33   FORMAT(' +++++++++  NOT ENOUGH SPACE IN CWORK  +++++++')
 00046  52      CIF
 00047  53      IXYF(1)=IREM
 00048  54      HPFREE=HPOLD
 00049  55      RETURN
 00050  56      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          55 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          55 TARGET STATEMENTS
 00000    C   08/04/81 107101020  MEMBER NAME  BAKPAK1  (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE BAKPAK(ICHNG)
 00002    C
 00003    C     THIS SUB LOOPS OVER BACKTRACE TRACKS TRYING ALL POSSIBLE
 00004    C     CONNECTIONS IF TRACKS BEGIN AND END CLOSE TO ONE ANOTHER
 00005    C     THE CONNECTION IS ACCEPTED IF THE RMS IS LT RMSLIM.
 00006    C     CONNECTIONS WHERE THE RMS IS BETWEEN RMSLI1 AND RMSLI2
 00007    C     ARE MARKED AND THIS PARENT TRACK IS TRIED AGAIN AT THE
 00008    C     END (EXCEPT ON THE FIRST ENTRY TO BAKPAK).
 00009    C
 00010    C     FIRST ENTRY TO BAKPAK IS SIGNALLED BY ICHNG=99
 00011    C     SUBSEQUENT ENTRIES BY ICHNG=0
 00012    C
 00013   3      IMPLICIT INTEGER*2 (H)
 00014    C
 00015   4      LOGICAL DEADCL
 00016    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
         5      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
         6      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
         7      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
         8      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
         9      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
          C----------------------------------------------------------------------
          C             MACRO CDATA .... BOS COMMON.
          C
          C             THIS MACRO ONLY DEFINES THE IDATA/HDATA/ADATA NAMES.
          C             THE ACTUAL SIZE OF /BCS/ IS FIXED ON MACRO CBCSMX
          C             OR BY OTHER MEANS. A DEFAULT SIZE OF 40000 IS GIVEN HERE.
          C
          C----------------------------------------------------------------------
          C
        10      COMMON /BCS/ IDATA(40000)
        11      DIMENSION HDATA(80000),ADATA(40000),IPNT(50)
        12      EQUIVALENCE (HDATA(1),IDATA(1),ADATA(1)),(IPNT(1),IDATA(55))
        13      EQUIVALENCE (NWORD,IPNT(50))
          C
          C------------------------ END OF MACRO CDATA --------------------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  14      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
          C----------------------------------------------
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        15      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        16      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        17      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        18      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        19      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        20      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        21      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00021  22      COMMON/CHEADR/HEAD(17),HRUN,HEV
 00022  23      COMMON/CADMIN/IEVTP,NREC,NRWRIT,NRERR
 00023    C     HTRK IS TRACK NO IN PATR BANK OF CORRESPONDING BACKTR TRACK
 00024    C     COMMON/CBKPAT/HTRK(100)
 00025    C
 00027  24      DIMENSION HTEMP(9),MAXC(3),HREP(10)                                HREP STORES PARENT TRACK NO TO TRY AGAIN
 00028  25      EQUIVALENCE (RMSLI1,XBKK(33)),(IDLIM,IYBKK(10))
 00029  26      EQUIVALENCE (JJPR,IXBKK(38))
 00030  27      DATA MSKLRL /ZFFFFEFFF/,MAXC/24,24,48/
 00031    C
 00032    C     IPPATR=IDATA(IBLN('PATR'))
 00033  28      CALL SETSL(HREP(1),0,20,0)
 00034  29      RMSLI2=XBKK(34)
 00035  30      IENTER=ICHNG
 00036  31      IF(ICHNG.EQ.99) RMSLI2=0.
 00037    C     LDTRK=IDATA(IPPATR+3)
 00038    C     IPPATR=IDATA(IPPATR+1)+IPPATR
 00039  33      IREM=IXYF(1)
 00040  34      IXYF(1)=9 + 32
 00041  35      ICHNG=0
 00042  36      ILT=0
 00043  37      IRPKNT=0
 00044  38      RMSLIM=RMSLI1
 00045  39      FOR JKREP=1,2
 00046  40         IKXKTR=0
 00047  41         REPEAT
 00049  42            IKXKTR=IKXKTR+1                                              EXTRACT PARENT TRACK NO
 00050  43            KTR=IKXKTR
 00051  44            IF JKREP.EQ.2
 00052  45            THEN
 00054  48               ILT=ILT+1                                                 FOR SECOND PASS TRACK NOS ARE IN HREP
 00055  49               IF ILT.LE.ITREP
 00056  50               THEN
 00057  53                  KTR=HREP(ILT)
 00058  54               ELSE
 00059  56                  XREPEAT
 00060  57               CIF
 00061  58            CIF
 00062  59            IF HNREL(KTR).NE.0
 00063  60            THEN
 00064  63               INUM=HNREL(KTR)
 00065  64               IXX=KTR
 00066  65               PERFORM CELLAN
 00067  68               IF IR1.GT.1.OR.IR2.LT.3
 00068  69               THEN
 00070  72                  IRNG1=IR1                                              RING NO OF INNER MOST TRACKEL
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00072  73                  IRNG2=IR2                                              RING NO OF OUTER MOST TRACKEL
 00073  74                  ICL1=KMP2
 00074  75                  LR1=0
 00076  76                  IF(KMP1.NE.KMP2) LR1=1                                 IF TRACK IS IN MORE THAN ONE CELL FREEZE LR
 00077    C     IF(LAND(JJPR,64).NE.0)WRITE(6,98) KTR,KMP1,KMP2,IR1
 00078    C98   FORMAT('0TRACK NO',I5,' CELL 1  CELL 2',2I5,'   ENDS IN RING',I5)
 00079  78                  RMSOLD=9999.
 00081  79                  FOR JTR=1,100                                          LOOP OVER CAND TRACKS
 00082  80                     IF HNREL(JTR).NE.0.AND.JTR.NE.KTR
 00083  81                     THEN
 00084  84                        IXX=JTR
 00085  85                        PERFORM CELLAN
 00087  88                        IF IR2.LT.IRNG1.OR.KMP1.NE.KMP2.AND.IR2.LE.IRNG1 TRY CONNECTION IF CAND IS IN NEXT RING OR IS IS IN
 00089  89                        THEN                                             SAME RING BUT HAS MORE THAN ONE CELL
 00090  92                           IPTRK=HISTR(1,JTR)
 00091  93                           IPTRK=IABS(IPTRK)
 00092  94                           ISPEC=0
 00093  95                           IF(HNREL(JTR).EQ.1.AND.NRHT(IPTRK).LT.5.AND.IR2.EQ.1) ISPEC=1
 00094                                                                             DUMMY
 00095  97                           IF HNREL(JTR).GT.1.OR.NRHT(IPTRK).GT.0.OR.IR2.GT.1
 00096  98                           THEN
 00097    C     IF(LAND(JJPR,64).NE.0)WRITE(6,99) JTR,KMP1,KMP2,IR2
 00098    C99   FORMAT(' CAND TRACK',I5,' CELL 1 CELL 2',2I5,' BEGINS IN RING',I5)
 00099 101                              ICL2=KMP1
 00100 102                              IF(IRNG1.EQ.3) ICL=(ICL1+1)/2
 00101 104                              IF(IRNG1.EQ.2) ICL=ICL1-24
 00102 106                              IF(IRNG1.EQ.3.AND.IR2.EQ.1) ICL=ICL-24
 00103 108                              IF(IR2.EQ.IRNG1) ICL=ICL1
 00105 110                              IDIF=IABS(ICL-ICL2)                        COMPUTE CELL DIF BETWEEN CAND AND PARENT
 00106 111                              IF IDIF.GT.MAXC(IR2)/2
 00107 112                              THEN
 00108 115                                 IF ICL.GT.ICL2
 00109 116                                 THEN
 00110 119                                    ICL=ICL-MAXC(IR2)
 00111 120                                    IDIF=IABS(ICL-ICL2)
 00112 121                                 ELSE
 00113 123                                    ICL2=ICL2-MAXC(IR2)
 00114 124                                    IDIF=IABS(ICL-ICL2)
 00115 125                                 CIF
 00116 126                              CIF
 00117                                                                             REFUSE SKIP RING CONN FOR LT 8 HITS IN FIRST PASS
 00118 127                              IF(IENTER.EQ.99.AND.IABS(IR2-IRNG1).GT.1.AND.IXBKK(35).EQ.0
 00119                                                                             UNLESS CALL PATROL FLAG IS ON
 00120         %                        .AND.HNREL(JTR).EQ.1.AND.NRHT(IPTRK).LT.8) IDIF=99
 00121 129                              LR2=0
 00122 130                              IF(KMP1.NE.KMP2) LR2=1
 00123    C     IF(LAND(JJPR,64).NE.0)WRITE(6,97) ICL1,ICL,ICL2,IDIF
 00124    C 97  FORMAT(' PAR CELL',I5,'  EX CELL',I5,' CAND CELL',I5,'DIFF',I5)
 00125 132                              IF IDIF.LE.IDLIM
 00126 133                              THEN
 00127 136                                 IAB=HNREL(JTR)
 00128 137                                 CALL MVC(HTEMP(1),0,HISTR(1,KTR),0,18)
 00129    C     IF(LAND(JJPR,64).NE.0)WRITE(6,96) (HISTR(IP,KTR),IP=1,9)
 00130    C96   FORMAT('  ORIG HISTR',9I5)
 00131    C     IF(LAND(JJPR,64).NE.0)WRITE(6,89) (HISTR(IP,JTR),IP=1,9)
 00132    C89   FORMAT('   CAND HISTR  ',9I5)
 00133 138                                 LRP=1
 00134 139                                 LRD=1
 00135 140                                 FOR IKOUNT=1,4
 00136 141                                    IF IKOUNT.GE.2
 00137 142                                    THEN
 00138 145                                    IF(LR1.NE.0.AND.LR2.NE.0) XFOR
 00139 147                                    IF LR1.NE.0.AND.LR2.EQ.0
 00140 148                                    THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00141 151                                    IF IKOUNT.EQ.2
 00142 152                                    THEN
 00143 155                                    LRD=-LRD
 00144 156                                    ELSE
 00145 158                                    XFOR
 00146 159                                    CIF
 00147 160                                    CIF
 00148 161                                    IF LR1.EQ.0.AND.LR2.NE.0
 00149 162                                    THEN
 00150 165                                    IF IKOUNT.EQ.2
 00151 166                                    THEN
 00152 169                                    LRP=-1
 00153 170                                    ELSE
 00154 172                                    XFOR
 00155 173                                    CIF
 00156 174                                    CIF
 00157 175                                    IF LR1.EQ.0.AND.LR2.EQ.0
 00158 176                                    THEN
 00159 179                                    IF(IKOUNT.EQ.2) LRD=-LRD
 00160 181                                    IF(IKOUNT.EQ.3) LRP=-LRP
 00161 183                                    IF(IKOUNT.EQ.4) LRD=-LRD
 00162 185                                    CIF
 00163 186                                    CIF
 00164    C     IF(LAND(JJPR,64).NE.0)WRITE(6,95) LRP,LRD
 00165    C 95  FORMAT('  LR (PARENT) ',I5,'    LR (DAUGHTER)   ',I5)
 00166 187                                    FOR JJ=1,INUM
 00167 188                                    HISTR(JJ,KTR)=HISTR(JJ,KTR)*LRP
 00168 189                                    CFOR
 00169 191                                    PERFORM ADD
 00170    C     IF(LAND(JJPR,64).NE.0)WRITE(6,93) (HISTR(IP,KTR),IP=1,9)
 00171    C93   FORMAT('  NEW HISTR',9I5)
 00172    C     IAB=HNREL(NTR)
 00173    C     IF(IXXB.NE.0) PRINT 37,KX,NTR,(HISTR(IR,NTR),IR=1,IAB)
 00174    C     IF(IXXB.NE.0) PRINT 38,(HTEMP(IR),IR=1,9)
 00175    C37   FORMAT(' KX, NTR,HISTR :',11I5)
 00176    C38   FORMAT(' OLD HISTR :',9I5)
 00177 194                                    IF IEXIT.EQ.99.OR.IEXIT.EQ.98
 00178 195                                    THEN
 00179 198                                    CALL MVC(HISTR(1,KTR),0,HTEMP(1),0,18)
 00180    C     IF(LAND(JJPR,64).NE.0) WRITE(6,78) KTR,JTR
 00181    C78   FORMAT('  *** EXIT TOO MANY ELEMENTS, TRACKS',2I5)
 00182 199                                    XFOR
 00183 200                                    CIF
 00184                                                                             IF CAND AND PARENT OVERLAP IN ONE RING AND HAD NO
 00185 201                                    IF JCOUNT.EQ.INUM+IAB.AND.IR2.EQ.IRNG1
 00187 202                                    THEN                                 TRCAKELS IN COMMON , CHECK NO OF LAYERS BETWEEN BE
 00189 205                                    ML1=INUM                             OF ONE TRACK AND END OF THE OTHER
 00190 206                                    ML1=HISTR(ML1,KTR)
 00191 207                                    ML1=IABS(ML1)
 00192 208                                    ML1=NWR1(ML1)
 00193 209                                    ML2=HISTR(1,JTR)
 00194 210                                    ML2=IABS(ML2)
 00195 211                                    ML2=NWR2(ML2)
 00196 212                                    IF ML2-ML1.GE.IBKK(7)
 00197 213                                    THEN
 00198 216                                    CALL MVC(HISTR(1,KTR),0,HTEMP(1),0,18)
 00199 217                                    IF(LAND(JJPR,64).NE.0) PRINT 295,ML1,ML2
 00200 219 295  FORMAT('   LAYER DIFFERENCE IS TOO LARGE',2I5)
 00201 220                                    XFOR
 00202 221                                    CIF
 00203 222                                    CIF
 00204 223                                    HPOLD=HPFREE
 00205 224                                    CALL FXYZ(KTR)
 00206 225                                    HPTR0=HPFREE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00207 226                                    HPTR9=HPTR0+49
 00208 227                                    HLDTR=50
 00209 228                                    HPFREE=HPTR9+1
 00210 229                                    IF HPFREE.LE.HPLAST
 00211 230                                    THEN
 00212 233                                    CALL XYFIT
 00213 234                                    RMS=WRK(HPTR0+22)
 00214    C     IF(LAND(JJPR,64).NE.0)WRITE(6,92) RMS
 00215    C92   FORMAT('  ******* RMS  *********',F10.5)
 00216                                                                             ON FIRST PASS MARK PARENT TRACKS WHICH HAVE A CONN
 00217 235                                    IF RMS.LT.RMSLI2.AND.RMS.GT.RMSLIM.AND.JKREP.EQ.1.AND.ISPEC.EQ.0
 00218                                                                             ETWEEN RMSLI1 AND RMSLI2
 00219         &                              .AND.(HREP(IRPKNT).NE.KTR.AND.IRPKNT.GT.0.OR.IRPKNT.EQ.0)
 00220         *                              .AND.IENTER.NE.99
 00221 236                                    THEN
 00222 239                                    IF IRPKNT.LT.10
 00223 240                                    THEN
 00224 243                                    IRPKNT=IRPKNT+1
 00225 244                                    HREP(IRPKNT)=KTR
 00226    C     IF(LAND(JJPR,64).NE.0) WRITE(6,843) KTR
 00227    C843  FORMAT('  UNLESS THIS TRACK IS SUCCESSFUL MUST GO AGAINSTARTING
 00228    C     WITH TRACK',I5)
 00229 245                                    CIF
 00230 246                                    CIF
 00231    C     IF RMS.LT.1.8.AND.RMS.GT.RMSLI2.AND.JKREP.EQ.1.AND.IDIF.EQ.0
 00232    C    % .AND.IR2.EQ.IRNG1.AND.(IRNG1.NE.IR1.OR.IRNG2.NE.IR2)
 00233    C     THEN
 00234    C     PRINT 385,(HISTR(IP,KTR),IP=1,9)
 00235    C     PRINT 385,(HISTR(IP,JTR),IP=1,9)
 00236    C385  FORMAT('   ',9I5)
 00237    C     IPTRK1=HTRK(KTR)
 00238    C     PRINT 624,IPTRK1
 00239    C624  FORMAT('   TRACK NO IN TRACK BANK ',I5)
 00240    C     IF(IPTRK1.NE.IDATA(IPPATR+LDTRK*(IPTRK1-1)+1))WRITE(6,765)
 00241    C765  FORMAT(' @@@@@@ ERROR IN TRACK BANK LOCATION')
 00242    C     IPTRK1=IPPATR+LDTRK*(IPTRK1-1)
 00243    C     CRV1=ADATA(IPTRK1+25)
 00244    C     RMS1=ADATA(IPTRK1+23)
 00245    C     IPTRK2=HTRK(JTR)
 00246    C     PRINT 624,IPTRK2
 00247    C     IF(IPTRK2.NE.IDATA(IPPATR+LDTRK*(IPTRK2-1)+1))WRITE(6,765)
 00248    C     IPTRK2=IPPATR+LDTRK*(IPTRK2-1)
 00249    C     CRV2=ADATA(IPTRK2+25)
 00250    C     RMS2=ADATA(IPTRK2+23)
 00251    C     PRINT 913,CRV1,CRV2,RMS1,RMS2
 00252    C913  FORMAT('  CRV   RMS  ',4F10.7)
 00253    C     CIF
 00254                                                                             SKIP RING CONNECTION
 00255 247                                    IF IRNG1.EQ.3.AND.IR2.EQ.1.AND.IXBKK(35).NE.0
 00256         %                              .AND.RMS.LT.RMSLIM.AND.RMS.LT.RMSOLD
 00257 248                                    THEN
 00258 251                                    IPREM1=IGFP(1)
 00259 252                                    IPREM2=IGFP(6)
 00260 253                                    IPREM3=IGFP(9)
 00261 254                                    PREM4=GFP(2)
 00262 255                                    PREM5=GFP(14)
 00263 256                                    IGFP(6)=17
 00264 257                                    IGFP(9)=0
 00265 258                                    GFP(2)=999999.
 00266 259                                    GFP(14)=999999.
 00267 260                                    IGFP(1)=LOR(IGFP(1),1)
 00268 261                                    RMIN=150.
 00269 262                                    RMAX=850.
 00270 263                                    CALL PATROL(RMIN,RMAX)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00271    C     CALL PCWORK(0,0,0,1,0)
 00272 264                                    IFOUND=0
 00273 265                                    FOR ICNT=HPHT0,HPHT9,HLDHT
 00274 266                                    IF(IWRK(ICNT+10).LT.2.AND.IWRK(ICNT+12).EQ.2) IFOUND=IFOUND+1
 00275 268                                    CFOR
 00277    C     WRITE(6,206) IFOUND
 00278    C206  FORMAT('  PATROL FOUND ',I5,'       HITS')
 00279    C     WRITE(6,93) (HISTR(IP,KTR),IP=1,9)
 00280 270                                    IC1=ICL2+24
 00281 271                                    IC2=(ICL1+1)/2
 00282 272                                    NRUN=HRUN
 00284    C     WRITE(6,773) NRUN,RMS
 00285    C773  FORMAT(' RUN ,RMS ',I10,F10.5)
 00286    C     WRITE(6,298) IDIF,ICL,ICL1,ICL2,IC1,IC2
 00287    C298  FORMAT(' IDIF,ICL,ICL1,ICL2,IC1,IC2 ',6I5)
 00288 273                                    NCL1=HNTCEL(IC1+1)-HNTCEL(IC1)
 00289 274                                    NCL2=HNTCEL(IC2+1)-HNTCEL(IC2)
 00292 275                                    IF(IDIF.EQ.0.AND.IFOUND.LT.IYBKK(9).AND..NOT.(DEADCL(IC1,NRUN)
 00293         $                              .AND.NCL1.EQ.0.OR.DEADCL(IC2,NRUN).AND.NCL2.EQ.0)) RMS=99.
 00294    C     IF(IDIF.EQ.0.AND.IFOUND.LT.IYBKK(9).AND.(DEADCL(IC1,NRUN)
 00295    C    $.AND.NCL1.EQ.0.OR.DEADCL(IC2,NRUN).AND.NCL2.EQ.0)) WRITE(6,65)
 00296 277                                    IF(IDIF.EQ.1.AND.IFOUND.LT.IYBKK(16).AND..NOT.(DEADCL(IC1,NRUN)
 00297         $                              .AND.NCL1.EQ.0.OR.DEADCL(IC2,NRUN).AND.NCL2.EQ.0)) RMS=99.
 00298    C     IF(IDIF.EQ.1.AND.IFOUND.LT.IYBKK(16).AND.(DEADCL(IC1,NRUN)
 00299    C    $.AND.NCL1.EQ.0.OR.DEADCL(IC2,NRUN).AND.NCL2.EQ.0)) WRITE(6,65)
 00300    C 65  FORMAT('   &&&&&&&&^^^^^^^^^^^ DIFF')
 00301 279                                    IGFP(1)=IPREM1
 00302 280                                    IGFP(6)=IPREM2
 00303 281                                    IGFP(9)=IPREM3
 00304 282                                    GFP(2)=PREM4
 00305 283                                    GFP(14)=PREM5
 00306 284                                    CIF
 00307 285                                    IF RMS.LT.RMSLIM.AND.RMS.LT.RMSOLD
 00308 286                                    THEN
 00309 289                                    IF ISPEC.EQ.0.OR.ISPEC.EQ.1.AND.RMS.LT.RMSLI1
 00310 290                                    THEN
 00311 293                                    RMSOLD=RMS
 00312 294                                    ITRACK=JTR
 00313 295                                    LRDFIN=LRD
 00314 296                                    LRPFIN=LRP
 00315    C     WRITE(6,91)
 00316    C91   FORMAT('  %%%%%%%% SUCCESS  %%%%%%%%%%%')
 00317 297                                    CIF
 00318 298                                    CIF
 00319 299                                    ELSE
 00320 301                                    PRINT 33,HRUN,HEV,NREC,KTR,JTR
 00321 302 33   FORMAT(' +++++++++  NOT ENOUGH SPACE IN CWORK  +++++++(BAKPAK)',
 00322         &                              5I10)
 00323 303                                    CIF
 00324 304                                    HPFREE=HPOLD
 00325 305                                    CALL MVC(HISTR(1,KTR),0,HTEMP(1),0,18)
 00326 306                                 CFOR
 00327 308                                 HNREL(KTR)=INUM
 00328 309                              CIF
 00329 310                           CIF
 00330 311                        CIF
 00331 312                     CIF
 00332 313                  CFOR
 00333 315                  IF RMSOLD.NE.9999.
 00334 316                  THEN
 00335 319                     FOR JJ=1,INUM
 00336 320                        HISTR(JJ,KTR)=HISTR(JJ,KTR)*LRPFIN
 00337 321                     CFOR
 00339 323                     IF HREP(IRPKNT).EQ.KTR.AND.JKREP.EQ.1               CANCEL NEED TO REPEAT WITH THIS TRACK
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 00340 324                     THEN
 00341 327                        IKXKTR=IKXKTR-1
 00342 328                        HREP(IRPKNT)=0
 00343 329                        IRPKNT=IRPKNT-1
 00344 330                     CIF
 00345 331                     IAB=HNREL(ITRACK)
 00346 332                     JTR=ITRACK
 00347 333                     LRD=LRDFIN
 00348 334                     PERFORM ADD
 00349 337                     FOR IY=1,JCOUNT
 00350 338                        ITC=HISTR(IY,KTR)
 00351 339                        ITC=IABS(ITC)
 00352 340                        LBL(ITC)=LAND(LBL(ITC),MSKLRL)
 00353 341                     CFOR
 00354 343                     IF(IEXIT.EQ.99.OR.IEXIT.EQ.98) WRITE(6,769)
 00355 345 769  FORMAT('  ********* ERROR IN BAKPAK  EXIT ****** ')
 00356 346                     HNREL(ITRACK)=0
 00357 347                     ICHNG=1
 00358    C     IF(LAND(JJPR,64).NE.0)WRITE(6,57) KTR
 00359    C57   FORMAT('     FINAL SELECTION     TRACK',I5)
 00360    C     IF(LAND(JJPR,64).NE.0)WRITE(6,56) RMSOLD,ITRACK,LRPFIN,LRDFIN
 00361    C56   FORMAT('  RMS ',F10.5,'  TRACK ',I5,'  LRP,LRD  ',2I5)
 00362    C     IF(LAND(JJPR,64).NE.0)WRITE(6,55)(HISTR(IP,KTR),IP=1,9),HNREL(KTR)
 00363    C55   FORMAT(' SELECTED HISTR ',9I5,' NO OF ELS',I5)
 00364 348                  CIF
 00365 349               CIF
 00366 350            CIF
 00367 351         UNTIL IKXKTR.GE.100
 00368 352         IF HREP(1).EQ.0
 00369 356         THEN
 00370 359            XFOR
 00371 360         ELSE
 00372 361            ITREP=IRPKNT
 00373 362            RMSLIM=RMSLI2
 00374    C     IF(LAND(JJPR,64).NE.0) WRITE(6,265) ITREP,HREP
 00375    C265  FORMAT('0  START AGAIN &&&&&&&&&&& WITH',I5,'  TRACKS=',10I5)
 00376 363         CIF
 00377 364      CFOR
 00378 366      IXYF(1)=IREM
 00379 367      IBTRK=NTR
 00380 368      NTR=100
 00381    C     CALL TRLORD
 00382 369      NTR=IBTRK
 00383 370      RETURN
 00384 371      PROC CELLAN
 00385 372         IR1=1
 00386 373         IR2=1
 00387 374         KMP1=HISTR(1,IXX)
 00388 375         KMP1=IABS(KMP1)
 00389 376         KMP1=IPCL(KMP1)
 00390 377         KMP2=HISTR(HNREL(IXX),IXX)
 00391 378         KMP2=IABS(KMP2)
 00392 379         KMP2=IPCL(KMP2)
 00393 380         IF(KMP2.GT.24) IR1=2
 00394 382         IF(KMP2.GT.48) IR1=3
 00395 384         IF(KMP1.GT.24) IR2=2
 00396 386         IF(KMP1.GT.48) IR2=3
 00397 388      CPROC
 00398 390      PROC ADD
 00399    C
 00400    C     THIS PROC ADDS TWO BACKTR ARRAYS TOGETHER
 00401    C     DELETING COMMON TRACK ELS
 00402    C
 00403 391         IEXIT=0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 00404 392         JCOUNT=INUM
 00405 393         FOR KK=1,IAB
 00406 394            ISIG=0
 00407 395            ITP2=HISTR(KK,JTR)
 00408 396            ITP2=IABS(ITP2)
 00409 397            FOR IJT=1,INUM
 00410 398               ITP1=HISTR(IJT,KTR)
 00411 399               IF IABS(ITP1).EQ.ITP2
 00412 400               THEN
 00413 403                  ISIG=1
 00414 404                  XFOR
 00415 405               CIF
 00416 406            CFOR
 00417 408            IF ISIG.EQ.0
 00418 409            THEN
 00419 412               JCOUNT=JCOUNT+1
 00420 413               IF JCOUNT.LE.9
 00421 414               THEN
 00422 417                  HISTR(JCOUNT,KTR)=HISTR(KK,JTR)*LRD
 00423 418               ELSE
 00424 420                  IEXIT=99
 00425 421                  XFOR
 00426 422               CIF
 00427 423            CIF
 00428 424         CFOR
 00429    C     IF(LAND(JJPR,64).NE.0.AND.JCOUNT.NE.INUM+IAB)WRITE(6,387)
 00430    C    & JTR,KTR
 00431    C 387 FORMAT('  ********* SOME TRACKELS DELETED IN JOINING TRACKS',2I5)
 00432 426         HNREL(KTR)=JCOUNT
 00433 427         IF JCOUNT.EQ.INUM.OR.JCOUNT.EQ.IAB
 00434 428         THEN
 00435 431            IEXIT=98
 00436    C     IF(LAND(JJPR,64).NE.0) WRITE(6,774)
 00437    C 774 FORMAT('  %%%% PHONY FIT')
 00438 432         CIF
 00439 433      CPROC
 00440 435      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         434 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         434 TARGET STATEMENTS
 00000    C   30/10/79 107101023  MEMBER NAME  BSIDE1   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE BSIDE
 00002    C
 00003    C     BACKTRACING VERSION 5 (MAR 2,79)
 00004    C   THIS PROCEDURE MATCHES AND STORES TRACKS GOING
 00005    C       THROUGH THE CELL SIDEWALLS
 00006    C
 00007   3      IMPLICIT INTEGER*2 (H)
 00008    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         4      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
         5      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
         6      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
         7      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
         8      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
         9      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        10      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  11      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
 00500         +                  RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,
 00510         +                  ZRESOL,ZNORM,ZAL,ZSCAL,DRIDEV,DRICOS,DRISIN,
 00600         +                  PEDES,TZERO(3),DRIROT(96,2),SINDRI(96,2),
 00701         +                  COSDRI(96,2),DRIVEL(96,2),T0FIX(3),
 00800         +                  ABERR(8), DUMJDC(20)
 00900    C
 01100    C      BLOCK DATA SET TO MC VALUES, KALIBR WILL SET REAL DATA VALUES
 01210    C--->  A CHANGE OF THIS COMMON MUST BE DONE SIMULTANEOUSLY WITH  <----
 01220    C--->  A CHANGE OF THE BLOCK DATA                                <----
 01230    C
 01300    C--------------------------- END OF MACRO CJDRCH -----------------------
 01400    C
          C----------------------------------------------------------------------
          C           MACRO CDSMAX .... PATTERN RECOGNITION CONSTANTS.
          C----------------------------------------------------------------------
        12      COMMON/CDSMAX/DSMAX(16,3,2),DIRWR1(24,2),DIRWR3(48,2)
               *             ,DHALF(16,3,2),DTWICE(16,3,2),HMCH(16,3,2)
               *             ,IBCK(9),DBCK(30),TRMATS(96,2),TRMATC(96,2)
          C------------------------ END OF MACRO CDSMAX -------------------------
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        13      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        14      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        15      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        16      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        17      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00000    C   30/10/79 910301050  MEMBER NAME  CWORKMX  (PATRECSR)    FORTRAN
 00100    C   16/09/79 C9092001   MEMBER NAME  CWORKMX  (UKSOR)       FORTRAN
 00200    C ==========MACRO CWORKMG =============================
 00300  18      EQUIVALENCE (ADWRK(291),HUSE(1)),(ADWRK(391),K),
 00400         * (ADWRK(392),ICL),(ADWRK(393),LRING),(ADWRK(394),KRING),
 00500         * (ADWRK(395),LR),(ADWRK(396),IRIFLG),(ADWRK(397),IUDFLG),
 00600         * (ADWRK(398),ILIM),(ADWRK(399),LR1),(ADWRK(400),IRL),
 00700         * (ADWRK(401),ITK(1,1)),(ADWRK(441),DTEMP(1)),
 00800         * (ADWRK(451),IPST),(ADWRK(452),IJFLG),(ADWRK(453),ICX),
 00900         * (ADWRK(454),KT),(ADWRK(455),ISDL),(ADWRK(456),IBFIT),
 01000         * (ADWRK(457),ISP),(ADWRK(458),ISKP(1)),(ADWRK(468),HSP1(1)),
 01100         * (ADWRK(478),ITOL),(ADWRK(479),IW),(ADWRK(480),A),
 01200         * (ADWRK(481),DS),(ADWRK(482),IWT),(ADWRK(483),ICT),
 01300         * (ADWRK(484),IKX),(ADWRK(485),LRCORN)
 01400  19      DIMENSION HUSE(200),DTEMP(10),ITK(10,4),ISKP(10),HSP1(20)
 01500  20      EQUIVALENCE (ILOUT,IBKK(3)),(ILIN,IBKK(4)),
 01600         * (ILBOT,IBKK(8)),(DCELL,BKK(9))
 01700    C ==========ENDMACRO CWORKMG==========================
 00014  21      DIMENSION LSTCL(3),LFTCL(3),NCELL(3),TANDEL(3)
 00015  22      EQUIVALENCE (IBCK(1),LSTCL(1)),(IBCK(4),LFTCL(1))
 00016  23      EQUIVALENCE (IBCK(7),NCELL(1)),(DBCK(1),TANDEL(1))
 00017  24      DATA MSKCR1 /Z100/
 00018    C
 00019    C
 00020  25      LRCORN=0
 00022  26      KT=K                                                               TEMPORARY TRACK NUMBER
 00023  27      IRIFLG=0
 00024  28      IWT=ILIM-1
 00026  29      ICX=ICL                                                            REMEMBER CURRENT CELL
 00027    C     CALL CHKX(58,KT,IWT,ICX)
 00028                                                                             'WHILE' ALLOWS FOR POSSIBILITY OF SEVERAL TRACKS
 00030  30      WHILE IWT.LT.ILIM                                                  IN SUCCESSION PASSING THROUGH SIDEWALL
 00032  32         DS=TRKAR(KT,10-IUDFLG)                                          DRIFT SPACE
 00033  36         IW=ITRKAR(KT,9-IUDFLG)
 00034  37         IKX=0
 00036  38         A=TRKAR(KT,11-IUDFLG)                                           SLOPE
 00037    C     CALL CHKX(27,KT,IW,IW)
 00038    C     CALL CHKX(-27,DS,A,A)
 00039  39         PERFORM PAR
 00040                                                                             TRY A SOLN ON RIGHT SIDE
 00042  42         ICT=ICX+1                                                       GET CELL OF CANDIDATE TRACK
 00043  43         IF(ICT.GT.LSTCL(KRING)) ICT=ICT-NCELL(KRING)
 00044    C     CALL CHKX(57,IPER,ICT,ICX)
 00045    C     CALL CHKX(58,NCELL(1),NCELL(2),NCELL(3))
 00046    C     CALL CHKX(59,LSTCL(1),LSTCL(2),LSTCL(3))
 00047  45         LR1=2
 00048  46         IF IPER.GE.0
 00049  47         THEN
 00050    C     PRINT 6677
 00051    C6677 FORMAT(' TRY A SOLN ON RIGHT SIDE')
 00053  50            IF HNTCEL(ICT+1)-HNTCEL(ICT).GT.0                            TRACKS IN THIS CELL?
 00054  51            THEN
 00055  54               PERFORM SIDCEL
 00056  57               IF LR.EQ.1.OR.IMARK.EQ.0.OR.LR.EQ.0
 00057  58               THEN
 00058  61                  CALL SIDE1
 00059  62               ELSE
 00060  64                  IWT=ILIM
 00061  65               CIF
 00062  66            ELSE
 00063  68               IWT=ILIM
 00064  69            CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00065  70         ELSE
 00066  72            IWT=ILIM
 00067    C     PRINT 589,KT
 00068    C589  FORMAT('  RIGHT SOLN REFUSED FOR TRACK',I5)
 00069  73         CIF
 00071  74         IF IKX.NE.0                                                     A SUCCESSFUL CONNECTION
 00072  75         THEN
 00073  78            IF LR.EQ.-1
 00074  79            THEN
 00076  82               CALL COREC                                                CORRECT STORED TRACK
 00077  83            CIF
 00079  84            LR=-1                                                        SET CORRECT LR FLAG
 00081  85            IWT=HMCH(ITRKAR(IKX,9-IUDFLG)+1,KRING,2)                     RESET IWT
 00082  86            IF(IUDFLG.EQ.6) IWT=-IWT
 00084  88            CALL BSTORE                                                  STORE IT AWAY
 00085  89            IPST=0
 00087  90            LR=1                                                         RESET FOR ANOTHER GO
 00088  91            IJFLG=0
 00089  92         CIF
 00091  93         IF IKX.EQ.0                                                     TRY SOLN FOR LR=-1 (IF NO PREVIOUUS LR=1 SOLN)
 00092  94         THEN
 00094  97            ICT=ICX-1                                                    GET CELL NUMBER OF CANDIDATE TRACK
 00095  98            IF(ICT.LT.LFTCL(KRING)) ICT=ICT+NCELL(KRING)
 00096 100            LR1=1
 00097 101            IF IPER.LE.0
 00098 102            THEN
 00099    C     PRINT 6678
 00100    C6678 FORMAT(' TRY A SOLN ON LEFT SIDE')
 00102 105               IF HNTCEL(ICT+1)-HNTCEL(ICT).GT.0                         TRACKS IN THIS CELL?
 00103 106               THEN
 00104 109                  PERFORM SIDCEL
 00105 112                  IF LR.EQ.-1.OR.IMARK.EQ.0.OR.LR.EQ.0
 00106 113                  THEN
 00107 116                     CALL SIDE1
 00108 117                  ELSE
 00109 119                     IWT=ILIM
 00110 120                  CIF
 00111 121               ELSE
 00112 123                  IWT=ILIM
 00113 124               CIF
 00114 125            ELSE
 00115 127               IWT=ILIM
 00116    C     PRINT 588,KT
 00117    C588  FORMAT('  LEFT SOLN REFUSED FOR TRACK',I5)
 00118 128            CIF
 00120 129            IF IKX.NE.0                                                  A SUCCESSFUL CONNECTION
 00121 130            THEN
 00122 133               IF LR.EQ.0
 00123 134               THEN
 00125 137                  HISTR(1,NTR)=-HISTR(1,NTR)                             CORRECT THE LR FLAG FOR THE FIRST TRACK STORED
 00126 138               CIF
 00127 139               IF LR.EQ.1
 00128 140               THEN
 00130 143                  CALL COREC                                             CORRECT STORED TRACKS
 00131 144               CIF
 00132 145               LR=1
 00134 146               IWT=HMCH(ITRKAR(IKX,9-IUDFLG)+1,KRING,1)                  RESET IWT
 00135 147               IF(IUDFLG.EQ.6) IWT=-IWT
 00137 149               CALL BSTORE                                               STORE THE MATCHING TRACK AWAY
 00138 150               IPST=0
 00139 151               IJFLG=0
 00141 152               LR=-1                                                     ESET FOR ANOTHER GO
 00142 153            CIF
 00143 154         ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00145 156            IWT=ILIM                                                     FAILURE
 00146 157         CIF
 00147 158      CWHILE
 00148 160      RETURN
 00149    C
 00150    C
 00151    C    **********************************************************
 00152    C
 00153    C
 00154 161      PROC SIDCEL
 00155    C
 00156    C     THIS PROC SETS IMARK=1 IF TRACK CROSSES
 00157    C     FROM RING 3 TO 2 OR IF CROSSES CORNER
 00158    C
 00159    C
 00160 162         IMARK=0
 00161 163         KC1=HISTR(1,NTR)
 00162 164         KC1=IPCL(IABS(KC1))
 00163 165         KC2=HISTR(HNREL(NTR),NTR)
 00164 166         KC2=IPCL(IABS(KC2))
 00165    C     CALL CHKX(38,KC1,KC2,KC2)
 00166 167         IF KC1.NE.KC2
 00167 168         THEN
 00168 171            IF KC1.LE.48
 00169 172            THEN
 00170 175               IF(KC1-KC2.NE.24) IMARK=1
 00171 177            ELSE
 00172 179               IMARK=1
 00173 180            CIF
 00174 181         CIF
 00175 182      CPROC
 00176    C
 00177    C     **********************************************************
 00178    C
 00179 184      PROC PAR
 00180    C
 00181    C     THIS PROC DETERMINES WHICH SIDCON FOR TRACK KT IS CONSISTENT
 00182    C     WITH LR FLAG IN MIDOUT
 00183    C     IPER=0   :   BOTH
 00184    C     IPER=1   :   RIGHT
 00185    C     IPER=-1  :   LEFT
 00186    C
 00187 185         IPER=0
 00188 186         IF IBKK(20).NE.0.AND.LR.NE.0.AND.NRHT(KT).GE.IBKK(19)
 00189 187         THEN
 00190 190            IPER=LR
 00191 191            IF(LAND(MSKCR1,LBL(KT)).NE.0.AND.IUDFLG.EQ.3) IPER=-IPER
 00192 193         CIF
 00193 194      CPROC
 00194 196      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         195 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         195 TARGET STATEMENTS
 00000    C   30/10/79 107101030  MEMBER NAME  BSTORE1  (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE BSTORE
 00002    C
 00003    C     THIS SUB STORES FOUND TRACK
 00004    C
 00005   3      IMPLICIT INTEGER*2 (H)
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         4      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
         5      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
         6      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
         7      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
         8      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
         9      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        10      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00000    C   30/10/79 910301050  MEMBER NAME  CWORKMX  (PATRECSR)    FORTRAN
 00100    C   16/09/79 C9092001   MEMBER NAME  CWORKMX  (UKSOR)       FORTRAN
 00200    C ==========MACRO CWORKMG =============================
 00300  11      EQUIVALENCE (ADWRK(291),HUSE(1)),(ADWRK(391),K),
 00400         * (ADWRK(392),ICL),(ADWRK(393),LRING),(ADWRK(394),KRING),
 00500         * (ADWRK(395),LR),(ADWRK(396),IRIFLG),(ADWRK(397),IUDFLG),
 00600         * (ADWRK(398),ILIM),(ADWRK(399),LR1),(ADWRK(400),IRL),
 00700         * (ADWRK(401),ITK(1,1)),(ADWRK(441),DTEMP(1)),
 00800         * (ADWRK(451),IPST),(ADWRK(452),IJFLG),(ADWRK(453),ICX),
 00900         * (ADWRK(454),KT),(ADWRK(455),ISDL),(ADWRK(456),IBFIT),
 01000         * (ADWRK(457),ISP),(ADWRK(458),ISKP(1)),(ADWRK(468),HSP1(1)),
 01100         * (ADWRK(478),ITOL),(ADWRK(479),IW),(ADWRK(480),A),
 01200         * (ADWRK(481),DS),(ADWRK(482),IWT),(ADWRK(483),ICT),
 01300         * (ADWRK(484),IKX),(ADWRK(485),LRCORN)
 01400  12      DIMENSION HUSE(200),DTEMP(10),ITK(10,4),ISKP(10),HSP1(20)
 01500  13      EQUIVALENCE (ILOUT,IBKK(3)),(ILIN,IBKK(4)),
 01600         * (ILBOT,IBKK(8)),(DCELL,BKK(9))
 01700    C ==========ENDMACRO CWORKMG==========================
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        14      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        15      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        16      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        17      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        18      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00009  19      IF(HNREL(NTR).EQ.9) RETURN
 00010  21      HNREL(NTR) = HNREL(NTR) + 1
 00011  22      KR = HNREL(NTR)
 00012  23      HISTR(KR,NTR) = IKX*LR
 00013  24      HUSE(IKX) = 1
 00014  25      RETURN
 00015  26      END
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          25 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 00016   2      FUNCTION SLCOR(SL,LRS)
 00017    C
 00018    C     THIS SUB TRANSFORMS SLOPES BECAUSE OF LORENTZ ANGLE
 00019    C
 00020   3      IMPLICIT INTEGER*2 (H)
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400   4      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
 00500         +                  RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,
 00510         +                  ZRESOL,ZNORM,ZAL,ZSCAL,DRIDEV,DRICOS,DRISIN,
 00600         +                  PEDES,TZERO(3),DRIROT(96,2),SINDRI(96,2),
 00701         +                  COSDRI(96,2),DRIVEL(96,2),T0FIX(3),
 00800         +                  ABERR(8), DUMJDC(20)
 00900    C
 01100    C      BLOCK DATA SET TO MC VALUES, KALIBR WILL SET REAL DATA VALUES
 01210    C--->  A CHANGE OF THIS COMMON MUST BE DONE SIMULTANEOUSLY WITH  <----
 01220    C--->  A CHANGE OF THE BLOCK DATA                                <----
 01230    C
 01300    C--------------------------- END OF MACRO CJDRCH -----------------------
 01400    C
 00022    C     LEFT SOLN
 00023   5      IF(LRS.EQ.-1)SLCOR=DRICOS*SL/(1.+SL*DRISIN)
 00024    C     RIGHT SOLN
 00025   7      IF(LRS.EQ.1) SLCOR=DRICOS*SL/(1.-SL*DRISIN)
 00026   9      RETURN
 00027  10      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS           9 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 00028   2      SUBROUTINE CHOOSE
 00029    C
 00030    C     THIS SUB CHOOSES BEST SOLN WHEN MORE THAN
 00031    C     ONE REMAINS AFTER COMPARING SLOPES AND DRIFT TIME
 00032    C     IT CHOOSES THE SOLN WITH THE BEST QUANTITY
 00033    C     'DTEMP' THAT ALSO HAS TRACK K AS ITS PARENT
 00034    C
 00035   3      IMPLICIT INTEGER*2 (H)
 00000    C   30/10/79 910301050  MEMBER NAME  CWORKMX  (PATRECSR)    FORTRAN
 00100    C   16/09/79 C9092001   MEMBER NAME  CWORKMX  (UKSOR)       FORTRAN
 00200    C ==========MACRO CWORKMG =============================
 00300   4      EQUIVALENCE (ADWRK(291),HUSE(1)),(ADWRK(391),K),
 00400         * (ADWRK(392),ICL),(ADWRK(393),LRING),(ADWRK(394),KRING),
 00500         * (ADWRK(395),LR),(ADWRK(396),IRIFLG),(ADWRK(397),IUDFLG),
 00600         * (ADWRK(398),ILIM),(ADWRK(399),LR1),(ADWRK(400),IRL),
 00700         * (ADWRK(401),ITK(1,1)),(ADWRK(441),DTEMP(1)),
 00800         * (ADWRK(451),IPST),(ADWRK(452),IJFLG),(ADWRK(453),ICX),
 00900         * (ADWRK(454),KT),(ADWRK(455),ISDL),(ADWRK(456),IBFIT),
 01000         * (ADWRK(457),ISP),(ADWRK(458),ISKP(1)),(ADWRK(468),HSP1(1)),
 01100         * (ADWRK(478),ITOL),(ADWRK(479),IW),(ADWRK(480),A),
 01200         * (ADWRK(481),DS),(ADWRK(482),IWT),(ADWRK(483),ICT),
 01300         * (ADWRK(484),IKX),(ADWRK(485),LRCORN)
 01400   5      DIMENSION HUSE(200),DTEMP(10),ITK(10,4),ISKP(10),HSP1(20)
 01500   6      EQUIVALENCE (ILOUT,IBKK(3)),(ILIN,IBKK(4)),
 01600         * (ILBOT,IBKK(8)),(DCELL,BKK(9))
 01700    C ==========ENDMACRO CWORKMG==========================
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
         7      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
         8      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
         9      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        10      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        11      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        12      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        13      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        14      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        15      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        16      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        17      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        18      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00039    C     PRINT 2228,(ITK(I,1),ITK(I,2),ITK(I,3),ITK(I,4),DTEMP(I),I=1,IRL)
 00040    C2228 FORMAT(' MORE THAN ONE SOLN ',4I4,F10.7)
 00042  19      ICHOOS=1                                                           ICHOOS IS A DUMMY VARIABLE FOR THE WHILE LOOP
 00043  20      IT=IRL-1
 00044  21      WHILE ICHOOS.EQ.1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00045  23         FOR I=1,IT
 00047  27            ITMP=I+1                                                     SORT THE ITK ARRAY BASED ON DTEMP
 00048  28            FOR J=ITMP,IRL
 00049  29               IF DTEMP(I).GT.DTEMP(J)
 00050  30               THEN
 00051  33                  TEMP=DTEMP(I)
 00052  34                  DTEMP(I)=DTEMP(J)
 00053  35                  DTEMP(J)=TEMP
 00054  36                  FOR JK=1,4
 00055  37                     TEMP=ITK(I,JK)
 00056  38                     ITK(I,JK)=ITK(J,JK)
 00057  39                     ITK(J,JK)=TEMP
 00058  40                  CFOR
 00059  42               CIF
 00060  43            CFOR
 00061  45         CFOR
 00063  47         IP=ITK(1,4)                                                     PARENT TRACK EL NO. FOR BEST SOLUTION
 00065  48         IC=ITK(1,1)                                                     CANDIDATE TRACK EL NO. FOR BEST SOLUTION
 00066  49         IF DTEMP(1).NE.100.
 00067  50         THEN
 00069  53            IF IP.NE.K                                                   DOES THE BEST CHOICE HAVE K AS PARENT
 00071  54            THEN                                                         NO, THEN CANCEL ALL TRACKS HAVING THIS
 00073  57               FOR J=1,IRL                                               PARENT OR THIS CANDIDATE
 00074  58                  IF DTEMP(J).NE.100.
 00075  59                  THEN
 00076  62                     IF(ITK(J,4).EQ.IP.OR.ITK(J,1).EQ.IC) DTEMP(J)=100.
 00077  64                  CIF
 00078  65               CFOR
 00079  67            ELSE
 00081  69               XWHILE                                                    SUCCESS
 00082  70            CIF
 00083  71         ELSE
 00085  73            XWHILE                                                       FAILURE
 00086  74         CIF
 00087  75      CWHILE
 00088  77      IF DTEMP(1).NE.100.
 00089  78      THEN
 00091  81         ITWO=2                                                          DUMMY STATEMENTS
 00092  82         ITHREE=ITWO+1
 00094    C     PRINT 2230,ITK(1,1),ITK(1,2),ITK(1,3),ITK(1,4)                     SUCCESS
 00095    C2230 FORMAT(' CHOOSE TRACK ',I4,' LR(PARENT)',I4,' LR(CANDIDATE)',
 00096    C    * I4,' PARENT TRACK',I4)
 00097  83      ELSE
 00099  85         IRIFLG=0                                                        FAILURE
 00100    C     PRINT 6543
 00101    C6543 FORMAT (' REJECT THE BEST CHOICE FOR THIS TRACK')
 00102  86      CIF
 00103  87      RETURN
 00104  88      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          87 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 00105   2      SUBROUTINE INTJN1(KK,KX,INTFLG,DTMP)
 00106    C
 00107    C     THIS SUB JOINS TWO TRACK ELS IN ONE CELL
 00108    C     PARENT(OR THE TRACK EL IN THE UPPER PART OF THE CELL)
 00109    C     IS KK, CANDIDATE(OR THE TRACK EL IN THE LOWER PART
 00110    C     OF THE CELL) IS KX,IW IS NWR1(KK),INTFLG IS RETURNED=1
 00111    C     FOR SUCCESS AND 0 FOR FAILURE,DTMP RETURNS A QUANTITY
 00112    C     PROPORTIONAL TO THE QUALITY OF THE JOIN.
 00113    C
 00114   3      IMPLICIT INTEGER*2 (H)
 00115    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
         4      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
         5      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
         6      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
         7      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
         8      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         9      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        10      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        11      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        12      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        13      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        14      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        15      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00000    C   30/10/79 910301050  MEMBER NAME  CWORKMX  (PATRECSR)    FORTRAN
 00100    C   16/09/79 C9092001   MEMBER NAME  CWORKMX  (UKSOR)       FORTRAN
 00200    C ==========MACRO CWORKMG =============================
 00300  16      EQUIVALENCE (ADWRK(291),HUSE(1)),(ADWRK(391),K),
 00400         * (ADWRK(392),ICL),(ADWRK(393),LRING),(ADWRK(394),KRING),
 00500         * (ADWRK(395),LR),(ADWRK(396),IRIFLG),(ADWRK(397),IUDFLG),
 00600         * (ADWRK(398),ILIM),(ADWRK(399),LR1),(ADWRK(400),IRL),
 00700         * (ADWRK(401),ITK(1,1)),(ADWRK(441),DTEMP(1)),
 00800         * (ADWRK(451),IPST),(ADWRK(452),IJFLG),(ADWRK(453),ICX),
 00900         * (ADWRK(454),KT),(ADWRK(455),ISDL),(ADWRK(456),IBFIT),
 01000         * (ADWRK(457),ISP),(ADWRK(458),ISKP(1)),(ADWRK(468),HSP1(1)),
 01100         * (ADWRK(478),ITOL),(ADWRK(479),IW),(ADWRK(480),A),
 01200         * (ADWRK(481),DS),(ADWRK(482),IWT),(ADWRK(483),ICT),
 01300         * (ADWRK(484),IKX),(ADWRK(485),LRCORN)
 01400  17      DIMENSION HUSE(200),DTEMP(10),ITK(10,4),ISKP(10),HSP1(20)
 01500  18      EQUIVALENCE (ILOUT,IBKK(3)),(ILIN,IBKK(4)),
 01600         * (ILBOT,IBKK(8)),(DCELL,BKK(9))
 01700    C ==========ENDMACRO CWORKMG==========================
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  19      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
 00500         +                  RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,
 00510         +                  ZRESOL,ZNORM,ZAL,ZSCAL,DRIDEV,DRICOS,DRISIN,
 00600         +                  PEDES,TZERO(3),DRIROT(96,2),SINDRI(96,2),
 00701         +                  COSDRI(96,2),DRIVEL(96,2),T0FIX(3),
 00800         +                  ABERR(8), DUMJDC(20)
 00900    C
 01100    C      BLOCK DATA SET TO MC VALUES, KALIBR WILL SET REAL DATA VALUES
 01210    C--->  A CHANGE OF THIS COMMON MUST BE DONE SIMULTANEOUSLY WITH  <----
 01220    C--->  A CHANGE OF THE BLOCK DATA                                <----
 01230    C
 01300    C--------------------------- END OF MACRO CJDRCH -----------------------
 01400    C
 00120    C
 00121  20      DIMENSION HTEMP(9)
 00122  21      DATA MSKCR1 /Z100/,MSKFIT/Z20000/,MSKAIT/ZFFFDFFFF/
 00123  22      MAMB=0
 00124  23      IF(NRHT(KK).GE.IBKK(19).AND.NRHT(KX).GE.IBKK(19)
 00125         & .AND.IBKK(20).NE.0) MAMB=1
 00126  25      INTFLG=0
 00127  26      IWX=ITRKAR(KX,6)
 00128  27      IOL=IBKK(1)-1
 00129  28      IGAP=IBKK(2)+1
 00131  29      IF IWX.LE.IW+IOL.AND.IWX.GE.IW-IGAP                                MATCHING OF FIRST AND LAST WIRES HIT
 00132  30      THEN
 00133  33         ICROSS=1
 00134  34         SLA=SL1(KK)/RINCR(KRING)
 00135  35         SLB=SL2(KX)/RINCR(KRING)
 00136  36         JT=IKX
 00137  37         IKX=KX
 00138  38         CALL LFRT(LRA)
 00139  39         IKX=KK
 00140  40         CALL LFRT(LR2)
 00141  41         IKX=JT
 00142  42         IF(IUDFLG.EQ.3.AND.LR.NE.0.AND.LRA.EQ.0) LRA=LR
 00143  44         IF(IUDFLG.EQ.6.AND.LR.NE.0.AND.LR2.EQ.0) LR2=LR
 00144  46         IDIW=IW-IWX
 00145  47         IF(IDIW.LT.0) IDIW=0
 00146  49         IF MAMB.NE.0.AND.LAND(MSKCR1,LBL(KK)).EQ.0.AND.
 00147               LAND(MSKCR1,LBL(KX)).EQ.0
 00148  50         THEN
 00149  53            IF(LRA.NE.LR2) ICROSS=-1
 00150  55            IF(LRA.EQ.0.OR.LR2.EQ.0) ICROSS=0
 00151    C     PRINT 289,KK,KX
 00152    C289  FORMAT(' OPP SIDES OF THE WIRE PLANE FOR TRACKS',2I5)
 00153  57         CIF
 00154  58         DSEX=TRKAR(KK,4)-SL1(KK)*IDIW
 00155  59         DX=DSEX-TRKAR(KX,7)
 00156  60         IF MAMB.EQ.0.OR.ICROSS.EQ.0
 00157  61         THEN
 00158  64            IF(SL2(KX).LT.0..AND.SL1(KK).GT.0..AND.LAND(LBL(KK),MSKCR1).EQ.0
 00159         *      .AND.LAND(LBL(KX),MSKCR1).EQ.0.AND.(DS1(KK).LT.BKK(5)
 00160               .OR.DS2(KX).LT.BKK(5))) ICROSS=-1
 00161  66         CIF
 00162  67         IF ICROSS.EQ.-1
 00163  68         THEN
 00164  71            SLA=-SLA
 00165  72            DX=TRKAR(KX,7)+DSEX
 00166  73         CIF
 00167  74         IF LAND(LBL(KK),MSKCR1).NE.0.AND.LAND(LBL(KX),MSKCR1).NE.0
 00168  75         THEN
 00169  78            DX=TRKAR(KX,7)+DSEX
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00171  79            SLA=-SLA                                                     OPPOSITE SIDES OF THE WIRE PLANE
 00172    C      CALL CHKX(-88,SLA,DSEX,DX)
 00173  80            IF(MAMB.NE.0.AND.LRA*LR2.LT.0) DX=1000000.
 00174  82         CIF
 00175  83         IF(ICROSS.EQ.0) ICROSS=1
 00176  85         IF(LAND(MSKCR1,LBL(KK)).EQ.0.AND.LAND(MSKCR1,LBL(KX)).NE.0
 00177         &   .AND.LRA*LR2.GT.0.AND.MAMB.NE.0) DX=10000000.
 00178  87         IF(LAND(MSKCR1,LBL(KX)).EQ.0.AND.LAND(MSKCR1,LBL(KK)).NE.0
 00179         &   .AND.LRA*LR2.LT.0.AND.MAMB.NE.0) DX=10000000.
 00181  89         IF ABS(DX).LT.DCELL                                             ARE DRIFT SPACES SIMILAR?
 00182  90         THEN
 00183    C     PRINT 6378,KK,KX,IWX,IW,DX
 00184    C6378 FORMAT(' JOIN TWO TKELS',2I4,' WIRE NOS. ',2I4,'  DX=',F7.3)
 00186  93            SLOLIM=(ABS(SLA)+ABS(SLB))/2.*BKK(14)+BKK(15)                SET UP SLOPE LIMIT
 00188  94            DTMP=ABS(SLA-SLB)                                            COMPARE SLOPES
 00189    C     PRINT 211,DTMP,SLOLIM
 00190    C 211 FORMAT(' SLOPE (CAND.-PARENT)',F10.5,'SLOLIM',F10.5)
 00192  95            IF DTMP.LT.SLOLIM                                            SUCCESS
 00193  96            THEN
 00194  99               IB=0
 00195 100               IF IBKK(16).NE.0.AND.IBFIT.EQ.0
 00196 101               THEN
 00197 104                  PERFORM INTFIT
 00198 107               CIF
 00199 108               IF IB.EQ.0
 00200 109               THEN
 00201 112                  INTFLG=ICROSS
 00202 113                  DTMP=ABS(DTMP*DX)
 00203 114               CIF
 00204 115            CIF
 00205 116            KMP1=HISTR(1,NTR)
 00206 117            KMP1=IABS(KMP1)
 00207 118            KMP1=IPCL(KMP1)
 00208 119            IF(KMP1.EQ.IPCL(KX).AND.IBKK(20).NE.0.AND.MAMB.EQ.0) IJFLG=1
 00209 121         CIF
 00210 122      CIF
 00211 123      RETURN
 00212    C
 00213    C     *********************************************
 00214    C
 00215 124      PROC INTFIT
 00216    C
 00217    C
 00218    C
 00219 125         IB=0
 00220 126         IF HNREL(NTR).LT.9
 00221 127         THEN
 00222 130            CALL MVC(HTEMP(1),0,HISTR(1,NTR),0,18)
 00223 131            IKST=IPST
 00224 132            IKFLG=IJFLG
 00225 133            IBJ=IKX
 00226 134            IKX=KX
 00227 135            LR3=1
 00228 136            IF(ICROSS.EQ.-1.OR.(LAND(LBL(KX),MSKCR1).NE.0.AND.
 00229         &      LAND(LBL(KK),MSKCR1).EQ.0)) LR3=-1
 00230 138            PERFORM INCRSS
 00231 141            HNREL(NTR)=HNREL(NTR)+1
 00232 142            LRC=LR2
 00233 143            HISTR(HNREL(NTR),NTR)=LRC*KX
 00234    C     LBL(KX)=LOR(LBL(KX),MSKFIT)
 00235 144            CALL BAKFIT(IB,1)
 00236    C     IF(IB.NE.0) PRINT 36
 00237    C36   FORMAT('   INTJ  FIT    ')
 00238 145            IAB=HNREL(NTR)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00239    C     IF(IB.NE.0) PRINT 37,KX,NTR,(HISTR(IR,NTR),IR=1,IAB)
 00240    C     IF(IB.NE.0) PRINT 38,(HTEMP(IR),IR=1,9)
 00241    C37   FORMAT(' KX, NTR,HISTR :',11I5)
 00242    C38   FORMAT(' OLD HISTR :',9I5)
 00243 146            HNREL(NTR)=HNREL(NTR)-1
 00244    C     LBL(KX)=LAND(LBL(KX),MSKAIT)
 00245 147            CALL MVC(HISTR(1,NTR),0,HTEMP(1),0,18)
 00246 148            IKX=IBJ
 00247 149            IJFLG=IKFLG
 00248 150            IPST=IKST
 00249 151         CIF
 00250 152      CPROC
 00251 154      PROC INCRSS
 00252    C
 00253    C     THIS PROC DETERMINES WHETHER CANDIDATE AND PARENT HAVE
 00254    C     DIFFERENT AMBIGUITY
 00255    C
 00256 155         CALL LFRT(LR2)
 00258 156         IF LR2.EQ.0                                                     DETERMINE LR OF CANDIDATE AND STORE IN LR2
 00259 157         THEN
 00260 160            IF LR.NE.0
 00261 161            THEN
 00262 164               LR2=LR*LR3
 00263 165            ELSE
 00264 167               LR2=LR3
 00265 168               IJFLG=1
 00266 169               IPST=1
 00267 170            CIF
 00268 171         ELSE
 00269 173            IF LR.EQ.0
 00270 174            THEN
 00271 177               IF(LR2*LR3.EQ.-1) HISTR(1,NTR)=-HISTR(1,NTR)
 00272 179            ELSE
 00273 181               IF LR2.NE.LR*LR3
 00274 182               THEN
 00275    C     IF(IJFLG.EQ.1) CALL COREC
 00276    C     IF(HNREL(NTR).EQ.1) HISTR(1,NTR)=-HISTR(1,NTR)
 00277 185                  LR2=-LR2
 00278 186               CIF
 00279 187            CIF
 00280 188         CIF
 00281 189      CPROC
 00282 191      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         190 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 00283   2      SUBROUTINE COREC
 00284    C
 00285    C     THIS SUB CORRECTS L-R AMBIGUITY OF PREVIOUSLY
 00286    C     STORED TRACKS WHEN THEY HAVE BEEN STORED AWAY WITH AN
 00287    C     ARBITRARILY SET AMBIGUITY(IJFLG=1) AND A TEST OF
 00288    C     THE AMBIGUITY FROM WIRE STAGGERING INDICATES
 00289    C     A DISCREPANCY
 00290    C
 00291   3      IMPLICIT INTEGER*2 (H)
 00000    C   30/10/79 910301050  MEMBER NAME  CWORKMX  (PATRECSR)    FORTRAN
 00100    C   16/09/79 C9092001   MEMBER NAME  CWORKMX  (UKSOR)       FORTRAN
 00200    C ==========MACRO CWORKMG =============================
 00300   4      EQUIVALENCE (ADWRK(291),HUSE(1)),(ADWRK(391),K),
 00400         * (ADWRK(392),ICL),(ADWRK(393),LRING),(ADWRK(394),KRING),
 00500         * (ADWRK(395),LR),(ADWRK(396),IRIFLG),(ADWRK(397),IUDFLG),
 00600         * (ADWRK(398),ILIM),(ADWRK(399),LR1),(ADWRK(400),IRL),
 00700         * (ADWRK(401),ITK(1,1)),(ADWRK(441),DTEMP(1)),
 00800         * (ADWRK(451),IPST),(ADWRK(452),IJFLG),(ADWRK(453),ICX),
 00900         * (ADWRK(454),KT),(ADWRK(455),ISDL),(ADWRK(456),IBFIT),
 01000         * (ADWRK(457),ISP),(ADWRK(458),ISKP(1)),(ADWRK(468),HSP1(1)),
 01100         * (ADWRK(478),ITOL),(ADWRK(479),IW),(ADWRK(480),A),
 01200         * (ADWRK(481),DS),(ADWRK(482),IWT),(ADWRK(483),ICT),
 01300         * (ADWRK(484),IKX),(ADWRK(485),LRCORN)
 01400   5      DIMENSION HUSE(200),DTEMP(10),ITK(10,4),ISKP(10),HSP1(20)
 01500   6      EQUIVALENCE (ILOUT,IBKK(3)),(ILIN,IBKK(4)),
 01600         * (ILBOT,IBKK(8)),(DCELL,BKK(9))
 01700    C ==========ENDMACRO CWORKMG==========================
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
         7      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
         8      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
         9      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        10      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        11      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        12      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        13      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        14      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        15      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        16      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        17      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        18      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00295  19      ITMP=HNREL(NTR)
 00296  20      FOR I=1,ITMP
 00297  21         HISTR(I,NTR)=-HISTR(I,NTR)
 00298  22      CFOR
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00299  24      IJFLG=0
 00300    C     PRINT 666
 00301    C666  FORMAT('  COREC================')
 00302  25      RETURN
 00303  26      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          25 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 00304   2      SUBROUTINE SIDE1
 00305    C
 00306    C     THIS SUB PRESETS CERTAIN QUANTITIES FOR
 00307    C     THE PROC SIDCN1 WHERE THE CONNECTION ACROSS
 00308    C     CELL SIDEWALLS IS ATTEMPTED
 00309    C
 00310   3      IMPLICIT INTEGER*2 (H)
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         4      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
         5      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
         6      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
         7      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
         8      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
         9      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        10      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00000    C   30/10/79 910301050  MEMBER NAME  CWORKMX  (PATRECSR)    FORTRAN
 00100    C   16/09/79 C9092001   MEMBER NAME  CWORKMX  (UKSOR)       FORTRAN
 00200    C ==========MACRO CWORKMG =============================
 00300  11      EQUIVALENCE (ADWRK(291),HUSE(1)),(ADWRK(391),K),
 00400         * (ADWRK(392),ICL),(ADWRK(393),LRING),(ADWRK(394),KRING),
 00500         * (ADWRK(395),LR),(ADWRK(396),IRIFLG),(ADWRK(397),IUDFLG),
 00600         * (ADWRK(398),ILIM),(ADWRK(399),LR1),(ADWRK(400),IRL),
 00700         * (ADWRK(401),ITK(1,1)),(ADWRK(441),DTEMP(1)),
 00800         * (ADWRK(451),IPST),(ADWRK(452),IJFLG),(ADWRK(453),ICX),
 00900         * (ADWRK(454),KT),(ADWRK(455),ISDL),(ADWRK(456),IBFIT),
 01000         * (ADWRK(457),ISP),(ADWRK(458),ISKP(1)),(ADWRK(468),HSP1(1)),
 01100         * (ADWRK(478),ITOL),(ADWRK(479),IW),(ADWRK(480),A),
 01200         * (ADWRK(481),DS),(ADWRK(482),IWT),(ADWRK(483),ICT),
 01300         * (ADWRK(484),IKX),(ADWRK(485),LRCORN)
 01400  12      DIMENSION HUSE(200),DTEMP(10),ITK(10,4),ISKP(10),HSP1(20)
 01500  13      EQUIVALENCE (ILOUT,IBKK(3)),(ILIN,IBKK(4)),
 01600         * (ILBOT,IBKK(8)),(DCELL,BKK(9))
 01700    C ==========ENDMACRO CWORKMG==========================
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        14      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        15      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        16      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        17      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        18      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
          C----------------------------------------------------------------------
          C           MACRO CDSMAX .... PATTERN RECOGNITION CONSTANTS.
          C----------------------------------------------------------------------
        19      COMMON/CDSMAX/DSMAX(16,3,2),DIRWR1(24,2),DIRWR3(48,2)
               *             ,DHALF(16,3,2),DTWICE(16,3,2),HMCH(16,3,2)
               *             ,IBCK(9),DBCK(30),TRMATS(96,2),TRMATC(96,2)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
          C------------------------ END OF MACRO CDSMAX -------------------------
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  20      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
 00500         +                  RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,
 00510         +                  ZRESOL,ZNORM,ZAL,ZSCAL,DRIDEV,DRICOS,DRISIN,
 00600         +                  PEDES,TZERO(3),DRIROT(96,2),SINDRI(96,2),
 00701         +                  COSDRI(96,2),DRIVEL(96,2),T0FIX(3),
 00800         +                  ABERR(8), DUMJDC(20)
 00900    C
 01100    C      BLOCK DATA SET TO MC VALUES, KALIBR WILL SET REAL DATA VALUES
 01210    C--->  A CHANGE OF THIS COMMON MUST BE DONE SIMULTANEOUSLY WITH  <----
 01220    C--->  A CHANGE OF THE BLOCK DATA                                <----
 01230    C
 01300    C--------------------------- END OF MACRO CJDRCH -----------------------
 01400    C
 00316  21      DIMENSION LSTCL(3),LFTCL(3),NCELL(3),TANDEL(3)
 00317  22      EQUIVALENCE (IBCK(1),LSTCL(1)),(IBCK(4),LFTCL(1))
 00318  23      EQUIVALENCE (IBCK(7),NCELL(1)),(DBCK(1),TANDEL(1))
 00319  24      DIMENSION HTEMP(9)
 00320  25      DATA MSKCR1 /Z100/,MSKFIT/Z20000/,MSKAIT/ZFFFDFFFF/
 00322  26      IIWW=IW+1                                                          IIWW IS THE FIRST WIRE THAT IS NOT HIT
 00323  27      IF(IIWW.GT.16) IIWW=16
 00324  29      IF(IIWW.LT.1) IIWW=1
 00326  31      BSL=A                                                              DSMX IS THE MAX DRIFT SPACE FOR THIS WIRE,CELL,AMB
 00328  32      IF(IUDFLG.EQ.6) BSL=-BSL                                           CHECK IF DRIFT SPACE IS MAX
 00329  34      DRIFT=DS+.5*BSL
 00330  35      IRT=LR1
 00331  36      IM1=6
 00332  37      IM2=3
 00333  38      PERFORM SIDCX
 00334  41      IWEX=HMCH(IIWW,KRING,LR1)+1
 00335  42      IF(IWEX.GT.16) IWEX=16
 00336  44      IF(IWEX.LT.1) IWEX=1
 00337    C     CALL CHKX(70,IIWW,IIWW,IWEX)
 00338    C     CALL CHKX(-70,DTMP,DTMP,DTMP)
 00339    C     ELSE
 00340    C     DTMP=100.
 00341    C     PRINT 6654,SLWALL,BSL
 00342    C6654 FORMAT(' WRONG SLOPE FOR SIDCON  ',2F10.5)
 00343    C     CIF
 00344  46      IF DTMP.LT.2.*CLIM.OR.DTMP.LT.2.
 00345  47      THEN
 00346    C     PRINT 2216,DS,A,DSMX,DTMP
 00347    C2216 FORMAT(' CELSID   DS=',F7.3,'A=',F7.3,'DSMX=',F7.3,'DIFF=',F7.3)
 00348    C     PRINT 2218
 00349    C2218 FORMAT(' CELSID   SUCCEEDS')
 00351  50         PERFORM SIDCN1                                                  TRY A SIDE CONNECTION
 00353  53         IF IKX.GT.0                                                     IS IT SUCCESSFUL?
 00354  54         THEN
 00355  57            IF LRCORN.EQ.0
 00356  58            THEN
 00358  61               ICX=ICT                                                   RESET THINGS FOR ANOTHER GO
 00359  62               IRIFLG=1
 00360  63               KT=IKX
 00361  64            CIF
 00363  65         ELSE                                                            FAILURE
 00364  67            IWT=ILIM
 00365  68         CIF
 00366  69      ELSE
 00367    C     PRINT 2217
 00368    C2217 FORMAT(' CELSID   FAILS')
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00369  71         IWT=ILIM
 00370  72      CIF
 00371  73      RETURN
 00372    C
 00373    C   *************************************************************
 00374    C
 00375  74      PROC SIDCN1
 00376    C
 00377    C  THIS PROC FINDS A MATCH THROUGH SIDEWALL OF ONE RING
 00378    C
 00380  75         IKX=0                                                           IKX WILL CONTAIN MATHING TRACK NO. IF SUCCESSFUL
 00381  76         ICNFLG=0
 00383  77         IF(LRCORN.EQ.0) IRL=0                                           PRESET COUNTERS IN CASE MORE THAN ONE SOLN IS FOUN
 00385  79         NTRLX1 = HNTCEL(ICT)                                            TRACK ELEMENTS IN NEIGHBOR CELL ?
 00386  80         NTRLX2 = HNTCEL(ICT+1)-1
 00387    C     PRINT 2219,ICT,NTRLX1,NTRLX2
 00388    C2219 FORMAT(' TRY SIDCON     CELL=',I4,' TRACKS=',2I4)
 00389                                                                             EXPECTED WIRE NO. IN NEIGHBOUR CELL DEPENDS ON L-R
 00390                                                                             ADD 1 OR SUBTRACT 1 TO EXPECTED WIRE NO.
 00391                                                                             DEPENDING ON WHETHER TRACK IS GOING OUT OR IN
 00393  81         FOR KX = NTRLX1,NTRLX2                                          LOOP TRACK ELEMENTS IN NEIGHBOR CELL
 00395  82            IF HUSE(KX).EQ.0                                             CHECK THAT IT HASN'T BEEN USED YET
 00396  83            THEN
 00397  86               IPER=0
 00398  87               IF IBKK(20).NE.0.AND.NRHT(KX).GE.IBKK(19)
 00399  88               THEN
 00400  91                  JT=IKX
 00401  92                  IKX=KX
 00402  93                  CALL LFRT(LK)
 00403  94                  IKX=JT
 00404  95                  IF(LAND(MSKCR1,LBL(KX)).NE.0.AND.IUDFLG.EQ.6) LK=-LK
 00405  97                  IF(LK.NE.3-2*LR1) IPER=1
 00406  99                  IF(LK.EQ.0) IPER=0
 00407 101               CIF
 00408 102               IF IPER.EQ.0
 00409 103               THEN
 00411 106                  IIWW= ITRKAR(KX,IUDFLG)+1                              WIRE NO. OF CANDIDATE TRACK
 00412 107                  IF(IIWW.GT.16) IIWW=16
 00413 109                  IF(IIWW.LT.1) IIWW=1
 00415 111                  BSL=TRKAR(KX,IUDFLG+2)                                 DSMX IS THE MAX DRIFT SPACE FOR THIS WIRE,CELL,AMB
 00417 112                  IF(IUDFLG.EQ.3) BSL=-BSL                               CHECK IF DRIFT SPACE IS MAX
 00418 114                  DRIFT=TRKAR(KX,IUDFLG+1)+.5*BSL
 00419 115                  IRT=3-LR1
 00420 116                  IM1=3
 00421 117                  IM2=6
 00422 118                  PERFORM SIDCX
 00423 121                  IWX=IIWW
 00424    C     CALL CHKX(70,IIWW,IWX,IWEX)
 00425    C     PRINT 2220,DTMP,IWEX,IWX
 00426    C2220 FORMAT(' DSX-DSMAX=',F7.3,'EXPECTED WIRE=',I4,' ACTUAL WIRE=',I4)
 00428    C     ELSE                                                               DOES CANDIDATE TRACK HAVE A MAX DRIFT SPACE?
 00429    C     DTMP=100.
 00430    C     PRINT 6654,SLWALL,BSL
 00431    C     CIF
 00432 122                  IF DTMP.LT.2.*CLIM.OR.DTMP.LT.2.
 00434 123                  THEN                                                   COMPARE SLOPES
 00435 126                     IF IABS(IWX-IWEX).LE.IBKK(6)-1
 00436 127                     THEN
 00437    C
 00438    C     THIS PROC CALCULATES SLOPE OF PARENT TRACK
 00439    C     IN THE CANDIDATE TRACKS CELL
 00440 130                        LRS=2*LR1-3
 00441 131                        SLB=A/RINCR(KRING)
 00443 132                        SL=SLCOR(SLB,LRS)                                COMPENSATE FOR LORENTZ ANGLE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00445 133                        T=TANDEL(KRING)                                  ROTATE TO NEIGHBOUR CELL CO-ORDINATE SYSTEM
 00447 134                        SLEX=(T-SL)/(1.+SL*T)                            EXPECTED SLOPE
 00448    C     CALL CHKX(-62,SL,T,SLEX)
 00449 135                        LRS=-LRS
 00451 136                        SLE=TRKAR(KX,IUDFLG+2)/RINCR(KRING)              GET CANDIDATE SLOPE
 00453 137                        SLC=SLCOR(SLE,LRS)                               COMPENSATE LORENTZ ANGLE
 00454    C     CALL CHKX(-63,SLE,SLC,SLC)
 00456    C     SLOLIM=ABS(SLEX)*FACTSL+CONSL                                      TOLERANCE ON SLOPE MATCHING
 00457    C     IF(SLOLIM.LE..1) SLOLIM=.045
 00458    C     IF(SLOLIM.GT..1) SLOLIM=.5
 00459 138                        SLOLIM=(ABS(SLE)+ABS(SLB))/2.*BKK(12)+BKK(13)
 00460 139                        DTMP=SLEX-SLC
 00461    C     PRINT 2229,KX,DTMP,SLOLIM
 00462    C2229 FORMAT(' COMP SLOPES, TRACK=',I4,' SLEX-SL ',F7.3,' SLOLIM',F7.3)
 00463 140                        IF ABS(DTMP).LT.SLOLIM
 00465 141                        THEN                                             SUCCESS SO STORE IT AWAY
 00466 144                           IF LRCORN.NE.0
 00467 145                           THEN
 00468 148                              IKX=KX
 00469    C     PRINT 2221,IKX
 00470 149                              XFOR
 00471 150                           CIF
 00472 151                           IB=0
 00473 152                           IF IBKK(17).NE.0.AND.IBFIT.EQ.0
 00474 153                           THEN
 00475 156                              PERFORM SIDFIT
 00476 159                           CIF
 00477 160                           IF IB.EQ.0
 00478 161                           THEN
 00479 164                              IRL=IRL+1
 00480 165                              DTEMP(IRL)=ABS(DTMP)
 00481 166                              ITK(IRL,1)=KX
 00482 167                              ITK(IRL,4)=KT
 00483 168                              ICNFLG=1
 00484 169                           ELSE
 00486 171                              ICNFLG=0                                   FAILURE
 00487 172                           CIF
 00488 173                        ELSE
 00490 175                           ICNFLG=0                                      FAILURE
 00491 176                        CIF
 00492 177                        IF(IRL.GT.0.AND.LRCORN.EQ.0) ICNFLG=1
 00493 179                     CIF
 00494 180                  CIF
 00495 181               ELSE
 00496    C     PRINT 59,KX
 00497    C59   FORMAT('   TRACK',I5,'   REFUSED AS CAND IN SIDCON')
 00498 183               CIF
 00499 184            CIF
 00500 185         CFOR
 00502 187         IF ICNFLG.EQ.1                                                  HAVE WE AT LEAST ONE MATCH?
 00503 188         THEN
 00505 191            IF IRL.GT.1                                                  IF MORE THAN ONE THEN WE MUST CHOOSE WHICH TO TAKE
 00506 192            THEN
 00507 195               CALL CHOOSE
 00508 196            CIF
 00510 197            IKX=ITK(1,1)                                                 PUT AWAY THE MATCHING TRACK NUMBER
 00511    C     PRINT 2221,IKX
 00512    C2221 FORMAT(' SUCCESS IN SIDCON,TRACK=',I4)
 00513 198         CIF
 00514 199      CPROC
 00515    C
 00516    C     ********************************************************
 00517    C
 00518 201      PROC SIDCX
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00519    C
 00520    C
 00521    C
 00522 202         CLIM=.5*BSL
 00523 203         DXNEW=DSMAX(IIWW,KRING,IRT)-DRIFT
 00524 204         DXOLD=9999.
 00525    C     SLWALL=DSMAX(2,KRING,LR1)-DSMAX(1,KRING,LR1)
 00526    C     IF BSL.GT.SLWALL
 00527    C     THEN
 00528 205         WHILE DXNEW.GT.CLIM
 00529 207            IF IIWW.EQ.16.OR.IIWW.EQ.1
 00530 211            THEN
 00531    C     PRINT 432
 00532    C 432 FORMAT(' WIRE NO. OUT OF RANGE  ')
 00533 214               XWHILE
 00534 215            CIF
 00535 216            DRIFT=DRIFT+BSL
 00536 217            IF(IUDFLG.EQ.IM1) IIWW=IIWW-1
 00537 219            IF(IUDFLG.EQ.IM2) IIWW=IIWW+1
 00538 221            DSMX=DSMAX(IIWW,KRING,IRT)
 00539 222            DXNEW=DSMX-DRIFT
 00540 223            IF ABS(DXNEW).GT.ABS(DXOLD)
 00541 224            THEN
 00542    C     PRINT 902
 00543    C902  FORMAT( '  DIVERGENCE  ')
 00544 227               DTMP=100.
 00545 228               XWHILE
 00546 229            CIF
 00547    C     CALL CHKX(69,IIWW,IUDFLG,IIWW)
 00548    C     CALL CHKX(-69,DXNEW,DXOLD,DRIFT)
 00549 230            IF DXNEW.LT.1.
 00550 231            THEN
 00551 234               XWHILE
 00552 235            ELSE
 00553 236               DXOLD=DXNEW
 00554 237            CIF
 00555 238         CWHILE
 00556 240         DTMP=DXNEW
 00557 241      CPROC
 00558    C
 00559    C     *******************************************************
 00560    C
 00561 243      PROC SIDFIT
 00562    C
 00563    C
 00564    C
 00565 244         IB=0
 00566 245         IF HNREL(NTR).LT.9
 00567 246         THEN
 00568 249            IKFLG=IJFLG
 00569 250            CALL MVC(HTEMP(1),0,HISTR(1,NTR),0,18)
 00570 251            IF(LR.EQ.-1.AND.LR1.EQ.2.OR.LR.EQ.1.AND.LR1.EQ.1) CALL COREC
 00571 253            IF(LR.EQ.0.AND.LR1.EQ.1) HISTR(1,NTR)=-HISTR(1,NTR)
 00572 255            HNREL(NTR)=HNREL(NTR)+1
 00573 256            IF(LR1.EQ.2) LRC=-1
 00574 258            IF(LR1.EQ.1) LRC=1
 00575 260            IF(LAND(LBL(KX),MSKCR1).NE.0.AND.IUDFLG.EQ.6) LRC=-LRC
 00576 262            IKRA=HISTR(1,NTR)
 00577 263            IKRA=IABS(IKRA)
 00578 264            IF(IKRA.EQ.KT.AND.IUDFLG.EQ.3.AND.LAND(MSKCR1,LBL(KT)).NE.0)
 00579         *      CALL COREC
 00580 266            HISTR(HNREL(NTR),NTR)=KX*LRC
 00581    C     LBL(KX)=LOR(LBL(KX),MSKFIT)
 00582 267            IAB=HNREL(NTR)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00583 268            CALL BAKFIT(IB,3)
 00584    C     IF(IB.NE.0) PRINT 36
 00585    C36   FORMAT('   SIDE  FIT    ')
 00586    C     IF(IB.NE.0) PRINT 37,KX,NTR,(HISTR(IR,NTR),IR=1,IAB)
 00587    C     IF(IB.NE.0) PRINT 38,(HTEMP(IR),IR=1,9)
 00588    C37   FORMAT(' KX, NTR,HISTR :',11I5)
 00589    C38   FORMAT(' OLD HISTR :',9I5)
 00590 269            HNREL(NTR)=HNREL(NTR)-1
 00591    C     LBL(KX)=LAND(LBL(KX),MSKAIT)
 00592 270            CALL MVC(HISTR(1,NTR),0,HTEMP(1),0,18)
 00593 271            IJFLG=IKFLG
 00594 272         CIF
 00595 273      CPROC
 00596 275      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         274 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 00597   2      SUBROUTINE LFRT(LR2)
 00598    C
 00599    C     THIS SUB EXTRACTS LEFT-RIGHT SOLN BASED
 00600    C     ON THE LABEL IN MIDOUT(WIRE STAGGERING)
 00601    C
 00602   3      IMPLICIT INTEGER*2 (H)
 00000    C   30/10/79 910301050  MEMBER NAME  CWORKMX  (PATRECSR)    FORTRAN
 00100    C   16/09/79 C9092001   MEMBER NAME  CWORKMX  (UKSOR)       FORTRAN
 00200    C ==========MACRO CWORKMG =============================
 00300   4      EQUIVALENCE (ADWRK(291),HUSE(1)),(ADWRK(391),K),
 00400         * (ADWRK(392),ICL),(ADWRK(393),LRING),(ADWRK(394),KRING),
 00500         * (ADWRK(395),LR),(ADWRK(396),IRIFLG),(ADWRK(397),IUDFLG),
 00600         * (ADWRK(398),ILIM),(ADWRK(399),LR1),(ADWRK(400),IRL),
 00700         * (ADWRK(401),ITK(1,1)),(ADWRK(441),DTEMP(1)),
 00800         * (ADWRK(451),IPST),(ADWRK(452),IJFLG),(ADWRK(453),ICX),
 00900         * (ADWRK(454),KT),(ADWRK(455),ISDL),(ADWRK(456),IBFIT),
 01000         * (ADWRK(457),ISP),(ADWRK(458),ISKP(1)),(ADWRK(468),HSP1(1)),
 01100         * (ADWRK(478),ITOL),(ADWRK(479),IW),(ADWRK(480),A),
 01200         * (ADWRK(481),DS),(ADWRK(482),IWT),(ADWRK(483),ICT),
 01300         * (ADWRK(484),IKX),(ADWRK(485),LRCORN)
 01400   5      DIMENSION HUSE(200),DTEMP(10),ITK(10,4),ISKP(10),HSP1(20)
 01500   6      EQUIVALENCE (ILOUT,IBKK(3)),(ILIN,IBKK(4)),
 01600         * (ILBOT,IBKK(8)),(DCELL,BKK(9))
 01700    C ==========ENDMACRO CWORKMG==========================
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         7      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
         8      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
         9      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        10      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        11      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        12      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        13      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        14      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        15      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        16      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        17      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        18      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00606  19      DATA MSKLFT,MSKRT/Z400,Z800/
 00607  20      LR2=0
 00608  21      IPST=0
 00609  22      I1=LAND(LBL(IKX),MSKLFT)
 00610  23      I2=LAND(LBL(IKX),MSKRT)
 00611    C     LEFT SOLN
 00612  24      IF(I1.NE.0) LR2=-1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00613    C     RIGHT SOLN
 00614  26      IF(I2.NE.0) LR2=1
 00615    C     CAN'T TELL
 00616  28      IF(I1*I2.NE.0) LR2=0
 00617  30      IF(LR2.NE.0) IPST=1
 00618  32      RETURN
 00619  33      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          32 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         642 TARGET STATEMENTS
 00000    C   28/01/80 104011107  MEMBER NAME  CBTREL   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE CBTREL(IPR1,IPR2)
 00002    C
 00003   3      IMPLICIT INTEGER*2 (H)
 00004   4      LOGICAL TBIT
 00005    C
 00006    C     SUBROUTINE TO COMBINE TRACK ELEMENTS
 00007    C     AUTHOR: P. STEFFEN(78/11/21)
 00008    C
 00009    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         5      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
         6      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
         7      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
         8      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
         9      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        10      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        11      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  12      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 00012    C
 00014  13      DIMENSION IPC(12), IAUX(8),RAUX(8),HAUX(2,8)                       POINTER TO ADJACENT CELLS
 00015  14      EQUIVALENCE (IAUX(1),HAUX(1,1))
 00016    C
 00018  15      INTEGER*2 HZW(2)                                                   I2-I4 CONVERSION:
 00019  16      EQUIVALENCE (HZW(1),IZW,HZW1) , (HZW(2),HZW2)
 00020    C
 00022  17      COMMON /CPTSLM/ BKTRLM(20)                                         LIMITS FOR CONNECTIONS OF TRELS
 00023  18      INTEGER LMBKTR(20)
 00024  19      REAL CBTRLM(10)
 00025  20      EQUIVALENCE (BKTRLM(11),LMBKTR(11),CBTRLM(1))
 00026    C
 00027  21      IPTR0 = HPTE0
 00028  22      IPTR9 = HPTE9
 00029  23      LDTRK = HLDTE
 00030  24      NPR  = 0
 00031  25      NPR9 = MIN0(IPR2,100)
 00032  26      IF(IPR1.EQ.0) NPR9 = 0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00033    C
 00035  28      FOR IPTR = IPTR0,IPTR9,LDTRK                                       LOOP OVER ALL TREL'S
 00037  29         ICELL = IWRK(IPTR   )                                           CELL #
 00038  30         LBTREL= IWRK(IPTR+19)
 00039    C
 00041  31         PERFORM PNTADJ                                                  GET POINTERS TO ADJACENT CELLS
 00042    C
 00044  34         RMSMIN = 1000.                                                  SEARCH FOR CONNECTION OUTWARDS
 00045  35         ALGHT1 = 0.
 00046  36         ALGHT2 = 200.
 00047  37         PERFORM CNOUTW
 00048    C
 00050  40         IF RMSMIN.GT.CBTRLM(4)                                          CHECK IF GOOD COMB. FOR 1. RING
 00051  41         THEN
 00053  44            IPC( 5) = 0                                                  NO GOOD COMB.: TRY R1-R3 COMB.
 00054  45            IPC( 6) = 0
 00055  46            IPC( 7) = 0
 00056  47            IPC( 8) = 0
 00057  48            IPC( 9) = IPC( 1)
 00058  49            IPC(10) = IPC( 2)
 00059  50            IPC(11) = IPC( 3)
 00060  51            IPC(12) = IPC( 4)
 00061  52            ALGHT2 = 400.
 00062  53            PERFORM CNOUTW
 00063  56         CIF
 00064    C
 00065  57      CFOR
 00066    C
 00067                                                                             ORDER MULT. CONNECTIONS
 00069  59      PERFORM ORDER                                                      CLOSEST CONNECT. FIRST
 00070    C
 00071  62      RETURN
 00072    C
 00073    C
 00075    C                                                                        *****  P N T A D J  *****
 00077  63      PROC PNTADJ                                                        GET POINTERS TO ADJACENT CELLS
 00078    C
 00079  64         IF ICELL.LE.24
 00081  65         THEN                                                            RING 1
 00082    C
 00083  68            IF ICELL.EQ.1
 00085  69            THEN                                                         SPECIAL FOR CELL 1
 00086  72               IPC( 5) = IPTR0
 00087  73               IPC( 6) = IPTR0 + (HNTCEL( 3)-2)*LDTRK
 00088  74               IPC( 7) = IPTR0 + (HNTCEL(24)-1)*LDTRK
 00089  75               IPC( 8) = IPTR0 + (HNTCEL(25)-2)*LDTRK
 00090  76               IPC( 9) = IPTR0 + (HNTCEL(25)-1)*LDTRK
 00091  77               IPC(10) = IPTR0 + (HNTCEL(27)-2)*LDTRK
 00092  78               IPC(11) = IPTR0 + (HNTCEL(48)-1)*LDTRK
 00093  79               IPC(12) = IPTR0 + (HNTCEL(49)-2)*LDTRK
 00094  80               IPC( 1) = IPTR0 + (HNTCEL(49)-1)*LDTRK
 00095  81               IPC( 2) = IPTR0 + (HNTCEL(53)-2)*LDTRK
 00096  82               IPC( 3) = IPTR0 + (HNTCEL(95)-1)*LDTRK
 00097  83               IPC( 4) = IPTR0 + (HNTCEL(97)-2)*LDTRK
 00098  84            ELSE
 00099  86               IF ICELL.LT.24
 00101  87               THEN                                                      CELL 2 - 23
 00102  90                  IPC( 5) = IPTR0 + (HNTCEL(ICELL- 1)-1)*LDTRK
 00103  91                  IPC( 6) = IPTR0 + (HNTCEL(ICELL+ 2)-2)*LDTRK
 00104  92                  IPC( 7) = 0
 00105  93                  IPC( 8) = 0
 00106  94                  IPC( 9) = IPTR0 + (HNTCEL(ICELL+23)-1)*LDTRK
 00107  95                  IPC(10) = IPTR0 + (HNTCEL(ICELL+26)-2)*LDTRK
 00108  96                  IPC(11) = 0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00109  97                  IPC(12) = 0
 00110  98                  ICLL3 = ICELL*2 + 46
 00111  99                  IPC( 1) = IPTR0 + (HNTCEL(ICLL3-1)-1)*LDTRK
 00112 100                  IPC( 2) = IPTR0 + (HNTCEL(ICLL3+5)-2)*LDTRK
 00113 101                  IPC( 3) = 0
 00114 102                  IPC( 4) = 0
 00116 103               ELSE                                                      SPECIAL FOR CELL 24
 00117 105                  IPC( 5) = IPTR0 + (HNTCEL(23)-1)*LDTRK
 00118 106                  IPC( 6) = IPTR0 + (HNTCEL(25)-2)*LDTRK
 00119 107                  IPC( 7) = IPTR0
 00120 108                  IPC( 8) = IPTR0 + (HNTCEL( 2)-2)*LDTRK
 00121 109                  IPC( 9) = IPTR0 + (HNTCEL(47)-1)*LDTRK
 00122 110                  IPC(10) = IPTR0 + (HNTCEL(49)-2)*LDTRK
 00123 111                  IPC(11) = IPTR0 + (HNTCEL(25)-1)*LDTRK
 00124 112                  IPC(12) = IPTR0 + (HNTCEL(26)-2)*LDTRK
 00125 113                  IPC( 1) = IPTR0 + (HNTCEL(93)-1)*LDTRK
 00126 114                  IPC( 2) = IPTR0 + (HNTCEL(97)-2)*LDTRK
 00127 115                  IPC( 3) = IPTR0 + (HNTCEL(49)-1)*LDTRK
 00128 116                  IPC( 4) = IPTR0 + (HNTCEL(51)-2)*LDTRK
 00129 117               CIF
 00130 118            CIF
 00131    C
 00132 119         ELSE
 00133 121            IF ICELL.LE.48
 00135 122            THEN                                                         RING2
 00136    C
 00137 125               IF ICELL.EQ.25
 00139 126               THEN                                                      SPECIAL FOR CELL 25
 00140 129                  IPC( 1) = IPTR0
 00141 130                  IPC( 2) = IPTR0 + (HNTCEL( 3)-2)*LDTRK
 00142 131                  IPC( 3) = IPTR0 + (HNTCEL(24)-1)*LDTRK
 00143 132                  IPC( 4) = IPTR0 + (HNTCEL(25)-2)*LDTRK
 00144 133                  IPC( 5) = IPTR0 + (HNTCEL(25)-1)*LDTRK
 00145 134                  IPC( 6) = IPTR0 + (HNTCEL(27)-2)*LDTRK
 00146 135                  IPC( 7) = IPTR0 + (HNTCEL(48)-1)*LDTRK
 00147 136                  IPC( 8) = IPTR0 + (HNTCEL(49)-2)*LDTRK
 00148 137                  IPC( 9) = IPTR0 + (HNTCEL(49)-1)*LDTRK
 00149 138                  IPC(10) = IPTR0 + (HNTCEL(53)-2)*LDTRK
 00150 139                  IPC(11) = IPTR0 + (HNTCEL(95)-1)*LDTRK
 00151 140                  IPC(12) = IPTR0 + (HNTCEL(97)-2)*LDTRK
 00152 141               ELSE
 00153 143                  IF ICELL.LT.48
 00155 144                  THEN                                                   CELLS 25 - 47
 00156 147                     IPC( 1) = IPTR0 + (HNTCEL(ICELL-25)-1)*LDTRK
 00157 148                     IPC( 2) = IPTR0 + (HNTCEL(ICELL-22)-2)*LDTRK
 00158 149                     IPC( 3) = 0
 00159 150                     IPC( 4) = 0
 00160 151                     IPC( 5) = IPTR0 + (HNTCEL(ICELL- 1)-1)*LDTRK
 00161 152                     IPC( 6) = IPTR0 + (HNTCEL(ICELL+ 2)-2)*LDTRK
 00162 153                     IPC( 7) = 0
 00163 154                     IPC( 8) = 0
 00164 155                     ICLL3 = (ICELL-24)*2 + 46
 00165 156                     IPC( 9) = IPTR0 + (HNTCEL(ICLL3-1)-1)*LDTRK
 00166 157                     IPC(10) = IPTR0 + (HNTCEL(ICLL3+5)-2)*LDTRK
 00167 158                     IPC(11) = 0
 00168 159                     IPC(12) = 0
 00169 160                  ELSE
 00171 162                     IPC( 1) = IPTR0 + (HNTCEL(23)-1)*LDTRK              SPECIAL FOR CELL 48
 00172 163                     IPC( 2) = IPTR0 + (HNTCEL(25)-2)*LDTRK
 00173 164                     IPC( 3) = IPTR0
 00174 165                     IPC( 4) = IPTR0 + (HNTCEL( 2)-2)*LDTRK
 00175 166                     IPC( 5) = IPTR0 + (HNTCEL(47)-1)*LDTRK
 00176 167                     IPC( 6) = IPTR0 + (HNTCEL(49)-2)*LDTRK
 00177 168                     IPC( 7) = IPTR0 + (HNTCEL(25)-1)*LDTRK
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00178 169                     IPC( 8) = IPTR0 + (HNTCEL(26)-2)*LDTRK
 00179 170                     IPC( 9) = IPTR0 + (HNTCEL(93)-1)*LDTRK
 00180 171                     IPC(10) = IPTR0 + (HNTCEL(97)-2)*LDTRK
 00181 172                     IPC(11) = IPTR0 + (HNTCEL(49)-1)*LDTRK
 00182 173                     IPC(12) = IPTR0 + (HNTCEL(51)-2)*LDTRK
 00183 174                  CIF
 00184 175               CIF
 00185    C
 00187 176            ELSE                                                         RING 3
 00188    C
 00189 178               IPC( 9) = 0
 00190 179               IPC(10) = 0
 00191 180               IPC(11) = 0
 00192 181               IPC(12) = 0
 00193    C
 00194 182               IF ICELL.EQ.49
 00196 183               THEN                                                      SPECIAL FOR CELL 49
 00197 186                  IPC( 1) = IPTR0 + (HNTCEL(48)-1)*LDTRK
 00198 187                  IPC( 2) = IPTR0 + (HNTCEL(49)-2)*LDTRK
 00199 188                  IPC( 3) = IPTR0 + (HNTCEL(25)-1)*LDTRK
 00200 189                  IPC( 4) = IPTR0 + (HNTCEL(26)-2)*LDTRK
 00201 190                  IPC( 5) = IPTR0 + (HNTCEL(49)-1)*LDTRK
 00202 191                  IPC( 6) = IPTR0 + (HNTCEL(51)-2)*LDTRK
 00203 192                  IPC( 7) = IPTR0 + (HNTCEL(96)-1)*LDTRK
 00204 193                  IPC( 8) = IPTR0 + (HNTCEL(97)-2)*LDTRK
 00205 194               ELSE
 00206 196                  IF ICELL.LT.96
 00208 197                  THEN                                                   CELLS 50 - 95
 00209 200                     ICLL2 = (ICELL-50)/2 + 25
 00210 201                     IPC( 1) = IPTR0 + (HNTCEL(ICLL2   )-1)*LDTRK
 00211 202                     IPC( 2) = IPTR0 + (HNTCEL(ICLL2+ 2)-2)*LDTRK
 00212 203                     IPC( 3) = 0
 00213 204                     IPC( 4) = 0
 00214 205                     IPC( 5) = IPTR0 + (HNTCEL(ICELL- 1)-1)*LDTRK
 00215 206                     IPC( 6) = IPTR0 + (HNTCEL(ICELL+ 2)-2)*LDTRK
 00216 207                     IPC( 7) = 0
 00217 208                     IPC( 8) = 0
 00218 209                  ELSE
 00220 211                     IPC( 1) = IPTR0 + (HNTCEL(48)-1)*LDTRK              SPECIAL FOR CELL 96
 00221 212                     IPC( 2) = IPTR0 + (HNTCEL(49)-2)*LDTRK
 00222 213                     IPC( 3) = IPTR0 + (HNTCEL(25)-1)*LDTRK
 00223 214                     IPC( 4) = IPTR0 + (HNTCEL(26)-2)*LDTRK
 00224 215                     IPC( 5) = IPTR0 + (HNTCEL(95)-1)*LDTRK
 00225 216                     IPC( 6) = IPTR0 + (HNTCEL(97)-2)*LDTRK
 00226 217                     IPC( 7) = IPTR0 + (HNTCEL(49)-1)*LDTRK
 00227 218                     IPC( 8) = IPTR0 + (HNTCEL(50)-2)*LDTRK
 00228 219                  CIF
 00229 220               CIF
 00230    C
 00231 221            CIF
 00232 222         CIF
 00233    C
 00235 223         IF(IPC( 1).GT.IPC( 2)) IPC( 1) = 0                              ZERO POINTERS IF NO TREL'S IN CELLS
 00236 225         IF(IPC( 3).GT.IPC( 4)) IPC( 3) = 0
 00237 227         IF(IPC( 5).EQ.IPC( 6)) IPC( 5) = 0
 00238 229         IF(IPC( 7).GT.IPC( 8)) IPC( 7) = 0
 00239 231         IF(IPC( 9).GT.IPC(10)) IPC( 9) = 0
 00240 233         IF(IPC(11).GT.IPC(12)) IPC(11) = 0
 00241    C
 00242 235      CPROC
 00243    C
 00244    C
 00246    C                                                                        *****  C N O U T W  *****
 00248 237      PROC CNOUTW                                                        CONNECT TREL OUTWARDS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00249    C
 00250                                                                             JPTRI = INNER TREL
 00252 238         JPTRI = IPTR                                                    JPTRO = OUTER TREL
 00253 239         LRFLGI = SHFTR(LBTREL,10)
 00254 240         LRFLGI = LAND(LRFLGI,3)
 00255 241         XXIM = AMIN1(ABS(WRK(JPTRI+11)),ABS(WRK(JPTRI+15)))
 00256 242         YYIM = AMIN1(ABS(WRK(JPTRI+12)),ABS(WRK(JPTRI+16)))
 00258 243         ICLOOP = 5                                                      LOOP OVER ALL ADJACENT CELLS
 00259 244         REPEAT
 00260 245            IF IPC(ICLOOP).GT.0
 00261 246            THEN
 00262 249               JPTRO = IPC(ICLOOP  )
 00263 250               JPTR9 = IPC(ICLOOP+1)
 00264 251               WHILE JPTRO.LE.JPTR9
 00265 253                  IF JPTRO.NE.JPTRI
 00266 257                  THEN
 00267    C
 00269 260                     NCAND = 255                                         CHECK IF TRELS OVERLAP
 00270 261                     IF ABS(XXIM).GT.ABS(YYIM)
 00271 262                     THEN
 00272 265                        XXOM = AMAX1(ABS(WRK(JPTRO+ 3)),ABS(WRK(JPTRO+ 7)))
 00273 266                        IF(XXOM-XXIM .GT. CBTRLM(1)) NCAND=0
 00274 268                     ELSE
 00275 270                        YYOM = AMAX1(ABS(WRK(JPTRO+ 4)),ABS(WRK(JPTRO+ 8)))
 00276 271                        IF(YYOM-YYIM .GT. CBTRLM(1)) NCAND=0
 00277 273                     CIF
 00278 274                     IF NCAND.EQ.0
 00279 275                     THEN
 00280    C
 00282 278                        NCOMB = 0                                        # OF COMBINATIONS OF 2 TRELS
 00284 279                        JCLLI = IWRK(JPTRI)                              SET LIMITS FOR STRAIGHT/CROSS CONNECT.
 00285 280                        IF(JCLLI.GT.48) JCLLI = SHFTR(JCLLI-46,1)
 00286 282                        IF(JCLLI.GT.24) JCLLI = JCLLI - 24
 00287 284                        JCLLO = IWRK(JPTRO)
 00288 285                        IF(JCLLO.GT.48) JCLLO = SHFTR(JCLLO-46,1)
 00289 287                        IF(JCLLO.GT.24) JCLLO = JCLLO - 24
 00290 289                        IF IABS(JCLLO-JCLLI).EQ.0
 00291 290                        THEN
 00292 293                           DRLIM = CBTRLM(2)
 00293 294                           DANGL = CBTRLM(3)
 00294 295                        ELSE
 00295 297                           DRLIM = CBTRLM(6)
 00296 298                           DANGL = CBTRLM(7)
 00297 299                        CIF
 00299 300                        ALGHT0 = ALGHT1                                  SET AVER. LENGTH OF TRACK
 00300 301                        IF(ICLOOP.GE.9) ALGHT0 = ALGHT2
 00302 303                        LRFLGO = SHFTR(IWRK(JPTRO+19),10)                SELECT L/R-COMB. FROM /CMDOUT/
 00303 304                        LRFLGO = LAND(LRFLGO,3)
 00304 305                        LRFLIO = LRFLGI + LRFLGO*4
 00305 306                        LBLR = 0
 00306 307                        RMSMZW = 1000.
 00307 308                        SELECT LRFLIO
 00309 309                        CASE 5                                           L - L
 00310 311                           LRFLAG = 1
 00311 312                           PERFORM CKCIRC
 00312 315                           LBLR = 1
 00314 316                        CASE 6                                           R - L
 00315 318                           LRFLAG = 2
 00316 319                           PERFORM CKCIRC
 00317 322                           LBLR = 2
 00319 323                        CASE 7                                           ? - L
 00320 325                           LRFLAG = 1
 00321 326                           PERFORM CKCIRC
 00322 329                           LRFLAG = 2
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00323 330                           PERFORM CKCIRC
 00324 333                           LBLR = 3
 00326 334                        CASE 9                                           L - R
 00327 336                           LRFLAG = 3
 00328 337                           PERFORM CKCIRC
 00329 340                           LBLR = 4
 00331 341                        CASE 10                                          R - R
 00332 343                           LRFLAG = 4
 00333 344                           PERFORM CKCIRC
 00334 347                           LBLR = 8
 00336 348                        CASE 11                                          ? - R
 00337 350                           LRFLAG = 3
 00338 351                           PERFORM CKCIRC
 00339 354                           LRFLAG = 4
 00340 355                           PERFORM CKCIRC
 00341 358                           LBLR = 12
 00343 359                        CASE 13                                          L - ?
 00344 361                           LRFLAG = 1
 00345 362                           PERFORM CKCIRC
 00346 365                           LRFLAG = 3
 00347 366                           PERFORM CKCIRC
 00348 369                           LBLR = 5
 00350 370                        CASE 14                                          R - ?
 00351 372                           LRFLAG = 2
 00352 373                           PERFORM CKCIRC
 00353 376                           LRFLAG = 4
 00354 377                           PERFORM CKCIRC
 00355 380                           LBLR = 10
 00356 381                        OTHER
 00357 386                        CSELECT
 00358    C
 00360 387                        IF RMSMZW.GT.CBTRLM(4)                           TRY ALL REMAINING COMB. IF NO GOOD ONE FOUND
 00361 388                        THEN
 00363 391                           IF(RMSMZW.LE.CBTRLM(5)) NCOMB = 0             KEEP NOT TOO BAD PREVIOUS COMB.
 00365 393                           IF LAND(LBLR,1).EQ.0                          TRY REMAINING COMB.
 00366 394                           THEN
 00367 397                              LRFLAG = 1
 00368 398                              PERFORM CKCIRC
 00369 401                           CIF
 00370 402                           IF LAND(LBLR,2).EQ.0
 00371 403                           THEN
 00372 406                              LRFLAG = 2
 00373 407                              PERFORM CKCIRC
 00374 410                           CIF
 00375 411                           IF LAND(LBLR,4).EQ.0
 00376 412                           THEN
 00377 415                              LRFLAG = 3
 00378 416                              PERFORM CKCIRC
 00379 419                           CIF
 00380 420                           IF LAND(LBLR,8).EQ.0
 00381 421                           THEN
 00382 424                              LRFLAG = 4
 00383 425                              PERFORM CKCIRC
 00384 428                           CIF
 00385 429                        CIF
 00386 430                        IF(RMSMZW.LT.RMSMIN) RMSMIN = RMSMZW
 00388    C                                                                        KEEP SMALLEST CHISQ
 00389 432                     CIF
 00390    C
 00391 433                  CIF
 00392 434                  JPTRO = JPTRO + LDTRK
 00393 435               CWHILE
 00394    C
 00395 437            CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 00396 438            ICLOOP = ICLOOP + 2
 00397 439         UNTIL ICLOOP.GE.12
 00398    C
 00399 440      CPROC
 00400    C
 00401    C
 00403    C                                                                        *****  C K C I R C  *****
 00405 445      PROC CKCIRC                                                        CONNECT TREL OUTWARDS
 00406    C
 00408 446         SELECT LRFLAG                                                   GET POINTERS FOR L/R-COMBINATION
 00410 447         CASE 1                                                          L - L
 00411 449            JPTII = JPTRI+3
 00412 450            JPTIO = JPTRI+11
 00413 451            JPTOI = JPTRO+3
 00414 452            JPTOO = JPTRO+11
 00415
 00417 453         CASE 2                                                          R - L
 00418 455            JPTII = JPTRI+7
 00419 456            JPTIO = JPTRI+15
 00420 457            JPTOI = JPTRO+3
 00421 458            JPTOO = JPTRO+11
 00423 459         CASE 3                                                          L - R
 00424 461            JPTII = JPTRI+3
 00425 462            JPTIO = JPTRI+11
 00426 463            JPTOI = JPTRO+7
 00427 464            JPTOO = JPTRO+15
 00429 465         CASE 4                                                          R - R
 00430 467            JPTII = JPTRI+7
 00431 468            JPTIO = JPTRI+15
 00432 469            JPTOI = JPTRO+7
 00433 470            JPTOO = JPTRO+15
 00434 471         OTHER
 00435 476         CSELECT
 00436    C
 00438 477         XXII = WRK(JPTII   )                                            SET END POINTS + SLOPES
 00439 478         YYII = WRK(JPTII+ 1)
 00440 479         DXII = WRK(JPTII+ 2)
 00441 480         DYII = WRK(JPTII+ 3)
 00442 481         XXOI = WRK(JPTOI   )
 00443 482         YYOI = WRK(JPTOI+ 1)
 00444 483         DXOI = WRK(JPTOI+ 2)
 00445 484         DYOI = WRK(JPTOI+ 3)
 00446 485         XXIO = WRK(JPTIO   )
 00447 486         YYIO = WRK(JPTIO+ 1)
 00448 487         DXIO = WRK(JPTIO+ 2)
 00449 488         DYIO = WRK(JPTIO+ 3)
 00450 489         XXOO = WRK(JPTOO   )
 00451 490         YYOO = WRK(JPTOO+ 1)
 00452 491         DXOO = WRK(JPTOO+ 2)
 00453 492         DYOO = WRK(JPTOO+ 3)
 00454    C
 00456    C                                                                        CHECK CONNECTION
 00457 493         REPEAT
 00458    C
 00460 494            ZW1 = (XXII-XXOI)**2 + (YYII-YYOI)**2                        CHECK IF OUTWARD CONNECTION
 00461 495            ZW2 = (XXOO-XXIO)**2 + (YYOO-YYIO)**2
 00462 496            ZW0 = (XXII-XXOO)**2 + (YYII-YYOO)**2
 00463 497            IF(ZW1.GT.ZW0 .OR. ZW2.GT.ZW0) XREPEAT
 00464    C
 00466    C                                                                        CALCULATE CIRCLE FROM3 POINTS
 00467    C
 00469 499            XOA = ( XXII + XXOO ) *.5                                    1. + LAST POINT + AVERAGE
 00470 500            YOA = ( YYII + YYOO ) *.5
 00472 501            COSTH = XXOO - XXII                                          DIRECTIONS FOR TRANSFORMATION
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 00473 502            SINTH = YYOO - YYII
 00474 503            ZWZ = SQRT(COSTH**2+SINTH**2)
 00475 504            COSTH = COSTH / ZWZ
 00476 505            SINTH = SINTH / ZWZ
 00478    C                                                                        TRANSFORMATIONS OF POINTS
 00479 506            XX = XXII - XOA
 00480 507            YY = YYII - YOA
 00481 508            YT1 = 0.
 00482 509            XT1 =-.5*ZWZ
 00483 510            XX = XXIO - XOA
 00484 511            YY = YYIO - YOA
 00485 512            YT2 = YY * COSTH - XX * SINTH
 00486 513            XT2 = XX * COSTH + YY * SINTH
 00487 514            XX = XXOI - XOA
 00488 515            YY = YYOI - YOA
 00489 516            YT3 = YY * COSTH - XX * SINTH
 00490 517            XT3 = XX * COSTH + YY * SINTH
 00491 518            XX = XXOO - XOA
 00492 519            YY = YYOO - YOA
 00493 520            YT4 = 0.
 00494 521            XT4 =-XT1
 00495    C
 00497 522            IF ABS(XT2).LT.ABS(XT3)                                      SELECT CENTRAL POINT
 00498 523            THEN
 00499 526               X1 = XT1
 00500 527               Y1 = YT1
 00501 528               X2 = XT2
 00502 529               XC = XT2
 00503 530               Y2 = YT2
 00504 531               YC = YT2
 00505 532               XL = XT3
 00506 533               YL = YT3
 00507 534            ELSE
 00508 536               X1 = XT3
 00509 537               XC = XT3
 00510 538               Y1 = YT3
 00511 539               YC = YT3
 00512 540               X2 = XT4
 00513 541               Y2 = YT4
 00514 542               XL = XT2
 00515 543               YL = YT2
 00516 544            CIF
 00518 545            X0 = 0.                                                      INTERSECT WITH Y-AXIS
 00519 546            Y0 = 1000000.
 00520 547            DY = Y2 - Y1
 00521 548            IF(ABS(DY).GT..01)
 00522         *      Y0 = ((X2-X1)*(X2+X1)/DY + Y2+Y1)*.5
 00523 550            T  = Y0 - YC
 00524 551            R0 = ABS(T)
 00525 552            CHARGE = SIGN(1.,T)
 00526 553            R0 = .5*(R0 + ((Y0-YC)**2+XC**2) / R0)
 00527 554            DR0 = (XL**2-XC**2 + (Y0-YL)**2-(Y0-YC)**2)*.5/R0
 00528 555            DSQ = .75*DR0**2
 00529 556            XCIRC = X0*COSTH - Y0*SINTH + XOA
 00530 557            YCIRC = Y0*COSTH + X0*SINTH + YOA
 00532 558            ALGHT = ABS(XT1)*2.                                          LENGTH/R RATIO
 00533 559            ALRAT = AMAX1(ALGHT,ALGHT0) / R0
 00535 560            DRLIM1 = AMAX1(ALRAT,1.)*CBTRLM(4) + DRLIM                   WIDEN LIMIT FOR LOW ENERGY TRACKS
 00536    C2002 FORMAT(' COMBA.:',3I6,F8.2,F8.5,5F8.3)
 00537    C2005 FORMAT(' COMBR:',10F10.1,/,7X,10F10.1)
 00538 561            IF(JPTRI.GE.IPR1) NPR = NPR + 1
 00539    C     IF(JPTRI.GE.IPR1 .AND. NPR.LE.NPR9)
 00540    C    ,PRINT 2005, X1,Y1,X2,Y2,XC,YC,X0,Y0,T,R0,DR0,DSQ
 00541    C    ,           ,XCIRC,YCIRC ,DRLIM,DRLIM1,ALGHT,ALRAT
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 00542    C
 00544 563            IF(ABS(DR0).GT.DRLIM1) XREPEAT                               CHECK IF GOOD CONNECTION
 00545 565            NCAND = 2
 00546    C
 00548 566            IF ABS(XXIO-XCIRC).LT.ABS(YYIO-YCIRC)                        CALC. TANGENTIAL ANGLES
 00549 567            THEN
 00550 570               TG1  = DYII / DXII
 00551 571               TGC1 =-(XXII-XCIRC) / (YYII-YCIRC)
 00552 572               TG2  = DYIO / DXIO
 00553 573               TGC2 =-(XXIO-XCIRC) / (YYIO-YCIRC)
 00554 574               TG3  = DYOI / DXOI
 00555 575               TGC3 =-(XXOI-XCIRC) / (YYOI-YCIRC)
 00556 576               TG4  = DYOO / DXOO
 00557 577               TGC4 =-(XXOO-XCIRC) / (YYOO-YCIRC)
 00558 578            ELSE
 00559 580               TG1  = DXII / DYII
 00560 581               TGC1 =-(YYII-YCIRC) / (XXII-XCIRC)
 00561 582               TG2  = DXIO / DYIO
 00562 583               TGC2 =-(YYIO-YCIRC) / (XXIO-XCIRC)
 00563 584               TG3  = DXOI / DYOI
 00564 585               TGC3 =-(YYOI-YCIRC) / (XXOI-XCIRC)
 00565 586               TG4  = DXOO / DYOO
 00566 587               TGC4 =-(YYOO-YCIRC) / (XXOO-XCIRC)
 00567 588            CIF
 00569 589            DLTS1 = (TG1-TGC1) / (1.+TG1*TGC1)                           DIFF. OF ANGLES
 00570 590            DLTS2 = (TG2-TGC2) / (1.+TG2*TGC2)
 00571 591            DLTS3 = (TG3-TGC3) / (1.+TG3*TGC3)
 00572 592            DLTS4 = (TG4-TGC4) / (1.+TG4*TGC4)
 00573 593            DLTSQ1 = DLTS1**2
 00574 594            DLTSQ2 = DLTS2**2
 00575 595            DLTSQ3 = DLTS3**2
 00576 596            DLTSQ4 = DLTS4**2
 00577 597            DELTSQ = DLTSQ1 + DLTSQ2 + DLTSQ3 + DLTSQ4
 00578    C     IF(JPTRI.GE.IPR1 .AND. NPR.LE.NPR9)
 00579    C    ,PRINT 2002, JPTRI,JPTRO,LRFLAG,DSQ,DELTSQ,
 00580    C    ,    DLTS1,DLTS2,DLTS3,DLTS4,DANGL
 00581 598            IF(AMAX1(DLTSQ1,DLTSQ2,DLTSQ3,DLTSQ4).GT.DANGL) XREPEAT
 00582 600            RMS = (DSQ/.06 + DELTSQ/.0020) * .2
 00583 601            IF(RMS.LT.RMSMZW) RMSMZW = RMS
 00584 603            NCAND = RMS
 00585 604            IF(NCAND.GE.256) NCAND = 255
 00586    C
 00588 606            IF IWRK(JPTRO+20).LT.8 .AND.                                 CHECK IF SPACE FOR NEW COMB.
 00589         ?         IWRK(JPTRI+21).LT.8 .AND. NCOMB.LT.2
 00590 607            THEN
 00591    C     PRINT 2990, JPTRI,JPTRO,LRFLAG,NCAND,IWRK(JPTRI+21),IWRK(JPTRO+20)
 00592    C2990 FORMAT(' COMB:',20I6)
 00593    C
 00594                                                                             KEEP ADDRESS OF GOOD CONNECTION
 00596 610               NCOMB = NCOMB + 1                                         COUNT COMBINATION
 00597 611               HZW(1) = JPTRO
 00598 612               HZW(2) = LRFLAG - 1 + NCAND*16
 00599 613               NCNTRI = IWRK(JPTRI+21) + 1
 00600 614               IWRK(JPTRI+NCNTRI+29) = IZW
 00601 615               IWRK(JPTRI+21) = NCNTRI
 00602 616               HZW(1) = JPTRI
 00603 617               NCNTRO = IWRK(JPTRO+20) + 1
 00604 618               IWRK(JPTRO+NCNTRO+21) = IZW
 00605 619               IWRK(JPTRO+20) = NCNTRO
 00606 620            CIF
 00607 621         UNTIL .TRUE.
 00608 622      CPROC
 00609    C
 00610                                                                             ***************************
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 00611                                                                             *      O R D E R          *
 00613    C                                                                        ***************************
 00614                                                                             ORDER MULT. CONNECTIONS
 00616    C                                                                        CLOSEST CONNECT. FIRST
 00617 627      PROC ORDER
 00618    C
 00620 628         IPTR = HPTE0                                                    LOOP OVER ALL CONNECTIONS
 00621 629         REPEAT
 00623 630            NCNT= IWRK(IPTR+20)                                          CHECK IF >1 DOWN-CONNECTION
 00624 631            IP0 = IPTR+22
 00625 632            IF NCNT.GT.1
 00626 633            THEN
 00627 636               ORFACT =-1.
 00628 637               PERFORM ORDCNT
 00629 640            CIF
 00631 641            NCNT= IWRK(IPTR+21)                                          CHECK IF >1 UP-CONNECTION
 00632 642            IP0 = IPTR+30
 00633 643            IF NCNT.GT.1
 00634 644            THEN
 00635 647               ORFACT =+1.
 00636 648               PERFORM ORDCNT
 00637 651            CIF
 00638 652            IPTR = IPTR + HLDTE
 00639 653         UNTIL IPTR.GT.HPTE9
 00640 654      CPROC
 00641    C
 00642                                                                             ***************************
 00643                                                                             *      O R D C N T        *
 00645    C                                                                        ***************************
 00647    C                                                                        ORDER MULT. CONNECTIONS
 00648 659      PROC ORDCNT
 00649    C
 00651 660         CALL MVC(IAUX(1),0,IWRK(IP0),0,32)                              STORE CONNECT. IN IAUX-ARRAY
 00653 661         LBORD = 0                                                       LOOP OVER DOWN CONNECT.
 00654 662         FOR I=1,NCNT
 00655 663            IZW = IAUX(I)
 00656 664            IPCN = HZW1
 00657 665            IF LAND(IZW,2).EQ.0
 00658 666            THEN
 00659 669               RSQ = WRK(IPCN+11)**2 + WRK(IPCN+12)**2
 00660 670            ELSE
 00661 672               RSQ = WRK(IPCN+15)**2 + WRK(IPCN+16)**2
 00662 673            CIF
 00663 674            RAUX(I) = RSQ
 00664 675            IF(I.GT.1 .AND. (RSQ-RAUX(I-1))*ORFACT.LT.0) LBORD = 1
 00665 677         CFOR
 00666    C
 00668 679         IF LBORD.NE.0                                                   CHECK IF CONNECT. TO BE REORDERED
 00669 680         THEN
 00671 683            IF NCNT.EQ.2                                                 CHECK IF ONLY 2 CONNECT.
 00672 684            THEN
 00673 687               IWRK(IP0  ) = IAUX(2)
 00674 688               IWRK(IP0+1) = IAUX(1)
 00675 689            ELSE
 00677 691               LBORD = 0                                                 COMPARE ALL COMB. WITH EACH OTHER
 00678 692               NCNT9 = NCNT - 1
 00679 693               FOR I1=1,NCNT9
 00680 694                  NCNT1 = I1 + 1
 00681 695                  FOR I2=NCNT1,NCNT
 00683 696                     IF (RAUX(I2)-RAUX(I1))*ORFACT .LT. 0.               CHECK LOWEST R FIRST
 00684 697                     THEN
 00686 700                        IZW = IAUX(I2)                                   INTERCHANGE COMB.
 00687 701                        IAUX(I2) = IAUX(I1)
 00688 702                        IAUX(I1) = IZW
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 00689 703                        ZW  = RAUX(I2)
 00690 704                        RAUX(I2) = RAUX(I1)
 00691 705                        RAUX(I1) = ZW
 00692 706                     CIF
 00693 707                  CFOR
 00694 709               CFOR
 00695    C
 00697 711               CALL MVC(IWRK(IP0),0,IAUX(1),0,32)                        FINAL INTERCHANGE
 00698 712            CIF
 00699 713         CIF
 00700 714      CPROC
 00701    C
 00702 716      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         715 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         715 TARGET STATEMENTS
 00000    C   10/02/80 102191151  MEMBER NAME  CIRCCK   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE CIRCCK(MTREL0,IATREL,RSLT)
 00002    C
 00003   3      IMPLICIT INTEGER*2 (H)
 00004   4      LOGICAL TBIT
 00005    C
 00006    C     SUBROUTINE TO ELIMINATE DOUBLE CONNECT. OF TRELS
 00007    C     AUTHOR: P. STEFFEN(78/11/21)
 00008    C
 00009    C     INPUT : IATREL(1) = # OF TRELS
 00010    C             IATREL(2) = POINTER TO 1. TREL
 00011    C             IATREL(3) = POINTER TO 2. TREL
 00012    C
 00013    C     OUTPUT: RSLT(1) = R
 00014    C             RSLT(2) = XCIRC
 00015    C             RSLT(3) = YCIRC
 00016    C             RSLT(4) = SIGMA
 00017    C             RSLT(5) = DEG. OF FREEDOM
 00018    C             RSLT(6) = LENGTH / R
 00019    C             RSLT(7) = SIGMA(DIRECTIONS)
 00020    C             RSLT(8) = #(CELLS)*200 / R
 00021    C
 00022   5      DIMENSION IATREL(1),RSLT(6),HATREL(24)
 00023    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
         6      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
         7      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
         8      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
         9      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        10      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00025    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        11      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        12      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        13      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        14      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        15      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        16      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        17      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  18      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 00028  19      EQUIVALENCE
 00029         ,           (ICELL ,IDWRK(1)),(NHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
 00030         ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
 00031    C
 00033  20      DIMENSION XO(20),YO(20), XT(20),YT(20)                             COORDINATE ARRAYS FOR CIRCLE FIT
 00034    C
 00036  21      FPAR (X) = (PAR1 *X + PAR2 )*X + PAR3                              FUNCTION
 00037    C
 00038    C2000 FORMAT('0FXYZPS:',12(I7,I3))
 00039    C2001 FORMAT('     XO:',I6,2F8.3,/,(8X,I6,2F8.3))
 00040    C2002 FORMAT('     XT:',I6,2F8.1,/,(8X,I6,2F8.1))
 00041    C2003   FORMAT(' CIRCLE:',10E12.5,/,(8X,10E12.5))
 00042    C2004     FORMAT(' LOOP(TILT):',I3,3F10.2,5E13.5)
 00043    C2005   FORMAT(' TILT + DX:',5E13.5)
 00044    C2006     FORMAT(' LOOP(SAG):',I3,3F10.2,5E13.5)
 00045    C2007   FORMAT(' B + DSAG:',5E13.5)
 00046    C2008     FORMAT(' RESIDUALS:',I3,5F10.2,3E13.5)
 00047    C2009   FORMAT(' AVERAGE + SIGMA:',9E13.5)
 00048    C2010   FORMAT(' SAG.CORR:', 8E13.5)
 00049    C2902 FORMAT('0PARABEL FIT',4F12.5,4F12.2,F8.2)
 00050    C2991 FORMAT(1X,3F10.1,F8.2,F3.0,F8.3)
 00051    C
 00052  22      DATA NPR /0/
 00053  23      NPR = NPR + 1
 00054    C
 00056  24      MTREL = IABS(MTREL0)                                               # OF TREL
 00057    C
 00059  25      SIGDV0 = RSLT(4)                                                   SAVE MAX(SIGMA)
 00060    C     LBPR = IATREL(1)
 00061    C     LBPR = SHFTR(IPPR,16)
 00062    C
 00063    C
 00064                                                                             ***************************
 00065                                                                             *      F X Y Z            *
 00067    C                                                                        ***************************
 00069    C                                                                        GET COORDINATES OF TRELS
 00070    C     LBPR = 0
 00071  26      IP = 0
 00072  27      ITREL = MTREL
 00073  28      REPEAT
 00075  29         JPTREL = IATREL(ITREL)                                          POINTER TO COORDINATE ARRAY
 00076  30         IPTREL = SHFTR(JPTREL,16)
 00077    C       IF(IPTREL.EQ.2817 .OR. IPTREL.EQ.1905) LBPR = LBPR + 1
 00079  31         IF LAND(JPTREL,1).EQ.0                                          CHECK IF LEFT /RIGHT SOLUTION
 00080  32         THEN
 00081  35            XO(IP+1) = WRK(IPTREL+ 3)
 00082  36            XO(IP+2) = WRK(IPTREL+11)
 00083  37            YO(IP+1) = WRK(IPTREL+ 4)
 00084  38            YO(IP+2) = WRK(IPTREL+12)
 00085  39         ELSE
 00086  41            XO(IP+1) = WRK(IPTREL+ 7)
 00087  42            XO(IP+2) = WRK(IPTREL+15)
 00088  43            YO(IP+1) = WRK(IPTREL+ 8)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00089  44            YO(IP+2) = WRK(IPTREL+16)
 00090  45         CIF
 00091    C
 00093  46         IF LAND(JPTREL,12).EQ.0                                         CHECK IF BOTH POINTS GOOD
 00094  47         THEN
 00095                                                                             BOTH POINTS
 00097  50            IF MTREL0.LT.0                                               CHECK IF POINTS TO BE REVERSED
 00098  51            THEN
 00099  54               ZWZ = XO(IP+1)
 00100  55               XO(IP+1) = XO(IP+2)
 00101  56               XO(IP+2) = ZWZ
 00102  57               ZWZ = YO(IP+1)
 00103  58               YO(IP+1) = YO(IP+2)
 00104  59               YO(IP+2) = ZWZ
 00105  60            CIF
 00106  61            IP = IP + 2
 00107  62         ELSE
 00109  64            IF LAND(JPTREL, 4).NE.0                                      ONLY 1 POINT GOOD
 00110  65            THEN
 00112  68               XO(IP+1) = XO(IP+2)                                       1. POINT BAD
 00113  69               YO(IP+1) = YO(IP+2)
 00114  70            CIF
 00115  71            IP = IP + 1
 00116  72         CIF
 00117  73         ITREL = ITREL - 1
 00118  74      UNTIL ITREL.EQ.0
 00119  75      IP9 = IP
 00120  79      IP8 = IP - 1
 00121    C     IF(MTREL.NE.2) LBPR = 0
 00122    C     IF(LBPR.EQ.2)
 00123    C    ,PRINT 2001, (I1,XO(I1),YO(I1),I1=1,IP9)
 00124    C
 00125    C
 00126                                                                             ***************************
 00127                                                                             *      T R A N S F        *
 00129    C                                                                        ***************************
 00131    C                                                                        TRANSFORM COORDINATES
 00133  80      X1 = XO(  1)                                                       1. + LAST POINT + AVERAGE
 00134  81      X2 = XO(IP9)
 00135  82      Y1 = YO(  1)
 00136  83      Y2 = YO(IP9)
 00137  84      XOA = ( X1 + X2 ) / 2
 00138  85      YOA = ( Y1 + Y2 ) / 2
 00140  86      COSTH = X2 - X1                                                    DIRECTIONS FOR TRANSFORMATION
 00141  87      SINTH = Y2 - Y1
 00142  88      SUMX = 1.0 / SQRT(COSTH**2+SINTH**2)
 00143  89      COSTH = COSTH * SUMX
 00144  90      SINTH = SINTH * SUMX
 00145                                                                             TRANSFORMATIONS OF POINTS
 00147  91      DMIN = 1000000.                                                    + SEARCH FOR CENTRAL POINT
 00148  92      FOR IP=1,IP9
 00149  93         XX = XO(IP) - XOA
 00150  94         YY = YO(IP) - YOA
 00151  95         YT(IP) = YY * COSTH - XX * SINTH
 00152  96         XT(IP) = XX * COSTH + YY * SINTH
 00153  97         DX = ABS(XT(IP))
 00154  98         IF DX.LT.DMIN
 00155  99         THEN
 00156 102            DMIN = DX
 00157 103            IPA = IP
 00158 104         CIF
 00159 105      CFOR
 00161 107      XC = XT(IPA)                                                       CENTRAL POINT
 00162 108      YC = YT(IPA)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00163    C     IF(LBPR.EQ.2)
 00164    C    ,PRINT 2002, (I1,XT(I1),YT(I1),I1=1,IP9)
 00165    C
 00166    C
 00167                                                                             ***************************
 00168                                                                             *      P A R A B          *
 00169                                                                             ***************************
 00171    C                                                                        DO PARABOLA FIT
 00172    C
 00174 109      S1 = 0.                                                            GET EQUATIONS
 00175 110      S2 = 0.
 00176 111      S3 = 0.
 00177 112      S4 = 0.
 00178 113      S5 = 0.
 00179 114      S6 = 0.
 00180 115      S7 = 0.
 00181 116      FOR IP = 1,IP9
 00182 117         X = XT(IP)
 00183 118         Y = YT(IP)
 00184 119         X2 = X**2
 00185 120         S1 = S1 + X
 00186 121         S2 = S2 + X2
 00187 122         S3 = S3 + X*X2
 00188 123         S4 = S4 + X2**2
 00189 124         S5 = S5 + Y*X2
 00190 125         S6 = S6 + Y*X
 00191 126         S7 = S7 + Y
 00192 127      CFOR
 00193 129      S0 = IP9
 00195 130      F1 = 1. / S4                                                       SOLVE EQUATIONS FOR PARABOLA FIT
 00196 131      XX12 = S3*F1
 00197 132      XX13 = S2*F1
 00198 133      YY1  = S5*F1
 00199 134      XX22 = S2 - S3*XX12
 00200 135      XX23 = S1 - S3*XX13
 00201 136      YY2  = S6 - S3*YY1
 00202 137      XX32 = S1 - S2*XX12
 00203 138      XX33 = S0 - S2*XX13
 00204 139      YY3  = S7 - S2*YY1
 00205 140      IF XX22.GT.XX32
 00206 141      THEN
 00207 144         XX23 = XX23 / XX22
 00208 145         YY2  = YY2  / XX22
 00209 146         PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 00210 147         PAR2 = YY2 - XX23*PAR3
 00211 148      ELSE
 00212 150         XX33 = XX33 / XX32
 00213 151         YY3  = YY3  / XX32
 00214 152         PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 00215 153         PAR2 = YY3 - XX33*PAR3
 00216 154      CIF
 00217 155      PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
 00218    C
 00220 156      XCIRC =-.5 * PAR2 / PAR1                                           CALC. CIRCLE PARAMETERS
 00221 157      YZW   = FPAR(XCIRC)
 00222 158      R0 = SIGN(1.E6,PAR1)
 00223 159      IF(ABS(PAR1).GT..5E-6) R0 = .5 / PAR1
 00224 161      YCIRC = R0 + YZW
 00225 162      R0 = ABS(R0)
 00226    C     IF(LBPR.EQ.2) PRINT 2902, PAR1,PAR2,PAR3,XCIRC,YZW,YCIRC,R0,SIG
 00227    C
 00228    C
 00230 163      IF R0.GT.2000.                                                     CHECK IF R > 2000 MM
 00231 164      THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00232    C
 00233                                                                             ===================================
 00234                                                                             =  R > 2000 ... PARABOLA IS GOOD  =
 00236    C                                                                        ===================================
 00237    C
 00239 167         SUM2 = 0.                                                       CALC. ERROR
 00240 168         ZW1 = R0**2
 00241 169         ZW2 = .5/R0
 00242 170         FOR IP=1,IP9
 00243 171            F = FPAR(XT(IP))
 00244 172            DR = YT(IP) - F
 00245 173            SUM2 = SUM2 + DR**2
 00246 174         CFOR
 00248 176         SIG = SQRT(SUM2/(IP9-3))                                        AVERAGE + SIGMA
 00249 177         DX = 0.
 00250    C     IF(LBPR.EQ.2) PRINT 2902, PAR1,PAR2,PAR3,XCIRC,YZW,YCIRC,R0,SIG
 00251 178      ELSE
 00252    C
 00253                                                                             ===================================
 00254                                                                             =   R < 2000 ... TRY CIRCLE FIT   =
 00256    C                                                                        ===================================
 00257    C
 00258                                                                             ***************************
 00259                                                                             *      C I R C L 1        *
 00261    C                                                                        ***************************
 00262                                                                             CALC. CIRCLE FROM 3 POINTS
 00263
 00265 180         IF XC.LT.0.                                                     SELECT 1. OR 2. BRANCH
 00266 181         THEN
 00267 184            X2 = XC
 00268 185            Y2 = YC
 00269 186            X1 = XT(  1)
 00270 187            Y1 = YT(  1)
 00271 188         ELSE
 00272 190            X1 = XC
 00273 191            Y1 = YC
 00274 192            X2 = XT(IP9)
 00275 193            Y2 = YT(IP9)
 00276 194         CIF
 00278 195         XCIRC = 0.                                                      INTERSECT WITH Y-AXIS
 00279 196         YCIRC = 100000.
 00280 197         DY = Y2 - Y1
 00281 198         IF(ABS(DY).GT..01)
 00282         *   YCIRC = ((X2-X1)*(X2+X1)/DY + Y2+Y1)*.5
 00283 200         IF(ABS(YCIRC).GT.100000.) YCIRC = SIGN(100000.,YCIRC)
 00284 202         T  = YCIRC - YC
 00285 203         R0 = ABS(T)
 00286 204         CHARGE = SIGN(1.,T)
 00287 205         R0 = .5*(R0 + ((YCIRC-YC)**2+XC**2) / R0)
 00288    C     IF(LBPR.EQ.2)
 00289    C    ,PRINT 2003, X1,Y1,X2,Y2,XC,YC,XCIRC,YCIRC,T,R0
 00290    C
 00291                                                                             **********************************
 00292                                                                             *  2 TRIALS IF CHANGE OF CHARGE  *
 00294    C                                                                        **********************************
 00295 206         NTRIAL = 0
 00296 207         REPEAT
 00297 208            NTRIAL = NTRIAL + 1
 00298    C
 00299                                                                             ***************************
 00300                                                                             *      T I L T C R        *
 00302    C                                                                        ***************************
 00304    C                                                                        TILT CORRECTION
 00306 209            SUM1 = 0.                                                    CALCULATE AVERAGE TILT
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00307 210            SUM2 = 0.
 00308 211            SUM3 = 0.
 00309 212            SUM4 = 0.
 00310 213            ZW1 = R0**2
 00311 214            ZW2 = .5/R0
 00312 215            FOR IP=1,IP9
 00313 216               XZW = XT(IP)
 00314 217               YZW = (XZW**2+(YT(IP)-YCIRC)**2 - ZW1) * ZW2
 00315 218               SUM1 = SUM1 + XZW
 00316 219               SUM2 = SUM2 + XZW**2
 00317 220               SUM3 = SUM3 + XZW*YZW
 00318 221               SUM4 = SUM4 + YZW
 00319    C     IF(LBPR.EQ.2)
 00320    C    ,PRINT 2004, IP,XT(IP),YT(IP),YZW,SUM1,SUM2,SUM3,SUM4
 00321 222            CFOR
 00323 224            TILT = (SUM3*IP9-SUM1*SUM4) / (SUM2*IP9-SUM1**2)             AVERAGE TILT
 00324 225            DR0  = (SUM4 - TILT*SUM1)/IP9
 00326 226            R0 = R0 + DR0                                                MODIFY RADIUS
 00327 227            DX =-TILT*R0
 00328    C     IF(LBPR.EQ.2)
 00329    C    ,PRINT 2005, TILT,DR0,DX
 00330    C
 00331    C
 00332                                                                             ***************************
 00333                                                                             *      R A D C R          *
 00335    C                                                                        ***************************
 00337    C                                                                        RADIAL CORRECTION
 00338                                                                             DET. CHANGE OF SAGITTA BY PARABOLA FIT
 00340 228            SUM1 = 0.                                                    DR = DSAG/2 + B*X**2
 00341 229            SUM2 = 0.
 00342 230            SUM3 = 0.
 00343 231            SUM4 = 0.
 00344 232            ZW1 = R0**2
 00345 233            ZW2 = .5/R0
 00346 234            FOR IP=1,IP9
 00348 235               XT(IP) = XT(IP) + DX                                      APPLY TILT CORRECTION
 00349 236               XZW = XT(IP)**2
 00350 237               YZW = (XZW+(YT(IP)-YCIRC)**2 - ZW1) * ZW2
 00351 238               SUM1 = SUM1 + XZW
 00352 239               SUM2 = SUM2 + XZW**2
 00353 240               SUM3 = SUM3 + XZW*YZW
 00354 241               SUM4 = SUM4 + YZW
 00355    C     IF(LBPR.EQ.2)
 00356    C    ,PRINT 2006, IP,XT(IP),YT(IP),YZW,SUM1,SUM2,SUM3,SUM4
 00357 242            CFOR
 00359 244            B = (SUM3*IP9-SUM1*SUM4) / (SUM2*IP9-SUM1**2)                PARAMETER
 00360 245            DSAG = (SUM4 - B*SUM1)*2. / IP9
 00361    C     IF(LBPR.EQ.2)
 00362    C    ,PRINT 2007, B,DSAG
 00364 246            SAG = (XT(IP9)-XT(1))**2 * .125/R0                           CHANGE YCIRC ACCORDINGLY
 00365 247            DR0 =-R0*DSAG/SAG
 00367 248            IF(ABS(DSAG/SAG) .GT. 0.2) DR0 = 0.                          SET DRO=0. IF DSAG/SAG > 0.2
 00368 250            R0ZW  = DR0 + R0
 00369 251            YCZW  = CHARGE*DR0 + YCIRC
 00371 252            IF ABS(YCZW).LT.100000. .AND. ABS(DR0).LT.100000.            CHECK IF CHANGE OF CHARGE
 00372 253            THEN
 00373 256               YCIRC = YCZW
 00374 257               R0    = R0ZW
 00375 258               LBCHCH= 0
 00376 259            ELSE
 00377 261               LBCHCH= 1
 00378 262            CIF
 00379    C     IF(LBPR.EQ.2)
 00380    C    ,PRINT 2010, SAG,YCIRC,R0,DR0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 00381    C
 00382                                                                             ***************************
 00383                                                                             *      R M S C A L        *
 00385    C                                                                        ***************************
 00387    C                                                                        CALCULATIONS OF RMS
 00389 263            SUM1 = 0.                                                    CALCULATE AVERAGE + SIGMA
 00390 264            SUM2 = 0.
 00391 265            ZW1 = R0**2
 00392 266            ZW2 = .5/R0
 00393 267            FOR IP=1,IP9
 00394 268               DR = ((XT(IP)-XCIRC)**2+(YT(IP)-YCIRC)**2 - ZW1) * ZW2
 00395 269               SUM1 = SUM1 + DR
 00396 270               SUM2 = SUM2 + DR**2
 00397    C     IF(LBPR.EQ.2)
 00398    C    ,PRINT 2008, IP,XT(IP),YT(IP),DR,SUM1,SUM2,R0,ZW1,ZW2
 00399 271            CFOR
 00401 273            DR0 = SUM1 / IP9                                             AVERAGE + SIGMA
 00402 274            R0 = R0 + DR0
 00403 275            YCIRC = YCIRC + DR0*CHARGE
 00404 276            SIG = 0.
 00405 277            IF(IP9.GT.3) SIG = SQRT(ABS(SUM2/IP9 - DR0**2)*IP9/(IP9-3))
 00406 279            SIG0= SQRT(SUM2/IP9)
 00407    C
 00409 280            IF(LBCHCH.EQ.0) XREPEAT                                      CHECK IF CHANGE OF CHARGE
 00411 282            IF(NTRIAL.GT.1) XREPEAT                                      STOP AFTER 2. TRIAL
 00412    C
 00414 284            YCSAV = YCIRC                                                SAVE CIRCLE PARAMETERS OF 1. TRIAL1
 00415 285            DXSAV = DX
 00416 286            SGSAV = SIG0
 00417 287            R0SAV = R0
 00418 288            CHSAV = CHARGE
 00419    C
 00421 289            YCIRC  = -YCIRC                                              SET NEW START PARAMETERS
 00422 290            R0     = ABS(YCIRC)
 00423 291            CHARGE =-CHARGE
 00424 292            FOR IP=1,IP9
 00425 293               XT(IP) = XT(IP) - DX
 00426 294            CFOR
 00427 296         UNTIL .FALSE.
 00428    C
 00430 297         IF NTRIAL.GT.1 .AND. SIG0.GT.SGSAV                              SELECT RESULTS IF 2 TRIALS
 00431 301         THEN
 00433 304            YCIRC  = YCSAV                                               RESTORE CIRCLE PARAMETERS OF 1. TRIAL1
 00434 305            DX     = DXSAV
 00435 306            SIG0   = SGSAV
 00436 307            R0     = R0SAV
 00437 308            CHARGE = CHSAVE
 00438 309         CIF
 00439    C
 00440 310      CIF
 00441    C
 00443 311      XX = XCIRC - DX                                                    TRANSFORM BACK TO INPUT SYSTEM
 00444 312      YY = YCIRC
 00445 313      X0 = XX * COSTH - YY * SINTH + XOA
 00446 314      Y0 = YY * COSTH + XX * SINTH + YOA
 00448 315      RATLR = ABS(XT(1)*2. / R0)                                         L/R RATIO
 00449    C
 00450                                                                             ***************************
 00451                                                                             *      S I G A N G        *
 00453    C                                                                        ***************************
 00455    C                                                                        CALC. SIGMA(DIRECTIONS OF TRELS)
 00457 316      SGANG  = 0.                                                        INITIALIZE SIGMA
 00458 317      RATCR  = 0.
 00459    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 00461 318      IF SIG.LE.SIGDV0                                                   CHECK IF REASONABLE FIT
 00462 319      THEN
 00464 322         NCLL  = 0                                                       GOOD FIT: GET DIRECTIONS OF TRELS
 00465 323         ICLL0 = 0
 00466 324         IP = 0
 00467 325         ITREL = MTREL
 00468 326         REPEAT
 00470 327            JPTREL = IATREL(ITREL)                                       POINTER TO COORDINATE ARRAY
 00471 328            IPTREL = SHFTR(JPTREL,16)
 00473 329            ICLL = IWRK(IPTREL)                                          COUNT # OF CELLS
 00474 330            IF(ICLL.NE.ICLL0) NCLL = NCLL + 1
 00475    C     IF(NPR.LE.5) PRINT 2901,ICLL0,ICLL,NCLL,IPTREL
 00476 332            ICLL0 = ICLL
 00478 333            IF LAND(JPTREL,1).EQ.0                                       CHECK IF LEFT /RIGHT SOLUTION
 00479 334            THEN
 00480 337               XO(IP+1) = WRK(IPTREL+ 3)
 00481 338               XO(IP+2) = WRK(IPTREL+11)
 00482 339               YO(IP+1) = WRK(IPTREL+ 4)
 00483 340               YO(IP+2) = WRK(IPTREL+12)
 00484 341               XT(IP+1) = WRK(IPTREL+ 5)
 00485 342               XT(IP+2) = WRK(IPTREL+13)
 00486 343               YT(IP+1) = WRK(IPTREL+ 6)
 00487 344               YT(IP+2) = WRK(IPTREL+14)
 00488 345            ELSE
 00489 347               XO(IP+1) = WRK(IPTREL+ 7)
 00490 348               XO(IP+2) = WRK(IPTREL+15)
 00491 349               YO(IP+1) = WRK(IPTREL+ 8)
 00492 350               YO(IP+2) = WRK(IPTREL+16)
 00493 351               XT(IP+1) = WRK(IPTREL+ 9)
 00494 352               XT(IP+2) = WRK(IPTREL+17)
 00495 353               YT(IP+1) = WRK(IPTREL+10)
 00496 354               YT(IP+2) = WRK(IPTREL+18)
 00497 355            CIF
 00498    C
 00499    C         CHECK IF BOTH POINTS GOOD
 00500 356            IF LAND(JPTREL,12).EQ.0
 00501 357            THEN
 00503 360               IF IABS(IWRK(IPTREL+2)).GT.5                              BOTH POINTS GOOD; CHECK IF >5 HITS ON TREL
 00504 361               THEN
 00506 364                  IP = IP + 2                                            USE BOTH SLOPES
 00507 365               ELSE
 00509 367                  XT(IP+1) = (XT(IP+1)+XT(IP+2)) * .5                    SHORT TREL: USE AVERAGE SLOPE ONLY
 00510 368                  YT(IP+1) = (YT(IP+1)+YT(IP+2)) * .5
 00511 369                  XO(IP+1) = (XO(IP+1)+XO(IP+2)) * .5
 00512 370                  YO(IP+1) = (YO(IP+1)+YO(IP+2)) * .5
 00513 371                  IP = IP + 1
 00514 372               CIF
 00515 373            ELSE
 00517 375               IF LAND(JPTREL, 4).NE.0                                   ONLY 1 POINT GOOD
 00518 376               THEN
 00520 379                  XT(IP+1) = XT(IP+2)                                    1. POINT BAD
 00521 380                  YT(IP+1) = YT(IP+2)
 00522 381               CIF
 00523 382               IP = IP + 1
 00524 383            CIF
 00525 384            ITREL = ITREL - 1
 00526 385         UNTIL ITREL.EQ.0
 00527 386         IP9 = IP
 00528 390         IP8 = IP - 1
 00529    C     IF(NPR.LT.40)
 00530    C    ,PRINT 2001, (I1,XO(I1),YO(I1),I1=1,IP9)
 00531    C     IF(NPR.LT.40)
 00532    C    ,PRINT 2001, (I1,XT(I1),YT(I1),I1=1,IP9)
 00533    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 00535 391         FOR IP=1,IP9                                                    CALC. SIGMA(DIRECTIONS)
 00536 392            DX = XT(IP)
 00537 393            DY = YT(IP)
 00538 394            XX = XO(IP)
 00539 395            YY = YO(IP)
 00540    C
 00542 396            IF ABS(XX-X0).LT.ABS(YY-Y0)                                  CALC. TANGENTIAL ANGLES
 00543 397            THEN
 00544 400               TG1  = DY / DX
 00545 401               TGC1 =-(XX-X0) / (YY-Y0)
 00546 402            ELSE
 00547 404               TG1  = DX / DY
 00548 405               TGC1 =-(YY-Y0) / (XX-X0)
 00549 406            CIF
 00551 407            DLTS1 = ABS((TG1-TGC1) / (1.+TG1*TGC1))                      DIFF. OF ANGLES
 00552 408            SGANG  = DLTS1**2 + SGANG
 00553 409         CFOR
 00554 411         SGANG  = SQRT(SGANG/FLOAT(IP9))
 00555 412         RATCR  = NCLL*200. / R0
 00556 413      CIF
 00557    C
 00558                                                                             ***************************
 00559                                                                             *    STORE   RESULTS      *
 00561 414      RSLT(1) = R0                                                       ***************************
 00562 415      RSLT(2) = X0
 00563 416      RSLT(3) = Y0
 00564 417      RSLT(4) = SIG
 00565 418      RSLT(5) = IP9 - 3
 00566 419      RSLT(6) = RATLR
 00567 420      RSLT(7) = SGANG
 00568 421      RSLT(8) = RATCR
 00569    C     IF(LBPR.EQ.2)
 00570    C    ,PRINT 2009, DR0,SIG,SIG0,XCIRC,YCIRC,R0
 00571    C     IF(LBPR.EQ.2)
 00572    C    ,PRINT 2991, RSLT
 00573    C
 00574 422      RETURN
 00575    C
 00576 423      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         422 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         422 TARGET STATEMENTS
 00000    C   10/02/80 102191151  MEMBER NAME  CIRCCK   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE CIRCCK(MTREL0,IATREL,RSLT)
 00002    C
 00003   3      IMPLICIT INTEGER*2 (H)
 00004   4      LOGICAL TBIT
 00005    C
 00006    C     SUBROUTINE TO ELIMINATE DOUBLE CONNECT. OF TRELS
 00007    C     AUTHOR: P. STEFFEN(78/11/21)
 00008    C
 00009    C     INPUT : IATREL(1) = # OF TRELS
 00010    C             IATREL(2) = POINTER TO 1. TREL
 00011    C             IATREL(3) = POINTER TO 2. TREL
 00012    C
 00013    C     OUTPUT: RSLT(1) = R
 00014    C             RSLT(2) = XCIRC
 00015    C             RSLT(3) = YCIRC
 00016    C             RSLT(4) = SIGMA
 00017    C             RSLT(5) = DEG. OF FREEDOM
 00018    C             RSLT(6) = LENGTH / R
 00019    C             RSLT(7) = SIGMA(DIRECTIONS)
 00020    C             RSLT(8) = #(CELLS)*200 / R
 00021    C
 00022   5      DIMENSION IATREL(1),RSLT(6),HATREL(24)
 00023    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
         6      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
         7      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
         8      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
         9      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        10      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00025    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        11      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        12      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        13      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        14      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        15      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        16      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        17      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  18      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 00028  19      EQUIVALENCE
 00029         ,           (ICELL ,IDWRK(1)),(NHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
 00030         ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
 00031    C
 00033  20      DIMENSION XO(20),YO(20), XT(20),YT(20)                             COORDINATE ARRAYS FOR CIRCLE FIT
 00034    C
 00036  21      FPAR (X) = (PAR1 *X + PAR2 )*X + PAR3                              FUNCTION
 00037    C
 00038    C2000 FORMAT('0FXYZPS:',12(I7,I3))
 00039    C2001 FORMAT('     XO:',I6,2F8.3,/,(8X,I6,2F8.3))
 00040    C2002 FORMAT('     XT:',I6,2F8.1,/,(8X,I6,2F8.1))
 00041    C2003   FORMAT(' CIRCLE:',10E12.5,/,(8X,10E12.5))
 00042    C2004     FORMAT(' LOOP(TILT):',I3,3F10.2,5E13.5)
 00043    C2005   FORMAT(' TILT + DX:',5E13.5)
 00044    C2006     FORMAT(' LOOP(SAG):',I3,3F10.2,5E13.5)
 00045    C2007   FORMAT(' B + DSAG:',5E13.5)
 00046    C2008     FORMAT(' RESIDUALS:',I3,5F10.2,3E13.5)
 00047    C2009   FORMAT(' AVERAGE + SIGMA:',9E13.5)
 00048    C2010   FORMAT(' SAG.CORR:', 8E13.5)
 00049    C2902 FORMAT('0PARABEL FIT',4F12.5,4F12.2,F8.2)
 00050    C2991 FORMAT(1X,3F10.1,F8.2,F3.0,F8.3)
 00051    C
 00052  22      DATA NPR /0/
 00053  23      NPR = NPR + 1
 00054    C
 00056  24      MTREL = IABS(MTREL0)                                               # OF TREL
 00057    C
 00059  25      SIGDV0 = RSLT(4)                                                   SAVE MAX(SIGMA)
 00060    C     LBPR = IATREL(1)
 00061    C     LBPR = SHFTR(IPPR,16)
 00062    C
 00063    C
 00064                                                                             ***************************
 00065                                                                             *      F X Y Z            *
 00067    C                                                                        ***************************
 00069    C                                                                        GET COORDINATES OF TRELS
 00070    C     LBPR = 0
 00071  26      IP = 0
 00072  27      ITREL = MTREL
 00073  28      REPEAT
 00075  29         JPTREL = IATREL(ITREL)                                          POINTER TO COORDINATE ARRAY
 00076  30         IPTREL = SHFTR(JPTREL,16)
 00077    C       IF(IPTREL.EQ.2817 .OR. IPTREL.EQ.1905) LBPR = LBPR + 1
 00079  31         IF LAND(JPTREL,1).EQ.0                                          CHECK IF LEFT /RIGHT SOLUTION
 00080  32         THEN
 00081  35            XO(IP+1) = WRK(IPTREL+ 3)
 00082  36            XO(IP+2) = WRK(IPTREL+11)
 00083  37            YO(IP+1) = WRK(IPTREL+ 4)
 00084  38            YO(IP+2) = WRK(IPTREL+12)
 00085  39         ELSE
 00086  41            XO(IP+1) = WRK(IPTREL+ 7)
 00087  42            XO(IP+2) = WRK(IPTREL+15)
 00088  43            YO(IP+1) = WRK(IPTREL+ 8)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00089  44            YO(IP+2) = WRK(IPTREL+16)
 00090  45         CIF
 00091    C
 00093  46         IF LAND(JPTREL,12).EQ.0                                         CHECK IF BOTH POINTS GOOD
 00094  47         THEN
 00095                                                                             BOTH POINTS
 00097  50            IF MTREL0.LT.0                                               CHECK IF POINTS TO BE REVERSED
 00098  51            THEN
 00099  54               ZWZ = XO(IP+1)
 00100  55               XO(IP+1) = XO(IP+2)
 00101  56               XO(IP+2) = ZWZ
 00102  57               ZWZ = YO(IP+1)
 00103  58               YO(IP+1) = YO(IP+2)
 00104  59               YO(IP+2) = ZWZ
 00105  60            CIF
 00106  61            IP = IP + 2
 00107  62         ELSE
 00109  64            IF LAND(JPTREL, 4).NE.0                                      ONLY 1 POINT GOOD
 00110  65            THEN
 00112  68               XO(IP+1) = XO(IP+2)                                       1. POINT BAD
 00113  69               YO(IP+1) = YO(IP+2)
 00114  70            CIF
 00115  71            IP = IP + 1
 00116  72         CIF
 00117  73         ITREL = ITREL - 1
 00118  74      UNTIL ITREL.EQ.0
 00119  75      IP9 = IP
 00120  79      IP8 = IP - 1
 00121    C     IF(MTREL.NE.2) LBPR = 0
 00122    C     IF(LBPR.EQ.2)
 00123    C    ,PRINT 2001, (I1,XO(I1),YO(I1),I1=1,IP9)
 00124    C
 00125    C
 00126                                                                             ***************************
 00127                                                                             *      T R A N S F        *
 00129    C                                                                        ***************************
 00131    C                                                                        TRANSFORM COORDINATES
 00133  80      X1 = XO(  1)                                                       1. + LAST POINT + AVERAGE
 00134  81      X2 = XO(IP9)
 00135  82      Y1 = YO(  1)
 00136  83      Y2 = YO(IP9)
 00137  84      XOA = ( X1 + X2 ) / 2
 00138  85      YOA = ( Y1 + Y2 ) / 2
 00140  86      COSTH = X2 - X1                                                    DIRECTIONS FOR TRANSFORMATION
 00141  87      SINTH = Y2 - Y1
 00142  88      SUMX = 1.0 / SQRT(COSTH**2+SINTH**2)
 00143  89      COSTH = COSTH * SUMX
 00144  90      SINTH = SINTH * SUMX
 00145                                                                             TRANSFORMATIONS OF POINTS
 00147  91      DMIN = 1000000.                                                    + SEARCH FOR CENTRAL POINT
 00148  92      FOR IP=1,IP9
 00149  93         XX = XO(IP) - XOA
 00150  94         YY = YO(IP) - YOA
 00151  95         YT(IP) = YY * COSTH - XX * SINTH
 00152  96         XT(IP) = XX * COSTH + YY * SINTH
 00153  97         DX = ABS(XT(IP))
 00154  98         IF DX.LT.DMIN
 00155  99         THEN
 00156 102            DMIN = DX
 00157 103            IPA = IP
 00158 104         CIF
 00159 105      CFOR
 00161 107      XC = XT(IPA)                                                       CENTRAL POINT
 00162 108      YC = YT(IPA)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00163    C     IF(LBPR.EQ.2)
 00164    C    ,PRINT 2002, (I1,XT(I1),YT(I1),I1=1,IP9)
 00165    C
 00166    C
 00167                                                                             ***************************
 00168                                                                             *      P A R A B          *
 00169                                                                             ***************************
 00171    C                                                                        DO PARABOLA FIT
 00172    C
 00174 109      S1 = 0.                                                            GET EQUATIONS
 00175 110      S2 = 0.
 00176 111      S3 = 0.
 00177 112      S4 = 0.
 00178 113      S5 = 0.
 00179 114      S6 = 0.
 00180 115      S7 = 0.
 00181 116      FOR IP = 1,IP9
 00182 117         X = XT(IP)
 00183 118         Y = YT(IP)
 00184 119         X2 = X**2
 00185 120         S1 = S1 + X
 00186 121         S2 = S2 + X2
 00187 122         S3 = S3 + X*X2
 00188 123         S4 = S4 + X2**2
 00189 124         S5 = S5 + Y*X2
 00190 125         S6 = S6 + Y*X
 00191 126         S7 = S7 + Y
 00192 127      CFOR
 00193 129      S0 = IP9
 00195 130      F1 = 1. / S4                                                       SOLVE EQUATIONS FOR PARABOLA FIT
 00196 131      XX12 = S3*F1
 00197 132      XX13 = S2*F1
 00198 133      YY1  = S5*F1
 00199 134      XX22 = S2 - S3*XX12
 00200 135      XX23 = S1 - S3*XX13
 00201 136      YY2  = S6 - S3*YY1
 00202 137      XX32 = S1 - S2*XX12
 00203 138      XX33 = S0 - S2*XX13
 00204 139      YY3  = S7 - S2*YY1
 00205 140      IF XX22.GT.XX32
 00206 141      THEN
 00207 144         XX23 = XX23 / XX22
 00208 145         YY2  = YY2  / XX22
 00209 146         PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 00210 147         PAR2 = YY2 - XX23*PAR3
 00211 148      ELSE
 00212 150         XX33 = XX33 / XX32
 00213 151         YY3  = YY3  / XX32
 00214 152         PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 00215 153         PAR2 = YY3 - XX33*PAR3
 00216 154      CIF
 00217 155      PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
 00218    C
 00220 156      XCIRC =-.5 * PAR2 / PAR1                                           CALC. CIRCLE PARAMETERS
 00221 157      YZW   = FPAR(XCIRC)
 00222 158      R0 = SIGN(1.E6,PAR1)
 00223 159      IF(ABS(PAR1).GT..5E-6) R0 = .5 / PAR1
 00224 161      YCIRC = R0 + YZW
 00225 162      R0 = ABS(R0)
 00226    C     IF(LBPR.EQ.2) PRINT 2902, PAR1,PAR2,PAR3,XCIRC,YZW,YCIRC,R0,SIG
 00227    C
 00228    C
 00230 163      IF R0.GT.2000.                                                     CHECK IF R > 2000 MM
 00231 164      THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00232    C
 00233                                                                             ===================================
 00234                                                                             =  R > 2000 ... PARABOLA IS GOOD  =
 00236    C                                                                        ===================================
 00237    C
 00239 167         SUM2 = 0.                                                       CALC. ERROR
 00240 168         ZW1 = R0**2
 00241 169         ZW2 = .5/R0
 00242 170         FOR IP=1,IP9
 00243 171            F = FPAR(XT(IP))
 00244 172            DR = YT(IP) - F
 00245 173            SUM2 = SUM2 + DR**2
 00246 174         CFOR
 00248 176         SIG = SQRT(SUM2/(IP9-3))                                        AVERAGE + SIGMA
 00249 177         DX = 0.
 00250    C     IF(LBPR.EQ.2) PRINT 2902, PAR1,PAR2,PAR3,XCIRC,YZW,YCIRC,R0,SIG
 00251 178      ELSE
 00252    C
 00253                                                                             ===================================
 00254                                                                             =   R < 2000 ... TRY CIRCLE FIT   =
 00256    C                                                                        ===================================
 00257    C
 00258                                                                             ***************************
 00259                                                                             *      C I R C L 1        *
 00261    C                                                                        ***************************
 00262                                                                             CALC. CIRCLE FROM 3 POINTS
 00263
 00265 180         IF XC.LT.0.                                                     SELECT 1. OR 2. BRANCH
 00266 181         THEN
 00267 184            X2 = XC
 00268 185            Y2 = YC
 00269 186            X1 = XT(  1)
 00270 187            Y1 = YT(  1)
 00271 188         ELSE
 00272 190            X1 = XC
 00273 191            Y1 = YC
 00274 192            X2 = XT(IP9)
 00275 193            Y2 = YT(IP9)
 00276 194         CIF
 00278 195         XCIRC = 0.                                                      INTERSECT WITH Y-AXIS
 00279 196         YCIRC = 100000.
 00280 197         DY = Y2 - Y1
 00281 198         IF(ABS(DY).GT..01)
 00282         *   YCIRC = ((X2-X1)*(X2+X1)/DY + Y2+Y1)*.5
 00283 200         IF(ABS(YCIRC).GT.100000.) YCIRC = SIGN(100000.,YCIRC)
 00284 202         T  = YCIRC - YC
 00285 203         R0 = ABS(T)
 00286 204         CHARGE = SIGN(1.,T)
 00287 205         R0 = .5*(R0 + ((YCIRC-YC)**2+XC**2) / R0)
 00288    C     IF(LBPR.EQ.2)
 00289    C    ,PRINT 2003, X1,Y1,X2,Y2,XC,YC,XCIRC,YCIRC,T,R0
 00290    C
 00291                                                                             **********************************
 00292                                                                             *  2 TRIALS IF CHANGE OF CHARGE  *
 00294    C                                                                        **********************************
 00295 206         NTRIAL = 0
 00296 207         REPEAT
 00297 208            NTRIAL = NTRIAL + 1
 00298    C
 00299                                                                             ***************************
 00300                                                                             *      T I L T C R        *
 00302    C                                                                        ***************************
 00304    C                                                                        TILT CORRECTION
 00306 209            SUM1 = 0.                                                    CALCULATE AVERAGE TILT
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00307 210            SUM2 = 0.
 00308 211            SUM3 = 0.
 00309 212            SUM4 = 0.
 00310 213            ZW1 = R0**2
 00311 214            ZW2 = .5/R0
 00312 215            FOR IP=1,IP9
 00313 216               XZW = XT(IP)
 00314 217               YZW = (XZW**2+(YT(IP)-YCIRC)**2 - ZW1) * ZW2
 00315 218               SUM1 = SUM1 + XZW
 00316 219               SUM2 = SUM2 + XZW**2
 00317 220               SUM3 = SUM3 + XZW*YZW
 00318 221               SUM4 = SUM4 + YZW
 00319    C     IF(LBPR.EQ.2)
 00320    C    ,PRINT 2004, IP,XT(IP),YT(IP),YZW,SUM1,SUM2,SUM3,SUM4
 00321 222            CFOR
 00323 224            TILT = (SUM3*IP9-SUM1*SUM4) / (SUM2*IP9-SUM1**2)             AVERAGE TILT
 00324 225            DR0  = (SUM4 - TILT*SUM1)/IP9
 00326 226            R0 = R0 + DR0                                                MODIFY RADIUS
 00327 227            DX =-TILT*R0
 00328    C     IF(LBPR.EQ.2)
 00329    C    ,PRINT 2005, TILT,DR0,DX
 00330    C
 00331    C
 00332                                                                             ***************************
 00333                                                                             *      R A D C R          *
 00335    C                                                                        ***************************
 00337    C                                                                        RADIAL CORRECTION
 00338                                                                             DET. CHANGE OF SAGITTA BY PARABOLA FIT
 00340 228            SUM1 = 0.                                                    DR = DSAG/2 + B*X**2
 00341 229            SUM2 = 0.
 00342 230            SUM3 = 0.
 00343 231            SUM4 = 0.
 00344 232            ZW1 = R0**2
 00345 233            ZW2 = .5/R0
 00346 234            FOR IP=1,IP9
 00348 235               XT(IP) = XT(IP) + DX                                      APPLY TILT CORRECTION
 00349 236               XZW = XT(IP)**2
 00350 237               YZW = (XZW+(YT(IP)-YCIRC)**2 - ZW1) * ZW2
 00351 238               SUM1 = SUM1 + XZW
 00352 239               SUM2 = SUM2 + XZW**2
 00353 240               SUM3 = SUM3 + XZW*YZW
 00354 241               SUM4 = SUM4 + YZW
 00355    C     IF(LBPR.EQ.2)
 00356    C    ,PRINT 2006, IP,XT(IP),YT(IP),YZW,SUM1,SUM2,SUM3,SUM4
 00357 242            CFOR
 00359 244            B = (SUM3*IP9-SUM1*SUM4) / (SUM2*IP9-SUM1**2)                PARAMETER
 00360 245            DSAG = (SUM4 - B*SUM1)*2. / IP9
 00361    C     IF(LBPR.EQ.2)
 00362    C    ,PRINT 2007, B,DSAG
 00364 246            SAG = (XT(IP9)-XT(1))**2 * .125/R0                           CHANGE YCIRC ACCORDINGLY
 00365 247            DR0 =-R0*DSAG/SAG
 00367 248            IF(ABS(DSAG/SAG) .GT. 0.2) DR0 = 0.                          SET DRO=0. IF DSAG/SAG > 0.2
 00368 250            R0ZW  = DR0 + R0
 00369 251            YCZW  = CHARGE*DR0 + YCIRC
 00371 252            IF ABS(YCZW).LT.100000. .AND. ABS(DR0).LT.100000.            CHECK IF CHANGE OF CHARGE
 00372 253            THEN
 00373 256               YCIRC = YCZW
 00374 257               R0    = R0ZW
 00375 258               LBCHCH= 0
 00376 259            ELSE
 00377 261               LBCHCH= 1
 00378 262            CIF
 00379    C     IF(LBPR.EQ.2)
 00380    C    ,PRINT 2010, SAG,YCIRC,R0,DR0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 00381    C
 00382                                                                             ***************************
 00383                                                                             *      R M S C A L        *
 00385    C                                                                        ***************************
 00387    C                                                                        CALCULATIONS OF RMS
 00389 263            SUM1 = 0.                                                    CALCULATE AVERAGE + SIGMA
 00390 264            SUM2 = 0.
 00391 265            ZW1 = R0**2
 00392 266            ZW2 = .5/R0
 00393 267            FOR IP=1,IP9
 00394 268               DR = ((XT(IP)-XCIRC)**2+(YT(IP)-YCIRC)**2 - ZW1) * ZW2
 00395 269               SUM1 = SUM1 + DR
 00396 270               SUM2 = SUM2 + DR**2
 00397    C     IF(LBPR.EQ.2)
 00398    C    ,PRINT 2008, IP,XT(IP),YT(IP),DR,SUM1,SUM2,R0,ZW1,ZW2
 00399 271            CFOR
 00401 273            DR0 = SUM1 / IP9                                             AVERAGE + SIGMA
 00402 274            R0 = R0 + DR0
 00403 275            YCIRC = YCIRC + DR0*CHARGE
 00404 276            SIG = 0.
 00405 277            IF(IP9.GT.3) SIG = SQRT(ABS(SUM2/IP9 - DR0**2)*IP9/(IP9-3))
 00406 279            SIG0= SQRT(SUM2/IP9)
 00407    C
 00409 280            IF(LBCHCH.EQ.0) XREPEAT                                      CHECK IF CHANGE OF CHARGE
 00411 282            IF(NTRIAL.GT.1) XREPEAT                                      STOP AFTER 2. TRIAL
 00412    C
 00414 284            YCSAV = YCIRC                                                SAVE CIRCLE PARAMETERS OF 1. TRIAL1
 00415 285            DXSAV = DX
 00416 286            SGSAV = SIG0
 00417 287            R0SAV = R0
 00418 288            CHSAV = CHARGE
 00419    C
 00421 289            YCIRC  = -YCIRC                                              SET NEW START PARAMETERS
 00422 290            R0     = ABS(YCIRC)
 00423 291            CHARGE =-CHARGE
 00424 292            FOR IP=1,IP9
 00425 293               XT(IP) = XT(IP) - DX
 00426 294            CFOR
 00427 296         UNTIL .FALSE.
 00428    C
 00430 297         IF NTRIAL.GT.1 .AND. SIG0.GT.SGSAV                              SELECT RESULTS IF 2 TRIALS
 00431 301         THEN
 00433 304            YCIRC  = YCSAV                                               RESTORE CIRCLE PARAMETERS OF 1. TRIAL1
 00434 305            DX     = DXSAV
 00435 306            SIG0   = SGSAV
 00436 307            R0     = R0SAV
 00437 308            CHARGE = CHSAVE
 00438 309         CIF
 00439    C
 00440 310      CIF
 00441    C
 00443 311      XX = XCIRC - DX                                                    TRANSFORM BACK TO INPUT SYSTEM
 00444 312      YY = YCIRC
 00445 313      X0 = XX * COSTH - YY * SINTH + XOA
 00446 314      Y0 = YY * COSTH + XX * SINTH + YOA
 00448 315      RATLR = ABS(XT(1)*2. / R0)                                         L/R RATIO
 00449    C
 00450                                                                             ***************************
 00451                                                                             *      S I G A N G        *
 00453    C                                                                        ***************************
 00455    C                                                                        CALC. SIGMA(DIRECTIONS OF TRELS)
 00457 316      SGANG  = 0.                                                        INITIALIZE SIGMA
 00458 317      RATCR  = 0.
 00459    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 00461 318      IF SIG.LE.SIGDV0                                                   CHECK IF REASONABLE FIT
 00462 319      THEN
 00464 322         NCLL  = 0                                                       GOOD FIT: GET DIRECTIONS OF TRELS
 00465 323         ICLL0 = 0
 00466 324         IP = 0
 00467 325         ITREL = MTREL
 00468 326         REPEAT
 00470 327            JPTREL = IATREL(ITREL)                                       POINTER TO COORDINATE ARRAY
 00471 328            IPTREL = SHFTR(JPTREL,16)
 00473 329            ICLL = IWRK(IPTREL)                                          COUNT # OF CELLS
 00474 330            IF(ICLL.NE.ICLL0) NCLL = NCLL + 1
 00475    C     IF(NPR.LE.5) PRINT 2901,ICLL0,ICLL,NCLL,IPTREL
 00476 332            ICLL0 = ICLL
 00478 333            IF LAND(JPTREL,1).EQ.0                                       CHECK IF LEFT /RIGHT SOLUTION
 00479 334            THEN
 00480 337               XO(IP+1) = WRK(IPTREL+ 3)
 00481 338               XO(IP+2) = WRK(IPTREL+11)
 00482 339               YO(IP+1) = WRK(IPTREL+ 4)
 00483 340               YO(IP+2) = WRK(IPTREL+12)
 00484 341               XT(IP+1) = WRK(IPTREL+ 5)
 00485 342               XT(IP+2) = WRK(IPTREL+13)
 00486 343               YT(IP+1) = WRK(IPTREL+ 6)
 00487 344               YT(IP+2) = WRK(IPTREL+14)
 00488 345            ELSE
 00489 347               XO(IP+1) = WRK(IPTREL+ 7)
 00490 348               XO(IP+2) = WRK(IPTREL+15)
 00491 349               YO(IP+1) = WRK(IPTREL+ 8)
 00492 350               YO(IP+2) = WRK(IPTREL+16)
 00493 351               XT(IP+1) = WRK(IPTREL+ 9)
 00494 352               XT(IP+2) = WRK(IPTREL+17)
 00495 353               YT(IP+1) = WRK(IPTREL+10)
 00496 354               YT(IP+2) = WRK(IPTREL+18)
 00497 355            CIF
 00498    C
 00499    C         CHECK IF BOTH POINTS GOOD
 00500 356            IF LAND(JPTREL,12).EQ.0
 00501 357            THEN
 00503 360               IF IABS(IWRK(IPTREL+2)).GT.5                              BOTH POINTS GOOD; CHECK IF >5 HITS ON TREL
 00504 361               THEN
 00506 364                  IP = IP + 2                                            USE BOTH SLOPES
 00507 365               ELSE
 00509 367                  XT(IP+1) = (XT(IP+1)+XT(IP+2)) * .5                    SHORT TREL: USE AVERAGE SLOPE ONLY
 00510 368                  YT(IP+1) = (YT(IP+1)+YT(IP+2)) * .5
 00511 369                  XO(IP+1) = (XO(IP+1)+XO(IP+2)) * .5
 00512 370                  YO(IP+1) = (YO(IP+1)+YO(IP+2)) * .5
 00513 371                  IP = IP + 1
 00514 372               CIF
 00515 373            ELSE
 00517 375               IF LAND(JPTREL, 4).NE.0                                   ONLY 1 POINT GOOD
 00518 376               THEN
 00520 379                  XT(IP+1) = XT(IP+2)                                    1. POINT BAD
 00521 380                  YT(IP+1) = YT(IP+2)
 00522 381               CIF
 00523 382               IP = IP + 1
 00524 383            CIF
 00525 384            ITREL = ITREL - 1
 00526 385         UNTIL ITREL.EQ.0
 00527 386         IP9 = IP
 00528 390         IP8 = IP - 1
 00529    C     IF(NPR.LT.40)
 00530    C    ,PRINT 2001, (I1,XO(I1),YO(I1),I1=1,IP9)
 00531    C     IF(NPR.LT.40)
 00532    C    ,PRINT 2001, (I1,XT(I1),YT(I1),I1=1,IP9)
 00533    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 00535 391         FOR IP=1,IP9                                                    CALC. SIGMA(DIRECTIONS)
 00536 392            DX = XT(IP)
 00537 393            DY = YT(IP)
 00538 394            XX = XO(IP)
 00539 395            YY = YO(IP)
 00540    C
 00542 396            IF ABS(XX-X0).LT.ABS(YY-Y0)                                  CALC. TANGENTIAL ANGLES
 00543 397            THEN
 00544 400               TG1  = DY / DX
 00545 401               TGC1 =-(XX-X0) / (YY-Y0)
 00546 402            ELSE
 00547 404               TG1  = DX / DY
 00548 405               TGC1 =-(YY-Y0) / (XX-X0)
 00549 406            CIF
 00551 407            DLTS1 = ABS((TG1-TGC1) / (1.+TG1*TGC1))                      DIFF. OF ANGLES
 00552 408            SGANG  = DLTS1**2 + SGANG
 00553 409         CFOR
 00554 411         SGANG  = SQRT(SGANG/FLOAT(IP9))
 00555 412         RATCR  = NCLL*200. / R0
 00556 413      CIF
 00557    C
 00558                                                                             ***************************
 00559                                                                             *    STORE   RESULTS      *
 00561 414      RSLT(1) = R0                                                       ***************************
 00562 415      RSLT(2) = X0
 00563 416      RSLT(3) = Y0
 00564 417      RSLT(4) = SIG
 00565 418      RSLT(5) = IP9 - 3
 00566 419      RSLT(6) = RATLR
 00567 420      RSLT(7) = SGANG
 00568 421      RSLT(8) = RATCR
 00569    C     IF(LBPR.EQ.2)
 00570    C    ,PRINT 2009, DR0,SIG,SIG0,XCIRC,YCIRC,R0
 00571    C     IF(LBPR.EQ.2)
 00572    C    ,PRINT 2991, RSLT
 00573    C
 00574 422      RETURN
 00575    C
 00576 423      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         422 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         422 TARGET STATEMENTS
 00000    C   29/07/80 102191150  MEMBER NAME  CKTRKO   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE CKTRKO(LBTRCK,LBCELL)
 00002    C
 00003    C        CHECK TRACK FROM ORIGIN
 00004    C        P. STEFFEN                    29/07/80
 00005    C
 00006   3      IMPLICIT INTEGER*2 (H)
 00007    C
          C----------------------------------------------------------------------
          C             MACRO CDATA .... BOS COMMON.
          C
          C             THIS MACRO ONLY DEFINES THE IDATA/HDATA/ADATA NAMES.
          C             THE ACTUAL SIZE OF /BCS/ IS FIXED ON MACRO CBCSMX
          C             OR BY OTHER MEANS. A DEFAULT SIZE OF 40000 IS GIVEN HERE.
          C
          C----------------------------------------------------------------------
          C
         4      COMMON /BCS/ IDATA(40000)
         5      DIMENSION HDATA(80000),ADATA(40000),IPNT(50)
         6      EQUIVALENCE (HDATA(1),IDATA(1),ADATA(1)),(IPNT(1),IDATA(55))
         7      EQUIVALENCE (NWORD,IPNT(50))
          C
          C------------------------ END OF MACRO CDATA --------------------------
          C----------------------------------------------------------------------
          C           MACRO CCYCP .... JET CHAMBER HIT POINTERS (PATREC)
          C----------------------------------------------------------------------
         8      INTEGER*4 HPTSEC
         9      COMMON/CCYCP/HPTSEC(98)
 00016    C     HPTSEC(I) = CDATA POINTER TO 1ST I*2 WORD FOR 1ST HIT OF CELL I
          C------------------------ END OF MACRO CCYCP --------------------------
 00010    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        10      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        11      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        12      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        13      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        14      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        15      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        16      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  17      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 00013    C
 00014  18      EQUIVALENCE
 00015         ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
 00016         ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
 00017         ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
 00018    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        19      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        20      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        21      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        22      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        23      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00020    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  24      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
 00500         +                  RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,
 00510         +                  ZRESOL,ZNORM,ZAL,ZSCAL,DRIDEV,DRICOS,DRISIN,
 00600         +                  PEDES,TZERO(3),DRIROT(96,2),SINDRI(96,2),
 00701         +                  COSDRI(96,2),DRIVEL(96,2),T0FIX(3),
 00800         +                  ABERR(8), DUMJDC(20)
 00900    C
 01100    C      BLOCK DATA SET TO MC VALUES, KALIBR WILL SET REAL DATA VALUES
 01210    C--->  A CHANGE OF THIS COMMON MUST BE DONE SIMULTANEOUSLY WITH  <----
 01220    C--->  A CHANGE OF THE BLOCK DATA                                <----
 01230    C
 01300    C--------------------------- END OF MACRO CJDRCH -----------------------
 01400    C
          C----------------------------------------------------------------------
          C           MACRO CDSMAX .... PATTERN RECOGNITION CONSTANTS.
          C----------------------------------------------------------------------
        25      COMMON/CDSMAX/DSMAX(16,3,2),DIRWR1(24,2),DIRWR3(48,2)
               *             ,DHALF(16,3,2),DTWICE(16,3,2),HMCH(16,3,2)
               *             ,IBCK(9),DBCK(30),TRMATS(96,2),TRMATC(96,2)
          C------------------------ END OF MACRO CDSMAX -------------------------
 00023    C
 00025  26      INTEGER MKLY(16) /1,2,4,8,16,32,64,128,256,512,1024,2048,          MASKS FOR HITS IN LAYERS OF JETC
 00026         ,                  Z1000,Z2000,Z4000,Z8000/
 00027    C
 00029  27      INTEGER MKDDCL(3) /Z01,Z02,Z04/, LBDDCL /ZFFFF/                    MASKS FOR DEAD CELL BITS
 00030    C
 00032  28      INTEGER MKBDCL(3) /Z10,Z20,Z40/                                    MASK FOR TRACKS AT CELL WALL
 00033    C
 00035  29      REAL RDLIM(5,2) / -2.0, -1.0, 1.0, 2.0, 8.5,                       ROAD LIMITS
 00036         ,                  -3.0, -2.0, 2.0, 3.0, 8.5/
 00037    C
 00039  30      DATA INDLM /-1/                                                    INITIALIZE INDEX FOR ROAD LIMITS
 00040    C
 00041  31      DIMENSION  LBHT(15)
 00042    C
 00043    C2001 FORMAT('0ROAD LIMITS:',I2,5F6.1)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00044    C2003 FORMAT(' CKTRK:',3I3,5X,5(1X,Z4),5X,5(1X,Z4),5X,5(1X,Z4))
 00045    C2005 FORMAT('0TRACK:',I6,/,(1X,3I6,4F8.1,I4,F6.2,2I4,F8.3,I6,F8.1))
 00046    C
 00048  32      LBTRCK = 0                                                         INITIALIZE RETURN LABEL
 00049    C
 00051  33      CALL SETS(LBHT(1),0,60,0)                                          INITIALIZE LABELS
 00052    C
 00053                                                                             LOOP OVER ALL HITS + SET BITS FOR HITS IN LAYERS
 00055  34      JRING0 = 0                                                         PREVIOUS RING #
 00056  35      FOR IP = HPCO0,HPCO9,HLDCO
 00057  36         ILAY   = IWRK(IP   )
 00058  37         JRING  = IWRK(IP+12)
 00059  38         LBGOOD = IWRK(IP+ 7)
 00060  39         DF     = WRK (IP+13)*IWRK(IP+2)
 00061    C
 00063  40         IF JRING.NE.JRING0                                              CHECK IF RING # CHANGES
 00064  41         THEN
 00065  44            JRING0 = JRING
 00067  45            INDLM1 = 1                                                   SET INDEX FPOR ROAD LIMITS
 00068  46            IF(LAND(MKBDCL(JRING),LBCELL).NE.0) INDLM1 = 2
 00070  48            IF INDLM1.NE.INDLM                                           CHANG LIMITS IF NEW INDEX
 00071  49            THEN
 00072  52               INDLM = INDLM1
 00073  53               RDLM1 = RDLIM(1,INDLM)
 00074  54               RDLM2 = RDLIM(2,INDLM)
 00075  55               RDLM3 = RDLIM(3,INDLM)
 00076  56               RDLM4 = RDLIM(4,INDLM)
 00077  57               RDLM5 = RDLIM(5,INDLM)
 00078    C     PRINT 2001, INDLM,RDLM1,RDLM2,RDLM3,RDLM4,RDLM5
 00079  58            CIF
 00080  59         CIF
 00081    C
 00083  60         IF LBGOOD .NE. 16                                               EXCLUDE DOUBLE HITS FROM L/R AMB.
 00084  61         THEN
 00086  64            LBGOOD = 1                                                   SET LBGOOD
 00087  65            IF(DF.LE. RDLM1 .OR.  DF.GE. RDLM5) LBGOOD = 5
 00088  67            IF(DF.GE. RDLM1 .AND. DF.LT. RDLM2) LBGOOD = 2
 00089  69            IF(DF.GE. RDLM3 .AND. DF.LT. RDLM4) LBGOOD = 3
 00090  71            IF(DF.GE. RDLM4 .AND. DF.LT. RDLM5) LBGOOD = 4
 00091  73            INDEX = JRING*5 - 5 + LBGOOD
 00092  74            LBHT(INDEX) = LOR(LBHT(INDEX),MKLY(ILAY+1))
 00093  75         CIF
 00094  76      CFOR
 00095    C
 00097  78      LMGAP = 3
 00098  79      MGAP  = 0
 00099  80      MGAP1 = 0
 00100  81      MGAPM = 0
 00101  82      MCON  = 0
 00102  83      ILAYR = 0
 00103  84      ILLST = 0
 00104  85      NHGD  = 0
 00106  86      LBOUND = 0                                                         LABEL FOR BIG GAP AT CELL BOUND
 00107    C
 00109  87      JRING = 0                                                          LOOP OVER ALL RINGS + LAYERS
 00110  88      REPEAT
 00111  89         JRING = JRING + 1
 00112  90         INDEX = JRING*5 - 5
 00113  91         NHGC  = 0
 00114  92         NHTRC = 0
 00115  93         LB1   = LBHT(INDEX + 1)
 00117  94         PERFORM CKGDHT                                                  COVER SINGLE MISSING GOOD HITS
 00118    C
 00119  97         LB2   = LBHT(INDEX + 2)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00120  98         LB3   = LBHT(INDEX + 3)
 00121    C
 00123  99         LB4   = LBHT(INDEX + 4)                                         LABEL FOR COVERED HITS
 00125 100         IF(LAND(MKDDCL(JRING),LBCELL).NE.0) LB4 = LBDDCL                SET BITS FOR COVERED HITS IF DEAD CELL
 00126    C
 00127 102         LB5   = LBHT(INDEX + 5)
 00128 103         LBCV  = LOR(  LB3,  LB4)
 00129    C
 00131 104         IF LBCV.NE.0                                                    CONSISTENCY CHECK OF COVERED HITS
 00132 105         THEN
 00133 108            PERFORM CKCVHT
 00134 111         CIF
 00135    C
 00136 112         LBGC  = LOR( LBCV,  LB1)
 00137 113         LBTRC = LOR( LBGC,  LB2)
 00138 114         LBHIT = LOR(LBTRC,  LB4)
 00139    C
 00140 115         IL = 0
 00141 116         WHILE IL.LT.16
 00142 118            IL    = IL    + 1
 00143 122            ILAYR = ILAYR + 1
 00144 123            MKLY1 = MKLY(IL)
 00145 124            IF LAND(LBGC,MKLY1).EQ.0
 00146 125            THEN
 00148 128               IF IL.GT.2 .AND. IL.LT.15                                 COUNT GAPS EXCEPT LAYERS 1,2,15,16
 00149 129               THEN
 00150 132                  MGAP  = MGAP  + 1
 00151 133                  MGAP1 = MGAP1+ 1
 00152 134                  MCON  = 0
 00153 135               CIF
 00154 136            ELSE
 00155 138               NHGC  = NHGC + 1
 00156 139               MCON  = MCON + 1
 00157 140               IF MCON.GE.2 .OR. MGAP1.EQ.1
 00158 141               THEN
 00159 144                  MGAP  = 0
 00160 145                  MGAPM = 0
 00161 146                  ILLST = ILAYR
 00162 147                  IF(MCON.EQ.4) LBOUND = 0
 00163 149               CIF
 00164 150               MGAPM = MAX0(MGAPM,MGAP1)
 00165 151               MGAP1 = 0
 00166 152            CIF
 00167 153            IF(LAND(LBTRC,MKLY1).NE.0) NHTRC = NHTRC + 1
 00168 155            IF(LAND(LB1  ,MKLY1).NE.0) NHGD  = NHGD  + 1
 00169 157            IF MGAPM.GE.4 .OR. MGAP.GE.6
 00170 158            THEN
 00172 161               LBACC = 0                                                 CHECK IF GAP AT CELL BOUND
 00173 162               IF(LAND(MKBDCL(JRING),LBCELL).NE.0 .AND. MGAPM.LE.6
 00174         ?         .AND. MGAP.LE.7) LBACC = 1
 00175    C           IF(IL.GE.15 .OR. IL.LE.5) LBACC = 1
 00176 164               IF LBACC.NE.0
 00177 165               THEN
 00178 168                  LBOUND = 1
 00179 169                  ILLSTB = ILLST
 00180 170               ELSE
 00181 172                  LBTRCK = ILLST
 00182 173                  XREPEAT
 00183 174               CIF
 00184 175            CIF
 00185 176         CWHILE
 00186    C
 00188    C       IF NHTRC.LT.10                                                   CHECK # OF HITS
 00189    C       THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00190    C         LBTRCK =-JRING*100
 00191    C         XREPEAT
 00192    C       CIF
 00193 178      UNTIL JRING.EQ.3
 00194    C
 00195 179      IF(LBTRCK.EQ. 0) LBTRCK = ILLST
 00196 184      IF(LBOUND.NE. 0) LBTRCK = ILLSTB
 00197 186      IF(NHGD  .LT. 8 .AND. LBTRCK.GT.0) LBTRCK =-LBTRCK
 00198    C     IF(LBTRCK.LE.16) PRINT 2005, ICELL,(WRK(I),I=HPCO0,HPCO9)
 00199    C     PRINT 2003, ICELL,LBTRCK,NHGD, LBHT
 00200    C
 00201 188      RETURN
 00202    C
 00203    C
 00204                                                                             *************************
 00205                                                                             *      M K G D H T      *
 00207    C                                                                        *************************
 00208    C
 00210 189      PROC CKGDHT                                                        ALLOW SINGEL MISSING HIT BETWEEN GOOD ONES
 00211    C
 00213 190         LBGD2 = SHFTL(LB1 ,1)                                           SHIFT LABEL BY 1 BIT
 00214    C
 00216 191         MKGD1 = 7                                                       LOOP OVER HITS + DELETE SINGLES
 00217 192         MKGD2 = 5
 00218 193         MKGD3 = 2
 00219 194         FOR IL=1,16
 00220 195            LBZW  = LAND(LBGD2,MKGD1)
 00221 196            IF LBZW.EQ.MKGD2
 00222 197            THEN
 00223 200               LBGD2 = LOR(MKGD3,LBGD2)
 00224 201            CIF
 00225 202            MKGD1 = SHFTL(MKGD1,1)
 00226 203            MKGD2 = SHFTL(MKGD2,1)
 00227 204            MKGD3 = SHFTL(MKGD3,1)
 00228 205         CFOR
 00229 207         LBPR = SHFTR(LBGD2,1)
 00230 208         LB1  = SHFTR(LBGD2,1)
 00231    C
 00232 209      CPROC
 00233    C
 00234    C
 00235                                                                             *************************
 00236                                                                             *      C K C V H T      *
 00238    C                                                                        *************************
 00239    C
 00241 211      PROC CKCVHT                                                        CHECK BITS FOR COVERED HITS
 00242    C
 00244 212         LBCV2 = SHFTL(LBCV,1)                                           SHIFT LABEL BY 1 BIT
 00245    C
 00247 213         MKCV1 = 7                                                       LOOP OVER HITS + DELETE SINGLES
 00248 214         MKCV2 = 2
 00249 215         FOR IL=1,16
 00250 216            LBZW  = LAND(LBCV2,MKCV1)
 00251 217            IF LBZW.EQ.MKCV2
 00252 218            THEN
 00253 221               LBCV2 = LAND(LCOMPL(MKCV2),LBCV2)
 00254 222            CIF
 00255 223            MKCV1 = SHFTL(MKCV1,1)
 00256 224            MKCV2 = SHFTL(MKCV2,1)
 00257 225         CFOR
 00258 227         LBCV = SHFTR(LBCV2,1)
 00259    C
 00260 228      CPROC
 00261    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00262 230      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         229 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         229 TARGET STATEMENTS
 00000    C   12/01/81 102191149  MEMBER NAME  CRTREL   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE CRTREL(IPHT,IERRFL)
 00002    C
 00003    C     SUBROUTINE FOR CREATION OF 1-HIT TREL
 00004    C     PETER STEFFEN  10/ 8/79
 00005    C
 00006   3      IMPLICIT INTEGER*2 (H)
 00007   4      LOGICAL TBIT
 00008    C
          C----------------------------------------------------------------------
          C             MACRO CDATA .... BOS COMMON.
          C
          C             THIS MACRO ONLY DEFINES THE IDATA/HDATA/ADATA NAMES.
          C             THE ACTUAL SIZE OF /BCS/ IS FIXED ON MACRO CBCSMX
          C             OR BY OTHER MEANS. A DEFAULT SIZE OF 40000 IS GIVEN HERE.
          C
          C----------------------------------------------------------------------
          C
         5      COMMON /BCS/ IDATA(40000)
         6      DIMENSION HDATA(80000),ADATA(40000),IPNT(50)
         7      EQUIVALENCE (HDATA(1),IDATA(1),ADATA(1)),(IPNT(1),IDATA(55))
         8      EQUIVALENCE (NWORD,IPNT(50))
          C
          C------------------------ END OF MACRO CDATA --------------------------
          C----------------------------------------------------------------------
          C           MACRO CCYCP .... JET CHAMBER HIT POINTERS (PATREC)
          C----------------------------------------------------------------------
         9      INTEGER*4 HPTSEC
        10      COMMON/CCYCP/HPTSEC(98)
 00016    C     HPTSEC(I) = CDATA POINTER TO 1ST I*2 WORD FOR 1ST HIT OF CELL I
          C------------------------ END OF MACRO CCYCP --------------------------
 00011    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        11      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        12      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        13      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        14      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        15      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        16      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        17      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  18      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 00014    C
 00015  19      EQUIVALENCE
 00016         ,           (ICELL ,IDWRK(1)),(NHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
 00017         ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
 00018         ,         , (ITR   ,IDWRK(7)),(ITRNG ,IDWRK(8))
 00019    C
 00021  20      DATA MKATR / ZFF01/                                                MASKS TO DELETE TRACK NO. IN HIT LABEL
 00023  21      INTEGER  MKLRHT(3) / Z800, Z0, Z900/                               L/R BIT IN HIT LABEL
 00024    C
 00025    C2003 FORMAT(1H0,A4,I6,2(/,1X,24I4),/,1X,50I2,
 00026    C    ,       90(/,1X,2I6,I3,2F10.3,I3,2F10.3,1X,Z4,2I3))
 00027    C2004 FORMAT(1H0,'BACKTR:',5X,20I6)
 00028    C2005 FORMAT(1H ,12X,20I6)
 00029    C2008 FORMAT(' HIT LABEL OF TRELS:',2I6,/,(12X,20(2X,Z4)))
 00030    C
 00032    C     I9 = HNTR                                                          PRINTOUT
 00033    C     PRINT 2003, HPRO,HNTR,HNTCEL,((TRKAR(I1,I2),I2=1,11),I1=1,I9)
 00034    C     PRINT 2005, (HRES(I1),I1=1,I9)
 00035    C     I0 = HPHL0
 00036    C     I9 = HPHL9
 00037    C     PRINT 2008, I0,I9,(HWRK(I1),I1=I0,I9)
 00038    C
 00040  22      IF HNTR.GE.200                                                     CHECK IF ENOUGH SPACE
 00041  23      THEN
 00042  26         IERRFL = -1
 00043  27         RETURN
 00044  28      CIF
 00045    C
 00046  29      LBLR = 1
 00047  30      IF(IPHT.LT.0) LBLR =-1
 00048  32      IPHT = IABS(IPHT)
 00049  33      IWIR = HDATA(IPHT)
 00050  34      IWIR = SHFTR(IWIR,3)
 00051  35      ICLL = SHFTR(IWIR,4)
 00052  36      ILAY = LAND(IWIR,15)
 00053  37      IPTR = HNTCEL(ICLL+2)
 00054  38      IRNG = ICLL / 24 + 1
 00055  39      IF(IRNG.GT.3) IRNG = 3
 00056    C     PRINT 2005, LBLR,IPHT,IWIR,ICLL,ILAY,IPTR,IRNG
 00057    C
 00059  41      IC1 =  1                                                           GET BIGGEST TREL#
 00060  42      IC9 = 24
 00061  43      IF(ICLL.GE.24) IC1 = 25
 00062  45      IF(ICLL.GE.24) IC9 = 48
 00063  47      IF(ICLL.GE.48) IC1 = 49
 00064  49      IF(ICLL.GE.48) IC9 = 96
 00065  51      IP1  = HNTCEL(IC1  )
 00066  52      IP9  = HNTCEL(IC9+1) - 1
 00067  53      JTRELM = 1
 00068  54      IF(IP1.LE.IP9) JTRELM = NTREL(IP9) + 1
 00069    C
 00071  56      IF JTRELM.GE.128                                                   CHECK IF TREL# <128
 00072  57      THEN
 00073  60         IERRFL = -1
 00074  61         RETURN
 00075  62      CIF
 00076    C
 00078  63      NTRL = 1                                                           GET TREL #
 00079  64      IF IPTR.GT.1
 00080  65      THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00081  68         NTRL = NTREL(IPTR-1) + 1
 00082  69         IRNG1 = (IPCL(IPTR-1)-1)/24 + 1
 00083  70         IF(IRNG1.GT.3) IRNG1 = 3
 00084  72         IF(IRNG1.NE.IRNG) NTRL = 1
 00085  74      CIF
 00086    C     PRINT 2005, ICLL,IC9,NTRL,JTRELM,IRNG1
 00087    C
 00089  75      IF IPTR.LE.IP9                                                     INCREASE REMAINING TREL# IN RING
 00090  76      THEN
 00091  79         FOR IP=IPTR,IP9
 00092  80            NTREL(IP) = NTREL(IP) + 1
 00093  81         CFOR
 00094    C
 00096  83         IPHT0 = (HPTSEC(ICLL+1)-HPTSEC(1))/2 + HPHL0                    INCREASE TREL# IN HIT LABEL ARRAY
 00097  84         IPHT9 = (HPTSEC(IC9 +1)-HPTSEC(1))/2 + HPHL0 - 1
 00098  85         FOR IP=IPHT0,IPHT9
 00099  86            LBHIT = HWRK(IP  )
 00100  87            NTR1 = SHFTR(LBHIT,1)
 00101  88            NTR1 = LAND(NTR1,127)
 00102  89            IF(NTR1.GE.NTRL) NTR1 = NTR1 + 1
 00103  91            LBHIT = LAND(MKATR,LBHIT)
 00104  92            LBHIT = LOR(LBHIT,SHFTL(NTR1,1))
 00105  93            HWRK(IP  ) = LBHIT
 00106  94         CFOR
 00107  96      CIF
 00108    C
 00110  97      IC0 = ICLL + 1                                                     INCREASE CELL POINTERS
 00111  98      FOR IC=IC0,96
 00112  99         HNTCEL(IC+1) = HNTCEL(IC+1) + 1
 00113 100      CFOR
 00114    C
 00116 102      HNTR = HNTR + 1                                                    INCREASE # OF TRELS
 00117    C
 00119 103      IF IPTR.NE.HNTR                                                    MOVE ARRAYS
 00120 104      THEN
 00121 107         IP = HNTR - 1
 00122 108         REPEAT
 00123 109            TRKAR(IP+1, 1) = TRKAR(IP, 1)
 00124 110            TRKAR(IP+1, 2) = TRKAR(IP, 2)
 00125 111            TRKAR(IP+1, 3) = TRKAR(IP, 3)
 00126 112            TRKAR(IP+1, 4) = TRKAR(IP, 4)
 00127 113            TRKAR(IP+1, 5) = TRKAR(IP, 5)
 00128 114            TRKAR(IP+1, 6) = TRKAR(IP, 6)
 00129 115            TRKAR(IP+1, 7) = TRKAR(IP, 7)
 00130 116            TRKAR(IP+1, 8) = TRKAR(IP, 8)
 00131 117            TRKAR(IP+1, 9) = TRKAR(IP, 9)
 00132 118            TRKAR(IP+1,10) = TRKAR(IP,10)
 00133 119            TRKAR(IP+1,11) = TRKAR(IP,11)
 00134 120            HRES(IP+1) = HRES(IP)
 00135 121            IP = IP - 1
 00136 122         UNTIL IP.LT.IPTR
 00137    C
 00139    C                                                                        INCREASE TREL# IN BACKTRACE ARRAY
 00140 123         IF NTR.GT.0
 00141 127         THEN
 00142    C         PRINT 2004,NTR, (HNREL(I1),I1=1,NTR)
 00143    C         FOR ITR=1,NTR
 00144    C           NELM = HNREL(ITR)
 00145    C           PRINT 2005, (HISTR(I1,ITR),I1=1,NELM)
 00146    C         CFOR
 00147 130            FOR ITR=1,NTR
 00148 131               NELM = HNREL(ITR)
 00149 132               FOR I=1,NELM
 00150 133                  IELM = HISTR(I,ITR)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00151 134                  INCR = ISIGN(1,IELM)
 00152 135                  IF(IABS(IELM).GE.IPTR) HISTR(I,ITR) = IELM + INCR
 00153 137               CFOR
 00154 139            CFOR
 00155    C         PRINT 2004,NTR, (HNREL(I1),I1=1,NTR)
 00156    C         FOR ITR=1,NTR
 00157    C           NELM = HNREL(ITR)
 00158    C           PRINT 2005, (HISTR(I1,ITR),I1=1,NELM)
 00159    C         CFOR
 00160 141         CIF
 00161 142      CIF
 00162    C
 00164 143      ITRKAR(IPTR, 1) = IC0                                              CREATE TREL
 00165 144      ITRKAR(IPTR, 2) = 1
 00166 145      ITRKAR(IPTR, 3) = ILAY
 00167 146      ITRKAR(IPTR, 4) = 0
 00168 147      ITRKAR(IPTR, 5) = 0
 00169 148      ITRKAR(IPTR, 6) = ILAY
 00170 149      ITRKAR(IPTR, 7) = 0
 00171 150      ITRKAR(IPTR, 8) = 0
 00172 151      ITRKAR(IPTR, 9) = 0
 00173 152      ITRKAR(IPTR,10) = NTRL
 00174 153      ITRKAR(IPTR,11) = 0
 00175 154      HRES(IPTR) = 0
 00176    C
 00178    C     I9 = HNTR                                                          PRINTOUT
 00179    C     PRINT 2003, HPRO,HNTR,HNTCEL,((TRKAR(I1,I2),I2=1,11),I1=1,I9)
 00180    C     PRINT 2005, (HRES(I1),I1=1,I9)
 00181    C
 00183 155      IPLBHT = (IPHT - HPTSEC(1))/2 + HPHL0                              CHANGE HIT LABEL
 00184 156      LBHIT = NTRL*2
 00185 157      LBHIT = LOR(LBHIT,MKLRHT(LBLR+2))
 00186 158      HWRK(IPLBHT+1) = HWRK(IPLBHT)
 00187 159      HWRK(IPLBHT  ) = LBHIT
 00188    C
 00190    C     I0 = HPHL0                                                         PRINTOUT
 00191    C     I9 = HPHL9
 00192    C     PRINT 2008, I0,I9,(HWRK(I1),I1=I0,I9)
 00193    C
 00194 160      IERRFL = 0
 00195 161      IPHT = IPTR
 00196 162      RETURN
 00197    C
 00198 163      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         162 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         162 TARGET STATEMENTS
 00000    C   28/09/79 102191155  MEMBER NAME  FLINEL   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE FLINEL
 00002    C
 00003    C        FIND LINE ELEMENTS IN ONE CELL: P.STEFFEN(78/11/78)
 00004    C
 00005   3      IMPLICIT INTEGER*2 (H)
 00006    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         4      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
         5      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
         6      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
         7      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
         8      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
         9      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        10      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  11      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 00009    C
 00010  12      EQUIVALENCE
 00011         ,           (ICELL ,IDWRK(1)),(NHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
 00012         ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
 00013    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        13      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        14      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        15      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        16      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        17      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00015    C
 00016    C2000 FORMAT(1H0,'ERROR CODE:',I4, ', ICELL:',I3,', TRACKS:',I9)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00017    C2001 FORMAT(1X,/,(1X,2I6,2F6.2,2X,Z4,6I6,F6.2))
 00018    C     PRINT 2000, IERRCD, ICELL, IPPATR
 00019    C     IF(ICELL.EQ.20)PRINT 2001, (WRK(I1),I1=HPHT0,HPHT9)
 00020    C
 00022  18      I9 = HPHL0 + 39                                                    LOOP OVER ALL HITS: TOP-DOWN
 00023  19      IP1 = HPHT0
 00024  20      IP9 = HPHT9
 00025  21      IPD = HLDHT
 00026  22      IP8 = IP9 - IPD
 00027  23      IP7 = IP8 - IPD
 00028  24      IP  = IP1 - IPD
 00029  25      WHILE IP.LT.IP7
 00030  27         IP = IP + IPD
 00032  31         IF IWRK(IP+7).EQ.0                                              CHECK IF HIT ALREADY FOUND
 00033  32         THEN
 00035  35            ILAY0 = IWRK(IP)                                             LAYER NO.
 00037  36            DS0 = WRK(IP+2)                                              DRIFT SPACE
 00038    C
 00040  37            PERFORM CLHTUP                                               SEARCH FOR CLOSE HITS IN UPPER LAYERS
 00041  40         CIF
 00042  41      CWHILE
 00043    C
 00044    C     CHECK ONE TO ONE CORRESPONDENCE OF POINTERS
 00045    C     AND LABEL POINTS OF DIVERGENCE
 00046    C
 00047  43      PERFORM LBCHCK
 00048    C     IF(ICELL.EQ.20)PRINT 2001, (WRK(I1),I1=HPHT0,HPHT9)
 00049    C
 00050  46      RETURN
 00051    C
 00052    C
 00053                                                                             ***************************
 00054                                                                             *      C L H T U P        *
 00056    C                                                                        ***************************
 00058  47      PROC CLHTUP                                                        SEARCH FOR CLOSE HITS IN UPPER LAYERS
 00059    C
 00060  48         IPHT = IP
 00061  49         IPA = IP
 00062  50         IPALST = 0
 00063  51         WHILE IPA.LT.IP8
 00064  53            IPA = IPA + IPD
 00065  57            IDLAYR = IWRK(IPA) - ILAY0
 00066  58            DS = WRK(IPA+2)
 00067  59            IF IDLAYR.EQ.2
 00068  60            THEN
 00069  63               IF IPALST.EQ.0
 00070  64               THEN
 00071  67                  IF(IWRK(IPHT+7).EQ.0) IWRK(IPHT+7) = -1
 00072  69                  XWHILE
 00073  70               CIF
 00074  71               IPHT = IPALST
 00075  72               IF IWRK(IPHT+7).GT.0
 00076  73               THEN
 00077  76                  XWHILE
 00078  77               CIF
 00079  78               IPA = IPHT + IPD
 00080  79               ILAY0 = IWRK(IPHT)
 00081  80               DS0 = WRK(IPHT+2)
 00082  81               IDLAYR = IWRK(IPA) - ILAY0
 00083  82               DS = WRK(IPA+2)
 00084  83               IPALST = 0
 00085  84            CIF
 00087  85            IF IDLAYR.GT.1                                               STOP IF NOT SAME/ADJACENT LAYER OR DISTANT HIT
 00088  86            THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00089  89               XWHILE
 00090  90            CIF
 00091    C
 00093  91            DDS = DS-DS0                                                 CHECK IF CLOSE HIT
 00094  92            IF ABS(DDS).LT.FLINLM(1)
 00095  93            THEN
 00096  96               IF IDLAYR.EQ.1
 00098  97               THEN                                                      CLOSE HIT IN ADJ. LAYR
 00100 100                  IF IWRK(IPHT+7).LE.0                                   CHECK IF 1. CLOSE HIT
 00101 101                  THEN
 00102 104                     WRK (IPHT+10) = DDS
 00103 105                     IWRK(IPHT+ 7) = IPA
 00104 106                     IPALST = IPA
 00106 107                  ELSE                                                   OTHER CLOSE HIT EXISTS: CHOSE CLOSEST
 00107 109                     IWRK(IPHT+4) = LOR(IWRK(IPHT+4),32)
 00108 110                     IF ABS(DDS).LT.ABS(WRK(IPHT+10))
 00109 111                     THEN
 00110 114                        WRK (IPHT+10) = DDS
 00111 115                        IWRK(IPHT+ 7) = IPA
 00112 116                        IPALST = IPA
 00113 117                     CIF
 00114 118                  CIF
 00116 119                  IF IWRK(IPA+5).EQ.0                                    CHECK IF 1. CLOSE HIT
 00117 120                  THEN
 00118 123                     IWRK(IPA+ 5) = IPHT
 00119 124                     WRK (IPA+ 8) = DDS
 00121 125                  ELSE                                                   OTHER CLOSE HIT EXISTS: CHOSE CLOSEST
 00122 127                     IWRK(IPA +4) = LOR(IWRK(IPA +4), 8)
 00123 128                     IF ABS(DDS).LT.ABS(WRK(IPA+ 8))
 00124 129                     THEN
 00125 132                        IWRK(IPA+ 5) = IPHT
 00126 133                        WRK (IPA+ 8) = DDS
 00127 134                     CIF
 00128 135                  CIF
 00129    C
 00131 136               ELSE                                                      CLOSE HIT IN SAME LAYER
 00133 138                  IF IWRK(IPHT+6).EQ.0                                   CHECK IF 1. CLOSE HIT
 00134 139                  THEN
 00135 142                     IWRK(IPHT+ 6) = IPA
 00136 143                     WRK (IPHT+ 9) = DDS
 00138 144                  ELSE                                                   OTHER CLOSE HIT EXISTS: CHOSE CLOSEST
 00139 146                     IF ABS(DDS).LT.ABS(WRK(IPHT+ 9))
 00140 147                     THEN
 00141 150                        IWRK(IPHT+ 6) = IPA
 00142 151                        WRK (IPHT+ 9) = DDS
 00143 152                     CIF
 00144 153                  CIF
 00146 154                  IF IWRK(IPA+6).EQ.0                                    CHECK IF 1. CLOSE HIT
 00147 155                  THEN
 00148 158                     IWRK(IPA+ 6) = IPHT
 00149 159                     WRK (IPA+ 9) = DDS
 00151 160                  ELSE                                                   OTHER CLOSE HIT EXISTS: CHOSE CLOSEST
 00152 162                     IF ABS(DDS).LT.ABS(WRK(IPA+ 9))
 00153 163                     THEN
 00154 166                        IWRK(IPA+ 6) = IPHT
 00155 167                        WRK (IPA+ 9) = DDS
 00156 168                     CIF
 00157 169                  CIF
 00158 170               CIF
 00159 171            CIF
 00160 172         CWHILE
 00161    C
 00162 174      CPROC
 00163    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00164                                                                             ***************************
 00165                                                                             *      L B C H C K        *
 00167    C                                                                        ***************************
 00169 176      PROC LBCHCK                                                        CHECK ONE TO ONE CONNECTIONS + LABEL HITS
 00170    C
 00172 177         IPHT = IP1                                                      FIND STRAIGHTEST LINEL IN MULT. CONNECTS.
 00173 178         REPEAT
 00175 179            IF LAND(IWRK(IPHT+4),40).NE.0                                CHECK IF >1 LINEL POSSIBLE
 00176 180            THEN
 00178 183               PERFORM STRLIN                                            SEARCH FOR STRAIGHTEST LINEL
 00179 186            CIF
 00180 187            IPHT = IPHT + IPD
 00181 188         UNTIL IPHT.GT.IP9
 00182    C
 00183 189         FOR IPHT = IP1,IP9,IPD
 00185 193            IPAL = IWRK(IPHT+5)                                          POINTER DOWN
 00187 194            IPAH = IWRK(IPHT+7)                                          POINTER UP
 00189 195            DDS = 100000.                                                CALCULATE PARAMETERS + LABEL
 00190 196            IF IPAH.GT.0
 00191 197            THEN
 00192 200               IF IPAL.GT.0
 00193 201               THEN
 00194 204                  SL = WRK(IPAH+2) - WRK(IPAL+2)
 00195 205                  DDS= WRK(IPAH+2)+WRK(IPAL+2) - WRK(IPHT+2)*2
 00197 206                  LB = 3                                                 SET LABEL
 00198 207                  IF(ABS(DDS).LE.FLINLM(2)) LB = 7
 00199 209               ELSE
 00200 211                  SL = (WRK(IPAH+2) - WRK(IPHT+2)) * 2
 00201 212                  LB = 2
 00202 213               CIF
 00203 214            ELSE
 00204 216               IF(IPAH.LT.0) IWRK(IPHT+7) = 0
 00205 218               IF IPAL.GT.0
 00206 219               THEN
 00207 222                  SL = (WRK(IPHT+2) - WRK(IPAL+2)) * 2
 00208 223                  LB = 1
 00209 224               ELSE
 00210 226                  SL = 0
 00211 227                  LB = 0
 00212 228               CIF
 00213 229            CIF
 00215 230            IF(IWRK(IPHT+6).NE.0) LB = LOR(LB,16)                        SET BIT FOR CLOSE HIT IN SAME LAYER
 00217 232            WRK (IPHT+ 3) = SL                                           FILL HIT ARRAY
 00218 233            IWRK(IPHT+ 4) = LOR(IWRK(IPHT+4),LB)
 00219 234            WRK (IPHT+ 8) = 0
 00220 235            WRK (IPHT+ 9) = 0
 00221 236            WRK (IPHT+10) = 0
 00222 237            WRK (IPHT+11) = DDS
 00223    C
 00224 238         CFOR
 00225    C
 00227    C                                                                        CHECK ONE TO ONE CORRESP.
 00228 240         FOR IPHT = IP1,IP9,IPD
 00230 241            IPAL = IWRK(IPHT+5)                                          POINTER DOWN
 00232 242            IPAH = IWRK(IPHT+7)                                          POINTER UP
 00233 243            LB   = IWRK(IPHT+4)
 00234 244            IF IPAL.GT.0
 00235 245            THEN
 00237 248               IPALH = IWRK(IPAL+7)                                      POINTER UP
 00239 249               IF IPALH.NE.IPHT                                          CHECK ONE TO ONE CORRESPONDENCE
 00241 250               THEN                                                      LABEL POINTS OF DIVERGENCE
 00242 253                  LB = LOR(LB, 256)
 00243 254                  IWRK(IPALH+4) = LOR(IWRK(IPALH+4), 512)
 00244 255                  IWRK(IPAL +4) = LOR(IWRK(IPAL +4),1024)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00245 256               CIF
 00246 257            CIF
 00247 258            IF IPAH.GT.0
 00248 259            THEN
 00250 262               IPAHL = IWRK(IPAH+5)                                      POINTER DOWN
 00252 263               IF IPAHL.NE.IPHT                                          CHECK ONE TO ONE CORRESPONDENCE
 00254 264               THEN                                                      LABEL POINTS OF DIVERGENCE
 00255 267                  LB = LOR(LB, 256)
 00256 268                  IWRK(IPAHL+4) = LOR(IWRK(IPAHL+4), 512)
 00257 269                  IWRK(IPAH +4) = LOR(IWRK(IPAH +4),1024)
 00258 270               CIF
 00259 271            CIF
 00260 272            IWRK(IPHT +4) = LB
 00261    C
 00262 273         CFOR
 00263    C
 00264 275      CPROC
 00265    C
 00266                                                                             ***************************
 00267                                                                             *      S T R L I N        *
 00269    C                                                                        ***************************
 00271 277      PROC STRLIN                                                        SEARCH FOR STRAIGHTESTT LINEL
 00272    C
 00273 278         IPAL = IWRK(IPHT+5)
 00274 279         IPAH = IWRK(IPHT+7)
 00275 280         IF IPAH.GT.0 .AND. IPAL.GT.0
 00276 281         THEN
 00277 284            DDS = WRK(IPHT+10) - WRK(IPHT+ 8)
 00279 285            IF ABS(DDS).GT.FLINLM(2)                                     CHECK IF KINKED LINEL
 00280 286            THEN
 00281 289               ILAY0 = IWRK(IPHT)
 00282 290               DS0 = WRK(IPHT+2)
 00283 291               DSLM = 100000.
 00285 292               IPUP = IPHT                                               SELECT UP CONNECTION
 00286 293               WHILE IPUP.LT.IP8
 00287 295                  IPUP = IPUP + IPD
 00288 299                  IF IWRK(IPUP)-ILAY0.GT.0
 00289 300                  THEN
 00290 303                     IF IWRK(IPUP)-ILAY0.GT.1
 00291 304                     THEN
 00292 307                        XWHILE
 00293 308                     CIF
 00294 309                     SLH = WRK(IPUP+2) - DS0
 00296 310                     IPDW = IPHT                                         SELECT DOWN CONNECTION
 00297 311                     WHILE IPDW.GT.IP1
 00298 313                        IPDW = IPDW - IPD
 00299 317                        IF ILAY0-IWRK(IPDW).GT.0
 00300 318                        THEN
 00301 321                           IF ILAY0-IWRK(IPDW).GT.1
 00302 322                           THEN
 00303 325                              XWHILE
 00304 326                           CIF
 00305 327                           SLL = DS0 - WRK(IPDW+2)
 00306 328                           DSL = ABS(SLH-SLL)
 00307 329                           IF DSL.LT.DSLM
 00308 330                           THEN
 00310 333                              DSLM = DSL                                 SET STRAIGHTEST SLOPE PARAMETERS
 00311 334                              IPAL = IPDW
 00312 335                              IPAH = IPUP
 00313 336                           CIF
 00314 337                        CIF
 00315 338                     CWHILE
 00316 340                  CIF
 00317 341               CWHILE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00318 343               IWRK(IPHT+ 5) = IPAL
 00319 344               IWRK(IPHT+ 7) = IPAH
 00320 345               WRK (IPHT+ 8) = DS0 - WRK(IPAL+2)
 00321 346               WRK (IPHT+10) = WRK(IPAH+2) - DS0
 00322 347               IF(IWRK(IPAL+ 7).LE.0)  WRK(IPAL+10) = WRK(IPHT+ 8)
 00323 349               IF(IWRK(IPAL+ 7).LE.0) IWRK(IPAL+ 7) = IPHT
 00324 351               IF(IWRK(IPAH+ 5).LE.0)  WRK(IPAH+ 8) = WRK(IPHT+10)
 00325 353               IF(IWRK(IPAH+ 5).LE.0) IWRK(IPAH+ 5) = IPHT
 00326 355               DATA IPR /0/
 00327 356               IPR = IPR + 1
 00328    C         IF IPR.LE.10
 00329    C         THEN
 00330    C2006   FORMAT(1H0,'IPHT:',I4, ', IPAL:',I3,', IPAH:',I4,', DDS =',F6.2)
 00331    C     IF(ICELL.EQ.20)PRINT 2006, IPHT,IPAL,IPAH,DDS
 00332    C     IF(ICELL.EQ.20)PRINT 2001, (WRK(I1),I1=HPHT0,HPHT9)
 00333    C         CIF
 00334 357            CIF
 00335 358         CIF
 00336 359      CPROC
 00337    C
 00338 361      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         360 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         360 TARGET STATEMENTS
 00000    C   03/10/80 102191156  MEMBER NAME  FTRELO   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE FTRELO
 00002    C
 00003    C        FIND TRACK ELEMENTS FROM LINE ELEMENTS: P.STEFFEN(80/06/27)
 00004    C                   HISTOGRAM METHOD USING INTERACTION POINT
 00005    C                   NO STOP AT POINT OF DIVERGENCE
 00006    C
 00007   3      IMPLICIT INTEGER*2 (H)
 00008   4      LOGICAL TBIT
 00009    C
          C-------------------------------
          C  MACRO CHEADR .... HEADER BANK
          C-------------------------------
         5      COMMON /CHEADR/ IHEADR(54)
         6      INTEGER*2 HHEADR(108)
         7      EQUIVALENCE (IHEADR(1),HHEADR(1))
          C --
          C --  HHEADR(17) = EXPERIMENT NUMBER
          C --  HHEADR(18) = RUN NUMBER
          C --  HHEADR(19) = EVENT NUMBER
          C --  HHEADR(38) = MAGNETIC FIELD (GAUSS)
          C --
          C--------- END OF MACRO CHEADR ------------
 00011   8      EQUIVALENCE (HRUN,HHEADR(18)) , (HEV,HHEADR(19))
 00012    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         9      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        10      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        11      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        12      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        13      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        14      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        15      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  16      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 00015    C
 00016  17      EQUIVALENCE
 00017         ,           (ICELL ,IDWRK(1)),(MHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00018         ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
 00019    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        18      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        19      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        20      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        21      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        22      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00021    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  23      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
 00500         +                  RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,
 00510         +                  ZRESOL,ZNORM,ZAL,ZSCAL,DRIDEV,DRICOS,DRISIN,
 00600         +                  PEDES,TZERO(3),DRIROT(96,2),SINDRI(96,2),
 00701         +                  COSDRI(96,2),DRIVEL(96,2),T0FIX(3),
 00800         +                  ABERR(8), DUMJDC(20)
 00900    C
 01100    C      BLOCK DATA SET TO MC VALUES, KALIBR WILL SET REAL DATA VALUES
 01210    C--->  A CHANGE OF THIS COMMON MUST BE DONE SIMULTANEOUSLY WITH  <----
 01220    C--->  A CHANGE OF THE BLOCK DATA                                <----
 01230    C
 01300    C--------------------------- END OF MACRO CJDRCH -----------------------
 01400    C
          C----------------------------------------------------------------------
          C           MACRO CDSMAX .... PATTERN RECOGNITION CONSTANTS.
          C----------------------------------------------------------------------
        24      COMMON/CDSMAX/DSMAX(16,3,2),DIRWR1(24,2),DIRWR3(48,2)
               *             ,DHALF(16,3,2),DTWICE(16,3,2),HMCH(16,3,2)
               *             ,IBCK(9),DBCK(30),TRMATS(96,2),TRMATC(96,2)
          C------------------------ END OF MACRO CDSMAX -------------------------
 00024    C
 00025  25      DIMENSION HPBAK(16),HLYAR(16),HLBAR(16),DSPAR(16),
 00026         ,          XTRAR(16),YTRAR(16),RESAR(16)
 00027  26      DIMENSION HST( 80), HSTL(5),HSTR(5)
 00028    C
 00030  27      DATA XCV /152.7/                                                   AVERAGE RADIUS FOR PAIR CONVERSION IN BEAM PIPE OR
 00031    C
 00033    C     DATA MKGDLN / Z107/                                                MASK FOR GOOD LINEL
 00035    C     DATA MKDIVL / Z100/                                                MASK FOR DIVERGING LINEL
 00036    C
 00038    C     DATA LBNOCN / Z1/                                                  LABEL FOR NO CONTINUATION OF TREL
 00040    C     DATA LBKINK / Z2/                                                  LABEL FOR KINK AT END POINT OF TREL
 00041    C
 00043  28      REAL SGCRV(3) /.000062,.000035,.000025/                            SIGMA(CURV) FOR HITS IN 3 RINGS
 00044    C
 00045    C     IF(ICELL.NE.40 .AND. ICELL.NE.58) RETURN
 00046    C2001 FORMAT(' L/R DET.:',10F8.3)
 00047    C2006 FORMAT(1X,I6,5F8.2,F12.1,5F8.2)
 00048    C2013 FORMAT('0FIT:',I3,F5.2,F5.1,F10.6,F7.3,F5.1,F7.4,F6.1,F5.2)
 00049    C2014 FORMAT(' X,Y,ZW1,ZW2,CRV0,CRV,IBNL:',6F10.5,I10)
 00050    C2100 FORMAT(' LINEL ',4I6,2F6.2,I4)
 00051    C2101 FORMAT('0HISTOGRAM:',20I2,2X,20I2,/,(11X,20I2,2X,20I2))
 00052    C2102 FORMAT(' PEAK =', 7I6,6F10.5)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00053    C2103 FORMAT(' TREL:',2I6,3(/,1X,16I7),3(/,1X,16F7.2))
 00054    C2900 FORMAT(1H0,'ERROR CODE:',I4, ', ICELL:',I3,', TRACKS:',I4)
 00055    C2901 FORMAT(1X,/,(1X,2I6,2F6.2,2X,Z4,4F7.1,2I6,F6.2))
 00056    C
 00058  29      ITRK = 0                                                           POINTER TO CURRENT TRKEL
 00059    C
 00061  30      DR =  RINCR(IRING)                                                 CALCULATE X,Y COORDINATES
 00062  31      R0 = FSENSW(IRING)
 00064  32      DRC = RINCR(1)*.5 * DRICOS                                         RADIUS AROUND WIRE FOR CORR. OF DRIFTSPACE
 00065    C
 00066  33      FOR IP = HPHT0,HPHT9,HLDHT
 00067  34         ILAY = IWRK(IP  )
 00068  35         Y    = SWDEPL
 00069  36         IF(LAND(ILAY,1).NE.0) Y =-Y
 00070  38         X    = ILAY * DR + R0
 00071  39         DS   =  WRK(IP+2)
 00072  40         IF DS.LE.DRC
 00073  41         THEN
 00074  44            DX   = 0.
 00075  45            DY   = DS
 00076  46         ELSE
 00077  48            DX   =-(DS-DRC)*DRISIN
 00078  49            DY   = (DS-DRC)*DRICOS + DRC
 00079  50         CIF
 00080  51         WRK(IP+5) = X - DX
 00081  52         WRK(IP+7) = X + DX
 00082  53         WRK(IP+6) = Y - DY
 00083  54         WRK(IP+8) = Y + DY
 00084  55      CFOR
 00085    C     PRINT 2900, IRING, ICELL, NTRCNT
 00086    C     IF(ICELL.LE.47) PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
 00087    C
 00089  57      IPHT1 = HPHT9 - HLDHT + 1                                          LOOP OVER HITS + SEARCH FOR LINE ELEMENT
 00090  58      REPEAT
 00092  59         IL1 = IWRK(IPHT1  )                                             1. HIT
 00093  60         IF(IL1.LT. 2) XREPEAT
 00095  62         DSP1 =  WRK(IPHT1+2)                                            CHECK IF UNUSED
 00096  63         IF DSP1.GT.0.7 .AND. IWRK(IPHT1+9).LE.0
 00097  64         THEN
 00098  67            IL2 =  IL1 - 1
 00099  68            IL3 =  IL2 - 1
 00100    C
 00102  69            DSLM = 1000.                                                 SEARCH STRAIGHTEST LINEL
 00103    C
 00105  70            IPHT2 = IPHT1 - HLDHT                                        SEARCH FOR 2. HIT
 00106  71            WHILE IPHT2.GE.HPHT0 .AND. IWRK(IPHT2).GE.IL2
 00108  73               DSP2 = WRK(IPHT2+2)                                       CHECK IF NEXT LAYER + UNUSED HIT
 00109  77               IF DSP2.GT.0.7.AND.IWRK(IPHT2).EQ.IL2.AND.IWRK(IPHT2+9).LE.0
 00110  78               THEN
 00111  81                  IF ABS(DSP2-DSP1).LE.12.5
 00112  82                  THEN
 00113    C
 00115  85                     IPHT3 = IPHT2 - HLDHT                               SEARCH FOR 3. HIT
 00116  86                     WHILE IPHT3.GE.HPHT0 .AND. IWRK(IPHT3).GE.IL3
 00118  88                        DSP3 = WRK(IPHT3+2)                              CHECK IF NEXT LAYER + UNUSED HIT
 00119  92                        IF DSP3.GT.0.7 .AND.
 00120         ?                     IWRK(IPHT3).EQ.IL3 .AND. IWRK(IPHT3+9).LE.0
 00121  93                        THEN
 00123  96                           DSL = DSP2*2.-DSP3-DSP1                       SEARCH FOR SRAIGHTEST LINEL
 00124  97                           IF ABS(DSL).LT.DSLM .AND. DSP1+DSP2+DSP3.GT.3.0
 00125  98                           THEN
 00126 101                              IF IWRK(IPHT1+9).EQ.0 .OR. IWRK(IPHT2+9).EQ.0
 00127         ?                           .OR. IWRK(IPHT3+9).EQ.0
 00128 102                              THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00129 105                                 DSLM  = ABS(DSL)
 00130 106                                 SDSLM = DSL
 00131 107                                 MP1 = IPHT1
 00132 108                                 MP2 = IPHT2
 00133 109                                 MP3 = IPHT3
 00134 110                              CIF
 00135 111                           CIF
 00136 112                        CIF
 00137 113                        IPHT3 = IPHT3 - HLDHT
 00138 114                     CWHILE
 00139 116                  CIF
 00140 117               CIF
 00141 118               IPHT2 = IPHT2 - HLDHT
 00142 119            CWHILE
 00143    C
 00145 121            REPEAT                                                       'XREPEAT' = STOP ANALYSIS
 00146
 00147
 00148
 00150 122               LBLRLE = LAND(IL2,1)*2 - 1                                CHECK IF GOOD LINEL
 00151 123               IF(SDSLM.LT.0) LBLRLE =-LBLRLE
 00152    C     IF(ICELL.LE.47)PRINT 2100, IL1,MP1,MP2,MP3,DSLM,SDSLM,LBLRLE
 00153 125               IF(DSLM.GE.2.0) XREPEAT
 00154    C
 00156 127               LBLRLE = LAND(IL2,1)*2 - 1                                GOOD LINEL, FETCH OTHER HITS
 00157 128               IF(SDSLM.LT.0) LBLRLE =-LBLRLE
 00158 130               PERFORM CVHIST
 00159    C
 00161 133               LRLOOP = 1                                                LOOP OVER L/R SOL. TRY BEST ONE FIRST
 00162 134               SIGLM = .250
 00163 135               SIG0 = 1000.
 00164 136               WHILE LRLOOP.LE.2
 00165    C
 00167 138                  PERFORM FETHST                                         FETCH HITS CONTRIBUTING TO HISTOGRAM PEAK
 00168    C
 00170 144                  IF(NHTTR.LT.4) XWHILE                                  CHECK IF AT LEAST 4 HITS
 00171    C
 00173 146                  WGHT0 = 0.01                                           FIT PARABOLA THROUGH ORIGIN
 00174 147                  Y0    = 0.
 00175 148                  PERFORM FPARA0
 00177 151                  IF ABS(PAR3).GT.3.0                                    CHECK IF DIST. TO ORIGIN ACCEPTABLE
 00178 152                  THEN
 00179 155                     WGHT0 = 0.1
 00180 156                     IF PAR1*PAR3.LE.0.
 00181 157                     THEN
 00182 160                        Y0 =-SIGN(2.,PAR1)
 00183 161                        PERFORM FPARA0
 00184 164                     ELSE
 00185 166                        DORMX = XCV**2*PAR1 + SIGN(2.,PAR1)
 00186 167                        IF ABS(PAR3).GT.ABS(DORMX)
 00187 168                        THEN
 00189 171                           Y0 = DORMX                                    TOO BIG DIST., REPEAT FIT WITH RESTRICTION
 00190 172                           PERFORM FPARA0
 00191 175                        CIF
 00192 176                     CIF
 00193 177                  CIF
 00194    C
 00196 178                  SIGLM = .50                                            CHECK IF REASONABLE FIT
 00197 179                  IF SIG.GT.SIGLM
 00198 180                  THEN
 00200 183                     SIG1 = (SIG*DEG - DCHIM1**2) / (DEG-1.)             BAD FIT, CHECK IF ONLY 1 BAD HIT
 00201 184                     IF(SIG1.GT.SIGLM .AND. LRLOOP.EQ.1) XREPEAT
 00202 186                  CIF
 00203    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00205 187                  FETLIM = 0.65                                          FETCH HITS
 00206 188                  PERFORM FETHIT
 00207 191                  WGHT0 = .01
 00208 192                  IF NHTTR.GE.4
 00209 193                  THEN
 00211 196                     PERFORM FPARA0                                      FIT PARABOLA THROUGH ORIGIN
 00212    C
 00214 199                     IF ABS(PAR3).GT.3.0                                 CHECK IF DIST. TO ORIGIN ACCEPTABLE
 00215 200                     THEN
 00216 203                        WGHT0 = 0.1
 00217 204                        IF PAR1*PAR3.LE.0.
 00218 205                        THEN
 00219 208                           Y0 =-SIGN(2.,PAR1)
 00220 209                           PERFORM FPARA0
 00221 212                        ELSE
 00222 214                           DORMX = XCV**2*PAR1 + SIGN(2.,PAR1)
 00223 215                           IF ABS(PAR3).GT.ABS(DORMX)
 00224 216                           THEN
 00226 219                              Y0 = DORMX                                 TOO BIG DIST., REPEAT FIT WITH RESTRICTION
 00227 220                              PERFORM FPARA0
 00228 223                           CIF
 00229 224                        CIF
 00230 225                     CIF
 00231 226                  CIF
 00233 227                  IF SIG.GT.SIGLM                                        CHECK IF REASONABLE FIT
 00234 228                  THEN
 00236 231                     SIG1 = (SIG*DEG - DCHIM1**2) / (DEG-1.)             BAD FIT, CHECK IF ONLY 1 BAD HIT
 00237 232                     IF(SIG1.GT.SIGLM .AND. LRLOOP.EQ.1) XREPEAT
 00238 234                  CIF
 00239    C
 00241 235                  SIGCOR = SIG                                           DET. CORRECTED SIGMA
 00242 236                  IF LRLOOP.EQ.2
 00243 237                  THEN
 00244 240                     DDSTG = DSTAG - DSTAG0
 00245 241                     SIGCOR = SIG - (DEG-DEG0)*.01 + DDSTG*.1 + .01
 00246    C     IF(ICELL.LE.47)PRINT 2001, SIG,SIGCOR,SIG0,DEG,DEG0,DSTAG,DSTAG0
 00247 242                  CIF
 00248    C
 00250 243                  IF SIGCOR .LT. SIG0                                    STORE BEST SOLUTION
 00251 244                  THEN
 00252 247                     LBLR0 = LBLRTR
 00253 248                     SIG0  = SIG
 00254 249                     SIGLM0= SIGLM
 00255 250                     PAR10 = PAR1
 00256 251                     PAR20 = PAR2
 00257 252                     PAR30 = PAR3
 00258 253                     DSTAG0= DSTAG
 00259 254                     DEG0  = DEG
 00261 255                     IF(SIG.LT..08) XWHILE                               STOP IF GOOD FIT
 00262 257                  CIF
 00263 258                  LBLRTR =-LBLRTR
 00264 259                  LRLOOP = LRLOOP + 1
 00265 260               CWHILE
 00266    C
 00268 262               IF(SIG0.GT..25) XREPEAT                                   CHECK IF GOOD SOL. FOUND
 00269    C
 00271 264               LBLRTR = LBLR0                                            RESTORE PARAMETERS
 00272 265               SIG    = SIG0
 00273 266               PAR1   = PAR10
 00274 267               PAR2   = PAR20
 00275 268               PAR3   = PAR30
 00276    C
 00278 269               ITRK = ITRK + 1                                           LABEL HITS
 00279 270               ALBLM1 = 0.7
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00280 271               ALBLM2 = 2.0
 00281 272               PERFORM LABEL
 00282    C
 00284 275               IF(SIG0.GT..10 .AND. ICELL.LE.48) XREPEAT                 CHECK IF GOOD SOLUTION IN R2
 00285    C
 00287 277               IF(ABS(PAR1).GT..00040 .OR. NHTGD.LT.4) XREPEAT           CHECK IF CURV.(>200MEV)
 00288    C
 00290 279               HPFRE1 = HPFREE                                           TRACE TRACK THROUGH ORIGIN
 00291 280               CALL TRACEO(ITRK,PAR1,PAR2,PAR3)
 00292 281               HPFREE = HPFRE1
 00293    C
 00294 282            UNTIL .TRUE.
 00295    C
 00296 283         CIF
 00297 287         IPHT1 = IPHT1 - HLDHT
 00298 288      UNTIL IPHT1.LT.HPHT0
 00299    C
 00301    C                                                                        SET POINTER TO END OF TRACK ARRAY
 00303    C                                                                        SET NUMBER OF TRKELS
 00304    C     IF(ICELL.LE.47)PRINT 2900, IERRCD, ICELL, NTRCNT
 00305    C     IF(ICELL.LE.47)PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
 00306 289      RETURN
 00307    C
 00308                                                                             *************************
 00309                                                                             *      C V H I S T      *
 00310                                                                             *************************
 00312 293      PROC CVHIST                                                        HISTOGRAM OF CURVATURES
 00313    C
 00315 294         CALL SETS(HST(1),0,160,0)                                       ZERO HISTOGRAM
 00316 295         DCRV =  SGCRV(IRING)
 00317 296         CRV1 = -DCRV*20.
 00318 297         IW1 = IL2
 00319    C
 00321 298         ILRSOL =-3                                                      LOOP OVER L/R SOLUTIONS
 00322 299         REPEAT
 00323 300            ILRSOL = ILRSOL + 2
 00324 301            IF ILRSOL.LT.0
 00325 302            THEN
 00327 305               ZW1L = (WRK(MP1+5)+WRK(MP2+5)+WRK(MP3+5)) / 3.            LEFT SOLUTION
 00328 306               ZW2L = (WRK(MP1+6)+WRK(MP2+6)+WRK(MP3+6)) / (ZW1L*3.)
 00329 307               ZW1  = ZW1L
 00330 308               ZW2  = ZW2L
 00331 309               X    = WRK(MP1+5)
 00332 310               Y    = WRK(MP1+6)
 00333 311               CV1  = (ZW2*X - Y) / ((ZW1-X)*X)
 00334 312               X    = WRK(MP3+5)
 00335 313               Y    = WRK(MP3+6)
 00336 314               CV3  = (ZW2*X - Y) / ((ZW1-X)*X)
 00337 315               CRVL = (CV1 + CV3) * .5 + CRV1
 00338 316               CRV0 = CRVL
 00339 317            ELSE
 00341 319               ZW1R = (WRK(MP1+7)+WRK(MP2+7)+WRK(MP3+7)) / 3.            RIGHT SOLUTION
 00342 320               ZW2R = (WRK(MP1+8)+WRK(MP2+8)+WRK(MP3+8)) / (ZW1R*3.)
 00343 321               ZW1  = ZW1R
 00344 322               ZW2  = ZW2R
 00345 323               X    = WRK(MP1+7)
 00346 324               Y    = WRK(MP1+8)
 00347 325               CV1  = (ZW2*X - Y) / ((ZW1-X)*X)
 00348 326               X    = WRK(MP3+7)
 00349 327               Y    = WRK(MP3+8)
 00350 328               CV3  = (ZW2*X - Y) / ((ZW1-X)*X)
 00351 329               CRVR = (CV1 + CV3) * .5 + CRV1
 00352 330               CRV0 = CRVR
 00353 331            CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 00354 332            CALL SETS(HST(1),0,160,0)
 00355 333            FOR IP0 = HPHT0,HPHT9,HLDHT
 00356 334               IF IWRK(IP0).NE.IW1
 00357 335               THEN
 00358 338                  X    = WRK(IP0+5)
 00359 339                  Y    = WRK(IP0+6)
 00360 340                  DX   = ZW1 - X
 00361 341                  IBNL = 1000
 00362 342                  IBNR = 1000
 00363 343                  IF ABS(DX).GT.5.0
 00364 344                  THEN
 00365 347                     CRV = (ZW2*X - Y) / (DX*X)
 00366 348                     IBNL = (CRV-CRV0) / DCRV + 1
 00367    C     IF(MP1.EQ.994)PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNL
 00368 349                  CIF
 00369 350                  X   = WRK(IP0+7)
 00370 351                  Y   = WRK(IP0+8)
 00371 352                  DX  = ZW1 - X
 00372 353                  IF ABS(DX).GT.5.0
 00373 354                  THEN
 00374 357                     CRV = (ZW2*X - Y) / (DX*X)
 00375 358                     IBNR = (CRV-CRV0) / DCRV + 1
 00376    C     IF(MP1.EQ.994)PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNR
 00377 359                  CIF
 00378 360                  IF IABS(IBNL-IBNR).GT.3
 00379 361                  THEN
 00380 364                     IF(IBNL.GT.0 .AND. IBNL.LE.40) HST(IBNL) = HST(IBNL) + 1
 00381 366                     IF(IBNR.GT.0 .AND. IBNR.LE.40) HST(IBNR) = HST(IBNR) + 1
 00382 368                  CIF
 00383 369               CIF
 00384 370            CFOR
 00385    C
 00386    C     IF(ICELL.LE.47)PRINT 2101, HST
 00387 372            MHST = 0
 00388 373            IMAX = 0
 00389 374            FOR I=19,22
 00390 375               NHST = HST(I-1) + HST(I  ) + HST(I+1)
 00391 376               IF NHST.GE.MHST
 00392 377               THEN
 00393 380                  MHST = NHST
 00394 381                  IMAX = I
 00395 382               CIF
 00396 383            CFOR
 00397    C     IF(ICELL.LE.47)PRINT 2102, IMAX,MHST,NHST
 00398    C
 00400 385            IF ILRSOL.LT.0                                               STORE PEAK FOR L/R SOLUTION
 00401 386            THEN
 00402 389               MHSTL = MHST
 00403 390               IMAXL = IMAX
 00404 391               CALL MVC(HSTL(1),0,HST(IMAX-2),0,10)
 00405 392            ELSE
 00406 394               MHSTR = MHST
 00407 395               IMAXR = IMAX
 00408 396               CALL MVC(HSTR(1),0,HST(IMAX-2),0,10)
 00409 397            CIF
 00410 398         UNTIL ILRSOL.EQ.1
 00411    C
 00413 399         LBLRTR = 1                                                      SELECT L/R SOLUTION ACCORD. TO HIST.-PEAK
 00414 403         IF(MHSTL.GT.MHSTR) LBLRTR =-1
 00415                                                                             IF AMBIGUOUS L/R SOL. USE LINEL
 00416 405         IF(IABS(MHSTL-MHSTR).LE.1 .AND. LBLRTR.NE.LBLRLE) LBLRTR=-LBLRTR
 00417    C
 00418 407      CPROC
 00419    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 00420                                                                             *************************
 00421                                                                             *      F E T H S T      *
 00423    C                                                                        *************************
 00424    C
 00426 409      PROC FETHST                                                        FETCH HITS CONTRIBUTING TO HISTOGRAM PEAK
 00427    C
 00428    C
 00430 410         IF LBLRTR.LT.0                                                  EVALUATE PEAK
 00431 411         THEN
 00432 414            MHST = MHSTL
 00433 415            IMAX = IMAXL
 00434 416            CALL MVC(HST(1),0,HSTL(1),0,10)
 00435 417            ZW1 = ZW1L
 00436 418            ZW2 = ZW2L
 00437 419            CRV0 = CRVL
 00438 420         ELSE
 00439 422            MHST = MHSTR
 00440 423            IMAX = IMAXR
 00441 424            CALL MVC(HST(1),0,HSTR(1),0,10)
 00442 425            ZW1 = ZW1R
 00443 426            ZW2 = ZW2R
 00444 427            CRV0 = CRVR
 00445 428         CIF
 00446    C
 00448 429         IF IMAX.EQ.19 .AND.                                             CORRECT FOR DOUBLE PEAK
 00449         ?      HST(1).GT.0 .AND. HST(1).GT.HST(2) .AND. HST(5).NE.0
 00450 430         THEN
 00451 433            IMAX = IMAX + 1
 00452 434         CIF
 00453 435         IF IMAX.EQ.22 .AND.
 00454         ?      HST(5).GT.0 .AND. HST(5).GT.HST(4) .AND. HST(1).NE.0
 00455 436         THEN
 00456 439            IMAX = IMAX - 1
 00457 440         CIF
 00458 441         IM1 = IMAX - 1
 00459 442         IM3 = IMAX + 1
 00460 443         NHST  = HST(2) + HST(3) + HST(4)
 00461 444         NHTTR = 0
 00462 445         IF NHST.GE.3
 00463 446         THEN
 00464    C     IF(ICELL.LE.47)PRINT 2102,IMAX,MHST,LBLRTR,IM1,IM3,MHSTL,MHSTR
 00465    C
 00467 449            IHIT = 0                                                     FETCH HITS OF PEAK IN HISTOGRAM
 00468 450            ILAYL = -1
 00469 451            LBHDEL = 0
 00470 452            CALL SETS(HLBAR(1),0,32,0)
 00471 453            FOR IP0 = HPHT0,HPHT9,HLDHT
 00472 454               IBNL = -1000
 00473 455               IBNR = -1000
 00474 456               IF IABS(IWRK(IP0)-IW1).LE.1
 00475 457               THEN
 00476 460                  IF LBLRTR.LT.0
 00477 461                  THEN
 00478 464                     IF(IP0.EQ.MP1.OR.IP0.EQ.MP2.OR.IP0.EQ.MP3) IBNL = IMAX
 00479 466                  ELSE
 00480 468                     IF(IP0.EQ.MP1.OR.IP0.EQ.MP2.OR.IP0.EQ.MP3) IBNR = IMAX
 00481 470                  CIF
 00482 471               ELSE
 00483 473                  X   = WRK(IP0+5)
 00484 474                  Y   = WRK(IP0+6)
 00485 475                  DX  = ZW1 - X
 00486 476                  IF ABS(DX).GT.5.0
 00487 477                  THEN
 00488 480                     CRV = (ZW2*X - Y) / (DX*X)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 00489 481                     IBNL = (CRV-CRV0) / DCRV + 1
 00490    C     IF(MP1.EQ.994) PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNL
 00491 482                  CIF
 00492 483                  X   = WRK(IP0+7)
 00493 484                  Y   = WRK(IP0+8)
 00494 485                  DX  = ZW1 - X
 00495 486                  IF ABS(DX).GT.5.0
 00496 487                  THEN
 00497 490                     CRV = (ZW2*X - Y) / (DX*X)
 00498 491                     IBNR = (CRV-CRV0) / DCRV + 1
 00499    C     IF(MP1.EQ.994) PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNR
 00500 492                  CIF
 00501 493               CIF
 00502 494               IF IABS(IBNL-IBNR).GT.3
 00503 495               THEN
 00504 498                  ILAY = IWRK(IP0)
 00505 499                  IF IBNL.GE.IM1 .AND. IBNL.LE.IM3
 00506 500                  THEN
 00507 503                     IF ILAY.EQ.ILAYL
 00508 504                     THEN
 00510 507                        IF(LBHDEL.EQ.0) IHIT = IHIT - 1                  ELIMINATE 2 HITS IN 1 LAYER
 00511 509                        LBHDEL = 1
 00512 510                     ELSE
 00513 512                        IHIT = IHIT + 1
 00514 513                        HPBAK(IHIT  ) = IP0
 00515 514                        HLYAR(IHIT  ) = ILAY
 00516 515                        HLBAR(IHIT  ) =   1
 00517 516                        DSPAR(IHIT  ) = WRK(IP0+2)
 00518 517                        XTRAR(IHIT  ) = WRK(IP0+5)
 00519 518                        YTRAR(IHIT  ) = WRK(IP0+6)
 00520 519                        ILAYL = ILAY
 00521 520                        LBHDEL = 0
 00522 521                     CIF
 00523 522                  ELSE
 00524 524                     IF IBNR.GE.IM1 .AND. IBNR.LE.IM3
 00525 525                     THEN
 00526 528                        IF ILAY.EQ.ILAYL
 00527 529                        THEN
 00529 532                           IF(LBHDEL.EQ.0) IHIT = IHIT - 1               ELIMINATE 2 HITS IN 1 LAYER
 00530 534                           LBHDEL = 1
 00531 535                        ELSE
 00532 537                           IHIT = IHIT + 1
 00533 538                           HPBAK(IHIT  ) = IP0
 00534 539                           HLYAR(IHIT  ) = ILAY
 00535 540                           HLBAR(IHIT  ) =   1
 00536 541                           DSPAR(IHIT  ) = WRK(IP0+2)
 00537 542                           XTRAR(IHIT  ) = WRK(IP0+7)
 00538 543                           YTRAR(IHIT  ) = WRK(IP0+8)
 00539 544                           ILAYL = ILAY
 00540 545                           LBHDEL = 0
 00541 546                        CIF
 00542 547                     CIF
 00543 548                  CIF
 00544 549               CIF
 00545 550            CFOR
 00546 552            NHTTR = IHIT
 00547    C     IF(ICELL.LE.47)
 00548    C    ,PRINT 2103, IPHT1,NHTTR,HPBAK,HLBAR,HLYAR,XTRAR,YTRAR,DSPAR
 00549 553         CIF
 00550    C
 00551 554      CPROC
 00552    C
 00553                                                                             *************************
 00554                                                                             *      F E T H I T      *
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 00556    C                                                                        *************************
 00557    C
 00559 556      PROC FETHIT                                                        FETCH HITS
 00560    C
 00561 557         IHIT = 0
 00562 558         IWL  =-1
 00563 559         CALL SETS(HLBAR(1),0,32,0)
 00564 560         FOR IP0 = HPHT0,HPHT9,HLDHT
 00565 561            IW0 = IWRK(IP0)
 00566 562            X   = WRK(IP0+5)
 00567 563            Y   = WRK(IP0+6)
 00568 564            F   = (PAR1 *X + PAR2 )*X + PAR3
 00569 565            DFL = F - Y
 00570 566            IF ABS(DFL).LT.FETLIM
 00571 567            THEN
 00572 570               IF IWL.EQ.IW0
 00573 571               THEN
 00575 574                  IHIT = IHIT - 1                                        ELIMINATE HIT IF 2 HITS IN SAME LAYER
 00576 575               ELSE
 00577 577                  IHIT = IHIT + 1
 00578 578                  HPBAK(IHIT  ) = IP0
 00579 579                  HLYAR(IHIT  ) = IW0
 00580 580                  HLBAR(IHIT  ) =   1
 00581 581                  DSPAR(IHIT  ) = WRK(IP0+2)
 00582 582                  XTRAR(IHIT  ) = WRK(IP0+5)
 00583 583                  YTRAR(IHIT  ) =   Y
 00584 584                  IWL = IW0
 00585 585               CIF
 00586 586            CIF
 00587 587            X   = WRK(IP0+7)
 00588 588            Y   = WRK(IP0+8)
 00589 589            F   = (PAR1 *X + PAR2 )*X + PAR3
 00590 590            DF  = F - Y
 00591 591            IF ABS(DF).LT.FETLIM
 00592 592            THEN
 00593 595               IF IWL.EQ.IW0
 00594 596               THEN
 00596 599                  IHIT = IHIT - 1                                        ELIMINATE HIT IF 2 HITS IN SAME LAYER
 00597 600               ELSE
 00598 602                  IHIT = IHIT + 1
 00599 603                  HPBAK(IHIT  ) = IP0
 00600 604                  HLYAR(IHIT  ) = IW0
 00601 605                  HLBAR(IHIT  ) =   1
 00602 606                  DSPAR(IHIT  ) = WRK(IP0+2)
 00603 607                  XTRAR(IHIT  ) = WRK(IP0+7)
 00604 608                  YTRAR(IHIT  ) =   Y
 00605 609                  IWL = IW0
 00606 610               CIF
 00607 611            CIF
 00608 612         CFOR
 00609 614         NHTTR = IHIT
 00610    C     IF(ICELL.LE.47)
 00611    C    ,PRINT 2103, IPHT1,NHTTR,HPBAK,HLBAR,HLYAR,XTRAR,YTRAR,DSPAR
 00612    C
 00613 615      CPROC
 00614    C
 00615                                                                             *************************
 00616                                                                             *      F P A R A 0      *
 00618    C                                                                        *************************
 00619    C
 00621 617      PROC FPARA0                                                        PARABOLA FIT THROUG ORIGIN
 00622    C
 00623                                                                             GET EQUATIONS
 00625 618         S0 = WGHT0                                                      WEIGHT ORIGIN AS POINT OF PARABOLA
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 00626 619         S1 = 0.
 00627 620         S2 = 0.
 00628 621         S3 = 0.
 00629 622         S4 = 0.
 00630 623         S5 = 0.
 00631 624         S6 = 0.
 00632 625         S7 = Y0 * WGHT0
 00633 626         FOR IHIT = 1,NHTTR
 00634 627            X = XTRAR(IHIT)
 00635 628            Y = YTRAR(IHIT)
 00636 629            X2 = X**2
 00637 630            S1 = S1 + X
 00638 631            S2 = S2 + X2
 00639 632            S3 = S3 + X*X2
 00640 633            S4 = S4 + X2**2
 00641 634            S5 = S5 + Y*X2
 00642 635            S6 = S6 + Y*X
 00643 636            S7 = S7 + Y
 00644 637            S0 = S0 + 1.
 00645 638         CFOR
 00646 640         MHIT = S0
 00647    C
 00649 641         F1 = 1. / S4                                                    SOLVE EQUATIONS FOR PARABOLA FIT
 00650 642         XX12 = S3*F1
 00651 643         XX13 = S2*F1
 00652 644         YY1  = S5*F1
 00653 645         XX22 = S2 - S3*XX12
 00654 646         XX23 = S1 - S3*XX13
 00655 647         YY2  = S6 - S3*YY1
 00656 648         XX32 = S1 - S2*XX12
 00657 649         XX33 = S0 - S2*XX13
 00658 650         YY3  = S7 - S2*YY1
 00659 651         IF XX22.GT.XX32
 00660 652         THEN
 00661 655            XX23 = XX23 / XX22
 00662 656            YY2  = YY2  / XX22
 00663 657            PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 00664 658            PAR2 = YY2 - XX23*PAR3
 00665 659         ELSE
 00666 661            XX33 = XX33 / XX32
 00667 662            YY3  = YY3  / XX32
 00668 663            PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 00669 664            PAR2 = YY3 - XX33*PAR3
 00670 665         CIF
 00671 666         PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
 00672 667         DEG = S0 - WGHT0 - 2.
 00673    C
 00675 668         CHISQ = 0.                                                      CALC. CHISQ + SOLVE L/R AMBIGUITY
 00676 669         DCHIM1 = 0.
 00677 670         IHITM1 = 0
 00679 671         NEVN   = 0                                                      L/R AMB. FROM STAGGERING
 00680 672         CHEVN  = 0.
 00681 673         NUNE   = 0
 00682 674         CHUNE  = 0.
 00683 675         IHSTRT = 0
 00684 676         FOR IHIT = 1,NHTTR
 00685 677            IF(IHSTRT.EQ.0) IHSTRT = IHIT
 00686 679            IHEND = IHIT
 00687 680            X = XTRAR(IHIT)
 00688 681            Y = YTRAR(IHIT)
 00689 682            F   = (PAR1 *X + PAR2 )*X + PAR3
 00690 683            DCHI = Y - F
 00691 684            RESAR(IHIT) = DCHI
 00693 685            CHISQ = CHISQ + DCHI**2                                      SUM FOR RMS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 12
0CARD TARGET
  NO  STM.NO
 
 00695 686            IF ABS(DCHI).GE.DCHIM1                                       KEEP BIGGEST RMS
 00696 687            THEN
 00697 690               DCHIM1 = ABS(DCHI)
 00698 691               IHITM1 = IHIT
 00699 692            CIF
 00700 693            ILAY = HLYAR(IHIT)
 00701 694            IF ABS(DCHI).LT. 0.6
 00702 695            THEN
 00703 698               IF LAND(ILAY,1).EQ.0
 00704 699               THEN
 00705 702                  NEVN  = NEVN  + 1
 00706 703                  CHEVN = CHEVN + DCHI
 00707 704               ELSE
 00708 706                  NUNE  = NUNE  + 1
 00709 707                  CHUNE = CHUNE + DCHI
 00710 708               CIF
 00711 709            CIF
 00712    C     IF(ICELL.LE.47)PRINT 2006, ILAY,X,Y,F,DCHI,CHISQ,XTRAR(IHIT)
 00713 710         CFOR
 00714 712         SIG    =      CHISQ  / DEG
 00715 713         DSTAG = -1000.
 00716 714         IF(NEVN.GT.1.AND. NUNE.GT.1) DSTAG = ABS(CHEVN/NEVN - CHUNE/NUNE)
 00717    C
 00719 716         SIGLM = .25                                                     LIMIT OF SIGMA
 00720    C
 00721    C     IF(ICELL.LE.47)PRINT 2013,NHTTR,SIG,DEG,PAR1,PAR2,PAR3,WGHT0,Y0
 00722    C
 00723 717      CPROC
 00724    C
 00725                                                                             *************************
 00726                                                                             *      L A B E L        *
 00728    C                                                                        *************************
 00729    C
 00731 719      PROC LABEL                                                         LABEL USED HITS
 00732    C
 00733 720         NHTGD  = 0
 00734 721         FOR IP0 = HPHT0,HPHT9,HLDHT
 00735 722            IW0 = IWRK(IP0)
 00736 723            X   = WRK(IP0+5)
 00737 724            Y   = WRK(IP0+6)
 00738 725            F   = (PAR1 *X + PAR2 )*X + PAR3
 00739 726            DFL = F - Y
 00740 727            X   = WRK(IP0+7)
 00741 728            Y   = WRK(IP0+8)
 00742 729            F   = (PAR1 *X + PAR2 )*X + PAR3
 00743 730            DFR = F - Y
 00745 731            DF  = DFL                                                    SELECT CLOSEST HIT
 00746 732            IF(ABS(DFR).LT.ABS(DFL)) DF = DFR
 00747 734            IF ABS(DF).LT.ALBLM2
 00748 735            THEN
 00749    C
 00751 738               ILBLR = 1                                                 CLOSE HIT
 00752 739               IF(DF.EQ.DFR) ILBLR = 2
 00753 741               IF ABS(DF).LT.ALBLM1
 00754 742               THEN
 00756 745                  NHTGD  = NHTGD + 1                                     HIT BELONGS TO TRACK
 00757 746                  IF(IWRK(IP0+ 9).LT.0) IWRK(IP0+ 9) = 0
 00758 748                  IF(IWRK(IP0+10).LT.0) IWRK(IP0+10) = 0
 00759 750                  IWRK(IP0+10) = IWRK(IP0+9)
 00760 751                  IWRK(IP0+ 9) = ITRK
 00761 752                  IF IWRK(IP0+10).NE.0
 00762 753                  THEN
 00763 756                     LB2 = LAND(IWRK(IP0+4),    3)*4
 00764 757                  ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 13
0CARD TARGET
  NO  STM.NO
 
 00765 759                     LB2 = 0
 00766 760                  CIF
 00767 761                  LB1 = LAND(IWRK(IP0+4),MKLR1)
 00768 762                  LB1 = LOR(LB1,LB2)
 00769 763                  IWRK(IP0+4) = LOR(LB1,ILBLR)
 00770 764               ELSE
 00772 766                  IF IWRK(IP0+ 9).LE.0                                   HIT MAY BELONG TO TRACK
 00773 767                  THEN
 00774 770                     IWRK(IP0+10) = IWRK(IP0+9)
 00775 771                     IWRK(IP0+ 9) =-ITRK
 00776 772                     IF IWRK(IP0+10).NE.0
 00777 773                     THEN
 00778 776                        LB2 = LAND(IWRK(IP0+4),    3)*4
 00779 777                     ELSE
 00780 779                        LB2 = 0
 00781 780                     CIF
 00782 781                     LB1 = LAND(IWRK(IP0+4),MKLR1)
 00783 782                     LB1 = LOR(LB1,LB2)
 00784 783                     IWRK(IP0+4) = LOR(LB1,ILBLR)
 00785 784                  CIF
 00786 785               CIF
 00787 786            CIF
 00788 787         CFOR
 00789    C
 00790 789      CPROC
 00791    C
 00792 791      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         790 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         790 TARGET STATEMENTS
 00000    C   03/10/80 102191156  MEMBER NAME  FTRELO   (PATRECSR)    SHELTRAN
 00001   2      SUBROUTINE FTRELO
 00002    C
 00003    C        FIND TRACK ELEMENTS FROM LINE ELEMENTS: P.STEFFEN(80/06/27)
 00004    C                   HISTOGRAM METHOD USING INTERACTION POINT
 00005    C                   NO STOP AT POINT OF DIVERGENCE
 00006    C
 00007   3      IMPLICIT INTEGER*2 (H)
 00008   4      LOGICAL TBIT
 00009    C
          C-------------------------------
          C  MACRO CHEADR .... HEADER BANK
          C-------------------------------
         5      COMMON /CHEADR/ IHEADR(54)
         6      INTEGER*2 HHEADR(108)
         7      EQUIVALENCE (IHEADR(1),HHEADR(1))
          C --
          C --  HHEADR(17) = EXPERIMENT NUMBER
          C --  HHEADR(18) = RUN NUMBER
          C --  HHEADR(19) = EVENT NUMBER
          C --  HHEADR(38) = MAGNETIC FIELD (GAUSS)
          C --
          C--------- END OF MACRO CHEADR ------------
 00011   8      EQUIVALENCE (HRUN,HHEADR(18)) , (HEV,HHEADR(19))
 00012    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         9      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
        10      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        11      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        12      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        13      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        14      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        15      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  16      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 00015    C
 00016  17      EQUIVALENCE
 00017         ,           (ICELL ,IDWRK(1)),(MHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00018         ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
 00019    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        18      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        19      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        20      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        21      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        22      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 00021    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  23      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
 00500         +                  RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,
 00510         +                  ZRESOL,ZNORM,ZAL,ZSCAL,DRIDEV,DRICOS,DRISIN,
 00600         +                  PEDES,TZERO(3),DRIROT(96,2),SINDRI(96,2),
 00701         +                  COSDRI(96,2),DRIVEL(96,2),T0FIX(3),
 00800         +                  ABERR(8), DUMJDC(20)
 00900    C
 01100    C      BLOCK DATA SET TO MC VALUES, KALIBR WILL SET REAL DATA VALUES
 01210    C--->  A CHANGE OF THIS COMMON MUST BE DONE SIMULTANEOUSLY WITH  <----
 01220    C--->  A CHANGE OF THE BLOCK DATA                                <----
 01230    C
 01300    C--------------------------- END OF MACRO CJDRCH -----------------------
 01400    C
          C----------------------------------------------------------------------
          C           MACRO CDSMAX .... PATTERN RECOGNITION CONSTANTS.
          C----------------------------------------------------------------------
        24      COMMON/CDSMAX/DSMAX(16,3,2),DIRWR1(24,2),DIRWR3(48,2)
               *             ,DHALF(16,3,2),DTWICE(16,3,2),HMCH(16,3,2)
               *             ,IBCK(9),DBCK(30),TRMATS(96,2),TRMATC(96,2)
          C------------------------ END OF MACRO CDSMAX -------------------------
 00024    C
 00025  25      DIMENSION HPBAK(16),HLYAR(16),HLBAR(16),DSPAR(16),
 00026         ,          XTRAR(16),YTRAR(16),RESAR(16)
 00027  26      DIMENSION HST( 80), HSTL(5),HSTR(5)
 00028    C
 00030  27      DATA XCV /152.7/                                                   AVERAGE RADIUS FOR PAIR CONVERSION IN BEAM PIPE OR
 00031    C
 00033    C     DATA MKGDLN / Z107/                                                MASK FOR GOOD LINEL
 00035    C     DATA MKDIVL / Z100/                                                MASK FOR DIVERGING LINEL
 00036    C
 00038    C     DATA LBNOCN / Z1/                                                  LABEL FOR NO CONTINUATION OF TREL
 00040    C     DATA LBKINK / Z2/                                                  LABEL FOR KINK AT END POINT OF TREL
 00041    C
 00043  28      REAL SGCRV(3) /.000062,.000035,.000025/                            SIGMA(CURV) FOR HITS IN 3 RINGS
 00044    C
 00045    C     IF(ICELL.NE.40 .AND. ICELL.NE.58) RETURN
 00046    C2001 FORMAT(' L/R DET.:',10F8.3)
 00047    C2006 FORMAT(1X,I6,5F8.2,F12.1,5F8.2)
 00048    C2013 FORMAT('0FIT:',I3,F5.2,F5.1,F10.6,F7.3,F5.1,F7.4,F6.1,F5.2)
 00049    C2014 FORMAT(' X,Y,ZW1,ZW2,CRV0,CRV,IBNL:',6F10.5,I10)
 00050    C2100 FORMAT(' LINEL ',4I6,2F6.2,I4)
 00051    C2101 FORMAT('0HISTOGRAM:',20I2,2X,20I2,/,(11X,20I2,2X,20I2))
 00052    C2102 FORMAT(' PEAK =', 7I6,6F10.5)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00053    C2103 FORMAT(' TREL:',2I6,3(/,1X,16I7),3(/,1X,16F7.2))
 00054    C2900 FORMAT(1H0,'ERROR CODE:',I4, ', ICELL:',I3,', TRACKS:',I4)
 00055    C2901 FORMAT(1X,/,(1X,2I6,2F6.2,2X,Z4,4F7.1,2I6,F6.2))
 00056    C
 00058  29      ITRK = 0                                                           POINTER TO CURRENT TRKEL
 00059    C
 00061  30      DR =  RINCR(IRING)                                                 CALCULATE X,Y COORDINATES
 00062  31      R0 = FSENSW(IRING)
 00064  32      DRC = RINCR(1)*.5 * DRICOS                                         RADIUS AROUND WIRE FOR CORR. OF DRIFTSPACE
 00065    C
 00066  33      FOR IP = HPHT0,HPHT9,HLDHT
 00067  34         ILAY = IWRK(IP  )
 00068  35         Y    = SWDEPL
 00069  36         IF(LAND(ILAY,1).NE.0) Y =-Y
 00070  38         X    = ILAY * DR + R0
 00071  39         DS   =  WRK(IP+2)
 00072  40         IF DS.LE.DRC
 00073  41         THEN
 00074  44            DX   = 0.
 00075  45            DY   = DS
 00076  46         ELSE
 00077  48            DX   =-(DS-DRC)*DRISIN
 00078  49            DY   = (DS-DRC)*DRICOS + DRC
 00079  50         CIF
 00080  51         WRK(IP+5) = X - DX
 00081  52         WRK(IP+7) = X + DX
 00082  53         WRK(IP+6) = Y - DY
 00083  54         WRK(IP+8) = Y + DY
 00084  55      CFOR
 00085    C     PRINT 2900, IRING, ICELL, NTRCNT
 00086    C     IF(ICELL.LE.47) PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
 00087    C
 00089  57      IPHT1 = HPHT9 - HLDHT + 1                                          LOOP OVER HITS + SEARCH FOR LINE ELEMENT
 00090  58      REPEAT
 00092  59         IL1 = IWRK(IPHT1  )                                             1. HIT
 00093  60         IF(IL1.LT. 2) XREPEAT
 00095  62         DSP1 =  WRK(IPHT1+2)                                            CHECK IF UNUSED
 00096  63         IF DSP1.GT.0.7 .AND. IWRK(IPHT1+9).LE.0
 00097  64         THEN
 00098  67            IL2 =  IL1 - 1
 00099  68            IL3 =  IL2 - 1
 00100    C
 00102  69            DSLM = 1000.                                                 SEARCH STRAIGHTEST LINEL
 00103    C
 00105  70            IPHT2 = IPHT1 - HLDHT                                        SEARCH FOR 2. HIT
 00106  71            WHILE IPHT2.GE.HPHT0 .AND. IWRK(IPHT2).GE.IL2
 00108  73               DSP2 = WRK(IPHT2+2)                                       CHECK IF NEXT LAYER + UNUSED HIT
 00109  77               IF DSP2.GT.0.7.AND.IWRK(IPHT2).EQ.IL2.AND.IWRK(IPHT2+9).LE.0
 00110  78               THEN
 00111  81                  IF ABS(DSP2-DSP1).LE.12.5
 00112  82                  THEN
 00113    C
 00115  85                     IPHT3 = IPHT2 - HLDHT                               SEARCH FOR 3. HIT
 00116  86                     WHILE IPHT3.GE.HPHT0 .AND. IWRK(IPHT3).GE.IL3
 00118  88                        DSP3 = WRK(IPHT3+2)                              CHECK IF NEXT LAYER + UNUSED HIT
 00119  92                        IF DSP3.GT.0.7 .AND.
 00120         ?                     IWRK(IPHT3).EQ.IL3 .AND. IWRK(IPHT3+9).LE.0
 00121  93                        THEN
 00123  96                           DSL = DSP2*2.-DSP3-DSP1                       SEARCH FOR SRAIGHTEST LINEL
 00124  97                           IF ABS(DSL).LT.DSLM .AND. DSP1+DSP2+DSP3.GT.3.0
 00125  98                           THEN
 00126 101                              IF IWRK(IPHT1+9).EQ.0 .OR. IWRK(IPHT2+9).EQ.0
 00127         ?                           .OR. IWRK(IPHT3+9).EQ.0
 00128 102                              THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 00129 105                                 DSLM  = ABS(DSL)
 00130 106                                 SDSLM = DSL
 00131 107                                 MP1 = IPHT1
 00132 108                                 MP2 = IPHT2
 00133 109                                 MP3 = IPHT3
 00134 110                              CIF
 00135 111                           CIF
 00136 112                        CIF
 00137 113                        IPHT3 = IPHT3 - HLDHT
 00138 114                     CWHILE
 00139 116                  CIF
 00140 117               CIF
 00141 118               IPHT2 = IPHT2 - HLDHT
 00142 119            CWHILE
 00143    C
 00145 121            REPEAT                                                       'XREPEAT' = STOP ANALYSIS
 00146
 00147
 00148
 00150 122               LBLRLE = LAND(IL2,1)*2 - 1                                CHECK IF GOOD LINEL
 00151 123               IF(SDSLM.LT.0) LBLRLE =-LBLRLE
 00152    C     IF(ICELL.LE.47)PRINT 2100, IL1,MP1,MP2,MP3,DSLM,SDSLM,LBLRLE
 00153 125               IF(DSLM.GE.2.0) XREPEAT
 00154    C
 00156 127               LBLRLE = LAND(IL2,1)*2 - 1                                GOOD LINEL, FETCH OTHER HITS
 00157 128               IF(SDSLM.LT.0) LBLRLE =-LBLRLE
 00158 130               PERFORM CVHIST
 00159    C
 00161 133               LRLOOP = 1                                                LOOP OVER L/R SOL. TRY BEST ONE FIRST
 00162 134               SIGLM = .250
 00163 135               SIG0 = 1000.
 00164 136               WHILE LRLOOP.LE.2
 00165    C
 00167 138                  PERFORM FETHST                                         FETCH HITS CONTRIBUTING TO HISTOGRAM PEAK
 00168    C
 00170 144                  IF(NHTTR.LT.4) XWHILE                                  CHECK IF AT LEAST 4 HITS
 00171    C
 00173 146                  WGHT0 = 0.01                                           FIT PARABOLA THROUGH ORIGIN
 00174 147                  Y0    = 0.
 00175 148                  PERFORM FPARA0
 00177 151                  IF ABS(PAR3).GT.3.0                                    CHECK IF DIST. TO ORIGIN ACCEPTABLE
 00178 152                  THEN
 00179 155                     WGHT0 = 0.1
 00180 156                     IF PAR1*PAR3.LE.0.
 00181 157                     THEN
 00182 160                        Y0 =-SIGN(2.,PAR1)
 00183 161                        PERFORM FPARA0
 00184 164                     ELSE
 00185 166                        DORMX = XCV**2*PAR1 + SIGN(2.,PAR1)
 00186 167                        IF ABS(PAR3).GT.ABS(DORMX)
 00187 168                        THEN
 00189 171                           Y0 = DORMX                                    TOO BIG DIST., REPEAT FIT WITH RESTRICTION
 00190 172                           PERFORM FPARA0
 00191 175                        CIF
 00192 176                     CIF
 00193 177                  CIF
 00194    C
 00196 178                  SIGLM = .50                                            CHECK IF REASONABLE FIT
 00197 179                  IF SIG.GT.SIGLM
 00198 180                  THEN
 00200 183                     SIG1 = (SIG*DEG - DCHIM1**2) / (DEG-1.)             BAD FIT, CHECK IF ONLY 1 BAD HIT
 00201 184                     IF(SIG1.GT.SIGLM .AND. LRLOOP.EQ.1) XREPEAT
 00202 186                  CIF
 00203    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 00205 187                  FETLIM = 0.65                                          FETCH HITS
 00206 188                  PERFORM FETHIT
 00207 191                  WGHT0 = .01
 00208 192                  IF NHTTR.GE.4
 00209 193                  THEN
 00211 196                     PERFORM FPARA0                                      FIT PARABOLA THROUGH ORIGIN
 00212    C
 00214 199                     IF ABS(PAR3).GT.3.0                                 CHECK IF DIST. TO ORIGIN ACCEPTABLE
 00215 200                     THEN
 00216 203                        WGHT0 = 0.1
 00217 204                        IF PAR1*PAR3.LE.0.
 00218 205                        THEN
 00219 208                           Y0 =-SIGN(2.,PAR1)
 00220 209                           PERFORM FPARA0
 00221 212                        ELSE
 00222 214                           DORMX = XCV**2*PAR1 + SIGN(2.,PAR1)
 00223 215                           IF ABS(PAR3).GT.ABS(DORMX)
 00224 216                           THEN
 00226 219                              Y0 = DORMX                                 TOO BIG DIST., REPEAT FIT WITH RESTRICTION
 00227 220                              PERFORM FPARA0
 00228 223                           CIF
 00229 224                        CIF
 00230 225                     CIF
 00231 226                  CIF
 00233 227                  IF SIG.GT.SIGLM                                        CHECK IF REASONABLE FIT
 00234 228                  THEN
 00236 231                     SIG1 = (SIG*DEG - DCHIM1**2) / (DEG-1.)             BAD FIT, CHECK IF ONLY 1 BAD HIT
 00237 232                     IF(SIG1.GT.SIGLM .AND. LRLOOP.EQ.1) XREPEAT
 00238 234                  CIF
 00239    C
 00241 235                  SIGCOR = SIG                                           DET. CORRECTED SIGMA
 00242 236                  IF LRLOOP.EQ.2
 00243 237                  THEN
 00244 240                     DDSTG = DSTAG - DSTAG0
 00245 241                     SIGCOR = SIG - (DEG-DEG0)*.01 + DDSTG*.1 + .01
 00246    C     IF(ICELL.LE.47)PRINT 2001, SIG,SIGCOR,SIG0,DEG,DEG0,DSTAG,DSTAG0
 00247 242                  CIF
 00248    C
 00250 243                  IF SIGCOR .LT. SIG0                                    STORE BEST SOLUTION
 00251 244                  THEN
 00252 247                     LBLR0 = LBLRTR
 00253 248                     SIG0  = SIG
 00254 249                     SIGLM0= SIGLM
 00255 250                     PAR10 = PAR1
 00256 251                     PAR20 = PAR2
 00257 252                     PAR30 = PAR3
 00258 253                     DSTAG0= DSTAG
 00259 254                     DEG0  = DEG
 00261 255                     IF(SIG.LT..08) XWHILE                               STOP IF GOOD FIT
 00262 257                  CIF
 00263 258                  LBLRTR =-LBLRTR
 00264 259                  LRLOOP = LRLOOP + 1
 00265 260               CWHILE
 00266    C
 00268 262               IF(SIG0.GT..25) XREPEAT                                   CHECK IF GOOD SOL. FOUND
 00269    C
 00271 264               LBLRTR = LBLR0                                            RESTORE PARAMETERS
 00272 265               SIG    = SIG0
 00273 266               PAR1   = PAR10
 00274 267               PAR2   = PAR20
 00275 268               PAR3   = PAR30
 00276    C
 00278 269               ITRK = ITRK + 1                                           LABEL HITS
 00279 270               ALBLM1 = 0.7
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 00280 271               ALBLM2 = 2.0
 00281 272               PERFORM LABEL
 00282    C
 00284 275               IF(SIG0.GT..10 .AND. ICELL.LE.48) XREPEAT                 CHECK IF GOOD SOLUTION IN R2
 00285    C
 00287 277               IF(ABS(PAR1).GT..00040 .OR. NHTGD.LT.4) XREPEAT           CHECK IF CURV.(>200MEV)
 00288    C
 00290 279               HPFRE1 = HPFREE                                           TRACE TRACK THROUGH ORIGIN
 00291 280               CALL TRACEO(ITRK,PAR1,PAR2,PAR3)
 00292 281               HPFREE = HPFRE1
 00293    C
 00294 282            UNTIL .TRUE.
 00295    C
 00296 283         CIF
 00297 287         IPHT1 = IPHT1 - HLDHT
 00298 288      UNTIL IPHT1.LT.HPHT0
 00299    C
 00301    C                                                                        SET POINTER TO END OF TRACK ARRAY
 00303    C                                                                        SET NUMBER OF TRKELS
 00304    C     IF(ICELL.LE.47)PRINT 2900, IERRCD, ICELL, NTRCNT
 00305    C     IF(ICELL.LE.47)PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
 00306 289      RETURN
 00307    C
 00308                                                                             *************************
 00309                                                                             *      C V H I S T      *
 00310                                                                             *************************
 00312 293      PROC CVHIST                                                        HISTOGRAM OF CURVATURES
 00313    C
 00315 294         CALL SETS(HST(1),0,160,0)                                       ZERO HISTOGRAM
 00316 295         DCRV =  SGCRV(IRING)
 00317 296         CRV1 = -DCRV*20.
 00318 297         IW1 = IL2
 00319    C
 00321 298         ILRSOL =-3                                                      LOOP OVER L/R SOLUTIONS
 00322 299         REPEAT
 00323 300            ILRSOL = ILRSOL + 2
 00324 301            IF ILRSOL.LT.0
 00325 302            THEN
 00327 305               ZW1L = (WRK(MP1+5)+WRK(MP2+5)+WRK(MP3+5)) / 3.            LEFT SOLUTION
 00328 306               ZW2L = (WRK(MP1+6)+WRK(MP2+6)+WRK(MP3+6)) / (ZW1L*3.)
 00329 307               ZW1  = ZW1L
 00330 308               ZW2  = ZW2L
 00331 309               X    = WRK(MP1+5)
 00332 310               Y    = WRK(MP1+6)
 00333 311               CV1  = (ZW2*X - Y) / ((ZW1-X)*X)
 00334 312               X    = WRK(MP3+5)
 00335 313               Y    = WRK(MP3+6)
 00336 314               CV3  = (ZW2*X - Y) / ((ZW1-X)*X)
 00337 315               CRVL = (CV1 + CV3) * .5 + CRV1
 00338 316               CRV0 = CRVL
 00339 317            ELSE
 00341 319               ZW1R = (WRK(MP1+7)+WRK(MP2+7)+WRK(MP3+7)) / 3.            RIGHT SOLUTION
 00342 320               ZW2R = (WRK(MP1+8)+WRK(MP2+8)+WRK(MP3+8)) / (ZW1R*3.)
 00343 321               ZW1  = ZW1R
 00344 322               ZW2  = ZW2R
 00345 323               X    = WRK(MP1+7)
 00346 324               Y    = WRK(MP1+8)
 00347 325               CV1  = (ZW2*X - Y) / ((ZW1-X)*X)
 00348 326               X    = WRK(MP3+7)
 00349 327               Y    = WRK(MP3+8)
 00350 328               CV3  = (ZW2*X - Y) / ((ZW1-X)*X)
 00351 329               CRVR = (CV1 + CV3) * .5 + CRV1
 00352 330               CRV0 = CRVR
 00353 331            CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 00354 332            CALL SETS(HST(1),0,160,0)
 00355 333            FOR IP0 = HPHT0,HPHT9,HLDHT
 00356 334               IF IWRK(IP0).NE.IW1
 00357 335               THEN
 00358 338                  X    = WRK(IP0+5)
 00359 339                  Y    = WRK(IP0+6)
 00360 340                  DX   = ZW1 - X
 00361 341                  IBNL = 1000
 00362 342                  IBNR = 1000
 00363 343                  IF ABS(DX).GT.5.0
 00364 344                  THEN
 00365 347                     CRV = (ZW2*X - Y) / (DX*X)
 00366 348                     IBNL = (CRV-CRV0) / DCRV + 1
 00367    C     IF(MP1.EQ.994)PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNL
 00368 349                  CIF
 00369 350                  X   = WRK(IP0+7)
 00370 351                  Y   = WRK(IP0+8)
 00371 352                  DX  = ZW1 - X
 00372 353                  IF ABS(DX).GT.5.0
 00373 354                  THEN
 00374 357                     CRV = (ZW2*X - Y) / (DX*X)
 00375 358                     IBNR = (CRV-CRV0) / DCRV + 1
 00376    C     IF(MP1.EQ.994)PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNR
 00377 359                  CIF
 00378 360                  IF IABS(IBNL-IBNR).GT.3
 00379 361                  THEN
 00380 364                     IF(IBNL.GT.0 .AND. IBNL.LE.40) HST(IBNL) = HST(IBNL) + 1
 00381 366                     IF(IBNR.GT.0 .AND. IBNR.LE.40) HST(IBNR) = HST(IBNR) + 1
 00382 368                  CIF
 00383 369               CIF
 00384 370            CFOR
 00385    C
 00386    C     IF(ICELL.LE.47)PRINT 2101, HST
 00387 372            MHST = 0
 00388 373            IMAX = 0
 00389 374            FOR I=19,22
 00390 375               NHST = HST(I-1) + HST(I  ) + HST(I+1)
 00391 376               IF NHST.GE.MHST
 00392 377               THEN
 00393 380                  MHST = NHST
 00394 381                  IMAX = I
 00395 382               CIF
 00396 383            CFOR
 00397    C     IF(ICELL.LE.47)PRINT 2102, IMAX,MHST,NHST
 00398    C
 00400 385            IF ILRSOL.LT.0                                               STORE PEAK FOR L/R SOLUTION
 00401 386            THEN
 00402 389               MHSTL = MHST
 00403 390               IMAXL = IMAX
 00404 391               CALL MVC(HSTL(1),0,HST(IMAX-2),0,10)
 00405 392            ELSE
 00406 394               MHSTR = MHST
 00407 395               IMAXR = IMAX
 00408 396               CALL MVC(HSTR(1),0,HST(IMAX-2),0,10)
 00409 397            CIF
 00410 398         UNTIL ILRSOL.EQ.1
 00411    C
 00413 399         LBLRTR = 1                                                      SELECT L/R SOLUTION ACCORD. TO HIST.-PEAK
 00414 403         IF(MHSTL.GT.MHSTR) LBLRTR =-1
 00415                                                                             IF AMBIGUOUS L/R SOL. USE LINEL
 00416 405         IF(IABS(MHSTL-MHSTR).LE.1 .AND. LBLRTR.NE.LBLRLE) LBLRTR=-LBLRTR
 00417    C
 00418 407      CPROC
 00419    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 00420                                                                             *************************
 00421                                                                             *      F E T H S T      *
 00423    C                                                                        *************************
 00424    C
 00426 409      PROC FETHST                                                        FETCH HITS CONTRIBUTING TO HISTOGRAM PEAK
 00427    C
 00428    C
 00430 410         IF LBLRTR.LT.0                                                  EVALUATE PEAK
 00431 411         THEN
 00432 414            MHST = MHSTL
 00433 415            IMAX = IMAXL
 00434 416            CALL MVC(HST(1),0,HSTL(1),0,10)
 00435 417            ZW1 = ZW1L
 00436 418            ZW2 = ZW2L
 00437 419            CRV0 = CRVL
 00438 420         ELSE
 00439 422            MHST = MHSTR
 00440 423            IMAX = IMAXR
 00441 424            CALL MVC(HST(1),0,HSTR(1),0,10)
 00442 425            ZW1 = ZW1R
 00443 426            ZW2 = ZW2R
 00444 427            CRV0 = CRVR
 00445 428         CIF
 00446    C
 00448 429         IF IMAX.EQ.19 .AND.                                             CORRECT FOR DOUBLE PEAK
 00449         ?      HST(1).GT.0 .AND. HST(1).GT.HST(2) .AND. HST(5).NE.0
 00450 430         THEN
 00451 433            IMAX = IMAX + 1
 00452 434         CIF
 00453 435         IF IMAX.EQ.22 .AND.
 00454         ?      HST(5).GT.0 .AND. HST(5).GT.HST(4) .AND. HST(1).NE.0
 00455 436         THEN
 00456 439            IMAX = IMAX - 1
 00457 440         CIF
 00458 441         IM1 = IMAX - 1
 00459 442         IM3 = IMAX + 1
 00460 443         NHST  = HST(2) + HST(3) + HST(4)
 00461 444         NHTTR = 0
 00462 445         IF NHST.GE.3
 00463 446         THEN
 00464    C     IF(ICELL.LE.47)PRINT 2102,IMAX,MHST,LBLRTR,IM1,IM3,MHSTL,MHSTR
 00465    C
 00467 449            IHIT = 0                                                     FETCH HITS OF PEAK IN HISTOGRAM
 00468 450            ILAYL = -1
 00469 451            LBHDEL = 0
 00470 452            CALL SETS(HLBAR(1),0,32,0)
 00471 453            FOR IP0 = HPHT0,HPHT9,HLDHT
 00472 454               IBNL = -1000
 00473 455               IBNR = -1000
 00474 456               IF IABS(IWRK(IP0)-IW1).LE.1
 00475 457               THEN
 00476 460                  IF LBLRTR.LT.0
 00477 461                  THEN
 00478 464                     IF(IP0.EQ.MP1.OR.IP0.EQ.MP2.OR.IP0.EQ.MP3) IBNL = IMAX
 00479 466                  ELSE
 00480 468                     IF(IP0.EQ.MP1.OR.IP0.EQ.MP2.OR.IP0.EQ.MP3) IBNR = IMAX
 00481 470                  CIF
 00482 471               ELSE
 00483 473                  X   = WRK(IP0+5)
 00484 474                  Y   = WRK(IP0+6)
 00485 475                  DX  = ZW1 - X
 00486 476                  IF ABS(DX).GT.5.0
 00487 477                  THEN
 00488 480                     CRV = (ZW2*X - Y) / (DX*X)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 00489 481                     IBNL = (CRV-CRV0) / DCRV + 1
 00490    C     IF(MP1.EQ.994) PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNL
 00491 482                  CIF
 00492 483                  X   = WRK(IP0+7)
 00493 484                  Y   = WRK(IP0+8)
 00494 485                  DX  = ZW1 - X
 00495 486                  IF ABS(DX).GT.5.0
 00496 487                  THEN
 00497 490                     CRV = (ZW2*X - Y) / (DX*X)
 00498 491                     IBNR = (CRV-CRV0) / DCRV + 1
 00499    C     IF(MP1.EQ.994) PRINT 2014, X,Y,ZW1,ZW2,CRV0,CRV,IBNR
 00500 492                  CIF
 00501 493               CIF
 00502 494               IF IABS(IBNL-IBNR).GT.3
 00503 495               THEN
 00504 498                  ILAY = IWRK(IP0)
 00505 499                  IF IBNL.GE.IM1 .AND. IBNL.LE.IM3
 00506 500                  THEN
 00507 503                     IF ILAY.EQ.ILAYL
 00508 504                     THEN
 00510 507                        IF(LBHDEL.EQ.0) IHIT = IHIT - 1                  ELIMINATE 2 HITS IN 1 LAYER
 00511 509                        LBHDEL = 1
 00512 510                     ELSE
 00513 512                        IHIT = IHIT + 1
 00514 513                        HPBAK(IHIT  ) = IP0
 00515 514                        HLYAR(IHIT  ) = ILAY
 00516 515                        HLBAR(IHIT  ) =   1
 00517 516                        DSPAR(IHIT  ) = WRK(IP0+2)
 00518 517                        XTRAR(IHIT  ) = WRK(IP0+5)
 00519 518                        YTRAR(IHIT  ) = WRK(IP0+6)
 00520 519                        ILAYL = ILAY
 00521 520                        LBHDEL = 0
 00522 521                     CIF
 00523 522                  ELSE
 00524 524                     IF IBNR.GE.IM1 .AND. IBNR.LE.IM3
 00525 525                     THEN
 00526 528                        IF ILAY.EQ.ILAYL
 00527 529                        THEN
 00529 532                           IF(LBHDEL.EQ.0) IHIT = IHIT - 1               ELIMINATE 2 HITS IN 1 LAYER
 00530 534                           LBHDEL = 1
 00531 535                        ELSE
 00532 537                           IHIT = IHIT + 1
 00533 538                           HPBAK(IHIT  ) = IP0
 00534 539                           HLYAR(IHIT  ) = ILAY
 00535 540                           HLBAR(IHIT  ) =   1
 00536 541                           DSPAR(IHIT  ) = WRK(IP0+2)
 00537 542                           XTRAR(IHIT  ) = WRK(IP0+7)
 00538 543                           YTRAR(IHIT  ) = WRK(IP0+8)
 00539 544                           ILAYL = ILAY
 00540 545                           LBHDEL = 0
 00541 546                        CIF
 00542 547                     CIF
 00543 548                  CIF
 00544 549               CIF
 00545 550            CFOR
 00546 552            NHTTR = IHIT
 00547    C     IF(ICELL.LE.47)
 00548    C    ,PRINT 2103, IPHT1,NHTTR,HPBAK,HLBAR,HLYAR,XTRAR,YTRAR,DSPAR
 00549 553         CIF
 00550    C
 00551 554      CPROC
 00552    C
 00553                                                                             *************************
 00554                                                                             *      F E T H I T      *
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 00556    C                                                                        *************************
 00557    C
 00559 556      PROC FETHIT                                                        FETCH HITS
 00560    C
 00561 557         IHIT = 0
 00562 558         IWL  =-1
 00563 559         CALL SETS(HLBAR(1),0,32,0)
 00564 560         FOR IP0 = HPHT0,HPHT9,HLDHT
 00565 561            IW0 = IWRK(IP0)
 00566 562            X   = WRK(IP0+5)
 00567 563            Y   = WRK(IP0+6)
 00568 564            F   = (PAR1 *X + PAR2 )*X + PAR3
 00569 565            DFL = F - Y
 00570 566            IF ABS(DFL).LT.FETLIM
 00571 567            THEN
 00572 570               IF IWL.EQ.IW0
 00573 571               THEN
 00575 574                  IHIT = IHIT - 1                                        ELIMINATE HIT IF 2 HITS IN SAME LAYER
 00576 575               ELSE
 00577 577                  IHIT = IHIT + 1
 00578 578                  HPBAK(IHIT  ) = IP0
 00579 579                  HLYAR(IHIT  ) = IW0
 00580 580                  HLBAR(IHIT  ) =   1
 00581 581                  DSPAR(IHIT  ) = WRK(IP0+2)
 00582 582                  XTRAR(IHIT  ) = WRK(IP0+5)
 00583 583                  YTRAR(IHIT  ) =   Y
 00584 584                  IWL = IW0
 00585 585               CIF
 00586 586            CIF
 00587 587            X   = WRK(IP0+7)
 00588 588            Y   = WRK(IP0+8)
 00589 589            F   = (PAR1 *X + PAR2 )*X + PAR3
 00590 590            DF  = F - Y
 00591 591            IF ABS(DF).LT.FETLIM
 00592 592            THEN
 00593 595               IF IWL.EQ.IW0
 00594 596               THEN
 00596 599                  IHIT = IHIT - 1                                        ELIMINATE HIT IF 2 HITS IN SAME LAYER
 00597 600               ELSE
 00598 602                  IHIT = IHIT + 1
 00599 603                  HPBAK(IHIT  ) = IP0
 00600 604                  HLYAR(IHIT  ) = IW0
 00601 605                  HLBAR(IHIT  ) =   1
 00602 606                  DSPAR(IHIT  ) = WRK(IP0+2)
 00603 607                  XTRAR(IHIT  ) = WRK(IP0+7)
 00604 608                  YTRAR(IHIT  ) =   Y
 00605 609                  IWL = IW0
 00606 610               CIF
 00607 611            CIF
 00608 612         CFOR
 00609 614         NHTTR = IHIT
 00610    C     IF(ICELL.LE.47)
 00611    C    ,PRINT 2103, IPHT1,NHTTR,HPBAK,HLBAR,HLYAR,XTRAR,YTRAR,DSPAR
 00612    C
 00613 615      CPROC
 00614    C
 00615                                                                             *************************
 00616                                                                             *      F P A R A 0      *
 00618    C                                                                        *************************
 00619    C
 00621 617      PROC FPARA0                                                        PARABOLA FIT THROUG ORIGIN
 00622    C
 00623                                                                             GET EQUATIONS
 00625 618         S0 = WGHT0                                                      WEIGHT ORIGIN AS POINT OF PARABOLA
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 00626 619         S1 = 0.
 00627 620         S2 = 0.
 00628 621         S3 = 0.
 00629 622         S4 = 0.
 00630 623         S5 = 0.
 00631 624         S6 = 0.
 00632 625         S7 = Y0 * WGHT0
 00633 626         FOR IHIT = 1,NHTTR
 00634 627            X = XTRAR(IHIT)
 00635 628            Y = YTRAR(IHIT)
 00636 629            X2 = X**2
 00637 630            S1 = S1 + X
 00638 631            S2 = S2 + X2
 00639 632            S3 = S3 + X*X2
 00640 633            S4 = S4 + X2**2
 00641 634            S5 = S5 + Y*X2
 00642 635            S6 = S6 + Y*X
 00643 636            S7 = S7 + Y
 00644 637            S0 = S0 + 1.
 00645 638         CFOR
 00646 640         MHIT = S0
 00647    C
 00649 641         F1 = 1. / S4                                                    SOLVE EQUATIONS FOR PARABOLA FIT
 00650 642         XX12 = S3*F1
 00651 643         XX13 = S2*F1
 00652 644         YY1  = S5*F1
 00653 645         XX22 = S2 - S3*XX12
 00654 646         XX23 = S1 - S3*XX13
 00655 647         YY2  = S6 - S3*YY1
 00656 648         XX32 = S1 - S2*XX12
 00657 649         XX33 = S0 - S2*XX13
 00658 650         YY3  = S7 - S2*YY1
 00659 651         IF XX22.GT.XX32
 00660 652         THEN
 00661 655            XX23 = XX23 / XX22
 00662 656            YY2  = YY2  / XX22
 00663 657            PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 00664 658            PAR2 = YY2 - XX23*PAR3
 00665 659         ELSE
 00666 661            XX33 = XX33 / XX32
 00667 662            YY3  = YY3  / XX32
 00668 663            PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 00669 664            PAR2 = YY3 - XX33*PAR3
 00670 665         CIF
 00671 666         PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
 00672 667         DEG = S0 - WGHT0 - 2.
 00673    C
 00675 668         CHISQ = 0.                                                      CALC. CHISQ + SOLVE L/R AMBIGUITY
 00676 669         DCHIM1 = 0.
 00677 670         IHITM1 = 0
 00679 671         NEVN   = 0                                                      L/R AMB. FROM STAGGERING
 00680 672         CHEVN  = 0.
 00681 673         NUNE   = 0
 00682 674         CHUNE  = 0.
 00683 675         IHSTRT = 0
 00684 676         FOR IHIT = 1,NHTTR
 00685 677            IF(IHSTRT.EQ.0) IHSTRT = IHIT
 00686 679            IHEND = IHIT
 00687 680            X = XTRAR(IHIT)
 00688 681            Y = YTRAR(IHIT)
 00689 682            F   = (PAR1 *X + PAR2 )*X + PAR3
 00690 683            DCHI = Y - F
 00691 684            RESAR(IHIT) = DCHI
 00693 685            CHISQ = CHISQ + DCHI**2                                      SUM FOR RMS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 12
0CARD TARGET
  NO  STM.NO
 
 00695 686            IF ABS(DCHI).GE.DCHIM1                                       KEEP BIGGEST RMS
 00696 687            THEN
 00697 690               DCHIM1 = ABS(DCHI)
 00698 691               IHITM1 = IHIT
 00699 692            CIF
 00700 693            ILAY = HLYAR(IHIT)
 00701 694            IF ABS(DCHI).LT. 0.6
 00702 695            THEN
 00703 698               IF LAND(ILAY,1).EQ.0
 00704 699               THEN
 00705 702                  NEVN  = NEVN  + 1
 00706 703                  CHEVN = CHEVN + DCHI
 00707 704               ELSE
 00708 706                  NUNE  = NUNE  + 1
 00709 707                  CHUNE = CHUNE + DCHI
 00710 708               CIF
 00711 709            CIF
 00712    C     IF(ICELL.LE.47)PRINT 2006, ILAY,X,Y,F,DCHI,CHISQ,XTRAR(IHIT)
 00713 710         CFOR
 00714 712         SIG    =      CHISQ  / DEG
 00715 713         DSTAG = -1000.
 00716 714         IF(NEVN.GT.1.AND. NUNE.GT.1) DSTAG = ABS(CHEVN/NEVN - CHUNE/NUNE)
 00717    C
 00719 716         SIGLM = .25                                                     LIMIT OF SIGMA
 00720    C
 00721    C     IF(ICELL.LE.47)PRINT 2013,NHTTR,SIG,DEG,PAR1,PAR2,PAR3,WGHT0,Y0
 00722    C
 00723 717      CPROC
 00724    C
 00725                                                                             *************************
 00726                                                                             *      L A B E L        *
 00728    C                                                                        *************************
 00729    C
 00731 719      PROC LABEL                                                         LABEL USED HITS
 00732    C
 00733 720         NHTGD  = 0
 00734 721         FOR IP0 = HPHT0,HPHT9,HLDHT
 00735 722            IW0 = IWRK(IP0)
 00736 723            X   = WRK(IP0+5)
 00737 724            Y   = WRK(IP0+6)
 00738 725            F   = (PAR1 *X + PAR2 )*X + PAR3
 00739 726            DFL = F - Y
 00740 727            X   = WRK(IP0+7)
 00741 728            Y   = WRK(IP0+8)
 00742 729            F   = (PAR1 *X + PAR2 )*X + PAR3
 00743 730            DFR = F - Y
 00745 731            DF  = DFL                                                    SELECT CLOSEST HIT
 00746 732            IF(ABS(DFR).LT.ABS(DFL)) DF = DFR
 00747 734            IF ABS(DF).LT.ALBLM2
 00748 735            THEN
 00749    C
 00751 738               ILBLR = 1                                                 CLOSE HIT
 00752 739               IF(DF.EQ.DFR) ILBLR = 2
 00753 741               IF ABS(DF).LT.ALBLM1
 00754 742               THEN
 00756 745                  NHTGD  = NHTGD + 1                                     HIT BELONGS TO TRACK
 00757 746                  IF(IWRK(IP0+ 9).LT.0) IWRK(IP0+ 9) = 0
 00758 748                  IF(IWRK(IP0+10).LT.0) IWRK(IP0+10) = 0
 00759 750                  IWRK(IP0+10) = IWRK(IP0+9)
 00760 751                  IWRK(IP0+ 9) = ITRK
 00761 752                  IF IWRK(IP0+10).NE.0
 00762 753                  THEN
 00763 756                     LB2 = LAND(IWRK(IP0+4),    3)*4
 00764 757                  ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 13
0CARD TARGET
  NO  STM.NO
 
 00765 759                     LB2 = 0
 00766 760                  CIF
 00767 761                  LB1 = LAND(IWRK(IP0+4),MKLR1)
 00768 762                  LB1 = LOR(LB1,LB2)
 00769 763                  IWRK(IP0+4) = LOR(LB1,ILBLR)
 00770 764               ELSE
 00772 766                  IF IWRK(IP0+ 9).LE.0                                   HIT MAY BELONG TO TRACK
 00773 767                  THEN
 00774 770                     IWRK(IP0+10) = IWRK(IP0+9)
 00775 771                     IWRK(IP0+ 9) =-ITRK
 00776 772                     IF IWRK(IP0+10).NE.0
 00777 773                     THEN
 00778 776                        LB2 = LAND(IWRK(IP0+4),    3)*4
 00779 777                     ELSE
 00780 779                        LB2 = 0
 00781 780                     CIF
 00782 781                     LB1 = LAND(IWRK(IP0+4),MKLR1)
 00783 782                     LB1 = LOR(LB1,LB2)
 00784 783                     IWRK(IP0+4) = LOR(LB1,ILBLR)
 00785 784                  CIF
 00786 785               CIF
 00787 786            CIF
 00788 787         CFOR
 00789    C
 00790 789      CPROC
 00791    C
 00792 791      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         790 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         790 TARGET STATEMENTS
 00000    C   14/01/82 201151105  MEMBER NAME  FTRKEL   (PATRECSR)    SHELTRAN
 00100    C   18/01/80 201131458  MEMBER NAME  ORFTRKEL (JADESR)      SHELTRAN
 00200    C   18/01/80 001181139  MEMBER NAME  ORFTRKEL (JADESR)      SHELTRAN
 00300   2      SUBROUTINE FTRKEL
 00400    C
 00500    C        FIND TRACK ELEMENTS FROM LINE ELEMENTS: P.STEFFEN(79/02/06)
 00600    C                   MIN. DRIFTSPACE REQUIRED
 00700    C                   NO STOP AT POINT OF DIVERGENCE
 00800    C
 00900   3      IMPLICIT INTEGER*2 (H)
 01000    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         4      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
               ,               NWR2(200),DS2(200),SL2(200),
               ,               LBL(200),NTREL(200),ICRO(200),
               ,               NTR,HNREL(100),HISTR(9,100),HRES(168),
               ,               NTRLM,RLMTR(3,5),
               ,               WRK(7000)
         5      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
         6      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
         7      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
         8      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
         9      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        10      EQUIVALENCE (IDWRK(1),ADWRK(1),HDWRK(1))
          C---------- END OF MACRO CWORKPR --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  11      EQUIVALENCE
 00410    C                POINTERS FOR FXYZ HIT ARRAY .. PRIMARY L/R SOLUTION
 00500         #          (HPHT0,HPWRK( 1)),(HPHT9,HPWRK( 2)),(HLDHT,HPWRK( 3))
 00510    C                POINTERS FOR CWORK SINGLE TRACK PATR BANK
 00600         #         ,(HPTR0,HPWRK( 4)),(HPTR9,HPWRK( 5)),(HLDTR,HPWRK( 6))
 00610    C                POINTERS FOR TRACK ELEMENT HIT LABEL ARRAY
 00700         #         ,(HPHL0,HPWRK( 7)),(HPHL9,HPWRK( 8)),(HLDHL,HPWRK( 9))
 00710    C                POINTERS FOR FXYZ HIT ARRAY .. OPPOSITE L/R SOLUTION
 00800         #         ,(HPHT0A,HPWRK(10)),(HPHT9A,HPWRK(11)),(HLDHTA,HPWRK(12))
 00810    C               POINTER LIMIT ON FXYZ HIT ARRAY
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 01300    C
 01400  12      EQUIVALENCE
 01500         ,           (ICELL ,IDWRK(1)),(MHIT  ,IDWRK(2)),(IRING ,IDWRK(3))
 01600         ,         , (IERRCD,IDWRK(4)),(NTRKEL,IDWRK(5))
 01700    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        13      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        14      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        15      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        16      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        17      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
               *YBKK(1))   ,(FLINLM(1),LMFLIN(1)),(TRELLM(1),LMTREL(1))
               *           ,(ZFITLM(1),LMZFIT(1)),(BKK(1),IBKK(1))
               *           ,(XYF(1),IXYF(1)),(GFP(1),IGFP(1)),(IADMIN(1),IMCERT)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
               *           ,(IYBKK(20),IPPASS),(IADMIN(2),IPFAST)
          C----------- END OF MACRO CPATLM --------------
 01900    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  18      COMMON / CJDRCH / RDEC(4),PSIIN(3),RINCR(3),FIRSTW(3),FSENSW(3),
 00500         +                  RDEPTH,SWDEPL,YSUSPN,TIMDEL(2,3),ZMAX,ZOFFS,
 00510         +                  ZRESOL,ZNORM,ZAL,ZSCAL,DRIDEV,DRICOS,DRISIN,
 00600         +                  PEDES,TZERO(3),DRIROT(96,2),SINDRI(96,2),
 00701         +                  COSDRI(96,2),DRIVEL(96,2),T0FIX(3),
 00800         +                  ABERR(8), DUMJDC(20)
 00900    C
 01100    C      BLOCK DATA SET TO MC VALUES, KALIBR WILL SET REAL DATA VALUES
 01210    C--->  A CHANGE OF THIS COMMON MUST BE DONE SIMULTANEOUSLY WITH  <----
 01220    C--->  A CHANGE OF THE BLOCK DATA                                <----
 01230    C
 01300    C--------------------------- END OF MACRO CJDRCH -----------------------
 01400    C
          C----------------------------------------------------------------------
          C           MACRO CDSMAX .... PATTERN RECOGNITION CONSTANTS.
          C----------------------------------------------------------------------
        19      COMMON/CDSMAX/DSMAX(16,3,2),DIRWR1(24,2),DIRWR3(48,2)
               *             ,DHALF(16,3,2),DTWICE(16,3,2),HMCH(16,3,2)
               *             ,IBCK(9),DBCK(30),TRMATS(96,2),TRMATC(96,2)
          C------------------------ END OF MACRO CDSMAX -------------------------
 02200    C
 02300  20      DIMENSION HPBAK(16),HLYAR(16),HLBAR(16),DSPAR(16),RESAR(16)
 02400    C
 02600  21      DATA MKGDLN / Z107/                                                MASK FOR GOOD LINEL
 02800  22      DATA MKDIVL / Z100/                                                MASK FOR DIVERGING LINEL
 02900    C
 03100  23      DATA LBNOCN / Z1/                                                  LABEL FOR NO CONTINUATION OF TREL
 03300  24      DATA LBKINK / Z2/                                                  LABEL FOR KINK AT END POINT OF TREL
 03500  25      DATA LBWALL / Z4/                                                  LABEL FOR WALL AT END POINT OF TREL
 03700  26      DATA LBWIRE / Z8/                                                  LABEL FOR WIRE PLANE AT END POINT OF TREL
 03900  27      DATA LBTREL /Z1000/                                                LABEL FOR GOOD TREL
 04100  28      INTEGER LBLFRT(3) /Z10000,Z30000,Z20000/                           LEFT/RIGHT LABEL OF TREL
 04200    C
 04400  29      FPAR0(X) = (PAR10*X + PAR20)*X + PAR30                             FUNCTIONS
 04500  30      FPAR (X) = (PAR1 *X + PAR2 )*X + PAR3
 04600    C
 04700    C     PRINT 2900, IERRCD, ICELL, NTRCNT
 04800    C     IF(ICELL.GT. 0) PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
 04900    C2001 FORMAT(1H0,9I6)
 05000    C2002 FORMAT(1X,3I6,10F8.2)
 05100    C2004 FORMAT('0********** UNDETERMINED L/R AMB. *********',I6,3F8.2)
 05200    C2005 FORMAT(' 0-TREL-CAND.:',I6,10F8.2)
 05300    C2006 FORMAT(1X,I6,F6.0,3F8.2,F12.1,5F8.2)
 05400    C2007 FORMAT(' TRELAN:',3I6,10F10.4)
 05500    C2008 FORMAT(' CUT   :',15I6)
 05600    C2009 FORMAT(1X,I6,F6.0,9F8.2)
 05700    C2010 FORMAT(' NEWCUT:',I6,F8.2,I6,F8.2)
 05800    C2011 FORMAT(1X,3I6,F8.2)
 05900    C2012 FORMAT(1X,I6,10F8.2)
 06000    C2900 FORMAT(1H0,'ERROR CODE:',I4, ', ICELL:',I3,', TRACKS:',I4)
 06100    C2901 FORMAT(1X,/,(1X,2I6,2F6.2,2X,Z4,6I6,F6.2))
 06200    C2902 FORMAT(/,(1X,3I6,4F8.5,I3,2F6.2,I3,2F6.2,2X,Z4,2X,Z4,2X,Z5,F6.2))
 06300    C
 06500  31      MTRK = 0                                                           PRESET COUNTER OF TRKELS
 06600                                                                             PRESET COUNTER OF ZERO APPROACH. LINELS
 06800  32      HPTR0= HPFREE                                                      POINTER TO START OF TRELS + LENGTH OF TREL
 06900  33      HLDTR= 17
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 07100  34      IPTR = HPTR0                                                       POINTER TO CURRENT TRKEL
 07200    C
 07400  35      IP=HPHT0                                                           LOOP OVER ALL LINE ELEMENTS
 07500  36      REPEAT
 07600  37         LB = LAND(IWRK(IP+4),MKGDLN)
 07700  38         IFREEU = IWRK(IP+5)
 07800  39         IF(IFREEU.GT.0) IFREEU = IWRK(IFREEU+9)
 07900  41         IFREED = IWRK(IP+7)
 08000  42         IF(IFREED.GT.0) IFREED = IWRK(IFREED+9)
 08100  44         IF IWRK(IP+8).EQ.0 .AND. LB.EQ.7
 08200         .      .AND. ABS(WRK(IP+11)).GT..1
 08300         .      .AND. IFREEU.EQ.0 .AND. IFREED.EQ.0
 08500  45         THEN                                                            ONLY GOOD + UNUSED LINEL WITH L/R DIFF.
 08600  48            DS0 = WRK(IP+2)
 08700  49            SL0 = WRK(IP+3)
 08900  50            NLINEL = 1                                                   COUNTER FOR LINELS
 09100  51            DDSOFF = SIGN(TRELLM(1),WRK(IP+11))                          OFFSET FOR STAGGERING
 09200  52            IF(LAND(IWRK(IP),1).NE.0) DDSOFF =-DDSOFF
 09400  54            INEXT = 5                                                    SEARCH FOR END OF TRKEL IN LOWER LAYERS
 09500  55            PERFORM SREND
 09600  58            LBSTRT = LBEND
 09700  59            IPL = IWRK(IPH+5)
 09800  60            IWRK(IPH+8) = 1
 09900    C
 10100  61            INEXT = 7                                                    SEARCH FOR END OF TRKEL IN HIGHER LAYERS
 10200  62            PERFORM SREND
 10300  65            IPH = IWRK(IPH+7)
 10400    C     PRINT 2001, IP,IPL,IPH,NLINEL
 10500    C
 10700  66            IF NLINEL+2.GE.LMTREL(13)                                    CHECK IF TRKEL. (>3 HITS)
 10900  67            THEN                                                         *****  THIS MIGHT BE A TRACK ELEMENT  *****
 11000    C
 11100                                                                             CHECK FOR KINKS,
 11200                                                                             CALCULATE TRACK PARAMETERS,
 11400  70               PERFORM TRCHCK                                            STORE RESULTS IN TRKEL BANK
 11500    C     PRINT 2001, IP,IPL,IPH,NLINEL
 11600  73            CIF
 11700  74         CIF
 11800  75         IP = IP + HLDHT
 11900  76      UNTIL IP.GT.HPHT9
 12000    C
 12200  77      HPFREE= IPTR                                                       SET POINTER TO END OF TRACK ARRAY
 12300  81      HPTR9 = IPTR - 1
 12400    C
 12600  82      NTRKEL = MTRK                                                      SET NUMBER OF TRKELS
 12700    C
 12800    C     IF(ICELL.GT. 0) PRINT 2900, IERRCD, ICELL, NTRCNT
 12900    C     IF(ICELL.GT. 36) PRINT 2901, (WRK(I1),I1=HPHT0,HPHT9)
 13000    C     IF(ICELL.GT. 36) PRINT 2902, (WRK(I1),I1=HPTR0,HPTR9)
 13100  83      RETURN
 13200                                                                             *************************
 13300                                                                             *      S R E N D        *
 13400                                                                             *************************
 13600  84      PROC SREND                                                         SEARCH FOR END OF TRKEL
 13700    C
 13900  85         IPH   = IP                                                      POINTER TO LAST LINEL
 14100  86         IPA   = IWRK(IP+INEXT)                                          POINTER
 14300  87         LBEND = 0                                                       PRESET END LABEL
 14400  88         WHILE IPA.GT.0
 14500  90            IPNXT = IWRK(IPA+INEXT)
 14600    C
 14800  94            IF IPNXT.LE.0                                                CHECK IF COMPLETE LINEL
 14900  95            THEN
 15000  98               LBEND = LBNOCN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 15100  99               XWHILE
 15200 100            CIF
 15300    C
 15500 101            IF IWRK(IPNXT+8).NE.0 .OR. LAND(IWRK(IPA+4),MKDIVL).NE.0     CHECK IF 'POINT OF DIVERGENCE'
 15600 102            THEN
 15700 105               LBEND = LBKINK
 15800 106               XWHILE
 15900 107            CIF
 16000    C
 16100 108            NLINEL = NLINEL + 1
 16200 109            IPH    = IPA
 16400 110            IPA    = IPNXT                                               GET POINTER TO NEXT LINEL.
 16500 111         CWHILE
 16600 113      CPROC
 16700    C
 16800                                                                             *************************
 16900                                                                             *      T R C H C K      *
 17000                                                                             *************************
 17200 115      PROC TRCHCK                                                        CHECK TREL FOR KINKS + CALC. PARAMETERS
 17300    C
 17500 116         IHIT = 0                                                        SET UP ARRAYS: HPBACK,HLYAR,HLBAR,DSPAR
 17600 117         IPA = IPL
 17700 118         REPEAT
 17900 119            IWRK(IPA+8) = 1                                              LABEL USED HITS
 18000 120            IHIT = IHIT + 1
 18100 121            HPBAK(IHIT  ) = IPA
 18200 122            HLYAR(IHIT  ) = IWRK(IPA  )
 18300 123            DSPAR(IHIT) =  WRK(IPA+2)
 18400    C     PRINT 2011, IPA,IHIT ,HLYAR(IHIT ),DSPAR(IHIT )
 18500 124            IPA = IWRK(IPA+ 7)
 18600 125         UNTIL IPA.GE.IPH
 18800 126         IWRK(IPA+8) = 1                                                 LAST POINT IN ARRAYS
 18900 130         HPBAK(IHIT+1) = IPA
 19000 131         HLYAR(IHIT+1) = IWRK(IPA  )
 19100 132         DSPAR(IHIT+1) =  WRK(IPA+2)
 19300 133         JHIT0 = 1                                                       POINTER TO 1. + LAST HIT
 19400 134         JHIT9 = IHIT + 1
 19500 135         IHIT9 = JHIT9
 19600 136         IHIT0 = 1
 19700 137         MHIT = IHIT9 - IHIT0 + 1
 19800    C     PRINT 2011, IPA,IHIT9,HLYAR(IHIT9),DSPAR(IHIT9)
 20000 138         MKCUT = 0                                                       MARKER FOR CUT OF TREL-CAND
 20100    C
 20200 139         WHILE MHIT.GE.LMTREL(13)
 20300    C
 20500 141            DSTAG0 = 0.                                                  TREL ANALYSIS WITH PARABOLA FIT
 20600 145            NITER = LMTREL(6)
 20700 146            PERFORM TRELAN
 20800    C
 20900 149            IF STAGSG.LE.SIGLM .AND. YPMIN.GE.TRELLM(10)
 21000 150            THEN
 21100    C
 21300 153               DSIGLR = ABS(SIGL-SIGR)                                   DET L/R
 21400 154               IF DSIGLR.GT.TRELLM(19) .AND.
 21500         ?            (MHIT.GT.6 .OR. STAGSG.LE.TRELLM(14)**2)
 21600 155               THEN
 21700 158                  LBLR =-1
 21800 159                  IF(SIGR.LT.SIGL) LBLR = 1
 21900 161               ELSE
 22000 163                  LBLR = 0
 22100 164               CIF
 22300 165               PERFORM TRKPAR                                            STORE TRACK PARAMETERS
 22400 168               MHIT = 0
 22500    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 22700 169            ELSE                                                         BAD FIT: CUT + CONT. WITH 1. BRANCH
 22800 171               PERFORM CUTREL
 22900 174               MHIT = IHIT9 - IHIT0 + 1
 23000 175            CIF
 23100    C
 23300 176            IF MKCUT.NE.0 .AND. MHIT.LT.LMTREL(13)                       FETCH LEFT OVER BRANCH IF NOT ENOUGH HITS LEFT
 23400 177            THEN
 23500 180               IHIT0 = JHIT0
 23600 181               IHIT9 = JHIT9
 23700 182               MKCUT = 0
 23800 183               MHIT = IHIT9 - IHIT0 + 1
 23900 184            CIF
 24000 185         CWHILE
 24100 187      CPROC
 24200    C
 24300                                                                             *************************
 24400                                                                             *      C U T R E L      *
 24500                                                                             *************************
 24700 189      PROC CUTREL                                                        CUT TREL
 24800    C
 24900 190         IHITM1 = IHITM0
 25000 191         IHITM2 = IHITM0
 25100 192         MHIT = IHIT9 - IHIT0 + 1
 25200    C
 25400 193         REPEAT                                                          SELECT DIFFERENT CUT PROCEDURES
 25500    C
 25700 194            IF YPMIN.LT.TRELLM(10) .AND. STAGSG.LE.SIGLM                 0-XING AT SMALL ANGLE
 25900 195            THEN                                                         CUT 0-XING TRACK AT MIN(PARABOLA)
 26100 198               HLYMIN = XPMIN                                            FIND HIT CLOSE TO MIN(PARABOLA)
 26200 199               FOR IHIT=IHIT0,IHIT9
 26300 200                  IF(HLYAR(IHIT).LE.HLYMIN) IHITM1 = IHIT
 26400 202               CFOR
 26500 204               IHITM2 = IHITM1 + 1
 26600    C     PRINT 2003, IHITM1,IHITM2,XPMIN,YPMIN
 26700    C2003 FORMAT(' CUTMIN:',2I6,2F10.1)
 26800 205               XREPEAT
 26900 206            CIF
 27000    C
 27200 207            IF YPMIN.LT.10. .AND. MHIT.GE.5                              0-XING AT BIG ANGLE
 27300 208            THEN
 27500 211               IHMIN  = IHIT0                                            CUT 0-XING TRACK AT MIN(DRIFTSP.)
 27600 212               DSMIN  = 100000.
 27800 213               FOR IHIT=IHIT0,IHIT9                                      FIND HIT CLOSE TO MIN(PARABOLA)
 27900 214                  IF DSPAR(IHIT).LT.DSMIN
 28000 215                  THEN
 28100 218                     DSMIN = DSPAR(IHIT)
 28200 219                     IHMIN = IHIT
 28300 220                  CIF
 28400 221               CFOR
 28600 223               IHMINS = IHMIN                                            SAVE FOUND MIN.
 28700    C
 28800                                                                             0-XING: HIT BELOW MIN.
 29000 224               DDSP   = 1000.                                            INITIALIZE D(DRIFTSP.) OF ADJACENT HITS
 29100 225               IF IHMIN.EQ.IHIT9
 29200 226               THEN
 29400 229                  IHMIN = IHMIN - 1                                      MIN AT LAST HIT
 29500 230               ELSE
 29600 232                  IF IHMIN.GT.IHIT0
 29700 233                  THEN
 29800 236                     DDSP = DSPAR(IHMIN+1) - DSPAR(IHMIN-1)
 29900 237                     IF(DDSP.GT.0) IHMIN = IHMIN - 1
 30000 239                  CIF
 30100 240               CIF
 30300 241               LBCUT = 0                                                 CHECK SLOPE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 30400 242               IF IHMIN-2.LT.IHIT0
 30500 243               THEN
 30600 246                  IF(DSPAR(IHMIN+3)-DSPAR(IHMIN+1).GT.2.0) LBCUT = 1
 30700 248               ELSE
 30800 250                  IF IHMIN+3.GT.IHIT9
 30900 251                  THEN
 31000 254                     IF(DSPAR(IHMIN-2)-DSPAR(IHMIN  ).GT.2.0) LBCUT = 1
 31100 256                  ELSE
 31200 258                     ZSL1 = DSPAR(IHMIN-2) - DSPAR(IHMIN  )
 31300 259                     ZSL2 = DSPAR(IHMIN+3) - DSPAR(IHMIN+1)
 31400 260                     IF(ZSL1.GT.2.0 .OR. ZSL2.GT.2.0) LBCUT = 1
 31500 262                  CIF
 31600 263               CIF
 31700 264               IF LBCUT.NE.0
 31800 265               THEN
 32000 268                  IF ABS(DDSP).GT..6 .AND. DSMIN.GT..6                   CHECK IF CLEAR MIN.
 32100 269                  THEN
 32200 272                     IHITM1 = IHMIN
 32300 273                     IHITM2 = IHMIN + 1
 32400 274                  ELSE
 32500 276                     IHITM1 = IHMINS - 1
 32600 277                     IHITM2 = IHMINS + 1
 32700 278                  CIF
 32800 279                  XREPEAT
 32900 280               CIF
 33000 281            CIF
 33100    C
 33300 282            IF MHIT.GE.6                                                 KINK OR DISCONTINUITY
 33400 283            THEN
 33500 286               DRES1 = 0.
 33600 287               DRES2 = 0.
 33700 288               IHMX1 =-1
 33800 289               IHMX2 =-1
 33900 290               DSL0  = PAR10*8.
 34100 291               IHIT4 = IHIT0+4                                           LOOP OVER ALL HITS
 34200 292               FOR IHIT = IHIT0,IHIT9
 34300 293                  X = HLYAR(IHIT)
 34400 294                  Y = DSPAR(IHIT)
 34500 295                  F = FPAR0(X)
 34600 296                  DCHI = F - Y
 34700 297                  RESAR(IHIT) = DCHI
 34800    C
 35000 298                  IF IHIT.GT.IHIT0                                       FIND MAX.GAP + MAX.KINK
 35100 299                  THEN
 35200    C
 35400 302                     DDRES1 = ABS(DCHI-DCHI1)                            GAP:
 35500 303                     IF DDRES1.GT.DRES1
 35600 304                     THEN
 35700 307                        DRES1 = DDRES1
 35800 308                        IHMX1 = IHIT
 35900 309                     CIF
 36000    C
 36100 310                     IF IHIT.GE.IHIT4
 36200 311                     THEN
 36400    C                 DDRES2 = ABS(2.*RESAR(IHIT-2) - RESAR(IHIT-4) - DCHI)  KINK:
 36500 314                        DDRES2 = ABS(2.*DSPAR(IHIT-2)-DSPAR(IHIT-4)-Y + DSL0)
 36600 315                        IF DDRES2.GT.DRES2
 36700 316                        THEN
 36800 319                           DRES2 = DDRES2
 36900 320                           IHMX2 = IHIT-2
 37000 321                        CIF
 37100 322                     CIF
 37200 323                  CIF
 37300    C     IF(ICELL.GT. 36)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 37400    C    ,PRINT 2009, IHIT,X,Y,F,DCHI,DRES1,DRES2,DDRES1,DDRES2
 37500    C
 37600 324                  DCHI1 = DCHI
 37700 325               CFOR
 37900 327               DRES1 = DRES1 * 1.5                                       SCALE UP DDRES1 (COMPARABLE TO DDRES2)
 38000    C
 38100    C     IF(ICELL.GT. 36) PRINT 2010, IHMX1,DRES1,IHMX2,DRES2
 38200    C
 38400 328               DRES0 = TRELLM(16)*2.5                                    CHECK IF REAL CUT FOUND
 38500 329               IF DRES0.LT.DRES2 .OR. DRES0.LT.DRES1
 38600 330               THEN
 38700    C
 38900 333                  IF DRES1-DRES2 .LT. TRELLM(14)*1.4                     SELECT GAP OR KINK CUT
 39100 334                  THEN                                                   KINK CUT SELECTED
 39200    C
 39400 337                     IF DSPAR(IHMX2).LT.TRELLM(10)                       CHECK IF 0-XING
 39500 338                     THEN
 39700 341                        IF DSPAR(IHMX2-1).LT.DSPAR(IHMX2+1)              0-XING: SELECT CUT
 39800 342                        THEN
 39900 345                           IHITM2 = IHMX2
 40000 346                           IHITM1 = IHMX2 - 1
 40100 347                        ELSE
 40200 349                           IHITM1 = IHMX2
 40300 350                           IHITM2 = IHMX2 + 1
 40400 351                        CIF
 40500 352                     ELSE
 40700 354                        IF DRES2.GT.TRELLM(14)*5.                        NOT 0-XING: SELECT CUT
 40800 355                        THEN
 40900 358                           IHITM1 = IHMX2
 41000 359                           IHITM2 = IHMX2
 41100 360                        ELSE
 41200 362                           IHITM1 = IHMX2 - 1
 41300 363                           IHITM2 = IHMX2 + 1
 41400 364                        CIF
 41500 365                     CIF
 41600    C
 41800 366                  ELSE                                                   GAP CUT SELECTED
 41900 368                     IHITM1 = IHMX1 - 1
 42000 369                     IHITM2 = IHMX1
 42100 370                  CIF
 42200 371               CIF
 42300 372            CIF
 42400 373         UNTIL .TRUE.
 42500    C
 42700    C     IF(ICELL.GT. 36)                                                   SELECT 1. BRANCH FOR CONT.
 42800    C    ,PRINT 2008, IHIT0,IHIT9,MKCUT,JHIT0,JHIT9,IHITM1,IHITM2
 42900 374         IF MKCUT.EQ.2  .OR.
 43000         ?      ((IHITM1-IHIT0).GE.(IHIT9-IHITM2) .AND. MKCUT.EQ.0)
 43100 378         THEN
 43300 381            IF IHITM1.GT.IHIT0                                           SELECT 1. BRANCH
 43400 382            THEN
 43500 385               IF(IHITM1.EQ.IHIT9) IHITM1 = IHITM1 - 1
 43600 387               IHIT9 = IHITM1
 43700 388               IF(MKCUT.NE.1) JHIT0 = MIN0(IHITM2,JHIT9)
 43800 390               MKCUT = 2
 43900 391            ELSE
 44000 393               IHIT9 = JHIT9
 44100 394               IHIT0 = IHIT0+1
 44200 395               JHIT0 = IHIT0
 44300 396               MKCUT = 0
 44400 397            CIF
 44500 398         ELSE
 44700 400            IF IHITM2.LT.IHIT9                                           SELECT 2. BRANCH
 44800 401            THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 44900 404               IF(IHITM2.EQ.IHIT0) IHITM2 = IHITM2 + 1
 45000 406               IHIT0 = IHITM2
 45100 407               IF(MKCUT.NE.2) JHIT9 = MAX0(IHITM1,JHIT0)
 45200 409               MKCUT = 1
 45300 410            ELSE
 45400 412               IHIT0 = JHIT0
 45500 413               IHIT9 = IHIT9-1
 45600 414               JHIT9 = IHIT9
 45700 415               MKCUT = 0
 45800 416            CIF
 45900 417         CIF
 46000 418      CPROC
 46100    C
 46200                                                                             *************************
 46300                                                                             *      T R K P A R      *
 46400                                                                             *************************
 46600 420      PROC TRKPAR                                                        GET TREL PARAMETERS
 46700    C
 46900 421         DSTAG0 = SWDEPL*LBLR                                            FINAL FIT WITH STAGGERING CORRECTION
 47000 422         NITER = 0
 47100 423         PERFORM TRELAN
 47200    C
 47400 426         IF MHIT.GE.LMTREL(13)                                           CHECK # OF HITS
 47500 427         THEN
 47600    C
 47800 430            FOR IHIT = IHIT0,IHIT9                                       LABEL HITS OF TREL / FIND POINTER TO 1. + LAST HIT
 47900 431               IF HLBAR(IHIT).EQ.0
 48000 432               THEN
 48100 435                  IPA = HPBAK(IHIT)
 48200 436                  IWRK(IPA+10) = IWRK(IPA+9)
 48300 437                  IWRK(IPA+ 9) = IPTR
 48400 438               CIF
 48500 439            CFOR
 48600    C
 48700    C
 48900 441            LRIND = SHFTR(LBLR+3,1)                                      SET LABELS FOR START + END POINT
 49000 442            IF(DSMAX(ILAY0+1,IRING,LRIND)-5. .LT. DS0)
 49100         ?      LBSTRT = LOR(LBSTRT,LBWALL)
 49200 444            IF(DS0.LT.1.5) LBSTRT = LOR(LBSTRT,LBWIRE)
 49300 446            IF(DSMAX(ILAY9+1,IRING,LRIND)-5. .LT. DS9)
 49400         ?      LBEND  = LOR(LBEND ,LBWALL)
 49500 448            IF(DS9.LT.1.5) LBEND  = LOR(LBEND ,LBWIRE)
 49600    C
 49800 450            LBTR = LOR(SHFTL(LBEND,4),LBSTRT)                            SET TRACK LABEL
 49900 451            LBTR = LOR(LBTR,LBTREL)
 50100 452            LBTR = LOR(LBTR,LBLFRT(LBLR+2))                              SET L/R BIT
 50200    C
 50400 453            IWRK(IPTR   ) = IPHIT0                                       SET BANK OF TREL
 50500 454            IWRK(IPTR+ 1) = IPHIT9
 50600 455            IWRK(IPTR+ 2) = MHIT
 50700 456            WRK (IPTR+ 3) = PAR1
 50800 457            WRK (IPTR+ 4) = PAR2
 50900 458            WRK (IPTR+ 5) = PAR3
 51000 459            WRK (IPTR+ 6) = SQRT(SIG)
 51100 460            IWRK(IPTR+ 7) = ILAY0
 51200 461            WRK (IPTR+ 8) = DS0
 51300 462            WRK (IPTR+ 9) = SLOP0
 51400 463            IWRK(IPTR+10) = ILAY9
 51500 464            WRK (IPTR+11) = DS9
 51600 465            WRK (IPTR+12) = SLOP9
 51700 466            IWRK(IPTR+13) = LBSTRT
 51800 467            IWRK(IPTR+14) = LBEND
 51900 468            IWRK(IPTR+15) = LBTR
 52000 469            I9 = IPTR + HLDTR - 1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 52100 470            MTRK = MTRK + 1
 52200 471            IPTR = IPTR + HLDTR
 52300 472         CIF
 52400 473      CPROC
 52500    C
 52600                                                                             *************************
 52700                                                                             *      T R E L A N      *
 52900    C                                                                        *************************
 53000    C
 53200 475      PROC TRELAN                                                        TREL ANALYSIS WITH PARABOLA FIT
 53300    C
 53500 476         ITER = 0                                                        ITERATE UNTIL GOOD PARABOLA FIT
 53600    C
 53700                                                                             IF 1. HIT CLOSE TO ZERO +  2. HIT NOT:
 53800                                                                             IGNORE 1. HIT
 53900 477         IF(DSPAR(IHIT0).LT.1.5 .AND. DSPAR(IHIT0+1).GT.5.) IHIT0 = IHIT0+1
 54000 479         IF(DSPAR(IHIT9).LT.1.5 .AND. DSPAR(IHIT9-1).GT.5.) IHIT9 = IHIT9-1
 54200 481         IF NITER.GT.0                                                   INITIALIZE LABEL OF BAD HITS
 54300 482         THEN
 54400 485            FOR IHIT=IHIT0,IHIT9
 54500 486               HLBAR(IHIT) = 0
 54600 487            CFOR
 54700 489         CIF
 54800    C
 54900 490         REPEAT
 55000    C
 55200 491            PERFORM FPARAB                                               FIT PARABOLA
 55300    C
 55500 494            IF MHIT.LT.LMTREL(13)                                        CHECK IF ENOUGH HITS
 55600 495            THEN
 55700 498               STAGSG = 10000000.
 55800 499               IHITM0 = IHIT0 + 1
 55900 500               XREPEAT
 56000 501            CIF
 56100    C
 56300 502            CHISQ = 0.                                                   CALC. CHISQ + SOLVE L/R AMBIGUITY
 56400 503            STAGS1 = 0.
 56500 504            STGSL1 = 0.
 56600 505            STGSL2 = 0.
 56700 506            STGSR1 = 0.
 56800 507            STGSR2 = 0.
 56900 508            DCHIM1 = 0.
 57000 509            IHITM1 = 0
 57100 510            FOR IHIT = IHIT0,IHIT9
 57300 511               IF HLBAR(IHIT).EQ.0                                       CHECK IF NOT REJECTED HIT
 57400 512               THEN
 57500 515                  X = HLYAR(IHIT)
 57600 516                  DSTAG = DSTAG0
 57700 517                  IF(LAND(HLYAR(IHIT),1).NE.0) DSTAG =-DSTAG0
 57800 519                  Y = DSPAR(IHIT) + DSTAG
 57900 520                  F = FPAR(X)
 58000 521                  DCHI = Y - F
 58100 522                  RESAR(IHIT) = DCHI
 58300 523                  CHISQ = CHISQ + DCHI**2                                SUM FOR RMS
 58500 524                  IF ABS(DCHI).GE.DCHIM1                                 KEEP BIGGEST RMS
 58600 525                  THEN
 58700 528                     DCHIM1 = ABS(DCHI)
 58800 529                     IHITM1 = IHIT
 58900 530                  CIF
 59100 531                  IF LAND(HLYAR(IHIT),1).NE.0                            SUM FOR RMS WITH CORRECTION OF STAGG.
 59200 532                  THEN
 59300 535                     STAGS1 = STAGS1 + DCHI
 59400 536                     DCHIL = DCHI + SWDEPL
 59500 537                     DCHIR = DCHI - SWDEPL
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 59600 538                  ELSE
 59700 540                     STAGS1 = STAGS1 - DCHI
 59800 541                     DCHIL = DCHI - SWDEPL
 59900 542                     DCHIR = DCHI + SWDEPL
 60000 543                  CIF
 60100 544                  STGSL1 = STGSL1 + DCHIL
 60200 545                  STGSL2 = STGSL2 + DCHIL**2
 60300 546                  STGSR1 = STGSR1 + DCHIR
 60400 547                  STGSR2 = STGSR2 + DCHIR**2
 60500    C     IF(ICELL.GT. 36)
 60600    C    ,PRINT 2006, IHIT,X,Y,F,DCHI,CHISQ,STAGS1,DCHIL,DCHIR,DSTAG0,SWDEPL
 60700 548               CIF
 60800 549            CFOR
 60900 551            SIG    =      CHISQ  / DEG
 61000 552            SIGL   = STGSL2 / DEG
 61100 553            SIGR   = STGSR2 / DEG
 61200 554            STAGSG = AMIN1(SIGL,SIGR)
 61300 555            STAGAV = STAGS1 / S0
 61400    C
 61600 556            IF ITER.EQ.0                                                 SAVE PAR. OF 0-TH ITER.
 61700 557            THEN
 61800 560               PAR10 = PAR1
 61900 561               PAR20 = PAR2
 62000 562               PAR30 = PAR3
 62100 563               IHITM0 = IHITM1
 62200 564            CIF
 62300    C
 62500 565            YPMIN = 1000.                                                CALC. MIN(PARABOLA)
 62600 566            XPMIN = 1000.
 62700 567            IF(PAR1.NE.0.) XPMIN = -.5 * PAR2 / PAR1
 62800 569            IF(XPMIN.GT.HLYAR(IHIT0) .AND. XPMIN.LT.HLYAR(IHIT9))
 62900         ?      YPMIN = FPAR(XPMIN)
 63000    C     IF(ICELL.GT. 36)
 63100    C    ,PRINT 2007, MHIT,IHIT0,IHIT9,PAR1,PAR2,PAR3,SIGLM,SIG,SIGL,SIGR
 63200    C    ,          ,XPMIN,YPMIN
 63300    C
 63500 571            IF(STAGSG.LE.SIGLM .OR. MHIT.LE.LMTREL(13)) XREPEAT          GOOD FIT .OR. TOO SMALL # OF HITS: STOP
 63700 573            IF(MHIT.LE.6 .AND. ABS(PAR1).GT.TRELLM(9)) XREPEAT           BAD FIT, <7 HITS, HIGH CURV: STOP
 63900 575            IF(YPMIN.LT.      100.) XREPEAT                              MIN(PARABOLA) CLOSE TO ZERO: STOP
 64000    C
 64100                                                                             INCREASE LIMIT FOR STRAIGHT DISTORTED TRACKS
 64200 577            IF MHIT.GE.6.AND.ABS(PAR1).LT..010.AND.STAGSG.LT.TRELLM(14)*1.5
 64300 578            THEN
 64400 581               DCHI = RESAR(IHITM1)
 64600 582               IF LAND(HLYAR(IHITM1),1).NE.0                             CORRECTION OF STAGG.
 64700 583               THEN
 64800 586                  DCHIL = DCHI + SWDEPL
 64900 587                  DCHIR = DCHI - SWDEPL
 65000 588               ELSE
 65100 590                  DCHIL = DCHI - SWDEPL
 65200 591                  DCHIR = DCHI + SWDEPL
 65300 592               CIF
 65400 593               DCHI = DCHIL
 65500 594               IF(SIGR.GT.SIGL) DCHI = DCHIR
 65600 596               IF DCHI**2*.33 .LT. STAGSG
 65700 597               THEN
 65800 600                  SIGLM = AMAX1(STAGSG*1.01,SIGLM)
 65900 601                  XREPEAT
 66000 602               CIF
 66100 603            CIF
 66200    C
 66400 604            IDHITM = IABS(IHITM1-IHITM0)                                 CHECK WORST POINT
 66500 605            DDCHIM = DCHIM1
 66600 606            IF(IHITM1.NE.IHIT0 .AND. IHITM1.NE.IHIT9)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 66700         ?      DDCHIM = ABS(RESAR(IHITM1)-(RESAR(IHITM1-1)+RESAR(IHITM1+1))*.5)
 66800 608            IF(IDHITM.EQ.1) XREPEAT
 66900 610            IF(DDCHIM**2.LT.SIGLM*4.0) XREPEAT
 67000    C
 67200 612            IF IHITM1-IHIT0 .EQ. 1                                       LABEL WORST POINT + TRY AGAIN
 67300 613            THEN
 67500 616               SL0   = HLYAR(IHITM1)*PAR1*2. + PAR2                      2. HIT BAD: CHECK IF NOT 1. HIT
 67600 617               DDSP1 = ABS(DSPAR(IHIT0+1)+SL0    - DSPAR(IHIT0+2))
 67700 618               DDSP2 = ABS(DSPAR(IHIT0  )+SL0*2. - DSPAR(IHIT0+2))
 67800 619               IF(DDSP1 .LT. DDSP2) IHITM1 = IHIT0
 67900    C     PRINT 2012,IHITM1,SL0,DSP0,DDSP1,DDSP2,RESAR(IHIT0),RESAR(IHIT0+1)
 68000 621            ELSE
 68100 623               IF IHIT9-IHITM1 .EQ. 1
 68200 624               THEN
 68400 627                  SL0   = HLYAR(IHITM1)*PAR1*2. + PAR2                   LAST BUT ONE HIT BAD: CHECK IF NOT LAST HIT
 68500 628                  DDSP1 = ABS(DSPAR(IHIT9-1)-SL0    - DSPAR(IHIT9-2))
 68600 629                  DDSP2 = ABS(DSPAR(IHIT9  )-SL0*2. - DSPAR(IHIT9-2))
 68700 630                  IF(DDSP1 .LT. DDSP2) IHITM1 = IHIT9
 68800    C     PRINT 2012,IHITM1,SL0,DSP0,DDSP1,DDSP2,RESAR(IHIT9),RESAR(IHIT9-1)
 68900 632               CIF
 69000 633            CIF
 69100 634            IF(ITER.NE.NITER) HLBAR(IHITM1) = 1
 69200 636            ITER = ITER + 1
 69300 637         UNTIL ITER.GT.NITER
 69400    C
 69600 638         IF ITER.GT.0 .AND. STAGSG.LE.SIGLM                              RESET LABEL OF BAD HITS
 69700 642         THEN
 69900 645            IF(HLBAR(IHIT0).NE.0) IHIT0 = IHIT0 + 1                      REDUCE RANGE IF WORST POINTS AT END
 70000 647            IF(HLBAR(IHIT0).NE.0) IHIT0 = IHIT0 + 1
 70100 649            IF(HLBAR(IHIT9).NE.0) IHIT9 = IHIT9 - 1
 70200 651            IF(HLBAR(IHIT9).NE.0) IHIT9 = IHIT9 - 1
 70300 653            IF(IHIT9.LT.JHIT0) JHIT0 = IHIT9
 70400 655            IF(IHIT0.GT.JHIT9) JHIT9 = IHIT0
 70500 657         CIF
 70600    C
 70700 658      CPROC
 70800    C
 70900                                                                             *************************
 71000                                                                             *      F P A R A B      *
 71200    C                                                                        *************************
 71300    C
 71500 660      PROC FPARAB                                                        PARABOLA FIT TO TREL-CAND
 71600    C
 71800 661         S0 = 0.                                                         GET EQUATIONS
 71900 662         S1 = 0.
 72000 663         S2 = 0.
 72100 664         S3 = 0.
 72200 665         S4 = 0.
 72300 666         S5 = 0.
 72400 667         S6 = 0.
 72500 668         S7 = 0.
 72600 669         FOR IHIT = IHIT0,IHIT9
 72800 670            IF HLBAR(IHIT).EQ.0                                          SELECT UNREJECTED HITS ONLY
 72900 671            THEN
 73000 674               IX = HLYAR(IHIT)
 73100 675               X  = IX
 73200 676               DSTAG = DSTAG0
 73300 677               IF(LAND(IX,1).NE.0) DSTAG =-DSTAG0
 73400 679               Y = DSPAR(IHIT) + DSTAG
 73500 680               X2 = X**2
 73600 681               S1 = S1 + X
 73700 682               S2 = S2 + X2
 73800 683               S3 = S3 + X*X2
 73900 684               S4 = S4 + X2**2
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 12
0CARD TARGET
  NO  STM.NO
 
 74000 685               S5 = S5 + Y*X2
 74100 686               S6 = S6 + Y*X
 74200 687               S7 = S7 + Y
 74300 688               S0 = S0 + 1.
 74400 689            CIF
 74500 690         CFOR
 74600 692         MHIT = S0 + .5
 74700    C
 74900 693         IF MHIT.LT.3                                                    CHECK IF <3 HITS
 75000 694         THEN
 75100 697            SIG = TRELLM(12)**2
 75200 698            PAR1 = 0.
 75300 699            PAR2 = 0.
 75400 700            PAR3 = 0.
 75500 701            DEG = 1.
 75600 702            S0  = 1.
 75700 703         ELSE
 75800 705            IF MHIT.LE.4
 76000 706            THEN                                                         STRAIGHT LINE FIT IF 3 - 4 HITS
 76100 709               ZW1  = (S6*S0 - S1*S7)
 76200 710               ZW2  = (S2*S0 - S1**2)
 76300 711               PAR1   = 0.
 76400 712               PAR2   = ZW1 / ZW2
 76500 713               PAR3   =(S7 - PAR2*S1) / S0
 76600 714               DEG = S0 - 2.
 76700 715            ELSE
 76900 717               F1 = 1. / S4                                              SOLVE EQUATIONS FOR PARABOLA FIT
 77000 718               XX12 = S3*F1
 77100 719               XX13 = S2*F1
 77200 720               YY1  = S5*F1
 77300 721               XX22 = S2 - S3*XX12
 77400 722               XX23 = S1 - S3*XX13
 77500 723               YY2  = S6 - S3*YY1
 77600 724               XX32 = S1 - S2*XX12
 77700 725               XX33 = S0 - S2*XX13
 77800 726               YY3  = S7 - S2*YY1
 77900 727               IF XX22.GT.XX32
 78000 728               THEN
 78100 731                  XX23 = XX23 / XX22
 78200 732                  YY2  = YY2  / XX22
 78300 733                  PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 78400 734                  PAR2 = YY2 - XX23*PAR3
 78500 735               ELSE
 78600 737                  XX33 = XX33 / XX32
 78700 738                  YY3  = YY3  / XX32
 78800 739                  PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 78900 740                  PAR2 = YY3 - XX33*PAR3
 79000 741               CIF
 79100 742               PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
 79200 743               DEG = S0 - 3.
 79300    C
 79400 744               IF MHIT.LT.6 .AND. ABS(PAR1).GT.TRELLM(9)
 79600 745               THEN                                                      STRAIGHT LINE FIT IF <6 HITS + TOO BIG CURV.
 79700 748                  ZW1  = (S6*S0 - S1*S7)
 79800 749                  ZW2  = (S2*S0 - S1**2)
 79900 750                  PAR1   = 0.
 80000 751                  PAR2   = ZW1 / ZW2
 80100 752                  PAR3   =(S7 - PAR2*S1) / S0
 80200 753                  DEG = S0 - 2.
 80300 754               CIF
 80400 755            CIF
 80500    C
 80600 756         CIF
 80700    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 13
0CARD TARGET
  NO  STM.NO
 
 80900 757         ILAY0 = HLYAR(IHIT0)                                            CALC. START + END POINT PARAM.
 81000 758         WR0   = ILAY0
 81100 759         DS0   = FPAR(WR0)
 81200 760         SLOP0 = WR0*PAR1*2. + PAR2
 81300 761         ILAY9 = HLYAR(IHIT9)
 81400 762         WR9   = ILAY9
 81500 763         DS9   = FPAR(WR9)
 81600 764         SLOP9 = WR9*PAR1*2. + PAR2
 81700    C
 81900 765         MDHIT = IHIT9-IHIT0 + 1 - MHIT                                  DETERMINE LIMIT OF SIGMA
 82000 766         IF ABS(PAR1).GT..05 .OR. (MHIT.LT.6 .AND. MDHIT.GT.0)
 82100 767         THEN
 82300 770            SIGLM = TRELLM(16)**2                                        CURVED TRACK
 82400 771         ELSE
 82600 773            SIG1 = TRELLM(16)                                            STRAIGHT TRACK
 82700 774            SIG2 = 0.
 82800 775            SIG3 = 0.
 83000 776            IF(DSMAX(ILAY0+1,IRING,1)-5. .LT. DS0) SIG2 = TRELLM(17)     INCREASE LIMIT FOR TRACKS AT WALL
 83200 778            IF(DS0.LT.1.5) SIG3 = TRELLM(18)                             INCREASE LIMIT FOR TRACKS AT WIRE PLANE
 83300 780            IF(DSMAX(ILAY9+1,IRING,1)-5. .LT. DS9) SIG2 = SIG2+TRELLM(17)
 83400 782            IF(DS9.LT.1.5) SIG3 = SIG3 + TRELLM(18)
 83500 784            SIGLM = SIG1**2 + SIG2**2 + SIG3**2
 83600 785         CIF
 83700    C
 83800                                                                             SPECIAL LIMIT FOR RATHER STRAIGHT TRELS
 84000 786         SIGSL = 0.                                                      WITH BIG SLOPE
 84100 787         SLRAT =  AMIN1(ABS(SLOP0+SLOP9)*.1, 1.0)
 84200 788         IF(ABS(PAR1).LT..5 .AND. SLRAT .GT. 0.2)
 84300         ?   SIGSL = (SLRAT*TRELLM(17))**2 + TRELLM(16)**2
 84400 790         IF(SIGSL.GT.SIGLM) SIGLM = SIGSL
 84500    C
 84600 792      CPROC
 84700    C
 84800 794      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         793 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
0END OF PROGRAM
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         793 TARGET STATEMENTS
