*
* $Id: forpre.F,v 1.1.1.1 1996/01/11 14:14:37 mclareni Exp $
*
* $Log: forpre.F,v $
* Revision 1.1.1.1  1996/01/11 14:14:37  mclareni
* Cojets
*
*
#include "cojets/pilot.h"
      SUBROUTINE FORPRE(IFL)
C     **********************
C-- SET FORCING OF DECAYS
C-- CREATED: 88/06/14
#if defined(CERNLIB_SINGLE)
      IMPLICIT REAL (A-H,O-Z)
#endif
#if defined(CERNLIB_DOUBLE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
#endif
#include "cojets/data1.inc"
#include "cojets/data2.inc"
#include "cojets/decpar.inc"
#include "cojets/forcsl.inc"
#include "cojets/fstate.inc"
#include "cojets/itapes.inc"
#include "cojets/stable.inc"
      DIMENSION MDEC(6)
      ONE=1.
      EPSI=1.E-10
C-- TREAT FORCE DECAYS
      IF(NFORCE.EQ.0) GO TO 110
      DO 113 N=1,NFORCE
      IF(KFORCE(1,N).LT.0) GO TO 113
      IF(KFORCE(1,N).EQ.80.OR.KFORCE(1,N).EQ.90) THEN
        WRITE(ITLIS,114) (KFORCE(L,N),L=1,6)
114     FORMAT(/' ***FORCE OF'//' ',3X,6I10//' ***IS INVALID'
     *,' TO FORCE Z/W DECAY MODE USE WDECMODE'
     */'***JOB WILL BE ABORTED')
        IFL=1
        GO TO 113
      ENDIF
      NR=N
      IFR=0
C-- DMATCH SETS CBR OF MATCHED CHANNEL NEGATIVE
      CALL DMATCH(NR,MDEC,IFR)
C-- LOOK FOR OTHER FORCINGS OF SAME PARTICLE
118   NR=NR+1
      IF(NR.GT.NFORCE) GO TO 119
      IF(KFORCE(1,NR).NE.KFORCE(1,N)) GO TO 118
      CALL DMATCH(NR,MDEC,IFR)
      IF(IFR.EQ.0) KFORCE(1,NR)=-KFORCE(1,NR)
      GO TO 118
119   IF(IFR.GT.0) GO TO 130
C-- GO FORWARD TO FIND FINAL DECAY CHANNEL OF PARTICLE
      ICHI=IDB(MDEC(6))
      ICHR=ICHI-1
120   ICHR=ICHR+1
      IF(ABS(ABS(CBR(ICHR))-ONE).GT.EPSI) GO TO 120
      ICHF=ICHR
C-- GO BACKWARDS, CONVERT CUMULATIVE BR TO BR
      ICHR=ICHF+1
121   ICHR=ICHR-1
      IF(ICHR.EQ.ICHI) GO TO 122
      CBR(ICHR)=SIGN(ABS(CBR(ICHR))-ABS(CBR(ICHR-1)),CBR(ICHR))
C-- GO FORWARD, GET TCBR
122   TCBR=0.
      ICHR=ICHI-1
123   ICHR=ICHR+1
      IF(CBR(ICHR).GT.0.) THEN
        CBR(ICHR)=0.
      ELSE
        CBR(ICHR)=ABS(CBR(ICHR))
        TCBR=TCBR+CBR(ICHR)
      ENDIF
      IF(ICHR.LT.ICHF) GO TO 123
C-- GO FORWARD, SET FINAL CBR'S
      ICHR=ICHI
      CBR(ICHR)=CBR(ICHR)/TCBR
124   ICHR=ICHR+1
      CBR(ICHR)=CBR(ICHR)/TCBR+CBR(ICHR-1)
      IF(ICHR.LT.ICHF) GO TO 124
      GO TO 113
130   IFL=1
113   CONTINUE
      DO 115 N=1,NFORCE
115   KFORCE(1,N)=ABS(KFORCE(1,N))
110   IF(IFL.EQ.1) RETURN
C
C-- TREAT FORCESL
      IF(LFORSL.EQ.0) RETURN
      NCBRF=0
      IDL=ABS(LFORSL)
      DO 201 IP=21,352
      IF(RDECAY(IP).EQ.0.) GO TO 201
      IF(IDB(IP).EQ.0) GO TO 201
      ID=IDENTF(IP)
      IF(ID.LE.100) GO TO 201
      IF(MOD(ID,10).NE.0) GO TO 201
      IH=MOD(ID,100)/10
      IF(IH.NE.KFORSL) GO TO 201
      ICHI=ABS(IDB(IP))
      IF(ICHI.EQ.0) GO TO 201
      IFLS=0
      ICHR=ICHI-1
202   ICHR=ICHR+1
      IDIN1=ABS(KDP(ICHR,1))
      IDIN2=ABS(KDP(ICHR,2))
      IF(IDIN1.LE.0.OR.IDIN1.GT.352.OR.
     *   IDIN2.LE.0.OR.IDIN2.GT.352) GO TO 209
      ID1=ABS(IDENTF(KDP(ICHR,1)))
      ID2=ABS(IDENTF(KDP(ICHR,2)))
      IF(ID1.NE.IDL.AND.ID2.NE.IDL) GO TO 209
      IF(ID1.LT.11.OR.ID1.GT.16.OR.ID2.LT.11.OR.ID2.GT.16) GO TO 209
      IFLS=1
      CBR(ICHR)=-CBR(ICHR)
      ICHF=ICHR
209   IF(ABS(ABS(CBR(ICHR))-ONE).GT.EPSI) GO TO 202
      IF(IFLS.EQ.0) GO TO 201
      NCBRFI=NCBRF+1
      TCBR=0.
      ICHR=ICHF+1
203   ICHR=ICHR-1
      IF(CBR(ICHR).LT.0) THEN
        NCBRF=NCBRF+1
        IF(NCBRF.GT.MXFOSL) GO TO 560
        IF(ICHR.NE.ICHI) THEN
          CBRF(NCBRF)=ABS(CBR(ICHR))-ABS(CBR(ICHR-1))
        ELSE
          CBRF(NCBRF)=ABS(CBR(ICHR))
        ENDIF
        CBR(ICHR)=ABS(CBR(ICHR))
        TCBR=TCBR+CBRF(NCBRF)
        IKDP(NCBRF)=ICHR
      ENDIF
      IF(ICHR.NE.ICHI) GO TO 203
      IR=NCBRFI
      CBRF(IR)=CBRF(IR)/TCBR
206   IR=IR+1
      IF(IR.GT.NCBRF) GO TO 208
      CBRF(IR)=CBRF(IR)/TCBR+CBRF(IR-1)
      GO TO 206
208   RDECAY(IP)=-(FLOAT(NCBRFI)+TCBR)
      RDECAY(INTID(-IDEXT(IP)))=RDECAY(IP)
201   CONTINUE
      BRXFSL=0.
      DO 207 IP=21,352
207   IF(RDECAY(IP).LT.0.)
     *BRXFSL=MIN(REAL(BRXFSL),REAL(MOD(RDECAY(IP),1.)))
      BRXFSL=ABS(BRXFSL)
      RETURN
C
C-- ABNORMAL EXIT
560   WRITE(ITLIS,561) MXFOSL
561   FORMAT(5(/),1X,'NUMBER OF FORCED SEMILEPTONIC DECAY'
     *,' CHANNELS EXCEEDS ',I5
     *//1X,'INCREASE MXFOSL'
     *//1X,'EXECUTION TERMINATED')
      STOP
      END