!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module clean_cycle_tool
  use gbl_message
  !
  public :: sub_major,major_cycle,minor_cycle
  private
  !
contains
  !
  subroutine sub_major(inout_method,hdirty,hresid,hclean,hbeam,hprim,hmask,&
       dcct,mask,list,error,major_plot,next_flux)
    use image_def
    use gkernel_interfaces
    use clean_support_tool
    use clean_beam_tool, only: beam_for_channel,get_beam
    use clean_flux_tool, only: init_plot
    use clean_types
    use cct_types
    use omp_buffers
    use clean_buffers, only: clean_buffer
    !$ use omp_lib
    !----------------------------------------------------------------------
    ! Perfom a CLEAN based on all CLEAN algorithms, except the MRC (Multi
    ! Resolution CLEAN) 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) :: inout_method
    type(gildas),    intent(in)    :: hdirty
    type(gildas),    intent(inout) :: hbeam
    type(gildas),    intent(inout) :: hclean
    type(gildas),    intent(inout) :: hresid
    type(gildas),    intent(in)    :: hprim
    type(gildas),    intent(in)    :: hmask
    real,            intent(inout) :: dcct(:,:,:) ! (3,hclean%gil%dim(3),*)
    logical, target, intent(in)    :: mask(:,:)
    integer, target, intent(in)    :: list(:)
    logical,         intent(inout) ::  error
    external                       :: major_plot
    external                       :: next_flux
    !
    real, pointer :: dirty(:,:)    ! Dirty map
    real, pointer :: resid(:,:)    ! Iterated residual
    real, pointer :: clean(:,:)    ! Clean Map
    real, pointer :: d3prim(:,:,:) ! Primary beam
    real, pointer :: d3beam(:,:,:) ! Dirty beam (per field)
    real, pointer :: weight(:,:)   ! Mosaic weight
    !
    integer :: f_iter, m_iter
    logical, allocatable :: s_mask(:,:)
    integer, allocatable :: mymask(:,:)
    real, allocatable :: s_beam(:,:,:),t_beam(:,:),s_resi(:,:)
    real, allocatable :: tfbeam(:,:,:)
    real, allocatable :: w_cct(:,:)
    real, allocatable :: w_fft(:)       ! TF work area
    complex, allocatable :: w_work(:,:) ! Work area
    type(cct_par), allocatable :: w_comp(:)
    ! Mask & List per thread
    integer :: nmask,j
    logical, allocatable, target :: masks(:,:,:)
    integer, allocatable, target :: lists(:,:)
    logical, pointer :: lmask(:,:)
    integer, pointer :: llist(:)
    !
    type(clean_par), save :: method
    type(cct_par), allocatable :: tcc(:)
    !
    logical :: parallel,omp_nested
    logical :: dotruc,do_fft
    integer :: iplane
    integer :: nx,ny,np,nl,mx,my,nc
    integer :: ip,ier,ix,iy,i,jcode
    integer :: ibeam, ithread, mthread, nplane
    real :: fhat,limit,flux
    real, save :: major,minor,angle
    real, target :: dummy_prim(1,1,1), dummy_weight(1,1)
    character(len=16) :: cmethod
    character(len=48) :: cthread
    character(len=24) :: cname
    character(len=message_length) :: chain,mess
    character(len=*), parameter :: rname='SUB_MAJOR'
    !
    parallel = .false.
    !$ parallel = .true.
    error = .false.
    if (parallel) then
       mess = 'Using Open-MP parallel code'
    else
       mess = 'Using Open-MP capable code in Non-Parallel mode'
    endif
    call map_message(seve%i,rname,mess)
    !
    method = inout_method
    !
    cmethod = method%method
    do_fft = cmethod.ne.'HOGBOM'
    !
    ! Local variables
    nx = hclean%gil%dim(1)
    ny = hclean%gil%dim(2)
    mx = hbeam%gil%dim(1)
    my = hbeam%gil%dim(2)
    nl = method%nlist
    nc = nx*ny
    np = max(1,hprim%gil%dim(1))
    !
    ! TFBEAM cannot be on the Call sequence here because 
    ! it must be PRIVATE in parallel sections
    if (do_fft) then
       allocate(w_work(nx,ny),w_fft(2*max(nx,ny)),tfbeam(nx,ny,np),stat=ier)
       if (ier.ne.0) then
          call map_message(seve%e,rname,'Memory allocation error for TFBEAM')
          error = .true.
          return
       endif
    else
       allocate(w_work(1,1),w_fft(1),tfbeam(1,1,1),stat=ier)  
    endif
    if (ier.ne.0) then
       call map_message(seve%e,rname,'FFT Memory allocation failure')
       error = .true.
       return
    endif
    !
    ier = 0
    select case (cmethod)
    case ('CLARK')
       allocate(w_comp(nc),w_cct(1,1),mymask(1,1), &
            s_mask(1,1),s_resi(1,1),t_beam(1,1), &
            s_beam(1,1,3),stat=ier)
    case ('SDI')
       allocate(w_comp(nc),w_cct(nx,ny),mymask(nx,ny), &
            s_mask(1,1),s_resi(1,1),t_beam(1,1), &
            s_beam(1,1,3),stat=ier)
    case ('MULTI')
       allocate(w_comp(1),w_cct(nx,ny),mymask(nx,ny), &
            s_mask(nx,ny),s_resi(nx,ny),t_beam(nx,ny), &
            s_beam(nx,ny,3),stat=ier)
    case default
       allocate(w_comp(1),w_cct(1,1),mymask(1,1), &
            s_mask(1,1),s_resi(1,1),t_beam(1,1), &
            s_beam(1,1,3),stat=ier)
    end select
    if (ier.ne.0) then
       call map_message(seve%e,rname,'Work Arrays Memory allocation failure')
       error = .true.
       return
    endif
    !
    ! Clean component work array
    allocate(tcc(method%m_iter),stat=ier)
    if (ier.ne.0) then
       call map_message(seve%e,rname,'Memory allocation error for TCC')
       error = .true.
       return
    endif
    !
    mthread = 1
    ithread = 1
    !$  mthread = omp_get_max_threads()
    nplane = method%last-method%first+1
    !$  omp_nested = omp_get_nested()
    if (nplane.eq.1) then
       !$  call omp_set_nested(.true.)
    else
       !$  call omp_set_nested(.false.)
    endif
    !
    ! Global aliases: SHARED here
    if (support_type.eq.support_mask) then
       ! Allocate the Masks and List per-thread
       nmask = min(hmask%gil%dim(3),nplane,mthread)
       if (nmask.gt.1) then
          allocate(masks(nx,ny,nmask),lists(nx*ny,nmask),stat=ier)
          if (ier.ne.0) then
             call map_message(seve%e,rname,'Mask & List memory allocation error')
             return
          endif
       endif
    else
       ! Keep the global association
       nmask = 0
    endif
    !
    cname = method%method
    ! 
    ! I had parallel block crashing if there were more threads
    ! than DO loop index (it should not but I could not find why).
    ! Seems to have disappeared with newer version of gfortran and/or
    ! extended stack
    !
    ! However, the common code is executed MTHREAD times
    ! Only loops are executed NPLANE times in this case,
    ! so limiting the MTHREAD would be good - but then
    ! number of threads must be reset at end.
    ! 
    !$ !  if (nplane.lt.mthread) call omp_set_num_threads(nplane)
    !$ !  print *,'Number of threads ',omp_get_num_threads()
    !
    !
    ! I need some CLEAN beam parameters
    if (omp%debug) print *,'Getting SOME beam parameters '
    iplane = method%first
    ibeam = beam_for_channel(iplane,hdirty,hbeam)
    d3beam  => hbeam%r4d(:,:,:,ibeam)
    call inout_method%fit_beam(hbeam,d3beam,error) !! TEST
    if (omp%debug) print *,'Got SOME beam parameters '
    !
    ! Loop here if needed
    !$OMP PARALLEL IF (nplane.gt.1) DEFAULT(none) & !! IF (nplane.ge.mthread) &
    !$OMP & SHARED(hdirty,hclean,hbeam,hprim,hresid,hmask) & ! Headers
    !$OMP & SHARED(dummy_prim,dummy_weight,dcct) & ! Big arrays
    !$OMP & SHARED(fhat, nx,ny,mx,my,np,nc, omp) &
    !$OMP & SHARED(inout_method)  & ! A modified structure
    !$OMP & SHARED(major,minor,angle,cmethod) &
    !$OMP & SHARED(nmask,masks,lists,mask,list) &
    !$OMP & SHARED(clean_buffer) &
    !$OMP & PRIVATE(method, dotruc)  &  ! A modified structure
    !$OMP & PRIVATE(iplane, ibeam, error, nl, chain, cthread, cname) &
    !$OMP & PRIVATE(tfbeam,w_work,w_fft,w_comp,w_cct,tcc) &   ! Arrays
    !$OMP & PRIVATE(flux,f_iter,m_iter,limit,ithread,jcode) &
    !$OMP & PRIVATE(ix,iy,i,j) &  ! These were NOT diagnosed by the DEFAULT(none)
    !$OMP & PRIVATE(d3beam,d3prim) &
    !$OMP & PRIVATE(mymask,s_mask,s_beam,s_resi,t_beam)  & ! Arrays
    !$OMP & PRIVATE(dirty,resid,clean) PRIVATE(weight,llist,lmask)  ! Pointers
    !
    ! Re-Define the method (in parallel mode, private entities are uninitialized)
    method = inout_method
    if (nmask.gt.1) then
       method%imask = 0 ! Mask is undefined at beginning if more than 1 plane
    endif
    !
    ! Global aliases: PRIVATE inside
    if (.not.method%mosaic) then
       weight => dummy_weight
    endif
    !
    ithread = 1
    !$  ithread = omp_get_thread_num()+1
    !
    !$OMP DO SCHEDULE(STATIC,1) !! SCHEDULE(DYNAMIC,1)
    do iplane = inout_method%first, inout_method%last
       method%iplane = iplane
       !
       call clean_buffer%get_stopping(method%m_iter,method%ares,iplane)
       !$ write(cthread,'(A,I2)') ', Thread ',ithread
       !$ write(cname,'(A,A,I0,A)') trim(cmethod),'(',iplane,')' 
       !
       if (omp%debug) then
          !$OMP CRITICAL
          print *,'Calling beam_plane '//cthread
          call method%list()
          print *,'Done beam_plane '//cthread
          !$OMP END CRITICAL
       endif
       !
       !THAT IS CRASHING ! call beam_plane(method,hbeam,hdirty)
       ibeam = beam_for_channel(iplane,hdirty,hbeam)
       method%ibeam = ibeam
       !
       ! Get the new mask
       if (nmask.gt.1) then
          lmask => masks(:,:,ithread)
          llist => lists(:,ithread)
       else
          lmask => mask
          llist => list
       endif
       !$ if (omp%debug) print *,'Calling get_maskplane - OMP'
       call get_maskplane(method,hmask,hdirty,lmask,llist)    
       nl = method%nlist
       !$ if (omp%debug) print *,'Thread ',ithread,' NL ',nl
       !
       ! Local aliases
       if (method%imask.ge.1) then
          write(chain,'(A,A,I0,A,I0,A,I0,1x,I0)') 'Planes: ', & 
               '  Image ',method%iplane, & 
               ', - Beam ', method%ibeam, & 
               ', - Mask ', method%imask, nl
       else
          write(chain,'(A,A,I0,A,I0,A,I0)') 'Planes: ', & 
               '  Image ',method%iplane, & 
               ', - Beam ', method%ibeam
       endif
       !$ chain = trim(chain)//cthread
       call map_message(seve%i,cname,chain)
       !
       ! Local aliases
       dirty => hdirty%r3d(:,:,iplane)
       resid => hresid%r3d(:,:,iplane)
       clean => hclean%r3d(:,:,iplane)
       !
       ! Initialize to Dirty map
       resid = dirty
       !
       d3beam  => hbeam%r4d(:,:,:,ibeam)
       if (method%mosaic) then
          d3prim => hprim%r4d(:,:,:,ibeam)
       else
          d3prim => dummy_prim
       endif
       !
       if (method%pcycle) call init_plot (method,hdirty,resid)
       !
       ! Prepare beam parameters - subroutine is not Thread safe though...
       !$OMP CRITICAL
       !$ if (omp%debug) print *,'Critical get_clean '//cthread
       error = .false.
       call method%fit_beam(hbeam,d3beam,error)
       !$ if (omp%debug) print *,'end Critical get_clean '//cthread
       !$OMP END CRITICAL
       if (error) then
          !return !Oops, cannot do that in a DO parallel...
          cycle
       endif
       !$ if (omp%debug) print *,'start get_beam '//cthread
       call get_beam(method,hbeam,hresid,hprim,&
            tfbeam,w_work,w_fft,fhat,error,lmask)
       !$ if (omp%debug) print *,'end get_beam '//cthread
       ! Empty beam case
       if (error) then
          error = .false.
          clean = resid
          !return !Oops, cannot do that in a DO parallel...
          cycle
       endif
       !
       ! Mosaic case
       if (method%mosaic) then
          !$ if (omp%debug) print *,'Setting weight for ',method%ibeam
          ! Reset search list as the mask may have been altered
          call lmask_to_list (lmask,nx*ny,llist,method%nlist)
          nl = method%nlist
          weight => method%weight(:,:,method%ibeam)
          !$ if (omp%debug) print *,'Done weight for ',method%ibeam
          resid = resid * weight
       endif
       !
       ! Performs decomposition into components only
       ! if NL # 0 
       if (nl.ne.0) then
          !$ if (omp%debug) print *,'Select case '//cmethod//cthread
          select case (cmethod)
          case('HOGBOM')
             call hogbom_cycle (cname,method%pflux,   &   ! Plot flux
                  d3beam,mx,my,   & ! Beam and size
                  resid,nx,ny,   & ! Residual and size
                  method%beam0(1),method%beam0(2),   & ! Beam center
                  method%box, method%fres, method%ares,   &
                  method%m_iter, method%p_iter, method%n_iter,   &
                  method%gain, method%keep,   &    !
                  tcc,   &         ! Component Structure
                  lmask,   & ! Search mask
                  llist,   & ! Search list
                  nl,   &          ! and its size
                  np,   &          ! Number of fields
                  d3prim,   &      ! Primary beams
                  weight,   &      ! Weight
                  method%trunca, flux, jcode, next_flux)
          case('CLARK')
             ! Find components
             call major_cycle (cname,method,hclean,   &   !
                  clean,   &       ! Final CLEAN image
                  d3beam,  &       ! Dirty beams
                  resid,nx,ny,   & ! Residual and size
                  tfbeam, w_work,   &  ! FT of dirty beam + Work area
                  w_comp, nc,       &  ! Component storage + Size
                  method%beam0(1),method%beam0(2),   & ! Beam center
                  method%patch(1), method%patch(2), method%bgain,   &
                  method%box,   &
                  w_fft,   &       ! Work space for FFTs
                  tcc,   &         ! Component table
                  llist, nl,   &   ! Search list (truncated...)
                  np,                & ! Number of fields
                  d3prim,            & ! Primary beams
                  weight,            & ! Weight
                  major_plot,        & ! Plotting routine
                  next_flux)
          case('SDI')
             ! Find components
             call major_sdi (cname,method,hclean,   &
                  clean,   &       ! Final CLEAN image
                  d3beam,  &       ! Dirty beams
                  resid,nx,ny,   & ! Residual and size
                  tfbeam, w_work,   &  ! FT of dirty beam + Work area
                  w_comp, nc,       &  ! Component storage + Size
                  method%beam0(1),method%beam0(2),   & ! Beam center
                  method%patch(1), method%patch(2), method%bgain,   &
                  method%box,   &
                  w_fft,   &       ! Work space for FFTs
                  w_cct,   &       ! Clean Component Image
                  llist, nl,   &   ! Search list (truncated...)
                  np,                & ! Number of fields
                  d3prim,            & ! Primary beams
                  weight,            & ! Weight
                  major_plot)          ! Plotting routine
          case('MULTI')
             ! Performs decomposition into components
             call amaxmask (resid,lmask,nx,ny,ix,iy)
             limit = max(method%ares,method%fres*abs(resid(ix,iy)))
             call map_message(seve%i,cname,chain)
             if (limit.eq.method%ares) then
                write (chain,'(A,1PG10.3,A)')  'Cleaning down to ',limit,' from ARES'
             else
                write (chain,'(A,1PG10.3,A,I7,I7)')  'Cleaning down to ',limit,' from FRES at ',ix,iy
             endif
             call map_message(seve%i,cname,chain)
             !
             call major_multi (cname,method,hclean,   &
                  hdirty%r3d(:,:,iplane),   &
                  hresid%r3d(:,:,iplane),   &
                  hbeam%r4d(:,:,:,method%ibeam),                  &
                  lmask,           & ! Check definition of this mask...
                  hclean%r3d(:,:,iplane),   &
                  nx,ny,                    &
                  tcc,   &         ! Clean component
                  method%m_iter,   &   ! Maximum number of components
                  limit,   &       ! Residual
                  method%n_iter,   &   ! Number of components
                  s_mask,   &      ! Smoothed mask
                  s_resi,   &      ! Smoothed residual,
                  t_beam,   &      ! Translated beam
                  w_work,   &      ! Complex work space
                  s_beam,   &      ! Smoothed beams
                  tfbeam,   &      ! Beam Fourier Transform (real)
                  w_fft)
             ! Need to add
             !             &        np,   &          ! Number of fields
             !             &        d3prim,   &      ! Primary beams
             !             &        weight)          ! Weight
             w_cct(:,:) = clean
          end select
          !$ if (omp%debug) print *,'End Select case '//cmethod//cthread
       else
          ! Empty search area: No Clean components...
          method%n_iter = 0
          flux = 0.0
       endif
       !
       ! Add clean components and residuals to produce clean map
       if (method%n_iter.ne.0) then
          !$ if (omp%debug) print *,'Critical clean_make '//cthread
          call clean_make (method, hclean, clean, tcc)
          !$ if (omp%debug) print *,'End clean_make '//cthread
          if (np.le.1) then
             clean = clean + resid
          else
             clean = clean + resid*weight
             where (weight.eq.0) clean = hclean%gil%bval ! Undefined pixel there
          endif
       else
          if (np.le.1) then
             clean = resid
          else
             clean = resid*weight
             where (weight.eq.0) clean = hclean%gil%bval ! Undefined pixel there
          endif
       endif
       !$ if (omp%debug) print *,'Finishing '//cthread
       !
       ! Put the TCC structure into its final place
       if (cmethod.eq.'MULTI' .or. cmethod.eq.'SDI') then
          if (method%n_iter.eq.0) then
             dcct(3,iplane,1) = 0
             write (chain,'(A,1PG10.3,A,I6,A,A,I6)')  'Cleaned ',0.0,   &
                  ' Jy with ',method%n_iter,' components ' &
                  ,' Plane ',iplane
          else
             if (cmethod.eq.'MULTI') then
                m_iter = method%ninflate*method%m_iter
             else
                m_iter = method%m_iter
             endif
             where (w_cct.ne.0)
                mymask = 1
             elsewhere
                mymask = 0
             end where
             f_iter = sum(mymask)
             if (f_iter.gt.m_iter) then
                write(chain,'(A,I8,A,I8)') 'Iterations overflow ',f_iter, &
                     ' > ',m_iter
                call map_message(seve%w,cname,chain)
                dcct(3,iplane,1) = 0
                chain = 'UV_RESTORE will not work, consider increasing INFLATE'
             else
                i = 0
                flux = 0
                do iy=1,ny
                   do ix=1,nx
                      if (w_cct(ix,iy).ne.0) then
                         i = i+1
                         dcct(1,iplane,i) = (dble(ix) -   &
                              hclean%gil%convert(1,1)) * hclean%gil%convert(3,1) + &
                              hclean%gil%convert(2,1)
                         dcct(2,iplane,i) = (dble(iy) -   &
                              hclean%gil%convert(1,2)) * hclean%gil%convert(3,2) + &
                              hclean%gil%convert(2,2)
                         dcct(3,iplane,i) = w_cct(ix,iy)
                         flux = flux+w_cct(ix,iy)
                      endif
                   enddo
                enddo
                method%n_iter = i
                write (chain,'(A,1PG10.3,A,I6,A,A,I6)')  'Cleaned ',flux,   &
                     ' Jy with ',method%n_iter,' components ' &
                     ,' Plane ',iplane
             endif
          endif
          !$ chain = trim(chain)//cthread
          call map_message(seve%i,cname,chain)
       else if (cmethod.ne.'MRC') then
          do i=1,method%n_iter
             dcct(1,iplane,i) = (dble(tcc(i)%ix) -   &
                  hclean%gil%convert(1,1)) * hclean%gil%convert(3,1) + &
                  hclean%gil%convert(2,1)
             dcct(2,iplane,i) = (dble(tcc(i)%iy) -   &
                  hclean%gil%convert(1,2)) * hclean%gil%convert(3,2) + &
                  hclean%gil%convert(2,2)
             dcct(3,iplane,i) = tcc(i)%value
          enddo
          if (method%n_iter.lt.method%m_iter) then
             dcct(3,iplane,method%n_iter+1) = 0
          endif
          if (cmethod.eq.'HOGBOM') then
             write (chain,'(A,1PG10.3,A,I6,A,A,I6)')  'Cleaned ',flux,   &
                  ' Jy with ',method%n_iter,' components ' &
                  ,' Plane ',iplane
             !$ chain = trim(chain)//cthread
             call map_message(seve%i,cname,chain)
          endif
          !
       endif
       !$ if (omp%debug) print *,'End loop '//cthread
    enddo
    !$OMP END DO
    ! There is no OMP FIRST_AND_LASTPRIVATE
    !$OMP MASTER
    major = method%major
    minor = method%minor
    angle = method%angle
    !$OMP END MASTER
    !!print *,'Major ',major,minor,angle
    !$OMP END PARALLEL
    inout_method%major = major
    inout_method%minor = minor
    inout_method%angle = angle
    !$  call omp_set_nested(omp_nested)
    !$  if (nplane.lt.mthread) call omp_set_num_threads(mthread)
    !
    if (allocated(masks)) then
       deallocate(masks,lists)
    endif
    !
    ! PHAT
    !!print *,'sub_major PHAT ',method%phat
    ! This logic is only valid for One beam for all...
    if (method%phat.ne.0) then
       fhat = 1.0/fhat
       if (method%mosaic) then
          d3beam = d3beam*fhat
          do ip=1,np
             d3beam(method%beam0(1),method%beam0(2),ip) =   &
                  d3beam(method%beam0(1),method%beam0(2),ip) -   &
                  method%phat
          enddo
       else
          d3beam = d3beam*fhat
       endif
    endif
    !
    ! Set the blanking value for Mosaics
    if (method%mosaic) then
       hclean%gil%eval = 0
    endif
    !
    ! Clean work space: in principle, Fortran 95 does it for you
    deallocate(w_comp,w_cct,mymask, &
         s_mask,s_resi,t_beam,s_beam, &
         w_work,w_fft,stat=ier)
  end subroutine sub_major
  !
  subroutine amaxmask(a,mask,nx,ny,ix,iy)
    !-----------------------------------------------------------------------
    ! Search the absolute maximum, in a masked region
    !-----------------------------------------------------------------------
    integer, intent(in)  :: nx          ! X size
    integer, intent(in)  :: ny          ! Y size
    real,    intent(in)  :: a(nx,ny)    ! Values
    logical, intent(in)  :: mask(nx,ny) ! Mask
    integer, intent(out) :: ix          ! X position of max
    integer, intent(out) :: iy          ! Y position of max
    !
    real :: rmax
    integer :: i,j
    !
    rmax = -1.0
    ix = 1
    iy = 1
    do j=1,ny
       do i=1,nx
          if (mask(i,j)) then
             if (abs(a(i,j)).gt.rmax) then
                rmax = abs(a(i,j))
                ix = i
                iy = j
             endif
          endif
       enddo
    enddo
  end subroutine amaxmask
  !
  !------------------------------------------------------------------------
  !
  subroutine hogbom_cycle(rname,pflux,beam,mx,my,resid,nx,ny,&
       ixbeam,iybeam,box,fracres,absres,miter,piter,niter,&
       gainloop,keep,cct,msk,list,nl,np,primary,weight,wtrun,&
       cflux,jcode,next_flux)
    use gkernel_interfaces
    use minmax_tool, only: maxlst
    use clean_types, only: clean_converge
    use cct_types
    !$ use omp_lib
    !----------------------------------------------------------------------
    ! Support routine for HOGBOM
    ! Deconvolve map into residual map and source list
    !-----------------------------------------------------------------------
    character(len=*), intent(in)    :: rname 
    logical,          intent(in)    :: pflux             ! Select only positive ?
    integer,          intent(in)    :: mx                ! X size of beam
    integer,          intent(in)    :: my                ! Y size of beam
    integer,          intent(in)    :: nx                ! X size of image
    integer,          intent(in)    :: ny                ! Y size of image
    integer,          intent(in)    :: np                ! Number of fields
    real,             intent(in)    :: beam(mx,my,np)    ! Primary beam(s)
    real,             intent(inout) :: resid(nx,ny)      ! residual image
    real,             intent(in)    :: fracres           ! Fractional residual
    real,             intent(in)    :: absres            ! Absolute residual
    integer,          intent(in)    :: miter             ! Maximum number of clean components
    integer,          intent(in)    :: ixbeam, iybeam    ! Beam maximum position
    integer,          intent(in)    :: box(4)            ! Cleaning box
    real,             intent(in)    :: gainloop          ! Clean loop gain
    logical,          intent(in)    :: keep              ! Keep cleaning after convergence
    integer,          intent(out)   :: niter             ! Iterations
    integer,          intent(out)   :: piter             ! Positive Iterations
    logical,          intent(in)    :: msk(nx,ny)        ! Mask for clean search
    integer,          intent(in)    :: nl                ! Size of search list
    integer,          intent(in)    :: list(nl)          ! Search list
    real,             intent(in)    :: primary(np,nx,ny) ! Primary beams
    real,             intent(in)    :: weight(nx,ny)     ! Weight function
    real,             intent(in)    :: wtrun             ! Safety threshold on primary beams
    type(cct_par),    intent(out)   :: cct(miter)
    integer,          intent(out)   :: jcode             ! Stopping code
    real,             intent(out)   :: cflux             ! Cleaned Flux
    external                        :: next_flux
    !
    logical :: ok
    integer :: dimcum
    integer :: i,j,ix,iy,ip,imax,jmax,imin,jmin,k,l
    integer :: it,ier,nthread,mthread,ithread
    real :: cum,converge,sign
    real :: valmax,valmin,f,vnew,borne,gain
    real, allocatable :: oldcum(:)
    real, allocatable :: vnew_it(:)
    integer, allocatable :: imax_it(:), jmax_it(:)
    character(len=message_length) :: chain
    !
    dimcum = clean_converge
    allocate(oldcum(dimcum),stat=ier)
    !
    ! Find highest point in region to be searched
    call maxlst(resid,nx,ny,list,nl,valmax,imax,jmax,valmin,imin,jmin)
    write(chain,'(A,1PG10.3,A,I6,I6,A,1PG10.3,A,I6,I6)') &
         'Map max. ',valmax,' at ',imax,jmax,  &
         ', Min. ',valmin,' at ',imin,jmin
    call map_message(seve%i,rname,chain)
    !
    ! Subtract +ve and -ve peaks
    niter = 0
    if (niter.lt.piter) then
       vnew = valmax
       ix = imax
       iy = jmax
       sign = 1.0
    elseif (abs(valmin) .gt. abs(valmax)) then
       vnew = valmin
       ix = imin
       iy = jmin
       sign = -1.0
    else
       vnew = valmax
       ix = imax
       iy = jmax
       sign = 1.0
    endif
    !
    ! Setup Subtraction loop
    cum    = 0.
    oldcum = 0.0
    niter  = 0
    converge=0.
    borne = max(absres,fracres*abs(vnew))
    if (np.le.1) then
       gain = gainloop / beam(ixbeam,iybeam,1)
    else
       gain = gainloop
    endif
    !
    ! Main subtraction loop
    mthread = 1
    !$  mthread = omp_get_max_threads()
!!$  print *,'OMP Already parallel ',omp_in_parallel(),' Nesting ',omp_get_nested(), mthread
    allocate(vnew_it(mthread),imax_it(mthread),jmax_it(mthread),stat=ier)
    if (ier.ne.0) then
       write(chain,'(A,I4)') 'Memory allocation error for Mthread ',mthread
       call map_message(seve%e,rname,chain)
       return
    endif
    !
    ok = niter.lt.miter .and. abs(vnew).gt.borne
    !
    do while (ok)
       ! Get the component flux
       niter = niter+1
       f = vnew * gain
       if (np.gt.1) then
          f = f * weight(ix,iy)    ! Convert to Clean component
       endif
       cct(niter)%value = f       ! Store as fractions of beam max
       cct(niter)%ix = ix
       cct(niter)%iy = iy
       cct(niter)%type = 0
       !
       ! Keep last 10 cumulative fluxes to test convergence
       cum = cum + f
       oldcum(mod(niter,dimcum)+1) = cum
       converge = sign * (cum - oldcum(mod(niter+1,dimcum)+1))
       !
       ! Plot the new point
       if (pflux) call next_flux(niter,cum)
       !
       ! Subtract previous component from residual map
       !$OMP PARALLEL DEFAULT(none) &
       !$OMP   &   SHARED(beam,resid,primary,weight,msk) &
       !$OMP   &   SHARED(nx,ny,mx,my,np,box,niter,piter,wtrun) &
       !$OMP   &   SHARED(vnew_it,imax_it,jmax_it) &
       !$OMP   &   SHARED(ixbeam,iybeam,f)  SHARED(ix,iy) &
       !$OMP   &   PRIVATE(j,l,i,k,ip,ithread) SHARED(nthread)
       !
       ithread = 1
       nthread = 1
       !$  nthread = omp_get_num_threads()
       !$  ithread = omp_get_thread_num()+1
       !
       vnew_it(ithread)  = 0
       !$OMP DO
       do j=1,ny
          ! Proceed Row by Row
          l = j-iy+iybeam
          if (l.ge.1 .and. l.le.my) then
             ! Along that row, subtract clean component if in beam
             do i = 1,nx
                k = i-ix+ixbeam
                if (k.ge.1 .and. k.le.mx) then
                   if (np.le.1) then
                      resid(i,j) = resid(i,j) - f*beam(k,l,1)
                   else
                      if (resid(i,j).ne.0) then
                         do ip = 1,np
                            !
                            ! Beware of truncating the primary beam.
                            if (primary(ip,i,j).gt.wtrun) then
                               resid(i,j) = resid(i,j) -   &
                                    f*beam(k,l,ip)*primary(ip,i,j)   &
                                    *primary(ip,ix,iy)*weight(i,j)
                            endif
                         enddo
                      endif
                   endif
                endif
             enddo
          endif
          !
          ! Find new maximum inside cleaning box in residual map for this row
          if ((j.ge.box(2)).and.(j.le.box(4))) then
             if (niter.lt.piter) then
                ! Force positive components
                do i = box(1), box(3)
                   if (msk(i,j)) then
                      if (vnew_it(ithread).lt.resid(i,j)) then
                         vnew_it(ithread)=resid(i,j)
                         imax_it(ithread)=i
                         jmax_it(ithread)=j
                      endif
                   endif
                enddo
             else
                ! Do not force positivity
                do i = box(1), box(3)
                   if (msk(i,j)) then
                      if (abs(vnew_it(ithread)).lt.abs(resid(i,j))) then
                         vnew_it(ithread)=resid(i,j)
                         imax_it(ithread)=i
                         jmax_it(ithread)=j
                      endif
                   endif
                enddo
             endif
          endif
          !
          ! Loop for next row
       enddo
       !$OMP END DO
       !$OMP END PARALLEL
       !
       ! Compute VNEW and Position for next iteration
       !print *,'Computing VNEW '
       vnew = 0.0
       it = 1
       do i=1,nthread
          if (abs(vnew).lt.abs(vnew_it(i))) then
             it = i
             vnew = vnew_it(i)
          endif
       enddo
       vnew = vnew_it(it)
       ix = imax_it(it)
       iy = jmax_it(it)
       !
       !!print *,'Niter ',niter,' < ',miter,niter.lt.miter
       !!print *,'Keep ',keep,' and Converge ',converge, ' > 0',keep.or.(converge.gt.0)
       !!print *,'Vnew = ',vnew,' > Borne = ',borne,abs(vnew).gt.borne
       !
       jcode = 0
       if (sic_ctrlc()) exit
       !
       if (niter.ge.miter) then
          jcode = 1
          exit
       endif
       if (.not.keep.and.(converge.le.0)) then
          jcode = 2
          exit
       endif
       if (abs(vnew) .le. borne) then
          jcode = 3
          exit
       endif
    enddo
    !
    cflux = cum
  end subroutine hogbom_cycle
  !
  !------------------------------------------------------------------------
  !
  subroutine major_cycle(rname,method,head,&
       clean,beam,resid,nx,ny,tfbeam,fcomp,&
       wcl,mcl,ixbeam,iybeam,ixpatch,iypatch,bgain,&
       box,wfft,tcc,list,nl,np,primary,weight,&
       major_plot,next_flux)
    use image_def
    use gkernel_interfaces, only : fourt_plan
    use minmax_tool, only: maxlst
    use clean_types
    use cct_types
    !----------------------------------------------------------------------
    ! Major cycle loop according to B.Clark idea
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: rname
    type(clean_par),  intent(inout) :: method
    type(gildas),     intent(in)    :: head
    integer,          intent(in)    :: np                 ! Number of pointings
    integer,          intent(in)    :: nx                 ! X size
    integer,          intent(in)    :: ny                 ! Y size
    integer,          intent(in)    :: mcl                ! Maximum number of clean components
    real,             intent(inout) :: clean(nx,ny)       ! Clean map
    real,             intent(inout) :: resid(nx,ny)       ! Residual map
    real,             intent(in)    :: beam(nx,ny,np)     ! Dirty beams (per pointing)
    real,             intent(in)    :: tfbeam(nx,ny,np)   ! T.F. du beam
    complex,          intent(inout) :: fcomp(nx,ny)       ! T.F. du vecteur modification
    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) :: wfft(*)            ! Work space for FFT
    type(cct_par),    intent(inout) :: tcc(method%m_iter) ! Clean components array
    type(cct_par),    intent(inout) :: wcl(mcl)           ! Work space for Clean components
    integer,          intent(inout) :: list(nx*ny)        ! list of searchable pixels
    integer,          intent(inout) :: nl                 ! List size
    real,             intent(in)    :: primary(np,nx,ny)  ! Primary beams
    real,             intent(in)    :: weight (nx,ny)     ! Flat field response
    external                        :: major_plot
    external                        :: next_flux
    !
    logical :: fini                ! critere d'arret
    logical :: converge            ! Indique la conv par acc de flux
    integer :: ncl                 ! nb de pts reellement retenus
    integer :: k,kcl
    integer :: nn(2),ndim
    integer :: imax,jmax,imin,jmin ! leurs coordonnees
    real :: maxc,minc,maxabs       ! max et min de la carte, absolute
    real :: lastabs                ! Check for oscillations
    real :: borne                  ! fraction de la carte initiale
    real :: limite                 ! intensite minimum des pts retenus
    real :: clarkl                 ! Clark worry limit
    real :: flux                   ! Total clean flux density
    character(len=message_length) :: chain
    !
    ! Find maximum residual
    call maxlst (resid,nx,ny,list,nl,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
    borne= max(method%fres*maxabs,method%ares)
    fini = maxabs.lt.borne
    method%n_iter= 0
    flux = 0.0
    !
    if (.not.fini) then
       ndim = 2
       nn(1) = nx
       nn(2) = ny
       call fourt_plan(fcomp,nn,ndim,-1,1)
       call fourt_plan(fcomp,nn,ndim,+1,1)
    endif
    !
    ! Major cycle
    k = 0
    do while (.not.fini)
       ! Define minor cycle limit
       k = k+1
       write(chain,100) 'Major cycle ',k,' loop gain ',method%gain
       call map_message(seve%i,rname,chain)
       limite = max(maxabs*bgain,0.8*borne)
       clarkl = maxabs*bgain
       !
       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,         &     ! CCT
            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_cycle (method,   &
               wcl,            &    ! CCT
               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
               np, primary, weight, method%trunca,   &
               flux,   &        ! Total Flux
               method%pflux, next_flux)
          !
          ! 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,         &    ! CCT
               ncl,   &          ! Number of Clean Components
               nx,ny,   &        ! Map size
               wfft,   &         ! FFT work space
               np, primary, weight, method%trunca)
          write (chain,101)  'Cleaned ',flux,' Jy with ',method%n_iter,' clean components'
          call map_message(seve%i,rname,chain)
          !
          ! Find new extrema
          lastabs = maxabs
          call maxlst(resid,nx,ny,list,nl,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
          if (maxabs.gt.1.15*lastabs) then
             write(chain,'(a,1pg10.3,a,1pg10.3)') &
                  'Detected beginning of oscillations',maxabs,' > ',lastabs
             call map_message(seve%w,rname,chain)
          endif
          !
          ! Check if converge
          fini = (maxabs.le.borne)   &
               .or. (method%m_iter.le.method%n_iter)   &
               .or. converge
       else
          ! No component found: finish...
          write(chain,101) 'No points selected above ',limite
          call map_message(seve%i,rname,chain)
          fini = .true.
       endif
       !
       ! Intermediate or final PLOT
       converge = fini
       call major_plot (method,head,   &
            converge,method%n_iter,nx,ny,np,   &
            tcc,clean,resid,weight)
       fini = converge
       !
       ! Limit number of major cycles...
       if (k.gt.method%n_major) fini = .true.
       !
       ! Get new list
       !    if (.not.fini) then
       !      !
       !      ! Get a new list if in QUERY mode
       !      ! Query mode does not exist for MRC
       !      if (method%qcycle) then
       !        ! For MRC, method is s_method, while
       !        ! head is the normal stuff... This would create a problem
       !        call get_newmask (method,head,nl,error)
       !        !
       !        ! Reset the List in its defined range.
       !        list(1:nl) = method%list(1:nl)
       !      endif
       !    endif
    enddo
    !
    ! End
    if (maxabs.le.borne) then
       call map_message(seve%i,rname,'Reached minimum flux density')
    elseif (method%m_iter.le.method%n_iter) then
       call map_message(seve%i,rname,'Reached maximum number of components')
    elseif (converge) then
       call map_message(seve%i,rname,'Reached minor cycle convergence')
    elseif (k.gt.method%n_major) then
       call map_message(seve%i,rname,'Reached maximum number of cycles')
    else
       call map_message(seve%i,rname,'End of transcendental causes')
    endif
    write(chain,101)  'CLEAN found ',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)
  end subroutine major_cycle
  !
  subroutine minor_cycle(method,wcl,ncl,&
       beam,nx,ny,ixbeam,iybeam,ixpatch,iypatch,&
       clarkmin,limite,converge,&
       tcc,np,primary,weight,wtrun,cum,pflux,next_flux)
    use gkernel_interfaces
    use clean_types
    use cct_types
    !----------------------------------------------------------------------
    ! B.Clark minor cycles
    ! Deconvolve as in standard clean a list of NCL points
    ! selected in the map until the residuals is less than CLARKMIN
    !----------------------------------------------------------------------
    type(clean_par), intent(inout) :: method
    integer,         intent(in)    :: np                   ! Number of fields in mosaic
    integer,         intent(in)    :: ncl                  ! nombre de points retenus
    integer,         intent(in)    :: nx,ny,ixbeam,iybeam  ! dimension et centre du beam
    integer,         intent(in)    :: ixpatch,iypatch      ! rayon utile du Beam
    real,            intent(in)    :: beam(nx,ny,np)       ! Dirty beam
    type(cct_par),   intent(inout) :: wcl(*)               ! Clean components
    type(cct_par),   intent(out)   :: tcc(*)               ! Effective clean components
    real,            intent(in)    :: clarkmin             ! borne d'arret de clean
    real,            intent(in)    :: limite               ! borne d'arret de clean
    logical,         intent(out)   :: converge             ! Controle de la convergence
    real,            intent(in)    :: primary(np,nx,ny)    ! Primary beams of mosaics
    real,            intent(in)    :: weight(nx,ny)        ! Effective weights on sky
    real,            intent(in)    :: wtrun                ! Threshold of primary beam
    real,            intent(inout) :: cum                  ! Cumulative flux
    logical,         intent(in)    :: pflux
    external                       :: next_flux
    !
    logical :: check             ! Controle de la convergence
    logical :: abor,goon
    integer :: n,ier,i
    integer :: kiter
    integer :: kcl               ! No de la composante courante
    integer :: nomax,nomin       ! No du max et min courant
    integer :: dimcum=10         ! par accumulation de flux positif
    real :: gain                 ! gain de clean
    real :: rmax,rmin,sign       ! Max et Min courant
    real :: worry,xfac           ! Conservative and speedup factor
    real :: f,bmax
    real, allocatable :: oldcum(:)
    character(len=20) :: comm
    !
    !call sic_get_inte('MAP_CONVERGE',dimcum,error)
    allocate(oldcum(dimcum),stat=ier)
    !
    abor = .false.
    do i=1,ncl
       wcl(i)%value = 0.0
    enddo
    oldcum = cum
    gain = method%gain
    check = .not.method%keep
    !
    call cct_par_minmax(wcl,ncl,nomin,rmin,nomax,rmax)
    !!print *,'Nomin ',nomin,rmin,nomax,rmax
    if (method%n_iter.lt.method%p_iter) then
       kcl=nomax
       rmax=abs(rmax)
       sign = 1.0
    elseif (abs(rmin).gt.rmax) then
       kcl=nomin
       rmax=abs(rmin)
       sign = -1.0
    else
       kcl=nomax
       rmax=abs(rmax)
       sign = 1.0
    endif
    !
    converge = rmax.le.limite
    worry = 1.0
    xfac = (clarkmin/rmax)**method%spexp
    kiter = 0
    goon = method%n_iter.lt.method%m_iter   &
         .and. .not.converge
    bmax = beam(ixbeam,iybeam,1)
    !
    do while (goon)
       method%n_iter = method%n_iter + 1
       kiter = kiter + 1
       if (np.gt.1) then
          f = gain * wcl(kcl)%influx* weight(wcl(kcl)%ix,wcl(kcl)%iy)
       else
          f = gain / bmax * wcl(kcl)%influx
       endif
       !
       ! Store clean component list
       cum = cum+f
       if (pflux) call next_flux(method%n_iter,cum)
       !
       wcl(kcl)%value = wcl(kcl)%value + f
       tcc(method%n_iter)%value = f    ! Store as fractions of beam max
       tcc(method%n_iter)%ix = wcl(kcl)%ix
       tcc(method%n_iter)%iy = wcl(kcl)%iy
       tcc(method%n_iter)%type = 0
       !
       ! Subtract from iterated values VCL
       call soustraire (wcl,ncl,           &
            beam,nx,ny,ixbeam,iybeam,   &
            ixpatch,iypatch,kcl,gain,   &
            np,primary,weight,wtrun)
       !
       ! Find maximum again
       call cct_par_minmax(wcl,ncl,nomin,rmin,nomax,rmax)
       if (method%n_iter.lt.method%p_iter) then
          kcl=nomax
          rmax=abs(rmax)
       elseif (abs(rmin).gt.rmax) then
          kcl=nomin
          rmax=abs(rmin)
       else
          kcl=nomax
          rmax=abs(rmax)
       endif
       !
       ! B.CLARK Magic confidence factor
       worry = worry+xfac/float(kiter)
       !
       ! Check convergence
       abor = sic_ctrlc()
       goon = (rmax.gt.worry*clarkmin) .and. (rmax.gt.limite)   &
            .and. (method%n_iter.lt.method%m_iter)
       goon = goon .and. .not.abor
       if (check) then
          oldcum(mod(method%n_iter,dimcum)+1) = cum
          if (method%n_iter.ge.dimcum) then
             converge =   &
                  sign*(cum-oldcum(mod(method%n_iter+1,dimcum)+1))   &
                  .lt.0.0
             goon = goon .and. .not.converge
          endif
       endif
    enddo
    !
    if (abor) then
       comm = ' '
       call sic_wprn('I-CLARK,  Enter last valid component ',comm,n)
       if (n.eq.0) return
       n = lenc(comm)
       if (n.eq.0) return
       read(comm(1:n),*,iostat=ier) method%n_iter
       converge = .true. ! It must be converged
    endif
  end subroutine minor_cycle
  !
  !------------------------------------------------------------------------
  !
  subroutine major_sdi(rname,method,head,clean,beam,resid,nx,ny,&
       tfbeam,fcomp,wcl,mcl,ixbeam,iybeam,ixpatch,iypatch,bgain,&
       box,wfft,comp,list,nl,np,primary,weight,&
       major_plot)
    use image_def
    use minmax_tool, only: maxlst
    use clean_types
    use cct_types
    !----------------------------------------------------------------------
    ! Major cycle loop according to Steer Dewdney and Ito idea
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: rname 
    type(clean_par),  intent(inout) :: method
    type(gildas),     intent(in)    :: head
    integer,          intent(in)    :: np                ! Number of fields
    integer,          intent(in)    :: nx                ! X size
    integer,          intent(in)    :: ny                ! Y size
    integer,          intent(in)    :: mcl               ! Maximum number of clean components
    real,             intent(inout) :: clean(nx,ny)      ! Clean map
    real,             intent(inout) :: resid(nx,ny)      ! Residual map
    real,             intent(in)    :: beam(nx,ny,np)    ! Dirty beams (per field)
    real,             intent(in)    :: tfbeam(nx,ny,np)  ! T.F. du beam
    complex,          intent(inout) :: fcomp(nx,ny)      ! T.F. du vecteur modification
    type(cct_par),    intent(inout) :: wcl(mcl)          ! Work space for Clean components
    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) :: wfft(*)           ! Work space for FFT
    integer,          intent(inout) :: list(nx*ny)       ! list of searchable pixels
    integer,          intent(inout) :: nl                ! List size
    real,             intent(inout) :: comp(nx,ny)       ! Clean components array
    real,             intent(in)    :: primary(np,nx,ny) ! Primary beams
    real,             intent(in)    :: weight (nx,ny)
    external                        :: major_plot
    !
    logical :: fini              ! critere d'arret
    logical :: converge          ! Indique la conv par acc de flux
    integer :: k
    integer :: ndim,nn(2)
    integer :: ncl               ! nb de pts reellement retenus
    integer imax,jmax,imin,jmin  ! leurs coordonnees
    real :: maxc,minc,maxabs     ! max et min de la carte, absolu
    real :: borne                ! fraction de la carte initiale
    real :: limite               ! intensite minimum des pts retenus
    real :: flux                 ! Total clean flux density
    real :: factor               ! Scaling factor
    type (cct_par) :: tcc(1)     ! Dummy argument for Major_PLOT
    character(len=message_length) :: chain
    !
    ! Find maximum residual
    call maxlst(resid,nx,ny,list,nl,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
    borne= max(method%fres*maxabs,method%ares)
    fini = maxabs.lt.borne
    method%n_iter= 0
    flux = 0.0
    !
    ! Initialize clean components
    comp = 0.0
    ndim = 2
    nn(1) = nx
    nn(2) = ny
    call fourt_plan(fcomp,nn,ndim,-1,1)
    call fourt_plan(fcomp,nn,ndim,+1,1)
    !
    ! Major cycle
    !
    converge = .false.
    k = 0
    do while (.not.fini)
       ! Define minor cycle limit
       k = k+1
       write(chain,100) 'Major cycle ',k,' loop gain ',method%gain
       call map_message(seve%i,rname,chain)
       limite = max(maxabs*bgain,0.8*borne)
       !
       ! 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
            mcl,         &      ! Maximum number of candidates
            wcl,         &      ! Selected candidate components
            ncl,         &      ! Selected Number of components
            maxabs, 0)
       !
       if (ncl.gt.0) then
          write(chain,100) 'Selected ',ncl,' points above ',limite
          call map_message(seve%i,rname,chain)
          !
          ! No minor cycles. Compute scaling factor
          call normal (   &
               fcomp,       &    ! Work space for Component TF
               tfbeam,      &    ! Beam TF
               nx,ny,       &    ! image size
               wcl,         &    ! Selected candidate components
               ncl,   &          ! Selected Number of components
               wfft,   &         ! FFT work space
               factor)
          !!print *,'Done NORMAL '
          !
          ! Compute Clean Components
          factor = method%gain*maxabs/factor
          call scalec(   &
               wcl,         &    ! Selected candidate components
               ncl,factor,flux,   &
               comp, nx, ny)
          !!print *,'Done SCALEC '
          method%n_iter = method%n_iter+ncl
          !
          ! Remove all components by FT : RESIDU = RESIDU - BEAM # WCL(*,4)
          call remisajour (nx*ny,   &
               clean,       &    ! CLEAN map used as work space
               resid,       &    ! Updated residuals
               tfbeam,      &    ! Beam TF
               fcomp,       &    ! Work space for Component TF
               wcl,         &    ! Clean components
               ncl,         &    ! Number of Clean Components
               nx,ny,       &    ! Map size
               wfft,        &    ! FFT work space
               np, primary, weight, method%trunca)
          !!print *,'Done REMISAJOUR '
          write (chain,101)  'Cleaned ',flux,' Jy with ',   &
               method%n_iter,' clean components'
          call map_message(seve%i,rname,chain)
          !
          ! Find new extrema
          call maxlst (resid,nx,ny,list,nl,   &
               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
          !
          ! Check if converge
          fini = (maxabs.le.borne)   &
               .or. (k.gt.method%n_major)   &
               .or. converge
       else
          write(chain,101) 'No point selected above ',limite
          fini = .true.
          call map_message(seve%i,rname,chain)
       endif
       !
       ! Intermediate or final PLOT
       converge = fini
       clean(:,:) = comp               ! Use CLEAN as work space to plot it
       !!print *,'Doing MAJOR_PLOT '
       call major_plot(method,head,   &
            converge,method%n_iter,nx,ny,np,   &
            tcc,clean,resid,weight)
       !!print *,'Done MAJOR_PLOT '
       fini = converge
       !
       ! Get new list
       !    if (.not.fini) then
       !      ! Get a new list if in QUERY mode
       !      ! Query mode does not exist for MRC
       !      if (method%qcycle) then
       !        ! For MRC, method is s_method, while
       !        ! head is the normal stuff... This would create a problem
       !        call get_newmask (method,head,nl,error)
       !        !
       !        ! Reset the List in its defined range.
       !        list(1:nl) = method%list(1:nl)
       !      endif
       !    endif
    enddo
    !
    ! End
    if (maxabs.le.borne) then
       write(chain,100) 'Reached minimum flux density '
    elseif (k.ge.method%n_major) then
       write(chain,100) 'Reached maximum number of cycles'
    elseif (converge) then
       write(chain,100) 'Reached minor cycle convergence'
    else
       write(chain,100) 'End of transcendental causes'
    endif
    call map_message(seve%i,rname,chain)
    !
    ! Store the result
    clean(:,:) = comp
    !
100 format (a,i6,a,1pg10.3,a)
101 format (a,1pg10.3,a,i7,a)
  end subroutine major_sdi
  !
  subroutine normal(fcomp,tfbeam,nx,ny,wcl,ncl,wfft,factor)
    use gkernel_interfaces, only : fourt
    use cct_types
    !----------------------------------------------------------------------
    ! Support routine for SDI
    ! Subtract last major cycle components from residual map.
    !----------------------------------------------------------------------
    integer,       intent(in)    :: nx            ! X size
    integer,       intent(in)    :: ny            ! Y size
    integer,       intent(in)    :: ncl           ! Number of clean components
    type(cct_par), intent(in)    :: wcl(ncl)      ! Clean comp.
    real,          intent(in)    :: tfbeam(nx,ny) ! Beam TF
    complex,       intent(out)   :: fcomp(nx,ny)  ! TF of clean comp.
    real,          intent(inout) :: wfft(*)       ! Work array
    real,          intent(out)   :: factor        ! Max of clean
    !
    integer :: i,j,k,ndim,nn(2)
    !
    fcomp = 0.0
    do k=1,ncl
       fcomp(wcl(k)%ix,wcl(k)%iy) = cmplx(wcl(k)%influx,0.0)
    enddo
    ndim = 2
    nn(1) = nx
    nn(2) = ny
    call fourt(fcomp,nn,ndim,-1,0,wfft)
    fcomp = fcomp*tfbeam
    call fourt(fcomp,nn,ndim,1,1,wfft)
    factor = abs(real(fcomp(1,1)))
    do j=1,ny
       do i=1,nx
          factor = max(factor,abs(real(fcomp(i,j))))
       enddo
    enddo
  end subroutine normal
  !
  subroutine scalec(wcl,ncl,f,s,compon,nx,ny)
    use cct_types
    !----------------------------------------------------------------------
    ! Support routine for SDI
    ! Subtract last major cycle components from residual map.
    !----------------------------------------------------------------------
    integer,       intent(in)    :: nx            ! X size
    integer,       intent(in)    :: ny            ! Y size
    integer,       intent(in)    :: ncl           ! Number of clean components
    type(cct_par), intent(inout) :: wcl(ncl)      ! Clean comp.
    real,          intent(in)    :: f             ! Gain factor
    real,          intent(inout) :: s             ! Cumulative flux
    real,          intent(inout) :: compon(nx,ny) ! Cumulative clean component
    !
    integer :: i
    !
    do i=1,ncl
       wcl(i)%value = wcl(i)%influx*f
       s = s+wcl(i)%value
       compon(wcl(i)%ix,wcl(i)%iy) = compon(wcl(i)%ix,wcl(i)%iy) + wcl(i)%value
    enddo
  end subroutine scalec
  !
  !------------------------------------------------------------------------
  !
  subroutine major_multi(rname,method,head,&
       dirty,resid,beam,mask,clean,nx,ny,&
       tcc,miter,limit,niter,&
       smask,sresid,trans,cdata,sbeam,&
       tfbeam,wfft)
    ! Need to add
    !    &    nf, primary, weight)
    use image_def
    use gkernel_interfaces
    use mapping_interfaces
    use clean_types
    use cct_types
    use clean_multi_tool
    use clean_flux_tool, only: plot_multi
    !$  use omp_lib
    !-----------------------------------------------------------------------
    ! 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)    :: 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)    ! Dirty beam
    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(*)
    type(cct_par),    intent(out)   :: tcc(miter)
    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
    !
    integer, parameter :: ms=3
    integer, parameter :: mk=11
    integer :: ncase(ms)
    integer :: ix(ms),iy(ms)     ! Coordinates of each iteration maximum
    integer :: nker(ms)          ! Kernel size
    integer :: ns                ! Number of Kernels
    real :: scale(ms)            ! Noise level for each beam
    real :: bruit(ms)            ! Residual level for each beam
    real :: sn(ms)               ! Signal / Noise
    real :: again(ms)            ! Gain per kernel
    real :: gains(ms)            ! same after noise correction
    real :: fluxes(ms)           ! Cumulative flux per kernel
    real :: loss(ms)             ! Noise degradation factor...
    real :: kernel(mk,mk,ms)     ! Smoothing kernels
    !
    logical :: ok,plot,keep,printout,interrupt
    integer, parameter :: mcum=10
    integer :: ncum
    integer :: nn(2),ndim,kx,ky
    integer :: is,i,j,oldis,goodis
    real :: value,oldcum(mcum),converge,sign
    real :: maxa,flux,smooth,gain,maxsn,worry
    character(len=24) :: string
    character(len=message_length) :: chain
    !
    smooth = method%smooth
    gain = method%gain
    plot = method%pflux
    keep = method%keep
    nker = method%nker
    printout = method%verbose  ! Default behaviour
    again = 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
    !
    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))
    !
    sbeam(:,:,1) = beam
    loss(1) = 1.0
    scale(1) = 1.0
    gains(1) = again(1)
    !
    kx = nx/2+1
    ky = ny/2+1
    do is = 2,ns
       call smooth_kernel (beam,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
       gains(is) = again(is)
    enddo
    !
    write(chain,'(A,3(1X,1PG11.4))') 'Scales ',scale
    call map_message(seve%i,rname,chain)
    write(chain,'(A,3(1X,1PG11.4))') 'Noise ',loss
    call map_message(seve%i,rname,chain)
    !
    ! Main clean loop
    niter = 0
    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
    !
    do           ! For ever...
       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
       !
       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.eq.0) maxsn = sn(goodis)
       !
       ! Check criterium
       ok = niter.lt.miter
       ok = ok .and. abs(bruit(1)).ge.limit
       if (.not.ok) exit
       if (sn(goodis).gt.maxsn) then
          write(chain,'(a,f14.7,2(x,f14.7))') 'S/N has degraded: ',sn(goodis),maxsn,&
               abs(2*(sn(goodis)-maxsn)/(sn(goodis)+maxsn))
          call map_message(seve%d,rname,chain)
       endif
       maxsn = worry*sn(goodis)+(1.0-worry)*maxsn  ! Propagate S/N estimate
       !
       niter = niter+1
       !
       tcc(niter)%value = gains(goodis)*bruit(goodis)
       tcc(niter)%ix = ix(goodis)
       tcc(niter)%iy = iy(goodis)
       tcc(niter)%type = goodis
       !
       ! Do not Scale component flux : See Note Later
       flux = flux + tcc(niter)%value*scale(goodis)
       !
       oldcum(ncum) = flux
       ncum = ncum+1
       if (ncum.gt.mcum) ncum = 1
       converge = sign * (flux - oldcum(ncum))
       !
       ! 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%r,rname,chain)
          oldis = goodis
       endif
       ncase(goodis) = ncase(goodis)+1
       ! Scale cumulative flux : See Note Later
       fluxes(goodis) = fluxes(goodis) + gains(goodis)*bruit(goodis)*scale(goodis)
       if (plot) then
          is = goodis
          call plot_multi (niter,flux,is)
       endif
       !
       ! Subtract from residual
       maxa = -again(goodis)*bruit(goodis)
       !
       ! Translate appropriate beam
       kx = ix(goodis)-nx/2-1
       ky = iy(goodis)-ny/2-1
       !
       !$    ! print *,'In parallel ',omp_in_parallel()
       !$OMP PARALLEL &
       !$OMP  & SHARED(nx,ny,kx,ky,goodis,trans)  PRIVATE(i,j)
       !$OMP DO
       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)
          enddo
       enddo
       !$OMP END DO
       !
       ! Why not subtract everywhere ?
       !     resid = resid + maxa*trans
       !    where (smask)
       !      resid = resid + maxa*trans
       !    end where
       !$OMP DO
       do j=1,ny
          do i=1,nx
             resid(i,j) = resid(i,j) + maxa * trans(i,j)
             trans(i,j) = 0.0
          enddo
       enddo
       !$OMP END DO
       !$OMP END PARALLEL
       if (.not.keep) 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 ((.not.keep).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%i,rname,chain)
    do is=1,ns
       write(chain,105) '#',is,' Ncomp ',ncase(is),' Flux ',fluxes(is)
       call map_message(seve%i,rname,chain)
    enddo
    !
    ! 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
    !
    write(chain,'(A,1PG11.4)') 'Cleaned flux ',flux
    call map_message(seve%i,rname,chain)
    do i=1,niter
       value = tcc(i)%value
       kx = tcc(i)%ix
       ky = tcc(i)%iy
       is = tcc(i)%type
       if (is.eq.1) then
          clean (kx,ky) = clean(kx,ky) + value
       else
          call add_kernel (clean,nx,ny,value,kx,ky,mk,nker(is),kernel(:,:,is))
       endif
    enddo
    !
    ! Final residual
    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)
    !
    ! 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,1pg11.4,1x,1pg11.4)
105 format(a,i1,a,i5,a,1pg11.4)
  end subroutine major_multi
end module clean_cycle_tool
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
