! Sblock is the Blocking factor
! Experience shows that the efficiency does not
! increase with large blocking factors. Values of order
! 16 are often sufficient and even optimal.
!   Huge values (e.g. 1024) yield a penalty.
! This drives from the fact that gridding is essentially
! memory access limited, so page fault dominate.
! In the presence of Multi-Threading, a good policy is
! be to have the number of blocks being a multiple of
! the number of threads.
!
!
subroutine one_beam_para (rname,map,huv,hbeam,hdirty,   &
     &    nx,ny,nu,nv,uvdata,   &
     &    w_mapu, w_mapv, w_grid, w_weight, w_v, do_weig,    &
     &    wcol,mcol,wfft,sblock,cpu0,error,uvmax)
  use gkernel_interfaces
  use mapping_interfaces, except_this=>one_beam_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
  !   one single beam for all channels.
  !
  ! 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) :: w_mapu(nx)      ! U grid coordinates
  real, intent(inout) :: w_mapv(ny)      ! V grid coordinates
  real, intent(inout) :: w_grid(nx,ny)   ! Gridding space
  real, intent(inout) :: w_weight(nv)    ! Weight of visibilities
  real, intent(inout) :: w_v(nv)         ! V values
  logical, intent(inout) :: do_weig
  !
  real, intent(inout) :: wfft(*)     ! Work space
  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
  !
  real ubias,vbias,ubuff(4096),vbuff(4096)
  common /conv/ ubias,vbias,ubuff,vbuff ! To be saved
  !
  integer :: nc   ! Number of channels
  integer :: nd   ! Size of data
  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 vref,voff,vinc
  real(kind=4) :: loff,boff
  integer ndim, nn(2), i, lx, ly
  integer istart,iblock,nblock,kz,iz,kkz
  integer blc(4),trc(4)
  character(len=message_length) :: chain
  !
  real rms, null_taper(4)
  complex, allocatable :: ftbeam(:,:)
  complex, allocatable :: tfgrid(:,:,:)
  real, allocatable :: w_xgrid(:),w_ygrid(:), w_w(:)
  integer(kind=8) :: ilong
  !
  integer :: ithread, nthread
  !$ integer(kind = OMP_lock_kind) :: lck
  real(8) :: elapsed_s, elapsed_e, elapsed
  real :: local_wfft(2*max(nx,ny))
  !
  data blc/4*0/, trc/4*0/
  !------------------------------------------------------------------------
  !
  ! Code:
  nd = nx*ny
  nc = huv%gil%nchan
  !
  ! 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, ubuff, ubias)
  call convfn (ctypy, yparm, vbuff, 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)
  !
  ! Load V values and original Weights
  icol = 3*wcol + 7
  allocate(w_w(nv),stat=ier)
  call dovisi (nu,nv,uvdata,w_v,w_w,icol)
  !
  ! Compute weights
  !
  if (do_weig) then
    call doweig (nu,nv,   &
       &    uvdata,   &          ! Visibilities
       &    1,2,   &             ! U, V pointers
       &    wcol,   &            ! Weight channel
       &    map%uniform(1),   &  ! Uniform UV cell size
       &    w_weight,   &        ! Weight array
       &    map%uniform(2),   &  ! Fraction of weight
       &    w_v,              &  ! V values
       &    error)
    if (error)  return
    !
    ! 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
    do_weig = .false.
  else
    call map_message(seve%i,rname,'Reusing weights')
  endif
  null_taper = 0
  ! For test
  !  else
  !    null_taper = map%taper
  !  endif
  !
  call gag_cpu(cpu1)
  write(chain,102) 'Finished weighting CPU ',cpu1-cpu0
  call map_message(seve%i,rname,chain)
  !
  wall = 0
  do iv=1,nv
    if (w_w(iv).gt.0) then
       wall = wall + w_w(iv)
    endif
  enddo
  if (wall.eq.0.0) then
    write(chain,101) 'Plane ',wcol,' has Zero weight'
    call map_message(seve%e,rname,chain)
    error = .true.
    return
  else
    !
    ! Noise definition
    wall = 1e-3/sqrt(wall)
    call prnoise(rname,'Natural',wall,rms)
    !
    ! Re-normalize the weights and re-count the noise
    call scawei (nv,w_weight,w_w,wall)
    wall = 1e-3/sqrt(wall)
    call prnoise(rname,'Expected',wall,rms)
  endif
  deallocate(w_w)
  !
  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
  call docoor (lx,-map%uvcell(1),w_mapu)
  call docoor (ly,map%uvcell(2),w_mapv)
  !
  ! Optimize SBLOCK now, allowing some additional memory if NBLOCK small
  if (sblock.gt.0) then
    nblock = (nc+sblock-1)/sblock
    kz = mod(nc,sblock)
    if (kz.ne.0 .and. kz.lt.(sblock/(nblock+1))) then
      if (nblock.ne.1) nblock = nblock-1
    endif
    sblock = (nc+nblock-1)/nblock
    kz = min(sblock,nc)
  else
    kz = nc
    nblock = 1
  endif
  !
  ! Get FFT's work space
  write(chain,101) 'Using a blocking factor of ',sblock,' planes'
  call map_message(seve%i,rname,chain)
  allocate (tfgrid(kz+1,lx,ly),ftbeam(nx,ny),stat=ier)
  ndim = 2
  nn(1) = nx
  nn(2) = ny
  call fourt_plan(ftbeam,nn,ndim,-1,1)
  !
  ! Prepare grid correction,
  !
  allocate(w_xgrid(nx),w_ygrid(ny),stat=ier)
  call grdtab (ny, vbuff, vbias, w_ygrid)
  call grdtab (nx, ubuff, 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 = 2
  hbeam%gil%dim(1) = nx
  hbeam%gil%dim(2) = ny
  hbeam%gil%dim(3) = 1
  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%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%gil%majo = 0.0
  hbeam%loca%size = nx*ny
  hbeam%char%type = 'GILDAS_IMAGE'
  !
  ! 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%gil%noise = wall
  hdirty%char%unit = 'Jy/beam'
  hdirty%char%type = 'GILDAS_IMAGE'
  hdirty%loca%size = nx*ny*nc
  !
  ! Loop over blocks
  !$ call omp_init_lock(lck)
  !
  kkz = kz
  !$OMP PARALLEL DEFAULT(none) &
  !$OMP PRIVATE(iblock,istart,kz,blc,trc)  &
  !$OMP PRIVATE(tfgrid,ftbeam) &  ! Big arrays
  !$OMP SHARED(nblock, sblock, kkz, nu,nv,nx,ny,nc,nd,fcol,lx,ly, lck,nthread) &
  !$OMP SHARED(w_mapu,w_mapv,map,null_taper) &
  !$OMP SHARED(ubias,vbias,ubuff,vbuff) &
  !$OMP SHARED(nn,ndim,hbeam,hdirty,rname) &
  !$OMP SHARED(w_grid,w_xgrid,w_ygrid,w_v,w_weight,uvdata, wfft) &
  !$OMP PRIVATE(rmi,rma,imi,ima,ilong,chain) &
  !$OMP SHARED(cpu0,cpu1) PRIVATE(elapsed_s, elapsed_e, elapsed, ithread)
  !
  !$OMP MASTER
  nthread = 1
  !$  nthread = omp_get_num_threads()
  if (nblock.lt.nthread) then
    nblock = min(nthread,nc)
    sblock = (nc+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)
    kkz = sblock
  endif
  !$OMP END MASTER
  !$OMP BARRIER
  !
  !$OMP DO
  do iblock = 1,nblock
    !$ elapsed_s = omp_get_wtime()
    !$ ithread = omp_get_thread_num()
    !$ if (iblock.eq.1) call omp_set_lock(lck)
    !
    istart = fcol+(iblock-1)*sblock
    blc(3) = (iblock-1)*kkz+1
    kz = min (sblock,nc-sblock*(iblock-1))
    trc(3) = blc(3)-1+kz
    !
    ! This is the power-hungry routine...
    call dofft (nu,nv,   &   ! Size of visibility array
         &        uvdata,   &      ! Visibilities
         &        1,2,   &         ! U, V pointers
         &        istart,   &      ! First channel to map
         &        kz,lx,ly,   &    ! Cube size
         &        tfgrid,   &      ! FFT cube
         &        w_mapu,w_mapv,   &   ! U and V grid coordinates
         &        map%support,map%uvcell,null_taper,   &    ! Gridding parameters
         &        w_weight,w_v,   &    ! Weight array
         &        ubias,vbias,ubuff,vbuff,map%ctype)
    !
    ! Should one beam per block be created, this test can be
    ! easily modified
    if (iblock.eq.1) then
      call map_message(seve%i,rname,'Creating beam ')
      !
      call extracs(kz+1,nx,ny,kz+1,tfgrid,ftbeam,lx,ly)
      call fourt  (ftbeam,nn,ndim,-1,1,wfft)
      call cmtore (ftbeam,hbeam%r3d(:,:,1),nx,ny)
      !
      ! Compute Grid correction and Free the Grid lock
      ! Normalization factor is applied to grid correction,
      ! for further use on beam and channel maps.
      call dogrid (w_grid,w_xgrid,w_ygrid,nx,ny,hbeam%r3d(:,:,1))
      !$ call omp_unset_lock(lck)
      !
      ! Normalize and Free beam
      call docorr (hbeam%r3d(:,:,1),w_grid,nd)
      rma = -1e38
      rmi = 1e38
      call domima (hbeam%r3d(:,:,1),rmi,rma,imi,ima,nd)
      hbeam%gil%extr_words = def_extr_words          ! extrema computed
      hbeam%gil%rmax = rma
      hbeam%gil%rmin = rmi
      ilong = imi
      call gdf_index_to_where (ilong,hbeam%gil%ndim,hbeam%gil%dim,hbeam%gil%minloc)
      ilong = ima
      call gdf_index_to_where (ilong,hbeam%gil%ndim,hbeam%gil%dim,hbeam%gil%maxloc)
      !
      !$ elapsed_e = omp_get_wtime()
      elapsed = elapsed_e - elapsed_s
      write(chain,102) 'Finished Beam, Elapsed ',elapsed
      call map_message(seve%i,rname,chain)
      call map_message(seve%i,rname,'Creating map file ')
    endif
    !
    ! Wait for gridding correction to be computed
    !$  call omp_set_lock(lck)
    ! but free lock immediately, as no further waiting is needed.
    !$  call omp_unset_lock(lck)
    ! In general, the time spent here is negligible,
    ! so Parallel Nesting is not needed,
    ! but this is not always the case...
    !$OMP PARALLEL DEFAULT(none) &
    !$OMP & PRIVATE(i,iz,ftbeam,local_wfft) &
    !$OMP & SHARED(lck,nx,ny,nd,nn,ndim,lx,ly,iblock,kz,kkz) &
    !$OMP & SHARED(hdirty,w_grid,tfgrid)
    !$OMP DO
    do i=1,kz
      iz = i+(iblock-1)*kkz
      call extracs(kz+1,nx,ny,i,tfgrid,ftbeam,lx,ly)
      call fourt  (ftbeam,nn,ndim,-1,1,local_wfft)
      call cmtore (ftbeam,hdirty%r3d(:,:,iz),nx,ny)
      call docorr (hdirty%r3d(:,:,iz),w_grid,nd)
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    !$  elapsed_e = omp_get_wtime()
    elapsed = elapsed_e - elapsed_s
    write(chain,103) 'End planes ',blc(3),trc(3),' Time ',elapsed &
      & ,' Block ',iblock,' Thread ',ithread
    call map_message(seve%i,rname,chain)
  enddo
  !$OMP END DO
  !$OMP END PARALLEL
  !$  call omp_destroy_lock(lck)
  !
  call gag_cpu(cpu1)
  write(chain,102) 'Finished maps ',cpu1-cpu0
  call map_message(seve%i,rname,chain)
  !
  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
  !  !
  ! Delete scratch space
  error = .false.
  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,' to ',i5,a,f9.2,a,i2,a,i2)
end subroutine one_beam_para
!
subroutine one_beam_serial (rname,map,huv,hbeam,hdirty,   &
     &    nx,ny,nu,nv,uvdata,   &
     &    w_mapu, w_mapv, w_grid, w_weight, w_v, do_weig,    &
     &    wcol,mcol,wfft,sblock,cpu0,error,uvmax)
  use gkernel_interfaces
  use mapping_interfaces, except_this=>one_beam_serial
  use clean_def
  use image_def
  use gbl_message
  !------------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Compute a map from a CLIC UV Sorted Table
  !   by Gridding and Fast Fourier Transform, with
  !   one single beam for all channels.
  !
  ! 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) :: w_mapu(nx)      ! U grid coordinates
  real, intent(inout) :: w_mapv(ny)      ! V grid coordinates
  real, intent(inout) :: w_grid(nx,ny)   ! Gridding space
  real, intent(inout) :: w_weight(nv)    ! Weight of visibilities
  real, intent(inout) :: w_v(nv)         ! V values
  logical, intent(inout) :: do_weig
  !
  real, intent(inout) :: wfft(*)     ! Work space
  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
  !
  real ubias,vbias,ubuff(4096),vbuff(4096)
  common /conv/ ubias,vbias,ubuff,vbuff ! To be saved
  !
  integer :: nc   ! Number of channels
  integer :: nd   ! Size of data
  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 vref,voff,vinc
  real(kind=4) :: loff,boff
  integer ndim, nn(2), i, lx, ly
  integer istart,iblock,nblock,kz,iz,kkz
  integer blc(4),trc(4)
  character(len=message_length) :: chain
  !
  real rms, null_taper(4)
  complex, allocatable :: ftbeam(:,:)
  complex, allocatable :: tfgrid(:,:,:)
  real, allocatable :: w_xgrid(:),w_ygrid(:), w_w(:)
  integer(kind=8) :: ilong
  !
  integer ithread
  real :: local_wfft(2*max(nx,ny))
  !
  data blc/4*0/, trc/4*0/
  !------------------------------------------------------------------------
  !
  ! Code:
  nd = nx*ny
  nc = huv%gil%nchan
  !
  ! 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, ubuff, ubias)
  call convfn (ctypy, yparm, vbuff, 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)
  !
  ! Load V values and original Weights
  icol = 3*wcol + 7
  allocate(w_w(nv),stat=ier)
  call dovisi (nu,nv,uvdata,w_v,w_w,icol)
  !
  ! Compute weights
  !
  if (do_weig) then
    call doweig (nu,nv,   &
       &    uvdata,   &          ! Visibilities
       &    1,2,   &             ! U, V pointers
       &    wcol,   &            ! Weight channel
       &    map%uniform(1),   &  ! Uniform UV cell size
       &    w_weight,   &        ! Weight array
       &    map%uniform(2),   &  ! Fraction of weight
       &    w_v,              &  ! V values
       &    error)
    if (error)  return
    !
    ! 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
    do_weig = .false.
  else
    call map_message(seve%i,rname,'Reusing weights')
  endif
  null_taper = 0
  ! For test
  !  else
  !    null_taper = map%taper
  !  endif
  !
  call gag_cpu(cpu1)
  write(chain,102) 'Finished weighting CPU ',cpu1-cpu0
  call map_message(seve%i,rname,chain)
  !
  wall = 0
  do iv=1,nv
    if (w_w(iv).gt.0) then
       wall = wall + w_w(iv)
    endif
  enddo
  if (wall.eq.0.0) then
    write(chain,101) 'Plane ',wcol,' has Zero weight'
    call map_message(seve%e,rname,chain)
    error = .true.
    return
  else
    !
    ! Noise definition
    wall = 1e-3/sqrt(wall)
    call prnoise(rname,'Natural',wall,rms)
    !
    ! Re-normalize the weights and re-count the noise
    call scawei (nv,w_weight,w_w,wall)
    wall = 1e-3/sqrt(wall)
    call prnoise(rname,'Expected',wall,rms)
  endif
  deallocate(w_w)
  !
  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
  call docoor (lx,-map%uvcell(1),w_mapu)
  call docoor (ly,map%uvcell(2),w_mapv)
  !
  ! Optimize SBLOCK now, allowing some additional memory if NBLOCK small
  if (sblock.gt.0) then
    nblock = (nc+sblock-1)/sblock
    kz = mod(nc,sblock)
    if (kz.ne.0 .and. kz.lt.(sblock/(nblock+1))) then
      if (nblock.ne.1) nblock = nblock-1
    endif
    sblock = (nc+nblock-1)/nblock
    kz = min(sblock,nc)
  else
    kz = nc
    nblock = 1
  endif
  !
  ! Get FFT's work space
  write(chain,101) 'Using a blocking factor of ',sblock,' planes'
  call map_message(seve%i,rname,chain)
  allocate (tfgrid(kz+1,lx,ly),ftbeam(nx,ny),stat=ier)
  ndim = 2
  nn(1) = nx
  nn(2) = ny
  call fourt_plan(ftbeam,nn,ndim,-1,1)
  !
  ! Compute FFT's
  call dofft (nu,nv,   &       ! Size of visibility array
       &    uvdata,   &          ! Visibilities
       &    1,2,   &             ! U, V pointers
       &    fcol,   &            ! First channel to map
       &    kz,lx,ly,   &        ! Cube size
       &    tfgrid,   &          ! FFT cube
       &    w_mapu,w_mapv,   &   ! U and V grid coordinates
       &    map%support,map%uvcell,null_taper,   &    ! Gridding parameters
       &    w_weight,w_v,   &    ! Weight array + V Visibilities
       &    ubias,vbias,ubuff,vbuff,map%ctype)
  call gag_cpu(cpu1)
  write(chain,102) 'Finished gridding CPU ',cpu1-cpu0
  call map_message(seve%i,rname,chain)
  !
  ! Make beam, not normalized
  call gdf_copy_header(huv,hbeam,error)
  hbeam%gil%dopp = 0    ! Nullify the Doppler factor
  !
  hbeam%gil%ndim = 2
  hbeam%gil%dim(1) = nx
  hbeam%gil%dim(2) = ny
  hbeam%gil%dim(3) = 1
  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%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%gil%majo = 0.0
  hbeam%loca%size = nx*ny
  hbeam%char%type = 'GILDAS_IMAGE'
  call map_message(seve%i,rname,'Creating beam ')
  !
  call extracs(kz+1,nx,ny,kz+1,tfgrid,ftbeam,lx,ly)
  !
  ! For debugging
  !      call sic_descriptor('ffta',desc,found)
  !      if (found) then
  !         jpd = pointer(desc%addr,memory)
  !         call r4tor4 (memory(ipf),memory(jpd),2*nx*ny)
  !      endif
  !
  call fourt  (ftbeam,nn,ndim,-1,1,wfft)
  call cmtore (ftbeam,hbeam%r3d(:,:,1),nx,ny)
  !
  ! Compute grid correction,
  ! Normalization factor is applied to grid correction, for further
  ! use on channel maps.
  !
  allocate(w_xgrid(nx),w_ygrid(ny),stat=ier)
  call grdtab (ny, vbuff, vbias, w_ygrid)
  call grdtab (nx, ubuff, ubias, w_xgrid)
  call dogrid (w_grid,w_xgrid,w_ygrid,nx,ny,   &
       &    hbeam%r3d(:,:,1))
  !
  ! Normalize and Free beam
  call docorr (hbeam%r3d(:,:,1),w_grid,nd)
  rma = -1e38
  rmi = 1e38
  call domima (hbeam%r3d(:,:,1),rmi,rma,imi,ima,nd)
  hbeam%gil%extr_words = def_extr_words          ! extrema computed
  hbeam%gil%rmax = rma
  hbeam%gil%rmin = rmi
  ilong = imi
  call gdf_index_to_where (ilong,hbeam%gil%ndim,hbeam%gil%dim,hbeam%gil%minloc)
  ilong = ima
  call gdf_index_to_where (ilong,hbeam%gil%ndim,hbeam%gil%dim,hbeam%gil%maxloc)
  !
  ! For debugging
  !      call sic_descriptor('fftb',desc,found)
  !      if (found) then
  !         jpd = pointer(desc%addr,memory)
  !         call r4toc4 (memory(ipy),memory(jpd),nx*ny)
  !         call fourt (memory(jpd),nn,ndim,1,0,wfft)
  !      endif
  !
  call gag_cpu(cpu1)
  write(chain,102) 'Finished beam CPU ',cpu1-cpu0
  call map_message(seve%i,rname,chain)
  !
  ! Create image (in order l m v )
  call map_message(seve%i,rname,'Creating map file ')
  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%gil%noise = wall
  hdirty%char%unit = 'Jy/beam'
  hdirty%char%type = 'GILDAS_IMAGE'
  hdirty%loca%size = nx*ny*nc
  !
  !
  ! Make maps with grid correction
  rmi = 1e38
  rma = -1e38
  blc(3) = 1
  trc(3) = kz
  iz = 0
  !
  do i=1,kz
     iz = i
     call extracs(kz+1,nx,ny,i,tfgrid,ftbeam,lx,ly)
     call fourt  (ftbeam,nn,ndim,-1,1,local_wfft)
     call cmtore (ftbeam,hdirty%r3d(:,:,iz),nx,ny)
     call docorr (hdirty%r3d(:,:,iz),w_grid,nd)
  enddo
  call gag_cpu(cpu1)
  write(chain,103) 'Finished planes ',blc(3),trc(3),' CPU ',cpu1-cpu0
  call map_message(seve%i,rname,chain)
  !
  ! Proceed with further planes
  if (kz.lt.nc) then
     kkz = kz
     do iblock = 2,nblock
        istart = fcol+(iblock-1)*sblock
        blc(3) = blc(3)+kz
        kz = min (sblock,nc-sblock*(iblock-1))
        trc(3) = blc(3)-1+kz
        call dofft (nu,nv,   &   ! Size of visibility array
             &        uvdata,   &      ! Visibilities
             &        1,2,   &         ! U, V pointers
             &        istart,   &      ! First channel to map
             &        kz,lx,ly,   &    ! Cube size
             &        tfgrid,   &      ! FFT cube
             &        w_mapu,w_mapv,   &   ! U and V grid coordinates
             &        map%support,map%uvcell,null_taper,   &    ! Gridding parameters
             &        w_weight,w_v,   &    ! Weight array
             &        ubias,vbias,ubuff,vbuff,map%ctype)
        do i=1,kz
           iz = i+(iblock-1)*kkz
           call extracs(kz+1,nx,ny,i,tfgrid,ftbeam,lx,ly)
           call fourt  (ftbeam,nn,ndim,-1,1,local_wfft)
           call cmtore (ftbeam,hdirty%r3d(:,:,iz),nx,ny)
           call docorr (hdirty%r3d(:,:,iz),w_grid,nd)
        enddo
        call gag_cpu(cpu1)
        write(chain,103) 'Finished planes ',blc(3),trc(3),   &
             &        ' CPU ',cpu1-cpu0
        call map_message(seve%i,rname,chain)
     enddo
  endif
  call gag_cpu(cpu1)
  write(chain,102) 'Finished maps ',cpu1-cpu0
  call map_message(seve%i,rname,chain)
  !
  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
  !  !
  ! Delete scratch space
  error = .false.
  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,' to ',i5,a,f9.2)
end subroutine one_beam_serial
!
