C  ETA & W(PI+PI-PI0)
+OPT, MAPASM.
+USE, DST CHECK, T = EXE.
+USE, *DST UTY.
+USE, DSTUTY, D=BLOCK DATA, EVLOOP, QEND, T = EXE.
+USE, PARTID, D=PARTID, T = EXE.Z
+USE, PROTON, T = INHIBIT.
+USE, PION. T = INHIBIT.
+USE, RUNA, T = INHIBIT.
+USE, RUNB, T = INHIBIT.
+USE, NA22, NEW GAM UTY,  T = INHIBIT.
+USE, WPI0, T = EXE...... D = CLEPI0, GAMLOS, T = EXE, IF = CROSS.
+USE, CLEAR PI0, T = INHIBIT.
+USE, FIT PI0, T = INHIBIT.
+USE, PI0. T = INHIBIT.
+USE, HANGARY. T = INHIBIT.
+USE, DSTUTY, D = BLOCK DATA, QEND, T = EXE.
+USE, DSTUTY, D = EVLOOP, HSAVE, PRNTRK, T = INHIBIT, IF = NA22.
+USE, GAM UTY, D = CPI0PI, D = CPI0PP, T = INHIBIT, IF = -NA22.
+USE, MULT, T = INHIBIT.   EFF. MASS FOR DIFF. MULT
+USE, XF. T = INHIBIT.    - " -  FOR DIFF. XF
+USE, YSTAR, T = INHIBIT. - " -  FOR DIFF. YSTAR
+USE, PTSQ.  T = INHIBIT. - " -  FOR DIFF. PTSQ
+USE, COSGJ. T = INHIBIT.
+KEEP, EVENT SAVE.
      IF (MOD (NEV, 10000) .EQ. 0) CALL HSAVE
+KEEP, PID SEL.
      IOK = -1
      IF (IISIS + ITRD .GT. 0)          IOK = 0
+KEEP, PID SEL.
        IOK = 0
        IF (P .LT.  4.1 .AND. ISAD .EQ. 0)                   IOK = -1
        IF (P .LT.  75. .AND. IISIS .EQ. 0)                  IOK = -1
        IF (P .GT.  45. .AND. ITRD+IGD .EQ. 0)               IOK = -1
        IF (P .GT.  75. .AND. P .LT. 250.0 .AND. IFC+ITRD .EQ. 0)
     +                                                       IOK = -1
        IF (P .GT. 120. .AND. ITRD .EQ. 0)                   IOK = -1
C-      IOK = -1
C-      IF (ISAD + IISIS + IGD + IFC + ITRD .GT. 0)          IOK = 0
+KEEP, RECOV1.
+USE, BUG, T = INHIBIT,
+USE, NO WEIGHT, T = INHIBIT.     BUILD ALSO UNWEIGHTED HISTOGRAMS
+KEEP, HISTEND.
C     CALL HISTDO
+KEEP, SET PTSQ.
      DATA PTSQMN / 0. /, DPTSQ /0.1/, NPTSQ /10/
     +,    PTSQM2 / 0.20/, DPTSQ2/0.020 /, NPTSQ2 /0 /
+KEEP, SET X.
      DATA NOXF /  9 /
      DIMENSION XXF(10)
      DATA XXF /
     - -.100, -.050, 0.000, 0.050, 0.100, 0.150, 0.200, 0.300, 0.500,
     - 1.000/
+KEEP, SET Y.
      DATA YMIN / -0.8/, DY /0.4/, NY/10/
+KEEP, SET COS.
      DATA COSMN/ -1./, DCOS /0.2/, NCOS/10/
      DATA PPHIMN / -1./, DPPHI / 0.2 /, NPPHI / 10 /
+KEEP, LIMITS.
      DATA XAMIN, XAMAX / 1.10, 3.10 /
+KEEP, RECOV1.
      EXTERNAL HANDLER
      CALL LIB$ESTABLISH (HANDLER)
+PAM, L = 11, T = A, C.    YF$PAM:DSTUTY
+PATCH, DST CHECK.
+DECK, MAIN.
      PROGRAM SUMX
C.
C
+CDE, SAVE.
+CDE ,DSTREC.
      COMMON // MAXQ, SPACE(999 000), MAXQH
C
      CHARACTER*320   ITTL
      DIMENSION       TITL (80)
      EQUIVALENCE (ITTL,TITL)
      COMMON /NEL/ NELAST,NMULT,NSKIP
      DATA NREC / 9 /
+SEQ, SET X, SET Y, SET PTSQ, SET COS, LIMITS.
      DATA           LUNIN / 11 /, LUNHSV / 31 /
C
C-----------------------------  END CDE  -------------------------------
C--
C--      INITIALISE ERROR RECOVERY.
+CDE, RECOV1.
C--
C--      ANALYSE THE MINIDST.
C
C
C --- HBOOK INITIALIZATION
C
      CALL HLIMIT (999 000)
      CALL HTITLE ('NA27 NOBC PHI$')
      NELAST = 0
      NMULT = 0
      NSKIP = 0
      CALL RESTART (IOK)
      IF (IOK .EQ. 0) GO TO 2000
      CALL HBOOK1 (50,'PRIMARY VERTEX MULTIPLICITY$',50,0.,50.)
      CALL HBOOK1 (51,'WEIGHTED EVENT MULTIPLICITY$',50,0.,50.)
      CALL HBOOK1 (52,'WEIGHTED TRIGGERED EVENT MULTIPLICITY$'
     +                                              ,50,0.,50.)
      DO 500 IR = 0, 1
        IF (IR .EQ. 0) ITTL(1:4) = 'PUR '
        IF (IR .EQ. 1) ITTL(1:4) = 'ALL '
        DO 510 ISS = 0, 4
          IS = 10+ ISS
          ISR = IS + 100* IR
          IDA =  0
          IDB = IDA + 1 000*ISR
          NX   = 100
          IF (ISS .EQ. 0) THEN
            XMIN = 0.40
            XMAX = 1.40
          ELSE IF (ISS .EQ. 1) THEN
            XMIN = 1.20
            XMAX = 2.80
          ELSE
            XMIN = 0.90
            XMAX = 2.90
          END IF
          IF (IS .EQ. 10) ITTL(5:15) = 'PI+PI-PI0  '
          IF (IS .EQ. 11) ITTL(5:15) = 'W(3PI)&ETA '
          IF (IS .EQ. 12) ITTL(5:15) = 'W(3PI)& PI0'
          IF (IS .EQ. 13) ITTL(5:15) = 'W(3PI)& PI+'
          IF (IS .EQ. 14) ITTL(5:15) = 'W(3PI)& PI-'
          ITTL(16:20) = '     '
          IDDA = IDA + 100
          IDDB = IDB + 100
          CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
+SELF, IF = MULT.
        DO    I = 2, 32, 2
          ENCODE (80,102,TITL(7)) I
  102     FORMAT (' FOR MULT =',I3,'$')
          IDDA = IDA + 100 + I
          IDDB = IDB + 100 + I
          CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
        END DO
+SELF, IF = XF.
        DO    I = 1, NOXF
          X1 = XXF(I)
          X2 = XXF(I+1)
          ENCODE (80,103,TITL(7)) X1, X2
  103     FORMAT (' FOR ',F6.3,' < XF < ',F6.3,' $')
          IDDA = IDA + 300 + I
          IDDB = IDB + 300 + I
          CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
CN        ENCODE (80,124,TITL(13))
CN        IDDB = IDB + 400 + I
CN        CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
        END DO
+SELF, IF = YSTAR.
        DO    I = 1, NY
          X1 = YMIN + DY*FLOAT(I - 1)
          X2 = X1 + DY
          ENCODE (80,104,TITL(7)) X1, X2
  104     FORMAT (' FOR ',F5.2,' < Y* < ',F5.2,'$')
          IDDA = IDA + 500 + I
          IDDB = IDB + 500 + I
          CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
        END DO
+SELF, IF = PTSQ.
        DO    I = 1, NPTSQ
          X1 = PTSQMN + DPTSQ *FLOAT(I - 1)
          X2 = X1 + DPTSQ
          ENCODE (80,105,TITL(7)) X1, X2
  105     FORMAT (' FOR ',F5.2,' < PT**2 < ',F5.2,'$')
          IDDA = IDA + 600 + I
          IDDB = IDB + 600 + I
          CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
CN        IDDB = IDB + 700 + I
CN        ENCODE (20,124,TITL(17))
CN        CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
        END DO
+SELF, IF = COSGJ.
        DO    I = 1, NCOS
          X1 = COSMN + DCOS *FLOAT(I - 1)
          X2 = X1 + DCOS
          ENCODE (80,106,TITL(7)) X1, X2
  106     FORMAT (' FOR ',F5.2,' < COSGJ < ',F5.2,'$')
          IDDA = IDA + 800 + I
          IDDB = IDB + 800 + I
          CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
        END DO
+SELF.
  510 CONTINUE
  500 CONTINUE
      CALL HBSTAT (0)
      CALL HBARX (0)
C-
 2000 CALL EVLOOP
C--
C--
C--      END OF RUN.
C
 3000 CALL QEND
      STOP
  124 FORMAT (' * ENERGY$')
      END
C=======================================================================
+DECK, HIST.
      SUBROUTINE HIST (IPRNT)
+CDE, DSTREC, CMS.
+CDE, PRBCUT.
+SEQ, SET X, SET Y, SET PTSQ, SET COS, LIMITS.
+SEQ, MASSES.
+SEQ, IGDEV, GSOURCE, QBCD, QUNIT, IF = BUG.
+CDE, PARTID.
+CDE, MICRO.
      DIMENSION  W(4,4),EW(4,4), YSTARS(3),PPA(3), PBB(4)
      DIMENSION ADLOSS(9), PXYZPH(4)
      DATA    PI / 3.14159265358979 /, PI2 / 6.283 185 307 179 59/
      DATA PRBCUT / 0.0450 /
      DIMENSION SGN(9), IIND(9)
      EQUIVALENCE (I1ND,IIND(1),IND), (I2ND,IIND(2)), (I3ND,IIND(3))
     -,           (I4ND,IIND(4)), (I5ND,IIND(5)), (I6ND,IIND(6))
     -,           (I7ND,IIND(7)), (I8ND,IIND(8)), (I9ND,IIND(9))
      DIMENSION   PAIR(4), TOPCS(14), EVNNUM(14)
      COMMON /NEL/ NELAST,NMULT,NSKIP
C-
+SELF, IF = -KAON, IF = NA22.
C     TOPOLOGICAL CROSS SECTION, PI+P AT 250 GEV/C, HEN 262A
      DATA TOPCS/ 1.480, 3.440, 3.760, 3.850 , 3.360,
     +            2.380, 1.410, 0.720, 0.310 , 0.160,
     +            0.046, 0.022, 0.006, 0.0004/
+SELF, IF = -KAON, IF = RUNB.
      DATA EVNNUM
     +/     2089.,0.9562E+04,0.1518E+05,0.1628E+05,0.1441E+05,
     + 0.9773E+04,     5682.,     2965.,    1203. ,   435.0  ,
     +   156.    ,    53.00 ,  10.00   ,   2.000/
      DATA NEVMAX / 77791/
+SELF, IF = -KAON, IF = RUNA.
      DATA EVNNUM
     +/  356., 1516., 2254., 2414., 2151., 1485.,  827.,  402.,
     +  166.,  78.,  18.,  13.,  3.,  0./
      DATA NEVMAX /11683/
+SELF.
C-
CYF   CALL CLEPRI (IOK)
C     IF (IOK .NE. 0) GO TO 999
      IF (FDST(29) .LE. 0.0) GO TO 999
C-
+SEQ, SELECT EV, T = PASS.
C-
      CALL USER
      IPRNT = 0
C --- PRIMARY INTERACTION
      IEL = 0
      MIW = FDST(21)
      IT = JBYT (MIW, 9,5)
      MULT = JBYT (MIW,16,6)
+SEQ, MULT.
+SELF, IF = NA22.
      IF (MULT .GT. 28 .OR. MULT .LT. 2) THEN
        NMULT = NMULT + 1
        GO TO 999
      END IF
      IM = MULT/2
      IF (MULT .NE. 2*IM) GO TO 999
CCCC    SELECT  ELASTIC   EVENTS
      IF (MULT .EQ. 2 .AND. NPI0 .EQ. 0) CALL ELAST(IEL)
      IF (IEL .EQ. 1) THEN
        NELAST = NELAST + 1
        GO TO 999
      END IF
      WEQMKB = 1000.*TOPCS(IM)/EVNNUM(IM)
+SELF, IF = - NA22.
      WEQMKB = FDST(29)
+SELF.
CCCCC
      CALL HFILL (50,FLOAT(MULT))
      CALL HFILL (51,FLOAT(MULT), WEQMKB)
      CALL CLEPI0
C     CALL PRNTEV
C
      CALL HFILL (52,FLOAT(MULT), WEQMKB)
      NETA = 0
      DO 140 I3 = 1, NPRT
        I3ND = INDPRT + NWPRT*(I3 - 1)
+SELF, IF = NA22.
        TRQU=FDST(I3ND+21)
C   CHECK THE TRACK QUALITY
        IF ( ABS(TRQU) .GT. 12.0) GO TO 140
        PLAB=VMOD(FDST(I3ND+4),3)
        IF(PLAB .LT. 0.0005 .OR. PLAB .GT. 350.0) GO TO 140
        IF (FDST(I3ND+18).EQ.1.0) GO TO 140
+SELF, IF = - NA22.
        IF (FDST(I3ND+21).LE.0.0) GO TO 140
+SELF.
        DO 130 I4 = 1, I3-1
          I4ND = INDPRT + NWPRT*(I4 - 1)
+SELF, IF = NA22.
          TRQU=FDST(I4ND+21)
C   CHECK THE TRACK QUALITY
          IF ( ABS(TRQU) .GT. 12.0) GO TO 130
          PLAB=VMOD(FDST(I4ND+4),3)
          IF(PLAB .LT. 0.0005 .OR. PLAB .GT. 350.0) GO TO 130
          IF (FDST(I4ND+18).EQ.1.0) GO TO 130
+SELF, IF = - NA22.
          IF (FDST(I4ND+21).LE.0.0) GO TO 130
+SELF.
          IF ( FDST(I3ND+2)*FDST(I4ND+2) .GT. 0.0 ) GO TO 130
          DO 210 I1 = 1, NPI0
            I1ND = INDPI0 + NWPI0*(I1 - 1)
            IF (FDST(I1ND+2).GT.0.2.AND.FDST(I1ND+2).LT.0.1) GO TO 210
            IF (FDST(I1ND+16) .LE. 0.0) GO TO 210
            AAMSS   = EMASS (AMPI, FDST(I3ND+4), AMPI, FDST(I4ND+4),
     +                     FDST(I1ND+2), FDST(I1ND+3))
            AMOM = 0.782
+SELF, IF = PION.
            DMSW = 0.030
+SELF, IF = PROTON.
            DMSW = 0.0376
+SELF.
            DMSETA = 0.044
            IR1 = 0
            IF (FDST(I1ND+15) .LT. 100.0) IR1 = 1
            IDB = 1000*( 10+IR1*100)
            WWW = 1.0
            CALL HFILL (IDB+100, AAMSS, WWW)
+SELF,   IF = MULT.
            CALL HFILL(IDB+100+MULT,AAMSS, WWW)
+SELF,   IF = XF.
            IX = LOCATF (XXF, NOXF, XF)
            IX = ABS (IX)
            IF (IX .GT. 0 .AND. IX .LE. NOXF) THEN
              CALL HFILL(IDB+300+IX,AAMSS, WWW)
CN            CALL HFILL(IDB+400+IX,AAMSS,EE*WWW)
            END IF
+SELF,   IF = YSTAR.
            IX  = IFIX((YSTAR-YMIN)/DY) + 1
            IF (IX .GT. 0 .AND. IX .LE. NY) THEN
              CALL HFILL(IDB+500+IX,AAMSS, WWW)
            END IF
+SELF,   IF = PTSQ.
            IX  = IFIX((PTSQ-PTSQMN)/DPTSQ)  + 1
            IF (IX .LE. NPTSQ) THEN
              CALL HFILL(IDB+600+IX,AAMSS, WWW)
CN            CALL HFILL(IDB+700+IX,AAMSS,EE*WWW)
            END IF
+SELF,   IF = COSGJ.
            IX  = IFIX(( COSTHE - COSMN )/ DCOS)  + 1
            IF (IX .LE. NCOS) THEN
              CALL HFILL(IDB+800+IX,AAMSS, WWW)
            END IF
+SELF.
            IT = 0
            IF (ABS(AAMSS - AMOM  ) .LT. DMSW) IT = 20
            IF (IT .EQ. 0) GO TO 210
            IF (IT .EQ. 20) AMSS = AMOM
            LND = NWORDS
            NW     = NWORDS + NWPI0
            IF (NW .GT. MAXDST) GO TO 210
            NWORDS = NW
            NETA = NETA + 1
            FDST(LND+1) = (NETA + 100 + 256*IT)
            FDST(LND+2) = AAMSS
            CALL UCOPY (PXYZ,FDST(LND+3),3)
            FDST(LND+ 6) = I3
            FDST(LND+ 7) = I4
            FDST(LND+12) = FDST(I1ND+12)
            FDST(LND+13) = FDST(I1ND+13)
            FDST(LND+14) = AMSS
            FDST(LND+15) = FDST(I1ND+15)
            FDST(LND+16) = FDST(I1ND+16)
  210     CONTINUE
  130   CONTINUE
  140 CONTINUE
C      CALL ADDETA (NEWET)
      NEWET = NETA
      IF ( NEWET .LE. 0) GO TO 999
      IPHIF = 0
      NNEW = NPI0+NEWET
      DO 110 I1 = 1, NPI0
C  ETA OR PI0 OR ETAP
        I1ND = INDPI0 + NWPI0*(I1 - 1)
        IF (FDST(I1ND+16) .LE. 0.0) GO TO 110
C  ONLY ETA OR PI0
        IF (FDST(I1ND+2).GT.0.7.AND.FDST(I1ND+2).LT.0.1) GO TO 110
        NS = 12
        IF (FDST(I1ND+2).GT.0.5) NS = 11
C         IT1 = FDST(I1ND+1)/256
C          IF (IT1 .EQ. 19) GO TO 110
        IR1 = 0
        IF (FDST(I1ND+15) .LT. 100.0) IR1 = 1
        DO 100 I2 = NPI0+1, NNEW
C  OMEGA
C           IF (I2 .LE. I1) GO TO 100
          I2ND = INDPI0 + NWPI0*(I2 - 1)
          IF (FDST(I2ND+16) .LE. 0.0) GO TO 100
          IT2 = FDST(I2ND+1)/256
          IF ( IT2 .NE. 20 ) GO TO 100
          IR = 1
C  ETA CL & W CL
          IF (FDST(I1ND+15) .GE. 100.0 .AND.
     -          FDST(I2ND+15) .GE. 100.0) IR = 0
C
          IF ( FDST (I1ND+12) .EQ. FDST (I2ND+12) .OR.
     -           FDST (I1ND+12) .EQ. FDST (I2ND+13)) GO TO 100
          IF ( FDST (I1ND+13) .EQ. FDST (I2ND+12) .OR.
     -           FDST (I1ND+13) .EQ. FDST (I2ND+13)) GO TO 100
          AMSS =
     -      EMASS (FDST(I1ND+2),FDST(I1ND+3)
     -            ,FDST(I2ND+2),FDST(I2ND+3))
          TY = PXYZ(2)/PXYZ(1)
          TZ = PXYZ(3)/PXYZ(1)
C!!         EFPI0 = GWPI0 (FDST(I2ND+2),FDST(I2ND+3),XYZPR,TY,TZ)
C!!         IF (EFPI0 .LT. 0.10) GO TO 100
          IDB = 1000*(NS+IR*100)
          WWW = 1.0
          CALL HFILL (IDB+100, AMSS, WWW)
+SELF,   IF = MULT.
            CALL HFILL(IDB+100+MULT,AMSS, WWW)
+SELF,   IF = XF.
            IX = LOCATF (XXF, NOXF, XF)
            IX = ABS (IX)
            IF (IX .GT. 0 .AND. IX .LE. NOXF) THEN
              CALL HFILL(IDB+300+IX,AMSS, WWW)
CN            CALL HFILL(IDB+400+IX,AMSS,EE*WWW)
            END IF
+SELF,   IF = YSTAR.
            IX  = IFIX((YSTAR-YMIN)/DY) + 1
            IF (IX .GT. 0 .AND. IX .LE. NY) THEN
              CALL HFILL(IDB+500+IX,AMSS, WWW)
            END IF
+SELF,   IF = PTSQ.
            IX  = IFIX((PTSQ-PTSQMN)/DPTSQ)  + 1
            IF (IX .LE. NPTSQ) THEN
              CALL HFILL(IDB+600+IX,AMSS, WWW)
CN            CALL HFILL(IDB+700+IX,AMSS,EE*WWW)
            END IF
+SELF,   IF = COSGJ.
            IX  = IFIX(( COSTHE - COSMN )/ DCOS)  + 1
            IF (IX .LE. NCOS) THEN
              CALL HFILL(IDB+800+IX,AMSS, WWW)
            END IF
+SELF.
  100     CONTINUE
  110   CONTINUE
        DO 200 I2 = NPI0+1, NNEW
C  OMEGA
          I2ND = INDPI0 + NWPI0*(I2 - 1)
          IF (FDST(I2ND+16) .LE. 0.0) GO TO 200
          IT2 = FDST(I2ND+1)/256
          IF ( IT2 .NE. 20 ) GO TO 200
          DO 240 I3 = 1, NPRT
            I3ND = INDPRT + NWPRT*(I3 - 1)
            IF(I3 .EQ.FDST(I2ND+6).OR.I3 .EQ.FDST(I2ND+7)) GO TO 240
            IF (FDST(I3ND+21).LE.0.0) GO TO 240
            NS = 13
            IF ( FDST(I3ND+2) .LT. 0.0 ) NS = 14
            IR = 1
C  W CL
            IF (FDST(I2ND+15) .GE. 100.0) IR = 0
C
            AMSS =
     -      EMASS (   AMPI ,    FDST(I3ND+4)
     -            ,FDST(I2ND+2),FDST(I2ND+3))
            TY = PXYZ(2)/PXYZ(1)
            TZ = PXYZ(3)/PXYZ(1)
            IDB = 1000*(NS+IR*100)
            WWW = 1.0
            CALL HFILL (IDB+100, AMSS, WWW)
+SELF,   IF = MULT.
            CALL HFILL(IDB+100+MULT,AMSS, WWW)
+SELF,   IF = XF.
            IX = LOCATF (XXF, NOXF, XF)
            IX = ABS (IX)
            IF (IX .GT. 0 .AND. IX .LE. NOXF) THEN
              CALL HFILL(IDB+300+IX,AMSS, WWW)
CN            CALL HFILL(IDB+400+IX,AMSS,EE*WWW)
            END IF
+SELF,   IF = YSTAR.
            IX  = IFIX((YSTAR-YMIN)/DY) + 1
            IF (IX .GT. 0 .AND. IX .LE. NY) THEN
              CALL HFILL(IDB+500+IX,AMSS, WWW)
            END IF
+SELF,   IF = PTSQ.
            IX  = IFIX((PTSQ-PTSQMN)/DPTSQ)  + 1
            IF (IX .LE. NPTSQ) THEN
              CALL HFILL(IDB+600+IX,AMSS, WWW)
CN            CALL HFILL(IDB+700+IX,AMSS,EE*WWW)
            END IF
+SELF,   IF = COSGJ.
            IX  = IFIX(( COSTHE - COSMN )/ DCOS)  + 1
            IF (IX .LE. NCOS) THEN
              CALL HFILL(IDB+800+IX,AMSS, WWW)
            END IF
+SELF.
  240     CONTINUE
  200   CONTINUE
  999   RETURN
        END
+DECK, PRNTRK.
      SUBROUTINE PRNTRK (IND)
C.
C...PRNTRK    PRINTS A TRACK                                   YF  1.10
C.
C.----------------------------------------------------------------------
C
+CDE, DSTREC, CMS.
+CDE ,QBCD.
+SEQ, PBEAM.
+CDE, MASSES.
+CDE, QUNIT.
+SEQ, IGDEV, GSOURCE. IGDEV, MGG
      DIMENSION      PROBS(4), YZ(2), CLVLS(10)
      CHARACTER*5    CHARFC, CHASAD, CHATRD, CHAISIS, CHTOT
      CHARACTER*3    CHARGD
      DIMENSION XMASS(5)
      DATA XMASS / 0.511 003 E-3, 0.105 659, 0.139 568
     +,                           0.493 667, 0.938 280 /
      DATA REFSAD / 1.0312 /
C
C-----------------------------  END CDE  -------------------------------
      CALL LABEHS(FDST(IND+1),LABEL)
      ICH = IQBLAN
      IF(FDST(IND+2).LT.0.0) ICH = IQMINS
      IF(FDST(IND+2).EQ.0.0) ICH = IQNUM1
      IF(FDST(IND+2).GT.0.0) ICH = IQPLUS
      P   = 0.0
      IF(FDST(IND+4).GT.0.0) P = 1.0/FDST(IND+4)
      IDP = ((SQRT(FDST(IND+7)) * P**2) + 0.00005) * 10000.0
      IF (IDP .GT. 999 999) IDP = 999 999
      IDL = (SQRT(FDST(IND+9)) + 0.00005) * 10000.0
      IDF = (SQRT(FDST(IND+12)) + 0.00005) * 10000.0
      LABDTF = ABS(FDST(IND+2))
      PARN = 'PI  '
      CALL LABEHS(FDST(IND+1),LABEL)
      ICH = IQBLAN
      IF(FDST(IND+2).LT.0.0) ICH = IQMINS
      IF(FDST(IND+2).EQ.0.0) ICH = IQNUM(1)
      IF(FDST(IND+2).GT.0.0) ICH = IQPLUS
      IS = 1
      IF (FDST(IND+2) .LT. 0.0) IS = 2
      P   = 0.0
      IF(FDST(IND+4).GT.0.0) P = 1.0/FDST(IND+4)
      IF (P .GT. 9999.9999)  P = 9999.9999
      IDP = MIN (99.9999,SQRT(FDST(IND+7))*P**2+.00005)*10000.
      IDL = (SQRT(FDST(IND+9)) + 0.00005) * 10000.0
      IDF = (SQRT(FDST(IND+12)) + 0.00005) * 10000.0
      DTF=ABS(FDST(IND+2))
      CALL VZERO (PROBS, 4)
      CALL VZERO (CLVLS, 3)
      CHARGD(1:3) = '   '
      IF (NWPRT .GE. 20 .AND. ISRLL .LT. 202) THEN
        ANPT = MOD (FDST(IND+19), 1000.)
        IF (ANPT .GE. 150.) THEN
          DO 160 IK = 1, 4
            PROBS(IK) = FDST(IND+13+IK)
  160     CONTINUE
        END IF
        WRITE(IQPRNT,9060) LABEL,DTF,ICH,PARN,P,IDP,FDST(IND+5) ,
     +IDL,FDST(IND+6),IDF,FDST(IND+13), PROBS, CHARGD, FDST(IND+21)
      END IF
      RETURN
 9050 FORMAT(1X,2A4,F6.0,2X,A1,4X,A4,F10.4,I6,2(F10.4,I5),F6.1,2X ,4F4.
     +0,A,3(F5.1,A))
 9060 FORMAT(1X,2A4,F6.0,2X,A1,4X,A4,F10.4,I6,2(F10.4,I5),F6.1,2X ,4F4.
     +0,A,F10.5)
      END
+DECK, CPI0.
      SUBROUTINE CPI0PI
+CDE, DSTREC, QUNIT, GEOM, MASSES, CPI0, CMS.
+CDE, PRBCUT.
+CDE, SLATET.
  140 NWORDS = NWORDS - NWPI0*NPI0
      NPI0  = 0
      DO 210 I = 1, NGAM - 1
        IND = INDGAM + NWGAM*(I-1)
        IF (IUCOMP (FDST(IND+1),GLAB, NTGAM) .LE. 0) GO TO 210
        IGAM1  = FDST(IND+12)
        ENI    = VMOD (FDST(IND+3),3)
C        TYI    = FDST(IND+4)/FDST(IND+3)
C        TZI    = FDST(IND+5)/FDST(IND+3)
C        IF (IGAM1 .EQ. 2) THEN
C          DENI = (0.02 + 0.15/SQRT(ENI) + 0.25/ENI)/2.35
C          DYI  = (0.8/SQRT(ENI) + 0.1)/XIGD
C        ELSE IF (IGAM1 .EQ. 3) THEN
C          DENI = (1.2/ENI + 0.026*ENI/(ENI + 50.))/2.35
C          DYI  = 0.3/XFGD
C        END IF
        DO 205 J = I + 1, NGAM
          JND = INDGAM + NWGAM*(J-1)
          IF (IUCOMP (FDST(JND+1),GLAB, NTGAM) .LE. 0) GO TO 205
          IGAM2  = FDST(JND+12)
          ENJ    = VMOD (FDST(JND+3),3)
C          TYJ    = FDST(JND+4)/FDST(JND+3)
C          TZJ    = FDST(JND+5)/FDST(JND+3)
C          IF (IGAM2 .EQ. 2) THEN
C            DENJ = (0.02 + 0.15/SQRT(ENJ) + 0.25/ENJ)/2.35
C            DYJ  = (0.8/SQRT(ENJ) + 0.1)/XIGD
C          ELSE IF (IGAM2 .EQ. 3) THEN
C            DENJ = (1.2/ENJ + 0.026*ENJ/(ENJ + 50.))/2.35
C            DYJ  = 0.3/XFGD
C          END IF
C          R2 = (TYI - TYJ)**2 + (TZI - TZJ)**2
          AAMSS   = EMASS (0., FDST(IND+3), 0., FDST(JND+3))
          DMSS19 = 0.0085
          DMSS20 = DMSS19/AMPI0*AMETA
          DMSS21 = DMSS19/AMPI0*AMETAP
          IT = 0
          IF (ABS(AAMSS - AMPI0 ) .LT. 4.*DMSS19) THEN
            IT = 19
          ELSE
            IF (ABS(AAMSS - AMETA ) .LT. 4.*DMSS20) THEN
              IT = 20
            ELSE
              IF (ABS(AAMSS - AMETAP) .LT. 4.*DMSS21) IT = 21
            END IF
          END IF
          IF (IT .EQ. 0) GO TO 205
          IF (IT .EQ. 19) AMSS = AMPI0
          IF (IT .EQ. 20) AMSS = AMETA
          IF (IT .EQ. 21) AMSS = AMETAP
          IF (IT .EQ. 19) DMSS = DMSS19
          IF (IT .EQ. 20) DMSS = DMSS20
          IF (IT .EQ. 21) DMSS = DMSS21
          CHISQ  = ((AMSS - AAMSS)/DMSS)**2
          PRBFIT = PROB (CHISQ, 1)
          IF (PRBFIT .LT. PRBCUT) GO TO 205
          P      = VMOD (PXYZ,3)
          COSTHE = ABS(ENI-ENJ)/P
          ETA  = P/AMSS
          GAMMA = SQRT (1. + ETA**2)
          OVBETA = GAMMA*AAMSS/P
          IGO = IGAM1 + IGAM2 - 3
          COSMIN = 0.
          IF (IGAM1 .EQ. IGAM2) THEN
            RMIN = RMNIGD
            IF (IGAM1 .EQ. 3) RMIN = RMNFGD
            ETASIN = 1./(RMIN*ETA)
            IF (ETASIN .LT. 1.0) COSMIN = SQRT (1. - ETASIN**2)
          END IF
          IF (COSTHE .LT. COSMIN) GO TO 205
          COSMAX = OVBETA*(1. - GAMMN(1)/GAMMA)
          COSMAX = MIN (0.9, COSMAX)
          IF (COSTHE .GE. COSMAX) GO TO 205
          LND = NWORDS
          NW     = NWORDS + NWPI0
          IF (NW .GT. MAXDST) GO TO 210
          NWORDS = NW
          NPI0 = NPI0 + 1
          FDST(LND+1) = (NPI0 + 256*IT)
          FDST(LND+2) = AAMSS
          CALL UCOPY (PXYZ,FDST(LND+3),3)
          FDST(LND+12) = FDST(JND+1)
          FDST(LND+13) = FDST(IND+1)
          FDST(LND+14) = AMSS
          FDST(LND+15) = PRBFIT
          FDST(LND+16) = FDST(IND+16)*FDST(JND+16)*(1. - PRBCUT)*
     *                  (COSMAX - COSMIN)
  205   CONTINUE
  210 CONTINUE
      CALL REMTCH
      RETURN
      END
C=======================================================================
+PATCH, NA22.
+DECK, EVLOOP.
      SUBROUTINE EVLOOP
C.
C...EVLOOP    READS AND ANALYSES THE MINIDST                    YF  1.00
C.
C.----------------------------------------------------------------------
C
+CDE, DSTREC.
+CDE, SAVE, MASSES.
C ---                        PT, SV, GM, PE, TM, TF,  MAX
+CDE, MICRO.
      COMMON /NEL/ NELAST,NMULT,NSKIP
C
C-----------------------------  END CDE  -------------------------------
C--
C--    READ NEXT DST RECORD
C
+SELF, IF = QMVAX.
      OPEN (UNIT=LUNIN,STATUS='OLD',FORM='UNFORMATTED',READONLY
     +,ERR=260)
+SELF.
      IFAIL = 0
  100 READ(LUNIN,END=240,ERR=220) NW, (DST(I), I = 2, NW)
      INUSER = 0
      INIPI0 = 0
      IFAIL = 0
C --- CHECK IF MICRO DST
      IF (IST(2) .GE. 0) THEN
        IF (NW .GT. MAXDST) GO TO 100
        NWORDS = NW
        CALL UCOPY (DST(2), FDST(2), NW-1)
      ELSE IF (IST(2) .LT. -1) THEN
        CALL VZERO (FDST,30)
        IRF = - IST(2)
        ISRLL = IRF/10 000
        ISFRM = IRF - 10 000*ISRLL
        IVRSN = -1
C--
C--      PRIMARY VERTEX AND BEAM ...
C
        NPRT =  MOD (IST(3)          , 100)
        NGAM =  MOD (IST(3)/      100, 100)
        NPI0 =  MOD (IST(3)/   10 000, 100)
        NSV0 =  MOD (IST(3)/1 000 000, 100)
        IF (NPRT .GT. 28 .OR. NGAM .GT. 35) THEN
          TYPE *, ' SKIP R/F ', IRF, ' T,G,P,V '
     +, NPRT, NGAM, NPI0, NSV0
          NSKIP = NSKIP + 1
          GO TO 100
        END IF
        CALL UCOPY (NWD, FDST(13), 6)
C--      PRIMARY VERTEX AND BEAM ...
C
        CALL UCOPY (DST(4), FDST(21), 4)
+SELF, IF = -KAON.
          FDST(25) = AMPI
+SELF, IF = KAON.
          FDST(25) = AMK
+SELF.
          FDST(26) = 1./250.
C       END IF
          CALL UCOPY (DST(8), FDST(27), 2)
          FDST(29) = MOD (DST(11), 10.0)
          IF (FDST(29) .LE. 0.0) GO TO 100
C         VERTEX QUALITY
          IDST(19) = DST(10)
C--      OUTGOING CHARGED TRACKS AT THE PRIMARY VERTEX ...
C
          INDPRT = 30
          IPRT = 11
          DO 120 I = 1, NPRT
            IND = INDPRT + NWPRT*(I - 1)
            CALL VZERO (FDST(IND+1), NWPRT)
            FDST(IND+1) = I
            IDC         = ABS(DST(IPRT+1)/1000.)
            IF (IDC .EQ. 0) IDC = 1
            FDST(IND+2) = 1000*IDC + I
            IF (DST(IPRT+4) .LT. 0.0) FDST(IND+2) = - FDST(IND+2)
            FDST(IND+3) = AMPI
            FDST(IND+4) = DST(IPRT+1)
            FDST(IND+4) = MOD (FDST(IND+4), 1000.)
            FDST(IND+5) =     DST(IPRT+2)
            FDST(IND+6) =     DST(IPRT+3)
            ITRQU = ABS(IST(IPRT+4))
            FDST(IND+21) = FLOAT(ITRQU)/256.
            JPRT = IPRT + 4
            IF (JBYT (IST(IPRT+4),1, 5) .EQ. 0) GO TO 120
            IF (JBIT (IST(IPRT+4), 1) .EQ. 1) FDST(IND+14) = 1.0
            IF (JBIT (IST(IPRT+4), 2) .EQ. 1) FDST(IND+15) = 1.0
            IF (JBIT (IST(IPRT+4), 3) .EQ. 1) FDST(IND+16) = 1.0
            IF (JBIT (IST(IPRT+4), 4) .EQ. 1) FDST(IND+17) = 1.0
CCC             FOR TRACKS WITH DP/P > 25%
            IF (JBIT (IST(IPRT+4), 5) .EQ. 1) FDST(IND+18) = 1.0
  120     IPRT = JPRT
          INDSV0 = INDPRT + NWPRT*NPRT
          ISV0P  = IPRT
+SELF, IF = - OLD VRS.
        IF (ISRLL .LE. 202) THEN
          IGAMP  = ISV0P +  NSV0*6
          NSV0 = 0
          GO TO 141
        END IF
+SELF.
        DO 140 I = 1, NSV0
          IND = INDSV0 + (4 + NWSV0)*(I - 1)
          ISV0 = ISV0P +  MWSV0*(I - 1)
+SELF, IF = OLD VRS.
          CALL VZERO (FDST(IND+1), NWSV0+4)
          FDST(IND+1) = I
          FDST(IND+2) = 1.
          CALL UCOPY (DST(ISV0+1), FDST(IND+8), 4)
          JND = IND + 4
          FDST(JND+15) = DST(ISV0+5)
          ISTAT = DST(ISV0+6)
          NDF = MOD (ISTAT/100, 100)
          NMF =      ISTAT/1000
          IAMB = MOD (ISTAT, 100)
          FDST(JND+14) = 10*NDF + 0.5
          FDST(IND+3) = NMF
          FDST(IND+4) = IAMB
+SELF, IF = - OLD VRS.
          FDST(IND+1) = DST(ISV0+1)
          FDST(IND+2) = 1.
          CALL UCOPY (DST(ISV0+2), FDST(IND+3), MWSV0-1)
+SELF.
  140   CONTINUE
        IGAMP  = ISV0P +  NSV0*MWSV0
  141   INDGAM = INDSV0 + NSV0*(4 + NWSV0)
        DO 160 I = 1, NGAM
          IGAM = IGAMP + MWGAM*(I - 1)
          IND  = INDGAM + NWGAM*(I-1)
          CALL VZERO (FDST(IND+1), NWGAM)
          CALL UCOPY (DST(IGAM+2), FDST(IND+3), 3)
          FDST(IND+12) = MOD (DST(IGAM+1), 10.)
          FDST(IND+14) = AINT (DST(IGAM+1)/10.)
          IT = FDST (IND+12) + 16
          FDST(IND+1) = (I + 256*(IT-1))
          FDST(IND+16) = 10.*MOD (DST(IGAM+1), 1.0)
  160   CONTINUE
        INDPI0 = INDGAM + NWGAM*NGAM
        IPI0P  = IGAMP + NGAM*MWGAM
        IRMTCH = 0
        DO 180 I = 1, NPI0
          IND = INDPI0 + NWPI0*(I - 1)
          CALL VZERO (FDST(IND+1), NWPI0)
          IPI0 = IPI0P + MWPI0*(I - 1)
          IT     = 19
          IF (DST(IPI0+1) .GT. 0.5) IT = 20
          IF (DST(IPI0+1) .GT. 0.9) IT = 21
          FDST(IND+1) = (I + 256*IT)
          CALL UCOPY (DST(IPI0+1), FDST(IND+2), 4)
+SELF, IF = - NEW MICRO.
          IGAM12 = DST(IPI0+5)
+SELF, IF = NEW MICRO.
          IGAM12 = IST(IPI0+5)
+SELF.
          IGAM1  = MOD (IGAM12, 100)
          IGAM2  = MOD (IGAM12/ 100, 100)
          IPRB   = MOD (IGAM12/ 100/ 100, 100)
+SELF, IF = - NEW MICRO.
          IF (IPRB .EQ. 0) IPRB = 5
+SELF.
          FDST(IND+15) = 0.01*(FLOAT(IPRB) - 0.5)
          IF (IGAM12 .GE. 1 000 000) FDST(IND+15) = FDST(IND+15) + 100.
          FG = 0.1*FLOAT (IT-18)
          IF (IGAM1 .EQ. 0 .OR. IGAM2 .EQ. 0) THEN
            FDST(IND+16) = -1.
          ELSE
            FDST(IND+16) = 1.
            JND = INDGAM + NWGAM*(IGAM1 - 1)
            IF (MOD (FDST(JND+13), 1.0) .NE. 0.0 .AND.
     -               FDST(IND+15)  .GE. 100.) IRMTCH = IRMTCH + 1
            FDST(IND+12) = FDST(JND+1)
            IF (FDST(IND+15) .GE. 100.0)
     -      FDST(JND+13) = FDST(IND+1) + FG
            JND = INDGAM + NWGAM*(IGAM2 - 1)
            IF (MOD (FDST(JND+13), 1.0) .NE. 0.0 .AND.
     -               FDST(IND+15)  .GE. 100.) IRMTCH = IRMTCH + 1
            FDST(IND+13) = FDST(JND+1)
            IF (FDST(IND+15) .GE. 100.0)
     -      FDST(JND+13) = FDST(IND+1) + FG
          END IF
  180   CONTINUE
        NWORDS = INDPI0 + NWPI0*NPI0
      END IF
+SELF, IF = REMATCH.
C-    REMATCH PI0/ETA/ETAP
      IF (IRMTCH .NE. 0) CALL REMTCH
+SELF.
C-
      IPRNT = 0
      CALL HIST (IPRNT)
      IF (IPRNT .NE. 0)  CALL PRNTEV
      IF (MOD (NEV,20) .NE. 0) GO TO 200
C--   CHECK TIME LIMIT
      CALL TIMEL (TLEFT)
      IF (TLEFT .GT. 120.0) GO TO 200
      GO TO 260
C--
C--      GO BACK FOR NEXT EVENT.
C
  200 CONTINUE
      NEV = NEV + 1
+SELF, EVENT SAVE.
      IF (MOD (NEV,10 000) .EQ. 0) CALL HSAVE
+SELF.
      GO TO 100
  220 IFAIL = IFAIL + 1
      PRINT *, ' FAILURE #', IFAIL, ' ON LUN ', LUNIN
      IF (IFAIL .LE. 13) GO TO 100
  240 CONTINUE
+SELF, IF = QMVAX.
      CLOSE (UNIT=LUNIN)
+SELF.
      NEVTOT = NEVTOT + NEV
      NEV  = 0
      NEVT = 0
      LUNIN = LUNIN + 1
+SELF, IF = QMVAX.
      OPEN (UNIT=LUNIN,STATUS='OLD',FORM='UNFORMATTED',READONLY
     +,ERR=260)
+SELF.
      CALL HSAVE
      GO TO 100
C-
  260 CALL QEND
C-
      END
C=======================================================================
+DECK, HSAVE.
      SUBROUTINE HSAVE
+CDE, SAVE, DSTREC.
      COMMON // IB(200)
      COMMON /NEL/ NELAST,NMULT,NSKIP
      LOGICAL HEXIST
C-
      NEVT   = NEVT   + NEV
      NEVTOT = NEVTOT + NEV
      IROLL  = ISRLL
      IFRAME = ISFRM
      NEV1   = NEV
      NEV = 0
C     COMMON /SAVE/ LUNHSV, NEVT, NEVTOT, NEV, IROLL, IFRAME, LUNIN
      IF (HEXIST(2))  THEN
        CALL VFLOAT (NEVT,SAVBUF,  6)
        CALL HPAK (2, SAVBUF)
      END IF
      IF (LUNHSV .EQ. 0) LUNHSV = 31
+SELF, QMVAX.
      OPEN (UNIT=LUNHSV,STATUS='UNKNOWN'
     +,              FORM='UNFORMATTED')
+SELF.
      CALL HSTORE (0,LUNHSV)
+SELF, QMVAX.
      CLOSE (UNIT=LUNHSV)
+SELF.
      PRINT 9000, LUNIN, NEVTOT, NEVT, NEV1, IROLL, IFRAME
      PRINT 9001, NELAST,NMULT,NSKIP
 9000 FORMAT('0HSAVE. ON LUN = ',I3 / 10X,'AFTER ',I10,'/',I10,'/',I10,
     +' EVENTS.' / 10X,'LAST ROLL/FRAME',I10,'/',I10 / 10X,23('-'))
 9001 FORMAT('NUMBER OF REJECTED ELASTIC EVENTS = ', I10/
     +       'NUMBER OF EVENTS WITH MULT>40 OR <2 = ', I10/
     +       'NUMBER OF SKIPPED EVENTS = ', I10)
C     WRITE(3,9011) LUNIN,  NEVTOT, NEVT, NEV1, IROLL, IFRAME
      RETURN
      END
C * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+DECK,ELAST.
      SUBROUTINE ELAST(IELOK)
+CDE, DSTREC,MASSES.
      DIMENSION VTR1(3),VTR2(3),V1(4),V2(4),VS(4),VM(4),SCM(4)
      IELOK = 0
      CHRG1 = -1.
      CHRG2 = -1.
      K=1
      INDT=INDPRT+NWPRT*(K-1)
      IF( FDST(INDT+2) .GT. 0.0) CHRG1 = 1.
      CALL UCOPY(FDST(INDT+4),VTR1(1),3)
      P1M = VMOD(VTR1(1),3)
      K=2
      INDT=INDPRT+NWPRT*(K-1)
      IF( FDST(INDT+2) .GT. 0.0) CHRG2 = 1.
      CALL UCOPY(FDST(INDT+4),VTR2(1),3)
      P2M = VMOD(VTR2(1),3)
      CHRG = CHRG1+CHRG2
      IF (CHRG .NE. 2.) GO TO 100
      IF (P1M .GT. P2M) THEN
        CALL UCOPY (VTR1,V1,3)
        CALL UCOPY (VTR2,V2,3)
      ELSE
        CALL UCOPY (VTR2,V1,3)
        CALL UCOPY (VTR1,V2,3)
      END IF
      P1M = VMOD(V1(1),3)
      P2M = VMOD(V2(1),3)
      V1(4) = SQRT(DOT(V1,V1)+AMPI**2)
      V2(4) = SQRT(DOT(V2,V2)+AMP**2)
CCC     BEAM IN LAB SYSTEM
      SCM(1) = 250.*COS(FDST(27))*COS(FDST(28))
      SCM(2) = 250.*COS(FDST(27))*SIN(FDST(28))
      SCM(3) = 250.*SIN(FDST(27))
      SCM(4) = SQRT(DOT(SCM,SCM)+AMPI**2)+AMP
CCC     SUM OF PARTICLE MOMENTA
      CALL VADD(V1,V2,VS,4)
CCC     MISSING  MOMENTUM
      CALL VSUB(SCM,VS,VM,4)
      PLM = DOT(VM,SCM)/250.
      PTM = SQRT(ABS(DOT(VM,VM)-PLM**2))
      CPHI = DOTNOR(V1,SCM)
      DPHI = 0.0
      IF (CPHI .LT. 1.) DPHI = 1000.*ACOS(CPHI)
      SQMM = -DOTI(VM,VM)
      IF (PLM .GE. -9. .AND. PLM .LE. 9.) GO TO 2
      IF (PTM .LE. 0.1) GO TO 2
C        IF (PLM .GE. -9. .AND. PLM .LE. 9. .AND.
C    +       PTM .LE. 0.1) GO TO 2
      IF (P2M .GT. 1.3) GO TO 100
C        IF (PLM .LT. -9. .OR. PLM .GT. 9.) GO TO 100
C        IF (PTM .GT. 0.1) GO TO 100
      IF (DPHI .GT. 4.0) GO TO 100
      IF (ABS(SQMM) .GT. 0.2) GO TO 100
    2 IELOK = 1
  100 RETURN
      END
C * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+PATCH, NEW GAM UTY.
+KEEP, SLATET.
      COMMON/SLATE/ NTGAM, GLAB(40), GMLAB(40)
+DECK, CLEPI0.
      SUBROUTINE CLEPI0
+CDE, DSTREC, QUNIT, GEOM, MASSES, CPI0, CMS.
+CDE, PRBCUT.
+CDE, SLATET.
C-
      IF (INIT .LE. 0) CALL GWINIT
      IF (NGAM .LE. 0) RETURN
C --- LOOP OVER GAMMAS
      NTGAM = 0
      DO 120 I = 1, NGAM
        IND = INDGAM + NWGAM*(I-1)
        FDST(IND+16) = -1.
        IF (FDST(IND+14) .GT.       0.) GO TO 120
C       IF (FDST(IND+14) .GE.  100000.) GO TO 120
        IF (FDST(IND+3) .LE. 0.0001) GO TO 120
        IF (FDST(IND+3) .GT. 400.00) GO TO 120
        P = VMOD (FDST(IND+3), 3)
        TY = FDST(IND+4)/FDST(IND+3)
        TZ = FDST(IND+5)/FDST(IND+3)
        X1 = LOG (P)
        IGAM  = FDST(IND+12) - 1
        XGD = XFGD
        IF (IGAM .EQ. 1) XGD = XIGD
        IF (IGAM .EQ. 1 .AND. ISRLL .GT. 300)
     +  XGD = XIGD + 3.09*(9./7. + 1.16*(LOG(P/0.0134) - 0.62))
        YGD = XYZPR(2) + TY*(XGD - XYZPR(1))
        ZGD = XYZPR(3) + TZ*(XGD - XYZPR(1))
        IF (IGAM.EQ. 1) THEN
          IF (ISRLL .GT. 300) THEN
            YGD = YGD + SYZIGD (TY, P) + 0.306
            ZGD = ZGD + SYZIGD (TZ, P) - 0.200
            XGD = XIGD
            P = 1.0095*P
          ELSE
            XGD = XIGD + 3.09*(9./7. + 1.16*(LOG(P/0.0134) - 0.62))
          END IF
        ELSE
          IF (ISRLL .GT. 300) THEN
            YGD = YGD + SYFGD  (TY, P) - 0.607
            ZGD = ZGD + SZFGD  (TZ, P) + 0.298
          END IF
        END IF
        TY = (YGD - XYZPR(2))/(XGD - XYZPR(1))
        TZ = (ZGD - XYZPR(3))/(XGD - XYZPR(1))
        FDST(IND+3) = P/SQRT (1. + TY**2 + TZ**2)
        FDST(IND+4) = TY*FDST(IND+3)
        FDST(IND+5) = TZ*FDST(IND+3)
C --- SET CUT ON GAMMA HERE
        IF (IGAM .EQ. 1 .AND. P .LE. ECUTIG) GO TO 120
        IF (IGAM .EQ. 2 .AND. P .LE. ECUTFG) GO TO 120
        CALL GAMLOS (XYZPR,FDST(IND+3), TRADL, IFLAG)
        IF (IFLAG .LE. 0)   GO TO 120
        FDST(IND+16) = EXP (- TRADL)
+SELF, IF = - CROSS.
  100   IF (IGAM .EQ. 2) THEN
          IF (ISRLL .GT. 202) THEN
C --- PROTON         NO MOMENTUM DEPENDING CORRECTION FOR PROTON PART
            EFGD = 1.
C           EFGD = MIN (1.0, 0.256 + 0.686*LOG10(P/2.))
C           EFGD = MAX (0.5, MIN (1.0, 0.256 + 0.686*LOG10(P/2.)))
C           EFGD  = MIN (1.0, 0.48747327+0.23221532*LOG(P/2.))
C           EFGD  = MIN (1.0, 1.0118*(0.22837 + 0.40903*LOG(P/2.)))
            EFGD  = MIN (1.0,(0.12861 + 0.54663*LOG(P/2.))/1.104)
          ELSE
C --- PION
+SELF, IF = - STOPCHENKO, IF = - CROSS.
            EFGD = 1.
C           EFGD = MIN (1.0, 0.324 + 0.446*LOG10(P/2.))
C           EFGD = MAX (0.5, MIN (1.0, 0.324 + 0.446*LOG10(P/2.)))
+SELF, IF = STOPCHENKO, IF = - CROSS.
            FGDW =   FGDWT (P)
            EFGD =   1.0
            IF (FGDW .GT. 0) EFGD = 1./FGDW
+SELF, IF = - CROSS.
        END IF
C          FDST(IND+16) = FDST(IND+16)*EFGD
      END IF
+SELF, IF = CROSS.
        FDST(IND+12) = IFLAG + 1
  100   CONTINUE
+SELF.
        NTGAM = NTGAM + 1
        GLAB(NTGAM) = FDST(IND+1)
  120 CONTINUE
+SELF, IF = - CROSS.
      CALL CPI022
+SELF, IF = ADD PI0.
C --- LOOK FOR FAST GAMMAS AND TRY TO MAKE NEW PI0S
      IF (NDEC .EQ. 0) THEN
        LND = NWORDS
        DO 220 I = 1, NGAM
          IND = INDGAM + NWGAM*(I - 1)
          IF (FDST(IND+3) .GT. 0.01) GO TO 220
          IF (FDST(IND+13) .NE. 0.0) GO TO 220
          IF (FDST(IND+16) .LE. 0.0) GO TO 220
          IGAM  = FDST(IND+12)
          RMIN = RMNIGD
          IF (IGAM .EQ. 3) RMIN = RMNFGD
          DO 215 IM = 1, 3
            AMSS = AMPI0
            IF (IM .EQ. 2) AMSS = AMETA
            IF (IM .EQ. 3) AMSS = AMETAP
            IF (FDST(IND+3) .LT. 0.9) ETA = 1./(FDST(IND+3)*AMSS)
            IF (FDST(IND+3) .GE. 0.9) ETA = VMOD (FDST(IND+3),3)/AMSS
            ETASIN = 1./(RMIN*ETA)
            IF (ETASIN .GE. 1.0) GO TO 220
            COSMIN = SQRT (1. - ETASIN**2)
            IF (COSTHE .LT. 0.1) GO TO 220
            CALL UCOPY (FDST(IND+1),FDST(LND+1), NWPI0)
            NPI0   = NPI0 + 1
            NW     = NWORDS + NWPI0
            IF (NW .GT. MAXDST) GO TO 240
            NWORDS = NW
            FDST(LND+2) = AMSS
            FDST(IND+13) = FDST(LND+1)
            FDST(LND+12) = FDST(IND+1)
            FDST(LND+13) = -1.
            FDST(LND+14) = 0.
            FDST(LND+15) = COSMIN
            FDST(LND+16) = FDST(IND+16)**2
            LND = LND + NWPI0
  215     CONTINUE
  220   CONTINUE
      END IF
  240 CONTINUE
+SELF.
      INIPI0 = 1
      RETURN
      END
+DECK, CPI022.
      SUBROUTINE CPI022
+CDE, DSTREC, QUNIT, GEOM, MASSES, CPI0, CMS.
+CDE, PRBCUT.
+CDE, SLATET.
  140 NWORDS = NWORDS - NWPI0*NPI0
      NPI0  = 0
      DO 210 I = 1, NGAM - 1
        IND = INDGAM + NWGAM*(I-1)
        IF (IUCOMP (FDST(IND+1),GLAB, NTGAM) .LE. 0) GO TO 210
        IGAM1  = FDST(IND+12)
        ENI    = VMOD (FDST(IND+3),3)
C        TYI    = FDST(IND+4)/FDST(IND+3)
C        TZI    = FDST(IND+5)/FDST(IND+3)
C        IF (IGAM1 .EQ. 2) THEN
C          DENI = (0.02 + 0.15/SQRT(ENI) + 0.25/ENI)/2.35
C          DYI  = (0.8/SQRT(ENI) + 0.1)/XIGD
C        ELSE IF (IGAM1 .EQ. 3) THEN
C          DENI = (1.2/ENI + 0.026*ENI/(ENI + 50.))/2.35
C          DYI  = 0.3/XFGD
C        END IF
        DO 205 J = I + 1, NGAM
          JND = INDGAM + NWGAM*(J-1)
          IF (IUCOMP (FDST(JND+1),GLAB, NTGAM) .LE. 0) GO TO 205
          IGAM2  = FDST(JND+12)
          ENJ    = VMOD (FDST(JND+3),3)
C          TYJ    = FDST(JND+4)/FDST(JND+3)
C          TZJ    = FDST(JND+5)/FDST(JND+3)
C          IF (IGAM2 .EQ. 2) THEN
C            DENJ = (0.02 + 0.15/SQRT(ENJ) + 0.25/ENJ)/2.35
C            DYJ  = (0.8/SQRT(ENJ) + 0.1)/XIGD
C          ELSE IF (IGAM2 .EQ. 3) THEN
C            DENJ = (1.2/ENJ + 0.026*ENJ/(ENJ + 50.))/2.35
C            DYJ  = 0.3/XFGD
C          END IF
C          R2 = (TYI - TYJ)**2 + (TZI - TZJ)**2
          AAMSS   = EMASS (0., FDST(IND+3), 0., FDST(JND+3))
          DMSS19 = 0.0085
          DMSS20 = DMSS19/AMPI0*AMETA
          DMSS21 = DMSS19/AMPI0*AMETAP
          IT = 0
          IF (ABS(AAMSS - AMPI0 ) .LT. 4.*DMSS19) THEN
            IT = 19
          ELSE
            IF (ABS(AAMSS - AMETA ) .LT. 4.*DMSS20) THEN
              IT = 20
            ELSE
              IF (ABS(AAMSS - AMETAP) .LT. 4.*DMSS21) IT = 21
            END IF
          END IF
          IF (IT .EQ. 0) GO TO 205
          IF (IT .EQ. 19) AMSS = AMPI0
          IF (IT .EQ. 20) AMSS = AMETA
          IF (IT .EQ. 21) AMSS = AMETAP
          IF (IT .EQ. 19) DMSS = DMSS19
          IF (IT .EQ. 20) DMSS = DMSS20
          IF (IT .EQ. 21) DMSS = DMSS21
          CHISQ  = ((AMSS - AAMSS)/DMSS)**2
          PRBFIT = PROB (CHISQ, 1)
          IF (PRBFIT .LT. PRBCUT) GO TO 205
          P      = VMOD (PXYZ,3)
          COSTHE = ABS(ENI-ENJ)/P
          ETA  = P/AMSS
          GAMMA = SQRT (1. + ETA**2)
          OVBETA = GAMMA*AAMSS/P
          IGO = IGAM1 + IGAM2 - 3
          COSMIN = 0.
          IF (IGAM1 .EQ. IGAM2) THEN
            RMIN = RMNIGD
            IF (IGAM1 .EQ. 3) RMIN = RMNFGD
            ETASIN = 1./(RMIN*ETA)
            IF (ETASIN .LT. 1.0) COSMIN = SQRT (1. - ETASIN**2)
          END IF
          IF (COSTHE .LT. COSMIN) GO TO 205
          COSMAX = OVBETA*(1. - GAMMN(1)/GAMMA)
          COSMAX = MIN (0.9, COSMAX)
          IF (COSTHE .GE. COSMAX) GO TO 205
          LND = NWORDS
          NW     = NWORDS + NWPI0
          IF (NW .GT. MAXDST) GO TO 210
          NWORDS = NW
          NPI0 = NPI0 + 1
          FDST(LND+1) = (NPI0 + 256*IT)
          FDST(LND+2) = AAMSS
          CALL UCOPY (PXYZ,FDST(LND+3),3)
          FDST(LND+12) = FDST(JND+1)
          FDST(LND+13) = FDST(IND+1)
          FDST(LND+14) = AMSS
          FDST(LND+15) = PRBFIT
          FDST(LND+16) = FDST(IND+16)*FDST(JND+16)*(1. - PRBCUT)*
     *                  (COSMAX - COSMIN)
  205   CONTINUE
  210 CONTINUE
      CALL REMTCH
      RETURN
      END
+DECK, GAMLOS.
      SUBROUTINE GAMLOS (XV, PGAM, TRADL, IFLAG)
C --- ACCOUNT LOSSES OF GAMMAS INTO E+E- CONVERSION
+CDE, GEOM, CPI0.
      DIMENSION XV(3), PGAM(4)
+SELF, IF = CROSS.
      DATA INCROS / 0 /
+SELF.
C-
      IF (INIT .LE. 0) CALL GWINIT
+SELF, IF = CROSS.
      IF (INCROS .EQ. 0) THEN
        DUM = MIN ( - YIGD(1), YIGD(2), - ZIGD(1), ZIGD(2))
        YIGD(1) = - DUM
        YIGD(2) =   DUM
        ZIGD(1) = - DUM
        ZIGD(2) =   DUM
        DUM = MAX ( - YIGH(1), YIGH(2))
        YIGH(1) = - DUM
        YIGH(2) =   DUM
        DUM = MAX ( - ZIGH(1), ZIGH(2))
        ZIGH(1) = - DUM
        ZIGH(2) =   DUM
        DUM = MIN ( - YFGD(1), YFGD(2))
        YFGD(1) = - DUM
        YFGD(2) =   DUM
        DUM = MIN ( - ZFGD(1), ZFGD(2))
        ZFGD(1) = - DUM
        ZFGD(2) =   DUM
      END IF
      INCROS = INCROS + 1
+SELF.
C-
      IFLAG = 0
      TY = PGAM(2)/PGAM(1)
      TZ = PGAM(3)/PGAM(1)
      TRADL  = -1.
C --- CHECK GEOMETRICAL ACCPTANCE
C --- FAST AND SIMPLE CHECK
      TYY = TY + (XV(2) - TY*XV(1))/XIGD
      IF (TYY .LT. YIGD(1) .OR. TYY .GT. YIGD(2)) GO TO 140
      TZZ = TZ + (XV(3) - TZ*XV(1))/XIGD
      IF (TZZ .LT. ZIGD(1) .OR. TZZ .GT. ZIGD(2)) GO TO 140
      IF (TYY .GE. YIGH(1) .AND. TYY .LE. YIGH(2) .AND. TZZ .GE. ZIGH(1)
     +.AND. TZZ .LE. ZIGH(2)) GO TO 100
      IFLAG = 1
C 10.03.88
C --- ACCOUNT LX EXIT (1%) + W0 (.22%) + MDC1 (.4%) + W1 (.22%) + MDC2(.8%)
C           + MINIPIC (.7%) + PIC (.7%) + W2 (.62%) + D1 (.42%)
C           + AIR UP TO ISIS (2.48%) + ISIS (7.32%)
C     TRADL = (0.149 + 0.001*(6. - XV(1)))
+SELF, IF = PION.
C 06.09.89
C --- ACCOUNT LX EXIT (1%) + W0 (.22%) + MDC (.40%) + W1 (.22%)
C           + PIC (.7%) + W2 (1.%) + D1-D3 (1.26%) + ISIS (7.32%)
C           + AIR UP TO IGD EXCLUDING ISIS (3.39%) = 15.58%
      TRADL = (0.156 + 0.001*(6. - XV(1)))
+SELF, IF = PROTON.
C 06.09.89
C --- ACCOUNT LX EXIT (1%) + W0 (.22%) + MDC1 (.4%) + W1 (.22%) + MDC2(.8%)
C           + MINIPIC (.7%) + PIC (.7%) + W2 (1.0%) + D1-D3 (1.26%)
C           + AIR UP TO ISIS (3.39%) + ISIS (7.32%) = 17.01%
      TRADL = (0.170 + 0.001*(6. - XV(1)))
+SELF, IF = NA22.
C 04.10.89
C --- ACCOUNT EXIT WINDOW (0.48%) + TANK (3%)
C           + W2 (1.0%) + D1-D3 (1.26%)
C           + AIR UP TO ISIS (2.35%) + ISIS (7.32%)
C           + SC. HODOSCOPE (4.1%)  = 17.01%
      TRADL = (0.1951 + 0.001*(40. - XV(1)))
+SELF,  IF = CROSS.
      TYY =   (TZ + (XV(3) - TZ*XV(1))/XIGD)
      IF (TYY .LT. YIGD(1) .OR. TYY .GT. YIGD(2)) GO TO 140
      TZZ = - (TY + (XV(2) - TY*XV(1))/XIGD)
      IF (TZZ .LT. ZIGD(1) .OR. TZZ .GT. ZIGD(2)) GO TO 140
      IF (TYY .GE. YIGH(1) .AND. TYY .LE. YIGH(2) .AND.
     +    TZZ .GE. ZIGH(1) .AND. TZZ .LE. ZIGH(2)) THEN
        TYY =   (TZ + (XV(3) - TZ*XV(1))/XFGD)
        TZZ = - (TY + (XV(2) - TY*XV(1))/XFGD)
        IF (TYY .LT. YFGD(1) .OR. TYY .GT. YFGD(2)) GO TO 140
        IF (TZZ .LT. ZFGD(1) .OR. TZZ .GT. ZFGD(2)) GO TO 140
        IFLAG = 3
      END IF
+SELF.
      GO TO 120
  100 TYY = TY + (XV(2) - TY*XV(1))/XFGD
      IF (TYY .LT. YFGD(1) .OR. TYY .GT. YFGD(2)) GO TO 140
      TZZ = TZ + (XV(3) - TZ*XV(1))/XFGD
      IF (TZZ .LT. ZFGD(1) .OR. TZZ .GT. ZFGD(2)) GO TO 140
+SELF,  IF = CROSS.
      TYY =   (TZ + (XV(3) - TZ*XV(1))/XIGD)
      TZZ = - (TY + (XV(2) - TY*XV(1))/XIGD)
      IF (TYY .GE. YIGH(1) .AND. TYY .LE. YIGH(2) .AND. TZZ .GE. ZIGH(1)
     +.AND. TZZ .LE. ZIGH(2)) GO TO 140
+SELF.
      IFLAG = 2
+SELF,  IF = PION.
C 10.03.88
C --- ACCOUNT LX EXIT (1%) + W0 (.22%) + MDC1 (.4%) + W1 (.22%) + MDC2(.8%)
C           + MINIPIC (.7%) + PIC (.7%) + W2 (.62%) + D1 (.42%)
C           + AIR UP TO ISIS (2.48%) + ISIS (7.32%) +
C           + D2-D6 (.42% EACH) + AIR UP TO TRD (7.63%) +
C PION      + TRD (3.37% + 2.62?%)     15.4% FROM IGD TO FGD
      TRADL = (0.310 + 0.001*(6. - XV(1)))
+SELF,  IF = PROTON.
C 06.09.89
C --- ACCOUNT LX EXIT (1%) + W0 (.22%) + MDC1 (.4%) + W1 (.22%) + MDC2(.8%)
C           + MINIPIC (.7%) + PIC (.7%) + W2 (1.0%) + D1-D3 (1.26%)
C           + AIR UP TO ISIS (3.39%) + ISIS (7.32%) = 17.01%
C           + D4-D6(1.26%) + FC (?) + TRD (3.37+2.62+15%) + AIR UP TO FGD (7.4%)
C           = 46.66% +   12.7% (!?!)
CC      TRADL = (0.567 + 0.001*(6. - XV(1)))
      TRADL = (0.467 + 0.001*(6. - XV(1)))
+SELF, IF = NA22.
C 04.10.89
C --- ACCOUNT EXIT WINDOW (0.48%) + TANK (3%)
C           + W2 (1.0%) + D1-D3 (1.26%)
C           + AIR UP TO ISIS (2.35%) + ISIS (7.32%)
C           + SC. HODOSCOPE (4.1%)  = 17.01%
C           + D4-D6 (1.26%) +  + FC (?) +
C           + TRD (3.37+2.62+15%) + AIR UP TO FGD (7.4%)
      TRADL = (0.4916 + 0.001*(40. - XV(1)))
+SELF.
  120 CONTINUE
+SELF, IF = - NA22.
C --- CHECK LEXAN HOLE
      YPRED = XV(2) + TY*(10.1 - XV(1))
      ZPRED = XV(3) + TZ*(10.1 - XV(1))
      IF (ABS (YPRED) .GT. 2.5 .OR. ABS(ZPRED) .GT. 2.3) THEN
        IF (ABS (YPRED) .GT. 2.5) THEN
          IF (3.8*ABS(TY) .GT. ABS (YPRED) - 2.5) THEN
            XY = (ABS(YPRED) - 2.5)/ABS(TY)
          ELSE
            XY = 3.8
          END IF
        ELSE
          XY = 0.
        END IF
        IF (ABS (ZPRED) .GT. 2.3) THEN
          IF (3.8*ABS(TZ) .GT. ABS (ZPRED) - 2.3) THEN
            XZ = (ABS(ZPRED) - 2.3)/ABS(TZ)
          ELSE
            XZ = 3.8
          END IF
        ELSE
          XZ = 0.
        END IF
        TRADL = TRADL + MIN (3.8, MAX (0., XY, XZ))/30.
      END IF
+SELF.
      TRADL  = 7./9.*TRADL*SQRT(1. + TY**2 + TZ**2)
  140 RETURN
      END
+QUIT.
