subroutine sub_alma (   &
     &    l_method,l_hdirty,l_hresid,l_hclean,   &
     &    l_hbeam,l_hprim,l_tfbeam,l_list,   &
     &    c_method,c_hdirty,c_hresid,c_hclean,   &
     &    c_hbeam,c_hprim,c_tfbeam,c_list,   &
     &    error,tcc)
  use gkernel_interfaces
  use mapping_interfaces, except_this=>sub_alma
  use clean_def
  use image_def
  use gbl_message
  !--------------------------------------------------------------
  ! @ private
  !
  ! MAPPING   Clean/Mosaic
  !     Perfom a CLEAN based on all CLEAN algorithms,
  !     except the Multi Resolution which requires a different tool
  !     Works for mosaic also, except for the Multi Scale clean
  !     (not yet implemented for this one, but feasible...)
  !--------------------------------------------------------------
  type (clean_par), intent(inout) :: l_method, c_method
  type (gildas), intent(inout)  :: l_hdirty, l_hbeam, l_hresid, l_hprim
  type (gildas), intent(inout)  :: l_hclean
  type (gildas), intent(inout)  :: c_hdirty, c_hbeam, c_hresid, c_hprim
  type (gildas), intent(inout)  :: c_hclean
  real, intent(inout) :: l_tfbeam(l_hbeam%gil%dim(2),l_hbeam%gil%dim(3),l_hbeam%gil%dim(1))
  real, intent(inout) :: c_tfbeam(c_hbeam%gil%dim(2),c_hbeam%gil%dim(3),c_hbeam%gil%dim(1))
  logical, intent(inout) :: error
  type (cct_par), intent(inout) :: tcc(l_method%m_iter)
  integer, intent(in) :: l_list(:)
  integer, intent(in) :: c_list(:)
  !
  real, pointer :: c_dirty(:,:)    ! Dirty map
  real, pointer :: c_resid(:,:)    ! Iterated residual
  real, pointer :: c_clean(:,:)    ! Clean Map
  real, pointer :: c_dprim(:,:,:)  ! Primary beam
  real, pointer :: c_dbeam(:,:,:)  ! Dirty beam (per field)
  real, pointer :: c_weight(:,:)
  !
  real, pointer :: l_dirty(:,:)    ! Dirty map
  real, pointer :: l_resid(:,:)    ! Iterated residual
  real, pointer :: l_clean(:,:)    ! Clean Map
  real, pointer :: l_beam(:,:) ! Beam for fit
  real, pointer :: l_dprim(:,:,:)  ! Primary beam
  real, pointer :: l_dbeam(:,:,:)  ! Dirty beam (per field)
  real, pointer :: l_weight(:,:)
  !
  real, allocatable :: w_fft(:) ! TF work area
  complex, allocatable :: w_work(:,:)  ! Work area
  complex, allocatable :: c_work(:,:)  ! Expansion of residual
  real, allocatable :: r_work(:,:) ! Expansion of residual
  type(cct_par), allocatable :: w_comp(:)
  real, allocatable, target :: sc_beam(:,:,:)
  real, allocatable :: w_resid(:,:)
  !
  character(len=*), parameter :: rname='SUB_ALMA'
  !
  integer iplane,ibeam
  integer nx,ny,np,mx,my,mp,nc,kx,ky
  integer ip, ier
  real l_max, c_max
  logical do_fft, ok
  character(len=80) :: chain
  character(len=2) ans
  integer nker,mker
  parameter (mker=11)
  real smooth
  real, allocatable :: kernel(:,:),kernels(:,:,:)
  real noise,value,scale,fhat,long,compact
  !
  error = .false.
  do_fft = .true.
  !
  ! Local variables
  nx = l_hclean%gil%dim(1)
  ny = l_hclean%gil%dim(2)
  np = l_hprim%gil%dim(1)
  mx = c_hbeam%gil%dim(1)
  my = c_hbeam%gil%dim(2)
  mp = c_hprim%gil%dim(1)
  nc = nx*ny
  !
  allocate (w_work(nx,ny),r_work(nx,ny),c_work(mx,my), &
       & w_fft(max(nx,ny)),w_comp(nc), stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error on ALMA arrays')
    error = .true.
    return
  endif
  !
  ! Smoothed version of the Compact images
  allocate (sc_beam(mx,my,mp),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error on ACA arrays')
    error = .true.
    return
  endif
  ! Global residuals
  allocate (w_resid(nx,ny),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error on residuals')
    error = .true.
    return
  endif
   !
  ! Some global pointers
  l_dprim => l_hprim%r3d
  l_dbeam => l_hbeam%r3d
  l_weight=> l_method%weight(:,:,1)
  c_dprim => c_hprim%r3d
  c_dbeam => c_hbeam%r3d       ! To begin with
  c_weight=> c_method%weight(:,:,1)
  !
  ! Relative noise contributions
  long = l_hdirty%gil%noise**2
  compact = c_hdirty%gil%noise**2
  scale = long+compact
  long = long/scale
  compact = compact/scale
  !
  ! Initialize the kernel
  smooth = c_method%smooth
  if (smooth.eq.0) then
     nker = 1
  else
     nker = mker
  endif
  allocate (kernels(nker,nker,mp),kernel(nker,nker),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error on Kernels')
    error = .true.
    return
  endif
  call init_kernel(kernel,nker,nker,smooth)
  !
  ! Initialize smoothed beams
  do ip=1,mp
     call smooth_kernel (c_dbeam(:,:,ip),sc_beam(:,:,ip),   &
          &      mx,my,nker,nker,kernel)
  enddo
  !
  ! Renormalize the beams. Have some difficulty here, because the
  ! factor isn't quite the same for each primary beam...
  !
  kx = mx/2+1
  ky = my/2+1
  noise = 0.0
  do ip=1,mp
    value = 1.0/sc_beam(kx,ky,ip)
    noise = noise + value
    sc_beam(:,:,ip) = sc_beam(:,:,ip) * value
    kernels(:,:,ip) = kernel*value
  enddo
  scale = noise/float(mp)      ! Kernel scaling factor
  kernel= kernel * scale       ! Mean smoothing kernel ...
  noise = sqrt(scale*compact/long) ! Mean noise RATIO
  !!
  !!      CALL SMOOTH_MASK (SC_MASK,C_METHOD%MASK,MX,MY,KERNEL,NKER)
  !
  ! Move pointer towards the Smoothed Compact Beams
  ! This allow to perform a "normal" deconvolution with the Smoothed
  ! Compact Beam
  c_hbeam%r3d => sc_beam
  !
  ! Loop here if needed
  do iplane = l_method%first, l_method%last
    l_method%flux = 0.0
    c_method%flux = 0.0
    l_method%n_iter= 0
    c_method%n_iter= 0
    !
    l_method%iplane = iplane
    c_method%iplane = iplane
    call beam_plane(l_method,l_hbeam,l_hdirty)
    ibeam = l_method%ibeam
    !
    ! Local aliases
    l_dirty => l_hdirty%r3d(:,:,iplane)
    l_resid => l_hresid%r3d(:,:,iplane)
    l_clean => l_hclean%r3d(:,:,iplane)
    l_beam  => l_hbeam%r3d(:,:,ibeam)
    !
    c_dirty => c_hdirty%r3d(:,:,iplane)
    c_resid => c_hresid%r3d(:,:,iplane)
    c_clean => c_hclean%r3d(:,:,iplane)
    !
    ! Initialize to Dirty map
    l_resid = l_dirty
    !
    ! C_RESID is now the Smoothed Compact Residual
    call smooth_kernel(c_dirty,c_resid,mx,my,nker,nker,kernel)
    !NO!         CALL SMOOTH_MASKED(C_DIRTY,C_RESID,MX,MY,KERNEL,
    !!     $   NKER,C_METHOD%MASK)
    !
    ! Prepare beam parameters
    call get_clean (l_method, l_hbeam, l_beam, error)
    if (error) return
    call get_beam (l_method,l_hbeam,l_hresid,l_hprim,   &
        &        l_tfbeam,w_work,w_fft,fhat,error)
    if (error) return
    !
    call get_beam (c_method,c_hbeam,c_hresid,c_hprim,   &
        &        c_tfbeam,w_work,w_fft,fhat,error)
    if (error) return
    !
    ! Apply the Weight
    l_resid = l_resid * l_weight
    c_resid = c_resid * c_weight
    call mrc_plot(c_weight,mx,my,1,'Weight')
    !
    ! Performs decomposition into components:
    ! Only one major cycle per iteration, with a limited number
    ! of components ?
    !
    l_method%ngoal = 1000
    c_method%ngoal = 100
    call sic_get_inte ('C_GOAL',c_method%ngoal,error)
    !
    ! Locate the maximum of the Compact & Normal images
    l_max = amaxlst (l_method,l_list,l_resid,nx,ny)
    c_max = amaxlst (c_method,c_list,c_resid,mx,my)
    ok = l_max.gt.l_method%ares .or. c_max.gt.c_method%ares
    do while (ok)
      !
      ! Plot for debug
      if (l_method%pcycle) then
        call mrc_plot(c_resid,mx,my,2,'Compact')
        call mrc_plot(l_resid,nx,ny,3,'Long')
      endif
      !
      ! NOISE is the Noise RATIO (mean value over the beams)
      !
      if (l_max.gt.c_max/noise) then
        write(chain,*) 'LONG baselines ',   &
            &          l_max,c_max/noise,noise
        call gagout(chain)
        if (l_method%qcycle) then
          call sic_wpr('WAIT ? ',ans)
        endif
        !
        ! Find components in LONG baseline image
        call one_cycle90 (l_method,l_hclean,   &   !
            &          l_clean,   &   ! Final CLEAN image
            &          l_dbeam,   &   ! Dirty beams
            &          l_resid,nx,ny,   & ! Residual and size
            &          l_tfbeam, w_work,   &  ! FT of dirty beam + Work area
            &          w_comp, nc,         &  ! Component storage + Size
            &          l_method%beam0(1),l_method%beam0(2),   &   ! Beam center
            &          l_method%patch(1),l_method%patch(2),   &
            &          l_method%bgain,l_method%box,   &
            &          w_fft,   &     ! Work space for FFTs
            &          tcc,   &       ! Component table
            &          l_list, l_method%nlist,   & ! Search list
            &          np,   &        ! Number of fields
            &          l_dprim,   &   ! Primary beams
            &          l_weight,   &  ! Weight
            &          l_max)
        !
        ! Define component type
        tcc(c_method%n_iter+1:l_method%n_iter)%type = 0
        ! Remove from COMPACT baselines
        call remove_inother(c_method,c_resid,mx,my,   &
            &          c_tfbeam, w_fft,mp,c_dprim,c_weight,   &
            &          tcc,c_method%n_iter+1,l_method%n_iter,nx,ny,   &
            &          kernel, nker)
        ! Define number of iterations
        c_method%n_iter = l_method%n_iter
        c_method%flux = l_method%flux
      else
        write (chain,*) 'COMPACT baselines ',   &
            &          l_max,c_max/noise,noise
        call gagout(chain)
        if (l_method%qcycle) then
          call sic_wpr('WAIT ? ',ans)
        endif
        !
        ! Find components in COMPACT baseline image
        call one_cycle90 (c_method,c_hclean,   &   !
            &          c_clean,   &   ! Final CLEAN image
            &          sc_beam,   &   ! (Smoothed) Dirty beams
            &          c_resid,mx,my,          &    ! Residual and size
            &          c_tfbeam, w_work,       &    ! FT of dirty beam + Work area
            &          w_comp, nc,             &    ! Component storage + Size
            &          c_method%beam0(1),c_method%beam0(2),   &   ! Beam center
            &          c_method%patch(1),c_method%patch(2),   &   ! Patch
            &          c_method%bgain,c_method%box,   &
            &          w_fft,    &    ! Work space for FFTs
            &          tcc,      &     ! Component table
            &          c_list, c_method%nlist,   & ! Search list
            &          mp,       &    ! Number of fields
            &          c_dprim,  &    ! Primary beams
            &          c_weight, &    ! Weight
            &          c_max)
        ! Define component type
        tcc(l_method%n_iter+1:c_method%n_iter)%type = 1
        ! Remove from LONG baselines
        call remove_inother(l_method,l_resid,nx,ny,   &
            &          l_tfbeam, w_fft, np,l_dprim,l_weight,   &
            &          tcc,l_method%n_iter+1,c_method%n_iter,mx,my,   &
            &          kernel, nker)
        ! Define number of components
        l_method%n_iter = c_method%n_iter
        l_method%flux = c_method%flux
      endif
      ! Stop if done
      l_max = amaxlst (l_method,l_list,l_resid,nx,ny)
      c_max = amaxlst (c_method,c_list,c_resid,mx,my)
      ok = l_max.gt.l_method%ares .or. c_max.gt.c_method%ares
      if (l_method%n_iter.ge.l_method%m_iter) ok = .false.
    enddo
    !
    ! Add clean components and residuals to produce clean map
    ! Note that the Kernel is still scaled in the same way as before
    if (l_method%n_iter.ne.0) then
      call alma_make90 (l_method, l_hclean, c_hclean,   &
           &        tcc, kernel, nker)
    else
      l_clean = 0
    endif
    !
    ! Which residual should be added ?...
    ! We don't want to add noise, but to combine it properly...
    ! We may need to go to the full combined gridding business here...
    l_clean = l_clean + l_resid * l_weight * long
    c_clean = c_resid * c_weight * compact
    call expand (nx,ny,r_work,w_work,mx,my,c_clean,c_work,w_fft)
    l_clean = l_clean + r_work
  enddo
end subroutine sub_alma
!
function amaxlst (method,list,resid,nx,ny)
  use clean_def
  use mapping_interfaces, only : maxlst
  !-----------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !-----------------------------------------------------
  real amaxlst      ! intent(out)
  type (clean_par), intent(inout) :: method
  integer, intent(in) :: nx,ny
  integer, intent(in) :: list(:)
  real, intent(in) :: resid(nx,ny)
  !
  real maxc, minc, maxabs
  integer imin,imax,jmin,jmax
  !
  call maxlst (resid,nx,ny,list,method%nlist,   &
       &    maxc,imax,jmax,minc,imin,jmin)
  if (method%n_iter.lt.method%p_iter) then
    maxabs=abs(maxc)
  elseif ( abs(maxc).lt.abs(minc) ) then
    maxabs=abs(minc)
  else
    maxabs=abs(maxc)
  endif
  amaxlst = maxabs
end function amaxlst
!
subroutine one_cycle90 (method,head,   &
     &    clean,beam,resid,nx,ny,tfbeam,fcomp,   &
     &    wcl,mcl,ixbeam,iybeam,ixpatch,iypatch,bgain,   &
     &    box, work, tcc, list, nl, nf, primary, weight, maxabs)
  use clean_def
  use image_def
  use gbl_message
  use mapping_interfaces, except_this=>one_cycle90
  !----------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Major cycle loop according to B.Clark idea
  !----------------------------------------------------------------------
  type (clean_par), intent(inout) :: method
  type (gildas), intent(in) :: head
  !
  integer, intent(in) ::  nf,nx,ny,mcl,nl
  real, intent(inout) ::  clean(nx,ny)
  real, intent(inout) ::  resid(nx,ny)
  real, intent(in) ::     beam(nx,ny,nf)
  real, intent(inout) ::  tfbeam(nx,ny,nf)     ! T.F. du beam  Complex ?
  complex, intent(inout) :: fcomp(nx,ny)       ! T.F. du vecteur modification
  type(cct_par), intent(inout) ::  wcl(mcl)
  real, intent(in) ::  bgain                   ! Maximum sidelobe level
  integer, intent(in) ::  ixbeam, iybeam       ! Beam maximum position
  integer, intent(in) ::  ixpatch, iypatch     ! Beam patch radius
  integer, intent(in) ::  box(4)               ! Cleaning box
  real, intent(inout) ::  work(*)                 ! Work space for FFT
  type(cct_par), intent(inout) :: tcc(method%m_iter) ! Clean components array
  integer, intent(in) ::  list(nl)
  !
  real, intent(in) ::  primary(nf,nx,ny)       ! Primary beams
  real, intent(in) ::  weight (nx,ny)
  !
  real    maxabs               !max et min de la carte, absolute
  real    borne                !fraction de la carte initiale
  real    limite               !intensite minimum des pts retenus
  real    clarkl
  !!      REAL FLUX                          !Total clean flux density
  integer ncl                  !nb de pts reellement retenus
  logical fini                 !critere d'arret
  logical converge             ! Indique la conv par acc de flux
  integer kcl
  character(len=message_length) :: chain
  character(len=*), parameter :: rname = 'CLARK'
  !
  ! Maximum residual is already located, MAXABS
  borne= max(method%fres*maxabs,method%ares)
  fini = maxabs.lt.borne
  !
  ! ONE Major cycle
  !
  ! Define minor cycle limit
  limite = max(maxabs*bgain,0.8*borne)
  clarkl = maxabs*bgain
  !!      PRINT *,'Limits ',MAXABS,LIMITE,CLARKL
  !
  kcl = mcl
  !
  ! Select points of maximum strength and load them in
  call choice (   &
       &    resid,   &           ! Current residuals
       &    nx,ny,   &           ! image size
       &    list, nl,   &        ! Search list
       &    limite,   &          ! Detection threshold
       &    kcl,   &             ! Maximum number of candidates
       &    wcl,   &             ! Selected candidate components
       &    ncl,   &             ! Selected Number of components
       &    maxabs, method%ngoal)
  !
  if (ncl.gt.0) then
     write(chain,100) 'Selected ',ncl,' points above ',limite
     call map_message(seve%i,rname,chain)
     !
     ! Make minor cycles
     call minor_cycle90 (method,   &
          &      wcl,          &    ! Original candidate components
          &      ncl,          &    ! Number of candidates
          &      beam,nx,ny,   &    ! Dirty beams and Size
          &      ixbeam,iybeam,   & ! Beam center
          &      ixpatch,iypatch,   &   ! Beam patch
          &      clarkl,limite,   &
          &      converge,   &      !
          &      tcc,   &           ! Cumulated components
          &      nf, primary, weight, method%trunca,   &
          &      method%flux,   &   ! Total Flux
          &      method%pflux, next_flux90)
     !
     ! Remove all components by FT : RESID = RESID - BEAM # WCL(*,4)
     call remisajour (nx*ny,   &    ! Total size
          &      clean,   &         ! CLEAN map used as work space
          &      resid,   &         ! Updated residuals
          &      tfbeam,   &        ! Beam TF
          &      fcomp,   &         ! Work space for Component TF
          &      wcl,     &         ! Clean flux values
          &      ncl,   &           ! Number of Clean Components
          &      nx,ny,   &         ! Map size
          &      work,   &          ! FFT work space
          &      nf, primary, weight, method%trunca)
     write (chain,101)  'Cleaned ',method%flux,' Jy with ',   &
          &      method%n_iter,' clean components'
     call map_message(seve%i,rname,chain)
  else
     ! No component found: finish...
     write(chain,101) 'No points selected above ',limite
     call map_message(seve%i,rname,chain)
  endif
  write(chain,102)  'CLEAN found ',method%flux,' Jy in ',   &
       &    method%n_iter,' clean components'
  call map_message(seve%i,'CLEAN',chain)
  !
100 format (a,i6,a,1pg10.3,a)
101 format (a,1pg10.3,a,i7,a)
102 format (a,1pg10.3,a,i7,a)
end subroutine one_cycle90
!
subroutine remove_inother(method,resid,nx,ny,tfbeam,wfft,   &
     &    np,primary,weight,   &
     &    tcc,first,last,mx,my,kernel,nker)
  use clean_def
  use gkernel_interfaces, only : fourt
  use mapping_interfaces, except_this=>remove_inother
  !--------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Support for ALMA deconvolution
  !--------------------------------------------------------------
  type (clean_par), intent(inout) :: method
  !
  integer, intent(in) ::  np,nx,ny,mx,my,nker,first,last
  real, intent(inout) ::  resid(nx,ny)
  real, intent(inout) ::  tfbeam(nx,ny,np)     ! T.F. du beam  Complex ?
  real, intent(in) :: primary(np,nx,ny)
  real, intent(in) :: weight(nx,ny)
  real, intent(inout) :: kernel(nker,nker)
  real, intent(inout) :: wfft(*)
  type(cct_par), intent(inout) :: tcc(last)
  !
  complex, allocatable :: icomp(:,:), ocomp(:,:)
  real, allocatable :: clean(:,:), prim(:,:), sky(:,:)
  real, allocatable :: ricomp(:,:),rocomp(:,:)
  real wtrun,val,fact
  integer k,ndim,nn(2),ip,ix,iy,ier
  integer jx,jy,xfact,yfact,firstx,lastx,firsty,lasty
  logical comp
  character(len=2) :: ans
  !
  wtrun = method%trunca
  ndim = 2
  nn(1) = nx
  nn(2) = ny
  !
  allocate (ocomp(nx,ny),stat=ier)
  allocate (icomp(mx,my),stat=ier)
  allocate (clean(nx,ny),stat=ier)
  allocate (ricomp(mx,my),stat=ier)
  allocate (rocomp(nx,ny),stat=ier)
  allocate (sky(nx,ny),stat=ier)
  allocate (prim(nx,ny),stat=ier)
  !
  comp = mx.gt.nx
  fact = float(mx*my)/float(nx*ny)
  xfact = nx/mx
  yfact = ny/my
  !
  ! Optimized by using CLEAN to store sum of components before multiplying
  ! by the weights to subtract from the Residuals
  clean = 0.0
  ricomp = 0.0
  do k=first,last
    ix = tcc(k)%ix
    iy = tcc(k)%iy
    val = tcc(k)%value * fact
    if (tcc(k)%type.eq.0) then
      ricomp(ix,iy) = ricomp(ix,iy) + val
    else
      call add_kernel (ricomp,mx,my,val,ix,iy,nker,nker,kernel)
    endif
  enddo
  !
  ! Add compression and/or expansion
  if (comp) then
    call compress(mx,my,ricomp,icomp,nx,ny,rocomp,ocomp,wfft)
  else
    !
    ! Expand by XFACT & YFACT
    rocomp = 0.0
    do k=first,last
      ix = tcc(k)%ix
      iy = tcc(k)%iy
      val = tcc(k)%value * fact
      lastx = xfact*ix
      lasty = yfact*iy
      firstx = lastx-xfact+1
      firsty = lasty-yfact+1
      do jy=firsty,lasty
        do jx=firstx,lastx
          rocomp(jx,jy) = rocomp(jx,jy)+val
        enddo
      enddo
      !!            CALL ADD_KERNEL (RICOMP,MX,MY,VAL,IX,IY,KERNEL,NKER)
    enddo
  endif
  sky = rocomp
  if (method%pcycle) then
    call mrc_plot(weight,nx,ny,1,'Weight')
    call mrc_plot(resid,nx,ny,2,'Resid')
    call mrc_plot(sky,nx,ny,3,'Sky')
    !         if (method%qcycle) call sic_wpr('Continue',ans)
  endif
  !
  ! Loop on the fields
  do ip=np,1,-1
    prim = primary(ip,:,:)
    if (method%pcycle) call mrc_plot(prim,nx,ny,1,'Primary')
    !
    ! Multiply by Complete Primary beam...
    rocomp = sky*prim
    !
    ! Convolve with dirty beam
    ocomp = cmplx(rocomp,0.0)
    call fourt(ocomp,nn,ndim,-1,0,wfft)
    rocomp = tfbeam(:,:,ip)
    ocomp = ocomp*rocomp
    call fourt(ocomp,nn,ndim,1,1,wfft)
    rocomp = real(ocomp)
    !
    ! Multiply by Truncated Primary beam now
    where (prim.lt.wtrun)
      prim = 0
    end where
    rocomp = rocomp*prim
    if (method%pcycle) call mrc_plot(rocomp,nx,ny,3,'Comp...')
    clean(:,:) = clean + rocomp
  enddo
  if (method%pcycle) then
    !         if (method%qcycle) call sic_wpr('Continue',ans)
    call mrc_plot(clean,nx,ny,3,'Clean')
    call mrc_plot(resid,nx,ny,1,'Residu')
  endif
  resid(:,:) = resid - clean*weight
end subroutine remove_inother
!
subroutine add_primker (clean,nx,ny,np,prim,value,kx,ky,kp,ker,nk)
  !-----------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Smooth an array using a kernel, with Primary Beams
  !   For ALMA deconvolution
  !-----------------------------------------------------------------------
  integer, intent(in) :: nx,ny,np             ! Image size
  real, intent(in) :: value                   ! Input value
  real, intent(inout) :: clean(nx,ny)         ! Summed output array
  real, intent(in) :: prim(np,nx,ny)
  integer, intent(in) :: kp                   ! Field
  integer, intent(in) :: kx,ky                ! Center of value
  integer, intent(in) :: nk                   ! Kernel size
  real, intent(in) :: ker(nk,nk)
  !
  integer i,j,lk,li,lj
  !
  if (nk.eq.1) then
    clean(kx,ky) = clean(kx,ky) + prim(kp,kx,ky)*value
  else
    lk = (nk-1)/2
    do j=ky-lk,ky+lk
      lj = j-ky+lk+1
      do i=kx-lk,kx+lk
        li = i-kx+lk+1
        clean(i,j) = clean(i,j) + prim(kp,i,j) *   &
              &          ker (li,lj) * value
      enddo
    enddo
  endif
end subroutine add_primker
!
subroutine alma_make90 (method, l_hclean, c_hclean,   &
     &    tcc, kernel,nker)
  use gkernel_interfaces, only : fourt
  use clean_def
  use image_def
  use mapping_gaussian_tool
  !-------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Make clean map
  !-------------------------------------------------------------
  integer, intent(in) :: nker
  real, intent(in) :: kernel(nker,nker)
  type (clean_par), intent(inout) :: method
  type (gildas), intent(inout) :: l_hclean, c_hclean
  type (cct_par), intent(in) :: tcc(method%n_iter)
  !
  real(8), parameter :: pi=3.141592653589793d0
  integer nx,ny,ix,iy,ic,ndim,nn(2),ier, iplane,mx,my
  real xinc, yinc,fact,val
  real, pointer :: l_clean(:,:), c_clean(:,:)
  real, allocatable :: wfft(:)
  complex, allocatable :: fcomp(:,:), c_work(:,:)
  !
  nx = l_hclean%gil%dim(1)
  ny = l_hclean%gil%dim(2)
  mx = c_hclean%gil%dim(1)
  my = c_hclean%gil%dim(2)
  iplane = method%iplane
  l_clean => l_hclean%r3d(:,:,iplane)
  c_clean => c_hclean%r3d(:,:,iplane)
  !
  allocate (wfft(2*max(nx,ny)),stat=ier)
  allocate (fcomp(nx,ny),stat=ier)
  allocate (c_work(mx,my),stat=ier)
  xinc = l_hclean%gil%convert(3,1)
  yinc = l_hclean%gil%convert(3,2)
  !
  ndim = 2
  nn(1) = nx
  nn(2) = ny
  !
  ! First pass for Compact Baselines
  c_clean = 0.0
  fact = float(nx*ny)/float(mx*my)
  do ic=1,method%n_iter
    if (tcc(ic)%type.ne.0) then
      ix = tcc(ic)%ix
      iy = tcc(ic)%iy
      val = tcc(ic)%value * fact
      call add_kernel (c_clean,mx,my,val,ix,iy,   &
           &        nker,nker,kernel)
    endif
  enddo
  !
  ! Expand the Compact Clean Components
  call expand (nx,ny,l_clean,fcomp,mx,my,c_clean,c_work,wfft)
  !
  ! Add the Long Baseline components
  do ic=1,method%n_iter
    if (tcc(ic)%type.eq.0) then
      ix = tcc(ic)%ix
      iy = tcc(ic)%iy
      val = tcc(ic)%value
      l_clean(ix,iy) = l_clean(ix,iy) + val
    endif
  enddo
  !
  ! Convolve by Gaussian
  fcomp = cmplx(l_clean,0.0)
  call fourt(fcomp,nn,ndim,-1,0,wfft)
  fact = method%major*method%minor*pi/(4.0*log(2.0))   &
       &    /abs(xinc*yinc)/(nx*ny)
  call mulgau(fcomp,nx,ny,   &
       &    method%major,method%minor,method%angle,   &
       &    fact,xinc,yinc)
  call fourt(fcomp,nn,ndim,1,1,wfft)
  l_clean = real(fcomp)
end subroutine alma_make90
