!
!  Phcorr - photometric corrections
!  Copyright (C) 2012-4, 2016-7  Filip Hroch, Masaryk University, Brno, 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/>.

program phcorr

  use robustmean
  use weightedmean
  use fitsio
  use xfitsio
  use iso_fortran_env

  implicit none

  ! No. of image dimensions
  integer, parameter :: DIM = 2

  character(len=*), parameter :: phid = 'PHCORR'

  ! This utility assumes that output image has in intensity
  ! within range minvalue < x < maxvalue.
  ! The minvalue always is 0 for measured intensities (?)
  ! The maxvalue is determined as (2**bitpix - 1).
  ! The specific characteristic of dark images may require some modification
  ! for real-type intensity of image.
  !real, parameter :: minvalue = 0.0

  character(len=FLEN_FILENAME) :: sciname,flatname='',biasname='',darkname='', &
       maskname='', outname,buf,backup,newname

  character(len=4*FLEN_FILENAME) :: key,val,record,flattext,darktext,biastext

  character(len=FLEN_KEYWORD) :: DATE_OBS=FITS_KEY_DATEOBS, &
       TEMPERAT=FITS_KEY_TEMPERATURE, EXPTIME=FITS_KEY_EXPTIME, &
       FILTER=FITS_KEY_FILTER,KEY_GAIN=FITS_KEY_GAIN, &
       KEY_SATURATE=FITS_KEY_SATURATE,flatfilter,filt,tmask

  integer :: i,j,eq,istat,blocksize,hdutype
  real :: xerr, t, temp, xmask
  real, dimension(:,:), allocatable :: FLAT, BIAS, DARK, MASK, OUT, &
       DFLAT, DBIAS, DDARK, DOUT
  logical :: verbose = .false.
  logical :: force_apply = .false.
  logical :: normalise = .false.
  logical :: phalready
  logical :: bitpix_user = .false.
  logical :: gain_set = .false.
  logical :: gain_apply = .true.
  logical :: saturate_set = .false.
  real :: saturate
  real :: tol_exptime = 1e-6
  real :: tol_temperat = 1.0
  real :: xdark = -1.0
  real :: etime = -1.0
  real :: darktemp, darketime = -1.0
  real :: flatmean = 1.0
  real :: gain = 1
  integer :: bitpix = -32

  type(xFITS) :: fits, biasfits, darkfits, flatfits, maskfits

  i = 0
  buf = ''

  call xfits_init(biasfits)
  call xfits_init(darkfits)
  call xfits_init(flatfits)
  call xfits_init(maskfits)

  do
     read(*,'(a)',end=20) record

     eq = index(record,'=')
     if( eq == 0 ) stop 'Improper input.'
     key = record(:eq-1)
     val = record(eq+1:)

     if( key == 'VERBOSE' ) then
        read(val,*) verbose
     endif

     if( key == 'BITPIX' ) then
        read(val,*) bitpix
        bitpix_user = .true.
     endif

     if( key == 'FITS_KEY_DATEOBS' ) then
        read(val,*) DATE_OBS
     endif

     if( key == 'FITS_KEY_FILTER' ) then
        read(val,*) FILTER
     endif

     if( key == 'FITS_KEY_TEMPERATURE' ) then
        read(val,*) TEMPERAT
     endif

     if( key == 'FITS_KEY_EXPTIME' ) then
        read(val,*) EXPTIME
     endif

     if( key == 'FITS_KEY_SATURATE' ) then
        read(val,*) KEY_SATURATE
     endif

     if( key == 'FITS_KEY_GAIN' ) then
        read(val,*) KEY_GAIN
     endif

     if( key == 'GAIN' ) then
        read(val,*) gain
        gain_set = .true.
     endif

     if( key == 'GAIN_APPLY' ) then
        read(val,*) gain_apply
     endif

     if( key == 'TOL_TEMPERATURE' ) then
        read(val,*) tol_temperat
     endif

     if( key == 'TOL_EXPOSURE' ) then
        read(val,*) tol_exptime
     endif

     if( key == 'FORCEAPPLY' ) then
        read(val,*) force_apply
     endif

     if( key == 'NORMALISE' ) then
        read(val,*) normalise
     endif

     if( key == 'FLAT' ) then

        read(val,*) flatname
        if( verbose ) write(error_unit,*) "FLAT=",trim(flatname)
        call xfits_read(flatname,flatfits)
        if( .not. flatfits%status ) stop 'Failed to load flat-field frame.'

        istat = 0
        call xfits_kys(flatfits,FILTER,flatfilter,istat)
        if( istat /= 0 ) then
           istat = 0
           flatfilter = ''
           if( verbose ) &
                write(error_unit,*) &
                "Warning: a photometric filter of flat-field unknown."
        end if


        if( normalise .or. flatfits%bitpix > 0 ) then

           ! average of flat
           call rwmean(pack(flatfits%image, flatfits%stderr > 0),&
                       pack(flatfits%stderr,flatfits%stderr > 0),flatmean,xerr)

           if( verbose ) &
                write(error_unit,*) 'Flat-frame statistics: mean=', &
                flatmean,'+-',xerr

           if( flatmean < epsilon(flatmean) ) &
                stop 'Mean of flat is not positive.'

        end if

     end if

     if( key == 'BIAS' ) then

        read(val,*) biasname
        if( verbose ) write(error_unit,*) "BIAS=",trim(biasname)
        call xfits_read(biasname,biasfits)
        if( .not. biasfits%status ) stop 'Failed to load bias frame.'

     end if

     if( key == 'DARK' ) then

        read(val,*) darkname
        if( verbose ) write(error_unit,*) "DARK=",trim(darkname)
        call xfits_read(darkname,darkfits)
        if( .not. darkfits%status ) stop 'Failed to load dark frame.'

        istat = 0
        call xfits_kye(darkfits,EXPTIME,darketime,istat)
        if( istat /= 0 ) then
           istat = 0
           darketime = -1
           if( verbose ) &
                write(error_unit,*) "An exposure time for dark frame unknown."
        end if

        call xfits_kye(darkfits,TEMPERAT,darktemp,istat)
        if( istat /= 0 ) then
           istat = 0
           darktemp = -999
           if( verbose ) &
                write(error_unit,*) "A temperature for dark frame unknown."
        end if

     end if

     if( key == 'XDARK' ) then
        read(val,*) xdark
     end if

     if( key == 'MASK' ) then

        read(val,*) maskname
        if( verbose ) write(error_unit,*) "MASK=",trim(maskname)
        call xfits_read(maskname,maskfits)
        if( .not. maskfits%status ) stop 'Failed to load mask frame.'

     end if

     if( key == 'XMASK' ) then
        read(val,*) tmask
     end if

     if( key == 'FILE' ) then

        read(val,*) sciname,backup,newname
        if( verbose ) write(error_unit,'(a)',advance="no") ' ('//trim(sciname)

        call xfits_init(fits)
        call xfits_read(sciname,fits)
        if( .not. fits%status ) then
           write(error_unit,*) &
                "Warning: Failed to read `",trim(sciname),"'. Skippy."
           call xfits_deallocate(fits)
           goto 665
        end if

        istat = 0

        call xfits_kye(fits,TEMPERAT,temp,istat)
        if( istat /= 0 ) then
           istat = 0
           temp = -999
        end if

        call xfits_kye(fits,EXPTIME,etime,istat)
        if( istat /= 0 ) then
           istat = 0
           etime = -1
        end if

        call xfits_kys(fits,FILTER,filt,istat)
        if( istat /= 0 ) then
           istat = 0
           filt = ''
        end if

        if( .not. gain_set .and. gain_apply ) then
           call xfits_kye(fits,KEY_GAIN,gain,istat)
           gain_set = istat == 0
           if( istat /= 0 ) then
              write(error_unit,*) &
                "Warning: Gain keyword not found in FITS header Skipping: `", &
                trim(sciname),"'"
              goto 665
           end if
        end if
        if( .not. (gain > 0) ) then
           write(error_unit,*) &
                "Warning: assumed gain > 0 ... Skipping: `",trim(sciname),"'"
           goto 665
        end if

        call xfits_kye(fits,KEY_SATURATE,saturate,istat)
        saturate_set = istat == 0
        if( istat /= 0 ) istat = 0

        ! check of already corrected images
        phalready = .false.
        do j = 1, fits%nhead
           if( index(fits%head(j),phid) > 0 ) phalready = .true.
        enddo

        if( phalready .and. .not. force_apply ) then
           write(error_unit,*) &
                "Warning: Photometric corrections already applied.", &
                " Skipping: `",trim(sciname),"'"
           goto 665
        end if

        allocate(FLAT(fits%naxes(1),fits%naxes(2)),DFLAT(fits%naxes(1),fits%naxes(2)))
        FLAT = 1.0
        DFLAT = epsilon(DFLAT)

        allocate(BIAS(fits%naxes(1),fits%naxes(2)),DBIAS(fits%naxes(1),fits%naxes(2)))
        BIAS = 0.0
        DBIAS = epsilon(DBIAS)

        allocate(DARK(fits%naxes(1),fits%naxes(2)),DDARK(fits%naxes(1),fits%naxes(2)))
        DARK = 0.0
        DDARK = epsilon(DDARK)

        if( flatfits%status ) then
           if( .not. all(flatfits%naxes == fits%naxes) )then
              write(error_unit,*) &
                   "Warning: Flat-field size does not match corrected frame.",&
                   "Skipped."
              goto 665
           end if

           if( verbose .and. flatfilter /= '' .and. filt /= '' )then
              if( flatfilter /= filt ) &
                   write(error_unit,*) "Warning: filters does not match."
           end if

           FLAT =  flatfits%image / flatmean
           DFLAT = flatfits%stderr / flatmean

        endif

        if( biasfits%status ) then
           if( .not. all(biasfits%naxes == fits%naxes) )then
              write(error_unit,*) &
                   "Warning: Frame and bias sizes does not match. Skipping."
              goto 665
           end if
           BIAS = biasfits%image
           DBIAS = biasfits%stderr

        endif

        if( maskfits%status ) then
           if( .not. all(maskfits%naxes == fits%naxes) )then
              write(error_unit,*) &
                   "Warning: Frame and mask sizes does not match. Skipping."
              goto 665
           end if
        endif

        if( darkfits%status ) then
           if( .not. all(darkfits%naxes == fits%naxes) )then
              write(error_unit,*) &
                   "Warning: Frame and dark sizes does not match. Skipping."
              goto 665
           end if

           if( verbose .and. darktemp > -273.0 .and. temp > -273.0 )then
              if( abs(temp - darktemp) > tol_temperat ) &
                   write(error_unit,*) &
                   "Warning: Temperature diference over limit."
           end if

           if( xdark > 0.0 ) then
              t = xdark
           else if( darketime > 0 .and. etime > 0 ) then
              t = etime / darketime
           else
              t = 1
           end if

           DARK = darkfits%image
           DDARK = darkfits%stderr

        endif

        if( gain_apply .and. .not. gain_set ) then
           write(error_unit,*) &
                "Warning: Gain unset (use --gain or --gain-ignore). Skipping."
              goto 665
        end if

        if( verbose ) then

           flattext = ''
           biastext = ''
           darktext = ''

           if( flatname /= '' ) write(flattext,'(3a,1pg0.6,a)') &
                '/ (',trim(flatname),'/',flatmean,')'

           if( biasname /= '' ) &
                biastext = " - "//trim(biasname)

           if( darkname /= '' ) &
                write(darktext,'(a,f0.3,2a)') ' - ',t,'*',trim(darkname)

           write(error_unit,'(a)',advance="no") &
                trim(darktext)//trim(biastext)//') '//trim(flattext)//' ='
        end if

        allocate(OUT(fits%naxes(1),fits%naxes(2)), &
                DOUT(fits%naxes(1),fits%naxes(2)))

        ! the corrections, we are sure that FLAT > 0
        where( FLAT > 0 )
           OUT = gain*(fits%image - (t*DARK + BIAS)) / FLAT
        elsewhere
           OUT = gain*(fits%image - (t*DARK + BIAS))
        end where
        where( FLAT > 0 .and. OUT > 0 )
           DOUT = sqrt(OUT + gain**2*(t**2*DDARK**2 + DBIAS**2))
           DOUT = abs(OUT)*sqrt(DOUT**2/OUT**2 + DFLAT**2/FLAT**2)
        elsewhere
           ! defective pixels (?)
           OUT = 0
           DOUT = 1
        end where
        ! YES, this small piece of code is the full correction!!!
        ! All everything is just a practise in reading and writing
        ! of FITS files.

        ! convert saturation to electrons
        if( gain_apply .and. gain_set .and. saturate_set ) &
             saturate = gain*saturate

        ! masking
        if( maskfits%status ) then

           allocate(MASK(fits%naxes(1),fits%naxes(2)))
           MASK = maskfits%image

           if( tmask == "MEAN" ) then
              ! median of the image
              call rmean(pack(OUT,OUT>0),xmask,xerr)
              if( verbose ) &
                   write(error_unit,*) 'Mask frame statistics: mean=',&
                   xmask,'+-',xerr
           else ! if( tmask == "ZERO" ) then
              xmask = 0
              xerr = 0
           end if

           where( MASK < epsilon(MASK) )
              OUT = xmask
              DOUT = xerr
           end where

           deallocate(MASK)
        end if

        ! cut-off negative counts
        where( OUT < 0 )
           OUT = 0
        end where

        ! default bitpix
        if( .not. bitpix_user ) bitpix = -32

        ! write out corrected image
        i = 0
        call fitsback(sciname,backup,newname,.true.,outname,i)
        if( backup /= '' ) then
           call ftopen(25,backup,0,blocksize,i)
        else
           call ftopen(25,sciname,0,blocksize,i)
        end if
        call ftinit(26,outname,1,i)

        if( fits%nhdu > 1 ) then

           ! copy all extensions
           call ftcpfl(25,26,1,1,1,i)

           ! point to right
           call ftmahd(25,fits%chdu,hdutype,i)
           call ftmahd(26,fits%chdu,hdutype,i)

           ! remove old one
           call ftdhdu(26,hdutype,i)

        end if

        ! create new one
        call ftiimg(26,bitpix,fits%naxis,fits%naxes,i)
        ! copy user-level header records
        do j = 1, fits%nhead
           if( fits%head(j) /= '' ) call ftprec(26,fits%head(j),i)
        enddo

        call ftclos(25,i)
        if( i /= 0 ) goto 665

        if( bitpix > 0 ) then
           call ftukyj(26,'BSCALE',1,'',i)
           if( bitpix < 32) then
              call ftukyj(26,'BZERO',2**(bitpix-1),'',i)
           else
              call ftukyj(26,'BZERO',1,'',i)
              ! Important: the 2**(32-1) is undefined when
              ! we are using 32-bit integers (perhaps including
              ! any other processing). We are setting to fallback values.
           end if
        else
           call ftdkey(26,'BSCALE',i)
           if( i == KEYWORD_NOT_FOUND ) i = 0
           call ftdkey(26,'BZERO',i)
           if( i == KEYWORD_NOT_FOUND ) i = 0
        end if

        if( gain_apply ) then
           call ftukye(26,KEY_GAIN,gain,5,'[e-/ADU] amplifier gain used for conversion',i)
           call ftukys(26,FITS_KEY_BUNIT,'COUNTS','count of captured electrons',i)
           write(buf,'(g0.3)') gain
           if( saturate_set ) then
              call ftukye(26,KEY_SATURATE,saturate,-5,'[counts] saturation level',i)
              buf = trim(buf) // " (updated saturation)"
           end if
           call ftphis(26,phid//" gain: "//trim(buf),i)
        else
           call ftukys(26,FITS_KEY_BUNIT,'ADU','values directly provided by camera',i)
        end if

        if( flatname /= '' ) then
           write(buf,'(1pg0.6)') flatmean
           call ftphis(26,phid//" flat-field: '"//trim(flatname)//"' / "//trim(buf),i)
        end if

        if( darkname /= '' ) then
           write(buf,'(f0.5)') t
           call ftphis(26,phid//" dark: '"//trim(darkname)//"' * "//trim(buf),i)
        end if

        if( biasname /= '' ) then
           call ftphis(26,phid//" bias: '"//trim(biasname)//"'",i)
        end if

        if( maskname /= '' ) then
           call ftphis(26,phid//" mask: '"//trim(maskname)//"'",i)
        end if

        call ftukys(26,FITS_KEY_CREATOR,FITS_VALUE_CREATOR,FITS_COM_CREATOR,i)
        call ftpcom(26,MUNIPACK_VERSION,i)

        ! corrected data
        call ftp2de(26,1,fits%naxes(1),fits%naxes(1),fits%naxes(2),OUT,i)

        ! stderr
        call ftiimg(26,bitpix,fits%naxis,fits%naxes,istat)
        call ftukys(26,'EXTNAME',EXT_STDERR,'',istat)
        call ftpcom(26,'The estimation of standard error.',istat)
        call ftp2de(26,1,fits%naxes(1),fits%naxes(1),fits%naxes(2),DOUT,istat)

        call ftclos(26,i)

        if( verbose ) write(error_unit,*) trim(outname)

665     continue

        if( allocated(FLAT) ) deallocate(FLAT,DFLAT)
        if( allocated(BIAS) ) deallocate(BIAS,DBIAS)
        if( allocated(DARK) ) deallocate(DARK,DDARK)

        if( allocated(OUT) ) deallocate(OUT,DOUT)

        call xfits_deallocate(fits)

     end if

  end do
20 continue

  call xfits_deallocate(maskfits)
  call xfits_deallocate(biasfits)
  call xfits_deallocate(darkfits)
  call xfits_deallocate(flatfits)

  if( allocated(OUT) ) deallocate(OUT,DOUT)

  if( i == 0 ) then
     stop 0
  else
     call ftrprt('STDERR',i)
  end if

end program phcorr
