*=== Cf252 neutron source ===========================================================*
*
      SUBROUTINE SOURCE ( NOMORE )

      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
*
      INCLUDE '(BEAMCM)'
      INCLUDE '(FHEAVY)'
      INCLUDE '(FLKSTK)'
      INCLUDE '(IOIOCM)'
      INCLUDE '(LTCLCM)'
      INCLUDE '(PAPROP)'
      INCLUDE '(SOURCM)'
      INCLUDE '(SUMCOU)'
*
      LOGICAL LFIRST
*
      SAVE LFIRST
      DATA LFIRST / .TRUE. /
*======================================================================*
      NOMORE = 0
*  +-------------------------------------------------------------------*
*  |  First call initializations:
      IF ( LFIRST ) THEN
*  |  *** The following 3 cards are mandatory ***
         TKESUM = ZERZER
         LFIRST = .FALSE.
         LUSSRC = .TRUE.
*  |  *** User initialization ***
c*****cf252 neutron source       
              
         if(FLRNDM.lt.3.09152E-10) then ENK =  4.14E-10
         IF(FLRNDM.ge.3.09152E-10 .and. FLRNDM.lt.1.13788E-08) ENK =  1.00E-09
         IF(FLRNDM.ge.1.13788E-08 .and. FLRNDM.lt.1.38031E-07) ENK =  1.00E-08
         IF(FLRNDM.ge.1.38031E-07 .and. FLRNDM.lt.4.13276E-07) ENK =  5.00E-08
         IF(FLRNDM.ge.4.13276E-07 .and. FLRNDM.lt.1.19314E-06) ENK =  1.00E-07
         if(FLRNDM.ge.1.19314E-06 .and. FLRNDM.lt.3.39709E-06) ENK =  2.00E-07
         IF(FLRNDM.ge.3.39709E-06 .and. FLRNDM.lt.7.91470E-06) ENK =  4.00E-07
         IF(FLRNDM.ge.7.91470E-06 .and. FLRNDM.lt.1.35792E-05) ENK =  7.00E-07
         IF(FLRNDM.ge.1.35792E-05 .and. FLRNDM.lt.6.85284E-05) ENK =  1.00E-06
         IF(FLRNDM.ge.6.85284E-05 .and. FLRNDM.lt.1.96178E-04) ENK =  3.00E-06
         IF(FLRNDM.ge.1.96178E-04 .and. FLRNDM.lt.4.25549E-04) ENK =  6.00E-06
         IF(FLRNDM.ge.4.25549E-04 .and. FLRNDM.lt.1.19743E-03) ENK =  1.00E-05
         IF(FLRNDM.ge.1.19743E-03 .and. FLRNDM.lt.3.36150E-03) ENK =  2.00E-05
         IF(FLRNDM.ge.3.36150E-03 .and. FLRNDM.lt.6.15384E-03) ENK =  4.00E-05
         IF(FLRNDM.ge.6.15384E-03 .and. FLRNDM.lt.9.43484E-03) ENK =  6.00E-05
         IF(FLRNDM.ge.9.43484E-03 .and. FLRNDM.lt.1.31048E-02) ENK =  8.00E-05
         IF(FLRNDM.ge.1.31048E-02 .and. FLRNDM.lt.2.35760E-02) ENK =  1.00E-04
         IF(FLRNDM.ge.2.35760E-02 .and. FLRNDM.lt.3.56429E-02) ENK =  1.50E-04
         IF(FLRNDM.ge.3.56429E-02 .and. FLRNDM.lt.4.89066E-02) ENK =  2.00E-04
         IF(FLRNDM.ge.4.89066E-02 .and. FLRNDM.lt.6.30677E-02) ENK =  2.50E-04
         IF(FLRNDM.ge.6.30677E-02 .and. FLRNDM.lt.7.79270E-02) ENK =  3.00E-04
         IF(FLRNDM.ge.7.79270E-02 .and. FLRNDM.lt.9.33846E-02) ENK =  3.50E-04
         IF(FLRNDM.ge.9.33846E-02 .and. FLRNDM.lt.1.09341E-01) ENK =  4.00E-04
         IF(FLRNDM.ge.1.09341E-01 .and. FLRNDM.lt.1.25596E-01) ENK =  4.50E-04
         IF(FLRNDM.ge.1.25596E-01 .and. FLRNDM.lt.1.42151E-01) ENK =  5.00E-04
         IF(FLRNDM.ge.1.42151E-01 .and. FLRNDM.lt.1.58905E-01) ENK =  5.50E-04
         IF(FLRNDM.ge.1.58905E-01 .and. FLRNDM.lt.1.92612E-01) ENK =  6.00E-04
         IF(FLRNDM.ge.1.92612E-01 .and. FLRNDM.lt.2.26420E-01) ENK =  7.00E-04
         IF(FLRNDM.ge.2.26420E-01 .and. FLRNDM.lt.2.60027E-01) ENK =  8.00E-04
         IF(FLRNDM.ge.2.60027E-01 .and. FLRNDM.lt.2.93236E-01) ENK =  9.00E-04
         IF(FLRNDM.ge.2.93236E-01 .and. FLRNDM.lt.3.57660E-01) ENK =  1.00E-03
         IF(FLRNDM.ge.3.57660E-01 .and. FLRNDM.lt.4.18692E-01) ENK =  1.20E-03
         IF(FLRNDM.ge.4.18692E-01 .and. FLRNDM.lt.4.75835E-01) ENK =  1.40E-03
         IF(FLRNDM.ge.4.75835E-01 .and. FLRNDM.lt.5.28790E-01) ENK =  1.60E-03
         IF(FLRNDM.ge.5.28790E-01 .and. FLRNDM.lt.5.77457E-01) ENK =  1.80E-03
         IF(FLRNDM.ge.5.77457E-01 .and. FLRNDM.lt.6.42778E-01) ENK =  2.00E-03
         IF(FLRNDM.ge.6.42778E-01 .and. FLRNDM.lt.6.99322E-01) ENK =  2.30E-03
         IF(FLRNDM.ge.6.99322E-01 .and. FLRNDM.lt.7.62449E-01) ENK =  2.60E-03
         IF(FLRNDM.ge.7.62449E-01 .and. FLRNDM.lt.8.24379E-01) ENK =  3.00E-03
         IF(FLRNDM.ge.8.24379E-01 .and. FLRNDM.lt.8.71051E-01) ENK =  3.50E-03
         IF(FLRNDM.ge.8.71051E-01 .and. FLRNDM.lt.9.05856E-01) ENK =  4.00E-03
         IF(FLRNDM.ge.9.05856E-01 .and. FLRNDM.lt.9.31585E-01) ENK =  4.50E-03
         IF(FLRNDM.ge.9.31585E-01 .and. FLRNDM.lt.9.64495E-01) ENK =  5.00E-03
         IF(FLRNDM.ge.9.64495E-01 .and. FLRNDM.lt.9.81847E-01) ENK =  6.00E-03
         IF(FLRNDM.ge.9.81847E-01 .and. FLRNDM.lt.9.90833E-01) ENK =  7.00E-03
         IF(FLRNDM.ge.9.90833E-01 .and. FLRNDM.lt.9.95430E-01) ENK =  8.00E-03
         IF(FLRNDM.ge.9.95430E-01 .and. FLRNDM.lt.9.97754E-01) ENK =  9.00E-03
         IF(FLRNDM.ge.9.97754E-01 .and. FLRNDM.lt.9.98921E-01) ENK =  1.00E-02
         IF(FLRNDM.ge.9.98921E-01 .and. FLRNDM.lt.9.99502E-01) ENK =  1.10E-02
         IF(FLRNDM.ge.9.99502E-01 .and. FLRNDM.lt.9.99789E-01) ENK =  1.20E-02
         IF(FLRNDM.ge.9.99789E-01 .and. FLRNDM.lt.9.99931E-01) ENK =  1.30E-02
         IF(FLRNDM.ge.9.99931E-01 .and. FLRNDM.lt.1.00000E+00) ENK =  1.40E-02
                                          
       END IF

*  |
* Npflka is the stack counter: of course any time source is called it
* must be =0
      NPFLKA = NPFLKA + 1
* Wt is the weight of the particle
      WTFLK  (NPFLKA) = ONEONE
      WEIPRI = WEIPRI + WTFLK (NPFLKA)
* Particle type (1=proton.....). Ijbeam is the type set by the BEAM
* card
*  +-------------------------------------------------------------------*
*  |  (Radioactive) isotope:
      IF ( IJBEAM .EQ. -2 .AND. LRDBEA ) THEN
         IARES  = IPROA
         IZRES  = IPROZ
         IISRES = IPROM
         CALL STISBM ( IARES, IZRES, IISRES )
         IJHION = IPROZ  * 1000 + IPROA
         IJHION = IJHION * 100 + KXHEAV
         IONID  = IJHION
         CALL DCDION ( IONID )
         CALL SETION ( IONID )
*  |
*  +-------------------------------------------------------------------*
*  |  Heavy ion:
      ELSE IF ( IJBEAM .EQ. -2 ) THEN
         IJHION = IPROZ  * 1000 + IPROA
         IJHION = IJHION * 100 + KXHEAV
         IONID  = IJHION
         CALL DCDION ( IONID )
         CALL SETION ( IONID )
         ILOFLK (NPFLKA) = IJHION
*  |  Flag this is prompt radiation
         LRADDC (NPFLKA) = .FALSE.
*  |
*  +-------------------------------------------------------------------*
*  |  Normal hadron:
      ELSE
         IONID = IJBEAM
         ILOFLK (NPFLKA) = IJBEAM
*  |  Flag this is prompt radiation
         LRADDC (NPFLKA) = .FALSE.
      END IF
*  |
*  +-------------------------------------------------------------------*
* From this point .....
* Particle generation (1 for primaries)
      LOFLK  (NPFLKA) = 1
* User dependent flag:
      LOUSE  (NPFLKA) = 0
* User dependent spare variables:
      DO 100 ISPR = 1, MKBMX1
         SPAREK (ISPR,NPFLKA) = ZERZER
 100  CONTINUE
* User dependent spare flags:
      DO 200 ISPR = 1, MKBMX2
         ISPARK (ISPR,NPFLKA) = 0
 200  CONTINUE
* Save the track number of the stack particle:
      ISPARK (MKBMX2,NPFLKA) = NPFLKA
      NPARMA = NPARMA + 1
      NUMPAR (NPFLKA) = NPARMA
      NEVENT (NPFLKA) = 0
      DFNEAR (NPFLKA) = +ZERZER
* ... to this point: don't change anything
* Particle age (s)
      AGESTK (NPFLKA) = +ZERZER
      AKNSHR (NPFLKA) = -TWOTWO
* Group number for "low" energy neutrons, set to 0 anyway
      IGROUP (NPFLKA) = 0
* Kinetic energy of the particle (GeV)
      TKEFLK (NPFLKA) = SQRT ( PBEAM**2 + AM (IONID)**2 ) - AM (IONID)
* Particle momentum
      PMOFLK (NPFLKA) = PBEAM
*     PMOFLK (NPFLKA) = SQRT ( TKEFLK (NPFLKA) * ( TKEFLK (NPFLKA)
*    &                       + TWOTWO * AM (IONID) ) )
* Cosines (tx,ty,tz)
      TXFLK  (NPFLKA) = UBEAM
      TYFLK  (NPFLKA) = VBEAM
      TZFLK  (NPFLKA) = WBEAM
*     TZFLK  (NPFLKA) = SQRT ( ONEONE - TXFLK (NPFLKA)**2
*    &                       - TYFLK (NPFLKA)**2 )
* Polarization cosines:
      TXPOL  (NPFLKA) = -TWOTWO
      TYPOL  (NPFLKA) = +ZERZER
      TZPOL  (NPFLKA) = +ZERZER
* Particle coordinates
      XFLK   (NPFLKA) = XBEAM
      YFLK   (NPFLKA) = YBEAM
      ZFLK   (NPFLKA) = ZBEAM
*  Calculate the total kinetic energy of the primaries: don't change
      IF ( ILOFLK (NPFLKA) .EQ. -2 .OR. ILOFLK (NPFLKA) .GT. 100000 )
     &   THEN
         TKESUM = TKESUM + TKEFLK (NPFLKA) * WTFLK (NPFLKA)
      ELSE IF ( ILOFLK (NPFLKA) .NE. 0 ) THEN
         TKESUM = TKESUM + ( TKEFLK (NPFLKA) + AMDISC (ILOFLK(NPFLKA)) )
     &          * WTFLK (NPFLKA)
      ELSE
         TKESUM = TKESUM + TKEFLK (NPFLKA) * WTFLK (NPFLKA)
      END IF
      RADDLY (NPFLKA) = ZERZER
*  Here we ask for the region number of the hitting point.
*     NREG (NPFLKA) = ...
*  The following line makes the starting region search much more
*  robust if particles are starting very close to a boundary:
      CALL GEOCRS ( TXFLK (NPFLKA), TYFLK (NPFLKA), TZFLK (NPFLKA) )
      CALL GEOREG ( XFLK  (NPFLKA), YFLK  (NPFLKA), ZFLK  (NPFLKA),
     &              NRGFLK(NPFLKA), IDISC )
*  Do not change these cards:
      CALL GEOHSM ( NHSPNT (NPFLKA), 1, -11, MLATTC )
      NLATTC (NPFLKA) = MLATTC
      CMPATH (NPFLKA) = ZERZER
      CALL SOEVSV
      RETURN
*=== End of subroutine Source =========================================*
      END






