70 lines
1.9 KiB
Fortran
70 lines
1.9 KiB
Fortran
SUBROUTINE lnsrch(n,xold,fold,g,p,x,f,stpmax,check,func)
|
|
INTEGER n
|
|
LOGICAL check
|
|
REAL f,fold,stpmax,g(n),p(n),x(n),xold(n),func,ALF,TOLX
|
|
PARAMETER (ALF=1.e-4,TOLX=1.e-7)
|
|
EXTERNAL func
|
|
CU USES func
|
|
INTEGER i
|
|
REAL a,alam,alam2,alamin,b,disc,f2,fold2,rhs1,rhs2,slope,sum,temp,
|
|
*test,tmplam
|
|
check=.false.
|
|
sum=0.
|
|
do 11 i=1,n
|
|
sum=sum+p(i)*p(i)
|
|
11 continue
|
|
sum=sqrt(sum)
|
|
if(sum.gt.stpmax)then
|
|
do 12 i=1,n
|
|
p(i)=p(i)*stpmax/sum
|
|
12 continue
|
|
endif
|
|
slope=0.
|
|
do 13 i=1,n
|
|
slope=slope+g(i)*p(i)
|
|
13 continue
|
|
test=0.
|
|
do 14 i=1,n
|
|
temp=abs(p(i))/max(abs(xold(i)),1.)
|
|
if(temp.gt.test)test=temp
|
|
14 continue
|
|
alamin=TOLX/test
|
|
alam=1.
|
|
1 continue
|
|
do 15 i=1,n
|
|
x(i)=xold(i)+alam*p(i)
|
|
15 continue
|
|
f=func(x)
|
|
if(alam.lt.alamin)then
|
|
do 16 i=1,n
|
|
x(i)=xold(i)
|
|
16 continue
|
|
check=.true.
|
|
return
|
|
else if(f.le.fold+ALF*alam*slope)then
|
|
return
|
|
else
|
|
if(alam.eq.1.)then
|
|
tmplam=-slope/(2.*(f-fold-slope))
|
|
else
|
|
rhs1=f-fold-alam*slope
|
|
rhs2=f2-fold2-alam2*slope
|
|
a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
|
|
b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/(alam-alam2)
|
|
if(a.eq.0.)then
|
|
tmplam=-slope/(2.*b)
|
|
else
|
|
disc=b*b-3.*a*slope
|
|
if(disc.lt.0.) pause 'roundoff problem in lnsrch'
|
|
tmplam=(-b+sqrt(disc))/(3.*a)
|
|
endif
|
|
if(tmplam.gt..5*alam)tmplam=.5*alam
|
|
endif
|
|
endif
|
|
alam2=alam
|
|
f2=f
|
|
fold2=fold
|
|
alam=max(tmplam,.1*alam)
|
|
goto 1
|
|
END
|