C DELTA
+LIS, CRA*.
+OPT, MAPASM.
+USE, PROTON. T = INHIBIT.
+USE, PION, T = INHIBIT.
+USE, *DST UTY.
+USE, BUG, T = INHIBIT.
+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, RHORFL,T = INHIBIT.
+USE, DST CHECK, T = EXE, T = LIS.
+USE, DSTUTY, D=QEND, GOTJAK, EVLOOP, BLOCK DATA, T = EXE.
+USE, DSTUTY, D=RHO0XF, KSTXF, AKSTXF, T = EXE.
+USE, GAM UTY, D = REMATCH, T = EXE.
+USE, PARTID, D=PARTID, FRZERO, T = EXE.
+USE, FORWARD, T = INHIBIT.
+USE, DELPP. T = INHIBIT.
+USE, DELT0, T = INHIBIT.
+USE, DELP,  T = INHIBIT.
+USE, PI0, IF = DELP..
+USE, ETA, T = INHIBIT.
+KEEP, RECOV1.
+KEEP, EVENT SAVE.
      IF (MOD (NEV, 2 000) .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, 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 XFMIN /0.0/, DXF /0.10/, NXF/ 10 /
+KEEP, SET Y.
      DATA YMIN / 0.0/, 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.080, 3.080 /
+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 999), MAXQH
C
      CHARACTER*320   ITTL
      DIMENSION       TITL (80)
      EQUIVALENCE (ITTL,TITL)
      DATA NREC / 5 /
      DATA NSIGN / 8 /
+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 --- HBOOK INITIALIZATION
      CALL HLIMIT (999 999)
      CALL HTITLE ('NA27 NOBC KSTAR$')
      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 501 IS = 1, NSIGN
      ITTL(1:320) = '$'
+SELF, IF = - DELPP.
        IF (IS .LE. 2) GO TO 501
+SELF, IF = - DELT0.
        IF (IS .GE. 3 .AND. IS .LE. 4) GO TO 501
+SELF, IF = - PI0.            
        IF (IS .GE. 5 .AND. IS .LE. 6) GO TO 501
+SELF, IF = - ETA.
        IF (IS .GE. 7 .AND. IS .LE. 8) GO TO 501
+SELF.
        IF (IS .EQ. 1) ITTL (1:8) = 'PROT PI+'
        IF (IS .EQ. 2) ITTL (1:8) = 'PBAR PI-  '
        IF (IS .EQ. 3) ITTL(1:16) = 'PROT PI-'
        IF (IS .EQ. 4) ITTL(1:16) = 'PBAR PI+'
        IF (IS .EQ. 5) ITTL(1:16) = 'PROT PI0'
        IF (IS .EQ. 6) ITTL(1:16) = 'PBAR PI0'
        IF (IS .EQ. 7) ITTL(1:16) = 'PROT ETA'
        IF (IS .EQ. 8) ITTL(1:16) = 'PBAR ETA'
        NREC = 5
        IF (IS .GT. 4) NREC = 3
        DO 500 IR = 1, NREC
          NX   = 100
          XMIN = XAMIN
          XMAX = XAMAX
          IF (IS .GE. 7) THEN
            XMIN = 1.400
            XMAX = 3.400
          END IF
          IDA =  1000*(IR-1)
          IDB = IDA + 10 000*IS
          IF (IR .EQ. 1)           ITTL(9:12) = 'ALL '
          IF (IR .GT. 1)           ITTL(9:12) = 'PID1'
          IF (IR .GT. 3)           ITTL(9:12) = 'PID2'
          ITTL(13:24) = '            '
          IF (IR .EQ. 3)           ITTL(13:24) = ' P SELECTED '
          IF (IR .EQ. 5)           ITTL(13:24) = ' P&PI SELECT'
          ITTL(24:200) = 'TOTAL $'
          IDDB = IDB + 100
          CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
+SELF, IF = MULT.
          DO    I = 2, 32, 2
            ENCODE (80,'('' FOR MULT ='',I3,''$'')',TITL(7)) I
            IDDA = IDA + 100 + I
            IDDB = IDB + 100 + I
            CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
          END DO
+SELF, IF = XF.
          DO    I = 1, NXF
            X1 = XFMN + DXF*FLOAT(I - 1)
            X2 = X1 + DXF
            IF (I .EQ. 1 .AND. IS .GE. 5 .AND. IS .LE. 6)  X1 = 0.05
            ENCODE (80,'('' FOR '',F6.3,'' < XF < '',F6.3,''   $'')'
     -      ,TITL(7)) X1, X2
            IDDA = IDA + 300 + I
            IDDB = IDB + 300 + I
            CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
            ENCODE (80,'('' * ENERGY$'')',TITL(14))
            IDDB = IDB + 400 + I
            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,'('' FOR '',F5.2,'' < Y* < '',F5.2,''$'')'
     -     ,TITL(7)) X1, X2
            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,'('' FOR '',F5.2,'' < PT**2 < '',F5.2,''  $'')'
     -     ,TITL(7)) X1, X2
            IDDA = IDA + 600 + I
            IDDB = IDB + 600 + I
            CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
            IDDB = IDB + 700 + I
            ENCODE (20,'('' * ENERGY$'')',TITL(14))
            CALL HBOOK1 (IDDB,TITL,NX,XMIN,XMAX)
          END DO
+SELF.
  490   CONTINUE
  500   CONTINUE
  501 CONTINUE
      CALL HBSTAT (0)
      CALL HBARY (0)
      CALL HSAVE
+SEQ, RECOV2, T = PASS.
 2000 CALL EVLOOP
C--
C--      END OF RUN.
C
 3000 CALL QEND
      STOP
      END
C=======================================================================
+DECK, HIST.
      SUBROUTINE HIST (IPRNT)
+CDE, DSTREC, GEOM, CMS, CPI0, PRBCUT.
+SEQ, SET X, SET Y, SET PTSQ, SET COS, LIMITS.
+SEQ, MASSES.
+SEQ, IGDEV, GSOURCE, QBCD, QUNIT, IF = BUG.
+CDE, PARTID.
      DIMENSION  W(4,4),EW(4,4), YSTARS(3),PPA(3), PBB(4)
      DIMENSION ADLOSS(5), REFL(4,4), RFL(4)
C-
+SEQ, SELECT EV.
      IF (FDST(29) .LE. 0.0) GO TO 999
C-
      CALL USER
+SELF, IF = PI0, ETA.
      CALL CLEPI0
+SELF.
C --- PRIMARY INTERACTION
      IPRNT = 0
      MIW = FDST(21)
      IT = JBYT (MIW, 9,5)
      MULT = JBYT (MIW,16,6)
+SEQ, MULT, IF = PION.
      CALL HFILL (50,FLOAT(MULT))
      WEQMKB = FDST(29)
      CALL HFILL (51,FLOAT(MULT), WEQMKB)
C
      DO 60 I=1,NPRT
        IND = INDPRT + NWPRT*(I - 1)
        IF (FDST(IND+21) .LE. 0.) GO TO 57
        IS = 1
        IF (FDST(IND+2) .LT. 0.0) IS = 2
        WWTK = FDST(IND+21)
+SELF, IF = BUG.
      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
      IDC = ABS(FDST(IND+2))/1000.
      IF (ISRLL .LE. 202) IDC = MAX (1, IDC - 1)
      IOK = - 10
+SELF.
        CALL PARTID (IND, W, EW, IOK)
+SELF, IF = BUG.
      WRITE(IQPRNT,9010) LABEL(1),IDC,ICH,(FDST(IND+3+M), M = 1,3)
     +, PHIESA, CHASAD, NPT, CHISIS, EGD, CHARGD, PHIEFC, CHARFC
     +, ENERTD, CHATRD
     +, CHATOT, FDST(IND+21)
 9010 FORMAT(1X,A4,I1,A1,F7.3,2F6.2,F4.1,A,I3,A,F5.1,A,2(F4.1,A),'/'
     +,A,F5.2)
+SELF.
        IF (ABS(VSUM (W(1,4),4) - 1.) .GT. 0.1) IOK = -1
        IF (IOK .NE. 0) GO TO 57
        CALL UCOPY (W(1,4), FDST(IND+14), 4)
        FDST(IND+18) = 999.
        CALL ADMIXT (IND, 4, ADLOSS, IOK)
        CALL VZERO (FDST(IND+22), 5)
        IF (IOK .LT. 0) GO TO 60
        CALL UCOPY (ADLOSS, FDST(IND+22), 5)
        GO TO 60
   57   CALL VZERO (FDST(IND+14),4)
        FDST(IND+18) = -999.
        CALL VZERO (FDST(IND+22), 5)
   60 CONTINUE
      CALL HFILL (52,FLOAT(MULT), WEQMKB)
      DO 200 I=1,NPRT
        IND = INDPRT + NWPRT*(I - 1)
        IF (FDST(IND+21) .LE. 0.) GO TO 200
        IS = 1
        IF (FDST(IND+2) .LT. 0.0) IS = 2
+SELF, IF = PI0, ETA.
        DO 120 J = 1, NPI0
          LND = INDPI0 + NWPI0*(J - 1)
          IF (FDST(LND+16) .LE. 0.0) GO TO 120
+SELF, IF = - PI0, IF = ETA.
          IF (FDST(LND+2) .GT. 0.1 .AND. FDST(LND+2) .LT. 0.2)GO TO 120
+SELF, IF = PI0, IF = - ETA.
          IF (FDST(LND+2) .GT. 0.5)                           GO TO 120       
+SELF, IF = PI0, ETA.
          IR = IS + 4            
          IF (FDST(LND+2) .GT. 0.5 .AND. FDST(LND+2) .LT. 0.6)     
     -    IR = IR + 2
          ECUT = 24.1*FDST(LND+2)
          E =
     = SQRT (FDST(LND+2)**2 + VDOT (FDST(LND+3), FDST(LND+3), 3))
          IF (E .LT. ECUT) GO TO 120
C          AMPIPI = EMASS (AMPI,FDST(IND+4),AMPI0,FDST(LND+3))
C          XFPIPI = XF
          AMSS = EMASS (AMP ,FDST(IND+4), FDST(LND+2),FDST(LND+3))
          EE = PCMXYZ(4)/PMAX
          CALL GOTJAK (PXYZ,AMP, FDST(IND+4), COSTHE)
          TY = PXYZ(2)/PXYZ(1)
          TZ = PXYZ(3)/PXYZ(1)
          EFPI0 = GWPI0 (FDST(LND+2),FDST(LND+3),XYZPR,TY,TZ)
          IF (EFPI0 .LT. 0.10) GO TO 120
          WWS = FDST(IND+21)/(EFPI0*FDST(LND+16))
          WWW = WEQMKB*WWS
          RFL(1) = 1.
          RFL(2) = 1.
          RFL(3) = 1.
+SELF, IF = PI0, ETA, IF = - FORWARD.
C --- ACCOUNT PI0 MOMENTUM CUT
          COSMAX = COSMXJ (PXYZ(4),AMSS,FDST(LND+2),AMP ,ECUT)
          IF (COSTHE .GT. COSMAX) WWW = 2.*WWW
+SELF, IF = PI0, ETA, IF = FORWARD.           
          IF (COSTHE .LE. 0.0) GO TO 120
          WWW = 2.*WWW
+SELF, IF = PI0, ETA.
          EE = PCMXYZ(4)/PMAX
C          IF (IS .EQ. 1) RFL = RHOP (AMPIPI, XFPIPI)*FDST(IND+21)/WWTPPI
C          IF (IS .EQ. 2) RFL = RHOM (AMPIPI, XFPIPI)*FDST(IND+21)/WWTPPI
          IDB = 10000*IR
          CALL FILKCH (IDB+100, AMSS, WWW, FDST(IND+14),FDST(JND+14)
     +     , RFL)
+SELF, IF = MULT, IF = PI0, ETA.
          CALL FILKCH (IDB+100+MULT, AMSS, WWW,
     +      FDST(IND+14),FDST(JND+14), RFL)
+SELF, IF = XF, IF = PI0, ETA.
          IX  = IFIX((XF-XFMIN)/DXF) + 1
          IX  = MIN (IX, NXF)
          IF (XF .GT. 0.05 .AND. IX.GT. 0 .AND. IX .LE. NXF) THEN
            CALL FILKCH (IDB+300+IX, AMSS, WWW
     +     , FDST(IND+14), FDST(JND+14), RFL)
            CALL FILKCH (IDB+400+IX, AMSS,WWW*EE
     +     ,FDST(IND+14),FDST(JND+14), RFL)
          END IF
+SELF, IF = YSTAR, IF = PI0, ETA.
          IX  = IFIX((YSTAR-YMIN)/DY) + 1
          IF (IX .GT. 0 .AND. IX .LE. NY)
     +      CALL FILKCH (IDB+500+IX, AMSS, WWW
     +     , FDST(IND+14), FDST(JND+14), RFL)
+SELF, IF = PTSQ, IF = PI0, ETA.
          IX  = IFIX((PTSQ-PTSQMN)/DPTSQ) + 1
          IF (IX .GT. 0 .AND. IX .LE. NPTSQ) THEN
            CALL FILKCH (IDB+600+IX, AMSS, WWW
     +     , FDST(IND+14), FDST(JND+14), RFL)
            CALL FILKCH (IDB+700+IX, AMSS,WWW*EE
     +     ,FDST(IND+14),FDST(JND+14), RFL)
          END IF
+SELF, IF = PI0, ETA.
  120   CONTINUE
+SELF, IF = DELPP, DELT0.
        DO 150 J = 1, NPRT
          IF (J .EQ. I) GO TO 150
          JND = INDPRT + NWPRT*(J - 1)
          IF (FDST(IND+2)*FDST(JND+2) .EQ. 0.0) GO TO 150
+SELF, IF = - DELT0, IF = DELPP.
          IF (FDST(IND+2)*FDST(JND+2) .LE. 0.0) GO TO 150
+SELF, IF = DELT0, IF = - DELPP.
          IF (FDST(IND+2)*FDST(JND+2) .GE. 0.0) GO TO 150
+SELF, IF = DELPP, DELT0.
          IF (FDST(JND+21) .LE. 0.0) GO TO 150
          RFL(1) = 1.
          RFL(2) = 1.
          RFL(3) = 1.
+SELF, IF = DELPP, DELT0, IF = - FORWARD.
* --- ACCOUNT REFLECTIONS 
          IF (FDST(IND+2)*FDST(JND+2) .LT. 0.0) THEN
            NRF = 1  
            IF (FDST(IND+18) .EQ. 999.) NRF = 3
            IF (FDST(IND+18) .EQ. 999. .AND. FDST(JND+18) .EQ. 999.) 
     +                                  NRF = 4
            AMPIPI = EMASS (AMPI,FDST(IND+4),AMPI,FDST(JND+4))
            CALL RHO0XF (AMPIPI, XF, NRF, REFL(1,1))
*        +- AMBIGUITY
            IF (IS .EQ. 2) REFL(2,1) = REFL(3,1)
            REFL(3,1) = REFL(4,1)
            NRF = MAX (1, NRF-1)
            AMKPI  = EMASS (AMK ,FDST(IND+4),AMPI,FDST(JND+4))
            IF (IS .EQ. 1) CALL  KSTXF (AMKPI , XF, NRF, REFL(1,2))
            IF (IS .EQ. 2) CALL AKSTXF (AMKPI , XF, NRF, REFL(1,2))
            RFL(1) = MAX (0., 1. - REFL(1,1) - REFL(1,2))
            IF (NRF .GE. 2)
     +    RFL(2) = MAX (0., 
     +      1. - REFL(2,1)*FDST(IND+24) - REFL(2,2)*FDST(IND+25))
            IF (NRF .GE. 3)        
     +    RFL(3) = MAX (0., 
     *     (1. - REFL(3,1)*FDST(IND+24) - REFL(3,2)*FDST(IND+25)))
          END IF
+SELF, IF = DELPP, DELT0.
          AMSS = EMASS (AMP ,FDST(IND+4),AMPI,FDST(JND+4))
          EE = PCMXYZ(4)/PMAX
          CALL GOTJAK (PXYZ,AMP, FDST(IND+4), COSTHE)
C         IF (COSTHE .LT. 0.0) GO TO 150
CPION     ALENG = DLENG (FDST(IND+4), XYZPR,  686.)/780.4
          FACTOR =  686./780.4*AMPI/VMOD(FDST(JND+4),3)
          WWTPJ = FDST(JND+21)*EXP (FACTOR)
          WWW = WEQMKB*FDST(IND+21)*WWTPJ
+SELF, IF = DELPP, DELT0, IF = FORWARD..
          IF (COSTHE .LT. 0.0) GO TO 150
          WWW = 2.*WWW
+SELF, IF = DELPP, DELT0.
          IDB = 10000*IS
          IF (FDST(IND+2)*FDST(JND+2) .LE. 0.0) IDB = 10000*(IS + 2)
          CALL FILDEL (IDB+100, AMSS, WWW
     +     , FDST(IND+14), FDST(JND+14), RFL)
+SELF, IF = DELPP, DELT0, IF = MULT.
          CALL FILDEL (IDB+100+MULT, AMSS, WWW
     +     , FDST(IND+14), FDST(JND+14), RFL)
+SELF, IF = DELPP, DELT0, IF = XF.
          IX  = IFIX((XF-XFMIN)/DXF) + 1
          IX  = MIN (IX, NXF)
          IF (IX .GT. 0 .AND. IX .LE. NXF) THEN
            CALL FILDEL (IDB+300+IX, AMSS, WWW
     +     , FDST(IND+14), FDST(JND+14), RFL)
            CALL FILDEL (IDB+400+IX, AMSS, WWW*EE
     +     , FDST(IND+14), FDST(JND+14), RFL)
          END IF
+SELF, IF = DELPP, DELT0, IF = YSTAR.
          IX  = IFIX((YSTAR-YMIN)/DY) + 1
          IF (IX .GT. 0 .AND. IX .LE. NY)
     +      CALL FILDEL (IDB+500+IX, AMSS, WWW
     +     , FDST(IND+14), FDST(JND+14), RFL)
+SELF, IF = DELPP, DELT0, IF = PTSQ.
          IX  = IFIX((PTSQ-PTSQMN)/DPTSQ) + 1
          IF (IX .GT. 0 .AND. IX .LE. NPTSQ) THEN
            CALL FILDEL (IDB+600+IX, AMSS, WWW
     +    , FDST(IND+14), FDST(JND+14), RFL)
            CALL FILDEL (IDB+700+IX, AMSS, WWW*EE
     +    , FDST(IND+14), FDST(JND+14), RFL)
          END IF
+SELF.
  150   CONTINUE
  200 CONTINUE
  999 RETURN
      END
+DECK, FILDEL.
      SUBROUTINE FILDEL (IDD, AMSS, WWW, WI, WJ, RFL)
+CDE, PARTID.
      DIMENSION WI (15), WJ (15), RFL(4)
      CALL HFILL (IDD, AMSS, WWW)
      IF (WI(5) .EQ. -999.0) RETURN
      IF (WI(5) .EQ.  999.0) THEN
        CALL HFILL (IDD+1000, AMSS, WWW)
        IF (WI(4) .GE. PRBPID) 
     +  CALL HFILL (IDD+2000, AMSS, WWW*WI(9)*RFL(2))
        IF (WJ(5) .EQ.999.0)THEN
          CALL HFILL (IDD+3000, AMSS, WWW)
          IF (WI(4) .GE. PRBPID .AND. WJ(2) .GE. PRBPID)
     +      CALL HFILL (IDD+4000, AMSS, WWW*WI(9)*RFL(3))
        END IF       
      END IF
      RETURN
      END
+DECK, FILKCH.
      SUBROUTINE FILKCH (IDD, AMSS, WWW, WI, RFL)
+CDE, PARTID.
      DIMENSION WI (12)
      CALL HFILL (IDD, AMSS, WWW)
      IF (WI(5) .EQ. -999.0) RETURN
      IF (WI(5) .EQ.  999.0) THEN
        CALL HFILL (IDD+1000, AMSS, WWW)
        IF (WI(4) .GE. PRBPID)
     +  CALL HFILL (IDD+2000, AMSS, WWW*WI(9)*WI(13))
      END IF
      RETURN
      END
+QUIT.
