subroutine sub_alma_quad (   &
     &    l_method,l_hdirty,l_hresid,l_hclean,   &
     &    l_hbeam,l_hprim,l_tfbeam, l_list,  &
     &    c_method,c_hdirty,c_hresid,c_hclean,   &
     &    c_hbeam,c_hprim,c_tfbeam, c_list,  &
     &    error,tcc)
  use gkernel_interfaces
  use imager_interfaces, except_this=>sub_alma_quad
  use clean_def
  use image_def
  use gbl_message
  !--------------------------------------------------------------
  ! @ private
  !
  ! MAPPING   Clean/Mosaic
  !     Perfom a CLEAN based on all CLEAN algorithms,
  !     except the Multi Resolution which requires a different tool
  !     Works for mosaic also, except for the Multi Scale clean
  !     (not yet implemented for this one, but feasible...)
  !--------------------------------------------------------------
  type (clean_par), intent(inout) :: l_method, c_method
  type (gildas), intent(inout)  :: l_hdirty, l_hbeam, l_hresid, l_hprim
  type (gildas), intent(inout)  :: l_hclean
  type (gildas), intent(inout)  :: c_hdirty, c_hbeam, c_hresid, c_hprim
  type (gildas), intent(inout)  :: c_hclean
  real, intent(inout) :: l_tfbeam(l_hbeam%gil%dim(2),l_hbeam%gil%dim(3),l_hbeam%gil%dim(1))
  real, intent(inout) :: c_tfbeam(c_hbeam%gil%dim(2),c_hbeam%gil%dim(3),c_hbeam%gil%dim(1))
  logical, intent(inout) :: error
  type (cct_par), intent(inout) :: tcc(l_method%m_iter)
  integer, intent(in) :: l_list(:)  ! List of searched pixels
  integer, intent(in) :: c_list(:)  ! List of searched pixels (compact array)
  !
  real, pointer :: c_dirty(:,:)    ! Dirty map
  real, pointer :: c_resid(:,:)    ! Iterated residual
  real, pointer :: c_clean(:,:)    ! Clean Map
  real, pointer :: c_dprim(:,:,:)  ! Primary beam
  real, pointer :: c_dbeam(:,:,:)  ! Dirty beam (per field)
  real, pointer :: c_atten(:,:)
  !
  real, pointer :: l_dirty(:,:)    ! Dirty map
  real, pointer :: l_resid(:,:)    ! Iterated residual
  real, pointer :: l_clean(:,:)    ! Clean Map
  real, pointer :: l_beam(:,:) ! Beam for fit
  real, pointer :: l_dprim(:,:,:)  ! Primary beam
  real, pointer :: l_dbeam(:,:,:)  ! Dirty beam (per field)
  real, pointer :: l_atten(:,:)
  !
  real, allocatable :: w_fft(:) ! TF work area
  complex, allocatable :: w_work(:,:)  ! Work area
  complex, allocatable :: c_work(:,:)  ! Expansion of residual
  real, allocatable :: r_work(:,:) ! Expansion of residual
  type(cct_par), allocatable :: w_comp(:)
  real, allocatable :: w_cctw(:,:), w_cctf(:,:)
  real, allocatable :: w_resid(:,:)
  type (cct_par), allocatable :: w_tcc(:)
  !
  integer icase, iext
  real last_flux, max_var, cpu0, cpu1
  integer iplane,ibeam
  integer nx,ny,np,mx,my,mp,nc
  integer ier, ix, iy, jx, jy, ncc
  real l_max, c_max
  logical do_fft, ok
  character(len=message_length) :: chain
  character(len=4) :: rname = 'ALMA'
  character(2) ans
  integer nker,mker
  parameter (mker=13)
  real smooth, default_thre
  real, allocatable :: kernel(:,:)
  integer, allocatable :: labelo(:,:)
  real, allocatable :: values(:)
  integer, allocatable :: xcoord(:),ycoord(:)
  real noise,scale,fhat,long,compact, factor, thre
  integer n_ext, kx, ky, kf, n_areas
  logical do_long, more
  integer type_long, type_compact,last_type
  parameter (type_long=1)
  parameter (type_compact=2)
  !
  error = .false.
  do_fft = .true.
  factor = 0.0
  chain = 'Using SUB_ALMA_QUAD of 20-Nov-2001'
  call map_message(seve%i,rname,chain)
  !
  ! Local variables
  nx = l_hclean%gil%dim(1)
  ny = l_hclean%gil%dim(2)
  np = l_hprim%gil%dim(1)
  mx = c_hbeam%gil%dim(1)
  my = c_hbeam%gil%dim(2)
  mp = c_hprim%gil%dim(1)
  nc = nx*ny
  !
  allocate (w_work(nx,ny),stat=ier)
  allocate (r_work(nx,ny),stat=ier)
  allocate (c_work(mx,my),stat=ier)
  allocate (w_fft(max(nx,ny)),stat=ier)
  allocate (w_comp(nc),stat=ier)
  !
  ! Global residuals
  allocate (w_resid(nx,ny),stat=ier)
  !
  allocate (w_tcc(nx*ny),stat=ier) ! Temporary Clean Component Array
  allocate (w_cctf(nx,ny),stat=ier)    ! Final Clean Components
  allocate (w_cctw(nx,ny),stat=ier)
  !
  ! Some global pointers
  l_dprim => l_hprim%r3d
  l_dbeam => l_hbeam%r3d
  l_atten => l_method%atten(:,:,1)
  c_dprim => c_hprim%r3d
  c_dbeam => c_hbeam%r3d
  c_atten => c_method%atten(:,:,1)
  !
  ! Relative noise contributions
  long = 1.0/l_hdirty%gil%noise**2
  compact = 1.0/c_hdirty%gil%noise**2
  noise = sqrt(long/compact)   ! Mean noise RATIO
  scale = long+compact
  long = long/scale
  compact = compact/scale
  !
  ! Initialize the kernel
  smooth = c_method%smooth
  if (smooth.eq.0) then
     nker = 1
  elseif  (smooth.lt.2) then
     nker = 5
  elseif  (smooth.lt.4) then
     nker = 9
  else
     nker = 13
  endif
  !
  allocate(kernel(nker,nker),stat=ier)
  call init_kernel(kernel,nker,nker,smooth)
  !
  kx = mx/2
  ky = my/2
  kf = kx*ky
  allocate (labelo(kx,ky),stat=ier)
  allocate (xcoord(kf),ycoord(kf),values(kf),stat=ier)
  !
  do_long = c_method%n_major.gt.0
  last_type = type_long
  tcc%type = 1
  !
  max_var = 0.005              ! Default value of flux stability
  call sic_get_real('F_THRES',max_var,error)
  default_thre = 0
  call sic_get_real('D_THRES',default_thre,error)
  if (default_thre.lt.0 .or. default_thre.gt.0.9) default_thre = 0.0
  !
  call gag_cpu (cpu0)
  if (l_method%pcycle) then
     call mrc_plot(c_resid,mx,my,1,'Compact')
  endif
  !
  ! Loop here if needed
  do iplane = l_method%first, l_method%last
     last_flux = 0.0
     more = .false.
     icase = 0
     write(chain,'(A,I6)') 'Starting loop ',iplane
     call map_message(seve%i,rname,chain)
     l_method%flux = 0.0
     c_method%flux = 0.0
     l_method%n_iter= 0
     c_method%n_iter= 0
     !
     l_method%iplane = iplane
     c_method%iplane = iplane
     call beam_plane(l_method,l_hbeam,l_hdirty)
     ibeam = l_method%ibeam
     c_method%ibeam = ibeam ! Was missing S.Guilloteau
     !
     ! Local aliases
     l_dirty => l_hdirty%r3d(:,:,iplane)
     l_resid => l_hresid%r3d(:,:,iplane)
     l_clean => l_hclean%r3d(:,:,iplane)
     l_beam  => l_hbeam%r3d(:,:,ibeam)
     !
     c_dirty => c_hdirty%r3d(:,:,iplane)
     c_resid => c_hresid%r3d(:,:,iplane)
     c_clean => c_hclean%r3d(:,:,iplane)
     !
     ! Initialize to Dirty map
     l_resid = l_dirty
     c_resid = c_dirty
     !
     ! Prepare beam parameters
     call get_clean (l_method, l_hbeam, l_beam, error)
     if (error) return
     !!Print *,'Done GET_CLEAN'
     !!Print *,'_______'
     !!Print *,'L_METHOD'
     !!call debug (l_method)
     call get_beam (l_method,l_hbeam,l_hresid,l_hprim,   &
          &        l_tfbeam,w_work,w_fft,fhat,error)
     if (error) return
     !
     !!Print *,'Done GET_BEAM Long'
     !!Print *,'_______'
     !!Print *,'C_METHOD'
     !!call debug (c_method)
     call get_beam (c_method,c_hbeam,c_hresid,c_hprim,   &
          &        c_tfbeam,w_work,w_fft,fhat,error)
     if (error) return
     !!Print *,'Done GET_BEAM Compact'
     l_resid = l_resid * l_atten
     c_resid = c_resid * c_atten
     !
     ! Performs decomposition into components:
     ! Only one major cycle per iteration, with a limited number
     ! of components ?
     !
     ans = ' '
     l_method%ngoal = 1000
     !
     ! Locate the maximum of the Compact & Normal images
     l_max = imaxlst (l_method,l_list,l_resid,nx,ny,ix,iy)
     c_max = imaxlst (c_method,c_list,c_resid,mx,my,jx,jy)
     ok = l_max.gt.l_method%ares .or. c_max.gt.c_method%ares
     do while (ok)
        !
        ! Plot for debug
        if (l_method%pcycle) then
           call mrc_clear
           call mrc_plot(c_resid,mx,my,2,'Compact')
           call mrc_plot(l_resid,nx,ny,3,'Long')
        endif
        !
        ! NOISE is the Noise RATIO (mean value over the beams)
        !
        if (l_max.gt.c_max/noise .or. do_long) then
           last_type = type_long  ! Use LONG baselines
        else
           ! May be using Compact baselines only. Check sign however
           l_max = l_resid(ix,iy)
           c_max = c_resid(jx,jy)
           if (default_thre.ne.0) then
              thre = default_thre
           else
              thre = min(0.3,c_method%bgain)
           endif
           last_type = type_compact
           if (c_max*l_max .lt. 0) then
              ! Use higher threshold
              last_type = type_compact
              thre = max(0.7,thre)
           endif
        endif
        !
        if (last_type.eq.type_long) then
           l_max = abs(l_max)
           if (l_method%verbose) then
              write(chain,*) 'Using LONG baselines ',   &
                   &            l_max,c_max/noise
              call map_message(seve%i,rname,chain)
           endif
           if (l_method%qcycle) then
              call sic_wpr('WAIT ? ',ans)
           endif
           !
           ! Find components in LONG baseline image
           !!Print *,'Calling ONE_CYCLE90'
           call one_cycle90 (l_method,l_hclean,   &   !
                &          l_clean,   &   ! Final CLEAN image
                &          l_dbeam,   &   ! Dirty beams
                &          l_resid,nx,ny,   & ! Residual and size
                &          l_tfbeam, w_work,   &  ! FT of dirty beam + Work area
                &          w_comp, nc,   &    ! Component storage + Size
                &          l_method%beam0(1),l_method%beam0(2),   &   ! Beam center
                &          l_method%patch(1),l_method%patch(2),   &
                &          l_method%bgain,l_method%box,   &
                &          w_fft,   &     ! Work space for FFTs
                &          tcc,   &       ! Component table
                &          l_list, l_method%nlist,   & ! Search list
                &          np,   &        ! Number of fields
                &          l_dprim,   &   ! Primary beams
                &          l_atten,   &  ! Weight
                &          l_max)
           !
           if (l_method%verbose) then
              write(chain,*) 'Flux ',last_flux,l_method%flux
              call map_message(seve%i,rname,chain)
           endif
           l_max = imaxlst (l_method,l_list,l_resid,nx,ny,ix,iy)
           !
           ! Define component type
           tcc(c_method%n_iter+1:l_method%n_iter)%type = 0
           ! Remove from COMPACT baselines
           !!Print *,'Calling REMOVE_INCOMPACT'
           call remove_incompact(c_method,c_resid,mx,my,   &
                &          c_tfbeam, w_fft,mp,c_dprim,c_atten,   &
                &          tcc,c_method%n_iter+1,l_method%n_iter,nx,ny)
           ! Transform Clean Components to Map Type Storage
           !!Print *,'Calling LONG_TO_IMAGE ', l_method%n_iter-c_method%n_iter
           call  long_to_image (tcc(c_method%n_iter+1),   &
                &          l_method%n_iter-c_method%n_iter,w_cctw,nx,ny)
           ! Add them to Final Clean Storage
           !!Print *,'Moving CCT'
           w_cctf(:,:) = w_cctf + w_cctw
           ! Define number of iterations and type
           tcc(c_method%n_iter+1:l_method%n_iter)%type = 0
           c_method%n_iter = l_method%n_iter
           c_method%flux = l_method%flux
           !
           do_long = .false.
           ! SG Test
           ! Force recomputation of SDI scaling factor
           factor = 0.0
           !
           ! Long baseline
           !!Print *,'Moving to next'
        else
           if (l_method%verbose) then
              write(chain,*) 'Using COMPACT baselines ',   &
                   &            l_max,c_max/noise
              call map_message(seve%i,rname,chain)
           endif
           if (l_method%qcycle) then
              call sic_wpr('WAIT ? ',ans)
           endif
           !
           ! Select extended area around this maximum
           thre = thre * c_max
           !
           xcoord = 0
           labelo = 0
           !
           !!Print *,'Calling THRESHOLD'
           call sub_threshold (c_resid,mx,my,   & ! Initial image and size
                &          c_method%blc,c_method%trc,   & ! Image area
                &          labelo,kx,ky,   &  ! Subset Image of area numbers
                &          n_areas,   &   ! Number of areas
                &          xcoord,   &    ! Work space for area numbers
                &          ycoord,kf,   & ! Area numbers
                &          thre,0.0,-1.0) ! Threshold and blanking
           if (l_method%verbose) then
              write(chain,*) 'Found ',n_areas,' areas above ',thre
              call map_message(seve%i,rname,chain)
           endif
           !
           ! Test
           if (more) icase = 1
           !
           ! Select the appropriate region and put them to TCC array
           ! Gain is not applied yet
           call label_to_cct (c_resid,mx,my,   &
                &          c_method,   &  ! Image area
                &          labelo,kx,ky,   &  ! Subset Image of area numbers
                &          w_tcc,n_ext,jx,jy, icase)
           write(chain,'(A,I6,A,1pg10.3)')   &
                &  'Selected ',n_ext,' components above ',thre
           call map_message(seve%i,'COMPACT',chain)
           !
           ! Compute the scale factor
           call cct_normal (w_tcc,n_ext,   &
                &          w_work,c_tfbeam,mx,my,w_fft,factor)
           factor = abs(c_max)/factor
           ! Scale the components
           do iext=1,n_ext  ! Circumvent GFORTRAN bug
              w_tcc(iext)%value = w_tcc(iext)%value *   &
                   &          c_method%gain * factor
           enddo
           !
           ! Transform Clean Components to Map Type Storage
           call  compact_to_image (c_method,mx,my,   &
                &          w_tcc,n_ext,   &
                &          r_work,nx,ny)
           !
           ! Smooth them by a kernel
           call smooth_kernel(r_work,w_cctw,nx,ny,nker,nker,kernel)
           !
           ! Transform them back to the TCC representation
           call image_to_long(w_cctw,nx,ny,w_tcc,nx*ny,ncc)
           !
           ! Compute flux, and plot
           call display_cct(c_method,w_tcc,ncc,l_method%n_iter)
           !
           ! Store component (temporary patch)
           if (l_method%n_iter+ncc-1.le.l_method%m_iter) then
              c_method%n_iter = l_method%n_iter+ncc-1
              tcc(l_method%n_iter+1:c_method%n_iter) = w_tcc(1:ncc)
              l_method%n_iter = c_method%n_iter
           else
              ok = .false.
           endif
           !
           ! Remove List in Compact Baselines
           call remove_incompact(c_method,c_resid,mx,my,   &
                &          c_tfbeam, w_fft,mp,c_dprim,c_atten,   &
                &          w_tcc,1,ncc,nx,ny)
           !
           ! Remove List in Long Baselines
           call remove_inlong(l_method,l_resid,nx,ny,   &
                &          l_tfbeam, w_fft,np,l_dprim,l_atten,   &
                &          w_tcc,1,ncc)
           !
           ! Add to final component representation
           w_cctf(:,:) = w_cctf + w_cctw
           ! Define number of components
           !                  L_METHOD%N_ITER = C_METHOD%N_ITER
           l_method%flux = c_method%flux
           write(chain,'(A,1PG11.4,A,I6,A)')  'Cleaned ',c_method%flux,   &
           &  ' Jy in ',c_method%n_iter,' components'
           call map_message(seve%i,'COMPACT',chain)
           !
        endif
        ! Stop if done
        l_max = imaxlst (l_method,l_list,l_resid,nx,ny,ix,iy)
        c_max = imaxlst (c_method,c_list,c_resid,mx,my,jx,jy)
        ok = ok .and. (l_max.gt.l_method%ares   &
             &        .or. c_max.gt.c_method%ares)
        if (l_method%n_iter.ge.l_method%m_iter) ok = .false.
        if (sic_ctrlc()) ok = .false.
        !
        if (ans.eq.'Q') ok = .false.
        ! Continue with ALMA only if not enough components yet
        if (l_method%n_iter .lt. c_method%n_major)   &
             &        do_long = .true.
        !
        ! Define Compact Cycle Type
        more = abs ((last_flux-l_method%flux)   &
             &        /l_method%flux).lt.max_var
        if (l_method%verbose) then
           write(chain,*) (last_flux-l_method%flux)/l_method%flux,   &
                &          max_var,more
           call gagout(chain)
        endif
        last_flux = l_method%flux
     enddo
     !
     ! Add clean components and residuals to produce clean map
     if (l_method%n_iter.ne.0) then
        call alma_make (l_method, l_hclean, tcc)
     else
        l_clean = 0
     endif
     !
     ! Which residual should be added ?...
     ! We do not want to add noise, but to combine it properly...
     ! We may need to go to the full combined gridding business here...
     l_clean = l_clean + l_resid * l_atten * long
     c_clean = c_resid * c_atten * compact
     call expand (nx,ny,r_work,w_work,mx,my,c_clean,c_work,w_fft)
     where (l_atten.lt.l_method%trunca)
        r_work = 0
     end where
     l_clean = l_clean + r_work
  enddo
  call gag_cpu (cpu1)
  write(chain,*) 'CPU used ',cpu1-cpu0
  call map_message(seve%i,rname,chain)
  !
  ! Cleanup
  deallocate (w_work,r_work,c_work)
  deallocate (w_fft,w_comp,w_resid)
  deallocate (kernel)
  deallocate (labelo,xcoord,ycoord,values)
end subroutine sub_alma_quad
!
subroutine label_to_cct (image,nx,ny,c_method,label,mx,my,   &
     &    tcc,nv,ix,iy, icase)
  !
  use clean_def
  use gbl_message
  ! @ private
  type (clean_par), intent(in) :: c_method
  type (cct_par), intent(inout) :: tcc(*)
  integer, intent(in) :: nx,ny,mx,my,ix,iy
  integer, intent(out) :: nv
  real(4), intent(in) :: image(nx,ny)
  integer, intent(in) :: label(mx,my)
  integer, intent(in) :: icase
  !
  integer i,j,ii,jj,label0,i0,j0
  logical doit
  character(len=message_length) :: chain
  character(len=4) :: rname = 'ALMA'
  !
  i0 = c_method%blc(1)
  j0 = c_method%blc(2)
  label0 = label(ix-i0+1,iy-j0+1)
  nv = 0
  if (icase.eq.0) then
    write(chain,'(A,I6,A)') 'Selected field ',label0,' only'
  else
    chain = 'Selected all fields'
  endif
  call map_message(seve%i,rname,chain)
  !
  do j=1,my
    do i=1,mx
      if (icase.eq.0) then
        doit = label(i,j).eq.label0
      else
        doit = label(i,j).ne.0
      endif
      if (doit) then
        nv = nv+1
        ii = i0+i-1
        jj = j0+j-1
        tcc(nv)%value = image(ii,jj) *   &
            &          c_method%atten(ii,jj,1)*c_method%gain
        tcc(nv)%ix = ii
        tcc(nv)%iy = jj
      endif
    enddo
  enddo
end subroutine label_to_cct
!
subroutine long_to_image (tcc,ncc,image,nx,ny)
  use clean_def
  ! @ private
  integer, intent(in) :: nx,ny,ncc
  type (cct_par), intent(in) :: tcc(ncc)
  real, intent(inout) :: image(nx,ny)
  !
  integer ix,iy,ic
  image = 0.0
  do ic = 1,ncc
    ix = tcc(ic)%ix
    iy = tcc(ic)%iy
    image(ix,iy) = image(ix,iy) + tcc(ic)%value
  enddo
end subroutine long_to_image
!
subroutine image_to_long (image,nx,ny,tcc,mcc,ncc)
  use clean_def
  ! @ private
  integer, intent(in) :: nx,ny,mcc
  integer, intent(out) :: ncc
  type (cct_par), intent(out) :: tcc(mcc)
  real, intent(in) :: image(nx,ny)
  !
  integer ix,iy,ic
  ic = 0
  do iy=1,ny
    do ix=1,nx
      if (image(ix,iy).ne.0.0) then
        ic = ic+1
        tcc(ic)%ix = ix
        tcc(ic)%iy = iy
        tcc(ic)%value = image(ix,iy)
      endif
    enddo
  enddo
  ncc = ic
end subroutine image_to_long
!
subroutine display_cct(method,tcc,ncc,ioff)
  use clean_def
  ! @ private
  integer, intent(in) :: ncc
  type(clean_par), intent(inout) :: method
  type(cct_par), intent(in) :: tcc(ncc)
  integer, intent(in) :: ioff
  ! Local
  integer ic
  !$$$ character(1) ans
  !
  do ic=1,ncc
    method%flux = method%flux + tcc(ic)%value
    !$$$         IF (METHOD%FLUX.LT.0) THEN
    !$$$            PRINT *,'Method%flux ',IC,METHOD%FLUX
    !$$$            PRINT *,IC,TCC(IC)
    !$$$            PRINT *,IC-1,TCC(IC-1)
    !$$$            PRINT *,IC-1,TCC(IC-2)
    !$$$            CALL SIC_WPR('What ',ANS)
    !$$$         ENDIF
    if (method%pflux) then
      call draw(dble(ic+ioff),dble(method%flux))
      call gr_out
    endif
  enddo
end subroutine display_cct
!
subroutine cct_normal (tcc,nc,fcomp,tfbeam,nx,ny,wfft,factor)
  !----------------------------------------------------------------------
  ! @ private
  !
  ! GILDAS: CLEAN   Internal routine
  !   Compute the SDI normalisation factor
  !----------------------------------------------------------------------
  use clean_def
  integer, intent(in) :: nx,ny,nc
  type (cct_par), intent(in) :: tcc(nc)
  real, intent(in) :: tfbeam(nx,ny)
  complex, intent(inout) :: fcomp(nx,ny)
  real, intent(inout) :: wfft(*)
  real factor
  !
  integer i,j,k,ndim,nn(2)
  !
  fcomp = 0.0
  do k=1,nc
     fcomp(tcc(k)%ix,tcc(k)%iy) = cmplx(tcc(k)%value,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 cct_normal
!
subroutine choice_to_cct (c_method,tcc,nc,xcoord,ycoord,values)
  use clean_def
  !----------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING   Internal routine
  !   Put the selected components into the TCC structure
  !----------------------------------------------------------------------
  type (clean_par), intent(in) :: c_method
  integer, intent(in) :: nc
  type (cct_par), intent(inout) :: tcc(nc)
  integer, intent(in) :: xcoord(nc), ycoord(nc)
  real, intent(in) :: values(nc)
  !
  integer ic,ix,iy
  !
  do ic = 1,nc
    ix = xcoord(ic)
    iy = ycoord(ic)
    tcc(ic)%ix = ix
    tcc(ic)%iy = iy
    tcc(ic)%value = values(ic) * c_method%atten(ix,iy,1)
  enddo
end subroutine choice_to_cct
!
subroutine compact_to_image (c_method,mx,my,tcc,ncc,image,nx,ny)
  use clean_def
  !----------------------------------------------------------------------
  ! @ private
  !
  ! MAPPING   Internal routine
  !   Put the TCC values on the map grid
  !----------------------------------------------------------------------
  type (clean_par) :: c_method
  integer nx,ny,ncc,mx,my
  type (cct_par) :: tcc(ncc)
  real image(nx,ny)
  !
  integer ix,iy,lx,ly,lkx,lky,xfact,yfact, ic,i,j
  real value, rfact
  !
  xfact = nx/mx
  yfact = ny/my
  rfact = 1.0/(xfact*yfact)
  lkx = (xfact+1)/2
  lky = (yfact+1)/2
  !
  image = 0.0
  !
  do ic = 1,ncc
     value = tcc(ic)%value*rfact
     lx = xfact*(tcc(ic)%ix-1) + xfact/2
     ly = yfact*(tcc(ic)%iy-1) + yfact/2
     do j=1,yfact
        do i=1,xfact
           ix = lx-lkx+i
           iy = ly-lky+j
           image(ix,iy) = value
        enddo
     enddo
  enddo
end subroutine compact_to_image
