* * $Id$ * * $Log$ * Revision 1.1.1.1 1996/04/01 15:03:26 mclareni * Mathlib gen * * #include "gen/pilot.h" SUBROUTINE BNDOPT (N,XMIN,XMAX,XLOW,XHI,FMIN,FMAX,FLOBD,FUPBD,X,XT 1EMP,GFREE,PFREE,GACTV,GNEW,AHESS,DELTA,FTOL,GTOL,ETA,ALFMAX,MAXFUN 2,NFCNT,IFREE,IACTV,IPRINT,IRESLT) INTEGER N, MAXFUN, NFCNT, IPRINT, IRESLT INTEGER IFREE(N), IACTV(N) DOUBLE PRECISION FMIN, FMAX, FLOBD, FUPBD, DELTA, FTOL, GTOL, 1 ETA, ALFMAX DOUBLE PRECISION XMIN(N), XMAX(N), XLOW(N), XHI(N), X(N), 1 XTEMP(N), GFREE(N), PFREE(N), GACTV(N), GNEW(N), 2 AHESS(N,N) INTEGER I, IBDEL, IBTRUE, IDNEW, II, IIMIN, ILOC, INEW, IPCNT, 1 ITER, ITEST, J, NACTV, NADIM, NFREE LOGICAL LOCAL, NEGMUL, XALTER DOUBLE PRECISION A, ALPHA, ALRAT, B, BTOL, B1, D, DEL, DFUN, 1 DVDOT, DXNORM, E, EPSMCH, FA, FBD, FBEST, FDIFF, 2 FOLD, FRAT, FTEST, FTRUE, FU, FV, FW, FY, FZ, 3 GNORM, GTEST1, GTEST2, GTP, GU, OLDF, PE, 4 PNORM, QEPS, R, RR, RTEPS, SCXBD, SFTBND, SS, 5 STEPMX, T, TOL, U, XBEST, XLAMDA, XNORM, XRAT, 6 XV, XW, ZTOL1, ZTOL2 DATA EPSMCH/2.22D-16/ RTEPS=SQRT(EPSMCH) QEPS=SQRT(RTEPS) ZTOL1=ABS(FTOL) NADIM=N NFCNT=0 DO 10 I=1,N IFREE(I)=0 IACTV(I)=0 10 CONTINUE IF(IPRINT.LT.0) GOTO 20 WRITE(6,310) WRITE(6,320) (XLOW(I),I=1,N) WRITE(6,330) (XHI(I),I=1,N) 20 DO 300 IIMIN=1,2 IF(IIMIN.EQ.2) GOTO 30 CALL DVCOPY(N,XMIN,X) FTRUE=FMIN FBEST=FTRUE FBD=FLOBD GOTO 40 30 CALL DVCOPY(N,XMAX,X) FTRUE=FMAX FBEST=-FTRUE FBD=FUPBD 40 ITER=0 GNORM=0.0D+0 IPCNT=0 FOLD=FBEST LOCAL=.FALSE. DO 60 J=1,N DO 50 I=1,N AHESS(I,J)=0.0D+0 50 CONTINUE AHESS(J,J)=1.0D+0 60 CONTINUE BTOL=QEPS 70 CALL BNDTST(N,X,XLOW,XHI,BTOL,NFREE,IFREE,NACTV,IACTV,XALTER) IF(.NOT.XALTER) GOTO 80 FTRUE=DFUN(N,X) FBEST=FTRUE IF(IIMIN.EQ.2) FBEST=-FTRUE FOLD=FBEST 80 IF(IPRINT.LT.0) GOTO 90 IF(IIMIN.EQ.1) WRITE(6,340) FTRUE IF(IIMIN.EQ.2) WRITE(6,350) FTRUE IF(LOCAL) WRITE(6,450) NFCNT WRITE(6,360) (X(I),I=1,N) WRITE(6,370) NFREE,NACTV IF(NFREE.GT.0.AND.NFREE.LT.N) WRITE(6,380) (IFREE(I),I=1,NFREE) IF(NACTV.GT.0.AND.NACTV.LT.N) WRITE(6,390) (IACTV(I),I=1,NACTV) 90 FTEST=RTEPS*(1.0D+0+ABS(FBD)) IF(ABS(FBD-FBEST).LT.FTEST) GOTO 250 IF(NFREE.EQ.0) GOTO 250 CALL GRDCMP(N,NFREE,IFREE,X,FTRUE,DELTA,XHI,XTEMP,GFREE) NFCNT=NFCNT+NFREE IF(IIMIN.EQ.1) GOTO 110 DO 100 I=1,NFREE GFREE(I)=-GFREE(I) 100 CONTINUE 110 CALL RLEN(NFREE,GFREE,GNORM) IF(GNORM.GT.GTOL.OR.LOCAL) GOTO 120 IF(IPRINT.GT.0) WRITE(6,440) DEL=DELTA IF(DELTA.LT.1.0D+0) DEL=SQRT(DELTA) ZTOL2=10.0D+0*SQRT(RTEPS*DEL) IF(ZTOL2.LT.RTEPS) ZTOL2=RTEPS LOCAL=.TRUE. CALL LOCSCH(IIMIN,N,NFREE,IFREE,X,FBEST,XLOW,XHI,DEL,ZTOL2,NFCNT, 1GNEW,FY,XTEMP,FZ,PFREE) FTEST=RTEPS*(1.0D+0+ABS(FBEST)) IF(FZ.GE.FBEST.OR.ABS(FZ-FBEST).LT.FTEST) GOTO 250 CALL DVCOPY(N,XTEMP,X) FBEST=FZ FTRUE=FZ IF(IIMIN.EQ.2) FTRUE=-FZ GOTO 70 120 ITER=ITER+1 IF(NFCNT.GT.MAXFUN) GOTO 270 IF(IPCNT.GE.IPRINT) IPCNT=0 IPCNT=IPCNT+1 IF(NFREE.EQ.0) GOTO 250 CALL LDLSOL(NFREE,NADIM,AHESS,GFREE,PFREE) DO 130 I=1,NFREE PFREE(I)=-PFREE(I) 130 CONTINUE CALL RLEN(NFREE,PFREE,PNORM) PE=PNORM+RTEPS CALL FEASMV(N,NFREE,IFREE,X,PFREE,XLOW,XHI,EPSMCH,STEPMX,INEW,IDN 1EW) IF((STEPMX*PE).GT.DELTA) GOTO 140 CALL ADDBND(N,NFREE,IFREE,NACTV,IACTV,INEW,IDNEW,NADIM,AHESS,XTEM 1P,GFREE,GNORM) ITER=ITER-1 GOTO 120 140 GTP=DVDOT(NFREE,GFREE,PFREE) XLAMDA=MIN(STEPMX,ALFMAX) U=MIN(1.0D+0,XLAMDA) FU=FBEST GU=GTP ILOC=1 SFTBND=DELTA/PE T=RTEPS/PE DO 150 I=1,N XTEMP(I)=X(I) 150 CONTINUE 160 CALL NEWPTQ(RTEPS,T,ETA,SFTBND,XLAMDA,U,FU,GU,XBEST,FBEST,XW,FW,X 1V,FV,A,FA,B,OLDF,B1,SCXBD,E,D,RR,SS,GTEST1,GTEST2,TOL,ILOC,ITEST) IF(ITEST.NE.1) GOTO 180 R=XBEST+U DO 170 I=1,NFREE II=IFREE(I) XTEMP(II)=X(II)+R*PFREE(I) 170 CONTINUE FU=DFUN(N,XTEMP) NFCNT=NFCNT+1 IF(IIMIN.EQ.2) FU=-FU GOTO 160 180 IF(ITEST.NE.0) GOTO 250 ALPHA=XBEST DO 190 I=1,NFREE II=IFREE(I) X(II)=X(II)+XBEST*PFREE(I) 190 CONTINUE FTRUE=FBEST IF(IIMIN.EQ.2) FTRUE=-FBEST IF(IPRINT.LE.0.OR.IPCNT.LT.IPRINT) GOTO 200 WRITE(6,400) ITER,NFCNT,FBEST WRITE(6,360) (X(I),I=1,N) WRITE(6,370) NFREE,NACTV IF(NFREE.GT.0.AND.NFREE.LT.N) WRITE(6,380) (IFREE(I),I=1,NFREE) IF(NACTV.GT.0.AND.NACTV.LT.N) WRITE(6,390) (IACTV(I),I=1,NACTV) 200 CALL GRDCMP(N,NFREE,IFREE,X,FTRUE,DELTA,XHI,XTEMP,GNEW) CALL RLEN(NFREE,GNEW,GNORM) IF(IPRINT.GT.0.AND.IPCNT.EQ.IPRINT) WRITE(6,460) GNORM IF(IIMIN.EQ.1) GOTO 220 DO 210 I=1,NFREE GNEW(I)=-GNEW(I) 210 CONTINUE 220 NFCNT=NFCNT+NFREE CALL BFGS(NFREE,NADIM,AHESS,EPSMCH,GFREE,GNEW,PFREE,ALPHA,XTEMP) DO 230 I=1,NFREE GFREE(I)=GNEW(I) 230 CONTINUE ALRAT=ABS(ALPHA-STEPMX)/STEPMX IF(ALRAT.GE.QEPS) GOTO 240 CALL ADDBND(N,NFREE,IFREE,NACTV,IACTV,INEW,IDNEW,NADIM,AHESS,XTEM 1P,GFREE,GNORM) GOTO 120 240 FDIFF=FOLD-FBEST FRAT=FDIFF/(1.0D+0+ABS(FBEST)) IF(FTOL.LT.0.0D+0) FRAT=FDIFF/MAX(ABS(FBEST),EPSMCH) CALL RLEN(N,X,XNORM) DXNORM=ALPHA*PNORM XRAT=DXNORM/(1.0D+0+XNORM) IF(FTOL.LT.0.0D+0) XRAT=DXNORM/MAX(XNORM,EPSMCH) FOLD=FBEST IF(FRAT.GT.ZTOL1.OR.XRAT.GT.ZTOL1) GOTO 120 250 IF(NACTV.EQ.0) GOTO 270 CALL MULCHK(N,NACTV,IACTV,IIMIN,RTEPS,X,XHI,FTRUE,DELTA,XTEMP,GAC 1TV,NEGMUL,IBDEL,IBTRUE) NFCNT=NFCNT+NACTV IF(IPRINT.LE.0.OR.IPCNT.LT.IPRINT) GOTO 260 WRITE(6,420) ITER,NACTV WRITE(6,390) (IACTV(I),I=1,NACTV) WRITE(6,430) (GACTV(I),I=1,NACTV) 260 IF(.NOT.NEGMUL) GOTO 270 CALL DELBND(N,NACTV,IACTV,NFREE,IFREE,IBDEL,IBTRUE,GACTV,NADIM,AH 1ESS,GFREE,GNORM) GOTO 120 270 IF(IPRINT.LT.0) GOTO 280 WRITE(6,410) ITER,NFCNT,FTRUE WRITE(6,360) (X(I),I=1,N) WRITE(6,370) NFREE,NACTV IF(NFREE.GT.0.AND.NFREE.LT.N) WRITE(6,380) (IFREE(I),I=1,NFREE) IF(NACTV.GT.0.AND.NACTV.LT.N) WRITE(6,390) (IACTV(I),I=1,NACTV) 280 IF(IIMIN.EQ.2) GOTO 290 FMIN=FBEST CALL DVCOPY(N,X,XMIN) GOTO 300 290 FMAX=-FBEST CALL DVCOPY(N,X,XMAX) 300 CONTINUE RETURN 310 FORMAT('-START OF OPTIMIZATION') 320 FORMAT(' LOWER BOUNDS', 6(1PD16.6)) 330 FORMAT(' UPPER BOUNDS', 6(1PD16.6)) 340 FORMAT(' MINIMIZATION STEP -- INITIAL FMIN =', 1PD16.6) 350 FORMAT('0MAXIMIZATION STEP -- INITIAL FMAX =', 1PD16.6) 360 FORMAT(' X ARRAY'/6(1PD16.6)) 370 FORMAT(1X,I5,' FREE VARIABLES',I5,' FIXED VARIABLES') 380 FORMAT(' INDICES OF FREE VARIABLES'/10I8) 390 FORMAT(' INDICES OF FIXED VARIABLES'/10I8) 400 FORMAT('0 AFTER ITERATION',I5,' AND',I5, 1 ' FUNCTION EVALUATIONS, THE FUNCTION VALUE IS',1PD16.6) 410 FORMAT('0*** FINAL RESULT ***'/' AFTER',I5, 1 ' ITERATIONS AND', I6,' FUNCTION EVALUATIONS', 2 ' THE BEST FUNCTION VALUE IS', 1PD17.7) 420 FORMAT('0 AT ITERATION',I6,' CHECK MULTIPLIERS', 1 ' FOR THE',I5,' FIXED VARIABLES') 430 FORMAT(' GRADIENT WITH RESPECT TO FIXED VARIABLES'/ 1 1X,6(1PD16.6)) 440 FORMAT(' EXECUTE LOCAL SEARCH') 450 FORMAT(1X,I5,' FUNCTION EVALUATIONS AFTER LOCAL SEARCH') 460 FORMAT(' NORM OF PROJECTED GRADIENT =', 1PD16.6) END