*$ 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)'
      real SPCTCUM(230), ENEDGE(230)
      real energy, xpos, ypos, zpos
      real xstart, xend, ystart, yend, zstart, zend
      INTEGER STAT1, STAT2, IE, IA, NE, NA
*
      LOGICAL LFIRST
*
      SAVE LFIRST
      DATA LFIRST / .TRUE. /
      DATA NE /230/
      DATA NA /40/
      data ENEDGE /
     &1.00000E-06,
     &9.82309E-05,
     &1.04693E-04,
     &1.11580E-04,
     &1.18921E-04,
     &1.26744E-04,
     &1.35082E-04,
     &1.43969E-04,
     &1.53440E-04,
     &1.63534E-04,
     &1.74293E-04,
     &1.85759E-04,
     &1.97979E-04,
     &2.11003E-04,
     &2.24884E-04,
     &2.39679E-04,
     &2.55446E-04,
     &2.72251E-04,
     &2.90161E-04,
     &3.09250E-04,
     &3.29595E-04,
     &3.51277E-04,
     &3.74387E-04,
     &3.99016E-04,
     &4.25266E-04,
     &4.53242E-04,
     &4.83060E-04,
     &5.14838E-04,
     &5.48708E-04,
     &5.84805E-04,
     &6.23277E-04,
     &6.64280E-04,
     &7.07981E-04,
     &7.54556E-04,
     &8.04195E-04,
     &8.57100E-04,
     &9.13486E-04,
     &9.73581E-04,
     &1.04000E-03,
     &1.11000E-03,
     &1.18000E-03,
     &1.26000E-03,
     &1.34000E-03,
     &1.43000E-03,
     &1.52000E-03,
     &1.62000E-03,
     &1.73000E-03,
     &1.84000E-03,
     &1.96000E-03,
     &2.09000E-03,
     &2.23000E-03,
     &2.38000E-03,
     &2.53000E-03,
     &2.70000E-03,
     &2.88000E-03,
     &3.07000E-03,
     &3.27000E-03,
     &3.48000E-03,
     &3.71000E-03,
     &3.95000E-03,
     &4.21000E-03,
     &4.49000E-03,
     &4.79000E-03,
     &5.10000E-03,
     &5.44000E-03,
     &5.80000E-03,
     &6.18000E-03,
     &6.58000E-03,
     &7.02000E-03,
     &7.48000E-03,
     &7.97000E-03,
     &8.49000E-03,
     &9.05000E-03,
     &9.65000E-03,
     &1.02800E-02,
     &1.09600E-02,
     &1.16800E-02,
     &1.24500E-02,
     &1.32700E-02,
     &1.41400E-02,
     &1.50700E-02,
     &1.60600E-02,
     &1.71200E-02,
     &1.82500E-02,
     &1.94500E-02,
     &2.07300E-02,
     &2.20900E-02,
     &2.35400E-02,
     &2.50900E-02,
     &2.67400E-02,
     &2.85000E-02,
     &3.03800E-02,
     &3.23800E-02,
     &3.45100E-02,
     &3.67800E-02,
     &3.92000E-02,
     &4.17700E-02,
     &4.45200E-02,
     &4.74500E-02,
     &5.05700E-02,
     &5.39000E-02,
     &5.74500E-02,
     &6.12300E-02,
     &6.52500E-02,
     &6.95500E-02,
     &7.41200E-02,
     &7.90000E-02,
     &8.41900E-02,
     &8.97300E-02,
     &9.56400E-02,
     &1.01930E-01,
     &1.08630E-01,
     &1.15780E-01,
     &1.23400E-01,
     &1.31510E-01,
     &1.40170E-01,
     &1.49390E-01,
     &1.59210E-01,
     &1.69690E-01,
     &1.80850E-01,
     &1.92750E-01,
     &2.05430E-01,
     &2.18940E-01,
     &2.33350E-01,
     &2.48700E-01,
     &2.65060E-01,
     &2.82500E-01,
     &3.01080E-01,
     &3.20890E-01,
     &3.42000E-01,
     &3.64500E-01,
     &3.88470E-01,
     &4.14030E-01,
     &4.41270E-01,
     &4.70300E-01,
     &5.01240E-01,
     &5.34210E-01,
     &5.69350E-01,
     &6.06810E-01,
     &6.46730E-01,
     &6.89280E-01,
     &7.34620E-01,
     &7.82950E-01,
     &8.34460E-01,
     &8.89350E-01,
     &9.47860E-01,
     &1.01022E+00,
     &1.07667E+00,
     &1.14750E+00,
     &1.22299E+00,
     &1.30345E+00,
     &1.38920E+00,
     &1.48059E+00,
     &1.57799E+00,
     &1.68180E+00,
     &1.79244E+00,
     &1.91036E+00,
     &2.03603E+00,
     &2.16998E+00,
     &2.31273E+00,
     &2.46488E+00,
     &2.62703E+00,
     &2.79986E+00,
     &2.98405E+00,
     &3.18036E+00,
     &3.38958E+00,
     &3.61257E+00,
     &3.85023E+00,
     &4.10352E+00,
     &4.37347E+00,
     &4.66119E+00,
     &4.96783E+00,
     &5.29464E+00,
     &5.64296E+00,
     &6.01419E+00,
     &6.40984E+00,
     &6.83152E+00,
     &7.28094E+00,
     &7.75992E+00,
     &8.27042E+00,
     &8.81450E+00,
     &9.39437E+00,
     &1.00124E+01,
     &1.06711E+01,
     &1.13731E+01,
     &1.21213E+01,
     &1.29187E+01,
     &1.37686E+01,
     &1.46743E+01,
     &1.56397E+01,
     &1.66686E+01,
     &1.77652E+01,
     &1.89339E+01,
     &2.01794E+01,
     &2.15070E+01,
     &2.29218E+01,
     &2.44298E+01,
     &2.60369E+01,
     &2.77498E+01,
     &2.95753E+01,
     &3.15210E+01,
     &3.35946E+01,
     &3.58047E+01,
     &3.81602E+01,
     &4.06706E+01,
     &4.33461E+01,
     &4.61977E+01,
     &4.92369E+01,
     &5.24760E+01,
     &5.59282E+01,
     &5.96075E+01,
     &6.35289E+01,
     &6.77082E+01,
     &7.21625E+01,
     &7.69097E+01,
     &8.19693E+01,
     &8.73618E+01,
     &9.31090E+01,
     &9.92343E+01,
     &1.05763E+02,
     &1.12720E+02,
     &1.20136E+02,
     &1.28039E+02,
     &1.36462E+02,
     &1.45440E+02,
     &1.55007E+02,
     &1.65205E+02,
     &1.76073E+02,
     &1.87656E+02,
     &2.00000E+02 /
     
     
      data SPCTCUM  /
     &0.0000000E-00,
     &6.1472630E-05,
     &1.7768269E-04,
     &2.5360972E-04,
     &3.7573178E-04,
     &4.7223193E-04,
     &5.9003698E-04,
     &7.0890804E-04,
     &8.2815210E-04,
     &9.5245016E-04,
     &1.0926452E-03,
     &1.2300723E-03,
     &1.3650794E-03,
     &1.5090714E-03,
     &1.6666835E-03,
     &1.8322866E-03,
     &2.0077737E-03,
     &2.1741587E-03,
     &2.3710688E-03,
     &2.5601669E-03,
     &2.7717210E-03,
     &2.9630841E-03,
     &3.2117152E-03,
     &3.4143443E-03,
     &3.6566325E-03,
     &3.9240076E-03,
     &4.1770997E-03,
     &4.4947599E-03,
     &4.7895540E-03,
     &5.0957872E-03,
     &5.4094123E-03,
     &5.7635055E-03,
     &6.1494347E-03,
     &6.4812048E-03,
     &6.9544010E-03,
     &7.2725692E-03,
     &7.7992935E-03,
     &8.2275327E-03,
     &8.6834099E-03,
     &9.2358861E-03,
     &9.7337354E-03,
     &1.0371897E-02,
     &1.0912483E-02,
     &1.1598038E-02,
     &1.2174409E-02,
     &1.2954437E-02,
     &1.3754084E-02,
     &1.4439130E-02,
     &1.5358399E-02,
     &1.6155828E-02,
     &1.7017599E-02,
     &1.7983384E-02,
     &1.8950649E-02,
     &2.0088119E-02,
     &2.1245270E-02,
     &2.2470351E-02,
     &2.3620521E-02,
     &2.4933712E-02,
     &2.6311482E-02,
     &2.7787853E-02,
     &2.9296504E-02,
     &3.1094915E-02,
     &3.2606715E-02,
     &3.4363246E-02,
     &3.6316567E-02,
     &3.8383348E-02,
     &4.0509409E-02,
     &4.2579600E-02,
     &4.4938591E-02,
     &4.7510173E-02,
     &4.9872194E-02,
     &5.2293065E-02,
     &5.5443866E-02,
     &5.8265558E-02,
     &6.1105979E-02,
     &6.4581811E-02,
     &6.8005232E-02,
     &7.1252114E-02,
     &7.5174406E-02,
     &7.8979838E-02,
     &8.3014020E-02,
     &8.7688822E-02,
     &9.2481834E-02,
     &9.6529386E-02,
     &1.0168537E-01,
     &1.0670206E-01,
     &1.1236527E-01,
     &1.1762262E-01,
     &1.2395463E-01,
     &1.3033923E-01,
     &1.3672128E-01,
     &1.4366179E-01,
     &1.5031133E-01,
     &1.5823132E-01,
     &1.6566439E-01,
     &1.7320723E-01,
     &1.8135351E-01,
     &1.8942435E-01,
     &1.9832491E-01,
     &2.0805518E-01,
     &2.1771002E-01,
     &2.2653515E-01,
     &2.3701965E-01,
     &2.4637278E-01,
     &2.5640478E-01,
     &2.6636134E-01,
     &2.7669504E-01,
     &2.8710415E-01,
     &2.9826755E-01,
     &3.0935556E-01,
     &3.2119786E-01,
     &3.3243667E-01,
     &3.4329837E-01,
     &3.5355668E-01,
     &3.6472009E-01,
     &3.7618519E-01,
     &3.8908350E-01,
     &4.0115200E-01,
     &4.1397481E-01,
     &4.2770282E-01,
     &4.4188332E-01,
     &4.5644103E-01,
     &4.7077244E-01,
     &4.8427414E-01,
     &4.9807755E-01,
     &5.1233356E-01,
     &5.2553356E-01,
     &5.3820557E-01,
     &5.4989697E-01,
     &5.6075868E-01,
     &5.7335519E-01,
     &5.8655519E-01,
     &5.9930260E-01,
     &6.1137110E-01,
     &6.2396761E-01,
     &6.3679042E-01,
     &6.4961322E-01,
     &6.6205893E-01,
     &6.7382573E-01,
     &6.8491374E-01,
     &6.9803825E-01,
     &7.1221875E-01,
     &7.2511706E-01,
     &7.3824156E-01,
     &7.5106437E-01,
     &7.6418888E-01,
     &7.7799228E-01,
     &7.9164479E-01,
     &8.0318530E-01,
     &8.1412240E-01,
     &8.2566291E-01,
     &8.3765601E-01,
     &8.4942282E-01,
     &8.5832337E-01,
     &8.6722393E-01,
     &8.7574734E-01,
     &8.8555304E-01,
     &8.9422731E-01,
     &9.0131940E-01,
     &9.0869681E-01,
     &9.1561600E-01,
     &9.2254728E-01,
     &9.2949211E-01,
     &9.3552143E-01,
     &9.4142511E-01,
     &9.4687374E-01,
     &9.5148446E-01,
     &9.5550565E-01,
     &9.5937124E-01,
     &9.6327578E-01,
     &9.6684589E-01,
     &9.7018282E-01,
     &9.7306673E-01,
     &9.7586334E-01,
     &9.7852194E-01,
     &9.8104068E-01,
     &9.8310621E-01,
     &9.8517313E-01,
     &9.8695565E-01,
     &9.8831492E-01,
     &9.8964780E-01,
     &9.9085114E-01,
     &9.9205965E-01,
     &9.9303933E-01,
     &9.9394959E-01,
     &9.9467795E-01,
     &9.9533663E-01,
     &9.9585957E-01,
     &9.9640208E-01,
     &9.9688877E-01,
     &9.9732637E-01,
     &9.9764525E-01,
     &9.9795989E-01,
     &9.9820337E-01,
     &9.9846032E-01,
     &9.9867660E-01,
     &9.9887773E-01,
     &9.9904513E-01,
     &9.9919031E-01,
     &9.9932122E-01,
     &9.9941243E-01,
     &9.9950575E-01,
     &9.9957891E-01,
     &9.9964710E-01,
     &9.9969466E-01,
     &9.9974136E-01,
     &9.9978232E-01,
     &9.9981981E-01,
     &9.9984532E-01,
     &9.9986749E-01,
     &9.9988910E-01,
     &9.9990886E-01,
     &9.9992421E-01,
     &9.9993290E-01,
     &9.9994405E-01,
     &9.9995511E-01,
     &9.9996371E-01,
     &9.9997050E-01,
     &9.9997596E-01,
     &9.9998156E-01,
     &9.9998570E-01,
     &9.9998889E-01,
     &9.9999150E-01,
     &9.9999354E-01,
     &9.9999532E-01,
     &9.9999676E-01,
     &9.9999786E-01,
     &9.9999903E-01,
     &1.0000000E+00,
     &1.0000000E+00 /      
*======================================================================*
*                                                                      *
*                 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
*  |
*  +-------------------------------------------------------------------*
*  Sample the energy
      XI = FLRNDM(DUMMY)
      DO 500 K = 2, 230
        IF(XI .LE. SPCTCUM(K)) THEN
          ENERGY = ENEDGE(K) -
     &    (XI-SPCTCUM(K-1))*(ENEDGE(K)-ENEDGE(K+1))
     &      /(SPCTCUM(K)-SPCTCUM(K-1))
          GO TO 600
        END IF
 500  CONTINUE
      STOP ' Failed to sample the energy group'
 600  CONTINUE
*  +-------------------------------------------------------------------*
*  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
      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)
!      TKEFLK (NPFLKA) = SQRT ( PBEAM**2 + AM (IONID)**2 ) - AM (IONID)
      TKEFLK (NPFLKA) = ENERGY
*  Particle momentum
c      PMOFLK (NPFLKA) = PBEAM
      PMOFLK (NPFLKA) = SQRT ( TKEFLK (NPFLKA) * ( TKEFLK (NPFLKA)
     &                       + TWOTWO * AM (IONID) ) )
!      write(lunout,*)"^^^^^", ENERGY, 
!     &SQRT ( PBEAM**2 + AM (IONID)**2 ) - 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

      if (whasou(1) == 1) then
         xstart = whasou(2)
	 xend = whasou(3)
      end if
      if (whasou(4) == 2) then
         ystart = whasou(5)
	 yend = whasou(6)
      end if
      if (whasou(7) == 3) then
         zstart = whasou(8)
	 zend = whasou(9)
      end if
      XFLK   (NPFLKA) = XBEAM
      YFLK   (NPFLKA) = YBEAM
      ZFLK   (NPFLKA) = ZBEAM
      xpos = xstart + (xend - xstart) * FLRNDM(DUMMY)
      ypos = ystart + (yend - ystart) * FLRNDM(DUMMY)
      zpos = zstart + (zend - zstart) * FLRNDM(DUMMY)
      XFLK   (NPFLKA) = xpos
      YFLK   (NPFLKA) = ypos
      ZFLK   (NPFLKA) = zpos
!      write(lunout,*)"^^^",whasou(1),whasou(2),whasou(3),whasou(4)
*  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

