subroutine remisajour (nxy,clean,resid,tfbeam,fcomp,   &
     &    wcl,ncl,nx,ny,wfft,   &
     &    np,primary,weight,wtrun)
  use gkernel_interfaces, only : fourt
  use clean_def
  !----------------------------------------------------------------------
  ! @ public
  !
  ! MAPPING
  !   CLEAN   Internal routine
  !   Subtract last major cycle components from residual map.
  !----------------------------------------------------------------------
  integer, intent(in) :: nxy      ! Problem size
  integer, intent(in) :: nx,ny    ! Problem size
  integer, intent(in) :: ncl      ! Number of clean components
  integer, intent(in) :: np       ! Number of primary beams
  type(cct_par), intent(in) :: wcl(ncl)   ! Clean component list
  real, intent(in) :: tfbeam(nx,ny,np)    ! TF of dirty beams
  complex, intent(inout) :: fcomp(nx,ny)  ! Work area
  real, intent(inout) :: clean(nx,ny)     ! Clean map
  real, intent(inout) :: resid(nx,ny)     ! Residual map
  real, intent(in) :: primary(np,nx,ny)   ! Primary beams
  real, intent(in) :: weight(nx,ny)       ! Flat field weights
  real, intent(in) :: wtrun               ! Truncation of mosaic
  real, intent(in) :: wfft(*)             ! work fft area
  !
  integer i,j,k,ndim,nn(2),ip
  !
  ndim = 2
  nn(1) = nx
  nn(2) = ny
  if (np.eq.1) then
    fcomp = 0.0
    do k = 1,ncl
      fcomp(wcl(k)%ix,wcl(k)%iy) = cmplx(wcl(k)%value,0.0)
    enddo
    call fourt(fcomp,nn,ndim,-1,0,wfft)
    fcomp = fcomp*tfbeam(:,:,1)
    call fourt(fcomp,nn,ndim,1,1,wfft)
    resid = resid-real(fcomp)
  else
    !
    ! Optimized by using CLEAN to store sum of components before multiplying
    ! by the weights to subtract from the Residuals
    clean = 0.0
    do ip=1,np
      fcomp = 0.0
      do k=1,ncl
        fcomp(wcl(k)%ix,wcl(k)%iy) = wcl(k)%value   &
     &          * primary(ip,wcl(k)%ix,wcl(k)%iy)
      enddo
      call fourt(fcomp,nn,ndim,-1,0,wfft)
      fcomp = fcomp*tfbeam(:,:,ip)
      call fourt(fcomp,nn,ndim,1,1,wfft)
      do j=1,ny
        do i=1,nx
          if (primary(ip,i,j).gt.wtrun) then
            clean(i,j) = clean(i,j) + real(fcomp(i,j))   &
     &              *primary(ip,i,j)
          endif
        enddo
      enddo
    enddo
    resid = resid - clean*weight
  endif
end subroutine remisajour
!
subroutine soustraire (wcl,ncl,        &
     &    dirty,nx,ny,ixbeam,iybeam,   &
     &    ixpatch,iypatch,kcl,gain,    &
     &    nf, primary, weight, wtrun)
  use clean_def
  !$ use omp_lib
  !----------------------------------------------------------------------
  ! @ public
  !
  ! GILDAS: CLEAN   Internal routine
  ! Subtract the clean component, convolved with dirty beam
  ! restricted to beam patch, from the list of selected points.
  ! Caution : points must be ordered according I and J
  !----------------------------------------------------------------------
  integer, intent(in) :: nf                   ! Number of fields
  integer, intent(in) :: ncl                  ! nombre de points retenus
  integer, intent(in) :: nx,ny,ixbeam,iybeam  ! dimension et centre du beam
  real, intent(in) :: dirty(nx,ny,nf)         ! Dirty Beam
  integer, intent(in) :: ixpatch,iypatch      ! taille du centre BEAM retenu
  type(cct_par), intent(inout) :: wcl(ncl)
  integer, intent(in) :: kcl                  ! No de la composante introduite
  real, intent(in) :: gain                    ! gain de clean
  real, intent(in) :: primary (nf,nx,ny)      ! Primary beams
  real, intent(in) :: weight (nx,ny)          ! Effective weights on sky
  real, intent(in) :: wtrun
  !
  logical condi,condj,cond,go_on     ! pour les boucles de soustraction
  integer no                   ! No du point courrant
  real f                       ! coefficient a retrancher
  integer k,l
  ! dans la carte du beam translatee sur la composante
  integer l0,k0                ! translation * du beam % a la composante
  integer i0,j0, i,j, if, fo, lo, ithread
  !
  ! Subtract current component
  i0 = wcl(kcl)%ix
  j0 = wcl(kcl)%iy
  k0 = i0 - ixbeam
  l0 = j0 - iybeam
  f = gain * wcl(kcl)%influx
  wcl(kcl)%influx = wcl(kcl)%influx - f      ! This property is always true
  if (nf.gt.1) then
    f = f * weight(i0,j0)      ! Convert to Clean Component
  else
    f = f / dirty(ixbeam,iybeam,1)
  endif
  !
  lo = kcl + 1
  fo = kcl - 1
  go_on = .true.
!$OMP PARALLEL &
!$OMP &   SHARED(f,wcl,dirty,fo,lo)  FIRSTPRIVATE(go_on) &
!$OMP &   PRIVATE(no,i,j,k,l,condi,condj,if)
!$  ithread = omp_get_thread_num()
!$  !Print *,"Number of threads ",omp_get_num_threads(),ithread
!$OMP DO ORDERED
  ! Subtract from current component to last valid.
  do no = lo,ncl
    if (go_on) then
      i = wcl(no)%ix
      j = wcl(no)%iy
      k = i-k0
      l = j-l0
      condi = abs(k-ixbeam) .lt. ixpatch
      condj = abs(l-iybeam) .lt. iypatch
      cond  = condi .or. condj
      if (.not.cond) then
        go_on = .false.
      else
        !
        if ( (condi.and.condj) .and. (k.gt.0 .and. k.le.nx)   &
         &      .and. (l.gt.0 .and. l.le.ny) ) then
          if (nf.gt.1) then
            do if = 1,nf
              if (primary(if,i,j).gt.wtrun) then
                wcl(no)%influx = wcl(no)%influx - f*dirty(k,l,if)   &
         &              *primary(if,i0,j0)*primary(if,i,j)   &
         &              *weight(i,j)
              endif
            enddo
          else
            wcl(no)%influx = wcl(no)%influx - f*dirty(k,l,1)
          endif
        endif
      endif
    endif
  enddo
  !
!$OMP END DO
  go_on = .true.
!$OMP DO ORDERED
  ! Now subtract from first valid to current component
  do no = fo,1,-1
    if (go_on) then
      i = wcl(no)%ix
      j = wcl(no)%iy
      k = i-k0
      l = j-l0
      condi = abs(k-ixbeam) .lt. ixpatch
      condj = abs(l-iybeam) .lt. iypatch
      cond  = condi .or. condj
      if (.not.cond) then
        go_on = .false.
      else
        !
        if ( (condi.and.condj) .and. (k.gt.0 .and. k.le.nx)   &
         &      .and. (l.gt.0 .and. l.le.ny) ) then
          if (nf.gt.1) then
            do if = 1,nf
              if (primary(if,i,j).gt.wtrun) then
                wcl(no)%influx = wcl(no)%influx - f*dirty(k,l,if)   &
         &              *primary(if,i0,j0)*primary(if,i,j)   &
         &              *weight(i,j)
              endif
            enddo
          else
            wcl(no)%influx = wcl(no)%influx - f*dirty(k,l,1)
          endif
        endif
      endif
    endif
  enddo
!$OMP END DO
!$OMP END PARALLEL
end subroutine soustraire
!
subroutine comshi (beam,nx,ny,ix,iy,shift)
  use gbl_message
  !-----------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Shift beam if needed
  !-----------------------------------------------------
  integer, intent(in) :: nx,ny     ! X,Y Size
  integer, intent(in) :: ix,iy     ! Position of maximum
  real, intent(in) :: beam(nx,ny)  ! Beam
  integer, intent(out) :: shift(3) ! Shift information
  !
  real tol
  !
  ! Attempt to find where is the true maximum of the (SYMMETRIC) beam
  ! based on a fit by a parabola in 9 points around maximum
  !
  tol = 1e-4*beam(ix,iy)
  shift(3) = 1
  if (abs(beam(ix-1,iy-1)-beam(ix+1,iy+1)).lt.tol) then
    shift(1) = 0
    shift(2) = 0
    shift(3) = 0
  elseif (abs(beam(ix+1,iy+1)-beam(ix,iy)).lt.tol) then
    shift(1) = 1
    shift(2) = 1
  elseif (abs(beam(ix-1,iy-1)-beam(ix,iy)).lt.tol) then
    shift(1) = -1
    shift(2) = -1
  elseif (abs(beam(ix+1,iy-1)-beam(ix,iy)).lt.tol) then
    shift(1) =  1
    shift(2) = -1
  elseif (abs(beam(ix-1,iy+1)-beam(ix,iy)).lt.tol) then
    shift(1) = -1
    shift(2) = 1
  elseif (abs(beam(ix+1,iy-1)-beam(ix,iy+1)).lt.tol) then
    shift(1) = 1
    shift(2) = 0
  elseif (abs(beam(ix-1,iy-1)-beam(ix,iy+1)).lt.tol) then
    shift(1) = -1
    shift(2) = 0
  elseif (abs(beam(ix-1,iy-1)-beam(ix+1,iy)).lt.tol) then
    shift(1) = 0
    shift(2) = -1
  elseif (abs(beam(ix-1,iy+1)-beam(ix+1,iy)).lt.tol) then
    shift(1) = 0
    shift(2) = 1
  else
    call map_message(seve%w,'SHIFT','Unknown beam symmetry')
    shift(1) = 0
    shift(2) = 0
    shift(3) = 0
  endif
end subroutine comshi
!
subroutine domima(a,rmi,rma,imi,ima,n)
  !----------------------------------------------------------
  ! @ public
  !
  ! MAPPING
  !   Compute minmax and location
  !----------------------------------------------------------
  integer, intent(in) :: n
  integer, intent(out) :: ima,imi
  real, intent(in) ::  a(n)
  real, intent(inout) :: rmi,rma
  !
  integer :: i
  !
  ima = 0
  imi = 0
  if (a(1).gt.rma) then
    rma = a(1)
    ima = 1
  endif
  if (a(1).lt.rmi) then
    rmi = a(1)
    imi = 1
  endif
  do i=2,n
    if (a(i).gt.rma) then
      rma = a(i)
      ima = i
    elseif (a(i).lt.rmi) then
      rmi = a(i)
      imi = i
    endif
  enddo
end subroutine domima
