C   22/03/97 703221857  MEMBER NAME  JEOSUM5  (JADEGS)      FORTRAN     00000000
          C   07/11/86 701231748  MEMBER NAME  AKOP     (S)           SHELTRAN
         2      SUBROUTINE AKOP( P, NP, NMAXP, A, AXIS, ITMERR )
          C *---------------------------------------------------------
          C *
          C *  VERSION OF 21/05/79   LAST MOD 02/06/81   E.ELSEN/S.BETHKE
          C *  INPUT : P(4,NP)   NP MOMENTA PX,PY,PZ,ABS(P)
          C *          NP        NUMBER OF MOMENTA
          C *          NMAXP     CUTOFF FOR PERMUTED MOMENTA
          C *                    =0 MEANS NO CUTOFF
          C *  OUTPUT: AKOP      AKOPLANARITY VALUE
          C *          AXIS      AKOP AXIS
          C *          ITMERR    =1, IF LEFT TIME IS NOT ENOUGH TO CALCULATE THRST
          C *                    (NOW MIN.2 SECONDS ARE REQUIRED.)
          C *  METHOD: MOMENTUM CONSERVATION IS TAKEN CARE OF BY INTRODUCING
          C *          MISSING MOMENTUM VECTOR AT THE END OF P ARRAY.
          C *          AKOPLANARITY VALUE IS FOUND BY LOOKING THROUGH ALL
          C *          PERMUTATIONS OF THE MOMENTA - PRODUCTS (PI X PJ) * PK
          C *---------------------------------------------------------
         3      DIMENSION P(1), AXIS(3)
         4      DIMENSION PIN(320), IPERM(200),IPS(320),PS(320)
         5      COMMON / CWORK / WORK(840)
         6      EQUIVALENCE (WORK(1),PIN(1)),(WORK(321),IPERM(1))
         7      EQUIVALENCE (WORK(521),PS(1),IPS(1))
          C
         8      DATA IPINC / 4 /
         9      DATA NLIMIT / 20 /
        10      DATA NSEC / 2 /
        11      DATA IER0 / 0/, IER1 /0/, IER2 /0/
          C
          C
        12      ITMERR = 0
          C
        13      AXIS(1) = 1.
        14      AXIS(2) = 1.
        15      AXIS(3) = 1.
        16      A = 1000.
          C
        17      IF NP .LE. 0
        18      THEN
        21         IF IER0 .LT. 10
        22         THEN
        25            WRITE(6,9103)
        26 9103 FORMAT(' +++ ERROR IN AKOP.  CALLED WITH ZERO PARTICLES +++')
        27         CIF
        28         IER0 = IER0 + 1
        29         RETURN
        30      CIF
          C
          C
        31      NMAXP1 = NMAXP
        32      IF  NP.GE.NLIMIT .AND. ( NMAXP.EQ.0 .OR. NMAXP.GT.NLIMIT )
        33      THEN
        36         IF IER1 .LT. 10                                                 WARNING CONCERNING NUMBER OF PARAMETERS
        37         THEN
        40            WRITE(6,9101) NP,NLIMIT,NMAXP
        41 9101 FORMAT(' +++++  WARNING FROM AKOP ROUTINE  +++++'/
               *      2X,I4,' ARE TOO MANY INPUT VECTORS. INTERNAL LIMIT=',I4,
               *      ' INPUT CUTOFF NMAXP=',I4,'. ONLY NLIMIT PARTICLES ARE PERMUTED')
          C
        42            NMAXP1 = NLIMIT
        43         CIF
        44         IER1 = IER1 + 1
        45      CIF
          C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
        46      NTOT = NP
        47      CALL BALANC( P, NTOT, PSUM )                                       BALANCE MOMENTA IN P ARRAY
        48      IF PSUM .LT. 1.E-6
        49      THEN
        52         IF IER2 .LT. 10
        53         THEN
        56            WRITE(6,9104)
        57 9104 FORMAT(' +++ ERROR IN AKOP. MOMENTUM SUM AFTER BALANCE=0. +++')
        58         CIF
        59         IER2 = IER2 + 1
        60         RETURN
        61      CIF
          C
        62      IF NTOT.GT.NMAXP1 .AND. NMAXP1.NE. 0
        63      THEN
        66         PERFORM SORT                                                    SORT MOMENTA IN DECREASING ORDER
          C
        69         NP1 = NTOT
        70         NTOT = NMAXP1 - 1
        71         PERFORM FILLIN                                                  PIN ARRAY = ORDERED P ARRAY
          C
        74         CALL BALANC( PIN, NTOT, PSUM1 )                                 BALANCE REDUCED SET OF MOMENTA
          C
        75         PERFORM AKOPL                                                   AKOP AND AXIS FOR PIN ARRAY
        78         PERFORM AKOEXP
        81      ELSE
        83         CALL UCOPY( P, PIN, NTOT*4 )                                    COPY FROM P TO PIN ARRAY
        84         PERFORM AKOPL                                                   AKOP   FOR PIN ARRAY
        87      CIF
        88      RETURN
          C
          C
          C
          C--------------
          C
        89      PROC SORT
          C--------------
                                                                                   ORDER P ARRAY USING SHELLSORT ALGTHM
        90         FOR J=1,NTOT                                                    SEQUENCE OF MOMENTA IS STORED IN IPERM
        91            IPERM(J) = J*4                                               INIT IPERM IN NATURAL ORDER
        92         CFOR
          C
        94         M = NTOT / 2
        95         WHILE  M.GT.0
        97            K = NTOT - M
       101            FOR J=1,K
       102               I = J
       103               WHILE  I.GT.0
       105                  ILOW = IPERM(I)
       109                  IHIGH = IPERM(I+M)
       110                  IF  P(IHIGH) .GT. P(ILOW)
       111                  THEN
       114                     IPERM(I) = IHIGH
       115                     IPERM(I+M) = ILOW
       116                     I = I - M
       117                  ELSE
       119                     XWHILE
       120                  CIF
       121               CWHILE
       123            CFOR
       125            M = M/2
       126         CWHILE
       128      CPROC
          C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
          C
          C--------------
          C
       130      PROC FILLIN
          C--------------
       131         FOR J=1,NTOT                                                    PIN(1..4,J) = P(1..4,IPERM(J)/4)
       132            IPJ = IPERM(J)
       133            J4 = J*4
       134            PIN(J4  ) = P(IPJ  )
       135            PIN(J4-1) = P(IPJ-1)
       136            PIN(J4-2) = P(IPJ-2)
       137            PIN(J4-3) = P(IPJ-3)
       138         CFOR
       140      CPROC
          C
          C
          C----------------
       142      PROC AKOPL
          C----------------
          C
       143         IF A .NE. 0.
       144         THEN
       147            K1 = NTOT-1
       148            FOR INDI=1,K1
       149               K2 = INDI+1
       150               FOR INDJ=K2,NTOT
       151                  INDI4 = INDI * 4                                       CALCULATE PIJ = PI X PJ
       152                  P11 = PIN(INDI4-3)
       153                  P12 = PIN(INDI4-2)
       154                  P13 = PIN(INDI4-1)
       155                  INDJ4 = INDJ * 4
       156                  P21 = PIN(INDJ4-3)
       157                  P22 = PIN(INDJ4-2)
       158                  P23 = PIN(INDJ4-1)
       159                  PIJ1 = P12 * P23 - P13 * P22
       160                  PIJ2 = P13 * P21 - P11 * P23
       161                  PIJ3 = P11 * P22 - P12 * P21
       162                  PIJ4 = SQRT(PIJ1*PIJ1 + PIJ2*PIJ2 + PIJ3*PIJ3)
       163                  AIJ = 0.
       164                  IF PIJ4 .GT. 1.E-5
       165                  THEN
       168                     FOR INDK=1,NTOT
       169                        INDK4 = INDK * 4                                 CALCULATE SUM(PIJ*PK)
       170                        AIJ = AIJ + ABS(PIJ1 * PIN(INDK4-3) + PIJ2 * PIN(INDK4-2)
               *                  + PIJ3 * PIN(INDK4-1))
       171                     CFOR
          C
       173                     AIJ = AIJ/PIJ4
       174                     IF AIJ .LT. A
       175                     THEN
       178                        AXIS(1) = PIJ1/PIJ4
       179                        AXIS(2) = PIJ2/PIJ4
       180                        AXIS(3) = PIJ3/PIJ4
       181                        A = AIJ
       182                     CIF
       183                  ELSE
       185                     IF NTOT .LE. 4
       186                     THEN
       189                        AXIS(1) = 0.
       190                        AXIS(2) = 0.
       191                        AXIS(3) = 0.
       192                        A = 0.
       193                     CIF
       194                  CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
          C
       195               CFOR
       197            CFOR
       199            A = 4. * ((A / PSUM)**2)
       200         CIF
       201      CPROC
          C
          C
          C--------------
          C
       203      PROC AKOEXP
          C--------------
       204         NIPINC = NP1*IPINC                                              COMPUTE AKOPL EXPLICITLY
       205         AA = 0.
       206         FOR J=1,NIPINC,IPINC
       207            AA = AA + ABS( AXIS(1)*P(J)+AXIS(2)*P(J+1)+AXIS(3)*P(J+2) )
       208         CFOR
       210         A = 4. * ((AA / PSUM)**2)
       211      CPROC
          C
       213      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         212 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
          C   23/05/79            MEMBER NAME  BALANC   (PHYS1)       SHELTRAN
         2      SUBROUTINE BALANC( P, NTOT, PSUM )
          C *---------------------------------------------------------
          C *
          C *  VERSION OF 23/05/79      LAST MOD 14/05/80     E.ELSEN
          C *  PUT IN MOMENTUM BALANCING VECTOR BEHIND THE NTOT MOMENTA
          C *  IN P. NTOT IS CHANGED ON RETURN. EXTRA LOCATIONS IN P MUST
          C *  BE ACCOUNTED FOR IN CALLING ROUTINE.
          C *  PSUM = SUM | P |    FOR BALANCED SET
          C *  STORAGE :    P(1..3) = THREE VECTOR
          C *               P(4)    = TOTAL MOMENTUM      BOTH REPEATED NTOT TIMES
          C *---------------------------------------------------------
          C
         3      DIMENSION P(1)
          C
         4      PSUM1 = 0.                                                         FIND SUM OF MOMENTA
         5      PSUM2 = 0.
         6      PSUM3 = 0.
         7      PSUM  = 0.
         8      N4 = NTOT*4
         9      FOR J=1,N4,4
        10         PSUM1 = P(J  ) + PSUM1
        11         PSUM2 = P(J+1) + PSUM2
        12         PSUM3 = P(J+2) + PSUM3
        13         PSUM  = P(J+3) + PSUM
        14      CFOR
        16      PTOT = SQRT( PSUM1*PSUM1 + PSUM2*PSUM2 + PSUM3*PSUM3 )
        17      IF  PTOT .GT. .01                                                  EXTRA LOC FOR PSUM IN P IF PSUM .GT. .01 GEV
        18      THEN
        21         P(N4+1) = -PSUM1
        22         P(N4+2) = -PSUM2
        23         P(N4+3) = -PSUM3
        24         P(N4+4) = PTOT
        25         PSUM = PSUM + PTOT
        26         NTOT = NTOT + 1                                                 INCREMENT NUMBER OF MOMENTA
        27      CIF
          C
        28      RETURN
        29      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          28 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         240 TARGET STATEMENTS
          C   28/04/87 803181309  MEMBER NAME  AMPS2Z   (JADEGS)      SHELTRAN
         2      SUBROUTINE AMPS2Z( IP, NPJETC, Z, W, IFLAG )
          C-----------------------------------------------------------
          C  VERSION OF 21/04/87         LAST MOD 10/03/88   E ELSEN
          C  Convert the amplitudes stored in HW(IP+1) and HW(IP+2)
          C  into Z and calculate the weight W associated with this
          C  measurement.
          C  NPJETC = IW(IBLN('JETC'))
          C  Flag IFLAG is 0 if the hit passes some quality criteria
          C  Weighting will only work if ZSFIT has been called. In that
          C  case CZSCAL has been initialised ( ZALPDI=1400 )
          C  Note the different effective wire length that is used
          C  for the two calibrations.
          C  Two track cut now at 3.6 mm to avoid differences
          C  between MC and Data.
          C-----------------------------------------------------------
         3      IMPLICIT INTEGER*2 (H)
          C                                           from zsfit
          C                                           zal name conflict
          C     COMMON /CZSCAL/ IPVERS,ZAL,RESFAC,SECH(5)
         4      COMMON /CZSCAL/ IPVERS, ZALPDI, RESFAC, SECH(5)
 01200    C
 01201    C  COMMON FOR Z-RESOLUTION PARAMETERS,   USED IN SUBR. AMPS2Z
 01202    C
 01210   5      COMMON / CZSPRM / NZSPRD,
 01300    C                                           PARMS FOR RESOLUTIONS
 01400         * AZSRS0(3), AZSRSA(3),
 01500    C                                           PARMS FOR CUTS
 01600         * AZSCT1(3), AZSCT2(3), AZSCT3(3), AZSCT4(3),
 01700    C                                           SECOND HIT
 01800         * AZSSHT(5,3),
 01900    C                                           SECOND HIT DISTANCE
 02000         * AZSSHD(3),
 02100    C                                           AVE RESOLUTIONS
 02200         * AZSSAV(3),
 02300    C                                           ZSPD BANK FILL FLAG
 02400         * LZSPDF
 02500   6      LOGICAL LZSPDF
          C
          C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400   7      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
         8      COMMON / BCS / HW(1)
          C
         9      REAL EXTRMZ / 1250. /, ZALDEF / 1400. /
          C                                           SECOND HIT DISTANCE
        10      REAL DISMAX / 3.6 /
          C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
        11      LOGICAL FIRST / .TRUE. /
          C
        12      IF FIRST
        13      THEN
        16         FIRST = .FALSE.
        17         WRITE(6,9101) NZSPRD, ZALPDI, ZALDEF
        18 9101    FORMAT(' +++ AMPS2Z    NZSPRD=',I3,' ZALPDI=',F10.3,
               *   ' ZALDEF=',F10.3)
        19      CIF
 
          C
        20      Z = 0.
        21      W = 1.
        22      IFLAG = 16
          C
        23      AL = HW(IP+2)/8.
        24      AR = HW(IP+1)/8.
          C                                          check whether CZSCAL has been
          C                                          initialised
        25      IF  AL.GT.0. .AND. AR.GT.0.
        26      THEN
        29         IF  ZALPDI .EQ. ZALDEF
        30         THEN
        33            Z = ZALPDI*(AL-AR)/(AL+AR)
        34            IF NZSPRD .LE. 2
        35            THEN
        38               W = ( AZSSAV(NZSPRD) /
               *         ( AZSRS0(NZSPRD)+
               *         AZSRSA(NZSPRD)*SQRT(AL**2+AR**2)/(AL+AR)**2
               *         )
               *         )**2
        39            ELSE
        41               W = (AZSSAV(NZSPRD)/
               *         (AZSRS0(NZSPRD)+AZSRSA(NZSPRD)/(AL+AR)))**2
        42            CIF
        43         ELSE
        45            Z = .5*ZAL*(AL-AR)/(AL+AR)
        46         CIF
        47         IF  ABS( Z ) .LT. EXTRMZ
        48         THEN
        51            IF NZSPRD.GT.2
        52            THEN
          C                                           ANY CLOSE HIT?
        55               ISEC = 0
        56               NP = IP - 4
        57               IF  NP.GT.NPJETC*2+100 .AND. HW(NP)/8 .EQ. HW(IP)/8
        58               THEN
        61                  ICELL = HW(IP)/128 + 1
        62                  DIS = (HW(NP+3)-HW(IP+3))*
               *            (DRIVEL(ICELL,1)+DRIVEL(ICELL,2))/2.
        63                  IF( ABS(DIS).LT.DISMAX ) ISEC = ISEC + 1
        65               CIF
        66               NP = IP + 4
        67               IF  NP.LT.NPJETC*2+100+HW(NPJETC*2+99) .AND.
               *            HW(NP)/8 .EQ. HW(IP)/8
        68               THEN
        71                  ICELL = HW(IP)/128 + 1
        72                  DIS = (HW(NP+3)-HW(IP+3))*
               *            (DRIVEL(ICELL,1)+DRIVEL(ICELL,2))/2.
        73                  IF( ABS(DIS).LT.DISMAX ) ISEC = ISEC + 1
        75               CIF
        76               IF( ISEC .EQ. 0 ) IFLAG = 0
        78            ELSE
        80               IFLAG = 0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
        81            CIF
        82         CIF
          C                                           OVERFLOW HITS
        83         IF(IFLAG.EQ.0 .AND.
               *   ( HW(IP+1).EQ. 32760 .OR. HW(IP+2).EQ. 32760 ) ) IFLAG = 32
        85      CIF
        86      RETURN
        87      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          86 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          86 TARGET STATEMENTS
 00000    C   09/06/83 801291914  MEMBER NAME  CNEWID   (JADEGS)      SHELTRAN
 00100   2      SUBROUTINE CNEWID(INDEX)
 00200    C
 00300    C        J. SPITZER                         86/10/16
 00400    C
 00500    C        HANDELS NEW ID CALIBRATION CONSTANTS WHEN AVAILABLE.
 00600    C        IN THE LATTER CASE SETS NEW RUN VERTEX TOO.
 00700    C        IT IS CALLED FOR EACH EVENT FROM KALIBR AFTER KLREAD WITH
 00800    C                                                            INDEX=0
 00900    C        EXTRA CALL AT ANY TIME WITH
 01000    C            INDEX=-1 : OLD CALIBRATION IS FORCED (CURRENT DEFAULT)
 01100    C                  -2 : NEW CALIBRATION WHEN AVAILABLE, OLD OTHERWISE
 01200    C               LE -3 : AS -2 BUT NEW RUN VERTEX IS NOT SET
 01300    C        THESE SETTINGS REMAIN IN EFFECT UNTIL AN OTHER CALL WITH
 01400    C        INDEX <0.   NEW OPERATION MODE SHOULD BE ASKED BEFORE
 01500    C        THE CALL TO KALIBR OTHERWEISE THE NEW SETTING WILL APPLY
 01600    C        STARTING AT THE NEXT EVENT ONLY. (AT THE CALLS WITH <0
 01700    C        JUST THE SETTING IS CHANGED, THE NORMAL TASKS ARE NOT
 01800    C        PERFORMED.)
 01900    C
 02000    C        THE NEW CALIBRATION IS IN EFFECT CURRENTLY ONLY IF JFETCH
 02100    C        IS USED FOR RECONSTRACTING THE HIT COORDINATES.
 02200    C        JFETCH HAS BEEN MODIFIED TO CALL THE NEW ROUTINE JFTNEW
 02300    C        IN CASE JESCAL POSITIVE (AS SET BY THIS ROUTINE).
 02400    C
 02500    C
 02600    C NEW CALIBRATION (ISTEAR=-2) DEFAULT 12.4.1987      J.S., J.O.
 02610    C LAST MOD   C.B.   29/01/88     PRINT BLANK LINE BEFORE MESSAGE
 02700    C
 02800    C
 02900   3      IMPLICIT INTEGER*2 (H)
 03000    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 CALIBR .... JADE CALIBRATION DATA COMMON
          C----------------------------------------------------------------------
         8      COMMON/CALIBR/ ACALIB(1000)
         9      DIMENSION HCALIB(100),ICALIB(100)
 02600  10      EQUIVALENCE(ACALIB(1),HCALIB(1),ICALIB(1))
          C------------------------ END OF MACRO CALIBR -------------------------
 03300    C
 03400    C
 03500    C     DATA ISTEAR/-1/,IRLAST/-99999/,IPLAST/-99999/,IPOINT/0/,IRPLST/0/
 03600  11      DATA ISTEAR/-2/,IRLAST/-99999/,IPLAST/-99999/,IPOINT/0/,IRPLST/0/
 03700    C
 03800  12      DATA ICLV /0/
 03900  13      DATA NCAL1/0/,IPLHDR/0/,IPRLIM/100/,IPRLIN/0/
 04000    C
 04100  14      COMMON/JSCALD/ JESCAL,JESKEY,JESDRW
 04200  15      INTEGER NVERTS/0/,IVERTS/0/,NVRUN(300,2)/600*0/
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 04300  16      REAL XVRUN(300)/300*0./,YVRUN(300)/300*0./
 04400  17      INTEGER IUPDJS(6,40),NUPDJS/0/
 04500  18      REAL RUPDJS(6,40)
 04600  19      EQUIVALENCE (IUPDJS(1,1),RUPDJS(1,1))
 04700    C
 04800    C
 04900    C-----------------------------------------------------------------------
 05000    C                        ----  CHANGE OF OPERATION MODE----
 05100  20      IF INDEX.LT.0
 05200  21      THEN
 05300  24         ISTEAR=INDEX
 05400  25         IF ISTEAR.LE.-2
 05500  26         THEN
 05600  29            PRINT 110,IRLAST
 05700  30            IF ISTEAR.EQ.-2
 05800  31            THEN
 05900  34               PRINT 111
 06000  35            ELSE
 06100  37               PRINT 112
 06200  38            CIF
 06300  39         ELSE
 06400  41            PRINT 120,IRLAST
 06500  42         CIF
 06600  43110   FORMAT(//,' **** USE NEW CALIBRATION WHEN AVAILABLE AFTER RUN',I7)
 06700  44111   FORMAT(6X,'WITH NEW RUN VERTEX',//)
 06800  45112   FORMAT(6X,'WITHOUT SETTING NEW RUN VERTEX',//)
 06900  46120   FORMAT(//,' **** USE OF OLD CALIBRATION FORCED AFTER RUN',I7,//)
 07000  47         RETURN
 07100  48      CIF
 07200    C
 07300    C-----------------------------------------------------------------------
 07400    C
 07500  49      IF NCAL1.EQ.0
 07600  50      THEN
 07700  53         NCAL1=1
 07800  54         IPLHDR=IBLN('HEAD')
 07900  55         JESKEY=54321
 08100  56         IPOINT=ICALIB(13)                                               * GET POINTER OF NEW CALIBR. DATA IN ACALIB
 08200  57      CIF
 08300    C-----------------------------------------------------------------------
 08400    C
 08500  58      IPHDR2=IDATA(IPLHDR)*2
 08600  59      IRUN=HDATA(IPHDR2+10)
 08700    C
 08800    C                --- NO NEW CALIBRATION IF OLD IS FORCED OR MONTE CARLO
 08900    C
 09000  60      IF ISTEAR.GT.-2 .OR. IRUN.LE.100
 09100  61      THEN
 09200  64         JESCAL=0
 09300  65         RETURN
 09400  66      CIF
 09500    C
 09600    C-----------------------------------------------------------------------
 09700    C    --- CHECK IF VALID CALIBRATION RECORD PRESENT ---
 09800  67      ICDNUM=ICALIB(IPOINT+1)
 09900  68      IF ICDNUM.LT.654320.OR.ICDNUM.GT.654322
 10000  69      THEN
 10100  72         IF IPRLIN.LT.IPRLIM
 10200  73         THEN
 10300  76            PRINT 9821,IRUN
 10400  779821        FORMAT(' *** NO VALID RECORD FOR NEW CALIBRATION',
 10500         +      ' PRESENT AT RUN',I8)
 10600  78            IPRLIN=IPRLIN+1
 10700  79         CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 10800  80         JESCAL=0
 10900  81         RETURN
 11000  82      CIF
 11100    C
 11200    C-----------------------------------------------------------------------
 11300    C                              --- NEW OR FIRST RUN ---
 11400  83      IF IRUN.NE.IRLAST
 11500  84      THEN
 11600  87         IRLAST=IRUN
 11700  88         IF ICALIB(IPOINT+2).NE.IPLAST
 11800  89         THEN
 11900    C                            ---  NEW CAL. PREIOD ---
 12000  92            IPLAST=ICALIB(IPOINT+2)
 12100  93            IRPLST=ICALIB(IPOINT+3)
 12200  94            IF ICDNUM.EQ.654320
 12300  95            THEN
 12400    C                            ---  NO NEW CAL. AVAILABLE YET ---
 12500  98               JESCAL=0
 12600  99               PRINT 721, IPLAST,IRPLST
 12700 100721            FORMAT(/' **** OLD ID CALIBRATION WILL BE USED FOR',
 12800         +         ' RUNS',I6,' TO',I6)
 12900 101            ELSE
 13000    C                            ---  THERE IS NEW CALIBRATION ---
 13100 103               JESCAL=IPLAST
 13200    C                     --- COPY RUN VERTICES ---
 13300 104               NVERTS=ICALIB(IPOINT+4)
 13400 105               IF NVERTS.GT.0
 13500 106               THEN
 13600 109                  FOR J=1,NVERTS
 13700 110                     NVRUN(J,1)=ICALIB(3*J+IPOINT+10275)
 13800 111                     XVRUN(J)=  ACALIB(3*J+IPOINT+10276)
 13900 112                     YVRUN(J)=  ACALIB(3*J+IPOINT+10277)
 14000 113                  CFOR
 14100    C
 14200 115                  NVRUN(1,1)=IPLAST
 14300 116                  I=1
 14400 117                  WHILE I.LT.NVERTS
 14500 119                     NVRUN(I,2)=NVRUN(I+1,1)-1
 14600 123                     I=I+1
 14700 124                  CWHILE
 14800 126                  NVRUN(NVERTS,2)=IRPLST
 14900    C                     --- SELECT RUN VERTEX PERIOD ---
 15000 127                  IVERTS=1
 15100 128                  WHILE IRUN.GT.NVRUN(IVERTS,2)
 15200 130                     IVERTS=IVERTS+1
 15300 134                  CWHILE
 15400 136               CIF
 15500    C                            --- COPY UPDATES ---
 15600 137               NUPDJS=ICALIB(IPOINT+5)
 15700 138               IF NUPDJS.GT.0
 15800 139               THEN
 15900 142                  FOR J2=1,NUPDJS
 16000 143                     FOR J1=1,6
 16100 144                        IUPDJS(J1,J2)=ICALIB(6*J2+J1+IPOINT+11171)
 16200 145                     CFOR
 16300 147                  CFOR
 16400 149               CIF
 16500    C                    --- NO/YES DISTORTIONS AVAILABLE ---
 16600 150               JESDRW=ICDNUM-654321
 16700 151               PRINT 720, JESCAL,IRPLST
 16800 152720            FORMAT(/' **** NEW ID CALIBRATION WILL BE USED FOR',
 16900         +         ' RUNS',I6,' TO',I6)
 17000 153            CIF
 17100 154         CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 17200    C                      --- CHECK IF RUN OUT OF RANGE ---
 17300 155         IF IRUN.LT.IPLAST.OR.IRUN.GT.IRPLST
 17400 156         THEN
 17500 159            IF IPRLIN.LT.IPRLIM
 17600 160            THEN
 17700 163               PRINT 9823,IRUN,IPLAST,IRPLST
 17800 1649823           FORMAT(' *** RUN',I7,' OUT OF RANGE OF CURRENT',
 17900         +         ' CALIBRATION PERIOD:',I7,' TO',I7)
 18000 165               IF(JESCAL.GT.0) PRINT 9824
 18100 1679824           FORMAT(' FIRST RUN IN THIS PERIOD ASSUMED FOR',
 18200         +         ' VERTEX AND UPDATES')
 18300 168               IPRLIN=IPRLIN+1
 18400 169            CIF
 18500 170            IRUN=IPLAST
 18600 171         CIF
 18700    C                      --- CHECK IF CHANGE IN RUN VERTEX PERIOD ---
 18800 172         IF JESCAL.GT.0 .AND. NVERTS.GT.0
 18900 173         THEN
 19000 176            IF IRUN.GT.NVRUN(IVERTS,2)
 19100 177            THEN
 19200 180               REPEAT
 19300 181                  IVERTS=IVERTS+1
 19400 182               UNTIL IRUN.LE.NVRUN(IVERTS,2)
 19500 183            ELSE
 19600 188               IF IRUN.LT.NVRUN(IVERTS,1)
 19700 189               THEN
 19800 192                  REPEAT
 19900 193                     IVERTS=IVERTS-1
 20000 194                  UNTIL IRUN.GE.NVRUN(IVERTS,1)
 20100 195               CIF
 20200 199            CIF
 20300 200         CIF
 20400    C             --- HANDLE UPDATES (WITHIN CURRENT CAL. PER.) ---
 20500 201         IF JESCAL.GT.0 .AND. NUPDJS.GT.0
 20600 202         THEN
 20700 205            FOR J=1,NUPDJS
 20800 206               IND=IUPDJS(4,J)*96+IUPDJS(3,J)-91+IPOINT
 20900 207               IF IRUN.GE.IUPDJS(1,J).AND.IRUN.LE.IUPDJS(2,J)
 21000 208               THEN
 21100 211                  ACALIB(IND)=RUPDJS(5,J)
 21200 212               ELSE
 21300 214                  ACALIB(IND)=RUPDJS(6,J)
 21400 215               CIF
 21500 216            CFOR
 21600 218         CIF
 21700 219      CIF
 21800    C
 21900    C-----------------------------------------------------------------------
 22000    C                            --- SET RUN VERTEX FOR EACH EVENT ---
 22100 220      IF JESCAL.GT.0 .AND. NVERTS.GT.0 .AND. ISTEAR.EQ.-2
 22200 221      THEN
 22400 224         ICLV = ICLV + 1                                                 SET RUN VERTEX
 22500 225         IF(ICLV.EQ.1) WRITE(6,864)
 22600 227864   FORMAT('  CNEWID ***:  RUN VERTICES CORRESPONDING TO NEW ID CALIBR
 22700         $   ATION SET IN /CALIBR/')
 22800 228         IPV  = ICALIB(10)
 22900 229         ACALIB(IPV+ 1) = XVRUN(IVERTS)
 23000 230         ACALIB(IPV+ 3) = YVRUN(IVERTS)
 23100 231      CIF
 23200    C
 23300 232      RETURN
 23400 233      END
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         232 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         232 TARGET STATEMENTS
 00000    C   09/06/83 703131344  MEMBER NAME  DISTXY   (S)           SHELTRAN
 00100   2      FUNCTION DISTXY(X,Y,DX,DY,R,X0,Y0,XP,YP,PHIP)
 00110    C                                   J. SPITZER
 00120    C     INPUT:
 00130    C        X,Y,DX,DY  POSITION AND DIRECTION FOR 1. MEASURED POINT
 00140    C        R= 1/CURVATURE
 00150    C        X0,Y0 ANY POINT
 00160    C     OUTPUT
 00170    C        DISTXY  CLOSEST DISTANCE OF TRACK TO (X0,Y0)
 00180    C        XP,YP,PHIP (0,2PI) CLOSEST POINT AND ANGLE OF TRACK THERE
 00190    C
 00200   3      DATA PIVALU/3.141593/
 00300   4      ALEN=SQRT(DX**2+DY**2)
 00400   5      SINOM=DY/ALEN
 00500   6      COSOM=DX/ALEN
 00600   7      G=(X0-X)**2+(Y0-Y)**2+2.*R*((Y0-Y)*COSOM-(X0-X)*SINOM)
 00700   8      DISTXY=SQTVAL(ABS(R),G,1.,1.E-4)
 00800   9      IF R.GT.0.
 00900  10      THEN
 01000  13         SGNR=1.
 01100  14      ELSE
 01200  16         SGNR=-1.
 01300  17      CIF
 01400  18      A1=DISTXY/ABS(R)
 01500  19      A2=1./(1.+A1)
 01600  20      XP=A2*(X0+X*A1+SINOM*SGNR*DISTXY)
 01700  21      YP=A2*(Y0+Y*A1-COSOM*SGNR*DISTXY)
 01800  22      SINOMP=A2*((X-X0)/R+SINOM)
 01900  23      COSOMP=A2*((Y0-Y)/R+COSOM)
 02000  24      IF(COSOMP.GT.1.) COSOMP=1.
 02100  26      IF(COSOMP.LT.-1.) COSOMP=-1.
 02200  28      PHIP=ACOS(COSOMP)
 02300  29      IF(SINOMP.LT.0.) PHIP=2.*PIVALU-PHIP
 02400  31      RETURN
 02500  32      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          31 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          31 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 00000    C   12/12/79 106101754  MEMBER NAME  EXJHTL   (JADEGS)      SHELTRAN
 00001    C   10/09/79 912120822  MEMBER NAME  EXJHTL   (JADESR)      SHELTRAN
 00002    C   06/09/79 C9091001   MEMBER NAME  EXJHTL   (JADESR)      SHELTRAN
 00003   2      SUBROUTINE EXJHTL(IERR)
 00004    C
 00005    C     SUBROUTINE FOR EXTENSION OF HIT LABEL ARRAY IN /BCS/
 00006    C     PETER STEFFEN   6/ 9/79
 00007    C
 00008   3      IMPLICIT INTEGER*2 (H)
 00009   4      LOGICAL TBIT
 00010    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 --------------------------
 00012    C
 00013    C2007 FORMAT(1H ,12X,2I6,10(4X,Z4))
 00014    C2008 FORMAT(' HIT LABEL OF TRELS:',4I6,/,(12X,20(2X,Z4)))
 00015    C
 00017   9      IERR = 0                                                           INITIALIZE ERROR FLAG
 00018  10      IPJHTL = IDATA(IBLN('JHTL'))
 00019  11      IPJETC = IDATA(IBLN('JETC'))
 00020  12      IF(IPJETC.LE.0) RETURN
 00021  14      IF(IPJHTL.LE.0) RETURN
 00023  16      NHIT  = (HDATA(IPJETC*2+99)) / 4                                   # OF HITS
 00024    C
 00026  17      REPEAT                                                             LOOP OVER ALL EXISTING 'JHTL'-BANKS
 00027  18         NWHTL = IDATA(IPJHTL)
 00028    C
 00030  19         I0 = IPJHTL*2 + 1                                               PRINTOUT
 00031  20         I9 = IDATA(IPJHTL)*2 + I0 - 1
 00032    C       PRINT 2008, NHIT,NWHTL,I0,I9,(HDATA(I1),I1=I0,I9)
 00033    C
 00035  21         IF(NWHTL.GE.NHIT) RETURN                                        'JHTL' ALREADY IN NEW FORMAT ?
 00036    C
 00038  23         NWDIFF = NHIT+1 - NWHTL                                         EXTEND LENGTH
 00039  24         CALL BCHM(IPJHTL,NWDIFF,IERR)
 00040  25         IF(IERR.NE.0) RETURN
 00041    C
 00043  27         IP0 =  IPJHTL*2+2                                               REFORMAT 'JHTL'
 00044  28         IP1 =  IP0 + NHIT
 00045  29         IP2 =  IP0 + NHIT*2
 00046  30         REPEAT
 00047  31            LBHIT = HDATA(IP1)
 00048  32            IF LBHIT.EQ.0
 00049  33            THEN
 00050  36               HDATA(IP2-1) = 0
 00051  37               HDATA(IP2  ) = 0
 00052  38            ELSE
 00053  40               LBZ   = LAND (LBHIT, 1)
 00054  41               LBB12 = SHFTR(LBHIT,13)
 00055  42               LBB12 = SHFTL(LBB12, 9)
 00056  43               LBHT1 = LAND (LBHIT,63)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 00057  44               LBHT1 = LOR  (LBHT1,LBB12)
 00058  45               IF(TBIT(LBHIT,25)) LBHT1 = BITON(LBHT1,23)
 00059  47               LBHT2 = SHFTR(LBHIT, 6)
 00060  48               LBHT2 = LAND (LBHT2,62)
 00061  49               IF LBHT2.NE.0
 00062  50               THEN
 00063  53                  LBHT2 = LOR  (LBHT2,LBZ)
 00064  54                  LBHT2 = LOR  (LBHT2,LBB12)
 00065  55                  IF(TBIT(LBHIT,19)) LBHT2 = BITON(LBHT2,23)
 00066  57               CIF
 00067  58               HDATA(IP2-1) = LBHT1
 00068  59               HDATA(IP2  ) = LBHT2
 00069  60            CIF
 00070  61            DATA NPR /0/
 00071  62            NPR = NPR + 1
 00072    C       IF(LBB12.NE.0) PRINT 2007, IP1,IP2,LBHIT,LBZ,LBB12,LBHT1,LBHT2
 00073  63            IP2 = IP2 - 2
 00074  64            IP1 = IP1 - 1
 00075  65         UNTIL IP1.LE.IP0
 00076    C
 00078  66         I0 = IPJHTL*2 + 1                                               PRINTOUT
 00079  70         I9 = IDATA(IPJHTL)*2 + I0 - 1
 00080    C       PRINT 2008, NHIT,NWHTL,I0,I9,(HDATA(I1),I1=I0,I9)
 00081    C
 00082  71         IPJHTL = IDATA(IPJHTL-1)
 00083  72      UNTIL IPJHTL.LE.0
 00084    C
 00085  73      RETURN
 00086    C
 00087  77      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          76 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          76 TARGET STATEMENTS
 00000    C   19/08/82 601231124  MEMBER NAME  FITEVF   (JADEGS)      SHELTRAN
 00100   2      SUBROUTINE FITEVF(MODE)
 00200    C---
 00300    C---     GENERAL REFIT OF ALL TRACKS IN R-PHI
 00400    C---     INPUT :
 00500    C---     MODE   = 0 : OVERWRITE OLD PATR-BANK WITH NEW RESULTS
 00600    C---     MODE   = 1 : CREATE NEW PATR-BANK WITH NEW RESULTS
 00700    C---                                           P. STEFFEN 82/08/19
 00800    C---
 00900   3      IMPLICIT INTEGER*2 (H)
 01000    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 --------------------------
 01200    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         8      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)
         9      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        10      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        11      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        12      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        13      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        14      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  15      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 ------------------
 01500    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 01600  16      EQUIVALENCE
 01700         ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
 01800         ,         ,(HPZR0 ,HPWRK(20)),(HPZR9 ,HPWRK(21)),(HLDZR ,HPWRK(22))
 01900         ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
 02000         ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
 02100    C
 02200    C2000 FORMAT('0CALL FITEVF(',2I6,1X,I4,' )')
 02300    C2001 FORMAT(1H0,2I3,I8,2(I4,3F6.1,3F6.3),
 02400    C    ,     /,14X,I3,4E13.5,F6.2,I3,4E13.5,
 02500    C    ,     /,14X,I3,2F8.3,F6.1,I3,10X,6I3,8I6,2X,Z4)
 02600    C2003 FORMAT(' FRFITO RESULT:',F6.0,F6.3,F6.0,F6.3)
 02700    C
 02800    C
 03000  17      DATA LBINIT /0/                                                    INITIALIZE POINTER
 03100  18      IF LBINIT.EQ.0
 03200  19      THEN
 03300  22         LBINIT = 1
 03400  23         IQPATR = IBLN('PATR')
 03500  24         IQJHTL = IBLN('JHTL')
 03600  25      CIF
 03700    C
 03800    C
 04000  26      IF(IDATA(IQPATR).LE.0) RETURN                                      CHECK IF PATR-BANK
 04100    C
 04300  28      IF LAND(MODE,1) .NE. 0                                             CREATE NEW PATR BANK FOR MODE=1
 04400  29      THEN
 04500  32         IPPAT0 = IDATA(IQPATR)
 04600  33         NBNK1  = IDATA(IPPAT0-2) - 1
 04700  34         NWRD   = IDATA(IPPAT0)
 04800  35         NBYTE  = NWRD*4
 04900  36         CALL CCRE(IPPATR,'PATR',NBNK1,NWRD,IERR)
 05000  37         IF IERR.NE.0
 05100  38         THEN
 05200    C           PRINT 2900, IERR
 05300  41 2900 FORMAT(' FITEVF(PS): CREATION OF NEW PATR-BANK RESULTED',
 05400         ,      ' IN ERROR',I3)
 05500  42            INDEX = 1
 05600  43            RETURN
 05700  44         CIF
 05800    C
 06000  45         CALL MVCL(IDATA(IPPATR+1),0,IDATA(IPPAT0+1),0,NBYTE)            COPY CONTENTS OF 'PATR'-BANK
 06100    C
 06200  46      CIF
 06300    C
 06400  47      IPPATR = IDATA(IQPATR)
 06500  48      IPTR1  = IDATA(IPPATR+1) + IPPATR
 06600  49      LDTR   = IDATA(IPPATR+3)
 06700  50      NTR    = IDATA(IPPATR+2)
 06800  51      IPJHTL = IDATA(IQJHTL)
 06900    C     PRINT 2000,IPPATR,IPJHTL,MODE
 07000    C     CALL PRPATR
 07100  52      IF NTR.GT.0
 07200  53      THEN
 07300    C
 07400  56         FOR ITR=1,NTR
 07500    C
 07700  57            IF ABS(ADATA(IPTR1+25)) .LT. .007                            CHECK IF PT > 20 MEV
 07800  58            THEN
 07900    C
 08100  61               CALL REFIT(IPTR1,IPJHTL)                                  REFIT TRACK WITH VERTEX CONSTRAINT
 08200    C           I0 = HPTR0
 08300    C           I9 = I0 + 47
 08400    C           PRINT 2001, (WRK(I1),I1=I0,I9)
 08500    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 08700  62               IP    = HPTR0 - 1                                         REPLACE BANK IF GOOD RESULT
 08800  63               IF LAND(IWRK(IP+ 2),16).EQ.0
 08900  64               THEN
 09000  67                  SIG   = 1000.
 09100  68                  SIG0  =    0.
 09200  69               ELSE
 09300  71                  SIG   =  WRK(IP+23)
 09400  72                  SIG0  = ADATA(IPTR1+23)
 09500  73                  ANHT  = IWRK(IP+24)
 09600  74                  ANHT0 = IDATA(IPTR1+24)
 09700    C             PRINT 2003, ANHT,SIG,ANHT0,SIG0
 09800  75                  IF(ANHT/ANHT0.LT..8) SIG = SIG + .5
 09900  77               CIF
 10000  78               IF SIG0.GT.SIG .OR. SIG.LT..35
 10100  79               THEN
 10200    C
 10300  82                  CALL MVC(IDATA(IPTR1+1),0,IWRK(HPTR0),0,112)
 10400    C
 10500  83               CIF
 10600  84            CIF
 10700  85            IPTR1 = IPTR1 + LDTR
 10800  86         CFOR
 10900    C
 11000  88      CIF
 11100  89      RETURN
 11200    C
 11300  90      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          89 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          89 TARGET STATEMENTS
 00010    C   13/08/82 601231126  MEMBER NAME  FITEVR   (JADEGS)      SHELTRAN
 00011    C
 00012    C-----------------------------------------------------------------------
 00020   2      SUBROUTINE FITEVR( NTRVTX, MODE )
 00021    C-----------------------------------------------------------------------
 00030    C
 00040    C        FIT TRACKS WITH CONSTRAINT TO RUN VERTEX
 00050    C                   AND COMMON Z-VERTEX (MODE + 2)
 00060    C        INPUT :
 00070    C        MODE   = 0 : OVERWRITE OLD PATR-BANK WITH NEW RESULTS
 00080    C        MODE   = 1 : CREATE NEW PATR-BANK WITH NEW RESULTS
 00090    C        MODE   + 2 : DO ALSO COMMON Z-FIT
 00100    C        MODE   + 4 : VERTEX WEAKLY CONSTRAINED (ERRFAC = 100.0)
 00110    C        MODE   + 8 : RERUN PATREC IN CASE OF BAD JHTL-BANK
 00120    C        MODE   +16 : NO VERTEX CONSTRAINT (ERRFAC = 1000.0 )
 00130    C        OUTPUT:
 00140    C        NTRVTX = NUMBER OF TRACKS FROM EVENT VERTEX
 00150    C
 00151    C-----------------------------------------------------------------------
 00152    C
 00160   3      IMPLICIT INTEGER*2 (H)
 00170    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 --------------------------
 00190    C
 00200    C
          C----------------------------------------------------------------------
          C            MACRO CALIBR .... JADE CALIBRATION DATA COMMON
          C----------------------------------------------------------------------
         8      COMMON/CALIBR/ ACALIB(1000)
         9      DIMENSION HCALIB(100),ICALIB(100)
 02600  10      EQUIVALENCE(ACALIB(1),HCALIB(1),ICALIB(1))
          C------------------------ END OF MACRO CALIBR -------------------------
 00220    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))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
        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
 00900         #         ,(HPHTLM,HPWRK(13))
 00910    C               POINTERS FOR
 01000         #         ,(HPTE0,HPWRK(14)),(HPTE9,HPWRK(15)),(HLDTE,HPWRK(16))
 01100    C-------------- END OF MACRO CWORKEQ ------------------
 00250    C
 00260  19      EQUIVALENCE
 00270         ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
 00280         ,         ,(HPZR0 ,HPWRK(20)),(HPZR9 ,HPWRK(21)),(HLDZR ,HPWRK(22))
 00290         ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
 00300         ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
 00310    C
 00320  20      DATA LBINIT /0/
 00330  21      DATA NPRMES /0/
 00340    C
 00360  22      IF LBINIT .LE.0                                                    INITIALIZATION
 00370  23      THEN
 00380    C
 00390  26         LBINIT = 1
 00400  27         IQHEAD = IBLN('HEAD')
 00410  28         IQPATR = IBLN('PATR')
 00420  29         IQJHTL = IBLN('JHTL')
 00430  30         IQZVTX = IBLN('ZVTX')
 00440    C
 00450  31      CIF
 00460    C
 00480  32      NITER = 0                                                          IF MODE=8, ITERATE WITH NEW PATREC
 00490  33      REPEAT
 00500  34         NITER = NITER + 1
 00510    C
 00520    C
 00530    C
 00550  35         NTRVTX = 0                                                      INITIALIZE NTRVTX
 00560    C
 00580  36         IF(IDATA(IQPATR).LE.0) RETURN                                   CHECK IF PATR-BANK
 00590    C
 00600    C
 00620  38         IF LAND(MODE,1) .NE. 0                                          CREATE NEW PATR BANK
 00630  39         THEN
 00640  42            IPPAT0 = IDATA(IQPATR)
 00650  43            NBNK1  = IDATA(IPPAT0-2) - 1
 00660  44            NWRD   = IDATA(IPPAT0)
 00670  45            NBYTE  = NWRD*4
 00680  46            CALL CCRE(IPPATR,'PATR',NBNK1,NWRD,IERR)
 00690  47            IF IERR.NE.0
 00700  48            THEN
 00710  51               PRINT 2900, IERR
 00720  52 2900   FORMAT(' USFITO3(PS): CREATION OF NEW PATR-BANK RESULTED',
 00730         ,         ' IN ERROR',I3)
 00740  53               INDEX = 1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 00750  54               RETURN
 00760  55            CIF
 00770    C
 00790  56            CALL MVCL(IDATA(IPPATR+1),0,IDATA(IPPAT0+1),0,NBYTE)         COPY CONTENTS OF 'PATR'-BANK
 00800    C
 00810  57         CIF
 00820    C
 00830  58         IPPATR = IDATA(IQPATR)
 00840  59         IPTR1  = IDATA(IPPATR+1) + IPPATR
 00850  60         LDTR   = IDATA(IPPATR+3)
 00860  61         NTR    = IDATA(IPPATR+2)
 00870    C
 00890  62         IF(NTR.LT.1) RETURN                                             CHECK IF 1 TRACK
 00900    C
 00920  64         MTRV = 0                                                        SEARCH FOR TRACKS FROM MAIN VERTEX
 00930    C
 00950  65         IPV  = ICALIB(10)                                               RUN VERTEX
 00960  66         X0   = ACALIB(IPV+ 1)
 00970  67         Y0   = ACALIB(IPV+ 3)
 00980    C
 00990  68         FOR ITR=1,NTR
 01000    C
 01020  69            IF ABS(ADATA(IPTR1+25)).LT..00143 .AND.IDATA(IPTR1+24).GT.16 CHECK IF MOMENTUM >100 MEV
 01030  70            THEN
 01040    C
 01060  73               CALL DRTRCK(IPTR1,X0,Y0,DR0)                              MARK + COUNT TRACKS FROM MAIN VERTEX
 01070  74               IF ABS(DR0).LT.25. .OR. IDATA(IPTR1+4).EQ.1
 01080  75               THEN
 01090  78                  MTRV = MTRV + 1
 01100  79                  IDATA(IPTR1+4) =-1
 01110  80               CIF
 01120  81            CIF
 01130  82            IPTR1 = IPTR1 + LDTR
 01140  83         CFOR
 01150    C
 01170  85         IF(MTRV.LE.0) XREPEAT                                           PERFORM SUPERFIT IF >1 TRACK
 01180  87         Z0 = 0.
 01190  88         IPZVTX = IDATA(IQZVTX)
 01200  89         IF(IPZVTX.GT.0.AND.IDATA(IPZVTX+6).EQ.3) Z0=ADATA(IPZVTX+1)
 01210  91         ERRFAC = 1.0
 01220  92         IF(LAND(MODE,4)  .NE. 0) ERRFAC =  100.0
 01230  94         IF(LAND(MODE,16) .NE. 0) ERRFAC = 1000.0
 01240  96         MODEF = MODE
 01250  97         CALL FZFITV(IPPATR,IDATA(IQJHTL),NTRVTX,Z0,ERRFAC,MODEF)
 01260    C     DATA NPRPAT/0/
 01270    C     NPRPAT = NPRPAT + 1
 01280    C     IF(NPRPAT.LE.2) CALL PRPATR
 01290    C
 01300    C
 01320  98         IF(MODEF       .GE.0) XREPEAT                                   STOP IF NO BAD TRACK
 01340 100         IPHEAD = IDATA(IQHEAD) * 2                                      ERROR IN JHTL-BANK, CHECK IF ITER. WITH NEW PATREC
 01350 101         NPRMES = NPRMES + 1
 01360 102         IF(NPRMES.LE.10)
 01370         ,   PRINT 2009, HDATA(IPHEAD+10),HDATA(IPHEAD+11),MODEF
 01380 104 2009 FORMAT(' FITEVR(PST): ERROR IN JHTL-BANK FOR EVENT',3I6)
 01390 105         IF(LAND(MODE,8).EQ.0) XREPEAT
 01410 107         IF(NITER       .GE.2) XREPEAT                                   STOP AFTER 1. ITERATION
 01420    C
 01440 109         IF LAND(MODE,1).NE.0                                            DELETE NEW CREATED PATR-BANK
 01450 110         THEN
 01460 113            IPPATR = IDATA(IQPATR)
 01470 114            NBNK   = IDATA(IPPATR-2)
 01480 115            CALL BDLS('PATR',NBNK)
 01490 116         CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 01500    C
 01520 117         IPPATR = IDATA(IQPATR)                                          DELETE OLD PATR-BANK + JHTL-BANK
 01530 118         NBNK   = IDATA(IPPATR-2)
 01540 119         CALL BDLS('PATR',NBNK)
 01550 120         IPJHTL = IDATA(IQPATR)
 01560 121         CALL BDLS('JHTL',NBNK)
 01570    C
 01590 122         IND = 1                                                         REPEAT PATREC
 01600 123         CALL PATRCO(IND)
 01610    C
 01620 124      UNTIL NITER .GE.2
 01630    C
 01640 125      RETURN
 01650    C
 16200 129      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         128 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         128 TARGET STATEMENTS
 00000    C   16/08/82 608111933  MEMBER NAME  FRFITV   (JADEGS)      SHELTRAN
 00100    C   18/02/81 208111542  MEMBER NAME  REFITV   (JETCALSR)    SHELTRAN
 00200   2      SUBROUTINE FRFITV(IPTR,IPJHTL,ERRFAC)
 00300    C
 00400    C        REFIT TRACK ITRK IN 'PATR'-BANK USING ORIGIN
 00500    C                   ONLY INTERMEDIATE VALUES STORED
 00600    C                   FOR POSITION + DIRECTION AT 1. AND LAST HIT
 00700    C                   THIS ROUTINE IS ONLY USED WITH SUBSEQUENT ZRFIT
 00800    C                   USE REFITV IF ONLY R-PHI-FIT WANTED
 00900    C        P. STEFFEN                    22/08/80
 00910    C  CHANGED 11.8.86  = 32  IS REPLACED WITH OR(, 32)    J.OLSSON
 01000    C
 01100   3      IMPLICIT INTEGER*2 (H)
 01200   4      LOGICAL DEADCL
 01300    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 --------------------------
 01500    C
          C-----------------------------------------------------------------------
          C                            MACRO CGEO1 .... JADE GEOMETRY
          C-----------------------------------------------------------------------
          C
         9      COMMON / CGEO1 / BKGAUS,
               +                 RPIP,DRPIP,XRLPIP,   RBPC,DRBPC,XRLBPC,
               +                 RITNK,DRITNK,XRLTKI, R0ROH,DR0ROH,XR0ROH,
               +                 R1ROH,DR1ROH,XR1ROH, R2ROH,DR2ROH,XR2ROH,
               +                 R3ROH,DR3ROH,XR3ROH, ROTNK,DROTNK,XRLTKO,
               +                 RTOF,DRTOF,XRTOF,    RCOIL,DRCOIL,XRCOIL,
               +                 ZJM,DZJM,XRZJM,ZJP,DZJP,XRZJP,ZTKM,DZTKM,XRZTKM,
               +                 ZTKP,DZTKP,XRZTKP,ZBPPL,ZBPMI,ZTOFPL,ZTOFMI,
               +                 XRJETC,RLG,ZLGPL,ZLGMI,OUTR2,CTLIMP,
               +                 CTLIMM,DELFI,BLXY,BLZ,BLDEP,ZENDPL,ZENDMI,DEPEND,
               +                 XHOL1,XHOL2,YHOL1,YHOL2,BLFI
          C
          C------------------------- END OF MACRO CGEO1 --------------------------
          C
 01700    C
          C----------------------------------------------------------------------
          C            MACRO CALIBR .... JADE CALIBRATION DATA COMMON
          C----------------------------------------------------------------------
        10      COMMON/CALIBR/ ACALIB(1000)
        11      DIMENSION HCALIB(100),ICALIB(100)
 02600  12      EQUIVALENCE(ACALIB(1),HCALIB(1),ICALIB(1))
          C------------------------ END OF MACRO CALIBR -------------------------
 01900    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        13      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
               ,               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)
        14      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        15      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        16      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        17      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        18      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        19      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  20      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 ------------------
 02200    C
 02300  21      EQUIVALENCE
 02400         ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
 02500         ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
 02600         ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
 02700    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        22      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        23      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        24      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        25      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        26      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 --------------
 02900    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  27      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  <----
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 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----------------------------------------------------------------------
        28      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 -------------------------
 03200    C
 03300  29      INTEGER DATE(5), IDAY /0/
 03400  30      DIMENSION  NHTRNG(3)
 03500    C
 03700  31      DATA RESJ0 /.200/, RESV0 /.300/                                    JET-CHAMBER AND VERTEX RESOLUTION
 03800    C
 04000  32      INTEGER MKLRT1 /Z1000000/, MKLRT2 /Z100/                           MASK FOR L/R BIT IN HIT LABEL
 04100    C
 04300  33      INTEGER MKBDCL(3) /Z10,Z20,Z40/                                    MASK FOR TRACKS AT CELL WALL
 04400  34      INTEGER MKDDCL(3) /Z01,Z02,Z04/
 04500    C
 04600    C     IF(IDATA(IPTR+1).LT. 4) RETURN
 04700    C     I0 = IPTR + 1
 04800    C     I9 = IPTR + 48
 04900    C     PRINT 2001, (IDATA(I1),I1=I0,I9)
 05000    C     I0 = IPJHTL*2 + 1
 05100    C     I9 = I0 + IDATA(IPJHTL)*2 - 1
 05200    C     PRINT 2000, IPJHTL,I0,I9,(HDATA(I1),I1=I0,I9)
 05300    C     IPJETC = IDATA(IBLN('JETC'))
 05400    C     I0 = IPJETC*2 + 1
 05500    C     I9 = I0 + 109
 05600    C     PRINT 2000, IPJETC,I0,I9,(HDATA(I1),I1=I0,I9)
 05700    C2000 FORMAT('0REFIT:',3I8,/,(20(1X,Z4)))
 05800    C2001 FORMAT(1H0,2I3,I8,2(I4,3F6.1,3F6.3),
 05900    C    ,     /,14X,I3,4E13.5,F6.2,I3,4E13.5,
 06000    C    ,     /,14X,I3,2F8.3,F6.1,I3,10X,6I3,8I6,2X,Z4)
 06100    C2002 FORMAT('0FETCH:',2I3,2I5,12F9.5)
 06200    C2003 FORMAT('0ROTATION:',12F10.5)
 06300    C2004 FORMAT('0CIRC.CENTRE:',2I3, F10.5,2F10.0,F8.1,2F8.1)
 06400    C2005 FORMAT('0TRACK:',I6,/,(1X,3I6,4F8.3,I4,F8.3,2I4,F8.3,I6,F8.2))
 06500    C2006 FORMAT(1X,I6,5F8.3,F12.1,5F8.3)
 06600    C2007 FORMAT(' FETCH:',I3,9F8.4,F10.5,F6.0)
 06700    C2008 FORMAT(' FIT:',2I3,2F8.3,F5.0,3E12.5,F6.3,F6.3)
 06800    C2009 FORMAT(' JHTL:',I8,1X,Z8,3I5)
 06900    C2010 FORMAT(' HIT:',I6,12F8.2)
 07000    C2011 FORMAT('0ABERR:',10F10.6)
 07100    C2012 FORMAT('0ERROR:',10E13.6)
 07200    C2014 FORMAT('0FIT-BANK:',5F8.3,5X,5F8.3,5X,F8.5,2F8.1)
 07300    C2016 FORMAT('0ITRCLL =',6I8,/,(9X,6F8.3))
 07400    C2107 FORMAT(' SIGLM:',10F8.3)
 07500    C
 07700  35      DATA LBINIT /0/                                                    INITIALIZATION
 07800  36      IF LBINIT .EQ. 0
 07900  37      THEN
 08000  40         LBINIT = 1
 08100  41         PERFORM INIT
 08200  44      CIF
 08300    C
 08400    C
 08600  45      IPHEAD = IDATA(IQHEAD)*2                                           GET RUN #
 08700  46      NRUN = HDATA(IPHEAD+10)
 08800  47      NEV  = HDATA(IPHEAD+11)
 08900    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 09100  48      ITRK = IDATA(IPTR+1)                                               TRACK #
 09200    C
 09300    C
 09500  49      HPFREE = 1                                                         RESERVE SPACE IN CWORK
 09600  50      HPFRE1 = HPFREE
 09700    C
 09900  51      IPV    = ICALIB(10)                                                GET X-Y-VERTEX AND DETERMINE ERROR
 10000  52      XO     = ACALIB(IPV+ 1)
 10100  53      YO     = ACALIB(IPV+ 3)
 10200    C     I0 = IPV + 1
 10300    C     I9 = IPV + 6
 10400    C     PRINT 2029, XO,YO,(ACALIB(I1),I1=I0,I9)
 10500  54      PTRANS = ABS(0.0299792458*BKGAUS/ADATA(IPTR+25)) * .001
 10600  55      RESV   = RESV0**2 + RESMS / PTRANS**2
 10700  56      WGHT0  = RESJ0**2 / RESV
 10800  57      F1     = ERRFAC
 10900  58      IF(F1 .LT. .10) F1 = .10
 11000  60      WGHT0  = WGHT0 / F1**2
 11100    C     PRINT 2029, XO,YO,WGHT0,F1,RESV,RESMS,PTRANS
 11200    C2029 FORMAT(' VERTEX',9E13.5)
 11300    C     PRINT 2011,ABERR
 11400    C
 11500    C
 11600                                                                             FETCH HITS, CALCULATE COORDINATES, AND
 11800  61      HPCO0  = HPFREE                                                    FILL ARRAY IN /CWORK/
 11900  62      LHIT   = 14
 12000  63      INDFET = 3
 12100  64      CALL JFETCH(IPTR,IPJHTL,WRK(HPCO0),LHIT,IPRES,INDFET,XO,YO)
 12200    C
 12300    C
 12400  65      HLDCO  = LHIT
 12500  66      HPCO9  = IPRES - 1
 12600  67      HPAR0  = IPRES
 12700  68      HLDPA  = 20
 12800  69      HPAR9  = HPAR0 + HLDPA - 1
 12900  70      HPFREE = HPAR9 + 1
 13000  71      XT     = WRK (IPRES   )
 13100  72      YT     = WRK (IPRES+ 1)
 13200  73      CSROT  = WRK (IPRES+ 2)
 13300  74      SNROT  = WRK (IPRES+ 3)
 13400  75      X0     = WRK (IPRES+ 9)
 13500  76      Y0     = WRK (IPRES+10)
 13600  77      XOR    =- XT*CSROT -  YT*SNROT
 13700  78      YOR    =  XT*SNROT -  YT*CSROT
 13800    C     PRINT 2003, CSROT,SNROT,XX,YY,XT,YT,X0,Y0,XO,YO,XOR,YOR,WGHT0
 13900    C
 14100  79      WRK(HPAR0+ 4) = 0.                                                 INITIALIZE FIT PARAMETERS IN CWORK
 14200  80      WRK(HPAR0+ 5) = 0.
 14300  81      WRK(HPAR0+ 6) = 0.
 14400  82      WRK(HPAR0+ 7) = 1000.
 14500  83      WRK(HPAR0+ 8) = 0.
 14600  84      CSTH   = WRK (IPRES+11)
 14700  85      SNTH   = WRK (IPRES+12)
 14800    C     PRINT 2007, HPCO0,HPCO9,HDLCO,HPFREE,(WRK(I1),I1=HPAR0,HPAR9)
 14900    C
 15000    C
 15200  86      HPTR0 = HPFREE                                                     COPY TRACK BANK
 15300  87      CALL MVC(IWRK(HPTR0),0,IDATA(IPTR+1),0,192)
 15400  88      IWRK(HPTR0+ 1) = 0
 15500  89      HPFREE = HPFREE + 48
 15600  90      IWRK(HPTR0+1) = 0
 15700    C
 15800    C       PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 15900    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 16000    C
 16100                                                                             1. PARABOLA FIT
 16300  91      JRINGL = 3                                                         LAST RING INCLUDED IN FIT
 16400  92      PERFORM FPARA0
 16500    C
 16700  95      ALBLM1 = 0.6                                                       RELABEL HITS
 16800  96      ALBLM2 = 3.0
 16900  97      PERFORM LABEL
 16910 100      WHILE NHGOOD.LT.8 .AND. NHFIT-NHGOOD.GT.8
 16920 102         ALBLM1 = ALBLM1 + 1.0
 16930 106         ALBLM2 = ALBLM2 + 1.0
 16940 107         PERFORM LABEL
 16950 110      CWHILE
 16960 112      ALBLM1 = 0.6
 16970 113      ALBLM2 = 3.0
 17000    C     PRINT 2005, NHFIT,(WRK(I),I=HPCO0,HPCO9)
 17100    C
 17200
 17300 114      REPEAT
 17500 115         PERFORM FPARA0                                                  REFIT PARABOLA
 17600    C
 17800 118         PERFORM LABEL                                                   RELABEL HITS
 17900    C
 18100 121      UNTIL NHGOOD-NHFIT .LT.4                                           REPEAT FIT IF >3 NEW GOOD HITS
 18200    C
 18300    C     PRINT 2005, NHGOOD,(WRK(I),I=HPCO0,HPCO9)
 18400    C
 18600 122      LBADFT = 0                                                         SET UP FIT-BANK
 18700 126      IF(IDATA(IPTR+24)-NHGOOD   .GT. 8) LBADFT = 1
 18800 128      IF(IDATA(IPTR+24) .GT. 1.3*NHGOOD) LBADFT = 1
 18900 130      IF SIG.LT.1. .AND. LBADFT .EQ.0
 19000 131      THEN
 19100 134         PERFORM FITBNK
 19200 137      CIF
 19300    C
 19500 138      IF ABS(PAR1).GT..00030 .AND. NHTRNG(1)+NHTRNG(2).GT.16             CHECK IF BAD FIT AND LOW MOMENTUM
 19600 139      THEN
 19700 142         ALBLM1 = 1.5
 19800 143         ALBLM2 = 3.0
 19900 144         PERFORM LABEL
 20000 147         JRINGL = 2
 20100 148         PERFORM FPARA0
 20200 151         ALBLM1 = 0.6
 20300 152         PERFORM LABEL
 20400 155         PERFORM FPARA0
 20500 158         PERFORM LABEL
 20600 161         LBADFT = 0
 20700 162         IF(IDATA(IPTR+24)-NHGOOD        .GT.   8) LBADFT = 1
 20800 164         IF(IDATA(IPTR+24)/FLOAT(NHGOOD) .GT. 1.3) LBADFT = 1
 20900 166         IF SIG.LT..10 .AND. LBADFT .EQ.0
 21000 167         THEN
 21100 170            PERFORM FITBK1
 21200 173            IWRK(IP+ 4) = 32
 21300 174         CIF
 21400 175      CIF
 21500 176      IF ABS(PAR1).GT..00150 .AND. NHTRNG(1)+NHTRNG(2).GT.9
 21600 177      THEN
 21700 180         ALBLM1 = 1.5
 21800 181         ALBLM2 = 3.0
 21900 182         PERFORM LABEL
 22000 185         JRINGL = 1
 22100 186         NHTFIT = NHTRNG(1)
 22200 187         IF NHTFIT.LE.5
 22300 188         THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 22400 191            NHTFIT = NHTFIT + NHTRNG(2)
 22500 192            JRINGL = 2
 22600 193         CIF
 22700 194         IF NHTFIT.GT.9
 22800 195         THEN
 22900 198            PERFORM FPARA0
 23000 201            ALBLM1 = 0.6
 23100 202            PERFORM LABEL
 23200 205            PERFORM FPARA0
 23300 208            PERFORM LABEL
 23400 211            LBADFT = 0
 23500 212            IF(IDATA(IPTR+24)-NHGOOD        .GT.   8) LBADFT = 1
 23600 214            IF(IDATA(IPTR+24)/FLOAT(NHGOOD) .GT. 1.3) LBADFT = 1
 23700 216            IF SIG.LT..10 .AND. LBADFT .EQ.0
 23800 217            THEN
 23900 220               PERFORM FITBK1
 24000 223               IWRK(IP+ 4) = 48
 24100 224            CIF
 24200 225         CIF
 24300 226      CIF
 24400    C
 24500    C     PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 24600 227      HPFREE = HPFRE1
 24700 228      RETURN
 24800    C
 24900                                                                             *************************
 25000                                                                             *      F P A R A 0      *
 25200    C                                                                        *************************
 25300    C
 25500 229      PROC FPARA0                                                        PARABOLA FIT THROUG ORIGIN
 25600    C
 25700                                                                             GET EQUATIONS
 25900 230         S0 = WGHT0                                                      WEIGHT ORIGIN AS POINT OF PARABOLA
 26000 231         S1 = X0*WGHT0
 26100 232         S2 = S1*X0
 26200 233         S3 = S2*X0
 26300 234         S4 = S3*X0
 26400 235         S7 = Y0 * WGHT0
 26500 236         S6 = S7*X0
 26600 237         S5 = S6*X0
 26700 238         IPCO = HPCO0
 26800 239         REPEAT
 26900 240            IF IWRK(IPCO+ 10).EQ.0 .AND. IWRK(IPCO+12).LE.JRINGL
 27000 241            THEN
 27100 244               X = WRK(IPCO+3)
 27200 245               Y = WRK(IPCO+4)
 27300 246               X2 = X**2
 27400 247               S1 = S1 + X
 27500 248               S2 = S2 + X2
 27600 249               S3 = S3 + X*X2
 27700 250               S4 = S4 + X2**2
 27800 251               S5 = S5 + Y*X2
 27900 252               S6 = S6 + Y*X
 28000 253               S7 = S7 + Y
 28100 254               S0 = S0 + 1.
 28200 255            CIF
 28300 256            IPCO = IPCO + HLDCO
 28400 257         UNTIL IPCO.GT.HPCO9
 28500 258         IF S0.LT.2.5
 28600 262         THEN
 28700 265            SIG = 1000.
 28800 266         ELSE
 28900    C
 29100 268            F1 = 1. / S4                                                 SOLVE EQUATIONS FOR PARABOLA FIT
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 29200 269            XX12 = S3*F1
 29300 270            XX13 = S2*F1
 29400 271            YY1  = S5*F1
 29500 272            XX22 = S2 - S3*XX12
 29600 273            XX23 = S1 - S3*XX13
 29700 274            YY2  = S6 - S3*YY1
 29800 275            XX32 = S1 - S2*XX12
 29900 276            XX33 = S0 - S2*XX13
 30000 277            YY3  = S7 - S2*YY1
 30100 278            IF XX22.GT.XX32
 30200 279            THEN
 30300 282               XX23 = XX23 / XX22
 30400 283               YY2  = YY2  / XX22
 30500 284               PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 30600 285               PAR2 = YY2 - XX23*PAR3
 30700 286            ELSE
 30800 288               XX33 = XX33 / XX32
 30900 289               YY3  = YY3  / XX32
 31000 290               PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 31100 291               PAR2 = YY3 - XX33*PAR3
 31200 292            CIF
 31300 293            PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
 31400 294            DEG   = S0 - WGHT0 - 2.
 31500 295            NHFIT = S0 - WGHT0 + .1
 31600    C
 31700    C
 31900 296            CHISQ = 0.                                                   CALC. CHISQ + SOLVE L/R AMBIGUITY
 32000 297            DCHIM1 = 0.
 32100 298            IHITM1 = 0
 32200 299            XST    = 999999.
 32300 300            XEN    =-999999.
 32400 301            IPCO = HPCO0
 32500 302            REPEAT
 32600 303               IF IWRK(IPCO+ 10).EQ.0 .AND. IWRK(IPCO+12).LE.JRINGL
 32700 304               THEN
 32800 307                  X = WRK(IPCO+3)
 32900 308                  IF(X.LT.XST) XST = X
 33000 310                  IF(X.GT.XEN) XEN = X
 33100 312                  Y = WRK(IPCO+4)
 33200 313                  F = (PAR1 *X + PAR2 )*X + PAR3
 33300 314                  DCHI = Y - F
 33400 315                  WRK(IPCO+13) = DCHI
 33600 316                  CHISQ = CHISQ + DCHI**2                                SUM FOR RMS
 33800    C           IF ABS(DCHI).GE.DCHIM1                                       KEEP BIGGEST RMS
 33900    C           THEN
 34000    C             DCHIM1 = ABS(DCHI)
 34100    C             IHITM1 = IPCO
 34200    C           CIF
 34300    C     PRINT 2006, IPCO,X,Y,F,DCHI,CHISQ
 34400 317               CIF
 34500 318               IPCO = IPCO + HLDCO
 34600 319            UNTIL IPCO.GT.HPCO9
 34700 320            SIG    =      CHISQ  / DEG
 34800    C     PRINT 2008, ITRK,NHFIT,XST,SIG,DEG,PAR1,PAR2,PAR3,WGHT0,Y0
 34900    C
 35100 324            SIGLM = TRELLM(16)**2                                        SET LIMIT FOR SIGMA
 35200 325         CIF
 35300    C
 35400 326      CPROC
 35500    C
 35600                                                                             *************************
 35700                                                                             *      F I T B N K      *
 35900    C                                                                        *************************
 36000    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 36200 328      PROC FITBNK                                                        SET UP FIT-BANK
 36300    C
 36500 329         YST  = (PAR1 *XST + PAR2 )*XST + PAR3                           START + END POINTS
 36600 330         YEN  = (PAR1 *XEN + PAR2 )*XEN + PAR3
 36800 331         TGST = PAR1*XST*2 + PAR2                                        DIRECTION AT START + END POINT
 36900 332         DXST = 1./SQRT(TGST**2+1.)
 37000 333         DYST = DXST * TGST
 37100 334         TGEN = PAR1*XEN*2 + PAR2
 37200 335         DXEN = 1./SQRT(TGEN**2+1.)
 37300 336         DYEN = DXEN * TGEN
 37500 337         XMIN = -PAR2*.5 / PAR1                                          MIN. OF PARABOLA
 37600 338         YMIN = (PAR1*XMIN + PAR2)*XMIN + PAR3
 37700    C
 37900    C     CURV =-PAR1 * 2.                                                   CURVATURE + ERROR
 38000 339         CVZW = TGST**2+1.
 38100 340         CVST =-PAR1 * 2 / (SQRT(CVZW)*CVZW)
 38200 341         DET = (S2*S0-S1*S1)*S4 + (S2*S1-S3*S0)*S3 + (S3*S1-S2*S2)*S2
 38300 342         SIG11 = (S2*S0 - S1*S1)/DET
 38400 343         SIG22 = (S4*S0 - S2*S2)/DET
 38500 344         SIG33 = (S4*S2 - S3*S3)/DET
 38600 345         SIG12 = (S3*S0 - S2*S1)/DET
 38700 346         SIG13 = (S3*S1 - S2*S2)/DET
 38800 347         SIG23 = (S4*S1 - S3*S2)/DET
 38900    C     PRINT 2012, DET,SIG11,SIG22,SIG33,SIG12,SIG13,SIG23,SIG
 39000    C
 39100    C
 39200    C     PRINT 2014, XST,YST,DXST,DYST,TGST,XEN,YEN,DXEN,DYEN,TGEN,CURV
 39300    C
 39500 348         IP    = HPTR0 - 1                                               FILL FIT-BANK
 39600 349         IWRK(IP+ 1) = ITRK
 39610 350         IWRK(IP+ 2) = LOR(IWRK(IP+ 2),32)
 39700    C     IWRK(IP+ 2) = 32
 39800 351         IWRK(IP+ 3) = IDAY
 39900 352         IWRK(IP+ 4) = 16
 40000 353         WRK (IP+ 5) = XST *CSROT - YST *SNROT + XT
 40100 354         WRK (IP+ 6) = XST *SNROT + YST *CSROT + YT
 40200 355         WRK (IP+ 7) = XST - X0
 40300 356         WRK (IP+ 8) = (DXST*CSROT - DYST*SNROT)
 40400 357         WRK (IP+ 9) = (DXST*SNROT + DYST*CSROT)
 40500 358         WRK (IP+10) = SNTH
 40600 359         IWRK(IP+11) = 0
 40700 360         WRK (IP+12) = XEN *CSROT - YEN *SNROT + XT
 40800 361         WRK (IP+13) = XEN *SNROT + YEN *CSROT + YT
 40900 362         WRK (IP+14) = XEN - X0
 41000 363         WRK (IP+15) = (DXEN*CSROT - DYEN*SNROT)
 41100 364         WRK (IP+16) = (DXEN*SNROT + DYEN*CSROT)
 41200 365         WRK (IP+17) = SNTH
 41300 366         IWRK(IP+18) = 2
 41400 367         WRK (IP+19) = ATAN2(SNROT,CSROT)
 41500 368         WRK (IP+20) = XMIN*CSROT - YMIN*SNROT + XT
 41600 369         WRK (IP+21) = XMIN*SNROT + YMIN*CSROT + YT
 41700 370         WRK (IP+22) = PAR1
 41800    C     IF(SIG  .LT.0) PRINT 2021,WRK(IP+1),LBPR,S0,SIG
 41900    C2021 FORMAT(' -VE SQRT:',2I4,5E13.5)
 42000 371         WRK (IP+23) = SQRT(SIG)
 42100 372         IWRK(IP+24) = S0 + .001
 42200 373         WRK (IP+25) = CVST
 42300    C     IF(SIG11.LT.0) PRINT 2021,WRK(IP+1),S0,SIG,SIG11
 42400 374         WRK (IP+26) = SQRT(SIG*SIG11) * 2.
 42500 375         WRK (IP+27) = CVST
 42600 376         WRK (IP+28) = CVST
 42700 377         WRK (IP+31) = XOR - X0
 42800    C       I0 = IP+ 1
 42900    C       I9 = IP+48
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 43000    C       PRINT 2001,(WRK(I1),I1=I0,I9)
 43100 378      CPROC
 43200    C
 43300                                                                             *************************
 43400                                                                             *      F I T B K 1      *
 43600    C                                                                        *************************
 43700    C
 43900 380      PROC FITBK1                                                        CHANGE FIT BANK (1.POINT)
 44000    C
 44200 381         YST  = (PAR1 *XST + PAR2 )*XST + PAR3                           START POINT
 44400 382         TGST = PAR1*XST*2 + PAR2                                        DIRECTION AT START POINT
 44500 383         DXST = 1./SQRT(TGST**2+1.)
 44600 384         DYST = DXST * TGST
 44800 385         XMIN = -PAR2*.5 / PAR1                                          MIN. OF PARABOLA
 44900 386         YMIN = (PAR1*XMIN + PAR2)*XMIN + PAR3
 45000    C
 45200    C     CURV =-PAR1 * 2.                                                   CURVATURE + ERROR
 45300 387         CVZW = TGST**2+1.
 45400 388         CVST =-PAR1 * 2 / (SQRT(CVZW)*CVZW)
 45500 389         DET = (S2*S0-S1*S1)*S4 + (S2*S1-S3*S0)*S3 + (S3*S1-S2*S2)*S2
 45600 390         SIG11 = (S2*S0 - S1*S1)/DET
 45700 391         SIG22 = (S4*S0 - S2*S2)/DET
 45800 392         SIG33 = (S4*S2 - S3*S3)/DET
 45900 393         SIG12 = (S3*S0 - S2*S1)/DET
 46000 394         SIG13 = (S3*S1 - S2*S2)/DET
 46100 395         SIG23 = (S4*S1 - S3*S2)/DET
 46200    C     PRINT 2012, DET,SIG11,SIG22,SIG33,SIG12,SIG13,SIG23,SIG
 46300    C
 46400    C     PRINT 2014, XST,YST,DXST,DYST,TGST,XEN,YEN,DXEN,DYEN,TGEN,CURV,
 46500    C    ,            XMIN,YMIN
 46600    C
 46800 396         IP    = HPTR0 - 1                                               FILL FIT-BANK
 46900 397         WRK (IP+ 5) = XST *CSROT - YST *SNROT + XT
 47000 398         WRK (IP+ 6) = XST *SNROT + YST *CSROT + YT
 47100 399         WRK (IP+ 7) = XST - X0
 47200 400         WRK (IP+ 8) = (DXST*CSROT - DYST*SNROT)
 47300 401         WRK (IP+ 9) = (DXST*SNROT + DYST*CSROT)
 47400 402         WRK (IP+10) = SNTH
 47500 403         IWRK(IP+18) = 2
 47600 404         WRK (IP+19) = ATAN2(SNROT,CSROT)
 47700 405         WRK (IP+20) = XMIN*CSROT - YMIN*SNROT + XT
 47800 406         WRK (IP+21) = XMIN*SNROT + YMIN*CSROT + YT
 47900 407         WRK (IP+22) = PAR1
 48000    C     IF(SIG  .LT.0) PRINT 2022,WRK(IP+1),S0,SIG
 48100    C2022 FORMAT(' -VE SQRT(1):',I4,5E13.5)
 48200 408         WRK (IP+23) = SQRT(SIG)
 48300 409         IWRK(IP+24) = S0 + .001
 48400 410         WRK (IP+25) = CVST
 48500    C     IF(SIG11.LT.0) PRINT 2022,WRK(IP+1),S0,SIG,SIG11
 48600 411         WRK (IP+26) = SQRT(SIG*SIG11) * 2.
 48700 412         WRK (IP+27) = CVST
 48800    C     I0 = IP+ 1
 48900    C     I9 = IP+48
 49000    C     PRINT 2001,(WRK(I1),I1=I0,I9)
 49100 413      CPROC
 49200    C
 49300    C
 49400                                                                             *************************
 49500                                                                             *      L A B E L        *
 49700    C                                                                        *************************
 49800    C
 50000 415      PROC LABEL                                                         LABEL USED HITS
 50100    C
 50300 416         IWL = -999                                                      PRESET LAST HIT POINTER
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 50310 417         NHTRNG(1) = 0
 50320 418         NHTRNG(2) = 0
 50330 419         NHTRNG(3) = 0
 50400    C
 50600 420         IWL = -999                                                      PRESET LAST HIT POINTER
 50700 421         NHGOOD = 0
 50800 422         FOR IP = HPCO0,HPCO9,HLDCO
 50900 423            IW0 = IWRK(IP)
 51000 424            X   = WRK(IP+3)
 51100 425            Y   = WRK(IP+4)
 51200 426            F   = (PAR1*X + PAR2)*X + PAR3
 51300 427            DF  = F - Y
 51500 428            LBGOOD = 4                                                   SELECT CLOSEST HIT
 51600 429            IF(ABS(DF).LT.ALBLM2) LBGOOD = 1
 51700 431            IF(ABS(DF).LT.ALBLM1) LBGOOD = 0
 51800 433            IWRK(IP+ 10) = LBGOOD
 51900 434            IF(LBGOOD.EQ.0) NHGOOD = NHGOOD + 1
 52000 436            WRK (IP+13) = DF
 52010 437            IRNG = IWRK(IP+12)
 52020 438            IF(LBGOOD.LE.1) NHTRNG(IRNG) = NHTRNG(IRNG) + 1
 52100    C
 52300 440            IF IWL.EQ.IW0                                                CHECK IF 2 HITS FROM SAME WIRE
 52400 441            THEN
 52600 444               IF ABS(DFL).LT.ABS(DF)                                    SELECT CLOSEST HIT
 52700 445               THEN
 52800 448                  IF(IWRK(IP +10).EQ.0) NHGOOD = NHGOOD - 1
 52900 450                  IWRK(IP +10) = 16
 53000 451               ELSE
 53100 453                  IF(IWRK(IPL+10).EQ.0) NHGOOD = NHGOOD - 1
 53200 455                  IWRK(IPL+10) = 16
 53300 456               CIF
 53400 457            CIF
 53600 458            IWL = IW0                                                    STORE LAST POINTERS + DF
 53700 459            IPL = IP
 53800 460            DFL = DF
 53900 461         CFOR
 54000    C
 54100 463      CPROC
 54200    C
 54300    C
 54400                                                                             *************************
 54500                                                                             *      I N I T          *
 54700    C                                                                        *************************
 54800    C
 55000 465      PROC INIT                                                          INITIALIZE CONSTANTS
 55100    C
 55200 466         IQJETC = IBLN('JETC')
 55300 467         IQHEAD = IBLN('HEAD')
 55400    C
 55500 468         CALL DAY2(DATE)
 55600 469         IDAY = DATE(1)*1000 + DATE(2)
 55700    C
 55900 470         RESMS = .020**2/2. * .16 * (1. + ALOG10(.16) / 9) * 155.45**2   MULT. SCATTERING CONSTANTS
 56000 471      CPROC
 56100    C
 56200 473      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         472 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         472 TARGET STATEMENTS
 00000    C   08/12/80 309201526  MEMBER NAME  ORFZFITV (FITSR)       SHELTRAN
 00100   2      SUBROUTINE FZFITV(IPPATR,IPJHTL,NTRVTX,Z0,ERRFAC,MODEF)
 00200    C---
 00300    C---     GENERAL VERTEX FIT ROUTINE USING MARKED TRACKS ONLY
 00400    C---
 00500   3      IMPLICIT INTEGER*2 (H)
 00600    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 --------------------------
 00800    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
         8      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)
         9      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        10      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        11      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        12      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        13      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        14      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  15      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 ------------------
 01100    C
 01200  16      EQUIVALENCE
 01300         ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
 01400         ,         ,(HPZR0 ,HPWRK(20)),(HPZR9 ,HPWRK(21)),(HLDZR ,HPWRK(22))
 01500         ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 01600         ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
 01700    C
 01800    C2000 FORMAT('0CALL FZFITO(',2I6,1X,I3,8.2,F8.4,I4' )')
 01900    C2001 FORMAT(1H0,2I3,I8,2(I4,3F6.1,3F6.3),
 02000    C    ,     /,14X,I3,4E13.5,F6.2,I3,4E13.5,
 02100    C    ,     /,14X,I3,2F8.3,F6.1,I3,10X,6I3,8I6,2X,Z4)
 02200    C2003 FORMAT(' FRFITO RESULT:',F6.0,F6.3,F6.0,F6.3)
 02300    C
 02400  17      NTRVTX = 0
 02500  18      MODE   = MODEF
 02600    C
 02700    C
 02800  19      IPTR1 = IDATA(IPPATR+1) + IPPATR
 02900  20      LDTR  = IDATA(IPPATR+3)
 03000  21      NTR   = IDATA(IPPATR+2)
 03100    C     PRINT 2000,IPPATR,IPJHTL,NTRVTX,Z0,ERRFAC,MODE
 03200    C     CALL PRPATR
 03300  22      IF NTR.GT.0
 03400  23      THEN
 03500    C
 03700  26         IF(LAND(MODE,2).NE.0) CALL ZRFITO(-1,2001)                      INITIALIZE ZRFITO
 03800    C
 03900  28         FOR ITR=1,NTR
 04000    C
 04200  29            ITYPE =-IDATA(IPTR1+4)                                       CHECK IF MARKED TRACK
 04300  30            IF ITYPE .GT. 0
 04400  31            THEN
 04500    C
 04700  34               CALL FRFITV(IPTR1,IPJHTL,ERRFAC)                          REFIT TRACK WITH VERTEX CONSTRAINT
 04800    C           I0 = HPTR0
 04900    C           I9 = I0 + 47
 05000    C           PRINT 2001, (WRK(I1),I1=I0,I9)
 05100    C
 05300  35               IP    = HPTR0 - 1                                         REPLACE BANK IF GOOD RESULT
 05400  36               SIG   =  WRK(IP+23)
 05500  37               IF LAND(IWRK(IP+ 2),32).EQ.0
 05600  38               THEN
 05700  41                  SIG   = 1000.
 05800  42                  SIG0  =    0.
 05900  43               ELSE
 06000  45                  SIG   =  WRK(IP+23)
 06100  46                  SIG0  = ADATA(IPTR1+23)
 06200  47                  ANHT  = IWRK(IP+24)
 06300  48                  IF(LAND(IWRK(IP+ 4),16).NE.0) ANHT = ANHT * 1.5
 06400  50                  ANHT0 = IDATA(IPTR1+24)
 06500    C             PRINT 2003, ANHT,SIG,ANHT0,SIG0
 06600  51                  IF(ANHT/ANHT0.LT..8) SIG = SIG + .5
 06700  53               CIF
 06800  54               IF SIG0.GT.SIG .OR. SIG.LT..35
 06900  55               THEN
 07000    C
 07100  58                  NTRVTX = NTRVTX + 1
 07200  59                  CALL MVC(IDATA(IPTR1+1),0,IWRK(HPTR0),0,112)
 07300  60                  IDATA(IPTR1+4) = LOR(IDATA(IPTR1+4),ITYPE)
 07500  61                  INDZR = 0                                              SET ZRFIT INDEX
 07600  62                  IF LAND(MODE,2) .NE. 0
 07700  63                  THEN
 07800  66                     ADATA(IPTR1+17) = WRK(HPTR0+30)
 08000  67                     CALL ZRFITO(INDZR,IPTR1)                            ZFIT: STORE R-Z COORDINATES FOR LATER USE
 08100  68                  CIF
 08200  69                  IF LAND(MODE,2) .EQ. 0 .OR. INDZR.NE.0
 08300  70                  THEN
 08500  73                     TGTH = ADATA(IPTR1+30)                              NO ZFIT: CALCULATE POINTS + DIRECTIONS
 08600  74                     Z0TR = ADATA(IPTR1+31)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 08700  75                     CSTH = 1./SQRT(TGTH**2+1.)
 08800  76                     SNTH = CSTH * TGTH
 08900  77                     ADATA(IPTR1+ 8) = ADATA(IPTR1+ 8) * CSTH
 09000  78                     ADATA(IPTR1+ 9) = ADATA(IPTR1+ 9) * CSTH
 09100  79                     ADATA(IPTR1+15) = ADATA(IPTR1+15) * CSTH
 09200  80                     ADATA(IPTR1+16) = ADATA(IPTR1+16) * CSTH
 09300  81                     ADATA(IPTR1+17) = SNTH
 09400  82                     ADATA(IPTR1+ 7) = ADATA(IPTR1+ 7) * TGTH + Z0TR
 09500  83                     ADATA(IPTR1+14) = ADATA(IPTR1+14) * TGTH + Z0TR
 09600  84                  CIF
 09700    C
 09900  85               ELSE                                                      NO TRACK FROM ORIGIN, RESET TYPE(1. POINT)
 10000  87                  IDATA(IPTR1+4) = 0
 10100    C
 10200  88               CIF
 10300  89            CIF
 10400  90            IPTR1 = IPTR1 + LDTR
 10500  91         CFOR
 10600    C
 10800  93         IF NTRVTX.GT.0                                                  CHECK IF TRACKS ACCEPTED
 10900  94         THEN
 11000    C
 11200  97            INDZR = 1                                                    PERFORM SUPERFIT
 11300  98            IF(LAND(MODE,2).NE.0) CALL ZRFITO(INDZR,Z0)
 11400    C
 11500 100         CIF
 11600    C
 11700 101      CIF
 11800 102      RETURN
 11900    C
 12000 103      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         102 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         102 TARGET STATEMENTS
 00000    C   09/06/83 802181227  MEMBER NAME  JFETCH   (JADEGS)      SHELTRAN
 00100   2      SUBROUTINE JFETCH(IPTR,IPJHTL,WRK,LHIT,IPRES,INDEX,/XO/,/YO/)
 00200    C
 00300    C        P. STEFFEN                         83/03/28
 00400    C
 00500    C        MODIFIED TO CALL NEW JFETCH WHEN APPLICABLE   J.SPITZER
 00600    C                                                       86/04/30
 00700    C    Z-CHAMBER COORDINATES ARE FETCHED IN CASE OF
 00800    C    ZS-FIT (INDEX=4)
 00900    C                                            15/7/87  J.S.
 01000    C        FETCH HITS FOR TRACK 'IPTR' IN PATR-BANK
 01100    C        CALCULATE COORDINATE INCLUDING ALL CORRECTIONS
 01200    C        USE SPECIAL LAYER DEPENDENT POS. + VD   ***************
 01300    C        STORE COORDINATES IN WRK(I1),I1=1,LHIT*NHIT
 01400    C
 01500    C        INDEX = 1 : COORDINATES IN REAL SPACE
 01600    C        INDEX = 2 : X-AXIS THROUGH 1. + LAST POINT
 01700    C        INDEX = 3 : X-AXIS THROUGH (XO,YO) + LAST POINT
 01800    C
 01900    C        INDEX = 4 : NEW FOR S-Z FITS    J. SPITZER 22/4/87
 02000    C                    COORDINATES IN REAL SPACE
 02100    C
 02200    C        LAST MOD: J. HAGEMANN 13/01/88  NEW FLAG VALUES FOR HITS OF
 02300    C                                        OVERLAPPING TRACKS (LBGOOD)
 02400    C                                        NOVL COUNTS THESE HITS
 02500    C                                        NOVL PASSED VIA COMMON/XYFVT1/
 02600    C
 02700    C  LBGOOD:  2=     OLD
 02800    C           2=  DIST. OF HIT-SEL. TRACK < DIST. OF HIT-SECOND TRACK
 02900    C          11=  DIST. OF HIT-SEL. TRACK = DIST. OF HIT-SECOND TRACK
 03000    C          12=  DIST. OF HIT-SEL. TRACK > DIST. OF HIT-SECOND TRACK
 03100    C
 03200    C
 03300   3      IMPLICIT INTEGER*2 (H)
 03400    C
 03500   4      DIMENSION WRK(200)
 03600   5      EQUIVALENCE (ZWZ,IZW)
 03700    C---------------------------------
 03800   6      COMMON/JSCALD/ JESCAL,JESKEY
 03900    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
         7      COMMON /BCS/ IDATA(40000)
         8      DIMENSION HDATA(80000),ADATA(40000),IPNT(50)
         9      EQUIVALENCE (HDATA(1),IDATA(1),ADATA(1)),(IPNT(1),IDATA(55))
        10      EQUIVALENCE (NWORD,IPNT(50))
          C
          C------------------------ END OF MACRO CDATA --------------------------
 04100    C
          C----------------------------------------------------------------------
          C            MACRO CALIBR .... JADE CALIBRATION DATA COMMON
          C----------------------------------------------------------------------
        11      COMMON/CALIBR/ ACALIB(1000)
        12      DIMENSION HCALIB(100),ICALIB(100)
 02600  13      EQUIVALENCE(ACALIB(1),HCALIB(1),ICALIB(1))
          C------------------------ END OF MACRO CALIBR -------------------------
 04300    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 04400    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  14      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----------------------------------------------------------------------
        15      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 -------------------------
 04700    C
 04800  16      COMMON/CCMZCT/ DIMPCT, ZCUTV, ZCUTVV, IZVCST(5), ZCHWW
 04900    C ONLY ZCHWW WHICH IS THE WEIGHT FOR Z-CHAMBER HITS IS USED HERE
 05000    C  ARRAYS FOR Z-CHAMBER INFORMATION
 05100  17      DIMENSION IZCHMB(3,2),AZCHMB(3,2)
 05200    C
 05300  18      COMMON/XYFVT1/MODXYV,NOVL
 05400    C
 05500  19      DIMENSION IRESAR(13),RESAR(13),HRESAR(26)
 05600  20      EQUIVALENCE (IRESAR(1),RESAR(1),HRESAR(1))
 05700    C
 05900  21      DATA NCOAR / 15/, DTGB / .15/                                      CONSTANTS FOR ANGULAR CORRECTION
 06000  22      REAL TGCOAR(15) /-99.,-.45, 12*0., 99./
 06100  23      REAL T0COAR(60) / .000, .000, .000, .000, .000,
 06200         ,     .000, .000,-.020,-.060,-.130,-.030, .100, .200, .200, .200,
 06300         ,                  .000, .000, .010, .110, .100,
 06400         ,     .075, .050, .025, .005, .015, .065, .060, .060, .060, .060,
 06500         ,                  .190, .190, .180, .165, .140,
 06600         ,     .120, .100, .075, .050, .010,-.050,-.075,-.035, .000, .000,
 06700         ,                  .110, .110, .115, .140, .135,
 06800         ,     .085, .045, .030, .040, .050, .055, .055, .055, .055, .055/
 06900  24      REAL SLCOAR(60) / 60*0./
 07000    C
 07200  25      INTEGER MKLRT1 /Z1000000/, MKLRT2 /Z100/                           MASK FOR L/R BIT IN HIT LABEL
 07300    C
 07400    C-----------------------------------------------------------------------
 07500    C      --- NEW CALIBRATION WHEN AVAILABLE AND IF REQUESTED   J.S. ---
 07600  26      IF JESCAL .GT. 0   .AND.   JESKEY .EQ. 54321
 07700  27      THEN
 07800  30         IP8=ICALIB(13)+6
 07900  31         IP9=ICALIB(13)+2598
 08000  32         CALL JFTNEW(IPTR,IPJHTL,WRK,LHIT,IPRES,INDEX,XO,YO,
 08100         +   ACALIB(IP8),ACALIB(IP9))
 08200  33         RETURN
 08300  34      CIF
 08400    C
 08500  35      INDX=INDEX
 08600  36      IF(INDX.EQ.4) INDX=1
 08700    C-----------------------------------------------------------------------
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 08800    C
 08900    C     IF(IDATA(IPTR+1).LT. 4) RETURN
 09000    C     I0 = IPTR + 1
 09100    C     I9 = IPTR + 48
 09200    C     PRINT 2001, (IDATA(I1),I1=I0,I9)
 09300    C     I0 = IPJHTL*2 + 1
 09400    C     I9 = I0 + IDATA(IPJHTL)*2 - 1
 09500    C     IPJETC = IDATA(IBLN('JETC'))
 09600    C     I0 = IPJETC*2 + 1
 09700    C     I9 = I0 + 109
 09800    C2001 FORMAT(1H0,2I3,I8,2(I4,3F6.1,3F6.3),
 09900    C    ,     /,14X,I3,4E13.5,F6.2,I3,4E13.5,
 10000    C    ,     /,14X,I3,2F8.3,F6.1,I3,10X,6I3,8I6,2X,Z4)
 10100    C2002 FORMAT('0FETCH:',2I3,2I5,12F9.5)
 10200    C2003 FORMAT('0ROTATION:',12F10.5)
 10300    C2004 FORMAT('0CIRC.CENTRE:',2I3, F10.5,2F10.0,F8.1,2F8.1)
 10400    C2005 FORMAT('0TRACK:',I6,/,(1X,3I6,4F9.3,I4,F9.3,2I4,F8.3,I6,3F8.2))
 10500    C2007 FORMAT(' FETCH:',I3,8F8.5,F10.7,F6.3)
 10600    C2009 FORMAT(' JHTL:',I8,1X,Z8,3I5,I8)
 10700    C2010 FORMAT(' HIT:',I6,12F8.2)
 10800    C2011 FORMAT('0ABERR:',10F10.6)
 10900    C2016 FORMAT('0ITRCLL =',6I8,/,(9X,6F8.3))
 11000    C
 11100    C2901 FORMAT('0JFETCH(PST) CALLED WITH WRONG INDEX:',I6)
 11200    C
 11300    C
 11500  38      DATA LBINIT /0/                                                    INITIALIZATION
 11600  39      IF LBINIT .EQ. 0
 11700  40      THEN
 11800  43         LBINIT = 1
 11900  44         NCALL = 0
 12000  45         PERFORM INIT
 12100  48         PRINT 7777
 12200  49 7777   FORMAT(' JFETCH : VERSION FROM 13/01/88 CALLED!',/,
 12300         &   ' +++++++++++++++++++++++++++++++++++++++++++++++++++++')
 12400  50      CIF
 12500  51      NCALL = NCALL + 1
 12600    C
 12700    CCC   RESERVE SPACE IN CWORK
 12800    CCC   HPCO0  = 1
 12900    CCCCC LHIT   = MAX0(LHIT,14)
 13000  52      LHBIT  = LHIT*4
 13100    CCC   HPFREE = LHIT*100 + HPCO0
 13200    CCC   HPCO9  = 0
 13300  53      IPCO = 1
 13400    C
 13600  54      IPHEAD = IDATA(IQHEAD)*2                                           GET RUN #
 13700  55      NRUN = HDATA(IPHEAD+10)
 13800  56      NEVT = HDATA(IPHEAD+11)
 13900    C
 14100  57      ITRK = IDATA(IPTR+1)                                               TRACK #
 14200    C
 14400  58      IF IDATA(IPTR+18).EQ.1                                             CENTRE OF CIRCLE (USED FOR ANGULAR CORRECTION)
 14500  59      THEN
 14700  62         ALFA  = ADATA(IPTR+21)                                          CIRCLE PARAMETERS
 14800  63         CRV   = ADATA(IPTR+19)
 14900  64         IF(ABS(CRV).LT.1.E-8) CRV = SIGN(1.E-8,CRV)
 15000  66         RAD   =  1./ABS(CRV) + ADATA(IPTR+20)
 15100  67         XCIRC = COS(ALFA) * RAD
 15200  68         YCIRC = SIN(ALFA) * RAD
 15300  69         CHARGE = SIGN(1.,ADATA(IPTR+25))
 15400  70      ELSE
 15600  72         CRV   = ADATA(IPTR+22)*2.                                       PARABOLA PARAMETERS
 15700  73         IF(ABS(CRV).LT.1.E-8) CRV = SIGN(1.E-8,CRV)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 15800  75         ALFA  = ADATA(IPTR+19)
 15900  76         XCIRC =-SIN(ALFA)/CRV + ADATA(IPTR+20)
 16000  77         YCIRC = COS(ALFA)/CRV + ADATA(IPTR+21)
 16100  78         CHARGE =-SIGN(1.,ADATA(IPTR+22))
 16200  79      CIF
 16300    C
 16500  80      ZVERT = ADATA(IPTR+31)                                             ZVERT, THETA + DIR. COSINES
 16600  81      TGTH = ADATA(IPTR+30)
 16700  82      CSTHI = SQRT(TGTH**2 + 1.)
 16800  83      CSTH  = 1. / CSTHI
 16900  84      SNTH  = CSTH * TGTH
 17000    C     PRINT 2004,ITRK,IDATA(IPTR+18),ALFA,XCIRC,YCIRC,ZVERT,TGTH,CSTHI
 17100    C
 17200    C     PRINT 2011,ABERR
 17300    C
 17500  85      SELECT INDX                                                        ROTATION ANGLE (USING LAST POINT OF TRACK)
 17600  86      CASE 1
 17700  88         XT = 0.
 17800  89         YT = 0.
 17900  90         CSROT = 1.
 18000  91         SNROT = 0.
 18100  92         XOT   = 0.
 18200  93         YOT   = 0.
 18300  94      CASE 2
 18400  96         XT    = (ADATA(IPTR+12) + ADATA(IPTR+5)) * .5
 18500  97         YT    = (ADATA(IPTR+13) + ADATA(IPTR+6)) * .5
 18600  98         XX    =  ADATA(IPTR+12) - ADATA(IPTR+5)
 18700  99         YY    =  ADATA(IPTR+13) - ADATA(IPTR+6)
 18800 100         RR    = SQRT(XX**2+YY**2)
 18900 101         IF RR.LT.10.
 19000 102         THEN
 19100 105            IPRES=IPCO
 19200 106            RETURN
 19300 107         CIF
 19400 108         CSROT = XX / RR
 19500 109         SNROT = YY / RR
 19600 110         XX    = XO - XT
 19700 111         YY    = YO - YT
 19800 112         XOT   = 0.
 19900 113         YOT   = 0.
 20000 114      CASE 3
 20100 116         XT    = (ADATA(IPTR+12) + XO) * .5
 20200 117         YT    = (ADATA(IPTR+13) + YO) * .5
 20300 118         XX    =  ADATA(IPTR+12) - XO
 20400 119         YY    =  ADATA(IPTR+13) - YO
 20500 120         RR    = SQRT(XX**2+YY**2)
 20600 121         CSROT = XX / RR
 20700 122         SNROT = YY / RR
 20800 123         XX    = XO - XT
 20900 124         YY    = YO - YT
 21000 125         XOT   = XX*CSROT + YY*SNROT
 21100 126         YOT   =-XX*SNROT + YY*CSROT
 21200 127      OTHER
 21300    C
 21500    C       PRINT 2901,INDEX                                                 ILLEGAL INDEX
 21600 132         RETURN
 21700    C
 21800 133      CSELECT
 21900    C
 22000 134      NOVL = 0
 22100    C
 22300    C                                                                        SELECT CELLS CONTAINING TRACK
 22400 135      IPC0 = IPTR + 34
 22500 136      IPC9 = IPC0 +  5
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 22600 137      FOR IPC = IPC0,IPC9
 22700 138         JCELL = IDATA(IPC)
 22800 139         IF JCELL.GT. 0 .AND. JCELL.LE.96
 22900 140         THEN
 23000 143            JRING = 1
 23100 144            IF(JCELL.GT.24) JRING = 2
 23200 146            IF(JCELL.GT.48) JRING = 3
 23300 148            PERFORM FETCH
 23400 151         CIF
 23500 152      CFOR
 23600    C
 23700    CCC   HPCO9 = IPCO - 1
 23800    CCC   PRINT 2005, LBCELL,(WRK(I),I=1,HPCO9)
 23900    C
 24000    C
 24100    C FETCH Z-CHAMBER HITS IN CASE Z-S FITS (INDEX=4)
 24200 154      IF INDEX.EQ.4 .AND. ZCHWW.GT..1 .AND. ZCHWW.LT.2000.
 24300 155      THEN
 24400 158         CALL ZCFTNW(NRUN,NEVT,ITRK,TGTH,ZVERT,NZHIT,IZCHMB,AZCHMB)
 24500 159         IF NZHIT.GT.0
 24600 160         THEN
 24700 163            FOR J=1,NZHIT
 24800 164               HRESAR( 1) = 100+IZCHMB(1,J)
 24900 165               HRESAR( 2) = IZCHMB(2,J)
 25000 166               HRESAR( 3) = 0
 25100 167               HRESAR( 4) = 0
 25200 168               HRESAR( 5) = 1
 25300    C              HRESAR( 6) = IP-2*IPJETC
 25400 169               HRESAR( 6) = 101
 25500 170               XX=AZCHMB(1,J)
 25600 171               YY=AZCHMB(2,J)
 25700 172               ZZ=AZCHMB(3,J)
 25800 173               RESAR ( 4) = XX
 25900 174               RESAR ( 5) = YY
 26000 175               RESAR ( 6) = ZZ
 26100    C CALCULATE TRACK LENGTH IN R-PHI FROM FIRST POINT ON TRACK
 26200 176               UX=XX-ADATA(IPTR+5)
 26300 177               UY=YY-ADATA(IPTR+6)
 26400 178               UU=SQRT(UX**2+UY**2)
 26500 179               IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*SIN(.5*CURVXY*UU)/CURVXY
 26600 181               IF(UX*ADATA(IPTR+8)+UY*ADATA(IPTR+9).LT.0.) UU=-UU
 26700 183               RESAR ( 7) = UU
 26800    C              RESAR ( 8) = WW
 26900 184               RESAR ( 8) = ZCHWW
 27000 185               IF(NRUN.LT.24200) RESAR(8)=RESAR(8)*.6
 27100 187               CALL MVC(WRK(IPCO),0,RESAR(1),0,LHBIT)
 27200 188               IPCO = IPCO + LHIT
 27300 189            CFOR
 27400 191         CIF
 27500 192      CIF
 27600    C
 27700    C
 27900 193      IPRES = IPCO                                                       STORE RESULTS
 28000 194      IF INDEX.NE.4
 28100 195      THEN
 28200 198         WRK (IPRES   ) = XT
 28300 199         WRK (IPRES+ 1) = YT
 28400 200         WRK (IPRES+ 2) = CSROT
 28500 201         WRK (IPRES+ 3) = SNROT
 28600 202         WRK (IPRES+ 9) = XOT
 28700 203         WRK (IPRES+10) = YOT
 28800 204         WRK (IPRES+11) = CSTH
 28900 205         WRK (IPRES+12) = SNTH
 29000 206      CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 29100    C
 29200    C     PRINT 2003, CSROT,SNROT,XT,YT
 29300    C
 29400    C
 29500 207      RETURN
 29600    C
 29700    C
 29800                                                                             *************************
 29900                                                                             *      F E T C H        *
 30100    C                                                                        *************************
 30200    C
 30400 208      PROC FETCH                                                         FETCH HITS IN CELL
 30500    C
 30700 209         IF JRING.NE.3                                                   DIR. OF SENSEW. + DRIFTSP.
 30800 210         THEN
 30900 213            IC1 = JCELL
 31000 214            IF(IC1.GT.24) IC1 = IC1 - 24
 31100 216            CSROT0 = DIRWR1(IC1,1)
 31200 217            SNROT0 = DIRWR1(IC1,2)
 31300 218         ELSE
 31400 220            IC1 = JCELL - 48
 31500 221            CSROT0 = DIRWR3(IC1,1)
 31600 222            SNROT0 = DIRWR3(IC1,2)
 31700 223         CIF
 31800 224         DRICS  = TRMATC(JCELL,2)
 31900 225         DRISN  = TRMATS(JCELL,2)
 32000 226         DRITG  = DRISN/DRICS
 32100 227         DRISNF = DRISN * .05
 32200    C
 32400 228         R0 = FSENSW(JRING)                                              LOAD RADIUS AND WIRE SPACING
 32500 229         DR = RINCR (JRING)
 32600    C
 32800 230         R1   = DR*7.5 + R0                                              ANGLE OF TRACK IN RING
 32900 231         DX   = R1 * CSROT0 - XCIRC
 33000 232         DY   = R1 * SNROT0 - YCIRC
 33100 233         RR   = SQRT(DX**2 + DY**2) * CHARGE
 33200 234         CSB  = DX / RR
 33300 235         SNB  = DY / RR
 33400 236         TGB  = CSB/SNB
 33500    C
 33700 237         DSBIN1 = DRIVEL(JCELL,1)                                        SET DRIFT SPACE BIN
 33800    C
 34000 238         TANBET = (DRITG - TGB) / (TGB*DRITG + 1.)                       ANGLE(TRACK,DRIFT DIRECT.)
 34100    C
 34300 239         IF NRUN.LE.100                                                  DIFFERENT CORRECTION CONST. FOR MC + DATA
 34400 240         THEN
 34600 243            DS0 = DSBIN1*.5                                              MC
 34700 244            T0CORR = 0.
 34800 245         ELSE
 35000 247            DS0 = T0FIX(JRING)*DSBIN1*64.                                DATA
 35100 248            FOR I1=1,NCOAR
 35200 249               IDX = I1
 35300 250               IF(TANBET.LT.TGCOAR(IDX)) XFOR
 35400 252            CFOR
 35500 254            KRNG = JRING
 35600 255            IF(KRNG.EQ.3 .AND. AND(JCELL,1).EQ.0) KRNG = 4
 35700 257            IBIN = (KRNG-1)*NCOAR  + IDX
 35800 258            T0CORR = (TANBET-TGCOAR(IDX)) * SLCOAR(IBIN) + T0COAR(IBIN)
 35900 259         CIF
 36000    C     IF(NCALL.LE.2)
 36100    C    ,PRINT 2007, JCELL,CSROT0,SNROT0,DRICS,DRISN,CSB,SNB,CHARGE,TANBET,
 36200    C    ,            DSBIN1,DS0
 36300    C     IF(NCALL.LE.8)
 36400    C    ,PRINT 2093, JCELL,KRNG,IDX,IBIN,T0CORR,TGCOAR(IDX),T0COAR(IBIN),
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 36500    C    ,            SLCOAR(IBIN),TANBET
 36600    C2093 FORMAT('0ANG.CORR.:',4I4,8F8.3)
 36800    C                                                                        CORRECTION CONSTANTS FOR JCELL
 36900 260         IPJCOR = ICALIB(5) + JCELL
 37000 261         CCST01 = ACALIB(IPJCOR     ) * ABS(TANBET)
 37100 262         CCST02 = ACALIB(IPJCOR+  96) * ABS(TANBET)
 37200 263         CCST11 = ACALIB(IPJCOR+ 192)
 37300 264         CCST12 = ACALIB(IPJCOR+ 288)
 37400 265         CCST21 = ACALIB(IPJCOR+ 384)
 37500 266         CCST22 = ACALIB(IPJCOR+ 480)
 37600 267         CCST51 = ACALIB(IPJCOR+ 576) * 10.
 37700 268         CCST52 = ACALIB(IPJCOR+ 672) / 121.15
 37800 269         CCST61 = ACALIB(IPJCOR+ 768) * 10.
 37900 270         CCST62 = ACALIB(IPJCOR+ 864) / 121.15
 38000 271         CCST81 = ACALIB(IPJCOR+1152)
 38100    C     IF(NCALL.LE.2)
 38200    C    ,PRINT 2002, JRING,JCELL,IP,IPCLLC,CCST01,CCST02,CCST11,CCST12,
 38300    C    ,  CCST21,CCST22,CCST51,CCST52,CCST61,CCST62,ACALIB(IPDY),CCST81
 38500 272         JHIT = 0                                                        COUNTER FOR NUMBER OF HITS FOUND
 38600 273         NHIT   = 0
 38700 274         NHGOOD = 0
 38900 275         ILAYL =-99                                                      PRESET LAST LAYER
 39100 276         IPCO = IPCO - LHIT                                              LOOP OVER ALL HITS OF CELL
 39200 277         IPJET4 = IDATA(IQJETC)
 39300 278         IPJETC = IDATA(IQJETC)*2
 39400 279         IP0    = IPJETC + 100
 39500 280         IPCLL  = IPJETC + 2 + JCELL
 39600 281         IP     = HDATA(IPCLL  ) + IP0
 39700 282         IP9    = HDATA(IPCLL+1) + IP0
 39800 283         IPHL   = IPJHTL + 2 + HDATA(IPCLL)/4
 39900    C     PRINT 2002, JRING,JCELL,IP,IP9,TGB,SNB,CSB,DRISN,DRICS
 40000 284         WHILE IP.LT.IP9
 40100    C
 40300 286            LB   = IDATA(IPHL)                                           CHECK TRACK # OF HIT LABEL
 40400 290            ITR1 = LAND(SHFTR(LB,17),127)
 40500 291            ITR2 = LAND(SHFTR(LB, 1),127)
 40600    C     PRINT 2009, IPHL,LB,ITR1,ITR2,ITRK,IP
 40700 292            IF ITR1.EQ.ITRK .OR. ITR2.EQ.ITRK
 40800 293            THEN
 40900    C
 41100 296               L0GOOD = 0                                                SET LBGOOD =  2,11,12 IF HIT ASSOCIATED WITH 2 TRA
 41200 297               IF ITR1.NE.0 .AND. ITR2.NE.0
 41300 298               THEN
 41400 301                  NOVL   = NOVL + 1
 41500 302                  L0GOOD = 11
 41600 303                  ID1    = LAND(SHFTR(LB,27), 31)
 41700 304                  ID2    = LAND(SHFTR(LB,11), 31)
 41800 305                  IF ITR1 .EQ. ITRK
 41900 306                  THEN
 42000 309                     IF( ID1 .LT. ID2 ) L0GOOD = 2
 42100 311                     IF( ID1 .GT. ID2 ) L0GOOD = 12
 42200 313                  ELSE
 42300 315                     IF( ID2 .LT. ID1 ) L0GOOD = 2
 42400 317                     IF( ID2 .GT. ID1 ) L0GOOD = 12
 42500 319                  CIF
 42600 320               CIF
 42700    C
 42900 321               LBLR = 0                                                  L/R FROM HIT LABEL
 43000 322               IF(ITR1.EQ.ITRK) LBLR = LAND(LB,MKLRT1)
 43100 324               IF(ITR2.EQ.ITRK) LBLR = LAND(LB,MKLRT2)
 43200 326               LBSIDE =-1
 43300 327               IF(LBLR.NE.0) LBSIDE = 1
 43400 329               LBLR = LBSIDE
 43500    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 43600 330               IWIR = HDATA(IP)
 43700 331               IWIR = SHFTR(IWIR,3)
 43900 332               ILAY = LAND(IWIR,15)                                      LAYER NUMBER WITHIN RING 3
 44100 333               IAMPL = HDATA(IP+1)                                       AMPLITUDES
 44200 334               IAMPR = HDATA(IP+2)
 44400 335               DS =(HDATA(IP+3)) * DSBIN1                                DRIFT SPACE
 44500 336               X1   = ILAY * DR + R0
 44600 337               Z1   = X1*TGTH + ZVERT
 44800 338               DDS = (1222.9-ABS(Z1))*ABERR(1) + ABERR(6)*R1*CSTHI       CORRECTION FOR TOF + PROPAG. ALONG WIRE
 45000 339               IF NRUN.LE.100                                            CORRECTION FOR GRAVITATION
 45100 340               THEN
 45300 343                  DGR = 0.0                                              MC
 45400 344               ELSE
 45600 346                  DGR = ((Z1/1222.9)**2 - 1.) * .075                     REAL
 45700 347               CIF
 45800 348               DSC =  DS - DDS + DS0
 45900    C     DATA NPRHT /0/
 46000    C     NPRHT = NPRHT + 1
 46100    C     IF(NPRHT.LE.50) PRINT 2019, IWIR,ILAY,JCELL,HDATA(IP+3),DS,DSBIN1,
 46200    C    ,                DSC,DDS,DS0,ACALIB(IPVD+ILAY)
 46300    C2019 FORMAT(' HIT ',4I6,F7.3,5E13.5)
 46400 349               Y1   = SWDEPL
 46500 350               IF(LAND(ILAY,1).NE.0) Y1 =-Y1
 46600 352               Y1   = (7.5-ILAY)*(CCST52*Z1+CCST51) - CCST62*Z1-CCST61 + Y1
 46700 353               X    = X1*CSROT0 - Y1*SNROT0
 46800 354               Y    = X1*SNROT0 + Y1*CSROT0 - DGR
 46900 355               IF DSC.LE.DRC
 47000 356               THEN
 47100 359                  IF DSC.LT.DSD2
 47200 360                  THEN
 47300 363                     IF DSC.LT.DSD1
 47400 364                     THEN
 47500 367                        DSC = DSC + DDS1 + (DSC-DSD1)*DRV1
 47600 368                     ELSE
 47700 370                        DSC = DSC + DDS2 + (DSC-DSD2)*DRV2
 47800 371                     CIF
 48000    C               DSC = DSC/DSD2 * T0CORR + DSC                            ANGULAR CORRECTION
 48100 372                     IF(DSC.LT.0.1) DSC = 0.1
 48200 374                  ELSE
 48300    C
 48500    C               DSC = DSC + T0CORR                                       ANGULAR CORRECTION
 48600 376                     DSC = (DSC-DSD2)/(DRC-DSD2) * T0CORR + DSC
 48700 377                  CIF
 48800    C             DSC = DSC + DSOFF
 48900 378                  DXR  = DSC * CSB
 49000 379                  DYR  = DSC * SNB
 49100 380                  DXL =-DXR
 49200 381                  DYL =-DYR
 49300 382               ELSE
 49400    C
 49600 384                  DSC = DSC + T0CORR                                     ANGULAR CORRECTION
 49700    C             DSC = DSC + DSOFF
 49800    C
 50000 385                  IF ILAY.LT. 3                                          EDGE WIRE FIELD DISTORTION
 50100 386                  THEN
 50200 389                     DILAY =-(ILAY- 3)**2
 50300 390                     DSCL  = (DILAY*CCST11 + 1.) * DSC * (1. - CCST81)
 50400 391                     DSCR  = (DILAY*CCST12 + 1.) * DSC * (1. + CCST81)
 50500 392                  ELSE
 50600 394                     IF ILAY.GT.12
 50700 395                     THEN
 50800 398                        DILAY =-(ILAY-12)**2
 50900 399                        DSCL  = (DILAY*CCST21 + 1.) * DSC * (1. - CCST81)
 51000 400                        DSCR  = (DILAY*CCST22 + 1.) * DSC * (1. + CCST81)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 51100 401                     ELSE
 51200 403                        DSCL = DSC * (1. - CCST81)
 51300 404                        DSCR = DSC * (1. + CCST81)
 51400 405                     CIF
 51500 406                  CIF
 51600    C
 51800 407                  IF DSC.GT.ABERR(7)                                     FIELD DISTORTIONS AT LARGE DRIFT TIMES
 51900 408                  THEN
 52000 411                     DWIR  = ILAY - 7.5
 52100 412                     DWIRC = DSC*DRISNF
 52200 413                     DWIRL = DWIR + DWIRC
 52300 414                     DWIRR = DWIR - DWIRC
 52400 415                     DSCL  = (DSCL-ABERR(7))*DWIRL*CCST01 + DSCL
 52500 416                     DSCR  =-(DSCR-ABERR(7))*DWIRR*CCST02 + DSCR
 52600 417                  CIF
 52700 418                  DXR  = (DSCR-DRC)*DRISN + DRC*CSB
 52800 419                  DYR  = (DSCR-DRC)*DRICS + DRC*SNB
 52900 420                  DXL  =-(DSCL-DRC)*DRISN - DRC*CSB
 53000 421                  DYL  =-(DSCL-DRC)*DRICS - DRC*SNB
 53100 422               CIF
 53200    C     PRINT 2010, ILAY,DS,DSC,DSCL,DSCR,XL,XR,X,Y,DXL,DXR,DYL,DYR
 53300 423               XL   = DXL + X - XT
 53400 424               YL   = DYL + Y - YT
 53500 425               XXL  = XL*CSROT + YL*SNROT
 53600 426               YYL  =-XL*SNROT + YL*CSROT
 53700 427               XR   = DXR + X - XT
 53800 428               YR   = DYR + Y - YT
 53900 429               XXR  = XR*CSROT + YR*SNROT
 54000 430               YYR  =-XR*SNROT + YR*CSROT
 54100    C
 54300    C           IF IAMPR.LE.0.OR.IAMPL.LE.0                                  CALCULATE Z COORDINATE
 54400    C           THEN
 54500    C             ZZ     = 0.
 54600    C             LZGOOD = 16
 54700    C           ELSE
 54800    C             ZZ = IAMPR + IAMPL
 54900    C             ZZ = FLOAT(IAMPR-IAMPL) * ZAL*.5 / ZZ
 55000    C             LZGOOD = 0
 55100    C             IF(ABS(ZZ).GT.1250.) LZGOOD = 16
 55200    C           CIF
 55300 431               CALL AMPS2Z( IP,IPJET4,ZZ,WW,LZGOOD)
 55400    C
 55600    C     PRINT 2010, ILAY,DS,XXL,YYL,X1,Z1,XXR,YYR,Y1                       SET ARRAY
 55700    C
 55900 432               NLRSOL = 1                                                CHECK IF LEFT + RIGHT SOLUTION POSSIBLE
 56000 433               IF(DSC.LT.2.0) NLRSOL = 2
 56100    C
 56300 435               ILRSOL = 0                                                LOOP OVER LEFT +/OR RIGHT SOLUTION
 56400 436               REPEAT
 56500 437                  ILRSOL = ILRSOL + 1
 56600 438                  LBGOOD = L0GOOD
 56700    C
 56900 439                  IF NLRSOL.EQ.1 .AND. LBSIDE.LT.0  .OR.                 SELECT SIDE
 57000         ?               NLRSOL.EQ.2 .AND. ILRSOL.EQ.1
 57100 440                  THEN
 57300 443                     LBSIDE =-1                                          LEFT SIDE
 57400 444                     XX  = XXL
 57500 445                     YY  = YYL
 57600 446                  ELSE
 57800 448                     LBSIDE = 1                                          RIGHT SIDE
 57900 449                     XX  = XXR
 58000 450                     YY  = YYR
 58100 451                  CIF
 58200    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 58400 452                  IF(LBSIDE.NE.LBLR) LBGOOD = LBGOOD + 1                 HIT QUALITY:
 58600 454                  IF ILAY.NE.ILAYL .OR. LBGDL.LE.1.AND.LBGOOD.LE.2       NEW LAYER?
 58700 455                  THEN
 58800 458                     LBREG = 1
 59000 459                     JHIT = JHIT + 1                                     INCREASE HIT COUNTER
 59100 460                     IPCO = IPCO + LHIT
 59200 461                  ELSE
 59400 463                     LBREG = 0                                           2 HITS IN SAME LAYER, SELECT CLOSEST
 59500 464                     ZWZ = WRK(IPCO+10)
 59600 465                     IF(LBGOOD.LT.IZW) LBREG = 1
 59700 467                  CIF
 59900 468                  IF LBREG.NE.0                                          REGISTER NEW HIT?
 60000 469                  THEN
 60100 472                     NHIT   = NHIT   + 1
 60200 473                     IF(LBGOOD.LE.2) NHGOOD = NHGOOD + 1
 60300 475                     IF INDEX.NE.4
 60400 476                     THEN
 60500 479                        IRESAR( 1) = ILAY
 60600 480                        IRESAR( 2) = IP
 60700 481                        IRESAR( 3) = LBSIDE
 60800 482                        RESAR ( 4) = XX
 60900 483                        RESAR ( 5) = YY
 61000 484                        RESAR ( 6) = ZZ
 61100 485                        RESAR ( 7) = XX - XOT
 61200 486                        IF(INDX.EQ.1) RESAR ( 7) = SQRT(XX**2 + YY**2)
 61300 488                        IRESAR( 8) = LZGOOD
 61400 489                        RESAR ( 9) = DSC
 61500 490                        IRESAR(10) = JCELL
 61600 491                        IRESAR(11) = LBGOOD
 61700 492                        RESAR (12) = TANBET
 61800 493                        IRESAR(13) = JRING
 61900 494                        RESAR (14) = 0.
 62000 495                     ELSE
 62100 497                        HRESAR( 1) = JCELL
 62200 498                        HRESAR( 2) = ILAY
 62300 499                        HRESAR( 3) = LZGOOD
 62400 500                        HRESAR( 4) = LBGOOD
 62500 501                        HRESAR( 5) = 1
 62600 502                        HRESAR( 6) = IP-IPJETC
 62700 503                        RESAR ( 4) = XX
 62800 504                        RESAR ( 5) = YY
 62900 505                        RESAR ( 6) = ZZ
 63000    C CALCULATE TRACK LENGTH IN R-PHI FROM FIRST POINT ON TRACK
 63100 506                        UX=XX-ADATA(IPTR+5)
 63200 507                        UY=YY-ADATA(IPTR+6)
 63300 508                        UU=SQRT(UX**2+UY**2)
 63400 509                        CURVXY=ADATA(IPTR+25)
 63500 510                        IF(ABS(CURVXY).LT.1.E-8) CURVXY = SIGN(1.E-8,CURVXY)
 63600 512                        IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*SIN(.5*CURVXY*UU)/CURVXY
 63700 514                        IF(UX*ADATA(IPTR+8)+UY*ADATA(IPTR+9).LT.0.) UU=-UU
 63800 516                        RESAR ( 7) = UU
 63900 517                        RESAR ( 8) = WW
 64000 518                     CIF
 64100    C     PRINT 2005, LHIT,(RESAR(I1),I1=1,13)
 64200 519                     CALL MVC(WRK(IPCO),0,RESAR(1),0,LHBIT)
 64300    CCCCC           IF LHIT.GT.14
 64400    CCCCC           THEN
 64500    CCCCC             I0 = IPCO+14
 64600    CCCCC             I9 = IPCO+LHIT - 1
 64700    CCCCC             FOR I1=I0,I9
 64800    CCCCC               WRK(I1) = 0.
 64900    CCCCC             CFOR
 65000    CCCCC           CIF
 65100 520                     ILAYL = ILAY
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 65200 521                     LBGDL = LBGOOD
 65300 522                  CIF
 65400    C
 65500 523               UNTIL ILRSOL.GE.NLRSOL
 65600    C
 65700 524            CIF
 65800    C
 65900 528            IPHL = IPHL + 1
 66000 529            IP   = IP   + 4
 66100 530         CWHILE
 66300 532         IPCO = IPCO + LHIT                                              SET IPCO TO 1. FREE LOCATION
 66400    C
 66500    C
 66600 533      CPROC
 66700    C
 66800    C
 66900                                                                             *************************
 67000                                                                             *      I N I T          *
 67200    C                                                                        *************************
 67300    C
 67500 535      PROC INIT                                                          INITIALIZE CONSTANTS
 67600    C
 67700 536         IQJETC = IBLN('JETC')
 67800 537         IQHEAD = IBLN('HEAD')
 67900    C
 68100 538         DRC = RINCR(1)*.5 * DRICOS                                      RADIUS AROUND WIRE FOR CORR. OF DRIFTSPACE
 68200    C       CONST. FOR VAR. OF DRIFT VEL.
 68400 539         IPHEAD = IDATA(IQHEAD)*2                                        GET RUN #
 68500 540         NRUN = HDATA(IPHEAD+10)
 68600 541         IF NRUN.LE.100
 68700 542         THEN
 68800 545            DSD0   = .0
 68900 546            DSD1   = .0
 69000 547            DSD2   = .0
 69100 548            DDS0   = .0
 69200 549            DDS1   = .0
 69300 550            DDS2   = .0
 69400 551            DRV1   = .0
 69500 552            DRV2   = .0
 69600 553         ELSE
 69700 555            DSD0   =-0.400
 69800 556            DSD1   = 0.300
 69900 557            DSD2   = 2.500
 70000 558            DDS0   = 0.720
 70100 559            DDS1   = 0.330
 70200 560            DDS2   = 0.0
 70300 561            DRV1   = (DDS0-DDS1) / (DSD0-DSD1)
 70400 562            DRV2   = (DDS1-DDS2) / (DSD1-DSD2)
 70500 563         CIF
 70600    C     PRINT 2091, DSD0,DDS0,DSD1,DDS1,DSD2,DDS2,DRV1,DRV2,DRC
 70700    C2091 FORMAT(' DSD,DDS=',3(F9.3,F7.3),F11.5,F9.5,F9.3,F8.3)
 70800    C
 71000 564         I9 = NCOAR - 1                                                  INITIALIZE ANGULAR CORRECTION CONSTANTS
 71100 565         FOR I1=2,I9
 71200 566            IF(I1.GT.2) TGCOAR(I1   ) = TGCOAR(I1- 1) + DTGB
 71300 568            SLCOAR(I1   ) = (T0COAR(I1   )-T0COAR(I1- 1)) / DTGB
 71400 569            SLCOAR(I1+15) = (T0COAR(I1+15)-T0COAR(I1+14)) / DTGB
 71500 570            SLCOAR(I1+30) = (T0COAR(I1+30)-T0COAR(I1+29)) / DTGB
 71600 571            SLCOAR(I1+45) = (T0COAR(I1+45)-T0COAR(I1+44)) / DTGB
 71700 572         CFOR
 71800    C     PRINT 2092, TGCOAR,T0COAR,SLCOAR
 71900    C2092 FORMAT('0ANG.CORR.:',15F8.3,/,(11X,15F8.3))
 72000 574      CPROC
 72100    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 12
0CARD TARGET
  NO  STM.NO
 
 72200 576      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         575 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         575 TARGET STATEMENTS
 00000    C   09/06/83 802181229  MEMBER NAME  JFTNEW   (JADEGS)      SHELTRAN
 00100   2      SUBROUTINE JFTNEW(IPTR,IPJHTL,WRK,LHIT,IPRES,INDEX,/XO/,/YO/,
 00200         +CALCST,DSTORW)
 00300    C
 00400    C        J. SPITZER                           /10/86
 00500    C    UPDATED 4.4.87, FROM F11SPI.JADECAL.S
 00600    C    INCLUDE POSSIBILITY OF SUPPLYING PARTICLE MASS FOR
 00700    C    FLIGHT TIME CORRECTION                   1/6/87  J.S.
 00800    C
 00900    C    Z-CHAMBER COORDINATES ARE FETCHED IN CASE OF
 01000    C    ZS-FIT (INDEX=4)
 01100    C                                            15/7/87  J.S.
 01200    C
 01300    C        FETCH HITS FOR TRACK 'IPTR' IN PATR-BANK
 01400    C        CALCULATE COORDINATE INCLUDING ALL CORRECTIONS
 01500    C        STORE COORDINATES IN WRK(I1),I1=1,LHIT*NHIT
 01600    C
 01700    C        INDEX = 1 : COORDINATES IN REAL SPACE
 01800    C        INDEX = 2 : X-AXIS THROUGH 1. + LAST POINT
 01900    C        INDEX = 3 : X-AXIS THROUGH (XO,YO) + LAST POINT
 02000    C
 02100    C        INDEX = 4 : NEW FOR S-Z FITS    J. SPITZER 22/4/87
 02200    C                    COORDINATES IN REAL SPACE
 02300    C
 02400    C        LAST MOD: J. HAGEMANN 13/01/88  NEW FLAG VALUES FOR HITS OF
 02500    C                                        OVERLAPPING TRACKS (LBGOOD)
 02600    C                                        NOVL COUNTS THESE HITS
 02700    C                                        NOVL PASSED VIA COMMON/XYFVT1/
 02800    C
 02900    C  LBGOOD:  2=     OLD
 03000    C           2=  DIST. OF HIT-SEL. TRACK < DIST. OF HIT-SECOND TRACK
 03100    C          11=  DIST. OF HIT-SEL. TRACK = DIST. OF HIT-SECOND TRACK
 03200    C          12=  DIST. OF HIT-SEL. TRACK > DIST. OF HIT-SECOND TRACK
 03300    C
 03400    C
 03500   3      IMPLICIT INTEGER*2 (H)
 03600    C
 03700   4      DIMENSION WRK(200)
 03800   5      EQUIVALENCE (ZWZ,IZW)
 03900    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
         6      COMMON /BCS/ IDATA(40000)
         7      DIMENSION HDATA(80000),ADATA(40000),IPNT(50)
         8      EQUIVALENCE (HDATA(1),IDATA(1),ADATA(1)),(IPNT(1),IDATA(55))
         9      EQUIVALENCE (NWORD,IPNT(50))
          C
          C------------------------ END OF MACRO CDATA --------------------------
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  10      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),
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 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
 04200    C
 04300  11      COMMON/CCMZCT/ DIMPCT, ZCUTV, ZCUTVV, IZVCST(5), ZCHWW
 04400    C ONLY ZCHWW WHICH IS THE WEIGHT FOR Z-CHAMBER HITS IS USED HERE
 04500    C  ARRAYS FOR Z-CHAMBER INFORMATION
 04600  12      DIMENSION IZCHMB(3,2),AZCHMB(3,2)
 04700    C
 04900  13      COMMON/JSCALD/ JESCAL,JESKEY,JESDRW                                * CALIBRATION CONSTANTS
 05000    C
 05100  14      COMMON/XYFVT1/MODXYV,NOVL
 05200    C
 05300  15      COMMON /CFLMAS/ AFLMAS
 05400  16      DIMENSION CALCST(96,27),DSTORW(5,64,24)
 05500  17      REAL GG(4,8) / 1.16872E-1,-2.58070E-1, 1.32006E-1, 286.,
 05600         +              -1.04290E-1, 8.84550E-2,-1.96380E-2, 286.,
 05700         +               3.24418E-2,-7.46600E-2, 2.36765E-2, 496.,
 05800         +              -5.75000E-2, 4.36000E-2,-1.10000E-2, 496.,
 05900         +               3.12761E-2,-1.12856E-1, 6.26170E-2, 707.,
 06000         +               5.44166E-1,-8.74361E-1, 3.05246E-1, 707.,
 06100         +               3.54954E-1,-6.67922E-1, 2.74681E-1, 707.,
 06200         +              -2.26062E-1, 3.02971E-1,-1.15400E-1, 707./
 06300  18      REAL GGF(4,8)/         0.,         0.,         0., 286.,
 06400         +                       0.,         0.,         0., 286.,
 06500         +                       0.,         0.,         0., 496.,
 06600         +                       0.,         0.,         0., 496.,
 06700         +                       0.,         0.,         0., 707.,
 06800         +               7.52764E-1,-1.10923E00, 3.47826E-1, 707.,
 06900         +               2.52785E-1,-4.63690E-1, 1.75837E-1, 707.,
 07000         +                       0.,         0.,         0., 707./
 07100  19      REAL THL(4)/-52.,-52.,-4.,960./,
 07200         +     THU(4)/-4.,-4.,960.,1570./,
 07300         +     A2(4)/-52.,-1.97924E-5,-20.5739,0./,
 07400         +     A3(4)/-9.224,700.,6.E-5,2.E-10/,
 07500         +     A4(4)/1.497,1320.,-8.31E-6,-2.73E-10/
 07600    C
 07700  20      REAL B1(4,4)/
 07800         + 0.62000E+03,   0.87300E+03,  -0.41000E+03,   0.15800E+04,
 07900         + 0.62000E+03,   0.87300E+03,  -0.41000E+03,   0.15800E+04,
 08000         + 0.57030E+03,   0.89000E+03,  -0.38000E+03,   0.15800E+04,
 08100         + 0.64300E+03,   0.90200E+03,  -0.41200E+03,   0.15800E+04/
 08200    C
 08300  21      DIMENSION Q(5,4)
 08400  22      DATA Q/14.5142,3.2743E-2,-6.E-6,0.,0.,
 08500         +       4.46445E1,-8.87962E-2,1.29605E-4,9.02461E-9,-5.85976E-11,
 08600         +       4.52471E1,-8.94577E-2,1.39668E-4,1.05065E-8,-7.46739E-11,
 08700         +       18.256,3.46596E-2,-1.26438E-5,0.,0./
 08800  23      DIMENSION P(5,4)
 08900  24      DATA P/-.955408,1.62185E-3,-8.22074E-7,0.,0.,
 09000         +       -.1736,1.41338E-3,-1.14314E-5,1.96957E-8,-7.93752E-12,
 09100         +       -.173,2.2942E-4,-2.4298E-6,0.,0.,
 09200         +       -1.0475,1.92375E-3,-1.2E-6,0.,0./
 09300    C
 09400  25      REAL OMERIN(3)/2*.130900,.0654498/,ALORIN(3)/3*.34/,
 09500         +     RR1(3)/211.,421.,632./,WIRDIS/10./,SMAXW(2,64),SM01(2,64),
 09600         +     ANG375/.0654498/,
 09700         +     FLTIM1/.028/,FLTIM2/.0363/,FLTIM3/1222.9/,ELFRCZ/.231/,
 09800         +     AVFRMX/.78742/,EPS/1.E-4/,TANLOR/.365028/,SINLOR/.342898/,
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 09900         +     COSLOR/.939373/,PIVALU/3.141593/,
 10000         +     PARVD(3)/.59562E-2,.59482E-2,.59421E-2/
 10100    C
 10200  26      DATA JESOLD/-1/,LIMPRT/0/,KIMPRT/0/,LIMPR1/3/,KIMPR1/0/
 10300    C
 10400  27      DIMENSION IRESAR(13),RESAR(13),HRESAR(13)
 10500  28      EQUIVALENCE (IRESAR(1),RESAR(1),HRESAR(1))
 10600    C
 10700    C
 10900  29      INTEGER MKLRT1 /Z1000000/, MKLRT2 /Z100/                           MASK FOR L/R BIT IN HIT LABEL
 11000    C
 11100  30      INDX=INDEX
 11200  31      IF(INDX.EQ.4) INDX=1
 11300  33      IF JESCAL.NE.JESOLD
 11400  34      THEN
 11500  37         JESOLD=JESCAL
 11600  38         IF KIMPR1.LT.LIMPR1
 11700  39         THEN
 11800  42            KIMPR1=KIMPR1+1
 11900  43            PRINT 720, JESCAL
 12000  44720      FORMAT(' **** NEW ID CALIBRATION IN EFFECT IN JFETCH AFTER ',
 12100         +      'RUN', I7,/,6X,'BIT 256 IS SET IN THE PROGRAM IDENTIFIER ',
 12200         +      'WORD OF THE PATR BANK',////)
 12300  45         CIF
 12400  46      CIF
 12500    C
 12700  47      DATA LBINIT /0/,IQJETC/0/,IQHEAD/0/                                INITIALIZATION
 12800  48      IF LBINIT .EQ. 0
 12900  49      THEN
 13000  52         LBINIT = 1
 13100  53         IQJETC = IBLN('JETC')
 13200  54         IQHEAD = IBLN('HEAD')
 13300    C
 13400  55         A5=1./.6726
 13500  56         FOR J=1,8
 13600  57            GG(1,J)=GG(1,J)*A5
 13700  58            GG(2,J)=GG(2,J)*A5*.5/GG(4,J)
 13800  59            GG(3,J)=GG(3,J)*A5*.333333/GG(4,J)**2
 13900  60            IF J.EQ.6.OR.J.EQ.7
 14000  61            THEN
 14100  64               GGF(1,J)=GGF(1,J)*A5
 14200  65               GGF(2,J)=GGF(2,J)*A5*.5/GGF(4,J)
 14300  66               GGF(3,J)=GGF(3,J)*A5*.333333/GGF(4,J)**2
 14400  67            CIF
 14500  68         CFOR
 14600    C
 14700  70         FOR I=1,64
 14800  71            IF I.LE.16
 14900  72            THEN
 15000  75               IRIN=1
 15100  76               IW=I
 15200  77            ELSE
 15300  79               IF I.LE.32
 15400  80               THEN
 15500  83                  IRIN=2
 15600  84                  IW=I-16
 15700  85               ELSE
 15800  87                  IRIN=3
 15900  88                  IW=I-32
 16000  89                  IF(IW.GT.16) IW=IW-16
 16100  91               CIF
 16200  92            CIF
 16300  93            R=RR1(IRIN)+(IW-1)*WIRDIS
 16400  94            SMAXW(1,I)=1.05*R*SIN(OMERIN(IRIN))/COS(ALORIN(IRIN)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 16500         +      -OMERIN(IRIN))
 16600  95            SMAXW(2,I)=1.05*R*SIN(OMERIN(IRIN))/COS(ALORIN(IRIN)
 16700         +      +OMERIN(IRIN))
 16800  96            SM01(1,I)=.7*SMAXW(1,I)
 16900  97            SM01(2,I)=.7*SMAXW(2,I)
 17000  98            IF IW.LT.3.OR.IW.GT.14
 17100  99            THEN
 17200 102               SM01(1,I)=.45*SMAXW(1,I)
 17300 103               SM01(2,I)=.45*SMAXW(2,I)
 17400 104            CIF
 17500 105         CFOR
 17600 107         PRINT 7777
 17700 108 7777   FORMAT(' JFTNEW : VERSION FROM 13/01/88 CALLED!',/,
 17800         &   ' +++++++++++++++++++++++++++++++++++++++++++++++++++++')
 17900 109      CIF
 18000    C
 18100 110      LHBIT  = LHIT*4
 18200 111      IPCO = 1
 18300    C
 18500 112      IPHEAD = IDATA(IQHEAD)*2                                           GET RUN #
 18600 113      NRUN = HDATA(IPHEAD+10)
 18700 114      IF NRUN.LT.24200
 18800 115      THEN
 18900 118         FREQR=1.0127
 19000 119         FLTIM2=.0363
 19100 120      ELSE
 19200 122         FREQR=1.
 19300 123         FLTIM2=0.
 19400 124      CIF
 19500 125      NEVT = HDATA(IPHEAD+11)
 19600    C
 19800 126      ITRK = IDATA(IPTR+1)                                               TRACK #
 20000 127      IDATA(IPTR+2) = LOR(IDATA(IPTR+2),256)                             SET FLAG FOR NEW CALIBRATION
 20100    C
 20300 128      IPJETC = IDATA(IQJETC)                                             POINTER TO CALIBRATED JETC BANK
 20400 129      IP0    = 2*IPJETC + 100
 20500    C++++++++
 20700 130      IPRAW=IPJETC                                                       LOCATE RAW JETC BANK
 20800 131      WHILE IDATA(IPRAW -1).GT.0
 20900 133         IPRAW =IDATA(IPRAW -1)
 21000 137      CWHILE
 21100 139      IPRAW2=2*IPRAW -2*IPJETC
 21200    C========
 21300    C
 21500 140      ZVERT = ADATA(IPTR+31)                                             ZVERT, THETA + DIR. COSINES
 21600 141      TGTH = ADATA(IPTR+30)
 21700 142      CSTH = 1./SQRT(TGTH**2 + 1.)
 21800 143      SNTH  = CSTH * TGTH
 21900    C
 22000    C
 22100    C++++++++
 22200 144      XHCS = (ADATA(IPTR+12) + ADATA(IPTR+5)) * .5
 22300 145      YHCS = (ADATA(IPTR+13) + ADATA(IPTR+6)) * .5
 22400 146      XX    =  ADATA(IPTR+12) - ADATA(IPTR+5)
 22500 147      YY    =  ADATA(IPTR+13) - ADATA(IPTR+6)
 22600 148      RR    = SQRT(XX**2+YY**2)
 22700 149      IF RR.LT.10.
 22800 150      THEN
 22900 153         IPRES=IPCO
 23000 154         RETURN
 23100 155      CIF
 23200 156      CSROT = XX / RR
 23300 157      SNROT = YY / RR
 23400 158      ALCS=.5*RR
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 23500 159      SINFIC=SNROT
 23600 160      COSFIC=CSROT
 23700 161      IF(COSFIC.GT.1.) COSFIC=1.
 23800 163      IF(COSFIC.LT.-1.) COSFIC=-1.
 23900 165      FIC=ACOS(COSFIC)
 24000 166      IF(SINFIC.LT.0.) FIC=2.*PIVALU-FIC
 24100 168      BCS1X=-XHCS*COSFIC-YHCS*SINFIC
 24200 169      BCS1Y= XHCS*SINFIC-YHCS*COSFIC
 24300 170      CURVXY=ADATA(IPTR+25)
 24400 171      IF(ABS(CURVXY).LT.1.E-8) CURVXY = SIGN(1.E-8,CURVXY)
 24500    C   FOLLOWING PARAMETERS ARE USED FOR CORRECTIONS ONLY
 24600 173      IF(ABS(CURVXY*ALCS).GT..966) CURVXY=SIGN(.966/ALCS,CURVXY)
 24700 175      CTGTH=TGTH
 24800 176      IF(ABS(CTGTH).GT.2.) CTGTH=SIGN(2.,CTGTH)
 24900    C
 25000 178      CPR0=CURVXY/SQRT(1.-(CURVXY*ALCS)**2)
 25100 179      VCRS=1./CPR0
 25200 180      CURN1=CURVXY*PARVD(2)
 25300    C========
 25400    C
 25600 181      SELECT INDX                                                        ROTATION ANGLE (USING LAST POINT OF TRACK)
 25700 182      CASE 1
 25800 184         XT = 0.
 25900 185         YT = 0.
 26000 186         CSROT = 1.
 26100 187         SNROT = 0.
 26200 188         XOT   = 0.
 26300 189      CASE 2
 26400 191         XT    = XHCS
 26500 192         YT    = YHCS
 26600 193         XOT   = 0.
 26700 194      CASE 3
 26800 196         XT    = (ADATA(IPTR+12) + XO) * .5
 26900 197         YT    = (ADATA(IPTR+13) + YO) * .5
 27000 198         XX    =  ADATA(IPTR+12) - XO
 27100 199         YY    =  ADATA(IPTR+13) - YO
 27200 200         RR    = SQRT(XX**2+YY**2)
 27300 201         CSROT = XX / RR
 27400 202         SNROT = YY / RR
 27500    C++
 27600 203         XOT   = -.5*RR
 27700 204      OTHER
 27900 209         RETURN                                                          ILLEGAL INDEX
 28000 210      CSELECT
 28100    C
 28200 211      NOVL = 0
 28300    C
 28500    C                                                                        SELECT CELLS CONTAINING TRACK
 28600 212      IPC0 = IPTR + 34
 28700 213      IPC9 = IPC0 +  5
 28800 214      FOR IPC = IPC0,IPC9
 28900 215         JCELL = IDATA(IPC)
 29000 216         IF JCELL.GT. 0 .AND. JCELL.LE.96
 29100 217         THEN
 29200 220            JRING = 1
 29300 221            IF(JCELL.GT.24) JRING = 2
 29400 223            IF(JCELL.GT.48) JRING = 3
 29500 225            PERFORM FETCH
 29600 228         CIF
 29700 229      CFOR
 29800    C
 29900    C FETCH Z-CHAMBER HITS IN CASE Z-S FITS (INDEX=4)
 30000 231      IF INDEX.EQ.4 .AND. ZCHWW.GT..1 .AND. ZCHWW.LT.2000.
 30100 232      THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 30200 235         CALL ZCFTNW(NRUN,NEVT,ITRK,TGTH,ZVERT,NZHIT,IZCHMB,AZCHMB)
 30300 236         IF NZHIT.GT.0
 30400 237         THEN
 30500 240            FOR J=1,NZHIT
 30600 241               HRESAR( 1) = 100+IZCHMB(1,J)
 30700 242               HRESAR( 2) = IZCHMB(2,J)
 30800 243               HRESAR( 3) = 0
 30900 244               HRESAR( 4) = 0
 31000 245               HRESAR( 5) = 1
 31100    C              HRESAR( 6) = IP-2*IPJETC
 31200 246               HRESAR( 6) = 101
 31300 247               XX=AZCHMB(1,J)
 31400 248               YY=AZCHMB(2,J)
 31500 249               ZZ=AZCHMB(3,J)
 31600 250               RESAR ( 4) = XX
 31700 251               RESAR ( 5) = YY
 31800 252               RESAR ( 6) = ZZ
 31900    C CALCULATE TRACK LENGTH IN R-PHI FROM FIRST POINT ON TRACK
 32000 253               UX=XX-ADATA(IPTR+5)
 32100 254               UY=YY-ADATA(IPTR+6)
 32200 255               UU=SQRT(UX**2+UY**2)
 32300 256               IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*SIN(.5*CURVXY*UU)/CURVXY
 32400 258               IF(UX*ADATA(IPTR+8)+UY*ADATA(IPTR+9).LT.0.) UU=-UU
 32500 260               RESAR ( 7) = UU
 32600    C              RESAR ( 8) = WW
 32700 261               RESAR ( 8) = ZCHWW
 32800 262               IF(NRUN.LT.24200) RESAR(8)=RESAR(8)*.6
 32900 264               CALL MVC(WRK(IPCO),0,RESAR(1),0,LHBIT)
 33000 265               IPCO = IPCO + LHIT
 33100 266            CFOR
 33200 268         CIF
 33300 269      CIF
 33400    C
 33600 270      IPRES = IPCO                                                       STORE RESULTS
 33700 271      IF INDEX.LT.4
 33800 272      THEN
 33900 275         WRK (IPRES   ) = XT
 34000 276         WRK (IPRES+ 1) = YT
 34100 277         WRK (IPRES+ 2) = CSROT
 34200 278         WRK (IPRES+ 3) = SNROT
 34300 279         WRK (IPRES+ 9) = XOT
 34400 280         WRK (IPRES+10) = 0.
 34500 281         WRK (IPRES+11) = CSTH
 34600 282         WRK (IPRES+12) = SNTH
 34700 283      CIF
 34800    C
 34900 284      RETURN
 35000    C
 35100                                                                             *************************
 35200                                                                             *      F E T C H        *
 35400    C                                                                        *************************
 35500    C
 35700 285      PROC FETCH                                                         FETCH HITS IN CELL
 35800    C
 35900    C+++++++
 36000 286         KRING=JRING
 36100 287         IF(JRING.EQ.3 .AND. JCELL-(JCELL/2)*2.NE.1) KRING=4
 36200 289         IF JCELL.LE.24
 36300 290         THEN
 36400 293            ISEG=JCELL
 36500 294         ELSE
 36600 296            IF JCELL.LE.48
 36700 297            THEN
 36800 300               ISEG=JCELL-24
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 36900 301            ELSE
 37000 303               ISEG=(JCELL-47)/2
 37100 304            CIF
 37200 305         CIF
 37300 306         FISEGM=((ISEG-1)*4+2)*ANG375
 37500 307         ACEL1=CALCST(JCELL,18)                                          IDDLE OF CELL WITHIN SEGMENT
 37600 308         ZETCEL=2.*SIN(.5*ACEL1*CURVXY)/CURVXY*TGTH+ZVERT
 37700 309         IF(ABS(ZETCEL).GT.1000.) ZETCEL=SIGN(1000.,ZETCEL)
 37800 311         ACEL1=   ACEL1        +ZETCEL*CALCST(JCELL,19)
 37900 312         BCEL1=CALCST(JCELL,20)+ZETCEL*CALCST(JCELL,21)
 38000 313         OCEL1=CALCST(JCELL,22)+ZETCEL*CALCST(JCELL,23)
 38100 314         FIIC=FISEGM+OCEL1-FIC
 38200 315         ACEL2=CALCST(JCELL,19)*CTGTH*WIRDIS
 38300 316         BCEL2=CALCST(JCELL,21)*CTGTH*WIRDIS
 38400 317         OCEL2=CALCST(JCELL,23)*CTGTH*WIRDIS
 38500 318         ROT1X=COS(FIIC)
 38600 319         ROT1Y=SIN(FIIC)
 38700 320         ROT2X=SIN(FIC-FISEGM)
 38800 321         ROT2Y=COS(FIC-FISEGM)
 38900 322         BCS1XC=BCS1X+ACEL1*ROT2Y+BCEL1*ROT2X
 39000 323         BCS1YC=BCS1Y-ACEL1*ROT2X+BCEL1*ROT2Y
 39100    C=========
 39200    C
 39400 324         JHIT = 0                                                        COUNTER FOR NUMBER OF HITS FOUND
 39500 325         NHIT   = 0
 39600 326         NHGOOD = 0
 39800 327         ILAYL =-99                                                      PRESET LAST LAYER
 40000 328         IPCO = IPCO - LHIT                                              LOOP OVER ALL HITS OF CELL
 40100 329         IPCLL  = 2*IPJETC + 2 + JCELL
 40200 330         IP     = HDATA(IPCLL  ) + IP0
 40300 331         IP9    = HDATA(IPCLL+1) + IP0
 40400 332         IPHL   = IPJHTL + 2 + HDATA(IPCLL)/4
 40500 333         WHILE IP.LT.IP9
 40600    C
 40800 335            LB   = IDATA(IPHL)                                           CHECK TRACK # OF HIT LABEL
 40900 339            ITR1 = LAND(SHFTR(LB,17),127)
 41000 340            ITR2 = LAND(SHFTR(LB, 1),127)
 41100 341            IF ITR1.EQ.ITRK .OR. ITR2.EQ.ITRK
 41200 342            THEN
 41300    C
 41500 345               L0GOOD = 0                                                SET LBGOOD =  2,11,12 IF HIT ASSOCIATED WITH 2 TRA
 41600 346               IF ITR1.NE.0 .AND. ITR2.NE.0
 41700 347               THEN
 41800 350                  NOVL   = NOVL + 1
 41900 351                  L0GOOD = 11
 42000 352                  ID1    = LAND(SHFTR(LB,27), 31)
 42100 353                  ID2    = LAND(SHFTR(LB,11), 31)
 42200 354                  IF ITR1 .EQ. ITRK
 42300 355                  THEN
 42400 358                     IF( ID1 .LT. ID2 ) L0GOOD = 2
 42500 360                     IF( ID1 .GT. ID2 ) L0GOOD = 12
 42600 362                  ELSE
 42700 364                     IF( ID2 .LT. ID1 ) L0GOOD = 2
 42800 366                     IF( ID2 .GT. ID1 ) L0GOOD = 12
 42900 368                  CIF
 43000 369               CIF
 43100    C
 43300 370               LBLR = 0                                                  L/R FROM HIT LABEL
 43400 371               IF(ITR1.EQ.ITRK) LBLR = LAND(LB,MKLRT1)
 43500 373               IF(ITR2.EQ.ITRK) LBLR = LAND(LB,MKLRT2)
 43600 375               LBSIDE =-1
 43700 376               IF(LBLR.NE.0) LBSIDE = 1
 43800 378               LBLR = LBSIDE
 43900    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 44000 379               IWIR = HDATA(IP)
 44100 380               IWIR = SHFTR(IWIR,3)
 44300 381               ILAY = LAND(IWIR,15)                                      LAYER NUMBER WITHIN RING 3
 44500 382               IAMPL = HDATA(IP+1)                                       AMPLITUDES
 44600 383               IAMPR = HDATA(IP+2)
 44800    C           IF IAMPR.LE.0.OR.IAMPL.LE.0                                  CALCULATE Z COORDINATE
 44900    C           THEN
 45000    C             ZZ     = 0.
 45100    C             LZGOOD = 16
 45200    C           ELSE
 45300    C             ZZ = IAMPR + IAMPL
 45400    C             ZZ = FLOAT(IAMPR-IAMPL) * ZAL*.5 / ZZ
 45500    C             LZGOOD = 0
 45600    C             IF(ABS(ZZ).GT.1250.) LZGOOD = 16
 45700    C           CIF
 45800 384               CALL AMPS2Z( IP,IPJETC,ZZ,WW,LZGOOD)
 45900    C
 46000    C+++++++
 46200 385               IW=ILAY+1                                                 WIRE NUMBER WITHIN CELL 1..16
 46300 386               IODD=1
 46400 387               IF(IW-(IW/2)*2.EQ.0) IODD=-1
 46500 389               RHIT=ACEL1+(IW-8.5)*WIRDIS
 46600 390               FLPATH=2.*SIN(.5*RHIT*CURVXY)/CURVXY
 46700 391               ZHIT=FLPATH*TGTH+ZVERT
 46800 392               IF(ABS(ZHIT).GT.1200.) ZHIT=SIGN(1200.,ZHIT)
 46900 394               FLPATH=SQRT(FLPATH**2+ZHIT**2)
 47000    C
 47200 395               TDRIFT=HDATA(IP+3+IPRAW2)                                 DRIFT TIME (FROM RAW BANK) + CORRECTIONS
 47300 396               IF NRUN.LT.24200
 47400 397               THEN
 47500 400                  TDRIFT=TDRIFT*64.+32.
 47600 401                  IF(NRUN.GE.19050.AND.NRUN.LE.20274) TDRIFT=TDRIFT+20.
 47700 403                  IF(NRUN.GE. 3300.AND.NRUN.LE. 3550) TDRIFT=TDRIFT-90.
 47800 405               ELSE
 47900 407                  IF NRUN.LE.24698
 48000 408                  THEN
 48100 411                     TDRIFT=TDRIFT-5.
 48200 412                     IF(NRUN.LT.24405) TDRIFT=TDRIFT+153.
 48300 414                     IF(NRUN.GE.24227.AND.NRUN.LE.24232) TDRIFT=TDRIFT+147.
 48400 416                     IF(NRUN.GE.24233.AND.NRUN.LE.24245) TDRIFT=TDRIFT+297.
 48500 418                  CIF
 48600 419               CIF
 48700 420               AMRAWL=HDATA(IP+1+IPRAW2)*8.
 48800 421               AMRAWR=HDATA(IP+2+IPRAW2)*8.
 49000 422               PERFORM SLWCOR                                            SLEWING CORRECTION
 49200 425               IF(JRING.EQ.3) TDRIFT=TDRIFT*FREQR                        CLOCK FREQUENCY
 49400 427               BKGS=ABS(HDATA(IPHEAD+30)*.001)                           FLIGHT AND PROPAGATION TIME
 49500 428               IF(BKGS.LT.3.) BKGS=4.8
 49600 430               AMOMGV=.02998E-3*BKGS*SQRT(1.+CTGTH**2)/CURVXY
 49700 431               CPERV=SQRT(1.+(AFLMAS/AMOMGV)**2)
 49800 432               TDRIFT=TDRIFT-FLTIM1*FLPATH*CPERV-FLTIM2*(FLTIM3-ABS(ZHIT))
 50000 433               TDRIFT=TDRIFT-CALCST(JCELL,IW)                            T0
 50200 434               TSTG=CALCST(JCELL,17)*(1.-ELFRCZ*(ZHIT/1200.)**2)         * CALCULATE "WIRE NUMBER CORRECTION"
 50300         +         *AVFRMX*SINLOR*PARVD(JRING)/WIRDIS
 50400 435               XK=IW-IODD*TSTG-8.5
 50500 436               ROT3X=XK*WIRDIS*(ROT1X-ROT1Y*XK*OCEL2)
 50600 437               ROT3Y=XK*WIRDIS*(ROT1Y+ROT1X*XK*OCEL2)
 50800 438               XWPR=ROT3X+BCS1XC+XK*( ACEL2*ROT2Y+BCEL2*ROT2X)           * WIRE IN THE "CIRCLE" SYSTEM
 50900 439               YWPR=ROT3Y+BCS1YC+XK*(-ACEL2*ROT2X+BCEL2*ROT2Y)
 51000    C========
 51200 440               NLRSOL = 1                                                CHECK IF LEFT + RIGHT SOLUTION POSSIBLE
 51300    C++
 51400 441               IF(TDRIFT.LT.300.) NLRSOL = 2
 51500    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 51700 443               ILRSOL = 0                                                LOOP OVER LEFT +/OR RIGHT SOLUTION
 51800 444               REPEAT
 51900 445                  ILRSOL = ILRSOL + 1
 52000 446                  LBGOOD = L0GOOD
 52100    C
 52300 447                  IF NLRSOL.EQ.1 .AND. LBSIDE.LT.0  .OR.                 SELECT SIDE
 52400         ?               NLRSOL.EQ.2 .AND. ILRSOL.EQ.1
 52500 448                  THEN
 52700 451                     LBSIDE =-1                                          LEFT SIDE
 52800    C++
 52900 452                     PERFORM GETCOR
 53000 455                  ELSE
 53200 457                     LBSIDE = 1                                          RIGHT SIDE
 53300    C++
 53400 458                     PERFORM GETCOR
 53500 461                  CIF
 53600    C
 53800 462                  IF(LBSIDE.NE.LBLR) LBGOOD = LBGOOD + 1                 HIT QUALITY:
 54000 464                  IF ILAY.NE.ILAYL .OR. LBGDL.LE.1.AND.LBGOOD.LE.2       NEW LAYER?
 54100 465                  THEN
 54200 468                     LBREG = 1
 54400 469                     JHIT = JHIT + 1                                     INCREASE HIT COUNTER
 54500 470                     IPCO = IPCO + LHIT
 54600 471                  ELSE
 54800 473                     LBREG = 0                                           2 HITS IN SAME LAYER, SELECT CLOSEST
 54900 474                     ZWZ = WRK(IPCO+10)
 55000 475                     IF(LBGOOD.LT.IZW) LBREG = 1
 55100 477                  CIF
 55300 478                  IF LBREG.NE.0                                          REGISTER NEW HIT?
 55400 479                  THEN
 55500 482                     NHIT   = NHIT   + 1
 55600 483                     IF(LBGOOD.LE.2) NHGOOD = NHGOOD + 1
 55700 485                     IF INDEX.NE.4
 55800 486                     THEN
 55900 489                        IRESAR( 1) = ILAY
 56000 490                        IRESAR( 2) = IP
 56100 491                        IRESAR( 3) = LBSIDE
 56200 492                        RESAR ( 4) = XX
 56300 493                        RESAR ( 5) = YY
 56400 494                        RESAR ( 6) = ZZ
 56500 495                        RESAR ( 7) = XX - XOT
 56600 496                        IF(INDX.EQ.1) RESAR ( 7) = SQRT(XX**2 + YY**2)
 56700 498                        IRESAR( 8) = LZGOOD
 56800 499                        RESAR ( 9) = DSC
 56900 500                        IRESAR(10) = JCELL
 57000 501                        IRESAR(11) = LBGOOD
 57100 502                        RESAR (12) = TANBET
 57200 503                        IRESAR(13) = JRING
 57300 504                        RESAR (14) = 0.
 57400 505                     ELSE
 57500 507                        HRESAR( 1) = JCELL
 57600 508                        HRESAR( 2) = ILAY
 57700 509                        HRESAR( 3) = LZGOOD
 57800 510                        HRESAR( 4) = LBGOOD
 57900 511                        HRESAR( 5) = 1
 58000 512                        HRESAR( 6) = IP-2*IPJETC
 58100 513                        RESAR ( 4) = XX
 58200 514                        RESAR ( 5) = YY
 58300 515                        RESAR ( 6) = ZZ
 58400    C CALCULATE TRACK LENGTH IN R-PHI FROM FIRST POINT ON TRACK
 58500 516                        UX=XX-ADATA(IPTR+5)
 58600 517                        UY=YY-ADATA(IPTR+6)
 58700 518                        UU=SQRT(UX**2+UY**2)
 58800 519                        IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*SIN(.5*CURVXY*UU)/CURVXY
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 58900 521                        IF(UX*ADATA(IPTR+8)+UY*ADATA(IPTR+9).LT.0.) UU=-UU
 59000 523                        RESAR ( 7) = UU
 59100 524                        RESAR ( 8) = WW
 59200 525                     CIF
 59300 526                     CALL MVC(WRK(IPCO),0,RESAR(1),0,LHBIT)
 59400 527                     ILAYL = ILAY
 59500 528                     LBGDL = LBGOOD
 59600 529                  CIF
 59700    C
 59800 530               UNTIL ILRSOL.GE.NLRSOL
 59900    C
 60000 531            CIF
 60100    C
 60200 535            IPHL = IPHL + 1
 60300 536            IP   = IP   + 4
 60400 537         CWHILE
 60600 539         IPCO = IPCO + LHIT                                              SET IPCO TO 1. FREE LOCATION
 60700    C
 60800 540      CPROC
 60900    C
 61000                                                                             *************************
 61100                                                                             *      G E T C O R      *
 61300    C                                                                        *************************
 61400 542      PROC GETCOR
 61500 543         IF LBSIDE.LT.0
 61600 544         THEN
 61700 547            AG2= CALCST(JCELL,26)
 61800 548            VDP=-CALCST(JCELL,24)
 61900 549         ELSE
 62000 551            AG2= CALCST(JCELL,27)
 62100 552            VDP= CALCST(JCELL,25)
 62200 553         CIF
 62300 554         AG2=AG2-FIIC-XK*OCEL2
 62400 555         SINAG2=SIN(AG2)
 62500 556         COSAG2=COS(AG2)
 62600    C CALCULATE DELTA=SIGNED CHANGE OF DRIFT TIME PRO WIRE SPACING
 62700 557         F=XWPR*SINAG2+(YWPR+VCRS)*COSAG2
 62800 558         G=(ALCS-XWPR)*(ALCS+XWPR)-YWPR*(YWPR+2.*VCRS)
 62900 559         IF G.GT.-.98*F**2
 63000 560         THEN
 63200 563            PERFORM CALSQT                                               * WIRE CIRCLE DISTANCE ALONG DRIFT DIR.
 63300 566            DISTWC=SQTVAL
 63400 567            XPR=XWPR+DISTWC*SINAG2
 63500 568            DYPDXP=1.-(CURVXY*XPR)**2
 63600 569            IF DYPDXP.LT..02
 63700 570            THEN
 63800 573               IF KIMPRT.LT.LIMPRT
 63900 574               THEN
 64000 577                  KIMPRT=KIMPRT+1
 64100 578                  PRINT 675,CURVXY,ALCS,XPR,NRUN,NEVT,ITRK
 64200 579675      FORMAT(' *** ERROR IN JFTNEW *** CURVATURE, HALF TRACK LENGTH',
 64300         +            ' X IN TR C.S.',/,8X,3E15.5,'   TRACK',I9,I6,I4)
 64400    C
 64500 580                  PRINT 676, CPR0,VCRS,XHCS,YHCS,FIC,TGTH,
 64600         +            XWPR,YWPR,AG2,F,G,DISTWC,DYPDXP,
 64700         +            KRING,JCELL,ISEG,FISEGM,IW,IODD,ILRSOL,LBSIDE
 64800 581676               FORMAT(/,' CPR0,VCRS,XHCS,YHCS,FIC,TGTH,',/,
 64900         +            ' XWPR,YWPR,AG2,F,G,DISTWC,DYPDXP,'/,
 65000         +            ' KRING,JCELL,ISEG,FISEGM,IW,IODD,ILRSOL,LBSIDE',/,
 65100         +            1X,6E15.5,/,1X,7E15.5,/,1X,3I4,E15.5,4I6,////)
 65200 582               CIF
 65300 583               DYPDXP=.02
 65400 584            CIF
 65500 585            DYPDXP=-XPR*CURVXY/SQRT(DYPDXP)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 65600 586            C=1.-DYPDXP*SINAG2/COSAG2
 65700 587            IF(ABS(C).LT..001) C=SIGN(.001,C)
 65800 589            TANBET=(DYPDXP+SINAG2/COSAG2)/C
 65900 590            AMU=WIRDIS/PARVD(JRING)*COSLOR
 66000 591            DELTA=AMU*(TANBET-TANLOR)
 66100 592            IF(ABS(DELTA).GT.1800.) DELTA=SIGN(1800.,DELTA)
 66200 594         ELSE
 66300    C           HIT CAN NOT BE ON THE TRACK. FOR ANGLE DEPENDENT
 66400    C           CORRECTIONS A TRACK PARALELL WITH THE WIRE PLANE
 66500    C           WILL BE ASSUMED
 66600 596            IF KIMPRT.LT.LIMPRT
 66700 597            THEN
 66800 600               KIMPRT=KIMPRT+1
 66900 601               PRINT 674,CURVXY,ALCS,NRUN,NEVT,ITRK
 67000 602674      FORMAT(' *** ERROR IN JFTNEW *** CURVATURE, HALF TRACK LENGTH',
 67100         +         /,8X,2E15.5,'   TRACK',I9,I6,I4)
 67200 603               PRINT 677, CPR0,VCRS,XHCS,YHCS,FIC,TGTH,
 67300         +         XWPR,YWPR,AG2,F,G,
 67400         +         KRING,JCELL,ISEG,FISEGM,IW,IODD,ILRSOL,LBSIDE
 67500 604677            FORMAT(/,' CPR0,VCRS,XHCS,YHCS,FIC,TGTH,',/,
 67600         +         ' XWPR,YWPR,AG2,F,G,'/,
 67700         +         ' KRING,JCELL,ISEG,FISEGM,IW,IODD,ILRSOL,LBSIDE',/,
 67800         +         1X,6E15.5,/,1X,5E15.5,/,1X,3I4,E15.5,4I6,////)
 67900 605            CIF
 68000 606            TANBET=TANLOR
 68100 607            DELTA=0.
 68200 608         CIF
 68300    C
 68500 609         PERFORM SLWZTH                                                  *  Z AND THETA DEPENDENT SLEWING
 68700 612         PERFORM CLWCOR                                                  * CLOSE WIRE CORRECTION
 68900 615         PERFORM STGANG                                                  * CORRECT FOR STAGGERING AND TRACK ANGLE FI
 69000    C
 69200 618         Y1=VDP*TCORR                                                    * DISTANCE FROM WIRE
 69400 619         IF(JESDRW.GT.0) PERFORM DSTRTN                                  * DISTORTIONS
 69500 623         DSC=ABS(Y1)
 69600 624         XX=XWPR+Y1*SINAG2
 69700 625         YY=YWPR+Y1*COSAG2
 69800 626         IF INDX.NE.2
 69900 627         THEN
 70000 630            A= XX*COSFIC-YY*SINFIC+XHCS
 70100 631            YY=XX*SINFIC+YY*COSFIC+YHCS
 70200 632            XX=A
 70300 633            IF INDX.EQ.3
 70400 634            THEN
 70500 637               A = (XX-XT)*CSROT+(YY-YT)*SNROT
 70600 638               YY=-(XX-XT)*SNROT+(YY-YT)*CSROT
 70700 639               XX=A
 70800 640            CIF
 70900 641         CIF
 71000 642      CPROC
 71100    C
 71200                                                                             *************************
 71300                                                                             *      S L W C O R      *
 71500    C                                                                        *************************
 71600 644      PROC SLWCOR
 71700 645         A=AMRAWL
 71800 646         IF(AMRAWR.GT.A) A=AMRAWR
 71900 648         IF(A.LT.10.) A=10.
 72100 650         IF NRUN.GE. 24200                                               SLEWING FOR RAW AMPLITUDES
 72200 651         THEN
 72300 654            IF A.GT.1800.
 72400 655            THEN
 72500 658               TSLEW=-1.449+1.19097E-3*(A-2000.)
 72600 659            ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 12
0CARD TARGET
  NO  STM.NO
 
 72700 661               TSLEW=-2.100+2.11521E-3*(A-1600.)-8.50349E-12*(1600.-A)**4
 72800 662            CIF
 72900 663         ELSE
 73000 665            IF A.GT.5000.
 73100 666            THEN
 73200 669               TSLEW=-50.+5.80000E-3*(A-5000.)
 73300 670            ELSE
 73400 672               IF A.LT.300.
 73500 673               THEN
 73600 676                  TSLEW=-200.
 73700 677               ELSE
 73800 679                  TSLEW=-4472.05*A**(-5.23557E-1-6.42692E-3*(ALOG(A)-7.77529)**2)
 73900 680                  IF(NRUN.GE.20275.AND.A.LT.1500.)
 74000         +            TSLEW=TSLEW-(A-1500.)**2*2.26664E-5
 74100 682               CIF
 74200 683               IF(A.LT.650. .AND.(NRUN.GE.20275 .OR.
 74300         +         NRUN.GE.13000 .AND. NRUN.LE. 14599) )
 74400         +         TSLEW=TSLEW+116.6-1.79687E-1*A
 74500 685               IF(A.LT.800. .AND. NRUN.GE.11473 .AND. NRUN.LE.12554)
 74600         +         TSLEW=TSLEW+139.4-1.74800E-1*A
 74700 687            CIF
 74800 688         CIF
 74900 689         TDRIFT=TDRIFT+TSLEW
 75000 690      CPROC
 75100    C
 75200                                                                             *************************
 75300                                                                             *      S L W Z T H      *
 75500    C                                                                        *************************
 75600 692      PROC SLWZTH
 75700 693         ACTG=ABS(CTGTH)
 75800 694         IF NRUN.GE. 24200
 75900 695         THEN
 76000 698            ZTSLW=0.
 76100 699            IF KRING.EQ.4
 76200 700            THEN
 76300 703               IF LBSIDE.LT.0
 76400 704               THEN
 76500 707                  ZTSLW=-19.43-14.5942*ACTG+19.8951*ACTG**2
 76600 708                  IF ACTG.LT..42
 76700 709                  THEN
 76800 712                     ZTSLW=ZTSLW+5.1921+3.216*ACTG-82.49*ACTG**2
 76900 713                  ELSE
 77000 715                     ZTSLW=ZTSLW-24.66+48.9578*ACTG-22.7265*ACTG**2
 77100 716                  CIF
 77200 717               ELSE
 77300 719                  ZTSLW=5.918-5.45559*ACTG-2.12*ACTG**2
 77400 720               CIF
 77500 721            CIF
 77600 722            IF KRING.EQ.3
 77700 723            THEN
 77800 726               IF LBSIDE.LT.0
 77900 727               THEN
 78000 730                  ZTSLW=-.937-8.66313*ACTG+9.8988*ACTG**2
 78100 731               ELSE
 78200 733                  ZTSLW= 2.46- 3.8375*ACTG-14.5671*ACTG**2
 78300 734               CIF
 78400 735            CIF
 78500 736            J=2*KRING
 78600 737            IF(LBSIDE.LT.0) J=J-1
 78700 739            IF J.EQ.6.OR.J.EQ.7
 78800 740            THEN
 78900 743               AZ=ABS(ZHIT)
 79000 744               BZ=ACTG*GGF(4,J)
 79100 745               ZTSLW=ZTSLW+(AZ-BZ)*(GGF(1,J)+GGF(2,J)*(AZ+BZ)+GGF(3,J)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 13
0CARD TARGET
  NO  STM.NO
 
 79200         +         *(AZ*(AZ+BZ)+BZ**2))
 79300 746            CIF
 79400 747         ELSE
 79500 749            IF KRING.EQ.1
 79600 750            THEN
 79700 753               ZTSLW=13.46-14.03*ACTG
 79800 754            ELSE
 79900 756               IF KRING.EQ.2
 80000 757               THEN
 80100 760                  ZTSLW=15.23-31.278*ACTG+7.54731*ACTG**2
 80200 761               ELSE
 80300 763                  ZTSLW=20.86-48.672*ACTG+13.663*ACTG**2
 80400 764               CIF
 80500 765            CIF
 80600    C
 80700 766            IF KRING.EQ.1
 80800 767            THEN
 80900 770               IF LBSIDE.LT.0
 81000 771               THEN
 81100 774                  IF ACTG.LT..37
 81200 775                  THEN
 81300 778                     T1=10.30-26.1*ACTG
 81400 779                  ELSE
 81500 781                     T1=3.88-18.5345*ABS(ACTG-.5427)
 81600 782                  CIF
 81700 783                  T1=T1-0.30+ 0.77*ACTG-0.7648*ACTG**2
 81800 784               ELSE
 81900 786                  IF ACTG.LT..37
 82000 787                  THEN
 82100 790                     T1=7.50-26.3*ACTG
 82200 791                  ELSE
 82300 793                     T1=-1.95+6.84118*ABS(ACTG-.4)
 82400 794                  CIF
 82500 795                  T1=T1+3.21-14.10*ACTG+10.73*ACTG**2
 82600 796               CIF
 82700 797               ZTSLW=ZTSLW+T1
 82800 798            CIF
 82900 799            IF KRING.EQ.2
 83000 800            THEN
 83100 803               IF LBSIDE.LT.0
 83200 804               THEN
 83300 807                  IF ACTG.LT..40
 83400 808                  THEN
 83500 811                     T1=8.787-19.675*ACTG
 83600 812                  ELSE
 83700 814                     T1=4.091-18.133*ABS(ACTG-.56)
 83800 815                  CIF
 83900 816               ELSE
 84000 818                  IF ACTG.LT..48
 84100 819                  THEN
 84200 822                     T1=1.983-12.667*ACTG
 84300 823                  ELSE
 84400 825                     T1=-4.1125+13.574*ABS(ACTG-.5)
 84500 826                  CIF
 84600 827               CIF
 84700 828               ZTSLW=ZTSLW+T1
 84800 829            CIF
 84900 830            IF KRING.EQ.3
 85000 831            THEN
 85100 834               T1=8.336-12.3519*ACTG
 85200 835               IF LBSIDE.LT.0
 85300 836               THEN
 85400 839                  T1=T1-2.68+18.09*ACTG-15.95*ACTG**2
 85500 840               ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 14
0CARD TARGET
  NO  STM.NO
 
 85600 842                  T1=T1+1.20-14.489*ACTG+14.623*ACTG**2
 85700 843                  IF(NRUN.GE.8712.AND.NRUN.LE.9999)
 85800         +            T1=T1+14.20-8.5415*ACTG-10.6000*ACTG**2
 85900 845                  IF(NRUN.GE.7592.AND.NRUN.LE.8711)
 86000         +            T1=T1+4.16+17.97*ACTG-24.33*ACTG**2
 86100 847               CIF
 86200 848               ZTSLW=ZTSLW+T1
 86300 849            CIF
 86400 850            IF KRING.EQ.4
 86500 851            THEN
 86600 854               IF ACTG.LT..56
 86700 855               THEN
 86800 858                  T1=5.58-15.183*ACTG
 86900 859               ELSE
 87000 861                  T1=-3.30+8.1613*(ACTG-.5)
 87100 862               CIF
 87200 863               IF LBSIDE.LT.0
 87300 864               THEN
 87400 867                  T1=T1+3.12-21.16*ACTG+18.90*ACTG**2
 87500 868                  IF(NRUN.GE.11038.AND.NRUN.LE.12554)
 87600         +            T1=T1+.39+29.1785*ACTG-30.4402*ACTG**2
 87700 870                  IF(NRUN.GE.8712.AND.NRUN.LE.9999)
 87800         +            T1=T1+7.30+13.8*ACTG-23.20*ACTG**2
 87900 872                  IF(NRUN.GE.7592.AND.NRUN.LE.8711)
 88000         +            T1=T1+0.16+ 9.08*ACTG- 9.60*ACTG**2
 88100 874                  IF(NRUN.GE.6185.AND.NRUN.LE.7591)
 88200         +            T1=T1-16.6+41.18*ACTG-20.60*ACTG**2
 88300 876               ELSE
 88400 878                  T1=T1-0.62+12.25*ACTG-10.52*ACTG**2
 88500 879               CIF
 88600 880               ZTSLW=ZTSLW+T1
 88700 881            CIF
 88800    C
 88900 882            J=2*KRING
 89000 883            IF(LBSIDE.LT.0) J=J-1
 89100 885            AZ=ABS(ZHIT)
 89200 886            BZ=ACTG*GG(4,J)
 89300 887            ZTSLW=ZTSLW+(AZ-BZ)*(GG(1,J)+GG(2,J)*(AZ+BZ)+GG(3,J)
 89400         +      *(AZ*(AZ+BZ)+BZ**2))
 89500 888            IF KRING.GE.3
 89600 889            THEN
 89700 892               ZTSLW=ZTSLW+1.70E-2/.6727*(ZHIT-CTGTH*GG(4,J))
 89800 893            CIF
 89900    C
 90000 894            IF(KRING.GE.3) ZTSLW=ZTSLW*FREQR
 90100 896         CIF
 90200 897         TCORR=TDRIFT+ZTSLW
 90300 898      CPROC
 90400    C
 90500                                                                             *************************
 90600                                                                             *      C L W C O R      *
 90800    C                                                                        *************************
 90900 900      PROC CLWCOR
 91000    C     APPLY CLOSE WIRE CORRECTION
 91100 901         IF TCORR.LT.THU(4)
 91200 902         THEN
 91300 905            TCOR=TCORR
 91400 906            IF TCOR.GT.THL(4)
 91500 907            THEN
 91600 910               TCOR=TCOR+A4(1)+A4(3)*(TCOR-A4(2))**2+A4(4)*(TCOR-A4(2))**4
 91700 911            ELSE
 91800 913               IF TCOR.GT.THL(3)
 91900 914               THEN
 92000 917                  TCOR=TCOR+A3(1)+A3(3)*(TCOR-A3(2))**2
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 15
0CARD TARGET
  NO  STM.NO
 
 92100         +            +A3(4)*(TCOR-A3(2))**4
 92200 918               ELSE
 92300 920                  IF TCOR.GT.THL(2)
 92400 921                  THEN
 92500 924                     TCOR=TCOR-A2(1)+A2(2)*((TCOR-A2(3))**4-
 92600         +               (A2(1)-A2(3))**4)
 92700 925                  ELSE
 92800 927                     TCOR=TCOR-A2(1)
 92900 928                  CIF
 93000 929               CIF
 93100 930            CIF
 93200 931            IF(TCOR.GT.0..AND.TCOR.LT.120.) TCOR=TCOR-8.E-2*(TCOR-120.)
 93300 933            TCORR=TCOR
 93400 934         CIF
 93500 935      CPROC
 93600    C
 93700                                                                             *************************
 93800                                                                             *      S T G A N G      *
 94000    C                                                                        *************************
 94100 937      PROC STGANG
 94200 938         PERFORM STGFIZ
 94300 941         STGTC=CALCST(JCELL,17)*IODD*LBSIDE*STGCOR
 94400    C
 94500 942         IF DELTA.GT.B1(3,KRING)
 94600 943         THEN
 94700 946            A12=B1(2,KRING)
 94800 947         ELSE
 94900 949            A12=B1(1,KRING)
 95000 950         CIF
 95100 951         CSGINV=SQRT(1.+((DELTA-B1(3,KRING))/B1(4,KRING))**2)
 95200 952         IF TCORR.GT.A12
 95300 953         THEN
 95400    C           Y=A12*CURN1*LBSIDE
 95500    C           IF ABS(Y).GT.1.E-5
 95600    C           THEN
 95700    C!!            TANGCC=A12*(-SQTVAL(1./(Y*CSGINV),1.-2./Y,1.,1.E-4)-1.)
 95800    C           ELSE
 95900 956            TANGCC=A12*(CSGINV-1.)
 96000    C           CIF
 96100 957         ELSE
 96200    C           Y=TCORR*CURN1*LBSIDE
 96300    C           IF ABS(Y).GT.1.E-5
 96400    C           THEN
 96500    C !!           TANGCC=TCORR*(SQTVAL(1./(Y*CSGINV),1.-2./Y,1.,1.E-4)+1.)
 96600    C           ELSE
 96700 959            TANGCC=TCORR*(CSGINV-1.)
 96800    C           CIF
 96900 960         CIF
 97000 961         TCORR=TCORR+TANGCC+STGTC
 97100 962      CPROC
 97200    C
 97300                                                                             *************************
 97400                                                                             *      S T G F I Z      *
 97600    C                                                                        *************************
 97700 964      PROC STGFIZ
 97800    C
 97900 965         D=DELTA
 98000 966         Z=ZHIT
 98100 967         PERFORM STGZ0
 98200 970         PERFORM FRACT
 98300 973         U=(Z/1200.)**2
 98400 974         STGCOR=STGDZ0*(1.+U*FRACZD)
 98500 975         IF(STGCOR.LT..2) STGCOR=.2
 98600 977      CPROC
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 16
0CARD TARGET
  NO  STM.NO
 
 98700    C-----------------------------------------------------------------------
 98800 979      PROC STGZ0
 99000 980         IF D.LT.-600.                                                   * CALCULATE D DEPENDENT STAG FRAC AT Z=0
 99100 981         THEN
 99200 984            I=1
 99300 985         ELSE
 99400 987            IF D.LT.0.
 99500 988            THEN
 99600 991               I=2
 99700 992            ELSE
 99800 994               IF D.LT.600.
 99900 995               THEN
 00000 998                  I=3
 00100 999               ELSE
 002001001                  I=4
 003001002               CIF
 004001003            CIF
 005001004         CIF
 006001005         STGDZ0=Q(1,I)+ABS(D)*(Q(2,I)+Q(4,I)*D**2)+Q(3,I)*D**2
 00700         +   +Q(5,I)*D**4
 008001006         STGDZ0=STGDZ0/44.9444
 009001007      CPROC
 01000    C-----------------------------------------------------------------------
 011001009      PROC FRACT
 013001010         IF D.LT.-500.                                                   * CALCULATE D DEPENDENT EL.STAT.FRACTION
 014001011         THEN
 015001014            I=1
 016001015         ELSE
 017001017            IF D.LT.0.
 018001018            THEN
 019001021               I=2
 020001022            ELSE
 021001024               IF D.LT.400.
 022001025               THEN
 023001028                  I=3
 024001029               ELSE
 025001031                  I=4
 026001032               CIF
 027001033            CIF
 028001034         CIF
 029001035         FRACZD=P(1,I)+ABS(D)*(P(2,I)+P(4,I)*D**2)+P(3,I)*D**2
 03000         +   +P(5,I)*D**4
 031001036      CPROC
 03200    C
 03300                                                                             *************************
 03400                                                                             *      D S T R T N      *
 03600    C                                                                        *************************
 037001038      PROC DSTRTN
 03800    C
 039001039         IWR=(KRING-1)*16+IW
 040001040         IF Y1.GT.0.
 041001041         THEN
 042001044            IND=2
 043001045         ELSE
 044001047            IND=1
 045001048         CIF
 046001049         SMAX=SMAXW(IND,IWR)
 047001050         SM0=SM01(IND,IWR)
 048001051         Y1COR=DSTORW(2*IND,IWR,ISEG)*Y1**2    +   DSTORW(5,IWR,ISEG)
 049001052         S0=ABS(Y1)-SM0
 050001053         IF(S0.GT.0.) Y1COR=Y1COR+DSTORW(2*IND-1,IWR,ISEG)*S0**2
 051001055         IF IW.EQ.1 .OR. IW.EQ.16
 052001056         THEN
 053001059            X=ABS(Y1/SMAX)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 17
0CARD TARGET
  NO  STM.NO
 
 054001060            IF IWR.EQ.1
 055001061            THEN
 056001064               IF IND.EQ.2
 057001065               THEN
 058001068                  IF X.LT..52
 059001069                  THEN
 060001072                     T=-.07*(1.-((2.*X-.52)/.52)**2)
 061001073                  ELSE
 062001075                     IF X.LT.1.
 063001076                     THEN
 064001079                        T=.05*(1.-((2.*X-1.37)/.33)**2)
 065001080                     ELSE
 066001082                        T=-.13
 067001083                     CIF
 068001084                  CIF
 069001085               ELSE
 070001087                  IF X.LT..52
 071001088                  THEN
 072001091                     T=-.05*(1.-((2.*X-.52)/.52)**2)
 073001092                  ELSE
 074001094                     IF X.LT.1.
 075001095                     THEN
 076001098                        T=.035*(1.-((2.*X-1.34)/.30)**2)
 077001099                     ELSE
 078001101                        T=-.13
 079001102                     CIF
 080001103                  CIF
 081001104               CIF
 082001105            CIF
 083001106            IF IWR.EQ.16
 084001107            THEN
 085001110               IF IND.EQ.2
 086001111               THEN
 087001114                  IF X.LT..42
 088001115                  THEN
 089001118                     T=.075*(1.-((2.*X-.42)/.42)**2)
 090001119                  ELSE
 091001121                     IF X.LT..67
 092001122                     THEN
 093001125                        T=-.06*(1.-((2.*X-1.09)/.25)**2)
 094001126                     ELSE
 095001128                        IF X.LT..9
 096001129                        THEN
 097001132                           T= .06*(1.-((2.*X-1.53)/.19)**2)
 098001133                        ELSE
 099001135                           T=-.080
 100001136                        CIF
 101001137                     CIF
 102001138                  CIF
 103001139               ELSE
 104001141                  IF X.LT..50
 105001142                  THEN
 106001145                     T= .05*(1.-((2.*X-.50)/.50)**2)
 107001146                  ELSE
 108001148                     IF X.LT..75
 109001149                     THEN
 110001152                        T=-.02*(1.-((2.*X-1.25)/.25)**2)
 111001153                     ELSE
 112001155                        IF X.LT.1.
 113001156                        THEN
 114001159                           T=.025*(1.-((2.*X-1.70)/.20)**2)
 115001160                        ELSE
 116001162                           T=-.03
 117001163                        CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 18
0CARD TARGET
  NO  STM.NO
 
 118001164                     CIF
 119001165                  CIF
 120001166               CIF
 121001167            CIF
 122001168            IF IWR.EQ.17
 123001169            THEN
 124001172               IF IND.EQ.2
 125001173               THEN
 126001176                  IF X.LT..40
 127001177                  THEN
 128001180                     T=-.085*(1.-((2.*X-.40)/.40)**2)
 129001181                  ELSE
 130001183                     IF X.LT..62
 131001184                     THEN
 132001187                        T= .05*(1.-((2.*X-1.02)/.22)**2)
 133001188                     ELSE
 134001190                        IF X.LT.1.
 135001191                        THEN
 136001194                           T=-.04*(1.-((2.*X-1.47)/.23)**2)
 137001195                        ELSE
 138001197                           T= .170
 139001198                        CIF
 140001199                     CIF
 141001200                  CIF
 142001201               ELSE
 143001203                  IF X.LT..37
 144001204                  THEN
 145001207                     T=-.10*(1.-((2.*X-.37)/.37)**2)
 146001208                  ELSE
 147001210                     IF X.LT..60
 148001211                     THEN
 149001214                        T= .06*(1.-((2.*X- .97)/.23)**2)
 150001215                     ELSE
 151001217                        IF X.LT..72
 152001218                        THEN
 153001221                           T=-.03*(1.-((2.*X-1.32)/.12)**2)
 154001222                        ELSE
 155001224                           IF X.LT..9
 156001225                           THEN
 157001228                              T= .03*(1.-((2.*X-1.58)/.14)**2)
 158001229                           ELSE
 159001231                              T=-.07
 160001232                           CIF
 161001233                        CIF
 162001234                     CIF
 163001235                  CIF
 164001236               CIF
 165001237            CIF
 166001238            IF IWR.EQ.32
 167001239            THEN
 168001242               IF IND.EQ.2
 169001243               THEN
 170001246                  IF X.LT..27
 171001247                  THEN
 172001250                     T=.120*(1.-((2.*X-.27)/.27)**2)
 173001251                  ELSE
 174001253                     IF X.LT..46
 175001254                     THEN
 176001257                        T=-.08*(1.-((2.*X- .73)/.19)**2)
 177001258                     ELSE
 178001260                        IF X.LT..64
 179001261                        THEN
 180001264                           T= .055*(1.-((2.*X-1.10)/.18)**2)
 181001265                        ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 19
0CARD TARGET
  NO  STM.NO
 
 182001267                           T=0.
 183001268                        CIF
 184001269                     CIF
 185001270                  CIF
 186001271               ELSE
 187001273                  IF X.LT..43
 188001274                  THEN
 189001277                     T= .05*(1.-((2.*X-.43)/.43)**2)
 190001278                  ELSE
 191001280                     IF X.LT..67
 192001281                     THEN
 193001284                        T=-.025*(1.-((2.*X-1.10)/.24)**2)
 194001285                     ELSE
 195001287                        IF X.LT.1.
 196001288                        THEN
 197001291                           T=.020*(1.-((2.*X-1.55)/.21)**2)
 198001292                        ELSE
 199001294                           T=-.070
 200001295                        CIF
 201001296                     CIF
 202001297                  CIF
 203001298               CIF
 204001299            CIF
 205001300            IF IWR.EQ.33
 206001301            THEN
 207001304               IF IND.EQ.2
 208001305               THEN
 209001308                  IF X.LT..42
 210001309                  THEN
 211001312                     T=-.09*(1.-((2.*X-.42)/.42)**2)
 212001313                  ELSE
 213001315                     IF X.LT..68
 214001316                     THEN
 215001319                        T= .06*(1.-((2.*X-1.10)/.26)**2)
 216001320                     ELSE
 217001322                        IF X.LT..95
 218001323                        THEN
 219001326                           T=-.055*(1.-((2.*X-1.54)/.18)**2)
 220001327                        ELSE
 221001329                           T=.170
 222001330                        CIF
 223001331                     CIF
 224001332                  CIF
 225001333               ELSE
 226001335                  IF X.LT..44
 227001336                  THEN
 228001339                     T=-.11*(1.-((2.*X-.44)/.44)**2)
 229001340                  ELSE
 230001342                     IF X.LT..68
 231001343                     THEN
 232001346                        T= .075*(1.-((2.*X-1.12)/.24)**2)
 233001347                     ELSE
 234001349                        IF X.LT..9
 235001350                        THEN
 236001353                           T=-.05*(1.-((2.*X-1.53)/.17)**2)
 237001354                        ELSE
 238001356                           T= .080
 239001357                        CIF
 240001358                     CIF
 241001359                  CIF
 242001360               CIF
 243001361            CIF
 244001362            IF IWR.EQ.48
 245001363            THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 20
0CARD TARGET
  NO  STM.NO
 
 246001366               IF IND.EQ.2
 247001367               THEN
 248001370                  IF X.LT..34
 249001371                  THEN
 250001374                     T= .08*(1.-((2.*X-.34)/.34)**2)
 251001375                  ELSE
 252001377                     IF X.LT..85
 253001378                     THEN
 254001381                        T=-.035*(1.-((2.*X- .99)/.31)**2)
 255001382                     ELSE
 256001384                        T=.150
 257001385                     CIF
 258001386                  CIF
 259001387               ELSE
 260001389                  IF X.LT..30
 261001390                  THEN
 262001393                     T=.035*(1.-((2.*X-.30)/.30)**2)
 263001394                  ELSE
 264001396                     T=-.035*(1.-((2.*X-1.10)/.50)**2)
 265001397                  CIF
 266001398               CIF
 267001399            CIF
 268001400            IF IWR.EQ.49
 269001401            THEN
 270001404               IF IND.EQ.2
 271001405               THEN
 272001408                  IF X.LT..42
 273001409                  THEN
 274001412                     T=-.08*(1.-((2.*X-.42)/.42)**2)
 275001413                  ELSE
 276001415                     IF X.LT..70
 277001416                     THEN
 278001419                        T=.018*(1.-((2.*X-1.07)/.23)**2)
 279001420                     ELSE
 280001422                        T=.035
 281001423                     CIF
 282001424                  CIF
 283001425               ELSE
 284001427                  IF X.LT..50
 285001428                  THEN
 286001431                     T=-.09*(1.-((2.*X-.50)/.50)**2)
 287001432                  ELSE
 288001434                     IF X.LT..85
 289001435                     THEN
 290001438                        T= .080*(1.-((2.*X-1.30)/.30)**2)
 291001439                     ELSE
 292001441                        T=-.060
 293001442                     CIF
 294001443                  CIF
 295001444               CIF
 296001445            CIF
 297001446            IF IWR.EQ.64
 298001447            THEN
 299001450               IF IND.EQ.2
 300001451               THEN
 301001454                  IF X.LT..35
 302001455                  THEN
 303001458                     T= .09*(1.-((2.*X-.35)/.35)**2)
 304001459                  ELSE
 305001461                     IF X.LT..64
 306001462                     THEN
 307001465                        T=-.07*(1.-((2.*X- .99)/.29)**2)
 308001466                     ELSE
 309001468                        IF X.LT..85
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 21
0CARD TARGET
  NO  STM.NO
 
 310001469                        THEN
 311001472                           T= .05*(1.-((2.*X-1.44)/.16)**2)
 312001473                        ELSE
 313001475                           T=-.09
 314001476                        CIF
 315001477                     CIF
 316001478                  CIF
 317001479               ELSE
 318001481                  IF X.LT..40
 319001482                  THEN
 320001485                     T= .09*(1.-((2.*X-.40)/.40)**2)
 321001486                  ELSE
 322001488                     T=0.
 323001489                  CIF
 324001490               CIF
 325001491            CIF
 326001492            Y1COR=Y1COR+T
 327001493         CIF
 328001494         Y1=Y1+Y1COR
 329001495      CPROC
 33000    C
 33100    CCCCCCCCCCCCCCCC
 33200    C     FUNCTION SQTVAL(F,G,AL,EPS)
 33300    C
 33400    C     CALCULATE SQTVAL=F*(SQRT(1+G*AL**2/F**2)-1).
 33500    C     TO ACHIEVE GOOD PRECISION, FOR LARGE F THE TAYLOR EXPANSION
 33600    C     IS USED UPTO AT MOST 15 TERMS
 33700    C     EPS IS THE REQUIRED ABSOLUTE PRECISION
 33800    C
 339001497      PROC CALSQT
 340001498         S=G/F
 341001499         U=-S/F
 342001500         S=-.5*S
 343001501         IF ABS(U).GT..3
 344001502         THEN
 345001505            IF U.LT..98
 346001506            THEN
 347001509               SQTVAL=F*(SQRT(1.-U)-1.)
 348001510            ELSE
 349001512               SQTVAL=0.
 35000    C           PRINT 100,F,G,AL
 35100    C100        FORMAT(1X,' SQTVAL',3E16.7)
 352001513            CIF
 353001514         ELSE
 354001516            VAL=-S*(1.+.25*U+.125*U**2)
 355001517            QQ=S*U**3/12.8
 356001518            N=5
 357001519            WHILE ABS(QQ).GT.EPS .AND.N.LT.15
 358001521               VAL=VAL-QQ
 359001525               QQ=QQ*U*(1.-1.5/N)
 360001526               N=N+1
 361001527            CWHILE
 362001529            SQTVAL=VAL
 363001530         CIF
 364001531      CPROC
 365001533      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS        1532 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        1532 TARGET STATEMENTS
 00000    C   19/03/80 312171949  MEMBER NAME  REDONE   (JADEGS)      SHELTRAN
 00100   2      SUBROUTINE REDONE (INDREJ,LBWRT,IWRT)
 00200    C---
 00300    C---     SHORT VERSION OF USREDUC1 ON JADEPR.JADESR
 00400    C---     RETURNS REJECT CODE INDREJ, WRITE CODES LBWRT AND IWRT
 00500    C---                                  LAST CHANGE 25.08.80
 00600   3      IMPLICIT INTEGER*2 (H)
 00700    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 --------------------------
 00900    C
 01000   8      COMMON /CREDON/LIMHIT,LIMHT1,CRVTAG,CRVNTG
 01100   9      COMMON /CIPRI/ IPRI
 01200  10      COMMON /CHEADR/ HEAD(108)
 01300  11      EQUIVALENCE (HRUN,HEAD(18)),(HEVENT,HEAD(19))
 01400    C
 01500  12      DATA ETAGLM /300./
 01600  13      DATA MKTAGE /Z400/, MKLGLE /Z200/, MKLUMI /Z100/, MKFWMU/Z800/
 01700  14      DATA MKMUCN /Z00F/
 01800    C
 01900  15      IQHEAD = IBLN('HEAD')
 02000  16      IQTRIG = IBLN('TRIG')
 02100  17      IQALGN = IBLN('ALGN')
 02200  18      IQZVTX = IBLN('ZVTX')
 02300  19      IQJETC = IBLN('JETC')
 02400  20      IQPATR = IBLN('PATR')
 02500  21      IQJHTL = IBLN('JHTL')
 02600  22      IPHEAD=IDATA(IQHEAD)
 02700  23      CALL MVCL(HEAD(1),0,IDATA(IPHEAD-3),0,216)
 02800    C
 02900  24      INDREJ = 0
 03000  25      LBWRT = 0
 03100  26      IWRT = 0
 03200    C
 03400  27      IFLW= 0                                                            SET OVERFLOW MARKER
 03500  28      IF(HEAD(23).NE.0) IFLW = 1
 03600    C
 03800  30      LBTRBT = 0                                                         CHECK TRIGGER WITH T2-ACCEPT
 04000  31      IPTRIG = IDATA(IQTRIG)                                             SET TRIGGER BITS IF 'TRIG' BANK # 1 EXISTS
 04100  32      IF(IPTRIG.GT.0 .AND. IDATA(IPTRIG-2).EQ.1)
 04200         ?  LBTRBT = HDATA(IPTRIG*2+10)
 04400  34      ILUMI = 0                                                          SET LUMI-FLAG
 04500  35      IF(LAND(LBTRBT,MKLUMI).NE.0) ILUMI = 1
 04600    C
 04800  37      IMUACC=0                                                           CHECK FOR MUON HITS IF FWD MU TRIG
 04900  38      IF(LAND(LBTRBT,MKFWMU).NE.0) CALL MEWT3(IMUACC)
 05000  40      IF IMUACC.LE.0
 05100  41      THEN
 05200  44         CALL TRGCHK(LBTRCK,LBTRBT)
 05400    C                                                     >>>>> REJECT <<<<< TRIGGER CHECK -VE
 05500  45         INDREJ =  1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 05600  46         IF(IPRI.GT.0.AND.LBTRCK.EQ.0) WRITE(6,4810)
 05700  484810  FORMAT(' REJECTED BY TRIGGER CHECK  ')
 05800  49         IF(LBTRCK.EQ.0) RETURN
 05900    C
 06100  51         IACC = 0                                                        LG-ENERGY IN CYLINDER AND E-CAPS; SET FLAG IACC
 06200  52         CALL LGCUTX(IACC,ECYL,ECAMI,ECAPL,ETOT)
 06400  53         IF(LAND(LBTRBT,MKLGLE).EQ.0) IACC = 0                           RESET IACC IF NO HIGH ENERGY TRIGGER
 06500    C
 06600    C  SET   FLAG FOR ENERGY IN FORWARD TAGGING BLOCKS
 06700    C              IFTG = 0      NO ENERGY
 06800    C              IFTG = 11     ENERGY ABOVE LIMIT IN NEG. FW ARM
 06900    C              IFTG = 12     ENERGY ABOVE LIMIT IN POS. FW ARM
 07000    C              IFTG = 113/13 ENERGY ABOVE LIMIT IN BOTH FW ARMS(LUMI)
 07100  55         IFTG = 0
 07200  56         IF(LAND(LBTRBT,2).NE.0) CALL TAGFLG(IFTG)
 07300  58         ETAG = 0.
 07400  59         IF(IFTG.NE.0. .AND. LAND(LBTRBT,MKTAGE).NE.0) ETAG = ETOT
 07500    C
 07700  61         IF(IACC.NE.     0) IWRT = 1                                     SET WRITE FLAG FOR HIGH ENERGY, OVERFLOW, TAGGING,
 07800  63         IF(IFLW.NE.     0) IWRT = IWRT + 2
 07900  65         IF ETAG.GT.ETAGLM .AND. IWRT.EQ.0
 08000  66         THEN
 08100  69            ECENTR = 0.
 08200  70            IF(IFTG.EQ.11) ECENTR = ETOT - ECAMI
 08300  72            IF(IFTG.EQ.12) ECENTR = ETOT - ECAPL
 08400  74            IF(IFTG.GT.12) ECENTR = ETOT
 08500  76            IF(ECENTR.GT.100.) IWRT = IWRT + 4
 08600    C         IF(IFTG.GT.0.AND.IFTG.LT.11.AND.ETOT.GT.100.) IWRT=IWRT+4
 08700  78         CIF
 08800    C
 09000    C                                                     >>>>> REJECT <<<<< IWRT = 0 .AND. GOOD TRIGGER CHECK -VE
 09100  79         INDREJ =  2
 09200  80         IF(IPRI.GT.0.AND.LBTRCK.EQ.16.AND.IWRT.EQ.0) WRITE(6,4811)
 09300  824811  FORMAT(' REJECTED BY TRIGGER CHECK, WITH IWRT = 0 ,NO TRACKS ')
 09400  83         IF(IWRT.EQ.0 .AND. LBTRCK.EQ.16) RETURN
 09600  85      ELSE                                                               ACCEPT FWD MUON TRIG WITH MUON HITS
 09700  87         IWRT=1
 09800  88         LBWRT=16
 09900  89         INDREJ = 0
 10000  90         IF(IPRI.GT.0) WRITE(6,4521)
 10100  924521  FORMAT(' ACCEPTED AS FW MU TRIGGER WITH MU TRACKS ')
 10200  93         RETURN
 10300  94      CIF
 10400    C
 10500    C       CHECK IF HITS IN ID
 10600  95      IPJCA  = IDATA(IQJETC)
 10700  96      IF IPJCA.LE.0
 10800  97      THEN
 11000    C                                                     >>>>> REJECT <<<<< NO HITS IN 'JETC'
 11100 100         INDREJ =  3
 11200 101         IF(IPRI.GT.0.AND.IWRT.EQ.0) WRITE(6,4812)
 11300 1034812  FORMAT(' NO HITS IN INNER DET.,WITH IWRT = 0  REJECTED ')
 11400 104         IF(IWRT.EQ.0) RETURN
 11500                                                                             WRITE  IF IWRT = 1
 11700    C                                                     ***** ACCEPT ***** IWRT=1, NO HITS IN 'JETC'
 11800 106         INDREJ = 0
 11900 107         LBWRT =  1
 12000 108         IF(IPRI.GT.0) WRITE(6,4813)
 12100 1104813  FORMAT(' NO HITS IN INNER DET.,WITH IWRT = 1  ACCEPTED ')
 12200 111         RETURN
 12300 112      CIF
 12400    C
 12500    C
 12700 113      INDREJ = 0                                                         STOP ANALYSIS FOR IWRT=1,4
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 12800 114      LBWRT = 2
 12900 115      IF(IPRI.GT.0.AND.(IWRT.EQ.1.OR.IWRT.EQ.4)) WRITE(6,4814)
 13000 1174814  FORMAT('  IWRT = 1,4 ACCEPTED ')
 13100 118      IF(LAND(IWRT,5).NE.0) RETURN
 13200 120      LBWRT = 0
 13300    C
 13400 121      IPJCA  = IDATA(IQJETC)
 13500 122      IPJCA2 = IPJCA*2
 13600 123      IPZV   = IDATA(IQZVTX)
 13700 124      IF IPZV.GT.0
 13800 125      THEN
 13900 128         IFLAG  = IDATA(IPZV+6)
 14000 129         ZVTX   = ADATA(IPZV+1)
 14100 130         PEAK   = ADATA(IPZV+4)
 14200    C
 14400 131         IF(IFLAG.LT.3 .AND. LBTRCK.EQ.8) IFLAG = 0                      ONLY CLEAN VTX FOR 1T + 1T(R1) * CLEAN R1
 14500 133         IF IFLAG.LE.0
 14600 134         THEN
 14800    C                                                     >>>>> REJECT <<<<< EVENTS WITHOUT ZVTX
 14900 137            IF IWRT.EQ.0
 15000 138            THEN
 15100 141               INDREJ=4
 15200 142               IF(IPRI.GT.0) WRITE(6,4347)
 15300 1444347  FORMAT('  NO ZVTX FOUND,IWRT=0   REJECTED ')
 15400 145            ELSE
 15500 147               LBWRT = 14
 15600 148               IF(IPRI.GT.0) WRITE(6,4387)
 15700 1504387  FORMAT('  NO ZVTX FOUND,IWRT>0   ACCEPTED ')
 15800 151            CIF
 15900 152            RETURN
 16000 153         ELSE
 16100    C
 16200 154            IF ABS(ZVTX).GT.350.
 16300 155            THEN
 16400 158               IF IWRT.EQ.0
 16500 159               THEN
 16600 162                  INDREJ=5
 16700 163                  IF(IPRI.GT.0) WRITE(6,9347)
 16800 1659347  FORMAT('  ZVTX > 350,IWRT=0   REJECTED ')
 16900 166               ELSE
 17000 168                  LBWRT = 15
 17100 169                  IF(IPRI.GT.0) WRITE(6,9387)
 17200 1719387  FORMAT('  ZVTX > 350,IWRT>0   ACCEPTED ')
 17300 172               CIF
 17400 173               RETURN
 17500 174            CIF
 17600 175         CIF
 17700 176      ELSE
 17900    C                                                     >>>>> REJECT <<<<< NO 'ZVTX'-BANK
 18000 178         IF IWRT.EQ.0
 18100 179         THEN
 18200 182            INDREJ=6
 18300 183            IF(IPRI.GT.0) WRITE(6,4817)
 18400 1854817  FORMAT('  NO ZVTX BANK,IWRT=0   REJECTED ')
 18500 186         ELSE
 18600 188            LBWRT = 6
 18700 189            IF(IPRI.GT.0) WRITE(6,4887)
 18800 1914887  FORMAT('  NO ZVTX BANK,IWRT>0   ACCEPTED ')
 18900 192         CIF
 19000 193         RETURN
 19100 194      CIF
 19200    C
 19300 195      IPPATR = IDATA(IQPATR)
 19400 196      IF IPPATR.LE.0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 19500 197      THEN
 19600 200         IF IWRT.EQ.0
 19700 201         THEN
 19800 204            INDREJ = 7
 19900 205            IF(IPRI.GT.0) WRITE(6,4818)
 20000 2074818  FORMAT('  NO PATR BANK,IWRT=0   REJECTED ')
 20100 208         ELSE
 20200 210            LBWRT = 7
 20300 211            IF(IPRI.GT.0) WRITE(6,4888)
 20400 2134888  FORMAT('  NO PATR BANK, IWRT>0  ACCEPTED ')
 20500 214         CIF
 20600 215         RETURN
 20700 216      CIF
 20800    C
 20900 217      NTR    = IDATA(IPPATR+2)
 21000 218      LDTR   = IDATA(IPPATR+3)
 21100 219      IPTR0  = IPPATR + IDATA(IPPATR+1)
 21200 220      IPTR9  = IPTR0 + (NTR-1)*LDTR
 21300 221      IF NTR.LE.0
 21400 222      THEN
 21600    C                                                     >>>>> REJECT <<<<< 0 TRACKS
 21700 225         IF IWRT.EQ.0
 21800 226         THEN
 21900 229            INDREJ = 8
 22000 230            IF(IPRI.GT.0) WRITE(6,4819)
 22100 2324819  FORMAT('  NO TRACKS, IWRT=0   REJECTED ')
 22200 233         ELSE
 22300 235            LBWRT = 8
 22400 236            IF(IPRI.GT.0) WRITE(6,4889)
 22500 2384889  FORMAT('  NO TRACKS, IWRT>0   ACCEPTED ')
 22600 239         CIF
 22700 240         RETURN
 22800 241      CIF
 22900    C
 23000 242      IF IFTG.NE.0
 23100 243      THEN
 23200    C
 23400 246         ACRV=1000.                                                      ***** TAGGING EVENTS WITH IWRT=0
 23500 247         ZMIN = 1000.
 23700 248         FOR IPTR=IPTR0,IPTR9,LDTR                                       FIND MIN(Z) OF LONG TRACKS, >200MEV
 23800 249            IF IDATA(IPTR+24).GT.LIMHIT
 23900 250            THEN
 24000 253               CRV = ADATA(IPTR+25)
 24100 254               IF(ABS(CRV).LT.ACRV) ACRV=ABS(CRV)
 24300 256               IF ABS(CRV)      .LE.CRVTAG                               CURVATURE CUT CORRESPONDING TO 200 MEV
 24400 257               THEN
 24500 260                  AZV = ADATA(IPTR+31)
 24700 261                  IF(ABS(AZV).LT.ABS(ZMIN)) ZMIN = AZV                   ZR FIT INTERCEPT WITH Z-AXIS
 24800 263               CIF
 24900 264            CIF
 25000 265         CFOR
 25100 267         IF ABS(ZMIN).GT.300.
 25200 268         THEN
 25400    C                                                     >>>>> REJECT <<<<< MIN(Z) > 300.
 25500 271            IF IWRT.EQ.0
 25600 272            THEN
 25700 275               INDREJ = 9
 25800 276               IF(IPRI.GT.0) WRITE(6,4829)
 25900 2784829  FORMAT('  TAGGED EVENT, ZMIN > 300 MM IWRT=0   REJECTED ')
 26000 279            ELSE
 26100 281               LBWRT = 9
 26200 282               IF(IPRI.GT.0) WRITE(6,4869)
 26300 2844869  FORMAT('  TAGGED EVENT, ZMIN > 300 MM IWRT>0   ACCEPTED ')
 26400 285            CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 26500 286            RETURN
 26600 287         CIF
 26700 288         IWRT = IWRT + 16
 26900    C                                                     ***** ACCEPT ***** MIN(Z) < 300.
 27000 289         INDREJ = 0
 27100 290         LBWRT = 3
 27200 291         IF(IPRI.GT.0) WRITE(6,4830)
 27300 2934830  FORMAT('  TAGGED EVENT, ZMIN < 300 MM  ACCEPTED ')
 27400 294         RETURN
 27500 295      CIF
 27600    C
 27800    C                                                                        ***** OTHER EVENTS WITH IWRT=0
 28000 296      LBLONG = 0                                                         LABEL FOR LONG TRACKS
 28200 297      NE100 = 0                                                          LABEL FOR LONG TRACKS, >600MEV
 28300 298      ZSUM = 0.
 28400 299      LBEHIG = 0
 28500 300      ACRV=1000.
 28600 301      ZAV=0.
 28700 302      ZMIN = 1000.
 28800 303      IKNT=0
 29000 304      FOR IPTR=IPTR0,IPTR9,LDTR                                          DET. MIN(Z) FOR LONG TRACKS, >600MEV
 29200 305         IF IDATA(IPTR+33).GT.LIMHIT                                     CHECK IF LIMHIT HITS USED IN ZR-FIT
 29300 306         THEN
 29400 309            LBLONG = 1
 29500 310            CRV = ADATA(IPTR+25)
 29600 311            AZV = ADATA(IPTR+31)
 29700 312            IF(ABS(CRV).LT.ACRV) ACRV=ABS(CRV)
 29900 314            IF ABS(CRV)      .LE.CRVNTG                                  CURVATURE CUT CORRESPONDING TO C:A 600 MEV
 30000 315            THEN
 30100 318               LBEHIG = 1
 30200 319               ZAV=ZAV+AZV
 30300 320               IKNT=IKNT+1
 30400 321               IF(ABS(AZV).LT.ABS(ZMIN)) ZMIN = AZV
 30500 323            ELSE
 30600 325               IF ABS(CRV).LT.CRVTAG.AND.ABS(AZV).LE.300.
 30700 326               THEN
 30800 329                  RSQ = ADATA(IPTR+5)**2+ADATA(IPTR+6)**2
 30900 330                  IF RSQ.LT.250000.
 31000 331                  THEN
 31100 334                     NE100 = NE100 + 1
 31200 335                     ZSUM = AZV + ZSUM
 31300 336                  CIF
 31400 337               CIF
 31500 338            CIF
 31600 339         CIF
 31700 340      CFOR
 31800 342      ISTAR = LBEHIG*2 + LBLONG
 31900 343      IF(NE100.GE.2) ISTAR = ISTAR + 4
 32000 345      IF(IKNT.GT.0) ZAV=ZAV/FLOAT(IKNT)
 32100 347      IF(NE100.GE.2.AND.LBEHIG.EQ.0) ZMIN = ZSUM/FLOAT(NE100)
 32200    C
 32400 349      IF LBLONG.EQ.0                                                     ***** EVENTS WITH SHORT TRACKS ONLY
 32500 350      THEN
 32600 353         ETOTX = ECAMI + ECAPL
 32800 354         ACRV=1000.                                                      CHECK IF LONG TRACK IN R-FI
 32900 355         IKNT=0
 33000 356         FOR IPTR=IPTR0,IPTR9,LDTR
 33200 357            IF IDATA(IPTR+24).GT.LIMHT1                                  CHECK IF LIMHT1 HITS USED IN RFI-FIT
 33300 358            THEN
 33400 361               LBLONG = 1
 33500 362               CRV = ADATA(IPTR+25)
 33600 363               IF(ABS(CRV).LT.ACRV) ACRV=ABS(CRV)
 33700 365               IKNT=IKNT+1
 33800 366            CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 33900 367         CFOR
 34000 369         IF LBLONG.EQ.0
 34100 370         THEN
 34300    C                                                     >>>>> REJECT <<<<< ONLY SHORT TRACKS
 34400 373            IF IWRT.EQ.0
 34500 374            THEN
 34600 377               INDREJ = 10
 34700 378               IF(IPRI.GT.0) WRITE(6,4831)
 34800 3804831  FORMAT('  NOTAG EVENT, ONLY SHORT TRACKS  IWRT=0    REJECTED ')
 34900 381            ELSE
 35000 383               LBWRT = 10
 35100 384               IF(IPRI.GT.0) WRITE(6,4851)
 35200 3864851  FORMAT('  NOTAG EVENT, ONLY SHORT TRACKS  IWRT>0  ACCEPTED ')
 35300 387            CIF
 35400 388            RETURN
 35500 389         CIF
 35600    C
 35800    C                                                     ***** ACCEPT ***** LONG TRACKS IN R-FI, SHORT TRACKS IN R-Z
 35900 390         INDREJ = 0
 36000 391         LBWRT = 4
 36100 392         IF(IPRI.GT.0) WRITE(6,4832)
 36200 3944832  FORMAT('  NOTAG EVENT, LONG TRACKS RFI, SHORT RZ, ACCEPTED ')
 36300 395         IWRT = IWRT + 32
 36400 396         RETURN
 36500 397      CIF
 36600    C
 36800 398      IF LBEHIG.EQ.0.AND.NE100.LT.2                                      ***** LONG TRACKS
 36900 399      THEN
 37100 402         ETOTX = ECAMI + ECAPL                                           ***** LONG TRACKS, <600MEV
 37300    C                                                     >>>>> REJECT <<<<< LONG TRACKS, <600MEV
 37400 403         IF IWRT.EQ.0
 37500 404         THEN
 37600 407            INDREJ = 11
 37700 408            IF(IPRI.GT.0) WRITE(6,4833)
 37800 4104833  FORMAT(' LONG TRKS < 600 , < 2 WEAK TRACKS, IWRT=0  REJECTED')
 37900 411         ELSE
 38000 413            LBWRT = 11
 38100 414            IF(IPRI.GT.0) WRITE(6,4873)
 38200 4164873  FORMAT(' LONG TRKS < 600 , < 2 WEAK TRACKS, IWRT>0  ACCEPTED')
 38300 417         CIF
 38400 418         RETURN
 38500 419      CIF
 38600    C
 38800 420      IF ABS(ZMIN).GT.300.                                               ***** LONG TRACKS, >600MEV
 38900 421      THEN
 39100    C                                                     >>>>> REJECT <<<<< MIN(Z) >300.
 39200 424         IF IWRT.EQ.0
 39300 425         THEN
 39400 428            INDREJ = 12
 39500 429            IF(IPRI.GT.0) WRITE(6,4834)
 39600 4314834  FORMAT(' LONG TRKS > 600, OR<2 WEAK TR.ZMIN>300 IWRT=0 REJECTED')
 39700 432         ELSE
 39800 434            LBWRT = 12
 39900 435            IF(IPRI.GT.0) WRITE(6,4884)
 40000 4374884  FORMAT(' LONG TRKS > 600, OR<2 WEAK TR.ZMIN>300 IWRT>0 ACCEPTED')
 40100 438         CIF
 40200 439         RETURN
 40300 440      CIF
 40400    C
 40600    C                                                                        ***** LONG TRACKS, >600MEV, MIN(Z)<300.
 40700    C       CHECK RMIN
 40800 441      RMIN=10000.
 40900 442      FOR IPTR=IPTR0,IPTR9,LDTR
 41000 443         IF IDATA(IPTR+33).GT.LIMHIT
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 41100 444         THEN
 41200 447            CRV = ADATA(IPTR+25)
 41300 448            AZV = ADATA(IPTR+31)
 41400 449            IF ABS(CRV)      .LE.CRVTAG.AND.ABS(AZV).LE.300.
 41500 450            THEN
 41600 453               CALL PRTOCI(IPTR,DUM1,RM,DUM2,DUM3)
 41700 454               IF(RM.LT.RMIN) RMIN=RM
 41800 456            CIF
 41900 457         CIF
 42000 458      CFOR
 42200    C                                                     >>>>> REJECT <<<<< RMIN > 60.
 42300 460      IF RMIN.GT.60.
 42400 461      THEN
 42500 464         IF IWRT.EQ.0
 42600 465         THEN
 42700 468            INDREJ = 13
 42800 469            IF(IPRI.GT.0) WRITE(6,4835)
 42900 4714835  FORMAT(' LONG>600,OR<2 WEAK TR.ZMN>300 IWRT=0 RMIN>60 REJECTED')
 43000 472         ELSE
 43100 474            LBWRT = 13
 43200 475            IF(IPRI.GT.0) WRITE(6,4895)
 43300 4774895  FORMAT(' LONG>600,OR<2 WEAK TR.ZMN>300 IWRT>0 RMIN>60 ACCEPTED')
 43400 478         CIF
 43500 479         RETURN
 43600 480      CIF
 43800    C                                                     ***** ACCEPT ***** LONG TRACKS, >600MEV, MIN(Z)<300.,
 44000 481      INDREJ = 0                                                         RMIN<60.
 44100 482      LBWRT  = 5
 44200 483      IF(IPRI.GT.0) WRITE(6,4836)
 44300 4854836  FORMAT(' LONG TR>600 OR 2 WEAK TR., ZMIN<300 RMIN<60  ACCEPTED')
 44400 486      IWRT = IWRT + 64
 44500 487      RETURN
 44600 488      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         487 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 44700   2      BLOCK DATA
 44800   3      COMMON /CREDON/LIMHIT,LIMHT1,CRVTAG,CRVNTG
 44900   4      COMMON /CIPRI/IPRI
 45000   5      DATA IPRI /0/
 45100   6      DATA LIMHIT/12/, LIMHT1/20/
 45200   7      DATA CRVTAG/.00150/, CRVNTG/.00025/
 45300   8      END
 ..WARNING..                STOP OR RETURN ARE MISSING
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           1 WARNINGS           7 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 45400   2      SUBROUTINE TRGCHK(LBTRCK,LBTRBT)
 45500    C
 45600   3      IMPLICIT INTEGER*2 (H)
 45700   4      LOGICAL TBIT
 45800    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 --------------------------
 46000    C
          C-------------------------------
          C  MACRO CHEADR .... HEADER BANK
          C-------------------------------
         9      COMMON /CHEADR/ IHEADR(54)
        10      INTEGER*2 HHEADR(108)
        11      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 ------------
 46200    C
 46300  12      COMMON /CWORK/ ILGE(84),HCLWR(96)
 46400    C
 46600  13      DATA MKTREV /Z653/, MKT2AC /Z53/, MKEHIG /Z600/                    MASKS FOR EVENT TRIGGER  + HIGH ENERGY
 46800  14      INTEGER MKTRBT( 7) /1,2,4,8,16,32,64/                              MASKS FOR TRIGGER IN 'LATC' BANK
 47000    C     INTEGER MKCLBT(16) /1,2,4,8,16,32,64,128,256,512,1024,2048,        MASKS FOR HITS IN LAYERS OF JETC
 47100    C    ,                    Z1000,Z2000,Z4000,Z8000/
 47300  15      INTEGER NCTOF ( 7) /2,3,3,3,3,3,3/                                 # OF CELLS FOR TOF COUNTER 1...7
 47500  16      INTEGER ICTOF ( 7) /0,1,2,3,4,5,6/                                 1. CELL FOR TOF-COUNTER 1...7
 47600    C
 47800  17      LBTRCK = 0                                                         INITIALIZE LABEL FOR TRIGGER CHECK
 47900    C
 48100  18      IF(LAND(LBTRBT,MKTREV).EQ.0) RETURN                                REJECT LUMI-TRIGGER
 48200    C
 48400  20      IF(LAND(LBTRBT,MKEHIG).NE.0) LBTRCK = 16                           ACCEPT T1-ACCEPT TRIGGER
 48500    C     PRINT 2991, HHEADR(17),HHEADR(18),HHEADR(19),NREC,LBTRBT,LBTRCK
 48600    C2991 FORMAT(' **********************   EVENT:',4I6,1X,Z4,1X,Z4)
 48700    C
 48900  22      IF(LAND(LBTRBT,MKT2AC).EQ.0) RETURN                                CHECK IF T1-POSTPONE
 49000    C
 49200  24      CALL SETSL(ILGE(1),0,528,0)                                        INITIALIZE LG-ROWS + CELL BITS
 49300    C
 49500  25      REPEAT                                                             ACCUMULATE E(LG-ROWS)
 49600  26         IPALGN = IDATA(IBLN('ALGN'))
 49700  27         IF(IPALGN.LE.0) XREPEAT
 49900  29         IF(IDATA(IPALGN).LE. 3) XREPEAT                                 CHECK IF ANY LG-ENERGIES
 50000  31         IPLG2 = IPALGN*2
 50100  32         NBARR = HDATA(IPLG2+ 4) - HDATA(IPLG2+ 3)
 50300  33         IF(NBARR.LE.0) XREPEAT                                          CHECK IF ANY LG-ENERGY IN BARREL
 50500  35         IP0 = IPLG2 + 7                                                 SUM ENERGIES OF LG-ROWS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 50600  36         IP9 = IP0 + NBARR - 1
 50700  37         FOR IP=IP0,IP9,2
 50800  38            NBL  = HDATA(IP)
 50900  39            IROW = SHFTR(NBL,5)
 51000  40            ILGE(IROW) = ILGE(IROW) + HDATA(IP+1)
 51100  41         CFOR
 51200    C     PRINT 2003, ILGE
 51300    C2003   FORMAT('0EROW:',20I6,/,(6X,20I6))
 51400  43      UNTIL .TRUE.
 51500    C
 51700  44      IPJETC = IDATA(IBLN('JETC'))                                       ACCUMULATE CELL BITS OF 3. RING
 51800  48      IF(IPJETC.LE.0) RETURN
 51900    C     PRINTOUT
 52000    C     I0 = IPJETC*2 + 1
 52100    C     I9 = I0 + IDATA(IPJETC)*2 - 1
 52200    C     PRINT 2001, I0,I9,IDATA(IPJETC),(HDATA(I1),I1=I0,I9)
 52300    C2001 FORMAT('0JETC:',3I6,/,(6X,20I6))
 52400    C
 52600  50      IF(IDATA(IPJETC).LE.50) RETURN                                     CHECK IF ANY JETC DATA
 52700  52      IPJC2 = IPJETC*2
 52800  53      NHTR3 = HDATA(IPJC2+99) - HDATA(IPJC2+51)
 53000  54      IF(NHTR3.LE.0) RETURN                                              CHECK IF ANY HITS IN R3
 53200  56      IP0 = IPJC2 + 100 + HDATA(IPJC2+51)                                SET UP 1 LABEL/CELL WITH 1 BIT/LAYER
 53300  57      IP9 = IP0 + NHTR3 - 1
 53400  58      IWIR0 =-1
 53500  59      FOR IP=IP0,IP9,4
 53600  60         IWIR = HDATA(IP)
 53700  61         IWIR = SHFTR(IWIR,3)
 53800  62         HCLL = SHFTR(IWIR,3) - 95
 53900  63         IF(IWIR.NE.IWIR0) HCLWR(HCLL) = HCLWR(HCLL) + 1
 54000  65         IWIR0 = IWIR
 54100  66      CFOR
 54200    C     PRINT 2004, HCLWR
 54300    C2004 FORMAT('0HCLWR:',12I6,/,(7X,12I6))
 54400    C
 54600  68      IPLATC = IDATA(IBLN('LATC'))                                       CHECK IF 'LATC' BANK
 54700  69      IF(IPLATC.LE.0) RETURN
 54900  71      IPLT2 = IPLATC*2                                                   LOOP OVER ALL TOF COUNTER
 55000  72      IP0 = IPLT2 + 6
 55100  73      IP9 = IP0 + 5
 55200  74      ITLST =-100
 55300  75      ITOF0 = 0
 55400  76      ICLL0 = 0
 55500  77      NTRCK = 0
 55600  78      NTREL = 0
 55700  79      REPEAT
 55800  80         ITRBT = HDATA(IP0)
 55900  81         FOR JTOF=1,7
 56000  82            IF LAND(MKTRBT(JTOF),ITRBT) .NE. 0
 56100  83            THEN
 56300  86               ITOF = ITOF0 + JTOF                                       TOF COUNTER #
 56400    C
 56600    C                                                                        CHECK IF TRACK IN JETC
 56700    C
 56900  87               JCTOF = (ICTOF(JTOF) + ICLL0)*2 - 1                       LABEL FOR OVERLAPPING CELLS
 57100  88               LBTRK = 0                                                 INITIALIZE LABEL FOR TRACK CAND.
 57200    C
 57400  89               IF ITOF-ITLST.LE.2                                        CHECK IF 2 ADJACENT TOF
 57500  90               THEN
 57700  93                  HCLL9 = NCTOF(JTOF)*2 + JCTOF - 1                      CHECK IF 2 DIFFERENT TRACKS
 57800  94                  HCLL1 =-99
 57900  95                  MTRK = 0
 58000    C     PRINT 2005, ITOF,JTOF,JCTOF,ITLST,HCLL0,HCLL9
 58100  96                  FOR ICLL=HCLL0,HCLL9
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 58200  97                     IF HCLWR(ICLL).GE.6
 58300  98                     THEN
 58400 101                        HDCLL = ICLL - HCLL1
 58500 102                        IF HDCLL.EQ.1
 58600 103                        THEN
 58700 106                           HCLL1 = -99
 58800 107                        ELSE
 58900 109                           IF HDCLL.NE.3 .OR. TBIT(ICLL,31)
 59000 110                           THEN
 59100 113                              MTRK = MTRK + 1
 59200 114                              HCLL1 = ICLL
 59300 115                           CIF
 59400 116                        CIF
 59500 117                     CIF
 59600 118                  CFOR
 59700 120                  IF(MTRK.GE.2) LBTRK = 1
 59800 122               ELSE
 59900 124                  NHIT5 = 0
 60000 125                  NHIT6 = 0
 60100 126                  IF JCTOF.LT.0
 60200 127                  THEN
 60300 130                     NHIT1 = HCLWR(95)
 60400 131                     NHIT2 = HCLWR(96)
 60500 132                     NHIT3 = HCLWR( 1)
 60600 133                     NHIT4 = HCLWR( 2)
 60700 134                     IF(NHIT2.GE.3 .AND. HCLWR(93).GE.6) NHIT2 = 8
 60800 136                     IF(NHIT4.GE.3 .AND. HCLWR( 3).GE.6) NHIT4 = 8
 60900 138                  ELSE
 61000 140                     NHIT1 = HCLWR(JCTOF  )
 61100 141                     NHIT2 = HCLWR(JCTOF+1)
 61200 142                     NHIT3 = HCLWR(JCTOF+2)
 61300 143                     NHIT4 = HCLWR(JCTOF+3)
 61400 144                     IF NCTOF(JTOF).EQ.3
 61500 145                     THEN
 61600 148                        NHIT5 = HCLWR(JCTOF+4)
 61700 149                        NHIT6 = HCLWR(JCTOF+5)
 61800 150                     ELSE
 61900 152                        IF(NHIT2.GE.3 .AND. HCLWR(JCTOF-2).GE.6) NHIT2 = 8
 62000 154                        IF(NHIT4.GE.3 .AND. HCLWR(JCTOF+4).GE.6) NHIT4 = 8
 62100 156                     CIF
 62200 157                  CIF
 62300    C     PRINT 2005,ITOF,JTOF,JCTOF,NHIT1,NHIT2,NHIT3,NHIT4,NHIT5,NHIT6
 62400    C2005   FORMAT(' JETC:',20I6)
 62500    C
 62600                                                                             CHECK IF ENOUGH HITS FOR TRACK CAND.
 62700 158                  IF(MAX0(NHIT1,NHIT2,NHIT3,NHIT4,NHIT5,NHIT6).GE.6) LBTRK=1
 62800 160               CIF
 62900    C
 63100 161               IF LBTRK.NE.0                                             CHECK IF TRACK + COUNT
 63200 162               THEN
 63300 165                  NTRCK = NTRCK + 1
 63400 166                  ITLST = ITOF
 63500 167                  HCLL0 = JCTOF
 63600    C     PRINT 2005, NHIT1,NHIT2,NTRCK
 63700    C
 63800                                                                             CHECK IF ELECTRON TRACK
 64000 168                  IR = ITOF*2 - 3                                        CORRESP. LG-ROW
 64100 169                  IF ITOF.EQ.1
 64200 170                  THEN
 64300 173                     ILGENG = ILGE(83)+ILGE(  84)+ILGE(   1)+ILGE(   2)
 64400 174                  ELSE
 64500 176                     IF ITOF.EQ.42
 64600 177                     THEN
 64700 180                        ILGENG = ILGE(82)+ILGE(  83)+ILGE(  84)+ILGE(   1)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 64800 181                     ELSE
 64900 183                        ILGENG = ILGE(IR)+ILGE(IR+1)+ILGE(IR+2)+ILGE(IR+3)
 65000 184                     CIF
 65100 185                     IF(ILGENG.GT.1000) NTREL = NTREL + 1
 65200    C     PRINT 2002,NTREL,ITOF,IR,ILGENG
 65300    C2002 FORMAT(6X,20I6)
 65400    C
 65500 187                  CIF
 65600 188               CIF
 65700 189            CIF
 65800 190         CFOR
 65900 192         ICLL0 = ICLL0 + 8
 66000 193         ITOF0 = ITOF0 + 7
 66100 194         IP0   = IP0   + 1
 66200 195      UNTIL IP0.GT.IP9
 66300    C
 66500 196      LB1TCL = 0                                                         CHECK IF ONLY 1 TRACK, NO E
 66600 200      IF NTRCK.EQ.1 .AND. NTREL.EQ.0
 66700 201      THEN
 66900 204         IPJC2 = IPJETC*2                                                CHECK CLEAN 1. RING
 67000 205         NHTR1 = HDATA(IPJC2+27) - HDATA(IPJC2+ 3)
 67200 206         IF NHTR1.GT.96 .AND. NHTR1.LT.196                               CHECK IF ANY HITS IN R3
 67300 207         THEN
 67500 210            CALL SETS(HCLWR(1),0,48,0)                                   COUNT HITS/HALF CELL
 67600 211            IP0 = IPJC2 + 100 + HDATA(IPJC2+ 3)
 67700 212            IP9 = IP0 + NHTR1 - 1
 67800 213            IWIR0 =-1
 67900 214            FOR IP=IP0,IP9,4
 68000 215               IWIR = HDATA(IP)
 68100 216               IWIR = SHFTR(IWIR,3)
 68200 217               HCLL = SHFTR(IWIR,3) + 1
 68300 218               IF(IWIR.NE.IWIR0) HCLWR(HCLL) = HCLWR(HCLL) + 1
 68400 220               IWIR0 = IWIR
 68500 221            CFOR
 68600    C     PRINT 2004, HCLWR
 68700 223            MTRK = 0
 68800 224            HCLL1 =-99
 68900 225            FOR ICLL=1,48
 69000 226               IF HCLWR(ICLL).GE.6
 69100 227               THEN
 69200 230                  HDCLL = ICLL - HCLL1
 69300 231                  IF HDCLL.EQ.1
 69400 232                  THEN
 69500 235                     HCLL1 = -99
 69600 236                  ELSE
 69700 238                     IF HDCLL.NE.3 .OR. TBIT(ICLL,31)
 69800 239                     THEN
 69900 242                        MTRK = MTRK + 1
 70000 243                        HCLL1 = ICLL
 70100 244                     CIF
 70200 245                  CIF
 70300 246               CIF
 70400 247            CFOR
 70500 249            IF(MTRK.EQ.2 .OR. MTRK.EQ.3) LB1TCL = 1
 70600 251         CIF
 70700 252      CIF
 70800    C
 70900                                                                             SET LABEL FOR TRIGGER CHECK
 71100 253      IF(NTRCK .GE.2) LBTRCK = LBTRCK + 2                                2 TRACKS IN GENERAL
 71300 255      IF(NTRCK .EQ.1 .AND. LAND(LBTRBT,2).NE.0) LBTRCK = LBTRCK + 1      1 TRACK FOR TAGG-EVENTS ONLY
 71500 257      IF(NTREL .EQ.1) LBTRCK = LBTRCK + 4                                1 TRACK FOR ELECTRON EVENTS ONLY
 71700 259      IF(LB1TCL.EQ.1) LBTRCK = LBTRCK + 8                                1 TRACK +1 TRACK IN CLEAN RING 1
 71800    C     PRINT 2009, NTRCK,NTREL,LB1TCL,LBTRCK
 71900    C2009 FORMAT('0TRACKS:',4I6)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 72000 261      RETURN
 72100 262      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         261 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           1 WARNINGS         755 TARGET STATEMENTS
 00000    C   19/08/82 509161839  MEMBER NAME  REFIT    (JADEGS)      SHELTRAN
 00100   2      SUBROUTINE REFIT(IPTR,IPJHTL)
 00200    C
 00300    C        REFIT TRACK ITRK IN 'PATR'-BANK
 00400    C        P. STEFFEN                    80/08/19
 00500    C  CORRECTION OF UNINITIALIZED ARRAY NHTRNG     03.3.1984   J.OLSSON
 00510    C  REMOVAL OF DEBUG PRINT...                    16.9.1985   J.OLSSON
 00600    C
 00700   3      IMPLICIT INTEGER*2 (H)
 00800   4      LOGICAL DEADCL
 00900    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 --------------------------
 01100    C
          C----------------------------------------------------------------------
          C            MACRO CALIBR .... JADE CALIBRATION DATA COMMON
          C----------------------------------------------------------------------
         9      COMMON/CALIBR/ ACALIB(1000)
        10      DIMENSION HCALIB(100),ICALIB(100)
 02600  11      EQUIVALENCE(ACALIB(1),HCALIB(1),ICALIB(1))
          C------------------------ END OF MACRO CALIBR -------------------------
 01300    C
          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 --------------
 00100    C-------------------------------------------------------
 00200    C  MACRO CWORKEQ .... PATTERN RECOGNITION CWORK POINTERS
 00300    C-------------------------------------------------------
 00400  19      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))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 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 ------------------
 01600    C
 01700  20      EQUIVALENCE
 01800         ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
 01900         ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
 02000         ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
 02100    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  21      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----------------------------------------------------------------------
        22      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 -------------------------
 02400    C
 02500  23      INTEGER DATE(5), IDAY /0/
 02600  24      DIMENSION ITRCLL(6), NCNCK(24), NHTRNG(3)
 02700    C
 02900  25      INTEGER MKLRT1 /Z1000000/, MKLRT2 /Z100/                           MASK FOR L/R BIT IN HIT LABEL
 03000    C
 03200  26      INTEGER MKBDCL(3) /Z10,Z20,Z40/                                    MASK FOR TRACKS AT CELL WALL
 03300  27      INTEGER MKDDCL(3) /Z01,Z02,Z04/
 03400    C
 03500    C     IF(IDATA(IPTR+1).LT. 4) RETURN
 03600    C     I0 = IPTR + 1
 03700    C     I9 = IPTR + 48
 03800    C     PRINT 2001, (IDATA(I1),I1=I0,I9)
 03900    C     I0 = IPJHTL*2 + 1
 04000    C     I9 = I0 + IDATA(IPJHTL)*2 - 1
 04100    C     PRINT 2000, IPJHTL,I0,I9,(HDATA(I1),I1=I0,I9)
 04200    C     IPJETC = IDATA(IBLN('JETC'))
 04300    C     I0 = IPJETC*2 + 1
 04400    C     I9 = I0 + 109
 04500    C     PRINT 2000, IPJETC,I0,I9,(HDATA(I1),I1=I0,I9)
 04600    C2000 FORMAT('0REFIT:',3I8,/,(20(1X,Z4)))
 04700    C2001 FORMAT(1H0,2I3,I8,2(I4,3F6.1,3F6.3),
 04800    C    ,     /,14X,I3,4E13.5,F6.2,I3,4E13.5,
 04900    C    ,     /,14X,I3,2F8.3,F6.1,I3,10X,6I3,8I6,2X,Z4)
 05000    C2002 FORMAT('0FETCH:',2I3,2I5,12F9.5)
 05100    C2003 FORMAT('0ROTATION:',12F10.5)
 05200    C2004 FORMAT('0CIRC.CENTRE:',2I3, F10.5,2F10.0,F8.1,2F8.1)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 05300  28 2005 FORMAT('0TRACK:',I6,/,(1X,3I6,4F8.3,I4,F8.3,2I4,F8.3,I6,F8.3))
 05400  293001  FORMAT('0NHTRNG',3I6)
 05500    C2006 FORMAT(1X,I6,5F8.2,F12.1,5F8.2)
 05600    C2007 FORMAT(' FETCH:',I3,9F8.4,F10.5,F6.0)
 05700    C2008 FORMAT(' FIT:',2I3,F8.3,F5.0,3E13.5,2F8.3)
 05800    C2009 FORMAT(' JHTL:',I8,1X,Z8,3I5)
 05900    C2010 FORMAT(' HIT:',I6,12F8.2)
 06000    C2011 FORMAT('0ABERR:',10F10.6)
 06100    C2012 FORMAT('0ERROR:',10E13.6)
 06200    C2014 FORMAT('0FIT-BANK:',5F8.3,5X,5F8.3,5X,F8.5,2F8.1)
 06300    C2016 FORMAT('0ITRCLL =',6I8,/,(9X,6F8.3))
 06400    C
 06600  30      DATA LBINIT /0/                                                    INITIALIZATION
 06700  31      IF LBINIT .EQ. 0
 06800  32      THEN
 06900  35         LBINIT = 1
 07000  36         PERFORM INIT
 07100  39      CIF
 07200    C
 07400  40      IPHEAD = IDATA(IQHEAD)*2                                           GET RUN #
 07500  41      NRUN = HDATA(IPHEAD+10)
 07600  42      NEV  = HDATA(IPHEAD+11)
 07700    C
 07900  43      ITRK = IDATA(IPTR+1)                                               TRACK #
 08000    C
 08100    C
 08200    C
 08400  44      HPFREE = 1                                                         RESERVE SPACE IN CWORK
 08500  45      HPFRE1 = HPFREE
 08600    C
 08700    C
 08800                                                                             FETCH HITS, CALCULATE COORDINATES, AND
 09000  46      HPCO0  = HPFREE                                                    FILL ARRAY IN /CWORK/
 09100  47      LHIT   = 14
 09200  48      INDFET = 2
 09300  49      CALL JFETCH(IPTR,IPJHTL,WRK(HPCO0),LHIT,IPRES,INDFET)
 09400    C
 09500    C
 09600  50      HLDCO  = LHIT
 09700  51      HPCO9  = IPRES - 1
 09800  52      HPAR0  = IPRES
 09900  53      HLDPA  = 20
 10000  54      HPAR9  = HPAR0 + HLDPA - 1
 10100  55      HPFREE = HPAR9 + 1
 10200  56      XT     = WRK (IPRES   )
 10300  57      YT     = WRK (IPRES+ 1)
 10400  58      CSROT  = WRK (IPRES+ 2)
 10500  59      SNROT  = WRK (IPRES+ 3)
 10700  60      WRK(HPAR0+ 4) = 0.                                                 INITIALIZE FIT PARAMETERS IN CWORK
 10800  61      WRK(HPAR0+ 5) = 0.
 10900  62      WRK(HPAR0+ 6) = 0.
 11000  63      WRK(HPAR0+ 7) = 1000.
 11100  64      WRK(HPAR0+ 8) = 0.
 11200  65      CSTH   = WRK (IPRES+11)
 11300  66      SNTH   = WRK (IPRES+12)
 11400    C
 11600  67      ZVERT = ADATA(IPTR+31)                                             ZVERT, THETA
 11700  68      TGTH = ADATA(IPTR+30)
 11800    C     PRINT 2007, HPCO0,HPCO9,HDLCO,HPFREE,(WRK(I1),I1=HPAR0,HPAR9)
 11900    C
 12000    C
 12200  69      HPTR0 = HPFREE                                                     COPY TRACK BANK
 12300  70      CALL MVC(IWRK(HPTR0),0,IDATA(IPTR+1),0,192)
 12400  71      IWRK(HPTR0+1) = 0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 12500    C  SET ARRAY NHTRNG    CORRECTION FROM 29.2.1984   J.OLSSON
 12600  72      IPCO = HPCO0 - HLDCO
 12700  73      NHTRNG(1) = 0
 12800  74      NHTRNG(2) = 0
 12900  75      NHTRNG(3) = 0
 13000  76      ILAYOL = -1
 13100  77      REPEAT
 13200  78         IPCO = IPCO + HLDCO
 13300  79         ILAY = IWRK(IPCO   )
 13400  80         IF ILAY.NE.ILAYOL
 13500  81         THEN
 13600  84            JRING = IWRK(IPCO+12)
 13700  85            NHTRNG(JRING) = NHTRNG(JRING) + 1
 13800  86            ILAYOL = ILAY
 13900  87         CIF
 14000  88      UNTIL IPCO.GE.HPCO9-HLDCO
 14100    C
 14200    C      PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 14300    C      PRINT 3001, (NHTRNG(IR),IR=1,3)
 14400  89      HPFREE = HPFREE + 48
 14500    C
 14600    C
 14700    C
 14800  93      REPEAT
 14900    C
 15000    C
 15100                                                                             1. PARABOLA FIT
 15300  94         JRINGL = 3                                                      LAST RING INCLUDED IN FIT
 15400  95         PERFORM FPARA0
 15500    C
 15700  98         ALBLM1 = 0.6                                                    RELABEL HITS
 15800  99         ALBLM2 = 3.0
 15900 100         PERFORM LABEL
 16000    C       PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 16100    C
 16200 103         REPEAT
 16400 104            PERFORM FPARA0                                               REFIT PARABOLA
 16500    C
 16700 107            PERFORM LABEL                                                RELABEL HITS
 16800    C
 17000 110         UNTIL NHGOOD-NHFIT .LT.4                                        REPEAT FIT IF >3 NEW GOOD HITS
 17100    C       PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 17200    C
 17400 111         IF SIG.LT.1.                                                    SET UP FIT-BANK
 17500 115         THEN
 17600 118            PERFORM FITBNK
 17700 121         CIF
 17800    C
 18000 122         IF(SIG.LT..10) XREPEAT                                          STOP IF SIG < .10
 18100    C
 18300 124         IF(ABS(PAR1).LT..00030) XREPEAT                                 STOP IF HIGH MOMENTUM
 18400    C
 18600 126         IF(NHTRNG(1)+NHTRNG(2).LE.16) XREPEAT                           STOP IF NOT ENOUGH HITS IN R1 + R2
 18700    C
 18900 128         ALBLM1 = 2.0                                                    CONTINUE + FIT ONLY R1 + R2
 19000 129         ALBLM2 = 3.0
 19100 130         PERFORM LABEL
 19200 133         JRINGL = 2
 19300 134         PERFORM FPARA0
 19400 137         ALBLM1 = 1.0
 19500 138         PERFORM LABEL
 19600 141         PERFORM FPARA0
 19700 144         PERFORM LABEL
 19800 147         IF SIG.LT..20
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 19900 148         THEN
 20000 151            PERFORM FITBK1
 20100 154         CIF
 20200    C       IF(ITRK.EQ.17) PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 20300    C
 20500 155         IF(SIG.LT..20) XREPEAT                                          STOP IF GOOD FIT
 20600    C
 20800 157         IF(ABS(PAR1).LT..00150) XREPEAT                                 STOP IF NOT LOW MOMENTUM
 20900    C
 21100 159         IF(NHTRNG(1).LE.9) XREPEAT                                      STOP IF NOT ENOUGH HITS IN R1
 21200    C
 21400 161         ALBLM1 = 2.0                                                    CONTINUE + FIT IN R1 ONLY
 21500 162         ALBLM2 = 3.0
 21600 163         PERFORM LABEL
 21700 166         JRINGL = 1
 21800 167         NHTFIT = NHTRNG(1)
 21900 168         IF NHTFIT.LE.5
 22000 169         THEN
 22100 172            NHTFIT = NHTFIT + NHTRNG(2)
 22200 173            JRINGL = 2
 22300 174         CIF
 22400 175         IF NHTFIT.GT.9
 22500 176         THEN
 22600 179            PERFORM FPARA0
 22700 182            ALBLM1 = 1.0
 22800 183            PERFORM LABEL
 22900 186            PERFORM FPARA0
 23000 189            PERFORM LABEL
 23100 192            IF SIG.LT..20
 23200 193            THEN
 23300 196               PERFORM FITBK1
 23400 199            CIF
 23500 200         CIF
 23600    C       IF(ITRK.EQ.17) PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 23700    C
 23800    C
 23900 201      UNTIL .TRUE.
 24000    C
 24100    C
 24200 202      HPFREE = HPFRE1
 24300 206      RETURN
 24400    C
 24500                                                                             *************************
 24600                                                                             *      F P A R A 0      *
 24800    C                                                                        *************************
 24900    C
 25100 207      PROC FPARA0                                                        PARABOLA FIT THROUG ORIGIN
 25200    C
 25300                                                                             GET EQUATIONS
 25500 208         S0 = 0.                                                         WEIGHT ORIGIN AS POINT OF PARABOLA
 25600 209         S1 = 0.
 25700 210         S2 = 0.
 25800 211         S3 = 0.
 25900 212         S4 = 0.
 26000 213         S7 = 0.
 26100 214         S6 = 0.
 26200 215         S5 = 0.
 26300 216         IPCO = HPCO0
 26400 217         REPEAT
 26500 218            IF IWRK(IPCO+ 10).EQ.0 .AND. IWRK(IPCO+12).LE.JRINGL
 26600 219            THEN
 26700 222               X = WRK(IPCO+3)
 26800 223               Y = WRK(IPCO+4)
 26900 224               X2 = X**2
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 27000 225               S1 = S1 + X
 27100 226               S2 = S2 + X2
 27200 227               S3 = S3 + X*X2
 27300 228               S4 = S4 + X2**2
 27400 229               S5 = S5 + Y*X2
 27500 230               S6 = S6 + Y*X
 27600 231               S7 = S7 + Y
 27700 232               S0 = S0 + 1.
 27800 233            CIF
 27900 234            IPCO = IPCO + HLDCO
 28000 235         UNTIL IPCO.GT.HPCO9
 28100 236         IF S0.LT.3.5
 28200 240         THEN
 28300 243            SIG = 1000.
 28400 244         ELSE
 28500    C
 28700 246            F1 = 1. / S4                                                 SOLVE EQUATIONS FOR PARABOLA FIT
 28800 247            XX12 = S3*F1
 28900 248            XX13 = S2*F1
 29000 249            YY1  = S5*F1
 29100 250            XX22 = S2 - S3*XX12
 29200 251            XX23 = S1 - S3*XX13
 29300 252            YY2  = S6 - S3*YY1
 29400 253            XX32 = S1 - S2*XX12
 29500 254            XX33 = S0 - S2*XX13
 29600 255            YY3  = S7 - S2*YY1
 29700 256            IF XX22.GT.XX32
 29800 257            THEN
 29900 260               XX23 = XX23 / XX22
 30000 261               YY2  = YY2  / XX22
 30100 262               PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 30200 263               PAR2 = YY2 - XX23*PAR3
 30300 264            ELSE
 30400 266               XX33 = XX33 / XX32
 30500 267               YY3  = YY3  / XX32
 30600 268               PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 30700 269               PAR2 = YY3 - XX33*PAR3
 30800 270            CIF
 30900 271            PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
 31000 272            DEG = S0 - 3.
 31100 273            NHFIT = S0 + .1
 31200    C
 31300    C
 31500 274            CHISQ = 0.                                                   CALC. CHISQ + SOLVE L/R AMBIGUITY
 31600 275            DCHIM1 = 0.
 31700 276            IHITM1 = 0
 31800 277            XST    = 999999.
 31900 278            XEN    =-999999.
 32000 279            IPCO = HPCO0
 32100 280            REPEAT
 32200 281               IF IWRK(IPCO+ 10).EQ.0 .AND. IWRK(IPCO+12).LE.JRINGL
 32300 282               THEN
 32400 285                  X = WRK(IPCO+3)
 32500 286                  IF(X.LT.XST) XST = X
 32600 288                  IF(X.GT.XEN) XEN = X
 32700 290                  Y = WRK(IPCO+4)
 32800 291                  F = (PAR1 *X + PAR2 )*X + PAR3
 32900 292                  DCHI = Y - F
 33000 293                  WRK(IPCO+13) = DCHI
 33200 294                  CHISQ = CHISQ + DCHI**2                                SUM FOR RMS
 33400    C           IF ABS(DCHI).GE.DCHIM1                                       KEEP BIGGEST RMS
 33500    C           THEN
 33600    C             DCHIM1 = ABS(DCHI)
 33700    C             IHITM1 = IPCO
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 33800    C           CIF
 33900    C     PRINT 2006, IPCO,X,Y,F,DCHI,CHISQ
 34000 295               CIF
 34100 296               IPCO = IPCO + HLDCO
 34200 297            UNTIL IPCO.GT.HPCO9
 34300 298            SIG    =      CHISQ  / DEG
 34400    C     PRINT 2008, JRINGL,IWRK(IHEND),SIG,DEG,PAR1,PAR2,PAR3,WGHT0,Y0
 34500    C     PRINT 2012, S0,S1,S2,S3,S4,S5,S6,S7
 34600    C
 34700 302         CIF
 34800    C
 34900 303      CPROC
 35000    C
 35100                                                                             *************************
 35200                                                                             *      F I T B N K      *
 35400    C                                                                        *************************
 35500    C
 35700 305      PROC FITBNK                                                        SET UP FIT-BANK
 35800    C
 36000 306         YST  = (PAR1 *XST + PAR2 )*XST + PAR3                           START + END POINTS
 36100 307         YEN  = (PAR1 *XEN + PAR2 )*XEN + PAR3
 36300 308         TGST = PAR1*XST*2 + PAR2                                        DIRECTION AT START + END POINT
 36400 309         DXST = 1./SQRT(TGST**2+1.)
 36500 310         DYST = DXST * TGST
 36600 311         TGEN = PAR1*XEN*2 + PAR2
 36700 312         DXEN = 1./SQRT(TGEN**2+1.)
 36800 313         DYEN = DXEN * TGEN
 37000 314         XMIN = -PAR2*.5 / PAR1                                          MIN. OF PARABOLA
 37100 315         YMIN = (PAR1*XMIN + PAR2)*XMIN + PAR3
 37200    C
 37400    C     CURV =-PAR1 * 2.                                                   CURVATURE + ERROR
 37500 316         CVZW = TGST**2+1.
 37600 317         CVST =-PAR1 * 2 / (SQRT(CVZW)*CVZW)
 37700 318         DET = (S2*S0-S1*S1)*S4 + (S2*S1-S3*S0)*S3 + (S3*S1-S2*S2)*S2
 37800 319         SIG11 = (S2*S0 - S1*S1)/DET
 37900 320         SIG22 = (S4*S0 - S2*S2)/DET
 38000 321         SIG33 = (S4*S2 - S3*S3)/DET
 38100 322         SIG12 = (S3*S0 - S2*S1)/DET
 38200 323         SIG13 = (S3*S1 - S2*S2)/DET
 38300 324         SIG23 = (S4*S1 - S3*S2)/DET
 38400    C     PRINT 2012, DET,SIG11,SIG22,SIG33,SIG12,SIG13,SIG23,SIG
 38500    C
 38600    C
 38700    C     PRINT 2014, XST,YST,DXST,DYST,TGST,XEN,YEN,DXEN,DYEN,TGEN,CURV
 38800    C
 39000 325         IP    = HPTR0 - 1                                               FILL FIT-BANK
 39100 326         IWRK(IP+ 1) = ITRK
 39200 327         IWRK(IP+ 2) = 16
 39300 328         IWRK(IP+ 3) = IDAY
 39400 329         IWRK(IP+ 4) =  0
 39500 330         WRK (IP+ 5) = XST *CSROT - YST *SNROT + XT
 39600 331         WRK (IP+ 6) = XST *SNROT + YST *CSROT + YT
 39700 332         WRK (IP+ 7) = SQRT(WRK(IP+ 5)**2 + WRK(IP+ 6)**2) * TGTH + ZVERT
 39800 333         WRK (IP+ 8) = (DXST*CSROT - DYST*SNROT)*CSTH
 39900 334         WRK (IP+ 9) = (DXST*SNROT + DYST*CSROT)*CSTH
 40000 335         WRK (IP+10) = SNTH
 40100 336         IWRK(IP+11) = 0
 40200 337         WRK (IP+12) = XEN *CSROT - YEN *SNROT + XT
 40300 338         WRK (IP+13) = XEN *SNROT + YEN *CSROT + YT
 40400 339         WRK (IP+14) = SQRT(WRK(IP+12)**2 + WRK(IP+13)**2) * TGTH + ZVERT
 40500 340         WRK (IP+15) = (DXEN*CSROT - DYEN*SNROT)*CSTH
 40600 341         WRK (IP+16) = (DXEN*SNROT + DYEN*CSROT)*CSTH
 40700 342         WRK (IP+17) = SNTH
 40800 343         IWRK(IP+18) = 2
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 40900 344         WRK (IP+19) = ATAN2(SNROT,CSROT)
 41000 345         WRK (IP+20) = XMIN*CSROT - YMIN*SNROT + XT
 41100 346         WRK (IP+21) = XMIN*SNROT + YMIN*CSROT + YT
 41200 347         WRK (IP+22) = PAR1
 41300 348         IF(SIG  .LT.0) PRINT 2021,WRK(IP+1),S0,SIG
 41400 350 2021 FORMAT(' REFIT(PST): -VE SQRT:',I4,5E13.5)
 41500 351         WRK (IP+23) = SIG
 41600 352         IF(SIG  .GT.0) WRK(IP+23) = SQRT(SIG)
 41700 354         IWRK(IP+24) = S0 + .001
 41800 355         WRK (IP+25) = CVST
 41900 356         IF(SIG11.LT.0) PRINT 2021,WRK(IP+1),S0,SIG,SIG11
 42000 358         WRK (IP+26) = SIG*SIG11
 42100 359         IF(WRK(IP+26) .GT. 0) WRK(IP+26) = SQRT(WRK(IP+26))*2.
 42200 361         WRK (IP+27) = CVST
 42300 362         WRK (IP+28) = CVST
 42400 363         I0 = IP+ 1
 42500 364         I9 = IP+48
 42600    C     PRINT 2001,(WRK(I1),I1=I0,I9)
 42700 365      CPROC
 42800    C
 42900                                                                             *************************
 43000                                                                             *      F I T B K 1      *
 43200    C                                                                        *************************
 43300    C
 43500 367      PROC FITBK1                                                        CHANGE FIT BANK (1.POINT)
 43600    C
 43800 368         YST  = (PAR1 *XST + PAR2 )*XST + PAR3                           START POINT
 44000 369         TGST = PAR1*XST*2 + PAR2                                        DIRECTION AT START POINT
 44100 370         DXST = 1./SQRT(TGST**2+1.)
 44200 371         DYST = DXST * TGST
 44400 372         XMIN = -PAR2*.5 / PAR1                                          MIN. OF PARABOLA
 44500 373         YMIN = (PAR1*XMIN + PAR2)*XMIN + PAR3
 44600    C
 44800    C     CURV =-PAR1 * 2.                                                   CURVATURE + ERROR
 44900 374         CVZW = TGST**2+1.
 45000 375         CVST =-PAR1 * 2 / (SQRT(CVZW)*CVZW)
 45100 376         DET = (S2*S0-S1*S1)*S4 + (S2*S1-S3*S0)*S3 + (S3*S1-S2*S2)*S2
 45200 377         SIG11 = (S2*S0 - S1*S1)/DET
 45300 378         SIG22 = (S4*S0 - S2*S2)/DET
 45400 379         SIG33 = (S4*S2 - S3*S3)/DET
 45500 380         SIG12 = (S3*S0 - S2*S1)/DET
 45600 381         SIG13 = (S3*S1 - S2*S2)/DET
 45700 382         SIG23 = (S4*S1 - S3*S2)/DET
 45800    C     PRINT 2012, DET,SIG11,SIG22,SIG33,SIG12,SIG13,SIG23,SIG
 45900    C
 46000    C     PRINT 2014, XST,YST,DXST,DYST,TGST,XEN,YEN,DXEN,DYEN,TGEN,CURV,
 46100    C    ,            XMIN,YMIN
 46200    C
 46400 383         IP    = HPTR0 - 1                                               FILL FIT-BANK
 46500 384         WRK (IP+ 5) = XST *CSROT - YST *SNROT + XT
 46600 385         WRK (IP+ 6) = XST *SNROT + YST *CSROT + YT
 46700 386         WRK (IP+ 7) = SQRT(WRK(IP+ 5)**2 + WRK(IP+ 6)**2) * TGTH + ZVERT
 46800 387         WRK (IP+ 8) = (DXST*CSROT - DYST*SNROT)*CSTH
 46900 388         WRK (IP+ 9) = (DXST*SNROT + DYST*CSROT)*CSTH
 47000 389         WRK (IP+10) = SNTH
 47100 390         IWRK(IP+18) = 2
 47200 391         WRK (IP+19) = ATAN2(SNROT,CSROT)
 47300 392         WRK (IP+20) = XMIN*CSROT - YMIN*SNROT + XT
 47400 393         WRK (IP+21) = XMIN*SNROT + YMIN*CSROT + YT
 47500 394         WRK (IP+22) = PAR1
 47600 395         IF(SIG  .LT.0) PRINT 2022,WRK(IP+1),S0,SIG
 47700 397 2022 FORMAT(' REFIT(PST): -VE SQRT(1):',I4,5E13.5)
 47800 398         WRK (IP+23) = SIG
 47900 399         IF(SIG  .GT.0) WRK(IP+23) = SQRT(SIG)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 48000 401         IWRK(IP+24) = S0 + .001
 48100 402         WRK (IP+25) = CVST
 48200 403         IF(SIG11.LT.0) PRINT 2022,WRK(IP+1),S0,SIG,SIG11
 48300 405         WRK (IP+26) = SIG*SIG11
 48400 406         IF(WRK(IP+26) .GT. 0) WRK(IP+26) = SQRT(WRK(IP+26))*2.
 48500 408         WRK (IP+27) = CVST
 48600    C     I0 = IP+ 1
 48700    C     I9 = IP+48
 48800    C     PRINT 2001,(WRK(I1),I1=I0,I9)
 48900 409      CPROC
 49000    C
 49100    C
 49200                                                                             *************************
 49300                                                                             *      L A B E L        *
 49500    C                                                                        *************************
 49600    C
 49800 411      PROC LABEL                                                         LABEL USED HITS
 49900    C
 50100 412         NHGOOD = 0                                                      PRESET LAST HIT POINTER
 50200 413         IWL = -999
 50300 414         FOR IP = HPCO0,HPCO9,HLDCO
 50400 415            IW0 = IWRK(IP)
 50500 416            X   = WRK(IP+3)
 50600 417            Y   = WRK(IP+4)
 50700 418            F   = (PAR1*X + PAR2)*X + PAR3
 50800 419            DF  = F - Y
 51000 420            LBGOOD = 4                                                   SELECT CLOSEST HIT
 51100 421            IF(ABS(DF).LT.ALBLM2) LBGOOD = 1
 51200 423            IF(ABS(DF).LT.ALBLM1) LBGOOD = 0
 51300 425            IWRK(IP+ 10) = LBGOOD
 51400 426            IF(LBGOOD.EQ.0) NHGOOD = NHGOOD + 1
 51500 428            WRK (IP+13) = DF
 51600    C
 51800 429            IF IWL.EQ.IW0                                                CHECK IF 2 HITS FROM SAME WIRE
 51900 430            THEN
 52100 433               IF ABS(DFL).LT.ABS(DF)                                    SELECT CLOSEST HIT
 52200 434               THEN
 52300 437                  IF(IWRK(IP +10).EQ.0) NHGOOD = NHGOOD - 1
 52400 439                  IWRK(IP +10) = 16
 52500 440               ELSE
 52600 442                  IF(IWRK(IPL+10).EQ.0) NHGOOD = NHGOOD - 1
 52700 444                  IWRK(IPL+10) = 16
 52800 445               CIF
 52900 446            CIF
 53100 447            IWL = IW0                                                    STORE LAST POINTERS + DF
 53200 448            IPL = IP
 53300 449            DFL = DF
 53400 450         CFOR
 53500    C
 53600 452      CPROC
 53700    C
 53800    C
 53900                                                                             *************************
 54000                                                                             *      I N I T          *
 54200    C                                                                        *************************
 54300    C
 54500 454      PROC INIT                                                          INITIALIZE CONSTANTS
 54600    C
 54700 455         IQHEAD = IBLN('HEAD')
 54800    C
 54900 456         CALL DAY2(DATE)
 55000 457         IDAY = DATE(1)*1000 + DATE(2)
 55100    C
 55200 458      CPROC
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 55300    C
 55400 460      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         459 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         459 TARGET STATEMENTS
 00000    C   16/08/82 509161841  MEMBER NAME  REFITV   (JADEGS)      SHELTRAN
 00100   2      SUBROUTINE REFITV(IPTR,IPJHTL,ERRFAC)
 00200    C
 00300    C        REFIT TRACK ITRK IN 'PATR'-BANK USING ORIGIN
 00400    C                   ONLY INTERMEDIATE VALUES STORED
 00500    C                   FOR POSITION + DIRECTION AT 1. AND LAST HIT
 00600    C                   THIS ROUTINE IS ONLY USED WITH SUBSEQUENT ZRFIT
 00700    C                   USE REFITV IF ONLY R-PHI-FIT WANTED
 00800    C        P. STEFFEN                    22/08/80
 00900    C  CORRECTION OF UNINITIALIZED ARRAY NHTRNG     29.2.1984   J.OLSSON
 00910    C  REMOVAL OF DEBUG PRINT...                    16.9.1985   J.OLSSON
 01000    C
 01100   3      IMPLICIT INTEGER*2 (H)
 01200   4      LOGICAL DEADCL
 01300    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 --------------------------
 01500    C
          C-----------------------------------------------------------------------
          C                            MACRO CGEO1 .... JADE GEOMETRY
          C-----------------------------------------------------------------------
          C
         9      COMMON / CGEO1 / BKGAUS,
               +                 RPIP,DRPIP,XRLPIP,   RBPC,DRBPC,XRLBPC,
               +                 RITNK,DRITNK,XRLTKI, R0ROH,DR0ROH,XR0ROH,
               +                 R1ROH,DR1ROH,XR1ROH, R2ROH,DR2ROH,XR2ROH,
               +                 R3ROH,DR3ROH,XR3ROH, ROTNK,DROTNK,XRLTKO,
               +                 RTOF,DRTOF,XRTOF,    RCOIL,DRCOIL,XRCOIL,
               +                 ZJM,DZJM,XRZJM,ZJP,DZJP,XRZJP,ZTKM,DZTKM,XRZTKM,
               +                 ZTKP,DZTKP,XRZTKP,ZBPPL,ZBPMI,ZTOFPL,ZTOFMI,
               +                 XRJETC,RLG,ZLGPL,ZLGMI,OUTR2,CTLIMP,
               +                 CTLIMM,DELFI,BLXY,BLZ,BLDEP,ZENDPL,ZENDMI,DEPEND,
               +                 XHOL1,XHOL2,YHOL1,YHOL2,BLFI
          C
          C------------------------- END OF MACRO CGEO1 --------------------------
          C
 01700    C
          C----------------------------------------------------------------------
          C            MACRO CALIBR .... JADE CALIBRATION DATA COMMON
          C----------------------------------------------------------------------
        10      COMMON/CALIBR/ ACALIB(1000)
        11      DIMENSION HCALIB(100),ICALIB(100)
 02600  12      EQUIVALENCE(ACALIB(1),HCALIB(1),ICALIB(1))
          C------------------------ END OF MACRO CALIBR -------------------------
 01900    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        13      COMMON /CWORK/ HPLAST,HPFREE,HPWRK(30),ADWRK(600),
               ,               HPRO,HNTR,HNTCEL(98),IPCL(200),NRHT(200),
               ,               NWR1(200),DS1(200),SL1(200),
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
               ,               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)
        14      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        15      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        16      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        17      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        18      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        19      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  20      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 ------------------
 02200    C
 02300  21      EQUIVALENCE
 02400         ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
 02500         ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
 02600         ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
 02700    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        22      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        23      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        24      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        25      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        26      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 --------------
 02900    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  27      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  <----
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 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----------------------------------------------------------------------
        28      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 -------------------------
 03200    C
 03300  29      INTEGER DATE(5), IDAY /0/
 03400  30      DIMENSION ITRCLL(6), NCNCK(24), NHTRNG(3)
 03500    C
 03700  31      DATA RESJ0 /.200/, RESV0 /.300/                                    JET-CHAMBER AND VERTEX RESOLUTION
 03800    C
 04000  32      INTEGER MKLRT1 /Z1000000/, MKLRT2 /Z100/                           MASK FOR L/R BIT IN HIT LABEL
 04100    C
 04300  33      INTEGER MKBDCL(3) /Z10,Z20,Z40/                                    MASK FOR TRACKS AT CELL WALL
 04400  34      INTEGER MKDDCL(3) /Z01,Z02,Z04/
 04500    C
 04600    C     IF(IDATA(IPTR+1).LT. 4) RETURN
 04700    C     I0 = IPTR + 1
 04800    C     I9 = IPTR + 48
 04900    C     PRINT 2001, (IDATA(I1),I1=I0,I9)
 05000    C     I0 = IPJHTL*2 + 1
 05100    C     I9 = I0 + IDATA(IPJHTL)*2 - 1
 05200    C     PRINT 2000, IPJHTL,I0,I9,(HDATA(I1),I1=I0,I9)
 05300    C     IPJETC = IDATA(IBLN('JETC'))
 05400    C     I0 = IPJETC*2 + 1
 05500    C     I9 = I0 + 109
 05600    C     PRINT 2000, IPJETC,I0,I9,(HDATA(I1),I1=I0,I9)
 05700    C2000 FORMAT('0REFIT:',3I8,/,(20(1X,Z4)))
 05800    C2001 FORMAT(1H0,2I3,I8,2(I4,3F6.1,3F6.3),
 05900    C    ,     /,14X,I3,4E13.5,F6.2,I3,4E13.5,
 06000    C    ,     /,14X,I3,2F8.3,F6.1,I3,10X,6I3,8I6,2X,Z4)
 06100    C2002 FORMAT('0FETCH:',2I3,2I5,12F9.5)
 06200    C2003 FORMAT('0ROTATION:',12F10.5)
 06300    C2004 FORMAT('0CIRC.CENTRE:',2I3, F10.5,2F10.0,F8.1,2F8.1)
 06400  352005  FORMAT('0TRACK:',I6,/,(1X,3I6,4F8.3,I4,F8.3,2I4,F8.3,I6,F8.2))
 06500  363001  FORMAT('0NHTRNG',3I6)
 06600    C2006 FORMAT(1X,I6,5F8.3,F12.1,5F8.3)
 06700    C2007 FORMAT(' FETCH:',I3,9F8.4,F10.5,F6.0)
 06800    C2008 FORMAT(' FIT:',2I3,2F8.3,F5.0,3E12.5,F6.3,F6.3)
 06900    C2009 FORMAT(' JHTL:',I8,1X,Z8,3I5)
 07000    C2010 FORMAT(' HIT:',I6,12F8.2)
 07100    C2011 FORMAT('0ABERR:',10F10.6)
 07200    C2012 FORMAT('0ERROR:',10E13.6)
 07300    C2014 FORMAT('0FIT-BANK:',5F8.3,5X,5F8.3,5X,F8.5,2F8.1)
 07400    C2016 FORMAT('0ITRCLL =',6I8,/,(9X,6F8.3))
 07500    C2107 FORMAT(' SIGLM:',10F8.3)
 07600    C
 07800  37      DATA LBINIT /0/                                                    INITIALIZATION
 07900  38      IF LBINIT .EQ. 0
 08000  39      THEN
 08100  42         LBINIT = 1
 08200  43         PERFORM INIT
 08300  46      CIF
 08400    C
 08500    C
 08700  47      IPHEAD = IDATA(IQHEAD)*2                                           GET RUN #
 08800  48      NRUN = HDATA(IPHEAD+10)
 08900  49      NEV  = HDATA(IPHEAD+11)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 09000    C
 09200  50      ITRK = IDATA(IPTR+1)                                               TRACK #
 09300    C
 09400    C
 09600  51      HPFREE = 1                                                         RESERVE SPACE IN CWORK
 09700  52      HPFRE1 = HPFREE
 09800    C
 10000  53      IPV    = ICALIB(10)                                                GET X-Y-VERTEX AND DETERMINE ERROR
 10100  54      XO     = ACALIB(IPV+ 1)
 10200  55      YO     = ACALIB(IPV+ 3)
 10300    C     I0 = IPV + 1
 10400    C     I9 = IPV + 6
 10500    C     PRINT 2029, XO,YO,(ACALIB(I1),I1=I0,I9)
 10600  56      PTRANS = ABS(0.0299792458*BKGAUS/ADATA(IPTR+25)) * .001
 10700  57      RESV   = RESV0**2 + RESMS / PTRANS**2
 10800  58      WGHT0  = RESJ0**2 / RESV
 10900  59      F1     = ERRFAC
 11000  60      IF(F1 .LT. .10) F1 = .10
 11100  62      WGHT0  = WGHT0 / F1**2
 11200    C     PRINT 2029, XO,YO,WGHT0,F1,RESV,RESMS,PTRANS
 11300    C2029 FORMAT(' VERTEX',9E13.5)
 11400    C     PRINT 2011,ABERR
 11500    C
 11600    C
 11700                                                                             FETCH HITS, CALCULATE COORDINATES, AND
 11900  63      HPCO0  = HPFREE                                                    FILL ARRAY IN /CWORK/
 12000  64      LHIT   = 14
 12100  65      INDFET = 3
 12200  66      CALL JFETCH(IPTR,IPJHTL,WRK(HPCO0),LHIT,IPRES,INDFET,XO,YO)
 12300    C
 12400    C
 12500  67      HLDCO  = LHIT
 12600  68      HPCO9  = IPRES - 1
 12700  69      HPAR0  = IPRES
 12800  70      HLDPA  = 20
 12900  71      HPAR9  = HPAR0 + HLDPA - 1
 13000  72      HPFREE = HPAR9 + 1
 13100  73      XT     = WRK (IPRES   )
 13200  74      YT     = WRK (IPRES+ 1)
 13300  75      CSROT  = WRK (IPRES+ 2)
 13400  76      SNROT  = WRK (IPRES+ 3)
 13500  77      X0     = WRK (IPRES+ 9)
 13600  78      Y0     = WRK (IPRES+10)
 13700  79      XOR    =- XT*CSROT -  YT*SNROT
 13800  80      YOR    =  XT*SNROT -  YT*CSROT
 13900    C     PRINT 2003, CSROT,SNROT,XX,YY,XT,YT,X0,Y0,XO,YO,XOR,YOR,WGHT0
 14000    C
 14200  81      WRK(HPAR0+ 4) = 0.                                                 INITIALIZE FIT PARAMETERS IN CWORK
 14300  82      WRK(HPAR0+ 5) = 0.
 14400  83      WRK(HPAR0+ 6) = 0.
 14500  84      WRK(HPAR0+ 7) = 1000.
 14600  85      WRK(HPAR0+ 8) = 0.
 14700  86      CSTH   = WRK (IPRES+11)
 14800  87      SNTH   = WRK (IPRES+12)
 14900    C
 15100  88      ZVERT = ADATA(IPTR+31)                                             ZVERT, THETA
 15200  89      TGTH = ADATA(IPTR+30)
 15300    C     PRINT 2007, HPCO0,HPCO9,HDLCO,HPFREE,(WRK(I1),I1=HPAR0,HPAR9)
 15400    C
 15500    C
 15700  90      HPTR0 = HPFREE                                                     COPY TRACK BANK
 15800  91      CALL MVC(IWRK(HPTR0),0,IDATA(IPTR+1),0,192)
 15900  92      HPFREE = HPFREE + 48
 16000  93      IWRK(HPTR0+1) = 0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 16100    C  SET ARRAY NHTRNG    CORRECTION FROM 29.2.1984   J.OLSSON
 16200  94      IPCO = HPCO0 - HLDCO
 16300  95      NHTRNG(1) = 0
 16400  96      NHTRNG(2) = 0
 16500  97      NHTRNG(3) = 0
 16600  98      ILAYOL = -1
 16700  99      REPEAT
 16800 100         IPCO = IPCO + HLDCO
 16900 101         ILAY = IWRK(IPCO   )
 17000 102         IF ILAY.NE.ILAYOL
 17100 103         THEN
 17200 106            JRING = IWRK(IPCO+12)
 17300 107            NHTRNG(JRING) = NHTRNG(JRING) + 1
 17400 108            ILAYOL = ILAY
 17500 109         CIF
 17600 110      UNTIL IPCO.GE.HPCO9-HLDCO
 17700    C
 17800    C      PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 17900    C      PRINT 3001, (NHTRNG(IR),IR=1,3)
 18000    C
 18100    C
 18200                                                                             1. PARABOLA FIT
 18400 111      JRINGL = 3                                                         LAST RING INCLUDED IN FIT
 18500 115      PERFORM FPARA0
 18600    C
 18800 118      ALBLM1 = 0.6                                                       RELABEL HITS
 18900 119      ALBLM2 = 3.0
 19000 120      PERFORM LABEL
 19100    C     PRINT 2005, NHFIT,(WRK(I),I=HPCO0,HPCO9)
 19200    C
 19300
 19400 123      REPEAT
 19600 124         PERFORM FPARA0                                                  REFIT PARABOLA
 19700    C
 19900 127         PERFORM LABEL                                                   RELABEL HITS
 20000    C
 20200 130      UNTIL NHGOOD-NHFIT .LT.4                                           REPEAT FIT IF >3 NEW GOOD HITS
 20300    C
 20400    C     PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 20500    C
 20700 131      IF SIG.LT.1.                                                       SET UP FIT-BANK
 20800 135      THEN
 20900 138         PERFORM FITBNK
 21000 141      CIF
 21100    C
 21300 142      IF ABS(PAR1).GT..00030 .AND. NHTRNG(1)+NHTRNG(2).GT.16             CHECK IF BAD FIT AND LOW MOMENTUM
 21400 143      THEN
 21500 146         ALBLM1 = 1.5
 21600 147         ALBLM2 = 3.0
 21700 148         PERFORM LABEL
 21800 151         JRINGL = 2
 21900 152         PERFORM FPARA0
 22000 155         ALBLM1 = 0.6
 22100 156         PERFORM LABEL
 22200 159         PERFORM FPARA0
 22300 162         PERFORM LABEL
 22400 165         IF SIG.LT..10
 22500 166         THEN
 22600 169            PERFORM FITBK1
 22700 172            IWRK(IP+ 4) = 32
 22800 173         CIF
 22900 174      CIF
 23000 175      IF ABS(PAR1).GT..00150 .AND. NHTRNG(1)+NHTRNG(2).GT.9
 23100 176      THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 23200 179         ALBLM1 = 1.5
 23300 180         ALBLM2 = 3.0
 23400 181         PERFORM LABEL
 23500 184         JRINGL = 1
 23600 185         NHTFIT = NHTRNG(1)
 23700 186         IF NHTFIT.LE.5
 23800 187         THEN
 23900 190            NHTFIT = NHTFIT + NHTRNG(2)
 24000 191            JRINGL = 2
 24100 192         CIF
 24200 193         IF NHTFIT.GT.9
 24300 194         THEN
 24400 197            PERFORM FPARA0
 24500 200            ALBLM1 = 0.6
 24600 201            PERFORM LABEL
 24700 204            PERFORM FPARA0
 24800 207            PERFORM LABEL
 24900 210            IF SIG.LT..10
 25000 211            THEN
 25100 214               PERFORM FITBK1
 25200 217               IWRK(IP+ 4) = 48
 25300 218            CIF
 25400 219         CIF
 25500 220      CIF
 25600    C
 25700    C     PRINT 2005, LBCELL,(WRK(I),I=HPCO0,HPCO9)
 25800 221      HPFREE = HPFRE1
 25900 222      RETURN
 26000    C
 26100                                                                             *************************
 26200                                                                             *      F P A R A 0      *
 26400    C                                                                        *************************
 26500    C
 26700 223      PROC FPARA0                                                        PARABOLA FIT THROUG ORIGIN
 26800    C
 26900                                                                             GET EQUATIONS
 27100 224         S0 = WGHT0                                                      WEIGHT ORIGIN AS POINT OF PARABOLA
 27200 225         S1 = X0*WGHT0
 27300 226         S2 = S1*X0
 27400 227         S3 = S2*X0
 27500 228         S4 = S3*X0
 27600 229         S7 = Y0 * WGHT0
 27700 230         S6 = S7*X0
 27800 231         S5 = S6*X0
 27900 232         IPCO = HPCO0
 28000 233         REPEAT
 28100 234            IF IWRK(IPCO+ 10).EQ.0 .AND. IWRK(IPCO+12).LE.JRINGL
 28200 235            THEN
 28300 238               X = WRK(IPCO+3)
 28400 239               Y = WRK(IPCO+4)
 28500 240               X2 = X**2
 28600 241               S1 = S1 + X
 28700 242               S2 = S2 + X2
 28800 243               S3 = S3 + X*X2
 28900 244               S4 = S4 + X2**2
 29000 245               S5 = S5 + Y*X2
 29100 246               S6 = S6 + Y*X
 29200 247               S7 = S7 + Y
 29300 248               S0 = S0 + 1.
 29400 249            CIF
 29500 250            IPCO = IPCO + HLDCO
 29600 251         UNTIL IPCO.GT.HPCO9
 29700 252         IF S0.LT.2.5
 29800 256         THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 29900 259            SIG = 1000.
 30000 260         ELSE
 30100    C
 30300 262            F1 = 1. / S4                                                 SOLVE EQUATIONS FOR PARABOLA FIT
 30400 263            XX12 = S3*F1
 30500 264            XX13 = S2*F1
 30600 265            YY1  = S5*F1
 30700 266            XX22 = S2 - S3*XX12
 30800 267            XX23 = S1 - S3*XX13
 30900 268            YY2  = S6 - S3*YY1
 31000 269            XX32 = S1 - S2*XX12
 31100 270            XX33 = S0 - S2*XX13
 31200 271            YY3  = S7 - S2*YY1
 31300 272            IF XX22.GT.XX32
 31400 273            THEN
 31500 276               XX23 = XX23 / XX22
 31600 277               YY2  = YY2  / XX22
 31700 278               PAR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 31800 279               PAR2 = YY2 - XX23*PAR3
 31900 280            ELSE
 32000 282               XX33 = XX33 / XX32
 32100 283               YY3  = YY3  / XX32
 32200 284               PAR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 32300 285               PAR2 = YY3 - XX33*PAR3
 32400 286            CIF
 32500 287            PAR1 = YY1 - XX12*PAR2 - XX13*PAR3
 32600 288            DEG   = S0 - WGHT0 - 2.
 32700 289            NHFIT = S0 - WGHT0 + .1
 32800    C
 32900    C
 33100 290            CHISQ = 0.                                                   CALC. CHISQ + SOLVE L/R AMBIGUITY
 33200 291            DCHIM1 = 0.
 33300 292            IHITM1 = 0
 33400 293            XST    = 999999.
 33500 294            XEN    =-999999.
 33600 295            IPCO = HPCO0
 33700 296            REPEAT
 33800 297               IF IWRK(IPCO+ 10).EQ.0 .AND. IWRK(IPCO+12).LE.JRINGL
 33900 298               THEN
 34000 301                  X = WRK(IPCO+3)
 34100 302                  IF(X.LT.XST) XST = X
 34200 304                  IF(X.GT.XEN) XEN = X
 34300 306                  Y = WRK(IPCO+4)
 34400 307                  F = (PAR1 *X + PAR2 )*X + PAR3
 34500 308                  DCHI = Y - F
 34600 309                  WRK(IPCO+13) = DCHI
 34800 310                  CHISQ = CHISQ + DCHI**2                                SUM FOR RMS
 35000    C           IF ABS(DCHI).GE.DCHIM1                                       KEEP BIGGEST RMS
 35100    C           THEN
 35200    C             DCHIM1 = ABS(DCHI)
 35300    C             IHITM1 = IPCO
 35400    C           CIF
 35500    C     PRINT 2006, IPCO,X,Y,F,DCHI,CHISQ
 35600 311               CIF
 35700 312               IPCO = IPCO + HLDCO
 35800 313            UNTIL IPCO.GT.HPCO9
 35900 314            SIG    =      CHISQ  / DEG
 36000    C     PRINT 2008, ITRK,NHFIT,XST,SIG,DEG,PAR1,PAR2,PAR3,WGHT0,Y0
 36100    C
 36300 318            SIGLM = TRELLM(16)**2                                        SET LIMIT FOR SIGMA
 36400 319         CIF
 36500    C
 36600 320      CPROC
 36700    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 36800                                                                             *************************
 36900                                                                             *      F I T B N K      *
 37100    C                                                                        *************************
 37200    C
 37400 322      PROC FITBNK                                                        SET UP FIT-BANK
 37500    C
 37700 323         YST  = (PAR1 *XST + PAR2 )*XST + PAR3                           START + END POINTS
 37800 324         YEN  = (PAR1 *XEN + PAR2 )*XEN + PAR3
 38000 325         TGST = PAR1*XST*2 + PAR2                                        DIRECTION AT START + END POINT
 38100 326         DXST = 1./SQRT(TGST**2+1.)
 38200 327         DYST = DXST * TGST
 38300 328         TGEN = PAR1*XEN*2 + PAR2
 38400 329         DXEN = 1./SQRT(TGEN**2+1.)
 38500 330         DYEN = DXEN * TGEN
 38700 331         XMIN = -PAR2*.5 / PAR1                                          MIN. OF PARABOLA
 38800 332         YMIN = (PAR1*XMIN + PAR2)*XMIN + PAR3
 38900    C
 39100    C     CURV =-PAR1 * 2.                                                   CURVATURE + ERROR
 39200 333         CVZW = TGST**2+1.
 39300 334         CVST =-PAR1 * 2 / (SQRT(CVZW)*CVZW)
 39400 335         DET = (S2*S0-S1*S1)*S4 + (S2*S1-S3*S0)*S3 + (S3*S1-S2*S2)*S2
 39500 336         SIG11 = (S2*S0 - S1*S1)/DET
 39600 337         SIG22 = (S4*S0 - S2*S2)/DET
 39700 338         SIG33 = (S4*S2 - S3*S3)/DET
 39800 339         SIG12 = (S3*S0 - S2*S1)/DET
 39900 340         SIG13 = (S3*S1 - S2*S2)/DET
 40000 341         SIG23 = (S4*S1 - S3*S2)/DET
 40100    C     PRINT 2012, DET,SIG11,SIG22,SIG33,SIG12,SIG13,SIG23,SIG
 40200    C
 40300    C
 40400    C     PRINT 2014, XST,YST,DXST,DYST,TGST,XEN,YEN,DXEN,DYEN,TGEN,CURV
 40500    C
 40700 342         IP    = HPTR0 - 1                                               FILL FIT-BANK
 40800 343         IWRK(IP+ 1) = ITRK
 40900 344         IWRK(IP+ 2) = 32
 41000 345         IWRK(IP+ 3) = IDAY
 41100 346         IWRK(IP+ 4) = 16
 41200 347         WRK (IP+ 5) = XST *CSROT - YST *SNROT + XT
 41300 348         WRK (IP+ 6) = XST *SNROT + YST *CSROT + YT
 41400 349         WRK (IP+ 7) = SQRT(WRK(IP+ 5)**2 + WRK(IP+ 6)**2) * TGTH + ZVERT
 41500 350         WRK (IP+ 8) = (DXST*CSROT - DYST*SNROT)*CSTH
 41600 351         WRK (IP+ 9) = (DXST*SNROT + DYST*CSROT)*CSTH
 41700 352         WRK (IP+10) = SNTH
 41800 353         IWRK(IP+11) = 0
 41900 354         WRK (IP+12) = XEN *CSROT - YEN *SNROT + XT
 42000 355         WRK (IP+13) = XEN *SNROT + YEN *CSROT + YT
 42100 356         WRK (IP+14) = SQRT(WRK(IP+12)**2 + WRK(IP+13)**2) * TGTH + ZVERT
 42200 357         WRK (IP+15) = (DXEN*CSROT - DYEN*SNROT)*CSTH
 42300 358         WRK (IP+16) = (DXEN*SNROT + DYEN*CSROT)*CSTH
 42400 359         WRK (IP+17) = SNTH
 42500 360         IWRK(IP+18) = 2
 42600 361         WRK (IP+19) = ATAN2(SNROT,CSROT)
 42700 362         WRK (IP+20) = XMIN*CSROT - YMIN*SNROT + XT
 42800 363         WRK (IP+21) = XMIN*SNROT + YMIN*CSROT + YT
 42900 364         WRK (IP+22) = PAR1
 43000    C     IF(SIG  .LT.0) PRINT 2021,WRK(IP+1),S0,SIG
 43100    C2021 FORMAT(' -VE SQRT:',I4,5E13.5)
 43200 365         WRK (IP+23) = SQRT(SIG)
 43300 366         IWRK(IP+24) = S0 + .001
 43400 367         WRK (IP+25) = CVST
 43500    C     IF(SIG11.LT.0) PRINT 2021,WRK(IP+1),S0,SIG,SIG11
 43600 368         WRK (IP+26) = SQRT(SIG*SIG11) * 2.
 43700 369         WRK (IP+27) = CVST
 43800 370         WRK (IP+28) = CVST
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 43900    C     I0 = IP+ 1
 44000    C     I9 = IP+48
 44100    C     PRINT 2001,(WRK(I1),I1=I0,I9)
 44200 371      CPROC
 44300    C
 44400                                                                             *************************
 44500                                                                             *      F I T B K 1      *
 44700    C                                                                        *************************
 44800    C
 45000 373      PROC FITBK1                                                        CHANGE FIT BANK (1.POINT)
 45100    C
 45300 374         YST  = (PAR1 *XST + PAR2 )*XST + PAR3                           START POINT
 45500 375         TGST = PAR1*XST*2 + PAR2                                        DIRECTION AT START POINT
 45600 376         DXST = 1./SQRT(TGST**2+1.)
 45700 377         DYST = DXST * TGST
 45900 378         XMIN = -PAR2*.5 / PAR1                                          MIN. OF PARABOLA
 46000 379         YMIN = (PAR1*XMIN + PAR2)*XMIN + PAR3
 46100    C
 46300    C     CURV =-PAR1 * 2.                                                   CURVATURE + ERROR
 46400 380         CVZW = TGST**2+1.
 46500 381         CVST =-PAR1 * 2 / (SQRT(CVZW)*CVZW)
 46600 382         DET = (S2*S0-S1*S1)*S4 + (S2*S1-S3*S0)*S3 + (S3*S1-S2*S2)*S2
 46700 383         SIG11 = (S2*S0 - S1*S1)/DET
 46800 384         SIG22 = (S4*S0 - S2*S2)/DET
 46900 385         SIG33 = (S4*S2 - S3*S3)/DET
 47000 386         SIG12 = (S3*S0 - S2*S1)/DET
 47100 387         SIG13 = (S3*S1 - S2*S2)/DET
 47200 388         SIG23 = (S4*S1 - S3*S2)/DET
 47300    C     PRINT 2012, DET,SIG11,SIG22,SIG33,SIG12,SIG13,SIG23,SIG
 47400    C
 47500    C     PRINT 2014, XST,YST,DXST,DYST,TGST,XEN,YEN,DXEN,DYEN,TGEN,CURV,
 47600    C    ,            XMIN,YMIN
 47700    C
 47900 389         IP    = HPTR0 - 1                                               FILL FIT-BANK
 48000 390         WRK (IP+ 5) = XST *CSROT - YST *SNROT + XT
 48100 391         WRK (IP+ 6) = XST *SNROT + YST *CSROT + YT
 48200 392         WRK (IP+ 7) = SQRT(WRK(IP+ 5)**2 + WRK(IP+ 6)**2) * TGTH + ZVERT
 48300 393         WRK (IP+ 8) = (DXST*CSROT - DYST*SNROT)
 48400 394         WRK (IP+ 9) = (DXST*SNROT + DYST*CSROT)
 48500 395         WRK (IP+10) = SNTH
 48600 396         IWRK(IP+18) = 2
 48700 397         WRK (IP+19) = ATAN2(SNROT,CSROT)
 48800 398         WRK (IP+20) = XMIN*CSROT - YMIN*SNROT + XT
 48900 399         WRK (IP+21) = XMIN*SNROT + YMIN*CSROT + YT
 49000 400         WRK (IP+22) = PAR1
 49100    C     IF(SIG  .LT.0) PRINT 2022,WRK(IP+1),S0,SIG
 49200    C2022 FORMAT(' -VE SQRT(1):',I4,5E13.5)
 49300 401         WRK (IP+23) = SQRT(SIG)
 49400 402         IWRK(IP+24) = S0 + .001
 49500 403         WRK (IP+25) = CVST
 49600    C     IF(SIG11.LT.0) PRINT 2022,WRK(IP+1),S0,SIG,SIG11
 49700 404         WRK (IP+26) = SQRT(SIG*SIG11) * 2.
 49800 405         WRK (IP+27) = CVST
 49900    C     I0 = IP+ 1
 50000    C     I9 = IP+48
 50100    C     PRINT 2001,(WRK(I1),I1=I0,I9)
 50200 406      CPROC
 50300    C
 50400    C
 50500                                                                             *************************
 50600                                                                             *      L A B E L        *
 50800    C                                                                        *************************
 50900    C
 51100 408      PROC LABEL                                                         LABEL USED HITS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 51200    C
 51400 409         IWL = -999                                                      PRESET LAST HIT POINTER
 51500    C
 51700 410         IWL = -999                                                      PRESET LAST HIT POINTER
 51800 411         NHGOOD = 0
 51900 412         FOR IP = HPCO0,HPCO9,HLDCO
 52000 413            IW0 = IWRK(IP)
 52100 414            X   = WRK(IP+3)
 52200 415            Y   = WRK(IP+4)
 52300 416            F   = (PAR1*X + PAR2)*X + PAR3
 52400 417            DF  = F - Y
 52600 418            LBGOOD = 4                                                   SELECT CLOSEST HIT
 52700 419            IF(ABS(DF).LT.ALBLM2) LBGOOD = 1
 52800 421            IF(ABS(DF).LT.ALBLM1) LBGOOD = 0
 52900 423            IWRK(IP+ 10) = LBGOOD
 53000 424            IF(LBGOOD.EQ.0) NHGOOD = NHGOOD + 1
 53100 426            WRK (IP+13) = DF
 53200    C
 53400 427            IF IWL.EQ.IW0                                                CHECK IF 2 HITS FROM SAME WIRE
 53500 428            THEN
 53700 431               IF ABS(DFL).LT.ABS(DF)                                    SELECT CLOSEST HIT
 53800 432               THEN
 53900 435                  IF(IWRK(IP +10).EQ.0) NHGOOD = NHGOOD - 1
 54000 437                  IWRK(IP +10) = 16
 54100 438               ELSE
 54200 440                  IF(IWRK(IPL+10).EQ.0) NHGOOD = NHGOOD - 1
 54300 442                  IWRK(IPL+10) = 16
 54400 443               CIF
 54500 444            CIF
 54700 445            IWL = IW0                                                    STORE LAST POINTERS + DF
 54800 446            IPL = IP
 54900 447            DFL = DF
 55000 448         CFOR
 55100    C
 55200 450      CPROC
 55300    C
 55400    C
 55500                                                                             *************************
 55600                                                                             *      I N I T          *
 55800    C                                                                        *************************
 55900    C
 56100 452      PROC INIT                                                          INITIALIZE CONSTANTS
 56200    C
 56300 453         IQJETC = IBLN('JETC')
 56400 454         IQHEAD = IBLN('HEAD')
 56500 455         PRINT 2999
 56600 456 2999 FORMAT(///,'0***************************************',
 56700         ,   /,' **                                   **',
 56800         ,   /,' **        WHO IS USING THIS          **',
 56900         ,   /,' **                                   **',
 57000         ,   /,' **     SUBROUTINE   REFITV  ???      **',
 57100         ,   /,' **    ==========================     **',
 57200         ,   /,' **                                   **',
 57300         ,   /,' **    PLEASE CONTACT  P. STEFFEN     **',
 57400         ,   /,' **                                   **',
 57500         ,   /,' **                                   **',
 57600         ,   /,' ***************************************',////)
 57700    C
 57800 457         CALL DAY2(DATE)
 57900 458         IDAY = DATE(1)*1000 + DATE(2)
 58000    C
 58200 459         RESMS = .020**2/2. * .16 * (1. + ALOG10(.16) / 9) * 155.45**2   MULT. SCATTERING CONSTANTS
 58300 460      CPROC
 58400    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 58500 462      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         461 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         461 TARGET STATEMENTS
 00000    C   09/06/83 703131338  MEMBER NAME  SAGCIR   (S)           SHELTRAN
 00100   2      FUNCTION SAGCIR(FPP,CP,G,SP,EPS)
 00200    C                                   J. SPITZER
 00300    C     CALCULATE SAGCIR=(SQRT(1+G*(FPP*CP)**2)-1)/(FPP*CP)
 00400    C               SP    =SAGCIR/CP
 00500    C     TO ACHIEVE GOOD PRECISION, FOR SMALL FPP*CP THE TAYLOR EXPANSION
 00600    C     IS USED UPTO AT MOST 15 TERMS
 00700    C     EPS IS THE REQUIRED ABSOLUTE PRECISION
 00800    C
 00900   3      FP=FPP*CP
 01000   4      U=-(G*FP)*FP
 01100   5      S=-.5*G*FPP
 01200   6      IF ABS(U).GT..3
 01300   7      THEN
 01400  10         IF U.LT..98
 01500  11         THEN
 01600  14            SAGCIR=(SQRT(1.-U)-1.)/FP
 01700  15         ELSE
 01800  17            SAGCIR=0.
 01900  18            PRINT 100,FPP,CP,G
 02000  19100         FORMAT(1X,' SAGCIR',3E16.7)
 02100  20         CIF
 02200  21         SP=SAGCIR/CP
 02300  22         RETURN
 02400  23      CIF
 02500  24      VAL=-S*(1.+.25*U+.125*U**2)
 02600  25      Q=S*U**3/12.8
 02700  26      N=5
 02800  27      WHILE ABS(Q).GT.EPS .AND.N.LT.15
 02900  29         VAL=VAL-Q
 03000  33         Q=Q*U*(1.-1.5/N)
 03100  34         N=N+1
 03200  35      CWHILE
 03300  37      SP=VAL
 03400  38      SAGCIR=SP*CP
 03500  39      RETURN
 03600  40      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          39 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          39 TARGET STATEMENTS
 00000    C   09/06/83 703131345  MEMBER NAME  SHELL9   (S)           SHELTRAN
 00100   2      SUBROUTINE SHELL9(IVAL,IIND,N)
 00110    C                                   J. SPITZER
 00120    C     SORT INDICES IN THE ARRAY IIND(.) ACCORDING TO
 00130    C     THE CORRESPONDING VALUES IN IVAL(IIND(.))
 00140    C
 00200   3      DIMENSION IVAL(N),IIND(N)
 00300   4      INTEGER*2 I,J,K,M
 00400    C
 00500   5      M=N/2
 00600   6      WHILE M.GT.0
 00700   8         K=N-M
 00800  12         FOR J=1,K
 00900  13            I=J
 01000  14            WHILE I.GE.1
 01100  16               IVI=IVAL(IIND(I))
 01200  20               IVIPM=IVAL(IIND(I+M))
 01300  21               IF(IVIPM.GE.IVI) XWHILE
 01400  23               I1=IIND(I+M)
 01500  24               IIND(I+M)=IIND(I)
 01600  25               IIND(I)=I1
 01700  26               I=I-M
 01800  27            CWHILE
 01900  29         CFOR
 02000  31         M=M/2
 02100  32      CWHILE
 02200  34      RETURN
 02300  35      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          34 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          34 TARGET STATEMENTS
 00000    C   09/06/83 703131348  MEMBER NAME  SQTVAL   (S)           SHELTRAN
 00100   2      FUNCTION SQTVAL(F,G,AL,EPS)
 00200    C                                  J. SPITZER
 00300    C     CALCULATE SQTVAL=F*(SQRT(1+G*AL**2/F**2)-1).
 00400    C     TO ACHIEVE GOOD PRECISION, FOR LARGE F THE TAYLOR EXPANSION
 00500    C     IS USED UPTO AT MOST 15 TERMS
 00600    C     EPS IS THE REQUIRED ABSOLUTE PRECISION
 00700    C
 00800   3      S=(AL/F)*G
 00900   4      U=-S*(AL/F)
 01000   5      S=-.5*S*AL
 01100   6      IF ABS(U).GT..3
 01200   7      THEN
 01300  10         IF U.LT..98
 01400  11         THEN
 01500  14            SQTVAL=F*(SQRT(1.-U)-1.)
 01600  15         ELSE
 01700  17            SQTVAL=0.
 01800  18            PRINT 100,F,G,AL
 01900  19100         FORMAT(1X,' SQTVAL',3E16.7)
 02000  20         CIF
 02100  21         RETURN
 02200  22      CIF
 02300  23      VAL=-S*(1.+.25*U+.125*U**2)
 02400  24      Q=S*U**3/12.8
 02500  25      N=5
 02600  26      WHILE ABS(Q).GT.EPS .AND.N.LT.15
 02700  28         VAL=VAL-Q
 02800  32         Q=Q*U*(1.-1.5/N)
 02900  33         N=N+1
 03000  34      CWHILE
 03100  36      SQTVAL=VAL
 03200  37      RETURN
 03300  38      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          37 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          37 TARGET STATEMENTS
          C   25/10/79 807251857  MEMBER NAME  THRUNB   (JADEGS)      SHELTRAN
          C
          C-----------------------------------------------------------------------
         2      SUBROUTINE THRUNB( P, NP, NMAXP, PTHR, AXIS, ITMERR )
          C-----------------------------------------------------------------------
          C
          C    VERSION OF 21/05/79   LAST MOD 25/10/79   E.ELSEN
          C                          ITMERR IS ADDED TO THE ARG06-06-79 S.YAMADA
          C    INPUT : P(4,NP)   NP MOMENTA PX,PY,PZ,ABS(P)
          C            NP        NUMBER OF MOMENTA
          C            NMAXP     CUTOFF FOR PERMUTED MOMENTA
          C                      =0 MEANS NO CUTOFF
          C    OUTPUT: PTHR      THRUST VALUE
          C            AXIS      THRUST AXIS
          C            ITMERR    =1, IF LEFT TIME IS NOT ENOUGH TO CALCULATE THRST
          C                      (NOW MIN.2 SECONDS ARE REQUIRED.)
          C    METHOD: NO MOMENTUM CONSERVATION
          C            THRUST VALUE IS FOUND BY LOOKING THROUGH ALL
          C            PERMUTATIONS OF THE MOMENTA.
          C
          C-----------------------------------------------------------------------
          C
         3      DIMENSION P(1), AXIS(3)
         4      DIMENSION PIN(320), IPERM(80),IPS(320),PS(320)
         5      COMMON / CWORK / WORK(720)
         6      EQUIVALENCE (WORK(1),PIN(1)),(WORK(321),IPERM(1))
         7      EQUIVALENCE (WORK(401),PS(1)),(WORK(401),IPS(1))
          C
         8      DATA IPINC / 4 /
         9      DATA NLIMIT / 15 /
        10      DATA NSEC / 2 /
          C
          C------------------  C O D E  ------------------------------------------
          C
        11      ITMERR = 0
          C
        12      NMAXP1 = NMAXP
        13      IF  NP.GE.NLIMIT .AND. ( NMAXP.EQ.0 .OR. NMAXP.GT.NLIMIT )
        14      THEN
        17         PERFORM WARN                                                    WARNING CONCERNING NUMBER OF PARAMETERS
        20         NMAXP1 = NLIMIT
        21      CIF
        22      NTOT = NP
        23      NP1 = NTOT
        24      IF NTOT.GT.NMAXP1 .AND. NMAXP1.NE. 0
        25      THEN
        28         PERFORM SORT                                                    SORT MOMENTA IN DECREASING ORDER
        31         NTOT = NMAXP1 - 1
        32         PERFORM FILLIN                                                  PIN ARRAY = ORDERED P ARRAY
        35      ELSE
        37         CALL UCOPY( P, PIN, NTOT*4 )                                    COPY FROM P TO PIN ARRAY
        38      CIF
        39      PERFORM THRST                                                      THRUST AXIS FOR PIN ARRAY
        42      PERFORM THREXP                                                     THRUST VALUE FOR P ARRAY
        45      RETURN
          C
          C
          C
          C--------------
          C
        46      PROC WARN
          C--------------
        47         WRITE(6,9101) NP,NLIMIT,NMAXP
        48 9101 FORMAT(' +++++  WARNING FROM THRUST ROUTINE  +++++'/
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
               *   2X,I4,' ARE TOO MANY INPUT VECTORS. NLIMIT=',I4,
               *   ' INPUT CUTOFF NMAXP=',I4,'.PTHR VAL. FOR NMAXP=NLIMIT WAS TAKEN')
        49      CPROC
          C
          C
          C
          C--------------
          C
        51      PROC SORT
          C--------------
                                                                                   ORDER P ARRAY USING SHELLSORT ALGTHM
        52         FOR J=1,NTOT                                                    SEQUENCE OF MOMENTA IS STORED IN IPERM
        53            IPERM(J) = J*4                                               INIT IPERM IN NATURAL ORDER
        54         CFOR
          C
        56         M = NTOT / 2
        57         WHILE  M.GT.0
        59            K = NTOT - M
        63            FOR J=1,K
        64               I = J
        65               WHILE  I.GT.0
        67                  ILOW = IPERM(I)
        71                  IHIGH = IPERM(I+M)
        72                  IF  P(IHIGH) .GT. P(ILOW)
        73                  THEN
        76                     IPERM(I) = IHIGH
        77                     IPERM(I+M) = ILOW
        78                     I = I - M
        79                  ELSE
        81                     XWHILE
        82                  CIF
        83               CWHILE
        85            CFOR
        87            M = M/2
        88         CWHILE
        90      CPROC
          C
          C
          C--------------
          C
        92      PROC FILLIN
          C--------------
        93         FOR J=1,NTOT                                                    PIN(1..4,J) = P(1..4,IPERM(J)/4)
        94            IPJ = IPERM(J)
        95            J4 = J*4
        96            PIN(J4  ) = P(IPJ  )
        97            PIN(J4-1) = P(IPJ-1)
        98            PIN(J4-2) = P(IPJ-2)
        99            PIN(J4-3) = P(IPJ-3)
       100         CFOR
       102      CPROC
          C
          C
          C----------------
       104      PROC THRST
          C----------------
       105         NUP = NTOT*4 - 4
       106         K = 5                                                           FIRST VALID POSITION
       107         IPS(1) = 1                                                      INIT ACCUMULATOR ARRAY
       108         IPS(K) = 1
       109         PS(2) = 0.
       110         PS(3) = 0.
       111         PS(4) = 0.
       112         PM2 = 0.
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
          C
       113         REPEAT                                                          START OF PERMUTATION LOOP
       114            PERFORM COMPAR                                               COMPARE THIS PERMUTATION WITH PREVIOUS
       117            IF IPS(K) .LT. NUP
       118            THEN
       121               PERFORM EXPAND                                            EXPAND NUMBER OF ELEMENTS IN PERMUTATION
       124            ELSE
       126               PERFORM COMPRS                                            DECREASE NUMBER OF ELEMENTS IN PERMUTATION
       129            CIF
       130         UNTIL IPS(1) .NE. 1                                             END IF FIRST VALID ELEMENT IS THE SECOND VECTOR
          C
          C
       131         AXISL = SQRT( PM2)                                              SQRT( MAX (SUM OVER PERM. OF MOMENTA ))
       135         FOR  J=1,3
       136            AXIS(J) = AXIS(J) / AXISL                                    THRUST AXIS
       137         CFOR
       139         PSUM = 0.
       140         NIPINC = NTOT * 4
       141         FOR J = 4,NIPINC,4
       142            PSUM = PSUM + PIN(J)                                         SUM OF MOMENTA
       143         CFOR
       145         PTHR = 2. * AXISL / PSUM                                        THRUST VALUE
       146      CPROC
          C
          C
          C--------------
          C
       148      PROC THREXP
          C--------------
       149         NIPINC = NP1*IPINC                                              COMPUTE THRUST EXPLICITLY
       150         SPCOS = 0.
       151         PSUM = 0.
       152         FOR J=1,NIPINC,IPINC
       153            SPCOS = SPCOS + ABS( AXIS(1)*P(J)+AXIS(2)*P(J+1)+AXIS(3)*P(J+2) )
       154            PSUM = PSUM + P(J+3)
       155         CFOR
       157         PTHR = SPCOS / PSUM
       158      CPROC
          C
          C
          C--------------
          C
       160      PROC COMPAR
          C--------------
       161         J = IPS(K)                                                      CHECK THIS PERMUTATION AND STORE IN AXIS IF .GT. T
       162         PS(K+1) = PS(K-3) + PIN(J  )
       163         PS(K+2) = PS(K-2) + PIN(J+1)
       164         PS(K+3) = PS(K-1) + PIN(J+2)
       165         PCL2 = PS(K+1)*PS(K+1) + PS(K+2)*PS(K+2) + PS(K+3)*PS(K+3)
       166         IF  PCL2 .GT. PM2
       167         THEN
       170            PM2 = PCL2
       171            AXIS(1) = PS(K+1)
       172            AXIS(2) = PS(K+2)
       173            AXIS(3) = PS(K+3)
       174         CIF
       175      CPROC
          C
          C
          C-----------------
          C
       177      PROC EXPAND
          C-----------------
       178         K = K + 4                                                       INCREASE NUMBER OF COMPARED ELEMENTS BY 1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
       179         IPS(K) = IPS(K-4) + 4
       180      CPROC
          C
          C
          C-----------------
          C
       182      PROC COMPRS
          C-----------------
       183         K = K - 4                                                       DECREASE NUMBER OF COMPARED ELEMENTS BY 1
       184         IPS(K) = IPS(K) + 4
       185         IF  JUHR(NSEC) .EQ. 2                                           CHECK REMAINING TIME
       186         THEN
       189            PERFORM ERROR
       192            RETURN
       193         CIF
       194      CPROC
          C
          C
          C-----------------
          C
       196      PROC ERROR
          C-----------------
       197         AXIS(1) = 0.                                                    SET DEFAULT FOR AXIS AND THRUST
       198         AXIS(2) = 0.
       199         AXIS(3) = 1.
       200         PTHR = .5
       201         ITMERR = 1
       202         WRITE(6,9102) NSEC,NP,NMAXP,NLIMIT
       203 9102 FORMAT(' +++++++   TIME PROBLEMS IN THRUST - ROUTINE   ++++++++'/
               *   '        REMAINING TIME IS LESS THAN ',I4,' SECS.'/
               *   '        ',I4,' ARE TOO MANY INPUT VECTORS.  NMAXP =',I4,
               *   ' NLIMIT =',I4/
               *   '         AXIS WAS SET TO Z AXIS AND PTHR = .5')
       204      CPROC
          C
          C
       206      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         205 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         205 TARGET STATEMENTS
 00000    C   22/09/79 807251900  MEMBER NAME  THRUST   (JADEGS)      SHELTRAN
 00010    C
 00020    C-----------------------------------------------------------------------
 00100   2      SUBROUTINE THRUST( P, NP, NMAXP, PTHR, AXIS, ITMERR )
 00200    C-----------------------------------------------------------------------
 00300    C
 00400    C    VERSION OF 21/05/79   LAST MOD 16/05/80   E.ELSEN
 00410    C
 00500    C    INPUT : P(4,NP)   NP MOMENTA PX,PY,PZ,ABS(P)
 00600    C            NP        NUMBER OF MOMENTA
 00700    C            NMAXP     CUTOFF FOR PERMUTED MOMENTA
 00800    C                      =0 MEANS NO CUTOFF
 00900    C    OUTPUT: PTHR      THRUST VALUE
 01000    C            AXIS      THRUST AXIS
 01100    C            ITMERR    =1, IF LEFT TIME IS NOT ENOUGH TO CALCULATE THRST
 01200    C                      (NOW MIN.2 SECONDS ARE REQUIRED.)
 01300    C    METHOD: MOMENTUM CONSERVATION IS TAKEN CARE OF BY INTRODUCING
 01400    C            MISSING MOMENTUM VECTOR AT THE END OF P ARRAY.
 01500    C            THRUST VALUE IS FOUND BY LOOKING THROUGH ALL
 01600    C            PERMUTATIONS OF THE MOMENTA.
 01610    C
 01700    C-----------------------------------------------------------------------
 01710    C
 01800   3      DIMENSION P(1), AXIS(3)
 01900   4      DIMENSION PIN(320), IPERM(200),IPS(320),PS(320)
 02000   5      COMMON / CWORK / WORK(840)
 02100   6      EQUIVALENCE (WORK(1),PIN(1)),(WORK(321),IPERM(1))
 02200   7      EQUIVALENCE (WORK(521),PS(1),IPS(1))
 02300    C
 02400   8      DATA IPINC / 4 /
 02500   9      DATA NLIMIT / 15 /
 02600  10      DATA NSEC / 2 /
 02700  11      DATA IER0 / 0/, IER1 /0/, IER2 /0/
 02800    C
 02810    C------------------  C O D E  ------------------------------------------
 02900    C
 03000  12      ITMERR = 0
 03100    C
 03200  13      AXIS(1) = 0.
 03300  14      AXIS(2) = 0.
 03400  15      AXIS(3) = 1.
 03500  16      PTHR = .5
 03600    C
 03700  17      IF NP .LE. 0
 03800  18      THEN
 03900  21         IF IER0 .LT. 10
 04000  22         THEN
 04100  25            WRITE(6,9103)
 04200  26 9103 FORMAT(' +++ ERROR IN THRUST.  CALLED WITH ZERO PARTICLES +++')
 04300  27         CIF
 04400  28         IER0 = IER0 + 1
 04500  29         RETURN
 04600  30      CIF
 04700    C
 04800    C
 04900  31      NMAXP1 = NMAXP
 05000  32      IF  NP.GE.NLIMIT .AND. ( NMAXP.EQ.0 .OR. NMAXP.GT.NLIMIT )
 05100  33      THEN
 05300  36         IF IER1 .LT. 10                                                 WARNING CONCERNING NUMBER OF PARAMETERS
 05400  37         THEN
 05500  40            WRITE(6,9101) NP,NLIMIT,NMAXP
 05600  41 9101 FORMAT(' +++++  WARNING FROM THRUST ROUTINE  +++++'/
 05700         *      2X,I4,' ARE TOO MANY INPUT VECTORS. INTERNAL LIMIT=',I4,
 05800         *      ' INPUT CUTOFF NMAXP=',I4,'. ONLY NLIMIT PARTICLES ARE PERMUTED')
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 05900    C
 06000  42            NMAXP1 = NLIMIT
 06100  43         CIF
 06200  44         IER1 = IER1 + 1
 06300  45      CIF
 06400    C
 06500  46      NTOT = NP
 06700  47      CALL BALANC( P, NTOT, PSUM )                                       BALANCE MOMENTA IN P ARRAY
 06800  48      IF PSUM .LT. 1.E-6
 06900  49      THEN
 07000  52         IF IER2 .LT. 10
 07100  53         THEN
 07200  56            WRITE(6,9104)
 07300  57 9104 FORMAT(' +++ ERROR IN THRUST. MOMENTUM SUM AFTER BALANCE=0. +++')
 07400  58         CIF
 07500  59         IER2 = IER2 + 1
 07600  60         RETURN
 07700  61      CIF
 07800    C
 07900  62      IF NTOT.GT.NMAXP1 .AND. NMAXP1.NE. 0
 08000  63      THEN
 08200  66         PERFORM SORT                                                    SORT MOMENTA IN DECREASING ORDER
 08300    C
 08400  69         NP1 = NTOT
 08500  70         NTOT = NMAXP1 - 1
 08700  71         PERFORM FILLIN                                                  PIN ARRAY = ORDERED P ARRAY
 08800    C
 09000  74         CALL BALANC( PIN, NTOT, PSUM1 )                                 BALANCE REDUCED SET OF MOMENTA
 09100    C
 09300  75         PERFORM THRST                                                   THRUST AXIS FOR PIN ARRAY
 09500  78         PERFORM THREXP                                                  THRUST VALUE FOR P ARRAY
 09600  81      ELSE
 09800  83         CALL UCOPY( P, PIN, NTOT*4 )                                    COPY FROM P TO PIN ARRAY
 10000  84         PERFORM THRST                                                   THRUST FOR PIN ARRAY
 10100  87      CIF
 10200  88      RETURN
 10300    C
 10400    C
 10500    C
 10600    C--------------
 10700    C
 10800  89      PROC SORT
 10900    C--------------
 11000                                                                             ORDER P ARRAY USING SHELLSORT ALGTHM
 11200  90         FOR J=1,NTOT                                                    SEQUENCE OF MOMENTA IS STORED IN IPERM
 11400  91            IPERM(J) = J*4                                               INIT IPERM IN NATURAL ORDER
 11500  92         CFOR
 11600    C
 11700  94         M = NTOT / 2
 11800  95         WHILE  M.GT.0
 11900  97            K = NTOT - M
 12000 101            FOR J=1,K
 12100 102               I = J
 12200 103               WHILE  I.GT.0
 12300 105                  ILOW = IPERM(I)
 12400 109                  IHIGH = IPERM(I+M)
 12500 110                  IF  P(IHIGH) .GT. P(ILOW)
 12600 111                  THEN
 12700 114                     IPERM(I) = IHIGH
 12800 115                     IPERM(I+M) = ILOW
 12900 116                     I = I - M
 13000 117                  ELSE
 13100 119                     XWHILE
 13200 120                  CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 13300 121               CWHILE
 13400 123            CFOR
 13500 125            M = M/2
 13600 126         CWHILE
 13700 128      CPROC
 13800    C
 13900    C
 14000    C--------------
 14100    C
 14200 130      PROC FILLIN
 14300    C--------------
 14500 131         FOR J=1,NTOT                                                    PIN(1..4,J) = P(1..4,IPERM(J)/4)
 14600 132            IPJ = IPERM(J)
 14700 133            J4 = J*4
 14800 134            PIN(J4  ) = P(IPJ  )
 14900 135            PIN(J4-1) = P(IPJ-1)
 15000 136            PIN(J4-2) = P(IPJ-2)
 15100 137            PIN(J4-3) = P(IPJ-3)
 15200 138         CFOR
 15300 140      CPROC
 15400    C
 15500    C
 15600    C----------------
 15700 142      PROC THRST
 15800    C----------------
 15900 143         NPERM = 2**(NTOT-1)
 16000 144         NOUT = ( NPERM - 1) / 8192 + 1
 16100 145         NIN = MIN0( 8192, NPERM )
 16200 146         NUP = NTOT*4 - 3
 16400 147         PS(1) = 0.                                                      START VALUES
 16500 148         PS(2) = 0.
 16600 149         PS(3) = 0.
 16700 150         IPS(4) = 1
 16800 151         PM2 = 0.
 16900 152         J = 1
 17000 153         K = 1
 17100    C
 17300 154         FOR IOUT = 1, NOUT                                              LOOPS OVER PERMUTATIONS
 17400 155            IF JUHR(NSEC) .EQ. 2
 17500 156            THEN
 17700 159               AXIS(1) = 0.                                              SET DEFAULT FOR AXIS AND THRUST
 17800 160               AXIS(2) = 0.
 17900 161               AXIS(3) = 1.
 18000 162               PTHR = .5
 18100 163               ITMERR = 1
 18200 164               WRITE(6,9102) NSEC
 18300 165 9102 FORMAT(' +++++++   TIME PROBLEMS IN THRUST - ROUTINE   ++++++++'/
 18400         *         '        REMAINING TIME IS LESS THAN ',I4,' SECS.'/
 18500         *         '         AXIS WAS SET TO Z AXIS AND THRUST = .5')
 18600 166               RETURN
 18700 167            CIF
 18800    C
 18900 168            FOR IIN = 1, NIN
 19000    C
 19100 169               PS1 = PS(K  ) + PIN(J  )
 19200 170               PS2 = PS(K+1) + PIN(J+1)
 19300 171               PS3 = PS(K+2) + PIN(J+2)
 19400 172               PCL2 = PS1*PS1 + PS2*PS2 + PS3*PS3
 19500 173               IF  PCL2 .GT. PM2
 19600 174               THEN
 19700 177                  PM2 = PCL2
 19800 178                  AXIS(1) = PS1
 19900 179                  AXIS(2) = PS2
 20000 180                  AXIS(3) = PS3
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 20100 181               CIF
 20200    C
 20300 182               IF J .LT. NUP
 20500 183               THEN                                                      EXPAND
 20600 186                  J = J + 4
 20700 187                  K = K + 4
 20800 188                  PS(K  ) = PS1
 20900 189                  PS(K+1) = PS2
 21000 190                  PS(K+2) = PS3
 21100 191                  IPS(K+3) = J
 21200    C
 21400 192               ELSE                                                      COMPRESS
 21500 194                  J = IPS(K+3)
 21600 195                  K = K - 4
 21700 196               CIF
 21800    C
 21900 197            CFOR
 22000 199         CFOR
 22100    C
 22300 201         AXISL = SQRT( PM2)                                              SQRT( MAX (SUM OVER PERM. OF MOMENTA ))
 22400 202         FOR  J=1,3
 22600 203            AXIS(J) = AXIS(J) / AXISL                                    THRUST AXIS
 22700 204         CFOR
 22900 206         PTHR = 2. * AXISL / PSUM                                        THRUST VALUE
 23000 207      CPROC
 23100    C
 23200    C
 23300    C--------------
 23400    C
 23500 209      PROC THREXP
 23600    C--------------
 23800 210         NIPINC = NP1*IPINC                                              COMPUTE THRUST EXPLICITLY
 23900 211         SPCOS = 0.
 24000 212         FOR J=1,NIPINC,IPINC
 24100 213            SPCOS = SPCOS + ABS( AXIS(1)*P(J)+AXIS(2)*P(J+1)+AXIS(3)*P(J+2) )
 24200 214         CFOR
 24300 216         PTHR = SPCOS / PSUM
 24400 217      CPROC
 24500    C
 24600    C
 24700 219      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         218 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 24800    C   23/05/79            MEMBER NAME  BALANC   (PHYS1)       SHELTRAN
 24900   2      SUBROUTINE BALANC( P, NTOT, PSUM )
 25000    C *---------------------------------------------------------
 25100    C *
 25200    C *  VERSION OF 23/05/79      LAST MOD 14/05/80     E.ELSEN
 25300    C *  PUT IN MOMENTUM BALANCING VECTOR BEHIND THE NTOT MOMENTA
 25400    C *  IN P. NTOT IS CHANGED ON RETURN. EXTRA LOCATIONS IN P MUST
 25500    C *  BE ACCOUNTED FOR IN CALLING ROUTINE.
 25600    C *  PSUM = SUM | P |    FOR BALANCED SET
 25700    C *  STORAGE :    P(1..3) = THREE VECTOR
 25800    C *               P(4)    = TOTAL MOMENTUM      BOTH REPEATED NTOT TIMES
 25900    C *---------------------------------------------------------
 26000    C
 26100   3      DIMENSION P(1)
 26200    C
 26400   4      PSUM1 = 0.                                                         FIND SUM OF MOMENTA
 26500   5      PSUM2 = 0.
 26600   6      PSUM3 = 0.
 26700   7      PSUM  = 0.
 26800   8      N4 = NTOT*4
 26900   9      FOR J=1,N4,4
 27000  10         PSUM1 = P(J  ) + PSUM1
 27100  11         PSUM2 = P(J+1) + PSUM2
 27200  12         PSUM3 = P(J+2) + PSUM3
 27300  13         PSUM  = P(J+3) + PSUM
 27400  14      CFOR
 27500  16      PTOT = SQRT( PSUM1*PSUM1 + PSUM2*PSUM2 + PSUM3*PSUM3 )
 27700  17      IF  PTOT .GT. .01                                                  EXTRA LOC FOR PSUM IN P IF PSUM .GT. .01 GEV
 27800  18      THEN
 27900  21         P(N4+1) = -PSUM1
 28000  22         P(N4+2) = -PSUM2
 28100  23         P(N4+3) = -PSUM3
 28200  24         P(N4+4) = PTOT
 28300  25         PSUM = PSUM + PTOT
 28500  26         NTOT = NTOT + 1                                                 INCREMENT NUMBER OF MOMENTA
 28600  27      CIF
 28700    C
 28800  28      RETURN
 28900  29      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          28 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         246 TARGET STATEMENTS
 00100    C   09/06/83 807271340  MEMBER NAME  XYRFTV   (JADEGS)      SHELTRAN
 00200   2      SUBROUTINE XYRFTV(MODE)
 00300    C-----------------------------------------------------------------------
 00400    C                                   J. SPITZER 13/3/87
 00500    C        FIT ALL TRACKS WITH OR WITHOUT CONSTRAINT TO RUN VERTEX
 00600    C        INPUT :
 00700    C        MODE   = 0 : OVERWRITE OLD PATR-BANK WITH NEW RESULTS
 00800    C        MODE   = 1 : CREATE NEW PATR-BANK WITH NEW RESULTS
 00900    C        MODE   + 2 : NOT USED
 01000    C        MODE   + 4 : VERTEX WEAKLY CONSTRAINED (ERRFAC = 100.0)
 01100    C        MODE   + 8 : NOT USED
 01200    C        MODE   +16 : NO VERTEX CONSTRAINT (ERRFAC = 1000.0 )
 01300    C        MODE   +32 : UPDATE OR CREATE JHTL IN PARALLEL WITH PATR.
 01400    C                     IF A NEW PATR IS TO BE CREATED OR THE OLD
 01500    C                       PATR IS TO BE OVERWRITTEN AND THERE IS NO
 01600    C                       JHTL WITH THE SAME NUMBER A NEW JHTL WILL
 01700    C                       BE CREATED.
 01800    C                     OTHERWISE THE OLD JHTL IS OVERWRITTEN.
 01900    C  MODIFICATIONS:
 02000    C     27/7/88    EXTRA BITS SET TO DISTINGUISH STRONG AND WEAK
 02100    C                CONSTRAINS       E ELSEN
 02200    C-----------------------------------------------------------------------
 02300    C
 02400   3      IMPLICIT INTEGER*2 (H)
 02500    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 --------------------------
 02700    C
 02800   8      COMMON/XYFVT1/MODXYV
 02900    C
 03000   9      DATA LBINIT /0/, IQPATR/0/, IQJHTL/0/
 03100    C
 03200  10      INTEGER WEAK / Z80000 /, STRONG / Z40000 /, CONCLR,
 03300         *        CONSTR / Z400 /
 03400    C
 03600  11      IF LBINIT .LE.0                                                    INITIALIZATION
 03700  12      THEN
 03800  15         LBINIT = 1
 03900  16         IQPATR = IBLN('PATR')
 04000  17         IQJHTL = IBLN('JHTL')
 04100    C
 04200  18         CONCLR = LCOMPL(LOR(STRONG,WEAK))
 04300    C
 04400  19         IF LAND(MODE,16).NE.0
 04500  20         THEN
 04600  23            WRITE(6,81)
 04700  24 81         FORMAT(' *** XYRFTV WITHOUT VERTEX CONSTRAINT ***')
 04800  25         ELSE
 04900  27            IF LAND(MODE,4).EQ.0
 05000  28            THEN
 05100  31               WRITE(6,82)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 05200  32 82            FORMAT(' *** XYRFTV WITH VERTEX CONSTRAINT ***')
 05300  33               WRITE(6,84)
 05400  34 84            FORMAT(' VC NOT APPLIED IF VERTEX INCOMPATIBLE',
 05500         +         ' WITH TRACK FITTED W/O VC FIRST.')
 05600  35            ELSE
 05700  37               WRITE(6,83)
 05800  38 83            FORMAT(' *** XYRFTV WITH WEAK VERTEX CONSTRAINT ***')
 05900  39               WRITE(6,84)
 06000  40            CIF
 06100  41         CIF
 06200  42      CIF
 06300    C
 06400    C
 06600  43      IPPAT0 = IDATA(IQPATR)                                             CHECK IF PATR- AND JHTL-BANK
 06700  44      IF(IPPAT0.LE.0 .OR. IDATA(IQJHTL).LE.0 ) RETURN
 06800    C
 06900  46      NTR    = IDATA(IPPAT0+2)
 07000    C
 07200  47      IF(NTR.LT.1) RETURN                                                CHECK IF 1 TRACK
 07300    C
 07500  49      IF LAND(MODE,1) .NE. 0                                             CREATE NEW PATR BANK
 07600  50      THEN
 07700  53         NBNK1  = IDATA(IPPAT0-2) - 1
 07800  54         NWRD   = IDATA(IPPAT0)
 07900  55         NBYTE  = NWRD*4
 08000  56         CALL CCRE(IPPATR,'PATR',NBNK1,NWRD,IERR)
 08100  57         IF IERR.NE.0
 08200  58         THEN
 08300  61            PRINT 2900, IERR
 08400  62 2900       FORMAT(' CREATION OF NEW PATR-BANK RESULTED IN ERROR',I3)
 08500  63            RETURN
 08600  64         CIF
 08800  65         CALL MVCL(IDATA(IPPATR+1),0,IDATA(IPPAT0+1),0,NBYTE)            COPY CONTENTS OF 'PATR'-BANK
 08900  66      CIF
 09000    C
 09200  67      IF LAND(MODE,32) .NE. 0                                            UPDATE JHTL BANK
 09300  68      THEN
 09400  71         NBNK1 = IDATA(IDATA(IQPATR)-2)
 09500  72         IPJHTL = IDATA(IQJHTL)
 09600  73         NWRD = IDATA(IPJHTL)
 09700  74         CALL CLOC( NPJHTL, 'JHTL', NBNK1, IER )
 09800  75         IF NPJHTL.LE.0
 09900  76         THEN
 10000  79            CALL CCRE(NPJHTL,'JHTL',NBNK1,NWRD,IERR)
 10100  80            IF IERR.NE.0
 10200  81            THEN
 10300  84               PRINT 2910, IERR
 10400  85 2910         FORMAT(' CREATION OF NEW JHTL-BANK RESULTED IN ERROR',I3)
 10500  86               RETURN
 10600  87            CIF
 10800  88            CALL MVCL(IDATA(NPJHTL+1),0,IDATA(IPJHTL+1),0,NWRD*4)        COPY CONTENTS OF 'JHTL'-BANK
 10900  89         CIF
 11000  90      CIF
 11100    C
 11200  91      IPPATR = IDATA(IQPATR)
 11300  92      IPTR   = IDATA(IPPATR+1) + IPPATR
 11400  93      LDTR   = IDATA(IPPATR+3)
 11500    C
 11600  94      IF LAND(MODE,16) .NE. 0
 11700  95      THEN
 11800  98         ERRFAC = 1000.0
 11900  99         KIND = 0
 12000 100      ELSE
 12100 102         IF LAND(MODE,4)  .NE. 0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 12200 103         THEN
 12300 106            ERRFAC =  100.0
 12400 107            KIND = WEAK
 12500 108         ELSE
 12600 110            ERRFAC = 1.0
 12700 111            KIND = STRONG
 12800 112         CIF
 12900 113      CIF
 13000    C
 13100 114      MODXYV=MODE
 13200 115      FOR ITR=1,NTR
 13400 116         CALL XYRFT1(IPTR,IDATA(IQJHTL),ERRFAC,LDTR)                     R-PHI FIT
 13600 117         IDATA(IPTR+2) = LAND(IDATA(IPTR+2),CONCLR)                      CLEAR CONSTRAIN BITS
 13700 118         IF  LAND(IDATA(IPTR+2),CONSTR).NE.0
 13800 119         THEN
 13900 122            IDATA(IPTR+2) = LOR(IDATA(IPTR+2),KIND)
 14000 123         CIF
 14100 124         IPTR=IPTR+LDTR
 14200 125      CFOR
 14300    C
 14400 127      RETURN
 14500 128      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         127 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         127 TARGET STATEMENTS
 00000    C   09/06/83 809021126  MEMBER NAME  XYRFT1   (JADEGS)      SHELTRAN
 00200   2      SUBROUTINE XYRFT1(IPTR,IPJHTL,ERRFAC,LDTR)
 00300    C
 00400    C        REFIT TRACK ITRK IN 'PATR'-BANK (WITH A VERTEX
 00500    C        CONSTRAINT OF STRENGTH 1/ERRFAC IF ERRFAC<200.
 00600    C        VERTEX OMITTED IF INCOMPATIBLE.)
 00700    C        PARABOLA FIT IF |OLD CURVATURE * HALF TRACK LENGTH| < .04
 00800    C        CIRCLE FIT OTHERWISE
 00900    C
 01000    C    TEST VERSION 3.     (TESTED TO SOME EXTENT)
 01100    C    18.3.88   PROPER RUN NUMBER HANDLING USING LDATYP      E E
 01200    C    22.2.88   MVC CHANGED TO MVCL (256 BYTES NOT ENOUGH!)  J.H./J.O.
 01210    C     2.9.88   SI --> SID IN COV EXPRESSION                 C.K./E.E.
 01300    C
 01400    C                                J. SPITZER  25/3/87
 01500    C
 01600    C    EXTENDED TO GIVE COVARIANCE MATRIX FOR FIT PARAMETERS
 01700    C    CIRCLE PARAMETERS ARE SET EVEN IF PARABOLA FIT WAS PERFORMED
 01800    C                                      J.S.  2/4/87
 01900    C
 02000    C    DOUBLE PRECISION TO CALCULATE DETERMINANT FOR COVARIANCE MATRIX
 02100    C                                      J.S.  5/6/87
 02200    C
 02300    C    MODIFIED TO UPDATE JHTL BANK UPON REQUEST (MADE IN MODXYV)
 02400    C    + SMALL MODIFICATIONS IN THE WORK COMMON FOR THE
 02500    C      VERTEX CHAMBER GROUP
 02600    C                                      J.S.  5/1/88
 02700    C
 02800   3      IMPLICIT INTEGER*2 (H)
 02900   4      REAL*8   S0D,S1D,S2D,S3D,S4D,S8D,DETD
 03000    C
 03100   5      COMMON/XYFVT1/MODXYV
 03200    C
 03300    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
         6      COMMON /BCS/ IDATA(40000)
         7      DIMENSION HDATA(80000),ADATA(40000),IPNT(50)
         8      EQUIVALENCE (HDATA(1),IDATA(1),ADATA(1)),(IPNT(1),IDATA(55))
         9      EQUIVALENCE (NWORD,IPNT(50))
          C
          C------------------------ END OF MACRO CDATA --------------------------
 03500    C
          C-----------------------------------------------------------------------
          C                            MACRO CGEO1 .... JADE GEOMETRY
          C-----------------------------------------------------------------------
          C
        10      COMMON / CGEO1 / BKGAUS,
               +                 RPIP,DRPIP,XRLPIP,   RBPC,DRBPC,XRLBPC,
               +                 RITNK,DRITNK,XRLTKI, R0ROH,DR0ROH,XR0ROH,
               +                 R1ROH,DR1ROH,XR1ROH, R2ROH,DR2ROH,XR2ROH,
               +                 R3ROH,DR3ROH,XR3ROH, ROTNK,DROTNK,XRLTKO,
               +                 RTOF,DRTOF,XRTOF,    RCOIL,DRCOIL,XRCOIL,
               +                 ZJM,DZJM,XRZJM,ZJP,DZJP,XRZJP,ZTKM,DZTKM,XRZTKM,
               +                 ZTKP,DZTKP,XRZTKP,ZBPPL,ZBPMI,ZTOFPL,ZTOFMI,
               +                 XRJETC,RLG,ZLGPL,ZLGMI,OUTR2,CTLIMP,
               +                 CTLIMM,DELFI,BLXY,BLZ,BLDEP,ZENDPL,ZENDMI,DEPEND,
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
               +                 XHOL1,XHOL2,YHOL1,YHOL2,BLFI
          C
          C------------------------- END OF MACRO CGEO1 --------------------------
          C
 03700    C
          C----------------------------------------------------------------------
          C            MACRO CALIBR .... JADE CALIBRATION DATA COMMON
          C----------------------------------------------------------------------
        11      COMMON/CALIBR/ ACALIB(1000)
        12      DIMENSION HCALIB(100),ICALIB(100)
 02600  13      EQUIVALENCE(ACALIB(1),HCALIB(1),ICALIB(1))
          C------------------------ END OF MACRO CALIBR -------------------------
 03900    C
          C----------------------------------------------
          C  MACRO CWORKPR .... PATTERN RECOGNITION CWORK
          C----------------------------------------------
        14      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)
        15      DIMENSION TRKAR(200,11),ITRKAR(200,11),
               ,                         LMRTR(3,5)
        16      EQUIVALENCE (IPCL(1),TRKAR(1,1),ITRKAR(1,1))
        17      EQUIVALENCE (LMRTR(1,1),RLMTR(1,1))
        18      DIMENSION IWRK(7000),HWRK(14000),IDWRK(600),HDWRK(1200)
        19      EQUIVALENCE (IWRK(1),WRK(1),HWRK(1))
        20      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  21      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 ------------------
 04200    C
 04300  22      EQUIVALENCE
 04400         ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
 04500         ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
 04600         ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
 04700    C
          C----------------------------------------------
          C  MACRO CPATLM .... PATTERN RECOGNITION LIMITS
          C----------------------------------------------
        23      COMMON /CPATLM/ PATRLM(5),FLINLM(10),TRELLM(20),ZFITLM(10),BKK(20)
               *               ,XYF(20),IGFP(20),XBKK(40),IADMIN(5),YBKK(20)
        24      INTEGER IXYF(20),LMPATR(5),LMFLIN(10)
        25      INTEGER LMTREL(20),LMZFIT(10),IBKK(20)
        26      DIMENSION GFP(20),IXBKK(40),IYBKK(20)
        27      EQUIVALENCE (PATRLM(1),LMPATR(1)),(IXBKK(1),XBKK(1)),(IYBKK(1),
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
               *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 --------------
 04900    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400  28      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----------------------------------------------------------------------
        29      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 -------------------------
 05200  30      INTEGER DATE(5), IDAY /0/
 05300    C-----------------------------
 05400  31      INTEGER NCHECK(5)/5*8/
 05500  32      REAL RCHECK(12,2,5)/
 05600         +   0.,  .004,  .01,  .045,  .06,  .1,  1.,  6., 4*0.,
 05700         +   0.,  .65,   .79,  .86,   .89, .91, .94,  1., 4*1.,
 05800         +   0.,  .004,  .01,  .045,  .06,  .1,  1.,  6., 4*0.,
 05900         +   0.,  .65,   .79,  .86,   .89, .91, .94,  1., 4*1.,
 06000         +   0.,  .004,  .01,  .045,  .06,  .1,  1.,  6., 4*0.,
 06100         +   0.,  .65,   .79,  .86,   .89, .91, .94,  1., 4*1.,
 06200         +   0.,  .004,  .01,  .045,  .06,  .1,  1.,  6., 4*0.,
 06300         +   0.,  .65,   .79,  .86,   .89, .91, .94,  1., 4*1.,
 06400         +   0.,  .004,  .01,  .045,  .06,  .1,  1.,  6., 4*0.,
 06500         +   0.,  .65,   .79,  .86,   .89, .91, .94,  1., 4*1./
 06600    C
 06700    C
 06800  33      REAL RESCUT/8./,CKAPP/.966/
 06900  34      DIMENSION ISORT1(71),ISORT2(3,71),IRESHT(71),ISORT3(91)
 07000         +,ISORT4(2,91)
 07100  35      DATA KPRT1/0/,NPRT1/50/,IQJETC/0/,IQHEAD/0/
 07200  36      DATA MASK1/Z2FFFFFF/,MASK2/ZFFFF02FF/,MASK3/ZFFFFF1FF/
 07300    C
 07400    C
 07500    C
 07700  37      DATA LBINIT /0/                                                    INITIALIZATION
 07800  38      IF LBINIT .EQ. 0
 07900  39      THEN
 08000  42         LBINIT = 1
 08100    C
 08200  43         IQJETC = IBLN('JETC')
 08300  44         IQHEAD = IBLN('HEAD')
 08400    C
 08500  45         CALL DAY2(DATE)
 08600  46         IDAY = DATE(1)*1000 + DATE(2)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 08700    C
 08900  47         RESMS = .020**2/2. * .16 * (1. + ALOG10(.16) /9.) * 155.45**2   MULT. SCATTERING CONSTANTS
 09000    C
 09100  48         WRITE(6,137)
 09200  49 137     FORMAT(/,' *** XYRFT1 ***  A NEW R-PHI FITTING ROUTINE',/,
 09300         +   '                 TEST VERSION 3. (J. SPITZER)',
 09400         +   ' LAST MOD 02/09/88           ',/
 09500         +   ' BIT 512 OR 1024 IS SET IN THE PROGRAM IDENTIFIER WORD',/,
 09600         +   ' IN CASE VERTEX CONSTRAINT WAS NOT OR WAS USED RESP.',/,
 09700         +   ' CORRECT COV MATRIX IS PROVIDED WITH BIT 2048 SWITCHED ON',/,
 09800         +   ' IF THE PATR BANK ALREADY HAS THE LARGER LENGTH, THE NUMBER',/,
 09900         +   ' OF HITS USED IN THE FIT IS AT LEAST 10 AND THE FIT CONVERGED.',
 10000         +   /)
 10100  50      CIF
 10200    C
 10300    C
 10500  51      IPHEAD = IDATA(IQHEAD)*2                                           GET RUN #
 10600  52      NRUN = HDATA(IPHEAD+10)
 10700  53      NEV  = HDATA(IPHEAD+11)
 10800    C
 11000  54      ITRK = IDATA(IPTR+1)                                               TRACK #
 11100    C
 11200    C
 11400  55      HPFREE = 1                                                         RESERVE SPACE IN CWORK
 11500    C
 11600    C=======================================================================
 11800  56      IPV    = ICALIB(10)                                                GET X-Y-VERTEX AND STRENGTH OF VC
 11900  57      XO     = ACALIB(IPV+ 1)
 12000  58      YO     = ACALIB(IPV+ 3)
 12100  59      CURVXY=ADATA(IPTR+25)
 12200  60      IF(ABS(CURVXY).LT.1.E-9) CURVXY = SIGN(1.E-9,CURVXY)
 12300  62      DDR0=DISTXY(ADATA(IPTR+5),ADATA(IPTR+6),ADATA(IPTR+8),
 12400         +ADATA(IPTR+9),1./CURVXY,XO,YO,XP,YP,FI)
 12500  63      FV     = ERRFAC
 12600  64      IF(FV .LT. .50) FV = .50
 12700  66      IF LDATYP(DUMMY) .EQ. 1
 12800  67      THEN
 12900  70         SRESO=.160
 13000  71      ELSE
 13100  73         SRESO=.100
 13200  74      CIF
 13300  75      SIGMIN=(SRESO/1.6)**2
 13400  76      PTRANS = ABS(0.0299792458*BKGAUS/CURVXY) * .001
 13500  77      RESV=.0100+.25*SIN(FI)**2+RESMS/PTRANS**2
 13600  78      WGHT0  = (SRESO/FV)**2 / RESV
 13700  79      INDBIT=512
 13800    C=======================================================================
 14000  80      XX    =  ADATA(IPTR+12) - ADATA(IPTR+5)                            HALF DISTANCE BETWEEN FIRST AND LAST POINTS ON TRA
 14100  81      YY    =  ADATA(IPTR+13) - ADATA(IPTR+6)
 14200  82      RR    = 0.5*SQRT(XX**2+YY**2)
 14300    C
 14400  83      IF RR.LT.10.
 14500  84      THEN
 14600  87         IF KPRT1.LT.NPRT1
 14700  88         THEN
 14800  91            KPRT1=KPRT1+1
 14900  92            WRITE(6,848) NRUN,NEV,ITRK,RR
 15000  93848         FORMAT(' ******** RUN,EV,TRACK',I8,I6,I3,/,
 15100         +      ' HALF DISTANCE OF FIRST AND LAST POINTS',E14.3,
 15200         +      ', XYRFT1 DOES NOT ATTEMPT R-PHI FIT')
 15300  94         CIF
 15400  95         RETURN
 15500  96      CIF
 15600    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 15700    C
 15800                                                                             FETCH HITS, CALCULATE COORDINATES, AND
 16000  97      HPCO0  = HPFREE                                                    FILL ARRAY IN /CWORK/
 16100  98      LHIT   = 14
 16200    C     ORIGIN HALFWAY BETWEEN FIRST AND LAST POINTS ON TRACK
 16300  99      INDFET = 2
 16400 100      CALL JFETCH(IPTR,IPJHTL,WRK(HPCO0),LHIT,IPRES,INDFET,XO,YO)
 16500    C
 16600    C
 16700 101      HLDCO  = LHIT
 16800 102      HPCO9  = IPRES - 1
 16900 103      HPAR0  = IPRES
 17000 104      HLDPA  = 20
 17100 105      HPAR9  = HPAR0 + HLDPA - 1
 17200 106      HPFREE = HPAR9 + 1
 17300 107      XT     = WRK (IPRES   )
 17400 108      YT     = WRK (IPRES+ 1)
 17500 109      CSROT  = WRK (IPRES+ 2)
 17600 110      SNROT  = WRK (IPRES+ 3)
 17800 111      XOR    =- XT*CSROT -  YT*SNROT                                     JADE ORIGIN IN THE FIT SYSTEM
 17900 112      YOR    =  XT*SNROT -  YT*CSROT
 18100 113      X0     = (XO-XT)*CSROT+(YO-YT)*SNROT                               VERTEX IN THE FIT SYSTEM
 18200 114      Y0     =-(XO-XT)*SNROT+(YO-YT)*CSROT
 18300    C
 18500 115      ZVERT = ADATA(IPTR+31)                                             ZVERT, THETA
 18600 116      TGTH = ADATA(IPTR+30)
 18700 117      CSTH   = WRK (IPRES+11)
 18800 118      SNTH   = WRK (IPRES+12)
 18900    C
 19000 119      IWRK(IPRES+10)=0
 19100    C
 19200    C ORIGINAL CHI2 AND CURVATURE ERROR IN PATR BANK
 19300 120      SIG=ADATA(IPTR+23)**2
 19400 121      IF(SIG.LT.1.E-5) SIG=1.E-5
 19500 123      SIG11=(.5*ADATA(IPTR+26))**2/SIG
 19600    C
 19700    C-----------------------------------------------------------------------
 19800    C
 19900    C     GYMNASTICS FOR PRIVATE HIT QUALIFICATION
 20000    C     AND FOR HANDLING MORE HITS ON SAME WIRE
 20100    C
 20200    C
 20300    C TRY TO RECOVER HITS POSSIBLY LOST BY EARLIER FIT
 20400 124      XHCUT=RR+200.
 20500    C
 20600 125      XREGA= 100000.
 20700 126      XREGB=-100000.
 20800 127      NHALL=0
 20900 128      NHWIR=0
 21000 129      NHPOT=0
 21100 130      IPCO=HPCO0
 21200 131      REPEAT
 21300 132         NHWIR=NHWIR+1
 21400 133         IF(NHWIR.GT.70) RETURN
 21500 135         ISORT1(NHWIR)=NHWIR
 21600 136         ISORT2(1,NHWIR)=IPCO
 21700 137         ISORT2(3,NHWIR)=0
 21800 138         IW0=IWRK(IPCO)
 21900 139         ICL0=IWRK(IPCO+9)
 22000 140         LFL=0
 22100 141         WHILE IPCO.LE.HPCO9
 22200 143            IW9=IWRK(IPCO)
 22300 147            ICL9=IWRK(IPCO+9)
 22400 148            IF IW9.EQ.IW0 .AND. ICL9.EQ.ICL0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 22500 149            THEN
 22700 152               NHALL=NHALL+1                                             HIT ON THE SAME WIRE
 22800 153               IF(NHALL.GT.90) RETURN
 22900 155               IF(ISORT2(3,NHWIR).EQ.0) ISORT2(2,NHWIR)=NHALL
 23000 157               ISORT2(3,NHWIR)=ISORT2(3,NHWIR)+1
 23100    C
 23200 158               XA=WRK(IPCO+3)
 23300 159               LBGOOD=IWRK(IPCO+10)
 23400 160               IF LBGOOD.LE.2
 23500 161               THEN
 23600 164                  IF ABS(XA).GT.XHCUT
 23700 165                  THEN
 23800 168                     ISORT3(NHALL)=-1
 23900 169                  ELSE
 24000 171                     ISORT3(NHALL)= 1
 24100 172                     LFL=1
 24200 173                     IF(XA.LT.XREGA) XREGA=XA
 24300 175                     IF(XA.GT.XREGB) XREGB=XA
 24400 177                  CIF
 24500    C
 24600 178                  IWRK(IPCO+10)=1
 24700 179               ELSE
 24800 181                  ISORT3(NHALL)=-1
 24900 182               CIF
 25000    C
 25100 183               IPCO=IPCO+HLDCO
 25200 184            ELSE
 25300 186               XWHILE
 25400 187            CIF
 25500 188         CWHILE
 25600 190         IF LFL.EQ.1
 25700 191         THEN
 25800 194            NHPOT=NHPOT+1
 25900 195         ELSE
 26000 197            ISORT3(ISORT2(2,NHWIR))=-2
 26100 198         CIF
 26200 199      UNTIL IPCO.GT.HPCO9
 26300    C-----------------------------------------------------------------------
 26400    C
 26500    C IF LESS THAN 4 HITS SURVIVE NOTHING WILL BE DONE
 26600 200      IF(NHPOT.LT.4) RETURN
 26700 205      XHF=.5*(XREGA+XREGB)
 26800 206      RRPL=.5*(XREGB-XREGA)
 26900 207      RRMI=RRPL
 27000 208      IF ABS(XHF).GT.RR
 27100 209      THEN
 27200 212         RRPL=RRPL+XHF-SIGN(RR,XHF)
 27300 213         RRMI=RRMI-XHF+SIGN(RR,XHF)
 27400 214         XHF=SIGN(RR,XHF)
 27500 215      CIF
 27600    C-----------------------------------------------------------------------
 27700    C  STARTING VALUES OF FIT PARAMETERS
 27800    C
 27900 216      LCHC=0
 28000    C  CHANGE START VALUE IF CURVATURE INCONSISTENT WITH FIRST & LAST POINTS
 28100 217      IF ABS(CURVXY*RR).GT.CKAPP
 28200 218      THEN
 28300 221         LCHC=1
 28400 222         CURVXY=SIGN(CKAPP/RR,CURVXY)
 28500 223      CIF
 28600 224      IF ABS(CURVXY)*RR .GT. .04
 28700 225      THEN
 28800    C      CIRCLE FIT
 28900 228         LFTYP=1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 29000 229         P1=CURVXY/SQRT(1.-(CURVXY*RR)**2)
 29100 230         AAH=(RR-XHF)*(RR+XHF)
 29200 231         PAR3=SAGCIR(1.,P1,AAH,SAGPR,1.E-4)
 29300 232         PAR2=-P1/(1.+PAR3*P1)*XHF
 29400 233         CSI2GM=1.+PAR2**2
 29500 234         PAR1=CURVXY*SQRT(CSI2GM)
 29600 235      ELSE
 29700    C      PARABOLA FIT
 29800 237         LFTYP=2
 29900 238         PAR3=.5*CURVXY*(RR-XHF)*(RR+XHF)
 30000 239         PAR2=-CURVXY*XHF
 30100 240         CSI2GM=1.+PAR2**2
 30200 241         PAR1=-0.5*CURVXY*SQRT(CSI2GM)*CSI2GM
 30300 242      CIF
 30400 243      XMIN=PAR2/PAR1-CKAPP/ABS(CURVXY)
 30500 244      XMAX=PAR2/PAR1+CKAPP/ABS(CURVXY)
 30600    C
 30700    C-----------------------------------------------------------------------
 30800    C  FIT SHIFT AND ROTATION ONLY (CURVATURE KEPT FIXED)
 30900 245      DISCUT=400.
 31000 246      KFLIP=1
 31100 247      PERFORM SHFROT
 31200 250      IF(NHFIT.LT.4) RETURN
 31300 252      IF NHFIT.LT.6
 31400 253      THEN
 31500    C FIT OF SHIFT AND ROTATION HAS ONLY BEEN PERFORMED
 31600    C CHI2 AND CURVATURE ERROR REMAIN THE OLD VALUES IN THE PATR BANK
 31700 256         PERFORM FITBNK
 31800 259         RETURN
 31900 260      CIF
 32000    C
 32100    C-----------------------------------------------------------------------
 32200 261      IF ABS(DA).GT.1.5 .OR. ABS(DB).GT..1 .OR. LCHC.EQ.1
 32300 262      THEN
 32400    C SHIFT TO ORIGINAL FIT TOO BIG OR CHANGE OF CURVATURE FOR START
 32500    C TRY TO FIND CORRECT STARTING VALUES, TAKE CIRCLE IN ANY CASE
 32600 265         IF LFTYP.EQ.2
 32700 266         THEN
 32800 269            LFTYP=1
 32900 270            PAR1=CUROUT*SQRT(CSI2GM)
 33000 271            XMIN=PAR2/PAR1-CKAPP/ABS(CUROUT)
 33100 272            XMAX=PAR2/PAR1+CKAPP/ABS(CUROUT)
 33200 273         CIF
 33300 274         PERFORM STVCIR
 33400 277      CIF
 33500    C
 33600    C
 33700    C IF TOO MANY HITS THROWN AWAY EVEN WITH THE VERY LOOSE RESIDUAL CUTS
 33800    C DO NOT DARE TO ACCEPT/START THE FIT
 33900    C
 34000 278      IF(NHFIT.LT.NHPOT/2) RETURN
 34100    C
 34200    C
 34400 280      NHFTLS=NHFIT                                                       SAVE CURRENT (START) VALUES
 34500 281      PAR1LS=PAR1
 34600 282      PAR2LS=PAR2
 34700 283      PAR3LS=PAR3
 34800 284      CSI2LS=CSI2GM
 34900 285      CURLST=CUROUT
 35000 286      XMAXLS=XMAX
 35100 287      XMINLS=XMIN
 35200 288      SIG11L=SIG11
 35300 289      SIGLST=SIG
 35400    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 35500    C
 35700 290      NHWIRV=NHWIR+1                                                     VERTEX
 35800 291      ISORT1(NHWIRV)=NHWIRV
 35900 292      ISORT2(1,NHWIRV)=-200
 36000    C
 36100    C
 36200    C=======================================================================
 36300    C
 36500 293      INDMAX=NHFIT/8+1                                                   FIRST ITERATE WITHOUT VERTEX CONSTRAINT
 36600 294      IF(INDMAX.GT.8) INDMAX=8
 36700 296      INDFIT=0
 36800 297      WHILE INDFIT.LT.INDMAX
 36900 299         INDFIT=INDFIT+1
 37100 303         PERFORM FTCURV                                                  ARABOLA OR CIRCLE FIT
 37200 306         IF LNOCON.EQ.1
 37300 307         THEN
 37400    C NO CONVERGENCE AS INDICATED BY LOSS OF TOO MANY HITS
 37500    C STILL RETAIN THE EARLIER FIT
 37600    C IF IT IS THE ONE OBTAINED IN PROC STVCIR,
 37700    C CHI2 AND CURVATURE ERROR REMAIN THE OLD VALUES IN THE PATR BANK
 37800 310            NHFIT=NHFTLS
 37900 311            PAR1=PAR1LS
 38000 312            PAR2=PAR2LS
 38100 313            PAR3=PAR3LS
 38200 314            CSI2GM=CSI2LS
 38300 315            CUROUT=CURLST
 38400 316            XMAX=XMAXLS
 38500 317            XMIN=XMINLS
 38600 318            SIG11=SIG11L
 38700 319            SIG=SIGLST
 38800    C
 38900    C DO NOT ATTEMPT VERTEX CONSTRAINT
 39000 320            PERFORM FITBNK
 39100 323            RETURN
 39200 324         CIF
 39300 325         IF(SIG.LT.SIGMIN) XWHILE
 39400 327         IF INDFIT.GE.2
 39500 328         THEN
 39600 331            PERFORM LLSTOP
 39700 334            IF LSTOP.EQ.1
 39800 335            THEN
 39900    C      PREVIOUS FIT ACCEPTED, RESTORE ITS RESULTS
 40000 338               INDFIT=INDFIT-1
 40100 339               NHFIT=NHFTLS
 40200 340               PAR1=PAR1LS
 40300 341               PAR2=PAR2LS
 40400 342               PAR3=PAR3LS
 40500 343               CSI2GM=CSI2LS
 40600 344               CUROUT=CURLST
 40700 345               XMAX=XMAXLS
 40800 346               XMIN=XMINLS
 40900 347               SIG11=SIG11L
 41000 348               SIG=SIGLST
 41100 349               KFLIP=3-KFLIP
 41200 350               XWHILE
 41300 351            CIF
 41400 352         CIF
 41500 353         IF(INDFIT.EQ.INDMAX) XWHILE
 41700 355         NHFTLS=NHFIT                                                    SAVE FIT RESULTS
 41800 356         PAR1LS=PAR1
 41900 357         PAR2LS=PAR2
 42000 358         PAR3LS=PAR3
 42100 359         CSI2LS=CSI2GM
 42200 360         CURLST=CUROUT
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 42300 361         XMAXLS=XMAX
 42400 362         XMINLS=XMIN
 42500 363         SIG11L=SIG11
 42600 364         SIGLST=SIG
 42800 365         PERFORM HITCLN                                                  HIT CLEANING
 42900 368      CWHILE
 43000    C
 43100    C            ======  VERTEX CONSTRAINT  =======
 43200 370      X0R=X0-XHF
 43300 371      IF FV.LT.200. .AND. X0R.GT.XMIN .AND. X0R.LT.XMAX
 43400 372      THEN
 43500    C        VERTEX CONSTRAINT (WEEK OR STRONG) HAS BEEN REQUESTED
 43600    C        ROUGH CHECK IF RUN VERTEX CONSISTENT WITH THE TRACK
 43700 375         IF LFTYP.EQ.2
 43800 376         THEN
 43900 379            DVCHI2=((PAR1*X0R+PAR2)*X0R+PAR3-Y0)**2*WGHT0
 44000 380         ELSE
 44100 382            AAH=-X0R**2*CSI2GM
 44200 383            FDBPR=1./(1.+PAR1*X0R*PAR2)
 44300 384            SAG=SAGCIR(FDBPR,PAR1,AAH,SAGPR,1.E-4)
 44400 385            DVCHI2=(SAG+PAR2*X0R+PAR3-Y0)**2*WGHT0
 44500 386         CIF
 44600 387         IF DVCHI2 .LT.  9.*SIG
 44700 388         THEN
 44800 391            ISORT2(1,NHWIRV)=-100
 44900 392            PERFORM FTCURV
 45000 395            IF(LNOCON.EQ.0) INDBIT=1024
 45100 397         CIF
 45200 398      CIF
 45300    C
 45500 399      PERFORM FITBNK                                                     SET UP PATR-BANK
 45600 402      RETURN
 45700    C=======================================================================
 45800    C
 45900                                                                             *************************
 46000                                                                             *      F T C U R V      *
 46200    C                                                                        *************************
 46300    C
 46500 403      PROC FTCURV                                                        PARABOLA OR CIRCLE FIT
 46600    C
 46700 404         LNOCON=0
 46800                                                                             GET EQUATIONS
 47000 405         KFLIP=3-KFLIP                                                   WEIGHT VERTEX AS POINT OF PARABOLA
 47100 406         KITER=0
 47200 407         WHILE KITER .LT. 3-LFTYP
 47300 409            KITER=KITER+1
 47400 413            X0R=X0-XHF
 47500 414            IF ISORT2(1,NHWIRV).EQ.-100 .AND. X0R.GT.XMIN .AND. X0R.LT.XMAX
 47600 415            THEN
 47800 418               IF LFTYP.EQ.2                                             VERTEX INCLUDED
 47900 419               THEN
 48000 422                  DYDP1=X0R**2
 48100 423                  DYDP2=X0R
 48200 424                  DYRES=Y0
 48300 425               ELSE
 48400 427                  AAH=-X0R**2
 48500 428                  FDBPR=1./(1.+PAR1*X0R*PAR2)
 48600 429                  SAG=SAGCIR(FDBPR,PAR1,AAH*CSI2GM,SAGPR,1.E-4)
 48700 430                  CC1=FDBPR/(1.+SAG*PAR1*FDBPR)
 48800 431                  DYDP1=CC1*SAGPR
 48900 432                  DYDP2=X0R+PAR1*CC1*(AAH*PAR2-SAG*X0R)
 49000 433                  DYRES=Y0-SAG-PAR2*X0R-PAR3
 49100 434               CIF
 49200 435               S0 = WGHT0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 49300 436               S1=DYDP2*WGHT0
 49400 437               S2=DYDP1*WGHT0
 49500 438               S3=S2*DYDP2
 49600 439               S4=S2*DYDP1
 49700 440               S8=S1*DYDP2
 49800 441               S7=DYRES*WGHT0
 49900 442               S6=S7*DYDP2
 50000 443               S5=S7*DYDP1
 50100 444            ELSE
 50300 446               S0 = 0.                                                   VERTEX OMITTED
 50400 447               S1 = 0.
 50500 448               S2 = 0.
 50600 449               S3 = 0.
 50700 450               S4 = 0.
 50800 451               S8 = 0.
 50900 452               S7 = 0.
 51000 453               S6 = 0.
 51100 454               S5 = 0.
 51200 455            CIF
 51300 456            S00=S0
 51400 457            FOR IHWIR=1,NHWIR
 51500 458               IH=ISORT2(2,IHWIR)
 51600 459               NNH=ISORT2(3,IHWIR)
 51700 460               FOR JNH=1,NNH
 51800 461                  ISORT4(KFLIP,IH+JNH-1)=0
 51900 462               CFOR
 52000 464               IF ISORT3(IH).EQ.1 .OR. ISORT3(IH).EQ.-1.AND.NNH.GT.1
 52100 465               THEN
 52200 468                  RESMIN=10000.
 52300 469                  FOR JNH=1,NNH
 52400 470                     JH=IH+JNH-1
 52500 471                     IF ISORT3(JH).EQ.1
 52600 472                     THEN
 52700 475                        IPCO=ISORT2(1,IHWIR)+(JNH-1)*HLDCO
 52800 476                        XA = WRK(IPCO+3)
 52900 477                        XAR=XA-XHF
 53000 478                        IF XAR.GT.XMIN.AND.XAR.LT.XMAX
 53100 479                        THEN
 53200 482                           YA = WRK(IPCO+4)
 53300 483                           IF LFTYP.EQ.2
 53400 484                           THEN
 53500 487                              DYDP1A=XAR**2
 53600 488                              DYDP2A=XAR
 53700 489                              DYRESA=YA
 53800 490                              DF0=ABS(YA-((PAR1*XAR+PAR2)*XAR+PAR3))
 53900 491                           ELSE
 54000 493                              AAH=-XAR**2
 54100 494                              FDBPR=1./(1.+PAR1*XAR*PAR2)
 54200 495                              SAG=SAGCIR(FDBPR,PAR1,AAH*CSI2GM,SAGPR,1.E-4)
 54300 496                              CC1=FDBPR/(1.+SAG*PAR1*FDBPR)
 54400 497                              DYDP1A=CC1*SAGPR
 54500 498                              DYDP2A=XAR+PAR1*CC1*(AAH*PAR2-SAG*XAR)
 54600 499                              DYRESA=YA-SAG-PAR2*XAR-PAR3
 54700 500                              DF0=ABS(DYRESA)
 54800 501                           CIF
 54900 502                        ELSE
 55000 504                           DF0=15000.
 55100 505                        CIF
 55200 506                        IF DF0.LT.RESMIN
 55300 507                        THEN
 55400 510                           RESMIN=DF0
 55500 511                           DYDP1=DYDP1A
 55600 512                           DYDP2=DYDP2A
 55700 513                           DYRES=DYRESA
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 55800 514                           JHUSE=JH
 55900 515                        CIF
 56000 516                     CIF
 56100 517                  CFOR
 56200 519                  IF RESMIN.LT.RESCUT
 56300 520                  THEN
 56400 523                     S0=S0+1.
 56500 524                     S1=S1+DYDP2
 56600 525                     S2=S2+DYDP1
 56700 526                     S3=S3+DYDP1*DYDP2
 56800 527                     S4=S4+DYDP1**2
 56900 528                     S8=S8+DYDP2**2
 57000 529                     S7=S7+DYRES
 57100 530                     S6=S6+DYRES*DYDP2
 57200 531                     S5=S5+DYRES*DYDP1
 57300 532                     ISORT4(KFLIP,JHUSE)=1
 57400 533                  ELSE
 57500 535                     ISORT3(IH)=-2
 57600 536                  CIF
 57700 537               CIF
 57800 538            CFOR
 57900 540            NHF1=S0-S00+.1
 58000 541            IF NHF1.LT.6 .OR. NHF1.LT.NHPOT/2
 58100 542            THEN
 58200 545               LNOCON=1
 58300 546               XWHILE
 58400 547            CIF
 58500 548            NHFIT=NHF1
 58600 549            DEG   = S0 - S00 - 3.
 58800 550            DET = (S8*S0-S1*S1)*S4 + (S2*S1-S3*S0)*S3 + (S3*S1-S2*S8)*S2 CURVATURE ERROR
 58900 551            SIG11 = (S8*S0 - S1*S1)/DET
 59000    C
 59200 552            F1 = 1. / S4                                                 SOLVE EQUATIONS
 59300 553            XX12 = S3*F1
 59400 554            XX13 = S2*F1
 59500 555            YY1  = S5*F1
 59600 556            XX22 = S8 - S3*XX12
 59700 557            XX23 = S1 - S3*XX13
 59800 558            YY2  = S6 - S3*YY1
 59900 559            XX32 = S1 - S2*XX12
 60000 560            XX33 = S0 - S2*XX13
 60100 561            YY3  = S7 - S2*YY1
 60200 562            IF XX22.GT.XX32
 60300 563            THEN
 60400 566               XX23 = XX23 / XX22
 60500 567               YY2  = YY2  / XX22
 60600 568               PARR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 60700 569               PARR2 = YY2 - XX23*PARR3
 60800 570            ELSE
 60900 572               XX33 = XX33 / XX32
 61000 573               YY3  = YY3  / XX32
 61100 574               PARR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 61200 575               PARR2 = YY3 - XX33*PARR3
 61300 576            CIF
 61400 577            PARR1 = YY1 - XX12*PARR2 - XX13*PARR3
 61500    C
 61600 578            IF LFTYP.EQ.2
 61700 579            THEN
 61800 582               PAR1=PARR1
 61900 583               PAR2=PARR2
 62000 584               PAR3=PARR3
 62100 585               IF(ABS(PAR1).LT.1.E-10) PAR1 = SIGN(1.E-10,PAR1)
 62200 587               CSI2GM=PAR2**2+1.
 62300 588               CUROUT =-PAR1 * 2./ (SQRT(CSI2GM)*CSI2GM)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 12
0CARD TARGET
  NO  STM.NO
 
 62400 589            ELSE
 62500 591               PAR1=PAR1+PARR1
 62600 592               PAR2=PAR2+PARR2
 62700 593               PAR3=PAR3+PARR3
 62800 594               IF(ABS(PAR1).LT.1.E-10) PAR1 = SIGN(1.E-10,PAR1)
 62900 596               CSI2GM=PAR2**2+1.
 63000 597               CUROUT=PAR1/SQRT(CSI2GM)
 63100 598               XMIN=PAR2/PAR1-CKAPP/ABS(CUROUT)
 63200 599               XMAX=PAR2/PAR1+CKAPP/ABS(CUROUT)
 63300 600            CIF
 63400 601         CWHILE
 63500    C  END ITERATION DONE IN CASE OF CIRCLE FIT ONLY
 63600    C
 63700    C
 63800 603         IF LNOCON.EQ.0
 63900 604         THEN
 64100 607            CHISQ = 0.                                                   CALC. CHISQ + SOLVE L/R AMBIGUITY
 64200 608            NHF1=0
 64300 609            FOR IHWIR=1,NHWIR
 64400 610               IRESHT(IHWIR)=-1
 64500 611               IH=ISORT2(2,IHWIR)
 64600 612               NNH=ISORT2(3,IHWIR)
 64700 613               IF ISORT3(IH).GE.0 .OR. ISORT3(IH).EQ.-1.AND.NNH.GT.1
 64800 614               THEN
 64900 617                  RESMIN=10000.
 65000 618                  FOR JNH=1,NNH
 65100 619                     JH=IH+JNH-1
 65200 620                     IF ISORT3(JH).GE.0
 65300 621                     THEN
 65400 624                        IFLG=ISORT3(JH)
 65500 625                        IPCO=ISORT2(1,IHWIR)+(JNH-1)*HLDCO
 65600 626                        XR= WRK(IPCO+3)-XHF
 65700 627                        IF XR.GT.XMIN.AND.XR.LT.XMAX
 65800 628                        THEN
 65900 631                           Y = WRK(IPCO+4)
 66000 632                           IF LFTYP.EQ.2
 66100 633                           THEN
 66200 636                              DF0=ABS(Y-(PAR1*XR+PAR2)*XR-PAR3)
 66300 637                           ELSE
 66400 639                              AAH=-XR**2*CSI2GM
 66500 640                              FDBPR=1./(1.+PAR1*XR*PAR2)
 66600 641                              SAG=SAGCIR(FDBPR,PAR1,AAH,SAGPR,1.E-4)
 66700 642                              DF0=ABS(Y-SAG-PAR2*XR-PAR3)
 66800 643                           CIF
 66900 644                           IF(DF0.LT.RESMIN) RESMIN=DF0
 67000 646                        CIF
 67100 647                     CIF
 67200 648                  CFOR
 67300 650                  IF RESMIN.LT.5000.
 67400 651                  THEN
 67500 654                     IRESHT(IHWIR)=RESMIN*1.E6
 67600 655                     IF IFLG.EQ.1
 67700 656                     THEN
 67800 659                        CHISQ=CHISQ+RESMIN**2
 67900 660                        NHF1=NHF1+1
 68000 661                     CIF
 68100 662                  CIF
 68200 663               CIF
 68300 664            CFOR
 68400 666            IF(NHF1.LT.NHFIT-3) LNOCON=1
 68500 668            SIG    =      CHISQ  / DEG
 68600 669         CIF
 68700 670      CPROC
 68800    C=======================================================================
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 13
0CARD TARGET
  NO  STM.NO
 
 68900 672      PROC HITCLN
 69000    C      LABEL HITS NOT TO BE USED IN THE NEXT ITRATION
 69200    C  VERTEX NOT INCLUDED IN THE ITERATIVE PART                             SQRT(CHI2) OF VERTEX
 69300    C  IN THE CURRENT VERSION
 69400    CV       X0R=X0-XHF
 69500    CV       IF LFTYP.EQ.2
 69600    CV       THEN
 69700    CV          DFVERT=((PAR1*X0R+PAR2)*X0R+PAR3-Y0)*SQRT(WGHT0)
 69800    CV       ELSE
 69900    CV          AAH=-X0R**2*CSI2GM
 70000    CV          FDBPR=1./(1.+PAR1*X0R*PAR2)
 70100    CV          SAG=SAGCIR(FDBPR,PAR1,AAH,SAGPR,1.E-4)
 70200    CV          DFVERT=(SAG+PAR2*X0R+PAR3-Y0)*SQRT(WGHT0)
 70300    CV       CIF
 70400    CV       IRESHT(NHWIRV)=ABS(DFVERT)*1.E6
 70500    C-------------------------------------------------------------
 70600    C
 70800    C  EXCLUDE THE INDFIT LARGEST RESIDUAL HITS,                             SORT HITS ACCORDING TO RESIDUALS
 70900    C  RESTORE THE OTHERS (EXLUDED FOR EVER HITS NOT COUNTED)
 71000    C
 71100    CV       CALL SHELL9(IRESHT,ISORT1,NHWIRV)
 71200 673         CALL SHELL9(IRESHT,ISORT1,NHWIR)
 71300 674         KOMIT=0
 71400    CV       FOR J1=1,NHWIRV
 71500 675         FOR J1=1,NHWIR
 71600    CV          IHWIR=ISORT1(NHWIRV+1-J1)
 71700 676            IHWIR=ISORT1(NHWIR+1-J1)
 71800 677            IPCO=ISORT2(1,IHWIR)
 71900 678            IF IPCO.NE.-100 .AND. IPCO.NE.-200
 72000 679            THEN
 72200 682               NNH=ISORT2(3,IHWIR)                                       HIT, NOT VERTEX
 72300 683               IH=ISORT2(2,IHWIR)
 72400 684               LFLG=0
 72500 685               FOR JNH=1,NNH
 72600 686                  IHA=IH+JNH-1
 72700 687                  IQA=ISORT3(IHA)
 72800 688                  IF IQA.GT.-1
 72900 689                  THEN
 73000 692                     IF LFLG.EQ.0
 73100 693                     THEN
 73200 696                        LFLG=1
 73300 697                        KOMIT=KOMIT+1
 73400 698                     CIF
 73500 699                     IF KOMIT.LE.INDFIT
 73600 700                     THEN
 73700 703                        ISORT3(IHA)=0
 73800 704                     ELSE
 73900 706                        ISORT3(IHA)=1
 74000 707                     CIF
 74100 708                  CIF
 74200 709               CFOR
 74300    CV          ELSE
 74400    C   VERTEX;   DOES NOT OCCOUR IN THE CURRENT VERSION
 74500    CV             KOMIT=KOMIT+1
 74600    CV             IF(KOMIT.LE.INDFIT) WGHT0=WGHT0*.01
 74700 711            CIF
 74800 712         CFOR
 74900 714      CPROC
 75000    C=======================================================================
 75100 716      PROC LLSTOP
 75200 717         IF INDFIT.LE.6
 75300 718         THEN
 75400 721            INDCK=INDFIT-1
 75500 722         ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 14
0CARD TARGET
  NO  STM.NO
 
 75600 724            INDCK=5
 75700 725         CIF
 75800 726         ICHCK=NCHECK(INDCK)
 75900 727         WHILE SIGLST.LT.RCHECK(ICHCK,1,INDCK)
 76000 729            ICHCK=ICHCK-1
 76100 733         CWHILE
 76200 735         IF(ICHCK.LT.1) ICHCK=1
 76300 737         IF SIG/SIGLST.GT.RCHECK(ICHCK,2,INDCK)
 76400 738         THEN
 76500 741            LSTOP=1
 76600 742         ELSE
 76700 744            LSTOP=0
 76800 745         CIF
 76900 746      CPROC
 77000    C=======================================================================
 77100    C
 77200    C
 77300                                                                             *************************
 77400                                                                             *      F I T B N K      *
 77600    C                                                                        *************************
 77700    C
 77900 748      PROC FITBNK                                                        SET UP FIT-BANK
 78000    C
 78200 749         XST=XHF+XMIN                                                    START + END POINTS
 78300 750         IF(XST.LT.XREGA) XST=XREGA
 78400 752         XSTR=XST-XHF
 78500 753         XEN=XHF+XMAX
 78600 754         IF(XEN.GT.XREGB) XEN=XREGB
 78700 756         XENR=XEN-XHF
 78800 757         IF LFTYP.EQ.2
 78900 758         THEN
 79000 761            YST  = (PAR1 *XSTR+ PAR2 )*XSTR+ PAR3
 79100 762            YEN  = (PAR1 *XENR+ PAR2 )*XENR+ PAR3
 79300 763            TGST = PAR1*XSTR*2.+ PAR2                                    DIRECTION AT START + END POINT
 79400 764            TGEN = PAR1*XENR*2.+ PAR2
 79500 765         ELSE
 79600 767            AAH=-XSTR**2
 79700 768            FDBPR=1./(1.+PAR1*XSTR*PAR2)
 79800 769            SAG=SAGCIR(FDBPR,PAR1,AAH*CSI2GM,SAGPR,1.E-4)
 79900 770            YST=SAG+PAR2*XSTR+PAR3
 80000 771            TGST=PAR2-PAR1*FDBPR/(1.+SAG*PAR1*FDBPR)*(SAG*PAR2+XSTR*CSI2GM)
 80100 772            AAH=-XENR**2
 80200 773            FDBPR=1./(1.+PAR1*XENR*PAR2)
 80300 774            SAG=SAGCIR(FDBPR,PAR1,AAH*CSI2GM,SAGPR,1.E-4)
 80400 775            YEN=SAG+PAR2*XENR+PAR3
 80500 776            TGEN=PAR2-PAR1*FDBPR/(1.+SAG*PAR1*FDBPR)*(SAG*PAR2+XENR*CSI2GM)
 80600 777         CIF
 80700 778         DXST = 1./SQRT(TGST**2+1.)
 80800 779         DYST = DXST * TGST
 80900 780         DXEN = 1./SQRT(TGEN**2+1.)
 81000 781         DYEN = DXEN * TGEN
 81100    C
 81200    C
 81300    C
 81500 782         HPTR0 = HPFREE                                                  COPY TRACK BANK
 81600 783         CALL MVCL(IWRK(HPTR0),0,IDATA(IPTR+1),0,4*LDTR)
 81700    C
 81900 784         IP    = HPTR0 - 1                                               FILL FIT-BANK
 82000 785         IWRK(IP+2) = LAND(IWRK(IP+2),MASK3)
 82100 786         IWRK(IP+2) = LOR(IWRK(IP+2),INDBIT)
 82200 787         IWRK(IP+ 3) = IDAY
 82300 788         WRK (IP+ 5) = XST *CSROT - YST *SNROT + XT
 82400 789         WRK (IP+ 6) = XST *SNROT + YST *CSROT + YT
 82500 790         WRK (IP+ 7) = SQRT(WRK(IP+ 5)**2 + WRK(IP+ 6)**2)*TGTH+ZVERT
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 15
0CARD TARGET
  NO  STM.NO
 
 82600 791         DXSTJ       =  DXST*CSROT - DYST*SNROT
 82700 792         DYSTJ       =  DXST*SNROT + DYST*CSROT
 82800 793         WRK (IP+ 8) =  DXSTJ*CSTH
 82900 794         WRK (IP+ 9) =  DYSTJ*CSTH
 83000 795         WRK (IP+12) = XEN *CSROT - YEN *SNROT + XT
 83100 796         WRK (IP+13) = XEN *SNROT + YEN *CSROT + YT
 83200 797         WRK (IP+14) = SQRT(WRK(IP+12)**2 + WRK(IP+13)**2)*TGTH+ZVERT
 83300 798         WRK (IP+15) = (DXEN*CSROT - DYEN*SNROT)*CSTH
 83400 799         WRK (IP+16) = (DXEN*SNROT + DYEN*CSROT)*CSTH
 83500 800         IWRK(IP+24) = NHFIT
 83600 801         WRK (IP+25) = CUROUT
 83700 802         WRK (IP+27) = CUROUT
 83800 803         WRK (IP+28) = CUROUT
 83900    C
 84000 804         WRK (IP+23) = SQRT(SIG)
 84100 805         WRK (IP+26) = SQRT(SIG*SIG11/CSI2GM)
 84200 806         IF(LFTYP.EQ.2) WRK(IP+26)=WRK(IP+26)*2./CSI2GM
 84300    C
 84400    C        IWRK(IP+18) = LFTYP
 84500    C EVEN IF PARABOLA FIT WAS DONE, CIRCLE PARAMETERS ARE STORED
 84600 808         IWRK(IP+18) = 1
 84700    C
 84800 809         PAR1=CUROUT*SQRT(CSI2GM)
 84900 810         SIGNC=SIGN(1.,CUROUT)
 85000 811         ACURV=ABS(CUROUT)
 85100 812         A=((XHF-XOR)*PAR2-PAR3+YOR)/SQRT(CSI2GM)
 85200 813         B=(XHF-XOR+(PAR3-YOR)*PAR2)/SQRT(CSI2GM)
 85300 814         FDBPR=1./ACURV+SIGNC*A
 85400 815         IF FDBPR.LT.100.
 85500 816         THEN
 85600 819            DIMP=-1./ACURV+SQRT(FDBPR**2+B**2)
 85700 820         ELSE
 85800 822            DIMP=SIGNC*A+SAGCIR(1./(1.+CUROUT*A),ACURV,B**2,SP,1.E-4)
 85900 823         CIF
 86000 824         FDBPR=1.+DIMP*ACURV
 86100 825         IF FDBPR.LT.ACURV*1.E-3
 86200 826         THEN
 86300 829            WRK(IP+19)=ACURV
 86400 830            WRK(IP+20)=DIMP
 86500 831            WRK(IP+21)=0.
 86600 832         ELSE
 86700 834            FDBPR=SIGNC/FDBPR
 86800 835            SGPFI=(PAR2*CSROT+SNROT)/SQRT(CSI2GM)
 86900 836            CGPFI=(CSROT-PAR2*SNROT)/SQRT(CSI2GM)
 87000 837            COSALP=(CUROUT*(XHF*CSROT-PAR3*SNROT+XT)+SGPFI)*FDBPR
 87100 838            SINALP=(CUROUT*(XHF*SNROT+PAR3*CSROT+YT)-CGPFI)*FDBPR
 87200 839            WRK(IP+19)=ACURV
 87300 840            WRK(IP+20)=DIMP
 87400 841            WRK(IP+21)=ATAN2(SINALP,COSALP)
 87500    C
 87600 842            IF LDTR.GE.55.AND.NHFIT.GE.10.AND.LNOCON.EQ.0
 87700 843            THEN
 87800 846               LCOVAR=1
 87900 847            ELSE
 88000 849               LCOVAR=0
 88100 850            CIF
 88200 851            IF LAND(MODXYV,32) .NE. 0
 88300 852            THEN
 88400 855               LJHTLU=1
 88500 856            ELSE
 88600 858               LJHTLU=0
 88700 859            CIF
 88800    C           CALCULATE COVARIANCE MATRIX AND/OR UPDATE JHTL BANK
 88900 860            PERFORM COVAR
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 16
0CARD TARGET
  NO  STM.NO
 
 89000    C
 89100 863            IWRK(IPRES+10)=1
 89200    C
 89300 864         CIF
 89400    C
 89600 865         CALL MVCL(IDATA(IPTR+1),0,IWRK(HPTR0),0,4*LDTR)                 PUT RESULT INTO PATR-BANK
 89700    C
 89800    C
 89900 866      CPROC
 90000    C-----------------------------------------------------------------------
 90100 868      PROC SHFROT
 90200    C  FIT SHIFT AND ROTATION ONLY (CURVATURE KEPT FIXED)
 90300 869         S0 = 0.
 90400 870         S1 = 0.
 90500 871         S2 = 0.
 90600 872         S3 = 0.
 90700 873         S4 = 0.
 90800 874         FOR IHWIR=1,NHWIR
 90900 875            IH=ISORT2(2,IHWIR)
 91000 876            NNH=ISORT2(3,IHWIR)
 91100 877            FOR JNH=1,NNH
 91200 878               ISORT4(KFLIP,IH+JNH-1)=0
 91300 879            CFOR
 91400 881            IF ISORT3(IH).EQ.1 .OR. ISORT3(IH).EQ.-1.AND.NNH.GT.1
 91500 882            THEN
 91600 885               RESMIN=10000.
 91700 886               FOR JNH=1,NNH
 91800 887                  JH=IH+JNH-1
 91900 888                  IF ISORT3(JH).EQ.1
 92000 889                  THEN
 92100 892                     IPCO=ISORT2(1,IHWIR)+(JNH-1)*HLDCO
 92200 893                     XA = WRK(IPCO+3)
 92300 894                     XAR=XA-XHF
 92400 895                     IF XAR.GT.XMIN .AND. XAR.LT.XMAX
 92500 896                     THEN
 92600 899                        YA = WRK(IPCO+4)
 92700 900                        IF LFTYP.EQ.2
 92800 901                        THEN
 92900 904                           DYRESA=YA-(PAR1*XAR+PAR2)*XAR-PAR3
 93000 905                        ELSE
 93100 907                           AAH=-XAR**2*CSI2GM
 93200 908                           FDBPR=1./(1.+PAR1*XAR*PAR2)
 93300 909                           SAG=SAGCIR(FDBPR,PAR1,AAH,SAGPR,1.E-4)
 93400 910                           DYRESA=YA-SAG-PAR2*XAR-PAR3
 93500 911                        CIF
 93600 912                        DF0=ABS(DYRESA)
 93700 913                     ELSE
 93800 915                        DF0=15000.
 93900 916                     CIF
 94000 917                     IF DF0.LT.RESMIN
 94100 918                     THEN
 94200 921                        RESMIN=DF0
 94300 922                        XR=XAR
 94400 923                        DYRES=DYRESA
 94500 924                        JHUSE=JH
 94600 925                     CIF
 94700 926                  CIF
 94800 927               CFOR
 94900 929               IF RESMIN.LT.DISCUT
 95000 930               THEN
 95100 933                  S0=S0+1.
 95200 934                  S1=S1+XR
 95300 935                  S2=S2+XR**2
 95400 936                  S3=S3+DYRES
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 17
0CARD TARGET
  NO  STM.NO
 
 95500 937                  S4=S4+DYRES*XR
 95600 938                  ISORT4(KFLIP,JHUSE)=1
 95700 939               CIF
 95800 940            CIF
 95900 941         CFOR
 96000 943         NHFIT=S0+.1
 96100 944         IF NHFIT.GE.4
 96200 945         THEN
 96300 948            S12=S1/S2
 96400 949            S42=S4/S2
 96500 950            DA=(S3-S1*S42)/(S0-S1*S12)
 96600 951            DB=S42-S12*DA
 96700 952            PAR3=PAR3+DA
 96800 953            PAR2=PAR2+DB
 96900 954            CSI2GM=1.+PAR2**2
 97000 955            IF LFTYP.EQ.2
 97100 956            THEN
 97200 959               CUROUT =-PAR1 * 2./ (SQRT(CSI2GM)*CSI2GM)
 97300 960            ELSE
 97400 962               CUROUT=PAR1/SQRT(CSI2GM)
 97500 963               XMIN=PAR2/PAR1-CKAPP/ABS(CUROUT)
 97600 964               XMAX=PAR2/PAR1+CKAPP/ABS(CUROUT)
 97700 965            CIF
 97800 966         CIF
 97900 967      CPROC
 98000    C=======================================================================
 98100 969      PROC STVCIR
 98200    C  TRY TO FIND STARTING VALUES FOR CIRCLE FIT
 98300    C  THIS PART IS EXECUTED FOR ONLY A VERY SMALL FRACTION OF THE TRACKS
 98400    C  JUST LOOP UNTIL 10, NO STOP CONDITION CHECKED
 98500 970         ISTV1=0
 98600 971         DISCUT=400.
 98700 972         WHILE ISTV1.LT.10
 98800 974            ISTV1=ISTV1+1
 98900    C  FIT PARABOLA P1*X**2+P2*X+P3 TO RESIDUALS & MODIFY CIRCLE PARAMETERS
 99000 978            S0 = 0.
 99100 979            S1 = 0.
 99200 980            S2 = 0.
 99300 981            S3 = 0.
 99400 982            S4 = 0.
 99500 983            S8 = 0.
 99600 984            S7 = 0.
 99700 985            S6 = 0.
 99800 986            S5 = 0.
 99900 987            KFLIP=3-KFLIP
 00000 988            FOR IHWIR=1,NHWIR
 00100 989               IH=ISORT2(2,IHWIR)
 00200 990               NNH=ISORT2(3,IHWIR)
 00300 991               FOR JNH=1,NNH
 00400 992                  ISORT4(KFLIP,IH+JNH-1)=0
 00500 993               CFOR
 00600 995               IF ISORT3(IH).EQ.1 .OR. ISORT3(IH).EQ.-1.AND.NNH.GT.1
 00700 996               THEN
 00800 999                  RESMIN=10000.
 009001000                  FOR JNH=1,NNH
 010001001                     JH=IH+JNH-1
 011001002                     IF ISORT3(JH).EQ.1
 012001003                     THEN
 013001006                        IPCO=ISORT2(1,IHWIR)+(JNH-1)*HLDCO
 014001007                        XA = WRK(IPCO+3)
 015001008                        XAR= WRK(IPCO+3)-XHF
 016001009                        IF XAR.GT.XMIN.AND.XAR.LT.XMAX
 017001010                        THEN
 018001013                           YA = WRK(IPCO+4)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 18
0CARD TARGET
  NO  STM.NO
 
 019001014                           AAH=-XAR**2
 020001015                           FDBPR=1./(1.+PAR1*XAR*PAR2)
 021001016                           SAG=SAGCIR(FDBPR,PAR1,AAH*CSI2GM,SAGPR,1.E-4)
 022001017                           DYRESA=YA-SAG-PAR2*XAR-PAR3
 023001018                           DF0=ABS(DYRESA)
 024001019                        ELSE
 025001021                           DF0=15000.
 026001022                        CIF
 027001023                        IF DF0.LT.RESMIN
 028001024                        THEN
 029001027                           RESMIN=DF0
 030001028                           X=XAR
 031001029                           DYRES=DYRESA
 032001030                           JHUSE=JH
 033001031                        CIF
 034001032                     CIF
 035001033                  CFOR
 036001035                  IF RESMIN.LT.DISCUT
 037001036                  THEN
 038001039                     S0=S0+1.
 039001040                     S1=S1+X
 040001041                     S2=S2+X**2
 041001042                     S3=S3+X**3
 042001043                     S4=S4+X**4
 043001044                     S8=S8+X**2
 044001045                     S7=S7+DYRES
 045001046                     S6=S6+DYRES*X
 046001047                     S5=S5+DYRES*X**2
 047001048                     ISORT4(KFLIP,JHUSE)=1
 048001049                  CIF
 049001050               CIF
 050001051            CFOR
 051001053            NHFIT=S0+.1
 05200    C
 05300    C
 054001054            IF(NHFIT.LT.5) RETURN
 05500    C
 05600    C
 058001056            F1 = 1. / S4                                                 SOLVE EQUATIONS
 059001057            XX12 = S3*F1
 060001058            XX13 = S2*F1
 061001059            YY1  = S5*F1
 062001060            XX22 = S8 - S3*XX12
 063001061            XX23 = S1 - S3*XX13
 064001062            YY2  = S6 - S3*YY1
 065001063            XX32 = S1 - S2*XX12
 066001064            XX33 = S0 - S2*XX13
 067001065            YY3  = S7 - S2*YY1
 068001066            IF XX22.GT.XX32
 069001067            THEN
 070001070               XX23 = XX23 / XX22
 071001071               YY2  = YY2  / XX22
 072001072               PARR3 = (YY3 - XX32*YY2) / (XX33 - XX32*XX23)
 073001073               PARR2 = YY2 - XX23*PARR3
 074001074            ELSE
 075001076               XX33 = XX33 / XX32
 076001077               YY3  = YY3  / XX32
 077001078               PARR3 = (YY2 - XX22*YY3) / (XX23 - XX22*XX33)
 078001079               PARR2 = YY3 - XX33*PARR3
 079001080            CIF
 080001081            PARR1 = YY1 - XX12*PARR2 - XX13*PARR3
 08100    C
 082001082            XAR=-.7*RRMI
 083001083            IF(XAR.LT..8*XMIN) XAR=.8*XMIN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 19
0CARD TARGET
  NO  STM.NO
 
 084001085            XBR= .7*RRPL
 085001086            IF(XBR.GT..8*XMAX) XBR=.8*XMAX
 086001088            IF -XAR.LT.XBR
 087001089            THEN
 088001092               XBR=-XAR
 089001093            ELSE
 090001095               XAR=-XBR
 091001096            CIF
 09200    C
 093001097            AAH=-XAR**2*CSI2GM
 094001098            FDBPR=1./(1.+PAR1*XAR*PAR2)
 095001099            SAG=SAGCIR(FDBPR,PAR1,AAH,SAGPR,1.E-4)
 096001100            YA=SAG+PAR2*XAR+PAR3 + (PARR1*XAR+PARR2)*XAR+PARR3
 097001101            AAH=-XBR**2*CSI2GM
 098001102            FDBPR=1./(1.+PAR1*XBR*PAR2)
 099001103            SAG=SAGCIR(FDBPR,PAR1,AAH,SAGPR,1.E-4)
 100001104            YB=SAG+PAR2*XBR+PAR3 + (PARR1*XBR+PARR2)*XBR+PARR3
 101001105            YC=PAR3+PARR3
 102001106            P2=(YB-YA)/(2.*XBR)
 103001107            C2=1.+P2**2
 104001108            SAG=YC-.5*(YA+YB)
 105001109            IF SAG**2.GT.(CKAPP*XBR)**2*C2
 106001110            THEN
 107001113               SAG=SIGN(CKAPP*XBR*SQRT(C2),SAG)
 108001114               YC=.5*(YA+YB)+SAG
 109001115            CIF
 110001116            PAR3=YC
 111001117            P1=2.*SAG/(C2*XBR**2-SAG**2)
 112001118            CUROUT=P1/SQRT(C2*(1.+(P1*XBR)**2))
 113001119            IF(ABS(CUROUT).LT.1.E-8) CUROUT= SIGN(1.E-8,CUROUT)
 114001121            PAR2=P2/(1.+SAG*P1)
 115001122            CSI2GM=1.+PAR2**2
 116001123            PAR1=CUROUT*SQRT(CSI2GM)
 117001124            XMIN=PAR2/PAR1-CKAPP/ABS(CUROUT)
 118001125            XMAX=PAR2/PAR1+CKAPP/ABS(CUROUT)
 11900    C
 120001126            DISCUT=.5*DISCUT
 121001127            IF(DISCUT.LT.10.) DISCUT=10.
 122001129         CWHILE
 123001131      CPROC
 12400    C-----------------------------------------------------------------------
 125001133      PROC COVAR
 12600    C
 12700    C      CALCULATE COVARIANCE MATRIX AND/OR UPDATE JHTL BANK
 12800    C
 129001134         SAMFI=SINALP*CSROT-COSALP*SNROT
 130001135         CAMFI=COSALP*CSROT+SINALP*SNROT
 13100    C
 13200    C        UPDATE OF JHTL FOR HITS   N O T   USED IN THE FIT
 133001136         IP00=2*IDATA(IQJETC)+100
 134001137         FOR IHWIR=1,NHWIR
 135001138            IH=ISORT2(2,IHWIR)
 136001139            NNH=ISORT2(3,IHWIR)
 137001140            FOR JNH=1,NNH
 138001141               JH=IH+JNH-1
 139001142               IF ISORT4(KFLIP,JH).NE.1
 140001143               THEN
 141001146                  IPCO=ISORT2(1,IHWIR)+(JNH-1)*HLDCO
 142001147                  X=WRK(IPCO+3)
 143001148                  Y=WRK(IPCO+4)
 144001149                  A=(X-XOR)*CAMFI+(Y-YOR)*SAMFI
 145001150                  B=(X-XOR)*SAMFI-(Y-YOR)*CAMFI
 146001151                  FDBPR=1./ACURV+DIMP-A
 147001152                  IF FDBPR.LT.100.
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 20
0CARD TARGET
  NO  STM.NO
 
 148001153                  THEN
 149001156                     SAG=SQRT(FDBPR**2+B**2)
 150001157                     RESA=SAG-1./ACURV
 151001158                  ELSE
 152001160                     FDBPR=1./(1.+ACURV*(DIMP-A))
 153001161                     SAG=SAGCIR(FDBPR,ACURV,B**2,SP,1.E-4)
 154001162                     RESA=DIMP-A+SAG
 155001163                  CIF
 15600    C
 15700    C                 IWRK(IPCO+10)=1
 158001164                  WRK(IPCO+13)=RESA
 159001165                  IF LJHTLU.EQ.1
 160001166                  THEN
 161001169                     IP1   =IWRK(IPCO+1)
 162001170                     LBSIDE=IWRK(IPCO+2)
 163001171                     IPHL=IPJHTL+2+(IP1-IP00)/4
 164001172                     LB=IDATA(IPHL)
 165001173                     IDST=ABS(RESA)*5.
 166001174                     IF(IDST.GT.31) IDST=31
 167001176                     IDST=SHFTL(IDST,11)
 168001177                     IDST=LOR(IDST,1024)
 169001178                     IF(LBSIDE.EQ.1) IDST=LOR(IDST,256)
 170001180                     ITR1=LAND(SHFTR(LB,17),127)
 171001181                     IF ITR1.EQ.ITRK
 172001182                     THEN
 173001185                        IDATA(IPHL)=LOR(LAND(LB,MASK1),SHFTL(IDST,16))
 174001186                     ELSE
 175001188                        IDATA(IPHL)=LOR(LAND(LB,MASK2),      IDST    )
 176001189                     CIF
 177001190                  CIF
 178001191               CIF
 179001192            CFOR
 180001194         CFOR
 18100    C
 182001196         CHISQ=0.
 18300    C
 185001197         NHF1=0                                                          VERTEX OMITTED
 186001198         S0D= 0.D0
 187001199         S1D= 0.D0
 188001200         S2D= 0.D0
 189001201         S3D= 0.D0
 190001202         S4D= 0.D0
 191001203         S8D= 0.D0
 192001204         FOR IHWIR=1,NHWIR
 193001205            IH=ISORT2(2,IHWIR)
 194001206            NNH=ISORT2(3,IHWIR)
 195001207            FOR JNH=1,NNH
 196001208               JH=IH+JNH-1
 197001209               IF ISORT4(KFLIP,JH).EQ.1
 198001210               THEN
 199001213                  IPCO=ISORT2(1,IHWIR)+(JNH-1)*HLDCO
 200001214                  X=WRK(IPCO+3)
 201001215                  Y=WRK(IPCO+4)
 202001216                  A=(X-XOR)*CAMFI+(Y-YOR)*SAMFI
 203001217                  B=(X-XOR)*SAMFI-(Y-YOR)*CAMFI
 204001218                  FDBPR=1./ACURV+DIMP-A
 205001219                  IF FDBPR.LT.100.
 206001220                  THEN
 207001223                     SAG=SQRT(FDBPR**2+B**2)
 208001224                     RESA=SAG-1./ACURV
 209001225                     DRDP2=FDBPR/SAG
 210001226                     DRDP1=B*(DRDP2+A/SAG)
 211001227                     DRDP3=1./ACURV**2*(1.-DRDP2)
 212001228                  ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 21
0CARD TARGET
  NO  STM.NO
 
 213001230                     FDBPR=1./(1.+ACURV*(DIMP-A))
 214001231                     SAG=SAGCIR(FDBPR,ACURV,B**2,SP,1.E-4)
 215001232                     DRDP2=1./(1.+SAG*FDBPR*ACURV)
 216001233                     DRDP1=DRDP2*B*(1.+A*FDBPR*ACURV)
 217001234                     DRDP3=DRDP2*FDBPR*SP
 218001235                     RESA=DIMP-A+SAG
 219001236                  CIF
 22000    C
 221001237                  NHF1=NHF1+1
 222001238                  CHISQ=CHISQ+RESA**2
 223001239                  S0D=S0D+DRDP3**2
 224001240                  S1D=S1D+DRDP3*DRDP2
 225001241                  S2D=S2D+DRDP1*DRDP3
 226001242                  S3D=S3D+DRDP1*DRDP2
 227001243                  S4D=S4D+DRDP1**2
 228001244                  S8D=S8D+DRDP2**2
 22900    C
 230001245                  IWRK(IPCO+10)=0
 231001246                  WRK(IPCO+13)=RESA
 232001247                  IF LJHTLU.EQ.1
 233001248                  THEN
 234001251                     IP1   =IWRK(IPCO+1)
 235001252                     LBSIDE=IWRK(IPCO+2)
 236001253                     IPHL=IPJHTL+2+(IP1-IP00)/4
 237001254                     LB=IDATA(IPHL)
 238001255                     IDST=ABS(RESA)*5.
 239001256                     IF(IDST.GT.31) IDST=31
 240001258                     IDST=SHFTL(IDST,11)
 241001259                     IF(LBSIDE.EQ.1) IDST=LOR(IDST,256)
 242001261                     ITR1=LAND(SHFTR(LB,17),127)
 243001262                     IF ITR1.EQ.ITRK
 244001263                     THEN
 245001266                        IDATA(IPHL)=LOR(LAND(LB,MASK1),SHFTL(IDST,16))
 246001267                     ELSE
 247001269                        IDATA(IPHL)=LOR(LAND(LB,MASK2),      IDST    )
 248001270                     CIF
 249001271                  CIF
 250001272               CIF
 251001273            CFOR
 252001275         CFOR
 253001277         IF LCOVAR.EQ.1
 254001278         THEN
 255001281            IF NHF1.LT.10.OR.NHF1.NE.NHFIT
 256001282            THEN
 257001285               PRINT 6781,NRUN,NEV,ITRK,NHFIT,NHF1
 2580012866781           FORMAT(' RUN,EV,TRK,NHFIT,NHF1',I7,I6,I3,2I5)
 259001287            ELSE
 260001289               DETD=(S8D*S0D-S1D*S1D)*S4D+
 26100         +         (S2D*S1D-S3D*S0D)*S3D+(S3D*S1D-S2D*S8D)*S2D
 262001290               FACT=CHISQ/(NHFIT-3)/DETD
 26300    C
 264001291               IWRK(IP+2) =LOR(IWRK(IP+2),2048)
 265001292               WRK(IP+49)=CHISQ/.115**2
 266001293               WRK(IP+50)=(S8D*S0D-S1D**2)*FACT
 267001294               WRK(IP+51)=(S1D*S2D-S0D*S3D)*FACT
 268001295               WRK(IP+52)=(S4D*S0D-S2D**2)*FACT
 269001296               WRK(IP+53)=(S3D*S1D-S8D*S2D)*FACT
 270001297               WRK(IP+54)=(S2D*S3D-S1D*S4D)*FACT
 271001298               WRK(IP+55)=(S8D*S4D-S3D**2)*FACT
 272001299            CIF
 273001300         CIF
 274001301      CPROC
 275001303      END
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 22
0CARD TARGET
  NO  STM.NO
 
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS        1302 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        1302 TARGET STATEMENTS
 00000    C   09/06/83 809201304  MEMBER NAME  ZCFTNW   (S)           SHELTRAN
 00100   2      SUBROUTINE ZCFTNW(NRUN,NEVT,ITRK,TGTH,ZVERT,NZHIT,IZCHMB,AZCHMB)
 00200    C             J.SPITZER    15/7/87
 00300    C      PRINT STATEMENT FOR USE OF Z-CHAMBER HITS IN FIT  12.8.87  J.S.
 00400    C    PASS Z-CHAMBER DATA FOR A SINGLE TRACK TO JFTNEW (OR JFETCH).
 00500    C    AT REQUESTING DATA FOR THE FIRST TRACK IN THE EVENT,
 00600    C    SUSAN'S ZCDATA IS CALLED WHICH CALCULATES THE COORDINATES
 00700    C    FOR THE Z-CH HITS AND PERFORMS THE TRACK-HIT ASSOCIATION.
 00800    C    THE Z-COORDINATES ARE CORRECTED IN THIS ROUTINE IN ORDER
 00900    C    TO MATCH THE JET-CHAMBER EXTRAPOLATIONS ON THE AVERAGE.
 00910    C  20/5/88     USE RRTRK TO AVOID DIVIDE CHECK             EE          *
 00920    C  27/6/88     CORRECT IMI TYPING ERROR                    E E         *
 00930    C  20/9/88     INTRODUCE VARIABLE FIRST                    E E         *
 01000    C
 01100   3      DIMENSION IZCHMB(3,2),AZCHMB(3,2)
 01200   4      DATA NRUNLS/-99/,NEVTLS/-99/,JZERR/0/
 01300    C
 01400   5      COMMON/CZDATA/JZDATA(64),IZDATA(3,8,64),RZDATA(3,8,64)
 01500    C*****              JZDATA(NW)        NUMBER OF HITS ON WIRE NW
 01600    C                   IZDATA(*,         ADC1,ADC2,TDC
 01700    C                            NH,      HIT NUMBER (1--8)
 01800    C                               NW)   WIRE NUMBER (1--64)
 01900    C                   RZDATA(*,         Z-DZ,Z+DZ,PHI
 02000    C*****                       NH,NW)   HIT NO, WIRE NO.
 02010   6      COMMON/CZTRK /RZTRK(5,100),IZTRK(3,2,100), RRTRK(2,100)
 02200    C*****              RZTRK(*,NTR)      ZI1,PHI1,ZI2,PHI2,TANTH
 02300    C                                         FOR TRACK NUMBER NTR
 02400    C                   IZTRK(*,          IM(=1,-DZ,=2,+DZ),NH,NW
 02500    C                           IL,       LAYER(=1,INNER,=2,OUTER)
 02600    C                              NTR)   TRACKNO
 02650    C*****              RRTRK(*,   NTR)   RI1, RI2 FOR TRACK NTR
 02700    C
 02710   7      LOGICAL FIRST / .TRUE. /
 02720
 02800   8      IF NEVT.NE.NEVTLS .OR. NRUN.NE.NRUNLS
 02900   9      THEN
 03000  12         IF FIRST
 03100  13         THEN
 03110  16            FIRST = .FALSE.
 03200  17            WRITE(6,1111)
 03300  181111    FORMAT(' Z-CHAMBER HITS ARE USED IN FITTING WITH ZSRFTV ')
 03400  19         CIF
 03500  20         NEVTLS=NEVT
 03600  21         NRUNLS=NRUN
 03700  22         CALL ZCDATA(NTPAT,NZHT,NASS1,NASS2,JZERR)
 03800  23      CIF
 03900    C
 04000  24      NZHIT=0
 04100  25      IF(JZERR.NE.0) RETURN
 04200  27      IMIR=IZTRK(1,1,ITRK)
 04300  28      IF IMIR.GT.0
 04400  29      THEN
 04500  32         IHT=IZTRK(2,1,ITRK)
 04600  33         IWR=IZTRK(3,1,ITRK)
 04700  34         PHI=RZTRK(2,ITRK)
 04800    CCC      RR=(RZTRK(1,ITRK)-ZVERT)/TGTH
 04804  35         RR = RRTRK(1,ITRK)
 04900  36         XX=RR*COS(PHI)
 05000  37         YY=RR*SIN(PHI)
 05100  38         ZZ=RZDATA(IMIR,IHT,IWR)-13.77
 05200  39         IF XX.LT.0.
 05300  40         THEN
 05400  43            IF ZZ.LT.-270.
 05500  44            THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 05600  47               ZZ=ZZ-10.9-1.0414E-2*(ZZ+270.)+7.93616E-6*(ZZ+270.)**2
 05700  48            ELSE
 05800  50               ZZ=ZZ-10.9+1.98198E-2*(ZZ+270.)-5.13690E-6*(ZZ+270.)**2
 05900  51            CIF
 06000  52            IF NRUN.LT.24200
 06100  53            THEN
 06200  56               IF ZZ.LT.-270.
 06300  57               THEN
 06400  60                  ZZ=ZZ+9.2+5.25E-3*(ZZ+270.)
 06500  61               ELSE
 06600  63                  ZZ=ZZ+9.2-1.49E-2*(ZZ+270.)+5.1E-6*(ZZ+270.)**2
 06700  64               CIF
 06800  65               ZZ=ZZ-4.7E-2+9.87E-5*ZZ
 06900  66            CIF
 07000  67         ELSE
 07100  69            IF ZZ.LT.-270.
 07200  70            THEN
 07300  73               ZZ=ZZ-2.995-3.42774E-3*(ZZ+270.)+1.3112E-5*(ZZ+270.)**2
 07400  74            ELSE
 07500  76               ZZ=ZZ-2.995+7.2565E-3*(ZZ+270.)
 07600  77            CIF
 07700  78            IF NRUN.GE.24200
 07800  79            THEN
 07900  82               ZZ=ZZ+1.-2.8E-3*ZZ
 08000  83               ZZ=ZZ-.076+2.67E-4*ZZ
 08100  84            ELSE
 08200  86               IF NRUN.GE.20275
 08300  87               THEN
 08400  90                  IF ZZ.LT.0.
 08500  91                  THEN
 08600  94                     ZZ=ZZ-8.09E-3*ZZ-4.5E-6*ZZ**2
 08700  95                  ELSE
 08800  97                     ZZ=ZZ-8.09E-3*ZZ+5.85E-6*ZZ**2
 08900  98                  CIF
 09000  99               ELSE
 09100 101                  IF ZZ.LT.480.
 09200 102                  THEN
 09300 105                     ZZ=ZZ+7.75-1.367E-2*ZZ-1.309E-5*ZZ**2
 09400 106                  ELSE
 09500 108                     ZZ=ZZ-1.34+2.556E-2*(ZZ-500.)-4.25E-5*(ZZ-500.)**2
 09600 109                  CIF
 09700 110               CIF
 09800 111               ZZ=ZZ-.085+1.59E-4*ZZ
 09900 112            CIF
 10000 113         CIF
 10100 114         NZHIT=NZHIT+1
 10200 115         IZCHMB(1,NZHIT)=IWR
 10300 116         IZCHMB(2,NZHIT)=1
 10400 117         IZCHMB(3,NZHIT)=IMIR
 10500 118         AZCHMB(1,NZHIT)=XX
 10600 119         AZCHMB(2,NZHIT)=YY
 10700 120         AZCHMB(3,NZHIT)=ZZ
 10800 121      CIF
 10900 122      IMIR=IZTRK(1,2,ITRK)
 11000 123      IF IMIR.GT.0
 11100 124      THEN
 11200 127         IHT=IZTRK(2,2,ITRK)
 11300 128         IWR=IZTRK(3,2,ITRK)
 11400 129         PHI=RZTRK(4,ITRK)
 11500    CC       RR=(RZTRK(3,ITRK)-ZVERT)/TGTH
 11511 130         RR = RRTRK(2,ITRK)
 11600 131         XX=RR*COS(PHI)
 11700 132         YY=RR*SIN(PHI)
 11800 133         ZZ=RZDATA(IMIR,IHT,IWR)-14.06
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 11900 134         IF XX.LT.0.
 12000 135         THEN
 12100 138            IF ZZ.LT.-270.
 12200 139            THEN
 12300 142               ZZ=ZZ-10.9-1.0414E-2*(ZZ+270.)+7.93616E-6*(ZZ+270.)**2
 12400 143            ELSE
 12500 145               ZZ=ZZ-10.9+1.98198E-2*(ZZ+270.)-5.13690E-6*(ZZ+270.)**2
 12600 146            CIF
 12700 147            IF NRUN.LT.24200
 12800 148            THEN
 12900 151               IF ZZ.LT.-270.
 13000 152               THEN
 13100 155                  ZZ=ZZ+9.2+5.25E-3*(ZZ+270.)
 13200 156               ELSE
 13300 158                  ZZ=ZZ+9.2-1.49E-2*(ZZ+270.)+5.1E-6*(ZZ+270.)**2
 13400 159               CIF
 13500 160               ZZ=ZZ+4.7E-2-9.87E-5*ZZ
 13600 161            CIF
 13700 162         ELSE
 13800 164            IF ZZ.LT.-270.
 13900 165            THEN
 14000 168               ZZ=ZZ-2.995-3.42774E-3*(ZZ+270.)+1.3112E-5*(ZZ+270.)**2
 14100 169            ELSE
 14200 171               ZZ=ZZ-2.995+7.2565E-3*(ZZ+270.)
 14300 172            CIF
 14400 173            IF NRUN.GE.24200
 14500 174            THEN
 14600 177               ZZ=ZZ+1.-2.8E-3*ZZ
 14700 178               ZZ=ZZ+.076-2.67E-4*ZZ
 14800 179            ELSE
 14900 181               IF NRUN.GE.20275
 15000 182               THEN
 15100 185                  IF ZZ.LT.0.
 15200 186                  THEN
 15300 189                     ZZ=ZZ-8.09E-3*ZZ-4.5E-6*ZZ**2
 15400 190                  ELSE
 15500 192                     ZZ=ZZ-8.09E-3*ZZ+5.85E-6*ZZ**2
 15600 193                  CIF
 15700 194               ELSE
 15800 196                  IF ZZ.LT.480.
 15900 197                  THEN
 16000 200                     ZZ=ZZ+7.75-1.367E-2*ZZ-1.309E-5*ZZ**2
 16100 201                  ELSE
 16200 203                     ZZ=ZZ-1.34+2.556E-2*(ZZ-500.)-4.25E-5*(ZZ-500.)**2
 16300 204                  CIF
 16400 205               CIF
 16500 206               ZZ=ZZ+.085-1.59E-4*ZZ
 16600 207            CIF
 16700 208         CIF
 16800 209         NZHIT=NZHIT+1
 16900 210         IZCHMB(1,NZHIT)=IWR
 17000 211         IZCHMB(2,NZHIT)=2
 17100 212         IZCHMB(3,NZHIT)=IMIR
 17200 213         AZCHMB(1,NZHIT)=XX
 17300 214         AZCHMB(2,NZHIT)=YY
 17400 215         AZCHMB(3,NZHIT)=ZZ
 17500 216      CIF
 17600 217      RETURN
 17700 218      END
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         217 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         217 TARGET STATEMENTS
 00000    C   27/11/80 309201618  MEMBER NAME  ORZRFITO (FITSR)       SHELTRAN
 00100   2      SUBROUTINE ZRFITO(INDEX,/IARG1/,/X0/,/Y0/,/Z0/)
 00200    C
 00300    C
 00400    C     INDEX =-1: INITIALIZE FOR NEW EVENT
 00500    C
 00600    C     INDEX = 0: STORES Z-R-KOORDINATES OF TRACKS FROM ORIGIN
 00700    C                TRACK#, Z, R
 00800    C     INDEX = 1: FIT ALL TRACKS SIMULTANEOUSLY
 00900    C
 01000    C
 01100    C
 01200    C     P. STEFFEN 27/11/80
 01300    C
 01400   3      IMPLICIT INTEGER*2 (H)
 01500    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 --------------------------
 01700    C
 00100    C-----------------------------------------------------------------------
 00200    C                            MACRO CJDRCH .... JET CHAMBER CONSTANTS.
 00300    C-----------------------------------------------------------------------
 00310    C
 00400   8      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
 01900    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))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
        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 ------------------
 02200    C
 02300  17      EQUIVALENCE
 02400         ,          (HPCO0 ,HPWRK(17)),(HPCO9 ,HPWRK(18)),(HLDCO ,HPWRK(19))
 02500         ,         ,(HPZR0 ,HPWRK(20)),(HPZR9 ,HPWRK(21)),(HLDZR ,HPWRK(22))
 02600         ,         ,(ICELL ,IDWRK( 1)),(MHIT  ,IDWRK( 2)),(IRING ,IDWRK( 3))
 02700         ,         ,(IERRCD,IDWRK( 4)),(NTRKEL,IDWRK( 5))
 02800    C
 02900  18      DIMENSION HST(200),IPTRZ(40,2),JPTRBK(40)
 03000  19      DIMENSION SUMF(40,5),JTRZF(40),SLTRZ(40)
 03100    C
 03200  20      EQUIVALENCE (ZWZ,IZW)
 03300    C
 03400    C 2000 FORMAT('0CALL ZRFITO(',I2,1X,I6,')')
 03500    C2999 FORMAT(' RETURN FROM ZRFITO(',I2,')')
 03600    C2001 FORMAT(' NTRZ =',I6,/,(1X,7(I6,I5,I6)))
 03700    C2002 FORMAT(' R/Z(',I2,')',/,(1X, 6(I6,2F6.0)))
 03800    C2004 FORMAT(' HST(',I2,')',/(1X,50I2))
 03900  21 2005 FORMAT(' ZRFITO(PST): TRACK',I6,I3,' NOT ACCEPTED')
 04000    C2006 FORMAT('0HST-LOOP',3I6)
 04100    C2008 FORMAT(' PEAK =',3I6,F10.3)
 04200    C2010 FORMAT(' ZRFIT:',I6,2F12.0,/,(I6,5F12.0))
 04300    C2011 FORMAT(' ZRFIT:',I6,4F12.0,2F8.1)
 04400    C2012 FORMAT(' SOPES(FIT):',10F8.3)
 04500    C2013 FORMAT(' R/Z(',I2,') :',I6,2F10.1,/,(1X, 6(F6.1,2F6.0)))
 04600    C
 04700    C     PRINT 2000, INDEX,IARG1
 04800    C
 04900  22      DATA LBINIT /0/
 05000  23      IF LBINIT.EQ.0
 05100  24      THEN
 05200    C
 05400  27         LBINIT = 1                                                      INITIALIZATION: SET BOS-POINTER
 05500  28         IQPATR = IBLN('PATR')
 05600  29         IQJHTL = IBLN('JHTL')
 05700  30      CIF
 05800    C
 05900    C
 06000    C
 06200  31      REPEAT                                                             SELECT DIFFERENT PARTS OF PROGRAM
 06300  32         IF INDEX.LT.0
 06400  33         THEN
 06500                                                                             INDEX =-1 : INITIALIZATION FOR NEW EVENT
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 06700    C                                                                        ----------------------------------------
 06800    C
 06900  36            HPZR0 = IARG1
 07000  37            HPZR9 = IARG1 - 1
 07100  38            HLDZR = 3
 07300  39            NTRZ  = 0                                                    # OF ACCEPTED Z-R TRACKS
 07400  40            XREPEAT
 07500  41         CIF
 07600    C
 07700    C
 07800  42         IF INDEX.EQ.0
 07900  43         THEN
 08000                                                                             INDEX = 0 : STORE Z-R COORDINATES TRACK
 08200    C                                                                        ---------------------------------------
 08300    C
 08400  46            IPZR = HPZR9
 08500    C
 08700  47            NHIT3 = 0                                                    PREPARE GOODNESS LABELS FOR ZRFIT
 08800  48            FOR IP=HPCO0,HPCO9,HLDCO
 09000  49               IF(IWRK(IP+10).GT.1) IWRK(IP+7) = 16                      SET ERROR LABEL FOR Z-R FIT
 09100  51               IF IWRK(IP+7).LT.8
 09200  52               THEN
 09300  55                  IWRK(IPZR+1) = 0
 09400  56                  WRK (IPZR+2) = WRK(IP+6)
 09500  57                  WRK (IPZR+3) = WRK(IP+5)
 09600  58                  NHIT3 = NHIT3 + 1
 09700  59                  IPZR  = IPZR + HLDZR
 09800  60               CIF
 09900  61            CFOR
 10000    C
 10200  63            IF NHIT3.GE.8                                                ACCEPT TRACK IF >7 HITS
 10300  64            THEN
 10400  67               NTRZ = NTRZ + 1
 10600  68               IPTRZ(NTRZ,1) = HPZR9 + 1                                 POINTER TO 1. HIT OF TRACK
 10800  69               IPTRZ(NTRZ,2) = IPZR                                      POINTER TO LAST HIT OF TRACK
 10900  70               JPTRBK(NTRZ)  = IARG1
 11000  71               HPZR9 = IPZR
 11100  72            ELSE
 11200                                                                             TRACK NOT ACCEPTED,
 11400  74               IPTR1 = IARG1                                             RESTORE 1. + LAST POINT + DIRECRECTION
 11500  75               PRINT 2005,IPTR1, IDATA(IPTR1+1)
 11600  76               INDEX =-2
 11700  77            CIF
 11800    C
 11900    C
 12000  78            XREPEAT
 12100  79         CIF
 12200    C
 12300    C
 12400  80         IF INDEX.GT.0
 12500  81         THEN
 12600                                                                             INDEX = 1 : START FITTING OF TRACKS
 12800    C                                                                        ----------------------------------------
 12900    C
 13000    C       PRINT 2001, NTRZ,(IPTRZ(I1,1),IPTRZ(I1,2),JPTRBK(I1),I1=1,NTRZ)
 13100    C       PERFORM PRINT
 13200    C
 13400  84            IF(NTRZ.LE.0) XREPEAT                                        CHECK IF >1 TRACK
 13500    C
 13700  86            IZW = IARG1                                                  GET START VALUE FOR VERTEX
 13800  87            ZVTX0 = ZWZ
 13900    C
 14100  88            ITRZ = 0                                                     LOOP OVER ALL TRACKS + HSTOGRAM HITS
 14200  89            WHILE ITRZ.LT.NTRZ
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 14300  91               ITRZ = ITRZ + 1
 14400    C
 14500  95               IP0 = IPTRZ(ITRZ,1)
 14600  96               IP9 = IPTRZ(ITRZ,2)
 14700    C
 14800                                                                             HSTOGRAM SLOPES
 15000  97               PERFORM HSTSEL                                            AND SELECT HITS CONTRIBUTING TO PEAK
 15100 100            CWHILE
 15200    C
 15300    C       PERFORM PRINT
 15400    C
 15600 102            PERFORM SUPFIT                                               DO SUPERFIT
 15700    C
 15900 105            PERFORM LABEL                                                LABEL BAD HITS
 16000    C       PERFORM PRINT
 16100    C
 16300 108            PERFORM SUPFIT                                               DO SUPERFIT
 16400    C
 16600 111            PERFORM RESBNK                                               LABEL BAD HITS
 16700    C
 16800 114            XREPEAT
 16900 115         CIF
 17000    C
 17100    C
 17200 116      UNTIL .TRUE.
 17300    C
 17400    C     PRINT 2999, INDEX
 17500 117      RETURN
 17600    C
 17700    C
 17800                                                                             *************************
 17900                                                                             *      H S T S E L      *
 18100    C                                                                        *************************
 18200    C
 18300                                                                             HSTOGRAM SLOPES
 18500 121      PROC HSTSEL                                                        AND SELECT HITS CONTRIBUTING TO PEAK
 18600    C
 18700 122         CALL SETSL(HST(1),0,400,0)
 18800 123         SL0   =-7.5
 18900 124         BINSL = .075
 19000 125         BINIV = 1. / BINSL
 19100    C       PRINT 2006, ITRZ,IP0,IP9
 19200 126         FOR IP1=IP0,IP9,3
 19300 127            R1 = WRK(IP1+1)
 19400 128            Z1 = WRK(IP1+2)
 19500 129            SL = (Z1 - ZVTX0) / R1
 19600 130            IBIN = (SL - SL0) * BINIV
 19700 131            IF(IBIN.GT.0 .AND. IBIN.LT.200) HST(IBIN) = HST(IBIN) + 1
 19800 133         CFOR
 19900    C       PRINT 2004, ITRZ,HST
 20000    C
 20100    C
 20300    C                                                                        FIND PEAK IN HSTOGRAMS
 20400    C
 20600 135         IMAX = 1                                                        HSTOGRAM SLOPES OF TRACKS
 20700 136         MHST = HST(1) + HST(2) + HST(3) + HST(4) + HST(5)
 20800 137         NHST = MHST
 20900 138         FOR I= 2,196
 21000 139            NHST = NHST + HST(I+4) - HST(I-1)
 21100 140            IF NHST.GT.MHST
 21200 141            THEN
 21300 144               IMAX = I
 21400 145               MHST = NHST
 21500 146            CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 21600 147         CFOR
 21700    C       PRINT 2008, MHST,IMAX
 21800    C
 22000 149         IF MHST.LT.5                                                    DETEMIN AV. SLOPE
 22100 150         THEN
 22200 153            SLP = 1000.
 22300 154         ELSE
 22400 156            ISL = HST(IMAX+1) + HST(IMAX+2)*2 + HST(IMAX+3)*3
 22500         +      + HST(IMAX+4)*4
 22600 157            SLP = (FLOAT(ISL) / MHST + IMAX + .5) * BINSL + SL0
 22700 158         CIF
 22800    C       PRINT 2008, MHST,IMAX,ISL,SLP
 22900    C
 23100 159         FOR IP1=IP0,IP9,3                                               LABEL GOOD + BAD HITS
 23200 160            R1 = WRK(IP1+1)
 23300 161            Z1 = WRK(IP1+2)
 23400 162            F1 = R1*SLP + ZVTX0
 23500 163            DF = F1 - Z1
 23600 164            IF ABS(DF).LT.80.
 23700 165            THEN
 23800 168               IWRK(IP1) = 0
 23900 169            ELSE
 24000 171               IWRK(IP1) = 16
 24100 172            CIF
 24200 173         CFOR
 24300    C
 24400 175      CPROC
 24500    C
 24600                                                                             *************************
 24700                                                                             *      S U P F I T      *
 24900    C                                                                        *************************
 25000    C
 25200 177      PROC SUPFIT                                                        FIT ALL TRACKS FROM VERTEX SIMULTANEOUSLY
 25300    C
 25500 178         ITRZ = 0                                                        LOOP OVER ALL TRACKS + HSTOGRAM HITS
 25600 179         MTRZ = 0
 25700 180         SUM0 = 0.
 25800 181         SUM4 = 0.
 25900 182         WHILE ITRZ.LT.NTRZ
 26000 184            ITRZ = ITRZ + 1
 26100    C
 26200                                                                             LOOP OVER ALL HITS
 26400 188            IP0 = IPTRZ(ITRZ,1)                                          POINTER OF TRACK HITS
 26500 189            IP9 = IPTRZ(ITRZ,2)
 26700 190            S1 = 0.                                                      ZERO SUMS
 26800 191            S2 = 0.
 26900 192            S3 = 0.
 27000 193            S4 = 0.
 27100 194            S5 = 0.
 27200 195            FOR IP1=IP0,IP9,3
 27300 196               IF IWRK(IP1).EQ.0
 27400 197               THEN
 27500 200                  R1 = WRK(IP1+1)
 27600 201                  Z1 = WRK(IP1+2)
 27700 202                  S1 = 1.    + S1
 27800 203                  S2 = R1    + S2
 27900 204                  S3 = R1*R1 + S3
 28000 205                  S4 = Z1    + S4
 28100 206                  S5 = Z1*R1 + S5
 28200 207               CIF
 28300 208            CFOR
 28400    C
 28600 210            IF S1.LT.7.5                                                 CHECK IF >7 HITS ACCEPTED
 28700 211            THEN
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 28900 214               JTRZF(ITRZ) = 0                                           BAD TRACK, IGNAORE
 29000 215            ELSE
 29200 217               MTRZ = MTRZ + 1                                           REGISTER SUMS
 29300 218               JTRZF(ITRZ) = MTRZ
 29400 219               SUM0 = SUM0 + S1
 29500 220               SUM4 = SUM4 + S4
 29600 221               SUMF(MTRZ,1) = S1
 29700 222               SUMF(MTRZ,2) = S2
 29800 223               SUMF(MTRZ,3) = S3
 29900 224               SUMF(MTRZ,4) = S4
 30000 225               SUMF(MTRZ,5) = S5
 30100 226            CIF
 30200 227         CWHILE
 30300    C     PRINT 2010,MTRZ,SUM0,SUM4,(I,(SUMF(I,J),J=1,5),I=1,MTRZ)
 30400    C
 30600 229         IF MTRZ.GT.0                                                    CHECK IF ANY TRACKS
 30700 230         THEN
 30800    C
 31000 233            S0 = 0.                                                      GENERAL VERTEX
 31100 234            S4 = 0.
 31200 235            FOR I=1,MTRZ
 31300 236               S0 = SUMF(I,2)**2 / SUMF(I,3)        + S0
 31400 237               S4 = SUMF(I,5)*SUMF(I,2) / SUMF(I,3) + S4
 31500 238            CFOR
 31600 240            S0 = SUM0 - S0
 31700 241            S4 = SUM4 - S4
 31800 242            ZVFIT = S4 / S0
 31900    C         PRINT 2011,MTRZ,SUM0,SUM4,S0,S4,ZVFIT,ZVTX0
 32000    C
 32200 243            FOR I=1,MTRZ                                                 SLOPES OF TRACKS
 32300 244               SLTRZ(I) = (-SUMF(I,2)*ZVFIT + SUMF(I,5)) / SUMF(I,3)
 32400 245            CFOR
 32500    C         PRINT 2012, (SLTRZ(I),I=1,MTRZ)
 32600    C
 32700 247         CIF
 32800    C
 32900 248      CPROC
 33000    C
 33100                                                                             *************************
 33200                                                                             *      L A B E L        *
 33400    C                                                                        *************************
 33500    C
 33700 250      PROC LABEL                                                         LABEL HITS NOT BELONGING TO TRACK
 33800    C
 33900 251         ITRZ = 0
 34000 252         WHILE ITRZ.LT.NTRZ
 34100 254            ITRZ = ITRZ + 1
 34200 258            JTRZ = JTRZF(ITRZ)
 34400 259            IF JTRZ.GT.0                                                 CHECK IF ACC. TRACK
 34500 260            THEN
 34600 263               SLP  = SLTRZ(JTRZ)
 34800 264               IP0 = IPTRZ(ITRZ,1)                                       POINTER OF TRACK HITS
 34900 265               IP9 = IPTRZ(ITRZ,2)
 35000    C
 35200 266               FOR IP1=IP0,IP9,3                                         LABEL GOOD + BAD HITS
 35300 267                  R1 = WRK(IP1+1)
 35400 268                  Z1 = WRK(IP1+2)
 35500 269                  F1 = R1*SLP + ZVFIT
 35600 270                  DF = F1 - Z1
 35700 271                  IF ABS(DF).LT.80.
 35800 272                  THEN
 35900 275                     IWRK(IP1) = 0
 36000 276                  ELSE
 36100 278                     IWRK(IP1) = 16
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 36200 279                  CIF
 36300 280               CFOR
 36400    C
 36500 282            CIF
 36600    C
 36700 283         CWHILE
 36800    C
 36900 285      CPROC
 37000    C
 37100                                                                             *************************
 37200                                                                             *      R E S B N K      *
 37400    C                                                                        *************************
 37500    C
 37700 287      PROC RESBNK                                                        FILL RESULT BANK
 37800    C
 37900 288         ITRZ = 0
 38000 289         WHILE ITRZ.LT.NTRZ
 38100 291            ITRZ = ITRZ + 1
 38200 295            JTRZ = JTRZF(ITRZ)
 38400 296            IF JTRZ.LE.0                                                 CHECK IF ACCEPTED TRACK
 38500 297            THEN
 38700 300               IPTR1 = JPTRBK(ITRZ)                                      RESTORE 1. + LAST POINT + DIRECTION
 38800    C     PRINT 2007,IPTR1, IDATA(IPTR1+1)
 38900    C2007 FORMAT(' TRACK',I6,I3,' NOT FITTED')
 39000 301               TGTH = ADATA(IPTR1+30)
 39100 302               Z0TR = ADATA(IPTR1+31)
 39200 303               CSTH = 1./SQRT(TGTH**2+1.)
 39300 304               SNTH = CSTH * TGTH
 39400 305               ADATA(IPTR1+ 8) = ADATA(IPTR1+ 8) * CSTH
 39500 306               ADATA(IPTR1+ 9) = ADATA(IPTR1+ 9) * CSTH
 39600 307               ADATA(IPTR1+15) = ADATA(IPTR1+15) * CSTH
 39700 308               ADATA(IPTR1+16) = ADATA(IPTR1+16) * CSTH
 39800 309               ADATA(IPTR1+17) = SNTH
 39900 310               ADATA(IPTR1+ 7) = ADATA(IPTR1+ 7) * TGTH + Z0TR
 40000 311               ADATA(IPTR1+14) = ADATA(IPTR1+14) * TGTH + Z0TR
 40100 312            ELSE
 40200 314               SLP  = SLTRZ(JTRZ)
 40400 315               IPTR1 = JPTRBK(ITRZ)                                      POINTER TO TRACK ARRAY IN 'PATR'
 40600 316               IP0 = IPTRZ(ITRZ,1)                                       POINTER OF TRACK HITS
 40700 317               IP9 = IPTRZ(ITRZ,2)
 40800    C
 41000 318               S1 = 0.                                                   CALC. RESIDUA + SUM CHISQ.
 41100 319               FOR IP1=IP0,IP9,3
 41200 320                  R1 = WRK(IP1+1)
 41300 321                  Z1 = WRK(IP1+2)
 41400 322                  F1 = R1*SLP + ZVFIT
 41500 323                  DF = F1 - Z1
 41700 324                  IF(IWRK(IP1).EQ.0) S1 = DF**2 + S1                     SUM CHISQ
 41800 326                  WRK(IP1) = DF
 41900 327               CFOR
 42100 329               MHT = SUMF(JTRZ,1)                                        SIGMA
 42200 330               SIG = SQRT(S1 / (MHT-1))
 42300    C           PRINT 2013, ITRZ,MHT,SIG,S1,(WRK(I1),I1=IP0,IP9)
 42400    C
 42600 331               CSTH = 1./SQRT(SLP**2+1.)                                 SET NEW PARAMETERS IN 'PATR'-BANK
 42700 332               SNTH = CSTH * SLP
 42800 333               RVTX = ADATA(IPTR1+17)
 42900 334               ADATA(IPTR1+ 7) = ADATA(IPTR1+ 7)*SLP + ZVFIT
 43000 335               ADATA(IPTR1+14) = ADATA(IPTR1+14)*SLP + ZVFIT
 43100 336               ADATA(IPTR1+ 8) = ADATA(IPTR1+ 8)*CSTH
 43200 337               ADATA(IPTR1+ 9) = ADATA(IPTR1+ 9)*CSTH
 43300 338               ADATA(IPTR1+10) = SNTH
 43400 339               ADATA(IPTR1+15) = ADATA(IPTR1+15)*CSTH
 43500 340               ADATA(IPTR1+16) = ADATA(IPTR1+16)*CSTH
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 43600 341               ADATA(IPTR1+17) = SNTH
 43700 342               IDATA(IPTR1+29) = 1
 43800 343               ADATA(IPTR1+30) = SLP
 43900 344               ADATA(IPTR1+31) = RVTX*SLP + ZVFIT
 44000 345               ADATA(IPTR1+32) = SIG
 44100 346               IDATA(IPTR1+33) = MHT
 44200 347               IDATA(IPTR1+ 2) = LOR(IDATA(IPTR1+ 2),64)
 44300 348               IDATA(IPTR1+ 4) = LOR(IDATA(IPTR1+ 4),64)
 44400    C
 44500 349            CIF
 44600    C
 44700 350         CWHILE
 44800    C
 44900 352      CPROC
 45000    C
 45100    C
 45200    C     PROC PRINT
 45300    C       FOR ITRZ = 1,NTRZ
 45400    C         IP0 = IPTRZ(ITRZ,1)
 45500    C         IP9 = IPTRZ(ITRZ,2)
 45600    C         PRINT 2002, ITRZ,(WRK(I1),I1=IP0,IP9)
 45700    C       CFOR
 45800    C     CPROC
 45900    C
 46000 354      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         353 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         353 TARGET STATEMENTS
 00000    C   09/06/83 806271304  MEMBER NAME  ZSRFTV   (JADEGS)      SHELTRAN
 00100    C   09/06/83 803181238  MEMBER NAME  ZSRFTV   (S)           SHELTRAN
 00200   2      SUBROUTINE ZSRFTV(MODE,IOPT)
 00300    C-----------------------------------------------------------------------
 00400    C                                   J. SPITZER 22/4/87
 00500    C                    UPDATED TO GIVE COMMON Z    1/6/87  J.S.
 00510    C    16.5.88 ARSIN ARG PROTECTION ADDED E.E.
 00511    C    13.5.88 (FRIDAY!) SEVERE BUG CORRECTED IN SEVERAL PLACES J.H./J.O.
 00520    C            ARSIN INSTEAD OF SIN
 00600    C    18.3.88   PROPER RUN NUMBER HANDLING USING LDATYP      E E
 00700    C    22.2.88   MVC CHANGED TO MVCL (256 BYTES NOT ENOUGH!)  J.H./J.O.
 00800    C
 00900    C       A GENERAL S-Z FIT ROUTINE
 01000    C       S = TRACK LENGTH ALONG THE CIRCLE COUNTED FROM THE
 01100    C           FIRST POINT IN THE DIRECTION OF THE LAST ONE
 01200    C
 01300    C      MODE   = 0 : OVERWRITE OLD PATR-BANK WITH NEW RESULTS
 01400    C      MODE   = 1 : CREATE NEW PATR-BANK WITH NEW RESULTS
 01500    C
 01600    C      IOPT =   1 : S-Z FIT SEPARATELY FOR ALL TRACKS
 01700    C      IOPT =   2 : S-Z FIT SEPARATELY FOR ALL TRACKS AND SUBSEQUENTLY
 01800    C                   A COMMON S-Z FIT FOR THOSE ONES WHICH
 01900    C                   EXTRAPOLATE WITHIN 15 MM TO THE RUN VERTEX IN R-PHI
 02000    C                   AND HAVE  | Z(R=0) | < 800 MM
 02100    C      *****************************************************************
 02200    C      *  THE FOLLOWIG OPTION NEEDS FILLING OF A COMMON IN ADDITION !!!*
 02300    C      *****************************************************************
 02400    C      IOPT =   4 : COMMON S-Z FITS FOR USER SPECIFIED (UPTO 5) SETS
 02500    C                   OF TRACKS WITH USER SPECIFIED COMMON (X,Y) POINTS
 02600    C                   IN R-PHI (OR SINGLE TRACK S-Z FIT, SEE LATER).
 02700    C                   THE SINGLE TRACK S-Z FITS ARE ONLY DONE FOR THOSE
 02800    C                   TRACKS WHICH APPEAR IN THE SETS.
 02900    C                   IF A TRACK IS NOT WITHIN 15 MM TO THE SPECIFIED
 03000    C                   (X,Y) POINT OR | Z(X,Y) | > 1600 MM, IT WILL BE
 03100    C                   DISCARDED.
 03200    C
 03300    C    TRACK SELECTION PARAMETERS FOR COMMON Z FIT ARE IN /CCMZCT/
 03400    C
 03500    C    ( IOPT <= IOPT+8 CREATES A SPECIAL BANK IN ADDITION )
 03510    C
 03520    C    For details of the parameter setting see:
 03530    C    JCN 95, p.1 and addendum p.7
 03540    C    JCN 95, supplement 1, p.3
 03550    C
 03600    C
 03700    C-----------------------------------------------------------------------
 03800    C
 03900   3      IMPLICIT INTEGER*2 (H)
 04000    C
 04100    C-----------------------------------------------------------------------
 04200    C *****************************************************************
 04300    C *  THE COMMON TO BE FILLED BY THE USER IF IOPT=4 IS REQUESTED   *
 04400    C *****************************************************************
 04500    C
 04600   4      COMMON/CZSSTE/ NSETZS,NTSTZS(5),KTSTZS(100,2,5),XYSTZS(2,5),
 04700         +SQCHZS(3,5)
 04800    C
 04900    C NSETZS : NUMBER OF TRACK SETS FOR WHICH COMMON FIT IS TO BE DONE
 05000    C NTSTZS(1..NSETZS) : NUMBER OF TRACKS IN EACH SET
 05100    C KTSTZS(1..,1,I) TRACK SEQUENCE NUMBERS FOR SET "I"
 05200    C XYSTZS(1,I), XYSTZS(2,I) : COMMON X,Y FOR SET "I"
 05300    C
 05400    C FOR SINGLE TRACK FIT PLEASE SET     NSETZS=1, NTSTZS(1)=1,
 05500    C                                     KTSTZS(1,1,1)=ITRK (TR. SEQ. NR.)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 05600    C                              NOTHING ELSE NEEDS TO BE SET.
 05700    C
 05800    C  ***********
 05900    C  * ON EXIT *
 06000    C  ***********
 06100    C
 06200    C  KTSTZS(.,2,.)  IS A FLAG THAT TELLS YOU:
 06300    C       2 : TRACK WAS USED IN A COMMON Z-FIT
 06400    C       1 : SINGLE TRACK FIT WAS SUCCESSFUL BUT
 06500    C           THE TRACK WAS NOT USED IN A COMMON FIT
 06600    C       0 : TRACK WAS NOT CONSIDERED FOR REFIT
 06700    C      <0 : SINGLE TRACK FIT FAILED (TOO FEW USABLE HITS IN GENERAL)
 06800    C
 06900    C  THIS INFORMATION IS PROVIDED FOR IOPT=1 AND 2 AS WELL BUT
 07000    C  WITHOUT FILLING  KTSTZS(J,1,.)=J
 07100    C
 07200    C  SQCHZS(1,.) : SQUARE ROOT OF {SUM OF WEIGHTED RESIDUAL SQUARES
 07300    C                DIVIDED BY THE NUMBER OF DEGREES OF FREEDOM (LATTER=
 07400    C                NHITS-NTRACKS-1)} FOR COMMON FIT (.)
 07500    C                OR 0.0 IF NO COMMON FIT WAS PERFORMED.
 07600    C                THE (DIFFERENT FOR DL8 AND FADC) NORMALIZATION
 07700    C                TO GET THE CHI**2/DOF. IS LEFT FOR THE USER
 07800    C  SQCHZS(2,.) : NUMBER OF HITS USED IN THE COMMON FIT OR 0.0; REAL !!!
 07900    C  SQCHZS(3,.) : COMMON Z AT THE COMMON (X,Y)    (OR 0.0)
 08000    C
 08100   5      COMMON/CCMZCT/ DIMPCT, ZCUTV, ZCUTVV, IZVCST(5)
 08200    C
 08300    C THIS COMMON IS BLOCK DATA SET IN   JADEBD
 08400    C
 08500    C     BLOCK DATA
 08600    C     COMMON/CCMZCT/ DIMPCT, ZCUTV, ZCUTVV, IZVCST(5)
 08700    C     DATA  DIMPCT /15./, ZCUTV /800./, ZCUTVV /1600./, IZVCST/5*0/
 08800    C     END
 08900    C=======================================================================
 09000    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
         6      COMMON /BCS/ IDATA(40000)
         7      DIMENSION HDATA(80000),ADATA(40000),IPNT(50)
         8      EQUIVALENCE (HDATA(1),IDATA(1),ADATA(1)),(IPNT(1),IDATA(55))
         9      EQUIVALENCE (NWORD,IPNT(50))
          C
          C------------------------ END OF MACRO CDATA --------------------------
          C----------------------------------------------------------------------
          C            MACRO CALIBR .... JADE CALIBRATION DATA COMMON
          C----------------------------------------------------------------------
        10      COMMON/CALIBR/ ACALIB(1000)
        11      DIMENSION HCALIB(100),ICALIB(100)
 02600  12      EQUIVALENCE(ACALIB(1),HCALIB(1),ICALIB(1))
          C------------------------ END OF MACRO CALIBR -------------------------
 09300    C
 09400  13      COMMON/CWORK/NDIWRK,WRK(20000)
 09500  14      DIMENSION IWRK(20000),HWRK(40000)
 09600  15      EQUIVALENCE (WRK(1),IWRK(1),HWRK(1))
 09700    C
 09800  16      INTEGER ITRREQ(100)
 09900  17      REAL CORTRC(2,100)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 10000  18      DATA LBINIT /0/, IQPATR/0/, IQJHTL/0/, IQHEAD/0/, IQJETC/0/
 10100  19      DATA NPRLIM/50/,KPRLIM/0/
 10200    C=======================================================================
 10300    C
 10400  20      KOPT=IOPT
 10500  21      IF(KOPT.GT.8) KOPT=KOPT-8
 10600  23      IF KOPT.NE.1 .AND. KOPT.NE.2 .AND. KOPT.NE.4
 10700  24      THEN
 10800  27         IF KPRLIM.LT.NPRLIM
 10900  28         THEN
 11000  31            KPRLIM=KPRLIM+1
 11100  32            WRITE(6,100) IOPT
 11200  33100         FORMAT(' **** ZSRFTV CALLED WITH INVALID OPTION :',I8)
 11300  34         CIF
 11400  35         RETURN
 11500  36      CIF
 11600    C
 11700    C
 11800  37      IF KOPT.EQ.4
 11900  38      THEN
 12000    C PRODUCE ARRAY OF ALL TRACKS REQUESTED; CHECK CONSISTENCY OF REQUEST
 12100  41         IF NTSTZS(1).EQ.1
 12200  42         THEN
 12300  45            KTC=KTSTZS(1,1,1)
 12400  46            IF KTC.LT.1 .OR. KTC.GT.100
 12500  47            THEN
 12600  50               LINCON=1
 12700  51            ELSE
 12800  53               LINCON=0
 12900  54               NTRREQ=1
 13000  55               ITRREQ(1)=KTC
 13100  56               KTSTZS(1,2,1)=0
 13200  57            CIF
 13300  58         ELSE
 13400  60            IF NSETZS.GE.1.AND.NSETZS.LE.5
 13500  61            THEN
 13600  64               NTRREQ=0
 13700  65               LINCON=0
 13800  66               FOR ISET=1,NSETZS
 13900  67                  SQCHZS(1,ISET)=0.
 14000  68                  SQCHZS(2,ISET)=0.
 14100  69                  SQCHZS(3,ISET)=0.
 14200  70                  NTSETI=NTSTZS(ISET)
 14300  71                  IF NTSETI.LT.2 .OR. NTSETI.GT.100
 14400  72                  THEN
 14500  75                     LINCON=1
 14600  76                     XFOR
 14700  77                  CIF
 14800  78                  FOR JT=1,NTSETI
 14900  79                     KTC=KTSTZS(JT,1,ISET)
 15000  80                     IF KTC.LT.1 .OR. KTC.GT.100
 15100  81                     THEN
 15200  84                        LINCON=1
 15300  85                        XFOR
 15400  86                     CIF
 15500  87                     KTSTZS(JT,2,ISET)=0
 15600  88                     LPRES=0
 15700  89                     IF NTRREQ.GT.0
 15800  90                     THEN
 15900  93                        FOR J=1,NTRREQ
 16000  94                           IF ITRREQ(J).EQ.KTC
 16100  95                           THEN
 16200  98                              LPRES=1
 16300  99                              XFOR
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 16400 100                           CIF
 16500 101                        CFOR
 16600 103                     CIF
 16700 104                     IF LPRES.EQ.0
 16800 105                     THEN
 16900 108                        IF NTRREQ.EQ.100
 17000 109                        THEN
 17100 112                           LINCON=1
 17200 113                           XFOR
 17300 114                        CIF
 17400 115                        NTRREQ=NTRREQ+1
 17500 116                        ITRREQ(NTRREQ)=KTC
 17600 117                     CIF
 17700 118                  CFOR
 17800 120                  IF(LINCON.NE.0) XFOR
 17900 122               CFOR
 18000 124            ELSE
 18100 126               LINCON=1
 18200 127            CIF
 18300 128         CIF
 18400 129         IF LINCON.NE.0
 18500 130         THEN
 18600 133            IF KPRLIM.LT.NPRLIM
 18700 134            THEN
 18800 137               KPRLIM=KPRLIM+1
 18900 138               WRITE(6,200)
 19000 139200            FORMAT(' **** ZSRFTV: INVALID REQUEST IN /CZSSTE/')
 19100 140            CIF
 19200 141            RETURN
 19300 142         CIF
 19400 143      ELSE
 19500 145         SQCHZS(1,1)=0.
 19600 146         SQCHZS(2,1)=0.
 19700 147         SQCHZS(3,1)=0.
 19800 148         FOR J=1,100
 19900 149            KTSTZS(J,2,1)=0
 20000 150         CFOR
 20100 152      CIF
 20200    C-----------------------------------------------------------------------
 20400 153      IF LBINIT .LE.0                                                    INITIALIZATION
 20500 154      THEN
 20600 157         LBINIT = 1
 20700 158         IQPATR = IBLN('PATR')
 20800 159         IQJHTL = IBLN('JHTL')
 20900 160         IQHEAD = IBLN('HEAD')
 21000 161         IQJETC = IBLN('JETC')
 21100 162      CIF
 21200    C
 21300    C-----------------------------------------------------------------------
 21400    C
 21600 163      IF(IDATA(IQPATR).LE.0) RETURN                                      CHECK IF PATR-BANK
 21700    C-----------------------------------------------------------------------
 21800    C
 21900    C     CREATE NEW PATR BANK IF REQUESTED
 22000 165      IF MODE.EQ.1
 22100 166      THEN
 22200 169         IPPAT0 = IDATA(IQPATR)
 22300 170         NBNK1  = IDATA(IPPAT0-2) - 1
 22400 171         NWRD   = IDATA(IPPAT0)
 22500 172         NBYTE  = NWRD*4
 22600 173         CALL CCRE(IPPATR,'PATR',NBNK1,NWRD,IERR)
 22700 174         IF IERR.NE.0
 22800 175         THEN
 22900 178            PRINT 2900, IERR
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 23000 179 2900       FORMAT(' CREATION OF NEW PATR-BANK RESULTED IN ERROR',I3)
 23100 180            RETURN
 23200 181         CIF
 23400 182         CALL MVCL(IDATA(IPPATR+1),0,IDATA(IPPAT0+1),0,NBYTE)            COPY CONTENTS OF 'PATR'-BANK
 23500 183      CIF
 23600    C-----------------------------------------------------------------------
 23700    C
 23800 184      IPPATR = IDATA(IQPATR)
 23900 185      IPTR   = IDATA(IPPATR+1) + IPPATR
 24000 186      LDTR   = IDATA(IPPATR+3)
 24100 187      NTR    = IDATA(IPPATR+2)
 24200    C
 24400 188      IF(NTR.LT.1) RETURN                                                CHECK IF 1 TRACK
 24500    C
 24600 190      IF NTR.GT.100
 24700 191      THEN
 24800 194         IF KPRLIM.LT.NPRLIM
 24900 195         THEN
 25000 198            KPRLIM=KPRLIM+1
 25100 199            WRITE(6,300) NTR
 25200 200300         FORMAT(' **** ZSRFTV : NUMBER OF TRACKS IN PATR BANK :',
 25300         +      I4,'. FIRST 100 WILL BE CONSIDERED.')
 25400 201         CIF
 25500 202         NTR=100
 25600 203      CIF
 25700    C
 25800    C-----------------------------------------------------------------------
 25900    C
 26000    C GET LATEST AMPLITUDE CALIBRATION
 26100 204      CALL JRECAL(IERR)
 26200 205      IF IERR.NE.0
 26300 206      THEN
 26400 209         PRINT 6784,IERR
 26500 210 6784    FORMAT(' *** ERROR IN JRECAL',I3)
 26600 211         RETURN
 26700 212      CIF
 26800    C-----------------------------------------------------------------------
 26900    C
 27100 213      IPJETC = IDATA(IQJETC)                                             RECALIBRATE Z-COORDINATES
 27200 214      IPJHTL = IDATA(IQJHTL)
 27300    C
 27400    C MODEZ=1 MEANS    CALIBRATION ONLY
 27500    C
 27600 215      MODEZ  = 1
 27700 216      CALL ZSFIT(IPJETC,IDATA(IPJETC-1),IPJHTL,IPPATR,MODEZ)
 27800    C
 27900    C
 28000    C=======================================================================
 28100    C
 28200    C     COLLECTION OF HIT DATA IN /CWORK/ AND SINGLE TRACK FITS
 28300    C
 28400    C DIMENSION OF WRK(.)
 28500 217      NDIWRK=20000
 28600    C NUMBER OF TRACKS STORED IN /CWORK/
 28700 218      NTRKS=0
 28800    C POINTER TO TRACK DATA THAT STORES THE STRUCTURE OF WRK(.) ETC.
 28900 219      IDTR2=1
 29000    C LENGTH OF ABOVE DATA PRO TRACK
 29100 220      LDTR2=11
 29200    C LENGTH OF HIT AND SUBSEQUENT TRACK DATA IN /CWORK/
 29300 221      LHIT=8
 29400 222      LTRREC=0
 29500    C POINTER TO FIRST HIT OF TRACK IN /CWORK/
 29600 223      IHIT1=NTR*LDTR2+1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 29700    C
 29800    C
 29900 224      FOR ITR=1,NTR
 30000    C NO SPACE TO STORE MORE TRACKS
 30100 225         IF(IHIT1 .GT. NDIWRK-200-(70*LHIT+LTRREC)) XFOR
 30200    C CHECK IF TRACK CONSIDERED FOR REFIT
 30300 227         IF KOPT.NE.4
 30400 228         THEN
 30500 231            LFIT=1
 30600 232         ELSE
 30700 234            LFIT=0
 30800 235            FOR J=1,NTRREQ
 30900 236               IF ITRREQ(J).EQ.ITR
 31000 237               THEN
 31100 240                  LFIT=1
 31200 241                  XFOR
 31300 242               CIF
 31400 243            CFOR
 31500 245         CIF
 31600 246         IF LFIT.EQ.1
 31700 247         THEN
 31800 250            INDFET = 4
 31900 251            CALL JFETCH(IPTR,IPJHTL,WRK(IHIT1),LHIT,IPRES,INDFET,XD,YD)
 32000 252            NHIT=(IPRES-1)/LHIT
 32100 253            IF NHIT.GT.1
 32200 254            THEN
 32300    C OTHERWISE TRACK IS NOT CONSIDERED FOR REFIT
 32400 257               IPRES=IHIT1+IPRES-1
 32500    C ----------------------------------------------------------------------
 32600    C S-Z FIT FOR SINGLE TRACK; MARK USED HITS
 32700    C IOPT IS PASSED ONLY TO INDICATE WHETHER SPECIAL BANK IS TO BE
 32800    C CREATED (IF IOPT>8)
 32900 258               CALL ZSRFT1(IPTR,LDTR,IHIT1,IPRES,LHIT,IQUAL,IOPT)
 33000    C-----------------------------------------------------------------------
 33100    C
 33200    C SET SINGLE TRACK FIT FLAG IN   KTSTZS(.,2,.)
 33300 259               IF KOPT.EQ.4
 33400 260               THEN
 33500 263                  IF NTSTZS(1).EQ.1
 33600 264                  THEN
 33700    C  S-Z FIT OF A SINGLE TRACK WAS REQUESTED
 33800 267                     KTSTZS(1,2,1)=IQUAL
 33900 268                     RETURN
 34000 269                  ELSE
 34100 270                     FOR ISET=1,NSETZS
 34200 271                        NTSETI=NTSTZS(ISET)
 34300 272                        FOR JT=1,NTSETI
 34400 273                           IF(KTSTZS(JT,1,ISET).EQ.ITR)KTSTZS(JT,2,ISET)=IQUAL
 34500 275                        CFOR
 34600 277                     CFOR
 34700 279                  CIF
 34800 280               ELSE
 34900 282                  KTSTZS(ITR,2,1)=IQUAL
 35000 283               CIF
 35100    C-----------------------------------------------------------------------
 35200 284               IF IQUAL.GT.0 .AND. KOPT.NE.1
 35300 285               THEN
 35400    C STORE TRACK FOR SUBSEQUENT COMMON S-Z FIT
 35500 288                  NTRKS=NTRKS+1
 35600 289                  IWRK(IDTR2  )=ITR
 35700 290                  IWRK(IDTR2+1)=IPTR
 35800    C
 35900 291                  IF(KOPT.EQ.2) IQUAL=2
 36000    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 36100 293                  IWRK(IDTR2+2)=IQUAL
 36200 294                  IWRK(IDTR2+3)=IHIT1
 36300 295                  IWRK(IDTR2+4)=IPRES
 36400    C
 36500 296                  IHIT1=IPRES+LTRREC
 36600 297                  IDTR2=IDTR2+LDTR2
 36700 298               CIF
 36800 299            CIF
 36900 300         CIF
 37000 301         IPTR=IPTR+LDTR
 37100 302      CFOR
 37200    C
 37300    C NO COMMON FIT IS REQUESTED OR POSSIBLE
 37400    C
 37500 304      IF(KOPT.EQ.1.OR.NTRKS.LT.2) RETURN
 37600    C
 37700    C=======================================================================
 37800    C
 37900    C     COMMON S-Z FIT TO RUN VERTEX
 38000    C
 38100    C
 38200 306      IF KOPT.EQ.2
 38300 307      THEN
 38400 310         IRUN=HDATA( 2*IDATA(IQHEAD) + 10)
 38500 311         IF  IRUN.GE.100
 38600 312         THEN
 38700 315            IPV    = ICALIB(10)
 38800 316            XCOMM  = ACALIB(IPV+ 1)
 38900 317            YCOMM  = ACALIB(IPV+ 3)
 39000 318         ELSE
 39100 320            XCOMM  = 0.
 39200 321            YCOMM  = 0.
 39300 322         CIF
 39400 323         IVNEED=IZVCST(1)
 39500    C
 39600 324         PERFORM COMMZS
 39700    C
 39800 327      CIF
 39900    C
 40000    C=======================================================================
 40100    C
 40200    C     COMMON S-Z FIT FOR USER SPECIFIED TRACK SETS
 40300    C
 40400    C
 40500 328      IF KOPT.EQ.4
 40600 329      THEN
 40700 332         FOR ISET=1,NSETZS
 40800 333            NTSETI=NTSTZS(ISET)
 40900 334            NTRFIT=0
 41000 335            IDTR2=1
 41100 336            FOR JTR=1,NTRKS
 41200 337               ITR=IWRK(IDTR2)
 41300 338               IWRK(IDTR2+2)=1
 41400 339               FOR JT=1,NTSETI
 41500 340                  IF KTSTZS(JT,1,ISET).EQ.ITR
 41600 341                  THEN
 41700 344                     NTRFIT=NTRFIT+1
 41800 345                     IWRK(IDTR2+2)=2
 41900 346                     XFOR
 42000 347                  CIF
 42100 348               CFOR
 42200 350               IDTR2=IDTR2+LDTR2
 42300 351            CFOR
 42400 353            IF NTRFIT.GE.2
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 42500 354            THEN
 42600 357               XCOMM=XYSTZS(1,ISET)
 42700 358               YCOMM=XYSTZS(2,ISET)
 42800 359               IVNEED=IZVCST(ISET)
 42900 360               PERFORM COMMZS
 43000 363            CIF
 43100 364         CFOR
 43200 366      CIF
 43300    C
 43400 367      RETURN
 43500    C
 43600    C
 43700    C=======================================================================
 43800    C
 43900    C
 44000    C  CODE FOR THE COMMON S-Z FIT
 44100    C  HITS ARE USED   IFF   MARKED AS USED IN ZSRFT1
 44200    C
 44300 368      PROC COMMZS
 44400    C
 44500    C STARTING VALUE FOR COMMON Z AND
 44600    C CHECK IF TRACK CONSISTENT WITH THE COMMON POINT IN R-PHI
 44700    C AND IF Z AT COMMON POINT IS WITHIN LIMITS
 44800    C
 44900 369         ZCUT=ZCUTV
 45000 370         IF(KOPT.EQ.4) ZCUT=ZCUTVV
 45100 372         IDTR2=1
 45200 373         NTRFIT=0
 45300 374         ZCOMM=0.
 45400 375         FOR JTR=1,NTRKS
 45500 376            IF IWRK(IDTR2+2).EQ.2
 45600 377            THEN
 45700    C TRACK WAS REQUESTED
 45800 380               IPTR=IWRK(IDTR2+1)
 45900    C CALCULATE DISTANCE OF COMMON POINT TO CIRCLE IN R-PHI
 46000 381               CURVXY=ADATA(IPTR+25)
 46100 382               IF(ABS(CURVXY).LT.1.E-9) CURVXY = SIGN(1.E-9,CURVXY)
 46200 384               DDR0=DISTXY(ADATA(IPTR+5),ADATA(IPTR+6),ADATA(IPTR+8),
 46300         +         ADATA(IPTR+9),1./CURVXY,XCOMM,YCOMM,CORTRC(1,JTR),
 46400         +         CORTRC(2,JTR),FI)
 46500 385               IF ABS(DDR0).LT.DIMPCT
 46600 386               THEN
 46700    C CIRCLE CLOSE ENOUGH TO COMMON POINT
 46800    C TRACK DIRECTION AT COMMON POINT
 46900 389                  WRK(IDTR2+5)=COS(FI)
 47000 390                  WRK(IDTR2+6)=SIN(FI)
 47100    C CALCULATE Z OF TRACK AT THE COMMON POINT
 47200 391                  DDR0=DISTXY(ADATA(IPTR+5),ADATA(IPTR+6),ADATA(IPTR+8),
 47300         +            ADATA(IPTR+9),1./CURVXY,0.,0.,XP,YP,FI)
 47400 392                  UU=SQRT((CORTRC(1,JTR)-XP)**2+(CORTRC(2,JTR)-YP)**2)
 47410 393                  ARGARG = .5*CURVXY*UU
 47420 394                  IF( ABS(ARGARG).GT.1.) ARGARG = SIGN( 1., ARGARG )
 47500 396                  IF(ABS(CURVXY*UU).GT.1.E-5)
 47600         +            UU=2.*ARSIN(ARGARG)/CURVXY
 47610    CC                IF(ABS(CURVXY*UU).GT.1.E-5)
 47620    CC   +            UU=2.*ARSIN(.5*CURVXY*UU)/CURVXY
 47700 398                  ZCOMM1=ADATA(IPTR+31)+ADATA(IPTR+30)*UU
 47800 399                  IF ABS(ZCOMM1) .LT. ZCUT
 47900 400                  THEN
 48000 403                     WRK(IDTR2+7)=ZCOMM1
 48100 404                     WRK(IDTR2+10)=CURVXY
 48200 405                     ZCOMM=ZCOMM+ZCOMM1
 48300 406                     NTRFIT=NTRFIT+1
 48400 407                  ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 48500 409                     IWRK(IDTR2+2)=1
 48600 410                  CIF
 48700 411               ELSE
 48800 413                  IWRK(IDTR2+2)=1
 48900 414               CIF
 49000 415            CIF
 49100 416            IDTR2=IDTR2+LDTR2
 49200 417         CFOR
 49300    C
 49400    C STARTING VALUE OF COMMON Z; NO CHECK IF Z OF TRACK CONSISTENT WITH IT
 49500    C COLLECT SUMS FOR COMMON Z FIT
 49600 419         IF NTRFIT.GE.2
 49700 420         THEN
 49800 423            ZCOMM=ZCOMM/NTRFIT
 49900    COMIT       DZLIM=400.
 50000    COMIT       NTRFIT=0
 50100 424            NHTOT=0
 50200 425            IF IVNEED.EQ.1
 50300 426            THEN
 50400    C VERTEX CONSTRAINT OF 10 MM ON THE COMMON Z
 50500 429               S0=(20./10.)**2
 50600 430               IF( LDATYP(DUMMY).EQ.2 ) S0=S0*4.
 50700 432               S3=-ZCOMM*S0
 50800 433               S7=ZCOMM**2*S0
 50900 434            ELSE
 51000 436               S0=0.
 51100 437               S3=0.
 51200 438               S7=0.
 51300 439            CIF
 51400 440            S5=0.
 51500 441            S6=0.
 51600 442            IDTR2=1
 51700 443            FOR JTR=1,NTRKS
 51800 444               IF IWRK(IDTR2+2).EQ.2
 51900 445               THEN
 52000    C TRACK REQUESTED AND SURVIVED THE R-PHI DISTANCE AND Z CUTS
 52100    COMIT             IF ABS(WRK(IDTR2+7)-ZCOMM).LT.DZLIM
 52200    COMIT             THEN
 52300    C TRACK CLOSE ENOUGH IN Z
 52400    COMIT                NTRFIT=NTRFIT+1
 52500 448                  IPTR=IWRK(IDTR2+1)
 52600 449                  CURVXY=WRK(IDTR2+10)
 52700 450                  CTGTH=ADATA(IPTR+30)
 52800 451                  S1=0.
 52900 452                  S2=0.
 53000 453                  S4=0.
 53100    C LOOP OVER HITS
 53200 454                  IPCO =IWRK(IDTR2+3)
 53300 455                  IPCO9=IWRK(IDTR2+4)-LHIT
 53400 456                  FOR IP=IPCO,IPCO9,LHIT
 53500 457                     IF HWRK(2*IP+3).EQ.1
 53600 458                     THEN
 53700    C HIT WAS USED IN THE SINGLE TRACK FIT
 53800    C CALCULATE TRACK LENGTH IN R-PHI COUNTED FROM COMMON POINT
 53900 461                        UX=WRK(IP+3)-CORTRC(1,JTR)
 54000 462                        UY=WRK(IP+4)-CORTRC(2,JTR)
 54100 463                        UU=SQRT(UX**2+UY**2)
 54110 464                        ARGARG = .5*CURVXY*UU
 54120 465                        IF( ABS(ARGARG).GT.1.) ARGARG=SIGN(1.,ARGARG)
 54130 467                        IF(ABS(CURVXY*UU).GT.1.E-5)
 54140         +                  UU=2.*ARSIN(ARGARG)/CURVXY
 54200    CC                         IF(ABS(CURVXY*UU).GT.1.E-5)
 54300    CC   +                     UU=2.*ARSIN(.5*CURVXY*UU)/CURVXY
 54400 469                        IF(UX*WRK(IDTR2+5)+UY*WRK(IDTR2+6).LT.0.)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 54500         +                  UU=-UU
 54600    C RESIDUAL TO LINE WITH START PARAMETERS
 54700 471                        DZ=WRK(IP+5)-ZCOMM-CTGTH*UU
 54800 472                        W=WRK(IP+7)
 54900 473                        NHTOT=NHTOT+1
 55000 474                        S0=S0+W
 55100 475                        S3=S3+DZ*W
 55200 476                        S1=S1+UU*W
 55300 477                        S2=S2+UU**2*W
 55400 478                        S4=S4+DZ*UU*W
 55500 479                        S7=S7+DZ**2*W
 55600 480                     CIF
 55700 481                  CFOR
 55800 483                  WRK(IDTR2+7)=S4
 55900 484                  WRK(IDTR2+8)=S1
 56000 485                  WRK(IDTR2+9)=S2
 56100 486                  S5=S5+S1*S4/S2
 56200 487                  S6=S6+S1*S1/S2
 56300    COMIT             ELSE
 56400    COMIT                IWRK(IDTR2+2)=1
 56500    COMIT             CIF
 56600 488               CIF
 56700 489               IDTR2=IDTR2+LDTR2
 56800 490            CFOR
 56900    C
 57000    C RESULTS OF COMMON FIT; FILL 'PATR' BANK
 57100    COMIT       IF NTRFIT.GE.2
 57200    COMIT       THEN
 57300 492            DZCOMM=(S3-S5)/(S0-S6)
 57400 493            ZCOMMR=ZCOMM+DZCOMM
 57500    C
 57600 494            ISETOP=1
 57700 495            IF(KOPT.EQ.4) ISETOP=ISET
 57800 497            SQCHZS(2,ISETOP)=NHTOT
 57900 498            SQCHZS(3,ISETOP)=ZCOMMR
 58000 499            SQCHZS(1,ISETOP)=S7+DZCOMM*(DZCOMM*S0-2.*S3)
 58100    C
 58200 500            IDTR2=1
 58300 501            FOR JTR=1,NTRKS
 58400 502               IF IWRK(IDTR2+2).EQ.2
 58500 503               THEN
 58600 506                  IPTR=IWRK(IDTR2+1)
 58700 507                  PERFORM FITBNK
 58800    C
 58900    C SET SINGLE TRACK FIT FLAG IN   KTSTZS(.,2,.)
 59000 510                  ITR=IWRK(IDTR2)
 59100 511                  IF KOPT.EQ.4
 59200 512                  THEN
 59300 515                     FOR JT=1,NTSETI
 59400 516                        IF(KTSTZS(JT,1,ISET).EQ.ITR)KTSTZS(JT,2,ISET)=2
 59500 518                     CFOR
 59600 520                  ELSE
 59700 522                     KTSTZS(ITR,2,1)=2
 59800 523                  CIF
 59900    C
 60000 524               CIF
 60100 525               IDTR2=IDTR2+LDTR2
 60200 526            CFOR
 60300    C
 60400 528            IF(SQCHZS(1,ISETOP).LT.1.E-5) SQCHZS(1,ISETOP)=1.E-5
 60500 530            SQCHZS(1,ISETOP)=SQRT(SQCHZS(1,ISETOP)/(NHTOT-NTRFIT-1))
 60600    C
 60700    COMIT       CIF
 60800 531         CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 11
0CARD TARGET
  NO  STM.NO
 
 60900 532      CPROC
 61000    C=======================================================================
 61100    C
 61200    C
 61300                                                                             *************************
 61400                                                                             *      F I T B N K      *
 61600    C                                                                        *************************
 61700    C
 61900 534      PROC FITBNK                                                        SET UP FIT-BANK
 62000    C
 62100 535         DCTGTH=(WRK(IDTR2+7)-DZCOMM*WRK(IDTR2+8))/WRK(IDTR2+9)
 62200    C
 62300 536         SQCHZS(1,ISETOP)=SQCHZS(1,ISETOP)+DCTGTH*(DCTGTH*WRK(IDTR2+9)+
 62400         +   2.*DZCOMM*WRK(IDTR2+8)-2.*WRK(IDTR2+7))
 62500    C
 62600 537         CTGTH=ADATA(IPTR+30)+DCTGTH
 62700 538         CSTH = 1./SQRT(CTGTH**2 + 1.)
 62800 539         SNTH  = CSTH * CTGTH
 62900 540         CURVXY=WRK(IDTR2+10)
 63000    C
 63100    C
 63200    C
 63400 541         IFREE=NDIWRK-100                                                COPY TRACK BANK
 63500 542         CALL MVCL(IWRK(IFREE),0,IDATA(IPTR+1),0,4*LDTR)
 63600    C
 63800 543         IP    = IFREE - 1                                               FILL FIT-BANK
 63900 544         IWRK(IP+ 2) = LOR(IWRK(IP+2),8192)
 64000    C FIRST POINT ON TRACK
 64100 545         UX=WRK(IP+5)-CORTRC(1,JTR)
 64200 546         UY=WRK(IP+6)-CORTRC(2,JTR)
 64300 547         UU=SQRT(UX**2+UY**2)
 64310 548         ARGARG = .5*CURVXY*UU
 64320 549         IF( ABS(ARGARG).GT.1.) ARGARG = SIGN( 1., ARGARG )
 64330 551         IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(ARGARG)/CURVXY
 64400    CC       IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(.5*CURVXY*UU)/CURVXY
 64500 553         IF(UX*WRK(IDTR2+5)+UY*WRK(IDTR2+6).LT.0.) UU=-UU
 64600 555         WRK (IP+ 7) = ZCOMMR+CTGTH*UU
 64700 556         A=SQRT(WRK(IP+8)**2+WRK(IP+9)**2)
 64800 557         WRK (IP+ 8) = WRK (IP+ 8)/A*CSTH
 64900 558         WRK (IP+ 9) = WRK (IP+ 9)/A*CSTH
 65000 559         WRK (IP+10) = SNTH
 65100    C LAST POINT ON TRACK
 65200 560         UX=WRK(IP+12)-CORTRC(1,JTR)
 65300 561         UY=WRK(IP+13)-CORTRC(2,JTR)
 65400 562         UU=SQRT(UX**2+UY**2)
 65410 563         ARGARG = .5*CURVXY*UU
 65420 564         IF( ABS(ARGARG).GT.1.) ARGARG = SIGN( 1., ARGARG )
 65430 566         IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(ARGARG)/CURVXY
 65500    CC       IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(.5*CURVXY*UU)/CURVXY
 65600 568         IF(UX*WRK(IDTR2+5)+UY*WRK(IDTR2+6).LT.0.) UU=-UU
 65700 570         WRK (IP+14) = ZCOMMR+CTGTH*UU
 65800 571         A=SQRT(WRK(IP+15)**2+WRK(IP+16)**2)
 65900 572         WRK (IP+15) = WRK (IP+15)/A*CSTH
 66000 573         WRK (IP+16) = WRK (IP+16)/A*CSTH
 66100 574         WRK (IP+17) = SNTH
 66200    C STORE COMMON FIT PARAMETERS
 66300 575         IWRK(IP+29) = 2
 66400 576         WRK (IP+30) = CTGTH
 66500    C GET CLOSEST POINT (XP,YP) TO ORIGIN
 66600 577         DDR0=DISTXY(ADATA(IPTR+5),ADATA(IPTR+6),ADATA(IPTR+8),
 66700         +   ADATA(IPTR+9),1./CURVXY,0.,0.,XP,YP,FI)
 66800    C CALCULATE TRACK LENGTH ALONG CIRCLE FROM FIRST POINT TO (XP,YP)
 66900 578         UX=XP-CORTRC(1,JTR)
 67000 579         UY=YP-CORTRC(2,JTR)
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 12
0CARD TARGET
  NO  STM.NO
 
 67100 580         UU=SQRT(UX**2+UY**2)
 67110 581         ARGARG = .5*CURVXY*UU
 67120 582         IF( ABS(ARGARG).GT.1.) ARGARG = SIGN( 1., ARGARG )
 67130 584         IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(ARGARG)/CURVXY
 67200    CC       IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(.5*CURVXY*UU)/CURVXY
 67300 586         IF(UX*WRK(IDTR2+5)+UY*WRK(IDTR2+6).LT.0.) UU=-UU
 67400 588         WRK (IP+31) = ZCOMMR+CTGTH*UU
 67600 589         CALL MVCL(IDATA(IPTR+1),0,IWRK(IFREE),0,4*LDTR)                 PUT RESULT INTO PATR-BANK
 67700 590      CPROC
 67800 592      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         591 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         591 TARGET STATEMENTS
 00000    C   09/06/83 805241835  MEMBER NAME  ZSRFT1   (JADEGS)      SHELTRAN
 00100    C   09/06/83 803181242  MEMBER NAME  ZSRFT1   (S)           SHELTRAN
 00200   2      SUBROUTINE ZSRFT1(IPTR,LDTR,IPCO0,IPRES,LHIT,IQUAL,IOPT)
 00300    C
 00400    C        S-Z ("HELIX") REFIT OF A SINGLE TRACK
 00500    C
 00510    C    20.5.88 WEIGHT RENORMAL. AFTER ALL ITERATIONS        J.H./E.E.
 00511    C            MC USE ZRS AS RESOLUTION                     J.H./E.E.
 00513    C    18.5.88 SMOOTH CUTOFF PROCEDURE FOR LSTOP            J.H./E.E.
 00514    C    13.5.88 (FRIDAY!) SEVERE BUG CORRECTED IN TWO PLACES J.H./J.O.
 00520    C            ARSIN INSTEAD OF SIN
 00530    C            IN ADDITION MISPRINT XP CHANGED INTO YP
 00600    C    18.3.88   PROPER RUN NUMBER HANDLING USING LDATYP      E E
 00700    C    22.2.88   MVC CHANGED TO MVCL (256 BYTES NOT ENOUGH!)  J.H./J.O.
 00800    C    TEST VERSION 1.
 00900    C
 01000    C                                J. SPITZER  12/4/87
 01100    C
 01200    C    COVARIANCE MATRIX FOR FIT PARAMETERS IF AREA (LDTR) LARGE ENOUGH
 01300    C
 01400   3      IMPLICIT INTEGER*2 (H)
 01500    C
 01510   4      LOGICAL LIDHIT
 01520    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 CALIBR .... JADE CALIBRATION DATA COMMON
          C----------------------------------------------------------------------
         9      COMMON/CALIBR/ ACALIB(1000)
        10      DIMENSION HCALIB(100),ICALIB(100)
 02600  11      EQUIVALENCE(ACALIB(1),HCALIB(1),ICALIB(1))
          C------------------------ END OF MACRO CALIBR -------------------------
 01800    C
 01900  12      COMMON/CWORK/NDIWRK,WRK(200)
 02000  13      DIMENSION IWRK(200),HWRK(400)
 02100  14      EQUIVALENCE (WRK(1),IWRK(1),HWRK(1))
 02200    C
 02220  15      COMMON / CBIN   / TIME(6),ZOF,ZRS,ZL,ZSC,EPSI(3),DOUB(3),IRN(3),
 02230         +                BINDL8(6),RJITT, DLRSLN(3), DLZSLN(3)
 02300    C
 02400  16      INTEGER DATE(5), IDAY /0/
 03900    C
 04000  17      REAL RESCUT/600./
 04100  18      DIMENSION ISORT1(71),ISORT2(3,71),IRESHT(71),ISORT3(91)
 04200         +,ISORT4(2,91),KSORT3(91),KSZSRT(91,2)
 04300  19      DATA IQHEAD/0/,MASK4/ZFFFFCFFF/
 04400    C
 04500    C
 04600    C
 04800  20      DATA LBINIT /0/                                                    INITIALIZATION
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 04900  21      IF LBINIT .EQ. 0
 05000  22      THEN
 05100  25         LBINIT = 1
 05200    C
 05300  26         IQHEAD = IBLN('HEAD')
 05400    C
 05500  27         CALL DAY2(DATE)
 05600  28         IDAY = DATE(1)*1000 + DATE(2)
 05700    C
 05800  29         WRITE(6,137)
 05900  30 137     FORMAT(/,' *** ZSRFT1 ***  (J.SPITZER) VERSION OF 20/5/88',
 06000         +   ' SMOOTH CUTOFF PROCEDURE IMPLEMENTED')
 06400  31      CIF
 06500    C
 06600    C
 06800  32      IPHEAD = IDATA(IQHEAD)*2                                           GET RUN #
 06900  33      NRUN = HDATA(IPHEAD+10)
 07000  34      NEV  = HDATA(IPHEAD+11)
 07100    C
 07300  35      ITRK = IDATA(IPTR+1)                                               TRACK #
 07400    C
 07500    C=======================================================================
 07600  36      IF LDATYP(DUMMY) .EQ. 1
 07700  37      THEN
 07800  40         SRESO=24.
 07900  41         STPFAC=.85
 08000  42      ELSE
 08100  44         SRESO=32.
 08200  45         STPFAC=.92
 08300  46      CIF
 08310  47      IF( NRUN.LT.100 ) SRESO = SQRT(ZRS**2+1.)
 08400  49      SIGMIN=(SRESO/1.6)**2
 08500  50      SIGFAC=(.14/30.)**2
 08600    C
 08700    C
 08800    C-----------------------------------------------------------------------
 08900    C
 09000    C     GYMNASTICS FOR PRIVATE HIT QUALIFICATION
 09100    C     AND FOR HANDLING MORE HITS ON SAME WIRE
 09200    C
 09300    C  STARTING VALUES OF FIT PARAMETERS Z=P1*S+P2
 09400    C
 09500  51      PAR1=ADATA(IPTR+30)
 09600  52      PAR2=ADATA(IPTR+7)
 09700    C
 09800  53      NHALL=0
 09900  54      NHWIR=0
 10000  55      NHPOT=0
 10100  56      NHPOTT=0
 10200  57      IPCO=IPCO0
 10300  58      IPCO9=IPRES-LHIT
 10400  59      REPEAT
 10500  60         NHWIR=NHWIR+1
 10600  61         IF NHWIR.GT.70
 10700  62         THEN
 10800  65            IQUAL=-1
 10900  66            RETURN
 11000  67         CIF
 11100  68         ISORT1(NHWIR)=NHWIR
 11200  69         ISORT2(1,NHWIR)=IPCO
 11300  70         ISORT2(3,NHWIR)=0
 11400  71         IW0=IWRK(IPCO)
 11500  72         LFL=0
 11600  73         LFL1=0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 11700  74         LFL2=0
 11800  75         WHILE IPCO.LE.IPCO9
 11900  77            IW9=IWRK(IPCO)
 12000  81            IF IW9.EQ.IW0
 12100  82            THEN
 12300  85               NHALL=NHALL+1                                             HIT ON THE SAME WIRE
 12400  86               IF NHALL.GT.90
 12500  87               THEN
 12600  90                  IQUAL=-2
 12700  91                  RETURN
 12800  92               CIF
 12900  93               IF(ISORT2(3,NHWIR).EQ.0) ISORT2(2,NHWIR)=NHALL
 13000  95               ISORT2(3,NHWIR)=ISORT2(3,NHWIR)+1
 13100    C
 13200  96               KSORT3(NHALL)= NHALL
 13300  97               LZGOOD=HWRK(2*IPCO+1)
 13400  98               IF LZGOOD.NE.0
 13500  99               THEN
 13600 102                  ISORT3(NHALL)=-1
 13700 103                  KSZSRT(NHALL,1)= 100000
 13800 104               ELSE
 13900 106                  ISORT3(NHALL)= 1
 14000 107                  IF LFL2.EQ.0
 14100 108                  THEN
 14200 111                     KSZSRT(NHALL,1)= WRK(IPCO+6)
 14300 112                     KSZSRT(NHALL,2)= WRK(IPCO+5)
 14400 113                     LFL2=1
 14500 114                  ELSE
 14600 116                     KSZSRT(NHALL,1)= 100000
 14700 117                  CIF
 14800 118                  LFL=1
 14900 119                  IF ABS(WRK(IPCO+5)-PAR1*WRK(IPCO+6)-PAR2).LT.RESCUT
 15000 120                  THEN
 15100 123                     IF LFL1.EQ.0
 15200 124                     THEN
 15300 127                        LFL1=1
 15400 128                        NHPOTT=NHPOTT+1
 15500 129                     CIF
 15600 130                  CIF
 15700 131               CIF
 15800    C
 15900 132               IPCO=IPCO+LHIT
 16000 133            ELSE
 16100 135               XWHILE
 16200 136            CIF
 16300 137         CWHILE
 16400 139         IF LFL.EQ.1
 16500 140         THEN
 16600 143            NHPOT=NHPOT+1
 16700 144         ELSE
 16800 146            ISORT3(ISORT2(2,NHWIR))=-2
 16900 147         CIF
 17000 148      UNTIL IPCO.GT.IPCO9
 17100    C-----------------------------------------------------------------------
 17200    C
 17300    C IF LESS THAN 2 WIRES WITH GOOD Z MEASUREMENT, NOTHING DONE
 17400 149      IF NHPOT.LT.2
 17500 153      THEN
 17600 156         IQUAL=-3
 17700 157         RETURN
 17800 158      CIF
 17900    C-----------------------------------------------------------------------
 18000 159      KFLIP=2
 18100    C
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 18200 160      NHFIT=NHPOTT
 18300 161      LFOUND=-1
 18400 162      IF NHPOTT.LT.6.OR.NHPOTT.LT.NHPOT*.75
 18500 163      THEN
 18600    C TRY TO FIND BETTER START VALUES
 18700 166         PERFORM STVSEA
 18800 169      CIF
 18900    C-----------------------------------------------------------------------
 19000    C
 19100 170      INDMAX=NHFIT/4+1
 19200 171      IF(INDMAX.GT.13) INDMAX=13
 19300 173      INDFIT=0
 19400 174      WHILE INDFIT.LT.INDMAX
 19500 176         INDFIT=INDFIT+1
 19700 180         PERFORM LINFIT                                                  INEAR FIT
 19800 183         IF LNOCON.EQ.1
 19900 184         THEN
 20000    C NO CONVERGENCE AS INDICATED BY LOSS OF TOO MANY HITS
 20100 187            IQUAL=-4
 20200 188            RETURN
 20300 189         CIF
 20400 190         IF(SIG.LT.SIGMIN) XWHILE
 20500 192         IF INDFIT.GE.2
 20600 193         THEN
 20700 196            PERFORM LLSTOP
 20800 199            IF LSTOP.EQ.1
 20900 200            THEN
 21000    C      PREVIOUS FIT ACCEPTED, RESTORE ITS RESULTS
 21100 203               INDFIT=INDFIT-1
 21200 204               KFLIP=3-KFLIP
 21300 205               NHFIT=NHFTLS
 21400 206               PAR1=PAR1LS
 21500 207               PAR2=PAR2LS
 21600 208               SIG=SIGLST
 21700 209               S0=S0LS
 21800 210               S1=S1LS
 21900 211               S2=S2LS
 22000 212               S3=S3LS
 22100 213               S4=S4LS
 22110 214               SHID = SHIDLS
 22120 215               S0ID = S0IDLS
 22200 216               XWHILE
 22300 217            CIF
 22400 218         CIF
 22500 219         IF(INDFIT.EQ.INDMAX.OR.NHFIT.EQ.2) XWHILE
 22700 221         NHFTLS=NHFIT                                                    SAVE FIT RESULTS
 22800 222         PAR1LS=PAR1
 22900 223         PAR2LS=PAR2
 23000 224         SIGLST=SIG
 23100 225         S0LS=S0
 23200 226         S1LS=S1
 23300 227         S2LS=S2
 23400 228         S3LS=S3
 23500 229         S4LS=S4
 23510 230         SHIDLS = SHID
 23520 231         S0IDLS = S0ID
 23700 232         PERFORM HITCLN                                                  HIT CLEANING
 23800 235      CWHILE
 23900    C
 24000    C
 24200 237      PERFORM FITBNK                                                     SET UP PATR-BANK
 24300 240      IQUAL=1
 24400 241      RETURN
 24500    C=======================================================================
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 24600    C
 24700                                                                             *************************
 24800                                                                             *      L I N F I T      *
 25000    C                                                                        *************************
 25100    C
 25300 242      PROC LINFIT                                                        LINEAR FIT
 25400    C
 25500 243         LNOCON=0
 25700 244         KFLIP=3-KFLIP                                                   GET EQUATIONS
 25800 245         NHF1=0
 25810 246         SHID = 0.
 25820 247         S0ID = 0.
 25900 248         S0 = 0.
 26000 249         S1 = 0.
 26100 250         S2 = 0.
 26200 251         S3 = 0.
 26300 252         S4 = 0.
 26400 253         FOR IHWIR=1,NHWIR
 26500 254            IH=ISORT2(2,IHWIR)
 26600 255            NNH=ISORT2(3,IHWIR)
 26700 256            FOR JNH=1,NNH
 26800 257               ISORT4(KFLIP,IH+JNH-1)=0
 26900 258            CFOR
 27000 260            IF ISORT3(IH).EQ.1 .OR. ISORT3(IH).EQ.-1.AND.NNH.GT.1
 27100 261            THEN
 27200 264               RESMIN=10000.
 27210 265               LIDHIT = .TRUE.
 27300 266               FOR JNH=1,NNH
 27400 267                  JH=IH+JNH-1
 27500 268                  IF ISORT3(JH).EQ.1
 27600 269                  THEN
 27700 272                     IPCO=ISORT2(1,IHWIR)+(JNH-1)*LHIT
 27800 273                     SA = WRK(IPCO+6)
 27900 274                     ZA = WRK(IPCO+5)
 28000 275                     WA = WRK(IPCO+7)
 28100 276                     DZRESA=ZA-PAR1*SA-PAR2
 28200 277                     DF0=ABS(DZRESA)
 28300 278                     IF DF0.LT.RESMIN
 28400 279                     THEN
 28500 282                        RESMIN=DF0
 28600 283                        S=SA
 28700 284                        W=WA
 28800 285                        DZRES=DZRESA
 28900 286                        JHUSE=JH
 28910 287                        LIDHIT = HWRK(IPCO*2-1).LT.97
 29000 288                     CIF
 29100 289                  CIF
 29200 290               CFOR
 29300 292               IF RESMIN.LT.RESCUT
 29400 293               THEN
 29500 296                  NHF1=NHF1+1
 29600 297                  S0=S0+W
 29700 298                  S1=S1+S*W
 29800 299                  S2=S2+S**2*W
 29900 300                  S3=S3+DZRES*W
 30000 301                  S4=S4+DZRES*S*W
 30010 302                  IF LIDHIT
 30020 303                  THEN
 30030 306                     SHID = SHID + 1.
 30031 307                     S0ID = S0ID + W
 30040 308                  CIF
 30100 309                  ISORT4(KFLIP,JHUSE)=1
 30200 310               ELSE
 30300 312                  ISORT3(IH)=-2
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 30400 313               CIF
 30500 314            CIF
 30600 315         CFOR
 30700 317         IF NHF1.LT.2 .OR. S2.LT.1.
 30800 318         THEN
 30900 321            LNOCON=1
 31000 322         ELSE
 31100 324            NHFIT=NHF1
 31200    C
 31400 325            F1 = 1. / S2                                                 SOLVE EQUATIONS
 31500 326            XX12 = S1*F1
 31600 327            YY1  = S4*F1
 31700 328            PARR2=(S3-S1*YY1)/(S0-S1*XX12)
 31800 329            PAR1=YY1-PARR2*XX12+PAR1
 31900 330            PAR2=PAR2+PARR2
 32000    C
 32200 331            CHISQ = 0.                                                   CALC. CHISQ + SOLVE L/R AMBIGUITY
 32300 332            NHF1=0
 32400 333            FOR IHWIR=1,NHWIR
 32500 334               IRESHT(IHWIR)=-1
 32600 335               IH=ISORT2(2,IHWIR)
 32700 336               NNH=ISORT2(3,IHWIR)
 32800 337               IF ISORT3(IH).GE.0 .OR. ISORT3(IH).EQ.-1.AND.NNH.GT.1
 32900 338               THEN
 33000 341                  RESMIN=10000.
 33100 342                  FOR JNH=1,NNH
 33200 343                     JH=IH+JNH-1
 33300 344                     IF ISORT3(JH).GE.0
 33400 345                     THEN
 33500 348                        IFLG=ISORT3(JH)
 33600 349                        IPCO=ISORT2(1,IHWIR)+(JNH-1)*LHIT
 33700 350                        SA = WRK(IPCO+6)
 33800 351                        ZA = WRK(IPCO+5)
 33900 352                        WA = WRK(IPCO+7)
 34000 353                        DF0=ABS(ZA-PAR1*SA-PAR2)
 34100 354                        IF DF0.LT.RESMIN
 34200 355                        THEN
 34300 358                           RESMIN=DF0
 34400 359                           W=WA
 34500 360                        CIF
 34600 361                     CIF
 34700 362                  CFOR
 34800 364                  IF RESMIN.LT.8000.
 34900 365                  THEN
 35000 368                     RESMIN=RESMIN*SQRT(W)
 35100 369                     IRESHT(IHWIR)=RESMIN*1.E4
 35200 370                     IF IFLG.EQ.1
 35300 371                     THEN
 35400 374                        CHISQ=CHISQ+RESMIN**2
 35500 375                        NHF1=NHF1+1
 35600 376                     CIF
 35700 377                  CIF
 35800 378               CIF
 35900 379            CFOR
 36000 381            IF NHF1.LT.2
 36100 382            THEN
 36200 385               LNOCON=1
 36300 386            ELSE
 36400 388               IF NHF1.EQ.2
 36500 389               THEN
 36600 392                  SIG=1.E-5
 36700 393               ELSE
 36800 395                  SIG=CHISQ/(NHF1-2)
 36900 396               CIF
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 37000 397            CIF
 37100 398            NHFIT=NHF1
 37200 399         CIF
 37300 400      CPROC
 37400    C=======================================================================
 37500 402      PROC HITCLN
 37600    C      LABEL HITS NOT TO BE USED IN THE NEXT ITRATION
 37700    C-------------------------------------------------------------
 37800    C
 38000    C  EXCLUDE THE INDFIT LARGEST RESIDUAL HITS,                             SORT HITS ACCORDING TO RESIDUALS
 38100    C  RESTORE THE OTHERS (EXLUDED FOR EVER HITS NOT COUNTED)
 38200    C
 38300 403         CALL SHELL9(IRESHT,ISORT1,NHWIR)
 38400 404         KOMIT=0
 38500 405         FOR J1=1,NHWIR
 38600 406            IHWIR=ISORT1(NHWIR+1-J1)
 38700 407            IPCO=ISORT2(1,IHWIR)
 38800 408            NNH=ISORT2(3,IHWIR)
 38900 409            IH=ISORT2(2,IHWIR)
 39000 410            LFLG=0
 39100 411            FOR JNH=1,NNH
 39200 412               IHA=IH+JNH-1
 39300 413               IQA=ISORT3(IHA)
 39400 414               IF IQA.GT.-1
 39500 415               THEN
 39600 418                  IF LFLG.EQ.0
 39700 419                  THEN
 39800 422                     LFLG=1
 39900 423                     KOMIT=KOMIT+1
 40000 424                  CIF
 40100 425                  IF KOMIT.LE.INDFIT
 40200 426                  THEN
 40300 429                     ISORT3(IHA)=0
 40400 430                  ELSE
 40500 432                     ISORT3(IHA)=1
 40600 433                  CIF
 40700 434               CIF
 40800 435            CFOR
 40900 437         CFOR
 41000 439      CPROC
 41100    C=======================================================================
 41200 441      PROC LLSTOP
 41300 442         SIGCHK = SIGLST*SIGFAC
 41400 443         IF SIGCHK .LT. 0.002
 41500 444         THEN
 41600 447            RCHKPR = 0.0
 41700 448         ELSE
 41810 450            RCHKPR = 1.139 + 0.08862*ALOG(SIGCHK)
 41900 451         CIF
 42000 452         IF SIG/SIGLST*STPFAC.GT.RCHKPR
 42500 453         THEN
 42600 456            LSTOP=1
 42700 457         ELSE
 42800 459            LSTOP=0
 42900 460         CIF
 43000 461      CPROC
 43100    C=======================================================================
 43200    C
 43300    C
 43400                                                                             *************************
 43500                                                                             *      F I T B N K      *
 43700    C                                                                        *************************
 43800    C
 44000 463      PROC FITBNK                                                        SET UP FIT-BANK
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 44100    C
 44200 464         CTGTH=PAR1
 44300 465         CSTH = 1./SQRT(CTGTH**2 + 1.)
 44400 466         SNTH  = CSTH * CTGTH
 44500    C
 44600    C
 44720 467         IF( S0ID.GT.0. ) SIG = SIG*SHID/S0ID                            NORMALIZE SIG FOR WEIGHT EQUAL 1
 44900 469         IFREE=NDIWRK-100                                                COPY TRACK BANK
 45000 470         CALL MVCL(IWRK(IFREE),0,IDATA(IPTR+1),0,4*LDTR)
 45100    C
 45300 471         IP    = IFREE - 1                                               FILL FIT-BANK
 45400 472         IWRK(IP+ 2) = LAND(IWRK(IP+2),MASK4)
 45500 473         IWRK(IP+ 2) = LOR(IWRK(IP+2),4096)
 45600 474         WRK (IP+ 7) = PAR2
 45700 475         A=SQRT(WRK(IP+8)**2+WRK(IP+9)**2)
 45800 476         WRK (IP+ 8) = WRK (IP+ 8)/A*CSTH
 45900 477         WRK (IP+ 9) = WRK (IP+ 9)/A*CSTH
 46000 478         WRK (IP+10) = SNTH
 46100    C CALCULATE TRACK LENGTH IN R-PHI FROM FIRST TO LAST POINT ON TRACK
 46200 479         CURVXY=WRK(IP+25)
 46300 480         IF(ABS(CURVXY).LT.1.E-9) CURVXY = SIGN(1.E-9,CURVXY)
 46400 482         UU=SQRT((WRK(IP+12)-WRK(IP+5))**2+(WRK(IP+13)-WRK(IP+6))**2)
 46410 483         ARGARG = .5*CURVXY*UU
 46420 484         IF(ABS(ARGARG).GT.1.) ARGARG = SIGN(1.,ARGARG)
 46510 486         IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(ARGARG)/CURVXY
 46520    C        IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(.5*CURVXY*UU)/CURVXY
 46600 488         WRK (IP+14) = PAR2+UU*PAR1
 46700 489         A=SQRT(WRK(IP+15)**2+WRK(IP+16)**2)
 46800 490         WRK (IP+15) = WRK (IP+15)/A*CSTH
 46900 491         WRK (IP+16) = WRK (IP+16)/A*CSTH
 47000 492         WRK (IP+17) = SNTH
 47100 493         IWRK(IP+33) = NHFIT
 47200 494         WRK (IP+32) = SQRT(SIG)
 47300    C FIT TYPE WILL BE 2: "HELIX FIT"
 47400 495         IWRK(IP+29) = 2
 47500 496         WRK (IP+30) = PAR1
 47600    C GET CLOSEST POINT (XP,YP) TO ORIGIN
 47700 497         DDR0=DISTXY(ADATA(IPTR+5),ADATA(IPTR+6),ADATA(IPTR+8),
 47800         +   ADATA(IPTR+9),1./CURVXY,0.,0.,XP,YP,FI)
 47900    C CALCULATE TRACK LENGTH ALONG CIRCLE FROM FIRST POINT TO (XP,YP)
 48000 498         UU=SQRT((XP-WRK(IP+5))**2+(YP-WRK(IP+6))**2)
 48010 499         ARGARG = .5*CURVXY*UU
 48020 500         IF(ABS(ARGARG).GT.1.) ARGARG = SIGN(1.,ARGARG)
 48030 502         IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(ARGARG)/CURVXY
 48040    C        IF(ABS(CURVXY*UU).GT.1.E-5) UU=2.*ARSIN(.5*CURVXY*UU)/CURVXY
 48200 504         WRK (IP+31) = PAR2-PAR1*UU
 48300    C
 48400 505         IF LDTR.GE.59 .AND. NHFIT.GE.4 .AND. LNOCON.EQ.0
 48500 506         THEN
 48600    C CALCULATE COVARIANCE MATRIX
 48700 509            DET=S0*S2-S1**2
 48800 510            FACT=SIG/DET
 48900 511            WRK(IP+56)=SIG*(NHFIT-2)/20.**2
 49000 512            WRK(IP+57)=(S2+2.*UU*S1+UU**2*S0)*FACT
 49100 513            WRK(IP+58)=-(UU*S0+S1)*FACT
 49200 514            WRK(IP+59)=S0*FACT
 49300 515         CIF
 49400    C
 49500    C MARK HITS USED IN THE FIT
 49600 516         LFL=0
 49700 517         FOR IHWIR=1,NHWIR
 49800 518            IH=ISORT2(2,IHWIR)
 49900 519            NNH=ISORT2(3,IHWIR)
 50000 520            FOR JNH=1,NNH
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 50100 521               IPCO=ISORT2(1,IHWIR)+(JNH-1)*LHIT
 50200 522               HWRK(2*IPCO+3)=ISORT4(KFLIP,IH+JNH-1)
 50300 523               IF(HWRK(2*IPCO-1).GT.100.AND.HWRK(2*IPCO+3).EQ.1) LFL=1
 50400 525            CFOR
 50500 527         CFOR
 50600 529         IF(LFL.EQ.1) IWRK(IP+ 2) = LOR(IWRK(IP+2),16384)
 50700    C
 50900 531         CALL MVCL(IDATA(IPTR+1),0,IWRK(IFREE),0,4*LDTR)                 PUT RESULT INTO PATR-BANK
 51000    C
 51100    C CREATE Z-S BANK 'ZSPD'
 51200    C
 51300 532         IF IOPT.GT.8
 51400 533         THEN
 51500 536            CALL CCRE(NPZSPD,'ZSPD',ITRK,5*NHALL+1,IERR)
 51600 537            IF IERR.EQ.0
 51700 538            THEN
 51800 541               CALL BSAW(1,'ZSPD')
 51900 542               NPZSP1=NPZSPD+1
 52000 543               IDATA(NPZSP1)=5
 52100 544               FOR IHWIR=1,NHWIR
 52200 545                  IH=ISORT2(2,IHWIR)
 52300 546                  NNH=ISORT2(3,IHWIR)
 52400 547                  FOR JNH=1,NNH
 52500 548                     IPCO=ISORT2(1,IHWIR)+(JNH-1)*LHIT
 52600 549                     IFL=ISORT4(KFLIP,IH+JNH-1)
 52700 550                     IF IFL.EQ.1
 52800 551                     THEN
 52900 554                        IFL=0
 53000 555                     ELSE
 53100 557                        IFL=16
 53200 558                     CIF
 53300 559                     IDATA(NPZSP1+1)=HWRK(2*IPCO+4)
 53400 560                     ADATA(NPZSP1+2)=WRK(IPCO+6)
 53500 561                     ADATA(NPZSP1+3)=WRK(IPCO+5)
 53600 562                     IDATA(NPZSP1+4)=IFL
 53700 563                     ADATA(NPZSP1+5)=WRK(IPCO+7)
 53800 564                     NPZSP1=NPZSP1+5
 53900 565                  CFOR
 54000 567               CFOR
 54100 569            CIF
 54200 570         CIF
 54300 571      CPROC
 54400    C=======================================================================
 54500 573      PROC STVSEA
 54600    C  SEARCH FOR STARTING VALUES
 54700    C
 54800    C  ORDER ACCORDING TO S
 54900 574         CALL SHELL9(KSZSRT(1,1),KSORT3,NHALL)
 55000 575         NH9=NHALL
 55100 576         WHILE KSZSRT(KSORT3(NH9),1).GT.99999
 55200 578            NH9=NH9-1
 55300 582         CWHILE
 55400 584         NH99=NH9
 55500 585         NH1=1
 55600 586         LFOUND=0
 55700 587         NHMAX=0
 55800 588         CI2MAX=1.E10
 55900 589         WHILE NH9.GT.NH1
 56000 591            FOR KK=1,3
 56100 595               IF KK.EQ.1
 56200 596               THEN
 56300 599                  JH1=NH1
 56400 600                  JH9=NH9
 56500 601               ELSE
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE 10
0CARD TARGET
  NO  STM.NO
 
 56600 603                  IF KK.EQ.2
 56700 604                  THEN
 56800 607                     JH9=JH9-1
 56900 608                  ELSE
 57000 610                     JH9=JH9+1
 57100 611                     JH1=JH1+1
 57200 612                  CIF
 57300 613               CIF
 57400 614               IF JH9.GT.JH1
 57500 615               THEN
 57600 618                  AS1=KSZSRT(KSORT3(JH1),1)
 57700 619                  AS9=KSZSRT(KSORT3(JH9),1)
 57800 620                  IF(AS9.LT.AS1+5.) XWHILE
 57900 622                  AZ1=KSZSRT(KSORT3(JH1),2)
 58000 623                  AZ9=KSZSRT(KSORT3(JH9),2)
 58100 624                  PAR1=(AZ9-AZ1)/(AS9-AS1)
 58200 625                  PAR2=AZ1-PAR1*AS1
 58300 626                  NHFIT=0
 58400 627                  CI2=0.
 58500 628                  FOR I=1,NH99
 58600 629                     DZ=ABS(KSZSRT(KSORT3(I),2)-PAR1*KSZSRT(KSORT3(I),1)
 58700         +               -PAR2)
 58800 630                     IF DZ.LT.RESCUT
 58900 631                     THEN
 59000 634                        NHFIT=NHFIT+1
 59100 635                        CI2=CI2+DZ**2
 59200 636                     CIF
 59300 637                  CFOR
 59400 639                  IF NHFIT.GT.NHPOT*.75
 59500 640                  THEN
 59600 643                     LFOUND=1
 59700 644                     XWHILE
 59800 645                  CIF
 59900 646                  IF NHFIT.GT.NHMAX .OR.NHFIT.EQ.NHMAX.AND.CI2.LT.CI2MAX
 60000 647                  THEN
 60100 650                     NHMAX=NHFIT
 60200 651                     P1MAX=PAR1
 60300 652                     P2MAX=PAR2
 60400 653                     CI2MAX=CI2
 60500 654                  CIF
 60600 655               CIF
 60700 656            CFOR
 60800 658            NH1=NH1+1
 60900 659            NH9=NH9-1
 61000 660         CWHILE
 61100 662         IF LFOUND.EQ.0 .AND. NHMAX.GT.0
 61200 663         THEN
 61300 666            NHFIT=NHMAX
 61400 667            PAR1=P1MAX
 61500 668            PAR2=P2MAX
 61600 669         CIF
 61700 670      CPROC
 61800 672      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         671 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         671 TARGET STATEMENTS
 00000    C   03/03/80 106101800  MEMBER NAME  ZVERTF   (JADEGS)      SHELTRAN
 00100    C   12/11/79 911141755  MEMBER NAME  OLZVERTF (JADESR)      SHELTRAN
 00200    C   04/07/79 C9070601   MEMBER NAME  ZVERTY   (JADESR)      SHELTRAN
 00300    C   04/07/79 C9070401   MEMBER NAME  ZVERTZ   (UKSOR)       SHELTRAN
 00400    C   03/07/79 C9070401   MEMBER NAME  ZVERTY   (JADESR)      SHELTRAN
 00500    C   29/06/79 C9070201   MEMBER NAME  ZVERTF   (JADEGS)      SHELTRAN
 00600    C   28/03/79 C9062901   MEMBER NAME  ORZVERTF (JADESR)      SHELTRAN
 00700    C   13/03/79 C9032801   MEMBER NAME  ORZVERTF (JADESR)      SHELTRAN
 00800    C   07/03/79 C9031301   MEMBER NAME  ZVERTF8  (JADESR)      SHELTRAN
 00900   2      SUBROUTINE ZVERTF
 01000    C
 01100    C     CALCULATION OF Z-VERTEX: P.STEFFEN(78/11/15)
 01200    C
 01300   3      IMPLICIT INTEGER*2 (H)
 01400    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 --------------------------
 01600    C
          C-----------------------------------------------------------------------
          C                            MACRO CGRAPH .... GRAPHICS COMMON
          C-----------------------------------------------------------------------
          C
         8      LOGICAL DSPDTL,SSTPS,PSTPS,FREEZE
          C
         9      COMMON / CGRAPH / JUSCRN,NDDINN,NDDOUT,IDATSV(11),ICREC,MAXREC,
               +                  LSTCMD,ACMD,LASTVW,ISTANV,
               +                  SXIN,SXAX,SYIN,SYAX,XMIN,XMAX,YMIN,YMAX,
               +                  DSPDTL(30),SSTPS(10),PSTPS(10),FREEZE(30),
               +                  IREADM,LABEL,LSTPS(10),IPSVAR
          C
          C------- END OF MACRO CGRAPH -------------------------------------------
          C
 00100    C====MACRO CZVPAR===================================
 00200    C-------------------------------------------
 00300    C   RESULTS FROM ZVERTF
 00400    C   P. STEFFEN (79/01/26)
 00500    C---------------------------------------------
 00600  10      COMMON /CZVPAR/ LBZVDF,ZLOW,  BINZ,  NBINZ,
 00700         ,                NWRDR1,LWRDC0,LWRDC1,LWRDC2,
 00800         ,                IDZ1LM,IDZ2LM,NPKMIN,SBRAT,DFIMAX,
 00900         ,                DZVPAR(5)
 01000    C==ENDMACRO CZVPAR========================================
 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),
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 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 CLBPGM ....
          C------------------------------------------
        13      COMMON /CLBPGM/ LBPGM(30)
          C--------- END OF MACRO CLBPGM ------------
 02200    C
 00100    C====  MACRO CWORKZV  ==================================
 00200    C-------------------------------------------
 00300    C   RESULTS + INTERM. STORAGE OF ZVERTF
 00400    C   P. STEFFEN (79/01/21)
 00500    C---------------------------------------------
 00600  14      COMMON /CWORK/ FZRSLT(12)
 00700         ,             , HUFLO,HOFLO,MAXZ,HIST(100)
 00800         ,             , HPTSEC(98)
 00900         ,             , NZ1(16),NZ2(16), HLB1(8),HLB2(8)
 01000         ,        , HZ1(8,16),HZ2(16,16), FI1(8,16),FI2(8,16),HTMP(100)
 01100  15      INTEGER*4 HPTSEC
 01110  16      INTEGER IZRSLT(12)
 01200  17      EQUIVALENCE (IZRSLT(1),FZRSLT(1))
 01300    C
 01400    C==  ENDMACRO CWORKZV  ========================================
 02400    C
 02500    C
 02700  18      LBPGM(2) = LBPGM(2) + 1                                            SET PROGRAM LABEL
 02800    C
 02900  19      DATA MKLAYR /15/
 03000    C
 03200  20      DATA LBINIT /0/                                                    INITIALIZATION
 03300  21      IF LBINIT.EQ.0
 03400  22      THEN
 03500  25         LBINIT = 1
 03600  26         IQJETC = IBLN('JETC')
 03800  27         IZCON = ZAL*.5                                                  COMMON FACTOR FOR Z(VERT.) CALC.
 03900  28         IZMAX = ZMAX + 40.
 04000  29      CIF
 04100    C
 04300    C                                                                        HISTOGRAM PARAMETERS
 04400                                                                             SET UP CYCLIC POINTER ARRAY
 04600  30      IPJCA  = IDATA(IQJETC)                                             ADDRESS OF POINTERS TO CELLS (-1)
 04700  31      IPJCA2 = IPJCA*2 + 2
 04800    C
 05000  32      IP0 = IPJCA2 + 98                                                  COPY CELL POINTERS + CALC. LENGTH
 05100  33      ISEGO = IPJCA2
 05200  34      FOR ISEG=1,96
 05300  35         ISEGO = ISEGO + 1
 05400  36         HPTSEC(ISEG) = HDATA(ISEGO) + IP0
 05500  37      CFOR
 05600  39      HPTSEC(97) = HDATA(ISEGO+1) + IP0
 05700  40      HPTSEC(98) = 0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 05800    C
 05900  41      FZRSLT(1) = 0.
 06000  42      FZRSLT(2) = 1000000.
 06100  43      FZRSLT(3) = 1000000.
 06200  44      FZRSLT(4) = 0.
 06300  45      FZRSLT(5) = 0.
 06400  46      IZRSLT(6) =-2
 06500  47      INDLB = 3
 06600    C
 06800  48      DFIMX0 = DFIMAX                                                    DET. ZVTX FROM R1 + R2
 06900  49      PERFORM ZVTX12
 07000    C
 07200  52      IF IZRSLT(6).LT.3                                                  CHECK IF NO GOOD VERTEX FOUND
 07300  53      THEN
 07500  56         IZRSLT( 7) = IZRSLT( 1)                                         NO GOOD VERTEX FOUND, SAVE RESULTS
 07600  57         IZRSLT( 8) = IZRSLT( 2)
 07700  58         IZRSLT( 9) = IZRSLT( 3)
 07800  59         IZRSLT(10) = IZRSLT( 4)
 07900  60         IZRSLT(11) = IZRSLT( 5)
 08000  61         IZRSLT(12) = IZRSLT( 6)
 08200  62         DFIMX0 = 1000.                                                  TRY ZVTX FROM R2 + R3
 08300  63         PERFORM ZVTX23
 08500  66         IF IZRSLT(6).LE.IZRSLT(12)                                      CHECK IF WORSE VERTEX
 08600  67         THEN
 08800  70            IZRSLT( 1) = IZRSLT( 7)                                      RESTORE OLD RESULTS
 08900  71            IZRSLT( 2) = IZRSLT( 8)
 09000  72            IZRSLT( 3) = IZRSLT( 9)
 09100  73            IZRSLT( 4) = IZRSLT(10)
 09200  74            IZRSLT( 5) = IZRSLT(11)
 09300  75            IZRSLT( 6) = IZRSLT(12)
 09400  76         CIF
 09500  77      CIF
 09600    C
 09800  78      NWRES = 6                                                          SET BOS BANK OF RESULTS
 09900  79      CALL CCRE(IPHT,'ZVTX',0,NWRES,IERR)
 10000  80      IF(IERR.NE.0) RETURN
 10100  82      CALL BSAW(1,'ZVTX')
 10200  83      ADATA(IPHT+1) = FZRSLT(1)
 10300  84      ADATA(IPHT+2) = FZRSLT(2)
 10400  85      ADATA(IPHT+3) = FZRSLT(3)
 10500  86      ADATA(IPHT+4) = FZRSLT(4)
 10600  87      ADATA(IPHT+5) = FZRSLT(5)
 10700  88      ADATA(IPHT+6) = FZRSLT(6)
 10800    C
 11000    C---  PSTPS(INDLB) = .TRUE.                                              SET STOP LABEL
 11100    C
 11200  89      RETURN
 11300    C
 11400                                                                             *************************
 11500                                                                             *      Z V T X 1 2      *
 11600                                                                             *************************
 11800    C                                                                        DETERMINE ZVTX FROM R1 + R2
 11900  90      PROC ZVTX12
 12000    C
 12100  91         BINZIV = 1. / BINZ
 12200  92         PAR1 = FSENSW(1) / (FSENSW(2) - FSENSW(1))
 12300  93         PAR2 =  RINCR(1) / (FSENSW(2) - FSENSW(1))
 12400  94         HUFLO = 0
 12500  95         HOFLO = 0
 12600  96         MAXZ = 0
 12700  97         NBACK = 0
 12900  98         CALL SETS(HIST(1),0,200,0)                                      ZERO HISTOGRAM
 13000    C
 13200  99         IF HPTSEC(25)-HPTSEC(1) .LT. NWRDR1                             CHECK IF AT LEAST 10 HITS IN 1. RING
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 13300 100         THEN
 13400 103            IZRSLT(6) = -2
 13500 104            INDLB = 1
 13600 105         ELSE
 13700    C
 13800
 14000 107            JSEC=1                                                       LOOP OVER ALLSECTOR(RING1): JSEC = SECTOR NUMBER +
 14100 108            REPEAT
 14300 109               NWRD1 = HPTSEC(JSEC+1) - HPTSEC(JSEC)                     # OF WORDS IN SECT
 14400 110               NWRD2 = HPTSEC(JSEC+25) - HPTSEC(JSEC+24)
 14600 111               IF NWRD1.GE.LWRDC0                                        CHECK IF MORE THAN 1 HIT
 14700 112               THEN
 14900 115                  IF JSEC.EQ.1                                           # OF WORDS IN LEFT ADJ SECT
 15000 116                  THEN
 15100 119                     NWRD1L= HPTSEC(25) - HPTSEC(24)
 15200 120                     NWRD2L= HPTSEC(49) - HPTSEC(48)
 15300 121                  ELSE
 15400 123                     NWRD1L= HPTSEC(JSEC   ) - HPTSEC(JSEC- 1)
 15500 124                     NWRD2L= HPTSEC(JSEC+24) - HPTSEC(JSEC+23)
 15600 125                  CIF
 15800 126                  IF JSEC.EQ.24                                          # OF WORDS IN RGHT ADJ SECT
 15900 127                  THEN
 16000 130                     NWRD1R= HPTSEC( 2) - HPTSEC( 1)
 16100 131                     NWRD2R= HPTSEC(26) - HPTSEC(25)
 16200 132                  ELSE
 16300 134                     NWRD1R= HPTSEC(JSEC+ 2) - HPTSEC(JSEC+ 1)
 16400 135                     NWRD2R= HPTSEC(JSEC+26) - HPTSEC(JSEC+25)
 16500 136                  CIF
 16700 137                  IF NWRD1+NWRD1L.GE.LWRDC1 .OR. NWRD1+NWRD1R.GE.LWRDC1  CHECK IF MORE THAN 12 HITS
 16800 138                  THEN
 16900                                                                             CHECK IF .GT. 10 HITS IN CORRSP SECT
 17000 141                     IF NWRD2L+NWRD2.GE.LWRDC2 .OR. NWRD2R+NWRD2.GE.LWRDC2
 17100 142                     THEN
 17300 145                        PERFORM ZCOL12                                   COLLECT ALL Z IN RING 1 + 2
 17500 148                        PERFORM HSTFLL                                   FILL HISTOGRAM
 17600 151                     CIF
 17700 152                  CIF
 17800 153               CIF
 17900 154               JSEC = JSEC + 1
 18000 155            UNTIL JSEC.GT.24
 18100    C
 18200 156            CALL MVC(HTMP(1),0,HIST(1),0,200)
 18300 160            PERFORM HEVAL
 18400    C
 18500 163         CIF
 18600 164      CPROC
 18700    C
 18800                                                                             *************************
 18900                                                                             *      Z C O L 1 2      *
 19100    C                                                                        *************************
 19300 166      PROC ZCOL12                                                        ****  COLLECT ALL Z IN RING 1 + 2  *****
 19400    C
 19600 167         FOR ILAYR=1,16                                                  ZERO HIT COUNTERS FOR EACH LAYER
 19700 168            NZ1(ILAYR) = 0
 19800 169            NZ2(ILAYR) = 0
 19900 170         CFOR
 20100 172         DSBIN1 = TIMDEL(1,1)                                            DRIFT SPACE BINS
 20200 173         DSBIN2 = TIMDEL(2,1)
 20400 174         IPT0 = HPTSEC(JSEC)                                             SET POINTERS OF SC1
 20500 175         IPT9 = HPTSEC(JSEC+1) - 1
 20700 176         FOR IPT = IPT0,IPT9,4                                           LOOP OVER ALL HITS IN SC1
 20900 177            IWIRE = HDATA(IPT)                                           SET WIRE #
 21000 178            IWIRE = SHFTR(IWIRE,3)
 21100 179            ILAYR = LAND(IWIRE,MKLAYR) + 1
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 21300 180            IAMPL = HDATA(IPT+1)                                         STORE HIT
 21400 181            IAMPR = HDATA(IPT+2)
 21500 182            IF IAMPL.GT.0 .AND. IAMPR.GT.0
 21600 183            THEN
 21700 186               IZ1 = (IZCON * (IAMPR-IAMPL)) / (IAMPR+IAMPL)
 21900 187               IF IABS(IZ1).LT.IZMAX                                     CHECK IF Z INSIDE ID
 22000 188               THEN
 22100 191                  NZ1(ILAYR) = NZ1(ILAYR) + 1
 22200 192                  IHIT = NZ1(ILAYR)
 22300 193                  HZ1(IHIT,ILAYR) = IZ1
 22500 194                  IF(ILAYR.GT.8) DSBIN1 = DSBIN2                         FI ANGLE
 22600 196                  DRLAY = (ILAYR-1) * RINCR(1)
 22700 197                  FI1(IHIT,ILAYR) = HDATA(IPT+3)*DSBIN1 / (FSENSW(1)+DRLAY)
 22800 198               CIF
 22900 199            CIF
 23000 200         CFOR
 23200 202         JSECA=1                                                         LOOP OVER ADJACENT SECTORS
 23300 203         REPEAT
 23400 204            JSEC2 = JSEC + JSECA + 22
 23500 205            IF(JSEC2.LT.25) JSEC2 = 48
 23600 207            IF(JSEC2.GT.48) JSEC2 = 25
 23800 209            IPT0 = HPTSEC(JSEC2)                                         SET POINTERS OF SC2
 23900 210            IPT9 = HPTSEC(JSEC2+1) - 1
 24000 211            IF IPT9.GT.IPT0
 24100 212            THEN
 24300 215               DSBIN1 = TIMDEL(1,2)                                      DRIFT SPACE BINS
 24400 216               DSBIN2 = TIMDEL(2,2)
 24600 217               FOR IPT = IPT0,IPT9,4                                     LOOP OVER ALL HITS IN SC1
 24800 218                  IWIRE = HDATA(IPT)                                     SET WIRE #
 24900 219                  IWIRE = SHFTR(IWIRE,3)
 25000 220                  ILAYR = LAND(IWIRE,MKLAYR) + 1
 25200 221                  IAMPL = HDATA(IPT+1)                                   STORE HIT
 25300 222                  IAMPR = HDATA(IPT+2)
 25400 223                  IF IAMPL.GT.0 .AND. IAMPR.GT.0
 25500 224                  THEN
 25600 227                     IZ2 = (IZCON * (IAMPR-IAMPL)) / (IAMPR+IAMPL)
 25800 228                     IF IABS(IZ2).LT.IZMAX                               CHECK IF Z INSIDE ID
 25900 229                     THEN
 26000 232                        NZ2(ILAYR) = NZ2(ILAYR) + 1
 26100 233                        IHIT = NZ2(ILAYR)
 26200 234                        HZ2(IHIT,ILAYR) = IZ2
 26400 235                        IF(ILAYR.GT.8) DSBIN1 = DSBIN2                   FI ANGLE
 26500 237                        DS = HDATA(IPT+3)*DSBIN1
 26600 238                        IF(JSECA.NE.2)
 26700         ?                  DS = DSMAX(ILAYR,2,1)+DSMAX(ILAYR,2,2) - DS
 26800 240                        DRLAY = (ILAYR-1) * RINCR(2)
 26900 241                        FI2(IHIT,ILAYR) = DS / (FSENSW(2)+DRLAY)
 27000 242                     CIF
 27100 243                  CIF
 27200 244               CFOR
 27300 246            CIF
 27400 247            JSECA = JSECA + 1
 27500 248         UNTIL JSECA.GT.3
 27600    C
 27700 249      CPROC
 27800    C
 27900                                                                             *************************
 28000                                                                             *      Z V T X 2 3      *
 28200    C                                                                        *************************
 28400 254      PROC ZVTX23                                                        DETERMINE ZVTX FROM R2 + R3
 28500    C
 28700 255         BINZIV = .5 / BINZ                                              INITIALIZE HISTOGRAM
 28800 256         PAR1 = FSENSW(2) / (FSENSW(3) - FSENSW(2))
 28900 257         PAR2 =  RINCR(2) / (FSENSW(3) - FSENSW(2))
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 29000 258         HUFLO = 0
 29100 259         HOFLO = 0
 29200 260         MAXZ = 0
 29300 261         NBACK = 0
 29500 262         CALL SETS (HIST(1),0,200,0)                                     ZERO HISTOGRAM
 29600 263         CALL SETSL(FI1(1,1),0,1024,0)
 29700    C
 29900 264         IF HPTSEC(97)-HPTSEC(49) .LT. NWRDR1                            CHECK IF AT LEAST 10 HITS IN 3. RING
 30000 265         THEN
 30100 268            IZRSLT(6) = -2
 30200 269            INDLB = 1
 30300 270         ELSE
 30400    C
 30500
 30700 272            ICLL=49                                                      LOOP OVER ALL SECTORS(RING1): ICLL = SECTOR NUMBER
 30800 273            REPEAT
 31000 274               NWRD1 = HPTSEC(ICLL+1) - HPTSEC(ICLL)                     # OF WORDS IN SECT
 31200 275               IF NWRD1.GE.LWRDC0                                        CHECK IF MORE THAN 1 HIT
 31300 276               THEN
 31500 279                  IF ICLL.EQ.49                                          # OF WORDS IN LEFT ADJ SECT
 31600 280                  THEN
 31700 283                     NWRD1L= HPTSEC(97) - HPTSEC(96)
 31800 284                  ELSE
 31900 286                     NWRD1L= HPTSEC(ICLL   ) - HPTSEC(ICLL- 1)
 32000 287                  CIF
 32200 288                  IF ICLL.EQ.96                                          # OF WORDS IN RGHT ADJ SECT
 32300 289                  THEN
 32400 292                     NWRD1R= HPTSEC(50) - HPTSEC(49)
 32500 293                  ELSE
 32600 295                     NWRD1R= HPTSEC(ICLL+ 2) - HPTSEC(ICLL+ 1)
 32700 296                  CIF
 32900 297                  IF NWRD1+NWRD1L.GE.LWRDC1 .OR. NWRD1+NWRD1R.GE.LWRDC1  CHECK IF MORE THAN 12 HITS
 33000 298                  THEN
 33200 301                     IF ICLL.EQ.49 .OR. ICLL.EQ.96                       CHECK IF .GT. 10 HITS IN CORRSP SECT
 33300 302                     THEN
 33400 305                        NWRD2 = HPTSEC(25)-HPTSEC(24) + HPTSEC(49)-HPTSEC(48)
 33500 306                     ELSE
 33600 308                        ICLL2L = ICLL/2
 33700 309                        NWRD2 = HPTSEC(ICLL2L+2) - HPTSEC(ICLL2L)
 33800 310                     CIF
 33900 311                     IF NWRD2.GE.LWRDC2
 34000 312                     THEN
 34200 315                        PERFORM ZCOL23                                   COLLECT ALL Z IN RING 1 + 2
 34400 318                        PERFORM HSTFLL                                   FILL HISTOGRAM
 34500 321                     CIF
 34600 322                  CIF
 34700 323               CIF
 34800 324               ICLL = ICLL + 1
 34900 325            UNTIL ICLL.GT.96
 35000    C
 35100 326            CALL MVC(HTMP(1),0,HIST(1),0,200)
 35200 330            PERFORM HEVAL
 35300    C
 35400 333         CIF
 35500 334      CPROC
 35600    C
 35700                                                                             *************************
 35800                                                                             *      Z C O L 2 3      *
 36000    C                                                                        *************************
 36100    C
 36300 336      PROC ZCOL23                                                        ****  COLLECT ALL Z IN RING 2 + 3  *****
 36400    C
 36600 337         FOR ILAYR=1,16                                                  ZERO HIT COUNTERS FOR EACH LAYER
 36700 338            NZ1(ILAYR) = 0
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 36800 339            NZ2(ILAYR) = 0
 36900 340         CFOR
 37000                                                                             DRIFT SPACE BINS
 37200 342         IPT0 = HPTSEC(ICLL)                                             SET POINTERS OF SC1
 37300 343         IPT9 = HPTSEC(ICLL+1) - 1
 37500 344         FOR IPT = IPT0,IPT9,4                                           LOOP OVER ALL HITS IN SC1
 37700 345            IWIRE = HDATA(IPT)                                           SET WIRE #
 37800 346            IWIRE = SHFTR(IWIRE,3)
 37900 347            ILAYR = LAND(IWIRE,MKLAYR) + 1
 38100 348            IAMPL = HDATA(IPT+1)                                         STORE HIT
 38200 349            IAMPR = HDATA(IPT+2)
 38300 350            IF IAMPL.GT.0 .AND. IAMPR.GT.0
 38400 351            THEN
 38500 354               IZ1 = (IZCON * (IAMPR-IAMPL)) / (IAMPR+IAMPL)
 38700 355               IF IABS(IZ1).LT.IZMAX                                     CHECK IF Z INSIDE ID
 38800 356               THEN
 38900 359                  NZ2(ILAYR) = NZ2(ILAYR) + 1
 39000 360                  IHIT = NZ2(ILAYR)
 39100 361                  HZ2(IHIT,ILAYR) = IZ1
 39200 362               CIF
 39300 363            CIF
 39400 364         CFOR
 39600 366         ICLLA=0                                                         LOOP OVER ADJACENT SECTORS
 39700 367         REPEAT
 39800 368            ICLL2 = ICLL/2 + ICLLA
 39900 369            IF(ICLL2.LT.25) ICLL2 = 48
 40000 371            IF(ICLL2.GT.48) ICLL2 = 25
 40200 373            IPT0 = HPTSEC(ICLL2)                                         SET POINTERS OF SC2
 40300 374            IPT9 = HPTSEC(ICLL2+1) - 1
 40400 375            IF IPT9.GT.IPT0
 40500 376            THEN
 40700 379               FOR IPT = IPT0,IPT9,4                                     LOOP OVER ALL HITS IN SC1
 40900 380                  IWIRE = HDATA(IPT)                                     SET WIRE #
 41000 381                  IWIRE = SHFTR(IWIRE,3)
 41100 382                  ILAYR = LAND(IWIRE,MKLAYR) + 1
 41300 383                  IAMPL = HDATA(IPT+1)                                   STORE HIT
 41400 384                  IAMPR = HDATA(IPT+2)
 41500 385                  IF IAMPL.GT.0 .AND. IAMPR.GT.0
 41600 386                  THEN
 41700 389                     IZ1 = (IZCON * (IAMPR-IAMPL)) / (IAMPR+IAMPL)
 41900 390                     IF IABS(IZ1).LT.IZMAX                               CHECK IF Z INSIDE ID
 42000 391                     THEN
 42100 394                        NZ1(ILAYR) = NZ1(ILAYR) + 1
 42200 395                        IHIT = NZ1(ILAYR)
 42300 396                        HZ1(IHIT,ILAYR) = IZ1
 42400 397                     CIF
 42500 398                  CIF
 42600 399               CFOR
 42700 401            CIF
 42800 402            ICLLA = ICLLA + 1
 42900 403         UNTIL ICLLA.GT.1
 43000    C
 43100 404      CPROC
 43200    C
 43300                                                                             *************************
 43400                                                                             *      H S T F L L      *
 43600    C                                                                        *************************
 43800 409      PROC HSTFLL                                                        FILL HISTOGRAM
 44000 410         FOR ILAYR=1,16                                                  LOOP OVER ALL LAYERS
 44100 411            MZ1 = NZ1(ILAYR)
 44200 412            MZ2 = NZ2(ILAYR)
 44400 413            IF MZ1.GT.0 .AND. MZ2.GT.0                                   CHECK IF HITS
 44500 414            THEN
 44700 417               FACT = (ILAYR-1)*PAR2 + PAR1                              CALC. COMMON FACTOR
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 44900 418               FOR IHIT1=1,MZ1                                           LOOP OVER HITS(SC1)
 45000 419                  Z1 = HZ1(IHIT1,ILAYR)
 45100 420                  FI01 = FI1(IHIT1,ILAYR)
 45300 421                  FOR IHIT2=1,MZ2                                        LOOP OVER HITS(SC2)
 45500 422                     DFI = ABS(FI01 - FI2(IHIT2,ILAYR))                  MOMENTUM CUT (DFI .LT. DFIMAX)
 45600 423                     IF DFI.LT.DFIMX0
 45700 424                     THEN
 45800 427                        Z2 = HZ2(IHIT2,ILAYR)
 46000 428                        ZV = Z1 - (Z2-Z1)*FACT                           Z(VERTEX)
 46200 429                        IZV = (ZV-ZLOW) * BINZIV + 1                     CALC. HIST. INDEX + PLOT
 46300 430                        IF IZV.GT.0 .AND. IZV.LE.100
 46400 431                        THEN
 46500 434                           HIST(IZV) = HIST(IZV) + 1
 46600 435                        ELSE
 46700 437                           IF(IZV.LE.  0) HUFLO = HUFLO + 1
 46800 439                           IF(IZV.GT.NBINZ) HOFLO = HOFLO + 1
 46900 441                        CIF
 47000 442                     CIF
 47100 443                  CFOR
 47200 445               CFOR
 47300 447            CIF
 47400 448         CFOR
 47500 450      CPROC
 47600    C
 47800 452      PROC HEVAL                                                         *****  H I S T. E V A L U A T I O N  *****
 47900 453         IZCNT=0
 48000 454         ICODE=0
 48100 455         ZPREV=-1000000.
 48200    C     PRINT 2001, HIST
 48300    C2001 FORMAT('0HIST:',50I2,/,6X,50I2)
 48400 456         WHILE IZCNT.LT.5
 48600 458            MAXHST = 0                                                   FIND BIN WITH MAX.CONTENT
 48700 462            NHIST1 = 0
 48800 463            FOR IHIST = 1,NBINZ
 48900 464               NHIST1 = NHIST1 + HTMP(IHIST)
 49000 465               IF(HTMP(IHIST).GT.MAXHST) MAXHST =HTMP(IHIST)
 49100 467            CFOR
 49200 469            MAXZ = MAXHST
 49400 470            NPEAK = 0                                                    FIND PEAK
 49500 471            IH9 = NBINZ-11
 49600 472            FOR IH=7,IH9
 49700 473               IHSUM = HTMP(IH)+HTMP(IH+1)+HTMP(IH+2)+HTMP(IH+3)+HTMP(IH+4)
 49800 474               IF IHSUM.GT.NPEAK
 49900 475               THEN
 50100 478                  NPEAK = IHSUM                                          MEMORIZE PEAK
 50200 479                  HPEAK = IH
 50300 480               CIF
 50400 481            CFOR
 50500 483            IF NPEAK.EQ.0
 50600 484            THEN
 50700 487               XWHILE
 50800 488            CIF
 50900 489            PEAK = NPEAK
 51000 490            H1 = HPEAK - 7
 51100 491            H2 = HPEAK + 7
 51200 492            NBACK = HTMP(H1  )+HTMP(H1+1)+HTMP(H1+2)+HTMP(H1+3)+HTMP(H1+4)
 51300         +      + HTMP(H2  )+HTMP(H2+1)+HTMP(H2+2)+HTMP(H2+3)+HTMP(H2+4)
 51400 493            BACK = .5 * NBACK
 51500    C
 51700 494            ZV = HTMP(HPEAK+1)   +HTMP(HPEAK+2)*2                        CALC. ACCURATE PEAK POS.
 51800         +      +HTMP(HPEAK+3)*3 +HTMP(HPEAK+4)*4
 51900 495            ZV = ZV / PEAK
 52000 496            ZVTX      = (HPEAK+ZV-.5)/BINZIV + ZLOW
 52100 497            DZ =HTMP(HPEAK  )*(ZV   )**2 +HTMP(HPEAK+1)*(ZV-1.)**2
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 52200         +      +HTMP(HPEAK+2)*(ZV-2.)**2 +HTMP(HPEAK+3)*(ZV-3.)**2
 52300         +      +HTMP(HPEAK+4)*(ZV-4.)**2
 52400 498            IF(NPEAK.GT.NPKMIN) ICODE=ICODE+1
 52500 500            SGN  = (PEAK - BACK)**2
 52600 501            DSGN = BACK*.5 + PEAK
 52700 502            IF(SGN/DSGN.GE.SBRAT .AND. NPEAK.GT.2) ICODE=ICODE+2
 52800    C     PRINT 2002, HPEAK,ZVTX,PEAK,BACK,SGN,DSGN
 52900    C2002 FORMAT('0PEAK:',I6,5F8.2)
 53000 504            IF ICODE.GE.IZRSLT(6)
 53100 505            THEN
 53200 508               IF ICODE.EQ.IZRSLT(6).AND.ABS(ZVTX).GT.ABS(ZPREV)
 53300 509               THEN
 53400 512                  XWHILE
 53500 513               CIF
 53600 514               IZCNT=IZCNT+1
 53700 515               SCPEAK = BACK * .2
 53800 516               HTMP(HPEAK-2)=SCPEAK
 53900 517               HTMP(HPEAK-1)=SCPEAK
 54000 518               HTMP(HPEAK  )=SCPEAK
 54100 519               HTMP(HPEAK+1)=SCPEAK
 54200 520               HTMP(HPEAK+2)=SCPEAK
 54300 521               HTMP(HPEAK+3)=SCPEAK
 54400 522               HTMP(HPEAK+4)=SCPEAK
 54500 523               HTMP(HPEAK+5)=SCPEAK
 54600 524               HTMP(HPEAK+6)=SCPEAK
 54700 525               FZRSLT(2) = DZ / (BINZIV**2 * PEAK)
 54800 526               FZRSLT(3) = FZRSLT(2) / PEAK
 54900 527               FZRSLT(2) = SQRT(FZRSLT(2))
 55000 528               FZRSLT(3) = SQRT(FZRSLT(3))
 55100 529               FZRSLT(4) = PEAK
 55200 530               FZRSLT(5) = BACK
 55300 531               FZRSLT(1) = ZVTX
 55400 532               IND = ABS(ZVTX)*.01 + 1.
 55500 533               IF(IND.GT.4) IND = 4
 55600 535               IF(IZRSLT(6).EQ.1) IND = IND + 4
 55700 537               INDLB = IND + 2
 55800 538               ZPREV=ZVTX
 55900 539               IZRSLT(6)=ICODE
 56000 540               ICODE=0
 56100 541            ELSE
 56200 543               XWHILE
 56300 544            CIF
 56400 545         CWHILE
 56500 547      CPROC
 56600    C
 56700 549      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         548 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 56800    C
 56900   2      SUBROUTINE INITZV
 57000    C
 57100    C     INITIALIZATION OF ZVERT LIMITS
 00100    C====MACRO CZVPAR===================================
 00200    C-------------------------------------------
 00300    C   RESULTS FROM ZVERTF
 00400    C   P. STEFFEN (79/01/26)
 00500    C---------------------------------------------
 00600   3      COMMON /CZVPAR/ LBZVDF,ZLOW,  BINZ,  NBINZ,
 00700         ,                NWRDR1,LWRDC0,LWRDC1,LWRDC2,
 00800         ,                IDZ1LM,IDZ2LM,NPKMIN,SBRAT,DFIMAX,
 00900         ,                DZVPAR(5)
 01000    C==ENDMACRO CZVPAR========================================
 57300    C
 57400                                                                             INITIALIZE DEFAULT PARAMETERS
 57600   4      LBZVDF = 1                                                         SET DEFAULT LABEL TO 1
 57800   5      ZLOW = -3500.                                                      HISTOGR. PARAMETERS
 57900   6      BINZ = 70.
 58000   7      NBINZ = 100
 58200   8      NWRDR1 = 24                                                        MIN. (NUMBER OF HITS)*4  IN RING 1
 58400   9      LWRDC0 = 8                                                         MIN. (NUMBER OF HITS)*4  IN SELECTED CELLS
 58600  10      LWRDC1 = 16                                                        MIN. (NUMBER OF HITS)*4  IN ADJ. CELLS OF R1
 58800  11      LWRDC2 = 16                                                        MIN. (NUMBER OF HITS)*4  IN ADJ. CELLS OF R2
 59000  12      IDZ1LM = 80                                                        LIMITS FOR TOO CLOSE HITS IN RING 1 + 2
 59100  13      IDZ2LM = 140
 59300  14      NPKMIN = 8                                                         MINIMUM PEAK HEIGHT
 59500  15      SBRAT  = 6.25                                                      MIN.: ((PEAK-BACK) / SIGMA)**2
 59700  16      DFIMAX = .1                                                        MAX. FI INCLINATION: P > 1GEV
 59800    C
 59900  17      RETURN
 60000  18      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          17 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         565 TARGET STATEMENTS
 00000    C   28/04/81            MEMBER NAME  ZVERTFPR (JADEGS)      SHELTRAN
 00100    C   03/03/80 104271818  MEMBER NAME  ZVERTFPR (JADESR)      SHELTRAN
 00200   2      SUBROUTINE ZVERTF
 00300    C
 00400    C     CALCULATION OF Z-VERTEX: P.STEFFEN(78/11/15)
 00500    C
 00600   3      IMPLICIT INTEGER*2 (H)
 00700    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 --------------------------
 00900    C
          C-----------------------------------------------------------------------
          C                            MACRO CGRAPH .... GRAPHICS COMMON
          C-----------------------------------------------------------------------
          C
         8      LOGICAL DSPDTL,SSTPS,PSTPS,FREEZE
          C
         9      COMMON / CGRAPH / JUSCRN,NDDINN,NDDOUT,IDATSV(11),ICREC,MAXREC,
               +                  LSTCMD,ACMD,LASTVW,ISTANV,
               +                  SXIN,SXAX,SYIN,SYAX,XMIN,XMAX,YMIN,YMAX,
               +                  DSPDTL(30),SSTPS(10),PSTPS(10),FREEZE(30),
               +                  IREADM,LABEL,LSTPS(10),IPSVAR
          C
          C------- END OF MACRO CGRAPH -------------------------------------------
          C
 00100    C====MACRO CZVPAR===================================
 00200    C-------------------------------------------
 00300    C   RESULTS FROM ZVERTF
 00400    C   P. STEFFEN (79/01/26)
 00500    C---------------------------------------------
 00600  10      COMMON /CZVPAR/ LBZVDF,ZLOW,  BINZ,  NBINZ,
 00700         ,                NWRDR1,LWRDC0,LWRDC1,LWRDC2,
 00800         ,                IDZ1LM,IDZ2LM,NPKMIN,SBRAT,DFIMAX,
 00900         ,                DZVPAR(5)
 01000    C==ENDMACRO CZVPAR========================================
 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 -----------------------
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  2
0CARD TARGET
  NO  STM.NO
 
 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 CLBPGM ....
          C------------------------------------------
        13      COMMON /CLBPGM/ LBPGM(30)
          C--------- END OF MACRO CLBPGM ------------
 01500    C
 00100    C====  MACRO CWORKZV  ==================================
 00200    C-------------------------------------------
 00300    C   RESULTS + INTERM. STORAGE OF ZVERTF
 00400    C   P. STEFFEN (79/01/21)
 00500    C---------------------------------------------
 00600  14      COMMON /CWORK/ FZRSLT(12)
 00700         ,             , HUFLO,HOFLO,MAXZ,HIST(100)
 00800         ,             , HPTSEC(98)
 00900         ,             , NZ1(16),NZ2(16), HLB1(8),HLB2(8)
 01000         ,        , HZ1(8,16),HZ2(16,16), FI1(8,16),FI2(8,16),HTMP(100)
 01100  15      INTEGER*4 HPTSEC
 01110  16      INTEGER IZRSLT(12)
 01200  17      EQUIVALENCE (IZRSLT(1),FZRSLT(1))
 01300    C
 01400    C==  ENDMACRO CWORKZV  ========================================
 01700    C
 01800    C
 02000  18      LBPGM(2) = LBPGM(2) + 1                                            SET PROGRAM LABEL
 02100    C
 02200  19      DATA MKLAYR /15/
 02300    C
 02500  20      DATA LBINIT /0/                                                    INITIALIZATION
 02600  21      IF LBINIT.EQ.0
 02700  22      THEN
 02800  25         LBINIT = 1
 02900  26         IQJETC = IBLN('JETC')
 03100  27         IZCON = ZAL*.5                                                  COMMON FACTOR FOR Z(VERT.) CALC.
 03200  28         IZMAX = ZMAX + 40.
 03300  29      CIF
 03400    C
 03600    C                                                                        HISTOGRAM PARAMETERS
 03700                                                                             SET UP CYCLIC POINTER ARRAY
 03900  30      IPJCA  = IDATA(IQJETC)                                             ADDRESS OF POINTERS TO CELLS (-1)
 04000  31      IPJCA2 = IPJCA*2 + 2
 04100    C
 04300  32      IP0 = IPJCA2 + 98                                                  COPY CELL POINTERS + CALC. LENGTH
 04400  33      ISEGO = IPJCA2
 04500  34      FOR ISEG=1,96
 04600  35         ISEGO = ISEGO + 1
 04700  36         HPTSEC(ISEG) = HDATA(ISEGO) + IP0
 04800  37      CFOR
 04900  39      HPTSEC(97) = HDATA(ISEGO+1) + IP0
 05000  40      HPTSEC(98) = 0
 05100  41      PRINT 2901, HPTSEC
 05200  42      I0 = IPJCA2 + 1
 05300  43      I9 = I0 + 97
 05400  44      PRINT 2901, (HDATA(I1),I1=I0,I9)
 05500  45 2901 FORMAT(1H0,/,(1X,24I5))
 05600    C
 05700  46      FZRSLT(1) = 0.
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  3
0CARD TARGET
  NO  STM.NO
 
 05800  47      FZRSLT(2) = 1000000.
 05900  48      FZRSLT(3) = 1000000.
 06000  49      FZRSLT(4) = 0.
 06100  50      FZRSLT(5) = 0.
 06200  51      IZRSLT(6) =-2
 06300  52      INDLB = 3
 06400    C
 06600  53      PRINT 2008                                                         DET. ZVTX FROM R1 + R2
 06700  54 2008 FORMAT('0PERFORM ZVTX12')
 06800  55      DFIMX0 = DFIMAX
 06900  56      PERFORM ZVTX12
 07000    C
 07200  59      IF IZRSLT(6).LT.3                                                  CHECK IF NO GOOD VERTEX FOUND
 07300  60      THEN
 07500  63         IZRSLT( 7) = IZRSLT( 1)                                         NO GOOD VERTEX FOUND, SAVE RESULTS
 07600  64         IZRSLT( 8) = IZRSLT( 2)
 07700  65         IZRSLT( 9) = IZRSLT( 3)
 07800  66         IZRSLT(10) = IZRSLT( 4)
 07900  67         IZRSLT(11) = IZRSLT( 5)
 08000  68         IZRSLT(12) = IZRSLT( 6)
 08200  69         PRINT 2009                                                      TRY ZVTX FROM R2 + R3
 08300  70 2009 FORMAT('0PERFORM ZVTX23')
 08400  71         DFIMX0 = 1000.
 08500  72         PERFORM ZVTX23
 08700  75         IF IZRSLT(6).LE.IZRSLT(12)                                      CHECK IF WORSE VERTEX
 08800  76         THEN
 09000  79            IZRSLT( 1) = IZRSLT( 7)                                      RESTORE OLD RESULTS
 09100  80            IZRSLT( 2) = IZRSLT( 8)
 09200  81            IZRSLT( 3) = IZRSLT( 9)
 09300  82            IZRSLT( 4) = IZRSLT(10)
 09400  83            IZRSLT( 5) = IZRSLT(11)
 09500  84            IZRSLT( 6) = IZRSLT(12)
 09600  85         CIF
 09700  86      CIF
 09800    C
 10000  87      NWRES = 6                                                          SET BOS BANK OF RESULTS
 10100  88      CALL CCRE(IPHT,'ZVTX',0,NWRES,IERR)
 10200  89      IF(IERR.NE.0) RETURN
 10300  91      CALL BSAW(1,'ZVTX')
 10400  92      ADATA(IPHT+1) = FZRSLT(1)
 10500  93      ADATA(IPHT+2) = FZRSLT(2)
 10600  94      ADATA(IPHT+3) = FZRSLT(3)
 10700  95      ADATA(IPHT+4) = FZRSLT(4)
 10800  96      ADATA(IPHT+5) = FZRSLT(5)
 10900  97      ADATA(IPHT+6) = FZRSLT(6)
 11000    C
 11200    C---  PSTPS(INDLB) = .TRUE.                                              SET STOP LABEL
 11300    C
 11400  98      RETURN
 11500    C
 11600                                                                             *************************
 11700                                                                             *      Z V T X 1 2      *
 11800                                                                             *************************
 12000    C                                                                        DETERMINE ZVTX FROM R1 + R2
 12100  99      PROC ZVTX12
 12200    C
 12300 100         BINZIV = 1. / BINZ
 12400 101         PAR1 = FSENSW(1) / (FSENSW(2) - FSENSW(1))
 12500 102         PAR2 =  RINCR(1) / (FSENSW(2) - FSENSW(1))
 12600 103         HUFLO = 0
 12700 104         HOFLO = 0
 12800 105         MAXZ = 0
 12900 106         NBACK = 0
 13100 107         CALL SETS(HIST(1),0,200,0)                                      ZERO HISTOGRAM
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  4
0CARD TARGET
  NO  STM.NO
 
 13200    C
 13400 108         IF HPTSEC(25)-HPTSEC(1) .LT. NWRDR1                             CHECK IF AT LEAST 10 HITS IN 1. RING
 13500 109         THEN
 13600 112            IZRSLT(6) = -2
 13700 113            INDLB = 1
 13800 114         ELSE
 13900    C
 14000
 14200 116            JSEC=1                                                       LOOP OVER ALLSECTOR(RING1): JSEC = SECTOR NUMBER +
 14300 117            REPEAT
 14500 118               NWRD1 = HPTSEC(JSEC+1) - HPTSEC(JSEC)                     # OF WORDS IN SECT
 14600 119               NWRD2 = HPTSEC(JSEC+25) - HPTSEC(JSEC+24)
 14800 120               IF NWRD1.GE.LWRDC0                                        CHECK IF MORE THAN 1 HIT
 14900 121               THEN
 15100 124                  IF JSEC.EQ.1                                           # OF WORDS IN LEFT ADJ SECT
 15200 125                  THEN
 15300 128                     NWRD1L= HPTSEC(25) - HPTSEC(24)
 15400 129                     NWRD2L= HPTSEC(49) - HPTSEC(48)
 15500 130                  ELSE
 15600 132                     NWRD1L= HPTSEC(JSEC   ) - HPTSEC(JSEC- 1)
 15700 133                     NWRD2L= HPTSEC(JSEC+24) - HPTSEC(JSEC+23)
 15800 134                  CIF
 16000 135                  IF JSEC.EQ.24                                          # OF WORDS IN RGHT ADJ SECT
 16100 136                  THEN
 16200 139                     NWRD1R= HPTSEC( 2) - HPTSEC( 1)
 16300 140                     NWRD2R= HPTSEC(26) - HPTSEC(25)
 16400 141                  ELSE
 16500 143                     NWRD1R= HPTSEC(JSEC+ 2) - HPTSEC(JSEC+ 1)
 16600 144                     NWRD2R= HPTSEC(JSEC+26) - HPTSEC(JSEC+25)
 16700 145                  CIF
 16900 146                  IF NWRD1+NWRD1L.GE.LWRDC1 .OR. NWRD1+NWRD1R.GE.LWRDC1  CHECK IF MORE THAN 12 HITS
 17000 147                  THEN
 17100                                                                             CHECK IF .GT. 10 HITS IN CORRSP SECT
 17200 150                     IF NWRD2L+NWRD2.GE.LWRDC2 .OR. NWRD2R+NWRD2.GE.LWRDC2
 17300 151                     THEN
 17500 154                        PERFORM ZCOL12                                   COLLECT ALL Z IN RING 1 + 2
 17700 157                        PERFORM HSTFLL                                   FILL HISTOGRAM
 17800 160                     CIF
 17900 161                  CIF
 18000 162               CIF
 18100 163               JSEC = JSEC + 1
 18200 164            UNTIL JSEC.GT.24
 18300    C
 18400 165            CALL MVC(HTEMP(1),0,HIST(1),0,200)
 18500 169            PERFORM HEVAL
 18600    C
 18700 172         CIF
 18800 173      CPROC
 18900    C
 19000                                                                             *************************
 19100                                                                             *      Z C O L 1 2      *
 19300    C                                                                        *************************
 19500 175      PROC ZCOL12                                                        ****  COLLECT ALL Z IN RING 1 + 2  *****
 19600    C
 19800 176         FOR ILAYR=1,16                                                  ZERO HIT COUNTERS FOR EACH LAYER
 19900 177            NZ1(ILAYR) = 0
 20000 178            NZ2(ILAYR) = 0
 20100 179         CFOR
 20300 181         DSBIN1 = TIMDEL(1,1)                                            DRIFT SPACE BINS
 20400 182         DSBIN2 = TIMDEL(2,1)
 20600 183         IPT0 = HPTSEC(JSEC)                                             SET POINTERS OF SC1
 20700 184         IPT9 = HPTSEC(JSEC+1) - 1
 20900 185         FOR IPT = IPT0,IPT9,4                                           LOOP OVER ALL HITS IN SC1
 21100 186            IWIRE = HDATA(IPT)                                           SET WIRE #
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  5
0CARD TARGET
  NO  STM.NO
 
 21200 187            IWIRE = SHFTR(IWIRE,3)
 21300 188            ILAYR = LAND(IWIRE,MKLAYR) + 1
 21500 189            IAMPL = HDATA(IPT+1)                                         STORE HIT
 21600 190            IAMPR = HDATA(IPT+2)
 21700 191            IF IAMPL.GT.0 .AND. IAMPR.GT.0
 21800 192            THEN
 21900 195               IZ1 = (IZCON * (IAMPR-IAMPL)) / (IAMPR+IAMPL)
 22100 196               IF IABS(IZ1).LT.IZMAX                                     CHECK IF Z INSIDE ID
 22200 197               THEN
 22300 200                  NZ1(ILAYR) = NZ1(ILAYR) + 1
 22400 201                  IHIT = NZ1(ILAYR)
 22500 202                  HZ1(IHIT,ILAYR) = IZ1
 22700 203                  IF(ILAYR.GT.8) DSBIN1 = DSBIN2                         FI ANGLE
 22800 205                  DRLAY = (ILAYR-1) * RINCR(1)
 22900 206                  FI1(IHIT,ILAYR) = HDATA(IPT+3)*DSBIN1 / (FSENSW(1)+DRLAY)
 23000 207               CIF
 23100 208            CIF
 23200 209         CFOR
 23400 211         JSECA=1                                                         LOOP OVER ADJACENT SECTORS
 23500 212         REPEAT
 23600 213            JSEC2 = JSEC + JSECA + 22
 23700 214            IF(JSEC2.LT.25) JSEC2 = 48
 23800 216            IF(JSEC2.GT.48) JSEC2 = 25
 24000 218            IPT0 = HPTSEC(JSEC2)                                         SET POINTERS OF SC2
 24100 219            IPT9 = HPTSEC(JSEC2+1) - 1
 24200 220            IF IPT9.GT.IPT0
 24300 221            THEN
 24500 224               DSBIN1 = TIMDEL(1,2)                                      DRIFT SPACE BINS
 24600 225               DSBIN2 = TIMDEL(2,2)
 24800 226               FOR IPT = IPT0,IPT9,4                                     LOOP OVER ALL HITS IN SC1
 25000 227                  IWIRE = HDATA(IPT)                                     SET WIRE #
 25100 228                  IWIRE = SHFTR(IWIRE,3)
 25200 229                  ILAYR = LAND(IWIRE,MKLAYR) + 1
 25400 230                  IAMPL = HDATA(IPT+1)                                   STORE HIT
 25500 231                  IAMPR = HDATA(IPT+2)
 25600 232                  IF IAMPL.GT.0 .AND. IAMPR.GT.0
 25700 233                  THEN
 25800 236                     IZ2 = (IZCON * (IAMPR-IAMPL)) / (IAMPR+IAMPL)
 26000 237                     IF IABS(IZ2).LT.IZMAX                               CHECK IF Z INSIDE ID
 26100 238                     THEN
 26200 241                        NZ2(ILAYR) = NZ2(ILAYR) + 1
 26300 242                        IHIT = NZ2(ILAYR)
 26400 243                        HZ2(IHIT,ILAYR) = IZ2
 26600 244                        IF(ILAYR.GT.8) DSBIN1 = DSBIN2                   FI ANGLE
 26700 246                        DS = HDATA(IPT+3)*DSBIN1
 26800 247                        IF(JSECA.NE.2)
 26900         ?                  DS = DSMAX(ILAYR,2,1)+DSMAX(ILAYR,2,2) - DS
 27000 249                        DRLAY = (ILAYR-1) * RINCR(2)
 27100 250                        FI2(IHIT,ILAYR) = DS / (FSENSW(2)+DRLAY)
 27200 251                     CIF
 27300 252                  CIF
 27400 253               CFOR
 27500 255            CIF
 27600 256            JSECA = JSECA + 1
 27700 257         UNTIL JSECA.GT.3
 27800    C
 27900 258      CPROC
 28000    C
 28100                                                                             *************************
 28200                                                                             *      Z V T X 2 3      *
 28400    C                                                                        *************************
 28600 263      PROC ZVTX23                                                        DETERMINE ZVTX FROM R2 + R3
 28700    C
 28900 264         BINZIV = .5 / BINZ                                              INITIALIZE HISTOGRAM
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  6
0CARD TARGET
  NO  STM.NO
 
 29000 265         PAR1 = FSENSW(2) / (FSENSW(3) - FSENSW(2))
 29100 266         PAR2 =  RINCR(2) / (FSENSW(3) - FSENSW(2))
 29200 267         HUFLO = 0
 29300 268         HOFLO = 0
 29400 269         MAXZ = 0
 29500 270         NBACK = 0
 29700 271         CALL SETS (HIST(1),0,200,0)                                     ZERO HISTOGRAM
 29800 272         CALL SETSL(FI1(1,1),0,1024,0)
 29900    C
 30100 273         IF HPTSEC(97)-HPTSEC(49) .LT. NWRDR1                            CHECK IF AT LEAST 10 HITS IN 3. RING
 30200 274         THEN
 30300 277            IZRSLT(6) = -2
 30400 278            INDLB = 1
 30500 279            PRINT 2911, HPTSEC(49),HPTSEC(97),NWRDR1
 30600 280 2911   FORMAT(' REJECT -2',10I6)
 30700 281         ELSE
 30800    C
 30900
 31100 283            ICLL=49                                                      LOOP OVER ALL SECTORS(RING1): ICLL = SECTOR NUMBER
 31200 284            REPEAT
 31400 285               NWRD1 = HPTSEC(ICLL+1) - HPTSEC(ICLL)                     # OF WORDS IN SECT
 31600 286               IF NWRD1.GE.LWRDC0                                        CHECK IF MORE THAN 1 HIT
 31700 287               THEN
 31900 290                  IF ICLL.EQ.49                                          # OF WORDS IN LEFT ADJ SECT
 32000 291                  THEN
 32100 294                     NWRD1L= HPTSEC(97) - HPTSEC(96)
 32200 295                  ELSE
 32300 297                     NWRD1L= HPTSEC(ICLL   ) - HPTSEC(ICLL- 1)
 32400 298                  CIF
 32600 299                  IF ICLL.EQ.96                                          # OF WORDS IN RGHT ADJ SECT
 32700 300                  THEN
 32800 303                     NWRD1R= HPTSEC(50) - HPTSEC(49)
 32900 304                  ELSE
 33000 306                     NWRD1R= HPTSEC(ICLL+ 2) - HPTSEC(ICLL+ 1)
 33100 307                  CIF
 33300 308                  IF NWRD1+NWRD1L.GE.LWRDC1 .OR. NWRD1+NWRD1R.GE.LWRDC1  CHECK IF MORE THAN 12 HITS
 33400 309                  THEN
 33600 312                     IF ICLL.EQ.49 .OR. ICLL.EQ.96                       CHECK IF .GT. 10 HITS IN CORRSP SECT
 33700 313                     THEN
 33800 316                        NWRD2 = HPTSEC(25)-HPTSEC(24) + HPTSEC(49)-HPTSEC(48)
 33900 317                     ELSE
 34000 319                        ICLL2L = ICLL/2
 34100 320                        NWRD2 = HPTSEC(ICLL2L+2) - HPTSEC(ICLL2L)
 34200 321                     CIF
 34300 322                     IF NWRD2.GE.LWRDC2
 34400 323                     THEN
 34500                                                                             COLLECT ALL Z IN RING 1 + 2
 34600 326                        PRINT 2912, ICLL,ICLL2L,NWRD1,NWRD1R,NWRD1L,NWRD2
 34700 327 2912 FORMAT(' PERFORM ZCOL23',10I6)
 34800 328                        PERFORM ZCOL23
 35000 331                        PERFORM HSTFLL                                   FILL HISTOGRAM
 35100 334                     CIF
 35200 335                  CIF
 35300 336               CIF
 35400 337               ICLL = ICLL + 1
 35500 338            UNTIL ICLL.GT.96
 35600    C
 35700 339            CALL MVC(HTEMP(1),0,HIST(1),0,200)
 35800 343            PERFORM HEVAL
 35900    C
 36000 346         CIF
 36100 347      CPROC
 36200    C
 36300                                                                             *************************
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  7
0CARD TARGET
  NO  STM.NO
 
 36400                                                                             *      Z C O L 2 3      *
 36600    C                                                                        *************************
 36700    C
 36900 349      PROC ZCOL23                                                        ****  COLLECT ALL Z IN RING 2 + 3  *****
 37000    C
 37200 350         FOR ILAYR=1,16                                                  ZERO HIT COUNTERS FOR EACH LAYER
 37300 351            NZ1(ILAYR) = 0
 37400 352            NZ2(ILAYR) = 0
 37500 353         CFOR
 37600                                                                             DRIFT SPACE BINS
 37800 355         IPT0 = HPTSEC(ICLL)                                             SET POINTERS OF SC1
 37900 356         IPT9 = HPTSEC(ICLL+1) - 1
 38100 357         FOR IPT = IPT0,IPT9,4                                           LOOP OVER ALL HITS IN SC1
 38300 358            IWIRE = HDATA(IPT)                                           SET WIRE #
 38400 359            IWIRE = SHFTR(IWIRE,3)
 38500 360            ILAYR = LAND(IWIRE,MKLAYR) + 1
 38700 361            IAMPL = HDATA(IPT+1)                                         STORE HIT
 38800 362            IAMPR = HDATA(IPT+2)
 38900 363            IF IAMPL.GT.0 .AND. IAMPR.GT.0
 39000 364            THEN
 39100 367               IZ1 = (IZCON * (IAMPR-IAMPL)) / (IAMPR+IAMPL)
 39300 368               IF IABS(IZ1).LT.IZMAX                                     CHECK IF Z INSIDE ID
 39400 369               THEN
 39500 372                  NZ2(ILAYR) = NZ2(ILAYR) + 1
 39600 373                  IHIT = NZ2(ILAYR)
 39700 374                  HZ2(IHIT,ILAYR) = IZ1
 39800 375               CIF
 39900 376            CIF
 40000 377         CFOR
 40200 379         ICLLA=0                                                         LOOP OVER ADJACENT SECTORS
 40300 380         REPEAT
 40400 381            ICLL2 = ICLL/2 + ICLLA
 40500 382            IF(ICLL2.LT.25) ICLL2 = 48
 40600 384            IF(ICLL2.GT.48) ICLL2 = 25
 40800 386            IPT0 = HPTSEC(ICLL2)                                         SET POINTERS OF SC2
 40900 387            IPT9 = HPTSEC(ICLL2+1) - 1
 41000 388            IF IPT9.GT.IPT0
 41100 389            THEN
 41300 392               FOR IPT = IPT0,IPT9,4                                     LOOP OVER ALL HITS IN SC1
 41500 393                  IWIRE = HDATA(IPT)                                     SET WIRE #
 41600 394                  IWIRE = SHFTR(IWIRE,3)
 41700 395                  ILAYR = LAND(IWIRE,MKLAYR) + 1
 41900 396                  IAMPL = HDATA(IPT+1)                                   STORE HIT
 42000 397                  IAMPR = HDATA(IPT+2)
 42100 398                  IF IAMPL.GT.0 .AND. IAMPR.GT.0
 42200 399                  THEN
 42300 402                     IZ1 = (IZCON * (IAMPR-IAMPL)) / (IAMPR+IAMPL)
 42500 403                     IF IABS(IZ1).LT.IZMAX                               CHECK IF Z INSIDE ID
 42600 404                     THEN
 42700 407                        NZ1(ILAYR) = NZ1(ILAYR) + 1
 42800 408                        IHIT = NZ1(ILAYR)
 42900 409                        HZ1(IHIT,ILAYR) = IZ1
 43000 410                     CIF
 43100 411                  CIF
 43200 412               CFOR
 43300 414            CIF
 43400 415            ICLLA = ICLLA + 1
 43500 416         UNTIL ICLLA.GT.1
 43600    C
 43700 417      CPROC
 43800    C
 43900                                                                             *************************
 44000                                                                             *      H S T F L L      *
 44200    C                                                                        *************************
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  8
0CARD TARGET
  NO  STM.NO
 
 44400 422      PROC HSTFLL                                                        FILL HISTOGRAM
 44600 423         FOR ILAYR=1,16                                                  LOOP OVER ALL LAYERS
 44700 424            MZ1 = NZ1(ILAYR)
 44800 425            MZ2 = NZ2(ILAYR)
 45000 426            IF MZ1.GT.0 .AND. MZ2.GT.0                                   CHECK IF HITS
 45100 427            THEN
 45300 430               FACT = (ILAYR-1)*PAR2 + PAR1                              CALC. COMMON FACTOR
 45500 431               FOR IHIT1=1,MZ1                                           LOOP OVER HITS(SC1)
 45600 432                  Z1 = HZ1(IHIT1,ILAYR)
 45700 433                  FI01 = FI1(IHIT1,ILAYR)
 45900 434                  FOR IHIT2=1,MZ2                                        LOOP OVER HITS(SC2)
 46100 435                     DFI = ABS(FI01 - FI2(IHIT2,ILAYR))                  MOMENTUM CUT (DFI .LT. DFIMAX)
 46200 436                     IF DFI.LT.DFIMX0
 46300 437                     THEN
 46400 440                        Z2 = HZ2(IHIT2,ILAYR)
 46600 441                        ZV = Z1 - (Z2-Z1)*FACT                           Z(VERTEX)
 46800 442                        IZV = (ZV-ZLOW) * BINZIV + 1                     CALC. HIST. INDEX + PLOT
 46900 443                        IF IZV.GT.0 .AND. IZV.LE.100
 47000 444                        THEN
 47100 447                           HIST(IZV) = HIST(IZV) + 1
 47200 448                        ELSE
 47300 450                           IF(IZV.LE.  0) HUFLO = HUFLO + 1
 47400 452                           IF(IZV.GT.NBINZ) HOFLO = HOFLO + 1
 47500 454                        CIF
 47600 455                     CIF
 47700 456                  CFOR
 47800 458               CFOR
 47900 460            CIF
 48000 461         CFOR
 48100 463      CPROC
 48200    C
 48400 465      PROC HEVAL                                                         *****  H I S T. E V A L U A T I O N  *****
 48500 466         IZCNT=0
 48600 467         ICODE=0
 48700 468         ZPREV=-1000000.
 48800 469         PRINT 2904, LBZVDF,ZLOW,  BINZ,  NBINZ,
 48900         ,   NWRDR1,LWRDC0,LWRDC1,LWRDC2,
 49000         ,   IDZ1LM,IDZ2LM,NPKMIN,SBRAT,DFIMX0
 49100 4702904  FORMAT('0PARAMETERS:',I6,2F6.0,8I6,F6.2,F6.3)
 49200 471         WHILE IZCNT.LT.5
 49300 473            PRINT 2001, HTEMP
 49400 477 2001 FORMAT('0HIST:',50I2,/,6X,50I2)
 49600 478            MAXHST = 0                                                   FIND BIN WITH MAX.CONTENT
 49700 479            NHIST1 = 0
 49800 480            FOR IHIST = 1,NBINZ
 49900 481               NHIST1 = NHIST1 + HTEMP(IHIST)
 50000 482               IF(HTEMP(IHIST).GT.MAXHST) MAXHST =HTEMP(IHIST)
 50100 484            CFOR
 50200 486            MAXZ = MAXHST
 50400 487            NPEAK = 0                                                    FIND PEAK
 50500 488            IH9 = NBINZ-11
 50600 489            FOR IH=7,IH9
 50700 490               IHSUM = HTEMP(IH)+HTEMP(IH+1)+HTEMP(IH+2)+HTEMP(IH+3)+HTEMP(IH+4)
 50800 491               IF IHSUM.GT.NPEAK
 50900 492               THEN
 51100 495                  NPEAK = IHSUM                                          MEMORIZE PEAK
 51200 496                  HPEAK = IH
 51300 497               CIF
 51400 498            CFOR
 51500 500            IF NPEAK.EQ.0
 51600 501            THEN
 51700 504               XWHILE
 51800 505            CIF
 51900 506            PEAK = NPEAK
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  9
0CARD TARGET
  NO  STM.NO
 
 52000 507            H1 = HPEAK - 7
 52100 508            H2 = HPEAK + 7
 52200 509            NBACK = HIST(H1  )+HIST(H1+1)+HIST(H1+2)+HIST(H1+3)+HIST(H1+4)
 52300         +      + HIST(H2  )+HIST(H2+1)+HIST(H2+2)+HIST(H2+3)+HIST(H2+4)
 52400 510            BACK = .5 * NBACK
 52500    C
 52700 511            ZV = HTEMP(HPEAK+1)   +HTEMP(HPEAK+2)*2                      CALC. ACCURATE PEAK POS.
 52800         +      +HTEMP(HPEAK+3)*3 +HTEMP(HPEAK+4)*4
 52900 512            ZV = ZV / PEAK
 53000 513            ZVTX      = (HPEAK+ZV-.5)/BINZIV + ZLOW
 53100 514            DZ =HTEMP(HPEAK  )*(ZV   )**2 +HTEMP(HPEAK+1)*(ZV-1.)**2
 53200         +      +HTEMP(HPEAK+2)*(ZV-2.)**2 +HTEMP(HPEAK+3)*(ZV-3.)**2
 53300         +      +HTEMP(HPEAK+4)*(ZV-4.)**2
 53400 515            IF(NPEAK.GT.NPKMIN) ICODE=ICODE+1
 53500 517            SGN  = (PEAK - BACK)**2
 53600 518            DSGN = BACK*.5 + PEAK
 53700 519            IF(SGN/DSGN.GE.SBRAT .AND. NPEAK.GT.2) ICODE=ICODE+2
 53800 521            PRINT 2002, HPEAK,ZVTX,PEAK,BACK,SGN,DSGN,ICODE
 53900 522 2002 FORMAT('0PEAK:',I6,5F8.2,I3)
 54000 523            IF ICODE.GE.IZRSLT(6)
 54100 524            THEN
 54200 527               IF ICODE.EQ.IZRSLT(6).AND.ABS(ZVTX).GT.ABS(ZPREV)
 54300 528               THEN
 54400 531                  XWHILE
 54500 532               CIF
 54600 533               IZCNT=IZCNT+1
 54700 534               SCPEAK = BACK * .2
 54800 535               HTEMP(HPEAK  )=SCPEAK
 54900 536               HTEMP(HPEAK+1)=SCPEAK
 55000 537               HTEMP(HPEAK+2)=SCPEAK
 55100 538               HTEMP(HPEAK+3)=SCPEAK
 55200 539               HTEMP(HPEAK+4)=SCPEAK
 55300 540               FZRSLT(2) = DZ / (BINZIV**2 * PEAK)
 55400 541               FZRSLT(3) = FZRSLT(2) / PEAK
 55500 542               FZRSLT(2) = SQRT(FZRSLT(2))
 55600 543               FZRSLT(3) = SQRT(FZRSLT(3))
 55700 544               FZRSLT(4) = PEAK
 55800 545               FZRSLT(5) = BACK
 55900 546               FZRSLT(1) = ZVTX
 56000 547               IND = ABS(ZVTX)*.01 + 1.
 56100 548               IF(IND.GT.4) IND = 4
 56200 550               IF(IZRSLT(6).EQ.1) IND = IND + 4
 56300 552               INDLB = IND + 2
 56400 553               ZPREV=ZVTX
 56500 554               IZRSLT(6)=ICODE
 56600 555               ICODE=0
 56700 556            ELSE
 56800 558               XWHILE
 56900 559            CIF
 57000 560         CWHILE
 57100 562      CPROC
 57200    C
 57300 564      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS         563 TARGET STATEMENTS
1VERSION 1 (MAR 81 )                    SHELTRAN                        PAGE  1
0CARD TARGET
  NO  STM.NO
 
 57400    C
 57500   2      SUBROUTINE INITZV
 57600    C
 57700    C     INITIALIZATION OF ZVERT LIMITS
 00100    C====MACRO CZVPAR===================================
 00200    C-------------------------------------------
 00300    C   RESULTS FROM ZVERTF
 00400    C   P. STEFFEN (79/01/26)
 00500    C---------------------------------------------
 00600   3      COMMON /CZVPAR/ LBZVDF,ZLOW,  BINZ,  NBINZ,
 00700         ,                NWRDR1,LWRDC0,LWRDC1,LWRDC2,
 00800         ,                IDZ1LM,IDZ2LM,NPKMIN,SBRAT,DFIMAX,
 00900         ,                DZVPAR(5)
 01000    C==ENDMACRO CZVPAR========================================
 57900    C
 58000                                                                             INITIALIZE DEFAULT PARAMETERS
 58200   4      LBZVDF = 1                                                         SET DEFAULT LABEL TO 1
 58400   5      ZLOW = -3500.                                                      HISTOGR. PARAMETERS
 58500   6      BINZ = 70.
 58600   7      NBINZ = 100
 58800   8      NWRDR1 = 24                                                        MIN. (NUMBER OF HITS)*4  IN RING 1
 59000   9      LWRDC0 = 8                                                         MIN. (NUMBER OF HITS)*4  IN SELECTED CELLS
 59200  10      LWRDC1 = 16                                                        MIN. (NUMBER OF HITS)*4  IN ADJ. CELLS OF R1
 59400  11      LWRDC2 = 16                                                        MIN. (NUMBER OF HITS)*4  IN ADJ. CELLS OF R2
 59600  12      IDZ1LM = 80                                                        LIMITS FOR TOO CLOSE HITS IN RING 1 + 2
 59700  13      IDZ2LM = 140
 59900  14      NPKMIN = 8                                                         MINIMUM PEAK HEIGHT
 60100  15      SBRAT  = 6.25                                                      MIN.: ((PEAK-BACK) / SIGMA)**2
 60300  16      DFIMAX = .1                                                        MAX. FI INCLINATION: P > 1GEV
 60400    C
 60500  17      RETURN
 60600  18      END
0END OF SEGMENT
0  OPTIONS IN EFFECT - LINECOUNT=64,LINEWIDTH=131,  SOURCE,  FORTRAN  NUMBERING
0   0 ERRORS           0 WARNINGS          17 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         580 TARGET STATEMENTS
