!
!  timeserie, light curve
!
!  Copyright © 2011-4 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/>.

module tmseries

  use fitsio
  use iso_fortran_env

  implicit none

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

  integer, private :: nfile
  real(dbl), dimension(:), allocatable, private :: timelike,gexposure, &
       gxcoo,gycoo,gvxcoo,gvycoo
  real(dbl), dimension(:,:), allocatable, private :: dat
  character(len=FLEN_FILENAME),dimension(:), allocatable, private :: gfiles
  character(len=FLEN_KEYWORD),dimension(:), allocatable, private :: gfitskeys
  character(len=FLEN_VALUE),dimension(:), allocatable, private :: gfitsval
  character(len=80), private :: timetype, timestamp, gfilter, gphsystem, cootype
  character(len=FLEN_VALUE) :: extname
  character(len=FLEN_VALUE), dimension(:), allocatable, private :: coocols,cols
  real(dbl), private :: gtol,min0,per,jd0,timeerr,timeres
  logical, private :: gdiffmag,verbose,gstdout,allstars, &
       gfiltermatch, gphsystemmatch, gstarsmatch

contains

  subroutine tmseries_init(xtimetype,xtimestamp,xtimeerr,xtimeres,xcootype,nfiles, &
       fitskeys,xextname,xcoocols,xcols,tol,xmin0,xper,xepoch,diffmag,verb,stdout,alls)

    character(len=*), intent(in) :: xtimetype, xtimestamp, xextname, xcootype
    integer, intent(in) :: nfiles
    character(len=*), dimension(:), intent(in) :: fitskeys, xcoocols,xcols
    real(dbl), intent(in) :: tol,xmin0,xper,xepoch,xtimeerr,xtimeres
    logical, intent(in) :: diffmag,verb,stdout,alls

    timetype = xtimetype
    timestamp = xtimestamp
    timeerr = xtimeerr
    timeres = xtimeres
    cootype = xcootype
    if( allocated(gfitskeys) ) stop 'tmseries_init: gfitskeys already allocated.'
    allocate(gfitskeys(size(fitskeys)),gfitsval(size(fitskeys)))
    gfitskeys = fitskeys
    allocate(gfiles(nfiles),gexposure(nfiles),timelike(nfiles))

    allocate(coocols(size(xcoocols)),cols(size(xcols)))
    coocols = xcoocols
    cols = xcols


    nfile = 0
    gtol = tol
    min0 = xmin0
    per = xper
    gdiffmag = diffmag
    verbose = verb
    gstdout = stdout
    allstars = alls
    gfilter = ''
    gphsystem = ''
    gfiltermatch = .true.
    gphsystemmatch = .true.
    gstarsmatch = .true.
    jd0 = xepoch
    extname = xextname


  end subroutine tmseries_init

! ------

  subroutine tmseries_coo(xcoo,ycoo,vxcoo,vycoo)

    real(dbl), dimension(:), intent(in) :: xcoo,ycoo,vxcoo,vycoo
    integer :: n

    n = size(xcoo)
    if( allocated(gxcoo) ) stop 'tmseries_coo: gxcoo already allocated.'
    allocate(gxcoo(n),gycoo(n),gvxcoo(n),gvycoo(n))
    gxcoo = xcoo
    gycoo = ycoo
    gvxcoo = vxcoo
    gvycoo = vycoo

    if( allocated(dat) ) stop 'tmseries_coo: dat-es already allocated.'
    allocate(dat(size(timelike),n*size(cols)))

  end subroutine tmseries_coo

! ------

  subroutine tmseries_addcoo(t,tol,x,y)

    use astrotrafo
    use muniarrays

    type(AstroTrafoProj),intent(in) :: t
    real(dbl), intent(in) :: tol
    real(dbl), dimension(:), intent(in) :: x,y
    real(dbl), dimension(:), allocatable :: a,d,u,v
    integer, dimension(:), allocatable :: idx
    integer :: nidx,i,j,n,nsize
    real(dbl) :: r
    logical :: found

    if( .not. allocated(gxcoo) ) then

       n = size(x)
       allocate(gxcoo(n),gycoo(n),gvxcoo(n),gvycoo(n))
       gxcoo = 0.0
       gycoo = 0.0
       call invtrafo(t,x,y,gxcoo,gycoo)
       gvxcoo = 0.0_dbl
       gvycoo = 0.0_dbl

       if( allocated(dat) ) stop 'tmseries_coo: dat-es already allocated.'

       nsize = size(timelike)
       allocate(dat(nsize,n*size(cols)))

    else

       allocate(u(size(gxcoo)),v(size(gycoo)))
       allocate(a(size(x)),d(size(y)),idx(size(x)))

       if( cootype == 'DEG' ) then
          call proj(t,gxcoo,gycoo,u,v)
          call invtrafo(t,x,y,a,d)
       else if( cootype == 'RECT' ) then
          u = gxcoo
          v = gycoo
          a = x
          d = y
       end if

       nidx = 0

       do i = 1, size(x)

          found = .false.
          do j = 1,size(u)
             r = sqrt((u(j) - x(i))**2 + (v(j) - y(i))**2)
             if( r < tol ) found = .true.
          end do

          if( .not. found ) then
             nidx = nidx + 1
             idx(nidx) = i
          end if

       end do

       if( nidx > 0 ) then

          nsize = size(gxcoo)
          n = nsize + nidx
          call reallocate(gxcoo,n)
          call reallocate(gycoo,n)
          call reallocate(gvxcoo,n)
          call reallocate(gvycoo,n)
          call reallocate2d(dat,size(timelike),size(cols)*n)

          n = nsize+1
          dat(:,n:) = 0.0_dbl

          do i = 1, nidx
             n = nsize + i
             gxcoo(n) = a(idx(i))
             gycoo(n) = d(idx(i))
             gvxcoo(n) = 0.0_dbl
             gvycoo(n) = 0.0_dbl
          end do

       end if

       deallocate(a,d,u,v,idx)

    end if


  end subroutine tmseries_addcoo

! -----

  subroutine tmseries_add(filename)

    use fitsio
    use trajd
    use astrosphere
    use astrotrafo
    use photoconv
    use mtable

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

    character(len=FLEN_VALUE) :: filter,photsys
    integer :: i,j,ij,n, status, nidx
    integer, dimension(:,:), allocatable :: idxs
    real(dbl) :: year,month,day,hour,min,sec,amass,exptime,jd,r,rmin,dt,tol,etime,tm
    character(len=FLEN_KEYWORD), dimension(0) :: headkeys
    character(len=FLEN_VALUE), dimension(0) :: headval
    real(dbl),dimension(:,:), allocatable :: coo,data,cts
    real(dbl), dimension(:), allocatable :: a,d,u,v
    real, dimension(:), allocatable :: undef
    type(AstroTrafoProj) :: t

    if( nfile == size(timelike) ) goto 666

    if( verbose ) write(error_unit,*) trim(filename),":"

    call table(filename, extname, gfitskeys, headkeys, coocols, cols, &
         verbose,cootype,gfitsval,headval,photsys,filter,year,month,day,&
         hour,min,sec,amass,exptime,t,coo,data,status)

    if( status /= 0 ) then
       write(error_unit,*) "Failed to read `",trim(filename),"'."
       goto 666
    end if
    if( size(coo) == 0 ) goto 666

    allocate(undef(size(cols)))
    call undefs(cols,undef)

    if( filter /= gfilter .and. gfilter /= '' ) then
       gfiltermatch = .false.
       if( verbose ) write(error_unit,*) "Filters `", &
            trim(filter),"' and `",trim(gfilter),"' doesn't match."
    end if

    if( photsys /= gphsystem .and. gphsystem /= '' ) then
       gphsystemmatch = .false.
       if( verbose ) &
            write(error_unit,*) "Photometric systems `",trim(photsys),"' and `", &
            trim(gphsystem),"' doesn't match."
    end if

    if( cootype == 'DEG' ) then
       if( gtol > 0.0 ) then
          tol = gtol
       else
          ! one looks strange, but 1pix is prefered over dtol=0.0
          tol = 5.0*max(t%err,1.0/t%scale)
       end if
!       tol = t%scale*tol
!           write(*,*) tol,t%err,1.0/t%scale,t%scale
    else if( cootype == 'RECT' ) then
       if( gtol > 0.0 ) then
          tol = gtol
       else
          tol = 1.0
       end if
    end if

    if( allstars ) call tmseries_addcoo(t,tol,coo(:,1),coo(:,2))

    nfile = nfile + 1
    gfiles(nfile) = filename
    gexposure(nfile) = exptime
    gfilter = filter
    gphsystem = photsys


    ! Evaluate Julian date at time-stamp of exposure
    jd = datjd(year,month,day + (hour + (min + sec/60.0_dbl)/60.0_dbl)/24.0_dbl)

    etime = exptime/86400.0_dbl
    if( timestamp == 'MID' ) then
       jd = jd + etime/2.0_dbl
    else if ( timestamp == 'END' ) then
       jd = jd + etime
    end if

    ! time (-like) determination

    if( timetype == 'JD' ) then
       tm = jd
    else if( timetype == 'MJD' ) then
       tm = mjd(jd)
    else if( timetype == 'HJD' ) then
       tm = hjd(jd,helcor(longsun(jd,year),t%acen,t%dcen))
    else if( timetype == 'PHASE' ) then
       tm = phase(jd,min0,per)
    else if( timetype == 'AIRMASS' ) then
       tm = amass
    else
       tm = 0.0
    end if

    timelike(nfile) = tm


    ! look for coordinates
    n = size(gxcoo)
    allocate(a(n),d(n),u(n),v(n))

    ! WARNING! the current epoch coords are computed here only,
    !          may be also computed in tmserie_addcoo ??
    dt = (jd - jd0)!/365.25_dbl

    if( cootype == 'DEG' ) then

       do j = 1, n
          d(j) = gycoo(j) + gvycoo(j)*dt
          a(j) = gxcoo(j) + gvxcoo(j)*dt ! * cos(d(j)/rad) !!!! ?????
          ! write(*,*) a(j),d(j),dt,gvycoo(j)
       end do
       call trafo(t,a,d,u,v)

    else if( cootype == 'RECT' ) then

       u = gxcoo + gvxcoo*dt
       v = gycoo + gvycoo*dt

    end if

    nidx = 0
    allocate(idxs(size(gxcoo),2),cts(size(data,1),size(data,2)))
    cts = 0.0_dbl
    do j = 1, n

       rmin = tol
       ij = 0

       if( coocols(1) == FITS_COL_X .and. coocols(2) == FITS_COL_Y ) then

          do i = 1, size(coo,1)
             ! locate stars on base of euclidean metric
             r = sqrt((coo(i,1) - u(j))**2 + (coo(i,2) - v(j))**2)
             if( r < rmin) then
                rmin = r
                ij = i
             end if
          end do

       else

          do i = 1, size(coo,1)
             ! locate stars in spherical coordinates
             r = sqrt(((coo(i,1) - a(j))*cos(d(j)/rad))**2 + (coo(i,2) - d(j))**2)
             if( r < rmin) then
                rmin = r
                ij = i
             end if
          end do


       end if

       if( ij > 0 .and. nidx < size(cts,1) ) then
          nidx = nidx + 1
          idxs(nidx,:) = (/ij,j/)
          cts(nidx,:) = data(ij,:)
       else
          nidx = nidx + 1
          idxs(nidx,:) = (/0,j/)
          cts(nidx,:) = undef
          if( .not. allstars ) then
             gstarsmatch = .false.
             if( verbose ) &
                  write(error_unit,'(a,2(f0.5,1x),"(",2(f0.1,1x),"[pix])",a,g0.2)') &
                  'Object at ',a(j),d(j),u(j),v(j),' not found. tol=',rmin
          end if
       end if
    end do

    deallocate(a,d,u,v)

    call tmappend(nfile,nidx,idxs,cts(1:nidx,:))
    if( gstdout ) call xwrite(tm,headval,cols,cts(1:nidx,:))

666 continue

    if( allocated(coo) ) deallocate(coo)
    if( allocated(data) ) deallocate(data)
    if( allocated(idxs) ) deallocate(idxs,cts)
    if( allocated(undef) ) deallocate(undef)

  end subroutine tmseries_add

! ----------------

  subroutine tmappend(nfile,nidx,idxs,cts)

    ! transposes: stacks columns to rows, one by one

    integer, intent(in) :: nfile, nidx
    integer, dimension(:,:), intent(in) :: idxs
    real(dbl), dimension(:,:), intent(in) :: cts
    integer :: i,j,n

    n = size(cts,2)
    dat(nfile,:) = 0.0_dbl
    do i = 1, nidx
       j = n*(idxs(i,2) - 1) + 1
       dat(nfile,j:j+n-1) = cts(i,:)
    end do

  end subroutine tmappend

! ----------------

  subroutine xwrite(tm,vals,cols,cts)

    real(dbl), intent(in) :: tm
    character(len=*), dimension(:), intent(in) :: vals,cols
    real(dbl), dimension(:,:), intent(in) :: cts

    character(len=666) :: fmt = ""
    integer :: i,n,m

    n = size(cts,1)
    m = size(cols)

    write(*,'(f0.10)',advance="no") tm
    if( size(vals) > 0 ) then
       write(fmt,'(a,i0,a)') '(',size(vals),'(a),1x'
       write(*,fmt,advance="no") (trim(vals(i)),i=1,size(vals))
    end if
    if( n > 0 ) then
       write(fmt,'(a,i0,a)') '(1x,',n,'('
       do i = 1,m
          if( index(cols(i),'MAG') > 0 ) then
             fmt = trim(fmt) // 'f0.5'
          else
             fmt = trim(fmt) // 'g0'
          end if
          if( i < n ) then
             fmt = trim(fmt) // ',1x,'
          else
             fmt = trim(fmt) // ',1x'
          end if
       end do
       fmt = trim(fmt) // '))'
       write(*,fmt,advance="no") (cts(i,:),i=1,n)
    end if
    write(*,*)

  end subroutine xwrite

! ----------------

  subroutine different(mag,dmag,dag,ddag)

    real(dbl), parameter :: magnan = 99.99999_dbl
    real(dbl), parameter :: dmagnan = 9.99999_dbl
    real(dbl), dimension(:), intent(in) :: mag,dmag
    real(dbl), dimension(:), intent(out) :: dag,ddag
    integer :: i,j

    dag = magnan
    ddag = dmagnan

    do i = 1, size(mag)-1
       j = i + 1
       if( mag(j) < magnan .and. mag(1) < magnan ) then
          dag(i) = mag(j) - mag(1)
          ddag(i) = sqrt(dmag(j)**2 + dmag(1)**2)
       else
          dag(i) = magnan
          ddag(i) = dmagnan
       end if
    end do

  end subroutine different

! ----------------


  subroutine tmseries_finish(output,backup)

    character(len=*), intent(in) :: output,backup
    character(len=80), dimension(:), allocatable :: xcols, fmtcols
    character(len=80) :: units
    integer :: i, j, n, ncols

    if( output /= '' .and. nfile > 0 ) then

       n = size(gxcoo)
       ncols = size(cols)
       allocate(xcols(n*ncols),fmtcols(ncols))

       do i = 1,ncols
          fmtcols(i) = '("'//trim(cols(i))//'_",i0)'
          units = ''
       end do

       do i = 1,n
          do j = 1,ncols
             write(xcols(ncols*(i-1)+j),fmtcols(j)) i
          end do
       end do
       deallocate(fmtcols)

       call savelc(output,backup,xcols,units,gfitskeys,gfitsval,jd0,&
            gexposure,timelike,gfilter,gphsystem,gxcoo,gycoo,dat)

       deallocate(xcols)
    end if

    if( allocated(timelike) ) deallocate(gfiles,gexposure,timelike)
    if( allocated(dat) ) deallocate(dat)
    if( allocated(gxcoo) ) deallocate(gxcoo,gycoo,gvxcoo,gvycoo)
    if( allocated(gfitskeys) ) deallocate(gfitskeys,gfitsval)
    if( allocated(cols) ) deallocate(cols)
    if( allocated(coocols) ) deallocate(coocols)

    if( .not. gfiltermatch ) write(error_unit,*) "Warning: Filters doesn't match!"
    if( .not. gphsystemmatch ) write(error_unit,*) &
         "Warning: Photometric systems doesn't match!"
!    if( .not. gstarsmatch .and. verbose ) &
    if( .not. gstarsmatch ) write(error_unit,*) &
         "Warning: One or more stars not found. Try --verbose for details."

  end subroutine tmseries_finish


  subroutine savelc(file,backup,xcols,units,fitskeys,fitsval,epoch,&
       exposure,timelike,filter,phsystem,xcoo,ycoo,dat)

    use fitsio

    integer, parameter :: ntime = 2
    integer, parameter :: frow = 1, felem = 1

    character(len=*), intent(in) :: file,backup,filter,phsystem,units
    character(len=*), dimension(:), intent(in) :: fitskeys,fitsval,xcols
    real(dbl), dimension(:), intent(in) :: exposure,timelike,xcoo,ycoo
    real(dbl), dimension(:,:), intent(in) :: dat
    real(dbl), intent(in) :: epoch

    character(len=FLEN_VALUE), dimension(:), allocatable :: ttype, tform, tunit
    integer :: i,n,nrows,ntypes
    integer :: status, blocksize

    ntypes = ntime + size(xcols)
    allocate(ttype(ntypes),tform(ntypes),tunit(ntypes))
    tform = '1D'

    ttype(1) = FITS_COL_TIME;   tunit(1) = 'day'   ! jd
    ttype(2) = fitskeys(3);     tunit(2) = 's'     ! exptime
    ttype(ntime+1:) = xcols(:)
    tunit(ntime+1:) = units

    status = 0
    blocksize = 0
    nrows = nfile
    call fitsbackup(file,backup,status)
    call ftinit(15,file,blocksize,status)
    call ftiimg(15,8,0,(/0/),status)
    call ftpkys(15,'HDUNAME',MEXTNAMETS,'time series table',status)
    call ftpkys(15,FITS_KEY_CREATOR,FITS_VALUE_CREATOR,FITS_COM_CREATOR,status)
    call ftpcom(15,MUNIPACK_VERSION,status)
    call ftpcom(15,'Description: http://munipack.physics.muni.cz/dataform_tmserie.html',status)

    ! LC extension
    call ftibin(15,nrows,ntypes,ttype,tform,tunit,MEXTNAMETS,0,status)
    call ftpkys(15,fitskeys(6),fitsval(6),'observed object',status)
    call ftpkys(15,fitskeys(7),fitsval(7),'observer who acquired the data',status)
    call ftpkys(15,fitskeys(8),fitsval(8),'author of the data',status)
    call ftpkys(15,fitskeys(9),fitsval(9),'name of instrument',status)
    call ftpkys(15,fitskeys(10),fitsval(10),'name of telescope',status)
    call ftpkys(15,fitskeys(11),fitsval(11),'organization responsible for the data',status)
    call ftpkys(15,fitskeys(12),fitsval(12),'bibliographic reference',status)
    call ftpcom(15,'Aperture photometry has been used.',status)

    ! time info: http://dotastro.org/simpletimeseries/
    call ftpkys(15,'TIMETYPE',timetype,'JD,MJD,HJD,phase,airmass',status)
    call ftpkys(15,'TIMESYS','UTC','',status)
    call ftpkys(15,'TIMEREF','GEOCENTER','',status)
    call ftpkys(15,'TIMESTMP','MIDPOINT','time stamp = MIDPOINT,BEGIN,END',status)
    if( timeerr > 0.0_dbl ) &
         call ftpkyd(15,'TIMEERR',timeerr,2,'[s] uncertainty in the time measurement',status)
    if( timeres > 0.0_dbl ) &
         call ftpkyd(15,'TIMERES',timeres,2,'[s] resolution in the time measurement',status)
    call ftpkys(15,fitskeys(4),filter,'spectral band',status)
    call ftpkys(15,fitskeys(15),phsystem,'Photometric system',status)

    call ftpcom(15,'File names for each frame (ordered):',status)
    do i = 1, nfile
       call ftpcom(15,gfiles(i),status)
    end do

    call ftpcld(15,1,frow,felem,nrows,timelike,status)
    call ftpcld(15,2,frow,felem,nrows,exposure,status)

    do n = 1,size(xcols)
       call ftpcld(15,ntime+n,frow,felem,nrows,dat(:,n),status)
    end do
    deallocate(ttype,tform,tunit)

    ! OBJECT extension
    nrows = size(xcoo)
    ntypes = 2
    allocate(ttype(ntypes),tform(ntypes),tunit(ntypes))
    tform = '1D'
    tunit = 'deg'
    ttype(1) = FITS_COL_RA
    ttype(2) = FITS_COL_DEC

    call ftibin(15,nrows,ntypes,ttype,tform,tunit,MEXTNAMETSC,0,status)
    call ftpkys(15,"REFRAME",'ICRS','reference celestial coordinate system',status)
    call ftpkyd(15,"EPOCH",epoch,15,'reference epoch for proper motion',status)
    call ftpcld(15,1,frow,felem,nrows,xcoo,status)
    call ftpcld(15,2,frow,felem,nrows,ycoo,status)

    deallocate(ttype,tform,tunit)

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


  end subroutine savelc


  subroutine undefs(cols,data)

    character(len=*), dimension(:), intent(in) :: cols
    real, dimension(:), intent(out) :: data
    integer :: i

    do i = 1,size(cols)
       if( index(cols(i),'MAGERR') > 0 ) then
          data(i) = 9.99999
       else if( index(cols(i),'MAG') > 0 ) then
          data(i) = 99.99999
       else
          data(i) = -1
       end if
    end do


  end subroutine undefs

  subroutine reallocate2d(x,n,m)

    implicit none
    real(dbl), dimension(:,:),allocatable,intent(inout) :: x
    integer, intent(in) :: n,m
    real(dbl), dimension(:,:),allocatable :: y

    allocate(y(n,m))

    if( n < size(x,1) .and. m < size(x,2) )then
       y = x(1:n,1:m)
    else if( n >= size(x,1) .and. m >= size(x,2) )then
       y(1:size(x,1),1:size(x,2)) = x
    else
       y = x
    end if

    deallocate(x)
    allocate(x(n,m))
    x(1:size(y,1),1:size(y,2)) = y
    deallocate(y)

  end subroutine reallocate2d

end module tmseries
