NLSL: lgrint.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

lgrint.f90
Go to the documentation of this file.
1 c NLSL Version 1.5 7/1/95
2 c----------------------------------------------------------------------
3 c =========================
4 c function LGRINT
5 c =========================
6 c
7 c Given an array of five points corresponding to a function fn
8 c tabulated at equally spaced abscissae x(-2),x(-1),x(0),x(1),x(2),
9 c such that there is a maximum in fn at one of the internal point
10 c of the array, this routine finds a value p such that fn(x(0)+p)
11 c is the extremum, where p is given as a multiple of the spacing
12 c between the x-values.
13 c
14 c The minimization is based on the 5-point Lagrange formula for
15 c polynomial interpolation using equally-spaced x-values [formula
16 c 25.2.15 in Abramowitz and Stegun, Handbook of Mathematical Functions,
17 c Dover, 2nd edition (1978).]
18 c
19 c The extremum is found by setting the first derivative of formula
20 c 25.2.15 w.r.t. p equal to zero and finding the root of the
21 c resulting polynomial using a method based on the polynomial
22 c root-finding algorithm given in Numerical Recipes by Press. et al.
23 c
24 c The starting point for the root search is assumed to be x(0) (p=0).
25 c
26 c Inputs:
27 c fn 5-vector with function values
28 c
29 c Output:
30 c err is set to error estimate given by Abramowitz and Stegun
31 c Function return is value of p corresponding to the function
32 c maximum
33 c
34 c----------------------------------------------------------------------
35 c
36 function lgrint(fn,err)
37 implicit none
38 double complex lgrint
39 double precision fn(5),err
40 c
41 integer iter,j,m,npol
42 double precision cdx,ctmp,dxold,eps,yy,zz
43 double complex a(4)
44 double complex x,dx,x1,b,d,f,g,h,sq,gp,gm,g2,zero,xx,ww
45 c
46 integer MAXIT
47 double precision TINY
48 double complex CZERO
49 parameter(czero=(0.,0.),tiny=1.e-15,maxit=100)
50 c
51 c ---------------------------------------------------------------
52 c Define coefficients for polynomial that is the first-derivative
53 c of the 5-point Lagrange polynomial with respect to p
54 c ---------------------------------------------------------------
55 ctmp = ((fn(1)-fn(5))-8.0d0*(fn(2)-fn(4)))/12.0d0
56 a(1) = dcmplx(ctmp,0.0d0)
57 ctmp = ( -(fn(1)+fn(5))+16.0d0*(fn(2)+fn(4))-30.0d0*fn(3))/12.0d0
58 a(2) = dcmplx(ctmp,0.0d0)
59 ctmp =(-2.0d0*(fn(1)-fn(5))+6.0d0*(fn(2)-fn(4)))/12.0d0
60 a(3) = dcmplx(ctmp,0.0d0)
61 ctmp = ( 2.0*(fn(1)+fn(5))-8.0d0*(fn(2)+fn(4)))/12.0d0+fn(3)
62 a(4) = dcmplx(ctmp,0.0d0)
63 c
64 x=czero
65 eps=1.0d-6
66 m=3
67 c
68 c --------------------------------------------------------------------
69 c Start of polynomial root-finding
70 c Given the degree m and the m+1 complex coefficients a of the
71 c fitting polynomial, and given eps, the desired fractional accuracy,
72 c and given a complex value x as the seed for the search, the
73 c following routine improves x by Laguerre's method until it converges
74 c to a root of the polynomial.
75 c --------------------------------------------------------------------
76 do iter=1,maxit
77 b=a(m+1)
78 d=czero
79 f=czero
80 do j=m,1,-1
81 f=x*f+d
82 d=x*d+b
83 b=x*b+a(j)
84 end do
85 c
86 if(abs(b).le.tiny) then
87 dx=czero
88 else if(abs(d).le.tiny.and.abs(f).le.tiny)then
89 dx=cmplx(abs(b/a(m+1))**(1.d0/m),0.d0)
90 else
91 g=d/b
92 g2=g*g
93 h=g2-2.*f/b
94 xx=(m-1)*(m*h-g2)
95 c yy=abs(real(xx))
96 c zz=abs(aimag(xx))
97 yy=abs(dble(xx))
98 zz=abs(dimag(xx))
99 if(yy.lt.tiny.and.zz.lt.tiny) then
100 sq=czero
101 else if (yy.ge.zz) then
102 ww=(1.0/yy)*xx
103 sq=sqrt(yy)*sqrt(ww)
104 else
105 ww=(1.0/zz)*xx
106 sq=sqrt(zz)*sqrt(ww)
107 endif
108 gp=g+sq
109 gm=g-sq
110 if(abs(gp).lt.abs(gm)) gp=gm
111 dx=m/gp
112 endif
113 x1=x-dx
114 if(x.eq.x1)then
115 lgrint=x
116 return
117 endif
118 c
119 x=x1
120 if(abs(dx).le.eps*abs(x))then
121 lgrint=x
122 return
123 endif
124 end do
125 print *, 'LGRINT: too many iterations'
126 print *, '[execution paused, press enter to continue]'
127 read (*,*)
128 return
129 end
lgrint
double complex function lgrint(fn, err)
Definition: lgrint.f90:37