Initial commit

2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
@@ -0,0 +1,124 @@
+!-----------4 parameters---------------------------------
+! Non-rectangular hyperbola function and derivatives
+! y=a+b(x-sqrt(c+dx+x2)) or y=(ax+b-sqrt((ax+b)^2-4abcx))/2c-d
+!
+      subroutine fnonrecthypb(a,b,c,d,x,y,iwrong)
+      implicit none
+      integer iwrong
+      double precision a,b,c,d,x,y,p
+      iwrong=0
+      goto 10
+!----------------------------------------
+!a=alpha, b=Amax, c=theta, d=rd
+      p=(a*x+b)*(a*x+b)-4.0d0*a*b*c*x
+      if(p.lt.0.0d0)then
+        iwrong=1
+        return
+      endif
+      y=(a*x+b-dsqrt(p))/(2.0d0*c)-d
+      return
+!----------------------------------------
+10    p=c+d*x+x*x
+      if(p.lt.0.0d0)then
+        iwrong=1
+        return
+      endif
+      y=a+b*(x-dsqrt(p))
+      return
+      end
+      
+      subroutine indices_fnonrecthypb(a,b,c,d,root,
+     &   der_root,fmax,iwrong)
+      implicit none
+      double precision a,b,c,d,root,der_root,fmax,p
+      integer iwrong
+      iwrong=0
+      goto 10
+!---------------------------
+      root=(c*d*d-b*d)/(a*d-a*b)
+      fmax=b
+      p=(a*root+b)*(a*root+b)-4.0d0*a*b*c*root
+      if(p.lt.0.0d0)then
+        iwrong=1
+        return
+      endif
+      der_root=(a-a*(a*root+b-2.0d0*b*c)/dsqrt(p))
+     &       /(2.0d0*c)
+      return
+!------------------------------
+10    root=(b*b*c-a*a)/(2.0d0*a*b-b*b*d)
+      fmax=a-0.5d0*b*d
+      p=root*root+d*root+c
+      if(p.lt.0.0d0)then
+        iwrong=1
+        return
+      endif
+      der_root=b*(1.0d0-(2.0d0*root+d)/
+     &            (2.0d0*dsqrt(p)))
+      return
+      end
+      
+      subroutine der_fnonrecthypb(a,b,c,d,x,da,db,dc,dd,dx,
+     &                            iwrong)
+      implicit none
+      integer iwrong
+      double precision a,b,c,d,x,da,db,dc,dd,dx
+      double precision p
+      iwrong=0
+      goto 10
+!-----------------------------------------
+      p=(a*x+b)*(a*x+b)-4.0d0*a*b*c*x
+      if(p.lt.0.0d0)then
+        iwrong=1
+        return
+      endif
+      p=dsqrt(p)
+      da=(x-x*(a*x+b-2.0d0*b*c)/p)/(2.0d0*c)
+      db=(1.0d0-(a*x+b-2.0d0*a*c*x)/p)/(2.0d0*c)
+      dd=-1.0d0
+      dc=a*b*x/(c*p)-(a*x+b-p)/(2.0d0*c*c)
+      dx=(a-a*(a*x+b-2.0d0*b*c)/p)/(2.0d0*c)
+      return
+!------------------------------------------
+10    p=c+d*x+x*x
+      if(p.lt.0.0d0)then
+        iwrong=1
+        return
+      endif
+      p=dsqrt(p)
+      da=1.0d0
+      db=x-p
+      dc=-b/(2.0d0*p)
+      dd=dc*x
+      dx=b*(1.0d0-(d+2.0d0*x)/(2.0d0*p))
+      return
+      end
+
+!-------3 parameters----------------------
+      subroutine recthypb(a,b,c,x,y)
+      implicit none
+      double precision a,b,c,x,y
+      y=(a*x+b)/(x+c)
+      return
+      end
+
+      subroutine indices_frecthypb(a,b,c,root,
+     &   der_root,fmax)
+      implicit none
+      double precision a,b,c,root,
+     &   der_root,fmax
+      root=-b/a
+      der_root=a*a/(a*c-b)
+      fmax=a
+      return
+      end
+
+      subroutine der_recthypb(a,b,c,x,da,db,dc,dx)
+      implicit none
+      double precision a,b,c,x,da,db,dc,dx
+      da=x/(x+c)
+      db=1.0d0/(x+c)
+      dc=-(a*x+b)/((x+c)*(x+c))
+      dx=a/(x+c)-(a*x+b)/((x+c)*(x+c))
+      return
+      end