228 lines
7.0 KiB
FortranFixed
228 lines
7.0 KiB
FortranFixed
subroutine surffunc(nyvars,yvars,nxvars,
|
|
& xvars,ndim,beta,dydxp,idowhat)
|
|
implicit none
|
|
!idowhat=0, value of the function only
|
|
!idowhat=1, derivative with respect to the independent variable x
|
|
!idowhat=2, derivative with respect to the parameters
|
|
integer nyvars,nxvars,ndim,idowhat
|
|
double precision yvars(nyvars),xvars(nxvars),
|
|
&beta(5),dydxp(nyvars,(nxvars+5))
|
|
!-------------------------------------------------------
|
|
double precision y0,a,b,c,x0,x,term,crit
|
|
parameter(crit=300.0d0)
|
|
a=beta(1)
|
|
b=beta(2)
|
|
c=beta(3)
|
|
x=xvars(1)
|
|
if(ndim.eq.3)then
|
|
term=dexp(-b*x)
|
|
if(idowhat.eq.0)yvars(1)=c+a*(1.0d0-term)
|
|
if(idowhat.eq.1)then
|
|
dydxp(1,1)=a*b*term
|
|
endif
|
|
if(idowhat.eq.2)then
|
|
dydxp(1,1)=1.0d0-term
|
|
dydxp(1,2)=a*x*term
|
|
dydxp(1,3)=1.0d0
|
|
endif
|
|
return
|
|
endif
|
|
if(ndim.eq.4)then
|
|
x0=beta(4)
|
|
if(idowhat.eq.0)yvars(1)=a*(1.0d0-b*x)*(x-x0)/(1.0d0+c*x)
|
|
if(idowhat.eq.1)then
|
|
dydxp(1,1)=a*(1.0d0-2.0d0*b*x-b*c*x*x+(b+c)*x0)/
|
|
&((1.0d0+c*x)*(1.0d0+c*x))
|
|
endif
|
|
if(idowhat.eq.2)then
|
|
dydxp(1,1)=(1.0d0-b*x)*(x-x0)/(1.0d0+c*x)
|
|
dydxp(1,2)=a*(1.0d0-x)*(x-x0)/(1.0d0+c*x)
|
|
dydxp(1,3)=-a*(1.0d0-b*x)*(x-x0)*x/((1.0d0+c*x)*(1.0d0+c*x))
|
|
dydxp(1,4)=-a*(1.0d0-b*x)/(1.0d0+c*x)
|
|
endif
|
|
return
|
|
endif
|
|
! if(ndim.eq.3)then
|
|
! yvars(1)=(1.0d0+a*x)/(b+c*x)
|
|
! if(idowhat.eq.0)return
|
|
! if(idowhat.eq.1)then
|
|
! dydxp(1,1)=(a-yvars(1)*c)/(b+c*x)
|
|
! return
|
|
! endif
|
|
! if(idowhat.eq.2)then
|
|
! dydxp(1,1)=x/(b+c*x)
|
|
! dydxp(1,2)=-yvars(1)/(b+c*x)
|
|
! dydxp(1,3)=-yvars(1)*dydxp(1,1)
|
|
! return
|
|
! endif
|
|
! endif
|
|
|
|
!A/Ci or A/PAR curves
|
|
x0=beta(4)
|
|
y0=beta(5)
|
|
if(idowhat.eq.0)then
|
|
if((-(x-x0)/b).lt.crit)then
|
|
term=dexp(-(x-x0)/b)
|
|
yvars(1)=y0+a*(1.0d0/(1.0d0+term))**c
|
|
else
|
|
term=dexp((x-x0)/b)
|
|
yvars(1)=y0+a*(term/(1.0d0+term))**c
|
|
endif
|
|
endif
|
|
if(idowhat.eq.1)then
|
|
if((-(x-x0)/b).lt.crit)then
|
|
term=dexp(-(x-x0)/b)
|
|
dydxp(1,1)=(a*c*term/b)*
|
|
& (1.0d0/(1.0d0+term))**(1.0d0+c)
|
|
else
|
|
term=(x-x0)/b
|
|
dydxp(1,1)=(a*c/b)*(dexp(term*c/(c+1.0d0))/
|
|
& (1.0d0+dexp(term)))**(c+1.0d0)
|
|
endif
|
|
endif
|
|
if(idowhat.eq.2)then
|
|
dydxp(1,5)=1.0d0
|
|
if((-(x-x0)/b).lt.crit)then
|
|
term=dexp(-(x-x0)/b)
|
|
dydxp(1,1)=(1.0d0/(1.0d0+term))**c
|
|
dydxp(1,4)=-(a*c*term/b)*
|
|
& (1.0d0/(1.0d0+term))**(1.0d0+c)
|
|
dydxp(1,2)=-(a*c*term*(x-x0)/(b*b))*
|
|
& (1.0d0/(1.0d0+term))**(1.0d0+c)
|
|
dydxp(1,3)=-(a*dlog(1.0d0+term))*
|
|
& (1.0d0/(1.0d0+term))**c
|
|
else
|
|
term=(x-x0)/b
|
|
dydxp(1,1)=(dexp(term)/(1.0d0+dexp(term)))**c
|
|
dydxp(1,4)=-(a*c/b)*(dexp(term*c/(c+1))/
|
|
& (1.0d0+dexp(term)))**(c+1.0d0)
|
|
dydxp(1,2)=-(a*c*(x-x0)/(b*b))*(dexp(term*c/
|
|
& (c+1.0d0))/(1.0d0+dexp(term)))**(1.0d0+c)
|
|
dydxp(1,3)=-a*(dlog(1.0d0+dexp(term))-term)*
|
|
& (dexp(term)/(1.0d0+dexp(term)))**c
|
|
endif
|
|
endif
|
|
return
|
|
end
|
|
!==========================================================
|
|
subroutine properties_surffunc(ndim,beta,root,der_root,fmax,
|
|
&yinter,der_yinter,agivenx,der_agivenx,funcval_agivenx,
|
|
&xmin,xmax,curvatmax,xcurvatmax)
|
|
implicit none
|
|
integer ndim
|
|
double precision beta(5),root,der_root,fmax,yinter,der_yinter,
|
|
&agivenx,der_agivenx,funcval_agivenx,xmin,xmax,curvatmax,xcurvatmax
|
|
double precision a,b,c,x0,y0,term,term1,term2,term3,step,
|
|
&deratx,der2atx
|
|
|
|
a=beta(1)
|
|
b=beta(2)
|
|
c=beta(3)
|
|
|
|
if(ndim.eq.3)then
|
|
!y=c+a(1-exp(-bx))
|
|
root=-dlog(1.0d0+c/a)/b
|
|
der_root=a*b*dexp(-b*root)
|
|
fmax=c+a
|
|
yinter=c
|
|
der_yinter=a*b
|
|
funcval_agivenx=c+a*(1.0d0-dexp(-b*agivenx))
|
|
der_agivenx=a*b*dexp(-b*agivenx)
|
|
xcurvatmax=dlog(2*a*a*b*b)/(2.0d0*b)
|
|
! curvatmax=-a*b*b*dexp(-b*xcurvatmax)/
|
|
! &((1.0d0+a*a*b*b*dexp(-2.0d0*b*xcurvatmax))**1.5d0)
|
|
curvatmax=-b*0.3849d0
|
|
curvatmax=dabs(curvatmax)*1000.0d0
|
|
return
|
|
endif
|
|
|
|
if(ndim.eq.4)then
|
|
!y=a*(1-bx)*(x-x0)/(1+c*x)
|
|
!we ignore the other root
|
|
!dydxp(1,1)=a*(1.0d0-2.0d0*b*x-b*c*x*x+(b+c)*x0)/((1.0d0+c*x)*(1.0d0+c*x))
|
|
x0=beta(4)
|
|
root=x0
|
|
der_root=a*(1.0d0-2.0d0*b*root-b*c*root*root+(b+c)*x0)/
|
|
&((1.0d0+c*root)*(1.0d0+c*root))
|
|
term=(dsqrt((b+c)*(1.0d0+c*x0)/b)-1.0d0)/c
|
|
fmax=a*(1.0d0-b*term)*(term-x0)/(1.0d0+c*term)
|
|
yinter=-a*x0
|
|
der_yinter=a*(1.0d0+(b+c)*x0)
|
|
funcval_agivenx=a*(1.0d0-b*agivenx)*(agivenx-x0)/
|
|
&(1.0d0+c*agivenx)
|
|
der_agivenx=
|
|
&a*(1.0d0-2.0d0*b*agivenx-b*c*agivenx*agivenx+(b+c)*x0)/
|
|
&((1.0d0+c*agivenx)*(1.0d0+c*agivenx))
|
|
xcurvatmax=-9999.0d0
|
|
curvatmax=-9999.0d0
|
|
return
|
|
endif
|
|
! if(ndim.eq.3)then
|
|
!y=(1+a*x)/(b+c*x)
|
|
! root=-1.0d0/a
|
|
! der_root=a/(b-c/a)
|
|
! fmax=a/c
|
|
! yinter=1.0d0/b
|
|
! der_yinter=(a*b-c)/(b*b)
|
|
! return
|
|
! endif
|
|
x0=beta(4)
|
|
y0=beta(5)
|
|
if((-a/y0).gt.0.0d0)then
|
|
term=(-a/y0)**(1.0d0/c)-1.0d0
|
|
root=x0-b*dlog(term)
|
|
term=dexp(-(root-x0)/b)
|
|
der_root=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
|
|
else
|
|
root=-9999.0d0
|
|
der_root=-9999.0d0
|
|
endif
|
|
fmax=a+y0
|
|
call surffunc(1,yinter,1,0.0d0,ndim,beta,term,0)
|
|
call surffunc(1,term,1,0.0d0,ndim,beta,der_yinter,1)
|
|
call surffunc(1,term,1,agivenx,ndim,beta,der_agivenx,1)
|
|
call surffunc(1,funcval_agivenx,1,agivenx,ndim,beta,term,0)
|
|
|
|
curvatmax=-9999.0d0
|
|
xcurvatmax=-9999.0d0
|
|
step=(xmax-xmin)/1000.0d0
|
|
do term=xmin,xmax,step
|
|
call surffunc(1,term1,1,term,ndim,beta,deratx,1)
|
|
term2=dexp(-(term-x0)/b)
|
|
der2atx=-deratx/b+
|
|
&(1.0d0+c)*deratx*deratx*((1.0d0+term2)**c)/(a*c)
|
|
term3=dabs(der2atx/((1.0d0+deratx*deratx)**1.5d0))
|
|
if(term3.gt.curvatmax)then
|
|
curvatmax=term3
|
|
xcurvatmax=term
|
|
endif
|
|
enddo
|
|
if(dabs(xcurvatmax-xmin).le.step.or.
|
|
&dabs(xcurvatmax-xmax).le.step)then
|
|
curvatmax=-9999.0d0
|
|
xcurvatmax=-9999.0d0
|
|
else
|
|
curvatmax=dabs(curvatmax)*1000.0d0
|
|
endif
|
|
return
|
|
end
|
|
!==========================================================
|
|
subroutine indices_surffunc(ndim,beta,root,
|
|
& der_root,fmax)
|
|
implicit none
|
|
integer ndim
|
|
double precision beta(ndim),root,der_root,fmax
|
|
double precision a,b,c,x0,y0,term
|
|
a=beta(1)
|
|
b=beta(2)
|
|
c=beta(3)
|
|
x0=beta(4)
|
|
y0=beta(5)
|
|
term=(-a/y0)**(1.0d0/c)-1.0d0
|
|
root=x0-b*dlog(term)
|
|
term=dexp(-(root-x0)/b)
|
|
der_root=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
|
|
fmax=a+y0
|
|
return
|
|
end
|