!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module uvmap_tool
  use gbl_message
  !
  public :: uvmap_main
  public :: map_prepare
  public :: uv_squeeze_clean,uv_removef_clean,uv_removes_clean,uv_clean_sizes
  public :: new_dirty_beam,plunge_real,recent
  private
  !
contains
  !
  subroutine map_prepare(rname,map,error)
    use gkernel_interfaces
    use map_buffers
    use uvmap_types
    use uvmap_buffers
    !-----------------------------------------------------------------------
    !
    !-----------------------------------------------------------------------
    character(len=*), intent(in)    :: rname
    type(uvmap_par),  intent(inout) :: map
    logical,          intent(inout) :: error
    !
    character(len=*), parameter :: obsol='obsolescent'
    !
    ! Check version
    if (map_buffer%version.lt.-1 .or. map_buffer%version.gt.1) then
       call map_message(seve%e,rname,'Invalid MAP_VERSION, should be -1,0 or 1')
       error = .true.
       return
    endif
    !
    ! Check old syntax
    if (uvmap_old%uniform(1).ne.uvmap_saved%uniform(1)) then
       call map_message(seve%w,rname,'UV_CELL is '//obsol//', use MAP_UVCELL instead')
       uvmap_default%uniform(1) = uvmap_old%uniform(1)
    endif
    if (uvmap_old%uniform(2).ne.uvmap_saved%uniform(2)) then
       call map_message(seve%w,rname,'UV_CELL is '//obsol//', use MAP_ROBUST instead')
       uvmap_default%uniform(2) = uvmap_old%uniform(2)
    endif
    if (uvmap_old%taper(4).ne.uvmap_saved%taper(4)) then
       call map_message(seve%w,rname,'TAPER_EXPO is '//obsol//', use MAP_TAPER_EXPO instead')
       uvmap_saved%taper(4) = uvmap_old%taper(4)
       uvmap_default%taper(4) = uvmap_old%taper(4)
    endif
    if (any(uvmap_old%taper.ne.uvmap_saved%taper)) then
       call map_message(seve%w,rname,'UV_TAPER is '//obsol//', use MAP_UVTAPER instead')
       uvmap_default%taper = uvmap_old%taper
    endif
    if (uvmap_old%ctype.ne.uvmap_saved%ctype) then
       call map_message(seve%w,rname,'CONVOLUTION is '//obsol//', use MAP_CONVOLUTION instead')
       uvmap_default%ctype = uvmap_old%ctype
    endif
    if (uvmap_old%mode.ne.uvmap_saved%mode) then
       call map_message(seve%w,rname,'WEIGHT_MODE is '//obsol//', use MAP_WEIGHT instead')
       uvmap_default%mode = uvmap_old%mode
    endif
    if (uvmap_old%shift.neqv.uvmap_saved%shift) then
       call map_message(seve%w,rname,'UV_SHIFT is '//obsol//', use MAP_SHIFT instead')
       uvmap_default%shift = uvmap_old%shift
    endif
    !
    ! Copy the current default to the actual structure
    call uvmap_default%copyto(map)
    !
    ! Weighting scheme
    call uvmap_user_weight_mode_toprog(rname,map,error)
    if (error) return
    uvmap_default%mode = map%mode ! Solve ambiguities
    !
    if (map%mode.eq.'NATU') map%uniform(1) = 0.0
    if (map%uniform(2).le.0.0) map%uniform(2) =  1.0
    !
    error = .false.
    !
    ! Here, we do not care about the fields issue
    uvmap_old = uvmap_default
    uvmap_saved = uvmap_default
  end subroutine map_prepare
  !
  subroutine uvmap_main(rname,line,error)
    use phys_const, only: pi
    use gkernel_interfaces
    use mapping_types, only: map_minmax
    use uv_continuum, only: map_beams,map_parameters
    use uv_shift, only: map_get_radecang
    use uv_rotate_shift_and_sort_tool, only: uv_sort_main
    use clean_types
    use file_buffers
    use uv_buffers
    use uvmap_buffers
    use clean_buffers
    !------------------------------------------------------------------------
    ! Support for commands
    !    UV_RESTORE
    !    UV_MAP
    !    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)    :: rname ! Caller (MX or UV_MAP or UV_RESTORE)
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    logical :: do_cct,do_slow,do_copy
    logical :: one,sorted,shift,found(3)
    integer :: ier
    integer, save :: saved_mcol(2)=[0,0]
    integer, save :: saved_wcol=0
    integer, parameter :: o_slow = 2
    integer, parameter :: o_copy = 1
    integer :: nx,ny,nu,nv,nc,nb,mx,my
    integer :: wcol,mcol(2),rcol,sblock
    real :: cpu0,cpu1
    real, allocatable :: w_mapu(:),w_mapv(:),w_grid(:,:)
    real(4) :: rmega,uvmax,uvmin,uvma
    real(8) :: new(3),freq
    real(8), parameter :: f_to_k = 2.d0*pi/299792458.d-6
    character(len=message_length) :: chain
    !
    ! print *,'DO_WEIG at start ',do_weig
    !
    uvmap_prog%beam = 0
    call sic_get_inte('MAP_BEAM_STEP',uvmap_prog%beam,error)
    !
    do_cct = rname.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,rname,'No UV data loaded')
          error = .true.
       endif
       if (.not.allocated(cct%data)) then
          call map_message(seve%e,rname,'No CCT data available')
          error = .true.
       endif
       if (error) return
    endif
    !
    call map_prepare(rname,uvmap_prog,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(rname,found,new,error)
       if (error)  return
       if (.not.all(found)) then
          call map_message(seve%e,rname,'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_main(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,rname,chain)
    !
    call map_parameters(rname,uvmap_prog,freq,uvmax,uvmin,error)
    if (error) return
    uvma = uvmax/(freq*f_to_k)
    !
    uvmap_prog%xycell = uvmap_prog%xycell*pi/180.0/3600.0
    !
    ! Get work space, ideally before mapping first image, for
    ! memory contiguity reasons.
    !
    nx = uvmap_prog%size(1)
    ny = uvmap_prog%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.cct%head%gil%dim(2)) then
       print *,'Mismatch number of channels between HUV ',nc,' and CCT ',cct%head%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(rname,uvmap_prog%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 (clean_prog%method.eq.'MX') do_weig = .true. ! Test
    if (do_weig) then
       call map_message(seve%i,rname,'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,rname,'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,rname,'Memory allocation error on DBEAM')
       error =.true.
       return
    endif
    !
    if (do_cct) then
       cct%head%r3d => cct%data
       !
       ! New residual image
       if (allocated(resid%data)) then
          call sic_delvariable ('RESIDUAL',.false.,error)
          deallocate(resid%data)
       endif
       allocate(resid%data(nx,ny,nc),stat=ier)
       !
       call gildas_null(resid%head)
       resid%head%gil%ndim = 3
       resid%head%gil%dim(1:3) = (/nx,ny,nc/)
       resid%head%r3d => resid%data
       !
       if (allocated(clean%data)) then
          call sic_delvariable ('CLEAN',.false.,error)
          deallocate(clean%data)
       endif
       allocate(clean%data(nx,ny,nc),stat=ier)
       clean%head%r3d => clean%data
       !
       call uvmap_and_restore(&
            rname,uvmap_prog, &
            huv,hbeam,resid%head, &
            nx,ny,nu,nv,duv, &
            g_weight,g_v,do_weig, &
            rcol,wcol,mcol,sblock,cpu0,error,uvma, &
            clean_prog,do_cct,cct%head,clean%head,do_slow,do_copy)
       !!PRINT *,'DO_WEIG after ',do_weig
       !
       ! Specify clean beam parameters
       clean%head%gil%reso_words = 3
       clean%head%gil%majo = clean_prog%major
       clean%head%gil%mino = clean_prog%minor
       clean%head%gil%posa = pi*clean_prog%angle/180.0
       !
       ! Get extrema
       call map_minmax(clean%head)
       !
       clean%head%loca%size = nx*ny*nc
       clean%head%gil%ndim = 3
       clean%head%gil%dim(1:3) = (/nx,ny,nc/)
       call sic_mapgildas ('CLEAN',clean%head,error,clean%data)
       call sic_mapgildas ('RESIDUAL',resid%head,error,resid%data)
       !
       save_data(code_save_clean) = .true.
       save_data(code_save_resid) = .true.
    else
       ! New dirty image
       if (allocated(dirty%data)) then
          call sic_delvariable ('DIRTY',.false.,error)
          deallocate(dirty%data)
       endif
       allocate(dirty%data(nx,ny,nc),stat=ier)
       !
       call gildas_null(dirty%head)
       dirty%head%gil%ndim = 3
       dirty%head%gil%dim(1:3) = (/nx,ny,nc/)
       dirty%head%r3d => dirty%data
       call sic_mapgildas('DIRTY',dirty%head,error,dirty%data)
       !
       call uvmap_and_restore (rname,uvmap_prog,   &
            &    huv, hbeam, dirty%head,   &
            &    nx,ny,nu,nv, duv,   &
            &    g_weight, g_v, do_weig,  &
            &    rcol,wcol,mcol,sblock,cpu0,error,uvma, &
            &    clean_prog, do_cct, cct%head, clean%head, 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(error)
       if (error) return
       !
       ! Define Min Max
       call map_minmax(dirty%head)
       !
       d_max = dirty%head%gil%rmax
       if (dirty%head%gil%rmin.eq.0) then
          d_min = -0.03*dirty%head%gil%rmax
       else
          d_min = dirty%head%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,rname,'Successful completion')
    !
    if (rname.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,rname,'Memory allocation failure')
    error = .true.
    return
    !
102 format(a,f9.2)
  end subroutine uvmap_main
  !
  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 image_def
    use mapping_interfaces, only: grdflt,convfn,convfn,docoor,grdtab,doweig,dotape,dofft,scawei
    use mapping_interfaces, only: sump,extracs,cmtore,chkfft
    use mapping_types, only: map_minmax
    use minmax_tool, only: maxmap
    use uvstat_tool, only: prnoise
    use gridding_types
    use uvmap_types
    use cct_types
    use clean_types
    use fit_beam_tool
    use omp_buffers
    !$ use omp_lib
    ! ------------------------------------------------------------------------
    ! 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
    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, target,     intent(inout) :: 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
    !
    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)
    !
    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) & ! 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%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_make(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
    !-----------------------------------------------------------------
    ! 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, optional, intent(in)  :: 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
    !-----------------------------------------------------------------
    ! 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 omp_lib
    !-----------------------------------------------------------------
    ! 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, optional, intent(in)  :: 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)
    !-----------------------------------------------------------------
    ! 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
    !-----------------------------------------------------------------
    ! 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)
    !-----------------------------------------------------------------
    ! 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
    !
    integer :: i,if,ia,ja
    real(8), parameter :: clight=299792458d0
    real(8) :: kwx,kwy,stepx,stepy,lambda,xr,yr
    complex(8) :: aplus,amoin,azero,afin
    !
    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
  !
  !------------------------------------------------------------------------------
  !
  subroutine new_dirty_beam(error)
    use gkernel_interfaces
    use clean_types
    use uv_buffers
    use uvmap_buffers
    use clean_buffers
    use primary_buffers
    !---------------------------------------------------------------------------
    ! Needed when a new dirty map is computed by command uv_map
    !---------------------------------------------------------------------------
    logical, intent(inout) :: error
    !
    if (allocated(clean%data)) deallocate(clean%data)
    call sic_delvariable('CLEAN',.false.,error)
    if (error) return
    clean%head%loca%size = 0
    !
    if (allocated(resid%data)) deallocate(resid%data)
    call sic_delvariable('RESIDUAL',.false.,error)
    if (error) return
    resid%head%loca%size = 0
    !
    if (allocated(cct%data)) deallocate(cct%data)
    call sic_delvariable('CCT',.false.,error)
    if (error) return
    cct%head%loca%size = 0
    !
    if (allocated(sky%data)) deallocate(sky%data)
    call sic_delvariable('SKY',.false.,error)
    if (error) return
    sky%head%loca%size = 0
  end subroutine new_dirty_beam
  !
  subroutine plunge_real(r,nx,ny,c,mx,my)
    !------------------------------------------------------------------------------
    ! Plunge a Real array into a Complex array
    !-----------------------------------------------------------------
    integer, intent(in)  :: nx,ny    ! Size of input array
    real,    intent(in)  :: r(nx,ny) ! Input real array
    integer, intent(in)  :: mx,my    ! Size of output array
    complex, intent(out) :: c(mx,my) ! Output complex array
    !
    integer :: i,j
    integer :: kx,ky,lx,ly
    !
    kx = nx/2+1
    lx = mx/2+1
    ky = ny/2+1
    ly = my/2+1
    !
    c = 0.0
    do j=1,ny
       do i=1,nx
          c(i-kx+lx,j-ky+ly) = cmplx(r(i,j),0.0)
       enddo
    enddo
  end subroutine plunge_real
  !
  subroutine recent(nx,ny,z)
    !------------------------------------------------------------------------------
    ! Recenters the Fourier Transform, for easier display. The present version
    ! will only work for even dimensions.
    !------------------------------------------------------------------------------
    integer, intent(in)    :: nx
    integer, intent(in)    :: ny
    complex, intent(inout) :: z(nx,ny)
    !
    integer :: i,j
    complex :: tmp
    !
    do j=1,ny/2
       do i=1,nx/2
          tmp = z(i+nx/2,j+ny/2)
          z(i+nx/2,j+ny/2) = z(i,j)
          z(i,j) = tmp
       enddo
    enddo
    !
    do j=1,ny/2
       do i=1,nx/2
          tmp = z(i,j+ny/2)
          z(i,j+ny/2) = z(i+nx/2,j)
          z(i+nx/2,j) = tmp
       enddo
    enddo
    !
    do j=1,ny
       do i=1,nx
          if (mod(i+j,2).ne.0) then
             z(i,j) = -z(i,j)
          endif
       enddo
    enddo
  end subroutine recent  
end module uvmap_tool
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
