Files
piscal/dataassim/math/nonlinsystems/testexample.f
T
2016-02-03 18:52:05 +00:00

86 lines
2.4 KiB
FortranFixed

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