549 lines
14 KiB
FortranFixed
549 lines
14 KiB
FortranFixed
SUBROUTINE powell(p,xi,n,np,ftol,fret,pmin,pmax,
|
|
& funkmin,f1dim,ITMAX)
|
|
! fret must be given on entry
|
|
implicit none
|
|
INTEGER iter,n,np,NMAX,ITMAX
|
|
double precision fret,ftol,p(np),xi(np,np),TINY,
|
|
& pmin(np),pmax(np),f1dim
|
|
PARAMETER (NMAX=1000,TINY=1.0d-25)
|
|
CU USES funkmin,linmin
|
|
INTEGER i,ibig,j
|
|
double precision del,fp,fptt,t,pt(NMAX),
|
|
& ptt(NMAX),xit(NMAX)
|
|
external funkmin,f1dim
|
|
do 11 j=1,n
|
|
pt(j)=p(j)
|
|
11 continue
|
|
iter=0
|
|
1 iter=iter+1
|
|
fp=fret
|
|
ibig=0
|
|
del=0.0d0
|
|
do 13 i=1,n
|
|
do 12 j=1,n
|
|
xit(j)=xi(j,i)
|
|
12 continue
|
|
fptt=fret
|
|
call linmin(p,pmin,pmax,xit,n,f1dim,fret)
|
|
if(fptt-fret.gt.del)then
|
|
del=fptt-fret
|
|
ibig=i
|
|
endif
|
|
13 continue
|
|
if(2.0d0*(fp-fret).le.ftol*(dabs(fp)+dabs(fret))+TINY)return
|
|
if(iter.eq.ITMAX)then
|
|
! write(*,*)'powell exceeding maximum iterations'
|
|
return
|
|
endif
|
|
do 14 j=1,n
|
|
ptt(j)=2.0d0*p(j)-pt(j)
|
|
xit(j)=p(j)-pt(j)
|
|
pt(j)=p(j)
|
|
14 continue
|
|
call funkmin(n,ptt,fptt)
|
|
if(fptt.ge.fp)goto 1
|
|
t=2.0d0*(fp-2.0d0*fret+fptt)*(fp-fret-del)**2-
|
|
& del*(fp-fptt)**2
|
|
if(t.ge.0.0d0)goto 1
|
|
call linmin(p,pmin,pmax,xit,n,f1dim,fret)
|
|
if(ibig.eq.0)return
|
|
do 15 j=1,n
|
|
xi(j,ibig)=xi(j,n)
|
|
xi(j,n)=xit(j)
|
|
15 continue
|
|
goto 1
|
|
END
|
|
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
|
|
|
SUBROUTINE linmin(p,pmin,pmax,xi,n,f1dim,fret)
|
|
implicit none
|
|
INTEGER n
|
|
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n),f1dim
|
|
PARAMETER (TOL=1.0d-8)
|
|
CU USES brent,f1dim,mnbrak
|
|
INTEGER j,k,ierr
|
|
double precision ax,bx,fa,fb,fx,xmin,xx,brent,xxmin,xxmax
|
|
!((((((((((((((((((((((((((((((((((((((((((((((((((((
|
|
!It is essential NMAX must be set to 1000 in f1dim!
|
|
integer NMAX,ncom
|
|
parameter(NMAX=1000)
|
|
double precision pcom(NMAX),xicom(NMAX)
|
|
COMMON /f1com/ pcom,xicom,ncom
|
|
save /f1com/
|
|
!))))))))))))))))))))))))))))))))))))))))))))))))))))
|
|
EXTERNAL f1dim
|
|
ncom=n
|
|
do j=1,n
|
|
pcom(j)=p(j)
|
|
xicom(j)=xi(j)
|
|
enddo
|
|
xxmax=1.0d+100
|
|
xxmin=-1.0d+100
|
|
do j=1,n
|
|
if(xicom(j).gt.1.0d-100)then
|
|
! if(xicom(j).gt.0.0d0)then
|
|
xx=(pmax(j)-pcom(j))/xicom(j)
|
|
ax=(pmin(j)-pcom(j))/xicom(j)
|
|
else
|
|
if(xicom(j).lt.(-1.0d-100))then
|
|
! if(xicom(j).lt.0.0d0)then
|
|
ax=(pmax(j)-pcom(j))/xicom(j)
|
|
xx=(pmin(j)-pcom(j))/xicom(j)
|
|
else
|
|
xx=1.0d+100
|
|
ax=-1.0d+100
|
|
endif
|
|
endif
|
|
if(xxmax.gt.xx)then
|
|
xxmax=xx
|
|
endif
|
|
if(xxmin.lt.ax)then
|
|
xxmin=ax
|
|
endif
|
|
enddo
|
|
ax=0.0d0
|
|
if(dabs(xxmax).gt.dabs(xxmin))then
|
|
xx=0.25d0*xxmax
|
|
else
|
|
xx=0.25d0*xxmin
|
|
endif
|
|
call mnbrak(ax,xx,bx,fa,fx,fb,xxmin,xxmax,ierr,f1dim)
|
|
if(ierr.eq.0)then
|
|
fret=brent(ax,xx,bx,f1dim,TOL,xmin)
|
|
else
|
|
xmin=xx
|
|
fret=fx
|
|
endif
|
|
do 12 j=1,n
|
|
xi(j)=xmin*xi(j)
|
|
p(j)=p(j)+xi(j)
|
|
12 continue
|
|
return
|
|
END
|
|
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
|
!
|
|
!
|
|
double precision function brent(ax,bx,cx,f,tol,xmin)
|
|
INTEGER ITMAX
|
|
double precision ax,bx,cx,tol,xmin,f,CGOLD,ZEPS
|
|
EXTERNAL f
|
|
PARAMETER (ITMAX=10000,CGOLD=.381966d0,ZEPS=1.0d-10)
|
|
INTEGER iter
|
|
double precision a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,
|
|
& tol2,u,v,w,x,xm
|
|
a=dmin1(ax,cx)
|
|
b=dmax1(ax,cx)
|
|
v=bx
|
|
w=v
|
|
x=v
|
|
e=0.0d0
|
|
fx=f(x)
|
|
fv=fx
|
|
fw=fx
|
|
do 11 iter=1,ITMAX
|
|
xm=0.5d0*(a+b)
|
|
tol1=tol*dabs(x)+ZEPS
|
|
tol2=2.0d0*tol1
|
|
if(dabs(x-xm).le.(tol2-.5d0*(b-a))) goto 3
|
|
if(dabs(e).gt.tol1) then
|
|
r=(x-w)*(fx-fv)
|
|
q=(x-v)*(fx-fw)
|
|
p=(x-v)*q-(x-w)*r
|
|
q=2.0d0*(q-r)
|
|
if(q.gt.0.0d0) p=-p
|
|
q=dabs(q)
|
|
etemp=e
|
|
e=d
|
|
if(dabs(p).ge.dabs(.5d0*q*etemp).or.
|
|
& p.le.q*(a-x).or.p.ge.q*(b-x))goto 1
|
|
d=p/q
|
|
u=x+d
|
|
if(u-a.lt.tol2.or.b-u.lt.tol2)d=dsign(tol1,xm-x)
|
|
goto 2
|
|
endif
|
|
1 if(x.ge.xm)then
|
|
e=a-x
|
|
else
|
|
e=b-x
|
|
endif
|
|
d=CGOLD*e
|
|
2 if(dabs(d).ge.tol1) then
|
|
u=x+d
|
|
else
|
|
u=x+dsign(tol1,d)
|
|
endif
|
|
fu=f(u)
|
|
if(fu.le.fx)then
|
|
if(u.ge.x)then
|
|
a=x
|
|
else
|
|
b=x
|
|
endif
|
|
v=w
|
|
fv=fw
|
|
w=x
|
|
fw=fx
|
|
x=u
|
|
fx=fu
|
|
else
|
|
if(u.lt.x) then
|
|
a=u
|
|
else
|
|
b=u
|
|
endif
|
|
if(fu.le.fw.or.w.eq.x)then
|
|
v=w
|
|
fv=fw
|
|
w=u
|
|
fw=fu
|
|
else if(fu.le.fv.or.v.eq.x.or.v.eq.w)then
|
|
v=u
|
|
fv=fu
|
|
endif
|
|
endif
|
|
11 continue
|
|
! write(*,*) 'brent exceed maximum iterations'
|
|
3 xmin=x
|
|
brent=fx
|
|
return
|
|
END
|
|
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
|
|
|
! double precision function f1dim(x)
|
|
! implicit none
|
|
! double precision x
|
|
!CU USES funkmin
|
|
! INTEGER j
|
|
!
|
|
!((((((((((((((((((((((((((((((((((((((((((((((((((((
|
|
! integer NMAX,ncom
|
|
! parameter(NMAX=1000)
|
|
! double precision pcom(NMAX),xicom(NMAX)
|
|
! COMMON /f1com/ pcom,xicom,ncom
|
|
! save /f1com/
|
|
!))))))))))))))))))))))))))))))))))))))))))))))))))))
|
|
! double precision xt(NMAX)
|
|
! do 11 j=1,ncom
|
|
! xt(j)=pcom(j)+x*xicom(j)
|
|
!11 continue
|
|
! call funkmin(ncom,xt,f1dim)
|
|
! return
|
|
! END
|
|
!C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
|
|
|
SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax,
|
|
& ierr,func)
|
|
implicit none
|
|
double precision ax,bx,cx,fa,fb,fc,
|
|
& func,GOLD,GLIMIT,TINY
|
|
EXTERNAL func
|
|
PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20)
|
|
double precision dum,fu,q,r,u,ulim,xxmin,xxmax
|
|
integer ierr
|
|
ierr=0
|
|
fa=func(ax)
|
|
fb=func(bx)
|
|
if(fb.gt.fa)then
|
|
dum=ax
|
|
ax=bx
|
|
bx=dum
|
|
dum=fb
|
|
fb=fa
|
|
fa=dum
|
|
!from ax to bx, f decreases
|
|
endif
|
|
if(fa.eq.fb)then
|
|
cx=(bx+ax)/2.0d0
|
|
fc=func(cx)
|
|
if(fc.le.fa)return
|
|
endif
|
|
cx=bx+GOLD*(bx-ax)
|
|
if(cx.le.xxmin)then
|
|
cx=0.5d0*(dmin1(ax,bx)+xxmin)
|
|
endif
|
|
if(cx.ge.xxmax)then
|
|
cx=0.5d0*(dmax1(ax,bx)+xxmax)
|
|
endif
|
|
fc=func(cx)
|
|
1 if(fb.ge.fc)then
|
|
r=(bx-ax)*(fb-fc)
|
|
q=(bx-cx)*(fb-fa)
|
|
u=bx-((bx-cx)*q-(bx-ax)*r)/
|
|
& (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r))
|
|
ulim=bx+GLIMIT*(cx-bx)
|
|
if(ulim.ge.xxmax)then
|
|
ulim=xxmax-TINY
|
|
endif
|
|
if(ulim.le.xxmin)then
|
|
ulim=xxmin+TINY
|
|
endif
|
|
if((bx-u)*(u-cx).gt.0.0d0)then
|
|
fu=func(u)
|
|
if(fu.lt.fc)then
|
|
ax=bx
|
|
fa=fb
|
|
bx=u
|
|
fb=fu
|
|
return
|
|
elseif(fu.gt.fb)then
|
|
cx=u
|
|
fc=fu
|
|
return
|
|
endif
|
|
u=cx+GOLD*(cx-bx)
|
|
if(u.gt.xxmax)then
|
|
u=cx+0.5d0*(xxmax-cx)
|
|
endif
|
|
if(u.lt.xxmin)then
|
|
u=cx+0.5d0*(xxmin-cx)
|
|
endif
|
|
fu=func(u)
|
|
elseif((cx-u)*(u-ulim).gt.0.0d0)then
|
|
fu=func(u)
|
|
if(fu.lt.fc)then
|
|
bx=cx
|
|
cx=u
|
|
u=cx+GOLD*(cx-bx)
|
|
if(u.gt.xxmax)then
|
|
u=cx+0.5d0*(xxmax-cx)
|
|
endif
|
|
if(u.lt.xxmin)then
|
|
u=cx+0.5d0*(xxmin-cx)
|
|
endif
|
|
fb=fc
|
|
fc=fu
|
|
fu=func(u)
|
|
endif
|
|
else if((u-ulim)*(ulim-cx).ge.0.0d0)then
|
|
u=ulim
|
|
fu=func(u)
|
|
else
|
|
u=cx+GOLD*(cx-bx)
|
|
if(u.gt.xxmax)then
|
|
u=cx+0.5d0*(xxmax-cx)
|
|
endif
|
|
if(u.lt.xxmin)then
|
|
u=cx+0.5d0*(xxmin-cx)
|
|
endif
|
|
fu=func(u)
|
|
endif
|
|
ax=bx
|
|
bx=cx
|
|
cx=u
|
|
fa=fb
|
|
fb=fc
|
|
fc=fu
|
|
r=dmin1(dabs(ax-bx),dabs(ax-cx))
|
|
r=dmin1(r,dabs(bx-cx))
|
|
if(r.lt.TINY)then
|
|
! bracketing failed
|
|
ierr=1
|
|
return
|
|
endif
|
|
goto 1
|
|
endif
|
|
return
|
|
END
|
|
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
|
|
|
SUBROUTINE leafmnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax,
|
|
& ierr,func)
|
|
implicit none
|
|
double precision ax,bx,cx,fa,fb,fc,
|
|
& func,GOLD,GLIMIT,TINY
|
|
EXTERNAL func
|
|
PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20)
|
|
double precision dum,fu,q,r,u,ulim,xxmin,xxmax
|
|
integer ierr
|
|
ierr=0
|
|
fa=func(ax)
|
|
fb=func(bx)
|
|
if(fb.gt.fa)then
|
|
dum=ax
|
|
ax=bx
|
|
bx=dum
|
|
dum=fb
|
|
fb=fa
|
|
fa=dum
|
|
!from ax to bx, f decreases
|
|
endif
|
|
if(fa.eq.fb)then
|
|
cx=(bx+ax)/2.0d0
|
|
fc=func(cx)
|
|
if(fc.le.fa)return
|
|
endif
|
|
cx=bx+GOLD*(bx-ax)
|
|
if(cx.le.xxmin)then
|
|
cx=0.5d0*(dmin1(ax,bx)+xxmin)
|
|
endif
|
|
if(cx.ge.xxmax)then
|
|
cx=0.5d0*(dmax1(ax,bx)+xxmax)
|
|
endif
|
|
fc=func(cx)
|
|
1 if(fb.ge.fc)then
|
|
r=(bx-ax)*(fb-fc)
|
|
q=(bx-cx)*(fb-fa)
|
|
u=bx-((bx-cx)*q-(bx-ax)*r)/
|
|
& (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r))
|
|
ulim=bx+GLIMIT*(cx-bx)
|
|
if(ulim.ge.xxmax)then
|
|
ulim=xxmax-TINY
|
|
endif
|
|
if(ulim.le.xxmin)then
|
|
ulim=xxmin+TINY
|
|
endif
|
|
if((bx-u)*(u-cx).gt.0.0d0)then
|
|
fu=func(u)
|
|
if(fu.lt.fc)then
|
|
ax=bx
|
|
fa=fb
|
|
bx=u
|
|
fb=fu
|
|
return
|
|
elseif(fu.gt.fb)then
|
|
cx=u
|
|
fc=fu
|
|
return
|
|
endif
|
|
u=cx+GOLD*(cx-bx)
|
|
if(u.gt.xxmax)then
|
|
u=cx+0.5d0*(xxmax-cx)
|
|
endif
|
|
if(u.lt.xxmin)then
|
|
u=cx+0.5d0*(xxmin-cx)
|
|
endif
|
|
fu=func(u)
|
|
elseif((cx-u)*(u-ulim).gt.0.0d0)then
|
|
fu=func(u)
|
|
if(fu.lt.fc)then
|
|
bx=cx
|
|
cx=u
|
|
u=cx+GOLD*(cx-bx)
|
|
if(u.gt.xxmax)then
|
|
u=cx+0.5d0*(xxmax-cx)
|
|
endif
|
|
if(u.lt.xxmin)then
|
|
u=cx+0.5d0*(xxmin-cx)
|
|
endif
|
|
fb=fc
|
|
fc=fu
|
|
fu=func(u)
|
|
endif
|
|
else if((u-ulim)*(ulim-cx).ge.0.0d0)then
|
|
u=ulim
|
|
fu=func(u)
|
|
else
|
|
u=cx+GOLD*(cx-bx)
|
|
if(u.gt.xxmax)then
|
|
u=cx+0.5d0*(xxmax-cx)
|
|
endif
|
|
if(u.lt.xxmin)then
|
|
u=cx+0.5d0*(xxmin-cx)
|
|
endif
|
|
fu=func(u)
|
|
endif
|
|
ax=bx
|
|
bx=cx
|
|
cx=u
|
|
fa=fb
|
|
fb=fc
|
|
fc=fu
|
|
r=dmin1(dabs(ax-bx),dabs(ax-cx))
|
|
r=dmin1(r,dabs(bx-cx))
|
|
if(r.lt.TINY)then
|
|
! bracketing failed
|
|
ierr=1
|
|
return
|
|
endif
|
|
goto 1
|
|
endif
|
|
return
|
|
END
|
|
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
|
|
|
double precision function leafbrent(ax,bx,cx,f,tol,xmin)
|
|
INTEGER ITMAX
|
|
double precision ax,bx,cx,tol,xmin,f,CGOLD,ZEPS
|
|
EXTERNAL f
|
|
PARAMETER (ITMAX=10000,CGOLD=.381966d0,ZEPS=1.0d-10)
|
|
INTEGER iter
|
|
double precision a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,
|
|
& tol2,u,v,w,x,xm
|
|
a=dmin1(ax,cx)
|
|
b=dmax1(ax,cx)
|
|
v=bx
|
|
w=v
|
|
x=v
|
|
e=0.0d0
|
|
fx=f(x)
|
|
fv=fx
|
|
fw=fx
|
|
do 11 iter=1,ITMAX
|
|
xm=0.5d0*(a+b)
|
|
tol1=tol*dabs(x)+ZEPS
|
|
tol2=2.0d0*tol1
|
|
if(dabs(x-xm).le.(tol2-.5d0*(b-a))) goto 3
|
|
if(dabs(e).gt.tol1) then
|
|
r=(x-w)*(fx-fv)
|
|
q=(x-v)*(fx-fw)
|
|
p=(x-v)*q-(x-w)*r
|
|
q=2.0d0*(q-r)
|
|
if(q.gt.0.0d0) p=-p
|
|
q=dabs(q)
|
|
etemp=e
|
|
e=d
|
|
if(dabs(p).ge.dabs(.5d0*q*etemp).or.
|
|
& p.le.q*(a-x).or.p.ge.q*(b-x))goto 1
|
|
d=p/q
|
|
u=x+d
|
|
if(u-a.lt.tol2.or.b-u.lt.tol2)d=dsign(tol1,xm-x)
|
|
goto 2
|
|
endif
|
|
1 if(x.ge.xm)then
|
|
e=a-x
|
|
else
|
|
e=b-x
|
|
endif
|
|
d=CGOLD*e
|
|
2 if(dabs(d).ge.tol1) then
|
|
u=x+d
|
|
else
|
|
u=x+dsign(tol1,d)
|
|
endif
|
|
fu=f(u)
|
|
if(fu.le.fx)then
|
|
if(u.ge.x)then
|
|
a=x
|
|
else
|
|
b=x
|
|
endif
|
|
v=w
|
|
fv=fw
|
|
w=x
|
|
fw=fx
|
|
x=u
|
|
fx=fu
|
|
else
|
|
if(u.lt.x) then
|
|
a=u
|
|
else
|
|
b=u
|
|
endif
|
|
if(fu.le.fw.or.w.eq.x)then
|
|
v=w
|
|
fv=fw
|
|
w=u
|
|
fw=fu
|
|
else if(fu.le.fv.or.v.eq.x.or.v.eq.w)then
|
|
v=u
|
|
fv=fu
|
|
endif
|
|
endif
|
|
11 continue
|
|
! write(*,*) 'brent exceed maximum iterations'
|
|
3 xmin=x
|
|
leafbrent=fx
|
|
return
|
|
END
|
|
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|