fidasim.f90 Source File

This file contains the main routines for FIDASIM 2.0.0


This file depends on

sourcefile~~fidasim.f90~~EfferentGraph sourcefile~fidasim.f90 fidasim.f90 sourcefile~utilities.f90 utilities.f90 sourcefile~fidasim.f90->sourcefile~utilities.f90 sourcefile~eigensystem.f90 eigensystem.f90 sourcefile~fidasim.f90->sourcefile~eigensystem.f90 sourcefile~hdf5_utils.f90 hdf5_utils.f90 sourcefile~fidasim.f90->sourcefile~hdf5_utils.f90 sourcefile~mpi_utils.f90 mpi_utils.f90 sourcefile~fidasim.f90->sourcefile~mpi_utils.f90 sourcefile~utilities.f90->sourcefile~mpi_utils.f90

Contents

Source Code


Source Code

!+ This file contains the main routines for FIDASIM {!../VERSION!}
module libfida
!+ Main FIDASIM library
USE ISO_C_BINDING
USE H5LT !! High level HDF5 Interface
USE HDF5 !! Base HDF5
USE hdf5_utils !! Additional HDF5 routines
USE eigensystem, ONLY : eigen, linsolve
USE utilities
#ifdef _MPI
USE mpi_utils
#endif

implicit none

character(30) :: version = ''
    !+ FIDASIM version number
integer, dimension(8) :: time_start
    !+ Start time
integer, parameter, private   :: Int32   = 4
    !+ Defines a 32 bit integer
integer, parameter, private   :: Int64   = 8
    !+ Defines a 64 bit integer
integer, parameter, private   :: Float32 = 4
    !+ Defines a 32 bit floating point real
integer, parameter, private   :: Float64 = 8
    !+ Defines a 64 bit floating point real
integer, parameter :: charlim = 150
    !+ Defines character limit for files and directories

character(charlim) :: namelist_file
    !+ Input namelist file
integer, parameter :: nbif_type  = 1
    !+ Identifier for full energy NBI neutral interaction
integer, parameter :: nbih_type  = 2
    !+ Identifier for half energy NBI neutral interaction
integer, parameter :: nbit_type  = 3
    !+ Identifier for third energy NBI neutral interaction
integer, parameter :: dcx_type   = 4
    !+ Identifier for dcx neutral interaction
integer, parameter :: halo_type  = 5
    !+ Identifier for halo neutral interaction
integer, parameter :: fida_type  = 6
    !+ Identifier for fida neutral interaction
integer, parameter :: brems_type = 7
    !+ Identifier for bremsstrahlung interaction. Acts as dummy type
integer, parameter :: ntypes     = 7
    !+ Number of different types of neutrals

integer, parameter :: beam_ion = 1
    !+ Identifier for a beam ion
integer, parameter :: thermal_ion = 2
    !+ Identifier for a thermal ion

!! Physical units
real(Float64), parameter :: e_amu = 5.48579909070d-4
    !+ Atomic mass of an electron [amu]
real(Float64), parameter :: H1_amu = 1.007276466879d0
    !+ Atomic mass of Hydrogen-1 (protium) [amu]
real(Float64), parameter :: H2_amu = 2.013553212745d0
    !+ Atomic mass of Hydrogen-2 (deuterium) [amu]
real(Float64), parameter :: H3_amu = 3.01550071632d0
    !+ Atomic mass of Hydrogen-3 (tritium) [amu]
real(Float64), parameter :: He3_amu = 3.01602931914d0
    !+ Atomic mass of Helium-3 [amu]
real(Float64), parameter :: B5_amu = 10.81d0
    !+ Atomic mass of Boron [amu]
real(Float64), parameter :: C6_amu = 12.011d0
    !+ Atomic mass of Carbon [amu]
real(Float64), parameter :: mass_u    = 1.660539040d-27
    !+ Atomic mass unit [kg]
real(Float64), parameter :: e0        = 1.60217733d-19
    !+ Electron charge [C]
real(Float64), parameter :: pi        = 3.14159265358979323846264d0
    !+ Pi
real(Float64), parameter :: c0        = 2.99792458d+08
    !+ Speed of light [m/s]
real(Float64), parameter :: h_planck  = 4.135667516d-15
    !+ Planck's constant [eV*s]
real(Float64), parameter :: lambda0   = 656.1d0
    !+ D-alpha emission line [nm]
real(Float64), parameter :: v2_to_E_per_amu = mass_u/(2.*e0*1.d3)*1.d-4
    !+ \(cm^2/s^2\) to keV conversion factor
real(Float64), parameter :: log_10 = log(10.d0)
    !+ Natural log of 10.0

integer, parameter ::n_stark = 15
    !+ Number of Stark lines
real(Float64), parameter, dimension(n_stark) :: stark_wavel = &
     [-2.20200d-07,-1.65200d-07,-1.37700d-07,-1.10200d-07, &
      -8.26400d-08,-5.51000d-08,-2.75600d-08, 0.00000d0,   &
       2.75700d-08, 5.51500d-08, 8.27400d-08, 1.10300d-07, &
       1.38000d-07, 1.65600d-07, 2.20900d-07               ]
    !+ Stark wavelengths [nm*m/V]
real(Float64), parameter, dimension(n_stark) :: stark_intens= &
     [ 1.000d0, 18.00d0, 16.00d0, 1681.d0, 2304.d0, &
       729.0d0, 1936.d0, 5490.d0, 1936.d0, 729.0d0, &
       2304.d0, 1681.d0, 16.00d0, 18.00d0, 1.000d0  ]
    !+ Stark Intensities
integer, parameter, dimension(n_stark) :: stark_pi= &
     [1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 1]
    !+ Pi line indicators
integer, parameter, dimension(n_stark) :: stark_sigma=1 - stark_pi
    !+ Sigma line indicators

!!Numerical Settings
integer, parameter :: nlevs=6
    !+ Number of atomic energy levels
real(Float64), dimension(ntypes) :: halo_iter_dens = 0.d0
    !+ Keeps track of how of each generations halo density
integer :: nbi_outside = 0
    !+ Keeps track of how many beam neutrals do not hit the [[libfida:beam_grid]]

!!Loop Parallization Settings
integer :: istart = 1
    !+ Starting loop counter (1 if OpenMP, processor number if MPI)
integer :: istep = 1
    !+ Loop step size (1 if OpenMP, number of processes if MPI)

type InterpolCoeffs1D
    !+ Linear Interpolation Coefficients and indices
    integer :: i = 0
        !+ Index of position right before `xout`
    real(Float64) :: b1 = 0.d0
        !+ Coefficient for y(i) term
    real(Float64) :: b2 = 0.d0
        !+ Coefficient for y(i+1) term
end type InterpolCoeffs1D

type InterpolCoeffs2D
    !+ 2D Linear Interpolation Coefficients and indices
    integer :: i = 0
        !+ Index of abscissa before `xout`
    integer :: j = 0
        !+ Index of ordinate before `yout`
    real(Float64) :: b11 = 0.d0
        !+ Coefficient for z(i,j) term
    real(Float64) :: b12 = 0.d0
        !+ Coefficient for z(i,j+1) term
    real(Float64) :: b21 = 0.d0
        !+ Coefficient for z(i+1,j) term
    real(Float64) :: b22 = 0.d0
        !+ Coefficient for z(i+1,j+1) term
end type InterpolCoeffs2D

type InterpolCoeffs3D
    !+ 3D Cylindrical Interpolation Coefficients and indices
    integer :: i = 0
        !+ Index of R before `rout`
    integer :: j = 0
        !+ Index of Z before `zout`
    integer :: k = 0
        !+ Index of Phi before `phiout`
    real(Float64) :: b111 = 0.d0
        !+ Coefficient for z(i,j,k) term
    real(Float64) :: b121 = 0.d0
        !+ Coefficient for z(i,j+1,k) term
    real(Float64) :: b112 = 0.d0
        !+ Coefficient for z(i,j,k+1) term
    real(Float64) :: b122 = 0.d0
        !+ Coefficient for z(i,j+1,k+1) term
    real(Float64) :: b211 = 0.d0
        !+ Coefficient for z(i+1,j,k) term
    real(Float64) :: b212 = 0.d0
        !+ Coefficient for z(i+1,j,k+1) term
    real(Float64) :: b221 = 0.d0
        !+ Coefficient for z(i+1,j+1,k) term
    real(Float64) :: b222 = 0.d0
        !+ Coefficient for z(i+1,j+1,k+1) term
end type InterpolCoeffs3D

type BeamGrid
    !+ Defines a 3D grid for neutral beam calculations
    integer(Int32) :: nx
        !+ Number of cells in the x direction
    integer(Int32) :: ny
        !+ Number of cells in the y direction
    integer(Int32) :: nz
        !+ Number of cells in the z direction
    real(Float64)  :: xmin
        !+ Minimum x value
    real(Float64)  :: xmax
        !+ Maximum x value
    real(Float64)  :: ymin
        !+ Minimum y value
    real(Float64)  :: ymax
        !+ Maximum y value
    real(Float64)  :: zmin
        !+ Minimum z value
    real(Float64)  :: zmax
        !+ Maximum z value
    real(Float64)  :: alpha
        !+ Tait-Bryan angle for a rotation about z [radians]
    real(Float64)  :: beta
        !+ Tait-Bryan angle for a rotation about y' [radians]
    real(Float64)  :: gamma
        !+ Tait-Bryan angle for a rotation about x" [radians]
    real(Float64)  :: drmin
        !+ Minimum cell spacing: `min(dx,dy,dz)`
    real(Float64)  :: dv
        !+ Cell volume [\(cm^3\)]
    real(Float64)  :: volume
        !+ Grid volume [\(cm^3\)]
    integer(Int32) :: ntrack
        !+ Maximum number of cell for particle tracking
    integer(Int32) :: ngrid
        !+ Number of cells
    integer(Int32), dimension(3)  :: dims
        !+ Dimensions of beam grid
    real(Float64), dimension(3)   :: origin
        !+ Origin of beam grid in machine coordinates
    real(Float64), dimension(3)   :: center
        !+ Center of beam grid in beam coordinates
    real(Float64), dimension(3)   :: dr
        !+ Cell spacings [dx, dy, dz]
    real(Float64), dimension(3)   :: lwh
        !+ Grid [length(x), width(y), height(z)]
    real(Float64), dimension(3,3) :: basis
        !+Beam grid basis for converting from beam coordinates(xyz)
        !+to machine coordinates(uvw): (\uvw = B*xyz + origin\)
    real(Float64), dimension(3,3) :: inv_basis
        !+Inverse basis for reverse transformation: (\xyz = B^{-1}*(uvw - origin)\)
    real(Float64), dimension(:), allocatable :: xc
        !+ x positions of cell centers
    real(Float64), dimension(:), allocatable :: yc
        !+ y positions of cell centers
    real(Float64), dimension(:), allocatable :: zc
        !+ z positions of cell centers
end type BeamGrid

type InterpolationGrid
    !+ Defines a 3D R-Z-phi grid for interpolating plasma parameters and fields
    integer(Int32) :: nr
        !+ Number of Radii
    integer(Int32) :: nz
        !+ Number of Z values
    integer(Int32) :: nphi
        !+ Number of phi values
    real(Float64)  :: dr
        !+ Radial spacing [cm]
    real(Float64)  :: dz
        !+ Vertical spacing [cm]
    real(Float64)  :: dphi
        !+ Angular spacing [rad]
    real(Float64)  :: da
        !+ Grid element area [\(cm^2\)]
    real(Float64)  :: dv
        !+ dr*dz*dphi [\(rad*cm^2\)]
    integer(Int32) :: dims(3)
        !+ Dimension of the interpolation grid
    real(Float64), dimension(:),   allocatable :: r
        !+ Radii values [cm]
    real(Float64), dimension(:),   allocatable :: z
        !+ Z values [cm]
    real(Float64), dimension(:),   allocatable :: phi
        !+ Angular values [rad]
    integer(Int32) :: ntrack
        !+ Maximum number of cells for particle tracking
    integer(Int32) :: ngrid
        !+ Number of cells
end type InterpolationGrid

type Profiles
    !+ Torodial symmetric plasma parameters at a given R-Z
    real(Float64) :: dene = 0.d0
        !+ Electron density [\(cm^{-3}\)]
    real(Float64) :: denp = 0.d0
        !+ Ion density [\(cm^{-3}\)]
    real(Float64) :: denimp = 0.d0
        !+ Impurity density [\(cm^{-3}\)]
    real(Float64) :: denf = 0.d0
        !+ Fast-ion density [\(cm^{-3}\)]
    real(Float64) :: te = 0.d0
        !+ Electron temperature [kev]
    real(Float64) :: ti = 0.d0
        !+ Ion temperature [kev]
    real(Float64) :: zeff = 0.d0
        !+ Effective Nuclear Charge
    real(Float64) :: vr = 0.d0
        !+ Plasma rotation in radial direction
    real(Float64) :: vt = 0.d0
        !+ Plasma rotation in torodial/phi direction
    real(Float64) :: vz = 0.d0
        !+ Plasma rotation in z direction
    real(Float64) :: denn(nlevs) = 0.d0
        !+ Cold neutral density [\(cm^{-3}\)]
end type Profiles

type, extends( Profiles ) :: LocalProfiles
    !+ Plasma parameters at given position
    logical :: in_plasma = .False.
        !+ Indicates whether plasma parameters are valid/known
    integer :: coords = 0
        !+ Indicates coordinate system of vectors. Beam grid (0), machine (1) and cylindrical (2)
    real(Float64), dimension(3) :: pos = 0.d0
        !+ Position in beam grid coordinates
    real(Float64), dimension(3) :: uvw = 0.d0
        !+ Position in machine coordinates
    real(Float64), dimension(3) :: vrot = 0.d0
        !+ Plasma rotation in beam grid coordinates
    real(Float64), dimension(3) :: vrot_uvw = 0.d0
        !+ Plasma rotation in machine coordinates
    type(InterpolCoeffs3D) :: b
        !+ Cylindrical Interpolation Coefficients and indicies for interpolation at `pos`
end type LocalProfiles

type EMFields
    !+ Torodial symmetric electro-magnetic fields at given R-Z
    real(Float64) :: br = 0.d0
        !+ Radial magnetic field [T]
    real(Float64) :: bt = 0.d0
        !+ Torodial magnetic field [T]
    real(Float64) :: bz = 0.d0
        !+ Vertical magnetic field [T]
    real(Float64) :: er = 0.d0
        !+ Radial electric field [V/m]
    real(Float64) :: et = 0.d0
        !+ Torodial electric field [V/m]
    real(Float64) :: ez = 0.d0
        !+ Vertical electric field [V/m]
    real(Float64) :: dbr_dr = 0.d0
        !+ Radial derivative of the radial magnetic field [T/m]
    real(Float64) :: dbr_dphi = 0.d0
        !+ Angular derivative of the radial magnetic field [T/m]
    real(Float64) :: dbr_dz = 0.d0
        !+ Vertical derivative of the radial magnetic field [T/m]
    real(Float64) :: dbt_dr = 0.d0
        !+ Radial derivative of the torodial magnetic field [T/m]
    real(Float64) :: dbt_dphi = 0.d0
        !+ Angular derivative of the torodial magnetic field [T/m]
    real(Float64) :: dbt_dz = 0.d0
        !+ Vertical derivative of the torodial magnetic field [T/m]
    real(Float64) :: dbz_dr = 0.d0
        !+ Radial derivative of the radial magnetic field [T/m]
    real(Float64) :: dbz_dphi = 0.d0
        !+ Angular derivative of the radial magnetic field [T/m]
    real(Float64) :: dbz_dz = 0.d0
        !+ Vertical derivative of the vertical magnetic field [T/m]
end type EMFields

type, extends( EMFields ) :: LocalEMFields
    !+ Electro-magnetic fields at given position
    logical       :: in_plasma = .False.
        !+ Indicates whether fields are valid/known
    integer :: coords = 0
        !+ Indicates coordinate system of vectors. Beam grid (0), machine (1) and cylindrical (2)
    real(Float64) :: b_abs = 0.d0
        !+ Magnitude of magnetic field
    real(Float64) :: e_abs = 0.d0
        !+ Magnitude of electrin field
    real(Float64), dimension(3) :: pos = 0.d0
        !+ Position in beam grid coordinates
    real(Float64), dimension(3) :: uvw = 0.d0
        !+ Position in machine coordinates
    real(Float64), dimension(3) :: b_norm = 0.d0
        !+ Direction of magnetic field in beam grid coordinates
    real(Float64), dimension(3) :: a_norm = 0.d0
        !+ Vector perpendicular to `b_norm` and `c_norm`
    real(Float64), dimension(3) :: c_norm = 0.d0
        !+ Vector perpendicular to `b_norm` and `a_norm`
    real(Float64), dimension(3) :: e_norm = 0.d0
        !+ Direction of electric field in beam grid coordinates
    type(InterpolCoeffs3D) :: b
        !+ Cylindrical Interpolation Coefficients and indicies for interpolation at `pos`
end type LocalEMFields

type Equilibrium
    !+MHD Equilbrium
    type(EMFields), dimension(:,:,:), allocatable :: fields
        !+ Electro-magnetic fields at points defined in [[libfida:inter_grid]]
    type(Profiles), dimension(:,:,:), allocatable :: plasma
        !+ Plasma parameters at points defined in [[libfida:inter_grid]]
    real(Float64), dimension(:,:,:), allocatable  :: mask
        !+ Indicates whether fields and plasma are well-defined at points defined in [[libfida:inter_grid]]
end type Equilibrium

type FastIonDistribution
    !+ Defines a Guiding Center Fast-ion Distribution Function: F(E,p,R,Z,Phi)
    integer(Int32) :: nenergy
        !+ Number of energies
    integer(Int32) :: npitch
        !+ Number of pitches
    integer(Int32) :: nr
        !+ Number of radii
    integer(Int32) :: nz
        !+ Number of z values
    integer(Int32) :: nphi
        !+ Number of phi values
    real(Float64)  :: dE
        !+ Energy spacing [keV]
    real(Float64)  :: dp
        !+ Pitch spacing
    real(Float64)  :: dr
        !+ Radial spacing [cm]
    real(Float64)  :: dz
        !+ Z spacing [cm]
    real(Float64)  :: dphi
        !+ Angular spacing [rad]
    real(Float64)  :: emin
        !+ Minimum energy [keV]
    real(Float64)  :: emax
        !+ Maximum energy [keV]
    real(Float64)  :: e_range
        !+ Energy interval length [keV]
    real(Float64)  :: pmin
        !+ Minimum pitch
    real(Float64)  :: pmax
        !+ Maximum pitch
    real(Float64)  :: p_range
        !+ Pitch interval length
    real(Float64)  :: rmin
        !+ Minimum radius [cm]
    real(Float64)  :: rmax
        !+ Maximum radius [cm]
    real(Float64)  :: r_range
        !+ Radius interval length [cm]
    real(Float64)  :: zmin
        !+ Minimum Z [cm]
    real(Float64)  :: zmax
        !+ Maximum Z [cm]
    real(Float64)  :: z_range
        !+ Z interval length [cm]
    real(Float64)  :: phimin
        !+ Minimum Phi [rad]
    real(Float64)  :: phimax
        !+ Maximum Phi [rad]
    real(Float64)  :: phi_range
        !+ Phi interval length [rad]
    real(Float64)  :: n_tot = 0.d0
        !+ Total Number of fast-ions
    real(Float64), dimension(:), allocatable       :: energy
        !+ Energy values [keV]
    real(Float64), dimension(:), allocatable       :: pitch
        !+ Pitch w.r.t. the magnetic field
    real(Float64), dimension(:), allocatable       :: r
        !+ Radius [cm]
    real(Float64), dimension(:), allocatable       :: z
        !+ Z [cm]
    real(Float64), dimension(:), allocatable       :: phi
        !+ Angles [rad]
    real(Float64), dimension(:,:,:), allocatable     :: denf
        !+ Fast-ion density defined on the [[libfida:inter_grid]]: denf(R,Z,Phi)
    real(Float64), dimension(:,:,:,:,:), allocatable :: f
        !+ Fast-ion distribution function defined on the [[libfida:inter_grid]]: F(E,p,R,Z,Phi)
end type FastIonDistribution

type FastIon
    !+ Defines a fast-ion
    logical        :: beam_grid_cross_grid = .False.
        !+ Indicates whether the fast-ion crosses the [[libfida:beam_grid]]
    real(Float64)  :: r = 0.d0
        !+ Radial position of fast-ion [cm]
    real(Float64)  :: phi = 0.d0
        !+ Angular position of fast-ion [rad]
    real(Float64)  :: z = 0.d0
        !+ Vertical position of fast-ion [cm]
    real(Float64)  :: beam_grid_phi_enter = 0.d0
        !+ Torodial/phi position where fast-ion enters the [[libfida:beam_grid]] [radians]
    real(Float64)  :: delta_phi = 2*pi
        !+ Angle subtended by the [[libfida:beam_grid]] at (r,z)
    real(Float64)  :: energy = 0.d0
        !+ Energy [keV]
    real(Float64)  :: pitch = 0.d0
        !+ Pitch w.r.t. the magnetic field
    real(Float64)  :: vabs = 0.d0
        !+ Speed [cm/s]
    real(Float64)  :: vr = 0.d0
        !+ Radial velocity [cm/s]
    real(Float64)  :: vt = 0.d0
        !+ Torodial velocity [cm/s]
    real(Float64)  :: vz = 0.d0
        !+ Z velocity [cm/s]
    real(Float64)  :: weight = 0.d0
        !+ Particle weight: How many fast-ions does particle represent.
    integer(Int32) :: class = 0
        !+ Orbit class id
end type FastIon

type FastIonParticles
    !+ Collection of fast-ion particles
    integer(Int32) :: nparticle = 0
        !+ Number of particles
    integer(Int32) :: nclass = 1
        !+ Number of orbit classes
    logical :: axisym = .True.
        !+ Indicates whether distribution function is axisymmetric
    type(FastIon), dimension(:), allocatable :: fast_ion
        !+ Fast-ion particles
end type FastIonParticles

type NeutralBeam
    !+ Defines a neutral beam with +x defined to be into the plasma
    character(25) :: name = ''
        !+ Beam name
    integer       :: shape
        !+ Beam source shape 1="rectangular", 2="circular"
    real(Float64) :: widy
        !+ Half width of source in y direction
    real(Float64) :: widz
        !+ Half height of source in z direction
    real(Float64) :: focy
        !+ Focal length in y direction
    real(Float64) :: focz
        !+ Focal length in z direction
    real(Float64) :: einj
        !+ NBI voltage  [kV]
    real(Float64) :: pinj
        !+ NBI power    [MW]
    real(Float64) :: vinj
        !+ NBI velocity [cm/s]
    real(Float64) :: alpha
        !+ Z rotation not same as [[libfida:beam_grid]] alpha
    real(Float64) :: beta
        !+ Tilt rotation not same as [[libfida:beam_grid]] beta
    real(Float64), dimension(3)   :: divy
        !+ Energy dependent divergence in y direction
    real(Float64), dimension(3)   :: divz
        !+ Energy dependent divergence in z direction
    real(Float64), dimension(3)   :: current_fractions
        !+ Fractions of full, half, and third energy neutrals
    real(Float64), dimension(3)   :: src
        !+ Position of source in beam grid coordinates [cm]
    real(Float64), dimension(3)   :: axis
        !+ Beam centerline
    integer :: naperture
        !+ Number of beam apertures
    integer, dimension(:), allocatable       :: ashape
        !+ Aperture shape 1="rectangular", 2="circular"
    real(Float64), dimension(:), allocatable :: awidy
        !+ Half width of the aperture(s) in y direction
    real(Float64), dimension(:), allocatable :: awidz
        !+ Half height of the aperture(s) in z direction
    real(Float64), dimension(:), allocatable :: aoffy
        !+ Horizontal (y) offset of the aperture(s) relative to the beam centerline [cm]
    real(Float64), dimension(:), allocatable :: aoffz
        !+ Vertical (z) offset of the aperture(s) relative to the beam centerline [cm]
    real(Float64), dimension(:), allocatable :: adist
        !+ Distance from the center of the beam source grid to the aperture(s) plane [cm]
    real(Float64), dimension(3,3) :: basis
        !+ Beam basis for converting from centerline coordinates to beam grid coordinates
    real(Float64), dimension(3,3) :: inv_basis
        !+ Inverse basis for reverse transfomation
end type NeutralBeam

type AtomicCrossSection
    !+ Defines a n/m-resolved atomic cross section table
    integer       :: nenergy = 1
        !+ Number of beam energies
    real(Float64) :: logemin = 0.d0
        !+ Log-10 minimum energy
    real(Float64) :: logemax = 0.d0
        !+ Log-10 maximum energy
    integer       :: n_max = nlevs
        !+ Number of initial atomic energy levels
    integer       :: m_max = nlevs
        !+ Number of final atomic energy levels
    real(Float64) :: dlogE = 0.d0
        !+ Log-10 energy spacing
    real(Float64) :: minlog_cross
        !+ Log-10 minimum cross section
    real(Float64), dimension(:,:,:), allocatable :: log_cross
        !+ Log-10 cross sections
end type AtomicCrossSection

type AtomicRates
    !+ Defines a n/m-resolved atomic cross section table
    integer       :: nenergy = 1
        !+ Number of beam energies
    real(Float64) :: logemin = 0.d0
        !+ Log-10 minimum energy
    real(Float64) :: logemax = 0.d0
        !+ Log-10 maximum energy
    integer       :: ntemp = 1
        !+ Number of target temperatures
    real(Float64) :: logtmin = 0.d0
        !+ Log-10 minimum temperature
    real(Float64) :: logtmax = 0.d0
        !+ Log-10 maximum temperature
    integer       :: n_max = nlevs
        !+ Number of initial atomic energy levels
    integer       :: m_max = nlevs
        !+ Number of final atomic energy levels
    real(Float64) :: dlogE = 0.d0
        !+ Log-10 energy spacing
    real(Float64) :: dlogT = 0.d0
        !+ Log-10 temperature spacing
    real(Float64) :: minlog_rate = 0.d0
        !+ Log-10 minimum reaction rate
    real(Float64), dimension(2) :: ab = 0.d0
        !+ Atomic mass of beam and thermal ions respectively [amu]
    real(Float64), dimension(:,:,:,:,:), allocatable :: log_rate
        !+ Log-10 beam-target rates
end type AtomicRates

type AtomicTransitions
    !+ Defines an atomic table for populating and de-populating reaction rates
    integer       :: nenergy = 1
        !+ Number of beam energies
    real(Float64) :: logemin = 0.d0
        !+ Log-10 minimum energy
    real(Float64) :: logemax = 0.d0
        !+ Log-10 maximum energy
    integer       :: ntemp = 1
        !+ Number of target temperatures
    real(Float64) :: logtmin = 0.d0
        !+ Log-10 minimum temperature
    real(Float64) :: logtmax = 0.d0
        !+ Log-10 maximum temperature
    integer       :: n_max = nlevs
        !+ Number of initial atomic energy levels
    integer       :: m_max = nlevs
        !+ Number of final atomic energy levels
    real(Float64) :: dlogE = 0.d0
        !+ Log-10 energy spacing
    real(Float64) :: dlogT = 0.d0
        !+ Log-10 temperature spacing
    real(Float64) :: minlog_pop = 0.d0
        !+ Log-10 minimum reaction rates for populating transistions
    real(Float64) :: minlog_depop = 0.d0
        !+ Log-10 minimum reaction rates for de-populating transistions
    real(Float64), dimension(2) :: ab = 0.d0
        !+ Atomic mass of beam and thermal ions respectively [amu]
    real(Float64), dimension(:,:,:,:,:), allocatable :: log_pop
        !+ Log-10 reaction rates for populating transistions
    real(Float64), dimension(:,:,:,:), allocatable   :: log_depop
        !+ Log-10 reaction rates for de-populating transistions
end type AtomicTransitions

type NuclearRates
    !+ Nuclear reaction rates
    integer       :: nbranch = 1
        !+ Number of reaction branches
    integer       :: nenergy = 1
        !+ Number of beam energies
    real(Float64) :: logemin = 0.d0
        !+ Log-10 minimum energy
    real(Float64) :: logemax = 0.d0
        !+ Log-10 maximum energy
    integer       :: ntemp = 1
        !+ Number of target temperatures
    real(Float64) :: logtmin = 0.d0
        !+ Log-10 minimum temperature
    real(Float64) :: logtmax = 0.d0
        !+ Log-10 maximum temperature
    real(Float64) :: dlogE = 0.d0
        !+ Log-10 energy spacing
    real(Float64) :: dlogT = 0.d0
        !+ Log-10 temperature spacing
    real(Float64) :: minlog_rate = 0.d0
        !+ Log-10 minimum reaction rate
    real(Float64), dimension(2) :: bt_amu = 0.d0
        !+ Isotope mass of beam and thermal ions respectively [amu]
    real(Float64), dimension(:,:,:), allocatable :: log_rate
        !+ Log-10 reaction rates: log_rate(energy, temperature, branch)
end type NuclearRates

type AtomicTables
    !+ Atomic tables for various types of interactions
    type(AtomicCrossSection) :: H_H_cx_cross
        !+ Hydrogen-Hydrogen charge exchange n/m-resolved cross sections
    type(AtomicRates)        :: H_H_cx_rate
        !+ Hydrogen-Hydrogen charge exchange n/m-resolved beam-target rates
    type(AtomicTransitions)  :: H_H
        !+ Hydrogen-Hydrogen atomic transitions
    type(AtomicTransitions)  :: H_e
        !+ Hydrogen-Electron atomic transitions
    type(AtomicTransitions)  :: H_Aq
        !+ Hydrogen-Impurity atomic transitions
    real(Float64), dimension(nlevs,nlevs) :: einstein
        !+ Einstein coefficients for spontaneous emission
    type(NuclearRates)       :: D_D
        !+ Deuterium-Deuterium reaction rates
end type AtomicTables

type LineOfSight
    !+ Defines a line of sight
    real(Float64) :: sigma_pi = 1.d0
        !+ Ratio of sigma to pi line intensity
    real(Float64) :: spot_size = 0.d0
        !+ Radius of spot size [cm]
    real(Float64), dimension(3) :: lens = 0.d0
        !+ Lens location in beam grid coordinates
    real(Float64), dimension(3) :: axis = 0.d0
        !+ Optical axis in beam grid coordinates
    real(Float64), dimension(3) :: lens_uvw = 0.d0
        !+ Lens location in machine coordinates
    real(Float64), dimension(3) :: axis_uvw = 0.d0
        !+ Optical axis in machine coordinates
end type LineOfSight

type LOSElement
    !+ Defines a element of a line of sight and cell intersection
    integer :: id
        !+ Line of sight index
    real(Float64) :: length
        !+ Length of crossing
end type LOSElement

type LOSInters
    !+ Defines the channels that intersect a cell
    integer :: nchan = 0
        !+ Number of channels that intersect
    type(LOSElement), dimension(:), allocatable :: los_elem
        !+ Array of crossing
end type LOSInters

type SpectralChords
    !+ Defines an spectral diagnostic system
    integer :: nchan = 0
        !+ Number of channels
    integer :: ncell = 0
        !+ Number of beam_grid cells with intersections
    integer :: cyl_ncell = 0
        !+ Number of pass_grid cells with intersections
    type(LineOfSight), dimension(:), allocatable :: los
        !+ Line of sight array
    real(Float64), dimension(:), allocatable     :: radius
        !+ Radius of each line of sight
    type(LOSInters), dimension(:,:,:), allocatable :: inter
        !+ Array of LOS intersections with [[libfida:beam_grid]]
    type(LOSInters), dimension(:,:,:), allocatable :: cyl_inter
        !+ Array of LOS intersections with [[libfida:pass_grid]]
    integer, dimension(:), allocatable :: cell
        !+ Linear indices of beam_grid that have intersections
    integer, dimension(:), allocatable :: cyl_cell
        !+ Linear indices of pass_grid that have intersections
end type SpectralChords

type BoundedPlane
    !+ Defines a plane with a circular or rectangular boundary
    integer       :: shape    = 0
        !+ Boundary shape 1="Rectangular", 2="circular"
    real(Float64) :: hh       = 0.d0
        !+ Half height of boundary [cm]
    real(Float64) :: hw       = 0.d0
        !+ Half width of boundary [cm]
    real(Float64), dimension(3)   :: origin   = 0.d0
        !+ Origin of plane in machine coordinates
    real(Float64), dimension(3,3) :: basis    = 0.d0
        !+ Basis vectors basis(:,1) = u_1 is plane normal
    real(Float64), dimension(3,3) :: inv_basis= 0.d0
        !+ Inverse basis
end type BoundedPlane

type NPADetector
    !+ Defines a NPA detector
    type(BoundedPlane) :: detector
        !+ Detecting plane of NPA detector
    type(BoundedPlane) :: aperture
        !+ Aperture plane of NPA detector
end type NPADetector

type NPAProbability
    !+ Type to contain the probability of hitting a NPA detector
    real(Float64) :: p = 0.d0
        !+ Hit probability
    real(Float64) :: pitch = -2.d0
        !+ Pitch
    real(Float64), dimension(3) :: eff_rd = 0.d0
        !+ Effective position of detector
    real(Float64), dimension(3) :: dir = 0.d0
        !+ Trajectory direction
end type NPAProbability

type NPAChords
    !+ Defines a NPA system
    integer :: nchan = 0
         !+ Number of channels
    type(NPADetector), dimension(:), allocatable          :: det
         !+ NPA detector array
    real(Float64), dimension(:), allocatable              :: radius
         !+ Radius [cm]
    logical, dimension(:,:,:), allocatable                :: hit
         !+ Indicates whether a particle can hit any NPA detector from a grid cell: hit(x,y,z)
    type(NPAProbability), dimension(:,:,:,:), allocatable :: phit
         !+ Probability of hitting a detector from a grid cell: phit(x,y,z,chan)
end type NPAChords

type NPAParticle
    !+ Defines a NPA particle
    integer       :: detector = 0
        !+ Detector NPA particle hit
    integer(Int32) :: class = 0
        !+ Orbit class id
    real(Float64) :: xi = 0.d0
        !+ Initial x position
    real(Float64) :: yi = 0.d0
        !+ Initial y position
    real(Float64) :: zi = 0.d0
        !+ Initial z position
    real(Float64) :: xf = 0.d0
        !+ Final x position
    real(Float64) :: yf = 0.d0
        !+ Final y position
    real(Float64) :: zf = 0.d0
        !+ Final z position
    real(Float64) :: weight = 0.d0
        !+ NPA particle weight
    real(Float64) :: energy = 0.d0
        !+ Birth Energy [keV]
    real(Float64) :: pitch = 0.d0
        !+ Birth Pitch
end type NPAParticle

type NPAResults
    !+ MC NPA result structure
    integer(Int32) :: nchan = 0
        !+ Number of NPA channels
    integer(Int32) :: npart = 0
        !+ Number of particles that hit a detector
    integer(Int32) :: nmax = 1000000
        !+ Maximum allowed number of particles grows if necessary
    integer(Int32) :: nenergy = 122
        !+ Number of energy values
    type(NPAParticle), dimension(:), allocatable :: part
        !+ Array of NPA particles
    real(Float64), dimension(:), allocatable     :: energy
        !+ Energy array [keV]
    real(Float64), dimension(:,:,:), allocatable :: flux
        !+ Neutral particle flux: flux(energy,chan, orbit_type) [neutrals/(s*dE)]
end type NPAResults

type BirthParticle
    !+ Defines a Birth particle
    integer :: neut_type = 0
        !+ Birth type (1=Full, 2=Half, 3=Third)
    integer(Int32), dimension(3) :: ind = 0
        !+ Initial [[libfida:beam_grid]] indices
    real(Float64), dimension(3) :: ri = 0.d0
        !+ Initial position in beam grid coordinates [cm]
    real(Float64), dimension(3) :: vi = 0.d0
        !+ Initial velocity in beam grid coordinates [cm/s]
    real(Float64), dimension(3) :: ri_gc = 0.d0
        !+ Initial guiding-center position in beam grid coordinates [cm]
    real(Float64) :: weight = 0.d0
        !+ NPA particle weight [fast-ions/s]
    real(Float64) :: energy = 0.d0
        !+ Birth Energy [keV]
    real(Float64) :: pitch = 0.d0
        !+ Birth Pitch w.r.t. the magnetic field
end type BirthParticle

type BirthProfile
    !+ Birth profile structure
    integer :: cnt = 1
        !+ Particle counter
    type(BirthParticle), dimension(:), allocatable :: part
        !+ Array of birth particles
    real(Float64), dimension(:,:,:,:), allocatable :: dens
        !+ Birth density: dens(neutral_type,x,y,z) [fast-ions/(s*cm^3)]
end type BirthProfile

type Spectra
    !+ Spectra storage structure
    real(Float64), dimension(:,:), allocatable   :: brems
        !+ Bremsstruhlung: brems(lambda,chan)
    real(Float64), dimension(:,:), allocatable   :: full
        !+ Full energy beam emission: full(lambda,chan)
    real(Float64), dimension(:,:), allocatable   :: half
        !+ Half energy beam emission: half(lambda,chan)
    real(Float64), dimension(:,:), allocatable   :: third
        !+ Third energy beam emission: third(lambda,chan)
    real(Float64), dimension(:,:), allocatable   :: dcx
        !+ Direct CX emission: dcx(lambda,chan)
    real(Float64), dimension(:,:), allocatable   :: halo
        !+ Thermal halo emission: halo(lambda,chan)
    real(Float64), dimension(:,:), allocatable   :: cold
        !+ Cold D-alpha emission: cold(lambda,chan)
    real(Float64), dimension(:,:,:), allocatable :: fida
        !+ Active FIDA emission: fida(lambda,chan,orbit_type)
    real(Float64), dimension(:,:,:), allocatable :: pfida
        !+ Passive FIDA emission: pfida(lambda,chan,orbit_type)
end type Spectra

type NeutronRate
    !+ Neutron storage structure
    real(Float64), dimension(:), allocatable :: rate
        !+ Neutron rate: rate(orbit_type) [neutrons/sec]
    real(Float64), dimension(:,:,:,:,:), allocatable :: weight
        !+ Neutron rate weight: weight(E,p,R,Z,Phi)
    real(Float64), dimension(:,:,:), allocatable :: emis
        !+ Neutron emissivity: emis(R,Z,Phi)
end type NeutronRate

type NeutralDensity
    !+ Neutral density structure
    real(Float64), dimension(:,:,:,:), allocatable :: full
        !+ Full energy neutral density: full(lev,x,y,z)
    real(Float64), dimension(:,:,:,:), allocatable :: half
        !+ Half energy neutral density: half(lev,x,y,z)
    real(Float64), dimension(:,:,:,:), allocatable :: third
        !+ Third energy neutral density: third(lev,x,y,z)
    real(Float64), dimension(:,:,:,:), allocatable :: dcx
        !+ Direct CX neutral density: dcx(lev,x,y,z)
    real(Float64), dimension(:,:,:,:), allocatable :: halo
        !+ Thermal halo neutral density: dens(lev,x,y,z)
end type NeutralDensity

type FIDAWeights
    !+ FIDA weights structure
    real(Float64), dimension(:,:,:), allocatable   :: mean_f
        !+ Estimate of mean fast-ion distribution function "seen" by LOS: mean_f(E,p,chan)
    real(Float64), dimension(:,:,:,:), allocatable :: weight
        !+ FIDA weight function: weight(lambda,E,p,chan)
end type FIDAWeights

type NPAWeights
    !+ NPA weights structure
    real(Float64), dimension(:,:,:,:,:), allocatable :: attenuation
        !+ Attenuation fraction: attenuation(E,x,y,z,chan)
    real(Float64), dimension(:,:,:,:,:), allocatable :: cx
        !+ Charge Exchange reaction rates: cx(E,x,y,z,chan)
    real(Float64), dimension(:,:,:,:), allocatable   :: emissivity
        !+ Emissivity: emissivity(x,y,z,chan) [neutrals/(s*dV)]
    real(Float64), dimension(:,:,:), allocatable     :: weight
        !+ NPA weight function: weight(E,p,chan) [neutrals/(s*fast-ion*dE*dP)]
    real(Float64), dimension(:,:), allocatable       :: flux
        !+ Neutral particle flux: flux(E,chan) [neutrals/(s*dE)]
end type NPAWeights

type SimulationInputs
    !+ Simulation settings structure
    integer(Int32) :: shot_number
        !+ Shot Number
    real(Float64)  :: time
        !+ Shot time [s]
    character(charlim) :: runid = ''
        !+ FIDASIM run ID
    character(charlim) :: result_dir = ''
        !+ Result directory
    character(charlim) :: tables_file = ''
        !+ Atomic tables file
    character(charlim) :: geometry_file = ''
        !+ FIDASIM input file containing geometric quantities
    character(charlim) :: equilibrium_file = ''
        !+ FIDASIM input file containing the plasma parameters and fields
    character(charlim) :: distribution_file = ''
        !+ FIDASIM input file containing the fast-ion distribution
    character(charlim) :: neutrals_file = ''
        !+ FIDASIM output/input file containing beam neutral density.
        !+ Used when [[SimulationInputs:load_neutrals]] is set.

    !! Random Number Generator Settings
    integer :: seed
        !+ Random number generator seed

    !! Monte Carlo settings
    integer(Int64) :: n_fida
        !+ Number of Active FIDA mc markers
    integer(Int64) :: n_pfida
        !+ Number of Passive FIDA mc markers
    integer(Int64) :: n_npa
        !+ Number of Passiv NPA mc markers
    integer(Int64) :: n_pnpa
        !+ Number of Passive NPA mc markers
    integer(Int64) :: n_nbi
        !+ Number of neutral beam mc markers
    integer(Int64) :: n_dcx
        !+ Number of direct charge exchange (DCX) mc markers
    integer(Int64) :: n_halo
        !+ Number of halo mc markers
    integer(Int64) :: n_birth
        !+ Number of birth particles per [[SimulationInputs:n_nbi]]

    !! Simulation switches
    integer(Int32) :: calc_spec
        !+ Calculate spectra: 0 = off, 1=on
    integer(Int32) :: calc_beam
        !+ Calculate beam densities: 0 = off, 1=on
    integer(Int32) :: calc_nbi_dens
        !+ Calculate neutral beam density: 0 = off, 1=on
    integer(Int32) :: calc_dcx_dens
        !+ Calculate Direct Charge Exchange (DCX) density: 0 = off, 1=on
    integer(Int32) :: calc_halo_dens
        !+ Calculate Thermal Halo density: 0 = off, 1=on
    integer(Int32) :: calc_brems
        !+ Calculate bremmstruhlung: 0 = off, 1=on
    integer(Int32) :: calc_bes
        !+ Calculate NBI: 0 = off, 1=on
    integer(Int32) :: calc_dcx
        !+ Calculate DCX: 0 = off, 1=on
    integer(Int32) :: calc_halo
        !+ Calculate Halo: 0 = off, 1=on
    integer(Int32) :: calc_cold
        !+ Calculate Cold D-alpha: 0 = off, 1=on
    integer(Int32) :: calc_fida
        !+ Calculate Active FIDA: 0 = off, 1=on
    integer(Int32) :: calc_pfida
        !+ Calculate Passive FIDA: 0 = off, 1=on
    integer(Int32) :: tot_spectra
        !+ Total number of spectral switches on
    integer(Int32) :: load_neutrals
        !+ Load neutrals from file: 0 = off, 1=on
    integer(Int32) :: calc_npa
        !+ Calculate Active NPA: 0 = off, 1=on, 2=on++
    integer(Int32) :: calc_pnpa
        !+ Calculate Passive NPA: 0 = off, 1=on, 2=on++
    integer(Int32) :: calc_fida_wght
        !+ Calculate FIDA weight: 0 = off, 1=on, 2=on++
    integer(Int32) :: calc_npa_wght
        !+ Calculate NPA weights: 0 = off, 1=on, 2=on++
    integer(Int32) :: calc_birth
        !+ Calculate birth profile: 0 = off, 1=on
    integer(Int32) :: calc_neutron
        !+ Calculate neutron flux: 0 = off, 1=on, 2=on++
    integer(Int32) :: flr
        !+ FLR correction: 0=off, 1=1st order(vxb/omega), 2=2nd order correction
    integer(Int32) :: split
        !+ Split signals by fast ion class: 0=off, 1=on
    integer(Int32) :: verbose
        !+ Verbosity: <0 = off++, 0 = off, 1=on, 2=on++

    !! Neutral Beam Settings
    real(Float64)    :: ab
        !+ Atomic mass of beam neutrals

    !! Plasma parameters
    integer(Int32) :: impurity_charge
        !+ Impurity proton number
    real(Float64)  :: ai
        !+ Atomic mass of thermal ions

    !! Distribution settings
    integer(Int32) :: dist_type
        !+ Type of fast-ion distribution

    !! Spectrum parameters
    integer(Int32) :: nlambda
        !+ Number of wavelength to calculate
    real(Float64)  :: dlambda
        !+ Wavelength spacing [nm]
    real(Float64)  :: lambdamin
        !+ Minimum wavelength [nm]
    real(Float64)  :: lambdamax
        !+ Maximum wavelength [nm]

    !! Weight function settings
    integer(Int32) :: ne_wght
        !+ Number of energies in weight functions
    integer(Int32) :: np_wght
        !+ Number of pitches in weight functions
    integer(Int32) :: nphi_wght
        !+ Number of gyro-angles to average over in weight functions
    integer(Int32) :: nlambda_wght
        !+ Number of wavelength to calculate in weight functions
    real(Float64)  :: emax_wght
        !+ Maximum energy in weight functions [keV]
    real(Float64)  :: lambdamin_wght
        !+ Minimum wavelength in weight functions [nm]
    real(Float64)  :: lambdamax_wght
        !+ Maximum wavelength in weight functions [nm]
end type SimulationInputs

type ParticleTrack
    !+ Stores properties seen when traveling through a 3D grid
    real(Float64) :: time = 0.d0
        !+ Time/distance/... in cell
    real(Float64) :: flux = 0.d0
        !+ Flux/density/... in cell
    integer(Int32), dimension(3) :: ind = 0
        !+ Indices of cell
    real(Float64), dimension(3)  :: pos = 0.d0
        !+ Midpoint of track in cell [cm]
end type ParticleTrack

type GyroSurface
    !+ Surface containing the fast-ion velocity vectors for all values of the
    !+ gyro-angle. It takes the form of a hyperboloid
    !+ \((x(\gamma,t) = \alpha \sqrt{1-\rm{pitch}^2}(cos(\gamma + \pi/2) - \omega_i t sin(\gamma + \pi/2)) \)
    !+ \((y(\gamma,t) = \alpha \sqrt{1-\rm{pitch}^2}(sin(\gamma + \pi/2) + \omega_i t cos(\gamma + \pi/2)) \)
    !+ \((z(\gamma,t) = \alpha \omega_i \rm{pitch} t\)
    !+ where \(\gamma\) is the gyro-angle, \(\omega_i\) is the ion
    !+ gyro-frequency and \(\alpha = V/\omega_i \)
    real(Float64) :: v = 0.d0
        !+ Particle speed
    real(Float64) :: omega = 0.d0
        !+ Ion gyro-frequency
    real(Float64), dimension(3)   :: axes = 0.d0
        !+ Semi-axes of the hyperboloid, i.e. a, b, c coefficients
    real(Float64), dimension(3)   :: center = 0.d0
        !+ Center of the gyrosurface
    real(Float64), dimension(3,3) :: A = 0.d0
        !+ Coefficients of quartic surface i.e. `basis*diagm(1/a^2,1/b^2,1/c^2)*basis'`
    real(Float64), dimension(3,3) :: basis = 0.d0
        !+ Basis of coordinate system of gyrosurface
end type GyroSurface

interface assignment(=)
    !+ Allows for assigning [[Profiles]],[[LocalProfiles]],
    !+ [[EMFields]],[[LocalEMFields]],[[FastIon]], [[NPAParticle]], and [[BirthParticle]]
    module procedure pp_assign, lpp_assign, plp_assign, lplp_assign, &
                     ff_assign, lff_assign, flf_assign, lflf_assign, &
                     fast_ion_assign,npa_part_assign,birth_part_assign
end interface

interface operator(+)
    !+ Allows for adding [[Profiles]],[[LocalProfiles]],
    !+ [[EMFields]], and [[LocalEMFields]]
    module procedure pp_add,lplp_add,ff_add,lflf_add
end interface

interface operator(-)
    !+ Allows for subtracting [[Profiles]],[[LocalProfiles]],
    !+ [[EMFields]], and [[LocalEMFields]]
    module procedure pp_subtract,lplp_subtract,ff_subtract,lflf_subtract
end interface

interface operator(*)
    !+ Allows for multiplying [[Profiles]],[[LocalProfiles]],
    !+ [[EMFields]], and [[LocalEMFields]] by scalars
    module procedure sp_multiply, ps_multiply, lps_multiply, slp_multiply, &
                     sf_multiply, fs_multiply, lfs_multiply, slf_multiply
end interface

interface operator(/)
    !+ Allows for dividing [[Profiles]],[[LocalProfiles]],
    !+ [[EMFields]], and [[LocalEMFields]] by scalars
    module procedure ps_divide, lps_divide, fs_divide, lfs_divide
end interface

interface interpol_coeff
    !+ Calculates interpolation coefficients
    module procedure interpol1D_coeff, interpol1D_coeff_arr
    module procedure interpol2D_coeff, interpol2D_coeff_arr
    module procedure cyl_interpol3D_coeff, cyl_interpol3D_coeff_arr
end interface

interface interpol
    !+ Performs linear/bilinear/cylindrical interpolation
    module procedure interpol1D_arr
    module procedure interpol2D_arr, interpol2D_2D_arr
    module procedure interpol3D_arr, interpol3D_2D_arr
end interface

!! definition of the structures:
type(BeamGrid), save            :: beam_grid
    !+ Variable containing beam grid definition
type(InterpolationGrid), save   :: inter_grid
    !+ Variable containing interpolation grid definition
type(InterpolationGrid), save   :: pass_grid
    !+ Variable containing passive neutral grid definition
type(FastIonDistribution), save :: fbm
    !+ Variable containing the fast-ion distribution function
type(FastIonParticles), save    :: particles
    !+ Variable containing a MC fast-ion distribution
type(Equilibrium), save         :: equil
    !+ Variable containing the plasma parameters and fields
type(NeutralBeam), save         :: nbi
    !+ Variable containing the neutral beam geometry and settings
type(AtomicTables), save        :: tables
    !+ Variable containing the atomic tables
type(NPAResults), save          :: npa
    !+ Variable for storing the calculated active NPA results
type(NPAResults), save          :: pnpa
    !+ Variable for storing the calculated passive NPA results
type(SpectralChords), save      :: spec_chords
    !+ Variable containing the spectral system definition
type(NPAChords), save           :: npa_chords
    !+ Variable containing the NPA system definition
type(SimulationInputs), save    :: inputs
    !+ Variable containing the simulation inputs
type(BirthProfile), save        :: birth
    !+ Variable for storing the calculated birth profile
type(NeutralDensity), save      :: neut
    !+ Variable for storing the calculated beam density
type(Spectra), save             :: spec
    !+ Variable for storing the calculated spectra
type(NeutronRate), save         :: neutron
    !+ Variable for storing the neutron rate
type(FIDAWeights), save         :: fweight
    !+ Variable for storing the calculated FIDA weights
type(NPAWeights), save          :: nweight
    !+ Variable for storing the calculated NPA weights

contains

subroutine print_banner()
    !+ Prints FIDASIM banner
    write(*,'(a)') "   ____ ____ ___   ___    ____ ____ __  ___"
    write(*,'(a)') "  / __//  _// _ \ / _ |  / __//  _//  |/  /"
    write(*,'(a)') " / _/ _/ / / // // __ | _\ \ _/ / / /|_/ / "
    write(*,'(a)') "/_/  /___//____//_/ |_|/___//___//_/  /_/  "
    write(*,'(a)') "                                           "
    if(version.ne."") then
        write(*,'(a,a)') "Version: ",trim(version)
    endif
    write(*,'(a)') ""
    write(*,'(a)') "FIDASIM is released as open source code under the MIT Licence."
    write(*,'(a)') "For more information visit http://d3denergetic.github.io/FIDASIM/"
    write(*,'(a)') ""

#ifdef _DEBUG
    write(*,'(a)') "########################### ATTENTION ###########################"
    write(*,'(a)') "# Running in debug mode. All optimizations have been turned off #"
    write(*,'(a)') "#################################################################"
    write(*,'(a)') ""
#endif

#ifdef _PROF
    write(*,'(a)') "########################### ATTENTION ###########################"
    write(*,'(a)') "#                   Running in profiling mode                   #"
    write(*,'(a)') "#################################################################"
    write(*,'(a)') ""
#endif

#ifndef _OMP
#ifndef _MPI
    write(*,'(a)') "########################### ATTENTION ###########################"
    write(*,'(a)') "#              OpenMP threading has been disabled               #"
    write(*,'(a)') "#################################################################"
    write(*,'(a)') ""
#endif
#endif

#ifndef _MPI
#ifndef _OMP
    write(*,'(a)') "########################### ATTENTION ###########################"
    write(*,'(a)') "#                     MPI has been disabled                     #"
    write(*,'(a)') "#################################################################"
    write(*,'(a)') ""
#endif
#endif

end subroutine print_banner

!============================================================================
!---------------------------Operator Overloading-----------------------------
!============================================================================
subroutine fast_ion_assign(p1, p2)
    !+ Defines how to assign [[FastIon]] types to eachother
    type(FastIon), intent(in)  :: p2
    type(FastIon), intent(out) :: p1

    p1%beam_grid_cross_grid = p2%beam_grid_cross_grid
    p1%r                    = p2%r
    p1%z                    = p2%z
    p1%phi                  = p2%phi
    p1%beam_grid_phi_enter  = p2%beam_grid_phi_enter
    p1%delta_phi            = p2%delta_phi
    p1%energy               = p2%energy
    p1%pitch                = p2%pitch
    p1%vabs                 = p2%vabs
    p1%vr                   = p2%vr
    p1%vt                   = p2%vt
    p1%vz                   = p2%vz
    p1%weight               = p2%weight
    p1%class                = p2%class

end subroutine fast_ion_assign

subroutine npa_part_assign(p1, p2)
    !+ Defines how to assign [[NPAParticle]] types to eachother
    type(NPAParticle), intent(in)  :: p2
    type(NPAParticle), intent(out) :: p1

    p1%xi = p2%xi
    p1%yi = p2%yi
    p1%zi = p2%zi
    p1%xf = p2%xf
    p1%yf = p2%yf
    p1%zf = p2%zf
    p1%weight = p2%weight
    p1%energy = p2%energy
    p1%pitch = p2%pitch
    p1%detector = p2%detector

end subroutine npa_part_assign

subroutine birth_part_assign(p1, p2)
    !+ Defines how to assign [[BirthParticle]] types to eachother
    type(BirthParticle), intent(in)  :: p2
    type(BirthParticle), intent(out) :: p1

    p1%neut_type = p2%neut_type
    p1%ind       = p2%ind
    p1%ri        = p2%ri
    p1%vi        = p2%vi
    p1%ri_gc     = p2%ri_gc
    p1%weight    = p2%weight
    p1%energy    = p2%energy
    p1%pitch     = p2%pitch

end subroutine birth_part_assign

subroutine pp_assign(p1, p2)
    !+ Defines how to assign [[Profiles]] types to eachother
    type(Profiles), intent(in)    :: p2
    type(Profiles), intent(inout) :: p1

    p1%dene   = p2%dene
    p1%ti     = p2%ti
    p1%te     = p2%te
    p1%denp   = p2%denp
    p1%denf   = p2%denf
    p1%denimp = p2%denimp
    p1%zeff   = p2%zeff
    p1%vr     = p2%vr
    p1%vt     = p2%vt
    p1%vz     = p2%vz
    p1%denn   = p2%denn

end subroutine pp_assign

subroutine lpp_assign(p1, p2)
    !+ Defines how to assign a [[Profiles]] type to a [[LocalProfiles]] type
    type(Profiles), intent(in)         :: p2
    type(LocalProfiles), intent(inout) :: p1

    p1%dene   = p2%dene
    p1%ti     = p2%ti
    p1%te     = p2%te
    p1%denp   = p2%denp
    p1%denf   = p2%denf
    p1%denimp = p2%denimp
    p1%zeff   = p2%zeff
    p1%vr     = p2%vr
    p1%vt     = p2%vt
    p1%vz     = p2%vz
    p1%denn   = p2%denn

end subroutine lpp_assign

subroutine plp_assign(p1, p2)
    !+ Defines how to assign a [[LocalProfiles]] type to a [[Profiles]] type
    type(LocalProfiles), intent(in) :: p2
    type(Profiles), intent(inout)   :: p1

    p1%dene   = p2%dene
    p1%ti     = p2%ti
    p1%te     = p2%te
    p1%denp   = p2%denp
    p1%denf   = p2%denf
    p1%denimp = p2%denimp
    p1%zeff   = p2%zeff
    p1%vr     = p2%vr
    p1%vt     = p2%vt
    p1%vz     = p2%vz
    p1%denn   = p2%denn

end subroutine plp_assign

subroutine lplp_assign(p1, p2)
    !+ Defines how to assign [[LocalProfiles]] types to eachother
    type(LocalProfiles), intent(in)    :: p2
    type(LocalProfiles), intent(inout) :: p1

    p1%pos    = p2%pos
    p1%uvw    = p2%uvw
    p1%dene   = p2%dene
    p1%ti     = p2%ti
    p1%te     = p2%te
    p1%denp   = p2%denp
    p1%denf   = p2%denf
    p1%denimp = p2%denimp
    p1%zeff   = p2%zeff
    p1%vr     = p2%vr
    p1%vt     = p2%vt
    p1%vz     = p2%vz
    p1%denn   = p2%denn
    p1%vrot   = p2%vrot

end subroutine lplp_assign

subroutine ff_assign(p1, p2)
    !+ Defines how to assign [[EMFields]] types to eachother
    type(EMFields), intent(in)    :: p2
    type(EMFields), intent(inout) :: p1

    p1%br   = p2%br
    p1%bt   = p2%bt
    p1%bz   = p2%bz
    p1%er   = p2%er
    p1%et   = p2%et
    p1%ez   = p2%ez

    p1%dbr_dr   = p2%dbr_dr
    p1%dbr_dz   = p2%dbr_dz
    p1%dbt_dr   = p2%dbt_dr
    p1%dbt_dz   = p2%dbt_dz
    p1%dbz_dr   = p2%dbz_dr
    p1%dbz_dz   = p2%dbz_dz

end subroutine ff_assign

subroutine lff_assign(p1, p2)
    !+ Defines how to assign a [[EMFields]] type to a [[LocalEMFields]] type
    type(EMFields), intent(in)         :: p2
    type(LocalEMFields), intent(inout) :: p1

    p1%br   = p2%br
    p1%bt   = p2%bt
    p1%bz   = p2%bz
    p1%er   = p2%er
    p1%et   = p2%et
    p1%ez   = p2%ez

    p1%dbr_dr   = p2%dbr_dr
    p1%dbr_dz   = p2%dbr_dz
    p1%dbt_dr   = p2%dbt_dr
    p1%dbt_dz   = p2%dbt_dz
    p1%dbz_dr   = p2%dbz_dr
    p1%dbz_dz   = p2%dbz_dz

end subroutine lff_assign

subroutine flf_assign(p1, p2)
    !+ Defines how to assign a [[LocalEMFields]] type to a [[EMFields]] type
    type(LocalEMFields), intent(in) :: p2
    type(EMFields), intent(inout)   :: p1

    p1%br   = p2%br
    p1%bt   = p2%bt
    p1%bz   = p2%bz
    p1%er   = p2%er
    p1%et   = p2%et
    p1%ez   = p2%ez

    p1%dbr_dr   = p2%dbr_dr
    p1%dbr_dz   = p2%dbr_dz
    p1%dbt_dr   = p2%dbt_dr
    p1%dbt_dz   = p2%dbt_dz
    p1%dbz_dr   = p2%dbz_dr
    p1%dbz_dz   = p2%dbz_dz

end subroutine flf_assign

subroutine lflf_assign(p1, p2)
    !+ Defines how to assign [[LocalEMFields]] types to eachother
    type(LocalEMFields), intent(in)    :: p2
    type(LocalEMFields), intent(inout) :: p1

    p1%pos  = p2%pos
    p1%uvw  = p2%uvw
    p1%br   = p2%br
    p1%bt   = p2%bt
    p1%bz   = p2%bz
    p1%er   = p2%er
    p1%et   = p2%et
    p1%ez   = p2%ez
    p1%b_abs = p2%b_abs
    p1%e_abs = p2%e_abs
    p1%a_norm = p2%a_norm
    p1%b_norm = p2%b_norm
    p1%c_norm = p2%c_norm
    p1%e_norm = p2%e_norm

    p1%dbr_dr   = p2%dbr_dr
    p1%dbr_dz   = p2%dbr_dz
    p1%dbt_dr   = p2%dbt_dr
    p1%dbt_dz   = p2%dbt_dz
    p1%dbz_dr   = p2%dbz_dr
    p1%dbz_dz   = p2%dbz_dz

end subroutine lflf_assign

function pp_add(p1, p2) result (p3)
    !+ Defines how to add two [[Profiles]] types
    type(Profiles), intent(in) :: p1,p2
    type(Profiles)             :: p3

    p3%dene   = p1%dene   + p2%dene
    p3%ti     = p1%ti     + p2%ti
    p3%te     = p1%te     + p2%te
    p3%denp   = p1%denp   + p2%denp
    p3%denf   = p1%denf   + p2%denf
    p3%denimp = p1%denimp + p2%denimp
    p3%zeff   = p1%zeff   + p2%zeff
    p3%vr     = p1%vr     + p2%vr
    p3%vt     = p1%vt     + p2%vt
    p3%vz     = p1%vz     + p2%vz
    p3%denn   = p1%denn   + p2%denn

end function pp_add

function pp_subtract(p1, p2) result (p3)
    !+ Defines how to subtract two [[Profiles]] types
    type(Profiles), intent(in) :: p1,p2
    type(Profiles)             :: p3

    p3%dene   = p1%dene   - p2%dene
    p3%ti     = p1%ti     - p2%ti
    p3%te     = p1%te     - p2%te
    p3%denp   = p1%denp   - p2%denp
    p3%denf   = p1%denf   - p2%denf
    p3%denimp = p1%denimp - p2%denimp
    p3%zeff   = p1%zeff   - p2%zeff
    p3%vr     = p1%vr     - p2%vr
    p3%vt     = p1%vt     - p2%vt
    p3%vz     = p1%vz     - p2%vz
    p3%denn   = p1%denn   - p2%denn

end function pp_subtract

function lplp_add(p1, p2) result (p3)
    !+ Defines how to add two [[LocalProfiles]] types
    type(LocalProfiles), intent(in) :: p1,p2
    type(LocalProfiles)             :: p3

    p3%pos    = p1%pos    + p2%pos
    p3%uvw    = p1%uvw    + p2%uvw
    p3%dene   = p1%dene   + p2%dene
    p3%ti     = p1%ti     + p2%ti
    p3%te     = p1%te     + p2%te
    p3%denp   = p1%denp   + p2%denp
    p3%denf   = p1%denf   + p2%denf
    p3%denimp = p1%denimp + p2%denimp
    p3%zeff   = p1%zeff   + p2%zeff
    p3%vr     = p1%vr     + p2%vr
    p3%vt     = p1%vt     + p2%vt
    p3%vz     = p1%vz     + p2%vz
    p3%denn   = p1%denn   + p2%denn
    p3%vrot   = p1%vrot   + p2%vrot

end function lplp_add

function lplp_subtract(p1, p2) result (p3)
    !+ Defines how to subtract two [[LocalProfiles]] types
    type(LocalProfiles), intent(in) :: p1,p2
    type(LocalProfiles)             :: p3

    p3%pos    = p1%pos    - p2%pos
    p3%uvw    = p1%uvw    - p2%uvw
    p3%dene   = p1%dene   - p2%dene
    p3%ti     = p1%ti     - p2%ti
    p3%te     = p1%te     - p2%te
    p3%denp   = p1%denp   - p2%denp
    p3%denf   = p1%denf   - p2%denf
    p3%denimp = p1%denimp - p2%denimp
    p3%zeff   = p1%zeff   - p2%zeff
    p3%vr     = p1%vr     - p2%vr
    p3%vt     = p1%vt     - p2%vt
    p3%vz     = p1%vz     - p2%vz
    p3%denn   = p1%denn   - p2%denn
    p3%vrot   = p1%vrot   - p2%vrot

end function lplp_subtract

function ps_multiply(p1, real_scalar) result (p3)
    !+ Defines how to multiply [[Profiles]] types by a scalar
    type(Profiles), intent(in) :: p1
    real(Float64), intent(in)  :: real_scalar
    type(Profiles)             :: p3

    p3%dene   = p1%dene   * real_scalar
    p3%ti     = p1%ti     * real_scalar
    p3%te     = p1%te     * real_scalar
    p3%denp   = p1%denp   * real_scalar
    p3%denf   = p1%denf   * real_scalar
    p3%denimp = p1%denimp * real_scalar
    p3%zeff   = p1%zeff   * real_scalar
    p3%vr     = p1%vr     * real_scalar
    p3%vt     = p1%vt     * real_scalar
    p3%vz     = p1%vz     * real_scalar
    p3%denn   = p1%denn   * real_scalar

end function ps_multiply

function sp_multiply(real_scalar, p1) result (p3)
    !+ Defines how to multiply [[Profiles]] types by a scalar
    type(Profiles), intent(in) :: p1
    real(Float64), intent(in)  :: real_scalar
    type(Profiles)             :: p3

    p3 = p1*real_scalar

end function sp_multiply

function ps_divide(p1, real_scalar) result (p3)
    !+ Defines how to divide [[Profiles]] types by a scalar
    type(Profiles), intent(in) :: p1
    real(Float64), intent(in)  :: real_scalar
    type(Profiles)             :: p3

    p3 = p1*(1.d0/real_scalar)

end function ps_divide

function lps_multiply(p1, real_scalar) result (p3)
    !+ Defines how to multiply [[LocalProfiles]] types by a scalar
    type(LocalProfiles), intent(in) :: p1
    real(Float64), intent(in)       :: real_scalar
    type(LocalProfiles)             :: p3

    p3%pos    = p1%pos    * real_scalar
    p3%uvw    = p1%uvw    * real_scalar
    p3%dene   = p1%dene   * real_scalar
    p3%ti     = p1%ti     * real_scalar
    p3%te     = p1%te     * real_scalar
    p3%denp   = p1%denp   * real_scalar
    p3%denf   = p1%denf   * real_scalar
    p3%denimp = p1%denimp * real_scalar
    p3%zeff   = p1%zeff   * real_scalar
    p3%vr     = p1%vr     * real_scalar
    p3%vt     = p1%vt     * real_scalar
    p3%vz     = p1%vz     * real_scalar
    p3%denn   = p1%denn   * real_scalar
    p3%vrot   = p1%vrot   * real_scalar

end function lps_multiply

function slp_multiply(real_scalar, p1) result (p3)
    !+ Defines how to multiply [[LocalProfiles]] types by a scalar
    type(LocalProfiles), intent(in) :: p1
    real(Float64), intent(in)       :: real_scalar
    type(LocalProfiles)             :: p3

    p3 = p1*real_scalar

end function slp_multiply

function lps_divide(p1, real_scalar) result (p3)
    !+ Defines how to divide [[LocalProfiles]] types by a scalar
    type(LocalProfiles), intent(in) :: p1
    real(Float64), intent(in)       :: real_scalar
    type(LocalProfiles)             :: p3

    p3 = p1*(1.d0/real_scalar)

end function lps_divide

function ff_add(p1, p2) result (p3)
    !+ Defines how to add two [[EMFields]] types
    type(EMFields), intent(in) :: p1,p2
    type(EMFields)             :: p3

    p3%br   = p1%br   + p2%br
    p3%bt   = p1%bt   + p2%bt
    p3%bz   = p1%bz   + p2%bz
    p3%er   = p1%er   + p2%er
    p3%et   = p1%et   + p2%et
    p3%ez   = p1%ez   + p2%ez

    p3%dbr_dr   = p1%dbr_dr + p2%dbr_dr
    p3%dbr_dz   = p1%dbr_dz + p2%dbr_dz
    p3%dbt_dr   = p1%dbt_dr + p2%dbt_dr
    p3%dbt_dz   = p1%dbt_dz + p2%dbt_dz
    p3%dbz_dr   = p1%dbz_dr + p2%dbz_dr
    p3%dbz_dz   = p1%dbz_dz + p2%dbz_dz

end function ff_add

function ff_subtract(p1, p2) result (p3)
    !+ Defines how to subtract two [[EMFields]] types
    type(EMFields), intent(in) :: p1,p2
    type(EMFields)             :: p3

    p3%br   = p1%br   - p2%br
    p3%bt   = p1%bt   - p2%bt
    p3%bz   = p1%bz   - p2%bz
    p3%er   = p1%er   - p2%er
    p3%et   = p1%et   - p2%et
    p3%ez   = p1%ez   - p2%ez

    p3%dbr_dr   = p1%dbr_dr - p2%dbr_dr
    p3%dbr_dz   = p1%dbr_dz - p2%dbr_dz
    p3%dbt_dr   = p1%dbt_dr - p2%dbt_dr
    p3%dbt_dz   = p1%dbt_dz - p2%dbt_dz
    p3%dbz_dr   = p1%dbz_dr - p2%dbz_dr
    p3%dbz_dz   = p1%dbz_dz - p2%dbz_dz

end function ff_subtract

function fs_multiply(p1, real_scalar) result (p3)
    !+ Defines how to multiply [[EMFields]] types by a scalar
    type(EMFields), intent(in) :: p1
    real(Float64), intent(in)  :: real_scalar
    type(EMFields)             :: p3

    p3%br   = p1%br   * real_scalar
    p3%bt   = p1%bt   * real_scalar
    p3%bz   = p1%bz   * real_scalar
    p3%er   = p1%er   * real_scalar
    p3%et   = p1%et   * real_scalar
    p3%ez   = p1%ez   * real_scalar

    p3%dbr_dr   = p1%dbr_dr * real_scalar
    p3%dbr_dz   = p1%dbr_dz * real_scalar
    p3%dbt_dr   = p1%dbt_dr * real_scalar
    p3%dbt_dz   = p1%dbt_dz * real_scalar
    p3%dbz_dr   = p1%dbz_dr * real_scalar
    p3%dbz_dz   = p1%dbz_dz * real_scalar

end function fs_multiply

function sf_multiply(real_scalar, p1) result (p3)
    !+ Defines how to multiply [[EMFields]] types by a scalar
    type(EMFields), intent(in) :: p1
    real(Float64), intent(in)  :: real_scalar
    type(EMFields)             :: p3

    p3 = p1*real_scalar

end function sf_multiply

function fs_divide(p1, real_scalar) result (p3)
    !+ Defines how to divide [[EMFields]] types by a scalar
    type(EMFields), intent(in) :: p1
    real(Float64), intent(in)  :: real_scalar
    type(EMFields)             :: p3

    p3 = p1*(1.d0/real_scalar)

end function fs_divide

function lflf_add(p1, p2) result (p3)
    !+ Defines how to add two [[LocalEMFields]] types
    type(LocalEMFields), intent(in) :: p1,p2
    type(LocalEMFields)             :: p3

    real(Float64), dimension(3) :: bfield,efield

    p3%pos    = p1%pos    + p2%pos
    p3%uvw    = p1%uvw    + p2%uvw
    p3%br     = p1%br     + p2%br
    p3%bt     = p1%bt     + p2%bt
    p3%bz     = p1%bz     + p2%bz
    p3%er     = p1%er     + p2%er
    p3%et     = p1%et     + p2%et
    p3%ez     = p1%ez     + p2%ez

    bfield = p1%b_abs*p1%b_norm + p2%b_abs*p2%b_norm
    p3%b_abs = norm2(bfield)
    if(p3%b_abs.gt.0.d0) then
        p3%b_norm = bfield/p3%b_abs
        call calc_perp_vectors(p3%b_norm,p3%a_norm,p3%c_norm)
    endif

    efield = p1%e_abs*p1%e_norm + p2%e_abs*p2%e_norm
    p3%e_abs = norm2(efield)
    if(p3%e_abs.gt.0.d0) p3%e_norm = efield/p3%e_abs

    p3%dbr_dr   = p1%dbr_dr + p2%dbr_dr
    p3%dbr_dz   = p1%dbr_dz + p2%dbr_dz
    p3%dbt_dr   = p1%dbt_dr + p2%dbt_dr
    p3%dbt_dz   = p1%dbt_dz + p2%dbt_dz
    p3%dbz_dr   = p1%dbz_dr + p2%dbz_dr
    p3%dbz_dz   = p1%dbz_dz + p2%dbz_dz

end function lflf_add

function lflf_subtract(p1, p2) result (p3)
    !+ Defines how to subtract two [[LocalEMFields]] types
    type(LocalEMFields), intent(in) :: p1,p2
    type(LocalEMFields)             :: p3

    real(Float64), dimension(3) :: bfield,efield

    p3%pos    = p1%pos    - p2%pos
    p3%uvw    = p1%uvw    - p2%uvw
    p3%br     = p1%br     - p2%br
    p3%bt     = p1%bt     - p2%bt
    p3%bz     = p1%bz     - p2%bz
    p3%er     = p1%er     - p2%er
    p3%et     = p1%et     - p2%et
    p3%ez     = p1%ez     - p2%ez

    bfield = p1%b_abs*p1%b_norm - p2%b_abs*p2%b_norm
    p3%b_abs = norm2(bfield)
    if(p3%b_abs.gt.0.d0) then
        p3%b_norm = bfield/p3%b_abs
        call calc_perp_vectors(p3%b_norm,p3%a_norm,p3%c_norm)
    endif

    efield = p1%e_abs*p1%e_norm - p2%e_abs*p2%e_norm
    p3%e_abs = norm2(efield)
    if(p3%e_abs.gt.0.d0) p3%e_norm = efield/p3%e_abs

    p3%dbr_dr   = p1%dbr_dr - p2%dbr_dr
    p3%dbr_dz   = p1%dbr_dz - p2%dbr_dz
    p3%dbt_dr   = p1%dbt_dr - p2%dbt_dr
    p3%dbt_dz   = p1%dbt_dz - p2%dbt_dz
    p3%dbz_dr   = p1%dbz_dr - p2%dbz_dr
    p3%dbz_dz   = p1%dbz_dz - p2%dbz_dz

end function lflf_subtract

function lfs_multiply(p1, real_scalar) result (p3)
    !+ Defines how to multiply [[LocalEMFields]] types by a scalar
    type(LocalEMFields), intent(in) :: p1
    real(Float64), intent(in)       :: real_scalar
    type(LocalEMFields)             :: p3

    p3%pos  = p1%pos  * real_scalar
    p3%uvw  = p1%uvw  * real_scalar
    p3%br   = p1%br   * real_scalar
    p3%bt   = p1%bt   * real_scalar
    p3%bz   = p1%bz   * real_scalar
    p3%er   = p1%er   * real_scalar
    p3%et   = p1%et   * real_scalar
    p3%ez   = p1%ez   * real_scalar
    p3%b_abs  = p1%b_abs  * real_scalar
    p3%e_abs  = p1%e_abs  * real_scalar
    p3%a_norm = p1%a_norm
    p3%b_norm = p1%b_norm
    p3%c_norm = p1%c_norm
    p3%e_norm = p1%e_norm

    p3%dbr_dr   = p1%dbr_dr * real_scalar
    p3%dbr_dz   = p1%dbr_dz * real_scalar
    p3%dbt_dr   = p1%dbt_dr * real_scalar
    p3%dbt_dz   = p1%dbt_dz * real_scalar
    p3%dbz_dr   = p1%dbz_dr * real_scalar
    p3%dbz_dz   = p1%dbz_dz * real_scalar

end function lfs_multiply

function slf_multiply(real_scalar, p1) result (p3)
    !+ Defines how to multiply [[LocalEMFields]] types by a scalar
    type(LocalEMFields), intent(in) :: p1
    real(Float64), intent(in)       :: real_scalar
    type(LocalEMFields)             :: p3

    p3 = p1*real_scalar

end function slf_multiply

function lfs_divide(p1, real_scalar) result (p3)
    !+ Defines how to divide [[LocalEMFields]] types by a scalar
    type(LocalEMFields), intent(in) :: p1
    real(Float64), intent(in)       :: real_scalar
    type(LocalEMFields)             :: p3

    p3 = p1*(1.d0/real_scalar)

end function lfs_divide

!============================================================================
!-------------------------------I/O Routines---------------------------------
!============================================================================
subroutine read_inputs
    !+ Reads input namelist file and stores the results into [[libfida:inputs]],
    !+ [[libfida:nbi]], and [[libfida:beam_grid]]
    character(charlim) :: runid,result_dir, tables_file
    character(charlim) :: distribution_file, equilibrium_file
    character(charlim) :: geometry_file, neutrals_file
    integer            :: pathlen, calc_neutron, seed
    integer            :: calc_brems, calc_dcx, calc_halo, calc_cold, calc_bes
    integer            :: calc_fida, calc_pfida, calc_npa, calc_pnpa
    integer            :: calc_birth,calc_fida_wght,calc_npa_wght
    integer            :: load_neutrals,verbose,flr,split
    integer(Int64)     :: n_fida,n_pfida,n_npa,n_pnpa,n_nbi,n_halo,n_dcx,n_birth
    integer(Int32)     :: shot,nlambda,ne_wght,np_wght,nphi_wght,nlambda_wght
    real(Float64)      :: time,lambdamin,lambdamax,emax_wght
    real(Float64)      :: lambdamin_wght,lambdamax_wght
    real(Float64)      :: ai,ab,pinj,einj,current_fractions(3)
    integer(Int32)     :: impurity_charge
    integer(Int32)     :: nx,ny,nz
    real(Float64)      :: xmin,xmax,ymin,ymax,zmin,zmax
    real(Float64)      :: alpha,beta,gamma,origin(3)
    logical            :: exis, error

    NAMELIST /fidasim_inputs/ result_dir, tables_file, distribution_file, &
        geometry_file, equilibrium_file, neutrals_file, shot, time, runid, &
        calc_brems, calc_dcx,calc_halo, calc_cold, calc_fida, calc_bes,&
        calc_pfida, calc_npa, calc_pnpa,calc_birth, seed, flr, split, &
        calc_fida_wght, calc_npa_wght, load_neutrals, verbose, &
        calc_neutron, n_fida, n_pfida, n_npa, n_pnpa, n_nbi, n_halo, n_dcx, n_birth, &
        ab, pinj, einj, current_fractions, ai, impurity_charge, &
        nx, ny, nz, xmin, xmax, ymin, ymax, zmin, zmax, &
        origin, alpha, beta, gamma, &
        ne_wght, np_wght, nphi_wght, &
        nlambda, lambdamin,lambdamax,emax_wght, &
        nlambda_wght,lambdamin_wght,lambdamax_wght

    inquire(file=namelist_file,exist=exis)
    if(.not.exis) then
        write(*,'(a,a)') 'READ_INPUTS: Input file does not exist: ', trim(namelist_file)
        stop
    endif

    ! variables that are not changed not be auto-initalized
    ! provide reasonable defaults here
    result_dir="."
    tables_file="."
    distribution_file="."
    geometry_file ="."
    equilibrium_file="."
    neutrals_file="."
    shot=0
    time=0
    runid="0"
    seed = -1
    calc_brems=0
    calc_bes=0
    calc_dcx=0
    calc_halo=0
    calc_cold=0
    calc_fida=0
    calc_pfida=0
    calc_npa=0
    calc_pnpa=0
    calc_birth=0
    flr=2
    split=1
    calc_fida_wght=0
    calc_npa_wght=0
    load_neutrals=0
    verbose=0
    calc_neutron=0
    n_fida=0
    n_pfida=0
    n_npa=0
    n_pnpa=0
    n_nbi=0
    n_halo=0
    n_dcx=0
    n_birth=0
    ab=0
    pinj=0
    einj=0
    current_fractions=0
    ai=0
    impurity_charge=0
    nx=0
    ny=0
    nz=0
    xmin=0
    xmax=0
    ymin=0
    ymax=0
    zmin=0
    zmax=0
    origin=0
    alpha=0
    beta=0
    gamma=0
    ne_wght=0
    np_wght=0
    nphi_wght=0
    nlambda=0
    lambdamin=0
    lambdamax=0
    emax_wght=0
    nlambda_wght=0
    lambdamin_wght=0
    lambdamax_wght=0

    open(13,file=namelist_file)
    read(13,NML=fidasim_inputs)
    close(13)

    !!General Information
    inputs%shot_number=shot
    inputs%time=time
    inputs%runid=runid
    inputs%result_dir=result_dir

    !!Input Files
    inputs%tables_file=tables_file
    inputs%geometry_file=geometry_file
    inputs%equilibrium_file=equilibrium_file
    inputs%distribution_file=distribution_file
    inputs%neutrals_file=neutrals_file

    !! RNG seed
    inputs%seed = seed
    if(inputs%seed.lt.0) inputs%seed = rng_seed()

    !!Simulation Switches
    if((calc_brems+calc_bes+calc_dcx+calc_halo+&
        calc_cold+calc_fida+calc_pfida).gt.0) then
        inputs%calc_spec=1
        inputs%tot_spectra=calc_brems+calc_bes+calc_dcx+calc_halo+&
                           calc_cold+calc_fida+calc_pfida
    else
        inputs%calc_spec=0
        inputs%tot_spectra=0
    endif

    inputs%calc_beam = 0
    if((calc_bes+calc_birth+calc_dcx+&
        calc_halo+calc_fida+calc_npa+&
        calc_fida_wght+calc_npa_wght).gt.0) then
        inputs%calc_nbi_dens=1
        inputs%calc_beam=1
    else
        inputs%calc_nbi_dens=0
    endif

    if((calc_dcx+calc_halo+calc_fida+calc_npa+&
        calc_fida_wght+calc_npa_wght).gt.0) then
        inputs%calc_dcx_dens=1
        inputs%calc_beam=1
    else
        inputs%calc_dcx_dens=0
    endif

    if((calc_halo+calc_fida+calc_npa+&
        calc_fida_wght+calc_npa_wght).gt.0) then
        inputs%calc_halo_dens=1
        inputs%calc_beam=1
    else
        inputs%calc_halo_dens=0
    endif

    inputs%calc_brems=calc_brems
    inputs%calc_bes=calc_bes
    inputs%calc_dcx=calc_dcx
    inputs%calc_halo=calc_halo
    inputs%calc_cold=calc_cold
    inputs%calc_fida=calc_fida
    inputs%calc_pfida=calc_pfida
    inputs%calc_npa=calc_npa
    inputs%calc_pnpa=calc_pnpa
    inputs%calc_birth=calc_birth
    inputs%calc_fida_wght=calc_fida_wght
    inputs%calc_npa_wght=calc_npa_wght
    inputs%calc_neutron=calc_neutron
    inputs%load_neutrals=load_neutrals
    inputs%verbose=verbose
    inputs%flr = flr
    inputs%split = split

    !!Monte Carlo Settings
    inputs%n_fida=max(10,n_fida)
    inputs%n_pfida=max(10,n_pfida)
    inputs%n_npa=max(10,n_npa)
    inputs%n_pnpa=max(10,n_pnpa)
    inputs%n_nbi=max(10,n_nbi)
    inputs%n_halo=max(10,n_halo)
    inputs%n_dcx=max(10,n_dcx)
    inputs%n_birth= max(1,nint(n_birth/real(n_nbi)))

    !!Plasma Settings
    inputs%ai=ai
    inputs%impurity_charge=impurity_charge

    !!Neutral Beam Settings
    inputs%ab=ab
    nbi%current_fractions=current_fractions
    nbi%einj=einj
    nbi%pinj=pinj

    !!Weight Function Settings
    inputs%ne_wght=ne_wght
    inputs%np_wght=np_wght
    inputs%nphi_wght=nphi_wght
    inputs%emax_wght=emax_wght
    inputs%nlambda_wght = nlambda_wght
    inputs%lambdamin_wght=lambdamin_wght
    inputs%lambdamax_wght=lambdamax_wght

    !!Wavelength Grid Settings
    inputs%nlambda=nlambda
    inputs%lambdamin=lambdamin
    inputs%lambdamax=lambdamax
    inputs%dlambda=(inputs%lambdamax-inputs%lambdamin)/inputs%nlambda

    !!Beam Grid Settings
    beam_grid%nx=nx
    beam_grid%ny=ny
    beam_grid%nz=nz
    beam_grid%xmin=xmin
    beam_grid%xmax=xmax
    beam_grid%ymin=ymin
    beam_grid%ymax=ymax
    beam_grid%zmin=zmin
    beam_grid%zmax=zmax
    beam_grid%alpha=alpha
    beam_grid%beta=beta
    beam_grid%gamma=gamma
    beam_grid%origin=origin

#ifdef _MPI
    if(my_rank().ne.0) inputs%verbose=0
#endif

    if(inputs%verbose.ge.1) then
        write(*,'(a)') "---- Shot settings ----"
        write(*,'(T2,"Shot: ",i8)') inputs%shot_number
        write(*,'(T2,"Time: ",i4," [ms]")') int(inputs%time*1.d3)
        write(*,'(T2,"Runid: ",a)') trim(adjustl(inputs%runid))
        write(*,*) ''
        write(*,'(a)') "---- Input files ----"
    endif

    error = .False.

    inquire(file=inputs%tables_file,exist=exis)
    if(exis) then
        if(inputs%verbose.ge.1) then
            write(*,'(T2,"Tables file: ",a)') trim(inputs%tables_file)
        endif
    else
        if(inputs%verbose.ge.0) then
            write(*,'(a,a)') 'READ_INPUTS: Tables file does not exist: ', &
                             trim(inputs%tables_file)
        endif
        error = .True.
    endif

    inquire(file=inputs%geometry_file,exist=exis)
    if(exis) then
        if(inputs%verbose.ge.1) then
            write(*,'(T2,"Geometry file: ",a)') trim(inputs%geometry_file)
        endif
    else
        if(inputs%verbose.ge.0) then
            write(*,'(a,a)') 'READ_INPUTS: Geometry file does not exist: ', &
                             trim(inputs%geometry_file)
        endif
        error = .True.
    endif

    inquire(file=inputs%equilibrium_file,exist=exis)
    if(exis) then
        if(inputs%verbose.ge.1) then
            write(*,'(T2,"Equilibrium file: ",a)') trim(inputs%equilibrium_file)
        endif
    else
        if(inputs%verbose.ge.0) then
            write(*,'(a,a)') 'READ_INPUTS: Equilibrium file does not exist: ', &
                              trim(inputs%equilibrium_file)
        endif
        error = .True.
    endif

    inquire(file=inputs%distribution_file,exist=exis)
    if(exis) then
        if(inputs%verbose.ge.1) then
            write(*,'(T2,"Distribution file: ",a)') trim(inputs%distribution_file)
        endif
    else
        if(inputs%verbose.ge.0) then
            write(*,'(a,a)') 'READ_INPUTS: Distribution file does not exist: ', &
                             trim(inputs%distribution_file)
        endif
        error = .True.
    endif

    pathlen = len_trim(inputs%result_dir)+len_trim(inputs%runid) + 20
    !+20 for suffixes and seperators e.g. /, _npa.h5, ...
    if(pathlen.gt.charlim) then
        if(inputs%verbose.ge.0) then
            write(*,'(a,i3,a,i3)') 'READ_INPUTS: Result directory path + runID use too many characters: ', &
                                   pathlen-20,'>', charlim-20
        endif
        error = .True.
    endif

    if(inputs%verbose.ge.1) then
        write(*,*) ''
    endif

    if(error) then
        stop
    endif

end subroutine read_inputs

subroutine make_beam_grid
    !+ Makes [[libfida:beam_grid] from user defined inputs
    integer(Int32) :: i, j, k, n
    real(Float64) :: dx, dy, dz, ri(3)
    logical :: inp

    allocate(beam_grid%xc(beam_grid%nx),  &
             beam_grid%yc(beam_grid%ny),  &
             beam_grid%zc(beam_grid%nz))

    dx = (beam_grid%xmax - beam_grid%xmin)/beam_grid%nx
    dy = (beam_grid%ymax - beam_grid%ymin)/beam_grid%ny
    dz = (beam_grid%zmax - beam_grid%zmin)/beam_grid%nz

    do i=1, beam_grid%nx
        beam_grid%xc(i) = beam_grid%xmin + (i-0.5)*dx
    enddo
    do i=1, beam_grid%ny
        beam_grid%yc(i) = beam_grid%ymin + (i-0.5)*dy
    enddo
    do i=1, beam_grid%nz
        beam_grid%zc(i) = beam_grid%zmin + (i-0.5)*dz
    enddo

    beam_grid%dr(1) = abs(beam_grid%xc(2)-beam_grid%xc(1))
    beam_grid%dr(2) = abs(beam_grid%yc(2)-beam_grid%yc(1))
    beam_grid%dr(3) = abs(beam_grid%zc(2)-beam_grid%zc(1))

    beam_grid%lwh(1) = abs(beam_grid%xc(beam_grid%nx) - beam_grid%xc(1)) + beam_grid%dr(1)
    beam_grid%lwh(2) = abs(beam_grid%yc(beam_grid%ny) - beam_grid%yc(1)) + beam_grid%dr(2)
    beam_grid%lwh(3) = abs(beam_grid%zc(beam_grid%nz) - beam_grid%zc(1)) + beam_grid%dr(3)

    beam_grid%volume = beam_grid%lwh(1)*beam_grid%lwh(2)*beam_grid%lwh(3)

    beam_grid%center(1) = (minval(beam_grid%xc) - 0.5*beam_grid%dr(1)) + 0.5*beam_grid%lwh(1)
    beam_grid%center(2) = (minval(beam_grid%yc) - 0.5*beam_grid%dr(2)) + 0.5*beam_grid%lwh(2)
    beam_grid%center(3) = (minval(beam_grid%zc) - 0.5*beam_grid%dr(3)) + 0.5*beam_grid%lwh(3)

    beam_grid%drmin  = minval(beam_grid%dr)
    beam_grid%dv     = beam_grid%dr(1)*beam_grid%dr(2)*beam_grid%dr(3)
    beam_grid%ntrack = beam_grid%nx+beam_grid%ny+beam_grid%nz
    beam_grid%ngrid  = beam_grid%nx*beam_grid%ny*beam_grid%nz

    beam_grid%dims(1) = beam_grid%nx
    beam_grid%dims(2) = beam_grid%ny
    beam_grid%dims(3) = beam_grid%nz

    call tb_zyx(beam_grid%alpha,beam_grid%beta,beam_grid%gamma, &
                beam_grid%basis, beam_grid%inv_basis)

    !! Check if beam grid is in the plasma
    n = 0
    do k=1,beam_grid%nz
        do j=1,beam_grid%ny
            do i=1,beam_grid%nx
                ri = [beam_grid%xc(i),beam_grid%yc(j), beam_grid%zc(k)]
                call in_plasma(ri, inp)
                if(inp) n = n + 1
            enddo
        enddo
    enddo

    if(inputs%verbose.ge.1) then
        write(*,'(a)') "---- Beam grid settings ----"
        write(*,'(T2,"Nx: ", i3)') beam_grid%nx
        write(*,'(T2,"Ny: ", i3)') beam_grid%ny
        write(*,'(T2,"Nz: ", i3)') beam_grid%nz
        write(*,'(T2,"dV: ", f5.2," [cm^3]")') beam_grid%dv
        write(*,'(T2,"alpha: ",f5.2," [rad]")') beam_grid%alpha
        write(*,'(T2,"beta:  ",f5.2," [rad]")') beam_grid%beta
        write(*,'(T2,"gamma: ",f5.2," [rad]")') beam_grid%gamma
        write(*,'(T2,"origin: [",f7.2,",",f7.2,",",f7.2,"] [cm]")') beam_grid%origin
        write(*,'(T2,"Number of cells in plasma: ",i8)') n
        write(*,*) ''
    endif

    if(n.le.(0.1*beam_grid%ngrid)) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "MAKE_BEAM_GRID: Beam grid definition is poorly defined. &
                            &Less than 10% of the beam grid cells fall within the plasma."
        endif
        stop
    endif

end subroutine make_beam_grid

subroutine make_passive_grid
    !+ Makes [[libfida:pass_grid] from user defined inputs
    real(Float64), dimension(3,spec_chords%nchan+npa_chords%nchan) :: r0_arr, v0_arr
    real(Float64), dimension(2,spec_chords%nchan+npa_chords%nchan) :: xy_enter, xy_exit
    logical, dimension(8+2*(spec_chords%nchan+npa_chords%nchan))   :: yle, ygt
    logical, dimension(spec_chords%nchan+npa_chords%nchan)         :: skip
    real(Float64), dimension(:), allocatable  :: xarr, yarr
    real(Float64), dimension(3,8) :: vertices_xyz, vertices_uvw
    real(Float64), dimension(2,3) :: extrema
    real(Float64), dimension(3,3) :: xyz_axis
    real(Float64), dimension(3)   :: r0, vi
    real(Float64), dimension(8)   :: xarr_beam_grid, yarr_beam_grid
    real(Float64) :: xmin, ymin, xmax, ymax, zmin, zmax, max_length
    real(Float64) :: dlength = 3.0 !cm
    integer :: i, iin, iout, dim_le, dim_gt, dim
    logical :: inp, phi_pos

    !! Get beam grid boundaries
    ! Convert vertices_xyz to vertices_uvw
    ! Note: vertices_xyz has the following coordinate definitions:
    ! 111 = 1, 222 = 2, 112 = 3, 211 = 4, 121 = 5, 212 = 6, 122 = 7, 221 = 8
    xmin = beam_grid%xmin ; xmax = beam_grid%xmax
    ymin = beam_grid%ymin ; ymax = beam_grid%ymax
    zmin = beam_grid%zmin ; zmax = beam_grid%zmax

    !Initialize minimum and maximum vertices
    vertices_xyz(1,1) = xmin   ; vertices_xyz(2,1) = ymin   ; vertices_xyz(3,1) = zmin
    vertices_xyz(1,2) = xmax   ; vertices_xyz(2,2) = ymax   ; vertices_xyz(3,2) = zmax

    !Initialize
    vertices_xyz(:,3) = vertices_xyz(:,1)
    vertices_xyz(:,4) = vertices_xyz(:,1)
    vertices_xyz(:,5) = vertices_xyz(:,1)
    !Update
    vertices_xyz(3,3) = zmax
    vertices_xyz(1,4) = xmax
    vertices_xyz(2,5) = ymax
    !Initialize
    vertices_xyz(:,7) = vertices_xyz(:,2)
    vertices_xyz(:,8) = vertices_xyz(:,2)
    vertices_xyz(:,6) = vertices_xyz(:,2)
    !Update
    vertices_xyz(1,7) = xmin
    vertices_xyz(3,8) = zmin
    vertices_xyz(2,6) = ymin

    do i=1, 8
        call xyz_to_uvw(vertices_xyz(:,i),vertices_uvw(:,i))
        xarr_beam_grid(i) = vertices_uvw(1,i)
        yarr_beam_grid(i) = vertices_uvw(2,i)
    enddo

    !! Next consider passive diagnostic extrema relative to the plasma
    if((inputs%calc_pfida.gt.0).and.(inputs%calc_pnpa.gt.0)) then
        do i=1,(spec_chords%nchan)
            r0_arr(:,i) = spec_chords%los(i)%lens_uvw
            v0_arr(:,i) = spec_chords%los(i)%axis_uvw
        enddo
        do i=1, npa_chords%nchan
            call xyz_to_uvw(npa_chords%det(i)%detector%origin, r0_arr(:,i+spec_chords%nchan))
            xyz_axis = npa_chords%det(i)%detector%basis
            v0_arr(:,i+spec_chords%nchan) = matmul(beam_grid%basis, xyz_axis(:,3))
        enddo
    else if(inputs%calc_pfida.gt.0) then
        do i=1, spec_chords%nchan
            r0_arr(:,i) = spec_chords%los(i)%lens_uvw
            v0_arr(:,i) = spec_chords%los(i)%axis_uvw
        enddo
    else !pnpa>=1 case
        do i=1, npa_chords%nchan
            call xyz_to_uvw(npa_chords%det(i)%detector%origin, r0_arr(:,i))
            xyz_axis = npa_chords%det(i)%detector%basis
            v0_arr(:,i) = matmul(beam_grid%basis, xyz_axis(:,3))
        enddo
    endif

    call get_plasma_extrema(r0_arr,v0_arr,extrema,xarr_beam_grid,yarr_beam_grid)

    !! Store the passive neutral grid
    pass_grid%dr = inter_grid%dr
    pass_grid%dz = inter_grid%dz
    pass_grid%nr = inter_grid%nr
    pass_grid%nz = inter_grid%nz
    allocate(pass_grid%r(pass_grid%nr), pass_grid%z(pass_grid%nz))
    pass_grid%r = inter_grid%r
    pass_grid%z = inter_grid%z
    pass_grid%da = pass_grid%dr*pass_grid%dz

    pass_grid%dphi = 2*pi/100 !TODO: make this user input
    pass_grid%nphi = int(ceiling((extrema(2,3)-extrema(1,3))/pass_grid%dphi))

    allocate(pass_grid%phi(pass_grid%nphi))
    do i=1, pass_grid%nphi
        pass_grid%phi(i) = extrema(1,3) + (i-1)*pass_grid%dphi
    enddo

    pass_grid%dv = pass_grid%dr*pass_grid%dphi*pass_grid%dz
    pass_grid%dims = [pass_grid%nr, pass_grid%nz, pass_grid%nphi]

    pass_grid%ntrack = pass_grid%nr+pass_grid%nz+pass_grid%nphi
    pass_grid%ngrid  = pass_grid%nr*pass_grid%nz*pass_grid%nphi

    if(inputs%verbose.ge.1) then
        write(*,'(a)') "---- Passive grid settings ----"
        write(*,'(T2,"Nr: ", i3)') pass_grid%nr
        write(*,'(T2,"Nz: ", i3)') pass_grid%nz
        write(*,'(T2,"Nphi: ", i3)') pass_grid%nphi
        write(*,'(T2,"R  range = [",f6.2,",",f6.2,"]")') &
              pass_grid%r(1),pass_grid%r(pass_grid%nr)
        write(*,'(T2,"Z  range = [",f7.2,",",f6.2,"]")') &
              pass_grid%z(1),pass_grid%z(pass_grid%nz)
        write(*,'(T2,"Phi  range = [",f5.2,",",f5.2,"]")') &
              pass_grid%phi(1),pass_grid%phi(pass_grid%nphi)
        write(*,'(T2,"dA: ", f5.2," [cm^3]")') pass_grid%da
        write(*,*) ''
    endif

end subroutine make_passive_grid

subroutine make_diagnostic_grids
    !+ Makes [[libfida:pass_grid] from user defined inputs, and stores the quantities in
    !+ [[libfida:spec_chords]] and [[libfida:npa_chords]]
    real(Float64), dimension(:,:,:), allocatable :: dlength
    type(LOSElement), dimension(:), allocatable :: los_elem
    type(ParticleTrack), dimension(:), allocatable :: tracks
    real(Float64) :: r0(3), v0(3), r_enter(3), r_exit(3), r0_cyl(3), ri(3)
    real(Float64), dimension(3,3) :: basis
    real(Float64), dimension(2) :: randomu
    real(Float64) :: theta, sqrt_rho, dl, length
    character(len=20) :: system = ''
    real(Float64), dimension(:), allocatable :: probs
    real(Float64), dimension(:,:), allocatable :: eff_rds
    real(Float64), parameter :: inv_4pi = (4.d0*pi)**(-1)
    real(Float64), dimension(3) :: eff_rd, rd, rd_d, r0_d
    real(Float64), dimension(3,3) :: inv_basis
    real(Float64), dimension(:),allocatable :: xd, yd
    type(LocalEMFields) :: fields
    real(Float64) :: total_prob, hh, hw, dprob, dx, dy, r, pitch
    integer :: ichan,k,id,ix,iy,d_index,nd,ind_d(2)
    integer :: i, j, ic, nc, ntrack, ind(3), ii, jj, kk
    integer :: error

    if(inputs%calc_pfida+inputs%calc_pnpa.gt.0) then
        if(inter_grid%nphi.gt.1) then
            pass_grid = inter_grid
        else
            call make_passive_grid()
        endif
    endif

    !! Spectral line-of-sight passive neutral grid intersection calculations
    allocate(spec_chords%cyl_inter(pass_grid%nr,pass_grid%nz,pass_grid%nphi))
    if(inputs%calc_pfida.gt.0) then
        allocate(tracks(pass_grid%ntrack))
        allocate(dlength(pass_grid%nr, &
                         pass_grid%nz, &
                         pass_grid%nphi) )
        pass_grid_chan_loop: do i=1,spec_chords%nchan
            r0 = spec_chords%los(i)%lens_uvw
            v0 = spec_chords%los(i)%axis_uvw
            v0 = v0/norm2(v0)
            call line_basis(r0,v0,basis)

            call grid_intersect(r0,v0,length,r_enter,r_exit,passive=.True.)
            if(length.le.0.d0) then
                if(inputs%verbose.ge.1) then
                    WRITE(*,'("Channel ",i5," missed the passive neutral grid or starts inside the plasma")') i
                endif
                cycle pass_grid_chan_loop
            endif

            if(spec_chords%los(i)%spot_size.le.0.d0) then
                nc = 1
            else
                nc = 100
            endif

            dlength = 0.d0
            !$OMP PARALLEL DO schedule(guided) private(ic,randomu,sqrt_rho,theta,r0, &
            !$OMP& length, r_enter, r_exit, j, tracks, ntrack, ind)
            do ic=1,nc
                ! Uniformally sample within spot size
                call randu(randomu)
                sqrt_rho = sqrt(randomu(1))
                theta = 2*pi*randomu(2)
                r0(1) = 0.d0
                r0(2) = spec_chords%los(i)%spot_size*sqrt_rho*cos(theta)
                r0(3) = spec_chords%los(i)%spot_size*sqrt_rho*sin(theta)
                r0 = matmul(basis,r0) + spec_chords%los(i)%lens_uvw

                call grid_intersect(r0,v0,length,r_enter,r_exit,passive=.True.)
                call track_cylindrical(r_enter, v0, tracks, ntrack)
                pass_grid_track_loop: do j=1, ntrack
                    ind = tracks(j)%ind
                    !inds can repeat so add rather than assign
                    !$OMP ATOMIC UPDATE
                    dlength(ind(1),ind(2),ind(3)) = &
                    dlength(ind(1),ind(2),ind(3)) + tracks(j)%time/real(nc) !time == distance
                    !$OMP END ATOMIC
                enddo pass_grid_track_loop
            enddo
            !$OMP END PARALLEL DO
            do kk=1,pass_grid%nphi
                do jj=1,pass_grid%nz
                    rloop: do ii=1, pass_grid%nr
                        if(dlength(ii,jj,kk).ne.0.d0) then
                            dl = dlength(ii,jj,kk)
                            nc = spec_chords%cyl_inter(ii,jj,kk)%nchan + 1
                            if(nc.eq.1) then
                                allocate(spec_chords%cyl_inter(ii,jj,kk)%los_elem(nc))
                                spec_chords%cyl_inter(ii,jj,kk)%los_elem(nc) = LOSElement(i, dl)
                            else
                                allocate(los_elem(nc))
                                los_elem(1:(nc-1)) = spec_chords%cyl_inter(ii,jj,kk)%los_elem
                                los_elem(nc) = LOSElement(i, dl)
                                deallocate(spec_chords%cyl_inter(ii,jj,kk)%los_elem)
                                call move_alloc(los_elem, spec_chords%cyl_inter(ii,jj,kk)%los_elem)
                            endif
                            spec_chords%cyl_inter(ii,jj,kk)%nchan = nc
                        endif
                    enddo rloop
                enddo
            enddo
        enddo pass_grid_chan_loop

        spec_chords%cyl_ncell = count(spec_chords%cyl_inter%nchan.gt.0)
        allocate(spec_chords%cyl_cell(spec_chords%cyl_ncell))

        nc = 0
        do ic=1,pass_grid%ngrid
            call ind2sub(pass_grid%dims,ic,ind)
            ii = ind(1) ; jj = ind(2) ; kk = ind(3)
            if(spec_chords%cyl_inter(ii,jj,kk)%nchan.gt.0) then
                nc = nc + 1
                spec_chords%cyl_cell(nc) = ic
            endif
        enddo
        deallocate(dlength, tracks)
    endif

    !! Spectral line-of-sight beam grid intersection calculations
    if((inputs%tot_spectra+inputs%calc_fida_wght-inputs%calc_pfida).gt.0) then
        allocate(dlength(beam_grid%nx, &
                         beam_grid%ny, &
                         beam_grid%nz) )
        allocate(tracks(beam_grid%ntrack))
        spec_chan_loop: do i=1,spec_chords%nchan
            r0 = spec_chords%los(i)%lens
            v0 = spec_chords%los(i)%axis
            v0 = v0/norm2(v0)
            call line_basis(r0,v0,basis)

            call grid_intersect(r0,v0,length,r_enter,r_exit)
            if(length.le.0.d0) then
                if(inputs%verbose.ge.1) then
                    WRITE(*,'("Channel ",i5," missed the beam grid")') i
                endif
                cycle spec_chan_loop
            endif

            if(spec_chords%los(i)%spot_size.le.0.d0) then
                nc = 1
            else
                nc = 100
            endif

            dlength = 0.d0
            !$OMP PARALLEL DO schedule(guided) private(ic,randomu,sqrt_rho,theta,r0, &
            !$OMP& length, r_enter, r_exit, j, tracks, ntrack, ind)
            do ic=1,nc
                ! Uniformally sample within spot size
                call randu(randomu)
                sqrt_rho = sqrt(randomu(1))
                theta = 2*pi*randomu(2)
                r0(1) = 0.d0
                r0(2) = spec_chords%los(i)%spot_size*sqrt_rho*cos(theta)
                r0(3) = spec_chords%los(i)%spot_size*sqrt_rho*sin(theta)
                r0 = matmul(basis,r0) + spec_chords%los(i)%lens

                call grid_intersect(r0, v0, length, r_enter, r_exit)
                call track(r_enter, v0, tracks, ntrack)
                track_loop: do j=1, ntrack
                    ind = tracks(j)%ind
                    !inds can repeat so add rather than assign
                    !$OMP ATOMIC UPDATE
                    dlength(ind(1),ind(2),ind(3)) = &
                    dlength(ind(1),ind(2),ind(3)) + tracks(j)%time/real(nc) !time == distance
                    !$OMP END ATOMIC
                enddo track_loop
            enddo
            !$OMP END PARALLEL DO
            do kk=1,beam_grid%nz
                do jj=1,beam_grid%ny
                    xloop: do ii=1, beam_grid%nx
                        if(dlength(ii,jj,kk).ne.0.d0) then
                            dl = dlength(ii,jj,kk)
                            nc = spec_chords%inter(ii,jj,kk)%nchan + 1
                            if(nc.eq.1) then
                                allocate(spec_chords%inter(ii,jj,kk)%los_elem(nc))
                                spec_chords%inter(ii,jj,kk)%los_elem(nc) = LOSElement(i, dl)
                            else
                                allocate(los_elem(nc))
                                los_elem(1:(nc-1)) = spec_chords%inter(ii,jj,kk)%los_elem
                                los_elem(nc) = LOSElement(i, dl)
                                deallocate(spec_chords%inter(ii,jj,kk)%los_elem)
                                call move_alloc(los_elem, spec_chords%inter(ii,jj,kk)%los_elem)
                            endif
                            spec_chords%inter(ii,jj,kk)%nchan = nc
                        endif
                    enddo xloop
                enddo
            enddo
        enddo spec_chan_loop

        spec_chords%ncell = count(spec_chords%inter%nchan.gt.0)
        allocate(spec_chords%cell(spec_chords%ncell))

        nc = 0
        do ic=1,beam_grid%ngrid
            call ind2sub(beam_grid%dims,ic,ind)
            ii = ind(1) ; jj = ind(2) ; kk = ind(3)
            if(spec_chords%inter(ii,jj,kk)%nchan.gt.0) then
                nc = nc + 1
                spec_chords%cell(nc) = ic
            endif
        enddo
    endif

    !! NPA probability calculations
    allocate(xd(50),yd(50))
    allocate(probs(beam_grid%ngrid))
    allocate(eff_rds(3,beam_grid%ngrid))
    allocate(npa_chords%phit(beam_grid%nx, &
                             beam_grid%ny, &
                             beam_grid%nz, &
                             npa_chords%nchan) )
    allocate(npa_chords%hit(beam_grid%nx, &
                            beam_grid%ny, &
                            beam_grid%nz) )
    npa_chords%hit = .False.

    npa_chan_loop: do ichan=1,npa_chords%nchan
        v0 = npa_chords%det(ichan)%aperture%origin - npa_chords%det(ichan)%detector%origin
        v0 = v0/norm2(v0)
        call grid_intersect(npa_chords%det(ichan)%detector%origin,v0,length,r0,r0_d)
        if(length.le.0.0) then
            if(inputs%verbose.ge.0) then
                WRITE(*,'("Channel ",i3," centerline missed the beam grid")') ichan
            endif
        endif

        if(inputs%calc_npa_wght.ge.1) then
            hw = npa_chords%det(ichan)%detector%hw
            hh = npa_chords%det(ichan)%detector%hh
            nd = size(xd)
            do i=1,nd
                xd(i) = -hw + 2*hw*(i-0.5)/real(nd)
                yd(i) = -hh + 2*hh*(i-0.5)/real(nd)
            enddo
            dx = abs(xd(2) - xd(1))
            dy = abs(yd(2) - yd(1))
            basis = npa_chords%det(ichan)%detector%basis
            inv_basis = npa_chords%det(ichan)%detector%inv_basis
            eff_rds = 0.d0
            probs = 0.d0
            ! For each grid point find the probability of hitting the detector given an isotropic source
            !$OMP PARALLEL DO schedule(guided) private(ic,i,j,k,ix,iy,total_prob,eff_rd,r0,r0_d, &
            !$OMP& rd_d,rd,d_index,v0,dprob,r,fields,id,ind_d,ind)
            do ic=istart,beam_grid%ngrid,istep
                call ind2sub(beam_grid%dims,ic,ind)
                i = ind(1) ; j = ind(2) ; k = ind(3)
                r0 = [beam_grid%xc(i),beam_grid%yc(j),beam_grid%zc(k)]
                r0_d = matmul(inv_basis,r0-npa_chords%det(ichan)%detector%origin)
                do id = 1, nd*nd
                    call ind2sub([nd,nd],id,ind_d)
                    ix = ind_d(1) ; iy = ind_d(2)
                    rd_d = [xd(ix),yd(iy),0.d0]
                    rd = matmul(basis,rd_d) + npa_chords%det(ichan)%detector%origin
                    v0 = rd - r0
                    d_index = 0
                    call hit_npa_detector(r0,v0,d_index,det=ichan)
                    if(d_index.ne.0) then
                        r = norm2(rd_d - r0_d)**2
                        dprob = (dx*dy) * inv_4pi * r0_d(3)/(r*sqrt(r))
                        eff_rds(:,ic) = eff_rds(:,ic) + dprob*rd
                        probs(ic) = probs(ic) + dprob
                    endif
                enddo
            enddo
            !$OMP END PARALLEL DO
#ifdef _MPI
            call parallel_sum(eff_rds)
            call parallel_sum(probs)
#endif
            do ic = 1, beam_grid%ngrid
                if(probs(ic).gt.0.0) then
                    call ind2sub(beam_grid%dims, ic, ind)
                    i = ind(1) ; j = ind(2) ; k = ind(3)
                    r0 = [beam_grid%xc(i),beam_grid%yc(j),beam_grid%zc(k)]
                    eff_rd = eff_rds(:,ic)/probs(ic)
                    call get_fields(fields,pos=r0)
                    v0 = (eff_rd - r0)/norm2(eff_rd - r0)
                    npa_chords%phit(i,j,k,ichan)%pitch = dot_product(fields%b_norm,v0)
                    npa_chords%phit(i,j,k,ichan)%p = probs(ic)
                    npa_chords%phit(i,j,k,ichan)%dir = v0
                    npa_chords%phit(i,j,k,ichan)%eff_rd = eff_rd
                    npa_chords%hit(i,j,k) = .True.
                endif
            enddo
            total_prob = sum(probs)
            if(total_prob.le.0.d0) then
                if(inputs%verbose.ge.0) then
                    WRITE(*,'("Channel ",i3," missed the beam grid")') ichan
                endif
                cycle npa_chan_loop
            endif
        endif
    enddo npa_chan_loop
    deallocate(probs,eff_rds,xd,yd)

end subroutine make_diagnostic_grids

subroutine read_beam
    !+ Reads neutral beam geometry and stores the quantities in [[libfida:nbi]]
    integer(HID_T) :: fid, gid
    integer(HSIZE_T), dimension(1) :: dims

    real(Float64), dimension(3) ::uvw_src, uvw_axis, pos
    real(Float64) :: dis
    logical :: path_valid
    integer :: error

    !!Initialize HDF5 interface
    call h5open_f(error)

    !!Open HDF5 file
    call h5fopen_f(inputs%geometry_file, H5F_ACC_RDONLY_F, fid, error)

    !!Check if SPEC group exists
    call h5ltpath_valid_f(fid, "/nbi", .True., path_valid, error)
    if(.not.path_valid) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'READ_BEAM: NBI geometry is not in the geometry file'
        endif
        stop
    endif

    !!Open NBI group
    call h5gopen_f(fid, "/nbi", gid, error)

    !!Read in beam definitions
    call h5ltread_dataset_string_f(gid, "/nbi/name",nbi%name, error)
    dims(1) = 3
    call h5ltread_dataset_double_f(gid, "/nbi/src", uvw_src, dims, error)
    call h5ltread_dataset_double_f(gid, "/nbi/axis", uvw_axis, dims, error)
    call h5ltread_dataset_double_f(gid, "/nbi/divy", nbi%divy, dims, error)
    call h5ltread_dataset_double_f(gid, "/nbi/divz", nbi%divz, dims, error)
    call h5ltread_dataset_int_scalar_f(gid, "/nbi/shape", nbi%shape, error)
    call h5ltread_dataset_double_scalar_f(gid, "/nbi/focy", nbi%focy, error)
    call h5ltread_dataset_double_scalar_f(gid, "/nbi/focz", nbi%focz, error)
    call h5ltread_dataset_double_scalar_f(gid, "/nbi/widy", nbi%widy, error)
    call h5ltread_dataset_double_scalar_f(gid, "/nbi/widz", nbi%widz, error)

    !!Read in aperture definitions
    !! Check for naperture for compatibility with old runs
    call h5ltpath_valid_f(gid, "/nbi/naperture", .True., path_valid, error)
    if(path_valid) then
        call h5ltread_dataset_int_scalar_f(gid,"/nbi/naperture",nbi%naperture, error)
    else
        nbi%naperture = 0
    endif
    if(nbi%naperture.gt.0) then
        allocate(nbi%ashape(nbi%naperture), nbi%adist(nbi%naperture), &
                 nbi%awidy(nbi%naperture), nbi%awidz(nbi%naperture),  &
                 nbi%aoffy(nbi%naperture), nbi%aoffz(nbi%naperture)   )

        dims(1) = nbi%naperture
        call h5ltread_dataset_int_f(gid, "/nbi/ashape", nbi%ashape, dims, error)
        call h5ltread_dataset_double_f(gid, "/nbi/awidy", nbi%awidy, dims, error)
        call h5ltread_dataset_double_f(gid, "/nbi/awidz", nbi%awidz, dims, error)
        call h5ltread_dataset_double_f(gid, "/nbi/aoffy", nbi%aoffy, dims, error)
        call h5ltread_dataset_double_f(gid, "/nbi/aoffz", nbi%aoffz, dims, error)
        call h5ltread_dataset_double_f(gid, "/nbi/adist", nbi%adist, dims, error)
    endif

    !!Close NBI group
    call h5gclose_f(gid, error)

    !!Close file id
    call h5fclose_f(fid, error)

    !!Close HDF5 interface
    call h5close_f(error)

    !!Convert to beam grid coordinates
    call uvw_to_xyz(uvw_src,nbi%src)
    nbi%axis = matmul(beam_grid%inv_basis,uvw_axis)

    nbi%vinj=sqrt(2.d0*nbi%einj*1.d3 *e0/(inputs%ab*mass_u))*1.d2 !! [cm/s]
    pos = nbi%src + 200.0*nbi%axis
    dis = sqrt(sum((pos - nbi%src)**2))
    nbi%beta = asin((nbi%src(3) - pos(3))/dis)
    nbi%alpha = atan2(pos(2)-nbi%src(2),pos(1)-nbi%src(1))

    call tb_zyx(nbi%alpha,nbi%beta,0.d0,nbi%basis,nbi%inv_basis)

    if(inputs%verbose.ge.1) then
        write(*,'(a)') '---- Neutral beam settings ----'
        write(*,'(T2,"Beam: ",a)') nbi%name
        write(*,'(T2,"Power:   ",f5.2," [MW]")') nbi%pinj
        write(*,'(T2,"Voltage: ",f6.2," [keV]")') nbi%einj
        write(*,*) ''
    endif

end subroutine read_beam

subroutine read_chords
    !+ Reads the spectral geometry and stores the quantities in [[libfida:spec_chords]]
    integer(HID_T) :: fid, gid
    integer(HSIZE_T), dimension(2) :: dims
    logical :: path_valid

    real(Float64), dimension(:,:), allocatable :: lenses
    real(Float64), dimension(:,:), allocatable :: axes
    real(Float64) :: xyz_lens(3), xyz_axis(3)
    character(len=20) :: system = ''

    integer :: i
    integer :: error

    if(inputs%verbose.ge.1) then
        write(*,'(a)') '---- FIDA/BES settings ----'
    endif

    !!Initialize HDF5 interface
    call h5open_f(error)

    !!Open HDF5 file
    call h5fopen_f(inputs%geometry_file, H5F_ACC_RDONLY_F, fid, error)

    !!Check if SPEC group exists
    call h5ltpath_valid_f(fid, "/spec", .True., path_valid, error)
    if(.not.path_valid) then
        if(inputs%verbose.ge.1) then
            write(*,'(a)') 'FIDA/BES geometry is not in the geometry file'
            write(*,'(a)') 'Continuing without spectral diagnostics'
        endif
        inputs%calc_spec = 0
        inputs%tot_spectra=0
        inputs%calc_fida = 0
        inputs%calc_pfida = 0
        inputs%calc_bes = 0
        inputs%calc_dcx = 0
        inputs%calc_halo = 0
        inputs%calc_cold = 0
        inputs%calc_brems = 0
        inputs%calc_fida_wght = 0
        call h5fclose_f(fid, error)
        call h5close_f(error)
        return
    endif

    !!Open SPEC group
    call h5gopen_f(fid, "/spec", gid, error)

    call h5ltread_dataset_string_f(gid, "/spec/system", system, error)
    call h5ltread_dataset_int_scalar_f(gid, "/spec/nchan", spec_chords%nchan, error)

    allocate(lenses(3, spec_chords%nchan))
    allocate(axes(3, spec_chords%nchan))
    allocate(spec_chords%los(spec_chords%nchan))
    allocate(spec_chords%radius(spec_chords%nchan))

    dims = [3,spec_chords%nchan]
    call h5ltread_dataset_double_f(gid, "/spec/lens", lenses, dims, error)
    call h5ltread_dataset_double_f(gid, "/spec/axis", axes, dims, error)
    call h5ltread_dataset_double_f(gid, "/spec/spot_size", spec_chords%los%spot_size, dims(2:2), error)
    call h5ltread_dataset_double_f(gid, "/spec/sigma_pi", spec_chords%los%sigma_pi, dims(2:2), error)
    call h5ltread_dataset_double_f(gid, "/spec/radius", spec_chords%radius, dims(2:2), error)

    !!Close SPEC group
    call h5gclose_f(gid, error)

    !!Close file id
    call h5fclose_f(fid, error)

    !!Close HDF5 interface
    call h5close_f(error)

    chan_loop: do i=1,spec_chords%nchan
        call uvw_to_xyz(lenses(:,i), xyz_lens)
        xyz_axis = matmul(beam_grid%inv_basis, axes(:,i))
        spec_chords%los(i)%lens = xyz_lens
        spec_chords%los(i)%axis = xyz_axis
        spec_chords%los(i)%lens_uvw = lenses(:,i)
        spec_chords%los(i)%axis_uvw = axes(:,i)
    enddo chan_loop

    if(inputs%verbose.ge.1) then
        write(*,'(T2,"FIDA/BES System: ",a)') trim(adjustl(system))
        write(*,'(T2,"Number of channels: ",i5)') spec_chords%nchan
        write(*,*) ''
    endif

    deallocate(lenses,axes)

end subroutine read_chords

subroutine read_npa
    !+ Reads the NPA geometry and stores the quantities in [[libfida:npa_chords]]
    integer(HID_T) :: fid, gid
    integer(HSIZE_T), dimension(2) :: dims
    logical :: path_valid

    real(Float64), dimension(:,:), allocatable :: a_tedge,a_redge,a_cent
    real(Float64), dimension(:,:), allocatable :: d_tedge,d_redge,d_cent
    character(len=20) :: system = ''

    real(Float64), dimension(3) :: xyz_a_tedge,xyz_a_redge,xyz_a_cent
    real(Float64), dimension(3) :: xyz_d_tedge,xyz_d_redge,xyz_d_cent
    real(Float64), dimension(3,3) :: basis, inv_basis
    real(Float64) :: hh, hw
    integer :: ichan
    integer :: error

    !!Initialize HDF5 interface
    call h5open_f(error)

    !!Open HDF5 file
    call h5fopen_f(inputs%geometry_file, H5F_ACC_RDWR_F, fid, error)

    !!Check if NPA group exists
    call h5ltpath_valid_f(fid, "/npa", .True., path_valid, error)
    if(.not.path_valid) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'NPA geometry is not in the geometry file'
            write(*,'(a)') 'Continuing without NPA diagnostics'
        endif
        inputs%calc_npa = 0
        inputs%calc_pnpa = 0
        inputs%calc_npa_wght = 0
        call h5fclose_f(fid, error)
        call h5close_f(error)
        return
    endif

    !!Open NPA group
    call h5gopen_f(fid, "/npa", gid, error)

    call h5ltread_dataset_string_f(gid, "/npa/system", system, error)
    call h5ltread_dataset_int_scalar_f(gid, "/npa/nchan", npa_chords%nchan, error)

    if(inputs%verbose.ge.1) then
        write(*,'(a)') "---- NPA settings ----"
        write(*,'(T2,"NPA System: ", a)') trim(adjustl(system))
        write(*,'(T2,"Number of channels: ",i3)') npa_chords%nchan
    endif

    allocate(a_tedge(3, npa_chords%nchan))
    allocate(a_redge(3, npa_chords%nchan))
    allocate(a_cent(3,  npa_chords%nchan))
    allocate(d_tedge(3, npa_chords%nchan))
    allocate(d_redge(3, npa_chords%nchan))
    allocate(d_cent(3,  npa_chords%nchan))
    allocate(npa_chords%radius(npa_chords%nchan))
    allocate(npa_chords%det(npa_chords%nchan))

    dims = [3,spec_chords%nchan]
    call h5ltread_dataset_double_f(gid,"/npa/radius", npa_chords%radius, dims(2:2), error)
    call h5ltread_dataset_int_f(gid, "/npa/a_shape", npa_chords%det%aperture%shape, dims(2:2), error)
    call h5ltread_dataset_double_f(gid, "/npa/a_tedge", a_tedge, dims, error)
    call h5ltread_dataset_double_f(gid, "/npa/a_redge", a_redge, dims, error)
    call h5ltread_dataset_double_f(gid, "/npa/a_cent",  a_cent, dims, error)

    call h5ltread_dataset_int_f(gid, "/npa/d_shape", npa_chords%det%detector%shape, dims(2:2), error)
    call h5ltread_dataset_double_f(gid, "/npa/d_tedge", d_tedge, dims, error)
    call h5ltread_dataset_double_f(gid, "/npa/d_redge", d_redge, dims, error)
    call h5ltread_dataset_double_f(gid, "/npa/d_cent",  d_cent, dims, error)

    !!Close NPA group
    call h5gclose_f(gid, error)

    !!Close file id
    call h5fclose_f(fid, error)

    !!Close HDF5 interface
    call h5close_f(error)

    chan_loop: do ichan=1,npa_chords%nchan
        ! Convert to beam grid coordinates
        call uvw_to_xyz(a_cent(:,ichan), xyz_a_cent)
        call uvw_to_xyz(a_redge(:,ichan),xyz_a_redge)
        call uvw_to_xyz(a_tedge(:,ichan),xyz_a_tedge)
        call uvw_to_xyz(d_cent(:,ichan), xyz_d_cent)
        call uvw_to_xyz(d_redge(:,ichan),xyz_d_redge)
        call uvw_to_xyz(d_tedge(:,ichan),xyz_d_tedge)

        ! Define detector/aperture hh/hw
        npa_chords%det(ichan)%detector%hw = norm2(xyz_d_redge - xyz_d_cent)
        npa_chords%det(ichan)%aperture%hw = norm2(xyz_a_redge - xyz_a_cent)

        npa_chords%det(ichan)%detector%hh = norm2(xyz_d_tedge - xyz_d_cent)
        npa_chords%det(ichan)%aperture%hh = norm2(xyz_a_tedge - xyz_a_cent)

        ! Define detector/aperture origin
        npa_chords%det(ichan)%detector%origin = xyz_d_cent
        npa_chords%det(ichan)%aperture%origin = xyz_a_cent

        ! Define detector/aperture basis
        call plane_basis(xyz_d_cent, xyz_d_redge, xyz_d_tedge, &
             npa_chords%det(ichan)%detector%basis, &
             npa_chords%det(ichan)%detector%inv_basis)
        call plane_basis(xyz_a_cent, xyz_a_redge, xyz_a_tedge, &
             npa_chords%det(ichan)%aperture%basis, &
             npa_chords%det(ichan)%aperture%inv_basis)
    enddo chan_loop

    if(inputs%verbose.ge.1) write(*,'(50X,a)') ""

    deallocate(a_cent,a_redge,a_tedge)
    deallocate(d_cent,d_redge,d_tedge)

end subroutine read_npa

subroutine read_equilibrium
    !+ Reads in the interpolation grid, plasma parameters, and fields
    !+ and stores the quantities in [[libfida:inter_grid]] and [[libfida:equil]]
    integer(HID_T) :: fid, gid
    integer(HSIZE_T), dimension(3) :: dims

    integer :: impc, ic, ir, iz, iphi, it, ind(3), i
    type(LocalProfiles) :: plasma
    real(Float64) :: photons
    real(Float64), dimension(nlevs) :: rates, denn, rates_avg
    real(Float64), dimension(3) :: vi, random3
    integer :: error
    integer :: n = 50
    logical :: path_valid

    integer, dimension(:,:,:), allocatable :: p_mask, f_mask
    real(Float64), dimension(:,:,:), allocatable :: denn3d

    !!Initialize HDF5 interface
    call h5open_f(error)

    !!Open HDF5 file
    call h5fopen_f(inputs%equilibrium_file, H5F_ACC_RDONLY_F, fid, error)

    !!Open PLASMA group
    call h5gopen_f(fid, "/plasma", gid, error)

    !!Read in interpolation grid
    call h5ltread_dataset_int_scalar_f(gid, "/plasma/nr", inter_grid%nr, error)
    call h5ltread_dataset_int_scalar_f(gid, "/plasma/nz", inter_grid%nz, error)
    call h5ltpath_valid_f(gid, "/plasma/nphi", .True., path_valid, error)
    if(path_valid) then
        call h5ltread_dataset_int_scalar_f(gid, "/plasma/nphi", inter_grid%nphi, error)
    else
        inter_grid%nphi=1
    endif

    inter_grid%dims = [inter_grid%nr, inter_grid%nz, inter_grid%nphi]

    allocate(inter_grid%r(inter_grid%nr),inter_grid%z(inter_grid%nz),inter_grid%phi(inter_grid%nphi))
    allocate(p_mask(inter_grid%nr,inter_grid%nz,inter_grid%nphi))
    allocate(f_mask(inter_grid%nr,inter_grid%nz,inter_grid%nphi))
    allocate(denn3d(inter_grid%nr,inter_grid%nz,inter_grid%nphi))

    dims = [inter_grid%nr, inter_grid%nz, inter_grid%nphi]

    call h5ltread_dataset_double_f(gid, "/plasma/r", inter_grid%r, dims(1:1), error)
    call h5ltread_dataset_double_f(gid, "/plasma/z", inter_grid%z, dims(2:2), error)
    if(path_valid) then
        call h5ltread_dataset_double_f(gid, "/plasma/phi", inter_grid%phi, dims(3:3), error)
    else
        inter_grid%phi=0.d0
    endif

    inter_grid%dr = abs(inter_grid%r(2)-inter_grid%r(1))
    inter_grid%dz = abs(inter_grid%z(2)-inter_grid%z(1))
    inter_grid%da = inter_grid%dr*inter_grid%dz
    if (inter_grid%nphi .eq. 1) then
        inter_grid%dphi = 2*pi
    else
        inter_grid%dphi = abs(inter_grid%phi(2)-inter_grid%phi(1))
    endif
    inter_grid%dv = inter_grid%dr*inter_grid%dphi*inter_grid%dz

    inter_grid%ntrack = inter_grid%nr+inter_grid%nz+inter_grid%nphi
    inter_grid%ngrid  = inter_grid%nr*inter_grid%nz*inter_grid%nphi

    if(inputs%verbose.ge.1) then
        write(*,'(a)') '---- Interpolation grid settings ----'
        write(*,'(T2,"Nr: ",i3)') inter_grid%nr
        write(*,'(T2,"Nz: ",i3)') inter_grid%nz
        if(inter_grid%nphi.gt.1) then
            write(*,'(T2,"Nphi: ",i3)') inter_grid%nphi
        endif
        write(*,'(T2,"dA: ", f5.2," [cm^2]")') inter_grid%da
        write(*,*) ''
    endif

    !!Read in plasma parameters
    allocate(equil%plasma(inter_grid%nr,inter_grid%nz,inter_grid%nphi))

    call h5ltread_dataset_double_f(gid, "/plasma/dene", equil%plasma%dene, dims, error)
    call h5ltread_dataset_double_f(gid, "/plasma/te", equil%plasma%te, dims, error)
    call h5ltread_dataset_double_f(gid, "/plasma/ti", equil%plasma%ti, dims, error)
    call h5ltread_dataset_double_f(gid, "/plasma/zeff", equil%plasma%zeff, dims, error)
    call h5ltread_dataset_double_f(gid, "/plasma/vr", equil%plasma%vr, dims, error)
    call h5ltread_dataset_double_f(gid, "/plasma/vt", equil%plasma%vt, dims, error)
    call h5ltread_dataset_double_f(gid, "/plasma/vz", equil%plasma%vz, dims, error)
    call h5ltread_dataset_int_f(gid, "/plasma/mask", p_mask, dims,error)

    impc = inputs%impurity_charge
    where(equil%plasma%zeff.lt.1.0)
        equil%plasma%zeff = 1
    endwhere

    where(equil%plasma%zeff.gt.impc)
        equil%plasma%zeff = impc
    endwhere

    where(equil%plasma%dene.lt.0.0)
        equil%plasma%dene = 0.0
    endwhere

    where(equil%plasma%te.lt.0.0)
        equil%plasma%te = 0.0
    endwhere

    where(equil%plasma%ti.lt.0.0)
        equil%plasma%ti = 0.0
    endwhere

    equil%plasma%denimp = ((equil%plasma%zeff-1.d0)/(impc*(impc-1.d0)))*equil%plasma%dene
    equil%plasma%denp = equil%plasma%dene - impc*equil%plasma%denimp

    call h5ltpath_valid_f(fid, "/plasma/denn", .True., path_valid, error)
    if(path_valid) then
        call h5ltread_dataset_double_f(gid, "/plasma/denn", denn3d, dims, error)
        where(denn3d.lt.0.0)
            denn3d = 0.0
        endwhere
    else
        if((inputs%calc_pnpa + inputs%calc_pfida + inputs%calc_cold).gt.0) then
            if(inputs%verbose.ge.0) then
                write(*,'(a)') "READ_EQUILIBRIUM: Cold neutral density was not provided"
                write(*,'(a)') "Continuing without passive calculations"
            endif
        endif
        inputs%calc_pnpa = 0
        inputs%calc_pfida = 0
        inputs%calc_cold = 0
    endif

    loop_over_cells: do ic=1, inter_grid%nr*inter_grid%nz*inter_grid%nphi
        call ind2sub(inter_grid%dims,ic,ind)
        ir = ind(1) ; iz = ind(2) ; iphi = ind(3)
        if(p_mask(ir,iz,iphi).lt.0.5) cycle loop_over_cells
        if(denn3d(ir,iz,iphi).le.0.0) cycle loop_over_cells
        plasma = equil%plasma(ir,iz,iphi)
        plasma%vrot = [plasma%vr, plasma%vt, plasma%vz]
        plasma%in_plasma = .True.
        rates_avg = 0.0
        do it=1,n
            rates = 0.0
            rates(1) = 1.d19
            call randn(random3)
            vi = plasma%vrot + sqrt(plasma%ti*0.5/(v2_to_E_per_amu*inputs%ai))*random3
            call colrad(plasma, thermal_ion, vi, 1.0d-7, rates, denn, photons)
            rates_avg = rates_avg + rates/n
        enddo
        if(sum(rates_avg).le.0.0) cycle loop_over_cells
        equil%plasma(ir,iz,iphi)%denn = denn3d(ir,iz,iphi)*(rates_avg)/sum(rates_avg)
    enddo loop_over_cells

    !!Close PLASMA group
    call h5gclose_f(gid, error)

    !!Open FIELDS group
    call h5gopen_f(fid, "/fields", gid, error)

    allocate(equil%fields(inter_grid%nr,inter_grid%nz,inter_grid%nphi))

    !!Read in electromagnetic fields
    call h5ltread_dataset_double_f(gid, "/fields/br", equil%fields%br, dims, error)
    call h5ltread_dataset_double_f(gid, "/fields/bt", equil%fields%bt, dims, error)
    call h5ltread_dataset_double_f(gid, "/fields/bz", equil%fields%bz, dims, error)
    call h5ltread_dataset_double_f(gid, "/fields/er", equil%fields%er, dims, error)
    call h5ltread_dataset_double_f(gid, "/fields/et", equil%fields%et, dims, error)
    call h5ltread_dataset_double_f(gid, "/fields/ez", equil%fields%ez, dims, error)
    call h5ltread_dataset_int_f(gid, "/fields/mask", f_mask, dims,error)

    !!Calculate B field derivatives
    call deriv(inter_grid%r, inter_grid%z, inter_grid%phi, equil%fields%br, &
        equil%fields%dbr_dr, equil%fields%dbr_dz, equil%fields%dbr_dphi)
    call deriv(inter_grid%r, inter_grid%z, inter_grid%phi, equil%fields%bt, &
        equil%fields%dbt_dr, equil%fields%dbt_dz, equil%fields%dbt_dphi)
    call deriv(inter_grid%r, inter_grid%z, inter_grid%phi, equil%fields%bz, &
        equil%fields%dbz_dr, equil%fields%dbz_dz, equil%fields%dbz_dphi)

    !!Close FIELDS group
    call h5gclose_f(gid, error)

    !!Close file
    call h5fclose_f(fid, error)

    !!Close HDF5 interface
    call h5close_f(error)

    allocate(equil%mask(inter_grid%nr,inter_grid%nz,inter_grid%nphi))
    equil%mask = 0.d0
    where ((p_mask.eq.1).and.(f_mask.eq.1)) equil%mask = 1.d0
    if (sum(equil%mask).le.0.d0) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "READ_EQUILIBRIUM: Plasma and/or fields are not well defined anywhere"
        endif
        stop
    endif

end subroutine read_equilibrium

subroutine read_f(fid, error)
    !+ Reads in the fast-ion distribution function and stores the quantities in [[libfida:fbm]]
    integer(HID_T), intent(inout) :: fid
        !+ HDF5 file ID
    integer, intent(out)          :: error
        !+ Error code

    integer(HSIZE_T), dimension(5) :: dims
    real(Float64) :: denp_tot
    integer :: ir
    logical :: path_valid

    if(inputs%verbose.ge.1) then
        write(*,'(a)') '---- Fast-ion distribution settings ----'
    endif

    call h5ltread_dataset_int_scalar_f(fid,"/nenergy", fbm%nenergy, error)
    call h5ltread_dataset_int_scalar_f(fid,"/npitch", fbm%npitch, error)
    call h5ltread_dataset_int_scalar_f(fid,"/nr", fbm%nr, error)
    call h5ltread_dataset_int_scalar_f(fid,"/nz", fbm%nz, error)
    call h5ltpath_valid_f(fid, "/nphi", .True., path_valid, error)
    if(path_valid) then
        call h5ltread_dataset_int_scalar_f(fid,"/nphi", fbm%nphi, error)
    else
        fbm%nphi=1
    endif

    if(((fbm%nr.ne.inter_grid%nr).or.(fbm%nz.ne.inter_grid%nz)).or.(fbm%nphi.ne.inter_grid%nphi)) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "READ_F: Distribution file has incompatable grid dimensions"
        endif
        stop
    endif

    if (fbm%nphi .eq. 1) then
        allocate(fbm%energy(fbm%nenergy), fbm%pitch(fbm%npitch), fbm%r(fbm%nr), fbm%z(fbm%nz), fbm%phi(1))
        allocate(fbm%denf(fbm%nr, fbm%nz,1))
        allocate(fbm%f(fbm%nenergy, fbm%npitch, fbm%nr, fbm%nz,1))
    else
        allocate(fbm%energy(fbm%nenergy), fbm%pitch(fbm%npitch), fbm%r(fbm%nr), fbm%z(fbm%nz), fbm%phi(fbm%nphi))
        allocate(fbm%denf(fbm%nr, fbm%nz, fbm%nphi))
        allocate(fbm%f(fbm%nenergy, fbm%npitch, fbm%nr, fbm%nz, fbm%nphi))
    endif

    if (fbm%nphi .eq. 1) then
        dims = [fbm%nenergy, fbm%npitch, fbm%nr, fbm%nz, 1]
        call h5ltread_dataset_double_f(fid, "/denf",fbm%denf, dims(3:4), error)
        call h5ltread_dataset_double_f(fid, "/f", fbm%f, dims(1:4), error)
    else
        dims = [fbm%nenergy, fbm%npitch, fbm%nr, fbm%nz, fbm%nphi]
        call h5ltread_dataset_double_f(fid, "/denf",fbm%denf, dims(3:5), error)
        call h5ltread_dataset_double_f(fid, "/f", fbm%f, dims(1:5), error)
    endif
    call h5ltread_dataset_double_f(fid, "/energy", fbm%energy, dims(1:1), error)
    call h5ltread_dataset_double_f(fid, "/pitch", fbm%pitch, dims(2:2), error)
    call h5ltread_dataset_double_f(fid, "/r", fbm%r, dims(3:3), error)
    call h5ltread_dataset_double_f(fid, "/z", fbm%z, dims(4:4), error)
    call h5ltpath_valid_f(fid, "/phi", .True., path_valid, error)
    if(path_valid) then
        call h5ltread_dataset_double_f(fid, "/phi", fbm%phi, dims(5:5), error)
    else
        fbm%phi=0.d0
    endif

    equil%plasma%denf = fbm%denf

    fbm%dE = abs(fbm%energy(2) - fbm%energy(1))
    fbm%dp = abs(fbm%pitch(2) - fbm%pitch(1))
    fbm%dr = abs(fbm%r(2) - fbm%r(1))
    fbm%dz = abs(fbm%z(2) - fbm%z(1))
    if (fbm%nphi .eq. 1) then
        fbm%dphi = 2*pi
    else
        fbm%dphi = abs(fbm%phi(2)-fbm%phi(1))
    endif

    fbm%emin = minval(fbm%energy,1)
    fbm%emax = maxval(fbm%energy,1)
    fbm%e_range = fbm%emax - fbm%emin
    fbm%pmin = minval(fbm%pitch,1)
    fbm%pmax = maxval(fbm%pitch,1)
    fbm%p_range = fbm%pmax - fbm%pmin
    fbm%rmin = minval(fbm%r,1)
    fbm%rmax = maxval(fbm%r,1)
    fbm%r_range = fbm%rmax - fbm%rmin
    fbm%zmin = minval(fbm%z,1)
    fbm%zmax = maxval(fbm%z,1)
    fbm%z_range = fbm%zmax - fbm%zmin
    fbm%phimin = minval(fbm%phi,1)
    fbm%phimax = maxval(fbm%phi,1)
    fbm%phi_range = fbm%phimax - fbm%phimin

    denp_tot = 0.0
    do ir=1,fbm%nr
        fbm%n_tot = fbm%n_tot + fbm%dphi*fbm%dr*fbm%dz*sum(fbm%denf(ir,:,:))*fbm%r(ir)
        denp_tot = denp_tot + fbm%dphi*fbm%dr*fbm%dz*sum(equil%plasma(ir,:,:)%denp)*fbm%r(ir)
    enddo

    if(fbm%n_tot.ge.denp_tot) then
        if(inputs%verbose.ge.0) then
            write(*,'(a," (",ES10.3," >=",ES10.3,")")') &
                "READ_F: The total of number of fast ions exceeded the total number of thermal ions.", &
                 fbm%n_tot, denp_tot
            write(*,'(a)') "This is usually caused by zeff being incorrect."
        endif
        stop
    endif

    if(inputs%verbose.ge.1) then
        if(fbm%nphi.gt.1) then
            write(*,'(T2,"Distribution type: ",a)') "Non-axisymmetric Fast-ion Density Function F(energy,pitch,R,Z,Phi)"
        else
            write(*,'(T2,"Distribution type: ",a)') "Axisymmetric Fast-ion Density Function F(energy,pitch,R,Z)"
        endif
        write(*,'(T2,"Nenergy = ",i3)') fbm%nenergy
        write(*,'(T2,"Npitch  = ",i3)') fbm%npitch
        write(*,'(T2,"Nr  = ",i3)') fbm%nr
        write(*,'(T2,"Nz  = ",i3)') fbm%nz
        if(fbm%nphi.gt.1) then
            write(*,'(T2,"Nphi  = ",i3)') fbm%nphi
        endif
        write(*,'(T2,"Energy range = [",f5.2,",",f6.2,"]")') fbm%emin,fbm%emax
        write(*,'(T2,"Pitch  range = [",f5.2,",",f5.2,"]")') fbm%pmin,fbm%pmax
        write(*,'(T2,"R  range = [",f6.2,",",f6.2,"]")') fbm%rmin,fbm%rmax
        write(*,'(T2,"Z  range = [",f7.2,",",f6.2,"]")') fbm%zmin,fbm%zmax
        if(fbm%nphi.gt.1) then
            write(*,'(T2,"Phi  range = [",f5.2,",",f5.2,"]")') fbm%phimin,fbm%phimax
        endif
        write(*,'(T2,"Ntotal = ",ES10.3)') fbm%n_tot
        write(*,*) ''
    endif

end subroutine read_f

subroutine read_mc(fid, error)
    !+ Reads in a MC particle fast-ion distribution and puts them in [[libfida:particles]]
    integer(HID_T), intent(inout) :: fid
        !+ HDF5 file ID
    integer, intent(out)          :: error
        !+ Error code

    integer(HSIZE_T), dimension(1) :: dims
    integer(Int32) :: i,j,ii,ir,iz,iphi,nphi
    real(Float64) :: phi,beam_grid_phi_enter,beam_grid_phi_exit,delta_phi,xp,yp,zp
    real(Float64), dimension(3) :: uvw,xyz,ri,vi,e1_xyz,e2_xyz,C_xyz,dum
    real(Float64), dimension(:), allocatable :: weight
    type(LocalEMFields) :: fields
    integer :: cnt,num
    logical :: inp,path_valid
    character(len=50) :: dist_type_name = ''

    if(inputs%verbose.ge.1) then
        write(*,'(a)') '---- Fast-ion distribution settings ----'
    endif

    call h5ltread_dataset_int_scalar_f(fid, "/nparticle", particles%nparticle, error)

    !!ALLOCATE SPACE
    allocate(particles%fast_ion(particles%nparticle))
    allocate(weight(particles%nparticle))

    dims(1) = particles%nparticle
    call h5ltread_dataset_double_f(fid, "/r", particles%fast_ion%r, dims, error)
    call h5ltread_dataset_double_f(fid, "/z", particles%fast_ion%z, dims, error)
    call h5ltpath_valid_f(fid, "/phi", .True., path_valid, error)
    if(path_valid) then
        call h5ltread_dataset_double_f(fid, "/phi", particles%fast_ion%phi, dims, error)
        particles%axisym = .False.
    endif
    call h5ltread_dataset_int_f(fid, "/class", particles%fast_ion%class, dims, error)

    if(any(particles%fast_ion%class.le.0)) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'READ_MC: Orbit class ID must be greater than 0'
        endif
        stop
    endif

    if(inputs%split.ge.1) then
        call h5ltread_dataset_int_scalar_f(fid, "/nclass", particles%nclass, error)
        if(any(particles%fast_ion%class.gt.particles%nclass)) then
            if(inputs%verbose.ge.0) then
                write(*,'(a)') 'READ_MC: Orbit class ID greater than the number of classes'
            endif
            stop
        endif
    endif

    if(inputs%dist_type.eq.2) then
        if(particles%axisym) then
            dist_type_name = "Axisymmetric Guiding Center Monte Carlo"
        else
            dist_type_name = "Non-axisymmetric Guiding Center Monte Carlo"
        endif
        call h5ltread_dataset_double_f(fid, "/energy", particles%fast_ion%energy, dims, error)
        call h5ltread_dataset_double_f(fid, "/pitch", particles%fast_ion%pitch, dims, error)
        particles%fast_ion%vabs  = sqrt(particles%fast_ion%energy/(v2_to_E_per_amu*inputs%ab))
    else
        if(particles%axisym) then
            dist_type_name = "Axisymmetric Full Orbit Monte Carlo"
        else
            dist_type_name = "Non-axisymmetric Full Orbit Monte Carlo"
        endif
        call h5ltread_dataset_double_f(fid, "/vr", particles%fast_ion%vr, dims, error)
        call h5ltread_dataset_double_f(fid, "/vt", particles%fast_ion%vt, dims, error)
        call h5ltread_dataset_double_f(fid, "/vz", particles%fast_ion%vz, dims, error)
        particles%fast_ion%vabs = sqrt(particles%fast_ion%vr**2 + &
                                       particles%fast_ion%vt**2 + &
                                       particles%fast_ion%vz**2)
        particles%fast_ion%energy = v2_to_E_per_amu*inputs%ab*particles%fast_ion%vabs**2
    endif

    call h5ltread_dataset_double_f(fid, "/weight", weight, dims, error)

    cnt=0
    e1_xyz = matmul(beam_grid%inv_basis,[1.0,0.0,0.0])
    e2_xyz = matmul(beam_grid%inv_basis,[0.0,1.0,0.0])
    !$OMP PARALLEL DO schedule(guided) private(i,ii,j,ir,iz,iphi,fields,uvw,phi,ri,vi, &
    !$OMP& delta_phi,beam_grid_phi_enter,beam_grid_phi_exit,C_xyz,xyz,xp,yp,zp,dum,inp)
    particle_loop: do i=1,particles%nparticle
        if(inputs%verbose.ge.2) then
            WRITE(*,'(f7.2,"% completed",a,$)') cnt/real(particles%nparticle)*100,char(13)
        endif

        if(particles%axisym) then
            uvw = [particles%fast_ion(i)%r, 0.d0 , particles%fast_ion(i)%z]
        else
            xp = particles%fast_ion(i)%r * cos(particles%fast_ion(i)%phi)
            yp = particles%fast_ion(i)%r * sin(particles%fast_ion(i)%phi)
            zp = particles%fast_ion(i)%z
            uvw = [xp,yp,zp]
        endif
        call in_plasma(uvw,inp,input_coords=1)
        if(.not.inp) cycle particle_loop

        if(particles%axisym) then
            beam_grid_phi_enter = 0.0
            beam_grid_phi_exit = 0.0
            dum = [0.d0, 0.d0, particles%fast_ion(i)%z]
            call uvw_to_xyz(dum, C_xyz)
            call circle_grid_intersect(C_xyz,e1_xyz,e2_xyz,particles%fast_ion(i)%r,beam_grid_phi_enter,beam_grid_phi_exit)
            delta_phi = beam_grid_phi_exit-beam_grid_phi_enter
            if(delta_phi.gt.0) then
                particles%fast_ion(i)%beam_grid_cross_grid = .True.
            else
                particles%fast_ion(i)%beam_grid_cross_grid = .False.
                delta_phi = 2*pi
            endif
            particles%fast_ion(i)%beam_grid_phi_enter = beam_grid_phi_enter
        else
            delta_phi = 2*pi
            call uvw_to_xyz(uvw,xyz)
            particles%fast_ion(i)%beam_grid_cross_grid = in_grid(xyz)
            particles%fast_ion(i)%beam_grid_phi_enter = particles%fast_ion(i)%phi
        endif
        particles%fast_ion(i)%delta_phi = delta_phi
        particles%fast_ion(i)%weight = weight(i)

        ir = minloc(abs(inter_grid%r - particles%fast_ion(i)%r),1)
        iphi = minloc(abs(inter_grid%phi - particles%fast_ion(i)%phi),1)
        iz = minloc(abs(inter_grid%z - particles%fast_ion(i)%z),1)

        !$OMP ATOMIC UPDATE
        equil%plasma(ir,iz,iphi)%denf = equil%plasma(ir,iz,iphi)%denf + weight(i) / &
                                   (particles%fast_ion(i)%r*inter_grid%dv)
        !$OMP END ATOMIC
        cnt=cnt+1
    enddo particle_loop
    !$OMP END PARALLEL DO

    num = count(particles%fast_ion%beam_grid_cross_grid)
    if(num.le.0) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'READ_MC: No mc particles in beam grid'
        endif
        stop
    endif

    if(inputs%verbose.ge.1) then
        write(*,'(T2,"Distribution type: ",a)') dist_type_name
        write(*,'(T2,"Number of mc particles: ",i10)') particles%nparticle
        write(*,'(T2,"Number of orbit classes: ",i6)') particles%nclass
        write(*,*) ''
    endif

end subroutine read_mc

subroutine read_distribution
    !+ Reads in the fast-ion distribution
    integer(HID_T) :: fid
    integer :: error

    !!Initialize HDF5 interface
    call h5open_f(error)

    !!Open HDF5 file
    call h5fopen_f(inputs%distribution_file, H5F_ACC_RDONLY_F, fid, error)

    !!Get distribution type
    call h5ltread_dataset_int_scalar_f(fid, "/type", inputs%dist_type, error)

    if(inputs%dist_type.eq.1) then
        call read_f(fid, error)
    else !2 or 3
        call read_mc(fid, error)
    endif

    !!Close file
    call h5fclose_f(fid, error)

    !!Close HDF5 interface
    call h5close_f(error)

end subroutine read_distribution

subroutine read_atomic_cross(fid, grp, cross)
    !+ Reads in a cross section table from file
    !+ and puts it into a [[AtomicCrossSection]] type
    integer(HID_T), intent(in)              :: fid
        !+ HDF5 file ID
    character(len=*), intent(in)            :: grp
        !+ HDF5 group to read from
    type(AtomicCrossSection), intent(inout) :: cross
        !+ Atomic cross section

    integer(HSIZE_T), dimension(3) :: dim3
    real(Float64) :: emin, emax, rmin
    integer :: i, n_max, m_max, error
    real(Float64), dimension(:,:,:), allocatable :: dummy3
    logical :: path_valid

    call h5ltpath_valid_f(fid, grp, .True., path_valid, error)
    if(.not.path_valid) then
        if(inputs%verbose.ge.0) then
            write(*,'(a,a)') 'READ_ATOMIC_CROSS: Unknown atomic interaction: ', trim(grp)
        endif
        stop
    endif

    call h5ltread_dataset_int_scalar_f(fid, grp//"/nenergy", cross%nenergy, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/n_max", n_max, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/m_max", m_max, error)
    call h5ltread_dataset_double_scalar_f(fid,grp//"/emin", emin, error)
    call h5ltread_dataset_double_scalar_f(fid,grp//"/emax", emax, error)
    call h5ltread_dataset_double_scalar_f(fid,grp//"/dlogE", cross%dlogE, error)
    cross%logemin = log10(emin)
    cross%logemax = log10(emax)

    allocate(dummy3(n_max, m_max, cross%nenergy))

    allocate(cross%log_cross(cross%m_max,cross%n_max, cross%nenergy))

    dim3 = [n_max, m_max, cross%nenergy]
    call h5ltread_dataset_double_f(fid,grp//"/cx", dummy3, dim3, error)
    rmin = minval(dummy3,dummy3.gt.0.d0)
    where (dummy3.le.0.0)
        dummy3 = 0.9*rmin
    end where
    cross%minlog_cross = log10(rmin)
    do i=1, cross%nenergy
        cross%log_cross(:,:,i) = log10(transpose(dummy3(1:nlevs,1:nlevs,i)))
    enddo
    deallocate(dummy3)

end subroutine read_atomic_cross

subroutine read_atomic_rate(fid, grp, b_amu, t_amu, rates)
    !+ Reads in a atomic rate table from file
    !+ and puts it into a [[AtomicRates]] type
    integer(HID_T), intent(in)              :: fid
        !+ HDF5 file ID
    character(len=*), intent(in)            :: grp
        !+ HDF5 group to read from
    real(Float64), dimension(2), intent(in) :: b_amu
        !+ Atomic masses of "beam" species (beam ion and thermal ion)
    real(Float64), intent(in)               :: t_amu
        !+ Atomic mass of "target" species (thermal ion)
    type(AtomicRates), intent(inout)        :: rates
        !+ Atomic reaction rates

    integer(HSIZE_T), dimension(2) :: dim2
    integer(HSIZE_T), dimension(4) :: dim4
    integer(HSIZE_T), dimension(5) :: dim5
    logical :: path_valid
    integer :: i, j, n, n_max, m_max, error
    integer :: n_bt_amu, tt_ind, bt_ind, drank
    real(Float64) :: emin,emax,tmin,tmax,rmin
    real(Float64) :: bt_min, tt_min, tt_dum, bt_dum
    real(Float64), dimension(2) :: bt_amu, tt_amu
    real(Float64), dimension(:,:), allocatable :: dummy2
    real(Float64), dimension(:,:,:,:), allocatable :: dummy4
    real(Float64), dimension(:,:,:,:,:), allocatable :: dummy5

    call h5ltpath_valid_f(fid, grp, .True., path_valid, error)
    if(.not.path_valid) then
        if(inputs%verbose.ge.0) then
            write(*,'(a,a)') 'READ_ATOMIC_RATE: Unknown atomic interaction: ', trim(grp)
        endif
        stop
    endif

    call h5ltread_dataset_int_scalar_f(fid, grp//"/n_bt_amu", n_bt_amu, error)
    allocate(dummy2(2, n_bt_amu))
    dim2 = [2, n_bt_amu]
    call h5ltread_dataset_double_f(fid, grp//"/bt_amu", dummy2, dim2, error)

    call h5ltread_dataset_int_scalar_f(fid, grp//"/n_max", n_max, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/m_max", m_max, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/nenergy", rates%nenergy, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/emin", emin, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/emax", emax, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/dlogE", rates%dlogE, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/ntemp", rates%ntemp, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/tmin", tmin, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/tmax", tmax, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/dlogT", rates%dlogT, error)
    rates%logemin = log10(emin)
    rates%logemax = log10(emax)
    rates%logtmin = log10(tmin)
    rates%logtmax = log10(tmax)

    bt_ind = 1
    tt_ind = 1
    bt_amu = [b_amu(1), t_amu]
    tt_amu = [b_amu(2), t_amu]
    bt_min = norm2(bt_amu - dummy2(:,1))
    tt_min = norm2(tt_amu - dummy2(:,1))
    do i=2, n_bt_amu
        bt_dum = norm2(bt_amu - dummy2(:,i))
        tt_dum = norm2(tt_amu - dummy2(:,i))
        if(bt_dum.lt.bt_min) then
            bt_min = bt_dum
            bt_ind = i
        endif
        if(tt_dum.lt.tt_min) then
            tt_min = tt_dum
            tt_ind = i
        endif
    enddo
    rates%ab(1) = dummy2(1,bt_ind)
    rates%ab(2) = dummy2(1,tt_ind)

    deallocate(dummy2)

    allocate(rates%log_rate(&
                    rates%m_max, &
                    rates%n_max, &
                    rates%nenergy, &
                    rates%ntemp, 2))
    rates%log_rate = 0.d0

    !!Read CX
    call h5ltpath_valid_f(fid, grp//"/cx", .True., path_valid, error)
    if(path_valid) then
        call h5ltget_dataset_ndims_f(fid, grp//"/cx", drank, error)
        if(drank.eq.5) then
            allocate(dummy5(n_max, m_max, &
                           rates%nenergy, &
                           rates%ntemp, n_bt_amu))
            dim5 = [n_max, m_max, rates%nenergy, rates%ntemp,n_bt_amu]
            call h5ltread_dataset_double_f(fid, grp//"/cx", dummy5, dim5, error)

            do j=1,rates%ntemp
                do i=1,rates%nenergy
                        rates%log_rate(:,:,i,j,1) = transpose(dummy5(1:nlevs,1:nlevs,i,j,bt_ind))
                        rates%log_rate(:,:,i,j,2) = transpose(dummy5(1:nlevs,1:nlevs,i,j,tt_ind))
                enddo
            enddo
            deallocate(dummy5)
        else
            if(inputs%verbose.ge.0) then
                write(*,'(a,a)') 'READ_ATOMIC_RATE: Unsupported atomic interaction: ', trim(grp)
            endif
            stop
        endif
    endif

    rmin = minval(rates%log_rate, rates%log_rate.gt.0.d0)
    where (rates%log_rate.le.0.d0)
        rates%log_rate = 0.9*rmin
    end where
    rates%minlog_rate = log10(rmin)
    rates%log_rate = log10(rates%log_rate)

end subroutine read_atomic_rate

subroutine read_atomic_transitions(fid, grp, b_amu, t_amu, rates)
    !+ Reads in a atomic transitions table from file
    !+ and puts it into a [[AtomicTransitions]] type
    integer(HID_T), intent(in)              :: fid
        !+ HDF5 file ID
    character(len=*), intent(in)            :: grp
        !+ HDF5 group to read from
    real(Float64), dimension(2), intent(in) :: b_amu
        !+ Atomic masses of "beam" species (beam ion and thermal ion)
    real(Float64), intent(in)               :: t_amu
        !+ Atomic mass of "target" species (thermal ion)
    type(AtomicTransitions), intent(inout)  :: rates
        !+ Atomic transitions

    integer(HSIZE_T), dimension(2) :: dim2
    integer(HSIZE_T), dimension(4) :: dim4
    integer(HSIZE_T), dimension(5) :: dim5
    logical :: path_valid
    integer :: i, j, n, n_max, m_max, error
    integer :: n_bt_amu, tt_ind, bt_ind, drank
    real(Float64) :: emin,emax,tmin,tmax,rmin
    real(Float64) :: bt_min, tt_min, tt_dum, bt_dum
    real(Float64), dimension(2) :: bt_amu, tt_amu
    real(Float64), dimension(:,:), allocatable :: dummy2
    real(Float64), dimension(:,:,:,:), allocatable :: dummy4
    real(Float64), dimension(:,:,:,:,:), allocatable :: dummy5

    call h5ltpath_valid_f(fid, grp, .True., path_valid, error)
    if(.not.path_valid) then
        if(inputs%verbose.ge.0) then
            write(*,'(a,a)') 'READ_ATOMIC_TRANSITIONS: Unknown atomic interaction: ', trim(grp)
        endif
        stop
    endif

    call h5ltread_dataset_int_scalar_f(fid, grp//"/n_bt_amu", n_bt_amu, error)
    allocate(dummy2(2, n_bt_amu))
    dim2 = [2, n_bt_amu]
    call h5ltread_dataset_double_f(fid, grp//"/bt_amu", dummy2, dim2, error)

    call h5ltread_dataset_int_scalar_f(fid, grp//"/n_max", n_max, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/m_max", m_max, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/nenergy", rates%nenergy, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/emin", emin, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/emax", emax, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/dlogE", rates%dlogE, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/ntemp", rates%ntemp, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/tmin", tmin, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/tmax", tmax, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/dlogT", rates%dlogT, error)
    rates%logemin = log10(emin)
    rates%logemax = log10(emax)
    rates%logtmin = log10(tmin)
    rates%logtmax = log10(tmax)

    bt_ind = 1
    tt_ind = 1
    bt_amu = [b_amu(1), t_amu]
    tt_amu = [b_amu(2), t_amu]
    bt_min = norm2(bt_amu - dummy2(:,1))
    tt_min = norm2(tt_amu - dummy2(:,1))
    do i=2, n_bt_amu
        bt_dum = norm2(bt_amu - dummy2(:,i))
        tt_dum = norm2(tt_amu - dummy2(:,i))
        if(bt_dum.lt.bt_min) then
            bt_min = bt_dum
            bt_ind = i
        endif
        if(tt_dum.lt.tt_min) then
            tt_min = tt_dum
            tt_ind = i
        endif
    enddo
    rates%ab(1) = dummy2(1,bt_ind)
    rates%ab(2) = dummy2(1,tt_ind)

    deallocate(dummy2)

    allocate(rates%log_pop(&
                    rates%m_max, &
                    rates%n_max, &
                    rates%nenergy, &
                    rates%ntemp, 2))
    allocate(rates%log_depop(&
                    rates%n_max, &
                    rates%nenergy, &
                    rates%ntemp, 2))
    rates%log_pop = 0.d0
    rates%log_depop = 0.d0

    !!Read CX
    call h5ltpath_valid_f(fid, grp//"/cx", .True., path_valid, error)
    if(path_valid) then
        call h5ltget_dataset_ndims_f(fid, grp//"/cx", drank, error)
        if(drank.eq.4) then
            allocate(dummy4(n_max, &
                           rates%nenergy, &
                           rates%ntemp, n_bt_amu))
            dim4 = [n_max, rates%nenergy, rates%ntemp,n_bt_amu]
            call h5ltread_dataset_double_f(fid, grp//"/cx", dummy4, dim4, error)
            do j=1,rates%ntemp
                do i=1,rates%nenergy
                    do n=1,rates%n_max
                        rates%log_depop(n,i,j,1) = dummy4(n,i,j,bt_ind)
                        rates%log_depop(n,i,j,2) = dummy4(n,i,j,tt_ind)
                    enddo
                enddo
            enddo
            deallocate(dummy4)
        endif
        if(drank.eq.5) then
            allocate(dummy5(n_max, m_max, &
                           rates%nenergy, &
                           rates%ntemp, n_bt_amu))
            dim5 = [n_max, m_max, rates%nenergy, rates%ntemp,n_bt_amu]
            call h5ltread_dataset_double_f(fid, grp//"/cx", dummy5, dim5, error)
            do j=1,rates%ntemp
                do i=1,rates%nenergy
                    do n=1,rates%n_max
                        rates%log_depop(n,i,j,1) = sum(dummy5(n,:,i,j,bt_ind))
                        rates%log_depop(n,i,j,2) = sum(dummy5(n,:,i,j,tt_ind))
                    enddo
                enddo
            enddo
            deallocate(dummy5)
        endif
    endif

    !!Read ionization
    call h5ltpath_valid_f(fid, grp//"/ionization", .True., path_valid, error)
    if(path_valid) then
        allocate(dummy4(n_max, &
                       rates%nenergy, &
                       rates%ntemp, n_bt_amu))
        dim4 = [n_max, rates%nenergy, rates%ntemp,n_bt_amu]
        call h5ltread_dataset_double_f(fid, grp//"/ionization", dummy4, dim4, error)
        do j=1,rates%ntemp
            do i=1,rates%nenergy
                do n=1,rates%n_max
                    rates%log_depop(n,i,j,1) = rates%log_depop(n,i,j,1) + &
                                               dummy4(n,i,j,bt_ind)
                    rates%log_depop(n,i,j,2) = rates%log_depop(n,i,j,2) + &
                                               dummy4(n,i,j,tt_ind)
                enddo
            enddo
        enddo
        deallocate(dummy4)
    endif

    !!Read excitation
    call h5ltpath_valid_f(fid, grp//"/excitation", .True., path_valid, error)
    if(path_valid) then
        allocate(dummy5(n_max, m_max,&
                       rates%nenergy, &
                       rates%ntemp, n_bt_amu))
        dim5 = [n_max, m_max, rates%nenergy, rates%ntemp,n_bt_amu]
        call h5ltread_dataset_double_f(fid, grp//"/excitation", dummy5, dim5, error)
        do j=1,rates%ntemp
            do i=1,rates%nenergy
                rates%log_pop(:,:,i,j,1) = transpose(dummy5(1:nlevs,1:nlevs,i,j,bt_ind))
                rates%log_pop(:,:,i,j,2) = transpose(dummy5(1:nlevs,1:nlevs,i,j,tt_ind))
                do n=1,rates%n_max
                    rates%log_depop(n,i,j,1) = rates%log_depop(n,i,j,1) + &
                                               sum(dummy5(n,:,i,j,bt_ind))
                    rates%log_depop(n,i,j,2) = rates%log_depop(n,i,j,2) + &
                                               sum(dummy5(n,:,i,j,tt_ind))
                enddo
            enddo
        enddo
        deallocate(dummy5)
    endif

    rmin = minval(rates%log_depop, rates%log_depop.gt.0.d0)
    where (rates%log_depop.le.0.d0)
        rates%log_depop = 0.9*rmin
    end where
    rates%minlog_depop = log10(rmin)
    rates%log_depop = log10(rates%log_depop)

    rmin = minval(rates%log_pop, rates%log_pop.gt.0.d0)
    where (rates%log_pop.le.0.d0)
        rates%log_pop = 0.9*rmin
    end where
    rates%minlog_pop = log10(rmin)
    rates%log_pop = log10(rates%log_pop)

end subroutine read_atomic_transitions

subroutine read_nuclear_rates(fid, grp, rates)
    !+ Reads in a nuclear reaction rates table from file
    !+ and puts it into a [[NuclearRates]] type
    integer(HID_T), intent(in)              :: fid
        !+ HDF5 file ID
    character(len=*), intent(in)            :: grp
        !+ HDF5 group to read from
    type(NuclearRates), intent(inout)       :: rates
        !+ Atomic reaction rates

    integer(HSIZE_T), dimension(1) :: dim1
    integer(HSIZE_T), dimension(3) :: dim3
    logical :: path_valid, err
    integer :: i, j, error
    real(Float64) :: emin, emax, tmin, tmax, rmin

    err = .False.
    call h5ltpath_valid_f(fid, grp, .True., path_valid, error)
    if(.not.path_valid) then
        if(inputs%verbose.ge.0) then
            write(*,'(a,a)') 'READ_NUCLEAR_RATES: Unknown nuclear interaction: ', trim(grp)
            write(*,'(a)') 'Continuing without neutron calculation'
        endif
        inputs%calc_neutron=0
        return
    endif

    dim1 = [2]
    call h5ltread_dataset_double_f(fid, grp//"/bt_amu", rates%bt_amu, dim1, error)

    if(abs(inputs%ab-rates%bt_amu(1)).gt.0.2) then
        if(inputs%verbose.ge.0) then
            write(*,'(a,f6.3,a,f6.3,a)') 'READ_NUCLEAR_RATES: Unexpected beam species mass. Expected ',&
                rates%bt_amu(1),' amu got ', inputs%ab, ' amu'
        endif
        err = .True.
    endif

    if(abs(inputs%ai-rates%bt_amu(2)).gt.0.2) then
        if(inputs%verbose.ge.0) then
            write(*,'(a,f6.3,a,f6.3,a)') 'READ_NUCLEAR_RATES: Unexpected thermal species mass. Expected ',&
                 rates%bt_amu(2),' amu got ', inputs%ai, ' amu'
        endif
        err = .True.
    endif

    if(err) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'Continuing without neutron calculation'
        endif
        inputs%calc_neutron=0
        return
    endif

    call h5ltread_dataset_int_scalar_f(fid, grp//"/nbranch", rates%nbranch, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/nenergy", rates%nenergy, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/emin", emin, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/emax", emax, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/dlogE", rates%dlogE, error)
    call h5ltread_dataset_int_scalar_f(fid, grp//"/ntemp", rates%ntemp, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/tmin", tmin, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/tmax", tmax, error)
    call h5ltread_dataset_double_scalar_f(fid, grp//"/dlogT", rates%dlogT, error)
    rates%logemin = log10(emin)
    rates%logemax = log10(emax)
    rates%logtmin = log10(tmin)
    rates%logtmax = log10(tmax)

    allocate(rates%log_rate(rates%nenergy, &
                            rates%ntemp,   &
                            rates%nbranch))

    dim3 = [rates%nenergy, rates%ntemp, rates%nbranch]
    call h5ltread_dataset_double_f(fid, grp//"/fusion", rates%log_rate, dim3, error)

    rmin = minval(rates%log_rate, rates%log_rate.gt.0.d0)
    where (rates%log_rate.le.0.d0)
        rates%log_rate = 0.9*rmin
    end where
    rates%minlog_rate = log10(rmin)
    rates%log_rate = log10(rates%log_rate)

end subroutine read_nuclear_rates

subroutine read_tables
    !+ Reads in atomic tables from file and stores them in [[libfida:tables]]
    integer(HID_T) :: fid
    integer(HSIZE_T), dimension(2) :: dim2
    integer :: error

    integer :: n_max, m_max
    character(len=4) :: impname
    real(Float64) :: imp_amu
    real(Float64), dimension(2) :: b_amu
    real(Float64), dimension(:,:), allocatable :: dummy2

    if(inputs%verbose.ge.1) then
        write(*,'(a)') "---- Atomic tables settings ----"
    endif

    !!Initialize HDF5 interface
    call h5open_f(error)

    !!Open HDF5 file
    call h5fopen_f(inputs%tables_file, H5F_ACC_RDONLY_F, fid, error)

    !!Read Hydrogen-Hydrogen CX Cross Sections
    call read_atomic_cross(fid,"/cross/H_H",tables%H_H_cx_cross)

    !!Read Hydrogen-Hydrogen CX Rates
    b_amu = [inputs%ab, inputs%ai]
    call read_atomic_rate(fid,"/rates/H_H",b_amu, inputs%ai, tables%H_H_cx_rate)

    !!Read Hydrogen-Hydrogen Transitions
    call read_atomic_transitions(fid,"/rates/H_H",b_amu, inputs%ai, tables%H_H)
    inputs%ab = tables%H_H%ab(1)
    inputs%ai = tables%H_H%ab(2)

    !!Read Hydrogen-Electron Transitions
    call read_atomic_transitions(fid,"/rates/H_e",b_amu, e_amu, tables%H_e)

    !!Read Hydrogen-Impurity Transitions
    impname = ''
    select case (inputs%impurity_charge)
        case (5)
            impname = "B5"
            imp_amu = B5_amu
        case (6)
            impname = "C6"
            imp_amu = C6_amu
        case DEFAULT
            impname = "Aq"
            imp_amu = 2.d0*inputs%impurity_charge
    end select

    call read_atomic_transitions(fid,"/rates/H_"//trim(adjustl(impname)), b_amu, imp_amu, tables%H_Aq)

    !!Read Einstein coefficients
    call h5ltread_dataset_int_scalar_f(fid,"/rates/spontaneous/n_max", n_max, error)
    call h5ltread_dataset_int_scalar_f(fid,"/rates/spontaneous/m_max", m_max, error)
    allocate(dummy2(n_max,m_max))
    dim2 = [n_max, m_max]
    call h5ltread_dataset_double_f(fid,"/rates/spontaneous/einstein",dummy2, dim2, error)
    tables%einstein(:,:) = transpose(dummy2(1:nlevs,1:nlevs))
    deallocate(dummy2)

    !!Read nuclear Deuterium-Deuterium rates
    if(inputs%calc_neutron.ge.1) then
        call read_nuclear_rates(fid, "/rates/D_D", tables%D_D)
    endif

    !!Close file
    call h5fclose_f(fid, error)

    !!Close HDF5 interface
    call h5close_f(error)

    if(inputs%verbose.ge.1) then
        write(*,'(T2,"Maximum n/m: ",i2)') nlevs
        write(*,'(T2,"Beam/Fast-ion mass: ",f6.3," [amu]")') inputs%ab
        write(*,'(T2,"Thermal/Bulk-ion mass: ",f6.3," [amu]")') inputs%ai
        write(*,'(T2,"Impurity mass: ",f6.3," [amu]")') imp_amu
        write(*,*) ''
    endif

end subroutine read_tables

subroutine write_beam_grid(id, error)
    !+ Write [[libfida:beam_grid]] to an HDF5 file
    integer(HID_T), intent(inout) :: id
        !+ HDF5 file ID
    integer, intent(out)          :: error
        !+ Error code

    integer(HID_T) :: gid
    integer(HSIZE_T), dimension(3) :: dims
    real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: u_grid, v_grid, w_grid
    real(Float64) :: xyz(3),uvw(3)
    integer :: i,j,k

    !Create uvw grids
    do k=1, beam_grid%nz
        do j=1, beam_grid%ny
            do i=1, beam_grid%nx
                xyz = [beam_grid%xc(i), &
                       beam_grid%yc(j), &
                       beam_grid%zc(k)]
                call xyz_to_uvw(xyz,uvw)
                u_grid(i,j,k) = uvw(1)
                v_grid(i,j,k) = uvw(2)
                w_grid(i,j,k) = uvw(3)
           enddo
        enddo
    enddo

    !Create grid group
    call h5gcreate_f(id, "grid", gid, error)

    !Write variables
    dims(1) = 1
    call h5ltmake_dataset_int_f(gid,"nx", 0, dims(1:1), [beam_grid%nx], error)
    call h5ltmake_dataset_int_f(gid,"ny", 0, dims(1:1), [beam_grid%ny], error)
    call h5ltmake_dataset_int_f(gid,"nz", 0, dims(1:1), [beam_grid%nz], error)

    dims = [beam_grid%nx, beam_grid%ny, beam_grid%nz]
    call h5ltmake_compressed_dataset_double_f(gid,"x", 1, dims(1:1), beam_grid%xc, error)
    call h5ltmake_compressed_dataset_double_f(gid,"y", 1, dims(2:2), beam_grid%yc, error)
    call h5ltmake_compressed_dataset_double_f(gid,"z", 1, dims(3:3), beam_grid%zc, error)

    call h5ltmake_compressed_dataset_double_f(gid,"x_grid", 3, dims, u_grid, error)
    call h5ltmake_compressed_dataset_double_f(gid,"y_grid", 3, dims, v_grid, error)
    call h5ltmake_compressed_dataset_double_f(gid,"z_grid", 3, dims, w_grid, error)

    !Write attributes
    call h5ltset_attribute_string_f(gid,"nx","description", &
         "Number of cells in the X direction", error)
    call h5ltset_attribute_string_f(gid,"ny","description", &
         "Number of cells in the Y direction", error)
    call h5ltset_attribute_string_f(gid,"nz","description", &
         "Number of cells in the Z direction", error)
    call h5ltset_attribute_string_f(gid,"x","description", &
         "X value of cell center in beam grid coordinates", error)
    call h5ltset_attribute_string_f(gid,"x","units", "cm", error)
    call h5ltset_attribute_string_f(gid,"y","description", &
         "Y value of cell center in beam grid coordinates", error)
    call h5ltset_attribute_string_f(gid,"y","units", "cm", error)
    call h5ltset_attribute_string_f(gid,"z","description", &
         "Z value of cell center in beam grid coordinates", error)
    call h5ltset_attribute_string_f(gid,"z","units", "cm", error)

    call h5ltset_attribute_string_f(gid,"x_grid","description", &
         "X value of cell center in machine coordinates: x_grid(x,y,z)", error)
    call h5ltset_attribute_string_f(gid,"x_grid","units", "cm", error)
    call h5ltset_attribute_string_f(gid,"y_grid","description", &
         "Y value of cell center in machine coordinates: y_grid(x,y,z)", error)
    call h5ltset_attribute_string_f(gid,"y_grid","units", "cm", error)
    call h5ltset_attribute_string_f(gid,"z_grid","description", &
         "Z value of cell center in machine coordinates: z_grid(x,y,z)", error)
    call h5ltset_attribute_string_f(gid,"z_grid","units", "cm", error)

    call h5ltset_attribute_string_f(id,"grid","coordinate_system", &
         "Right-handed cartesian",error)

    !Close grid group
    call h5gclose_f(gid, error)

end subroutine write_beam_grid

subroutine write_birth_profile
    !+ Writes [[libfida:birth]] to a HDF5 file
    integer(HID_T) :: fid
    integer(HSIZE_T), dimension(4) :: dim4
    integer(HSIZE_T), dimension(2) :: dim2
    integer(HSIZE_T), dimension(1) :: d
    integer :: error, i, c, npart, start_index, end_index

    character(charlim) :: filename
    type(LocalEMFields) :: fields
    type(BirthParticle) :: part
    real(Float64), dimension(:,:), allocatable :: ri, ri_gc
    real(Float64), dimension(:,:), allocatable :: vi
    real(Float64), dimension(:), allocatable :: energy, pitch, weight
    integer, dimension(:,:), allocatable :: inds
    integer, dimension(:), allocatable :: neut_types
    real(Float64), dimension(3) :: xyz,v_xyz,uvw,v_uvw,r_gyro,uvw_gc
    logical :: do_write

#ifdef _MPI
    integer :: rank
    integer, dimension(:), allocatable :: npart_image
#endif

    npart = birth%cnt-1
#ifdef _MPI
    call parallel_sum(npart)
#endif

    allocate(ri(3,npart))
    allocate(vi(3,npart))
    allocate(ri_gc(3,npart))
    allocate(energy(npart),pitch(npart),weight(npart))
    allocate(inds(3,npart))
    allocate(neut_types(npart))
    ri = 0.d0
    vi = 0.d0
    ri_gc = 0.d0
    energy = 0.d0
    pitch = 0.d0
    weight = 0.d0
    inds = 0
    neut_types = 0

    c = 0
#ifdef _MPI
    rank = my_rank()
    allocate(npart_image(0:num_ranks()-1))
    npart_image(:) = 0
    npart_image(rank) = birth%cnt - 1
    call parallel_sum(npart_image)

    do i=0,rank-1
        c = c +  npart_image(i)
    enddo
    deallocate(npart_image)
#endif
    start_index = 1 + c
    end_index = birth%cnt - 1 + c

    c = 1
    do i=start_index, end_index
        part = birth%part(c)
        ! Convert position to rzphi
        xyz = part%ri
        v_xyz = part%vi

        inds(:,i) = part%ind
        neut_types(i) = part%neut_type
        energy(i) = part%energy
        weight(i) = part%weight

        ! Get guiding center positions
        pitch(i) = part%pitch
        call xyz_to_uvw(part%ri_gc, uvw_gc)
        ri_gc(1,i) = sqrt(uvw_gc(1)*uvw_gc(1) + uvw_gc(2)*uvw_gc(2))
        ri_gc(2,i) = uvw_gc(3)
        ri_gc(3,i) = atan2(uvw_gc(2),uvw_gc(1))

        ! Get position in cylindrical
        call xyz_to_uvw(xyz,uvw)
        ri(1,i) = sqrt(uvw(1)*uvw(1) + uvw(2)*uvw(2))
        ri(2,i) = uvw(3)
        ri(3,i) = atan2(uvw(2),uvw(1))

        ! Convert velocity to cylindrical
        v_uvw = matmul(beam_grid%basis, v_xyz)
        vi(1,i) = v_uvw(1)*cos(ri(3,i)) + v_uvw(2)*sin(ri(3,i))
        vi(2,i) = v_uvw(3)
        vi(3,i) = -v_uvw(1)*sin(ri(3,i)) + v_uvw(2)*cos(ri(3,i))
        c = c + 1
    enddo

    filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_birth.h5"

    do_write = .True.
#ifdef _MPI
    call parallel_sum(ri_gc)
    call parallel_sum(energy)
    call parallel_sum(pitch)
    call parallel_sum(weight)
    call parallel_sum(ri)
    call parallel_sum(vi)
    call parallel_sum(inds)
    call parallel_sum(neut_types)
    if(my_rank().ne.0) do_write = .False.
#endif

    if(do_write) then
        !Open HDF5 interface
        call h5open_f(error)

        !Create file overwriting any existing file
        call h5fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error)

        !Write variables
        call write_beam_grid(fid, error)
        d(1) = 1
        call h5ltmake_dataset_int_f(fid, "/n_birth", 0, d, [npart], error)
        dim4 = shape(birth%dens)
        call h5ltmake_compressed_dataset_double_f(fid,"/dens", 4, dim4, birth%dens, error)
        dim2 = [3, npart]
        call h5ltmake_compressed_dataset_double_f(fid,"/ri_gc", 2, dim2, ri_gc, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/ri", 2, dim2, ri, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/vi", 2, dim2, vi, error)
        call h5ltmake_compressed_dataset_int_f(fid,"/ind", 2, dim2, inds, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/energy", 1, dim2(2:2), energy, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/pitch", 1, dim2(2:2), pitch, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/weight", 1, dim2(2:2), weight, error)
        call h5ltmake_compressed_dataset_int_f(fid,"/type", 1, dim2(2:2), neut_types, error)

        !Add attributes
        call h5ltset_attribute_string_f(fid, "/n_birth","description", &
             "Number of birth mc particles deposited", error)
        call h5ltset_attribute_string_f(fid, "/dens", "description", &
             "Birth density: dens(beam_component,x,y,z)", error)
        call h5ltset_attribute_string_f(fid, "/dens", "units", &
             "fast-ions/(s*cm^3)", error)
        call h5ltset_attribute_string_f(fid, "/ri_gc", "description", &
             "Fast-ion guiding-center birth position in R-Z-Phi: ri_gc([r,z,phi],particle)", error)
        call h5ltset_attribute_string_f(fid, "/ri_gc", "units", "cm, radians", error)
        call h5ltset_attribute_string_f(fid, "/ri", "description", &
             "Fast-ion birth position in R-Z-Phi: ri([r,z,phi],particle)", error)
        call h5ltset_attribute_string_f(fid, "/ri", "units", "cm, radians", error)
        call h5ltset_attribute_string_f(fid, "/vi", "description", &
             "Fast-ion birth velocity in R-Z-Phi: vi([r,z,phi],particle)", error)
        call h5ltset_attribute_string_f(fid, "/vi", "units", "cm/s", error)
        call h5ltset_attribute_string_f(fid, "/energy", "description", &
             "Fast-ion birth energy: energy(particle)", error)
        call h5ltset_attribute_string_f(fid, "/energy", "units", "keV", error)
        call h5ltset_attribute_string_f(fid, "/weight", "description", &
             "Fast-ion birth weight: weight(particle)", error)
        call h5ltset_attribute_string_f(fid, "/weight", "units", "fast-ions/s", error)
        call h5ltset_attribute_string_f(fid, "/pitch", "description", &
             "Fast-ion birth pitch w.r.t. the magnetic field: pitch(particle)", error)
        call h5ltset_attribute_string_f(fid, "/ind", "description", &
             "Fast-ion birth beam grid indices: ind([i,j,k],particle)", error)
        call h5ltset_attribute_string_f(fid, "/type", "description", &
             "Fast-ion birth type (1=Full, 2=Half, 3=Third)", error)

        call h5ltset_attribute_string_f(fid, "/", "coordinate_system", &
             "Cylindrical (R,Z,Phi)",error)
        call h5ltset_attribute_string_f(fid, "/", "version", version, error)
        call h5ltset_attribute_string_f(fid, "/", "description", &
             "Birth density and particles calculated by FIDASIM", error)

        !!Close file
        call h5fclose_f(fid, error)

        !!Close HDF5 interface
        call h5close_f(error)
    endif

    ! Deallocate arrays since they aren't needed anymore
    deallocate(ri,vi,ri_gc,energy,pitch,neut_types,inds)
    deallocate(birth%dens,birth%part)

    if(inputs%verbose.ge.1) then
        write(*,'(T4,a,a)') 'birth profile written to: ',trim(filename)
    endif

end subroutine write_birth_profile

subroutine write_neutrals
    !+ Writes [[libfida:neut]] to a HDF5 file
    integer(HID_T) :: fid
    integer(HSIZE_T), dimension(4) :: dims
    integer(HSIZE_T), dimension(1) :: d
    integer :: error

    character(charlim) :: filename

    filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_neutrals.h5"

    !Open HDF5 interface
    call h5open_f(error)

    !Create file overwriting any existing file
    call h5fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error)

    !Write variables
    call write_beam_grid(fid, error)
    dims = [nlevs, beam_grid%nx, beam_grid%ny, beam_grid%nz]
    d(1) =1
    call h5ltmake_dataset_int_f(fid,"/nlevel", 0, d, [nlevs], error)
    call h5ltset_attribute_string_f(fid,"/nlevel","description", &
         "Number of atomic energy levels", error)

    if(inputs%calc_nbi_dens.ge.1) then
        call h5ltmake_compressed_dataset_double_f(fid, "/fdens", 4, dims, &
             neut%full, error)
        call h5ltset_attribute_string_f(fid,"/fdens","units","neutrals*cm^-3",error)
        call h5ltmake_compressed_dataset_double_f(fid, "/hdens", 4, dims, &
             neut%half, error)
        call h5ltmake_compressed_dataset_double_f(fid, "/tdens", 4, dims, &
             neut%third, error)

        call h5ltset_attribute_string_f(fid,"/fdens","description", &
             "Neutral density for the full energy component of the beam: fdens(level,x,y,z)", error)
        call h5ltset_attribute_string_f(fid,"/hdens","description", &
             "Neutral density for the half energy component of the beam: hdens(level,x,y,z)", error)
        call h5ltset_attribute_string_f(fid,"/hdens","units","neutrals*cm^-3",error)
        call h5ltset_attribute_string_f(fid,"/tdens","description", &
             "Neutral density for the third energy component of the beam: tdens(level,x,y,z)", error)
        call h5ltset_attribute_string_f(fid,"/tdens","units","neutrals*cm^-3",error)
    endif

    if(inputs%calc_dcx_dens.ge.1) then
        call h5ltmake_compressed_dataset_double_f(fid, "/dcxdens", 4, dims, &
             neut%dcx, error)

        call h5ltset_attribute_string_f(fid,"/dcxdens","description", &
             "Direct Charge Exchange (DCX) neutral density: dcxdens(level,x,y,z)", error)
        call h5ltset_attribute_string_f(fid,"/dcxdens","units","neutrals*cm^-3",error)
    endif

    if(inputs%calc_halo_dens.ge.1) then
        call h5ltmake_compressed_dataset_double_f(fid, "/halodens", 4, dims, &
             neut%halo, error)

        call h5ltset_attribute_string_f(fid,"/halodens","description", &
             "Neutral density of the beam halo: halodens(level,x,y,z)", error)
        call h5ltset_attribute_string_f(fid,"/halodens","units","neutrals*cm^-3",error)
    endif

    call h5ltset_attribute_string_f(fid, "/", "version", version, error)
    call h5ltset_attribute_string_f(fid,"/","description", &
         "Beam neutral density calculated by FIDASIM", error)

    !Close file
    call h5fclose_f(fid, error)

    !Close HDF5 interface
    call h5close_f(error)

    if(inputs%verbose.ge.1) then
        write(*,'(T4,a,a)') 'neutral density written to: ',trim(filename)
    endif

end subroutine write_neutrals

subroutine write_npa
    !+ Writes [[libfida:npa]] to a HDF5 file
    integer(HID_T) :: fid, gid
    integer(HSIZE_T), dimension(3) :: dim3
    integer(HSIZE_T), dimension(2) :: dim2
    integer(HSIZE_T), dimension(1) :: d
    integer :: error

    integer, dimension(:), allocatable :: dcount
    real(Float64), dimension(:,:), allocatable :: ri, rf
    real(Float64), dimension(:), allocatable :: weight, energy, pitch
    integer, dimension(:), allocatable :: det, orbit_type
    integer :: i, npart, c, start_index, end_index
    character(charlim) :: filename = ''
    logical :: do_write = .True.

#ifdef _MPI
    integer :: rank
    integer, dimension(:), allocatable :: npart_image

    rank = my_rank()
    allocate(npart_image(0:num_ranks()-1))
#endif

#ifdef _MPI
    if(my_rank().ne.0) do_write = .False.
#endif

    filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_npa.h5"

    if(do_write) then
        !Open HDF5 interface
        call h5open_f(error)

        !Create file overwriting any existing file
        call h5fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error)
    endif

    !! Active
    allocate(dcount(npa_chords%nchan))
    npart = npa%npart
    if(npart.gt.0) then
        do i=1,npa_chords%nchan
            dcount(i) = count(npa%part%detector.eq.i)
        enddo
    else
        dcount = 0
    endif

#ifdef _MPI
    call parallel_sum(dcount)
    call parallel_sum(npart)
#endif

    c = 0
#ifdef _MPI
    npart_image(:) = 0
    npart_image(rank) = npa%npart
    call parallel_sum(npart_image)

    do i=0,rank-1
        c = c +  npart_image(i)
    enddo
#endif
    start_index = 1 + c
    end_index = npa%npart + c

    if(npart.gt.0) then
        allocate(ri(3,npart),rf(3,npart))
        allocate(weight(npart),energy(npart),pitch(npart))
        allocate(det(npart),orbit_type(npart))
        ri = 0.d0     ; rf = 0.d0
        weight = 0.d0 ; energy = 0.d0
        pitch = 0.d0  ; det = 0
        orbit_type = 0
        c = 1
        do i=start_index, end_index
            ri(1,i) = npa%part(c)%xi
            ri(2,i) = npa%part(c)%yi
            ri(3,i) = npa%part(c)%zi
            rf(1,i) = npa%part(c)%xf
            rf(2,i) = npa%part(c)%yf
            rf(3,i) = npa%part(c)%zf
            weight(i) = npa%part(c)%weight
            energy(i) = npa%part(c)%energy
            pitch(i) = npa%part(c)%pitch
            det(i) = npa%part(c)%detector
            orbit_type(i) = npa%part(c)%class
            c = c + 1
        enddo
#ifdef _MPI
        call parallel_sum(ri)
        call parallel_sum(rf)
        call parallel_sum(weight)
        call parallel_sum(energy)
        call parallel_sum(pitch)
        call parallel_sum(det)
        call parallel_sum(orbit_type)
#endif
    endif

    if(do_write.and.(inputs%calc_npa.ge.1)) then
        !Write Active Flux
        d(1) = 1
        dim2 = [npa%nenergy, npa%nchan]
        dim3 = [npa%nenergy, npa%nchan, particles%nclass]
        if(particles%nclass.gt.1) then
            call h5ltmake_dataset_int_f(fid,"/nclass", 0, d, [particles%nclass], error)
            call h5ltmake_compressed_dataset_double_f(fid,"/flux",3,dim3,npa%flux, error)
            call h5ltset_attribute_string_f(fid,"/flux", "description", &
                 "Active Neutral flux: flux(energy,chan,class)", error)
        else
            call h5ltmake_compressed_dataset_double_f(fid,"/flux",2,dim3(1:2),npa%flux(:,:,1), error)
            call h5ltset_attribute_string_f(fid,"/flux", "description", &
                 "Active Neutral flux: flux(energy,chan)", error)
        endif
        call h5ltset_attribute_string_f(fid,"/flux", "units","neutrals/(s*dE)", error)

        call h5ltmake_dataset_int_f(fid,"/nenergy", 0, d, [npa%nenergy], error)
        call h5ltmake_dataset_int_f(fid,"/nchan", 0, d, [npa%nchan], error)
        call h5ltmake_compressed_dataset_double_f(fid,"/energy",1,dim2(1:1),&
             npa%energy, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/radius",1,dim2(2:2),&
             npa_chords%radius, error)
        call h5ltmake_compressed_dataset_int_f(fid,"/count",1,dim2(2:2), dcount, error)

        !Add attributes
        call h5ltset_attribute_string_f(fid, "/", "version", version, error)
        call h5ltset_attribute_string_f(fid,"/","description", &
             "NPA flux calculated by FIDASIM",error)
        call h5ltset_attribute_string_f(fid,"/nenergy","description",&
             "Number of energy values",error)
        call h5ltset_attribute_string_f(fid,"/nchan","description",&
             "Number of channels",error)
        call h5ltset_attribute_string_f(fid,"/energy","description", &
             "Energy array", error)
        call h5ltset_attribute_string_f(fid,"/energy","units","keV", error)
        call h5ltset_attribute_string_f(fid,"/radius","description", &
             "Detector line of sight radius at midplane or tangency point", error)
        call h5ltset_attribute_string_f(fid,"/radius","units","cm",error)
        call h5ltset_attribute_string_f(fid,"/count","description", &
             "Number of particles that hit the detector: count(chan)", error)


        if((npart.gt.0).and.(inputs%calc_npa.ge.2)) then
            !Create Group
            call h5gcreate_f(fid,"/particles",gid, error)
            call h5ltmake_dataset_int_f(gid, "nparticle", 0, d, [npart], error)
            d(1) = npart
            dim2 = [3, npart]
            call h5ltmake_compressed_dataset_double_f(gid,"ri",2,dim2, ri, error)
            call h5ltmake_compressed_dataset_double_f(gid,"rf",2,dim2, rf, error)
            call h5ltmake_compressed_dataset_double_f(gid,"pitch",1,d, pitch, error)
            call h5ltmake_compressed_dataset_double_f(gid,"energy",1,d, energy, error)
            call h5ltmake_compressed_dataset_double_f(gid,"weight",1,d, weight, error)
            call h5ltmake_compressed_dataset_int_f(gid,"detector",1,d, det, error)
            call h5ltmake_compressed_dataset_int_f(gid,"class",1,d, orbit_type, error)

            !Add attributes
            call h5ltset_attribute_string_f(gid,"nparticle","description", &
                 "Number of particles that hit a detector", error)
            call h5ltset_attribute_string_f(gid,"ri","description", &
                 "Neutral particle's birth position in machine coordinates: ri([x,y,z],particle)", error)
            call h5ltset_attribute_string_f(gid,"ri","units", "cm", error)
            call h5ltset_attribute_string_f(gid,"rf","description", &
                 "Neutral particle's hit position in machine coordinates: rf([x,y,z],particle)", error)
            call h5ltset_attribute_string_f(gid,"rf","units", "cm", error)
            call h5ltset_attribute_string_f(gid,"pitch","description", &
                 "Pitch value of the neutral particle: p = v_parallel/v  w.r.t. the magnetic field", error)
            call h5ltset_attribute_string_f(gid,"energy","description", &
                 "Energy value of the neutral particle", error)
            call h5ltset_attribute_string_f(gid,"energy","units","keV",error)
            call h5ltset_attribute_string_f(gid,"weight","description", &
                 "Neutral particle's contribution to the flux", error)
            call h5ltset_attribute_string_f(gid,"weight","units","neutrals/s",error)
            call h5ltset_attribute_string_f(gid,"detector","description", &
                 "Detector that the neutral particle hit", error)
            call h5ltset_attribute_string_f(gid,"class","description", &
                 "Class of the neutral particle", error)

            call h5ltset_attribute_string_f(fid,"/particles","coordinate_system", &
                 "Right-handed cartesian",error)
            call h5ltset_attribute_string_f(fid,"/particles","description", &
                 "Active NPA Monte Carlo particles",error)

            !Close group
            call h5gclose_f(gid, error)
        endif
    endif

    deallocate(dcount)
    if(npart.gt.0) then
        deallocate(ri,rf)
        deallocate(energy,pitch,weight,det,orbit_type)
    endif

    !! Passive
    allocate(dcount(npa_chords%nchan))
    npart = pnpa%npart
    if(npart.gt.0) then
        do i=1,npa_chords%nchan
            dcount(i) = count(pnpa%part%detector.eq.i)
        enddo
    else
        dcount = 0
    endif

#ifdef _MPI
    call parallel_sum(dcount)
    call parallel_sum(npart)
#endif

    c = 0
#ifdef _MPI
    npart_image(:) = 0
    npart_image(rank) = pnpa%npart
    call parallel_sum(npart_image)

    do i=0,rank-1
        c = c +  npart_image(i)
    enddo
#endif
    start_index = 1 + c
    end_index = pnpa%npart + c

    if(npart.gt.0) then
        allocate(ri(3,npart),rf(3,npart))
        allocate(weight(npart),energy(npart),pitch(npart))
        allocate(det(npart),orbit_type(npart))
        ri = 0.d0     ; rf = 0.d0
        weight = 0.d0 ; energy = 0.d0
        pitch = 0.d0  ; det = 0
        orbit_type = 0
        c = 1
        do i=start_index, end_index
            ri(1,i) = pnpa%part(c)%xi
            ri(2,i) = pnpa%part(c)%yi
            ri(3,i) = pnpa%part(c)%zi
            rf(1,i) = pnpa%part(c)%xf
            rf(2,i) = pnpa%part(c)%yf
            rf(3,i) = pnpa%part(c)%zf
            weight(i) = pnpa%part(c)%weight
            energy(i) = pnpa%part(c)%energy
            pitch(i) = pnpa%part(c)%pitch
            det(i) = pnpa%part(c)%detector
            orbit_type(i) = pnpa%part(c)%class
            c = c + 1
        enddo
#ifdef _MPI
        call parallel_sum(ri)
        call parallel_sum(rf)
        call parallel_sum(weight)
        call parallel_sum(energy)
        call parallel_sum(pitch)
        call parallel_sum(det)
        call parallel_sum(orbit_type)
#endif
    endif

    if(do_write.and.(inputs%calc_pnpa.ge.1)) then
        !Write Passive Flux
        d(1) = 1
        dim2 = [pnpa%nenergy, pnpa%nchan]
        dim3 = [pnpa%nenergy, pnpa%nchan, particles%nclass]
        if(particles%nclass.gt.1) then
            call h5ltmake_compressed_dataset_double_f(fid,"/pflux",3,dim3,pnpa%flux, error)
            call h5ltset_attribute_string_f(fid,"/pflux", "description", &
                 "Passive Neutral flux: pflux(energy,chan,class)", error)
        else
            call h5ltmake_compressed_dataset_double_f(fid,"/pflux",2,dim3(1:2),pnpa%flux(:,:,1), error)
            call h5ltset_attribute_string_f(fid,"/pflux", "description", &
                 "Passive Neutral flux: pflux(energy,chan)", error)
        endif
        call h5ltset_attribute_string_f(fid,"/pflux", "units","neutrals/(s*dE)", error)
        call h5ltmake_compressed_dataset_int_f(fid,"/pcount",1,dim2(2:2), dcount, error)
        call h5ltset_attribute_string_f(fid,"/pcount","description", &
             "Number of passive particles that hit the detector: pcount(chan)", error)

        if(inputs%calc_npa.le.0) then
            call h5ltmake_dataset_int_f(fid,"/nenergy", 0, d, [pnpa%nenergy], error)
            call h5ltmake_dataset_int_f(fid,"/nchan", 0, d, [pnpa%nchan], error)
            call h5ltmake_compressed_dataset_double_f(fid,"/energy",1,dim2(1:1),&
                 pnpa%energy, error)
            call h5ltmake_compressed_dataset_double_f(fid,"/radius",1,dim2(2:2),&
                 npa_chords%radius, error)

            !Add attributes
            call h5ltset_attribute_string_f(fid, "/", "version", version, error)
            call h5ltset_attribute_string_f(fid,"/","description", &
                 "NPA flux calculated by FIDASIM",error)
            call h5ltset_attribute_string_f(fid,"/nenergy","description",&
                 "Number of energy values",error)
            call h5ltset_attribute_string_f(fid,"/nchan","description",&
                 "Number of channels",error)
            call h5ltset_attribute_string_f(fid,"/energy","description", &
                 "Energy array", error)
            call h5ltset_attribute_string_f(fid,"/energy","units","keV", error)
            call h5ltset_attribute_string_f(fid,"/radius","description", &
                 "Detector line of sight radius at midplane or tangency point", error)
            call h5ltset_attribute_string_f(fid,"/radius","units","cm",error)
        endif

        if((npart.gt.0).and.(inputs%calc_pnpa.ge.2)) then
            !Create Group
            call h5gcreate_f(fid,"/passive_particles",gid, error)
            call h5ltmake_dataset_int_f(gid, "nparticle", 0, d, [npart], error)
            d(1) = npart
            dim2 = [3, npart]
            call h5ltmake_compressed_dataset_double_f(gid,"ri",2,dim2, ri, error)
            call h5ltmake_compressed_dataset_double_f(gid,"rf",2,dim2, rf, error)
            call h5ltmake_compressed_dataset_double_f(gid,"pitch",1,d, pitch, error)
            call h5ltmake_compressed_dataset_double_f(gid,"energy",1,d, energy, error)
            call h5ltmake_compressed_dataset_double_f(gid,"weight",1,d, weight, error)
            call h5ltmake_compressed_dataset_int_f(gid,"detector",1,d, det, error)
            call h5ltmake_compressed_dataset_int_f(gid,"class",1,d, orbit_type, error)

            !Add attributes
            call h5ltset_attribute_string_f(gid,"nparticle","description", &
                 "Number of particles that hit a detector", error)
            call h5ltset_attribute_string_f(gid,"ri","description", &
                 "Neutral particle's birth position in machine coordinates: ri([x,y,z],particle)", error)
            call h5ltset_attribute_string_f(gid,"ri","units", "cm", error)
            call h5ltset_attribute_string_f(gid,"rf","description", &
                 "Neutral particle's hit position in machine coordinates: rf([x,y,z],particle)", error)
            call h5ltset_attribute_string_f(gid,"rf","units", "cm", error)
            call h5ltset_attribute_string_f(gid,"pitch","description", &
                 "Pitch value of the neutral particle: p = v_parallel/v  w.r.t. the magnetic field", error)
            call h5ltset_attribute_string_f(gid,"energy","description", &
                 "Energy value of the neutral particle", error)
            call h5ltset_attribute_string_f(gid,"energy","units","keV",error)
            call h5ltset_attribute_string_f(gid,"weight","description", &
                 "Neutral particle's contribution to the flux", error)
            call h5ltset_attribute_string_f(gid,"weight","units","neutrals/s",error)
            call h5ltset_attribute_string_f(gid,"detector","description", &
                 "Detector that the neutral particle hit", error)
            call h5ltset_attribute_string_f(gid,"class","description", &
                 "Class of the neutral particle", error)

            call h5ltset_attribute_string_f(fid,"/passive_particles","coordinate_system", &
                 "Right-handed cartesian",error)
            call h5ltset_attribute_string_f(fid,"/passive_particles","description", &
                 "Passive NPA Monte Carlo particles",error)

            !Close group
            call h5gclose_f(gid, error)
        endif
    endif

    if(do_write) then
        !Close file
        call h5fclose_f(fid, error)

        !Close HDF5 interface
        call h5close_f(error)
    endif

    if(inputs%verbose.ge.1) then
        write(*,'(T4,a,a)') 'NPA data written to: ',trim(filename)
    endif

#ifdef _MPI
    deallocate(npart_image)
#endif

end subroutine write_npa

subroutine write_spectra
    !+ Writes [[libfida:spectra]] to a HDF5 file
    integer(HID_T) :: fid
    integer(HSIZE_T), dimension(3) :: dims
    integer(HSIZE_T), dimension(1) :: d
    integer :: error

    character(charlim) :: filename
    integer :: i
    real(Float64) :: factor
    real(Float64), dimension(:), allocatable :: lambda_arr

    allocate(lambda_arr(inputs%nlambda))
    do i=1,inputs%nlambda
        lambda_arr(i) = (i-0.5)*inputs%dlambda + inputs%lambdamin
    enddo

    !! convert [Ph/(s*wavel_bin*cm^2*all_directions)] to [Ph/(s*nm*sr*m^2)]!
    factor = 1.d0/(inputs%dlambda)/(4.d0*pi)*1.d4

    !! write to file
    filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_spectra.h5"

    !Open HDF5 interface
    call h5open_f(error)

    !Create file overwriting any existing file
    call h5fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error)

    !Write variables
    d(1) = 1
    call h5ltmake_dataset_int_f(fid, "/nchan", 0, d, [spec_chords%nchan], error)
    call h5ltmake_dataset_int_f(fid, "/nlambda", 0, d, [inputs%nlambda], error)
    dims(1) = inputs%nlambda
    dims(2) = spec_chords%nchan
    dims(3) = particles%nclass
    call h5ltmake_compressed_dataset_double_f(fid, "/lambda", 1, dims(1:1), &
         lambda_arr, error)
    call h5ltmake_compressed_dataset_double_f(fid, "/radius", 1, dims(2:2), &
         spec_chords%radius, error)

    !Add attributes
    call h5ltset_attribute_string_f(fid,"/nchan", "description", &
         "Number of channels", error)
    call h5ltset_attribute_string_f(fid,"/nlambda", "description", &
         "Number of wavelengths", error)
    call h5ltset_attribute_string_f(fid,"/lambda","description", &
         "Wavelength array", error)
    call h5ltset_attribute_string_f(fid,"/lambda","units","nm", error)
    call h5ltset_attribute_string_f(fid,"/radius", "description", &
         "Line of sight radius at midplane or tangency point", error)
    call h5ltset_attribute_string_f(fid,"/radius","units","cm", error)

    if(inputs%calc_brems.ge.1) then
        spec%brems = factor*spec%brems
        !Write variables
        call h5ltmake_compressed_dataset_double_f(fid, "/brems", 2, &
             dims(1:2), spec%brems, error)
        !Add attributes
        call h5ltset_attribute_string_f(fid,"/brems","description", &
             "Visible Bremsstrahlung: brems(lambda,chan)", error)
        call h5ltset_attribute_string_f(fid,"/brems","units",&
             "Ph/(s*nm*sr*m^2)",error )
    endif

    if(inputs%calc_bes.ge.1) then
        spec%full  = factor*spec%full
        spec%half  = factor*spec%half
        spec%third = factor*spec%third
        !Write variables
        call h5ltmake_compressed_dataset_double_f(fid, "/full", 2, dims(1:2), &
             spec%full, error)
        call h5ltmake_compressed_dataset_double_f(fid, "/half", 2, dims(1:2), &
             spec%half, error)
        call h5ltmake_compressed_dataset_double_f(fid, "/third", 2, dims(1:2),&
             spec%third, error)
        !Add attributes
        call h5ltset_attribute_string_f(fid,"/full","description", &
             "Full energy component of the beam emmision: full(lambda,chan)", error)
        call h5ltset_attribute_string_f(fid,"/full","units","Ph/(s*nm*sr*m^2)",error )
        call h5ltset_attribute_string_f(fid,"/half","description", &
             "Half energy component of the beam emmision: half(lambda,chan)", error)
        call h5ltset_attribute_string_f(fid,"/half","units","Ph/(s*nm*sr*m^2)",error )
        call h5ltset_attribute_string_f(fid,"/third","description", &
             "Third energy component of the beam emmision: third(lambda,chan)", error)
        call h5ltset_attribute_string_f(fid,"/third","units","Ph/(s*nm*sr*m^2)",error )
    endif

    if(inputs%calc_dcx.ge.1) then
        spec%dcx   = factor*spec%dcx
        call h5ltmake_compressed_dataset_double_f(fid, "/dcx", 2, dims(1:2), &
             spec%dcx, error)
        call h5ltset_attribute_string_f(fid,"/dcx","description", &
             "Direct Charge Exchange (DCX) emission: dcx(lambda,chan)", error)
        call h5ltset_attribute_string_f(fid,"/dcx","units","Ph/(s*nm*sr*m^2)",error )
    endif

    if(inputs%calc_halo.ge.1) then
        spec%halo  = factor*spec%halo
        call h5ltmake_compressed_dataset_double_f(fid, "/halo", 2, dims(1:2), &
             spec%halo, error)
        call h5ltset_attribute_string_f(fid,"/halo","description", &
             "Halo component of the beam emmision: halo(lambda,chan)", error)
        call h5ltset_attribute_string_f(fid,"/halo","units","Ph/(s*nm*sr*m^2)",error )
    endif

    if(inputs%calc_cold.ge.1) then
        spec%cold  = factor*spec%cold
        call h5ltmake_compressed_dataset_double_f(fid, "/cold", 2, dims(1:2), &
             spec%cold, error)
        call h5ltset_attribute_string_f(fid,"/cold","description", &
             "Cold D-alpha emission: cold(lambda,chan)", error)
        call h5ltset_attribute_string_f(fid,"/cold","units","Ph/(s*nm*sr*m^2)",error )
    endif

    if(inputs%calc_fida.ge.1) then
        spec%fida  = factor*spec%fida
        !Write variables
        if(particles%nclass.le.1) then
            call h5ltmake_compressed_dataset_double_f(fid, "/fida", 2, &
                 dims(1:2), spec%fida(:,:,1), error)
            !Add attributes
            call h5ltset_attribute_string_f(fid,"/fida","description", &
                 "Active Fast-ion D-alpha (FIDA) emmision: fida(lambda,chan)", error)
        else
            call h5ltmake_dataset_int_f(fid,"/nclass", 0, d, [particles%nclass], error)
            call h5ltmake_compressed_dataset_double_f(fid, "/fida", 3, &
                 dims, spec%fida, error)
            !Add attributes
            call h5ltset_attribute_string_f(fid,"/fida","description", &
                 "Active Fast-ion D-alpha (FIDA) emmision: fida(lambda,chan,class)", error)
       endif
        call h5ltset_attribute_string_f(fid,"/fida","units","Ph/(s*nm*sr*m^2)",error )
    endif

    if(inputs%calc_pfida.ge.1) then
        spec%pfida = factor*spec%pfida
        !Write variables
        if(particles%nclass.le.1) then
            call h5ltmake_compressed_dataset_double_f(fid, "/pfida", 2, &
                 dims(1:2), spec%pfida(:,:,1), error)
            !Add attributes
            call h5ltset_attribute_string_f(fid,"/pfida","description", &
                 "Passive Fast-ion D-alpha (p-FIDA) emmision: pfida(lambda,chan)", error)
        else
            if(inputs%calc_fida.le.0) then
                call h5ltmake_dataset_int_f(fid,"/nclass", 0, d, [particles%nclass], error)
            endif
            call h5ltmake_compressed_dataset_double_f(fid, "/pfida", 3, &
                 dims, spec%pfida, error)
            !Add attributes
            call h5ltset_attribute_string_f(fid,"/pfida","description", &
                 "Passive Fast-ion D-alpha (p-FIDA) emmision: pfida(lambda,chan,class)", error)
       endif
        call h5ltset_attribute_string_f(fid,"/pfida","units","Ph/(s*nm*sr*m^2)",error )
    endif

    call h5ltset_attribute_string_f(fid, "/", "version", version, error)
    call h5ltset_attribute_string_f(fid,"/","description",&
         "Spectra calculated by FIDASIM", error)

    !Close file
    call h5fclose_f(fid, error)

    !Close HDF5 interface
    call h5close_f(error)

    if(inputs%verbose.ge.1) then
        write(*,'(T4,a,a)') 'Spectra written to: ', trim(filename)
    endif

end subroutine write_spectra

subroutine write_neutrons
    !+ Writes [[libfida:neutron]] to a HDF5 file
    integer(HID_T) :: fid
    integer(HSIZE_T), dimension(1) :: dim1
    integer(HSIZE_T), dimension(3) :: dim3
    integer(HSIZE_T), dimension(5) :: dim5
    integer :: error

    character(charlim) :: filename

    !! write to file
    filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_neutrons.h5"

    !Open HDF5 interface
    call h5open_f(error)

    !Create file overwriting any existing file
    call h5fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error)

    !Write variables
    if(particles%nclass.gt.1) then
        dim1(1) = 1
        call h5ltmake_dataset_int_f(fid,"/nclass", 0, dim1, [particles%nclass], error)
        dim1(1) = particles%nclass
        call h5ltmake_compressed_dataset_double_f(fid, "/rate", 1, dim1, neutron%rate, error)
        call h5ltset_attribute_string_f(fid,"/rate","description", &
             "Neutron rate: rate(orbit_class)", error)
    else
        dim1(1) = 1
        call h5ltmake_dataset_double_f(fid, "/rate", 0, dim1, neutron%rate, error)
        call h5ltset_attribute_string_f(fid,"/rate","description", &
             "Neutron rate", error)
    endif
    call h5ltset_attribute_string_f(fid,"/rate","units","neutrons/s",error )

    if((inputs%dist_type.eq.1).and.(inputs%calc_neutron.ge.2)) then
        dim1(1) = 1
        call h5ltmake_dataset_int_f(fid,"/nenergy",0,dim1,[fbm%nenergy], error)
        call h5ltmake_dataset_int_f(fid,"/npitch",0,dim1,[fbm%npitch], error)
        call h5ltmake_dataset_int_f(fid,"/nr",0,dim1,[fbm%nr], error)
        call h5ltmake_dataset_int_f(fid,"/nz",0,dim1,[fbm%nz], error)
        dim5 = shape(neutron%weight)
        call h5ltmake_compressed_dataset_double_f(fid, "/weight", 5, dim5, neutron%weight, error)
        dim3 = shape(neutron%emis)
        call h5ltmake_compressed_dataset_double_f(fid, "/emissivity", 3, dim3, neutron%emis, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/energy", 1, dim5(1:1), fbm%energy, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/pitch", 1, dim5(2:2), fbm%pitch, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/r", 1, dim5(3:3), fbm%r, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/z", 1, dim5(4:4), fbm%z, error)
        call h5ltmake_compressed_dataset_double_f(fid,"/phi", 1, dim5(5:5), fbm%phi, error)

        call h5ltset_attribute_string_f(fid,"/nenergy", "description", &
             "Number of energy values", error)
        call h5ltset_attribute_string_f(fid,"/npitch", "description", &
             "Number of pitch values", error)
        call h5ltset_attribute_string_f(fid,"/nr", "description", &
             "Number of R values", error)
        call h5ltset_attribute_string_f(fid,"/nz", "description", &
             "Number of Z values", error)
        call h5ltset_attribute_string_f(fid,"/weight", "description", &
             "Neutron Weight Function: weight(E,p,R,Z,Phi), rate = sum(f*weight)", error)
        call h5ltset_attribute_string_f(fid,"/weight", "units","neutrons*cm^3*dE*dp/fast-ion*s", error)
        call h5ltset_attribute_string_f(fid,"/emissivity", "description", &
             "Neutron Emissivity: emissivity(R,Z,Phi), rate = sum(emissivity)", error)
        call h5ltset_attribute_string_f(fid,"/emissivity", "units","neutrons*cm^3/fast-ion*s", error)

        call h5ltset_attribute_string_f(fid,"/energy","description", &
             "Energy array", error)
        call h5ltset_attribute_string_f(fid,"/energy", "units","keV", error)
        call h5ltset_attribute_string_f(fid,"/pitch", "description", &
             "Pitch array: p = v_parallel/v  w.r.t. the magnetic field", error)
        call h5ltset_attribute_string_f(fid,"/r","description", &
             "Radius array", error)
        call h5ltset_attribute_string_f(fid,"/r", "units","cm", error)
        call h5ltset_attribute_string_f(fid,"/z","description", &
             "Z array", error)
        call h5ltset_attribute_string_f(fid,"/z", "units","cm", error)
    endif

    call h5ltset_attribute_string_f(fid, "/", "version", version, error)
    call h5ltset_attribute_string_f(fid,"/","description",&
         "Neutron rate calculated by FIDASIM", error)

    !Close file
    call h5fclose_f(fid, error)

    !Close HDF5 interface
    call h5close_f(error)

    if(inputs%verbose.ge.1) then
        write(*,'(T4,a,a)') 'Neutrons written to: ', trim(filename)
    endif

end subroutine write_neutrons

subroutine write_fida_weights
    !+ Writes [[libfida:fweight]] to a HDF5 file
    !! HDF5 variables
    integer(HID_T) :: fid
    integer(HSIZE_T), dimension(4) :: dim4
    integer(HSIZE_T), dimension(2) :: dim2
    integer(HSIZE_T), dimension(1) :: dim1
    integer :: error

    character(charlim) :: filename
    integer :: i,ie,ip,ic,iwav
    real(Float64), dimension(:),   allocatable :: lambda_arr
    real(Float64), dimension(:),   allocatable :: ebarr,ptcharr
    real(Float64), dimension(:,:), allocatable :: jacobian,e_grid,p_grid
    real(Float64), dimension(:,:), allocatable :: vpa_grid,vpe_grid,fida
    real(Float64) :: dlambda, wtot, dE, dP

    dlambda=(inputs%lambdamax_wght-inputs%lambdamin_wght)/inputs%nlambda_wght
    allocate(lambda_arr(inputs%nlambda_wght))
    do i=1,inputs%nlambda_wght
        lambda_arr(i)=(i-0.5)*dlambda + inputs%lambdamin_wght
    enddo

    !! define arrays
    !! define energy - array
    allocate(ebarr(inputs%ne_wght))
    do i=1,inputs%ne_wght
        ebarr(i)=real(i-0.5)*inputs%emax_wght/real(inputs%ne_wght)
    enddo
    dE = abs(ebarr(2)-ebarr(1))

    !! define pitch - array
    allocate(ptcharr(inputs%np_wght))
    do i=1,inputs%np_wght
        ptcharr(i)=real(i-0.5)*2./real(inputs%np_wght)-1.
    enddo
    dP = abs(ptcharr(2)-ptcharr(1))

    !! define 2d grids
    !! define energy grid
    allocate(e_grid(inputs%ne_wght,inputs%np_wght))
    do i=1,inputs%ne_wght
        e_grid(i,:) = ebarr(i)
    enddo

    !! define pitch grid
    allocate(p_grid(inputs%ne_wght,inputs%np_wght))
    do i=1,inputs%np_wght
        p_grid(:,i) = ptcharr(i)
    enddo

    !! define velocity space grid
    allocate(vpe_grid(inputs%ne_wght,inputs%np_wght)) !! V perpendicular
    allocate(vpa_grid(inputs%ne_wght,inputs%np_wght)) !! V parallel
    vpa_grid = 100*sqrt((((2.0d3)*e0)/(mass_u*inputs%ab))*e_grid)*p_grid ! [cm/s]
    vpe_grid = 100*sqrt((((2.0d3)*e0)/(mass_u*inputs%ab))*e_grid*(1.0-p_grid**2)) ![cm/s]

    !! define jacobian to convert between E-p to velocity
    allocate(jacobian(inputs%ne_wght,inputs%np_wght))
    jacobian = ((inputs%ab*mass_u)/(e0*1.0d3)) *vpe_grid/sqrt(vpa_grid**2 + vpe_grid**2)

    !! normalize mean_f
    do ic=1,spec_chords%nchan
        do ip=1,inputs%np_wght
            do ie=1,inputs%ne_wght
                wtot = sum(fweight%weight(:,ie,ip,ic))
                if((wtot.gt.0.d0)) then
                    fweight%mean_f(ie,ip,ic) = fweight%mean_f(ie,ip,ic)/wtot
                endif
            enddo
        enddo
    enddo

    !! Calculate FIDA estimate
    allocate(fida(inputs%nlambda_wght,spec_chords%nchan))
    do iwav=1,size(fida,1)
        fida(iwav,:) = (dE*dP*1d4)*sum(sum(fweight%mean_f(:,:,:)*fweight%weight(iwav,:,:,:),1),1)
    enddo

    filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_fida_weights.h5"

    !Open HDF5 interface
    call h5open_f(error)

    !Create file overwriting any existing file
    call h5fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error)

    dim1(1) = 1
    dim2 = [inputs%nlambda_wght, spec_chords%nchan]
    dim4 = [inputs%nlambda_wght, inputs%ne_wght, inputs%np_wght, spec_chords%nchan]
    call h5ltmake_dataset_int_f(fid,"/nenergy",0,dim1,[inputs%ne_wght], error)
    call h5ltmake_dataset_int_f(fid,"/npitch",0,dim1,[inputs%np_wght], error)
    call h5ltmake_dataset_int_f(fid,"/nchan",0,dim1,[spec_chords%nchan], error)
    call h5ltmake_compressed_dataset_double_f(fid,"/weight",4,dim4,fweight%weight,error)
    call h5ltmake_compressed_dataset_double_f(fid,"/fida",2,dim2,fida,error)
    call h5ltmake_compressed_dataset_double_f(fid,"/mean_f",3,dim4(2:4),fweight%mean_f,error)
    call h5ltmake_compressed_dataset_double_f(fid,"/lambda",1,dim4(1:1),lambda_arr,error)
    call h5ltmake_compressed_dataset_double_f(fid,"/energy",1,dim4(2:2),ebarr, error)
    call h5ltmake_compressed_dataset_double_f(fid,"/pitch",1,dim4(3:3),ptcharr, error)
    call h5ltmake_compressed_dataset_double_f(fid,"/radius",1,dim4(4:4),spec_chords%radius, error)
    dim2 = [inputs%ne_wght, inputs%np_wght]
    call h5ltmake_compressed_dataset_double_f(fid,"/jacobian",2,dim2, jacobian, error)
    call h5ltmake_compressed_dataset_double_f(fid,"/vpe_grid",2,dim2,vpe_grid, error)
    call h5ltmake_compressed_dataset_double_f(fid,"/vpa_grid",2,dim2,vpa_grid, error)
    call h5ltmake_compressed_dataset_double_f(fid,"/e_grid",2,dim2,e_grid, error)
    call h5ltmake_compressed_dataset_double_f(fid,"/p_grid",2,dim2,p_grid, error)

    !Add attributes
    call h5ltset_attribute_string_f(fid, "/", "version", version, error)
    if(inputs%calc_fida_wght.eq.1) then
        call h5ltset_attribute_string_f(fid,"/", "description", &
             "Line of Sight averaged FIDA E-p space sensitivity/weights " // &
             "and spectra calculated by FIDASIM", error)
    else
        call h5ltset_attribute_string_f(fid,"/", "description", &
             "Full FIDA E-p space sensitivity/weights and spectra calculated " // &
             "by FIDASIM via Monte Carlo method", error)
    endif
    call h5ltset_attribute_string_f(fid,"/weight","description", &
         "E-p space sensivity/weight of FIDA diagnostic: weight(lambda,energy,pitch,chan)", error)
    call h5ltset_attribute_string_f(fid,"/weight","units", &
         "(Ph*cm)/(s*nm*sr*fast-ion*dE*dP)",error)
    call h5ltset_attribute_string_f(fid,"/fida","units", &
         "Ph/(s*nm*sr*m^2)",error )
    call h5ltset_attribute_string_f(fid,"/fida","description", &
         "Estimate of Fast-ion D-alpha (FIDA) emmision calculated by 1e4*weight*mean_f*dEdP: fida(lambda,chan)", error)
    call h5ltset_attribute_string_f(fid,"/mean_f","description", &
         "Estimated mean fast-ion distribution function seen by los: mean_f(energy,pitch,chan)", error)
    call h5ltset_attribute_string_f(fid,"/mean_f","units", &
         "fast-ion/(dE*dP*cm^3)", error)
    call h5ltset_attribute_string_f(fid,"/lambda","description", &
         "Wavelength array", error)
    call h5ltset_attribute_string_f(fid,"/lambda","units","nm", error)
    call h5ltset_attribute_string_f(fid,"/nchan", "description", &
         "Number of channels", error)
    call h5ltset_attribute_string_f(fid,"/nenergy", "description", &
         "Number of energy values", error)
    call h5ltset_attribute_string_f(fid,"/npitch", "description", &
         "Number of pitch value", error)
    call h5ltset_attribute_string_f(fid,"/energy","description", &
         "Energy array", error)
    call h5ltset_attribute_string_f(fid,"/energy", "units","keV", error)
    call h5ltset_attribute_string_f(fid,"/pitch", "description", &
         "Pitch array: p = v_parallel/v  w.r.t. the magnetic field", error)
    call h5ltset_attribute_string_f(fid,"/radius", "description", &
         "Line of sight radius at midplane or tangency point", error)
    call h5ltset_attribute_string_f(fid,"/radius", "units","cm", error)
    call h5ltset_attribute_string_f(fid,"/jacobian","description", &
         "Jacobian used to convert from E-p space to velocity space", error)
    call h5ltset_attribute_string_f(fid,"/jacobian","units", &
         "(dE*dP)/(dvpa*dvpe)", error)
    call h5ltset_attribute_string_f(fid,"/e_grid","description", &
         "2D energy grid", error)
    call h5ltset_attribute_string_f(fid,"/e_grid","units","keV", error)
    call h5ltset_attribute_string_f(fid,"/p_grid","description", &
         "2D pitch grid", error)
    call h5ltset_attribute_string_f(fid,"/vpe_grid","description", &
         "2D perpendicular velocity grid", error)
    call h5ltset_attribute_string_f(fid,"/vpe_grid","units","cm/s", error)
    call h5ltset_attribute_string_f(fid,"/vpa_grid","description", &
         "2D parallel velocity grid", error)
    call h5ltset_attribute_string_f(fid,"/vpa_grid","units","cm/s", error)

    !Close file
    call h5fclose_f(fid, error)

    !Close HDF5 interface
    call h5close_f(error)

    if(inputs%verbose.ge.1) then
        write(*,'(T4,a,a)') 'FIDA weights written to: ', trim(filename)
    endif

end subroutine write_fida_weights

subroutine write_npa_weights
    !+ Writes [[libfida:nweight]] to a HDF5 file
    character(charlim) :: filename
    integer :: i
    real(Float64), dimension(:), allocatable :: ebarr,ptcharr

    !! HDF5 variables
    integer(HID_T) :: fid
    integer(HSIZE_T), dimension(5) :: dim5
    integer(HSIZE_T), dimension(3) :: dim3
    integer(HSIZE_T), dimension(2) :: dim2
    integer(HSIZE_T), dimension(1) :: d
    integer :: error

    !! define energy - array
    allocate(ebarr(inputs%ne_wght))
    do i=1,inputs%ne_wght
        ebarr(i)=real(i-0.5)*inputs%emax_wght/real(inputs%ne_wght)
    enddo

    !! define pitch - array
    allocate(ptcharr(inputs%np_wght))
    do i=1,inputs%np_wght
        ptcharr(i)=real(i-0.5)*2./real(inputs%np_wght)-1.
    enddo

    filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_npa_weights.h5"

    !Open HDF5 interface
    call h5open_f(error)

    !Create file overwriting any existing file
    call h5fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error)

    !Write variables
    d(1) = 1
    dim2 = [inputs%ne_wght, npa_chords%nchan]
    dim3 = [inputs%ne_wght, inputs%np_wght, npa_chords%nchan]
    dim5 = [inputs%ne_wght, beam_grid%nx, beam_grid%ny, beam_grid%nz, npa_chords%nchan]
    call h5ltmake_dataset_int_f(fid, "/nchan", 0, d, [npa_chords%nchan], error)
    call h5ltmake_dataset_int_f(fid, "/nenergy", 0, d, [inputs%ne_wght], error)
    call h5ltmake_dataset_int_f(fid, "/npitch", 0, d, [inputs%np_wght], error)
    call h5ltmake_compressed_dataset_double_f(fid, "/radius", 1, &
         dim2(2:2), npa_chords%radius, error)
    call h5ltmake_compressed_dataset_double_f(fid, "/energy", 1, &
         dim2(1:1), ebarr, error)
    call h5ltmake_compressed_dataset_double_f(fid, "/pitch", 1, &
         dim3(2:2), ptcharr, error)
    call h5ltmake_compressed_dataset_double_f(fid, "/flux", 2, &
         dim2, nweight%flux, error)
    call h5ltmake_compressed_dataset_double_f(fid, "/weight", 3, &
         dim3, nweight%weight, error)

    !Add attributes
    call h5ltset_attribute_string_f(fid, "/", "version", version, error)
    call h5ltset_attribute_string_f(fid,"/", "description", &
         "NPA E-p space sensitivity/weights and Flux calculated by FIDASIM", error)
    call h5ltset_attribute_string_f(fid,"/nchan", "description", &
         "Number of channels", error)
    call h5ltset_attribute_string_f(fid,"/nenergy", "description", &
         "Number of energy values", error)
    call h5ltset_attribute_string_f(fid,"/npitch", "description", &
         "Number of pitch value", error)
    call h5ltset_attribute_string_f(fid,"/energy","description", &
         "Energy array", error)
    call h5ltset_attribute_string_f(fid,"/energy", "units","keV", error)
    call h5ltset_attribute_string_f(fid,"/pitch", "description", &
         "Pitch array: p = v_parallel/v  w.r.t. the magnetic field", error)
    call h5ltset_attribute_string_f(fid,"/radius", "description", &
         "Line of sight radius at midplane or tangency point", error)
    call h5ltset_attribute_string_f(fid,"/radius", "units","cm", error)
    call h5ltset_attribute_string_f(fid,"/flux", "description", &
         "Neutral flux: flux(energy,chan)", error)
    call h5ltset_attribute_string_f(fid,"/flux", "units", &
         "neutrals/(s*dE)", error)
    call h5ltset_attribute_string_f(fid,"/weight", "description", &
         "E-p space sensivity/weight of NPA diagnostics: weight(energy,pitch,chan)", error)
    call h5ltset_attribute_string_f(fid,"/weight","units", &
         "neutrals/(s*fast-ion*dE*dP)",error)

    if(inputs%calc_npa_wght.ge.2) then !Write diagnostic variables
        call write_beam_grid(fid, error)
        call h5ltmake_compressed_dataset_double_f(fid, "/emissivity", 4, &
             dim5(2:5), nweight%emissivity, error)
        call h5ltmake_compressed_dataset_double_f(fid, "/attenuation", 5, &
             dim5, nweight%attenuation, error)
        call h5ltmake_compressed_dataset_double_f(fid, "/cx", 5, &
             dim5, nweight%cx, error)
        call h5ltmake_compressed_dataset_double_f(fid, "/phit", 4, &
             dim5(2:5), npa_chords%phit%p, error)

        call h5ltset_attribute_string_f(fid,"/emissivity", "description", &
             "Neutral emissivity: emissivity(x,y,z,chan)", error)
        call h5ltset_attribute_string_f(fid,"/emissivity", "units", &
             "neutrals/(s*dV)", error)
        call h5ltset_attribute_string_f(fid,"/cx", "description", &
             "Charge-exchange rate: cx(energy,x,y,z,chan)", error)
        call h5ltset_attribute_string_f(fid,"/cx", "units", "s^(-1)", error)
        call h5ltset_attribute_string_f(fid,"/attenuation","description", &
             "Attenuation factor i.e. survival probability: attenuation(energy,x,y,z,chan)", error)
        call h5ltset_attribute_string_f(fid,"/phit","description", &
             "Probability of hitting the detector given an isotropic source: phit(x,y,z,chan)", error)
    endif

    !Close file
    call h5fclose_f(fid, error)

    !Close HDF5 interface
    call h5close_f(error)
    if(inputs%verbose.ge.1) then
        write(*,'(T4,a,a)') 'NPA weights written to: ',trim(filename)
    endif

end subroutine write_npa_weights

subroutine read_neutrals
    !+ Reads neutral density from file and puts it in [[libfida:neut]]
    integer(HID_T) :: fid, gid
    integer(HSIZE_T), dimension(4) :: dims
    integer :: error,nx,ny,nz
    logical :: exis,fatal_error

    if(inputs%verbose.ge.1) then
        write(*,'(a)') '---- loading neutrals ----'
    endif

    inquire(file=inputs%neutrals_file,exist=exis)
    if(exis) then
        if(inputs%verbose.ge.1) then
            write(*,'(T2,"Neutrals file: ",a)') trim(inputs%neutrals_file)
            write(*,*) ''
        endif
    else
        if(inputs%verbose.ge.0) then
            write(*,'(a,a)') 'READ_NEUTRALS: Neutrals file does not exist: ',inputs%neutrals_file
        endif
        stop
    endif

    !Open HDF5 interface
    call h5open_f(error)

    !Create file overwriting any existing file
    call h5fopen_f(inputs%neutrals_file, H5F_ACC_RDONLY_F, fid, error)

    call h5gopen_f(fid, "/grid", gid, error)
    call h5ltread_dataset_int_scalar_f(gid,"nx", nx, error)
    call h5ltread_dataset_int_scalar_f(gid,"ny", ny, error)
    call h5ltread_dataset_int_scalar_f(gid,"nz", nz, error)
    call h5gclose_f(gid, error)

    fatal_error = .False.
    if((nx.ne.beam_grid%nx).or. &
       (ny.ne.beam_grid%ny).or. &
       (nz.ne.beam_grid%nz)) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'READ_NEUTRALS: Neutrals file has incompatable grid dimensions'
        endif
        fatal_error = .True.
    endif

    !Check to make sure the neutrals file has all the needed neutrals
    call h5ltpath_valid_f(fid, "/fdens", .True., exis, error)
    if((.not.exis).and.(inputs%calc_nbi_dens.ge.1)) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'READ_NEUTRALS: Full energy neutral density is not in the neutrals file'
        endif
        fatal_error = .True.
    endif
    call h5ltpath_valid_f(fid, "/hdens", .True., exis, error)
    if((.not.exis).and.(inputs%calc_nbi_dens.ge.1)) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'READ_NEUTRALS: Half energy neutral density is not in the neutrals file'
        endif
        fatal_error = .True.
    endif
    call h5ltpath_valid_f(fid, "/tdens", .True., exis, error)
    if((.not.exis).and.(inputs%calc_nbi_dens.ge.1)) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'READ_NEUTRALS: Third energy neutral density is not in the neutrals file'
        endif
        fatal_error = .True.
    endif
    call h5ltpath_valid_f(fid, "/dcxdens", .True., exis, error)
    if((.not.exis).and.(inputs%calc_dcx_dens.ge.1)) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'READ_NEUTRALS: Direct Charge Exchange (DCX) neutral density is not in the neutrals file'
        endif
        fatal_error = .True.
    endif
    call h5ltpath_valid_f(fid, "/halodens", .True., exis, error)
    if((.not.exis).and.(inputs%calc_halo_dens.ge.1)) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'READ_NEUTRALS: Thermal Halo neutral density is not in the neutrals file'
        endif
        fatal_error = .True.
    endif

    if(fatal_error) stop

    dims = [nlevs, nx, ny, nz]
    if(inputs%calc_nbi_dens.ge.1) then
        call h5ltread_dataset_double_f(fid,"/fdens", &
             neut%full, dims, error)
        call h5ltread_dataset_double_f(fid,"/hdens", &
             neut%half, dims, error)
        call h5ltread_dataset_double_f(fid,"/tdens", &
             neut%third, dims, error)
    endif
    if(inputs%calc_dcx_dens.ge.1) then
        call h5ltread_dataset_double_f(fid,"/dcxdens", &
             neut%dcx, dims, error)
    endif
    if(inputs%calc_halo_dens.ge.1) then
        call h5ltread_dataset_double_f(fid,"/halodens", &
             neut%halo, dims, error)
    endif

    !Close file
    call h5fclose_f(fid, error)

    !Close HDF5 interface
    call h5close_f(error)

end subroutine read_neutrals

!=============================================================================
!-----------------------------Geometry Routines-------------------------------
!=============================================================================
function approx_eq(x,y,tol) result(a)
    !+ Inexact equality comparison: `x ~= y` true if `abs(x-y) <= tol` else false
    real(Float64), intent(in) :: x
        !+First value in comparison
    real(Float64), intent(in) :: y
        !+Second value in comparison
    real(Float64), intent(in) :: tol
        !+Equality tolerance

    logical :: a

    a = abs(x-y).le.tol

end function approx_eq

function approx_ge(x,y,tol) result(a)
    !+ Inexact greater than or equal to comparison: `x >~= y`
    real(Float64), intent(in) :: x
        !+First value in comparison
    real(Float64), intent(in) :: y
        !+Second value in comparison
    real(Float64), intent(in) :: tol
        !+Equality tolerance

    logical :: a

    a = (x.gt.y).or.(approx_eq(x,y,tol))

end function approx_ge

function approx_le(x,y,tol) result(a)
    !+ Inexact less then or equal to comparison: `x <~= y`
    real(Float64), intent(in) :: x
        !+First value in comparison
    real(Float64), intent(in) :: y
        !+Second value in comparison
    real(Float64), intent(in) :: tol
        !+Equality tolerance

    logical :: a

    a = (x.lt.y).or.(approx_eq(x,y,tol))

end function approx_le

function cross_product(u, v) result(s)
    !+ Calculates the cross product of two vectors: `u`x`v`
    real(Float64), dimension(3), intent(in) :: u
    real(Float64), dimension(3), intent(in) :: v
    real(Float64), dimension(3)             :: s

    s(1) = u(2)*v(3) - u(3)*v(2)
    s(2) = u(3)*v(1) - u(1)*v(3)
    s(3) = u(1)*v(2) - u(2)*v(1)

end function cross_product

subroutine tb_zyx(alpha, beta, gamma, basis, inv_basis)
    !+ Creates active rotation matrix for z-y'-x" rotation given Tait-Bryan angles
    real(Float64), intent(in)                            :: alpha
        !+ Angle of rotation about z
    real(Float64), intent(in)                            :: beta
        !+ Angle of rotation about y'
    real(Float64), intent(in)                            :: gamma
        !+ Angle of rotation about x"
    real(Float64), dimension(3,3), intent(out)           :: basis
        !+ Rotation matrix/basis for transforming from rotated to non-rotated coordinates
    real(Float64), dimension(3,3), intent(out), optional :: inv_basis
        !+ Inverse basis for reverse transformation

    real(Float64) :: sa, sb, sg, ca, cb, cg

    sa = sin(alpha) ; sb = sin(beta) ; sg = sin(gamma)
    ca = cos(alpha) ; cb = cos(beta) ; cg = cos(gamma)

    basis(1,1) = ca*cb ; basis(1,2) = ca*sb*sg - cg*sa ; basis(1,3) = sa*sg + ca*cg*sb
    basis(2,1) = cb*sa ; basis(2,2) = ca*cg + sa*sb*sg ; basis(2,3) = cg*sa*sb - ca*sg
    basis(3,1) = -sb   ; basis(3,2) = cb*sg            ; basis(3,3) = cb*cg

    if(present(inv_basis)) inv_basis = transpose(basis)

end subroutine tb_zyx

subroutine line_basis(r0, v0, basis, inv_basis)
    !+ Calculates basis from a line with +x in the direction of line
    real(Float64), dimension(3), intent(in)              :: r0
        !+ Starting point of line [cm]
    real(Float64), dimension(3), intent(in)              :: v0
        !+ Direction of line
    real(Float64), dimension(3,3), intent(out)           :: basis
        !+ Basis for transforming from line coordinates to cartesian
    real(Float64), dimension(3,3), intent(out), optional :: inv_basis
        !+ Inverse basis for the reverse transformation cartesian to line

    real(Float64), dimension(3) :: rf
    real(Float64) :: alpha, beta, dis

    rf = r0 + v0
    dis = sqrt(sum((rf - r0)**2))
    beta = asin((r0(3) - rf(3))/dis)
    alpha = atan2(rf(2)-r0(2),rf(1)-r0(1))

    call tb_zyx(alpha,beta,0.d0,basis)

    if(present(inv_basis)) inv_basis = transpose(basis)

end subroutine line_basis

subroutine plane_basis(center, redge, tedge, basis, inv_basis)
    !+ Calculates basis from 3 points on a plane with +z being the plane normal
    real(Float64), dimension(3), intent(in)              :: center
        !+ Plane origin
    real(Float64), dimension(3), intent(in)              :: redge
        !+ Right edge of plane
    real(Float64), dimension(3), intent(in)              :: tedge
        !+ Top edge of plane
    real(Float64), dimension(3,3), intent(out)           :: basis
        !+ Basis for transforming from plane to cartesian coordinates
    real(Float64), dimension(3,3), intent(out), optional :: inv_basis
        !+ Inverse basis for the reverse transformation cartesian to plane

    real(Float64), dimension(3) :: u1,u2,u3

    u1 = (redge - center)
    u1 = u1/norm2(u1)
    u2 = (tedge - center)
    u2 = u2/norm2(u2)
    u3 = cross_product(u1,u2)
    u3 = u3/norm2(u3)

    basis(:,1) = u1
    basis(:,2) = u2
    basis(:,3) = u3

    if(present(inv_basis)) inv_basis = transpose(basis)

end subroutine plane_basis

subroutine line_plane_intersect(l0, l, p0, n, p, t)
    !+ Calculates the intersection of a line and a plane
    real(Float64), dimension(3), intent(in)  :: l0
        !+ Point on line
    real(Float64), dimension(3), intent(in)  :: l
        !+ Ray of line
    real(Float64), dimension(3), intent(in)  :: p0
        !+ Point on plane
    real(Float64), dimension(3), intent(in)  :: n
        !+ Normal vector of plane
    real(Float64), dimension(3), intent(out) :: p
        !+ Line-plane intersect point
    real(Float64), intent(out)               :: t
        !+ "time" to intersect

    real(Float64) :: ldotn

    ldotn = dot_product(l, n)
    if(ldotn.eq.0.0)then
        t = 0.0
    else
        t = dot_product(p0 - l0, n)/ldotn
    endif
    p = l0 + t*l

end subroutine line_plane_intersect

subroutine line_cylinder_intersect(l0, l, p0, p, t)
    !+ Calculates the intersection of a line and a cylinder
    real(Float64), dimension(3), intent(in)  :: l0
        !+ Point on line
    real(Float64), dimension(3), intent(in)  :: l
        !+ Ray of line
    real(Float64), dimension(3), intent(in)  :: p0
        !+ Point on cylinder
    real(Float64), dimension(3), intent(out) :: p
        !+ Line-cylinder intersect point
    real(Float64), intent(out)               :: t
        !+ "time" to intersect

    real(Float64), dimension(2) :: times
    logical, dimension(2) :: mask
    real(Float64) :: r, vx, vy, x0, y0
    real(Float64) :: radicand, npos

    r = sqrt(p0(1) * p0(1) + p0(2) * p0(2))
    x0 = l0(1) ; y0 = l0(2)
    vx = l(1)  ; vy = l(2)

    if((vx.eq.0.d0).and.(vy.eq.0.d0)) then
        t = 0.d0        ! Parallel to a plane tangent to the cylinder
    else
        radicand = r**2 * (vx**2 + vy**2) - (vy * x0 - vx * y0)**2
        if(radicand.lt.0) then
            t = 0.d0    ! Parallel to a plane tangent to the cylinder
        else
            times(1) = (- vx * x0 - vy * y0 - sqrt(radicand)) / (vx**2 + vy**2)
            times(2) = (- vx * x0 - vy * y0 + sqrt(radicand)) / (vx**2 + vy**2)
            mask = times.gt.0
            npos = count(mask)
            if(npos.gt.0) then
                t = minval(times, mask=times.gt.0)
            else
                t = maxval(times, mask=times.le.0)
            endif
        endif
    endif

    p = l0 + l * t

end subroutine line_cylinder_intersect

function in_boundary(bplane, p) result(in_b)
    !+ Indicator function for determining if a point on a plane is within the plane boundary
    type(BoundedPlane), intent(in)          :: bplane
        !+ Plane with boundary
    real(Float64), dimension(3), intent(in) :: p
        !+ Point on plane
    logical :: in_b

    real(Float64), dimension(3) :: pp
    real(Float64) :: hh, hw

    hh = bplane%hh
    hw = bplane%hw
    pp = matmul(bplane%inv_basis, p - bplane%origin)
    in_b = .False.
    SELECT CASE (bplane%shape)
        CASE (1) !Rectangular boundary
            if((abs(pp(1)).le.hw).and. &
               (abs(pp(2)).le.hh)) then
                in_b = .True.
            endif
        CASE (2) !Circular/Ellipsoidal boundary
            if(((hh*pp(1))**2 + (hw*pp(2))**2).le.((hh*hw)**2)) then
                in_b = .True.
            endif
        CASE DEFAULT
            if(inputs%verbose.ge.0) then
                write(*,'("IN_BOUNDARY: Unknown boundary shape: ",i2)') bplane%shape
            endif
            stop
    END SELECT

end function in_boundary

subroutine boundary_edge(bplane, bedge, nb)
    !+ Returns 3 x `nb` array containing points along the BoundedPlane's boundary edge
    type(BoundedPlane), intent(in)             :: bplane
        !+ Bounded plane
    real(Float64), dimension(:,:), intent(out) :: bedge
        !+ Boundary edge points of bounded plane
    integer, intent(out)                       :: nb
        !+ Number of points in boundary edge

    integer :: i
    real(Float64) :: th, dth, x, y
    real(Float64), dimension(4) :: xx, yy

    select case (bplane%shape)
        case (1) !Rectangular boundary
            nb = 4
            if(nb.gt.size(bedge,2)) then
                if(inputs%verbose.ge.0) then
                    write(*,'("BOUNDARY_EDGE: Incompatible boundary edge array : ",i2," > ",i2)') nb, size(bedge,2)
                endif
                stop
            endif
            xx = [-bplane%hw,-bplane%hw,bplane%hw,bplane%hw]
            yy = [-bplane%hh,bplane%hh,bplane%hh,-bplane%hh]
            do i=1,nb
                bedge(:,i) = matmul(bplane%basis,[xx(i),yy(i),0.d0]) + bplane%origin
            enddo
        case (2)
            nb = 50
            if(nb.gt.size(bedge,2)) then
                if(inputs%verbose.ge.0) then
                    write(*,'("BOUNDARY_EDGE: Incompatible boundary edge array : ",i2," > ",i2)') nb, size(bedge,2)
                endif
                stop
            endif
            dth = 2*pi/nb
            do i=1,nb
                th = i*dth
                x = bplane%hw*cos(th)
                y = bplane%hh*sin(th)
                bedge(:,i) = matmul(bplane%basis,[x,y,0.d0]) + bplane%origin
            enddo
        case default
            if(inputs%verbose.ge.0) then
                write(*,'("BOUNDARY_EDGE: Unknown boundary shape: ",i2)') bplane%shape
            endif
            stop
    end select

end subroutine boundary_edge

subroutine gyro_surface(fields, energy, pitch, gs)
    !+ Calculates the surface of all possible trajectories
    type(LocalEMFields), intent(in) :: fields
        !+ Electromagnetic fields at guiding center
    real(Float64), intent(in)       :: energy
        !+ Energy of particle
    real(Float64), intent(in)       :: pitch
        !+ Particle pitch w.r.t the magnetic field
    type(GyroSurface), intent(out)  :: gs
        !+ Gyro-surface

    integer :: i
    real(Float64) :: alpha, vabs, omega
    real(Float64), dimension(3,3) :: s

    vabs  = sqrt(energy/(v2_to_E_per_amu*inputs%ab))
    omega= (fields%b_abs*e0)/(inputs%ab*mass_u)
    alpha = vabs/omega

    gs%omega = omega
    gs%v = vabs
    gs%axes(1) = alpha*sqrt(1-pitch**2)
    gs%axes(2) = alpha*sqrt(1-pitch**2)
    gs%axes(3) = pitch*alpha

    s = 0.d0
    s(1,1) = gs%axes(1)**(-2)
    s(2,2) = gs%axes(2)**(-2)
    s(3,3) = -gs%axes(3)**(-2)

    gs%center = fields%pos

    gs%basis(:,1) = fields%a_norm
    gs%basis(:,2) = fields%c_norm
    gs%basis(:,3) = fields%b_norm

    gs%A = matmul(gs%basis,matmul(s,transpose(gs%basis)))

end subroutine gyro_surface

subroutine line_gyro_surface_intersect(r0, v0, gs, t)
    !+ Calculates the times of intersection of a line and a gyro-surface
    real(Float64), dimension(3), intent(in)  :: r0
        !+ Point on line
    real(Float64), dimension(3), intent(in)  :: v0
        !+ Direction of line
    type(GyroSurface), intent(in)            :: gs
        !+ Gyro-surface
    real(Float64), dimension(2), intent(out) :: t
        !+ "time" to intersect

    real(Float64), dimension(3) :: rr
    real(Float64) :: a, b, c, d, tp, tm

    rr = r0 - gs%center
    a = dot_product(v0, matmul(gs%A,v0))
    b = dot_product(rr, matmul(gs%A,v0)) + dot_product(v0,matmul(gs%A,rr))
    c = dot_product(rr, matmul(gs%A,rr)) - 1.0

    d = b**2 - 4*a*c
    if(d.lt.0.0) then
        t = 0.0
        return
    endif

    t(1) = (-b - sqrt(d))/(2*a)
    t(2) = (-b + sqrt(d))/(2*a)

end subroutine line_gyro_surface_intersect

subroutine gyro_surface_coordinates(gs, p, u)
    !+ Calculates the parametric coordinates, `u`, of point `p` on the gyro_surface
    type(GyroSurface), intent(in)            :: gs
        !+ Gyro_surface
    real(Float64), dimension(3), intent(in)  :: p
        !+ Point on gyro_surface
    real(Float64), dimension(2), intent(out) :: u
        !+ Parametric coordinates (gyro-angle, t)

    real(Float64), dimension(3) :: pp
    real(Float64) :: t, a, b, c, d, thm, thp, dp, dm, th
    integer :: i

    pp = matmul(transpose(gs%basis),p - gs%center)
    t = pp(3)/gs%axes(3)
    a = gs%axes(1) + gs%axes(2)*t
    b = gs%axes(2) - gs%axes(1)*t
    d = pp(1) + pp(2)
    c = max(min(d/sqrt(a**2 + b**2),1.d0),-1.d0)

    thm = -acos(c) + atan2(b,a)
    thp =  acos(c) + atan2(b,a)

    dm = norm2([gs%axes(1)*(cos(thm) - t*sin(thm)), &
                gs%axes(2)*(sin(thm) + t*cos(thm)), &
                gs%axes(3)*t ] - pp)
    dp = norm2([gs%axes(1)*(cos(thp) - t*sin(thp)), &
                gs%axes(2)*(sin(thp) + t*cos(thp)), &
                gs%axes(3)*t ] - pp)

    th = thm - pi/2
    if(dp.le.dm) th = thp - pi/2
    if(th.lt.0.0) th = th + 2*pi
    u = [th, t/gs%omega]

end subroutine gyro_surface_coordinates

subroutine gyro_trajectory(gs, theta, ri, vi)
    !+ Calculate particle trajectory for a given gyro-angle and gyro-surface
    type(GyroSurface), intent(in) :: gs
        !+ Gyro-Surface
    real(Float64), intent(in) :: theta
        !+ Gyro-angle
    real(Float64), dimension(3) :: ri
        !+ Particle position
    real(Float64), dimension(3) :: vi
        !+ Particle Velocity

    real(Float64) :: a,b,c,th
    a = gs%axes(1)
    b = gs%axes(2)
    c = gs%axes(3)
    th = theta + pi/2
    ri = matmul(gs%basis, [a*cos(th), b*sin(th), 0.d0]) + gs%center
    vi = gs%omega*matmul(gs%basis, [-a*sin(th), b*cos(th), c])

end subroutine gyro_trajectory

function in_gyro_surface(gs, p) result(in_gs)
    !+ Indicator function for determining if a point is inside the gyro_surface
    type(GyroSurface), intent(in)           :: gs
        !+ Gyro-surface
    real(Float64), dimension(3), intent(in) :: p
        !+ Point
    logical :: in_gs

    real(Float64), dimension(3) :: pp

    pp = p - gs%center
    in_gs = dot_product(pp, matmul(gs%A, pp)).le.1.d0

end function in_gyro_surface

subroutine gyro_range(b, gs, gyrange, nrange)
    !+ Calculates the range(s) of gyro-angles that would land within a bounded plane
    type(BoundedPlane), intent(in)             :: b
        !+ Bounded Plane
    type(GyroSurface), intent(in)              :: gs
        !+ Gyro-surface
    real(Float64), dimension(2,4), intent(out) :: gyrange
        !+ (theta, dtheta) values
    integer, intent(out) :: nrange
        !+ Number of ranges. `1 <= nrange <= 4`

    integer :: nb, i, j, ninter
    logical :: in_gs
    logical, dimension(8) :: cross = .False.
    real(Float64) :: t_p, th1, th2, dth
    real(Float64), dimension(2) :: u_cur, t_i
    real(Float64), dimension(3) :: rc, p_pre, p_cur, v0, ri
    real(Float64), dimension(2,8) :: u
    real(Float64), dimension(3,50) :: bedge

    nrange = 0
    gyrange = 0.d0

    call line_plane_intersect(gs%center, gs%basis(:,3), b%origin, b%basis(:,3), rc, t_p)
    if(t_p.eq.0.0) return

    call boundary_edge(b, bedge, nb)
    p_pre = bedge(:,1)
    in_gs = in_gyro_surface(gs, p_pre)

    ninter = 0
    u = 0.d0
    boundary_loop: do i=1,nb
        p_cur = bedge(:,modulo(i,nb)+1)
        v0 = p_cur - p_pre
        call line_gyro_surface_intersect(p_pre, v0, gs, t_i)
        do j=1,2
            if((t_i(j).gt.0.0).and.(t_i(j).lt.1.0)) then
                ri = p_pre + t_i(j)*v0
                call gyro_surface_coordinates(gs, ri, u_cur)
                if(u_cur(2).gt.0.0) then
                    in_gs = .not.in_gs
                    ninter = ninter + 1
                    cross(ninter) = in_gs
                    u(:,ninter) = u_cur
                endif
            endif
        enddo
        p_pre = p_cur
    enddo boundary_loop

    if(ninter.eq.0) then
        if(in_boundary(b, rc)) then
            nrange = 1
            gyrange(:,1) = [0.d0,2*pi]
        endif
        return
    endif

    do i=1, ninter
        if(cross(i)) then
            th1 = u(1,i)
            j = modulo(i,ninter) + 1
            th2 = u(1,j)
            dth = th2-th1
            nrange = nrange + 1
            if(dth.gt.0.0) then
                gyrange(:,nrange) = [th1, dth]
            else
                gyrange(:,nrange) = [th2, -dth]
            endif
        endif
        !! OpenMP with multiple threads is duplicating gyro-ranges for some markers
        !! causing double counting and I don't know why.
        !! It should be very unlikely for multiple gyro-ranges to occur so for
        !! now I'm including this cludge to force only one gyro-range when using
        !! OpenMP.
#ifdef _OMP
        if(nrange.eq.1) exit
#endif
    enddo

end subroutine gyro_range

subroutine npa_gyro_range(ichan, gs, gyrange, nrange)
    !+ Calculates range of gyro-angles that would hit the NPA detector
    integer, intent(in) :: ichan
        !+ Index of NPA detector
    type(GyroSurface), intent(in) :: gs
    real(Float64), dimension(2,4), intent(out) :: gyrange
    integer, intent(out) :: nrange

    type(LocalEMFields) :: fields
    integer :: i, j, a_nrange, d_nrange
    real(Float64) :: a0, a, b, c, d
    real(Float64), dimension(2,4) :: a_gyrange, d_gyrange

    nrange = 0
    gyrange = 0.d0

    call gyro_range(npa_chords%det(ichan)%aperture, gs, a_gyrange, a_nrange)
    if(a_nrange.eq.0) return

    call gyro_range(npa_chords%det(ichan)%detector, gs, d_gyrange, d_nrange)
    if(d_nrange.eq.0) return

    if((a_nrange.eq.1).and.approx_eq(a_gyrange(2,1),2*pi,1d-6)) then
        gyrange = d_gyrange
        nrange = d_nrange
        return
    endif

    if((d_nrange.eq.1).and.approx_eq(d_gyrange(2,1),2*pi,1d-6)) then
        gyrange = a_gyrange
        nrange = a_nrange
        return
    endif

    do i=1,a_nrange
        do j=1, d_nrange
            a0 = 0.d0
            if(d_gyrange(1,j).gt.a_gyrange(1,i)) then
                a0 = a_gyrange(1,i)
                a = 0.d0
                b = modulo(a_gyrange(1,i) + a_gyrange(2,i) - a0, 2*pi)
                c = modulo(d_gyrange(1,j) - a0, 2*pi)
                d = modulo(d_gyrange(1,j) + d_gyrange(2,j) - a0, 2*pi)
            else
                a0 = d_gyrange(1,j)
                a = 0.d0
                b = modulo(d_gyrange(1,j) + d_gyrange(2,j) - a0, 2*pi)
                c = modulo(a_gyrange(1,i) - a0, 2*pi)
                d = modulo(a_gyrange(1,i) + a_gyrange(2,i) - a0, 2*pi)
            endif
            if((c.lt.b).or.(d.lt.c)) then
                if(c.lt.d) then
                    nrange = nrange + 1
                    gyrange(:,nrange) = [a0 + c, min(d-c,b-c)]
                else
                    nrange = nrange + 1
                    gyrange(:,nrange) = [a0, d]
                    nrange = nrange + 1
                    gyrange(:,nrange) = [a0+c, b-c]
                endif
            endif
        enddo
    enddo

end subroutine npa_gyro_range

subroutine hit_npa_detector(r0, v0, d_index, rd, det)
    !+ Routine to check if a particle will hit a NPA detector
    real(Float64), dimension(3), intent(in)            :: r0
        !+ Starting point of particle
    real(Float64), dimension(3), intent(in)            :: v0
        !+ Particle velocity
    integer, intent(out)                               :: d_index
        !+ Index of NPA detector. Zero if particle doesn't hit
    real(Float64), dimension(3), intent(out), optional :: rd
        !+ Point where particle hit detector
    integer, intent(in), optional :: det
        !+ Index of NPA detector to check

    real(Float64), dimension(3) :: d, a
    real(Float64) :: t_a,t_d
    integer :: i, s, ndet

    if(present(det)) then
        s = det
        ndet = det
    else
        s = 1
        ndet = npa_chords%nchan
    endif

    d_index = 0
    detector_loop: do i=s,ndet
        !! Find where trajectory crosses detector plane
        call line_plane_intersect(r0,v0,npa_chords%det(i)%detector%origin, &
             npa_chords%det(i)%detector%basis(:,3),d,t_d)

        !! Find where trajectory crosses aperture plane
        call line_plane_intersect(r0,v0,npa_chords%det(i)%aperture%origin, &
             npa_chords%det(i)%aperture%basis(:,3),a,t_a)

        !! If both points are in plane boundaries and the
        !! particle is heading toward the detector then its a hit
        if(in_boundary(npa_chords%det(i)%aperture,a) .and. &
           in_boundary(npa_chords%det(i)%detector,d) .and. &
           (t_d.gt.0.0) ) then
            d_index = i
            exit detector_loop
        endif
    enddo detector_loop
    if(present(rd)) rd = d

end subroutine hit_npa_detector

subroutine xyz_to_uvw(xyz, uvw)
    !+ Convert beam coordinate `xyz` to machine coordinate `uvw`
    real(Float64), dimension(3), intent(in)  :: xyz
    real(Float64), dimension(3), intent(out) :: uvw

    real(Float64), dimension(3) :: origin
    real(Float64), dimension(3,3) :: basis

    origin = beam_grid%origin
    basis = beam_grid%basis
    uvw = matmul(basis,xyz)
    uvw = uvw + origin

end subroutine xyz_to_uvw

subroutine xyz_to_cyl(xyz, cyl)
    !+ Convert beam coordinate `xyz` to cylindrical coordinate `cyl`
    real(Float64), dimension(3), intent(in)  :: xyz
    real(Float64), dimension(3), intent(out) :: cyl

    real(Float64), dimension(3) :: uvw

    call xyz_to_uvw(xyz, uvw)
    call uvw_to_cyl(uvw, cyl)

end subroutine xyz_to_cyl

subroutine uvw_to_xyz(uvw,xyz)
    !+ Convert machine coordinate `uvw` to beam coordinate `xyz`
    real(Float64), dimension(3), intent(in)  :: uvw
    real(Float64), dimension(3), intent(out) :: xyz

    real(Float64), dimension(3) :: origin, uvw_p
    real(Float64), dimension(3,3) :: basis

    origin = beam_grid%origin
    basis = beam_grid%inv_basis
    uvw_p = uvw - origin
    xyz = matmul(basis,uvw_p)

end subroutine uvw_to_xyz

subroutine cyl_to_uvw(cyl, uvw)
    !+ Convert cylindrical coordinate `cyl` to machine coordinate `uvw`
    real(Float64), dimension(3), intent(in)  :: cyl
    real(Float64), dimension(3), intent(out) :: uvw

    uvw(1) = cyl(1) * cos(cyl(3))
    uvw(2) = cyl(1) * sin(cyl(3))
    uvw(3) = cyl(2)

end subroutine cyl_to_uvw

subroutine cyl_to_xyz(cyl, xyz)
    !+ Convert cylindrical coordinate `cyl` to beam coordinate `xyz`
    real(Float64), dimension(3), intent(in)  :: cyl
    real(Float64), dimension(3), intent(out) :: xyz

    real(Float64), dimension(3) :: uvw

    call cyl_to_uvw(cyl, uvw)
    call uvw_to_xyz(uvw, xyz)

end subroutine cyl_to_xyz

subroutine uvw_to_cyl(uvw, cyl)
    !+ Convert machine coordinate `uvw` to cylindrical coordinate `cyl`
    real(Float64), dimension(3), intent(in)  :: uvw
    real(Float64), dimension(3), intent(out) :: cyl

    cyl(1) = sqrt(uvw(1)*uvw(1) + uvw(2)*uvw(2))
    cyl(2) = uvw(3)
    cyl(3) = atan2(uvw(2),uvw(1))

end subroutine uvw_to_cyl

subroutine grid_intersect(r0, v0, length, r_enter, r_exit, center_in, lwh_in, passive)
    !+ Calculates a particles intersection length with the [[libfida:beam_grid]]
    real(Float64), dimension(3), intent(in)           :: r0
        !+ Initial position of particle [cm]
    real(Float64), dimension(3), intent(in)           :: v0
        !+ Velocity of particle [cm/s]
    real(Float64), intent(out)                        :: length
        !+ Intersection length [cm]
    real(Float64), dimension(3), intent(out)          :: r_enter
        !+ Point where particle enters
    real(Float64), dimension(3), intent(out)          :: r_exit
        !+ Point where particle exits
    real(Float64), dimension(3), intent(in), optional :: center_in
        !+ Alternative grid center
    real(Float64), dimension(3), intent(in), optional :: lwh_in
        !+ Alternative grid [length,width,height]
    logical, intent(in), optional                     :: passive
        !+ Calculates a particles intersection length with the [[libfida:pass_grid]]

    real(Float64), dimension(3,6) :: ipnts
    real(Float64), dimension(3) :: ri, vi
    real(Float64), dimension(3) :: center
    real(Float64), dimension(3) :: lwh
    integer, dimension(6) :: side_inter
    integer, dimension(2) :: ind
    integer :: i, j, nunique, ind1, ind2
    real(Float64) :: dlength, max_length
    logical :: ing, pas

    pas = .False.
    if(present(passive)) pas = passive

    if(pas) then
        ing = in_passive_grid(r0)
        if (ing) then
            length = 0.d0
            return
        endif

        ri = r0 ; vi = v0
        dlength = 2.0 !cm
        max_length=0.0

        do while (.not.ing)
            ri = ri + vi*dlength ! move dlength
            ing = in_passive_grid(ri)
            max_length = max_length + dlength
            if(max_length.gt.1d3) then
                length = 0.d0
                return
            endif
        enddo
        r_enter = ri

        do while (ing)
            ri = ri + vi*dlength
            ing =  in_passive_grid(ri)
        enddo
        r_exit = ri

        length = sqrt(sum((r_exit-r_enter)**2))
    else
        if (present(center_in)) then
            center = center_in
        else
            center = beam_grid%center
        endif

        if (present(lwh_in)) then
            lwh = lwh_in
        else
            lwh = beam_grid%lwh
        endif

        side_inter = 0
        ipnts = 0.d0
        do i=1,6
            j = int(ceiling(i/2.0))
            if (j.eq.1) ind = [2,3]
            if (j.eq.2) ind = [1,3]
            if (j.eq.3) ind = [1,2]
            if (abs(v0(j)).gt.0.d0) then
                ipnts(:,i) = r0 + v0*( ( (center(j) + &
                             (mod(i,2) - 0.5)*lwh(j)) - r0(j))/v0(j) )
                if ((abs(ipnts(ind(1),i) - center(ind(1))).le.(0.5*lwh(ind(1)))).and. &
                    (abs(ipnts(ind(2),i) - center(ind(2))).le.(0.5*lwh(ind(2))))) then
                    side_inter(i) = 1
                endif
            endif
        enddo

        length = 0.d0
        r_enter = r0
        r_exit  = r0
        ind1=0
        ind2=0
        if (sum(side_inter).ge.2) then
            ! Find first intersection side
            i=1
            do while (i.le.6)
                if(side_inter(i).eq.1) exit
                i=i+1
            enddo
            ind1=i
            !Find number of unique points
            nunique = 0
            do i=ind1+1,6
                if (side_inter(i).ne.1) cycle
                if (sqrt( sum( ( ipnts(:,i)-ipnts(:,ind1) )**2 ) ).gt.0.001) then
                    ind2=i
                    nunique = 2
                    exit
                endif
            enddo

            if(nunique.eq.2) then
                vi = ipnts(:,ind2) - ipnts(:,ind1)
                if (dot_product(v0,vi).gt.0.0) then
                    r_enter = ipnts(:,ind1)
                    r_exit  = ipnts(:,ind2)
                else
                    r_enter = ipnts(:,ind2)
                    r_exit  = ipnts(:,ind1)
                endif
                length = sqrt(sum((r_exit - r_enter)**2))
            endif
        endif
    endif

end subroutine grid_intersect

function in_grid(xyz) result(ing)
    !+ Determines if a position `pos` is in the [[libfida:beam_grid]]
    real(Float64), dimension(3), intent(in) :: xyz
        !+ Position in beam grid coordinates [cm]
    logical :: ing
        !+ Indicates whether the position is in the beam grid

    real(Float64) :: tol = 1.0d-10

    if((approx_ge(xyz(1),beam_grid%xmin,tol).and.approx_le(xyz(1),beam_grid%xmax,tol)).and. &
       (approx_ge(xyz(2),beam_grid%ymin,tol).and.approx_le(xyz(2),beam_grid%ymax,tol)).and. &
       (approx_ge(xyz(3),beam_grid%zmin,tol).and.approx_le(xyz(3),beam_grid%zmax,tol))) then
        ing = .True.
    else
        ing = .False.
    endif

end function

function in_passive_grid(uvw) result(ing)
    !+ Determines if a position `pos` is in the [[libfida:pass_grid]]
    real(Float64), dimension(3), intent(in) :: uvw
        !+ Position in machine coordinates [cm]
    logical :: ing
        !+ Indicates whether the position is in the passive neutral grid

    real(Float64), dimension(3) :: cyl
    real(Float64) :: phimin, phimax
    real(Float64) :: tol = 1.0d-10

    phimin = minval(pass_grid%phi)
    phimax = maxval(pass_grid%phi)

    call uvw_to_cyl(uvw, cyl)

    if((approx_ge(cyl(1),minval(pass_grid%r),tol).and.approx_le(cyl(1),maxval(pass_grid%r),tol)).and. &
       (approx_ge(cyl(2),minval(pass_grid%z),tol).and.approx_le(cyl(2),maxval(pass_grid%z),tol)).and. &
       ((approx_ge(cyl(3),phimin,tol).and.approx_le(cyl(3),phimax,tol)).or. &
       (approx_ge(modulo(cyl(3),2*pi),phimin,tol).and.approx_le(modulo(cyl(3),2*pi),phimax,tol)))) then
        ing = .True.
    else
        ing = .False.
    endif

end function

subroutine circle_grid_intersect(r0, e1, e2, radius, beam_grid_phi_enter, beam_grid_phi_exit)
    !+ Calculates the intersection arclength of a circle with the [[libfida:beam_grid]]
    real(Float64), dimension(3), intent(in) :: r0
        !+ Position of center enter of the circle in beam grid coordinates [cm]
    real(Float64), dimension(3), intent(in) :: e1
        !+ Unit vector pointing towards (R, 0) (r,phi) position of the circle in beam grid coordinates
    real(Float64), dimension(3), intent(in) :: e2
        !+ Unit vector pointing towards (R, pi/2) (r,phi) position of the circle in beam grid coordinates
    real(Float64), intent(in)               :: radius
        !+ Radius of circle [cm]
    real(Float64), intent(out)              :: beam_grid_phi_enter
        !+ Phi value where the circle entered the [[libfida:beam_grid]] [rad]
    real(Float64), intent(out)              :: beam_grid_phi_exit
        !+ Phi value where the circle exits the [[libfida:beam_grid]] [rad]

    real(Float64), dimension(3) :: i1_p,i1_n,i2_p,i2_n
    real(Float64), dimension(4) :: d
    real(Float64), dimension(6) :: p, gams
    real(Float64), dimension(4,6) :: phi
    logical, dimension(4,6) :: inter
    integer, dimension(6) :: n
    integer :: i
    real(Float64) :: alpha,beta,delta,sinx1,cosx1,sinx2,cosx2,tmp
    real(Float64) :: tol = 1.0d-10
    logical :: r0_ing

    p = [beam_grid%xmin, beam_grid%xmax, &
         beam_grid%ymin, beam_grid%ymax, &
         beam_grid%zmin, beam_grid%zmax ]
    n = [1, 1, 2, 2, 3, 3]
    inter = .False.
    phi = 0.d0

    r0_ing = in_grid(r0)
    do i=1,6
        alpha = e2(n(i))
        beta = e1(n(i))
        if((alpha.eq.0.0).and.(beta.eq.0.0)) cycle
        gams(i) = (p(i) - r0(n(i)))/radius
        delta = alpha**4 + (alpha**2)*(beta**2 - gams(i)**2)
        if (delta.ge.0.0) then
            cosx1 = (gams(i)*beta + sqrt(delta))/(alpha**2 + beta**2)
            if ((cosx1**2).le.1.0) then
                sinx1 = sqrt(1 - cosx1**2)
                i1_p = r0 + radius*cosx1*e1 + radius*sinx1*e2
                i1_n = r0 + radius*cosx1*e1 - radius*sinx1*e2
                if (approx_eq(i1_p(n(i)),p(i),tol).and.in_grid(i1_p)) then
                    inter(1,i) = .True.
                    phi(1,i) = atan2(sinx1,cosx1)
                endif
                if (approx_eq(i1_n(n(i)),p(i),tol).and.in_grid(i1_n)) then
                    inter(2,i) = .True.
                    phi(2,i) = atan2(-sinx1,cosx1)
                endif
            endif

            if(delta.gt.0.0) then
                cosx2 = (gams(i)*beta - sqrt(delta))/(alpha**2 + beta**2)
                if ((cosx2**2).le.1.0) then
                    sinx2 = sqrt(1 - cosx2**2)
                    i2_p = r0 + radius*cosx2*e1 + radius*sinx2*e2
                    i2_n = r0 + radius*cosx2*e1 - radius*sinx2*e2
                    if (approx_eq(i2_p(n(i)),p(i),tol).and.in_grid(i2_p)) then
                        inter(3,i) = .True.
                        phi(3,i) = atan2(sinx2,cosx2)
                    endif
                    if (approx_eq(i2_n(n(i)),p(i),tol).and.in_grid(i2_n)) then
                        inter(4,i) = .True.
                        phi(4,i) = atan2(-sinx2,cosx2)
                    endif
                endif
            endif
        endif
    enddo

    beam_grid_phi_enter = 0.d0
    beam_grid_phi_exit = 0.d0
    if (count(inter).gt.2) then
        write(*,'("CIRCLE_GRID_INTERSECT: Circle intersects grid more than 2 times: ",i2)') count(inter)
        return
    endif

    if(any(inter)) then
        beam_grid_phi_enter = minval(phi,inter)
        beam_grid_phi_exit = maxval(phi,inter)
        if(r0_ing.and.any(count(inter,1).ge.2)) then
            if((beam_grid_phi_exit - beam_grid_phi_enter) .lt. pi) then
                tmp = beam_grid_phi_enter
                beam_grid_phi_enter = beam_grid_phi_exit
                beam_grid_phi_exit = tmp + 2*pi
            endif
        else
            if((beam_grid_phi_exit - beam_grid_phi_enter) .gt. pi) then
                tmp = beam_grid_phi_enter
                beam_grid_phi_enter = beam_grid_phi_exit
                beam_grid_phi_exit = tmp + 2*pi
            endif
        endif
        if(approx_eq(beam_grid_phi_exit-beam_grid_phi_enter,pi,tol).and.r0_ing) then
            beam_grid_phi_enter = 0.0
            beam_grid_phi_exit = 2*pi
        endif
    else
        if(r0_ing) then
            call grid_intersect(r0, e1, tmp, i1_n,i1_p)
            call grid_intersect(r0, e2, tmp, i2_n,i2_p)
            d(1) = norm2(r0 - i1_n)/radius
            d(2) = norm2(r0 - i1_p)/radius
            d(3) = norm2(r0 - i2_n)/radius
            d(4) = norm2(r0 - i2_p)/radius
            if(all(d.ge.1.0)) then
                beam_grid_phi_enter = 0.d0
                beam_grid_phi_exit = 2.d0*pi
            endif
        endif
    endif

end subroutine circle_grid_intersect

subroutine get_indices(pos, ind)
    !+ Find closests [[libfida:beam_grid]] indices `ind` to position `pos`
    real(Float64),  dimension(3), intent(in)  :: pos
        !+ Position [cm]
    integer(Int32), dimension(3), intent(out) :: ind
        !+ Closest indices to position

    real(Float64),  dimension(3) :: mini
    integer(Int32), dimension(3) :: maxind
    integer :: i

    maxind(1) = beam_grid%nx
    maxind(2) = beam_grid%ny
    maxind(3) = beam_grid%nz

    mini(1) = minval(beam_grid%xc) - 0.5*beam_grid%dr(1)
    mini(2) = minval(beam_grid%yc) - 0.5*beam_grid%dr(2)
    mini(3) = minval(beam_grid%zc) - 0.5*beam_grid%dr(3)

    do i=1,3
        ind(i) = floor((pos(i)-mini(i))/beam_grid%dr(i)) + 1
        if (ind(i).gt.maxind(i)) ind(i)=maxind(i)
        if (ind(i).lt.1) ind(i)=1
    enddo

end subroutine get_indices

subroutine get_passive_grid_indices(pos, ind, input_coords)
    !+ Find closest [[libfida:pass_grid]] indices `ind` to position `pos`
    real(Float64),  dimension(3), intent(in)  :: pos
        !+ Position [cm]
    integer(Int32), dimension(3), intent(out) :: ind
        !+ Closest indices to position
    integer, intent(in), optional             :: input_coords
        !+ Indicates coordinate system of `pos`. Beam grid (0), machine (1) and cylindrical (2)

    real(Float64),  dimension(3) :: mini, differentials, loc
    integer(Int32), dimension(3) :: maxind
    integer :: i, ics

    if(present(input_coords)) then
        ics = input_coords
    else
        ics = 2
    endif

    if(ics.eq.1) then
        loc(1) = sqrt(pos(1)*pos(1) + pos(2)*pos(2))
        loc(2) = pos(3)
        loc(3) = atan2(pos(2),pos(1))
    endif

    if(ics.eq.2) then
        loc(1) = pos(1)
        loc(2) = pos(2)
        loc(3) = pos(3)
    endif

    maxind(1) = pass_grid%nr
    maxind(2) = pass_grid%nz
    maxind(3) = pass_grid%nphi

    mini(1) = minval(pass_grid%r)
    mini(2) = minval(pass_grid%z)
    mini(3) = minval(pass_grid%phi)

    differentials(1) = pass_grid%dr
    differentials(2) = pass_grid%dz
    differentials(3) = pass_grid%dphi

    do i=1,3
        ind(i) = floor((loc(i)-mini(i))/differentials(i)) + 1
        if (ind(i).gt.maxind(i)) ind(i)=maxind(i)
        if (ind(i).lt.1) ind(i)=1
    enddo

end subroutine get_passive_grid_indices

subroutine get_plasma_extrema(r0, v0, extrema, x0, y0)
    !+ Returns extrema points where line(s) parametrized by `r0` and `v0` intersect the plasma boudnary
    real(Float64), dimension(:,:), intent(in)            :: r0, v0
    !+ Arrays the define line(s) in machine coordinates
    real(Float64), dimension(2,3), intent(out)           :: extrema
    !+ Minimum and maximumm R, Z, and Phi points
    real(Float64), dimension(:), intent(in), optional  :: x0, y0
    !+ Additional x and y points to consider

    real(Float64), dimension(:,:), allocatable :: xy_in, xy_out
    real(Float64), dimension(:,:), allocatable :: cyl_in, cyl_out
    real(Float64), dimension(:), allocatable  :: x, y, xlo, xhi
    real(Float64), dimension(:), allocatable  :: r, z, phi
    logical, dimension(:), allocatable :: skip

    real(Float64), dimension(3) :: ri, vi
    real(Float64) :: max_length, dlength
    integer :: i, iin, iout, ilo, ihi, dlo, dhi, dim, nlines, d
    logical :: inp

    nlines = size(r0(1,:))
    allocate(xy_in(2,nlines), xy_out(2,nlines))
    allocate(cyl_in(3,nlines), cyl_out(3,nlines))
    allocate(skip(nlines))

    dlength = 3.0 !cm
    skip = .False.

    loop_over_channels: do i=1, nlines
        ri = r0(:,i)
        vi = v0(:,i)
        vi = vi/norm2(vi)

        ! Find the position that the los first intersects the plasma
        call in_plasma(ri, inp, input_coords=1)
        max_length=0.0
        do while (.not.inp)
            ri = ri + vi*dlength ! move dlength
            call in_plasma(ri, inp, input_coords=1)
            max_length = max_length + dlength
            if(max_length.gt.1d9) then
                skip(i) = .True. !used below to skip los that do not intersect the plasma
                cycle loop_over_channels
            endif
        enddo

        xy_in(1,i) = ri(1) ; xy_in(2,i) = ri(2)
        call uvw_to_cyl(ri, cyl_in(:,i))

        ! Find the position that the los intersects upon exiting the plasma
        do while (inp)
            ri = ri + vi*dlength
            call in_plasma(ri, inp, input_coords=1)
        enddo

        xy_out(1,i) = ri(1) ; xy_out(2,i) = ri(2)
        call uvw_to_cyl(ri, cyl_out(:,i))

    enddo loop_over_channels

    dim = 2*count(.not.skip) ! 2 for enter and exit

    d = 0
    if (present(x0).and.present(y0)) then
        d = size(x0)
        if (size(x0).ne.size(y0)) then
            if(inputs%verbose.ge.0) then
                write(*,'("GET_PLASMA_EXTREMA: Sizes of X and Y input arrays are not identical")')
                stop
            endif
        endif
    endif

    allocate(x(dim+d), y(dim+d), r(dim), z(dim), phi(dim))

    iin = 1 ; iout = 2
    do i=1, nlines
        if (.not.skip(i)) then
            x(iin) = xy_in(1,i)  ; x(iout) = xy_out(1,i)
            y(iin) = xy_in(2,i)  ; y(iout) = xy_out(2,i)
            r(iin) = cyl_in(1,i) ; r(iout) = cyl_out(1,i)
            z(iin) = cyl_in(2,i) ; z(iout) = cyl_out(2,i)
            iin = iin + 2 ; iout = iout + 2
        endif
    enddo

    extrema(1,1) = minval(r) ; extrema(2,1) = maxval(r)
    extrema(1,2) = minval(z) ; extrema(2,2) = maxval(z)

    ! Append extra x and y points
    if(d.gt.0) then
        x(dim+1:dim+d) = x0
        y(dim+1:dim+d) = y0
    endif

    !! Domain is between 0 and 2 pi if all x points are left of the line x=0
    !! Else domain is between -pi and pi
    dlo = count(y.le.0) ; dhi = count(y.gt.0)
    allocate(xlo(dlo), xhi(dhi))

    ilo = 0 ; ihi = 0
    do i=1, size(x)
        if (y(i).le.0.d10) then
            ilo = ilo + 1
            xlo(ilo) = x(i)
        else
            ihi = ihi + 1
            xhi(ihi) = x(i)
        endif
    enddo

    phi = atan2(y, x)
    if (all(x.le.0) & !none in quadrant 1 and 4
        .or.(all(xlo.le.0).and.(size(x).ne.size(xhi))) & !quadrant 3
        .or.(all(xhi.le.0).and.(size(x).ne.size(xlo)))) then !quadrant 2
        phi = modulo(phi, 2*pi)
    endif

    extrema(1,3) = minval(phi) ; extrema(2,3) = maxval(phi)

end subroutine get_plasma_extrema

subroutine get_position(ind, pos, input_coords)
    !+ Get position `pos` given indices `ind`
    integer(Int32), dimension(3), intent(in) :: ind
        !+ Indices
    real(Float64), dimension(3), intent(out) :: pos
        !+ Position in [[libfida:beam_grid]] coordinates [cm]
    integer, intent(in), optional            :: input_coords
        !+ Indicates coordinate system of `ind`. Beam grid (0) and cylindrical (2)

    real(Float64), dimension(3) :: pos_temp1, pos_temp2
    integer :: ics, ocs

    if(present(input_coords)) then
        ics = input_coords
    else
        ics = 0
    endif

    if(ics.eq.0) then
        pos(1) = beam_grid%xc(ind(1))
        pos(2) = beam_grid%yc(ind(2))
        pos(3) = beam_grid%zc(ind(3))
    endif

    if(ics.eq.2) then
        pos_temp1(1) = inter_grid%r(ind(1))
        pos_temp1(2) = inter_grid%z(ind(2))
        pos_temp1(3) = inter_grid%phi(ind(3))
        call cyl_to_xyz(pos_temp1,pos)
    endif

end subroutine get_position

subroutine track(rin, vin, tracks, ntrack, los_intersect)
    !+ Computes the path of a neutral through the [[libfida:beam_grid]]
    real(Float64), dimension(3), intent(in)          :: rin
        !+ Initial position of particle
    real(Float64), dimension(3), intent(in)          :: vin
        !+ Initial velocity of particle
    type(ParticleTrack), dimension(:), intent(inout) :: tracks
        !+ Array of [[ParticleTrack]] type
    integer(Int32), intent(out)                      :: ntrack
        !+ Number of cells that a particle crosses
    logical, intent(out), optional                   :: los_intersect
        !+ Indicator whether particle intersects a LOS in [[libfida:spec_chords]]

    integer :: cc, i, j, ii, mind,ncross, id
    integer, dimension(3) :: ind
    logical :: in_plasma1, in_plasma2, in_plasma_tmp, los_inter
    real(Float64) :: dT, dt1, inv_50
    real(Float64), dimension(3) :: dt_arr, dr
    real(Float64), dimension(3) :: vn, inv_vn, vp
    real(Float64), dimension(3) :: ri, ri_tmp, ri_cell
    type(LocalEMFields) :: fields
    type(LOSInters) :: inter
    real(Float64), dimension(n_stark) :: lambda
    integer, dimension(3) :: sgn
    integer, dimension(3) :: gdims

    vn = vin ;  ri = rin ; sgn = 0 ; ntrack = 0

    los_inter=.False.
    if(.not.present(los_intersect)) then
        los_inter = .True. !avoids computation if not needed
    endif

    if(dot_product(vin,vin).eq.0.0) then
        return
    endif

    gdims(1) = beam_grid%nx
    gdims(2) = beam_grid%ny
    gdims(3) = beam_grid%nz

    !! define actual cell
    call get_indices(ri,ind)
    ri_cell = [beam_grid%xc(ind(1)), &
               beam_grid%yc(ind(2)), &
               beam_grid%zc(ind(3))]

    do i=1,3
        if (vn(i).gt.0.0) sgn(i) = 1
        if (vn(i).lt.0.0) sgn(i) =-1
        if (vn(i).eq.0.0) vn(i)  = 1.0d-3
    enddo

    dr = beam_grid%dr*sgn
    inv_vn = 1/vn
    inv_50 = 1.0/50.0
    cc=1
    tracks%time = 0.d0
    tracks%flux = 0.d0
    ncross = 0
    call in_plasma(ri,in_plasma1)
    track_loop: do i=1,beam_grid%ntrack
        if(cc.gt.beam_grid%ntrack) exit track_loop
        dt_arr = abs(( (ri_cell + 0.5*dr) - ri)*inv_vn)
        mind = minloc(dt_arr,1)
        dT = dt_arr(mind)
        ri_tmp = ri + dT*vn

        !! Check if velocity intersects LOS and produces wavelength in the right region
        inter = spec_chords%inter(ind(1),ind(2),ind(3))
        if((.not.los_inter).and.(inter%nchan.ne.0))then
            call get_fields(fields, pos=ri_tmp)
            chan_loop: do j=1,inter%nchan
                id = inter%los_elem(j)%id
                vp = ri_tmp - spec_chords%los(id)%lens
                call doppler_stark(vp, vn, fields, lambda)
                los_inter = any((lambda.ge.inputs%lambdamin).and.(lambda.le.inputs%lambdamax))
                if(los_inter) exit chan_loop
            enddo chan_loop
        endif

        call in_plasma(ri_tmp,in_plasma2)
        if(in_plasma1.neqv.in_plasma2) then
            dt1 = 0.0
            track_fine: do ii=1,50
                dt1 = dt1 + dT*inv_50
                ri_tmp = ri + vn*dt1
                call in_plasma(ri_tmp,in_plasma_tmp)
                if(in_plasma2.eqv.in_plasma_tmp) exit track_fine
            enddo track_fine
            tracks(cc)%pos = ri + 0.5*dt1*vn
            tracks(cc+1)%pos = ri + 0.5*(dt1 + dT)*vn
            tracks(cc)%time = dt1
            tracks(cc+1)%time = dT - dt1
            tracks(cc)%ind = ind
            tracks(cc+1)%ind = ind
            cc = cc + 2
            ncross = ncross + 1
        else
            tracks(cc)%pos = ri + 0.5*dT*vn
            tracks(cc)%time = dT
            tracks(cc)%ind = ind
            cc = cc + 1
        endif
        in_plasma1 = in_plasma2

        ri = ri + dT*vn
        ind(mind) = ind(mind) + sgn(mind)
        ri_cell(mind) = ri_cell(mind) + dr(mind)

        if (ind(mind).gt.gdims(mind)) exit track_loop
        if (ind(mind).lt.1) exit track_loop
        if (ncross.ge.2) then
            cc = cc - 1 !dont include last segment
            exit track_loop
        endif
    enddo track_loop
    ntrack = cc-1
    if(present(los_intersect)) then
        los_intersect = los_inter
    endif

end subroutine track

subroutine track_cylindrical(rin, vin, tracks, ntrack, los_intersect)
    !+ Computes the path of a neutral through the [[libfida:pass_grid]]
    real(Float64), dimension(3), intent(in)          :: rin
        !+ Initial position of particle
    real(Float64), dimension(3), intent(in)          :: vin
        !+ Initial velocity of particle
    type(ParticleTrack), dimension(:), intent(inout) :: tracks
        !+ Array of [[ParticleTrack]] type
    integer(Int32), intent(out)                      :: ntrack
        !+ Number of cells that a particle crosses
    logical, intent(out), optional                   :: los_intersect
        !+ Indicator whether particle intersects a LOS in [[libfida:spec_chords]]

    real(Float64), dimension(3,3) :: basis
    real(Float64), dimension(3) :: dt_arr, dr !! Need to make this rzphi
    real(Float64), dimension(3) :: vn, vn_cyl, vp
    real(Float64), dimension(3) :: ri, ri_cyl, ri_tmp
    real(Float64), dimension(3) :: p, nz
    real(Float64), dimension(3) :: v_plane_cyl, v_plane
    real(Float64), dimension(3) :: h_plane_cyl, h_plane
    real(Float64), dimension(3) :: arc_cyl, arc
    real(Float64), dimension(3) :: redge, tedge
    real(Float64), dimension(3) :: redge_cyl, tedge_cyl
    integer, dimension(3) :: sgn
    integer, dimension(3) :: gdims
    integer, dimension(1) :: minpos
    integer, dimension(3) :: ind
    real(Float64) :: dT, dt1, inv_50, t
    real(Float64) :: s, c, phi
    integer :: cc, i, j, ii, mind, ncross, id
    type(LocalEMFields) :: fields
    type(LOSInters) :: inter
    real(Float64), dimension(n_stark) :: lambda
    logical :: in_plasma1, in_plasma2, in_plasma_tmp, los_inter
    integer :: ir, iz, iphi

    vn = vin ;  ri = rin ; sgn = 0 ; ntrack = 0

    los_inter=.False.
    if(.not.present(los_intersect)) then
        los_inter = .True. !avoids computation if not needed
    endif

    if(dot_product(vn,vn).eq.0.0) then
        return
    endif

    gdims(1) = pass_grid%nr
    gdims(2) = pass_grid%nz
    gdims(3) = pass_grid%nphi

    phi = atan2(rin(2),rin(1))
    s = sin(phi) ; c = cos(phi)
    vn_cyl(1) = c*vn(1) + s*vn(2)
    vn_cyl(3) = -s*vn(1) + c*vn(2)
    vn_cyl(2) = vn(3)

    do i=1,3
        !! sgn is in R-Z-Phi coordinates
        if (vn_cyl(i).gt.0.d0) then
            sgn(i) = 1
        else if (vn_cyl(i).lt.0.d0) then
            sgn(i) =-1
        end if
    enddo

    dr(1) = pass_grid%dr*sgn(1)
    dr(2) = pass_grid%dz*sgn(2)
    dr(3) = pass_grid%dphi*sgn(3)

    !! Define actual cell
    ri_cyl(1) = sqrt(ri(1)*ri(1) + ri(2)*ri(2))
    ri_cyl(2) = ri(3)
    ri_cyl(3) = atan2(ri(2), ri(1))
    call get_passive_grid_indices(ri_cyl,ind)

    arc_cyl(1) = pass_grid%r(ind(1))
    arc_cyl(2) = pass_grid%z(ind(2))
    arc_cyl(3) = pass_grid%phi(ind(3))
    h_plane_cyl = arc_cyl
    v_plane_cyl = arc_cyl

    !! Define surfaces to intersect
    if(sgn(1).gt.0.d0) arc_cyl(1) = pass_grid%r(ind(1)+1)
    if(sgn(2).gt.0.d0) h_plane_cyl(2) = pass_grid%z(ind(2)+1)
    if(sgn(3).gt.0.d0) v_plane_cyl(3) = pass_grid%phi(ind(3)+1)
    ! Special case of the particle being on the surace handled below
    if((sgn(1).lt.0.d0).and.(arc_cyl(1).eq.ri_cyl(1))) then
        arc_cyl(1) = pass_grid%r(ind(1)-1)
        h_plane_cyl(1) = pass_grid%r(ind(1)-1)
        v_plane_cyl(1) = pass_grid%r(ind(1)-1)
    endif
    if((sgn(2).lt.0.d0).and.(h_plane_cyl(2).eq.ri_cyl(2))) then
        arc_cyl(2) = pass_grid%z(ind(2)-1)
        h_plane_cyl(2) = pass_grid%z(ind(2)-1)
        v_plane_cyl(2) = pass_grid%z(ind(2)-1)
    endif
    if((sgn(3).lt.0.d0).and.(v_plane_cyl(3).eq.ri_cyl(3))) then
        arc_cyl(3) = pass_grid%phi(ind(3)-1)
        h_plane_cyl(3) = pass_grid%phi(ind(3)-1)
        v_plane_cyl(3) = pass_grid%phi(ind(3)-1)
    endif
    call cyl_to_uvw(arc_cyl,arc)
    call cyl_to_uvw(h_plane_cyl,h_plane)
    call cyl_to_uvw(v_plane_cyl,v_plane)

    !! Normal vectors
    nz(1) = 0.d0 ; nz(2) = 0.d0 ; nz(3) = 1.d0
    redge_cyl(1) = v_plane_cyl(1) + pass_grid%dr
    redge_cyl(2) = v_plane_cyl(2)
    redge_cyl(3) = v_plane_cyl(3)
    call cyl_to_uvw(redge_cyl,redge)
    tedge_cyl(1) = v_plane_cyl(1)
    tedge_cyl(2) = v_plane_cyl(2) + pass_grid%dz
    tedge_cyl(3) = v_plane_cyl(3)
    call cyl_to_uvw(tedge_cyl,tedge)
    call plane_basis(v_plane, redge, tedge, basis)

    !! Track the particle
    inv_50 = 1.0/50.0
    cc=1
    tracks%time = 0.d0
    tracks%flux = 0.d0
    ncross = 0
    call in_plasma(ri,in_plasma1,input_coords=1)
    track_loop: do i=1,pass_grid%ntrack
        if(cc.gt.pass_grid%ntrack) exit track_loop

        call line_cylinder_intersect(ri, vn, arc, p, dt_arr(1))
        call line_plane_intersect(ri, vn, h_plane, nz, p, dt_arr(2))
        call line_plane_intersect(ri, vn, v_plane, -basis(:,3), p, dt_arr(3))

        minpos = minloc(dt_arr, mask=dt_arr.gt.0.d0)
        mind = minpos(1)
        dT = dt_arr(mind)
        ri_tmp = ri + dT*vn

        !! Check if velocity intersects LOS and produces wavelength in the right region
        inter = spec_chords%cyl_inter(ind(1),ind(2),ind(3))
        if((.not.los_inter).and.(inter%nchan.ne.0))then
            call get_fields(fields, pos=ri_tmp, input_coords=1)
            chan_loop: do j=1,inter%nchan
                id = inter%los_elem(j)%id
                vp = ri_tmp - spec_chords%los(id)%lens_uvw
                call doppler_stark(vp, vn, fields, lambda)
                los_inter = any((lambda.ge.inputs%lambdamin).and.(lambda.le.inputs%lambdamax))
                if(los_inter) exit chan_loop
            enddo chan_loop
        endif

        call in_plasma(ri_tmp,in_plasma2,input_coords=1)
        if(in_plasma1.neqv.in_plasma2) then
            dt1 = 0.0
            track_fine: do ii=1,50
                dt1 = dt1 + dT*inv_50
                ri_tmp = ri + vn*dt1
                call in_plasma(ri_tmp,in_plasma_tmp,input_coords=1)
                if(in_plasma2.eqv.in_plasma_tmp) exit track_fine
            enddo track_fine
            tracks(cc)%pos = ri + 0.5*dt1*vn
            tracks(cc+1)%pos = ri + 0.5*(dt1 + dT)*vn
            tracks(cc)%time = dt1
            tracks(cc+1)%time = dT - dt1
            tracks(cc)%ind = ind
            tracks(cc+1)%ind = ind
            cc = cc + 2
            ncross = ncross + 1
        else
            tracks(cc)%pos = ri + 0.5*dT*vn
            tracks(cc)%time = dT
            tracks(cc)%ind = ind
            cc = cc + 1
        endif
        in_plasma1 = in_plasma2

        ri = ri + dT*vn
        ind(mind) = ind(mind) + sgn(mind)

        if (ind(mind).gt.gdims(mind)) exit track_loop
        if (ind(mind).lt.1) exit track_loop
        if (ncross.ge.2) then
            cc = cc - 1 !dont include last segment
            exit track_loop
        endif
        !! Particle advancement and basis update
        arc_cyl(mind) = arc_cyl(mind) + dr(mind)
        h_plane_cyl(mind) = h_plane_cyl(mind) + dr(mind)
        v_plane_cyl(mind) = v_plane_cyl(mind) + dr(mind)
        call cyl_to_uvw(arc_cyl,arc)
        call cyl_to_uvw(h_plane_cyl,h_plane)
        call cyl_to_uvw(v_plane_cyl,v_plane)
        redge_cyl(1) = v_plane_cyl(1) + pass_grid%dr
        redge_cyl(2) = v_plane_cyl(2)
        redge_cyl(3) = v_plane_cyl(3)
        call cyl_to_uvw(redge_cyl,redge)
        tedge_cyl(1) = v_plane_cyl(1)
        tedge_cyl(2) = v_plane_cyl(2) + pass_grid%dz
        tedge_cyl(3) = v_plane_cyl(3)
        call cyl_to_uvw(tedge_cyl,tedge)
        call plane_basis(v_plane, redge, tedge, basis)
    enddo track_loop
    ntrack = cc-1
    if(present(los_intersect)) then
        los_intersect = los_inter
    endif

end subroutine track_cylindrical

!============================================================================
!---------------------------Interpolation Routines---------------------------
!============================================================================
subroutine interpol1D_coeff(xmin,dx,nx,xout,c,err)
    !+ Linear interpolation coefficients and index for a 1D grid y(x)
    real(Float64), intent(in)           :: xmin
        !+ Minimum abscissa value
    real(Float64), intent(in)           :: dx
        !+ Absissa spacing
    integer, intent(in)                 :: nx
        !+ Number of abscissa
    real(Float64), intent(in)           :: xout
        !+ Abscissa value to interpolate
    type(InterpolCoeffs1D), intent(out) :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional      :: err
        !+ Error code

    real(Float64) :: x1, xp, b1, b2
    integer :: i, err_status

    err_status = 1
    xp = max(xout,xmin)
    i = floor((xp - xmin)/dx)+1

    if ((i.gt.0).and.(i.le.(nx-1))) then
        x1 = xmin + (i-1)*dx

        b2 = (xp - x1)/dx
        b1 = (1.0 - b2)

        c%i = i
        c%b1 = b1
        c%b2 = b2
        err_status = 0
    endif

    if(present(err)) err = err_status

end subroutine interpol1D_coeff

subroutine interpol1D_coeff_arr(x,xout,c,err)
    !+ Linear interpolation coefficients and index for a 1D grid y(x)
    real(Float64), dimension(:), intent(in) :: x
        !+ Abscissa values
    real(Float64), intent(in)               :: xout
        !+ Abscissa value to interpolate
    type(InterpolCoeffs1D), intent(out)     :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional          :: err
        !+ Error code

    real(Float64) :: xmin, dx
    integer :: sx,err_status

    err_status = 1
    sx = size(x)
    xmin = x(1)
    dx = abs(x(2)-x(1))

    call interpol1D_coeff(xmin, dx, sx, xout, c, err_status)

    if(present(err)) err = err_status

end subroutine interpol1D_coeff_arr

subroutine interpol2D_coeff(xmin,dx,nx,ymin,dy,ny,xout,yout,c,err)
    !+ Bilinear interpolation coefficients and indicies for a 2D grid z(x,y)
    real(Float64), intent(in)           :: xmin
        !+ Minimum abscissa
    real(Float64), intent(in)           :: dx
        !+ Abscissa spacing
    integer, intent(in)                 :: nx
        !+ Number of abscissa
    real(Float64), intent(in)           :: ymin
        !+ Minimum ordinate
    real(Float64), intent(in)           :: dy
        !+ Ordinate spacing
    integer, intent(in)                 :: ny
        !+ Number of ordinates points
    real(Float64), intent(in)           :: xout
        !+ Abscissa value to interpolate
    real(Float64), intent(in)           :: yout
        !+ Ordinate value to interpolate
    type(InterpolCoeffs2D), intent(out) :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional      :: err
        !+ Error code

    real(Float64) :: x1, x2, y1, y2, xp, yp
    integer :: i, j, err_status

    err_status = 1
    xp = max(xout,xmin)
    yp = max(yout,ymin)
    i = floor((xp-xmin)/dx)+1
    j = floor((yp-ymin)/dy)+1

    if (((i.gt.0).and.(i.le.(nx-1))).and.((j.gt.0).and.(j.le.(ny-1)))) then
        x1 = xmin + (i-1)*dx
        x2 = x1 + dx
        y1 = ymin + (j-1)*dy
        y2 = y1 + dy

        c%b11 = ((x2 - xp) * (y2 - yp))/(dx*dy)
        c%b21 = ((xp - x1) * (y2 - yp))/(dx*dy)
        c%b12 = ((x2 - xp) * (yp - y1))/(dx*dy)
        c%b22 = ((xp - x1) * (yp - y1))/(dx*dy)
        c%i = i
        c%j = j
        err_status = 0
    endif

    if(present(err)) err = err_status

end subroutine interpol2D_coeff

subroutine interpol2D_coeff_arr(x,y,xout,yout,c,err)
    !!Bilinear interpolation coefficients and indicies for a 2D grid z(x,y)
    real(Float64), dimension(:), intent(in) :: x
        !+ Abscissa values
    real(Float64), dimension(:), intent(in) :: y
        !+ Ordinate values
    real(Float64), intent(in)               :: xout
        !+ Abscissa value to interpolate
    real(Float64), intent(in)               :: yout
        !+ Ordinate value to interpolate
    type(InterpolCoeffs2D), intent(out)     :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional          :: err
        !+ Error code

    real(Float64) :: xmin, ymin, dx, dy
    integer :: sx, sy, err_status

    err_status = 1
    sx = size(x)
    sy = size(y)
    xmin = x(1)
    ymin = y(1)
    dx = abs(x(2)-x(1))
    dy = abs(y(2)-y(1))

    call interpol2D_coeff(xmin, dx, sx, ymin, dy, sy, xout, yout, c, err_status)

    if(present(err)) err = err_status

end subroutine interpol2D_coeff_arr

subroutine cyl_interpol3D_coeff(rmin,dr,nr,zmin,dz,nz,phimin,dphi,nphi,rout,zout,phiout,c,err)
    !+ Cylindrical interpolation coefficients and indicies for a 3D grid
    real(Float64), intent(in)           :: rmin
        !+ Minimum R
    real(Float64), intent(in)           :: dr
        !+ R spacing
    integer, intent(in)                 :: nr
        !+ Number of R points
    real(Float64), intent(in)           :: zmin
        !+ Minimum Z
    real(Float64), intent(in)           :: dz
        !+ Z spacing
    integer, intent(in)                 :: nz
        !+ Number of Z points
    real(Float64), intent(in)           :: phimin
        !+ Minimum phi
    real(Float64), intent(in)           :: dphi
        !+ Phi spacing
    integer, intent(in)                 :: nphi
        !+ Number of phi points
    real(Float64), intent(in)           :: rout
        !+ R value to interpolate
    real(Float64), intent(in)           :: zout
        !+ Z value to interpolate
    real(Float64), intent(in)           :: phiout
        !+ Phi value to interpolate
    type(InterpolCoeffs3D), intent(out) :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional      :: err
        !+ Error code

    type(InterpolCoeffs2D) :: b
    real(Float64) :: r1, r2, phi1, phi2, z1, z2, rp, phip, zp, dV
    real(Float64) :: phi
    integer :: i, j, k, err_status

    err_status = 1

    rp = max(rout,rmin)
    zp = max(zout,zmin)
    phip = max(phiout,phimin)
    i = floor((rp-rmin)/dr)+1
    j = floor((zp-zmin)/dz)+1
    k = floor((phip-phimin)/dphi)+1

    if (nphi .eq. 1) then
        if (((i.gt.0).and.(i.le.(nr-1))).and.((j.gt.0).and.(j.le.(nz-1)))) then
            call interpol2D_coeff(rmin, dr, nr, zmin, dz, nz, rout, zout, b, err_status)
            c%b111 = b%b11
            c%b121 = b%b12
            c%b221 = b%b22
            c%b211 = b%b21
            c%b212 = 0
            c%b222 = 0
            c%b122 = 0
            c%b112 = 0
            c%i = b%i
            c%j = b%j
            c%k = 1
            err_status = 0
        endif
    else
        if ((((i.gt.0).and.(i.le.(nr-1))).and.((j.gt.0).and.(j.le.(nz-1)))).and.((k.gt.0).and.(k.le.(nphi-1)))) then
            r1 = rmin + (i-1)*dr
            r2 = r1 + dr
            z1 = zmin + (j-1)*dz
            z2 = z1 + dz
            phi1 = phimin + (k-1)*dphi
            phi2 = phi1 + dphi
            dV = ((r2**2 - r1**2) * (phi2 - phi1) * (z2 - z1))

            !! Both volume elements have a factor of 1/2 that cancels out
            c%b111 = ((r2**2 - rp**2) * (phi2 - phip) * (z2 - zp)) / dV
            c%b121 = ((r2**2 - rp**2) * (phi2 - phip) * (zp - z1)) / dV
            c%b221 = ((rp**2 - r1**2) * (phi2 - phip) * (zp - z1)) / dV
            c%b211 = ((rp**2 - r1**2) * (phi2 - phip) * (z2 - zp)) / dV
            c%b212 = ((rp**2 - r1**2) * (phip - phi1) * (z2 - zp)) / dV
            c%b222 = ((rp**2 - r1**2) * (phip - phi1) * (zp - z1)) / dV
            c%b122 = ((r2**2 - rp**2) * (phip - phi1) * (zp - z1)) / dV
            c%b112 = ((r2**2 - rp**2) * (phip - phi1) * (z2 - zp)) / dV
            c%i = i
            c%j = j
            c%k = k
            err_status = 0
        endif
    endif

    if(present(err)) err = err_status

end subroutine cyl_interpol3D_coeff

subroutine cyl_interpol3D_coeff_arr(r,z,phi,rout,zout,phiout,c,err)
    !+ Cylindrical interpolation coefficients and indicies for a 3D grid
    real(Float64), dimension(:), intent(in) :: r
        !+ R values
    real(Float64), dimension(:), intent(in) :: z
        !+ Z values
    real(Float64), dimension(:), intent(in) :: phi
        !+ Phi values
    real(Float64), intent(in)               :: rout
        !+ R value to interpolate
    real(Float64), intent(in)               :: zout
        !+ Z value to interpolate
    real(Float64), intent(in)               :: phiout
        !+ Phi value to interpolate
    type(InterpolCoeffs3D), intent(out)     :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional          :: err
        !+ Error code

    type(InterpolCoeffs2D) :: b
    real(Float64) :: rmin, phimin, zmin, dr, dphi, dz
    integer :: sr, sphi, sz, err_status

    err_status = 1
    sr = size(r)
    sphi = size(phi)
    sz = size(z)

    rmin = r(1)
    zmin = z(1)
    dr = abs(r(2)-r(1))
    dz = abs(z(2)-z(1))

    if (sphi .eq. 1) then
        call interpol2D_coeff(rmin, dr, sr, zmin, dz, sz, rout, zout, b, err_status)
        c%b111 = b%b11
        c%b121 = b%b12
        c%b221 = b%b22
        c%b211 = b%b21
        c%b212 = 0
        c%b222 = 0
        c%b122 = 0
        c%b112 = 0
        c%i = b%i
        c%j = b%j
        c%k = 1
    else
        phimin = phi(1)
        dphi = abs(phi(2)-phi(1))
        call cyl_interpol3D_coeff(rmin, dr, sr, zmin, dz, sz, phimin, dphi, sphi, rout, zout, phiout, c, err_status)
    endif

    if(present(err)) err = err_status

end subroutine cyl_interpol3D_coeff_arr

subroutine interpol1D_arr(x, y, xout, yout, err, coeffs)
    !+ Performs linear interpolation on a uniform 1D grid y(x)
    real(Float64), dimension(:), intent(in)      :: x
        !+ The abscissa values of `y`
    real(Float64), dimension(:), intent(in)      :: y
        !+ Values at abscissa values `x`: y(x)
    real(Float64), intent(in)                    :: xout
        !+ Abscissa value to interpolate
    real(Float64), intent(out)                   :: yout
        !+ Interpolant: y(xout)
    integer, intent(out), optional               :: err
        !+ Error code
    type(InterpolCoeffs1D), intent(in), optional :: coeffs
        !+ Precomputed Linear Interpolation Coefficients

    type(InterpolCoeffs1D) :: c
    integer :: i, err_status

    err_status = 1
    if(present(coeffs)) then
        c = coeffs
        err_status = 0
    else
        call interpol_coeff(x,xout,c,err_status)
    endif

    if(err_status.eq.0) then
        i = c%i
        yout = c%b1*y(i) + c%b2*y(i+1)
    else
        yout = 0.d0
    endif

    if(present(err)) err = err_status

end subroutine interpol1D_arr

subroutine interpol2D_arr(x, y, z, xout, yout, zout, err, coeffs)
    !+ Performs bilinear interpolation on a 2D grid z(x,y)
    real(Float64), dimension(:), intent(in)   :: x
        !+ The abscissa values of `z`
    real(Float64), dimension(:), intent(in)   :: y
        !+ The ordinate values of `z`
    real(Float64), dimension(:,:), intent(in) :: z
        !+ Values at the abscissa/ordinates: z(x,y)
    real(Float64), intent(in)                 :: xout
        !+ The abscissa value to interpolate
    real(Float64), intent(in)                 :: yout
        !+ The ordinate value to interpolate
    real(Float64), intent(out)                :: zout
        !+ Interpolant: z(xout,yout)
    integer, intent(out), optional            :: err
        !+ Error code
    type(InterpolCoeffs2D), intent(in), optional :: coeffs
        !+ Precomputed Linear Interpolation Coefficients

    type(InterpolCoeffs2D) :: c
    integer :: i, j, err_status

    err_status = 1
    if(present(coeffs)) then
        c = coeffs
        err_status = 0
    else
        call interpol_coeff(x,y,xout,yout,c,err_status)
    endif

    if(err_status.eq.0) then
        i = c%i
        j = c%j
        zout = c%b11*z(i,j) + c%b12*z(i,j+1) + c%b21*z(i+1,j) + c%b22*z(i+1,j+1)
    else
        zout = 0.d0
    endif

    if(present(err)) err = err_status

end subroutine interpol2D_arr

subroutine interpol2D_2D_arr(x, y, z, xout, yout, zout, err, coeffs)
    !+ Performs bilinear interpolation on a 2D grid of 2D arrays z(:,:,x,y)
    real(Float64), dimension(:), intent(in)       :: x
        !+ The abscissa values of `z`
    real(Float64), dimension(:), intent(in)       :: y
        !+ The ordinate values of `z`
    real(Float64), dimension(:,:,:,:), intent(in) :: z
        !+ Values at the abscissa/ordinates: z(:,:,x,y)
    real(Float64), intent(in)                     :: xout
        !+ The abscissa value to interpolate
    real(Float64), intent(in)                     :: yout
        !+ The ordinate value to interpolate
    real(Float64), dimension(:,:), intent(out)    :: zout
        !+ Interpolant: z(:,:,xout,yout)
    integer, intent(out), optional                :: err
        !+ Error code
    type(InterpolCoeffs2D), intent(in), optional :: coeffs
        !+ Precomputed Linear Interpolation Coefficients

    type(InterpolCoeffs2D) :: c
    integer :: i, j, err_status

    err_status = 1
    if(present(coeffs)) then
        c = coeffs
        err_status = 0
    else
        call interpol_coeff(x,y,xout,yout,c,err_status)
    endif

    if(err_status.eq.0) then
        i = c%i
        j = c%j
        zout = c%b11*z(:,:,i,j) + c%b12*z(:,:,i,j+1) + c%b21*z(:,:,i+1,j) + c%b22*z(:,:,i+1,j+1)
    else
        zout = 0.0
    endif

    if(present(err)) err = err_status

end subroutine interpol2D_2D_arr

subroutine interpol3D_arr(r, z, phi, d, rout, zout, phiout, dout, err, coeffs)
    !+ Performs cylindrical interpolation on a 3D grid f(r,z,phi)
    real(Float64), dimension(:), intent(in) :: r
        !+ R values
    real(Float64), dimension(:), intent(in) :: z
        !+ Z values
    real(Float64), dimension(:), intent(in) :: phi
        !+ Phi values
    real(Float64), dimension(:,:,:), intent(in) :: d
        !+ Values at r,z,phi: d(r,z,phi)
    real(Float64), intent(in)               :: rout
        !+ R value to interpolate
    real(Float64), intent(in)               :: zout
        !+ Z value to interpolate
    real(Float64), intent(in)               :: phiout
        !+ Phi value to interpolate
    real(Float64), intent(out)                :: dout
        !+ Interpolant: d(rout,zout,phiout)
    integer, intent(out), optional          :: err
        !+ Error code
    type(InterpolCoeffs3D), intent(in), optional :: coeffs
        !+ Precomputed Interpolation Coefficients

    type(InterpolCoeffs3D) :: b
    integer :: i, j, k, k2, err_status
    integer :: nphi

    err_status = 1

    nphi = size(phi)

    if(present(coeffs)) then
        b = coeffs
        if(nphi .eq. 1) then
            b%b212 = 0
            b%b222 = 0
            b%b122 = 0
            b%b112 = 0
            b%k = 1
        endif
        err_status = 0
    else
        call interpol_coeff(r,z,phi,rout,zout,phiout,b,err_status)
    endif


    if(err_status.eq.0) then
        i = b%i
        j = b%j
        k = b%k
        if(nphi .eq. 1) then
            k2 = min(k+1,nphi)
        else
            k2 = k+1
        endif

        dout = b%b111*d(i,j,k)    + b%b121*d(i,j+1,k) +   &
               b%b112*d(i,j,k2)   + b%b122*d(i,j+1,k2) +  &
               b%b211*d(i+1,j,k)  + b%b221*d(i+1,j+1,k) + &
               b%b212*d(i+1,j,k2) + b%b222*d(i+1,j+1,k2)
    else
        dout = 0.d0
    endif

    if(present(err)) err = err_status

end subroutine interpol3D_arr

subroutine interpol3D_2D_arr(r, z, phi, f, rout, zout, phiout, fout, err, coeffs)
    !+ Performs cylindrical interpolation on a 3D grid of 2D arrays
    !+ f(:,:,r,z,phi)
    real(Float64), dimension(:), intent(in) :: r
        !+ R values
    real(Float64), dimension(:), intent(in) :: z
        !+ Z values
    real(Float64), dimension(:), intent(in) :: phi
        !+ Phi values
    real(Float64), dimension(:,:,:,:,:), intent(in) :: f
        !+ Values at r,z,phi: f(:,:,r,z,phi)
    real(Float64), intent(in)               :: rout
        !+ R value to interpolate
    real(Float64), intent(in)               :: zout
        !+ Z value to interpolate
    real(Float64), intent(in)               :: phiout
        !+ Phi value to interpolate
    real(Float64), dimension(:,:), intent(out)    :: fout
        !+ Interpolant: f(:,:,rout,zout,phiout)
    integer, intent(out), optional          :: err
        !+ Error code
    type(InterpolCoeffs3D), intent(in), optional :: coeffs
        !+ Precomputed Interpolation Coefficients

    type(InterpolCoeffs3D) :: b
    integer :: i, j, k, k2, err_status
    integer :: nphi

    err_status = 1

    nphi = size(phi)

    if(present(coeffs)) then
        b = coeffs
        if(nphi .eq. 1) then
            b%b212 = 0
            b%b222 = 0
            b%b122 = 0
            b%b112 = 0
            b%k = 1
        endif
        err_status = 0
    else
        call interpol_coeff(r,z,phi,rout,zout,phiout,b,err_status)
    endif

    if(err_status.eq.0) then
        i = b%i
        j = b%j
        k = b%k
        if(nphi .eq. 1) then
            k2 = min(k+1,nphi)
        else
            k2 = k+1
        endif
        fout = b%b111*f(:,:,i,j,k)    + b%b121*f(:,:,i,j+1,k) +   &
               b%b112*f(:,:,i,j,k2)   + b%b122*f(:,:,i,j+1,k2) +  &
               b%b211*f(:,:,i+1,j,k)  + b%b221*f(:,:,i+1,j+1,k) + &
               b%b212*f(:,:,i+1,j,k2) + b%b222*f(:,:,i+1,j+1,k2)
    else
        fout = 0.0
    endif

    if(present(err)) err = err_status

end subroutine interpol3D_2D_arr

!=============================================================================
!-------------------------Profiles and Fields Routines------------------------
!=============================================================================
subroutine in_plasma(xyz, inp, input_coords, coeffs, uvw_out)
    !+ Indicator subroutine to determine if a position is in a region where
    !+ the plasma parameter and fields are valid/known
    real(Float64), dimension(3), intent(in) :: xyz
        !+ Position in beam coordinates
    logical, intent(out)                    :: inp
        !+ Indicates whether plasma parameters and fields are valid/known
    integer, intent(in), optional           :: input_coords
        !+ Indicates coordinate system of xyz. Beam grid (0), machine (1) and cylindrical (2)
    type(InterpolCoeffs3D), intent(out), optional      :: coeffs
        !+ Interpolation coefficients used in calculation
    real(Float64), dimension(3), intent(out), optional :: uvw_out
        !+ Position in machine coordinates

    real(Float64), dimension(3) :: uvw
    type(InterpolCoeffs3D) :: b
    real(Float64) :: R, W, mask
    real(Float64) :: phi
    integer :: i, j, k, k2, err, ics

    err = 1

    if(present(input_coords)) then
        ics = input_coords
    else
        ics = 0
    endif

    if(ics.eq.0) then
        call xyz_to_uvw(xyz,uvw)
    endif
    if(ics.eq.1) then
        uvw = xyz
    endif
    if(ics.eq.2) then
        call cyl_to_uvw(xyz,uvw)
    endif

    R = sqrt(uvw(1)*uvw(1) + uvw(2)*uvw(2))
    W = uvw(3)
    phi = atan2(uvw(2),uvw(1))
    !! Interpolate mask value
    call interpol_coeff(inter_grid%r, inter_grid%z, inter_grid%phi, R, W, phi, b, err)

    inp = .False.
    if(err.eq.0) then
        i = b%i
        j = b%j
        k = b%k
        if(inter_grid%nphi .eq. 1) then
            k2 = min(k+1,inter_grid%nphi)
        else
            k2 = k+1
        endif
        mask = b%b111*equil%mask(i,j,k)     + b%b112*equil%mask(i,j,k2) +   &
               b%b121*equil%mask(i,j+1,k)   + b%b122*equil%mask(i,j+1,k2) + &
               b%b211*equil%mask(i+1,j,k)   + b%b212*equil%mask(i+1,j,k2) + &
               b%b221*equil%mask(i+1,j+1,k) + b%b222*equil%mask(i+1,j+1,k2)

        if((mask.ge.0.5).and.(err.eq.0)) then
            inp = .True.
        endif
    endif


    if(present(coeffs)) coeffs = b
    if(present(uvw_out)) uvw_out = uvw

end subroutine in_plasma

subroutine get_plasma(plasma, pos, ind, input_coords, output_coords)
    !+ Gets plasma parameters at position `pos` or [[libfida:beam_grid]] indices `ind`
    type(LocalProfiles), intent(out)                   :: plasma
        !+ Plasma parameters at `pos`/`ind`
    real(Float64), dimension(3), intent(in), optional  :: pos
        !+ Position in beam grid coordinates
    integer(Int32), dimension(3), intent(in), optional :: ind
        !+ [[libfida:beam_grid]] indices
    integer(Int32), intent(in), optional               :: input_coords
        !+ Indicates coordinate system of inputs. Beam grid (0), machine (1) and cylindrical (2)
    integer(Int32), intent(in), optional               :: output_coords
        !+ Indicates coordinate system of outputs. Beam grid (0), machine (1) and cylindrical (2)

    logical :: inp
    type(InterpolCoeffs3D) :: coeffs
    real(Float64), dimension(3) :: xyz, uvw, cyl, vrot_uvw
    real(Float64) :: phi, s, c
    integer :: i, j, k, k2, ics, ocs

    plasma%in_plasma = .False.

    if(present(input_coords)) then
        ics = input_coords
    else
        ics = 0
    endif
    if(present(output_coords)) then
        ocs = output_coords
    else
        ocs = 0
    endif

    if(present(ind)) then
        if(ics.eq.0) then
            call get_position(ind,xyz)
        endif
        if(ics.eq.2) then
            call get_position(ind,xyz,input_coords=2)
        endif
    endif

    if(present(pos)) then
        if(ics.eq.0) then
            xyz = pos
            call xyz_to_uvw(xyz, uvw)
        endif
        if(ics.eq.1) then
            uvw = pos
            call uvw_to_xyz(uvw, xyz)
        endif
    endif

    call in_plasma(xyz,inp,0,coeffs)
    if(inp) then
        phi = atan2(uvw(2),uvw(1))
        i = coeffs%i
        j = coeffs%j
        k = coeffs%k
        if(inter_grid%nphi .eq. 1) then
            k2 = min(k+1,inter_grid%nphi)
        else
            k2 = k+1
        endif

        plasma = coeffs%b111*equil%plasma(i,j,k)    + coeffs%b121*equil%plasma(i,j+1,k) +   &
                 coeffs%b112*equil%plasma(i,j,k2)   + coeffs%b122*equil%plasma(i,j+1,k2) +  &
                 coeffs%b211*equil%plasma(i+1,j,k)  + coeffs%b221*equil%plasma(i+1,j+1,k) + &
                 coeffs%b212*equil%plasma(i+1,j,k2) + coeffs%b222*equil%plasma(i+1,j+1,k2)

        s = sin(phi) ; c = cos(phi)
        vrot_uvw(1) = plasma%vr*c - plasma%vt*s
        vrot_uvw(2) = plasma%vr*s + plasma%vt*c
        vrot_uvw(3) = plasma%vz
        if(ocs.eq.0) then
            plasma%vrot = matmul(beam_grid%inv_basis,vrot_uvw)
            plasma%pos = xyz
        endif
        if(ocs.eq.1) then
            plasma%vrot = vrot_uvw
            plasma%pos = uvw
        endif
        plasma%uvw = uvw
        plasma%in_plasma = .True.
        plasma%b = coeffs
    endif

end subroutine get_plasma

subroutine calc_perp_vectors(b, a, c)
  !+ Calculates normalized vectors that are perpendicular to b
  !+ such that `a` x `c` = `b_norm`
  real(Float64), dimension(3), intent(in)  :: b
  real(Float64), dimension(3), intent(out) :: a
  real(Float64), dimension(3), intent(out) :: c

  real(Float64), dimension(3) :: bnorm

  bnorm=b/norm2(b)

  if (abs(bnorm(3)).eq.1) then
      a=[1.d0,0.d0,0.d0]
      c=[0.d0,1.d0,0.d0]
  else
      if (bnorm(3).eq.0.) then
          a=[0.d0,0.d0,1.d0]
          c=[bnorm(2),-bnorm(1), 0.d0]/sqrt(bnorm(1)**2+bnorm(2)**2)
      else
          a=[bnorm(2),-bnorm(1),0.d0]/sqrt(bnorm(1)**2+bnorm(2)**2)
          c=-[ a(2) , -a(1) , (a(1)*bnorm(2)-a(2)*bnorm(1))/bnorm(3) ]
          c=c/norm2(c)
          if(bnorm(3).lt.0.0) then
              c=-c
          endif
      endif
  endif

end subroutine calc_perp_vectors

subroutine get_fields(fields, pos, ind, input_coords, output_coords)
    !+ Gets electro-magnetic fields at position `pos` or [[libfida:beam_grid]] indices `ind`
    type(LocalEMFields),intent(out)                    :: fields
        !+ Electro-magnetic fields at `pos`/`ind`
    real(Float64), dimension(3), intent(in), optional  :: pos
        !+ Position in beam grid coordinates
    integer(Int32), dimension(3), intent(in), optional :: ind
        !+ [[libfida:beam_grid]] indices
    integer(Int32), intent(in), optional               :: input_coords
        !+ Indicates coordinate system of inputs. Beam grid (0), machine (1) and cylindrical (2)
    integer(Int32), intent(in), optional               :: output_coords
        !+ Indicates coordinate system of outputs. Beam grid (0), machine (1) and cylindrical (2)

    logical :: inp
    real(Float64), dimension(3) :: xyz, uvw
    real(Float64), dimension(3) :: uvw_bfield, uvw_efield
    real(Float64), dimension(3) :: xyz_bfield, xyz_efield
    real(Float64) :: phi, s, c
    type(InterpolCoeffs3D) :: coeffs
    integer :: i, j, k, k2, mc, ocs, ics

    fields%in_plasma = .False.

    if(present(input_coords)) then
        ics = input_coords
    else
        ics = 0
    endif

    if(present(output_coords)) then
        ocs = output_coords
    else
        ocs = 0
    endif

    if(present(ind)) call get_position(ind,xyz)

    if(present(pos)) then
        if(ics.eq.0) then
            xyz = pos
            call xyz_to_uvw(xyz, uvw)
        endif
        if(ics.eq.1) then
            uvw = pos
            call uvw_to_xyz(uvw, xyz)
        endif
    endif

    call in_plasma(xyz,inp,0,coeffs)
    if(inp) then
        i = coeffs%i
        j = coeffs%j
        k = coeffs%k
        if(inter_grid%nphi .eq. 1) then
            k2 = min(k+1,inter_grid%nphi)
        else
            k2 = k+1
        endif

        fields = coeffs%b111*equil%fields(i,j,k)    + coeffs%b121*equil%fields(i,j+1,k) +   &
                 coeffs%b112*equil%fields(i,j,k2)   + coeffs%b122*equil%fields(i,j+1,k2) +  &
                 coeffs%b211*equil%fields(i+1,j,k)  + coeffs%b221*equil%fields(i+1,j+1,k) + &
                 coeffs%b212*equil%fields(i+1,j,k2) + coeffs%b222*equil%fields(i+1,j+1,k2)

        phi = atan2(uvw(2),uvw(1))
        s = sin(phi) ; c = cos(phi)

        !Convert cylindrical coordinates to uvw
        uvw_bfield(1) = c*fields%br - s*fields%bt
        uvw_bfield(2) = s*fields%br + c*fields%bt
        uvw_bfield(3) = fields%bz
        uvw_efield(1) = c*fields%er - s*fields%et
        uvw_efield(2) = s*fields%er + c*fields%et
        uvw_efield(3) = fields%ez

        if(ocs.eq.0) then
            !Represent fields in beam grid coordinates
            xyz_bfield = matmul(beam_grid%inv_basis,uvw_bfield)
            xyz_efield = matmul(beam_grid%inv_basis,uvw_efield)
            fields%pos = xyz
        endif
        if(ocs.eq.1) then
            xyz_bfield = uvw_bfield
            xyz_efield = uvw_efield
            fields%pos = uvw
        endif

        !Calculate field directions and magnitudes
        fields%b_abs = norm2(xyz_bfield)
        fields%e_abs = norm2(xyz_efield)
        if(fields%b_abs.gt.0.d0) fields%b_norm = xyz_bfield/fields%b_abs
        if(fields%e_abs.gt.0.d0) fields%e_norm = xyz_efield/fields%e_abs

        call calc_perp_vectors(fields%b_norm,fields%a_norm,fields%c_norm)

        fields%uvw = uvw
        fields%in_plasma = .True.
        fields%coords = ocs
        fields%b = coeffs
    endif

end subroutine get_fields

subroutine get_distribution(fbeam, denf, pos, ind, coeffs)
    !+ Gets Guiding Center distribution at position `pos` or [[libfida:beam_grid]] indices `ind`
    real(Float64), dimension(:,:), intent(out)         :: fbeam
        !+ Guiding Center Fast-ion distribution at `pos`/`ind`: F(E,p)
    real(Float64), intent(out)                         :: denf
        !+ Guiding Center Fast-ion density at `pos`/`ind` [fast-ions/cm^3]
    real(Float64), dimension(3), intent(in), optional  :: pos
        !+ Position in beam grid coordinates
    integer(Int32), dimension(3), intent(in), optional :: ind
        !+ [[libfida:beam_grid]] indices
    type(InterpolCoeffs3D), intent(in), optional       :: coeffs
        !+ Precomputed interpolation coefficients

    real(Float64), dimension(3) :: xyz, uvw
    real(Float64) :: R, Z, Phi
    integer :: err

    if(present(coeffs)) then
        call interpol(fbm%r, fbm%z, fbm%phi, fbm%f, R, Z, Phi, fbeam, err, coeffs)
        call interpol(fbm%r, fbm%z, fbm%phi, fbm%denf, R, Z, Phi, denf, err, coeffs)
    else
        if(present(ind)) call get_position(ind,xyz)
        if(present(pos)) xyz = pos

        !! Convert to machine coordinates
        call xyz_to_uvw(xyz,uvw)
        R = sqrt(uvw(1)*uvw(1) + uvw(2)*uvw(2))
        Z = uvw(3)
        Phi = atan2(uvw(2),uvw(1))

        call interpol(fbm%r, fbm%z, fbm%phi, fbm%f, R, Z, Phi, fbeam, err)
        call interpol(fbm%r, fbm%z, fbm%phi, fbm%denf, R, Z, Phi, denf, err)
    endif

end subroutine get_distribution

subroutine get_ep_denf(energy, pitch, denf, pos, ind, coeffs)
    !+ Get guiding center fast-ion density at given energy and pitch
    !+ at position `pos` or [[libfida:beam_grid]] indices `ind`
    real(Float64), intent(in)                          :: energy
        !+ Energy [keV]
    real(Float64), intent(in)                          :: pitch
        !+ Pitch
    real(Float64), intent(out)                         :: denf
        !+ Fast-ion density [fast-ions/(cm^3*dE*dp)]
    real(Float64), dimension(3), intent(in), optional  :: pos
        !+ Position in beam grid coordinates
    integer(Int32), dimension(3), intent(in), optional :: ind
        !+ [[libfida:beam_grid]] indices
    type(InterpolCoeffs3D), intent(in), optional       :: coeffs
        !+ Precomputed interpolation coefficients

    real(Float64), dimension(3) :: xyz, uvw
    real(Float64), dimension(fbm%nenergy,fbm%npitch)  :: fbeam
    integer(Int32), dimension(2) :: epi
    real(Float64) :: R, Phi, Z
    real(Float64) :: dE, dp
    integer :: err

    epi(1) = minloc(abs(fbm%energy - energy),1)
    epi(2) = minloc(abs(fbm%pitch - pitch),1)
    dE = abs(fbm%energy(epi(1)) - energy)
    dp = abs(fbm%pitch(epi(2)) - pitch)

    if((dE.le.fbm%dE).and.(dp.le.fbm%dp)) then
        if(present(coeffs)) then
            call interpol(inter_grid%r, inter_grid%z, inter_grid%phi, fbm%f, R, Z, Phi, fbeam, err, coeffs)
        else
            if(present(ind)) call get_position(ind,xyz)
            if(present(pos)) xyz = pos

            !! Convert to machine coordinates
            call xyz_to_uvw(xyz,uvw)
            R = sqrt(uvw(1)*uvw(1) + uvw(2)*uvw(2))
            Z = uvw(3)
            Phi = atan2(uvw(2),uvw(1))

            call interpol(inter_grid%r, inter_grid%z, inter_grid%phi, fbm%f, R, Z, Phi, fbeam, err)
        endif
        denf = fbeam(epi(1),epi(2))
    else
        denf = 0.0
    endif

end subroutine get_ep_denf

!=============================================================================
!--------------------------Result Storage Routines----------------------------
!=============================================================================
subroutine store_neutrals(ind, neut_type, dens, vn, store_iter)
    !Store neutrals in [[libfida:neut]] at indices `ind`
    integer(Int32), dimension(3), intent(in) :: ind
        !+ [[libfida:beam_grid]] indices
    integer, intent(in)                      :: neut_type
        !+ Neutral type
    real(Float64), dimension(:), intent(in)  :: dens
        !+ Neutral density [neutrals/cm^3]
    real(Float64), dimension(3), intent(in)  :: vn
        !+ Neutral particle velocity [cm/s]
    logical, intent(in), optional            :: store_iter
        !+ Store DCX/Halo iteration density in [[libfida:halo_iter_dens]]
    logical :: iter

    integer :: i, j, k
    if(present(store_iter)) then
        iter = store_iter
    else
        iter = .False.
    endif

    i = ind(1) ; j = ind(2) ; k = ind(3)

    !$OMP CRITICAL(store_neutrals_1)
    if(iter) halo_iter_dens(neut_type) = halo_iter_dens(neut_type) + sum(dens)
    select case (neut_type)
        case (nbif_type)
            neut%full(:,i,j,k) = neut%full(:,i,j,k) + dens
        case (nbih_type)
            neut%half(:,i,j,k) = neut%half(:,i,j,k) + dens
        case (nbit_type)
            neut%third(:,i,j,k) = neut%third(:,i,j,k) + dens
        case (dcx_type)
            neut%dcx(:,i,j,k) = neut%dcx(:,i,j,k) + dens
        case (halo_type)
            neut%halo(:,i,j,k) = neut%halo(:,i,j,k) + dens
        case default
            if(inputs%verbose.ge.0) then
                write(*,'("STORE_NEUTRALS: Unknown neutral type: ",i2)') neut_type
            endif
            stop
    end select
    !$OMP END CRITICAL(store_neutrals_1)

end subroutine store_neutrals

subroutine store_births(ind, neut_type, dflux)
    !+ Store birth particles/density in [[libfida:birth]]
    integer(Int32), dimension(3), intent(in) :: ind
        !+ [[libfida:beam_grid]] indices
    integer(Int32), intent(in)               :: neut_type
        !+ Neutral type
    real(Float64), intent(in)                :: dflux
        !+ Deposited flux

    !$OMP ATOMIC UPDATE
    birth%dens( neut_type,ind(1),ind(2),ind(3))= &
     birth%dens(neut_type,ind(1),ind(2),ind(3)) + dflux
    !$OMP END ATOMIC
end subroutine store_births

subroutine store_npa(det, ri, rf, vn, flux, orbit_class, passive)
    !+ Store NPA particles in [[libfida:npa]]
    integer, intent(in)                     :: det
        !+ Detector/Channel Number
    real(Float64), dimension(3), intent(in) :: ri
        !+ Birth position in beam coordinates [cm]
    real(Float64), dimension(3), intent(in) :: rf
        !+ Detector position in beam coordinates [cm]
    real(Float64), dimension(3), intent(in) :: vn
        !+ Particle velocity [cm/s]
    real(Float64), intent(in)               :: flux
        !+ Neutral flux [neutrals/s]
    integer, intent(in), optional           :: orbit_class
        !+ Orbit class ID
    logical, intent(in), optional           :: passive
        !+ Indicates whether npa particle is passive

    integer :: iclass, oclass
    type(LocalEMFields) :: fields
    real(Float64), dimension(3) :: uvw_ri, uvw_rf,vn_norm
    real(Float64) :: energy, pitch, dE
    integer(Int32), dimension(1) :: ienergy
    type(NPAParticle), dimension(:), allocatable :: parts
    logical :: pas = .False.

    if(present(orbit_class)) then
        iclass = min(orbit_class,particles%nclass)
        oclass = orbit_class
    else
        iclass = 1
        oclass = 1
    endif

    if(present(passive)) pas = passive

    ! Convert to machine coordinates
    call xyz_to_uvw(ri,uvw_ri)
    call xyz_to_uvw(rf,uvw_rf)

    ! Calculate energy
    energy = inputs%ab*v2_to_E_per_amu*dot_product(vn,vn)
    if(pas) then
        dE = pnpa%energy(2)-pnpa%energy(1)
    else
        dE = npa%energy(2)-npa%energy(1)
    endif


    ! Calculate pitch if distribution actually uses pitch
    if(inputs%dist_type.le.2) then
        call get_fields(fields, pos = ri)
        vn_norm = vn/norm2(vn)
        pitch = dot_product(fields%b_norm,vn_norm)
    else
        pitch = 0.d0
    endif

    if(pas) then
        !$OMP CRITICAL(store_npa_1)
        pnpa%npart = pnpa%npart + 1
        if(pnpa%npart.gt.pnpa%nmax) then
            pnpa%nmax = int(pnpa%nmax*2)
            allocate(parts(pnpa%nmax))
            parts(1:(pnpa%npart-1)) = pnpa%part
            deallocate(pnpa%part)
            call move_alloc(parts, pnpa%part)
        endif
        pnpa%part(pnpa%npart)%detector = det
        pnpa%part(pnpa%npart)%class = oclass
        pnpa%part(pnpa%npart)%xi = uvw_ri(1)
        pnpa%part(pnpa%npart)%yi = uvw_ri(2)
        pnpa%part(pnpa%npart)%zi = uvw_ri(3)
        pnpa%part(pnpa%npart)%xf = uvw_rf(1)
        pnpa%part(pnpa%npart)%yf = uvw_rf(2)
        pnpa%part(pnpa%npart)%zf = uvw_rf(3)
        pnpa%part(pnpa%npart)%energy = energy
        pnpa%part(pnpa%npart)%pitch = pitch
        pnpa%part(pnpa%npart)%weight = flux
        ienergy = minloc(abs(pnpa%energy - energy))
        pnpa%flux(ienergy(1),det,iclass) = &
            pnpa%flux(ienergy(1),det,iclass) + flux/dE
        !$OMP END CRITICAL(store_npa_1)
    else
        !$OMP CRITICAL(store_npa_2)
        npa%npart = npa%npart + 1
        if(npa%npart.gt.npa%nmax) then
            npa%nmax = int(npa%nmax*2)
            allocate(parts(npa%nmax))
            parts(1:(npa%npart-1)) = npa%part
            deallocate(npa%part)
            call move_alloc(parts, npa%part)
        endif
        npa%part(npa%npart)%detector = det
        npa%part(npa%npart)%class = oclass
        npa%part(npa%npart)%xi = uvw_ri(1)
        npa%part(npa%npart)%yi = uvw_ri(2)
        npa%part(npa%npart)%zi = uvw_ri(3)
        npa%part(npa%npart)%xf = uvw_rf(1)
        npa%part(npa%npart)%yf = uvw_rf(2)
        npa%part(npa%npart)%zf = uvw_rf(3)
        npa%part(npa%npart)%energy = energy
        npa%part(npa%npart)%pitch = pitch
        npa%part(npa%npart)%weight = flux
        ienergy = minloc(abs(npa%energy - energy))
        npa%flux(ienergy(1),det,iclass) = &
            npa%flux(ienergy(1),det,iclass) + flux/dE
        !$OMP END CRITICAL(store_npa_2)
    endif

end subroutine store_npa

!=============================================================================
!--------------------------Atomic Physics Routines----------------------------
!=============================================================================
subroutine bb_cx_rates(denn, vi, vn, rates)
    !+ Get beam-beam neutralization/cx rates
    real(Float64), dimension(nlevs), intent(in)  :: denn
        !+ Neutral density [cm^-3]
    real(Float64), dimension(3),     intent(in)  :: vi
        !+ Ion velocity [cm/s]
    real(Float64), dimension(3),     intent(in)  :: vn
        !+ Neutral velocity [cm/s]
    real(Float64), dimension(nlevs), intent(out) :: rates
        !+ Reaction rates [1/s]

    real(Float64), dimension(nlevs,nlevs) :: neut  !!rate coeff
    real(Float64) :: eb !! relative Energy
    type(InterpolCoeffs1D) :: c
    real(Float64) :: dlogE, logEmin, logeb
    real(Float64) :: vrel !! relative velocity
    integer :: ebi, neb, err

    !Eeff
    vrel=norm2(vi-vn)
    eb=v2_to_E_per_amu*vrel**2  ! [kev/amu]
    logeb = log10(eb)
    logEmin = tables%H_H_cx_cross%logemin
    dlogE = tables%H_H_cx_cross%dlogE
    neb = tables%H_H_cx_cross%nenergy
    call interpol_coeff(logEmin,dlogE,neb,logeb,c,err)
    ebi = c%i
    if(err.eq.1) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "BB_CX_RATES: Eb out of range of H_H_cx table. Using nearest energy value."
            write(*,'("eb = ",ES10.3," [keV]")') eb
        endif
        if(ebi.lt.1) then
            ebi=1
            c%b1=1.0 ; c%b2=0.0
        else
            ebi=neb-1
            c%b1=0.0 ; c%b2=1.0
        endif
    endif

    neut(:,:) = (c%b1*tables%H_H_cx_cross%log_cross(:,:,ebi) + &
                 c%b2*tables%H_H_cx_cross%log_cross(:,:,ebi+1))

    where (neut.lt.tables%H_H_cx_cross%minlog_cross)
        neut = 0.d0
    elsewhere
        neut = exp(neut*log_10)
    end where

    rates=matmul(neut,denn)*vrel

end subroutine bb_cx_rates

subroutine bt_cx_rates(plasma, denn, vi, i_type, rates)
    !+ Get beam-target neutralization/cx rates
    type(LocalProfiles), intent(in)              :: plasma
        !+ Plasma parameters
    real(Float64), dimension(nlevs), intent(in)  :: denn
        !+ Neutral density [cm^-3]
    real(Float64), dimension(3),     intent(in)  :: vi
        !+ Ion velocity [cm/s]
    integer, intent(in)                          :: i_type
        !+ Ion type
    real(Float64), dimension(nlevs), intent(out) :: rates
        !+ Reaction rates [1/s]

    real(Float64) :: logEmin, dlogE, logeb, eb
    real(Float64) :: logTmin, dlogT, logti, vrel
    integer :: neb, nt
    type(InterpolCoeffs2D) :: c
    real(Float64) :: b11, b12, b21, b22, b_amu
    real(Float64), dimension(nlevs,nlevs) :: H_H_rate
    integer :: ebi, tii, n, err_status

    H_H_rate = 0.d0

    if(i_type.eq.beam_ion) then
        b_amu = inputs%ab
    else
        b_amu = inputs%ai
    endif
    vrel=norm2(vi-plasma%vrot)
    eb=b_amu*v2_to_E_per_amu*vrel**2  ! [kev/amu]

    logeb = log10(eb)
    logti = log10(plasma%ti)

    !!H_H
    err_status = 1
    logEmin = tables%H_H_cx_rate%logemin
    logTmin = tables%H_H_cx_rate%logtmin
    dlogE = tables%H_H_cx_rate%dlogE
    dlogT = tables%H_H_cx_rate%dlogT
    neb = tables%H_H_cx_rate%nenergy
    nt = tables%H_H_cx_rate%ntemp
    call interpol_coeff(logEmin, dlogE, neb, logTmin, dlogT, nt, &
                        logeb, logti, c, err_status)
    ebi = c%i
    tii = c%j
    b11 = c%b11
    b12 = c%b12
    b21 = c%b21
    b22 = c%b22
    if(err_status.eq.1) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "BT_CX_RATES: Eb or Ti out of range of H_H_CX table. Setting H_H_CX rates to zero"
            write(*,'("eb = ",ES10.3," [keV]")') eb
            write(*,'("ti = ",ES10.3," [keV]")') plasma%ti
        endif
        rates = 0.0
        return
    endif

    H_H_rate = (b11*tables%H_H_cx_rate%log_rate(:,:,ebi,tii,i_type)   + &
                b12*tables%H_H_cx_rate%log_rate(:,:,ebi,tii+1,i_type) + &
                b21*tables%H_H_cx_rate%log_rate(:,:,ebi+1,tii,i_type) + &
                b22*tables%H_H_cx_rate%log_rate(:,:,ebi+1,tii+1,i_type))

    where (H_H_rate.lt.tables%H_H_cx_rate%minlog_rate)
        H_H_rate = 0.d0
    elsewhere
        H_H_rate = exp(H_H_rate*log_10) !cm^3/s
    end where

    rates=matmul(H_H_rate,denn) !1/s

end subroutine bt_cx_rates

subroutine get_neutron_rate(plasma, eb, rate)
    !+ Gets neutron rate for a beam with energy `eb` interacting with a target plasma
    type(LocalProfiles), intent(in) :: plasma
        !+ Plasma Paramters
    real(Float64), intent(in)       :: eb
        !+ Beam energy [keV]
    real(Float64), intent(out)      :: rate
        !+ Neutron reaction rate [1/s]

    integer :: err_status, neb, nt, ebi, tii
    real(Float64) :: dlogE, dlogT, logEmin, logTmin
    real(Float64) :: logeb, logti, lograte, denp
    type(InterpolCoeffs2D) :: c
    real(Float64) :: b11, b12, b21, b22

    logeb = log10(eb)
    logti = log10(plasma%ti)
    denp = plasma%denp

    !!D_D
    err_status = 1
    logEmin = tables%D_D%logemin
    logTmin = tables%D_D%logtmin
    dlogE = tables%D_D%dlogE
    dlogT = tables%D_D%dlogT
    neb = tables%D_D%nenergy
    nt = tables%D_D%ntemp
    call interpol_coeff(logEmin, dlogE, neb, logTmin, dlogT, nt, &
                        logeb, logti, c, err_status)
    ebi = c%i
    tii = c%j
    b11 = c%b11
    b12 = c%b12
    b21 = c%b21
    b22 = c%b22
    if(err_status.eq.1) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "GET_NEUTRON_RATE: Eb or Ti out of range of D_D table. Setting D_D rates to zero"
            write(*,'("eb = ",ES10.3," [keV]")') eb
            write(*,'("ti = ",ES10.3," [keV]")') plasma%ti
        endif
        denp = 0.d0
    endif

    lograte = (b11*tables%D_D%log_rate(ebi,tii,2)   + &
               b12*tables%D_D%log_rate(ebi,tii+1,2) + &
               b21*tables%D_D%log_rate(ebi+1,tii,2) + &
               b22*tables%D_D%log_rate(ebi+1,tii+1,2))

    if (lograte.lt.tables%D_D%minlog_rate) then
        rate = 0.d0
    else
        rate = denp * exp(lograte*log_10)
    endif

end subroutine get_neutron_rate

subroutine get_beam_cx_rate(ind, pos, v_ion, i_type, types, rate_tot)
    !+ Get probability of a thermal ion charge exchanging with `types` neutrals
    integer(Int32), dimension(3), intent(in)     :: ind
        !+ [[libfida:beam_grid]] indices
    real(Float64), dimension(3), intent(in)      :: pos
        !+ Interaction position in beam grid coordinates
    real(Float64), dimension(3), intent(in)      :: v_ion
        !+ Ion velocity [cm/s]
    integer, intent(in)                          :: i_type
        !+ Ion type
    integer(Int32), dimension(:), intent(in)     :: types
        !+ Neutral types
    real(Float64), dimension(nlevs), intent(out) :: rate_tot
        !+ Total charge exchange rate [1/s]

    integer :: n, i, j, k, ii
    type(LocalProfiles) :: plasma
    real(Float64), dimension(nlevs) :: rates, denn
    real(Float64), dimension(3) :: vhalo,vn,vnbi

    vnbi = pos - nbi%src
    vnbi = nbi%vinj*vnbi/norm2(vnbi)

    n = size(types)
    rate_tot = 0

    i = ind(1) ; j = ind(2) ; k = ind(3)
    do ii=1,n
        select case (types(ii))
            case (nbif_type)
                vn = vnbi
                call bb_cx_rates(neut%full(:,i,j,k),v_ion,vn,rates)
            case (nbih_type)
                vn = vnbi/sqrt(2.0)
                call bb_cx_rates(neut%half(:,i,j,k),v_ion,vn,rates)
            case (nbit_type)
                vn = vnbi/sqrt(3.0)
                call bb_cx_rates(neut%third(:,i,j,k),v_ion,vn,rates)
            case (dcx_type)
                call get_plasma(plasma, pos=pos)
                call bt_cx_rates(plasma,neut%dcx(:,i,j,k),v_ion,i_type,rates)
            case (halo_type)
                call get_plasma(plasma, pos=pos)
                call bt_cx_rates(plasma,neut%halo(:,i,j,k),v_ion,i_type,rates)
        end select
        rate_tot = rate_tot + rates
    enddo

end subroutine get_beam_cx_rate

subroutine get_rate_matrix(plasma, i_type, eb, rmat)
    !+ Gets rate matrix for use in [[libfida:colrad]]
    type(LocalProfiles), intent(in)                    :: plasma
        !+ Plasma parameters
    integer, intent(in)                                :: i_type
        !+ Ion type
    real(Float64), intent(in)                          :: eb
        !+ Ion energy [keV]
    real(Float64), dimension(nlevs,nlevs), intent(out) :: rmat
        !+ Rate matrix

    real(Float64) :: logEmin, dlogE, logeb
    real(Float64) :: logTmin, dlogT, logti, logte
    integer :: neb, nt
    type(InterpolCoeffs2D) :: c
    real(Float64) :: b11, b12, b21, b22, dene, denp, denimp
    real(Float64), dimension(nlevs,nlevs) :: H_H_pop, H_e_pop, H_Aq_pop
    real(Float64), dimension(nlevs) :: H_H_depop, H_e_depop, H_Aq_depop
    integer :: ebi, tii, tei, n, err_status

    H_H_pop = 0.d0
    H_e_pop = 0.d0
    H_Aq_pop = 0.d0
    H_H_depop = 0.d0
    H_e_depop = 0.d0
    H_Aq_depop = 0.d0
    denp = plasma%denp
    dene = plasma%dene
    denimp = plasma%denimp
    logeb = log10(eb)
    logti = log10(plasma%ti)
    logte = log10(plasma%te)
    !!H_H
    err_status = 1
    logEmin = tables%H_H%logemin
    logTmin = tables%H_H%logtmin
    dlogE = tables%H_H%dlogE
    dlogT = tables%H_H%dlogT
    neb = tables%H_H%nenergy
    nt = tables%H_H%ntemp
    call interpol_coeff(logEmin, dlogE, neb, logTmin, dlogT, nt, &
                        logeb, logti, c, err_status)
    ebi = c%i
    tii = c%j
    b11 = c%b11
    b12 = c%b12
    b21 = c%b21
    b22 = c%b22
    if(err_status.eq.1) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "GET_RATE_MATRIX: Eb or Ti out of range of H_H table. Setting H_H rates to zero"
            write(*,'("eb = ",ES10.3," [keV]")') eb
            write(*,'("ti = ",ES10.3," [keV]")') plasma%ti
        endif
    else
        H_H_pop = (b11*tables%H_H%log_pop(:,:,ebi,tii,i_type)   + &
                   b12*tables%H_H%log_pop(:,:,ebi,tii+1,i_type) + &
                   b21*tables%H_H%log_pop(:,:,ebi+1,tii,i_type) + &
                   b22*tables%H_H%log_pop(:,:,ebi+1,tii+1,i_type))
        where (H_H_pop.lt.tables%H_H%minlog_pop)
            H_H_pop = 0.d0
        elsewhere
            H_H_pop = denp * exp(H_H_pop*log_10)
        end where

        H_H_depop = (b11*tables%H_H%log_depop(:,ebi,tii,i_type)   + &
                     b12*tables%H_H%log_depop(:,ebi,tii+1,i_type) + &
                     b21*tables%H_H%log_depop(:,ebi+1,tii,i_type) + &
                     b22*tables%H_H%log_depop(:,ebi+1,tii+1,i_type))
        where (H_H_depop.lt.tables%H_H%minlog_depop)
            H_H_depop = 0.d0
        elsewhere
            H_H_depop = denp * exp(H_H_depop*log_10)
        end where
    endif

    !!H_e
    err_status = 1
    logEmin = tables%H_e%logemin
    logTmin = tables%H_e%logtmin
    dlogE = tables%H_e%dlogE
    dlogT = tables%H_e%dlogT
    neb = tables%H_e%nenergy
    nt = tables%H_e%ntemp
    call interpol_coeff(logEmin, dlogE, neb, logTmin, dlogT, nt, &
                        logeb, logte, c, err_status)
    ebi = c%i
    tei = c%j
    b11 = c%b11
    b12 = c%b12
    b21 = c%b21
    b22 = c%b22
    if(err_status.eq.1) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "GET_RATE_MATRIX: Eb or Te out of range of H_e table. Setting H_e rates to zero"
            write(*,'("eb = ",ES10.3," [keV]")') eb
            write(*,'("te = ",ES10.3," [keV]")') plasma%te
        endif
    else
        H_e_pop = (b11*tables%H_e%log_pop(:,:,ebi,tei,i_type)   + &
                   b12*tables%H_e%log_pop(:,:,ebi,tei+1,i_type) + &
                   b21*tables%H_e%log_pop(:,:,ebi+1,tei,i_type) + &
                   b22*tables%H_e%log_pop(:,:,ebi+1,tei+1,i_type))
        where (H_e_pop.lt.tables%H_e%minlog_pop)
            H_e_pop = 0.d0
        elsewhere
            H_e_pop = dene * exp(H_e_pop*log_10)
        end where

        H_e_depop = (b11*tables%H_e%log_depop(:,ebi,tei,i_type)   + &
                     b12*tables%H_e%log_depop(:,ebi,tei+1,i_type) + &
                     b21*tables%H_e%log_depop(:,ebi+1,tei,i_type) + &
                     b22*tables%H_e%log_depop(:,ebi+1,tei+1,i_type))

        where (H_e_depop.lt.tables%H_e%minlog_depop)
            H_e_depop = 0.d0
        elsewhere
            H_e_depop = dene * exp(H_e_depop*log_10)
        end where
    endif

    !!H_Aq
    err_status = 1
    logEmin = tables%H_Aq%logemin
    logTmin = tables%H_Aq%logtmin
    dlogE = tables%H_Aq%dlogE
    dlogT = tables%H_Aq%dlogT
    neb = tables%H_Aq%nenergy
    nt = tables%H_Aq%ntemp
    call interpol_coeff(logEmin, dlogE, neb, logTmin, dlogT, nt, &
                        logeb, logti, c, err_status)
    ebi = c%i
    tii = c%j
    b11 = c%b11
    b12 = c%b12
    b21 = c%b21
    b22 = c%b22
    if(err_status.eq.1) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "GET_RATE_MATRIX: Eb or Ti out of range of H_Aq table. Setting H_Aq rates to zero"
            write(*,'("eb = ",ES10.3," [keV]")') eb
            write(*,'("ti = ",ES10.3," [keV]")') plasma%ti
        endif
    else
        H_Aq_pop = (b11*tables%H_Aq%log_pop(:,:,ebi,tii,i_type)   + &
                    b12*tables%H_Aq%log_pop(:,:,ebi,tii+1,i_type) + &
                    b21*tables%H_Aq%log_pop(:,:,ebi+1,tii,i_type) + &
                    b22*tables%H_Aq%log_pop(:,:,ebi+1,tii+1,i_type))
        where (H_Aq_pop.lt.tables%H_Aq%minlog_pop)
            H_Aq_pop = 0.d0
        elsewhere
            H_Aq_pop = denimp * exp(H_Aq_pop*log_10)
        end where
        H_Aq_depop = (b11*tables%H_Aq%log_depop(:,ebi,tii,i_type)   + &
                      b12*tables%H_Aq%log_depop(:,ebi,tii+1,i_type) + &
                      b21*tables%H_Aq%log_depop(:,ebi+1,tii,i_type) + &
                      b22*tables%H_Aq%log_depop(:,ebi+1,tii+1,i_type))

        where (H_Aq_depop.lt.tables%H_Aq%minlog_depop)
            H_Aq_depop = 0.d0
        elsewhere
            H_Aq_depop = denimp * exp(H_Aq_depop*log_10)
        end where
    endif

    rmat = tables%einstein + H_H_pop + H_e_pop + H_Aq_pop
    do n=1,nlevs
        rmat(n,n) = -sum(tables%einstein(:,n)) - H_H_depop(n) - H_e_depop(n) - H_Aq_depop(n)
    enddo

end subroutine get_rate_matrix

subroutine colrad(plasma,i_type,vn,dt,states,dens,photons)
    !+ Evolve density of states in time `dt` via collisional radiative model
    type(LocalProfiles), intent(in)              :: plasma
        !+ Plasma parameters
    integer, intent(in)                          :: i_type
        !+ Ion/Neutral type (beam,thermal)
    real(Float64), dimension(:), intent(in)      :: vn
        !+ Neutral velocitiy [cm/s]
    real(Float64), intent(in)                    :: dt
        !+ Time interval [s]
    real(Float64), dimension(:), intent(inout)   :: states
        !+ Density of states
    real(Float64), dimension(nlevs), intent(out) :: dens
        !+ Density of neutrals
    real(Float64), intent(out)                   :: photons
        !+ Emitted photons(3->2)

    real(Float64), dimension(nlevs,nlevs) :: matrix  !! Matrix
    real(Float64) :: b_amu
    real(Float64) :: vnet_square    !! net velocity of neutrals squared
    real(Float64) :: eb             !! Energy of the fast neutral

    real(Float64), dimension(nlevs,nlevs) :: eigvec
    real(Float64), dimension(nlevs) :: eigval, coef
    real(Float64), dimension(nlevs) :: exp_eigval_dt
    real(Float64) :: iflux !!Initial total flux
    integer :: n

    photons=0.d0
    dens=0.d0

    iflux=sum(states)

    if(.not.plasma%in_plasma) then
        dens = states*dt
        return
    endif

    if(i_type.eq.beam_ion) then
        b_amu = inputs%ab
    else
        b_amu = inputs%ai
    endif
    vnet_square=dot_product(vn-plasma%vrot,vn-plasma%vrot)  ![cm/s]
    eb = v2_to_E_per_amu*b_amu*vnet_square ![kev]
    call get_rate_matrix(plasma, i_type, eb, matrix)

    call eigen(nlevs,matrix, eigvec, eigval)
    call linsolve(eigvec,states,coef) !coeffs determined from states at t=0
    exp_eigval_dt = exp(eigval*dt)   ! to improve speed (used twice)
    do n=1,nlevs
        if(eigval(n).eq.0.0) eigval(n)=eigval(n)+1 !protect against dividing by zero
    enddo

    states = matmul(eigvec, coef * exp_eigval_dt)  ![neutrals/cm^3/s]!
    dens   = matmul(eigvec,coef*(exp_eigval_dt-1.d0)/eigval)

    where (states.lt.0)
        states = 0.d0
    endwhere

    where (dens.lt.0)
        dens = 0.d0
    endwhere

    photons=dens(3)*tables%einstein(2,3) !! - [Ph/(s*cm^3)] - !!

end subroutine colrad

subroutine attenuate(ri, rf, vi, states, dstep_in)
    !+ Attenuate `states` along a trajectory
    real(Float64), dimension(3), intent(in)        :: ri
        !+ Initial position in beam grid coordinates
    real(Float64), dimension(3), intent(in)        :: rf
        !+ Final position in beam grid coordinates
    real(Float64), dimension(3), intent(in)        :: vi
        !+ Initial velocity of neutral
    real(Float64), dimension(nlevs), intent(inout) :: states
        !+ Density of states
    real(Float64), intent(in), optional            :: dstep_in
        !+ Step length [cm]

    type(LocalProfiles) :: plasma
    real(Float64) :: photons, vabs, dt, dstep, dis,max_dis
    real(Float64), dimension(3) :: r0
    real(Float64), dimension(nlevs) :: dens
    logical :: inp
    integer :: ncross

    if(present(dstep_in)) then
        dstep=dstep_in
    else
        dstep = sqrt(inter_grid%da) !cm
    endif

    max_dis = norm2(rf-ri)

    vabs = norm2(vi)
    dt = dstep/vabs

    call get_plasma(plasma,pos=ri)
    r0 = ri
    dis = 0.d0
    ncross = 0
    inp = plasma%in_plasma
    do while (dis.le.max_dis)
        call colrad(plasma,beam_ion,vi,dt,states,dens,photons)
        r0 = r0 + vi*dt
        dis = dis + dstep
        call get_plasma(plasma,pos=r0)
        if(inp.neqv.plasma%in_plasma) then
            ncross = ncross + 1
            inp = plasma%in_plasma
        endif
    enddo

    if(ncross.gt.1) states = 0.0

end subroutine attenuate

subroutine doppler_stark(vecp, vi, fields, lambda)
    !+ Calculates doppler shift and stark split wavelengths
    real(Float64), dimension(3), intent(in)        :: vecp
        !+ Vector directing towards optical head
    real(Float64), dimension(3), intent(in)        :: vi
        !+ Particle velocity
    type(LocalEMFields), intent(in)                :: fields
        !+ Electro-magnetic fields
    real(Float64), dimension(n_stark), intent(out) :: lambda
        !+ Wavelengths [nm]

    real(Float64), dimension(3) :: vp, vn
    real(Float64), dimension(3) :: bfield, efield
    real(Float64) :: E, lambda_shifted

    !! vector directing towards the optical head
    vp=vecp/norm2(vecp)

    !! Calculate Doppler shift
    vn=vi*0.01d0 ! [m/s]
    lambda_shifted = lambda0*(1.d0 + dot_product(vn,vp)/c0)

    !! Calculate Stark Splitting
    !! Calculate E-field
    bfield = fields%b_norm*fields%b_abs
    efield = fields%e_norm*fields%e_abs
    efield(1) = efield(1) +  vn(2)*bfield(3) - vn(3)*bfield(2)
    efield(2) = efield(2) - (vn(1)*bfield(3) - vn(3)*bfield(1))
    efield(3) = efield(3) +  vn(1)*bfield(2) - vn(2)*bfield(1)
    E = norm2(efield)

    !! Stark Splitting
    lambda =  lambda_shifted + E * stark_wavel ![nm]
end

subroutine spectrum(vecp, vi, fields, sigma_pi, photons, dlength, lambda, intensity)
    !+ Calculates doppler shift, stark splitting, and intensities
    real(Float64), dimension(3), intent(in)        :: vecp
        !+ Vector directing towards optical head
    real(Float64), dimension(3), intent(in)        :: vi
        !+ Particle velocity
    type(LocalEMFields), intent(in)                :: fields
        !+ Electro-magnetic fields
    real(Float64), intent(in)                      :: sigma_pi
        !+ Sigma-pi ratio
    real(Float64), intent(in)                      :: photons
        !+ Photon density from [[libfida:colrad]]
    real(Float64), intent(in)                      :: dlength
        !+ LOS intersection length with [[libfida:beam_grid]] cell particle is in
    real(Float64), dimension(n_stark), intent(out) :: lambda
        !+ Wavelengths [nm]
    real(Float64), dimension(n_stark), intent(out) :: intensity
        !+ Spectra intensities [Ph/(s cm^2 starkline)]

    real(Float64), dimension(3) :: vp, vn
    real(Float64), dimension(3) :: bfield, efield
    real(Float64) :: E, cos_los_Efield, lambda_shifted
    integer, parameter, dimension(n_stark) :: stark_sign= +1*stark_sigma -1*stark_pi

    !! vector directing towards the optical head
    vp=vecp/norm2(vecp)

    ! Calculate Doppler shift
    vn=vi*0.01d0 ! [m/s]
    lambda_shifted = lambda0*(1.d0 + dot_product(vn,vp)/c0)

    !! Calculate Stark Splitting
    ! Calculate E-field
    bfield = fields%b_norm*fields%b_abs
    efield = fields%e_norm*fields%e_abs
    efield(1) = efield(1) +  vn(2)*bfield(3) - vn(3)*bfield(2)
    efield(2) = efield(2) - (vn(1)*bfield(3) - vn(3)*bfield(1))
    efield(3) = efield(3) +  vn(1)*bfield(2) - vn(2)*bfield(1)
    E = norm2(efield)

    !Stark Splitting
    lambda =  lambda_shifted + E * stark_wavel ![nm]

    !Intensities of stark components
    if (E .eq. 0.d0) then
        cos_los_Efield = 0.d0
    else
        cos_los_Efield = dot_product(vp,efield) / E
    endif

    intensity = stark_intens*(1.d0+ stark_sign* cos_los_Efield**2)
    !! E.g. mirrors may change the pi to sigma intensity ratio
    where (stark_sigma .eq. 1)
        intensity = intensity * sigma_pi
    endwhere

    !! normalize and multiply with photon density from colrad
    intensity = intensity/sum(intensity)*photons*dlength

endsubroutine spectrum

subroutine store_photons(pos, vi, photons, spectra, passive)
    !+ Store photons in `spectra`
    real(Float64), dimension(3), intent(in)      :: pos
        !+ Position of neutral
    real(Float64), dimension(3), intent(in)      :: vi
        !+ Velocitiy of neutral [cm/s]
    real(Float64), intent(in)                    :: photons
        !+ Photons from [[libfida:colrad]] [Ph/(s*cm^3)]
    real(Float64), dimension(:,:), intent(inout) :: spectra
    logical, intent(in), optional                :: passive
        !+ Indicates whether photon is passive FIDA

    real(Float64), dimension(n_stark) :: lambda, intensity
    real(Float64) :: dlength, sigma_pi
    type(LocalEMFields) :: fields
    integer(Int32), dimension(3) :: ind
    real(Float64), dimension(3) :: pos_xyz, lens_xyz, cyl, vp
    type(LOSInters) :: inter
    integer :: ichan,i,j,bin,nchan
    logical :: pas = .False.

    if(present(passive)) pas = passive

    if(pas) then
        cyl(1) = sqrt(pos(1)*pos(1) + pos(2)*pos(2))
        cyl(2) = pos(3)
        cyl(3) = atan2(pos(2), pos(1))
        call get_passive_grid_indices(cyl,ind)
        inter = spec_chords%cyl_inter(ind(1),ind(2),ind(3))
        call uvw_to_xyz(pos, pos_xyz)
    else
        call get_indices(pos,ind)
        inter = spec_chords%inter(ind(1),ind(2),ind(3))
        pos_xyz = pos
    endif

    nchan = inter%nchan
    if(nchan.eq.0) return

    call get_fields(fields,pos=pos_xyz)

    loop_over_channels: do j=1,nchan
        ichan = inter%los_elem(j)%id
        dlength = inter%los_elem(j)%length
        sigma_pi = spec_chords%los(ichan)%sigma_pi
        if(pas) then
            call uvw_to_xyz(spec_chords%los(ichan)%lens_uvw,lens_xyz)
        else
            lens_xyz = spec_chords%los(ichan)%lens
        endif
        vp = pos_xyz - lens_xyz
        call spectrum(vp,vi,fields,sigma_pi,photons, &
                      dlength,lambda,intensity)

        loop_over_stark: do i=1,n_stark
            bin=floor((lambda(i)-inputs%lambdamin)/inputs%dlambda) + 1
            if (bin.lt.1) cycle loop_over_stark
            if (bin.gt.inputs%nlambda) cycle loop_over_stark
            !$OMP ATOMIC UPDATE
            spectra(bin,ichan) = spectra(bin,ichan) + intensity(i)
            !$OMP END ATOMIC
        enddo loop_over_stark
    enddo loop_over_channels

end subroutine store_photons

subroutine store_bes_photons(pos, vi, photons, neut_type)
    !+ Store BES photons in [[libfida:spectra]]
    real(Float64), dimension(3), intent(in) :: pos
        !+ Position of neutral in beam grid coordinates
    real(Float64), dimension(3), intent(in) :: vi
        !+ Velocitiy of neutral [cm/s]
    real(Float64), intent(in)               :: photons
        !+ Photons from [[libfida:colrad]] [Ph/(s*cm^3)]
    integer,intent(in)                      :: neut_type
        !+ Neutral type (full,half,third,halo)

    select case (neut_type)
           case (nbif_type)
               call store_photons(pos,vi,photons,spec%full)
           case (nbih_type)
               call store_photons(pos,vi,photons,spec%half)
           case (nbit_type)
               call store_photons(pos,vi,photons,spec%third)
           case (dcx_type)
               call store_photons(pos,vi,photons,spec%dcx)
           case (halo_type)
               call store_photons(pos,vi,photons,spec%halo)
           case default
               if(inputs%verbose.ge.0) then
                   write(*,'("STORE_BES_PHOTONS: Unknown neutral type: ",i2)') neut_type
               endif
               stop
    end select

end subroutine store_bes_photons

subroutine store_fida_photons(pos, vi, photons, orbit_class, passive)
    !+ Store fida photons in [[libfida:spectra]]
    real(Float64), dimension(3), intent(in) :: pos
        !+ Position of neutral in beam grid coordinates
    real(Float64), dimension(3), intent(in) :: vi
        !+ Velocitiy of neutral [cm/s]
    real(Float64), intent(in)               :: photons
        !+ Photons from [[libfida:colrad]] [Ph/(s*cm^3)]
    integer, intent(in), optional           :: orbit_class
        !+ Orbit class ID
    logical, intent(in), optional           :: passive
        !+ Indicates whether photon is passive FIDA

    integer :: iclass = 1
    logical :: pas = .False.

    if(present(orbit_class)) then
        iclass = min(orbit_class,particles%nclass)
    endif

    if(present(passive)) pas = passive

    if(pas) then
        call store_photons(pos, vi, photons, spec%pfida(:,:,iclass), passive=.True.)
    else
        call store_photons(pos, vi, photons, spec%fida(:,:,iclass))
    endif

end subroutine store_fida_photons

subroutine store_neutrons(rate, orbit_class)
    !+ Store neutron rate in [[libfida:neutron]]
    real(Float64), intent(in)     :: rate
        !+ Neutron rate [neutrons/sec]
    integer, intent(in), optional :: orbit_class
        !+ Orbit class ID

    integer :: iclass

    if(present(orbit_class)) then
        iclass = min(orbit_class,particles%nclass)
    else
        iclass = 1
    endif

    !$OMP ATOMIC UPDATE
    neutron%rate(iclass)= neutron%rate(iclass) + rate
    !$OMP END ATOMIC

end subroutine store_neutrons

subroutine store_fw_photons_at_chan(ichan,eind,pind,vp,vi,fields,dlength,sigma_pi,denf,photons)
    !+ Store FIDA weight photons in [[libfida:fweight]] for a specific channel
    integer, intent(in)                     :: ichan
        !+ Channel index
    integer, intent(in)                     :: eind
        !+ Energy index
    integer, intent(in)                     :: pind
        !+ Pitch index
    real(Float64), dimension(3), intent(in) :: vp
        !+ Vector pointing toward optical head
    real(Float64), dimension(3), intent(in) :: vi
        !+ Velocity of neutral [cm/s]
    type(LocalEMFields), intent(in)         :: fields
        !+ Electro-magnetic fields
    real(Float64), intent(in)               :: dlength
        !+ LOS intersection length with [[libfida:beam_grid]] cell particle is in
    real(Float64), intent(in)               :: sigma_pi
        !+ Sigma-pi ratio for channel
    real(Float64), intent(in)               :: denf
        !+ Fast-ion density [cm^-3]
    real(Float64), intent(in)               :: photons
        !+ Photons from [[libfida:colrad]] [Ph/(s*cm^3)]

    real(Float64), dimension(n_stark) :: lambda,intensity
    real(Float64) :: dlambda,intens_fac
    integer :: i,bin


    dlambda=(inputs%lambdamax_wght-inputs%lambdamin_wght)/inputs%nlambda_wght
    intens_fac = (1.d0)/(4.d0*pi*dlambda)
    call spectrum(vp,vi,fields,sigma_pi,photons, &
                  dlength,lambda,intensity)

    !$OMP CRITICAL(fida_wght)
    loop_over_stark: do i=1,n_stark
        bin=floor((lambda(i) - inputs%lambdamin_wght)/dlambda) + 1
        if (bin.lt.1)                   cycle loop_over_stark
        if (bin.gt.inputs%nlambda_wght) cycle loop_over_stark
        !fida(bin,ichan)= fida(bin,ichan) + &
        !  (denf*intens_fac*1.d4)*intensity(i) !ph/(s*nm*sr*m^2)
        fweight%weight(bin,eind,pind,ichan) = &
          fweight%weight(bin,eind,pind,ichan) + intensity(i)*intens_fac !(ph*cm)/(s*nm*sr*fast-ion*dE*dp)
    enddo loop_over_stark
    if(denf.gt.0.d0) then
        fweight%mean_f(eind,pind,ichan) = fweight%mean_f(eind,pind,ichan) + &
                                          (denf*intens_fac)*sum(intensity)
    endif
    !$OMP END CRITICAL(fida_wght)

end subroutine store_fw_photons_at_chan

subroutine store_fw_photons(eind, pind, pos, vi, denf, photons)
    !+ Store FIDA weight photons in [[libfida:fweight]]
    integer, intent(in)                     :: eind
        !+ Energy index
    integer, intent(in)                     :: pind
        !+ Pitch index
    real(Float64), dimension(3), intent(in) :: pos
        !+ Position of neutral
    real(Float64), dimension(3), intent(in) :: vi
        !+ Velocity of neutral [cm/s]
    real(Float64), intent(in)               :: denf
        !+ Fast-ion density [cm^-3]
    real(Float64), intent(in)               :: photons
        !+ Photons from [[libfida:colrad]] [Ph/(s*cm^3)]

    real(Float64) :: dlength, sigma_pi
    type(LocalEMFields) :: fields
    integer(Int32), dimension(3) :: ind
    real(Float64), dimension(3) :: vp
    type(LOSInters) :: inter
    integer :: ichan,nchan,i

    call get_indices(pos,ind)
    inter = spec_chords%inter(ind(1),ind(2),ind(3))
    nchan = inter%nchan
    if(nchan.eq.0) return

    call get_fields(fields,pos=pos)

    loop_over_channels: do i=1,nchan
        ichan = inter%los_elem(i)%id
        dlength = inter%los_elem(i)%length
        sigma_pi = spec_chords%los(ichan)%sigma_pi
        vp = pos - spec_chords%los(ichan)%lens
        call store_fw_photons_at_chan(ichan, eind, pind, &
             vp, vi, fields, dlength, sigma_pi, denf, photons)
    enddo loop_over_channels

end subroutine store_fw_photons

!=============================================================================
!---------------------------Monte Carlo Routines------------------------------
!=============================================================================
subroutine get_nlaunch(nr_markers,papprox, nlaunch)
    !+ Sets the number of MC markers launched from each [[libfida:beam_grid]] cell
    integer(Int64), intent(in)                    :: nr_markers
        !+ Approximate total number of markers to launch
    real(Float64), dimension(:,:,:), target, intent(in)   :: papprox
        !+ [[libfida:beam_grid]] cell weights
    integer(Int32), dimension(:,:,:), intent(out) :: nlaunch
        !+ Number of mc markers to launch for each cell: nlaunch(x,y,z)

    logical, dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: mask
    real(Float64), dimension(beam_grid%ngrid) :: cdf
    integer  :: c, i, j, k, nc, nm, ind(3)
    integer  :: nmin = 5
    integer, dimension(1) :: randomi
    type(rng_type) :: r
    real(Float64), pointer :: papprox_ptr(:)

    !! Fill in minimum number of markers per cell
    nlaunch = 0
    mask = papprox.gt.0.0
    where(mask)
        nlaunch = nmin
    endwhere

    !! If there are any left over distribute according to papprox
    nc = count(mask)
    if(nr_markers.gt.(nmin*nc)) then
        nm = nr_markers - nmin*nc

        !! precalculate cdf to save time
        call c_f_pointer(c_loc(papprox), papprox_ptr, [beam_grid%ngrid])
        call cumsum(papprox_ptr, cdf)

        !! use the same seed for all processes
        call rng_init(r, 932117)
        do c=1, nm
            call randind_cdf(r, cdf, randomi)
            call ind2sub(beam_grid%dims, randomi(1), ind)
            i = ind(1) ; j = ind(2) ; k = ind(3)
            nlaunch(i,j,k) = nlaunch(i,j,k) + 1
        enddo
    endif

end subroutine get_nlaunch

subroutine get_nlaunch_pass_grid(nr_markers,papprox, nlaunch)
    !+ Sets the number of MC markers launched from each [[libfida:pass_grid]] cell
    integer(Int64), intent(in)                    :: nr_markers
        !+ Approximate total number of markers to launch
    real(Float64), dimension(:,:,:), intent(in)   :: papprox
        !+ [[libfida:pass_grid]] cell weights
    integer(Int32), dimension(:,:,:), intent(out) :: nlaunch
        !+ Number of mc markers to launch for each cell: nlaunch(r,z,phi)

    logical, dimension(pass_grid%nr,pass_grid%nz,pass_grid%nphi) :: mask
    real(Float64), dimension(pass_grid%ngrid) :: cdf
    integer, dimension(1) :: randomi
    type(rng_type) :: r
    integer :: c, i, j, k, nc, nm, ind(3)
    integer :: nmin = 5

    !! Fill in minimum number of markers per cell
    nlaunch = 0
    mask = papprox.gt.0.0
    where(mask)
        nlaunch = nmin
    endwhere

    !! If there are any left over distribute according to papprox
    nc = count(mask)
    if(nr_markers.gt.(nmin*nc)) then
        nm = nr_markers - nmin*nc

        !! precalculate cdf to save time
        call cumsum(reshape(papprox,[pass_grid%ngrid]), cdf)
        !! use the same seed for all processes
        call rng_init(r, 932117)
        do c=1, nm
            call randind_cdf(r, cdf, randomi)
            call ind2sub(pass_grid%dims, randomi(1), ind)
            i = ind(1) ; j = ind(2) ; k = ind(3)
            nlaunch(i,j,k) = nlaunch(i,j,k) + 1
        enddo
    endif

end subroutine get_nlaunch_pass_grid

subroutine pitch_to_vec(pitch, gyroangle, fields, vi_norm)
    !+ Calculates velocity vector from pitch, gyroangle and fields
    real(Float64), intent(in)                :: pitch
        !+ Pitch
    real(Float64), intent(in)                :: gyroangle
        !+ Gyroangle [radians]
    type(LocalEMFields), intent(in)          :: fields
        !+ Electromagnetic fields
    real(Float64), dimension(3), intent(out) :: vi_norm
        !+ Normalized velocity vector

    real(Float64) :: sinus

    sinus = sqrt(max(1.d0-pitch**2,0.d0))
    vi_norm = (sinus*cos(gyroangle)*fields%a_norm + &
               pitch*fields%b_norm + &
               sinus*sin(gyroangle)*fields%c_norm)

end subroutine pitch_to_vec

subroutine gyro_step(vi, fields, r_gyro)
    !+ Calculates gyro-step
    !+
    !+###References
    !+ Belova, E. V., N. N. Gorelenkov, and C. Z. Cheng. "Self-consistent equilibrium model of low aspect-
    !+ ratio toroidal plasma with energetic beam ions." Physics of Plasmas (1994-present) 10.8 (2003):
    !+ 3240-3251. Appendix A: Last equation
    real(Float64), dimension(3), intent(in)  :: vi
        !+ Ion velocity
    type(LocalEMFields), intent(in)          :: fields
        !+ Electro-magnetic fields
    real(Float64), dimension(3), intent(out) :: r_gyro
        !+ Gyro-step
        !+ Gyro-radius vector from particle position to guiding center

    real(Float64), dimension(3) :: vxB, rg_uvw, uvw, cuvrxb, b_rtz, grad_B, rg_rtz
    real(Float64) :: one_over_omega, phi, R, vpar, term1, term2

    if(inputs%flr.ge.1) then
        uvw = fields%uvw
        R = sqrt(uvw(1)**2 + uvw(2)**2)
        phi = atan2(uvw(2),uvw(1))
        one_over_omega=inputs%ab*mass_u/(fields%b_abs*e0)
        vxB = cross_product(vi,fields%b_norm)
        vpar =  dot_product(vi,fields%b_norm)
        r_gyro = vxB*one_over_omega !points towards gyrocenter, in beam coordinates

        if(inputs%flr.ge.2) then
            !! convert the r_gyro vector to machine coordiantes
            if(fields%coords.eq.0) then
                rg_uvw=  matmul(beam_grid%basis, r_gyro)
            endif
            if(fields%coords.eq.1) then
                rg_uvw = r_gyro
            endif

            b_rtz(1) = fields%br/fields%b_abs
            b_rtz(2) = fields%bt/fields%b_abs
            b_rtz(3) = fields%bz/fields%b_abs
            cuvrxb(1) = (1./R*fields%dbz_dphi-fields%dbt_dz)/fields%b_abs
            cuvrxb(2) = (fields%dbr_dz - fields%dbz_dr)/fields%b_abs
            cuvrxb(3) = (1.0/R*fields%bt + fields%dbt_dr - 1.0/R*fields%dbr_dphi)/fields%b_abs
            term1 = vpar*one_over_omega*dot_product(b_rtz,cuvrxb)
            grad_B(1) = (fields%br*fields%dbr_dr + fields%bt * fields%dbt_dr + fields%bz*fields%dbz_dr)/&
                        fields%b_abs
            grad_B(2) = 1.0/R*(fields%br*fields%dbr_dphi + fields%bt * fields%dbt_dphi + fields%bz*fields%dbz_dphi)/&
                        fields%b_abs
            grad_B(3) = (fields%br*fields%dbr_dz + fields%bt * fields%dbt_dz + fields%bz*fields%dbz_dz)/&
                        fields%b_abs
            !convert rg_uvw vector to cylindrical coordiantes
            rg_rtz(1) = rg_uvw(1)*cos(phi) + rg_uvw(2)*sin(phi)
            rg_rtz(2) = -rg_uvw(1)*sin(phi) + rg_uvw(2)*cos(phi)
            rg_rtz(3) = rg_uvw(3)
            term2 = -1.0 / (2.0 * fields%b_abs)*dot_product(rg_rtz,grad_B)
        else
            term1 = 0.0
            term2 = 0.0
        endif

        r_gyro = r_gyro * (1.0 - term1 - term2)
        if ((1.0 - term1 - term2 .le. 0.0) .or. (1.0 - term1 - term2 .ge. 2.0) ) then
            write(*,*) 'GYRO_STEP: Gyro correction results in negative distances or too large shift: ', &
                          1.0-term1-term2
            stop
        endif
    else
        r_gyro = 0.d0
    endif

end subroutine gyro_step

subroutine gyro_correction(fields, energy, pitch, rp, vp, theta_in)
    !+ Calculates gyro correction for Guiding Center MC distribution calculation
    type(LocalEMFields), intent(in)          :: fields
        !+ Electromagnetic fields at guiding center
    real(Float64), intent(in)                :: energy
        !+ Energy of particle
    real(Float64), intent(in)                :: pitch
        !+ Particle pitch w.r.t the magnetic field
    real(Float64), dimension(3), intent(out) :: rp
        !+ Particle position
    real(Float64), dimension(3), intent(out) :: vp
        !+ Particle velocity
    real(Float64), intent(in), optional      :: theta_in
        !+ Gyro-angle
    real(Float64), dimension(3) :: vi_norm, r_step
    real(Float64), dimension(1) :: randomu
    real(Float64) :: vabs, theta

    vabs  = sqrt(energy/(v2_to_E_per_amu*inputs%ab))

    if(present(theta_in)) then
        theta = theta_in
    else
        !! Sample gyroangle
        call randu(randomu)
        theta = 2*pi*randomu(1)
    endif

    !! Calculate velocity vector
    call pitch_to_vec(pitch, theta, fields, vi_norm)
    vp = vabs*vi_norm

    !! Move to particle location
    call gyro_step(vp, fields, r_step)
    rp = fields%pos - r_step

end subroutine gyro_correction

function gyro_radius(fields, energy, pitch) result (gyro_rad)
    !+ Calculates mean gyro-radius
    type(LocalEMFields), intent(in)          :: fields
        !+ Electromagnetic fields at guiding center
    real(Float64), intent(in)                :: energy
        !+ Energy of particle
    real(Float64), intent(in)                :: pitch
        !+ Particle pitch w.r.t the magnetic field
    real(Float64) :: gyro_rad
        !+ Mean gyro-radius

    real(Float64), dimension(3) :: vi_norm, r_step
    real(Float64) :: vabs, phi
    integer :: i,n

    vabs  = sqrt(energy/(v2_to_E_per_amu*inputs%ab))

    gyro_rad = 0.d0
    n = 6
    do i=1,n
        phi = i*2*pi/n
        call pitch_to_vec(pitch, phi, fields, vi_norm)
        call gyro_step(vabs*vi_norm, fields, r_step)
        gyro_rad = gyro_rad + norm2(r_step)/n
    enddo

end function gyro_radius

subroutine mc_fastion(ind,fields,eb,ptch,denf)
    !+ Samples a Guiding Center Fast-ion distribution function at a given [[libfida:beam_grid]] index
    integer, dimension(3), intent(in) :: ind
        !+ [[libfida:beam_grid]] index
    type(LocalEMFields), intent(out)       :: fields
        !+ Electromagnetic fields at the guiding center
    real(Float64), intent(out)             :: eb
        !+ Energy of the fast ion
    real(Float64), intent(out)             :: ptch
        !+ Pitch of the fast ion
    real(Float64), intent(out)             :: denf
        !+ Fast-ion density at guiding center

    real(Float64), dimension(fbm%nenergy,fbm%npitch) :: fbeam
    real(Float64), dimension(3) :: rg
    real(Float64), dimension(3) :: randomu3
    integer, dimension(2,1) :: ep_ind

    call randu(randomu3)
    rg(1) = beam_grid%xc(ind(1)) + beam_grid%dr(1)*(randomu3(1) - 0.5)
    rg(2) = beam_grid%yc(ind(2)) + beam_grid%dr(2)*(randomu3(2) - 0.5)
    rg(3) = beam_grid%zc(ind(3)) + beam_grid%dr(3)*(randomu3(3) - 0.5)
    denf=0.d0

    call get_fields(fields,pos=rg)
    if(.not.fields%in_plasma) return

    call get_distribution(fbeam,denf,pos=rg, coeffs=fields%b)
    call randind(fbeam,ep_ind)
    call randu(randomu3)
    eb = fbm%energy(ep_ind(1,1)) + fbm%dE*(randomu3(1)-0.5)
    ptch = fbm%pitch(ep_ind(2,1)) + fbm%dp*(randomu3(2)-0.5)

end subroutine mc_fastion

subroutine mc_fastion_pass_grid(ind,fields,eb,ptch,denf,output_coords)
    !+ Samples a Guiding Center Fast-ion distribution function at a given [[libfida:pass_grid]] index
    integer, dimension(3), intent(in)      :: ind
        !+ [[libfida:pass_grid]] index
    type(LocalEMFields), intent(out)       :: fields
        !+ Electromagnetic fields at the guiding center
    real(Float64), intent(out)             :: eb
        !+ Energy of the fast ion
    real(Float64), intent(out)             :: ptch
        !+ Pitch of the fast ion
    real(Float64), intent(out)             :: denf
        !+ Fast-ion density at guiding center
    integer, intent(in), optional          :: output_coords
        !+ Indicates coordinate system of `fields`. Beam grid (0), machine (1) and cylindrical (2)

    real(Float64), dimension(fbm%nenergy,fbm%npitch) :: fbeam
    real(Float64), dimension(3) :: rg, rg_cyl
    real(Float64), dimension(3) :: randomu3
    real(Float64) :: rmin, rmax, zmin, phimin
    integer, dimension(2,1) :: ep_ind
    integer :: ocs

    if(present(output_coords)) then
        ocs = output_coords
    else
        ocs = 0
    endif

    denf=0.d0

    call randu(randomu3)
    rmin = pass_grid%r(ind(1))
    rmax = rmin + pass_grid%dr
    zmin = pass_grid%z(ind(2))
    phimin = pass_grid%phi(ind(3))

    ! Sample uniformally in annulus
    rg_cyl(1) = sqrt(randomu3(1)*(rmax**2 - rmin**2) + rmin**2)
    rg_cyl(2) = zmin + randomu3(2)*pass_grid%dz
    rg_cyl(3) = phimin + randomu3(3)*pass_grid%dphi
    call cyl_to_uvw(rg_cyl, rg)

    call get_fields(fields,pos=rg,input_coords=1,output_coords=ocs)
    if(.not.fields%in_plasma) return

    call get_distribution(fbeam,denf,coeffs=fields%b)
    call randind(fbeam,ep_ind)
    call randu(randomu3)
    eb = fbm%energy(ep_ind(1,1)) + fbm%dE*(randomu3(1)-0.5)
    ptch = fbm%pitch(ep_ind(2,1)) + fbm%dp*(randomu3(2)-0.5)

end subroutine mc_fastion_pass_grid

subroutine mc_halo(ind,vhalo,ri,plasma_in)
    !+ Sample thermal Maxwellian distribution at [[libfida:beam_grid]] indices `ind`
    integer, dimension(3), intent(in)                  :: ind
        !+ [[libfida:beam_grid]] indices
    real(Float64), dimension(3), intent(out)           :: vhalo
        !+ Velocity [cm/s]
    real(Float64), dimension(3), intent(out), optional :: ri
        !+ Position in [[libfida:beam_grid]] cell
    type(LocalProfiles), intent(in), optional          :: plasma_in
        !+ Plasma parameters

    type(LocalProfiles) :: plasma
    real(Float64), dimension(3) :: random3

    if(.not.present(plasma_in)) then
        if(present(ri)) then
            call randu(random3)
            ri(1) = beam_grid%xc(ind(1)) + beam_grid%dr(1)*(random3(1) - 0.5)
            ri(2) = beam_grid%yc(ind(2)) + beam_grid%dr(2)*(random3(2) - 0.5)
            ri(3) = beam_grid%zc(ind(3)) + beam_grid%dr(3)*(random3(3) - 0.5)
            call get_plasma(plasma,pos=ri)
        else
            call get_plasma(plasma,ind=ind)
        endif
    else
        plasma=plasma_in
    endif

    call randn(random3)

    vhalo = plasma%vrot + sqrt(plasma%ti*0.5/(v2_to_E_per_amu*inputs%ai))*random3 !![cm/s]

end subroutine mc_halo

subroutine mc_nbi(vnbi,efrac,rnbi,err)
    !+ Generates a neutral beam particle trajectory
    integer, intent(in)                      :: efrac
        !+ Beam neutral type (1,2,3)
    real(Float64), dimension(3), intent(out) :: vnbi
        !+ Velocity [cm/s]
    real(Float64), dimension(3), intent(out) :: rnbi
        !+ Starting position on [[libfida:beam_grid]]
    logical, intent(out)                     :: err
        !+ Error Code

    real(Float64), dimension(3) :: r_exit
    real(Float64), dimension(3) :: uvw_src    !! Start position on ion source
    real(Float64), dimension(3) :: xyz_src    !! Start position on ion source
    real(Float64), dimension(3) :: uvw_ray    !! NBI velocity in uvw coords
    real(Float64), dimension(3) :: xyz_ray    !! NBI velocity in xyz coords
    real(Float64), dimension(3) :: xyz_ape    !! Aperture plane intersection point
    real(Float64), dimension(2) :: randomu    !! uniform random numbers
    real(Float64), dimension(2) :: randomn    !! normal random numbers
    real(Float64) :: length, sqrt_rho, theta
    integer :: i, j
    logical :: inp, valid_trajectory

    err = .False.
    valid_trajectory = .False.
    rejection_loop: do i=1,1000
        call randu(randomu)
        select case (nbi%shape)
            case (1)
                ! Uniformally sample in rectangle
                xyz_src(1) =  0.d0
                xyz_src(2) =  nbi%widy * 2.d0*(randomu(1)-0.5d0)
                xyz_src(3) =  nbi%widz * 2.d0*(randomu(2)-0.5d0)
            case (2)
                ! Uniformally sample in ellipse
                sqrt_rho = sqrt(randomu(1))
                theta = 2*pi*randomu(2)
                xyz_src(1) = 0.d0
                xyz_src(2) = nbi%widy*sqrt_rho*cos(theta)
                xyz_src(3) = nbi%widz*sqrt_rho*sin(theta)
        end select

        !! Create random velocity vector
        call randn(randomn)
        xyz_ray(1)= 1.d0
        xyz_ray(2)=(-xyz_src(2)/nbi%focy + tan(nbi%divy(efrac)*randomn(1)))
        xyz_ray(3)=(-xyz_src(3)/nbi%focz + tan(nbi%divz(efrac)*randomn(2)))

        aperture_loop: do j=1,nbi%naperture
            xyz_ape = xyz_ray*nbi%adist(j) + xyz_src
            select case (nbi%ashape(j))
                case (1)
                    if ((abs(xyz_ape(2) - nbi%aoffy(j)).gt.nbi%awidy(j)).or.&
                        (abs(xyz_ape(3) - nbi%aoffz(j)).gt.nbi%awidz(j))) then
                        cycle rejection_loop
                    endif
                case (2)
                    if ((((xyz_ape(2) - nbi%aoffy(j))*nbi%awidz(j))**2 + &
                         ((xyz_ape(3) - nbi%aoffz(j))*nbi%awidy(j))**2).gt. &
                         (nbi%awidy(j)*nbi%awidz(j))**2) then
                        cycle rejection_loop
                    endif
            end select
        enddo aperture_loop
        valid_trajectory = .True.

        !! Convert to beam centerline coordinates to beam grid coordinates
        uvw_src = matmul(nbi%basis,xyz_src) + nbi%src
        uvw_ray = matmul(nbi%basis,xyz_ray)
        exit rejection_loop
    enddo rejection_loop

    !Set Default trajectory in case rejection sampling fails
    if(.not.valid_trajectory)then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "MC_NBI: Failed to find trajectory though aperture(s). Using beam centerline."
        endif
        uvw_src = nbi%src
        uvw_ray = nbi%axis
    endif
    vnbi = uvw_ray/norm2(uvw_ray)

    !! Determine start position on beam grid
    call grid_intersect(uvw_src,vnbi,length,rnbi,r_exit)
    if(length.le.0.0)then
        err = .True.
        nbi_outside = nbi_outside + 1
    endif

    !! Check if start position is in the plasma
    call in_plasma(rnbi,inp)
    if(inp)then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') "MC_NBI: A beam neutral has started inside the plasma."
            write(*,'(a)') "Move the beam grid closer to the source to fix"
        endif
        stop
    endif

    !! Determine velocity of neutrals corrected by efrac
    vnbi = vnbi*nbi%vinj/sqrt(real(efrac))
end subroutine mc_nbi

subroutine mc_nbi_cell(ind, neut_type, vnbi, weight)
    !+ Generates a neutral beam velocity vector
    !+ that passes through cell at `ind` with weight `weight`
    integer, dimension(3), intent(in)        :: ind
        !+ Cell index
    integer, intent(in)                      :: neut_type
        !+ Neutral Type (1=Full,2=Half,3=Third)
    real(Float64), dimension(3), intent(out) :: vnbi
        !+ Normalized Velocity
    real(Float64), intent(out)               :: weight
        !+ Weigth/probability of trajectory

    real(Float64), dimension(3) :: rc         !! Center of cell in uvw coords
    real(Float64), dimension(3) :: uvw_rf     !! End position in xyz coords
    real(Float64), dimension(3) :: xyz_rf     !! End position in xyz coords
    real(Float64), dimension(3) :: uvw_src    !! Start position on ion source
    real(Float64), dimension(3) :: xyz_src    !! Start position on ion source
    real(Float64), dimension(3) :: uvw_ray    !! NBI velocity in uvw coords
    real(Float64), dimension(3) :: xyz_ray    !! NBI velocity in xyz coords
    real(Float64), dimension(3) :: xyz_ape    !! Aperture plane intersection point
    real(Float64), dimension(3) :: randomu    !! uniform random numbers
    real(Float64) :: sqrt_rho, theta, vy, vz, theta_y, theta_z, py, pz
    integer :: i, j
    logical :: valid_trajectory

    rc = [beam_grid%xc(ind(1)), beam_grid%yc(ind(2)), beam_grid%zc(ind(3))]
    valid_trajectory = .False.
    rejection_loop: do i=1,1000
        call randu(randomu)
        select case (nbi%shape)
            case (1)
                ! Uniformally sample in rectangle
                xyz_src(1) =  0.d0
                xyz_src(2) =  nbi%widy * 2.d0*(randomu(1)-0.5d0)
                xyz_src(3) =  nbi%widz * 2.d0*(randomu(2)-0.5d0)
            case (2)
                ! Uniformally sample in ellipse
                sqrt_rho = sqrt(randomu(1))
                theta = 2*pi*randomu(2)
                xyz_src(1) = 0.d0
                xyz_src(2) = nbi%widy*sqrt_rho*cos(theta)
                xyz_src(3) = nbi%widz*sqrt_rho*sin(theta)
        end select

        !! Create random position in the cell
        call randu(randomu)
        uvw_rf = rc + (randomu - 0.5)*beam_grid%dr
        xyz_rf = matmul(nbi%inv_basis, uvw_rf - nbi%src)

        xyz_ray = xyz_rf - xyz_src
        xyz_ray = xyz_ray/norm2(xyz_ray)

        aperture_loop: do j=1,nbi%naperture
            xyz_ape = xyz_ray*nbi%adist(j) + xyz_src
            select case (nbi%ashape(j))
                case (1)
                    if ((abs(xyz_ape(2) - nbi%aoffy(j)).gt.nbi%awidy(j)).or.&
                        (abs(xyz_ape(3) - nbi%aoffz(j)).gt.nbi%awidz(j))) then
                        cycle rejection_loop
                    endif
                case (2)
                    if ((((xyz_ape(2) - nbi%aoffy(j))*nbi%awidz(j))**2 + &
                         ((xyz_ape(3) - nbi%aoffz(j))*nbi%awidy(j))**2).gt. &
                         (nbi%awidy(j)*nbi%awidz(j))**2) then
                        cycle rejection_loop
                    endif
            end select
        enddo aperture_loop
        valid_trajectory = .True.

        !! Convert to beam centerline coordinates to beam grid coordinates
        uvw_src = matmul(nbi%basis,xyz_src) + nbi%src
        uvw_ray = matmul(nbi%basis,xyz_ray)
        vnbi = nbi%vinj*uvw_ray/norm2(uvw_ray)/sqrt(real(neut_type))

        exit rejection_loop
    enddo rejection_loop

    !Set Default trajectory in case rejection sampling fails
    if(.not.valid_trajectory)then
        call randu(randomu)
        uvw_rf = rc + (randomu - 0.5)*beam_grid%dr
        uvw_ray = uvw_rf - nbi%src
        vnbi = nbi%vinj*uvw_ray/norm2(uvw_ray)/sqrt(real(neut_type))
    endif

    !! Find probability of trajectory
    vy = xyz_ray(2)/xyz_ray(1)
    vz = xyz_ray(3)/xyz_ray(1)
    theta_y = atan(vy + xyz_src(2)/nbi%focy)
    theta_z = atan(vz + xyz_src(3)/nbi%focz)

    py = (1.0/(1.0 + (vy + xyz_src(2)/nbi%focy)**2)) * &
         exp(-(theta_y**2)/(2*nbi%divy(neut_type)**2)) / &
         sqrt(2*nbi%divy(neut_type)**2)

    pz = (1.0/(1.0 + (vz + xyz_src(3)/nbi%focy)**2)) * &
         exp(-(theta_z**2)/(2*nbi%divz(neut_type)**2)) / &
         sqrt(2*nbi%divz(neut_type)**2)

    weight = py*pz

end subroutine mc_nbi_cell

!=============================================================================
!------------------------Primary Simulation Routines--------------------------
!=============================================================================
subroutine ndmc
    !+ Calculates neutral beam deposition and spectra
    integer :: neut_type !! full half third energy
    real(Float64)  :: nlaunch   !! nr. of markers
    real(Float64)  :: nneutrals !! # NBI particles
    real(Float64), dimension(3) :: vnbi !! velocities(full..)
    real(Float64), dimension(3) :: rnbi !! initial position

    integer(Int64) :: jj, ii, kk, cnt
    integer :: ntrack
    type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks
    type(LocalProfiles) :: plasma
    type(LocalEMFields) :: fields
    real(Float64), dimension(nlevs) :: states, dens
    real(Float64) :: photons, iflux,flux_tot
    integer(Int32), dimension(3) :: ind
    real(Float64), dimension(3) :: ri,ri_gc,r_gyro
    real(Float64), dimension(1) :: randomu
    integer, dimension(1) :: randi
    logical :: err

    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i10)') inputs%n_nbi
        if(inputs%calc_birth.ge.1) then
            write(*,'(T6,"# of birth markers: 3 x",i10)') int(inputs%n_nbi*inputs%n_birth)
        endif
    endif

    !! # of injected neutrals = NBI power/energy_per_particle
    nneutrals=1.d6*nbi%pinj/ (1.d3*nbi%einj*e0 &
         *( nbi%current_fractions(1)      &
         +  nbi%current_fractions(2)/2.d0 &
         +  nbi%current_fractions(3)/3.d0 ) )

    nlaunch=real(inputs%n_nbi)
    !$OMP PARALLEL DO schedule(guided) &
    !$OMP& private(vnbi,rnbi,tracks,ntrack,plasma,fields,randi,flux_tot, &
    !$OMP& states,dens,iflux,photons,neut_type,jj,ii,kk,ind,err,ri,ri_gc,r_gyro)
    loop_over_markers: do ii=istart,inputs%n_nbi,istep
        energy_fractions: do neut_type=1,3
            !! (type = 1: full energy, =2: half energy, =3: third energy
            call mc_nbi(vnbi,neut_type,rnbi,err)
            if(err) cycle energy_fractions

            call track(rnbi,vnbi,tracks,ntrack)
            if(ntrack.eq.0) cycle energy_fractions

            !! Solve collisional radiative model along track
            flux_tot = 0.d0
            states=0.d0
            states(1)=nneutrals*nbi%current_fractions(neut_type)/beam_grid%dv
            loop_along_track: do jj=1,ntrack
                iflux = sum(states)
                ind = tracks(jj)%ind
                call get_plasma(plasma,pos=tracks(jj)%pos)

                call colrad(plasma,beam_ion,vnbi,tracks(jj)%time,states,dens,photons)
                call store_neutrals(ind,neut_type,dens/nlaunch,vnbi)
                tracks(jj)%flux = (iflux - sum(states))/nlaunch
                flux_tot = flux_tot + tracks(jj)%flux*beam_grid%dv

                if(inputs%calc_birth.ge.1) then
                    call store_births(ind,neut_type,tracks(jj)%flux)
                endif

                if((photons.gt.0.d0).and.(inputs%calc_bes.ge.1)) then
                    call store_bes_photons(tracks(jj)%pos,vnbi,photons/nlaunch,neut_type)
                endif
            enddo loop_along_track
            if((inputs%calc_birth.ge.1).and.(flux_tot.gt.0.d0)) then
                !! Sample according to deposited flux along neutral trajectory
                !$OMP CRITICAL(ndmc_birth)
                do kk=1,inputs%n_birth
                    call randind(tracks(1:ntrack)%flux,randi)
                    call randu(randomu)
                    birth%part(birth%cnt)%neut_type = neut_type
                    birth%part(birth%cnt)%energy = nbi%einj/real(neut_type)
                    birth%part(birth%cnt)%weight = flux_tot/inputs%n_birth
                    birth%part(birth%cnt)%ind = tracks(randi(1))%ind
                    birth%part(birth%cnt)%vi = vnbi
                    ri = tracks(randi(1))%pos + vnbi*(tracks(randi(1))%time*(randomu(1)-0.5))
                    birth%part(birth%cnt)%ri = ri

                    call get_fields(fields,pos=ri)
                    birth%part(birth%cnt)%pitch = dot_product(fields%b_norm,vnbi/norm2(vnbi))
                    call gyro_step(vnbi,fields,r_gyro)
                    birth%part(birth%cnt)%ri_gc = ri + r_gyro
                    birth%cnt = birth%cnt + 1
                enddo
                !$OMP END CRITICAL(ndmc_birth)
            endif
        enddo energy_fractions
    enddo loop_over_markers
    !$OMP END PARALLEL DO

#ifdef _MPI
    !! Combine beam neutrals
    call parallel_sum(neut%full)
    call parallel_sum(neut%half)
    call parallel_sum(neut%third)
    call parallel_sum(nbi_outside)
    if(inputs%calc_birth.ge.1) then
        call parallel_sum(birth%dens)
    endif
    !! Combine spectra
    if(inputs%calc_bes.ge.1) then
        call parallel_sum(spec%full)
        call parallel_sum(spec%half)
        call parallel_sum(spec%third)
    endif
#endif

    if(nbi_outside.gt.0)then
        if(inputs%verbose.ge.1) then
            write(*,'(T4,a, f6.2,a)') 'Percent of markers outside the grid: ', &
                                  100.*nbi_outside/(3.*inputs%n_nbi),'%'
        endif
        if(sum(neut%full).eq.0) stop 'Beam does not intersect the grid!'
    endif

end subroutine ndmc

subroutine bremsstrahlung
    !+ Calculates bremsstrahlung
    type(LocalProfiles) :: plasma
    integer :: i, ichan, nc, ic
    real(Float64) :: dlength, dlambda, gaunt, max_length
    real(Float64) :: spot_size, theta, sqrt_rho
    real(Float64), dimension(2) :: randomu
    real(Float64), dimension(3) :: vi, xyz, r0
    real(Float64), dimension(3,3) :: basis
    real(Float64), dimension(:), allocatable :: lambda_arr,brems

    allocate(lambda_arr(inputs%nlambda))
    allocate(brems(inputs%nlambda))

    do i=1,inputs%nlambda
        lambda_arr(i)= 10*((i-0.5)*inputs%dlambda+inputs%lambdamin) ! [A]
    enddo
    dlambda = 10*inputs%dlambda ![A]

    dlength = 0.3 !cm
    !! $OMP PARALLEL DO schedule(guided) private(ichan,xyz,vi,basis,spot_size, &
    !! $OMP& max_length, ic, nc,randomu,sqrt_rho,theta,r0,plasma,gaunt,brems)
    loop_over_channels: do ichan=istart,spec_chords%nchan,istep
        xyz = spec_chords%los(ichan)%lens
        vi = spec_chords%los(ichan)%axis
        vi = vi/norm2(vi)
        spot_size = spec_chords%los(ichan)%spot_size
        call line_basis(xyz,vi,basis)

        if(spot_size.le.0.d0) then
            nc = 1
        else
            nc = 100
        endif

        loop_over_los: do ic=1,nc
            call randu(randomu)
            sqrt_rho = sqrt(randomu(1))
            theta = 2*pi*randomu(2)
            r0(1) = 0.d0
            r0(2) = spot_size*sqrt_rho*cos(theta)
            r0(3) = spot_size*sqrt_rho*sin(theta)
            r0 = matmul(basis,r0) + xyz

            ! Find edge of plasma
            call get_plasma(plasma,pos=r0)
            max_length=0.0
            do while (.not.plasma%in_plasma)
                r0 = r0 + vi*dlength ! move dlength
                call get_plasma(plasma,pos=r0)
                max_length = max_length + dlength
                if(max_length.gt.300) cycle loop_over_los
            enddo

            ! Calculate bremsstrahlung along los
            do while (plasma%in_plasma)
                if(plasma%te.gt.0.0) then
                    gaunt = 5.542-(3.108-log(plasma%te))*(0.6905-0.1323/plasma%zeff)
                    brems = (7.57d-9)*gaunt*((plasma%dene**2)*plasma%zeff/(lambda_arr &
                            *sqrt(plasma%te*1000.0)))*exp(-h_planck*c0/((1.d-10)*lambda_arr*plasma%te*1.d3)) &
                            *dlambda*(4.d0*pi)*1.d-4

                    spec%brems(:,ichan)= spec%brems(:,ichan) + (brems*dlength*1.d-2)/nc
                endif
                ! Take a step
                r0 = r0 + vi*dlength
                call get_plasma(plasma,pos=r0)
            enddo
        enddo loop_over_los
    enddo loop_over_channels
    !! $OMP END PARALLEL DO

#ifdef _MPI
    !! Combine Brems
    call parallel_sum(spec%brems)
#endif

    deallocate(lambda_arr,brems)

end subroutine bremsstrahlung

subroutine dcx
    !+ Calculates Direct Charge Exchange (DCX) neutral density and spectra
    integer :: ic,i,j,k,ncell
    integer(Int64) :: idcx !! counter
    real(Float64), dimension(3) :: ri    !! start position
    real(Float64), dimension(3) :: vihalo
    integer,dimension(3) :: ind
    integer,dimension(3) :: neut_types = [1,2,3]
    !! Determination of the CX probability
    type(LocalProfiles) :: plasma
    real(Float64), dimension(nlevs) :: denn    !!  neutral dens (n=1-4)
    real(Float64), dimension(nlevs) :: rates    !!  CX rates
    !! Collisiional radiative model along track
    real(Float64), dimension(nlevs) :: states  ! Density of n-states
    integer :: ntrack
    type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks  !! Particle tracks
    integer :: jj       !! counter along track
    real(Float64):: tot_denn, photons  !! photon flux
    integer, dimension(beam_grid%ngrid) :: cell_ind
    real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox
    integer(Int32), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: nlaunch
    real(Float64) :: fi_correction

    halo_iter_dens(dcx_type) = 0.d0
    papprox=0.d0
    tot_denn=0.d0
    do ic=1,beam_grid%ngrid
        call ind2sub(beam_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        call get_plasma(plasma,ind=ind)
        if(.not.plasma%in_plasma) cycle
        tot_denn = sum(neut%full(:,i,j,k)) + &
                   sum(neut%half(:,i,j,k)) + &
                   sum(neut%third(:,i,j,k))
        papprox(i,j,k)= tot_denn*(plasma%denp-plasma%denf)
    enddo

    ncell = 0
    do ic=1,beam_grid%ngrid
        call ind2sub(beam_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        if(papprox(i,j,k).gt.0.0) then
            ncell = ncell + 1
            cell_ind(ncell) = ic
        endif
    enddo

    call get_nlaunch(inputs%n_dcx,papprox,nlaunch)

    if(inputs%verbose.ge.1) then
       write(*,'(T6,"# of markers: ",i10)') sum(nlaunch)
    endif
    !$OMP PARALLEL DO schedule(dynamic,1) private(i,j,k,ic,idcx,ind,vihalo, &
    !$OMP& ri,tracks,ntrack,rates,denn,states,jj,photons,plasma,fi_correction)
    loop_over_cells: do ic = istart, ncell, istep
        call ind2sub(beam_grid%dims,cell_ind(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        !! Loop over the markers
        loop_over_dcx: do idcx=1, nlaunch(i,j,k)
            !! Calculate ri,vhalo and track
            call mc_halo(ind,vihalo,ri)
            call track(ri,vihalo,tracks,ntrack)
            if(ntrack.eq.0) cycle loop_over_dcx

            !! Calculate CX probability
            call get_beam_cx_rate(tracks(1)%ind,ri,vihalo,thermal_ion,neut_types,rates)
            if(sum(rates).le.0.) cycle loop_over_dcx

            !! Solve collisional radiative model along track
            call get_plasma(plasma,pos=tracks(1)%pos)

            !! Weight CX rates by ion source density
            states = rates*plasma%denp
            fi_correction = max((plasma%denp - plasma%denf)/plasma%denp,0.d0)

            loop_along_track: do jj=1,ntrack
                call get_plasma(plasma,pos=tracks(jj)%pos)
                if(.not.plasma%in_plasma) exit loop_along_track
                call colrad(plasma,thermal_ion,vihalo,tracks(jj)%time,states,denn,photons)
                call store_neutrals(tracks(jj)%ind,dcx_type,denn/nlaunch(i,j,k),vihalo,plasma%in_plasma)

                if((photons.gt.0.d0).and.(inputs%calc_dcx.ge.1)) then
                    photons = fi_correction*photons !! Correct for including fast-ions in states
                    call store_bes_photons(tracks(jj)%pos,vihalo,photons/nlaunch(i,j,k),dcx_type)
                endif
            enddo loop_along_track
        enddo loop_over_dcx
    enddo loop_over_cells
    !$OMP END PARALLEL DO

#ifdef _MPI
    !! Combine densities
    call parallel_sum(neut%dcx)
    if(inputs%calc_dcx.ge.1) then
        call parallel_sum(spec%dcx)
    endif
    call parallel_sum(halo_iter_dens(dcx_type))
#endif

end subroutine dcx

subroutine halo
    !+ Calculates halo neutral density and spectra
    integer :: ic,i,j,k,ncell
    integer(Int64) :: ihalo !! counter
    real(Float64), dimension(3) :: ri    !! start position
    real(Float64), dimension(3) :: vihalo!! velocity bulk plasma ion
    integer,dimension(3) :: ind,tind    !! actual cell
    !! Determination of the CX probability
    type(LocalProfiles) :: plasma
    real(Float64), dimension(nlevs) :: denn    !!  neutral dens (n=1-4)
    real(Float64), dimension(nlevs) :: rates    !! CX rates
    !! Collisiional radiative model along track
    real(Float64), dimension(nlevs) :: states  ! Density of n-states
    integer :: ntrack
    type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks  !! Particle Tracks
    integer :: jj       !! counter along track
    real(Float64) :: tot_denn, photons  !! photon flux
    integer, dimension(beam_grid%ngrid) :: cell_ind
    real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox
    integer(Int32), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: nlaunch
    real(Float64), dimension(nlevs,beam_grid%nx,beam_grid%ny,beam_grid%nz) :: dens_prev
    real(Float64), dimension(:,:,:,:,:),allocatable :: dens_cur
    real(Float64) :: local_iter_dens
    integer :: n_slices, cur_slice, is
#ifdef _OMP
    integer, external :: omp_get_max_threads, omp_get_thread_num
#endif
    !! Halo iteration
    integer(Int64) :: hh, n_halo !! counters
    real(Float64) :: dcx_dens, halo_iteration_dens,seed_dcx
    integer :: prev_type  ! previous iteration
    integer :: cur_type  ! current iteration
    real(Float64) :: fi_correction


    prev_type = fida_type
    cur_type = brems_type

    cur_slice = 1
    n_slices = 1
#ifdef _OMP
    n_slices = omp_get_max_threads()
#endif

    allocate(dens_cur(nlevs,beam_grid%nx,beam_grid%ny,beam_grid%nz,n_slices))

    dens_prev = 0.d0
    dens_cur = 0.d0
    dcx_dens = halo_iter_dens(dcx_type)
    halo_iter_dens(prev_type) = dcx_dens
    if(dcx_dens.eq.0) then
        if(inputs%verbose.ge.0) then
            write(*,'(a)') 'HALO: Density of DCX-neutrals is zero'
        endif
        stop
    endif
    dens_prev = neut%dcx
    n_halo = inputs%n_halo
    seed_dcx = 1.0
    iterations: do hh=1,200
        papprox=0.d0
        tot_denn=0.d0
        halo_iter_dens(cur_type) = 0.d0
        do ic=1,beam_grid%ngrid
            call ind2sub(beam_grid%dims,ic,ind)
            i = ind(1) ; j = ind(2) ; k = ind(3)
            call get_plasma(plasma,ind=ind)
            if(.not.plasma%in_plasma) cycle
            tot_denn = sum(dens_prev(:,i,j,k))
            papprox(i,j,k)= tot_denn*(plasma%denp-plasma%denf)
        enddo

        cell_ind = 0
        ncell = 0
        do ic=1,beam_grid%ngrid
            call ind2sub(beam_grid%dims,ic,ind)
            i = ind(1) ; j = ind(2) ; k = ind(3)
            if(papprox(i,j,k).gt.0.0) then
                ncell = ncell + 1
                cell_ind(ncell) = ic
            endif
        enddo

        call get_nlaunch(n_halo, papprox, nlaunch)

        if(inputs%verbose.ge.1) then
            write(*,'(T6,"# of markers: ",i10," --- Seed/DCX: ",f5.3)') sum(nlaunch), seed_dcx
        endif

        local_iter_dens = halo_iter_dens(cur_type)
        !$OMP PARALLEL DO schedule(dynamic,1) private(i,j,k,ic,ihalo,ind,vihalo, &
        !$OMP& ri,tracks,ntrack,rates,denn,states,jj,photons,plasma,tind, cur_slice,fi_correction) &
        !$OMP& reduction(+: local_iter_dens )
        loop_over_cells: do ic=istart,ncell,istep
#ifdef _OMP
            cur_slice = omp_get_thread_num()+1
#endif
            call ind2sub(beam_grid%dims,cell_ind(ic),ind)
            i = ind(1) ; j = ind(2) ; k = ind(3)
            !! Loop over the markers
            loop_over_halos: do ihalo=1, nlaunch(i,j,k)
                !! Calculate ri,vhalo and track
                call mc_halo(ind,vihalo,ri)
                call track(ri,vihalo,tracks,ntrack)
                if(ntrack.eq.0)cycle loop_over_halos

                !! Get plasma parameters at particle location
                call get_plasma(plasma, pos=ri)

                !! Calculate CX probability
                tind = tracks(1)%ind
                call bt_cx_rates(plasma, dens_prev(:,tind(1),tind(2),tind(3)), vihalo, thermal_ion, rates)
                if(sum(rates).le.0.)cycle loop_over_halos

                !! Get plasma parameters at mean point in cell
                call get_plasma(plasma,pos=tracks(1)%pos)

                !! Weight CX rates by ion source density
                states = rates*plasma%denp
                fi_correction = max((plasma%denp - plasma%denf)/plasma%denp,0.d0)

                loop_along_track: do jj=1,ntrack
                    call get_plasma(plasma,pos=tracks(jj)%pos)
                    if(.not.plasma%in_plasma) exit loop_along_track
                    call colrad(plasma,thermal_ion,vihalo,tracks(jj)%time,states,denn,photons)

                    !! Store Neutrals
                    tind = tracks(jj)%ind
                    dens_cur(:,tind(1),tind(2),tind(3),cur_slice) = &
                        dens_cur(:,tind(1),tind(2),tind(3),cur_slice) + denn/nlaunch(i,j,k)
                    local_iter_dens = &
                        local_iter_dens + sum(denn)/nlaunch(i,j,k)
                    if((photons.gt.0.d0).and.(inputs%calc_halo.ge.1)) then
                        photons = fi_correction*photons !! Correct for including fast-ions in states
                        call store_bes_photons(tracks(jj)%pos,vihalo,photons/nlaunch(i,j,k),halo_type)
                    endif
                enddo loop_along_track
            enddo loop_over_halos
        enddo loop_over_cells
        !$OMP END PARALLEL DO
        halo_iter_dens(cur_type) = local_iter_dens

#ifdef _OMP
        !$OMP PARALLEL DO private(i,j,is)
        do i=1,beam_grid%nz
         do j=1,beam_grid%ny
          do is = 2, n_slices
            dens_cur(:,:,j,i,1) = dens_cur(:,:,j,i,1) + dens_cur(:,:,j,i,is)
          enddo
         enddo
        enddo
#endif
        ! at this point, dens_cur(*,1) contains all the info

#ifdef _MPI
        !! Combine densities
        call parallel_sum(dens_cur(:,:,:,:,1))
        call parallel_sum(halo_iter_dens(cur_type))
#endif

        if(halo_iter_dens(cur_type)/halo_iter_dens(prev_type).gt.1.0) then
            write(*,'(a)') "HALO: Halo generation density exceeded seed density. This shouldn't happen."
            exit iterations
        endif

        halo_iteration_dens = halo_iter_dens(cur_type)
        halo_iter_dens(prev_type) = halo_iter_dens(cur_type)
        !$OMP PARALLEL DO private(i)
        do i=1,beam_grid%nz
          neut%halo(:,:,:,i) = neut%halo(:,:,:,i) + dens_cur(:,:,:,i,1)
          dens_prev(:,:,:,i) = dens_cur(:,:,:,i,1)
          dens_cur(:,:,:,i,:) = 0.d0
        enddo

        seed_dcx = halo_iteration_dens/dcx_dens
        n_halo=int(inputs%n_halo*seed_dcx,Int64)

        if(seed_dcx.lt.0.01) exit iterations
    enddo iterations
#ifdef _MPI
    !! Combine Spectra
    if(inputs%calc_halo.ge.1) then
        call parallel_sum(spec%halo)
    endif
#endif

    deallocate(dens_cur)

end subroutine halo

subroutine nbi_spec
    !+ Calculates approximate neutral beam emission (full, half, third)
    !+ from user supplied neutrals file
    integer :: ic, i, j, k, it
    real(Float64), dimension(3) :: ri, vnbi, random3, rc
    integer,dimension(3) :: ind
    !! Determination of the CX probability
    real(Float64) :: nbif_photons, nbih_photons, nbit_photons
    real(Float64) :: f_wght, h_wght, t_wght
    real(Float64) :: f_tot, h_tot, t_tot
    real(Float64), dimension(inputs%nlambda,spec_chords%nchan) :: full, half, third
    logical :: inp
    integer :: n = 10000

    !$OMP PARALLEL DO schedule(dynamic,1) private(i,j,k,ic,ind, &
    !$OMP& nbif_photons, nbih_photons, nbit_photons, rc, ri,inp, vnbi,&
    !$OMP& random3,f_tot,h_tot,t_tot,full,half,third,f_wght,h_wght,t_wght)
    loop_over_cells: do ic = istart, spec_chords%ncell, istep
        call ind2sub(beam_grid%dims,spec_chords%cell(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)

        nbif_photons = neut%full(3,i,j,k)*tables%einstein(2,3)
        nbih_photons = neut%half(3,i,j,k)*tables%einstein(2,3)
        nbit_photons = neut%third(3,i,j,k)*tables%einstein(2,3)
        if((nbif_photons + nbih_photons + nbit_photons).le.0.0) then
            cycle loop_over_cells
        endif

        rc = [beam_grid%xc(i), beam_grid%yc(j), beam_grid%zc(k)]

        !Find a point in cell that is also in the plasma
        ri = rc
        call in_plasma(ri, inp)
        do while (.not.inp)
            call randu(random3)
            ri = rc + beam_grid%dr*(random3 - 0.5)
            call in_plasma(ri,inp)
        enddo

        f_tot = 0.0 ; h_tot = 0.0 ; t_tot = 0.0
        full  = 0.0 ; half  = 0.0 ; third = 0.0
        do it=1, n
            !! Full Spectra
            call mc_nbi_cell(ind, nbif_type, vnbi, f_wght)
            f_tot = f_tot + f_wght
            call store_photons(ri, vnbi, f_wght*nbif_photons, full)

            !! Half Spectra
            call mc_nbi_cell(ind, nbih_type, vnbi, h_wght)
            h_tot = h_tot + h_wght
            call store_photons(ri, vnbi, h_wght*nbih_photons, half)

            !! Third Spectra
            call mc_nbi_cell(ind, nbit_type, vnbi, t_wght)
            t_tot = t_tot + t_wght
            call store_photons(ri, vnbi, t_wght*nbit_photons, third)
        enddo
        !$OMP CRITICAL(nbi_spec_1)
        spec%full = spec%full + full/f_tot
        spec%half = spec%half + half/h_tot
        spec%third = spec%third + third/t_tot
        !$OMP END CRITICAL(nbi_spec_1)
    enddo loop_over_cells
    !$OMP END PARALLEL DO

#ifdef _MPI
    !! Combine Spectra
    call parallel_sum(spec%full)
    call parallel_sum(spec%half)
    call parallel_sum(spec%third)
#endif

end subroutine nbi_spec

subroutine dcx_spec
    !+ Calculates DCX emission from user supplied neutrals file
    integer :: ic, i, j, k, it
    real(Float64), dimension(3) :: ri, vhalo, random3, rc
    integer,dimension(3) :: ind
    !! Determination of the CX probability
    type(LocalProfiles) :: plasma
    real(Float64) :: dcx_photons
    logical :: inp
    integer :: n = 10000

    !$OMP PARALLEL DO schedule(dynamic,1) private(i,j,k,ic,ind, &
    !$OMP& dcx_photons, rc, ri, inp, vhalo, random3, plasma)
    loop_over_cells: do ic = istart, spec_chords%ncell, istep
        call ind2sub(beam_grid%dims,spec_chords%cell(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)

        dcx_photons  = neut%dcx(3,i,j,k)*tables%einstein(2,3)
        if(dcx_photons.le.0.0) cycle loop_over_cells

        rc = [beam_grid%xc(i), beam_grid%yc(j), beam_grid%zc(k)]

        !Find a point in cell that is also in the plasma
        ri = rc
        call in_plasma(ri, inp)
        do while (.not.inp)
            call randu(random3)
            ri = rc + beam_grid%dr*(random3 - 0.5)
            call in_plasma(ri,inp)
        enddo

        call get_plasma(plasma, pos=ri)
        do it=1, n
            !! DCX Spectra
            call randn(random3)
            vhalo = plasma%vrot + sqrt(plasma%ti*0.5/(v2_to_E_per_amu*inputs%ai))*random3
            call store_photons(ri, vhalo, dcx_photons/n, spec%dcx)
        enddo
    enddo loop_over_cells
    !$OMP END PARALLEL DO

#ifdef _MPI
    !! Combine Spectra
    call parallel_sum(spec%dcx)
#endif

end subroutine dcx_spec

subroutine halo_spec
    !+ Calculates halo emission from user supplied neutrals file
    integer :: ic, i, j, k, it
    real(Float64), dimension(3) :: ri, vhalo, random3, rc
    integer,dimension(3) :: ind
    !! Determination of the CX probability
    type(LocalProfiles) :: plasma
    real(Float64) :: halo_photons
    logical :: inp
    integer :: n = 10000

    !$OMP PARALLEL DO schedule(dynamic,1) private(i,j,k,ic,ind, &
    !$OMP& halo_photons, rc, ri, inp, vhalo, random3, plasma)
    loop_over_cells: do ic = istart, spec_chords%ncell, istep
        call ind2sub(beam_grid%dims,spec_chords%cell(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)

        halo_photons = neut%halo(3,i,j,k)*tables%einstein(2,3)
        if(halo_photons.le.0.0) cycle loop_over_cells

        rc = [beam_grid%xc(i), beam_grid%yc(j), beam_grid%zc(k)]

        !Find a point in cell that is also in the plasma
        ri = rc
        call in_plasma(ri, inp)
        do while (.not.inp)
            call randu(random3)
            ri = rc + beam_grid%dr*(random3 - 0.5)
            call in_plasma(ri,inp)
        enddo

        call get_plasma(plasma, pos=ri)
        do it=1, n
            !! Halo Spectra
            call randn(random3)
            vhalo = plasma%vrot + sqrt(plasma%ti*0.5/(v2_to_E_per_amu*inputs%ai))*random3
            call store_photons(ri, vhalo, halo_photons/n, spec%halo)
        enddo
    enddo loop_over_cells
    !$OMP END PARALLEL DO

#ifdef _MPI
    !! Combine Spectra
    call parallel_sum(spec%halo)
#endif

end subroutine halo_spec

subroutine cold_spec
    !+ Calculates cold D-alpha emission
    integer :: ic, i, j, k, it, ncell
    real(Float64), dimension(3) :: ri, vhalo, random3
    integer,dimension(3) :: ind
    !! Determination of the CX probability
    type(LocalProfiles) :: plasma
    real(Float64) :: cold_photons
    integer :: n = 10000

    !$OMP PARALLEL DO schedule(dynamic,1) private(i,j,k,ic,ind, &
    !$OMP& cold_photons, ri, vhalo, random3, plasma)
    loop_over_cells: do ic = istart, spec_chords%ncell, istep
        call ind2sub(beam_grid%dims,spec_chords%cell(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        ri = [beam_grid%xc(i), beam_grid%yc(j), beam_grid%zc(k)]

        call get_plasma(plasma, pos=ri)
        cold_photons = plasma%denn(3)*tables%einstein(2,3)
        if(cold_photons.le.0.0) cycle loop_over_cells

        do it=1, n
            !! Cold Spectra
            call randn(random3)
            vhalo = plasma%vrot + sqrt(plasma%ti*0.5/(v2_to_E_per_amu*inputs%ai))*random3
            call store_photons(ri, vhalo, cold_photons/n, spec%cold)
        enddo
    enddo loop_over_cells
    !$OMP END PARALLEL DO

#ifdef _MPI
    !! Combine Spectra
    call parallel_sum(spec%cold)
#endif

end subroutine cold_spec

subroutine fida_f
    !+ Calculate Active FIDA emission using a Fast-ion distribution function F(E,p,r,z)
    integer :: i,j,k,ic,ncell
    integer(Int64) :: iion
    real(Float64), dimension(3) :: ri      !! start position
    real(Float64), dimension(3) :: vi      !! velocity of fast ions
    real(Float64) :: denf !! fast-ion density
    integer, dimension(3) :: ind      !! new actual cell
    integer, dimension(5) :: neut_types=[1,2,3,4,5]
    logical :: los_intersect
    !! Determination of the CX probability
    type(LocalEMFields) :: fields
    type(LocalProfiles) :: plasma
    real(Float64), dimension(nlevs) :: rates !! CX rates

    !! Collisiional radiative model along track
    integer :: ntrack
    integer :: jj      !! counter along track
    type(ParticleTrack),dimension(beam_grid%ntrack) :: tracks

    real(Float64) :: photons !! photon flux
    real(Float64), dimension(nlevs) :: states  !! Density of n-states
    real(Float64), dimension(nlevs) :: denn

    !! Number of particles to launch
    real(Float64) :: eb, ptch
    integer, dimension(beam_grid%ngrid) :: cell_ind
    real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox
    integer(Int32), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: nlaunch

    !! Estimate how many particles to launch in each cell
    papprox=0.d0
    do ic=1,beam_grid%ngrid
        call ind2sub(beam_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        call get_plasma(plasma,ind=ind)
        if(.not.plasma%in_plasma) cycle
        papprox(i,j,k) = (sum(neut%full(:,i,j,k)) + &
                          sum(neut%half(:,i,j,k)) + &
                          sum(neut%third(:,i,j,k)) + &
                          sum(neut%dcx(:,i,j,k)) + &
                          sum(neut%halo(:,i,j,k)))* &
                          plasma%denf
    enddo

    ncell = 0
    do ic=1,beam_grid%ngrid
        call ind2sub(beam_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        if(papprox(i,j,k).gt.0.0) then
            ncell = ncell + 1
            cell_ind(ncell) = ic
        endif
    enddo

    call get_nlaunch(inputs%n_fida, papprox, nlaunch)
    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i10)') sum(nlaunch)
    endif

    !! Loop over all cells that have neutrals
    !$OMP PARALLEL DO schedule(dynamic,1) private(ic,i,j,k,ind,iion,vi,ri,fields, &
    !$OMP tracks,ntrack,jj,plasma,rates,denn,states,photons,denf,eb,ptch,los_intersect)
    loop_over_cells: do ic = istart, ncell, istep
        call ind2sub(beam_grid%dims,cell_ind(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        loop_over_fast_ions: do iion=1, nlaunch(i, j, k)
            !! Sample fast ion distribution for velocity and position
            call mc_fastion(ind, fields, eb, ptch, denf)
            if(denf.le.0.0) cycle loop_over_fast_ions

            !! Correct for gyro motion and get particle position and velocity
            call gyro_correction(fields, eb, ptch, ri, vi)

            !! Find the particles path through the beam grid
            call track(ri, vi, tracks, ntrack,los_intersect)
            if(.not.los_intersect) cycle loop_over_fast_ions
            if(ntrack.eq.0) cycle loop_over_fast_ions

            !! Calculate CX probability with beam and halo neutrals
            call get_beam_cx_rate(tracks(1)%ind, ri, vi, beam_ion, neut_types, rates)
            if(sum(rates).le.0.) cycle loop_over_fast_ions

            !! Weight CX rates by ion source density
            states=rates*denf

            !! Calculate the spectra produced in each cell along the path
            loop_along_track: do jj=1,ntrack
                call get_plasma(plasma,pos=tracks(jj)%pos)

                call colrad(plasma,beam_ion, vi, tracks(jj)%time, states, denn, photons)

                call store_fida_photons(tracks(jj)%pos, vi, photons/nlaunch(i,j,k))
            enddo loop_along_track
        enddo loop_over_fast_ions
    enddo loop_over_cells
    !$OMP END PARALLEL DO

#ifdef _MPI
    call parallel_sum(spec%fida)
#endif

end subroutine fida_f

subroutine pfida_f
    !+ Calculate Passive FIDA emission using a Fast-ion distribution function F(E,p,r,z)
    integer :: i,j,k,ic,ncell
    integer(Int64) :: iion
    real(Float64), dimension(3) :: ri      !! start position
    real(Float64), dimension(3) :: vi      !! velocity of fast ions
    real(Float64), dimension(3) :: xyz_vi
    real(Float64) :: denf !! fast-ion density
    integer, dimension(3) :: ind      !! new actual cell
    logical :: los_intersect
    !! Determination of the CX probability
    type(LocalEMFields) :: fields
    type(LocalProfiles) :: plasma
    real(Float64), dimension(nlevs) :: rates !! CX rates

    !! Collisiional radiative model along track
    integer :: ntrack
    integer :: jj      !! counter along track
    type(ParticleTrack),dimension(pass_grid%ntrack) :: tracks

    real(Float64) :: photons !! photon flux
    real(Float64), dimension(nlevs) :: states  !! Density of n-states
    real(Float64), dimension(nlevs) :: denn

    !! Number of particles to launch
    real(Float64) :: max_papprox, eb, ptch
    integer, dimension(pass_grid%ngrid) :: cell_ind
    real(Float64), dimension(pass_grid%nr,pass_grid%nz,pass_grid%nphi) :: papprox
    integer(Int32), dimension(pass_grid%nr,pass_grid%nz,pass_grid%nphi) :: nlaunch

    !! Estimate how many particles to launch in each cell
    papprox=0.d0
    do ic=1,pass_grid%ngrid
        call ind2sub(pass_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        call get_plasma(plasma,ind=ind,input_coords=2)
        if(.not.plasma%in_plasma) cycle
        papprox(i,j,k) = sum(plasma%denn)*plasma%denf
    enddo
    max_papprox = maxval(papprox)
    where (papprox.lt.(max_papprox*1.d-6))
        papprox = 0.0
    endwhere

    ncell = 0
    do ic=1,pass_grid%ngrid
        call ind2sub(pass_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        if(papprox(i,j,k).gt.0.0) then
            ncell = ncell + 1
            cell_ind(ncell) = ic
        endif
    enddo

    call get_nlaunch_pass_grid(inputs%n_pfida, papprox, nlaunch)
    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i10)') sum(nlaunch)
    endif

    !! Loop over all cells that have neutrals
    !$OMP PARALLEL DO schedule(dynamic,1) private(ic,i,j,k,ind,iion,vi,xyz_vi,ri,fields, &
    !$OMP tracks,ntrack,jj,plasma,rates,denn,states,photons,denf,eb,ptch,los_intersect)
    loop_over_cells: do ic = istart, ncell, istep
        call ind2sub(pass_grid%dims,cell_ind(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        loop_over_fast_ions: do iion=1, nlaunch(i, j, k)
            !! Sample fast ion distribution for velocity and position
            call mc_fastion_pass_grid(ind, fields, eb, ptch, denf, output_coords=1)
            if(denf.le.0.0) cycle loop_over_fast_ions

            !! Correct for gyro motion and get particle position and velocity
            call gyro_correction(fields, eb, ptch, ri, vi)
            xyz_vi = matmul(beam_grid%inv_basis,vi)

            !! Find the particles path through the interpolation grid
            call track_cylindrical(ri, vi, tracks, ntrack,los_intersect)
            if(.not.los_intersect) cycle loop_over_fast_ions
            if(ntrack.eq.0) cycle loop_over_fast_ions

            !! Calculate CX probability with beam and halo neutrals
            call get_plasma(plasma, pos=ri, input_coords=1)
            call bt_cx_rates(plasma, plasma%denn, xyz_vi, beam_ion, rates)
            if(sum(rates).le.0.) cycle loop_over_fast_ions

            !! Weight CX rates by ion source density
            states=rates*denf

            !! Calculate the spectra produced in each cell along the path
            loop_along_track: do jj=1,ntrack
                call get_plasma(plasma,pos=tracks(jj)%pos,input_coords=1)

                call colrad(plasma,beam_ion, xyz_vi, tracks(jj)%time, states, denn, photons)

                call store_fida_photons(tracks(jj)%pos, xyz_vi, photons/nlaunch(i,j,k), passive=.True.)
            enddo loop_along_track
        enddo loop_over_fast_ions
    enddo loop_over_cells
    !$OMP END PARALLEL DO

#ifdef _MPI
    call parallel_sum(spec%pfida)
#endif

end subroutine pfida_f

subroutine fida_mc
    !+ Calculate Active FIDA emission using a Monte Carlo Fast-ion distribution
    integer :: iion,igamma,ngamma
    type(FastIon) :: fast_ion
    type(LocalEMFields) :: fields
    type(LocalProfiles) :: plasma
    real(Float64) :: phi
    real(Float64), dimension(3) :: ri      !! start position
    real(Float64), dimension(3) :: vi      !! velocity of fast ions
    !! Determination of the CX probability
    real(Float64), dimension(nlevs) :: denn    !!  neutral dens (n=1-4)
    real(Float64), dimension(nlevs) :: rates    !! CX rates
    !! Collisiional radiative model along track
    real(Float64), dimension(nlevs) :: states  ! Density of n-states
    integer :: ntrack
    type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks
    logical :: los_intersect
    integer :: jj      !! counter along track
    real(Float64) :: photons !! photon flux
    integer, dimension(5) :: neut_types=[1,2,3,4,5]
    real(Float64), dimension(3) :: uvw, uvw_vi
    real(Float64)  :: s, c
    real(Float64), dimension(1) :: randomu

    ngamma = 1
    if(particles%axisym.or.(inputs%dist_type.eq.2)) then
        ngamma = ceiling(dble(inputs%n_fida)/particles%nparticle)
    endif

    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i10)') int(particles%nparticle*ngamma,Int64)
    endif

    !$OMP PARALLEL DO schedule(dynamic,1) private(iion,igamma,fast_ion,vi,ri,phi,tracks,s,c, &
    !$OMP& randomu,plasma,fields,uvw,uvw_vi,ntrack,jj,rates,denn,los_intersect,states,photons)
    loop_over_fast_ions: do iion=istart,particles%nparticle,istep
        fast_ion = particles%fast_ion(iion)
        if(fast_ion%vabs.eq.0) cycle loop_over_fast_ions
        if(.not.fast_ion%beam_grid_cross_grid) cycle loop_over_fast_ions
        gamma_loop: do igamma=1,ngamma
            if(particles%axisym) then
                !! Pick random toroidal angle
                call randu(randomu)
                phi = fast_ion%beam_grid_phi_enter + fast_ion%delta_phi*randomu(1)
            else
                phi = fast_ion%phi
            endif
            s = sin(phi)
            c = cos(phi)

            !! Calculate position in machine coordinates
            uvw(1) = fast_ion%r*c
            uvw(2) = fast_ion%r*s
            uvw(3) = fast_ion%z

            !! Convert to beam grid coordinates
            call uvw_to_xyz(uvw, ri)

            if(inputs%dist_type.eq.2) then
                !! Get electomagnetic fields
                call get_fields(fields, pos=ri)

                !! Correct for gyro motion and get particle position and velocity
                call gyro_correction(fields, fast_ion%energy, fast_ion%pitch, ri, vi)
            else !! Full Orbit
                !! Calculate velocity vector
                uvw_vi(1) = c*fast_ion%vr - s*fast_ion%vt
                uvw_vi(2) = s*fast_ion%vr + c*fast_ion%vt
                uvw_vi(3) = fast_ion%vz
                vi = matmul(beam_grid%inv_basis,uvw_vi)
            endif

            !! Track particle through grid
            call track(ri, vi, tracks, ntrack, los_intersect)
            if(.not.los_intersect) cycle gamma_loop
            if(ntrack.eq.0)cycle gamma_loop

            !! Calculate CX probability
            call get_beam_cx_rate(tracks(1)%ind,ri,vi,beam_ion,neut_types,rates)
            if(sum(rates).le.0.)cycle gamma_loop

            !! Weight CX rates by ion source density
            states=rates*fast_ion%weight*(fast_ion%delta_phi/(2*pi))/beam_grid%dv/ngamma

            !! Calculate the spectra produced in each cell along the path
            loop_along_track: do jj=1,ntrack
                call get_plasma(plasma,pos=tracks(jj)%pos)

                call colrad(plasma,beam_ion, vi, tracks(jj)%time, states, denn, photons)

                call store_fida_photons(tracks(jj)%pos, vi, photons, fast_ion%class)
            enddo loop_along_track
        enddo gamma_loop
    enddo loop_over_fast_ions
    !$OMP END PARALLEL DO

#ifdef _MPI
    call parallel_sum(spec%fida)
#endif

end subroutine fida_mc

subroutine pfida_mc
    !+ Calculate Passive FIDA emission using a Monte Carlo Fast-ion distribution
    integer :: iion,igamma,ngamma
    type(FastIon) :: fast_ion
    type(LocalEMFields) :: fields
    type(LocalProfiles) :: plasma
    real(Float64) :: phi
    real(Float64), dimension(3) :: ri      !! start position
    real(Float64), dimension(3) :: vi      !! velocity of fast ions
    real(Float64), dimension(3) :: xyz_vi
    !! Determination of the CX probability
    real(Float64), dimension(nlevs) :: denn    !!  neutral dens (n=1-4)
    real(Float64), dimension(nlevs) :: rates    !! CX rates
    !! Collisiional radiative model along track
    real(Float64), dimension(nlevs) :: states  ! Density of n-states
    type(ParticleTrack), dimension(pass_grid%ntrack) :: tracks
    integer :: ntrack
    logical :: los_intersect
    integer :: jj      !! counter along track
    real(Float64) :: photons !! photon flux
    real(Float64)  :: s, c
    real(Float64), dimension(1) :: randomu

    ngamma = 1
    if(particles%axisym.or.(inputs%dist_type.eq.2)) then
        ngamma = ceiling(dble(inputs%n_pfida)/particles%nparticle)
    endif

    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i10)') int(particles%nparticle*ngamma,Int64)
    endif

    !$OMP PARALLEL DO schedule(dynamic,1) private(iion,igamma,fast_ion,vi,ri,phi,tracks,s,c,&
    !$OMP& randomu,plasma,fields,ntrack,jj,rates,denn,los_intersect,states,photons,xyz_vi)
    loop_over_fast_ions: do iion=istart,particles%nparticle,istep
        fast_ion = particles%fast_ion(iion)
        if(fast_ion%vabs.eq.0) cycle loop_over_fast_ions
        gamma_loop: do igamma=1,ngamma
            if(particles%axisym) then
                !! Pick random toroidal angle
                call randu(randomu)
                phi = pass_grid%phi(1)+pass_grid%nphi*pass_grid%dphi*randomu(1)
            else
                phi = fast_ion%phi
            endif
            s = sin(phi)
            c = cos(phi)

            !! Calculate position in machine coordinates
            ri(1) = fast_ion%r*c
            ri(2) = fast_ion%r*s
            ri(3) = fast_ion%z

            if(inputs%dist_type.eq.2) then
                !! Get electomagnetic fields
                call get_fields(fields, pos=ri, input_coords=1, output_coords=1)

                !! Correct for gyro motion and get particle position and velocity
                call gyro_correction(fields, fast_ion%energy, fast_ion%pitch, ri, vi)
            else !! Full Orbit
                !! Calculate velocity vector
                vi(1) = c*fast_ion%vr - s*fast_ion%vt
                vi(2) = s*fast_ion%vr + c*fast_ion%vt
                vi(3) = fast_ion%vz
            endif
            xyz_vi = matmul(beam_grid%inv_basis,vi)

            !! Track particle through grid
            call track_cylindrical(ri, vi, tracks, ntrack, los_intersect)
            if(.not.los_intersect) cycle gamma_loop
            if(ntrack.eq.0) cycle gamma_loop

            !! Calculate CX probability
            call get_plasma(plasma, pos=ri, input_coords=1)
            call bt_cx_rates(plasma, plasma%denn, xyz_vi, beam_ion, rates)
            if(sum(rates).le.0.) cycle gamma_loop

            !! Weight CX rates by ion source density
            if(particles%axisym) then
                states=rates*fast_ion%weight*(pass_grid%nphi*pass_grid%dphi/(2*pi))  &
                       /(fast_ion%r*pass_grid%dv)/ngamma

            else
                states=rates*fast_ion%weight/(fast_ion%r*pass_grid%dv)/ngamma
            endif

            !! Calculate the spectra produced in each cell along the path
            loop_along_track: do jj=1,ntrack
                call get_plasma(plasma,pos=tracks(jj)%pos,input_coords=1)

                call colrad(plasma,beam_ion, xyz_vi, tracks(jj)%time, states, denn, photons)

                call store_fida_photons(tracks(jj)%pos, xyz_vi, photons, fast_ion%class,passive=.True.)
            enddo loop_along_track
        enddo gamma_loop
    enddo loop_over_fast_ions
    !$OMP END PARALLEL DO

#ifdef _MPI
    call parallel_sum(spec%pfida)
#endif

end subroutine pfida_mc

subroutine npa_f
    !+ Calculate Active NPA flux using a fast-ion distribution function F(E,p,r,z)
    integer :: i,j,k,det,ic
    integer(Int64) :: iion
    real(Float64), dimension(3) :: rg,ri,rf,vi
    integer, dimension(3) :: ind,pind
    real(Float64) :: denf
    type(LocalProfiles) :: plasma
    type(LocalEMFields) :: fields
    type(GyroSurface) :: gs
    real(Float64), dimension(2,4) :: gyrange
    integer, dimension(5) :: neut_types=[1,2,3,4,5]
    real(Float64), dimension(nlevs) :: rates
    real(Float64), dimension(nlevs) :: states
    real(Float64) :: flux, theta, dtheta, eb, ptch

    integer :: inpa,ichan,nrange,ir,npart,ncell
    integer, dimension(beam_grid%ngrid) :: cell_ind
    real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox
    integer(Int32), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: nlaunch

    papprox=0.d0
    do ic=1,beam_grid%ngrid
        call ind2sub(beam_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        call get_plasma(plasma,ind=ind)
        if(.not.plasma%in_plasma) cycle
        papprox(i,j,k)=(sum(neut%full(:,i,j,k)) + &
                        sum(neut%half(:,i,j,k)) + &
                        sum(neut%third(:,i,j,k)) + &
                        sum(neut%dcx(:,i,j,k)) + &
                        sum(neut%halo(:,i,j,k)))* &
                        plasma%denf
    enddo

    ncell = 0
    do ic=1,beam_grid%ngrid
        call ind2sub(beam_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        if(papprox(i,j,k).gt.0.0) then
            ncell = ncell + 1
            cell_ind(ncell) = ic
        endif
    enddo

    call get_nlaunch(inputs%n_npa, papprox, nlaunch)
    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i12)') sum(nlaunch)
    endif

    !! Loop over all cells that can contribute to NPA signal
    !$OMP PARALLEL DO schedule(dynamic,1) private(ic,i,j,k,ind,iion,ichan,fields,nrange,gyrange, &
    !$OMP& pind,vi,ri,rf,det,plasma,rates,states,flux,denf,eb,ptch,gs,ir,theta,dtheta)
    loop_over_cells: do ic = istart, ncell, istep
        call ind2sub(beam_grid%dims,cell_ind(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        loop_over_fast_ions: do iion=1, nlaunch(i, j, k)
            !! Sample fast ion distribution for energy and pitch
            call mc_fastion(ind, fields, eb, ptch, denf)
            if(denf.le.0.0) cycle loop_over_fast_ions

            call gyro_surface(fields, eb, ptch, gs)

            detector_loop: do ichan=1,npa_chords%nchan
                call npa_gyro_range(ichan, gs, gyrange, nrange)
                if(nrange.eq.0) cycle detector_loop
                gyro_range_loop: do ir=1,nrange
                    dtheta = gyrange(2,ir)
                    theta = gyrange(1,ir) + 0.5*dtheta
                    call gyro_trajectory(gs, theta, ri, vi)

                    !! Check if particle hits a NPA detector
                    call hit_npa_detector(ri, vi ,det, rf, ichan)
                    if(det.ne.ichan) then
                        if (inputs%verbose.ge.0)then
                            write(*,*) "NPA_F: Missed Detector ",ichan
                        endif
                        cycle gyro_range_loop
                    endif

                    !! Get beam grid indices at ri
                    call get_indices(ri,pind)

                    !! Calculate CX probability with beam and halo neutrals
                    call get_beam_cx_rate(pind,ri,vi,beam_ion,neut_types,rates)
                    if(sum(rates).le.0.) cycle gyro_range_loop

                    !! Weight CX rates by ion source density
                    states=rates*denf

                    !! Attenuate states as the particle move through plasma
                    call attenuate(ri,rf,vi,states)

                    !! Store NPA Flux
                    flux = (dtheta/(2*pi))*sum(states)*beam_grid%dv/nlaunch(i,j,k)
                    call store_npa(det,ri,rf,vi,flux)
                enddo gyro_range_loop
            enddo detector_loop
        enddo loop_over_fast_ions
    enddo loop_over_cells
    !$OMP END PARALLEL DO

    npart = npa%npart
#ifdef _MPI
    call parallel_sum(npart)
    call parallel_sum(npa%flux)
#endif

    if(inputs%verbose.ge.1) then
        write(*,'(T4,"Number of Active NPA particles that hit a detector: ",i8)') npart
    endif

end subroutine npa_f

subroutine pnpa_f
    !+ Calculate Passive NPA flux using a fast-ion distribution function F(E,p,r,z)
    integer :: i,j,k,det,ic
    integer(Int64) :: iion
    real(Float64), dimension(3) :: rg,ri,rf,vi,ri_uvw
    integer, dimension(3) :: ind
    real(Float64) :: denf,r
    type(LocalProfiles) :: plasma
    type(LocalEMFields) :: fields
    type(GyroSurface) :: gs
    real(Float64), dimension(2,4) :: gyrange
    real(Float64), dimension(nlevs) :: rates
    real(Float64), dimension(nlevs) :: states
    real(Float64) :: flux, theta, dtheta, eb, ptch,max_papprox

    integer :: inpa,ichan,nrange,ir,npart,ncell
    integer, dimension(pass_grid%ngrid) :: cell_ind
    real(Float64), dimension(pass_grid%nr,pass_grid%nz,pass_grid%nphi) :: papprox
    integer(Int32), dimension(pass_grid%nr,pass_grid%nz,pass_grid%nphi) :: nlaunch

    papprox=0.d0
    do ic=1,pass_grid%ngrid
        call ind2sub(pass_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        call get_plasma(plasma,ind=ind,input_coords=2)
        if(.not.plasma%in_plasma) cycle
        papprox(i,j,k) = sum(plasma%denn)*plasma%denf
    enddo
    max_papprox = maxval(papprox)
    where (papprox.lt.(max_papprox*1.d-6))
        papprox = 0.0
    endwhere

    ncell = 0
    do ic=1,pass_grid%ngrid
        call ind2sub(pass_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        if(papprox(i,j,k).gt.0.0) then
            ncell = ncell + 1
            cell_ind(ncell) = ic
        endif
    enddo

    call get_nlaunch_pass_grid(inputs%n_pnpa, papprox, nlaunch)
    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i12)') sum(nlaunch)
    endif

    !! Loop over all cells that can contribute to NPA signal
    !$OMP PARALLEL DO schedule(dynamic,1) private(ic,i,j,k,ind,iion,ichan,fields,nrange,gyrange, &
    !$OMP& vi,ri,rf,det,plasma,rates,states,flux,denf,eb,ptch,gs,ir,theta,dtheta,r,ri_uvw)
    loop_over_cells: do ic = istart, ncell, istep
        call ind2sub(pass_grid%dims,cell_ind(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        loop_over_fast_ions: do iion=1, nlaunch(i, j, k)
            !! Sample fast ion distribution for energy and pitch
            call mc_fastion_pass_grid(ind, fields, eb, ptch, denf)
            if(denf.le.0.0) cycle loop_over_fast_ions

            call gyro_surface(fields, eb, ptch, gs)

            detector_loop: do ichan=1,npa_chords%nchan
                call npa_gyro_range(ichan, gs, gyrange, nrange)
                if(nrange.eq.0) cycle detector_loop
                gyro_range_loop: do ir=1,nrange
                    dtheta = gyrange(2,ir)
                    theta = gyrange(1,ir) + 0.5*dtheta
                    call gyro_trajectory(gs, theta, ri, vi)

                    !! Check if particle hits a NPA detector
                    call hit_npa_detector(ri, vi ,det, rf, ichan)
                    if(det.ne.ichan) then
                        if (inputs%verbose.ge.0)then
                            write(*,*) "PNPA_F: Missed Detector ",ichan
                        endif
                        cycle gyro_range_loop
                    endif

                    !! Calculate CX probability with beam and halo neutrals
                    call get_plasma(plasma, pos=ri)
                    call bt_cx_rates(plasma, plasma%denn, vi, beam_ion, rates)
                    if(sum(rates).le.0.) cycle gyro_range_loop

                    !! Weight CX rates by ion source density
                    states=rates*denf

                    !! Attenuate states as the particle move through plasma
                    call attenuate(ri,rf,vi,states)

                    !! Store NPA Flux
                    flux = (dtheta/(2*pi))*sum(states)*pass_grid%r(i)*pass_grid%dv/nlaunch(i,j,k)
                    call store_npa(det,ri,rf,vi,flux,passive=.True.)
                enddo gyro_range_loop
            enddo detector_loop
        enddo loop_over_fast_ions
    enddo loop_over_cells
    !$OMP END PARALLEL DO

    npart = pnpa%npart
#ifdef _MPI
    call parallel_sum(npart)
    call parallel_sum(pnpa%flux)
#endif

    if(inputs%verbose.ge.1) then
        write(*,'(T4,"Number of Passive NPA particles that hit a detector: ",i8)') npart
    endif

end subroutine pnpa_f

subroutine npa_mc
    !+ Calculate Active NPA flux using a Monte Carlo fast-ion distribution
    integer :: iion,igamma,ngamma,npart
    type(FastIon) :: fast_ion
    real(Float64) :: phi,theta,dtheta
    real(Float64), dimension(3) :: ri, rf, rg, vi
    integer :: det,ichan,ir,nrange,it
    type(LocalEMFields) :: fields
    type(GyroSurface) :: gs
    real(Float64), dimension(nlevs) :: rates
    real(Float64), dimension(nlevs) :: states
    real(Float64) :: flux
    integer, dimension(5) :: neut_types=[1,2,3,4,5]
    integer, dimension(3) :: ind
    real(Float64), dimension(3) :: uvw, uvw_vi
    real(Float64), dimension(2,4) :: gyrange
    real(Float64) :: s,c
    real(Float64), dimension(1) :: randomu

    ngamma = 1
    if(particles%axisym.or.(inputs%dist_type.eq.2)) then
        ngamma = ceiling(dble(inputs%n_npa)/particles%nparticle)
    endif

    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i10)') int(particles%nparticle*ngamma,Int64)
    endif

    !$OMP PARALLEL DO schedule(guided) private(iion,igamma,ind,fast_ion,vi,ri,rf,phi,s,c,ir,it, &
    !$OMP& randomu,rg,fields,uvw,uvw_vi,rates,states,flux,det,ichan,gs,nrange,gyrange,theta,dtheta)
    loop_over_fast_ions: do iion=istart,particles%nparticle,istep
        fast_ion = particles%fast_ion(iion)
        if(fast_ion%vabs.eq.0) cycle loop_over_fast_ions
        if(.not.fast_ion%beam_grid_cross_grid) cycle loop_over_fast_ions
        gamma_loop: do igamma=1,ngamma
            if(particles%axisym) then
                !! Pick random toroidal angle
                call randu(randomu)
                phi = fast_ion%beam_grid_phi_enter + fast_ion%delta_phi*randomu(1)
            else
                phi = fast_ion%phi
            endif
            s = sin(phi)
            c = cos(phi)

            !! Calculate position in machine coordinates
            uvw(1) = fast_ion%r*c
            uvw(2) = fast_ion%r*s
            uvw(3) = fast_ion%z

            if(inputs%dist_type.eq.2) then
                !! Convert to beam grid coordinates
                call uvw_to_xyz(uvw, rg)

                !! Get electomagnetic fields
                call get_fields(fields, pos=rg)

                !! Correct for gyro motion and get position and velocity
                call gyro_surface(fields, fast_ion%energy, fast_ion%pitch, gs)

                detector_loop: do ichan=1,npa_chords%nchan
                    call npa_gyro_range(ichan, gs, gyrange, nrange)
                    if(nrange.eq.0) cycle detector_loop

                    gyro_range_loop: do ir=1,nrange
                        dtheta = gyrange(2,ir)
                        theta = gyrange(1,ir) + 0.5*dtheta
                        call gyro_trajectory(gs, theta, ri, vi)

                        !! Check if particle hits a NPA detector
                        call hit_npa_detector(ri, vi ,det, rf, det=ichan)
                        if(det.ne.ichan) then
                            if (inputs%verbose.ge.0)then
                                write(*,*) "NPA_MC: Missed Detector ",ichan
                            endif
                            cycle gyro_range_loop
                        endif

                        !! Get beam grid indices at ri
                        call get_indices(ri,ind)

                        !! Calculate CX probability with beam and halo neutrals
                        call get_beam_cx_rate(ind,ri,vi,beam_ion,neut_types,rates)
                        if(sum(rates).le.0.) cycle gyro_range_loop

                        !! Weight CX rates by ion source density
                        states=rates*fast_ion%weight*(fast_ion%delta_phi/(2*pi))/beam_grid%dv/ngamma

                        !! Attenuate states as the particle move through plasma
                        call attenuate(ri,rf,vi,states)

                        !! Store NPA Flux
                        flux = (dtheta/(2*pi))*sum(states)*beam_grid%dv
                        spread_loop: do it=1,25
                            theta = gyrange(1,ir) + (it-0.5)*dtheta/25
                            call gyro_trajectory(gs, theta, ri, vi)
                            call hit_npa_detector(ri, vi ,det, rf, det=ichan)
                            if(det.ne.ichan) then
                                if (inputs%verbose.ge.0)then
                                    write(*,*) "NPA_MC: Missed Detector ",ichan
                                endif
                                cycle spread_loop
                            endif
                            call store_npa(det,ri,rf,vi,flux/25,fast_ion%class)
                        enddo spread_loop
                    enddo gyro_range_loop
                enddo detector_loop
            else !! Full Orbit
                !! Convert to beam grid coordinates
                call uvw_to_xyz(uvw, ri)

                !! Calculate velocity vector
                uvw_vi(1) = c*fast_ion%vr - s*fast_ion%vt
                uvw_vi(2) = s*fast_ion%vr + c*fast_ion%vt
                uvw_vi(3) = fast_ion%vz
                vi = matmul(beam_grid%inv_basis,uvw_vi)

                !! Check if particle hits a NPA detector
                call hit_npa_detector(ri, vi ,det, rf)
                if(det.eq.0) cycle gamma_loop

                !! Get beam grid indices at ri
                call get_indices(ri,ind)

                !! Calculate CX probability with beam and halo neutrals
                call get_beam_cx_rate(ind,ri,vi,beam_ion,neut_types,rates)
                if(sum(rates).le.0.) cycle gamma_loop

                !! Weight CX rates by ion source density
                states=rates*fast_ion%weight*(fast_ion%delta_phi/(2*pi))/beam_grid%dv/ngamma

                !! Attenuate states as the particle moves though plasma
                call attenuate(ri,rf,vi,states)

                !! Store NPA Flux
                flux = sum(states)*beam_grid%dv
                call store_npa(det,ri,rf,vi,flux,fast_ion%class)
            endif
        enddo gamma_loop
    enddo loop_over_fast_ions
    !$OMP END PARALLEL DO

    npart = npa%npart
#ifdef _MPI
    call parallel_sum(npart)
    call parallel_sum(npa%flux)
#endif

    if(inputs%verbose.ge.1) then
        write(*,'(T4,"Number of Active NPA particles that hit a detector: ",i8)') npart
    endif

end subroutine npa_mc

subroutine pnpa_mc
    !+ Calculate Passive NPA flux using a Monte Carlo fast-ion distribution
    integer :: iion,igamma,ngamma,npart
    type(FastIon) :: fast_ion
    real(Float64) :: phi,theta,dtheta
    real(Float64), dimension(3) :: ri, rf, rg, vi
    integer :: det,j,ichan,ir,nrange,it
    type(LocalEMFields) :: fields
    type(LocalProfiles) :: plasma
    type(GyroSurface) :: gs
    real(Float64), dimension(nlevs) :: rates
    real(Float64), dimension(nlevs) :: states
    real(Float64) :: flux
    integer, dimension(3) :: ind
    real(Float64), dimension(3) :: uvw, uvw_vi
    real(Float64), dimension(2,4) :: gyrange
    real(Float64) :: s,c
    real(Float64), dimension(1) :: randomu

    ngamma = 1
    if(particles%axisym.or.(inputs%dist_type.eq.2)) then
        ngamma = ceiling(dble(inputs%n_pnpa)/particles%nparticle)
    endif

    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i10)') int(particles%nparticle*ngamma,Int64)
    endif

    !$OMP PARALLEL DO schedule(guided) private(iion,igamma,ind,fast_ion,vi,ri,rf,phi,s,c,ir,it,plasma, &
    !$OMP& randomu,rg,fields,uvw,uvw_vi,rates,states,flux,det,ichan,gs,nrange,gyrange,theta,dtheta)
    loop_over_fast_ions: do iion=istart,particles%nparticle,istep
        fast_ion = particles%fast_ion(iion)
        if(fast_ion%vabs.eq.0) cycle loop_over_fast_ions
        gamma_loop: do igamma=1,ngamma
            if(particles%axisym) then
                !! Pick random toroidal angle
                call randu(randomu)
                phi = pass_grid%phi(1)+pass_grid%nphi*pass_grid%dphi*randomu(1)
            else
                phi = fast_ion%phi
            endif
            s = sin(phi)
            c = cos(phi)

            !! Calculate position in machine coordinates
            uvw(1) = fast_ion%r*c
            uvw(2) = fast_ion%r*s
            uvw(3) = fast_ion%z

            if(inputs%dist_type.eq.2) then
                !! Get electomagnetic fields
                call get_fields(fields, pos=uvw, input_coords=1)

                !! Correct for gyro motion and get position and velocity
                call gyro_surface(fields, fast_ion%energy, fast_ion%pitch, gs)

                detector_loop: do ichan=1,npa_chords%nchan
                    call npa_gyro_range(ichan, gs, gyrange, nrange)
                    if(nrange.eq.0) cycle detector_loop

                    gyro_range_loop: do ir=1,nrange
                        dtheta = gyrange(2,ir)
                        theta = gyrange(1,ir) + 0.5*dtheta
                        call gyro_trajectory(gs, theta, ri, vi)

                        !! Check if particle hits a NPA detector
                        call hit_npa_detector(ri, vi ,det, rf, det=ichan)
                        if(det.ne.ichan) then
                            if (inputs%verbose.ge.0)then
                                write(*,*) "PNPA_MC: Missed Detector ",ichan
                            endif
                            cycle gyro_range_loop
                        endif

                        !! Calculate CX probability with beam and halo neutrals
                        call get_plasma(plasma, pos=ri)
                        call bt_cx_rates(plasma, plasma%denn, vi, beam_ion, rates)
                        if(sum(rates).le.0.) cycle gyro_range_loop

                        !! Weight CX rates by ion source density
                        if(particles%axisym) then
                            states=rates*fast_ion%weight*(pass_grid%nphi*pass_grid%dphi/(2*pi)) &
                                   /(fast_ion%r*pass_grid%dv)/ngamma
                        else
                            states=rates*fast_ion%weight/(fast_ion%r*pass_grid%dv)/ngamma
                        endif

                        !! Attenuate states as the particle move through plasma
                        call attenuate(ri,rf,vi,states)

                        !! Store NPA Flux
                        flux = (dtheta/(2*pi))*sum(states)*(fast_ion%r*pass_grid%dv)
                        spread_loop: do it=1,25
                            theta = gyrange(1,ir) + (it-0.5)*dtheta/25
                            call gyro_trajectory(gs, theta, ri, vi)
                            call hit_npa_detector(ri, vi ,det, rf, det=ichan)
                            if(det.ne.ichan) then
                                if (inputs%verbose.ge.0)then
                                    write(*,*) "PNPA_MC: Missed Detector ",ichan
                                endif
                                cycle spread_loop
                            endif
                            call store_npa(det,ri,rf,vi,flux/25,fast_ion%class, passive=.True.)
                        enddo spread_loop
                    enddo gyro_range_loop
                enddo detector_loop
            else !! Full Orbit
                !! Convert to beam grid coordinates
                call uvw_to_xyz(uvw, ri)

                !! Calculate velocity vector
                uvw_vi(1) = c*fast_ion%vr - s*fast_ion%vt
                uvw_vi(2) = s*fast_ion%vr + c*fast_ion%vt
                uvw_vi(3) = fast_ion%vz
                vi = matmul(beam_grid%inv_basis,uvw_vi)

                !! Check if particle hits a NPA detector
                call hit_npa_detector(ri, vi ,det, rf)
                if(det.eq.0) cycle gamma_loop

                !! Calculate CX probability with beam and halo neutrals
                call get_plasma(plasma, pos=ri)
                call bt_cx_rates(plasma, plasma%denn, vi, beam_ion, rates)
                if(sum(rates).le.0.) cycle gamma_loop

                !! Weight CX rates by ion source density
                if(particles%axisym) then
                    states=rates*fast_ion%weight*(pass_grid%nphi*pass_grid%dphi/(2*pi)) &
                           /(fast_ion%r*pass_grid%dv)/ngamma
                else
                    states=rates*fast_ion%weight/(fast_ion%r*pass_grid%dv)/ngamma
                endif

                !! Attenuate states as the particle moves though plasma
                call attenuate(ri,rf,vi,states)

                !! Store NPA Flux
                flux = sum(states)*(fast_ion%r*pass_grid%dv)
                call store_npa(det,ri,rf,vi,flux,fast_ion%class,passive=.True.)
            endif
        enddo gamma_loop
    enddo loop_over_fast_ions
    !$OMP END PARALLEL DO

    npart = pnpa%npart
#ifdef _MPI
    call parallel_sum(npart)
    call parallel_sum(pnpa%flux)
#endif

    if(inputs%verbose.ge.1) then
        write(*,'(T4,"Number of Passive NPA particles that hit a detector: ",i8)') npart
    endif

end subroutine pnpa_mc

subroutine neutron_f
    !+ Calculate neutron emission rate using a fast-ion distribution function F(E,p,r,z)
    integer :: ir, iphi, iz, ie, ip, igamma, ngamma
    type(LocalProfiles) :: plasma
    type(LocalEMFields) :: fields
    real(Float64) :: eb,pitch
    real(Float64) :: erel, rate
    real(Float64), dimension(3) :: ri
    real(Float64), dimension(3) :: vi
    real(Float64), dimension(3) :: uvw, uvw_vi
    real(Float64)  :: vnet_square, factor
    real(Float64)  :: s, c

    if(inputs%calc_neutron.ge.2) then
        allocate(neutron%weight(fbm%nenergy,fbm%npitch,fbm%nr,fbm%nz,fbm%nphi))
        neutron%weight = 0.d0
        allocate(neutron%emis(fbm%nr,fbm%nz,fbm%nphi))
        neutron%emis = 0.d0
    endif

    ngamma = 20
    rate = 0
    !$OMP PARALLEL DO schedule(guided) private(fields,vi,ri,pitch,eb,&
    !$OMP& ir,iphi,iz,ie,ip,igamma,plasma,factor,uvw,uvw_vi,vnet_square,rate,erel,s,c)
    phi_loop: do iphi = 1, fbm%nphi
        z_loop: do iz = istart, fbm%nz, istep
            r_loop: do ir=1, fbm%nr
                !! Calculate position
                if(fbm%nphi.eq.1) then
                    s = 0.d0
                    c = 1.d0
                else
                    s = sin(fbm%phi(iphi))
                    c = cos(fbm%phi(iphi))
                endif

                uvw(1) = fbm%r(ir)*c
                uvw(2) = fbm%r(ir)*s
                uvw(3) = fbm%z(iz)

                !! Get fields
                call get_fields(fields,pos=uvw,input_coords=1)
                if(.not.fields%in_plasma) cycle r_loop

                factor = fbm%r(ir)*fbm%dE*fbm%dp*fbm%dr*fbm%dz*fbm%dphi/ngamma
                !! Loop over energy/pitch/gamma
                pitch_loop: do ip = 1, fbm%npitch
                    pitch = fbm%pitch(ip)
                    energy_loop: do ie =1, fbm%nenergy
                        eb = fbm%energy(ie)
                        gyro_loop: do igamma=1, ngamma
                            call gyro_correction(fields,eb,pitch,ri,vi)

                            !! Get plasma parameters at particle position
                            call get_plasma(plasma,pos=ri)
                            if(.not.plasma%in_plasma) cycle gyro_loop

                            !! Calculate effective beam energy
                            vnet_square=dot_product(vi-plasma%vrot,vi-plasma%vrot)  ![cm/s]
                            erel = v2_to_E_per_amu*inputs%ab*vnet_square ![kev]

                            !! Get neutron production rate
                            call get_neutron_rate(plasma, erel, rate)
                            if(inputs%calc_neutron.ge.2) then
                                neutron%weight(ie,ip,ir,iz,iphi) = neutron%weight(ie,ip,ir,iz,iphi) &
                                                                 + rate * factor
                                !$OMP CRITICAL(neutron_emis)
                                neutron%emis(ir,iz,iphi) = neutron%emis(ir,iz,iphi) &
                                                                 + rate * fbm%f(ie,ip,ir,iz,iphi) &
                                                                 * factor
                                !$OMP END CRITICAL(neutron_emis)
                            endif

                            rate = rate*fbm%f(ie,ip,ir,iz,iphi)*factor
                            !! Store neutrons
                            call store_neutrons(rate)
                        enddo gyro_loop
                    enddo energy_loop
                enddo pitch_loop
            enddo r_loop
        enddo z_loop
    enddo phi_loop
    !$OMP END PARALLEL DO

#ifdef _MPI
    call parallel_sum(neutron%rate)
    if(inputs%calc_neutron.ge.2) then
        call parallel_sum(neutron%weight)
        call parallel_sum(neutron%emis)
    endif
#endif

    if(inputs%verbose.ge.1) then
        write(*,'(T4,A,ES14.5," [neutrons/s]")') 'Rate:   ',sum(neutron%rate)
        write(*,'(30X,a)') ''
        write(*,*) 'write neutrons:    ' , time(time_start)
    endif

#ifdef _MPI
    if(my_rank().eq.0) call write_neutrons()
#else
    call write_neutrons()
#endif


end subroutine neutron_f

subroutine neutron_mc
    !+ Calculate neutron flux using a Monte Carlo Fast-ion distribution
    integer :: iion, ngamma, igamma
    type(FastIon) :: fast_ion
    type(LocalProfiles) :: plasma
    type(LocalEMFields) :: fields
    real(Float64) :: eb, rate
    real(Float64), dimension(3) :: ri
    real(Float64), dimension(3) :: vi
    real(Float64), dimension(3) :: uvw, uvw_vi
    real(Float64)  :: vnet_square
    real(Float64)  :: phi, s, c, factor, delta_phi

    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i10)') particles%nparticle
    endif

    !! Correct neutron rate when equilibrium is 3D and MC distribution is 4D
    if(particles%axisym.and.(inter_grid%nphi.gt.1)) then
        delta_phi = inter_grid%phi(inter_grid%nphi)-inter_grid%phi(1)
        delta_phi = delta_phi + delta_phi/(inter_grid%nphi-1)/2 !Add half a cell
        factor = delta_phi/(2*pi) * 2 !Riemann sum below assumes coord's are at midpoint of cell
    else
        factor = 1
    endif

    rate=0.0
    ngamma = 20
    !$OMP PARALLEL DO schedule(guided) private(iion,fast_ion,vi,ri,s,c, &
    !$OMP& plasma,fields,uvw,uvw_vi,vnet_square,rate,eb,igamma,phi)
    loop_over_fast_ions: do iion=istart,particles%nparticle,istep
        fast_ion = particles%fast_ion(iion)
        if(fast_ion%vabs.eq.0.d0) cycle loop_over_fast_ions

        !! Calculate position in machine coordinates
        if(particles%axisym) then
            s = 0.d0
            c = 1.d0
        else
            phi = fast_ion%phi
            s = sin(phi)
            c = cos(phi)
        endif

        uvw(1) = fast_ion%r*c
        uvw(2) = fast_ion%r*s
        uvw(3) = fast_ion%z

        if(inputs%dist_type.eq.2) then
            !! Get electomagnetic fields
            call get_fields(fields, pos=uvw, input_coords=1)
            if(.not.fields%in_plasma) cycle loop_over_fast_ions

            gyro_loop: do igamma=1,ngamma
                !! Correct for Gyro-motion
                call gyro_correction(fields, fast_ion%energy, fast_ion%pitch, ri, vi)

                !! Get plasma parameters
                call get_plasma(plasma,pos=ri)
                if(.not.plasma%in_plasma) cycle gyro_loop

                !! Calculate effective beam energy
                vnet_square=dot_product(vi-plasma%vrot,vi-plasma%vrot)  ![cm/s]
                eb = v2_to_E_per_amu*inputs%ab*vnet_square ![kev]

                !! Get neutron production rate
                call get_neutron_rate(plasma, eb, rate)
                rate = rate*fast_ion%weight/ngamma*factor

                !! Store neutrons
                call store_neutrons(rate, fast_ion%class)
            enddo gyro_loop
        else
            !! Get plasma parameters
            call get_plasma(plasma,pos=uvw,input_coords=1)
            if(.not.plasma%in_plasma) cycle loop_over_fast_ions

            !! Calculate effective beam energy
            uvw_vi(1) = fast_ion%vr
            uvw_vi(2) = fast_ion%vt
            uvw_vi(3) = fast_ion%vz
            vi = matmul(beam_grid%inv_basis,uvw_vi)
            vnet_square=dot_product(vi-plasma%vrot,vi-plasma%vrot)  ![cm/s]
            eb = v2_to_E_per_amu*inputs%ab*vnet_square ![kev]

            !! Get neutron production rate
            call get_neutron_rate(plasma, eb, rate)
            rate = rate*fast_ion%weight*factor

            !! Store neutrons
            call store_neutrons(rate, fast_ion%class)
        endif
    enddo loop_over_fast_ions
    !$OMP END PARALLEL DO

#ifdef _MPI
    call parallel_sum(neutron%rate)
#endif

    if(inputs%verbose.ge.1) then
        write(*,'(T4,A,ES14.5," [neutrons/s]")') 'Rate:   ',sum(neutron%rate)
        write(*,'(30X,a)') ''
        write(*,*) 'write neutrons:    ' , time(time_start)
    endif

#ifdef _MPI
    if(my_rank().eq.0) call write_neutrons()
#else
    call write_neutrons()
#endif

end subroutine neutron_mc

subroutine fida_weights_mc
    !+ Calculates FIDA weights
    integer :: i,j,k,ic,ncell
    integer(Int64) :: iion,ip
    real(Float64), dimension(3) :: ri,rg      !! start position
    real(Float64), dimension(3) :: vi     !! velocity of fast ions
    integer, dimension(3) :: ind      !! new actual cell
    integer,dimension(5) :: neut_types=[1,2,3,4,5]
    logical :: los_intersect

    !! Determination of the CX rates
    type(LocalProfiles) :: plasma
    type(LocalEMFields) :: fields
    real(Float64), dimension(nlevs) :: rates !! CX rates

    !! Collisiional radiative model along track
    integer :: ntrack
    integer :: jj      !! counter along track
    type(ParticleTrack),dimension(beam_grid%ntrack) :: tracks

    real(Float64) :: photons !! photon flux
    real(Float64), dimension(nlevs) :: states  !! Density of n-states
    real(Float64), dimension(nlevs) :: denn

    integer :: nwav
    real(Float64) :: etov2, energy, pitch
    real(Float64) :: dE, dP, dEdP
    real(Float64), dimension(:), allocatable :: ebarr, ptcharr
    integer, dimension(1) :: ienergy, ipitch
    real(Float64), dimension(3) :: randomu3

    !! Number of particles to launch
    real(Float64) :: fbm_denf,phase_area
    integer, dimension(beam_grid%ngrid) :: cell_ind
    real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox
    integer(Int32), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: nlaunch

    nwav = inputs%nlambda_wght

    !! define arrays
    !! define energy - array
    allocate(ebarr(inputs%ne_wght))
    do i=1,inputs%ne_wght
        ebarr(i)=real(i-0.5)*inputs%emax_wght/real(inputs%ne_wght)
    enddo
    dE = abs(ebarr(2)-ebarr(1))

    !! define pitch - array
    allocate(ptcharr(inputs%np_wght))
    do i=1,inputs%np_wght
        ptcharr(i)=real(i-0.5)*2./real(inputs%np_wght)-1.
    enddo
    dP = abs(ptcharr(2)-ptcharr(1))
    dEdP = dE*dP
    phase_area = dEdP*real(inputs%np_wght)*real(inputs%ne_wght)

    !! allocate storage arrays
    allocate(fweight%weight(nwav,inputs%ne_wght,inputs%np_wght,spec_chords%nchan))
    allocate(fweight%mean_f(inputs%ne_wght,inputs%np_wght,spec_chords%nchan))

    if(inputs%verbose.ge.1) then
        write(*,'(T3,"Number of Channels: ",i5)') spec_chords%nchan
        write(*,'(T3,"Nlambda: ",i4)') nwav
        write(*,'(T3,"Nenergy: ",i3)') inputs%ne_wght
        write(*,'(T3,"Maximum Energy: ",f7.2)') inputs%emax_wght
        write(*,'(T3,"LOS averaged: ",a)') "False"
    endif

    !! zero out arrays
    fweight%weight = 0.d0
    fweight%mean_f = 0.d0

    etov2 = 1.d0/(v2_to_E_per_amu*inputs%ab)

    !! Estimate how many particles to launch in each cell
    papprox=0.d0
    do ic=1,beam_grid%ngrid
        call ind2sub(beam_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        call get_plasma(plasma,ind=ind)
        if(.not.plasma%in_plasma) cycle
        papprox(i,j,k)=(sum(neut%full(:,i,j,k)) + &
                        sum(neut%half(:,i,j,k)) + &
                        sum(neut%third(:,i,j,k)) + &
                        sum(neut%dcx(:,i,j,k)) + &
                        sum(neut%halo(:,i,j,k)))
    enddo

    ncell = 0
    do ic=1,beam_grid%ngrid
        call ind2sub(beam_grid%dims,ic,ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        if(papprox(i,j,k).gt.0.0) then
            ncell = ncell + 1
            cell_ind(ncell) = ic
        endif
    enddo

    call get_nlaunch(10*inputs%n_fida,papprox, nlaunch)
    if(inputs%verbose.ge.1) then
        write(*,'(T6,"# of markers: ",i10)') sum(nlaunch)
    endif

    !! Loop over all cells that have neutrals
    !$OMP PARALLEL DO schedule(guided) private(ic,i,j,k,ind,iion,vi,ri,rg,ienergy,ipitch, &
    !$OMP tracks,ntrack,jj,plasma,fields,rates,denn,states,photons,energy,pitch, &
    !$OMP los_intersect,randomu3,fbm_denf)
    loop_over_cells: do ic = istart, ncell, istep
        call ind2sub(beam_grid%dims,cell_ind(ic),ind)
        i = ind(1) ; j = ind(2) ; k = ind(3)
        loop_over_fast_ions: do iion=1, nlaunch(i, j, k)
            !! Sample fast ion distribution uniformally
            call randind(inputs%ne_wght, ienergy)
            call randind(inputs%np_wght, ipitch)
            call randu(randomu3)
            energy = ebarr(ienergy(1)) + dE*(randomu3(1)-0.5)
            pitch = ptcharr(ipitch(1)) + dP*(randomu3(2)-0.5)
            if(energy.le.0) cycle loop_over_fast_ions

            call randu(randomu3)
            rg = [beam_grid%xc(i),beam_grid%yc(j),beam_grid%zc(k)] + beam_grid%dr*(randomu3-0.5)

            !! Get velocity
            call get_fields(fields,pos=rg)
            if(.not.fields%in_plasma) cycle loop_over_fast_ions
            call gyro_correction(fields,energy,pitch,ri,vi)

            fbm_denf = 0.0
            if (inputs%dist_type.eq.1) then
                call get_ep_denf(energy,pitch,fbm_denf,coeffs=fields%b)
            endif

            !! Find the particles path through the beam grid
            call track(ri, vi, tracks, ntrack, los_intersect)
            if(.not.los_intersect) cycle loop_over_fast_ions
            if(ntrack.eq.0) cycle loop_over_fast_ions

            !! Calculate CX probability with beam and halo neutrals
            call get_beam_cx_rate(tracks(1)%ind, ri, vi, beam_ion, neut_types, rates)
            if(sum(rates).le.0.) cycle loop_over_fast_ions
            states=rates*1.d20

            !! Calculate the spectra produced in each cell along the path
            loop_along_track: do jj=1,ntrack
                call get_plasma(plasma,pos=tracks(jj)%pos)

                call colrad(plasma,beam_ion, vi, tracks(jj)%time, states, denn, photons)

                call store_fw_photons(ienergy(1), ipitch(1), &
                     tracks(jj)%pos, vi, fbm_denf, photons/nlaunch(i,j,k))
            enddo loop_along_track
        enddo loop_over_fast_ions
    enddo loop_over_cells
    !$OMP END PARALLEL DO

    fweight%weight = ((1.d-20)*phase_area/dEdP)*fweight%weight
    fweight%mean_f = ((1.d-20)*phase_area/dEdP)*fweight%mean_f

    if(inputs%verbose.ge.1) then
        write(*,*) 'write fida weights:    ' , time(time_start)
    endif

#ifdef _MPI
    call parallel_sum(fweight%weight)
    call parallel_sum(fweight%mean_f)
    if(my_rank().eq.0) call write_fida_weights()
#else
    call write_fida_weights()
#endif

end subroutine fida_weights_mc

subroutine fida_weights_los
    !+ Calculates LOS averaged FIDA weights
    type(LocalProfiles) :: plasma, plasma_cell
    type(LocalEMFields) :: fields, fields_cell
    real(Float64) :: denf
    real(Float64) :: wght, wght_tot
    real(Float64) :: photons !! photon flux
    real(Float64) :: length
    type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks
    integer :: nwav
    integer(Int32) :: i, j, k, ienergy, cid, cind
    integer(Int32) :: ipitch, igyro, icell, ichan
    real(Float64), dimension(:), allocatable :: ebarr,ptcharr,phiarr
    real(Float64), dimension(:,:), allocatable :: mean_f
    real(Float64), dimension(3) :: vi, vi_norm, vp
    real(Float64), dimension(3) :: vnbi_f, vnbi_h, vnbi_t, vhalo
    real(Float64), dimension(3) :: r_enter, r_exit
    real(Float64) :: vabs, dE, dP
    !! Determination of the CX probability
    real(Float64), dimension(nlevs) :: fdens,hdens,tdens,dcxdens,halodens
    real(Float64), dimension(nlevs) :: rates
    real(Float64), dimension(nlevs) :: states ! Density of n-states
    real(Float64), dimension(nlevs) :: denn  ! Density of n-states
    !! COLRAD
    real(Float64) :: dt, max_dens, dlength, sigma_pi
    type(LOSInters) :: inter
    real(Float64) :: eb, ptch, phi
    !! Solution of differential equation
    integer, dimension(3) :: ind  !!actual cell
    real(Float64), dimension(3) :: ri
    integer(Int32) :: ntrack
    logical :: inp

    real(Float64):: etov2, dEdP

    nwav = inputs%nlambda_wght

    !! Define energy array
    allocate(ebarr(inputs%ne_wght))
    do i=1,inputs%ne_wght
        ebarr(i)=real(i-0.5)*inputs%emax_wght/real(inputs%ne_wght)
    enddo
    dE = abs(ebarr(2)-ebarr(1))

    !! Define pitch array
    allocate(ptcharr(inputs%np_wght))
    do i=1,inputs%np_wght
        ptcharr(i)=real(i-0.5)*2./real(inputs%np_wght)-1.
    enddo
    dP = abs(ptcharr(2)-ptcharr(1))
    dEdP = dE*dP

    !! define gyro - array
    allocate(phiarr(inputs%nphi_wght))
    do i=1,inputs%nphi_wght
        phiarr(i)=real(i-0.5)*2.d0*pi/real(inputs%nphi_wght)
    enddo

    !! allocate storage arrays
    allocate(fweight%mean_f(inputs%ne_wght,inputs%np_wght,spec_chords%nchan))
    allocate(fweight%weight(nwav,inputs%ne_wght,inputs%np_wght,spec_chords%nchan))

    allocate(mean_f(inputs%ne_wght,inputs%np_wght))
    !! zero out arrays
    fweight%weight = 0.d0
    fweight%mean_f = 0.d0
    mean_f = 0.d0

    if(inputs%verbose.ge.1) then
        write(*,'(T3,"Number of Channels: ",i5)') spec_chords%nchan
        write(*,'(T3,"Nlambda: ",i4)') nwav
        write(*,'(T3,"Nenergy: ",i3)') inputs%ne_wght
        write(*,'(T3,"Npitch: ",i3)') inputs%np_wght
        write(*,'(T3,"Ngyro: ", i3)') inputs%nphi_wght
        write(*,'(T3,"Maximum Energy: ",f7.2)') inputs%emax_wght
        write(*,'(T3,"LOS averaged: ",a)') "True"
        write(*,*) ''
    endif

    etov2 = 1.0/(v2_to_E_per_amu*inputs%ab)

    chan_loop: do ichan=1,spec_chords%nchan
        fdens = 0.d0 ; hdens = 0.d0 ; tdens = 0.d0
        halodens = 0.d0 ; dcxdens = 0.d0
        plasma = plasma*0.d0
        fields = fields*0.d0
        wght_tot = 0.d0
        mean_f = 0.d0
        do k=1,beam_grid%nz
            do j=1,beam_grid%ny
                x_loop: do i=1,beam_grid%nx
                    inter = spec_chords%inter(i,j,k)
                    cid = 0
                    cind = 0
                    do while (cid.ne.ichan.and.cind.lt.inter%nchan)
                        cind = cind + 1
                        cid = inter%los_elem(cind)%id
                    enddo
                    if(cid.eq.ichan) then
                        ind = [i,j,k]
                        ri = [beam_grid%xc(i), beam_grid%yc(j), beam_grid%zc(k)]
                        call in_plasma(ri,inp)
                        if(.not.inp) cycle x_loop
                        dlength = inter%los_elem(cind)%length
                        fdens = fdens + neut%full(:,i,j,k)*dlength
                        hdens = hdens + neut%half(:,i,j,k)*dlength
                        tdens = tdens + neut%third(:,i,j,k)*dlength
                        dcxdens = dcxdens + neut%dcx(:,i,j,k)*dlength
                        halodens = halodens + neut%halo(:,i,j,k)*dlength
                        wght = (neut%full(3,i,j,k) + neut%half(3,i,j,k) + &
                                neut%third(3,i,j,k) + neut%dcx(3,i,j,k) + &
                                neut%halo(3,i,j,k))*dlength

                        call get_plasma(plasma_cell,pos=ri)
                        call get_fields(fields_cell,pos=ri)
                        plasma = plasma + wght*plasma_cell
                        fields = fields + wght*fields_cell
                        if (inputs%dist_type.eq.1) then
                            do ipitch=1,inputs%np_wght
                                do ienergy=1,inputs%ne_wght
                                    call get_ep_denf(ebarr(ienergy),ptcharr(ipitch),denf,coeffs=fields_cell%b)
                                    mean_f(ienergy,ipitch) = mean_f(ienergy,ipitch) + wght*denf
                                enddo
                            enddo
                        endif
                        wght_tot = wght_tot + wght
                    endif
                enddo x_loop
            enddo
        enddo

        if(wght_tot.le.0) then
            if(inputs%verbose.ge.1) then
                write(*,'(T4,"Skipping channel ",i5,": Neutral density is zero")') ichan
            endif
            cycle chan_loop
        else
            plasma = plasma/wght_tot
            plasma%in_plasma = .True.
            fields = fields/wght_tot
            fields%in_plasma= .True.
            mean_f = mean_f/wght_tot
            if(inputs%verbose.ge.1) then
                write(*,'(T4,"Channel: ",i5)') ichan
                write(*,'(T4,"Radius: ",f7.2)') spec_chords%radius(ichan)
                write(*,'(T4,"Mean Fast-ion Density: ",ES14.5)') sum(mean_f)*dEdP
                write(*,*)''
            endif
        endif

        ri = plasma%pos
        vp = ri - spec_chords%los(ichan)%lens
        vnbi_f = ri - nbi%src
        vnbi_f = vnbi_f/norm2(vnbi_f)*nbi%vinj
        vnbi_h = vnbi_f/sqrt(2.d0)
        vnbi_t = vnbi_f/sqrt(3.d0)
        sigma_pi = spec_chords%los(ichan)%sigma_pi
        dlength = 1.d0

        !$OMP PARALLEL DO schedule(guided) collapse(3) private(eb,vabs,ptch,phi,vi,vi_norm, &
        !$OMP& r_enter,r_exit,length,max_dens,ind,tracks,ntrack,dt,icell,states,rates, &
        !$OMP& vhalo,denn,denf,photons,ienergy,ipitch,igyro)
        do ienergy=istart,inputs%ne_wght,istep
            do ipitch=1,inputs%np_wght
                do igyro=1,inputs%nphi_wght
                    eb = ebarr(ienergy)
                    vabs = sqrt(eb*etov2)
                    ptch = ptcharr(ipitch)
                    phi = phiarr(igyro)
                    call pitch_to_vec(ptch,phi,fields,vi_norm)
                    vi = vabs*vi_norm

                    call grid_intersect(ri,vi,length,r_enter,r_exit)
                    call track(r_enter, vi, tracks, ntrack)
                    max_dens = 0.d0
                    do icell=1,ntrack
                        ind = tracks(icell)%ind
                        tracks(icell)%flux = neut%full(3,ind(1),ind(2),ind(3))  + &
                                             neut%half(3,ind(1),ind(2),ind(3))  + &
                                             neut%third(3,ind(1),ind(2),ind(3)) + &
                                             neut%dcx(3,ind(1),ind(2),ind(3))   + &
                                             neut%halo(3,ind(1),ind(2),ind(3))
                        if(tracks(icell)%flux.gt.max_dens) max_dens=tracks(icell)%flux
                    enddo
                    dt = 0.d0
                    do icell=1,ntrack
                        if(tracks(icell)%flux.gt.(0.5*max_dens)) then
                            dt = dt + tracks(icell)%time
                        endif
                    enddo

                    states=0.d0
                    call bb_cx_rates(fdens,vi,vnbi_f,rates)
                    states = states + rates
                    call bb_cx_rates(hdens,vi,vnbi_h,rates)
                    states = states + rates
                    call bb_cx_rates(tdens,vi,vnbi_t,rates)
                    states = states + rates
                    call bt_cx_rates(plasma, dcxdens + halodens, vi, beam_ion, rates)
                    states = states + rates

                    call colrad(plasma,beam_ion,vi,dt,states,denn,photons)
                    denf = mean_f(ienergy,ipitch)*dEdP
                    photons = photons/real(inputs%nphi_wght)
                    call store_fw_photons_at_chan(ichan, ienergy, ipitch, &
                         vp, vi, fields, dlength, sigma_pi, denf, photons)

                enddo
            enddo
        enddo
        !$OMP END PARALLEL DO

    enddo chan_loop

    fweight%mean_f = fweight%mean_f/(dEdP)

    if(inputs%verbose.ge.1) then
        write(*,*) 'write fida weights:    ' , time(time_start)
    endif

#ifdef _MPI
    call parallel_sum(fweight%weight)
    call parallel_sum(fweight%mean_f)
    if(my_rank().eq.0) call write_fida_weights()
#else
    call write_fida_weights()
#endif

end subroutine fida_weights_los

subroutine npa_weights
    !+ Calculates NPA weights
    type(LocalEMFields) :: fields
    type(NPAProbability) :: phit
    real(Float64) :: pitch
    real(Float64) :: pcxa
    integer(Int32) :: det
    integer(Int32) :: ii, jj, kk, i, ic   !!indices
    integer,dimension(1) :: ipitch
    real(Float64), dimension(3) :: vi,vi_norm
    real(Float64) :: vabs, fbm_denf, dE, dP
    real(Float64), dimension(nlevs) :: pcx   !! Rate coefficiants for CX
    real(Float64), dimension(nlevs) :: states, states_i  ! Density of n-states
    integer, dimension(5) :: neut_types=[1,2,3,4,5]
    real(Float64), dimension(3) :: pos,dpos,r_gyro
    integer(Int32) :: ichan
    real(Float64), dimension(:), allocatable :: ebarr, ptcharr

    !! define energy - array
    allocate(ebarr(inputs%ne_wght))
    do i=1,inputs%ne_wght
        ebarr(i)=real(i-0.5)*inputs%emax_wght/real(inputs%ne_wght)
    enddo
    dE=abs(ebarr(2)-ebarr(1))

    !! define pitch - array
    allocate(ptcharr(inputs%np_wght))
    do i=1,inputs%np_wght
        ptcharr(i)=real(i-0.5)*2./real(inputs%np_wght)-1.
    enddo
    dP=abs(ptcharr(2)-ptcharr(1))

    if(inputs%verbose.ge.1) then
        write(*,'(T3,"Number of Channels: ",i3)') npa_chords%nchan
        write(*,'(T3,"Nenergy: ",i3)') inputs%ne_wght
        write(*,'(T3,"Npitch: ",i3)') inputs%np_wght
        write(*,'(T3,"Maximum energy: ",f7.2)') inputs%emax_wght
        write(*,*) ''
    endif

    !! define storage arrays
    allocate(nweight%emissivity(beam_grid%nx, &
                                beam_grid%ny, &
                                beam_grid%nz, &
                                npa_chords%nchan))

    allocate(nweight%attenuation(inputs%ne_wght, &
                                 beam_grid%nx, &
                                 beam_grid%ny, &
                                 beam_grid%nz, &
                                 npa_chords%nchan))

    allocate(nweight%cx(inputs%ne_wght, &
                        beam_grid%nx, &
                        beam_grid%ny, &
                        beam_grid%nz, &
                        npa_chords%nchan))

    allocate(nweight%weight(inputs%ne_wght, &
                            inputs%np_wght, &
                            npa_chords%nchan))

    allocate(nweight%flux(inputs%ne_wght, npa_chords%nchan))

    nweight%emissivity = 0.d0
    nweight%attenuation = 0.d0
    nweight%cx = 0.d0
    nweight%weight = 0.d0
    nweight%flux = 0.d0

    loop_over_channels: do ichan=1,npa_chords%nchan
        !$OMP PARALLEL DO schedule(guided) collapse(3) private(ii,jj,kk,fields,phit,&
        !$OMP& ic,det,pos,dpos,r_gyro,pitch,ipitch,vabs,vi,pcx,pcxa,states,states_i,vi_norm,fbm_denf)
        loop_along_z: do kk=1,beam_grid%nz
            loop_along_y: do jj=1,beam_grid%ny
                loop_along_x: do ii=1,beam_grid%nx
                    phit = npa_chords%phit(ii,jj,kk,ichan)
                    if(phit%p.gt.0.d0) then
                        pos = [beam_grid%xc(ii), beam_grid%yc(jj), beam_grid%zc(kk)]
                        call get_fields(fields,pos=pos)
                        if(.not.fields%in_plasma) cycle loop_along_x

                        !!Check if it hits a detector just to make sure
                        dpos = phit%eff_rd
                        vi_norm = phit%dir
                        call hit_npa_detector(pos,vi_norm,det)
                        if (det.ne.ichan) then
                            if(inputs%verbose.ge.0) then
                                write(*,'(a)') 'NPA_WEIGHTS: Missed detector'
                            endif
                            cycle loop_along_x
                        endif

                        !! Determine the angle between the B-field and the Line of Sight
                        pitch = phit%pitch
                        ipitch=minloc(abs(ptcharr - pitch))
                        loop_over_energy: do ic = istart, inputs%ne_wght,istep !! energy loop
                            vabs = sqrt(ebarr(ic)/(v2_to_E_per_amu*inputs%ab))
                            vi = vi_norm*vabs
                            !!Correct for gyro orbit
                            call gyro_step(vi,fields,r_gyro)

                            fbm_denf=0
                            if (inputs%dist_type.eq.1) then
                                !get dist at guiding center
                                call get_ep_denf(ebarr(ic),pitch,fbm_denf,pos=(pos+r_gyro))
                            endif
                            if (fbm_denf.ne.fbm_denf) cycle loop_over_energy

                            !! -------------- calculate CX probability -------!!
                            call get_beam_cx_rate([ii,jj,kk],pos,vi,beam_ion,neut_types,pcx)
                            if(sum(pcx).le.0) cycle loop_over_energy

                            !!Calculate attenuation
                            states = pcx*1.0d14 !!needs to be large aribitrary number so colrad works
                            states_i=states
                            call attenuate(pos,dpos,vi,states)
                            pcxa=sum(states)/sum(states_i)

                            !$OMP CRITICAL(npa_wght)
                            nweight%attenuation(ic,ii,jj,kk,ichan) = pcxa
                            nweight%cx(ic,ii,jj,kk,ichan) = sum(pcx)
                            nweight%weight(ic,ipitch(1),ichan) = nweight%weight(ic,ipitch(1),ichan) + &
                                      2*sum(pcx)*pcxa*phit%p*beam_grid%dv/dP

                            nweight%flux(ic,ichan) = nweight%flux(ic,ichan) + &
                                      2*beam_grid%dv*fbm_denf*sum(pcx)*pcxa*phit%p
                                      !Factor of 2 above is to convert fbm to ions/(cm^3 dE (domega/4pi))
                            nweight%emissivity(ii,jj,kk,ichan)=nweight%emissivity(ii,jj,kk,ichan)+ &
                                      2*fbm_denf*sum(pcx)*pcxa*phit%p*dE
                            !$OMP END CRITICAL(npa_wght)
                        enddo loop_over_energy
                    endif
                enddo loop_along_x
            enddo loop_along_y
        enddo loop_along_z
        !$OMP END PARALLEL DO
    enddo loop_over_channels

#ifdef _MPI
    call parallel_sum(nweight%weight)
    call parallel_sum(nweight%flux)
    call parallel_sum(nweight%cx)
    call parallel_sum(nweight%attenuation)
    call parallel_sum(nweight%emissivity)
#endif

    do ichan=1,npa_chords%nchan
        if(inputs%verbose.ge.1) then
            write(*,'(T4,"Channel: ",i3)') ichan
            write(*,'(T4,"Radius: ",f10.3)') npa_chords%radius(ichan)
            write(*,'(T4,A,ES14.5)') 'Flux:   ',sum(nweight%flux(:,ichan))*dE
            write(*,'(T4,A,ES14.5)') 'Weight: ',sum(nweight%weight(:,:,ichan))*dE*dP
            write(*,*) ''
        endif
    enddo

    if(inputs%verbose.ge.1) then
        write(*,*) 'write npa weights:    ' , time(time_start)
    endif

#ifdef _MPI
    if(my_rank().eq.0) call write_npa_weights()
#else
    call write_npa_weights()
#endif

end subroutine npa_weights

end module libfida

!=============================================================================
!-------------------------------Main Program----------------------------------
!=============================================================================
program fidasim
    !+ FIDASIM {!../VERSION!}
    use libfida
    use hdf5_utils
#ifdef _OMP
    use omp_lib
#endif
#ifdef _MPI
    use mpi_utils
#endif
    implicit none
    character(3)          :: arg = ''
    integer               :: i,narg,nthreads,max_threads,seed

#ifdef _VERSION
    version = _VERSION
#endif

#ifdef _MPI
    call init_mpi()
    if(my_rank().eq.0) call print_banner()
#else
    call print_banner()
#endif

    narg = command_argument_count()
    if(narg.eq.0) then
#ifdef _MPI
        if(my_rank().eq.0) write(*,'(a)') "usage: mpirun -np [num_processes] ./fidasim namelist_file"
        call cleanup_mpi()
#else
        write(*,'(a)') "usage: ./fidasim namelist_file [num_threads]"
#endif
        stop
    else
        call get_command_argument(1,namelist_file)
    endif

    !! Check if compression is possible
    call check_compression_availability()

    !! measure time
    call date_and_time (values=time_start)

    call read_inputs()

#ifdef _OMP
    max_threads = OMP_get_num_procs()
    if(narg.ge.2) then
        call get_command_argument(2,arg)
        read(arg,'(i3)') nthreads
    else
        nthreads = max_threads
    endif
    max_threads = min(nthreads,max_threads)
    if(inputs%verbose.ge.1) then
        write(*,'(a)') "---- OpenMP settings ----"
        write(*,'(T2,"Number of threads: ",i2)') max_threads
        write(*,*) ''
    endif
    call OMP_set_num_threads(max_threads)
#else
    max_threads = 1
#endif

#ifdef _MPI
    istart = my_rank()+1
    istep = num_ranks()
    if(inputs%verbose.ge.1) then
        write(*,'(a)') "---- MPI settings ----"
        write(*,'(T2,"Number of processes: ",i3)') istep
        write(*,*) ''
    endif
#endif

    !! ----------------------------------------------------------
    !! ------ INITIALIZE THE RANDOM NUMBER GENERATOR  -----------
    !! ----------------------------------------------------------
    allocate(rng(max_threads))
#ifdef _OMP
    do i=1,max_threads
        if(inputs%seed.lt.0) then
            call rng_init(rng(i), inputs%seed)
        else
            call rng_init(rng(i), inputs%seed + i)
        endif
    enddo
#else
    call rng_init(rng(1), inputs%seed)
#endif
    if(inputs%verbose.ge.1) then
        write(*,'(a)') "---- Random Number Generator settings ----"
        write(*,'(T2,"RNG Seed: ",i10)') inputs%seed
        write(*,*) ''
    endif

    !! ----------------------------------------------------------
    !! ------- READ GRIDS, PROFILES, LOS, TABLES, & FBM --------
    !! ----------------------------------------------------------
    call read_tables()
    call read_equilibrium()
    call make_beam_grid()
    if(inputs%calc_beam.ge.1) call read_beam()
    call read_distribution()

    allocate(spec_chords%inter(beam_grid%nx,beam_grid%ny,beam_grid%nz))
    if((inputs%calc_spec.ge.1).or.(inputs%calc_fida_wght.ge.1)) then
        call read_chords()
    endif

    if((inputs%calc_npa.ge.1).or.(inputs%calc_npa_wght.ge.1).or.(inputs%calc_pnpa.ge.1)) then
        call read_npa()
    endif

    call make_diagnostic_grids()

    !! ----------------------------------------------------------
    !! --------------- ALLOCATE THE RESULT ARRAYS ---------------
    !! ----------------------------------------------------------
    !! neutral density array!
    allocate(neut%full(nlevs,beam_grid%nx,beam_grid%ny,beam_grid%nz))
    allocate(neut%half(nlevs,beam_grid%nx,beam_grid%ny,beam_grid%nz))
    allocate(neut%third(nlevs,beam_grid%nx,beam_grid%ny,beam_grid%nz))
    allocate(neut%dcx(nlevs,beam_grid%nx,beam_grid%ny,beam_grid%nz))
    allocate(neut%halo(nlevs,beam_grid%nx,beam_grid%ny,beam_grid%nz))
    neut%full = 0.d0
    neut%half = 0.d0
    neut%third = 0.d0
    neut%dcx = 0.d0
    neut%halo = 0.d0

    !! birth profile
    if(inputs%calc_birth.ge.1) then
        allocate(birth%dens(3, &
                            beam_grid%nx, &
                            beam_grid%ny, &
                            beam_grid%nz))
        allocate(birth%part(int(3*inputs%n_birth*inputs%n_nbi)))
    endif

    if(inputs%calc_spec.ge.1) then
        if(inputs%calc_brems.ge.1) then
            allocate(spec%brems(inputs%nlambda,spec_chords%nchan))
            spec%brems = 0.d0
        endif
        if(inputs%calc_bes.ge.1) then
            allocate(spec%full(inputs%nlambda,spec_chords%nchan))
            allocate(spec%half(inputs%nlambda,spec_chords%nchan))
            allocate(spec%third(inputs%nlambda,spec_chords%nchan))
            spec%full = 0.d0
            spec%half = 0.d0
            spec%third = 0.d0
        endif
        if(inputs%calc_dcx.ge.1) then
            allocate(spec%dcx(inputs%nlambda,spec_chords%nchan))
            spec%dcx = 0.d0
        endif
        if(inputs%calc_halo.ge.1) then
            allocate(spec%halo(inputs%nlambda,spec_chords%nchan))
            spec%halo = 0.d0
        endif
        if(inputs%calc_cold.ge.1) then
            allocate(spec%cold(inputs%nlambda,spec_chords%nchan))
            spec%cold = 0.d0
        endif
        if(inputs%calc_fida.ge.1) then
            allocate(spec%fida(inputs%nlambda,spec_chords%nchan,particles%nclass))
            spec%fida = 0.d0
        endif
        if(inputs%calc_pfida.ge.1) then
            allocate(spec%pfida(inputs%nlambda,spec_chords%nchan,particles%nclass))
            spec%pfida = 0.d0
        endif
    endif

    if(inputs%calc_npa.ge.1)then
        npa%nchan = npa_chords%nchan
        allocate(npa%part(npa%nmax))
        if(inputs%dist_type.eq.1) then
            npa%nenergy = fbm%nenergy
            allocate(npa%energy(npa%nenergy))
            npa%energy = fbm%energy
        else
            allocate(npa%energy(npa%nenergy))
            do i=1,npa%nenergy
                npa%energy(i)=real(i-0.5)
            enddo
        endif
        allocate(npa%flux(npa%nenergy,npa%nchan,particles%nclass))
        npa%flux = 0.0
    endif

    if(inputs%calc_pnpa.ge.1)then
        pnpa%nchan = npa_chords%nchan
        allocate(pnpa%part(pnpa%nmax))
        if(inputs%dist_type.eq.1) then
            pnpa%nenergy = fbm%nenergy
            allocate(pnpa%energy(pnpa%nenergy))
            pnpa%energy = fbm%energy
        else
            allocate(pnpa%energy(pnpa%nenergy))
            do i=1,pnpa%nenergy
                pnpa%energy(i)=real(i-0.5)
            enddo
        endif
        allocate(pnpa%flux(pnpa%nenergy,pnpa%nchan,particles%nclass))
        pnpa%flux = 0.0
    endif

    if(inputs%calc_neutron.ge.1)then
        allocate(neutron%rate(particles%nclass))
        neutron%rate = 0.d0
    endif

    !! -----------------------------------------------------------------------
    !! --------------- CALCULATE/LOAD the BEAM and HALO DENSITY---------------
    !! -----------------------------------------------------------------------
    if(inputs%load_neutrals.eq.1) then
        call read_neutrals()

        if(inputs%calc_bes.ge.1) then
            if(inputs%verbose.ge.1) then
                write(*,*) 'nbi:     ' , time(time_start)
            endif
            call nbi_spec()
            if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
        endif

        if(inputs%calc_dcx.ge.1) then
            if(inputs%verbose.ge.1) then
                write(*,*) 'dcx:     ' , time(time_start)
            endif
            call dcx_spec()
            if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
        endif

        if(inputs%calc_halo.ge.1) then
            if(inputs%verbose.ge.1) then
                write(*,*) 'halo:    ' , time(time_start)
            endif
            call halo_spec()
            if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
        endif
    else
        if(inputs%calc_beam.ge.1) then
            !! ----------- BEAM NEUTRALS ---------- !!
            if(inputs%calc_nbi_dens.ge.1) then
                if(inputs%verbose.ge.1) then
                    write(*,*) 'nbi:     ' , time(time_start)
                endif
                call ndmc
                if(inputs%verbose.ge.1) write(*,'(30X,a)') ''

                if(inputs%calc_birth.eq.1)then
                    if(inputs%verbose.ge.1) then
                        write(*,*) 'write birth:    ' , time(time_start)
                    endif
                    call write_birth_profile()
                    if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
                endif
            endif

            !! ---------- DCX (Direct charge exchange) ---------- !!
            if(inputs%calc_dcx_dens.ge.1) then
                if(inputs%verbose.ge.1) then
                    write(*,*) 'dcx:     ' , time(time_start)
                endif
                call dcx()
                if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
            endif

            !! ---------- HALO ---------- !!
            if(inputs%calc_halo_dens.ge.1) then
                if(inputs%verbose.ge.1) then
                    write(*,*) 'halo:    ' , time(time_start)
                endif
                call halo()
                if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
            endif

            !! ---------- WRITE NEUTRALS ---------- !!
            if(inputs%verbose.ge.1) then
                write(*,*) 'write neutrals:    ' , time(time_start)
            endif
#ifdef _MPI
            if(my_rank().eq.0) call write_neutrals()
#else
            call write_neutrals()
#endif
            if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
        endif
    endif

    !! -----------------------------------------------------------------------
    !!------------------------------ COLD D-ALPHA ----------------------------
    !! -----------------------------------------------------------------------
    if(inputs%calc_cold.ge.1) then
        if(inputs%verbose.ge.1) then
            write(*,*) 'cold:    ' ,time(time_start)
        endif
        call cold_spec()
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    !! -----------------------------------------------------------------------
    !!----------------------------- BREMSSTRAHLUNG ---------------------------
    !! -----------------------------------------------------------------------
    if(inputs%calc_brems.ge.1) then
        if(inputs%verbose.ge.1) then
            write(*,*) 'bremsstrahlung:    ' ,time(time_start)
        endif
        call bremsstrahlung()
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    !! -----------------------------------------------------------------------
    !! --------------------- CALCULATE the FIDA RADIATION --------------------
    !! -----------------------------------------------------------------------
    if(inputs%calc_fida.ge.1)then
        if(inputs%verbose.ge.1) then
            write(*,*) 'fida:    ' ,time(time_start)
        endif
        if(inputs%dist_type.eq.1) then
            call fida_f()
        else
            call fida_mc()
        endif
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    if(inputs%calc_pfida.ge.1)then
        if(inputs%verbose.ge.1) then
            write(*,*) 'pfida:   ' ,time(time_start)
        endif
        if(inputs%dist_type.eq.1) then
            call pfida_f()
        else
            call pfida_mc()
        endif
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    if(inputs%calc_spec.ge.1) then
        if(inputs%verbose.ge.1) then
            write(*,*) 'write spectra:    ' , time(time_start)
        endif
#ifdef _MPI
        if(my_rank().eq.0) call write_spectra()
#else
        call write_spectra()
#endif
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    !! -----------------------------------------------------------------------
    !! ----------------------- CALCULATE the NPA FLUX ------------------------
    !! -----------------------------------------------------------------------
    if(inputs%calc_npa.ge.1)then
        if(inputs%verbose.ge.1) then
            write(*,*) 'npa:     ' ,time(time_start)
        endif
        if(inputs%dist_type.eq.1) then
            call npa_f()
        else
            call npa_mc()
        endif
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    if(inputs%calc_pnpa.ge.1)then
        if(inputs%verbose.ge.1) then
            write(*,*) 'pnpa:     ' ,time(time_start)
        endif
        if(inputs%dist_type.eq.1) then
            call pnpa_f()
        else
            call pnpa_mc()
        endif
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    if((inputs%calc_npa.ge.1).or.(inputs%calc_pnpa.ge.1)) then
        if(inputs%verbose.ge.1) then
            write(*,*) 'write npa:    ' , time(time_start)
        endif
        call write_npa()
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    !! -------------------------------------------------------------------
    !! ------------------- Calculation of neutron flux -------------------
    !! -------------------------------------------------------------------
    if(inputs%calc_neutron.ge.1) then
        if(inputs%verbose.ge.1) then
            write(*,*) 'neutron rate:    ', time(time_start)
        endif
        if(inputs%dist_type.eq.1) then
            call neutron_f()
        else
            call neutron_mc()
        endif
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    !! -------------------------------------------------------------------
    !! ----------- Calculation of weight functions -----------------------
    !! -------------------------------------------------------------------
    if(inputs%calc_fida_wght.ge.1) then
        if(inputs%verbose.ge.1) then
            write(*,*) 'fida weight function:    ', time(time_start)
        endif
        if(inputs%calc_fida_wght.eq.1) then
            call fida_weights_los()
        else
            call fida_weights_mc()
        endif
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

    if(inputs%calc_npa_wght.ge.1) then
        if(inputs%verbose.ge.1) then
            write(*,*) 'npa weight function:    ', time(time_start)
        endif
        call npa_weights()
        if(inputs%verbose.ge.1) write(*,'(30X,a)') ''
    endif

#ifdef _MPI
    call cleanup_mpi()
#endif

    if(inputs%verbose.ge.1) then
        write(*,*) 'END: hour:minute:second ', time(time_start)
    endif

end program fidasim