! Copyright (c) 2013 Aubrey Barnard.  This is free software.  See
! LICENSE.txt for details.

! Program to exercise the gradient descent module and provide a baseline
! for its operation (to compare to interfaces to other languages).

! Module containing objective function and gradient
module functions
  use gd

contains

  ! Parabola (sphere) function
  function sphere(x, f) result(error_code)
    real(dp), intent(in) :: x(:)
    real(dp), intent(out) :: f
    integer :: error_code
    f = sum(x ** 2)
    !print *, "sphere(", x, ") =", f
    error_code = 0
  end function sphere

  ! Parabola (sphere) gradient
  function sphere_grad(x, g) result(error_code)
    real(dp), intent(in) :: x(:)
    real(dp), intent(out) :: g(size(x))
    integer :: error_code
    g = 2.0_dp * x
    !print *, "sphere_grad(", x, ") =", g
    error_code = 0
  end function sphere_grad

end module functions

! Program to run gradient descent on the objective and display results
program mainf
  use gd
  use functions

  ! Locals
  integer, parameter :: dim = 3
  type(point_value_gradient) :: min
  real(dp) :: x0(dim)
  integer :: error_code

  print *, "Fortran optimization interface prototype"
  print *

  ! Init
  x0 = [7_dp, -8_dp, 9_dp]

  ! Do minimization for 100 iterations
  error_code = gradient_descent(sphere, sphere_grad, x0, 1d-1, 100, min)

  ! Output result
  print *, "mainf("
  print *, "     x0:", x0
  print *, "  min%x:", min%x
  print *, "  min%g:", min%g
  print *, "  min%f:", min%f
  print *, "  error:", error_code
  print *, ")"

end program mainf


!=====================================================================
    FUNCTION bvmv(n, k, array, type, x, y)
!=====================================================================
!
!   Returns bvmv = <x,array y> for the band array.
!
!   The original size of array is n*n. The bandwidth of array is 2k-1
!   for the non-symmetric case, and is k for symmetric case.
!   The lower-band column storage mode is assumed.
!---------------------------------------------------------------------
!
!   on entry
!   --------
!       n      the leading dimension.
!       k      the band width.
!       array  a banded matrix in the lower-band column storage mode.
!              Its element (i,j) represents the element (i,i+j-k) of
!              the original matrix. For a symmetric matrix, only the
!              lower diagonals are needed.
!       type   'g' for general;
!              's' for symmetric;
!              'a' for "almost"  symmetric, as db2
!       x      vector with length n.
!       y      vector with length n.
!
!----------------------------------------------------------------------

       REAL(KIND=8) :: bvmv
       INTEGER, INTENT(in) :: n, k
       CHARACTER(LEN=1), INTENT(in) :: type
       REAL(KIND=8), DIMENSION(n, *), INTENT(in) :: array
       REAL(KIND=8), DIMENSION(n), INTENT(in) :: x, y

       ! .. Local variables

       INTEGER :: i, j, jp, kp

       bvmv = 0.d0

       if (type /= 'g') then

          ! .. symmetric

          do jp = 1, k - 1
             do i = k + 1 - jp, n
                j = i + jp - k
                bvmv = bvmv + array(i, jp)*(x(i)*y(j) + x(j)*y(i))
             end do
          end do

          ! .. make correction for 'a' (almost symmetric)

          if (type == 'a') &
             bvmv = bvmv + x(n - 1)*y(n)*(array(1, 1) - array(n, k - 1))

       else

          do jp = 1, k - 1
             do i = k - jp + 1, n
                j = i + jp - k
                kp = 2*k - j
                bvmv = bvmv + array(i, jp)*x(i)*y(j)
                bvmv = bvmv + array(j, kp)*x(j)*y(i)
             end do
          end do

       end if

       ! .. add central diagonal

       bvmv = bvmv + SUM(array(:, k)*x(:)*y(:))

    END FUNCTION bvmv


module aux
  integer, parameter :: dp=kind(0.d0) ! double precision - use real(dp) :: instead of double precision
  integer, parameter :: sp=kind(0.0)  ! single precision
  real(dp)           :: pi
  complex(dp)        :: ci
  parameter(ci=(0.d0,1.d0)) ! complex unit i
  parameter(pi=3.1415926535897932384626433832795028841971693993751D0)
  character(len=80)  :: outfolder, hamfolder
  character(len=80)  :: filename_umatrix, filename_vq, filename_dmft
  real(dp)           :: beta
  integer            :: nw
end module aux


subroutine init_phi(lo, hi, &
     phi, p_l1, p_l2, p_l3, p_h1, p_h2, p_h3, &
     ncomp, dx, prob_lo, prob_hi) bind(C, name="init_phi")

  implicit none

  integer, intent(in) :: lo(3), hi(3), ncomp
  integer, intent(in) :: p_l1, p_l2, p_l3, p_h1, p_h2, p_h3
  double precision, intent(inout) :: phi(p_l1:p_h1,p_l2:p_h2,p_l3:p_h3,ncomp)
  double precision :: dx(3), prob_lo(3), prob_hi(3)

  integer          :: i,j,k,n
  double precision :: x,y,z,r2

  do n = 1, ncomp
     do k = lo(3), hi(3)
        z = prob_lo(3) + (dble(k)+0.5d0) * dx(3)
        do j = lo(2), hi(2)
           y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
           do i = lo(1), hi(1)
              x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)

              r2 = ((x-0.25d0)**2 + (y-0.25d0)**2 + (z-0.25d0)**2) * 100.d0
              phi(i,j,k,n) = 1.d0 + exp(-r2)
           end do
        end do
     end do
  end do

end subroutine init_phi


program tarefad

    parameter (M = 400, N = 1000000, Nmax=3000, pi = 4e0*atan(1e0))
    dimension I_AndPos(M,2), I_Passo(2), Prob(0:Nmax*Nmax)

    open(10, file="saida-d-10407962")

    I_AndPos = 0
    Prob = 0

    do j = 1, N
        S = 0
        do i = 1, M

            i_rand = 4*rand()
            arg = i_rand*pi/2
            I_Passo = (/cos(arg), sin(arg)/)
            I_AndPos(i,:) = I_AndPos(i,:) + I_Passo

        end do

        do i = 1, M

            i_x = abs(I_AndPos(i,1))
            i_y = abs(I_AndPos(i,2))
            iglob = i_x + i_y*Nmax
            Prob(iglob) = Prob(iglob) + 1

        end do

        Prob = Prob/M

        do i = 0, Nmax*Nmax

            if (Prob(i).ne.0) then
                S = S - Prob(i)*log(Prob(i))
            end if
        end do

        write(10,'(I0," ",1F0.3)') j, S
    end do

    close(10)

end program tarefad