subroutine fgetmaxmin(n,x,xmin,imin,xmax,imax)
      implicit none
      integer n,imin,imax,i
      double precision x(n),xmin,xmax
      imin=1
      xmin=x(1)
      imax=1
      xmax=x(1)
      do i=2,n
        if(x(i).lt.xmin)then
          imin=i
          xmin=x(i)
        endif
        if(x(i).gt.xmax)then
          imax=i
          xmax=x(i)
        endif
      enddo
      return
      end

      double precision function fdotsec(idotsec)
      implicit none
      integer idotsec,i,k,j(100),n
      k=idotsec
      i=1
10    j(i)=mod(k,10)
      k=k/10
      if(k.gt.0)then
        i=i+1
        goto 10
      endif
      fdotsec=0.0d0
      do k=1,i
        n=10**(i-k+1)
        fdotsec=fdotsec+dble(j(k))/dble(n)
      enddo
      return
      end

      integer function isitnaninf(x)
!If x is NaN or INF, isitnaninf=1. Otherwise, isitnaninf=0
      implicit none
      double precision x
      isitnaninf=1
      if((x+1.0d0).gt.x)isitnaninf=0
      if((x+1.0d0).lt.x)isitnaninf=1
      if((x+1.0d0).eq.x)isitnaninf=1
      return
      end

      subroutine sort_shell(n,a,iorder)
!sort array a with the Shell method (from smallest to largest).
!iorder records the original position of each member.
      implicit none
      integer n,iorder(n)
      double precision a(n)
      integer i,j,inc,k
      double precision v
      
      do i=1,n
        iorder(i)=i
      enddo
      inc=1
1     inc=3*inc+1
      if(inc.le.n)goto 1
2     continue
        inc=inc/3
        do i=inc+1,n
          v=a(i)
          k=iorder(i)
          j=i
3         if(a(j-inc).gt.v)then
            a(j)=a(j-inc)
            iorder(j)=iorder(j-inc)
            j=j-inc
            if(j.le.inc)goto 4
            goto 3
          endif
4         a(j)=v
          iorder(j)=k
        enddo
      if(inc.gt.1)goto 2
      return
      end
c
c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
c This subroutine solves the real root of a cubic equation. Solutions
c are found from p184-185 W. Press et al 1992 Numerical Recipes in C
c
      double precision function cubicroot(p,q,r)
c
      implicit double precision(a-h,l,o-z)
      
c: x^3+p*x^2+q*x+r=0

      capq=(p*p-3.0d0*q)/9.0d0
      capr=(2.0d0*p*p*p-9.0d0*p*q+27.0d0*r)/54.0d0
      if (capr*capr .lt. capq*capq*capq) then
        rtta=dacos(capr/(dsqrt(capq*capq*capq)))
        root1=-2.0d0*dsqrt(capq)*dcos(rtta/3.0d0)-p/3.0d0
        
        root2=dsqrt(capq)*(dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
     &        dsqrt(3.0d0))-p/3.0d0
        root3=-dsqrt(capq)*(-dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
     &        dsqrt(3.0d0))-p/3.0d0
      else
        capa=-dsign(1.0d0, capr)*(dabs(capr)+dsqrt(capr*capr-
     &       capq*capq*capq))**(1.0d0/3.0d0)
        if (dabs(capa) .lt. 1.0d-6) then
          capb=0.0
        else
          capb=capq/capa
        end if
        root2 =(capa+capb)-p/3.0d0
      end if
      cubicroot=root2
      return
      end

      subroutine getcubicroot(p,q,r,root1,root2,root3)
c
      implicit double precision(a-h,l,o-z)
      
c: x^3+p*x^2+q*x+r=0
      root1=-9999.0d0
      root2=-9999.0d0
      root3=-9999.0d0

      capq=(p*p-3.0d0*q)/9.0d0
      capr=(2.0d0*p*p*p-9.0d0*p*q+27.0d0*r)/54.0d0
      if (capr*capr .lt. capq*capq*capq) then
        rtta=dacos(capr/(dsqrt(capq*capq*capq)))
        root1=-2.0d0*dsqrt(capq)*dcos(rtta/3.0d0)-p/3.0d0
        
        root2=dsqrt(capq)*(dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
     &        dsqrt(3.0d0))-p/3.0d0
        root3=-dsqrt(capq)*(-dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
     &        dsqrt(3.0d0))-p/3.0d0
      else
        capa=-dsign(1.0d0, capr)*(dabs(capr)+dsqrt(capr*capr-
     &       capq*capq*capq))**(1.0d0/3.0d0)
        if (dabs(capa) .lt. 1.0d-6) then
          capb=0.0
        else
          capb=capq/capa
        end if
        root2 =(capa+capb)-p/3.0d0
      end if
      cubicroot=root2
      return
      end


c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      subroutine quadraticroots(a,b,c,root1,root2)
      implicit none
      double precision a,b,c,root1,root2,b24ac,q
      
      if(dabs(a).lt.1.0d-8)then
        if(dabs(b).lt.1.0d-8)then
          root1=-9999.0d0
          root2=-9999.0d0
          return
        endif
        root1=-c/b
        root2=-9999.0d0
        return
      endif
      b24ac=b*b-4.0d0*a*c
      if(b24ac.lt.0.0d0)then
        root1=-9999.0d0
        root2=-9999.0d0
        return
      endif
!      q=-0.5d0*(b+dsign(1.0d0,b)*dsqrt(b24ac))
!      root1=q/a
!      root2=c/q
      root1=(-b-dsqrt(b24ac))/(2.0d0*a)
      root2=(-b+dsqrt(b24ac))/(2.0d0*a)
      return
      end

      subroutine quadraticrootsbound(a,b,c,
     &  lower,upper,root,otherroot,iwrong)
      implicit none
      double precision a,b,c,lower,upper,root,
     &  otherroot

      integer iwrong
!iwrong=0, root is within (lower,upper) and otherroot is not
!iwrong=1, both root and otherroot are within (lower,upper)
!iwrong=2, both root and otherroot are real but outside of (lower, upper)
!iwrong=3, the equation bx+c=0 type, one root only
!iwrong=4, no real roots
!iwrong=5, invalid equation

      double precision b24ac,q
      
      if(a.eq.0.0d0)then
        if(b.eq.0.0d0)then
          root=-9999.0d0
          otherroot=-9999.0d0
          iwrong=5
          return
        endif
        root=-c/b
        otherroot=-9999.0d0
        iwrong=3
        return
      endif

      b24ac=b*b-4.0d0*a*c
      if(b24ac.lt.0.0d0)then
        root=-9999.0d0
        otherroot=-9999.0d0
        iwrong=4
        return
      endif
      q=-0.5d0*(b+dsign(1.0d0,b)*dsqrt(b24ac))
      root=c/q
      otherroot=q/a
      
      if(root.ge.lower.and.root.le.upper)then
        if(otherroot.ge.lower.and.otherroot.le.upper)then
          iwrong=1
        else
          iwrong=0
        endif
      else
        if(otherroot.ge.lower.and.otherroot.le.upper)then
          b24ac=root
          root=otherroot
          otherroot=b24ac
          iwrong=0
        else
          iwrong=2
        endif
      endif
      return
      end
c
c####################################################################
c random number generator
c
      double precision function ran2()
      implicit none
      integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv
      double precision am,eps,rnmx
!      parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1),
!     &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
!     &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7,
!     &rnmx=1.0d0-eps)
     
      parameter(im1=2147483563,im2=2147483399,
     &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
     &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab)
      parameter(am=1.0d0/dble(im1),eps=1.2d-7,
     &rnmx=1.0d0-eps)
     
      integer idum2,j,k,iv(ntab),iy,idum
      save iv,iy,idum2,idum
      data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/
      
      if(idum.le.0) then
        idum=max0(-idum,1)
        idum2=idum
        do 11 j=ntab+8,1,-1
          k=idum/iq1
          idum=ia1*(idum-k*iq1)-k*ir1
          if(idum.lt.0)idum=idum+im1
          if(j.le.ntab)iv(j)=idum
11      continue
        iy=iv(1)
      end if
      k=idum/iq1
      idum=ia1*(idum-k*iq1)-k*ir1
      if(idum.lt.0)idum=idum+im1
      k=idum2/iq2
      idum2=ia2*(idum2-k*iq2)-k*ir2
      if(idum2.lt.0) idum2=idum2+im2
      j=1+iy/ndiv
      iy=iv(j)-idum2
      iv(j)=idum
      if(iy.lt.1)iy=iy+imm1
      ran2=dmin1(am*dble(iy),rnmx)
      return
      end
c
c####################################################################
      double precision function beta(beta1,beta2)
c Returns the value of the Beta function B(u,v)
c
      implicit double precision(a-h,l,o-z)
      beta=dexp(gammln(beta1)+gammln(beta2)-gammln(beta1+beta2))
      return
      end
c
! Logarithm of gamma function.
! Used by routine betai.
! Numerical Recipes, chapter 6.1.
      double precision function gammln(xx)
      implicit none
      double precision xx
      integer j
      double precision cof(6)
      double precision ser,stp,tmp,x,y
     
      save cof,stp
      data cof,stp/76.18009172947146d0,-86.50532032941677d0,
     &24.01409824083091d0,-1.231739572450155d0,0.1208650973866179d-2,
     &-0.5395239384953d-5,2.5066282746310005d0/
      
      x=xx
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*dlog(tmp)-tmp
      ser=1.000000000190015d0
      do 11 j=1,6
        y=y+1.0d0
        ser=ser+cof(j)/y
11    continue
      gammln=tmp+dlog(stp*ser/x)
      return
      end
c##################################################################
c
c    This subroutine quadrat performs the transformation of 8 point
c  Gaussian Quadrature in the interval (-1, 1) to any interval (x0,
c  x1).
c
      subroutine quadrat(x0, x1, abscis, weight, timeby)
      implicit double precision(a-h,l,o-z)
      dimension abscis(8), root(8), weight(8), weit(8)

c
      save root,weit
      data(root(i),i=1,4)/0.18343464d0,0.52553241d0,0.79666648d0,
     &                    0.96028986d0/
      data(root(i),i=5,8)/-0.18343464d0,-0.52553241d0,-0.79666648d0,
     &                    -0.96028986d0/
      data(weit(i),i=1,4)/0.36268378d0,0.31370665d0,0.22238103d0,
     &                     0.10122854d0/
      data(weit(i),i=5,8)/0.36268378d0,0.31370665d0,0.22238103d0,
     &                     0.10122854d0/

      do 10 i = 1, 8
        abscis(i) = ((x1-x0)*root(i)+x1+x0)/2.0d0
        weight(i) = weit(i)
10    continue
      timeby = (x1-x0)/2.0d0
      return
      end
c####################################################################
c random number generator
c
      double precision function ran2_reset()
      implicit none
      integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv
      double precision am,eps,rnmx
!      parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1),
!     &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
!     &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7,
!     &rnmx=1.0d0-eps)
      
      parameter(im1=2147483563,im2=2147483399,
     &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
     &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab)

      parameter(am=1.0d0/dble(im1),eps=1.2d-7,
     &rnmx=1.0d0-eps)
      
      
      logical resetran2
      common /ran2reset/resetran2
      save /ran2reset/

      integer idum2,j,k,iv(ntab),iy,idum
      save iv,iy,idum2,idum
      data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/
      
      if(resetran2.eqv..true..or.resetran2.eqv..TRUE.)then
        idum2=123456789
        do j=1,ntab
          iv(j)=0
        enddo
        iy=0
        idum=-1
      endif
      resetran2=.false.
            
      if(idum.le.0) then
        idum=max0(-idum,1)
        idum2=idum
        do 11 j=ntab+8,1,-1
          k=idum/iq1
          idum=ia1*(idum-k*iq1)-k*ir1
          if(idum.lt.0) idum=idum+im1
          if(j.le.ntab) iv(j)=idum
11      continue
        iy=iv(1)
      end if
      k=idum/iq1
      idum=ia1*(idum-k*iq1)-k*ir1
      if(idum.lt.0)idum=idum+im1
      k=idum2/iq2
      idum2=ia2*(idum2-k*iq2)-k*ir2
      if(idum2.lt.0) idum2=idum2+im2
      j=1+iy/ndiv
      iy=iv(j)-idum2
      iv(j)=idum
      if(iy.lt.1)iy=iy+imm1
      ran2_reset=dmin1(am*dble(iy),rnmx)
      return
      end
c
c####################################################################
c random number generator
c
      double precision function cpran2_reset()
      implicit none
      integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv
      double precision am,eps,rnmx
!      parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1),
!     &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
!     &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7,
!     &rnmx=1.0d0-eps)
      
      parameter(im1=2147483563,im2=2147483399,
     &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
     &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab)

      parameter(am=1.0d0/dble(im1),eps=1.2d-7,
     &rnmx=1.0d0-eps)
      
      logical resetran2
      common /cpran2reset/resetran2
      save /cpran2reset/

      integer idum2,j,k,iv(ntab),iy,idum
      save iv,iy,idum2,idum
      data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/
      
      if(resetran2.eqv..true..or.resetran2.eqv..TRUE.)then
        idum2=123456789
        do j=1,ntab
          iv(j)=0
        enddo
        iy=0
        idum=-1
      endif
      resetran2=.false.
            
      if(idum.le.0) then
        idum=max0(-idum,1)
        idum2=idum
        do 11 j=ntab+8,1,-1
          k=idum/iq1
          idum=ia1*(idum-k*iq1)-k*ir1
          if(idum.lt.0) idum=idum+im1
          if(j.le.ntab) iv(j)=idum
11      continue
        iy=iv(1)
      end if
      k=idum/iq1
      idum=ia1*(idum-k*iq1)-k*ir1
      if(idum.lt.0)idum=idum+im1
      k=idum2/iq2
      idum2=ia2*(idum2-k*iq2)-k*ir2
      if(idum2.lt.0) idum2=idum2+im2
      j=1+iy/ndiv
      iy=iv(j)-idum2
      iv(j)=idum
      if(iy.lt.1)iy=iy+imm1
      cpran2_reset=dmin1(am*dble(iy),rnmx)
      return
      end
c####################################################################
c This subroutine calculates R2 and root mean square error and index of 
cagreement
      subroutine rsq_rms(y10,y20,n0,rsq,rms,agrind)
      implicit double precision (a-h,l,o-z)
      dimension y10(n0),y20(n0),y1(n0),y2(n0)
      fn9999=-9999.0d0
      tiny=1.0d-7
      n=0
      do i=1,n0
        if(dabs(y10(i)-fn9999).gt.tiny.and.
     &dabs(y20(i)-fn9999).gt.tiny)then
          n=n+1
          y1(n)=y10(i)
          y2(n)=y20(i)
        endif
      enddo
      sum=0.0d0 
      do 10 i=1,n
        sum=sum+(y1(i)-y2(i))*(y1(i)-y2(i))
10    continue   
      rms=dsqrt(sum/dble(n))
      ymean1=0.0d0
      ymean2=0.0d0
      do 20 i=1,n
        ymean1=ymean1+y1(i)
        ymean2=ymean2+y2(i)
20    continue
      ymean1=ymean1/dble(n)
      ymean2=ymean2/dble(n)
      sum1=0.0d0
      sum2=0.0d0
      sum3=0.0d0
      sum4=0.0d0
      sum5=0.0d0
      do 30 i=1,n
        sum1=(y1(i)-ymean1)*(y2(i)-ymean2)+sum1
        sum2=(y1(i)-ymean1)*(y1(i)-ymean1)+sum2
        sum3=(y2(i)-ymean2)*(y2(i)-ymean2)+sum3
        sum4=(y1(i)-y2(i))*(y1(i)-y2(i))+sum4
        sum5=(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))*
     &(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))+sum5
30    continue
      if((sum2*sum3).eq.0.0d0)then
        rsq=-9999.0d0
      else
        rsq=sum1/dsqrt(sum2*sum3)
        rsq=rsq*rsq
      endif
      if(sum5.eq.0.0d0)then
        agrind=-9999.0d0
      else
        agrind=1.0d0-sum4/sum5
      endif
      return
      end
c####################################################################
      subroutine extrsq_rms(y10,y20,n0,nparams,rsq,rms,agrind,
     &rmse_norm,rmse_perc,aic,aicc)
      implicit double precision (a-h,l,o-z)
      dimension y10(n0),y20(n0),y1(n0),y2(n0)
      fn9999=-9999.0d0
      tiny=1.0d-7
      n=0
      do i=1,n0
        if(dabs(y10(i)-fn9999).gt.tiny.and.
     &dabs(y20(i)-fn9999).gt.tiny)then
          n=n+1
          y1(n)=y10(i)
          y2(n)=y20(i)
        endif
      enddo
      ymin=y1(1)
      ymax=y1(1)
      do i=2,n
        if(y1(i).lt.ymin)ymin=y1(i)
        if(y1(i).gt.ymax)ymax=y1(i)
      enddo
      sum=0.0d0
      rmse_perc=0.0d0
      do 10 i=1,n
        sum=sum+(y1(i)-y2(i))*(y1(i)-y2(i))
        rmse_perc=rmse_perc+(y1(i)-y2(i))*(y1(i)-y2(i))/(y2(i)*y2(i))
10    continue   
      rms=dsqrt(sum/dble(n))
      if(nparams.gt.0)then
        aic=dble(n)*dlog(rms*rms)+2.0d0*dble(nparams)
        aicc=aic+2.0d0*dble(nparams*(nparams+1))/dble(n-nparams-1)
      else
        aic=-9999.0d0
        aicc=-9999.0d0
      endif
      rmse_norm=rms/(ymax-ymin)
      rmse_perc=100.0d0*dsqrt(rmse_perc/dble(n))
      ymean1=0.0d0
      ymean2=0.0d0
      do 20 i=1,n
        ymean1=ymean1+y1(i)
        ymean2=ymean2+y2(i)
20    continue
      ymean1=ymean1/dble(n)
      ymean2=ymean2/dble(n)
      sum1=0.0d0
      sum2=0.0d0
      sum3=0.0d0
      sum4=0.0d0
      sum5=0.0d0
      do 30 i=1,n
        sum1=(y1(i)-ymean1)*(y2(i)-ymean2)+sum1
        sum2=(y1(i)-ymean1)*(y1(i)-ymean1)+sum2
        sum3=(y2(i)-ymean2)*(y2(i)-ymean2)+sum3
        sum4=(y1(i)-y2(i))*(y1(i)-y2(i))+sum4
        sum5=(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))*
     &(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))+sum5
30    continue
      if((sum2*sum3).eq.0.0d0)then
        rsq=-9999.0d0
      else
        rsq=sum1/dsqrt(sum2*sum3)
        rsq=rsq*rsq
      endif
      if(sum5.eq.0.0d0)then
        agrind=-9999.0d0
      else
        agrind=1.0d0-sum4/sum5
      endif
      return
      end
!####################################################################
      subroutine stdmean(nsamp,xvar,std,fmean)
      implicit none
      integer nsamp,j
      double precision xvar(nsamp),std,fmean
      fmean=0.0d0
      do j=1,nsamp
        fmean=fmean+xvar(j)
      enddo
      fmean=fmean/dble(nsamp)
      std=0.0d0
      do j=1,nsamp
        std=std+(xvar(j)-fmean)*(xvar(j)-fmean)       
      enddo
      std=dsqrt(std/dble(nsamp-1))
      end

      subroutine stdmeancv(nsamp0,xvar0,std,fmean,cv)
      implicit none
      integer nsamp0,nsamp,j
      double precision xvar0(nsamp0),xvar(nsamp0),std,fmean,cv
      nsamp=0
      do j=1,nsamp0
        if(dabs(xvar0(j)+9999.0d0).gt.1.0d-7)then
          nsamp=nsamp+1
          xvar(nsamp)=xvar0(j)
        endif
      enddo
      fmean=0.0d0
      do j=1,nsamp
        fmean=fmean+xvar(j)
      enddo
      fmean=fmean/dble(nsamp)
      std=0.0d0
      do j=1,nsamp
        std=std+(xvar(j)-fmean)*(xvar(j)-fmean)       
      enddo
      std=dsqrt(std/dble(nsamp-1))
      cv=std/fmean
      end
c#######################################################################
      subroutine reinitialization(x0min,x0likely,
     &    x0max,x0new,minterval)
      implicit none
      double precision x0min,x0likely,x0max,x0new,zrand,
     &                 delta1,delta2,ran2_reset
      integer minterval,iwhichone
      save
      intrinsic dble,dabs
      if(x0likely.le.x0min.or.x0likely.ge.x0max)then
        x0new=(x0min+x0max)/2.0d0+
     &        (x0max-x0min)*(ran2_reset()-0.5d0)
      else      
        delta1=(x0likely-x0min)/dble(minterval)
        delta2=(x0max-x0likely)/dble(minterval)
        zrand=ran2_reset()     
        iwhichone=idint(dble(2*minterval)*zrand)+1
        if(iwhichone.gt.(2*minterval))iwhichone=minterval+1
        zrand=ran2_reset()
        if(iwhichone.le.minterval)then
          x0new=x0likely-(x0likely-x0min
     &                    -delta1*dble(iwhichone-1))*zrand
        else
          x0new=x0likely+
     &        zrand*delta2*dble(iwhichone-minterval)
        endif
      endif
      return
      end
c#######################################################################
      
      double precision function whatismedian(n,x)
      implicit none
      integer n,i,j
      double precision x(n),copyx(n),term
      
      do i=1,n
        copyx(i)=x(i)
      enddo
      do i=1,n
        do j=i+1,n
          if(copyx(j).lt.copyx(i))then
            term=copyx(i)
            copyx(i)=copyx(j)
            copyx(j)=term
          endif
        enddo
      enddo
      if(mod(n,2).eq.0)then
        whatismedian=(copyx(n/2)+copyx(n/2+1))/2.0d0
      else
        whatismedian=copyx((n-1)/2+1)
      endif
      return
      end
!------------------------------------------------
      subroutine y_aPLUSbxrsq(npoints,x,y,a,b,rsq)
      implicit none
!fit for y=a+bx
      integer npoints
      double precision x(npoints),y(npoints),a,b,rsq,rms,agrind
      integer i
      double precision fn9999,tiny,ycal(npoints)
      parameter(fn9999=-9999.0d0,tiny=1.0d-7)

      call y_aPLUSbx(npoints,x,y,a,b)
      do i=1,npoints
        ycal(i)=fn9999
        if(dabs(x(i)-fn9999).gt.tiny)ycal(i)=a+b*x(i)
      enddo
      call rsq_rms(y,ycal,npoints,rsq,rms,agrind)
      return
      end
!------------------------------------------------
      subroutine y_aPLUSbx(npoints0,x0,y0,a,b)
      implicit none
!fit for y=a+bx
      integer npoints0
      double precision x0(npoints0),y0(npoints0),a,b
      integer i,npoints
      double precision xmean,ymean,lxx,lyy,lxy,fn9999,tiny,
     &x(npoints0),y(npoints0)
      parameter(fn9999=-9999.0d0,tiny=1.0d-7)

      npoints=0
      do i=1,npoints0
        if(dabs(x0(i)-fn9999).gt.tiny.and.
     &dabs(y0(i)-fn9999).gt.tiny)then
          npoints=npoints+1
          x(npoints)=x0(i)
          y(npoints)=y0(i)
        endif
      enddo
      xmean=0.0d0
      ymean=0.0d0
      do i=1,npoints
        xmean=xmean+x(i)
        ymean=ymean+y(i)
      enddo
      xmean=xmean/dble(npoints)
      ymean=ymean/dble(npoints)
      lxx=0.0d0
      lyy=0.0d0
      lxy=0.0d0
      do i=1,npoints
        lxx=lxx+(x(i)-xmean)**2
        lyy=lyy+(y(i)-ymean)**2
        lxy=lxy+(x(i)-xmean)*(y(i)-ymean)
      enddo
      if(lxx.ne.0.0d0)then
        b=lxy/lxx
        a=ymean-b*xmean
      else
        b=-9999.0d0
        a=-9999.0d0
      endif
      return
      end
!----------------------------------------------
      subroutine y_bx(npoints0,x0,y0,b)
      implicit none
!fit for y=bx
      integer npoints0
      double precision x0(npoints0),y0(npoints0),b
      integer i,npoints
      double precision lxx,lxy,fn9999,tiny,
     &x(npoints0),y(npoints0)
      parameter(fn9999=-9999.0d0,tiny=1.0d-7)

      npoints=0
      do i=1,npoints0
        if(dabs(x0(i)-fn9999).gt.tiny.and.
     &dabs(y0(i)-fn9999).gt.tiny)then
          npoints=npoints+1
          x(npoints)=x0(i)
          y(npoints)=y0(i)
        endif
      enddo
      lxx=0.0d0
      lxy=0.0d0
      do i=1,npoints
        lxx=lxx+x(i)*x(i)
        lxy=lxy+x(i)*y(i)
      enddo
      b=lxy/lxx
      return
      end
!======================================================
      subroutine linearsys_dim2(a,b,c,d,e,f,x,y)
      implicit none
!solve for x and y in
!     ax+by=c
!     dx+ey=f
!avoiding overflow
      double precision a,b,c,d,e,f,x,y
      if(dabs(a).gt.dabs(b).and.dabs(a).gt.dabs(d)
     &  .and.dabs(a).gt.dabs(e))then
        y=(f-c*d/a)/(e-b*d/a)
        x=c/a-b*y/a
      else
        if(dabs(b).gt.dabs(a).and.dabs(b).gt.dabs(d)
     &    .and.dabs(b).gt.dabs(e))then
          x=(f-c*e/b)/(d-a*e/b)
          y=c/b-a*x/b
        else
          if(dabs(d).gt.dabs(a).and.dabs(d).gt.dabs(b)
     &      .and.dabs(d).gt.dabs(e))then
            y=(c-a*f/d)/(b-a*e/d)
            x=f/d-e*y/d
          else
            x=(c-b*f/e)/(a-b*d/e)
            y=f/e-d*x/e
          endif
        endif
      endif
      return
      end
!===========================================================
      double precision function crosscorrel(nsamp,var1,var2,
     &  istart,iend,ndelay)
      implicit none
      integer nsamp,istart,iend,ndelay,i,j
      double precision var1(1:nsamp),var2(istart:iend),var1mean,
     &  var2mean,sxy,sxx,syy
      var1mean=0.0d0
      var2mean=0.0d0
      j=0
      do i=1,nsamp
        if((i-ndelay).ge.istart.and.(i-ndelay).le.iend)then
          j=j+1
          var1mean=var1mean+var1(i)
          var2mean=var2mean+var2(i-ndelay)
        endif
      enddo
      var1mean=var1mean/dble(j)
      var2mean=var2mean/dble(j)
      sxy=0.0d0
      sxx=0.0d0
      syy=0.0d0
      do i=1,nsamp
        if((i-ndelay).ge.istart.and.(i-ndelay).le.iend)then
          sxy=sxy+(var1(i)-var1mean)*(var2(i-ndelay)-var2mean)
          sxx=sxx+(var1(i)-var1mean)*(var1(i)-var1mean)
          syy=syy+(var2(i-ndelay)-var2mean)*(var2(i-ndelay)-var2mean)
        endif
      enddo
      crosscorrel=sxy/dsqrt(sxx*syy)
      return
      end
!===========================================================
      double precision function cumutailsum(n,time,starttime,endtime,
     &xtosum,threshold,iaboveorbelow)
      implicit none
      integer n,i,j,iaboveorbelow,iabove,ibelow
      double precision time(n),starttime,endtime,xtosum(n),agap,
     &threshold(n)
      parameter(iabove=1,ibelow=-1)
      agap=-9999.0d0
      cumutailsum=0.0d0
      do i=1,n
        if(time(i).ge.starttime.and.time(i).lt.endtime)then
          if(dabs(xtosum(i)-agap).gt.1.0d-5)then
            if(iaboveorbelow.eq.iabove)then
              if(xtosum(i).ge.threshold(i))
     &cumutailsum=cumutailsum+xtosum(i)
            endif
            if(iaboveorbelow.eq.ibelow)then
              if(xtosum(i).le.threshold(i))
     &cumutailsum=cumutailsum+xtosum(i)
            endif
          endif
        endif
      enddo 
      return
      end
!----------------------------------------------------------------
      double precision function ran1(idum)
      INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
      double precision AM,EPS,RNMX
      PARAMETER (IA=16807,IM=2147483647,AM=1.d0/dble(IM),
     &IQ=127773,IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-7,
     &RNMX=1.0d0-EPS)
      INTEGER j,k,iv(NTAB),iy
      SAVE iv,iy
      DATA iv /NTAB*0/, iy /0/
      if (idum.le.0.or.iy.eq.0) then
        idum=max(-idum,1)
        do 11 j=NTAB+8,1,-1
          k=idum/IQ
          idum=IA*(idum-k*IQ)-IR*k
          if (idum.lt.0) idum=idum+IM
          if (j.le.NTAB) iv(j)=idum
11      continue
        iy=iv(1)
      endif
      k=idum/IQ
      idum=IA*(idum-k*IQ)-IR*k
      if (idum.lt.0) idum=idum+IM
      j=1+iy/NDIV
      iy=iv(j)
      iv(j)=idum
      ran1=dmin1(AM*dble(iy),RNMX)
      return
      END