dirsubrout.f

优化问题中的直接搜索法

        END IF
10    CONTINUE
      DO 20,i = 1,n
        IF (length(pos,i) .EQ. help) THEN
           ArrayI(j) = i
           j = j + 1
        END IF
20    CONTINUE
      maxi = j - 1
      END

C+-----------------------------------------------------------------------+
C|    SUBROUTINE DIRInitList                                             |
C|    Initialise the list.                                               |
C+-----------------------------------------------------------------------+
      SUBROUTINE DIRInitList(anchor,free,point,f,maxfunc,maxdeep)
      IMPLICIT None
      Integer maxdeep,maxfunc
      Double Precision f(maxfunc,2)
C   f -- values of functions.
      Integer anchor(-1:maxdeep)
C   anchor -- anchors of lists with deep i
      Integer point(maxfunc), free
C   point -- lists
C   free  -- first free position
      Integer i

      DO 10,i = -1,maxdeep
        anchor(i) = 0
10    CONTINUE
      DO 20,i = 1,maxfunc
        f(i,1) = 0.D0
        f(i,2) = 0
        point(i) = i + 1
C       point(i) = 0
20    CONTINUE
      point(maxfunc) = 0
      free = 1
      END


C+-----------------------------------------------------------------------+
C|    SUBROUTINE DIRInsert3                                              |
C+-----------------------------------------------------------------------+
         SUBROUTINE DIRInsert3(pos1,pos2,pos3,deep,anchor,point,free,
     +                   f,fmin,minpos,maxfunc,maxdeep)
      IMPLICIT None
      INTEGER maxfunc,maxdeep
      INTEGER deep,free,pos1,pos2,pos3
      INTEGER anchor(-1:maxdeep),point(maxfunc)
      Double Precision f(maxfunc,2),fmin
      INTEGER pos,minpos

      CALL DIRSort3(pos1,pos2,pos3,f,maxfunc)
      IF (anchor(deep) .EQ. 0) THEN
        anchor(deep) = pos1
        point(pos1) = pos2
        point(pos2) = pos3
        point(pos3) = 0
      ELSE
        pos = anchor(deep)
        IF (f(pos1,1) .LT. f(pos,1)) THEN
          anchor(deep) = pos1
          point(pos1) = pos
        ELSE
          CALL DIRInsert(pos,pos1,point,f,maxfunc)
        END IF
        CALL DIRInsert(pos,pos2,point,f,maxfunc)
        CALL DIRInsert(pos,pos3,point,f,maxfunc)	  	
      END IF
        IF ((f(pos1,1) .LT. fmin) .and. (f(pos1,2) .eq. 0)) THEN
           fmin = f(pos1,1)
           minpos = pos1
        END IF
      END

C+-----------------------------------------------------------------------+
C|    SUBROUTINE DIRInsert                                               |
C+-----------------------------------------------------------------------+
      SUBROUTINE DIRInsert(start,ins,point,f,maxfunc)
      IMPLICIT None
      INTEGER maxfunc,start,ins
      INTEGER point(maxfunc)
      Double Precision f(maxfunc,2)
      INTEGER i,help

C JG 09/17/00 Rewrote this routine.      
C      DO 10,i = 1,maxfunc
C        IF (f(ins,1) .LT. f(point(start),1)) THEN
C          help = point(start)
C          point(start) = ins
C          point(ins) = help
C          GOTO 20
C        END IF
C        IF (point(start) .EQ. 0) THEN
C           point(start) = ins
C           point(ins) = 0
C           GOTO 20
C        END IF
C        start = point(start)   
C10    CONTINUE
C20    END
      DO 10,i = 1,maxfunc
        IF (point(start) .EQ. 0) THEN
           point(start) = ins
           point(ins) = 0
           GOTO 20
        ELSE
          IF (f(ins,1) .LT. f(point(start),1)) THEN
            help = point(start)
            point(start) = ins
            point(ins) = help
            GOTO 20
          END IF
        END IF
        start = point(start)   
10    CONTINUE
20    END

C+-----------------------------------------------------------------------+
C|    SUBROUTINE DIRSort3                                                |
C+-----------------------------------------------------------------------+
      SUBROUTINE DIRSort3(pos1,pos2,pos3,f,maxfunc)
      IMPLICIT None
      INTEGER maxfunc
      Double Precision f(maxfunc,2)
      INTEGER pos1,pos2,pos3,help

      IF (f(pos1,1) .LT. f(pos2,1)) THEN
         IF (f(pos1,1) .LT. f(pos3,1)) THEN
           IF (f(pos3,1) .LT. f(pos2,1)) THEN
             help = pos2
             pos2 = pos3
             pos3 = help
           END IF
         ELSE
           help = pos1
           pos1 = pos3
           pos3 = pos2
           pos2 = help
         END IF 
      ELSE 
         IF (f(pos2,1) .LT. f(pos3,1)) THEN
           IF (f(pos3,1) .LT. f(pos1,1)) THEN
             help = pos1
             pos1 = pos2
             pos2 = pos3
             pos3 = help
           ELSE
             help = pos1
             pos1 = pos2
             pos2 = help
           END IF
         ELSE
           help = pos1
           pos1 = pos3
           pos3 = help
         END IF
      END IF
      END

C+-----------------------------------------------------------------------+
C|                                                                       |
C|                       SUBROUTINE DIRPREPRC                            |
C|                                                                       |
C| Subroutine DIRpreprc uses an afine mapping to map the hyper-box given |
C| by the constraints on the variable x onto the n-dimensional unit cube.|
C| This mapping is done using the following equation:                    |
C|                                                                       |
C|               x(i)=x(i)/(u(i)-l(i))-l(i)/(u(i)-l(i)).                 |
C|                                                                       |
C| DIRpreprc checks if the bounds l and u are well-defined. That is, if  |
C|                                                                       |
C|               l(i) < u(i) forevery i.                                 |
C|                                                                       |
C| On entry                                                              |
C|                                                                       |
C|          u -- A double-precision vector of length n. The vector       |
C|               containing the upper bounds for the n independent       |
C|               variables.                                              |
C|                                                                       |
C|          l -- A double-precision vector of length n. The vector       |
C|               containing the lower bounds for the n independent       |
C|               variables.                                              |
C|                                                                       |
C|          n -- An integer. The dimension of the problem.               |
C|                                                                       |
C| On return                                                             |
C|                                                                       |
C|        xs1 -- A double-precision vector of length n, used for scaling |
C|               and unscaling the vector x.                             |
C|                                                                       |
C|        xs2 -- A double-precision vector of length n, used for scaling |
C|               and unscaling the vector x.                             |
C|                                                                       |
C|                                                                       |
C|       oops -- An integer. If an upper bound is less than a lower      |
C|               bound or if the initial point is not in the             |
C|               hyper-box oops is set to 1 and iffco terminates.        |
C|                                                                       |
C+-----------------------------------------------------------------------+
      subroutine DIRpreprc(u,l,n,xs1,xs2,oops)

        integer n,i,oops

        Double Precision u(n),l(n),xs1(n),xs2(n)
        Double Precision help


        oops=0

        do 20 i=1,n

C+-----------------------------------------------------------------------+
C| Check if the hyper-box is well-defined.                               |
C+-----------------------------------------------------------------------+
            if(u(i).le.l(i))then
               oops=1
               return
            end if

20    continue

C+-----------------------------------------------------------------------+
C| Scale the initial iterate so that it is in the unit cube.             |
C+-----------------------------------------------------------------------+
      do 50 i=1,n
            help=(u(i)-l(i))
            xs2(i)=l(i)/help
            xs1(i)=help
 50     continue
      
        return
        end

C+-----------------------------------------------------------------------+
C|                                                                       |
C|                       SUBROUTINE DIRINFCN                             |
C|                                                                       |
C| Subroutine DIRinfcn unscales the variable x for use in the            |
C| user-supplied function evaluation subroutine fcn. After fcn returns   |
C| to DIRinfcn, DIRinfcn then rescales x for use by DIRECT.              |
C|                                                                       |
C| On entry                                                              |
C|                                                                       |
C|        fcn -- The argument containing the name of the user-supplied   |
C|               subroutine that returns values for the function to be   |
C|               minimized.                                              |
C|                                                                       |
C|          x -- A double-precision vector of length n. The point at     |
C|               which the derivative is to be evaluated.                |
C|                                                                       |
C|        xs1 -- A double-precision vector of length n. Used for         |
C|               scaling and unscaling the vector x by DIRinfcn.         |
C|                                                                       |
C|        xs2 -- A double-precision vector of length n. Used for         |
C|               scaling and unscaling the vector x by DIRinfcn.         |
C|                                                                       |
C|          n -- An integer. The dimension of the problem.               |
C|       kret -- An Integer. If kret =  1, the point is infeasible,      |
C|                              kret = -1, bad problem set up,           |
C|                              kret =  0, feasible.                     |
C|                                                                       |
C| On return                                                             |
C|                                                                       |
C|          f -- A double-precision scalar.                              |
C|                                                                       |
C| Subroutines and Functions                                             |
C|                                                                       |
C| The subroutine whose name is passed through the argument fcn.         |
C|                                                                       |
C+-----------------------------------------------------------------------+
      subroutine DIRinfcn(fcn,x,c1,c2,n,f,flag,
     +                  iidata, iisize, ddata, idsize, cdata, icsize)

      implicit none
      integer n,i, flag

      Double Precision x(n),c1(n),c2(n),f
      EXTERNAL fcn
C+-----------------------------------------------------------------------+
C| Variables to pass user defined data to the function to be optimized.  |
C+-----------------------------------------------------------------------+
      INTEGER iisize, idsize, icsize
      INTEGER iidata(iisize)
      Double Precision ddata(idsize)
      Character*40 cdata(icsize)


C+-----------------------------------------------------------------------+
C| Unscale the variable x.                                               |
C+-----------------------------------------------------------------------+
      do 20 i=1,n
        x(i)=(x(i)+c2(i))*c1(i)
20    continue
C+-----------------------------------------------------------------------+
C| Call the function-evaluation subroutine fcn.                          |
C+-----------------------------------------------------------------------+
      f = 0.D0
      CALL fcn(n,x,f,flag,iidata, iisize, ddata, idsize, cdata, icsize)

C+-----------------------------------------------------------------------+