!
! Catalogue cross-match
!
! Copyright © 2013 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 cross

  use iso_fortran_env
  use fitsio

  implicit none

  integer, parameter :: dbl = selected_real_kind(15)
  integer, parameter :: nfile = 2

  integer :: eq
  character(len=FLEN_VALUE), dimension(nfile) :: col_ra, col_dec, &
       col_pmra, col_pmdec, col_mag
  character(len=FLEN_KEYWORD) :: key_epoch
  character(len=4*FLEN_FILENAME) :: record, key, val, output, backup
  character(len=4*FLEN_FILENAME), dimension(nfile) :: file
  logical :: verbose = .false.
  real(dbl) :: tol,ftol
  integer :: n

  key_epoch = FITS_KEY_EPOCH
  col_ra = 'RA'
  col_dec = 'DEC'
  col_pmra = ''
  col_pmdec = ''
  col_mag = ''

  file=''
  output = ''
  backup = ''
  tol = epsilon(tol)
  ftol = 1

  do
     
     read(*,'(a)',end=99) 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

     else if( key == 'OUTPUT' ) then

        read(val,*) output, backup

     else if( key == 'NFILE' ) then

        read(val,*) n
        if( nfile /= n ) stop 'Cross-match requires exactly two files.'
        n = 0

     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 == 'TOL' ) then

        read(val,*) tol

     else if( key == 'FTOL' ) then

        read(val,*) ftol

     else if( key == 'FILE' ) then

        n = n + 1
        read(val,*) file(n)

     end if

  end do
99 continue

  call crossing

  stop 0

contains


  subroutine crossing

    use crossmatch

    real(dbl), allocatable, dimension(:) :: ra1,dec1,flux1,ra2,dec2,flux2
    integer, dimension(:,:), allocatable :: idx
    character(len=FLEN_VALUE) :: catid1,catid2
    integer :: status
!    integer :: i

    status = 0
    call tabcoo(file(1),col_ra(1),col_dec(1),col_pmra(1),col_pmdec(1),&
         col_mag(1),key_epoch,ra1,dec1,flux1,catid1,status)
    call tabcoo(file(2),col_ra(2),col_dec(2),col_pmra(2),col_pmdec(2),&
         col_mag(2),key_epoch,ra2,dec2,flux2,catid2,status)

    allocate(idx(nfile,max(size(ra1),size(ra2))))

    call join(ra1,dec1,ra2,dec2,tol,ftol,idx)

    ! check point
!    do i = 1,size(idx,2)
!       if( idx(2,i) > 0 ) then
!          write(*,*) i,idx(:,i),ra2(idx(2,i)),dec2(idx(2,i)),ra1(i),dec1(i)
!       end if
!    end do
    
    call savecross(output,file,idx,status)

    deallocate(ra1,dec1,ra2,dec2,flux1,flux2,idx)

  end subroutine crossing

  
  subroutine tabcoo(filename,col_ra,col_dec,col_pmra,col_pmdec,&
         col_mag,key_epoch,ra,dec,flux,catid,status)

    use trajd

    character(len=*), intent(in) :: filename, col_ra, col_dec, col_pmra, &
         col_pmdec, col_mag, key_epoch
    real(dbl), allocatable, dimension(:), intent(out) :: ra, dec, flux
    character(len=*), intent(out) :: catid
    integer, intent(in out) :: status

    real(dbl), parameter :: nullval = 0.0_dbl
    integer, parameter :: ncols = 5, frow = 1, felem = 1
    integer, dimension(ncols) :: col, statuses
    integer :: nrows,i
    logical :: anyf
    character(len=FLEN_CARD) :: buf
    character(len=FLEN_VALUE), dimension(ncols) :: label,colname
    real(dbl), allocatable, dimension(:) :: alpha, delta, pmalpha, pmdelta
    real(dbl) :: t0,t,dt

    if( status /= 0 ) return

    ! ICRS
    t0 = yearjd(2000.00_dbl)

    label(1) = col_ra
    label(2) = col_dec
    label(3) = col_pmra
    label(4) = col_pmdec
    label(5) = col_mag

    if( label(1) == '' .or. label(2) == '' ) then
       write(error_unit,*) "Coordinate columns are not fully specified (empty)."
       return
    end if

    ! open and move to a table extension
    call fttopn(15,filename,0,status)
    call ftgnrw(15,nrows,status)
    if( status /= 0 ) then
       write(error_unit,*) "Failed to open table in `"//trim(filename)//"'."
       goto 666
    end if

    if( .not. (nrows > 0) ) then
       write(error_unit,*) "Table `"//trim(filename)//"' looks empty."
       goto 666
    end if

    ! identification of catalogue
    call ftgkys(15,'EXTNAME',catid,buf,status)
    call ftgkyd(15,key_epoch,t,buf,status)
    if( status == KEYWORD_NOT_FOUND ) then
       write(error_unit,*) "Epoch by `"//trim(key_epoch)// &
            "' keyword not found (assumed J2000.0)."
       status = 0
       t = t0
    end if

    ! find columns by labels
    statuses = 0
    col = 0
    do i = 1, ncols
       if( label(i) /= '' ) then
          call ftgcnn(15,.false.,label(i),colname(i),col(i),statuses(i))
       else
          col(i) = 0
       end if
    end do
    
    if( col(1) == 0 .or. col(2) == 0 ) then
       write(error_unit,*) "Coordinates column `"//trim(col_ra)//","// &
            trim(col_dec)//"' in `"//trim(filename)//"' not found."
       goto 666
    end if



    allocate(alpha(nrows),delta(nrows))
    call ftgcvd(15,col(1),frow,felem,nrows,nullval,alpha,anyf,status)
    call ftgcvd(15,col(2),frow,felem,nrows,nullval,delta,anyf,status)
    if( status /= 0 ) goto 666

    allocate(pmalpha(nrows),pmdelta(nrows))
    pmalpha = 0.0_dbl
    pmdelta = 0.0_dbl
    if( col(3) /= 0 .and. col(4) /= 0) then
       call ftgcvd(15,col(3),frow,felem,nrows,nullval,pmalpha,anyf,status)
       call ftgcvd(15,col(4),frow,felem,nrows,nullval,pmdelta,anyf,status)
    end if
    if( status == 0 ) then
       pmalpha = pmalpha / 3.6e6_dbl  ! supposing mas/year
       pmdelta = pmdelta / 3.6e6_dbl
    else 
       write(error_unit,*) "Requested proper-motion columns `"//trim(col_ra)//","// &
            trim(col_dec)//"' in `"//trim(filename)//"' not found."
       goto 666
    end if

    allocate(flux(nrows))
    if( col(5) /= 0 ) then
       call ftgcvd(15,col(5),frow,felem,nrows,nullval,flux,anyf,status)

       if( status == 0 ) then
          flux = 10.0**((25.0 - flux)/2.5)
       else
          write(error_unit,*) "Requested proper-motion columns `"//trim(col_ra)//","// &
               trim(col_dec)//"' in `"//trim(filename)//"' not found."
          flux = 0.0
       end if
    end if

    if( status /= 0 ) goto 666

    call ftclos(15,status)


    ! compute coordinates for the epoch
    allocate(ra(nrows),dec(nrows))
    dt = (t - t0)/ 365.25


    ra  = alpha + dt*pmalpha
    dec = delta + dt*pmdelta

!    return

666 continue

    if( allocated(alpha) ) deallocate(alpha,delta)
    if( allocated(pmalpha) ) deallocate(pmalpha,pmdelta)
!    if( allocated(flux) ) deallocate(flux)

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


  end subroutine tabcoo

  subroutine savecross(output,filename,idx,status)

    character(len=*), intent(in) :: output
    character(len=*), dimension(:), intent(in) :: filename
    integer, dimension(:,:), intent(in) :: idx
    integer, intent(in out) :: status

    integer, parameter :: frow = 1, felem = 1
    character(len=FLEN_VALUE), dimension(:), allocatable :: ttype, tform,tunit
    character(len=FLEN_KEYWORD) :: key
    integer, dimension(:), allocatable :: iq
    integer :: nrows,i

    status = 0
    call ftinit(26,output,0,status)

    allocate(ttype(nfile),tform(nfile),tunit(nfile))

    tform = '1J'
    tunit = ''

    ttype = filename
    call ftibin(26,0,size(ttype),ttype,tform,tunit,'CROSSMATCH',0,status)

    do i = 1,nfile
       write(key,'(a,i1)') 'FILE',i
       call ftukys(26,key,filename(i),'FITS table',status)
    end do

    nrows = size(idx,2)
    allocate(iq(nrows))
    do i = 1,nfile
       iq = idx(i,:)
       call ftpclj(26,i,frow,felem,nrows,iq,status)
    end do
    deallocate(iq)
    call ftclos(26,status)

    call ftrprt('STDERR',status)

    deallocate(ttype,tform,tunit)

  end subroutine savecross
  

end program cross
