saddle-FF-tapenade.f

      subroutine f(x, r)
      include 'saddle-FF-tapenade.inc'
      double precision x(4), r
      r = x(1)*x(1)+x(2)*x(2)-x(3)*x(3)-x(4)*x(4)
      end

      subroutine inner(x2, r)
      include 'saddle-FF-tapenade.inc'
      double precision x2(ninner), r, x(ntotal), s, x1c(nouter)
      common /closure/ x1c
      x(1) = x1c(1)
      x(2) = x1c(2)
      x(3) = x2(1)
      x(4) = x2(2)
      call f(x, s)
      r = -s
      end

      subroutine gradient_inner(x, g)
      include 'saddle-FF-tapenade.inc'
      double precision x(ninner), g(ninner), g_x(ninner, ninner), y
      integer k, l
      do k = 1, ninner
         do l = 1, ninner
            g_x(k, l) = 0d0
         enddo
         g_x(k, k) = 1d0
      enddo
      call inner_gv(x, g_x, y, g, ninner)
      end

      subroutine multivariate_argmin_inner(n, x, x_star, fx)
      include 'common-tapenade.inc'
      integer n, i, j
      double precision x(n), x_star(n), fx
      double precision gx(size), eta, t(size), x_prime(size), fx_prime
      double precision s
C     need to enforce n<=size
      call inner(x, fx)
      eta = 1d-5
      i = 0
      do j = 1, n
         x_star(j) = x(j)
      enddo
      call gradient_inner(x, gx)
 1    call magnitude(n, gx, s)
      if (s.le.1d-5) return
      if (i.eq.10) then
         eta = eta*2d0
         i = 0
         goto 1
      endif
      call ktimesv(n, eta, gx, t)
      call vminus(n, x_star, t, x_prime)
      call distance(n, x_star, x_prime, s)
      if (s.le.1d-5) return
      call inner(x_prime, fx_prime)
      if (fx_prime.lt.fx) then
         do j = 1, n
            x_star(j) = x_prime(j)
         enddo
         fx = fx_prime
         call gradient_inner(x_prime, gx)
         i = i+1
         goto 1
      endif
      eta = eta/2d0
      i = 0
      goto 1
      end

      subroutine outer(x1, r)
      include 'saddle-FF-tapenade.inc'
      double precision x1(nouter), r, x2(ninner), x2_star(ninner), s
      double precision x1c(nouter), x1c_g(ninner, nouter)
      common /closure/ x1c
      common /closure_gv/ x1c_g
      integer k
      x1c(1) = x1(1)
      x1c(2) = x1(2)
      do k = 1, ninner
         x1c_g(k, 1) = 0d0
         x1c_g(k, 2) = 0d0
      enddo
      x2(1) = 1d0
      x2(2) = 1d0
      call multivariate_argmin_inner(ninner, x2, x2_star, s)
      r = -s
      end

      subroutine gradient_outer(x, g)
      include 'saddle-FF-tapenade.inc'
      double precision x(nouter), g(nouter), g_x(nouter, nouter), y
      integer k, l
      do k = 1, nouter
         do l = 1, nouter
            g_x(k, l) = 0d0
         enddo
         g_x(k, k) = 1d0
      enddo
      call outer_hv(x, g_x, y, g, nouter)
      end

      program main
      include 'saddle-FF-tapenade.inc'
      double precision x1_start(nouter), x2_start(ninner)
      double precision x1_star(nouter), x2_star(ninner), r
      double precision x1c(nouter), x1c_g(ninner, nouter)
      common /closure/ x1c
      common /closure_gv/ x1c_g
      integer i, k
      external outer, gradient_outer, inner, gradient_inner
      do i = 1, 1000
         x1_start(1) = 1d0
         x1_start(2) = 1d0
         x2_start(1) = 1d0
         x2_start(2) = 1d0
         call multivariate_argmin
     +        (nouter, outer, gradient_outer, x1_start, x1_star, r)
         x1c(1) = x1_star(1)
         x1c(2) = x1_star(2)
         do k = 1, ninner
            x1c_g(k, 1) = 0d0
            x1c_g(k, 2) = 0d0
         enddo
         call multivariate_argmin
     +        (ninner, inner, gradient_inner, x2_start, x2_star, r)
         print *, x1_star(1), x1_star(2), x2_star(1), x2_star(2)
      enddo
      end