! The MIT License (MIT)
!
! Copyright (c) 2016 odlomax
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

! ray module for luminosity packet propagation
module m_ray

   use m_kind_parameters
   use m_sph_parameters
   use m_constants_parameters
   use m_maths
   use m_line
   use m_particle
   use m_kernel
   use m_binary_tree
   use m_binary_tree_node
   use m_dust
   use m_atomic_update

   implicit none

   private
   public :: ray

   ! ray particle type
   type :: ray_particle

      real(kind=rel_kind) :: r(n_dim)           ! particle position
      real(kind=rel_kind) :: v(n_dim)           ! paticle velocity
      real(kind=rel_kind) :: m                  ! particle mass
      real(kind=rel_kind) :: inv_h              ! one over smoothing length
      real(kind=rel_kind) :: inv_rho            ! one over density
      real(kind=rel_kind) :: a_dot              ! temperature of particle
      real(kind=rel_kind) :: t_r                ! particle postion along ray
      real(kind=rel_kind) :: b                  ! impact m_parameter
      real(kind=rel_kind) :: s_0                ! paticle-origin distance
      real(kind=rel_kind) :: s_1                ! particle-terminal distance
      real(kind=rel_kind) :: sigma              ! column density through particle
      real(kind=rel_kind) :: lambda_ob          ! rest frame wavelength
      real(kind=rel_kind) :: kappa_ext          ! dust mass extinction coeff
      real(kind=rel_kind) :: a                  ! dust albedo
      real(kind=rel_kind) :: f_sub              ! dust sublimation fraction
      type(particle),pointer :: particle_ptr    ! particle pointer

      contains

      procedure,non_overridable :: initialise=>initialise_ray_particle

   end type

   ! ray type
   type :: ray

      integer(kind=int_kind) :: n_item          ! number of items in item array
      real(kind=rel_kind) :: l_chunk            ! chunk of luminosity
      real(kind=rel_kind) :: v_em(n_dim)        ! emission velocity
      real(kind=rel_kind) :: lambda_em          ! wavelength of emission
      real(kind=rel_kind) :: min_length         ! minimum ray length
      real(kind=rel_kind) :: max_length         ! maximum ray length
      type(line) :: path                        ! path of ray
      type(ray_particle),allocatable :: item(:) ! ray particle array
      type(binary_tree),pointer :: sph_tree     ! binary tree
      class(kernel),pointer :: sph_kernel       ! sph kernel object
      class(dust),pointer :: dust_prop          ! dust properties object

      contains

      procedure,non_overridable :: initialise=>initialise_ray
      procedure,non_overridable :: destroy=>destroy_ray
      procedure,non_overridable :: follow
      procedure,non_overridable :: ray_trace_initialise
      procedure,non_overridable :: ray_trace_i
      procedure,non_overridable :: ray_trace_tau
      procedure,non_overridable :: ray_trace_j
      procedure,non_overridable,private :: v_sph
      procedure,non_overridable,private :: a_dot_sph
      procedure,non_overridable,private :: a_dot_o_sph
      procedure,non_overridable,private :: a_sph
      procedure,non_overridable,private :: h_sph
      procedure,non_overridable,private :: ave_inv_mfp_sph
      procedure,non_overridable,private :: grad_ave_inv_mfp_sph
      procedure,non_overridable,private :: tau_sph
      procedure,non_overridable,private :: inv_mfp
      procedure,non_overridable,private :: grad_inv_mfp
      procedure,non_overridable,private :: find_particles
      procedure,non_overridable,private :: set_length
      procedure,non_overridable,private :: stock_geometric
      procedure,non_overridable,private :: stock_optical
      procedure,non_overridable,private :: stock_mrw_optical
      procedure,non_overridable,private :: stock_sigma
      procedure,non_overridable,private :: update_absorption_rate

   end type

   contains

   ! associate particle from particle_array with ray_particle object
   pure subroutine initialise_ray_particle(self,sph_particle)

      ! argument declarations
      class(ray_particle),intent(inout) :: self ! ray particle object
      type(particle),intent(inout),target :: sph_particle       ! sph particle

      ! set quantities
      self%r=sph_particle%r
      self%v=sph_particle%v
      self%m=sph_particle%m
      self%inv_h=sph_particle%inv_h
      self%inv_rho=sph_particle%inv_rho
      self%a_dot=sph_particle%a_dot
      self%f_sub=sph_particle%f_sub
      self%particle_ptr=>sph_particle

      return

   end subroutine

   ! initialise the ray
   pure subroutine initialise_ray(self,sph_kernel,sph_tree,dust_prop)

      ! argument declarations
      class(ray),intent(inout) :: self                          ! ray object
      class(kernel),intent(inout),target :: sph_kernel          ! sph kernel object
      class(dust),intent(inout),target :: dust_prop             ! dust properties object
      type(binary_tree),intent(inout),target:: sph_tree         ! particle tree

      ! associate kernel and tree root node
      self%dust_prop=>dust_prop
      self%sph_kernel=>sph_kernel
      self%sph_tree=>sph_tree

      self%min_length=sph_tree%min_length
      self%max_length=sph_tree%max_length

      ! allocate ray_particle array
      allocate(self%item(n_ray))

      return

   end subroutine

   ! deallocate ray object
   elemental subroutine destroy_ray(self)

      ! argument declarations
      class(ray),intent(inout) :: self          ! ray object

      deallocate(self%item)

      return

   end subroutine

   ! follow a luminosity packet
   subroutine follow(self,origin_in,direction_in,v_em_in,lambda_em_in,l_chunk,use_mrw,mrw_gamma,n_tau)

      ! argument declarations
      class(ray),intent(inout) :: self                  ! ray object
      real(kind=rel_kind),intent(in) :: origin_in(n_dim)        ! origin of ray
      real(kind=rel_kind),intent(in) :: direction_in(n_dim)     ! direction of ray
      real(kind=rel_kind),intent(in) :: v_em_in(n_dim)  ! velocity of emitter
      real(kind=rel_kind),intent(in) :: lambda_em_in    ! emission wavelength
      real(kind=rel_kind),intent(in) :: l_chunk         ! chunk of luminosity
      logical(kind=log_kind),intent(in) :: use_mrw      ! use modified random walk
      real(kind=rel_kind),intent(in) :: mrw_gamma       ! mrw gamma parameter
      real(kind=rel_kind),intent(inout) :: n_tau        ! number of optical depths travelled (initialised before sub. call)

      ! variable declarations
      integer(kind=int_kind) :: i,j                     ! counter
      real(kind=rel_kind) :: origin(n_dim)              ! origin of ray
      real(kind=rel_kind) :: direction(n_dim)           ! direction of ray
      real(kind=rel_kind) :: new_direction(n_dim)       ! new direction of ray
      real(kind=rel_kind) :: v_em(n_dim)                ! velocity of emitter
      real(kind=rel_kind) :: v_ob(n_dim)                ! velocity of observer
      real(kind=rel_kind) :: lambda_em                  ! emission wavelength
      real(kind=rel_kind) :: mrw_length                 ! length of mrw step
      real(kind=rel_kind) :: length                     ! length of ray
      real(kind=rel_kind) :: tau                        ! number of optical depths to travel
      real(kind=rel_kind) :: tau_est                    ! estimated value of tau
      real(kind=rel_kind) :: inv_mfp                    ! inverse mean free path (density * kappa_ext)
      real(kind=rel_kind) :: grad_inv_mfp(n_dim)        ! gradient of inverse mean free path
      real(kind=rel_kind) :: uni_r                      ! uniform random number
      real(kind=rel_kind) :: lambda_ob                  ! rest frame wavelength
      real(kind=rel_kind) :: h                          ! smoothing length
      real(kind=rel_kind) :: ave_inv_mfp                ! planck averaged inverse mean free path
      real(kind=rel_kind) :: grad_ave_inv_mfp(n_dim)    ! gradient of planck averaged inverse mean free path
      logical(kind=log_kind) :: extend_ray              ! are we extending a ray?
      logical(kind=log_kind) :: short_ray               ! is ray shorter than sim resolution?
      real(kind=rel_kind) :: mrw_distance               ! distance travelled along modified random walk
      real(kind=rel_kind) :: mrw_tau                    ! escape optical depth through mrw sphere
      real(kind=rel_kind) :: mrw_norm                   ! mrw normalisation constant
      real(kind=rel_kind) :: planck_abs                 ! planck mean absorption
      real(kind=rel_kind) :: planck_sca                 ! planck mean scatter
      real(kind=rel_kind),allocatable :: planck_ext(:)  ! planck mean extinction
      real(kind=rel_kind) :: tau_chunk                  ! partial optical depth chunk

      ! set input variables
      origin=origin_in
      direction=direction_in
      v_em=v_em_in
      lambda_em=lambda_em_in

      self%l_chunk=l_chunk
      self%lambda_em=lambda_em
      self%v_em=v_em

      extend_ray=.false.

      ! calculate inv_mfp and grad_inv_mfp from tree
      inv_mfp=0._rel_kind
      grad_inv_mfp=0._rel_kind
      h=0._rel_kind
      ave_inv_mfp=0._rel_kind
      grad_ave_inv_mfp=0._rel_kind
      call self%sph_tree%root_node%sph_inv_mfp(self%sph_kernel,self%dust_prop,&
         &origin,lambda_em,direction,v_em,inv_mfp,grad_inv_mfp,h,ave_inv_mfp,grad_ave_inv_mfp)
      h=merge(h**(-1._rel_kind/real(n_dim,rel_kind)),0._rel_kind,h>0._rel_kind)

      call random_number(tau)
      tau=-log(tau)

      ! allocate item list
      if (.not.allocated(self%item)) allocate(self%item(n_ray))

      do

         ! estimate length from local quantities
         if (inv_mfp>0._rel_kind) then
            length=2._rel_kind*ray_eta*tau/&
               &(inv_mfp+sqrt(max(inv_mfp**2+2._rel_kind*tau*dot_product(grad_inv_mfp,direction),0._rel_kind)))
         else
            length=self%max_length
         end if

         ! adjust length if it's too short
         if (length<max(self%min_length,h)) then
            short_ray=.true.
            length=max(self%min_length,h)
         else
            short_ray=.false.
         end if

         ! check if we need to perform modified random walk
         if (short_ray.and.use_mrw.and.(.not.extend_ray)) then

            mrw_length=min(length,0.5_rel_kind*ave_inv_mfp/norm2(grad_ave_inv_mfp)-1._rel_kind/ave_inv_mfp)

            ! check if mean free path is less then gamma * h
            if (mrw_length*ave_inv_mfp>mrw_gamma) then

               ! shorten length if gradient is high
               length=min(length,0.5_rel_kind*ave_inv_mfp/norm2(grad_ave_inv_mfp))

               ! set new isotropic direction
               direction=self%dust_prop%random_emission_direction()

               ! set target optical depth
               tau=length*ave_inv_mfp

               ! initialise path

               ! make length bigger
               length=length*mrw_max_len
               call self%path%initialise(origin,direction,length)

               ! find particles
               self%n_item=0
               call self%find_particles(self%sph_tree%root_node)

               ! calculate ray properties
               call self%stock_geometric()
               call self%stock_sigma()
               call self%stock_mrw_optical()

               ! if ray longer that needs to be (it should be), shorten it.
               ! otherwise, just take the hit in accuracy
               if (self%tau_sph()>=tau) then
                  call self%set_length(tau,length)
               end if

               ! calculate mrw variables
               mrw_tau=self%tau_sph()

               ! ratio of total optical depth over mrw_tau
               mrw_distance=-log(self%dust_prop%mrw_random_y())*3._rel_kind/pi**2

               ! calculate normalisation constant
               if (allocated(planck_ext)) deallocate(planck_ext)
               allocate(planck_ext(self%n_item))
               planck_ext=self%dust_prop%mrw_planck_ext(self%item(:self%n_item)%a_dot)*self%item(:self%n_item)%f_sub

               mrw_norm=sum(self%item(:self%n_item)%sigma*self%item(:self%n_item)%kappa_ext)*&
                  &sum(self%item(:self%n_item)%sigma*planck_ext)/&
                  &sum((1._rel_kind/self%item(:self%n_item)%inv_rho)*self%item(:self%n_item)%sigma*&
                  &self%item(:self%n_item)%kappa_ext*planck_ext)

               ! update mrw_distance by normalisation constant
               mrw_distance=mrw_distance*mrw_norm

               ! update particle absorption rates
               do i=1,self%n_item

                  planck_abs=self%dust_prop%mrw_planck_abs(self%item(i)%a_dot)*self%item(i)%f_sub

                  tau_chunk=mrw_distance*(1._rel_kind/self%item(i)%inv_rho)*self%item(i)%kappa_ext*self%item(i)%sigma*planck_abs
                  call atomic_real_add(self%item(i)%particle_ptr%a_dot_new,self%l_chunk*tau_chunk)

                  ! update total optical depth
                  n_tau=n_tau+tau_chunk

                  ! check if scattered light array exists
                  if (associated(self%item(i)%particle_ptr%a_dot_scatter_array)) then

                     do j=1,size(self%item(i)%particle_ptr%a_dot_scatter_array)

                        planck_sca=self%dust_prop%mrw_planck_sca(self%item(i)%a_dot,&
                           &self%item(i)%particle_ptr%lambda_array(j),self%item(i)%particle_ptr%lambda_array(j+1))*&
                           &self%item(i)%f_sub

                        tau_chunk=mrw_distance*(1._rel_kind/self%item(i)%inv_rho)*self%item(i)%kappa_ext*&
                           &self%item(i)%sigma*planck_sca
                        call atomic_real_add(self%item(i)%particle_ptr%a_dot_scatter_array(j),&
                           &self%l_chunk*tau_chunk)

                        ! update total optical depth
                        n_tau=n_tau+tau_chunk

                     end do

                  end if

               end do

               ! set new position, direction, wavelength
               origin=origin+self%path%direction*self%path%length
               direction=self%dust_prop%mrw_random_direction(direction)
               self%lambda_em=self%dust_prop%mrw_random_wavelength(self%a_dot_sph())
               self%v_em=self%v_sph()

               ! restock optical properties
               call self%stock_optical()
               inv_mfp=self%inv_mfp()
               grad_inv_mfp=self%grad_inv_mfp()
               h=self%h_sph()
               ave_inv_mfp=self%ave_inv_mfp_sph()
               grad_ave_inv_mfp=self%grad_ave_inv_mfp_sph()
               call random_number(tau)
               tau=-log(tau)

               ! skip to next loop iteration
               extend_ray=.false.
               cycle

            end if

         end if

         ! standard packet propagation

         ! initialise path
         call self%path%initialise(origin,direction,length)

         ! set number of items to 0
         self%n_item=0

         ! find particles
         call self%find_particles(self%sph_tree%root_node)

         ! photon trajectory is complete when n_item=0
         if (self%n_item==0) exit

         ! calculate quantities
         call self%stock_geometric()
         call self%stock_sigma()
         call self%stock_optical()

         tau_est=self%tau_sph()

         ! was initial length estimate too short?
         if (tau_est<tau) then

            ! set new properties
            ! new optical depth and origin

            tau=tau-tau_est
            origin=origin+direction*length
            call self%update_absorption_rate()
            n_tau=n_tau+tau_est
            extend_ray=.true.

         else

            extend_ray=.false.

            ! perform Newton Raphson iterations until length has converged
            call self%set_length(tau,length)

            call self%update_absorption_rate()
            n_tau=n_tau+self%tau_sph()

            ! set new properties

            ! set local velocity frame wavelength
            v_ob=self%v_sph()
            lambda_ob=self%lambda_em*&
               &(dot_product(v_ob-self%v_em,self%path%direction)/c_light+1._rel_kind)

            ! decide whether packet is absorbed or scattered
            call random_number(uni_r)
            if (uni_r<self%dust_prop%albedo(lambda_ob)) then

               ! packet is scattered
               new_direction=self%dust_prop%random_scatter_direction(direction,lambda_ob)
               lambda_em=lambda_ob

            else

               ! packet is absorbed and re-emitted
               new_direction=self%dust_prop%random_emission_direction()
               lambda_em=self%dust_prop%random_wavelength(self%a_dot_sph())

            end if

            ! set new origin
            origin=origin+direction*length
            direction=new_direction
            ! set new emission velocity
            v_em=v_ob

            call random_number(tau)
            tau=-log(tau)

            self%lambda_em=lambda_em
            self%v_em=v_em

            call self%stock_optical()

         end if

         ! set new inv_mfp and grad_inv_mfp
         inv_mfp=self%inv_mfp()
         grad_inv_mfp=self%grad_inv_mfp()
         h=self%h_sph()
         ave_inv_mfp=self%ave_inv_mfp_sph()
         grad_ave_inv_mfp=self%grad_ave_inv_mfp_sph()

      end do

      return

   end subroutine

   ! find and set the length of a ray, given an optical depth
   pure subroutine set_length(self,tau,length)

      ! argument declarations
      class(ray),intent(inout) :: self                ! ray object
      real(kind=rel_kind),intent(in) :: tau           ! target optical depth
      real(kind=rel_kind),intent(out) :: length       ! length of ray

      ! variable declarations
      real(kind=rel_kind) :: tau_0                    ! previous optical depth
      real(kind=rel_kind) :: tau_1                    ! new optical depth
      real(kind=rel_kind) :: tau_b                    ! bracketing optical depth
      real(kind=rel_kind) :: dtau_dl                  ! first derivative of optical depth
      real(kind=rel_kind) :: d2tau_dl2                ! numerical second derivative of optical depth
      real(kind=rel_kind) :: l_0                      ! previous length
      real(kind=rel_kind) :: l_1                      ! new length
      real(kind=rel_kind) :: l_b                      ! bracketing length
      real(kind=rel_kind) :: origin(n_dim)            ! origin of ray
      real(kind=rel_kind) :: direction(n_dim)         ! direction of ray

      ! bracket root (tau=0) between 0 and tau_est
      tau_b=-tau
      tau_0=self%tau_sph()-tau
      l_b=0._rel_kind
      l_0=length

      do

         ! calculate derivatives
         dtau_dl=self%inv_mfp()
         d2tau_dl2=2._rel_kind*((tau_b-tau_0)/(l_b-l_0)**2-dtau_dl/(l_b-l_0))

         ! set new value of l
         l_1=l_0-2._rel_kind*tau_0/(dtau_dl+sqrt(dtau_dl**2-2._rel_kind*tau_0*d2tau_dl2))

         length=l_1
         origin=self%path%origin
         direction=self%path%direction
         call self%path%initialise(origin,direction,length)
         call self%stock_sigma()

         ! exit if l_0 and l_1 have converged
         if (abs(l_0-l_1)/l_1<ray_conv) exit

         ! otherwise, set up next iteration
         tau_1=self%tau_sph()-tau

         ! make sure tau_0 and tau_b are either side of solution
         if (tau_0*tau_1<0._rel_kind) then
            ! tau_0 and tau_1 are either side of root (tau=0)
            l_b=l_0
            tau_b=tau_0
         end if

         l_0=l_1
         tau_0=tau_1

      end do

      return

   end subroutine

   ! initialise a ray trace (self%initialise has already been called)
   pure subroutine ray_trace_initialise(self,position,direction)

      ! argument declarations
      class(ray),intent(inout) :: self                   ! ray object
      real(kind=rel_kind),intent(in) :: position(n_dim)  ! position of ray trace
      real(kind=rel_kind),intent(in) :: direction(n_dim) ! direction of ray trace (away from position)

      ! set almost infinitely long path
      call self%path%initialise(position,direction,self%max_length)

      ! find particles along path
      self%n_item=0
      call self%find_particles(self%sph_tree%root_node)

      ! calculated geometric quantities and col density
      call self%stock_geometric()
      call self%stock_sigma()

      ! sort particles along ray
      call ray_particle_sort(self%item(:self%n_item))

      return

   end subroutine

   ! calculate intensity from ray trace (ray_trace_initialise has already been called)
   pure function ray_trace_i(self,lambda_ob,v_ob,i_bg) result (i_value)

      ! argument declarations
      class(ray),intent(in) :: self                      ! ray object
      real(kind=rel_kind),intent(in) :: lambda_ob        ! observer rest frame wavelength
      real(kind=rel_kind),intent(in) :: v_ob(n_dim)      ! observer rest frame velocity
      real(kind=rel_kind),intent(in) :: i_bg             ! background intensity

      ! result declaration
      real(kind=rel_kind) :: i_value                     ! monochromatic intensity at position

      ! variable declaration
      integer(kind=int_kind) :: i                        ! counter
      real(kind=rel_kind) :: lambda_em                   ! wavelength in emission rest frame
      real(kind=rel_kind) :: j_value                     ! mass emissivity
      real(kind=rel_kind) :: kappa_ext                   ! extinction coeff
      real(kind=rel_kind) :: a                           ! albedo

      ! loop backwards over ray and calculate j_value
      i_value=i_bg
      do i=self%n_item,1,-1

         ! observed wavelength in emission rest frame
         lambda_em=lambda_ob*(dot_product(v_ob-self%item(i)%v,self%path%direction)/c_light+1._rel_kind)

         ! calculate opacity and albedo
         call self%dust_prop%dust_mass_ext_and_albedo(lambda_em,kappa_ext,a)

         ! sink term
         i_value=i_value*exp(-kappa_ext*self%item(i)%sigma*self%item(i)%f_sub)

         ! emission component source term
         j_value=self%dust_prop%mono_mass_emissivity(lambda_em,self%item(i)%a_dot)

         ! scattering source term
         if (associated(self%item(i)%particle_ptr%lambda_array)) then

            j_value=j_value+self%item(i)%particle_ptr%a_dot_scatter(lambda_em)/(4._rel_kind*pi)

         end if

         ! add source term
         i_value=i_value+j_value*(1._rel_kind-exp(-kappa_ext*self%item(i)%sigma*self%item(i)%f_sub))/kappa_ext

      end do

      return

   end function

   ! calculate optical depth from ray trace (ray_trace_initialise has already been called)
   pure function ray_trace_tau(self,lambda_ob,v_ob) result (tau_value)

      ! argument declarations
      class(ray),intent(in) :: self                      ! ray object
      real(kind=rel_kind),intent(in) :: lambda_ob        ! observer rest frame wavelength
      real(kind=rel_kind),intent(in) :: v_ob(n_dim)      ! observer rest frame velocity

      ! result declaration
      real(kind=rel_kind) :: tau_value                   ! optical depth from infinity to position

      ! variable declaration
      integer(kind=int_kind) :: i                        ! counter
      real(kind=rel_kind) :: lambda_em                   ! wavelength in emission rest frame

      ! tau value
      tau_value=0._rel_kind
      do i=1,self%n_item
         lambda_em=lambda_ob*(dot_product(v_ob-self%item(i)%v,self%path%direction)/c_light+1._rel_kind)
         tau_value=tau_value+self%item(i)%sigma*self%dust_prop%dust_mass_ext(lambda_em)*self%item(i)%f_sub
      end do

      return

   end function

   ! ray trace integrated  emissivity (i.e. no extinction)
   pure function ray_trace_j(self,lambda_ob,v_ob) result (j_value)

      ! argument declarations
      class(ray),intent(in) :: self                      ! ray object
      real(kind=rel_kind),intent(in) :: lambda_ob        ! observer rest frame wavelength
      real(kind=rel_kind),intent(in) :: v_ob(n_dim)      ! observer rest frame velocity

      ! result declaration
      real(kind=rel_kind) :: j_value                     ! integrated emissivity from infinity to position

      ! variable declaration
      integer(kind=int_kind) :: i                        ! counter
      real(kind=rel_kind) :: lambda_em                   ! wavelength in emission rest frame

      ! tau value
      j_value=0._rel_kind
      do i=1,self%n_item
         lambda_em=lambda_ob*(dot_product(v_ob-self%item(i)%v,self%path%direction)/c_light+1._rel_kind)
         j_value=j_value+self%item(i)%sigma*self%dust_prop%mono_mass_emissivity(lambda_em,self%item(i)%a_dot)*self%item(i)%f_sub
      end do

      return

   end function

   ! find all particles along ray
   pure recursive subroutine find_particles(self,tree_node)

      ! argument declarations
      class(ray),intent(inout) :: self                  ! ray object
      type(binary_tree_node),intent(inout) :: tree_node ! binary tree node object

      ! variable declarations
      type(ray_particle),allocatable :: temp_item(:)    ! temporary ray particle array
      integer(kind=int_kind) :: i                       ! counter
      logical(kind=log_kind),allocatable :: live_particles(:)   ! mask for "live" particles

      if (associated(tree_node%left_node)) then

         ! walk tree if not at leaf node
         if (tree_node%left_node%ray_aabb_intersection(self%path))&
            &call self%find_particles(tree_node%left_node)
         if (tree_node%right_node%ray_aabb_intersection(self%path))&
            &call self%find_particles(tree_node%right_node)

      else

         ! at leaf node.
         ! build live_particle array
         allocate(live_particles(size(tree_node%particle_array)))
         do concurrent (i=1:size(tree_node%particle_array))

            live_particles(i)=&
               &(sum((self%path%origin+&
               &dot_product(tree_node%particle_array(i)%r-self%path%origin,self%path%direction)*&
               &self%path%direction-&
               &tree_node%particle_array(i)%r)**2)*&
               &tree_node%particle_array(i)%inv_h**2)<self%sph_kernel%r_support**2

         end do

         ! first check if there's enough storage in item array, resize if necessary
         if (self%n_item+count(live_particles)>size(self%item)) then

            allocate(temp_item(2*size(self%item)+count(live_particles)))
            temp_item(:size(self%item))=self%item
            call move_alloc(temp_item,self%item)

         end if

         ! add live particles to ray
         do i=1,size(tree_node%particle_array)

            if (live_particles(i)) then

               self%n_item=self%n_item+1
               call self%item(self%n_item)%initialise(tree_node%particle_array(i))

            end if

         end do
         deallocate(live_particles)

      end if

      return

   end subroutine

   ! calculate geometric properties
   pure subroutine stock_geometric(self)

      ! argument declarations
      class(ray),intent(inout) :: self                  ! ray object

      ! variable declarations
      integer(kind=int_kind) :: i                       ! counter

      do concurrent (i=1:self%n_item)

         ! calculate particle position along ray
         self%item(i)%t_r=&
            &dot_product(self%item(i)%r-self%path%origin,self%path%direction)

         ! calculate impact parameter
         self%item(i)%b=&
            &norm2(self%path%origin+&
            &self%item(i)%t_r*self%path%direction-&
            &self%item(i)%r)*&
            &self%item(i)%inv_h

         ! calculate particle-origin distance
         self%item(i)%s_0=&
            &norm2(self%path%origin-&
            &self%item(i)%r)*&
            &self%item(i)%inv_h

         ! calculate particle-terminus distance
         self%item(i)%s_1=&
            &norm2(self%path%terminus-&
            &self%item(i)%r)*&
            &self%item(i)%inv_h

      end do

      return

   end subroutine

   ! calculate optical properties
   pure subroutine stock_optical(self)

      ! argument declarations
      class(ray),intent(inout) :: self                  ! ray object

      ! variable declarations
      integer(kind=int_kind) :: i                       ! counter

      do concurrent (i=1:self%n_item)

         ! calculate dust mass extinction and albedo
         self%item(i)%lambda_ob=self%lambda_em*&
            &(dot_product(self%item(i)%v-self%v_em,self%path%direction)/c_light+1._rel_kind)
         call self%dust_prop%dust_mass_ext_and_albedo(self%item(i)%lambda_ob,self%item(i)%kappa_ext,self%item(i)%a)

         ! adjust opacity for f_sub
         self%item(i)%kappa_ext=self%item(i)%kappa_ext*self%item(i)%f_sub

      end do

      return

   end subroutine

   ! calculate optical properties
   pure subroutine stock_mrw_optical(self)

      ! argument declarations
      class(ray),intent(inout) :: self                  ! ray object

      ! variable declarations
      integer(kind=int_kind) :: i                       ! counter

      do concurrent (i=1:self%n_item)

         self%item(i)%kappa_ext=self%dust_prop%mrw_inv_planck_ext(self%item(i)%a_dot)

         ! adjust opacity for f_sub
         self%item(i)%kappa_ext=self%item(i)%kappa_ext*self%item(i)%f_sub

      end do

      return

   end subroutine

   ! calculate quantities along populated ray
   ! similar to stock, but calculates fewer quantities
   pure subroutine stock_sigma(self)

      ! argument declarations
      class(ray),intent(inout) :: self                  ! ray object

      ! variable declarations
      integer(kind=int_kind) :: i                       ! counter
      real(kind=rel_kind) :: sigma_0                    ! column density 0
      real(kind=rel_kind) :: sigma_1                    ! column density 1

      do concurrent (i=1:self%n_item)

         ! calculate particle-terminus distance
         self%item(i)%s_1=&
            &norm2(self%path%terminus-&
            &self%item(i)%r)*&
            &self%item(i)%inv_h

         ! calculate column density
         sigma_0=self%sph_kernel%sigma(self%item(i)%b,self%item(i)%s_0)
         sigma_1=self%sph_kernel%sigma(self%item(i)%b,self%item(i)%s_1)
         self%item(i)%sigma=self%item(i)%m*self%item(i)%inv_h**(n_dim-1)*&
            &merge(sigma_0+sigma_1,abs(sigma_0-sigma_1),&
            &self%item(i)%t_r>0._rel_kind.and.self%item(i)%t_r<self%path%length)

      end do

      return

   end subroutine

   ! update particle energy absorption rates
   subroutine update_absorption_rate(self)

      ! argument declarations
      class(ray),intent(inout) :: self                  ! ray object

      ! variable declarations
      integer(kind=int_kind) :: i                       ! counter
      integer(kind=int_kind) :: j                       ! index

      do i=1,self%n_item

         call atomic_real_add(self%item(i)%particle_ptr%a_dot_new,&
            &self%item(i)%sigma*self%item(i)%kappa_ext*(1._rel_kind-self%item(i)%a)*self%l_chunk)

         ! update scattered light histogram, if allocated.
         if (associated(self%item(i)%particle_ptr%lambda_array)) then

            if (self%item(i)%lambda_ob>=self%item(i)%particle_ptr%lambda_array(1).and.&
               &self%item(i)%lambda_ob<=self%item(i)%particle_ptr%lambda_array(&
               &size(self%item(i)%particle_ptr%lambda_array))) then

               j=binary_search(self%item(i)%lambda_ob,self%item(i)%particle_ptr%lambda_array)
               call atomic_real_add(self%item(i)%particle_ptr%a_dot_scatter_array(j),&
                  &self%item(i)%sigma*self%item(i)%kappa_ext*self%item(i)%a*self%l_chunk)

            end if

         end if

      end do

      return

   end subroutine

   ! get absorption rate at path%length for ray object
   pure function a_dot_sph(self) result (a_dot_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: a_dot_value                    ! absorption rate path%length

      a_dot_value=sum(self%item(:self%n_item)%m*&
         &self%item(:self%n_item)%inv_rho*&
         &self%item(:self%n_item)%inv_h**(n_dim)*&
         &self%item(:self%n_item)%a_dot*&
         &self%sph_kernel%w(self%item(:self%n_item)%s_1))

      return

   end function

   ! get absorption rate at origin for ray object
   pure function a_dot_o_sph(self) result (a_dot_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: a_dot_value                    ! absorption rate path%length

      a_dot_value=sum(self%item(:self%n_item)%m*&
         &self%item(:self%n_item)%inv_rho*&
         &self%item(:self%n_item)%inv_h**(n_dim)*&
         &self%item(:self%n_item)%a_dot*&
         &self%sph_kernel%w(self%item(:self%n_item)%s_0))

      return

   end function

   ! get velocity at path%length for ray object
   pure function v_sph(self) result (v_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: v_value(n_dim)             ! velocity path%length

      ! variable declaration
      integer(kind=int_kind) :: i                       ! counter

      v_value=0._rel_kind
      do i=1,self%n_item

         v_value=v_value+self%item(i)%m*&
            &self%item(i)%inv_rho*&
            &self%item(i)%inv_h**(n_dim)*&
            &self%item(i)%v*&
            &self%sph_kernel%w(self%item(i)%s_1)

      end do

      return

   end function

   ! get rest albedo at path%length for ray object
   pure function a_sph(self) result (a_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: a_value                    ! albedo path%length

      a_value=sum(self%item(:self%n_item)%m*&
         &self%item(:self%n_item)%inv_rho*&
         &self%item(:self%n_item)%inv_h**(n_dim)*&
         &self%item(:self%n_item)%a*&
         &self%sph_kernel%w(self%item(:self%n_item)%s_1))

      return

   end function

   ! smoothing length path%length for ray object
   pure function h_sph(self) result (h_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: h_value                    ! smoothing length path%length

      h_value=sum(self%item(:self%n_item)%inv_h**(n_dim)*&
         &self%sph_kernel%w(self%item(:self%n_item)%s_1))

      h_value=merge(h_value**(-1._rel_kind/real(n_dim,rel_kind)),0._rel_kind,h_value>0._rel_kind)

      return

   end function

   ! planck averaged mean free path path%length for ray object
   pure function ave_inv_mfp_sph(self) result (ave_inv_mfp_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: ave_inv_mfp_value          ! planck average inverse mean free path

      ave_inv_mfp_value=sum(self%item(:self%n_item)%m*&
         &self%item(:self%n_item)%inv_h**(n_dim)*&
         &self%dust_prop%mrw_inv_planck_ext(self%item(:self%n_item)%a_dot)*self%item(:self%n_item)%f_sub*&
         &self%sph_kernel%w(self%item(:self%n_item)%s_1))

      return

   end function

   pure function grad_ave_inv_mfp_sph(self) result (grad_ave_inv_mfp_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: grad_ave_inv_mfp_value(n_dim)  ! grad_ave_inv_mfp at path%length

      ! variable declarations
      integer(kind=int_kind) :: i                       ! counter

      grad_ave_inv_mfp_value=0._rel_kind
      do i=1,self%n_item

         grad_ave_inv_mfp_value=grad_ave_inv_mfp_value+self%item(i)%m*&
            &self%item(i)%inv_h**(n_dim+2)*&
            &self%dust_prop%mrw_inv_planck_ext(self%item(i)%a_dot)*self%item(i)%f_sub*&
            &self%sph_kernel%dw_dr(self%item(i)%s_1)*&
            &(self%path%terminus-self%item(i)%r)/self%item(i)%s_1

      end do

      return

   end function

   ! get the optical depth along ray
   pure function tau_sph(self) result (tau_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: tau_value                  ! optical depth along ray

      tau_value=sum(self%item(:self%n_item)%sigma*&
         &self%item(:self%n_item)%kappa_ext)

      return

   end function

   ! get inverse mean free path at path%length for ray object
   pure function inv_mfp(self) result (inv_mfp_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: inv_mfp_value              ! inv_mfp at path%length

      inv_mfp_value=sum(self%item(:self%n_item)%m*&
         &self%item(:self%n_item)%inv_h**(n_dim)*&
         &self%item(:self%n_item)%kappa_ext*&
         &self%sph_kernel%w(self%item(:self%n_item)%s_1))

      return

   end function

   pure function grad_inv_mfp(self) result (grad_inv_mfp_value)

      ! argument declarations
      class(ray),intent(in) :: self                     ! ray object

      ! result declaration
      real(kind=rel_kind) :: grad_inv_mfp_value(n_dim)  !grad_inv_mfp at path%length

      ! variable declarations
      integer(kind=int_kind) :: i                       ! counter

      grad_inv_mfp_value=0._rel_kind
      do i=1,self%n_item

         grad_inv_mfp_value=grad_inv_mfp_value+self%item(i)%m*&
            &self%item(i)%inv_h**(n_dim+2)*&
            &self%item(i)%kappa_ext*&
            &self%sph_kernel%dw_dr(self%item(i)%s_1)*&
            &(self%path%terminus-self%item(i)%r)/self%item(i)%s_1

      end do

      return

   end function

   ! sort ray items in order of position along ray
   pure recursive subroutine ray_particle_sort(array)

      ! argument declarations
      type(ray_particle),intent(inout) :: array(:) ! array to be sorted

      ! variable declarations
      integer(kind=int_kind) :: i               ! counter
      integer(kind=int_kind) :: pivot           ! pivot element

      ! sort array
      if (size(array)>1) then

         ! set pivot to middle element
         pivot=1+(size(array)-1)/2

         ! move pivot to end of array
         call ray_particle_swap(array(pivot),array(size(array)))

         ! loop over array
         pivot=1
         do i=1,size(array)-1

            if (array(i)%t_r<=array(size(array))%t_r) then

               call ray_particle_swap(array(pivot),array(i))
               pivot=pivot+1

            end if

         end do

         ! move pivot back
         call ray_particle_swap(array(pivot),array(size(array)))

         ! sort rest of array
         call ray_particle_sort(array(:pivot-1))
         call ray_particle_sort(array(pivot+1:))

      end if

      return

   end subroutine

   ! swaps ray item a with ray item b
   pure subroutine ray_particle_swap(a,b)

      ! argument declarations
      type(ray_particle),intent(inout) :: a
      type(ray_particle),intent(inout) :: b

      ! variable declarations
      type(ray_particle) :: temp

      temp=a
      a=b
      b=temp

      return

   end subroutine

end module


        SUBROUTINE ZCLDOP(ROOT,IREAD,PERIOD,TOTEXP,DELTAT,
     *                          DOPLER,ISTAT)
*
*  Module number:
*
*  Module name: ZCLDOP
*
*  Keyphrase:
*  ----------
*	Compute doppler wieghts
*
*  Description:
*  ------------
*	This routine computes the percent of time spent at each doppler
*	offset.  These are computed by dividing the observation into
*	DELTAT time segments and computing the deflection offset for each
*	segment.  The SHP packet time is used as the start of the readout
*	and the packet time of the first science packet is used as the
*	ending time of the readout
*
*  FORTRAN name: zcldop.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*	Rootname.shh		I	standard header packet.
*					used to get zero spacecraft
*					time and the starting observation
*					time
*	Rootname.d0h		I	used to get the ending observation
*					time
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*	ztimev, zsctim
*
*  SDAS:
*	ZMSPUT
*
*  History:
*  --------
*  Version      Date        Author          Description
*	1	May 89	D. Lindler	Designed and coded
*		Sep 90	S. Hulbert	Account for non-zero spacecraft time
*					at UTC0
*		Feb 91	S. Hulbert	Corrected computation of UTC0
*	2	May 91	S. Hulbert	All packet times in MJD
*       2.1     Nov 96  M. De La Pena   Added STPTIM to HRSDEF
*-------------------------------------------------------------------------------
*
* INPUTS:
*       ROOT = root file name
*       IREAD = readout
*       PERIOD = orbital period in minutes
*       TOTEXP = total exposure time all bins (seconds)
*       DELTAT = deflection update interval in 1/8 second UNITS
*
* OUTPUTS:
*       DOPLER - doppler weights.  DOPLER(i) gives the percent of
*               time spent at deflection offset i-200.
*       ISTAT - error status
*_-------------------------------------------------------------------------
        INTEGER IREAD,ISTAT
        REAL PERIOD,TOTEXP,DELTAT,DOPLER(400)
        CHARACTER*64 ROOT
C
C     FILE I/O ACCESS MODES
C
      INTEGER   RDONLY
      PARAMETER (RDONLY = 1)
C
C     ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C			/HRSMOD/
C Common block containing observing mode parameters
C
C   GRAT - grating mode
C   DET - detector
C   SCLAMP - spectral calibration lamp
C   CARPOS - carrousel position
C   OBSMOD - observation mode (DIR, ACC, TAR)
C   APER - aperture (LSA, SSA, SC1, SC2)
C
        CHARACTER*3 OBSMOD,APER
        CHARACTER*5 GRAT
        INTEGER DET,SCLAMP,CARPOS
        COMMON /HRSMOD/ DET,SCLAMP,CARPOS
        COMMON /HRSMD1/ GRAT,OBSMOD,APER
C
C
C                       /HRSDEF/
C Deflection pattern common block
C       NBINS - Number of supstep bins
C       NINIT - number of initial deflection pairs
C       IXDEF(5) - initial x-deflections
C       XDEF(7) - x-deflections for each bin
C       YDEF(7) - y-deflections for each bin
C       RCODES(7) - repeat codes for each bin
C       BINIDS(7) - substep bins ids for each bin
C       SAMPLE(7) - starting sample position for each spectra
C       LINE(7) - starting line position for each spectra
C       DELTAS(7) - sample position increment for each spectra
C       HOFF(7),VOFF(7) - horizontal and vertical offsets
C       DOPMAG, DOPZER - dopler magnitude and zero time
C       XDCAL, XDCALP - x-deflection calibration parameters
C       STPTIM - integration time at each step pattern position
C
        INTEGER NBINS,NINIT,IXDEF(5),XDEF(7),YDEF(7),RCODES(7)
        INTEGER BINIDS(7),HOFF(7),VOFF(7)
        REAL SAMPLE(7),LINE(7),DELTAS(7),DOPMAG,XDCAL,XDCALP
        DOUBLE PRECISION DOPZER,STPTIM
        COMMON /HRSDEF/ DOPZER,STPTIM,NBINS,NINIT,IXDEF,XDEF,YDEF,
     *                  RCODES,BINIDS,SAMPLE,LINE,DELTAS,HOFF,VOFF,
     *                  DOPMAG,XDCAL,XDCALP
C
C                         /HRSGPR/
C
C Common block for output group parameter storage
C
C        PKTIME - packet times in MJD
C        ERRCNT - error counts (.d0h)
C        FILLCN - fill counts  (.d0h)
C        SCOEF - sample coefficients
C        EXPO - exposure times
C
        INTEGER ERRCNT(7),FILLCN(7)
        REAL SCOEF(4,7),EXPO(7)
        DOUBLE PRECISION PKTIME(7)
        COMMON /HRSGPR/PKTIME,ERRCNT,FILLCN,SCOEF,EXPO
C
C                       /HRSIO/
C Common Block containting input/output parameters
C
C   IDS(20) - input file IDs
C               1 - .shh
C               2 - .ulh
C               3 - .d0h
C               4 - .q0h
C               5 - .x0h
C               6 - .xqh
C               7 - .c0h
C               8 - .c1h
C               9 - .cqh
C               10 - .c2h
C               11 - .c3h
C               12 - .c4h
C               13 - .c5h
C   GCOUNT(20) - group counts for input files
C   MERGE - Number of bins merged in output spectra
C   OBSRPT - observation repeats
C   NGOUT - number of output groups
C   NGSDT - number of output groups for special diode files
C   READNO - readout number
C   NSOUT - number of samples in the output data sets
C
        INTEGER IDS(20),MERGE,OBSRPT,NGOUT,GCOUNT(20),READNO,NSOUT,NGSDT
        COMMON /HRSIO/ IDS,GCOUNT,MERGE,OBSRPT,NGOUT,READNO,NSOUT,NGSDT
C
	DOUBLE PRECISION PI
	PARAMETER (PI = 3.1415926535898D0)
C
C Local variables
C
        CHARACTER*80 CONTXT
        DOUBLE PRECISION TIME1,TIME2
C                                    --->last two SHP times
        DOUBLE PRECISION ETIME
C                                    --->end time of the observation
        DOUBLE PRECISION OTIME
C                                    --->total observation time
        DOUBLE PRECISION STIME
C                                    --->start time
        INTEGER NINT
C                                    --->number of deltat intervals
        CHARACTER*64 FNAME
C                                    --->File name
        INTEGER ISHP,NSHP
C                                    --->number and current group in SHP file
        REAL SCALE
C                                    --->2*pi/peroid
        INTEGER DX
C                                    --->deflection offset
        DOUBLE PRECISION PKTSHP
C				     --->packet time from shp
        INTEGER POS,I
        REAL DMIN,DMAX
        DOUBLE PRECISION DIFF
C
C-----------------------------------------------------------------------------
C
C Initialization on first read
C
        IF(DOPMAG.EQ.0.0) GO TO 1000
C
C IF DDLINK then no change in dopler deflection after first readout
C
        IF((IREAD.GT.1).AND.(OBSMOD.EQ.'DIR')) GO TO 1000
C
C Initialize dopler array
C
        DO 3 I=1,400
            DOPLER(I)=0.0
3	CONTINUE
C
C first time through
C
        IF(IREAD.EQ.1)THEN
C
C check limits
C
                IF((DOPMAG.GT.199.0).OR.(DOPMAG.LT.0.0))THEN
                        CONTXT='ERROR: Invalid DOPMAG in .D0H file'
                        GO TO 999
                ENDIF
                IF((PERIOD.LT.50.0).OR.(PERIOD.GT.300.0))THEN
                        CONTXT='ERROR: Invalid orbital period in CCR3'
                        GO TO 999
                ENDIF
C
C convert deltat to seconds
C
                DELTAT = DELTAT/8.0
                IF(DELTAT.LT.1.0)THEN
                        CONTXT='ERROR: DELTA-T in CCR3 is too small'
                        GO TO 999
                ENDIF
C
C convert period to seconds
C
                PERIOD = PERIOD * 60.0
                SCALE = 2.0 * PI / PERIOD
C
C initialize a few things
C
                TIME1=0.0
                TIME2=0.0
                NSHP=GCOUNT(1)
                ISHP=1
        ENDIF
C
C set the end time of the observation to the packet time of
C the first packet in the d0h file
C
	ETIME = PKTIME(1)
C
C Find begin time from .shh file
C
10	CALL ZFNAME(ROOT,'shh',ISHP,0,FNAME)
        CALL UUOPGR(IDS(1),ISHP,DMIN,DMAX,0,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR: switching groups in the .shh file '
                GO TO 999
        ENDIF
C
C get the next begin time
C
        CALL UHDGSD(IDS(1),'PKTTIME',PKTSHP,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR: getting PKTTIME from '//FNAME
                GO TO 999
        ENDIF
C
C set the last begin time
C note: time1 and time2 hold the two shp times that end up bracketing
C the end time from the d0h. time1 should end up holding the
C necessary begin time
C
	TIME2 = PKTSHP
C
C now make sure time1 has something in it the first time through
C
        IF (TIME1 .EQ. 0.0) TIME1 = TIME2
C
C if time2(shp) is past etime(d0h) then time1 is the one we want
C
        IF (TIME2 .GT. ETIME) THEN
	    STIME = TIME1
	    GO TO 100
	ENDIF
C
C if we made it here we need to try again:
C go point to next group in the shp to be read
C
        ISHP=ISHP+1
C
C if we've gone throught all groups of the shp save the latest begin time
C and go try to finish
C
        IF(ISHP.GT.NSHP)THEN
            STIME = TIME2
            GO TO 100
        ENDIF
C
C save the last time and go get the next
C
        TIME1=TIME2
        GO TO 10
C
C compute observation length in seconds
C
100     OTIME = (ETIME - STIME) * 86400.0D0
C
C Compare observation time with total exposure time
C
        DIFF = OTIME-TOTEXP
        IF((DIFF.LT.0).OR.(DIFF.GT.5000))THEN
           CONTXT='Invalid observation time computed for'//
     *                 ' doppler correction'
           GO TO 999
        ENDIF
C
C number of intervals
C

        NINT = OTIME/DELTAT + 1
C
C compute doppler weights (put them in the 'middle' of the array)
C deltim is the number of seconds since dopzer
C
	DELTIM = (STIME - DOPZER) * 86400.
        DO 200 I=1,NINT
            DX = DOPMAG * SIN(SCALE*(I*DELTAT+DELTIM)) + 0.5
            POS = DX + 200
            DOPLER(POS)=DOPLER(POS)+1
200     CONTINUE
C
C normalize doppler weights
C
        DO 300 I=1,400
300             DOPLER(I)=DOPLER(I)/NINT
C
        ISTAT = 0
        GO TO 1000
999     CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END