      SUBROUTINE interpolation3D(C,x0,x,r,d)
      ! 3 dimensional interpolation kernel.
      !
      ! Inputs:
      !         x0: array with dimension(3) [x0,y0,z0]
      !         x : array with dimensions(1:r^3,1:3)
      !             x=[x1, x2,..;y1,y2,..;z1,z2,..]^T
      !         r : size of stencil (INTEGER)
      !         d: characteristic lengthscale, used for scaling in
      !         order to keep the matrix well conditioned
      !
      ! Output:
      !         C: A interpolation kernel with dimension(r^3:r^3)
      !         The stencil is assumed to be logically square so that the grid points
      !         and derivatives start at the lower left-hand corner and follow
      !         coordinate 2 (y) first and then coordinate 1 (x).  The coefficients
      !         are thus defined such that
      !
      !  c(k,1:r^3), k=(m-1)*r+n; corresponds to d^{m+n}/dx^m/dy^n.
      !   eg.:r=2 [f0 df/dy df/dx d^2f/dxdy df/dz df^2/dzdy df^2]
      !
      !
      ! Written by Bo Terp Paulsen, botp@mek.dtu.dk
      !

      ! Inputs / outputs
      !
      USE Interpolation_functions ! Decleration of matrix inversion,
      ! and factorial.
      IMPLICIT NONE
      INTEGER, PARAMETER :: dp = selected_real_kind(15, 307)
      INTEGER :: r,count1,count2
      REAL(KIND=dp), DIMENSION(:,:) :: x(r**3,3),C(r**3,r**3),mat(r**3,r**3)
      REAL(KIND=dp), DIMENSION(:) :: x0(3)
      REAL(KIND=dp) :: d

      ! Local variables
      !
      INTEGER :: i,j,k,m,n,b
      REAL(KIND=dp) :: factor

      !
      !
      factor = 1/d

      ! Generate Taylor coefficient matrix
      !
      count1 = 0
      count2 = 0
      DO i = 1,r ! x
        DO j = 1,r ! y
          Do k = 1,r ! z
          count1 = count1 +1
                DO m = 1,r ! x
                  DO n = 1,r ! y
                    DO b = 1,r ! z
                      count2 = count2 +1
                mat(count1,count2) = ((factor*(x(count1,1)-x0(1)))**(m-1)/fact(m-1))* &
                                     ((factor*(x(count1,2)-x0(2)))**(n-1)/fact(n-1))* &
                                     ((factor*(x(count1,3)-x0(3)))**(b-1)/fact(b-1))
                    END DO
                  END DO
                END DO

           count2 = 0
          END DO
        END DO
      END DO

        C = inv(mat)

      ! Rescaling of coefficients
      !
      count1 = 0

      DO i = 1,r ! x
        DO j = 1,r ! y
          Do k = 1,r ! z
          count1 = count1 +1
          DO count2 =1,r**3
          C(count1,count2) = factor**(i-1)*factor**(j-1)*factor**(k-1)*C(count1,count2)
          END DO

          END DO
        END DO
      END DO
      END SUBROUTINE interpolation3D

      SUBROUTINE interpolation2D(C,x0,x,r,d)
      ! 2 dimensional interpolation kernel.
      !
      ! Inputs:
      !         x0: array with dimension(3) [x0,y0,z0], only x0 and y0
      !         is used
      !         x=[x1, x2,..;y1,y2,..]^T
      !         r : size of stencil (INTEGER)
      !         dx: characteristic lengthscale, used for scaling in
      !         order to keep the matrix well conditioned
      !
      ! Output:
      !         C: A interpolation kernel with dimension(r^2:r^2)
      !         The stencil is assumed to be logically square so that the grid points
      !         and derivatives start at the lower left-hand corner and follow
      !         coordinate 2 (y) first and then coordinate 1 (x).  The coefficients !
      !         are
      !         thus defined such that
      !
      !  c(k,1:r^3), k=(m-1)*r+n; corresponds to d^{m+n}/dx^m/dy^n.
      !   eg.:r=2 [f0 df/dy df/dx d^2f/dxdy df/dz df^2/dzdy df^2]
      !
      !
      ! Written by Bo Terp Paulsen, botp@mek.dtu.dk
      !

      ! Inputs / outputs
      !
      USE Interpolation_functions
      IMPLICIT NONE
      INTEGER, PARAMETER :: dp = selected_real_kind(15, 307)
      INTEGER :: r
      REAL(KIND=dp), DIMENSION(:,:) :: x(r**2,2),C(r**2,r**2),mat(r**2,r**2)
      REAL(KIND=dp), DIMENSION(:) :: x0(3)
      REAL(KIND=dp) :: d

      ! Local variables
      !
      INTEGER :: i,j,m,n,count1,count2
      REAL(KIND=dp) :: factor

      ! Scaling factor
      !
      factor = 1/d

      ! Generate Taylor coefficient matrix
      !
      count1 = 0
      count2 = 0
      DO i = 1,r
        DO j = 1,r
          count1 = count1 +1
                DO m = 1,r
                  DO n = 1,r
                      count2 = count2 +1
           mat(count1,count2) = ((factor*(x(count1,1)-x0(1)))**(m-1)/fact(m-1))* &
                                ((factor*(x(count1,2)-x0(2)))**(n-1)/fact(n-1))
                  END DO
                END DO
           count2 = 0
        END DO
      END DO
        C = inv(mat)

      ! Rescaling of coefficients
      !
      count1 = 0

      DO i = 1,r
        DO j = 1,r
          count1 = count1 +1
          DO count2 =1,r**2
          C(count1,count2) = factor**(i-1)*factor**(j-1)*C(count1,count2)
          END DO

        END DO
      END DO
      END SUBROUTINE interpolation2D

      SUBROUTINE interpolation1D(C,x0,x,r)
      ! 1 dimensional interpolation kernel.
      !
      ! Inputs:
      !         x0: array with dimension(3) [x0,y0,z0], Only x0 is used
      !         x : array with dimensions(1:r,1)
      !             x=[x1, x2,..]^T
      !         r : size of stencil (INTEGER)
      !
      ! Output:
      !         C: A interpolation kernel with dimension(r:r)
      !
      !
      ! Written by Bo Terp Paulsen, botp@mek.dtu.dk
      !

      ! Inputs / outputs
      !
      USE Interpolation_functions
      IMPLICIT NONE
      INTEGER, PARAMETER :: dp = selected_real_kind(15, 307)
      INTEGER :: r
      REAL(KIND=dp), DIMENSION(:,:) :: C(r,r),mat(r,r)
      REAL(KIND=dp), DIMENSION(:) :: x0(3),x(r)
      REAL(KIND=dp) :: d

      ! Local variables
      !
      INTEGER :: i,m,count1, count2
      REAL(KIND=dp) :: factor

      ! Scaling factor
      !
      d = x(r)-x(r-1)
      factor = 1/d

      ! Generate Taylor coefficient matrix
      !
      count1 = 0
      count2 = 0
      DO i = 1,r
          count1 = count1 +1
                DO m = 1,r
                      count2 = count2 +1
          mat(count1,count2) = (factor*(x(count1)-x0(1)))**(m-1)/fact(m-1)
                END DO
          count2 = 0
      END DO
        C = inv(mat)

      ! Rescaling of coefficients
      !
      count1 = 0

      DO i = 1,r
          count1 = count1 +1
          DO count2 =1,r
          C(count1,count2) = factor**(i-1)*C(count1,count2)
          END DO
      END DO
      END SUBROUTINE interpolation1D

      SUBROUTINE TaylorInterpolation&
      (dir,x0,stencilSize)
      ! Evaluating a Taylor polynomial at point x0, with expansion point
      !at nearest neighbour.
      !
      ! Inputs:
      !        dir: Integer indication in which
      !        directions interpolation is desired.
      !        x0 : Point to which the values are interpolated.
      !
      ! Output:
      !        TaylorStencil: Interpolation stencil
      !        inOrOut: Flag indicating however the cell is located in
      !        or outside the water column
      !
      ! Written by Bo Terp Paulsen, botp@mek.dtu.dk
      !
      USE Precision
      USE GlobalVariables
      USE Interpolation_functions !Declaration of factorial func.
      IMPLICIT NONE

      ! Input variables
      !
      INTEGER :: dir
      REAL(KIND=long), DIMENSION(:) :: x0(3)

      ! Local variables
      !
      INTEGER :: stencilSize, i
      INTEGER, DIMENSION(:), POINTER :: NN
      REAL(KIND=long) :: sigma, dl
      REAL(KIND=long), DIMENSION(:), ALLOCATABLE :: dlVector
      REAL(KIND=long), DIMENSION(:,:) :: &
      transMAT(stencilSize,stencilSize)
      REAL(KIND=long), DIMENSION(:), POINTER :: xStencil, yStencil, zStencil

      ! Assign local pointers
      !
      xStencil => interpolation%stencilX
      yStencil => interpolation%stencilY
      zStencil => interpolation%stencilZ
      NN       => interpolation%NN

        IF(dir == 1) THEN
               ALLOCATE(dlVector(2*alpha +1))
               dl = x0(1)-FineGrid%x(NN(1),1)
               DO i = 0,2*alpha
                        dlVector(i+1) = dl**i / fact(i)
               END DO

               xStencil = &
               MATMUL(Interpolation%dx,dlVector)
       ENDIF

       IF(dir == 2) THEN
               ALLOCATE(dlVector(2*beta +1))
               dl = x0(2) - FineGrid%y(1,NN(2))
               DO i = 0,2*beta
                        dlVector(i+1) = dl**i / fact(i)
               END DO

               yStencil = &
               MATMUL(Interpolation%dy(:,:),dlVector)

       ENDIF

       IF(dir == 3) THEN
      ! Transformation of z-physical into sigma
      !
      sigma = (x0(3) ) / &
              (FineGrid%h(NN(1),NN(2)) + Wavefield%E(NN(1),NN(2)))

               ALLOCATE(dlVector(2*gamma + 1))
               dl = (sigma - FineGrid%z(NN(3)))
               DO i = 0,2*gamma
                        dlVector(i+1) = dl**i / fact(i)
               END DO

               zStencil = &
               MATMUL(Interpolation%dz(:,:,NN(3)),dlVector)

       ENDIF

      END SUBROUTINE TaylorInterpolation


MODULE AutoDiff_Module
USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY : DFP=>real64, I4B=>int32
IMPLICIT NONE

REAL( DFP ), PARAMETER :: eps=1.0E-8

PRIVATE

!----------------------------------------------------------------------------
!                                                                 Interfaces
!----------------------------------------------------------------------------

ABSTRACT INTERFACE

!> authors: Dr. Vikas Sharma
!
! This is a template for a scalar valued scalar function
! f:R-->R
  PURE FUNCTION userFunc_R_to_R( x ) RESULT( Ans )
    IMPORT :: DFP, I4B
    REAL( DFP ), INTENT( IN ) ::  x
    REAL( DFP ) :: Ans
  END FUNCTION userFunc_R_to_R
END INTERFACE

ABSTRACT INTERFACE

!> authors: Dr. Vikas Sharma
!
! This is a template for a scalar valued scalar function
! f:R2-->R
  PURE FUNCTION userFunc_R2_to_R( x, y ) RESULT( Ans )
    IMPORT :: DFP, I4B
    REAL( DFP ), INTENT( IN ) ::  x, y
    REAL( DFP ) :: Ans
  END FUNCTION userFunc_R2_to_R
END INTERFACE

!----------------------------------------------------------------------------
!                                                                 Derivative
!----------------------------------------------------------------------------

INTERFACE

!> authors: Dr. Vikas Sharma
!
!  $$\frac{df}{dx}$$
MODULE PURE FUNCTION derivative_R_to_R( f, x ) RESULT( Ans )
  REAL( DFP ), INTENT( IN ) :: x
  REAL( DFP ) :: Ans
  PROCEDURE( userFunc_R_to_R ), POINTER, INTENT( IN ) :: f
END FUNCTION derivative_R_to_R
END INTERFACE

!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------

INTERFACE

!> authors: Dr. Vikas Sharma
!
!  $$\frac{\partial f(x,y)}{\partial x}, \frac{\partial f(x,y)}{\partial y}$$
MODULE PURE FUNCTION derivative_R2_to_R( f, x, y ) RESULT( Ans )
  REAL( DFP ), INTENT( IN ) :: x, y
  REAL( DFP ) :: Ans(2)
  PROCEDURE( userFunc_R2_to_R ), POINTER, INTENT( IN ) :: f
END FUNCTION derivative_R2_to_R
END INTERFACE

INTERFACE derivative
  MODULE PROCEDURE derivative_R_to_R, derivative_R2_to_R
END INTERFACE derivative

PUBLIC :: derivative

END MODULE AutoDiff_Module


! { dg-do run { target vect_simd_clones } }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }

program fibonacci
   implicit none
   integer,parameter :: N=30
   integer           :: a(0:N-1), b(0:N-1)
   integer           :: a_ref(0:N-1)
   integer           :: i
   integer, external :: fib

   !$omp simd
   do i = 0,N-1
      b(i) = i
   end do

   !$omp simd
   do i=0,N-1
      a(i) = fib(b(i))
   end do

   call fib_ref (a_ref, N)

   do i = 0, N-1
     if (a(i) .ne. a_ref(i)) call abort ()
   end do

end program

recursive function fib(n) result(r)
!$omp declare simd(fib) inbranch
   integer  :: n, r

   if (n <= 1) then
       r = n
   else
      r = fib(n-1) + fib(n-2)
   endif

end function fib

subroutine fib_ref(a_ref, n)
   integer  :: n, a_ref(0:n-1)

   a_ref(0) = 0
   a_ref(1) = 1

   do i = 2, n-1
     a_ref(i) = a_ref(i-1) + a_ref(i-2)
   end do

end subroutine fib_ref


module test_function_object
  ! Object oriented approach for function
  ! evaluation.

  use utils, only : wp
  use num_integration

  implicit none

  abstract interface
    function f_interface(x)
      import :: wp
      real(wp), intent(in) :: x
      real(wp) :: f_interface
    end function f_interface
  end interface

  ! function_object is an object that can point
  ! to any function that follow the f_interface.
  ! This allows for the object to change its behavior
  ! in runtime.
  type, extends(fun) :: function_object
    procedure(f_interface), pointer, nopass :: f
  contains
    procedure :: eval => specialized_function
  end type function_object

  contains

  function specialized_function(self, x)
    class(function_object), intent(in) :: self
    real(wp), intent(in) :: x
    real(wp) :: specialized_function
    specialized_function = self%f(x)
  end function specialized_function

end module test_function_object

program romgerg_tests
use utils
use num_integration
use test_function_object

! Note that not every test is meant to pass,
! depending on the chosen number of iterations.
! Estimations by Romberg's using a low number
! of iterations should not give a decent
! approximation for higher order polynomials
! or complex functions.

implicit none

!---------------
! Variables
!---------------

integer :: i,j,l,m,n,total_tests,passed_tests
character (len=:), allocatable :: expression
real(wp) :: a(3),b(3)
integer :: k(3)
type(function_object) :: fobj

!---------------
! Logic
!---------------

total_tests = 1
passed_tests = 0
k = [5, 10, 15]
a = [-2.0, 0.0, 1.0]
b = [1.0, 1.0, 5.0]

write(*,*)
write(*,*) "!-------------------------------"
write(*,*) "! Testing integration by Romberg"
write(*,*) "!-------------------------------"
write(*,*)

do i = 1, size(k)
  write(*,*)
  write(*,*) "!----------------------------------"
  write(*,*) "! With k = ",k(i)
  write(*,*) "!----------------------------------"
  do j = 1, size(a)
    expression = trim("f(x)=1")
    fobj%f => poly0
    call test_integration(fobj,a(j),b(j),k(i),expression,passed_tests,total_tests,romberg,close)

    expression = trim("f(x)=x+1")
    fobj%f => poly1
    call test_integration(fobj,a(j),b(j),k(i),expression,passed_tests,total_tests,romberg,close)

    expression = trim("f(x)=3*x**2 + 2")
    fobj%f => poly2
    call test_integration(fobj,a(j),b(j),k(i),expression,passed_tests,total_tests,romberg,close)

    expression = trim("f(x)=33.33*x**5 + 8.8*x**4 + x**3 + 4.5*x*2 + 2.123")
    fobj%f => poly5
    call test_integration(fobj,a(j),b(j),k(i),expression,passed_tests,total_tests,romberg,close)

    expression = trim("f(x)=8*x**7/77 + (4*sin(2*x*pi) + 9*cos(11*x*pi))/5")
    fobj%f => ftrig
    call test_integration(fobj,a(j),b(j),k(i),expression,passed_tests,total_tests,romberg,close)

    expression = trim("f(x)=e^x")
    fobj%f => fe
    call test_integration(fobj,a(j),b(j),k(i),expression,passed_tests,total_tests,romberg,close)

    if ( a(j) > 0 ) then
      expression = trim("f(x)=ln(x)")
      fobj%f => fln
      call test_integration(fobj,a(j),b(j),k(i),expression,passed_tests,total_tests,romberg,close)
    end if
  end do
  write(*,*)
end do

write(*,*) "!---------------------------"
write(*,'(a,g14.6)') " !Total tests ", total_tests-1
write(*,'(a,g14.6)') " !Tests passed", passed_tests
write(*,*) "!---------------------------"

contains

  function poly0(x)
    real(wp), intent(in) :: x
    real(wp) :: poly0

    poly0 = 1.0_wp
  end function poly0

  function poly1(x)
    real(wp), intent(in) :: x
    real(wp) :: poly1

    poly1 = x + 1
  end function poly1

  function poly2(x)
    real(wp), intent(in) :: x
    real(wp) :: poly2

    poly2 = 3*x**2 + 2
  end function poly2

  function poly5(x)
    real(wp), intent(in) :: x
    real(wp) :: poly5

    poly5 = 33.33*x**5 + 8.8*x**4 + x**3 + 4.5*x*2 + 2.123
  end function poly5

  function ftrig(x)
    real(wp), intent(in) :: x
    real(wp) :: ftrig

    ftrig = 8*x**7/77 + (4*sin(2*x*pi) + 9*cos(11*x*pi))/5
  end function ftrig

  function fe(x)
    real(wp), intent(in) :: x
    real(wp) :: fe

    fe = exp(x)
  end function fe

  function fln(x)
    real(wp), intent(in) :: x
    real(wp) :: fln

    fln = log(x)
  end function fln

  subroutine test_integration(fobj,a,b,k,expression,passed_tests,total_tests,romberg,close)
    real(wp), intent(in) :: a,b
    real(wp) :: true,result,abserr
    real(wp), parameter :: epsabs = 0.0D+00
    real(wp), parameter :: epsrel = 0.001D+00
    integer, intent(inout) :: passed_tests, total_tests
    integer, intent(in) :: k
    integer, parameter :: key = 6
    integer, parameter :: limit = 500
    integer, parameter :: lenw = 4 * limit
    integer :: ier
    integer :: iwork(limit)
    integer :: last
    integer :: neval
    real(wp) :: work(lenw)

!    real(wp), external :: f
!    real(wp), external :: fcomp
    class(function_object), intent(in) :: fobj
    real(wp), external :: romberg
    logical, external :: close

    character (len=:), allocatable, intent(in) :: expression

    write(*,*)
    write(*,*) "Test number ", total_tests
    total_tests = total_tests + 1
    result = romberg(fobj, a, b, k)
    call dqag ( fobj%f , a, b, epsabs, epsrel, key, true, abserr, neval, ier,&
    limit, lenw, last, iwork, work )

    write (*, '(A,A)') '  Integrand is ', expression
    write ( *, '(A,F15.5)' ) '  Integral left endpoint A     ', a
    write ( *, '(A,F15.5)' ) '  Integral right endpoint B    ', b
    write (*, '(A,I15)') '  #Romberg iterations(k) is', k
    write ( *, '(A,F15.5)' ) '  Integral is                  ', true
    write ( *, '(A,F15.5)' ) '  Estimated integral is        ', result
    if ( close(result,true,1.0_wp*1e-5) ) then
      passed_tests = passed_tests + 1
      write(*,*) "!Test passed!"
    else
      write(*,*) "!-----------!"
      write(*,*) "!Test failed!"
      write(*,*) "!-----------!"
    end if
    write(*,*)

  end subroutine test_integration
end program romgerg_tests


program ch0510v2
    ! Using the Numeric Inquiry Functions with Real Types
    use iso_fortran_env
    implicit none

    real :: r
    real(real32) :: rsp
    real(real64) :: rdp
    real(real128) :: rqp

    print *, ' ====================='
    print *, ' Real kind information'
    print *, ' ====================='
    print *, ' kind number'
    print *, ' ', kind(r), ' ', kind(rsp), ' ', &
        kind(rdp), ' ', kind(rqp)

    print *, ' digits details'
    print *, ' ', digits(r), ' ', digits(rsp), &
        ' ', digits(rdp), ' ', digits(rqp)

    print *, ' epsilon details'
    print *, ' ', epsilon(r)
    print *, ' ', epsilon(rsp)
    print *, ' ', epsilon(rdp)
    print *, ' ', epsilon(rqp)

    print *, ' huge value'
    print *, ' ', huge(r)
    print *, ' ', huge(rsp)
    print *, ' ', huge(rdp)
    print *, ' ', huge(rqp)

    print *, ' maxexponent value'
    print *, ' ', maxexponent(r)
    print *, ' ', maxexponent(rsp)
    print *, ' ', maxexponent(rdp)
    print *, ' ', maxexponent(rqp)

    print *, ' minexponent value'
    print *, ' ', minexponent(r)
    print *, ' ', minexponent(rsp)
    print *, ' ', minexponent(rdp)
    print *, ' ', minexponent(rqp)

    print *, ' precision details'
    print *, ' ', precision(r), ' ', &
        precision(rsp), ' ', precision(rdp), ' ', &
        precision(rqp)

    print *, ' radix details'
    print *, ' ', radix(r), ' ', radix(rsp), &
        ' ', radix(rdp), ' ', radix(rqp)

    print *, ' range details'
    print *, ' ', range(r), ' ', range(rsp), &
        ' ', range(rdp), ' ', range(rqp)

    print *, ' tiny details'
    print *, ' ', tiny(r)
    print *, ' ', tiny(rsp)
    print *, ' ', tiny(rdp)
    print *, ' ', tiny(rqp)
end program


module reciprocal_module
    implicit none

    contains
    elemental real function reciprocal(x)
        implicit none

        real, intent(in) :: x

        reciprocal = 1./x
    end function
end module

program ch1213
    ! Elemental Functions
    use reciprocal_module
    implicit none

    real :: x = 10.
    real, dimension(1:5) :: y = [ 1., 2., 3., 4., 5. ]

    print *, 'reciprocal of x is ', reciprocal(x)
    print *, 'reciprocal of y is ', reciprocal(y)
end program


INCLUDE 'calc_hypotenuse.f90'

PROGRAM test_hypotenuse
IMPLICIT NONE
  REAL :: s1, s2, hypo
  WRITE(*, *) "Testing subroutine calc_hypotenuse."
  WRITE(*, *) "Enter length of side 1: "
  READ(*, *) s1
  WRITE(*, *) "Enter length of side 2:"
  READ(*, *) s2
  CALL calc_hypotenuse(s1, s2, hypo)
  WRITE(*, 1000) hypo
  1000 FORMAT ('The length of the hypotenuse is ', F10.4)

END PROGRAM test_hypotenuse


	FUNCTION TRAPZ2(X,Y,N,X1,X2,IERR)

c	Finds area below y(x) from x=X1 to x =X2
c	X1 and X2 are not necessarily values of x(i)
c	but must fulfill X1>=x(1) and X2<=x(n)

c	Array declaration
	real x(n),y(n)
	data jerr1,jerr2/2*0/

	TRAPZ2=0.
	ierr=0.

!	Check for values outside valid range
	if (x1 < x(1)) then
		if (jerr1.eq.0) then
			write (6,*) 'TRAPZ2: X1 outside valid range:',x1,x(1),x(n),n
			jerr1=1
		endif
		ierr=1
		return
!		stop
	elseif (x1 == x(1)) then
		i1 = 1
	else
!		Find first element in array X above X1
		do i=1,n
		if (x(i) > x1) then
			i1=i
!			Find by interpolation values of Y1=y(X1)
			Y1 = ( (x(i1)-x1)*y(i1-1) + (x1-x(i1-1))*y(i1) ) / (x(i1)-x(i1-1))
!			Add area from x(i1-1) to X1
			trapz2=trapz2+(x(i1)-x1)*(Y1+y(i1))/2.
			goto 1
		endif
		enddo
	endif
1	if (x2 > x(n)) then
		if (jerr2.eq.0) then
			write (6,*) 'TRAPZ2: X2 outside valid range:',x2,x(1),x(n),n
			jerr2=1
		endif
		ierr=2
		return
!		stop
	elseif (x2 == x(n)) then
		i2 = n
	else
!		Find last element in array X below X2
		do i=i1,n
		if (x(i) > x2) then
			i2=i-1
!			Find by interpolation values of Y2=y(X2)
			Y2 = ( (x(i2+1)-x2)*y(i2) + (x2-x(i2))*y(i2+1) ) / (x(i2+1)-x(i2))
!			Add area from x(i2) to X2
			trapz2=trapz2+(x2-x(i2))*(Y2+y(i2))/2.
			goto 2
		endif
		enddo
	endif

!	Compute area from x(i1) to x(i2)
2	do i=i1+1,i2
	trapz2=trapz2+(x(i)-x(i-1))*(y(i)+y(i-1))/2.
	enddo
!	write (6,*) 'TRAPZ2: using = ',i1+1,i2,x(i1),x(i2),i2-i1,' points'
	return
	end


program problem72
  implicit none
  integer, parameter    :: m=664579,limit=1000000
  integer, dimension(m) :: primes
  integer               :: i
  integer*16            :: answer

  open(33,file='./data/problem70.dat')
  read(33,*) primes

  answer=0
  do i=2,limit
     answer=answer+phi(i)
  end do

  print *, answer

contains

  function phi(n)
    implicit none
    integer, intent(in) :: n
    integer             :: p,phi,i,rest

    phi=n
    rest=n
    do i=1,n
       p=primes(i)
       if (mod(rest,p)==0) then
          phi=(phi/p)*(p-1)
          do while (mod(rest,p)==0)
             rest=rest/p
          end do
       end if

       ! Important: if the current prime is more than the square root
       ! of what is left, then what is left must be the last prime
       ! factor.
       if (p>sqrt(real(rest))) then
          if (rest>1) phi=(phi/rest)*(rest-1)
          exit
       end if
    end do

  end function phi

end program problem72


submodule (points) points_a
contains

real module function point_dist(a,b) result(dist)
        type(point), intent(in) :: a, b
        real :: dist
        dist = sqrt((a%x-b%x)**2+(a%y-b%y)**2)
end function point_dist

end submodule points_a


module forno1d

contains

subroutine calcula_perfil(Ta, T1, T2, T3, R1, R2, R3,T)
    implicit none

    real, intent(in) :: Ta, T1, T2, T3, R1, R2, R3
    integer, parameter :: n = 30   ! número de elementos finitos
    real, dimension(n), intent(out) :: T

    real :: L, sor, dx, T_media, Tn
    integer :: p_n1, p_n2, p_n3, i, j ,k
    real, dimension(n) :: fonte

    L = 2.0         ! comprimento do forno em metros
    sor = 1.85      ! parâmetro sor
    p_n1 = n/4      ! posição do primeiro sensor de Temperatura
    p_n2 = n/2      ! segundo sensor
    p_n3 = 3*n/4    ! terceiro sensor

    dx = L/(n+1)
    T_media = (2*Ta + T1 + T2 + T3)/5

    ! valores iniciais da temperatura
    do i=1, n-1
        T(i) = T_media
    enddo
    T(1) = Ta   ! tempa ambiente nas pontas (direichilet)
    T(n) = Ta   ! tempa ambiente nas pontas (direichilet)

    ! valores da fonte
    do i=1, INT(n/3)
        fonte(i) = R1
    enddo
    do i=INT(n/3)+1, INT(2*n/3)
        fonte(i) = R2
    enddo
    do i=INT(2*n/3)+1, n
        fonte(i) = R3
    enddo

    do j=1, 200
        do i=2 , n-1
            if (i == p_n1) then
                T(i) = T1
            else if (i == p_n2) then
                T(i) = T2
            else if (i == p_n3) then
                T(i) = T3
            else
                Tn = (T(i-1) + T(i+1))/2.0 +dx*dx*fonte(i)
                T(i) = T(i) + sor*( Tn - T(i) )
            end if
        enddo
    enddo

end subroutine calcula_perfil

end module forno1d


program phase_iterative
    implicit none

!!  # Grid parameters
    integer maxmx, maxmy
    parameter(maxmx = 2**10, maxmy = 2**10)

!!   # Input parameters
    double precision ax_in, ay_in, dx_in, dy_in, t_in, tstart
    double precision domain_length
    integer mx_in, my_in, nstp, izero, nchar
    character*100 fname
    logical restart

    double precision phi(maxmx, maxmy)
    double precision u(maxmx, maxmy)
    double precision theta, r, rp, amp

!!  # More grid parameters
    integer mx, my, i, j, n, nout, nstep
    double precision ax, ay, bx, by, dx, dy, dt, tfinal, t
    double precision x(maxmx), y(maxmy)

!!  # Misc
    integer iframe, iframe_start
    double precision pi, dsgn

    integer mbdcnd, nbdcnd, ierror, idimf
    double precision lambda, lambda_phi, pertrb
    double precision bda(maxmy), bdb(maxmy)
    double precision bdc(maxmx), bdd(maxmx)
    double precision f(maxmx, maxmy)

!!  # Temporary variables
    double precision u_n, phi_n, g0, g

    double precision phik(maxmx, maxmy)
    double precision uk(maxmx, maxmy)
    double precision phikp1(maxmx, maxmy)
    double precision ukp1(maxmx, maxmy)

    double precision f1(maxmx, maxmy)
    double precision f2(maxmx, maxmy)
    double precision S1(maxmx, maxmy)
    double precision S2(maxmx, maxmy)
    double precision S3(maxmx, maxmy)
    double precision err(2), errmax(2), tol

!!  # Model parameters
    double precision S, alpha, mparm, xi, gamma

    double precision r0, x0, y0, kanio, pdel
    common /parm_comm/ r0, x0, y0, kanio, pdel

    !! Temporary variables
    double precision beta, Tinv

    integer wsize, wsize_t
!!         13M + 4N + M*INT(LOG2(N))
!!             log2(N) <= log2(maxmy) ~ 10
    parameter(wsize = 4*maxmy + (13 + 12)*maxmx)
    double precision work(wsize)

    double precision xlow, ylow, w

    integer k, kmax, ktotal, avg_iterations, method
    logical prt_iterations
    integer jacobi, gauss_seidel
    parameter(jacobi=0, gauss_seidel=1)

    wsize_t = 4*(maxmy) + &
            (13 + int(log(real(my))/log(2.d0))*mx)
    if (wsize < wsize_t) then
        write(6,*) 'Increase wsize from ', wsize, ' to ',wsize_t
        stop
    endif
    pi = 4.d0*datan(1.d0)

!!  # --------------------------------
!!  # Set up grid
!!  # --------------------------------

    open(10,file='phase_iterative.dat')
    read(10,*) mx, my
!!      read(10,*) ax, bx, ay, by
    read(10,*) domain_length
    read(10,*) nstep, nout
    read(10,*) dt

    if (mx > maxmx .or. my > maxmy) then
        write(6,*) 'mx or my too big'
        stop
    endif

    ax = -domain_length/2
    bx = domain_length/2
    ay = -domain_length/2
    by = domain_length/2

    dx = (bx - ax)/mx
    dy = (by - ay)/my

    do i = 1,mx
        x(i) = ax + (i-0.5)*dx
    enddo

    do j = 1,my
        y(j) = ay + (j-0.5)*dy
    enddo

!!  # ------------------------------------
!!  # Numerical parameters - Jacobi method
!!  # ------------------------------------
    read(10,*) kmax
    read(10,*) tol
    read(10,*) method
    read(10,*) prt_iterations

!!  # ----------------------------
!!  # model parameters
!!  # ----------------------------
    read(10,*) S
    read(10,*) alpha
    read(10,*) mparm
    read(10,*) xi
    read(10,*) kanio
    read(10,*) r0
    read(10,*) pdel
    read(10,*) gamma

!!  # ----------------------------
!!  # Get restart information
!!  # ----------------------------
    read(10,*) restart
    if (restart) then
       read(10,*) fname
    endif
    close(10)

    write(6,*) 'Parameters used for this run : '
    write(6,*) '---------------------------'
    write(6,*) 'Non-dimensional parameters'
    write(6,*) '---------------------------'
    write(6,200) 'S       = ', S
    write(6,200) 'alpha   = ', alpha
    write(6,200) 'm       = ', mparm
    write(6,200) 'xi      = ', xi
    write(6,200) 'k       = ', kanio
    write(6,200) 'r0      = ', r0
    write(6,200) 'pdel    = ', pdel
    write(6,200) 'gamma   = ', gamma
    write(6,*) ' '
    write(6,*) '---------------------------'
    write(6,*) 'Grid parameters'
    write(6,*) '---------------------------'
    write(6,220) 'mx   = ', mx
    write(6,220) 'my   = ', my
    write(6,200) 'ax   = ', ax
    write(6,200) 'bx   = ', bx
    write(6,200) 'ay   = ', ay
    write(6,200) 'by   = ', by
    write(6,200) 'dx   = ', dx
    write(6,200) 'dy   = ', dy
    write(6,220) 'kmax = ',kmax
    write(6,225) 'tol  = ',tol

    if (restart) then
        write(6,*) 'Restart from file ', fname
    else
        write(6,*) 'Initializing run from scratch...'
    endif

 200  format(a,F10.5)
 210  format(a,E12.6)
 225  format(a,E12.1)
 220  format(a,I5)

!!   # --------------------------------
!!   # Initialize phi
!!   # --------------------------------
    write(6,*) 'Initializing phi and u...'

    if (restart) then
        open(20,file=fname)
        read(20,*) mx_in
        read(20,*) my_in
        read(20,*) ax_in
        read(20,*) ay_in
        read(20,*) dx_in
        read(20,*) dy_in
        read(20,*) t_in

        if (mx_in .ne. mx .or. my_in .ne. my) then
            write(6,*) 'Problem with restart: mx or my not right.'
            stop
        elseif (ax_in .ne. ax .or. ay_in .ne. ay) then
            write(6,*) 'Problem with restart: ax or ay not right'
            stop
        endif
        izero = iachar('0')
        tstart = t_in
        iframe_start = 0
        nstp = 1
        do i = 10,7,-1
            nchar = iachar(fname(i:i)) - izero
            iframe_start = iframe_start + nchar*nstp
            nstp = nstp*10
        enddo

        do j = 1,my
            do i = 1,mx
                read(20,*) phi(i,j), u(i,j)
            enddo
        enddo
        close(20)
    else

        x0 = (ax + bx)/2.d0
        y0 = (ay + by)/2.d0
        tstart = 0.0
        iframe = 0
        do j = 1,my
            do i = 1,mx
                xlow = ax + (i-1)*dx
                ylow = ay + (j-1)*dy
!!              rp = sqrt((xlow)**2 + (ylow)**2)

                call cellave(xlow,ylow,dx,dy,w)
                u(i,j) = w-1.d0
                phi(i,j) = 1-w

!!              r = sqrt((amp*(x(i) - x0))**2 + (y(j) - y0)**2)
!!              theta = atan2(y(j) - y0,x(i) - x0)
!!              rp = r0*(1.d0 + pdel*cos(kanio*theta))
!!              d = tanh((r-rp)/xi)
!!              u(i,j) = -0.5d0*(d + 1)  !! In [-1,0]
!!              phi(i,j) = 0 0.5d0*(d + 1)  !! In [0,1]
            enddo
        enddo
        write(6,*) 'Done with initialization'

!!      # Output frame only if we have initialized data from scratch.
        write(6,600) 0,tstart,0
        call out2(maxmx,maxmy,mx,my,ax,ay,dx,dy,phi,u,tstart, &
              iframe_start)
    endif

    !!  % --------------------------------------
    !!  % Time step through results
    !!  % --------------------------------------

    do j = 1,my
        bda(j) = 0.d0
        bdb(j) = 0.d0
    enddo

    do i = 1,mx
        bdc(i) = 0.d0
        bdd(i) = 0.d0
    enddo

    lambda = -1.d0/dt
    idimf = maxmx
    mbdcnd = 3
    nbdcnd = 3

    beta = xi**2/mparm
    Tinv = 1.d0/xi**2
    lambda_phi = lambda*beta*Tinv

    avg_iterations = 0
    iframe = iframe_start
    do n = 1,nout
        t = tstart + n*dt

        !!  write(6,100) n,t
100     format('Step',I5,' at time t = ',1PE12.5)

        !! From right hand side for block linear system
        do j = 1,my
            do i = 1,mx
                phi_n = phi(i,j) !! old phi(i,j)
                u_n = u(i,j)

                g0 = phi_n*(1-phi_n)
                g = g0*g0

                S1(i,j) = 30*g/S
                S2(i,j) = 30*g*xi*alpha*S
                S3(i,j) = g0*(phi_n - 0.5d0)

                f1(i,j) = lambda*(u_n + S1(i,j)*phi_n);
                f2(i,j) = lambda*beta*phi_n - S3(i,j)
            end do
        end do

        !!  # Start Jacobi iterations
        do j = 1,my
            do i = 1,mx
                uk(i,j) = u(i,j)
                phik(i,j) = phi(i,j)
            end do
        end do
        do k = 1,kmax

            !! ----------------------------------------------
            !!  # Set up right hand side for u
            !! ----------------------------------------------
            do j = 1,my
                do i = 1,mx
                    !! this could be  computed outside of k-loop
!!                    phi_n = phi(i,j)
!!                    g0 = phi_n*(1-phi_n)
!!                    g = g0*g0
!!                    S1 = 30*g/S

                    f(i,j) = -lambda*S1(i,j)*phik(i,j) + f1(i,j)
                end do
            end do

            !!  # Solve equation for u; solution will be in f
            call hstcrt(ax,bx,mx,mbdcnd,bda,bdb,ay,by,my,nbdcnd, &
                        bdc,bdd,lambda,f,idimf,pertrb,ierror,work)

            if (work(1) .gt. wsize) then
                write(6,*) 'hstcrt : Allocate more work for wsize; ', wsize, work(1)
            endif

            if (ierror .ne. 0) then
                write(6,*) 'hstcrt : ierror /= 0', ierror
                stop
            endif

            if (abs(pertrb) .gt. 0) then
                write(6,*) 'pertrb > 0;  ', pertrb
                stop
            endif

            do j = 1,my
                do i = 1,mx
                    ukp1(i,j) = f(i,j)
                end do
            end do

            !! ----------------------------------------------
            !! Set-up right hand side for phi
            !! ----------------------------------------------
            do j = 1,my
                do i = 1,mx
!!                    u_n = u(i,j)
!!                    phi_n = phi(i,j)
!!                    g0 = phi_n*(1-phi_n)
!!                    g = g0*g0
!!                    S2 = 30*g*xi*alpha*S
                    if (method .eq. jacobi) then
                        f(i,j) = Tinv*(-S2(i,j)*uk(i,j) + f2(i,j))
                    else
                        f(i,j) = Tinv*(-S2(i,j)*ukp1(i,j) + f2(i,j))
                    endif
                end do
            end do

            !!  # Solve equation for phi; solution will be in f
            call hstcrt(ax,bx,mx,mbdcnd,bda,bdb,ay,by,my,nbdcnd, &
                        bdc,bdd,lambda_phi,f,idimf,pertrb,ierror,work)

            if (ierror .ne. 0) then
                write(6,*) 'hstcrt : ierror /= 0; ', ierror
                stop
            endif

            do j = 1,my
                do i = 1,mx
                    phikp1(i,j) = f(i,j)
                end do
            end do

            errmax(1) = 0
            errmax(2) = 0
            do j = 1,my
                do i = 1,mx
                    err(1) = abs(ukp1(i,j) - uk(i,j))
                    err(2) = abs(phikp1(i,j) - phik(i,j))
                    errmax(1) = max(errmax(1),err(1))
                    errmax(2) = max(errmax(2),err(2))
                end do
            end do
            if (prt_iterations) then
!!                write(6,601) 'Step ', n, 'Iteration ',k,'Residual(u)', errmax(1), &
!!                                        'Residual(phi)', errmax(2)
            endif
            ktotal = k
            if (max(errmax(1), errmax(2)) < tol) then
                exit  !! Exit Jacobi iteration
            endif

            !! Swap k and kp1
            do j = 1,my
                do i = 1,mx
                    uk(i,j) = ukp1(i,j)
                    phik(i,j) = phikp1(i,j)
                end do
            end do

        !! end of Jacobi iteration
        end do
        if (prt_iterations) then
            write(6,601) 'Step ', n, 'Iterations/step ',ktotal,'Residual(u)', errmax(1), &
                     'Residual(phi)', errmax(2)
!!            write(6,*) ' '
        endif
        avg_iterations = avg_iterations + ktotal

        !!  # ---------------------------------
        !!  # Output results
        !!  # ---------------------------------

        if (nstep*(n/nstep) == n) then
            iframe = iframe + 1
            write(6,600) iframe, t, avg_iterations/nstep
            call out2(maxmx,maxmy,mx,my,ax,ay,dx,dy,phi,u,t,iframe)
            avg_iterations = 0
        endif

600     format('Writing frame ',I5,' at time t = ',1PE12.5,' (avg. iterations = ',I3,')')
601     format(A,I5,A20,I4,A15,E12.4,A15,E12.4)

        !! Update time level n solutions
        do j = 1,my
            do i = 1,mx
                u(i,j) = ukp1(i,j)
                phi(i,j) = phikp1(i,j)
            end do
        end do

    !! End of time  loop
    end do

end program phase_iterative

double precision function fdisc(x,y)
    implicit none

    double precision x,y, r, rp, theta

    double precision r0, x0, y0, kanio, pdel
    common /parm_comm/ r0, x0, y0, kanio, pdel

    r = sqrt((x-x0)**2 + (y-y0)**2)
    theta = atan2(y - y0,x - x0)
    rp = r0*(1.d0 + pdel*cos(kanio*theta))
    fdisc = r - rp

end function fdisc


program prog
   use variables
   use constants

   call InitiliseVariables
   call InitFields

   call UVSolver

   call DestroyVariables

end program prog
!-------------------------------------!
! Setting boundary condition for UV   !
!-------------------------------------!
subroutine InitFields
   use variables
   use constants

   do i=1,MaxN
      aUx1(i)=0.0
      bUx1(i)=0.0
      aUx2(i)=0.0
      bUx2(i)=0.0

      aUy1(i)=0.0
      bUy1(i)=0.0
      aUy2(i)=0.0
      bUy2(i)=1.0

      aVx1(i)=0.0
      bVx1(i)=0.0
      aVx2(i)=0.0
      bVx2(i)=0.0

      aVy1(i)=0.0
      bVy1(i)=0.0
      aVy2(i)=0.0
      bVy2(i)=0.0

   enddo

   do i=0,MaxN+1
       do j=0,MaxN+1
           u(i,j)=0.0
           v(i,j)=0.0
           p(i,j)=0.0
           Uo12(i,j)=0.0
           Uon(i,j)=0.0
           Vo12(i,j)=0.0
           Von(i,j)=0.0
       enddo
   enddo
 !  forall (j=1:MaxN) u(0,j)=1.0
end subroutine InitFields
!-------------------------------------!
! Run solver for velocity             !
! Rouch 140 stranica                  !
!-------------------------------------!
subroutine UVSolver
   use variables
   use constants
   real, dimension(0:MaxN) :: A
   real, dimension(0:MaxN) :: B
   real, dimension(0:MaxN) :: C
   real, dimension(0:MaxN) :: F
   real, dimension(1:MaxN) :: X
   integer :: i,j,k
   integer :: printtime
   do iter=1,MaxTime
	!***************  U po x
	   do j=1,MaxN
		 do i=1,MaxN
            A(i) = -(-u(i,j)*addx(i,j) + ad2dx2(i,j)/Re)
            B(i) = -(-u(i,j)*bddx(i,j) + bd2dx2(i,j)/Re) + 2.0/dt
            C(i) = -(-u(i,j)*cddx(i,j) + cd2dx2(i,j)/Re)
            F(i) =(-v(i,j)*dudy(i,j,0) + d2udy2(i,j,0)/Re) + 2.0*u(i,j)/dt
         enddo
         A(0)=aUx1(j)
         B(0)=bUx1(j)
         C(0)=aUx2(j)
         F(0)=bUx2(j)
		 call sweepF(A,B,C,F,X)
         forall (i=1:MaxN)	Uo12(i,j)=X(i)
       enddo
!       forall (i=1:MaxN, j=1:MaxN) u(i,j)=Uo12(i,j)
!       call WriteFile(VarU,Iter+MaxTime)
	!***************  U po y
	   do i=1,MaxN
		 do j=1,MaxN
            A(j) = -(-v(i,j)*addy(i,j) + ad2dy2(i,j)/Re)
            B(j) = -(-v(i,j)*bddy(i,j) + bd2dy2(i,j)/Re) + 2.0/dt
            C(j) = -(-v(i,j)*cddy(i,j) + cd2dy2(i,j)/Re)
            F(j) =(-u(i,j)*dudx(i,j,1) + d2udx2(i,j,1)/Re) + 2.0*Uo12(i,j)/dt
         enddo
         A(0)=aUy1(i)
         B(0)=bUy1(i)
         C(0)=aUy2(i)
         F(0)=bUy2(i)
    	 call sweepF(A,B,C,F,X)
         forall (j=1:MaxN) Uon(i,j)=X(j)
       enddo
!	forall (i=1:MaxN, j=1:MaxN) u(i,j)=Uo23(i,j)
	!***************  V po x
	   do j=1,MaxN
		 do i=1,MaxN
            A(i) = -(-u(i,j)*addx(i,j) + ad2dx2(i,j)/Re)
            B(i) = -(-u(i,j)*bddx(i,j) + bd2dx2(i,j)/Re) + 2.0/dt
            C(i) = -(-u(i,j)*cddx(i,j) + cd2dx2(i,j)/Re)
            F(i) =(-v(i,j)*dvdy(i,j,0) + d2vdy2(i,j,0)/Re) + 2.0*v(i,j)/dt
         enddo
         A(0)=aVx1(j)
         B(0)=bVx1(j)
         C(0)=aVx2(j)
         F(0)=bVx2(j)
		 call sweepF(A,B,C,F,X)
         forall (i=1:MaxN)	Vo12(i,j)=X(i)
       enddo
	forall (i=1:MaxN, j=1:MaxN) v(i,j)=Vo12(i,j)
	!**************  V po y
	   do i=1,MaxN
		 do j=1,MaxN
            A(j) = -(-v(i,j)*addy(i,j) + ad2dy2(i,j)/Re)
            B(j) = -(-v(i,j)*bddy(i,j) + bd2dy2(i,j)/Re) + 2.0/dt
            C(j) = -(-v(i,j)*cddy(i,j) + cd2dy2(i,j)/Re)
            F(j) =(-u(i,j)*dvdx(i,j,1) + d2vdx2(i,j,1)/Re) + 2.0*Vo12(i,j)/dt
         enddo
         A(0)=aVy1(i)
         B(0)=bVy1(i)
         C(0)=aVy2(i)
         F(0)=bVy2(i)
		 call sweepF(A,B,C,F,X)
         forall (j=1:MaxN) Von(i,j)=X(j)
       enddo
!    forall (i=1:MaxN, j=1:MaxN) v(i,j)=Vo23(i,j)
!    forall (i=1:MaxN, j=1:MaxN) u(i,j)=Uo23(i,j)
    call Poisson_2D
    do j=1,MaxN
        do i=2,MaxN-1
            u(i,j)=Uon(i,j)-dt*(p(i,j)-p(i-1,j))/dx

        enddo
    enddo
    do i=1,MaxN
        do j=2,MaxN-1
            v(i,j)=Von(i,j)-dt*(p(i,j)-p(i,j-1))/dy
        enddo
    enddo

!    call WriteFile(VarU,Iter)
!    call WriteFile(VarV,Iter)
     if (Mod(Iter,PrintEvery).eq.0) then
         WRITE(*,*) 'Time: ', Iter
         printtime=Iter/PrintEvery
         call WriteIter(printtime)
     endif
   enddo
end subroutine UVSolver
!-------------------------------------!
! Thomas method                       !
!-------------------------------------!
subroutine sweepF(A,B,C,F,X)
   use variables
   use constants
   real :: A(0:MaxN),B(0:MaxN),C(0:MaxN),F(0:MaxN)
   real :: X(1:MaxN)
   integer :: I
   real :: alfa(MaxN+1),beta(MaxN+1)
   real :: temp
   alfa(MaxN)=C(0)
   beta(MaxN)=F(0)
   do I=MaxN-1,1,-1
      temp =(B(I)+A(I)*alfa(I+1))

      alfa(I)=-C(I)/temp
      beta(I)=(F(I)-A(I)*beta(I+1))/temp
   enddo
     X(1)=(alfa(1)*B(0)+beta(1))/(1.0-alfa(1)*A(0))
   do I=1,  MaxN-1
      X(I+1)=alfa(I+1)*X(I)+beta(I+1)
   enddo
end subroutine sweepF

subroutine sweepB(A,B,C,F,X)
   use variables
   use constants
   real :: A(0:MaxN),B(0:MaxN),C(0:MaxN),F(0:MaxN)
   real :: X(1:MaxN)
   integer :: I,M
   real :: alfa(MaxN+1),beta(MaxN+1)
   alfa(1)=A(0)
   beta(1)=B(0)
   do I=1,MaxN-1
      alfa(I+1)=-C(I)/(B(I)+A(I)*alfa(I) )
      beta(I+1)=(F(I)-A(I)*beta(I))/(B(I)+A(I)*alfa(I))
   enddo
     X(MaxN)=(F(0)+C(0)*beta(MaxN))/(1-C(0)*alfa(MaxN))
   do I=MaxN-1,1,-1
      X(I)=alfa(I+1)*X(I+1)+beta(I+1)
   enddo
end subroutine sweepB

!   elseif (ProblemDim.eq.3D) then
!
!      dudx(i,j,k) = (u(i+1,j,k)-u(i-1,j,k))/(2.0*dx)
!      dvdx(i,j,k) = (v(i+1,j,k)-v(i-1,j,k))/(2.0*dx)
!      dwdx(i,j,k) = (w(i+1,j,k)-w(i-1,j,k))/(2.0*dx)
!
!      dudy(i,j,k) = (u(i,j+1,k)-u(i,j-1,k))/(2.0*dy)
!      dvdy(i,j,k) = (v(i,j+1,k)-v(i,j-1,k))/(2.0*dy)
!      dwdy(i,j,k) = (w(i,j+1,k)-w(i,j-1,k))/(2.0*dy)
!
!      dudz(i,j,k) = (u(i,j,k+1)-u(i,j,k-1))/(2.0*dz)
!      dvdz(i,j,k) = (v(i,j,k+1)-v(i,j,k-1))/(2.0*dz)
!      dwdz(i,j,k) = (w(i,j,k+1)-w(i,j,k-1))/(2.0*dz)
!
!      d2udx2(i,j,k) = (u(i+1,j,k)-2.0*u(i,j,k)+u(i-1,j,k))/(2.0*dx*dx)
!      d2vdx2(i,j,k) = (v(i+1,j,k)-2.0*v(i,j,k)+v(i-1,j,k))/(2.0*dx*dx)
!      d2wdx2(i,j,k) = (w(i+1,j,k)-2.0*w(i,j,k)+w(i-1,j,k))/(2.0*dx*dx)
!
!      d2udy2(i,j,k) = (u(i,j+1,k)-2.0*u(i,j,k)+u(i,j-1,k))/(2.0*dy*dy)
!      d2vdy2(i,j,k) = (v(i,j+1,k)-2.0*v(i,j,k)+v(i,j-1,k))/(2.0*dy*dy)
!      d2wdy2(i,j,k) = (w(i,j+1,k)-2.0*w(i,j,k)+w(i,j-1,k))/(2.0*dy*dy)
!
!      d2udz2(i,j,k) = (u(i,j,k+1)-2.0*u(i,j,k)+u(i,j,k-1))/(2.0*dz*dz)
!      d2vdz2(i,j,k) = (v(i,j,k+1)-2.0*v(i,j,k)+v(i,j,k-1))/(2.0*dz*dz)
!      d2wdz2(i,j,k) = (w(i,j,k+1)-2.0*w(i,j,k)+w(i,j,k-1))/(2.0*dz*dz)
!   endif
!--------------------------------------------!
! Koefficienti of raznosti protiv potoka 2   !
!--------------------------------------------!

subroutine WriteFile(TVar,Num)
   use variables
   use constants
   Character(LEN=15) :: FName
   Integer :: TVar
   Integer :: Num
   If (TVar.eq.VarU) then
    Write(FName,"(A,I5.5,A)") 'U',Num,'.dat'
   else
    Write(FName,"(A,I5.5,A)") 'V',Num,'.dat'
   endif

   open(TVar,file=trim(adjustl(FName)))
   write(TVar,*) 'TITLE = "Example: Simple 2D-Plane Data"'
   write(TVar,*) 'VARIABLES = "X", "Y", "Var"'
   write(TVar,*) 'ZONE I=',MaxN,'  J=',MaxN,' F=POINT'
   do i=1,MaxN
     do j=1,MaxN
       if (TVar.eq.VarU) then
          write(TVar,*) i,j,u(i,j)
       elseif (TVar.eq.VarV) then
          write(TVar,*) i,j,v(i,j)
!       else
!          write(1,*) i,j,p(i,j)
       endif
     enddo
   enddo
   close(TVar)
end subroutine WriteFile
subroutine WriteIter(Num)
   use variables
   use constants
   Character(LEN=15) :: FName
   Integer :: TVar=10
   Integer :: Num
   Write(FName,"(A,I5.5,A)") 'Out',Num,'.dat'

   open(TVar,file=trim(adjustl(FName)))
   write(TVar,*) 'TITLE = "Example: Simple 2D-Plane Data"'
   write(TVar,*) 'VARIABLES = "X", "Y", "U", "V"'
   write(TVar,*) 'ZONE I=',MaxN,'  J=',MaxN,' F=POINT'
   do i=1,MaxN
     do j=1,MaxN
          write(TVar,*) i,j,u(i,j),v(i,j)
     enddo
   enddo
   close(TVar)
end subroutine WriteIter

!-------------------------------------!
! Set Variables                       !
!-------------------------------------!
subroutine InitiliseVariables
   use variables
   use constants

   allocate(P(0:MaxN+1,0:MaxN+1),STAT=istat)
   if (istat.ne.0) write(*,*) "**** Not enough memory to allocate P ****"

   allocate(aUx1(1:MaxN),STAT=istat)
   allocate(bUx1(1:MaxN),STAT=istat)
   allocate(aUx2(1:MaxN),STAT=istat)
   allocate(bUx2(1:MaxN),STAT=istat)
   allocate(aUy1(1:MaxN),STAT=istat)
   allocate(bUy1(1:MaxN),STAT=istat)
   allocate(aUy2(1:MaxN),STAT=istat)
   allocate(bUy2(1:MaxN),STAT=istat)

   allocate(aVx1(1:MaxN),STAT=istat)
   allocate(bVx1(1:MaxN),STAT=istat)
   allocate(aVx2(1:MaxN),STAT=istat)
   allocate(bVx2(1:MaxN),STAT=istat)
   allocate(aVy1(1:MaxN),STAT=istat)
   allocate(bVy1(1:MaxN),STAT=istat)
   allocate(aVy2(1:MaxN),STAT=istat)
   allocate(bVy2(1:MaxN),STAT=istat)

   allocate(U(0:MaxN+1,0:MaxN+1),STAT=istat)
   if (istat.ne.0) write(*,*) "**** Not enough memory to allocate U ****"
   allocate(V(0:MaxN+1,0:MaxN+1),STAT=istat)
   if (istat.ne.0) write(*,*) "**** Not enough memory to allocate V ****"
   allocate(Uon(0:MaxN+1,0:MaxN+1),STAT=istat)
   if (istat.ne.0) write(*,*) "**** Not enough memory to allocate Uon1 ****"
   allocate(Von(0:MaxN+1,0:MaxN+1),STAT=istat)
   if (istat.ne.0) write(*,*) "**** Not enough memory to allocate Von1 ****"

   allocate(Uo12(0:MaxN+1,0:MaxN+1),STAT=istat)
   if (istat.ne.0) write(*,*) "**** Not enough memory to allocate Uo13 ****"
   allocate(Vo12(0:MaxN+1,0:MaxN+1),STAT=istat)
   if (istat.ne.0) write(*,*) "**** Not enough memory to allocate Vo13 ****"
end subroutine InitiliseVariables
!-------------------------------------!
! Destroy Variables                   !
!-------------------------------------!
subroutine DestroyVariables
   use variables
   use constants

   deallocate(P,STAT=istat)
   if (istat.ne.0) write(*,*) "**** Can't deallocate P ****"

   deallocate(aUx1,STAT=istat)
   deallocate(bUx1,STAT=istat)
   deallocate(aUx2,STAT=istat)
   deallocate(bUx2,STAT=istat)
   deallocate(aUy1,STAT=istat)
   deallocate(bUy1,STAT=istat)
   deallocate(aUy2,STAT=istat)
   deallocate(bUy2,STAT=istat)

   deallocate(aVx1,STAT=istat)
   deallocate(bVx1,STAT=istat)
   deallocate(aVx2,STAT=istat)
   deallocate(bVx2,STAT=istat)
   deallocate(aVy1,STAT=istat)
   deallocate(bVy1,STAT=istat)
   deallocate(aVy2,STAT=istat)
   deallocate(bVy2,STAT=istat)

   deallocate(U,STAT=istat)
   if (istat.ne.0) write(*,*) "**** Can't deallocate U ****"
   deallocate(V,STAT=istat)
   if (istat.ne.0) write(*,*) "**** Can't deallocate V ****"
   deallocate(Uon,STAT=istat)
   if (istat.ne.0) write(*,*) "**** Can't deallocate Uon1 ****"
   deallocate(Von,STAT=istat)
   if (istat.ne.0) write(*,*) "**** Can't deallocate Von1 ****"

   deallocate(Uo12,STAT=istat)
   if (istat.ne.0) write(*,*) "**** Can't deallocate Uo13 ****"
   deallocate(Vo12,STAT=istat)
   if (istat.ne.0) write(*,*) "**** Can't deallocate Vo13 ****"
end subroutine DestroyVariables


      real function resc(xmin1,xmax1,xmin2,xmax2,x111)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      real*8 rsc
c
c Simple linear rescaling (get a value in coordinate system "2" given
c a value in "1"):
c
      rsc  = dble((xmax2-xmin2)/(xmax1-xmin1))
      resc = xmin2 + real( dble(x111 - xmin1) * rsc )
      return
      end


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine dt_evolve
  use global_variables
  implicit none
  integer :: it

  call laplacian_Ez
  Ez_new = 2d0*eps/dt**2*Ez - (eps/dt**2 - 2d0*pi*sigma/dt)*Ez_old + clight**2*LapEz
  Ez_new = Ez_new/(eps/dt**2 + 2d0*pi*sigma/dt)

  Ez_old = Ez
  Ez = Ez_new

  contains
    subroutine laplacian_Ez
      implicit none
      integer :: ix

      LapEz(NX_L) = (0d0 - 2d0*Ez(Nx_L) + Ez(Nx_L+1) )/Hx**2
      do ix = Nx_L + 1, Nx_R -1
        LapEz(ix) = (Ez(ix-1) - 2d0*Ez(ix) + Ez(ix+1) )/Hx**2
      end do

      LapEz(Nx_R) = (Ez(Nx_R-1) - 2d0*Ez(ix) + 0d0 )/Hx**2

    end subroutine laplacian_Ez
end subroutine dt_evolve


FUNCTION bnc(N,P,rank)

!-------------------------------------------------------------
!
!  Compute the number of cells for the subdomain, one
!   dimension at a time.
!  Take in the number of cells total for a dimension, N, the
!   number of processes P in that dimension, and the rank.
!  Return the integer number of cells for that sub-domain, bnc.
!
!  When not evenly divided, keeps all but one even, then tries
!   tries to keep last sub-domain close
!
!-------------------------------------------------------------

IMPLICIT NONE
INTEGER, INTENT(IN) :: N, P, rank
INTEGER :: bnc, tmpi1, tmpi2
REAL :: tmpr

! Set the values to be checked against
tmpr = 0.5*REAL(P)

tmpi1 = MOD(N,P)
tmpi2 = N/P

! If it's evenly divisible, just use the division
IF (tmpi1 == 0) THEN
   bnc = tmpi2

! If not, then compare the MOD result to half the number of processes and set
ELSE IF (REAL(tmpi1) < tmpr) THEN
   IF (rank /= P-1) THEN
      bnc = tmpi2
   ELSE
      bnc = N - (P-1)*tmpi2
   END IF

ELSE IF (REAL(tmpi1) >= tmpr) THEN
   IF (rank /= P-1) THEN
      bnc = tmpi2 + 1
   ELSE
      bnc = N - (P-1)*(tmpi2+1)
   END IF

END IF

END FUNCTION bnc


SUBROUTINE TaylorFDStencils1DArbitrary(alp,bet,order,Stencils,x)
! By Allan P. Engsig-Karup.
USE Precision
USE DataTypes
IMPLICIT NONE
INTEGER :: r, alp, bet, m, n, order, count
REAL(KIND=long), DIMENSION(:,:), ALLOCATABLE :: Mat
REAL(KIND=long), DIMENSION(alp+bet+1) :: Stencils, x
r = alp + bet + 1; ! rank of points in stencil
ALLOCATE(Mat(r,order+1))
CALL weights(x(alp+1),x,r-1,r-1,order,Mat)
Stencils = Mat(1:r,order+1)
DEALLOCATE(Mat)
END SUBROUTINE TaylorFDStencils1DArbitrary


module Ray_Casting_Algo
  use Polygons
  implicit none

  real, parameter, private :: eps = 0.00001
  private :: ray_intersects_seg

contains

  function ray_intersects_seg(p0, a0, b0) result(intersect)
    type(point), intent(in) :: p0, a0, b0
    logical :: intersect

    type(point) :: a, b, p
    real :: m_red, m_blue

    p = p0
    ! let variable "a" be the point with smallest y coordinate
    if ( a0%y > b0%y ) then
       b = a0
       a = b0
    else
       a = a0
       b = b0
    end if

    if ( (p%y == a%y) .or. (p%y == b%y) ) p%y = p%y + eps

    intersect = .false.

    if ( (p%y > b%y) .or. (p%y < a%y) ) return
    if ( p%x > max(a%x, b%x) ) return

    if ( p%x < min(a%x, b%x) ) then
       intersect = .true.
    else
       if ( abs(a%x - b%x) > tiny(a%x) ) then
          m_red = (b%y - a%y) / (b%x - a%x)
       else
          m_red = huge(m_red)
       end if
       if ( abs(a%x - p%x) > tiny(a%x) ) then
          m_blue = (p%y - a%y) / (p%x - a%x)
       else
          m_blue = huge(m_blue)
       end if
       if ( m_blue >= m_red ) then
          intersect = .true.
       else
          intersect = .false.
       end if
    end if

  end function ray_intersects_seg

  function point_is_inside(p, pol) result(inside)
    logical :: inside
    type(point), intent(in) :: p
    type(polygon), intent(in) :: pol

    integer :: i, cnt, pa, pb

    cnt = 0
    do i = lbound(pol%vertices,1), ubound(pol%vertices,1), 2
       pa = pol%vertices(i)
       pb = pol%vertices(i+1)
       if ( ray_intersects_seg(p, pol%points(pa), pol%points(pb)) ) cnt = cnt + 1
    end do

    inside = .true.
    if ( mod(cnt, 2) == 0 ) then
       inside = .false.
    end if

  end function point_is_inside

end module Ray_Casting_Algo


      subroutine irev_daatheta(n_DDLthetatheta,n_DDLxx,n_JSthth,n_JSxx,n
     &_Pthetatheta,n_RRthetatheta,n_RRxx,n_Uthetatheta,n_alpha,n_em4phi,
     &n_metthetatheta,n_metxx,nm1_Athth,np1_Athth,Nx,ht,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 n_DDLthetatheta(Nx)
      real*8 n_DDLxx(Nx)
      real*8 n_JSthth(Nx)
      real*8 n_JSxx(Nx)
      real*8 n_Pthetatheta(Nx)
      real*8 n_RRthetatheta(Nx)
      real*8 n_RRxx(Nx)
      real*8 n_Uthetatheta(Nx)
      real*8 n_alpha(Nx)
      real*8 n_em4phi(Nx)
      real*8 n_metthetatheta(Nx)
      real*8 n_metxx(Nx)
      real*8 nm1_Athth(Nx)
      real*8 np1_Athth(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = -0.5000000000000000D0 * (nm1_Athth(i) - 0.1D1 * np1_Athth(i))
     # / ht + 0.3333333333333333D0 / n_metxx(i) * n_alpha(i) * n_metthet
     #atheta(i) * n_RRxx(i) * n_em4phi(i) - 0.3333333333333333D0 / n_met
     #xx(i) * n_em4phi(i) * n_alpha(i) * n_JSxx(i) * n_metthetatheta(i)
     #- 0.3333333333333333D0 * n_alpha(i) * n_RRthetatheta(i) * n_em4phi
     #(i) + 0.3333333333333333D0 * n_alpha(i) * n_JSthth(i) * n_em4phi(i
     #) - 0.1D1 * n_alpha(i) * n_Uthetatheta(i) - 0.3333333333333333D0 /
     # n_metxx(i) * n_DDLxx(i) * n_metthetatheta(i) * n_em4phi(i) + 0.33
     #33333333333333D0 * n_DDLthetatheta(i) * n_em4phi(i) - 0.1D1 * n_Pt
     #hetatheta(i)
      res(i)=qb
      end do
      END


MODULE MODULE_GEOMETRY

USE MODULE_MATH
USE MODULE_PBC
!USE MODULE_COM
USE MODULE_BOX

CONTAINS

  FUNCTION DIST2POINTS(point1,point2,box,inv,ortho,pbc_opt) RESULT (valdist)

    IMPLICIT NONE
    INTEGER, INTENT(IN)::ortho,pbc_opt
    DOUBLE PRECISION,DIMENSION(3),INTENT(IN)::point1,point2
    DOUBLE PRECISION,DIMENSION(3,3),INTENT(IN)::box,inv
    DOUBLE PRECISION::valdist
    DOUBLE PRECISION,DIMENSION(3)::vect_aux

    vect_aux(:)=point1(:)-point2(:)
    IF (pbc_opt==1) THEN
        CALL PBC (vect_aux,box,inv,ortho)
    END IF
    valdist=sqrt(dot_product(vect_aux(:),vect_aux(:)))

  END FUNCTION DIST2POINTS

  FUNCTION ANG3VECTS (vec1,vec2,vec3) RESULT (ang)

    IMPLICIT NONE

    DOUBLE PRECISION,dimension(3),intent(in)::vec1,vec2,vec3
    DOUBLE PRECISION::ang
    DOUBLE PRECISION,dimension(3)::aux1,aux2,aux3
    DOUBLE PRECISION::cosa
    integer::signo
    double precision::pi

    cosa=0.0d0
    signo=0
    ang=0.0d0
    pi=3.14159265358979

    aux1=0.0d0
    aux2=0.0d0

    CALL PRODUCT_VECT(vec1,vec2,aux1)
    CALL PRODUCT_VECT(vec2,vec3,aux2)

    cosa=(aux1(1)*aux2(1)+aux1(2)*aux2(2)+aux1(3)*aux2(3))/(sqrt(dot_product(aux1,aux1))*sqrt(dot_product(aux2,aux2)))

    IF (cosa>=1.0d0) THEN
       cosa=1.0d0
    END IF
    IF (cosa<=-1.0d0) THEN
       cosa=-1.0d0
    END IF

    cosa=(DACOS(cosa))*(180.0d0/pi)

    IF (cosa>180.0d0) THEN
        print*,'ERROR: ANGLE > 180.0 DEGREES'
        STOP
    END IF

    aux3=0.0d0

    CALL PRODUCT_VECT(aux1,aux2,aux3)

    IF ( dot_product(aux3,vec2) <= 0.0d0 ) THEN
       signo=-1
    ELSE
       signo=+1
    END IF

    ang=cosa*signo

  END FUNCTION ANG3VECTS

  SUBROUTINE DISTANCE(diff_set, coors1, coors2, box, ortho, pbc_opt, n1, n2, n_frames, matrix)

  IMPLICIT NONE
  INTEGER,INTENT(IN):: diff_set, ortho, pbc_opt, n1, n2, n_frames
  DOUBLE PRECISION,DIMENSION(n_frames,n1,3),INTENT(IN)::coors1
  DOUBLE PRECISION,DIMENSION(n_frames,n2,3),INTENT(IN)::coors2
  DOUBLE PRECISION,DIMENSION(n_frames,3,3),INTENT(IN)::box
  DOUBLE PRECISION,DIMENSION(n_frames,n1,n2),INTENT(OUT)::matrix

  DOUBLE PRECISION,DIMENSION(n_frames,3,3)::inv

  INTEGER::ii,jj,kk
  DOUBLE PRECISION::val_aux
  DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::vect,vect_aux,vect_aux2
  DOUBLE PRECISION,DIMENSION(:,:),ALLOCATABLE::tmp_box,tmp_inv

  ALLOCATE(vect(3),vect_aux(3),vect_aux2(3))
  ALLOCATE(tmp_box(3,3),tmp_inv(3,3))

  inv=0.0d0
  IF (pbc_opt==1) THEN
    CALL BOX2INVBOX (box, inv, n_frames)
  END IF

  IF (diff_set==1) THEN
    DO kk=1,n_frames
      tmp_box=box(kk,:,:)
      tmp_inv=inv(kk,:,:)
      DO ii=1,n1
        vect_aux=coors1(kk,ii,:)
          DO jj=1,n2
            vect_aux2=coors2(kk,jj,:)
            matrix(kk,ii,jj)=DIST2POINTS(vect_aux,vect_aux2,tmp_box,tmp_inv,ortho,pbc_opt)
         END DO
      END DO
    END DO
  ELSE
    DO kk=1,n_frames
      tmp_box=box(kk,:,:)
      tmp_inv=inv(kk,:,:)
      DO ii=1,n1
         matrix(kk,ii,ii)=0.0d0
         vect_aux=coors1(kk,ii,:)
         DO jj=ii+1,n1
            vect_aux2=coors1(kk,jj,:)
            val_aux=DIST2POINTS(vect_aux,vect_aux2,tmp_box,tmp_inv,ortho,pbc_opt)
            matrix(kk,ii,jj)=val_aux
            matrix(kk,jj,ii)=val_aux
         END DO
      END DO
    END DO
  END IF

  DEALLOCATE(vect,vect_aux,vect_aux2)
  DEALLOCATE(tmp_box,tmp_inv)

  END SUBROUTINE DISTANCE

  SUBROUTINE DISTANCE_PAIRS(coors1, coors2, box, ortho, pbc_opt, n1, n2, n_frames, matrix)

  IMPLICIT NONE
  INTEGER,INTENT(IN):: ortho, pbc_opt, n1, n2, n_frames
  DOUBLE PRECISION,DIMENSION(n_frames,n1,3),INTENT(IN)::coors1
  DOUBLE PRECISION,DIMENSION(n_frames,n2,3),INTENT(IN)::coors2
  DOUBLE PRECISION,DIMENSION(n_frames,3,3),INTENT(IN)::box
  DOUBLE PRECISION,DIMENSION(n_frames,n1),INTENT(OUT)::matrix

  DOUBLE PRECISION,DIMENSION(n_frames,3,3)::inv

  INTEGER::ii,kk
  DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::vect,vect_aux,vect_aux2
  DOUBLE PRECISION,DIMENSION(:,:),ALLOCATABLE::tmp_box,tmp_inv

  ALLOCATE(vect(3),vect_aux(3),vect_aux2(3))
  ALLOCATE(tmp_box(3,3),tmp_inv(3,3))

  inv=0.0d0
  IF (pbc_opt==1) THEN
    CALL BOX2INVBOX (box, inv, n_frames)
  END IF

  DO kk=1,n_frames
    tmp_box=box(kk,:,:)
    tmp_inv=inv(kk,:,:)
    DO ii=1,n1
      vect_aux=coors1(kk,ii,:)
      vect_aux2=coors2(kk,ii,:)
      matrix(kk,ii)=DIST2POINTS(vect_aux,vect_aux2,tmp_box,tmp_inv,ortho,pbc_opt)
    END DO
  END DO

  DEALLOCATE(vect,vect_aux,vect_aux2)
  DEALLOCATE(tmp_box,tmp_inv)

  END SUBROUTINE DISTANCE_PAIRS

  !FUNCTION RADIUS_OF_GYRATION (coors,weights,n_frames,n_atoms) RESULT(Rg)

  !  IMPLICIT NONE
  !  INTEGER, INTENT(IN)::n_frames,n_atoms
  !  DOUBLE PRECISION,DIMENSION(n_frames,n_atoms,3),INTENT(IN)::coors
  !  DOUBLE PRECISION,DIMENSION(n_atoms),INTENT(IN)::weights
  !  DOUBLE PRECISION,DIMENSION(n_frames)::Rg

  !  INTEGER::ii,jj
  !  DOUBLE PRECISION,DIMENSION(n_frames,3)::com
  !  DOUBLE PRECISION,DIMENSION(3)::vect_aux
  !  DOUBLE PRECISION::total_weight
  !  DOUBLE PRECISION::val_aux

  !  Rg(:) = 0.0d0
  !  com = CENTER_OF_MASS(coors,weights,n_frames,n_atoms)
  !  total_weight=SUM(weights)

  !  DO ii=1,n_frames
  !      val_aux=0.0d0
  !      DO jj=1,n_atoms
  !          vect_aux = coors(ii,jj,:)-com(ii,:)
  !          Rg(ii)=Rg(ii)+weights(jj)*dot_product(vect_aux,vect_aux)
  !      END DO
  !  END DO

  !  Rg(:)=Rg(:)/total_weight
  !  Rg(:)=sqrt(Rg(:))

  !END FUNCTION

  SUBROUTINE TRANSLATE(coors, shifts, frame_indices, n_atoms, n_frames, n_frame_indices)

    IMPLICIT NONE
    INTEGER,INTENT(IN)::n_frames, n_atoms, n_frame_indices
    DOUBLE PRECISION,DIMENSION(n_frames, n_atoms, 3),INTENT(INOUT)::coors
    DOUBLE PRECISION,DIMENSION(n_frame_indices, 3),INTENT(IN)::shifts
    INTEGER,DIMENSION(n_frame_indices),INTENT(IN)::frame_indices
    INTEGER::ii,jj,frame_index

    DO ii=1,n_frame_indices
      frame_index = frame_indices(ii)+1
      DO jj=1,n_atoms
          coors(frame_index,jj,:)=coors(frame_index,jj,:)+shifts(ii,:)
      END DO
    END DO

  END SUBROUTINE

  SUBROUTINE DIHEDRAL_ANGLES (angs, coors, box, ortho, pbc_opt, quartets, n_angs, n_atoms, n_frames)

    INTEGER,INTENT(IN)::ortho, n_atoms, n_angs, pbc_opt, n_frames
    INTEGER,DIMENSION(n_angs,4),INTENT(IN)::quartets
    DOUBLE PRECISION,DIMENSION(n_frames,n_atoms,3),INTENT(IN)::coors
    DOUBLE PRECISION,DIMENSION(n_frames,3,3),INTENT(IN)::box
    DOUBLE PRECISION,DIMENSION(n_frames,n_angs),INTENT(OUT)::angs

    DOUBLE PRECISION,DIMENSION(n_frames,3,3)::inv
    DOUBLE PRECISION,DIMENSION(3,3)::tmp_box,tmp_inv
    INTEGER::ii,jj
    INTEGER::atom1,atom2,atom3,atom4
    DOUBLE PRECISION,DIMENSION(3)::vect1,vect2,vect3

    inv=0.0d0
    IF (pbc_opt==1) THEN
        CALL BOX2INVBOX (box, inv, n_frames)
    END IF

    DO jj=1,n_frames
        tmp_box=box(jj,:,:)
        tmp_inv=inv(jj,:,:)
        DO ii=1,n_angs
            atom1=quartets(ii,1)+1
            atom2=quartets(ii,2)+1
            atom3=quartets(ii,3)+1
            atom4=quartets(ii,4)+1
            vect1=coors(jj,atom2,:)-coors(jj,atom1,:)
            vect2=coors(jj,atom3,:)-coors(jj,atom2,:)
            vect3=coors(jj,atom4,:)-coors(jj,atom3,:)
            IF (pbc_opt==1) THEN
                CALL PBC (vect1,tmp_box,tmp_inv,ortho)
                CALL PBC (vect2,tmp_box,tmp_inv,ortho)
                CALL PBC (vect3,tmp_box,tmp_inv,ortho)
            END IF
            angs(jj,ii)=ANG3VECTS(vect1,vect2,vect3)
        END DO
    END DO

  END SUBROUTINE DIHEDRAL_ANGLES

  SUBROUTINE SET_DIHEDRAL_ANGLES (coors, box, ortho, pbc_opt, quartets, angs, blocks, atoms_per_block, n_angs, n_atoms, &
      n_frames, blocks_size)

    INTEGER,INTENT(IN)::ortho, n_atoms, n_angs, pbc_opt, n_frames, blocks_size
    INTEGER,DIMENSION(n_angs,4),INTENT(IN)::quartets
    DOUBLE PRECISION,DIMENSION(n_frames,n_atoms,3),INTENT(INOUT)::coors
    DOUBLE PRECISION,DIMENSION(n_frames,3,3),INTENT(IN)::box
    DOUBLE PRECISION,DIMENSION(n_frames,n_angs),INTENT(IN)::angs
    INTEGER,DIMENSION(blocks_size),INTENT(IN)::blocks
    INTEGER,DIMENSION(n_angs),INTENT(IN)::atoms_per_block

    DOUBLE PRECISION,DIMENSION(n_frames,3,3)::inv
    DOUBLE PRECISION,DIMENSION(3,3)::tmp_box,tmp_inv
    INTEGER::ii,jj,kk,ll
    INTEGER::atom1,atom2,atom3,atom4
    DOUBLE PRECISION,DIMENSION(3)::vect1,vect2,vect3,vect_aux,u_vect
    DOUBLE PRECISION::old_ang, shift_ang
    INTEGER,DIMENSION(n_angs+1)::aux_block

    aux_block(:)=0

    DO ii=1,n_angs
        aux_block(ii+1:)=aux_block(ii+1:)+atoms_per_block(ii)
    END DO

    inv=0.0d0
    IF (pbc_opt==1) THEN
        CALL BOX2INVBOX (box, inv, n_frames)
    END IF

    DO jj=1,n_frames
        tmp_box=box(jj,:,:)
        tmp_inv=inv(jj,:,:)
        DO ii=1,n_angs
            atom1=quartets(ii,1)+1
            atom2=quartets(ii,2)+1
            atom3=quartets(ii,3)+1
            atom4=quartets(ii,4)+1
            vect1=coors(jj,atom2,:)-coors(jj,atom1,:)
            vect2=coors(jj,atom3,:)-coors(jj,atom2,:)
            vect3=coors(jj,atom4,:)-coors(jj,atom3,:)
            IF (pbc_opt==1) THEN
                CALL PBC (vect1,tmp_box,tmp_inv,ortho)
                CALL PBC (vect2,tmp_box,tmp_inv,ortho)
                CALL PBC (vect3,tmp_box,tmp_inv,ortho)
            END IF
            u_vect = vect2/(sqrt(dot_product(vect2,vect2)))
            old_ang=ANG3VECTS(vect1,vect2,vect3)
            shift_ang = angs(jj,ii)-old_ang
            DO kk=aux_block(ii)+1,aux_block(ii+1)
                ll = blocks(kk)+1 !!!!!!!! aqui
                vect_aux = coors(jj,ll,:)-coors(jj,atom3,:)
                IF (pbc_opt==1) THEN
                    CALL PBC (vect_aux,tmp_box,tmp_inv,ortho)
                END IF
                CALL RODRIGUES_ROTATION(vect_aux, u_vect, shift_ang)
                IF (pbc_opt==1) THEN
                    CALL PBC (vect_aux,tmp_box,tmp_inv,ortho)
                END IF
                coors(jj,ll,:)=coors(jj,atom3,:)+vect_aux
            END DO
        END DO
    END DO

  END SUBROUTINE SET_DIHEDRAL_ANGLES

  SUBROUTINE RODRIGUES_ROTATION (vect, unit_vector, angle)

    IMPLICIT NONE
    DOUBLE PRECISION,DIMENSION(3),INTENT(INOUT)::vect
    DOUBLE PRECISION,DIMENSION(3),INTENT(IN)::unit_vector
    DOUBLE PRECISION,INTENT(IN)::angle

    DOUBLE PRECISION,dimension(3)::aux1,aux2,aux3
    DOUBLE PRECISION::cosa, sina, aux_ang
    double precision::pi

    cosa=0.0d0
    sina=0.0d0
    pi=3.14159265358979

    aux1=0.0d0
    aux2=0.0d0
    aux3=0.0d0

    aux_ang = (pi/180.0d0)*angle

    cosa = DCOS(aux_ang)
    sina = DSIN(aux_ang)

    aux1 = vect*cosa
    CALL PRODUCT_VECT(unit_vector,vect,aux2)
    aux2 = aux2*sina
    aux3 = dot_product(unit_vector, vect)*(1.0d0-cosa)*unit_vector

    vect = aux1+aux2+aux3

  END SUBROUTINE RODRIGUES_ROTATION

END MODULE MODULE_GEOMETRY


module PhysicalConstantsClass
    use iso_fortran_env
    implicit none

	type :: PhysicalConstants_
        real(real64) :: c =  299792458.0d0! speed of light in vacuum (m/s)
        real(real64) :: speed_of_light =  299792458.0d0! speed of light in vacuum (m/s)
        real(real64) :: Plank = 6.62607015*10.0d0**(-34.0) ! the Plank constant (J s)
        real(real64) :: g =9.80665d0  ! standard acceleration of gravity (m/s)
        real(real64) :: R =8.31446261815324d0 ! Molar gas constant (J/K/mol)
        real(real64) :: gas_constant = 8.31446261815324d0 ! Molar gas constant (J/K/mol)
        real(real64) :: Avogadro = 6.02214076*10.0d0**23 ! Avogadro constant (/mol)
        real(real64) :: k = 1.380649*10.0d0**(-23) ! Boltzmann constant (J/K)
        real(real64) :: Boltzmann = 1.380649*10.0d0**(-23) ! Boltzmann constant(J/K)
    contains
        procedure,public :: unit => unitPhysicalConstants
    end type
contains

function unitPhysicalConstants(obj,tgt) result(ret)
    class(PhysicalConstants_),intent(in) :: obj
    character(*),intent(in) :: tgt
    character(:),allocatable :: ret

    if(tgt=="c")then
        ret = "m/s"
        return
    endif
    if(tgt=="speed_of_light")then
        ret = "m/s"
        return
    endif
    if(tgt=="Plank")then
        ret = "J s"
        return
    endif
    if(tgt=="g")then
        ret = "m/s"
        return
    endif
    if(tgt=="R")then
        ret = "J/K/mol"
        return
    endif
    if(tgt=="gas_constant")then
        ret = "J/K/mol"
        return
    endif
    if(tgt=="Avogadro")then
        ret = "/mol"
        return
    endif
    if(tgt=="k")then
        ret = "J/K"
        return
    endif
    if(tgt=="Boltzmann")then
        ret = "J/K"
        return
    endif

end function

end module


Module ToolsLib

contains

    ! Fonction du calcul du module de la tension nodale en un noeud
    Real function ModCmplx(z)
        complex, intent(IN) :: z

        !ModCmplx = (sqrt(Real(z)**2 + Aimag(z)**2))
        ModCmplx = (cabs(z))
    end function ModCmplx

    ! Fonction du calcul de l'argument de la tension nodale en un noeud
    Real function Argum(z)
        real :: theta

        complex, intent(IN) :: z

        theta = Atan(Aimag(z)/real(z))
        !Argum = (theta*180)/pi
        Argum = theta
    end function

    ! Fonction du calcul de la solution du système AX=B selon GAUSS
    Subroutine GaussMat(Jaa, Bb, Xx, Nn)

        integer, intent(IN) :: Nn
        Real, intent(IN) :: Jaa(:,:), Bb(:)
        Real, allocatable, intent(OUT) :: Xx(:)

        Real, allocatable, Dimension(:,:) :: Aa
        integer :: ii, ij, ik
        Real :: Xsum, xmult
        !character(len=40) :: A3Fmt

        ! Formation de la matrice a = [Jaa | I]
        allocate(Aa(Nn,Nn+1), Xx(Nn))

        Xx=0.
        Aa=0.
        do ii=1, Nn
            do ij=1, Nn+1
               Aa(ii,ij) = Jaa(ii,ij)
            end do
            Aa(ii, Nn+1) = Bb(ii)
        end do

        ! Elimination de Gauss
        do ik = 1, Nn-1
           do ii = ik+1, Nn
              xmult = Aa(ii, ik) / Aa(ik, ik)
              Aa(ii, ik) = 0.
              do ij = ik+1, Nn+1
                 Aa(ii, ij) = Aa(ii, ij) - xmult * Aa(ik, ij)
              end do
           end do
        end do

        Xx(Nn) = Aa(Nn, Nn+1) / Aa(Nn, Nn)
        do ii = Nn-1, 1, -1
           Xsum = 0.
           do ij= ii+1, Nn
              Xsum = Xsum + Aa(ii, ij) * Xx(ij)
           end do
           Xx(ii) = (Aa(ii, Nn+1) - Xsum) / Aa(ii, ii)
        end do

        deallocate(Aa)
    End Subroutine

    ! Procédure d'inversion matrice selon GAUSS-JORDAN
    Subroutine InvMat(Aa, Cc, Nn)
        !implicit none

        integer, Intent(IN) :: Nn
        Real, Intent(INOUT) :: Aa(Nn,Nn)

        Real, Intent(OUT) :: Cc(Nn,Nn)
        Real :: L(Nn,Nn), U(Nn,Nn), b(Nn), d(Nn), Xx(Nn)
        Real :: coeff
        integer ii, ij, ik

        L = 0.0
        U = 0.0
        b = 0.0

        do ik = 1, Nn-1
           do ii = ik+1, Nn
              coeff = Aa(ii,ik) / Aa(ik,ik)
              L(ii,ik) = coeff
              do ij = ik + 1, Nn
                 Aa(ii,ij) = Aa(ii,ij) - coeff*Aa(ik,ij)
              end do
           end do
        end do

        do ii = 1, Nn
          L(ii,ii) = 1.0
        end do

        do ij = 1, Nn
          do ii = 1, ij
            U(ii, ij) = Aa(ii,ij)
          end do
        end do

        do ik = 1, Nn
          b(ik) = 1.0
          d(1) = b(1)
          do ii = 2, Nn
            d(ii) = b(ii)
            do ij = 1, ii-1
              d(ii) = d(ii) - L(ii,ij)*d(ij)
            end do
          end do
          Xx(Nn)=d(Nn)/U(Nn,Nn)
          do ii = Nn-1, 1, -1
            Xx(ii) = d(ii)
            do ij = Nn, ii+1, -1
              Xx(ii) = Xx(ii) - U(ii, ij)*Xx(ij)
            end do
            Xx(ii) = Xx(ii)/U(ii,ii)
          end do
          do ii = 1, Nn
            Cc(ii, ik) = Xx(ii)
          end do
          b(ik)=0.0
        end do
    end subroutine InvMat

    ! Gauss-Jordan avec pivotation de lignes
    SUBROUTINE GaussJordanPivation (A_,Nn,B_,Xx)
      Implicit none

      INTEGER, INTENT (IN) :: Nn
      INTEGER :: iI,iJ
      INTEGER, DIMENSION (Nn) :: INDX
      REAL, INTENT (IN), DIMENSION (Nn,Nn) :: A_
      REAL, INTENT (IN), DIMENSION (Nn) :: B_
      REAL, DIMENSION (Nn,Nn) :: Aa
      REAL, DIMENSION (Nn) :: Bb
      REAL, INTENT (OUT), DIMENSION (Nn) :: Xx

      Aa  = A_
      Bb  = B_
      CALL PivotationLU (Aa,Nn,INDX)
      DO iI = 1, Nn-1
        DO iJ = iI+1, Nn
          Bb(INDX(iJ)) = Bb(INDX(iJ))-Aa(INDX(iJ),iI)*Bb(INDX(iI))
        END DO
      END DO

      Xx(Nn) = Bb(INDX(Nn))/Aa(INDX(Nn),Nn)
      DO iI = Nn-1, 1, -1
        Xx(iI) = Bb(INDX(iI))
        DO iJ = iI+1, Nn
          Xx(iI) = Xx(iI)-Aa(INDX(iI),iJ)*Xx(iJ)
        END DO
        Xx(iI) =  Xx(iI)/Aa(INDX(iI),iI)
      END DO
    END SUBROUTINE GaussJordanPivation

    ! Subroutine de pivotation de lignes
    SUBROUTINE PivotationLU (Aa,Nn,INDX)
      Implicit none
      INTEGER, INTENT (IN) :: Nn
      INTEGER :: iI, iJ, iK = 0, ITMP
      INTEGER, INTENT (OUT), DIMENSION (Nn) :: INDX
      REAL :: C1, PI, PI1,PJ
      REAL, INTENT (INOUT), DIMENSION (Nn,Nn) :: Aa
      REAL, DIMENSION (Nn) :: C

      DO iI = 1, Nn
        INDX(iI) = iI
      END DO

      DO iI = 1, Nn
        C1= 0.0
        DO iJ = 1, Nn
          C1 = AMAX1(C1,ABS(Aa(iI,iJ)))
        END DO
        C(iI) = C1
      END DO

      DO iJ = 1, Nn-1
        PI1 = 0.0
        DO iI = iJ, Nn
          PI = ABS(Aa(INDX(iI),iJ))/C(INDX(iI))
          IF (PI.GT.PI1) THEN
            PI1 = PI
            iK   = iI
          ENDIF
        END DO

        ITMP     = INDX(iJ)
        INDX(iJ) = INDX(iK)
        INDX(iK) = ITMP

        DO iI = iJ+1, Nn
          PJ  = Aa(INDX(iI),iJ)/Aa(INDX(iJ),iJ)
          Aa(INDX(iI),iJ) = PJ
          DO iK = iJ+1, Nn
             Aa(INDX(iI),iK) = Aa(INDX(iI),iK)-PJ*Aa(INDX(iJ),iK)
          END DO
        END DO
      END DO
    END SUBROUTINE PivotationLU

    ! Convertir un intier en chaine de caractères.
    character(len=20) function rStr(rk)
    implicit none

    real, intent(in) :: rk

    write(rStr, *) rk
    rStr = adjustl(rStr)
    end function rStr

    ! Convertir un intier en chaine de caractères.
    character(len=20) function Str(ik)
    implicit none

    integer, intent(in) :: ik

    write(Str, *) ik
    Str = adjustl(str)
    end function Str

    ! Convertit une chaine de caractères (numerique) en entier
    Integer function Str2int(str_)
       implicit none

       character(len=*), intent(in) :: str_
       integer :: int_
       read(str_, *)  int_
       Str2int = int_
    end function Str2int

    ! Convertit une chaine de caractères (Réelle) en réel
    Real function Str2float(str_)
       implicit none

       character(len=*), intent(in) :: str_
       Real :: f_

       read(str_, "(F9.3)")  f_
       Str2float = f_
    end function Str2float

    ! Subroutine de nettoyage de caractère spéciaux d'une chaine de caractères.
    Subroutine Removesp(str)
        implicit none

        character(len=*):: str
        character(len=1):: ch
        character(len=len_trim(str))::outstr
        integer :: i_, k_, ich, lenstr

        str=adjustl(str)
        lenstr=len_trim(str)
        outstr=' '
        k_=0
        do i_=1,lenstr
          ch=str(i_:i_)
          ich=iachar(ch)
          select case(ich)
            case(0:32)  ! space, tab, or control character
                 cycle
            case(33:)
              k_=k_+1
              outstr(k_:k_)=ch
          end select
        end do
        str=adjustl(outstr)
    end subroutine Removesp

    ! Génére une chaine de caractère (à partir de nombres aléatoires)
    character(len=30) Function GenerateRndCar()
        implicit none

        real :: r_ = 2008.1960

        call RANDOM_NUMBER(r_)
        GenerateRndCar = Adjustl(Str(floor(r_*10000)))

    end function GenerateRndCar
End module ToolsLib


! Program to test initialization expressions involving subobjects
program parameter_2
  implicit none
  type :: SS
     integer :: I
     integer :: J
  end type SS
  type :: TT
    integer :: N
    type (SS), dimension(2) :: o
  end type

  type (SS), parameter :: s =  SS (1, 2)
  type (TT), parameter :: t = TT(42, (/ SS(3, 4), SS(8, 9) /))

  integer, parameter :: a(2) = (/5, 10/)
  integer, parameter :: d1 = s%i
  integer, parameter :: d2 = a(2)
  integer, parameter :: d4 = t%o(2)%j

  integer q1, q2, q3, q4
  common /c1/q1(d1), q2(d2), q3(a(1)), q4(d4) ! legal
end


 program prepare

!***********************************************************************
!
!     LBsoft tool for preparing the isfluid.dat file as a set
!     of 1 byte integers in natural order
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification October 2019
!
!***********************************************************************

  implicit none

  integer :: nx,ny,nz,nn,i,j,k,cx,cy,cz
  !isfluid should be 1 byte integer
  integer(kind=1), allocatable, dimension(:,:,:) :: isfluid

  integer, parameter :: iout=16
  double precision :: rdist,radius

  nx=64
  ny=64
  nz=64

  cx=32
  cy=32
  cz=32

  radius=12

  nn=nx*ny*nz

  allocate(isfluid(nx,ny,nz))

  open(unit=iout,file='isfluid.dat',action='write',status='replace', &
   access='stream',form='unformatted')

  !i should be the fastest (natural order of the 3d matrix)
  !remember that FORTRAN is column-major order
  do k=1,nz
    do j=1,ny
      do i=1,nx
        !insert a geometrical rule here
        rdist=dsqrt(dble((i-cx)**2+(j-cy)**2+(k-cz)**2))
        if(rdist<=radius)then
          isfluid(i,j,k)=3 !3 = solid
        else
          isfluid(i,j,k)=1 !1 = liquid
        endif
        !print on isfluid.dat
        write(iout)isfluid(i,j,k)
      enddo
    enddo
  enddo

  close(iout)

  stop

 end program prepare


PROGRAM  Particle_1D_Box
    IMPLICIT NONE

    REAL, PARAMETER :: pi = acos(-1.0)
    REAL:: bl, x, psi         ! bl is bond length
    CHARACTER*10:: filename
    INTEGER:: i, n, outunit
    bl = 1.
    WRITE(*, *) "Enter the quantum number n"
    READ *, n

    ! WRITE(fiblame, 10) "psi.", n
    ! 10 FORMAT(a, i0)
    WRITE(filename, fmt = "(a, i0)") "psi.", n
    OPEN(UNIT = outunit, FILE = filename, FORM = "formatted")
    x = -0.001
    DO i = 1, 1001
        x = x + 0.001
        psi = sqrt(2.0/bl) * sin(n * pi * x/bl);
        WRITE(outunit, *) x, psi, psi**2
    ENDDO
    CLOSE(outunit)
END


module bouss_module

    implicit none
    logical      :: bouss  ! Turn on the dispersive terms
    real(kind=8) :: B_param
    real(kind=8) :: sw_depth0, sw_depth1
    integer :: bc_xlo, bc_xhi

    ! for higher-order derivatives:
    real(kind=8), allocatable, dimension(:) :: dxm, dxc, cm, cp, c0

    ! for tridiagonal solver:
    integer, allocatable, dimension(:) :: IPIV
    real(kind=8), allocatable, dimension(:) :: D, DL, DU, DU2

    save

contains

!======================================================================

    subroutine set_bouss(mx,mbc,mthbc)

    ! Set things up for Boussinesq solver, in particular
    ! create and factor tridiagonal matrix for implicit solves.

    use geoclaw_module, only: sea_level, coordinate_system
    use grid_module, only: xcell, zcell, grid_type

    implicit none
    integer, intent(in) :: mx, mbc, mthbc(2)
    real(kind=8) :: DLi, r
    integer :: i, iunit
    character*25 fname
    real(kind=8), dimension(1-mbc:mx+mbc) :: h0, h02, h03
    integer(kind=4) :: INFO

    iunit = 7
    fname = 'bouss.data'
 !  # open the unit with new routine from Clawpack 4.4 to skip over
 !  # comment lines starting with #:
    call opendatafile(iunit, fname)

    read(7,*) bouss
    read(7,*) B_param
    read(7,*) sw_depth0
    read(7,*) sw_depth1

    allocate(dxm(0:mx+1),dxc(0:mx+1),cm(0:mx+1),cp(0:mx+1),c0(0:mx+1))

    ! Boundary conditions to impose in computing Boussinesq update:

    if ((mthbc(1)==2) .or. (mthbc(2)==2)) then
        write(6,*) '*** Periodic BCs not supported in bouss_module'
        stop
    endif

    ! Use Dirichlet BC with value 0 for correction in ghost cells by default:
    bc_xlo = 0
    bc_xhi = 0

    ! Check if wall BCs specified (also be used for radial symmetry at r=0):

    if (mthbc(1)==3) then
        ! For wall boundary conditions at left boundary:
        bc_xlo = 3
    endif

    if (mthbc(2)==3) then
        ! For wall boundary conditions at right boundary:
        bc_xhi = 3
    endif

    if (mthbc(1)==0) then
        ! For wavemaker BC at left
        bc_xlo = 3
    endif

    ! To try out Neumann BCs:
    ! This doesn't seem to work well, so not a general option
    !bc_xlo = 1
    !bc_xhi = 1

    !------------------------------------
    ! coefficients needed for second-order derivatives:

    do i=0,mx+2
        dxm(i) = xcell(i) - xcell(i-1)
    enddo

    do i=0,mx+1
        if (grid_type == 0) then
            ! uniform grid
            dxc(i) = 2*dxm(i)
            cm(i) = 1.d0/dxm(i)**2
            c0(i) = -2.d0/dxm(i)**2
            cp(i) = 1.d0/dxm(i)**2
        else
            dxc(i) = (xcell(i+1) - xcell(i-1))  ! = 2*dx for uniform grid!
            cm(i) = 2.d0 / (dxm(i)*dxc(i))
            cp(i) = 2.d0 / (dxm(i+1)*dxc(i))
            c0(i) = -(cm(i) + cp(i))
        endif

        if (coordinate_system == -1) then
            ! x = radial coordinate r >= 0
            ! include factors for ((1/r)*(r*q)_r)_r
            ! using form q_{rr} + (1/r)q_r - (1/r**2)q
            r = xcell(i)
            cm(i) = cm(i) - 1.d0/(r*dxc(i))
            cp(i) = cp(i) + 1.d0/(r*dxc(i))
            c0(i) = c0(i) - 1.d0/(r**2)
        else if (coordinate_system == 2) then
            write(6,*) '*** latitude coordinates not yet implemented in Bouss'
            stop
        endif
    enddo

    !------------------------------------
    ! Form tridiagonal matrix and factor
    ! Done once at start and then used in each time step

    !h0 = sea_level - aux(1,:)  # resting depth

    do i=1-mbc,mx+mbc
        h0(i) = sea_level - zcell(i)
  666   format(i3,3e16.6)
        h02(i)=(max(0.,h0(i)))**2
        h03(i)=(max(0.,h0(i)))**3
    enddo

    ! allocate tridiagonal and initialize to identity matrix:
    allocate(D(mx+2), DL(mx+1), DU(mx+2), DU2(mx+2), IPIV(mx+2))
    D = 1.d0
    DU= 0.d0
    DL= 0.d0

    ! First and last rows (rows 1 and mx+2) of matrix corresponds to BCs
    ! Row i+1 of matrix corresponds to equation for cell i

    do i=1,mx

        ! Modify row i+1 (equation for i'th grid cell) to form (I-d^2) operator,
        ! unless this is a cell where SWE are used, then leave as row of I
        ! and set RHS to 0, so no modification to SWE result.

        if ((h0(i) > sw_depth0)) then

          ! Replace this row of identity matrix with dispersion terms
          ! Note that cm(i)*w(i-1) + c0(i)*w(i) + cp(i)*w(i+1) gives
          ! approximation to d^2 w = w_{xx} in plane wave case, or
          !                  d^2 w = (1/r * (r*w)_r)_r  in radial case
          ! Also h02 is h0**2 and h03 is h0**3:

          D(i+1) = 1.d0 - c0(i)*((B_param+.5d0)*h02(i) &
                - 1.d0/6.d0*h03(i)/h0(i))

          DU(i+1)= -cp(i)*((B_param+.5d0)*h02(i) &
                - 1.d0/6.d0*h03(i)/h0(i+1))

          DL(i)= -cm(i)*((B_param+.5d0)*h02(i) &
                - 1.d0/6.d0*h03(i)/h0(i-1))

        endif

    enddo

    ! left boundary
    ! No change ==> Dirichlet value 0 in ghost cell, Q_0 = 0
    ! For other BCs, change superdiagonal in row 1:

    if (bc_xlo==1) then
        ! for Neumann BC at left: impose Q_0 = Q_1
        DU(1) = -1.d0
    endif
    if (bc_xlo==3) then
        ! for wall-reflecting BC at left: impose Q_0 = -Q_1
        DU(1) = 1.d0
    endif

    ! right boundary
    ! No change ==> Dirichlet value 0 in ghost cell, Q_{mx+1} = 0
    ! For other BCs, change subdiagonal in row mx+2:

    if (bc_xhi==1) then
        ! for Neumann at right: impose Q_mx = Q_{mx+1}
        DL(mx+1) = -1.d0
    endif
    if (bc_xhi==3) then
        ! for wall at right: impose Q_mx = - Q_{mx+1}
        DL(mx+1) = 1.d0
    endif

    if (.false.) then
        ! DEBUG:
        write(66,*) 'D matrix:'
        do i=1,mx+2
            if (i>1) then
                DLi = DL(i-1)
            else
                DLi = -9999.  ! since no subdiag in first row
            endif
            write(66,661) DLi, D(i), DU(i)
  661       format(3e16.6)
        enddo
        write(66,*) '===== end of D'
    endif

    ! factor the tridiagonal matrix:
    call DGTTRF( mx+2, DL, D, DU, DU2, IPIV, INFO )

    end subroutine set_bouss

!======================================================================

    subroutine solve_tridiag(mx,meqn,mbc,dx,q,maux,aux,psi)

    ! Set up right hand side for tridagonal system and then solve it
    ! psi first holds RHS and then the solution to be passed back.

    ! Note that matrix has already been factored in set_bouss, so the
    ! arrays D, DL, DU, DU2, IPIV are already set up for the solver.

    use geoclaw_module, only: g => grav, sea_level, dry_tolerance
    use geoclaw_module, only: coordinate_system
    use grid_module, only: xcell

    implicit none

    integer, intent(in) :: mx,meqn,mbc,maux
    real(kind=8), intent(in) :: dx

    real(kind=8), intent(in) ::  q(meqn,1-mbc:mx+mbc)
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(out) :: psi(mx+2)

    real(kind=8)  depth
    real(kind=8), dimension(1-mbc:mx+mbc) :: h0, h02, h03, eta, hu2
    real(kind=8), dimension(1-mbc:mx+mbc) :: h_eta_x,h0_eta_x,s1,s1_h0
    real(kind=8)  h0_eta_xxx,s1_xx,s1_h0_xx
    integer :: i,j,k,kk,iL,iR
    integer(kind=4) :: INFO
    integer :: LDB

    h0 = sea_level - aux(1,:)

    do i=1-mbc,mx+mbc
        ! compute hu2 = h*u**2
        if (q(1,i).gt.dry_tolerance) then
            hu2(i)= q(2,i)**2/q(1,i)
        else
            hu2(i)= 0.d0
        endif

        !hu2(i) = 0.d0  ! Debug: turning off nonlinear terms

        ! h0 is resting depth, h02 = h0**2 and h03 = h0**3:
        eta(i)= q(1,i) - h0(i)
        h02(i)=(max(0.d0,h0(i)))**2
        h03(i)=(max(0.d0,h0(i)))**3

    enddo

    ! compute these quantities, extending to one set of ghost cells:
    ! h_eta_x  = h * eta_x
    ! h0_eta_x = h0 * eta_x

    ! defaults to 0 if h0==0 at one of the stencil points:
    h_eta_x = 0.d0
    h0_eta_x = 0.d0

    do i= 0,mx+1
        if (minval(h0(i-1:i+1)) > 0.d0) then
            ! if h0 > 0 at all stencil points.  Note dxc(i) = 2*dx if uniform:
            h_eta_x(i)= q(1,i)*(eta(i+1)-eta(i-1))/dxc(i)
            h0_eta_x(i)= h0(i)*(eta(i+1)-eta(i-1))/dxc(i)
        endif
    enddo

    do i=0,mx+1

        ! compute approximation to
        !   s1 = (h*u**2)_x + g*h*eta_x   (plane wave) or
        !   s1 = (1/r)*(r*h*u**2)_r + r*g*h*eta_r   (radial)
        !      = (h*u**2)_r + (1/r)*h*u**2 + r*g*h*eta_r

        s1(i) =  (hu2(i+1) - hu2(i-1)) / dxc(i) + g*h_eta_x(i)
        !s1(i) =  g*h_eta_x(i)  ! debug
        !s1(i) =  (hu2(i+1) - hu2(i-1)) / dxc(i)

        if (coordinate_system == -1) then
            ! radial: add term for (1/r)*h*u**2:
            s1(i) =  s1(i) + hu2(i) / xcell(i)
        else if (coordinate_system == 2) then
            ! latitude
            write(6,*) '*** latitude not yet implemented in bouss_module'
            stop
        endif

        ! compute s1_h0 = s1 / h0:

        if (h0(i) > dry_tolerance) then
            s1_h0(i)=s1(i)/h0(i)
        else
            s1_h0(i)=0.d0
        endif
    enddo

    ! Compute right hand side psi:

    psi = 0.d0

    do i=1,mx

       k = i+1  ! i'th equation corresponds to row k=i+1 of RHS

       if (h0(i) <= sw_depth0) then
            ! no dispersive term:
            psi(k) = 0.d0

        else
            ! Note that cm(i)*w(i-1) + c0(i)*w(i) + cp(i)*w(i+1) gives
            ! approximation to d^2 w = w_{xx}
            ! or in radial case to d^2 w = (1/r * (rw)_r)_r

            ! compute s1_xx, approximates d^2 s1:

            s1_xx = cp(i)*s1(i+1) + c0(i)*s1(i) + cm(i)*s1(i-1)

            ! compute s1_h0_xx, approximates d^2 s1_h0 = d^2(s1 / h0):

            s1_h0_xx = cp(i)*s1_h0(i+1) + c0(i)*s1_h0(i) + cm(i)*s1_h0(i-1)

            ! compute h0_eta_xxx, approximates d^2 h0_eta_x:

            h0_eta_xxx = cp(i)*h0_eta_x(i+1) + c0(i)*h0_eta_x(i) + &
                    cm(i)*h0_eta_x(i-1)

            ! Right-hand side:

            psi(k) = -(B_param+.5d0) * h02(i) * s1_xx &
                        + h03(i)/6.d0 * s1_h0_xx &
                        + B_param * g * h02(i) * h0_eta_xxx
            if (.false.) then
                write(66,*) '+++i,rhs(i+1): ',i, psi(k)
                write(66,*) (B_param+.5d0) * h02(i), s1_xx
                write(66,*) h03(i)/6.d0,  s1_h0_xx
                write(66,*) B_param * g * h02(i) * h0_eta_xxx
                write(66,*) B_param,  g,  h02(i),  h0_eta_xxx
                write(66,*) s1(i)
                write(66,*) h0_eta_x(i)
                write(66,*) eta(i)
            endif

        endif

        if ((h0(i) > sw_depth0) .and. (h0(i) < sw_depth1)) then
            ! reduce psi linearly between sw_depth0 and sw_depth1:
            psi(k) = psi(k) * (h0(i)-sw_depth0)/(sw_depth1-sw_depth0)
        endif

    enddo

    if (.false.) then
        write(66,*) 'RHS:'
        do i=1,mx+2
            write(66,*) '+++i,rhs: ',i, psi(i)
        enddo
    endif

    ! -------------------------
    ! solve tridiagonal system.
    ! psi is RHS on entry, solution on exit:

    LDB = mx+2  ! leading dimension of right-hand side matrix psi

    call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2, &
                 IPIV, psi, LDB,INFO )

    if (.false.) then
        write(66,*) 'Solution psi: '
        do i=1,mx+2
            write(66,*) '+++ i,psi: ',i,psi(i)
        enddo
    endif

    return
end subroutine solve_tridiag

end module bouss_module


      SUBROUTINE MB04OW( M, N, P, A, LDA, T, LDT, X, INCX, B, LDB,
     $                   C, LDC, D, INCD )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To perform the QR factorization
C
C        ( U  ) = Q*( R ),  where  U = ( U1  U2 ),  R = ( R1  R2 ),
C        ( x' )     ( 0 )              ( 0   T  )       ( 0   R3 )
C
C     where U and R are (m+n)-by-(m+n) upper triangular matrices, x is
C     an m+n element vector, U1 is m-by-m, T is n-by-n, stored
C     separately, and Q is an (m+n+1)-by-(m+n+1) orthogonal matrix.
C
C     The matrix ( U1 U2 ) must be supplied in the m-by-(m+n) upper
C     trapezoidal part of the array A and this is overwritten by the
C     corresponding part ( R1 R2 ) of R. The remaining upper triangular
C     part of R, R3, is overwritten on the array T.
C
C     The transformations performed are also applied to the (m+n+1)-by-p
C     matrix ( B' C' d )' (' denotes transposition), where B, C, and d'
C     are m-by-p, n-by-p, and 1-by-p matrices, respectively.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M      (input) INTEGER
C            The number of rows of the matrix ( U1  U2 ).  M >= 0.
C
C     N      (input) INTEGER
C            The order of the matrix T.  N >= 0.
C
C     P      (input) INTEGER
C            The number of columns of the matrices B and C.  P >= 0.
C
C     A      (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C            On entry, the leading M-by-(M+N) upper trapezoidal part of
C            this array must contain the upper trapezoidal matrix
C            ( U1 U2 ).
C            On exit, the leading M-by-(M+N) upper trapezoidal part of
C            this array contains the upper trapezoidal matrix ( R1 R2 ).
C            The strict lower triangle of A is not referenced.
C
C     LDA    INTEGER
C            The leading dimension of the array A.  LDA >= max(1,M).
C
C     T      (input/output) DOUBLE PRECISION array, dimension (LDT,N)
C            On entry, the leading N-by-N upper triangular part of this
C            array must contain the upper triangular matrix T.
C            On exit, the leading N-by-N upper triangular part of this
C            array contains the upper triangular matrix R3.
C            The strict lower triangle of T is not referenced.
C
C     LDT    INTEGER
C            The leading dimension of the array T.  LDT >= max(1,N).
C
C     X      (input/output) DOUBLE PRECISION array, dimension
C            (1+(M+N-1)*INCX), if M+N > 0, or dimension (0), if M+N = 0.
C            On entry, the incremented array X must contain the
C            vector x. On exit, the content of X is changed.
C
C     INCX   (input) INTEGER
C            Specifies the increment for the elements of X.  INCX > 0.
C
C     B      (input/output) DOUBLE PRECISION array, dimension (LDB,P)
C            On entry, the leading M-by-P part of this array must
C            contain the matrix B.
C            On exit, the leading M-by-P part of this array contains
C            the transformed matrix B.
C            If M = 0 or P = 0, this array is not referenced.
C
C     LDB    INTEGER
C            The leading dimension of the array B.
C            LDB >= max(1,M), if P > 0;
C            LDB >= 1,        if P = 0.
C
C     C      (input/output) DOUBLE PRECISION array, dimension (LDC,P)
C            On entry, the leading N-by-P part of this array must
C            contain the matrix C.
C            On exit, the leading N-by-P part of this array contains
C            the transformed matrix C.
C            If N = 0 or P = 0, this array is not referenced.
C
C     LDC    INTEGER
C            The leading dimension of the array C.
C            LDC >= max(1,N), if P > 0;
C            LDC >= 1,        if P = 0.
C
C     D      (input/output) DOUBLE PRECISION array, dimension
C            (1+(P-1)*INCD), if P > 0, or dimension (0), if P = 0.
C            On entry, the incremented array D must contain the
C            vector d.
C            On exit, this incremented array contains the transformed
C            vector d.
C            If P = 0, this array is not referenced.
C
C     INCD   (input) INTEGER
C            Specifies the increment for the elements of D.  INCD > 0.
C
C     METHOD
C
C     Let q = m+n. The matrix Q is formed as a sequence of plane
C     rotations in planes (1, q+1), (2, q+1), ..., (q, q+1), the
C     rotation in the (j, q+1)th plane, Q(j), being chosen to
C     annihilate the jth element of x.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0((M+N)*(M+N+P)) operations and is backward
C     stable.
C
C     FURTHER COMMENTS
C
C     For P = 0, this routine produces the same result as SLICOT Library
C     routine MB04OX, but matrix T may not be stored in the array A.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Matrix operations, plane rotations.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER            INCD, INCX, LDA, LDB, LDC, LDT, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), B(LDB,*), C(LDC,*), D(*), T(LDT,*),
     $                   X(*)
C     .. Local Scalars ..
      DOUBLE PRECISION   CI, SI, TEMP
      INTEGER            I, IX, MN
C     .. External Subroutines ..
      EXTERNAL           DLARTG, DROT
C
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked.
C
      MN = M + N
      IF ( INCX.GT.1 ) THEN
C
C        Code for increment INCX > 1.
C
         IX = 1
         IF ( M.GT.0 ) THEN
C
            DO 10 I = 1, M - 1
               CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP )
               A(I,I) = TEMP
               IX = IX + INCX
               CALL DROT( MN-I, A(I,I+1), LDA, X(IX), INCX, CI, SI )
               IF ( P.GT.0 )
     $            CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI )
   10       CONTINUE
C
            CALL DLARTG( A(M,M), X(IX), CI, SI, TEMP )
            A(M,M) = TEMP
            IX = IX + INCX
            IF ( N.GT.0 )
     $         CALL DROT( N, A(M,M+1), LDA, X(IX), INCX, CI, SI )
            IF ( P.GT.0 )
     $         CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI )
         END IF
C
         IF ( N.GT.0 ) THEN
C
            DO 20 I = 1, N - 1
               CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP )
               T(I,I) = TEMP
               IX = IX + INCX
               CALL DROT( N-I, T(I,I+1), LDT, X(IX), INCX, CI, SI )
               IF ( P.GT.0 )
     $            CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI )
   20       CONTINUE
C
            CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP )
            T(N,N) = TEMP
            IF ( P.GT.0 )
     $         CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI )
         END IF
C
      ELSEIF ( INCX.EQ.1 ) THEN
C
C        Code for increment INCX = 1.
C
         IF ( M.GT.0 ) THEN
C
            DO 30 I = 1, M - 1
               CALL DLARTG( A(I,I), X(I), CI, SI, TEMP )
               A(I,I) = TEMP
               CALL DROT( MN-I, A(I,I+1), LDA, X(I+1), 1, CI, SI )
               IF ( P.GT.0 )
     $            CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI )
   30       CONTINUE
C
            CALL DLARTG( A(M,M), X(M), CI, SI, TEMP )
            A(M,M) = TEMP
            IF ( N.GT.0 )
     $         CALL DROT( N, A(M,M+1), LDA, X(M+1), 1, CI, SI )
            IF ( P.GT.0 )
     $         CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI )
         END IF
C
         IF ( N.GT.0 ) THEN
            IX = M + 1
C
            DO 40 I = 1, N - 1
               CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP )
               T(I,I) = TEMP
               IX = IX + 1
               CALL DROT( N-I, T(I,I+1), LDT, X(IX), 1, CI, SI )
               IF ( P.GT.0 )
     $            CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI )
   40       CONTINUE
C
            CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP )
            T(N,N) = TEMP
            IF ( P.GT.0 )
     $         CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI )
         END IF
      END IF
C
      RETURN
C *** Last line of MB04OW ***
      END


program ciclista

    implicit none
    double precision, dimension(0:500) :: v, v1, tempo, diff
    double precision :: m, p, dt, b, ro, a
    integer :: c

    m = 60
    p = 400
    dt = 0.05
    b = 05
    ro = 1
    a = 0.33
    v(0) = 4

	do c = 1,500
	    tempo(c) = c*dt
	    diff(c-1) = p/(m*v(c-1))
	    v(c) = diff(c-1)*dt + v(c-1) - ((b*ro*a*v(c-1)**2)/m)*dt
!	    v(c) = diff(c-1)*dt + v(c-1)
	    write(*,*) tempo(c), v(c)
	enddo

    open(1,FILE = "dados2.txt")

	do c = 1,500
	    write(1,*) tempo(c), v(c)
	enddo

    close(1)

end program