 
subroutine sub_uv_stitch(n_in, table_in, table_out, &
     weight, factor, mode, spindex, freqref, error)
  use gildas_def
  use gkernel_interfaces
  use image_def
  use gbl_message
  use clean_def
  use clean_default
  use imager_interfaces, except_this=>sub_uv_stitch
  !---------------------------------------------------------------------
  ! @ private
  !
  ! IMAGER -- Merge an arbitray number of UV tables in STITCHING mpde
  !
  ! 
  ! Input :  names of several UV tables  
  ! Output :  one new UV table
  !
  !   UV tables must have the same UV coverage ---
  ! 
  ! UV coverage is set as  
  !   - the Union of the available ones, with data flagged 
  !   if not available, leading to frequency dependent beams.
  ! or  
  !   - the Intersection of the available ones, losing data
  !   but ensuring only one beam for all (except for the frequency
  !   dependence
  !
  ! The Intersect mode is obtained by flagging data that has at least
  ! one channel flagged ...
  !
  ! This is a 3 or 4 pass process. 
  ! - Pass 1: Headers only, build the list of frequency channels
  ! - Pass 2: build required Time - Baseline list.
  ! - Pass 3: Stitch (per file) the spectral visibilities
  ! - Pass 4: Flag data if needed
  !
  ! For the time being, Pass 2 uses the Time - Baseline of the First
  ! UV table.
  !!
  !---------------------------------------------------------------------
  integer, intent(in) :: n_in                 !! Number of input tables
  character(len=*), intent(in) :: table_out   !! Output Table name
  character(len=*), intent(in) :: table_in(*) !! Other tables names
  real, intent(in)  :: weight(*)              !! Weights
  real, intent(in)  :: factor(*)              !! Scale factors
  integer, intent(in)  :: mode                !! Merging mode
  logical, intent(out) :: error               !! Error flag
  real, intent(in) :: spindex                 !! Spectral index
  real, intent(in) :: freqref                 !! Reference frequency
  !
  ! Constants
  character(len=*), parameter :: rname='UV_MERGE'
  integer, parameter :: code_line=0
  integer, parameter :: code_cont=1
  integer, parameter :: code_stack=2
  integer, parameter :: code_concat=-1
  integer, parameter :: code_stitch=-2
  integer, parameter :: code_inter=-3
  real(kind=8), parameter :: pi=3.14159265358979323846d0
  real(kind=8), parameter :: f_to_k = 2.d0*pi/299792458.d-6
  !
  ! Local ---
  character(len=256) :: table_ref   ! Reference Table name
  type(gildas) :: in,inref,out,horigin
  integer, allocatable :: iwork(:,:)
  real(4), allocatable :: rwork(:,:)
  real :: scale_uv(3)
  real(8) :: rfreq
  real :: fact, weig
  integer :: nblock, ier, im
  character(len=80) :: mess
  integer :: code
  integer(kind=size_length) :: in_gil_dim1,in_gil_dim2
  !
!  real(8) :: vinf, vsup, vmin, vmax, vres
  integer :: im_first
  real :: basemin, basemax
  integer :: multiplier, sever
  !
  integer, allocatable :: cmin(:), cmax(:)
  real(8), pointer :: afreq(:)
  real(8), allocatable :: the_freqs(:), tfreq(:)
  integer :: ifi, nfi, nfreq, kfi, kla, jfi, jla, mblock, ib, iv, lv
  real :: oinc, iinc
  real, parameter :: spec_tol=1E-4
  logical :: notrail=.false.    ! TO BE DONE
  integer :: ignore=0 
  integer :: astoke
  !
  ! Code ----
  !  
  error = .true.
  if (n_in.eq.0) return
  if (len_trim(table_out).eq.0) return
  !
  table_ref = table_in(1)
  if (len_trim(table_ref).eq.0) return
  error = .false.
  !
  ! Input file TABLE_REF  (INREF) is the reference one
  call gildas_null(inref, type = 'UVT')
  call gildas_null(in, type = 'UVT')
  call gildas_null(out, type = 'UVT')
  call gildas_null(horigin, type = 'UVT')
  !     
  multiplier = 1 ! Number of output visibilities per input one
  scale_uv = 1.0 ! UV scale by default
  allocate(cmin(n_in),cmax(n_in),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  !
  basemin = 1E38
  basemax = 0.0
  !
  ! Dummy initialization to avoid messages
  in_gil_dim1 = 1
  in_gil_dim2 = 1
  astoke = 0
  rfreq = 1.d0
  !
  im_first = 0
  if (mode.ne.code_stitch) then
    !
    ! Pure Stitching -
    ! All UV tables must have the same Time-Baseline ordering
    !   Channels are "glued" together, using a Random Frequency axis
    !
    call map_message(seve%e,rname,'Invalid mode (expected STITCH)')
    error = .true.
    return
  endif
  !
  ! Setup the Outer UV table from the First data file
  call gdf_read_gildas (horigin, table_in(1), '.uvt', error, data=.false.)
  call gdf_copy_header (horigin, inref, error)
  call gdf_close_image (horigin, error)
  !
  ! Build list of frequencies and verify spectral resolution, except
  ! for continuum stitch mode
  nfi = 0
  allocate(the_freqs(1))  ! Avoid allocation warning message
  do im=1,n_in    ! This loop must execute sequentially
    call gdf_read_gildas (horigin, table_in(im), '.uvt', error, data=.false.)
    if (error) then
      write(mess,'(A,I0)') 'Cannot read input UV table #',im
      call map_message(seve%e,rname,mess)
      return
    endif
    oinc = abs(horigin%gil%inc(1))
    iinc = abs(inref%gil%inc(1)) 
    if (abs(oinc-iinc).gt. spec_tol*iinc) then
      call map_message(seve%w,rname,'Spectral resolution do not match')
    endif
    !
    if (horigin%gil%nfreq.ne.0) then
      ! Random Frequency axis
      nfreq = horigin%gil%nfreq
      afreq => horigin%gil%freqs(1:nfreq)
    else
      nfreq = horigin%gil%nchan
      allocate(afreq(nfreq))
      do ifi=1,nfreq
        afreq(ifi) = (ifi-horigin%gil%convert(1,1))*horigin%gil%convert(3,1) + horigin%gil%convert(2,1)
      enddo
    endif
    if (nfi.eq.0) then
      deallocate(the_freqs) 
      allocate(the_freqs(nfreq))
      nfi = nfreq
      the_freqs(:) = afreq
      cmin(im) = 1
    else
      allocate(tfreq(nfi))
      tfreq(:) = the_freqs(:)
      deallocate(the_freqs)
      allocate(the_freqs(nfi+nfreq))
      the_freqs(1:nfi) = tfreq
      cmin(im) = nfi+1
      the_freqs(nfi+1:) = afreq
      nfi = nfi+nfreq
      deallocate(tfreq)
    endif
    cmax(im) = nfi
    if (abs(horigin%gil%order).eq.abs(code_stok_chan)) then
      inref%gil%order = horigin%gil%order
      astoke = horigin%gil%stokes(1) 
    else
      inref%gil%order = horigin%gil%order
      astoke = horigin%gil%order
    endif
    call gdf_close_image (horigin,error)
    !
  enddo
  !
  ! Compute the number of channels
  inref%gil%nstokes = 0
  if (associated(inref%gil%stokes)) then
    call map_message(seve%w,rname,'Nullifying Stokes ')
  endif
  inref%gil%nchan = nfi
  inref%gil%nfreq = nfi
  allocate(inref%gil%freqs(nfi),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  inref%gil%freqs(1:nfi) = the_freqs(1:nfi)
  !
  inref%gil%dim(1) = horigin%gil%dim(1) + 3*(inref%gil%nchan-horigin%gil%nchan)
  in_gil_dim1 = inref%gil%dim(1)  
  in_gil_dim2 = inref%gil%dim(2)  
  !
  im_first = 0
  inref%gil%freq = sum(inref%gil%freqs) / nfi
  !
  ! Set the Stokes parameters
  if (associated(inref%gil%stokes)) then
    deallocate(inref%gil%stokes,stat=ier)
    Print *,'Stokes deallocation error ',ier
  endif
  nullify(inref%gil%stokes)
  allocate(inref%gil%stokes(inref%gil%nfreq),stat=ier)
  inref%gil%stokes = astoke
  inref%gil%nstokes = 1
  ! Do not forget trailing columns
  call gdf_uv_shift_columns(horigin,inref)
  call gdf_setuv(inref,error)
  call gdf_copy_header (inref, out, error)
  call sic_parse_file(table_out,' ','.uvt',out%file)
  !
  error = .false.
  !
  ! Loop over tables to be merged for further verifications
  do im=1,n_in    ! This loop must execute sequentially
    call gdf_read_gildas (horigin, table_in(im), '.uvt', error, data=.false.)
    if (error) then
      write(mess,'(A,I0)') 'Cannot read input UV table # ',im
      call map_message(seve%e,rname,mess)
      return
    endif
    call gdf_close_image(horigin,error)
    !
    ! Verify number of visibilities match
    if (horigin%gil%nvisi.ne.out%gil%nvisi) then
      write(mess,'(A,I0,A,I0)') 'Visibilities mismatch: Out ',out%gil%nvisi, &
        & ', In ',horigin%gil%nvisi
      call map_message(seve%e,rname,trim(mess)//' '//trim(table_in(im)))
      error = .true.
      return
    endif
    !
    ! Verify Baseline lengths are present
!    if (horigin%gil%basemax.le.horigin%gil%basemin) then
!      call map_message(seve%e,rname,'Missing baseline lengths range in file '//trim(table_in(im)))
!      call map_message(seve%i,rname,'Use command HEADER '//trim(table_in(im))//' /EXTREMA to set them')
!      error = .true.
!      return
!    endif
    !
    call gdf_copy_header(horigin,in,error)
    !
    ! Verify Proper Motion & Epoch match
    if ((in%gil%mura.ne.out%gil%mura).or.(in%gil%mudec.ne.out%gil%mudec)) then
      call map_message(seve%e,rname,'Proper Motions do not match')
      error = .true.
    else if ((in%gil%mura.ne.0.).or.(in%gil%mudec.ne.0.)) then
      if (in%gil%epoc.ne.out%gil%epoc) then
        call map_message(seve%e,rname,'Proper Motions match, but Epochs do not match')
        error = .true.
      endif
    endif
    if (error) return
    !
    ! Verify if trailing columns do match
    call gdf_uvmatch_codes(inref,in,code,ignore)
    if (code.eq.3) then
      ! Column # 3 has a mismatch - Make sure the Ref is now SCAN
      inref%gil%column_pointer(code_uvt_w) = 0
      inref%gil%column_size(code_uvt_w) = 0
      inref%gil%column_pointer(code_uvt_scan) = 3
      inref%gil%column_size(code_uvt_scan) = 1
    else if (code.lt.0) then
      if (notrail) then
        sever = seve%w
        error = .false.
      else
        sever = seve%e
        error = .true. 
      endif
      if (code.eq.-1) then
        call map_message(sever,rname,'Leading columns do not match')
      else if (code.eq.-2) then
        call map_message(sever,rname,'Trailing columns do not match')
        Print *,'Ntrail out ',inref%gil%ntrail,' in ',in%gil%ntrail
      else
        call map_message(sever,rname,'Leading columns do not match')
      endif
      if (error) then
        call map_message(seve%e,rname,'Second pass verification error')
        return
      endif
    endif
    !
  enddo
  !
  ! Finished preparatory work, and create the OUT table
  call map_message(seve%i,rname,'Creating UV table '//trim(out%file))
  call gdf_create_image(out, error)
  if (error) then
    call map_message(seve%e,rname,'Cannot create output UV table')
    return
  endif
  !
  ! Define blocking factor on input file
  call gdf_nitems('SPACE_GILDAS',nblock,in_gil_dim1) ! Visibilities at once
  nblock = min(nblock,in_gil_dim2)
  allocate (out%r2d(out%gil%dim(1),nblock*multiplier), stat=ier)
  if (ier.ne.0) then
    write(mess,*) 'Memory allocation error OUT ',out%gil%dim(1), nblock, multiplier
    call map_message(seve%e,rname,mess)
    call gdf_close_image(out, error)
    error = .true.
    return
  endif
  !
  if (out%gil%nchan.eq.1 .and. in%gil%nchan.eq.1) then
    call map_message(seve%i,rname,'Merging continuum tables')
  else if (mode.eq.code_cont) then
    call map_message(seve%i,rname,'Merging line tables in continuum mode')  
  else 
    allocate (iwork(2,out%gil%nchan), rwork(4,out%gil%nchan), stat=ier)
    if (ier.ne.0) then
      write(mess,*) 'Memory allocation error WORK ',6,out%gil%nchan
      call map_message(seve%e,rname,mess)
      call gdf_close_image(out, error)
      error = .true.
      return
    endif
    call map_message(seve%i,rname,'Merging line tables')
  endif
  !
  ! Append IN channels to OUT with rescaling when needed
  out%trc = 0
  out%blc = 0 
  !
  ! Allocate the appropriate work-space
  allocate (out%r2d(out%gil%dim(1),nblock),stat=ier)
  if (ier.ne.0) then
    write(mess,*) 'Memory allocation error OUT',out%gil%dim(1), nblock
    call map_message(seve%e,rname,mess)
    goto 98
  endif
  !
  mblock = out%gil%dim(2)/nblock
  if (mblock*nblock.ne.out%gil%dim(2)) mblock = mblock+1
  in%blc = 0
  in%trc = 0
  !
  iv = 1
  do ib = 1,mblock
    lv = min(out%gil%nvisi,iv+nblock-1)
    if (mblock.gt.1) then
      write(mess,'(A,I0,A,I0,1X,I0)') 'Handling block ',ib,' Visi ',iv,lv
      call map_message(seve%i,rname,mess)
    endif
    out%blc(2) = iv
    out%trc(2) = lv 
    write(mess,*) iv,' / ',out%gil%dim(2),min(100,nint((iv+nblock-1)*100./out%gil%dim(2))),' %'
    call map_message(seve%i,rname,mess)
    !
    do im = 1,n_in
      mess = 'Reading '//trim(table_in(im))
      call map_message(seve%i,rname,mess)
      call gdf_read_gildas (in, table_in(im), '.uvt', error, data=.false.)
      if (error) then
        write(mess,*) 'Cannot read input UV table #',im
        call map_message(seve%e,rname,mess)
        goto 98
      endif
      !
      allocate (in%r2d(in%gil%dim(1),nblock), stat=ier)
      if (ier.ne.0) then
        write(mess,*) 'Memory allocation error IN ',in%gil%dim(1), nblock
        call map_message(seve%e,rname,mess)
        goto 98
      endif
      !
      fact = factor(im)
      weig = weight(im)
      write(mess,'(A,F8.2,A,F8.2,A,F8.4)') 'Factors: Flux ',fact, &
        & ', Weight ',weig
      call map_message(seve%i,rname,mess)
      !
      in%blc(2) = iv
      in%trc(2) = lv 
      !
      ! read Block on current input file
      if (sic_ctrlc()) goto 98
      !
      call gdf_read_data(in,in%r2d,error)
      if (error) goto 98
      !
      ! Place it at appropriate channel range
      kfi = out%gil%nlead+3*(cmin(im)-1)+1
      kla = out%gil%nlead+3*cmax(im)
      jfi = in%gil%nlead+1
      jla = in%gil%nlead+3*in%gil%nchan
      !
      ! Scale factors and Weight factors should be applied - to be done
      out%r2d(kfi:kla,1:lv-iv+1) = in%r2d(jfi:jla,1:lv-iv+1)
      !
      if (im.eq.1) then
        ! Set leading column
        out%r2d(1:out%gil%nlead,1:lv-iv+1) = in%r2d(1:in%gil%nlead,1:lv-iv+1)
        if (in%gil%ntrail.gt.0) then
          ! Set trailing columns
          kfi = out%gil%lcol+1
          kla = out%gil%dim(1)
          jfi = in%gil%lcol+1
          jla = in%gil%dim(1)
          out%r2d(kfi:kla,1:lv-iv+1) = in%r2d(jfi:jla,1:lv-iv+1)
        endif
      endif
      !
      call gdf_close_image(in,error)
      !
    enddo     ! Block loop
    !
    call gdf_write_data(out,out%r2d,error)
    if (error) goto 98
    ! Increment position
    iv = lv+1
  enddo       ! Block loop
  !
  call gdf_close_image(out,error)
  deallocate(out%r2d)
  return
  !
  ! Error handling
98      continue
  call gdf_close_image(out, error)
  call gdf_close_image(in, error)
  error = .true.
  return
end subroutine sub_uv_stitch
!
