program uv_proper_motion
  use gkernel_interfaces
  !------------------------------------------------------------------------
  ! TASK  Apply specified proper motion to an input UV Table
  !
  ! input :
  ! a uv table
  ! output :
  ! a uv table
  !------------------------------------------------------------------------
  character(len=filename_length) :: input,output
  real(8) :: proper(2)
  logical error
  !
  ! Input parameters
  call gildas_open
  call gildas_char('UV_INPUT$',input)
  call gildas_char('UV_OUTPUT$', output)
  call gildas_dble('PROPER$',proper,2)
  call gildas_close
  call sub_uv_proper_motion (input, output, proper, error)
  if (error) call sysexi(fatale)
end program uv_proper_motion
!
subroutine sub_uv_proper_motion (cuvin, cuvou, proper, error)
  use gkernel_interfaces
  use image_def
  use gbl_message
  !---------------------------------------------------------------------
  ! GILDAS
  !      Apply specified proper motion to an input UV Table
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: cuvin
  character(len=*), intent(in) :: cuvou
  real(8), intent(in) :: proper(2)
  logical, intent(out) :: error
  !
  ! Local variables
  character(len=*), parameter :: rname='UV_PROPER_MOTION'
  character(len=80)  :: mess
  type (gildas) :: uvin
  type (gildas) :: uvou
  integer :: ier, nblock, ib, nvisi
  !
  ! Simple checks
  error = len_trim(cuvin).eq.0
  if (error) then
    call map_message(seve%e,rname,'No input UV table name')
    return
  endif
  !
  call gildas_null (uvin, type = 'UVT')     ! Define a UVTable gildas header
  call gdf_read_gildas (uvin, cuvin, '.uvt', error, data=.false.)
  if (error) then
    call map_message(seve%e,rname,'Cannot read input UV table')
    return
  endif
  !
  ! Here modify the header of the output UV table according
  ! to the desired goal
  !
  call gildas_null (uvou, type = 'UVT')     ! Define a UVTable gildas header
  call gdf_copy_header(uvin,uvou,error)
  call sic_parse_file(cuvou,' ','.uvt',uvou%file)
  !
  uvou%gil%astr_words = def_astr_words ! 3
  uvou%gil%mura = proper(1)
  uvou%gil%mudec = proper(2)
  uvou%gil%parallax = 0.0
  !
  ! create the image
  call gdf_create_image(uvou,error)
  if (error) return
  !
  ! Define blocking factor, on largest data file, usually the input one
  ! but not always...
  call gdf_nitems('SPACE_GILDAS',nblock,uvin%gil%dim(1)) ! Visibilities at once
  nblock = min(nblock,uvin%gil%dim(2))
  ! Allocate respective space for each file
  allocate (uvin%r2d(uvin%gil%dim(1),nblock), stat=ier)
  if (ier.ne.0) then
    write(mess,*) 'Memory allocation error ',uvin%gil%dim(1), nblock
    call map_message(seve%e,rname,mess)
    error = .true.
    return
  endif
  !
  ! Loop over line table - The example assumes the same
  ! number of visibilities in Input and Output, which may not
  ! be true...
  uvin%blc = 0
  uvin%trc = 0
  uvou%blc = 0
  uvou%trc = 0
  do ib = 1,uvin%gil%dim(2),nblock
    write(mess,*) ib,' / ',uvin%gil%dim(2),nblock
    call map_message(seve%i,rname,mess)
    uvin%blc(2) = ib
    uvin%trc(2) = min(uvin%gil%dim(2),ib-1+nblock)
    uvou%blc(2) = ib
    uvou%trc(2) = uvin%trc(2)
    call gdf_read_data(uvin,uvin%r2d,error)
    !
    ! Here do the job
    !
    nvisi = uvou%trc(2)-uvou%blc(2)+1
    !
    ! Note that we use UVIN to have the old proper motion...
    call proper_motion (proper,uvin,nvisi,uvin%r2d)
    !
    call gdf_write_data (uvou,uvin%r2d,error)
    if (error) return
  enddo
  !
  ! Finalize the image
  call gdf_close_image(uvin,error)
  call gdf_close_image(uvou,error)
  if (error) return
  !
  call map_message(seve%i,rname,'Successful completion')
  return
end subroutine sub_uv_proper_motion
!
subroutine proper_motion (mu,huv,nvisi,visi)
  use gkernel_interfaces
  use image_def
  real(8), intent(in) :: mu(2)
  type (gildas), intent(in) :: huv
  integer, intent(in) :: nvisi
  real(4), intent(inout) :: visi(huv%gil%dim(1),nvisi)
  !
  integer j2000
  real(8) :: dzero,murad(2),pos(2),freq
  real(8), parameter :: pi=3.14159265358979323846d0
  real(8), parameter :: f_to_k = 2.d0*pi/299792458.d-6
  !
  character(len=11) date
  integer :: i, ix, iu, iv, id
  real(4) :: reel, imag
  real(8) :: uu, vv, phi, sphi, cphi, d, dyear
  logical :: error, uv8
  !
  ! Subtract existing proper motion
  murad(1) = mu(1)-huv%gil%mura
  murad(2) = mu(2)-huv%gil%mudec
  !
  ! Get proper motion in Rad/year
  murad = murad*1d-3*pi/180D0/3600d0 ! Radians / year
  !
  ! Get J2000 in CLASS date
  !
  date = '01-JAN-2000'
  call gag_fromdate(date,j2000,error)
  !
  ! Use the Equinox of the coordinates
  dzero = dble(huv%gil%epoc)-2000.0d0
  !
  ! Get observing frequency
  freq = gdf_uv_frequency(huv)
  !
  uv8 = huv%gil%column_size(code_uvt_u).ne.1
  !
  iu = huv%gil%column_pointer(code_uvt_u)
  iv = huv%gil%column_pointer(code_uvt_v)
  id = huv%gil%column_pointer(code_uvt_date)
  if (uv8) print *,'UV8 ',uv8,iu,iv,id
  !
  do i = 1,nvisi
    if (uv8) then
      call r4tor4 (visi(iu,i),uu,2)   ! Avoid r8tor8 for alignment problems
      call r4tor4 (visi(iv,i),vv,2)
    else
      uu = visi(iu,i)                 ! Implicit Real(4) -> Real(8) conversion
      vv = visi(iv,i)
    endif
    !
    ! Get date in CLASS Days
    d = visi(id,i)
    ! Get time increment in years
    dyear = (d-j2000)/365.25d0 - dzero
    ! Position at this date
    pos = murad*dyear
    !!Print *,i,d,j2000,dyear,pos
    !
    ! compute new phase center in wavelengths
    pos = - freq * f_to_k * pos
    phi = pos(1)*uu + pos(2)*vv
    cphi = cos(phi)
    sphi = sin(phi)
    do ix = huv%gil%fcol, huv%gil%lcol, huv%gil%natom
      reel = visi(ix,i) * cphi - visi(ix+1,i) * sphi
      imag = visi(ix,i) * sphi + visi(ix+1,i) * cphi
      visi(ix,i) = reel
      visi(ix+1,i) = imag
    enddo
  enddo
end subroutine proper_motion

