!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
program uvshort_program
  use image_def
  use gkernel_interfaces
  !------------------------------------------------------------------------
  ! Task  UV_SHORT
  !
  !   Compute a short spacings uv table from a single-dish table
  !   by gridding, extending to 0, filtering in uv plane, multiplication
  !   by interferometer primary beam, and sampling in uv plane.
  !
  ! input:  a single-dish table or image, and optionally a mosaic UV Table
  ! output: a UV table
  !------------------------------------------------------------------------
  !
  type uvshort_input_t
     character(len=12)              :: action = "all"
     character(len=filename_length) :: name
     !
     real(kind=4)      :: postol = 0.10         ! [---|sec] Pointing tolerance (fraction of beam on input, arcsec on output)
     real(kind=8)      :: spetol = 0.01         ! [-------] Spectral tolerance (fraction of channel, velocity, frequency)
     !
     real(kind=4)      :: ipfac = 1.0           ! [-------] Multiplicative factor for interferometric data. Normally 1
     !
     character(len=12) :: sdunit = "*"          ! [-------] * means to try "K (Tmb) to Jy/Beam" or "Jy/Beam to Jy/Beam".
     real(kind=4)      :: sdfac = 1.0           ! [-------] Multiplicative factor for single dish data. Normally 1
     real(kind=4)      :: sdwei = 1.0           ! [-------] Single dish  weight factor. Normally 1
     !
     real(kind=4)      :: uvtrunc  = 0.0        ! [      m] Truncation radius. If zero, it will be set to sd_beam - ip_beam
     real(kind=4)      :: sdbeamin = 0.0        ! [sec|rad] Single dish beam of the input table of cube (sec on input, rad internally)
     real(kind=4)      :: sdbeamou = 0.0        ! [sec|rad] Single dish beam of the output cube         (sec on input, rad internally)
     real(kind=4)      :: sddiam   = 0.0        ! [      m] Single dish diameter
     real(kind=4)      :: ipbeam   = 0.0        ! [sec|rad] Interf. primary beam (sec on input, rad internally)
     real(kind=4)      :: ipdiam   = 0.0        ! [      m] Interf. primary diameter
     real(kind=4)      :: uvstep   = 0.0        ! [      m] Step in the UV plane for weight density bins
  end type uvshort_input_t
  !
  type uvshort_action_t
     logical           :: break  = .true.       ! Break running flow on error
     logical           :: all    = .false.      !
     logical           :: setup  = .false.      !
     logical           :: grid   = .false.      ! Grid single dish data
     logical           :: pseudo = .false.      !
     logical           :: merge  = .false.      !
     character(len=12) :: wei = 'natural'       ! Normally UN or NA, but little effect
     logical           :: zero = .false.        ! Zero or short-spacings?
     logical           :: deconv_sd = .true.    ! Deconvolve single dish beam
     logical           :: apply_ip = .true.     ! Apply interferometer primary beam
     logical           :: write_sdou = .true.   ! 
     logical           :: write_uvps = .true.   ! 
  end type uvshort_action_t
  !
  type uvshort_sddata_t
     type(gildas) :: in ! Input single dish table
     type(gildas) :: ou ! (Output) single dish data cube in LMV order
     type(gildas) :: we ! (Output) gridded weights in LM plane
     !
     logical :: islmv = .false. ! TAB or LMV input file?
     real(kind=4)    :: xmin = 0.0
     real(kind=4)    :: xmax = 0.0
     real(kind=4)    :: ymin = 0.0
     real(kind=4)    :: ymax = 0.0
     integer(kind=4) :: xcol = 1
     integer(kind=4) :: ycol = 2
     integer(kind=4) :: wcol = 3
     integer(kind=4) :: mcol(2) = (4,0)
     integer(kind=4) :: nchan = 0
  end type uvshort_sddata_t
  !
  type uvshort_uvdata_t
     type(gildas) :: in ! Input  uv table when used to append
     type(gildas) :: ou ! Output uv table
     type(gildas) :: ps ! Computed pseudo visibilities
     !
     type(gildas) :: inbeam
     type(gildas) :: oubeam
     !
     logical                   :: ismos = .true.      ! Mosaic or single field?
     logical                   :: islm  = .true.      ! LM or XY type UV table?
     integer(kind=4)           :: ocol(2) = 0         ! Table columns where field offsets are stored
     integer(kind=4)           :: wcol = 0            ! Table column where the weights will be taken
     integer(kind=4)           :: ivisi = 0           ! Current number of visibility copied or written
     integer(kind=4)           :: nvisi_per_field = 0 ! Number of pseudo-visibility per field
     integer(kind=4)           :: ifield = 0          ! 
     integer(kind=4)           :: nfield = 0          ! Number of fields
     real(kind=4), allocatable :: raoff(:)            ! Field RA  offsets
     real(kind=4), allocatable :: deoff(:)            ! Field Dec offsets
     real(kind=4)              :: ipdatfac = 1.0      ! User correction to Interferometer calibration
     real(kind=4)              :: sddatfac = 1.0 ! = user%sdfac * prog%sdfac (ie, user correction * unit conversion)
     real(kind=4)              :: sdweifac = 1.0 ! = user%sdwei * prog%sdwei (ie, user correction * automatic guess)
  end type uvshort_uvdata_t
  !
  type uvshort_buffer_t
     integer(kind=4) :: ndim = 2
     integer(kind=4) :: dim(2) = 0
     integer(kind=4) :: nx = 0
     integer(kind=4) :: ny = 0
     integer(kind=4) :: nf = 0
     real(kind=8),    allocatable :: xy(:,:)        ! [ 2,nf] Position shift per channel
     real(kind=4),    allocatable :: uvwei(:,:)     ! [nx,ny] Gridded weights in UV plane
     real(kind=4),    allocatable :: sdlobe_uv(:,:) ! [nx,ny] Single dish beam in UV plane
     real(kind=4),    allocatable :: iplobe_lm(:,:) ! [nx,ny] Interferometer primary beam in LM plane
     complex(kind=4), allocatable :: iplobe_uv(:,:) ! [nx,ny] Interferometer beam in UV plane
     complex(kind=4), allocatable :: visi(:,:,:)    ! [nx,ny,nf] Cube of pseudo visilibities
     real(kind=4),    allocatable :: fftws(:)       ! [2*max(nx,ny)] FFT work space
  end type uvshort_buffer_t
  !
  logical :: break,error
  real(kind=4) :: ubias,vbias,ubuff(8192),vbuff(8192)
  !
  call uvshort_main(break,error)
  if (error.and.break) call sysexi(fatale)
  !
contains
  !
  subroutine uvshort_main(break,error)
    !------------------------------------------------------------------------
    ! Main subroutine
    !------------------------------------------------------------------------
    logical, intent(out) :: break
    logical, intent(out) :: error
    !
    type(uvshort_input_t) :: user
    type(uvshort_input_t) :: prog
    type(uvshort_action_t) :: do
    type(uvshort_sddata_t) :: sd
    type(uvshort_uvdata_t) :: uv
    character(len=*), parameter :: rname='UV_SHORT'
    !
    break = .true.
    error = .false.
    call uvshort_input_get(user)
    call uvshort_check_action(rname,user,prog,do,error)
    if (error) return
    break = do%break
    if (do%all.or.do%setup) then
       call uvshort_check_sd(rname,user,prog,do,sd,error)
       if (error) goto 10
       call uvshort_check_uv(rname,user,prog,do,uv,error)
       if (error) goto 10
       call uvshort_check_spectral_consistency(rname,prog,uv,sd,error)
       if (error) goto 10
       call uvshort_check_uvtrunc(rname,user,uv,sd,prog,do,error)    
       if (error) goto 10
       call uvshort_check_uvstep(rname,user,prog,error)
       if(error) goto 10
       call uvshort_user_feedback(rname,user,prog,do,sd,uv,error)
       if (error) goto 10
    endif
    if (do%all.or.do%pseudo) then
       call uvshort_sd_get(rname,prog,uv,sd,error)
       if (error) goto 10
       call uvshort_pseudo(rname,user,prog,do,sd,uv,error)
       if (error) goto 10
       !!$    if (do_zero) then
!!$       call uvshort_uvzero(rname,user,uvdat%in,error)
!!$       if (error) return
!!$    endif
    endif
!!$ Logic needs to be refined if we want to separate gridding from
!!$ computation of pseudo-visibilities
!!$    if (do%all.or.do%grid) then
!!$       call uvshort_sd_get(rname,prog,uv,sd,error)
!!$       if (error) return
!!$    endif
!!$    if (do%all.or.do%pseudo) then
!!$       call uvshort_pseudo(rname,user,prog,do,sd,uv,error)
!!$       if (error) return
!!$    endif
    if (do%all.or.do%merge) then
       if (.not.do%all) then
          !load uv%ps%gil
       endif
       call uvshort_merge(rname,user,prog,uv,error)
       if (error) return
    endif
    !
    ! Cleaning
10  continue
    call uvshort_sd_free(sd)
    call uvshort_uv_free(uv)
    !
  end subroutine uvshort_main
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Routines to get an analysis input parameters
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 
  subroutine uvshort_input_get(user)
    !------------------------------------------------------------------------
    ! Put task inputs into user structure
    !------------------------------------------------------------------------
    type(uvshort_input_t), intent(inout) :: user
    !
    call gildas_open
    call gildas_char('ACTION$',user%action)
    call gildas_char('NAME$',user%name)
    !
    call gildas_dble('SPETOL$',user%spetol,1)
    call gildas_real('POSTOL$',user%postol,1)
    !
    call gildas_real('IPFAC$',user%ipfac,1)
    !
    call gildas_char('SDUNIT$',user%sdunit)
    call gildas_real('SDFAC$',user%sdfac,1)
    call gildas_real('SDWEI$',user%sdwei,1)
    !
    call gildas_real('UVTRUNC$',user%uvtrunc,1)
    call gildas_real('SDBEAM$',user%sdbeamin,1)         
    call gildas_real('SDDIAM$',user%sddiam,1)         
    call gildas_real('IPBEAM$',user%ipbeam,1)         
    call gildas_real('IPDIAM$',user%ipdiam,1)
    call gildas_real('UVSTEP$',user%uvstep,1)
    call gildas_close
    !
  end subroutine uvshort_input_get
  !    
  subroutine uvshort_check_action(rname,user,prog,do,error)
    use gbl_message
    use gkernel_interfaces
    !------------------------------------------------------------------------
    ! Analysis action input
    !------------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(uvshort_input_t),  intent(inout) :: prog
    type(uvshort_action_t), intent(inout) :: do
    logical,                intent(inout) :: error
    !
    integer(kind=4), parameter :: maction=5
    integer :: iaction
    character(len=12) :: actions(maction),myaction
    data actions /'ALL','SETUP','GRID','PSEUDO','MERGE'/
    !
    prog%action = user%action
    call sic_upper(prog%action)
    call sic_ambigs(rname,prog%action,myaction,iaction,actions,maction,error)
    if (error)  return
    !
    do%break  = .true. ! Default is to break running flow on error
    do%all    = .false.
    do%setup  = .true. ! Setup is required in all cases
    do%grid   = .false.
    do%pseudo = .false.
    do%merge  = .false.
    if (myaction.eq.'ALL') then
       do%all = .true.
    else if (myaction.eq.'SETUP') then
       do%setup = .true.
       do%break = .false. ! When the action is only setup an error is considered just a warning
    else if (myaction.eq.'GRID') then
       do%grid = .true.
    else if (myaction.eq.'PSEUDO') then
       do%pseudo = .true.
    else if (myaction.eq.'MERGE') then
       do%merge = .true.
    else
       call map_message(seve%e,rname,'Unknown action'''//trim(myaction))
       error = .true.
       return
    endif
    !
  end subroutine uvshort_check_action
  !
  subroutine uvshort_check_sd(rname,user,prog,do,sd,error)
    use phys_const
    use image_def
    use gbl_message
    use gkernel_interfaces
    !------------------------------------------------------------------------
    ! Analysis single-dish input
    !------------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(uvshort_input_t),  intent(inout) :: prog
    type(uvshort_action_t), intent(inout) :: do
    type(uvshort_sddata_t), intent(inout) :: sd
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: iaxis
    character(len=12) :: unit
    character(len=filename_length) :: filename,name,dir,ext
    !
    ! Initialization
    call gildas_null(sd%in)
    call gildas_null(sd%ou)
    !
    ! Does the .tab or .lmv corresponding file exist?
    filename = trim(user%name)
    call sic_parse_file(filename,' ','.tab',sd%in%file)
    call gdf_read_header(sd%in,error)
    if (error) then
       call map_message(seve%w,rname,'Input single dish table '//trim(sd%in%file)//' not found')
       error = .false.
       call sic_parse_file(filename,' ','-short.lmv',sd%in%file)
       call gdf_read_header(sd%in,error)
       if (error) then
          call map_message(seve%e,rname,'Input single dish cube '//trim(sd%in%file)//' not found either')
          return
       endif
    endif
    !
    ! Is it a TAB or LMV file?
    if (sd%in%gil%ndim.eq.2) then
       ! *** JP: The table command should set the code code_gdf_xyt
       ! *** JP: and that's what we should check here.
       ! *** JP: How can a user change the code_gdf_xyt for backward compatibility?
       !
       ! Check existence of xcol, ycol, and wcol columns
       if ((sd%xcol.lt.1).or.(sd%in%gil%dim(1).lt.sd%xcol)) then
          call map_message(seve%e,rname,'X column does not exist')
          error = .true.
          return
       endif
       if ((sd%ycol.lt.1).or.(sd%in%gil%dim(1).lt.sd%ycol)) then
          call map_message(seve%e,rname,'Y column does not exist')
          error = .true.
          return
       endif
       if ((sd%wcol.lt.1).or.(sd%in%gil%dim(1).lt.sd%wcol)) then
          call map_message(seve%e,rname,'W column does not exist')
          error = .true.
          return
       endif
       sd%islmv=.false.
       do%grid=.true.
       sd%nchan = sd%in%gil%dim(1)-3
       sd%mcol(1) = 4
       sd%mcol(2) = sd%in%gil%dim(1)
    else if (sd%in%gil%ndim.eq.3) then
       if ((sd%in%gil%xaxi.ne.1).or.(sd%in%gil%yaxi.ne.2).or.(sd%in%gil%faxi.ne.3)) then
          call map_message(seve%e,rname,'Input single dish '//trim(sd%in%file)//' is not an LMV cube')
          error = .true.
          return
       else
          sd%islmv=.true.
          do%grid=.false.
          sd%nchan = sd%in%gil%dim(3)
          sd%mcol(1) = 1
          sd%mcol(2) = sd%in%gil%dim(3)
       endif
    else
       call map_message(seve%e,rname,'Input single dish '//trim(sd%in%file)//' dimension is neither 2 (table) or 3 (cube)')
       error = .true.
       return
    endif
    call gdf_copy_header(sd%in,sd%ou,error)
    if (error) return
    if (do%grid) then
       call sic_parse_name(filename,name,ext,dir)
       if (dir.ne."") then
          filename = trim(dir)//'/'//trim(name)//'-short'
       else
          filename = trim(name)//'-short'
       endif
       call sic_parse_file(filename,' ','.lmv',sd%ou%file)
    else
       sd%ou%file = trim(sd%in%file)
       do iaxis = 1,2
          sd%ou%gil%dim(iaxis) = 2**ceiling(log(real(sd%in%gil%dim(iaxis)))/log(2.0))
          sd%ou%gil%ref(iaxis) = sd%in%gil%ref(iaxis) + (sd%ou%gil%dim(iaxis)/2+1) - floor(sd%in%gil%dim(iaxis)/2.0)
       enddo ! iaxis
    endif
    !
    ! Get telescope diameter and beam
    call uvshort_check_diambeam(rname,sd%in,&
         user%sddiam,user%sdbeamin,&
         prog%sddiam,prog%sdbeamin,error)
    if (error) return
    if (do%grid) then
       ! Takes into account beam smoothing by gridding
       ! 9.0 assumes a Gaussian gridding kernel of 1/3 the single-dish natural HPBW
       prog%sdbeamou = prog%sdbeamin*sqrt(1.0+1.0/9.0)
    else
       prog%sdbeamou = prog%sdbeamin
    endif
    !
    ! Get the unit conversion factor to go to Jy/Beam
    if (user%sdunit.eq."*") then
       ! Searched for recognized units in header
       prog%sdunit = sd%in%char%unit
       unit = prog%sdunit
       call sic_lower(unit)
       if (unit.eq."jy/beam") then
          ! Right unit => Nothing to do!
          prog%sdfac = 1.0
       else if ((unit.eq."k (tmb)").or.(unit.eq."k (ta*)")) then
          prog%sdfac = 2.0*kbolt*1d26*pi*prog%sdbeamou**2/(4.d0*log(2.d0))*(sd%in%gil%freq/clight_mhz)**2
          if ((unit.eq."k (ta*)").and.(user%sdfac.eq.1.0)) then
             call map_message(seve%e,rname,'Unit is K (Ta*) and not K (Tmb)')
             call map_message(seve%e,rname,&
                  'Please set the unit conversion factor from K (Ta*) to K (Tmb) into the sdfac factor')
             error = .true.
             return
          endif
       else
          call map_message(seve%e,rname,'Unknown file unit: '//sd%in%char%unit)
          call map_message(seve%e,rname,&
               'Convert to K (Tmb), or Jy/Beam or enforce the right unit in input')
          error = .true.
          return
       endif
    else
       ! User defined unit
       prog%sdunit = user%sdunit
       unit = prog%sdunit
       call sic_lower(unit)
       if (unit.eq."jy/beam") then
          prog%sdfac = 1.0
       else if (unit.eq."k") then
          prog%sdfac = 2.0*kbolt*1d26*pi*prog%sdbeamou**2/(4.d0*log(2.d0))*(sd%in%gil%freq/clight_mhz)**2
       else if ((unit.eq."k (tmb)").or.(unit.eq."k (ta*)")) then
          prog%sdfac = 2.0*kbolt*1d26*pi*prog%sdbeamou**2/(4.d0*log(2.d0))*(sd%in%gil%freq/clight_mhz)**2
          if ((unit.eq."k (ta*)").and.(user%sdfac.eq.1.0)) then
             call map_message(seve%e,rname,'Unit is K (Ta*) and not K (Tmb)')
             call map_message(seve%e,rname,&
                  'Please set the unit conversion factor from K (Ta*) to K (Tmb) into the sdfac factor')
             error = .true.
             return
          endif
       else
          call map_message(seve%e,rname,'Unknown user unit: '//user%sdunit)
          call map_message(seve%e,rname,' Only K or Jy/Beam is recognised')
          error = .true.
          return
       endif
    endif
    !
    ! Get gridding position tolerance
    prog%postol = prog%sdbeamin*user%postol   
  end subroutine uvshort_check_sd  
  !
  subroutine uvshort_check_uv(rname,user,prog,do,uv,error)
    use image_def
    use gbl_message
    use gkernel_interfaces
    use mapping_interfaces
    !------------------------------------------------------------------------
    ! Analysis user inputs
    !------------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(uvshort_input_t),  intent(inout) :: prog
    type(uvshort_action_t), intent(inout) :: do
    type(uvshort_uvdata_t), intent(inout) :: uv
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: ier
    integer(kind=4) :: xoff,yoff,loff,moff,nvis,ncol
    real(kind=4), allocatable :: duv(:,:),offxy(:,:)
    character(len=filename_length) :: filename,name,ext,dir
    !
    call gildas_null(uv%in,type='UVT')
    call gildas_null(uv%ps,type='UVT')
    call gildas_null(uv%ou,type='UVT')
    !
    ! Does the .uvt corresponding file exist?
    filename  = trim(user%name)
    call sic_parse_file(filename,' ','.uvt',uv%in%file)
    ! Yes => Read the corresponding header
    call gdf_read_header(uv%in,error)
    if (error) return
    ! Create the associated uv table used to compute the beam
    call gdf_copy_header(uv%in,uv%inbeam,error)
    if (error) return
    filename = trim(user%name)//'-beam'
    call sic_parse_file(filename,' ','.uvt',uv%inbeam%file)
    ! Create the pseudo-visibility header
    call gdf_copy_header(uv%in,uv%ps,error)
    if (error) return
    filename  = trim(user%name)
    call sic_parse_name(filename,name,ext,dir)
    if (dir.ne."") then
       filename = trim(dir)//'/'//trim(name)//'-short'
    else
       filename = trim(name)//'-short'
    endif
    call sic_parse_file(filename,' ','.uvt',uv%ps%file)
    ! Create the merged header
    call gdf_copy_header(uv%in,uv%ou,error)
    if (error) return
    filename  = trim(user%name)
    call sic_parse_name(filename,name,ext,dir)
    if (dir.ne."") then
       filename = trim(dir)//'/'//trim(name)//'-merged'
    else
       filename = trim(name)//'-merged'
    endif
    call sic_parse_file(filename,' ','.uvt',uv%ou%file)
    ! Create the associated uv table used to compute the beam
    call gdf_copy_header(uv%ou,uv%oubeam,error)
    if (error) return
    filename = trim(filename)//'-beam'
    call sic_parse_file(filename,' ','.uvt',uv%oubeam%file)
    ! Is it a mosaic?
    ! Do we find phase offsets?
    loff = uv%in%gil%column_pointer(code_uvt_loff)
    moff = uv%in%gil%column_pointer(code_uvt_moff)
    if ((loff.ne.0).or.(moff.ne.0)) then
       ! Yes.
       if (moff.ne.loff+1) then
          call map_message(seve%e,rname,'Mosaic M column does not follow the L column')
          error = .true.
          return
       endif
       uv%in%blc(1:2) = [loff,0]
       uv%in%trc(1:2) = [moff,0]
       uv%ocol(1) = loff
       uv%ocol(2) = moff 
       uv%islm = .true.
       uv%ismos = .true.
    else
       ! No => Do we find pointing offsets?
       xoff = uv%in%gil%column_pointer(code_uvt_xoff)
       yoff = uv%in%gil%column_pointer(code_uvt_yoff)
       if ((xoff.ne.0).or.(yoff.ne.0)) then
          ! Yes.
          if (yoff.ne.xoff+1) then
             call map_message(seve%e,rname,'Mosaic Y column does not follow the X column')
             error = .true.
             return
          endif
          uv%in%blc(1:2) = [xoff,0]
          uv%in%trc(1:2) = [yoff,0]
          uv%ocol(1) = xoff
          uv%ocol(2) = yoff
          uv%islm = .false.
          uv%ismos = .true.
       else
          ! No
          uv%ismos = .false.
          uv%islm  = .true.  ! Programming convention to simplify things later on
          uv%ocol(1) = 0
          uv%ocol(2) = 0
       endif
    endif
    !
    ! Get field offsets
    if (uv%ismos) then
       ! Read the corresponding columns only
       ncol = 2
       nvis = uv%in%gil%nvisi
       allocate(duv(ncol,nvis),stat=ier)
       if (failed_allocate(rname,'Field columns',ier,error)) return
       call gdf_read_data(uv%in,duv,error)
       if (error) return
       ! Sort offsets into equivalence classes
       !   => nf: number of fields
       !   => offxy(2,nf): field offsets
       call mosaic_getfields(duv,ncol,nvis,1,2,uv%nfield,offxy)
       deallocate(duv)
       ! Keep memory of offset information
       uv%nfield = max(uv%nfield,1)
       allocate(uv%raoff(uv%nfield),uv%deoff(uv%nfield),stat=ier)
       if (failed_allocate(rname,'Field offsets',ier,error)) return
       uv%raoff(:) = offxy(1,:)
       uv%deoff(:) = offxy(2,:)
    else
       uv%nfield = 1
       allocate(uv%raoff(uv%nfield),uv%deoff(uv%nfield),stat=ier)
       if (failed_allocate(rname,'Field offsets',ier,error)) return
       uv%raoff = 0.0
       uv%deoff = 0.0
    endif
    !
    ! Get telescope diameter and beam
    call uvshort_check_diambeam(rname,uv%in,&
         user%ipdiam,user%ipbeam,&
         prog%ipdiam,prog%ipbeam,error)
    if (error) return
    !
    ! Multiply unit conversion factor with user multiplicative correction
    uv%sddatfac = user%sdfac*prog%sdfac
    !
    ! Get user weight factor
    if (user%sdwei.eq.0.0) then
       ! Automatic
       prog%sdwei = 1.0
    else
       ! User defined
       prog%sdwei = user%sdwei
    endif
    uv%sdweifac = 1.0 ! *** JP
    ! Get uv table weight column
    uv%wcol = (uv%in%gil%nchan+2)/3
    uv%wcol = uv%in%gil%fcol+3*uv%wcol-1
    !
    if (user%ipfac.ge.1e-7) then
       prog%ipfac = user%ipfac
    else
       call map_message(seve%e,rname,"Interferometer calibration factor cannot be zero or negative")
       error = .true.
       return
    endif
    !
    uv%ipdatfac = prog%ipfac
    !
  end subroutine uvshort_check_uv
  !
  subroutine uvshort_check_uvstep(rname,user,prog,error)
    use gbl_message
    !------------------------------------------------------------------------
    ! Analysis of uvstep
    !------------------------------------------------------------------------
    character(len=*), intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(uvshort_input_t),  intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    if (user%uvstep.eq.0) then
       prog%uvstep = 1.25*prog%ipdiam
    else if (user%uvstep.le.0) then
       call map_message(seve%e,rname,"UVSTEP cannot be negative")
       error = .true.
       return
    else if (user%uvstep.le.prog%uvtrunc) then
       call map_message(seve%e,rname,"UVSTEP cannot be smaller than the UV truncation Radius")
       error = .true.
       return
    else
       prog%uvstep = user%uvstep
    endif
    !
  end subroutine uvshort_check_uvstep
  !
  subroutine uvshort_check_diambeam(rname,head,userdiam,userbeam,progdiam,progbeam,error)
    use phys_const
    use image_def
    use gbl_message
    use mapping_interfaces
    !------------------------------------------------------------------------
    ! Analysis antenna diameter and associated beamwidth
    !------------------------------------------------------------------------
    character(len=*), intent(in)    :: rname
    type(gildas),     intent(in)    :: head
    real(kind=4),     intent(in)    :: userdiam
    real(kind=4),     intent(in)    :: userbeam
    real(kind=4),     intent(inout) :: progdiam
    real(kind=4),     intent(inout) :: progbeam
    logical,          intent(inout) :: error
    !
    character(len=message_length) :: mess
    logical, parameter :: fromressection=.true.
    !
    ! Diameter
    if (userdiam.eq.0) then
       ! It should be automatically defined from the input file.
       if (head%gil%nteles.eq.1) then
          progdiam = head%gil%teles(1)%diam          
       else if(head%gil%nteles.eq.0) then
          write(mess,'(A,A)') 'No telescope section in ',trim(head%file)
          error = .true.
       else
          write(mess,'(A,A)') 'More than 1 telescope defined in ',trim(head%file)
          error = .true.
          return
       endif
       if (error) then
          call map_message(seve%e,rname,mess)
          return
       endif
    else
       ! User defined => No more checks...
       progdiam = userdiam
    endif
    !
    ! Beam
    if (userbeam.eq.0.0) then
       ! It should be automatically defined from the input file.
       progbeam = primary_beam(rname,head,fromressection)
    else
       progbeam = userbeam*rad_per_sec
    endif    
  end subroutine uvshort_check_diambeam
  !
  subroutine uvshort_check_spectral_consistency(rname,prog,uv,sd,error)
    use gbl_message
    !------------------------------------------------------------------------
    ! Check spectral axis consistency
    ! On purpose, return only when all checks are done
    !------------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: prog
    type(uvshort_uvdata_t), intent(in)    :: uv
    type(uvshort_sddata_t), intent(in)    :: sd
    logical,                intent(inout) :: error
    !
    real(kind=8) :: velo
    real(kind=8) :: freq
    character(len=message_length) :: mess
    !
    ! Number of channels
    if (uv%in%gil%nchan.ne.sd%nchan) then
       write(mess,'(A,I0,A,I0,A)') 'Inconsistent number of channels (UVT: ',uv%in%gil%nchan,', SD: ',sd%nchan,')'
       call map_message(seve%e,rname,mess)
       error = .true.
    endif
    ! Velocity resolution
    if (abs(uv%in%gil%vres-sd%in%gil%vres).gt.abs(uv%in%gil%vres*prog%spetol)) then
       write(mess,'(A,F0.8,A,F0.8,A)') 'Inconsitent velocity resolution (UVT: ',uv%in%gil%vres,', SD: ',sd%in%gil%vres,')'
       call map_message(seve%e,rname,mess)
       error = .true.
    endif
    ! Frequency resolution
    if (abs(uv%in%gil%fres-sd%in%gil%fres).gt.abs(uv%in%gil%fres*prog%spetol)) then
       write(mess,'(A,F0.8,A,F0.8,A)') 'Inconsitent velocity resolution (UVT: ',uv%in%gil%fres,', SD: ',sd%in%gil%fres,')'
       call map_message(seve%e,rname,mess)
       error = .true.
    endif
    ! Systemic velocity and rest frequency
    if (sd%islmv) then
       velo = (uv%in%gil%ref(1) - sd%in%gil%ref(3))*sd%in%gil%vres + sd%in%gil%voff
       freq = (uv%in%gil%ref(1) - sd%in%gil%ref(3))*sd%in%gil%fres + sd%in%gil%freq
    else
       velo = (uv%in%gil%ref(1) - sd%in%gil%ref(1) + 3)*sd%in%gil%vres + sd%in%gil%voff
       freq = (uv%in%gil%ref(1) - sd%in%gil%ref(1) + 3)*sd%in%gil%fres + sd%in%gil%freq
    endif
    if (abs(uv%in%gil%voff-velo).gt.abs(uv%in%gil%vres*prog%spetol)) then
       write(mess,'(A,F0.8,A,F0.8,A)') 'Inconsistent velocity axis (UVT: ',uv%in%gil%voff,', SD: ',velo,')'
       call map_message(seve%e,rname,mess)
       error = .true.
    endif
    if (abs(uv%in%gil%freq-freq).gt.abs(uv%in%gil%fres*prog%spetol)) then
       write(mess,'(A,F0.8,A,F0.8,A)') 'Inconsistent frequency axis (UVT: ',uv%in%gil%freq,', SD: ',freq,')'
       call map_message(seve%e,rname,mess)
       error = .true.
    endif
  end subroutine uvshort_check_spectral_consistency
  !
  subroutine uvshort_check_uvtrunc(rname,user,uv,sd,prog,do,error)
    use gbl_message
    !------------------------------------------------------------------------
    ! Check UV truncation radius
    !------------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(uvshort_uvdata_t), intent(in)    :: uv
    type(uvshort_sddata_t), intent(in)    :: sd
    type(uvshort_input_t),  intent(inout) :: prog
    type(uvshort_action_t), intent(inout) :: do
    logical,                intent(inout) :: error
    !
    real(kind=4), parameter :: tol=0.001
    !
    ! Zero or short-spacings?
    if (abs(prog%sddiam-prog%ipdiam).le.tol*prog%ipdiam) then
       do%zero = .true.
       prog%uvtrunc = 0
    else if (prog%sddiam.gt.prog%ipdiam) then
       do%zero = .false.
       if (user%uvtrunc.eq.0.0) then
          ! Automatic
          prog%uvtrunc = prog%sddiam-prog%ipdiam
       else
          ! User defined
          prog%uvtrunc = user%uvtrunc
       endif
    else  
       call map_message(seve%e,rname,'Single dish diameter smaller than interferometer diameter')
       error = .true.
       return
    endif
    !
  end subroutine uvshort_check_uvtrunc
  !
  subroutine uvshort_user_feedback(rname,user,prog,do,sd,uv,error)
    use phys_const
    use image_def
    use gbl_message
    use mapping_interfaces
    !------------------------------------------------------------------------
    ! User feedback
    !------------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(uvshort_input_t),  intent(in)    :: prog
    type(uvshort_action_t), intent(in)    :: do
    type(uvshort_sddata_t), intent(in)    :: sd
    type(uvshort_uvdata_t), intent(in)    :: uv
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: if
    character(len=message_length) :: mess,kind
    !
    ! Interferometric data
    call map_message(seve%r,rname,"---------------------------------------------------------------------------")
    write(mess,'(A,A)') 'Interferometer - Input         file: ',trim(uv%in%file)
    call map_message(seve%r,rname,mess)
!!$    write(mess,'(A,A)') '               - Input beam    file: ',trim(uv%inbeam%file)
!!$    call map_message(seve%r,rname,mess)
    if (do%all.or.do%pseudo) then
       write(mess,'(A,A,x,A)') '               - Short-spacing file: ',trim(uv%ps%file)
       call map_message(seve%r,rname,mess)
    endif
    if (do%all.or.do%merge) then
       write(mess,'(A,A,x,A)') '               - Merged        file: ',trim(uv%ou%file)
       call map_message(seve%r,rname,mess)
!!$       write(mess,'(A,A,x,A)') '               - Merged beam   file: ',trim(uv%oubeam%file)
!!$       call map_message(seve%r,rname,mess)
    endif
    call map_message(seve%r,rname,"")
    ! Mosaic or single-field
    if (uv%islm) then
       write(mess,'(I0,A,I0,A,I0,A)') &
            uv%nfield,'-field mosaic with phase offset columns at (Lcol,Mcol) = (',uv%ocol(1),',',uv%ocol(2),')'
    else
       write(mess,'(I0,A,I0,A,I0,A)') &
            uv%nfield,'-field mosaic with pointing offset columns at (Xcol,Ycol) = (',uv%ocol(1),',',uv%ocol(2),')'
    endif
    call map_message(seve%r,rname,mess)
    do if = 1,uv%nfield
       write(mess,'(A,f8.2,a,F8.2,A)') ' &
            [',uv%raoff(if)*sec_per_rad,',',uv%deoff(if)*sec_per_rad,'] '
       call map_message(seve%r,rname,mess)
    enddo ! if
    call map_message(seve%r,rname,"")
    ! Frequency, diameter, and HPBW
    write(mess,'(A30,F11.6,A)') 'Observed frequency ',uv%in%gil%freq/1d3,' GHz'
    call map_message(seve%r,rname,mess)
    write(mess,'(A30,F6.1,A)') 'Diameter ',prog%ipdiam,' m'
    call map_message(seve%r,rname,mess)
    write(mess,'(A30,F6.1,A)') 'Half primary beam width ',prog%ipbeam*sec_per_rad,'"'
    call map_message(seve%r,rname,mess)
    !
    ! Single dish data
    call map_message(seve%r,rname,"---------------------------------------------------------------------------")
    if (sd%islmv) then
       kind = 'LMV'
    else
       kind = 'TAB'
    endif
    write(mess,'(A,A,x,A,A,A)') 'Single dish - Input  file: ',trim(sd%in%file),'(',trim(kind),')'
    call map_message(seve%r,rname,mess)
    if (do%all.or.do%grid) then
       write(mess,'(A,A,x,A)') '            - Output file: ',trim(sd%ou%file),'(LMV)'
       call map_message(seve%r,rname,mess)
    endif
    call map_message(seve%r,rname,"")
    ! Frequency, diameter, and HPBW
    write(mess,'(A30,F11.6,A)') 'Observed frequency ',sd%in%gil%freq/1d3,' GHz'
    call map_message(seve%r,rname,mess)
    write(mess,'(A30,F6.1,A)') 'Diameter ',prog%sddiam,' m'
    call map_message(seve%r,rname,mess)
    write(mess,'(A30,F6.1,A)') 'Half primary beam width (LMV)',prog%sdbeamou*sec_per_rad,'"'
    call map_message(seve%r,rname,mess)
    call map_message(seve%r,rname,"")
    write(mess,'(A30,F6.1)') 'Interferometer Data factor ',uv%ipdatfac
    call map_message(seve%r,rname,mess)
    call map_message(seve%r,rname,"")
    write(mess,'(A30,F6.1,A)') 'Single Dish Data conversion factor ',prog%sdfac,' (from '//trim(prog%sdunit)//' to Jy/Beam)'
    call map_message(seve%r,rname,mess)
    write(mess,'(A30,F6.1)') 'Single Dish Data user factor ',user%sdfac
    call map_message(seve%r,rname,mess)
    write(mess,'(A30,F6.1,A)') 'Single Dish Data final factor ',uv%sddatfac,' (= conversion * user)'
    call map_message(seve%r,rname,mess)
    call map_message(seve%r,rname,"")
    write(mess,'(A30,F6.1,A)') 'Single Dish Weight user factor ',user%sdwei
    call map_message(seve%r,rname,mess)
    call map_message(seve%r,rname,"")
    if (.not.sd%islmv) then
       write(mess,'(A30,F6.1,A,F7.4,A)') 'Gridding position tolerance ',prog%postol*sec_per_rad,'" (HPBW * ',user%postol,')'
       call map_message(seve%r,rname,mess)
    else
       write(mess,'(A30,I0,A,I0,A)') 'Image cube lmv with ',sd%in%gil%dim(1),' by ',sd%in%gil%dim(2),' pixels'
       call map_message(seve%i,rname,mess)
       write(mess,'(A30,F0.2,A,F0.2,A)') 'Pixel size is ',sd%in%gil%inc(1)*sec_per_rad,' x ', sd%in%gil%inc(2)*sec_per_rad,'"'
       call map_message(seve%i,rname,mess)
    endif
    call map_message(seve%r,rname,"---------------------------------------------------------------------------")
    call map_message(seve%r,rname,'Interferometer and Single-dish data have consistent spectral axes')
    call map_message(seve%r,rname,"")
    write(mess,'(A30,F7.2,A,F6.2,A)') 'UV truncation radius: ',prog%uvtrunc,' m (Useful range = [0.00,',prog%sddiam-prog%ipdiam,'])'
    call map_message(seve%r,rname,mess)
    write(mess,'(a,f8.3,a)') 'UV step: ',prog%uvstep,' m '
    call map_message(seve%r,rname,mess)
    call map_message(seve%r,rname,"---------------------------------------------------------------------------")
    !
  end subroutine uvshort_user_feedback
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Routines to read or make single LMV cube
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  subroutine uvshort_sd_get(rname,prog,uv,sd,error)
    use gkernel_interfaces
    !------------------------------------------------------------------------
    ! Reads Single dish data into sd data structure
    ! If SD already in lmv format: reads file.
    ! Else: Create and fill lmv file from info in .tab file.
    !------------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: prog
    type(uvshort_uvdata_t), intent(in)    :: uv
    type(uvshort_sddata_t), intent(inout) :: sd
    logical,                intent(inout) :: error
    !
    if (sd%islmv) then
       call uvshort_sd_read_lmv(rname,sd%in,sd%ou,sd%we,error)
       if (error) return
       ! *** JP: Is the beam resolution section filled and up-to-date?
    else
       call uvshort_sd_create_lmv(rname,prog,uv,sd,error)
       if (error) return
       call gdf_create_image(sd%ou,error)
       if (error) return
       call gdf_write_data(sd%ou,sd%ou%r3d,error)
       if (error) return
       call gdf_close_image(sd%ou,error)
       if (error) return
    endif
  end subroutine uvshort_sd_get
  !
  subroutine uvshort_sd_read_lmv(rname,lmvin,lmvou,wei,error)
    use gbl_message
    use image_def
    use gkernel_interfaces
    !------------------------------------------------------------------------
    ! Read an existing LMV data cube to be used to compute the short spacings
    !------------------------------------------------------------------------
    character(len=*),  intent(in)    :: rname
    type(gildas),      intent(inout) :: lmvin
    type(gildas),      intent(inout) :: lmvou
    type(gildas),      intent(inout) :: wei
    logical,           intent(inout) :: error
    !
    integer(kind=4) :: ier
    integer(kind=4) :: ix,iy,if,idx,idy
    integer(kind=4) :: jx,jy
    real(kind=4) :: val
    !
    allocate(lmvin%r3d(lmvin%gil%dim(1),lmvin%gil%dim(2),lmvin%gil%dim(3)),stat=ier)
    if (failed_allocate(rname,'Input LMV cube',ier,error)) return
    call gdf_read_data(lmvin,lmvin%r3d,error)
    if (error) return
    allocate(lmvou%r3d(lmvou%gil%dim(1),lmvou%gil%dim(2),lmvou%gil%dim(3)),stat=ier)
    if (failed_allocate(rname,'Output LMV cube',ier,error)) return
    allocate(wei%r2d(lmvou%gil%dim(1),lmvou%gil%dim(2)),stat=ier)
    if (failed_allocate(rname,'Weight of LMV cube',ier,error)) return
    lmvou%r3d = 0.0
    idx = floor(lmvou%gil%ref(1)-lmvin%gil%ref(1))
    idy = floor(lmvou%gil%ref(2)-lmvin%gil%ref(2))
    do if = 1, lmvin%gil%dim(3)
       do iy = 1, lmvin%gil%dim(2)
          jy = iy+idy
          do ix = 1, lmvin%gil%dim(1)
             val = lmvin%r3d(ix,iy,if)
             if (abs(val-lmvin%gil%bval).gt.lmvin%gil%eval) then
                jx = ix+idx
                lmvou%r3d(jx,jy,if) = val
             endif
          enddo ! ix
       enddo ! iy
    enddo ! if
    wei%r2d = 1.0
  end subroutine uvshort_sd_read_lmv
  !
  subroutine uvshort_sd_create_lmv(rname,prog,uv,sd,error)
    use phys_const
    use gbl_message
    use image_def
    use gkernel_interfaces
    use mapping_interfaces
    !------------------------------------------------------------------------
    ! Creates a "well behaved" Single Dish map from a Single Dish table
    ! for derivation of the short spacings of an interferometer mosaic
    !
    ! Use convolution by a fraction of the beam, and smooth extrapolation
    ! to zero beyond the mosaic edge
    !------------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: prog
    type(uvshort_uvdata_t), intent(in)    :: uv
    type(uvshort_sddata_t), intent(inout) :: sd
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: nc,nd,nf,nx,ny
    integer(kind=4) :: ier
    real(kind=8) :: xconv(3),yconv(3)
    real(kind=4), allocatable :: sdwei(:)       ! weights table
    real(kind=4), allocatable :: vlmcube(:,:,:) ! work space for sdin gridded values
    !
    nc = sd%in%gil%dim(1)
    nd = sd%in%gil%dim(2)
    allocate(sd%in%r2d(nc,nd),stat=ier)
    if (failed_allocate(rname,'Input single-dish table',ier,error)) return
    call gdf_read_data(sd%in,sd%in%r2d,error)
    call uvshort_define_lmv(rname,prog,uv,nc,nd,sd,sdwei,nf,nx,ny,xconv,yconv,error)
    if (error) return
    !
    allocate(sd%ou%r3d(nx,ny,nf),stat=ier)
    if (failed_allocate(rname,'Output LMV cube',ier,error)) return
    allocate(vlmcube(nf,nx,ny),stat=ier)
    if (failed_allocate(rname,'Output VLM cube',ier,error)) return
    allocate(sd%we%r2d(nx,ny),stat=ier)
    if (failed_allocate(rname,'Output LM weights',ier,error)) return
    !
    call uvshort_sd_grid(rname,prog,nc,nd,nf,nx,ny,xconv,yconv,sdwei,sd,vlmcube)
    call map_message(seve%i,rname,'Done Single Dish table gridding')
    call uvshort_sd_apodize(rname,prog,nf,nx,ny,xconv,yconv,sd,vlmcube)
    call map_message(seve%i,rname,'Done Single Dish apodisation')
    call uvshort_sd_transpose(vlmcube,sd%ou%r3d,nf,nx*ny)
    call map_message(seve%i,rname,'Done transposition to lmv order')
    !
    deallocate(sdwei,vlmcube)
  end subroutine uvshort_sd_create_lmv
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  subroutine uvshort_define_lmv(rname,prog,uv,nc,nd,sd,sdwei,nf,nx,ny,&
       xconv,yconv,error)
    use phys_const
    use gbl_message
    use gkernel_interfaces
    !------------------------------------------------------------------------
    ! Creates the lmv file to be used to store single image
    !------------------------------------------------------------------------
    character(len=*),          intent(in)    :: rname
    type(uvshort_input_t),     intent(in)    :: prog
    type(uvshort_uvdata_t),    intent(in)    :: uv
    integer(kind=4),           intent(in)    :: nc,nd
    integer(kind=4),           intent(out)   :: nf,nx,ny
    type(uvshort_sddata_t),    intent(inout) :: sd
    real(kind=4), allocatable, intent(inout) :: sdwei(:)
    real(kind=8),              intent(inout) :: xconv(3),yconv(3)
    logical,                   intent(inout) :: error
    !
    integer(kind=4) ::nxmore,nymore,i
    character(len=message_length) :: mess
    !
    call uvshort_reproject_offsets(rname,uv,nd,sd,error)
    if (error) return
    call uvshort_sort_by_increasing_y(rname,sd%in%r2d,nc,nd,sd%ycol,error)
    if (error) return
    call uvshort_get_weight_column(rname,sd%in%r2d,nc,nd,sdwei,sd%wcol,error)
    if (error) return
    !
    ! Field of view and pixel size
    call uvshort_find_size(sd%in%r2d,nc,nd,sd%xcol,sd%ycol,sdwei,sd%xmin,sd%xmax,sd%ymin,sd%ymax)
    xconv(3) = -prog%sdbeamin/4.0
    yconv(3) = +prog%sdbeamin/4.0
    !
    ! Number of pixels
    nx = 2 * max ( nint(abs(sd%xmax/xconv(3))+1),nint(abs(sd%xmin/xconv(3))+1) )
    ny = 2 * max ( nint(abs(sd%ymax/yconv(3))+1),nint(abs(sd%ymin/yconv(3))+1) )
    nxmore = nint(4*prog%sdbeamin/abs(xconv(3)))+1
    nymore = nint(4*prog%sdbeamin/abs(yconv(3)))+1
    nx = nx+2*nxmore
    ny = ny+2*nymore
    !
    ! Extend nx,ny to nearest power of two
    i = 32
    do while(i.lt.nx)
       i = i*2
    enddo
    nx = i
    i = 32
    do while(i.lt.ny)
       i = i*2
    enddo
    ny = i
    !
    ! Reference position for lmv cube header
    xconv(1) = nx/2+1
    xconv(2) = 0.0
    yconv(1) = ny/2+1
    yconv(2) = 0.0
    !
    ! User feedback
    write(mess,'(A,I0,A,I0,A)') 'Creating a cube with ',nx,' by ',ny,' pixels'
    call map_message(seve%i,rname,mess)
    write(mess,'(A,F8.3,A)') 'Pixel size: ',0.1*nint(yconv(3)*10*sec_per_rad),' arcsec'
    call map_message(seve%i,rname,mess)
    !
    ! Warn for big images
    if (nx.gt.512 .or. ny.gt.512) then
       if (nx.gt.8192 .or. ny.gt.8192) then
          call map_message(seve%e,rname,'More than 8192 pixels in X or Y')
          error = .true.
       else
          call map_message(seve%w,rname,'More than 512 pixels in X or Y')
       endif
       write(mess,*) 'Offset extrema are: ',sd%xmin,sd%xmax,sd%ymin,sd%ymax
       call map_message(seve%i,rname,mess)
       write(mess,*) 'Pixel sizes are',xconv(3),yconv(3)
       call map_message(seve%i,rname,mess)
       if (error) return
    endif
    !
    ! Number of channels
    nf = sd%mcol(2)-sd%mcol(1)+1
    write(mess,'(A,I0,A,I0,A,I0,A)') 'Creating ',nf,' channels from [',sd%mcol(1),',',sd%mcol(2),']'
    call map_message(seve%i,rname,mess)
    !
    ! Fill output cube header in LMV order
    call map_message(seve%i,rname,'Creating map file '//trim(sd%ou%file))
    sd%ou%gil%ndim = 3
    sd%ou%gil%dim(1) = nx
    sd%ou%gil%dim(2) = ny
    sd%ou%gil%dim(3) = nf
    sd%ou%gil%dim(4) = 1
    sd%ou%loca%size = nx*ny*nf
    sd%ou%gil%ref(3) = sd%in%gil%ref(1)-sd%mcol(1)+1
    sd%ou%gil%val(3) = sd%ou%gil%voff
    sd%ou%gil%inc(3) = sd%ou%gil%vres
    sd%ou%gil%convert(:,1) = xconv
    sd%ou%gil%convert(:,2) = yconv
    sd%ou%char%code(1) = sd%in%char%code(2)
    sd%ou%char%code(2) = sd%in%char%code(3)
    ! Patch a bug in Header transmission: the table has only 2 dimensions,so the 3rd axis is undefined
    if (len_trim(sd%ou%char%code(2)).eq.0) sd%ou%char%code(2)='DEC'
    sd%ou%char%code(3) = sd%in%char%code(1)
    sd%ou%gil%coor_words = 6*gdf_maxdims       ! not a table
    sd%ou%gil%extr_words = 0                   ! extrema not computed
    sd%ou%gil%xaxi = 1
    sd%ou%gil%yaxi = 2
    sd%ou%gil%faxi = 3
    sd%ou%gil%form = fmt_r4
    ! Take into account gridding kernel
    sd%ou%gil%reso_words = 3
    sd%ou%gil%majo = prog%sdbeamou
    sd%ou%gil%mino = prog%sdbeamou
    sd%ou%gil%posa = 0.0
  end subroutine uvshort_define_lmv
  !
  subroutine uvshort_reproject_offsets(rname,uv,nd,sd,error)
    use gbl_message
    use gkernel_types
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Reproject the single-dish table offsets to the UV table reference
    ! position. SD offsets are replaced in-place. SD header is also
    ! updated to ensure consistency.
    !-------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_uvdata_t), intent(in)    :: uv
    integer(kind=4),        intent(in)    :: nd
    type(uvshort_sddata_t), intent(inout) :: sd
    logical,                intent(inout) :: error
    !
    type(projection_t) :: uvproj,sdproj
    integer(kind=4) :: ioff
    real(kind=8) :: rxoff,ryoff,axoff,ayoff
    !
    ! Setup the projections
    call gwcs_projec(uv%in%gil%a0,uv%in%gil%d0,&
                     uv%in%gil%pang,uv%in%gil%ptyp,&
                     uvproj,error)
    if (error) return
    call gwcs_projec(sd%in%gil%a0,sd%in%gil%d0,&
                     sd%in%gil%pang,sd%in%gil%ptyp,&
                     sdproj,error)
    if (error) return
    !
    if (uv%in%gil%a0.eq.sd%in%gil%a0 .and.  &
        uv%in%gil%d0.eq.sd%in%gil%d0 .and.  &
        uv%in%gil%pang.eq.sd%in%gil%pang .and.  &
        uv%in%gil%ptyp.eq.sd%in%gil%ptyp)  return
    !
    call map_message(seve%i,rname,  &
      'Reprojecting single-dish offsets to UV table projection')
    !
    ! New header (for table AND lmv)
    sd%in%gil%a0 = uv%in%gil%a0
    sd%in%gil%d0 = uv%in%gil%d0
    sd%in%gil%pang = uv%in%gil%pang
    sd%in%gil%ptyp = uv%in%gil%ptyp
    !
    sd%ou%gil%a0 = uv%in%gil%a0
    sd%ou%gil%d0 = uv%in%gil%d0
    sd%ou%gil%pang = uv%in%gil%pang
    sd%ou%gil%ptyp = uv%in%gil%ptyp
    !
    ! New offsets
    do ioff=1,nd
       rxoff = sd%in%r2d(sd%xcol,ioff)
       ryoff = sd%in%r2d(sd%ycol,ioff)
       call rel_to_abs(sdproj,rxoff,ryoff,axoff,ayoff,1)
       call abs_to_rel(uvproj,axoff,ayoff,rxoff,ryoff,1)
       sd%in%r2d(sd%xcol,ioff) = rxoff
       sd%in%r2d(sd%ycol,ioff) = ryoff
    enddo
    !
  end subroutine uvshort_reproject_offsets
  !
  subroutine uvshort_sort_by_increasing_y(rname,data,nc,nd,iy,error)
    use gbl_message
    use gkernel_interfaces
    use mapping_interfaces
    !------------------------------------------------------------------------
    ! Output visi(nc,nd) will contain iy column values in increasing order
    ! In other words, data(iy,*) is the sorting key
    !------------------------------------------------------------------------
    character(len=*), intent(in)    :: rname
    integer(kind=4),  intent(in)    :: nc,nd
    integer(kind=4),  intent(in)    :: iy
    real(kind=4),     intent(inout) :: data(nc,nd)
    logical,          intent(inout) :: error
    !
    integer(kind=4) :: i,ier
    real(kind=4), allocatable :: ws(:) ! Work space
    !
    do i=1,nd-1
       if (data(iy,i).gt.data(iy,i+1)) then
          call map_message(seve%i,rname,'Sorting input table')
          allocate(ws(nc),stat=ier)
          if (failed_allocate(rname,'Sorting work space',ier,error)) return
          ier = trione (data,nc,nd,iy,ws)
          if (ier.ne.1) then
             call map_message(seve%e,rname,'Insufficient sorting space')
             error = .true.
          endif
          deallocate(ws)
          return
       endif
    enddo
    call map_message(seve%i,rname,'Input table is sorted')
  end subroutine uvshort_sort_by_increasing_y
  !
  function trione(x,nd,n,ix,work)
    !------------------------------------------------------------------------
    ! sorting program that uses a quicksort algorithm.
    ! sort on one row
    !------------------------------------------------------------------------
    integer(kind=4), intent(in)    :: nd,n
    real(kind=4),    intent(inout) :: x(nd,n)   ! Array to be sorted
    integer(kind=4), intent(in)    :: ix        ! x(ix,*) is the sorting key
    real(kind=4),    intent(inout) :: work(nd)  ! Work space for exchange
    !
    integer(kind=4), parameter :: maxstack=1000
    integer(kind=4), parameter :: nstop=15
    integer(kind=4) :: trione
    integer(kind=4) :: i,j,k,l1,r1,l,r,m
    integer(kind=4) :: lstack(maxstack),rstack(maxstack),sp
    real(kind=4) :: key
    logical :: mgtl,lgtr,rgtm
    !
    trione = 1
    if (n.le.nstop) goto 50
    sp = 0
    sp = sp + 1
    lstack(sp) = 1
    rstack(sp) = n
    !
    ! Sort a subrecord off the stack
    ! set key = median of x(l),x(m),x(r)
    ! no! this is not reasonable,as systematic very inequal partitioning will
    ! occur in some cases (especially for nearly already sorted files)
    ! to fix this problem,i found (but i cannot prove it) that it is best to
    ! select the estimation of the median value from intermediate records. p.v.
    !
1   l = lstack(sp)
    r = rstack(sp)
    sp = sp - 1
    m = (l + r) / 2
    l1=(2*l+r)/3
    r1=(l+2*r)/3
    !
    mgtl = x(ix,m) .gt. x(ix,l)
    rgtm = x(ix,r) .gt. x(ix,m)
    !
    ! Algorithm to select the median key. the original one from mongo
    ! was completely wrong. p. valiron,24-jan-84 .
    !
    !       mgtl  rgtm  lgtr  mgtl.eqv.lgtr median_key
    !
    ! kl < km < kr  t t * *   km
    ! kl > km > kr  f f * *   km
    !
    ! kl < km > kr  t f f f   kr
    ! kl < km > kr  t f t t   kl
    !
    ! kl > km < kr  f t f t   kl
    ! kl > km < kr  f t t f   kr
    !
    if (mgtl .eqv. rgtm) then
       key = x(ix,m)
    else
       lgtr = x(ix,l) .gt. x(ix,r)
       if (mgtl .eqv. lgtr) then
          key = x(ix,l)
       else
          key = x(ix,r)
       endif
    endif
    i = l
    j = r
    !
    ! Find a big record on the left
    !
10  if (x(ix,i).ge.key) goto 11
    i = i + 1
    goto 10
11  continue
    !
    ! Find a small record on the right
    !
20  if (x(ix,j).le.key) goto 21
    j = j - 1
    goto 20
21  continue
    if (i.ge.j) goto 2
    !
    ! Exchange records
    !
    call r4tor4 (x(1,i),work,nd)
    call r4tor4 (x(1,j),x(1,i),nd)
    call r4tor4 (work,x(1,j),nd)
    i = i + 1
    j = j - 1
    goto 10
    !
    ! Subfile is partitioned into two halves,left .le. right
    ! push the two halves on the stack
    !
2   continue
    if (j-l+1 .gt. nstop) then
       sp = sp + 1
       if (sp.gt.maxstack) then
          write(6,*) 'E-UV_SHORT,Stack overflow ',sp
          trione = 0
          return
       endif
       lstack(sp) = l
       rstack(sp) = j
    endif
    if (r-j .gt. nstop) then
       sp = sp + 1
       if (sp.gt.maxstack) then
          write(6,*) 'E-UV_SHORT,Stack overflow ',sp
          trione = 0
          return
       endif
       lstack(sp) = j+1
       rstack(sp) = r
    endif
    !
    ! anything left to process?
    !
    if (sp.gt.0) goto 1
    !
50  continue
    !
    do 110 j = n-1,1,-1
       k = j
       do i = j+1,n
          if (x(ix,j).le.x(ix,i)) goto 121
          k = i
       enddo
121    continue
       if (k.eq.j) goto 110
       call r4tor4 (x(1,j),work,nd)
       do i = j+1,k
          call r4tor4 (x(1,i),x(1,i-1),nd)
       enddo
       call r4tor4 (work,x(1,k),nd)
110 continue
    !
  end function trione
  !
  subroutine uvshort_get_weight_column(rname,data,nc,nd,we,iw,error)
    !------------------------------------------------------------------------
    ! Fill in weights array from the input table
    !------------------------------------------------------------------------    
    character(len=*),          intent(in)    :: rname
    integer(kind=4),           intent(in)    :: nc
    integer(kind=4),           intent(in)    :: nd
    integer(kind=4),           intent(in)    :: iw          ! Weight column
    real(kind=4),              intent(in)    :: data(nc,nd)
    real(kind=4), allocatable, intent(inout) :: we(:)
    logical,                   intent(inout) :: error
    !
    integer(kind=4) :: ier
    !
    allocate(we(nd),stat=ier)
    if (failed_allocate(rname,'Single-dish weights',ier,error)) return
    !
    if (iw.le.0 .or. iw.gt.nc) then
       ! Weight column does not exist...
       we(1:nd) = 1.0
    else
       ! Weight colum do exist
       we(1:nd) = data(iw,1:nd)
    endif
  end subroutine uvshort_get_weight_column
  !
  subroutine uvshort_find_size(x,nc,nd,ix,iy,we,xmin,xmax,ymin,ymax)
    !------------------------------------------------------------------------
    ! Find extrema xmin,xmax in ix column values
    !          and ymin,ymax in iy column values,
    ! in table x(nd,nd) for points where weight is not null
    ! taking in account that table x is ordered on iy column values.
    !------------------------------------------------------------------------
    integer(kind=4), intent(in)  :: nc,nd       ! Table size
    integer(kind=4), intent(in)  :: ix,iy       ! X and Y column pointers
    real(kind=4),    intent(in)  :: x(nc,nd)    ! Table data
    real(kind=4),    intent(in)  :: we(nd)      ! Weights
    real(kind=4),    intent(out) :: xmin,xmax,ymin,ymax  ! Min-Max
    !
    integer(kind=4) :: i,j
    !
    i = 1
    ! Loop to start after null weights measurements
    do while (we(i).eq.0)
       i = i+1
    enddo
    ! ymin is first y value with weight not null
    ymin = x(iy,i)
    ! initialize xmin and xmax for searching loop
    xmin = x(ix,i)
    xmax = x(ix,i)
    ! Loop on table lines to find xmin and xmax
    i = i+1
    do j=i,nd
       if (we(j).ne.0) then
          if (x(ix,j).lt.xmin) then
             xmin = x(ix,j)
          elseif (x(ix,j).gt.xmax) then
             xmax = x(ix,j)
          endif
       endif
    enddo
    ! Loop to find ymax = last y values with weight not null
    i = nd
    do while (we(i).eq.0)
       i = i-1
    enddo
    ymax = x(iy,i)
  end subroutine uvshort_find_size
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  subroutine uvshort_sd_grid(rname,prog,nc,nd,nf,nx,ny,xconv,yconv,sdwei,sd,vlmcube)
    use mapping_interfaces
    !-----------------------------------------------------------------------
    ! Grid the SD data: Resample in space of the original spectra on a
    ! regular grid, using a convolution kernel
    !
    ! Compute gridding function: a small (1/3 of SD beam) gaussian
    ! Note: since xconv and yconv depends on SD beam, all gridding
    ! parameters do depend on SD beam value...
    !-----------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: prog
    integer(kind=4),        intent(in)    :: nc,nd,nf,nx,ny
    real(kind=8),           intent(in)    :: xconv(3),yconv(3)
    real(kind=4),           intent(in)    :: sdwei(nd)
    type(uvshort_sddata_t), intent(inout) :: sd
    real(kind=4),           intent(inout) :: vlmcube(nf,nx,ny)
    !
    integer(kind=4) :: ctypx,ctypy,ix,iy,ier
    real(kind=4) :: smooth,xparm(10),yparm(10),support(2),cell(2)
    real(kind=4), allocatable :: xcoord(:),ycoord(:)
    !
    ! Define X and Y convolution functions
    smooth = prog%sdbeamin/3.0
    ctypx = 2
    ctypy = 2
    support(1) = 5*smooth
    support(2) = 5*smooth
    xparm(1) = support(1)/abs(xconv(3))
    yparm(1) = support(2)/abs(yconv(3))
    xparm(2) = smooth/(2*sqrt(log(2.0)))/abs(xconv(3))
    yparm(2) = smooth/(2*sqrt(log(2.0)))/abs(yconv(3))
    xparm(3) = 2
    yparm(3) = 2
    call convfn(ctypx,xparm,ubuff,ubias)
    call convfn(ctypy,yparm,vbuff,vbias)
    cell(1) = xconv(3)
    cell(2) = yconv(3)
    ! Grid coordinates
    allocate(xcoord(nx),ycoord(ny),stat=ier)
    if (failed_allocate(rname,'L or M axis',ier,error)) return
    xcoord(:) = (/(real((dble(ix)-sd%ou%gil%ref(1))*sd%ou%gil%inc(1)+sd%ou%gil%val(1)),ix=1,nx)/)
    ycoord(:) = (/(real((dble(iy)-sd%ou%gil%ref(2))*sd%ou%gil%inc(2)+sd%ou%gil%val(2)),iy=1,ny)/)
    ! Do the actual work
    call uvshort_sd_conv(nc,nd,sd%in%r2d,sd%xcol,sd%ycol,sd%mcol(1),&
         sdwei,sd%we%r2d,nf,nx,ny,vlmcube,xcoord,ycoord,support,cell)
    deallocate(xcoord,ycoord)
  end subroutine uvshort_sd_grid
  !
  subroutine uvshort_sd_conv(nd,np,visi,jx,jy,jo,we,gwe,&
      nf,nx,ny,map,mapx,mapy,sup,cell)
    !------------------------------------------------------------------------
    ! Convolution of 'map' by function defined by vbuff & vbias
    ! (via subroutine uvshort_convol, available by CONTAIN association).
    !------------------------------------------------------------------------
    integer(kind=4), intent(in)  :: np                ! number of visibilities
    integer(kind=4), intent(in)  :: nd                ! visibility size
    integer(kind=4), intent(in)  :: nf                ! number of channels
    integer(kind=4), intent(in)  :: nx,ny             ! map size
    integer(kind=4), intent(in)  :: jx,jy             ! x and y columns in visi
    real(kind=4),    intent(in)  :: we(np)            ! weights
    integer(kind=4), intent(in)  :: jo                ! offset for data in visi
    real(kind=4),    intent(in)  :: visi(nd,np)       ! values
    real(kind=4),    intent(out) :: gwe(nx,ny)        ! gridded weights
    real(kind=4),    intent(out) :: map(nf,nx,ny)     ! gridded values
    real(kind=4),    intent(in)  :: mapx(nx),mapy(ny) ! coordinates of grid
    real(kind=4),    intent(in)  :: sup(2)            ! support of convolving function in user units
    real(kind=4),    intent(in)  :: cell(2)           ! cell size in user units
    !
    integer(kind=4) :: ifirs,ilast ! range to be considered
    integer(kind=4) :: ix,iy,i
    real(kind=4) :: result,weight
    real(kind=4) :: u,v,du,dv,um,up,vm,vp
    !
    gwe = 0.0
    ! Loop on Y
    ifirs = 1
    do iy=1,ny
       v = mapy(iy)
       ! sup is the support of the gridding function
       vm = v-sup(2)
       vp = v+sup(2)
       ! Find points to be considered
       call uvshort_find_point(np,nd,jy,visi,vm,ifirs)
       ilast = ifirs
       call uvshort_find_point(np,nd,jy,visi,vp,ilast)
       ilast = ilast-1
       ! Initialize x column
       map(1:nf,1:nx,iy) = 0.0
       if (ilast.ge.ifirs) then
          ! Loop on x cells
          do ix=1,nx
             u = mapx(ix)
             um = u-sup(1)
             up = u+sup(1)
             weight = 0.0
             ! Loop on relevant data points
             do i=ifirs,ilast
                ! Test if X position is within the range to be
                ! considered
                if (visi(jx,i).ge.um .and. visi(jx,i).le.up) then
                   ! Compute convolving factor
                   du = (u-visi(jx,i))/cell(1)
                   dv = (v-visi(jy,i))/cell(2)
                   call uvshort_convol(du,dv,result)
                   if (result.ne.0.0) then
                      ! Do the convolution: map(pixel) = sum of
                      ! relevant values * convolving factor * weight
                      result = result*we(i)
                      weight = weight + result
                      map (1:nf,ix,iy) = map (1:nf,ix,iy) + visi((jo):(nf+jo-1),i)*result
                   endif
                endif
             enddo
             ! gwe is the sum of the (convolving factor * weight) ie
             ! the sum of the weighting factors applied to the data
             gwe(ix,iy) = weight
             ! Normalization (only in cells where some data exists)
             if (weight.ne.0) then
                map (1:nf,ix,iy) = map(1:nf,ix,iy)/weight
             endif
          enddo
       endif
    enddo
  end subroutine uvshort_sd_conv
  !
  subroutine uvshort_find_point(nv,nc,ic,xx,xlim,nlim)
    !-----------------------------------------------------------------------
    ! Optimized dichotomic search of nlim such as
    !   xx(ic,nlim-1) < xlim < xx(ic,nlim)
    ! It assumes that the input data is ordered, and that nlim is already
    ! preset so that xx(ic,nlim-1) < xlim
    !-----------------------------------------------------------------------
    integer(kind=4), intent(in)    :: nv       ! Number of visibilities
    integer(kind=4), intent(in)    :: nc       ! Size of a visibility
    integer(kind=4), intent(in)    :: ic       ! Column to be tested
    integer(kind=4), intent(inout) :: nlim
    real(kind=4),    intent(in)    :: xx(nc,nv),xlim
    !
    integer(kind=4) :: ninf,nsup,nmid
    !
    if (nlim.gt.nv) return
    ! Define limits of searching area in the table
    if (xx(ic,nlim).gt.xlim) then
       return
    elseif (xx(ic,nv).lt.xlim) then
       nlim = nv+1
       return
    endif
    ninf = nlim
    nsup = nv
    ! Dichotomic search for input data ordered
    do while(nsup.gt.ninf+1)
       ! Define middle of the searching area on the table
       nmid = (nsup + ninf)/2
       ! If it's not in the last part,it's in the first one...
       ! then defined new searching limits area
       if (xx(ic,nmid).lt.xlim) then
          ninf = nmid
       else
          nsup = nmid
       endif
    enddo
    ! Output
    nlim = nsup
  end subroutine uvshort_find_point
  !
  subroutine uvshort_convol(du,dv,resu)
    !-----------------------------------------------------------------------
    ! Compute convolving factor resu
    ! resu is the result of the multiplication of the convolution functions,
    ! for u and v axes,at point (du,dv)
    !
    ! Convolution function is defined in ubuff ubias and in vbuff & vbias,
    ! by CONTAIN association in the main program
    !-----------------------------------------------------------------------
    real(kind=4), intent(in)  :: du,dv
    real(kind=4), intent(out) :: resu
    !
    integer(kind=4) :: iu,iv
    !
    ! convolving functions values are tabulated every 1/100 cell
    iu = nint(100.0*du+ubias)
    iv = nint(100.0*dv+vbias)
    !
    ! Participation of u and v axes convolution functions
    resu = ubuff(iu)*vbuff(iv)
    if (resu.lt.1e-20) resu = 0.0
  end subroutine uvshort_convol
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  subroutine uvshort_sd_apodize(rname,prog,nf,nx,ny,xconv,yconv,sd,vlmcube)
    use gbl_message
    use mapping_interfaces
    !-----------------------------------------------------------------------  
    ! Extrapolate to zero outside the convex hull of the mapped region
    !-----------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: prog
    integer(kind=4),        intent(in)    :: nf,nx,ny
    real(kind=8),           intent(in)    :: xconv(3),yconv(3)
    type(uvshort_sddata_t), intent(inout) :: sd
    real(kind=4),           intent(inout) :: vlmcube(nf,nx,ny)
    !
    integer(kind=4) :: ctypx,ctypy,ix,iy,ier
    real(kind=4) :: xparm(10),yparm(10),support(2),cell(2),minwei
    real(kind=4), allocatable :: xcoord(:),ycoord(:)
    !
    ! Define X and Y convolution functions = SD primary beam
    ctypx = 2
    ctypy = 2
    support(1) = 3*prog%sdbeamin
    support(2) = 3*prog%sdbeamin
    xparm(1) = support(1)/abs(xconv(3))
    yparm(1) = support(2)/abs(yconv(3))
    xparm(2) = prog%sdbeamin/(2*sqrt(log(2.0)))/abs(xconv(3))
    yparm(2) = prog%sdbeamin/(2*sqrt(log(2.0)))/abs(yconv(3))
    xparm(3) = 2
    yparm(3) = 2
    call convfn(ctypx,xparm,ubuff,ubias)
    call convfn(ctypy,yparm,vbuff,vbias)
    cell(1) = xconv(3)
    cell(2) = yconv(3)
    ! Grid coordinates
    allocate(xcoord(nx),ycoord(ny),stat=ier)
    if (failed_allocate(rname,'L or M axis',ier,error)) return
    xcoord(:) = (/(real((dble(ix)-sd%ou%gil%ref(1))*sd%ou%gil%inc(1)+sd%ou%gil%val(1)),ix=1,nx)/)
    ycoord(:) = (/(real((dble(iy)-sd%ou%gil%ref(2))*sd%ou%gil%inc(2)+sd%ou%gil%val(2)),iy=1,ny)/)
    !
    call uvshort_sd_analyze_wei(rname,sd%we%r2d,nx,ny,(/sd%we%gil%bval,sd%we%gil%eval/),minwei,error)
    if (error) return
    ! Actual work...
    ! in: vlmcube, out: sd%ou%r3d
    call uvshort_sd_smooth(vlmcube,sd%we%r2d,nf,nx,ny,sd%ou%r3d,&
      xcoord,ycoord,support,cell)
    call map_message(seve%i,rname,'Done image smoothing')
    ! in: sd%ou%r3d, out: vlmcube
!!$ *** JP
!!$    call uvshort_sd_extrapolate(sd%xmin,sd%xmax,sd%ymin,sd%ymax,prog%postol,prog%sdbeam,&
!!$      nf,nx,ny,sd%ou%r3d,vlmcube,xcoord,ycoord,sd%we%r2d,minwei)
!!$ *** JP
    call uvshort_sd_extrapolate(sd%xmin,sd%xmax,sd%ymin,sd%ymax,prog%postol,prog%sdbeamin,&
      nf,nx,ny,sd%ou%r3d,vlmcube,xcoord,ycoord)
    call map_message(seve%i,rname,'Done image extrapolation')
    !
    deallocate(xcoord,ycoord)
  end subroutine uvshort_sd_apodize
  !
  subroutine uvshort_sd_analyze_wei(rname,weiimg,nx,ny,blank,minwei,error)
    use gkernel_interfaces
    use gbl_message
    !-----------------------------------------------------------------------
    ! Compute statistics on the weight image and determine minimal weight
    ! for data to be apodized
    !-----------------------------------------------------------------------
    character(len=*), intent(in)    :: rname
    integer(kind=4),  intent(in)    :: nx,ny
    real(kind=4),     intent(in)    :: blank(2)
    real(kind=4),     intent(in)    :: weiimg(nx,ny)
    real(kind=4),     intent(out)   :: minwei
    logical,          intent(inout) :: error
    !
    real(kind=4) :: max,thres,limx
    real(kind=4), allocatable :: locwei(:)
    integer(kind=4), allocatable :: nind(:)
    integer(kind=4) :: nw,ier,iw,nblan,nval,nbin
    integer(kind=size_length) :: nw8,nume
    !
    ! Allocate work arrays
    nw = nx*ny
    allocate(locwei(nw),nind(nw),stat=ier)
    if (failed_allocate(rname,'Sorted weight arrays',ier,error)) return
    ! weiimg is intent(in), since we need to copy it, might as well reshape
    locwei(:) = reshape(weiimg,(/nw/)) 
    ! sorting
    call gr4_trie(locwei,nind,nw,error)
    if (error) then
       call map_message(seve%e,rname,"Sorting of weights has failed")
       return
    end if
    nblan = 0    
    ! Remove blanking of local weights
    do iw=1,nw 
       if (abs(locwei(iw)-blank(1)).lt.blank(2)) then
          locwei(iw) = 0.0
          nblan = nblan+1
       else if (locwei(iw).eq.0.0) then
          nblan = nblan+1
       endif
    enddo
    ! Computing first box of histogram
    max = locwei(nw)
    nbin = 100
    limx = max/nbin
    nw8 = nw
    call gr4_dicho(nw8,locwei,limx,nume)
    nume=nume-nblan-1
    ! Finding minwei
    do iw=nblan+nume,nw
       if (1.0*(iw-nblan-nume)/nval.gt.thres) then
          minwei = locwei(iw)
          return
       endif
    enddo
    minwei = -1
    error = .true.
    call map_message(seve%e,rname,'Minimal weight for cut off not found')
    deallocate(locwei,nind)
  end subroutine uvshort_sd_analyze_wei
  !
  subroutine uvshort_sd_smooth(raw,we,nf,nx,ny,map,mapx,mapy,sup,cell)
    !-----------------------------------------------------------------------
    ! Smooth an input data cube raw in vlm along l and m by convolution
    ! by a gaussian function defined in vbuff & vbias via subroutine
    ! uvshort_convol (available by CONTAIN association)
    !-----------------------------------------------------------------------
    integer(kind=4), intent(in)  :: nf,nx,ny          ! map size
    real(kind=4),    intent(in)  :: we(nx,ny)         ! weights
    real(kind=4),    intent(in)  :: raw(nf,nx,ny)     ! raw map
    real(kind=4),    intent(out) :: map(nf,nx,ny)     ! smoothed map
    real(kind=4),    intent(in)  :: mapx(nx),mapy(ny) ! coordinates of grid
    real(kind=4),    intent(in)  :: sup(2)            ! support of convolving function in user units
    real(kind=4),    intent(in)  :: cell(2)           ! cell size in user units
    !
    integer(kind=4) :: yfirs,ylast ! range to be considered
    integer(kind=4) :: xfirs,xlast ! range to be considered
    integer(kind=4) :: ix,iy
    integer(kind=4) :: jx,jy       ! x coord, y coord location in raw
    real(kind=4) :: result,weight
    real(kind=4) :: u,v,du,dv,um,up,vm,vp,dx,dy
    !
    dx = abs(mapx(2)-mapx(1))
    dy = abs(mapy(2)-mapy(1))
    ! Loop on y rows
    do iy=1,ny
       ! Compute extrema positions on axe y
       ! of gaussian function centered on map(1:nf,ix,iy)
       v = mapy(iy)
       vm = v-sup(2)
       vp = v+sup(2)
       ! Compute extrema positions on axe y
       ! of relevant data points for map(1:nf,ix,iy) convolution
       yfirs = max(1,nint((iy-sup(2)/dy)))
       ylast = min(ny,nint((iy+sup(2)/dy)))
       ! Initialize x colum
       map(1:nf,1:nx,iy) = 0.0
       ! Loop on x cells
       if (yfirs.le.ylast) then
          do ix=1,nx
             ! Compute extrema positions on axe x,idem y
             u = mapx(ix)
             um = u-sup(1)
             up = u+sup(1)
             weight = 0.0
             xfirs = max(1,nint(ix-sup(1)/dx))
             xlast = min(nx,nint(ix+sup(1)/dx))
             ! Loop on relevant data points
             if (xfirs.le.xlast) then
                do jy=yfirs,ylast
                   dv = (v-mapy(jy))/cell(2)
                   do jx=xfirs,xlast
                      du = (u-mapx(jx))/cell(1)
                      ! Compute convolving factor
                      call uvshort_convol (du,dv,result)
                      if (result.ne.0.0) then
                         ! Do the convolution: map(pixel) = sum of
                         ! relevant values * convolving factor
                         weight = weight + result
                         map (1:nf,ix,iy) = map (1:nf,ix,iy) + raw(1:nf,jx,jy)*result
                      endif
                   enddo
                enddo
                ! Normalize weight only in cells where some data exists...
                if (weight.ne.0) then
                   map (1:nf,ix,iy) = map(1:nf,ix,iy)/weight
                endif
             endif
          enddo
       endif
    enddo
  end subroutine uvshort_sd_smooth
  !
  subroutine uvshort_sd_extrapolate(xmin,xmax,ymin,ymax,tole,beam,&
       nf,nx,ny,map,raw,mapx,mapy)
    !-----------------------------------------------------------------------
    ! Replace map edges of raw input data cube with smoothed values
    ! contains in mapx data cube
    !
    ! Map edges corresponding to the part of the map between
    ! max SD observations locations xmin,xmax,ymin,ymax, and map size nx,ny
    !-----------------------------------------------------------------------
    real(kind=4),    intent(in)  :: xmin,xmax,ymin,ymax,tole,beam
    integer(kind=4), intent(in)  :: nf,nx,ny
    real(kind=4),    intent(in)  :: mapx(nx),mapy(ny)
    real(kind=4),    intent(in)  :: map(nf,nx,ny)
    real(kind=4),    intent(out) :: raw(nf,nx,ny)
    !
    integer(kind=4) :: ix,iy
    real(kind=4) :: lobe,apod,disty,distx
    !
    ! Apodisation by a gaussian, twice as large than the SD beam
    lobe = log(2.0)/beam**2
    ! Loop on pixels
    do iy=1,ny
       ! Compute disty: distance between map size ny
       ! and ymin or ymax SD observations limits
       if (mapy(iy).le.ymin-tole) then
          disty = ymin-mapy(iy)
       elseif (mapy(iy).ge.ymax+tole) then
          disty = mapy(iy)-ymax
       else
          disty = 0.0
       endif
       do ix=1,nx
          ! Idem on X, compute distx
          if (mapx(ix).le.xmin-tole) then
             distx = xmin-mapx(ix)
          elseif (mapx(ix).ge.xmax+tole) then
             distx = mapx(ix)-xmax
          else
             distx = 0.0
          endif
          ! Apodisation factor
          apod = (distx**2+disty**2)*lobe
          ! 'raw' is replaced by something else only in two cases
          if (apod.gt.80) then
             ! Map edges
             raw(1:nf,ix,iy) = 0.0
          elseif (apod.ne.0.0) then
             ! Map edges
             apod = exp(-apod)
             raw(1:nf,ix,iy) = map(1:nf,ix,iy)*apod
          endif
       enddo ! ix
    enddo ! iy
    !
  end subroutine uvshort_sd_extrapolate
  !
  subroutine uvshort_sd_transpose(a,b,n,m)
    !-----------------------------------------------------------------------
    ! Output table "b" is table "a" transposed in line/column order
    !-----------------------------------------------------------------------
    integer(kind=4), intent(in)  :: n,m
    real(kind=4),    intent(in)  :: a(n,m)
    real(kind=4),    intent(out) :: b(m,n)
    !
    integer(kind=4) :: i,j
    !
    do i=1,m
       do j=1,n
          b(i,j) = a(j,i)
       enddo
    enddo
  end subroutine uvshort_sd_transpose
  !
  subroutine uvshort_sd_free(sd)
    !-------------------------------------------------------------------
    ! Clean up a 'uvshort_sddata_t' structure
    !-------------------------------------------------------------------
    type(uvshort_sddata_t), intent(inout) :: sd
    !
    if (associated(sd%in%r2d))  deallocate(sd%in%r2d)
    if (associated(sd%we%r2d))  deallocate(sd%we%r2d)
    if (associated(sd%ou%r3d))  deallocate(sd%ou%r3d)
    !
  end subroutine uvshort_sd_free
  !
  subroutine uvshort_uv_free(uv)
    !-------------------------------------------------------------------
    ! Clean up a 'uvshort_uvdata_t' structure
    !-------------------------------------------------------------------
    type(uvshort_uvdata_t), intent(inout) :: uv
    !
    if (associated(uv%ps%r2d))  deallocate(uv%ps%r2d)
    if (associated(uv%inbeam%r2d))  deallocate(uv%inbeam%r2d)
    if (associated(uv%oubeam%r2d))  deallocate(uv%oubeam%r2d)
    !
  end subroutine uvshort_uv_free
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  subroutine uvshort_pseudo(rname,user,prog,do,sd,uv,error)
    use gbl_message
    !$ use omp_lib
    !-----------------------------------------------------------------------
    !
    !-----------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(uvshort_input_t),  intent(in)    :: prog
    type(uvshort_action_t), intent(in)    :: do
    type(uvshort_sddata_t), intent(in)    :: sd
    type(uvshort_uvdata_t), intent(inout) :: uv
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: ifield
    type(uvshort_buffer_t) :: buf
    character(len=message_length) :: mess
    !
    !$ integer(kind=4) :: ompkind, dochunksize, ompcounter, threadid
    !
    call uvshort_pseudo_header(rname,prog,sd,uv)
    call map_message(seve%i,rname,'Done definition of pseudo-visibility header')
    !
    !$OMP PARALLEL &
    !$OMP DEFAULT(none) &
    !$OMP SHARED(rname,do,prog,uv,sd,error,ompkind,ompcounter,dochunksize) &
    !$OMP FIRSTPRIVATE(buf) &
    !$OMP PRIVATE(ifield,mess,threadid)
    !$ ompcounter = 0
    call uvshort_pseudo_buffer_allocate(rname,&
         sd%ou%gil%dim(1),sd%ou%gil%dim(2),sd%ou%gil%dim(3),&
         buf,error)
    if (.not.error) then
       call map_message(seve%i,rname,'Done buffer memory allocation')
       call uvshort_pseudo_get_sdlobe_uv(prog%sddiam,sd%ou,buf)
       call map_message(seve%i,rname,'Done single-dish lobe definition')
       !
       ! Loop on mosaic field
       !$OMP DO
       do ifield=1,uv%nfield
          if (.not.error) then
             !$ threadid = omp_get_thread_num();
             !$ if (threadid.eq.0) then
             !$    call OMP_GET_SCHEDULE(ompkind, dochunksize)
             !$    if (OMP_IN_PARALLEL()) then
             !$       ompcounter = ompcounter +1
             !$       write(mess,'(A,i0,A,i0)') 'Computing chunk: ',ompcounter,' / ',dochunksize
             !$    else
                      write(mess,'(A,i0,A,i0)') 'Computing field ',ifield,' / ',uv%nfield
             !$    end if
                   call map_message(seve%i,rname,mess)
             !$ end if          
             call uvshort_pseudo_get_iplobe(prog%ipdiam,prog%ipbeam,uv,sd%ou,ifield,buf)
             call uvshort_pseudo_compute_visi(do,sd,buf)
             call uvshort_pseudo_compute_wei(do,sd,buf)
             call uvshort_pseudo_fill_uvt(rname,prog%uvtrunc,sd%ou,ifield,buf,uv,error)
          endif
       enddo ! ifield
       !$OMP END DO
    endif
    call uvshort_pseudo_buffer_deallocate(rname,buf,error)
    !$OMP END PARALLEL
    if (error) return ! This is not allowed inside parallel session, moved out
    !
    ! Write pseudo-visibility table
    call gdf_create_image(uv%ps,error)
    if (error) return
    call gdf_write_data(uv%ps,uv%ps%r2d,error)
    if (error) return
    call gdf_close_image(uv%ps,error)
    if (error) return
    ! *** JP => Should clean up memory
  end subroutine uvshort_pseudo
  !
  subroutine uvshort_pseudo_header(rname,prog,sd,uv)
    use gbl_message
    use gkernel_interfaces
    !-----------------------------------------------------------------------
    !
    !-----------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: prog
    type(uvshort_sddata_t), intent(in)    :: sd
    type(uvshort_uvdata_t), intent(inout) :: uv
    !
    integer(kind=4) :: nvis,ncol,ier
    !
    call map_message(seve%i,rname,'Creating UV table '//trim(uv%ps%file))
    call uvshort_pseudo_count_visi(sd%ou,prog%uvtrunc,uv%nvisi_per_field)
    nvis = uv%nvisi_per_field*uv%nfield
    ! Initialize the header
    uv%ps%gil%nvisi = nvis
    uv%ps%gil%dim(2) = nvis
    uv%ps%blc(2) = 1
    uv%ps%trc(2) = nvis
    ncol = uv%ps%gil%dim(1)
    allocate(uv%ps%r2d(ncol,nvis),stat=ier)
    if (failed_allocate(rname,'pseudo visibility table',ier,error)) return
  end subroutine uvshort_pseudo_header
  !
  subroutine uvshort_pseudo_count_visi(lmv,uvmax,nvisi)
    use phys_const
    use image_def
    !-----------------------------------------------------------------------
    ! Compute number of visibilities nvisi sampled on a regular grid of
    ! steps dx, dy inside the disk of radius uvmax for one mosaic field
    ! -----------------------------------------------------------------------
    type(gildas),    intent(in)  :: lmv
    real(kind=4),    intent(in)  :: uvmax
    integer(kind=4), intent(out) :: nvisi
    !
    integer(kind=4) :: i,j,ii,jj,nx,ny
    real(kind=4) :: uu,vv,uvmax2
    real(kind=8) :: dx,dy
    !
    dx = clight_mhz/lmv%gil%freq/(lmv%gil%inc(1)*lmv%gil%dim(1))
    dy = clight_mhz/lmv%gil%freq/(lmv%gil%inc(2)*lmv%gil%dim(2))
    uvmax2 = uvmax**2
    ! Count number of visilibity for one mosaic field
    nx = lmv%gil%dim(1)
    ny = lmv%gil%dim(2)
    nvisi = 0
    do j = 1,ny
       jj = mod(j-1+ny/2,ny)-ny/2
       vv = jj*dy
       do i = 1,nx/2
          ii = mod(i-1+nx/2,nx)-nx/2
          uu = ii*dx
          if (uu*uu+vv*vv.le.uvmax2) then
             nvisi = nvisi + 1
          endif
       enddo ! i
    enddo ! j
  end subroutine uvshort_pseudo_count_visi
  !
  subroutine uvshort_pseudo_buffer_allocate(rname,nx,ny,nf,buf,error)
    use gkernel_interfaces
    !-----------------------------------------------------------------------
    !
    !-----------------------------------------------------------------------
    character(len=*),           intent(in)    :: rname
    integer(kind=index_length), intent(in)    :: nx,ny,nf
    type(uvshort_buffer_t),     intent(inout) :: buf
    logical,                    intent(inout) :: error
    !
    integer(kind=4) :: ier
    !
    allocate(buf%xy(2,nf),stat=ier)
    if (failed_allocate(rname,'phase shift memory',ier,error)) return
    allocate(buf%sdlobe_uv(nx,ny),stat=ier)
    if (failed_allocate(rname,'single dish beam',ier,error)) return
    allocate(buf%iplobe_uv(nx,ny),stat=ier)
    if (failed_allocate(rname,'interferometer primary beam',ier,error)) return
    allocate(buf%iplobe_lm(nx,ny),stat=ier)
    if (failed_allocate(rname,'interferometer primary beam',ier,error)) return
    allocate(buf%visi(nx,ny,nf),stat=ier)
    if (failed_allocate(rname,'work space',ier,error)) return
    allocate(buf%uvwei(nx,ny),stat=ier)
    if (failed_allocate(rname,'uv weights',ier,error)) return
    allocate(buf%fftws(2*max(nx,ny)),stat=ier)
    if (failed_allocate(rname,'FFT work space',ier,error)) return
    ! Successful allocation
    buf%nx = nx
    buf%ny = ny
    buf%nf = nf
    buf%ndim = 2
    buf%dim(1) = nx
    buf%dim(2) = ny
  end subroutine uvshort_pseudo_buffer_allocate
  !
  subroutine uvshort_pseudo_buffer_deallocate(rname,buf,error)
    use gkernel_interfaces
    use gbl_message
    !-----------------------------------------------------------------------
    ! 
    !-----------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_buffer_t), intent(inout) :: buf
    logical,                intent(inout) :: error
    !
    buf%nx = 0
    buf%ny = 0
    buf%nf = 0
    buf%ndim = 0
    buf%dim(1) = 0
    buf%dim(2) = 0
    !
    if (allocated(buf%xy)) deallocate(buf%xy)
    if (allocated(buf%sdlobe_uv)) deallocate(buf%sdlobe_uv)
    if (allocated(buf%iplobe_uv)) deallocate(buf%iplobe_uv)
    if (allocated(buf%iplobe_lm)) deallocate(buf%iplobe_lm)
    if (allocated(buf%visi)) deallocate(buf%visi)
    if (allocated(buf%uvwei)) deallocate(buf%uvwei)
    if (allocated(buf%fftws)) deallocate(buf%fftws)
  end subroutine uvshort_pseudo_buffer_deallocate
  !
  subroutine uvshort_pseudo_get_sdlobe_uv(diam,lmv,buf)
    use phys_const
    use image_def
    !-----------------------------------------------------------------------
    ! Compute the single-dish beam directly in the uv plane, i.e., a
    ! Gaussian truncated at dish size
    !-----------------------------------------------------------------------
    real(kind=4),           intent(in)    :: diam
    type(gildas),           intent(in)    :: lmv
    type(uvshort_buffer_t), intent(inout) :: buf
    !
    integer(kind=4) :: i,j,ii,jj,nx,ny
    real(kind=4) :: a,b,xx,yy
    real(kind=4) :: beam
    real(kind=8) :: dx,dy
    !
    ! Equivalent beam area in square pixels
    beam = lmv%gil%majo ! *** JP is it what we actually want?
    dx = clight_mhz/lmv%gil%freq/(lmv%gil%inc(1)*lmv%gil%dim(1))
    dy = clight_mhz/lmv%gil%freq/(lmv%gil%inc(2)*lmv%gil%dim(2))
    a = abs(4*alog(2.)/pi/beam**2*lmv%gil%inc(2)*lmv%gil%inc(1))
    b = (pi*beam/2/clight_mhz*lmv%gil%freq)**2/alog(2.)
! *** JP
!    print *,'sdlobe',beam,a,b
!    print *,'sdlobe: freq,dx,dy',lmv%gil%freq,dx,dy
! *** JP
    ! Loop on pixels
    nx = buf%nx
    ny = buf%ny
    do j = 1,ny
       ! Loop on Y, pixels locations on Fourier plane
       jj = mod(j-1+ny/2,ny)-ny/2
       yy = ( jj*dy )**2
       do i = 1,nx
          ! Loop on X, pixels locations on Fourier plane
          ii = mod(i-1+nx/2,nx)-nx/2
          xx = ( ii*dx )**2
          ! Truncation of the gaussian at diam
          if (xx+yy.le.diam**2) then
             buf%sdlobe_uv(i,j) = exp(b*(xx+yy))*a
          else
             buf%sdlobe_uv(i,j) = 0.0
          endif
       enddo ! i
    enddo ! j
  end subroutine uvshort_pseudo_get_sdlobe_uv
  !
  subroutine uvshort_pseudo_get_iplobe(diam,beam,uv,lmv,ifield,buf)
    use phys_const
    use image_def
    !-----------------------------------------------------------------------
    ! 1. Compute the interferometric primary beam directly in the uv plane, i.e.,
    !    Gaussian truncated at dish size
    ! 2. UV shift the beam at (uv%raoff(ifield),uv%deoff(ifield)) in the uv plane
    ! 3. And inverse Fourier Transform it to get the interferometric primary
    !    beam in the LM plane
    !----------------------------------------------------------------------
    real(kind=4),           intent(in)    :: diam
    real(kind=4),           intent(in)    :: beam
    type(uvshort_uvdata_t), intent(in)    :: uv
    type(gildas),           intent(in)    :: lmv
    integer(kind=4),        intent(in)    :: ifield
    type(uvshort_buffer_t), intent(inout) :: buf
    !
    integer(kind=4) :: i,j,ii,jj,nx,ny
    real(kind=4) :: a,b,xx,yy
    real(kind=8) :: dx,dy
    !
    ! Equivalent beam area in square pixels...
    dx = clight_mhz/lmv%gil%freq/(lmv%gil%inc(1)*lmv%gil%dim(1))
    dy = clight_mhz/lmv%gil%freq/(lmv%gil%inc(2)*lmv%gil%dim(2))
    a = abs(4*alog(2.)/pi/beam**2*lmv%gil%inc(2)*lmv%gil%inc(1))
    b = (pi*beam/2/clight_mhz*lmv%gil%freq)**2/alog(2.)
! *** JP
!    print *,'iplobe: beam,a,b',beam,a,b
!    print *,'iplobe: freq,dx,dy',lmv%gil%freq,dx,dy
! *** JP
    ! Loop on pixels
    nx = buf%nx
    ny = buf%ny
    do j = 1,ny
       ! Loop on Y, pixels locations on Fourier plane
       jj = mod(j-1+ny/2,ny)-ny/2
       yy = ( jj*dy )**2
       do i = 1,nx
          ! Loop on X, pixels locations on Fourier plane
          ii = mod(i-1+nx/2,nx)-nx/2
          xx = ( ii*dx )**2
          ! Truncation of the gaussian at diam
          if (xx+yy.le.diam**2) then
             buf%iplobe_uv(i,j) = cmplx(exp(-b*(xx+yy))*a)
          else
             buf%iplobe_uv(i,j) = cmplx(0.0)
          endif
       enddo ! i
    enddo ! j
    ! UV shift
    call uvshort_pseudo_uvshift_iplobe(&
         uv%raoff(ifield),uv%deoff(ifield),lmv,buf)
    ! Inverse Fourier Transform
    call fourt(buf%iplobe_uv,buf%dim,buf%ndim,1,1,buf%fftws)
    call cmtore(buf%iplobe_uv,buf%iplobe_lm,buf%nx,buf%ny)
    ! Normalize peak to 1
    buf%iplobe_lm(:,:) = buf%iplobe_lm/maxval(buf%iplobe_lm)
  end subroutine uvshort_pseudo_get_iplobe
  !
  subroutine uvshort_pseudo_uvshift_iplobe(offra,offde,lmv,buf)
    use phys_const
    use image_def
    !-----------------------------------------------------------------------
    ! Center in uv plane interferometer beam of a mosaic field
    ! at its right position (offra,offdec)
    !-----------------------------------------------------------------------
    real(kind=4),           intent(in)    :: offra,offde
    type(gildas),           intent(in)    :: lmv
    type(uvshort_buffer_t), intent(inout) :: buf
    !
    integer(kind=4) :: i,j,ii,jj,nx,ny
    real(kind=4) :: phi,sp,cp,xx,yy,re,im
    real(kind=8) :: du,dv
    !
    du = 1.d0/(lmv%gil%inc(1)*lmv%gil%dim(1))
    dv = 1.d0/(lmv%gil%inc(2)*lmv%gil%dim(2))
    ! Loop on pixels
    nx = buf%nx
    ny = buf%ny
    do j = 1,ny
       ! Loop on Y,pixels locations on Fourier plane
       jj = mod(j-1+ny/2,ny)-ny/2
       yy = jj*dv
       do i = 1,nx
          ! Loop on X,pixels locations on Fourier plane
          ii = mod(i-1+nx/2,nx)-nx/2
          xx = ii*du
          !
          phi = -2.d0*pi*(offra*xx + offde*yy)
          cp = cos(phi)
          sp = sin(phi)
          !
          re = real(buf%iplobe_uv(i,j))*cp - imag(buf%iplobe_uv(i,j))*sp
          im = real(buf%iplobe_uv(i,j))*sp + imag(buf%iplobe_uv(i,j))*cp
          buf%iplobe_uv(i,j) = cmplx(re,im)
       enddo ! i
    enddo ! j
  end subroutine uvshort_pseudo_uvshift_iplobe
  !
  subroutine uvshort_pseudo_compute_visi(do,sd,buf)
    !-----------------------------------------------------------------------
    ! 1 - Computes the direct fourrier transform of the SD data onto the UV plane
    ! 2 - Deconvolves it from the SD beam.
    ! 3 - Convolves it with the Interferometer primary beam uv shifted to the
    ! current offset.
    !-----------------------------------------------------------------------
    type(uvshort_action_t), intent(in)    :: do
    type(uvshort_sddata_t), intent(in)    :: sd
    type(uvshort_buffer_t), intent(inout) :: buf
    !
    integer(kind=4) :: if
    !
    ! Loop on frequencies
    do if=1,buf%nf
       ! DFT of SD data
       call retocm(sd%ou%r3d(:,:,if),buf%visi(:,:,if),buf%nx,buf%ny)
       call fourt(buf%visi(:,:,if),buf%dim,buf%ndim,1,1,buf%fftws)
       if (do%deconv_sd) then
          ! Deconvolve SD beam in uv plane
          buf%visi(:,:,if) = buf%visi(:,:,if)*buf%sdlobe_uv
       endif
       if (do%apply_ip) then
          ! Apply interferometer primary beam in image plane
          call fourt(buf%visi(:,:,if),buf%dim,buf%ndim,-1,1,buf%fftws)
          call uvshort_pseudo_multiply_by_iplobe_lm(buf%nx,buf%ny,buf%iplobe_lm,buf%visi(:,:,if))
          call fourt(buf%visi(:,:,if),buf%dim,buf%ndim,1,1,buf%fftws)
          buf%visi(:,:,if) = buf%visi(:,:,if)/(buf%nx*buf%ny)
       endif
    enddo ! if
  end subroutine uvshort_pseudo_compute_visi
  !
  subroutine uvshort_pseudo_multiply_by_iplobe_lm(nx,ny,f,z)
    !-----------------------------------------------------------------------
    ! z = z*f => used to multiply by interferometer primary beam in image plane
    !-----------------------------------------------------------------------
    integer(kind=4), intent(in)    :: nx,ny    ! Problem size
    real(kind=4),    intent(in)    :: f(nx,ny) ! Multiplication function
    complex(kind=4), intent(inout) :: z(nx,ny) ! Complex values
    !
    integer(kind=4) :: i,j,ii,jj
    !
    do j = 1,ny
       jj = mod(j+ny/2-1,ny)+1
       do i = 1,nx
          ii = mod(i+nx/2-1,nx)+1
          z(ii,jj) = z(ii,jj) * f(i,j)
       enddo
    enddo
  end subroutine uvshort_pseudo_multiply_by_iplobe_lm
  !
  subroutine uvshort_pseudo_compute_wei(do,sd,buf)
    !-----------------------------------------------------------------------
    ! Computes weights for single dish data in the UV plane
    !-----------------------------------------------------------------------
    type(uvshort_action_t), intent(in)    :: do
    type(uvshort_sddata_t), intent(in)    :: sd
    type(uvshort_buffer_t), intent(inout) :: buf
    !
    if (do%wei.eq.'natural') then
       ! *** JP Something to be done here.
       buf%uvwei = 1.
    else
       buf%uvwei = 1.
    endif
    if (do%deconv_sd) then
       where (buf%sdlobe_uv.ne.0)
          buf%uvwei = 1.0/buf%sdlobe_uv**2
       else where
          buf%uvwei = 0.0
       end where
    endif
  end subroutine uvshort_pseudo_compute_wei
  !  
  subroutine uvshort_pseudo_fill_uvt(rname,uvmax,lmv,ifield,buf,uv,error)
    use phys_const
    use image_def
    use gbl_message
    !-----------------------------------------------------------------------    
    ! Tabulate the visibilities
    !-----------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    real(kind=4),           intent(in)    :: uvmax
    type(gildas),           intent(in)    :: lmv
    integer(kind=4),        intent(in)    :: ifield
    type(uvshort_buffer_t), intent(inout) :: buf
    type(uvshort_uvdata_t), intent(inout) :: uv
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: i,j,k,kk,ii,jj,kvis,kstart,if
    integer(kind=4) :: nc,nv,nf,nx,ny,ifirst,ilast,mv
    integer(kind=4) :: gdate
    real(kind=4) :: sddatfac,sdweifac,offra,offde
    real(kind=4) :: uu,vv,weisum,we,duv,uvmax2
    real(kind=8) :: dx,dy,freq
    real(kind=4) :: cs(2)
    !
    dx = clight_mhz/lmv%gil%freq/(lmv%gil%inc(1)*lmv%gil%dim(1))
    dy = clight_mhz/lmv%gil%freq/(lmv%gil%inc(2)*lmv%gil%dim(2))
    uvmax2 = uvmax**2
    !
    sddatfac = uv%sddatfac
    sdweifac = 1/(sddatfac**2) ! *** JP probably could be done before...
    !
    call sic_gagdate(gdate)
    !
    nc = uv%ps%gil%dim(1)
    nv = uv%ps%gil%dim(2)
    nf = buf%nf
    nx = buf%nx
    ny = buf%ny
    !
    ! Loop on pixels of the visibility map
    kstart = (ifield-1)*uv%nvisi_per_field
    kvis = kstart
    weisum = 0.0
    do j = 1,ny
       jj = mod(j-1+ny/2,ny)-ny/2
       vv = jj*dy
       do i = 1,nx/2
          ii = mod(i-1+nx/2,nx)-nx/2
          uu = ii*dx
          duv = uu**2+vv**2
          ! Keep only points inside circle defined by uvmax
          if (duv.le.uvmax2) then
             kvis = kvis + 1
             if (kvis.gt.nv) then
                call map_message(seve%e,rname,'Try to write outside space allocated for short-spacing table')
                error = .true.
                return
             endif
             uv%ps%r2d(1,kvis) = uu
             uv%ps%r2d(2,kvis) = vv
             uv%ps%r2d(3,kvis) = 0
             uv%ps%r2d(4,kvis) = gdate   ! Current date
             uv%ps%r2d(5,kvis) = 0
             uv%ps%r2d(6:7,kvis) = -1.0  ! Convention: Antenna # -1 for Short spacings
             kk = 7
             ! Weight
             we = buf%uvwei(i,j)*sdweifac
             if (i.eq.1 .and. j.ne.1) then
                we = we*0.5
             endif
!!$             if (we.lt.0) we = -we   ! *** JP
!!$             ! u=0 v=0 point
!!$             if (duv.eq.0) k00 = kvis
             ! Extract visibilities
             do k=1,nf
                uv%ps%r2d(kk+1,kvis) = real(buf%visi(i,j,k))*sddatfac
                uv%ps%r2d(kk+2,kvis) = imag(buf%visi(i,j,k))*sddatfac
                uv%ps%r2d(kk+3,kvis) = we
                kk = kk + 3
             enddo
             weisum = weisum+we
          endif
       enddo ! i
    enddo ! j
    ! Sanity check
    if ((kvis-kstart).ne.uv%nvisi_per_field) then
       call map_message(seve%e,rname,'Inconsistent number of visibilities')
       error = .true.
       return
    endif
    ifirst = kstart+1
    ilast = kvis
    mv = ilast-ifirst+1
!!$    ! Normalize the weights *** JP ***
!!$    if (weisum.ne.0.) then
!!$       weisum = 1/weisum
!!$       do i=1,nvis
!!$          do k=1,nf
!!$             uv%ps%r2d(7+k*3,i) = uv%ps%r2d(7+k*3,i)*weisum
!!$          enddo ! k
!!$       enddo ! i 
!!$    endif
    !
    if (uv%ismos) then
       offra = uv%raoff(ifield)
       offde = uv%deoff(ifield)
       if (uv%islm) then
          ! Unshift phase center to current pointing center
          ! => Hence the minus sign when computing buf%xy
          cs = [1.0,0.0] ! cos/sin of rotation
                         ! Rotation has already been taken care of before => 1.0,0.0
          do if=1,buf%nf
             freq = gdf_uv_frequency(uv%ps,dble(if))
             buf%xy(1,if) = - freq * f_to_k * offra
             buf%xy(2,if) = - freq * f_to_k * offde
          enddo
          ! Initialize the loff & moff columns to 0 (no shift yet!)
          uv%ps%r2d(uv%ocol(1),ifirst:ilast) = 0
          uv%ps%r2d(uv%ocol(2),ifirst:ilast) = 0
          ! Then shift the UV data set
          call shift_uvdata(uv%ps,nc,mv,uv%ps%r2d(:,ifirst:ilast),&
               cs,buf%nf,buf%xy)
          ! And only ultimately put the final loff & moff values
       endif
       uv%ps%r2d(uv%ocol(1),ifirst:ilast) = offra
       uv%ps%r2d(uv%ocol(2),ifirst:ilast) = offde
    endif
  end subroutine uvshort_pseudo_fill_uvt
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  subroutine uvshort_merge(rname,user,prog,uv,error)
    use gbl_message
    use gkernel_interfaces
    use mapping_interfaces
    !-------------------------------------------------------------------
    ! Merge interferometric (uv%in) and short-spacing uv (uv%ps) tables
    !-------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(uvshort_input_t),  intent(inout) :: prog
    type(uvshort_uvdata_t), intent(inout) :: uv
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: ier
    !
    ! If uv%ps is not loaded load it here before it is used that is
    ! why it is the first thing done here
    if (.not.associated(uv%ps%r2d)) then
      ! Read all pseudo-visibilities at once from disk
      call gdf_read_header(uv%ps,error)
      if (error)  goto 10
      allocate(uv%ps%r2d(uv%ps%gil%dim(1),uv%ps%gil%dim(2)),stat=ier)
      if (failed_allocate(rname,'pseudo-visibility table',ier,error)) goto 10
      call gdf_read_data(uv%ps,uv%ps%r2d,error)
      if (error)  goto 10
      call gdf_close_image(uv%ps,error)
      if (error)  goto 10
    endif
    ! Header set and written to its final size
    uv%ou%gil%dim(2) = uv%in%gil%nvisi+uv%ps%gil%nvisi
    uv%ou%gil%nvisi  = uv%ou%gil%dim(2)
    uv%ou%blc(:) = 0
    uv%ou%trc(:) = 0
    call gdf_create_image(uv%ou,error)
    if (error) return
    ! Prepare weight adjustment
    allocate(uv%inbeam%r2d(4,uv%in%gil%dim(2)),stat=ier)
    if (failed_allocate(rname,'Input weight table',ier,error)) return
    allocate(uv%oubeam%r2d(4,uv%ou%gil%dim(2)),stat=ier)
    if (failed_allocate(rname,'Output weight table',ier,error)) return
    !
    uv%ivisi = 0
    call map_message(seve%i,rname,'Copying interferometric data to output table')
    call uvshort_merge_copy_uvin_fromdisk(rname,uv,error)
    if (error)  goto 10
    call gag_message(seve%i,rname,'Appending short-spacing data to output table')
    
    call uvshort_merge_append_uvps(rname,user,prog,uv,error)
    if (error)  goto 10
    !
    ! Clean up
10  continue
    call gdf_close_image(uv%ou,error)
    if (error)  return
    !
  end subroutine uvshort_merge
  !
  subroutine uvshort_merge_copy_uvin_fromdisk(rname,uv,error)
    !-------------------------------------------------------------------
    ! Copy the uv%in table into the uv%ou table (both must be already
    ! GDF-opened). Input data is read from disk.
    !-------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_uvdata_t), intent(inout) :: uv
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: nvisiperblock,ier,ivisi,jvisi,kvisi,ichan,icol
    real(kind=4), allocatable :: din(:,:)
    real(kind=4) :: uvdist
    !
    ! Copy input table by blocks of SPACE_GILDAS
    call gdf_nitems('SPACE_GILDAS',nvisiperblock,uv%in%gil%dim(1))
    nvisiperblock = min(nvisiperblock,uv%in%gil%nvisi)
    !
    allocate(din(uv%in%gil%dim(1),nvisiperblock),stat=ier)
    if (failed_allocate(rname,'UV reading buffer',ier,error))  return
    !
    uv%in%blc(:) = 0
    uv%in%trc(:) = 0
    uv%ou%blc(:) = 0
    uv%ou%trc(:) = 0
    do ivisi=1,uv%in%gil%nvisi,nvisiperblock
       uv%in%blc(2) = ivisi
       uv%in%trc(2) = min(ivisi+nvisiperblock-1,uv%in%gil%nvisi)
       call gdf_read_data(uv%in,din,error)
       if (error)  return
       do jvisi=uv%in%blc(2),uv%in%trc(2)
          kvisi = jvisi-ivisi+1
          if (uv%ismos) then
             uv%inbeam%r2d(1:2,jvisi) = din(uv%ocol(1):uv%ocol(2),kvisi)
          else
             uv%inbeam%r2d(1:2,jvisi) = 0.0
          endif
          uvdist = sqrt(din(1,kvisi)**2+din(2,kvisi)**2)
          uv%inbeam%r2d(3,jvisi) = uvdist
          uv%inbeam%r2d(4,jvisi) = din(uv%wcol,kvisi)
          ! Multiplication by the interferometer calibration factor
          do ichan=1,uv%in%gil%nchan
             icol = 7+(ichan-1)*3+1
             din(icol,kvisi) = din(icol,kvisi)*uv%ipdatfac
             icol = icol+1
             din(icol,kvisi) = din(icol,kvisi)*uv%ipdatfac
             icol = icol+1
             din(icol,kvisi) = din(icol,kvisi)*(1/uv%ipdatfac**2)
          enddo
       enddo ! jvisi
       uv%ou%blc(2) = uv%ivisi+ivisi
       uv%ou%trc(2) = uv%ivisi+uv%in%trc(2)
       call gdf_write_data(uv%ou,din,error)
       if (error)  return
    enddo ! ivisi
    uv%in%blc(:) = 0
    uv%in%trc(:) = 0
    deallocate(din)
    uv%ou%blc(:) = 0
    uv%ou%trc(:) = 0
    uv%ivisi = uv%ivisi+uv%in%gil%nvisi
    !
  end subroutine uvshort_merge_copy_uvin_fromdisk
  !
  subroutine uvshort_merge_append_uvps(rname,user,prog,uv,error)
    use phys_const
    use gbl_message
    use mapping_interfaces
    !-------------------------------------------------------------------
    ! Append the pseudo-visibility table to the output table. The
    ! pseudo-visibility table is already loaded in memory and the output
    ! table is already GDF-opened.
    ! -------------------------------------------------------------------
    character(len=*),       intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(uvshort_input_t),  intent(inout) :: prog
    type(uvshort_uvdata_t), intent(inout) :: uv
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: ivisi,jvisi,icol,ibin,nbin,ier
    real(kind=4) :: uvdist,uvmin,uvmax,alpha,beta
    real(kind=4), allocatable :: weidens(:)
    character(len=message_length) :: mess
    !
    uv%oubeam%r2d(:,1:uv%ivisi) = uv%inbeam%r2d(:,1:uv%ivisi)
    uvmax = maxval(uv%oubeam%r2d(3,1:uv%ivisi))
    jvisi = uv%ivisi
    do ivisi=1,uv%ps%gil%nvisi
       jvisi = jvisi+1
       if (uv%ismos) then
          uv%oubeam%r2d(1:2,jvisi) = uv%ps%r2d(uv%ocol(1):uv%ocol(2),ivisi)
       else
          uv%oubeam%r2d(1:2,jvisi) = 0.0
       endif
       uvdist = sqrt(uv%ps%r2d(1,ivisi)**2+uv%ps%r2d(2,ivisi)**2)
       uv%oubeam%r2d(3,jvisi) = uvdist
       uv%oubeam%r2d(4,jvisi) = uv%ps%r2d(uv%wcol,ivisi)
    enddo ! ivisi
    uv%oubeam%gil%dim(2) = jvisi
    !
    ! *** JP: The following computation should be done by field...
    uvmax = maxval(uv%oubeam%r2d(3,1:jvisi))
    uvmin = minval(uv%oubeam%r2d(3,1:uv%ivisi))
    nbin = ceiling(uvmax/prog%uvstep)
    allocate(weidens(nbin),stat=ier)
    if (failed_allocate(rname,'Weidens density',ier,error))  return
    weidens = 0
    alpha = (nbin-0.5)/uvmax
    beta = 0.5
    do ivisi=1,uv%oubeam%gil%dim(2)
       ibin = nint(uv%oubeam%r2d(3,ivisi)*alpha+beta)
       if (ibin.eq.0) then
          ibin = 1
       else if ((ibin.lt.0).or.(ibin.gt.nbin)) then
          call map_message(seve%e,rname,'Problem when computing weidens density')
          error = .true.
          return
       endif
       weidens(ibin) = weidens(ibin)+uv%oubeam%r2d(4,ivisi)
    enddo ! ivisi
    weidens(1) = weidens(1)/(pi*prog%uvstep**2)
    weidens(2:nbin) = weidens(2:nbin)/(3.0*pi*prog%uvstep**2*uv%ipdatfac**2)
    !
    if (weidens(1).le.0) then
       call map_message(seve%e,rname,'Negative or zero valued single-dish weight density')
       error = .true.
       return
    endif
    if (weidens(2).le.0) then
       if (uvmin.ge.2*prog%uvstep) then
          call map_message(seve%e,rname,'No matching between Single dish and interferometric visbilities')
          call map_message(seve%e,rname,"Increase UV step to make matching possible")
          write (mess,'(a,f8.3,a,f8.3)') "UV step should be in the range ",uvmin/2.,":",uvmin
          call map_message(seve%e,rname,mess)
       else
          call map_message(seve%e,rname,'Negative or zero valued interferometric weight density')
       endif
       error = .true.
       return
    endif
    prog%sdwei = weidens(2)/weidens(1)
    uv%sdweifac = user%sdwei*prog%sdwei
    print *,"weight density: ",weidens(1),weidens(2)
    print *,"weight factors: ",uv%sdweifac,user%sdwei,prog%sdwei
    !
    do ivisi=1,uv%ps%gil%nvisi
       do icol=uv%ps%gil%fcol+2,uv%ps%gil%lcol,3
          uv%ps%r2d(icol,ivisi) = uv%ps%r2d(icol,ivisi)*uv%sdweifac
       enddo ! icol
    enddo ! ivisi
    !
    ! Input table is entirely in memory => copy all at once
    uv%ou%blc(:) = 0
    uv%ou%trc(:) = 0
    uv%ou%blc(2) = uv%ivisi+1
    uv%ou%trc(2) = uv%ivisi+uv%ps%gil%nvisi
    call gdf_write_data(uv%ou,uv%ps%r2d,error)
    if (error)  return
    uv%ou%blc(:) = 0
    uv%ou%trc(:) = 0
    uv%ivisi = uv%ivisi+uv%ps%gil%nvisi
    !
  end subroutine uvshort_merge_append_uvps
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  subroutine uvshort_uvzero(rname,user,uvin,error)
    character(*),           intent(in)    :: rname
    type(uvshort_input_t),  intent(in)    :: user
    type(gildas),           intent(inout) :: uvin
    logical,                intent(inout) :: error
    !------------------------------------------------------------------------
    ! Does nothing anymore for the moment...
    !------------------------------------------------------------------------
!!$    type(projection_t) :: uv_proj,lm_proj  
!!$    real(8) :: alpha,delta,dx,dy
!!$    integer :: ix,iy,is,icol,ocol,jf
!!$    integer :: gdate,last,ixcol,iycol
!!$    real, allocatable :: zero_uvdata(:,:)
!!$    real, allocatable :: sddat%in%r2d(:,:)
!!$    real, allocatable :: spectrum(:)
!!$    real :: ws,dist,dmin,total_weight
!!$    !
!!$    ! We already have the reference UV table header here
!!$    ! Allocate some work space
!!$    !
!!$    call gwcs_projec(uvin%gil%a0,uvin%gil%d0,-uvin%gil%pang,uvin%gil%ptyp,uv_proj,error)
!!$    call sic_gagdate(gdate)
!!$    ! ...
!!$    last = uvin%gil%fcol + uvin%gil%natom * uvin%gil%nchan - 1
!!$    ixcol = last+1
!!$    iycol = last+2
!!$    !
!!$    if (sddat%islmv) then
!!$       ! Read LMV file
!!$       ! Input file is a lmv cube
!!$       call uvshort_sd_read_lmv(rname,user%sdin_name,lmv,sddat%ou%r3d,buf%imwei,error)
!!$       !
!!$       ! We can get the weight from the Noise in the map
!!$       weight = user%sdfac*max(sddat%ou%gil%rms,sddat%ou%gil%noise)
!!$       if (weight.ne.0.0) then
!!$          weight = 1d-6/weight**2
!!$          ! weight = user%sdwei * weight ! Is that useful ?...
!!$       else
!!$          call map_message(seve%w,rname,'No weight in LMV file')
!!$          weight = 1.0
!!$       endif
!!$       !
!!$       nc=sddat%ou%gil%dim(3)
!!$       call uvshort_consistency(rname,nc,uvin,lmv,user%postol,error)
!!$       if (error) return
!!$       !
!!$       allocate(zero_uvdata(uvin%gil%dim(1),nf),spectrum(nc),stat=ier)
!!$       if (ier.ne.0) then
!!$          call map_message(seve%e,rname,'Zero spacing Memory allocation failure')
!!$          error = .true.
!!$          return
!!$       endif
!!$       !
!!$       ! Extract appropriate directions from it: loop on fields
!!$       call gwcs_projec(sddat%ou%gil%a0,sddat%ou%gil%d0,-sddat%ou%gil%pang,sddat%ou%gil%ptyp,lm_proj,error)
!!$       do if=1,nf
!!$          call rel_to_abs(uv_proj,dble(raoff(if)),dble(deoff(if)),alpha,delta,1)
!!$          call abs_to_rel(lm_proj,alpha,delta,dx,dy,1)
!!$          ix = nint((dx-sddat%ou%gil%val(1))/sddat%ou%gil%inc(1)+sddat%ou%gil%ref(1))
!!$          iy = nint((dy-sddat%ou%gil%val(2))/sddat%ou%gil%inc(2)+sddat%ou%gil%ref(2))
!!$          if (ix.lt.1 .or. ix.gt.nx .or. iy.lt.1 .or. iy.gt.ny) then
!!$             write(mess,*) 'Field ',if,' is out of map ',ix,iy
!!$             call map_message(seve%e,rname,mess)
!!$             error = .true.
!!$             return
!!$          endif
!!$          !
!!$          ! Put it in place...
!!$          spectrum(:) = user%sdfac * sddat%ou%r3d(ix,iy,:) 
!!$          call spectrum_to_zero(nc,spectrum,zero_uvdata(:,if),gdate,weight)
!!$          zero_uvdata(ixcol,if) = raoff(if)
!!$          zero_uvdata(iycol,if) = deoff(if)        
!!$       enddo
!!$       !
!!$       total_weight = nf*weight
!!$    else
!!$       !
!!$       nc = uvin%gil%nchan
!!$       !
!!$       call uvshort_read_class_table(rname,user%sdin_name,sddat%in,sddat%in%r2d,error)
!!$       if (error) return
!!$       !      
!!$       ! Set valid defaults for Class Tables
!!$       if (sddat%xcol.eq.0) sddat%xcol = 1
!!$       if (sddat%ycol.eq.0) sddat%ycol = 2
!!$       if (sddat%wcol.eq.0) sddat%wcol = 3
!!$       if (sddat%mcol(1).eq.0) sddat%mcol(1) = 4
!!$       icol = sddat%mcol(1)
!!$       if (sddat%mcol(2).ne.0) then
!!$          ocol = sddat%mcol(2)
!!$          if (ocol-icol+1.ne.nc) then
!!$             Print *,'MCOL ',sddat%mcol,' ICOL OCOL ',icol,ocol,' NC ',nc
!!$             call map_message(seve%e,rname,'Number of channels mismatch')
!!$             error = .true.
!!$             return
!!$          endif
!!$       else
!!$          ocol = icol+nc-1
!!$          if (ocol.gt.sddat%in%gil%dim(1)) then
!!$             Print *,'MCOL ',sddat%mcol,' ICOL OCOL ',icol,ocol,' Sddat%In ',sddat%in%gil%dim(1)
!!$             call map_message(seve%e,rname,'Number of channels mismatch')
!!$             error = .true.
!!$             return
!!$          endif
!!$       endif
!!$       !
!!$       allocate(zero_uvdata(uvin%gil%dim(1),nf),spectrum(nc),stat=ier)
!!$       if (ier.ne.0) then
!!$          call map_message(seve%e,rname,'Zero spacing Memory allocation failure')
!!$          error = .true.
!!$          return
!!$       endif!
!!$       !
!!$       ! Find all spectra towards the appropriate directions,
!!$       ! with the specified tolerance
!!$       total_weight =0.0
!!$       call gwcs_projec(sddat%in%gil%a0,sddat%in%gil%d0,-sddat%in%gil%pang,sddat%in%gil%ptyp,lm_proj,error)
!!$       do if=1,nf
!!$          spectrum(:) = 0.0
!!$          weight = 0.0
!!$          jf = 0
!!$          dmin = 1e36
!!$          !
!!$          call rel_to_abs(uv_proj,dble(raoff(if)),dble(deoff(if)),alpha,delta,1)
!!$          call abs_to_rel(lm_proj,alpha,delta,dx,dy,1)
!!$          !
!!$          do is=1,sddat%in%gil%nvisi
!!$             dist = (sddat%in%r2d(sddat%xcol,is)-dx)**2+(sddat%in%r2d(sddat%ycol,is)-dy)**2
!!$             if (dist .le. user%postol**2) then
!!$                jf = jf+1
!!$                !         Print *,'Field ',if,' X',(sddat%in%r2d(sddat%xcol,is)-dx)*sec_per_rad,  
!!$                !         '  Y',(sddat%in%r2d(ycol,is)-dy)*sec_per_rad,     &
!!$                !         ' user%Postol ',user%postol*sec_per_rad
!!$                ws = sddat%in%r2d(sddat%wcol,is)
!!$                weight = weight + ws
!!$                spectrum(:) = spectrum(:) + ws * sddat%in%r2d(icol:ocol,is)
!!$                dmin = min(dmin,dist)
!!$             endif
!!$          enddo
!!$          dmin = sqrt(dmin)*sec_per_rad
!!$          if (weight.eq.0) then
!!$             write(mess,'(A,I0,A,1PG10.2)') 'Field ',if,' has no Zero spacing' &
!!$                  //' Min distance ',dmin
!!$             call map_message(seve%e,rname,mess)
!!$             error = .true.
!!$          else
!!$             write(mess,'(I0,A,I0,A,1PG10.2)') jf,' spectra added to Field ',if &
!!$                  ,'; Min distance ',dmin
!!$             call map_message(seve%i,rname,mess)
!!$             total_weight = total_weight + weight
!!$          endif
!!$          !
!!$          ! Put it in place...
!!$          spectrum = spectrum/weight
!!$          call spectrum_to_zero(nc,spectrum,zero_uvdata(:,if),gdate,weight)
!!$          zero_uvdata(ixcol,if) = raoff(if)
!!$          zero_uvdata(iycol,if) = deoff(if)        
!!$       enddo
!!$    endif
!!$    if (error) return
!!$    !
!!$    ! Now concatenate the Zero spacing data to the Mosaic UV Table
!!$    ! or Create a Zero spacing UV table
!!$    if (do%detect.lt.0) then
!!$       ! short_mode < 0
!!$       !   Here we create a single UV table containing only
!!$       !   the short spacings  for all fields
!!$       name = trim(user%uvin_name)//"-short"
!!$       call sic_parsef(name,uvin%file,' ','.uvt')
!!$       call map_message(seve%i,rname,'Creating UV table '//trim(uvin%file))
!!$       uvin%gil%nvisi = nf
!!$       uvin%gil%nvisi = nf
!!$       call gdf_create_image(uvin,error)
!!$       uvin%blc = 0
!!$       uvin%trc = 0
!!$    else
!!$       ! short_mode > 0
!!$       !   Here we create a UV table containing the short spacings
!!$       !   for all fields appended to the previous UV table
!!$       call gildas_null(uvdat%in)
!!$       name = trim(user%uvin_name)
!!$       call sic_parsef(name,uvdat%in%file,' ','.uvt')
!!$       call gdf_read_header(uvdat%in,error)
!!$       if (error) return
!!$       !
!!$       name = trim(user%uvin_name)//"-merged"
!!$       call sic_parsef(name,uvin%file,' ','.uvt')
!!$       call map_message(seve%i,rname,'UV Table to be appended is '//trim(uvin%file))
!!$       wcol = (nc+2)/3
!!$       ! Copy UV table and get Total weight up to UMAX
!!$       umax = 2.0*user%sddiam  ! Here user%sddiam = user%ipdiam
!!$       call uvshort_copy_uvtable(rname,uvdat%in,uvt,umax,wcol,weight,error)
!!$       if (error) return
!!$       !
!!$       ! Scaling factor for Weights
!!$       call map_message(seve%i,rname,'Appending UV table '//trim(uvin%file))
!!$       string = 'appended'
!!$       uvin%blc(2) = uvin%gil%nvisi+1
!!$       mvis = uvin%gil%nvisi+nf      ! Add NF visibilities
!!$       uvin%trc(2) = mvis
!!$       call gdf_extend_image(uvt,mvis,error)
!!$       uvin%gil%nvisi = uvin%gil%nvisi
!!$       !
!!$       ! Re-normalize the Weight to have a nice beam,including
!!$       ! User-specified Weight factor USER%SDWEI
!!$       scale_weight = weight*user%sdwei/4.0/total_weight
!!$       do if=1,nf
!!$          do is = 10,7+3*nc,3
!!$             zero_uvdata(is,if) = zero_uvdata(is,if) * scale_weight
!!$          enddo
!!$       enddo
!!$    endif
!!$    !
!!$    ! Write the Zero spacings in place now
!!$    call gdf_write_data(uvt,zero_uvdata,error)
!!$    if (error) then
!!$       call map_message(seve%e,rname,'Error writing UV data ')
!!$       return
!!$    endif
!!$    write(mess,'(I0,A)') nf,' Zero spacings added'
!!$    call map_message(seve%i,rname,mess)
!!$    !
!!$    ! Finish the job. Update the number of visibilities
!!$    call gdf_update_header(uvt,error)
!!$    call gdf_close_image(uvt,error)
  end subroutine uvshort_uvzero
  !
  subroutine spectrum_to_zero(nc,spectrum,uvdata,date,weight)
    !
    ! Convert a spectrum into a Zero spacing
    integer,intent(in) :: nc
    real,intent(in) :: spectrum(nc) 
    real,intent(out) :: uvdata(:)
    integer,intent(in) :: date
    real,intent(in) :: weight
    !
    integer :: ic
    !
    uvdata = 0
    uvdata(4) = date
    uvdata(6:7) = -1.0      ! Conventional antenna number
    do ic=1,nc
       uvdata(5+3*ic) = spectrum(ic)
       uvdata(7+3*ic) = weight
    enddo
  end subroutine spectrum_to_zero
  !
end program uvshort_program
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
