!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
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
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module uv_sort
  use gbl_message
  !
  public :: uv_sort_comm
  public :: uv_tri,uv_findtb
  private
  !
contains
  !
  subroutine uv_sort_comm(line,error)
    use gkernel_interfaces
    use uv_sort_codes
    !----------------------------------------------------------------------
    ! UVSORT [TIME|BASE|FIELD]
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    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 image_def
    use gkernel_interfaces
    use uvmosaic_tool, only: loadfiuv
    use uv_rotate_shift_and_sort_tool, only: sortuv,loaduv
    use uv_buffers
    use uvmap_buffers, only: uvmap_prog
    !-----------------------------------------------------------------
    ! Allows for sorting for fields using mosaic uv sorting routines
    !-----------------------------------------------------------------
    logical, intent(inout) :: error
    !
    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(:)
    character(len=*), parameter :: rname='UV_SORT'
    !
    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 (uvtb%data) is already allocated
    if (allocated(uvtb%data))  deallocate (uvtb%data)
    !
    ! Copy header information
    call gildas_null(uvtb%head)
    call gdf_copy_header(huv,uvtb%head,error)
    if (error) return
    !
    ! Allocate duvt
    allocate(uvtb%data(uvtb%head%gil%dim(1),uvtb%head%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',uvtb%data,uvtb%head%gil%ndim,uvtb%head%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, uvtb%data, 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(uvmap_prog%ifields)) deallocate(uvmap_prog%ifields)
    allocate(uvmap_prog%ifields(nf+1))
    ifi = 1
    uvmap_prog%ifields(ifi) = 1
    do iv=1,nv
       if ( (foff(1,ifi).ne.uvtb%data(ixcol,iv)) .or. &
            &  (foff(2,ifi).ne.uvtb%data(iycol,iv)) ) then
          ifi = ifi+1
          uvmap_prog%ifields(ifi) = iv
       endif
    enddo
    uvmap_prog%ifields(nf+1) = nv+1
    fsize(1) = nf+1  
    call sic_def_inte("FIELDS%ifields",uvmap_prog%ifields,1,fsize,.true.,error)
    deallocate(foff)
    !
    error = .false.
  end subroutine uv_fsort
  !
  subroutine uv_tri(code,error)
    use gkernel_interfaces
    use uv_buffers
    !----------------------------------------------------------------------
    ! UVSORT [TIME|BASE|UNIQUE]
    !----------------------------------------------------------------------
    integer(kind=4), intent(in)    :: code  ! Sorting code
    logical,         intent(inout) :: error
    !
    integer(kind=4) :: ier,nd,nv,id,iv
    integer(kind=4), allocatable :: it(:),ot(:)
    real(kind=8), allocatable :: order(:)
    logical :: sorted, warning, alloc
    character(len=*), parameter :: rname='UV_SORT'
    !
    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(uvtb%data)) then
       if ( (huv%gil%dim(2).ne.uvtb%head%gil%dim(1)) .or. &
            & (huv%gil%dim(1)+3.ne.uvtb%head%gil%dim(2)) ) then
          deallocate (uvtb%data)
       else
          alloc = .true.
       endif
    endif
    !
    call gildas_null (uvtb%head, type = 'TUV')
    call gdf_transpose_header(huv,uvtb%head,'21  ',error)
    if (error)  return
    nd = uvtb%head%gil%dim(2)
    nv = uvtb%head%gil%dim(1)
    uvtb%head%gil%dim(2) = nd+3
    !
    if (.not.alloc) then
       allocate(uvtb%data(uvtb%head%gil%dim(1),uvtb%head%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',uvtb%data,uvtb%head%gil%ndim,uvtb%head%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
             uvtb%data(iv,id) = duv(id,iv)
          enddo
       enddo
    else
       do id=1,nd
          do iv=1,nv
             uvtb%data(iv,id) = duv(id,it(iv))
          enddo
       enddo
    endif
    do iv=1,nv
       uvtb%data(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 gkernel_interfaces
    use uv_sort_codes
    !---------------------------------------------------------------
    ! 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
    !
    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.
    character(len=*), parameter :: rname='UV_SORT'
    !
    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
end module uv_sort
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
