program data_types

! This program prints the maximum values for intrinsic integer data types,
! and minimum and maximum values for intrinsic real data types.

  use iso_fortran_env, only: int8, int16, int32, int64, real32, real64, real128

  implicit none

  integer(int8) :: i8
  integer(int16) :: i16
  integer(int32) :: i32
  integer(int64) :: i64

  real(real32) :: r32
  real(real64) :: r64
  real(real128) :: r128

  print *, 'This program prints the range of standard integer &
            and real kinds available in iso_fortran_env'

  print *, 'Largest int8: ', huge(i8)
  print *, 'Largest int16: ', huge(i16)
  print *, 'Largest int32: ', huge(i32)
  print *, 'Largest int64: ', huge(i64)

  print *, 'Smallest/largest real32: ', tiny(r32), huge(r32)
  print *, 'Smallest/largest real64: ', tiny(r64), huge(r64)
  print *, 'Smallest/largest real128: ', tiny(r128), huge(r128)

end program data_types


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     Subroutine plane_eq.f
!
!     Creates the plane equation from three known points.
!     Gives the z-coordinate of the fourth point as an output.
!
!     x1,y1,z1: The coordinates of the first point
!     x2,y2,z2: The coordinates of the second point
!     x3,y3,z3: The coordinates of the third point
!     x0,y0: The x and y-coordinates for the fourth point
!     output: The z-coordinate according to the x0 and y0
!
!     by: Jaro Hokkanen
!
      subroutine plane_eq(x1,y1,z1,x2,y2,z2,x3,y3,z3,x0,y0,output)
!
      implicit none
!
      real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,x0,y0,output,
     &  a,b,c,d
!
      d=x1*y2*z3+y1*z2*x3+z1*x2*y3-x1*z2*y3-y1*x2*z3-z1*y2*x3
      if(d.ne.0.d0) then
         a=1.d0/d*(y2*z3+y1*z2+z1*y3-z2*y3-y1*z3-z1*y2)
      endif
      if(d.ne.0.d0) then
         b=1.d0/d*(x1*z3+z2*x3+z1*x2-x1*z2-x2*z3-z1*x3)
      endif
      if(d.ne.0.d0) then
         c=1.d0/d*(x1*y2+y1*x3+x2*y3-x1*y3-y1*x2-y2*x3)
      endif
      if(d.ne.0.d0) then
         output=1.d0/c*(1.d0-a*x0-b*y0)
      else
         output=0.d0
      endif
      return
      end


real*8 function SHConfidence(l_conf, r)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will calculate the probability that two sets of spherical
!	harmonic coefficients, which possess a correlation coefficients r, are
!	linearly correlated at a given degree. This is calucated according to
!	equation A7 in Pauer et al. (2007), which is from Eckhard 1984, and MathWorld
!	http://mathworld.wolfram.com/CorrelationCoefficientBivariateNormalDistribution.html.
!
!	CALLING PARAMETERS
!		INPUT
!			l_conf		degree to calculate confidence levels.
!			r		the correlation coefficient of two sets
!					of spherical harmonic coeficients at degree l_conf.
!		OUTPUT
!			cl		The confidence level.
!
!	Written by Mark Wieczorek (April 18, 2007)
!
!	Copyright (c) 2007, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) :: r
	integer, intent(in) :: l_conf
	real*8 :: prod
	integer:: l, i

	SHConfidence = abs(r)
	prod = 1.0d0

	do l=2, l_conf, 1
		i = l-1
		prod = prod * dble(2*i-1) / dble(2*i)
		SHConfidence = SHConfidence + prod * abs(r) * (1.0d0 - r**2)**(l-1)
	enddo

end function SHConfidence


program main
  use timers
  type(TimerType) :: seriesTime,monteTime,totalTime

  integer npoints,i,numinside
  parameter (npoints=300000)
  complex*16 c(npoints)
  real*8 r1,r2,halfpi,err1,area,err2
  real rand

  call TimerCreate(seriesTime,"series")
  call TimerCreate(monteTime,"monte")
  call TimerCreate(totalTime,"Series+monte")

! GENERATE RANDOM NUMBERS

  call srand(54321)
  do i=1,npoints
     r1=rand()
     r2=rand()
     c(i)=CMPLX(-2.0+2.5*r1,1.125*r2)
  end do

  call TimerOn(totalTime)

!  CALCULATE PI/2 FROM GREGORY'S FORMULA

  call TimerOn(seriesTime)
  call series(halfpi,err1)
  call TimerOff(seriesTime)

!  CALCULATE AREA OF MANDELBROT SET BY MONTE CARLO SAMPLING

  call TimerOn(monteTime)
  call monte(c,numinside)
  call TimerOff(monteTime)

  call TimerOff(totalTime)

!  OUTPUT RESULTS

  area = 2.0*2.5*1.125 * real(numinside)/real(npoints)
  err2 = area/sqrt(real(npoints))
  print *, "Pi/2 = ", halfpi," +/- ",err1
  print *, "Area of Mandelbrot set = ",area," +/- ",err2

!  OUTPUT TIMING DATA

  call TimerPrint(seriesTime)
  call TimerPrint(monteTime)
  call TimerPrint(totalTime)

  stop
end program main

subroutine series(halfpi,err)

  real*8 halfpi,err,sum
  integer sign,terms,denom,i
  parameter (terms = 100000000)

  sum=0.0d0
  sign=1
  denom=1

  do i=1,terms
     sum=sum + sign*(1.0d0/denom)
     sign=(-sign)
     denom=denom + 2
  end do

  halfpi = 2.0d0 * sum
  err = 2.0d0/terms
  return
end subroutine series

subroutine monte(c,numinside)

  integer npoints,npoints_p,maxiter,maxiter_p,numinside,i,j
  parameter (npoints_p=300000,maxiter_p=10000)
  complex*16 c(npoints_p),z

  maxiter=maxiter_p
  npoints=npoints_p
  numinside=0
!$omp parallel do default (none) private(i,j,z) &
!$omp shared (c,maxiter,npoints) reduction(+:numinside)

  do i=1,npoints
     z=(0.0,0.0)
     do j=1,maxiter
        z = z*z +c(i)
        if (abs(z).gt.2.0) goto 10
     end do
     numinside = numinside +1
10   continue
  end do

  return
end subroutine monte


program Automorphic_check
    implicit none
    Integer(kind=16) :: a,sq
    print*, "Give an integer to check whether it is automorphic or not"
    read *, a
    sq = a*a
    print *, "Square is:", sq
    do while (a>0)
        if (mod(a,10) .ne. mod(sq,10)) then
            print*, "Non-automorphic"
            stop
        end if
        a= a/10
        sq = sq/10
    end do
    print *, "Automorphic"
end program Automorphic_check


PROGRAM factorial
IMPLICIT NONE
  INTEGER :: index, n, result = 1 ! User input n and output result for factorial function
  WRITE(*, *) "Enter a non-negative integer to compute its factorial:"
  READ(*, *) n
  IF (n .lt. 0) THEN
    WRITE(*, *) "You must enter a non-negative integer."
  ELSE
    DO index = 0, n - 1
      result = result * (n - index)
    END DO
    WRITE(*, *) "Factorial of ", n, " = ", result
  END IF
END PROGRAM factorial


! **
! * Provides functions to compute the derivative of a function numerically
! **
module nderiv
    use kinds, only: dp
    implicit none
    private
    public :: linderiv

    contains

        ! **
        ! * Calculates the derivative of the function y = f(x) using the method of finite differences.
        ! *
        ! * Input:
        ! *     - x: array representing the x-values of the function f
        ! *     - y: array representing the y-values of the function f (same size as array x)
        ! *
        ! * Return value: array for the right derivatives df(x)/dx.
        ! *
        ! * Note: the last two values are equal
        ! **
        function linderiv(x,y) result(dxy)
            real(dp),dimension(:), intent(in)        :: x,y
            real(dp),dimension(size(x))              :: dxy
            integer                                  :: dx_size

            dx_size = size(x)
            dxy = (eoshift(y,1)-y) / (eoshift(x,1)-x)
            dxy(dx_size)=dxy(dx_size-1)
        end function

end module nderiv


!===--- Jacobi.f90 ----- Jacobi Iterative Method ----*- Fortran -*-===!
!
! This file implements Jacobi iterative method which is an iterative
! method used to solve partial differential equations.
!
!===---------------------------------------------------------------===!

program Jacobi
  parameter (L = 8, ITMAX = 10)
  real A(L,L), Eps, Maxeps, B(L, L)
  MAXEPS = 0.5
  do J = 1, L
    do I = 1, L
      A(I, J) = 0.
      if (I == 1 .or. J == 1 .or. I == L .or. J == L) then
        B(I, J) = 0.
      else
        B(I, J) = 1. + I + J
      endif
    enddo
  enddo
  do It = 1, ITMAX
    Eps = 0.
      do J = 2, L - 1
        do I = 2, L - 1
          Eps = max(Eps, abs(B(I, J) - A(I, J)))
          A(I, J) = B(I, J)
        enddo
      enddo
    do J = 2, L - 1
      do I = 2, l - 1
        B(I, J) =  (A(I, J-1) + A(I-1, J) + A(I+1, J) + A(I, J+1) ) / 4.
      enddo
    enddo
    print 200, It, Eps
200 format (' It = ', i4, '   Eps = ', e14.7)
    if (Eps < MAXEPS) exit
  enddo
end


!=====================================================
SUBROUTINE eva2d_sd(nx,ny,ix,iy,dx,dy,spl,spval)

! Evaluates the second derivatives of 2-dimensional cubic spline of function f(x,y)
!
! Input:  nx, ny              number of values in x and y
!         ix, iy              pointer into the spline array spl
!         dx, dy              distance from x(ix) and y(iy)
!         spl                 array with spline data
! Output: spval(3)            evaluated function values
!                             spval(1) = d^2f/dx^2
!                             spval(2) = d^2f/(dxdy)
!                             spval(3) = d^2f/dy^2

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                             INTENT(in)  :: nx, ny, ix, iy
  REAL(kind=dp),                       INTENT(in)  :: dx, dy
  REAL(kind=dp), DIMENSION(4,4,nx,ny), INTENT(in)  :: spl
  REAL(kind=dp), DIMENSION(3),         INTENT(out) :: spval

  INTEGER                                          :: i,j
  REAL(kind=dp)                                    :: muli, mulj

  spval = 0

! d^2f/dx^2
  DO i=3,4
     IF (i == 3) THEN
        muli = 1
     ELSE
        muli = dx**(i-3)
     END IF
     muli = muli * (i-1) * (i-2)
     DO j=1,4
        IF (j == 1) THEN
           mulj = 1
        ELSE
           mulj = dy**(j-1)
        END IF
        spval(1) = spval(1) + spl(i,j,ix,iy) * muli * mulj
     END DO
  END DO

! d^2f/(dxdy)
  DO i=2,4
     IF (i == 2) THEN
        muli = 1
     ELSE
        muli = dx**(i-2)
     END IF
     muli = muli * (i-1)
     DO j=2,4
        IF (j == 2) THEN
           mulj = 1
        ELSE
           mulj = dy**(j-2)
        END IF
        mulj = mulj * (j-1)
        spval(2) = spval(2) + spl(i,j,ix,iy) * muli * mulj
     END DO
  END DO

! d^2f/dy^2
  DO i=1,4
     IF (i == 1) THEN
        muli = 1
     ELSE
        muli = dx**(i-1)
     END IF
     DO j=3,4
        IF (j == 3) THEN
           mulj = 1
        ELSE
           mulj = dy**(j-3)
        END IF
        mulj = mulj * (j-1) * (j-2)
        spval(3) = spval(3) + spl(i,j,ix,iy) * muli * mulj
     END DO
  END DO

  RETURN
END SUBROUTINE eva2d_sd


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! DARCG22 (Double Auxiliary Routine Compute Givens generators 2->2)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the generator for A Givens rotation represented
! by 2 real numbers: A strictly real cosine and A scrictly real sine.
! The first column is constructed to be parallel with the real vector
! [A,B]^T. The (2->2) refers to the 2 double inputs and 2 double outputs
! (excluding the norm).
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  A               REAL(8)
!                    the first component of the real vector [A,B]^T
!
!  B               REAL(8)
!                    the second component of the real vector [A,B]^T
!
! OUTPUT VARIABLES:
!
!  C               REAL(8)
!                    on exit contains the generator for the cosine
!                    component of the Givens rotation
!
!  S               REAL(8)
!                    on exit contains the generator for the sine
!                    component of the Givens rotation
!
!  NRM             REAL(8)
!                    on exit contains the norm of the vector [A,B]^T
!
!  INFO            INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies A is invalid
!                    INFO = -2 implies B is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine DARCG22(A,B,C,S,NRM,INFO)

  implicit none

  ! input variables
  integer, intent(inout) :: INFO
  real(8), intent(in) :: A,B
  real(8), intent(inout) :: C,S,NRM

  ! compute variables
  real(8), parameter :: tol = epsilon(1d0)

  ! initialize INFO
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! Check A
    call DARACH1(1,A,INFO)
    call UARERR(__FILE__,__LINE__,"A is invalid",INFO,-1)
    if (INFO.NE.0) then
      return
    end if

    ! Check B
    call DARACH1(1,B,INFO)
    call UARERR(__FILE__,__LINE__,"B is invalid",INFO,-2)
    if (INFO.NE.0) then
      return
    end if

  end if

  ! construct rotation
  NRM = 1d0
  if (B == 0) then
     if (A<0) then
        C = -1d0
        S = 0d0
        NRM = -A
     else
        C = 1d0
        S = 0d0
        NRM = A
     endif
  else if (abs(A) >= abs(B)) then
     S = B/A
     NRM = sqrt(1.d0 + S**2)
     if (A<0) then
        C = -1.d0/NRM
        S =  S*C
        NRM = -A*NRM
     else
        C =  1.d0/NRM
        S =  S*C
        NRM =  A*NRM
     end if
  else
     C = A/B;
     NRM = sqrt(1.d0 + C**2)
     if (B<0) then
        S = -1.d0/NRM
        C =  C*S
        NRM = -B*NRM
     else
        S =  1.d0/NRM
        C =  C*S
        NRM =  B*NRM
     end if
  end if

end subroutine DARCG22


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes derivative of Legendre basis function.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] ng polynomial degree
!> @param[in] csii GLL node
!> @param[in] csij GLL node identifying the basis function
!> @param[out] DPHI derivative of the j-th (csij) basis function of degree ng at node csii
!!              DPHI(ng,csii,csij) = DPHI_csij/dcsi (csii)

      function DPHI(ng,csii,csij)

     implicit real*8 (a-h,o-z)

     integer*4 :: ng

     call GET_LEGENDRE_VALUE_2DER(p2der2,p2,p2der,p1,p1der,ng,csii)
     call GET_LEGENDRE_VALUE_2DER(q2der2,q2,q2der,q1,q1der,ng,csij)

     if(abs(csij + 1.d0).le. 1.e-8 .and. abs(csii + 1.d0).le. 1.e-8) then
         DPHI = -(ng+1.d0)*ng/4.d0
     elseif(abs(csij - 1.d0).le. 1.e-8 .and. abs(csii - 1.d0).le. 1.e-8) then
         DPHI = (ng+1.d0)*ng/4.d0
     elseif(abs(csii - csij).le. 1.e-8) then
         DPHI = 0.d0
     else
         anum = (csij-csii)*ng*(ng+1.d0)*q2 + (1.d0-csij**2.d0)*q2der
         aden = p2*ng*(ng+1.d0)*(csii - csij)**2.d0
         DPHI =  anum/aden
     endif

     if(abs(DPHI) .lt. 1.e-10) then
         DPHI = 0.d0
     endif

     return
     end function DPHI


!> @brief This function returns the integral of the supplied 2D tabulated data.
!>
!> @param[in] x1 The first variable of integration.
!>
!> @param[in] x2 The second variable of integration.
!>
!> @param[in] arr The integrand.
!>
!> @note "x1" and "x2" do not have to be uniform.
!>
!> @warning "x1" must be the same as the first dimension of "arr".
!>
!> @warning "x2" must be the same as the second dimension of "arr".
!>

PURE FUNCTION func_integrate_2D_REAL64_real_array(x1, x2, arr) RESULT(ans)
    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare input variables ...
    REAL(kind = REAL64), DIMENSION(:), INTENT(in)                               :: x1
    REAL(kind = REAL64), DIMENSION(:), INTENT(in)                               :: x2
    REAL(kind = REAL64), DIMENSION(:, :), INTENT(in)                            :: arr

    ! Declare output variables ...
    REAL(kind = REAL64)                                                         :: ans

    ! Declare internal variables ...
    INTEGER(kind = INT64)                                                       :: i1
    INTEGER(kind = INT64)                                                       :: i2
    INTEGER(kind = INT64)                                                       :: n1
    INTEGER(kind = INT64)                                                       :: n2

    ! Find size of input arrays ...
    n1 = SIZE(x1, kind = INT64)
    n2 = SIZE(x2, kind = INT64)

    ! Set starting value ...
    ans = 0.0e0_REAL64

    ! Loop over x ...
    DO i1 = 1_INT64, n1 - 1_INT64
        ! Loop over y ...
        DO i2 = 1_INT64, n2 - 1_INT64
            ! Integrate via the trapezium rule ...
            ans = ans + (x1(i1 + 1_INT64) - x1(i1)) * (x2(i2 + 1_INT64) - x2(i2)) * 0.25e0_REAL64 * (arr(i1, i2) + arr(i1 + 1_INT64, i2) + arr(i1, i2 + 1_INT64) + arr(i1 + 1_INT64, i2 + 1_INT64))
        END DO
    END DO
END FUNCTION func_integrate_2D_REAL64_real_array


module dyn_sys
  use nrtype
  implicit none
  real(dp) :: a, b, c, u, d, alpha, beta

contains

  subroutine Chen(x,y,dydx)
    ! https://en.wikipedia.org/wiki/Multiscroll_attractor
    ! x := t
    ! y(1:3) := x, y, z
    ! dydx(1:3) := dx/dt, dy/dt, dz/dt
    implicit none
    real(dp), intent(in)  :: x, y(:)
    real(dp), intent(out) :: dydx(:)

    dydx(1) = a * (y(2) - y(1))
    dydx(2) = (c-a) * y(1) - y(1) * y(3) + c * y(2)
    dydx(3) = y(1) * y(2) - b * y(3)
  end subroutine Chen

  subroutine Lu_Chen(x,y,dydx)
    ! https://en.wikipedia.org/wiki/Multiscroll_attractor
    ! x := t
    ! y(1:3) := x, y, z
    ! dydx(1:3) := dx/dt, dy/dt, dz/dt
    implicit none
    real(dp), intent(in)  :: x, y(:)
    real(dp), intent(out) :: dydx(:)

    dydx(1) = a * (y(2) - y(1))
    dydx(2) = y(1) - y(1) * y(3) + c * y(2) + u
    dydx(3) = y(1) * y(2) - b * y(3)
  end subroutine Lu_Chen

  subroutine mc_Chua(x,y,dydx)
    implicit none
    real(dp), intent(in)  :: x, y(:)
    real(dp), intent(out) :: dydx(:)

    dydx(1) = alpha * (y(2) - b * sin(pi*y(1))/(2.*a) + d)
    dydx(2) = y(1) - y(2) + y(3)
    dydx(3) = -beta * y(2)
  end subroutine mc_Chua

end module dyn_sys


! Módulo para juntar funções que resolvem sistemas
! lineares cuja matriz de coeficientes é triangular
! inferior ou superior
module trisys
    implicit none
contains
    ! Resolve um sistema linear
    !    Ax = b
    ! com
    !    A ∈ ℝⁿˣⁿ, triangular inferior
    !    b ∈ ℝⁿ
    ! com orientação a colunas, gravando
    ! a solução (x ∈ ℝⁿ) sobre o vetor b.
    !     Opcionalmente resolve para A triangular
    ! inferior unitária, não acessando os elementos
    ! da diagonal principal neste caso.
    ! Retorna
    !     0: caso tenha resolvido o sistema com sucesso
    !    -1: caso a matriz A seja singular e sistema
    !        não possa ser resolvido
    !
    function forwcol(n, A, b, unit) result(status)
        integer, intent(in)    :: n
        double precision,    intent(in)    :: A(:, :)
        double precision,    intent(inout) :: b(:)
        logical, intent(in)    :: unit

        integer :: i, j
        integer :: status

        status = -1

        do j = 1, n
            if (.not. unit) then
                if (A(j, j) == 0) then
                    return
                end if

                b(j) = b(j)/A(j, j)
            end if

            do i = j+1, n
                b(i) = b(i) - b(j)*A(i, j)
            end do
        end do

        status = 0
    end function forwcol

    ! Resolve um sistema linear
    !    Ax = b
    ! com
    !    A ∈ ℝⁿˣⁿ, triangular inferior
    !    b ∈ ℝⁿ
    ! com orientação a linhas, gravando
    ! a solução (x ∈ ℝⁿ) sobre o vetor b.
    !     Opcionalmente resolve para A triangular
    ! inferior unitária, não acessando os elementos
    ! da diagonal principal neste caso.
    ! Retorna
    !     0: caso tenha resolvido o sistema com sucesso
    !    -1: caso a matriz A seja singular e sistema
    !        não possa ser resolvido
    !
    function forwrow(n, A, b, unit) result(status)
        integer, intent(in)    :: n
        double precision,    intent(in)    :: A(:, :)
        double precision,    intent(inout) :: b(:)
        logical, intent(in)    :: unit

        integer :: i, j
        integer :: status

        status = -1

        do i = 1, n
            if (.not. unit) then
                if (A(i, i) == 0) then
                    return
                end if
            end if

            do j = 1, i-1
                b(i) = b(i) - b(j)*A(i, j)
            end do

            if (.not. unit) b(i) = b(i)/A(i, i)
        end do

        status = 0
    end function forwrow

    ! Resolve um sistema linear
    !    Ax = b
    ! com
    !    A ∈ ℝⁿˣⁿ, triangular superior
    !    b ∈ ℝⁿ
    ! com orientação a colunas, gravando
    ! a solução (x ∈ ℝⁿ) sobre o vetor b.
    !   Além disso, pode receber no lugar de A,
    ! sua transposta, fato indicado pela variável
    ! trans.
    ! Retorna
    !     0: caso tenha resolvido o sistema com sucesso
    !    -1: caso a matriz A seja singular e sistema
    !        não possa ser resolvido
    function backcol(n, A, b, trans) result(status)
        integer, intent(in)    :: n
        double precision,    intent(in)    :: A(:, :)
        double precision,    intent(inout) :: b(:)
        logical, intent(in)    :: trans

        integer :: i, j
        integer :: status

        status = -1
        if (trans) then
            do j = n, 1, -1
                if (A(j, j) == 0) then
                    return
                end if

                do i = j+1, n
                    b(j) = b(j) - b(i)*A(i, j)
                end do

                b(j) = b(j)/A(j, j)
            end do
            status = 0
            return
        else
            do j = n, 1, -1
                if (A(j, j) == 0) then
                    return
                end if

                b(j) = b(j)/A(j, j)

                do i = 1, j-1
                    b(i) = b(i) - b(j)*A(i, j)
                end do
            end do

            status = 0
            return
        end if
    end function backcol

    ! Resolve um sistema linear
    !    Ax = b
    ! com
    !    A ∈ ℝⁿˣⁿ, triangular superior
    !    b ∈ ℝⁿ
    ! com orientação a linhas, gravando
    ! a solução (x ∈ ℝⁿ) sobre o vetor b.
    !   Além disso, pode receber no lugar de A,
    ! sua transposta, fato indicado pela variável
    ! trans.
    ! Retorna
    !     0: caso tenha resolvido o sistema com sucesso
    !    -1: caso a matriz A seja singular e sistema
    !        não possa ser resolvido
    function backrow(n, A, b, trans) result(status)
        integer, intent(in)    :: n
        double precision,    intent(in)    :: A(:, :)
        double precision,    intent(inout) :: b(:)
        logical, intent(in)    :: trans

        integer :: i, j
        integer :: status

        status = -1
        if (trans) then
            do i = n, 1, -1
                if (A(i, i) == 0) then
                    return
                end if

                b(i) = b(i)/A(i, i)

                do j = 1, i-1
                    b(j) = b(j) - b(i)*A(i, j)
                end do
            end do

            status = 0
            return
        else
            do i = n, 1, -1
                if (A(i, i) == 0) then
                    return
                end if

                do j = i+1, n
                    b(i) = b(i) - b(j)*A(i, j)
                end do

                b(i) = b(i)/A(i, i)
            end do
            status = 0
            return
        end if
    end function backrow
end module trisys


Program Task3
  IMPLICIT NONE

  REAL    ::  h,xdash_s,xdash_mid,x_mid,vdash_s,vdash_mid,v_mid,k
  INTEGER ::  i

  REAL, DIMENSION(1:1001) :: t
  REAL, DIMENSION(1:1001) :: x
  REAL, DIMENSION(1:1001) :: v
  REAL, DIMENSION(1:1001) :: error_x
  REAL, DIMENSION(1:1001) :: error_v

  !Open Files to store data

  OPEN(unit=12,file='Task3.dat')

  !k=spring_constant h=step v=velocity x=position

  h=0.01

  !Define initial BCs

  t(1)=0
  v(1)=0
  x(1)=0.1
  k=5
  error_x(1)=x(1)-0.1*cos((5**0.5)*t(1))
  error_v(1)=v(1)+0.1*(5**0.5)*sin((5**0.5)*t(1))

  WRITE(12,'(5f9.5)') t(1),x(1),v(1),error_x(1),error_v(1)

  !Euler method for integrating two coupled ODEs simultaneously

  DO i=1,1000

  !Use these values at the midpoint

    vdash_s=-k*x(i)
    xdash_s=v(i)

    x_mid=x(i)+0.5*h*xdash_s
    v_mid=v(i)+0.5*h*vdash_s

    xdash_mid=v_mid
    vdash_mid=-k*x_mid

    !Input these values into the formulae below

    t(i+1)=t(i)+h
    x(i+1)=x(i)+h*xdash_mid
    v(i+1)=v(i)+h*vdash_mid

    error_x(i+1)=x(i+1)-0.1*cos((5**0.5)*t(i+1))
    error_v(i+1)=v(i+1)+0.1*(5**0.5)*sin((5**0.5)*t(i+1))

    !Write the values in the array to Task3.dat

    WRITE(12,'(5f9.5)') t(i+1),x(i+1),v(i+1),error_x(i+1),error_v(i+1)
  END DO

!Run Program
!Run gnuplot
!Write "plot "Task3.dat" using 1:2 with lines
!,0.1*cos(sqrt(5)*x)" in the terminal

END PROGRAM Task3


        subroutine idd_house(n,x,rss,vn,scal)
c
c       constructs the vector vn with vn(1) = 1
c       and the scalar scal such that
c       H := identity_matrix - scal * vn * transpose(vn) is orthogonal
c       and Hx = +/- e_1 * the root-sum-square of the entries of x
c       (H is the Householder matrix corresponding to x).
c
c       input:
c       n -- size of x and vn, though the indexing on vn goes
c            from 2 to n
c       x -- vector to reflect into its first component
c
c       output:
c       rss -- first entry of the vector resulting from the application
c              of the Householder matrix to x;
c              its absolute value is the root-sum-square
c              of the entries of x
c       vn -- entries 2 to n of the Householder vector vn;
c             vn(1) is assumed to be 1
c       scal -- scalar multiplying vn * transpose(vn);
c
c               scal = 2/(1 + vn(2)^2 + ... + vn(n)^2)
c               when vn(2), ..., vn(n) don't all vanish;
c
c               scal = 0
c               when vn(2), ..., vn(n) do all vanish
c               (including when n = 1)
c
c       reference:
c       Golub and Van Loan, "Matrix Computations," 3rd edition,
c            Johns Hopkins University Press, 1996, Chapter 5.
c
        implicit none
        save
        integer n,k
        real*8 x(n),rss,sum,v1,scal,vn(2:*),x1
c
c
        x1 = x(1)
c
c
c       Get out of this routine if n = 1.
c
        if(n .eq. 1) then
          rss = x1
          scal = 0
          return
        endif
c
c
c       Calculate (x(2))^2 + ... (x(n))^2
c       and the root-sum-square value of the entries in x.
c
c
        sum = 0
        do k = 2,n
          sum = sum+x(k)**2
        enddo ! k
c
c
c       Get out of this routine if sum = 0;
c       flag this case as such by setting v(2), ..., v(n) all to 0.
c
        if(sum .eq. 0) then
c
          rss = x1
          do k = 2,n
            vn(k) = 0
          enddo ! k
          scal = 0
c
          return
c
        endif
c
c
        rss = x1**2 + sum
        rss = sqrt(rss)
c
c
c       Determine the first component v1
c       of the unnormalized Householder vector
c       v = x - rss * (1 0 0 ... 0 0)^T.
c
c       If x1 <= 0, then form x1-rss directly,
c       since that expression cannot involve any cancellation.
c
        if(x1 .le. 0) v1 = x1-rss
c
c       If x1 > 0, then use the fact that
c       x1-rss = -sum / (x1+rss),
c       in order to avoid potential cancellation.
c
        if(x1 .gt. 0) v1 = -sum / (x1+rss)
c
c
c       Compute the vector vn and the scalar scal such that vn(1) = 1
c       in the Householder transformation
c       identity_matrix - scal * vn * transpose(vn).
c
        do k = 2,n
          vn(k) = x(k)/v1
        enddo ! k
c
c       scal = 2
c            / ( vn(1)^2 + vn(2)^2 + ... + vn(n)^2 )
c
c            = 2
c            / ( 1 + vn(2)^2 + ... + vn(n)^2 )
c
c            = 2*v(1)^2
c            / ( v(1)^2 + (v(1)*vn(2))^2 + ... + (v(1)*vn(n))^2 )
c
c            = 2*v(1)^2
c            / ( v(1)^2 + (v(2)^2 + ... + v(n)^2) )
c
        scal = 2*v1**2 / (v1**2+sum)
c
c
        return
        end
c
c
c
c


program main
  use utils
  use gauss
  implicit none
  real(kind = iKIND), allocatable, dimension(:,:) :: A
  real(kind = iKIND), allocatable, dimension(:) :: X, RES
  real(kind = 16), allocatable, dimension(:) :: IDEAL, ERROR
  real(kind = iKIND) :: h
  integer(kind=8) :: i, n, parse_result
  character(len=10) :: arg

  if (command_argument_count() .NE. 1) then
    print *, "Elements count should be given as program argument, exiting"
    error stop
  else
    call get_command_argument(1, arg)
  end if

  read(arg, *, iostat=parse_result) n
  if (parse_result .NE. 0) then
    print *, "Invalid size argument format!"
    error stop
  end if

  allocate(A(0:n, 0:n))
  allocate(X(0:n))
  allocate(RES(0:n))
  allocate(IDEAL(0:n))
  allocate(ERROR(0:n))
  h = real(1.0/n, kind=iKIND)

  IDEAL(0) = 0
  do i = 1, n
    IDEAL(i) = real(1, kind=16) / real(n, kind=16) * i
  end do

  call init_matrices(A, X, n, h)
  call eliminate(A, X, n)

  do i = 1, n-1
    ! for the sake of completeness, although A(i,i) == 1
    X(i) = X(i) / A(i,i)
  end do

  do i = 0, n
    print *, i, X(i)
  end do

  ERROR(:) = X - IDEAL
  print *, iKIND, N, (SUM(ABS(ERROR)) / size(ERROR))

  contains

    subroutine init_matrices(A, X, n, h)
      use utils
      integer(kind=8), intent(in) :: n
      integer(kind=8) :: i
      real(kind = iKIND), intent(inout) :: A(0:n, 0:n)
      real(kind = iKIND), intent(inout) :: X(0:n)
      real(kind = iKIND), intent(in) :: h
      real(kind = iKIND) :: diag, side
      ! values to be set on the diagonal and one colument left/right
      side = 1/(h**2)
      diag = -2 * side

      X(:) = real(0, kind=iKIND)
      X(n) = real(1, kind=iKIND)
      A(:,:) = real(0, kind=iKIND)

      do i = 1,n-1
        A(i - 1, i) = side
        A(i + 1, i) = side
        A(i, i) = diag
      end do

      A(0, 0) = 1
      A(n, n) = 1
    end subroutine init_matrices

end program main


program main

!*****************************************************************************80
!
!! MAIN runs an example of Dijkstra's minimum distance algorithm.
!
!  Discussion:
!
!    Given the distance matrix that defines a graph, we seek a list
!    of the minimum distances between node 0 and all other nodes.
!
!    This program sets up a small example problem and solves it.
!
!    The correct minimum distances are:
!
!      0   35   15   45   49   41
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 July 2010
!
!  Author:
!
!    Original C version by Norm Matloff, CS Dept, UC Davis.
!    FORTRAN90 version by John Burkardt.
!
  use omp_lib

  implicit none

  integer ( kind = 4 ), parameter :: nv = 6

  integer ( kind = 4 ) i
  integer ( kind = 4 ) :: i4_huge = 2147483647
  integer ( kind = 4 ) j
  integer ( kind = 4 ) mind(nv)
  integer ( kind = 4 ) ohd(nv,nv)

  call timestamp ( )
  write ( *, '(a)' )  ' '
  write ( *, '(a)' )  'DIJKSTRA_OPENMP:'
  write ( *, '(a)' )  '  FORTRAN90 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 for'
  write ( *, '(a)' )  '  parallel execution.'
!
!  Initialize the problem data.
!
  call init ( nv, ohd )
!
!  Print the distance matrix.
!
  write ( *, '(a)' )  ' '
  write ( *, '(a)' )  '  Distance matrix:'
  write ( *, '(a)' )  ' '
  do i = 1, nv
    do j = 1, nv
      if ( ohd(i,j) == i4_huge ) then
        write ( *, '(2x,a)', advance = 'NO' ) 'Inf'
      else
        write ( *, '(2x,i3)', advance = 'NO' ) ohd(i,j)
      end if
    end do
    write ( *, '(a)', advance = 'yes' )
  end do
!
!  Carry out the algorithm.
!
  call dijkstra_distance ( nv, ohd, mind )
!
!  Print the results.
!
  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
!
!  Terminate.
!
  write ( *, '(a)' )  ' '
  write ( *, '(a)' )  'DIJKSTRA_OPENMP:'
  write ( *, '(a)' )  '  Normal end of execution.'

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

  stop
end
subroutine dijkstra_distance ( nv, ohd, mind )

!*****************************************************************************80
!
!! DIJKSTRA_DISTANCE uses Dijkstra's minimum distance algorithm.
!
!  Discussion:
!
!    We essentially build a tree.  We start with only node 0 connected
!    to the tree, and this is indicated by setting CONNECTED(0) = TRUE.
!
!    We initialize MIND(I) to the one step distance from node 0 to node I.
!
!    Now we search among the unconnected nodes for the node MV whose minimum
!    distance is smallest, and connect it to the tree.  For each remaining
!    unconnected node I, we check to see whether the distance from 0 to MV
!    to I is less than that recorded in MIND(I), and if so, we can reduce
!    the distance.
!
!    After NV-1 steps, we have connected all the nodes to 0, and computed
!    the correct minimum distances.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 July 2010
!
!  Author:
!
!    Original C version by Norm Matloff, CS Dept, UC Davis.
!    This FORTRAN90 version by John Burkardt.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NV, the number of nodes.
!
!    Input, integer ( kind = 4 ) OHD(NV,NV), the distance of the direct
!    link between nodes I and J.
!
!    Output, integer ( kind = 4 ) MIND(NV), the minimum
!    distance from node 1 to each node.
!
  use omp_lib

  implicit none

  integer ( kind = 4 ) nv

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

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

!$omp end parallel

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

!*****************************************************************************80
!
!! FIND_NEAREST finds the nearest unconnected node.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 July 2010
!
!  Author:
!
!    Original C version by Norm Matloff, CS Dept, UC Davis.
!    This FORTRAN90 version by John Burkardt.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) S, E, the first and last nodes that
!    are to be checked.
!
!    Input, integer ( kind = 4 ) NV, the number of nodes.
!
!    Input, integer ( kind = 4 ) MIND(NV), the currently computed minimum
!    distance from node 1 to each node.
!
!    Input, logical CONNECTED(NV), is true for each connected node, whose
!    minimum distance to node 1 has been determined.
!
!    Output, integer ( kind = 4 ) D, the distance from node 1 to the nearest
!    unconnected node in the range S to E.
!
!    Output, integer ( kind = 4 ) V, the index of the nearest unconnected node
!    in the range S to E.
!
  implicit none

  integer ( kind = 4 ) nv

  logical connected(nv)
  integer ( kind = 4 ) d
  integer ( kind = 4 ) e
  integer ( kind = 4 ) i
  integer ( kind = 4 ) :: i4_huge = 2147483647
  integer ( kind = 4 ) mind(nv)
  integer ( kind = 4 ) s
  integer ( kind = 4 ) v

  d = i4_huge
  v = -1

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

  return
end
subroutine init ( nv, ohd )

!*****************************************************************************80
!
!! INIT initializes the problem data.
!
!  Discussion:
!
!    The graph uses 6 nodes, and has the following diagram and
!    distance matrix:
!
!    N0--15--N2-100--N3           0   40   15  Inf  Inf  Inf
!      \      |     /            40    0   20   10   25    6
!       \     |    /             15   20    0  100  Inf  Inf
!        40  20  10             Inf   10  100    0  Inf  Inf
!          \  |  /              Inf   25  Inf  Inf    0    8
!           \ | /               Inf    6  Inf  Inf    8    0
!            N1
!            / \
!           /   \
!          6    25
!         /       \
!        /         \
!      N5----8-----N4
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 July 2010
!
!  Author:
!
!    Original C version by Norm Matloff, CS Dept, UC Davis.
!    This FORTRAN90 version by John Burkardt.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NV, the number of nodes.
!
!    Output, integer ( kind = 4 ) OHD(NV,NV), the distance of the direct
!    link between nodes I and J.
!
  implicit none

  integer ( kind = 4 ) nv

  integer ( kind = 4 ) i
  integer ( kind = 4 ) :: i4_huge = 2147483647
  integer ( kind = 4 ) ohd(nv,nv)

  ohd(1:nv,1:nv) = i4_huge

  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 ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 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, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

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

!*****************************************************************************80
!
!! UPDATE_MIND updates the minimum distance vector.
!
!  Discussion:
!
!    We've just determined the minimum distance to node MV.
!
!    For each node I which is not connected yet,
!    check whether the route from node 0 to MV to I is shorter
!    than the currently known minimum distance.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 July 2010
!
!  Author:
!
!    Original C version by Norm Matloff, CS Dept, UC Davis.
!    This FORTRAN90 version by John Burkardt.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) S, E, the first and last nodes that are
!    to be checked.
!
!    Input, integer ( kind = 4 ) NV, the number of nodes.
!
!    Input, logical CONNECTED(NV), is true for each connected node, whose
!    minimum distance to node 0 has been determined.
!
!    Input, integer ( kind = 4 ) OHD(NV,NV), the distance of the direct link
!    between nodes I and J.
!
!    Input, integer ( kind = 4 ) MV, the node whose minimum distance to node 20
!    has just been determined.
!
!    Input/output, integer ( kind = 4 ) MIND(NV), the currently computed
!    minimum distances from node 1 to each node.  On output, the values for
!    nodes S through E have been updated.
!
  implicit none

  integer ( kind = 4 ) nv

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

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

  return
end


      subroutine get_growth_rate(doubling_time, growth_rate)
        real doubling_time, growth_rate

        if (doubling_time .eq. 0.0) then
            growth_rate = 0.0
        else
          growth_rate = 2.0 ** (1.0 / doubling_time) - 1.0
        endif
      end subroutine get_growth_rate

      subroutine get_beta(gamma, doubling_time, s_c, relative_contact_rate, beta)
        real growth_rate, s_c, relative_contact_rate, doubling_time
        real inv_contact_rate, updated_growth_rate, gamma, beta

        call get_growth_rate(doubling_time, growth_rate)

        inv_contact_rate = 1.0 - relative_contact_rate
        updated_growth_rate = growth_rate + gamma
        beta = updated_growth_rate / s_c * inv_contact_rate
      end subroutine get_beta

      subroutine sir(s_c, i_c, r_c, doubling_time,
     &               relative_contact_rate, gamma, n)
        real relative_contact_rate, doubling_time
        real s_c, i_c, r_c, n, s_n, i_n, r_n, beta, gamma, scale

        call get_beta(gamma, doubling_time, s_c, relative_contact_rate, beta)

        s_n = (-beta * s_c * i_c) + s_c
        i_n = (beta * s_c * i_c - gamma * i_c) + i_c
        r_n = gamma * i_c + r_c

        scale = n / (s_n + i_n + r_n)

        s_c = s_n * scale
        i_c = i_n * scale
        r_c = r_n * scale
      end subroutine sir