module cities
implicit none
real*8, parameter :: inf = 1.d12
contains

subroutine calcDistances(places,distances)
  ! Calculates distances between all posible cities. We deal with a problem of MINIMAL path, so we set the distance between city with itself as infinity (or very large). To calculate the distance from lattitude and longitude, we assume that the Earth is a sphere (not elipsoid). Then, we use the cosine rules for spherical trigonometry: https://en.wikipedia.org/wiki/Spherical_trigonometry#Cosine_rules_and_sine_rules
  ! The angular distance dS between two points of lattitudes fi1 and fi2 and longitudes  difference deltaLong is:
  ! dS = arccos(sin(f1)sin(f2)+cos(fi1)cos(fi2)cos(deltaLong)). Then, the final distance between points is d=R*dS, where R is mean radius of the earth.
  real*8,  intent(in)  :: places(:,:)
  real*8,  intent(out) :: distances(:,:)
  real*8,  parameter   :: R=6371.d0
  integer :: genNo, i, j
  real*8  :: dLong, fi1, fi2, dist
  genNo = size(places,2)
  distances = inf
  do i=1,genNo
    do j=i+1,genNo
      dLong = dabs(places(2,i)-places(2,j))
      fi1 = places(1,i)
      fi2 = places(1,j)
      dist = acos(sin(fi1)*sin(fi2) + cos(fi1)*cos(fi2)*cos(dLong))
      distances(i,j) = dist*R
      distances(j,i) = dist*R
    end do!j
  end do!i
  ! TODO CHECK
end subroutine calcDistances

end module cities


! Created by mus on 28/07/2021.
! l :: dimension of x input
! N :: Polynomial order
! i :: i index in the lagrange polynomial ell
! fac :: resulting polynomial array
! xi :: gll points
! wi :: gll quadrature weights
subroutine lagrangep(N,i,x,fac,l)
    implicit none
    integer, intent(in) :: N, i,l
    real (kind=8), dimension(l),intent(in) :: x
    real (kind=8), dimension(l),intent(out) :: fac
    integer :: j
    real (kind=8) , dimension(N+1) :: xi,wi

    call zwgljd(xi,wi,N+1,0.,0.)
    fac = 1
    do j=0,N
        if (i /= j) then
            fac = fac * ((x - xi(j+1))/(xi(i+1)-xi(j+1)))
        end if
    end do
end subroutine lagrangep


program caf_pi
  implicit none

  integer          :: j
  integer*8        :: N_steps, i_step, hits
  integer          :: seed(2)
  double precision :: x, y
  double precision :: pi_sum, pi
  double precision :: pi_global[*]
  double precision, allocatable :: pi_local(:)

  seed(1) = 17*this_image()
  call random_seed(PUT=seed)

  hits = 0_8
  N_steps = 10000000_8
  do i_step=1,N_steps
    call random_number(x)
    call random_number(y)
    if ( (x*x + y*y) <= 1.d0) then
      hits = hits + 1_8
    endif
  enddo
  pi_global = 4.d0*dble(hits)/dble(N_steps)

  SYNC ALL

  if (this_image() == 1) then
    pi_sum = 0.d0
    do j=1,num_images()
      pi_sum = pi_sum + pi_global[j]
    enddo

    pi = pi_sum / num_images()
    print *, 'pi = ', pi
 endif

end program caf_pi


! Author: Mohammad Asif Zaman
! Original version: April, 2012

program nonlinear_solver

implicit none

integer, parameter :: max_iter = 270, data_type = 10
real(kind = data_type) ::  err_lim = 1e-14, err_store = 0.1, eps = 1e-19
real(kind = data_type), dimension(max_iter) :: x = 13, y = 13, fx = 13, fy = 13, dfx = 13, dfy = 13
integer :: n, iter_store, function_select, method_select

print *, eps

print *, "Enter test function number (1 - 11): "
read *, function_select
print *

print *, "Enter method number (1 - 4): "
print *, "1. NM"
print *, "2. DNM"
print *, "3. JM"
print *, "4. KJ"

read *, method_select
print * , "================================================"
print *

! Initial values for the test functions
select case (function_select)
	case(1) ;	x(1) = 1
	case(2) ;	x(1) = 0
	case(3) ;	x(1) = -1.5
	case(4) ;	x(1) = 2
	case(5) ;	x(1) = 3.5
	case(6) ;	x(1) = 3
	case(7) ;	x(1) = 1
	case(8) ;	x(1) = 1
	case(9); x(1) = 1
	case(10); x(1) = 3.5
	case(11); x(1) = 2
end select

Do n = 1, max_iter

	if (n > 1) then
	if (abs(x(n) - x(n-1)) < err_lim) then
		err_store = abs(x(n) - x(n-1))
		iter_store = n - 1
		exit
	end if
	end if

	select case (method_select)

		case(1)
			! Newton's Method Start
			call test_function(function_select, x(n), fx(n), dfx(n))
			y(n) = x(n) - fx(n)/(dfx(n) + eps)
			x(n+1) = y(n)
			!Neton's Method end

		case(2)
			! Double Newton's Method Start
			call test_function(function_select, x(n), fx(n), dfx(n))
			y(n) = x(n) - fx(n)/(dfx(n) + eps)
			call test_function(function_select, y(n), fy(n), dfy(n))
			x(n + 1) = y(n) - fy(n)/(dfy(n) + eps)
			! Double Neton's Method end

		case(3)
			! Jarratt Method Start
			call test_function(function_select, x(n), fx(n), dfx(n))
			y(n) = x(n) - (2/3) * fx(n) / dfx(n)
			call test_function(function_select, y(n), fy(n), dfy(n))
			x(n + 1) = x(n) - (1 - (3/2)*(dfy(n) - dfx(n))/(3*dfy(n) - dfx(n)))*(fx(n)/dfx(n))
			! Jarratt Method End

		case(4)
			! Kou Jesheng's Method Start
			call test_function(function_select, x(n), fx(n), dfx(n))
			y(n) = x(n) - fx(n)/(dfx(n) + eps)
			call test_function(function_select, y(n), fy(n), dfy(n))
			x(n+1) = x(n) - (fx(n)**2 + fy(n)**2)/( dfx(n)*(fx(n) - fy(n)) + eps)
			! Kog Jesheng's Method End

	end select

end do

Do n = 1, max_iter
	!if (fx(n) == 0) exit			! The exit condition,
	!print *, x(n),  "  " ,fx(n)
end do

print *
Print *, "================================================"
print *, "Summary Result"
Print *, "================================================"

Print *, "Test function number       = ", function_select
print *, "Method number              = ", method_select
Print *, "================================================"
print *
print *, "Number of iterations       = ", iter_store
print *, "Defined Error limit        = ", err_lim
print *, "Final value of error       = ", err_store
print *, "Calculated root            = ", x(iter_store)
print *, "f(x)                       = ", fx(iter_store)
print *
Print *, "================================================"

 contains

  ! Test functions
  subroutine test_function(function_select, x, fx, dfx)
    integer, intent(in) :: function_select
    !integer, parameter, intent(in) ::data_type
    real(kind = data_type) , intent(in) :: x
    real(kind = data_type) , intent(out) :: fx, dfx

    select case (function_select)
	case(1);    fx = x**3 + 4*x**2- 10;    dfx = 3*x**2 + 8*x
	case(2);    fx = x**2 - exp(x) - 3*x + 2;    dfx = 2*x - exp(x) - 3
	case(3)
			  fx = x*exp(x**2) - (sin(x))**2 + 3*cos(x) + 5
 			  dfx = x*exp(x**2)*2*x + exp(x**2) - 2*sin(x)*cos(x) - 3*sin(x)
	case(4)
			  fx = exp(x)*sin(x) + log(x**2 + 1)
			  dfx = exp(x)*cos(x) + sin(x)*exp(x) + (1/(x**2 + 1))* 2*x

	case(5);    fx = (x - 1)**2 - 1; dfx = 2*(x - 1);
	case(6);    fx = (x - 1)**3 - 2;    dfx = 3*(x - 1)**2
	case(7);    fx = 10*x*exp(-x**2) - 1; dfx = 10*x*exp(-x**2)*(-2*x) + 10*exp(-x**2)
	case(8);    fx = cos(x) - x;    dfx = -sin(x) - 1
	case(9);    fx = (sin(x))**2 - x**2 + 1;    dfx = 2*sin(x)*cos(x) - 2*x
	case(10);  fx = exp(x**2 + 7*x - 30) - 1;    dfx = exp(x**2 + 7*x - 30)*(2*x + 7)
	case(11);  fx = (x + 2)*exp(x) - 1; dfx = (x + 2)*exp(x) + exp(x)

    end select

  end subroutine test_function

end program nonlinear_solver


!##############################################################################
! PROGRAM inversion
!
! ## Invert a matrix using LU-decomposition
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program inversion

    use toolbox

    implicit none
    integer :: i, j
    real*8 :: A(3, 3), Ainv(3, 3), b(3)

    ! set up matrix and vector
    A(1, :) = (/ 2d0,  0d0,  1d0/)
    A(2, :) = (/ 0d0,  4d0,  1d0/)
    A(3, :) = (/ 1d0,  1d0,  2d0/)
    b       = (/30d0, 40d0, 30d0/)

    ! invert A
    Ainv = lu_invert(A)

    ! calculate solution
    b = matmul(Ainv, b)

    ! output
    write(*,'(a,3f7.2/)')'    x = ', (b(j),j=1,3)
    write(*,'(a,3f7.2/,2(8x,3f7.2/))') &
        ' A^-1 = ',((Ainv(i,j),j=1,3),i=1,3)

end program


FUNCTION gammln(xx)
REAL*8 gammln,xx
INTEGER*4 j
REAL*8 ser,stp,tmp,x,y,cof(6)
SAVE cof,stp
DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,&
	24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,&
	-.5395239384953d-5,2.5066282746310005d0/
x=xx
y=x
tmp=x+5.5d0
tmp=(x+0.5d0)*log(tmp)-tmp
ser=1.000000000190015d0
do j=1,6
	y=y+1.d0
	ser=ser+cof(j)/y
end do
gammln=tmp+log(stp*ser/x)
return
END


!==============================================================================!
  program Parabolic
!------------------------------------------------------------------------------!
  implicit none
!------------------------------------------------------------------------------!
  real    :: x_s =  -0.005
  real    :: x_e =   0.005
  real    :: bulk = -1.0
  integer :: i
  integer :: n = 41

  real    :: x_l, x_r, x_c, y_l, y_r, y_c, dx, lx, integral, area
!==============================================================================!

  print *, '#=================='
  print *, '# Number of points '
  print *, '#=================='
  print *, n

  print *, '#================================='
  print *, '#   Coordinate      Velocity'
  print *, '#================================='

  ! distance between two nodes
  lx = (x_e - x_s)
  dx = lx / (n-1)

  ! Print profile and compute integral
  area     = 0.0
  integral = 0.0
  do i = 1, n
    x_l  = (x_s + dx * (i-1))  ! x left
    x_r  = (x_s + dx *  i   )  ! x rigth
    y_l = (1.0 - ((x_l/lx) ** 2 / 0.25)) * bulk *  1.5
    y_r = (1.0 - ((x_r/lx) ** 2 / 0.25)) * bulk *  1.5

    print '(2es16.5)', x_l, y_l

    if(i < n) then
      y_c      = (y_l + y_r) * 0.5
      area     = area     + dx
      integral = integral + y_c * dx
    end if
  end do

  print *, '# Bulk velocity is: ', integral / area

  ! Compute integral

  end program


	FUNCTION bessk_s(n,x)
	use mo_kind
          use mo_nrutil, ONLY : assert
	use mo_nr, ONLY : bessk0,bessk1
	IMPLICIT NONE
	INTEGER(I4), INTENT(IN) :: n
	REAL(SP), INTENT(IN) :: x
	REAL(SP) :: bessk_s
	INTEGER(I4) :: j
	REAL(SP) :: bk,bkm,bkp,tox
	call assert(n >= 2, x > 0.0, 'bessk_s args')
	tox=2.0_sp/x
	bkm=bessk0(x)
	bk=bessk1(x)
	do j=1,n-1
		bkp=bkm+j*tox*bk
		bkm=bk
		bk=bkp
	end do
	bessk_s=bk
	END FUNCTION bessk_s

	FUNCTION bessk_v(n,x)
	use mo_kind
          use mo_nrutil, ONLY : assert
	use mo_nr, ONLY : bessk0,bessk1
	IMPLICIT NONE
	INTEGER(I4), INTENT(IN) :: n
	REAL(SP), DIMENSION(:), INTENT(IN) :: x
	REAL(SP), DIMENSION(size(x)) :: bessk_v
	INTEGER(I4) :: j
	REAL(SP), DIMENSION(size(x)) :: bk,bkm,bkp,tox
	call assert(n >= 2, all(x > 0.0), 'bessk_v args')
	tox=2.0_sp/x
	bkm=bessk0(x)
	bk=bessk1(x)
	do j=1,n-1
		bkp=bkm+j*tox*bk
		bkm=bk
		bk=bkp
	end do
	bessk_v=bk
	END FUNCTION bessk_v

	FUNCTION dbessk_s(n,x)
	use mo_kind
          use mo_nrutil, ONLY : assert
	use mo_nr, ONLY : bessk0,bessk1
	IMPLICIT NONE
	INTEGER(I4), INTENT(IN) :: n
	REAL(DP), INTENT(IN) :: x
	REAL(DP) :: dbessk_s
	INTEGER(I4) :: j
	REAL(DP) :: bk,bkm,bkp,tox
	call assert(n >= 2, x > 0.0, 'dbessk_s args')
	tox=2.0_dp/x
	bkm=bessk0(x)
	bk=bessk1(x)
	do j=1,n-1
		bkp=bkm+j*tox*bk
		bkm=bk
		bk=bkp
	end do
	dbessk_s=bk
	END FUNCTION dbessk_s

	FUNCTION dbessk_v(n,x)
	use mo_kind
          use mo_nrutil, ONLY : assert
	use mo_nr, ONLY : bessk0,bessk1
	IMPLICIT NONE
	INTEGER(I4), INTENT(IN) :: n
	REAL(DP), DIMENSION(:), INTENT(IN) :: x
	REAL(DP), DIMENSION(size(x)) :: dbessk_v
	INTEGER(I4) :: j
	REAL(DP), DIMENSION(size(x)) :: bk,bkm,bkp,tox
	call assert(n >= 2, all(x > 0.0), 'dbessk_v args')
	tox=2.0_dp/x
	bkm=bessk0(x)
	bk=bessk1(x)
	do j=1,n-1
		bkp=bkm+j*tox*bk
		bkm=bk
		bk=bkp
	end do
	dbessk_v=bk
	END FUNCTION dbessk_v


COMPLEX FUNCTION Pade( x0, x, f, N, ErrorMessage )

  !     Computes the [MU, NU] Pade approximant at x0, where
  !        MU = [M/2], NU = M - MU and M = N - 1
  !
  !     FORMULAS TAKEN FROM BURLISCH AND STOER
  !        NUMERISCHE MATHEMATIK 8:1-13(1966)
  !
  !     N IS THE NUMBER OF POINTS USED.
  !     x CONTAINS THE INDEPENDENT VARIABLE
  !     f CONTAINS THE FUNCTIONAL VALUES AT EACH x
  !     x0 IS THE POINT AT WHICH THE APPROXIMATION IS TO BE CALCULATED
  !
  !     Note much wasted space in this implementation ...
  !
  !     Michael Porter, 11 September 1985

  IMPLICIT NONE
  INTEGER, INTENT( IN ) :: N   ! order of the Pade approximant
  COMPLEX, INTENT( IN ) :: x0, x( N ), f( N )  ! x, y values of the polynomila
  CHARACTER (LEN=80), INTENT( OUT ) :: ErrorMessage
  !INTEGER              :: II( 1 )
  INTEGER               :: K, M, Nearest
  COMPLEX               :: RDT, WDen, CNum, CDen, D( N, N ), C( N, N ), H( N )

  ErrorMessage = '      '
  H = x - x0   ! distance between x0 and every point in x

  ! Quick return if x lies "on" a data point
  Nearest = 1
  !II      = MINLOC( ABS( H ) )
  !Nearest = II( 1 )
  !IF ( ABS( H( Nearest ) ) < 100 * SPACING( REAL( x0 ) ) ) THEN
  !   Pade = f( Nearest )
  !   RETURN
  !ENDIF

  ! Recursion for solution
  DO M = 1, N
     D( 1, M ) = f( M ) + EPSILON( REAL( x0 ) )  ! perturbation to avoid 0/0 condition
     C( 1, M ) = f( M )

     IF ( M >= 2 ) THEN

        DO K = 1, M - 1
           RDT  = H( M - K ) / H( M ) * D( K, M - K )
           CNum = C( K, M - K + 1 ) - D( K, M - K )
           CDen = RDT - C( K, M - K + 1 )

           IF ( ABS( CNum ) > 1.0E10 * ABS( CDen ) ) THEN
              ErrorMessage = 'ERROR: Nearly-singular matrix in Pade'
              Pade = f( Nearest )
              RETURN
           ENDIF

           WDen = CNum / CDen
           D( K + 1, M - K ) = C( K, M - K + 1 ) * WDen
           C( K + 1, M - K ) = RDT * WDen
        END DO
     ENDIF
  END DO

  ! Sum diagonal elements to get interpolate
  Pade = 0.0
  DO K = 1, N
     Pade = Pade + D( K, N - K + 1 )
  END DO

END FUNCTION Pade


C
C NLP-UNCONSTRAINED-CLI/NELDER-MEAD/__ORIG/SRC/NELMIN.F
C =============================================================================
C NONLINEAR OPTIMIZATION ALGORITHMS MULTILANG. VERSION 0.1
C =============================================================================
C NONLINEAR PROGRAMMING ALGORITHMS AS THE (UN-)CONSTRAINED MINIMIZATION
C PROBLEMS WITH THE FOCUS ON THEIR NUMERICAL EXPRESSION USING VARIOUS
C PROGRAMMING LANGUAGES.
C
C THIS IS THE NELDER-MEAD NONLINEAR UNCONSTRAINED MINIMIZATION ALGORITHM.
C =============================================================================
C WRITTEN BY RADISLAV (RADICCHIO) GOLUBTSOV, 2015-2020
C
C THIS IS FREE AND UNENCUMBERED SOFTWARE RELEASED INTO THE PUBLIC DOMAIN.
C
C ANYONE IS FREE TO COPY, MODIFY, PUBLISH, USE, COMPILE, SELL, OR
C DISTRIBUTE THIS SOFTWARE, EITHER IN SOURCE CODE FORM OR AS A COMPILED
C BINARY, FOR ANY PURPOSE, COMMERCIAL OR NON-COMMERCIAL, AND BY ANY
C MEANS.
C
C (SEE THE LICENSE FILE AT THE TOP OF THE SOURCE TREE.)

C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C *                                                                           *
C *             SEE THE NELMIN.TXT.C FILE FOR DETAILS DESCRIPTION.            *
C *                                                                           *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

C     === THE USER-SUPPLIED OBJECTIVE FUNCTION F(X).
      FUNCTION F(X)
          IMPLICIT NONE

C         CONSTANT. THE MAXIMUM NUMBER OF VARIABLES.
          INTEGER    VARS
          PARAMETER (VARS = 20)

C         RETURN VAL. THE OBJECTIVE FUNCTION VALUE.
          DOUBLE PRECISION F

C         ARG. THE POINT AT WHICH F(X) SHOULD BE EVALUATED.
          DOUBLE PRECISION X(VARS)

#ifndef WOODS
C     ROSENBROCK'S CLASSIC PARABOLIC VALLEY ('BANANA') FUNCTION.
          DOUBLE PRECISION A
          DOUBLE PRECISION B

          A = X(2) - X(1) ** 2
          B = 1    - X(1)

          F = 100 * (A ** 2) + (B ** 2)
#else
C     WOODS -- A LA MORE, GARBOW AND HILLSTROM (TOMS ALGORITHM 566).
          DOUBLE PRECISION S1
          DOUBLE PRECISION S2
          DOUBLE PRECISION S3
          DOUBLE PRECISION T1
          DOUBLE PRECISION T2
          DOUBLE PRECISION T3
          DOUBLE PRECISION T4
          DOUBLE PRECISION T5

          S1 = X(2) - X(1) ** 2
          S2 = 1    - X(1)
          S3 = X(2) - 1

          T1 = X(4) - X(3) ** 2
          T2 = 1    - X(3)
          T3 = X(4) - 1

          T4 = S3 + T3
          T5 = S3 - T3

          F = 100 * (S1 ** 2) + (S2 ** 2)
     *       + 90 * (T1 ** 2) + (T2 ** 2)
     *       + 10 * (T4 ** 2) + (T5 ** 2) / 10
#endif
          RETURN
      END

C     === MAIN OPTIMIZATION SUBROUTINE.
C     THE NELMIN SUBROUTINE ITSELF (NELDER-MEAD MINIMIZATION).
      SUBROUTINE NELMIN(   F,      N,  START,   XMIN, YNEWLO, REQMIN,
     *                  STEP, KONVGE, KCOUNT, ICOUNT, NUMRES, IFAULT)

          IMPLICIT NONE

C         CONSTANT. THE MAXIMUM NUMBER OF VARIABLES.
          INTEGER    VARS
          PARAMETER (VARS = 20)

C         CONSTANT. THE REFLECTION COEFFICIENT.
          DOUBLE PRECISION RCOEFF
          PARAMETER       (RCOEFF = 1.0D+00)

C         CONSTANT. THE EXTENSION COEFFICIENT.
          DOUBLE PRECISION ECOEFF
          PARAMETER       (ECOEFF = 2.0D+00)

C         CONSTANT. THE CONTRACTION COEFFICIENT.
          DOUBLE PRECISION CCOEFF
          PARAMETER       (CCOEFF = 0.5D+00)

C         CONSTANT. THE OPTIMALITY FACTOR.
          DOUBLE PRECISION EPS
          PARAMETER       (EPS = 0.001D+00)

C         ARG. THE OBJECTIVE FUNCTION F(X).
          DOUBLE PRECISION F
          EXTERNAL         F

C         ARG. THE NUMBER OF VARIABLES.
          INTEGER N

C         ARG. THE STARTING POINT FOR THE ITERATION.
          DOUBLE PRECISION START(VARS)

C         ARG. THE COORDINATES OF THE POINT WHICH IS ESTIMATED
C              TO MINIMIZE THE FUNCTION.
          DOUBLE PRECISION XMIN(VARS)

C         ARG. THE MINIMUM VALUE OF THE FUNCTION.
          DOUBLE PRECISION YNEWLO

C         ARG. THE TERMINATING LIMIT FOR THE VARIANCE
C              OF FUNCTION VALUES.
          DOUBLE PRECISION REQMIN

C         ARG. THE SIZE AND SHAPE OF THE INITIAL SIMPLEX.
          DOUBLE PRECISION STEP(VARS)

C         ARG. THE CONVERGENCE CHECK.
          INTEGER KONVGE

C         ARG. THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS.
          INTEGER KCOUNT

C         ARG. THE NUMBER OF FUNCTION EVALUATIONS USED.
          INTEGER ICOUNT

C         ARG. THE NUMBER OF RESTARTS.
          INTEGER NUMRES

C         ARG. THE ERROR INDICATOR.
          INTEGER IFAULT

          INTEGER JCOUNT
          INTEGER NN
          INTEGER I
          INTEGER J
          INTEGER ILO
          INTEGER IHI
          INTEGER L

          DOUBLE PRECISION DN
          DOUBLE PRECISION DNN
          DOUBLE PRECISION DEL
          DOUBLE PRECISION RQ
          DOUBLE PRECISION P(VARS, VARS + 1)
          DOUBLE PRECISION Y(VARS + 1)
          DOUBLE PRECISION X
          DOUBLE PRECISION YLO
          DOUBLE PRECISION Z
          DOUBLE PRECISION PBAR(VARS)
          DOUBLE PRECISION PSTAR(VARS)
          DOUBLE PRECISION YSTAR
          DOUBLE PRECISION P2STAR(VARS)
          DOUBLE PRECISION Y2STAR

C         CHECK THE INPUT PARAMETERS.
          IF (REQMIN .LE. 0.0D+00) THEN
              IFAULT = 1

              RETURN
          END IF

          IF (N .LT. 1) THEN
              IFAULT = 1

              RETURN
          END IF

          IF (VARS .LT. N) THEN
              IFAULT = 1

              RETURN
          END IF

          IF (KONVGE .LT. 1) THEN
              IFAULT = 1

              RETURN
          END IF

          ICOUNT = 0
          NUMRES = 0

          JCOUNT = KONVGE
          DN     = DBLE(N)
          NN     = N + 1
          DNN    = DBLE(NN)
          DEL    = 1.0D+00
          RQ     = REQMIN * DN

C         CONSTRUCTION OF INITIAL SIMPLEX.
1000      CONTINUE

          DO 10 I = 1, N
              P(I, NN) = START(I)
10        CONTINUE

          Y(NN) = F(START)

          DO 20 J = 1, N
              X        = START(J)
              START(J) = START(J) + STEP(J) * DEL

              DO 30 I = 1, N
                  P(I, J) = START(I)
30            CONTINUE

              Y(J) = F(START)

              START(J) = X
20        CONTINUE

          ICOUNT = ICOUNT + NN

C         THE SIMPLEX CONSTRUCTION IS COMPLETE.

C         FIND HIGHEST AND LOWEST Y VALUES.
C         YNEWLO = Y(IHI) INDICATES THE VERTEX OF THE SIMPLEX
C         TO BE REPLACED.
          YLO = Y(1)
          ILO =   1

          DO 40 I = 2, NN
              IF (Y(I) .LT. YLO) THEN
                  YLO = Y(I)
                  ILO = I
              END IF
40        CONTINUE

2000      CONTINUE

          YNEWLO = Y(1)
          IHI    =   1

          DO 50 I = 2, NN
              IF (YNEWLO .LT. Y(I)) THEN
                  YNEWLO = Y(I)
                  IHI    = I
              END IF
50        CONTINUE

C         CALCULATE PBAR, THE CENTROID OF THE SIMPLEX VERTICES
C         EXCEPTING THE VERTEX WITH Y VALUE YNEWLO.
          DO 60 I = 1, N
              Z = 0.0D+00

              DO 70 J = 1, NN
                  Z = Z + P(I, J)
70            CONTINUE

              Z       = Z - P(I, IHI)
              PBAR(I) = Z / DN
60        CONTINUE

C         REFLECTION THROUGH THE CENTROID.
          DO 80 I = 1, N
              PSTAR(I) = PBAR(I) + RCOEFF * (PBAR(I) - P(I, IHI))
80        CONTINUE

          YSTAR = F(PSTAR)

          ICOUNT = ICOUNT + 1

C         SUCCESSFUL REFLECTION, SO EXTENSION.
          IF (YSTAR .LT. YLO) THEN
              DO 90 I = 1, N
                  P2STAR(I) = PBAR(I) + ECOEFF * (PSTAR(I) - PBAR(I))
90            CONTINUE

              Y2STAR = F(P2STAR)

              ICOUNT = ICOUNT + 1

C             CHECK EXTENSION.
              IF (YSTAR .LT. Y2STAR) THEN
                  DO 100 I = 1, N
                      P(I, IHI) = PSTAR(I)
100               CONTINUE

                  Y(IHI) = YSTAR
C             RETAIN EXTENSION OR CONTRACTION.
              ELSE
                  DO 110 I = 1, N
                      P(I, IHI) = P2STAR(I)
110               CONTINUE

                  Y(IHI) = Y2STAR
              END IF
C         NO EXTENSION.
          ELSE
              L = 0

              DO 120 I = 1, NN
                  IF (YSTAR .LT. Y(I)) THEN
                      L = L + 1
                  END IF
120           CONTINUE

              IF (1 .LT. L) THEN
                  DO 130 I = 1, N
                      P(I, IHI) = PSTAR(I)
130               CONTINUE

                  Y(IHI) = YSTAR
C             CONTRACTION ON THE Y(IHI) SIDE OF THE CENTROID.
              ELSE IF (L .EQ. 0) THEN
                  DO 140 I = 1, N
                      P2STAR(I) = PBAR(I)
     *                          + CCOEFF * (P(I, IHI) - PBAR(I))
140               CONTINUE

                  Y2STAR = F(P2STAR)

                  ICOUNT = ICOUNT + 1

C                 CONTRACT THE WHOLE SIMPLEX.
                  IF (Y(IHI) .LT. Y2STAR) THEN
                      DO 150 J = 1, NN
                          DO 160 I = 1, N
                              P(I, J) = (P(I, J) + P(I, ILO)) * CCOEFF
                              XMIN(I) =  P(I, J)
160                       CONTINUE

                          Y(J) = F(XMIN)
150                   CONTINUE

                      ICOUNT = ICOUNT + NN

                      IF (KCOUNT .LT. ICOUNT) THEN
                          GO TO 3000
                      END IF

                      YLO = Y(1)
                      ILO =   1

                      DO 170 I = 2, NN
                          IF (Y(I) .LT. YLO) THEN
                              YLO = Y(I)
                              ILO = I
                          END IF
170                   CONTINUE

                      GO TO 2000
C                 RETAIN CONTRACTION.
                  ELSE
                      DO 180 I = 1, N
                          P(I, IHI) = P2STAR(I)
180                   CONTINUE

                      Y(IHI) = Y2STAR
                  END IF
C             CONTRACTION ON THE REFLECTION SIDE OF THE CENTROID.
              ELSE IF (L .EQ. 1) THEN
                  DO 190 I = 1, N
                      P2STAR(I) = PBAR(I)
     *                          + CCOEFF * (PSTAR(I) - PBAR(I))
190               CONTINUE

                  Y2STAR = F(P2STAR)

                  ICOUNT = ICOUNT + 1

C                 RETAIN REFLECTION?
                  IF (Y2STAR .LE. YSTAR) THEN
                      DO 200 I = 1, N
                          P(I, IHI) = P2STAR(I)
200                   CONTINUE

                      Y(IHI) = Y2STAR
                  ELSE
                      DO 210 I = 1, N
                          P(I, IHI) = PSTAR(I)
210                   CONTINUE

                      Y(IHI) = YSTAR
                  END IF
              END IF
          END IF

C         CHECK IF YLO IMPROVED.
          IF (Y(IHI) .LT. YLO) THEN
              YLO = Y(IHI)
              ILO = IHI
          END IF

          JCOUNT = JCOUNT - 1

          IF (JCOUNT .NE. 0) THEN
              GO TO 2000
          END IF

C         CHECK TO SEE IF MINIMUM REACHED.
          IF (ICOUNT .LE. KCOUNT) THEN
              JCOUNT = KONVGE
              Z      = 0.0D+00

              DO 220 I = 1, NN
                  Z = Z + Y(I)
220           CONTINUE

              X = Z / DNN
              Z = 0.0D+00

              DO 230 I = 1, NN
                  Z = Z + (Y(I) - X) ** 2
230           CONTINUE

              IF (RQ .LT. Z) THEN
                  GO TO 2000
              END IF
          END IF

C         FACTORIAL TESTS TO CHECK THAT YNEWLO IS A LOCAL MINIMUM.
3000      CONTINUE

          DO 240 I = 1, N
              XMIN(I) = P(I, ILO)
240       CONTINUE

          YNEWLO = Y(ILO)

          IF (KCOUNT .LT. ICOUNT) THEN
              IFAULT = 2

              RETURN
          END IF

          IFAULT = 0

          DO 250 I = 1, N
              DEL     = STEP(I) * EPS
              XMIN(I) = XMIN(I) + DEL

              Z = F(XMIN)

              ICOUNT = ICOUNT + 1

              IF (Z .LT. YNEWLO) THEN
                  IFAULT = 2

                  GO TO 4000
              END IF

              XMIN(I) = XMIN(I) - (DEL * 2)

              Z = F(XMIN)

              ICOUNT = ICOUNT + 1

              IF (Z .LT. YNEWLO) THEN
                  IFAULT = 2

                  GO TO 4000
              END IF

              XMIN(I) = XMIN(I) + DEL
250       CONTINUE

4000      CONTINUE

          IF (IFAULT .EQ. 0) THEN
              RETURN
          END IF

C         RESTART THE PROCEDURE.
          DO 260 I = 1, N
              START(I) = XMIN(I)
260       CONTINUE

          DEL    = EPS
          NUMRES = NUMRES + 1

          GO TO 1000
      END

C     === MAIN PROGRAM.
      PROGRAM AMOEBA
          IMPLICIT NONE

C         CONSTANT. THE MAXIMUM NUMBER OF VARIABLES.
          INTEGER    VARS
          PARAMETER (VARS = 20)

          INTEGER N
          INTEGER KONVGE
          INTEGER KCOUNT
          INTEGER I
          INTEGER ICOUNT
          INTEGER NUMRES
          INTEGER IFAULT

          DOUBLE PRECISION START(VARS)
          DOUBLE PRECISION REQMIN
          DOUBLE PRECISION STEP(VARS)
          DOUBLE PRECISION YNEWLO
          DOUBLE PRECISION XMIN(VARS)

C         PROTO REF. THE OBJECTIVE FUNCTION F(X).
          DOUBLE PRECISION F

#ifndef WOODS
C     STARTING GUESS FOR ROSENBROCK'S TEST FUNCTION.
          PRINT 10
10        FORMAT (/,   'TEST01',
     *            /2X, 'Apply NELMIN to ROSENBROCK function.')

          N        =  2
          START(1) = -1.2
          START(2) =  1.0
#else
C     STARTING GUESS TEST PROBLEM 'WOODS'.
          PRINT 50
50        FORMAT (/,   'TEST05',
     *            /2X, 'Apply NELMIN to WOODS function.')

          N        =  4
          START(1) = -3.0
          START(2) = -1.0
          START(3) = -3.0
          START(4) = -1.0
#endif

          REQMIN  = 1.0D-08
          STEP(1) = 1.0
          STEP(2) = 1.0

#ifdef WOODS
          STEP(3) = 1.0
          STEP(4) = 1.0
#endif

C         KONVGE AND KCOUNT HAVE SAME VALUES FOR ALL TEST PRBMS:
C         SHOULD THEY BE VARIED?
          KONVGE  = 10
          KCOUNT  = 500

          PRINT 60
60        FORMAT (/2X, 'Starting point X:', /)

          DO 70 I = 1, N
              PRINT 80, START(I), START(I)
80            FORMAT (            2X, G14.6, 12X, '->', 4X, F20.12)
70        CONTINUE

          YNEWLO = F(START)

          PRINT 90, YNEWLO, YNEWLO
90        FORMAT (/2X, 'F(X)  =', 1X, G14.6,  4X, '->', 4X, F20.12)

          CALL NELMIN(   F,      N,  START,   XMIN, YNEWLO, REQMIN,
     *                STEP, KONVGE, KCOUNT, ICOUNT, NUMRES, IFAULT)

          PRINT 100, IFAULT
100       FORMAT (/2X, 'Return code IFAULT   =', 1X, I8)

          PRINT 110
110       FORMAT (/2X, 'Estimate of minimizing value X*:', /)

          DO 120 I = 1, N
              PRINT 130, XMIN(I), XMIN(I)
130           FORMAT (            2X, G14.6, 12X, '->', 4X, F20.12)
120       CONTINUE

          PRINT 140, YNEWLO, YNEWLO
140       FORMAT (/2X, 'F(X*) =', 1X, G14.6,  4X, '->', 4X, F20.12)

          PRINT 150, ICOUNT
150       FORMAT (/2X, 'Number of iterations =', 1X, I8)

          PRINT 160, NUMRES
160       FORMAT ( 2X, 'Number of restarts   =', 1X, I8)
      END


!
! ej6_c.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! 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; either version 2 of the License, or
! (at your option) any later version.
!
! 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., 51 Franklin Street, Fifth Floor, Boston,
! MA 02110-1301, USA.
!
!
!
PROGRAM ej6_c

use precision, pr => dp

IMPLICIT NONE

integer :: i, j, k
integer, parameter :: n = 10000
real(pr) :: h, t0, tf, x0, v0, t, error, exacta, vexacta
real(pr) :: k1(2), k2(2), k3(2), k4(2), xi(2), xi_1(2)

open(unit=10, file='ej6_c.dat', status='UNKNOWN', action='WRITE')

write(10, *) "#  t   x   v   err  exact  vexact"

!condiciones iniciales
t0 = 0._pr
tf = 10._pr
x0 = 1._pr
v0 = 1._pr

h = (tf - t0)/real(n, pr)

! para t == 0
xi(1) = x0
xi(2) = v0
write(10, *) t0, x0, v0, 0._pr, x0, v0

do i = 1, n
    xi_1 = xi
    ! integro en v
    k1 = h * f(xi_1)
    k2 = h * f(xi_1 + k1*0.5_pr)
    k3 = h * f(xi_1 + k2*0.5_pr)
    k4 = h * f(xi_1 + k3)

    xi = xi_1 + (k1 + 2._pr * k2 + 2._pr * k3 + k4) / 6._pr

    t = t0 + i * h
    exacta = sin(t) + cos(t)
    vexacta = cos(t) - sin(t)
    error = abs(xi(1) - exacta)
    write(10, *) t, xi(1), xi(2), error, exacta, vexacta
end do

CONTAINS

function f(x)
integer(kind=8), parameter :: k = 1, n = 2
real (pr) :: f(n)
real (pr), intent(in) :: x(n)

    f(1) = x(2)
    f(2) = -k*x(1)

end function f

END PROGRAM ej6_c


MODULE wlGridModule

  USE wlKindModule, ONLY: dp

  IMPLICIT NONE
  PRIVATE

  TYPE, PUBLIC :: GridType
    CHARACTER(LEN=32) :: Name
    CHARACTER(LEN=32) :: Unit
    INTEGER  :: nPoints
    INTEGER  :: LogInterp
    REAL(dp) :: minValue
    REAL(dp) :: maxValue
    REAL(dp), DIMENSION(:), ALLOCATABLE :: Values
  END TYPE

  PUBLIC :: MakeLinearGrid
  PUBLIC :: MakeLogGrid
  PUBLIC :: AllocateGrid
  PUBLIC :: DeallocateGrid
  PUBLIC :: DescribeGrid

CONTAINS

  SUBROUTINE MakeLinearGrid( LowerBound, UpperBound, nPoints, Grid )

    INTEGER,                      INTENT(in)  :: nPoints
    REAL(dp),                     INTENT(in)  :: LowerBound
    REAL(dp),                     INTENT(in)  :: UpperBound
    REAl(dp), DIMENSION(nPoints), INTENT(out) :: Grid

    INTEGER  :: i
    REAL(dp) :: BinWidth

    IF ( nPoints == 1 ) THEN
      Grid(1) = LowerBound
      RETURN
    END IF

    BinWidth = ( UpperBound - LowerBound ) / DBLE( nPoints - 1 )

    DO i = 1, nPoints
      Grid(i) = LowerBound + DBLE( i - 1 ) * BinWidth
    END DO

  END SUBROUTINE MakeLinearGrid

  SUBROUTINE MakeLogGrid( LowerBound, UpperBound, nPoints, Grid )

    Integer, INTENT(in)      :: nPoints
    REAL(dp), INTENT(in)     :: LowerBound
    Real(dp), INTENT(in)     :: UpperBound

    REAl(dp), DIMENSION(nPoints), INTENT(out)   :: Grid

    Integer  :: m
    REAL(dp) :: ScaleFactor

    IF ( nPoints == 1 ) THEN
      Grid(1) = LowerBound
      RETURN
    END IF

    ScaleFactor &
      = EXP( LOG( UpperBound / LowerBound ) / DBLE( nPoints - 1 ) )

    Grid(1) = LowerBound

    DO m = 2, nPoints - 1
      Grid(m) = Grid(m-1) * ScaleFactor
    END DO

    Grid(nPoints) = UpperBound

  END SUBROUTINE MakeLogGrid

  SUBROUTINE AllocateGrid( Grid, nPoints )

    TYPE(GridType), INTENT(inout) :: Grid
    INTEGER, INTENT(in)                 :: nPoints

    Grid % nPoints = nPoints

    ALLOCATE( Grid % Values(nPoints) )

  END SUBROUTINE AllocateGrid

  SUBROUTINE DeAllocateGrid( Grid )

    TYPE(GridType), INTENT(inout) :: Grid

    DEALLOCATE( Grid % Values )

  END SUBROUTINE DeAllocateGrid

  SUBROUTINE DescribeGrid( Grid )

    TYPE(GridType), INTENT(in) :: Grid

    INTEGER :: i

    WRITE(*,*)
    WRITE(*,'(A4,A)') '', 'Grid:'
    WRITE(*,*)

    WRITE(*,'(A6,A12,A)') &
      ' ', 'Name      = ', TRIM( Grid % Name )
    WRITE(*,'(A6,A12,A)') &
      ' ', 'Unit      = ', TRIM( Grid % Unit )
    WRITE(*,'(A6,A12,ES10.3E2)') &
      ' ', 'Min Value = ', Grid % minValue
    WRITE(*,'(A6,A12,ES10.3E2)') &
      ' ', 'Max Value = ', Grid % maxValue
    WRITE(*,'(A6,A12,I4.4)') &
      ' ', 'nPoints   = ', Grid % nPoints
    IF ( Grid % LogInterp == 1 ) THEN
      WRITE (*,'(A6,A27)') &
          ' ', 'Grid Logarithmically Spaced'
    ELSE
      WRITE (*,'(A6,A20)') &
          ' ', 'Grid Linearly Spaced'
    END IF
    WRITE(*,*)

    DO i = 1, Grid % nPoints
      WRITE(*,'(A8,A6,I4.4,A4,ES10.3E2)') &
        ' ','Value(', i, ') = ', Grid % Values(i)
    END DO

  END SUBROUTINE DescribeGrid

END MODULE wlGridModule


program main
    use mpi
    implicit none
    integer :: ntasks, rank, ierr
    integer, allocatable :: status(:)
    integer :: i, n, clock
    integer, allocatable :: seed(:)
    integer(4) :: n_in = 0, n_tot = 100000000
    real(8), parameter :: l = 0.d0, r = 1.d0, b = -1.d0, t = 2.d0
    real(8) :: x, y, y_real
    real(8) :: integral_local, integral

    ! initialize the MPI environment
    call MPI_INIT(ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
    allocate(status(MPI_STATUS_SIZE))

    if (rank == 0) then
        call SYSTEM_CLOCK(clock)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
        do i = 1, ntasks - 1
            call RANDOM_NUMBER(x)
            clock = clock + Int(x * 1000000)
            call MPI_SEND(clock, 1, MPI_INTEGER, i, i, MPI_COMM_WORLD, ierr)
        end do
    else
        call MPI_RECV(clock, 1, MPI_INTEGER, 0, rank, MPI_COMM_WORLD, status, ierr)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
    end if

    do i = 1, n_tot
        call RANDOM_NUMBER(x)
        x = x * (r - l) + l
        call RANDOM_NUMBER(y)
        y = y * (t - b) + b
        call func(x, y_real)
        if (y < y_real) then
            n_in = n_in + 1
        end if
    end do
    integral_local = (t - b) * (r - l) * dble(n_in) / dble(n_tot) + b * (r - l)

    call MPI_REDUCE(integral_local, integral, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, ierr)

    if (rank == 0) then
        integral = integral / dble(ntasks)
        write(*,'(f10.5)') integral
    end if

    call MPI_FINALIZE(ierr)
end program main

subroutine func(x, y)
    ! the function to be integrated
    implicit none
    real(8), intent(in) :: x
    real(8), intent(out) :: y

    y = x**2
end subroutine func


!MIT License
!Copyright (c) 2017 VL Srinivas

! This program solves "Shallow Water Equations" in 1D using
! Richtmyer two-step Lax–Wendroff method with reference to John bukardt's code.
! 3 types of initial conditions and 3 boundary conditions are tested.
! IC: Sine wave, Dam break, Gaussian functions
! BC: Periodic, Free, reflective bcs
! @ author: VL Srinivas (https://www.linkedin.com/in/vl-srinivas/)

program main
implicit none

    integer, parameter:: nx =20 , nt = 250
    integer:: iter,i, j
    real(8) :: dx, dt, x_length, T_length
    character:: file_h, file_t, file_uh, file_x
    character(len=100)::fileplace, pico
    real(8), parameter:: g = 9.81d0, pi=3.141592653589793D0
    ! hm: cell centre values of h; h: nodal values of h;
    ! h_array: h values over the grid along with time
    real(8):: h(nx), h_array(nx,nt+1), hm(nx-1), x(nx)
    ! uhm: cell centre values of uh; uh: nodal values of uh;
    ! uh_array: uh values over the grid along with time
    real(8):: t(nt+1), uh(nx), uh_array(nx, nt+1), uhm(nx-1)
    ! RK4 variables
    real(8), dimension(nx):: kh1,kh2,kh3,kh4,kuh1,kuh2,kuh3,kuh4
    real:: t1, t2, t3       ! Time variables

    call cpu_time(t1)

    ! File names with extensions
    file_h = 'h'
    file_t = 't'
    file_uh = 'uh'
    file_x = 'x'

!   write(*,*) "Enter the following input values:"
    x_length = 1.0d0
    T_length = 0.50d0

    ! Creating spatial and time grid
    call linspace(nx, 0.0d0, x_length, X)
    !print *, 'X'
    !print *, X

    call linspace(nt, 0.0d0, T_length, T)
    !print *, 't'
    !print *, t

    ! Creating step size for time and space
    dx = x_length/(nx-1)
    !print *, 'dx', dx

    dt = T_length/(nt-1)
    print *, 'dt', dt

    call initial(pi, nx, X, h, uh, X_length)
    ! ----------------------- MAIN LOOP --------------------
    do iter = 1, nt

		! Lax-Wendroff's method for finite difference hyperbolic pde
    	! Taking half step at cell centres
        do i = 1, nx-1

            hm(i) =  ( h(i) + h(i+1) )/2.0d0 &
                - dt/2.0d0 *( uh(i+1) - uh(i) )/dx
            !print *, 'hm-',i,hm(i)

            uhm(i) = ( uh(i) + uh(i+1) )/2.0d0 - dt/2.0d0 * &
    			( ( uh(i+1)**2 /h(i+1) + g/2.0d0*h(i+1)**2 ) - &
    				( uh(i)**2 /h(i) + g/2.0d0 * h(i)**2) )

        end do
		! Taking the full time step at grid points defining the parameters
		! at the next time step only for internal grid points and excluding the
		! extreme points

        do i = 2, nx-1

            h(i) = h(i) - dt/dx *( uhm(i) - uhm(i-1) )
            !print *, 'h-',i,h(i)

            uh(i) = uh(i) - dt/dx *( uhm(i)**2/hm(i) + &
                0.5d0*g*hm(i)**2 - uhm(i-1)**2/hm(i-1) - &
                    0.5d0*g*hm(i-1)**2 )
        end do

		! ------------ Runge-Kutta 4th order scheme ----------------
		! RK step: 1
!		call func(dx, g, nx, h,				  uh, 				 kh1, kuh1)
!		! RK step: 2
!		call func(dx, g, nx, h+ dt/2.0d0, uh+ kuh1*dt/2.0d0, kh2, kuh2)
!		! RK step: 3
!		call func(dx, g, nx, h+ dt/2.0d0, uh+ kuh2*dt/2.0d0, kh3, kuh3)
!		! RK step: 4
!		call func(dx, g, nx, h + dt, 	  uh + kuh3, 		 kh4, kuh4)

!		! RK final step - adding all weights
!		h(1:nx) = h(1:nx) + ( kh1(1:nx) + 2.0d0*kh2(1:nx) + &
!			2.0d0*kh3(1:nx) + kh4(1:nx) ) * dt/6.0d0

!		uh(1:nx) = uh(1:nx) + ( kuh1(1:nx) + 2.0d0*kuh2(1:nx) + &
!			2.0d0*kuh3(1:nx) + kuh4(1:nx) ) * dt/6.0d0

        !print *, 'h-', h

!--------! Applying the boundary conditions
		call apply_BC(nx, h, uh, 3)

		! Entering the data into matrices with time
		h_array(1:nx, iter+1) = h(1:nx)

		uh_array(1:nx, iter+1) = uh(1:nx)

		! Writing the data to the files : ( h & uh )
		if ( mod(iter,1) == 0 )  then!call write_vec(file_h,fileplace,nx,h,iter)

            !write(fileplace,*) '/home/srinivas/Desktop/vls/files/'
            write(pico,*) iter

            open(unit=03, file= "/home/srinivas/Desktop/vls/files/h_"// &
            	trim(adjustl(pico))//".dat", status='unknown')

            write(03,*) "X steps:", nx
            write(03,*) "T steps:", nt

            !if (nx > 0) then
                ! Writing the data
                do j = 1, nx
                    write(03,100) real(X(j), kind=4), real(h(j), kind=4)
                end do
            !end if
            100 format(2x, 10(e12.6,' '))

            close(unit=03)
        end if
		!call write_vec(file_uh, fileplace, nx, h, iter)

	end do
	! ----------------------- END MAIN LOOP --------------------

	! Writing the arrays to files

	!call write_vec('T', fileplace, nt+1, T, 0)

	!call write_mat('h_array', fileplace, nx, nt+1, h_array)

	!call write_mat('uh_array', fileplace, nx, nt+1, uh_array)
	!call write_mat(filename, fileplace, x, y, matrix)

	call cpu_time(t2)

	t3 = t2 - t1

	write(*,*) "---------------------------------------------"
	write(*,*) "Shallow Water Equations 1D"
	write(*,*) "Spatial grid:", nx
	write(*,*) "Time grid:", nt
	write(*,*) "T_length:", t_length
	write(*,*) "X_length:", x_length
	write(*,*) "Spatial step size:", dx
	write(*,*) "Time step size:", dt
	write(*,*) "Time taken:", t3, 'sec'
	write(*,*) "---------------------------------------------"

 end program
!*******************************************************************************
subroutine linspace(n, first, last, A)
implicit none

    integer:: i
    integer, intent(in):: n
    real(8), intent(in):: first, last
    real(8), intent(out):: A(n)

    if (n==1) then
        a(1) = (first + last)/2.0d0

    else
        do i = 1, n

            A(i) = ( real(n-i, kind=8)*first + real(i-1, kind=8)*last )/ &
                   real(n-1,kind=8)
        end do

    end if

return
end subroutine
!*******************************************************************************
subroutine initial(pi, nx, X, h, uh, X_length)
implicit none

    integer, intent(in):: nx
	real(8), intent(in):: X(nx), pi, X_length
	real(8), intent(out):: h(nx), uh(nx)
	real(8)::a, b, c

    ! Sine wave initial condition
	!h(1:nx) = 2.0d0 + sin(2*pi* X(1:nx))

	! Dam break initial condition
	!h = 1.0d0
	!h(1:nx/2) = 3.0d0

    ! Gaussian function
    a=3.0d0
    b=X_length/2.0d0
    c=0.2d0
    h(1:nx) = a*exp(-(X(1:nx)-b)**2 /(2*c**2))

	uh(1:nx) = 0.0d0

return
end subroutine
!*******************************************************************************
subroutine apply_BC(nx, h, uh, bc)
implicit none

	integer, intent(in):: bc, nx
	real(8):: h(nx), uh(nx)

	! Applying Periodic boundary conditions
	if (bc==1) then
		h(1) = h(nx-1)
		h(nx) = h(2)
		uh(1) = uh(nx-1)
		uh(nx) = uh(2)

	! Applying Free Boundary Condition
	else if (bc==2) then
		h(1) = h(2)
		h(nx) = h(nx-1)
		uh(1) = uh(2)
		uh(nx) = uh(nx-1)

	! Applying Reflective BC for 'uh' & Free BC for 'h'
	else if (bc==3) then
		h(1) = h(2)
		h(nx) = h(nx-1)
		uh(1) = -uh(2)
		uh(nx) = -uh(nx-1)

	end if

return
end subroutine
!*******************************************************************************
subroutine write_vec(filename, fileplace, n, vector, iter)
! Write a vector of length n to a file
implicit none

	integer:: n, j, iter
	character:: filename, fileplace
	character(len=100):: pico
	real(8):: vector(n)

    write(pico,*) iter
	open(unit=01, file = "/home/srinivas/Desktop/vls/files/T_"//&
		trim(adjustl(pico))//".dat", status='unknown')

	write(01,*) "size:", sizeof(vector)

	if (n > 0) then
		! Writing the data
		do j = 1, n
			write(01,*) real(vector(j), kind=4)
		end do
	end if
	!100 format(2x, 10(e12.6,' '))

	close(unit=01)

return
end subroutine
!*******************************************************************************
subroutine write_mat(filename, fileplace, x, y, matrix)
! Writes a matrix of size x*y to a file with name 'filename'
! For every iteration there will be a fresh data file.
implicit none

	integer:: i, j, x, y
	real(8):: matrix(x,y)
	character:: filename, fileplace

	open(unit=02, file=trim(adjustl(fileplace))//trim(filename)//'.dat', &
		status='unknown')

	write(02,100) "size:", x, y

	if (x > 0 .and. y > 0) then
		! Writing the data
		do j = 1, y
			do i = 1, x
				write(01,100) matrix(i,j)
			end do
		end do

	end if
	100 format(2x, 10(e12.6,' '))

	close(unit=02)

return
end subroutine
!*******************************************************************************
subroutine func(dx, g, nx, hin, uhin, hout, uhout)
! Getting the function for time-marching for Runge-Kutta method
implicit none

	integer:: i, nx
	real(8), intent(in):: dx, g, hin(nx), uhin(nx)
	real(8), intent(out):: hout(nx), uhout(nx)

	! Applying Central difference scheme for spatial discretization

	do i = 1, nx

        print*, 'hin:', i,'=',hin(i)
        print*, 'uhin:', i,'=',uhin(i)

		hout(i) = -( uhin(i+1) - uhin(i-1) )/(2.0d0*dx)
		print *, 'hout:', hout(i)

		uhout(i) = -0.5d0/dx *( (uhin(i+1)**2 /hin(i+1) + 0.5d0*g*hin(i+1)**2) &
			- uhin(i+1)**2 /hin(i+1) + 0.5d0*g*hin(i+1**2))

	end do

return
end subroutine
!*******************************************************************************


MODULE lib_mandelbrot

    IMPLICIT NONE

    CONTAINS

    ! Why *NOT* in Mandelbrol set instead of *IS* in Mandelbrot set ?
    ! Because we can't now for sure if it really is inside the set
    ! until we iterate an infinite number of time.
    ! but we now for sure it's not in the mandelbrot set if it escape before n_max
    !   c = the complex point we want to check
    !   n_max = the maximum iteration
    PURE FUNCTION notInMset(c, n_max)
        COMPLEX, INTENT(IN) :: c
        INTEGER, INTENT(IN) :: n_max
        INTEGER :: n
        COMPLEX :: z
        LOGICAL :: notInMSet
        z = CMPLX(0,0)
        n = 0

        ! early escape attempts. if it's in the main cardioid or largest bulbs
        ! then it's proven it's in the mandelbrot set
        IF(((ABS(c - CMPLX(-1,0) )) < 0.25) .OR. ((ABS( 1.0 - SQRT(1-(4*c)) ))  < 1.0 ) ) THEN
            notInMset = .FALSE.

        ! else do the regular iteration
        ELSE
            ! iterate until we escape or reach mac iteration
            DO WHILE (ABS(z) < 2 .AND. (n < n_max))
                z = z**2 + c
                n = n + 1
            END DO

            IF (n >= n_max) THEN
                ! we reached max iteration without escaping, it may be in mandelbrot set so we return false
                notInMset = .FALSE.
            ELSE
                ! it escaped before reaching max iteration, it's not in mandelbrot set for sure
                notInMset = .TRUE.
            END IF
        END IF
    END FUNCTION notInMset

END MODULE lib_mandelbrot