subroutine sg_map(task,line,error)
  use gkernel_interfaces
  use mapping_interfaces, except_this=>sg_map
  use clean_def
  use clean_arrays
  use clean_types
  use clean_default
  use gbl_message
  !------------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !
  !     Support for commands
  !       UV_RESTORE
  !       UV_MAP
  ! and   MX (eventually, not coded yet)
  !
  ! Compute a map from a CLIC UV Sorted Table  by Gridding and Fast Fourier
  ! Transform, using adequate virtual memory space for optimisation. Also
  ! allows removal of Clean Components in the UV data and restoration of
  ! the clean image.
  !
  ! Input :
  !     a precessed UV table
  !     a list of Clean components
  ! Output :
  !     a precessed, rotated, shifted UV table, sorted in V,
  !     ordered in (U,V,W,D,T,iant,jant,nchan(real,imag,weig))
  !     a beam image or cube
  !     a LMV cube  (dirty or clean)
  !
  ! To be implemented
  !     Optionally, a Residual UV table
  !------------------------------------------------------------------------
  character(len=*), intent(in) :: task ! Caller (MX or UV_MAP or UV_RESTORE)
  character(len=*), intent(in) :: line ! Command line
  logical, intent(out) :: error
  !
  real(8), parameter :: pi=3.14159265358979323846d0
  real(8), parameter :: f_to_k = 2.d0*pi/299792458.d-6
  !
  real, allocatable :: w_mapu(:), w_mapv(:), w_grid(:,:)
  real(8) new(3)
  real(4) rmega,uvmax,uvmin,uvma
  integer wcol,mcol(2),rcol,sblock
  integer ier
  logical one, sorted, shift, found(3)
  character(len=message_length) :: chain
  real cpu0, cpu1
  real(8) :: freq
  integer nx,ny,nu,nv,nc,nb,mx,my
  !
  logical do_cct, do_slow, do_copy
  integer, parameter :: o_slow = 2
  integer, parameter :: o_copy = 1
  !
  integer, save :: saved_mcol(2)=[0,0]
  integer, save :: saved_wcol=0
  !
  ! Print *,'DO_WEIG at start ',do_weig
  !
  themap%beam = 0
  call sic_get_inte('MAP_BEAM_STEP',themap%beam,error)
  !
  do_cct = task.eq.'UV_RESTORE'
  !
  do_slow = sic_present(o_slow,0)
  do_copy = sic_present(o_copy,0)
  !
  error = .false.
  !
  if (do_cct) then
    !
    ! Subtract all Clean Components
    if (.not.associated(duv)) then
      call map_message(seve%e,task,'No UV data loaded')
      error = .true.
    endif
    if (.not.allocated(dcct)) then
      call map_message(seve%e,task,'No CCT data available')
      error = .true.
    endif
    if (error) return
  endif
  !
  call map_prepare(task,themap,error)
  if (error) return
  !
  one = .true.
  call sic_get_inte('WCOL',wcol,error)
  call sic_get_inte('MCOL[1]',mcol(1),error)
  call sic_get_inte('MCOL[2]',mcol(2),error)
  !
  call sic_get_logi('UV_SHIFT',shift,error)
  if (shift) then
    ! Read MAP_RA, MAP_DEC, MAP_ANGLE
    call map_get_radecang(task,found,new,error)
    if (error)  return
    if (.not.all(found)) then
      call map_message(seve%e,task,'MAP_RA and MAP_DEC must be defined')
      error = .true.
      return
    endif
  else
    new(:) = 0.d0
  endif
  !
  ! First sort the input UV Table, leaving UV Table in UV_*
  call gag_cpu(cpu0)
  call uv_sort (error,sorted,shift,new,uvmax,uvmin)
  if (error) return
  if (.not.sorted) then
    ! Redefine SIC variables (mandatory)
    call sic_delvariable ('UV',.false.,error)
    call sic_mapgildas ('UV',huv,error,duv)
  endif
  call gag_cpu(cpu1)
  write(chain,102) 'Finished sorting ',cpu1-cpu0
  call map_message(seve%i,task,chain)
  !
  call map_parameters(task,themap,freq,uvmax,uvmin,error)
  if (error) return
  uvma = uvmax/(freq*f_to_k)
  !
  themap%xycell = themap%xycell*pi/180.0/3600.0
  !
  ! Get work space, ideally before mapping first image, for
  ! memory contiguity reasons.
  !
  nx = themap%size(1)
  ny = themap%size(2)
  nu = huv%gil%dim(1)
  nv = huv%gil%dim(2)
  !
  ! Define the number of output channels
  nc = huv%gil%nchan
  if (do_cct .and. nc.ne.hcct%gil%dim(2)) then
    Print *,'Mismatch number of channels between HUV ',nc,' and CCT ',hcct%gil%dim(2)
  endif
  if (mcol(1).eq.0) then
    mcol(1) = 1
  else
    mcol(1) = max(1,min(mcol(1),nc))
  endif
  if (mcol(2).eq.0) then
    mcol(2) = nc
  else
    mcol(2) = max(1,min(mcol(2),nc))
  endif
  nc = mcol(2)-mcol(1)+1
  !
  ! Find out how many beams are required
  call map_beams(task,themap%beam,huv,nx,ny,nb,nc)
  !
  ! Check if Weights have changed by MCOL choice
  !!PRINT *,'DO_WEIG before ',do_weig
  if (any(saved_mcol.ne.mcol) .or. nb.gt.1) do_weig = .true.
  if (saved_wcol.ne.wcol) do_weig = .true.
  !!PRINT *,'DO_WEIG just after ',do_weig,' nb ',nb
  saved_mcol = mcol
  saved_wcol = wcol
  !
  if (method%method.eq.'MX') do_weig = .true. ! Test
  if (do_weig) then
    call map_message(seve%i,task,'Computing weights ')
    if (allocated(g_weight)) deallocate(g_weight)
    if (allocated(g_v)) deallocate(g_v)
    allocate(g_weight(nv),g_v(nv),stat=ier)
    if (ier.ne.0) goto 98
  else
    call map_message(seve%i,task,'Re-using weight space')
  endif
  !
  rmega = 512.0
  ier = sic_ramlog('SPACE_MAPPING',rmega)
  !
  ! In fast mode, an intermediate Large FFT is used
  ! The maximum number of threads should also play a role here,
  ! but we assume the user has accounted for this in its definition
  ! of SPACE_MAPPING
  !
  if (do_cct.and..not.do_slow) then
    mx = max(nx,min(4*nx,4096))
    my = max(ny,min(4*ny,4096))
    sblock = max(int(256.0*rmega*1024.0)/mx/my,1)
  else
    sblock = max(int(256.0*rmega*1024.0)/(nx*ny),1)
  endif
  !
  ! New Beam place
  if (allocated(dbeam)) then
    call sic_delvariable ('BEAM',.false.,error)
    deallocate(dbeam)
  endif
  call gildas_null(hbeam)
  !
  ! Process sorted UV Table according to the number of beams produced
  !
  hbeam%gil%ndim = 3
  hbeam%gil%dim(1:4)=[nx,ny,nb,1]
  if (nb.gt.1) then
    allocate(hbeam%r3d(nx,ny,nb),dbeam(nx,ny,1,nb),stat=ier)
    rcol = 0
  else
    allocate(dbeam(nx,ny,1,1),stat=ier)
    hbeam%r3d => dbeam(:,:,:,1)
    rcol = (mcol(2)+mcol(1))/2
  endif
  if (ier.ne.0) then
    call map_message(seve%e,task,'Memory allocation error on DBEAM')
    error =.true.
    return
  endif
  !
  if (do_cct) then
    hcct%r3d => dcct
    !
    ! New residual image
    if (allocated(dresid)) then
       call sic_delvariable ('RESIDUAL',.false.,error)
       deallocate(dresid)
    endif
    allocate(dresid(nx,ny,nc),stat=ier)
    !
    call gildas_null(hresid)
    hresid%gil%ndim = 3
    hresid%gil%dim(1:3) = (/nx,ny,nc/)
    hresid%r3d => dresid
    !
    if (allocated(dclean)) then
       call sic_delvariable ('CLEAN',.false.,error)
       deallocate(dclean)
    endif
    allocate(dclean(nx,ny,nc),stat=ier)
    hclean%r3d => dclean
    !
    call uvmap_and_restore (task,themap,   &
       &    huv, hbeam, hresid,   &
       &    nx,ny,nu,nv, duv,   &
       &    g_weight, g_v, do_weig,  &
       &    rcol,wcol,mcol,sblock,cpu0,error,uvma, &
       &    method, do_cct, hcct, hclean, do_slow, do_copy)
    !!PRINT *,'DO_WEIG after ',do_weig
    !
    ! Specify clean beam parameters
    hclean%gil%reso_words = 3
    hclean%gil%majo = method%major
    hclean%gil%mino = method%minor
    hclean%gil%posa = pi*method%angle/180.0
    !
    ! Get extrema
    call map_minmax(hclean)
    !
    hclean%loca%size = nx*ny*nc
    hclean%gil%ndim = 3
    hclean%gil%dim(1:3) = (/nx,ny,nc/)
    call sic_mapgildas ('CLEAN',hclean,error,dclean)
    call sic_mapgildas ('RESIDUAL',hresid,error,dresid)
    !
    save_data(code_save_clean) = .true.
    save_data(code_save_resid) = .true.
  else
    !
    ! New dirty image
    if (allocated(ddirty)) then
       call sic_delvariable ('DIRTY',.false.,error)
       deallocate(ddirty)
    endif
    allocate(ddirty(nx,ny,nc),stat=ier)
    !
    call gildas_null(hdirty)
    hdirty%gil%ndim = 3
    hdirty%gil%dim(1:3) = (/nx,ny,nc/)
    hdirty%r3d => ddirty
    call sic_mapgildas('DIRTY',hdirty,error,ddirty)
    !
    call uvmap_and_restore (task,themap,   &
       &    huv, hbeam, hdirty,   &
       &    nx,ny,nu,nv, duv,   &
       &    g_weight, g_v, do_weig,  &
       &    rcol,wcol,mcol,sblock,cpu0,error,uvma, &
       &    method, do_cct, hcct, hclean, do_slow, do_copy)
    !!PRINT *,'DO_WEIG after ',do_weig
    !
    save_data(code_save_beam) = .true.
    save_data(code_save_dirty) = .true.
    !
    call new_dirty_beam
    !
    ! Define Min Max
    call map_minmax(hdirty)
    !
    d_max = hdirty%gil%rmax
    if (hdirty%gil%rmin.eq.0) then
       d_min = -0.03*hdirty%gil%rmax
    else
       d_min = hdirty%gil%rmin
    endif
  endif
  !
  ! Re-shape the beam, and reset the 4-D pointer,
  ! but show it as a 3-D array in SIC
  if (nb.gt.1) then
    dbeam(:,:,:,:) = reshape(hbeam%r3d,[nx,ny,1,nb])
    deallocate(hbeam%r3d)
  endif
  !
  hbeam%r4d => dbeam
  hbeam%gil%dim(1:4)=[nx,ny,1,nb]
  hbeam%gil%ndim = 4
  !
  ! Transpose the header appropriately
  hbeam%gil%convert(:,4) = hbeam%gil%convert(:,3)
  hbeam%gil%faxi = 4
  hbeam%char%code(4) = 'VELOCITY' ! Frequency would be better...
  hbeam%gil%convert(:,3) = 1.d0
  hbeam%char%code(3) = 'FIELD'    ! Pseudo-mosaic
  hbeam%gil%ndim = 4
  !
  call sic_mapgildas('BEAM',hbeam,error,dbeam)
  !
  if (.not.error) call map_message(seve%i,task,'Successful completion')
  !
  !
  if (task.ne.'MX') goto 99
  !
99 continue
  if (allocated(w_mapu)) deallocate(w_mapu)
  if (allocated(w_mapv)) deallocate(w_mapv)
  if (allocated(w_grid)) deallocate(w_grid)
  !!PRINT *,'DO_WEIG at end ',do_weig
  return
  !
98 call map_message(seve%e,task,'Memory allocation failure')
  error = .true.
  return
  !
102 format(a,f9.2)
  !
end subroutine sg_map
!
subroutine uvmap_and_restore (rname,map,huv,hbeam,hdirty,   &
     &    nx,ny,nu,nv,uvdata,r_weight, w_v, do_weig,    &
     &    rcol,wcol,mcol,sblock,cpu0,error,uvmax, &
     &    method, do_cct,hcct,hclean,do_slow,do_copy)
  use gkernel_interfaces
  use mapping_interfaces, except_this=>uvmap_and_restore
  use clean_def
  use clean_default
  use image_def
  use gbl_message
  !$ use omp_lib
  !------------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Compute a map from a CLIC UV Sorted Table
  !   by Gridding and Fast Fourier Transform, with
  !   a different beam per channel.
  !
  ! Input :
  ! a precessed UV table, sorted in V, ordered in
  ! (U,V,W,D,T,iant,jant,nchan(real,imag,weig))
  !
  ! (optionally) a list of Clean components
  !
  ! Output :
  ! a beam image
  ! a DIRTY or RESIDUAL and CLEAN cube
  !------------------------------------------------------------------------
  character(len=*), intent(in) :: rname   ! Calling Task name
  type (uvmap_par), intent(inout) :: map  ! Mapping parameters
  type (gildas), intent(inout) :: huv     ! UV data set
  type (gildas), intent(inout) :: hbeam   ! Dirty beam data set
  type (gildas), intent(inout) :: hdirty  ! Dirty image data set
  integer, intent(in) :: nx   ! X size
  integer, intent(in) :: ny   ! Y size
  integer, intent(in) :: nu   ! Size of a visibilities
  integer, intent(in) :: nv   ! Number of visibilities
  real, intent(inout) :: uvdata(nu,nv)
  real, intent(inout), target :: r_weight(nv)    ! Weight of visibilities
  real, intent(inout) :: w_v(nv)         ! V values
  logical, intent(inout) :: do_weig
  !
  real, intent(inout) :: cpu0        ! CPU
  real, intent(inout) :: uvmax       ! Maximum baseline
  integer, intent(inout) :: sblock   ! Blocking factor
  integer, intent(inout) :: rcol     ! Reference frequency channel
  integer, intent(inout) :: wcol     ! Weight channel
  integer, intent(inout) :: mcol(2)  ! First and last channel
  logical, intent(inout) :: error
  logical, intent(in) :: do_cct
  type (clean_par), intent(inout) :: method
  type (gildas), intent(inout) :: hcct
  type (gildas), intent(inout) :: hclean
  logical, intent(in) :: do_slow
  logical, intent(in) :: do_copy
  !
  ! Global variables:
  !
  real(kind=8), parameter :: clight=299792458d-6 ! Frequency in  MHz
  real(8), parameter :: pi=3.14159265358979323846d0
  !
  type (gridding) :: conv
  character(len=32) :: cname
  !
  integer :: nchan    ! Number of channels
  integer :: ndata    ! Size of data
  integer :: nbeam    ! Number of beams
  integer :: schunk   ! Number of channels per chunk
  integer :: nblock   ! Number of blocks/chunks ( = nbeam if nbeam.gt.1)
  integer :: ier, icmax
  real(kind=8) :: freq
  integer ctypx,ctypy
  integer lcol,fcol
  real wall,cpu1
  real xparm(10),yparm(10)
  real(8) :: vref,voff,vinc
  real(kind=4) :: loff,boff
  integer ndim, nn(2), lx, ly, kz1
  integer kz,iz,ic,kc,kb,jc,lc
  character(len=message_length) :: chain
  !
  real :: rms, null_taper(4), wold
  complex, allocatable :: ftbeam(:,:)
  complex, allocatable :: tfgrid(:,:,:)
  real, allocatable :: w_xgrid(:),w_ygrid(:), w_w(:),  w_grid(:,:), walls(:)
  real, allocatable :: w_weight(:)
  real, allocatable :: beam(:,:)
  real, allocatable :: w_mapu(:), w_mapv(:)
  real, allocatable :: local_wfft(:)
  real uvcell(2)
  real support(2)
  real(8) local_freq
  !
  integer :: ithread,othread,nthread
  real(8) :: elapsed_s, elapsed_e, elapsed
  !
  logical :: local_error
  logical :: compute_weight
  !
  integer :: maxic, icc, no, niter
  integer, allocatable :: mic(:)    ! Number of clean components per channel
  real, allocatable :: ouv(:,:)     ! Residual Visibilities
  real, allocatable :: ccou(:,:,:)  ! Transpose, compressed Clean Component List
  type (cct_par), allocatable :: p_cct(:)
  type(clean_par) :: my_method
  real :: my_major, my_minor, my_angle
  integer :: ix_min,ix_max,iy_min,iy_max
  real :: bmin,bmax
  character(len=12) :: fname
  integer :: grid_code
  integer(kind=4) :: lastchanblock,firstchanblock
  !$ integer(kind = OMP_lock_kind) :: lck_weight, lck_grid
  !
  grid_code = 0
  call sic_get_inte('MAP_GRID_CODE',grid_code,error)
  !
  ! Code:
  elapsed_s = 0
  elapsed_e = 0
  error = .false.
  ndata = nx*ny
  nchan = huv%gil%nchan
  nbeam = hbeam%gil%dim(3)
  !
  schunk = map%beam
  null_taper = 0
  !
  if (schunk.ne.1 .and. nbeam.gt.1) then
    write(chain,'(a,i6,a)') 'Processing ',schunk,' channels per beam'
    call map_message(seve%w,rname,chain)
  endif
  if (nbeam.eq.1) then
    !
    ! Optimize SBLOCK now, allowing some additional memory if NBLOCK small
    if (sblock.gt.0) then
      nblock = (nchan+sblock-1)/sblock
      kz = mod(nchan,sblock)
      if (kz.ne.0 .and. kz.lt.(sblock/(nblock+1))) then
        if (nblock.ne.1) nblock = nblock-1
      endif
      sblock = (nchan+nblock-1)/nblock
      schunk = min(sblock,nchan)
    else
      schunk = nchan
      nblock = 1
    endif
    !$ nthread = omp_get_max_threads()
    if (nblock.lt.nthread) then
      nblock = min(nthread,nchan)
      sblock = (nchan+nblock-1)/nblock
      write(chain,'(A,I6,A,I8,A)') 'Reset ',nblock,' blocks of ',&
        & sblock,' channels for Threading'
      call map_message(seve%w,rname,chain)
      schunk = sblock
    endif
    write(chain,'(A,I6,A,I8,A)') 'Using ',nblock,' blocks of ',&
        & schunk
    call map_message(seve%w,rname,chain)
  else
    nblock = nbeam  ! For the Nesting of OMP parallel codes
  endif
  !
  ! Reset the parameters
  xparm = 0.0
  yparm = 0.0
  !
  vref = huv%gil%ref(1)
  voff = huv%gil%voff
  vinc = huv%gil%vres
  if (mcol(1).eq.0) then
    mcol(1) = 1
  else
    mcol(1) = max(1,min(mcol(1),nchan))
  endif
  if (mcol(2).eq.0) then
    mcol(2) = nchan
  else
    mcol(2) = max(1,min(mcol(2),nchan))
  endif
  fcol = min(mcol(1),mcol(2))
  lcol = max(mcol(1),mcol(2))
  if (wcol.eq.0) then
    wcol = (fcol+lcol)/3
  endif
  wcol = max(1,wcol)
  wcol = min(wcol,nchan)
  nchan = lcol-fcol+1
  !
  ! Compute observing sky frequency for U,V cell size
  if (rcol.eq.0) then
    freq = gdf_uv_frequency(huv, 0.5d0*dble(lcol+fcol) )
  else
    freq = gdf_uv_frequency(huv, dble(rcol) )
  endif
  !
  ! Compute gridding function
  ctypx = map%ctype
  ctypy = map%ctype
  call grdflt (ctypx, ctypy, xparm, yparm)
  call convfn (ctypx, xparm, conv%ubuff, conv%ubias)
  call convfn (ctypy, yparm, conv%vbuff, conv%vbias)
  map%uvcell = clight/freq/(map%xycell*map%size)
  map%support(1) = xparm(1)*map%uvcell(1)  ! In meters
  map%support(2) = yparm(1)*map%uvcell(2)
  !
  ! Process sorted UV Table according to the type of beam produced
  !
  allocate (w_w(nv),w_weight(nv),walls(nbeam),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Cannot allocate Weight arrays')
    error = .true.
    return
  endif
  w_v(:) = uvdata(2,1:nv)
  !
  !
  lx = (uvmax+map%support(1))/map%uvcell(1) + 2
  ly = (uvmax+map%support(2))/map%uvcell(2) + 2
  lx = 2*lx
  ly = 2*ly
  if (ly.gt.ny) then
    write(chain,'(A,A,F8.3)') 'Map cell is too large ',   &
        &      ' Undersampling ratio ',float(ly)/float(ny)
    call map_message(seve%e,rname,chain)
    ly = min(ly,ny)
    lx = min(lx,nx)
  endif
  !
  ! Get FFT's and beam work spaces
  allocate (tfgrid(schunk+1,lx,ly),ftbeam(nx,ny),beam(nx,ny),&
    & w_mapu(lx),w_mapv(ly),local_wfft(2*max(nx,ny)), &
    & w_xgrid(nx),w_ygrid(ny),w_grid(nx,ny),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Cannot allocate TF arrays')
    error = .true.
    return
  endif
  !
  call docoor (lx,-map%uvcell(1),w_mapu)
  call docoor (ly,map%uvcell(2),w_mapv)
  !
  ndim = 2
  nn(1) = nx
  nn(2) = ny
  call fourt_plan(ftbeam,nn,ndim,-1,1)
  !
  ! Prepare grid correction,
  call grdtab (ny, conv%vbuff, conv%vbias, w_ygrid)
  call grdtab (nx, conv%ubuff, conv%ubias, w_xgrid)
  !
  ! Make beam, not normalized
  call gdf_copy_header(huv,hbeam,error)
  hbeam%gil%dopp = 0.0  ! Nullify the Doppler factor
  !
  hbeam%gil%ndim = 3
  hbeam%gil%dim(1) = nx
  hbeam%gil%dim(2) = ny
  hbeam%gil%dim(3) = nbeam
  hbeam%gil%dim(4) = 1
  hbeam%gil%convert(1,1) = nx/2+1
  hbeam%gil%convert(1,2) = ny/2+1
  hbeam%gil%convert(2,1) = 0
  hbeam%gil%convert(2,2) = 0
  hbeam%gil%convert(3,1) = -map%xycell(1)  ! Assume EQUATORIAL system
  hbeam%gil%convert(3,2) = map%xycell(2)
!    hbeam%gil%convert(1,3) = vref-fcol+1     ! for 1 per channel
! From UV_COMPRESS
!    uvout%gil%inc(1) = uvout%gil%inc(1)*nc
!    uvout%gil%ref(1) = (2.0*uvout%gil%ref(1)+nc-1.0)/2/nc
!    uvout%gil%vres = nc*uvout%gil%vres
!    uvout%gil%fres = nc*uvout%gil%fres
!
! Strictly speaking, this is true only if there is more than one beam
! but the information is only used in this case anyway
  hbeam%gil%convert(1,3) = (2.d0*(vref-fcol)+schunk+1.d0)/2/schunk ! Correct
  hbeam%gil%convert(2,3) = voff
  hbeam%gil%proj_words = 0
  hbeam%gil%extr_words = 0
  hbeam%gil%reso_words = 0
  hbeam%gil%uvda_words = 0
  hbeam%gil%type_gdf = code_gdf_image
  !
  hbeam%char%code(1) = 'ANGLE'
  hbeam%char%code(2) = 'ANGLE'
  hbeam%char%code(3) = 'VELOCITY'
  hbeam%gil%xaxi = 1
  hbeam%gil%yaxi = 2
  hbeam%gil%faxi = 3
  hbeam%gil%majo = 0.0
  hbeam%loca%size = nx*ny*nbeam
  !
  ! Prepare the dirty map header
  call gdf_copy_header(hbeam,hdirty,error)
  hdirty%gil%ndim = 3
  hdirty%gil%dim(1) = nx
  hdirty%gil%dim(2) = ny
  hdirty%gil%dim(3) = nchan
  hdirty%gil%dim(4) = 1
  hdirty%gil%convert(1,3) = vref-fcol+1
  hdirty%gil%convert(2,3) = voff
  hdirty%gil%convert(3,3) = vinc
  hdirty%gil%proj_words = def_proj_words
  hdirty%gil%uvda_words = 0
  hdirty%gil%type_gdf = code_gdf_image
  hdirty%char%code(1) = 'RA'
  hdirty%char%code(2) = 'DEC'
  hdirty%char%code(3) = 'VELOCITY'
  call equ_to_gal(hdirty%gil%ra,hdirty%gil%dec,0.0,0.0,   &
                  hdirty%gil%epoc,hdirty%gil%lii,hdirty%gil%bii,loff,boff,error)
  if (huv%gil%ptyp.eq.p_none) then
    hdirty%gil%ptyp = p_azimuthal  ! Azimuthal (Sin)
    hdirty%gil%pang = 0.d0     ! Defined in table.
    hdirty%gil%a0 = hdirty%gil%ra
    hdirty%gil%d0 = hdirty%gil%dec
  else
    hdirty%gil%ptyp = p_azimuthal
    hdirty%gil%pang = huv%gil%pang ! Defined in table.
    hdirty%gil%a0 = huv%gil%a0
    hdirty%gil%d0 = huv%gil%d0
  endif
  hdirty%char%syst = 'EQUATORIAL'
  hdirty%gil%xaxi = 1
  hdirty%gil%yaxi = 2
  hdirty%gil%faxi = 3
  hdirty%gil%extr_words = 0          ! extrema not computed
  hdirty%gil%reso_words = 0          ! no beam defined
  hdirty%gil%nois_words = 2
  hdirty%gil%majo = 0
  hdirty%char%unit = 'Jy/beam'
  hdirty%loca%size = nx*ny*nchan
  !
  ! Smooth the beam
  hbeam%gil%convert(3,3) = vinc*schunk
  hbeam%gil%vres = schunk*vinc
  hbeam%gil%fres = schunk*hbeam%gil%fres
  !
  if (do_cct) then
    call gdf_copy_header(hdirty,hclean,error)
    maxic = hcct%gil%dim(3)
    no = 7+3*schunk
    allocate (ouv(no,huv%gil%dim(2)), &
    &   ccou(3,maxic,schunk), mic(schunk), p_cct(maxic), stat=ier)
  else
    no = 7+3*schunk
    allocate (ouv(no,huv%gil%dim(2)), stat=ier)
    maxic = 0
  endif
  if (ier.ne.0) then
    call map_message(seve%e,rname,'UV data allocation error')
    error = .true.
    return
  endif
  !
  cname = rname
  !
  error = .false.
  if (nbeam.gt.1) then
    !$ othread = omp_get_max_threads()
    !$ nthread = min(othread,nbeam)
    !$ call omp_set_num_threads(nthread)
  else
    ! Set a lock if Nbeam is One
    if (omp_uvmap_lock) then
    !$ call omp_init_lock(lck_weight)
    !$ call omp_init_lock(lck_grid)
    endif
  endif
  !$ elapsed_s = omp_get_wtime()
  !
  ! Print *,'WCOL ',wcol,' RCOL ',rcol,' FREQ '
  !
  ! Loop over blocks
  !
  !$OMP PARALLEL if (nblock.gt.1) DEFAULT(none) &      ! For UV_MAP first
  !$OMP PRIVATE(tfgrid,ftbeam,beam,w_weight,w_w) &
  !$OMP PRIVATE(w_mapu,w_mapv,w_grid) &
  !$OMP PRIVATE(local_wfft,chain,firstchanblock,lastchanblock) &
  !$OMP PRIVATE(local_freq,support,wall,rms,uvcell,local_error) &
  !$OMP PRIVATE(kz,kb,kc,iz,ic, kz1,jc,lc, cname) &
  !$OMP SHARED(walls,schunk,nbeam) &
  !$OMP SHARED(nu,nv,nx,ny,nchan,ndata,fcol,lcol,lx,ly, nthread) &
  !$OMP SHARED(map,null_taper,error) &
  !$OMP SHARED(conv,freq,do_weig, r_weight) &
  !$OMP SHARED(nn,ndim,huv,hbeam,hdirty,rname) &
  !$OMP SHARED(w_xgrid,w_ygrid,w_v,uvdata) &
  !$OMP SHARED(cpu0,cpu1) PRIVATE(elapsed_s, elapsed_e, elapsed, ithread) &
  !$OMP SHARED(maxic,hcct,hclean,no,do_cct,do_slow,method,do_copy) & ! For RESTORE
  !$OMP PRIVATE(mic,niter,ccou,ouv,p_cct) &
  !$OMP PRIVATE(ix_min,ix_max,iy_min,iy_max,bmin,bmax,icmax) &
  !$OMP PRIVATE(my_method,fname,compute_weight) SHARED(my_major, my_minor, my_angle) &
  !$OMP SHARED(lck_weight, lck_grid, omp_uvmap_lock, omp_debug) & ! Lock mechanism for grid & weight
  !$OMP SHARED(rcol, wold, wcol, grid_code)
  kz = 1 ! test for bug below
  !
  ! Print *,'KZ ',kz,' NChan ',nchan,' ndata ',ndata
  my_method = method
  my_method%method = 'RESTORE'
  !
  ! Loop over blocks
  !$OMP DO SCHEDULE(STATIC)
  do ic = fcol,lcol,schunk                !
    ! Set a Lock
    lc = min(lcol,ic+schunk-1) ! Last channel in the block (in input unit)
    kz = lc-ic+1 ! Width of the chunk, may be different from schunk in last block
    ! First and last channels in block in output unit
    firstchanblock = ic-fcol+1 
    lastchanblock = lc-fcol+1
    !
    ithread = 1
    !$ ithread = omp_get_thread_num()+1
    !$ elapsed_s = omp_get_wtime()
    !$ write(cname,'(A,A,I0,A)') trim(rname),'(',ic,')' 
    !
    jc = min(lcol,ic+schunk/2)            ! The default weight channel here...
    if (nbeam.eq.1) jc = wcol             ! Reset the default weight channel
    !!Print *,'JC ',jc,' Wcol ',wcol, ic, lcol,schunk
    compute_weight = do_weig
    !$ if (nbeam.eq.1 .and. omp_uvmap_lock) then
    ! One will get the lock, the others will not compute the weights
    !$   if (do_weig .and. (ic.le.wcol .and. ic+schunk.gt.wcol) ) then
    !$     call omp_set_lock(lck_weight)
    !$     Print *,'Thread ',ithread,' got WEIGHT lock ',do_weig,' WCOL ',ic,' < ',wcol &
    !$       ,' < ',ic+schunk
    !$   else
    !$     compute_weight = .false.
    !$   endif
    !$ endif
    !Print *,'Thread ',ithread,' IC ',ic,', KZ ',kz,', Schunk ',schunk
    !
    kb = (ic-fcol)/schunk+1
    if (kb.gt.nbeam .or. kb.lt.1) then
      !
      ! *** Actually, this is perfectly acceptable in the One Beam, Many Chunks case
      if (nbeam.gt.1) Print *,'Programming error, expected 0 < ',kb,' < ',nbeam+1
      kb = nbeam
    endif
    !
    w_w(:) = uvdata(7+3*jc,:)
    wold = sump(nv,w_w)
    !
    ! Search for a non empty weight channel
    if (wold.eq.0) then
      do kc=ic,lc 
        if (kc.ne.jc) then
          w_w(:) = uvdata(7+3*kc,:)
          wold = sump(nv,w_w)
          if (wold.ne.0) then
            jc = kc
            exit
          endif
        endif
      enddo
    endif
    !
    if (wold.eq.0) then
       write(chain,'(A,I6,A)') 'Channel ',jc, ' has zero weight'
       hbeam%r3d(:,:,kb) = 0
       do kc=firstchanblock,lastchanblock
          hdirty%r3d(:,:,kc) = 0
       end do
      walls(kb) = 0.0
      if (nbeam.eq.1) then
        call map_message(seve%e,rname,chain)
        error = .true.
      else
        call map_message(seve%w,rname,chain)
      endif
      !
      ! One should release the Lock if only one beam is needed...
      cycle
    else
      wall = 1e-3/sqrt(wold)
      !!write(chain,'(a,i6,a)') 'Plane ',ic,' Natural '
      !!call prnoise('UV_MAP',trim(chain),wall,rms)
      walls(kb) = wall
    endif
    !
    ! Compute the weights from this
    !
    if (compute_weight) then
       local_error = .false.
      call doweig (nu,nv,   &
         &    uvdata,   &          ! Visibilities
         &    1,2,    &            ! U, V pointers
         &    jc,     &            ! Weight channel
         &    map%uniform(1),   &  ! Uniform UV cell size
         &    w_weight,   &        ! Weight array
         &    map%uniform(2),   &  ! Fraction of weight
         &    w_v,              &  ! V values
         &    local_error,      &
         &    grid_code)           ! Gridding method (for tests)
      if (local_error)  then
        error = .true.
        ! One should release the Lock if only one beam is needed...
        cycle
      endif
      !
      ! Should also plug the TAPER here, rather than in DOFFT later  !
      call dotape (nu,nv,   &
         &    uvdata,   &          ! Visibilities
         &    1,2,   &             ! U, V pointers
         &    map%taper,  &        ! Taper
         &    w_weight)            ! Weight array
      !
      ! Re-normalize the weights and re-count the noise
      wall = sump(nv,w_weight)
      if (wall.ne.wold) call scawei (nv,w_weight,w_w,wall)
      !
      ! Declare the weight ready
      if (nbeam.eq.1) then
        if (do_weig) r_weight = w_weight
        !$ if (omp_uvmap_lock) then
        !$ Print *,'Thread ',ithread,' Unsetting LCK Weight ',do_weig, compute_weight
        !$ call omp_unset_lock(lck_weight)  ! Release the lock
        !$ endif
      endif
    else
      !$  if (nbeam.eq.1 .and. omp_uvmap_lock) then
      !$    if (omp_debug) Print *,'Thread ',ithread,' waiting for lck_weight ',do_weig
      !$    call omp_set_lock(lck_weight)    ! Wait for the Lock to be grasped
      !$    if (omp_debug) Print *,'Thread ',ithread,' got lck_weight ',do_weig
      !$    call omp_unset_lock(lck_weight)  ! and free it immediately
      !$  endif
      chain = 'Reusing weights'
      !$ write(chain(20:),'(a,i4)') ' - Thread ',ithread
      call map_message(seve%i,cname,chain)
      w_weight = r_weight
      !
      wall = sump(nv,w_weight)
      if (wall.ne.wold) call scawei (nv,w_weight,w_w,wall)
    endif
    !
    wall = 1e-3/sqrt(wall)
    write(chain,'(a,i6,a)') 'Plane ',ic,' Expected '
    call prnoise(cname,trim(chain),wall,rms)
    walls(kb) = wall
    !
    ! Then compute the Dirty Beam
    if (rcol.eq.0) then
      local_freq = gdf_uv_frequency(huv, dble(ic))
    else
      local_freq = freq
    endif
    uvcell = map%uvcell * (freq / local_freq)
    support = map%support * (freq / local_freq)
    !
    call docoor (lx,-uvcell(1),w_mapu)
    call docoor (ly,uvcell(2),w_mapv)
    !
    ! Optionally remove the Clean components
    icmax = 0
    !
    if (maxic.ne.0) then
      ! Compact the Clean components first
      call uv_clean_sizes(hcct,hcct%r3d,mic,ic,lc)
      icmax = maxval(mic)
      if (icmax.ne.0) then
        call uv_squeeze_clean(nchan,hcct%r3d,ccou, mic,ic,lc)
        freq = gdf_uv_frequency(huv,0.5d0*(ic+lc))
        if (do_slow) then
          call uv_removes_clean(huv,uvdata,ouv,kz,mic,ccou,freq,ic,lc)
          !!Print *,'Done remove clean SLOW'
        else
          call uv_removef_clean(hdirty,uvdata,ouv,kz,mic,ccou,freq,ic,lc)
          !!Print *,'Done remove clean FAST'
        endif
      else
        if (do_copy) call uv_extract_clean(uvdata,ouv,kz,ic,lc)
        call map_message(seve%w,cname,'No valid Clean Component')
      endif
      !$  elapsed_e = omp_get_wtime()
      !$  elapsed = elapsed_e - elapsed_s
      !$  write(chain,'(a,f9.2,a)') 'Finished Subtract Clean ',elapsed
      !$  call map_message(seve%i,cname,chain)
    else if (do_copy) then
      call uv_extract_clean(uvdata,ouv,kz,ic,lc)
    endif
    !
    if (.not.do_copy .and. icmax.eq.0) then
      !$ if (omp_debug) Print *,'No copy '
      !
      ! Compute FFT's
      call dofft (nu,nv,          &   ! Size of visibility array
           &    uvdata,           &   ! Visibilities
           &    1,2,              &   ! U, V pointers
           &    ic,               &   ! First channel to map
           &    kz,lx,ly,         &   ! Cube size
           &    tfgrid,           &   ! FFT cube
           &    w_mapu,w_mapv,    &   ! U and V grid coordinates
           &    support,uvcell,null_taper, &  ! Gridding parameters
           &    w_weight,w_v,     &    ! Weight array + V Visibilities
           &    conv%ubias,conv%vbias,conv%ubuff,conv%vbuff,map%ctype)
    else
      !$ if (omp_debug) Print *,'With copy '
      call dofft (no,nv,          &   ! Size of visibility array
           &    ouv,              &   ! Visibilities
           &    1,2,              &   ! U, V pointers
           &    1,                &   ! First channel to map
           &    kz,lx,ly,         &   ! Cube size
           &    tfgrid,           &   ! FFT cube
           &    w_mapu,w_mapv,    &   ! U and V grid coordinates
           &    support,uvcell,null_taper, &  ! Gridding parameters
           &    w_weight,w_v,     &    ! Weight array + V Visibilities
           &    conv%ubias,conv%vbias,conv%ubuff,conv%vbuff,map%ctype)
      !
    endif
    !
! *** Compute the beam only if needed ***
! **** Put a LOCK around this in case of only One Beam but multi-thread ****
    !
    kz1 = kz+1
    call extracs(kz1,nx,ny,kz1,tfgrid,ftbeam,lx,ly)
    call fourt  (ftbeam, nn,ndim,-1,1,local_wfft)
    beam = 0.0
    call cmtore (ftbeam, beam ,nx,ny)
    call chkfft (beam, nx,ny, error)
    !!Print *,'NU,NV ',nu,nv
    !!Print *,'IC ',ic
    !!Print *,'KZ,LX,LY ',kz,lx,ly
    !!Print *,'support ',support,' uvcell ',uvcell, ' null_taper ',null_taper
    !!Print *,'conv%ubias,conv%vbias,map%ctype ',conv%ubias,conv%vbias,map%ctype
    !!Print *, ' '
    if (error) then
      Print *,ic,'BEAM ',nx,ny,beam(nx/2+1,ny/2+1),' NO ',no
      Print *,'Local freq ',local_freq
      Print *,'KZ, LX, LY ', kz,lx,ly, ' nx,ny ',nx,ny, ' Schunk ',schunk
      call map_message(seve%e,rname,'Inconsistent pixel size')
      cycle
    endif
    !
    ! Compute grid correction,
    ! Normalization factor is applied to grid correction, for further
    ! use on channel maps.
    !
    !
    ! Make beam, not normalized
    call dogrid (w_grid,w_xgrid,w_ygrid,nx,ny,beam)  ! grid correction
    !
    ! Normalize and Free beam
    call docorr (beam,w_grid,nx*ny)
    !
    ! Fit beam if needed
    if (do_cct) then
      my_method%major = 0
      my_method%minor = 0
      my_method%bzone=[1,1,nx,ny]
      call maxmap(beam,nx,ny,my_method%bzone,   &
          &      bmax,ix_max,iy_max,   &
          &      bmin,ix_min,iy_min)
      my_method%beam0 = [ix_max,iy_max]
      my_method%ibeam = kb
      !$OMP CRITICAL
      if (ic.eq.fcol) then
        fname = rname  ! Print beam
      else
        fname = ' '    ! Do not print beam
      endif
      call fibeam (fname,beam,nx,ny,   &
       &    my_method%patch(1),my_method%patch(2),my_method%thresh,   &
       &    my_method%major,my_method%minor,my_method%angle,   &
       &    hbeam%gil%convert,error)
      !
      my_major = my_method%major
      my_minor = my_method%minor
      my_angle = my_method%angle
      ! Print *,'fit results ',my_method%major, my_method%minor, my_method%angle
      !$OMP END CRITICAL
    endif
    !
    !
! *** End of LOCK in case of One Beam ***
    ! Wait for gridding correction to be computed
!    if (nbeam.eq.1) then
!      !$   if (ic.eq.fcol) then
!      !$     Print *,'Thread ',ithread,' freeing lck_grid'
!      !$     call omp_unset_lock(lck_grid)  ! Release the lock
!      !$   else
!      !$     Print *,'Thread ',ithread,' waiting for lck_grid'
!      !$     call omp_set_lock(lck_grid)    ! Wait for the Lock to be grasped
!      !$     Print *,'Thread ',ithread,' got lck_grid'
!      !$     call omp_unset_lock(lck_grid)  ! and free it immediately
!      !$   endif
!    endif
! *** End of One Beam region ***
    !
    ! Write beam
    hbeam%r3d(:,:,kb) = beam
    !
    ! Now extracts the Image planes...
    do iz=1,kz
      call extracs(kz+1,nx,ny,iz,tfgrid,ftbeam,lx,ly)
      call fourt  (ftbeam,nn,ndim,-1,1,local_wfft)
      call cmtore (ftbeam,beam,nx,ny)
      call docorr (beam,w_grid,ndata)
      ! Write the subset
      kc = ic-fcol+iz
      hdirty%r3d(:,:,kc) = beam
      !
      if (do_cct) then
        !
        ! And add the Clean Components
        ! Recover the component list in pixels
        !
        niter = mic(iz)
        do icc = 1,mic(iz)
          !
          ! The NINT is required because of rounding errors
          p_cct(icc)%ix = nint( (ccou(1,icc,iz)-hdirty%gil%convert(2,1)) /  &
              &        hdirty%gil%convert(3,1) + hdirty%gil%convert(1,1))
          p_cct(icc)%iy = nint( (ccou(2,icc,iz)-hdirty%gil%convert(2,2)) /  &
              &        hdirty%gil%convert(3,2) + hdirty%gil%convert(1,2))
          p_cct(icc)%value = ccou(3,icc,iz)
        enddo
        !
        ! Compute Clean image and add back residual
        if (niter.gt.0) then
          my_method%n_iter = niter
          call clean_make90(my_method,hclean,hclean%r3d(:,:,kc),p_cct)
          hclean%r3d(:,:,kc) = hclean%r3d(:,:,kc) + hdirty%r3d(:,:,kc)
        else
          hclean%r3d(:,:,kc) = hdirty%r3d(:,:,kc)
        endif
        ! Make sure the next Clean Component is empty 
        if (niter.lt.maxic) p_cct(niter+1)%value = 0 ! Required
      endif
      !
    enddo
    !
    !$  elapsed_e = omp_get_wtime()
    elapsed = elapsed_e - elapsed_s
    write(chain,103) 'End plane ',kc,' Time ',elapsed &
      & ,' Thread ',ithread
    call map_message(seve%d,cname,chain)
    !
  enddo
  !$OMP END DO
  !$OMP END PARALLEL
  !$ if (nbeam.gt.1) call omp_set_num_threads(othread)
  if (error) return
  !
  if (nbeam.eq.1) do_weig = .false.
  !
  method%major = my_major
  method%minor = my_minor
  method%angle = my_angle
  !
  call gag_cpu(cpu1)
  !$  elapsed_e = omp_get_wtime()
  !$  elapsed = elapsed_e - elapsed_s
  if (elapsed.eq.0) then
    write(chain,102) 'Finished maps CPU ',cpu1-cpu0
  else
    write(chain,102) 'Finished maps Elapsed ',elapsed,'; CPU ',cpu1-cpu0
  endif
  call map_message(seve%i,rname,chain)
  !
  call map_minmax(hdirty)
  !
  wall = maxval(walls(1:nbeam))
  call prnoise(rname,'Expected',wall,rms)
  hdirty%gil%noise = wall
  hclean%gil%noise = wall ! Also for the Restored clean map
  !  !
  ! Delete scratch space
  error = .false.
  if (nbeam.ne.1)  deallocate(w_grid)
  if (allocated(tfgrid)) deallocate(tfgrid)
  if (allocated(ftbeam)) deallocate(ftbeam)
  if (allocated(w_xgrid)) deallocate(w_xgrid)
  if (allocated(w_ygrid)) deallocate(w_ygrid)
  return
  !
102 format(a,f9.2,a,f9.2)
103 format(a,i5,a,f9.2,a,i2,a,i2)
end subroutine uvmap_and_restore
!
subroutine uv_removes_clean(huv,duv,ouv,nc,mic,dcct,freq,first,last, &
  & beams)
  use image_def
  use gbl_message
  !$ use omp_lib
  !-----------------------------------------------------------------
  ! @ private-mandatory
  !
  ! MAPPING   Support for UV_RESTORE
  !     Compute visibilities for a UV data set according to a
  !     set of Clean Components , and remove them from the original
  !     UV table.
  !       Semi-Slow version using interpolation from pre-tabulated
  !       Sin/Cos, which could still be optimized
  !-----------------------------------------------------------------
  type(gildas), intent(in) :: huv   ! header of UV data set
  real, intent(in) :: duv(:,:)      ! UV data set
  integer, intent(in) :: nc         ! Number of channels
  integer, intent(in) :: mic(:)     ! Number of Clean Components
  real, intent(out) :: ouv(:,:)     ! Extracted UV data set
  real, intent(in) :: dcct(:,:,:)   ! Clean component
  real(8), intent(in) :: freq       ! Apparent observing frequency
  integer, intent(in) :: first      ! First channel
  integer, intent(in) :: last       ! Last channel
  real, intent(in), optional :: beams(3) ! Mosaic primary beam (0 = single)
  !
  real(8) :: pidsur            ! 2*pi*D/Lambda
  real(8), parameter :: pi=3.14159265358979323846d0
  real(8), parameter :: f_to_k=2.d0*pi/299792458.d-6
  real(8) :: phase, cp, sp
  real(4) :: rvis, ivis, b2, dxy, value
  integer ii, ir, iw
  integer oi, or, ow
  integer ic,iv,jc,kc
  !
  integer :: nv    ! Number of visibilities
  integer :: no, icmax
  !
  pidsur = f_to_k * freq
  !
  nv = huv%gil%dim(2)  ! Number of Visibilities
  no = ubound(mic,1)
  if (no.lt.last-first+1 .or. no.gt.ubound(dcct,3)) then
    Print *,'Remove Clean Slow dimension error ',no,last-first+1,ubound(dcct,3)
  endif
  icmax = maxval(mic)
  if (icmax.gt.ubound(dcct,2))  then
    Print *,'Remove Clean Slow -- too many Clean Comp.',icmax,ubound(dcct,2)
  endif
  ! Mosaic : Get 1/e width from FWHM
  b2 = 0.
  if (present(beams)) then
    if (beams(1).ne.0.) b2 = 4.d0*log(2.d0)/beams(1)**2
  endif
  !
  ! Remove clean component from UV data set
  !
  !$OMP PARALLEL DEFAULT(none) &
  !$OMP    & SHARED(duv,ouv,dcct)  SHARED(pidsur,nv,first,last,mic) &
  !$OMP    & PRIVATE(iv,jc,ic,kc,ir,ii,iw,or,oi,ow,phase,rvis,ivis,cp,sp) &
  !$OMP    & PRIVATE(dxy,value) SHARED(b2,beams)
  !
  !$OMP DO SCHEDULE(DYNAMIC,1)
  do iv=1,nv
    ouv(1:7,iv) = duv(1:7,iv)
    do jc = first,last  ! Channels
      ir = 5+3*jc
      ii = 6+3*jc
      iw = 7+3*jc
      kc = jc-first+1
      or = 5+3*kc
      oi = 6+3*kc
      ow = 7+3*kc
      ouv(or,iv) = duv(ir,iv)
      ouv(oi,iv) = duv(ii,iv)
      do ic = 1,mic(kc)  ! Clean components
        if (dcct(3,ic,kc).ne.0) then
          if (b2.ne.0) then
            ! In case of Mosaics, multiply by beam value
            dxy = ((dcct(1,ic,kc)-beams(2))**2+(dcct(2,ic,kc)-beams(3))**2)*b2
            if (dxy.gt.16.0) cycle ! Too faint anyway ...
            value = dcct(3,ic,kc)*exp(-dxy)
          else
            value = dcct(3,ic,kc)
          endif
          phase = (ouv(1,iv)*dcct(1,ic,kc) + ouv(2,iv)*dcct(2,ic,kc))*pidsur
          call cossin(phase,cp,sp)
          rvis = value*cp
          ivis = value*sp
          ouv(or,iv) = ouv(or,iv) - rvis   ! Subtract
          ouv(oi,iv) = ouv(oi,iv) - ivis
        else
          Print *,'Premature end of work for channel ',jc
          exit ! End of work, jump to next channel
        endif
      enddo  ! Clean components
      ouv(ow,iv) = duv(iw,iv)
    enddo  ! Channels
  enddo ! Visibilities
  !$OMP END DO
  !$OMP END PARALLEL
end subroutine uv_removes_clean
!
subroutine uv_squeeze_clean(nc,ccin,ccou, mic, first, last)
  use image_def
  !-----------------------------------------------------------------
  ! @ private-mandatory
  !
  ! MAPPING   Support for UV_RESTORE
  !   Compact the component list by summing up all values at the
  !   same position in a range of channels.
  !   The output list has a transposed order
  !-----------------------------------------------------------------
  integer, intent(in) :: nc         ! Number of channels
  real, intent(in) :: ccin(:,:,:)   ! Initial Clean Component List
  real, intent(out) :: ccou(:,:,:)  ! Resulting list
  integer, intent(inout) :: mic(:)  ! Number of Clean component per channel
  integer, intent(in) :: first      ! First channel
  integer, intent(in) :: last       ! Last channel
  !
  integer :: ii,jj,ic,jc
  integer :: ki    ! Number of different components per channel
  logical doit
  !
  ccou = 0
  !
  do ic=first,last
    jc = ic-first+1
    ki = 0
    do ii=1,mic(jc)
      if (ccin(3,ic,ii).eq.0) then
        exit
      else
        doit = .true.
        do jj=1,ki
          if (ccou(1,jj,jc).eq.ccin(1,ic,ii)) then
            if (ccou(2,jj,jc).eq.ccin(2,ic,ii)) then
              doit = .false.
              ccou(3,jj,jc) = ccou(3,jj,jc) + ccin(3,ic,ii)
              exit
            endif
          endif
        enddo
        if (doit) then
          ki = ki+1
          ccou(1:3,ki,jc) = ccin(1:3,ic,ii)
        endif
      endif
    enddo
    mic(jc) = ki
  enddo
end subroutine uv_squeeze_clean
!
subroutine uv_removef_clean(hdirty,duv,ouv,nc,mic,dcct,freq,first,last, &
  & beams)
  use image_def
  use mapping_interfaces, except_this => uv_removef_clean
  use gbl_message
  !$ use omp_lib
  !-----------------------------------------------------------------
  ! @ private-mandatory
  !
  ! MAPPING   Support for UV_RESTORE
  !     Compute visibilities for a UV data set according to a
  !     set of Clean Components , and remove them from the original
  !     UV table
  !   This version is for tranpose CCT data (3,ncomp,nchannels)
  !   and uses an intermediate FFT for speed
  !-----------------------------------------------------------------
  type(gildas), intent(in) :: hdirty  ! header of Dirty image
  integer, intent(in) :: nc         ! Number of channels
  integer, intent(in) :: mic(:)     ! Number of Clean Components
  real, intent(in) :: duv(:,:)      ! Input visibilities
  real, intent(out) :: ouv(:,:)     ! Output visibilities
  real, intent(in) :: dcct(:,:,:)   ! Clean components
  real(8), intent(in) :: freq       ! Apparent observing frequency
  integer, intent(in) :: first      ! First
  integer, intent(in) :: last       ! and last channel
  real, intent(in), optional :: beams(3) ! Mosaic primary beam (in radians)
  !
  integer :: nv    ! Number of visibilities
  integer :: mv    ! Size of a visibility
  integer :: nx,ny
  integer :: mx,my
  integer :: kx,ky
  real :: rx,ry,b2,dxy
  real :: value
  complex, allocatable :: cfft(:,:,:)
  real, allocatable :: comp(:,:), work(:)
  integer :: iplane,ic,ix,iy,iv,ier, dim(2)
  logical :: error
  real(8) :: xinc, yinc, xref, yref, xval, yval
  real(8), parameter :: pi=3.14159265358979323846d0
  !
  nv = ubound(duv,2)    ! Number of Visibilities
  mv = 7+3*nc
  mx = hdirty%gil%dim(1)
  my = hdirty%gil%dim(2)
  !
  ! Define the image size
  rx = log(float(mx))/log(2.0)
  kx = nint(rx)
  if (kx.lt.rx) kx = kx+1
  nx = 2**kx
  ry = log(float(my))/log(2.0)
  ky = nint(ry)
  if (ky.lt.ry) ky = ky+1
  ny = 2**ky
  kx = max(nx,ny)
  kx = min(4*kx,4096)
  !
  ! If the image is already fine enough, use it "as is"
  !    even if it is not a power of two...
  nx = max(kx,mx)  ! max(kx,nx) for power of two
  ny = max(kx,my)  ! max(kx,ny) for power of two
  !
  !
  ! Get Virtual Memory & compute the FFT
  allocate(comp(mx,my),cfft(nx,ny,nc),work(2*max(nx,ny)),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,'UV_RESTORE','uv_removef_clean -- allocation error')
    error = .true.
    return
  endif
  !
  xref = hdirty%gil%convert(1,1)
  yref = hdirty%gil%convert(1,2)
  xval = hdirty%gil%convert(2,1)
  yval = hdirty%gil%convert(2,2)
  xinc = hdirty%gil%convert(3,1)
  yinc = hdirty%gil%convert(3,2)
  dim = [nx,ny]
  !
  b2 = 0.
  if (present(beams)) then
    if (beams(1).ne.0.) b2 = 4.d0*log(2.d0)/beams(1)**2
  endif
  !  call fourt_plan(ftbeam,dim,2,1,1)
  !
  !$OMP PARALLEL DEFAULT(none) SHARED(dcct,cfft) &
  !$OMP    & SHARED(nc,mic,nx,ny,mx,my,dim,xinc,yinc,xref,yref,xval,yval) &
  !$OMP    & PRIVATE(iplane,ic,ix,iy,value) PRIVATE(comp,work) &
  !$OMP    & PRIVATE(dxy) SHARED(b2,beams)
  !
  !$OMP DO
  do iplane=1,nc
    comp = 0.
    do ic=1,mic(iplane)
      if (dcct(3,ic,iplane).eq.0) exit
      !
      if (b2.ne.0) then
        ! In case of Mosaics, multiply by beam value
        dxy = ((dcct(1,ic,iplane)-beams(2))**2+(dcct(2,ic,iplane)-beams(3))**2)*b2
        if (dxy.gt.16.0) cycle ! Too faint anyway ...
        value = dcct(3,ic,iplane)*exp(-dxy)
      else
        value = dcct(3,ic,iplane)
      endif
      ! The NINT is required because of rounding errors
      ix = nint( (dcct(1,ic,iplane)-xval) / xinc + xref )
      iy = nint( (dcct(2,ic,iplane)-yval) / yinc + yref )
      comp(ix,iy) = comp(ix,iy) + value
    enddo
    !
    call plunge_real (comp,mx,my,cfft(:,:,iplane),nx,ny)
    ! FOURT is now Thread-safe for the non-FFTW version.
    call fourt(cfft(:,:,iplane),dim,2,1,1,work)
    call recent(nx,ny,cfft(:,:,iplane))
  enddo
  !$OMP END DO
  !$OMP END PARALLEL
  !
  ! Extract the visibility subset
  do iv = 1,nv
    ouv(1:7,iv) = duv(1:7,iv)
    ouv(8:mv,iv) = duv(5+3*first:7+3*last,iv)
  enddo
  !
  ! Interpolate and subtract the model visibilities
  call do_smodel(ouv,mv,nv,cfft,nx,ny,nc,freq,xinc,yinc,1.0)
  !
  deallocate(comp,cfft)
end subroutine uv_removef_clean
!
subroutine cossin(phase,rcos,rsin)
  !-------------------------------------------------------
  ! Semi-Fast,  Semi-accurate Sin/Cos pair computation
  ! using (not yet clever) interpolation from a precise
  ! loop-up table
  !
  ! A solution using Taylor expansion and symmetries
  ! would be faster and more accurate
  !-------------------------------------------------------
  real(8), intent(inout) :: phase
  real(8), intent(out) :: rcos
  real(8), intent(out) :: rsin

!!  integer, intent(inout) :: ier
!!  real(8), intent(in) :: maxerr
!!  real(8), intent(inout) :: themax
  !
  real(8), parameter :: pi=3.14159265358979323846d0
  integer, parameter :: mcos=2048
  integer, save :: ncos = 0
  real(8), save :: cosine(mcos)
  real(8), save :: sine(mcos)
  real(8), save :: rstep
  real(8) :: rdeg
  integer :: i
  logical :: minus
  !
  rcos = cos(phase)
  rsin = sin(phase)
  return
  !
  if (ncos.eq.0) then
    ncos = mcos
    rstep = 2.01d0*pi/mcos
    do i=1,ncos
      rdeg = (i-1)*rstep
      cosine(i) = cos(rdeg)
      sine(i) = sin(rdeg)
    enddo
  endif
  !
  if (phase.ge.0) then
    minus =.false.
    rdeg = modulo(phase,2.0d0*pi)+0.5d0*rstep
  else
    minus = .true.
    rdeg = modulo(-phase,2.0d0*pi)+0.5d0*rstep
  endif
  rdeg = rdeg/rstep
  i = int(rdeg)
  rdeg = rdeg - i
  i = i+1
  rcos = (1.0-rdeg)*cosine(i) + rdeg*cosine(i+1)
  rsin = (1.0-rdeg)*sine(i) + rdeg*sine(i+1)
  if (minus) rsin = -rsin
end subroutine cossin
!
subroutine uv_extract_clean(duv,ouv,nc,first,last)
  !-----------------------------------------------------------------
  ! @ private-mandatory
  !
  ! MAPPING   Support for UV_MAP  &  UV_RESTORE
  !     Extract a subset of visibilities
  !-----------------------------------------------------------------
  integer, intent(in) :: nc         ! Number of channels
  real, intent(in) :: duv(:,:)      ! Input visbilities
  real, intent(out) :: ouv(:,:)     ! Output visibilities
  integer, intent(in) :: first      ! First channel
  integer, intent(in) :: last       ! Last channel
  !
  integer :: iv, nv
  !
  nv = ubound(duv,2)                ! Number of Visibilities
  !
  do iv=1,nv
    ouv(1:7,iv) = duv(1:7,iv)
    ouv(8:,iv) = duv(5+3*first:7+3*last,iv)
  enddo
end subroutine uv_extract_clean
!
subroutine uv_clean_sizes(hcct,ccin, mic, first, last)
  use image_def
  !-----------------------------------------------------------------
  ! @ private-mandatory
  !
  ! MAPPING   Support for UV_RESTORE
  !   Compute the actual number of components
  !-----------------------------------------------------------------
  type(gildas), intent(in) :: hcct  ! header of CCT data set
  real, intent(in) :: ccin(:,:,:)   ! Clean component table
  integer, intent(out) :: mic(:)    ! Number of iterations per channel
  integer, intent(in) :: first      ! First
  integer, intent(in) :: last       ! and last channel
  integer :: nc
  integer :: ni, ki
  integer :: i,ic,jc
  !
  nc = hcct%gil%dim(2)
  ni = hcct%gil%dim(3)
  !
  mic(:) = ni ! Up to the last one
  do ic=first,last
    jc = ic-first+1
    ki = 0
    do i=1,ni
      if (ccin(3,ic,i).eq.0) then
        mic(jc) = i-1
        exit
      endif
    enddo
  enddo
end subroutine uv_clean_sizes
!
subroutine do_smodel (visi,nc,nv,a,nx,ny,nf,freq,xinc,yinc,factor)
  !-----------------------------------------------------------------
  ! @ private-mandatory
  !
  ! MAPPING   Support for UV_RESTORE
  !
  !     Remove model visibilities from UV data set.
  !     Interpolate from a grid of values obtained by FFT before.
  !-----------------------------------------------------------------
  integer, intent(in) :: nc ! Visibility size
  integer, intent(in) :: nv ! Number of visibilities
  integer, intent(in) :: nx ! X size
  integer, intent(in) :: ny ! Y size
  integer, intent(in) :: nf ! Number of frequencies
  real, intent(inout) :: visi(:,:)    ! Computed visibilities
  real(8), intent(in) :: freq         ! Effective frequency
  real, intent(in)  :: factor         ! Flux factor
  complex, intent(in) ::  a(:,:,:)    ! FFT
  real(8), intent(in) :: xinc,yinc    ! Pixel sizes
  !
  real(8), parameter :: clight=299792458d0
  real(8) :: kwx,kwy,stepx,stepy,lambda,xr,yr
  complex(8) :: aplus,amoin,azero,afin
  integer i,if,ia,ja
  !
  lambda = clight/(freq*1d6)
  stepx = 1.d0/(nx*xinc)*lambda
  stepy = 1.d0/(ny*yinc)*lambda
  !
  ! Loop on visibility
  do i = 1, nv
    kwx =  visi(1,i) / stepx + dble(nx/2 + 1)
    ia = int(kwx)
    if (ia.le.1) cycle
    if (ia.ge.nx) cycle
    kwy =  visi(2,i) / stepy + dble(ny/2 + 1)
    ja = int(kwy)
    if (ja.le.1) cycle
    if (ja.ge.ny) cycle
    !
    xr = kwx - ia
    yr = kwy - ja
    do if=1,nf
      !
      ! Interpolate (X or Y first, does not matter in this case)
      aplus = ( (a(ia+1,ja+1,if)+a(ia-1,ja+1,if)   &
   &          - 2.d0*a(ia,ja+1,if) )*xr   &
   &          + a(ia+1,ja+1,if)-a(ia-1,ja+1,if) )*xr*0.5d0   &
   &          + a(ia,ja+1,if)
      azero = ( (a(ia+1,ja,if)+a(ia-1,ja,if)   &
   &          - 2.d0*a(ia,ja,if) )*xr   &
   &          + a(ia+1,ja,if)-a(ia-1,ja,if) )*xr*0.5d0   &
   &          + a(ia,ja,if)
      amoin = ( (a(ia+1,ja-1,if)+a(ia-1,ja-1,if)   &
   &          - 2.d0*a(ia,ja-1,if) )*xr   &
   &          + a(ia+1,ja-1,if)-a(ia-1,ja-1,if) )*xr*0.5d0   &
   &          + a(ia,ja-1,if)
      ! Then Y (or X)
      afin = ( (aplus+amoin-2.d0*azero)   &
   &          *yr + aplus-amoin )*yr*0.5d0 + azero
      !
      visi(5+3*if,i) =  visi(5+3*if,i) - real(afin)*factor
      visi(6+3*if,i) =  visi(6+3*if,i) - imag(afin)*factor
    enddo
  enddo
end subroutine do_smodel
!
