subroutine fcheb  (xx,a,np1)
  !---------------------------------------------------------------------
  ! Fitting routine for a Chebychev polynomial of degree NP-1.
  ! Compute all coefficients of the polynomials, from the usual recurrence
  ! Beware of first point for "true" Chebychev polynomials
  !---------------------------------------------------------------------
  real*8 :: xx                      !
  integer :: np1                    !
  real*8 :: a(np1)                  !
  ! Local
  integer :: j
  real*8 :: z
  !
  a(1) = 1.d0
  a(2) = xx
  do j=3,np1
    z = a(j-1)*xx
    a(j)= z+z-a(j-2)
  enddo
  ! Note that this one is special
  a(1) = 0.5d0
end subroutine fcheb
!
subroutine svdput(f,np,a,nrows)
  !---------------------------------------------------------------------
  ! Move solution of least-square fit of Chebychev polynomial
  ! found by Singular Value Decomposition or Linear Fit into
  ! appropriate place for compatibility with NAG.
  !
  ! A bit crazy, but...
  !---------------------------------------------------------------------
  integer :: np                     !
  real*8 :: f(np)                   !
  integer :: nrows                  !
  real*8 :: a(nrows,np)             !
  ! Local
  integer :: j
  !
  ! Storage is incredible, but documented...
  do j=1,np
    a(np,j) = f(j)
  enddo
end subroutine svdput
!
subroutine svdfit(x,y,weight,ndata,a,ma,u,v,w,mp,np,chisq,   &
    funcs,b,afunc,error)
  !---------------------------------------------------------------------
  ! Singular value decomposition
  ! Given a set of NDATA points X(I), Y(I) with individual weights
  ! WEIGHT(I), use Chi2 minimization to determine the MA coefficients A of the
  ! fitting function. Here we solve the fitting
  ! equations using singular value decomposition of the NDATA by MA matrix.
  ! Arrays U,V,W provide workspace on input. On output they define the singular
  ! value decomposition and can be used to obtain the covariance matrix. MP, NP
  ! are the physical dimensions of the matrices U, V, W, as indicated below. It
  ! is necessary that MP>=NDATA, NP>=MA. The programs returns values for the MA
  ! fit parameters and Chi2, CHISQ. The user supplies a subroutine
  ! FUNCS(X,AFUNC,MA) that returns the MA basis functions evaluated at x=X in the
  ! array AFUNC.
  !
  ! As compared to the basic algorithm in "Numerical recipes",
  !     work arrays AFUNC and B are passed as argument. This suppress
  !     the need for size dependent storage.
  ! WEIGHT is the inverse of the sigma.
  !     Written by T.Forveille sometime ago
  !     Modifications by S.Guilloteau 28-feb-1995
  !---------------------------------------------------------------------
  integer :: ndata                  !
  real*8 :: x(ndata)                !
  real*8 :: y(ndata)                !
  real*8 :: weight(ndata)           !
  integer :: ma                     !
  real*8 :: a(ma)                   !
  integer :: mp                     !
  integer :: np                     !
  real*8 :: u(mp,np)                !
  real*8 :: v(np,np)                !
  real*8 :: w(np)                   !
  real*8 :: chisq                   !
  external :: funcs                 !
  real*8 :: b(ndata)                !
  real*8 :: afunc(ma)               !
  logical :: error                  !
  ! Local
  real*8 :: tol
  parameter (tol=1d-5)
  !
  integer :: i,j
  real*8 :: wmax,thresh,sum
  !
  error = .false.
  do i=1,ndata
    call funcs(x(i),afunc,ma)
    do j=1,ma
      u(i,j) = afunc(j)*weight(i)
    enddo
    b(i) = y(i)*weight(i)
  enddo
  call svdcmp(u,ndata,ma,mp,np,w,v,error)
  if (error) return
  ! Edit out the (nearly) singular values
  wmax = 0.
  do j=1,ma
    if (w(j).gt.wmax) wmax=w(j)
  enddo
  thresh = tol*wmax
  do j=1,ma
    if (w(j).lt.thresh) w(j) = 0
  enddo
  ! Solve the equations
  call svbksb(u,w,v,ndata,ma,mp,np,b,a,error)
  if (error) return
  ! Evaluate chi-square
  chisq = 0.d0
  do i=1,ndata
    call funcs(x(i),afunc,ma)
    sum=0.
    do j=1,ma
      sum = sum+a(j)*afunc(j)
    enddo
    chisq = chisq+((y(i)-sum)*weight(i))**2
  enddo
end subroutine svdfit
!
subroutine svdcmp(a,m,n,mp,np,w,v,error)
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! Singular value decomposition
  ! Given a matrix A with logical dimensions M by N and physical dimensions MP
  ! by NP, this routine computes its singular value decomposition
  !	A = U.W.Vt
  ! The matrix U replaces A on output. The diagonal matrix of singular values W
  ! is a output as a vector W. The matrix V (not the transpose Vt) is output as
  ! V. M must be greater or equal to N. If it is smaller, then A should be filled
  ! up to square with zero rows.
  ! Typed from "numerical recipes".  TF
  !---------------------------------------------------------------------
  integer :: mp                     !
  integer :: np                     !
  real*8 :: a(mp,np)                !
  integer :: m                      !
  integer :: n                      !
  real*8 :: w(np)                   !
  real*8 :: v(np,np)                !
  logical :: error                  !
  ! Local
  integer :: nmax
  parameter (nmax=100)         ! Maximum anticipated value of N
  real*8 :: rv1(nmax)
  integer :: i,j,k,l,nm,its,jj
  real*8 :: scale,anorm,c,s,x,y,z
  real*8 :: f,g,h
  !
  if (n.gt.nmax) then
    call gagout('E-SVDCMP,  NMAX dimension too small. '//   &
      'Will need to recompile.')
    error = .true.
    return
  elseif (m.lt.n) then
    call gagout('E-SVDCMP,  You must augment A with extra '//   &
      'zero rows.')
    error = .true.
    return
  endif
  ! Householder reduction to diagonal form
  g = 0.0
  scale = 0.0
  anorm = 0.0
  do i=1,n
    l=i+1
    rv1(i) = scale*g
    g = 0.0
    s = 0.0
    scale = 0.0
    if (i.le.m) then
      do k=i,m
        scale = scale+abs(a(k,i))
      enddo
      if (scale.ne.0.0) then
        do k=i,m
          a(k,i) = a(k,i)/scale
          s = s+a(k,i)*a(k,i)
        enddo
        f = a(i,i)
        g = -sign(sqrt(s),f)
        h = f*g-s
        a(i,i) = f-g
        if(i.ne.n) then
          do j=l,n
            s=0.0
            do k=i,m
              s = s+a(k,i)*a(k,j)
            enddo
            f = s/h
            do k=i,m
              a(k,j) = a(k,j)+f*a(k,i)
            enddo
          enddo
        endif
        do k=i,m
          a(k,i) = scale*a(k,i)
        enddo
      endif
    endif
    w(i) = scale*g
    g = 0.0
    s = 0.0
    scale = 0.0
    if ((i.le.m).and.(i.ne.n)) then
      do k=l,n
        scale = scale+abs(a(i,k))
      enddo
      if (scale.ne.0) then
        do k=l,n
          a(i,k)=a(i,k)/scale
          s=s+a(i,k)*a(i,k)
        enddo
        f=a(i,l)
        g=-sign(sqrt(s),f)
        h=f*g-s
        a(i,l)=f-g
        do k=l,n
          rv1(k)=a(i,k)/h
        enddo
        if (i.ne.m) then
          do j=l,m
            s=0.0
            do k=l,n
              s=s+a(j,k)*a(i,k)
            enddo
            do k=l,n
              a(j,k)=a(j,k)+s*rv1(k)
            enddo
          enddo
        endif
        do k=l,n
          a(i,k)=scale*a(i,k)
        enddo
      endif
    endif
    anorm = max(anorm,(abs(w(i))+abs(rv1(i))))
  enddo
  ! Accumulation of right hand transformation
  do i=n,1,-1
    if (i.lt.n) then
      if (g.ne.0.0) then
        do j=l,n               ! Double division avoids possible underflow
          v(j,i) = (a(i,j)/a(i,l))/g
        enddo
        do j=l,n
          s=0.0
          do k=l,n
            s=s+a(i,k)*v(k,j)
          enddo
          do k=l,n
            v(k,j)=v(k,j)+s*v(k,i)
          enddo
        enddo
      endif
      do j=l,n
        v(i,j) = 0.0
        v(j,i) = 0.0
      enddo
    endif
    v(i,i) = 1.0
    g = rv1(i)
    l = i
  enddo
  ! Accumulation of left hand transformations.
  do i=n,1,-1
    l = i+1
    g = w(i)
    if (i.lt.n) then
      do j=l,n
        a(i,j) = 0.0
      enddo
    endif
    if (g.ne.0.0) then
      g = 1.0/g
      if (i.ne.n) then
        do j=l,n
          s = 0.0
          do k=l,m
            s = s+a(k,i)*a(k,j)
          enddo
          f = (s/a(i,i))*g
          do k=i,m
            a(k,j)=a(k,j)+f*a(k,i)
          enddo
        enddo
      endif
      do j=i,m
        a(j,i) = a(j,i)*g
      enddo
    else
      do j=i,m
        a(j,i) = 0.0
      enddo
    endif
    a(i,i) = a(i,i)+1.0
  enddo
  ! Diagonalization of the bidiagonal form
  do k=n,1,-1                  ! Loop over singular values
    do its=1,30                ! Loop over allowed iterations
      do l=k,1,-1              ! Test for splitting:
        nm=l-1                 ! Note that RV1(1) is always zero
        if ((abs(rv1(l))+anorm).eq.anorm) goto 2
        if ((abs(w(nm))+anorm).eq.anorm) goto 1
      enddo
1     c=0.0        ! Cancellation of RV1(L), if L>1
      s=1.0
      do i=l,k
        f=s*rv1(i)
        if ((abs(f)+anorm).ne.anorm) then
          g = w(i)
          h = sqrt(f*f+g*g)
          w(i) = h
          h = 1.0/h
          c = (g*h)
          s = -f*h
          do j=1,m
            y = a(j,nm)
            z = a(j,i)
            a(j,nm)=(y*c)+(z*s)
            a(j,i)=-(y*s)+(z*c)
          enddo
        endif
      enddo
2     z=w(k)
      if (l.eq.k) then         ! Convergence
        if (z.lt.0.0) then     ! Singular value is made non negative
          w(k)=-z
          do j=1,n
            v(j,k)=-v(j,k)
          enddo
        endif
        goto 3
      endif
      if (its.eq.30) then
        call gagout('E-SVDCMP,  '//   &
          'No convergence in 30 iterations.')
        error = .true.
        return
      endif
      x=w(l)                   ! Shift from bottom 2-by-2 minor
      nm = k-1
      y = w(nm)
      g = rv1(nm)
      h = rv1(k)
      f = ((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y)
      g = sqrt(f*f+1.0)
      f = ((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
      ! Next QR transformation
      c=1.0
      s=1.0
      do j=l,nm
        i=j+1
        g=rv1(i)
        y=w(i)
        h=s*g
        g=c*g
        z=sqrt(f*f+h*h)
        rv1(j) = z
        c=f/z
        s=h/z
        f= (x*c)+(g*s)
        g=-(x*s)+(g*c)
        h=y*s
        y=y*c
        do jj=1,n
          x=v(jj,j)
          z=v(jj,i)
          v(jj,j)= (x*c)+(z*s)
          v(jj,i)=-(x*s)+(z*c)
        enddo
        z=sqrt(f*f+h*h)
        w(j) = z
        if (z.ne.0) then       ! Rotation can be arbitrary if Z=0
          z=1.0/z
          c=f*z
          s=h*z
        endif
        f= (c*g)+(s*y)
        x=-(s*g)+(c*y)
        do jj=1,m
          y=a(jj,j)
          z=a(jj,i)
          a(jj,j) = (y*c)+(z*s)
          a(jj,i) =-(y*s)+(z*c)
        enddo
      enddo
      rv1(l)=0.0
      rv1(k)=f
      w(k)=x
    enddo
3   continue
  enddo
  return
end subroutine svdcmp
!
subroutine svbksb(u,w,v,m,n,mp,np,b,x,error)
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! Singular value decomposition
  ! Solves A.X = B for a vector X, where A is specified by the arrays U,W,V as
  ! returned by SVDCMP. M and N are the logical dimensions of A, and will be
  ! equal for square matrices. MP and NP are the physical dimensions of A. B
  ! is the input right hand side. X is the output soolution vector. No input
  ! quantities are destroyed, so the routine may be called sequentially with
  ! different B's.
  ! Typed from "numerical recipes".  TF
  !---------------------------------------------------------------------
  integer :: mp                     !
  integer :: np                     !
  real*8 :: u(mp,np)                !
  real*8 :: w(np)                   !
  real*8 :: v(np,np)                !
  integer :: m                      !
  integer :: n                      !
  real*8 :: b(mp)                   !
  real*8 :: x(np)                   !
  logical :: error                  !
  ! Local
  integer :: nmax
  parameter (nmax=100)
  real*8 :: tmp(nmax),s
  integer :: i,j,jj
  !
  if (n.gt.nmax) then
    call gagout('E-SVDCMP,  NMAX dimension too small. '//   &
      'Will need to recompile.')
    error = .true.
    return
  endif
  ! Calculate UtB
  do j=1,n
    s = 0.
    if (w(j).ne.0.) then
      do i=1,m
        s=s+u(i,j)*b(i)
      enddo
      s = s/w(j)
    endif
    tmp(j) = s
  enddo
  ! Matrix multiply by V to get answer
  do j=1,n
    s = 0.0
    do jj=1,n
      s = s+v(j,jj)*tmp(jj)
    enddo
    x(j) = s
  enddo
end subroutine svbksb
!
subroutine fpoly(x,p,np)
  !---------------------------------------------------------------------
  ! Fitting routine for a polynomial of degree NP-1.
  !---------------------------------------------------------------------
  real*8 :: x                       !
  integer :: np                     !
  real*8 :: p(np)                   !
  ! Local
  integer :: j
  !
  p(1) = 1.d0
  do j=2,np
    p(j)=p(j-1)*x
  enddo
end subroutine fpoly
!
subroutine lfit(x,y,weight,ndata,a,ma,covar,ncvm,chisq,   &
    funcs,error)
  !---------------------------------------------------------------------
  ! Given a set of NDATA points X(I),Y(I) with individual weights WEIGHT(I),
  ! use Chi2 minimization to determine the MA coefficients A of a function
  ! that depends linearly on A.
  !
  ! WEIGHT is the inverse of the Sigmas.
  !---------------------------------------------------------------------
  integer :: ndata                  !
  real*8 :: x(ndata)                !
  real*8 :: y(ndata)                !
  real*8 :: weight(ndata)           !
  integer :: ma                     !
  real*8 :: a(ma)                   !
  integer :: ncvm                   !
  real*8 :: covar(ncvm,ncvm)        !
  real*8 :: chisq                   !
  external :: funcs                 !
  logical :: error                  !
  ! Local
  integer :: mmax
  parameter (mmax=50)
  real*8 :: beta(mmax),afunc(mmax),sig2i,sum,ym,wt
  integer :: i,j,k
  !
  if (ma.gt.mmax) then
    call message(8,4,'LFIT','Incoherent array dimensions')
    error = .true.
    return
  endif
  !
  do j=1,ma
    do k=1,ma
      covar(j,k)=0.d0
    enddo
    beta(j)=0.d0
  enddo
  do i=1,ndata
    call funcs(x(i),afunc,ma)
    ym=y(i)
    sig2i=weight(i)**2
    do j=1,ma
      wt=afunc(j)*sig2i
      do k=1,j
        covar(j,k)=covar(j,k)+wt*afunc(k)
      enddo
      beta(j)=beta(j)+ym*wt
    enddo
  enddo
  if (ma.gt.1) then
    do j=2,ma
      do k=1,j-1
        covar(k,j)=covar(j,k)
      enddo
    enddo
  endif
  call gaussj(covar,ma,ncvm,beta,1,1)
  do j=1,ma
    a(j)=beta(j)
  enddo
  chisq=0.d0
  do i=1,ndata
    call funcs(x(i),afunc,ma)
    sum=0.d0
    do j=1,ma
      sum=sum+a(j)*afunc(j)
    enddo
    chisq=chisq+((y(i)-sum)*weight(i))**2
  enddo
end subroutine lfit
!
subroutine gaussj(a,n,np,b,m,mp)
  use gkernel_interfaces
  integer :: np                     !
  real*8 :: a(np,np)                !
  integer :: n                      !
  integer :: mp                     !
  real*8 :: b(np,mp)                !
  integer :: m                      !
  ! Local
  integer :: nmax
  !
  real*8 :: big,dum,pivinv
  parameter (nmax=50)
  integer :: ipiv(nmax),indxr(nmax),indxc(nmax)
  integer :: i,j,k,l,ll,irow,icol
  !
  do j=1,n
    ipiv(j)=0
  enddo
  !
  do i=1,n
    big=0.d0
    do j=1,n
      if (ipiv(j).ne.1) then
        do k=1,n
          if (ipiv(k).eq.0) then
            if (abs(a(j,k)).ge.big) then
              big=abs(a(j,k))
              irow=j
              icol=k
            endif
          elseif (ipiv(k).gt.1) then
            call gagout('F-GAUSSJ,  Singular matrix')
            return
          endif
        enddo
      endif
    enddo
    ipiv(icol)=ipiv(icol)+1
    if (irow.ne.icol) then
      do l=1,n
        dum=a(irow,l)
        a(irow,l)=a(icol,l)
        a(icol,l)=dum
      enddo
      do l=1,m
        dum=b(irow,l)
        b(irow,l)=b(icol,l)
        b(icol,l)=dum
      enddo
    endif
    indxr(i)=irow
    indxc(i)=icol
    if (a(icol,icol).eq.0.d0) then
      call gagout('F-GAUSSJ,  Singular matrix')
      return
    endif
    pivinv=1.d0/a(icol,icol)
    a(icol,icol)=1.d0
    do l=1,n
      a(icol,l)=a(icol,l)*pivinv
    enddo
    do l=1,m
      b(icol,l)=b(icol,l)*pivinv
    enddo
    do ll=1,n
      if (ll.ne.icol) then
        dum=a(ll,icol)
        a(ll,icol)=0.d0
        do l=1,n
          a(ll,l)=a(ll,l)-a(icol,l)*dum
        enddo
        do l=1,m
          b(ll,l)=b(ll,l)-b(icol,l)*dum
        enddo
      endif
    enddo
  enddo
  !
  do l=n,1,-1
    if (indxr(l).ne.indxc(l)) then
      do k=1,n
        dum=a(k,indxr(l))
        a(k,indxr(l))=a(k,indxc(l))
        a(k,indxc(l))=dum
      enddo
    endif
  enddo
end subroutine gaussj
!
subroutine mindeg(a,n)
  integer :: n                      !
  real*8 :: a(n)                    !
  ! Local
  integer :: i,imin
  character(len=32) :: chain
  !
  ! Crude criterium, shout on first minimum
  imin = n
  do i=n-1,1,-1
    if (a(i).le.a(imin)) imin = i
  enddo
  if (imin.lt.n) then
    write(chain,'(A,I2,A)') 'Degree ',imin-1,   &
      ' would be even better'
    call message(6,2,'POLYNO',chain)
    print *,(a(i),i=1,n)
  endif
end subroutine mindeg
!
subroutine svdvar(v,ma,np,w,cvm,ncvm,wti,sigma)
  !---------------------------------------------------------------------
  ! Compute covariance matrix
  ! Note NP > MA
  !---------------------------------------------------------------------
  integer :: np                     ! Dimension of V matrix
  real*8 :: v(np,np)                !
  integer :: ma                     ! Number of variables
  real*8 :: w(np)                   !
  integer :: ncvm                   ! Dimension of covariance matrix
  real*8 :: cvm(ncvm,ncvm)          !
  real*8 :: wti(ma)                 !
  real*8 :: sigma                   !
  ! Local
  real*8 :: sum
  integer :: i,j,k
  !
  do i=1,ma
    wti(i)=0.
    if (w(i).ne.0.d0) wti(i)=(sigma/w(i))**2
  enddo
  do i=1,ma
    do j=1,i
      sum=0.d0
      do k=1,ma
        sum=sum+v(i,k)*v(j,k)*wti(k)
      enddo
      cvm(i,j)=sum
      cvm(j,i)=sum
    enddo
  enddo
end subroutine svdvar
