program uv_fast_ccmodel
  use gildas_def
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! GILDAS
  ! Compute a UV data set from an image model
  ! Input : a UV table, created for example by ASTRO
  ! Input : an image, LMV-like
  ! Output: the UV table, where the visibilities have been computed.
  !
  !     Uses an intermediate FFT with further interpolation for
  !     better speed than UV_CCT
  !---------------------------------------------------------------------
  character(len=256) :: uvdata,image,uvmodel
  real :: frequency
  logical :: large
  integer :: nclean
  logical :: error
  !
  ! Code:
  call gildas_open
  call gildas_char('UVSAMPLE$',uvdata)
  call gildas_char('IMAGE$',image)
  call gildas_char('UVMODEL$',uvmodel)
  call gildas_real('FREQUENCY$',frequency,1)
  call gildas_logi('LARGE$',large,1)
  call gildas_inte('CLEAN$',nclean,1)
  call gildas_close
  !
  call uv_auto_model(uvdata,image,uvmodel,frequency,large,nclean,error)
  if (error) call sysexi(fatale)

contains
!<FF>
subroutine uv_auto_model (uvdata,image,uvmodel,frequency,large,nclean,error)
  use image_def
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! GILDAS
  ! Compute a UV data set from a  Clean Components table
  ! Input : a UV table, created for example by ASTRO
  ! Input : a CCT table, both ways accepted
  ! Output: the UV table, where the visibilities have been computed.
  !
  !     Uses an intermediate FFT with further interpolation for
  !     better speed than UV_CCT
  !
  ! Intermediate FFT is a "large" version, i.e. 4 times the nearest power
  ! of 2 of the initial image, or a maximum of 4096 x 4096.
  !---------------------------------------------------------------------
  !
  character(len=*), intent(inout) :: uvdata        ! Sample UV table
  character(len=*), intent(inout) :: image         ! Clean Component Table
  character(len=*), intent(inout) :: uvmodel       ! Output UV table
  real, intent(in) :: frequency                    ! Observing frequency
  logical, intent(in) :: large                     ! Precision
  integer, intent(in) :: nclean                    ! Retained clean components
  logical, intent(out) :: error
  ! Global
  type (gildas) :: huvd
  type (gildas) :: hima
  type (gildas) :: huvm
  !
  complex, allocatable :: fft(:,:,:)
  real, allocatable :: uvd(:,:)
  real, allocatable :: ima(:,:,:)
  real, allocatable :: map(:,:,:)
  real, allocatable :: uvm(:,:)
  real, allocatable :: work(:)
  !
  ! Local
  integer :: nf,nx,ny,mx,my,kx,ky,nt,nv,mt, ier
  real :: cpu0, cpu1
  real :: rx, ry, fres, factor
  real(8) :: xinc, yinc, freq
  !
  ! Code
  error = .false.
  call gag_cpu(cpu0)
  !
  ! Input file
  call gildas_null(huvd, type= 'UVT')
  call sic_parsef(uvdata,huvd%file,' ','.uvt')
  call gdf_read_header (huvd,error)
  if (error) then
     call gagout ('F-UV_MODEL,  Cannot read input table')
     goto 999
  endif
  if (huvd%char%type(1:9).ne.'GILDAS_UV') then
     call gagout ('W-UV_MODEL,  Input data is not a UV table')
     goto 999
  endif
  !
  allocate (uvd(huvd%gil%dim(1),huvd%gil%dim(2)),stat=ier)
  if (ier.ne.0) then
     call gagout ('F-UV_MODEL,  UVD Allocation error')
     error = .true.
     goto 999
  endif
  call gdf_read_data(huvd,uvd,error)
  !
  ! CCT
  call gildas_null(hima)
  call sic_parsef(image,hima%file,' ','.cct')
  call gdf_read_header (hima,error)
  if (error) then
     call gagout ('F-UV_MODEL,  Cannot read Clean Component table')
     goto 999
  endif
  if (hima%char%type.ne.'GILDAS_IMAGE') then
     call gagout ('W-UV_MODEL,  Input model is not an image' )
     goto 999
  endif
  !
  mx = hima%gil%dim(1)
  my = hima%gil%dim(2)
  nf = hima%gil%dim(3)
  allocate (ima(mx,my,nf),stat=ier)
  if (ier.ne.0) then
     call gagout ('F-UV_MODEL,  IMA Allocation error')
     error = .true.
     goto 999
  endif
  call gdf_read_data(hima,ima,error)
  !
  ! Compact it into an image
  ! This depends on the CCT type, and is done in a subroutine
  !    First, defined the sampling and image size
  call cct_def_image (hima,mx,my,nf,freq,xinc,yinc,error)
  if (error) return
  !    Then do the job
  allocate (map(mx,my,nf),stat=ier)
  if (ier.ne.0) then
     call gagout ('F-UV_MODEL,  MAP Allocation error')
     error = .true.
     goto 999
  endif
  call cct_set_image (hima,ima,mx,my,nclean,xinc,yinc,nf,map,error)
  !
  !! pixel_area = abs(xinc*yinc)   ! in radian
  !
  !
  ! Define the image size
  !
  if (large) then
     rx = log(float(mx))/log(2.0)
     kx = nint(rx)
     if (kx.lt.rx) kx = kx+1
     nx = 2**kx
     ry = log(float(my))/log(2.0)
     ky = nint(ry)
     if (ky.lt.ry) ky = ky+1
     ny = 2**ky
     kx = max(nx,ny)
     kx = min(4*kx,4096)
     kx = max(mx,kx)
     kx = max(my,kx)
     nx = kx
     ny = kx
     call gag_cpu(cpu1)
  else
     nx = mx
     ny = my
  endif
  !
  ! Get Virtual Memory & compute the FFT
  allocate (fft(nx,ny,nf),stat=ier)
  if (ier.ne.0) then
     call gagout('E-UV_FCCT,  FFT space allocation error')
     goto 999
  endif
  !
  if (nx.eq.mx .and. ny.eq.my) then
     fft(:,:,:) = cmplx(map,0.0)
  else
     call plunge_real (map,mx,my,fft,nx,ny,nf)
  endif
  ! Free map
  deallocate (map,stat=ier)
  allocate (work(2*max(nx,ny)),stat=ier)
  if (ier.ne.0) then
     call gagout('E-UV_FCCT,  FFT work allocation error')
     goto 999
  endif
  !
  ! Compute the FFT
  call do_fft(nx,ny,nf,fft,work)
  call gag_cpu(cpu1)
  !
  call gildas_null(huvm, type = 'UVT')
  call gdf_copy_header(huvd,huvm,error)
  fres = hima%gil%fres
  if (freq.eq.0.0) then
     freq = 1d5                 ! 100 GHz
     fres = 1d3
  endif
  if (frequency.ne.0) freq = frequency !! All in MHz
  !
  ! Define scaling factor from Brightness to Flux (2 k B^2 / l^2)
  !! lambda = 299792.458e3/(freq*1e6) ! in meter
  ! 1.38E3 is the Boltzmann constant times 10^26 to give result in Jy
  !! factor = 2*1.38e3/lambda**2*pixel_area
  !! print *,'Factor ',factor,pixel_area
  !! if (factor.eq.0.0) factor = 1.0
  !
  ! We are in Jy, so this is simple
  factor = 1.0
  !
  call sic_parsef(uvmodel,huvm%file,' ','.uvt')
  huvm%gil%dim(1) = 7+3*nf
  huvm%gil%ref(1)  = 1.0
  huvm%gil%val(1)  = freq
  huvm%gil%inc(1)  = fres
  huvm%gil%freq  = freq
  !
  allocate (uvm(huvm%gil%dim(1),huvm%gil%dim(2)),stat=ier)
  nt = huvm%gil%dim(1)
  nv = huvm%gil%dim(2)
  mt = huvd%gil%dim(1)
  call copyuv (nt,nv,uvm,mt,uvd)
  deallocate (uvd)
  !
  ! OK, compute the model
  call do_model(uvm, nt, nv,   &
       &    fft,nx,ny,nf,freq,xinc,yinc,factor)
  !
  call gdf_write_image(huvm,uvm,error)
  call gagout('S-UV_FCCT,  Successful completion')
  call gag_cpu(cpu1)
  error = .false.
  return
  !
999 error = .true.
  return
end subroutine uv_auto_model
!<FF>
subroutine do_model (visi,nc,nv,a,nx,ny,nf,   &
     &    freq,xinc,yinc,factor)
  integer, intent(in) :: nc                     !
  integer, intent(in) :: nv                     !
  real, intent(inout) :: visi(nc,nv)            !
  integer, intent(in) :: nx                     !
  integer, intent(in) :: ny                     !
  integer, intent(in) :: nf                     !
  complex, intent(in) :: a(nx,ny,nf)            !
  real(8), intent(in) :: freq                   !
  real(8), intent(in) :: xinc                   !
  real(8), intent(in) :: yinc                   !
  real, intent(in) :: factor                    !
  ! Local
  real(kind=8), parameter :: clight=299792458d0
  real(kind=8) :: kwx,kwy,stepx,stepy,lambda,bfin(2),xr,yr
  complex(kind=8) :: aplus,amoin,azero,afin
  integer :: i,if,ia,ja
  logical :: inside
  equivalence (afin,bfin)
  !
  lambda = clight/(freq*1d6)
  stepx = 1.d0/(nx*xinc)*lambda
  stepy = 1.d0/(ny*yinc)*lambda
  !
  ! Loop on visibility
  do i = 1, nv
     kwx =  visi(1,i) / stepx + dble(nx/2 + 1)
     kwy =  visi(2,i) / stepy + dble(ny/2 + 1)
     ia = int(kwx)
     ja = int(kwy)
     inside = (ia.gt.1 .and. ia.lt.nx) .and.   &
          &      (ja.gt.1 .and. ja.lt.ny)
     if (inside) then
        xr = kwx - ia
        yr = kwy - ja
        do if=1,nf
           !
           ! Interpolate (X or Y first, does not matter in this case)
           aplus = ( (a(ia+1,ja+1,if)+a(ia-1,ja+1,if)   &
                &          - 2.d0*a(ia,ja+1,if) )*xr   &
                &          + a(ia+1,ja+1,if)-a(ia-1,ja+1,if) )*xr*0.5d0   &
                &          + a(ia,ja+1,if)
           azero = ( (a(ia+1,ja,if)+a(ia-1,ja,if)   &
                &          - 2.d0*a(ia,ja,if) )*xr   &
                &          + a(ia+1,ja,if)-a(ia-1,ja,if) )*xr*0.5d0   &
                &          + a(ia,ja,if)
           amoin = ( (a(ia+1,ja-1,if)+a(ia-1,ja-1,if)   &
                &          - 2.d0*a(ia,ja-1,if) )*xr   &
                &          + a(ia+1,ja-1,if)-a(ia-1,ja-1,if) )*xr*0.5d0   &
                &          + a(ia,ja-1,if)
           ! Then Y (or X)
           afin = ( (aplus+amoin-2.d0*azero)   &
                &          *yr + aplus-amoin )*yr*0.5d0 + azero
           !
           visi(5+3*if,i) =  bfin(1)*factor
           ! There was a - sign in the precedent version
           visi(6+3*if,i) =  bfin(2)*factor
        enddo
     else
        print *,'Error Visi ',i,ia,nx,ja,ny
     endif
  enddo
end subroutine do_model
!<FF>
subroutine do_fft (nx,ny,nf,fft,work)
  integer, intent(in)  :: nx                     !
  integer, intent(in)  :: ny                     !
  integer, intent(in)  :: nf                     !
  complex, intent(inout) :: fft(nx,ny,nf)
  real, intent(inout)  :: work(2*max(nx,ny))
  ! Local
  integer :: if,dim(2)
  !
  ! Loop on channels
  dim(1) = nx
  dim(2) = ny
  do if = 1, nf
     call fourt(fft(:,:,if),dim,2,1,1,work)
     call recent(nx,ny,fft(:,:,if))
  enddo
end subroutine do_fft
!<FF>
subroutine copyuv (nco,nv,out,nci,in)
  integer, intent(in)  :: nco                    !
  integer, intent(in)  :: nv                     !
  real, intent(out)  :: out(nco,nv)              !
  integer, intent(in) :: nci                     !
  real, intent(in)  :: in(nci,nv)                !
  ! Local
  integer :: i,j
  do i=1,nv
     do j=1,7
        out(j,i) = in(j,i)
     enddo
     do j=8,nco,3
        out(j,i) = 0
        out(j+1,i) = 0
        out(j+2,i) = in(10,i)
     enddo
  enddo
end subroutine copyuv
!<FF>
subroutine recent(nx,ny,z)
  !---------------------------------------------------------------------
  ! Recenters the Fourier Transform, for easier display. The present version
  ! will only work for even dimensions.
  !---------------------------------------------------------------------
  integer, intent(in)  :: nx                     !
  integer, intent(in)  :: ny                     !
  complex, intent(inout)  :: z(nx,ny)               !
  ! Local
  integer :: i, j
  complex :: tmp
  !
  do j=1,ny/2
    do i=1,nx/2
      tmp = z(i+nx/2,j+ny/2)
      z(i+nx/2,j+ny/2) = z(i,j)
      z(i,j) = tmp
    enddo
  enddo
  !
  do j=1,ny/2
    do i=1,nx/2
      tmp = z(i,j+ny/2)
      z(i,j+ny/2) = z(i+nx/2,j)
      z(i+nx/2,j) = tmp
    enddo
  enddo
  !
  do j=1,ny
    do i=1,nx
      if (mod(i+j,2).ne.0) then
         z(i,j) = -z(i,j)
      endif
    enddo
  enddo
end subroutine recent
!<FF>
subroutine plunge_real (r,nx,ny,c,mx,my,nf)
  !---------------------------------------------------------------------
  !     Plunge a Real array into a Complex array
  !---------------------------------------------------------------------
  integer, intent(in)  :: nx                     ! Size of input array
  integer, intent(in)  :: ny                     ! Size of input array
  integer, intent(in)  :: nf                     !
  real, intent(in)  :: r(nx,ny,nf)               ! Input real array
  integer, intent(in)  :: mx                     ! Size of output array
  integer, intent(in)  :: my                     ! Size of output array
  complex, intent(inout)  :: c(mx,my,nf)         ! Output complex array
  ! Local
  integer :: kx,ky,lx,ly
  integer :: i,j,k
  !
  kx = nx/2+1
  lx = mx/2+1
  ky = ny/2+1
  ly = my/2+1
  !
  do k=1,nf
     do j=1,my
        do i=1,mx
           c(i,j,k) = 0.0
        enddo
     enddo
     do j=1,ny
        do i=1,nx
           c(i-kx+lx,j-ky+ly,k) = cmplx(r(i,j,k),0.0)
        enddo
     enddo
  enddo
end subroutine plunge_real
!
subroutine cct_def_image (hima,mx,my,nf,freq,xinc,yinc,error)
  use image_def
  type (gildas) :: hima
  integer, intent(out) :: mx,my,nf
  real(8), intent(out) :: freq
  real(8), intent(out) :: xinc,yinc
  logical, intent(out) :: error
  !
  error = .false.
  if (hima%char%code(3).eq.'COMPONENT') then
     call gagout('I-UV_FCCT,  Clean Components from MAPPING')
     nf = hima%gil%dim(2)  ! Number of channels
     mx = (hima%gil%ref(1)-1)*2
     xinc = hima%gil%inc(1)
     my = (hima%gil%ref(3)-1)*2
     yinc = hima%gil%inc(3)
     ! Define observing frequency
     freq = hima%gil%freq + hima%gil%fres*((nf+1)*0.5-hima%gil%ref(2))
  else
     call gagout('I-UV_FCCT,  Clean Components from Task CLEAN')
     nf = hima%gil%dim(3)
     mx = (hima%gil%ref(1)-1)*2
     xinc = hima%gil%inc(1)
     my = (hima%gil%ref(2)-1)*2
     yinc = hima%gil%inc(2)
     freq = hima%gil%freq + hima%gil%fres*((nf+1)*0.5-hima%gil%ref(3))
  endif
end subroutine cct_def_image
!
subroutine cct_set_image (hima,clean,mx,my,mc,xinc,yinc,nf,image,error)
  use image_def
  type (gildas) :: hima
  real clean(hima%gil%dim(1),hima%gil%dim(2),hima%gil%dim(3))
  integer, intent(in) :: mx,my,nf
  integer, intent(in) :: mc
  real(8), intent(in) :: xinc,yinc
  real, intent(out) :: image(mx,my,nf)
  logical, intent(out) :: error
  !
  integer lc,nc,kc
  integer ic,jf
  integer ix,iy
  !
  image = 0
  if (hima%char%code(3).eq.'COMPONENT') then
    lc = hima%gil%dim(1)
    nc = hima%gil%dim(2)  ! Number of channels
    if (nc.ne.nf) then
      Print *,'Channel mismatch ',nc,nf
      error = .true.
      return
    endif
    if (mc.eq.0) then
      kc = hima%gil%dim(3)  ! Number of components
    else
      kc = min(mc,hima%gil%dim(3))
    endif
    !
    do jf = 1,nf
      do ic = 1,kc
        if (clean(3,jf,ic).ne.0) then
          ix = nint(clean(1,jf,ic)/xinc)+mx/2+1
          iy = nint(clean(2,jf,ic)/yinc)+my/2+1
          image(ix,iy,jf) = image(ix,iy,jf) + clean(3,jf,ic)
        else
          exit ! No more components for this channel
        endif
      enddo
    enddo
  else
    lc = hima%gil%dim(1)
    if (mc.eq.0) then
      kc = hima%gil%dim(2)  ! Number of components
    else
      kc = min(mc,hima%gil%dim(2))
    endif
    nc = hima%gil%dim(3)
    if (nc.ne.nf) then
      Print *,'Channel mismatch ',nc,nf
      error = .true.
      return
    endif
    do jf = 1,nf
      do ic = 1,kc
        if (clean(1,ic,jf).ne.0) then
          ix = nint(clean(2,ic,jf))
          iy = nint(clean(3,ic,jf))
          image(ix,iy,jf) = image(ix,iy,jf) + clean(1,ic,jf)
        else
          exit ! No more components for this channel
        endif
      enddo
    enddo
  endif
end subroutine cct_set_image
!
end program uv_fast_ccmodel
