Initial commit
This commit is contained in:
@@ -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
|
||||
Reference in New Issue
Block a user