!
! astromatch - matching engine
!
!
! Copyright © 2011-5, 2017 F.Hroch (hroch@physics.muni.cz)
!
! This file is part of Munipack.
!
! Munipack is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! Munipack is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with Munipack.  If not, see <http://www.gnu.org/licenses/>.
!

module astromatcher

  use iso_fortran_env

  implicit none

  integer, parameter, private :: dbl = selected_real_kind(15)

  ! maximal number of loop over frame stars
  integer, parameter, private :: maxloop = 3

  character(len=80), private :: ptype
  real(dbl), dimension(:), pointer, private :: astar,dstar,xstar,ystar
  logical, private :: verbose, plog
  real(dbl), private :: xcen,ycen,acen,dcen

contains

  subroutine astromatch(minmatch,maxmatch,type,a,d,pma,pmd,rflux, &
       xx,yy,flux,ac,dc,xc,yc,id1,id2,sig1,sig2,fsig,fluxtest, &
       epoch,jd,fullmatch,luckymatch,verb,pl,status)

    use astrotrafo
    use matcher

    integer, intent(in) :: minmatch, maxmatch, luckymatch
    logical, intent(in) :: fullmatch,verb, pl, fluxtest
    character(len=*), intent(in) :: type
    real(dbl), intent(in) :: ac,dc,xc,yc,sig1,sig2,fsig,epoch,jd
    real(dbl), dimension(:), intent(in), target :: a, d, pma, pmd, xx, yy, &
         flux, rflux
    integer, dimension(:), allocatable, intent(out) :: id1,id2
    logical, intent(out) :: status

    real(dbl), dimension(:), allocatable :: u,v,x,y
    type(AstroTrafoProj) :: t
    real(dbl) :: dt
    integer :: n1,n2,l,n,k,m

    status = .false.

    verbose = verb
    plog = pl
    ptype = type
    astar => a
    dstar => d
    xstar => xx
    ystar => yy
    acen = ac
    dcen = dc
    xcen = xc
    ycen = yc

    if(verbose) write(error_unit,*) "=== Matching ==="

    n1 = size(a)
    n2 = size(xx)
    allocate(x(n2),y(n2),u(n1),v(n1))

    x = xx - xc
    y = yy - yc

    dt = (jd - epoch)/365.25_dbl

    call trafo_init(t,type,ac,dc)
    call proj(t,a+dt*pma,d+dt*pmd,u,v)

    if( verbose ) then
       write(error_unit,'(2(a,i0),a)') " Matching of ",size(u), &
            " reference stars against to ",size(x)," frame stars:"
       write(error_unit,*) &
            "#: {seq1} -> {seq2} | scale,r: sq.(angle, scale, flux) < Xi2(0.95)"
    end if

    k = 1
    do m = 1, min(size(x)/maxmatch + 1, maxloop)
       n2 = min(maxmatch,size(x)-k) - 1
       l = 1
       do n = 1, size(u)/maxmatch + 1
          n1 = min(maxmatch,size(u)-l) - 1
          if(verbose) write(error_unit,'(2(2(a,i0),a))') &
               " Reference stars in range ",l," -- ",l+n1,".", &
               " Frame stars in range ",k," -- ",k+n2,"."
          call match(u(l:l+n1),v(l:l+n1),rflux(l:l+n1), &
               x(k:k+n2),y(k:k+n2),flux(k:k+n2), &
               minmatch,maxmatch,sig1,sig2,fsig,fluxtest,id1,id2,&
               fullmatch,luckymatch,matchprint,progress2,status)
          if( status ) then
             id1 = l + id1 - 1
             id2 = k + id2 - 1
             goto 99
          end if
          l = l + maxmatch
       end do
       k = k + maxmatch
    end do
99  continue

    deallocate(u,v,x,y)


  end subroutine astromatch


  subroutine matchprint(id1,id2,c,t,a,d,f,q)

    use matcher

    integer, dimension(:), intent(in) :: id1,id2
    real(dbl), intent(in) :: c,t,a,d,f,q
    real(dbl), dimension(size(id1)) :: u,v
    integer :: i,n
    real(dbl) :: d3
    character(len=80) :: fmt

    if( size(id1) /= size(id2) ) stop 'Astromatch size(id1) /= size(id2)'

    n = size(id2)

    if( verbose ) then

       write(fmt,"(a,i0,a,i0,a)") "(i0,a,",n,"(1x,i0),a,",n, &
            "(1x,i0),a,f0.1,2x,g0.2,a,3(2x,g0.3),a,f0.1)"
       write(error_unit,fmt) n,":",id1,' -> ',id2,' | ',c,t,': ',a,d,f,' < ',q

    end if

    return

    if( plog ) then

       write(fmt,"(a,i0,a)") "(a,i0,",2*n,"(1x,f0.3),f6.3,f8.5)"
       write(*,fmt) "=M> ",n,(xstar(id2(i)),ystar(id2(i)),i=1,n),a,d

       do i = 3,n
          call triangle(xstar(i-2),ystar(i-2),xstar(i-1), &
               ystar(i-1),xstar(i),ystar(i),d3,u(i),v(i))
       end do

       write(fmt,"(a,i0,a)") "(a,i0,",2*(n-2),"(1x,f0.3))"
       write(*,fmt) "=MUV> ",n-2,(u(i),v(i),i=3,n)
    end if

  end subroutine matchprint


  subroutine progress2(ns,ntot,xamin,xdmin,xfmin,id1,id2)

    use matcher
    use absfit
    use estimator

    integer, intent(in) :: ns,ntot
    integer, dimension(:), intent(in), optional :: id1,id2
    real(dbl), intent(in), optional :: xamin,xdmin,xfmin
    character(len=80) :: fmt,fm
    real(dbl), dimension(:), allocatable :: u,v
    integer :: n,m,i,i1,i2,i3
    real(dbl) :: ac,dc,sc,dsc,rot,drot,rms,amin,dmin,fmin,d3,refl, &
         xoff,yoff,dxoff,dyoff
    real(dbl), dimension(:), allocatable :: alpha,delta,x,y

    if( .not. plog ) return

    if( present(id2) ) then

       n = size(id2)

       allocate(u(n),v(n))

       ! FIT
       allocate(alpha(n),delta(n),x(n),y(n))
       do i = 1,n
          i1 = id1(i)
          i2 = id2(i)
          alpha(i) = astar(i1)
          delta(i) = dstar(i1)
          x(i) = xstar(i2)
          y(i) = ystar(i2)
       end do

       ac = acen
       dc = dcen
       call inestim(ptype,alpha,delta,xcen,ycen,x,y,ac,dc,sc,dsc,rot,drot, &
            refl,xoff,yoff,dxoff,dyoff,verbose)
       call absmin(ptype,alpha,delta,xcen,ycen,x,y,ac,dc,sc,dsc,rot,drot,refl,&
            0.0_dbl,0.0_dbl,0.0_dbl,0.0_dbl,rms,.false.)
       deallocate(alpha,delta,x,y)

       write(*,'(a,en15.3,en25.15,en25.15,4en25.15)') &
            "=MFIT> ",rms,sc,rot,ac,dc,xcen,ycen

       if( xdmin < 0.1*huge(xdmin) ) then
          amin = xamin
          dmin = xdmin
          fmin = xfmin
       else
          dmin = -1.0
          amin = -1.0
          fmin = -1.0
       end if

       do i = 3,n
          i1 = id2(i)
          i2 = id2(i - 1)
          i3 = id2(i - 2)
          call triangle(xstar(i3),ystar(i3),xstar(i2),ystar(i2), &
               xstar(i1),ystar(i1),d3,u(i),v(i))
       end do

       write(fmt,"(a,i0,a,i0,a)") "(a,3(1x,g0.7),1x,i0,",2*n,"(1x,f0.3),1x,i0,"
       m = n - 2
       write(fm,'(i0,a)') 2*(n-2),"(1x,f0.3))"

       fmt = trim(fmt)//fm
       write(*,fmt) "=MPROGRES2> ",amin,dmin,fmin,n, &
            (xstar(id2(i)),ystar(id2(i)),i=1,n),m,(u(i),v(i),i=3,n)
       deallocate(u,v)

    else
       write(*,'(a,2(1x,i0))') "=MPROGRESO> ",ns,ntot
    end if


  end subroutine progress2

  subroutine uvhist(x,y)

    use matcher

    integer, parameter :: nhist = 100

    real(dbl), dimension(:), intent(in) :: x,y
    integer, allocatable, dimension(:,:) :: hist
    real(dbl) :: u, v, d3
    integer :: i,j,k,m,n,c
    character(len=80) :: fmt

    allocate(hist(nhist,nhist))
    hist = 0

    ! the number of triangles is limited to enable an acceptable user response
    c = max(size(x)/137,1)

    do i = 1, size(x) - 2,c
       do j = i+1, size(x) - 1,c
          do k = j+1, size(x),c
             call triangle(x(i),y(i),x(j),y(j),x(k),y(k),d3,u,v)
             m = nint(nhist*u)
             n = nint(nhist*v)
             if( 1 <= m .and. m <= nhist .and. 1 <= n .and. n <= nhist ) &
                  hist(m,n) = hist(m,n) + 1
          end do
       end do
    end do

    write(fmt,'(a,i0,a)') "(a,1x,i0,1x,",nhist**2,"(1x,i0))"
    write(*,fmt) "=MTRI> ",nhist,hist

    deallocate(hist)

  end subroutine uvhist

end module astromatcher
