!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module clean_mfs
  use gbl_message
  !
  public :: mfs_comm
  private
  !
contains
  !
  subroutine mfs_comm(line,error)
    use image_def
    use gkernel_interfaces
    use file_buffers
    use uv_buffers
    use clean_buffers, only: clean_user,clean_prog
    !-----------------------------------------------
    !
    !-----------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    integer :: ixoff,iyoff
    !
    ! Get a default spectral index?
    call sic_i4(line,0,1,ixoff,.false.,error)
    iyoff = ixoff
    !
    call clean_user%copyto(clean_prog)
    call mfs_main(ixoff,iyoff,error)
    print *,'Mask off ',ixoff,iyoff
    !
    save_data(code_save_clean) = .true.
  end subroutine mfs_comm
  !
  subroutine mfs_main(ixoff,iyoff,error)
    use phys_const
    use image_def
    use gkernel_interfaces
    use mapping_interfaces
    use mapping_gaussian_tool
    use clean_beam_tool, only: init_convolve,convolve
    use cct_types
    use uv_buffers
    use uvmap_buffers
    use clean_buffers
    !-----------------------------------------------
    !
    !-----------------------------------------------
    integer, intent(inout) :: ixoff, iyoff
    logical, intent(inout) :: error
    !
    logical :: ok
    integer :: ier,ic
    integer :: i,j,k,l
    integer :: nx,ny,nc
    integer :: niter,miter
    integer :: ixb,jyb,ix,jy,ii(2),dim(2),ndim
    real :: mres,gain
    real(4) :: fact,xinc,yinc
    real(8) :: nu_0,nu_i
    real :: a_0,a_1,rval_0,rval_1,maxv,swc,tmp,area
    real :: a_00_p,a_11_p,a_01_p,a_10_p,delta
    real, allocatable :: local_wfft(:)
    real, allocatable :: idirty(:,:),aprime(:,:),rmask(:,:)
    real, allocatable :: b_0(:,:),b_1(:,:),tb(:,:)
    real, allocatable :: r_0(:,:),r_1(:,:),a_00(:,:),a_01(:,:),a_10(:,:),a_11(:,:)
    real, allocatable :: r_max(:,:),wc(:)
    complex, allocatable :: ftb_0(:,:),ftb_1(:,:),ft(:,:),tfb_0(:,:),tfb_1(:,:)
    type(cct_par), allocatable :: mycct(:)
    character(len=*), parameter :: rname='MFS>MAIN'
    !
    ! 3) The "flat" spectrum intensity is such that it has
    !  been observed with
    !  B_0 = TF [ sum_i ( s(u,v,nu_i) ) ]
    !
    ! 4)  The first order Taylor expansion indicates it has
    !  been observed with
    !  B_1 = TF [ sum_i ( (nu_i-nu_0)/nu_i) s(u,v,nu_i) ) ]
    !
    ! 5) higher (n-th) order terms have an exponent n
    !  (see Conway et al 1990 MNRAS 246, 490)
    !
    if (hbeam%loca%size.eq.0) then
       call map_message(seve%e,rname,'Beam not computed')
       error = .true.
       return
    endif
    !
    if (hbeam%gil%dim(3).ne.huv%gil%nchan) then
       call map_message(seve%e,rname,'Beam has not one plane per channel')
       error = .true.
       return
    endif
    !
    allocate(mycct(miter),stat=ier)
    if (ier.ne.0) then
       call map_message(seve%e,rname,'Cannot allocate Clean Component')
       error = .true.
       return
    endif
    !
    nx = hbeam%gil%dim(1)
    ny = hbeam%gil%dim(2)
    nc = hbeam%gil%dim(3)
    xinc = clean%head%gil%convert(3,1)
    yinc = clean%head%gil%convert(3,2)
    !
    allocate(b_0(nx,ny),b_1(nx,ny),idirty(nx,ny),aprime(nx,ny),&
         & rmask(nx,ny),tb(nx,ny),wc(nc),stat=ier)
    if (ier.ne.0) then
       print *,' NX NY ',nx,ny
       call map_message(seve%e,rname,'Beam memory allocation error')
       error = .true.
       return
    endif
    !
    ! Default mask
    rmask = 0.0
    ixoff = min(ixoff,nx/2)
    iyoff = min(iyoff,ny/2)
    do j=ny/2+1-iyoff,ny/2+iyoff
       do i=nx/2+1-ixoff,ny/2+ixoff
          rmask(i,j) = 1.0
       enddo
    enddo
    !
    nu_0 = gdf_uv_frequency(huv)
    b_0 = 0.0
    do ic=1,nc
       wc(ic) = maxval(hbeam%r3d(:,:,ic))
    enddo
    do ic=1,nc
       b_0 = b_0 + hbeam%r3d(:,:,ic)
    enddo
    swc = sum(wc)
    b_0 = b_0 / swc
    !
    b_1 = 0.0
    tmp = 0
    do ic=1,nc
       nu_i = gdf_uv_frequency(huv,dble(ic))
       print *,'NU ',nu_i,nu_0,(nu_i-nu_0)/nu_0
       b_1 = b_1 + (nu_i-nu_0)/nu_0 * hbeam%r3d(:,:,ic)
       tmp = tmp + wc(ic)*((nu_i-nu_0)/nu_0)**2
    enddo
    b_1 = b_1 / swc
    maxv = maxval(b_1)
    print *,'B_1 max ',maxv,' Guess ',tmp/2.0/swc
    !
    do ic=1,nc
       idirty(:,:) = idirty(:,:) + dirty%head%r3d(:,:,ic)
    enddo
    idirty = idirty / swc
    !
    ! Cleaning parameters
    if (clean_prog%ares.eq.0) then
       maxv = maxval(idirty)
       mres = clean_prog%fres * maxv
    else
       mres = clean_prog%ares
    endif
    !
    ! Get beam parameters
    call clean_prog%fit_beam(hbeam,b_0,error)
    if (error) return
    miter = clean_prog%m_iter
    gain  = clean_prog%gain
    !
    aprime = 0.0
    !
    ii = maxloc(b_0)
    ixb = ii(1)
    jyb = ii(2)
    print *,'IXB JYB ',ixb,jyb,b_0(ixb,jyb)
    print *,swc,'  WC ',wc
    !
    ! What are the beam and image normalisation ?
    !
    ! 6) for power laws spectral index, the scaling
    ! factor of each order is
    !
    !  I times prod_k(1 to n) (a'+k-1)
    !
    ! where a' = a-a_0,  a_0 being the "mean spectral index"
    ! and a' is the spatially dependent spectral index...
    !
    ! we thus have for order 1
    !   I times a'
    !
    ! B) Deconvolution: see Sault & Wieringa 1994, A&ASS 108, 585
    !
    ! Once we have B_0 and B_1, it involves several
    ! intermediate images
    ! R_0 = I ** B_0    (this not the "normal" iterated
    !  dirty image, but this image convolved by the
    !  "normal" dirty beam)
    ! R_1 = I ** B_1
    ! A_00 = B_0 ** B_0
    ! A_01 = B_0 ** B_1
    ! A_10 = B_1 ** B_0
    ! A_11 = B_1 ** B_1
    !
    ! Locate "j" which maximizes
    ! R_0(j)^2 A_11 + R_1(j)^2 A_00 - 2 R_0(j) R_1(j) A_01
    !
    ! Delta = A_00 A_11 - A_01 A_10 at beam center (pixel "0")
    !
    ! a_0 = (A_11(0) R_0(j) - A_01(0) R_1(j) ) / Delta
    ! a_1 = (A_00(0) R_1(j) - A_01(0) R_0(j) ) / Delta
    !
    !   and update I with shifted beams and coefficients
    ! a_0 g  and a_1 g where "g" is the loop gain.
    !   to find the next iterate I
    !
    allocate(r_0(nx,ny),r_1(nx,ny),a_00(nx,ny),a_01(nx,ny),&
         a_10(nx,ny),a_11(nx,ny), r_max(nx,ny), stat=ier)
    if (ier.ne.0) then
       print *,'NX NY ',nx,ny
       call map_message(seve%e,rname,'Aij memory allocation error')
       error = .true.
       return
    endif
    !
    allocate (ftb_0(nx,ny),ftb_1(nx,ny),ft(nx,ny),&
         tfb_0(nx,ny), tfb_1(nx,ny), local_wfft(2*max(nx,ny)),stat=ier)
    if (ier.ne.0) then
       call map_message(seve%e,rname,'TF memory allocation error')
       error = .true.
       return
    endif
    !
    dim = [nx,ny]
    ndim = 2
    ! call convolve(a_00,b_0,b_0)
    ftb_0 = cmplx(b_0,0.0)
    call fourt(ftb_0,dim,ndim,-1,0,local_wfft)
    ftb_1 = cmplx(b_1,0.0)
    call fourt(ftb_1,dim,ndim,-1,0,local_wfft)
    ! Truncated beam TFs
    tb = b_0 * rmask
    call init_convolve (ixb,jyb,nx,ny,tb,tfb_0,area,local_wfft)
    tb = b_1 * rmask
    call init_convolve (ixb,jyb,nx,ny,tb,tfb_1,area,local_wfft)
    !
    call convolve (b_0,a_00,nx,ny,tfb_0,ft,local_wfft)
    print *,' a_00 ',a_00(ixb,jyb),maxval(a_00)
    !
    call convolve (b_0,a_01,nx,ny,tfb_1,ft,local_wfft)
    call convolve (b_1,a_10,nx,ny,tfb_0,ft,local_wfft)
    call convolve (b_1,a_11,nx,ny,tfb_1,ft,local_wfft)
    !
    !  Delta = A_00(ixb,jyb) * A_11(ixb,jyb) - A_01(ixb,jyb) * A_10(ixb,jyb)
    a_11_p = a_11(ixb,jyb)
    a_01_p = a_01(ixb,jyb)
    a_10_p = a_10(ixb,jyb)
    a_00_p = a_00(ixb,jyb)
    !
    Delta = A_00_P * A_11_P - A_01_P * A_10_P
    print *,'Terms in IXB, JYB ',ixb,jyb
    print *,'A_ij ',a_00_p,a_11_p, a_01_p,a_10_p
    print *,'Delta ', delta
    if (delta.eq.0.0) then
       call map_message(seve%e,rname,'Delta is NULL')
       error = .true.
       return
    endif
    !
    ! R_0 = I ** B_0
    call convolve (idirty,r_0,nx,ny,tfb_0,ft,local_wfft)
    ! R_1 = I ** B_1
    call convolve (idirty,r_1,nx,ny,tfb_1,ft,local_wfft)
    !
    ! LOOP HERE FOR NEXT ITERATION
    ok = .true.
    niter = 0
    !
    print *,'niter,  a_0,   a_1,  ix,   jy,  rval_0, rval_1 '
    do while (ok)
       ! Locate "ix,jy" which maximizes
       ! R_0(j)^2 A_11 + R_1(j)^2 A_00 - 2 R_0(j) R_1(j) A_01
       !
       ! We can put a MASK here if needed, or make
       ! an explicit loop over some "cleaning box" area
       r_max = r_0**2 * A_11_P + r_1**2 * A_00_P - 2 * r_0 * r_1 * A_01_P
       !
       ii = maxloc(r_max)
       ix = ii(1)
       jy = ii(2)
       rval_0 = r_0(ix,jy)
       rval_1 = r_1(ix,jy)
       ! a_0 = (A_11(0) R_0(j) - A_01(0) R_1(j) ) / Delta
       ! a_1 = (A_00(0) R_1(j) - A_01(0) R_0(j) ) / Delta
       a_0 = (a_11_p * rval_0 - a_01_p * rval_1 ) / Delta
       a_1 = (a_00_p * rval_1 - a_01_p * rval_0 ) / Delta
       print *,niter,a_0,a_1,ix,jy,rval_0,rval_1
       !
       ! Update I with a_0*g and a' = a-a_ref with a_1*g
       ! which is equivalent to
       !
       ! r_0(i) <-- r_0(i) - g * (a_0 * a_00(i-j) - a_1 * a_10(i-j))
       ! r_1(i) <-- r_1(i) - g * (a_0 * a_01(i-j) - a_1 * a_11(i-j))
       !
       do j=1,ny
          !
          ! Proceed Row by Row
          l = j-jy+jyb
          if (l.ge.1 .and. l.le.ny) then
             !
             ! Along that row, subtract clean component if in beam
             do i = 1,nx
                k = i-ix+ixb
                if (k.ge.1 .and. k.le.nx) then
                   r_0(i,j) = r_0(i,j) - gain * (a_0 * a_00(k,l) - a_1 * a_10(k,l))
                   r_1(i,j) = r_1(i,j) - gain * (a_0 * a_01(k,l) - a_1 * a_11(k,l))
                endif
             enddo
          endif
       enddo
       !
       ! Propagate the component list
       niter = niter+1
       mycct(niter)%value = gain * a_0       ! Store as fractions of beam max
       mycct(niter)%ix = ix
       mycct(niter)%iy = jy
       mycct(niter)%influx = gain * a_1      ! Use that as temporary storage for this type of Clean
       !
       ok = abs(a_0).gt.mres .and. niter.lt.miter
       print *,'OK ',niter,miter, abs(a_0), mres
    enddo
    !
    ! Now restore each of the two images
    call gildas_null(clean%head)
    call gdf_copy_header(dirty%head,clean%head,error)
  !
    clean%head%char%code(3) = 'INDEX'
    clean%head%gil%dim(3) = 2
    clean%head%gil%ref(3) = 1.d0
    clean%head%gil%val(3) = 0.d0
    clean%head%gil%inc(3) = 1.d0
    !
    allocate (clean%data(nx,ny,2),stat=ier)
    !
    ! Beam Area = PI * BMAJ * BMIN / (4 * LOG(2) ) for flux density
    ! normalisation
    fact = clean_prog%major*clean_prog%minor*pi/(4.0*log(2.0))   &
         &    /abs(xinc*yinc)/(nx*ny)
    !
    ! 1) Normal Clean Image
    ft = cmplx(0.0,0.0)
    do ic=1,niter
       ix = mycct(ic)%ix
       jy = mycct(ic)%iy
       ft(ix,jy) = ft(ix,jy) + mycct(ic)%value
    enddo
    call fourt(ft,dim,ndim,-1,0,local_wfft)
    call mulgau(ft,nx,ny,&
         clean_prog%major,clean_prog%minor,clean_prog%angle,&
         fact,xinc,yinc)
    call fourt(ft,dim,ndim,1,1,local_wfft)
    clean%data(:,:,1) = real(ft) ! Extract real part
    !
    ! 2) Pseudo-Spectral Index Map
    ft = cmplx(0.0,0.0)
    do ic=1,niter
       ix = mycct(ic)%ix
       jy = mycct(ic)%iy
       ft(ix,jy) = ft(ix,jy) + mycct(ic)%influx
    enddo
    call fourt(ft,dim,ndim,-1,0,local_wfft)
    call mulgau(ft,nx,ny,   &
         &    clean_prog%major,clean_prog%minor,clean_prog%angle,   &
         &    fact,xinc,yinc)
    call fourt(ft,dim,ndim,1,1,local_wfft)
    clean%data(:,:,2) = real(ft)
    !
    ! Done...
    clean%head%gil%extr_words = 0
    ! Specify clean beam parameters
    clean%head%gil%reso_words = 3
    clean%head%gil%majo = clean_prog%major
    clean%head%gil%mino = clean_prog%minor
    clean%head%gil%posa = pi*clean_prog%angle/180.0
    clean%head%r3d => clean%data
    !
    clean_prog%n_iter = niter
  end subroutine mfs_main
end module clean_mfs
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
