174 lines
5.8 KiB
FortranFixed
174 lines
5.8 KiB
FortranFixed
Subroutine mctsglobalmin(ndim,funkmin_nongrad,f1dim_nongrad,
|
|
&beta,betamin,betamax,ftol,fatbeta)
|
|
implicit none
|
|
integer ndim
|
|
double precision beta(ndim),betamin(ndim),betamax(ndim),
|
|
&ftol,fatbeta
|
|
!
|
|
integer i,j,k,n,i2,icompete
|
|
double precision ran2,ftol_relax,term1,term2,beta0(ndim),
|
|
&fatbeta0,history(2000,ndim+3),discount
|
|
external funkmin_nongrad,f1dim_nongrad
|
|
!-----------------------------------------------------
|
|
!the cost funcation value for the first initial guess must be provided!
|
|
do i=1,ndim
|
|
beta0(i)=beta(i)
|
|
history(1,i)=beta(i)
|
|
enddo
|
|
fatbeta0=fatbeta
|
|
history(1,ndim+1)=fatbeta
|
|
!entrance counter
|
|
history(1,ndim+2)=1.0d0
|
|
!failure counter
|
|
history(1,ndim+3)=0.0d0
|
|
!Is it a competition among different initial guesses?
|
|
icompete=0
|
|
!j the total number of calls to nongradopt; k is the number of returns to the current best and reset
|
|
!to zero if a better minumum is found; n is the number of scouting points over the landscape of the cost function.
|
|
!The first initial guess provided by the user is always part of the set of scouting points.the rest consist of outcomes
|
|
!from calls to nongradopt if they are significantly different from the current best.
|
|
j=0
|
|
k=0
|
|
n=1
|
|
ftol_relax=ftol*1000.0d0
|
|
discount=2.0d0
|
|
!relax the convergence criterion for scouting
|
|
30 call nongradopt(ndim,funkmin_nongrad,f1dim_nongrad,
|
|
&beta,betamin,betamax,ftol_relax,fatbeta)
|
|
call funkmin_generic(ndim,beta,fatbeta)
|
|
if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then
|
|
!failure
|
|
if((fatbeta+1.0d0).ne.fatbeta)then
|
|
if((fatbeta-fatbeta0).gt.10.0d0*ftol_relax)then
|
|
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0
|
|
!even though fatbeta is much worse than fatbeta0, it is an output of optimization after all so
|
|
!include it in the set if it has not already been included in the set.
|
|
i=1
|
|
i2=1
|
|
40 if(dabs(history(i2,i)-beta(i)).gt.ftol_relax)then
|
|
if(dabs(history(i2,ndim+1)-fatbeta).lt.ftol_relax)then
|
|
history(i2,ndim+3)=history(i2,ndim+3)+1.0d0
|
|
goto 60
|
|
endif
|
|
if(i2.ge.n)goto 50
|
|
i2=i2+1
|
|
i=1
|
|
goto 40
|
|
else
|
|
if(i.ge.ndim)goto 60
|
|
i=i+1
|
|
goto 40
|
|
endif
|
|
50 n=n+1
|
|
do i=1,ndim
|
|
history(n,i)=beta(i)
|
|
enddo
|
|
history(n,ndim+1)=fatbeta
|
|
history(n,ndim+2)=0.0d0
|
|
history(n,ndim+3)=0.0d0
|
|
else
|
|
!the difference is minimal even though fatbeta is larger than fatbeta0.
|
|
!Increment the counter for arriving at the same minimum.
|
|
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0
|
|
k=k+1
|
|
endif
|
|
else
|
|
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+2.0d0
|
|
endif
|
|
60 do i=1,ndim
|
|
beta(i)=beta0(i)
|
|
enddo
|
|
fatbeta=fatbeta0
|
|
else
|
|
!success
|
|
if((fatbeta0-fatbeta).lt.10.0d0*ftol_relax)then
|
|
!negligible improvement. Increment the counter for arriving at the same minimum.
|
|
!no increment for the set of central initial guesses
|
|
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.1d0
|
|
k=k+1
|
|
else
|
|
!reset the counter for arriving at a better minimum.
|
|
!Increment the set of central initial guesses
|
|
if(dabs(discount-2.0d0).lt.ftol)then
|
|
discount=dmax1(0.001d0,(fatbeta0-fatbeta)/1000.0d0)
|
|
endif
|
|
k=0
|
|
n=n+1
|
|
do i=1,ndim+3
|
|
history(n,i)=history(1,i)
|
|
enddo
|
|
do i=1,ndim
|
|
history(1,i)=beta(i)
|
|
enddo
|
|
history(1,ndim+1)=fatbeta
|
|
history(1,ndim+2)=0.0d0
|
|
history(1,ndim+3)=0.0d0
|
|
endif
|
|
do i=1,ndim
|
|
beta0(i)=beta(i)
|
|
enddo
|
|
fatbeta0=fatbeta
|
|
endif
|
|
j=j+1
|
|
if(j.lt.990.and.k.lt.3)then
|
|
!try different initial guesses
|
|
if(ran2().gt.0.1d0)then
|
|
!guess around the best
|
|
icompete=1
|
|
term1=history(1,ndim+1)+
|
|
&discount*history(1,ndim+2)*history(1,ndim+3)
|
|
do i=2,n
|
|
term2=history(i,ndim+1)+
|
|
&discount*history(i,ndim+2)*history(i,ndim+3)
|
|
if(term2.le.term1)then
|
|
term1=term2
|
|
do i2=1,ndim+3
|
|
history(n+1,i2)=history(i,i2)
|
|
history(i,i2)=history(1,i2)
|
|
history(1,i2)=history(n+1,i2)
|
|
enddo
|
|
endif
|
|
enddo
|
|
term1=0.5d0*history(i,ndim+2)*history(i,ndim+3)
|
|
history(1,ndim+2)=history(1,ndim+2)+1.0d0
|
|
do i=1,ndim
|
|
if(ran2().gt.0.5d0)then
|
|
if((betamax(i)-history(1,i)).gt.
|
|
&(betamax(i)-betamin(i))*1.0d-5)then
|
|
beta(i)=history(1,i)+(ran2()**(4.0d0/(term1+1.0d0)))*
|
|
&(betamax(i)-history(1,i))
|
|
else
|
|
beta(i)=betamax(i)-
|
|
&(ran2()**4.0d0)*(betamax(i)-betamin(i))
|
|
endif
|
|
else
|
|
if((history(1,i)-betamin(i)).gt.
|
|
&(betamax(i)-betamin(i))*1.0d-5)then
|
|
beta(i)=history(1,i)-(ran2()**(4.0d0/(term1+1.0d0)))*
|
|
&(history(1,i)-betamin(i))
|
|
else
|
|
beta(i)=betamin(i)+
|
|
&(ran2()**4.0d0)*(betamax(i)-betamin(i))
|
|
endif
|
|
endif
|
|
enddo
|
|
else
|
|
!completely random guess
|
|
icompete=0
|
|
do i=1,ndim
|
|
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
|
|
enddo
|
|
endif
|
|
call funkmin_generic(ndim,beta,fatbeta)
|
|
goto 30
|
|
else
|
|
if((ftol_relax-ftol).gt.ftol)then
|
|
ftol_relax=ftol
|
|
if(k.le.1)j=0
|
|
goto 30
|
|
endif
|
|
endif
|
|
return
|
|
end subroutine mctsglobalmin
|
|
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|