    Program dbdsqr_example

!     DBDSQR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dbdsqr, dlaset
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: one = 1.0_dp
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: ifail, info, ldc, ldu, ldvt, n
      Character (1) :: uplo
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: c(:, :), d(:), e(:), u(:, :), vt(:, :), &
        work(:)
!     .. Executable Statements ..
      Write (nout, *) 'DBDSQR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldc = 1
      ldu = n
      ldvt = n
      Allocate (c(ldc,1), d(n), e(n-1), u(ldu,n), vt(ldvt,n), work(4*n))

!     Read B from data file

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

      Read (nin, *) uplo

!     Initialize U and VT to be the unit matrix
      Call dlaset('General', n, n, zero, one, u, ldu)
      Call dlaset('General', n, n, zero, one, vt, ldvt)

!     Calculate the SVD of B
      Call dbdsqr(uplo, n, n, n, 0, d, e, vt, ldvt, u, ldu, c, ldc, work, &
        info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Print singular values, left & right singular vectors

        Write (nout, *) 'Singular values'
        Write (nout, 100) d(1:n)
        Write (nout, *)
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, vt, ldvt, &
          'Right singular vectors, by row', ifail)

        Write (nout, *)
        Flush (nout)

        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, u, ldu, &
          'Left singular vectors, by column', ifail)

      End If

100   Format (3X, (8F8.4))
    End Program


c A collection of covariance functions for Gaussian processes, implemented in Fortran.
c By convention, the first dimension of each input array iterates over points, and
c subsequent dimensions iterate over spatial dimensions.

      SUBROUTINE axi_gauss(a,pts_x,pts_y,symm,scale,amp,nx,ny,ndx,ndy)

cf2py real dimension(nx,ny),intent(inplace)::a
cf2py real dimension(nx,ndx),intent(in)::pts_x
cf2py real dimension(ny,ndy),intent(in)::pts_y
cf2py logical intent(in),optional::symm
cf2py real intent(in)::scale
cf2py real intent(in)::amp
cf2py integer intent(hide),depend(a)::nx=shape(a,0)
cf2py integer intent(hide),depend(a)::ny=shape(a,1)
cf2py integer intent(hide),depend(pts_x)::ndx=shape(pts_x,1)
cf2py integer intent(hide),depend(pts_y)::ndy=shape(pts_y,1)

      INTEGER nx,ny,i,j,ndx,ndy,k
      REAL a(nx,ny),pts_x(nx,ndx),pts_y(ny,ndy)
      REAL amp,scale,val_now,dev_now
      LOGICAL symm

      if(symm) then
        do i=1,nx
          do j=i,ny
            val_now = 0.0
            do k=1,ndx
              dev_now = (pts_x(i,k)-pts_y(j,k))*scale
              val_now = val_now + dev_now * dev_now
            enddo
            a(i,j) = amp * exp(-val_now/2.0)
            a(j,i) = a(i,j)
          enddo
        enddo
      else
        do i=1,nx
          do j=1,ny
            val_now = 0.0
            do k=1,ndx
              dev_now = (pts_x(i,k)-pts_y(j,k))*scale
              val_now = val_now + dev_now * dev_now
            enddo
            a(i,j) = amp * exp(-val_now/2.0)
          enddo
        enddo
      endif

      return
      END

      SUBROUTINE axi_exp(a,pts_x,pts_y,symm,scale,amp,pow,nx,ny,ndx,ndy)

cf2py real dimension(nx,ny),intent(inplace)::a
cf2py real dimension(nx,ndx),intent(in)::pts_x
cf2py real dimension(ny,ndy),intent(in)::pts_y
cf2py logical intent(in),optional::symm
cf2py real intent(in)::scale
cf2py real intent(in)::amp
cf2py real intent(in)::pow
cf2py integer intent(hide),depend(a)::nx=shape(a,0)
cf2py integer intent(hide),depend(a)::ny=shape(a,1)
cf2py integer intent(hide),depend(pts_x)::ndx=shape(pts_x,1)
cf2py integer intent(hide),depend(pts_y)::ndy=shape(pts_y,1)

      INTEGER nx,ny,i,j,ndx,ndy,k
      REAL a(nx,ny),pts_x(nx,ndx),pts_y(ny,ndy)
      REAL amp,scale,val_now,dev_now,pow
      LOGICAL symm

      if(symm) then
        do i=1,nx
          do j=i,ny
            val_now = 0.0
            do k=1,ndx
              dev_now = (pts_x(i,k)-pts_y(j,k))*scale
              val_now = val_now + dev_now * dev_now
            enddo
            a(i,j) = amp * exp(-val_now**(pow/2.0)/2.0)
            a(j,i) = a(i,j)
          enddo
        enddo
      else
        do i=1,nx
          do j=1,ny
            val_now = 0.0
            do k=1,ndx
              dev_now = (pts_x(i,k)-pts_y(j,k))*scale
              val_now = val_now + dev_now * dev_now
            enddo
            a(i,j) = amp * exp(-val_now**(pow/2.0)/2.0)
          enddo
        enddo
      endif

      return
      END


        program gau
        implicit none
!
        real (kind(0.d0))     :: a,b,fx,exacto,gerror,serror,terror  ! conservar doble prec.
        real (kind(0.d0))     :: gcuad,h
        real (kind(0.d0))     :: simpson,trapezoid
        real (kind(0.d0)), allocatable  :: x(:),w(:)                 ! conservar doble prec.
        integer              :: i,j,np,npts,in,n_max
!
        a = 0.d0   ! limite inferior de integracion
        b = 1.d0   ! limite superior de integracion
!
        exacto = 1.d0 - exp(-1.d0)   !  valor exacto de la integral
!
!
        open(37,file='err_gau.d',status='replace')
!
!       calculo para diferentes valores de n
        n_max = 30
!
        do in=3,n_max,2
          npts = in-1
!
          call gausscuad(npts,a,b,gcuad)
          gerror = abs(gcuad - exacto)
          write(37,'(I5,2x,3(E15.6,2x))') in,gerror
        enddo
        close(37)
!
        CONTAINS
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
        subroutine gausscuad(n,a,b,gau)
!       calcula la integral de la funcion Func, entre a y b
!       utilizando n puntos de evaluacion, mediante
!       la cuadratura de Gauss-Legendre (gau)
!
        use gaussmod, only : gauss
        implicit none
        real (kind(0.d0)), INTENT(IN)  :: a,b
        integer, INTENT(IN)            :: n
        real (kind(0.d0)), INTENT(OUT) :: gau
        real (kind(0.d0))              :: w(0:n),x(0:n)
        integer                        :: j
!
        call gauss(npts,0,a,b,x(0:npts),w(0:npts))  ! calculo nodos y pesos para Gauss
!
!       calculo la integral
          gau  = 0.d0
!
          do j=0,n
            call func(x(j),fx)
            gau = gau + fx*w(j)
          enddo
        return
        end subroutine gausscuad
!
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!
        subroutine func(x,fx)
        implicit none
        real (kind(0.d0)), INTENT(IN)  :: x
        real (kind(0.d0)), INTENT(OUT) :: fx
!
        fx = exp(-x)
        return
        end subroutine func
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!
        end program


function sinc(x) result(y)
    Real :: x, y
    y = sin(x)/x
end function sinc

function Lambert_W(x, accuracy) result(y)
    Integer :: count, I, M
    Integer :: accuracy
    Real :: x, y, STR, W

    W = 0
    y = 0
    STR = 0
    I = 0
    count = 0
    M = 0

10  if (abs(W - x) .GT. (Real(1)/accuracy) .AND. M .LT. accuracy) then
        I = I + 1
        M = (10 ** count)
        y = STR + Real(I)/M
        W = y * exp(y)
        if (W .GT. x) then
            y = STR + Real(I-1)/M
            STR = y
            I = 0
            count = count + 1
        end if
        goto 10
    end if
end function Lambert_W

function Log_Integral(x) result(y)
    Integer :: x
    Real :: y
    y = Integral_func(f, 2, x, 10000)
contains
    function f(x) result(y)
        Real :: x, y
        y = 1/log(x)
    end function f
end function Log_Integral

function Bump_function(x) result(y)
    Real :: x, y
    if (abs(x) < 1) then
        y = exp(-1/(1-(x**2)))
    else
        y = 0
    end if
end function Bump_function

function Dirac_Delta(n, x) result(y)
    Real :: x, y, n
    if (abs(x) > 1/(2*x)) then
        y = 0
    else
        y = n
    end if
end function Dirac_Delta

! subroutine Lambert_W_test(x, accuracy)
!     Integer :: count, I
!     Integer :: x, accuracy
!     Real :: y, STR, W

!     W = 0
!     y = 0
!     STR = 0
!     I = 0
!     count = 0
!     Write(*, *) "W: ", W

! 10  if (abs(W - x) .GT. (Real(1)/accuracy)) then
!         I = I + 1
!         y = STR + Real(I)/(10 ** count)
!         W = y * exp(y)
!         if (W .GT. x) then
!             y = STR + Real(I-1)/(10 ** count)
!             STR = y
!             I = 0
!             count = count + 1
!             Write(*, *) "W: ", W
!         end if
!         goto 10
!     end if
! end subroutine Lambert_W_test


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                         Russian Peasant Multiplication                      !
!                                   in Fortran                                !
!                              Jason Nguyen (XXXXXXXX)                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    program russian
    implicit none

!   Array of ranges I test the functions on
    integer, dimension(0:4) :: tests = [1, 5, 50, 500, 5000]

!   Interface for my two russian algorithms
    integer(kind=8) :: russianPeasantIterative
    integer(kind=8) :: russianPeasantRecursive

!   User interface vars
    integer(kind=8) :: m, n

!   Iterator var
    integer :: i

    print *, "-------------------------------------------"
    print *, "-- Russian Peasant Multiplication in F95 --"
    print *, "--       By Jason Nguyen (XXXXXXXX)       --"
    print *, "-------------------------------------------"

!   Benchmarking
    call sleep(1)
    print *, "Please wait...running startup benchmarks..."
    print *, " "

!   Calling my dedicated benchmark functions
    do i = 1, 4
        call sleep(1)
        print '(" Multiplying every number from ", I0, " to ", I0)', &
            tests(i - 1), tests(i)
        call benchmarkRecursive(int(tests(i - 1), 8), int(tests(i), 8))
        call benchmarkIterative(int(tests(i - 1), 8), int(tests(i), 8))
        print *, " "
    end do

    do
!       Ask for user input
        print *, "Enter a positive number (to quit, enter a negative):"
        read(*, *) m

!       Abort if negative
        if (m < 0) then
            exit
        end if

!       Continue asking
        print *, " "
        print *, "Enter another positive (to quit, enter a negative):"
        read(*, *) n

!       Check for abort
        if (n < 0) then
            exit
        end if

!       Calculate and print
        print *, " "
        print '("Recursive answer: ", I0)', russianPeasantRecursive(m, n)
        print '("Iterative answer: ", I0)', russianPeasantIterative(m, n)
        print *, " "

!       Terminate program if negative
        if (m < 0 .or. n < 0) then
            exit
        end if
    end do

!   Done
    print *, " "
    print *, "Thank you for using this program!"

end program russian

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

recursive function russianPeasantRecursive(m, n) result(output)
    implicit none
    integer(kind=8), intent(in) :: m, n
    integer(kind=8) :: output

!   Base cases
    if (m == 0) then
        output = 0
    else if (m == 1) then
        output = n

!   Recursive cases
    else if (mod(m, 2) == 0) then
        output = russianPeasantRecursive(m / 2, n * 2)
    else
        output = n + russianPeasantRecursive(m / 2, n * 2)
    end if

end function russianPeasantRecursive

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

function russianPeasantIterative(m, n) result(output)
    implicit none
    integer(kind=8), intent(in) :: m, n
    integer(kind=8) :: output, multiplier, multiplicand

!   Initialization
    output = 0
    multiplicand = n
    multiplier = m

!   Iterative algorithm
    do while (multiplier > 0)
        if (mod(multiplier, 2) == 1) then
            output = output + multiplicand
        end if
        multiplier = multiplier / 2
        multiplicand = multiplicand * 2
    end do
end function russianPeasantIterative

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

! Benchmark the recursive function
subroutine benchmarkRecursive(m, n)
    implicit none
    integer(kind=8), intent(in) :: m, n

!   Interface
    integer(kind=8) :: russianPeasantRecursive
    integer(kind=8) :: output

!   Test iterator
    integer(kind=8) :: i, j

!   Timing
    real :: start, finish
    call cpu_time(start)
    do i = m, n
        do j = m, n
            output = russianPeasantRecursive(i, j)
        end do
    end do
    call cpu_time(finish)

!   Print results
    write(*,'(A,F8.6,A)') "    Recursive took ", finish-start, " seconds"
end subroutine benchmarkRecursive

! Benchmark the iterative function
subroutine benchmarkIterative(m, n)
    implicit none
    integer(kind=8), intent(in) :: m, n

!   Interface
    integer(kind=8) :: russianPeasantIterative
    integer(kind=8) :: output

!   Test iterator
    integer(kind=8) :: i, j
    real :: start, finish

!   Timing
    call cpu_time(start)
    do i = m, n
        do j = m, n
            output = russianPeasantIterative(i, j)
        end do
    end do
    call cpu_time(finish)

!   Print results
    write(*,'(A,F8.6,A)') "    Iterative took ", finish-start, " seconds"
end subroutine benchmarkIterative


module timeit

  implicit none
  integer, parameter :: dp = kind(1.d0)
contains

subroutine time_all(n,iters)
  integer :: i
  integer,dimension(8) :: ut1,ut2
  real :: t1, t2, etime
  real(dp), allocatable :: A(:, :), B(:, :)
  real(dp), allocatable :: C(:, :)
  integer, intent(in) :: n,iters
  character(len=32), dimension(5) :: methods
  real(dp), dimension(5) :: ctimes
  real(dp), dimension(5) :: etimes

  write(*,*)
  write(*,'(a16,i10)') "Matrix size:",n
  write(*,'(a16,i10)') "Iterations:",iters

  allocate(A(n, n), B(n, n), C(n, n))
  call random_number(A)
  call random_number(B)

  !Testing matmul1 (dgemm)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul1(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(1)="External dgemm"
  ctimes(1)=t2-t1
  etimes(1)=elapsedtime(ut1,ut2)

  !Testing matmul2 (intrinsic matmul)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul2(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(2)="Intrinsic matmul"
  ctimes(2)=t2-t1
  etimes(2)=elapsedtime(ut1,ut2)

  !Testing matmul3 (manual looping)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul3(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(3)="Manual loops v1"
  ctimes(3)=t2-t1
  etimes(3)=elapsedtime(ut1,ut2)

  !Testing matmul4 (manual looping)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul4(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(4)="Manual loops V2"
  ctimes(4)=t2-t1
  etimes(4)=elapsedtime(ut1,ut2)

  !Testing matmul5 (manual looping)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul5(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(5)="Manual loops V3"
  ctimes(5)=t2-t1
  etimes(5)=elapsedtime(ut1,ut2)

  call printtimes(methods,ctimes,etimes,5)

  deallocate(A)
  deallocate(B)
  deallocate(C)
end subroutine

subroutine test_matmul1(n,iters)
  integer :: i
  integer,dimension(8) :: ut1,ut2
  real :: t1, t2, etime
  real(dp), allocatable :: A(:, :), B(:, :)
  real(dp), allocatable :: C(:, :)
  integer, intent(in) :: n,iters
  character(len=32), dimension(5) :: methods
  real(dp), dimension(5) :: ctimes
  real(dp), dimension(5) :: etimes

  write(*,*)
  write(*,'(a16,i10)') "Matrix size:",n
  write(*,'(a16,i10)') "Iterations:",iters

  allocate(A(n, n), B(n, n), C(n, n))
  call random_number(A)
  call random_number(B)

  !Testing matmul1 (dgemm)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul1(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(1)="External dgemm"
  ctimes(1)=t2-t1
  etimes(1)=elapsedtime(ut1,ut2)
  call printtimes(methods,ctimes,etimes,1)

  deallocate(A)
  deallocate(B)
  deallocate(C)
end subroutine

subroutine test_matmul2(n,iters)
  integer :: i
  integer,dimension(8) :: ut1,ut2
  real :: t1, t2, etime
  real(dp), allocatable :: A(:, :), B(:, :)
  real(dp), allocatable :: C(:, :)
  integer, intent(in) :: n,iters
  character(len=32), dimension(5) :: methods
  real(dp), dimension(5) :: ctimes
  real(dp), dimension(5) :: etimes

  write(*,*)
  write(*,'(a16,i10)') "Matrix size:",n
  write(*,'(a16,i10)') "Iterations:",iters

  allocate(A(n, n), B(n, n), C(n, n))
  call random_number(A)
  call random_number(B)

  !Testing matmul2 (intrinsic matmul)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul2(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(1)="Intrinsic matmul"
  ctimes(1)=t2-t1
  etimes(1)=elapsedtime(ut1,ut2)
  call printtimes(methods,ctimes,etimes,1)

  deallocate(A)
  deallocate(B)
  deallocate(C)
end subroutine

subroutine test_matmul3(n,iters)
  integer :: i
  integer,dimension(8) :: ut1,ut2
  real :: t1, t2, etime
  real(dp), allocatable :: A(:, :), B(:, :)
  real(dp), allocatable :: C(:, :)
  integer, intent(in) :: n,iters
  character(len=32), dimension(5) :: methods
  real(dp), dimension(5) :: ctimes
  real(dp), dimension(5) :: etimes

  write(*,*)
  write(*,'(a16,i10)') "Matrix size:",n
  write(*,'(a16,i10)') "Iterations:",iters

  allocate(A(n, n), B(n, n), C(n, n))
  call random_number(A)
  call random_number(B)

  !Testing matmul3 (manual looping)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul3(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(1)="Manual loops V1"
  ctimes(1)=t2-t1
  etimes(1)=elapsedtime(ut1,ut2)
  call printtimes(methods,ctimes,etimes,1)

  deallocate(A)
  deallocate(B)
  deallocate(C)
end subroutine

subroutine test_matmul4(n,iters)
  integer :: i
  integer,dimension(8) :: ut1,ut2
  real :: t1, t2, etime
  real(dp), allocatable :: A(:, :), B(:, :)
  real(dp), allocatable :: C(:, :)
  integer, intent(in) :: n,iters
  character(len=32), dimension(5) :: methods
  real(dp), dimension(5) :: ctimes
  real(dp), dimension(5) :: etimes

  write(*,*)
  write(*,'(a16,i10)') "Matrix size:",n
  write(*,'(a16,i10)') "Iterations:",iters

  allocate(A(n, n), B(n, n), C(n, n))
  call random_number(A)
  call random_number(B)

  !Testing matmul4 (manual looping)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul4(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(1)="Manual loops V2"
  ctimes(1)=t2-t1
  etimes(1)=elapsedtime(ut1,ut2)
  call printtimes(methods,ctimes,etimes,1)

  deallocate(A)
  deallocate(B)
  deallocate(C)
end subroutine

subroutine test_matmul5(n,iters)
  integer :: i
  integer,dimension(8) :: ut1,ut2
  real :: t1, t2, etime
  real(dp), allocatable :: A(:, :), B(:, :)
  real(dp), allocatable :: C(:, :)
  integer, intent(in) :: n,iters
  character(len=32), dimension(5) :: methods
  real(dp), dimension(5) :: ctimes
  real(dp), dimension(5) :: etimes

  write(*,*)
  write(*,'(a16,i10)') "Matrix size:",n
  write(*,'(a16,i10)') "Iterations:",iters

  allocate(A(n, n), B(n, n), C(n, n))
  call random_number(A)
  call random_number(B)

  !Testing matmul5 (manual looping)
  call cpu_time(t1)
  call date_and_time(values=ut1)
  do i = 1, iters
      call matmul5(A,B,C)
  end do
  call cpu_time(t2)
  call date_and_time(values=ut2)
  methods(1)="Manual loops V3"
  ctimes(1)=t2-t1
  etimes(1)=elapsedtime(ut1,ut2)
  call printtimes(methods,ctimes,etimes,1)

  deallocate(A)
  deallocate(B)
  deallocate(C)
end subroutine

real(dp) function elapsedtime(starttime,stoptime)
  integer, dimension(8), intent(in) :: starttime,stoptime
  elapsedtime=(stoptime(5)*3600._dp+stoptime(6)*60._dp+real(stoptime(7),kind=dp)+stoptime(8)/1000._dp)- &
       (starttime(5)*3600._dp+starttime(6)*60._dp+real(starttime(7),kind=dp)+starttime(8)/1000._dp)
end function

subroutine printtimes(methods,ctimes,etimes,n_methods)
  integer, intent(in) :: n_methods
  character(len=*), dimension(n_methods), intent(in) :: methods
  real(dp),dimension(n_methods), intent(in) :: ctimes
  real(dp),dimension(n_methods), intent(in) :: etimes
  integer :: i
  write(*,'(a16)',advance='no')    "Method:"
  do i=1,n_methods
     write(*,'(a22)',advance='no')    trim(methods(i))
  end do
  write(*,*) ''
  write(*,'(a16)',advance='no') "CPU time:"
  do i=1,n_methods
     write(*,'(f20.3,a2)',advance='no') ctimes(i), " s"
  end do
  write(*,*) ''
  write(*,'(a16)',advance='no') "Elapsed time:"
  do i=1,n_methods
     write(*,'(f20.3,a2)',advance='no') etimes(i), " s"
  end do
  write(*,*) ''
end subroutine

subroutine matmul1(A,B,C) !Using dgemm
  integer :: n
  real(dp), intent(out) :: C(:, :)
  real(dp), intent(in) :: A(:, :), B(:, :)
  external :: dgemm
  n = size(A,1)
  call dgemm('N', 'N', n, n, n, 1.0_dp, A, n, B, n, 0.0_dp, C, n);
end subroutine

subroutine matmul2(A,B,C) !Using matmul
  real(dp), intent(out) :: C(:, :)
  real(dp), intent(in) :: A(:, :), B(:, :)
  C = matmul(A, B)
end subroutine

subroutine matmul3(A,B,C) !Manual loops V1 (Similar to dgemm logic)
  real(dp), intent(out) :: C(:, :)
  real(dp), intent(in) :: A(:, :), B(:, :)
  integer :: i,j,k,l,n
  real(dp) :: tmp
  n = size(A,1)

  do j=1,n
    do l=1,n
      C(l,j)=0.0_dp
    end do

    do k=1,n
      tmp=B(k,j)
      do i=1,n
        C(i,j)=C(i,j)+tmp*A(i,k)
      end do
    end do
  end do
end subroutine

subroutine matmul4(A,B,C) !Manual loops V2 (Not using tmp outside the i loop)
  real(dp), intent(out) :: C(:, :)
  real(dp), intent(in) :: A(:, :), B(:, :)
  integer :: i,j,k,l,n
  n = size(A,1)

  do j=1,n
    do l=1,n
      C(l,j)=0.0_dp
    end do

    do k=1,n
      do i=1,n
        C(i,j)=C(i,j)+B(k,j)*A(i,k)
      end do
    end do
  end do
end subroutine

subroutine matmul5(A,B,C) !Manual loops V3 (Not using initialization loop for C)
  real(dp), intent(out) :: C(:, :)
  real(dp), intent(in) :: A(:, :), B(:, :)
  integer :: i,j,k,n
  n = size(A,1)

  do j=1,n
    do i=1,n
      C(i,j)=0.0_dp
      do k=1,n
         C(i,j)=C(i,j)+B(k,j)*A(i,k)
      end do
    end do
  end do
end subroutine

end module

program matrix

  use timeit
  implicit none
  integer :: matrix_size,n_iter

!  integer, parameter :: dp = kind(1.d0)

!matrix_size=1000
!n_iter=1
!call time_all(matrix_size,n_iter)
!matrix_size=20
!n_iter=1000000
!call time_all(matrix_size,n_iter)
!matrix_size=3
!n_iter=10000000
!call time_all(matrix_size,n_iter)

matrix_size=1000
n_iter=1
call test_matmul1(matrix_size,n_iter)
call test_matmul2(matrix_size,n_iter)
call test_matmul3(matrix_size,n_iter)
call test_matmul4(matrix_size,n_iter)
call test_matmul5(matrix_size,n_iter)

!####################################################################
!End of executable statements.
!####################################################################
end program matrix


      program generate_test_data

      implicit double precision (a-h,o-z)

      nb = 10000

      n = 800

      tmin = 0.

      tmax = 10.

      eps = 0.1

      dtb = (tmax - tmin) / nb

      dt = (tmax - tmin) / n

      open (unit = 20, file = 'Bench.dat', status = 'unknown')
      open (unit = 21, file = 'Test.dat', status = 'unknown')

      write(20,*) '# ',nb+1
      do i = 0, nb

         t = i*dtb

         write(20,*) t, sin(t)

      enddo

      write(21,*) '# ',n+1
      do i = 0, n

         t = i*dt

         write(21,*) t, sin((1.+eps)*t)

      enddo

      write(*,*) 'test these date in rms_error.f; analytical normalized'
      write(*,*) 'error is 0.6068828437420661'
      write(*,*) 'see verification_mathematica.nb for details'

      end


\-------------------------------------------------------------------------------------------
\
\ https://projecteuler.net/problem=1
\

: IS-MULTIPLE   ( n1 n2 -- 0/1 if n1 is multiple of n2 )
    MOD NOT
;

: PEULER-001 ( limit -- result )
    0 SWAP 1            ( sum limit index )
    DO
        I 3 IS-MULTIPLE ( sum r1 )
        I 5 IS-MULTIPLE ( sum r1 r2 )
        OR IF           ( sum r1|r2 )
            I +         ( sum )
        THEN
    LOOP
;

\-------------------------------------------------------------------------------------------
\
\ https://projecteuler.net/problem=2
\

: IS-EVEN       ( n1 -- 0/1 )
    2 MOD NOT
;

: FIBONACCI ( n1 n2 -- n2 n1+n2 )
    TUCK    ( n2 n1 n2 )
    +       ( n2 n1+n2 )
;

: PEULER-002    ( limit -- result )
    0 1 1               ( limit sum n1 n2 )
    BEGIN
        DUP 4 PICK <    \ while n2 < limit
    WHILE               ( limit sum n1 n2 )
        FIBONACCI       ( limit sum n1 n2 )
        OVER IS-EVEN IF \ if n1 is even...
            OVER        ( limit sum n1 n2 n1 )
            2SWAP       ( limit n2 n1 sum n1 )
            +           ( limit n2 n1 sum )
            -ROT        ( limit sum n2 n1 )
            SWAP        ( limit sum n1 n2 )
        THEN
    REPEAT
    2DROP               ( limit sum )
    NIP                 ( sum )
;

\-------------------------------------------------------------------------------------------
\
\ https://projecteuler.net/problem=3
\

: IS-EVEN       ( n1 -- 0/1 )
    2 MOD NOT
;

: IS-MULTIPLE   ( n1 n2 -- 0/1 ) \ n1 is a multiple of n2
    MOD NOT
;

: IS-PRIME     ( n -- 0/1 )
    DUP 2 = IF
        DROP                    (   )
        TRUE                    ( result )
        EXIT
    THEN
    DUP IS-EVEN IF
        DROP                    (   )
        FALSE                   ( result )
        EXIT
    THEN                        ( n )
    3                           ( n index )
    BEGIN
        2DUP                    ( n index n index )
        SWAP                    ( n index index n )
        2 /                     ( n index index limit )
        <                       \ while index < limit
    WHILE                       ( n index )
        2DUP IS-MULTIPLE IF     \ if n is a multiple of index
            2DROP               (   )
            FALSE               ( result )
            EXIT
        THEN
        1+ 1+                   ( n index )
    REPEAT
    2DROP                       (   )
    TRUE                        ( result )
;

: NEXT-PRIME-FACTOR ( n, factor -- n, factor )
    BEGIN
        2DUP                    ( n factor n factor )
        SWAP                    ( n factor factor n )
        2 /                     ( n factor factor limit )
        <                       \ while factor < limit
    WHILE                       ( n factor )
        2DUP IS-MULTIPLE IF     \ if n is a multiple of factor
            DUP IS-PRIME IF     \ if factor is a prime
                TUCK            ( factor n factor )
                /               ( factor n )
                SWAP            ( n factor )
                EXIT
            THEN
        THEN
        1+
    REPEAT                      ( factor n )
    1-
;

: PEULER-003 ( n -- factor )
    2                           ( n factor )
    BEGIN
        OVER IS-PRIME NOT       \ while n is not prime
    WHILE
        NEXT-PRIME-FACTOR       ( n factor )
        2DUP . . CR
    REPEAT
    DROP                        ( n )
;

\-------------------------------------------------------------------------------------------
\
\ https://projecteuler.net/problem=4
\

: NTH-CHAR-FROM-FRONT ( address length position -- char )
    NIP     ( address position )
    + C@    ( char )
;

: NTH-CHAR-FROM-BACK ( address length position -- char )
    -       ( address position )
    +       ( address )
    1-      ( address )
    C@      ( char )
;

: IS-PALINDROME ( address length -- result )
    0           ( address length index )
    BEGIN
        2DUP >
    WHILE       \ while index < length
        3 NDUP                  ( address length index address length index )
        NTH-CHAR-FROM-FRONT     ( address length index left )
        3 PICK                  ( address length index left address )
        3 PICK                  ( address length index left address length )
        3 PICK                  ( address length index left address length index )
        NTH-CHAR-FROM-BACK      ( address length index left right )
        <> IF                   \ left == right
            3 NDROP             (  )
            FALSE               ( result )
            EXIT
        THEN
        1+
    REPEAT
    3 NDROP                     ( result )
    TRUE
;

: PEULER-004 ( -- result )
    0               ( result )
    1000 100        ( result limit i )
    DO
        1000 100    ( result limit j )
        DO
            I J *   ( result value )
            <# #S #> IS-PALINDROME IF \ if result is a palindrome
                I J * MAX ( result )
            THEN
        LOOP
    LOOP
;

\-------------------------------------------------------------------------------------------
\
\ https://projecteuler.net/problem=5
\

: IS-MULTIPLE   ( n1 n2 -- 0/1 ) \ n1 is a multiple of n2
    MOD NOT
;

: IS-DIVISIBLE-BY-ANY-IN ( n limit -- result )
    TUCK            ( limit n limit )
    2               ( limit n limit index )
    DO
        DUP I IS-MULTIPLE NOT IF  \ if n is not a multiple of index
            UNLOOP  ( limit n )
            2DROP   ( )
            FALSE   ( result )
            EXIT
        THEN
        DUP         ( limit n n)
    +LOOP
    2DROP       ( )
    TRUE        ( result )
;

: PEULER-005    ( n divisor -- result )
    TUCK        ( divisor n divisor )
    DO
        I DUP IS-DIVISIBLE-BY-ANY-IN IF \ if n is divisibly by any up to divisor
            S" HIER A"
            I       ( divisor result )
            NIP     ( result )
            UNLOOP
            EXIT
        THEN
        DUP         ( divisor divisor )
    +LOOP
    S" HIER B"
    DROP            (   )
;


SUBROUTINE weight(ord,x,y,sig,mu,eta)

!-------------------------------------------------------------
!
!  Computes the spatial weights
!  From Azmy 1988 in NSE, equations 20a and 20b used
!  First find the epsilons
!  Input: order, dx, dy, total XS, mu, eta
!  Returns: weight for cell (i,j) in x (alpha) and
!            y (beta) directions
!
!-------------------------------------------------------------

USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: ord
REAL*8, INTENT(IN) :: x, y, sig, mu, eta
INTEGER :: k
REAL*8 :: shx, shy, chx, chy, epsxe, epsxo, epsye, epsyo
REAL*8 :: smxe, smxo, smye, smyo

! Compute the coefficients and the hyperbolic functions
ex = 0.5*sig*x/mu
ey = 0.5*sig*y/eta
shx = SINH(ex)
shy = SINH(ey)
chx = COSH(ex)
chy = COSH(ey)

! Initialize values for epsilons from 15c in Azmy '88 NSE
epsxe = shx/ex
epsxo = 3.0*(chx-shx/ex)/ex
epsye = shy/ey
epsyo = 3.0*(chy-shy/ey)/ey

! Initialize summation terms
smxe = 0.0
smxo = 0.0
smye = 0.0
smyo = 0.0
k = 0

! Start the summations
DO
   ! Even terms
   smxe = smxe + epsxe
   smye = smye + epsye
   IF (k == ord) EXIT
   k = k + 1

   ! Odd terms
   smxo = smxo + epsxo
   smyo = smyo + epsyo
   IF (k == ord) EXIT
   k = k + 1

   ! Compute the updates
   epsxe = (2.0*k+1.0)*(ex*epsxe/(2.0*k-3.0)-epsxo)/ex
   epsye = (2.0*k+1.0)*(ey*epsye/(2.0*k-3.0)-epsyo)/ey
   epsxo = (2.0*k+3.0)*(ex*epsxo/(2.0*k-1.0)-epsxe)/ex
   epsyo = (2.0*k+3.0)*(ey*epsyo/(2.0*k-1.0)-epsye)/ey
END DO

! Finish by taking ratio related to odd and even summations
alpha = (chx - smxe)/(shx - smxo)
beta  = (chy - smye)/(shy - smyo)

RETURN
END SUBROUTINE weight


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pair_cover_query( n, c1, gg1, c2, gg2, rmax )

!  Given a pair of  ellipsoids, E1 and E2, determine whether E1
!  covers E2.  rmax <=1.d0 indicates that E1 covers E2.
!  E1 is defined by:  (x-c1)^T * G1 * G1^T * (x-c1) <= 1,
!  where the array gg1 contains G1 in packed format.  Similarly for E2.

!  Method:
!  1/ transform to y-space in which E1 is the unit ball at the origin:
!        y = G1^T * (x-c)
!  2/ in y-space, determine rmax = the distance from the origin to the
!        furthest point in E2
!  3/ if rmax <=1.d0, then E1 covers E2.

!  S.B. Pope  10/27/04

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: gg1((n*(n+1))/2), gg2((n*(n+1))/2), c1(n), c2(n)
real(k_dp), intent(out) :: rmax

integer    :: i, j, k
real(k_dp) :: g1(n,n), g2(n,n), c(n), origin(n), r(n)

! unpack gg1 and gg2
k  = 0
g1 = 0.d0
g2 = 0.d0
do j = 1, n
   do i = j, n
      k = k + 1
	  g1(i,j) = gg1(k)
	  g2(i,j) = gg2(k)
   end do
end do

! transform to y-space:  y = G1^T * x;  G2y = G1^{-1} * G2
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, g1, n, g2, n )

c = matmul( (c2-c1), g1 )

!  find point in G2y furthest from the origin

origin = 0.d0
call ellu_pt_near_far( 2, n, c, g2, origin, r )

rmax = sqrt( sum(r*r) )

return
end subroutine ell_pair_cover_query


      SUBROUTINE dcosft(Y,N)
!
! This is a double-precision version of a fast cosine transform routine
! from Numerical Recipes.  Computes the transform of Y(1:N+1) where N is a
! power of two.  This is also the inverse transform but in that case
! multiply Y by 2/N.
!
      IMPLICIT NONE
      INTEGER n, j
      REAL*8 Y(N+1)
      REAL*8 WR, WI, WPR, WPI, WTEMP, THETA, SUM, y1, y2
      THETA=3.141592653589793D0/DBLE(n)
      WR=1.0D0
      WI=0.0D0
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      SUM=.5d0*(Y(1)-y(n+1))
      y(1)=.5d0*(y(1)+y(n+1))
      DO 11 J=1,n/2 -1
         WTEMP=WR
         WR=WR*WPR-WI*WPI+WR
         WI=WI*WPR+WTEMP*WPI+WI
         Y1=0.5d0*(Y(J+1)+Y(n-J+1))
         Y2=(Y(J+1)-Y(n-J+1))
         Y(J+1)=Y1-WI*Y2
         Y(n-J+1)=Y1+WI*Y2
         SUM=SUM+WR*Y2
 11   CONTINUE
      CALL drealft(Y,n,+1)
      y(n+1)=y(2)
      Y(2)=SUM
      DO 12 J=4,N,2
         SUM=SUM+Y(J)
         Y(J)=SUM
 12   CONTINUE
      RETURN
      END SUBROUTINE DCOSFT


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pts_uncover( n, c, r_max, theta, npts, p, gg, phi, r_min )

!  Given:
!  1/ npts points p in n-space
!  2/ a center position c and a radius r_max
!  3/ a parameter  theta  0< theta <=1

!  Determine an ellipsoid E which:
!  1/ is centered at c
!  2/ has principal semi-axes no larger than r_max
!  3/ does not cover any of the given points p
!  4/ is as "large" as possible.

!  E is given by { x | norm(G^T * (x-c) ) <=1 ),  where G is an n x n lower
!  triangular matrix.  The array gg contains the matrix G in packed format.

!  The parameter theta ( 0 < theta <= 1 ) controls the shape of the ellipsoid
!  and the conditioning of the procedure.

!  In the first phase of the algorithm described below, a provisional ellipsoid,
!  E_n, is determined.  E is then obtained, by shrinking E_n by a factor phi,
!  so that no points are covered by E.  phi satisfies  theta <= phi <= 1.

!  S.B. Pope  6/30/06

!  Method:
!  There are n stages, in each of which a principal axis is determined.
!  The ellipsoid generated by stage k is denoted by E_k.
!  The length of the k-th principal semi-axis of E_k is r(k), and is determined
!  in the k-th stage.  The principal axes of E_k are r(j), for 1<= j <= k,
!  and r(k) for k <= j <= n.

!  The points are either "included", "partially excluded" or "excluded",
!  as described below.  Initially, all points are "included."

!  The displacementa of the points from c are given by y(1:n,1:npts), which
!  are the coordinates in an orthonormal basis which evolves (by Householder
!  reflections).  After stage k, the first k basis vectors are the principal axes.

!  At the end of the k-th stage, point j is covered by E_k if  h(j) <= 1,
!  where  h(j)  is defined by:
!    h(j) = sum_{i=1:n} (y(i,j)/r(i))^2
!  This can be decomposed as:
!    h(j) = f(j) + g(j)/r(k)^2,  where
!    f(j) = sum_{i<k} (y(i,j)/r(i))^2  and   g(j) = sum_{i>=k}(y(i,j))^2.

!  In the k-th stage, r(k) is taken to be as large as possible, such that  h(j)
!  is greater than (or equal to) one for all included points, and such that r(k)
!  is no greater that r_max.

!  If, at some stage and for some point j, f(j) exceeds unity, then that
!  point cannot be covered by E_n, regardless of how the remaining principal
!  axes are chose.  Such points are therefore "excluded" from further consideration.

!  Points with f(j) > theta^2 (for  0 < theta <= 1) are "partially excluded."
!  This means that they are not used to decide the principal axes.

!  The ellipsoid E_n generated at the end of the n-th stage has pricipal axes less
!  than or equal to r_max.  It does not cover any excluded points, but it may
!  cover other points.  E is then obtained by shrinking E_n by a determined factor
!  phi  (theta <= phi <= 1) such that E covers none of the points.

implicit none

integer, parameter      :: k_dp = kind(1.d0)

integer, intent(in)     :: n      ! dimensionality of the space
real(k_dp), intent(in)  :: c(n)   ! center of the ellipsoid E
real(k_dp), intent(in)  :: r_max  ! upper bound on principal semi-axes
real(k_dp), intent(in)  :: theta  ! control parameter
integer, intent(in)     :: npts   ! number of given points
real(k_dp), intent(in)  :: p(1:n,1:npts)   !  given points
real(k_dp), intent(out) :: gg((n*(n+1))/2) !  packed Cholesky matrix for E
real(k_dp), intent(out) :: phi    !  factor by which E_n is shrunk
real(k_dp), intent(out) :: r_min  !  smallest principal semi-axis of E

real(k_dp), parameter   :: shrink = 1.d-6  ! shrink to uncover points on boundary

integer    :: indicator(npts)  ! = 0, 1, 2 for included, partially excluded,
!                                  and excluded points
integer    :: j, k, kk, jmin
real(k_dp) :: f(npts), y(n,npts), g, r_max_sq, rsq, rsq_min, u(n,n), &
              r(n), v(n), w(n), beta, theta_sq

!---------  check input

   if( n < 1  .or.  npts < 0  .or.  r_max <= 0.d0  .or.  &
       theta <= 0.d0  .or.  theta > 1.d0 ) then
	   write(0,*) 'ell_pts_uncover: bad inpt, n, r_max, theta, npts = ', &
	              n, r_max, theta, npts
	   stop
   endif
!---------  initialization

   indicator = 0      !  all points are initially included
   r         = r_max  !  provisionally set E to ball of radius r_max
   f         = 0.d0
   u         = 0.d0
   r_max_sq  = r_max**2
   theta_sq  = theta**2
   phi       = 1.d0

   do k = 1, n  !  set canonical basis, i.e., U = I
      u(k,k) = 1.d0
   end do

   do j=1,npts  !  set displacements of points from c
      y(1:n,j) = p(1:n,j) - c(1:n)
   end do

!--------  loop over stages

   stages: do k = 1, n

      jmin = 0
	  rsq_min = r_max_sq

!  find the smallest g(j)
      do j = 1, npts
	     if( indicator(j) > 0 ) cycle  !  consider only included points
		 g    = sum( y(k:n,j)*y(k:n,j) )
		 if( g < rsq_min*(1.d0-f(j) ) ) then
		    jmin    = j
			rsq_min = g / ( 1.d0 - f(j) )
		 endif
      end do

	  if( jmin == 0 ) exit  stages  ! remaining principal semi-axis = r_max

      r(k) = sqrt( rsq_min ) !  principal semi-axis

	  !  Householder transformation so that, after transformation,
	  !  y(k:n,jmin) = [ r(k) 0 0 ... 0]'
	  !  Transform all included points

      v  = 0.d0
	  kk = n+1-k
	  call ell_house( kk, y(k:n,jmin), v(k:n), beta )

!  update orthogonal matrix U: post-multiply by H = I - beta * v * v^T

      w = beta * matmul( u(:,k:n), v(k:n) )
	  do j = k, n
	     u(:,j) = u(:,j) - w(:) * v(j)
	  end do

      if( k == n ) exit stages  !  skip f update on last stage

!  loop over points to update f and exclude
      do j = 1, npts
	     if( indicator(j) > 0 ) cycle  !  consider only included points

!  transform points to new basis
         y(k:n,j) = y(k:n,j) - beta * v(k:n) * sum( v(k:n)*y(k:n,j) )

!  update f and exclude points if so indicated
         f(j) = f(j) + (y(k,j)/r(k))**2

		 if( f(j) >= 1.d0 ) then
		    indicator(j) = 2  !  fully excluded
		 elseif( f(j) > theta_sq ) then
		    indicator(j) = 1  !  partially exclude
		 endif

      end do

   end do  stages !  end of loop over stages

!  form first estimate of E
   r_min = r(1)

   do k = 1, n
	  r(k) = 1.d0 / r(k)
   end do

   call ell_eig2chol( n, u, r, gg )

!  scale gg to ensure that all included and partially-excluded points are not
!    covered

   rsq_min = huge(0.d0)

   kk = 0
   do j = 1, npts
      if( indicator(j) == 2 ) cycle  !  do not consider excluded points
	  kk      = kk + 1
      v       = p(:,j)-c
      call dtpmv( 'L', 'T', 'N', n, gg, v, 1 )  !  yp = G^T * [p-c]
      rsq     = sum(v*v)
	  rsq_min = min( rsq, rsq_min )
   end do

   if( kk > 0 .and.  rsq_min < 1.d0 ) then ! shrink E by phi to uncover all points
      phi   = sqrt(rsq_min)
	  phi   = min( phi, 1.d0/(1.d0+shrink) )
	  r_min = r_min * phi
      gg    = gg  / phi

   else  ! shrink E slightly to uncover points on boundary
      gg    = gg * (1.d0+shrink)
      r_min = r_min / (1.d0+shrink)
   endif

   return

end subroutine ell_pts_uncover


program mtx_multi_loop

    !Undergraduate Student: Arturo Burgos
    !Professor: João Rodrigo Andrade
    !Federal University of Uberlândia - UFU, Fluid Mechanics Laboratory
    !MFLab, Block 5P, Uberlândia, MG, Brazil

    implicit none !To avoid variable definition problems, checking if they are correctly defined
    integer :: i, j, k
    real :: soma
    real, DIMENSION(1500,1500) :: mtx1, mtx2, mtx3
    DOUBLE PRECISION :: start, finish

    call random_number(mtx1)
    call random_number(mtx2)

    call cpu_time(start)

    do i = 1,1500

        do j = 1,1500
            soma = 0
            do k = 1,1500

                soma = soma + mtx1(i,k)*mtx2(k,j)
                mtx3(i,j) = soma

            end do

        end do

    end do

    call cpu_time(finish)

    print *,'Elapsed time is:',finish - start

end program mtx_multi_loop


submodule(euler_interface_m) euler_prob_0003_m
    implicit none

contains

    module character(len=20) function euler0003()
        write (euler0003, "(i20)") answer(600851475143_int64)
    end function euler0003

    pure function answer(n) result(ret)
        use euler_primes_m, only: sieve_of_Eratosthenes
        implicit none

        integer(int64), intent(in) :: n
        logical, allocatable :: is_prime(:)
        integer(int64) :: max_, ret

        max_ = int(sqrt(real(n, sp)) + 1._sp, int64)
        call sieve_of_Eratosthenes(max_, is_prime)
        do ret = max_, 2_int64, -1_int64
            if (is_prime(ret) .and. mod(n, ret) == 0_int64) exit
        end do
    end function answer

end submodule euler_prob_0003_m