Initial commit
This commit is contained in:
@@ -0,0 +1,23 @@
|
||||
program testnewton
|
||||
implicit none
|
||||
integer i
|
||||
double precision x,f0,f1,func,recider
|
||||
x=-1.5d0
|
||||
do i=1,200
|
||||
f0=func(x)
|
||||
write(*,*)i,x,f0
|
||||
pause
|
||||
|
||||
f1=func(x+f0)
|
||||
recider=f0/(f1-f0)
|
||||
x=x-recider*f0
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
double precision function func(x)
|
||||
double precision x
|
||||
func=x-(x*x+1.0d0)/2.0d0
|
||||
!x^2-2*x+1=0
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,66 @@
|
||||
subroutine bookkeeping(nunknowns,xvar,fequ,
|
||||
& icall,iflargest)
|
||||
implicit none
|
||||
include 'nslasystem.h'
|
||||
integer nunknowns,icall,iflargest
|
||||
double precision xvar(nunknowns),fequ(nunknowns)
|
||||
integer iGuCall,i,j,k
|
||||
parameter(iGuCall=49)
|
||||
!--------------------------------------------------------------------------
|
||||
iflargest=1
|
||||
do j=2,nunknowns
|
||||
if(dabs(fequ(j)).gt.dabs(fequ(iflargest)))
|
||||
& iflargest=j
|
||||
enddo
|
||||
if(numeval.eq.maxeval)goto 100
|
||||
if(numeval.eq.0.or.icall.eq.iGuCall)then
|
||||
numeval=numeval+1
|
||||
flargest(numeval)=dabs(fequ(iflargest))
|
||||
do i=1,nunknowns
|
||||
xevaluated(numeval,i)=xvar(i)
|
||||
fevaluated(numeval,i)=fequ(i)
|
||||
enddo
|
||||
return
|
||||
endif
|
||||
100 do i=1,numeval
|
||||
k=0
|
||||
do j=1,nunknowns
|
||||
if(dabs(xvar(j)-xevaluated(i,j)).gt.
|
||||
& 1.0d-5*dabs(xvar(j)))k=1
|
||||
enddo
|
||||
if(k.eq.0)goto 500
|
||||
enddo
|
||||
if(numeval.lt.maxeval)then
|
||||
numeval=numeval+1
|
||||
flargest(numeval)=dabs(fequ(iflargest))
|
||||
do i=1,nunknowns
|
||||
xevaluated(numeval,i)=xvar(i)
|
||||
fevaluated(numeval,i)=fequ(i)
|
||||
enddo
|
||||
return
|
||||
endif
|
||||
! replace a point
|
||||
j=1
|
||||
do i=2,numeval
|
||||
if(flargest(j).lt.flargest(i))then
|
||||
j=i
|
||||
endif
|
||||
enddo
|
||||
if(dabs(fequ(iflargest)).lt.flargest(j))then
|
||||
flargest(j)=dabs(fequ(iflargest))
|
||||
do i=1,nunknowns
|
||||
xevaluated(j,i)=xvar(i)
|
||||
fevaluated(j,i)=fequ(i)
|
||||
enddo
|
||||
endif
|
||||
return
|
||||
! too close to the existing point i
|
||||
500 if(dabs(fequ(iflargest)).lt.flargest(i))then
|
||||
flargest(i)=dabs(fequ(iflargest))
|
||||
do j=1,nunknowns
|
||||
xevaluated(i,j)=xvar(j)
|
||||
fevaluated(i,j)=fequ(j)
|
||||
enddo
|
||||
endif
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,567 @@
|
||||
C This file contains all the subroutines needed by the nonlinear solver broydn
|
||||
C code modified based on on-line version in Numerical Recipes Website, Dec 28, 2004
|
||||
|
||||
SUBROUTINE broydn(x0min,x,x0max,STPMX,n,
|
||||
& fveccopy,funcv,TOLF,ierr)
|
||||
implicit none
|
||||
INTEGER n,NP,MAXITS,ierr
|
||||
double precision x(n),EPS,TOLF,TOLMIN,TOLX,STPMX
|
||||
double precision x0min(n),x0max(n),fveccopy(n)
|
||||
LOGICAL check
|
||||
! PARAMETER (NP=1000,MAXITS=250,EPS=1.0d-7,TOLF=1.0d-4,
|
||||
! & TOLMIN=1.d-6,TOLX=EPS)
|
||||
PARAMETER(NP=1000,MAXITS=250,EPS=1.0d-7,TOLX=EPS)
|
||||
CU USES fdjac,funcv,lnsrch,qrdcmp,qrupdt,rsolv
|
||||
INTEGER i,its,j,k
|
||||
double precision den,f,fold,stpmax,sum,temp,test,c(NP),
|
||||
& d(NP),fvcold(NP),g(NP),p(NP),qt(NP,NP),r(NP,NP),
|
||||
& s(NP),t(NP),w(NP),xold(NP),fvec(NP)
|
||||
LOGICAL restrt,sing,skip
|
||||
EXTERNAL funcv
|
||||
TOLMIN=TOLF*0.01d0
|
||||
call funcv(n,x,fvec,f)
|
||||
test=0.0d0
|
||||
do 11 i=1,n
|
||||
if(dabs(fvec(i)).gt.test)test=dabs(fvec(i))
|
||||
11 continue
|
||||
if(test.lt..01d0*TOLF)then
|
||||
ierr=0
|
||||
! check=.false.
|
||||
return
|
||||
endif
|
||||
sum=0.0d0
|
||||
do 12 i=1,n
|
||||
sum=sum+x(i)*x(i)
|
||||
12 continue
|
||||
stpmax=STPMX*dmax1(dsqrt(sum),dble(n))
|
||||
restrt=.true.
|
||||
do 42 its=1,MAXITS
|
||||
if(restrt)then
|
||||
do i=1,n
|
||||
if(x(i).lt.x0min(i).or.x(i).gt.x0max(i))then
|
||||
ierr=1
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
call fdjac(n,x,fvec,NP,r,funcv)
|
||||
call qrdcmp(r,n,NP,c,d,sing)
|
||||
! if(sing) pause 'singular Jacobian in broydn'
|
||||
if(sing)then
|
||||
ierr=2
|
||||
return
|
||||
end if
|
||||
do 14 i=1,n
|
||||
do 13 j=1,n
|
||||
qt(i,j)=0.0d0
|
||||
13 continue
|
||||
qt(i,i)=1.0d0
|
||||
14 continue
|
||||
do 18 k=1,n-1
|
||||
if(c(k).ne.0.0d0)then
|
||||
do 17 j=1,n
|
||||
sum=0.0d0
|
||||
do 15 i=k,n
|
||||
sum=sum+r(i,k)*qt(i,j)
|
||||
15 continue
|
||||
sum=sum/c(k)
|
||||
do 16 i=k,n
|
||||
qt(i,j)=qt(i,j)-sum*r(i,k)
|
||||
16 continue
|
||||
17 continue
|
||||
endif
|
||||
18 continue
|
||||
do 21 i=1,n
|
||||
r(i,i)=d(i)
|
||||
do 19 j=1,i-1
|
||||
r(i,j)=0.0d0
|
||||
19 continue
|
||||
21 continue
|
||||
else
|
||||
do 22 i=1,n
|
||||
s(i)=x(i)-xold(i)
|
||||
22 continue
|
||||
do 24 i=1,n
|
||||
sum=0.0d0
|
||||
do 23 j=i,n
|
||||
sum=sum+r(i,j)*s(j)
|
||||
23 continue
|
||||
t(i)=sum
|
||||
24 continue
|
||||
skip=.true.
|
||||
do 26 i=1,n
|
||||
sum=0.0d0
|
||||
do 25 j=1,n
|
||||
sum=sum+qt(j,i)*t(j)
|
||||
25 continue
|
||||
w(i)=fvec(i)-fvcold(i)-sum
|
||||
if(dabs(w(i)).ge.EPS*(dabs(fvec(i))+
|
||||
& dabs(fvcold(i))))then
|
||||
skip=.false.
|
||||
else
|
||||
w(i)=0.0d0
|
||||
endif
|
||||
26 continue
|
||||
if(.not.skip)then
|
||||
do 28 i=1,n
|
||||
sum=0.0d0
|
||||
do 27 j=1,n
|
||||
sum=sum+qt(i,j)*w(j)
|
||||
27 continue
|
||||
t(i)=sum
|
||||
28 continue
|
||||
den=0.0d0
|
||||
do 29 i=1,n
|
||||
den=den+s(i)*s(i)
|
||||
29 continue
|
||||
do 31 i=1,n
|
||||
s(i)=s(i)/den
|
||||
31 continue
|
||||
call qrupdt(r,qt,n,NP,t,s)
|
||||
do 32 i=1,n
|
||||
if(r(i,i).eq.0.0d0) then
|
||||
write(*,*) 'r singular in broydn'
|
||||
end if
|
||||
d(i)=r(i,i)
|
||||
32 continue
|
||||
endif
|
||||
endif
|
||||
do 34 i=1,n
|
||||
sum=0.0d0
|
||||
do 33 j=1,n
|
||||
sum=sum+qt(i,j)*fvec(j)
|
||||
33 continue
|
||||
p(i)=-sum
|
||||
34 continue
|
||||
do 36 i=n,1,-1
|
||||
sum=0.0d0
|
||||
do 35 j=1,i
|
||||
sum=sum-r(j,i)*p(j)
|
||||
35 continue
|
||||
g(i)=sum
|
||||
36 continue
|
||||
do 37 i=1,n
|
||||
xold(i)=x(i)
|
||||
fvcold(i)=fvec(i)
|
||||
37 continue
|
||||
fold=f
|
||||
call rsolv(r,n,NP,d,p)
|
||||
|
||||
! Gu modification starts
|
||||
do 100 i=1,n
|
||||
if(xold(i).lt.x0min(i).or.xold(i).gt.x0max(i))then
|
||||
ierr=1
|
||||
return
|
||||
endif
|
||||
100 continue
|
||||
! Gu modification ends
|
||||
call lnsrch(n,xold,fold,g,p,x,f,
|
||||
& stpmax,check,funcv,fvec)
|
||||
test=0.0d0
|
||||
do 38 i=1,n
|
||||
if(dabs(fvec(i)).gt.test)test=dabs(fvec(i))
|
||||
fveccopy(i)=fvec(i)
|
||||
38 continue
|
||||
if(test.lt.TOLF)then
|
||||
ierr=0
|
||||
! check=.false.
|
||||
return
|
||||
endif
|
||||
if(check)then
|
||||
if(restrt)then
|
||||
ierr=3
|
||||
return
|
||||
else
|
||||
test=0.0d0
|
||||
den=dmax1(f,.5d0*dble(n))
|
||||
do 39 i=1,n
|
||||
temp=dabs(g(i))*dmax1(dabs(x(i)),1.0d0)/den
|
||||
if(temp.gt.test)test=temp
|
||||
39 continue
|
||||
if(test.lt.TOLMIN)then
|
||||
ierr=4
|
||||
return
|
||||
else
|
||||
restrt=.true.
|
||||
endif
|
||||
endif
|
||||
else
|
||||
restrt=.false.
|
||||
test=0.0d0
|
||||
do 41 i=1,n
|
||||
temp=(dabs(x(i)-xold(i)))/dmax1(dabs(x(i)),1.0d0)
|
||||
if(temp.gt.test)test=temp
|
||||
41 continue
|
||||
if(test.lt.TOLX)then
|
||||
ierr=4
|
||||
! check=.true.
|
||||
return
|
||||
endif
|
||||
endif
|
||||
42 continue
|
||||
ierr=5
|
||||
return
|
||||
END
|
||||
|
||||
SUBROUTINE fdjac(n,x,fvec,np,df,funcv)
|
||||
implicit none
|
||||
INTEGER n,np
|
||||
double precision df(np,np),fvec(n),x(n),EPS
|
||||
PARAMETER (EPS=1.0d-4)
|
||||
CU USES funcv
|
||||
INTEGER i,j,k
|
||||
double precision h,temp,f(n),fsqsum
|
||||
external funcv
|
||||
do 12 j=1,n
|
||||
temp=x(j)
|
||||
h=EPS*dabs(temp)
|
||||
if(h.eq.0.0d0)h=EPS
|
||||
x(j)=temp+h
|
||||
h=x(j)-temp
|
||||
call funcv(n,x,f,fsqsum)
|
||||
x(j)=temp
|
||||
do 11 i=1,n
|
||||
df(i,j)=(f(i)-fvec(i))/h
|
||||
11 continue
|
||||
12 continue
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE lnsrch(n,xold,fold,g,p,x,f,
|
||||
& stpmax,check,funcv,fvec)
|
||||
implicit none
|
||||
INTEGER n
|
||||
LOGICAL check
|
||||
DOUBLE PRECISION f,fold,stpmax,g(n),p(n),x(n),
|
||||
*xold(n),ALF,TOLX,fvec(n)
|
||||
PARAMETER (ALF=1.d-4,TOLX=1.d-7)
|
||||
EXTERNAL funcv
|
||||
CU USES funcv
|
||||
INTEGER i
|
||||
DOUBLE PRECISION a,alam,alam2,alamin,b,disc,
|
||||
*f2,rhs1,rhs2,slope,sum,temp,test,tmplam
|
||||
check=.false.
|
||||
sum=0.0d0
|
||||
do 11 i=1,n
|
||||
sum=sum+p(i)*p(i)
|
||||
11 continue
|
||||
sum=dsqrt(sum)
|
||||
if(sum.gt.stpmax)then
|
||||
do 12 i=1,n
|
||||
p(i)=p(i)*stpmax/sum
|
||||
12 continue
|
||||
endif
|
||||
slope=0.0d0
|
||||
do 13 i=1,n
|
||||
slope=slope+g(i)*p(i)
|
||||
13 continue
|
||||
! if(slope.ge.0.0d0)pause 'roundoff problem in lnsrch'
|
||||
test=0.0d0
|
||||
do 14 i=1,n
|
||||
temp=dabs(p(i))/dmax1(dabs(xold(i)),1.0d0)
|
||||
if(temp.gt.test)test=temp
|
||||
14 continue
|
||||
alamin=TOLX/test
|
||||
alam=1.0d0
|
||||
1 continue
|
||||
do 15 i=1,n
|
||||
x(i)=xold(i)+alam*p(i)
|
||||
15 continue
|
||||
call funcv(n,x,fvec,f)
|
||||
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.0d0)then
|
||||
tmplam=-slope/(2.0d0*(f-fold-slope))
|
||||
else
|
||||
rhs1=f-fold-alam*slope
|
||||
rhs2=f2-fold-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.0d0)then
|
||||
tmplam=-slope/(2.0d0*b)
|
||||
else
|
||||
disc=b*b-3.0d0*a*slope
|
||||
if(disc.lt.0.0d0) then
|
||||
tmplam=0.5d0*alam
|
||||
else if(b.le.0.0d0)then
|
||||
tmplam=(-b+dsqrt(disc))/(3.0d0*a)
|
||||
else
|
||||
tmplam=-slope/(b+dsqrt(disc))
|
||||
endif
|
||||
endif
|
||||
if(tmplam.gt..5d0*alam)tmplam=.5d0*alam
|
||||
endif
|
||||
endif
|
||||
alam2=alam
|
||||
f2=f
|
||||
alam=dmax1(tmplam,.1d0*alam)
|
||||
goto 1
|
||||
END
|
||||
c
|
||||
SUBROUTINE qrdcmp(a,n,np,c,d,sing)
|
||||
implicit none
|
||||
INTEGER n,np
|
||||
DOUBLE PRECISION a(np,np),c(n),d(n)
|
||||
LOGICAL sing
|
||||
INTEGER i,j,k
|
||||
DOUBLE PRECISION scale,sigma,sum,tau
|
||||
sing=.false.
|
||||
do 17 k=1,n-1
|
||||
scale=0.0d0
|
||||
do 11 i=k,n
|
||||
scale=dmax1(scale,dabs(a(i,k)))
|
||||
11 continue
|
||||
if(scale.eq.0.0d0)then
|
||||
sing=.true.
|
||||
c(k)=0.0d0
|
||||
d(k)=0.0d0
|
||||
else
|
||||
do 12 i=k,n
|
||||
a(i,k)=a(i,k)/scale
|
||||
12 continue
|
||||
sum=0.0d0
|
||||
do 13 i=k,n
|
||||
sum=sum+a(i,k)**2
|
||||
13 continue
|
||||
sigma=dsign(dsqrt(sum),a(k,k))
|
||||
a(k,k)=a(k,k)+sigma
|
||||
c(k)=sigma*a(k,k)
|
||||
d(k)=-scale*sigma
|
||||
do 16 j=k+1,n
|
||||
sum=0.0d0
|
||||
do 14 i=k,n
|
||||
sum=sum+a(i,k)*a(i,j)
|
||||
14 continue
|
||||
tau=sum/c(k)
|
||||
do 15 i=k,n
|
||||
a(i,j)=a(i,j)-tau*a(i,k)
|
||||
15 continue
|
||||
16 continue
|
||||
endif
|
||||
17 continue
|
||||
d(n)=a(n,n)
|
||||
if(d(n).eq.0.0d0)sing=.true.
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE qrupdt(r,qt,n,np,u,v)
|
||||
implicit none
|
||||
INTEGER n,np
|
||||
DOUBLE PRECISION r(np,np),qt(np,np),u(np),v(np)
|
||||
CU USES rotate
|
||||
INTEGER i,j,k
|
||||
do 11 k=n,1,-1
|
||||
if(u(k).ne.0.0d0)goto 1
|
||||
11 continue
|
||||
k=1
|
||||
1 do 12 i=k-1,1,-1
|
||||
call rotate(r,qt,n,np,i,u(i),-u(i+1))
|
||||
if(u(i).eq.0.0d0)then
|
||||
u(i)=dabs(u(i+1))
|
||||
else if(dabs(u(i)).gt.dabs(u(i+1)))then
|
||||
u(i)=dabs(u(i))*dsqrt(1.0d0+(u(i+1)/u(i))**2)
|
||||
else
|
||||
u(i)=dabs(u(i+1))*dsqrt(1.0d0+(u(i)/u(i+1))**2)
|
||||
endif
|
||||
12 continue
|
||||
do 13 j=1,n
|
||||
r(1,j)=r(1,j)+u(1)*v(j)
|
||||
13 continue
|
||||
do 14 i=1,k-1
|
||||
call rotate(r,qt,n,np,i,r(i,i),-r(i+1,i))
|
||||
14 continue
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE rsolv(a,n,np,d,b)
|
||||
implicit none
|
||||
INTEGER n,np
|
||||
DOUBLE PRECISION a(np,np),b(n),d(n)
|
||||
INTEGER i,j
|
||||
DOUBLE PRECISION sum
|
||||
b(n)=b(n)/d(n)
|
||||
do 12 i=n-1,1,-1
|
||||
sum=0.0d0
|
||||
do 11 j=i+1,n
|
||||
sum=sum+a(i,j)*b(j)
|
||||
11 continue
|
||||
b(i)=(b(i)-sum)/d(i)
|
||||
12 continue
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE rotate(r,qt,n,np,i,a,b)
|
||||
implicit none
|
||||
INTEGER n,np,i
|
||||
DOUBLE PRECISION a,b,r(np,np),qt(np,np)
|
||||
INTEGER j
|
||||
DOUBLE PRECISION c,fact,s,w,y
|
||||
if(a.eq.0.0d0)then
|
||||
c=0.0d0
|
||||
s=dsign(1.0d0,b)
|
||||
else if(dabs(a).gt.dabs(b))then
|
||||
fact=b/a
|
||||
c=dsign(1.0d0/dsqrt(1.0d0+fact**2),a)
|
||||
s=fact*c
|
||||
else
|
||||
fact=a/b
|
||||
s=dsign(1.0d0/dsqrt(1.0d0+fact**2),b)
|
||||
c=fact*s
|
||||
endif
|
||||
do 11 j=i,n
|
||||
y=r(i,j)
|
||||
w=r(i+1,j)
|
||||
r(i,j)=c*y-s*w
|
||||
r(i+1,j)=s*y+c*w
|
||||
11 continue
|
||||
do 12 j=1,n
|
||||
y=qt(i,j)
|
||||
w=qt(i+1,j)
|
||||
qt(i,j)=c*y-s*w
|
||||
qt(i+1,j)=s*y+c*w
|
||||
12 continue
|
||||
return
|
||||
END
|
||||
|
||||
subroutine xmprove(N,NP,a,b,x,mark)
|
||||
implicit none
|
||||
INTEGER i,j,idum,N,NP,indx(N),mark
|
||||
double precision d,a(NP,NP),b(N),x(N),aa(NP,NP)
|
||||
|
||||
do 12 i=1,N
|
||||
x(i)=b(i)
|
||||
do 11 j=1,N
|
||||
aa(i,j)=a(i,j)
|
||||
11 continue
|
||||
12 continue
|
||||
call ludcmp(aa,N,NP,indx,d,mark)
|
||||
if (mark .eq. 0) goto 20
|
||||
call lubksb(aa,N,NP,indx,x)
|
||||
call mprove(a,aa,N,NP,indx,b,x)
|
||||
20 continue
|
||||
return
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE mprove(a,alud,n,np,indx,b,x)
|
||||
implicit none
|
||||
INTEGER n,np,indx(n),NMAX
|
||||
double precision a(np,np),alud(np,np),b(n),x(n)
|
||||
PARAMETER (NMAX=500)
|
||||
CU USES lubksb
|
||||
INTEGER i,j
|
||||
double precision r(NMAX)
|
||||
DOUBLE PRECISION sdp
|
||||
do 12 i=1,n
|
||||
sdp=-b(i)
|
||||
do 11 j=1,n
|
||||
sdp=sdp+(a(i,j))*(x(j))
|
||||
11 continue
|
||||
r(i)=sdp
|
||||
12 continue
|
||||
call lubksb(alud,n,np,indx,r)
|
||||
do 13 i=1,n
|
||||
x(i)=x(i)-r(i)
|
||||
13 continue
|
||||
return
|
||||
END
|
||||
|
||||
SUBROUTINE ludcmp(a,n,np,indx,d,mark)
|
||||
implicit none
|
||||
INTEGER n,np,indx(n),NMAX
|
||||
double precision d,a(np,np),TINY
|
||||
PARAMETER (NMAX=500,TINY=1.0d-20)
|
||||
INTEGER i,imax,j,k,mark
|
||||
double precision aamax,dum,sum,vv(NMAX)
|
||||
mark=1
|
||||
d=1.0d0
|
||||
do 12 i=1,n
|
||||
aamax=0.0d0
|
||||
do 11 j=1,n
|
||||
if (dabs(a(i,j)).gt.aamax) aamax=dabs(a(i,j))
|
||||
11 continue
|
||||
if (aamax.eq.0.0d0) then
|
||||
! singular matrix
|
||||
mark=0
|
||||
return
|
||||
end if
|
||||
vv(i)=1.0d0/aamax
|
||||
12 continue
|
||||
do 19 j=1,n
|
||||
do 14 i=1,j-1
|
||||
sum=a(i,j)
|
||||
do 13 k=1,i-1
|
||||
sum=sum-a(i,k)*a(k,j)
|
||||
13 continue
|
||||
a(i,j)=sum
|
||||
14 continue
|
||||
aamax=0.0d0
|
||||
do 16 i=j,n
|
||||
sum=a(i,j)
|
||||
do 15 k=1,j-1
|
||||
sum=sum-a(i,k)*a(k,j)
|
||||
15 continue
|
||||
a(i,j)=sum
|
||||
dum=vv(i)*dabs(sum)
|
||||
if (dum.ge.aamax) then
|
||||
imax=i
|
||||
aamax=dum
|
||||
endif
|
||||
16 continue
|
||||
if (j.ne.imax)then
|
||||
do 17 k=1,n
|
||||
dum=a(imax,k)
|
||||
a(imax,k)=a(j,k)
|
||||
a(j,k)=dum
|
||||
17 continue
|
||||
d=-d
|
||||
vv(imax)=vv(j)
|
||||
endif
|
||||
indx(j)=imax
|
||||
if(a(j,j).eq.0.0d0)a(j,j)=TINY
|
||||
if(j.ne.n)then
|
||||
dum=1.0d0/a(j,j)
|
||||
do 18 i=j+1,n
|
||||
a(i,j)=a(i,j)*dum
|
||||
18 continue
|
||||
endif
|
||||
19 continue
|
||||
return
|
||||
END
|
||||
|
||||
SUBROUTINE lubksb(a,n,np,indx,b)
|
||||
implicit none
|
||||
INTEGER n,np,indx(n)
|
||||
double precision a(np,np),b(n)
|
||||
INTEGER i,ii,j,ll
|
||||
double precision sum
|
||||
ii=0
|
||||
do 12 i=1,n
|
||||
ll=indx(i)
|
||||
sum=b(ll)
|
||||
b(ll)=b(i)
|
||||
if (ii.ne.0)then
|
||||
do 11 j=ii,i-1
|
||||
sum=sum-a(i,j)*b(j)
|
||||
11 continue
|
||||
else if (sum.ne.0.0d0) then
|
||||
ii=i
|
||||
endif
|
||||
b(i)=sum
|
||||
12 continue
|
||||
do 14 i=n,1,-1
|
||||
sum=b(i)
|
||||
do 13 j=i+1,n
|
||||
sum=sum-a(i,j)*b(j)
|
||||
13 continue
|
||||
b(i)=sum/a(i,i)
|
||||
14 continue
|
||||
return
|
||||
END
|
||||
@@ -0,0 +1,65 @@
|
||||
subroutine cpbookkeeping(nunknowns,xvar,fequ,
|
||||
& icall,iflargest)
|
||||
implicit none
|
||||
include 'cpnslasystem.h'
|
||||
integer nunknowns,icall,iflargest
|
||||
double precision xvar(nunknowns),fequ(nunknowns)
|
||||
integer iGuCall,i,j,k
|
||||
parameter(iGuCall=49)
|
||||
!--------------------------------------------------------------------------
|
||||
iflargest=1
|
||||
do j=2,nunknowns
|
||||
if(dabs(fequ(j)).gt.dabs(fequ(iflargest)))
|
||||
& iflargest=j
|
||||
enddo
|
||||
if(numeval.eq.0.or.icall.eq.iGuCall)then
|
||||
numeval=numeval+1
|
||||
flargest(numeval)=dabs(fequ(iflargest))
|
||||
do i=1,nunknowns
|
||||
xevaluated(numeval,i)=xvar(i)
|
||||
fevaluated(numeval,i)=fequ(i)
|
||||
enddo
|
||||
return
|
||||
endif
|
||||
do i=1,numeval
|
||||
k=0
|
||||
do j=1,nunknowns
|
||||
if(dabs(xvar(j)-xevaluated(i,j)).gt.
|
||||
& 1.0d-5*dabs(xvar(j)))k=1
|
||||
enddo
|
||||
if(k.eq.0)goto 500
|
||||
enddo
|
||||
if(numeval.lt.maxeval)then
|
||||
numeval=numeval+1
|
||||
flargest(numeval)=dabs(fequ(iflargest))
|
||||
do i=1,nunknowns
|
||||
xevaluated(numeval,i)=xvar(i)
|
||||
fevaluated(numeval,i)=fequ(i)
|
||||
enddo
|
||||
return
|
||||
endif
|
||||
! replace a point
|
||||
j=1
|
||||
do i=2,numeval
|
||||
if(flargest(j).lt.flargest(i))then
|
||||
j=i
|
||||
endif
|
||||
enddo
|
||||
if(dabs(fequ(iflargest)).lt.flargest(j))then
|
||||
flargest(j)=dabs(fequ(iflargest))
|
||||
do i=1,nunknowns
|
||||
xevaluated(j,i)=xvar(i)
|
||||
fevaluated(j,i)=fequ(i)
|
||||
enddo
|
||||
endif
|
||||
return
|
||||
! too close to the existing point i
|
||||
500 if(dabs(fequ(iflargest)).lt.flargest(i))then
|
||||
flargest(i)=dabs(fequ(iflargest))
|
||||
do j=1,nunknowns
|
||||
xevaluated(i,j)=xvar(j)
|
||||
fevaluated(i,j)=fequ(j)
|
||||
enddo
|
||||
endif
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,567 @@
|
||||
C This file contains all the subroutines needed by the nonlinear solver broydn
|
||||
C code modified based on on-line version in Numerical Recipes Website, Dec 28, 2004
|
||||
|
||||
SUBROUTINE cpbroydn(x0min,x,x0max,STPMX,n,
|
||||
& fveccopy,funcv,TOLF,ierr)
|
||||
implicit none
|
||||
INTEGER n,NP,MAXITS,ierr
|
||||
double precision x(n),EPS,TOLF,TOLMIN,TOLX,STPMX
|
||||
double precision x0min(n),x0max(n),fveccopy(n)
|
||||
LOGICAL check
|
||||
! PARAMETER (NP=1000,MAXITS=250,EPS=1.0d-7,TOLF=1.0d-4,
|
||||
! & TOLMIN=1.d-6,TOLX=EPS)
|
||||
PARAMETER(NP=1000,MAXITS=250,EPS=1.0d-7,TOLX=EPS)
|
||||
CU USES fdjac,funcv,lnsrch,qrdcmp,qrupdt,rsolv
|
||||
INTEGER i,its,j,k
|
||||
double precision den,f,fold,stpmax,sum,temp,test,c(NP),
|
||||
& d(NP),fvcold(NP),g(NP),p(NP),qt(NP,NP),r(NP,NP),
|
||||
& s(NP),t(NP),w(NP),xold(NP),fvec(NP)
|
||||
LOGICAL restrt,sing,skip
|
||||
EXTERNAL funcv
|
||||
TOLMIN=TOLF*0.01d0
|
||||
call funcv(n,x,fvec,f)
|
||||
test=0.0d0
|
||||
do 11 i=1,n
|
||||
if(dabs(fvec(i)).gt.test)test=dabs(fvec(i))
|
||||
11 continue
|
||||
if(test.lt..01d0*TOLF)then
|
||||
ierr=0
|
||||
! check=.false.
|
||||
return
|
||||
endif
|
||||
sum=0.0d0
|
||||
do 12 i=1,n
|
||||
sum=sum+x(i)*x(i)
|
||||
12 continue
|
||||
stpmax=STPMX*dmax1(dsqrt(sum),dble(n))
|
||||
restrt=.true.
|
||||
do 42 its=1,MAXITS
|
||||
if(restrt)then
|
||||
do i=1,n
|
||||
if(x(i).lt.x0min(i).or.x(i).gt.x0max(i))then
|
||||
ierr=1
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
call cpfdjac(n,x,fvec,NP,r,funcv)
|
||||
call cpqrdcmp(r,n,NP,c,d,sing)
|
||||
! if(sing) pause 'singular Jacobian in broydn'
|
||||
if(sing)then
|
||||
ierr=2
|
||||
return
|
||||
end if
|
||||
do 14 i=1,n
|
||||
do 13 j=1,n
|
||||
qt(i,j)=0.0d0
|
||||
13 continue
|
||||
qt(i,i)=1.0d0
|
||||
14 continue
|
||||
do 18 k=1,n-1
|
||||
if(c(k).ne.0.0d0)then
|
||||
do 17 j=1,n
|
||||
sum=0.0d0
|
||||
do 15 i=k,n
|
||||
sum=sum+r(i,k)*qt(i,j)
|
||||
15 continue
|
||||
sum=sum/c(k)
|
||||
do 16 i=k,n
|
||||
qt(i,j)=qt(i,j)-sum*r(i,k)
|
||||
16 continue
|
||||
17 continue
|
||||
endif
|
||||
18 continue
|
||||
do 21 i=1,n
|
||||
r(i,i)=d(i)
|
||||
do 19 j=1,i-1
|
||||
r(i,j)=0.0d0
|
||||
19 continue
|
||||
21 continue
|
||||
else
|
||||
do 22 i=1,n
|
||||
s(i)=x(i)-xold(i)
|
||||
22 continue
|
||||
do 24 i=1,n
|
||||
sum=0.0d0
|
||||
do 23 j=i,n
|
||||
sum=sum+r(i,j)*s(j)
|
||||
23 continue
|
||||
t(i)=sum
|
||||
24 continue
|
||||
skip=.true.
|
||||
do 26 i=1,n
|
||||
sum=0.0d0
|
||||
do 25 j=1,n
|
||||
sum=sum+qt(j,i)*t(j)
|
||||
25 continue
|
||||
w(i)=fvec(i)-fvcold(i)-sum
|
||||
if(dabs(w(i)).ge.EPS*(dabs(fvec(i))+
|
||||
& dabs(fvcold(i))))then
|
||||
skip=.false.
|
||||
else
|
||||
w(i)=0.0d0
|
||||
endif
|
||||
26 continue
|
||||
if(.not.skip)then
|
||||
do 28 i=1,n
|
||||
sum=0.0d0
|
||||
do 27 j=1,n
|
||||
sum=sum+qt(i,j)*w(j)
|
||||
27 continue
|
||||
t(i)=sum
|
||||
28 continue
|
||||
den=0.0d0
|
||||
do 29 i=1,n
|
||||
den=den+s(i)*s(i)
|
||||
29 continue
|
||||
do 31 i=1,n
|
||||
s(i)=s(i)/den
|
||||
31 continue
|
||||
call cpqrupdt(r,qt,n,NP,t,s)
|
||||
do 32 i=1,n
|
||||
if(r(i,i).eq.0.0d0) then
|
||||
write(*,*) 'r singular in broydn'
|
||||
end if
|
||||
d(i)=r(i,i)
|
||||
32 continue
|
||||
endif
|
||||
endif
|
||||
do 34 i=1,n
|
||||
sum=0.0d0
|
||||
do 33 j=1,n
|
||||
sum=sum+qt(i,j)*fvec(j)
|
||||
33 continue
|
||||
p(i)=-sum
|
||||
34 continue
|
||||
do 36 i=n,1,-1
|
||||
sum=0.0d0
|
||||
do 35 j=1,i
|
||||
sum=sum-r(j,i)*p(j)
|
||||
35 continue
|
||||
g(i)=sum
|
||||
36 continue
|
||||
do 37 i=1,n
|
||||
xold(i)=x(i)
|
||||
fvcold(i)=fvec(i)
|
||||
37 continue
|
||||
fold=f
|
||||
call cprsolv(r,n,NP,d,p)
|
||||
|
||||
! Gu modification starts
|
||||
do 100 i=1,n
|
||||
if(xold(i).lt.x0min(i).or.xold(i).gt.x0max(i))then
|
||||
ierr=1
|
||||
return
|
||||
endif
|
||||
100 continue
|
||||
! Gu modification ends
|
||||
call cplnsrch(n,xold,fold,g,p,x,f,
|
||||
& stpmax,check,funcv,fvec)
|
||||
test=0.0d0
|
||||
do 38 i=1,n
|
||||
if(dabs(fvec(i)).gt.test)test=dabs(fvec(i))
|
||||
fveccopy(i)=fvec(i)
|
||||
38 continue
|
||||
if(test.lt.TOLF)then
|
||||
ierr=0
|
||||
! check=.false.
|
||||
return
|
||||
endif
|
||||
if(check)then
|
||||
if(restrt)then
|
||||
ierr=3
|
||||
return
|
||||
else
|
||||
test=0.0d0
|
||||
den=dmax1(f,.5d0*dble(n))
|
||||
do 39 i=1,n
|
||||
temp=dabs(g(i))*dmax1(dabs(x(i)),1.0d0)/den
|
||||
if(temp.gt.test)test=temp
|
||||
39 continue
|
||||
if(test.lt.TOLMIN)then
|
||||
ierr=4
|
||||
return
|
||||
else
|
||||
restrt=.true.
|
||||
endif
|
||||
endif
|
||||
else
|
||||
restrt=.false.
|
||||
test=0.0d0
|
||||
do 41 i=1,n
|
||||
temp=(dabs(x(i)-xold(i)))/dmax1(dabs(x(i)),1.0d0)
|
||||
if(temp.gt.test)test=temp
|
||||
41 continue
|
||||
if(test.lt.TOLX)then
|
||||
ierr=4
|
||||
! check=.true.
|
||||
return
|
||||
endif
|
||||
endif
|
||||
42 continue
|
||||
ierr=5
|
||||
return
|
||||
END
|
||||
|
||||
SUBROUTINE cpfdjac(n,x,fvec,np,df,funcv)
|
||||
implicit none
|
||||
INTEGER n,np
|
||||
double precision df(np,np),fvec(n),x(n),EPS
|
||||
PARAMETER (EPS=1.0d-4)
|
||||
CU USES funcv
|
||||
INTEGER i,j,k
|
||||
double precision h,temp,f(n),fsqsum
|
||||
external funcv
|
||||
do 12 j=1,n
|
||||
temp=x(j)
|
||||
h=EPS*dabs(temp)
|
||||
if(h.eq.0.0d0)h=EPS
|
||||
x(j)=temp+h
|
||||
h=x(j)-temp
|
||||
call funcv(n,x,f,fsqsum)
|
||||
x(j)=temp
|
||||
do 11 i=1,n
|
||||
df(i,j)=(f(i)-fvec(i))/h
|
||||
11 continue
|
||||
12 continue
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE cplnsrch(n,xold,fold,g,p,x,f,
|
||||
& stpmax,check,funcv,fvec)
|
||||
implicit none
|
||||
INTEGER n
|
||||
LOGICAL check
|
||||
DOUBLE PRECISION f,fold,stpmax,g(n),p(n),x(n),
|
||||
*xold(n),ALF,TOLX,fvec(n)
|
||||
PARAMETER (ALF=1.d-4,TOLX=1.d-7)
|
||||
EXTERNAL funcv
|
||||
CU USES funcv
|
||||
INTEGER i
|
||||
DOUBLE PRECISION a,alam,alam2,alamin,b,disc,
|
||||
*f2,rhs1,rhs2,slope,sum,temp,test,tmplam
|
||||
check=.false.
|
||||
sum=0.0d0
|
||||
do 11 i=1,n
|
||||
sum=sum+p(i)*p(i)
|
||||
11 continue
|
||||
sum=dsqrt(sum)
|
||||
if(sum.gt.stpmax)then
|
||||
do 12 i=1,n
|
||||
p(i)=p(i)*stpmax/sum
|
||||
12 continue
|
||||
endif
|
||||
slope=0.0d0
|
||||
do 13 i=1,n
|
||||
slope=slope+g(i)*p(i)
|
||||
13 continue
|
||||
! if(slope.ge.0.0d0)pause 'roundoff problem in lnsrch'
|
||||
test=0.0d0
|
||||
do 14 i=1,n
|
||||
temp=dabs(p(i))/dmax1(dabs(xold(i)),1.0d0)
|
||||
if(temp.gt.test)test=temp
|
||||
14 continue
|
||||
alamin=TOLX/test
|
||||
alam=1.0d0
|
||||
1 continue
|
||||
do 15 i=1,n
|
||||
x(i)=xold(i)+alam*p(i)
|
||||
15 continue
|
||||
call funcv(n,x,fvec,f)
|
||||
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.0d0)then
|
||||
tmplam=-slope/(2.0d0*(f-fold-slope))
|
||||
else
|
||||
rhs1=f-fold-alam*slope
|
||||
rhs2=f2-fold-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.0d0)then
|
||||
tmplam=-slope/(2.0d0*b)
|
||||
else
|
||||
disc=b*b-3.0d0*a*slope
|
||||
if(disc.lt.0.0d0) then
|
||||
tmplam=0.5d0*alam
|
||||
else if(b.le.0.0d0)then
|
||||
tmplam=(-b+dsqrt(disc))/(3.0d0*a)
|
||||
else
|
||||
tmplam=-slope/(b+dsqrt(disc))
|
||||
endif
|
||||
endif
|
||||
if(tmplam.gt..5d0*alam)tmplam=.5d0*alam
|
||||
endif
|
||||
endif
|
||||
alam2=alam
|
||||
f2=f
|
||||
alam=dmax1(tmplam,.1d0*alam)
|
||||
goto 1
|
||||
END
|
||||
c
|
||||
SUBROUTINE cpqrdcmp(a,n,np,c,d,sing)
|
||||
implicit none
|
||||
INTEGER n,np
|
||||
DOUBLE PRECISION a(np,np),c(n),d(n)
|
||||
LOGICAL sing
|
||||
INTEGER i,j,k
|
||||
DOUBLE PRECISION scale,sigma,sum,tau
|
||||
sing=.false.
|
||||
do 17 k=1,n-1
|
||||
scale=0.0d0
|
||||
do 11 i=k,n
|
||||
scale=dmax1(scale,dabs(a(i,k)))
|
||||
11 continue
|
||||
if(scale.eq.0.0d0)then
|
||||
sing=.true.
|
||||
c(k)=0.0d0
|
||||
d(k)=0.0d0
|
||||
else
|
||||
do 12 i=k,n
|
||||
a(i,k)=a(i,k)/scale
|
||||
12 continue
|
||||
sum=0.0d0
|
||||
do 13 i=k,n
|
||||
sum=sum+a(i,k)**2
|
||||
13 continue
|
||||
sigma=dsign(dsqrt(sum),a(k,k))
|
||||
a(k,k)=a(k,k)+sigma
|
||||
c(k)=sigma*a(k,k)
|
||||
d(k)=-scale*sigma
|
||||
do 16 j=k+1,n
|
||||
sum=0.0d0
|
||||
do 14 i=k,n
|
||||
sum=sum+a(i,k)*a(i,j)
|
||||
14 continue
|
||||
tau=sum/c(k)
|
||||
do 15 i=k,n
|
||||
a(i,j)=a(i,j)-tau*a(i,k)
|
||||
15 continue
|
||||
16 continue
|
||||
endif
|
||||
17 continue
|
||||
d(n)=a(n,n)
|
||||
if(d(n).eq.0.0d0)sing=.true.
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE cpqrupdt(r,qt,n,np,u,v)
|
||||
implicit none
|
||||
INTEGER n,np
|
||||
DOUBLE PRECISION r(np,np),qt(np,np),u(np),v(np)
|
||||
CU USES rotate
|
||||
INTEGER i,j,k
|
||||
do 11 k=n,1,-1
|
||||
if(u(k).ne.0.0d0)goto 1
|
||||
11 continue
|
||||
k=1
|
||||
1 do 12 i=k-1,1,-1
|
||||
call cprotate(r,qt,n,np,i,u(i),-u(i+1))
|
||||
if(u(i).eq.0.0d0)then
|
||||
u(i)=dabs(u(i+1))
|
||||
else if(dabs(u(i)).gt.dabs(u(i+1)))then
|
||||
u(i)=dabs(u(i))*dsqrt(1.0d0+(u(i+1)/u(i))**2)
|
||||
else
|
||||
u(i)=dabs(u(i+1))*dsqrt(1.0d0+(u(i)/u(i+1))**2)
|
||||
endif
|
||||
12 continue
|
||||
do 13 j=1,n
|
||||
r(1,j)=r(1,j)+u(1)*v(j)
|
||||
13 continue
|
||||
do 14 i=1,k-1
|
||||
call cprotate(r,qt,n,np,i,r(i,i),-r(i+1,i))
|
||||
14 continue
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE cprsolv(a,n,np,d,b)
|
||||
implicit none
|
||||
INTEGER n,np
|
||||
DOUBLE PRECISION a(np,np),b(n),d(n)
|
||||
INTEGER i,j
|
||||
DOUBLE PRECISION sum
|
||||
b(n)=b(n)/d(n)
|
||||
do 12 i=n-1,1,-1
|
||||
sum=0.0d0
|
||||
do 11 j=i+1,n
|
||||
sum=sum+a(i,j)*b(j)
|
||||
11 continue
|
||||
b(i)=(b(i)-sum)/d(i)
|
||||
12 continue
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE cprotate(r,qt,n,np,i,a,b)
|
||||
implicit none
|
||||
INTEGER n,np,i
|
||||
DOUBLE PRECISION a,b,r(np,np),qt(np,np)
|
||||
INTEGER j
|
||||
DOUBLE PRECISION c,fact,s,w,y
|
||||
if(a.eq.0.0d0)then
|
||||
c=0.0d0
|
||||
s=dsign(1.0d0,b)
|
||||
else if(dabs(a).gt.dabs(b))then
|
||||
fact=b/a
|
||||
c=dsign(1.0d0/dsqrt(1.0d0+fact**2),a)
|
||||
s=fact*c
|
||||
else
|
||||
fact=a/b
|
||||
s=dsign(1.0d0/dsqrt(1.0d0+fact**2),b)
|
||||
c=fact*s
|
||||
endif
|
||||
do 11 j=i,n
|
||||
y=r(i,j)
|
||||
w=r(i+1,j)
|
||||
r(i,j)=c*y-s*w
|
||||
r(i+1,j)=s*y+c*w
|
||||
11 continue
|
||||
do 12 j=1,n
|
||||
y=qt(i,j)
|
||||
w=qt(i+1,j)
|
||||
qt(i,j)=c*y-s*w
|
||||
qt(i+1,j)=s*y+c*w
|
||||
12 continue
|
||||
return
|
||||
END
|
||||
|
||||
subroutine cpxmprove(N,NP,a,b,x,mark)
|
||||
implicit none
|
||||
INTEGER i,j,idum,N,NP,indx(N),mark
|
||||
double precision d,a(NP,NP),b(N),x(N),aa(NP,NP)
|
||||
|
||||
do 12 i=1,N
|
||||
x(i)=b(i)
|
||||
do 11 j=1,N
|
||||
aa(i,j)=a(i,j)
|
||||
11 continue
|
||||
12 continue
|
||||
call cpludcmp(aa,N,NP,indx,d,mark)
|
||||
if (mark .eq. 0) goto 20
|
||||
call cplubksb(aa,N,NP,indx,x)
|
||||
call cpmprove(a,aa,N,NP,indx,b,x)
|
||||
20 continue
|
||||
return
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE cpmprove(a,alud,n,np,indx,b,x)
|
||||
implicit none
|
||||
INTEGER n,np,indx(n),NMAX
|
||||
double precision a(np,np),alud(np,np),b(n),x(n)
|
||||
PARAMETER (NMAX=500)
|
||||
CU USES lubksb
|
||||
INTEGER i,j
|
||||
double precision r(NMAX)
|
||||
DOUBLE PRECISION sdp
|
||||
do 12 i=1,n
|
||||
sdp=-b(i)
|
||||
do 11 j=1,n
|
||||
sdp=sdp+(a(i,j))*(x(j))
|
||||
11 continue
|
||||
r(i)=sdp
|
||||
12 continue
|
||||
call cplubksb(alud,n,np,indx,r)
|
||||
do 13 i=1,n
|
||||
x(i)=x(i)-r(i)
|
||||
13 continue
|
||||
return
|
||||
END
|
||||
|
||||
SUBROUTINE cpludcmp(a,n,np,indx,d,mark)
|
||||
implicit none
|
||||
INTEGER n,np,indx(n),NMAX
|
||||
double precision d,a(np,np),TINY
|
||||
PARAMETER (NMAX=500,TINY=1.0d-20)
|
||||
INTEGER i,imax,j,k,mark
|
||||
double precision aamax,dum,sum,vv(NMAX)
|
||||
mark=1
|
||||
d=1.0d0
|
||||
do 12 i=1,n
|
||||
aamax=0.0d0
|
||||
do 11 j=1,n
|
||||
if (dabs(a(i,j)).gt.aamax) aamax=dabs(a(i,j))
|
||||
11 continue
|
||||
if (aamax.eq.0.0d0) then
|
||||
! singular matrix
|
||||
mark=0
|
||||
return
|
||||
end if
|
||||
vv(i)=1.0d0/aamax
|
||||
12 continue
|
||||
do 19 j=1,n
|
||||
do 14 i=1,j-1
|
||||
sum=a(i,j)
|
||||
do 13 k=1,i-1
|
||||
sum=sum-a(i,k)*a(k,j)
|
||||
13 continue
|
||||
a(i,j)=sum
|
||||
14 continue
|
||||
aamax=0.0d0
|
||||
do 16 i=j,n
|
||||
sum=a(i,j)
|
||||
do 15 k=1,j-1
|
||||
sum=sum-a(i,k)*a(k,j)
|
||||
15 continue
|
||||
a(i,j)=sum
|
||||
dum=vv(i)*dabs(sum)
|
||||
if (dum.ge.aamax) then
|
||||
imax=i
|
||||
aamax=dum
|
||||
endif
|
||||
16 continue
|
||||
if (j.ne.imax)then
|
||||
do 17 k=1,n
|
||||
dum=a(imax,k)
|
||||
a(imax,k)=a(j,k)
|
||||
a(j,k)=dum
|
||||
17 continue
|
||||
d=-d
|
||||
vv(imax)=vv(j)
|
||||
endif
|
||||
indx(j)=imax
|
||||
if(a(j,j).eq.0.0d0)a(j,j)=TINY
|
||||
if(j.ne.n)then
|
||||
dum=1.0d0/a(j,j)
|
||||
do 18 i=j+1,n
|
||||
a(i,j)=a(i,j)*dum
|
||||
18 continue
|
||||
endif
|
||||
19 continue
|
||||
return
|
||||
END
|
||||
|
||||
SUBROUTINE cplubksb(a,n,np,indx,b)
|
||||
implicit none
|
||||
INTEGER n,np,indx(n)
|
||||
double precision a(np,np),b(n)
|
||||
INTEGER i,ii,j,ll
|
||||
double precision sum
|
||||
ii=0
|
||||
do 12 i=1,n
|
||||
ll=indx(i)
|
||||
sum=b(ll)
|
||||
b(ll)=b(i)
|
||||
if (ii.ne.0)then
|
||||
do 11 j=ii,i-1
|
||||
sum=sum-a(i,j)*b(j)
|
||||
11 continue
|
||||
else if (sum.ne.0.0d0) then
|
||||
ii=i
|
||||
endif
|
||||
b(i)=sum
|
||||
12 continue
|
||||
do 14 i=n,1,-1
|
||||
sum=b(i)
|
||||
do 13 j=i+1,n
|
||||
sum=sum-a(i,j)*b(j)
|
||||
13 continue
|
||||
b(i)=sum/a(i,i)
|
||||
14 continue
|
||||
return
|
||||
END
|
||||
@@ -0,0 +1,315 @@
|
||||
subroutine cpfixedpoint(funcnleq1,x0min,x0ori,xp,
|
||||
& x0max,fequ,nunknowns,TOLF,stpmax,iwhichsolver)
|
||||
implicit none
|
||||
include 'cpnslasystem.h'
|
||||
!-------- Inputs ---------------------------------------
|
||||
! nunknowns: The number of unknowns to be solved
|
||||
! x0ori(1:nunknowns): initial guess for the unknowns
|
||||
! x0min(1:nunknowns): lower bound of the solution
|
||||
! x0max(1:nunknowns): upper bound of the solution
|
||||
! stpmax: the maximum length of the steps allowed to prevent search into
|
||||
! undefined region.
|
||||
! TOLF: Error tolerance
|
||||
! funcnleq1: the subroutine name for the nonlinear system
|
||||
integer nunknowns
|
||||
double precision x0min(1:nunknowns),x0ori(1:nunknowns),
|
||||
& x0max(1:nunknowns),TOLF,stpmax
|
||||
! --------- Outputs -------------------------------------
|
||||
! fequ(1:nunknowns): function values at the last step of iteration
|
||||
! xp(1:nunknowns): final solutions or solutions not worse than x0ori
|
||||
! iwhichsolver: =1,2,3,4 successful
|
||||
! =-9999 failed, best solution returned
|
||||
integer iwhichsolver
|
||||
double precision fequ(1:nunknowns),xp(1:nunknowns)
|
||||
! ---------Local variables --------------------------------
|
||||
integer i,j,k,maxiter,notfound,ncount,ierr,
|
||||
& ismallest,iGuCall
|
||||
double precision swap,x1,x2,f1,f2,fsqsumold,
|
||||
& fsqsumnew,xpold(nunknowns),fequold(nunknowns),
|
||||
& gfuncsum(nunknowns),deltax(nunknowns),
|
||||
& xpder(nunknowns),fjacob(nunknowns,nunknowns),
|
||||
& fjacobcopy(nunknowns,nunknowns),fsqsum
|
||||
logical check
|
||||
parameter(maxiter=200,notfound=-9999,iGuCall=49)
|
||||
integer iselect(300*maxiter)
|
||||
logical resetran2
|
||||
common /cpran2reset/resetran2
|
||||
save /cpran2reset/
|
||||
external funcnleq1
|
||||
!-----------------------------------------------------------
|
||||
resetran2=.true.
|
||||
do i=1,nunknowns
|
||||
xp(i)=x0ori(i)
|
||||
enddo
|
||||
iwhichsolver=notfound
|
||||
numeval=0
|
||||
!--------------------------------------------------------------
|
||||
!Plain fixed-point method. Fixed-point method 1
|
||||
do i=1,maxiter
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
if(dabs(fequ(k)).lt.TOLF)then
|
||||
iwhichsolver=1
|
||||
return
|
||||
endif
|
||||
do j=1,nunknowns
|
||||
xp(j)=xp(j)-fequ(j)
|
||||
if(xp(j).lt.x0min(j).or.xp(j).gt.x0max(j))then
|
||||
call reinitialization(x0min(j),x0ori(j),
|
||||
& x0max(j),xp(j),50000)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
!_____________________________________________________________________
|
||||
!try fixed-point method 2
|
||||
do j=1,nunknowns
|
||||
call reinitialization(x0min(j),x0ori(j),
|
||||
& x0max(j),xp(j),10000)
|
||||
enddo
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
do i=1,nunknowns
|
||||
xp(i)=xp(i)-fequ(i)
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),2000)
|
||||
endif
|
||||
enddo
|
||||
do i=1,maxiter
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
if(dabs(fequ(k)).lt.TOLF)then
|
||||
iwhichsolver=2
|
||||
return
|
||||
endif
|
||||
do j=1,nunknowns
|
||||
ierr=0
|
||||
x1=xevaluated(numeval-1,j)
|
||||
f1=x1-fevaluated(numeval-1,j)
|
||||
x2=xevaluated(numeval,j)
|
||||
f2=x2-fevaluated(numeval,j)
|
||||
if(dabs(f2-f1-x2+x1).gt.1.0d-20)then
|
||||
ierr=1
|
||||
xp(j)=(x1*(f2-f1)-f1*(x2-x1))/
|
||||
& (f2-f1-x2+x1)
|
||||
if(xp(j).le.x0min(j).or.xp(j)
|
||||
& .ge.x0max(j))then
|
||||
ierr=0
|
||||
endif
|
||||
endif
|
||||
if(ierr.le.0.and.numeval.ge.3)then
|
||||
! haven't found a usable new point yet, first try the opposite sign point
|
||||
ncount=0
|
||||
do k=1,numeval-2
|
||||
if((fevaluated(k,j)*fevaluated(numeval,j))
|
||||
& .lt.0.0d0)then
|
||||
ncount=ncount+1
|
||||
iselect(ncount)=k
|
||||
endif
|
||||
enddo
|
||||
if(ncount.gt.0)then
|
||||
! there are points at different sides of the zero.
|
||||
ismallest=1
|
||||
do k=2,ncount
|
||||
if(dabs(xevaluated(iselect(k),j)-x2).lt.
|
||||
& dabs(xevaluated(iselect(ismallest),j)-x2))then
|
||||
ismallest=k
|
||||
endif
|
||||
enddo
|
||||
ierr=1
|
||||
x1=xevaluated(iselect(ismallest),j)
|
||||
f1=x1-fevaluated(iselect(ismallest),j)
|
||||
xp(j)=(x1*(f2-f1)-f1*(x2-x1))/
|
||||
& (f2-f1-x2+x1)
|
||||
else
|
||||
! all at the same sides of the zero.
|
||||
do k=1,numeval-2
|
||||
x1=xevaluated(k,j)
|
||||
f1=x1-fevaluated(k,j)
|
||||
if(dabs(f2-f1-x2+x1).gt.1.0d-10)then
|
||||
xp(j)=(x1*(f2-f1)-f1*(x2-x1))/
|
||||
& (f2-f1-x2+x1)
|
||||
if(xp(j).gt.x0min(j).and.xp(j).lt.x0max(j))then
|
||||
ierr=1
|
||||
endif
|
||||
endif
|
||||
if(ierr.eq.1)goto 10
|
||||
enddo
|
||||
10 continue
|
||||
endif
|
||||
endif
|
||||
if(ierr.eq.0)then
|
||||
call reinitialization(x0min(j),
|
||||
& xevaluated(numeval,j),x0max(j),xp(j),1000)
|
||||
endif
|
||||
enddo
|
||||
ierr=0
|
||||
do k=1,nunknowns
|
||||
if(xp(k).ne.xevaluated(numeval,k))ierr=1
|
||||
enddo
|
||||
if(ierr.eq.0)then
|
||||
do k=1,nunknowns
|
||||
call reinitialization(x0min(k),
|
||||
& xevaluated(numeval,k),x0max(k),xp(k),25000)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
!__________________________________________________________________
|
||||
!Try fixed-point method 3
|
||||
do i=1,nunknowns
|
||||
xp(i)=x0ori(i)+1.0d-6
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),250910)
|
||||
endif
|
||||
enddo
|
||||
do j=1,maxiter
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
if(dabs(fequ(k)).lt.TOLF)then
|
||||
iwhichsolver=3
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
xp(i)=xp(i)-fequ(i)
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),25500)
|
||||
endif
|
||||
enddo
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
if(dabs(fequ(k)).lt.TOLF)then
|
||||
iwhichsolver=3
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
if(fevaluated(numeval,i).eq.
|
||||
& fevaluated(numeval-1,i))then
|
||||
x1=(xevaluated(numeval,i)+
|
||||
& xevaluated(numeval-1,i))/2.0d0
|
||||
call reinitialization(x0min(i),x1,
|
||||
& x0max(i),xp(i),35678)
|
||||
else
|
||||
xp(i)=(xevaluated(numeval,i)*fevaluated(numeval-1,i)
|
||||
& -xevaluated(numeval-1,i)*fevaluated(numeval,i))/
|
||||
& (fevaluated(numeval-1,i)-fevaluated(numeval,i))
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),45678)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
!------------------------------------------------------------
|
||||
!Try fixed-point method 4
|
||||
|
||||
!11 call funcnleq1(nunknowns,xp,fequ,fsqsumold)
|
||||
! call cpbookkeeping(nunknowns,xp,fequ,iGuCall,i)
|
||||
|
||||
fsqsumold=0.0d0
|
||||
do i=1,nunknowns
|
||||
xpold(i)=xevaluated(1,i)
|
||||
fequold(i)=fevaluated(1,i)
|
||||
fsqsumold=fsqsumold+fequold(i)*fequold(i)
|
||||
enddo
|
||||
fsqsumold=0.5d0*fsqsumold
|
||||
do k=1,maxiter
|
||||
do j=1,nunknowns
|
||||
do i=1,nunknowns
|
||||
xpder(i)=xpold(i)
|
||||
enddo
|
||||
if(dabs(fequold(j)).lt.1.0d-10)then
|
||||
xpder(j)=xpold(j)+1.0d-5
|
||||
else
|
||||
xpder(j)=xpold(j)-fequold(j)
|
||||
endif
|
||||
if(xpder(j).lt.x0min(j).or.xpder(j).
|
||||
& gt.x0max(j))then
|
||||
call reinitialization(x0min(j),xpold(j),
|
||||
& x0max(j),xpder(j),89000)
|
||||
endif
|
||||
call funcnleq1(nunknowns,xpder,fequ,fsqsumnew)
|
||||
call cpbookkeeping(nunknowns,xpder,fequ,iGuCall,i)
|
||||
if(dabs(fequ(i)).lt.TOLF)then
|
||||
iwhichsolver=4
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
fjacob(i,j)=(fequ(i)-fequold(i))/
|
||||
& (xpder(j)-xpold(j))
|
||||
fjacobcopy(i,j)=fjacob(i,j)
|
||||
enddo
|
||||
gfuncsum(j)=(fsqsumnew-fsqsumold)/
|
||||
& (xpder(j)-xpold(j))
|
||||
enddo
|
||||
call cpxmprove(nunknowns,nunknowns,
|
||||
& fjacob,fequold,deltax,ierr)
|
||||
!if ierr = 0, matrix is singular. ierr = 1, everything is ok.
|
||||
if(ierr.eq.0)then
|
||||
call adsor(fjacobcopy,nunknowns,nunknowns,
|
||||
& fequold,deltax,ierr)
|
||||
if(ierr.ne.1)ierr=0
|
||||
endif
|
||||
if(ierr.ne.0)then
|
||||
do i=1,nunknowns
|
||||
deltax(i)=-deltax(i)
|
||||
enddo
|
||||
call cplnsrch(nunknowns,xpold,fsqsumold,
|
||||
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
||||
& check,funcnleq1,fequ)
|
||||
if(check.eq..true..or.check.eq..TRUE.)then
|
||||
do i=1,nunknowns
|
||||
call reinitialization(x0min(i),xpold(i),
|
||||
& x0max(i),xp(i),6678)
|
||||
enddo
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),678)
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
do i=1,nunknowns
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),75678)
|
||||
enddo
|
||||
endif
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsumold)
|
||||
call cpbookkeeping(nunknowns,xp,fequ,iGuCall,i)
|
||||
if(dabs(fequ(i)).lt.TOLF)then
|
||||
iwhichsolver=4
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
xpold(i)=xp(i)
|
||||
fequold(i)=fequ(i)
|
||||
enddo
|
||||
enddo
|
||||
!_____________________________________________________________
|
||||
!If all four methods failed, choose the best xp
|
||||
do i=1,numeval
|
||||
do k=i+1,numeval
|
||||
if(flargest(k).lt.flargest(i))then
|
||||
swap=flargest(k)
|
||||
flargest(k)=flargest(i)
|
||||
flargest(i)=swap
|
||||
do ncount=1,nunknowns
|
||||
swap=xevaluated(k,ncount)
|
||||
xevaluated(k,ncount)=xevaluated(i,ncount)
|
||||
xevaluated(i,ncount)=swap
|
||||
swap=fevaluated(k,ncount)
|
||||
fevaluated(k,ncount)=fevaluated(i,ncount)
|
||||
fevaluated(i,ncount)=swap
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
! Best solution found so far
|
||||
do i=1,nunknowns
|
||||
xp(i)=xevaluated(1,i)
|
||||
fequ(i)=fevaluated(1,i)
|
||||
enddo
|
||||
return
|
||||
end subroutine cpfixedpoint
|
||||
@@ -0,0 +1,116 @@
|
||||
subroutine cpnonsyssolver(funcnleq1,fmin_funcnleq1,
|
||||
& f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp,
|
||||
& nunknowns,iwhichsolver)
|
||||
implicit none
|
||||
integer nunknowns,iwhichsolver
|
||||
double precision x0min(nunknowns),x0ori(nunknowns),
|
||||
& xp(nunknowns),x0max(nunknowns),fp(nunknowns)
|
||||
!-------- Specified values ---------------------------------------
|
||||
!funcnleq1: the subroutine that calculates the functional values of the
|
||||
! the nonlinear system in the following form:
|
||||
! funcnleq1(nunknowns,xp,fp,fsqsum)
|
||||
!fmin_funcnleq1: the subroutine that calls funcnleq1 and returns fsqsum (half
|
||||
! of the sum of the squared functional values of the nonlinear system)
|
||||
! fmin_funcnleq1(nunknowns,xp,fsqsum)
|
||||
!f1dim_funcnleq1: a function subroutine that returns fsqsum
|
||||
! f1dim_funcnleq1(xp)
|
||||
! nunknowns: The number of unknowns to be solved
|
||||
! x0ori(1:nunknowns): initial guess for the unknowns
|
||||
! x0min(1:nunknowns): lower bound of the solution
|
||||
! x0max(1:nunknowns): upper bound of the solution
|
||||
! --------- Calculated values -------------------------------------
|
||||
! fp(1:nunknowns): function values at the last step of iteration
|
||||
! xp(1:nunknowns): final solutions
|
||||
! iwhichsolver:
|
||||
! =1 solved by plain fixed point method 1
|
||||
! =2 solved by fixed point method 2
|
||||
! =3 solved by fixed point method 3
|
||||
! =4 solved by fixed point method 4
|
||||
! =6 solved by broydn
|
||||
! =7 Solved by multiobjective minimization.
|
||||
! =-9999 Best approximation returned. Solution may not be accurate.
|
||||
! --------- Local variables ---------------------------------------
|
||||
double precision x0(nunknowns),TOLF,stpmax,scldstpmax,
|
||||
& sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,
|
||||
& f1dim_funcnleq1
|
||||
integer i,irepeat,maxrepeats,IERR,notfound
|
||||
intrinsic dble
|
||||
parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-10)
|
||||
external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1
|
||||
!-------------------------------------------------------------------
|
||||
stpmax=0.0d0
|
||||
sum=0.0d0
|
||||
do i=1, nunknowns
|
||||
x0(i)=x0ori(i)
|
||||
sum=sum+x0ori(i)*x0ori(i)
|
||||
stpmax=stpmax+
|
||||
& (x0min(i)-x0max(i))*(x0min(i)-x0max(i))
|
||||
enddo
|
||||
stpmax=dsqrt(stpmax)/4.0d0
|
||||
scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns))
|
||||
! In Numerical Recipes, scldstpmax (STPMX) is 100
|
||||
scldstpmax=dmax1(100.0d0,scldstpmax)
|
||||
iwhichsolver=notfound
|
||||
do irepeat=1,maxrepeats
|
||||
call cpfixedpoint(funcnleq1,x0min,x0,xp,
|
||||
& x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver)
|
||||
if(iwhichsolver.ne.notfound)return
|
||||
tp=dabs(fp(1))
|
||||
xb(1)=xp(1)
|
||||
do i=2,nunknowns
|
||||
if(dabs(fp(i)).gt.tp)tp=dabs(fp(i))
|
||||
xb(i)=xp(i)
|
||||
enddo
|
||||
call cpbroydn(x0min,xb,x0max,scldstpmax,nunknowns,
|
||||
& fb,funcnleq1,TOLF,IERR)
|
||||
call funcnleq1(nunknowns,xb,fb,fsqsum)
|
||||
tb=dabs(fb(1))
|
||||
do i=2,nunknowns
|
||||
if(dabs(fb(i)).gt.tb)tb=dabs(fb(i))
|
||||
enddo
|
||||
do i=1,nunknowns
|
||||
if(xb(i).lt.x0min(i).or.xb(i).gt.x0max(i))then
|
||||
tb=1.0d+100
|
||||
endif
|
||||
enddo
|
||||
if(tb.lt.tp)then
|
||||
do i=1,nunknowns
|
||||
xp(i)=xb(i)
|
||||
fp(i)=fb(i)
|
||||
enddo
|
||||
if(tb.lt.TOLF)then
|
||||
iwhichsolver=6
|
||||
return
|
||||
endif
|
||||
endif
|
||||
fsqsum=0.0d0
|
||||
do i=1,nunknowns
|
||||
fsqsum=fsqsum+fp(i)*fp(i)
|
||||
enddo
|
||||
tp=fsqsum
|
||||
call cpnongradopt(nunknowns,fmin_funcnleq1,
|
||||
& f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum)
|
||||
if(dabs(tp-fsqsum).gt.TOLF)then
|
||||
call cpRepeatCompassSearch(nunknowns,xp,fsqsum,
|
||||
& x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
|
||||
& TOLF)
|
||||
endif
|
||||
call funcnleq1(nunknowns,xp,fp,fsqsum)
|
||||
tp=dabs(fp(1))
|
||||
do i=2,nunknowns
|
||||
if(dabs(fp(i)).gt.tp)tp=dabs(fp(i))
|
||||
enddo
|
||||
if(tp.lt.TOLF)then
|
||||
iwhichsolver=7
|
||||
return
|
||||
endif
|
||||
IERR=0
|
||||
do i=1,nunknowns
|
||||
if(dabs(xp(i)-x0(i)).gt.TOLF)IERR=1
|
||||
enddo
|
||||
if(IERR.eq.0)return
|
||||
do i=1,nunknowns
|
||||
x0(i)=xp(i)
|
||||
enddo
|
||||
enddo
|
||||
end subroutine cpnonsyssolver
|
||||
@@ -0,0 +1,18 @@
|
||||
!------------------ Common Blocks -------------------------
|
||||
integer numeval,maxndim,maxeval
|
||||
parameter(maxndim=1000,maxeval=15000)
|
||||
double precision xevaluated,fevaluated,flargest
|
||||
common /cpFuncvRegresInteg/numeval
|
||||
common /cpFuncvRegresDble/xevaluated(1:maxeval,1:maxndim),
|
||||
& fevaluated(1:maxeval,1:maxndim),
|
||||
& flargest(1:maxeval)
|
||||
save /cpFuncvRegresInteg/,/cpFuncvRegresDble/
|
||||
! numeval: the number of times that the system is evaluated so far
|
||||
! iflargest: the index of the largest function for the latest evaluation
|
||||
! xevaluated: the positions where the system is evaluated
|
||||
! fevaluated: the function values at xevaluated
|
||||
! flargest: the largest absolute function value
|
||||
! maxndim: the maximum allowable dimensions of the system
|
||||
! maxeval: the maximum allowable number of function evaluations
|
||||
|
||||
!--------------------------------------------------------------
|
||||
@@ -0,0 +1,370 @@
|
||||
subroutine fixedpoint(funcnleq1,x0min,x0ori,xp,
|
||||
& x0max,fequ,nunknowns,TOLF,stpmax,iwhichsolver)
|
||||
implicit none
|
||||
include 'nslasystem.h'
|
||||
!-------- Inputs ---------------------------------------
|
||||
! nunknowns: The number of unknowns to be solved
|
||||
! x0ori(1:nunknowns): initial guess for the unknowns
|
||||
! x0min(1:nunknowns): lower bound of the solution
|
||||
! x0max(1:nunknowns): upper bound of the solution
|
||||
! stpmax: the maximum length of the steps allowed to prevent search into
|
||||
! undefined region.
|
||||
! TOLF: Error tolerance
|
||||
! funcnleq1: the subroutine name for the nonlinear system
|
||||
integer nunknowns
|
||||
double precision x0min(1:nunknowns),x0ori(1:nunknowns),
|
||||
& x0max(1:nunknowns),TOLF,stpmax
|
||||
! --------- Outputs -------------------------------------
|
||||
! fequ(1:nunknowns): function values at the last step of iteration
|
||||
! xp(1:nunknowns): final solutions or solutions not worse than x0ori
|
||||
! iwhichsolver: =0,1,2,3,4 successful
|
||||
! =-9999 failed, best solution returned
|
||||
integer iwhichsolver
|
||||
double precision fequ(1:nunknowns),xp(1:nunknowns)
|
||||
! ---------Local variables --------------------------------
|
||||
integer i,j,k,n,maxiter,notfound,ncount,ierr,
|
||||
& ismallest,iGuCall
|
||||
double precision swap,x1,x2,f1,f2,fsqsumold,
|
||||
& fsqsumnew,xpold(nunknowns),fequold(nunknowns),
|
||||
& gfuncsum(nunknowns),deltax(nunknowns),
|
||||
& xpder(nunknowns),fjacob(nunknowns,nunknowns),
|
||||
& fjacobcopy(nunknowns,nunknowns),fsqsum,term
|
||||
logical check
|
||||
parameter(maxiter=200,notfound=-9999,iGuCall=49)
|
||||
integer iselect(300*maxiter)
|
||||
logical resetran2
|
||||
common /ran2reset/resetran2
|
||||
save /ran2reset/
|
||||
external funcnleq1
|
||||
!-----------------------------------------------------------
|
||||
resetran2=.true.
|
||||
do i=1,nunknowns
|
||||
xp(i)=x0ori(i)
|
||||
enddo
|
||||
iwhichsolver=notfound
|
||||
numeval=0
|
||||
!--------------------------------------------------------------
|
||||
!Plain fixed-point method. Fixed-point method 1
|
||||
do i=1,maxiter
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call bookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
if(dabs(fequ(k)).lt.TOLF)then
|
||||
iwhichsolver=1
|
||||
return
|
||||
endif
|
||||
do j=1,nunknowns
|
||||
xp(j)=xp(j)-fequ(j)
|
||||
if(xp(j).lt.x0min(j).or.xp(j).gt.x0max(j))then
|
||||
call reinitialization(x0min(j),x0ori(j),
|
||||
& x0max(j),xp(j),50000)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
!_____________________________________________________________________
|
||||
!try approximation to the newton method, iwhichsolver=0. this would work
|
||||
!if the equations are independent
|
||||
1 do i=1,nunknowns
|
||||
xp(i)=x0ori(i)
|
||||
enddo
|
||||
do i=1,maxiter
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
n=0
|
||||
do j=1,nunknowns
|
||||
if(dabs(fequ(j)).gt.0.0d0)then
|
||||
else
|
||||
n=1
|
||||
call reinitialization(x0min(j),x0ori(j),
|
||||
& x0max(j),xp(j),50000)
|
||||
endif
|
||||
enddo
|
||||
if(n.ne.0)goto 2
|
||||
call bookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
if(dabs(fequ(k)).lt.TOLF)then
|
||||
iwhichsolver=0
|
||||
return
|
||||
endif
|
||||
do j=1,nunknowns
|
||||
xpold(j)=xp(j)
|
||||
fequold(j)=fequ(j)
|
||||
xp(j)=xp(j)+fequ(j)
|
||||
enddo
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
do j=1,nunknowns
|
||||
if(dabs(fequ(j)).gt.0.0d0)then
|
||||
else
|
||||
n=1
|
||||
call reinitialization(x0min(j),x0ori(j),
|
||||
& x0max(j),xp(j),50000)
|
||||
endif
|
||||
enddo
|
||||
if(n.ne.0)goto 2
|
||||
call bookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
do j=1,nunknowns
|
||||
if(fequ(j).ne.fequold(j))then
|
||||
xpder(j)=fequold(j)/(fequ(j)-fequold(j))
|
||||
else
|
||||
xpder(j)=0.0d0
|
||||
endif
|
||||
xp(j)=xpold(j)-xpder(j)*fequold(j)
|
||||
if(xp(j).lt.x0min(j).or.xp(j).gt.x0max(j))then
|
||||
call reinitialization(x0min(j),x0ori(j),
|
||||
& x0max(j),xp(j),50000)
|
||||
endif
|
||||
enddo
|
||||
2 continue
|
||||
enddo
|
||||
!_____________________________________________________________________
|
||||
!try fixed-point method 2
|
||||
do j=1,nunknowns
|
||||
call reinitialization(x0min(j),x0ori(j),
|
||||
& x0max(j),xp(j),10000)
|
||||
enddo
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call bookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
do i=1,nunknowns
|
||||
xp(i)=xp(i)-fequ(i)
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),2000)
|
||||
endif
|
||||
enddo
|
||||
do i=1,maxiter
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call bookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
if(dabs(fequ(k)).lt.TOLF)then
|
||||
iwhichsolver=2
|
||||
return
|
||||
endif
|
||||
do j=1,nunknowns
|
||||
ierr=0
|
||||
x1=xevaluated(numeval-1,j)
|
||||
f1=x1-fevaluated(numeval-1,j)
|
||||
x2=xevaluated(numeval,j)
|
||||
f2=x2-fevaluated(numeval,j)
|
||||
if(dabs(f2-f1-x2+x1).gt.1.0d-20)then
|
||||
ierr=1
|
||||
xp(j)=(x1*(f2-f1)-f1*(x2-x1))/
|
||||
& (f2-f1-x2+x1)
|
||||
if(xp(j).le.x0min(j).or.xp(j)
|
||||
& .ge.x0max(j))then
|
||||
ierr=0
|
||||
endif
|
||||
endif
|
||||
if(ierr.le.0.and.numeval.ge.3)then
|
||||
! haven't found a usable new point yet, first try the opposite sign point
|
||||
ncount=0
|
||||
do k=1,numeval-2
|
||||
if((fevaluated(k,j)*fevaluated(numeval,j))
|
||||
& .lt.0.0d0)then
|
||||
ncount=ncount+1
|
||||
iselect(ncount)=k
|
||||
endif
|
||||
enddo
|
||||
if(ncount.gt.0)then
|
||||
! there are points at different sides of the zero.
|
||||
ismallest=1
|
||||
do k=2,ncount
|
||||
if(dabs(xevaluated(iselect(k),j)-x2).lt.
|
||||
& dabs(xevaluated(iselect(ismallest),j)-x2))then
|
||||
ismallest=k
|
||||
endif
|
||||
enddo
|
||||
ierr=1
|
||||
x1=xevaluated(iselect(ismallest),j)
|
||||
f1=x1-fevaluated(iselect(ismallest),j)
|
||||
xp(j)=(x1*(f2-f1)-f1*(x2-x1))/
|
||||
& (f2-f1-x2+x1)
|
||||
else
|
||||
! all at the same sides of the zero.
|
||||
do k=1,numeval-2
|
||||
x1=xevaluated(k,j)
|
||||
f1=x1-fevaluated(k,j)
|
||||
if(dabs(f2-f1-x2+x1).gt.1.0d-10)then
|
||||
xp(j)=(x1*(f2-f1)-f1*(x2-x1))/
|
||||
& (f2-f1-x2+x1)
|
||||
if(xp(j).gt.x0min(j).and.xp(j).lt.x0max(j))then
|
||||
ierr=1
|
||||
endif
|
||||
endif
|
||||
if(ierr.eq.1)goto 10
|
||||
enddo
|
||||
10 continue
|
||||
endif
|
||||
endif
|
||||
if(ierr.eq.0)then
|
||||
call reinitialization(x0min(j),
|
||||
& xevaluated(numeval,j),x0max(j),xp(j),1000)
|
||||
endif
|
||||
enddo
|
||||
ierr=0
|
||||
do k=1,nunknowns
|
||||
if(xp(k).ne.xevaluated(numeval,k))ierr=1
|
||||
enddo
|
||||
if(ierr.eq.0)then
|
||||
do k=1,nunknowns
|
||||
call reinitialization(x0min(k),
|
||||
& xevaluated(numeval,k),x0max(k),xp(k),25000)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
!__________________________________________________________________
|
||||
!Try fixed-point method 3
|
||||
do i=1,nunknowns
|
||||
xp(i)=x0ori(i)+1.0d-6
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),250910)
|
||||
endif
|
||||
enddo
|
||||
do j=1,maxiter
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call bookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
if(dabs(fequ(k)).lt.TOLF)then
|
||||
iwhichsolver=3
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
xp(i)=xp(i)-fequ(i)
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),25500)
|
||||
endif
|
||||
enddo
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsum)
|
||||
call bookkeeping(nunknowns,xp,fequ,iGuCall,k)
|
||||
if(dabs(fequ(k)).lt.TOLF)then
|
||||
iwhichsolver=3
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
if(fevaluated(numeval,i).eq.
|
||||
& fevaluated(numeval-1,i))then
|
||||
x1=(xevaluated(numeval,i)+
|
||||
& xevaluated(numeval-1,i))/2.0d0
|
||||
call reinitialization(x0min(i),x1,
|
||||
& x0max(i),xp(i),35678)
|
||||
else
|
||||
xp(i)=(xevaluated(numeval,i)*fevaluated(numeval-1,i)
|
||||
& -xevaluated(numeval-1,i)*fevaluated(numeval,i))/
|
||||
& (fevaluated(numeval-1,i)-fevaluated(numeval,i))
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),45678)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
!------------------------------------------------------------
|
||||
!Try fixed-point method 4
|
||||
|
||||
!11 call funcnleq1(nunknowns,xp,fequ,fsqsumold)
|
||||
! call bookkeeping(nunknowns,xp,fequ,iGuCall,i)
|
||||
|
||||
fsqsumold=0.0d0
|
||||
do i=1,nunknowns
|
||||
xpold(i)=xevaluated(numeval,i)
|
||||
fequold(i)=fevaluated(numeval,i)
|
||||
fsqsumold=fsqsumold+fequold(i)*fequold(i)
|
||||
enddo
|
||||
term=fsqsumold
|
||||
do k=1,maxiter/5
|
||||
do j=1,nunknowns
|
||||
do i=1,nunknowns
|
||||
xpder(i)=xpold(i)
|
||||
enddo
|
||||
if(dabs(fequold(j)).lt.1.0d-10)then
|
||||
xpder(j)=xpold(j)+1.0d-5
|
||||
else
|
||||
xpder(j)=xpold(j)-fequold(j)
|
||||
endif
|
||||
if(xpder(j).lt.x0min(j).or.xpder(j).
|
||||
& gt.x0max(j))then
|
||||
call reinitialization(x0min(j),xpold(j),
|
||||
& x0max(j),xpder(j),89000)
|
||||
endif
|
||||
call funcnleq1(nunknowns,xpder,fequ,fsqsumnew)
|
||||
call bookkeeping(nunknowns,xpder,fequ,iGuCall,i)
|
||||
if(dabs(fequ(i)).lt.TOLF)then
|
||||
iwhichsolver=4
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
fjacob(i,j)=(fequ(i)-fequold(i))/
|
||||
& (xpder(j)-xpold(j))
|
||||
fjacobcopy(i,j)=fjacob(i,j)
|
||||
enddo
|
||||
gfuncsum(j)=(fsqsumnew-fsqsumold)/
|
||||
& (xpder(j)-xpold(j))
|
||||
enddo
|
||||
call xmprove(nunknowns,nunknowns,
|
||||
& fjacob,fequold,deltax,ierr)
|
||||
!if ierr = 0, matrix is singular. ierr = 1, everything is ok.
|
||||
if(ierr.eq.0)then
|
||||
call adsor(fjacobcopy,nunknowns,nunknowns,
|
||||
& fequold,deltax,ierr)
|
||||
if(ierr.ne.1)ierr=0
|
||||
endif
|
||||
if(ierr.ne.0)then
|
||||
do i=1,nunknowns
|
||||
deltax(i)=-deltax(i)
|
||||
enddo
|
||||
call lnsrch(nunknowns,xpold,fsqsumold,
|
||||
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
||||
& check,funcnleq1,fequ)
|
||||
if(check.eq..true..or.check.eq..TRUE.)then
|
||||
do i=1,nunknowns
|
||||
call reinitialization(x0min(i),xpold(i),
|
||||
& x0max(i),xp(i),6678)
|
||||
enddo
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),678)
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
do i=1,nunknowns
|
||||
call reinitialization(x0min(i),x0ori(i),
|
||||
& x0max(i),xp(i),75678)
|
||||
enddo
|
||||
endif
|
||||
call funcnleq1(nunknowns,xp,fequ,fsqsumold)
|
||||
call bookkeeping(nunknowns,xp,fequ,iGuCall,i)
|
||||
if(dabs(fequ(i)).lt.TOLF)then
|
||||
iwhichsolver=4
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
xpold(i)=xp(i)
|
||||
fequold(i)=fequ(i)
|
||||
enddo
|
||||
if(fsqsumold.ge.term)goto 30
|
||||
term=fsqsumold
|
||||
enddo
|
||||
!_____________________________________________________________
|
||||
!If all four methods failed, choose the best xp
|
||||
30 do i=1,numeval
|
||||
do k=i+1,numeval
|
||||
if(flargest(k).lt.flargest(i))then
|
||||
swap=flargest(k)
|
||||
flargest(k)=flargest(i)
|
||||
flargest(i)=swap
|
||||
do ncount=1,nunknowns
|
||||
swap=xevaluated(k,ncount)
|
||||
xevaluated(k,ncount)=xevaluated(i,ncount)
|
||||
xevaluated(i,ncount)=swap
|
||||
swap=fevaluated(k,ncount)
|
||||
fevaluated(k,ncount)=fevaluated(i,ncount)
|
||||
fevaluated(i,ncount)=swap
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
! Best solution found so far
|
||||
do i=1,nunknowns
|
||||
xp(i)=xevaluated(1,i)
|
||||
fequ(i)=fevaluated(1,i)
|
||||
enddo
|
||||
return
|
||||
end subroutine fixedpoint
|
||||
@@ -0,0 +1,115 @@
|
||||
subroutine nonsyssolver(funcnleq1,fmin_funcnleq1,
|
||||
& f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp,
|
||||
& nunknowns,iwhichsolver)
|
||||
implicit none
|
||||
integer nunknowns,iwhichsolver
|
||||
double precision x0min(nunknowns),x0ori(nunknowns),
|
||||
& xp(nunknowns),x0max(nunknowns),fp(nunknowns)
|
||||
!-------- Specified values ---------------------------------------
|
||||
!funcnleq1: the subroutine that calculates the functional values of the
|
||||
! the nonlinear system in the following form:
|
||||
! funcnleq1(nunknowns,xp,fp,fsqsum)
|
||||
!fmin_funcnleq1: the subroutine that calls funcnleq1 and returns fsqsum
|
||||
! fmin_funcnleq1(nunknowns,xp,fsqsum)
|
||||
!f1dim_funcnleq1: a function subroutine that returns fsqsum
|
||||
! f1dim_funcnleq1(xp)
|
||||
! nunknowns: The number of unknowns to be solved
|
||||
! x0ori(1:nunknowns): initial guess for the unknowns
|
||||
! x0min(1:nunknowns): lower bound of the solution
|
||||
! x0max(1:nunknowns): upper bound of the solution
|
||||
! --------- Calculated values -------------------------------------
|
||||
! fp(1:nunknowns): function values at the last step of iteration
|
||||
! xp(1:nunknowns): final solutions
|
||||
! iwhichsolver:
|
||||
! =1 solved by plain fixed point method 1
|
||||
! =2 solved by fixed point method 2
|
||||
! =3 solved by fixed point method 3
|
||||
! =4 solved by fixed point method 4
|
||||
! =6 solved by broydn
|
||||
! =7 Solved by multiobjective minimization.
|
||||
! =-9999 Best approximation returned. Solution may not be accurate.
|
||||
! --------- Local variables ---------------------------------------
|
||||
double precision x0(nunknowns),TOLF,stpmax,scldstpmax,
|
||||
& sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,
|
||||
& f1dim_funcnleq1
|
||||
integer i,irepeat,maxrepeats,IERR,notfound
|
||||
intrinsic dble
|
||||
parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-7)
|
||||
external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1
|
||||
!-------------------------------------------------------------------
|
||||
stpmax=0.0d0
|
||||
sum=0.0d0
|
||||
do i=1, nunknowns
|
||||
x0(i)=x0ori(i)
|
||||
sum=sum+x0ori(i)*x0ori(i)
|
||||
stpmax=stpmax+
|
||||
& (x0min(i)-x0max(i))*(x0min(i)-x0max(i))
|
||||
enddo
|
||||
stpmax=dsqrt(stpmax)/4.0d0
|
||||
scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns))
|
||||
! In Numerical Recipes, scldstpmax (STPMX) is 100
|
||||
scldstpmax=dmax1(100.0d0,scldstpmax)
|
||||
iwhichsolver=notfound
|
||||
do irepeat=1,maxrepeats
|
||||
call fixedpoint(funcnleq1,x0min,x0,xp,
|
||||
& x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver)
|
||||
if(iwhichsolver.ne.notfound)return
|
||||
tp=dabs(fp(1))
|
||||
xb(1)=xp(1)
|
||||
do i=2,nunknowns
|
||||
if(dabs(fp(i)).gt.tp)tp=dabs(fp(i))
|
||||
xb(i)=xp(i)
|
||||
enddo
|
||||
call broydn(x0min,xb,x0max,scldstpmax,nunknowns,
|
||||
& fb,funcnleq1,TOLF,IERR)
|
||||
call funcnleq1(nunknowns,xb,fb,fsqsum)
|
||||
tb=dabs(fb(1))
|
||||
do i=2,nunknowns
|
||||
if(dabs(fb(i)).gt.tb)tb=dabs(fb(i))
|
||||
enddo
|
||||
do i=1,nunknowns
|
||||
if(xb(i).lt.x0min(i).or.xb(i).gt.x0max(i))then
|
||||
tb=1.0d+100
|
||||
endif
|
||||
enddo
|
||||
if(tb.lt.tp)then
|
||||
do i=1,nunknowns
|
||||
xp(i)=xb(i)
|
||||
fp(i)=fb(i)
|
||||
enddo
|
||||
if(tb.lt.TOLF)then
|
||||
iwhichsolver=6
|
||||
return
|
||||
endif
|
||||
endif
|
||||
fsqsum=0.0d0
|
||||
do i=1,nunknowns
|
||||
fsqsum=fsqsum+fp(i)*fp(i)
|
||||
enddo
|
||||
tp=fsqsum
|
||||
call nongradopt(nunknowns,fmin_funcnleq1,
|
||||
& f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum)
|
||||
! if(dabs(tp-fsqsum).gt.TOLF)then
|
||||
! call RepeatCompassSearch(nunknowns,xp,fsqsum,
|
||||
! & x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
|
||||
! & TOLF)
|
||||
! endif
|
||||
call funcnleq1(nunknowns,xp,fp,fsqsum)
|
||||
tp=dabs(fp(1))
|
||||
do i=2,nunknowns
|
||||
if(dabs(fp(i)).gt.tp)tp=dabs(fp(i))
|
||||
enddo
|
||||
if(tp.lt.TOLF)then
|
||||
iwhichsolver=7
|
||||
return
|
||||
endif
|
||||
IERR=0
|
||||
do i=1,nunknowns
|
||||
if(dabs(xp(i)-x0(i)).gt.TOLF)IERR=1
|
||||
enddo
|
||||
if(IERR.eq.0)return
|
||||
do i=1,nunknowns
|
||||
x0(i)=xp(i)
|
||||
enddo
|
||||
enddo
|
||||
end subroutine nonsyssolver
|
||||
@@ -0,0 +1,18 @@
|
||||
!------------------ Common Blocks -------------------------
|
||||
integer numeval,maxndim,maxeval
|
||||
parameter(maxndim=1000,maxeval=15000)
|
||||
double precision xevaluated,fevaluated,flargest
|
||||
common /FuncvRegresInteg/numeval
|
||||
common /FuncvRegresDble/xevaluated(1:maxeval,1:maxndim),
|
||||
& fevaluated(1:maxeval,1:maxndim),
|
||||
& flargest(1:maxeval)
|
||||
save /FuncvRegresInteg/,/FuncvRegresDble/
|
||||
! numeval: the number of times that the system is evaluated so far
|
||||
! iflargest: the index of the largest function for the latest evaluation
|
||||
! xevaluated: the positions where the system is evaluated
|
||||
! fevaluated: the function values at xevaluated
|
||||
! flargest: the largest absolute function value
|
||||
! maxndim: the maximum allowable dimensions of the system
|
||||
! maxeval: the maximum allowable number of function evaluations
|
||||
|
||||
!--------------------------------------------------------------
|
||||
@@ -0,0 +1,85 @@
|
||||
program test
|
||||
implicit none
|
||||
integer nunknowns,iwhichsolver,i,j
|
||||
double precision x0min(11),x0ori(11),xp(11),
|
||||
& x0max(11),fequ(11),f1dim_funcsys
|
||||
external funcsys,fsqsum_funcsys,f1dim_funcsys
|
||||
|
||||
nunknowns=11
|
||||
do i=1,nunknowns
|
||||
x0min(i)=-0.00001d0
|
||||
x0ori(i)=1.0d0
|
||||
x0max(i)=100.0d0
|
||||
enddo
|
||||
nunknowns=2
|
||||
x0ori(1)=0.0d0
|
||||
x0ori(2)=3.0d0
|
||||
call nonsyssolver(funcsys,fsqsum_funcsys,
|
||||
& f1dim_funcsys,x0min,x0ori,xp,x0max,
|
||||
& fequ,nunknowns,iwhichsolver)
|
||||
do i=1,nunknowns
|
||||
write(*,*)fequ(i),xp(i),iwhichsolver
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine funcsys(nunknowns,x,f,fsqsum)
|
||||
implicit none
|
||||
integer nunknowns,i
|
||||
double precision x(nunknowns),f(nunknowns),
|
||||
& fsqsum
|
||||
double precision R,p,K5,K6,K7,K8,K9,K10
|
||||
parameter(R=10.0d0,p=40.0d0,
|
||||
& K5=1.0d0,K6=1.0d0,
|
||||
& K7=1.0d0,K8=0.1d0,
|
||||
& K9=1.0d0,K10=0.1d0)
|
||||
|
||||
f(1)=x(1)-(1.0d0+0.5d0*dsin(x(1)))
|
||||
f(2)=x(2)-(3.0d0+2.0d0*dsin(x(2)))
|
||||
|
||||
! Combustion of propane problem
|
||||
! f(1)=x(1)-(3.0d0-x(4))
|
||||
! f(2)=x(2)-(R-2.0d0*x(1)-x(4)-x(7)-
|
||||
! & x(8)-x(9)-2.0d0*x(10))
|
||||
! f(3)=x(3)-(2.0d0*R-0.5d0*x(9))
|
||||
! f(4)=x(4)-x(1)*x(5)/(K5*x(2))
|
||||
! f(5)=x(5)-(4-x(2)-0.5d0*x(6)-0.5d0*x(7))
|
||||
! f(6)=x(6)-K6*dsqrt(x(2)*x(4)*x(11)/(p*x(1)))
|
||||
! f(7)=x(7)-K7*dsqrt(x(1)*x(2)*x(11)/(p*x(4)))
|
||||
! f(8)=x(8)-K8*x(1)*x(11)/(p*x(4))
|
||||
! f(9)=x(9)-K9*(x(1)/x(4))*dsqrt(x(3)*x(11)/p)
|
||||
! f(10)=x(10)-K10*x(1)*x(1)*x(11)/(p*x(4)*x(4))
|
||||
! f(11)=x(11)-(x(1)+x(2)+x(3)+x(4)+x(5)+x(6)
|
||||
! & +x(7)+x(8)+x(9)+x(10))
|
||||
fsqsum=0.0d0
|
||||
do i=1,nunknowns
|
||||
fsqsum=fsqsum+f(i)*f(i)
|
||||
enddo
|
||||
fsqsum=0.5d0*fsqsum
|
||||
return
|
||||
end
|
||||
|
||||
subroutine fsqsum_funcsys(nunknowns,xp,fsqsum)
|
||||
implicit none
|
||||
integer nunknowns
|
||||
double precision xp(nunknowns),fsqsum,
|
||||
& fequ(nunknowns)
|
||||
call funcsys(nunknowns,xp,fequ,fsqsum)
|
||||
return
|
||||
end
|
||||
|
||||
double precision function f1dim_funcsys(x)
|
||||
INTEGER NMAX
|
||||
double precision x
|
||||
PARAMETER (NMAX=1000)
|
||||
CU USES funcsys
|
||||
INTEGER j,ncom
|
||||
double precision pcom(NMAX),xicom(NMAX),
|
||||
& xt(NMAX),fequ(NMAX)
|
||||
COMMON /f1com/ pcom,xicom,ncom
|
||||
save /f1com/
|
||||
do 11 j=1,ncom
|
||||
xt(j)=pcom(j)+x*xicom(j)
|
||||
11 continue
|
||||
call funcsys(ncom,xt,fequ,f1dim_funcsys)
|
||||
return
|
||||
END
|
||||
Reference in New Issue
Block a user