Initial commit

2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
@@ -0,0 +1,67 @@
+      SUBROUTINE medfit(x,y,ndata,a,b,abdev)
+      INTEGER ndata,NMAX,ndatat
+      PARAMETER (NMAX=1000)
+      REAL a,abdev,b,x(ndata),y(ndata),arr(NMAX),xt(NMAX),yt(NMAX),aa,
+     *abdevt
+      COMMON /arrays/ xt,yt,arr,aa,abdevt,ndatat
+CU    USES rofunc
+      INTEGER j
+      REAL b1,b2,bb,chisq,del,f,f1,f2,sigb,sx,sxx,sxy,sy,rofunc
+      sx=0.
+      sy=0.
+      sxy=0.
+      sxx=0.
+      do 11 j=1,ndata
+        xt(j)=x(j)
+        yt(j)=y(j)
+        sx=sx+x(j)
+        sy=sy+y(j)
+        sxy=sxy+x(j)*y(j)
+        sxx=sxx+x(j)**2
+11    continue
+      ndatat=ndata
+      del=ndata*sxx-sx**2
+      aa=(sxx*sy-sx*sxy)/del
+      bb=(ndata*sxy-sx*sy)/del
+      chisq=0.
+      do 12 j=1,ndata
+        chisq=chisq+(y(j)-(aa+bb*x(j)))**2
+12    continue
+      sigb=sqrt(chisq/del)
+      b1=bb
+      f1=rofunc(b1)
+      b2=bb+sign(3.*sigb,f1)
+      f2=rofunc(b2)
+      if(b2.eq.b1)then
+        a=aa
+        b=bb
+        abdev=abdevt/ndata
+        return
+      endif
+1     if(f1*f2.gt.0.)then
+        bb=b2+1.6*(b2-b1)
+        b1=b2
+        f1=f2
+        b2=bb
+        f2=rofunc(b2)
+        goto 1
+      endif
+      sigb=0.01*sigb
+2     if(abs(b2-b1).gt.sigb)then
+        bb=b1+0.5*(b2-b1)
+        if(bb.eq.b1.or.bb.eq.b2)goto 3
+        f=rofunc(bb)
+        if(f*f1.ge.0.)then
+          f1=f
+          b1=bb
+        else
+          f2=f
+          b2=bb
+        endif
+        goto 2
+      endif
+3     a=aa
+      b=bb
+      abdev=abdevt/ndata
+      return
+      END