New changes from l2g
w
This commit is contained in:
@@ -0,0 +1,173 @@
|
||||
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
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
Reference in New Issue
Block a user