program uv_table
  use gildas_def
  use image_def
  use gkernel_interfaces, no_interface=>fourt
  !---------------------------------------------------------------------
  ! GILDAS
  !	Compute the UV data set corresponding to an image
  !	Input : an image.
  !	Output: the UV table, where the visibilities have been computed.
  ! This tasks differs from UV_MODEL by using an FFT, and generating UV
  ! data on a fully sampled grid (up to a maximum radius) rather than along
  ! user specified tracks.
  !---------------------------------------------------------------------
  ! Local
  type(gildas) :: x,y
  complex, allocatable :: tf(:,:), work(:)
  integer :: nf,nx,ny,n, if, nn(2), ier,ydim1
  character(len=filename_length) :: image,name,uvmodel
  character(len=132) :: mess
  real :: freq
  logical :: error
  !
  ! Code:
  call gildas_open
  call gildas_char('IMAGE$',image)
  call gildas_char('UVMODEL$',uvmodel)
  call gildas_close
  !
  ! Image
  n = len_trim(image)
  if (n.le.0) goto 999
  name = image(1:n)
  call gildas_null(y, type = 'IMAGE')
  call gdf_read_gildas(y, name, '.vlm', error, rank=3, data=.true.)
  if (error) then
    call gagout('E-UV_MODEL,  Could not read input image')
    goto 999
  endif
  if (y%char%code(1).eq.'FREQUENCY' .or.  &
      y%char%code(1).eq.'VELOCITY'  .or.  &
      y%char%code(1).eq.'UNKNOWN') then
    nf = y%gil%dim(1)
  else
    call gagout('E-UV_MODEL,  First axis unit not FREQUENCY')
    goto 999
  endif
  nx = y%gil%dim(2)
  ny = y%gil%dim(3)
  mess = 'I-UV_TABLE,  '//trim(y%file)//' succesfully opened'
  call gagout(mess)
  ! Define mean observing frequency
  freq = y%gil%freq+y%gil%fres*(nf*0.5-y%gil%ref(1))
  if (freq.lt.0.1) then        ! 100 kHz threshold for warning
    call gagout ('W-UV_MODEL,  VERY low frequency. Please check!')
    write(6,*) 'Value is ',freq,' MHz'
    goto 999
  endif
  !
  ! Get Virtual Memory to perform the FFT
  allocate (tf(nx,ny), work(max(nx,ny)), stat=ier)
!  ip = gag_pointer(addr,memory)    ! Complex copy of the image
!  ipw = gag_pointer(addr,memory)   ! FOURT internal work space
  if (ier.ne.0) then
    mess = 'E-UV_TABLE,  Error allocating virtual memory'
    call gagout (mess)
    goto 999
  endif
  ! Create output table
  call gildas_null(x, type = 'UVT')
  ! Transfer the cube (vlm) header to the UV table header.
  ! Problem: in such a mixed case, gdf_copy_header does not behave properly.
  ! If the input VLM has only 1 channel (dim1 = 1), the UV table will also
  ! have dim1 = 1; as a consequence gdf_setuv will discard all but 1 leading
  ! column, leading to later program error ("suspicious Nlead"). Fixed by
  ! temporarily setting dim1 to the desired size, copy it, and reset it back
  ! to the original value.
  ydim1 = y%gil%dim(1)
  y%gil%dim(1) = x%gil%nlead+x%gil%natom * nf
  call gdf_copy_header (y,x, error)
  y%gil%dim(1) = ydim1  ! Unpatch
  n = len_trim(uvmodel)
  if (n.le.0) then
    mess = 'E-UV_TABLE,  Output file name is empty.'
    call gagout (mess)
    goto 999
  endif
  name = uvmodel(1:n)
  call sic_parsef(name,x%file,' ','.uvt')
  x%gil%nchan = nf
  x%gil%dim(1) = x%gil%nlead+x%gil%natom * nf 
  x%gil%dim(2) = y%gil%dim(2)*(y%gil%dim(3)/2+1)   ! Use hermiticity for a factor of two
  x%gil%dim(3) = 1                 ! space saving
  x%gil%dim(4) = 1
  x%gil%ndim = 2
  x%gil%ref(1)  = y%gil%ref(1)
  x%gil%val(1)  = y%gil%freq
  x%gil%inc(1)  = y%gil%fres
  x%char%code(1) = 'UV-DATA'
  x%char%code(2) = 'RANDOM'
  x%char%code(3) = ' '
  x%char%code(4) = ' '
  x%gil%faxi = 1
  call gdf_create_image (x, error)
  !
  if (error) then
    mess = 'E-UV_MODEL,  Cannot create output UV model '//x%file
    call gagout (mess)
    goto 999
  endif
  call gdf_allocate (x, error)
  if (error) then
    mess = 'E-UV_MODEL,  Cannot obtain memory slot for UV model '
    call gagout (mess)
    goto 999
  endif
  !
  mess = 'I-UV_TABLE,  Output table '//trim(x%file)//' succesfully opened'
  call gagout(mess)
  !
  call uv_pos (error,x%gil%dim(1),x%gil%dim(2),x%r2d,nx,ny,  &
               y%gil%convert(1,2),y%gil%convert(1,3),freq)
  if (error) then
    mess = 'E-UV_TABLE,  Error in UV_POS'
    call gagout(mess)
    goto 999
  endif
  !
  ! OK, compute the model for each channel. Working on an LMV cube would avoid
  ! the (inefficiently programmed) transposition, but would not be consistent
  ! with UV_MODEL. Let's accept the inefficiency for the time being...
  nn(1:2) = y%gil%dim(2:3)
  do if=1,nf
    tf = cmplx ( y%r3d(if,:,:), 0.0)
    call fourt(tf,nn,2,-1,1,work)
    call recent(nx,ny,tf)
    call uv_fill (x%gil%dim(1),x%gil%dim(2),if,x%r2d,nx,ny,tf)
  enddo
  call gdf_write_data (x, x%r2d, error)
  if (error) then
    mess = 'E-UV_TABLE,  Error while updating images'
    call gagout(mess)
    goto 999
  endif
  call gagout('S-UV_TABLE,  Successful completion')
  call sysexi(1)
  !
999 call sysexi(fatale)
end program uv_table
!
subroutine uv_pos(errorfl,nco,nv,visi,nx,ny,xconvert,yconvert,freq)
  use gildas_def
  !---------------------------------------------------------------------
  ! Fill the UV coordinates of the grid points
  !---------------------------------------------------------------------
  logical :: errorfl                             !
  integer(kind=index_length), intent(in) :: nco  !
  integer(kind=index_length), intent(in) :: nv   !
  real :: visi(nco,nv)                           !
  integer :: nx                                  !
  integer :: ny                                  !
  real*8 :: xconvert(3)                          !
  real*8 :: yconvert(3)                          !
  real :: freq                                   !
  ! Global
  include 'gbl_pi.inc'
  ! Local
  real*8 :: clight
  parameter (clight = 299792458)
  real*8 :: lambda
  integer :: i,j,i0,j0,k,iv
  real :: u,v,stepx,stepy
  !
  if (mod(nx,2).ne.0.or.mod(ny,2).ne.0) then
    call gagout('E-UV_TABLE,  Odd image dimensions are not supported yet')
    errorfl = .true.
    return
  elseif (nv.lt.nx*(ny/2+1)) then  ! Internal logic must be wrong!
    call gagout('F-UV_TABLE, Output dimension is too small')
    errorfl = .true.
    return
  endif
  !
  i0 = nx/2+1
  j0 = ny/2+1
  lambda = clight/(freq*1e6)
  stepx = 1./(nx*xconvert(3))*lambda
  stepy = 1./(ny*yconvert(3))*lambda
  !
  iv = 0
  do j=1,j0-1
    v = (j-j0)*stepy
    do i=1,nx
      iv = iv+1
      u = (i-i0)*stepx
      visi(1,iv) = u           ! U
      visi(2,iv) = v           ! V
      visi(3,iv) = 0           ! W
      do k=8,nco,3
        visi(k,iv)   = 0
        visi(k+1,iv) = 0
        visi(k+2,iv) = 1.
      enddo
    enddo
  enddo
  ! Special handling of U axis to avoid storing conjugate data
  do j=j0,j0
    v = (j-j0)*stepy
    do i=1,i0
      iv = iv+1
      u = (i-i0)*stepx
      visi(1,iv) = u           ! U
      visi(2,iv) = v           ! V
      visi(3,iv) = 0           ! W
      do k=8,nco,3
        visi(k,iv)   = 0
        visi(k+1,iv) = 0
        visi(k+2,iv) = 1.
      enddo
    enddo
  enddo
end subroutine uv_pos
!
subroutine uv_fill (nco,nv,if,visi,nx,ny,fft)
  use gildas_def
  !---------------------------------------------------------------------
  ! Fill the visibilities for one frequency channel
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in) :: nco  !
  integer(kind=index_length), intent(in) :: nv   !
  integer :: if                                  !
  real :: visi(nco,nv)                           !
  integer :: nx                                  !
  integer :: ny                                  !
  real :: fft(2,nx,ny)                           !
  ! Local
  integer :: i,j,iv,i0,j0
  !
  i0 = nx/2+1
  j0 = ny/2+1
  !
  iv = 0
  do j=1,j0-1
    do i=1,nx
      iv = iv+1
      visi(5+3*if,iv) =  +(-1)**(i+j)*fft(1,i,j)
      visi(6+3*if,iv) =  -(-1)**(i+j)*fft(2,i,j)
    enddo
  enddo
  do j=j0,j0
    do i=1,i0
      iv = iv+1
      visi(5+3*if,iv) =  +(-1)**(i+j)*fft(1,i,j)
      visi(6+3*if,iv) =  -(-1)**(i+j)*fft(2,i,j)
    enddo
  enddo
end subroutine uv_fill
!
subroutine recent(nx,ny,z)
  !---------------------------------------------------------------------
  ! Recenters the Fourier Transform, for easier display. The present version
  ! will only work for even dimensions.
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  complex :: 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
end subroutine recent
