79 lines
2.0 KiB
Fortran
79 lines
2.0 KiB
Fortran
SUBROUTINE newt(x,n,check)
|
|
INTEGER n,nn,NP,MAXITS
|
|
LOGICAL check
|
|
REAL x(n),fvec,TOLF,TOLMIN,TOLX,STPMX
|
|
PARAMETER (NP=40,MAXITS=200,TOLF=1.e-4,TOLMIN=1.e-6,TOLX=1.e-7,
|
|
*STPMX=100.)
|
|
COMMON /newtv/ fvec(NP),nn
|
|
SAVE /newtv/
|
|
CU USES fdjac,fmin,lnsrch,lubksb,ludcmp
|
|
INTEGER i,its,j,indx(NP)
|
|
REAL d,den,f,fold,stpmax,sum,temp,test,fjac(NP,NP),g(NP),p(NP),
|
|
*xold(NP),fmin
|
|
EXTERNAL fmin
|
|
nn=n
|
|
f=fmin(x)
|
|
test=0.
|
|
do 11 i=1,n
|
|
if(abs(fvec(i)).gt.test)test=abs(fvec(i))
|
|
11 continue
|
|
if(test.lt..01*TOLF)then
|
|
check=.false.
|
|
return
|
|
endif
|
|
sum=0.
|
|
do 12 i=1,n
|
|
sum=sum+x(i)**2
|
|
12 continue
|
|
stpmax=STPMX*max(sqrt(sum),float(n))
|
|
do 21 its=1,MAXITS
|
|
call fdjac(n,x,fvec,NP,fjac)
|
|
do 14 i=1,n
|
|
sum=0.
|
|
do 13 j=1,n
|
|
sum=sum+fjac(j,i)*fvec(j)
|
|
13 continue
|
|
g(i)=sum
|
|
14 continue
|
|
do 15 i=1,n
|
|
xold(i)=x(i)
|
|
15 continue
|
|
fold=f
|
|
do 16 i=1,n
|
|
p(i)=-fvec(i)
|
|
16 continue
|
|
call ludcmp(fjac,n,NP,indx,d)
|
|
call lubksb(fjac,n,NP,indx,p)
|
|
call lnsrch(n,xold,fold,g,p,x,f,stpmax,check,fmin)
|
|
test=0.
|
|
do 17 i=1,n
|
|
if(abs(fvec(i)).gt.test)test=abs(fvec(i))
|
|
17 continue
|
|
if(test.lt.TOLF)then
|
|
check=.false.
|
|
return
|
|
endif
|
|
if(check)then
|
|
test=0.
|
|
den=max(f,.5*n)
|
|
do 18 i=1,n
|
|
temp=abs(g(i))*max(abs(x(i)),1.)/den
|
|
if(temp.gt.test)test=temp
|
|
18 continue
|
|
if(test.lt.TOLMIN)then
|
|
check=.true.
|
|
else
|
|
check=.false.
|
|
endif
|
|
return
|
|
endif
|
|
test=0.
|
|
do 19 i=1,n
|
|
temp=(abs(x(i)-xold(i)))/max(abs(x(i)),1.)
|
|
if(temp.gt.test)test=temp
|
|
19 continue
|
|
if(test.lt.TOLX)return
|
|
21 continue
|
|
pause 'MAXITS exceeded in newt'
|
|
END
|