module ps_nbline_module

  ! module for selection of beam trajectories, using 
  ! Plasma State data and random number generator routines provided.

  use plasma_state_mod
  implicit NONE

  SAVE
  PRIVATE

  ! these are the only publicly defined symbols

  PUBLIC :: beamlet    ! definition of data type returned by ps_nbline
  PUBLIC :: ps_nbline  ! subroutine to select beamlet neutral trajectory

  !-------------------------------------------------------------
  ! use one of these for "ispecie" argument in ps_nbline
  INTEGER, PARAMETER, PUBLIC :: All_species = 0   ! select all beams

  INTEGER, PARAMETER, PUBLIC :: i_Hydrogen = 1    ! select H beams only
  INTEGER, PARAMETER, PUBLIC :: i_Deuterium = 2   ! select D beams only
  INTEGER, PARAMETER, PUBLIC :: i_Tritium = 3     ! select T beams only

  INTEGER, PARAMETER, PUBLIC :: i_Helium3 = 4     ! select He3 beams only
  INTEGER, PARAMETER, PUBLIC :: i_Helium4 = 5     ! select He4 beams only

  INTEGER, PARAMETER, PUBLIC :: i_Neon = 6        ! select Neon beams only
  INTEGER, PARAMETER, PUBLIC :: i_Argon = 7       ! select Argon beams only
  INTEGER, PARAMETER, PUBLIC :: i_Krypton = 8     ! select Krypton beams only
  INTEGER, PARAMETER, PUBLIC :: i_Xenon = 9       ! select Xenon beams only

  INTEGER, PARAMETER :: ispec_min = 1, ispec_max = 9  ! validity range

  !-------------------------------------------------------------
  ! data type returned -- NOT FILLED if ierr.ne.0 on exit from nb_psline
  !   (specie = -1 is set on error).

  type beamlet

     integer :: specie        ! code for "H", "D", "T", "He3" or "He4", or...

     integer :: beam_number   ! selected injector (from Plasma State list)
     integer :: energy_frac   ! selected energy fraction (1:full; 2:half;
                              ! 3:(1/3) energy).

     real*8 :: Rsta           ! Major Radius of start of trajectory(m)
     real*8 :: Phista         ! Toroidal angle position of start (rad)
     real*8 :: Zsta           ! Elevation of start trajectory (m)

     real*8 :: vR             ! velocity in R direction (>0: outward) (m/s)
     real*8 :: vZ             ! velocity in Z direction (>0: up) (m/s)
     real*8 :: vPhi           ! velocity in toroidal direction (m/s)
                              !  (>0: counter-clockwise direction veiwed from
                              !  above).

  end type beamlet

  !-------------------------------------------------------------
  ! private stored data -- beam currents & state data hash code.
  ! when the state data hash code changes, the beam currents are updated.

  integer :: ps_hash1 = -99
  integer :: ps_hash2 = -99
  integer :: ierr_save = 0

  ! beam species identification, converted to integer:
  integer, dimension(:), allocatable :: beam_species
  integer, dimension(:), allocatable :: trace_beam_species

  real*8, dimension(:), allocatable :: beamcurs  ! currents in each beam
  real*8, dimension(:), allocatable :: beamcurt  ! trace currents in each beam
  integer, dimension(:), allocatable :: ifract   ! trace fractionation flag
  real*8 :: bmcur_spec(ispec_max)  ! total current for each species
  real*8 :: bmcur_tot      ! total current, all beams, all species

  !  index ranges of beams with power
  integer :: ib1a,ib2a             ! all beams
  integer :: ib1(ispec_max)        ! 1st beam index for each species
  integer :: ib2(ispec_max)        ! last beam index for each species

  real*8 :: mass_kg(ispec_max)     ! mass of nucleus, kg (taken from state)
  !  this is only set for beam injected species

  !-------------------------------------------------------------
  !  private data -- cgs nbline data, reconstructed from Plasma State
  !  machine description

  real*8, dimension(:), allocatable :: bmwidra,bmwidza
  real*8, dimension(:), allocatable :: rapedga,xzpedga
  real*8, dimension(:), allocatable :: xrapoffa,xzapoffa
  real*8, dimension(:), allocatable :: xlbapa2,rapedg2,xzpedg2
  real*8, dimension(:), allocatable :: xrapoff2,xzapoff2
  integer, dimension(:), allocatable :: nbapsha,nbapsh2,nbshapa
  real*8, dimension(:), allocatable :: foclra,foclza,divra,divza
  real*8, dimension(:), allocatable :: xlbapa,xybsca,xybapa,xlbtna
  real*8, dimension(:), allocatable :: rtcena,xbzeta

  !-------------------------------------------------------------
  !  private constants

  REAL*8, parameter :: ZERO = 0.0d0
  REAL*8, parameter :: ONE  = 1.0d0
  REAL*8, parameter :: Z100 = 1.0d2  ! m -> cm
  REAL*8, parameter :: Z001 = 1.0d-2 ! cm -> m
  REAL*8, parameter :: Z1000= 1.0d3  ! KeV -> eV; make current Amps
  REAL*8, parameter :: DEGRAD = 1.745329251994330d-2 ! radians/degree, pi/180
  REAL*8, parameter :: TWOPI = 6.2831853071795862D+00
CONTAINS

  subroutine ps_nbline(istream,frandm,fgauss, &
       pstate,ispecie, &
       trajectory,ierr)

    integer, intent(in) :: istream  ! RNG stream ID
    !  (interpretation depends on passed RNG routines frandm and fgauss)

    REAL*8 :: frandm                ! passed [0:1] RNG EXTERNAL function
    !   eta=frandm(istream) -> evenly sampled random number eta, 0 < eta < 1.

    REAL*8 :: fgauss                ! passed Gaussian RNG EXTERNAL function
    !   nu= fgauss(istream,xcen,xwid) -> sample from Gaussian 
    !        exp(-(x-xcen)**2/(2*xwid**2))

    type (plasma_state) :: pstate   ! Plasma State containing beam description

    integer, intent(in) :: ispecie  ! specie select (choose one of the
    !   module parameters, e.g. i_Deuterium or All_species.

    type (beamlet) :: trajectory    ! return one randomly selected trajectory
    !   probability weighting according to total beam current

    integer, intent(out) :: ierr    ! completion status: 0=OK

    !-------------------------------
    !  possible error:  Plasma State lacks beam description
    !     ierr=1 -- no beams
    !     ierr=2 -- beams, but no power
    !     ierr=3 -- for a beam with power, the voltage is zero or negative
    !     ierr=4 -- for a beam with power, the 1st & 2nd energy fractions are 0
    !     ierr=5 -- error in beam geometry
    !
    !     ierr=10 -- no power for selected beam species (no error message)
    !     ierr=11 -- "ispecie" input argument value out of range
    !
    !     ierr=13 -- error in plasma state: trace power > 10% main beam power
    !
    !     ierr=99 -- ps_chk_nbfrac error
    !-------------------------------

    integer :: ib,inb,ia1,ia2,ia,iz,ibi1,ibi2,ibsel,iesel,iout,ispec
    integer :: ispec_trace,iso,iso_trace,itrace
    real*8 :: pnbtot,fracfac,curtot,zcur,zrng,zsum,zv,zconv,zf2,zf3,zfrac
    real*8 :: zfac,zplim

    character*4 zspec,zspec_trace
    character*10 zshape

    !-------------------------------
    EXTERNAL frandm
    EXTERNAL fgauss
    !-------------------------------

    trajectory%specie = -1

    iout = SWIM_err_out_file

    inb = pstate%nbeam

    ia1 = ps_shash_state_data
    ia2 = ia1 + 1

    if((ps_hash1.eq.pstate%hash_codes(ia1)).and. &
         (ps_hash2.eq.pstate%hash_codes(ia2))) then

       ierr = ierr_save

    else

       ps_hash1 = pstate%hash_codes(ia1)
       ps_hash2 = pstate%hash_codes(ia2)

       mass_kg = ZERO
       do ib=1,pstate%nspec_beam
          iz = pstate%qatom_snbi(ib)/ps_xe + 0.1
          ia = pstate%m_snbi(ib)/ps_mp + 0.1
          if(iz.eq.1) then
             if(ia.eq.1) mass_kg(1) = pstate%m_snbi(ib)
             if(ia.eq.2) mass_kg(2) = pstate%m_snbi(ib)
             if(ia.eq.3) mass_kg(3) = pstate%m_snbi(ib)
          else if(iz.eq.2) then
             if(ia.eq.3) mass_kg(4) = pstate%m_snbi(ib)
             if(ia.eq.4) mass_kg(5) = pstate%m_snbi(ib)
          endif
       enddo
       ! new hash code means new state data

       ierr = 0

       call ps_chk_nbfrac(0, ierr, state=pstate)
       if(ierr.ne.0) then
          ierr = 99

       else if((inb.le.0).or.(.not.allocated(pstate%power_nbi))) then
          ierr = 1

       else
          pnbtot = ZERO
          do ib = 1,inb
             if(pstate%power_nbi(ib).gt.ZERO) then
                pnbtot = pnbtot + pstate%power_nbi(ib) + pstate%power_nbi_trace(ib)
                if(pstate%kvolt_nbi(ib).LE.ZERO) then
                   ierr = 3
                   exit
                endif
             endif
          enddo

          if(pnbtot.le.ZERO) then
             ierr = 2
          endif
       endif

       if(ierr.eq.0) then
          
          if(allocated(beamcurs)) deallocate(beamcurs,beamcurt,beam_species,ifract)
          allocate(beamcurs(inb),beamcurt(inb),beam_species(inb),ifract(inb))

          if(allocated(trace_beam_species)) deallocate(trace_beam_species)
          allocate(trace_beam_species(inb))

          trace_beam_species = 0 ! usually, no trace beam species
          beamcurt = ZERO  ! trace element currents-- generally zero
          ifract = 0

          bmcur_spec = ZERO
          bmcur_tot  = ZERO
          ib1 = 0
          ib2 = 0
          ib1a = 0
          ib2a = 0

          do ib = 1,inb

             zplim = 0.1d0*(pstate%power_nbi(ib)+pstate%power_nbi_trace(ib))
             if(pstate%power_nbi_trace(ib).gt.zplim) then
                ierr=13
                write(iout,*) ' ?ps_nbline: for beam #',ib
                write(iout,*) '  trace beam power = ',pstate%power_nbi_trace(ib)
                write(iout,*) '  exceeds 10% of total beam power: ',zplim
                exit
             endif

             zspec = pstate%nbion(ib)
             call uupper(zspec)

             zspec_trace = pstate%nbion_trace(ib)
             call uupper(zspec_trace)

             if(zspec.eq.'H') then
                iso=1
                ispec= i_Hydrogen  ! (1)
             else if(zspec.eq.'D') then
                iso=1
                ispec= i_Deuterium ! (2)
             else if(zspec.eq.'T') then
                iso=1
                ispec= i_Tritium   ! (3)
             else if(zspec.eq.'HE3') then
                iso=2
                ispec= i_Helium3
             else if(zspec.eq.'HE4') then
                iso=2
                ispec= i_Helium4
             else if(zspec.eq.'NE') then
                iso=10
                ispec= i_Neon
             else if(zspec.eq.'AR') then
                iso=18
                ispec= i_Argon
             else if(zspec.eq.'KR') then
                iso=36
                ispec= i_Krypton
             else if(zspec.eq.'XE') then
                iso=54
                ispec= i_Xenon
             else
                ierr=5
                exit
             endif

             beam_species(ib)=ispec

             trace_beam_species(ib)=0
             if(zspec_trace.ne.' ') then
                if(zspec_trace.eq.'H') then
                   iso_trace=1
                   ispec_trace= i_Hydrogen  ! (1)
                else if(zspec_trace.eq.'D') then
                   iso_trace=1
                   ispec_trace= i_Deuterium ! (2)
                else if(zspec_trace.eq.'T') then
                   iso_trace=1
                   ispec_trace= i_Tritium   ! (3)
                else if(zspec_trace.eq.'HE3') then
                   iso_trace=2
                   ispec_trace= i_Helium3
                else if(zspec_trace.eq.'HE4') then
                   iso_trace=2
                   ispec_trace= i_Helium4
                else if(zspec_trace.eq.'NE') then
                   iso_trace=10
                   ispec_trace= i_Neon
                else if(zspec_trace.eq.'AR') then
                   iso_trace=18
                   ispec_trace= i_Argon
                else if(zspec_trace.eq.'KR') then
                   iso_trace=36
                   ispec_trace= i_Krypton
                else if(zspec_trace.eq.'XE') then
                   iso_trace=54
                   ispec_trace= i_Xenon
                else
                   ierr=5
                   exit
                endif
             endif

             beamcurs(ib)=ZERO
             if(pstate%power_nbi(ib).gt.ZERO) then
                fracfac = pstate%frac_full(ib) + pstate%frac_half(ib)/2 + &
                     (ONE-pstate%frac_full(ib)-pstate%frac_half(ib))/3
                if(fracfac.le.ZERO) then
                   ierr=4
                   exit
                endif

                zcur = pstate%power_nbi(ib)/ &
                     (Z1000*pstate%kvolt_nbi(ib)*fracfac)

                beamcurs(ib) = zcur
                bmcur_tot = bmcur_tot + zcur
                bmcur_spec(ispec) = bmcur_spec(ispec) + zcur

                !  set indices for this species beam with non-zero power:

                if(ib1(ispec).eq.0) ib1(ispec)=ib
                ib2(ispec)=ib

                if(ib1a.eq.0) ib1a=ib
                ib2a=ib

             endif

             if(pstate%power_nbi_trace(ib).gt.ZERO) then
                if((iso.eq.1).and.(iso_trace.eq.1)) then
                   ! H isotope molecule @Einj; trace atom mass ratios:
                   zf2 = ispec_trace*ONE/(ispec + ispec_trace)
                   zf3 = ispec_trace*ONE/(2*ispec + ispec_trace)
                   fracfac = pstate%frac_full(ib) + pstate%frac_half(ib)*zf2 +&
                        (ONE-pstate%frac_full(ib)-pstate%frac_half(ib))*zf3
                   ifract(ib)=1
                else
                   fracfac=ONE
                endif

                zcur = pstate%power_nbi_trace(ib)/ &
                     (Z1000*pstate%kvolt_nbi(ib)*fracfac)

                beamcurt(ib) = zcur
                bmcur_tot = bmcur_tot + zcur
                bmcur_spec(ispec_trace) = bmcur_spec(ispec_trace) + zcur

                !  set indices for this species beam with non-zero power:

                if(ib1(ispec_trace).eq.0) ib1(ispec_trace)=ib
                ib2(ispec_trace)=ib

                if(ib1a.eq.0) ib1a=ib
                ib2a=ib
             endif

          enddo
       endif

       if(ierr.eq.1) then
          write(iout,*) ' ?ps_nbline: no neutral beams in plasma state.'

       else if(ierr.eq.2) then
          write(iout,*) ' ?ps_nbline: plasma state shows no beam power.'

       else if(ierr.eq.3) then
          write(iout,*) ' ?ps_nbline: beam with non-zero power has Einj=0.'

       else if(ierr.eq.4) then
          write(iout,*) ' ?ps_nbline: beam with non-zero power has zero energy fractions.'

       else if(ierr.eq.5) then
          write(iout,*) ' ?ps_nbline: beam #',ib,' unrecognized species: ', &
               pstate%nbion(ib)

       else if(ierr.ne.0) then
          write(iout,*) ' ?ps_nbline: an unexpected error occurred.'
       endif

       ierr_save = ierr

       !---------------------------------------------------------------------
       ! restore legacy NUBEAM NBLINE CGS geometry description

       if(ierr.eq.0) then
          ! transfer state geometry to local CGS variables-- names originally
          ! from nubeam/nbline.for

          if(allocated(rtcena)) then
             deallocate(bmwidra,bmwidza,rapedga,xzpedga)
             deallocate(xlbapa2,rapedg2,xzpedg2)
             deallocate(xrapoffa,xzapoffa,xrapoff2,xzapoff2)
             deallocate(nbapsha,nbapsh2,nbshapa)
             deallocate(foclra,foclza,divra,divza)
             deallocate(xlbapa,xybsca,xybapa,xlbtna)
             deallocate(rtcena,xbzeta)
          endif

          allocate(bmwidra(inb),bmwidza(inb))
          allocate(rapedga(inb),xzpedga(inb))
          allocate(xrapoffa(inb),xzapoffa(inb))
          allocate(xlbapa2(inb),rapedg2(inb),xzpedg2(inb))
          allocate(xrapoff2(inb),xzapoff2(inb))
          allocate(nbapsha(inb),nbapsh2(inb),nbshapa(inb))
          allocate(foclra(inb),foclza(inb),divra(inb),divza(inb))
          allocate(xlbapa(inb),xybsca(inb),xybapa(inb),xlbtna(inb))
          allocate(rtcena(inb),xbzeta(inb))

          bmwidra = Z100*pstate%b_halfwidth
          bmwidza = Z100*pstate%b_halfheight

          rapedga = Z100*pstate%ap_halfwidth
          xzpedga = Z100*pstate%ap_halfheight

          xrapoffa = Z100*pstate%ap_horiz_offset
          xzapoffa = Z100*pstate%ap_vert_offset

          foclra = Z100*pstate%b_hfocal_length
          foclza = Z100*pstate%b_vfocal_length

          zconv = degrad/sqrt(2.0d0)

          divra = zconv*pstate%b_hdivergence
          divza = zconv*pstate%b_vdivergence

          xlbapa = Z100*pstate%Lbscap
          xlbtna = Z100*pstate%Lbsctan
          rtcena = Z100*pstate%srtcen  ! SIGNed quantity, now

          xybsca = Z100*pstate%zbsc
          xybapa = Z100*pstate%zbap

          xbzeta = pstate%Phibsc

          xlbapa2 = Z100*pstate%Lbscap2
          rapedg2 = Z100*pstate%ap2_halfwidth
          xzpedg2 = Z100*pstate%ap2_halfheight

          xrapoff2 = Z100*pstate%ap2_horiz_offset
          xzapoff2 = Z100*pstate%ap2_vert_offset

          do ib=1,inb
             zshape = pstate%nbshape(ib)
             call uupper(zshape)
             if(zshape.eq.'RECTANGLE') then
                nbshapa(ib)=1
             else if(zshape.eq.'CIRCLE') then
                nbshapa(ib)=2
             else
                ierr=ierr+1
                write(6,*) ' ?ps_nbline: beam #',ib, &
                     ' source grid shape unknown: ',zshape
             endif

             zshape = pstate%nbap_shape(ib)
             call uupper(zshape)
             if(zshape.eq.'RECTANGLE') then
                nbapsha(ib)=1
             else if(zshape.eq.'CIRCLE') then
                nbapsha(ib)=2
             else
                ierr=ierr+1
                write(6,*) ' ?ps_nbline: beam #',ib, &
                     ' aperture shape unknown: ',zshape
             endif

             !  if 2nd aperture shape not "CIRCLE" or "RECTANGLE", assume
             !  there is no 2nd aperture

             zshape = pstate%nbap2_shape(ib)
             call uupper(zshape)
             if(zshape.eq.'RECTANGLE') then
                nbapsh2(ib)=1
             else if(zshape.eq.'CIRCLE') then
                nbapsh2(ib)=2
             else
                nbapsh2(ib)=0
                xlbapa2(ib)=ZERO
             endif

          enddo
          if(ierr.gt.0) then
             write(6,*) '?ps_nbline: error in Plasma State beam description.'
             ierr=5
          endif

       endif

    endif
    if(ierr.ne.0) return

    !--------------------------------------------
    !  OK: internal module data has been initialized
    !
    !  Check species selection...

    if(ispecie.eq.All_species) then
       curtot = bmcur_tot
       ibi1=ib1a
       ibi2=ib2a
    else if((ispecie.ge.ispec_min).and.(ispecie.le.ispec_max)) then
       curtot = bmcur_spec(ispecie)
       ibi1=ib1(ispecie)
       ibi2=ib2(ispecie)
    else
       write(6,*) ' ?ps_nbline: "ispecie" argument value invalid: ',ispecie
       ierr = 11
    endif

    if(ierr.eq.0) then
       if(curtot.le.ZERO) then
          ierr = 10    ! no power, no current, this specie
       endif
    endif
    if(ierr.ne.0) return

    !--------------------------------------------
    !  Use RNG to select neutral beam and energy fraction, if necessary

    if(ibi1.eq.ibi2) then
       ibsel = ibi1
    else
       zrng = frandm(istream)*curtot
       ibsel = ibi2
       zsum = ZERO
       do ib=ibi1,ibi2
          if(ispecie.eq.All_species) then
             zsum = zsum + beamcurs(ib) + beamcurt(ib)
             if(zsum.ge.zrng) then
                if(zsum-beamcurt(ib).ge.zrng) then
                   itrace=0
                   zfrac=pstate%frac_full(ib)
                else
                   itrace=1
                   if(ifract(ib).eq.1) then
                      zfrac=pstate%frac_full(ib)
                   else
                      zfrac=ONE
                   endif
                endif
                ibsel=ib
                exit
             endif
          else if(ispecie.eq.beam_species(ib)) then
             zsum = zsum + beamcurs(ib)
             if(zsum.ge.zrng) then
                itrace=0
                zfrac=pstate%frac_full(ib)
                ibsel=ib
                exit
             endif
          else if(ispecie.eq.trace_beam_species(ib)) then
             zsum = zsum + beamcurt(ib)
             if(zsum.ge.zrng) then
                itrace=1
                ibsel=ib
                exit
             endif
          endif
       enddo
    endif

    ispec=beam_species(ibsel)
    ispec_trace=trace_beam_species(ibsel)

    if(itrace.eq.0) then
       zfrac = pstate%frac_full(ib)
    else
       if(ifract(ib).eq.1) then
          zfrac=pstate%frac_full(ib)
       else
          zfrac=ONE
       endif
    endif

    zfac=ONE

    if(zfrac.eq.ONE) then
       iesel = 1
    else
       zrng = frandm(istream)
       if(zrng.le.pstate%frac_full(ib)) then
          iesel = 1
       else if(zrng.le.(pstate%frac_full(ib)+pstate%frac_half(ib))) then
          iesel = 2
          if(itrace.eq.0) then
             zfac=0.5d0
          else
             ! H isotope molecule @ Einj; trace atom mass ratio
             zfac=ispec_trace*ONE/(ispec+ispec_trace)
          endif
       else
          iesel = 3
          if(itrace.eq.0) then
             zfac=ONE/3
          else
             ! H isotope molecule @ Einj; trace atom mass ratio
             zfac=ispec_trace*ONE/(2*ispec+ispec_trace)
          endif
       endif
    endif

    !--------------------------------------------
    ! OK beam line has been selected...

    trajectory%specie = beam_species(ibsel)
    trajectory%beam_number = ibsel
    trajectory%energy_frac = iesel

    zv = sqrt(2*Z1000*pstate%kvolt_nbi(ibsel)*ps_xe*zfac/ &
         (mass_kg(beam_species(ibsel))) )  ! m/s

    !! write(6,*) ' E = ',pstate%kvolt_nbi(ibsel)*Z1000/iesel
    !! write(6,*) ' m/mp = ',mass_kg(beam_species(ibsel))/ps_mp
    !! write(6,*) ' Echk = ',(zv*zv*ia*1.0e4/(1.384e6*1.384e6))

    call ps_nbline_sub(istream,frandm,fgauss, pstate, trajectory, ibsel, ierr)

    if(ierr.ne.0) then
       write(6,*) ' ?ps_nbline: could not find trajectory in ps_nbline_sub.'
    else
       trajectory%vR = zv * trajectory%vR
       trajectory%vPhi = zv * trajectory%vPhi
       trajectory%vZ = zv * trajectory%vZ
    endif

  end subroutine ps_nbline

  subroutine ps_nbline_sub(istream,frandm,fgauss, pstate, trajectory, ib, ierr)

    integer, intent(in) :: istream  ! RNG stream ID
    !  (interpretation depends on passed RNG routines frandm and fgauss)

    REAL*8 :: frandm                ! passed [0:1] RNG EXTERNAL function
    !   eta=frandm(istream) -> evenly sampled random number eta, 0 < eta < 1.

    REAL*8 :: fgauss                ! passed Gaussian RNG EXTERNAL function
    !   nu= fgauss(istream,xcen,xwid) -> sample from Gaussian 
    !        exp(-(x-xcen)**2/(2*xwid**2))

    type (plasma_state) :: pstate   ! Plasma State containing beam description

    type (beamlet) :: trajectory    ! return one randomly selected trajectory
    !   start position; velocity normalized to v=1; actual velocity inserted
    !   by caller.

    integer, intent(in) :: ib       ! (already selected) beam index

    integer, intent(out) :: ierr    ! status code
    !  a non-zero "ierr" value indicates that a trajectory could not be
    !  found.  Generally this indicates an error in the beam geometry
    !  description (e.g. a zero width aperture).

    !-------------------------------
    !-------------------------------
    EXTERNAL frandm
    EXTERNAL fgauss
    !-------------------------------
    !  nubeam/nbline.for copied & adapted... DMC May 2008

    INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)

    REAL*8 zzgrd,zrgrd,zdzdl,zdrdl,zdza,zzap,zdra,zrap,zdzdl0
    REAL*8 zdrdl0,zradap,zdza2,zzap2,zdra2,zrap2,zradap2,zdymp
    REAL*8 zsiny,zcosy,zthet0,zlbmp,zlbmpa,zphil,zphi0,zbeta

    integer   intry, intrylim
    parameter ( intrylim = 100 )  !  Give up after .. attempts

    REAL*8 :: ysta,rsta,esta      ! Y(cm) R(cm) Phi_start (rad)
    real*8 :: thea                ! vert. velocity angle (rad)
    !              zero: horizontal; +: vZ > 0
    real*8 :: phia                ! horiz. angle (rad) w.r.t. -R direction
    !              zero: directed in towards center of machine
    !               +:   component in CCW horizontal direction

    REAL*8 :: zcosth,zsinth

    REAL*8 :: zrtcen
    logical :: ilccw

    !----------------------------------------------------------------
    !
    !  SELECT FROM BEAM FACE
    !  ---------------------

    ierr = 0

    if(rtcena(ib).lt.ZERO) then
       zrtcen=-rtcena(ib)
       ilccw=.FALSE.
    else
       zrtcen=rtcena(ib)
       ilccw=.TRUE.
    endif

    !  RETURN POINT FOR CASES OF BEAM SCRAPE OFF

    intry  =  0
10 CONTINUE
    !----------------------------------

    intry  =  intry + 1

    if( intry .gt. intrylim )   then
       !..       no good trajectory found ..  problem with aperture defn ?
       write(6,6000) ib, intry
       write(6,*) 'ps_nbline_sub : Cannot find good beam trajectory'
       write(6,*) '  (check beam geometry description)'
 
       ierr=20
       return
 
    endif
6000 format(10x,'ps_nbline_sub, beam #',i4,', after ',i6,' attempts ' )

    IF(NBSHAPA(IB).EQ.1) GOTO 100

    !  CIRCULAR BEAM GRIDS
50  CONTINUE
    ZZGRD=BMWIDRA(IB)*(1.0_R8-2.0_R8*FRANDM(ISTREAM))
    ZRGRD=BMWIDRA(IB)*(1.0_R8-2.0_R8*FRANDM(ISTREAM))
    !--     IF(ZZGRD**2+ZRGRD**2.GT.BMWIDRA(IB)**2) GOTO 50
    IF(ZZGRD**2+ZRGRD**2.GT.BMWIDRA(IB)**2) then
       !--        another loop trap..
       intry  =  intry + 1
       if( intry .gt. intrylim )  goto  10
       GOTO 50
    else
       GOTO 150
    endif

    !  RECTANGULAR BEAM GRIDS
100 CONTINUE
    ZZGRD=BMWIDZA(IB)*(1.0_R8-2.0_R8*FRANDM(ISTREAM))
    ZRGRD=BMWIDRA(IB)*(1.0_R8-2.0_R8*FRANDM(ISTREAM))
    
    !  ESTABLISH NEUTRAL TRAJECTORY WITHIN BEAM-LINE
    !  ---------------------------------------------

    !  ZDZDL AND ZDRDL ARE THE TANGENTS OF THE
    !  ANGLES BETWEEN THE NORMAL TO THE (ASSUMED FLAT) GRID
    !  SURFACE AND THE PARTICLE TRAJECTORY, PROJECTED INTO
    !  THE VERTICAL AND HORIZONTAL PLANES.
    !  I.E. DL IN THIS DEFINITION IS LENGTH ALONG THE GRID-NORMAL LINE

150 CONTINUE
    IF(NBSHAPA(IB).EQ.1) GOTO 1100

    !  CIRCULAR BEAM GRIDS
    ZDZDL0=-ZZGRD/FOCLRA(IB)
    ZDRDL0=-ZRGRD/FOCLRA(IB)
    ZDZDL=fgauss(istream,zdZdL0,divRa(ib))
    ZDRDL=fgauss(istream,zdRdL0,divRa(ib))
    GOTO 1150

    !  RECTANGULAR BEAM GRIDS
1100 CONTINUE
    ZDZDL0=-ZZGRD/FOCLZA(IB)
    ZDRDL0=-ZRGRD/FOCLRA(IB)
    ZDZDL=fgauss(istream,zdZdL0,divZa(ib))
    ZDRDL=fgauss(istream,zdRdL0,divRa(ib))
       
    !  SCRAPE OFF BEAM AT RECTANGULAR APERTURE
    !  ---------------------------------------

1150 CONTINUE

    ZDZA=ZDZDL*XLBAPA(IB)
    ZZAP=ZZGRD+ZDZA
    ZDRA=ZDRDL*XLBAPA(IB)
    ZRAP=ZRGRD+ZDRA
    IF(NBAPSHA(IB).EQ.1) THEN
       !  RECTANGULAR APERTURE
       IF(ABS(ZZAP-xzapoffa(ib)).GT.XZPEDGA(IB)) GOTO 10
       IF(ABS(ZRAP-xrapoffa(ib)).GT.RAPEDGA(IB)) GOTO 10
    ELSE
       !  CIRCULAR APERTURE
       ZRADAP=SQRT((ZZAP-xzapoffa(ib))**2+(ZRAP-xrapoffa(ib))**2)
       IF(ZRADAP.GT.RAPEDGA(IB)) GOTO 10
    ENDIF
       
    !  OPTIONAL 2ND APERTURE

    IF(XLBAPA2(IB).GT.0.0_R8) THEN
       ZDZA2=ZDZDL*XLBAPA2(IB)
       ZZAP2=ZZGRD+ZDZA2
       ZDRA2=ZDRDL*XLBAPA2(IB)
       ZRAP2=ZRGRD+ZDRA2
       IF(NBAPSH2(IB).EQ.1) THEN
          !  RECTANGULAR APERTURE
          IF(ABS(ZZAP2-xzapoff2(ib)).GT.XZPEDG2(IB)) GOTO 10
          IF(ABS(ZRAP2-xrapoff2(ib)).GT.RAPEDG2(IB)) GOTO 10
       ELSE
          !  CIRCULAR APERTURE
          ZRADAP2=SQRT((ZZAP2-xzapoff2(ib))**2+(ZRAP2-xrapoff2(ib))**2)
          IF(ZRADAP2.GT.RAPEDG2(IB)) GOTO 10
       ENDIF

    ENDIF
    !----------------------------------

    !  GOT A VIABLE PARTICLE TRAJECTORY
    !  --------------------------------

    !  DMC-- DEAL WITH BEAMLINE NOT PLL TO MIDPLANE

    ZDYMP=XYBAPA(IB)-XYBSCA(IB)
    IF(ZDYMP.EQ.0.0_R8) THEN
       ZSINY=0.0_R8
       ZCOSY=1.0_R8
       ZTHET0=0.0_R8
    ELSE
       ZSINY=ZDYMP/XLBAPA(IB)
       ZCOSY=SQRT(1.0_R8-ZSINY*ZSINY)
       ZTHET0=ATAN(ZSINY/ZCOSY)
    ENDIF

    !  FOLLOWING QUANTITIES INCLUDE CORRECTION FOR DEVIATION OF SELECTED
    !  SIGHTLINE FROM BEAM CENTERLINE

    !  DISTANCE, APERTURE TO TANGENCY RADIUS, PROJECTED TO MIDPLANE
    !  WITH CORRECTION FOR TILT OF APERTURE PLANE
    !   NOTE SIGN CONVENTION: ZSINY.LT.0.0 IF BEAMLINE IS COMING DOWN
    !  FROM ABOVE (CORRESPONDING TO A NEGATIVE THETA ARGUMENT FOR
    !  TRAKRB).

    ZLBMP=(XLBTNA(IB)-XLBAPA(IB))*ZCOSY + ZZAP*ZSINY

    !  DISTANCE, SCE TO APERTURE, PROJECTED TO MIDPLANE

    ZLBMPA=XLBAPA(IB)*ZCOSY - ZDZA*ZSINY

    !  FIND YSTA AND RSTA

    YSTA=ZZAP*ZCOSY+XYBAPA(IB)
    RSTA=SQRT((ZRTCEN-ZRAP)**2+ZLBMP**2)

    !  FIND PHIA AND THEA

    !  POSITIVE ZRAP, ZDRA MAKE BEAMLET MORE PERP (==> SMALLER PHIA)

    zphil = atan(zrtcen/(zcosy*xlbtna(ib)))  ! angle from beam sightline 
    ! to axis on equatorial plane

    !  COMPONENT, SCE TO APERTURE
    ZPHI0=ATAN(ZDRA/ZLBMPA)
    !  COMPONENT, FROM PT. CROSSING APERTURE PLANE ON IN
    PHIA=ATAN((ZRTCEN-ZRAP)/ZLBMP)
    !  ADD
    esta=phia-zphil   ! zeta angle relative to source
    PHIA=PHIA-ZPHI0

    IF(.NOT.ilccw) then
       PHIA=-PHIA    ! radians (unlike nubeam/nbline.for)
       esta=-esta
    end if
    esta=xbzeta(ib)*degrad + esta  !  make angle absolute in zeta -- radians

    !  NOTE THAT THEA IS **NOT** SIMPLY TAN(ZDZDL) SINCE
    !  DL NEEDS TO BE PROJECTED FROM THE TRAJECTORY DOWN TO THE
    !  HORIZONTAL MIDPLANE FIRST, RATHER THAN BEING THE GRID-NORMAL

    !  DMC-- ADD THETA CONTRIBUTION DUE TO BEAMLINE ITSELF

    THEA=ATAN(ZDZDL/SQRT(1.0_R8+ZDRDL**2))+ZTHET0   ! radians

    !-----------------
    !  load trajectory

    trajectory%Rsta = rsta*Z001
    trajectory%Phista = esta
    trajectory%Zsta = ysta*Z001

    !  normalized velocity components
    !  note -pi/2 < THEA < pi/2; cos(THEA) > 0

    trajectory%vZ = sin(THEA)

    zcosth = cos(THEA)
    trajectory%vR = -zcosth*cos(PHIA)  ! PHIA=0 -- dead perp inward injection
    trajectory%vPhi = zcosth*sin(PHIA) ! +PHIA: in CCW direction

  end subroutine ps_nbline_sub

end module ps_nbline_module
