!*********************************************
!
!Module containing routines for kronecker products
!and vector decomposition
!
!In modular form to make use of multi-level allocatable arrays
!that are standard in Fortran 95
!
!*********************************************
module kronecker_module
  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !!!!!!!!!!!!!!! GLOBAL VARIABLES !!!!!!!!!!!!!!!!!
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !Precision of numerical values
  integer, parameter		 :: dp=selected_real_kind(15, 300)		!IEEE 754 Double Precision

  !Error reporting
  integer, 			save :: ierr 										!Error integer

contains

  !*********************************************
  !
  !Performs Kronecker product of two matrices A and B producing matrix P
  !n and m correspond to the dimensions of A and x and y correspond to the dimensions of B
  !dimensions of P are assumed to be n*x and m*y
  !
  !*********************************************

  subroutine kronecker_product_complex(A, B, P)
    implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!! VARIABLES !!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !loop integers
    integer :: i, j, k, l

    !array size integers
    integer :: n, m, x, y

    !arrays for matrix storage
    complex(kind=dp), dimension(:, :), Allocatable :: A, B, P

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!! INITIALISATION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !calls the size of each dimension of matrix A
    !and assigns output to integer values
    n = SIZE(A, 1)
    m = SIZE(A, 2)

    !calls the size of each dimension of matrix B
    !and assigns output to integer values
    x = SIZE(B, 1)
    y = SIZE(B, 2)

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!! ARRAY SIZE CHECK !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !Checks to see if array sizes match for kronecker
    !product, aborts program if mismatch and prints error message
	if(SIZE(P, 1).eq.(n*x)) then
	  continue
	else if(SIZE(P, 2).eq.(m*y)) then
	  continue
	else
	  stop 'Array size mismatch in kronecker product routine'
	end if

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!! MAIN FUNCTION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    do i = 1, n
      do j = 1, m

	    do k = 1, x
	      do l = 1, y

            !Computes kronecker product values and
            !assigns them to matrix P
	        P((i-1)*x + k, (j-1)*y + l) = A(i, j) * B(k, l)

	      end do
	     end do

      end do
    end do

    return

  end subroutine kronecker_product_complex

  !*********************************************
  !
  !Performs Kronecker product of two vectors A and B producing vector P
  !n is the array size of of A and x is the array size of B
  !P is allocated a size of n*x
  !
  !*********************************************

  subroutine kronecker_product_complex_vector(A, B, P)
    implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!! VARIABLES !!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !loop integers
    integer :: i, j

    !array size integers
    integer :: n, x

    !arrays for matrix storage
    complex(kind=dp), dimension(:), Allocatable :: A, B, P

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!! INITIALISATION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !calls the size of vector A
    !and assigns output to integer value n
    n = SIZE(A)

    !calls the size of vector B
    !and assigns output to integer value x
    x = SIZE(B)

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!! ARRAY SIZE CHECK !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !Checks to see if array sizes match for kronecker
    !product, aborts program if mismatch and prints error message
	if(SIZE(P, 1).eq.(n*x)) then
	  continue
	else
	  stop 'Array size mismatch in kronecker product routine'
	end if

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!! MAIN FUNCTION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    do i = 1, n
      do j = 1, x

         !Computes kronecker product values and
         !assigns them to vector P
	     P((i-1)*x + j) = A(i) * B(j)

      end do
    end do

    return

  end subroutine kronecker_product_complex_vector

    !*********************************************
  !
  !Performs Kronecker product of two vectors A and B producing vector P
  !n is the array size of of A and x is the array size of B
  !P is allocated a size of n*x
  !
  !*********************************************

  subroutine outer_product_complex_vector(A, B, P)
    implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!! VARIABLES !!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !loop integers
    integer :: i, j

    !array size integers
    integer :: n, x

    !arrays for matrix storage
    complex(kind=dp), dimension(:), Allocatable :: A, B
    complex(kind=dp), dimension(:, :), Allocatable :: P

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!! INITIALISATION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !calls the size of vector A
    !and assigns output to integer value n
    n = SIZE(A)

    !calls the size of vector B
    !and assigns output to integer value x
    x = SIZE(B)

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!! ARRAY SIZE CHECK !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !Checks to see if array sizes match for outer
    !product, aborts program if mismatch and prints error message
	if((SIZE(P, 1).eq.(n)).and.(SIZE(P, 2).eq.(x))) then
	  continue
	else
	  stop 'Array size mismatch in between vectors and product matrix'
	end if

	if(x == n) then
	  continue
	else
	  stop 'Array size mismatch between vectors in outer product routine'
	end if

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!! MAIN FUNCTION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    do i = 1, n
      do j = 1, x

         !Computes outer product values and
         !assigns them to matrix P
         P(i, j) = A(i) * CONJG(B(j))

      end do
    end do

    return

  end subroutine outer_product_complex_vector

  !*********************************************
  !
  !Performs decomposition of vector A by performing inverse vectorisation
  !then taking a rank 1 decomposition
  !
  !Outputs vectors C and D
  !*********************************************

  subroutine rank_decomposition_complex(A, C, D)
    implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!! VARIABLES !!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !loop integers
    integer :: i, j

    !array size integers
    integer :: m, n, o

    !magnitude variable for normalisation
    real(kind=dp) :: magnitude

    !input and output vectors
    complex(kind=dp), dimension(:), Allocatable :: A, C, D

    !matrix for decomposition calculator
    complex(kind=dp), dimension(:,:), Allocatable :: B

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!! INITIALISATION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !calls the size of vector A
    !and assigns output to integer value m
    m = SIZE(A)

    !calls the size of vector C
    !and assigns output to integer value n
    n = SIZE(C)

    !calls the size of vector D
    !and assigns output to integer value o
    o = SIZE(D)

    !Allocates B with dimensions from size of input vectors
    Allocate(B(n, o))

    !Perform an inverse of the vec() operator by reshaping
    !vector A into a matrix of dimensions n x o
    B = TRANSPOSE(RESHAPE(A, (/ o, n /)))

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!! MAIN FUNCTION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !Finds the first non zero row from matrix B
    !and assigns it to vector C
    do i = 1, o
      do j = 1, n
	if(B(j, i) /= 0.0_dp) then
	  C(j) = B(j, i)
	  exit
	else
	  continue
	end if
      end do
    end do

    !Calculate vector magnitude of C
    do i = 1, n
      magnitude = magnitude + C(i)*C(i)
    end do

    magnitude = sqrt(magnitude)

    !Divide components of C by magnitude to normalise
    C = C / magnitude

    !Find the value of D required for matrix B to be formed
    !Reversing the kronecker product
    do i = 1, o
      do j = 1, n
	if(C(j) /= 0.0_dp) then
	  D(i) = (1.0_dp/(C(j))) * B(j, i)
	  exit
	else
	  continue
	end if
      end do
    end do

    Deallocate(B)

    return

  end subroutine

    !*********************************************
  !
  !Performs decomposition of vector A by performing inverse vectorisation
  !then taking a rank 1 decomposition
  !
  !Outputs vectors C and D
  !*********************************************

  subroutine known_rank_decomposition_complex(A, C, D)
    implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!! VARIABLES !!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !loop integers
    integer :: i, j

    !array size integers
    integer :: m, n, o

    !input and output vectors
    complex(kind=dp), dimension(:), Allocatable :: A, C, D

    !matrix for decomposition calculator
    complex(kind=dp), dimension(:,:), Allocatable :: B

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!! INITIALISATION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !calls the size of vector A
    !and assigns output to integer value m
    m = SIZE(A)

    !calls the size of vector C
    !and assigns output to integer value n
    n = SIZE(C)

    !calls the size of vector D
    !and assigns output to integer value o
    o = SIZE(D)

    !Allocates B with dimensions from size of input vectors
    Allocate(B(n, o))

    !Perform an inverse of the vec() operator by reshaping
    !vector A into a matrix of dimensions n x o
    B = TRANSPOSE(RESHAPE(A, (/ o, n /)))

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!! MAIN FUNCTION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !Find the value of D required for matrix B to be formed
    !Reversing the kronecker product
    do i = 1, o
      do j = 1, n
	if(C(j) /= 0.0_dp) then
	  D(i) = (1.0_dp/(C(j))) * B(j, i)
	  exit
	else
	  continue
	end if
      end do
    end do

    Deallocate(B)

    return

  end subroutine

  !*********************************************
  !
  !Performs decomposition of vector A by performing inverse vectorisation
  !then taking a single value decomposition and summing values of matrices
  !
  !Outputs vectors C and D
  !
  !*********************************************

  subroutine sv_decomposition_complex(A, C, D, U, S, VT)
    implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!! VARIABLES !!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !loop variables
    integer :: i, j

    !array size integers
    integer :: m, n, o

    !Input and output vectors
    complex(kind=dp), dimension(:), Allocatable :: A, C, D

    !Matrix for computation
    complex(kind=dp), dimension(:,:), Allocatable :: B

    !Output matrices and vectors of svd
    real(kind=dp), dimension(:), Allocatable :: S
    complex(kind=dp), dimension(:,:), Allocatable :: U, VT

    !variables required zgesvd
    integer :: LWORK, LDA, LDU, LDVT
    complex(kind=dp), dimension(:), Allocatable :: WORK
    real(kind=dp), dimension (:), Allocatable :: RWORK

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!! INITIALISATION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !calls the size of vector A
    !and assigns output to integer value m
    m = SIZE(A)

    !calls the size of vector C
    !and assigns output to integer value n
    n = SIZE(C)

    !calls the size of vector D
    !and assigns output to integer value o
    o = SIZE(D)

    !Assigns values to work variables
    LWORK = MAX(1, 4*(2*MIN(n, o) + MAX(n, o)))
    LDA = MAX(1, n)
    LDU = MAX(1, n)
    LDVT = MAX(1, o)

    !Allocates matrix for decomposition size n x o
    Allocate(B(n, o))

    !Allocates outputs of SVD
    Allocate(S(MIN(n, o)))
    Allocate(U(LDU, n))
    Allocate(VT(LDVT, o))

    !Allocates work arrays
    Allocate(WORK(MAX(1, LWORK)))
    Allocate(RWORK(5*MIN(n, o)))

    !Perform an inverse of the vec() operator by reshaping
    !vector A into a matrix of dimensions n x o
    B = TRANSPOSE(RESHAPE(A, (/ o, n /)))

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!! MAIN FUNCTION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !Calls the zgesvd LAPACK function to find SVD
    !stops program and prints error in case of failure
    call zgesvd('A', 'A', n, o, B, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, ierr)
      if(ierr.eq.0) then
	continue
      elseif(ierr.gt.0) then
	stop 'ZBDSQR did not converge'
      elseif(ierr.lt.0) then
	stop 'argument had an illegal value'
      end if

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!! OUTPUT !!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !Recombines values of svd to form vectors
    do i = 1, n
      C(i) = SUM(U(:,i))
    end do

    do i = 1, o
      D(i) = S(i)*SUM(VT(i,:))
    end do

    !Deallocates values no longer needed
    Deallocate(B, WORK, RWORK)

    return

  end subroutine

  !*********************************************
  !
  !Finds a 2 dimensional state vector for a specific qubit
  !in larger state vector
  !
  !Calls for decompositions to find appropriate qubit then recombines state vector
  !*********************************************

  subroutine get_vector_complex(A, E, G, m, trgt, U, S, VT)
    implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!! VARIABLES !!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    integer :: trgt
    integer :: m, n, o, p
    complex(kind=dp), dimension(:), Allocatable :: A, E, G
    complex(kind=dp), dimension(:), Allocatable :: C, D, F

    !Output matrices and vectors of svd
    real(kind=dp), dimension(:), Allocatable :: S
    complex(kind=dp), dimension(:,:), Allocatable :: U, VT

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!! INITIALISATION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !Assigns vector sizes depending on subroutine input
    if(trgt.eq.1) then
      n = 2
      o = 2**(m - 1)
    elseif(trgt.eq.m) then
      o = 2
      n = 2**(m - 1)
    else
      o = 2**(m - trgt)
      n = 2**(trgt)
      p = 2**(trgt-1)
    end if

    Allocate(D(o), C(n))

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!! MAIN FUNCTION !!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !Calls for svd of vector A
    call sv_decomposition_complex(A, C, D, U, S, VT)

    !Assigns values of decomposition based on target qubit
    !If target is not at either end of state vector, performs
    !another decomposition to find it
    if(trgt.eq.1) then
      E = C
      G = D
    elseif(trgt.eq.m) then
      G = C
      E = D
    else
      !Allocate(F(p))

      !call sv_decomposition_complex(D, E, F, U, S, VT)

      !call kronecker_product_complex_vector(C, F, G)

      !Deallocate(F)
    end if

    Deallocate(C, D)

    return

  end subroutine

end module


MODULE Circle
  !---------------------------------------------------------------------
  !
  !  Module containing definitions of variables needed to
  !  compute the area of a circle of radius r
  !
  !---------------------------------------------------------------------
  REAL, PARAMETER :: Pi = 3.1415927
  REAL :: radius
END MODULE Circle

PROGRAM Area
  !---------------------------------------------------------------------
  !
  !  This program computes the area of a circle given the input radius
  !
  !  Uses:  MODULE Circle
  !         FUNCTION Area_Circle (r)
  !
  !---------------------------------------------------------------------
  USE Circle, ONLY : radius
  IMPLICIT NONE

  INTERFACE
     FUNCTION Area_Circle (r)
       REAL, INTENT(IN) :: r
     END FUNCTION Area_Circle
  END INTERFACE

  !  Prompt user for radius of circle
  write(*, '(A)', ADVANCE = "NO") "Enter the radius of the circle:  "
  read(*,*) radius

  ! Write out area of circle using function call
  write(*,100) "Area of circle with radius", radius, " is", &
       Area_Circle(radius)
100 format (A, 2x, F6.2, A, 2x, F11.2)

END PROGRAM Area

!-----Area_Circle----------------------------------------------------
!
!  Function to compute the area of a circle of given radius
!
!---------------------------------------------------------------------
FUNCTION Area_Circle(r)
  USE Circle, ONLY : Pi

  IMPLICIT NONE
  REAL :: Area_Circle
  REAL, INTENT(IN) :: r

  Area_Circle = Pi * r * r

END FUNCTION Area_Circle


    program hello
    use custom_precision
    use initialisation
    use pretty_print
    use test

    implicit none

    integer, parameter          :: NMAX = 6
    integer, parameter          :: MAX_EXPORT_SIZE = 2000

#ifdef _DP
    real(DP), parameter         :: ST = -5., fn = 9.
    real(DP), parameter         :: DIAG_COEF = 2., UDIAG_COEF = -1., LDIAG_COEF = 1.
    real(DP), allocatable       :: matrix(:,:), vector_solution(:), vector_rhs(:), vector_rhs_blas(:)
#else
    real(SP), parameter         :: ST = -5., fn = 9.
    real(SP), parameter         :: DIAG_COEF = 2., UDIAG_COEF = -1., LDIAG_COEF = 1.
    real(SP), allocatable       :: matrix(:,:), vector_solution(:), vector_rhs(:), vector_rhs_blas(:)
#endif
    integer                     :: alloc_status
    real                        :: tstart, tfinish, tstart_total
    integer                     :: err
    integer                     :: N, nargs
    character(10)               :: arg

    nargs = command_argument_count()
    if (nargs > 0) then
        call get_command_argument(1, arg)
        read(arg, *) N
    else
        N = NMAX
    end if

    write(*,*) ''
    write(*,*) "Working with size ", N
#ifdef _DP
    write(*,*) "Double precision"
#else
    write(*,*) "Single precision"
#endif
    write(*,*) ''

    ! Start the timer...
    call cpu_time(tstart_total)

    allocate(matrix(N, N),  &
        vector_solution(N), &
        vector_rhs(N),      &
        vector_rhs_blas(N), &
        stat=alloc_status)

    if (alloc_status) then
        write(*,*) "ERROR: Failed to allocate required arrays...!"
        write(*,*) "       Try reducing the size."
        goto 100
    end if

    write(*,*) "Initialising arrays..."
    call initialise_tridiagonal(matrix, N, UDIAG_COEF, DIAG_COEF, LDIAG_COEF)
    call initialise_to_random(vector_solution, N, st, fn)

    call cpu_time(tfinish)
    write(*, '("Initialisation time = ",f6.3," seconds.")') tfinish - tstart_total

    write(*,*) "Getting correct result for reference..."
    call cpu_time(tstart)
    vector_rhs = matmul(matrix, vector_solution)
    call cpu_time(tfinish)
    write(*, '("matmul time = ",f6.3," seconds.")') tfinish - tstart

    call cpu_time(tstart)
    if (kind(matrix) == kind(1.)) then
        call sgemv('N', N, N, 1., matrix, N, vector_solution, 1, 0., vector_rhs_blas, 1)
    else
        call dgemv('N', N, N, 1.d0, matrix, N, vector_solution, 1, 0.d0, vector_rhs_blas, 1)
    end if
    call cpu_time(tfinish)
    write(*, '("?gemv time = ",f6.3," seconds.")') tfinish - tstart

    if (N < MAX_EXPORT_SIZE) then
        write(*,*) ''
        write(*,*) "Saving arrays..."
        call cpu_time(tstart)
        call pretty_write(matrix, 'matrix.log')
        call pretty_write(vector_solution, 'solution.log')
        call pretty_write(vector_rhs, 'vector_rhs.log')
        call pretty_write(vector_rhs_blas, 'vector_rhs_blas.log')
        call cpu_time(tfinish)
        write(*, '("Writing time = ",f6.3," seconds.")') tfinish - tstart
    end if

    write(*,*) ''
    call test_tridiagonal_solver(matrix, N, vector_rhs_blas, vector_solution, err)
    if (err /= 0) then
        write(*,*) "ERROR: Failed to complete test...!"
        goto 100
    end if

    write(*,*) ''
    call test_tridiagonal_solver_xp(matrix, N, vector_rhs_blas, vector_solution, err)
    if (err /= 0) then
        write(*,*) "ERROR: Failed to complete test...!"
        goto 100
    end if

    call cpu_time(tstart)
    call test_poisson_solver(200, 135, 0.1, 0.1)
    call cpu_time(tfinish)
    write(*, '("Poisson solver run time = ",f6.3," seconds.")') tfinish - tstart

    call cpu_time(tfinish)
    write(*, '("Total run time = ",f6.3," seconds.")') tfinish - tstart_total

100 write(*,*) "Done!"
#ifdef _VSBUILD
    write(*,*) "Press Enter to exit..."
    read(*,*)
#endif
    end program


! minimal working example of the pstar calculation following the
! algorithm of toro - shows his table is indeed correct and
! I was just being rather cavalier trying to
! embedd it within a more complicated program structure from the get-go!

program pstar

  implicit none

  integer, parameter :: num=selected_real_kind(p=6)

  integer :: i, imax, k

  real(num) :: rhol, rhor, rhok
  real(num) :: ul, ur
  real(num) :: pl, pr, pk
  real(num) :: ak, bk, ck

  real(num) :: ps, pold, delta, change
  real(num) :: f, fprime
  real(num) :: gamma
  real(num) :: tol

 !initial conditions

  !test 1 sod
  rhol = 1.0_num
  ul = 0.0_num
  pl = 1.0_num
  rhor = 0.125_num
  ur = 0.0_num
  pr = 0.1_num
  gamma = 1.4_num

!  !test 5 - both halfs of the W+C blast
!  rhol = 5.99924_num
!  ul = 19.5975_num
!  pl = 460.894_num
!  rhor= 5.99242_num
!  ur = -6.19633_num
!  pr = 46.0950_num
!  gamma = 1.4_num

  !initial guess on pstar

  ps = 0.5_num * (pl + pr)

  !iterate NR for converged pstar according to tolerances
  tol = 1e-6_num

  i = 0
  imax = 20 !debuggin
  change = 1e15_num
  do
    if (change <= tol) exit !condition on tolerance

    pold = ps

    !evaluate the function f and fprime at pold
    f = ur - ul !speed contribution to f(p)
    fprime = 0.0_num
    do k = 0, 1 !left and right wave contributions

      if (k == 0) then
        ak = 2.0_num / (gamma + 1.0_num) / rhol
        bk = (gamma-1.0_num)/(gamma+1.0_num) * pl
        ck = sqrt(gamma * pl / rhol)
        pk = pl
        rhok = rhol
      else
        ak = 2.0_num / (gamma + 1.0_num) / rhor
        bk = (gamma-1.0_num)/(gamma+1.0_num) * pr
        ck = sqrt(gamma * pl / rhor)
        pk = pr
        rhok = rhor
      endif

      if (ps > pk) then !shock
        f = f + (ps - pk) * sqrt(ak / (ps+bk))
        fprime = fprime + sqrt(ak / (ps+bk)) * &
          & (1.0_num - 0.5_num*(ps-pk)/(bk+ps))
      else !rarefaction
        f = f + 2.0_num / (gamma-1.0_num) * ck * &
          & ((ps/pk)**((gamma-1.0_num)/2.0_num/gamma) - 1.0_num)
        fprime = fprime + (ps/pk)**(-(gamma+1.0_num)/2.0_num/gamma) / &
          & (rhok * ck)
      endif
      print *,'i',i,'f',f,'fprime',fprime
    enddo

    !advance the newton raphson and calculate a change to compare to tol
    delta = f /fprime
    ps = pold - delta
    change = 2.0_num * abs((ps - pold) / (ps + pold))

    i = i + 1
    if (ps < 0.0_num) ps = tol !to correct -ve p guesses

    print *,'i',i,'pold',pold,'psnew',ps, 'change',change,'delta', delta

    if (i > imax ) exit
  enddo

print *, 'Newton-Raphson converged in',i,'iterations'

end program pstar


MODULE vector_module
IMPLICIT NONE
TYPE :: vector
  REAL :: x
  REAL :: y
CONTAINS
  PROCEDURE, PASS :: add
  PROCEDURE, PASS :: sub
END TYPE vector

CONTAINS
  TYPE (vector) FUNCTION add(this, v)
  IMPLICIT NONE
  CLASS (vector) :: this, v
  add = vector(this%x + v%x, this%y + v%y)
  END FUNCTION add

  TYPE (vector) FUNCTION sub(this, v)
  IMPLICIT NONE
  CLASS (vector) :: this, v
  sub = vector(this%x - v%x, this%y - v%y)
  END FUNCTION sub

  TYPE (vector) FUNCTION vector_add(v1, v2)
  IMPLICIT NONE
  TYPE (vector), INTENT(IN) :: v1, v2
  vector_add = vector(v1%x + v2%x, v1%y + v2%y)
  END FUNCTION vector_add

  TYPE (vector) FUNCTION vector_sub(v1, v2)
  IMPLICIT NONE
  TYPE (vector), INTENT(IN) :: v1, v2
  vector_sub = vector(v1%x - v2%x, v1%y - v2%y)
  END FUNCTION vector_sub
END MODULE vector_module

PROGRAM test_bound_vectors
USE vector_module
IMPLICIT NONE
TYPE (vector) :: a, b, c
a = vector(1., 2.)
b = vector(6., 9.)
!c = vector_add(a, b)
c = a%add(b)
WRITE(*, *) c
!c = vector_sub(a, b)
c = a%sub(b)
WRITE(*, *) c
END PROGRAM test_bound_vectors


      SUBROUTINE lop(out,u,n)
      INTEGER n
      DOUBLE PRECISION out(n,n),u(n,n)
      INTEGER i,j
      DOUBLE PRECISION h,h2i
      h=1.d0/(n-1)
      h2i=1.d0/(h*h)
      do 12 j=2,n-1
        do 11 i=2,n-1
          out(i,j)=h2i*(u(i+1,j)+u(i-1,j)+u(i,j+1)+u(i,j-1)-4.d0*u(i,
     *j))+u(i,j)**2
11      continue
12    continue
      do 13 i=1,n
        out(i,1)=0.d0
        out(i,n)=0.d0
        out(1,i)=0.d0
        out(n,i)=0.d0
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/lop.for


PROGRAM QUADRATIC

 IMPLICIT NONE
 INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15)
 REAL(dp) :: a, b, c, e, discriminant, rroot1, rroot2
 COMPLEX(dp) :: croot1, croot2

 WRITE(*,*) "Enter the coefficients of the equation ax^2 + bx + c"
 WRITE(*, "(A)", ADVANCE="NO") "a = "
 READ *, a
 WRITE(*,"(A)", ADVANCE="NO") "b = "
 READ *, b
 WRITE(*,"(A)", ADVANCE="NO") "c = "
 READ *, c

 WRITE(*,"(3(A,E23.15))") "Coefficients are: a = ", a, "   b = ", b, "   c = ", c
 e = 1.0e-9_dp
 discriminant = b*b - 4.0_dp*a*c

 IF (ABS(discriminant) < e) THEN
    rroot1 = -b / (2.0_dp * a)
    WRITE(*,*) "The roots are real and equal:"
    WRITE(*,"(A,E23.15)") "Root = ", rroot1
 ELSE IF (discriminant > 0) THEN
    rroot1 = -(b + SIGN(SQRT(discriminant), b)) / (2.0_dp * a)
    rroot2 = c / (a * rroot1)
    WRITE(*,*) "The roots are real:"
    WRITE(*,"(2(A,E23.15))") "Root1 = ", rroot1, "  Root2 = ", rroot2
 ELSE
    croot1 = (-b + SQRT(CMPLX(discriminant))) / (2.0_dp*a)
    croot2 = CONJG(croot1)
    WRITE(*,*) "The roots are complex:"
    WRITE(*,"(2(A,2E23.15,A))") "Root1 = ", croot1, "j ", "  Root2 = ", croot2, "j"
 END IF


c     Fortran translation (Heh!) of test5 in quadpack-tests.lisp.
      program test5
      implicit none
      double precision alpha
      integer key, keyval(3)
      data keyval/1,3,6/

      print *, 'Test 5, same integral as test 2'
      print *
      print *, ' integrate(1/((x-pi/4)^2+1/alpha, x, 0, 1)'
      print *, '   = atan((4-pi)*4^(alpha-1))+atan(pi*4^(alpha-1))'
      print *
      print *, 'QNG'
      print 9000
      do 10 alpha = 0d0, 20d0
         call qqng(alpha)
   10 continue
      print *
      print *, 'QAGS'
      print 9000
      do 30 alpha = 0d0, 20d0
         call qqags(alpha)
   30 continue
      print *
      print *, 'QAG'
      print 9000
      do 50 alpha = 0d0, 20d0
         call qqag(alpha)
   50 continue
 9000 format('alpha   est result              est abserr             nev
     &al    ier   true answer            true abs err')
      end
      double precision function soln(alpha)
      implicit none
      double precision alpha
      double precision z, pi
      parameter (pi = 3.141592653589793d0)

      z = 4**(alpha-1)
      soln = atan((4-pi)*z) + atan(pi*z)
      return
      end

      double precision function f(x)
      implicit none
      double precision pi
      parameter (pi = 3.141592653589793d0)
      double precision x
      double precision alfa
      common /param/ alfa
      f = 4d0**(-alfa)/((x-pi/4)**2 + 16d0**(-alfa))
      return
      end

      subroutine qqng(alpha)
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqng(f, 0d0, 1d0, 0d0, 1d-8, result, abserr, neval, ier)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      subroutine qqags(alpha)
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqags(f, 0d0, 1d0, 0d0, 1d-8, result, abserr, neval, ier,
     $     limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      subroutine qqag(alpha)
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqag(f, 0d0, 1d0, 0d0, 1d-8, 1, result, abserr, neval, ier,
     $     limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end


MODULE solvers
! This module contains simultaneous equation solvers.
INTERFACE
  MODULE SUBROUTINE simul(a, b, ndim, n, error)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: ndim
  REAL, INTENT(INOUT), DIMENSION(ndim, ndim) :: a
  REAL, INTENT(INOUT), DIMENSION(ndim) :: b
  INTEGER, INTENT(IN) :: n
  INTEGER, INTENT(OUT) :: error
  END SUBROUTINE simul
END INTERFACE
END MODULE solvers

SUBMODULE(solvers) solvers_exec
CONTAINS
  MODULE PROCEDURE simul
  REAL, PARAMETER :: EPSILON = 1.0E-6
  REAL :: factor
  INTEGER :: irow, ipeak, jrow, kcol
  REAL :: temp

  mainloop: DO irow = 1, n
    ipeak = irow
    max_pivot: DO jrow = irow + 1, n
      IF (ABS(a(jrow, irow)) > ABS(a(ipeak, irow))) THEN
        ipeak = jrow
      END IF
    END DO max_pivot

    singular: IF (ABS(a(ipeak, irow)) < EPSILON) THEN
      error = 1
      RETURN
    END IF singular

    swap_eqn: IF(ipeak /= irow) THEN
      DO kcol = 1, n
        temp           = a(ipeak, kcol)
        a(ipeak, kcol) = a(irow, kcol)
        a(irow, kcol)  = temp
      END DO
      temp     = b(ipeak)
      b(ipeak) = b(irow)
      b(irow)  = temp
    END IF swap_eqn

    eliminate: DO jrow = 1, n
      IF (jrow /= irow) THEN
        factor = -a(jrow, irow) / a(irow, irow)
        DO kcol = 1, n
          a(jrow, kcol) = a(irow, kcol) * factor + a(jrow, kcol)
        END DO
        b(jrow) = b(irow) * factor + b(jrow)
      END IF
    END DO eliminate
  END DO mainloop

  divide: DO irow = 1, n
    b(irow) = b(irow) / a(irow, irow)
    a(irow, irow) = 1.
  END DO divide
  error = 0
  END PROCEDURE simul
END SUBMODULE solvers_exec

PROGRAM test_simul2
USE solvers
IMPLICIT NONE
INTEGER, PARAMETER :: MAX_SIZE = 10
REAL, DIMENSION(MAX_SIZE, MAX_SIZE) :: a
REAL, DIMENSION(MAX_SIZE) :: b
INTEGER :: error
CHARACTER(len=20) :: file_name
INTEGER :: i, j
CHARACTER(len=80) :: msg
INTEGER :: n, istat

WRITE(*, "('Enter the file name containing the equations: ')")
READ(*, '(A20)') file_name

END PROGRAM test_simul2


program compute_pi
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    use omp_lib
    implicit none
    integer, parameter :: num_iters = 1000
    integer :: i
    real(kind=dp) :: x, pi_sum, dx, pi

    pi_sum = 0.0_dp
    dx = 1.0_dp/num_iters
    !$omp parallel private(x), shared(dx, pi_sum), default(none)
    !$omp do reduction(+:pi_sum) schedule(runtime)
    do i = 1, num_iters
        x = i*dx
        pi_sum = pi_sum + 1.0_dp/(1.0_dp + x**2)
    end do
    !$end omp do
    !$omp end parallel
    pi = 4.0_dp*pi_sum*dx
    print '(E10.7)', pi
end program compute_pi


! 8.24 в учебнике

program ex_8_24
    implicit none
    integer, parameter      :: R_ = 4
    integer                 :: In = 0, Out = 0, N = 0, i = 0
    real(R_)                :: x, a, b, h, sum, integral, t
    character(*), parameter :: output_file = "output.txt", &
                               input_file = "../data/input.txt"

    open (file=input_file, newunit=In)
        read(In, *) a, b
        read(In, *) N
        read(In, *) x
    close (In)

    if (mod(N,2) == 1 .or. N <= 0) then
        write(*,*) 'Число N должно быть положительным и четным. Отмена...'
        stop
    endif

    h = (b - a) / N
    t = a
    sum = F(t)

    i = 1
    do
        t = t + h
        sum = sum + 4 * F(t)

        i = i + 2

        if (i >= N) exit

        t = t + h
        sum = sum + 2 * F(t)
    enddo

    sum = sum + F(b)
    integral = h/3 * sum

    open (file=output_file, newunit=Out)
        write(Out,*) 'Ответ ', integral
    close (Out)

contains

real function F(x)
    implicit none
    real, intent(in) :: x

    F = (q(x) ** 2 + 1.57) / sqrt(q(x) + 2.15)

end function F

pure real function q(x)
    implicit none
    real, intent(in) :: x
    real             :: sum, old_E, new_E
    integer          :: i, j

    sum   = 1
    new_E = 1

    i   = 1
    do
        old_E = new_E
        new_E = old_E * x**i

        do j = i*2+1, 2, -1
            new_E = new_E / j
        enddo

        sum = sum + new_E
        if (new_E == old_E) exit
    enddo

    q = sum

end function q

end program ex_8_24


SUBROUTINE kstwo(data1,n1,data2,n2,d,prob)
INTEGER*4 n1,n2
REAL*8 d,prob,data1(n1),data2(n2)
! USES probks,sort
INTEGER*4 j1,j2
REAL*8 d1,d2,dt,en1,en2,en,fn1,fn2,probks
call sort(n1,data1)
call sort(n2,data2)
en1=n1
en2=n2
j1=1
j2=1
fn1=0.
fn2=0.
d=0.
do while(j1.le.n1.and.j2.le.n2)
	d1=data1(j1)
	d2=data2(j2)
	if(d1.le.d2)then
		fn1=j1/en1
          j1=j1+1
  	endif
	if(d2.le.d1)then
          fn2=j2/en2
          j2=j2+1
	endif
	dt=abs(fn2-fn1)
	if(dt.gt.d)d=dt
enddo
en=sqrt(en1*en2/(en1+en2))
prob=probks((en+0.12+0.11/en)*d)
return
END


      subroutine DGEFA(A,LDA,N,IPVT,INFO)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DGEFA  Krogh  Added external statement.
C>> 1994-10-20 DGEFA  Krogh  Changes to use M77CON
C>> 1987-08-18 DGEFA  Lawson  Initial code.
c--D replaces "?": ?GEFA, ?SCAL, ?AXPY, I?AMAX
C
C     DGEFA computes the LU factorization of the N x N matrix A by
c     Gaussian elimination.  This produces matrices, L and U, that
c     satisfy L * U = A, where U is an upper triangular matrix and
c     L is a permutation of a lower triangular matrix. Use of this
c     subroutine would typically be followed by use of other
c     subroutines that would use this factorization to solve a
c     system of linear equations, or to compute the inverse matrix
c     or the determinant of A.
C
C     DGEFA may be referenced indirectly via _GECO, but it can be called
C     directly with a saving in time if the reciprocal condition number
C     RCOND is not needed.
C     (Time for _GECO) = (1 + 9/N)*(Time for DGEFA) .
C
c     ------------------------------------------------------------------
c                        Subroutine arguments
C
C     A(,)  [inout]  An array of size at least N x N.  On entry must
c            contain an N x N matrix, A, to be factored.  On return will
c            contain the LU factors of A.
C
C     LDA  [in]  Leading dimensioning parameter for the array A(,).
C
C     N  [in]  The order of the matrix, A.
C
C     IPVT()  [in]  An integer array of length at least N, containg a
c           record of the row interchanges made during factorization of
c           A.
c
C      INFO  [out]  Indicate status on return
C              = 0  NORMAL VALUE.
C              = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C              CONDITION FOR THIS SUBROUTINE, but it does
C              indicate that the usual following steps to solve
c              equations or compute an inverse matrix cannot
c              be done, at least by the usual straightforward
c              algorithms.  Use RCOND in _GECO for a more reliable
C              indication of singularity.
c     ------------------------------------------------------------------
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
c     Ref: LINPACK Users' Guide, by J. J. Dongarra, C. B. Moler,
c     J. R. Bunch, and G. W. Stewart, publ by Soc. for Indust. and Appl.
c     Math, Philadelphia, 1979.
c     Adapted from LINPACK for the JPL Math77 library by
c     C. L. Lawson, JPL, Aug 1987.
c     ------------------------------------------------------------------
C     Subprograms referenced: DAXPY,DSCAL,IDAMAX
c     ------------------------------------------------------------------
      external IDAMAX
      integer IDAMAX
      integer LDA,N,IPVT(N),INFO, J,K,KP1,L,NM1
      double precision A(LDA,N), T, ONE, ZERO
      parameter(ONE=1.D0, ZERO=0.D0)
c     ------------------------------------------------------------------
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
      INFO = 0
      NM1 = N - 1
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IDAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. ZERO) THEN
           INFO = K
         ELSE
C           INTERCHANGE IF NECESSARY
           IF (L .NE. K) THEN
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
           END IF
C
C           COMPUTE MULTIPLIERS
C
            T = -ONE/A(K,K)
            CALL DSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .NE. K) THEN
                  A(L,J) = A(K,J)
                  A(K,J) = T
               END IF
               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         ENDIF
   60 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. ZERO) INFO = N
      RETURN
      END


! MIT License
! Copyright (c) 2019 Sam Miller
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module mod_gnoffo_aux_limiter

  use, intrinsic :: iso_fortran_env, only: ik => int32, rk => real64
  use math_constants, only: pi
  implicit none

  private
  public :: gnoffo_aux_limiter
contains

  real(rk) elemental function gnoffo_aux_limiter(p_unlim, p_i, p_j) result(phi_g)
    !< The Gnoffo Auxiliary limiter as described in [1]
    !< References
    !< [1] Keiichi Kitamura, Atsushi Hashimoto, Simple a posteriori slope limiter (Post Limiter) for high resolution and efficient flow computations
    !<     https://doi.org/10.1016/j.jcp.2017.04.002
    !< [2] P.A. Gnoffo, Updates to Multi-Dimensional Flux Reconstruction for Hypersonic Simulations on Tetrahedral Grids
    !<     https://ntrs.nasa.gov/archive/nasa/casi.ntrs.nasa.gov/20100003598.pdf

    real(rk), intent(in) :: p_unlim
    real(rk), intent(in) :: p_i
    real(rk), intent(in) :: p_j
    real(rk) :: phi
    real(rk) :: psi
    real(rk), parameter :: psi_max = 3.0_rk
    real(rk), parameter :: psi_min = 2.0_rk

    real(rk) :: p_max, p_min

    ! Eq. 5e
    p_max = max(p_unlim, p_i, p_j)

    ! Eq. 5d
    p_min = min(p_unlim, p_i, p_j)

    ! Eq. 5c
    psi = p_max / p_min

    ! Eq. 5b
    phi = min(1.0_rk, max(0.0_rk,(psi_max - psi) / (psi_max - psi_min)))

    ! Eq. 5a
    phi_g = (1.0_rk - cos(phi * pi)) / 2.0_rk

  endfunction

endmodule mod_gnoffo_aux_limiter