!
! Kombine     Combine a set of frames.
!
! Copyright © 1998-2006, 2011-21 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/>.
!

program kombine

  use fitskombi
  use oakleaf
  use astrotrafo
  use phio
  use titsio
  use iso_fortran_env

  implicit none

  integer, parameter :: dbl = selected_real_kind(15)

  character(len=FLEN_FILENAME) :: filename
  character(len=4*FLEN_FILENAME) :: key,val, record
  character(len=80) :: msg

  character(len=FLEN_KEYWORD), dimension(7) :: fitskeys
  character(len=FLEN_FILENAME) :: output = 'kombine.fits'

  ! spherical sprojection
  logical :: init_sproj = .false.  ! initialised by user
  logical :: init_crval = .false.  ! initialised by user
  logical :: init_crpix = .false.
  logical :: init_scale=.false.
  logical :: init_angle=.false.
  logical :: init_reflex = .false.
  logical :: init_jdref = .false.
  character(len=FLEN_VALUE) :: ptype = "GNOMONIC"
  real(dbl) :: scale = 1.0/3600.0! deg per pixel
  real(dbl) :: angle = 0         ! rotation in degrees
  logical :: reflex = .false.
  real(dbl) :: jdref = 0         ! proper motion reference JD
  real(dbl), dimension(2) :: crval, crpix
  real(dbl), dimension(2) :: crmov = [ real(0.0,dbl), real(0.0,dbl) ]
  real(dbl) :: longitude, latitude
  logical :: geodefined = .false.

  ! information keywords
  character(len=FLEN_VALUE) :: object = ''
  character(len=FLEN_VALUE) :: filter = ''
  character(len=FLEN_VALUE) :: dateobs = ''
  integer :: bitpix = -32        ! default output bitpix
  integer, dimension(2) :: naxes = -1 ! the code is restricted on 2D frames
  integer :: nfiles = 0          ! input files count
  real :: exptime = 1            ! mean exposure time
  logical :: robust = .true.     ! output image is computed by robust mean
  logical :: background = .true. ! subtract background
  logical :: verbose = .false.   ! verbose output
  logical :: pipelog = .false.

  ! selection of method of interpolation:
  !
  !  NEAR(default)  BILINEAR    BICUBIC   BI3CONV
  !  fast           slow        slower    the slowest
  !  pixelized      good        perfect   for undersampled
  !
  ! warning: all BI-* methods can give an undesired fringing patterns
  ! on the background
  character(len=10) :: method = 'NEAR'

  integer :: eq, stat, status
  type(KombiFits) :: fits
  type(KombiFits), dimension(:), allocatable :: files
  type(AstroTrafoProj) :: sproj     ! spherical projection
  real, dimension(:,:), allocatable :: IMAGE, EXPMASK

  ! mandatory keys
  fitskeys = [ FITS_KEY_DATEOBS, FITS_KEY_TIMEOBS, FITS_KEY_EXPTIME, &
       FITS_KEY_FILTER, FITS_KEY_OBJECT, FITS_KEY_LONGITUDE, &
       FITS_KEY_LATITUDE ]

  do
     read(*,'(a)',iostat=stat,iomsg=msg) record
     if( stat == IOSTAT_END ) exit
     if( stat > 0 ) then
        write(error_unit,*) trim(msg)
        error stop 'An input error.'
     end if

     eq = index(record,'=')
     if( eq == 0 ) stop 'Malformed input record.'

     key = record(:eq-1)
     val = record(eq+1:)

     if( key == 'OUTPUT' ) then

        read(val,*) output

     else if( key == 'FITS_KEY_OBJECT' ) then

        read(val,*) fitskeys(5)

     else if( key == 'FITS_KEY_FILTER' ) then

        read(val,*) fitskeys(4)

     else if( key == 'FITS_KEY_EXPTIME' ) then

        read(val,*) fitskeys(3)

     else if( key == 'FITS_KEY_DATEOBS' ) then

        read(val,*) fitskeys(1)

     else if( key == 'FITS_KEY_TIMEOBS' ) then

        read(val,*) fitskeys(2)

     else if( key == 'FITS_KEY_LONGITUDE' ) then

        read(val,*) fitskeys(6)

     else if( key == 'FITS_KEY_LATITUDE' ) then

        read(val,*) fitskeys(7)

     else if( key == 'VERBOSE' ) then

        read(val,*) verbose

     else if( key == 'PIPELOG' ) then

        read(val,*) pipelog

     else if( key == 'BITPIX' ) then

        read(val,*) bitpix

     else if( key == 'SCALE' ) then

        read(val,*) scale
        init_scale = .true.

     else if( key == 'ANGLE' ) then

        read(val,*) angle
        init_angle = .true.

     else if( key == 'REFLEX' ) then

        read(val,*) reflex
        init_reflex = .true.

     else if( key == 'CRVAL' ) then

        read(val,*) crval
        init_crval = .true.

     else if( key == 'CRMOV' ) then

        read(val,*) crmov

     else if( key == 'JDREF' ) then

        read(val,*) jdref
        init_jdref = .true.

     else if( key == 'CRPIX' ) then

        read(val,*) crpix
        init_crpix = .true.

     else if( key == 'NAXES' ) then

        read(val,*) naxes

     else if( key == 'SPROJECTION' ) then

        read(val,*) ptype
        init_sproj = .true.

     else if( key == 'INTERPOL' ) then

        read(val,*) method
        if( .not. (method == 'NEAR' .or. method == 'BILINEAR' .or. &
             method == 'BICUBIC' .or. method == 'BI3CONV') ) &
             stop 'Specified interpolation method is not implemented yet.'

     else if( key == 'ROBUST' ) then

        read(val,*) robust

     else if( key == 'BACKGROUND' ) then

        read(val,*) background

     else if( key == 'NFILES' ) then

        read(val,*) nfiles
        allocate(files(nfiles))
        nfiles = 0

     else if( key == 'FILE' ) then

        read(val,*) filename

        call fits%Load(filename,fitskeys,background,verbose)
        if( fits%status ) then
           nfiles = nfiles + 1
           files(nfiles) = fits
        else
           write(error_unit,*) &
                "Error: file `",trim(filename),"' read failed. Ignored."
        end if

     end if

  end do ! read

  if( nfiles == 0 ) stop 'No input images.'

  ! Section: initialisation -----------------------------------
  ! Unspecified parameters are derived from the first frame
  block

    exptime = 1

    if( dateobs == '' ) &
         dateobs = files(1)%dateobs

    if( filter == '' ) &
         filter = files(1)%filter

    if( object == '' ) &
         object = files(1)%object

    if( files(1)%geo ) then
       geodefined = .true.
       longitude = files(1)%longitude
       latitude = files(1)%latitude
    end if

    call trafo_fromwcs(sproj,files(1)%ctype,files(1)%crval,files(1)%crpix, &
         files(1)%cd,files(1)%crerr)

    if( any(naxes <= 0) ) &
       naxes = files(1)%naxes

    if( init_sproj ) sproj%type = ptype
    if( init_crval ) then
       sproj%acen = crval(1)
       sproj%dcen = crval(2)
    end if
    if( init_crpix ) then
       sproj%xcen = crpix(1)
       sproj%ycen = crpix(2)
    else
       sproj%xcen = naxes(1) / 2
       sproj%ycen = naxes(2) / 2
    end if
    if( init_scale ) sproj%scale = scale
    if( init_angle ) sproj%rot = angle
    if( init_reflex )then
       if( reflex ) then
          sproj%refl = -1.0_dbl
       else
          sproj%refl = 1.0_dbl
       end if
    end if

    call trafo_refresh(sproj)

    ! reference time for proper motion
    if( .not. init_jdref ) jdref = files(1)%jd()

  end block ! init

  ! time to create the output image
  allocate(IMAGE(naxes(1),naxes(2)),EXPMASK(naxes(1),naxes(2)), &
       stat=stat,errmsg=msg)
  if( stat /= 0 ) then
     write(error_unit,*) "Error: ",trim(msg)
     stop 'Failed to allocate memory.'
  end if
  IMAGE = 0
  EXPMASK = 0


  ! Section: processing ---------------------------------------------
  block

    real, dimension(:,:,:), allocatable :: bigimg
    logical, dimension(:,:), allocatable :: mask, fill
    real(dbl), dimension(:,:), allocatable :: alpha, delta
    real, dimension(:,:), allocatable :: img
    real, dimension(:), allocatable :: fbuf
    real :: amean
    integer :: i,j,n

    allocate(alpha(naxes(1),naxes(2)),delta(naxes(1),naxes(2)),fbuf(nfiles), &
         img(naxes(1),naxes(2)),mask(naxes(1),naxes(2)), &
         fill(naxes(1),naxes(2)),stat=stat,errmsg=msg)
    if( stat /= 0 ) then
       write(error_unit,*) trim(msg)
       error stop 'Failed to allocate an image.'
    end if

    ! determine nodes of sky coordinate grid
    do i = 1, naxes(1)
       do j = 1, naxes(2)
          call invtrafo(sproj,real(i,dbl),real(j,dbl),alpha(i,j),delta(i,j))
       end do
    end do

    ! compute mean exposure time
    do n = 1, nfiles
       fbuf(n) = files(n)%exptime
    end do
    call rmean(fbuf,exptime)

    ! mask of touched pixels, value .true. is for pixels which needs to be
    ! additionaly set with image mean
    fill = .true.

    if( robust ) then
       ! compute the average by robust mean

       ! allocate memory
       allocate(bigimg(naxes(1),naxes(2),nfiles),stat=stat,errmsg=msg)
       if( stat /= 0 ) then
          write(error_unit,*) trim(msg)
          error stop 'Failed to allocate so big image.'
       end if

       do n = 1, nfiles
          if( files(n)%loadimg() ) then
             call files(n)%reproject(method,jdref,crmov,alpha,delta,img,mask)
             where( mask )
                bigimg(:,:,n) = img / (files(n)%exptime / exptime) ! area?
             elsewhere
                bigimg(:,:,n) = -1
             end where
             fill = fill .and. .not. mask
             deallocate(files(n)%image)
          end if
       end do

       do i = 1, naxes(1)
          do j = 1, naxes(2)
             if( .not. fill(i,j) ) then
                call rmean(pack(bigimg(i,j,:),bigimg(i,j,:)>0),IMAGE(i,j))
             end if
          end do
       end do

    else
       ! compute the average by arithmetic mean
       do n = 1, nfiles
          if( files(n)%loadimg() ) then
             call files(n)%reproject(method,jdref,crmov,alpha,delta,img,mask)
             where( mask )
                IMAGE = IMAGE + img
                EXPMASK = EXPMASK + (files(n)%exptime / exptime)
             end where
             fill = fill .and. .not. mask
             deallocate(files(n)%image)
          end if
       end do

       where( EXPMASK > 0 )
          IMAGE = IMAGE / EXPMASK
       end where
    end if

    ! fill untouched pixels by mean
    amean = imean(.not.fill,IMAGE)
    do i = 1, naxes(1)
       do j = 1, naxes(2)
          if( fill(i,j) ) IMAGE(i,j) = amean
       end do
    end do

    ! scale on proper values
    IMAGE = nfiles * IMAGE

  end block

  ! Section: FITS save ----------------------------------------------
  block
    integer :: n,naxis
    character(len=FLEN_COMMENT) :: buf
    character(len=FLEN_VALUE), dimension(2) :: ctype
    real(dbl), dimension(2) :: crval,crpix,crder
    real(dbl), dimension(2,2) :: cd,rmat
    real, parameter :: minvalue = 0
    real :: maxvalue
    type(fitsfiles) :: fits

    status = 0
    call fits_create_scratch(fits,status)
    naxis = size(naxes)
    call fits_insert_img(fits,bitpix,naxis,naxes,status)
    if( object /= '' ) then
       call fits_update_key(fits,fitskeys(5),object,'',status)
    end if
    if( filter /= '' ) then
       call fits_update_key(fits,fitskeys(4),filter,'',status)
    end if
    call fits_update_key(fits,fitskeys(3),nfiles*exptime,-3,'Total exposure time',status)
    if( dateobs /= '' ) then
       call fits_update_key(fits,fitskeys(1),dateobs,'',status)
    end if

    if( geodefined ) then
       call fits_update_key(fits,fitskeys(6),longitude,-5, &
            '[deg] geographic longitude (-east)',status)
       call fits_update_key(fits,fitskeys(7),latitude,-5, &
            '[deg] geographic latitude (+north)',status)
    end if

    rmat(1,:) = real([-1,0],dbl)
    rmat(2,:) = real([ 0,1],dbl)
    cd = matmul(rmat,sproj%mat)

    ctype = [ 'RA---TAN', 'DEC--TAN' ]
    crval = [ sproj%acen, sproj%dcen ]
    crpix = [ sproj%xcen, sproj%ycen ]
    crder = sproj%err
    call fits_update_wcs(fits,ctype,crval,crpix,cd,crder,status)

    if( sproj%type == '' ) then
       call fits_write_errmark
       call fits_delete_key(fits,'CTYPE1',status)
       call fits_delete_key(fits,'CTYPE2',status)
       if( status == FITS_KEYWORD_NOT_FOUND ) then
          call fits_clear_errmark
          status = 0
       end if
    end if

    write(buf,'(a,i0,a)') &
         'The image is a collection of ',nfiles,' exposure(s):'
    call fits_write_comment(fits,buf,status)
    do n = 1, nfiles
       call fits_write_comment(fits,"'"//trim(files(n)%filename)//"'",status)
    enddo

    if( robust ) then
       buf = 'robust'
    else
       buf = 'arithmetic'
    end if
    call fits_write_comment(fits, &
         'The averadge by '//trim(buf)//' mean.',status)

    if( method == 'NEAR' ) then
       buf = 'Nearest-neighbour'
    else if( method == 'BILINEAR' ) then
       buf = 'Bi-linear'
    else if( method == 'BICUBIC' ) then
       buf = 'Bicubic'
    else if( method == 'BI3CONV' ) then
       buf = 'Bicubic convolution '
    else
       buf = 'Unspecified'
    end if
    call fits_write_comment(fits,trim(buf) // &
         ' method of interpolation has been used.',status)

    ! range cut-off
    if( bitpix > 0 )then
       maxvalue = 2.0**bitpix - 1.0
       IMAGE = max(minvalue,min(maxvalue,IMAGE))
    end if

    call fits_write_image(fits,0,IMAGE,status)

    if( status == 0 ) then
       if( fits_file_exist(output) ) call fits_file_delete(output)
       call fits_file_duplicate(fits,output,status)
    end if
    call fits_delete_file(fits,status)
    call fits_report_error(error_unit,status)

  end block

  deallocate(files,IMAGE,EXPMASK)

  ! print output info
  if( verbose .and. status == 0 ) then
     write(*,*) 'Output image: ',trim(output)
     write(*,*) 'Dimension: ',naxes(1),'x',naxes(2)
  end if

  if( status == 0 )then
     stop 0
  else
     stop 'An error during kombine run occurred.'
  end if

contains

  real function imean(fill,IMAGE)

    ! estimates mean of te IMAGE by using computed pixels

    logical, dimension(:,:), intent(in) :: fill
    real, dimension(:,:), intent(in) :: IMAGE
    real, dimension(:), allocatable :: fbuf
    integer :: i, j, n, nstep
    real :: x, y

    n = minval(naxes) / 77
    nstep = minval(naxes) / n
    allocate(fbuf(nstep**2))

    ! very sparse grid
    n = 0
    do i = 1, naxes(1), nstep
       do j = 1, naxes(2), nstep
          if( fill(i,j) .and. n < size(fbuf) ) then
             n = n + 1
             fbuf(n) = IMAGE(i,j)
          end if
       end do
    end do

    if( n > 0 ) then
       call rmean(fbuf(1:n),imean)
    else
       ! random selection is also very fine
       do n = 1, 10
          call random_number(x)
          i = int(naxes(1)*x)
          call random_number(y)
          j = int(naxes(2)*y)
          if( 0 < i .and. i < naxes(1) .and. 0 < j .and. j < naxes(2) ) then
             imean = IMAGE(i,j)
             if( fill(i,j) ) return
          end if
       end do
    end if

  end function imean

end program kombine
