Kolpack-Software-Consulting/piscal
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
James Kolpack
2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dataassim/math/optimization/cppowell.f
+344
View File
@@ -0,0 +1,344 @@
SUBROUTINE cppowell(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)
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 cplinmin(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 cplinmin(p,pmin,pmax,xit,n,f1dim,fret)
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 cplinmin(p,pmin,pmax,xi,n,f1dim,fret)
implicit none
INTEGER n
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n)
PARAMETER (TOL=1.0d-8)
CU USES brent,f1dim,mnbrak
INTEGER j,k,ierr
double precision ax,bx,fa,fb,fx,xmin,xx,cpbrent,xxmin,xxmax
!((((((((((((((((((((((((((((((((((((((((((((((((((((
integer NMAX,ncom
parameter(NMAX=1000)
double precision pcom(NMAX),xicom(NMAX)
COMMON /cpf1com/ pcom,xicom,ncom
save /cpf1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
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 cpmnbrak(ax,xx,bx,fa,fx,fb,
& xxmin,xxmax,ierr,f1dim)
if(ierr.eq.0)then
fret=cpbrent(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 cpbrent(ax,bx,cx,f,tol,xmin)
implicit none
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
cpbrent=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 /cpf1com/ pcom,xicom,ncom
! save /cpf1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
! 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 cpmnbrak(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
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