subroutine major_multi90 (rname,method,head,   &
     &    dirty,resid,beam,mask,clean,nx,ny,   &
     &    tcc,siter,miter,limit,niter, &
     &    smask, sresid, trans, cdata, sbeam, &
     &    tfbeam, wfft, mcct, nker, kernel, &
     &    np, primary, weight)    ! For mosaics
  use imager_interfaces, except_this=>major_multi90
  use gkernel_interfaces
  use image_def
  use gbl_message
  use clean_def
  !$  use omp_lib
  !-----------------------------------------------------------------------
  ! @ public
  !
  ! IMAGER
  !     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
  type (clean_par), intent(inout) :: method
  type (gildas), intent(inout) :: head         ! Unused, but here for consistency...
  integer, intent(in)  :: nx,ny                ! 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(nx,ny)            ! Dirty image
  real, intent(inout) :: resid(nx,ny)          ! Residual image (initialized to Dirty image)
  real, intent(in)  :: beam(nx,ny,np)          ! Dirty beams
  real, intent(inout) :: clean(nx,ny)          ! "CLEAN" image (not convolved yet)
  logical, intent(in)  :: mask(nx,ny)          ! Search area
  real, intent(in)  :: limit                   ! Maximum residual
  real, intent(in)  :: tfbeam(nx,ny)           ! Real Beam TF
  real, intent(inout) :: wfft(*)               ! Work space for FFT
  type (cct_par), intent(out) :: tcc(miter)
  integer, intent(out) :: nker(:)              ! Kernel sizes
  real, intent(out) :: kernel(:,:,:)           ! Smoothing kernel values
  !
  integer, intent(out) :: mcct                 ! Number of separate Clean components
  !
  ! Work spaces - In call sequence
  real, intent(inout) ::  sbeam(nx,ny,*)       ! Smoothed beams
  real, intent(inout) ::  sresid(nx,ny)        ! Smoothed residuals
  real, intent(inout) ::  trans(nx,ny)         ! Translated beam
  complex, intent(inout) ::  cdata(nx,ny)      ! Work array
  logical, intent(inout) ::  smask(nx,ny)      ! Smoothed mask
  !
  real, intent(in) :: primary(np, nx, ny)      ! Primary beams
  real, intent(in) :: weight(nx, ny)           ! Combined weights
  !
  !
  ! Local work variables
  integer :: mcum, ncum, nchain
  integer nn(2), ndim, kx,ky
  integer is,i,j, oldis, goodis
  real, allocatable :: oldcum(:)
  real value, converge, sign
  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, parameter :: ms=3
  integer, parameter :: mk=11
  integer  ns                  ! Number of Kernels
  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 :: ier, counter
  integer :: clean_slow=0      ! Precision and Speed control code (for tests)
  logical :: error
  !
  real, allocatable :: lbeam(:,:)  ! Local beam (average of all dirty beams)
  !
  error = .false.
  call sic_get_inte('CLEAN_SLOW',clean_slow,error)
  clean_slow = min(max(-2,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
  !
  mcum = method%converge
  allocate(oldcum(max(1,mcum)))
  !
  smooth = method%smooth
  gain = method%gain
  plot = method%pflux
  nker = method%nker
  printout = method%verbose  ! Default behaviour
  gains = method%gains
  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
  ncase(1:ms) = 0
  fluxes(:) = 0.0
  trans(:,:) = 0.0
  !
  ! Initialize smoothed beams & mask
  call smooth_mask (mask,smask,nx,ny,nker(ns))
  !
  kx = nx/2+1
  ky = ny/2+1
  ! 
  ! Get the scale factors and sensitivity loss
  allocate(lbeam(nx,ny),stat=ier)
  lbeam(:,:) = beam(:,:,1)
  do ip=2,np
    lbeam(:,:) = lbeam + beam(:,:,ip)
  enddo
  if (np.ne.1) lbeam = lbeam/np
  !
  sbeam(:,:,1) = lbeam
  loss(1)  = 1.0
  scale(1) = 1.0
  ! 
  ! Use the average dirty beam to estimate these factors
  do is = 2,ns
    call smooth_kernel (lbeam,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,nx,ny,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
  !
  counter = 0
  do           ! For ever...
    counter = counter+1
    !
    ! Locate the Clean Component - The Smoothed Beams do not intervene here,
    ! only the Normalized Kernel and Smoothed Mask
    do is = 1,ns
      if (is.eq.1) then
        call amaxmask (resid,mask,nx,ny,ix(1),iy(1))
        bruit(1) = resid(ix(1),iy(1))
      else
        !
        ! Smooth within (smoothed) mask
        call smooth_masked(nx,ny,sresid,resid, &
      &        smask,mk,nker(is),kernel(:,:,is))
!
! or (slower) anywhere
!!        call smooth_kernel(resid,sresid,nx,ny,mk,nker(is),kernel(:,:,is))
        !
        ! Use MASK or SMASK, more or less at will...
        call amaxmask (sresid,mask,nx,ny,ix(is),iy(is))
        bruit(is) = sresid(ix(is),iy(is))
      endif
    enddo
    !!Print *,'Bruit ',bruit,' Scale ',scale,' Gains ',gains
    !
    maxa = -1.0
    do is = 1,ns
      sn(is) = abs(bruit(is)/loss(is))
      if (sn(is).gt.maxa) then
        maxa = sn(is)
        goodis = is
      endif
    enddo
    !
    if (niter.lt.siter) maxsn = sn(goodis)
    !!Print *,'Maxa ',maxa,' Maxsn ',maxsn
    !
    ! Check criterium
    ok = niter.lt.miter
    ok = ok .and. abs(bruit(1)).ge.limit
    if (.not.ok) exit
    if (sn(goodis).gt.maxsn) then
      ok = .false.  ! Stop if S/N has degraded
      exit
    endif
    maxsn = worry*sn(goodis)+(1.0-worry)*maxsn  ! Propagate S/N estimate
!!    Print *,'Counter ',counter,' Maxsn ',maxsn,goodis,sn(goodis)
    !
    niter = niter+1
    !
    value = gains(goodis)*bruit(goodis)
    if (np.gt.1) then
      value = value * weight(ix(goodis),iy(goodis))    ! Convert to Clean component
    endif
    tcc(niter)%value = value 
    tcc(niter)%ix = ix(goodis)
    tcc(niter)%iy = iy(goodis)
    tcc(niter)%type = goodis
    !
    ! Do not Scale component flux : See Note Later (#1)
    flux = flux + tcc(niter)%value*scale(goodis)
    !
    if (mcum.ne.0) then
      oldcum(ncum) = flux
      ncum = ncum+1
      if (ncum.gt.mcum) ncum = 1
      converge = sign * (flux - oldcum(ncum))
    endif
    !
    ! Plot the new point
    if (printout.and.goodis.ne.oldis) then
      if (goodis.eq.1) then
        write(chain,101) niter,ix(goodis),iy(goodis),   &
     &            sn(1),sn(2),sn(3),bruit(goodis)*loss(goodis)
      elseif (goodis.eq.2) then
        write(chain,102) niter,ix(goodis),iy(goodis),   &
     &            sn(1),sn(2),sn(3),bruit(goodis)*loss(goodis)
      elseif (goodis.eq.3) then
        write(chain,103) niter,ix(goodis),iy(goodis),   &
     &            sn(1),sn(2),sn(3),bruit(goodis)*loss(goodis)
      endif
      call map_message(seve%i,rname,chain)
      oldis = goodis
    endif
    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
    !
    ! Beam offset
    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
      do j=max(1,ky+1),min(ny,ny+ky)
        do i=max(1,kx+1),min(nx,nx+kx)
          resid(i,j) = resid(i,j) + maxa * sbeam(i-kx,j-ky,goodis)
        enddo
      enddo
    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
          call spread_kernel (nx,ny,nf,nc,kcct,maxa,lx,ly, &
            &   nker(goodis),kernel(:,:,goodis))
        endif
        !!Print *,'LX LY ',lx,ly, 'NX NY ',nx,ny,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
              do j=max(1,ky+1),min(ny,ny+ky)
                do i=max(1,kx+1),min(nx,nx+kx)
                  resid(i,j) = resid(i,j) + & 
                  & maxp*beam(i-kx,j-ky,ip)*primary(ip,i,j)*weight(i,j)
                enddo
              enddo
              !
            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)
                do j=max(1,ky+1),min(ny,ny+ky)
                  do i=max(1,kx+1),min(nx,nx+kx)
                    trans(i,j) = trans(i,j) + beam(i-kx,j-ky,ip)*maxp
                  enddo
                enddo
              enddo
              ! 
              ! Remove from residual
              do j=1,ny
                do i=1,nx
                  resid(i,j) = resid(i,j) + & 
                  & trans(i,j)*primary(ip,i,j)*weight(i,j)
                enddo
              enddo
            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
              ! Attenuate by primary beam 
              maxp = kcct(3,1,ic) * primary(ip,lx,ly)
              do j=max(1,ky+1),min(ny,ny+ky)
                do i=max(1,kx+1),min(nx,nx+kx)
                  trans(i,j) = trans(i,j) + beam(i-kx,j-ky,ip)*maxp
                enddo
              enddo
            enddo
            ! 
            ! Remove from residual
            do j=1,ny
              do i=1,nx
                resid(i,j) = resid(i,j) + & 
                & trans(i,j)*primary(ip,i,j)*weight(i,j)
              enddo
            enddo
          enddo
        case(2)
          ! Slower
          do ic=1,nc
            !!Print *,'IC ',IC,' KCCT ',KCCT(1:3,1,IC)
            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(ny,ny+ky)
                do i=max(1,kx+1),min(nx,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
            !!Print *,'IC ',IC,' KCCT ',KCCT(1:3,1,IC)
            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(ny,ny+ky)
                do i=max(1,kx+1),min(nx,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,ny
                do i=1,nx
                  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)
            ! 
            do j=max(1,ky+1),min(ny,ny+ky)
              do i=max(1,kx+1),min(nx,nx+kx)
                resid(i,j) = resid(i,j) + & 
                & maxp*sbeam(i-kx,j-ky,goodis)*primary(ip,i,j)*weight(i,j)
              enddo
            enddo
          enddo
          !
        case (-1)
          ! Slightly slower
          do ip=1,np
            trans = 0. !
            ! Translate the appropriate smoothed dirty beam
            do j=max(1,ky+1),min(ny,ny+ky)
              do i=max(1,kx+1),min(nx,nx+kx)
                trans(i,j) = sbeam(i-kx,j-ky,goodis) ! WRONG, should be IP dependent (one per pointing)
              enddo
            enddo
            ! 
            ! 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)
            ! 
            do j=1,ny
              do i=1,nx
                resid(i,j) = resid(i,j) + & 
                & maxp*trans(i,j)*primary(ip,i,j)*weight(i,j)
              enddo
            enddo
          enddo
          !
        end select
      endif
    endif
!
    if (mcum.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 (mcum.gt.0.and.converge.lt.0.0) then
    string = 'flux convergence'
  else if (interrupt) then
    string = 'User ^C interrupt'
  else
    string = 'residual'
  endif
  write(chain,104) 'Stopped by ',trim(string),niter,bruit(1),limit
  call map_message(seve%d,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 NOT scaled (see comment Above)
  !
  mcct = 0
  do i=1,niter
    value = tcc(i)%value
    kx = tcc(i)%ix
    ky = tcc(i)%iy
    is = tcc(i)%type
    if (is.le.1) then         ! May have Type = 0 if restarted      
      clean (kx,ky) = clean(kx,ky) + value
      mcct = mcct+1
    else
      call add_kernel (clean,nx,ny,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) = nx
    nn(2) = ny
    call fourt(cdata,nn,ndim,-1,1,wfft)
    cdata = cdata*tfbeam            ! 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
  return
  !
  101   format(i6,i4,i4,' [',1pg11.4,'] ',1pg11.4,2x,1pg11.4,'  = ',   &
     &    1pg11.4)
  102   format(i6,i4,i4,2x,1pg11.4,' [',1pg11.4,'] ',1pg11.4,'  = ',   &
     &    1pg11.4)
  103   format(i6,i4,i4,2x,1pg11.4,2x,1pg11.4,' [',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  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                    !
  integer, intent(in)  :: niter                ! Number of found components
  type (cct_par), intent(in) :: tcc(niter)     !
  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 = tcc(i)%type
    !
    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
