This file contains the main routines for FIDASIM 1.3.4
!+ This file contains the main routines for FIDASIM {!../VERSION!} module libfida !+ Main FIDASIM library USE H5LT !! High level HDF5 Interface USE HDF5 !! Base HDF5 USE hdf5_extra !! Additional HDF5 routines USE eigensystem, ONLY : eigen, matinv USE utilities implicit none character(30) :: version = '' !+ FIDASIM version number 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 :: halo_type = 4 !+ Identifier for halo neutral interaction integer, parameter :: fida_type = 5 !+ Identifier for fida neutral interaction integer, parameter :: brems_type = 6 !+ Identifier for bremsstrahlung interaction. Acts as dummy type integer, parameter :: ntypes = 6 !+ 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.485799093287202d-4 !+ Atomic mass of an electron [amu] real(Float64), parameter :: H_1_amu = 1.00782504d0 !+ Atomic mass of Hydrogen-1 [amu] real(Float64), parameter :: H_2_amu = 2.0141017778d0 !+ Atomic mass of Hydrogen-2 [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.6605402d-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 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) :: colrad_threshold=1.d6 !+ colrad threshold 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]] 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 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 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 2D R-Z grid for interpolating plasma parameters and fields integer(Int32) :: nr !+ Number of Radii integer(Int32) :: nz !+ Number of Z values real(Float64) :: dr !+ Radial spacing [cm] real(Float64) :: dz !+ Vertical spacing [cm] real(Float64) :: da !+ Grid element area [\(cm^2\)] real(Float64), dimension(:), allocatable :: r !+ Radii values [cm] real(Float64), dimension(:), allocatable :: z !+ Z values [cm] real(Float64), dimension(:,:), allocatable :: r2d !+ 2D R grid [cm] real(Float64), dimension(:,:), allocatable :: z2d !+ 2D Z grid [cm] 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 end type Profiles type, extends( Profiles ) :: LocalProfiles !+ Plasma parameters at given position logical :: in_plasma = .False. !+ Indicates whether plasma parameters are valid/known logical :: machine_coords = .False. !+ Indicates whether vectors are in machine coordinates 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 type(InterpolCoeffs2D) :: c !+ Linear 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_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_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_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 logical :: machine_coords = .False. !+ Indicates whether vectors are in machine coordinates 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(InterpolCoeffs2D) :: c !+ Linear 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) 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 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) :: 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) :: 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 :: denf !+ Fast-ion density defined on the [[libfida:inter_grid]]: denf(R,Z) real(Float64), dimension(:,:,:,:), allocatable :: f !+ Fast-ion distribution function defined on the [[libfida:inter_grid]]: F(E,p,R,Z) end type FastIonDistribution type FastIon !+ Defines a fast-ion logical :: 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) :: z = 0.d0 !+ Vertical position of fast-ion [cm] real(Float64) :: 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 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 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 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]] 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 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 = 100 !+ 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 BirthProfile !+ Birth profile structure integer :: cnt = 1 !+ Particle counter integer, dimension(:), allocatable :: neut_type !+ Particle birth type (1=Full, 2=Half, 3=Third) real(Float64), dimension(:,:), allocatable :: ri !+ Particle birth position [cm] real(Float64), dimension(:,:), allocatable :: vi !+ Particle birth velocity [cm/s] integer, dimension(:,:), allocatable :: ind !+ Particle [[libfida:beam_grid]] indices 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 :: bes !+ Beam emission: bes(lambda,chan,neutral_type) real(Float64), dimension(:,:,:), allocatable :: fida !+ FIDA emission: fida(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) end type NeutronRate type NeutralDensity !+ Neutral density structure real(Float64), dimension(:,:,:,:,:), allocatable :: dens !+ Neutral density: dens(lev,neutral_type,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. !! Monte Carlo settings integer(Int64) :: n_fida !+ Number of FIDA mc markers integer(Int64) :: n_npa !+ Number of 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_brems !+ Calculate bremmstruhlung: 0 = off, 1=on integer(Int32) :: calc_bes !+ Calculate BES: 0 = off, 1=on integer(Int32) :: calc_fida !+ Calculate FIDA: 0 = off, 1=on integer(Int32) :: load_neutrals !+ Load neutrals from file: 0 = off, 1=on integer(Int32) :: calc_npa !+ Calculate 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 integer(Int32) :: no_flr !+ Turns off Finite Larmor Radius effects: 0=off, 1=on integer(Int32) :: dump_dcx !+ Output DCX density and spectra: 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 real(Float64), dimension(nlevs) :: dens = 0.d0 !+ Density [cm^-3] integer(Int32), dimension(3) :: ind = 0 !+ Indices of cell real(Float64), dimension(3) :: pos = 0.d0 !+ Midpoint of track in cell [cm] logical :: in_plasma = .False. !+ Indicates whether we are in the plasma 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 !+ 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]], and [[NPAParticle]] module procedure pp_assign, lpp_assign, plp_assign, lplp_assign, & ff_assign, lff_assign, flf_assign, lflf_assign, & fast_ion_assign,npa_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 linear interpolation coefficients module procedure interpol1D_coeff, interpol1D_coeff_arr module procedure interpol2D_coeff, interpol2D_coeff_arr end interface interface interpol !+ Performs linear/bilinear interpolation module procedure interpol1D_arr module procedure interpol2D_arr, interpol2D_2D_arr end interface interface store_neutrals module procedure store_neutrals_cell module procedure store_neutrals_track 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(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 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 #ifdef _OMP #else write(*,'(a)') "########################### ATTENTION ###########################" write(*,'(a)') "# OpenMP threading has been disabled #" write(*,'(a)') "#################################################################" write(*,'(a)') "" #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%cross_grid = p2%cross_grid p1%r = p2%r p1%z = p2%z p1%phi_enter = p2%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 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 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 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 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%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 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 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%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%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 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%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 integer :: calc_brems,calc_bes,calc_fida,calc_npa integer :: calc_birth,calc_fida_wght,calc_npa_wght integer :: load_neutrals,verbose,dump_dcx,no_flr integer(Int64) :: n_fida,n_npa,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_bes, calc_fida, calc_npa, calc_birth, no_flr, & calc_fida_wght, calc_npa_wght, load_neutrals, dump_dcx, verbose, & calc_neutron, n_fida,n_npa, 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 !!Set Defaults TODO: remove at next major release no_flr = 0 calc_neutron = 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 !!Simulation Switches if((calc_brems+calc_bes+calc_fida).gt.0) then inputs%calc_spec=1 else inputs%calc_spec=0 endif inputs%calc_brems=calc_brems inputs%calc_bes=calc_bes inputs%calc_fida=calc_fida inputs%calc_npa=calc_npa 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%dump_dcx=dump_dcx inputs%verbose=verbose inputs%no_flr = no_flr !!Monte Carlo Settings inputs%n_fida=max(10,n_fida) inputs%n_npa=max(10,n_npa) 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 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 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 write(*,'(a)') "MAKE_BEAM_GRID: Beam grid definition is poorly defined. & &Less than 10% of the beam grid cells fall within the plasma." stop endif end subroutine make_beam_grid 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) !!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), dimension(:,:,:), allocatable :: dlength real(Float64), dimension(:), allocatable :: spot_size, sigma_pi type(LOSElement), dimension(:), allocatable :: los_elem real(Float64) :: r0(3), v0(3), r_enter(3), r_exit(3) real(Float64) :: xyz_lens(3), xyz_axis(3), length real(Float64), dimension(3,3) :: basis real(Float64), dimension(2) :: randomu real(Float64) :: theta, sqrt_rho type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks character(len=20) :: system = '' integer :: i, j, ic, nc, ncell, ind(3), ii, jj, kk 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.0) then write(*,'(a)') 'FIDA/BES geometry is not in the geometry file' write(*,'(a)') 'Continuing without spectral diagnostics' endif inputs%calc_spec = 0 inputs%calc_fida = 0 inputs%calc_bes = 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(spot_size(spec_chords%nchan)) allocate(sigma_pi(spec_chords%nchan)) allocate(spec_chords%los(spec_chords%nchan)) allocate(spec_chords%radius(spec_chords%nchan)) allocate(dlength(beam_grid%nx, & beam_grid%ny, & beam_grid%nz) ) 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", spot_size, dims(2:2), error) call h5ltread_dataset_double_f(gid, "/spec/sigma_pi", 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)%sigma_pi = sigma_pi(i) spec_chords%los(i)%spot_size = spot_size(i) r0 = xyz_lens v0 = xyz_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.0) then WRITE(*,'("Channel ",i5," missed the beam grid")') i endif cycle chan_loop endif if(spot_size(i).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, ncell, 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) = spot_size(i)*sqrt_rho*cos(theta) r0(3) = spot_size(i)*sqrt_rho*sin(theta) r0 = matmul(basis,r0) + xyz_lens call grid_intersect(r0, v0, length, r_enter, r_exit) call track(r_enter, v0, tracks, ncell) track_loop: do j=1, ncell ind = tracks(j)%ind !inds can repeat so add rather than assign !$OMP CRITICAL(read_chords_1) dlength(ind(1),ind(2),ind(3)) = & dlength(ind(1),ind(2),ind(3)) + tracks(j)%time/real(nc) !time == distance !$OMP END CRITICAL(read_chords_1) 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 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, dlength(ii,jj,kk)) else allocate(los_elem(nc)) los_elem(1:(nc-1)) = spec_chords%inter(ii,jj,kk)%los_elem los_elem(nc) = LOSElement(i, dlength(ii,jj,kk)) 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 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,spot_size,sigma_pi) 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 integer, dimension(:), allocatable :: a_shape, d_shape character(len=20) :: system = '' real(Float64), parameter :: inv_4pi = (4.d0*pi)**(-1) 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) :: eff_rd, rd, rd_d, r0, r0_d, v0 real(Float64), dimension(3,3) :: basis, inv_basis real(Float64), dimension(50) :: xd, yd type(LocalEMFields) :: fields real(Float64) :: length,total_prob, hh, hw, dprob, dx, dy, r, pitch integer :: ichan,i,j,k,ix,iy,d_index,nd,cnt 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_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(a_shape(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(d_shape(npa_chords%nchan)) allocate(npa_chords%radius(npa_chords%nchan)) allocate(npa_chords%det(npa_chords%nchan)) 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. 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", a_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", d_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) ! Define detector/aperture shape npa_chords%det%detector%shape = d_shape npa_chords%det%aperture%shape = a_shape 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) v0 = xyz_a_cent - xyz_d_cent v0 = v0/norm2(v0) call grid_intersect(xyz_d_cent,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 cnt = 0 ! For each grid point find the probability of hitting the detector given an isotropic source !$OMP PARALLEL DO schedule(guided) collapse(3) private(i,j,k,ix,iy,total_prob,eff_rd,r0,r0_d, & !$OMP& rd_d,rd,d_index,v0,dprob,r,fields) do k=1,beam_grid%nz do j=1,beam_grid%ny do i=1,beam_grid%nx cnt = cnt+1 total_prob = 0.d0 eff_rd = eff_rd*0.d0 r0 = [beam_grid%xc(i),beam_grid%yc(j),beam_grid%zc(k)] r0_d = matmul(inv_basis,r0-xyz_d_cent) do ix = 1, nd do iy = 1, nd rd_d = [xd(ix),yd(iy),0.d0] rd = matmul(basis,rd_d) + xyz_d_cent 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_rd = eff_rd + dprob*rd total_prob = total_prob + dprob endif enddo !yd loop enddo !xd loop if(total_prob.gt.0.0) then eff_rd = eff_rd/total_prob 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 = total_prob 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 if(inputs%verbose.ge.2) then WRITE(*,'(T4,"Channel: ",i5," ",f7.2,"% completed",a,$)') & ichan, cnt/real(beam_grid%ngrid)*100,char(13) endif enddo !x loop enddo !y loop enddo !z loop !$OMP END PARALLEL DO total_prob = sum(npa_chords%phit(:,:,:,ichan)%p) if(total_prob.le.0.d0) then if(inputs%verbose.ge.0) then WRITE(*,'("Channel ",i3," missed the beam grid")') ichan endif cycle chan_loop endif endif enddo chan_loop if(inputs%verbose.ge.1) write(*,'(50X,a)') "" deallocate(a_shape,a_cent,a_redge,a_tedge) deallocate(d_shape,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(2) :: dims integer :: impc integer :: error integer, dimension(:,:), allocatable :: p_mask, f_mask !!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) allocate(inter_grid%r(inter_grid%nr),inter_grid%z(inter_grid%nz)) allocate(inter_grid%r2d(inter_grid%nr,inter_grid%nz)) allocate(inter_grid%z2d(inter_grid%nr,inter_grid%nz)) allocate(p_mask(inter_grid%nr,inter_grid%nz)) allocate(f_mask(inter_grid%nr,inter_grid%nz)) dims = [inter_grid%nr, inter_grid%nz] 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) call h5ltread_dataset_double_f(gid, "/plasma/r2d", inter_grid%r2d, dims, error) call h5ltread_dataset_double_f(gid, "/plasma/z2d", inter_grid%z2d, dims, error) 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(inputs%verbose.ge.1) then write(*,'(a)') '---- Interpolation grid settings ----' write(*,'(T2,"Nr: ",i3)') inter_grid%nr write(*,'(T2,"Nz: ",i3)') inter_grid%nz 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)) 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 !!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)) !!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, equil%fields%br, equil%fields%dbr_dr, equil%fields%dbr_dz) call deriv(inter_grid%r, inter_grid%z, equil%fields%bt, equil%fields%dbt_dr, equil%fields%dbt_dz) call deriv(inter_grid%r, inter_grid%z, equil%fields%bz, equil%fields%dbz_dr, equil%fields%dbz_dz) !!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)) 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 write(*,'(a)') "READ_EQUILIBRIUM: Plasma and/or fields are not well defined anywhere" 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(4) :: dims real(Float64) :: dummy(1), denp_tot integer :: ir 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) if((fbm%nr.ne.inter_grid%nr).or.(fbm%nz.ne.inter_grid%nz)) then if(inputs%verbose.ge.0) then write(*,'(a)') "READ_F: Distribution file has incompatable grid dimensions" endif stop endif allocate(fbm%energy(fbm%nenergy), fbm%pitch(fbm%npitch), fbm%r(fbm%nr), fbm%z(fbm%nz)) allocate(fbm%denf(fbm%nr, fbm%nz)) allocate(fbm%f(fbm%nenergy, fbm%npitch, fbm%nr, fbm%nz)) dims = [fbm%nenergy, fbm%npitch, fbm%nr, fbm%nz] 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 h5ltread_dataset_double_f(fid, "/denf",fbm%denf, dims(3:4), error) call h5ltread_dataset_double_f(fid, "/f", fbm%f, dims, error) 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)) dummy = minval(fbm%energy) fbm%emin = dummy(1) dummy = maxval(fbm%energy) fbm%emax = dummy(1) fbm%e_range = fbm%emax - fbm%emin dummy = minval(fbm%pitch) fbm%pmin = dummy(1) dummy = maxval(fbm%pitch) fbm%pmax = dummy(1) fbm%p_range = fbm%pmax - fbm%pmin denp_tot = 0.0 do ir=1,fbm%nr fbm%n_tot = fbm%n_tot + 2*pi*fbm%dr*fbm%dz*sum(fbm%denf(ir,:))*fbm%r(ir) denp_tot = denp_tot + 2*pi*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 write(*,'(T2,"Distribution type: ",a)') "Fast-ion Density Function F(energy,pitch,R,Z)" write(*,'(T2,"Nenergy = ",i3)') fbm%nenergy write(*,'(T2,"Npitch = ",i3)') fbm%npitch 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,"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 real(Float64) :: phi,phi_enter,phi_exit,delta_phi real(Float64), dimension(3) :: uvw,ri,vi,e1_xyz,e2_xyz,C_xyz,dum integer(Int32), dimension(1) :: minpos real(Float64), dimension(:), allocatable :: weight type(LocalEMFields) :: fields integer :: cnt,num logical :: inp character(len=32) :: 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) call h5ltread_dataset_int_scalar_f(fid, "/nclass", particles%nclass, 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 h5ltread_dataset_int_f(fid, "/class", particles%fast_ion%class, dims, 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 then the number of classes' endif stop endif if(inputs%dist_type.eq.2) then dist_type_name = "Guiding Center Monte Carlo" 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 dist_type_name = "Full Orbit Monte Carlo" 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,minpos,fields,uvw,phi,ri,vi, & !$OMP& delta_phi,phi_enter,phi_exit,C_xyz) 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 uvw = [particles%fast_ion(i)%r, 0.d0, particles%fast_ion(i)%z] call in_plasma(uvw,inp,machine_coords=.True.) if(.not.inp) cycle particle_loop phi_enter = 0.0 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,phi_enter,phi_exit) delta_phi = phi_exit-phi_enter if(delta_phi.gt.0) then particles%fast_ion(i)%cross_grid = .True. else particles%fast_ion(i)%cross_grid = .False. delta_phi = 2*pi endif particles%fast_ion(i)%phi_enter = phi_enter particles%fast_ion(i)%delta_phi = delta_phi particles%fast_ion(i)%weight = weight(i)*(delta_phi/(2*pi))/beam_grid%dv minpos = minloc(abs(inter_grid%r - particles%fast_ion(i)%r)) ir = minpos(1) minpos = minloc(abs(inter_grid%z - particles%fast_ion(i)%z)) iz = minpos(1) !$OMP CRITICAL(mc_denf) equil%plasma(ir,iz)%denf = equil%plasma(ir,iz)%denf + weight(i) / & (2*pi*particles%fast_ion(i)%r*inter_grid%da) !$OMP END CRITICAL(mc_denf) cnt=cnt+1 enddo particle_loop !$OMP END PARALLEL DO num = count(particles%fast_ion%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: ",i9)') 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, npart character(charlim) :: filename real(Float64), dimension(:,:), allocatable :: ri real(Float64), dimension(:,:), allocatable :: vi real(Float64), dimension(3) :: xyz,uvw,v_uvw npart = birth%cnt-1 allocate(ri(3,npart)) allocate(vi(3,npart)) do i=1,npart ! Convert position to rzphi xyz = birth%ri(:,i) 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 rzphi v_uvw = matmul(beam_grid%basis, birth%vi(:,i)) 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)) enddo filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_birth.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) 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", 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, birth%ind, error) call h5ltmake_compressed_dataset_int_f(fid,"/type", 1, dim2(2:2), birth%neut_type, 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", "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, "/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) deallocate(ri,vi) if(inputs%verbose.ge.1) then write(*,'(T4,a,a)') 'birth profile written to: ',trim(filename) endif end subroutine write_birth_profile subroutine write_dcx !+ Writes the direct charge exchange (DCX) neutrals and spectra 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 character(15) :: spec_str integer :: i real(Float64), dimension(:), allocatable :: lambda_arr real(Float64), dimension(:,:), allocatable :: dcx_spec filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_dcx.h5" spec_str = "" if(inputs%calc_spec.ge.1) then spec_str = " spectra and" allocate(lambda_arr(inputs%nlambda)) do i=1,inputs%nlambda lambda_arr(i) = (i-0.5)*inputs%dlambda + inputs%lambdamin ! [nm] enddo allocate(dcx_spec(inputs%nlambda,spec_chords%nchan)) !! convert [Ph/(s*wavel_bin*cm^2*all_directions)] to [Ph/(s*nm*sr*m^2)]! dcx_spec = spec%bes(:,:,halo_type)/(inputs%dlambda)/(4.d0*pi)*1.d4 endif !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,"/nlevel", 0, d, [nlevs], error) dims = [nlevs, beam_grid%nx, beam_grid%ny, beam_grid%nz ] call h5ltmake_compressed_dataset_double_f(fid, "/dens", 4, dims, & neut%dens(:,halo_type,:,:,:), error) if(inputs%calc_spec.ge.1) then 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 call h5ltmake_compressed_dataset_double_f(fid, "/spec", 2, dims(1:2), & dcx_spec, error) 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) endif !Add attributes call h5ltset_attribute_string_f(fid,"/nlevel","description", & "Number of atomic energy levels", error) call h5ltset_attribute_string_f(fid,"/dens", "description", & "Direct Charge Exchange (DCX) neutral density: dcx(level,x,y,z)", error) call h5ltset_attribute_string_f(fid,"/dens","units","neutrals*cm^-3", error) if(inputs%calc_spec.ge.1) then 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,"/spec","description", & "Direct Charge Exchange (DCX) beam emission: spec(lambda, chan)", error) call h5ltset_attribute_string_f(fid,"/spec","units","Ph/(s*nm*sr*m^2)",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) endif call h5ltset_attribute_string_f(fid, "/", "version", version, error) call h5ltset_attribute_string_f(fid,"/","description", & "Direct Charge Exchange (DCX)"//trim(spec_str)//" neutral density calculated by FIDASIM", error) !Close file call h5fclose_f(fid, error) !Close HDF5 interface call h5close_f(error) if(inputs%calc_spec.ge.1) then deallocate(dcx_spec,lambda_arr) endif if(inputs%verbose.ge.1) then write(*,'(T4,a,a)') 'dcx written to: ',trim(filename) endif end subroutine write_dcx 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 h5ltmake_compressed_dataset_double_f(fid, "/fdens", 4, dims, & neut%dens(:,nbif_type,:,:,:), error) call h5ltmake_compressed_dataset_double_f(fid, "/hdens", 4, dims, & neut%dens(:,nbih_type,:,:,:), error) call h5ltmake_compressed_dataset_double_f(fid, "/tdens", 4, dims, & neut%dens(:,nbit_type,:,:,:), error) call h5ltmake_compressed_dataset_double_f(fid, "/halodens", 4, dims, & neut%dens(:,halo_type,:,:,:), error) !Write attributes call h5ltset_attribute_string_f(fid,"/nlevel","description", & "Number of atomic energy levels", 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,"/fdens","units","neutrals*cm^-3",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) call h5ltset_attribute_string_f(fid,"/halodens","description", & "Neutral density of the beam halo(including dcx): halodens(level,x,y,z)", error) call h5ltset_attribute_string_f(fid,"/halodens","units","neutrals*cm^-3",error) 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 integer :: i, n character(charlim) :: filename = '' allocate(dcount(npa_chords%nchan)) do i=1,npa_chords%nchan dcount(i) = count(npa%part%detector.eq.i) enddo filename=trim(adjustl(inputs%result_dir))//"/"//trim(adjustl(inputs%runid))//"_npa.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 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", & "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", & "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) deallocate(dcount) if((npa%npart.ne.0).and.(inputs%calc_npa.ge.2)) then n = npa%npart allocate(ri(3,n),rf(3,n)) ri(1,:) = npa%part(1:n)%xi ri(2,:) = npa%part(1:n)%yi ri(3,:) = npa%part(1:n)%zi rf(1,:) = npa%part(1:n)%xf rf(2,:) = npa%part(1:n)%yf rf(3,:) = npa%part(1:n)%zf !Create Group call h5gcreate_f(fid,"/particles",gid, error) call h5ltmake_dataset_int_f(gid, "nparticle", 0, d, [npa%npart], error) d(1) = npa%npart dim2 = [3, n] 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, & npa%part(1:n)%pitch, error) call h5ltmake_compressed_dataset_double_f(gid,"energy",1,d,& npa%part(1:n)%energy, error) call h5ltmake_compressed_dataset_double_f(gid,"weight",1,d,& npa%part(1:n)%weight, error) call h5ltmake_compressed_dataset_int_f(gid,"detector",1,d,& npa%part(1:n)%detector, 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(fid,"/particles","coordinate_system", & "Right-handed cartesian",error) call h5ltset_attribute_string_f(fid,"/particles","description", & "Monte Carlo particles",error) !Close group call h5gclose_f(gid, error) deallocate(ri,rf) 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 data written to: ',trim(filename) 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), 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)]! spec%brems=spec%brems/(inputs%dlambda)/(4.d0*pi)*1.d4 spec%bes=spec%bes/(inputs%dlambda)/(4.d0*pi)*1.d4 spec%fida=spec%fida/(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 !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 !Write variables call h5ltmake_compressed_dataset_double_f(fid, "/full", 2, dims(1:2), & spec%bes(:,:,nbif_type), error) call h5ltmake_compressed_dataset_double_f(fid, "/half", 2, dims(1:2), & spec%bes(:,:,nbih_type), error) call h5ltmake_compressed_dataset_double_f(fid, "/third", 2, dims(1:2),& spec%bes(:,:,nbit_type), error) call h5ltmake_compressed_dataset_double_f(fid, "/halo", 2, dims(1:2), & spec%bes(:,:,halo_type), 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 ) call h5ltset_attribute_string_f(fid,"/halo","description", & "Halo component of the beam emmision (includes dcx): halo(lambda,chan)", error) call h5ltset_attribute_string_f(fid,"/halo","units","Ph/(s*nm*sr*m^2)",error ) endif if(inputs%calc_fida.ge.1) then !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", & "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", & "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 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(4) :: dim4 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) 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) dim4 = shape(neutron%weight) call h5ltmake_compressed_dataset_double_f(fid, "/weight", 4, dim4, neutron%weight, error) call h5ltmake_compressed_dataset_double_f(fid,"/energy", 1, dim4(1:1), fbm%energy, error) call h5ltmake_compressed_dataset_double_f(fid,"/pitch", 1, dim4(2:2), fbm%pitch, error) call h5ltmake_compressed_dataset_double_f(fid,"/r", 1, dim4(3:3), fbm%r, error) call h5ltmake_compressed_dataset_double_f(fid,"/z", 1, dim4(4:4), fbm%z, 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), 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,"/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 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) 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 stop endif dims = [nlevs, nx, ny, nz] call h5ltread_dataset_double_f(fid,"/fdens", & neut%dens(:,nbif_type,:,:,:), dims, error) call h5ltread_dataset_double_f(fid,"/hdens", & neut%dens(:,nbih_type,:,:,:), dims, error) call h5ltread_dataset_double_f(fid,"/tdens", & neut%dens(:,nbit_type,:,:,:), dims, error) call h5ltread_dataset_double_f(fid,"/halodens", & neut%dens(:,halo_type,:,:,:), dims, error) !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 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, bin_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 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) bin_gs = .False. 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 gyrange = 0.d0 if((ninter.eq.0).and.(.not.bin_gs)) 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 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 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 grid_intersect(r0, v0, length, r_enter, r_exit, center_in, lwh_in) !+ 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 [[libfida:beam_grid]] real(Float64), dimension(3), intent(out) :: r_exit !+ Point where particle exits [[libfida:beam_grid]] 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] real(Float64), dimension(3,6) :: ipnts real(Float64), dimension(3) :: 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 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 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 subroutine circle_grid_intersect(r0, e1, e2, radius, phi_enter, 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) :: phi_enter !+ Phi value where the circle entered the [[libfida:beam_grid]] [rad] real(Float64), intent(out) :: 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 phi_enter = 0.d0 phi_exit = 0.d0 if (count(inter).gt.2) return if(any(inter)) then phi_enter = minval(phi,inter) phi_exit = maxval(phi,inter) if(r0_ing.and.any(count(inter,1).ge.2)) then if((phi_exit - phi_enter) .lt. pi) then tmp = phi_enter phi_enter = phi_exit phi_exit = tmp + 2*pi endif else if((phi_exit - phi_enter) .gt. pi) then tmp = phi_enter phi_enter = phi_exit phi_exit = tmp + 2*pi endif endif if(approx_eq(phi_exit-phi_enter,pi,tol).and.r0_ing) then phi_enter = 0.0 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 phi_enter = 0.d0 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_position(ind, pos) !+ Get position `pos` given [[libfida:beam_grid]] indices `ind` integer(Int32), dimension(3), intent(in) :: ind !+ [[libfida:beam_grid]] indices real(Float64), dimension(3), intent(out) :: pos !+ Position [cm] pos(1) = beam_grid%xc(ind(1)) pos(2) = beam_grid%yc(ind(2)) pos(3) = beam_grid%zc(ind(3)) end subroutine get_position subroutine track(rin, vin, tracks, ncell, 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) :: ncell !+ 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, ii, mind 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 real(Float64), dimension(3) :: ri, ri_tmp, ri_cell integer, dimension(3) :: sgn integer, dimension(3) :: gdims integer, dimension(1) :: minpos vn = vin ; ri = rin ; sgn = 0 ; ncell = 0 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 los_inter = .False. tracks%time = 0.d0 tracks%flux = 0.d0 call in_plasma(ri,in_plasma1) track_loop: do i=1,beam_grid%ntrack if(cc.gt.beam_grid%ntrack) exit track_loop if((spec_chords%inter(ind(1),ind(2),ind(3))%nchan.ne.0) & .and.(.not.los_inter))then los_inter = .True. endif dt_arr = abs(( (ri_cell + 0.5*dr) - ri)*inv_vn) minpos = minloc(dt_arr) mind = minpos(1) dT = dt_arr(mind) ri_tmp = ri + dT*vn 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)%in_plasma = in_plasma2 tracks(cc+1)%in_plasma = .not.in_plasma2 tracks(cc+1)%pos = ri + 0.5*(dt1 + dT)*vn 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 else tracks(cc)%in_plasma = in_plasma2 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 enddo track_loop ncell = cc-1 if(present(los_intersect)) then los_intersect = los_inter endif end subroutine track !============================================================================ !---------------------------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 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 !============================================================================= !-------------------------Profiles and Fields Routines------------------------ !============================================================================= subroutine in_plasma(xyz, inp, machine_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 logical, intent(in), optional :: machine_coords !+ Indicates that xyz is in machine coordinates type(InterpolCoeffs2D), intent(out), optional :: coeffs !+ Linear Interpolation coefficients used in calculation real(Float64), dimension(3), intent(out), optional :: uvw_out !+ Position in machine coordinates real(Float64), dimension(3) :: uvw type(InterpolCoeffs2D) :: c real(Float64) :: R, W, mask logical :: mc integer :: i, j, err err = 1 mc = .False. if(present(machine_coords)) mc = machine_coords if(mc) then uvw = xyz else !! Convert to machine coordinates call xyz_to_uvw(xyz,uvw) endif R = sqrt(uvw(1)*uvw(1) + uvw(2)*uvw(2)) W = uvw(3) !! Interpolate mask value call interpol_coeff(inter_grid%r, inter_grid%z, R, W, c, err) inp = .False. if(err.eq.0) then i = c%i j = c%j mask = c%b11*equil%mask(i,j) + c%b12*equil%mask(i,j+1) + & c%b21*equil%mask(i+1,j) + c%b22*equil%mask(i+1,j+1) if((mask.ge.0.5).and.(err.eq.0)) then inp = .True. endif endif if(present(coeffs)) coeffs = c if(present(uvw_out)) uvw_out = uvw end subroutine in_plasma subroutine get_plasma(plasma, pos, ind) !+ 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 logical :: inp type(InterpolCoeffs2D) :: coeffs real(Float64), dimension(3) :: xyz, uvw, vrot_uvw real(Float64) :: phi, s, c integer :: i, j plasma%in_plasma = .False. if(present(ind)) call get_position(ind,xyz) if(present(pos)) xyz = pos call in_plasma(xyz,inp,.False.,coeffs,uvw) if(inp) then phi = atan2(uvw(2),uvw(1)) i = coeffs%i j = coeffs%j plasma = coeffs%b11*equil%plasma(i,j) + coeffs%b12*equil%plasma(i,j+1) + & coeffs%b21*equil%plasma(i+1,j) + coeffs%b22*equil%plasma(i+1,j+1) 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 plasma%vrot = matmul(beam_grid%inv_basis,vrot_uvw) plasma%pos = xyz plasma%uvw = uvw plasma%in_plasma = .True. plasma%c = 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, machine_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 logical, intent(in), optional :: machine_coords !+ Indicates that pos is machine coordinates logical :: inp, mc 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(InterpolCoeffs2D) :: coeffs integer :: i, j fields%in_plasma = .False. if(present(ind)) call get_position(ind,xyz) if(present(pos)) xyz = pos mc = .False. if(present(machine_coords)) mc = machine_coords call in_plasma(xyz,inp,mc,coeffs,uvw) if(inp) then phi = atan2(uvw(2),uvw(1)) i = coeffs%i j = coeffs%j fields = coeffs%b11*equil%fields(i,j) + coeffs%b12*equil%fields(i,j+1) + & coeffs%b21*equil%fields(i+1,j) + coeffs%b22*equil%fields(i+1,j+1) 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(mc) then xyz_bfield = uvw_bfield xyz_efield = uvw_efield else !Represent fields in beam grid coordinates xyz_bfield = matmul(beam_grid%inv_basis,uvw_bfield) xyz_efield = matmul(beam_grid%inv_basis,uvw_efield) 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%pos = xyz fields%uvw = uvw fields%in_plasma = .True. fields%machine_coords = mc fields%c = 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(InterpolCoeffs2D), intent(in), optional :: coeffs !+ Precomputed Linear Interpolation Coefficients real(Float64), dimension(3) :: xyz, uvw real(Float64) :: R, Z integer :: err if(present(coeffs)) then call interpol(fbm%r, fbm%z, fbm%f, R, Z, fbeam, err, coeffs) call interpol(fbm%r, fbm%z, fbm%denf, R, Z, 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) call interpol(fbm%r, fbm%z, fbm%f, R, Z, fbeam, err) call interpol(fbm%r, fbm%z, fbm%denf, R, Z, 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(InterpolCoeffs2D), intent(in), optional :: coeffs !+ Precomputed Linear Interpolation Coefficients real(Float64), dimension(3) :: xyz, uvw real(Float64), dimension(fbm%nenergy,fbm%npitch) :: fbeam integer(Int32), dimension(2) :: epi integer(Int32), dimension(1) :: dummy real(Float64) :: R, Z real(Float64) :: dE, dp integer :: err dummy = minloc(abs(fbm%energy - energy)) epi(1) = dummy(1) dummy = minloc(abs(fbm%pitch - pitch)) epi(2) = dummy(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, fbm%f, R, Z, 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) call interpol(inter_grid%r, inter_grid%z, fbm%f, R, Z, 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_cell(ind, neut_type, dens, store_iter) !Store neutrals in [[libfida:neut]] at indices `ind` integer(Int32), dimension(3), intent(in) :: ind !+ [[libfida:beam_grid]] indices integer, value :: neut_type !+ Neutral type real(Float64), dimension(:), intent(in) :: dens !+ Neutral density [neutrals/cm^3] logical, intent(in), optional :: store_iter !+ Store DCX/Halo iteration density in [[libfida:halo_iter_dens]] logical :: iter if(present(store_iter)) then iter = store_iter else iter = .False. endif !$OMP CRITICAL(store_neutrals_1) if(iter) halo_iter_dens(neut_type) = halo_iter_dens(neut_type) + sum(dens) neut%dens(:,neut_type,ind(1),ind(2),ind(3)) = & neut%dens(:,neut_type,ind(1),ind(2),ind(3))+dens ![neutrals/cm^3] !$OMP END CRITICAL(store_neutrals_1) end subroutine store_neutrals_cell subroutine store_neutrals_track(tracks, ncell, neut_type) !Store neutrals in [[libfida:neut]] from track type(ParticleTrack), dimension(:), intent(in) :: tracks !+ Neutral Particle Track integer, intent(in) :: ncell !+ Number of cell in the particle track integer, value :: neut_type !+ Neutral type integer :: n,i1,i2,i3 !$OMP CRITICAL(store_neutrals_m) do n=1,ncell i1 = tracks(n)%ind(1) i2 = tracks(n)%ind(2) i3 = tracks(n)%ind(3) neut%dens(:,neut_type,i1,i2,i3) = & neut%dens(:,neut_type,i1,i2,i3)+tracks(n)%dens ![neutrals/cm^3] if(tracks(n)%in_plasma) then halo_iter_dens(neut_type) = halo_iter_dens(neut_type) + sum(tracks(n)%dens) endif enddo !$OMP END CRITICAL(store_neutrals_m) end subroutine store_neutrals_track 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 CRITICAL(store_births_1) birth%dens( neut_type,ind(1),ind(2),ind(3))= & birth%dens(neut_type,ind(1),ind(2),ind(3)) + dflux !$OMP END CRITICAL(store_births_1) end subroutine store_births subroutine store_npa(det, ri, rf, vn, flux, orbit_class) !+ 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 integer :: iclass 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 if(present(orbit_class)) then iclass = orbit_class else iclass = 1 endif ! 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) dE = npa%energy(2)-npa%energy(1) ! 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 !$OMP CRITICAL(store_npa_1) 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)%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_1) 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 real(Float64) :: mullog10 = log(10.0d0) !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*mullog10) 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 real(Float64) :: mullog10 = log(10.0d0) 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*mullog10) !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 real(Float64) :: mullog10 = log(10.0d0) 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*mullog10) endif end subroutine get_neutron_rate subroutine get_beam_cx_rate(ind, pos, v_ion, i_type, types, prob) !+ 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) :: prob !+ Charge exchange rate/probability [1/s] integer :: ntypes, i, 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) ntypes = size(types) prob = 0 do i=1,ntypes if((types(i).le.3).and.(types(i).ne.0)) then ! CX with full type'th energy NBI neutrals denn = neut%dens(:,types(i),ind(1),ind(2),ind(3)) vn = vnbi/sqrt(real(types(i))) call bb_cx_rates(denn,v_ion,vn,rates) prob = prob+rates else call get_plasma(plasma,pos=pos) denn = neut%dens(:,types(i),ind(1),ind(2),ind(3)) call bt_cx_rates(plasma, denn, v_ion, i_type, rates) prob = prob + rates endif 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 real(Float64) :: mullog10 = log(10.0d0) 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 denp = 0.d0 endif 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*mullog10) 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*mullog10) end where !!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 dene = 0.d0 endif 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*mullog10) 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*mullog10) end where !!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 denimp = 0.d0 endif 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*mullog10) 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*mullog10) end where 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, eigvec_inv 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(iflux.lt.colrad_threshold .and. inputs%calc_npa.eq.0)then return endif 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 matinv(eigvec, eigvec_inv) coef = matmul(eigvec_inv, states)!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) if ((minval(states).lt.0).or.(minval(dens).lt.0)) then do n=1,nlevs if(states(n).lt.0) states(n)=0.d0 if(dens(n).lt.0) dens(n)=0.d0 enddo endif 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 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 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) enddo end subroutine attenuate subroutine spectrum(vecp, vi, fields, sigma_pi, photons, dlength, lambda, intensity) !+ Calculates doppler shift and stark splitting 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_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) real(Float64), dimension(n_stark) :: lambda, intensity real(Float64) :: dlength, sigma_pi type(LocalEMFields) :: fields integer(Int32), dimension(3) :: ind real(Float64), dimension(3) :: vp type(LOSInters) :: inter integer :: ichan,i,j,bin,nchan 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 j=1,nchan ichan = inter%los_elem(j)%id dlength = inter%los_elem(j)%length sigma_pi = spec_chords%los(ichan)%sigma_pi vp = pos - spec_chords%los(ichan)%lens 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 CRITICAL(bes_spectrum) spec%bes(bin,ichan,neut_type)= & spec%bes(bin,ichan,neut_type) + intensity(i) !$OMP END CRITICAL(bes_spectrum) enddo loop_over_stark enddo loop_over_channels end subroutine store_bes_photons subroutine store_fida_photons(pos, vi, photons, orbit_class) !+ 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 real(Float64), dimension(n_stark) :: lambda, intensity real(Float64) :: dlength, sigma_pi type(LocalEMFields) :: fields integer(Int32), dimension(3) :: ind real(Float64), dimension(3) :: vp type(LOSInters) :: inter integer :: ichan, i, j, bin, iclass, nchan if(present(orbit_class)) then iclass = orbit_class else iclass = 1 endif 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 j=1,nchan ichan = inter%los_elem(j)%id dlength = inter%los_elem(j)%length sigma_pi = spec_chords%los(ichan)%sigma_pi vp = pos - spec_chords%los(ichan)%lens 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 CRITICAL(fida_spectrum) spec%fida(bin,ichan,iclass)= & spec%fida(bin,ichan,iclass) + intensity(i) !$OMP END CRITICAL(fida_spectrum) enddo loop_over_stark enddo loop_over_channels 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 = orbit_class else iclass = 1 endif !$OMP CRITICAL(neutron_rate) neutron%rate(iclass)= neutron%rate(iclass) + rate !$OMP END CRITICAL(neutron_rate) 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,papprox_tot,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(:,:,:), intent(in) :: papprox !+ [[libfida:beam_grid]] cell weights real(Float64), intent(in) :: papprox_tot !+ Total cell weights real(Float64), dimension(:,:,:), intent(out) :: nlaunch !+ Number of mc markers to launch for each cell: nlaunch(x,y,z) integer :: i, j, k nlaunch = nr_markers*papprox/sum(papprox) where ((nlaunch.gt.0.0).and.(nlaunch.lt.5.0)) nlaunch = 5.0 endwhere nlaunch = floor(nlaunch) end subroutine get_nlaunch 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, rg_r, vpar, term1, term2 if(inputs%no_flr.eq.0) then 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 !! Second order correction approximation derived from !! 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 uvw = fields%uvw R = sqrt(uvw(1)**2 + uvw(2)**2) phi = atan2(uvw(2),uvw(1)) if(fields%machine_coords) then rg_uvw = r_gyro else rg_uvw = matmul(beam_grid%basis,r_gyro) endif rg_r = rg_uvw(1)*cos(phi) + rg_uvw(2)*sin(phi) 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) = -fields%dbt_dz/fields%b_abs cuvrxb(2) = (fields%dbr_dz - fields%dbz_dr)/fields%b_abs cuvrxb(3) = fields%dbt_dr/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) = 0.0 grad_B(3) = (fields%br*fields%dbr_dz + fields%bt * fields%dbt_dz + fields%bz*fields%dbz_dz)/& fields%b_abs rg_rtz(1) = rg_uvw(1)*cos(phi) + rg_uvw(2)*sin(phi) rg_rtz(2) = 0.0 rg_rtz(3) = rg_uvw(3) term2 = -1.0 / (2.0 * fields%b_abs)*dot_product(rg_rtz,grad_B) r_gyro = r_gyro * (1.0 - term1 - term2) if (1.0 - term1 - term2 .le. 0.0) then write(*,*) 'GYRO_STEP: Gyro correction results in negative distances: ', & 1.0-term1-term2 stop endif else r_gyro = 0.d0 endif end subroutine gyro_step subroutine gyro_correction(fields, energy, pitch, rp, vp, phi_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 :: phi_in !+ Gyro-angle real(Float64), dimension(3) :: vi_norm, r_step real(Float64), dimension(1) :: randomu real(Float64) :: vabs, phi vabs = sqrt(energy/(v2_to_E_per_amu*inputs%ab)) if(present(phi_in)) then phi = phi_in else !! Sample gyroangle call randu(randomu) phi = 2*pi*randomu(1) endif !! Calculate velocity vector call pitch_to_vec(pitch, phi, 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%c) 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_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 !============================================================================= !------------------------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 :: ncell type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks integer(Int64), dimension(3) :: nl_birth type(LocalProfiles) :: plasma real(Float64), dimension(nlevs) :: states, dens real(Float64) :: photons, iflux, r_nlaunch integer(Int32), dimension(3) :: ind real(Float64), dimension(1) :: randomu integer, dimension(1) :: randi logical :: err if(inputs%verbose.ge.1) then write(*,'(T6,"# of markers: ",i9)') inputs%n_nbi 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) r_nlaunch = 1.d0/nlaunch cnt = 0 !$OMP PARALLEL DO schedule(guided) & !$OMP& private(vnbi,rnbi,tracks,ncell,plasma,nl_birth,randi, & !$OMP& states,dens,iflux,photons,neut_type,jj,ii,kk,ind,err) loop_over_markers: do ii=1,inputs%n_nbi if(inputs%calc_birth.ge.1) then !! Determine the type of birth particle (1, 2, or 3) nl_birth = 0 do kk=1,inputs%n_birth call randind(nbi%current_fractions,randi) nl_birth(randi(1)) = nl_birth(randi(1)) + 1 enddo endif 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,ncell) if(ncell.eq.0) cycle energy_fractions !! Solve collisional radiative model along track states=0.d0 states(1)=nneutrals*nbi%current_fractions(neut_type)/beam_grid%dv loop_along_track: do jj=1,ncell 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) tracks(jj)%dens = dens*r_nlaunch tracks(jj)%flux = (iflux - sum(states))*beam_grid%dv*r_nlaunch 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*r_nlaunch,neut_type) endif enddo loop_along_track call store_neutrals(tracks, ncell, neut_type) if(inputs%calc_birth.ge.1) then !! Sample according to deposited flux along neutral trajectory !$OMP CRITICAL(ndmc_birth) do kk=1,nl_birth(neut_type) call randind(tracks(1:ncell)%flux,randi) call randu(randomu) birth%neut_type(birth%cnt) = neut_type birth%ind(:,birth%cnt) = tracks(randi(1))%ind birth%vi(:,birth%cnt) = vnbi birth%ri(:,birth%cnt) = tracks(randi(1))%pos + & vnbi*(tracks(randi(1))%time*(randomu(1)-0.5)) birth%cnt = birth%cnt+1 enddo !$OMP END CRITICAL(ndmc_birth) endif enddo energy_fractions if (inputs%verbose.ge.2)then cnt = cnt + 1 WRITE(*,'(f7.2,"% completed",a,$)') 100*cnt/nlaunch,char(13) endif enddo loop_over_markers !$OMP END PARALLEL DO if(nbi_outside.gt.0)then if(inputs%verbose.ge.0) then write(*,'(T4,a, f6.2)') 'Percent of markers outside the grid: ', & 100.*nbi_outside/(3.*inputs%n_nbi) endif if(sum(neut%dens).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& ic, nc,randomu,sqrt_rho,theta,r0,plasma,gaunt,brems) loop_over_channels: do ichan=1,spec_chords%nchan 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 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_channels 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/(lambda_arr*plasma%te*1000.0)) & *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 if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') 100*ichan/real(spec_chords%nchan),char(13) endif enddo loop_over_channels !! $OMP END PARALLEL DO deallocate(lambda_arr,brems) end subroutine bremsstrahlung subroutine dcx !+ Calculates Direct Charge Exchange (DCX) neutral density and spectra integer :: i,j,k !indices of cells integer(Int64) :: idcx !! counter real(Float64), dimension(3) :: ri !! start position real(Float64), dimension(3) :: vihalo integer,dimension(3) :: ind !! actual cell 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 :: ncell type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks !! Particle tracks integer :: jj !! counter along track real(Float64):: tot_denn, photons !! photon flux real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox, nlaunch !! approx. density real(Float64) :: papprox_tot, ccnt, inv_ng, r_nlaunchijk halo_iter_dens(halo_type) = 0.d0 papprox=0.d0 papprox_tot=0.d0 tot_denn=0.d0 do k=1,beam_grid%nz do j=1,beam_grid%ny do i=1,beam_grid%nx ind = [i,j,k] call get_plasma(plasma,ind=ind) tot_denn = sum(neut%dens(:,nbif_type,i,j,k)) + & sum(neut%dens(:,nbih_type,i,j,k)) + & sum(neut%dens(:,nbit_type,i,j,k)) papprox(i,j,k)= tot_denn*(plasma%denp-plasma%denf) if(plasma%in_plasma) papprox_tot=papprox_tot+papprox(i,j,k) enddo enddo enddo call get_nlaunch(inputs%n_dcx,papprox,papprox_tot,nlaunch) if(inputs%verbose.ge.1) then write(*,'(T6,"# of markers: ",i9)') int(sum(nlaunch),Int64) endif ccnt=0.d0 inv_ng = 100.0/real(beam_grid%ngrid) !$OMP PARALLEL DO collapse(3) schedule(dynamic,1) private(k,j,i,idcx,ind,vihalo, & !$OMP& ri,tracks,ncell,rates,denn,states,jj,photons,plasma,r_nlaunchijk) loop_along_z: do k = 1, beam_grid%nz loop_along_y: do j = 1, beam_grid%ny loop_along_x: do i = 1, beam_grid%nx !! Loop over the markers loop_over_dcx: do idcx=1,int(nlaunch(i,j,k),Int64) !! Calculate ri,vhalo and track ind = [i, j, k] r_nlaunchijk = 1.d0/nlaunch(i,j,k) call mc_halo(ind,vihalo,ri) call track(ri,vihalo,tracks,ncell) if(ncell.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 - plasma%denf) loop_along_track: do jj=1,ncell call get_plasma(plasma,pos=tracks(jj)%pos) call colrad(plasma,thermal_ion,vihalo,tracks(jj)%time,states,denn,photons) tracks(jj)%dens = denn*r_nlaunchijk if((photons.gt.0.d0).and.(inputs%calc_bes.ge.1)) then call store_bes_photons(tracks(jj)%pos,vihalo,photons*r_nlaunchijk,halo_type) endif enddo loop_along_track call store_neutrals(tracks, ncell, halo_type) enddo loop_over_dcx ccnt=ccnt+1 if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') ccnt*inv_ng,char(13) endif enddo loop_along_x enddo loop_along_y enddo loop_along_z end subroutine dcx subroutine halo !+ Calculates halo neutral density and spectra integer :: i,j,k !indices of cells integer(Int64) :: ihalo,n_halo !! counter real(Float64), dimension(3) :: ri !! start position real(Float64), dimension(3) :: vihalo!! velocity bulk plasma ion integer,dimension(3) :: ind !! 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 :: ncell type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks !! Particle Tracks integer :: jj !! counter along track real(Float64) :: tot_denn, photons !! photon flux real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox, nlaunch !! approx. density real(Float64) :: papprox_tot, ccnt, inv_ng !! Halo iteration integer :: hh !! counters real(Float64) :: dcx_dens, halo_iteration_dens, seed_dcx real(Float64) :: r_nlaunchijk, local_dens integer :: s1type ! halo iteration integer :: s2type ! halo iteration s1type = fida_type s2type = brems_type dcx_dens = halo_iter_dens(halo_type) halo_iter_dens(s1type) = 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 inv_ng = 100.0/real(beam_grid%ngrid) neut%dens(:,s1type,:,:,:) = neut%dens(:,halo_type,:,:,:) n_halo = inputs%n_halo seed_dcx = 1.0 iterations: do hh=1,200 papprox=0.d0 papprox_tot=0.d0 tot_denn=0.d0 halo_iter_dens(s2type) = 0.d0 do k=1,beam_grid%nz do j=1,beam_grid%ny do i=1,beam_grid%nx ind = [i,j,k] call get_plasma(plasma,ind=ind) tot_denn = sum(neut%dens(:,s1type,i,j,k)) papprox(i,j,k)= tot_denn*(plasma%denp-plasma%denf) if(plasma%in_plasma) papprox_tot=papprox_tot+papprox(i,j,k) enddo enddo enddo call get_nlaunch(n_halo,papprox,papprox_tot,nlaunch) if(inputs%verbose.ge.1) then write(*,'(T6,"# of markers: ",i9," --- Seed/DCX: ",f5.3)') int(sum(nlaunch),Int64), seed_dcx endif ccnt=0.d0 !$OMP PARALLEL DO schedule(dynamic,1) collapse(3) private(i,j,k,ihalo,ind,vihalo, & !$OMP& ri,tracks,ncell,rates,denn,states,jj,photons,plasma,r_nlaunchijk) loop_along_z: do k = 1, beam_grid%nz loop_along_y: do j = 1, beam_grid%ny loop_along_x: do i = 1, beam_grid%nx local_dens = 0.0d0 !! Loop over the markers loop_over_halos: do ihalo=1,int(nlaunch(i,j,k),Int64) !! Calculate ri,vhalo and track ind = [i, j, k] r_nlaunchijk = 1.0d0/nlaunch(i,j,k) call mc_halo(ind,vihalo,ri) call track(ri,vihalo,tracks,ncell) if(ncell.eq.0)cycle loop_over_halos !! Calculate CX probability call get_beam_cx_rate(tracks(1)%ind,ri,vihalo,thermal_ion,[s1type],rates) if(sum(rates).le.0.)cycle loop_over_halos !! 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 loop_along_track: do jj=1,ncell call get_plasma(plasma,pos=tracks(jj)%pos) call colrad(plasma,thermal_ion,vihalo,tracks(jj)%time,states,denn,photons) tracks(jj)%dens = denn*r_nlaunchijk if((photons.gt.0.d0).and.(inputs%calc_bes.ge.1)) then call store_bes_photons(tracks(jj)%pos,vihalo,photons*r_nlaunchijk,halo_type) endif enddo loop_along_track call store_neutrals(tracks, ncell, s2type) enddo loop_over_halos ccnt=ccnt+1 if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') ccnt*inv_ng,char(13) endif enddo loop_along_x enddo loop_along_y enddo loop_along_z !$OMP END PARALLEL DO if(halo_iter_dens(s2type)/halo_iter_dens(s1type).gt.1.0) then if(inputs%verbose.ge.0) then write(*,'(a)') "HALO: Halo generation density exceeded seed density. This shouldn't happen." endif exit iterations endif halo_iteration_dens = halo_iter_dens(s2type) halo_iter_dens(s1type) = halo_iter_dens(s2type) neut%dens(:,halo_type,:,:,:)= neut%dens(:,halo_type,:,:,:) & + neut%dens(:,s2type,:,:,:) neut%dens(:,s1type,:,:,:)= neut%dens(:,s2type,:,:,:) neut%dens(:,s2type,:,:,:)= 0. 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 !! set the neutral density in s1type(fida_type) and s2type (brems) to 0! neut%dens(:,s1type,:,:,:) = 0.d0 neut%dens(:,s2type,:,:,:) = 0.d0 end subroutine halo subroutine fida_f !+ Calculate FIDA emission using a Fast-ion distribution function F(E,p,r,z) integer :: i,j,k,ip !! indices x,y,z of cells 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(4) :: neut_types=[1,2,3,4] 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 :: ncell 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 integer(kind=8) :: pcnt real(Float64) :: papprox_tot, inv_maxcnt, cnt, eb, ptch integer, dimension(3,beam_grid%ngrid) :: pcell real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox, nlaunch !! approx. density !! Estimate how many particles to launch in each cell papprox=0.d0 papprox_tot=0.d0 pcnt=1 do k=1,beam_grid%nz do j=1,beam_grid%ny do i=1,beam_grid%nx ind =[i,j,k] call get_plasma(plasma,ind=ind) papprox(i,j,k) = (sum(neut%dens(:,nbif_type,i,j,k)) + & sum(neut%dens(:,nbih_type,i,j,k)) + & sum(neut%dens(:,nbit_type,i,j,k)) + & sum(neut%dens(:,halo_type,i,j,k)))* & plasma%denf if(papprox(i,j,k).gt.0) then pcell(:,pcnt)= ind pcnt=pcnt+1 endif if(plasma%in_plasma) papprox_tot=papprox_tot+papprox(i,j,k) enddo enddo enddo pcnt=pcnt-1 inv_maxcnt=100.0/real(pcnt) call get_nlaunch(inputs%n_fida,papprox,papprox_tot,nlaunch) if(inputs%verbose.ge.1) then write(*,'(T6,"# of markers: ",i9)') int(sum(nlaunch),Int64) endif !! Loop over all cells that have neutrals cnt=0.d0 loop_over_cells: do ip = 1, int(pcnt) i = pcell(1,ip) j = pcell(2,ip) k = pcell(3,ip) ind = [i, j, k] !$OMP PARALLEL DO schedule(guided) private(ip,iion,vi,ri,fields,los_intersect, & !$OMP tracks,ncell,jj,plasma,rates,denn,states,photons,denf,eb,ptch) loop_over_fast_ions: do iion=1,int(nlaunch(i, j, k),Int64) !! Sample fast ion distribution for velocity and position call mc_fastion(ind, fields, eb, ptch, denf) if(denf.eq.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, ncell,los_intersect) if(.not.los_intersect) cycle loop_over_fast_ions if(ncell.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,ncell 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 !$OMP END PARALLEL DO cnt=cnt+1 if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') cnt*inv_maxcnt,char(13) endif enddo loop_over_cells end subroutine fida_f subroutine fida_mc !+ Calculate FIDA emission using a Monte Carlo Fast-ion distribution integer :: iion,iphi,nphi 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 :: ncell type(ParticleTrack), dimension(beam_grid%ntrack) :: tracks logical :: los_intersect integer :: jj !! counter along track real(Float64) :: photons !! photon flux integer, dimension(4) :: neut_types=[1,2,3,4] real(Float64), dimension(3) :: uvw, uvw_vi real(Float64) :: s, c real(Float64) :: maxcnt, inv_maxcnt, cnt real(Float64), dimension(1) :: randomu maxcnt=particles%nparticle inv_maxcnt = 100.d0/maxcnt nphi = ceiling(dble(inputs%n_fida)/particles%nparticle) if(inputs%verbose.ge.1) then write(*,'(T6,"# of markers: ",i9)') int(particles%nparticle*nphi,Int64) endif cnt=0.0 !$OMP PARALLEL DO schedule(guided) private(iion,iphi,fast_ion,vi,ri,phi,tracks,s,c, & !$OMP& randomu,plasma,fields,uvw,uvw_vi,ncell,jj,rates,denn,los_intersect,states,photons) loop_over_fast_ions: do iion=1,particles%nparticle fast_ion = particles%fast_ion(iion) cnt=cnt+1 if(fast_ion%vabs.eq.0) cycle loop_over_fast_ions if(.not.fast_ion%cross_grid) cycle loop_over_fast_ions phi_loop: do iphi=1,nphi !! Pick random torodial angle call randu(randomu) phi = fast_ion%phi_enter + fast_ion%delta_phi*randomu(1) 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, ncell, los_intersect) if(.not.los_intersect) cycle phi_loop if(ncell.eq.0)cycle phi_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 phi_loop !! Weight CX rates by ion source density states=rates*fast_ion%weight/nphi !! Calculate the spectra produced in each cell along the path loop_along_track: do jj=1,ncell 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 phi_loop if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') cnt*inv_maxcnt,char(13) endif enddo loop_over_fast_ions !$OMP END PARALLEL DO end subroutine fida_mc subroutine npa_f !+ Calculate NPA flux using a fast-ion distribution function F(E,p,r,z) integer :: i,j,k,det,ip integer(Int64) :: iion real(Float64), dimension(3) :: rg,ri,rf,vi integer, dimension(3) :: ind,pind real(Float64) :: denf integer, dimension(3,beam_grid%ngrid) :: pcell type(LocalProfiles) :: plasma type(LocalEMFields) :: fields type(GyroSurface) :: gs real(Float64), dimension(2,4) :: gyrange integer, dimension(4) :: neut_types=[1,2,3,4] real(Float64), dimension(nlevs) :: rates real(Float64), dimension(nlevs) :: states real(Float64) :: flux, theta, dtheta, eb, ptch integer :: inpa,pcnt,ichan,nrange,ir real(Float64) :: papprox_tot, maxcnt, cnt, inv_maxcnt real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox, nlaunch papprox=0.d0 papprox_tot=0.d0 pcnt=1 do k=1,beam_grid%nz do j=1,beam_grid%ny do i=1,beam_grid%nx ind =[i,j,k] call get_plasma(plasma,ind=ind) papprox(i,j,k)=(sum(neut%dens(:,nbif_type,i,j,k)) + & sum(neut%dens(:,nbih_type,i,j,k)) + & sum(neut%dens(:,nbit_type,i,j,k)) + & sum(neut%dens(:,halo_type,i,j,k)))* & plasma%denf if(papprox(i,j,k).gt.0) then pcell(:,pcnt)= ind pcnt = pcnt + 1 endif if(plasma%in_plasma) papprox_tot=papprox_tot+papprox(i,j,k) enddo enddo enddo pcnt = pcnt - 1 maxcnt=real(pcnt) inv_maxcnt = 100.0/maxcnt call get_nlaunch(inputs%n_npa,papprox,papprox_tot,nlaunch) if(inputs%verbose.ge.1) then write(*,'(T6,"# of markers: ",i12)') int(sum(nlaunch),Int64) endif !! Loop over all cells that can contribute to NPA signal cnt=0.d0 loop_over_cells: do ip = 1, int(pcnt) i = pcell(1,ip) j = pcell(2,ip) k = pcell(3,ip) ind = [i, j, k] !$OMP PARALLEL DO schedule(guided) private(iion,ichan,fields,nrange,gyrange, & !$OMP& pind,vi,ri,rf,det,plasma,rates,states,flux,denf,eb,ptch,gs,ir,theta,dtheta) loop_over_fast_ions: do iion=1,int(nlaunch(i, j, k),Int64) !! Sample fast ion distribution for energy and pitch call mc_fastion(ind, fields, eb, ptch, denf) if(denf.eq.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 !$OMP END PARALLEL DO cnt=cnt+1 if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') cnt*inv_maxcnt,char(13) endif enddo loop_over_cells if(inputs%verbose.ge.1) then write(*,'(T4,"Number of NPA particles that hit a detector: ",i8)') npa%npart endif end subroutine npa_f subroutine npa_mc !+ Calculate NPA flux using a Monte Carlo fast-ion distribution integer :: iion,iphi,nphi type(FastIon) :: fast_ion real(Float64) :: phi,theta,dtheta real(Float64), dimension(3) :: ri, rf, rg, vi integer :: det,j,ichan,ir,nrange type(LocalEMFields) :: fields type(GyroSurface) :: gs real(Float64), dimension(nlevs) :: rates real(Float64), dimension(nlevs) :: states real(Float64) :: flux integer, dimension(4) :: neut_types=[1,2,3,4] integer, dimension(3) :: ind real(Float64), dimension(3) :: uvw, uvw_vi real(Float64), dimension(2,4) :: gyrange real(Float64) :: s,c real(Float64) :: maxcnt, inv_maxcnt, cnt real(Float64), dimension(1) :: randomu maxcnt=particles%nparticle inv_maxcnt = 100.d0/maxcnt nphi = ceiling(dble(inputs%n_npa)/particles%nparticle) if(inputs%verbose.ge.1) then write(*,'(T6,"# of markers: ",i9)') int(particles%nparticle*nphi,Int64) endif cnt=0.0 !$OMP PARALLEL DO schedule(guided) private(iion,iphi,ind,fast_ion,vi,ri,rf,phi,s,c,ir, & !$OMP& randomu,rg,fields,uvw,uvw_vi,rates,states,flux,det,ichan,gs,nrange,gyrange,theta,dtheta) loop_over_fast_ions: do iion=1,particles%nparticle cnt=cnt+1 fast_ion = particles%fast_ion(iion) if(fast_ion%vabs.eq.0)cycle loop_over_fast_ions if(.not.fast_ion%cross_grid) cycle loop_over_fast_ions phi_loop: do iphi=1,nphi !! Pick random torodial angle call randu(randomu) phi = fast_ion%phi_enter + fast_ion%delta_phi*randomu(1) 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/nphi !! 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 call store_npa(det,ri,rf,vi,flux,fast_ion%class) 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 phi_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 phi_loop !! Weight CX rates by ion source density states=rates*fast_ion%weight/nphi !! 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 phi_loop if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') cnt*inv_maxcnt,char(13) endif enddo loop_over_fast_ions !$OMP END PARALLEL DO if(inputs%verbose.ge.1) then write(*,'(T4,"Number of NPA particles that hit a detector: ",i8)') npa%npart endif end subroutine npa_mc subroutine neutron_f !+ Calculate neutron emission rate using a fast-ion distribution function F(E,p,r,z) integer :: ir, iz, ie, ip, iphi, nphi type(LocalProfiles) :: plasma type(LocalEMFields) :: fields real(Float64) :: eb,pitch,r,z real(Float64) :: erel, rate real(Float64), dimension(3) :: rg, ri real(Float64), dimension(3) :: vi real(Float64), dimension(3) :: uvw, uvw_vi real(Float64) :: vnet_square, factor real(Float64) :: maxcnt, inv_maxcnt, cnt allocate(neutron%weight(fbm%nenergy,fbm%npitch,fbm%nr,fbm%nz)) neutron%weight = 0.d0 nphi = 20 maxcnt=fbm%nr*fbm%nz inv_maxcnt = 100.d0/maxcnt cnt=0.0 !$OMP PARALLEL DO schedule(guided) private(fields,vi,ri,rg,pitch,eb,& !$OMP& ir,iz,ie,ip,iphi,plasma,factor,uvw,uvw_vi,vnet_square,rate,erel) z_loop: do iz = 1, fbm%nz r_loop: do ir=1, fbm%nr cnt = cnt+1 !! Calculate position uvw(1) = fbm%r(ir) uvw(2) = 0.d0 uvw(3) = fbm%z(iz) call uvw_to_xyz(uvw, rg) !! Get fields call get_fields(fields,pos=rg) if(.not.fields%in_plasma) cycle r_loop factor = 2*pi*fbm%r(ir)*fbm%dE*fbm%dp*fbm%dr*fbm%dz/nphi !! Loop over energy/pitch/phi 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 iphi=1, nphi 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) neutron%weight(ie,ip,ir,iz) = neutron%weight(ie,ip,ir,iz) & + rate*factor rate = rate*fbm%f(ie,ip,ir,iz)*factor !! Store neutrons call store_neutrons(rate) enddo gyro_loop enddo energy_loop enddo pitch_loop if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') cnt*inv_maxcnt,char(13) endif enddo r_loop enddo z_loop !$OMP END PARALLEL DO if(inputs%verbose.ge.1) then write(*,'(T4,A,ES14.5," [neutrons/s]")') 'Rate: ',sum(neutron%rate) write(*,'(30X,a)') '' endif call write_neutrons() end subroutine neutron_f subroutine neutron_mc !+ Calculate neutron flux using a Monte Carlo Fast-ion distribution integer :: iion, nphi, iphi type(FastIon) :: fast_ion type(LocalProfiles) :: plasma type(LocalEMFields) :: fields real(Float64) :: eb, rate real(Float64), dimension(3) :: ri, rg real(Float64), dimension(3) :: vi real(Float64), dimension(3) :: uvw, uvw_vi real(Float64) :: vnet_square real(Float64) :: maxcnt, inv_maxcnt, cnt maxcnt=particles%nparticle inv_maxcnt = 100.d0/maxcnt if(inputs%verbose.ge.1) then write(*,'(T6,"# of markers: ",i9)') particles%nparticle endif cnt=0.0 rate=0.0 nphi = 20 !$OMP PARALLEL DO schedule(guided) private(iion,fast_ion,vi,ri,rg, & !$OMP& plasma,fields,uvw,uvw_vi,vnet_square,rate,eb,iphi) loop_over_fast_ions: do iion=1,particles%nparticle cnt=cnt+1 fast_ion = particles%fast_ion(iion) if(fast_ion%vabs.eq.0.d0) cycle loop_over_fast_ions !! Calculate position uvw(1) = fast_ion%r uvw(2) = 0.0 uvw(3) = fast_ion%z if(inputs%dist_type.eq.2) then call uvw_to_xyz(uvw, rg) !! Get electomagnetic fields call get_fields(fields, pos=rg) if(.not.fields%in_plasma) cycle loop_over_fast_ions gyro_loop: do iphi=1,nphi !! 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*(2*pi/fast_ion%delta_phi)*beam_grid%dv/nphi !! Store neutrons call store_neutrons(rate, fast_ion%class) enddo gyro_loop else call uvw_to_xyz(uvw, ri) !! Get plasma parameters call get_plasma(plasma,pos=ri) 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*(2*pi/fast_ion%delta_phi)*beam_grid%dv !! Store neutrons call store_neutrons(rate, fast_ion%class) endif if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') cnt*inv_maxcnt,char(13) endif enddo loop_over_fast_ions !$OMP END PARALLEL DO if(inputs%verbose.ge.1) then write(*,'(T4,A,ES14.5," [neutrons/s]")') 'Rate: ',sum(neutron%rate) write(*,'(30X,a)') '' endif call write_neutrons() end subroutine neutron_mc subroutine fida_weights_mc !+ Calculates FIDA weights integer :: i,j,k !! indices x,y,z of cells 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(4) :: neut_types=[1,2,3,4] 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 :: ncell 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 integer(kind=8) :: pcnt real(Float64) :: papprox_tot,inv_maxcnt,cnt,fbm_denf,phase_area integer,dimension(3,beam_grid%ngrid) :: pcell real(Float64), dimension(beam_grid%nx,beam_grid%ny,beam_grid%nz) :: papprox,nlaunch !! approx. density 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(*,'(T2,"Number of Channels: ",i5)') spec_chords%nchan write(*,'(T2,"Nlambda: ",i4)') nwav write(*,'(T2,"Nenergy: ",i3)') inputs%ne_wght write(*,'(T2,"Maximum Energy: ",f7.2)') inputs%emax_wght write(*,'(T2,"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 papprox_tot=0.d0 pcnt=1 do k=1,beam_grid%nz do j=1,beam_grid%ny do i=1,beam_grid%nx ind =[i,j,k] call get_plasma(plasma,ind=ind) papprox(i,j,k)=(sum(neut%dens(:,nbif_type,i,j,k)) + & sum(neut%dens(:,nbih_type,i,j,k)) + & sum(neut%dens(:,nbit_type,i,j,k)) + & sum(neut%dens(:,halo_type,i,j,k))) if(papprox(i,j,k).gt.0) then pcell(:,pcnt)= ind pcnt=pcnt+1 endif if(plasma%in_plasma) papprox_tot=papprox_tot+papprox(i,j,k) enddo enddo enddo pcnt=pcnt-1 inv_maxcnt=100.0/real(pcnt) call get_nlaunch(10*inputs%n_fida,papprox,papprox_tot,nlaunch) if(inputs%verbose.ge.1) then write(*,'(T6,"# of markers: ",i9)') int(sum(nlaunch),Int64) endif !! Loop over all cells that have neutrals cnt=0.d0 loop_over_cells: do ip = 1, int(pcnt) i = pcell(1,ip) j = pcell(2,ip) k = pcell(3,ip) ind = [i, j, k] !$OMP PARALLEL DO schedule(guided) private(iion,vi,ri,rg,ienergy,ipitch, & !$OMP tracks,ncell,jj,plasma,fields,rates,denn,states,photons,energy,pitch, & !$OMP los_intersect,randomu3,fbm_denf) loop_over_fast_ions: do iion=1,int(nlaunch(i, j, k),Int64) !! 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%c) endif !! Find the particles path through the beam grid call track(ri, vi, tracks, ncell, los_intersect) if(.not.los_intersect) cycle loop_over_fast_ions if(ncell.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,ncell 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 !$OMP END PARALLEL DO cnt=cnt+1 if(inputs%verbose.ge.2) then WRITE(*,'(f7.2,"% completed",a,$)') cnt*inv_maxcnt,char(13) endif enddo loop_over_cells fweight%weight = ((1.d-20)*phase_area/dEdP)*fweight%weight fweight%mean_f = ((1.d-20)*phase_area/dEdP)*fweight%mean_f call write_fida_weights() 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,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) :: ncell 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(*,'(T2,"Number of Channels: ",i5)') spec_chords%nchan write(*,'(T2,"Nlambda: ",i4)') nwav write(*,'(T2,"Nenergy: ",i3)') inputs%ne_wght write(*,'(T2,"Npitch: ",i3)') inputs%np_wght write(*,'(T2,"Ngyro: ", i3)') inputs%nphi_wght write(*,'(T2,"Maximum Energy: ",f7.2)') inputs%emax_wght write(*,'(T2,"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 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%dens(:,nbif_type,i,j,k)*dlength hdens = hdens + neut%dens(:,nbih_type,i,j,k)*dlength tdens = tdens + neut%dens(:,nbit_type,i,j,k)*dlength halodens = halodens + neut%dens(:,halo_type,i,j,k)*dlength wght = sum(neut%dens(3,1:4,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%c) 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,ncell,dt,icell,states,rates, & !$OMP& vhalo,denn,denf,photons,ienergy,ipitch,igyro) do ienergy=1,inputs%ne_wght 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, ncell) max_dens = 0.d0 do icell=1,ncell ind = tracks(icell)%ind tracks(icell)%flux = sum(neut%dens(3,1:4,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,ncell 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, 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) call write_fida_weights() 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, ccnt real(Float64), dimension(nlevs) :: pcx !! Rate coefficiants for CX real(Float64), dimension(nlevs) :: states, states_i ! Density of n-states integer, dimension(4) :: neut_types=[1,2,3,4] 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(*,'(T2,"Number of Channels: ",i3)') npa_chords%nchan write(*,'(T2,"Nenergy: ",i3)') inputs%ne_wght write(*,'(T2,"Npitch: ",i3)') inputs%np_wght write(*,'(T2,"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 if(inputs%verbose.ge.1) then write(*,'(T4,"Channel: ",i3)') ichan write(*,'(T4,"Radius: ",f10.3)') npa_chords%radius(ichan) endif ccnt=0.d0 !$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 = 1, inputs%ne_wght !! 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 ccnt=ccnt+1 if (inputs%verbose.ge.2)then WRITE(*,'(f7.2,"% completed",a,$)') ccnt/real(beam_grid%ngrid)*100,char(13) endif enddo loop_along_x enddo loop_along_y enddo loop_along_z !$OMP END PARALLEL DO if(inputs%verbose.ge.1) then 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 loop_over_channels call write_npa_weights() end subroutine npa_weights end module libfida !============================================================================= !-------------------------------Main Program---------------------------------- !============================================================================= program fidasim !+ FIDASIM {!../VERSION!} use libfida use hdf5_extra #ifdef _OMP use omp_lib #endif implicit none character(3) :: arg = '' integer, dimension(8) :: time_arr,time_start,time_end !Time array integer :: i,narg,nthreads,max_threads integer :: hour,minu,sec #ifdef _VERSION version = _VERSION #endif call print_banner() narg = command_argument_count() if(narg.eq.0) then write(*,'(a)') "usage: ./fidasim namelist_file [num_threads]" 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 !! ---------------------------------------------------------- !! ------ INITIALIZE THE RANDOM NUMBER GENERATOR ----------- !! ---------------------------------------------------------- allocate(rng(max_threads)) do i=1,max_threads call rng_init(rng(i),932117 + i) enddo !! ---------------------------------------------------------- !! ------- READ GRIDS, PROFILES, LOS, TABLES, & FBM -------- !! ---------------------------------------------------------- call read_equilibrium() call make_beam_grid() call read_beam() call read_tables() 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)) then call read_npa() endif !! ---------------------------------------------------------- !! --------------- ALLOCATE THE RESULT ARRAYS --------------- !! ---------------------------------------------------------- !! neutral density array! allocate(neut%dens(nlevs,ntypes,beam_grid%nx,beam_grid%ny,beam_grid%nz)) neut%dens = 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%neut_type(int(inputs%n_birth*inputs%n_nbi))) allocate(birth%ind(3,int(inputs%n_birth*inputs%n_nbi))) allocate(birth%ri(3,int(inputs%n_birth*inputs%n_nbi))) allocate(birth%vi(3,int(inputs%n_birth*inputs%n_nbi))) birth%neut_type = 0 birth%dens = 0.d0 birth%ind = 0 birth%ri = 0.d0 birth%vi = 0.d0 endif if(inputs%calc_spec.ge.1) then allocate(spec%brems(inputs%nlambda,spec_chords%nchan)) allocate(spec%bes(inputs%nlambda,spec_chords%nchan,4)) allocate(spec%fida(inputs%nlambda,spec_chords%nchan,particles%nclass)) spec%brems = 0.d0 spec%bes = 0.d0 spec%fida = 0.d0 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_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() else !! ----------- BEAM NEUTRALS ---------- !! call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'ndmc: ' , & time_arr(5),time_arr(6),time_arr(7) endif call ndmc if(inputs%calc_birth.eq.1)then call write_birth_profile() endif if(inputs%verbose.ge.1) write(*,'(30X,a)') '' !! ---------- DCX (Direct charge exchange) ---------- !! call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'dcx: ' , & time_arr(5),time_arr(6),time_arr(7) endif call dcx() if(inputs%dump_dcx.eq.1) call write_dcx() if(inputs%verbose.ge.1) write(*,'(30X,a)') '' !! ---------- HALO ---------- !! call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'halo: ' , & time_arr(5),time_arr(6),time_arr(7) endif call halo() !! ---------- WRITE NEUTRALS ---------- !! call write_neutrals() if(inputs%verbose.ge.1) write(*,'(30X,a)') '' endif !! ----------------------------------------------------------------------- !!----------------------------- BREMSSTRAHLUNG --------------------------- !! ----------------------------------------------------------------------- if(inputs%calc_brems.ge.1) then call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'bremsstrahlung: ' , & time_arr(5),time_arr(6),time_arr(7) endif call bremsstrahlung() if(inputs%verbose.ge.1) write(*,'(30X,a)') '' endif !! ----------------------------------------------------------------------- !! --------------------- CALCULATE the FIDA RADIATION -------------------- !! ----------------------------------------------------------------------- if(inputs%calc_fida.ge.1)then call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'fida: ' , & time_arr(5),time_arr(6),time_arr(7) 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_spec.ge.1) then call write_spectra() write(*,'(30X,a)') '' endif !! ----------------------------------------------------------------------- !! ----------------------- CALCULATE the NPA FLUX ------------------------ !! ----------------------------------------------------------------------- if(inputs%calc_npa.ge.1)then call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'npa: ' , & time_arr(5),time_arr(6),time_arr(7) 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_npa.ge.1) then call write_npa() if(inputs%verbose.ge.1) write(*,'(30X,a)') '' endif !! ------------------------------------------------------------------- !! ------------------- Calculation of neutron flux ------------------- !! ------------------------------------------------------------------- if(inputs%calc_neutron.ge.1) then call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'neutron rate: ', & time_arr(5),time_arr(6),time_arr(7) 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 colrad_threshold=0. !! to speed up simulation! call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'fida weight function: ', & time_arr(5),time_arr(6),time_arr(7) 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 call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'npa weight function: ', & time_arr(5),time_arr(6),time_arr(7) endif call npa_weights() if(inputs%verbose.ge.1) write(*,'(30X,a)') '' endif call date_and_time (values=time_arr) if(inputs%verbose.ge.1) then write(*,'(A,I2,":",I2.2,":",I2.2)') 'END: hour, minute, second: ',& time_arr(5),time_arr(6),time_arr(7) endif call date_and_time (values=time_end) hour = time_end(5) - time_start(5) minu = time_end(6) - time_start(6) sec = time_end(7) - time_start(7) if (minu.lt.0.) then minu = minu +60 hour = hour -1 endif if (sec.lt.0.) then sec = sec +60 minu = minu -1 endif if(inputs%verbose.ge.1) then write(*,'(A,18X,I2,":",I2.2,":",I2.2)') 'duration:',hour,minu,sec endif end program fidasim