lgrint.f90

Go to the documentation of this file.

c NLSL Version 1.5 7/1/95
c----------------------------------------------------------------------
c                    =========================
c                       function LGRINT
c                    =========================
c
c Given an array of five points corresponding to a function fn
c tabulated at equally spaced abscissae x(-2),x(-1),x(0),x(1),x(2),
c such that there is a maximum in fn at one of the internal point
c of the array, this routine finds a value p such that fn(x(0)+p)
c is the extremum, where p is given as a multiple of the spacing
c between the x-values.
c
c The minimization is based on the 5-point Lagrange formula for
c polynomial interpolation using equally-spaced x-values [formula
c 25.2.15 in Abramowitz and Stegun, Handbook of Mathematical Functions,
c Dover, 2nd edition (1978).]
c
c The extremum is found by setting the first derivative of formula
c 25.2.15 w.r.t. p equal to zero and finding the root of the 
c resulting polynomial using a method based on the polynomial
c root-finding algorithm given in Numerical Recipes by Press. et al.
c
c The starting point for the root search is assumed to be x(0) (p=0).
c
c Inputs:
c   fn   5-vector with function values
c
c Output:
c   err  is set to error estimate given by Abramowitz and Stegun
c   Function return is value of p corresponding to the function
c   maximum
c
c----------------------------------------------------------------------
c
      function lgrint(fn,err)
      implicit none
      double complex lgrint
      double precision fn(5),err
c
      integer iter,j,m,npol
      double precision cdx,ctmp,dxold,eps,yy,zz
      double complex a(4)
      double complex x,dx,x1,b,d,f,g,h,sq,gp,gm,g2,zero,xx,ww
c
      integer MAXIT
      double precision TINY
      double complex CZERO
      parameter(czero=(0.,0.),tiny=1.e-15,maxit=100)
c
c ---------------------------------------------------------------
c Define coefficients for polynomial that is the first-derivative
c of the 5-point Lagrange polynomial with respect to p
c ---------------------------------------------------------------
      ctmp = ((fn(1)-fn(5))-8.0d0*(fn(2)-fn(4)))/12.0d0
      a(1) = dcmplx(ctmp,0.0d0)
      ctmp = ( -(fn(1)+fn(5))+16.0d0*(fn(2)+fn(4))-30.0d0*fn(3))/12.0d0
      a(2) = dcmplx(ctmp,0.0d0)
      ctmp =(-2.0d0*(fn(1)-fn(5))+6.0d0*(fn(2)-fn(4)))/12.0d0
      a(3) = dcmplx(ctmp,0.0d0)
      ctmp = ( 2.0*(fn(1)+fn(5))-8.0d0*(fn(2)+fn(4)))/12.0d0+fn(3)
      a(4) = dcmplx(ctmp,0.0d0)
c
      x=czero
      eps=1.0d-6
      m=3
c
c   --------------------------------------------------------------------
c   Start of polynomial root-finding 
c   Given the degree m and the m+1 complex coefficients a of the
c   fitting polynomial, and given eps, the desired fractional accuracy,
c   and given a complex value x as the seed for the search, the
c   following routine improves x by Laguerre's method until it converges
c   to a root of the polynomial.
c   --------------------------------------------------------------------
      do iter=1,maxit
         b=a(m+1)
         d=czero
         f=czero
         do j=m,1,-1
            f=x*f+d
            d=x*d+b
            b=x*b+a(j)
         end do
c
         if(abs(b).le.tiny) then
            dx=czero
         else if(abs(d).le.tiny.and.abs(f).le.tiny)then
            dx=cmplx(abs(b/a(m+1))**(1.d0/m),0.d0)
         else
            g=d/b
            g2=g*g
            h=g2-2.*f/b
            xx=(m-1)*(m*h-g2)
c           yy=abs(real(xx))
c           zz=abs(aimag(xx))
            yy=abs(dble(xx))
            zz=abs(dimag(xx))
            if(yy.lt.tiny.and.zz.lt.tiny) then
               sq=czero
            else if (yy.ge.zz) then
               ww=(1.0/yy)*xx
               sq=sqrt(yy)*sqrt(ww)
            else
               ww=(1.0/zz)*xx
               sq=sqrt(zz)*sqrt(ww)
            endif
            gp=g+sq
            gm=g-sq
            if(abs(gp).lt.abs(gm)) gp=gm
            dx=m/gp
         endif
         x1=x-dx
         if(x.eq.x1)then
            lgrint=x
            return
         endif
c
         x=x1
         if(abs(dx).le.eps*abs(x))then
            lgrint=x
            return
         endif
      end do
      print *, 'LGRINT: too many iterations'
      print *, '[execution paused, press enter to continue]'
      read (*,*)
      return
      end