!
!  Dark     Average of a set of dark or bias frames.
!
!  Copyright © 1998-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/>.
!
!
!  TODO:
!
!   * Is there a benefit from arithmetic mean at 21. century?
!

program adark

!
! Computes average of darks or biases by the arithmetical mean
! of all images (non-robust but fast) or by the robust mean (remove
! defects on single frame but slower and more memory consuming).
!

  use LibList
  use robustmean
  use weightedmean
  use means
  use fitsio
  use xfitsio
  use iso_fortran_env

  implicit none

  character(len=*), parameter :: adid = 'DARK'

  ! Output image name:
  Character(len=FLEN_FILENAME) :: namedark='dark.fits', backup, biasname=''

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

  Character(len=4*FLEN_FILENAME) :: sb,key,val,record,buf
  Character(len=FLEN_CARD) :: dateobs,dateobs1,imagetyp1,imagetyp
  character(len=FLEN_KEYWORD) :: TEMPERAT=FITS_KEY_TEMPERATURE, &
       EXPTIME=FITS_KEY_EXPTIME,DATE_OBS=FITS_KEY_DATEOBS,KEY_IMAGETYP=FITS_KEY_IMAGETYP

  Integer :: i,j,n, eq, nobs, istat, naxis
  Integer, dimension(DIM) :: naxes
  integer :: bitpix = -32
  logical :: robust = .true.
  logical :: verbose = .false.

! image
  real, dimension(:,:), allocatable :: DARK, DDARK, SIG
  real, dimension(:,:), pointer :: ccd
  real, dimension(:), allocatable :: fbuf
  real :: t, temp, stemp, e, etime,setime,aval, sval
  real :: tol_exptime = 1e-6
  real :: tol_temperat = 1.0
  type(Imagetype), pointer :: list,curr
  type(xFITS) :: fits, bias

  call xfits_init(bias)

  call InitList(list)
  curr => list

  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 == 'OUTPUT' ) then
        read(val,*) namedark, backup
     endif

     if( key == 'MEAN' ) then
        read(val,*) buf
        robust = buf /= 'A';
     endif

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

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

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

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

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

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

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

     if( key == 'BIAS' ) then

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

     end if

     if( key == 'FILE' ) then

        if( verbose .and. getno(curr) == 0 ) &
             write(error_unit,*) "Filename, exposure time [s], temperature [degC]:"


        read(val,*) sb
        if( verbose ) write(error_unit,'(a)',advance="no") trim(sb)//":"

        call xfits_init(fits)
        call xfits_read(sb,fits)
        if( .not. fits%status ) then
           call xfits_deallocate(fits)
           goto 665
        end if

        if( getno(curr) > 0 .and. .not. all(naxes == fits%naxes) ) then
           write(error_unit,*) &
                "Dimensions of images mutually does not corresponds. Skipping."
           goto 665
        endif

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

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

        call xfits_kys(fits,DATE_OBS,dateobs,istat)
        if( istat /= 0 ) then
           istat = 0
           dateobs = ''
        end if

        call xfits_kys(fits,KEY_IMAGETYP,imagetyp,istat)
        if( istat /= 0 ) then
           istat = 0
           imagetyp = ''
        end if

        if( verbose ) write(error_unit,'(2x,1pg12.3,1x,0pf7.1)') e,t

        ! first image => initialisation
        if( getno(curr) == 0 )then

           naxis = fits%naxis
           naxes = fits%naxes

           allocate(DARK(naxes(1),naxes(2)),DDARK(naxes(1),naxes(2)), &
                SIG(naxes(1),naxes(2)))
           DARK = 0.0
           SIG = 0.0
           DDARK = 0.0
           dateobs1 = dateobs
           imagetyp1 = imagetyp

           if( bias%status ) then
              if( .not. all(bias%naxes == naxes) ) &
                   stop "Biases has different axes sizes."
           end if

        end if

        if( bias%status ) fits%image = fits%image - bias%image
        ! bias error is neglected

        if( robust ) then
           allocate(ccd(naxes(1),naxes(2)))
           ccd = fits%image
           Call AddItem (curr,image=ccd,filename=sb,dateobs=dateobs,exptime=e,temp=t)
        else

           ! compute sumation
           DARK = DARK + fits%image
           SIG  = SIG  + fits%image**2

           ! add image
           Call AddItem (curr,filename=sb,dateobs=dateobs,exptime=e,temp=t)
        endif

665     continue
        call xfits_deallocate(fits)

     end if

  enddo

20 continue
  nobs = getno(curr)

  if( nobs == 0 ) stop 'None input image(s) are available to open.'

  if( nobs > 1 ) then

     if( verbose ) then
        write(error_unit,*)
        write(error_unit,*) 'Mean of frame(s):',nobs
        write(error_unit,*) 'Computed by mean: ',robust,' (T=robust, F=arithmetical)'
        write(error_unit,*) 'Dimensions:',naxes(1),'x',naxes(2)
        write(error_unit,*) 'Preparing a bias or dark frame ...'
     end if

     ! computation of mean
     if( robust ) then

        allocate(fbuf(nobs))
        do j = 1, naxes(2)
           do i = 1, naxes(1)

              curr => list
              do
                 curr => GetNext(curr)
                 if( .not. associated(curr) ) exit
                 call GetItem(curr,image=ccd)
                 n = getno(curr)
                 fbuf(n) = ccd(i,j)
              enddo
              call rmean(fbuf,DARK(i,j),DDARK(i,j),SIG(i,j))

           enddo
        enddo
        deallocate(fbuf)

        call rwmean(pack(DARK,DDARK > 0),pack(DDARK,DDARK > 0),aval,sval)

     else

        DARK = DARK / nobs
        SIG = sqrt((max(SIG - nobs*DARK**2,0.0)/(nobs - 1)))
        DDARK = SIG / sqrt(real(nobs))

        aval = sum(DARK)/size(DARK)
        sval = sum(SIG,mask=SIG>0) / count(SIG>0)

     end if

     allocate(fbuf(nobs))
     ! mean exposure time
     curr => list
     do
        curr => GetNext(curr)
        if( .not. associated(curr) ) exit
        n = getno(curr)
        call GetItem(curr,exptime=fbuf(n))
     enddo
     if( robust ) then
        call rmean(fbuf,etime,setime)
     else
        call mean(fbuf,etime,setime)
     end if
     setime = setime / sqrt(real(nobs))

     ! check exptimes
     if( etime > 0 )then
        curr => list
        do
           curr => GetNext(curr)
           if( .not. associated(curr) ) exit
           n = getno(curr)
           call GetItem(curr,filename=sb,exptime=e)
           if( e > 0 .and. abs(e-etime) > tol_exptime ) write(error_unit,*) &
                "Warning: Exposure time out of limit for `",trim(sb),"': ",e
        enddo
     end if

     ! computation of mean temperature
     curr => list
     do
        curr => GetNext(curr)
        if( .not. associated(curr) ) exit
        n = getno(curr)
        call GetItem(curr,temp=fbuf(n))
     enddo
     if( robust ) then
        call rmean(fbuf,temp,stemp)
     else
        call mean(fbuf,temp,stemp)
     end if
     stemp = stemp / sqrt(real(nobs))

     ! check temperatures
     if( temp > -273.0 ) then
        curr => list
        do
           curr => GetNext(curr)
           if( .not. associated(curr) ) exit
           n = getno(curr)
           call GetItem(curr,filename=sb,temp=t)
           if( t > -273 .and. abs(t-temp) > tol_temperat ) write(error_unit,*) &
                "Warning: Temperature out of limit for `",trim(sb),"': ",t
        enddo
     end if

     deallocate(fbuf)

  else

     ! nobs == 1
     DARK = ccd
     temp = t
     stemp = 0.0
     etime = e
     setime = 0.0
     aval = sum(DARK)/size(DARK)
     sval = 0.0

  end if

  if( verbose ) then
     write(error_unit,*) 'Output image: ',trim(namedark)
     write(error_unit,*) 'Average level: ',aval,'+-',sval
     write(error_unit,*) 'Average exposure time: ',etime,'+-',setime
     write(error_unit,*) 'Average temperature: ',temp,'+-',stemp
  end if

  ! save output image
  istat = 0
  call fitsbackup(namedark,backup,istat)
  Call ftinit(26,namedark,1,istat)
  Call ftphps(26,bitpix,naxis,naxes,istat)
  if( etime > 0.0 )then
     call ftpkye(26,EXPTIME,etime,6,'Average of exposure times',istat)
  end if
  if( temp > -273.0 )then
     call ftpkye(26,TEMPERAT,temp,4,'Average of camera temperatures',istat)
  end if
  call ftpkys(26,DATE_OBS,dateobs1,'UTC of the first on input',istat)
  if( bitpix > 0 ) then
     call ftpkyj(26,'BSCALE',1,'',istat)
     call ftpkyj(26,'BZERO',2**(bitpix-1),'',istat)
  endif
  if( imagetyp1 /= '' ) &
     call ftpkys(26,KEY_IMAGETYP,imagetyp,'image type',istat)
  if( temp > -273.0 )then
     write(buf,'(a,f0.2,a,f0.2,a)') ' Average temperature = ',temp,' +- ',stemp
     call ftpcom(26,buf(2:),istat)
  end if
  if( etime > 0.0 )then
     write(buf,'(a,1pg0.6,a,1pg0.2)') ' Average exposure time = ',etime,' +- ',setime
     call ftpcom(26,buf(2:),istat)
  end if
  write(buf,'(a,1pg0.5,a,1pg0.1)') ' Average level = ',aval,' +- ',sval
  call ftpcom(26,buf(2:),istat)

  if( bias%status ) call ftpcom(26,'BIAS: '//trim(bias%filename),istat)

  if( nobs > 0 ) then
     write(buf,'(a,i0,a)') 'Result of average of ',nobs,'  exposure(s).'
     call ftpcom(26,buf,istat)
     call ftpcom(26,'File name, time of start and temperature for each frame:',istat)
     curr => list
     do
        curr => GetNext(curr)
        if( .not. associated(curr) ) exit
        call GetItem(curr,filename=sb,dateobs=dateobs,temp=t)
        write(buf,'(f0.2)') t
        call ftpcom(26,"'"//trim(sb)//"' '"//trim(dateobs)//"' "//trim(buf),istat)
        ! just part of the comment will visible for very long filenames
     enddo
  endif
  if( robust ) then
     call FTPCOM(26,'The robust mean has been used.',istat)
  else
     call FTPCOM(26,'The arithmetical mean has been used.',istat)
  end if

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

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

  if( istat /= 0 ) goto 666

  ! data
  call ftp2de(26,1,naxes(1),naxes(1),naxes(2),DARK,istat)
  if( istat == NUMERICAL_OVERFLOW ) then
     write(error_unit,*) 'Warning: Numerical overflow occurred while writing dark.'
     istat = 0
  end if

  ! stderr
  call ftiimg(26,bitpix,naxis,naxes,istat)
  call ftukys(26,'EXTNAME',EXT_STDERR,'',istat)
  call ftpcom(26,'An estimation of standard error of every pixel.',istat)
  call ftp2de(26,1,naxes(1),naxes(1),naxes(2),DDARK,istat)
  if( istat == NUMERICAL_OVERFLOW ) then
     write(error_unit,*) 'Warning: Numerical overflow occurred while writing std.err.'
     istat = 0
  end if

  call ftclos(26,istat)
  if( istat /= 0 ) goto 666

  call DestroyList(list)
  deallocate(DARK,DDARK,SIG)

  call xfits_deallocate(bias)

  stop 0

666 continue

  call xfits_deallocate(bias)

  call ftrprt('STDERR',istat)

end program adark
