This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / divon / bndopt.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1996/04/01 15:03:26  mclareni
6 * Mathlib gen
7 *
8 *
9 #include "gen/pilot.h"
10       SUBROUTINE BNDOPT (N,XMIN,XMAX,XLOW,XHI,FMIN,FMAX,FLOBD,FUPBD,X,XT
11      1EMP,GFREE,PFREE,GACTV,GNEW,AHESS,DELTA,FTOL,GTOL,ETA,ALFMAX,MAXFUN
12      2,NFCNT,IFREE,IACTV,IPRINT,IRESLT)
13       INTEGER N, MAXFUN, NFCNT, IPRINT, IRESLT
14       INTEGER IFREE(N), IACTV(N)
15       DOUBLE PRECISION FMIN, FMAX, FLOBD, FUPBD, DELTA, FTOL, GTOL,
16      1                 ETA, ALFMAX
17       DOUBLE PRECISION XMIN(N), XMAX(N), XLOW(N), XHI(N), X(N),
18      1                 XTEMP(N), GFREE(N), PFREE(N), GACTV(N), GNEW(N),
19      2                 AHESS(N,N)
20       INTEGER I, IBDEL, IBTRUE, IDNEW, II, IIMIN, ILOC, INEW, IPCNT,
21      1        ITER, ITEST, J, NACTV, NADIM, NFREE
22       LOGICAL LOCAL, NEGMUL, XALTER
23       DOUBLE PRECISION  A, ALPHA, ALRAT, B, BTOL, B1, D, DEL, DFUN,
24      1 DVDOT, DXNORM, E, EPSMCH, FA, FBD, FBEST, FDIFF,
25      2                  FOLD, FRAT, FTEST, FTRUE, FU, FV, FW, FY, FZ,
26      3                  GNORM, GTEST1, GTEST2, GTP, GU, OLDF, PE,
27      4                  PNORM, QEPS, R, RR, RTEPS, SCXBD, SFTBND, SS,
28      5                  STEPMX, T, TOL, U, XBEST, XLAMDA, XNORM, XRAT,
29      6                  XV, XW, ZTOL1, ZTOL2
30       DATA EPSMCH/2.22D-16/
31       RTEPS=SQRT(EPSMCH)
32       QEPS=SQRT(RTEPS)
33       ZTOL1=ABS(FTOL)
34       NADIM=N
35       NFCNT=0
36       DO 10 I=1,N
37       IFREE(I)=0
38       IACTV(I)=0
39  10   CONTINUE
40       IF(IPRINT.LT.0) GOTO 20
41       WRITE(6,310)
42       WRITE(6,320) (XLOW(I),I=1,N)
43       WRITE(6,330) (XHI(I),I=1,N)
44  20   DO 300 IIMIN=1,2
45       IF(IIMIN.EQ.2) GOTO 30
46       CALL DVCOPY(N,XMIN,X)
47       FTRUE=FMIN
48       FBEST=FTRUE
49       FBD=FLOBD
50       GOTO 40
51  30   CALL DVCOPY(N,XMAX,X)
52       FTRUE=FMAX
53       FBEST=-FTRUE
54       FBD=FUPBD
55  40   ITER=0
56       GNORM=0.0D+0
57       IPCNT=0
58       FOLD=FBEST
59       LOCAL=.FALSE.
60       DO 60 J=1,N
61       DO 50 I=1,N
62       AHESS(I,J)=0.0D+0
63  50   CONTINUE
64       AHESS(J,J)=1.0D+0
65  60   CONTINUE
66       BTOL=QEPS
67  70   CALL BNDTST(N,X,XLOW,XHI,BTOL,NFREE,IFREE,NACTV,IACTV,XALTER)
68       IF(.NOT.XALTER) GOTO 80
69       FTRUE=DFUN(N,X)
70       FBEST=FTRUE
71       IF(IIMIN.EQ.2) FBEST=-FTRUE
72       FOLD=FBEST
73  80   IF(IPRINT.LT.0) GOTO 90
74       IF(IIMIN.EQ.1) WRITE(6,340) FTRUE
75       IF(IIMIN.EQ.2) WRITE(6,350) FTRUE
76       IF(LOCAL) WRITE(6,450) NFCNT
77       WRITE(6,360) (X(I),I=1,N)
78       WRITE(6,370) NFREE,NACTV
79       IF(NFREE.GT.0.AND.NFREE.LT.N) WRITE(6,380) (IFREE(I),I=1,NFREE)
80       IF(NACTV.GT.0.AND.NACTV.LT.N) WRITE(6,390) (IACTV(I),I=1,NACTV)
81  90   FTEST=RTEPS*(1.0D+0+ABS(FBD))
82       IF(ABS(FBD-FBEST).LT.FTEST) GOTO 250
83       IF(NFREE.EQ.0) GOTO 250
84       CALL GRDCMP(N,NFREE,IFREE,X,FTRUE,DELTA,XHI,XTEMP,GFREE)
85       NFCNT=NFCNT+NFREE
86       IF(IIMIN.EQ.1) GOTO 110
87       DO 100 I=1,NFREE
88       GFREE(I)=-GFREE(I)
89  100  CONTINUE
90  110  CALL RLEN(NFREE,GFREE,GNORM)
91       IF(GNORM.GT.GTOL.OR.LOCAL) GOTO 120
92       IF(IPRINT.GT.0) WRITE(6,440)
93       DEL=DELTA
94       IF(DELTA.LT.1.0D+0) DEL=SQRT(DELTA)
95       ZTOL2=10.0D+0*SQRT(RTEPS*DEL)
96       IF(ZTOL2.LT.RTEPS) ZTOL2=RTEPS
97       LOCAL=.TRUE.
98       CALL LOCSCH(IIMIN,N,NFREE,IFREE,X,FBEST,XLOW,XHI,DEL,ZTOL2,NFCNT,
99      1GNEW,FY,XTEMP,FZ,PFREE)
100       FTEST=RTEPS*(1.0D+0+ABS(FBEST))
101       IF(FZ.GE.FBEST.OR.ABS(FZ-FBEST).LT.FTEST) GOTO 250
102       CALL DVCOPY(N,XTEMP,X)
103       FBEST=FZ
104       FTRUE=FZ
105       IF(IIMIN.EQ.2) FTRUE=-FZ
106       GOTO 70
107  120  ITER=ITER+1
108       IF(NFCNT.GT.MAXFUN) GOTO 270
109       IF(IPCNT.GE.IPRINT) IPCNT=0
110       IPCNT=IPCNT+1
111       IF(NFREE.EQ.0) GOTO 250
112       CALL LDLSOL(NFREE,NADIM,AHESS,GFREE,PFREE)
113       DO 130 I=1,NFREE
114       PFREE(I)=-PFREE(I)
115  130  CONTINUE
116       CALL RLEN(NFREE,PFREE,PNORM)
117       PE=PNORM+RTEPS
118       CALL FEASMV(N,NFREE,IFREE,X,PFREE,XLOW,XHI,EPSMCH,STEPMX,INEW,IDN
119      1EW)
120       IF((STEPMX*PE).GT.DELTA) GOTO 140
121       CALL ADDBND(N,NFREE,IFREE,NACTV,IACTV,INEW,IDNEW,NADIM,AHESS,XTEM
122      1P,GFREE,GNORM)
123       ITER=ITER-1
124       GOTO 120
125  140  GTP=DVDOT(NFREE,GFREE,PFREE)
126       XLAMDA=MIN(STEPMX,ALFMAX)
127       U=MIN(1.0D+0,XLAMDA)
128       FU=FBEST
129       GU=GTP
130       ILOC=1
131       SFTBND=DELTA/PE
132       T=RTEPS/PE
133       DO 150 I=1,N
134       XTEMP(I)=X(I)
135  150  CONTINUE
136  160  CALL NEWPTQ(RTEPS,T,ETA,SFTBND,XLAMDA,U,FU,GU,XBEST,FBEST,XW,FW,X
137      1V,FV,A,FA,B,OLDF,B1,SCXBD,E,D,RR,SS,GTEST1,GTEST2,TOL,ILOC,ITEST)
138       IF(ITEST.NE.1) GOTO 180
139       R=XBEST+U
140       DO 170 I=1,NFREE
141       II=IFREE(I)
142       XTEMP(II)=X(II)+R*PFREE(I)
143  170  CONTINUE
144       FU=DFUN(N,XTEMP)
145       NFCNT=NFCNT+1
146       IF(IIMIN.EQ.2) FU=-FU
147       GOTO 160
148  180  IF(ITEST.NE.0) GOTO 250
149       ALPHA=XBEST
150       DO 190 I=1,NFREE
151       II=IFREE(I)
152       X(II)=X(II)+XBEST*PFREE(I)
153  190  CONTINUE
154       FTRUE=FBEST
155       IF(IIMIN.EQ.2) FTRUE=-FBEST
156       IF(IPRINT.LE.0.OR.IPCNT.LT.IPRINT) GOTO 200
157       WRITE(6,400) ITER,NFCNT,FBEST
158       WRITE(6,360) (X(I),I=1,N)
159       WRITE(6,370) NFREE,NACTV
160       IF(NFREE.GT.0.AND.NFREE.LT.N) WRITE(6,380) (IFREE(I),I=1,NFREE)
161       IF(NACTV.GT.0.AND.NACTV.LT.N) WRITE(6,390) (IACTV(I),I=1,NACTV)
162  200  CALL GRDCMP(N,NFREE,IFREE,X,FTRUE,DELTA,XHI,XTEMP,GNEW)
163       CALL RLEN(NFREE,GNEW,GNORM)
164       IF(IPRINT.GT.0.AND.IPCNT.EQ.IPRINT) WRITE(6,460) GNORM
165       IF(IIMIN.EQ.1) GOTO 220
166       DO 210 I=1,NFREE
167       GNEW(I)=-GNEW(I)
168  210  CONTINUE
169  220  NFCNT=NFCNT+NFREE
170       CALL BFGS(NFREE,NADIM,AHESS,EPSMCH,GFREE,GNEW,PFREE,ALPHA,XTEMP)
171       DO 230 I=1,NFREE
172       GFREE(I)=GNEW(I)
173  230  CONTINUE
174       ALRAT=ABS(ALPHA-STEPMX)/STEPMX
175       IF(ALRAT.GE.QEPS) GOTO 240
176       CALL ADDBND(N,NFREE,IFREE,NACTV,IACTV,INEW,IDNEW,NADIM,AHESS,XTEM
177      1P,GFREE,GNORM)
178       GOTO 120
179  240  FDIFF=FOLD-FBEST
180       FRAT=FDIFF/(1.0D+0+ABS(FBEST))
181       IF(FTOL.LT.0.0D+0) FRAT=FDIFF/MAX(ABS(FBEST),EPSMCH)
182       CALL RLEN(N,X,XNORM)
183       DXNORM=ALPHA*PNORM
184       XRAT=DXNORM/(1.0D+0+XNORM)
185       IF(FTOL.LT.0.0D+0) XRAT=DXNORM/MAX(XNORM,EPSMCH)
186       FOLD=FBEST
187       IF(FRAT.GT.ZTOL1.OR.XRAT.GT.ZTOL1) GOTO 120
188  250  IF(NACTV.EQ.0) GOTO 270
189       CALL MULCHK(N,NACTV,IACTV,IIMIN,RTEPS,X,XHI,FTRUE,DELTA,XTEMP,GAC
190      1TV,NEGMUL,IBDEL,IBTRUE)
191       NFCNT=NFCNT+NACTV
192       IF(IPRINT.LE.0.OR.IPCNT.LT.IPRINT) GOTO 260
193       WRITE(6,420) ITER,NACTV
194       WRITE(6,390) (IACTV(I),I=1,NACTV)
195       WRITE(6,430) (GACTV(I),I=1,NACTV)
196  260  IF(.NOT.NEGMUL) GOTO 270
197       CALL DELBND(N,NACTV,IACTV,NFREE,IFREE,IBDEL,IBTRUE,GACTV,NADIM,AH
198      1ESS,GFREE,GNORM)
199       GOTO 120
200  270  IF(IPRINT.LT.0) GOTO 280
201       WRITE(6,410) ITER,NFCNT,FTRUE
202       WRITE(6,360) (X(I),I=1,N)
203       WRITE(6,370) NFREE,NACTV
204       IF(NFREE.GT.0.AND.NFREE.LT.N) WRITE(6,380) (IFREE(I),I=1,NFREE)
205       IF(NACTV.GT.0.AND.NACTV.LT.N) WRITE(6,390) (IACTV(I),I=1,NACTV)
206  280  IF(IIMIN.EQ.2) GOTO 290
207       FMIN=FBEST
208       CALL DVCOPY(N,X,XMIN)
209       GOTO 300
210  290  FMAX=-FBEST
211       CALL DVCOPY(N,X,XMAX)
212  300  CONTINUE
213       RETURN
214  310  FORMAT('-START OF OPTIMIZATION')
215  320  FORMAT(' LOWER BOUNDS', 6(1PD16.6))
216  330  FORMAT(' UPPER BOUNDS', 6(1PD16.6))
217  340  FORMAT(' MINIMIZATION STEP -- INITIAL FMIN =', 1PD16.6)
218  350  FORMAT('0MAXIMIZATION STEP -- INITIAL FMAX =', 1PD16.6)
219  360  FORMAT(' X ARRAY'/6(1PD16.6))
220  370  FORMAT(1X,I5,' FREE VARIABLES',I5,' FIXED VARIABLES')
221  380  FORMAT(' INDICES OF FREE  VARIABLES'/10I8)
222  390  FORMAT(' INDICES OF FIXED VARIABLES'/10I8)
223  400  FORMAT('0 AFTER ITERATION',I5,' AND',I5,
224      1  ' FUNCTION EVALUATIONS, THE FUNCTION VALUE IS',1PD16.6)
225  410  FORMAT('0*** FINAL RESULT ***'/' AFTER',I5,
226      1    ' ITERATIONS AND', I6,' FUNCTION EVALUATIONS',
227      2      ' THE BEST FUNCTION VALUE IS', 1PD17.7)
228  420  FORMAT('0 AT ITERATION',I6,' CHECK MULTIPLIERS',
229      1    ' FOR THE',I5,' FIXED VARIABLES')
230  430  FORMAT(' GRADIENT WITH RESPECT TO FIXED VARIABLES'/
231      1             1X,6(1PD16.6))
232  440  FORMAT(' EXECUTE LOCAL SEARCH')
233  450  FORMAT(1X,I5,' FUNCTION EVALUATIONS AFTER LOCAL SEARCH')
234  460  FORMAT(' NORM OF PROJECTED GRADIENT =', 1PD16.6)
235       END