!
!  fitsaphot
!
!  Copyright © 2013-6 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/>.

! Parameters by:
! http://stsdas.stsci.edu/cgi-bin/gethelp.cgi?psfmeasure.hlp


module fitsaphot

  use fitsio
  use iso_fortran_env

  implicit none

contains

subroutine faphot(filename,raper,ring,verbose,plog)

  use mdaofotometr

  integer, parameter :: DIM = 2

  character(len=*),intent(in) :: filename
  real, dimension(:),intent(in) :: raper,ring
  logical, intent(in) :: verbose,plog

  integer :: status,naxis,bitpix,nrows,xcol,ycol,hcol,hdutype,i,j,n,naper
  integer, parameter :: group = 1, extver = 0, frow = 1, felem = 1, nbegin = 4
  real, parameter :: nullval = 0.0
  integer, dimension(DIM) :: naxes
  logical :: anyf
  real, dimension(:,:), allocatable :: data, stderr
  real, dimension(:), allocatable :: xcens,ycens,hstar,sky,sky_err
  real, dimension(:,:), allocatable :: apcts,apcts_err
  character(len=FLEN_VALUE), dimension(:), allocatable :: ttype, tform, tunit
  real :: lobad, hibad, fwhm, hwhm
  character(len=FLEN_COMMENT) :: com
  character(len=FLEN_VALUE) :: key

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

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

  call ftmnhd(15,IMAGE_HDU,EXT_STDERR,extver,status)
  if( status == 0 ) then
     call ftg2de(15,1,nullval,naxes(1),naxes(1),naxes(2),stderr,anyf,status)
  else if ( status == BAD_HDU_NUM ) then
     ! if the information about standard error is not available,
     ! we are continuing with epsilons
     ! if( verbose ) write(error_unit,*) "Standard errors of frame are not available."
     !     stderr = epsilon(stderr)
     ! we are continuing with only Poisson component
     where( data > 0 )
        stderr = sqrt(data)
     elsewhere
        stderr = -1
     end where
     status = 0
  end if

  if( status /= 0 ) then
     write(error_unit,*) trim(filename),": Failed to read data."
     goto 666
  end if

  call ftmnhd(15,BINARY_TBL,FINDEXTNAME,extver,status)
  if( status == BAD_HDU_NUM ) then
     write(error_unit,*) "Error: ",trim(FINDEXTNAME)//" extension not found."
     write(error_unit,*) "       Has been stars detected by `munipack find "// &
          trim(filename)//"'?"
     goto 666
  end if

  call ftgnrw(15,nrows,status)

  call ftgkye(15,FITS_KEY_LOWBAD,lobad,com,status)
  call ftgkye(15,FITS_KEY_HIGHBAD,hibad,com,status)
  call ftgkye(15,FITS_KEY_FWHM,fwhm,com,status)
  if( status /= 0 ) then
     write(error_unit,*) trim(filename),": Required keywords ",trim(FITS_KEY_LOWBAD),&
          ",",trim(FITS_KEY_HIGHBAD)," or ",trim(FITS_KEY_FWHM)," not found."
     goto 666
  end if

  naper = size(raper)
  allocate(xcens(nrows),ycens(nrows),hstar(nrows),sky(nrows),sky_err(nrows), &
       apcts(nrows,naper),apcts_err(nrows,naper))

  apcts = -1.0
  apcts_err = -1.0

  call ftgcno(15,.true.,FITS_COL_X,xcol,status)
  call ftgcno(15,.true.,FITS_COL_Y,ycol,status)
  call ftgcno(15,.true.,FITS_COL_PEAKRATIO,hcol,status)
  call ftgcve(15,xcol,frow,felem,size(xcens),nullval,xcens,anyf,status)
  call ftgcve(15,ycol,frow,felem,size(ycens),nullval,ycens,anyf,status)
  call ftgcve(15,hcol,frow,felem,size(hstar),nullval,hstar,anyf,status)
  if( status /= 0 ) goto 666

  ! aperture photometry
  call daophotsb(data,stderr,xcens,ycens,hstar,raper,ring,lobad,hibad,1.0, &
       verbose,plog,apcts,apcts_err,sky,sky_err,status)
  if( status /= 0 ) goto 666

  ! estimate of width parameter for Gaussian
  call estim_hwhm(data,xcens,ycens,sky,fwhm,lobad,hibad,hwhm)
  if( hwhm < 0 ) hwhm = fwhm / (2*sqrt(2*log(2.0)))

  ! store results to next extension
  call ftmnhd(15,BINARY_TBL,APEREXTNAME,extver,status)
  if( status == BAD_HDU_NUM ) then
     status = 0
  else
     ! already presented ? remove it !
     call ftdhdu(15,hdutype,status)
     if( status /= 0 ) goto 666
  end if

  n = nbegin + 2*size(raper)
  allocate(ttype(n), tform(n), tunit(n))

  tform = '1D'
  tunit = ''
  ttype(1) = FITS_COL_X
  ttype(2) = FITS_COL_Y
  ttype(3) = FITS_COL_SKY
  ttype(4) = FITS_COL_SKYERR

  do i = 1, size(raper)
     j = nbegin - 1 + 2*i
     write(ttype(j),'(a,i0)') trim(FITS_COL_APCOUNT),i
     write(ttype(j+1),'(a,i0)') trim(FITS_COL_APCOUNTERR),i
  end do

  ! aperture photometry table
  call ftibin(15,0,size(ttype),ttype,tform,tunit,APEREXTNAME,0,status)

  call ftpkye(15,FITS_KEY_HWHM,hwhm,-4,'[pix] half width at half of maximum',status)
  call ftpkyj(15,FITS_KEY_NAPER,size(raper),'Count of apertures',status)
  do i = 1, size(raper)
     call ftkeyn(FITS_KEY_APER,i,key,status)
     call ftpkye(15,key,raper(i),-5,'[pix] aperture radius',status)
  end do

  call ftpkye(15,trim(FITS_KEY_ANNULUS)//'1',ring(1),-5,'[pix] inner sky annulus radius',status)
  call ftpkye(15,trim(FITS_KEY_ANNULUS)//'2',ring(2),-5,'[pix] outer sky annulus radius',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(sky),sky,status)
  call ftpcle(15,4,frow,felem,size(sky_err),sky_err,status)

  do i = 1,size(apcts,2)
     j = nbegin-1+2*i
     call ftpcle(15,j,frow,felem,size(apcts(:,i)),apcts(:,i),status)
     call ftpcle(15,j+1,frow,felem,size(apcts_err(:,i)),apcts_err(:,i),status)
  end do
  deallocate(ttype,tform,tunit)


666 continue

  if( allocated(data) ) deallocate(data,stderr)
  if( allocated(apcts) ) deallocate(xcens,ycens,hstar,apcts,apcts_err, &
       sky,sky_err)


  call ftclos(15,status)
  call ftrprt('STDERR',status)

end subroutine faphot


subroutine estim_hwhm(data,xcens,ycens,sky,fwhm,lobad,hibad,hwhm)

  use robustmean

  real, dimension(:,:), intent(in) :: data
  real, dimension(:), intent(in) :: xcens,ycens,sky
  real, intent(in) :: fwhm,lobad,hibad
  real, intent(out) :: hwhm

  real, dimension(:), allocatable :: xhwhm
  real :: sx,sy,w,sw,w0
  integer :: nx,ny,i,j,l,m,n,i0,j0

  allocate(xhwhm(size(xcens)))

  nx = size(data,1)
  ny = size(data,2)

  n = 0
  m = nint(1.5*fwhm)
  m = nint(fwhm / 2) * 3
  ! neighborhood is 3*hwhm of expected which prefers important
  ! parts of profile

  do l = 1, size(xcens)

     sx = 0
     sy = 0
     sw = 0
     i0 = nint(xcens(l))
     j0 = nint(ycens(l))
     w0 = max(data(i0,j0) - sky(l),0.0)
     do i = i0-m,i0+m
        do j = j0-m,j0+m
           if( 0 < i .and. i <= nx .and. 0 < j .and. j <= ny ) then
              if( lobad < data(i,j) .and. data(i,j) < hibad ) then
                 w = max(data(i,j) - sky(l),0.0)
                 sx = sx + w*(i - xcens(l))**2
                 sy = sy + w*(j - ycens(l))**2
                 sw = sw + w
              end if
           end if
        end do
     end do
     if( sw > 0 .and. w0 > 0 .and. sqrt(w0) / w0 < 0.01) then
        ! estimation of fwhm is very sensitive on noise in data (w),
        ! therefore we're selecting only bright stars
        n = n + 1
        xhwhm(n) = (sqrt(sx/sw) + sqrt(sy/sw)) / 2
     end if
  end do

  if( n > 1 ) then
     call rmean(xhwhm(1:n),hwhm,w)
  else
     hwhm = -1
  end if

  deallocate(xhwhm)

end subroutine estim_hwhm


end module fitsaphot
