      program main

c*********************************************************************72
c
cc MAIN runs an example of Dijkstra's minimum distance algorithm.
c
c  Discussion:
c
c    Given the distance matrix that defines a graph, we seek a list
c    of the minimum distances between node 0 and all other nodes.
c
c    This program sets up a small example problem and solves it.
c
c    The correct minimum distances are:
c
c      0   35   15   45   49   41
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    BY Sourangshu Ghosh
c
c  Author:
c
c  Sourangshu Ghosh
c
      implicit none

      include 'omp_lib.h'

      integer nv
      parameter ( nv = 6 )

      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer j
      integer mind(nv)
      integer ohd(nv,nv)

      call timestamp ( )
      write ( *, '(a)' )  ' '
      write ( *, '(a)' )  'DIJKSTRA_OPENMP:'
      write ( *, '(a)' )  '  FORTRAN77 version'
      write ( *, '(a)' )
     &  '  Use Dijkstra''s algorithm to determine the minimum'
      write ( *, '(a)' )
     &  '  distance from node 1 to each node in a graph,'
      write ( *, '(a)' )
     &  '  given the distances between each pair of nodes.'
      write ( *, '(a)' )  ' '
      write ( *, '(a)' )
     &  '  Although a very small example is considered, we'
      write ( *, '(a)' )  '  demonstrate the use of OpenMP directives'
      write ( *, '(a)' )  '  for parallel execution.'
c
c  Initialize the problem data.
c
      call init ( nv, ohd )
c
c  Print the distance matrix.
c
      write ( *, '(a)' )  ' '
      write ( *, '(a)' )  '  Distance matrix:'
      write ( *, '(a)' )  ' '
      do i = 1, nv
        write ( *, '(6(2x,i3))' ) ( ohd(i,j), j = 1, nv )
      end do
c
c  Carry out the algorithm.
c
      call dijkstra_distance ( nv, ohd, mind )
c
c  Print the results.
c
      write ( *, '(a)' )  ' '
      write ( *, '(a)' )  '  Minimum distances from node 1:'
      write ( *, '(a)' )  ' '
      do i = 1, nv
        write ( *, '(2x,i2,2x,i2)' ) i, mind(i)
      end do
c
c  Terminate.
c
      write ( *, '(a)' )  ' '
      write ( *, '(a)' )  'DIJKSTRA_OPENMP:'
      write ( *, '(a)' )  '  Normal end of execution.'

      write ( *, '(a)' )  ' '
      call timestamp ( )

      stop
      end
      subroutine dijkstra_distance ( nv, ohd, mind )

c*********************************************************************72
c
cc DIJKSTRA_DISTANCE uses Dijkstra's minimum distance algorithm.
c
c  Discussion:
c
c    We essentially build a tree.  We start with only node 0 connected
c    to the tree, and this is indicated by setting CONNECTED(0) = TRUE.
c
c    We initialize MIND(I) to the one step distance from node 0 to node I.
c
c    Now we search among the unconnected nodes for the node MV whose minimum
c    distance is smallest, and connect it to the tree.  For each remaining
c    unconnected node I, we check to see whether the distance from 0 to MV
c    to I is less than that recorded in MIND(I), and if so, we can reduce
c    the distance.
c
c    After NV-1 steps, we have connected all the nodes to 0, and computed
c    the correct minimum distances.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Parameters:
c
c    Input, integer NV, the number of nodes.
c
c    Input, integer OHD(NV,NV), the distance of the direct
c    link between nodes I and J.
c
c    Output, integer MIND(NV), the minimum
c    distance from node 1 to each node.
c
      implicit none

      include 'omp_lib.h'

      integer nv

      logical connected(nv)
      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer md
      integer mind(nv)
      integer mv
      integer my_first
      integer my_id
      integer my_last
      integer my_md
      integer my_mv
      integer my_step
      integer nth
      integer ohd(nv,nv)
c
c  Start out with only node 1 connected to the tree.
c
      connected(1) = .true.
      do i = 2, nv
        connected(i) = .false.
      end do
c
c  Initialize the minimum distance to the one-step distance.
c
      do i = 1, nv
        mind(i) = ohd(1,i)
      end do
c
c  Begin the parallel region.
c
c$omp parallel private ( my_first, my_id, my_last, my_md, my_mv, my_step )
c$omp&         shared ( connected, md, mind, mv, nth, ohd )

      my_id = omp_get_thread_num ( )
      nth = omp_get_num_threads ( )
      my_first =   (   my_id       * nv ) / nth + 1
      my_last  =   ( ( my_id + 1 ) * nv ) / nth
c
c  The SINGLE directive means that the block is to be executed by only
c  one thread, and that thread will be whichever one gets here first.
c
c$omp single
      write ( *, '(a)' ) ' '
      write ( *, * ) '  P', my_id,
     &  ': Parallel region begins with ', nth, ' threads.'
      write ( *, '(a)' ) ' '
c$omp end single
      write ( *, * ) '  P', my_id, ':  First=', my_first,
     &  '  Last=', my_last
c
c  Attach one more node on each iteration.
c
      do my_step = 2, nv
c
c  Before we compare the results of each thread, set the shared variable
c  MD to a big value.  Only one thread needs to do this.
c
c$omp single
        md = i4_huge
        mv = -1
c$omp end single
c
c  Each thread finds the nearest unconnected node in its part of the graph.
c  Some threads might have no unconnected nodes left.
c
        call find_nearest ( my_first, my_last, nv, mind, connected,
     &    my_md, my_mv )
c
c  In order to determine the minimum of all the MY_MD's, we must insist
c  that only one thread at a time execute this block!
c
c$omp critical
        if ( my_md .lt. md ) then
          md = my_md
          mv = my_mv
        end if
c$omp end critical
c
c  This barrier means that ALL threads have executed the critical
c  block, and therefore MD and MV have the correct value.  Only then
c  can we proceed.
c
c$omp barrier
c
c  If MV is -1, then NO thread found an unconnected node, so we're done early.
c  OpenMP does not like to BREAK out of a parallel region, so we'll just have
c  to let the iteration run to the end, while we avoid doing any more updates.
c
c  Otherwise, we connect the nearest node.
c
c$omp single
        if ( mv .ne. - 1 ) then
          connected(mv) = .true.
          write ( *, * ) '  P', my_id, ': Connecting node ', mv
        else
          write ( *, * )
     &      '  P', my_id, ': No connecting node on step ', my_step
        end if
c$omp end single
c
c  Again, we don't want any thread to proceed until the value of
c  CONNECTED is updated.
c
c$omp barrier
c
c  Now each thread should update its portion of the MIND vector,
c  by checking to see whether the trip from 0 to MV plus the step
c  from MV to a node is closer than the current record.
c
        if ( mv .ne. -1 ) then
          call update_mind ( my_first, my_last, nv, connected, ohd,
     &      mv, mind )
        end if
c
c  Before starting the next step of the iteration, we need all threads
c  to complete the updating, so we set a BARRIER here.
c
c$omp barrier

      end do
c
c  Once all the nodes have been connected, we can exit.
c
c$omp single
      write ( *, * ) ' '
      write ( *, * ) '  P', my_id, ': Exiting parallel region.'
c$omp end single

c$omp end parallel

      return
      end
      subroutine find_nearest ( s, e, nv, mind, connected, d, v )

c*********************************************************************72
c
cc FIND_NEAREST finds the nearest unconnected node.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c   By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Parameters:
c
c    Input, integer S, E, the first and last nodes that
c    are to be checked.
c
c    Input, integer NV, the number of nodes.
c
c    Input, integer MIND(NV), the currently computed minimum
c    distance from node 1 to each node.
c
c    Input, logical CONNECTED(NV), is true for each connected node, whose
c    minimum distance to node 1 has been determined.
c
c    Output, integer D, the distance from node 1 to the nearest
c    unconnected node in the range S to E.
c
c    Output, integer V, the index of the nearest unconnected node
c    in the range S to E.
c
      implicit none

      integer nv

      logical connected(nv)
      integer d
      integer e
      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer mind(nv)
      integer s
      integer v

      d = i4_huge
      v = -1

      do i = s, e
        if ( .not. connected(i) .and. mind(i) .lt. d ) then
          d = mind(i)
          v = i
        end if
      end do

      return
      end
      subroutine init ( nv, ohd )

c*********************************************************************72
c
cc INIT initializes the problem data.
c
c  Discussion:
c
c    The graph uses 6 nodes, and has the following diagram and
c    distance matrix:
c
c    N0--15--N2-100--N3           0   40   15  Inf  Inf  Inf
c      \      |     /            40    0   20   10   25    6
c       \     |    /             15   20    0  100  Inf  Inf
c        40  20  10             Inf   10  100    0  Inf  Inf
c          \  |  /              Inf   25  Inf  Inf    0    8
c           \ | /               Inf    6  Inf  Inf    8    0
c            N1
c            / \
c           /   \
c          6    25
c         /       \
c        /         \
c      N5----8-----N4
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c   Sourangshu Ghosh
c
c  Parameters:
c
c    Input, integer NV, the number of nodes.
c
c    Output, integer OHD(NV,NV), the distance of the direct
c    link between nodes I and J.
c
      implicit none

      integer nv

      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer j
      integer ohd(nv,nv)

      do j = 1, nv
        do i = 1, nv
          ohd(i,j) = i4_huge
        end do
      end do

      do i = 1, nv
        ohd(i,i) = 0
      end do

      ohd(1,2) = 40
      ohd(1,3) = 15
      ohd(2,3) = 20
      ohd(2,4) = 10
      ohd(2,5) = 25
      ohd(3,4) = 100
      ohd(2,6) = 6
      ohd(5,6) = 8

      ohd(2,1) = 40
      ohd(3,1) = 15
      ohd(3,2) = 20
      ohd(4,2) = 10
      ohd(5,2) = 25
      ohd(4,3) = 100
      ohd(6,2) = 6
      ohd(6,5) = 8

      return
      end
      subroutine timestamp ( )

c*********************************************************************72
c
cc TIMESTAMP prints out the current YMDHMS date as a timestamp.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Parameters:
c
c    None
c
      implicit none

      character * ( 8 ) ampm
      integer d
      character * ( 8 ) date
      integer h
      integer m
      integer mm
      character * ( 9 ) month(12)
      integer n
      integer s
      character * ( 10 ) time
      integer y

      save month

      data month /
     &  'January  ', 'February ', 'March    ', 'April    ',
     &  'May      ', 'June     ', 'July     ', 'August   ',
     &  'September', 'October  ', 'November ', 'December ' /

      call date_and_time ( date, time )

      read ( date, '(i4,i2,i2)' ) y, m, d
      read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm

      if ( h .lt. 12 ) then
        ampm = 'AM'
      else if ( h .eq. 12 ) then
        if ( n .eq. 0 .and. s .eq. 0 ) then
          ampm = 'Noon'
        else
          ampm = 'PM'
        end if
      else
        h = h - 12
        if ( h .lt. 12 ) then
          ampm = 'PM'
        else if ( h .eq. 12 ) then
          if ( n .eq. 0 .and. s .eq. 0 ) then
            ampm = 'Midnight'
          else
            ampm = 'AM'
          end if
        end if
      end if

      write ( *,
     &  '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' )
     &  d, month(m), y, h, ':', n, ':', s, '.', mm, ampm

      return
      end
      subroutine update_mind ( s, e, nv, connected, ohd, mv, mind )

c*********************************************************************72
c
cc UPDATE_MIND updates the minimum distance vector.
c
c  Discussion:
c
c    We've just determined the minimum distance to node MV.
c
c    For each node I which is not connected yet,
c    check whether the route from node 0 to MV to I is shorter
c    than the currently known minimum distance.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    By Sourangshu
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Parameters:
c
c    Input, integer S, E, the first and last nodes that are
c    to be checked.
c
c    Input, integer NV, the number of nodes.
c
c    Input, logical CONNECTED(NV), is true for each connected node, whose
c    minimum distance to node 0 has been determined.
c
c    Input, integer OHD(NV,NV), the distance of the direct link
c    between nodes I and J.
c
c    Input, integer MV, the node whose minimum distance to node 20
c    has just been determined.
c
c    Input/output, integer MIND(NV), the currently computed
c    minimum distances from node 1 to each node.  On output, the values for
c    nodes S through E have been updated.
c
      implicit none

      integer nv

      logical connected(nv)
      integer e
      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer mind(nv)
      integer mv
      integer ohd(nv,nv)
      integer s

      do i = s, e
        if ( .not. connected(i) ) then
          if ( ohd(mv,i) .lt. i4_huge ) then
            if ( mind(mv) + ohd(mv,i) .lt. mind(i) ) then
              mind(i) = mind(mv) + ohd(mv,i)
            end if
          end if
        end if
      end do

      return
      end


      PROGRAM xavevar
C     driver for routine avevar
      INTEGER NPTS
      REAL EPS
      PARAMETER(NPTS=1000, EPS=0.1)
      INTEGER i,idum,j
      REAL ave,gasdev,shift,var,data(NPTS)
C     generate Gaussian distributed data
      idum=-5
      write(*,'(1x,t4,a,t14,a,t26,a)') 'Shift','Average','Variance'
      do 12 i=1,11
        shift=(i-1)*EPS
        do 11 j=1,NPTS
          data(j)=shift+i*gasdev(idum)
11      continue
        call avevar(data,NPTS,ave,var)
        write(*,'(1x,f6.2,2f12.2)') shift,ave,var
12    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xavevar.for


program prime_number
    implicit none
    integer, parameter :: n_min = 1, n_max = 40
    integer :: n, divisor
    logical :: is_prime

    do n = n_min, n_max
        if (n == 1) then
            print *, n, 'not prime'
        else
            is_prime = .true.
            do divisor = 2, n/2
                if (mod(n, divisor) == 0) then
                    print *, n, 'not prime'
                    is_prime = .false.
                    exit
                end if
            end do
            if (is_prime) then
                print *, n, 'prime'
            end if
        end if
    end do

end program prime_number


module integrate

  use utils, only : dp

  implicit none

contains

  pure function trapezoidal(y, x) result(r)
    ! Code taken from Fortran Wiki website:
    ! http://fortranwiki.org/fortran/show/integration
    ! written by contributor jabirali on April 22, 2016.
    !
    ! Calculates the integral of an array y with respect to x using the
    ! trapezoidal approximation. Note that the mesh spacing of x does not have
    ! to be uniform.
    real(dp), intent(in)  :: x(:)         !! Variable x
    real(dp), intent(in)  :: y(size(x))   !! Function y(x)
    real(dp)              :: r            !! Integral ∫y(x)·dx
    integer               :: n

    n = size(x)
    ! Integrate using the trapezoidal rule
    r = sum((y(1+1:n-0) + y(1+0:n-1))*(x(1+1:n-0) - x(1+0:n-1)))/2
    ! associate(n => size(x))
    !   r = sum((y(1+1:n-0) + y(1+0:n-1))*(x(1+1:n-0) - x(1+0:n-1)))/2
    ! end associate
  end function trapezoidal

end module integrate

! program main
!   use integrate
!   implicit none

!   real(dp) :: f(100), x(size(f)), a, b
!   integer  :: i, n

!   n = size(f)
!   ! integrate x^2 from 0 to 1
!   a = 0.
!   b = 1.
!   do i = 1,n
!      x(i) = (i-1) * (b-a) / (n-1) + a
!   end do
!   f(1:n) = x(1:n)**2

!   print "(f7.4)", trapezoidal(f, x)

! end program main


module class_Circle

  implicit none
  private
  public :: circle_print

  real :: pi = 3.1415926535897931D0 ! module-wide private constant

  type, public :: Circle

    real :: radius ! the radius of a circle
    real :: area   ! the area of a circle
    real :: circum ! the circumference of a circle

  end type Circle

contains

!==============================================================================
! CIRCLE_AREA calculates the area of a circle
!==============================================================================

  function circle_area(this) result(area)

    type(Circle), intent(in)  :: this ! circle instance
    real                      :: area ! the area of the circle

    ! calculate the area
    area = pi * this%radius**2

  end function circle_area

!==============================================================================
! CIRCLE_CIRCUM calculate the circumference of a circle
!==============================================================================

  function circle_circum(this) result(circum)

    type(Circle), intent(in) :: this   ! circle instance
    real                     :: circum ! the circumference

    ! calculate circumference
    circum = 2*pi*this%radius

  end function circle_circum

!==============================================================================
! CIRCLE_PRINT prints information about the circle
!==============================================================================

  subroutine circle_print(this)

    type(Circle), intent(inout) :: this ! circle instance

    ! calculate area
    this%area = circle_area(this)

    ! calculate circumference
    this%circum = circle_circum(this)

    ! print results
    write(*,'("The area is:",T30,F0.4,/,"The circumference is:",T30,F0.4)')    &
   &           this%area,this%circum

  end subroutine circle_print

end module class_Circle


program test
implicit none

integer :: j, divisions
real :: ix, I, function
real :: step
!=====================================================
! I make the total amount of infinitesimal a variable*
! so you can modify it for precision needs           *
!=====================================================
divisions = 100000.
!=====================================================
! DON'T write step = 1 / divisions, it take me hours *
! to find out the mistake. (or step is always 0, How *
! can you be unware of it?). Although you already    *
! learned the data type in Fortran. PNWU             *
!=====================================================
step = 1. / divisions
I = 0.
do j = 0, divisions
   ix = (j + 0.5) * step
   I = I + function(ix) * step
end do
print *, I
end program test

!=====================================================
! you use it when you need to! So you don't nest the *
! function in a module here                          *
!=====================================================
function function(x) result(expr)
real :: x , expr
expr = 4.0 / (1.0 + x ** 2)
end function function


!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
! TYPE  : MODULE
! NAME  : SpecialFunctions
! OBJECT: TYPE(func)
! USED  : CodeObject
! DATE  : 2018-03-27
! AUTHOR: hengyueli@gmail.com
!--------------
! Open-Source : No
!------------------
! DESCRIPTION:
!              ==========================
!               Special Funtionals-
!              ==========================
!              -------------------------
!              Legendre Polynomials :
!              p(n,x)
!              p(0,x) = 1
!              p(1,x) = x
!              k * p(k,x) = (2k-1) * x * p(k-1,x) - (k-1) * p(k-2,x) (k>=1)
!
! STANDARD:
!
!
! USING LIST:
!            :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!
!
! avalable sets:
!                  []
!
!
! avalable gets:
!
!
!
!                 --------------
!                  [fun] GetLegendreP(n,x)
!                        integer::n
!                        real*8 ::x
!                        get the value of Legendre function
!
!                  [fun] GetLegendreDxP(n,x)
!                        derivative of GetLegendreP
!
!
!                  [fun] GetZerosOfLegendre(n,i)
!                        for P(n,x), it contains n zeros. Return the i-th zero (ascending order)
! avalable Is:
!
! others:
!
!
!
!
!
!
!
!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

module SpecialFunctions
  use CodeObject
  implicit none

  type,extends(object)::func
    !
  contains
    procedure,pass::GetLegendreP
    procedure,pass::GetLegendreDxP
    procedure,pass::GetZerosOfLegendre
  endtype

  private::GetLegendreP,GetLegendreDxP

contains

  real*8 function GetLegendreP(self,n,x)
    implicit none
    class(func),intent(in)::self
    integer,intent(in)::n
    real*8,intent(in)::x
    !-------------------------------
    integer::jc
    REAL*8::pk_1,pk_2
    if (n.lt.0)then
      write(self%getprint(),*)"MathError: n<0 is not defined in GetLegendreP";stop
    elseif(n==0)then
      GetLegendreP = 1._8
    elseif(n==1)then
      GetLegendreP = x
    else
      pk_1 = x
      pk_2 = 1._8
      do jc = 2 , n
         GetLegendreP = (  (2*jc-1) * x * pk_1 - (jc-1) * pk_2 ) / jc
         pk_2 = pk_1
         pk_1 = GetLegendreP
      enddo
    endif
  endfunction

  real*8 function GetLegendreDxP(self,n,x)
    implicit none
    class(func),intent(in)::self
    integer,intent(in)::n
    real*8,intent(in)::x
    !-------------------------------
    if (n.lt.0)then
      write(self%getprint(),*)"MathError: n<0 is not defined in GetLegendreP.";stop
    elseif(n==0)then
      GetLegendreDxP = 0._8
    else
      GetLegendreDxP = n * ( x *GetLegendreP(self,n,x) - GetLegendreP(self,n-1,x) )/(x**2.0_8-1._8)
    endif
  endfunction

  function GetZerosOfLegendre(self,n,i) result(r)
    implicit none
    class(func),intent(in)::self
    integer,intent(in)::n,i
    real*8::r
    !-------------------------------
    real*8,parameter::pi=3.14159265358979323846264338327950288439_8
    real*8::Pre,temp1

    Pre   = 0.000000000000001_8
    temp1 = 800.0_8  ! random large number

    if (n.lt.1)then
      write(self%getprint(),*)"MathError: For n<1 case, there is no zero for Legendre function.";stop
    else
      if ( (i.gt.0) .and. (i.le.n) )then
        !r = DCOS( (4*I-1)*pi/(4*N+2) )
        r = -DCOS( (4*I-1)*pi/(4*N+2) )   ! re-order
        do while ( abs( r - temp1) .gt.Pre )
           temp1 = r
           r     = r - GetLegendreP(self,n,temp1)/GetLegendreDxP(self,n,temp1)
        enddo
      else
        write(self%getprint(),*)"MathError: i should in range of [1,n] for GetZerosOfLegendre"
        write(self%getprint(),*)"However,now (i,n)=(",i,",",n,")";stop
      endif
    endif
  endfunction

endmodule


      subroutine resid_alphaopl(n_K,n_alpha,np1_K,np1_alpha,x,Nx,gma,gmb
     &,ht,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 gma
      real*8 gmb
      real*8 ht
      real*8 myzero
      real*8 n_K(Nx)
      real*8 n_alpha(Nx)
      real*8 np1_K(Nx)
      real*8 np1_alpha(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = (-0.1D1 * n_alpha(i) + np1_alpha(i)) / ht + 0.500000000000000
     #0D0 * gma * np1_alpha(i) ** gmb * np1_K(i) + 0.5000000000000000D0
     #* gma * n_alpha(i) ** gmb * n_K(i)
      res = res + qb**2
      end do
      endif
      do i=2, Nx-1, 1
      qb = (-0.1D1 * n_alpha(i) + np1_alpha(i)) / ht + 0.500000000000000
     #0D0 * gma * np1_alpha(i) ** gmb * np1_K(i) + 0.5000000000000000D0
     #* gma * n_alpha(i) ** gmb * n_K(i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_alpha(i) + myzero * x(i) - 0.1D1
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


subroutine coarse_to_fine_vface(e_2h, nx, ny, e_h)
use kind_parameters
implicit none

integer, intent(in):: nx, ny
real(kind=dp), intent(in), dimension(nx,ny):: e_2h
real(kind=dp), intent(out), dimension(2*nx-2,2*ny-1):: e_h
integer:: i, j

!write(*,*) nx, ny

! Apply linear interpolation to get values from coarse to fine grid
! Input
! e_2h   Variable in coarse grid
! hx, hy     grid spacing
!
! Output
! e_h     Variable in fine grid

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012

do j = 1,ny-1

    do i = 2,nx-2

        e_h(2*i-1,2*j-1) = (1.0/4.0)*(3.0*e_2h(i,j) + e_2h(i+1,j))
        e_h(2*i,2*j) = (1.0/8.0)*(e_2h(i,j+1) + 3.0*e_2h(i+1,j+1) + e_2h(i,j) +3.0*e_2h(i+1,j))
        e_h(2*i-1, 2*j) = (1.0/8.0)*(3.0*e_2h(i,j+1) + e_2h(i+1,j+1) + 3.0*e_2h(i,j) + e_2h(i+1,j))
        e_h(2*i,2*j-1) = (1.0/4.0)*(e_2h(i,j) + 3.0*e_2h(i+1,j))

    end do

end do

i = 1

do j = 1,ny-1

	e_h(2*i,2*j-1) = (1.0/2.0)*(e_2h(i,j) + e_2h(i+1,j))
    e_h(2*i,2*j) = (1.0/4.0)*(e_2h(i,j) + e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))

end do

i = nx-1

do j = 1,ny-1

    e_h(2*i-1,2*j-1) = (1.0/2.0)*(e_2h(i,j) + e_2h(i+1,j))
    e_h(2*i-1,2*j) = (1.0/4.0)*(e_2h(i,j) + e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))

end do

end subroutine


subroutine residuo(a, u, lambda, r)

implicit none

real, dimension(:,:), intent(in) :: a
real, dimension(:), intent(in) :: u
real, intent(out) :: lambda

real, dimension(:), intent(inout) :: r

integer :: n, i

n = size(a(1,:))

r = matmul(a,u) - lambda*u

print*,
print*, 'Residuo: ', sqrt(dot_product(r,r))
print*,

end subroutine


C++ *********************************************************************
C Contains:
C  POLAR_DEG
C  DOUBLE_POLAR_DEG
C  DOUBLE_LOGPOLAR_DEG
C
C
C-- *********************************************************************
	SUBROUTINE POLAR_DEG(X,Y,RAD,ANGLE,OX,OY)
C *********************************************************************
C  Finds position angle given X, Y, and centre.
C  Position angle in degrees measured from positive X axis through
C  positive Y axis
C
C *********************************************************************
	REAL*4 X,Y,RAD,ANGLE,OX,OY,A,B,PI
        PI=ACOS(-1.)

	A=X-OX
	B=Y-OY
	RAD=SQRT(A*A+B*B)

	IF(RAD.LT.0.01) THEN
	 WRITE(6,100)
100	 FORMAT(' ANGLE CALLED AT CENTRE POINT')
	 ANGLE=0.0D0
	 RETURN
	ENDIF

	IF(B.GT.0.)THEN
	  ANGLE=ACOS(A/RAD)*180./PI
	ELSEIF(B.LT.0)THEN
	  ANGLE=ACOS(-A/RAD)*180./PI+180.
	ELSEIF(B.EQ.0)THEN
	  IF(A.GT.0)ANGLE=0.0D0
	  IF(A.LT.0)ANGLE=180.
	ENDIF

	RETURN
	END
C*********************************************************************
	SUBROUTINE DOUBLE_POLAR_DEG(X,Y,RAD,ANGLE,OX,OY)
C*********************************************************************
C Same as POLAR_DEG but in double precision
C
C Finds position angle given X, Y, and centre.
C Position angle in degrees measured from positive X axis through
C positive Y axis
C*********************************************************************
	REAL*8 X,Y,RAD,ANGLE,OX,OY,A,B,PI
        PI=ACOS(-1.)

	A=X-OX
	B=Y-OY
	RAD=SQRT(A*A+B*B)

	IF(RAD.LT.0.01) THEN
	 WRITE(6,100)
100	 FORMAT(' ANGLE CALLED AT CENTRE POINT')
	 ANGLE=0.0D0
	 RETURN
	ENDIF

	IF(B.GT.0.)THEN
	  ANGLE=ACOS(A/RAD)*180./PI
	ELSEIF(B.LT.0)THEN
	  ANGLE=ACOS(-A/RAD)*180./PI+180.
	ELSEIF(B.EQ.0)THEN
	  IF(A.GT.0)ANGLE=0.0D0
	  IF(A.LT.0)ANGLE=180.
	ENDIF

	RETURN
	END
C*********************************************************************
	SUBROUTINE DOUBLE_LOGPOLAR_DEG(X,Y,LOGRAD,ANGLE,OX,OY)
C*********************************************************************
C Same as DOUBLE_POLAR_DEG but log for x
C
C Finds position angle given X, Y, and centre.
C Position angle in degrees measured from positive X axis through
C positive Y axis
C*********************************************************************
	REAL*8 X,Y,RAD,LOGRAD,ANGLE,OX,OY,A,B,PI
        PI=ACOS(-1.)

	A=X-OX
	B=Y-OY
	RAD=SQRT(A*A+B*B)
        IF(RAD.EQ.0.)THEN
           LOGRAD = -1000.
        ELSE
           LOGRAD=LOG(RAD)
        ENDIF

	IF(RAD.LT.0.01) THEN
	 WRITE(6,100)
100	 FORMAT(' ANGLE CALLED AT CENTRE POINT')
	 ANGLE=0.0D0
	 RETURN
	ENDIF

	IF(B.GT.0.)THEN
	  ANGLE=ACOS(A/RAD)*180./PI
	ELSEIF(B.LT.0)THEN
	  ANGLE=ACOS(-A/RAD)*180./PI+180.
	ELSEIF(B.EQ.0)THEN
	  IF(A.GT.0)ANGLE=0.0D0
	  IF(A.LT.0)ANGLE=180.
	ENDIF

	RETURN
	END


!c****************************************************************

	real*8 function dot(r_v,r_w)

!c****************************************************************
!c**
!c**	FILE NAME: dot.f
!c**
!c**     DATE WRITTEN:7/15/90
!c**
!c**     PROGRAMMER:Scott Hensley
!c**
!c** 	FUNCTIONAL DESCRIPTION: This routine computes the dot product of
!c**     two 3 vectors as a function.
!c**
!c**     ROUTINES CALLED:none
!c**
!c**     NOTES: none
!c**
!c**     UPDATE LOG:
!c**
!c*****************************************************************

       	implicit none

!c	INPUT VARIABLES:
        real*8 r_v(3),r_w(3)          !3x1 vectors

!c   	OUTPUT VARIABLES: dot is the output

!c	LOCAL VARIABLES:none

!c	DATA STATEMENTS:none

!C	FUNCTION STATEMENTS:none

!c  	PROCESSING STEPS:

!c   compute dot product of two 3-vectors

	dot = r_v(1)*r_w(1) + r_v(2)*r_w(2) + r_v(3)*r_w(3)

	end


MODULE polar_tools
IMPLICIT NONE

TYPE :: polar
  REAL :: mag
  REAL :: angle
CONTAINS
  PROCEDURE, PASS :: mult
  PROCEDURE, PASS :: div
END TYPE polar

CONTAINS
  TYPE (polar) FUNCTION mult(this, p)
  IMPLICIT NONE
  CLASS (polar), INTENT(IN) :: this, p
  mult = polar(this%mag * p%mag, this%angle + p%angle)
  END FUNCTION mult

  TYPE (polar) FUNCTION div(this, p)
  IMPLICIT NONE
  CLASS (polar), INTENT(IN) :: this, p
  div = polar((this%mag / p%mag), this%angle - p%angle)
  END FUNCTION div
END MODULE polar_tools

PROGRAM bound_polar
USE polar_tools
IMPLICIT NONE
TYPE (polar) :: p1, p2
p1 = polar(5., 3.)
p2 = polar(0.25, 2.)
WRITE(*, *) p1%mult(p2)
WRITE(*, *) p1%div(p2)
WRITE(*, *) p2%div(p1)
WRITE(*, *) p1%div(p1)
END PROGRAM bound_polar


MODULE generic_maxval
!
!  Purpose:
!    To produce a generic procedure maxval that returns the
!    maximum value in an array and optionally the location
!    of that maximum value for the following input data types:
!    integer, single precision real, double precision real,
!    single precision complex, and double precision complex.
!    Complex comparisons are done on the absolute values of
!    values in the input array.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     12/15/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare parameters:
INTEGER, PARAMETER :: SGL = SELECTED_REAL_KIND(p=6)
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)

! Declare generic interface.
INTERFACE maxval
   MODULE PROCEDURE maxval_i
   MODULE PROCEDURE maxval_r
   MODULE PROCEDURE maxval_d
   MODULE PROCEDURE maxval_c
   MODULE PROCEDURE maxval_dc
END INTERFACE

CONTAINS
   SUBROUTINE maxval_i ( array, nvals, value_max, pos_maxval )
   IMPLICIT NONE

   ! List of calling arguments:
   INTEGER, INTENT(IN) :: nvals                     ! # vals.
   INTEGER, INTENT(IN), DIMENSION(nvals) :: array   ! Input data.
   INTEGER, INTENT(OUT) :: value_max                ! Max value.
   INTEGER, INTENT(OUT), OPTIONAL :: pos_maxval     ! Position

   !  List of local variables:
   INTEGER :: i                            ! Index
   INTEGER :: pos_max                      ! Pos of max value

   ! Initialize the values to first value in array.
   value_max = array(1)
   pos_max = 1

   ! Find the extreme values in array(2) through array(nvals).
   DO i = 2, nvals
      IF ( array(i) > value_max ) THEN
         value_max = array(i)
         pos_max = i
      END IF
   END DO

   ! Report the results
   IF ( PRESENT(pos_maxval) ) THEN
      pos_maxval = pos_max
   END IF

   END SUBROUTINE maxval_i

   SUBROUTINE maxval_r ( array, nvals, value_max, pos_maxval )
   IMPLICIT NONE

   ! List of calling arguments:
   INTEGER, INTENT(IN) :: nvals
   REAL(KIND=SGL), INTENT(IN), DIMENSION(nvals) :: array
   REAL(KIND=SGL), INTENT(OUT) :: value_max
   INTEGER, INTENT(OUT), OPTIONAL :: pos_maxval

   !  List of local variables:
   INTEGER :: i                            ! Index
   INTEGER :: pos_max                      ! Pos of max value

   ! Initialize the values to first value in array.
   value_max = array(1)
   pos_max = 1

   ! Find the extreme values in array(2) through array(nvals).
   DO i = 2, nvals
      IF ( array(i) > value_max ) THEN
         value_max = array(i)
         pos_max = i
      END IF
   END DO

   ! Report the results
   IF ( PRESENT(pos_maxval) ) THEN
      pos_maxval = pos_max
   END IF

   END SUBROUTINE maxval_r

   SUBROUTINE maxval_d ( array, nvals, value_max, pos_maxval )
   IMPLICIT NONE

   ! List of calling arguments:
   INTEGER, INTENT(IN) :: nvals
   REAL(KIND=DBL), INTENT(IN), DIMENSION(nvals) :: array
   REAL(KIND=DBL), INTENT(OUT) :: value_max
   INTEGER, INTENT(OUT), OPTIONAL :: pos_maxval

   !  List of local variables:
   INTEGER :: i                            ! Index
   INTEGER :: pos_max                      ! Pos of max value

   ! Initialize the values to first value in array.
   value_max = array(1)
   pos_max = 1

   ! Find the extreme values in array(2) through array(nvals).
   DO i = 2, nvals
      IF ( array(i) > value_max ) THEN
         value_max = array(i)
         pos_max = i
      END IF
   END DO

   ! Report the results
   IF ( PRESENT(pos_maxval) ) THEN
      pos_maxval = pos_max
   END IF

   END SUBROUTINE maxval_d

   SUBROUTINE maxval_c ( array, nvals, value_max, pos_maxval )
   IMPLICIT NONE

   ! List of calling arguments:
   INTEGER, INTENT(IN) :: nvals
   COMPLEX(KIND=SGL), INTENT(IN), DIMENSION(nvals) :: array
   REAL(KIND=SGL), INTENT(OUT) :: value_max
   INTEGER, INTENT(OUT), OPTIONAL :: pos_maxval

   !  List of local variables:
   INTEGER :: i                            ! Index
   INTEGER :: pos_max                      ! Pos of max value

   ! Initialize the values to first value in array.
   value_max = ABS(array(1))
   pos_max = 1

   ! Find the extreme values in array(2) through array(nvals).
   DO i = 2, nvals
      IF ( ABS(array(i)) > value_max ) THEN
         value_max = ABS(array(i))
         pos_max = i
      END IF
   END DO

   ! Report the results
   IF ( PRESENT(pos_maxval) ) THEN
      pos_maxval = pos_max
   END IF

   END SUBROUTINE maxval_c

   SUBROUTINE maxval_dc ( array, nvals, value_max, pos_maxval )
   IMPLICIT NONE

   ! List of calling arguments:
   INTEGER, INTENT(IN) :: nvals
   COMPLEX(KIND=DBL), INTENT(IN), DIMENSION(nvals) :: array
   REAL(KIND=DBL), INTENT(OUT) :: value_max
   INTEGER, INTENT(OUT), OPTIONAL :: pos_maxval

   !  List of local variables:
   INTEGER :: i                            ! Index
   INTEGER :: pos_max                      ! Pos of max value

   ! Initialize the values to first value in array.
   value_max = ABS(array(1))
   pos_max = 1

   ! Find the extreme values in array(2) through array(nvals).
   DO i = 2, nvals
      IF ( ABS(array(i)) > value_max ) THEN
         value_max = ABS(array(i))
         pos_max = i
      END IF
   END DO

   ! Report the results
   IF ( PRESENT(pos_maxval) ) THEN
      pos_maxval = pos_max
   END IF

   END SUBROUTINE maxval_dc

END MODULE generic_maxval


!-----------------------------------------------!
!     A  df/dx ->  Thomas algorithm             !
!-----------------------------------------------!
function addx(i,j)
use variables
use constants
real :: tempout
 if (Cscheme.eq.CentralDifference) then
     tempout=0.5/dx
 elseif (Cscheme.eq.ForwardDifference) then
     tempout=1.0/dx
 else
     tempout=0.0
 endif
 addx=tempout
return
end function addx

!-----------------------------------------------!
!     B  df/dx ->  Thomas algorithm             !
!-----------------------------------------------!
function bddx(i,j)
use variables
use constants
real :: tempout
 if (Cscheme.eq.CentralDifference) then
     tempout=0.0
 elseif (Cscheme.eq.ForwardDifference) then
     tempout=-1.0/dx
 elseif (Cscheme.eq.BackwardDifference) then
     tempout=1.0/dx
 else
     tempout=0.0
 endif
 bddx=tempout
return
end function bddx

!-----------------------------------------------!
!     C  df/dx ->  Thomas algorithm             !
!-----------------------------------------------!
function cddx(i,j)
use variables
use constants
real :: tempout
 if (Cscheme.eq.CentralDifference) then
     tempout=-0.5/dx
 elseif (Cscheme.eq.ForwardDifference) then
     tempout=0.0
 elseif (Cscheme.eq.BackwardDifference) then
     tempout=-1.0/dx
 else
     tempout=0.0
 endif
 cddx=tempout
return
end function cddx

!-----------------------------------------------!
!     A  df/dy ->  Thomas algorithm             !
!-----------------------------------------------!
function addy(i,j)
use variables
use constants
real :: tempout
 if (Cscheme.eq.CentralDifference) then
     tempout=0.5/dy
 elseif (Cscheme.eq.ForwardDifference) then
     tempout=1.0/dy
 else
     tempout=0.0
 endif
 addy=tempout
return
end function addy

!-----------------------------------------------!
!     B  df/dy ->  Thomas algorithm             !
!-----------------------------------------------!
function bddy(i,j)
use variables
use constants
real :: tempout
 if (Cscheme.eq.CentralDifference) then
     tempout=0.0
 elseif (Cscheme.eq.ForwardDifference) then
     tempout=-1.0/dy
 elseif (Cscheme.eq.BackwardDifference) then
     tempout=1.0/dy
 else
     tempout=0.0
 endif
 bddy=tempout
return
end function bddy

!-----------------------------------------------!
!     C  df/dy ->  Thomas algorithm             !
!-----------------------------------------------!
function cddy(i,j)
use variables
use constants
real :: tempout
 if (Cscheme.eq.CentralDifference) then
     tempout=-0.5/dy
 elseif (Cscheme.eq.ForwardDifference) then
     tempout=0.0
 elseif (Cscheme.eq.BackwardDifference) then
     tempout=-1.0/dy
 else
     tempout=0.0
 endif
 cddy=tempout
return
end function cddy
!-----------------------------------------------!
!     A  d2f/dx2 ->  Thomas algorithm           !
!-----------------------------------------------!
function ad2dx2(i,j)
use variables
use constants
real :: tempout
 tempout=1.0/(dx*dx)
 ad2dx2=tempout
return
end function ad2dx2

!-----------------------------------------------!
!     B  d2f/dx2 ->  Thomas algorithm           !
!-----------------------------------------------!
function bd2dx2(i,j)
use variables
use constants
real :: tempout
 tempout=-2.0/(dx*dx)
 bd2dx2=tempout
return
end function bd2dx2

!-----------------------------------------------!
!    C  d2f/dx2 ->  Thomas algorithm            !
!-----------------------------------------------!
function cd2dx2(i,j)
use variables
use constants
real :: tempout
 tempout=1.0/(dx*dx)
 cd2dx2=tempout
return
end function cd2dx2

!-----------------------------------------------!
!     A  d2f/dy2 ->  Thomas algorithm           !
!-----------------------------------------------!
function ad2dy2(i,j)
use variables
use constants
real :: tempout
 tempout=1.0/(dy*dy)
 ad2dy2=tempout
return
end function ad2dy2

!-----------------------------------------------!
!     B  d2f/dy2 ->  Thomas algorithm           !
!-----------------------------------------------!
function bd2dy2(i,j)
use variables
use constants
real :: tempout
 tempout=-2.0/(dy*dy)
 bd2dy2=tempout
return
end function bd2dy2

!-----------------------------------------------!
!    C  d2f/dy2 ->  Thomas algorithm            !
!-----------------------------------------------!
function cd2dy2(i,j)
use variables
use constants
real :: tempout
 tempout=1.0/(dy*dy)
 cd2dy2=tempout
return
end function cd2dy2

!-----------------------------------------------!
!    du/dx in i,j                               !
!-----------------------------------------------!
function dudx(i,j,sloi)
   use variables
   use constants
   integer :: i
   integer :: j
   integer :: sloi
   real :: tempout=0.0
   if (sloi.eq.0) then
      if (Cscheme.eq.CentralDifference) then
          tempout=(u(i+1,j)-u(i-1,j))/(2.0*dx)
      elseif (Cscheme.eq.ForwardDifference) then
          tempout=(u(i+1,j)-u(i,j))/dx
      elseif (Cscheme.eq.BackwardDifference) then
         tempout=(u(i,j)-u(i-1,j))/dx
      else
         tempout=0.0
      endif
   elseif (sloi.eq.1) then
      if (Cscheme.eq.CentralDifference) then
          tempout=(Uo12(i+1,j)-Uo12(i-1,j))/(2.0*dx)
      elseif (Cscheme.eq.ForwardDifference) then
          tempout=(Uo12(i+1,j)-Uo12(i,j))/dx
      elseif (Cscheme.eq.BackwardDifference) then
          tempout=(Uo12(i,j)-Uo12(i-1,j))/dx
      else
          tempout=0.0
      endif
   endif

   dudx=tempout
   return
end function dudx

!-----------------------------------------------!
!    du/dy in i,j                               !
!-----------------------------------------------!
function dudy(i,j,sloi)
   use variables
   use constants
   integer :: i
   integer :: j
   integer :: sloi
   real :: tempout=0.0
   if (sloi.eq.0) then
      if (Cscheme.eq.CentralDifference) then
          tempout=(u(i,j+1)-u(i,j-1))/(2.0*dy)
      elseif (Cscheme.eq.ForwardDifference) then
          tempout=(u(i,j+1)-u(i,j))/dy
      elseif (Cscheme.eq.BackwardDifference) then
          tempout=(u(i,j)-u(i,j-1))/dy
      else
          tempout=0.0
      endif
   elseif (sloi.eq.1) then
      if (Cscheme.eq.CentralDifference) then
          tempout=(Uo12(i,j+1)-Uo12(i,j-1))/(2.0*dy)
      elseif (Cscheme.eq.ForwardDifference) then
          tempout=(Uo12(i,j+1)-Uo12(i,j))/dy
      elseif (Cscheme.eq.BackwardDifference) then
         tempout=(Uo12(i,j)-Uo12(i,j-1))/dy
      else
         tempout=0.0
      endif
   endif

   dudy=tempout
   return
end function dudy

!-----------------------------------------------!
!    dv/dx in i,j                               !
!-----------------------------------------------!
function dvdx(i,j,sloi)
   use variables
   use constants
   integer :: i
   integer :: j
   integer :: sloi
   real :: tempout=0.0
   if (sloi.eq.0) then
      if (Cscheme.eq.CentralDifference) then
          tempout=(v(i+1,j)-v(i-1,j))/(2.0*dx)
      elseif (Cscheme.eq.ForwardDifference) then
          tempout=(v(i+1,j)-v(i,j))/dx
      elseif (Cscheme.eq.BackwardDifference) then
         tempout=(v(i,j)-v(i-1,j))/dx
      else
         tempout=0.0
      endif
   elseif (sloi.eq.1) then
      if (Cscheme.eq.CentralDifference) then
          tempout=(Vo12(i+1,j)-Vo12(i-1,j))/(2.0*dx)
      elseif (Cscheme.eq.ForwardDifference) then
          tempout=(Vo12(i+1,j)-Vo12(i,j))/dx
      elseif (Cscheme.eq.BackwardDifference) then
         tempout=(Vo12(i,j)-Vo12(i-1,j))/dx
      else
         tempout=0.0
      endif
   endif

   dvdx=tempout
   return
end function dvdx

!-----------------------------------------------!
!    dv/dy in i,j                               !
!-----------------------------------------------!
function dvdy(i,j,sloi)
   use variables
   use constants
   integer :: i
   integer :: j
   integer :: sloi
   real :: tempout=0.0
   if (sloi.eq.0) then
      if (Cscheme.eq.CentralDifference) then
          tempout=(v(i,j+1)-v(i,j-1))/(2.0*dy)
      elseif (Cscheme.eq.ForwardDifference) then
          tempout=(v(i,j+1)-v(i,j))/dy
      elseif (Cscheme.eq.BackwardDifference) then
         tempout=(v(i,j)-v(i,j-1))/dy
      else
         tempout=0.0
      endif
   elseif (sloi.eq.1) then
      if (Cscheme.eq.CentralDifference) then
          tempout=(Vo12(i,j+1)-Vo12(i,j-1))/(2.0*dy)
      elseif (Cscheme.eq.ForwardDifference) then
          tempout=(Vo12(i,j+1)-Vo12(i,j))/dy
      elseif (Cscheme.eq.BackwardDifference) then
         tempout=(Vo12(i,j)-Vo12(i,j-1))/dy
      else
         tempout=0.0
      endif
   endif

   dvdy=tempout
   return
end function dvdy

!-----------------------------------------------!
!    d2u/dx2 in i,j                             !
!-----------------------------------------------!
function d2udx2(i,j,sloi)
   use variables
   use constants
   integer :: i
   integer :: j
   integer :: sloi
   real :: tempout=0.0
   if (sloi.eq.0) then
       tempout = (u(i+1,j)-2.0*u(i,j)+u(i-1,j))/(dx*dx)
   elseif (sloi.eq.1) then
       tempout = (Uo12(i+1,j)-2.0*Uo12(i,j)+Uo12(i-1,j))/(dx*dx)
   endif
   d2udx2 = tempout
   return
end function d2udx2

!-----------------------------------------------!
!    d2v/dx2 in i,j                             !
!-----------------------------------------------!
function d2vdx2(i,j,sloi)
   use variables
   use constants
   integer :: i
   integer :: j
   real :: tempout=0.0
   integer :: sloi
   if (sloi.eq.0) then
       tempout = (v(i+1,j)-2.0*v(i,j)+v(i-1,j))/(dx*dx)
   elseif (sloi.eq.1) then
       tempout = (Vo12(i+1,j)-2.0*Vo12(i,j)+Vo12(i-1,j))/(dx*dx)
   endif
   d2vdx2 = tempout
   return
end function d2vdx2

!-----------------------------------------------!
!    d2u/dy2 in i,j                             !
!-----------------------------------------------!
function d2udy2(i,j,sloi)
   use variables
   use constants
   integer :: i
   integer :: j
   real :: tempout
   integer :: sloi
   if (sloi.eq.0) then
       tempout = (u(i,j+1)-2.0*u(i,j)+u(i,j-1))/(dy*dy)
   elseif (sloi.eq.1) then
       tempout = (Uo12(i,j+1)-2.0*Uo12(i,j)+Uo12(i,j-1))/(dy*dy)
   endif
   d2udy2 = tempout
   return
end function d2udy2

!-----------------------------------------------!
!    d2v/dy2 in i,j                             !
!-----------------------------------------------!
function d2vdy2(i,j,sloi)
   use variables
   use constants
   integer :: i
   integer :: j
   real :: tempout
   integer :: sloi
   if (sloi.eq.0) then
       tempout = (v(i,j+1)-2.0*v(i,j)+v(i,j-1))/(dy*dy)
   elseif (sloi.eq.1) then
       tempout = (Vo12(i,j+1)-2.0*Vo12(i,j)+Vo12(i,j-1))/(dy*dy)
   endif
   d2vdy2 = tempout
   return
end function d2vdy2

function S1(Ax)
   real :: Ax
   if (Ax.ge.0.0) then
       S1=0.0
   else
       S1=Ax
   endif
   return
end function S1
function S2(Ax)
   real :: Ax
   if (Ax.ge.0.0) then
       S2=Ax
   else
       S2=0.0
   endif
   return
end function S2
function S3(Bx)
   real :: Bx
   if (Bx.ge.0.0) then
       S3=0.0
   else
       S3=Bx
   endif
   return
end function S3
function S4(Bx)
   real :: Bx
   if (Bx.ge.0.0) then
       S4=Bx
   else
       S4=0.0
   endif
   return
end function S4


C$Procedure      VDIST ( Vector distance )

      DOUBLE PRECISION FUNCTION  VDIST ( V1, V2 )

C$ Abstract
C
C     Return the distance between two three-dimensional vectors.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION      V1 ( 3 )
      DOUBLE PRECISION      V2 ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C
C     V1,
C     V2         I   Two 3-vectors.
C
C     The function returns the distance between V1 and V2.
C
C$ Detailed_Input
C
C     V1,
C     V2         are two vectors in three-dimensional space, the
C                distance between which is desired.
C
C$ Detailed_Output
C
C     The function returns the distance between V1 and V2.  This is
C     defined as
C
C              ||  V1 - V2  ||,
C
C     where || x || indicates the Euclidean norm of the vector x.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This function is simply shorthand for the code
C
C        CALL VSUB ( V1, V2, DIFF )
C
C        DIST = VNORM ( DIFF )
C
C     Using this function saves you the annoyance of declaring local
C     storage for the difference vector DIFF.
C
C
C     The Euclidean norm of a three-dimensional vector (x, y, z) is
C     defined as
C
C                                     1/2
C             2        2        2
C        (   x    +   y    +   z    ).
C
C
C     This number is the distance of the point (x, y, z) from the
C     origin.  If A and B are two vectors whose components are
C
C        ( A(1), A(2), A(3) )    and    ( B(1), B(2), B(3) ),
C
C     then the distance between A and B is the norm of the difference
C     A - B, which has components
C
C
C        (  A(1) - B(1),  A(2) - B(2),  A(3) - B(3)  ).
C
C
C     A related routine is VDISTG, which computes the distance between
C     two vectors of general dimension.
C
C$ Examples
C
C     1)  If V1 is
C
C            ( 2.0D0,  3.0D0,  0.D0 )
C
C         and V2 is
C
C            ( 5.0D0,  7.0D0,  12.D0 ),
C
C         VDIST (V1, V2) will be 13.D0.
C
C
C     2)  If VGR2 and NEP are states of the Voyager 2 spacecraft and
C         Neptune with respect to some common center at a given time
C         ET, then
C
C            VDIST ( VGR2, NEP )
C
C         yields the distance between the spacecraft and Neptune at time
C         ET.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 08-JUL-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     distance between 3-dimensional vectors
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VNORM

C
C     Local variables
C
      DOUBLE PRECISION      DIFF ( 3 )

C
C     No surprises.
C
      CALL VSUB ( V1, V2, DIFF )

      VDIST = VNORM (DIFF)

      RETURN
      END


program matrixsederhana
    implicit none

    integer :: i,j
    real :: a(3,2)

    ! Defenisikan nilai dalam matrix
    a(1,1) = 1
    a(1,2) = 2
    a(2,1) = 4
    a(2,2) = 5
    a(3,1) = 7
    a(3,2) = 8

    ! Tampilkan matrix
    do i = 1,3
        do j = 1,2
            write(*,*) a(i,j)
        end do
    end do

    write(*,*)

    ! Cara lain menampilkan matrix
    do i = 1,3
        write(*,*) (a(i,j), j=1,2)
    end do

    write(*,*)

    ! Menjumlahkan matrix dengan suatu nilai
    do i = 1,3
        write(*,*) (a(i,j) + 3, j=1,2)
    end do

    write(*,*)

    ! Mengurangkan matrix dengan suatu nilai
    do i = 1,3
        write(*,*) (a(i,j) - 2, j=1,2)
    end do

    write(*,*)

    ! Menjumlahkan matrix dengan matrix
    do i = 1,3
        write(*,*) (a(i,j) + a(i,j), j=1,2)
    end do

    write(*,*)

    ! Mengurangkan matrix dengan matrix
    do i = 1,3
        write(*,*) (a(i,j) - a(i,j), j=1,2)
    end do

end program matrixsederhana


PROGRAM solve_linear
    USE PRECISION, ONLY: wp

    IMPLICIT NONE

    REAL(wp), ALLOCATABLE :: a(:,:), b(:,:), y(:)
    REAL(wp), ALLOCATABLE :: ipvt(:)
    REAL(wp)              :: relerr, dnrm2
    REAL(wp)              :: t_start, t_end
    REAL(wp), PARAMETER   :: one = 1.0_wp, zero = 0.0_wp

    INTEGER               :: i, j
    INTEGER               :: info
    INTEGER, PARAMETER    :: n = 4000

    CHARACTER(80)         :: msg

    ! allocate array
    ALLOCATE(a(n,n), b(n,1), y(n), ipvt(n), STAT=info, ERRMSG=msg)

    IF ( info /= 0 ) THEN
        WRITE(*, '("Error in array allocation: ", A)') msg
        STOP
    END IF

    ! fill matrices with uniformed random numbers
    CALL RANDOM_NUMBER(a)
    CALL RANDOM_NUMBER(b)
    CALL RANDOM_NUMBER(y)

    ! B = A*Y (BLAS2)
    CALL DGEMV('N', n, n, one, a, n, y, 1, zero, b, 1)

    ! start measurement
    CALL CPU_TIME(t_start)

    ! LU factorization
    CALL DGETRF(n, n, a, n ,ipvt, info)

    ! DGETRF return value
    IF ( info < 0 ) THEN
        WRITE(*, '("Argument", i3, "has an illegal value")') info
    ELSE IF ( info > 0 ) THEN
        WRITE(*, '("Zero diagonal element at", i3, "Division by zero will occur")') info
    END IF

    ! solve linear system
    CALL DGETRS('N', n, 1, a, n, ipvt, b, n, info)

    ! DGETRF return value
    IF ( info < 0 ) THEN
        WRITE(*, '("Argument", i3, "has an illegal value")') info
    END IF

    CALL CPU_TIME(t_end)

    ! difference between lapack solution and initial generator
    b(:,1) = b(:,1) - y
    relerr = DNRM2(n, b, 1)/DNRM2(n, y, 1)

    WRITE(*,'("Relative error: ", F15.8)') relerr
    WRITE(*,'("Elapsed time", F15.8)') t_end - t_start

    ! free memeory
    DEALLOCATE(a, b, y, ipvt, STAT=info )

    IF (info /= 0 ) THEN
        WRITE(*, '("Deallocation failed")')
    END IF
END PROGRAM


MODULE sort

CONTAINS

SUBROUTINE Shell_Sort(a)

  IMPLICIT NONE
  INTEGER :: i, j, increment
  REAL :: temp
  REAL, INTENT(in out) :: a(:)

  increment = SIZE(a) / 2
  DO WHILE (increment > 0)
      DO i = increment+1, SIZE(a)
         j = i
         temp = a(i)
         DO WHILE (j >= increment+1 .AND. a(j-increment) > temp)
            a(j) = a(j-increment)
            j = j - increment
         END DO
         a(j) = temp
      END DO
      IF (increment == 2) THEN
   	  increment = 1
      ELSE
         increment = increment * 5 / 11
      END IF
  END DO

END SUBROUTINE Shell_Sort

END MODULE sort

PROGRAM Shellsort

USE sort

  IMPLICIT NONE
  REAL :: array(1000)

  CALL RANDOM_SEED
  CALL RANDOM_NUMBER(array)

  WRITE (*,*) "Unsorted array"
  WRITE (*,*) array
  WRITE (*,*)
  CALL Shell_Sort(array)
  WRITE (*,*) "Sorted array"
  WRITE (*,*) array

END PROGRAM Shellsort


      SUBROUTINE F77WAVE(up, u, um, lambda, a, b, c, nx, ny,
     > dt, dx, dy)
      IMPLICIT LOGICAL (A-Z)
      INTEGER nx, ny
      REAL*8 up(nx,ny), u(nx,ny), um(nx,ny), lambda(nx,ny)
      REAL*8 a, b, c
      REAL*8 dt, dx, dy
      INTEGER i,j

      DO 20 j = 2, ny-1
         DO 10 i = 2, nx-1
            up(i,j) = a*2*u(i,j) - b*um(i,j) +
     > c*(dt*dt)/(dx*dx)* ( 0.5*(lambda(i+1,j )+lambda(i ,j ))*(u(i+1,j
     &)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i-1,j ))*(u(i ,j )-u(i-1,j
     &))) +(dt*dt)/(dy*dy)* ( 0.5*(lambda(i ,j+1)+lambda(i ,j ))*(u(i ,j
     &+1)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i ,j-1))*(u(i ,j )-u(i ,j
     &-1)))
 10   CONTINUE
 20   CONTINUE

C Boundary points:

      i=1
      DO 30 j = 2, ny-1
         up(i,j) = a*2*u(i,j) - b*um(i,j) +
     > c*(dt*dt)/(dx*dx)* ( 0.5*(lambda(i+1,j )+lambda(i ,j ))*(u(i+1,j
     &)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i+1,j ))*(u(i ,j )-u(i+1,j
     &))) +(dt*dt)/(dy*dy)* ( 0.5*(lambda(i ,j+1)+lambda(i ,j ))*(u(i ,j
     &+1)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i ,j-1))*(u(i ,j )-u(i ,j
     &-1)))
 30   CONTINUE

      i=nx
      DO 40 j = 2, ny-1
         up(i,j) = a*2*u(i,j) - b*um(i,j) +
     > c*(dt*dt)/(dx*dx)* ( 0.5*(lambda(i-1,j )+lambda(i ,j ))*(u(i-1,j
     &)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i-1,j ))*(u(i ,j )-u(i-1,j
     &))) +(dt*dt)/(dy*dy)* ( 0.5*(lambda(i ,j+1)+lambda(i ,j ))*(u(i ,j
     &+1)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i ,j-1))*(u(i ,j )-u(i ,j
     &-1)))
 40   CONTINUE

      j=1
      DO 50 i = 2, nx-1
         up(i,j) = a*2*u(i,j) - b*um(i,j) +
     > c*(dt*dt)/(dx*dx)* ( 0.5*(lambda(i+1,j )+lambda(i ,j ))*(u(i+1,j
     &)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i-1,j ))*(u(i ,j )-u(i-1,j
     &))) +(dt*dt)/(dy*dy)* ( 0.5*(lambda(i ,j+1)+lambda(i ,j ))*(u(i ,j
     &+1)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i ,j+1))*(u(i ,j )-u(i ,j
     &+1)))
 50   CONTINUE

      j=ny
      DO 60 i = 2, nx-1
         up(i,j) = a*2*u(i,j) - b*um(i,j) +
     > c*(dt*dt)/(dx*dx)* ( 0.5*(lambda(i+1,j )+lambda(i ,j ))*(u(i+1,j
     &)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i-1,j ))*(u(i ,j )-u(i-1,j
     &))) +(dt*dt)/(dy*dy)* ( 0.5*(lambda(i ,j-1)+lambda(i ,j ))*(u(i ,j
     &-1)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i ,j-1))*(u(i ,j )-u(i ,j
     &-1)))
 60   CONTINUE

C Corners:
      i=1
      j=1
      up(i,j) = a*2*u(i,j) - b*um(i,j) +
     > c*(dt*dt)/(dx*dx)* ( 0.5*(lambda(i+1,j )+lambda(i ,j ))*(u(i+1,j
     &)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i+1,j ))*(u(i ,j )-u(i+1,j
     &))) +(dt*dt)/(dy*dy)* ( 0.5*(lambda(i ,j+1)+lambda(i ,j ))*(u(i ,j
     &+1)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i ,j+1))*(u(i ,j )-u(i ,j
     &+1)))

      i=nx
      j=1
      up(i,j) = a*2*u(i,j) - b*um(i,j) +
     > c*(dt*dt)/(dx*dx)* ( 0.5*(lambda(i-1,j )+lambda(i ,j ))*(u(i-1,j
     &)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i-1,j ))*(u(i ,j )-u(i-1,j
     &))) +(dt*dt)/(dy*dy)* ( 0.5*(lambda(i ,j+1)+lambda(i ,j ))*(u(i ,j
     &+1)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i ,j+1))*(u(i ,j )-u(i ,j
     &+1)))

      i=1
      j=ny
      up(i,j) = a*2*u(i,j) - b*um(i,j) +
     > c*(dt*dt)/(dx*dx)* ( 0.5*(lambda(i+1,j )+lambda(i ,j ))*(u(i+1,j
     &)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i+1,j ))*(u(i ,j )-u(i+1,j
     &))) +(dt*dt)/(dy*dy)* ( 0.5*(lambda(i ,j-1)+lambda(i ,j ))*(u(i ,j
     &-1)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i ,j-1))*(u(i ,j )-u(i ,j
     &-1)))

      i=nx
      j=ny
      up(i,j) = a*2*u(i,j) - b*um(i,j) +
     > c*(dt*dt)/(dx*dx)* ( 0.5*(lambda(i-1,j )+lambda(i ,j ))*(u(i-1,j
     &)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i-1,j ))*(u(i ,j )-u(i-1,j
     &))) +(dt*dt)/(dy*dy)* ( 0.5*(lambda(i ,j-1)+lambda(i ,j ))*(u(i ,j
     &-1)-u(i ,j )) -0.5*(lambda(i ,j )+lambda(i ,j-1))*(u(i ,j )-u(i ,j
     &-1)))
      RETURN
      END


MODULE Functions
    USE Kinds
    USE Conversions
    IMPLICIT NONE
    !>@brief
    !> This module contains the main functions used by FRAPCON
    !> Functions include polate, terp, bes2, and ShiftArray
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 05/26/2015

    PUBLIC

!    GENERIC :: operator(.terp.) => Linear_Interpolation
    !
    CONTAINS
    !
    PURE REAL(r8k) FUNCTION AVERAGE (VALUES)
    !>@brief
    !> This function computes the average of an array of numbers
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 6/13/2016

    REAL(r8k), DIMENSION(:), INTENT(IN) :: VALUES

    AVERAGE = SUM(VALUES(:)) / UBOUND(VALUES,DIM=1)

    END FUNCTION AVERAGE
    !
    REAL(r8k) FUNCTION polate (xy, xx, nn, kk)
    USE Kinds
    USE Conversions
    USE Commons, ONLY : ounit
    IMPLICIT NONE
    !>@brief
    !> Polate is a linear interpolation function
    !>@author
    !> Updated by Ian Porter, NRC
    !>@date
    !> 1/8/2016
    !
    ! Input
    !
    ! xy - A table of y(1), x(1), y(2), x(2), ... y(nn), x(nn)
    ! xx - The given value for x
    ! nn - The number of pairs of entries in xy (OPTIONAL)
    !      If not supplied, calculated by subroutine
    ! kk - Both the position guess and the final value (OPTIONAL)
    !
    ! Internal
    !
    ! nprmax     - Maximum # of times polate error will be written to output file
    ! PolateType - Indicator for whether normal linear interpolation will be performed or if an out of bounds error occurred
    !
    INTEGER(ipk) :: nerr=0, n, m, k, i
    INTEGER(ipk), INTENT(IN), OPTIONAL :: nn
    INTEGER(ipk), INTENT(INOUT), OPTIONAL :: kk
    INTEGER(ipk), PARAMETER :: nprmax = 20
    REAL(r8k) :: x
    REAL(r8k), INTENT(IN) :: xx
    REAL(r8k), PARAMETER :: zero = 0.0_r8k
    REAL(r8k), PARAMETER :: dm10 = 1.0e-10_r8k
    REAL(r8k), DIMENSION(:), INTENT(IN) :: xy
    CHARACTER(LEN=6) :: PolateType
    LOGICAL :: IncreaseIndex = .FALSE.
    !
    PolateType = ''
    IncreaseIndex = .FALSE.
    x = xx
    IF (PRESENT(nn)) THEN
        n = nn
        IF (PRESENT(kk)) THEN
            k = kk
        ELSE
            ! Initial guess starts at the bottom of the array
            k = 1
        END IF
    ELSE
        ! Let the code determine length of array xy
        n = SIZE(xy) / 2
        k = n / 2
        ! Since there are arrays being sent in that are larger than the data stored in the arrays,
        ! The code will (potentially) see the 0.0's as the midpoint value and not be able to properly
        ! perform the linear interpolatoin. Therefore, start interpolating at the first value until
        ! all arrays are properly sized.
        k = 1
    END IF
    m = ABS(n)
    IF (k < 1) k = 1
    IF (k >= m) k = m - 1
    ! Is constant wanted?
    IF (m < 1) THEN
        polate = zero
        RETURN
    ELSE IF (m == 1) THEN
        polate = xy(1)
        RETURN
    END IF
    ! Loop to decrease index
    IndexDecrease: DO
        IF (xy(2*k) <= x) THEN
            IncreaseIndex = .TRUE.
            EXIT IndexDecrease
        END IF
        k = k - 1
        IF (k <= 0) THEN
            IF (n < 0) THEN
                k = 1
                EXIT IndexDecrease
            ELSE IF (n == 0) THEN
                polate = zero
                RETURN
            ELSE
                PolateType = 'Error1'
                EXIT IndexDecrease
            END IF
        END IF
    END DO IndexDecrease
    ! Loop to increase index
    IF (IncreaseIndex) THEN
        IndexIncrease: DO
            IF ((x - xy(2*k + 2)) <= dm10) EXIT IndexIncrease
            k = k + 1
            IF (k >= m) THEN
                ! test for extrapolation
                IF (n < 0) THEN
                    k = m - 1
                    EXIT IndexIncrease
                ELSE IF (n == 0) THEN
                    polate = zero
                    RETURN
                ELSE
                    PolateType = 'Error2'
                    EXIT IndexIncrease
                END IF
            END IF
        END DO IndexIncrease
    END IF
    ! Interpolation
    SELECT CASE (PolateType)
    CASE DEFAULT
        ! Everything ok, get answer
        IF (PRESENT(kk)) kk = k
        polate = xy(2*k - 1) + (x - xy(2*k)) * (xy(2*k + 1) - xy(2*k - 1)) / (xy(2*k + 2) - xy(2*k))
        RETURN
    CASE ('Error1')
        ! polate failure, search out of bounds
        polate = xy(1)
    CASE ('Error2')
        ! polate failure, search out of bounds
        polate = xy(2*m - 1)
    END SELECT
    IF (nerr <= nprmax) THEN
        IF (PRESENT(kk)) THEN
            WRITE (ounit,250) kk, k, n, x, (xy(2*i),i=1,n)
        ELSE
            WRITE (ounit,251) k, n, x, (xy(2*i),i=1,n)
        END IF
        ! CALL errtra
        IF (nerr == nprmax) WRITE (ounit,260)
        nerr = nerr + 1
    END IF
250 FORMAT (' error in polate',/,'0initial index =',i6,10x,'final index =',i6,10x, &
      &     'array length =',i6,10x,'argument =',e14.6/'0table of x values =',/,(8e15.6))
251 FORMAT (' error in polate',/,'0initial index not provided',10x,'final index =',i6,10x, &
      &     'array length =',i6,10x,'argument =',e14.6,/,'0table of x values =',/,(8e15.6))
260 FORMAT ('***** Further messages suppressed *****')
    !
    END FUNCTION polate
    !
    !
    !
    FUNCTION Step_Polate (Array, Interp_Value) RESULT (Value)
    USE Kinds
    USE Commons, ONLY : ounit
    IMPLICIT NONE
    !>@brief
    !> This function interpolates using a step-wise interpolation method
    !> It will assume that the value is equal to the lower bounds value of what's being interpolated upon
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 6/16/2016

    INTEGER(ipk) :: i
    REAL(r8k) :: Value
    REAL(r8k), PARAMETER :: Min_Delta = 1.0e-10_r8k
    REAL(r8k), INTENT(IN) :: Interp_Value
    REAL(r8k), DIMENSION(:), INTENT(IN) :: Array

    ! Check to see if interpolating on only 1 value
    IF (UBOUND(Array,DIM=1) == 2) THEN
        Value = Array(1)
        RETURN
    END IF

    ! Ensure array values are always increasing
    i = 2
    DO WHILE (i+2 <= UBOUND(Array,DIM=1))
        IF (Array(i+2) < Array(i)) THEN
            WRITE (ounit,*) 'Interpolation values are not increasing. Exeuction Terminated in Step_Polate'
            WRITE (ounit,*) Array
            ERROR STOP 'Interpolation values are not increasing. Exeuction Terminated in Step_Polate'
        END IF
        i = i + 2
    END DO

    ! Get value
    Value = Array(1)
    i = 2
    Get_Value: DO
        IF (Interp_Value >= (Array(i) - Min_Delta) .AND. Interp_Value < ABS(Array(i+2) - Min_Delta)) EXIT Get_Value
        ! Incriment to check next set of pairs
        i = i + 2
        ! Assign value
        Value = Array(i-1)
        ! Ensure does not exceed array bounds. If so, keep Value equal to last provided value in array and return.
        IF (i + 1 > UBOUND(Array,DIM=1)) EXIT Get_Value
    END DO Get_Value

    END FUNCTION Step_Polate
    !
    !
    !
    REAL(r8k) FUNCTION terp (tt, ti, td, n)
    USE Kinds
    USE Conversions
    IMPLICIT NONE
    !>@brief
    !> Interpolates to find a value terp from the td (dependent) array to correspond to the
    !> value tt from the ti (independent) array.  n is the number of values present in the ti or td arrays.
    !> The routine is capable of handling an independent array arranged in either increasing or decreasing order.
    !> To speed solution on large arrays, the arrays are subdivided into two or four sub-arrays to enhance the sorting.
    INTEGER(ipk), INTENT(IN) :: n
    INTEGER(ipk) :: no1, no2, no3, j, j1, j2
    REAL(r8k), INTENT(IN) :: tt
    REAL(r8k), DIMENSION(n), INTENT(IN) :: ti, td
    !
    no2 = n / 2
    IF (ti(1) > ti(n)) GOTO 210
    IF (tt <= ti(1)) GOTO 170
    IF (tt >= ti(n)) GOTO 180
    IF (tt >= ti(no2)) GOTO 120
    IF (n <= 12) GOTO 110
    no1 = no2 / 2
    IF (tt >= ti(no1)) GOTO 100
    j1 = 1
    j2 = no1
    GOTO 150
100 CONTINUE
    j1 = no1
    j2 = no2
    GOTO 150
110 CONTINUE
    j1 = 1
    j2 = no2
    GOTO 150
120 CONTINUE
    IF (n <= 12) GOTO 140
    no3 = (no2 + n) / 2
    IF (tt >= ti(no3)) GOTO 130
    j1 = no2
    j2 = no3
    GOTO 150
130 CONTINUE
    j1 = no3
    j2 = n
    GOTO 150
140 CONTINUE
    j1 = no2
    j2 = n
150 CONTINUE
    DO j = j1, j2
        IF (tt - ti(j) < 0.0_r8k) GOTO 200
        IF (tt - ti(j) == 0.0_r8k) GOTO 190
    END DO
    GOTO 180
170 terp = td(1)
    RETURN
180 terp = td(n)
    RETURN
190 terp = td(j)
    RETURN
200 CONTINUE
    terp = td(j-1) + (td(j) - td(j-1)) * (tt - ti(j-1)) / (ti(j) - ti(j-1))
    RETURN
210 IF (tt >= ti(1)) GOTO 170
    IF (tt <= ti(n)) GOTO 180
    IF (tt <= ti(no2)) GOTO 240
    IF (n <= 12) GOTO 230
    no1 = no2 / 2
    IF (tt <= ti(no1)) GOTO 220
    j1 = 1
    j2 = no1
    GOTO 270
220 CONTINUE
    j1 = no1
    j2 = no2
    GOTO 270
230 CONTINUE
    j1 = 1
    j2 = no2
    GOTO 270
240 CONTINUE
    IF (n <= 12) GOTO 260
    no3 = (no2 + n) / 2
    IF (tt <= ti(no3)) GOTO 250
    j1 = no2
    j2 = no3
    GOTO 270
250 CONTINUE
    j1 = no3
    j2 = n
    GOTO 270
260 CONTINUE
    j1 = no2
    j2 = n
270 CONTINUE
    DO j = j1, j2
        IF (tt == ti(j)) GOTO 190
        IF (tt > ti(j)) GOTO 200
    END DO
    GOTO 180
    END FUNCTION terp
    !
    !
    !
    REAL(r8k) FUNCTION bes2 (arg, n, m, ier)
    USE Kinds
    USE Conversions
    IMPLICIT NONE
    !>@brief
    !> To calculate i and k bessel functions of order 0 and 1
    !> @author
    !> origen: i d palmer
    !> modified and tested by r kunze
    !
    ! Input
    !
    ! arg  - argument
    ! x    - argument (equal to arg)
    ! n    - order of the bessel Function (0 or 1)
    ! m    - Determines i or k function.
    !    0 = i function
    !    1 = k function
    ! ier  - error indicator : =1  negative arg
    !
    INTEGER(ipk), INTENT(IN) :: n, m
    INTEGER(ipk), INTENT(OUT) :: ier
    REAL(r8k), INTENT(INOUT) :: arg
    REAL(r8k) :: x
    !
    ier = 0
    IF (arg <= 0.0_r8k) THEN
        IF (arg < 0.0_r8k) THEN
            ! --- argument is negative
            ier = 1
            arg = 0.0_r8k
        END IF
        IF (m == 0) THEN
            IF (n == 0) THEN
                bes2 = 1.0_r8k
                RETURN
            ELSE IF (n == 1) THEN
                bes2 = 0.0_r8k
                RETURN
            END IF
        ELSE IF (m == 1) THEN
            IF (n == 0) THEN
                bes2 = 1.0e10_r8k
                RETURN
            ELSE IF (n == 1) THEN
                bes2 = 1.0e10_r8k
                RETURN
            END IF
        END IF
    ELSE
        x = arg
        IF (m == 0) THEN
            IF (n == 0) THEN
                ! Calculation of i0
                IF (x <= 3.75_r8k) THEN
                    bes2 = bi0l((x ** 2) / (3.75_r8k ** 2))
                    RETURN
                ELSE
                    bes2 = bi0g(3.75_r8k / x) * EXP(x) / SQRT(x)
                    RETURN
                END IF
            ELSE IF (n == 1) THEN
                ! --- calculation of i1
                IF (x <= 3.75_r8k) THEN
                    bes2 = bi1l((x ** 2) / (3.75_r8k ** 2)) * x
                    RETURN
                END IF
            END IF
        ELSE IF (m == 1) THEN
            IF (n == 0) THEN
                ! --- calculation of k0
                IF (x <= 2.0_r8k) THEN
                    bes2 = bk0l((x ** 2) / 4.0_r8k) - LOG(x / 2.0_r8k) * bi0l((x ** 2) / (3.75_r8k ** 2))
                    RETURN
                ELSE
                    bes2 = bk0g(2.0_r8k / x) / EXP(x) / SQRT(x)
                    RETURN
                END IF
            ELSE IF (n == 1) THEN
                ! --- calculation of k1
                IF (x <= 2.0_r8k) THEN
                    bes2 = bk1l((x ** 2) / 4.0_r8k) / x + LOG(x / 2.0_r8k) * bi1l((x ** 2) / (3.75_r8k ** 2)) * x
                    RETURN
                ELSE
                    bes2 = bk1g(2.0_r8k / x) / EXP(x) / SQRT(x)
                    RETURN
                END IF
            END IF
        END IF
    END IF
    !
    CONTAINS
        !
        PURE REAL(r8k) FUNCTION bi0l (x)
        USE Kinds
        USE Conversions
        !>@author
        !> Ian Porter, NRC
        REAL(r8k), INTENT(IN) :: x
        !
        bi0l = 1.0_r8k + x * (3.5156229_r8k + x * (3.0899424_r8k + x * (1.2067492_r8k + x * (0.2659732_r8k + &
          &    x * (0.0360768_r8k + x *  0.0045813_r8k)))))
        !
        END FUNCTION bi0l
        !
        !
        !
        PURE REAL(r8k) FUNCTION bi0g (x)
        USE Kinds
        USE Conversions
        !>@author
        !> Ian Porter, NRC
        REAL(r8k), INTENT(IN) :: x
        !
        bi0g = 0.39894228_r8k + x * (0.01328592_r8k + x * (0.0022532_r8k + x * (-0.00157565_r8k + x * (0.0091628_r8k + &
          &    x * (-0.02057706_r8k + x * (0.02635537_r8k + x * (-0.01647633_r8k + x * 0.00392377_r8k)))))))
        !
        END FUNCTION bi0g
        !
        !
        !
        PURE REAL(r8k) FUNCTION bi1l (x)
        USE Kinds
        USE Conversions
        !>@author
        !> Ian Porter, NRC
        REAL(r8k), INTENT(IN) :: x
        !
        bi1l = 0.5_r8k + x * (0.87890594_r8k + x * (0.51498869_r8k + x * (0.15084934_r8k + x * (0.02658733_r8k + &
          &    x * (0.00301532_r8k + x *  0.00032411_r8k)))))
        !
        END FUNCTION bi1l
        !
        !
        !
        PURE REAL(r8k) FUNCTION bk0l (x)
        USE Kinds
        USE Conversions
        !>@author
        !> Ian Porter, NRC
        REAL(r8k), INTENT(IN) :: x
        !
        bk0l = -0.57721566_r8k + x * (0.42278420_r8k + x * (0.23069756_r8k + x * (0.03488590_r8k + x * (0.00262698_r8k + &
          &    x * (0.00010750_r8k + x * 0.00000740_r8k)))))
        !
        END FUNCTION bk0l
        !
        !
        !
        PURE REAL(r8k) FUNCTION bk0g (x)
        USE Kinds
        USE Conversions
        !>@author
        !> Ian Porter, NRC
        REAL(r8k), INTENT(IN) :: x
        !
        bk0g = 1.25331414_r8k + x * (-0.07832358_r8k + x * (0.02189568_r8k + x * (-0.01062446_r8k + x * (0.00587872_r8k + &
          &       x * (-0.00251540_r8k + x * 0.00053208_r8k)))))
        !
        END FUNCTION bk0g
        !
        !
        !
        PURE REAL(r8k) FUNCTION bk1l (x)
        USE Kinds
        USE Conversions
        !>@author
        !> Ian Porter, NRC
        REAL(r8k), INTENT(IN) :: x
        !
        bk1l = 1.0_r8k + x * (0.15443144_r8k + x * (-0.67278579_r8k + x * (-0.18156897_r8k + x * (-0.01919402_r8k + &
          &    x * (-0.00110404_r8k - x * 0.00004686_r8k)))))
        !
        END FUNCTION bk1l
        !
        !
        !
        PURE REAL(r8k) FUNCTION bk1g (x)
        USE Kinds
        USE Conversions
        !>@author
        !> Ian Porter, NRC
        REAL(r8k), INTENT(IN) :: x
        !
        bk1g = 1.25331414_r8k + x * (0.23498619_r8k + x * (-0.03655620_r8k + x * (0.01504268_r8k + x * (-0.00780353_r8k + &
          &    x * (0.00325614_r8k - x *  0.00068245_r8k)))))
        !
        END FUNCTION bk1g
    !
    END FUNCTION bes2
    !
    !
    !
    SUBROUTINE ShiftArray (size1, size2, ArrayVal, ShiftType)
    USE Kinds
    USE Conversions
    USE Commons, ONLY : ounit
    IMPLICIT NONE
    !>@brief
    !> This subroutine increases an array from (array1, size1) to (array2, size2) using either
    !> (1) linear interpolation or (2) histogram.
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 9/22/2014
    !
    INTEGER(ipk), INTENT(IN) :: size1, size2, ShiftType
    INTEGER(ipk) :: n, count, i, j
    REAL(r8k), DIMENSION(:), INTENT(INOUT) :: ArrayVal
    REAL(r8k), DIMENSION(:), ALLOCATABLE :: DumArray
    !
    ALLOCATE (DumArray(1:size1))
    !
    n = size2 / size1
    count = 0
    !
    SELECT CASE (ShiftType)
    CASE(1) ! LinearInterpolation
        ! Store old values
        DumArray(1:size1) = ArrayVal(1:size1)
        !
        DO i = 1, size1
            DO j = 1, n
                IF (i < size1) THEN
                    ArrayVal((i - 1) * n + j) = DumArray(i) + (DumArray(i + 1) - DumArray(i)) / n * j
                ELSE
                    ArrayVal((i - 1) * n + j) = DumArray(size1)
                END IF
            END DO
        END DO
    CASE (2) ! Histogram
        ! Store old values
        DumArray(1:size1) = ArrayVal(1:size1)
        !
        DO i = 1, size1
            DO j = 1, n
                ArrayVal((i - 1) * n + j) = DumArray(i)
            END DO
        END DO
    CASE DEFAULT
        WRITE (0,110)
        WRITE (ounit,110)
110     FORMAT('Error in Subroutine ShiftArray. Wrong shift type called. Program Execution Stopped.')
        ERROR STOP 'Wrong shift type called. Execution terminated in Subroutine: ShiftArray.'
    END SELECT
    !
    DEALLOCATE (DumArray)
    !
    END SUBROUTINE ShiftArray
    !
    !
    !
    SUBROUTINE ReAllocateArray (size_old, size_new, startval, RealArray)
    USE Kinds
    USE Conversions
    IMPLICIT NONE
    !>@brief
    !> This subroutine re-allocates the array size but keeps the data in the same location
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 9/22/2014
    !
    INTEGER(ipk), INTENT(IN) :: size_old, size_new, startval
    INTEGER(ipk) :: i, MinSize, MaxSize
    REAL(r8k), DIMENSION(:), ALLOCATABLE, INTENT(INOUT) :: RealArray
    REAL(r8k), DIMENSION(:), ALLOCATABLE :: DumArray
    !
    MinSize = MIN(size_old, size_new)
    MaxSize = MAX(size_old, size_new)
    !
    ALLOCATE(DumArray(startval:MinSize))
    DumArray = 0.0_r8k
    !
    DO i = startval, MinSize
        DumArray(i) = RealArray(i)
    END DO
    !
    IF (ALLOCATED(RealArray)) DEALLOCATE (RealArray)
    ALLOCATE (RealArray(startval:size_new))
    RealArray = 0.0_r8k
    !
    DO i = startval, MinSize
        RealArray(i) = DumArray(i)
    END DO
    !
    IF (ALLOCATED(DumArray)) DEALLOCATE (DumArray)
    !
    END SUBROUTINE ReAllocateArray
    !
    !
    SUBROUTINE ReAllocateArray1DInteger (size_old, size_new, startval, IntArray)
    USE Kinds
    USE Conversions
    IMPLICIT NONE
    !>@brief
    !> This subroutine re-allocates the array size but keeps the data in the same location
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 9/22/2014
    !
    INTEGER(ipk), INTENT(IN) :: size_old, size_new, startval
    INTEGER(ipk) :: i, MinSize, MaxSize
    INTEGER(ipk), DIMENSION(:), ALLOCATABLE, INTENT(INOUT) :: IntArray
    INTEGER(ipk), DIMENSION(:), ALLOCATABLE :: DumArray
    !
    MinSize = MIN(size_old, size_new)
    MaxSize = MAX(size_old, size_new)
    !
    ALLOCATE(DumArray(startval:MinSize))
    DumArray = 0
    !
    DO i = startval, MinSize
        DumArray(i) = IntArray(i)
    END DO
    !
    IF (ALLOCATED(IntArray)) DEALLOCATE (IntArray)
    ALLOCATE (IntArray(startval:size_new))
    IntArray = 0.0_r8k
    !
    DO i = startval, MinSize
        IntArray(i) = DumArray(i)
    END DO
    !
    IF (ALLOCATED(DumArray)) DEALLOCATE (DumArray)
    !
    END SUBROUTINE ReAllocateArray1DInteger
    !
    !
    !
    SUBROUTINE ReAllocateArray2D (size1_old, size1_new, startval1, size2_old, size2_new, startval2, RealArray)
    USE Kinds
    USE Conversions
    IMPLICIT NONE
    !>@brief
    !> This subroutine re-allocates the 2-D array size but keeps the data in the same location
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 9/22/2014
    !
    INTEGER(ipk), INTENT(IN) :: size1_old, size1_new, startval1, size2_old, size2_new, startval2
    INTEGER(ipk) :: i, l, MinSize1, MaxSize1, MinSize2, MaxSize2
    REAL(r8k), DIMENSION(:,:), ALLOCATABLE, INTENT(INOUT) :: RealArray
    REAL(r8k), DIMENSION(:,:), ALLOCATABLE :: DumArray
    !
    MinSize1 = MIN(size1_old, size1_new)
    MaxSize1 = MAX(size1_old, size1_new)
    MinSize2 = MIN(size2_old, size2_new)
    MaxSize2 = MAX(size2_old, size2_new)
    !
    ALLOCATE(DumArray(startval1:MinSize1, startval2:MinSize2))
    DumArray = 0.0_r8k
    !
    DO i = startval1, MinSize1
        DO l = startval2, MinSize2
            DumArray(i,l) = RealArray(i,l)
        END DO
    END DO
    !
    IF (ALLOCATED(RealArray)) DEALLOCATE (RealArray)
    ALLOCATE (RealArray(startval1:size1_new, startval2:size2_new))
    RealArray = 0.0_r8k
    !
    DO i = startval1, MinSize1
        DO l = startval2, MinSize2
            RealArray(i,l) = DumArray(i,l)
        END DO
    END DO
    !
    IF (ALLOCATED(DumArray)) DEALLOCATE (DumArray)
    !
    END SUBROUTINE ReAllocateArray2D
    !
    !
    !
    SUBROUTINE ReAllocateArray3D(size1_old, size1_new, startval1, size2_old, size2_new, startval2, &
      &                          size3_old, size3_new, startval3, RealArray)
    USE Kinds
    USE Conversions
    IMPLICIT NONE
    !>@brief
    !> This subroutine re-allocates the 3-D array size but keeps the data in the same location
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 9/22/2014
    !
    INTEGER(ipk), INTENT(IN) :: size1_old, size1_new, startval1, size2_old, size2_new, startval2, &
      &                         size3_old, size3_new, startval3
    INTEGER(ipk) :: i, l, k, MinSize1, MaxSize1, MinSize2, MaxSize2, MinSize3, MaxSize3
    REAL(r8k), DIMENSION(:,:,:), ALLOCATABLE, INTENT(INOUT) :: RealArray
    REAL(r8k), DIMENSION(:,:,:), ALLOCATABLE :: DumArray
    !
    MinSize1 = MIN(size1_old, size1_new)
    MaxSize1 = MAX(size1_old, size1_new)
    MinSize2 = MIN(size2_old, size2_new)
    MaxSize2 = MAX(size2_old, size2_new)
    MinSize3 = MIN(size3_old, size3_new)
    MaxSize3 = MAX(size3_old, size3_new)
    !
    ALLOCATE(DumArray(startval1:MinSize1, startval2:MinSize2, startval3:MinSize3))
    DumArray = 0.0_r8k
    !
    DO i = startval1, MinSize1
        DO l = startval2, MinSize2
            DO k = startval3, MinSize3
                DumArray(i,l,k) = RealArray(i,l,k)
            END DO
        END DO
    END DO
    !
    IF (ALLOCATED(RealArray)) DEALLOCATE (RealArray)
    ALLOCATE (RealArray(startval1:size1_new, startval2:size2_new, startval3:size3_new))
    RealArray = 0.0_r8k
    !
    DO i = startval1, MinSize1
        DO l = startval2, MinSize2
            DO k = startval3, MinSize3
                RealArray(i,l,k) = DumArray(i,l,k)
            END DO
        END DO
    END DO
    !
    IF (ALLOCATED(DumArray)) DEALLOCATE (DumArray)
    !
    END SUBROUTINE ReAllocateArray3D
    !
    !
    !
    PURE FUNCTION TO_UPPERCASE (String) RESULT (NewString)
    USE Kinds
    IMPLICIT NONE
    !>@brief
    !> This function changes lowercase text in a string to uppercase text
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 1/30/2015
    INTEGER(ipk) :: i, j
    CHARACTER(LEN=*), INTENT(IN) :: String
    CHARACTER(LEN=LEN_TRIM(String)) :: NewString
    CHARACTER(LEN=26), PARAMETER :: CAPL = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
    CHARACTER(LEN=26), PARAMETER :: LOWL = 'abcdefghijklmnopqrstuvwxyz'
    !
    NewString = ''
    !
    DO i = 1, LEN_TRIM(String)
        j = INDEX(LOWL, String(i:i))
        IF (j > 0) THEN
            NewString(i:i) = CAPL(j:j)
        ELSE
            NewString(i:i) = string(i:i)
        END IF
    END DO
    !
    END FUNCTION TO_UPPERCASE
    !
    !
    !
    PURE FUNCTION TO_LOWERCASE (String) RESULT (NewString)
    USE Kinds
    IMPLICIT NONE
    !>@brief
    !> This function changes uppercase text in a string to lowercase text
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 1/30/2015
    INTEGER(ipk) :: i, j
    CHARACTER(LEN=*), INTENT(IN) :: String
    CHARACTER(LEN=LEN_TRIM(String)) :: NewString
    CHARACTER(LEN=26), PARAMETER :: CAPL = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
    CHARACTER(LEN=26), PARAMETER :: LOWL = 'abcdefghijklmnopqrstuvwxyz'
    !
    NewString = ''
    !
    DO i = 1, LEN_TRIM(String)
        j = INDEX(CAPL, String(i:i))
        IF (j > 0) THEN
            NewString(i:i) = LOWL(j:j)
        ELSE
            NewString(i:i) = string(i:i)
        END IF
    END DO
    !
    END FUNCTION TO_LOWERCASE
    !
    !
    !
    SUBROUTINE simq (a, b, n)
    USE Kinds
    USE Commons, ONLY : ounit
    IMPLICIT NONE
    !>@brief
    !> Subroutine simq obtains solution of a set of simultaneous linear equations, ax=b
    !>@author
    !> Modified by Ian Porter, NRC, April 2014, to clean coding and convert to .f90
    !
    ! Input
    !
    ! a  - Matrix of coefficients stored columnwise. These are destroyed in the computation. The size of matrix a is n by n.
    ! b  - Vector of original constants (length n). These are replaced by final solution values, vector x.
    ! n  - Number of equations and variables. n must be > one.
    !
    ! Output
    !
    ! a  - Matrix of coefficients stored columnwise. These are destroyed in the computation. The size of matrix a is n by n.
    ! b  - Vector of original constants (length n). These are replaced by final solution values, vector x.
    !
    ! Remarks:
    !
    ! matrix a must be general.
    ! If matrix is singular, solution values are meaningless.
    ! An alternative solution may be obtained by using matrix inversion (minv) and matrix product (gmprd).
    !
    ! Method:
    !
    ! Method of solution is by elimination using largest pivotal divisor. Each stage of elimination consists of interchanging
    ! rows when necessary to avoid division by zero or small elements. The forward solution to obtain variable n is done in
    ! n stages. The back solution for the other variables is calculated by successive substitutions. The final solution
    ! values are developed in vector b, with variable 1 in b(1), variable 2 in b(2),........, variable n in b(n).
    ! If no pivot can be found exceeding a the tolerance set by Tolerance, the matrix is considered singular and fails.
    !
    ! ..................................................................
    !
    INTEGER(ipk) :: i,j,k, it, ny, ia, ic, jj, jy, ij, imax, i1, i2, ix, ixj, jx, iqs, ixjx, jjx, ib
    INTEGER(ipk), INTENT(IN) :: n
    REAL(r8k) :: biga, save
    REAL(r8k), PARAMETER :: Tolerance = 0.0_r8k
    REAL(r8k), DIMENSION(:), INTENT(INOUT) :: a, b

    ! Forward solution
    jj = -n
    ! Call error if n = 0
    IF (n == 0) THEN
        WRITE (0,*) 'Error in subroutine simq. n = 0.'
        WRITE (ounit, *) 'Error in subroutine simq. n = 0.'
        ERROR STOP 'Error in Subroutine: simq. N = 0.'
    END IF
    DO j = 1, n
        jy = j + 1
        jj = jj + n + 1
        biga = 0.0_r8k
        it = jj - j
        DO i = j, n
            ! Search for maximum coefficient in column
            ij = it + i
            IF (ABS(biga) < ABS(a(ij))) THEN
                biga = a(ij)
                imax = i
            END IF
        END DO
        ! Test for pivot less than tolerance (singular matrix)
        IF (ABS(biga) <= Tolerance) THEN
            ! Solution failured due to singular matrix
            WRITE(ounit,20)
20          FORMAT(' Solution failure in Subroutine: simq. Singular matrix encountered.Execution stopped')
            ERROR STOP ' Solution failure in Subroutine: simq. Singular matrix encountered.Execution stopped'
        END IF
        ! Interchange rows If necessary
        i1 = j + n * (j - 2)
        it = imax - j
        DO k = j, n
            i1 = i1 + n
            i2 = i1 + it
            save = a(i1)
            a(i1) = a(i2)
            a(i2) = save
            ! Divide equation by leading coefficient
            a(i1) = a(i1) / biga
        END DO
        save = b(imax)
        b(imax) = b(j)
        b(j) = save / biga
        ! Eliminate next variable
        IF (j == n) EXIT
        iqs = n * (j - 1)
        DO ix = jy, n
            ixj = iqs + ix
            it = j - ix
            DO jx = jy, n
                ixjx = n * (jx - 1) + ix
                jjx = ixjx + it
                a(ixjx) = a(ixjx) - (a(ixj) * a(jjx))
            END DO
            b(ix) = b(ix) - (b(j) * a(ixj))
        END DO
    END DO
    ! Back solution
    ny = n - 1
    it = n ** 2
    DO j = 1, ny
        ia = it - j
        ib = n - j
        ic = n
        DO k = 1, j
            b(ib) = b(ib) - a(ia) * b(ic)
            ia = ia - n
            ic = ic - 1
        END DO
    END DO
    !
    END SUBROUTINE simq
    !
END MODULE Functions


! Compute the dot product of two vectors w/ 4 entries with explicit loops.
!   Try changing the target architecture to AVX (-mavx)
!   and enabling optimisation (-O3) and compare the results.
real function dot_prod(a, b)
    implicit none
    real, intent(in), dimension(4) :: a, b
    real, dimension(4) :: temp
    integer :: i

    do i = 1, 4
        temp(i) = a(i) * b(i)
    end do

    dot_prod = 0.

    do i = 1,4
        dot_prod = dot_prod + temp(i)
    end do

    return
end function dot_prod


program MAIN
    use iso_fortran_env, wp => real64
    use graphf
    implicit none
    type(graph) :: G
    integer :: start,end

    !-- set up an example
    call example1(G)
    start = 1 !remember that arrays start at 1 in fortran
    end = 14

    !-- call the example with Dijkstra's Algorithm
    write(*,'(a,i0,a,i0,a)') "Shortest path from vertex ", start, " to vertex ", end, &
    & " using Dijkstra's algorithm:"
    call exampleDijkstra(G,start,end)

    !-- call the example with the Floyd-Warshall Algorithm
    write(*,'(/,a,i0,a,i0,a)') "Shortest path from vertex ", start, " to vertex ", end, &
    & " using the Floyd-Warshall algorithm:"
    call exampleFloydWarshall(G,start,end)

end program MAIN


module fac_mod
    implicit none
    public :: factorial

contains

    function factorial(n) result(fact)
        implicit none
        integer, intent(in) :: n
        integer :: fact
        integer :: fac = 1
        integer :: i
        do i = 2, n
            fac = fac*i
        end do
        fact = fac
    end function factorial

end module fac_mod