c This is a simple program to compute cycles of a 2-d map. Example here is
c the Henon map f(x,y)=(1.4-x**2+b*y,x). The program takes cycle length and
c initial guess as input. To try another map simply change the subroutine
c map. Understand first logistic_simple.f then compare it to this program;
c everything is the same except we are now dealing with 2-d vectors and
c 2x2 matrices instead of simple numbers.

      program henon_simple
      implicit none
c max is the maximal cycle length. If you really want longer cycles just
c change max in all the subroutines. nd is the dimension of the map.
      integer max,nd
      parameter (max=25,nd=2)

      integer q,i,j
      real*8 x(max,nd),eigval(nd)
      
      write(*,*) 'Finding cycles of the Henon map. Input is cycle'
      write(*,*) 'length, q, and an initial guess (x(i),y(i),i=1,q).'
      write(*,*) 'For a specific symbol sequence you may try'
      write(*,*) 'x(i)=1 for symb(i)=1, x(i)=-1 for symb(i)=0'
      write(*,*) 'and y(i)=x(i-1)'
      write(*,*) 'NB: the Henon map is heavily pruned for the'
      write(*,*) 'standard parameters. There are no 3- and 5-cycles.'
      write(*,*)

 10   write(*,'(a,i3,2x,a)') 'cycle length q? 0<q<',max,' (0 to stop)'
      read(*,*) q
      if(q.le.0.or.q.gt.max) stop

      write(*,*) 'initial guess (x(i),y(i)),i=1,q?'
      read(*,*) ((x(i,j),j=1,nd),i=1,q)

      call cyc(q,x,eigval)

      write(*,*)
      write(*,*) 'eigenvalues:',(eigval(i),i=1,nd)
      write(*,*) 'the cycle:'
      do i=1,q
         write(*,*) (x(i,j),j=1,nd)
      enddo
      write(*,*)

      goto 10

      end


c cyc is the heart of the program. We solve the equations 
c f(i)=x(i)-fx(x(i-1))=0, where fx is the given map, by Newton iteration. 
c This leads to solving the linear equation df(i)/dx(j) (x'(i)-x(i)) = -f(i)
c in each step. df(i)/dx(j) is a 2qx2q matrix with 1's in the diagonal and
c 2x2 matrices dfx/dx (x(i-1)) below the diagonal. First we eliminate the below
c diagonal 2x2 matrices, this leads to entries in the last double column of 
c the c matrix. These are then eliminated. And we are done.

      subroutine cyc(q,x,eigval)
      implicit none
      integer max,nd
      parameter (max=25,nd=2)

      integer q,i,j,k,l,iter
      real*8 x(max,nd),f(max,nd),col(max,nd,nd),fx(max,nd),
     &     dfx(max,nd,nd),err,eigval(nd),qcolinv(nd,nd),vec(nd)

      do iter=1,1000

c map gives the map fx (surprisingly) and its derivative dfx.
         call map(q,x,fx,dfx)

c f(i) is really -f(i), but we are trying to make it 0 anyway.
         do i=1,q
            do j=1,nd
               if(i.eq.1) then
                  f(i,j)=-x(i,j)+fx(q,j)
               else
                  f(i,j)=-x(i,j)+fx(i-1,j)
               endif
            enddo
         enddo

         err=0
         do i=1,q
            do j=1,nd
               err=err+abs(f(i,j))
            enddo
         enddo
         write(*,*) 'error=',err

c Here we eliminate the subdiagonal but create entries in the q'th 
c double column.
         do j=1,nd
            do k=1,nd
               col(1,j,k)=-dfx(q,j,k)
            enddo
         enddo
         do i=2,q
            do j=1,nd
               do k=1,nd
                  col(i,j,k)=0
                  do l=1,nd
                     col(i,j,k)=col(i,j,k)+
     &                    dfx(i-1,j,l)*col(i-1,l,k)
                  enddo
               enddo
               do l=1,nd
                  f(i,j)=f(i,j)+dfx(i-1,j,l)*f(i-1,l)
               enddo
            enddo
         enddo

c eliminate the q'th element in the digonal
         call qinvers(col,qcolinv,q)
         do j=1,nd
            vec(j)=0
            do k=1,nd
               vec(j)=vec(j)+qcolinv(j,k)*f(q,k)
            enddo
         enddo
         do j=1,nd
            f(q,j)=vec(j)
         enddo

c eliminate the rest of the q'the column
         do i=1,q-1
            do j=1,nd
               vec(j)=0
               do k=1,nd
                  vec(j)=vec(j)+col(i,j,k)*f(q,k)
               enddo
            enddo
            do j=1,nd
               f(i,j)=f(i,j)-vec(j)
            enddo
         enddo

c Voila!, new estimate of the cycle
         do i=1,q
            do j=1,nd
               x(i,j)=x(i,j)+f(i,j)
            enddo
         enddo

c is the error low enough?
         if(err.lt.1.d-12) then
            call eigen(col,eigval,q)
            return
         endif
      enddo

      write(*,*) 'Ups, cycle not found. We write it out anyway:'
      do j=1,nd
         eigval(j)=0
      enddo

      return
      end


c The map fx and the derivative dfx. Example here is the Henon map
c f(x,y)=(1.4-x**2+b*y,x)
      subroutine map(q,x,fx,dfx)
      implicit none
      integer max,nd
      parameter (max=25,nd=2)

      integer q,i
      real*8 x(max,nd),fx(max,nd),dfx(max,nd,nd),a,b

      a=1.4d0
      b=.3d0

      do i=1,q
         fx(i,1)=a-x(i,1)**2+b*x(i,2)
         fx(i,2)=x(i,1)
         dfx(i,1,1)=-2*x(i,1)
         dfx(i,1,2)=b
         dfx(i,2,1)=1
         dfx(i,2,2)=0
      enddo

      return
      end

c qinvers simply computes the inverse of the matrix 1+col(q)
c for 2-d problems this is no problem
      subroutine qinvers(col,qcolinv,q)
      implicit none
      integer max,nd
      parameter (max=25,nd=2)
      
      integer j,k,q
      real*8 col(max,nd,nd),qcolinv(nd,nd),mat(nd,nd),det

      do j=1,nd
         do k=1,nd
            mat(j,k)=col(q,j,k)
         enddo
         mat(j,j)=mat(j,j)+1
      enddo
      det=mat(1,1)*mat(2,2)-mat(1,2)*mat(2,1)
      qcolinv(1,1)=mat(2,2)/det
      qcolinv(2,2)=mat(1,1)/det
      qcolinv(2,1)=-mat(2,1)/det
      qcolinv(1,2)=-mat(1,2)/det

      return
      end
      
c eigen computes the eigenvalues of the cycle stability matrix
c which happens to be -col(q). For 2-d this is easy.
      subroutine eigen(col,eigval,q)
      implicit none
      integer max,nd
      parameter (max=25,nd=2)
      
      real*8 col(max,nd,nd),eigval(nd),mat(nd,nd),disc,dum
      integer j,k,q

      do j=1,nd
         do k=1,nd
            mat(j,k)=-col(q,j,k)
         enddo
      enddo

      disc=(mat(1,1)-mat(2,2))**2+4*mat(1,2)*mat(2,1)
      if(disc.lt.0) then
         write(*,*) 'complex eigenvalues'
         eigval(1)=sqrt((mat(1,1)+mat(2,2))**2-disc)/2
         eigval(2)=eigval(1)
      else
         eigval(1)=(mat(1,1)+mat(2,2)+sqrt(disc))/2
         eigval(2)=(mat(1,1)+mat(2,2)-sqrt(disc))/2
         if(abs(eigval(1)).lt.abs(eigval(2))) then
            dum=eigval(1)
            eigval(1)=eigval(2)
            eigval(2)=dum
         endif
      endif

      return
      end



      
      

