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 !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$