Millepede-II V04-16-00
linesrch.f90
Go to the documentation of this file.
1
2! Code converted using TO_F90 by Alan Miller
3! Date: 2012-03-16 Time: 11:06:29
4
50
53 USE mpdef
54
55 IMPLICIT NONE
56
57 INTEGER(mpi), PARAMETER :: msfd=20
58 INTEGER(mpi) :: nsfd
59 INTEGER(mpi) :: idgl
60 INTEGER(mpi):: idgr
61 INTEGER(mpi) :: idgm
62 INTEGER(mpi) :: minf=1
63 INTEGER(mpi) :: maxf=5
64 INTEGER(mpi) :: lsinfo
65 REAL(mpd), DIMENSION(4,msfd) :: sfd
66 REAL(mpd) :: stmx=0.9
67 REAL(mpd) :: gtol
68
69END MODULE linesrch
70
88
89SUBROUTINE ptline(n,x,f,g,s,step, info) ! - 2 arguments
90 USE linesrch
91
92 IMPLICIT NONE
93 INTEGER(mpi), INTENT(IN) :: n
94 REAL(mpd), INTENT(IN OUT) :: x(n)
95 REAL(mpd), INTENT(IN OUT) :: f
96 REAL(mpd), INTENT(IN OUT) :: g(n)
97 REAL(mpd), INTENT(IN OUT) :: s(n)
98 REAL(mpd), INTENT(OUT) :: step
99 INTEGER(mpi), INTENT(OUT) :: info
100
101 INTEGER(mpi):: i1
102 INTEGER(mpi) :: i2
103 INTEGER(mpi) :: i ! internal
104 INTEGER(mpi) :: im ! internal
105 REAL(mpd) :: alpha ! internal
106 REAL(mpd) :: dginit ! internal
107 REAL(mpd) :: dg ! internal
108 REAL(mpd) :: fsaved ! internal
109 REAL(mpd) :: tot ! internal
110 REAL(mpd) :: fp1 ! internal
111 REAL(mpd) :: fp2 ! internal
112 SAVE
113
114 ! initialization ---------------------------------------------------
115
116 info=0 ! reset INFO flag
117 dg=0.0_mpd
118 DO i=1,n !
119 dg=dg-g(i)*s(i) ! DG = scalar product: grad x search
120 END do!
121
122 IF(nsfd == 0) THEN ! initial call
123 dginit=dg ! DG = initial directional gradient
124 IF(dginit >= 0.0_mpd) GO TO 100 ! error: step not decreasing
125 step=1.0_mpd ! initial step factor is one
126 alpha=step ! get initial step factor
127 tot=0.0_mpd ! reset total step
128 idgl=1 ! index of smallest negative slope
129 idgr=0 ! index of smallest positive slope
130 fsaved=f ! initial Function value
131 nsfd=1 ! starting point of iteration
132 sfd(1,1)=0.0 ! abscissa
133 sfd(2,1)=0.0 ! reference function value
134 sfd(3,1)=dginit ! slope
135 sfd(4,1)=0.0 ! predicted zero
136 im=1 ! optimum
137 ELSE ! subsequent call
138 nsfd=nsfd+1
139 sfd(1,nsfd)=tot ! abscissa
140 sfd(2,nsfd)=f-fsaved ! function value difference to reference
141 sfd(3,nsfd)=dg ! slope
142 sfd(4,nsfd)=0.0 ! predicted zero (see below)
143 IF(dg < sfd(3,im)) THEN
144 im=nsfd
145 END IF
146
147 ! define interval indices IDGL and IDGR
148 IF(dg <= 0.0_mpd) THEN
149 IF(dg >= sfd(3,idgl)) idgl=nsfd
150 END IF
151 IF(dg >= 0.0_mpd) THEN ! limit to the right
152 IF(idgr == 0) idgr=nsfd
153 IF(dg <= sfd(3,idgr)) idgr=nsfd
154 END IF
155
156 IF(idgr == 0) THEN
157 i1=nsfd-1
158 i2=nsfd
159 ELSE
160 i1=idgl
161 i2=idgr
162 END IF
163 fp1=sfd(3,i1)
164 fp2=sfd(3,i2) ! interpolation
165 sfd(4,nsfd)=(sfd(1,i1)*fp2-sfd(1,i2)*fp1)/(fp2-fp1)
166
167 ! convergence tests
168 IF(nsfd >= minf.AND.abs(dg) <= abs(dginit)*gtol) THEN
169 ! normal convergence return with INFO=1 ----------------------
170 alpha=tot+alpha ! total ALPHA is returned
171 step =alpha
172 idgm=idgl
173 IF(idgr /= 0) THEN
174 IF(sfd(3,idgr)+sfd(3,idgl) < 0.0_mpd) idgm=idgr
175 END IF
176 GO TO 101
177 END IF
178 IF(nsfd >= maxf) GO TO 102 ! max number of function calls
179 alpha=min(sfd(4,nsfd),stmx)-tot ! new step from previous
180 IF(abs(alpha) < 1.0e-3_mpd.AND.sfd(4,nsfd) > stmx) GO TO 103
181 IF(abs(alpha) < 1.0e-3_mpd) GO TO 104
182 END IF
183
184 ! prepare next function call ---------------------------------------
185
186 DO i=1,n
187 x(i)=x(i)+alpha*s(i) ! step by ALPHA -> new X
188 END DO
189 tot=tot+alpha !
190 step=tot
191 info=-1 ! recalculate function and gradient
192 lsinfo=info
193 RETURN
194
195 ! error exits ------------------------------------------------------
196104 info=info+1 ! 4: step small
197103 info=info+1 ! 3: maximum reached
198102 info=info+1 ! 2: too many function calls
199101 info=info+1 ! 1: normal convergence
200 lsinfo=info
201 im=1
202 DO i=1,nsfd
203 IF(abs(sfd(3,i)) < abs(sfd(3,im))) im=i
204 END DO
205 alpha=sfd(1,im)-sfd(1,nsfd)
206 IF(im == nsfd) RETURN ! already at minimum
207 DO i=1,n
208 x(i)=x(i)+alpha*s(i) ! step by ALPHA to slope minimum
209 END DO
210 f=sfd(2,im)+fsaved ! F at minimum
211 step=sfd(1,im) ! total step at convergence
212 IF(im /= 1) RETURN ! improvement
213 info=5 ! no improvement
214100 step=0.0_mpd ! 0: initial slope not negative
215 lsinfo=info
216 RETURN
217END SUBROUTINE ptline
218
231
232SUBROUTINE ptldef(gtole,stmax,minfe,maxfe)
233 USE linesrch
234
235 IMPLICIT NONE
236 INTEGER(mpi), INTENT(IN) :: minfe
237 INTEGER(mpi), INTENT(IN) :: maxfe
238 REAL(mps), INTENT(IN) :: gtole
239 REAL(mps), INTENT(IN) :: stmax
240
241 gtol=max(1.0e-4,min(gtole,0.9e0)) ! slope ratio
242 IF(gtole == 0.0) gtol=0.9_mpd ! default slope ratio
243 stmx=stmax ! maximum total step
244 IF(stmx == 0.0_mpd) stmx=10.0_mpd ! default limit
245 minf=max(1,min(minfe,msfd-2)) ! minimum number of evaluations
246 maxf=max(2,min(maxfe,msfd-1)) ! maximum number of evaluations
247 IF(maxfe == 0) maxf=5 ! default max number of values
248 nsfd=0 ! reset
249END SUBROUTINE ptldef
250
257
258SUBROUTINE ptlopt(nf,m,slopes,steps)
259 USE linesrch
260 IMPLICIT NONE
261
262 INTEGER(mpi), INTENT(OUT) :: nf
263 INTEGER(mpi), INTENT(OUT) :: m
264 REAL(mps), DIMENSION(3), INTENT(OUT) :: slopes
265 REAL(mps), DIMENSION(3), INTENT(OUT) :: steps
266 INTEGER(mpi) :: i
267
268 ! ...
269 nf=nsfd
270 IF(nsfd == 0) THEN ! no values
271 m=0
272 DO i=1,3
273 slopes(i)=0.0
274 steps(i) =0.0
275 END DO
276 ELSE ! values exist
277 m=1
278 DO i=1,nsfd
279 IF(abs(sfd(3,i)) < abs(sfd(3,m))) m=i
280 END DO
281 slopes(1)=real(sfd(3,1))
282 slopes(2)=real(sfd(3,nsfd))
283 slopes(3)=real(sfd(3,m))
284 steps(1) =real(sfd(1,1))
285 steps(2) =real(sfd(1,nsfd))
286 steps(3) =real(sfd(1,m))
287 END IF
288END SUBROUTINE ptlopt
289
293
294SUBROUTINE ptlprt(lunp)
295 USE linesrch
296
297 IMPLICIT NONE
298 INTEGER(mpi) :: i
299 INTEGER(mpi) :: j
300 INTEGER(mpi) :: im
301 INTEGER(mpi) :: lun
302 INTEGER(mpi), INTENT(IN) :: lunp
303 REAL(mps) :: ratio
304 CHARACTER (LEN=2) :: tlr
305 ! ...
306 lun=lunp
307 IF(lun == 0) lun=6
308 IF(nsfd <= 0) RETURN
309 WRITE(lun,*) ' '
310 WRITE(lun,*) 'PTLINE: line-search method based on slopes', &
311 ' with sufficient slope-decrease'
312 WRITE(lun,*) 'PTLDEF: slope ratio limit=',gtol
313 WRITE(lun,*) 'PTLDEF: maximum step =',stmx
314 WRITE(lun,*) 'PTLDEF:',minf,' <= nr of calls <=',maxf
315 WRITE(lun,101)
316 im=1
317 DO i=1,nsfd
318 IF(abs(sfd(3,i)) < abs(sfd(3,im))) im=i
319 END DO
320 DO i=1,nsfd
321 tlr=' '
322 IF(i == im) tlr='**'
323 IF(i == idgl) tlr(1:1)='L'
324 IF(i == idgr) tlr(2:2)='R'
325 IF(i == 1) THEN
326 WRITE(lun,102) i-1, sfd(1,i),tlr,(sfd(j,i),j=2,4)
327 ELSE
328 ratio=real(abs(sfd(3,i)/sfd(3,1)))
329 WRITE(lun,103) i-1, sfd(1,i),tlr,(sfd(j,i),j=2,4),ratio
330 END IF
331
332 END DO
333 IF(lsinfo == 0) WRITE(lun,*) &
334 'PTLINE: INFO=0 input error (e.g. gradient not negative)'
335 IF(lsinfo == 1) WRITE(lun,*) 'PTLINE: INFO=1 convergence reached'
336 IF(lsinfo == 2) WRITE(lun,*) 'PTLINE: INFO=2 too many function calls'
337 IF(lsinfo == 3) WRITE(lun,*) 'PTLINE: INFO=3 maximum step reached'
338 IF(lsinfo == 4) WRITE(lun,*) 'PTLINE: INFO=4 step too small (< 0.001)'
339 WRITE(lun,*) ' '
340
341101 FORMAT(' i x F(x) F''(X)', &
342 ' minimum F''(X)')
343102 FORMAT(i3,f12.6,1x,a2,g15.6,g14.6,f12.6,' ratio')
344103 FORMAT(i3,f12.6,1x,a2,g15.6,g14.6,f12.6,f10.3)
345
346END SUBROUTINE ptlprt
347
subroutine ptlopt(nf, m, slopes, steps)
Get details.
Definition: linesrch.f90:259
subroutine ptline(n, x, f, g, s, step, info)
Perform linesearch.
Definition: linesrch.f90:90
subroutine ptldef(gtole, stmax, minfe, maxfe)
Initialize line search.
Definition: linesrch.f90:233
subroutine ptlprt(lunp)
Print line search data.
Definition: linesrch.f90:295
Line search data.
Definition: linesrch.f90:52
real(mpd) gtol
slope ratio
Definition: linesrch.f90:67
integer(mpi) minf
min.
Definition: linesrch.f90:62
integer(mpi) nsfd
number of function calls
Definition: linesrch.f90:58
integer(mpi) maxf
max.
Definition: linesrch.f90:63
integer(mpi) idgm
index of minimal slope
Definition: linesrch.f90:61
real(mpd), dimension(4, msfd) sfd
abscissa; function value; slope; predicted zero
Definition: linesrch.f90:65
integer(mpi) lsinfo
(status) information
Definition: linesrch.f90:64
integer(mpi) idgr
index of smallest positive slope
Definition: linesrch.f90:60
integer(mpi) idgl
index of smallest negative slope
Definition: linesrch.f90:59
integer(mpi), parameter msfd
Definition: linesrch.f90:57
real(mpd) stmx
maximum slope ratio
Definition: linesrch.f90:66
Definition of constants.
Definition: mpdef.f90:24
integer, parameter mpd
double precision
Definition: mpdef.f90:38