!
!  fitsfind
!
!  Copyright © 2013 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 fitsfind

  use fitsio

  implicit none

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

contains


subroutine ffind(filename,maxsky,verbose,plog,fkeys,fwhm,readns_init, &
     satur_init,lothresh,threshold,shrplo,shrphi,rndlo,rndhi)

  use mdaofind

  integer, parameter :: DIM = 2

  character(len=*),intent(in) :: filename
  logical, intent(in) :: verbose,plog
  character(len=*),dimension(:),intent(in) :: fkeys
  real,intent(in) :: fwhm,readns_init,satur_init, &
       lothresh,threshold,shrplo,shrphi,rndlo,rndhi
  integer,intent(in) :: maxsky
  integer :: status, naxis, bitpix, hdutype
  integer, parameter :: group = 1, extver = 0, frow = 1, felem = 1
  real, parameter :: nullval = 0.0
  integer, dimension(DIM) :: naxes
  logical :: anyf
  real, dimension(:,:), allocatable :: data
  real, dimension(:), allocatable :: xcens,ycens,hstar,rounds,sharps
  character(len=FLEN_CARD) :: buf
  real :: lobad, hibad, aduthresh,saturation,readns,skymod, skyerr, skysig
  character(len=FLEN_VALUE), dimension(5) :: ttype, tform, tunit

  buf = ''
  status = 0
  call ftiopn(15,filename,1,status)
  call ftgipr(15,DIM,bitpix,naxis,naxes,status)
  if( status /= 0 .or. naxis /= 2 ) goto 666

  if( readns_init > 0.0 ) then
     readns = readns_init
     call ftukye(15,fkeys(2),readns_init,-7,'[ADU] read noise',status)
  else
     call ftgkye(15,fkeys(2),readns,buf,status)
     if( status == KEYWORD_NOT_FOUND ) then
        readns = 0.0
        status = 0
     end if
  end if

  if( satur_init > 0.0 ) then
     saturation = satur_init
     call ftukye(15,fkeys(1),satur_init,5,'[counts] full well capacity',status)
  else
     call ftgkye(15,fkeys(1),saturation,buf,status)
     if( status == KEYWORD_NOT_FOUND ) then
        saturation = -1.0
        status = 0
     end if
  end if
  if( status /= 0 ) goto 666

  if( saturation > 0.0 ) then
     hibad = saturation
  else
     hibad = huge(data)
  end if

  allocate(data(naxes(1),naxes(2)))
  call ftg2de(15,group,nullval,size(data,1),naxes(1),naxes(2), &
       data,anyf,status)

  if( status /= 0 ) then
     call ftrprt('STDERR',status)
     deallocate(data)
     return
  end if

  if( status == 0 ) then

     call daofind(data,maxsky,verbose,plog,hibad,fwhm,lothresh,threshold, &
          shrplo,shrphi,rndlo,rndhi,readns,1.0,xcens,ycens,hstar,rounds,sharps, &
          lobad, aduthresh, skymod, skyerr, skysig)

     ! sort arrays by height above lower threshold
     call sorter(xcens,ycens,hstar)

  end if

! results fills new FITS extension

  ! look for the extension
  call ftmnhd(15,BINARY_TBL,FINDEXTNAME,extver,status)
  if( status == BAD_HDU_NUM ) then
     status = 0
  else if( status == 0 ) then
     ! already presented ? remove it !
     call ftdhdu(15,hdutype,status)
  end if
  if( status /= 0 ) goto 666

  ttype(1) = FITS_COL_X
  ttype(2) = FITS_COL_Y
  ttype(3) = FITS_COL_SHARP
  ttype(4) = FITS_COL_ROUND
  ttype(5) = FITS_COL_PEAKRATIO
  tform = '1D'
  tunit = ''

  call ftibin(15,0,size(ttype),ttype,tform,tunit,FINDEXTNAME,0,status)

  call ftukye(15,FITS_KEY_FWHM,fwhm,-2,'[pix] standard FWHM of objects',status)
  call ftukye(15,FITS_KEY_THRESHOLD,threshold,-2,'threshold in sigmas above background',status)
  call ftukye(15,FITS_KEY_LOWBAD,lobad,-3,'[ADU] low good datum',status)
  call ftukye(15,FITS_KEY_HIGHBAD,hibad,-3,'[ADU] high good datum',status)
  call ftukye(15,FITS_KEY_RNDLO,rndlo,-3,'low round',status)
  call ftukye(15,FITS_KEY_RNDHI,rndhi,-3,'high round',status)
  call ftukye(15,FITS_KEY_SHRPLO,shrplo,-3,'low sharp',status)
  call ftukye(15,FITS_KEY_SHRPHI,shrphi,-3,'high sharp',status)

  call ftpcom(15,'Star detection parameters:',status)

  write(buf,*) 'Saturation (ADU)=',saturation,' (see primary HDU)'
  call ftpcom(15,buf,status)

  write(buf,*) 'Read noise (ADU)=',readns,' (see primary HDU)'
  call ftpcom(15,buf,status)

  write(buf,*) 'Lower threshold (sigma)=',lothresh
  call ftpcom(15,buf,status)

  write(buf,*) 'Levels range (ADU) =',lobad, '..',hibad
  call ftpcom(15,buf,status)

  write(buf,*) 'Round range =',rndlo, '..',rndhi
  call ftpcom(15,buf,status)

  write(buf,*) 'Sharp range =',shrplo, '..',shrphi
  call ftpcom(15,buf,status)

  write(buf,*) 'Approximate sky value =',skymod,'+-',skyerr
  call ftpcom(15,buf,status)

  write(buf,*) 'Estimated sky sigma =',skysig
  call ftpcom(15,buf,status)

  write(buf,*) 'Pixels used for sky determination =',maxsky
  call ftpcom(15,buf,status)

  call ftpcle(15,1,frow,felem,size(xcens),xcens,status)
  call ftpcle(15,2,frow,felem,size(ycens),ycens,status)
  call ftpcle(15,3,frow,felem,size(sharps),sharps,status)
  call ftpcle(15,4,frow,felem,size(rounds),rounds,status)
  call ftpcle(15,5,frow,felem,size(hstar),hstar,status)

666 continue

  call ftclos(15,status)
  if( status /= 0 ) call ftrprt('STDERR',status)

  if( allocated(data) ) deallocate(data)
  if( allocated(xcens) ) deallocate(xcens,ycens,hstar,rounds,sharps)


contains

  subroutine sorter(xcens,ycens,hstar)

    use quicksort

    real, dimension(:),intent(inout) :: xcens,ycens,hstar

    real(rp), dimension(:), allocatable :: xs,ys,hs
    integer, dimension(:), allocatable :: id
    integer :: i,n,idx

    allocate(xs(size(xcens)),ys(size(ycens)),hs(size(hstar)),id(size(hstar)))
    forall( i = 1:size(hstar) )
       id(i) = i
       hs(i) = hstar(i)
    end forall
    call qsort(hs,id)
    ! sorted from low to high

    xs = xcens
    ys = ycens
    n = size(id) + 1
    do i = 1, size(id)
       idx = id(n - i)
       xcens(i) = real(xs(idx))
       ycens(i) = real(ys(idx))
    end do

    ! reverse sort
    forall( i = 1:size(hstar) )
       hstar(i) = real(hs(n - i))
    end forall
    deallocate(id,xs,ys,hs)

  end subroutine sorter


end subroutine ffind


end module fitsfind
