module ast_ephem
  !  Ephemeride computations, global parameters
  real(kind=8), parameter :: aukm=1.49597870d8   ! astronomical units to km conversion, IAU 1976
  real(kind=8), parameter :: mlt = 0.01230002d0  ! moon over earth mass ratio, IAU 1976 constant
  real(kind=8), parameter :: scale=1.D0/(1.d0+1D0/mlt)     ! 1 / (1+mt/ml)
  !
  !  Vector integration memory, defined in EPHSTA routine
  integer(kind=4), parameter :: ivect_out=0 ! out of Solar System
  integer(kind=4), parameter :: ivect_moon=1 ! MOON
  integer(kind=4), parameter :: ivect_sun=2 ! SUN
  integer(kind=4), parameter :: ivect_pla=3 ! PLANET
  !
  integer(kind=4) :: mvect, nvect         ! maximum number of component vectors
  parameter (mvect=4)          !
  logical :: vecdly(mvect)        ! indicate vector is computed at t-tau
  integer(kind=4) :: vecnum(mvect)        ! vector identification number in file
  real(kind=8) :: vecmul(mvect)         ! weight of each vector
  !!      common /vector/ vecmul, vecnum, vecdly, nvect
  !!      save /vector/
  !
  ! Stuff concerning the file vsop87.dat
  !
  integer(kind=4), parameter :: mfr=10000
  integer(kind=4), parameter :: mterm=8000
  integer(kind=4), parameter :: mbodies=10
  integer(kind=4), parameter :: mcoord=3
  integer(kind=4), parameter :: malpha=5
  integer(kind=4) ::  n_freq ! number of frequencies
  integer(kind=4) ::  n_term(mbodies,mcoord,0:malpha), i_rec_n_term ! number of terms for each series, and pointer
  integer(kind=4) ::  i_rec(mbodies,mcoord,0:malpha), i_rec_i_rec ! record number for each series, and pointer
  integer(kind=4) ::   i_rec_fr      ! record number for the list of frequencies
  integer(kind=4) ::   i_freq(mterm) ! frequency pointer for each term
  integer(kind=4) ::   elun=0   ! Logical unit number
  real(kind=8) :: efr(mfr)   ! frequencies
  real(kind=8) :: f(mterm), g(mterm), cs(mterm), ss(mterm)  ! cosine and sine term for each term
  !
  real(kind=8) :: oldtjj=-1.d30 ! A very old date to get started with...
  !
  !!      common /vsop/ fr, f, g, cs, ss, oldtjj,                                &
  !!     & n_freq,n_term,i_rec,i_rec_fr,i_freq,                                  &
  !!     & i_rec_i_rec, i_rec_n_term, lun
  !!      save /vsop/
end module ast_ephem
!
subroutine ephini(error)
  use gildas_def
  use gbl_format
  use gbl_message
  use gkernel_interfaces
  use ast_ephem
  !---------------------------------------------------------------------
  ! @ public
  ! Open direct access file of VSOP87 ephemeris.
  ! R. Lucas 29-apr-1994
  !---------------------------------------------------------------------
  logical, intent(out) :: error     !
  ! Local
  character(len=4) :: cfile
  character(len=256) :: file
  integer(kind=4) :: ier, irecord, nf, init(5)
  !
  if (elun.ne.0) return  ! Already done
  !
  error = sic_getlun (elun).ne.1
  if (error) return
  if (.not.sic_query_file('gag_ephemeris','data#dir:','',file)) then
    call astro_message(seve%f,'EPHINI','gag_ephemeris not found')
    error = .true.
    return
  endif
  nf = lenc(file)
  open(unit=elun,file=file(1:nf),form='unformatted', status='old',  &
       access='direct', recl=128*facunf, iostat = ier, action = 'read')
  if (ier.ne.0) then
    call sic_frelun(elun)
    call putios('F-VSOP87,  ',ier)
    error = .true.
    return
  endif
  read(elun,rec=1) cfile
  !
  call eph_convert (cfile)
  !
  irecord = 1
  ! one reads 5 numbers now ...
  call readi4(elun,irecord,5,init,error)
  if (error) return
  i_rec_n_term = init(2)
  i_rec_i_rec = init(3)
  i_rec_fr = init(4)
  n_freq = init(5)
  irecord = i_rec_n_term
  call readi4(elun,irecord,180,n_term,error)
  if (error) return
  irecord = i_rec_i_rec
  call readi4(elun,irecord,180,i_rec,error)
  if (error) return
  irecord = i_rec_fr
  call readr8(elun,irecord,n_freq,efr,error)
end subroutine ephini
!
subroutine ephclose(error)
  use gkernel_interfaces
  use ast_ephem
  !---------------------------------------------------------------------
  ! @ public
  ! Close the ephemeris file and free its logical unit
  !---------------------------------------------------------------------
  logical, intent(inout) :: error   !
  ! Local
  integer(kind=4) :: ier
  !
  close(unit=elun,iostat=ier)
  if (ier.ne.0)  error = .true.
  !
  ier = gag_frelun(elun)
  if (ier.ne.0)  error = .true.
  !
end subroutine ephclose
!
subroutine vsop87(tjj,ico,ider,prec,r,error)
  use gildas_def
  use gbl_message
  use ast_ephem
  !---------------------------------------------------------------------
  ! @ private
  ! Compute object position and velocities from VSOP87 ephemeris.
  !
  ! ICO    1 - 8 = Mercury to Neptune, relative to Sun
  !            9 = Earth/Moon barycenter, relative to Sun
  !           10 = Sun, relative to Solar system barycenter
  ! R(3,0:IDER) position (1-3) vector and derivatives (in au, au/day, au/day**2)
  !---------------------------------------------------------------------
  real(kind=8),    intent(in)    :: tjj          ! Julian date
  integer(kind=4), intent(in)    :: ico          ! Body identifier
  integer(kind=4), intent(in)    :: ider         ! Number of derivatives to compute (0 to 2)
  real(kind=8),    intent(in)    :: prec         ! Precision 0 to 0.01; 0 is maximal precision
  real(kind=8),    intent(out)   :: r(3,0:ider)  ! Position vector and derivatives
  logical,         intent(inout) :: error        !
  ! Local
  character(len=*), parameter :: rname='VSOP'
  character(len=filename_length) :: vsopname
  character(len=message_length) :: mess
  real(kind=8) :: dga(mbodies), t(-2:5), t2000, a1000, q, a, p, f0, f1
  integer(kind=4) :: i, iv, it, ntt, irecord, if, id, j
  ! Data
  data dga/0.3871d0, 0.7233d0, 1.d0, 1.5237d0, 5.2026d0, 9.5547d0,  &
           19.2181d0, 30.1096d0, 0.01d0, 1.d0/
  data t /2*0.d0, 1.d0, 5*0.d0/
  data t2000 /2451545.d0/
  data a1000 /365250.d0/
  !
  ! Sanity check
  if (ico.lt.0 .or. ico.gt.mbodies) then
    write(mess,'(a,i0)')  'Invalid body id. #',ico
    call astro_message(seve%e,rname,mess)
    error = .true.
    return
  endif
  !
  ! Reset the cosines if time has changed.
  if (oldtjj.ne.tjj) then
    do i=1, mterm
      cs(i) = 3.
    enddo
    oldtjj = tjj
  endif
  id = max(0,min(2,ider))
  !
  do i=1, 3
    do j= 0, id
      r(i,j) = 0
    enddo
  enddo
  t(1) = (tjj - t2000) / a1000
  do it=2, 5
    t(it) = t(1)*t(it-1)
  enddo
  if (prec.lt.0.d0 .or. prec.gt.1d-2) then
    error = .true.
    return
  endif
  q = max(3.d0,-log10(prec+1d-50))
  !
  do iv=1, 3
    do it = 0, 5
      p = prec*dga(ico)/10.d0/(q-2)/  &
          (abs(t(it))+it*abs(t(it-1))*1.d-4+1.d-50)
      ntt = n_term(ico,iv,it)
      if (ntt.gt.0) then
        irecord = i_rec(ico,iv,it)
        call readi4(elun,irecord,ntt,i_freq,error)
        if (error) then
          inquire(unit=elun,name=vsopname)
          write (mess,'(a,1x,a,1x,i0,1x,i0)') 'Error reading',trim(vsopname),irecord,ntt
          call astro_message(seve%e,rname,mess)
          return
        endif
        call readr8(elun,irecord,ntt,f,error)
        if (error) then
          inquire(unit=elun,name=vsopname)
          write (mess,'(a,1x,a,1x,i0,1x,i0)') 'Error reading',trim(vsopname),irecord,ntt
          call astro_message(seve%e,rname,mess)
          return
        endif
        call readr8(elun,irecord,ntt,g,error)
        if (error) then
          inquire(unit=elun,name=vsopname)
          write (mess,'(a,1x,a,1x,i0,1x,i0)') 'Error reading',trim(vsopname),irecord,ntt
          call astro_message(seve%e,rname,mess)
          return
        endif
        p = p*p
        a = 2*p
        i = 1
        do while (i.le.ntt .and. a.ge.p)
          a = f(i)**2+g(i)**2
          if = i_freq(i)
          if (cs(if).gt.2) then
            cs(if) = cos(efr(if)*t(1))
            ss(if) = sin(efr(if)*t(1))
          endif
          f0 = f(i)*cs(if)+g(i)*ss(if)
          r(iv,0) = r(iv,0) + f0*t(it)
          if (id.ge.1) then
            f1 = -f(i)*ss(if)+g(i)*cs(if)
            r(iv,1) = r(iv,1) + f0*it*t(it-1) + f1*efr(if)*t(it)
          endif
          if (id.ge.2) then
            r(iv,2) = r(iv,2) + f0*(it*(it-1)*t(it-2)-efr(if)**2 *t(it)) +  &
            2*f1*efr(if)*it*t(it-1)
          endif
          i = i+1
        enddo
      endif
    enddo
  enddo
  if (id.eq.0) return
  do j=1,id
    do i=1,3
      r(i,j) = r(i,j) /a1000**j
    enddo
  enddo
end subroutine vsop87
!
subroutine readr8(lun,irecord,nw,w,error)
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! @ private
  ! Read NW words starting at direct access record IRECORD on file LUN
  !---------------------------------------------------------------------
  integer(kind=4), intent(in)    :: lun
  integer(kind=4), intent(inout) :: irecord
  integer(kind=4), intent(in)    :: nw
  real(kind=8),    intent(out)   :: w(nw)
  logical,         intent(inout) :: error
  ! Local
  real(kind=8) :: buffer(64)
  integer(kind=4) :: iw, nrec, i, ier
  !
  iw = 1
  nrec = nw/64
  if (nrec.ge.1) then
    do i=1, nrec
      read(lun,rec=irecord,err=999,iostat=ier) buffer
      irecord = irecord+1
      call eph_convert_r8 (buffer,w(iw),64)
      iw = iw + 64
    enddo
  endif
  read(lun,rec=irecord,err=999,iostat=ier) buffer
  irecord = irecord+1
  call eph_convert_r8 (buffer,w(iw),nw-iw+1)
  return
  !
  999   call putios('F-VSOP87,  ',ier)
  error = .true.
end subroutine readr8
!
subroutine readi4(lun,irecord,nw,w,error)
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! @ private
  ! Read NW words starting at direct access record IRECORD on file LUN
  !---------------------------------------------------------------------
  integer(kind=4), intent(in)    :: lun
  integer(kind=4), intent(inout) :: irecord
  integer(kind=4), intent(in)    :: nw
  integer(kind=4), intent(out)   :: w(nw)
  logical,         intent(inout) :: error
  ! Local
  integer(kind=4) :: buffer(128), iw, nrec, i, ier
  !
  iw = 1
  nrec = nw/128
  if (nrec.ge.1) then
    do i=1, nrec
      read(lun,rec=irecord,err=999,iostat=ier) buffer
      irecord = irecord+1
      call eph_convert_i4 (buffer,w(iw),128)
      iw = iw + 128
    enddo
  endif
  read(lun,rec=irecord,err=999,iostat=ier) buffer
  irecord = irecord+1
  call eph_convert_i4 (buffer,w(iw),nw-iw+1)
  return
  !
  999   call putios('F-VSOP87,  ',ier)
  error = .true.
end subroutine readi4
!
subroutine eph_convert(cfile)
  use gkernel_interfaces
  use gbl_convert
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  character(len=*):: cfile          !
  ! Local
  character(len=4) :: csyst
  integer(kind=4) :: nw, w(*), buffer(*)
  !
  integer(kind=4) :: conve
  !
  save conve
  !
  call gdf_getcod  (csyst)
  call gdf_convcod (cfile,csyst,conve)
  return
  !
entry eph_convert_i4 (buffer,w,nw)
  !
  if (conve.eq.vax_to_ieee .or. conve.eq.vax_fr_ieee) then
    call r4tor4(buffer,w,nw)
  elseif (conve.eq.ieee_to_vax .or. conve.eq.ieee_fr_vax) then
    call r4tor4(buffer,w,nw)
  elseif (conve.eq.vax_to_eeei .or. conve.eq.vax_fr_eeei) then
    call vai4ei(buffer,w,nw)
  elseif (conve.eq.ieee_to_eeei .or. conve.eq.ieee_fr_eeei) then
    call iei4ei(buffer,w,nw)
  elseif (conve.eq.eeei_to_vax .or. conve.eq.eeei_fr_vax) then
    call eii4va(buffer,w,nw)
  elseif (conve.eq.eeei_to_ieee .or. conve.eq.eeei_fr_ieee) then
    call eii4ie(buffer,w,nw)
  else
    call r4tor4(buffer,w,nw)
  endif
  return
  !
entry eph_convert_r8 (buffer,w,nw)
  if (conve.eq.vax_to_ieee .or. conve.eq.vax_fr_ieee) then
    call var8ie(buffer,w,nw)
  elseif (conve.eq.ieee_to_vax .or. conve.eq.ieee_fr_vax) then
    call ier8va(buffer,w,nw)
  elseif (conve.eq.vax_to_eeei .or. conve.eq.vax_fr_eeei) then
    call var8ei(buffer,w,nw)
  elseif (conve.eq.ieee_to_eeei .or. conve.eq.ieee_fr_eeei) then
    call ier8ei(buffer,w,nw)
  elseif (conve.eq.eeei_to_vax .or. conve.eq.eeei_fr_vax) then
    call eir8va(buffer,w,nw)
  elseif (conve.eq.eeei_to_ieee .or. conve.eq.eeei_fr_ieee) then
    call eir8ie(buffer,w,nw)
  else
    call r8tor8(buffer,w,nw)
  endif
  return
end subroutine eph_convert
!
subroutine ephsta (vector,planet,error)
  use gildas_def
  use gbl_message
  use ast_ephem
  !---------------------------------------------------------------------
  ! @ private
  !  Define vector to compute
  ! two separate calls EPHSTA and EPHVEC are kept for compatibility.
  !---------------------------------------------------------------------
  integer(kind=4) :: vector         ! vector description code
  integer(kind=4) :: planet         ! object identification
  logical :: error                  !
  ! Local
  integer(kind=4) :: i
  integer(kind=4) :: object_vsop(9)
  character(len=message_length) :: mess
  !  Planets are strangely numbered in AstrO ...
  data object_vsop /0,0,1,2,4,5,6,7,8/
  !
  !  here S, T, P, B, and G are the Sun, Earth, Planet, Earth-Moon Barycenter
  !     and The Solar System Barycenter.
  !  We have available in VSOP87, the vectors ST, SP... , SB, and GS
  !  ' means argument is t-tau
  !  Case 0 (Object out of the solar system, assumed distance : infinite)
  !       Vector = -GS-ST		     Earth - Sun - Solar System Barycenter
  !  Case 1 (Object = Moon)
  !  	Vector = (SB-ST)*(1+mT/mM)   Earth - Moon
  ! Note : moon is approximate: errors mult. by approx 100.
  !  Case 2 (Object = Sun)
  !  	Vector = GS'-GS-ST                 Earth - Sun
  !  Case 3 (Object = Planet)
  !  	Vector = GS'+SP'-GS-ST               Earth - Sun - Planet
  !  Computation of vectors (unit = km), using BDL82 ephemerides
  !      TB = TL / (1+MT/ML)
  !      BS = -SB
  !----------------------------------------------------------------------
  !  Initialize memories
  do i = 1, mvect
    vecnum(i) = 0
    vecmul(i) = 0.d0
    vecdly(i) = .false.
  enddo
  !  Set weights and indices according to object
  if (vector.eq.ivect_out) then        ! Object out of solar system
    nvect = 2
    vecnum(1) = 10             ! -GS
    vecmul(1) = -1.d0
    vecnum(2) = 3              ! -ST
    vecmul(2) = -1.d0
  elseif (vector.eq.ivect_moon) then
    nvect = 2
    vecnum(1) = 9              ! SB*(1+ml/mt)
    vecmul(1) = 1.d0/scale
    vecnum(2) = 3              ! -ST*(1+ml/mt)
    vecmul(2) = -1d0/scale
  elseif (vector.eq.ivect_sun) then
    nvect = 3
    vecnum(1) = 10             ! GS'
    vecmul(1) = 1.d0
    vecdly(1) = .true.
    vecnum(2) = 10             ! -GS
    vecmul(2) = -1.d0
    vecnum(3) = 3              ! -ST
    vecmul(3) = -1.d0
  elseif (vector.eq.ivect_pla) then
    nvect = 4
    vecnum(1) = object_vsop(planet)    ! SP'
    vecmul(1) = 1.d0
    vecdly(1) = .true.
    vecnum(2) = 10             ! GS'
    vecmul(2) = 1.d0
    vecdly(2) = .true.
    vecnum(3) = 10             ! -GS
    vecmul(3) = -1.d0
    vecnum(4) = 3              ! -ST
    vecmul(4) = -1.d0
  else
    write(mess,*) 'Invalid vector ',vector
    call astro_message(seve%e,'EPHSTA',mess)
    error = .true.
    return
  endif
end subroutine ephsta
!
subroutine ephvec (jdate,deriv,rvec,error)
  use gildas_def
  use gbl_message
  use ast_ephem
  !---------------------------------------------------------------------
  ! @ private
  !  Compute position vector and derivatives at given date
  !---------------------------------------------------------------------
  real(kind=8)           :: jdate            ! julian date of computation
  integer(kind=4)        :: deriv            ! number of derivatives needed (if position only, DERIV = 0)
  real(kind=8)           :: rvec(3,0:deriv)  ! resulting vectors
  logical, intent(inout) :: error            !
  ! Local
  integer(kind=4) :: i,j,k                ! indexes
  real(kind=8) :: val(3,0:2), rtim(3,0:2), rdel(3,0:2), tau, tau1, dtau, c
  parameter (c=299792.458d0)
  logical :: delay
  character(len=message_length) :: mess
  !----------------------------------------------------------------------
  !  Initialization
  if (deriv.lt.0 .or. deriv.gt.2) then
    write(mess,*) 'DERIV out of range ',deriv
    call astro_message(seve%e,'EPHVEC',mess)
    error = .true.
    return
  endif
  do j=0,2
    do i=1,3
      rtim(i,j) = 0.d0
      rdel(i,j) = 0.d0
    enddo
  enddo
  !
  ! start with undelayed vector
  delay = .false.
  do k=1,nvect
    call vsop87(jdate,vecnum(k),2,0d0,val,error)
    if (error) return
    do j=0, 2
      do i=1,3
        val(i,j) = val(i,j)*aukm/86400d0**j
        if (vecdly(k)) then
          rdel(i,j) = rdel(i,j)+val(i,j)*vecmul(k)
          delay = .true.
        else
          rtim(i,j) = rtim(i,j)+val(i,j)*vecmul(k)
        endif
      enddo
    enddo
  enddo
  !
  ! Compute delay = tau, not tested ...
  delay = .false.
  if (delay) then
    tau = 0
    dtau = 1e35
    do while (dtau.gt.1d-8)
      tau1 = 0
      do i=1,3
        rvec(i,0) = rtim(i,0)+rdel(i,0) - tau*rdel(i,1) + tau**2/2.d0*rdel(i,2)
        tau1 = tau1 + rvec(i,0)**2
      enddo
      tau1 = sqrt(tau1)/c
      dtau = abs(tau1-tau)
      tau = tau1
      write(6,*) 'tau, dtau'
      write(6,*) tau, dtau
    enddo
    do i=1, 3
      if (deriv.ge.1) then
        rvec(i,1) = rtim(i,1) + rdel(i,1)-tau*rdel(i,2)
      endif
      if (deriv.ge.2) then
        rvec(i,2) = rtim(i,2) + rdel(i,2)
      endif
    enddo
  else
    do j=0, deriv
      do i=1, 3
        rvec(i,j) = rtim(i,j) + rdel(i,j)
      enddo
    enddo
  endif
  error = .false.
end subroutine ephvec
