!
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 gkernel_interfaces
  use mapping_interfaces, except_this=>many_beams_para
  use clean_def
  use image_def
  use gbl_message
  !$ use omp_lib
  !------------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Compute a map from a CLIC UV Sorted Table
  !   by Gridding and Fast Fourier Transform, with
  !   a different beam per channel.
  !
  ! Input :
  ! a precessed UV table, sorted in V, ordered in
  ! (U,V,W,D,T,iant,jant,nchan(real,imag,weig))
  ! 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, intent(inout), target :: 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
  ! Global variables:
  !
  real(kind=8), parameter :: clight=299792458d-6 ! Frequency in  MHz
  !
  type (gridding) :: conv
  !
  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
  real(kind=8) :: freq
  integer ctypx,ctypy
  integer icol,lcol,fcol,imi,ima,iv
  real rmi,rma,wall,cpu1
  real xparm(10),yparm(10)
  real(8) :: vref,voff,vinc
  real(kind=4) :: loff,boff
  integer ndim, nn(2), i, lx, ly, kz1
  integer istart,iblock,nblock,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(:)
  integer(kind=8) :: ilong
  real uvcell(2)
  real support(2)
  real(8) local_freq
  !
  integer :: ithread, othread, nthread, ians
  real(8) :: elapsed_s, elapsed_e, elapsed
  !
  real :: toto
  logical :: local_error
  !------------------------------------------------------------------------
  !
  ! Code:
  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(chain,'(a,i6,a)') 'Processing ',ns,' channels per beam'
    call map_message(seve%w,rname,chain)
  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(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(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,chain) &
  !$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(chain,'(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,chain)
        error = .true.
      else
        call map_message(seve%w,rname,chain)
      endif
      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 (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(chain,'(a,i6,a)') 'Plane ',ic,' Expected '
      !!call prnoise('UV_MAP',trim(chain),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(chain,103) 'End plane ',kc,' Time ',elapsed &
      & ,' Thread ',ithread
    call map_message(seve%d,rname,chain)
    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(chain,102) 'Finished maps ',cpu1-cpu0
    call map_message(seve%i,rname,chain)
  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
    chain = 'Expected'
  else
    write(chain,'(A,I0,A)') 'Field ',jfield,'; Expected'
  endif
  call prnoise(rname,trim(chain),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
  !
101 format(a,i6,a)
102 format(a,f9.2)
103 format(a,i5,a,f9.2,a,i2,a,i2)
end subroutine many_beams_para
