159 lines
5.2 KiB
FortranFixed
159 lines
5.2 KiB
FortranFixed
double precision function sigmoidfunc(y0,a,b,c,x0,x)
|
|
implicit none
|
|
double precision y0,a,b,c,x0,x,term,crit
|
|
parameter(crit=300.0d0)
|
|
if((-(x-x0)/b).lt.crit)then
|
|
term=dexp(-(x-x0)/b)
|
|
sigmoidfunc=y0+a*(1.0d0/(1.0d0+term))**c
|
|
else
|
|
term=dexp((x-x0)/b)
|
|
sigmoidfunc=y0+a*(term/(1.0d0+term))**c
|
|
endif
|
|
return
|
|
end
|
|
!-------------------------------------------------------------------
|
|
subroutine gradsigmoidfunc(y0,a,b,c,x0,x,grad)
|
|
implicit none
|
|
double precision y0,a,b,c,x0,x,grad(6),term,crit
|
|
parameter(crit=300.0d0)
|
|
! a<->grad(1)
|
|
! b<->grad(2)
|
|
! c<->grad(3)
|
|
! x0<->grad(4)
|
|
! y0<->grad(5)
|
|
! x<->grad(6)
|
|
grad(5)=1.0d0
|
|
if((-(x-x0)/b).lt.crit)then
|
|
term=dexp(-(x-x0)/b)
|
|
grad(1)=(1.0d0/(1.0d0+term))**c
|
|
grad(6)=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
|
|
grad(4)=-(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
|
|
grad(2)=-(a*c*term*(x-x0)/(b*b))*
|
|
& (1.0d0/(1.0d0+term))**(1.0d0+c)
|
|
grad(3)=-(a*dlog(1.0d0+term))*(1.0d0/(1.0d0+term))**c
|
|
else
|
|
term=(x-x0)/b
|
|
grad(1)=(dexp(term)/(1.0d0+dexp(term)))**c
|
|
grad(6)=(a*c/b)*(dexp(term*c/(c+1.0d0))/
|
|
& (1.0d0+dexp(term)))**(c+1.0d0)
|
|
grad(4)=-(a*c/b)*(dexp(term*c/(c+1))/
|
|
& (1.0d0+dexp(term)))**(c+1.0d0)
|
|
grad(2)=-(a*c*(x-x0)/(b*b))*
|
|
& (dexp(term*c/(c+1.0d0))/(1.0d0+dexp(term)))**(1.0d0+c)
|
|
grad(3)=-a*(dlog(1.0d0+dexp(term))-term)*
|
|
& (dexp(term)/(1.0d0+dexp(term)))**c
|
|
endif
|
|
return
|
|
end
|
|
!--------------------------------------------------------------------
|
|
double precision function twoexpfunc(y0,a1,b1,c1,x01,
|
|
&a2,b2,c2,x02,x)
|
|
implicit none
|
|
double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,sigmoidfunc
|
|
twoexpfunc=y0+sigmoidfunc(0.0d0,a1,b1,c1,x01,x)-
|
|
&sigmoidfunc(0.0d0,a2,b2,c2,x02,x)
|
|
return
|
|
end
|
|
!---------------------------------------------------------------------
|
|
subroutine gradtwoexp(y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad)
|
|
implicit none
|
|
double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad(10),grad6(6)
|
|
integer i
|
|
! a1<->grad(1)
|
|
! b1<->grad(2)
|
|
! c1<->grad(3)
|
|
! x01<->grad(4)
|
|
! y0<->grad(5)
|
|
! x<->grad(6)
|
|
! a2<->grad(7)
|
|
! b2<->grad(8)
|
|
! c2<->grad(9)
|
|
! x02<->grad(10)
|
|
call gradsigmoidfunc(y0,a1,b1,c1,x01,x,grad6)
|
|
do i=1,6
|
|
grad(i)=grad6(i)
|
|
enddo
|
|
call gradsigmoidfunc(0.0d0,a2,b2,c2,x02,x,grad6)
|
|
grad(6)=grad(6)-grad6(6)
|
|
do i=1,4
|
|
grad(6+i)=-grad6(i)
|
|
enddo
|
|
return
|
|
end
|
|
!------------------------------------------------------------------------------
|
|
subroutine proxyinflpoints(b1,c1,x01,b2,c2,x02,xinfl1,xinfl2)
|
|
! the approximate inflection points. The exact analytical solution
|
|
! is difficult to find
|
|
implicit none
|
|
double precision b1,c1,x01,b2,c2,x02,xinfl1,xinfl2
|
|
xinfl1=x01+b1*dlog(c1)
|
|
xinfl2=x02+b2*dlog(c2)
|
|
end
|
|
!------------------------------------------------------------------------------
|
|
double precision function sigmoidcurvat(y0,a,b,c,x0,x)
|
|
implicit none
|
|
double precision y0,a,b,c,x0,x,term,yp,ypp,crit
|
|
parameter(crit=300.0d0)
|
|
if((-(x-x0)/b).lt.crit)then
|
|
term=dexp(-(x-x0)/b)
|
|
yp=(a*c*term/b)*(1.0d0/(1.0d0+term))**(c+1.0d0)
|
|
ypp=(a*c/(b*b))*term*(c*term-1.0d0)*
|
|
& (1.0d0/(1.0d0+term))**(c+2)
|
|
else
|
|
term=(x-x0)/b
|
|
yp=(a*c/b)*(dexp(term*c/(c+1))/
|
|
& (1.0d0+dexp(term)))**(c+1.0d0)
|
|
ypp=(a*c/(b*b))*(c-dexp(term))*(dexp(term*c/(c+2))/
|
|
& (1.0d0+dexp(term)))**(c+2)
|
|
endif
|
|
sigmoidcurvat=dabs(ypp/((1.0d0+yp*yp)**1.5d0))
|
|
return
|
|
end
|
|
!------------------------------------------------------------------------------
|
|
double precision function twoexpcurvat(y0,a1,b1,c1,x01,
|
|
&a2,b2,c2,x02,x)
|
|
implicit none
|
|
double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,a,b,c,x0,
|
|
&term,yp,ypp,crit
|
|
parameter(crit=300.0d0)
|
|
|
|
! first part
|
|
a=a1
|
|
b=b1
|
|
c=c1
|
|
x0=x01
|
|
if((-(x-x0)/b).lt.crit)then
|
|
term=dexp(-(x-x0)/b)
|
|
yp=(a*c*term/b)*(1.0d0/(1.0d0+term))**(c+1.0d0)
|
|
ypp=(a*c/(b*b))*term*(c*term-1.0d0)*
|
|
& (1.0d0/(1.0d0+term))**(c+2)
|
|
else
|
|
term=(x-x0)/b
|
|
yp=(a*c/b)*(dexp(term*c/(c+1))/
|
|
& (1.0d0+dexp(term)))**(c+1.0d0)
|
|
ypp=(a*c/(b*b))*(c-dexp(term))*(dexp(term*c/(c+2))/
|
|
& (1.0d0+dexp(term)))**(c+2)
|
|
endif
|
|
|
|
! second part
|
|
a=a2
|
|
b=b2
|
|
c=c2
|
|
x0=x02
|
|
if((-(x-x0)/b).lt.crit)then
|
|
term=dexp(-(x-x0)/b)
|
|
yp=yp-(a*c*term/b)*(1.0d0/(1.0d0+term))**(c+1.0d0)
|
|
ypp=ypp-(a*c/(b*b))*term*(c*term-1.0d0)*
|
|
& (1.0d0/(1.0d0+term))**(c+2)
|
|
else
|
|
term=(x-x0)/b
|
|
yp=yp-(a*c/b)*(dexp(term*c/(c+1))/
|
|
& (1.0d0+dexp(term)))**(c+1.0d0)
|
|
ypp=ypp-(a*c/(b*b))*(c-dexp(term))*(dexp(term*c/(c+2))/
|
|
& (1.0d0+dexp(term)))**(c+2)
|
|
endif
|
|
twoexpcurvat=dabs(ypp/((1.0d0+yp*yp)**1.5d0))
|
|
return
|
|
end
|
|
!-----------------------------------------------------------------------
|