!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module uvmosaic_tool
  use gbl_message
  !
  public :: uvmosaic_main,mosaic_sort,loadfiuv
  public :: many_beams_para
  private
  !
contains
  !
  subroutine uvmosaic_main(rname,line,error)
    use phys_const, only: pi
    use image_def
    use gkernel_types, only: projection_t
    use gkernel_interfaces
    use mapping_types, only: map_minmax
    use mapping_list_tool
    use mapping_primary, only: get_bsize
    use mapping_mosaic, only: mosaic_main
    use uv_continuum, only: map_beams,map_parameters
    use uv_shift, only: map_get_radecang
    use uvmap_tool, only: map_prepare,new_dirty_beam
    use clean_beam_tool, only: beam_for_channel
    use clean_types
    use file_buffers
    use uv_buffers
    use uvmap_buffers
    use clean_buffers
    !------------------------------------------------------------------------
    ! Compute a Mosaic from a CLIC UV Table with pointing offset information.
    !
    ! Input :
    !     a UV table with pointing offset information
    !
    ! Ouput
    !   NX NY are the image sizes
    !   NC is the number of channels
    !   NF is the number of different frequencies
    !   NP is the number of pointing centers
    !
    ! 'NAME'.LMV  a 3-d cube containing the uniform noise
    !     combined mosaic, i.e. the sum of the product
    !     of the fields by the primary beam. (NX,NY,NC)
    ! 'NAME'.LOBE the primary beams pseudo-cube (NP,NX,NY,NB)
    ! 'NAME'.WEIGHT the sum of the square of the primary beams (NX,NY,NB)
    ! 'NAME'.BEAM a 4-d cube where each cube contains the synthesised
    !     beam for one field (NX,NY,NB,NP)
    !
    ! All images have the same X,Y sizes
    !------------------------------------------------------------------------
    character(len=*), intent(in)    :: rname ! Caller (MOSAIC)
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    real(8), parameter :: f_to_k = 2.d0*pi/299792458.d-6
    !
    logical :: debug
    logical :: found(3)
    logical :: one,sorted,shift
    !
    integer :: ier
    integer :: nx,ny,nu,nv,nc,np,mp
    integer :: wcol,mcol(2),nfft,sblock
    integer :: ifield,jfield,ic,j,fstart,fend
    integer :: ib,nb,old_ib
    integer, allocatable :: voff(:)
    integer(kind=index_length) :: dim(4)
    real :: cpu0, cpu1
    real :: beamx,beamy
    real :: thre,btrunc,bsize ! To be initialized
    real :: offx,offy,factory,xm,xp,off_range(2)
    real(4) :: rmega,uvmax,uvmin,uvma
    real(8) :: freq
    real(8) :: new(3)
    real(8) :: pos(2)
    real, allocatable :: fft(:)
    real, allocatable :: noises(:)
    real, allocatable :: w_mapu(:),w_mapv(:),w_grid(:,:)
    real, allocatable, target :: dmap(:,:,:),dtmp(:,:,:,:)
    real, allocatable :: dweight(:,:)
    real, allocatable :: dtrunc(:,:)
    real, allocatable :: doff(:,:)
    real, pointer :: my_dirty(:,:,:)
    real, allocatable :: factorx(:)
    logical, parameter :: fromressection=.true.
    integer, parameter :: o_trunc=1
    integer, parameter :: o_field=2
    character(len=message_length) :: chain
    type(projection_t) :: proj
    !
    debug = sic_present(0,2) 
    !
    ! Get beam size from data or command line
    if (sic_present(o_trunc,0)) then
       call get_bsize(huv,rname,line,fromressection,bsize,error,OTRUNC=o_trunc,BTRUNC=btrunc)
    else
       call get_bsize(huv,rname,line,fromressection,bsize,error,BTRUNC=btrunc)
    endif
    if (error) return
    write(chain,'(a,f10.2,a,f6.0,a)') 'Correcting for a beam size of ',&
         & bsize/pi*180*3600,'" down to ',100*btrunc,'% '
    call map_message(seve%i,rname,chain)
    !
    call map_prepare(rname,uvmap_prog,error)
    if (error) return
    ! Temporary patch as mosaics + several beams does not give satisfying
    ! results (e.g. the BEAM% buffer will have only 3 dimensions)
    if (uvmap_prog%beam.eq.-1) then  ! MAP_BEAM_STEP mode
       ! Turn it to mode 0, i.e. force 1 beam for all channels
       uvmap_prog%beam = 0
       call map_message(seve%w,rname,  &
            'MAP_BEAM_STEP mode -1 is not yet implemented for mosaics: fallback to mode 0')
    endif
    !
    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
       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_*
    !
    ! Note: the sorting should have FIELD ID as primary (slowest varying) key
    ! It needs a mandatory interface for Doffx & Doffy
    ! It may be better to have a separate counting of NP before, as
    ! such a thing would anyway be needed by UV_STAT
    !
    call gag_cpu(cpu0)
    call mosaic_sort(error,sorted,shift,new,uvmax,uvmin, &
         & huv%gil%column_pointer(code_uvt_xoff), &
         & huv%gil%column_pointer(code_uvt_yoff), &
         & mp,doff,voff)
    if (error) return
    !
    xm = minval(doff(1,1:mp))
    xp = maxval(doff(1,1:mp))
    off_range(1) = xp-xm
    xm = minval(doff(2,1:mp))
    xp = maxval(doff(2,1:mp))
    off_range(2) = xp-xm
    !
    if (.not.sorted) then
       !! print *,'Done mosaic_sort UV range ',uvmin,uvmax,' sorted ',sorted
       !! call uv_dump_buffers('UV_MOSAIC')
       ! Redefine SIC variables (mandatory)
       call sic_delvariable ('UV',.false.,error)
       call sic_mapgildas ('UV',huv,error,duv)
    else
       !! print *,'Mosaic was sorted ',uvmin,uvmax,' sorted ',sorted
    endif
    call gag_cpu(cpu1)
    write(chain,102) 'Finished sorting ',cpu1-cpu0
    call map_message(seve%i,rname,chain)
    !
    ! This may need to be revised 
    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)
    nc = huv%gil%nchan
    !
    allocate(w_mapu(nx),w_mapv(ny),w_grid(nx,ny),stat=ier)
    if (ier.ne.0) then
       call map_message(seve%e,rname,'Gridding allocation error')
       goto 98
    endif
    !
    do_weig = .true.
    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) then
          call map_message(seve%e,rname,'Weight allocation error')
          goto 98
       endif
    else
       call map_message(seve%i,rname,'Re-using weights')
    endif
    nfft = 2*max(nx,ny)
    allocate(fft(nfft),stat=ier)
    if (ier.ne.0) then
       call map_message(seve%e,rname,'FFT allocation error')
       goto 98
    endif
    !
    rmega = 8.0
    ier = sic_ramlog('SPACE_MAPPING',rmega)
    sblock = max(int(256.0*rmega*1024.0)/(nx*ny),1)
    !
    ! New Beam place
    if (allocated(dbeam)) then
       call sic_delvariable ('BEAM',.false.,error)
       deallocate(dbeam)
    endif
    call gildas_null(hbeam)
    !
    ! New dirty image
    if (rname.ne.'MOSAIC_RESTORE') then 
       if (allocated(dirty%data)) then
          call sic_delvariable ('DIRTY',.false.,error)
          deallocate(dirty%data)
       endif
       allocate(dirty%data(nx,ny,nc),dmap(nx,ny,nc),dtrunc(nx,ny),stat=ier)
       my_dirty => dirty%data
    else
       if (allocated(resid%data)) then
          call sic_delvariable ('RESIDUAL',.false.,error)
          deallocate(resid%data)
       endif
       allocate(resid%data(nx,ny,nc),dmap(nx,ny,nc),dtrunc(nx,ny),stat=ier)
       my_dirty => resid%data
    endif
    if (ier.ne.0) then
       call map_message(seve%e,rname,'Map allocation error')
       goto 98
    endif
    !
    call gildas_null(dirty%head)
    dirty%head%gil%ndim = 3
    dirty%head%gil%dim(1:3) = (/nx,ny,nc/)
    !
    ! Compute the primary beams and weight image
    call gildas_null(primbeam%head)
    if (allocated(primbeam%data)) then
       call sic_delvariable ('PRIMARY',.false.,error)
       deallocate(primbeam%data)
    endif
    if (allocated(fields%data)) then
       deallocate(fields%data)
    endif
    !
    ! Find out how many beams are required
    call map_beams(rname,uvmap_prog%beam,huv,nx,ny,nb,nc)
    !
    !!print *,'Done MAP_BEAMS ',uvmap_prog%beam,nb
    !
    call sic_delvariable('FIELDS%N_SELECT',.false.,error)
    call sic_delvariable('FIELDS%SELECTED',.false.,error)
    error = .false.
    !
    ! Get the field lists from the /FIELD option if any
    if (sic_present(o_field,0)) then
       np = 0
       call get_i4list_fromsic(rname,line,o_field,np,selected_fields,error)  
       if (np.gt.mp) then
          call map_message(seve%e,rname,'More selected fields than available')
          error = .true.
       else 
          do jfield=1,np
             ifield = selected_fields(jfield)
             if (ifield.le.0 .or. ifield.gt.mp) then
                write(chain,'(A,I0,I0,A,I0,A)') 'Selected field ',jfield,& 
                     & ifield,' out of range [1,',mp,']'
                call map_message(seve%e,rname,chain)
                error = .true.
             endif
          enddo
       endif
       if (error) return
       selected_fieldsize = np
       write(chain,'(I0,A,I0,A)') np,' fields selected:' 
       call map_message(seve%i,rname,chain)
       write(*,'(10X,6(2X,I0))') selected_fields(1:np)
       !
       call sic_def_inte('FIELDS%N_SELECT',selected_fieldsize,0,0,.true.,error)
       dim(1) = selected_fieldsize
       call sic_def_inte('FIELDS%SELECTED',selected_fields,1,dim,.true.,error)    
    else
       np = mp
       if (allocated(selected_fields))  deallocate(selected_fields)
       allocate(selected_fields(mp),stat=ier)
       do jfield=1,np
          selected_fields(jfield) = jfield
       enddo
       selected_fieldsize = 0    ! Means all
    endif
    !
    ! An issue is that the map characteristics are defined
    ! in "one_beam". We need to call the proper routines before...
    call map_headers(rname,uvmap_prog,huv,hbeam,dirty%head,primbeam%head,nb,np,mcol)
    !
    !!print *,'Done MAP_HEADERS '
    !
    ! Define the projection about the Phase center
    call gwcs_projec(huv%gil%a0,huv%gil%d0,-huv%gil%pang,huv%gil%ptyp,proj,error)
    ! POS is here the Offset of the Pointing center relative to the Phase center
    call abs_to_rel(proj,huv%gil%ra,huv%gil%dec,pos(1),pos(2),1)
    !
    !***JP: Here was the old code for mosaics. Look in the
    !***JP: obsolete/tool-uvmosaic.f90 file if needed.
    !
    !!print *,'Using untested code, use MAP_BEAM_STEP = -2 if failed'
    !
    ! Code ready but only tested for one Beam for all Frequencies.
    hbeam%gil%ndim = 4
    hbeam%gil%dim(1:4)=(/nx,ny,nb,np/)
    allocate(dbeam(nx,ny,nb,np),stat=ier)
    !
    allocate (primbeam%data(np,nx,ny,nb),dweight(nx,ny),&
          dtmp(nx,ny,nb,1),factorx(nx),stat=ier)
    if (ier.ne.0) then
       call map_message(seve%e,rname,'Primary beam allocation error')
       goto 98
    endif
    primbeam%head%r4d => primbeam%data
    !
    ! Create the primary beams, lobe and weight images
    do jfield = 1,np
       ifield = jfield
       if (selected_fieldsize.ne.0) ifield = selected_fields(jfield)    
       ! bsize is Frequency dependent TBC
       !
       do ib=1,nb
          beamx = primbeam%head%gil%inc(2)/bsize*2.0*sqrt(log(2.0))
          beamy = primbeam%head%gil%inc(3)/bsize*2.0*sqrt(log(2.0))
          offx = (doff(1,ifield)+pos(1))/primbeam%head%gil%inc(2)
          offy = (doff(2,ifield)+pos(2))/primbeam%head%gil%inc(3)
          !
          do j=1,nx
             factorx(j) = exp(-((j-primbeam%head%gil%ref(2)-offx)*beamx)**2)
          enddo
          do j=1,ny
             factory = exp(-((j-primbeam%head%gil%ref(3)-offy)*beamy)**2)
             primbeam%data(jfield,:,j,ib) = factorx(:) * factory
          enddo
       enddo
    enddo
    deallocate (factorx)
    !
    ! Loop on fields for imaging
    ! Use Dtmp and Dmap as work arrays for beam and image
    hbeam%r3d => dtmp(:,:,:,1)
    hbeam%gil%dim(4) = 1
    !
    ! Y a un os pour le mode parallele
    dirty%head%r3d => dmap
    !
    my_dirty = 0
    dbeam = 0
    allocate(noises(np))  ! To remember the noise
    !
    !$OMP PARALLEL DEFAULT(none) &
    !$OMP   & SHARED(np,debug,rname,uvmap_prog,huv,primbeam,dbeam,my_dirty) & 
    !$OMP   & FIRSTPRIVATE(dirty,hbeam) &
    !$OMP   & SHARED(voff, selected_fields, noises) &
    !$OMP   & SHARED(nx,ny,nu,nc,duv,wcol,mcol,sblock,cpu0,uvma,btrunc) &
    !$OMP   & PRIVATE(g_weight,g_v,ifield,jfield) &
    !$OMP   & PRIVATE(fstart,fend,nv,do_weig,error,chain) &
    !$OMP   & PRIVATE(old_ib,ic,ib,dtrunc,dmap,dtmp)
    !
    !$OMP DO
    do jfield = np,1,-1
       ifield = selected_fields(jfield)
       ! Pour le mode parallele
       dirty%head%r3d => dmap
       hbeam%r3d => dtmp(:,:,:,1)
       !
       do_weig = .true.
       fstart = voff(ifield)      ! Starting Visibility of field
       fend   = voff(ifield+1)-1  ! Ending Visibility of field
       nv = fend-fstart+1
       if (debug) then
          print *,'Ifield ',ifield,fstart,fend
          print *,'Cols ',wcol,mcol
          print *,'Sizes ',nx,ny,nu,nv,np,nc
          print *,'Calling many_beams_para with SBLOCK ',sblock
       endif
       call many_beams_para (rname,uvmap_prog, huv, hbeam, dirty%head,   &
            &    nx,ny,nu,nv, duv(:,fstart:fend),   &
            &    g_weight, g_v, do_weig,  &
            &    wcol,mcol,sblock,cpu0,error,uvma,ifield)
       noises(jfield) = dirty%head%gil%noise  ! Remember the noise
       !
       old_ib = 0
       !
       do ic=1,nc
          ib = beam_for_channel(ic,dirty%head,hbeam)
          if (debug) print *,'Selected beam ',ib
          ! Add it to the "mosaic dirty" image, by multiplying by
          ! the truncated primary beam
          if (ib.ne.old_ib) then
             dtrunc(:,:) = primbeam%data(jfield,:,:,ib)
             if (debug) print *,'Set DTRUNC ',ib,' # ',old_ib
             where (dtrunc.lt.btrunc) dtrunc = 0
             old_ib = ib
          endif
          !$OMP CRITICAL
          my_dirty(:,:,ic) = my_dirty(:,:,ic) + dmap(:,:,ic)*dtrunc(:,:)
          !$OMP END CRITICAL
       enddo
       !
       ! Save the beam - Transposition could be done here if needed
       dbeam(:,:,:,jfield) = dtmp(:,:,:,1)
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    dirty%head%gil%noise = sum(noises)/np
    !
    hbeam%r4d => dbeam
    !
    ! What about the weights here ?
    if (nb.eq.1) then
       dweight = 0
       call mos_addsq (nx*ny,np,dweight,primbeam%data)
       thre = btrunc**2
       call mos_inverse (nx*ny,dweight,thre)
       if (debug) print *,'Done MOS_INVERSE'
       !
       ! Repack the Beam to 3-Dimensions only
       hbeam%gil%dim(1:4) = [nx,ny,np,1]
       hbeam%gil%convert(:,3) = 1.d0
       hbeam%char%code(3) = 'FIELD'
       hbeam%gil%ndim = 3
    else
       call map_message(seve%e,rname,'More than one beam per field - Weights not computed')
    endif
    !
    call sic_mapgildas('BEAM',hbeam,error,dbeam)
    !
    ! OK we are done (apart from details like Extrema)
    if (.not.error) call map_message(seve%i,rname,'Successful completion')
    primbeam%head%gil%inc(1) = btrunc  ! Convention to store the truncation level
    call sic_mapgildas('PRIMARY',primbeam%head,error,primbeam%data)
    !
    ! Reset the Dirty pointer
    dirty%head%r3d => my_dirty
    ! Correct the noise for the approximate gain at mosaic center
    ! for HWHM hexagonal spacing (normally it is sqrt(1+6/4)) 
    dirty%head%gil%noise = dirty%head%gil%noise/1.5
    if (rname.ne.'MOSAIC_RESTORE') then 
       call sic_mapgildas('DIRTY',dirty%head,error,dirty%data)
       !
       save_data(code_save_beam) = .true.
       save_data(code_save_dirty) = .true.
       save_data(code_save_primary) = .true.
       save_data(code_save_fields) = .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
    else
       ! Restore the DIRTY image pointer
       dirty%head%r3d => dirty%data
       call map_minmax(dirty%head)
       ! And define the RESIDUAL
       call gdf_copy_header(dirty%head,resid%head,error)
       resid%head%r3d => resid%data
       call map_minmax(resid%head)
       call sic_mapgildas('RESIDUAL',resid%head,error,resid%data)
    endif
    !
    error = .false.
    !
    ! Backward compatibility with previous methods
    clean_user%trunca = btrunc ! By convention ***JP: bizarre to have this here
    primbeam%head%gil%convert(3,4) = bsize ! Primary beam size convention
    call mosaic_main('ON',error)
    !
    if (allocated(w_mapu)) deallocate(w_mapu)
    if (allocated(w_mapv)) deallocate(w_mapv)
    if (allocated(w_grid)) deallocate(w_grid)
    if (allocated(fft)) deallocate(fft)
    return
    !
98  call map_message(seve%e,rname,'Memory allocation failure')
    error = .true.
    return
    !
102 format(a,f9.2)
  end subroutine uvmosaic_main
  !
  subroutine map_headers(rname,map,huv,hbeam,hdirty,hprim,nb,nf,mcol)
    use image_def
    use gkernel_interfaces
    use uvmap_types
    !------------------------------------------------------------------------
    ! Define the image headers
    !------------------------------------------------------------------------
    character(len=*), intent(in)    :: rname
    type (uvmap_par), intent(inout) :: map
    type (gildas),    intent(inout) :: huv
    type (gildas),    intent(inout) :: hbeam
    type (gildas),    intent(inout) :: hdirty
    type (gildas),    intent(inout) :: hprim
    integer,          intent(in)    :: nb      ! Number of beams per field
    integer,          intent(in)    :: nf      ! Number of fields
    integer,          intent(inout) :: mcol(2) ! First and last channel
    !
    real(kind=8), parameter :: clight=299792458d-6 ! Frequency in  MHz
    !
    type(gildas) :: htmp
    integer :: nx   ! X size
    integer :: ny   ! Y size
    integer :: nc   ! Number of channels
    integer lcol,fcol
    real vref,voff,vinc,schunk
    real(kind=4) :: loff,boff
    logical :: error
    character(len=4) :: code
    !
    nx = map%size(1)
    ny = map%size(2)
    !
    vref = huv%gil%ref(1)
    voff = huv%gil%voff
    vinc = huv%gil%vres
    !
    nc = huv%gil%nchan
    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
    fcol = min(mcol(1),mcol(2))
    lcol = max(mcol(1),mcol(2))
    nc = lcol-fcol+1
    !
    ! Make beam, not normalized
    call gdf_copy_header(huv,hbeam,error)
    hbeam%gil%dopp = 0.0 ! Nullify the Doppler factor
    !
    ! Is that right ?
    schunk = nc/nb
    !
    hbeam%gil%ndim = 4
    hbeam%gil%dim(1) = nx
    hbeam%gil%dim(2) = ny
    hbeam%gil%dim(3) = nb
    hbeam%gil%dim(4) = nf
    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) = (2.d0*(vref-fcol)+schunk+1.d0)/2/schunk ! Correct
    hbeam%gil%convert(2,3) = voff
    hbeam%gil%convert(:,4) = 1.d0
    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%char%code(4) = 'FIELD'
    hbeam%gil%majo = 0.0
    hbeam%loca%size = nx*ny*nb*nf
    !
    ! 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) = nc
    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*nc
    !
    call gildas_null(hprim)
    if (nf.ge.1) then
       call gildas_null(htmp)
       ! Prepare the primary beam cube header
       call gdf_copy_header(hdirty,htmp,error)
       htmp%gil%dim(4) = nf
       htmp%gil%convert(:,4) = 1.d0
       htmp%char%unit = ' '
       htmp%char%code(4) = 'FIELD'
       ! Also reset the Number of Beams in Frequency
       htmp%gil%dim(3) = nb
       code = '4123'
       call gdf_transpose_header(htmp,hprim,code,error)    
    endif
  end subroutine map_headers
  !
  subroutine mosaic_sort(error,sorted,shift,new,uvmax,uvmin,ixoff,iyoff,nf,doff,voff)
    use phys_const, only: pi
    use image_def
    use gkernel_interfaces
    use uv_buffers, only: uv_find_buffers,uv_clean_buffers
    use uv_shift, only: uv_shift_header
    use clean_types
    use uv_buffers
    !----------------------------------------------------------------------
    ! Sort the input UV table
    !----------------------------------------------------------------------
    logical,              intent(inout) :: sorted       ! Is table sorted ?
    logical,              intent(inout) :: shift        ! Do we shift phase center ?
    real(kind=8),         intent(inout) :: new(3)       ! New phase center and PA
    real,                 intent(out)   :: uvmin        ! Min baseline
    real,                 intent(out)   :: uvmax        ! Max baseline
    integer,              intent(in)    :: ixoff,iyoff  ! Offset pointers
    integer,              intent(out)   :: nf           ! Number of fields
    real,    allocatable, intent(out)   :: doff(:,:)    ! Field offsets
    integer, allocatable                :: voff(:)      ! Field visibility offsets
    logical,              intent(inout) :: error
    !
    real(8), parameter :: f_to_k = 2.d0*pi/299792458.d-6
    real(kind=8) :: freq,off(3)
    real :: pos(2),cs(2)
    integer :: nu,nv
    real, pointer :: duv_previous(:,:),duv_next(:,:)
    !
    ! The UV table is available in HUV%
    if (huv%loca%size.eq.0) then
       call map_message(seve%e,'UV_MAP','No UV data loaded')
       error = .true.
       return
    endif
    nu = huv%gil%dim(1)
    nv = huv%gil%dim(2)
    !
    ! Correct for new phase center if required
    if (shift) then
       if (huv%gil%ptyp.eq.p_none) then
          call map_message(seve%w,'SHIFT','No previous phase center info')
          huv%gil%a0 = huv%gil%ra
          huv%gil%d0 = huv%gil%dec
          huv%gil%pang = 0.d0
          huv%gil%ptyp = p_azimuthal
       elseif (huv%gil%ptyp.ne.p_azimuthal) then
          call map_message(seve%w,'SHIFT','Previous projection type not SIN')
          huv%gil%ptyp = p_azimuthal
       endif
       call uv_shift_header(new,huv%gil%a0,huv%gil%d0,huv%gil%pang,off,shift)
       huv%gil%posi_words = def_posi_words
       huv%gil%proj_words = def_proj_words
    endif
    !
    sorted = .false.
    if (.not.shift) then
       call check_order_mosaic(duv,nu,nv,ixoff,iyoff,sorted)
    endif
    !
    ! Get center frequency
    freq = gdf_uv_frequency(huv,huv%gil%ref(1))
    !
    if (sorted) then
       ! If already sorted, use it
       call map_message(seve%i,'UV_MOSAIC','UV table is already sorted')
       !
       ! Load Field coordinates and compute UVMAX
       call mosaic_loadfield(duv,nu,nv,ixoff,iyoff,nf,doff,voff,uvmax,uvmin)
    else
       ! Else, create another copy
       call map_message(seve%i,'UV_MOSAIC','Sorting UV table...')
       !
       ! Compute observing frequency, and new phase center in wavelengths
       if (shift) then
          huv%gil%a0 = new(1)
          huv%gil%d0 = new(2)
          huv%gil%pang = new(3)
          cs(1)  =  cos(off(3))
          cs(2)  = -sin(off(3))
          ! Note that the new phase center is counter-rotated because rotations
          ! are applied before phase shift.
          pos(1) = - freq * f_to_k * ( off(1)*cs(1) - off(2)*cs(2) )
          pos(2) = - freq * f_to_k * ( off(2)*cs(1) + off(1)*cs(2) )
       else
          pos(1) = 0.0
          pos(2) = 0.0
          cs(1) = 1.0
          cs(2) = 0.0
       endif
       !
       ! OK, rotate, shift, sort and copy...
       !
       nullify (duv_previous, duv_next)
       !
       call uv_find_buffers('UV_MOSAIC',nu,nv,duv_previous,duv_next,error)
       if (error) return
       !! call uv_dump_buffers ('UV_MOSAIC - After Find')
       !
       call mosaic_sortuv(nu,nv,huv%gil%ntrail,duv_previous,duv_next,   &
            &        pos,cs,uvmax,uvmin,error,ixoff,iyoff,nf,doff,voff)
       call uv_clean_buffers(duv_previous, duv_next, error)
       if (error) return
       !! call uv_dump_buffers ('UV_MOSAIC- After Clean')
    endif
    !
    ! Now transform UVMAX in kiloWavelength (including 2 pi factor)
    uvmax = uvmax*freq*f_to_k
    uvmin = uvmin*freq*f_to_k
    error = .false.
  end subroutine mosaic_sort
  !
  subroutine mosaic_sortuv(np,nv,ntrail,vin,vout,xy,cs,uvmax,uvmin,&
       error,ixoff,iyoff,nf,doff,voff)
    use phys_const
    use gildas_def
    use gkernel_interfaces
    use uv_rotate_shift_and_sort_tool, only: loaduv,sortuv
    !---------------------------------------------------------------------
    ! Sort a UV table by fields
    ! Rotate, Shift and Sort a UV table for map making
    ! Differential precession should have been applied before.
    !---------------------------------------------------------------------
    integer,              intent(in)    :: np          ! Size of a visibility
    integer,              intent(in)    :: nv          ! Number of visibilities
    integer,              intent(in)    :: ntrail      ! Number of trailing daps
    real,                 intent(in)    :: vin(np,nv)  ! Input visibilities
    real,                 intent(out)   :: vout(np,nv) ! Output visibilities
    real,                 intent(in)    :: xy(2)       ! Phase shift
    real,                 intent(in)    :: cs(2)       ! Frame Rotation
    real,                 intent(out)   :: uvmax       ! Max UV value
    real,                 intent(out)   :: uvmin       ! Min UV value
    integer,              intent(in)    :: ixoff,iyoff
    integer,              intent(out)   :: nf
    real,    allocatable, intent(out)   :: doff(:,:)
    integer, allocatable, intent(out)   :: voff(:)
    logical,              intent(inout) :: error
    !
    logical :: sorted
    integer :: ier,ifi,iv
    integer, allocatable :: ipi(:)       ! Index
    real, allocatable :: rpu(:),rpv(:)   ! U,V coordinates
    real, allocatable :: spv(:)          ! Sorted V coordinates
    real(8), allocatable :: dtr(:)       ! Sorting number
    logical, allocatable :: ips(:)       ! Sign of visibility
    !
    ! Load U,V coordinates, applying possible rotation (CS),
    ! and making all V negative
    allocate (ips(nv),rpu(nv),rpv(nv),ipi(nv),dtr(nv),stat=ier)
    if (ier.ne.0) then
       error = .true.
       return
    endif
    call loaduv(vin,np,nv,cs,rpu,rpv,ips,uvmax,uvmin)
    !!print *,'UVMIN ',uvmin,' UVMAX ',uvmax,' NP ',np,' NV ',nv
    !
    ! Modify the uv coordinates to minimize
    ! the projection errors ... See Sault et al 1996 Appendix 1
    ! Key question here
    ! - modification must be done before sorting
    ! - but should we use the modified or intrinsic UV coordinates ?
    !
    ! For the rotation above, it does not matter, actually: the
    ! matrix commutes (I think so - That can be check later...)
    !
    !  call remapuv(nv,cs,rpu,rpv,ixoff,iyoff,uvmax,uvmin)
    !
    ! Identify number of fields
    call loadfiuv(vin,np,nv,dtr,ipi,sorted,ixoff,iyoff,rpv,nf,doff)
    !
    ! Sort by fields (major number) then V (fractionary part)
    if (.not.sorted) then
       !!print *,'Sorting UV data '
       call gr8_trie(dtr,ipi,nv,error)
       if (error) return
       deallocate (dtr,stat=ier)
       allocate (spv(nv),stat=ier)
       !
       ! One must sort RPV here to use SORTUV later...
       do iv=1,nv
          spv(iv) = rpv(ipi(iv))
       enddo
       rpv(:) = spv(:)
       deallocate (spv,stat=ier)
    else
       deallocate (dtr,stat=ier)
       !!print *,'UV Data is already sorted '
    endif
    !!Read(5,*) ifi
    !
    ! Apply phase shift and copy to output visibilities
    call sortuv(vin,vout,np,nv,ntrail,xy,rpu,rpv,ips,ipi)
    !
    ! Compute start & end of fields
    allocate(voff(nf+1),stat=ier)
    ifi = 1
    voff(ifi) = 1
    do iv=1,nv
       if ( (doff(1,ifi).ne.vout(ixoff,iv)) .or. &
            &  (doff(2,ifi).ne.vout(iyoff,iv)) ) then
          ifi = ifi+1
          voff(ifi) = iv
       endif
    enddo
    voff(nf+1) = nv+1
    !
    !!print *,'XOFF ',ixoff,' YOFF ',iyoff
    do ifi=1,min(nf,20)
       write(*,'(I4,A,2F12.4,2I10)') ifi,' DOFF ', &
            & doff(1,ifi)*180.*3600./pi, &
            & doff(2,ifi)*180.*3600./pi, &
            & voff(ifi), voff(ifi+1)-1
    enddo
  end subroutine mosaic_sortuv
  !
  subroutine check_order_mosaic(visi,np,nv,ixoff,iyoff,sorted)
    !----------------------------------------------------------
    ! Check if visibilites are sorted.
    ! Chksuv does a similar job, but using V values and an index.
    !----------------------------------------------------------
    integer, intent(in) :: np          ! Size of a visibility
    integer, intent(in) :: nv          ! Number of visibilities
    real,    intent(in) :: visi(np,nv) ! Visibilities
    integer, intent(in) :: ixoff       ! X pointing column
    integer, intent(in) :: iyoff       ! Y pointing column
    logical, intent(out) :: sorted
    !
    integer :: iv
    real :: vmax,xoff,yoff
    !
    vmax = visi(2,1)
    xoff = visi(ixoff,1)
    yoff = visi(iyoff,1)
    !
    do iv=2,nv
       if (visi(2,iv).lt.vmax) then
          if (visi(ixoff,iv).eq.xoff .and. visi(iyoff,iv).eq.yoff) then
             !!print *,'Unsorted V at ',iv,visi(2,iv),vmax
             sorted = .false.
             return
          endif
          ! else, this is a new offset
          xoff = visi(ixoff,iv)
          yoff = visi(iyoff,iv)
       else if (visi(ixoff,iv).eq.xoff .and. visi(iyoff,iv).eq.yoff) then
          ! ok, things progress normally
          continue
       else
          ! Unsorted offset
          !!print *,'Unsorted Position offset at ',iv
          sorted = .false.
          return
       endif
       vmax = visi(2,iv)
    enddo
    sorted = .true.
  end subroutine check_order_mosaic
  !
  subroutine loadfiuv(visi,np,nv,dtr,it,sorted,ixoff,iyoff,rpv,nf,doff)
    !----------------------------------------------------------------------
    ! Load field numbers into work arrays for sorting.
    !----------------------------------------------------------------------
    integer,                   intent(in)  :: np          ! Size of a visibility
    integer,                   intent(in)  :: nv          ! Number of visibilities
    real,                      intent(in)  :: visi(np,nv) ! Input visibilities
    real(8),                   intent(out) :: dtr(nv)     ! Output field number
    integer,                   intent(out) :: it(nv)      ! Indexes
    logical,                   intent(out) :: sorted      !
    integer,                   intent(in)  :: ixoff       ! X pointer
    integer,                   intent(in)  :: iyoff       ! Y pointer
    real(4),                   intent(in)  :: rpv(nv)     ! V Values
    integer,                   intent(out) :: nf          ! Number of fields
    real(kind=4), allocatable, intent(out) :: doff(:,:)   ! Fields offsets
    !
    integer :: iv,ifi,mfi,kfi,nfi,ier
    real(8) :: vmax
    real(kind=4), allocatable :: dtmp(:,:)
    !
    ! Scan how many fields
    nfi = 1
    mfi = 100
    !
    ! V are negative values, so this 1 + max(abs(V))
    vmax = 1.0d0-minval(rpv)
    !
    allocate(dtmp(2,mfi),stat=ier)
    dtmp(1,1) = visi(ixoff,1)
    dtmp(2,1) = visi(iyoff,1)
    dtr(1) = 1.d0+rpv(1)/vmax ! We have here 0 =< dtr < 1
    !
    do iv=2,nv
       kfi = 0
       do ifi=1,nfi
          if (visi(ixoff,iv).eq.dtmp(1,ifi) .and. &
               & visi(iyoff,iv).eq.dtmp(2,ifi) ) then
             dtr(iv) = dble(ifi)+rpv(iv)/vmax
             kfi = ifi
             exit
          endif
       enddo
       !
       ! New field
       if (kfi.eq.0) then
          if (nfi.eq.mfi) then
             allocate(doff(2,mfi),stat=ier)
             doff(:,:) = dtmp(:,:)
             deallocate(dtmp)
             allocate(dtmp(2,2*mfi),stat=ier)
             dtmp(:,1:mfi) = doff
             deallocate(doff)
             mfi = 2*mfi
          endif
          nfi = nfi+1
          dtmp(1,nfi) = visi(ixoff,iv)
          dtmp(2,nfi) = visi(iyoff,iv)
          dtr(iv) = dble(nfi)+rpv(iv)/vmax   ! nfi-1 =< dtr < nfi
       endif
    enddo
    !
    nf = nfi
    allocate(doff(2,nfi),stat=ier)
    doff(1:2,:) = dtmp(1:2,1:nfi)
    !
    do iv=1,nv
       it(iv) = iv
    enddo
    !
    ! DTR must in the end be ordered and increasing.
    vmax = dtr(1)
    do iv = 1,nv
       if (dtr(iv).lt.vmax) then
          sorted = .false.
          return
       endif
       vmax = dtr(iv)
    enddo
    sorted = .true.
  end subroutine loadfiuv
  !
  subroutine many_beams_para(rname,map,huv,hbeam,hdirty,&
       nx,ny,nu,nv,uvdata,&
       r_weight,w_v,do_weig,&
       wcol,mcol,sblock,cpu0,error,uvmax,jfield)
    use image_def
    use gkernel_interfaces
    use mapping_interfaces, only: grdflt,convfn,docoor,grdtab,doweig,dotape,dofft
    use mapping_interfaces, only: sump
    use gridding_types
    use uvmap_types
    use uvstat_tool, only: prnoise
    !$ 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))
    ! Output:
    !    a beam image
    !    a VLM cube
    ! Work space:
    !    a  VLM complex Fourier cube (first V value is for beam)
    !------------------------------------------------------------------------
    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, target,     intent(inout) :: r_weight(nv)  ! Weight of visibilities
    real,             intent(inout) :: w_v(nv)       ! V values
    logical,          intent(inout) :: do_weig
    integer,          intent(in)    :: jfield        ! Field number (for mosaic)
    real,             intent(inout) :: cpu0          ! CPU
    real,             intent(inout) :: uvmax         ! Maximum baseline
    integer,          intent(inout) :: sblock        ! Blocking factor
    integer,          intent(inout) :: wcol          ! Weight channel
    integer,          intent(inout) :: mcol(2)       ! First and last channel
    logical,          intent(inout) :: error
    !
    real(kind=8), parameter :: clight=299792458d-6 ! Frequency in  MHz
    !
    type (gridding) :: conv
    !
    logical :: local_error
    integer :: nc   ! Number of channels
    integer :: nd   ! Size of data
    integer :: nb   ! Number of beams
    integer :: ns   ! Number of channels per single beam
    integer :: ier
    integer :: ctypx,ctypy
    integer :: lcol,fcol
    integer :: ndim,nn(2),lx,ly,kz1
    integer :: kz,iz,ic,kc,kb,jc,lc
    real :: rmi,rma,wall,cpu1
    real :: xparm(10),yparm(10)
    real :: rms,null_taper(4),wold
    real :: uvcell(2)
    real :: support(2)
    real(kind=4) :: loff,boff
    real(8) :: vref,voff,vinc
    real(8) local_freq
    real(kind=8) :: freq
    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(:)
    complex, allocatable :: ftbeam(:,:)
    complex, allocatable :: tfgrid(:,:,:)
    !
    integer :: ithread,othread,nthread
    real(8) :: elapsed_s,elapsed_e,elapsed
    real :: toto
    character(len=message_length) :: mess
    !
    error = .false.
    nd = nx*ny
    nc = huv%gil%nchan
    nb = hbeam%gil%dim(3)
    !
    ns = map%beam
    null_taper = 0
    !
    if (ns.ne.1 .and. nb.gt.1) then
       write(mess,'(a,i6,a)') 'Processing ',ns,' channels per beam'
       call map_message(seve%w,rname,mess)
    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),nc))
    endif
    if (mcol(2).eq.0) then
       mcol(2) = nc
    else
       mcol(2) = max(1,min(mcol(2),nc))
    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,nc)
    nc = lcol-fcol+1
    !
    ! Compute observing sky frequency for U,V cell size
    freq = gdf_uv_frequency(huv, 0.5d0*dble(lcol+fcol) )
    !
    ! 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(nb),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(mess,'(A,A,F8.3)') 'Map cell is too large ',   &
            ' Undersampling ratio ',float(ly)/float(ny)
       call map_message(seve%e,rname,mess)
       ly = min(ly,ny)
       lx = min(lx,nx)
    endif
    !
    ! Get FFT's and beam work spaces
    allocate (tfgrid(ns+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    ! Nullify the Doppler factor
    !
    hbeam%gil%ndim = 3
    hbeam%gil%dim(1) = nx
    hbeam%gil%dim(2) = ny
    hbeam%gil%dim(3) = nb
    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
    !
    hbeam%gil%convert(1,3) = (2.d0*(vref-fcol)+ns+1.d0)/2/ns ! 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*nb
    !
    ! 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) = nc
    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*nc
    !
    ! Smooth the beam
    hbeam%gil%convert(3,3) = vinc*ns
    hbeam%gil%vres = ns*vinc
    hbeam%gil%fres = ns*hbeam%gil%fres
    !
    error = .false.
    if (nb.gt.1) then
       !$ othread = omp_get_max_threads()
       !$ nthread = min(othread,nb)
       !$ call omp_set_num_threads(nthread)
    else
       nthread = 1
    endif
    !
    ! Loop over blocks
    !
    !$OMP PARALLEL IF (nb.gt.1) DEFAULT(none) &
    !$OMP PRIVATE(tfgrid,ftbeam,beam,w_weight,w_w) &  ! Big arrays
    !$OMP PRIVATE(w_mapu,w_mapv,w_grid) &
    !$OMP PRIVATE(local_wfft,mess) &
    !$OMP PRIVATE(local_freq,support,wall,wold,rms,uvcell,local_error) &
    !$OMP PRIVATE(kz,kb,kc,iz,ic, kz1, toto, jc,lc) &
    !$OMP SHARED(walls,ns,nb) &
    !$OMP SHARED(nu,nv,nx,ny,nc,nd,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)
    !
    kz = 1 ! test for bug below
    !
    ! print *,'KZ ',kz,' NC ',nc,' nd ',nd
    !$OMP DO
    do ic = fcol,lcol,ns ! ,ns or ,1
       kz = min(ns,lcol-ic+1)
       jc = min(huv%gil%nchan,ic+ns/3)   ! The default weight channel here...
       !!print *,'IC ',ic,' JC ',jc,'MCOL ',fcol,lcol,' NS ',ns
       ithread = 1
       !$ elapsed_s = omp_get_wtime()
       !$ ithread = omp_get_thread_num()+1
       !print *,'Thread ',ithread,' IC ',ic,', KZ ',kz,', NS ',ns
       !
       kb = (ic-fcol)/ns+1
       if (kb.gt.nb .or. kb.lt.1) then
          print *,'Programming error, expected 0 < ',kb,' < ',nb+1
          kb = nb
       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 lc=ic,min(ic+ns,lcol) ! not  ,huv%gil%nchan)
             if (lc.ne.jc) then
                w_w(:) = uvdata(7+3*lc,:)
                wold = sump(nv,w_w)
                if (wold.ne.0) then
                   jc = lc
                   exit
                endif
             endif
          enddo
       endif
       !
       if (wold.eq.0) then
          write(mess,'(A,I6,A)') 'Channel ',jc, ' has zero weight'
          hbeam%r3d(:,:,kb) = 0
          hdirty%r3d(:,:,kb) = 0
          walls(kb) = 0.0
          if (nb.eq.1) then
             call map_message(seve%e,rname,mess)
             error = .true.
          else
             call map_message(seve%w,rname,mess)
          endif
          cycle
       else
          wall = 1e-3/sqrt(wold)
          !!write(mess,'(a,i6,a)') 'Plane ',ic,' Natural '
          !!call prnoise('UV_MAP',trim(mess),wall,rms)
          walls(kb) = wall
       endif
       !
       ! Compute the weights from this
       if (do_weig) 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)
          if (local_error)  then
             error = .true.
             cycle
          endif
          !    print *,ic,'doweig',w_v
          !    read(5,*) toto
          !
          ! 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
          !!print *,ic,'dotape'
       else
          call map_message(seve%i,rname,'Reusing weights')
          w_weight = r_weight
       endif
       !
       ! Re-normalize the weights and re-count the noise
       wall = sump(nv,w_weight)
       if (wall.ne.wold) then
          call scawei (nv,w_weight,w_w,wall)
          wall = 1e-3/sqrt(wall)
          !!write(mess,'(a,i6,a)') 'Plane ',ic,' Expected '
          !!call prnoise('UV_MAP',trim(mess),wall,rms)
          walls(kb) = wall
       endif
       !
       ! Then compute the Dirty Beam
       local_freq = gdf_uv_frequency(huv, dble(ic))
       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)
       !!print *,ic,'docoor'
       !
       ! 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)
       !!print *,ic,'dofft'
       !
       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 *,ic,'BEAM ',nx,ny,beam(nx/2+1,ny/2+1)
       !!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)
          print *,'Local freq ',local_freq
          print *,'KZ, LX, LY ', kz,lx,ly, ' nx,ny ',nx,ny, ' NS ',ns
          call gagout('E-UV_MAP,  Inconsistent pixel size')
          !      read(5,*) ians
          !      if (ians.eq.1) then
          !        print *,tfgrid(kz+1,:,ly/2)
          !      endif
          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)
       !!print *,ic,'docorr'
       !
       ! Write beam
       hbeam%r3d(:,:,kb) = beam
       !!print *,ic,'Done Beam ',kc,nc
       ! --- Done 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,nd)
          ! Write the subset
          kc = ic-fcol+iz
          hdirty%r3d(:,:,kc) = beam
       enddo
       !
       !$  elapsed_e = omp_get_wtime()
       elapsed = elapsed_e - elapsed_s
       write(mess,103) 'End plane ',kc,' Time ',elapsed &
            & ,' Thread ',ithread
       call map_message(seve%d,rname,mess)
       if (do_weig .and. nb.eq.1) then
          do_weig = .false.
          r_weight = w_weight
       endif
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    !$ if (nb.gt.1) call omp_set_num_threads(othread)
    if (error) return
    !
    call gag_cpu(cpu1)
    if (jfield.eq.0) then
       write(mess,102) 'Finished maps ',cpu1-cpu0
       call map_message(seve%i,rname,mess)
    endif
    !
    hdirty%gil%extr_words = def_extr_words  ! extrema computed
    hdirty%gil%minloc = 1
    hdirty%gil%maxloc = 1
    hdirty%gil%minloc(1:3) = minloc(hdirty%r3d)
    hdirty%gil%maxloc(1:3) = maxloc(hdirty%r3d)
    rma = hdirty%r3d(hdirty%gil%maxloc(1),hdirty%gil%maxloc(2),hdirty%gil%maxloc(3))
    rmi = hdirty%r3d(hdirty%gil%minloc(1),hdirty%gil%minloc(2),hdirty%gil%minloc(3))
    hdirty%gil%rmax = rma
    hdirty%gil%rmin = rmi
    !
    wall = maxval(walls(1:nb))
    if (jfield.eq.0) then
       mess = 'Expected'
    else
       write(mess,'(A,I0,A)') 'Field ',jfield,'; Expected'
    endif
    call prnoise(rname,trim(mess),wall,rms)
    hdirty%gil%noise = wall
    !
    ! Delete scratch space
    error = .false.
    if (nb.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)
103 format(a,i5,a,f9.2,a,i2,a,i2)
  end subroutine many_beams_para
  !
subroutine mos_inverse(n,weight,thre)
  !----------------------------------------------------------------------
  !
  !----------------------------------------------------------------------
  integer, intent(in) :: n
  real, intent(inout) :: weight(n)
  real, intent(in) :: thre
  !
  integer :: i
  !
  do i=1,n
    if (weight(i).ge.thre) then
      weight(i) = 1.0/weight(i)
    else
      weight(i) = 10.0
    endif
  enddo
end subroutine mos_inverse
!
subroutine mos_addsq(n,nf,weight,lobe)
  !----------------------------------------------------------------------
  !
  !----------------------------------------------------------------------
  integer, intent(in) :: n                      ! Size of arrays
  integer, intent(in) :: nf                     ! Number of fields
  real, intent(inout) :: weight(n)              ! Total weight
  real, intent(in) :: lobe(nf,n)                ! Primary beam array
  !
  integer :: i,if
  !
  do i=1,n
    do if=1,nf
      weight(i) = weight(i)+lobe(if,i)*lobe(if,i)
    enddo
  enddo
end subroutine mos_addsq
!
subroutine mosaic_loadfield(visi,np,nv,ixoff,iyoff,nf,doff,voff,uvmax,uvmin)
  !----------------------------------------------------------------------
  ! Load field coordinates into work arrays after sorting.
  !----------------------------------------------------------------------
  integer, intent(in)  :: np                   ! Size of a visibility
  integer, intent(in)  :: nv                   ! Number of visibilities
  real, intent(in) :: visi(np,nv)              ! Input visibilities
  integer, intent(in)  :: ixoff                ! X pointer
  integer, intent(in)  :: iyoff                ! Y pointer
  integer, intent(out) :: nf                   ! Number of fields
  real(kind=4), intent(out), allocatable :: doff(:,:)  ! Fields offsets
  integer, intent(out), allocatable :: voff(:)  ! Fields visibility offsets
  real, intent(inout) :: uvmax    ! Maximum length
  real, intent(inout) :: uvmin    ! Minimum baseline
  !
  integer :: iv, mfi, nfi, ier
  real(4) :: uv
  real(kind=4), allocatable :: dtmp(:,:)
  integer, allocatable :: vtmp(:)
  !
  ! Scan how many fields
  nfi = 1
  mfi = 100
  uvmax = 0
  uvmin = 1e36
  !
  allocate(dtmp(2,mfi),vtmp(mfi),stat=ier)
  dtmp(1,1) = visi(ixoff,1)
  dtmp(2,1) = visi(iyoff,1)
  vtmp(1) = 1
  nfi = 1
  !
  ! Fields are ordered here, so any change is a new one
  do iv=2,nv
    if (visi(ixoff,iv).ne.dtmp(1,nfi) .or. &
      & visi(iyoff,iv).ne.dtmp(2,nfi) ) then
      !
      ! New field
      if (nfi.eq.mfi) then
        allocate(doff(2,nfi),voff(nfi),stat=ier)
        doff(:,:) = dtmp(:,:)
        voff(:) = vtmp(:)
        deallocate(dtmp,vtmp)
        mfi = 2*mfi
        allocate(dtmp(2,mfi),vtmp(mfi),stat=ier)
        dtmp(:,1:nfi) = doff(:,:)
        vtmp(1:nfi) = voff
        deallocate(doff,voff)
      endif
      !
      nfi = nfi+1
      dtmp(1,nfi) = visi(ixoff,iv)
      dtmp(2,nfi) = visi(iyoff,iv)
      vtmp(nfi) = iv
    endif
    !
    uv = visi(1,iv)**2 + visi(2,iv)**2
    if (uv.ne.0) then
      uvmax = max(uv,uvmax)
      uvmin = min(uv,uvmin)
    endif
    !
  enddo
  !
  ! And put everything in place
  nf = nfi
  allocate(doff(2,nf),voff(nf+1),stat=ier)
  doff(:,:) = dtmp(:,1:nfi)
  voff(1:nfi) = vtmp(1:nfi)
  ! And set the last one
  voff(nfi+1) = nv+1
  deallocate(dtmp)
  !
  uvmax = sqrt(uvmax)
  uvmin = sqrt(uvmin)
end subroutine mosaic_loadfield
end module uvmosaic_tool
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
