subroutine v_size_r4_2(name,array,nn,err)
  use imager_interfaces, only : map_message
  use gbl_message
  ! @ public-mandatory
  character(len=*) :: name
  real, intent(in) :: array(:,:)
  integer, intent(in) :: nn(2)
  logical, intent(inout) :: err
  !
  integer i
  character(len=120) :: mess
  !
  write(mess,*) name//' expected ',nn,' Got ',ubound(array)
  call map_message(seve%d,'SIZECHECK',mess)
  do i=1,2
    if (ubound(array,i).ne.nn(i)) then
      err =.true.
      Print *,name//' 2 size error ',i,' got ',ubound(array,i),' expected ',nn(i)
    endif
  enddo
end subroutine v_size_r4_2
subroutine v_size_l4_2(name,array,nn,err)
  use imager_interfaces, only : map_message
  use gbl_message
  ! @ public-mandatory
  character(len=*) :: name
  logical, intent(in) :: array(:,:)
  integer, intent(in) :: nn(2)
  logical, intent(inout) :: err
  !
  integer i
  character(len=120) :: mess
  !
  write(mess,*) name//' expected ',nn,' Got ',ubound(array)
  call map_message(seve%d,'SIZECHECK',mess)
  do i=1,2
    if (ubound(array,i).ne.nn(i)) then
      err =.true.
      Print *,name//' 2 size error ',i,' got ',ubound(array,i),' expected ',nn(i)
    endif
  enddo
end subroutine v_size_l4_2
subroutine v_size_r4_3(name,array,nn,err)
  use imager_interfaces, only : map_message
  use gbl_message
  ! @ public-mandatory
  character(len=*) :: name
  real, intent(in) :: array(:,:,:)
  integer, intent(in) :: nn(3)
  logical, intent(inout) :: err
  !
  integer i
  !
  character(len=120) :: mess
  !
  write(mess,*) name//' expected ',nn,' Got ',ubound(array)
  call map_message(seve%d,'SIZECHECK',mess)
  do i=1,3
    if (ubound(array,i).ne.nn(i)) then
      err =.true.
      Print *,name//' 3 size error ',i,' got ',ubound(array,i),' expected ',nn(i)
    endif
  enddo
end subroutine v_size_r4_3
  !
subroutine major_multi90 (rname,method,head,   &
     &    beam,nx,ny,mx,my,            &
     &    dirty,resid,mask,clean,      &
     &    cct_list,siter,miter,limit,niter, &
     &    smask, sresid, trans, cdata, sbeam, &
     &    tfbeam, wfft, mcct, nker, kernel, &
     &    np, primary, weight)    ! For mosaics
  use gbl_ansicodes
  use imager_interfaces, except_this=>major_multi90
  use gkernel_interfaces
  use image_def
  use gbl_message
  use clean_def
  use clean_default
  use omp_control
  !$  use omp_lib
  !-----------------------------------------------------------------------
  ! @ public-mandatory
  !*
  ! IMAGER -- CLEAN Method MULTISCALE  
  !     Multi-Resolution CLEAN - with NS (parameter) scales
  !
  !     Algorithm  
  !     For each iteration, search at which scale the signal to noise
  !     is largest. Use the strongest S/N to determine the "component"
  !     intensity and shape at this iteration.
  !
  !     Restore the ("infinite" resolution) image from the list of location
  !     types, and intensities of the "components"
  !
  !     The noise level at each scale is computed from the Fourier transform
  !     of the smoothed dirty beams, since the FT is the weight distribution
  !     and the noise level is the inverse square root of the sum of the
  !     weights.
  !!
  !-----------------------------------------------------------------------
  character(len=*), intent(in) :: rname     !! Caller name
  type(clean_par), intent(inout) :: method  !! Clean method
  type(gildas), intent(inout) :: head       !! Unused, but here for consistency...
  real, intent(in)  :: beam(:,:,:)          !! Dirty beams
  integer, intent(in)  :: nx,ny             !! Beam sizes
  integer, intent(in)  :: mx,my             !! Image size
  integer, intent(in) :: np                 !! Number of Pointings
  integer, intent(in)  :: siter             !! Starting Iteration
  integer, intent(in)  :: miter             !! Maximum number of clean components
  integer, intent(out) :: niter             !! Number of found components
  real, intent(in)  :: dirty(:,:)           !! Dirty image
  real, intent(inout) :: resid(:,:)         !! Residual image (initialized to Dirty image)
  real, intent(inout) :: clean(:,:)         !! "CLEAN" image (not convolved yet)
  real, intent(in) :: weight(:,:)           !! Combined weights
  logical, intent(in)  :: mask(:,:)         !! Search area
  real, intent(in)  :: limit                !! Maximum residual
  real, intent(in)  :: tfbeam(:,:,:)        !! Real Beam FT. for final Clean restoration
  real, intent(inout) :: wfft(*)            !! Work space for FFT
  type(cct_lst), intent(inout) :: cct_list  !! Clean Component List
  integer, intent(out) :: nker(:)           !! Kernel sizes
  real, intent(out) :: kernel(:,:,:)        !! Smoothing kernel values
  real, intent(in) :: primary(np, mx, my)   !! Primary beams
  integer, intent(out) :: mcct              !! Number of separate Clean components
  real, intent(inout) ::  sbeam(:,:,:)      !! Smoothed beams workspace
  real, intent(inout) ::  sresid(:,:)       !! Smoothed residuals workspace
  real, intent(inout) ::  trans(:,:)        !! Translated beam workspace
  complex, intent(inout) ::  cdata(:,:)     !! Work array
  logical, intent(inout) ::  smask(:,:)     !! Smoothed mask workspace
  !
  ! Constants
  integer, parameter :: ms=3
  integer, parameter :: mk=11
  !
  ! Local ---
  integer :: dimcum, ncum, nchain
  integer :: nn(2), ndim, kx,ky
  integer :: is,i,j, oldis, goodis
  real, allocatable :: oldcum(:)
  real :: value, converge, sign, lastcum
  real :: maxa,flux,smooth,gain,maxsn,worry
  logical :: ok, plot, printout, interrupt
  character(len=message_length) :: chain
  character(len=24) :: string
  !
  ! Kernel related ones
  integer  :: ns                  ! Number of Kernels
  integer :: max_nker             ! Last kernel used
  real :: scale(ms)               ! Noise level for each beam - in ReadOnly
  real :: sn(ms)                  ! Signal / Noise - used in ReadOnly
  real :: gains(ms)               ! Gain per kernel 
  real :: fluxes(ms)              ! Cumulative flux per kernel
  real :: loss(ms)                ! Noise degradation factor...
  !
  integer :: ncase(ms)            ! Number of components per kernel case
  real :: bruit(ms)               ! Residual level for each kernel
  integer :: ix(ms),iy(ms)        ! Coordinates of each iteration maximum
  !
  integer :: nf                   ! Number of frequency planes (=1)
  integer :: ip                   ! Current pointing
  integer :: ic,nc                ! Current component and Number of components
  integer :: lx,ly                ! Current pixel and Offset from center
  real :: kcct(3,1,mk**2)         ! "Bulk" component decomposition
  real :: maxp                    ! Current Clean value
  integer :: counter
  integer :: clean_slow=0         ! Precision and Speed control code (for tests)
  integer :: step_iter            ! Printout every Step_Iter component
  logical :: error, detail
  logical :: debug=.false.
  logical :: err
  integer :: nnt(3)
  !
  integer :: fs,ls, ncount, mthread
  !
  ! Code ---
  !
  ! Verify array sizes
  nnt = [mx,my,1]
  err = .false.
  call v_size_r4_2('DIRTY',dirty,nnt,err)
  call v_size_r4_2('RESID',resid,nnt,err)
  call v_size_r4_2('CLEAN',clean,nnt,err)
  call v_size_r4_3('TFBEAM',tfbeam,nnt,err)
  call v_size_r4_2('SRESID',sresid,nnt,err)
  if (np.gt.1) call v_size_r4_2('WEIGHT',weight,nnt,err)
  call v_size_r4_2('TRANS',trans,nnt,err)
  call v_size_l4_2('SMASK',smask,nnt,err)
  nnt = [nx,ny,np]
  call v_size_r4_3('BEAM',beam,nnt,err)
  nnt = [nx,ny,3]
  call v_size_r4_3('SBEAM',sbeam,nnt,err)
  if (err) then
    call map_message(seve%e,rname,'Size error')
    error = .true.
    return
  endif
  !
  step_iter = multi_print
  if (multi_print.eq.0) step_iter = 1000
  !
  call sic_get_logi('DEBUG',debug,error)
  error = .false.
  call sic_get_inte('CLEAN_SLOW',clean_slow,error)
  clean_slow = min(clean_slow,3)
  if (clean_slow.lt.0) then
    call map_message(seve%w,rname,'Using approximate MultiScale method - Try CLEAN_SLOW = 0 for better result')
  else if (clean_slow.ne.0) then
    call map_message(seve%w,rname,"Speed set to CLEAN_SLOW "//char(clean_slow+ichar('0')))
  endif
  !
  dimcum = method%converge
  allocate(oldcum(max(1,dimcum)))
  !
  smooth = method%smooth
  gain = method%gain
  plot = method%pflux
  nker = method%nker
  printout = method%verbose  .or. debug ! Default behaviour
  gains = method%gains(1:ms)
  worry = method%worry
  !
  ! Initialize the kernel
  interrupt = .false.
  kernel = 0.0
  ns = 1
  nker(1) = 1
  kernel = 0.0
  kernel(1,1,1) = 1.0
  !
  nker = method%nker
  if (nker(2).gt.0) then
    call init_kernel(kernel(:,:,2),mk,nker(2),smooth)
    ns = 2
    if (nker(3).gt.0) then
      smooth = smooth**2
      call init_kernel(kernel(:,:,3),mk,nker(3),smooth)
      ns = 3
    endif
  endif
  max_nker = ns
  ncase(1:ms) = 0
  fluxes(:) = 0.0
  trans(:,:) = 0.0
  !
  ! Initialize smoothed beams & mask
  call smooth_mask (mask,smask,mx,my,nker(ns))
  !
  kx = nx/2+1
  ky = ny/2+1
  ! 
  ! Build an average dirty beam for mosaics
  sbeam(:,:,1) = beam(:,:,1)
  do ip=2,np
    sbeam(:,:,1) = sbeam(:,:,1) + beam(:,:,ip)
  enddo
  if (np.ne.1) sbeam(:,:,1) = sbeam(:,:,1)/np
  !
  ! Get the scale factors and sensitivity loss
  loss(1)  = 1.0
  scale(1) = 1.0
  ! 
  ! Use the average dirty beams to estimate these factors
  do is = 2,ns
    call smooth_kernel (sbeam(:,:,1),sbeam(:,:,is),nx,ny,mk,nker(is),kernel(:,:,is))
    value = 1.0/sbeam(kx,ky,is)
    loss(is) = sqrt(value)
    scale(is) = value
    sbeam(:,:,is) = sbeam(:,:,is)*value      ! Now normalized
    kernel(:,:,is) = kernel(:,:,is)*value    ! Corresponding Kernel
  enddo
  !
  write(chain,'(2(A,3(1X,F5.3)))') 'Scales ',scale,'; Noise loss ',loss
  call map_message(seve%i,rname,chain)
  !
  ! Main clean loop
  niter = siter-1      ! Start at siter
  ok = niter.lt.miter
  flux = 0.0
  !
  ! Initialize convergence test
  call amaxmask (resid,mask,mx,my,ix(1),iy(1))
  if (resid(ix(1),iy(1)).gt.0.0) then
    sign = 1.0
  else
    sign =-1.0
  endif
  ncum = 1
  converge = 0.0
  oldcum = 0.0
  oldis = 0
  goodis = 1   ! To prevent compiler warning only..
  maxsn = 0    ! Also
  sn =    0 ! Make sure they are all initialized
  !
  counter = 0
  ncount = 0
  if (clean_slow.lt.0) then
    ncount = -clean_slow ! Test
    clean_slow = -2
  endif
  !
  detail = .false.    ! Debug test message
  !
  mthread = 1
  !$  mthread = omp_get_max_threads()
  !$  if (omp_in_parallel()) then
  !$    if (omp_get_nested()) then
  !$      ! Further optimisation requires to know the number of Outer Threads
  !$      mthread = omp_inner_thread
  !$      if (omp_debug) Print *,'Already in parallel mode, Outer THREAD ',omp_outer_thread,' Inner ',omp_inner_thread
  !$    else
  !$      mthread = 1
  !$      if (omp_debug) Print *,'Already in parallel mode, Outer THREAD ',omp_outer_thread,' No Inner threads'
  !$    endif
  !$  else
  !$    mthread = omp_inner_thread
  !$    if (omp_get_nested()) then
  !$      if (omp_debug) Print *,'Activating nesting ',omp_get_max_threads(),' possible, used ',mthread
  !$    else
  !$      if (omp_debug) Print *,'No parallel, and No nesting either, ',mthread
  !$    endif
  !$  endif
  !
  do           ! For ever...
    if (ncount.eq.0) then
      fs = 1
      ls = ns
    else if (mod(counter,ncount).eq.0) then
      fs = 1
      ls = max_nker
      oldis = 0 ! Ensure printout can happen
    else
      fs = oldis
      ls = oldis
    endif
    counter = counter+1
    !
    ! Locate the Clean Component - The Smoothed Beams do not intervene here,
    ! only the Normalized Kernel and Smoothed Mask
    maxa = -1.0
    do is = fs,ls
      if (is.eq.1) then
        call amaxmask (resid,mask,mx,my,ix(1),iy(1))
        bruit(1) = resid(ix(1),iy(1))
      else
        !
        ! Smooth within (smoothed) mask
        call smooth_masked(mx,my,sresid,resid,smask,mk,nker(is),kernel(:,:,is))
        !
        ! Use MASK or SMASK, more or less at will...
        call amaxmask (sresid,mask,mx,my,ix(is),iy(is))
        bruit(is) = sresid(ix(is),iy(is))
      endif
      !
      if (debug) print *,is, 'Bruit ',bruit(is),' Loss ',loss(is)
      sn(is) = abs(bruit(is)/loss(is))
      if (sn(is).gt.maxa) then
        maxa = sn(is)
        goodis = is
      endif
    enddo
    !
    if (debug) then
      Print *,'Good ',goodis,'Bruit ',bruit,' Loss ',loss,' S/N ',sn  !Debug
      if (counter.lt.10) then
        is = goodis
        Print *,Counter,is,' IX IY ',ix(is),iy(is),' Resid ',sresid(ix(is),iy(is)),bruit(is) !Debug
      endif
    endif
    !
    if (niter.lt.siter) then
      maxsn = sn(goodis)
    endif
    !
    ! Check criterium
    ok = niter.lt.miter
    ok = ok .and. abs(bruit(1)).ge.limit
    if (.not.ok) exit
    if (sn(goodis).gt.maxsn) then
      if (niter.gt.2) then
        ok = .false.  ! Stop if S/N has degraded
        exit
      else
        maxsn = sn(goodis)
      endif
    endif
    maxsn = worry*sn(goodis)+(1.0-worry)*maxsn  ! Propagate S/N estimate
    if (debug) Print *,'Counter ',counter,' Maxsn ',maxsn,goodis,sn(goodis)
    !
    niter = niter+1
    if (niter.ge.cct_list%max_size) call cct_list%reallocate()
    !
    value = gains(goodis)*bruit(goodis)
    if (np.gt.1) then
      value = value * weight(ix(goodis),iy(goodis))    ! Convert to Clean component
    endif
    cct_list%cc(niter)%value = value*scale(goodis)     ! Scale the flux  
    cct_list%cc(niter)%ix = ix(goodis)
    cct_list%cc(niter)%iy = iy(goodis)
    cct_list%cc(niter)%size = -goodis   ! Kernel number
    cct_list%cur_size = niter
    !
    ! Do not Scale component flux : See Note Later (#1)
    flux = flux + value*scale(goodis)
    !
    ! Check flux stability - Switch to the accurate method when
    ! approaching convergence 
    if (dimcum.ne.0) then
      ! Keep last DIMCUM cumulative fluxes to test convergence
      oldcum(mod(niter,dimcum)+1) = flux
      lastcum = oldcum(mod(niter+1,dimcum)+1)
      converge = sign * (flux - lastcum) 
      if (clean_slow.lt.0) then
        if (abs((flux-lastcum)/flux).lt.0.05) then
          clean_slow = 0
          call map_message(seve%i,rname,'Switching to precise mode') 
          max_nker = 1
          oldis = 0
        endif
      endif 
    endif
    !
    ! Plot the new point
    ! detail = weight(ix(goodis),iy(goodis)).gt.2 ! Test
    if ((printout.and.(goodis.ne.oldis)).or.(mod(niter,step_iter).eq.0)) then
      if (goodis.eq.1) then
        write(chain,101) niter,ix(goodis),iy(goodis),   &
     &            c_red,sn(1),c_clear,sn(2),sn(3),bruit(goodis)*loss(goodis) &
     &            ,weight(ix(goodis),iy(goodis))
      elseif (goodis.eq.2) then
        write(chain,102) niter,ix(goodis),iy(goodis),   &
     &            sn(1),c_green,sn(2),c_clear,sn(3),bruit(goodis)*loss(goodis) &
     &            ,weight(ix(goodis),iy(goodis))
      elseif (goodis.eq.3) then
        write(chain,103) niter,ix(goodis),iy(goodis),   &
     &            sn(1),sn(2),c_blue,sn(3),c_clear,bruit(goodis)*loss(goodis) &
     &            ,weight(ix(goodis),iy(goodis))
      endif
      call map_message(seve%i,rname,chain)
    endif
    ! In all cases
    oldis = goodis
    ncase(goodis) = ncase(goodis)+1
    ! Scale cumulative flux : See Note Later
    fluxes(goodis) = fluxes(goodis) + value*scale(goodis)
    if (plot) then
      is = goodis
      call next_flux90(niter,flux,is)
    endif
    !
    ! Subtract from residual
    !
    maxa = -value  ! This is the Clean Component to be subtracted #1
    !
    ! Pixel offset in small beam (not in large map)
    kx = ix(goodis)-nx/2-1 
    ky = iy(goodis)-ny/2-1
    lx = ix(goodis)
    ly = iy(goodis)
    !
    if (np.eq.1) then
      !
      ! Translate appropriate beam
      !$OMP PARALLEL DEFAULT(none) NUM_THREADS(mthread) &
      !$OMP   &   SHARED(resid,sbeam)  &
      !$OMP   &   SHARED(mx,my,nx,ny,kx,ky,ip,maxa,goodis) &
      !$OMP   &   PRIVATE(i,j)
      !$OMP DO COLLAPSE(2)
      do j=max(1,ky+1),min(my,ny+ky)
        do i=max(1,kx+1),min(mx,nx+kx)
          resid(i,j) = resid(i,j) + maxa * sbeam(i-kx,j-ky,goodis)
        enddo
      enddo
      !$OMP ENDDO
      !$OMP END PARALLEL
    else
      if (clean_slow.ge.0) then
        !
        ! The accurate approach is to expand the Clean Component
        ! by the kernel, attenuate each new component by the
        ! primary beam, and subtract the list of Clean Components
        ! using the un-smoothed dirty beam
        !
        nf = 1 ! Only one frequency
        nc = 0 ! No previous component in, many out
        if (nker(goodis).eq.0) then
          nc = 1
          kcct(1,1,1) = lx !! ix(goodis)
          kcct(2,1,1) = ly !! iy(goodis)
          kcct(3,1,1) = maxa 
        else
          ! Use Large Region
          call spread_kernel (mx,my,nf,nc,kcct,maxa,lx,ly, &
            &   nker(goodis),kernel(:,:,goodis))
        endif
        ! !Print *,'LX LY ',lx,ly, 'MX MY ',mx,my,nker(goodis)
        ! !Print *,'NC out ',nc,goodis,maxa
        !
        ! The following sections are memory access limited
        ! Parallelism is inefficient there.
        select case(clean_slow)
        case(0)
          ! Fastest way ...
          do ip=1,np
            !
            if (nc.eq.1) then
              lx = kcct(1,1,1)
              ly = kcct(2,1,1)
              kx = lx-nx/2-1
              ky = ly-ny/2-1
              ! 
              ! Attenuate by primary beam 
              maxp = kcct(3,1,1) * primary(ip,lx,ly)
              ! Translate the original dirty beam
              !$OMP PARALLEL DEFAULT(none) NUM_THREADS(mthread) &
              !$OMP   &   SHARED(resid,beam,primary,weight) &
              !$OMP   &   SHARED(mx,my,nx,ny,kx,ky,ip,maxp) &
              !$OMP   &   PRIVATE(i,j)
              !$OMP DO COLLAPSE(2)
              do j=max(1,ky+1),min(my,ny+ky)
                do i=max(1,kx+1),min(mx,nx+kx)
                  resid(i,j) = resid(i,j) + & 
                  & maxp*beam(i-kx,j-ky,ip)*primary(ip,i,j)*weight(i,j)
                enddo
              enddo
              !$OMP ENDDO
              !$OMP END PARALLEL
              !
            else
              trans = 0.
              ! Translate the original dirty beam for each component
              do ic=1,nc
                lx = kcct(1,1,ic)
                ly = kcct(2,1,ic)
                kx = lx-nx/2-1
                ky = ly-ny/2-1
                ! Attenuate by primary beam 
                maxp = kcct(3,1,ic) * primary(ip,lx,ly)
                !$OMP PARALLEL DEFAULT(none) NUM_THREADS(mthread) &
                !$OMP   &   SHARED(trans,beam) &
                !$OMP   &   SHARED(mx,my,nx,ny,kx,ky,ip,maxp) &
                !$OMP   &   PRIVATE(i,j)
                !$OMP DO COLLAPSE(2)
                do j=max(1,ky+1),min(my,ny+ky)
                  do i=max(1,kx+1),min(mx,nx+kx)
                    trans(i,j) = trans(i,j) + beam(i-kx,j-ky,ip)*maxp
                  enddo
                enddo
                !$OMP ENDDO
                !$OMP END PARALLEL
              enddo
              ! 
              ! Remove from residual
              !$OMP PARALLEL DEFAULT(none) NUM_THREADS(mthread) &
              !$OMP   &   SHARED(resid,trans,primary,weight) &
              !$OMP   &   SHARED(mx,my,ip) PRIVATE(i,j)
              !$OMP DO COLLAPSE(2)
              do j=1,my
                do i=1,mx
                  resid(i,j) = resid(i,j) + & 
                  & trans(i,j)*primary(ip,i,j)*weight(i,j)
                enddo
              enddo
              !$OMP ENDDO
              !$OMP END PARALLEL
            endif
          enddo
          !
        case(1)
          ! Slightly slower (ratio depends on number of point sources)
          do ip=1,np
            trans = 0.
            ! Translate the original dirty beam for each component
            do ic=1,nc
              lx = kcct(1,1,ic)
              ly = kcct(2,1,ic)
              kx = lx-nx/2-1
              ky = ly-ny/2-1
              if (detail) Print *,IP,'IC ',IC,' KCCT ',KCCT(1:3,1,IC)
              ! Attenuate by primary beam 
              maxp = kcct(3,1,ic) * primary(ip,lx,ly)
              !$OMP PARALLEL DEFAULT(none) NUM_THREADS(mthread) &
              !$OMP   &   SHARED(trans,beam) &
              !$OMP   &   SHARED(mx,my,nx,ny,kx,ky,ip,maxp) &
              !$OMP   &   PRIVATE(i,j)
              !$OMP DO COLLAPSE(2)
              do j=max(1,ky+1),min(my,ny+ky)
                do i=max(1,kx+1),min(mx,nx+kx)
                  trans(i,j) = trans(i,j) + beam(i-kx,j-ky,ip)*maxp
                enddo
              enddo
              !$OMP ENDDO
              !$OMP END PARALLEL
            enddo
            ! 
            ! Remove from residual
            !$OMP PARALLEL DEFAULT(none) NUM_THREADS(mthread) &
            !$OMP   &   SHARED(trans,resid,primary,weight) &
            !$OMP   &   SHARED(mx,my,ip) PRIVATE(i,j)
            !$OMP DO COLLAPSE(2)
            do j=1,my
              do i=1,mx
                resid(i,j) = resid(i,j) + & 
                & trans(i,j)*primary(ip,i,j)*weight(i,j)
              enddo
            enddo
            !$OMP ENDDO
            !$OMP END PARALLEL
          enddo
        case(2)
          ! Slower
          do ic=1,nc
            lx = kcct(1,1,ic)
            ly = kcct(2,1,ic)
            kx = lx-nx/2-1
            ky = ly-ny/2-1
            do ip=1,np
              ! 
              ! Attenuate by primary beam 
              maxp = kcct(3,1,ic) * primary(ip,lx,ly)
              ! Translate the original dirty beam
              do j=max(1,ky+1),min(my,ny+ky)
                do i=max(1,kx+1),min(mx,nx+kx)
                  resid(i,j) = resid(i,j) + & 
                  & maxp*beam(i-kx,j-ky,ip)*primary(ip,i,j)*weight(i,j)
                enddo
              enddo
              ! 
            enddo
          enddo
          !        
        case (3)
          ! Really slow
          do ic=1,nc
            lx = kcct(1,1,ic)
            ly = kcct(2,1,ic)
            kx = lx-nx/2-1
            ky = ly-ny/2-1
            do ip=1,np
              trans = 0. !
              ! Translate the original dirty beam
              do j=max(1,ky+1),min(my,ny+ky)
                do i=max(1,kx+1),min(mx,nx+kx)
                  trans(i,j) = beam(i-kx,j-ky,ip) 
                enddo
              enddo
              ! 
              ! Attenuate by primary beam 
              maxp = kcct(3,1,ic) * primary(ip,lx,ly)
              ! 
              do j=1,my
                do i=1,mx
                  resid(i,j) = resid(i,j) + & 
                  & maxp*trans(i,j)*primary(ip,i,j)*weight(i,j)
                enddo
              enddo
            enddo
          enddo
          !
        end select
      else ! if (clean_slow.lt.0) then 
        !
        ! This code is incorrect for two reasons.
        !
        ! 1) Fundamental
        !   A smooth beam per pointing would not represent the properly attenuated
        !   Clean component list.
        !     It would only be an approximate solution, but which could work
        !   in a Minor / Major cycle, where the faster, but approximate
        !   solution is used in Minor Cycles, but the accurate version
        !   is used in Major Cycles by Fourier Transform.
        ! 2) Circumstancial (due to lazyness)
        !   We do not have a smoothed beam per pointing, but only one 
        !   so far.
        !
        ! Yet, it works surprisingly well by a combination of several reasons
        ! 1)  The code is correct for point sources
        ! 2)  The approximation is limited for Extended sources near a
        !     pointing center
        ! 3)  Dirty beams are reasonably similar from pointing to pointing
        !     so Smoothed beams too.
        ! 4)  The deconvolution method is self-correcting: improperly
        !     removed components are corrected later by components at
        !     a different scale ...
        ! 
        select case(clean_slow)
        !
        case (-2)
          ! Most efficient
          do ip=1,np
            ! 
            ! Globally attenuate by primary beam -- There is an issue here
            ! since normally each individual Clean Component should
            ! have a different attenuation
            !
            maxp = maxa * primary(ip,lx,ly)
            ! 
            !$OMP PARALLEL DEFAULT(none) NUM_THREADS(mthread) &
            !$OMP   &   SHARED(resid,sbeam,primary,weight) &
            !$OMP   &   SHARED(mx,my,nx,ny,kx,ky,ip,maxp,goodis) &
            !$OMP   &   PRIVATE(i,j)
            !$OMP DO COLLAPSE(2)
            do j=max(1,ky+1),min(my,ny+ky)
              do i=max(1,kx+1),min(mx,nx+kx)
                resid(i,j) = resid(i,j) + & 
                & maxp*sbeam(i-kx,j-ky,goodis)*primary(ip,i,j)*weight(i,j)
              enddo
            enddo
            !$OMP ENDDO
            !$OMP END PARALLEL
          enddo
          !
        case (-1)
          ! Slightly slower
          do ip=1,np
            trans = 0. !
            ! Translate the appropriate smoothed dirty beam
            !$OMP PARALLEL DEFAULT(none) NUM_THREADS(mthread) &
            !$OMP   &   SHARED(trans,sbeam) &
            !$OMP   &   SHARED(mx,my,nx,ny,kx,ky,goodis) &
            !$OMP   &   PRIVATE(i,j)
            !$OMP DO COLLAPSE(2)
            do j=max(1,ky+1),min(my,ny+ky)
              do i=max(1,kx+1),min(mx,nx+kx)
                trans(i,j) = sbeam(i-kx,j-ky,goodis) ! WRONG, should be IP dependent (one per pointing)
              enddo
            enddo
            !$OMP ENDDO
            !$OMP END PARALLEL
            ! 
            ! Globally attenuate by primary beam -- There is an issue here
            ! since normally each individual Clean Component should
            ! have a different attenuation
            !
            maxp = maxa * primary(ip,lx,ly)
            ! 
            !$OMP PARALLEL DEFAULT(none) NUM_THREADS(mthread) &
            !$OMP   &   SHARED(resid,trans,primary,weight) &
            !$OMP   &   SHARED(mx,my,nx,ny,kx,ky,ip,maxp) &
            !$OMP   &   PRIVATE(i,j)
            !$OMP DO COLLAPSE(2)
            do j=1,my
              do i=1,mx
                resid(i,j) = resid(i,j) + & 
                & maxp*trans(i,j)*primary(ip,i,j)*weight(i,j)
              enddo
            enddo
            !$OMP ENDDO
            !$OMP END PARALLEL
          enddo
          !
        end select
      endif
    endif
!
    if (dimcum.gt.0) ok = ok.and.(converge.ge.0.0)
    if (.not.ok) exit
    if (sic_ctrlc()) then
      interrupt = .true.
      exit
    endif
  enddo
  !
  if (niter.eq.miter) then
    string = 'iteration limit'
  else if (sn(goodis).gt.maxsn) then
    string = 'signal to noise stability'
  else if (dimcum.gt.0.and.converge.lt.0.0) then
    string = 'flux convergence'
  else if (interrupt) then
    string = 'User ^C interrupt'
  else
    string = 'residual limit'
  endif
  write(chain,104) 'Stopped by ',trim(string),niter,bruit(1),limit
  call map_message(seve%i,rname,chain)
  nchain = 1
  do is=1,ns
    write(chain(nchain:),105) is,ncase(is),fluxes(is)
    nchain = len_trim(chain)+2
  enddo
  call map_message(seve%i,rname,chain)
  !
  ! Done: RESTORATION Process now
  clean = 0.0
  !
  ! If CCT component flux are not scaled, use the Kernel as they are
  ! If they are scaled,  normalize them to 1 back again...
  !
  ! Here they ARE scaled (see comment #1 Above)
  !
  mcct = 0
  do i=1,niter
    value = cct_list%cc(i)%value
    kx = cct_list%cc(i)%ix
    ky = cct_list%cc(i)%iy
    is =  -nint(cct_list%cc(i)%size)
    if (is.le.1) then         ! May have Type = 0 if restarted      
      clean (kx,ky) = clean(kx,ky) + value
      mcct = mcct+1
    else
      value = value/scale(is)
      call add_kernel (clean,mx,my,value,kx,ky,mk,nker(is),kernel(:,:,is))
      mcct = mcct+nker(is)**2 ! Maximum value
    endif
  enddo
  !
  ! Final residual
  !
  if (np.eq.1) then
    ! This is only valid for a single field. 
    cdata = cmplx(clean,0.0)
    ndim = 2
    nn(1) = mx
    nn(2) = my
    call fourt(cdata,nn,ndim,-1,1,wfft)
    cdata = cdata*tfbeam(:,:,1)            ! Complex by Real multiplication
    call fourt(cdata,nn,ndim,1,1,wfft)
    resid = dirty-real(cdata)
  else  
    ! For mosaic, use the Weight - We already have the Residual here...
    ! resid = dirty-real(cdata)*weight
  endif
  !
  ! Convolution with clean beam is done outside
  if (debug) print *,'Returning'
  return
  !
  101   format(i6,i5,i5,a,' [',1pg11.4,'] ',a,1pg11.4,2x,1pg11.4,'  = ',   &
     &    1pg11.4,1pg11.4)
  102   format(i6,i5,i5,2x,1pg11.4,a,' [',1pg11.4,'] ',a,1pg11.4,'  = ',   &
     &    1pg11.4,1pg11.4)
  103   format(i6,i5,i5,2x,1pg11.4,2x,1pg11.4,a,' [',1pg11.4,'] = ',a,   &
     &    1pg11.4,1pg11.4)
  104   format(a,a,i6,1x,1pg11.4,1x,1pg11.4)
  105   format(('#',i0,' Ncct ',i0,' Flux ',1pg11.4))
  !
end subroutine major_multi90
!
subroutine expand_multi_cct(head,nker,kernel,nx,ny,ip,miter,flux,niter,tcc,dcct)
  use imager_interfaces, only : spread_kernel
  use gkernel_interfaces
  use image_def
  use clean_def
  !-----------------------------------------------------------------------------
  ! @ public-mandatory
  !*
  ! IMAGER  -- CLEAN Method MULTISCALE  
  !   Expand the MultiScale Clean Component List
  !!
  !-----------------------------------------------------------------------------
  type (gildas), intent(inout) :: head           !! Clean header
  integer, intent(in) :: nker(:)                 !! Kernel sizes
  real, intent(in) :: kernel(:,:,:)              !! Smoothing kernel values
  integer, intent(in)  :: nx,ny                  !! Image size
  integer, intent(in)  :: ip                     !! Plane number 
  integer, intent(in)  :: miter                  !! Maximum number of clean components
  real, intent(out) :: flux                      !! Cleaned flux
  integer, intent(in)  :: niter                  !! Number of found components
  type (cct_par), intent(in) :: tcc(niter)       !! Clean component list
  real, intent(inout) :: dcct(:,:,:)             !! Clean component values
  !
  integer :: i,kx,ky,is,nc
  real :: value
  !
  nc = 0
  do i=1,niter
    kx = tcc(i)%ix
    ky = tcc(i)%iy
    value = tcc(i)%value
    is = -nint(tcc(i)%size)
    !
    call spread_kernel (nx,ny,ip,nc,dcct,value,kx,ky,nker(is),kernel(:,:,is))
  enddo
  !
  flux = 0.
  do i=1,nc
    dcct(1,ip,i) = (dcct(1,ip,i) -   &
     & head%gil%convert(1,1)) * head%gil%convert(3,1) + &
     & head%gil%convert(2,1)
    dcct(2,ip,i) = (dcct(2,ip,i) -   &
     & head%gil%convert(1,2)) * head%gil%convert(3,2) + &
     & head%gil%convert(2,2)
    flux = flux + dcct(3,ip,i)
  enddo
  !
end subroutine expand_multi_cct
