!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! TELCAL fitting methods
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module fit_association
  use fit_definitions
  !----------------------------------------------------------------------
  ! This module is "private" to this file. It should *NOT* be used outside.
  !
  ! Association of one instanciation of each fit definitions.
  !
  ! This module association will enable parameter sharing of all input
  ! parameters (in particular the fixed parameters that the general
  ! fitting routine never transmit).
  !----------------------------------------------------------------------
  type(simple_1d), save :: adat
  type(fit_fun),   save :: afun
  type(fit_var),   save :: avar
end module fit_association
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
subroutine fit_1d(dat,fun,verbose)
  use telcal_interfaces, except_this=>fit_1d
  use fit_definitions
  use fit_association
  !----------------------------------------------------------------------
  ! @ public
  ! General unidimensional fitting routine
  !----------------------------------------------------------------------
  type(simple_1d), intent(in)  :: dat ! Data vectors
  type(fit_fun), intent(inout) :: fun ! Fitting function description
  logical, intent(in)      :: verbose ! Verbose or quiet?
  ! Local variables
  real(8), allocatable :: fvec(:)
  real(8), allocatable :: wa(:)
  integer, allocatable :: iw(:)
  real(8), allocatable :: wa1(:),wa2(:),wa3(:),wa4(:),r(:,:)
  type(simple_1d) :: sol
  !
  integer :: i,k,ier
  integer :: nprint,info,lwa,iopt,w
  real(8) :: tol,chi2,s,m
  logical :: minimize,find_errors,debug
  !
  ! Initialize flag
  fun%flag = 0
  !
  ! Check if fitting method is known
  if (fun%method.ne."SLATEC") then
     call gagout('E-FIT1D, Unknown fitting library: '//fun%method)
     fun%flag = -1
     return
  endif
  call xsetf(0)
  !
  ! Check if fitting function is known
  !
  ! iopt = 1 ! Minimization routine should guess the Jacobian
  if (fun%name.eq.'GAUSSIAN') then
     iopt = 2 ! Full Jacobian provided by this program
  else if (fun%name.eq.'GAUSSIAN+BASE') then
     iopt = 2 ! Full Jacobian provided by this program
  else if (fun%name.eq.'2*GAUSSIAN+BASE') then
     iopt = 2 ! Full Jacobian provided by this program
  else if (fun%name.eq.'LORENTZIAN') then
     iopt = 2 ! Full Jacobian provided by this program
  else if (fun%name.eq.'POLYNOMIAL') then
     call fit_polynomial(dat,fun)
     return
  else
     call gagout('E-FIT1D, Unknown fitting function: '//fun%name)
     fun%flag = -2
     return
  endif
  !
  ! Initialize
  debug       = .false.
  minimize    = .true.
  find_errors = .true.
  fun%ncall = 0
  do i=1,fun%npar
     fun%par(i)%value = fun%par(i)%guess
  enddo
  !
  ! Copy data from input parameters to association module to enable
  ! exchange of fixed parameters with computation routine "min_dnls".
  allocate(adat%x(dat%n),adat%y(dat%n),adat%w(dat%n),stat=ier)
  if (ier.eq.0) then
     call copy_simple_1d(dat,adat)
  else
     call gagout('E-FIT1D, Error in data array allocation')
     fun%flag = -3
     return
  endif
  !
  allocate (afun%par(fun%npar),stat=ier)
  if (ier.eq.0) then
     call copy_function(fun,afun)
  else
     call gagout('E-FIT1D, Error in function array allocation')
     fun%flag = -3
     return
  endif
  ! From now on, use only associated variables
  !
  ! Setup the variable parameters
  k = 0
  do i=1,afun%npar
     if (.not.afun%par(i)%fixed) then
        k = k+1
     endif
  enddo
  if (k.eq.0) then
     call gagout('W-FIT_1D, All parameter are fixed: Nothing to be done!...')
     fun%flag = -4
     return
  endif
  !
  avar%n = k
  allocate(avar%x(k),avar%d(k),avar%idx(k),stat=ier)
  k = 0
  do i=1,afun%npar
     if (.not.afun%par(i)%fixed) then
        k = k+1
        avar%x(k) = afun%par(i)%guess
        avar%d(k) = afun%par(i)%error
        avar%idx(k) = i
     endif
  enddo
  !
  allocate (fvec(adat%n),stat=ier)
  tol = min(0.7d0/adat%n,1d-4)
  !
  ! The fit happens here
  if (minimize) then
     !
     lwa = avar%n*(adat%n+5)+adat%n
     allocate (wa(lwa),stat=ier)
     allocate (iw(adat%n),stat=ier)
     !
     if (debug) then
        nprint = 50
     else
        nprint = 0
     endif
     info = 0
     call dnls1e(    &
          min_dnls,  & ! Function to be minimized
          iopt,      & ! 1=No, 2=Full Jacobian provided
          adat%n,    & ! Number of data points
          avar%n,    & ! Number of variable fitted parameters
          avar%x,    & ! Values of variable fitted parameters
          fvec,      & !
          tol,       & ! Tolerance
          nprint,    & ! Print control every NPRINT iterations (IFLAG = 0 in FCN)
          info,      & ! Information on result quality
          iw,        & ! integer work array of length NPAR
          wa,        & !
          lwa)         !
     !
     if (info.eq.0) then
        if (verbose) then
           print *,'E-DNLS1E, Improper input parameters, info= ',info
        endif
        fun%flag = -5
     elseif (info.eq.6 .or. info.eq.7) then
        if (verbose) then
           print *,'E-DNLS1E, TOL too small, info= ',info
        endif
        fun%flag = -5
     elseif (info.eq.5) then
        if (verbose) then
           print *,'E-DNLS1E, Not converging, info= ',info
        endif
        fun%flag = -5
     elseif (info.eq.4) then
        if (verbose) then
           print *,'W-DNLS1E, Singular Jacobian, info= ',info
        endif
        fun%flag = -5
     elseif (info.eq.1 .or. info.eq.2 .or.info.eq.3) then
        if (verbose) then
           print *,'I-DNLS1E, Algorithm reaches convergence, info= ',info
        endif
     else
        if (verbose) then
           print *,'E-DNLS1E, Unknown info code, info= ',info
        endif
        fun%flag = -5
     endif
     !
     deallocate (iw,wa)
  endif
  !
  ! After fitting stuffs, if fitting is a success
  if (fun%flag.eq.0) then
     !
     call patch_pointing(afun,avar)
     !
     ! Compute uncertainties
     if (find_errors) then
        allocate(r(adat%n,avar%n),stat=ier)
        allocate(wa1(avar%n),wa2(avar%n),wa3(avar%n),wa4(adat%n),stat=ier)
        !
        info = 0
        call dcov(        &
             min_dnls,    &
             iopt,        &
             adat%n,      &
             avar%n,      &
             avar%x,      &
             fvec,        &
             r,           &
             adat%n,      &
             info,        &            ! Result condition
             wa1,wa2,wa3, &
             wa4)
        !
        if (info.eq.0) then
           if (verbose) then
              print *,'F-DCOV, Improper input parameters, info= ',info
           endif
           fun%flag = -6
        elseif (info.eq.2) then
           if (verbose) then
              print *,'W-DCOV, Singular Jacobian, info= ',info
           endif
           fun%flag = -6
        else
           do i=1,avar%n
              avar%d(i) = sqrt(abs(r(i,i)))
           enddo
        endif
        deallocate (r,wa1,wa2,wa3,wa4)
     endif
     !
     do i=1,avar%n
        afun%par(avar%idx(i))%value = avar%x(i)
        afun%par(avar%idx(i))%error = avar%d(i)
     enddo
     !
     ! Compute final chi2
     chi2 = 0.
     do i=1,adat%n
        chi2 = chi2 + fvec(i)**2
     enddo
     afun%chi2 = chi2
     !
     ! Compute final RMS
     ! 1 - Compute the solution profile
     sol%n = adat%n
     allocate(sol%x(sol%n),sol%y(sol%n),stat=ier)
     ! if (failed_allocate(rname,"solution",ier,error)) goto 100
     sol%x(:) = adat%x(:)
     call get_profile(afun,sol)
     ! 2 - Compute the difference
     ! call get_difference(adat,afun,fvec)  ! Note: values are weighted in return
     do i=1,adat%n
       fvec(i) = sol%y(i)-adat%y(i)  ! Unweighted difference
     enddo
     deallocate(sol%x,sol%y)
     ! 3 - Compute mean
     s = 0.
     w = 0
     do i=1,adat%n
       if (adat%w(i).gt.0.) then
         s = s+fvec(i)  ! Unweighted mean
         w = w+1
       endif
     enddo
     m = s/w
     ! 4 - Compute RMS
     s = 0.
     w = 0
     do i=1,adat%n
       if (adat%w(i).gt.0.) then
         s = s+(fvec(i)-m)**2  ! Unweighted RMS
         w = w+1
       endif
     enddo
     afun%rms = sqrt(s/w)  ! Actually the standard deviation
     !
     ! Print results
     if (verbose) then
        print *,'------'
        print *,'FINAL RESULT after ',afun%ncall,' calls'
        print *,' '
        do i=1,afun%npar
           if (afun%par(i)%fixed) then
              write(6,'(a20,f12.4,7x,a)') afun%par(i)%name, afun%par(i)%value, "Fixed"
           else
              write(6,'(a20,2f12.4)') afun%par(i)%name, afun%par(i)%value, afun%par(i)%error
           endif
        enddo
     endif
     !
     ! Return results: ie get back to input parameters from association module
     call copy_function(afun,fun)
     !
  endif
  !
  deallocate(afun%par)
  deallocate(adat%x,adat%y,adat%w)
  deallocate(avar%x,avar%d,avar%idx)
  !
end subroutine fit_1d
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
subroutine min_dnls(iflag,mdat,npar,x,fvec,fjac,ldfjac)
  use telcal_interfaces, except_this=>min_dnls
  use fit_association ! Transmission of hidden (eg fixed) parameters
  !----------------------------------------------------------------------
  ! @ private-mandatory (because symbol is used elsewhere)
  !
  !----------------------------------------------------------------------
  integer, intent(in)  :: iflag          ! Input flag
  integer, intent(in)  :: mdat           ! Number of data points
  integer, intent(in)  :: npar           ! Number of variable (ie non-fixed) fitted parameters
  integer, intent(in)  :: ldfjac         ! First dimension of fjac
  real(8), intent(in)  :: x(npar)        ! Variable fitted parameters
  real(8), intent(out) :: fvec(mdat)     ! Difference between the function value and the data points
  real(8), intent(out) :: fjac(ldfjac,*) ! Jacobian (ie partial derivatives of f)
  !
  ! Local variables
  real(8) chi2
  integer i
  !
  ! From x to association module
  do i=1,avar%n
     afun%par(avar%idx(i))%value = x(i)
  enddo
  !
  if (iflag.eq.0) then         ! Print current values
     chi2 = 0.
     do i=1,mdat
        chi2 = chi2 + fvec(i)*fvec(i)
     enddo
     print *,'Val  ',x
     print '(1x,A,F12.2)','Chi2 ',chi2
  elseif  (iflag.eq.1) then    ! Compute the difference vector (fvec)
     call get_difference(adat,afun,fvec)
  elseif  (iflag.eq.2) then    ! Compute the Jacobian
     call get_jacobian(adat,afun,avar,fvec,fjac) ! ,ldfjac)
  else
     print *,'Do not know IFLAG ',iflag
  endif
end subroutine min_dnls
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
subroutine patch_pointing(fun,var)
  use fit_definitions
  !---------------------------------------------------------------------
  ! @ private
  ! Post-minimization patches
  !---------------------------------------------------------------------
  type(fit_fun), intent(in)    :: fun
  type(fit_var), intent(inout) :: var
  !
  integer(kind=4) :: ivar,iwidth,iarea
  !
  if (fun%name.eq.'GAUSSIAN' .or.  &
      fun%name.eq.'GAUSSIAN+BASE') then
    ! Patch for WIDTH and AREA signs:
    ! - the width of the minimized gaussian is insensitive to WIDTH
    !   sign => the WIDTH is forced positive.
    ! - the amplitude of the minimized gaussian is only sensitive to
    !   the WIDTH/AREA ratio sign (same sign: positive gaussian,
    !   opposite sign: negative gaussian) => if WIDTH sign is swapped
    !   AREA sign is swapped accordingly.
    iwidth = 0
    iarea  = 0
    do ivar=1,var%n
      if (fun%par(var%idx(ivar))%name.eq.'WIDTH')  iwidth=ivar
      if (fun%par(var%idx(ivar))%name.eq.'AREA')   iarea =ivar
    enddo
    if (iwidth.gt.0 .and. iarea.gt.0) then
      ! Both were free (fitted) parameters
      if (var%x(iwidth).lt.0.d0) then
        var%x(iwidth) = -var%x(iwidth)
        var%x(iarea) = -var%x(iarea)
      endif
    endif
  endif
end subroutine patch_pointing
!
subroutine get_difference(dat,fun,fvec)
  use telcal_interfaces, except_this=>get_difference
  use fit_definitions  ! Transmission of hidden (eg fixed) parameters
  !----------------------------------------------------------------------
  ! @ private
  !
  !----------------------------------------------------------------------
  type(simple_1d),  intent(in) :: dat ! Data vectors
  type(fit_fun), intent(inout) :: fun ! Fitting function description
  real(8), intent(out) :: fvec(dat%n) ! Difference between the function value and the data points
  !
  ! Local variables
  real(8) :: x01,y01,dx1
  real(8) :: x02,y02,dx2
  real(8) :: pi,xx
  integer i,j
  !
  fun%ncall = fun%ncall+1
  if (fun%name.eq.'GAUSSIAN') then
     pi = acos(-1.d0)
     x01 = fun%par(2)%value
     dx1 = 2.d0*sqrt(log(2.d0)) / fun%par(3)%value
     y01 = fun%par(1)%value / fun%par(3)%value * 2.d0*sqrt(log(2.d0)) / sqrt(pi)
     do i=1,dat%n
        xx = abs((dat%x(i)-x01)*dx1)
        if (xx.lt.5) then
           fvec(i) = dat%y(i) - y01 * exp(-(xx*xx))
        else
           fvec(i) = dat%y(i)
        endif
        fvec(i) = fvec(i) * dat%w(i)
     enddo
  else if (fun%name.eq.'GAUSSIAN+BASE') then
     pi = acos(-1.d0)
     x01 = fun%par(2)%value
     dx1 = 2.d0*sqrt(log(2.d0)) / fun%par(3)%value
     y01 = fun%par(1)%value / fun%par(3)%value * 2.d0*sqrt(log(2.d0)) / sqrt(pi)
     do i=1,dat%n
        xx = abs((dat%x(i)-x01)*dx1)
        if (xx.lt.5) then
           fvec(i) = dat%y(i) - y01 * exp(-(xx*xx))
        else
           fvec(i) = dat%y(i)
        endif
        fvec(i) = fvec(i) - (fun%par(4)%value + fun%par(5)%value*dat%x(i))
        fvec(i) = fvec(i) * dat%w(i)
     enddo
  else if (fun%name.eq.'2*GAUSSIAN+BASE') then
     pi = acos(-1.d0)
     x01 = fun%par(2)%value
     dx1 = 2.d0*sqrt(log(2.d0)) / fun%par(3)%value
     y01 = fun%par(1)%value / fun%par(3)%value * 2.d0*sqrt(log(2.d0)) / sqrt(pi)
     x02 = fun%par(2)%value+fun%par(5)%value
     dx2 = 2.d0*sqrt(log(2.d0)) / (fun%par(3)%value*fun%par(6)%value)
     y02 = (fun%par(1)%value*fun%par(4)%value) / (fun%par(3)%value*fun%par(6)%value) * 2.d0*sqrt(log(2.d0)) / sqrt(pi)
     do i=1,dat%n
        xx = (dat%x(i)-x01)*dx1
        if (xx.lt.5) then
           fvec(i) = dat%y(i) - y01 * exp(-xx*xx)
        else
           fvec(i) = dat%y(i)
        endif
        xx = (dat%x(i)-x02)*dx2
        if (xx.lt.5) then
           fvec(i) = fvec(i) - y02 * exp(-xx*xx)
        endif
        fvec(i) = fvec(i) - (fun%par(7)%value + fun%par(8)%value*dat%x(i))
        fvec(i) = fvec(i) * dat%w(i)
     enddo
  else if (fun%name.eq.'LORENTZIAN') then
    x01 = fun%par(2)%value
    dx1 = 1.d0 / fun%par(3)%value
    y01 = fun%par(1)%value
    do i=1,dat%n
       xx = (dat%x(i)-x01)*dx1
       fvec(i) = dat%y(i) - y01 / (1d0 + xx*xx)
       fvec(i) = fvec(i) * dat%w(i)
    enddo
  else if (fun%name.eq.'POLYNOMIAL') then
     do i=1,dat%n
        fvec(i) = fun%par(fun%npar)%value
        do j=fun%npar-1,1
           fvec(i) = fvec(i) * dat%x(i) + fun%par(j)%value
        enddo
        fvec(i) = (dat%y(i) - fvec(i)) * dat%w(i)
     enddo
  endif
end subroutine get_difference
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
subroutine get_jacobian(dat,fun,var,fvec,fjac)
  use telcal_interfaces, except_this=>get_jacobian
  use fit_definitions ! Transmission of hidden (eg fixed) parameters
  !----------------------------------------------------------------------
  ! @ private
  ! fvec must *NOT* be altered here (See dnsl1e documentation).
  !
  ! The difficulty here is that some parameters can be fixed, other
  ! variable. We calculate all derivatives in this version, and place
  ! them according to the indexing of the variable parameters ...
  !----------------------------------------------------------------------
  type(simple_1d),  intent(in) :: dat   ! Data vectors
  type(fit_var),    intent(in) :: var   !
  type(fit_fun), intent(inout) :: fun   ! Fitting function description
  real(8), intent(in)  :: fvec(dat%n)   ! Difference between the function value and the data points
  real(8), intent(out) :: fjac(dat%n,*) ! Jacobian (ie partial derivatives of f)
  !
  ! Local variables
  real(4) :: x01,y01,dx1,dy1
  real(4) :: x02,y02,dx2,dy2
  real(4) :: xx,y
  real(4) :: dy(8)
  integer :: i,j
  real(8) :: pi
  !
  fun%ncall = fun%ncall+1
  if (fun%name.eq.'GAUSSIAN') then
     pi = acos(-1.d0)
     x01 = fun%par(2)%value
     dx1 = 2.d0*sqrt(log(2.d0)) / fun%par(3)%value
     dy1 = dx1 / sqrt(pi)
     y01 = fun%par(1)%value
     do i=1,dat%n
        xx = (dat%x(i)-x01)*dx1
        if (abs(xx).lt.5) then
           y = dy1 * exp(-xx*xx)
           dy(1) = y
           dy(2) = y01 * y * dx1 * 2.d0 * xx
           dy(3) = y01 * y / fun%par(3)%value * (2d0*xx*xx - 1.d0)
           do j=1,var%n
              fjac(i,j) = - dy(var%idx(j)) * dat%w(i)
           enddo
        else
           do j=1,var%n
              fjac(i,j) = 0.0
           enddo
        endif
     enddo
  else if (fun%name.eq.'GAUSSIAN+BASE') then
     pi = acos(-1.d0)
     x01 = fun%par(2)%value
     dx1 = 2.d0*sqrt(log(2.d0)) / fun%par(3)%value
     dy1 = dx1 / sqrt(pi)
     y01 = fun%par(1)%value
     do i=1,dat%n
        xx = (dat%x(i)-x01)*dx1
        if (abs(xx).lt.5) then
           y = dy1 * exp(-xx*xx)
           dy(1) = y
           dy(2) = y01 * y * dx1 * 2.d0 * xx
           dy(3) = y01 * y / fun%par(3)%value * (2d0*xx*xx - 1.d0)
        else
           dy(1) = 0.0
           dy(2) = 0.0
           dy(3) = 0.0
        endif
        dy(4) = 1.0
        dy(5) = dat%x(i)
        do j=1,var%n
           fjac(i,j) = - dy(var%idx(j)) * dat%w(i)
        enddo
     enddo
  else if (fun%name.eq.'2*GAUSSIAN+BASE') then
     pi = acos(-1.d0)
     x01 = fun%par(2)%value
     y01 = fun%par(1)%value
     dx1 = 2.d0*sqrt(log(2.d0)) / fun%par(3)%value
     dy1 = dx1 / sqrt(pi)
     x02 = fun%par(2)%value+fun%par(5)%value
     y02 = fun%par(1)%value*fun%par(4)%value
     dx2 = 2.d0*sqrt(log(2.d0)) / (fun%par(3)%value*fun%par(6)%value)
     dy2 = dx2 / sqrt(pi)
     do i=1,dat%n
        xx = (dat%x(i)-x01)*dx1
        if (abs(xx).lt.5) then
           y = dy1 * exp(-xx*xx)
           dy(1) = y
           dy(2) = y01 * y * dx1 * 2.d0 * xx
           dy(3) = y01 * y / fun%par(3)%value * (2d0*xx*xx - 1.d0)
        else
           dy(1) = 0.0
           dy(2) = 0.0
           dy(3) = 0.0
        endif
        xx = (dat%x(i)-x02)*dx2
        if (abs(xx).lt.5) then
           y = dy2 * exp(-xx*xx)
           dy(4) = y
           dy(5) = y02 * y * dx2 * 2.d0 * xx
           dy(6) = y02 * y / (fun%par(3)%value*fun%par(6)%value) * (2d0*xx*xx - 1.d0)
           dy(1) = dy(1) + dy(4) * fun%par(4)%value
           dy(2) = dy(2) + dy(5)
           dy(3) = dy(3) + dy(6) * fun%par(6)%value
           dy(4) = dy(4) * fun%par(1)%value
           dy(6) = dy(6) * fun%par(3)%value
        else
           dy(4) = 0
           dy(5) = 0
           dy(6) = 0
        endif
        dy(7) = 1.0
        dy(8) = dat%x(i)
        do j=1,var%n
           fjac(i,j) = - dy(var%idx(j)) * dat%w(i)
        enddo
     enddo
  else if (fun%name.eq.'LORENTZIAN') then
    x01 = fun%par(2)%value
    dx1 = 1.d0 / fun%par(3)%value
    y01 = fun%par(1)%value
    do i=1,dat%n
       xx = (dat%x(i)-x01)*dx1
       y = 1.d0 / (1 + xx*xx)
       dy(1) = y
       y = y*y * y01
       dy(2) = 2.d0 * xx * y * dx1
       dy(3) = dy(2) * xx
       do j=1,var%n
          fjac(i,j) = - dy(var%idx(j)) * dat%w(i)
       enddo
    enddo
  endif
end subroutine get_jacobian
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
subroutine get_profile(fun,profile)
  use telcal_interfaces, except_this=>get_profile
  use fit_definitions ! Transmission of hidden (eg fixed) parameters
  !----------------------------------------------------------------------
  ! @ private
  !
  !----------------------------------------------------------------------
  type(fit_fun), intent(in)      :: fun     ! Fitting function description
  type(simple_1d), intent(inout) :: profile ! Solution profile
  !
  ! Local variables
  real(4) :: x01,y01,dx1,xx
  real(4) :: x02,y02,dx2
  real(8) :: pi
  integer i,j
  !
  if (fun%name.eq.'GAUSSIAN') then
     pi = acos(-1.d0)
     x01 = fun%par(2)%value
     dx1 = 2.d0*sqrt(log(2.d0)) / fun%par(3)%value
     y01 = fun%par(1)%value / fun%par(3)%value * 2.d0*sqrt(log(2.d0)) / sqrt(pi)
     do i=1,profile%n
        xx = (profile%x(i)-x01)*dx1
        if (xx.lt.5) then
           profile%y(i) = y01 * exp(-xx*xx)
        else
           profile%y(i) = 0
        endif
     enddo
  else if (fun%name.eq.'GAUSSIAN+BASE') then
     pi = acos(-1.d0)
     x01 = fun%par(2)%value
     dx1 = 2.d0*sqrt(log(2.d0)) / fun%par(3)%value
     y01 = fun%par(1)%value / fun%par(3)%value * 2.d0*sqrt(log(2.d0)) / sqrt(pi)
     do i=1,profile%n
        xx = (profile%x(i)-x01)*dx1
        if (xx.lt.5) then
           profile%y(i) = y01 * exp(-xx*xx)
        else
           profile%y(i) = 0
        endif
        profile%y(i) = profile%y(i) + fun%par(4)%value + fun%par(5)%value*profile%x(i)
     enddo
  else if (fun%name.eq.'2*GAUSSIAN+BASE') then
     pi = acos(-1.d0)
     x01 = fun%par(2)%value
     dx1 = 2.d0*sqrt(log(2.d0)) / fun%par(3)%value
     y01 = fun%par(1)%value / fun%par(3)%value * 2.d0*sqrt(log(2.d0)) / sqrt(pi)
     x02 = fun%par(2)%value+fun%par(5)%value
     dx2 = 2.d0*sqrt(log(2.d0)) / (fun%par(3)%value*fun%par(6)%value)
     y02 = (fun%par(1)%value*fun%par(4)%value) / (fun%par(3)%value*fun%par(6)%value) * 2.d0*sqrt(log(2.d0)) / sqrt(pi)
     do i=1,profile%n
        xx = (profile%x(i)-x01)*dx1
        if (xx.lt.5) then
           profile%y(i) = y01 * exp(-xx*xx)
        else
           profile%y(i) = 0
        endif
        xx = (profile%x(i)-x02)*dx2
        if (xx.lt.5) then
           profile%y(i) = profile%y(i) + y02 * exp(-xx*xx)
        endif
        profile%y(i) = profile%y(i) + fun%par(7)%value + fun%par(8)%value*profile%x(i)
     enddo
  else if (fun%name.eq.'LORENTZIAN') then
     x01 = fun%par(2)%value
     dx1 = 1.d0 / fun%par(3)%value
     y01 = fun%par(1)%value
     do i=1,profile%n
        xx = (profile%x(i)-x01)*dx1
        profile%y(i) = y01 / (1d0 + xx*xx)
     enddo
  else if (fun%name.eq.'POLYNOMIAL') then
     do i=1,profile%n
        profile%y(i) = fun%par(fun%npar)%value
        do j=fun%npar-1,1,-1
           profile%y(i) = profile%y(i) * profile%x(i) + fun%par(j)%value
        enddo
     enddo
  endif
end subroutine get_profile
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
subroutine fit_polynomial(dat,fun)
  use telcal_interfaces, except_this=>fit_polynomial
  use fit_definitions
  use fit_association
  !----------------------------------------------------------------------
  ! @ private
  !----------------------------------------------------------------------
  type(simple_1d), intent(in)  :: dat ! Data vectors
  type(fit_fun), intent(inout) :: fun ! Fitting function description
  !
  ! Local variables
  integer                             :: i,ier,info,maxdeg,ndeg
  real(8)                             :: eps
  real(8), dimension(dat%n)           :: r,tc
  real(8), dimension(3*dat%n+3*dat%n) :: a
  !
  call xsetf(0)
  !
  ! Copy data from input parameters to association module.
  allocate(adat%x(dat%n),adat%y(dat%n),adat%w(dat%n),stat=ier)
  if (ier.eq.0) then
     call copy_simple_1d(dat,adat)
  else
     call gagout('E-FIT1D, Error in data array allocation')
     fun%flag = -3
     return
  endif
  !
  allocate (afun%par(fun%npar),stat=ier)
  if (ier.eq.0) then
     call copy_function(fun,afun)
  else
     call gagout('E-FIT1D, Error in function array allocation')
     fun%flag = -3
     return
  endif
  ! From now on, use only associated variables
  !
  maxdeg = adat%n-1
  eps = 0.d0
  call dpolft(adat%n,adat%x,adat%y,adat%w,maxdeg,ndeg,eps,r,info,a)
  !
  if (info.eq.2) then
     print *, 'F-DPOLFT, invalid input parameter, info = ', info
     fun%flag = -5
     deallocate(afun%par)
     deallocate(adat%x,adat%y,adat%w)
     return
  endif
  call dpcoef(maxdeg,0.d0,tc,a)
  !
  do i=1,afun%npar
     afun%par(i)%value = tc(i)
  enddo
  ! Print results
  print *,'------'
  print *,'RESULT'
  print *,' '
  do i=1,afun%npar
     print *, afun%par(i)%name, afun%par(i)%value
  enddo
  print *, "RMS = ",eps
  !
  ! Return results: ie get back to input parameters from association module
  call copy_function(afun,fun)
  deallocate(afun%par)
  deallocate(adat%x,adat%y,adat%w)
  !
end subroutine fit_polynomial
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
subroutine null_simple_1d(dat)
  use fit_definitions
  !----------------------------------------------------------------------
  ! @ public
  ! TELCAL support routine of its derived types
  ! Purpose: Initialize a simple precision data vector
  !----------------------------------------------------------------------
  type(simple_1d), intent(inout) :: dat ! Data vector
  !
  ! Local variables
  dat%n = 0
  if (associated(dat%x)) deallocate(dat%x)
  if (associated(dat%y)) deallocate(dat%y)
  if (associated(dat%w)) deallocate(dat%w)
  if (associated(dat%d)) deallocate(dat%d)
  nullify(dat%x)
  nullify(dat%y)
  nullify(dat%w)
  nullify(dat%d)
end subroutine null_simple_1d
!
subroutine null_parameter(par)
  use fit_definitions
  !----------------------------------------------------------------------
  ! @ public
  ! TELCAL support routine of its derived types
  ! Purpose: Initialize a fitted parameter
  !----------------------------------------------------------------------
  type(fit_par), intent(inout) :: par ! Fitted parameter
  !
  ! Local variables
  par%guess = 0
  par%value = 0
  par%error = 0
  par%mini = -1e30
  par%maxi =  1e30
  par%fixed = .false.
  par%name = 'UNDEFINED'
end subroutine null_parameter
!
subroutine null_function(fun)
  use fit_definitions
  !----------------------------------------------------------------------
  ! @ public
  ! TELCAL support routine of its derived types
  ! Purpose: Initialize a fitted function description
  !----------------------------------------------------------------------
  type(fit_fun), intent(inout) :: fun ! Description of the fitted function
  !
  ! Local variables
  fun%name   = 'UNDEFINED'
  fun%method = 'UNDEFINED'
  fun%chi2   = 0.
  fun%rms    = 0.
  fun%flag   = 1 ! Waiting for data
  fun%ncall  = 0
  fun%npar   = 0
  if (associated(fun%par)) deallocate(fun%par)
  nullify(fun%par)
end subroutine null_function
!
! Fit derived type copy routines
!
subroutine copy_simple_1d(in,out)
  use fit_definitions
  !----------------------------------------------------------------------
  ! @ public
  ! TELCAL support routine of its derived types
  ! Purpose: Copy a simple precision data vector
  !----------------------------------------------------------------------
  type(simple_1d), intent(in)    :: in  ! Original vector
  type(simple_1d), intent(inout) :: out ! Copied vector
  !
  ! Local variables
  out%n = in%n
  if (associated(in%x).and.associated(out%x)) out%x = in%x
  if (associated(in%y).and.associated(out%y)) out%y = in%y
  if (associated(in%w).and.associated(out%w)) out%w = in%w
  if (associated(in%d).and.associated(out%d)) out%d = in%d
  !
end subroutine copy_simple_1d
!
subroutine copy_function(in,out)
  use fit_definitions
  !----------------------------------------------------------------------
  ! @ public
  ! TELCAL support routine of its derived types
  ! Purpose: Copy the description of a fitted function
  !----------------------------------------------------------------------
  type(fit_fun), intent(in)    :: in  ! Original function
  type(fit_fun), intent(inout) :: out ! Copied function
  !
  ! Local variables
  integer i
  !
  out%name   = in%name
  out%method = in%method
  out%chi2   = in%chi2
  out%rms    = in%rms
  out%flag   = in%flag
  out%ncall  = in%ncall
  out%npar   = in%npar
  do i=1,in%npar
     call null_parameter(out%par(i))
     out%par(i) = in%par(i)
  enddo
  !
end subroutine copy_function
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
