416 lines
11 KiB
FortranFixed
416 lines
11 KiB
FortranFixed
subroutine nongradopt(ndim,funkmin,f1dim,beta,
|
|
& bmin,bmax,ftol,fatbeta)
|
|
implicit none
|
|
! This subroutine minimizes function funkmin to estimate ndim parameters
|
|
! using non-gradient based methods
|
|
!
|
|
integer ndim
|
|
double precision beta(1:ndim),bmin(1:ndim),
|
|
&bmax(1:ndim),ftol,fatbeta,f1dim
|
|
!
|
|
! ------------------ Inputs -----------------------------
|
|
! ndim: the total number of parameters to be estimated
|
|
! bmax: the maximum possible value of beta, used to determine the distance scaling factor
|
|
! bmin: the minimum possible value of beta, used to determine the distance scaling factor
|
|
! beta: initial guess, overwritten upon return
|
|
! ftol: tolerance for convergence
|
|
! fatbeta: the cost function valuate at beta, overwritten upon return
|
|
! funkmin is the name of the subroutine that computes the cost function
|
|
! f1dim: the one dimensional cost function
|
|
|
|
! ------------------ Outputs ----------------------------
|
|
! beta: The best parameters obtained
|
|
! fatbeta: the cost function value at beta
|
|
|
|
integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX,
|
|
& icycle
|
|
parameter(maxredo=5,ITMAX=50000)
|
|
double precision fbest,xbest(1:ndim),term,
|
|
& xinidir(1:ndim,1:ndim),xbest0(1:ndim),
|
|
& pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1)
|
|
external funkmin,f1dim
|
|
! End of declaration of variables
|
|
!---------------------------------------------------------------
|
|
icycle=0
|
|
1 iredo=0
|
|
3 do n=1,ndim
|
|
xbest(n)=beta(n)
|
|
do nn=1,ndim
|
|
xinidir(n,nn)=0.0d0
|
|
enddo
|
|
xinidir(n,n)=1.0d0
|
|
enddo
|
|
fbest=fatbeta
|
|
call powell(beta,xinidir(1:ndim,1:ndim),ndim,ndim,
|
|
& ftol,fatbeta,bmin,bmax,funkmin,f1dim,ITMAX)
|
|
if(fatbeta.gt.fbest)then
|
|
do n=1,ndim
|
|
beta(n)=xbest(n)
|
|
enddo
|
|
fatbeta=fbest
|
|
goto 10
|
|
endif
|
|
if((fbest-fatbeta).gt.100.0d0*ftol)then
|
|
if(iredo.gt.maxredo)goto 10
|
|
iredo=iredo+1
|
|
goto 3
|
|
endif
|
|
10 iredo=0
|
|
20 do n=1,ndim
|
|
xbest(n)=beta(n)
|
|
enddo
|
|
fbest=fatbeta
|
|
do nn=1,ndim
|
|
pamoeba(1,nn)=beta(nn)
|
|
enddo
|
|
famoeba(1)=fatbeta
|
|
do n=2,ndim+1
|
|
do nn=1,ndim
|
|
pamoeba(n,nn)=beta(nn)
|
|
enddo
|
|
if((bmax(n-1)-pamoeba(n,n-1))
|
|
& .gt.(pamoeba(n,n-1)-bmin(n-1)))then
|
|
pamoeba(n,n-1)=pamoeba(n,n-1)+
|
|
& (bmax(n-1)-pamoeba(n,n-1))*0.1d0
|
|
else
|
|
pamoeba(n,n-1)=pamoeba(n,n-1)-
|
|
& (pamoeba(n,n-1)-bmin(n-1))*0.1d0
|
|
endif
|
|
do nn=1,ndim
|
|
xbest0(nn)=pamoeba(n,nn)
|
|
enddo
|
|
call funkmin(ndim,xbest0,famoeba(n))
|
|
enddo
|
|
mpamoeba=ndim+1
|
|
npamoeba=ndim
|
|
fatbeta=1.0d+100
|
|
term=1.0d0
|
|
30 nn=ITMAX/20
|
|
call amebsa(pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1),
|
|
&mpamoeba,npamoeba,ndim,beta,fatbeta,ftol,funkmin,nn,term)
|
|
if(fatbeta.lt.fbest)then
|
|
if((fbest-fatbeta).gt.ftol*100.0d0.and.term.gt.1.0d-2)then
|
|
term=term/3.0d0
|
|
fbest=fatbeta
|
|
do n=1,ndim
|
|
xbest(n)=beta(n)
|
|
enddo
|
|
goto 30
|
|
endif
|
|
do n=1,ndim
|
|
xbest(n)=beta(n)
|
|
enddo
|
|
fbest=fatbeta
|
|
else
|
|
do n=1,ndim
|
|
beta(n)=xbest(n)
|
|
enddo
|
|
fatbeta=fbest
|
|
endif
|
|
do nn=1,ndim
|
|
pamoeba(1,nn)=beta(nn)
|
|
enddo
|
|
famoeba(1)=fatbeta
|
|
do n=2,ndim+1
|
|
do nn=1,ndim
|
|
pamoeba(n,nn)=beta(nn)
|
|
enddo
|
|
if((bmax(n-1)-pamoeba(n,n-1))
|
|
& .gt.(pamoeba(n,n-1)-bmin(n-1)))then
|
|
pamoeba(n,n-1)=pamoeba(n,n-1)+
|
|
& (bmax(n-1)-pamoeba(n,n-1))*0.1d0
|
|
else
|
|
pamoeba(n,n-1)=pamoeba(n,n-1)-
|
|
& (pamoeba(n,n-1)-bmin(n-1))*0.1d0
|
|
endif
|
|
do nn=1,ndim
|
|
xbest0(nn)=pamoeba(n,nn)
|
|
enddo
|
|
call funkmin(ndim,xbest0,famoeba(n))
|
|
enddo
|
|
mpamoeba=ndim+1
|
|
npamoeba=ndim
|
|
call guamoeba(pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1),
|
|
&mpamoeba,npamoeba,ndim,ftol,funkmin,ITMAX/20)
|
|
nn=1
|
|
do n=2,ndim+1
|
|
if(famoeba(n).lt.famoeba(nn))nn=n
|
|
enddo
|
|
fatbeta=famoeba(nn)
|
|
do n=1,ndim
|
|
beta(n)=pamoeba(nn,n)
|
|
if(beta(n).lt.bmin(n).or.beta(n).gt.bmax(n))then
|
|
do nn=1,ndim
|
|
beta(nn)=xbest(nn)
|
|
enddo
|
|
fatbeta=fbest
|
|
return
|
|
endif
|
|
enddo
|
|
if((fbest-fatbeta).gt.ftol*100.0d0)then
|
|
if(iredo.gt.maxredo)then
|
|
if(icycle.lt.maxredo)then
|
|
icycle=icycle+1
|
|
goto 1
|
|
else
|
|
return
|
|
endif
|
|
endif
|
|
iredo=iredo+1
|
|
goto 20
|
|
endif
|
|
return
|
|
end subroutine nongradopt
|
|
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
|
SUBROUTINE guamoeba(p,y,mp,np,ndim,ftol,funkmin,ITMAX)
|
|
implicit none
|
|
INTEGER iter,mp,ndim,np,NMAX,ITMAX
|
|
double precision ftol,p(mp,np),y(mp),TINY
|
|
PARAMETER (TINY=1.0d-10)
|
|
external funkmin
|
|
CU USES guamotry,funkmin
|
|
INTEGER i,ihi,ilo,inhi,j,m,n
|
|
double precision rtol,cumx,swap,ysave,ytry,pcumx(ndim),
|
|
& guamotry,degen
|
|
iter=0
|
|
1 do 12 n=1,ndim
|
|
cumx=0.0d0
|
|
do 11 m=1,ndim+1
|
|
cumx=cumx+p(m,n)
|
|
11 continue
|
|
pcumx(n)=cumx
|
|
12 continue
|
|
2 ilo=1
|
|
if (y(1).gt.y(2)) then
|
|
ihi=1
|
|
inhi=2
|
|
else
|
|
ihi=2
|
|
inhi=1
|
|
endif
|
|
do 13 i=1,ndim+1
|
|
if(y(i).le.y(ilo)) ilo=i
|
|
if(y(i).gt.y(ihi)) then
|
|
inhi=ihi
|
|
ihi=i
|
|
else if(y(i).gt.y(inhi)) then
|
|
if(i.ne.ihi) inhi=i
|
|
endif
|
|
13 continue
|
|
rtol=2.0d0*dabs(y(ihi)-y(ilo))/
|
|
& (dabs(y(ihi))+dabs(y(ilo))+TINY)
|
|
if (rtol.lt.ftol) then
|
|
swap=y(1)
|
|
y(1)=y(ilo)
|
|
y(ilo)=swap
|
|
do 14 n=1,ndim
|
|
swap=p(1,n)
|
|
p(1,n)=p(ilo,n)
|
|
p(ilo,n)=swap
|
|
14 continue
|
|
return
|
|
endif
|
|
|
|
! check to see if the simplex is degenerate; if so, stop
|
|
degen=0.0d0
|
|
do i=1,mp
|
|
do m=i+1,mp
|
|
do n=1,np
|
|
if(dabs(p(m,n)-p(i,n)).gt.degen)then
|
|
degen=dabs(p(m,n)-p(i,n))
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
if(degen.lt.ftol*ftol)then
|
|
swap=y(1)
|
|
y(1)=y(ilo)
|
|
y(ilo)=swap
|
|
do n=1,ndim
|
|
swap=p(1,n)
|
|
p(1,n)=p(ilo,n)
|
|
p(ilo,n)=swap
|
|
enddo
|
|
return
|
|
endif
|
|
if(iter.ge.ITMAX)return
|
|
iter=iter+2
|
|
ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,-1.0d0)
|
|
if (ytry.le.y(ilo))then
|
|
ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,2.0d0)
|
|
else if (ytry.ge.y(inhi)) then
|
|
ysave=y(ihi)
|
|
ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,0.5d0)
|
|
if (ytry.ge.ysave) then
|
|
do 16 i=1,ndim+1
|
|
if(i.ne.ilo)then
|
|
do 15 j=1,ndim
|
|
pcumx(j)=0.5d0*(p(i,j)+p(ilo,j))
|
|
p(i,j)=pcumx(j)
|
|
15 continue
|
|
call funkmin(ndim,pcumx,y(i))
|
|
endif
|
|
16 continue
|
|
iter=iter+ndim
|
|
goto 1
|
|
endif
|
|
else
|
|
iter=iter-1
|
|
endif
|
|
goto 2
|
|
END
|
|
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
|
|
|
DOUBLE PRECISION FUNCTION guamotry(p,y,psum,
|
|
& mp,np,ndim,funkmin,ihi,fac)
|
|
implicit none
|
|
INTEGER ihi,mp,ndim,np
|
|
double precision fac,p(mp,np),psum(np),y(mp)
|
|
EXTERNAL funkmin
|
|
CU USES funkmin
|
|
INTEGER j
|
|
double precision fac1,fac2,ytry,ptry(ndim)
|
|
fac1=(1.0d0-fac)/dble(ndim)
|
|
fac2=fac1-fac
|
|
do 11 j=1,ndim
|
|
ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
|
|
11 continue
|
|
call funkmin(ndim,ptry,ytry)
|
|
if (ytry.lt.y(ihi)) then
|
|
y(ihi)=ytry
|
|
do 12 j=1,ndim
|
|
psum(j)=psum(j)-p(ihi,j)+ptry(j)
|
|
p(ihi,j)=ptry(j)
|
|
12 continue
|
|
endif
|
|
guamotry=ytry
|
|
return
|
|
END
|
|
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
|
|
|
c#######################################################################
|
|
|
|
SUBROUTINE amebsa(p,y,mp,np,ndim,pb,yb,ftol,funkmin,iter,temptr)
|
|
implicit none
|
|
INTEGER iter,mp,ndim,np
|
|
double precision ftol,temptr,yb,p(mp,np),pb(np),y(mp)
|
|
EXTERNAL funkmin
|
|
CU USES amotsa,funkmin,ran1
|
|
INTEGER i,idum,ihi,ilo,inhi,j,m,n
|
|
double precision rtol,sum,swap,tt,yhi,ylo,ynhi,ysave,yt,ytry,
|
|
&psum(ndim),amotsa,ran1
|
|
COMMON /ambsa/ tt,idum
|
|
tt=-temptr
|
|
1 do 12 n=1,ndim
|
|
sum=0.0d0
|
|
do 11 m=1,ndim+1
|
|
sum=sum+p(m,n)
|
|
11 continue
|
|
psum(n)=sum
|
|
12 continue
|
|
2 ilo=1
|
|
inhi=1
|
|
ihi=2
|
|
ylo=y(1)+tt*dlog(ran1(idum))
|
|
ynhi=ylo
|
|
yhi=y(2)+tt*dlog(ran1(idum))
|
|
if (ylo.gt.yhi) then
|
|
ihi=1
|
|
inhi=2
|
|
ilo=2
|
|
ynhi=yhi
|
|
yhi=ylo
|
|
ylo=ynhi
|
|
endif
|
|
do 13 i=3,ndim+1
|
|
yt=y(i)+tt*dlog(ran1(idum))
|
|
if(yt.le.ylo) then
|
|
ilo=i
|
|
ylo=yt
|
|
endif
|
|
if(yt.gt.yhi) then
|
|
inhi=ihi
|
|
ynhi=yhi
|
|
ihi=i
|
|
yhi=yt
|
|
else if(yt.gt.ynhi) then
|
|
inhi=i
|
|
ynhi=yt
|
|
endif
|
|
13 continue
|
|
rtol=2.0d0*dabs(yhi-ylo)/(dabs(yhi)+dabs(ylo))
|
|
if(rtol.lt.ftol.or.iter.lt.0) then
|
|
swap=y(1)
|
|
y(1)=y(ilo)
|
|
y(ilo)=swap
|
|
do 14 n=1,ndim
|
|
swap=p(1,n)
|
|
p(1,n)=p(ilo,n)
|
|
p(ilo,n)=swap
|
|
14 continue
|
|
return
|
|
endif
|
|
iter=iter-2
|
|
ytry=amotsa(p(1:mp,1:np),
|
|
&y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,-1.0d0)
|
|
if (ytry.le.ylo) then
|
|
ytry=amotsa(p(1:mp,1:np),
|
|
&y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,2.0d0)
|
|
else if (ytry.ge.ynhi) then
|
|
ysave=yhi
|
|
ytry=amotsa(p(1:mp,1:np),
|
|
&y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,0.5d0)
|
|
if (ytry.ge.ysave) then
|
|
do 16 i=1,ndim+1
|
|
if(i.ne.ilo)then
|
|
do 15 j=1,ndim
|
|
psum(j)=0.5d0*(p(i,j)+p(ilo,j))
|
|
p(i,j)=psum(j)
|
|
15 continue
|
|
call funkmin(ndim,psum,y(i))
|
|
endif
|
|
16 continue
|
|
iter=iter-ndim
|
|
goto 1
|
|
endif
|
|
else
|
|
iter=iter+1
|
|
endif
|
|
goto 2
|
|
END
|
|
|
|
double precision FUNCTION amotsa
|
|
&(p,y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,fac)
|
|
implicit none
|
|
INTEGER ihi,mp,ndim,np
|
|
double precision fac,yb,yhi,p(mp,np),pb(np),psum(ndim),y(mp)
|
|
EXTERNAL funkmin
|
|
CU USES funkmin,ran1
|
|
INTEGER idum,j
|
|
double precision fac1,fac2,tt,yflu,ytry,ptry(ndim),ran1
|
|
COMMON /ambsa/ tt,idum
|
|
fac1=(1.0d0-fac)/dble(ndim)
|
|
fac2=fac1-fac
|
|
do 11 j=1,ndim
|
|
ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
|
|
11 continue
|
|
call funkmin(ndim,ptry,ytry)
|
|
if (ytry.le.yb) then
|
|
do 12 j=1,ndim
|
|
pb(j)=ptry(j)
|
|
12 continue
|
|
yb=ytry
|
|
endif
|
|
yflu=ytry-tt*log(ran1(idum))
|
|
if (yflu.lt.yhi) then
|
|
y(ihi)=ytry
|
|
yhi=yflu
|
|
do 13 j=1,ndim
|
|
psum(j)=psum(j)-p(ihi,j)+ptry(j)
|
|
p(ihi,j)=ptry(j)
|
|
13 continue
|
|
endif
|
|
amotsa=yflu
|
|
return
|
|
END
|