!
! astrometry
!
!
! Copyright © 2011-20 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:
!
!   * add all WCS related projections
!   * add catalogue/reference matching identifier
!   * add correlation matching by FFT with help of artificial
!
!  testing:
!   * improve high-precision algorithm to fit all parameters simulatenously
!   * rewrite to use Penalty function to non-fitting parameters (centre)

! TODO for 0.5.7
!   * add mirror projection (done)
!   * add FITS extension with astrometry results
!   * filtering input for double stars (on photography or digital camera) (done)
!   * try to select better triangles firstly (abandoned)
!   * crossmatching by backtracking
!   * provide manual sequences as a reference parameter (done)
!   * estimate dispersion simultaneously
!   * use Rayleigh statistics (done)
!   * selection stars by magnitude limits (upper and lower)

program astrometry

  use titsio
  use astrofits
  use astrofitting
  use astromatcher
  use iso_fortran_env

  implicit none

  integer, parameter :: dbl = selected_real_kind(15)
  real(dbl), parameter :: rad = 57.295779513082322865_dbl

  character(len=4*FLEN_FILENAME) :: record, key, val, seq1, seq2
  character(len=FLEN_FILENAME) :: ref = '', cat = '', rel = '', &
       output = '', filename = ''
  character(len=FLEN_VALUE) :: col_ra = 'RAJ2000', col_dec = 'DEJ2000', &
       col_pmra = '', col_pmdec = '', col_mag = ''

  character(len=FLEN_VALUE) :: type = 'GNOMONIC', fit = 'ROBUST', aunits = '', &
       mode = 'MATCH'
  character(len=FLEN_VALUE) :: rframe = '', idcat = '', key_epoch = 'EPOCH', &
       key_dateobs = 'DATE-OBS'
  real(dbl), allocatable, dimension(:) :: alpha,delta,pmalpha,pmdelta,x,y, &
       ares,dres,flux, rflux
  integer,  allocatable, dimension(:) :: id1,id2
  integer,  allocatable, dimension(:) :: i1,i2
  character(len=FLEN_COMMENT), allocatable, dimension(:) :: com
  real(dbl), dimension(2) :: crpix = 0.0_dbl, crval = 0.0_dbl, &
       dcrval, xcrpix, xcrval
  real(dbl) :: tepoch,jd,scale = 1.0_dbl,dscale = epsilon(1.0_dbl), &
       angle = 0.0_dbl, dangle=epsilon(1.0_dbl), rms=0.0_dbl,a,da,b,db,s,ds,&
       w,h,density,sm,refl=1.0_dbl
  real(dbl) :: sig2 = 1.0, sig1= 1.0/3600.0, xsig = 3.0, fsig = -1
  integer :: eq,n,status,nseq,ncom
  integer :: minmatch = 5, maxmatch = 33
  integer :: luckymatch = 3
  logical :: fcrpix = .false., fcrval = .false., reflex = .false. ,&
       initpar = .true., matched = .false., rmscheck = .true., &
       fluxtest = .true., verbose = .false., wcssave = .true., &
       plog = .false., fullmatch = .false., init_match = .false., &
       ex, exitus = .true., reliable

  n = 0
  ncom = 0
  allocate(com(0))

  ! read input parameters
  do
     read(*,'(a)',end=99) record

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


     if( key == 'MODE' ) then

        read(val,*) mode  ! mode is expected as first parameter
        if( mode == 'DEFAULTS' ) call show_defaults

     elseif( key == 'PROJECTION' ) then

        read(val,*) type ! the projection must by defined before CAT,REF

     else if( key == 'FIT' ) then

        read(val,*) fit

     else if( key == 'AUNITS' ) then

        read(val,*) aunits

     else if( key == 'WCSSAVE' ) then

        read(val,*) wcssave

     else if( key == 'VERBOSE' ) then

        read(val,*) verbose

     else if( key == 'PIPELOG' ) then

        read(val,*) plog

     else if( key == 'CRPIX' ) then

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

     else if( key == 'CRVAL' ) then

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

     else if( key == 'SCALE' ) then

        read(val,*) scale

     else if( key == 'ANGLE' ) then

        read(val,*) angle

     else if( key == 'REFLEX' ) then

        read(val,*) reflex
        if( reflex ) refl = -1.0_dbl

     else if( key == 'SIG' ) then

        read(val,*) sig2

     else if( key == 'SIGCAT' ) then

        read(val,*) sig1

     else if( key == 'FSIG' ) then

        read(val,*) fsig

     else if( key == 'FLUXCHECK' ) then

        read(val,*) fluxtest

     else if( key == 'INITPAR' ) then

        read(val,*) initpar


     ! match parameters

     else if( key == 'MINMATCH' ) then

        read(val,*) minmatch
        init_match = .true.

     else if( key == 'MAXMATCH' ) then

        read(val,*) maxmatch
        init_match = .true.

     else if( key == 'FULLMATCH' ) then

        read(val,*) fullmatch

     else if( key == 'LUCKYMATCH' ) then

        read(val,*) luckymatch

        if( luckymatch < 0 ) stop 'Lucky match requires one or more stars.'

     else if( key == 'RMSCHECK' ) then

        read(val,*) rmscheck

     else if( key == 'COL_RA' ) then

        read(val,*) col_ra

     else if( key == 'COL_DEC' ) then

        read(val,*) col_dec

     else if( key == 'COL_PMRA' ) then

        read(val,*) col_pmra

     else if( key == 'COL_PMDEC' ) then

        read(val,*) col_pmdec

     else if( key == 'COL_MAG' ) then

        read(val,*) col_mag

     else if( key == 'FITS_KEY_EPOCH' ) then

        read(val,*) key_epoch

     else if( key == 'FITS_KEY_DATEOBS' ) then

        read(val,*) key_dateobs

     else if( key == 'NSEQ' ) then

        read(val,*) nseq

     else if( key == 'SEQ1' ) then

        read(val,*) seq1

     else if( key == 'SEQ2' ) then

        read(val,*) seq2

     else if( key == 'NCOM' ) then

        read(val,*) ncom
        deallocate(com)
        allocate(com(ncom))

     else if( key == 'COM' ) then

        if( size(com) > 0 ) then
           n = n + 1
           if( n < size(com) ) read(val,*) com(n)
        end if

     else if( key == 'REL' ) then

        read(val,*) rel
        call read_rel(rel)

     else if( key == 'REF' ) then

        read(val,*) ref
        call read_ref(ref)

     else if( key == 'CAT' ) then

        read(val,*) cat
        call read_cat(cat)

     else if( key == 'FILE' ) then

        read(val,*) filename, output

        if( mode == 'MATCH' .or. mode == 'SEQUENCE' ) then

           call calibrate(filename, output, ex)

        elseif( mode == 'MANUAL' ) then

           call mancal(filename, output, ex)

        elseif( mode == 'REMOVE' ) then

           call remove(filename, output, ex)

        elseif( mode == 'DEFAULTS' ) then

           call show_defaults

        end if

        exitus = exitus .and. ex

     end if


  end do
99 continue

  if( allocated(alpha) ) deallocate(alpha,delta,pmdelta,pmalpha,rflux)
  if( allocated(com) ) deallocate(com)

  if( exitus ) then
     stop 0
  else
     stop 'Some errors occurred during the astrometry calibration.'
  end if

contains

  subroutine calibrate(filename, output, exitus)

    character(len=*), intent(in) :: filename, output
    logical, intent(out) :: exitus

    type(fitsfiles) :: fits
    character(len=FLEN_COMMENT), allocatable, dimension(:) :: com
    real(dbl), dimension(2) :: zcrval

    exitus = .false.

    if( cat == '' .and. ref == '' .and. rel == '' ) &
         stop 'A reference file (catalogue, frame) unspecified.'

    if( verbose ) &
       write(error_unit,*) "Astrometry calibration of `"//trim(filename)//"'."

    if( plog ) write(*,'(a)') "=ASTROMETRY> Start `"//trim(filename)//"'."

    status = 0
    call readfile(filename,key_dateobs,w,h,x,y,flux,crpix,jd,zcrval,scale, &
         angle,refl,status)
    if( status /= 0 ) then
       write(error_unit,*) "Error: Failed to open  `" //trim(filename)//"'"
       goto 77
    end if

    if( .not. fcrval ) crval = xcrval

    if( mode == 'MATCH' ) then

       if( plog ) then
          write(*,'(a)') "=ASTROMATCH> Start"
          call uvhist(x,y)
       end if

       ! crowded field check, update parameters
       if( .not. init_match ) then
          density = size(x) / (w*h)  ! stars per sq. pixel
          if( density > 5e-4 ) then
             minmatch = 6
             maxmatch = 36
          else
             minmatch = 5
             maxmatch = 33
          end if
          if(verbose) &
               write(error_unit,'(2(a,i0),a)') &
               ' Match parameters updated: minmatch=', &
               minmatch,', maxmatch=',maxmatch,'.'
       end if

       call astromatch(minmatch,maxmatch,type,alpha,delta,pmalpha,pmdelta, &
            rflux,x,y,flux,crval(1),crval(2),crpix(1),crpix(2),id1,id2, &
            sig1,sig2,fsig,fluxtest,tepoch,jd,fullmatch,luckymatch,&
            verbose,plog,matched)
!           write(*,'(a,f10.7)') "=MATCH> End "

    else if( mode == 'SEQUENCE' ) then

       allocate(id1(nseq),id2(nseq))
       read(seq1,*) id1
       read(seq2,*) id2
       matched = .true.

!       call listmatch(type,alpha,delta,pmalpha,pmdelta,x,y,tepoch,jd, &
!            crval(1),crval(2),crpix(1),crpix(2),scale,angle,refl,xsig*sig2/scale,id1,id2,matched)

!           write(*,*) size(id1)
    end if

    if( .not. matched ) then
       if(plog) write(*,'(a)') "=ASTROMATCH> Finish Fail"

       write(error_unit,'(7a)') "Warning: Mutual match for files `", &
            trim(filename),"' and `",trim(cat),trim(ref),trim(rel), &
            "' failed. No common stars found."
    else
       if( plog ) write(*,'(a)') "=ASTROMATCH> Finish Success"

       if( plog ) write(*,'(a)') "=ASTROFIT> Start"
 !          if( verbose ) write(*,'(a)') "=> Fitting ..."
       call astrofit(fit,type,alpha,delta,pmalpha,pmdelta,x,y,sig2,xsig,&
            tepoch,jd,crpix(1),crpix(2),crval(1),dcrval(1),crval(2),dcrval(2),&
            scale,dscale,refl,rms,angle,dangle,ares,dres,id1,id2,i1,i2, &
            rmscheck,verbose,plog,reliable)

       if( .not. reliable ) write(error_unit,*) &
            'Warning: Reliability test failed for `',trim(filename),"'"

       ! use a return flag instead ?
       if( size(i1) > 0 ) then

          if( plog ) then
             write(*,'(a,e15.7)') "=ASTROFIT> Final ",rms
             write(*,'(a)') "=ASTROFIT> Finish Success"
          end if

          allocate(com(15+size(i1)))

          a = cos(angle/rad)
          da = abs((dangle/rad)*sin(angle/rad))
          b = sin(angle/rad)
          db = abs((dangle/rad)*cos(angle/rad))
          s = 3600.0_dbl*scale
          ds = s*dscale/scale

          if( aunits == '' ) then
             if( rel /= '' ) then
                aunits = 'pix'
             else if( log10(3600.0e6*rms) < 0.5 ) then
                aunits = 'uas'
             else if( log10(3600.0e3*rms) < 0.5 ) then
                aunits = 'mas'
             else if( log10(3600.0*rms) < 0.5 ) then
                aunits = 'arcsec'
             else if( log10(60.0*rms) < 0.5 ) then
                aunits = 'arcmin'
             else
                aunits = 'deg'
             end if
          end if

          if( rel /= '' ) then
             write(com(1),'(a)') "Type: relative"
             write(com(2),'(a)') "Reference frame: "//trim(rel)
          else
             write(com(1),'(a)') "Type: absolute"
             !                 write(com(2),'(a)') "Coordinate reference frame: ",trim(rframe)
             if( ref /= '' ) then
                write(com(2),'(a)') "Reference frame: "//trim(ref)
             else
                write(com(2),'(a)') "Reference catalogue: "//trim(idcat)
             end if
          end if
          write(com(3),'(a)') "Projection: "//trim(type)
          write(com(4),'(a,i0)') "Objects used = ",size(i1)
          if( aunits == 'arcsec' .or. aunits == 'arcmin' .or. &
               aunits == 'deg' .or. aunits == 'mas' .or. aunits == 'uas') then
             if( aunits == 'uas' ) then
                sm = 3600.0e6_dbl
             else if( aunits == 'mas' ) then
                sm = 3600.0e3_dbl
             else if( aunits == 'arcsec' ) then
                sm = 3600.0_dbl
             else if( aunits == 'arcmin' ) then
                sm = 60.0_dbl
             else if( aunits == 'deg' ) then
                sm = 1.0_dbl
             end if

             s = sm/scale
             ds = s*dscale/scale
             write(com(5),'(a,en11.1,3a)') "RMS = ",sm*rms,' [',trim(aunits),']'
             write(com(6),'(a,g15.7,a,es7.1,3a)') "Scale = ",s," +- ",ds, &
                  ' [',trim(aunits),'/pix]'
          else if( aunits == "pix" ) then
             write(com(5),'(a,g15.7,a)') "RMS = ",rms,' [pix]'
             write(com(6),'(a,g15.7,a,es7.1)') "Scale = ",scale," +- ",dscale
          end if
          write(com(7),'(a,f12.7,a,es7.1)') "cos(angle) = ",a," +- ",da
          write(com(8),'(a,f12.7,a,es7.1)') "sin(angle) = ",b," +- ",db
          write(com(9),'(a,l5)') "Reflexion = ", refl < 0
          write(com(10),'(a,f11.5,a,es7.1,a)') "Angle of rotation(angle) = ", &
               angle," +- ",dangle," [deg]"
          if( aunits == 'pix' ) then
             write(com(11), '(a,f12.7,a,es7.1)') &
                 "Alpha center projection (CRVAL1) = ",crval(1)," +- ",dcrval(1)
             write(com(12),'(a,f12.7,a,es7.1)') &
                 "Delta center projection (CRVAL2) = ",crval(2)," +- ",dcrval(2)
          else
             write(com(11),'(a,f12.7,a,es7.1,a)') &
                "Alpha center projection (CRVAL1) = ",crval(1)," +- ",dcrval(1)," [deg]"
             write(com(12),'(a,f12.7,a,es7.1,a)') "Delta center projection (CRVAL2) = ",&
                  crval(2)," +- ",dcrval(2)," [deg]"
          end if
          write(com(13),'(a,f9.3,a)') "Horizontal center (CRPIX1) = ",crpix(1),' [pix]'
          write(com(14),'(a,f9.3,a)') "Vertical   center (CRPIX2) = ",crpix(2),' [pix]'

          if( aunits == 'uas' .or. aunits == 'mas' .or. aunits == 'arcsec' .or. &
               aunits == 'arcmin' .or. aunits == 'deg' ) then
             write(com(15),'(3a)') 'Catalogue RA,DEC [deg]        Data X,Y [pix]     Residuals [',trim(aunits),']'
          else if( aunits == 'pix' ) then
             write(com(15),'(a)') 'Reference X,Y [pix]       Data X,Y [pix]       Residuals [pix]'
          end if

          if( rel /= '' ) then
             do n = 1, size(ares)
                write(com(15+n),'(2f9.3,6x,2f9.3,1x,2f9.3)') &
                     alpha(i1(n))+xcrpix(1),delta(i1(n))+xcrpix(2),x(i2(n)),y(i2(n)),ares(n),dres(n)
             end do
          else
             do n = 1, size(ares)
                write(com(15+n),'(2f13.7,2f9.3,2en12.1)') &
                     alpha(i1(n)),delta(i1(n)),x(i2(n)),y(i2(n)),sm*ares(n),sm*dres(n)
             end do
          end if

!              if( plog ) write(*,'("=C> ",a)') (trim(com(n)),n=1,size(com))
          if( verbose ) write(error_unit,'(a)') (trim(com(n)),n=1,size(com))

          if( wcssave ) then
             if( plog ) write(*,'(a)') "=WCSSAVE> Start"

             status = 0

             if( output == '' ) then
                call fits_open_file(fits,filename,FITS_READWRITE,status)
             else
                call fits_precopy_file(fits,filename,output,FITS_READWRITE, &
                     .true.,status)
             end if

              call wcsupdate(fits,type,crval,1/scale,angle,dangle, &
                  fcrpix,crpix,refl,rms,com,status)

             if( status == 0 ) then
                if( plog ) write(*,'(a)') "=WCSSAVE> Finish Success"
             else
                if( plog ) write(*,'(a)') "=WCSSAVE> Finish Fail"
                write(error_unit,*) &
                     "Warning: WCS save failed for `"//trim(filename)//"'."
             end if
             call fits_close_file(fits,status)
             call fits_report_error(error_unit,status)
             exitus = status == 0

          else
             exitus = .true.
          end if

          deallocate(com)


       else
          write(error_unit,'(a)') "Warning: Astrometry of `" // &
               trim(filename)//"' failed."
          if( plog ) write(*,'(a)') "=ASTROFIT> Finish Fail"
       end if

       if( allocated(ares)  ) deallocate(ares,dres,i1,i2)

    end if

77  continue
    if( allocated(x) ) deallocate(x,y,flux)
    if( allocated(id1) ) deallocate(id1,id2)

    if( plog ) write(*,'(a)') "=ASTROMETRY> Finish"

  end subroutine calibrate


  subroutine mancal(filename, output, exitus)

    use astrofits

    character(len=*), intent(in) :: filename, output
    logical, intent(out) :: exitus

    type(fitsfiles) :: fits
    integer :: status

    if( verbose ) write(error_unit,*) &
         "Manual astrometry calibration of `"//trim(filename)//"'."

    status = 0
    if( output == '' ) then
       call fits_open_file(fits,filename,FITS_READWRITE,status)
    else
       call fits_precopy_file(fits,filename,output,FITS_READWRITE,.true.,status)
    end if
    call wcsupdate(fits,type,crval,scale,angle,dangle,fcrpix,crpix,refl,rms,&
         com,status)
    call fits_close_file(fits,status)
    call fits_report_error(error_unit,status)

    exitus = status == 0

  end subroutine mancal


  subroutine remove(filename, output, exitus)

    use astrofits

    character(len=*), intent(in) :: filename, output
    logical, intent(out) :: exitus

    type(fitsfiles) :: fits
    integer :: status

    if( verbose ) write(error_unit,*) &
         "Removing astrometry calibration of `"//trim(filename)//"'."

    status = 0
    if( output == '' ) then
       call fits_open_file(fits,filename,FITS_READWRITE,status)
    else
       call fits_precopy_file(fits,filename,output,FITS_READWRITE,.true.,status)
    end if
    call wcsremove(fits,status)
    call fits_close_file(fits,status)
    call fits_report_error(error_unit,status)
    exitus = status == 0

  end subroutine remove


  subroutine read_rel(rel)

    character(len=*), intent(in) :: rel

    call readfile(rel,key_dateobs,w,h,x,y,rflux,xcrpix,tepoch,xcrval, &
         scale,angle,refl,status)
    if( status /= 0 ) stop 'Error: Opening of reference frame failed.'

    type = ' '
    xcrval = 0.0_dbl
    scale = 1.0_dbl
    angle = 0.0_dbl
    n = min(size(x),maxmatch)
    allocate(alpha(n),delta(n),pmalpha(n),pmdelta(n))
    alpha = x(1:n) - xcrpix(1)
    delta = y(1:n) - xcrpix(2)
    pmalpha = 0.0_dbl
    pmdelta = 0.0_dbl
    deallocate(x,y)

  end subroutine read_rel

  subroutine read_ref(ref)

    character(len=*), intent(in) :: ref

    call reffile(ref,key_dateobs,alpha,delta,rflux,tepoch,status)
    if( status /= 0 ) stop 'Error: Opening of reference frame failed.'

    if( initpar ) call init(alpha,delta,xcrval(1),xcrval(2))
    allocate(pmalpha(size(alpha)),pmdelta(size(delta)))
    pmalpha = 0.0_dbl
    pmdelta = 0.0_dbl

  end subroutine read_ref

  subroutine read_cat(cat)

    character(len=*), intent(in) :: cat

    call readtable(cat,col_ra,col_dec,col_pmra,col_pmdec,col_mag,&
         key_epoch,alpha,delta,pmalpha,pmdelta,rflux,rframe,idcat,tepoch,status)
    if( status /= 0 ) stop "Failed to open the catalogue file."
    if( initpar ) call init(alpha,delta,xcrval(1),xcrval(2))

  end subroutine read_cat


  subroutine init(a,d,acen,dcen)

    use oakleaf

    real(dbl), dimension(:), intent(in) :: a,d
    real(dbl), intent(out) :: acen,dcen
    real(dbl) :: x

    call rmean(a,acen,x)
    call rmean(d,dcen,x)

  end subroutine init


  subroutine show_defaults

    write(*,*) 'Default values for astrometry parameters :'
    write(*,*) '  Spherical Projection: ',trim(type)
    write(*,*) '  Right Ascension column label: ',trim(col_ra)
    write(*,*) '  Declination column label: ',trim(col_dec)
    write(*,*) '  Method for fitting: ',trim(fit)
    write(*,*) '  Minimum stars for matching: ',minmatch
    write(*,*) '  Maximum stars for matching: ',maxmatch
    write(*,*) '  Number stars for lucky matching: ',luckymatch

    write(*,*) '  Full match:   ',fullmatch
    write(*,*) '  Check fluxes: ',fluxtest
    write(*,*) '  Check RMS:    ',rmscheck
    write(*,*) '  Save results: ',wcssave
    write(*,'(a,f0.1,a)') &
         '   Mean uncertainty of centers stars on frame: ',sig2,' pix'
    write(*,'(a,f0.1,a)') &
         '   Mean uncertainty of stars in catalogue: ',sig1*3600.0,' arcsec'
    write(*,'(a,g0.1,a)') '   Mean uncertainty of fluxes: ',1.0

  end subroutine show_defaults


end program astrometry
