c dlia.f
c Revised KMB 1994 Aug 7.  See getnb1.
c
c
c
      program dlia
c -----------------------------------------------------------------------------
c
c  Liapunov exponents of time series.     K M Briggs  1990 Sept 18.
c  Polynomial fitting, double precision.
c
c
c  Link with dlp (Needs dqrdc,dqrsl,qrdcmp,matout,indexx)
c
c  Automatic version - analyzes data file, writes a report.
c  Data file format  - line  1: label
c                      line  2: sample time interval,
c                      lines 3 to end of file: data (4-byte integer).
c  See K M Briggs
c  An improved method for estimating Liapunov exponents of
c      chaotic time series.  {\em Phys. Lett.}\ {\bf A151}, 27-32 (1990).
c      J.-P. Eckmann and D. Ruelle, Ergodic theory of chaos and
c            strange attractors, Rev. Mod. Phys 57, 651 (1985).
c      J.-P. Eckmann et al, Liapunov exponents from time series
c            Phys. Rev. A34,4971 (1986).
c
c-----------------------------------------------------------------------------
c Typical dlia.h:
c Max data points
c     parameter (maxnd=5000)
c Max embedding dimension
c     parameter (maxm =5)
c Max parameters
c     parameter (maxnp =45)
c Max neighbours
c     parameter (maxnb=50)
c Max polynomial order
c     parameter (maxno=4)


      include       'dlia.h'
      real*8        tau
      character*20  fn,outfn
      character     lab*30
      integer       x(maxnd)

c Get filename
      write(6,*)' Enter data input file name   [.dat]: '
      read (5,'(a)') fn

c Read data
      nd = maxnd
      call getdat(fn,nd,x,lab,tau)

c Get number of points to use
      write(6,
     : '(''  Enter minimum number of points to use ( 1..''
     : ,i6,''): '')') nd
      read (5,*) ndmin
      write(6,
     : '(''  Enter maximum number of points to use ( 1..''
     : ,i6,''): '')') nd
      read (5,*) ndmax
      write(6,'(''  Enter step between number of points: '')')
      read (5,*) ndstep
      ndmax = min(ndmax,maxnd)

c Get embedding dimension range
      write(6,
     : '(''  Enter minimum embedding dimension  ( 1..''
     : ,i2,''): '')') maxm
      read (5,*) mmin
      write(6,
     : '(''  Enter maximum embedding dimension  ( 1..''
     : ,i2,''): '')') maxm
      read (5,*) mmax
      mmin = max(1,mmin)
      mmax = min(mmax,maxm)

c Get polynomial order range
      write(6,
     : '(''  Enter minimum polynomial order ('',i2,''..'',
     :  i2,''): '')') 1,maxno
      read (5,*) nomin
      write(6,
     : '(''  Enter maximum polynomial order ('',i2,''..'',
     :  i2,''): '')') 1,maxno
      read (5,*) nomax
      nomin = max(1,nomin)
      nomax = min(maxno,nomax)

c Get amount of overspecification
      write(6,'(''  Enter minimum nb-np: '')')
      read (5,*) nb1
      write(6,'(''  Enter maximum nb-np: '')')
      read (5,*) nb2

c Make output filename, format filename.out
      i = index(fn,'.dat')
      if (i.ne.0) fn=fn(1:i-1)
      i = index(fn,' ')
      outfn = fn(1:i-1)//'.out'
      open(unit=2,status='unknown',file=outfn)

      write(2,*) ' Time series analysis by DLIA.'
      write(2,'(''  Output file name is '',a50)') outfn
      write(6,'(2x,a,''tau ='',f6.3)') lab, (tau)
      write(2,'(2x,a,''tau ='',f6.3)') lab, (tau)

      do 10 nbmnp = nb1,nb2,2

       write(6,'(2x,''nb-np ='',i3)') nbmnp
       write(2,'(2x,''nb-np ='',i3)') nbmnp
       write(2,*) ' '
       write(6,'(2x'' n  m d  Liapunov exponents''23x''Sum   KY dim'')')
       write(2,'(2x'' n  m d  Liapunov exponents''23x''Sum   KY dim'')')
       write(2,*) ' '
       do 10 nd = ndmin, ndmax, ndstep
       do 10 m  = mmin,  mmax
       do 10 no = nomin, nomax
c Get number of parameters to be fitted:
        np = m+1
        if (no.gt.1) np = np+m*(m+1)/2
        if (no.gt.2) np = np+m*(m+1)*(m+2)/6
        if (no.gt.3) np = np+m*(m+1)*(m+2)*(m+3)/24
        if (np.gt.maxnp) stop ' maxnp too small'
        nb = np+nbmnp
        if (nb.gt.maxnb) stop 'maxnb too small'
        nm = nd-m
        call liapun (x,nd,m,nb,nm,no,np,tau)
10    continue

      close(2)
      stop ' dlia finished.'
      end


      subroutine liapun (x,nd,m,nb,nm,no,np,tau)
c Get Liapunov exponents
      implicit real*8 (a-h,o-w,y-z)
      include 'dlia.h'
      integer x(nd),indx(maxnd)
      real*8 averlt(maxm),diag(maxm)
      real*8 e(maxm,maxm),q(maxm,maxm),r(maxm,maxm),tdash(maxm,maxm)
      real*8 b0(maxnb,maxm),b1(maxnb,maxm),b11(maxnb,maxm)
      real*8 d(maxnb,maxnp)
      real*8 qraux(maxnp),sol(maxnp)
      real*8 rhs(maxnb),res(maxnb)
      character*40 formt

      if (m.eq.1) formt = '(i5,i2,i2, f8.4,32x,2f8.3)'
      if (m.eq.2) formt = '(i5,i2,i2,2f8.4,24x,2f8.3)'
      if (m.eq.3) formt = '(i5,i2,i2,3f8.4,16x,2f8.3)'
      if (m.eq.4) formt = '(i5,i2,i2,4f8.4, 8x,2f8.3)'
      if (m.eq.5) formt = '(i5,i2,i2,5f8.4,    2f8.3)'


c     Output about nlines, but only on multiples of 5:
      nlines = 10
      ifreq = nm/nlines
      ifreq = 5*(ifreq/5)

c     Initialize averlt, q
      do 1 i=1,maxm
        averlt(i) = 0.0d0
        do 1 j=1,maxm
          q(i,j) = 0.0d0
          if (i.eq.j) q(i,i) = 1.0d0
1     continue

c     Sort for getnb2 search method. (Not needed for slow getnb0 or getnb1)
c     call indexx(x,nm,indx)
c Main loop - b0 is neighbourhood matrix for x(k), b1 for x(k+1)
      do 100 k = 1,nm-1
c       Slow version:
c       call getnb0(x,k,nb,m,nd,b0,b1)
        call getnb1(x,k,nb,m,nd,b0,b1)
c       Fast version:
c       call getnb2(x,k,nb,m,nd,b0,b1,indx)

        call design(b0,d,nb,np,m,no)
        call dqrdc (d,maxnb,nb,np,qraux,jdum,dum,0)

c       Least squares solutions for m right hand sides.
c       jth RHS is jth column of b1, i.e. jth component of image vector.
c       00100 indicates compute solution only, not residual res.
c       Put 00110 for res also.
        do 20 j=1,m
          call dqrsl
     :    (d,maxnb,nb,np,qraux,b1(1,j),dum,res,sol,res,dum,00100,info)
          if (info.ne.0) call matout(' ',b1,nb,maxnb,np,maxnp,6)
          if (info.ne.0) stop ' Zero diagonal element in r.'

c         Get derivatives of map at base, put in row j of e.
c         Since neighbourhood vectors are with respect to base (set in getnb?)
c         we really want derivative at (0,0,..,0), so we don't need to call
c         dmapj, just get the linear part of sol.
          do 30 i=1,m
30          e(j,i) = sol(i+1)

c         For checking only:
          if (k.eq.1) then
            do 41 i=1,nb
              do 40 l=1,m
40              rhs(l) = b0(i,l)
              call mapj(rhs,b11(i,j),sol,np,m,no)
41          continue
          endif

20      continue

c       We now have e
        call matmul(e,m,maxm,q,m,maxm,tdash,m,maxm)
        call qrdcmp(tdash,m,maxm,q,r)

        do 29 i=1,m
29        diag(i) = r(i,i)

c       Sort:
c        do 31 i = 1,m
c          evmax = 0.0
c          do 32 j=1,m
c            if (r(j,j).gt.evmax) then
c              evmax = r(j,j)
c              jmax = j
c            endif
c 32        continue
c           diag(i) = r(jmax,jmax)
c           r(jmax,jmax) = -1.0d0
c 31      continue
c        write(6,'(1x,6f10.3)') (diag(i),i=1,m)

c       Check things first time:
c        if (k.eq.1) call check(b1,b11,nb,m,np)

        sum = 0.0d0
        j = -1
        dimky = 0.0d0

        do 50 i = 1,m
          if (diag(i).eq.0.0d0) stop '  Zero diagonal element in R.'
c         Update average lambda(i)*tau
          averlt(i) = averlt(i)+(dlog(diag(i))-averlt(i))/k
          t = averlt(i)/tau
          sum = sum+t
          if (j.lt.0) then
            dimky = dimky+t
            if (sum.lt.0.0d0) then
              j = i-1
              dimky = dimky-t
            endif
          endif
50      continue
        if (j.gt.-1 .and. j.lt.m) then
          dimky = j+dimky/(dabs(averlt(j+1))/tau)
        else
          dimky = 0.0d0
        endif
        if (mod(k,ifreq).eq.0 .or. k.eq.nm-1) then
          if (dimky.gt.0.0d0) then
            write(6,fmt=formt) nd,m,no,((averlt(i)/tau),i=1,m)
     :                  ,(sum),(dimky)
          else
            write(6,fmt=formt) nd,m,no,((averlt(i)/tau),i=1,m)
     :                  ,(sum)
          endif
        endif

c     end of k loop:
100   continue

c     Write info to output file:
      if (dimky.gt.0.0d0) then
        write(2,fmt=formt) nd,m,no,((averlt(i)/tau),i=1,m)
     :              ,(sum),(dimky)
      else
        write(2,fmt=formt) nd,m,no,((averlt(i)/tau),i=1,m)
     :              ,(sum)
      endif

201   format(1x,i5,i2,i2,1(f8.3),40x,2f8.3)
202   format(1x,i5,i2,i2,2(f8.3),32x,2f8.3)
203   format(1x,i5,i2,i2,3(f8.3),24x,2f8.3)
204   format(1x,i5,i2,i2,4(f8.3),16x,2f8.3)
205   format(1x,i5,i2,i2,5(f8.3), 8x,2f8.3)
206   format(1x,i5,i2,i2,6(f8.3)    ,2f8.3)

      return
      end


      subroutine design (b0,d,nb,np,m,no)
c Set up design matrix d.
      include 'dlia.h'
      real*8 b0(maxnb,maxm),d(maxnb,maxnp)
c Constant
      do 31 nbr = 1,nb
        d(nbr,1) = 1.0d0
c Linear
        do 21 l = 1,m
          d(nbr,l+1) = b0(nbr,l)
21      continue
        kk = m+1
        if (no.eq.1) goto 30
c Quadratic
        do 22 l = 1,m
        do 22 ll = l,m
          kk = kk+1
          d(nbr,kk) = b0(nbr,l)*b0(nbr,ll)
22      continue
        if (no.eq.2) goto 30
c Cubic
        do 23 l = 1,m
        do 23 ll = l,m
        do 23 lll = ll,m
          kk = kk+1
          d(nbr,kk) = b0(nbr,l)*b0(nbr,ll)*b0(nbr,lll)
23      continue
        if (no.eq.3) goto 30
c Quartic
        do 24 l = 1,m
        do 24 ll = l,m
        do 24 lll = ll,m
        do 24 llll = lll,m
          kk = kk+1
          d(nbr,kk) = b0(nbr,l)*b0(nbr,ll)*b0(nbr,lll)*b0(nbr,llll)
24      continue

30      if (kk.ne.np) stop 'Problem in design !'
31    continue
c     call matout('d         ',d,nb,maxnb,np,maxnp,6)
      return
      end


      subroutine getnb2 (x,k,nb,m,nd,b0,b1,indx)
c Finds the nb nearest points to x(k), puts in rows of b0 neighbourhood matrix.
c Also sets up b1.
c FAST VERSION!!  K M Briggs 1989 Dec 28.
c
c Modified 1990 Feb 22 to not include as neighbours vectors equal to base.
c This should fix 'Zero diagonal element in R' problem.

      implicit real*8 (a-h,o-w,y-z)
      parameter (zero=0.0d0, big=1.0d50)
      include 'dlia.h'
      integer x(nd),indx(nd-m)
      real*8  dist2(maxnb),temp(maxm+1)
      real*8  b0(maxnb,maxm),b1(maxnb,maxm)

c     nm = number of m-vectors, allowing for evolution of last one.
      nm = nd-m-1
      mm1 = m-1
      if (k.lt.1)  stop 'k<1 in getnb2.'
      if (k.gt.nm) stop 'k>nm in getnb2.'
      xk = x(k)
      do 1 kk=1,nm
        if (x(indx(kk)).ge.xk) goto 2
1     continue

c First phase
c Put nb vectors with first component near that of x(k) in b0
c Some might equal x(k)
2     n2 = min(nb-min(nb/2,kk-1),nm-kk)
      n2 = max(0,n2)
      n1 = nb-n2
      irow = 1
      farth = zero
      close = big
      do 3 i=n1,1,-1
        ii = indx(kk-i)
        diff = dble(x(ii)-x(k))
        ss = diff**2
        b0(irow,1) = diff
        do 4 j=1,mm1
          diff = dble(x(ii+j)-x(k+j))
          ss = ss+diff**2
          b0(irow,j+1) = diff
          b1(irow,j)   = diff
4       continue
        b1(irow,m) = dble(x(ii+m)-x(k+m))
        dist2(irow) = ss
        if (ss.gt.farth) then
          farth = ss
          ifarth = irow
        endif
        if (ss.lt.close) then
          close = ss
          iclose = irow
        endif
        irow = irow+1
3     continue

      do 13 i=1,n2
        ii = indx(kk+i)
        diff = dble(x(ii)-x(k))
        ss = diff**2
        b0(irow,1) = diff
        do 14 j=1,mm1
          diff = dble(x(ii+j)-x(k+j))
          ss = ss+diff**2
          b0(irow,j+1) = diff
          b1(irow,j)   = diff
14       continue
        b1(irow,m) = dble(x(ii+m)-x(k+m))
        dist2(irow) = ss
        if (ss.gt.farth) then
          farth = ss
          ifarth = irow
        endif
        if (ss.lt.close) then
          close = ss
          iclose = irow
        endif
        irow = irow+1
13    continue
      if (irow.ne.nb+1) then
        write(6,*)' Problem in getnb2'
        write(6,*)' n1,n2,nb,irow',n1,n2,nb,irow
        stop
      endif

c      call matout('in getnb2  ',b0,nb,maxnb,m,maxm,6)

c Second phase
c Examine more vectors - down list first.
      d1 = zero
      d2 = zero
      i = kk-n1
5     i = i-1
        if (i.le.0) goto 20
        ii = indx(i)
        ss = zero
        do 6 j=0,mm1
          diff = dble(x(ii+j)-x(k+j))
          ss = ss+diff**2
          temp(j+1) = diff
6       continue
        temp(m+1) = dble(x(ii+m)-x(k+m))
        d1 = (temp(1))**2
        if (d1.ge.farth) goto 20
        if (ss.gt.zero) then
c         It's closer than farthest, but not equal to x(k), so replace
          if (close.eq.zero) then
            irepl = iclose
          else
            irepl = ifarth
          endif
          do 7 j = 1,m
            b0(irepl,j) = temp(j)
            b1(irepl,j) = temp(j+1)
7         continue
          dist2(irepl) = ss
c         Get new closest and farthest
          close = big
          farth = zero
          do 8 j=1,nb
            d2j = dist2(j)
            if (d2j.gt.farth) then
              ifarth = j
              farth = d2j
            endif
            if (d2j.lt.close) then
              iclose = j
              close = d2j
            endif
8         continue
        endif
      goto 5

c     Now up list:
20    i = kk+n2
15    i = i+1
      if (i.gt.nm) return
        ss = zero
        ii = indx(i)
        do 16 j=0,mm1
          diff = dble(x(ii+j)-x(k+j))
          ss = ss+diff**2
          temp(j+1) = diff
16      continue
        temp(m+1) = dble(x(ii+m)-x(k+m))
        d2 = (temp(1))**2
        if (d2.gt.farth) return
        if (ss.gt.zero) then
c         It's closer than farthest, but not equal to x(k), so replace
          if (close.eq.zero) then
            irepl = iclose
          else
            irepl = ifarth
          endif
          do 17 j = 1,m
            b0(irepl,j) = temp(j)
            b1(irepl,j) = temp(j+1)
17        continue
          dist2(irepl) = ss
c         Get new closest and farthest
          close = big
          farth = zero
          do 18 j=1,nb
            d2j = dist2(j)
            if (d2j.gt.farth) then
              ifarth = j
              farth = d2j
            endif
            if (d2j.lt.close) then
              iclose = j
              close = d2j
            endif
18        continue
        endif
      goto 15
      end


      subroutine getnb1 (x,k,nb,m,nd,b0,b1)
c Finds the nb nearest points to x(k), puts in rows of b0 and b1
c neighbourhood matrices.
c Revised version of getnb0. KMB 1994 Aug 7
c This is an attempt to solve the "Zero diagonal element in R" problem,
c caused by equal rows of b0.

      implicit real*8 (a-h,o-w,y-z)
      parameter (big=1.0d50,scale=1.0d7)
      include 'dlia.h'
      integer x(nd)
      real*8  d2(maxnd),d2j(maxnb)
      real*8  b0(maxnb,maxm),b1(maxnb,maxm)
      logical new

      if (nb.gt.maxnb) stop ' nb too big in getnb1'
      n = nd-m  ! +1???
c     Set d2(i) to norm(x(k)-x(i))...
      do i=1, n
        ss = 0.0d0
        do j=0, m-1
          ss = ss+(abs(x(k+j)-x(i+j)))**2
        enddo
        d2(i) = ss
      enddo

      do i=1, n
c       find closest vector to x(k)...
        ssmin = big
        do j=1, n
          if (d2(j).lt.ssmin.and.d2(j).gt.0.0d0) then
            ssmin = d2(j)
            jmin = j
          endif
        enddo
c       See if neighbour vector is different to previous...
        new = .true.
        do j = 1, i-1
           new = new .and. (d2j(j).ne.d2(jmin))
        enddo
        if (new) then
c         Construct neighbour matrices...
          do l=0, m-1
            b0(i,l+1) = (x(jmin+l  )-x(k+l  ))/scale
            b1(i,l+1) = (x(jmin+l+1)-x(k+l+1))/scale
          enddo
          d2j(i) = d2(jmin)
c         Don't consider x(jmin) again...
          d2(jmin) = big
        endif
        if (i.eq.nb) return
      enddo
      stop 'Not enough neighbours found by getnb1 !'
      end

      subroutine getnb0 (x,k,nb,m,nd,b0,b1)
c Finds the nb nearest points to x(k), puts in rows of b0 and b1
c neighbourhood matrices.
c SLOW, CRUDE, ORIGINAL VERSION !!!!!

      implicit real*8 (a-h,o-w,y-z)
      parameter (big=1.0d50,scale=1.0d7)
      include 'dlia.h'
      integer x(nd)
      real*8    d2(maxnd)
      real*8    b0(maxnb,maxm),b1(maxnb,maxm)

      if (nb.gt.maxnb) stop ' nb too big in getnb0'
      n = nd-m
      do 1 i=1,n
        ss = 0.0d0
        do 2 j=0,m-1
2         ss = ss+dabs(dble(x(k+j)-x(i+j)))
        d2(i) = ss
1     continue

      do 3 i=1,nb
        ssmin = big
        do 4 j=1,n
          if (d2(j).lt.ssmin.and.d2(j).gt.0.0d0) then
            ssmin = d2(j)
            jmin = j
          endif
4       continue
        d2(jmin) = big
        do 5 l=0,m-1
          b0(i,l+1) = (x(jmin+l)-x(k+l))/scale
          b1(i,l+1) = (x(jmin+l+1)-x(k+l+1))/scale
5       continue
3     continue
      return
      end

      subroutine mapj   (base,pj,sol,np,m,no)
c Apply polynomial map to base, return jth component
c sol assumed to contain coefficients for jth map component.
      implicit real*8 (a-h,o-z)
      real*8 base(m),sol(np)
      pj = sol(1)
      do 1 l=1,m
1       pj = pj+base(l)*sol(l+1)
      if (no.eq.1) return
      k = m+1
      do 2 l = 1,m
      do 2 ll = l,m
        k = k+1
        pj = pj+sol(k)*base(l)*base(ll)
2     continue
      if (no.eq.2) goto 100
      do 3 l = 1,m
      do 3 ll = l,m
      do 3 lll = ll,m
        k = k+1
        pj = pj+sol(k)*base(l)*base(ll)*base(lll)
3     continue
      if (no.eq.3) goto 100
      do 4 l = 1,m
      do 4 ll = l,m
      do 4 lll = ll,m
      do 4 llll = lll,m
        k = k+1
        pj = pj+sol(k)*base(l)*base(ll)*base(lll)*base(llll)
4     continue
100   if (k.ne.np) stop 'Something wrong in mapj!'
      return
      end

      subroutine dmapj  (base,dpj,sol,np,m,no)
c Evaluates the m partial derivatives of jth component polynomial map at base.
c sol assumed to contain coefficients for jth map component.
c NB This could be improved! (It might be WRONG NOW)
      implicit real*8 (a-h,o-z)
      real*8 base(m),dpj(m),sol(np)
      if (no.eq.0) stop 'no=0 in dmapj.'
      do 10 k=1,m
10      dpj(k) = sol(k+1)
      if (no.eq.1) return
      do 21 k=1,m
        kk = m+1
        do 20 l = 1,m
        do 20 ll = l,m
          kk = kk+1
          solkk = sol(kk)
          if (k.eq.l)   dpj(k) = dpj(k)+solkk*base(ll)
          if (k.eq.ll)  dpj(k) = dpj(k)+solkk*base(l )
20      continue
21    continue
      if (no.eq.2) goto 100
      do 30 l = 1,m
      do 30 ll = l,m
      do 30 lll = ll,m
        kk = kk+1
        solkk = sol(kk)
        do 31 k=1,m
          if (k.eq.l)   dpj(k) = dpj(k)+solkk*base(ll)*base(lll)
          if (k.eq.ll)  dpj(k) = dpj(k)+solkk*base(l )*base(lll)
          if (k.eq.lll) dpj(k) = dpj(k)+solkk*base(l) *base(ll)
31      continue
30    continue
100   if (kk.ne.np) stop 'Something wrong in dmapj!'
      return
      end

      subroutine getdat (fn,nd,x,lab,tau)
c Read nd points or until end of file, return number actually read.
c Assumes first line of file is a comment, second is sample time interval.
      implicit real*8 (a-h,o-w,y-z)
      include 'dlia.h'
      integer x(nd)
      character lab*30,fn*20
      nd = min(nd,maxnd)
      if (index(fn,'.').eq.0) fn=fn(1:index(fn,' ')-1)//'.dat'
      write(6,'(x,a)') ' Reading '//fn
      open(unit=1,status='old',file=fn)
      read(1,'(a30)') lab
      read(1,*) tau
      n = 0
1     n = n+1
        read(unit=1,iostat=m,fmt='(i10)') x(n)
c       write(6,*) x(n)
      if (n.lt.nd.and.m.eq.0) goto 1
      close(unit=1)
      nd = n
      if (m.ne.0) nd = nd-1
      write(6,'(x,i10,'' points read.'')') nd
      return
      end

      subroutine check  (b1,b11,nb,m,np)
      include 'dlia.h'
      real*8 b1(maxnb,maxm),b11(maxnb,maxm)
      write(6,*)' '
      if (nb.eq.np) then
        write(6,*)' b1 should equal b11:'
      else
        write(6,*)' b1 should be close to b11:'
      endif
      call matout('b1        ',b1, nb,maxnb,m,maxm,6)
      call matout('b11       ',b11,nb,maxnb,m,maxm,6)
      write(6,*)' '
      return
      end


c END of dlia.f
