subroutine sub_alma_bis (   &
     &    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_bis
  use clean_def
  use image_def
  !--------------------------------------------------------------
  ! @ 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 :: w_cct(:,:)
  real, allocatable :: w_resid(:,:)
  !
  integer iplane,ibeam
  integer nx,ny,np,mx,my,mp,nc,kx,ky
  integer ip, ier, ix, iy
  real l_max, c_max
  logical do_fft, ok
  character(len=80) chain
  character(len=2) ans
  integer nker,mker
  parameter (mker=12)
  real smooth
  real, allocatable :: kernel(:,:)
  real noise,value,scale,fhat,long,compact
  !
  error = .false.
  do_fft = .true.
  print *,'Into SUB_ALMA_BIS '
  !
  ! 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),stat=ier)
  allocate (r_work(nx,ny),stat=ier)
  allocate (c_work(mx,my),stat=ier)
  allocate (w_fft(max(nx,ny)),stat=ier)
  allocate (w_comp(nc),stat=ier)
  !
  ! Global residuals
  allocate (w_resid(nx,ny),stat=ier)
  !
  ! 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
  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 = 4
    smooth = 3.0               ! Test
  elseif  (smooth.lt.4) then
    nker = 8
  else
    nker = mker
  endif
  allocate(kernel(nker,nker),stat=ier)
  call init_kernel(kernel,nker,nker,smooth)
  !
  noise = sqrt(compact/long)
  !
  ! Loop here if needed
  do iplane = l_method%first, l_method%last
    print *,'Starting loop ',iplane
    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 = c_dirty
    !
    ! 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
    call mrc_plot(c_weight,mx,my,1,'Weight')
    print *,'Beam gains ',l_method%bgain,c_method%bgain
    l_method%bgain = sqrt(l_method%bgain*c_method%bgain)
    l_resid = l_resid * l_weight
    c_resid = c_resid * c_weight
    !
    ! Performs decomposition into components:
    ! Only one major cycle per iteration, with a limited number
    ! of components ?
    !
    l_method%ngoal = 1000
    !
    ! Locate the maximum of the Compact & Normal images
    l_max = imaxlst (l_method,l_list,l_resid,nx,ny,ix,iy)
    c_max = imaxlst (c_method,c_list,c_resid,mx,my,ix,iy)
    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 .or.   &
         &        l_method%n_iter.gt.l_method%m_iter-nker**2) then
        print *,'LONG baselines ',l_max,c_max/noise,noise
        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_incompact(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)
        ! Define number of iterations
        c_method%n_iter = l_method%n_iter
        c_method%flux = l_method%flux
      else
        print *,'COMPACT baselines ',l_max,c_max/noise,noise
        if (l_method%qcycle) then
          call sic_wpr('WAIT ? ',ans)
        endif
        !
        ! Define the corresponding component list AND value
        call expand_kernel(c_method,mx,my,ix,iy,c_max,   &
            &          tcc,c_method%n_iter+1,l_method%n_iter,nx,ny,   &
            &          kernel, nker)
        !
        ! Remove List in Compact Baselines
        call remove_incompact(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)
        !
        ! Remove List in Long Baselines
        call remove_inlong(l_method,l_resid,nx,ny,   &
            &          l_tfbeam, w_fft,np,l_dprim,l_weight,   &
            &          tcc,c_method%n_iter+1,l_method%n_iter)
        !
        ! Define number of components
        c_method%n_iter = l_method%n_iter
        l_method%flux = c_method%flux
      endif
      ! Stop if done
      l_max = imaxlst (l_method,l_list,l_resid,nx,ny,ix,iy)
      c_max = imaxlst (c_method,c_list,c_resid,mx,my,ix,iy)
      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.
      if (sic_ctrlc()) 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_make (l_method, l_hclean, tcc)
    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)
    where (l_weight.lt.l_method%trunca)
      r_work = 0
    end where
    !!         L_CLEAN = L_CLEAN + R_WORK
  enddo
end subroutine sub_alma_bis
!
function imaxlst (method,list,resid,nx,ny,ix,jy)
  use clean_def
  !--------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Support for ALMA deconvolution
  !--------------------------------------------------------------
  real imaxlst  ! intent(out)
  type (clean_par), intent(in) :: method
  integer, intent(in) :: nx,ny
  integer, intent(out) :: ix,jy
  integer, intent(in) :: list(:)
  real, intent(in) :: resid(nx,ny)
  !
  real maxc, minc, maxabs
  integer i,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)
    ix = imax
    jy = jmax
  elseif ( abs(maxc).lt.abs(minc) ) then
    maxabs=abs(minc)
    ix = imin
    jy = jmin
  else
    maxabs=abs(maxc)
    ix = imax
    jy = jmax
  endif
  imaxlst = maxabs
end function imaxlst
!
subroutine remove_incompact(method,resid,nx,ny,tfbeam,wfft,   &
     &    np,primary,weight,tcc,first,last,mx,my)
  use gkernel_interfaces, only : fourt
  use clean_def
  !--------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Remove components in "compact" array
  !--------------------------------------------------------------
  type (clean_par), intent(inout) :: method
  !
  integer, intent(in) ::  np,nx,ny,mx,my,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)
  type(cct_par), intent(inout) :: tcc(last)
  real, intent(inout) :: wfft(*)
  !
  complex, allocatable :: icomp(:,:), ocomp(:,:)
  real, allocatable :: clean(:,:), prim(:,:), sky(:,:)
  real, allocatable :: ricomp(:,:),rocomp(:,:)
  real wtrun,val,fact
  integer i,j,k,ndim,nn(2),ip,ix,iy,ier
  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)
  !
  fact = float(mx*my)/float(nx*ny)
  !
  ! 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
    ricomp(ix,iy) = ricomp(ix,iy) + val
  enddo
  !
  ! Add compression
  call compress(mx,my,ricomp,icomp,nx,ny,rocomp,ocomp,wfft)
  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_incompact
!
subroutine remove_inlong(method,resid,nx,ny,tfbeam,wfft,   &
     &    np,primary,weight,tcc,first,last)
  use gkernel_interfaces, only : fourt
  use clean_def
  !--------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Remove components in "long baseline" array
  !--------------------------------------------------------------
  type (clean_par), intent(inout) :: method
  !
  integer, intent(in) ::  np,nx,ny,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)
  type(cct_par), intent(inout) :: tcc(last)
  real, intent(inout) :: wfft(*)
  !
  complex, allocatable :: icomp(:,:), ocomp(:,:)
  real, allocatable :: clean(:,:), prim(:,:), sky(:,:)
  real, allocatable :: ricomp(:,:),rocomp(:,:)
  real wtrun,val,fact
  integer i,j,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 (clean(nx,ny),stat=ier)
  allocate (rocomp(nx,ny),stat=ier)
  allocate (sky(nx,ny),stat=ier)
  allocate (prim(nx,ny),stat=ier)
  !
  ! Optimized by using CLEAN to store sum of components before multiplying
  ! by the weights to subtract from the Residuals
  clean = 0.0
  rocomp = 0.0
  do k=first,last
    ix = tcc(k)%ix
    iy = tcc(k)%iy
    val = tcc(k)%value
    rocomp(ix,iy) = rocomp(ix,iy) + val
  enddo
  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_inlong
!
subroutine expand_kernel(c_method,mx,my,ix,iy,c_max,   &
     &    tcc,first,last,nx,ny,kernel,nker)
  use clean_def
  ! @ private
  type (clean_par), intent(inout) :: c_method
  integer, intent(in) :: nx,ny
  integer, intent(in) :: mx,my
  integer, intent(in) :: ix,iy
  integer, intent(in) :: nker
  integer, intent(in) :: first
  integer, intent(inout) :: last
  real, intent(in) :: kernel(nker,nker)
  real, intent(in) :: c_max
  type (cct_par), intent(inout) :: tcc(*)
  !
  integer lk, i,j,lx,ly,xfact,yfact,nc
  real value
  !
  last = first+nker*nker-1
  !
  value = c_max * c_method%gain * c_method%weight(ix,iy,1)
  xfact = nx/mx
  yfact = ny/my
  !
  lx = xfact*(ix-1) + xfact/2
  ly = yfact*(iy-1) + yfact/2
  lk = (nker+1)/2
  nc = first
  !
  do j=1,nker
    do i=1,nker
      tcc(nc)%ix = lx-lk+i
      tcc(nc)%iy = ly-lk+j
      tcc(nc)%value = value*kernel(i,j)
      tcc(nc)%type = 0
      !!            print *,nc,tcc(nc)
      c_method%flux = c_method%flux + tcc(nc)%value
      if (c_method%pflux) then
         call draw(dble(nc),dble(c_method%flux))
         call gr_out
      endif
      nc = nc+1
    enddo
  enddo
  !
end subroutine expand_kernel
!
subroutine alma_make (method, l_hclean, tcc)
  use gkernel_interfaces, only : fourt
  use clean_def
  use image_def
  ! @ private
  type (clean_par), intent(inout) :: method
  type (gildas), intent(in) :: l_hclean
  type (cct_par), intent(in) :: tcc(method%n_iter)
  !
  real(8), parameter :: pi=3.141592653589793d0
  integer nx,ny,nc,ix,iy,ic,imax,ndim,nn(2),ier, iplane
  real xinc, yinc, fact, val
  real, pointer :: l_clean(:,:)
  real, allocatable :: wfft(:)
  complex, allocatable :: fcomp(:,:)
  !
  nx = l_hclean%gil%dim(1)
  ny = l_hclean%gil%dim(2)
  iplane = method%iplane
  l_clean => l_hclean%r3d(:,:,iplane)
  !
  allocate (wfft(2*max(nx,ny)),stat=ier)
  allocate (fcomp(nx,ny),stat=ier)
  xinc = l_hclean%gil%convert(3,1)
  yinc = l_hclean%gil%convert(3,2)
  !
  ndim = 2
  nn(1) = nx
  nn(2) = ny
  !
  ! Add the Long Baseline components
  l_clean = 0.0
  do ic=1,method%n_iter
    ix = tcc(ic)%ix
    iy = tcc(ic)%iy
    val = tcc(ic)%value
    l_clean(ix,iy) = l_clean(ix,iy) + val
  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_make
