!
!  Light Curve Approximations by Fourier series
!
!  gfortran -I../lib -Wall -g -p -fcheck=all -fimplicit-none -fbacktrace \
!            lcapprox.f08 -L../lib -lminpacks -lminpack
!
!  Copyright © 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/>.
!


program lcapprox

  use iso_fortran_env

  implicit none
  integer, parameter :: db = selected_real_kind(15)
  real(db), parameter :: pi = 3.14159265358979323844_db

  real(db), dimension(:), allocatable :: x,y
  character(len=10) :: modname, tail

  write(*,*)
  write(*,*) '!  Copyright © 2017 F.Hroch (hroch@physics.muni.cz)'
  write(*,*) '!'
  write(*,*) '!  This file is part of Munipack.'
  write(*,*) '!  All source code is generated by lcapprox.f08.'
  write(*,*) '!'
  write(*,*) '!  Munipack is free software: you can redistribute it and/or modify'
  write(*,*) '!  it under the terms of the GNU General Public License as published by'
  write(*,*) '!  the Free Software Foundation, either version 3 of the License, or'
  write(*,*) '!  (at your option) any later version.'
  write(*,*) '!'
  write(*,*) '!  Munipack is distributed in the hope that it will be useful,'
  write(*,*) '!  but WITHOUT ANY WARRANTY; without even the implied warranty of'
  write(*,*) '!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the'
  write(*,*) '!  GNU General Public License for more details.'
  write(*,*) '!'
  write(*,*) '!  You should have received a copy of the GNU General Public License'
  write(*,*) '!  along with Munipack.  If not, see <http://www.gnu.org/licenses/>.'
  write(*,*)

  modname = 'lcparams'
  write(*,'(a)') 'module '//modname
  write(*,*)
  write(*,'(a)') '   implicit none'
  write(*,'(a)') '   integer, parameter, private :: db = selected_real_kind(15)'
  write(*,*)

  ! delta Cep (simulated) by http://adsabs.harvard.edu/abs/2015A%26A...584A..80M
  call delta_cep

  write(*,*)

  ! Algol by http://adsabs.harvard.edu/abs/1989ApJ...342.1061K
  call algol

  write(*,*)
  write(*,'(a)') 'end module '//modname

  ! testing framework
  call testfour


contains

  subroutine delta_cep

    ! Dataset is simulated (without noise). Coeficients of polynomial
    ! are esimated by direct projection.

    complex(db), dimension(0:7) :: dcep
    real(db) :: s
    real :: tmp(4)
    integer :: i

    open(1,file='delta_Cep.dat',status='old')
    allocate(x(999),y(999))   ! dim by `wc delta_Cep.dat'
    do i = 1,size(x)
       read(1,*) x(i),tmp,y(i)
    end do
    close(1)

    ! normalise
    y = y / maxval(y)

    ! Fourier approximation of delta Cep
    write(*,'(a,i0,a)') '   complex(db), dimension(0:',size(dcep)-1, &
         '), parameter :: dcep = (/ &'
    do i = 0,size(dcep)-1
       dcep(i) =  fourproj(i,x,y)
       if( i /= size(dcep)-1 ) then
          tail = ', &'
       else
          tail = ' /)'
       end if
       write(*,'(2(a,es22.15),2a)') '     cmplx(',real(dcep(i)),',',&
            aimag(dcep(i)),')',tail
    end do

    open(9,file='/tmp/dcep')
    dcep(0) = dcep(0) / 2
    do i = 1,size(x)
       s = fourfun(dcep,x(i))
       write(9,*) x(i),y(i),s,y(i)-s
    end do
    close(9)

    deallocate(x,y)

  end subroutine delta_cep


  subroutine algol

    ! The real (measured) data are approximated by least squares.
    ! Some (one) original data-point (commented out with #) has been removed.
    ! The values has been transcribed by me by hand and can contain
    ! mistakes (but much less than any OCR reader which I checked).

    complex(db), dimension(0:13) :: c
    real(db) :: jd0, per, s
    integer :: i

    allocate(x(516),y(516)) ! dim by `wc algol.dat'
    open(1,file='algol.dat',status='old')
    read(1,*)
    read(1,*)
    do i = 1, size(x)
       read(1,*) x(i),y(i)
    end do
    close(1)

    ! to JD without 2.4e6
    x = x + 45000
    ! elements by Kim's paper
    jd0 = 41773.4894
    per = 2.8673285
    x = mod(x - jd0,per) / per
    y = 10**(0.4*y)
    y =  y / maxval(y)

    ! sort by phase
    block
      real(db) :: xx, yy
      integer :: j,k

      do i = 1, size(x) - 1
         k = i
         xx = x(i)
         yy = y(i)
         do j = i + 1, size(x)
            if( x(j) <= xx ) then
               k = j
               xx = x(j)
               yy = y(j)
            endif
         end do
         x(k) = x(i)
         y(k) = y(i)
         x(i) = xx
         y(i) = yy
      end do
    end block

    block
      use minpacks
      real(db), dimension(:), allocatable :: cab
      integer :: info

      allocate(cab(2*size(c)))
      cab = 0
      call lmdif3(fourmin,cab,info=info)
!      write(*,*) cab,info
      c = [(cmplx(cab(1+i),cab(1+i+size(c)),kind=db),i=0,size(c)-1)]

    end block

    write(*,'(a,i0,a)') '   complex(db), dimension(0:',size(c)-1, &
         '), parameter :: algol = (/ &'
    do i = 0,size(c)-1
       if( i /= size(c)-1 ) then
          tail = ', &'
       else
          tail = ' /)'
       end if
       write(*,'(2(a,es22.15),2a)') '     cmplx(',real(c(i)),',', &
            aimag(c(i)),')',tail
    end do

    open(9,file='/tmp/algol')
    do i = 1,size(x)
       s = fourfun(c,x(i))
       write(9,*) x(i),y(i),s,y(i)-s
    end do
    close(9)

    deallocate(x,y)

  end subroutine algol


  function fourproj(n,x,y) result(s)

    real(db), dimension(:), intent(in) :: x,y
    real(db), dimension(size(y)) :: f,t
    integer, intent(in) :: n
    complex(db) :: s
    real(db) :: a,b

    t = n*2*pi*x
    f = y*cos(t)
    call lich(x,f,a)

    f = y*sin(t)
    call lich(x,f,b)

    s = 2*cmplx(a,b,kind=db)

  end function fourproj

  subroutine fourmin(m,n,p,fvec,iflag)

    integer, parameter :: dbl = selected_real_kind(15)
    integer, intent(in) :: n, m
    integer, intent(in out) :: iflag
    real(dbl), dimension(m), intent(in) :: p
    real(dbl), dimension(n), intent(out) :: fvec

    complex(dbl), dimension(0:m/2-1) :: c
    real(dbl), dimension(:), allocatable :: res
    complex(dbl), dimension(:,:), allocatable :: cvec
    complex(dbl), dimension(:), allocatable :: w
    integer :: i,m2

    m2 = m / 2
    c = [(cmplx(p(i),p(i+m2),kind=db),i=1,m2)]

    allocate(cvec(size(x),0:m2-1),res(size(x)),w(size(x)))

    w = cmplx(cos(2*pi*x),-sin(2*pi*x),dbl)
    cvec(:,0) = cmplx(1.0_dbl,0.0_dbl,dbl)
    do i = 1, m2-1
       cvec(:,i) = cvec(:,i-1)*w
    end do
    do i = 1,size(x)
       res(i) = y(i) - real(sum(c*cvec(i,:)))
    end do
    do i = 0,m2-1
       fvec(1+i) = -2*sum(res*real(cvec(:,i)))
       fvec(1+i+m2) = -2*sum(res*aimag(cvec(:,i))) ! +- ?
!       write(*,*) i,real(fvec(1+i)),real(fvec(1+i+m2))
    end do
!    write(*,*) real(fvec)
!        stop

  end subroutine fourmin

  function fourfun(c,phi)

    complex(db), dimension(0:), intent(in) :: c
    real(db), intent(in) :: phi
    real(db) :: fourfun,t
    complex(db) :: s,u,w
    integer :: j

    t = 2*pi*phi
    w = cmplx(cos(t),-sin(t),db)
    u = cmplx(1.0_db,0.0_db,db)
    s = 0.0_db
    do j = 0,size(c)-1
       s = s + c(j)*u
       u = u * w
    end do
    fourfun = real(s)

  end function fourfun


  subroutine lich(x,y,s)

    ! trapezoidal rule on equidistant grid

    real(db), dimension(0:), intent(in) :: x,y
    real(db) :: s, h
    integer :: n

    n = size(y)-1
    h = (x(n) - x(0)) / n
    s = (y(0) + y(n)) / 2 + sum(y(1:n-1))
    s = h*s

  end subroutine lich

  subroutine testfour

    use minpacks

    real(db), dimension(:), allocatable :: cab
    complex(db), dimension(0:1) :: c
    integer :: i,info
    logical :: random = .true.

    allocate(cab(2*size(c)))

    if( random ) then
       allocate(x(8),y(8))

       x = [ 0.0, 0.0, 1.0471975512, 1.0471975512, 1.570796326775, &
            3.14159265355, 3.14159265355, 4.712388980325]
       y = [ 1.1, 0.8, 1.4, 1.6, 2.1, 2.8, 3.1, 2.1 ]
       cab = [ 2, -1,0,0]
       ! check: f(x) = 2 - cos(x)
    else
       allocate(x(5),y(5))

       x = [ 0.0, 1.25663706,2.513274122,3.76991118,5.0265482456]
       y = [ 3,1,-1,0,2]
       cab = [1.0,1.89443,0.0,-0.61554]
       ! check: f(x) = 1 + 1.89443*cos(x) - 0.61554*sin(x)
    end if

    x = x / 6.2831853071

    !cab = 0
    call lmdif3(fourmin,cab,info=info)
    write(error_unit,*) '!',cab,info

    c = [(cmplx(cab(1+i),cab(1+i+size(c)),kind=db),i=0,size(c)-1)]
    do i = 0,size(c)-1
       write(error_unit,*) '!',i,c(i)
    end do

    deallocate(x,y)

  end subroutine testfour

end program lcapprox
