      SUBROUTINE ISOBAR( E,KIND,AMASS,ASMASS,NOPI )
 
C-----------------------------------------------------------------------
C  ISOBAR
C
C  THREE AND FOUR PION DECAY OF HEAVY ISOBAR, DECAY IS PICKED AT
C  RANDOM FROM A UNIFORM DISTRIBUTION WITH EQUAL PROBABILITY
C  CHARGE IS DISTRIBUTED AT RANDOM WITH EQUAL PROBABILITY
C  DECAYS ARE COMPUTED VIA MOMENTA, HAVING UNIFORM DISTRIBUTION
C  UPPER LIMIT OF MOMENTUM DISTRIBUTIONS ARE SPECIFIED BY INPUT DATA
C  ENERGY IS STRICTLY CONSERVED, MOMENTA ONLY ON AVERAGE
C  THIS SUBROUTINE IS CALLED FROM MANY BOX ROUTINES
C  ARGUMENTS:
C   E      = AVAILABLE ENERGY IN CM
C   KIND   = 1  BACKWARD ISOBAR
C          = 0  FORWARD  ISOBAR
C   AMASS  = MASS OF HEAVY MESON
C   ASMASS = MASS TO BE LEFT OVER FOR OTHER PARTICLES
C   NOPI   = NUMBER OF PIONS TO BE GENERATED
C-----------------------------------------------------------------------
 
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
*KEEP,BAL.
      COMMON /BAL/     EBAL
      DOUBLE PRECISION EBAL(10)
*KEEP,CONST.
      COMMON /CONST/   PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,ELASTY.
      COMMON /ELASTY/  ELAST,IELIS,IELHM,IELNU,IELPI
      DOUBLE PRECISION ELAST
      INTEGER          IELIS(20),IELHM(20),IELNU(20),IELPI(20)
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(37,13),MULTOT(37,13)
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(14),SECPAR(14),PRMPAR(14),OUTPAR(14),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
      EQUIVALENCE      (CURPAR(2),GAMMA),  (CURPAR(3),COSTHE),
     *                 (CURPAR(4), PHI ),  (CURPAR(5), H    ),
     *                 (CURPAR(6), T   ),  (CURPAR(7), X    ),
     *                 (CURPAR(8), Y   ),  (CURPAR(9), CHI  ),
     *                 (CURPAR(10),BETA),  (CURPAR(11),GCM  ),
     *                 (CURPAR(12),ECM )
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,
     *                 STEPFC,NRRUN,NSHOW,PATAPE,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,
     *                 CETAPE,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,
     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
      COMMON /RUNPAC/  DSN,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB
      REAL             STEPFC
      INTEGER          NRRUN,NSHOW,PATAPE,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE
      INTEGER          CETAPE
      CHARACTER*79     DSN
      CHARACTER*20     HOST,USER
 
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
*KEEP,VKIN.
      COMMON /VKIN/    BETACM
      DOUBLE PRECISION BETACM
*KEND.
 
C-----------------------------------------------------------------------
 
      IF ( DEBUG ) WRITE(MDEBUG,201)E,KIND,AMASS,ASMASS,NOPI
 201  FORMAT(' ISOBAR: E,KIND,AMASS,ASMASS,NOPI=',1P,E10.4,I3,2E10.4,I3)
 
C  RETURN 1 KILLS PARTICLE
 
      ISET  = 1
      EDI   = 0.D0
      PACC  = 0.D0
      RESTE = AMASS
 
      IF ( KIND .NE. 0 ) GOTO 100
 
C-----------------------------------------------------------------------
C  FORWARD ISOBAR
C  PIONS FROM FORWARD ISOBAR
      IF ( NOPI .EQ. 1 ) THEN
        INOPI = NOPI
        A     = C(36)
        W     = 0.38D0
      ELSE
        W     = 1.5D0
        CALL RMMAR( RD,1,1 )
        IF ( RD(1) .LE. 0.5 ) THEN
          INOPI = 3
          A     = C(36)
        ELSE
          INOPI = 4
          A     = C(35)
        ENDIF
      ENDIF
 
      GIFCM  = (E**2+AMASS**2-ASMASS**2) * 0.5D0 /(E*AMASS)
      BEIFCM = SQRT(GIFCM**2 - 1.D0) / GIFCM
      GIFLAB = GCM * GIFCM * (1.D0+BETACM*BEIFCM)
      BEIFL  = SQRT(GIFLAB**2 - 1.D0) / GIFLAB
 
C  PION LOOP FOR FORWARD ISOBAR DECAY
 13   CONTINUE
      P      = PCL(A,W)
      PT     = PTRANS(DUMMY)
      GPIIF  = SQRT( P**2 / PAMA(8)**2 + 1.D0 )
      BEPIIF = SQRT(GPIIF**2 - 1.D0) / GPIIF
      EDI    = EDI + SQRT( PAMA(8)**2 + P**2 + PT**2 )
      RESTE  = RESTE - EDI
 
      CALL RMMAR( RD,3,1 )
      IF ( RD(1) .GT. 0.5 ) THEN
        GPILAB = GPIIF*GIFLAB*(1.D0-BEIFL*BEPIIF)
        PACC   = PACC - P
      ELSE
        GPILAB = GPIIF*GIFLAB*(1.D0+BEIFL*BEPIIF)
        PACC   = PACC + P
      ENDIF
 
C  CORRECTIVE ACTION IF PLLAB2 LE 1.E-6
      PLLAB2 = PAMA(8)**2 *(GPILAB**2 - 1.D0)
      PLLAB2 = MAX( 1.D-6, PLLAB2 )
      CTHETA = SQRT( PLLAB2 / (PT**2+PLLAB2) )
      IF ( CTHETA .GE. C(27) ) THEN
        CALL ADDANG( COSTHE,PHI, CTHETA,RD(2)*PI2, SECPAR(3),SECPAR(4) )
        IF ( SECPAR(3) .GE. C(29) ) THEN
          SECPAR(2) = GPILAB
C  CHARGE ASSIGNMENT
          IF     ( RD(3) .LE. OB3 ) THEN
            SECPAR(1) = 7.D0
          ELSEIF ( RD(3) .LE. TB3 ) THEN
            SECPAR(1) = 8.D0
          ELSE
            SECPAR(1) = 9.D0
          ENDIF
          DO  5  J = 5,8
            SECPAR(J) = CURPAR(J)
 5        CONTINUE
 
          CALL TSTACK
        ENDIF
      ENDIF
      IF ( RESTE .LE. PAMA(14)  .OR.  ISET .EQ. INOPI ) GOTO 14
      ISET = ISET + 1
      GOTO 13
 
C  NUCLEON FROM FORWARD ISOBAR
 14   CONTINUE
      PT    = PTRANS(DUMMY)
      MSMM  = MSMM + ISET
      EPT   = SQRT( PAMA(14)**2 + PT**2 )
      RESTE = RESTE - EPT
 
      IF ( RESTE .LE. 0.D0 ) THEN
        GNFLAB  = GIFLAB
        EBAL(1) = EBAL(1) + RESTE
      ELSE
        GNIF    = (RESTE+PAMA(14)) / PAMA(14)
        BENIF   = SQRT(GNIF**2 - 1.D0) / GNIF
        IF ( PACC .LE. 0.D0 ) THEN
          GNFLAB = GIFLAB * GNIF * (1.D0 + BENIF*BEIFL)
        ELSE
          GNFLAB = GIFLAB * GNIF * (1.D0 - BENIF*BEIFL)
        ENDIF
      ENDIF
 
      PLLAB2 = PAMA(14)**2 * (GNFLAB**2 - 1.D0)
      PLLAB2 = MAX( 1.D-6, PLLAB2 )
      CTHETA = SQRT( PLLAB2 / (PT**2+PLLAB2) )
      IF ( CTHETA .LT. C(27) ) RETURN
      CALL RMMAR( RD,2,1 )
      CALL ADDANG( COSTHE,PHI, CTHETA,RD(1)*PI2, SECPAR(3),SECPAR(4) )
      IF ( SECPAR(3) .LT. C(29) ) RETURN
      SECPAR(2) = GNFLAB
 
      IF ( RD(2) .LT. 0.5 ) THEN
        IADD = 1
      ELSE
        IADD = 0
      ENDIF
 
      IF ( ITYPE .EQ. 13  .OR.  ITYPE .EQ. 14 ) THEN
        SECPAR(1) = 14 - IADD
      ELSE
        SECPAR(1) = 15 + 10*IADD
      ENDIF
 
C  CHARGE ASSIGNMENT
      DO  9  J = 5,8
        SECPAR(J) = CURPAR(J)
    9 CONTINUE
      CALL TSTACK
 
C  FILL HISTOGRAM
      IN = 1.D0 + SECPAR(2) / GAMMA * 20.D0
      IN = MIN( IN, 20 )
      IELIS(IN) = IELIS(IN) + 1
 
      RETURN
 
C-----------------------------------------------------------------------
C  BACKWARD ISOBAR
C  PIONS FROM BACKWARD ISOBAR
  100 CONTINUE
 
      IF ( NOPI .EQ. 1 ) THEN
        INOPI = NOPI
      ELSE
        CALL RMMAR( RD,1,1 )
        IF ( RD(1) .LE. 0.5 ) THEN
          INOPI = 3
        ELSE
          INOPI = 4
        ENDIF
      ENDIF
      WORK = MIN( C(11), GAMMA*0.5D0 )
      MSMM = MSMM + INOPI
      DO 101  J = 1,INOPI
        CALL RMMAR( RD,3,1 )
        GPI    = RD(1)*(WORK-1.D0) + 1.D0
        PT     = PTRANS(DUMMY)
        EDI    = EDI+SQRT( PAMA(8)**2+PAMA(8)**2*(GPI**2-1.D0)+PT**2 )
        RESTE  = ASMASS - EDI
        PLLAB2 = PAMA(8)**2 * (GPI**2 - 1.D0)
        PLLAB2 = MAX( 1.D-6, PLLAB2 )
        CTHETA = SQRT( PLLAB2 / (PT**2+PLLAB2) )
        IF ( CTHETA .GE. C(27) ) THEN
          CALL ADDANG( COSTHE,PHI, CTHETA,RD(2)*PI2,
     *                                    SECPAR(3),SECPAR(4) )
          IF ( SECPAR(3) .GE. C(29) ) THEN
            SECPAR(2) = GPI
C  CHARGE ASSIGNMENT
            RR = RD(3)
            IF     ( RR .LE. OB3 ) THEN
              SECPAR(1) = 7.D0
            ELSEIF ( RR .LE. TB3 ) THEN
              SECPAR(1) = 8.D0
            ELSE
              SECPAR(1) = 9.D0
            ENDIF
            DO 104  I = 5,8
              SECPAR(I) = CURPAR(I)
  104       CONTINUE
 
            CALL TSTACK
          ENDIF
        ENDIF
        IF ( RESTE .LE. PAMA(14) ) GOTO 110
  101 CONTINUE
 
C  NUCLEON FROM BACKWARD ISOBAR
 
  110 CONTINUE
      WORK    = MIN( C(10), GAMMA*0.5D0 )
      CALL RMMAR( RD,3,1 )
      GNRLAB  = RD(1) * (WORK-1.D0) + 1.D0
      PT      = PTRANS(DUMMY)
      EDI = EDI+SQRT( PAMA(14)**2 + PAMA(14)**2*(GNRLAB**2-1.D0)+PT**2)
      RESTE   = ASMASS - EDI
      EBAL(2) = EBAL(2) + RESTE
      PLLAB2  = PAMA(14)**2 * (GNRLAB**2 - 1.D0)
      PLLAB2  = MAX( 1.D-6, PLLAB2 )
      CTHETA  = SQRT( PLLAB2 / (PT**2+PLLAB2) )
      IF ( CTHETA .LT. C(27) ) RETURN
      CALL ADDANG( COSTHE,PHI, CTHETA,RD(2)*PI2, SECPAR(3),SECPAR(4) )
      IF ( SECPAR(3) .LT. C(29) ) RETURN
      SECPAR(2) = GNRLAB
C  CHARGE ASSIGNMENT
      IF ( RD(3) .LT. 0.5 ) THEN
        SECPAR(1) = 13.D0
      ELSE
        SECPAR(1) = 14.D0
      ENDIF
      DO 113  J = 5,8
        SECPAR(J) = CURPAR(J)
  113 CONTINUE
      CALL TSTACK
 
      RETURN
      END
