module uv_sort_codes
  !
  integer(kind=4), parameter :: code_sort_bt=1     ! BASE then TIME
  integer(kind=4), parameter :: code_sort_tb=2     ! TIME then BASE
  integer(kind=4), parameter :: code_sort_ubt=3    ! UNIQUE-BASE then TIME
  integer(kind=4), parameter :: code_sort_field=4  ! FIELD
  !
  integer(kind=4), parameter :: ncode_sort=4
  character(len=6), parameter :: sort_names(ncode_sort) = &
    (/ 'BASE  ','TIME  ','UNIQUE','FIELD ' /)
  !
end module uv_sort_codes

subroutine display_uv(chain,error)
  use gbl_message
  use mapping_interfaces, except_this=>display_uv
  use clean_def
  use clean_arrays
  use uv_sort_codes
  !----------------------------------------------------------------------
  ! @ private
  !   SHOW UV
  !     TIME-BASE sort the UV table before displaying it
  !----------------------------------------------------------------------
  character(len=*), intent(in)    :: chain  !
  logical,          intent(inout) :: error  ! Logical error flag
  !
  ! Check data presence in buffer
  if (.not.associated(duv)) then
     call map_message(seve%e,'SHOW','No UV data')
     error = .true.
     return
  endif
  !
  ! Sort buffer (TIME-BASE) when needed and create the associated SIC buffer
  if (.not.allocated(duvt)) then
     call uv_tri(code_sort_tb,error)
     if (error) return
  endif
  !
  ! Plot SIC buffer
  call exec_program('@ p_uvshow_w.map w '//chain)
  !
end subroutine display_uv
!
subroutine uv_sort_comm(line,error)
  use gkernel_interfaces
  use mapping_interfaces, except_this=>uv_sort_comm
  use uv_sort_codes
  !----------------------------------------------------------------------
  ! @ private
  ! Support routine for command
  !   UVSORT [TIME|BASE|FIELD]
  !----------------------------------------------------------------------
  character(len=*), intent(in)    :: line  ! Command line
  logical,          intent(inout) :: error ! Logical error flag
  ! Local
  integer(kind=4) :: code,na
  character(len=6) :: argu,vvoc
  !
  ! Parse input line. Default argument is TIME
  argu = 'TIME'
  call sic_ke(line,0,1,argu,na,.false.,error)
  if (error) return
  call sic_ambigs('UV_SORT',argu,vvoc,code,sort_names,ncode_sort,error)
  if (error) return
  !
  ! Sort uv buffer
  if (code.eq.code_sort_field) then
     call uv_fsort(error)
  else
     call uv_tri(code,error)
  endif
  if (error) return
  !
end subroutine uv_sort_comm
!
subroutine uv_fsort(error)
  use gbl_message
  use gkernel_interfaces
  use mapping_interfaces, except => uv_fsort
  use clean_def
  use clean_arrays
  !-----------------------------------------------------------------
  ! @ private
  ! Support routine for command UV_SORT
  ! Allows for sorting for fields using mosaic uv sorting routines
  !-----------------------------------------------------------------
  logical, intent(inout) :: error
  ! Local
  character(len=*), parameter :: rname='UV_SORT'
  logical :: warning,sorted
  logical, allocatable :: signv(:)
  integer(kind=4) :: ier,ncol,nv,nf,xoff,yoff,loff,moff,ixcol,iycol
  integer(kind=index_length) :: iv,ifi,fsize(1)
  integer(kind=4), allocatable :: it(:)
  real(kind=4) :: cs(2),uvmax,uvmin,xy(2)
  real(kind=4), allocatable :: uarr(:),varr(:),foff(:,:),newv(:)
  real(kind=8), allocatable :: farr(:)
  !
  if (.not.associated(duv)) then
     call map_message(seve%e,rname,'No UV data')
     error = .true.
     return
  endif
  ! Do we find pointing offsets?
  xoff = huv%gil%column_pointer(code_uvt_xoff)
  yoff = huv%gil%column_pointer(code_uvt_yoff)
  if ((xoff.ne.0).or.(yoff.ne.0)) then
     ! Yes => This is a mosaic
     if (yoff.ne.xoff+1) then
        ! Ill-defined mosaic
        call map_message(seve%e,rname,'Mosaic Y column does not follow the X column')
        error = .true.
        return
     endif
     ixcol = xoff
     iycol = yoff
  else
     ! No => Do we find phase offsets?
     loff = huv%gil%column_pointer(code_uvt_loff)
     moff = huv%gil%column_pointer(code_uvt_moff)
     if ((loff.ne.0).or.(moff.ne.0)) then
        ! Yes => This is a mosaic
        if (moff.ne.loff+1) then
           ! Ill-defined mosaic
           call map_message(seve%e,rname,'Mosaic M column does not follow the L column')
           error = .true.
           return
        endif
        ixcol = loff
        iycol = moff
     else
        ! No => This is a single-field
        error = .true.
        call map_message(seve%e,rname,'UV table contains a single field, cannot sort it by field')
        return
     endif
  endif  
  !
  ! Create Sorted UV data
  call sic_delvariable('UVS',.false.,warning)
  !
  ! Check if new UV Table (duvt) is already allocated
  if (allocated(duvt))  deallocate (duvt)
  !
  ! Copy header information
  call gildas_null(huvt)
  call gdf_copy_header(huv,huvt,error)
  if (error) return
  !
  ! Allocate duvt
  allocate(duvt(huvt%gil%dim(1),huvt%gil%dim(2)),stat=ier)
  if (ier.ne.0) then
     call map_message(seve%e,rname,'Error allocating secondary UV buffer')
     error = .true.
     return
  endif
  call sic_def_real('UVS',duvt,huvt%gil%ndim,huvt%gil%dim,.false.,error)
  if (error) return
  !
  ! Start sorting using routines from Mosaic mode
  !
  nv = huv%gil%dim(2)
  ncol = huv%gil%dim(1)
  cs(1) = 1.0 ! no UV shift
  cs(2) = 0.0 ! no UV shift
  xy(1) = 0.0 ! no UV shift
  xy(2) = 0.0 ! no UV shift
  !
  allocate(uarr(nv), varr(nv), signv(nv), farr(nv), it(nv), stat=ier)
  if (ier.ne.0) then
     call map_message(seve%e,rname,'Error allocating work arrays')
     error = .true.
     return
  endif
  call loaduv(duv, ncol, nv, cs, uarr, varr, signv, uvmax, uvmin)
  ! Loading field numbers
  call loadfiuv(duv, ncol, nv, farr, it, sorted, ixcol, iycol, varr, nf, foff)
  !
  ! Proceed to sorting
  if (.not.sorted) then
     call gr8_trie (farr,it,nv,error) ! Actual sorting using quicksort
     deallocate (farr, stat=ier) ! Deallocate farr to save some memory
     allocate (newv(nv), stat=ier)
     if (ier.ne.0) then
        call map_message(seve%e,rname,'Error allocating work arrays')
        error = .true.
        return
     endif
     !
     ! v is sorted here so sortuv can be used later
     do iv=1,nv
        newv(iv) = varr(it(iv))
     enddo
     varr(:) = newv(:)
     deallocate (newv,stat=ier) ! Deallocate newv to save some memory
  else
     deallocate (farr,stat=ier) ! if data is already sorted dealocate farr since it will not be used
  endif
  ! Apply sorting to output visibilities
  call sortuv (duv, duvt, ncol, nv, huv%gil%ntrail, xy, uarr, varr, signv, it)
  !
  ! Deallocate reamining arrays to avoid leaks
  deallocate(uarr, varr, signv, it)
  !
  ! Adding field start and end info to Fields variable
  if (allocated(themap%ifields)) deallocate(themap%ifields)
  allocate(themap%ifields(nf+1))
  ifi = 1
  themap%ifields(ifi) = 1
  do iv=1,nv
     if ( (foff(1,ifi).ne.duvt(ixcol,iv)) .or. &
          &  (foff(2,ifi).ne.duvt(iycol,iv)) ) then
        ifi = ifi+1
        themap%ifields(ifi) = iv
     endif
  enddo
  themap%ifields(nf+1) = nv+1
  fsize(1) = nf+1  
  call sic_def_inte("FIELDS%ifields",themap%ifields,1,fsize,.true.,error)
  deallocate(foff)
  !
  error = .false.
end subroutine uv_fsort
!
subroutine uv_tri(code,error)
  use gbl_message
  use gkernel_interfaces
  use mapping_interfaces, except_this=>uv_tri
  use clean_def
  use clean_arrays
  !----------------------------------------------------------------------
  ! @ private
  ! Support routine for command
  !   UVSORT [TIME|BASE|UNIQUE]
  !----------------------------------------------------------------------
  integer(kind=4), intent(in)    :: code  ! Sorting code
  logical,         intent(inout) :: error ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='UV_SORT'
  integer(kind=4) :: ier,nd,nv,id,iv
  integer(kind=4), allocatable :: it(:),ot(:)
  real(kind=8), allocatable :: order(:)
  logical :: sorted, warning, alloc
  !
  if (.not.associated(duv)) then
    call map_message(seve%e,rname,'No UV data')
    error = .true.
    return
  endif
  !
  ! Create Sorted UV data
  call sic_delvariable('UVS',.false.,warning)
  !
  ! Check first if UVT is already matching UV
  alloc = .false.
  if (allocated(duvt)) then
    if ( (huv%gil%dim(2).ne.huvt%gil%dim(1)) .or. &
      & (huv%gil%dim(1)+3.ne.huvt%gil%dim(2)) ) then
      deallocate (duvt)
    else
      alloc = .true.
    endif
  endif
  !
  call gildas_null (huvt, type = 'TUV')
  call gdf_transpose_header(huv,huvt,'21  ',error)
  if (error)  return
  nd = huvt%gil%dim(2)
  nv = huvt%gil%dim(1)
  huvt%gil%dim(2) = nd+3
  !
  if (.not.alloc) then
    allocate(duvt(huvt%gil%dim(1),huvt%gil%dim(2)),stat=ier)
    if (ier.ne.0) then
      call map_message(seve%e,rname,'Error getting UV memory ')
      error = .true.
      return
    endif
  endif
  call sic_def_real('UVS',duvt,huvt%gil%ndim,huvt%gil%dim,.false.,error)
  if (error) return
  !
  allocate(order(nv),it(nv),ot(nv),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Error getting memory ')
    error = .true.
    return
  endif
  !
  call uv_findtb(code,duv,nv,nd,order,it,ot,sorted,error)
  if (error)  return
  if (sorted) then
    Print *,'****  SHOW UV -- already sorted for code ',code
    do id=1,nd
      do iv=1,nv
        duvt(iv,id) = duv(id,iv)
      enddo
    enddo
  else
    do id=1,nd
      do iv=1,nv
        duvt(iv,id) = duv(id,it(iv))
      enddo
    enddo
  endif
  do iv=1,nv
    duvt(iv,nd+1) = 1.0
  enddo
  deallocate(order,it,ot)
  !
end subroutine uv_tri
!
subroutine uv_findtb(code,uv,nv,nd,order,it,ot,sorted,error)
  use gbl_message
  use gkernel_interfaces
  use mapping_interfaces, except_this=>uv_findtb
  use uv_sort_codes
  !---------------------------------------------------------------
  ! @ private
  !   Support for SHOW UV
  !---------------------------------------------------------------
  integer(kind=4), intent(in)    :: code       ! Code for sort operation
  integer(kind=4), intent(in)    :: nd,nv      ! Size of visibility table
  real(kind=4),    intent(in)    :: uv(nd,nv)  ! Input UV data
  real(kind=8),    intent(out)   :: order(nv)  ! Sorting array
  integer(kind=4), intent(out)   :: it(nv)     ! Sort index
  integer(kind=4), intent(out)   :: ot(nv)     ! Reverse order
  logical,         intent(out)   :: sorted     ! Is already sorted
  logical,         intent(inout) :: error      ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='UV_SORT'
  integer(kind=4), parameter :: datecol=4
  integer(kind=4), parameter :: timecol=5
  integer(kind=4), parameter :: anticol=6
  integer(kind=4), parameter :: antjcol=7
  real(kind=4) :: rdate
  real(kind=8) :: olast
  integer(kind=4) :: iv
  real(kind=4) :: anti,antj,antmin,antmax  ! As they are also REAL*4 in the data
    ! format, avoid rounding issues as we use them as floats anyway.
  !
  select case (code)
  case (code_sort_bt)
    ! Order BASE(primary) then TIME(secondary). Build float list as:
    !   Antenna I   x  100*1000*86400 [pseudo-sec]
    ! + Antenna J   x      1000*86400 [pseudo-sec]
    ! + OffsetDate  x           86400 [sec]
    ! + Time                          [sec]
    ! This assumes 'OffsetDate' is less then 1000, and 'Antenna J' is less
    ! than 100.
    rdate = uv(datecol,1)
    do iv=1,nv
      order(iv) = 1000.d0*86400.0d0*(100.d0*uv(anticol,iv)+uv(antjcol,iv)) +  &
                  (uv(datecol,iv)-rdate)*86400.d0 + uv(timecol,iv)
    enddo
    !
  case (code_sort_ubt)
    ! Order by UNIQUE-BASE then TIME. UNIQUE-BASE means that bases 1-2
    ! and 2-1 are considered equal, and evaluated as 1-2. Then the sorting
    ! strategy is identical to BASE-TIME ordering.
    rdate = uv(datecol,1)
    do iv=1,nv
      anti = uv(anticol,iv)
      antj = uv(antjcol,iv)
      if (anti.lt.antj) then
        antmin = anti
        antmax = antj
      else
        antmin = antj
        antmax = anti
      endif
      order(iv) = 1000.d0*86400.0d0*(100.d0*antmin+antmax) +  &
                  (uv(datecol,iv)-rdate)*86400.d0 + uv(timecol,iv)
    enddo
    !
  case (code_sort_tb)
    ! Order TIME(primary) then BASE(secondary). Build float list as:
    !   OffsetDate  x  86400  [sec]
    ! + Time                  [sec]
    ! + Antenna I   x  0.01   [pseudo-sec]
    ! + Antenna J   x  0.0001 [pseudo-sec]
    ! This assumes 'Antenna I' and 'Antenna J' are less than 100.
    rdate = uv(datecol,1)
    do iv=1,nv
      order(iv) = (uv(datecol,iv)-rdate)*86400.d0 + uv(timecol,iv) +   &
                  (100.0d0*uv(anticol,iv)+uv(antjcol,iv))*1.0d-4
    enddo
    !
  case default
    call map_message(seve%e,rname,'Code is not implemented')
    error = .true.
    return
  end select
  !
  ! Check order... This is for dummy UV Tables produced by e.g. UV_CIRCLE
  ! which have no unique ordering...
  olast = order(1)
  sorted = .true.
  do iv=1,nv
    if (order(iv).lt.olast) then
      sorted = .false.
      exit
    endif
    olast = order(iv)
  enddo
  if (sorted) return
  !
  call gr8_trie(order,it,nv,error)
  if (error) return
  !
  do iv=1,nv
    ot(it(iv)) = iv
  enddo
  !
end subroutine uv_findtb
!
subroutine uv_flag_comm(line,error)
  use gkernel_interfaces
  use mapping_interfaces, except_this=>uv_flag_comm
  use clean_def
  use clean_arrays
  use clean_support
  use clean_types
  !----------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING Support routine for command
  !     UV_FLAG [/ANTENNA] [/RESET]
  !----------------------------------------------------------------------
  character(len=*), intent(in)  :: line  ! Command line
  logical,          intent(out) :: error ! Logical error flag
  !
  integer :: iant
  integer, parameter :: O_RESET=2
  integer, parameter :: O_ANT=1
  !
  ! Parse input line
  if (sic_present(O_RESET,0)) then  ! /RESET
    ! Reset flag array
    call reset_uvflag(duvt,huvt%gil%dim(1),huvt%gil%dim(2))
  else if (sic_present(O_ANT,0) ) then  ! /ANTENNA
    call sic_i4(line,O_ANT,1,iant,.true.,error)
    if (error) return
    ! Plot data
    call sic_let_logi('uvshow%flag',.true.,error)
    call display_buffer_sub('UV_FLAG',2,line,error)
    if (error) return
    call get_uvflag_ant(duvt,huvt%gil%dim(1),huvt%gil%dim(2),iant)
  else
    ! Plot data
    call sic_let_logi('uvshow%flag',.true.,error)
    call display_buffer_sub('UV_FLAG',2,line,error)
    if (error) return
    ! Make user to define a polygon from cursor
    call greg_poly_define('UV_FLAG','',.false.,supportpol,supportvar,error)
    if (error)  return
    ! Get flag array
    call get_uvflag(duvt,huvt%gil%dim(1),huvt%gil%dim(2))
    call sic_let_logi('uvshow%flag',.false.,error)
  endif
  ! Apply flag array to buffer
  call apply_uvflag(duvt,huvt%gil%dim(1),huvt%gil%dim(2)-3,duv)
  do_weig = .true.
  optimize(code_save_uv)%lastnc = -1 !  means UV data.
end subroutine uv_flag_comm
!
subroutine get_uvflag_ant(uvs,nv,nd,iant)
  use gildas_def
  !----------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Set uvflag array from antenna number
  !----------------------------------------------------------------------
  integer(kind=index_length), intent(in) :: nv,nd        ! Size of UV data
  real, intent(inout) :: uvs(nv,nd)
  integer, intent(in) :: iant
  !
  ! Local variables
  integer ne,nf,i
  !
  ne = nd-1
  nf = nd-2
  do i=1,nv
    if (uvs(i,6).eq.iant .or. uvs(i,7).eq.iant) then
      uvs(i,nf) = 0.0
    endif
  enddo
  !
end subroutine get_uvflag_ant
!
subroutine get_uvflag(uvs,nv,nd)
  use gildas_def
  use clean_support
  !----------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Get uvflag array from polygon (0 => Flag, 1 => Keep)
  !----------------------------------------------------------------------
  integer(kind=index_length), intent(in) :: nv,nd        ! Size of UV data
  real, intent(inout) :: uvs(nv,nd)
  !
  ! Local variables
  integer ne,nf
  !
  ne = nd-1
  nf = nd-2
  !
  ! Oh gosh, all that logic assumes the plotted stuff is in
  ! ne, nd, nf ...
  call gr4_inout(supportpol,uvs(1,ne),uvs(1,nd),uvs(1,nf),nv,.true.)
  !
end subroutine get_uvflag
!
!
subroutine reset_uvflag(uvs,nv,nd)
  use gildas_def
  !----------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Reset uvflag array to 1
  !----------------------------------------------------------------------
  integer(kind=index_length), intent(in) :: nv,nd        ! Size of UV data
  real, intent(inout) :: uvs(nv,nd)   ! UV data set
  !
  ! Local variables
  integer :: nf,i
  !
  nf = nd-2
  do i=1,nv
     uvs(i,nf) = 1.0
  enddo
end subroutine reset_uvflag
!
subroutine apply_uvflag(uvs,nv,nd,uv)
  use gildas_def
  !----------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Apply uvflag array by making negative the weight of the flagged data
  !----------------------------------------------------------------------
  integer(kind=index_length), intent(in) :: nv,nd        ! Size of UV data
  real, intent(inout) :: uvs(nv,nd)   ! UV data set
  real, intent(inout) :: uv(nd,nv)    ! Transposed version
  !
  ! Local variables
  real :: factor
  integer :: i,j
  !
  ! Loop on visibilities
  do i=1,nv
     ! Apply uvflag array
     factor = 2*uvs(i,nd+1)-1    ! 1 or -1 depending on selected option
     do j=10,nd,3
        uvs(i,j) = abs(uvs(i,j))*factor
     enddo
     ! Transpose uvs completely because uv and uvs may be ordered differently...
     do j=1,nd
        uv(j,i) = uvs(i,j)
     enddo
  enddo
end subroutine apply_uvflag
