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 imager_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_atten(:,:)
  !
  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_atten(:,:)
  !
  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_atten => l_method%atten(:,:,1)
  c_dprim => c_hprim%r3d
  c_dbeam => c_hbeam%r3d       ! To begin with
  c_atten => c_method%atten(:,:,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 is not exactly 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_atten
    c_resid = c_resid * c_atten
    call mrc_plot(c_atten,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_atten,   &  ! 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_atten,   &
            &          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_atten, &    ! 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_atten,   &
            &          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 do not 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_atten * long
    c_clean = c_resid * c_atten * 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 imager_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 imager_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 and min of data, absolute max value
  real    borne                ! Fraction of initial data
  real    limite               ! Minimal intensity retained
  real    clarkl               ! Clark worry limit
  integer ncl                  ! Number of selected data points
  logical fini                 ! Stopping criterium 
  logical converge             ! Stop by flux convergence
  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 imager_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
  !
  wtrun = method%trunca
  ndim = 2
  nn(1) = nx
  nn(2) = ny
  !
  allocate (ocomp(nx,ny),icomp(mx,my),clean(nx,ny),ricomp(mx,my) &
    & ,rocomp(nx,ny),sky(nx,ny),prim(nx,ny),stat=ier)
  if (ier.ne.0) return
  !
  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 imager_interfaces, only : mulgau
  !-------------------------------------------------------------
  ! @ 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,-1)
  call fourt(fcomp,nn,ndim,1,1,wfft)
  l_clean = real(fcomp)
end subroutine alma_make90
