V3FIT
fmin.f
1  FUNCTION fmin (ax, bx, f, tol)
2  USE stel_kinds
3  IMPLICIT NONE
4 C-----------------------------------------------
5 C D u m m y A r g u m e n t s
6 C-----------------------------------------------
7  REAL(rprec) ax, bx, f, tol
8 C-----------------------------------------------
9 C L o c a l P a r a m e t e r s
10 C-----------------------------------------------
11  REAL(rprec),PARAMETER :: zero = 0,one = 1, two = 2,
12  1 three = 3, five = 5, p5 = 0.5_dp
13 C-----------------------------------------------
14 C L o c a l V a r i a b l e s
15 C-----------------------------------------------
16  REAL(rprec):: a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,
17  1 u,v,w,fu,fv,fw,fx,x,fmin
18 C-----------------------------------------------
19 C E x t e r n a l F u n c t i o n s
20 C-----------------------------------------------
21  EXTERNAL f
22 C-----------------------------------------------
23 c
24 c c is the squared inverse of the golden ratio
25 c
26  c = p5*(three - sqrt(five))
27 c
28 c eps is approximately the square root of the relative machine
29 c precision.
30 c
31  eps = one
32  eps = eps/two
33  tol1 = one + eps
34  1003 CONTINUE
35  IF (tol1 .le. one) GOTO 1002
36  eps = eps/two
37  tol1 = one + eps
38  IF (tol1 .le. one) GOTO 1002
39  eps = eps/two
40  tol1 = one + eps
41  IF (tol1 .le. one) GOTO 1002
42  eps = eps/two
43  tol1 = one + eps
44  IF (tol1 .le. one) GOTO 1002
45  eps = eps/two
46  tol1 = one + eps
47  GOTO 1003
48  1002 CONTINUE
49  eps = sqrt(eps)
50 c
51 c initialization
52 c
53  a = ax
54  b = bx
55  v = a + c*(b - a)
56  w = v
57  x = v
58  e = zero
59  fx = f(x)
60  fv = fx
61  fw = fx
62 c
63 c main loop starts here
64 c
65  20 CONTINUE
66  xm = p5*(a + b)
67  tol1 = eps*abs(x) + tol/three
68  tol2 = two*tol1
69 c
70 c check STOPping criterion
71 c
72  IF (abs(x - xm) .le. tol2 - p5*(b - a)) GOTO 90
73 c
74 c is golden-section necessary
75 c
76  IF (abs(e) .le. tol1) GOTO 40
77 c
78 c fit parabola
79 c
80  r = (x - w)*(fx - fv)
81  q = (x - v)*(fx - fw)
82  p = (x - v)*q - (x - w)*r
83  q = two*(q - r)
84  IF (q .gt. zero) p = -p
85  q = abs(q)
86  r = e
87  e = d
88 c
89 c is parabola acceptable
90 c
91  IF (abs(p) .ge. abs(p5*q*r)) GOTO 40
92  IF (p .le. q*(a - x)) GOTO 40
93  IF (p .ge. q*(b - x)) GOTO 40
94 c
95 c a parabolic interpolation step
96 c
97  IF( q.ne.zero )d = p/q
98  u = x + d
99 c
100 c f must not be evaluated too CLOSE to ax or bx
101 c
102  IF (u - a < tol2) d = sign(tol1,xm - x)
103  IF (b - u < tol2) d = sign(tol1,xm - x)
104  GOTO 50
105 c
106 c a golden-section step
107 c
108  40 CONTINUE
109  IF (x .ge. xm) THEN
110  e = a - x
111  ELSE
112  e = b - x
113  END IF
114  d = c*e
115 c
116 c f must not be evaluated too CLOSE to x
117 c
118  50 CONTINUE
119  IF (abs(d) .ge. tol1) THEN
120  u = x + d
121  ELSE
122  u = x + sign(tol1,d)
123  END IF
124  fu = f(u)
125 c
126 c update a, b, v, w, and x
127 c
128  IF (fu .gt. fx) GOTO 60
129  IF (u .ge. x) THEN
130  a = x
131  ELSE
132  b = x
133  END IF
134  v = w
135  fv = fw
136  w = x
137  fw = fx
138  x = u
139  fx = fu
140  GOTO 20
141  60 CONTINUE
142  IF (u .lt. x) THEN
143  a = u
144  ELSE
145  b = u
146  END IF
147  IF (fu .le. fw) GOTO 70
148  IF (w .eq. x) GOTO 70
149  IF (fu .le. fv) GOTO 80
150  IF (v .eq. x) GOTO 80
151  IF (v .eq. w) GOTO 80
152  GOTO 20
153  70 CONTINUE
154  v = w
155  fv = fw
156  w = u
157  fw = fu
158  GOTO 20
159  80 CONTINUE
160  v = u
161  fv = fu
162  GOTO 20
163 c
164 c END of main loop
165 c
166  90 CONTINUE
167  fmin = x
168 
169  END FUNCTION fmin