*$ CREATE SOURCE.FOR
*COPY SOURCE
*
*=== source ===========================================================*
*
      SUBROUTINE SOURCE ( NOMORE )

      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
*
*----------------------------------------------------------------------*
*                                                                      *
*     Copyright (C) 1990-2010      by    Alfredo Ferrari & Paola Sala  *
*     All Rights Reserved.                                             *
*                                                                      *
*                                                                      *
*     New source for FLUKA9x-FLUKA20xy:                                *
*                                                                      *
*     Created on 07 January 1990   by    Alfredo Ferrari & Paola Sala  *
*                                                   Infn - Milan       *
*                                                                      *
*     Last change on  17-Oct-10    by    Alfredo Ferrari               *
*                                                                      *
*  This is just an example of a possible user written source routine.  *
*  note that the beam card still has some meaning - in the scoring the *
*  maximum momentum used in deciding the binning is taken from the     *
*  beam momentum.  Other beam card parameters are obsolete.            *
*                                                                      *
*       Output variables:                                              *
*                                                                      *
*              Nomore = if > 0 the run will be terminated              *
*                                                                      *
*----------------------------------------------------------------------*
*
      INCLUDE '(BEAMCM)'
      INCLUDE '(FHEAVY)'
      INCLUDE '(FLKSTK)'
      INCLUDE '(IOIOCM)'
      INCLUDE '(LTCLCM)'
      INCLUDE '(PAPROP)'
      INCLUDE '(SOURCM)'
      INCLUDE '(SUMCOU)'
*
      LOGICAL LFIRST
*
      SAVE LFIRST
      DATA LFIRST / .TRUE. /
*======================================================================*
*                                                                      *
*                 BASIC VERSION                                        *
*                                                                      *
*======================================================================*
      NOMORE = 0
*  +-------------------------------------------------------------------*
*  |  First call initializations:
      IF ( LFIRST ) THEN
*  |  *** The following 3 cards are mandatory ***
         TKESUM = ZERZER
         LFIRST = .FALSE.
         LUSSRC = .TRUE.
*  |  *** User initialization ***
      END IF
*  |
*  +-------------------------------------------------------------------*
*  Push one source particle to the stack. Note that you could as well
*  push many but this way we reserve a maximum amount of space in the
*  stack for the secondaries to be generated
*  Npflka is the stack counter: of course any time source is called it
*  must be =0

DO 10 I=1,2

      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.
*  |  Group number for "low" energy neutrons, set to 0 anyway
         IGROUP (NPFLKA) = 0
*  |
*  +-------------------------------------------------------------------*
*  |  Normal hadron:
      ELSE
         IONID = IJBEAM
         ILOFLK (NPFLKA) = IJBEAM
*  |  Flag this is prompt radiation
         LRADDC (NPFLKA) = .FALSE.
*  |  Group number for "low" energy neutrons, set to 0 anyway
         IGROUP (NPFLKA) = 0
      END IF
*  |
*  +-------------------------------------------------------------------*
*  From this point .....
*  Particle generation (1 for primaries)
      LOFLK  (NPFLKA) = 1
*  User dependent flag:
      LOUSE  (NPFLKA) = 0
*  No channeling:
      LCHFLK (NPFLKA) = .FALSE.
      DCHFLK (NPFLKA) = ZERZER
*  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
*  Kinetic energy of the particle (GeV)
	X=FLRNDM(XDUMMY)
	IF(X.LT.3.09152E-10)       THEN 
				TKEFLK (NPFLKA)=7.07E-10
	ELSE IF(X.LT.1.13788E-8 .AND. X.GE.3.09152E-10) THEN 
  				TKEFLK (NPFLKA)=5.5E-9
	ELSE IF(X.LT.1.38031E-7 .AND. X.GE.1.13788E-8 ) THEN 
  				TKEFLK (NPFLKA)=3.0E-8
	ELSE IF(X.LT.4.13276E-7 .AND. X.GE.1.38031E-7 ) THEN 
  				TKEFLK (NPFLKA)=7.5E-8
	ELSE IF(X.LT.1.19314E-6 .AND.X.GE.4.13276E-7  ) THEN 
  				TKEFLK (NPFLKA)=1.5E-7
	ELSE IF(X.LT.3.39709E-6 .AND.X.GE.1.19314E-6  ) THEN 
  				TKEFLK (NPFLKA)=3.0E-7
	ELSE IF(X.LT.7.91470E-6 .AND.X.GE.3.39709E-6  ) THEN 
  				TKEFLK (NPFLKA)=5.5E-7
	ELSE IF(X.LT.1.35792E-5 .AND. X.GE.7.91470E-6  ) THEN 
  				TKEFLK (NPFLKA)=8.5E-7
	ELSE IF(X.LT.6.85284E-5 .AND. X.GE.1.35792E-5  ) THEN 
  				TKEFLK (NPFLKA)=2.0E-6
	ELSE IF(X.LT.1.96178E-4 .AND. X.GE.6.85284E-5  ) THEN 
  				TKEFLK (NPFLKA)=4.5E-6
	ELSE IF(X.LT.4.25549E-4 .AND. X.GE.1.96178E-4  ) THEN 
  				TKEFLK (NPFLKA)=8.0E-6
	ELSE IF(X.LT.1.19743E-3 .AND. X.GE.4.25549E-4  ) THEN 
  				TKEFLK (NPFLKA)=1.5E-5
	ELSE IF(X.LT.3.36150E-3 .AND. X.GE.1.19743E-3  ) THEN 
  				TKEFLK (NPFLKA)=3E-5
	ELSE IF(X.LT.6.15384E-3 .AND. X.GE.3.36150E-3  ) THEN 
  				TKEFLK (NPFLKA)=5E-5
	ELSE IF(X.LT.9.43484E-3 .AND. X.GE.6.15384E-3  ) THEN 
  				TKEFLK (NPFLKA)=7E-5
	ELSE IF(X.LT.1.31048E-2 .AND. X.GE..9.43484E-3  ) THEN 
  				TKEFLK (NPFLKA)=9E-5
	ELSE IF(X.LT.2.35760E-2 .AND. X.GE.1.31048E-2  ) THEN 
  				TKEFLK (NPFLKA)=1.25E-4
	ELSE IF(X.LT.3.56429E-2 .AND. X.GE.2.35760E-2  ) THEN 
  				TKEFLK (NPFLKA)=1.75E-4
	ELSE IF(X.LT.4.89066E-2 .AND. X.GE.3.56429E-2  ) THEN 
  				TKEFLK (NPFLKA)=2.25E-4
	ELSE IF(X.LT.6.30677E-2 .AND. X.GE.4.89066E-2 ) THEN 
  				TKEFLK (NPFLKA)=2.75E-4
	ELSE IF(X.LT.7.79270E-2 .AND. X.GE.6.30677E-2  ) THEN 
  				TKEFLK (NPFLKA)=3.25E-4
	ELSE IF(X.LT.9.33846E-2 .AND. X.GE.7.79270E-2  ) THEN 
  				TKEFLK (NPFLKA)=3.75E-4
	ELSE IF(X.LT.1.09341E-1 .AND. X.GE.9.33846E-2  ) THEN 
  				TKEFLK (NPFLKA)=4.25E-4
	ELSE IF(X.LT.1.25596E-1 .AND. X.GE.1.09341E-1  ) THEN 
  				TKEFLK (NPFLKA)=4.75E-4
	ELSE IF(X.LT.1.42151E-1 .AND. X.GE.1.25596E-1  ) THEN 
  				TKEFLK (NPFLKA)=5.25E-4
	ELSE IF(X.LT.1.58905E-1 .AND. X.GE.1.42151E-1  ) THEN 
  				TKEFLK (NPFLKA)=5.75E-4
	ELSE IF(X.LT.1.92612E-1 .AND. X.GE.1.58905E-1  ) THEN 
  				TKEFLK (NPFLKA)=6.5E-4
	ELSE IF(X.LT.2.26420E-1 .AND. X.GE.1.92612E-1  ) THEN 
  				TKEFLK (NPFLKA)=7.5E-4
	ELSE IF(X.LT.2.60027E-1 .AND. X.GE.2.26420E-1  ) THEN 
  				TKEFLK (NPFLKA)=8.5E-4
	ELSE IF(X.LT.2.93236E-1 .AND. X.GE.2.60027E-1  ) THEN 
  				TKEFLK (NPFLKA)=9.5E-4
	ELSE IF(X.LT.3.57660E-1 .AND. X.GE.2.93236E-1  ) THEN 
  				TKEFLK (NPFLKA)=1.1E-3
	ELSE IF(X.LT.4.18692E-1 .AND. X.GE.3.57660E-1  ) THEN 
  				TKEFLK (NPFLKA)=1.3E-3
	ELSE IF(X.LT.4.75835E-1 .AND. X.GE.4.18692E-1  ) THEN 
  				TKEFLK (NPFLKA)=1.5E-3
	ELSE IF(X.LT.5.28790E-1 .AND. X.GE.4.75835E-1  ) THEN 
  				TKEFLK (NPFLKA)=1.7E-3
	ELSE IF(X.LT.5.77457E-1 .AND. X.GE.5.28790E-1  ) THEN 
  				TKEFLK (NPFLKA)=1.9E-3
	ELSE IF(X.LT.6.42778E-1 .AND. X.GE.5.77457E-1  ) THEN 
  				TKEFLK (NPFLKA)=2.15E-3
	ELSE IF(X.LT.6.99322E-1 .AND. X.GE.6.42778E-1  ) THEN 
  				TKEFLK (NPFLKA)=2.45E-3
	ELSE IF(X.LT.7.62449E-1 .AND. X.GE.6.99322E-1  ) THEN 
  				TKEFLK (NPFLKA)=2.8E-3
	ELSE IF(X.LT.8.24379E-1 .AND. X.GE.7.62449E-1  ) THEN 
  				TKEFLK (NPFLKA)=3.25E-3
	ELSE IF(X.LT.8.71051E-1 .AND. X.GE.8.24379E-1  ) THEN 
  				TKEFLK (NPFLKA)=3.75E-3
	ELSE IF(X.LT.9.05856E-1 .AND. X.GE.8.71051E-1  ) THEN 
  				TKEFLK (NPFLKA)=4.25E-3
	ELSE IF(X.LT.9.31585E-1 .AND. X.GE.9.05856E-1  ) THEN 
  				TKEFLK (NPFLKA)=4.75E-3
	ELSE IF(X.LT.9.64495E-1 .AND. X.GE.9.31585E-1  ) THEN 
  				TKEFLK (NPFLKA)=5.5E-3
	ELSE IF(X.LT.9.81847E-1 .AND. X.GE.9.64495E-1  ) THEN 
  				TKEFLK (NPFLKA)=6.5E-3
	ELSE IF(X.LT.9.90833E-1 .AND. X.GE.9.81847E-1  ) THEN 
  				TKEFLK (NPFLKA)=7.5E-3
	ELSE IF(X.LT.9.95430E-1 .AND. X.GE.9.90833E-1  ) THEN 
  				TKEFLK (NPFLKA)=8.5E-3
	ELSE IF(X.LT.9.97754E-1 .AND. X.GE.9.95430E-1  ) THEN 
  				TKEFLK (NPFLKA)=9.5E-3
	ELSE IF(X.LT.9.98921E-1 .AND. X.GE.9.97754E-1  ) THEN 
  				TKEFLK (NPFLKA)=1.050E-2
	ELSE IF(X.LT.9.99502E-1 .AND. X.GE.9.98921E-1  ) THEN 
  				TKEFLK (NPFLKA)=1.15E-2
	ELSE IF(X.LT.9.99789E-1 .AND. X.GE.9.99502E-1  ) THEN 
  				TKEFLK (NPFLKA)=1.25E-2
	ELSE IF(X.LT.9.99931E-1 .AND. X.GE.9.99789E-1  ) THEN 
  				TKEFLK (NPFLKA)=1.35E-2
	ELSE             	
				TKEFLK (NPFLKA)=1.45E-2
 	END IF
*  Particle momentum
      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

10 CONTINUE

      CALL SOEVSV
      RETURN
*=== End of subroutine Source =========================================*
      END


