Kolpack-Software-Consulting/piscal
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
poprhythm
2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dataassim/math/othersupmath/sigmoid.f
+158
View File
@@ -0,0 +1,158 @@
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.0,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
!-----------------------------------------------------------------------