subroutine vel_scale_2 (name,freq)
  use classic_api
  !---------------------------------------------------------------------
  ! Updates frequencies in header according to last 'SET FREQUENCY' command
  !---------------------------------------------------------------------
  character(len=*) :: name          !
  real*8 :: freq                    !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_clic.inc'
  include 'clic_par.inc'
  ! Local
  integer :: isb, sky(2), isub 
  real*8 :: c
  parameter (c=299792.458d0)
  !
  data sky/+1,-1/              ! Usb, Lsb
  !------------------------------------------------------------------------
  ! Code:
  ! Defaults from Input Header:
  if (name.eq.'*') then
    name = r_line
  endif
  if (freq.eq.0) then
    freq = r_restf
  endif
  ! Loop on sidebands
  do isb = 1, 2
    !
    ! Continuum
    r_crfoff(isb) = freq
    r_cnam(isb) = name
    !
    ! Line
    do isub=1, r_lband
      r_lrfoff(isb,isub) = freq
      r_lnam(isb,isub) = name
    enddo
  enddo
  call vel_scale
  return
  !
end subroutine vel_scale_2
!
subroutine interpolate_2(x,xdim,xinc,xref,xval,w,   &
    y,ydim,yinc,yref,yval)
  !---------------------------------------------------------------------
  ! LAS	Internal routine
  !	Performs the linear interpolation/integration
  !
  ! 1) if actual interpolation (XINC <= YINC)
  !     this is a 2-point linear interpolation formula.
  !     the data is untouched if the resolution is unchanged and the shift
  !     is an integer number of channels.
  !
  ! 2) if not (XINC > YINC)
  !     boxcar convolution (width xinc-yinc) followed by linear interpolation
  !
  ! Arguments:
  !	X	R*4(*)	Output spectrum
  !	XDIM	I*4	Output pixel number
  !	XINC	R*8	Output first axis increment
  !	XREF	R*4	Output first axis reference pixel
  !	XVAL	R*4	Output first axis value at reference pixel
  ! 	Y	R*4(*)	Input spectrum
  !---------------------------------------------------------------------
  integer :: xdim                   !
  complex :: x(xdim)                !
  real*8 :: xinc                    !
  real :: xref                      !
  real*8 :: xval                    !
  real :: w(xdim)                   !
  integer :: ydim                   !
  complex :: y(ydim)                !
  real :: yinc                      !
  real :: yref                      !
  real*8 :: yval                    !
  ! Local
  integer :: i,imax,imin, j
  real*8 :: pix, val, expand
  real :: scale, ww
  !-----------------------------------------------------------------------
  !
  expand = abs(xinc/yinc)
  do i = 1, xdim
    !
    ! Compute interval
    val = xval + (i-xref)*xinc
    pix = (val-yval)/yinc + yref
    if (expand.gt.1.) then
      imin = int(pix-expand/2d0+0.5d0)
      imax = int(pix+expand/2d0+0.5d0)
      ! This initial test was stupid.... It rejected ANY channel which did not match
      ! the exact final sampling...
      !      IF ((MIN(IMIN,IMAX).LT.1).OR.(MAX(IMIN,IMAX).GT.YDIM)) THEN
      !      Print *,'Rejecting ',imin,imax,ydim
      !         W(I) = 0
      !         X(I) = 0
      ! We are here ADDING channels together to produce wider ones.
      ! Edge channels must be accounted for with their weight corresponding to the
      ! fraction of the final channel width covered by the initial sampling.
      !
      ! The band stitching will then be done properly in FILL_VISI, since this
      ! contribution  is added to the final visibility
      if (imin.lt.1) then
        imin = 1
        ww = 1.0               ! The whole channel is in...
      else
        ww = imin-(pix-expand/2d0-0.5d0)
      endif
      x(i) = y(imin)*ww
      scale = ww
      !
      if (imax.gt.ydim) then
        imax = ydim
        ww = 1.0
      else
        ww = pix+expand/2d0+0.5d0-imax
      endif
      x(i) = x(i) + y(imax)*ww
      scale = scale + ww
      !
      do j=imin+1, imax-1
        x(i) = x(i) + y(j)
        scale = scale+1.
      enddo
      ! Normalize
      w(i) = scale/expand      ! This is the fraction of channel covered
      x(i) = x(i)/scale
    else
      imin = int(pix)
      imax = imin+1
      if ((imin.lt.1).or.(imax.gt.ydim)) then
        w(i) = 0
        x(i) = 0
      else
        w(i) = 1
        x(i) = y(imin)*(imin+1-pix) + y(imin+1)*(pix-imin)
      endif
    endif
  enddo
end subroutine interpolate_2
!
subroutine fft_interpolate(x,xdim,xinc,xref,xval,xwid,xshape,   &
    w,y,ydim,yinc,yref,yval,ywid,yshape,error)
  use gildas_def
  use gkernel_interfaces, no_interface=>fourt
  !---------------------------------------------------------------------
  ! CLIC	Internal routine
  ! (from CLASS, but complex input/ouput)
  !	Performs the  interpolation/integration, using FFT.
  ! Arguments:
  !	X	C*8(*)	Output spectrum
  !	XDIM	I*4	Output pixel number
  !	XINC	R*8	Output first axis increment
  !	XREF	R*4	Output first axis reference pixel
  !	XVAL	R*4	Output first axis value at reference pixel
  !	XWID	R*4	Output channel width, in terms of channel separation.
  !           (e.g. oversampling parameter)
  !	XSHAPE  C*      Channel shape (TBox, TParabola, FBox, Ftriangle)
  !           TBox means a box in delay space (unsmoothed correlator, w=1)
  !           Ppar means a parabola in delay space (smoothed "      , w=1)
  !           FBox means a box in frequency space (square filter,     w=0.5)
  !           FTri means a triangle in frequency space
  !                       (Hanning smoothed square filter,            w=1)
  ! 	Y	C*8(*)	Input spectrum, same parameters ...
  !---------------------------------------------------------------------
  integer :: xdim                   !
  complex :: x(xdim)                !
  real*8 :: xinc                    !
  real :: xref                      !
  real*8 :: xval                    !
  real :: xwid                      !
  character(len=*) :: xshape        !
  real :: w(xdim)                   !
  integer :: ydim                   !
  complex :: y(ydim)                !
  real :: yinc                      !
  real :: yref                      !
  real*8 :: yval                    !
  real :: ywid                      !
  character(len=*) :: yshape        !
  logical :: error                  !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  integer(kind=address_length) :: addr, yp, wp
  integer :: i, nstep, nx, noff, p
  real :: step, off, oxinc
  real*8 :: vx, y1
  !-----------------------------------------------------------------------------
  !
  ! Steps in  FFT space are 1/(ydim*yinc)=step
  step = 1d0/(ydim*yinc)
  nx = nint(1d0/step/xinc)
  nx = abs(nx)
  call pfactor(nx,p)
  do while (p.gt.100)
    nx = nx+1
    call pfactor(nx,p)
  enddo
  if (xinc.ne.1d0/step/nx) then
    oxinc = xinc
    xinc = sign(1d0/step/nx,xinc)
  endif
  nstep = max(nx,2*ydim)
  !
  ! Do FFT of input spectrum:
  error = (sic_getvm(4*nstep, addr).ne.1)
  if (error) return
  yp = gag_pointer(addr,memory)
  wp = yp + 2*nstep
  call r4tor4(y,memory(yp),2*ydim)
  if (yinc*xinc.lt.0d0) then
    call reverse(ydim,memory(yp))
    y1 = yval+(ydim-yref)*yinc
  else
    y1 = yval+(1-yref)*yinc
  endif
  call fourt(memory(yp),ydim,1,1,1,memory(wp))
  call fft_factor(ydim,memory(yp),1./ydim)
  !
  ! Deconvolve from input channel shape
  call fft_deconv(ydim,memory(yp),ywid,yshape)
  if (nstep.gt.ydim) then
    call  fft_extend(memory(yp),ydim,nstep)
  endif
  !
  ! Convolve to output channel shape
  if (nx.lt.nstep) then
    call fft_cutoff(memory(yp),nstep,nx)
  endif
  call fft_reconv(nx,memory(yp),xwid,xshape)
  !
  ! Correct for channel offset
  vx = (y1-xval)/xinc+xref-1
  vx = -vx
  noff = nint(vx)
  off = vx-noff
  call fft_offset(nx,memory(yp),-off)
  !
  ! FFT to output spectrum:
  call fourt(memory(yp),nx,1,-1,1,memory(wp))
  do i=1, xdim
    w(i) = 1
  enddo
  if (noff.lt.0) then
    call r4tor4(memory(yp),x(1-noff),2*(xdim+noff))
    do i=1, -noff
      w(i) = 0
    enddo
  elseif  (noff.gt.0) then
    call r4tor4(memory(yp+2*noff),x,2*(xdim-noff))
    do i=1, noff
      w(xdim-i+1) = 0
    enddo
  else
    call r4tor4(memory(yp),x,2*xdim)
  endif
  call free_vm(4*nstep, addr)
end subroutine fft_interpolate
!
subroutine reverse(n,r)
  !---------------------------------------------------------------------
  ! Reverses complex array R
  !---------------------------------------------------------------------
  integer :: n                      !
  complex :: r(n)                   !
  ! Local
  integer :: i
  complex :: temp
  !-----------------------------------------------------------------------
  do i=1, n/2
    temp = r(i)
    r(i) = r(n-i+1)
    r(n-i+1) = temp
  enddo
end subroutine reverse
!
subroutine fft_offset(n,z,x)
  !---------------------------------------------------------------------
  ! offset by x channels
  !---------------------------------------------------------------------
  integer :: n                      !
  complex :: z(n)                   !
  real :: x                         !
  ! Global
  include 'gbl_pi.inc'
  ! Local
  integer :: i, n2
  complex :: f, fn
  real ::  arg
  !-----------------------------------------------------------------------
  !
  arg = 2*pi/n*x
  n2 = n/2
  f = cmplx(cos(arg),sin(arg))
  fn = cmplx(1.,0.)
  do i = 2, n2
    fn = fn*f
    z(i) = z(i)*fn
    z(n-i+2)=z(n-i+2)/fn
  !         Z(N-I+1)=Z(N-I+1)/FN
  enddo
  fn = fn*f
  z(n2+1) = z(n2+1)*fn
  if (2*n2.lt.n) z(n2+2) = z(n2+2)/fn
end subroutine fft_offset
!
subroutine fft_factor(n,z,x)
  !---------------------------------------------------------------------
  ! Multiply Z complex array by X
  !---------------------------------------------------------------------
  integer :: n                      !
  complex :: z(n)                   !
  real :: x                         !
  ! Local
  !-----------------------------------------------------------------------
  integer :: i
  do i = 1, n
    z(i) = z(i)*x
  enddo
end subroutine fft_factor
!
subroutine fft_reconv(n,y,w,shape)
  !---------------------------------------------------------------------
  ! Reconvolution according to shape
  ! 'TB'    Time Box
  ! 'TP'    Time Parabola
  ! 'FB'    Frequency Box
  ! 'FT'    Frequency Triangle
  !---------------------------------------------------------------------
  integer :: n                      !
  complex :: y(n)                   !
  real :: w                         !
  character(len=*) :: shape         !
  ! Global
  include 'gbl_pi.inc'
  ! Local
  integer :: nmax, i, j
  real :: tmax, a, arg, fac
  !--------------------------------------------------------------------
  ! W = width (in terms of channel separation)
  tmax = n/w/2
  nmax = tmax
  a = 1./tmax**2
  arg = pi/tmax/2
  do j=1, n
    i = mod(j-1+n/2,n)-n/2
    ! Raw Correlator channels (no smoothing, sin(pi f/w)/(pi x/w),
    !  w is the first zero, measured in channel spacings.)
    if (shape(1:2).eq.'TB') then
      if (abs(i).ge.tmax) then
        y(j) = 0
      endif
    ! Smoothed correlator channels (parabolic smoothing function)
    elseif (shape(1:2).eq.'TP') then
      if (abs(i).ge.tmax) then
        y(j) = 0
      else
        y(j) = y(j)*(1.-a*i**2)
      endif
    ! Frequency Box of width = w * channel-spacing
    elseif (shape(1:2).eq.'FB') then
      fac = arg*i
      if (fac.ne.0) y(j) = y(j)*sin(fac)/fac
    ! Frequency Triangle of full-width = 2w * channel-spacing
    elseif (shape(1:2).eq.'FT') then
      fac = arg*i
      if (fac.ne.0) y(j) = y(j)*(sin(fac)/fac)**2
    endif
  enddo
end subroutine fft_reconv
!
subroutine fft_deconv(n,y,w,shape)
  !---------------------------------------------------------------------
  ! Deconvolution according to shape
  ! 'TB'    Time Box
  ! 'TP'    Time Parabola
  ! 'FB'    Frequency Box
  ! 'FT'    Frequency Triangle
  !---------------------------------------------------------------------
  integer :: n                      !
  complex :: y(n)                   !
  real :: w                         !
  character(len=*) :: shape         !
  ! Global
  include 'gbl_pi.inc'
  ! Local
  !-----------------------------------------------------------------------
  integer :: nmax, i, j
  real :: tmax, a, arg, fac, sfac
  !--------------------------------------------------------------------
  ! W = width (in terms of channel separation)
  tmax = n/w/2
  nmax = tmax
  a = 1./tmax**2
  arg = pi/tmax/2
  do j=1, n
    i = mod(j-1+n/2,n)-n/2
    ! Raw Correlator channels (no smoothing, sin(pi f/w)/(pi x/w),
    !  w is the first zero, measured in channel spacings.)
    ! nothing to do ...
    if (shape(1:2).eq.'TB') then
      return
    ! Smoothed correlator channels (parabolic smoothing function)
    elseif (shape(1:2).eq.'TP') then
      if (abs(i).lt.tmax) then
        y(j) = y(j)/(1.-a*i**2)
      endif
    ! Frequency Box of half-width = w * channel-spacing
    elseif (shape(1:2).eq.'FB') then
      fac = arg*i
      sfac = sin(fac)
      if (sfac.ne.0) y(j) = y(j)/(sfac/fac)
    ! Frequency Triangle of half-full-width = 2w * channel-spacing
    elseif (shape(1:2).eq.'FT') then
      fac = arg*i
      sfac = sin(fac)
      if (sfac.ne.0) y(j) = y(j)/(sfac/fac)**2
    endif
  enddo
end subroutine fft_deconv
!
subroutine fft_extend(c,n,m)
  !---------------------------------------------------------------------
  ! complete FFT with zeroes in high frequencies
  !---------------------------------------------------------------------
  integer :: m                      !
  complex :: c(m)                   !
  integer :: n                      !
  ! Local
  integer :: i, n2
  !-----------------------------------------------------------------------
  n2 = n/2
  do i=1, n2
    c(m-i+1) = c(n-i+1)
  enddo
  if (n.gt.2*n2) then
    c(m-n2)= c(n-n2)
  else
    c(m-n2)= 0
  endif
  do i=n2+1, m-n2-1
    c(i) = 0
  enddo
end subroutine fft_extend
!
subroutine fft_cutoff(c,m,n)
  !---------------------------------------------------------------------
  ! cutoff FFT in high frequencies
  !---------------------------------------------------------------------
  integer :: m                      !
  complex :: c(m)                   !
  integer :: n                      !
  ! Local
  integer :: i, n2
  !-----------------------------------------------------------------------
  n2 = n/2
  if (n.gt.2*n2) then
    c(n2+1) = (c(n2+1)+c(m-n2+1))/2.
  endif
  do i=n2, 1, -1
    c(n-i+1) = c(m-i+1)
  enddo
end subroutine fft_cutoff
!
subroutine pfactor(n,p)
  !---------------------------------------------------------------------
  ! Returns in p the largest prime factor in n
  !---------------------------------------------------------------------
  integer :: n                      !
  integer :: p                      !
  ! Global
  logical :: prime
  ! Local
  integer :: m, q, r
  !------------------------------------------------------------------------
  m = n
  p = 1
  do while (m .gt. p)
    if (prime(m,q)) then
      p = max(p,m)
      return
    else
      do while (.not.prime(q,r))
        q = q/r
      enddo
      p = max(p,q)
      m = m/q
    endif
  enddo
end subroutine pfactor
!
function prime(n,p)
  !---------------------------------------------------------------------
  ! Find if n is prime, returns the smallest integer divisor p.
  !---------------------------------------------------------------------
  logical :: prime                  !
  integer :: n                      !
  integer :: p                      !
  ! Local
  integer :: i, nn
  !------------------------------------------------------------------------
  prime = .false.
  p=2
  i=n/2
  if (i.gt.1 .and. i*2.eq.n) return
  p = 3
  nn = sqrt(float(n))
  do while (p.le.nn)
    i = n/p
    if (p*i.eq.n) return
    p = p+2
  enddo
  prime = .true.
  return
end function prime
!
