!     Program to compute the second derivative of exp(x).
!     Three calling functions are included
!     in this version. In one function we read in the data from screen,
!     the next function computes the second derivative
!     while the last function prints out data to screen.

!     The variable h is the step size. We also fix the total number
!     of divisions by 2 of h. The total number of steps is read from
!     screen

MODULE constants
  ! definition of variables for double precisions and complex variables
  INTEGER,  PARAMETER :: dp = KIND(1.0D0)
  INTEGER, PARAMETER :: dpc = KIND((1.0D0,1.0D0))
  ! Global Truncation parameter
  REAL(DP), PARAMETER, PUBLIC ::  truncation=1.0E-10
END MODULE constants

! Here you can include specific functions which can be used by
! many subroutines or functions

MODULE functions
USE constants
IMPLICIT NONE
CONTAINS
  SUBROUTINE derivative(number_of_steps, x, initial_step, h_step, &
       computed_derivative)
    USE constants
    INTEGER, INTENT(IN) :: number_of_steps
    INTEGER  :: loop
    REAL(DP), DIMENSION(number_of_steps), INTENT(INOUT) :: &
         computed_derivative, h_step
    REAL(DP), INTENT(IN) :: initial_step, x
    REAL(DP) :: h
    !     calculate the step size
    !     initialise the derivative, y and x (in minutes)
    !     and iteration counter
    h = initial_step
    ! start computing for different step sizes
    DO loop=1,  number_of_steps
       !  setup arrays with derivatives and step sizes
       h_step(loop) = h
       computed_derivative(loop) = (EXP(x+h)-2.*EXP(x)+EXP(x-h))/(h*h)
       h = h*0.5
    ENDDO
  END SUBROUTINE derivative

END MODULE functions

PROGRAM second_derivative
  USE constants
  USE functions
  IMPLICIT NONE
  ! declarations of variables
  INTEGER :: number_of_steps, loop
  REAL(DP) :: x, initial_step
  REAL(DP), ALLOCATABLE, DIMENSION(:) :: h_step, computed_derivative
  !  read in input data from screen
  WRITE(*,*) 'Read in initial step, x value and number of steps'
  READ(*,*) initial_step, x, number_of_steps
  ! open file to write results on
  OPEN(UNIT=7,FILE='out.dat')
  !  allocate space in memory for the one-dimensional arrays
  !  h_step and computed_derivative
  ALLOCATE(h_step(number_of_steps),computed_derivative(number_of_steps))
  ! compute the second derivative of exp(x)
  h_step = 0.0_dp; computed_derivative = 0.0_dp
  CALL  derivative(number_of_steps,x,initial_step,h_step,computed_derivative)

  !  Then we print the results to file
  DO loop=1,  number_of_steps
     WRITE(7,'(E16.10,2X,E16.10)') LOG10(h_step(loop)),&
     LOG10 ( ABS ( (computed_derivative(loop)-EXP(x))/EXP(x)))
     ! free memory
  ENDDO
  DEALLOCATE( h_step, computed_derivative)
END PROGRAM second_derivative


program cal_derteminant
    implicit none

    integer :: i,j,io
    integer :: m,n
    real, dimension(:,:), allocatable :: matrix
    real :: determinan,caldet

    ! Read number of data
    write(*,*) 'Status IOSTAT'
    open(1, file='data_matrix_high_A.txt')
    m = 0
    do
        read(1,*,iostat=io)
        write(*,*)'Baris ke-',m+1, io
        if (io /= 0) exit
        m = m + 1
    end do
    close(1)

    ! Set number of rows and columns of square matrix
    m = int(m**0.5)
    n = m

    ! Allocate memory size for array variable
    allocate(matrix(m,n))

    ! Read matrix file
    open(2,file='data_matrix_high_A.txt')
    do i = 1,m
        do j = 1,n
            read(2,*) matrix(i,j)
        end do
    end do
    close(2)

    ! Show matrix
    write(*,*)
    write(*,*) 'Matrix'
    do i = 1,m
        write(*,*) (matrix(i,j), j=1,n)
    end do

    write(*,*)

    ! Calculate determinant by calling its function
    determinan = caldet(matrix,m,n)

    write(*,*) 'Determinan:'
    write(*,*) determinan

    deallocate(matrix)
end program

subroutine getsubmatrix(matrix,m,n,mainrow,maincolumn,submatrix)
    ! ------------------------------------------------------------------
    ! This is a subroutine to get a cofactor/submatrix from main matrix
    ! This concept algorithm is obtained from
    ! https://www.geeksforgeeks.org/adjoint-inverse-matrix/ in C++
    ! ------------------------------------------------------------------
    real, dimension(m,n) :: matrix ! input matrix
    real, dimension(m-1,n-1) :: submatrix ! output matrix
    integer :: maincolumn, mainrow, row, col

    i = 1
    j = 1
    do row = 1,m
        do col = 1,n
            if ((row .ne. mainrow) .and. (col .ne. maincolumn)) then
                submatrix(i,j) = matrix(row,col)
                if (j == n-1) then
                    j = 1
                    i = i + 1
                else
                    j = j + 1
                end if
            end if
        end do
    end do

end subroutine getsubmatrix

recursive function caldet(matrix,m,n) result(sumdet)
    ! ------------------------------------------------------------------
    ! This is a recursive function to calculate determinant.
    ! ------------------------------------------------------------------
    real, dimension(m,n) :: matrix
    real, dimension(m-1,n-1) :: submatrix
    integer :: j

    if (m == 2 .and. n == 2 ) then
        det = matrix(1,1)*matrix(2,2) - matrix(1,2)*matrix(2,1)
    else
        det = 0
        do j = 1,n
            sign = (-1)**(j-1)
            call getsubmatrix(matrix,m,n,1,j,submatrix)
            det = det + (sign * matrix(1,j) * caldet(submatrix,m-1,n-1))
        end do
    end if

    sumdet = det
    return
end function caldet


C     NUMERICAL METHODS: FORTRAN Programs, (c) John H. Mathews 1994
C     To accompany the text:
C     NUMERICAL METHODS for Mathematics, Science and Engineering, 2nd Ed, 1992
C     Prentice Hall, Englewood Cliffs, New Jersey, 07632, U.S.A.
C     This free software is complements of the author.
C
C     Algorithm 7.2 (Composite Simpson Rule).
C     Section 7.2, Composite Trapezoidal and Simpson's Rule, Page 365
C

C     comment added by Kongbin Kang
C     F: integrand function
C     A: lower integration limit
C     B: higher integration limit
C     M: number of intervals. Notice, the subintervals used is 2M
C     Srule: output parameter to store simpson rule result

      SUBROUTINE SIMPRU(F,A,B,M,Srule)
      INTEGER K,M
      DOUBLE PRECISION A,B,H,Sum,SumEven,SumOdd,Srule,X
      EXTERNAL F
      H=(B-A)/(2*M)
      SumEven=0
      DO K=1,(M-1)
        X=A+H*2*K
        SumEven=SumEven+F(X)
      ENDDO
      SumOdd=0
      DO K=1,M
        X=A+H*(2*K-1)
        SumOdd=SumOdd+F(X)
      ENDDO
      Sum=H*(F(A)+F(B)+2*SumEven+4*SumOdd)/3
      Srule=Sum
      RETURN
      END

      SUBROUTINE XSIMPRU(F,A,B,M,Srule)
C     This subroutine uses labeled DO loop(s).
      INTEGER K,M
      DOUBLE PRECISION A,B,H,Sum,SumEven,SumOdd,Srule,X
      EXTERNAL F
      H=(B-A)/(2*M)
      SumEven=0
      DO 10 K=1,(M-1)
        X=A+H*2*K
        SumEven=SumEven+F(X)
10    CONTINUE
      SumOdd=0
      DO 20 K=1,M
        X=A+H*(2*K-1)
        SumOdd=SumOdd+F(X)
20    CONTINUE
      Sum=H*(F(A)+F(B)+2*SumEven+4*SumOdd)/3
      Srule=Sum
      RETURN
      END


#
# let's do some fibonacci sequences
#

print("Testing fibonacci sequence (recursion, scope)...")
errors = 0

#
# elegant, but extremely inefficient recursive algorithm
#
fibonacci-sequence = fn (n: int) {
    fibonacci-number = fn (nth: int)
        if nth <= 1
            nth
        else
            fibonacci-number(nth - 1) + fibonacci-number(nth - 2)

    for i in 1 to n
        yield fibonacci-number(i)
}

sequence = [ fibonacci-sequence(20) ]

try assert sequence == [
    1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144,
    233, 377, 610, 987, 1597, 2584, 4181, 6765
]
rescue errors += 1

#
# faster, non-recursive function
#
fibonacci-sequence = fn (n: int) {
    a = b = 1;
    for i in 3 to n + 2
        (a, b) = (b, (yield a) + b);
}

sequence = [ fibonacci-sequence(20) ]

try assert sequence == [
    1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144,
    233, 377, 610, 987, 1597, 2584, 4181, 6765
]
rescue errors += 1

print(if errors "Some tests failed ({errors}) errors\n" else "passed!\n")


SUBROUTINE simul(a, b, ndim, n, error)
IMPLICIT NONE
INTEGER, INTENT(IN) :: ndim
REAL, INTENT(INOUT), DIMENSION(ndim, ndim) :: a
REAL, INTENT(INOUT), DIMENSION(ndim) :: b
INTEGER, INTENT(IN) :: n
INTEGER, INTENT(OUT) :: error
REAL, PARAMETER :: EPSILON = 1.0E-6
REAL :: factor, temp
INTEGER :: irow, ipeak, jrow, kcol

! Process n times to get all equations...
mainloop: DO irow = 1, n
  ! Find peak pivot for column irow in rows irow to n
  ipeak = irow
  max_pivot: DO jrow = irow + 1, n
    IF (ABS(a(jrow,irow)) > ABS(a(ipeak,irow))) THEN
      ipeak = jrow
    END IF
  END DO max_pivot

  ! Check for singular equations.
  singular: IF(ABS(a(ipeak,irow)) < EPSILON) THEN
    error = 1
    RETURN
  END IF singular

  ! Otherwise, if ipeak /= irow, swap equations irow & ipeak
  swap_eqn: IF (ipeak /= irow) THEN
    DO kcol = 1, n
      temp           = a(ipeak, kcol)
      a(ipeak, kcol) = a(irow, kcol)
      a(irow, kcol)  = temp
    END DO
    temp     = b(ipeak)
    b(ipeak) = b(irow)
    b(irow)  = temp
  END IF swap_eqn

  ! Multiply equation irow by -a(jrow, irow)/a(irow, irow)
  ! and add it to eqn jrow (for all eqns except irow itself).
  eliminate: DO jrow = 1, n
    IF (jrow /= irow) THEN
      factor = -a(jrow, irow) / a(irow, irow)
      DO kcol = 1, n
        a(jrow, kcol) = a(irow, kcol) * factor + a(jrow, kcol)
      END DO
      b(jrow) = b(irow) * factor + b(jrow)
    END IF
  END DO eliminate
END DO mainloop

! End of mainloop over all equations. All off-diagonal
! terms are now zero. To get the final answer, we must
! divide each equation by the coefficient of its on-diagonal
! term.
divide: DO irow = 1, n
  b(irow)       = b(irow) / a(irow, irow)
  a(irow, irow) = 1
END DO divide

! Set error flag to 0 and return
error = 0
END SUBROUTINE simul

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

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

! Open input data file. Status is OLD because the input data must
! already exist.
OPEN (UNIT=1, FILE=file_name, STATUS='OLD', ACTION='READ', &
      IOSTAT=istat, IOMSG=msg)

! Was the OPEN successful?
fileopen: IF(istat == 0) THEN
  ! The file was opened successfully, so read the number of
  ! equations in the system.
  READ(1, *) n

  ! If the number of equations is <= MAX_SIZE, read them in
  ! and process them.
  size_ok: IF (n <= MAX_SIZE) THEN
    DO i = 1, n
      READ(1, *) (a(i, j), j = 1, n), b(i)
    END DO

    ! Display coefficients.
    WRITE(*, "(/,'Coefficients before call:')")
    DO i = 1, n
      WRITE(*, "(1X,7F11.4)") (a(i, j), j = 1, n), b(i)
    END DO

    ! Solve equations
    CALL simul(a, b, MAX_SIZE, n, error)

    ! Check for error.
    error_check: IF (error /= 0) THEN
      WRITE(*, 1010)
      1010 FORMAT(/'Zero pivot encountered!', &
                  //'There is no unique solution to this system.')
    ELSE error_check
      ! No errors. Display coefficients.
      WRITE(*, "(/,'Coefficients after call:')")
      DO i = 1, n
        WRITE(*, "(1X,7F11.4)") (a(i, j), j = 1, n), b(i)
      END DO
      ! Write the final answer.
      WRITE(*, "(/,'The solutions are:')")
      DO i = 1, n
        WRITE(*,"(2X,'X(',I2,') = ',F16.6)") i, b(i)
      END DO
    END IF error_check
  END IF size_ok
ELSE fileopen
  ! Else file open failed. Tell user.
  WRITE(*, 1020) msg
  1020 FORMAT('File open failed: ', A)
END IF fileopen
END PROGRAM gauss_jordan


program test_cholesky
use types, only: dp
use utils, only: assert
use linalg, only: cholesky, solve, solve_triangular
implicit none

real(dp), parameter :: eps = 1e-12_dp
real(dp) :: A(3,3), A2(3,3), L(3,3), b(3), x1(3), x2(3)

A = reshape([4, 12, -16, 12, 37, -43, -16, -43, 98], shape=[3,3], order=[2,1])
L = cholesky(A)
A2 = matmul(L, transpose(L))
print *, A
print *, L
print *, A2
call assert(maxval(abs(A - A2)) < eps)

b = [1, 2, 3]
x1 = solve(A, b)
print *, x1
x2 = solve_triangular(L, solve_triangular(L, b), .true.)
print *, x2
call assert(maxval(abs(x1 - x2)) < eps)

end program


program test_logspace

    use stdlib_error, only: check
    use stdlib_kinds, only: sp, dp, int8, int16, int32, int64
    use stdlib_math, only: logspace, DEFAULT_LOGSPACE_BASE, DEFAULT_LOGSPACE_LENGTH

    implicit none

        logical :: warn = .false.

        integer :: iunit

        ! Testing logspace
        !
        ! logspace should return a rank 1 array of values equally logarithmically spaced
        ! from the base**start to base**end, using 10 as the base. If no length
        ! is specified, return a rank 1 array with 50 elements.
        !
        ! Also test to verify that the proportion between adjacent elements is constant within
        ! a certain tolerance

        real(sp), parameter :: TOLERANCE_SP = 1000 * epsilon(1.0_sp)
        real(dp), parameter :: TOLERANCE_DP = 1000 * epsilon(1.0_dp) ! Percentage of the range for which the actual gap must not exceed

        open(newunit=iunit, file="test_logspace_log.txt", status="unknown") ! Log the results of the function

        write(iunit,*) "Writing to unit #: ", iunit

        call test_logspace_sp
        call test_logspace_dp
        call test_logspace_default
        call test_logspace_base_2
        call test_logspace_base_2_cmplx_start
        call test_logspace_base_i_int_start

        close(unit=iunit)

    contains

        subroutine test_logspace_sp

            integer :: n = 20
            real(sp) :: start = 0.0_sp
            real(sp) :: end = 2.0_sp

            real(sp) :: expected_proportion
            integer :: i = 1

            real(sp), allocatable :: x(:)

            x = logspace(start, end, n)

            expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) )

            call check(x(1) == DEFAULT_LOGSPACE_BASE ** start, msg="Initial value of array is not equal to 10^start", warn=warn)
            call check(x(n) == DEFAULT_LOGSPACE_BASE ** end, msg="Final value of array is not equal to 10^end", warn=warn)
            call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn)

            do i = 1, n-1

                call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_SP)

            end do

            write(unit=iunit, fmt=*) "logspace(0.0_sp, 2.0_sp, 20): "
            write(unit=iunit,fmt='(70("="))')
            write(unit=iunit,fmt="(20(F7.3, 2X))") x
            write(iunit,*)
            write(iunit,*)

        end subroutine

        subroutine test_logspace_dp

            integer :: n = 10
            real(dp) :: start = 1.0_dp
            real(dp) :: end = 0.0_dp
            real(dp) :: expected_proportion
            integer :: i = 1

            real(dp), allocatable :: x(:)

            x = logspace(start, end, n)

            expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) )

            call check(x(1) == DEFAULT_LOGSPACE_BASE ** start, msg="Initial value of array is not equal to 10^start", warn=warn)
            call check(x(n) == DEFAULT_LOGSPACE_BASE ** end, msg="Final value of array is not equal to 10^end", warn=warn)
            call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn)

            do i = 1, n-1

                call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP)

            end do

            write(unit=iunit, fmt=*) "logspace(1.0_dp, 0.0_dp, 10): "
            write(unit=iunit,fmt=99)
            write(unit=iunit,fmt="(10(F7.3, 2X))") x
            write(iunit,*)
            write(iunit,*)

            99 format(70("="))

        end subroutine

        subroutine test_logspace_default

            real(dp) :: start = 0.0_dp
            real(dp) :: end = 1.0_dp
            integer :: n = DEFAULT_LOGSPACE_LENGTH
            real(dp) :: expected_proportion
            integer :: i

            real(dp), allocatable :: x(:)

            x = logspace(start, end)

            expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) )

            call check(x(1) == DEFAULT_LOGSPACE_BASE ** start, msg="Initial value of array is not equal to 10^start", warn=warn)
            call check(x(n) == DEFAULT_LOGSPACE_BASE ** end, msg="Final value of array is not equal to 10^end", warn=warn)
            call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn)

            do i = 1, n-1

                call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP)

            end do

            write(unit=iunit, fmt=*) "logspace(0.0_dp, 1.0_dp): "
            write(unit=iunit,fmt='(70("="))')
            write(unit=iunit,fmt="(50(F7.3, 2X))") x
            write(iunit,*)
            write(iunit,*)

        end subroutine

        subroutine test_logspace_base_2

            integer :: n = 10
            real(dp) :: start = 1.0_dp
            real(dp) :: end = 10.0_dp
            integer :: base = 2
            integer :: i
            real(dp) :: expected_proportion

            real(dp), allocatable :: x(:)

            x = logspace(start, end, n, base)

            expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) )

            call check(x(1) == base ** start, msg="Initial value of array is not equal to 2^start", warn=warn)
            call check(x(n) == base ** end, msg="Final value of array is not equal to 2^end", warn=warn)
            call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn)

            do i = 1, n-1

                call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP)

            end do

            write(unit=iunit, fmt=*) "logspace(1.0_dp, 10.0_dp, 10, 2): "
            write(unit=iunit,fmt='(70("="))')
            write(unit=iunit,fmt="(10(F9.3, 2X))") x
            write(iunit,*)
            write(iunit,*)

        end subroutine

        subroutine test_logspace_base_2_cmplx_start

            integer :: n = 10
            complex(dp) :: start = (1, 0)
            complex(dp) :: end = (0, 1)
            integer :: base = 2
            complex(dp) :: expected_proportion
            integer :: i

            complex(dp), allocatable :: x(:)

            x = logspace(start, end, n, base)

            expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) )

            call check(x(1) == base ** start, msg="Initial value of array is not equal to 2^start", warn=warn)
            call check(x(n) == base ** end, msg="Final value of array is not equal to 2^end", warn=warn)
            call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn)

            do i = 1, n-1

                call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP)

            end do

            write(unit=iunit, fmt=*) "logspace(1, i, 10, 2): "
            write(unit=iunit,fmt='(70("="))')
            write(unit=iunit,fmt="(10('(', F6.3, ',', 1X, F6.3, ')', 2X))") x
            write(iunit,*)
            write(iunit,*)

        end subroutine

        subroutine test_logspace_base_i_int_start

            integer :: n = 5
            integer :: start = 1
            integer :: end = 5
            complex(dp) :: base = (0, 1) ! i
            complex(dp) :: expected_proportion
            integer :: i = 1

            complex(dp), allocatable :: x(:)

            x = logspace(start, end, n, base)

            expected_proportion = base ** ( ( end - start ) / ( n - 1 ) )

            call check(x(1) == base ** start, msg="Initial value of array is not equal to 2^start", warn=warn)
            call check(x(n) == base ** end, msg="Final value of array is not equal to 2^end", warn=warn)
            call check(size(x) == n, msg="Array not allocated to appropriate size", warn=warn)

            do i = 1, n-1

                call check(abs(x(i + 1) / x(i) - expected_proportion) < abs(expected_proportion) * TOLERANCE_DP)

            end do

            write(unit=iunit, fmt=*) "logspace(1, 5, 5, i): "
            write(unit=iunit,fmt='(70("="))')
            write(unit=iunit,fmt="(10('(', F6.3, ',', 1X, F6.3, ')', 2X))") x
            write(iunit,*)
            write(iunit,*)

        end subroutine

    end program


!-------------------------------------------------------
!
! main.f90
!
! Description:
! ------------
! Fortran snippet to produce a grid of real
! numbers with logarithmically equal spacing.
!
! Record of Revisions:
! --------------------
!
! Date:            Author:         Description:
! -----            -------         ------------
! 2020-03-06       P. Stegmann     Original Code
!
!
!
!
! Copyright © 2020 Patrick Stegmann
!
! This file is part of ScatteringBase.
!
! ScatteringBase is free software:
! you can redistribute it and/or modify it under
! the terms of the Apache License as published by
! the Apache Software Foundation, either version 2.0
! 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 Apache License for more details.
!
! You should have received a copy of the Apache 2.0
! License along with this program. If not,
! see <https://www.apache.org/licenses/LICENSE-2.0>.
!
!-------------------------------------------------------

PROGRAM MAIN

	IMPLICIT NONE
	! Data Dictionary:
	REAL(KIND=8), PARAMETER :: start = 0.1
	REAL(KIND=8), PARAMETER :: fin = 3000.
	INTEGER(KIND=4), PARAMETER :: steps = 100
	REAL(KIND=8),DIMENSION(steps) :: grid
    INTEGER(KIND=4), PARAMETER :: FileUnit = 444

	! Instructions:

	! Compute the logequal grid:
	grid = LOGEQUAL(start,fin,steps)

	! Output grid to file:
	OPEN(UNIT=FileUnit, &
		 FILE="grid.txt", &
		 ACTION="WRITE", &
		 STATUS="REPLACE")
	WRITE(FileUnit,*) grid
	CLOSE(FileUnit)

CONTAINS

	PURE FUNCTION LOGEQUAL(start,fin,steps) RESULT(grid)
		! Data Dictionary
		REAL(KIND=8), INTENT(IN) :: start
		REAL(KIND=8), INTENT(IN) :: fin
		INTEGER(KIND=4), INTENT(IN) :: steps
		REAL(KIND=8),DIMENSION(steps) :: grid
		INTEGER(KIND=4) :: ii
		REAL(KIND=8) :: tmp
		! Function Instructions:
		tmp = LOG(start)
		grid_loop: DO ii = 1, steps
			tmp = (LOG(fin)-LOG(start))/steps + tmp
			grid(ii) = EXP(tmp)
		END DO grid_loop
		RETURN
	END FUNCTION LOGEQUAL

END PROGRAM MAIN


module random_mod

    use model_constants

    implicit none

    private
    double precision, parameter :: root_pi_over_8 = 0.626657068658 ! sqrt(kPI/8)

    integer, parameter :: size_of_normal_cdf_lookup_table = 1000000
    double precision, allocatable :: fast_cdf_lookup_table(:), cdf_lookup_table(:,:)

    interface normal_cdf
        module procedure real_normal_cdf, double_normal_cdf
    end interface

    public :: normal_cdf, box_muller_random, get_normal_from_cdf

contains

    !>------------------------------------------------
    !! Use the Box-Muller Transform to convert uniform to normal random deviates
    !!
    !! Note random_sample should be an allocated 1D real array
    !! On return, random_sample will be filled with random normal (0,1) data
    !!
    !! Caveat: this transform is unable to generate extremely high values (>6.66)
    !! Having switched to double precision it may do better now.
    !!
    !-------------------------------------------------
    subroutine box_muller_random(random_sample)
        implicit none
        real, intent(inout) :: random_sample(:)
        integer :: n,i

        double precision :: u1, u2, s
        double precision, allocatable :: double_random(:)

        n = size(random_sample)
        allocate(double_random(n))
        call random_number(double_random)

        do i=1,n,2
            u1 = double_random(i)
            if (i<n) then
                u2 = double_random(i+1)
            else
                call random_number(u2)
            endif

            s = sqrt(-2 * log(u1))
            random_sample(i) = s * cos(2 * kPI * u2)
            if (i<n) then
                random_sample(i+1) = s * sin(2 * kPI * u2)
            endif

        enddo

    end subroutine box_muller_random

    !>------------------------------------------------
    !! Computes an approximation to the normal CDF based on Aludaat and Alodat (2008)
    !!
    !! Aludaat, K.M. and Alodat, M.T. (2008). A note on approximating the normal distribution function. Applied Mathematical Sciences, Vol 2, no 9, pgs 425-429.
    !!
    !!------------------------------------------------
    function real_normal_cdf(normal) result(cdf)
        implicit none
        real :: normal
        real :: cdf

        cdf = 0.5 * (1 + sqrt((1 - exp(0 - (root_pi_over_8 * normal**2))) ))

        if (normal < 0) then
            cdf = 1 - cdf
        endif

    end function real_normal_cdf

    !>------------------------------------------------
    !! Computes an approximation to the normal CDF based on Aludaat and Alodat (2008)
    !!
    !! Aludaat, K.M. and Alodat, M.T. (2008). A note on approximating the normal distribution function. Applied Mathematical Sciences, Vol 2, no 9, pgs 425-429.
    !!
    !!------------------------------------------------
    function double_normal_cdf(normal) result(cdf)
        implicit none
        double precision :: normal
        double precision :: cdf

        cdf = 0.5 * (1 + sqrt((1.d0 - exp(0.d0 - (root_pi_over_8 * normal**2))) ))

        if (normal < 0) then
            cdf = 1 - cdf
        endif

    end function double_normal_cdf

    !>------------------------------------------------
    !! Create a look up table to convert from Uniform random number to Normal random
    !!
    !!------------------------------------------------
    subroutine create_cdf_lookup_table()
        implicit none

        integer :: i
        real :: normal_random_value, normal_step

        ! in case another thread beat this one to the lock after the if
        if (.not.allocated(fast_cdf_lookup_table)) then

            allocate(cdf_lookup_table(size_of_normal_cdf_lookup_table, 2))

            normal_random_value = (-5.5)
            normal_step = 11.0 / (size_of_normal_cdf_lookup_table - 1)

            do i = 1, size_of_normal_cdf_lookup_table
                cdf_lookup_table(i,1) = normal_random_value
                cdf_lookup_table(i,2) = normal_cdf(normal_random_value)

                normal_random_value = normal_random_value + normal_step
            enddo

            ! now invert this slow lookup table to create a fast lookup table
            allocate(fast_cdf_lookup_table(size_of_normal_cdf_lookup_table))

            do i = 1,size_of_normal_cdf_lookup_table
                fast_cdf_lookup_table(i) = look_up(dble(i) / size_of_normal_cdf_lookup_table, cdf_lookup_table)
            enddo

            deallocate(cdf_lookup_table)
        endif

    end subroutine create_cdf_lookup_table

    !>------------------------------------------------
    !! Perform a binary search through LUT to find value, then interpolate between the two closest entries.
    !!
    !!------------------------------------------------
    function look_up(value, LUT) result(output)
        implicit none
        double precision, intent(in)  :: value
        double precision, intent(in)  :: LUT(:,:)
        real :: output

        real :: fraction, denominator
        integer :: i,n
        integer :: step

        n = size(LUT, 1)
        i = n/2
        step = n/2

        ! perform a binary search
        do while(step/2.0 >= 1)
            step = (step+1) / 2
            if (LUT(i,2) > value) then
                i = max(1, i - step)
            else
                i = min(n, i + step)
            endif

        enddo

        ! figure out which side of this index we fall on and interpolate
        if (value > LUT(i,2)) then
            if (i==n) then
                output = LUT(i,1)
            else
                denominator = max(1e-20, (LUT(i+1,2) - LUT(i,2)))
                fraction = (value - LUT(i,2)) / denominator
                output = fraction * LUT(i+1,1) + (1-fraction) * LUT(i,1)
            endif
        else
            if (i==1) then
                output = LUT(i,1)
            else
                denominator = max(1e-20, (LUT(i,2) - LUT(i-1,2)))
                fraction = (LUT(i,2) - value) / denominator

                output = fraction * LUT(i-1,1) + (1-fraction) * LUT(i,1)
            endif
        endif
    end function look_up

    !>------------------------------------------------
    !! Calculate index into precomputed LUT to find cdf_value, then interpolate between the two closest entries.
    !!
    !!------------------------------------------------
    function get_normal_from_cdf(cdf_value) result(random_normal)
        implicit none
        real, intent(in)  :: cdf_value
        real :: random_normal

        integer :: index
        double precision :: real_index
        double precision :: fraction

        if (.not.allocated(fast_cdf_lookup_table)) then
            !$omp critical(cdf_lookup)
            call create_cdf_lookup_table()
            !$omp end critical(cdf_lookup)
        endif

        ! in the fast look up table we can just compute the optimal index
        real_index = cdf_value * 1.0d0 * size_of_normal_cdf_lookup_table
        index = min(size_of_normal_cdf_lookup_table, max(1, nint( real_index)) )

        ! then interpolate between this index and the next closest
        if (index > real_index) then
            if (index == 1) then
                random_normal = fast_cdf_lookup_table(index)
            else
                fraction = (index - real_index)
                random_normal = (1-fraction) * fast_cdf_lookup_table(index)         &
                    + fraction * fast_cdf_lookup_table(max(1,index-1))
            endif
        else
            if (index == size_of_normal_cdf_lookup_table) then
                random_normal = fast_cdf_lookup_table(index)
            else
                fraction = (real_index - index)
                random_normal = (1-fraction) * fast_cdf_lookup_table(index)         &
                    + fraction * fast_cdf_lookup_table(min(size_of_normal_cdf_lookup_table,index+1))
            endif
        endif

    end function get_normal_from_cdf

end module random_mod


      subroutine gauleg(x1,x2,x,w,n)
c Routine from Numerical Recipes (Press, Flannery, Teukolsky and Vetterling,
c    1986, Cambridge University Press, ISBN 0 521 30811 9)
c
c Given the lower and upper limits of integration (X1, X2) and the number
c  of intervals (N), this routine returns arrays X and W of length N,
c  containing the abscissas and weights of the Gauss-Legendre N-point
c  quadrature formula.
c
      implicit real*4 (a-h,o-z)
      REAL*4        X1,X2,X(N),W(N)
      parameter (eps=3.e-7)
C
      m=(n+1)/2
      xm=0.5*(x2+x1)
      xl=0.5*(x2-x1)
      do i=1,m
        z=cos(3.141592654*(i-.25)/(n+.5))
        z1 = 0.0
        do while (abs(z-z1).gt.eps)
          p1=1.0
          p2=0.0
          do j=1,n
            p3=p2
            p2=p1
            p1=((2.0*j-1.0)*z*p2-(j-1.0)*p3)/j
          end do
          pp=n*(z*p1-p2)/(z*z-1.0)
          z1=z
          z=z1-p1/pp
        end do
        x(i)=xm-xl*z
        x(n+1-i)=xm+xl*z
        w(i)=2.0*xl/((1.0-z*z)*pp*pp)
        w(n+1-i)=w(i)
      end do
      return
      end


program gauss4by4
    implicit none
    real a(4,4),b(4),x(4),det
    integer i,j

    a(1,1)=2;a(1,2)= 4;a(1,3) = 5;a(1,4)= 2;
    a(2,1)=1;a(2,2)=-8;a(2,3) = 2;a(2,4)=-6;
    a(3,1)=4;a(3,2)= 1;a(3,3)=-10;a(3,4)=-2;
    a(4,1)=1;a(4,2)= 7;a(4,3) = 1;a(4,4)=-2;
    b(1)  =9;b(2)  =-3;b(3)   = 1;b(4)  =-3;
    call gaussian(a,b,4,x,det)
    print *,'X=',x(1),x(2),x(3),x(4),det
end program gauss4by4

subroutine gaussian(a,b,n,x,det)
    implicit none
    real a(n,n),b(n),x(n),det,dd
    integer n,i,j,k,row,col
    row=n;col=n
    do k=1,row
        do i=k+1,row
            dd=a(i,k)/a(k,k)
            do j = k+1,col
                a(i,j)=a(i,j)-dd*a(k,j)
            enddo
            b(i)=b(i)-dd*b(k)
        enddo
    enddo
    x(n)=b(n)/a(n,n)
    do i = n-1,1,-1
        dd=b(i)
        do j = i+1,n
            dd=dd-a(i,j)*x(j)
        enddo
        x(i)=dd/a(i,i)
    enddo
    det = a(1,1)
    do i=2,n
        det = det*a(i,i)
    enddo

end subroutine gaussian


C File: arrays-basic-07.f
C Illustrates: transposition of a 2-D matrix

	program main
	implicit none

	integer, dimension(3,5) :: A
	integer, dimension(5,3) :: B
	integer :: i, j

C Initialize matrix A
	do i = 1,3
	    do j = 1,5
	        A(i,j) = (i*j)+(i+j)
	    end do
	end do

C Transpose A into B
	do i = 1,3
	    do j = 1,5
	        B(j,i) = A(i,j)
	    end do
	end do

C Print out the results
 10     format('A:', 5(X,I4))
 11     format('')
 12     format('B:', 3(X,I4))

	do i = 1,3
	    write(*,10) A(i,1), A(i,2), A(i,3), A(i,4), A(i,5)
	end do

	write(*,11)

	do i = 1,5
	    write(*,12) B(i,1), B(i,2), B(i,3)
	end do

	stop
	end program main


	FUNCTION PR_TMCF  ( tmpc )
C************************************************************************
C* PR_TMCF								*
C*									*
C* This function computes TMPF from TMPC.  The following equation is    *
C* used:								*
C*									*
C*              TMPF = ( TMPC * 9 / 5 ) + 32				*
C*									*
C* REAL PR_TMCF  ( TMPC )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL    	Temperature in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_TMCF		REAL    	Temperature in Fahrenheit	*
C**									*
C* Log:									*
C* J. Woytek/GSFC	10/82	Original source code			*
C* M. Goodman/RDS	 9/84	Added error branch			*
C* M. desJardins/GSFC	 4/86	Added PARAMETER statement		*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 8/88	Modified documentation			*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	PARAMETER	( RPRM = 9.0 / 5.0 )
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( tmpc ) )  THEN
	    PR_TMCF = RMISSD
	  ELSE
	    PR_TMCF = ( tmpc * RPRM ) + 32.
	END IF
C*
	RETURN
	END


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

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

Area_Circle = Pi * r * r

END FUNCTION Area_Circle


module primes
    use, intrinsic :: iso_fortran_env
    implicit none
    private

    interface primesUpTo
        module procedure primesUpTo_int8, primesUpTo_int32
    end interface

    interface isPrime
        module procedure isPrime_int8, isPrime_int32
    end interface

    interface randomPrime
        module procedure randomPrime_int8, randomPrime_int32
    end interface

    public :: primesUpTo, isPrime, randomPrime

    contains
    function primesUpTo_int8(n) result(primes)
        integer(int8), intent(in) :: n
        integer(int8), dimension(:), allocatable :: primes
        integer(int8), dimension(:), allocatable :: temp
        logical, dimension(:), allocatable :: fullset
        integer(int8) :: i, j

        allocate(primes(0))
        if (n > 1_int8) then ! basic sieve
            allocate(fullset(n))
            fullset = .true.
            do i = 2,n
                if (fullset(i)) then
                    allocate(temp(size(primes) + 1))
                    temp(:size(primes)) = primes
                    temp(size(primes) + 1) = i
                    deallocate(primes)
                    allocate(primes(size(temp)), source=temp)
                    deallocate(temp)
                    do j = 2_int8 * i, n, i
                        fullset(j) = .false.
                    end do
                end if
            end do
            deallocate(fullset)
        end if
    end function

    function primesUpTo_int32(n) result(primes)
        integer(int32), intent(in) :: n
        integer(int32), dimension(:), allocatable :: primes
        integer(int32), dimension(:), allocatable :: temp
        logical, dimension(:), allocatable :: fullset
        integer(int32) :: i, j

        allocate(primes(0))
        if (n > 1_int32) then ! basic sieve
            allocate(fullset(n))
            fullset = .true.
            do i = 2,n
                if (fullset(i)) then
                    allocate(temp(size(primes) + 1))
                    temp(:size(primes)) = primes
                    temp(size(primes) + 1) = i
                    deallocate(primes)
                    allocate(primes(size(temp)), source=temp)
                    deallocate(temp)
                    do j = 2_int32 * i, n, i
                        fullset(j) = .false.
                    end do
                end if
            end do
            deallocate(fullset)
        end if
    end function

    function isPrime_int8(n) result(t)
        integer(int8), intent(in) :: n
        logical :: t
        integer(int8), dimension(:), allocatable :: primes
        integer :: i

        t = .true.
        primes = primesUpTo_int8(floor(sqrt(real(n)), int8))
        do i = 1,size(primes)
            if (mod(n, primes(i)) == 0_int8) then
                t = .false.
                exit
            end if
        end do
        deallocate(primes)
    end function

    function isPrime_int32(n) result(t)
        integer(int32), intent(in) :: n
        logical :: t
        integer(int32), dimension(:), allocatable :: primes
        integer :: i

        t = .true.
        primes = primesUpTo_int32(floor(sqrt(real(n)), int32))
        do i = 1,size(primes)
            if (mod(n, primes(i)) == 0_int32) then
                t = .false.
                exit
            end if
        end do
        deallocate(primes)
    end function

    recursive function randomPrime_int8(min, max) result(p)
        integer(int8), intent(in) :: min, max
        integer(int8) :: p
        logical :: first = .true.
        real(real32) :: r

        if (first) then
            first = .false.
            call RANDOM_SEED()
        end if
        call RANDOM_NUMBER(r)
        p = floor(r * ((max - 1) - min + 1), int8) + min
        if (.not. isPrime_int8(p)) then
            p = randomPrime_int8(min, max)
        end if
    end function

    recursive function randomPrime_int32(min, max) result(p)
        integer(int32), intent(in) :: min, max
        integer(int32) :: p
        logical :: first = .true.
        real(real32) :: r

        if (first) then
            first = .false.
            call RANDOM_SEED()
        end if
        call RANDOM_NUMBER(r)
        p = floor(r * ((max - 1) - min + 1), int32) + min
        if (.not. isPrime_int32(p)) then
            p = randomPrime_int32(min, max)
        end if
    end function
end module


module gcd_lcm_pf_module

  implicit none

  private
  public :: gcd
  public :: lcm
  public :: prime_factorization

contains

  integer function gcd( m_in, n_in )
    implicit none
    integer, intent(in) :: m_in, n_in
    integer :: m,n,m_tmp,loop
    if ( m_in >= n_in ) then
      m = m_in
      n = n_in
    else
      m = n_in
      n = m_in
    end if
    do
      if ( n == 0 ) exit
      m_tmp = n
      n = mod( m, n )
      m = m_tmp
    end do
    gcd = m
  end function gcd

  integer function lcm( m_in, n_in )
    implicit none
    integer, intent(in) :: m_in, n_in
    lcm = m_in * n_in / gcd( m_in, n_in )
  end function lcm

  subroutine prime_factorization( n_in, ifact )
    implicit none
    integer,intent(in)  :: n_in
    integer,intent(out) :: ifact(:)
    integer :: n,i,j,m
    ifact(:)=0
    ifact(1)=1
    n = n_in
    m = n
    loop_j : do j = 1, n_in
      loop_i : do i = 2, n
        if ( mod(m,i) == 0 ) then
          m = m/i
          ifact(i) = ifact(i) + 1
          exit loop_i
        else if ( i == n ) then
          exit loop_j
        end if
      end do loop_i
      n = m
    end do loop_j
  end subroutine prime_factorization

end module gcd_lcm_pf_module


!Numerical solution to non-linear equations using Newton and bisection methods
!
!(c) 2016 Matteo Paolieri
!LICENSE: The MIT License (MIT)

module functions

    contains

    double precision function es1(x) !function to solve
        double precision :: x
        es1 = EXP(x)-(x+1)**(x-1)
    end

    double precision function es1d(x) !derivative of es1
        double precision :: x
        es1d = EXP(x)-(x+1)**(x-2)*(x+(x+1)*log(x+1)-1)
    end

end module functions

module metodi

    contains

    subroutine bisection (a,b,f,tolx,x,steps) !bisection method

        implicit double precision (A-H, O-Z)

        interface
            double precision function f(x)
                implicit double precision (A-H, O-Z)
            end function f
        end interface

        fa = f(a)
        fb = f(b)
        x = (a+b)/2.0
        fx = f(x)

        c = log(b-a)/log(2.0) !log_2(b-a)
        d = log(tolx)/log(2.0) !log_2(tolx)
        kmax = ceiling(real(c-d))

        steps = kmax

        do k = 2, kmax

!~      f1x = |f'(x)| (using incremental ratio)

            f1x = abs((fb-fa)/(b-a))
            if (abs(fx) .le. tolx*f1x) then !arrest criteria
                steps = k-1
                exit
            else if (fa*fx > 0) then
                b = x
                fb = fx
            else
                a = x
                fa = fx
            end if
            x = (a+b)/2
            fx = f(x)
        end do

!~        arrest criteria: |f(x_i)| <= tolx*|f'(xi)|

    end subroutine bisection

    subroutine newton(x0, f, f1, tolx, kmax, x, steps)

      implicit double precision (A-H, O-Z)
        interface
            double precision function f(x)
                implicit double precision  (A-H, O-Z)
            end function f

            double precision function f1(x)
                implicit double precision  (A-H, O-Z)
            end function f1
        end interface

        fx = f(x0)
        f1x = f1(x0)
        x = x0 - fx/f1x ! first step of Newton's method
        k = 0

        do while ((k<kmax) .and. ( abs(x-x0)>tolx)) ! arrest criteria = |x(k+1)-x(k)|<tolx
            k = k+1
            x0 = x
            fx = f(x0)
            f1x = f1(x0)
            x = x-fx/f1x
        end do

        if (abs(x-x0)>tolx) then
            print *, "Newton: the method does not converge."
        end if

        steps = k

    end subroutine newton

end module metodi

program nonlin_eq

    use metodi
    use functions

    implicit double precision (A-H, O-Z)

        a = 2.0
        b = 4.5
        tolx = 1E-10

        call bisection(a, b, es1, tolx, xb, stepsb) !xb and stepsb are output

        print *, "______ BISECTION ______"
        print '(a, f10.5)', "x = ", xb
        print '(a, f10.0)', "steps = ", stepsb

        x0 = 3.0
        kmax = 100

        call newton(x0, es1, es1d, tolx, kmax, xn, stepsn) !xn and stepsn are output

        print *, "______ NEWTON ______"
        print '(a, f10.5)', "x = ", xn
        print '(a, f10.0)', "steps = ", stepsn

end program nonlin_eq


MODULE precision
    ! dp = double precision
    INTEGER, PARAMETER:: dp = SELECTED_REAL_KIND(12)
END MODULE precision

PROGRAM Newton_Raphson_Method
    USE precision
    IMPLICIT NONE

    REAL(KIND = dp):: x0, x1, f0, fun, fprime, error, root
    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter value of x0 : "
    ! For this question enter x0
    READ(*, *) x0

    error = 1e-6

    DO
        fun = Functn(x0)
        fprime = Functn_Prime(x0)
        x1 = x0 - fun / fprime
        f0 = Functn(x1)

        IF (f0 .EQ. 0.0_dp) THEN
            root = x1
            WRITE(*, *) "Root is: ", root
            RETURN
        ENDIF

        IF (abs((x1 - x0)/x1) .LT. error) THEN
            root = x1
            WRITE(*, *) "Root is: ", root
            RETURN
        ELSE
            x0 = x1
        ENDIF

    ENDDO

    CONTAINS
    REAL(KIND = dp) FUNCTION Functn(x)
        USE precision
        IMPLICIT NONE
        REAL(KIND = dp):: x, rho
        rho = 4.0_dp
        Functn = x*tan(x) - sqrt(rho**2 - x**2)
        RETURN
    END FUNCTION Functn

    REAL(KIND = dp) FUNCTION Functn_Prime(x)
        USE precision
        IMPLICIT NONE
        REAL(KIND = dp):: x, rho
        rho = 4.0_dp
        Functn_Prime = (x/(cos(x)**2)) + tan(x) + (x/sqrt((rho**2) - (x**2)))
        RETURN
    END FUNCTION Functn_Prime

END PROGRAM Newton_Raphson_Method


! -*- mode: f90 -*-
!
! $Id: mandelbrot.1.ifc.code,v 1.13 2010-02-20 17:36:19 igouy-guest Exp $ ; $Name:  $
!
! The Great Computer Language Shootout
! http://shootout.alioth.debian.org/
!
! Simon Geard, 6/1/05
!
! Adapted  mandelbrot.c by Greg Buchholz
!
! Modified to use explicit kind parameters by Jason Blevins, 4/10/10.
!
! Building info.
! ==============
!
! Linux  - using the Intel Fortran90 compiler:
!
!          ifort mandelbrot.f90 -O3 -static-libcxa -o mandelbrot
!
program mandelbrot
  implicit none
  integer, parameter :: dp = kind(1.0d0)
  integer w, h, x, y, bit_num
  integer(kind=1) byte_acc
  integer(kind=1), parameter :: K0 = 0
  integer(kind=1), parameter :: K1 = 1
  integer, parameter :: iter = 50
  real(kind=dp), parameter  :: limit2 = 4.0_dp
  integer  i
  character(len=8) argv
  complex(kind=dp) :: Z, C
  logical debug, in_mandelbrot

  call getarg(1,argv)
  read(argv,*) w
  h = w
  bit_num = 0
  byte_acc = K0
  ! Output pbm header
  write(*,'(a)') 'P4'
  write(*,'(i0,a,i0)') w,' ',h
  do y=0,h-1
     do x=0,w-1
        C = cmplx(2.0d0*x/w-1.5d0,2.0d0*y/h-1.0d0, dp)
        Z = (0.0d0,0.0d0)
        in_mandelbrot = .true.
        do i=0,iter-1
           Z = Z**2 + C
           if (real(Z*conjg(Z)) > limit2) then
              in_mandelbrot = .false.
              exit
           end if
        end do
        if (in_mandelbrot) then
           ! Inside the set so set this bit to 1
           byte_acc = ior(ishft(byte_acc,1),K1)
        else
           ! Outside the set so set this bit to 0
           byte_acc = ishft(byte_acc,1)
        end if

        bit_num = bit_num + 1
        if (bit_num == 8) then
           ! All bits set so output them
           write(*,'(a1)',advance='no') char(byte_acc)
           byte_acc = K0
           bit_num = 0

        elseif (x == w-1) then
           ! End of a row so left-justify the bits we have and output them
           byte_acc = ishft(byte_acc,8-mod(w,8))
           write(*,'(a1)',advance='no') char(byte_acc)
           byte_acc = K0
           bit_num = 0

        end if

     end do
  end do
end program mandelbrot


program perkalian_matrix
    implicit none

    integer :: i,j,k
    real :: a(3,3), b(3,3), c(3,3)

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

    b(1,1) = 2
    b(1,2) = 4
    b(1,3) = 6
    b(2,1) = 1
    b(2,2) = 3
    b(2,3) = 5
    b(3,1) = 1
    b(3,2) = 2
    b(3,3) = 3

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

    write(*,*)

    write(*,*) 'Matrix b'
    do i = 1,3
        write(*,*) (b(i,j), j=1,3)
    end do

    write(*,*)

    ! PERKALIAN MATRIX
    ! Mengalikan matrix dengan suatu nilai/konstanta
    write(*,*) 'Mengalikan matrix dengan suatu nilai/konstanta'
    do i = 1,3
        write(*,*) (a(i,j) * 2, j = 1,3)
    end do

    write(*,*)

    ! Mengalikan matrix dengan matrix
    do i = 1,3
        do j = 1,3
            c(i,j) = 0
            do k = 1,3
                c(i,j) = c(i,j) + (a(i,k) * b(k,j))
            end do
        end do
    end do

    ! Menampilkan hasil perkalian matrix dengan matrix
    write(*,*) 'Menampilkan hasil perkalian matrix dengan matrix'
    do i = 1,3
        write(*,*) (c(i,j), j = 1,3)
    end do

end program perkalian_matrix


SUBROUTINE interpolate_1D(x,y,x1,x2,y1,y2)
! Subroutine interpolates in 1 dimension, given
! Bounding independent coordinates x1,x2
! Corresponding dependent variables y1,y2
! Input independent coordinate x
! Desired interpolant y

implicit none

real :: x1,x2,y1,y2,x,y
real :: grad, inter

!print*, 'Calling interpolate 1D'

grad = (y2-y1)/(x2-x1)
inter = y2 - grad*x2

y = grad*x + inter

!print*, x,y,x1,x2,y1,y2, grad,inter

END SUBROUTINE interpolate_1D


program intrinsics_18
! This program tests all trigonometric intrinsics, both in declarations
! and in executable statements. Single and double precision, real only.
integer, parameter :: dp = kind(0.d0)

real, parameter :: &
    s1 = sin(0.5), &
    s2 = cos(0.5), &
    s3 = tan(0.5), &
    s4 = asin(0.5), &
    s5 = acos(0.5), &
    s6 = atan(0.5), &
    s7 = sinh(0.5), &
    s8 = cosh(0.5), &
    s9 = tanh(0.5), &
    s10 = asinh(0.5), &
    s11 = acosh(1.5), &
    s12 = atanh(0.5)

real(dp), parameter :: &
    d1 = sin(0.5_dp), &
    d2 = cos(0.5_dp), &
    d3 = tan(0.5_dp), &
    d4 = asin(0.5_dp), &
    d5 = acos(0.5_dp), &
    d6 = atan(0.5_dp), &
    d7 = sinh(0.5_dp), &
    d8 = cosh(0.5_dp), &
    d9 = tanh(0.5_dp), &
    d10 = asinh(0.5_dp), &
    d11 = acosh(1.5_dp), &
    d12 = atanh(0.5_dp)

real :: x, x2
real(dp) :: y, y2

x = 0.5
y = 0.5_dp
x2 = 1.5
y2 = 1.5_dp

print *, sin(0.5), sin(0.5_dp), s1, d1, sin(x), sin(y)
print *, cos(0.5), cos(0.5_dp), s2, d2, cos(x), cos(y)
print *, tan(0.5), tan(0.5_dp), s3, d3, tan(x), tan(y)

print *, asin(0.5), asin(0.5_dp), s4, d4, asin(x), asin(y)
print *, acos(0.5), acos(0.5_dp), s5, d5, acos(x), acos(y)
print *, atan(0.5), atan(0.5_dp), s6, d6, atan(x), atan(y)

print *, sinh(0.5), sinh(0.5_dp), s7, d7, sinh(x), sinh(y)
print *, cosh(0.5), cosh(0.5_dp), s8, d8, cosh(x), cosh(y)
print *, tanh(0.5), tanh(0.5_dp), s9, d9, tanh(x), tanh(y)

print *, asinh(0.5), asinh(0.5_dp), s10, d10, asinh(x), asinh(y)
print *, acosh(1.5), acosh(1.5_dp), s11, d11, acosh(x2), acosh(y2)
print *, atanh(0.5), atanh(0.5_dp), s12, d12, atanh(x), atanh(y)

end


submodule(forlab) forlab_degcir
    !degree circular functions
    !! Version: experimental
    !!
    !! Discussion:
    !! ----
    !! https://fortran-lang.discourse.group/t/fortran-function-return-value-polymorphism/1350/5
    use forlab_kinds
    implicit none
contains

    ! acosd
    !-----------------------------------------------------------------------
    ! acosd computes the inverse cosine in degrees.
    !
    ! Syntax
    !-----------------------------------------------------------------------
    ! y = acosd(x)
    !
    ! Description
    !-----------------------------------------------------------------------
    ! y = acosd(x) returns the inverse cosine of the elements in x in
    ! degrees. For real elements of x in the domain [-1,1], acosd returns
    ! values in the range [0,180]. For values of x outside this range,
    ! acosd returns NaN (Not a Number).
    !
    ! Examples
    !-----------------------------------------------------------------------
    ! y = acosd(1.)
    !     1.
    !
    ! y = acosd(2.)
    !     NaN
    !
    ! x = [ -1., 0., 1. ]
    ! y = acosd(x)
    !     180.  90.   0.

    ! asind
    !-----------------------------------------------------------------------
    ! asind computes the inverse sine in degrees.
    !
    ! Syntax
    !-----------------------------------------------------------------------
    ! y = asind(x)
    !
    ! Description
    !-----------------------------------------------------------------------
    ! y = asind(x) returns the inverse sine of the elements in x in degrees.
    ! For real elements of x in the domain [-1,1], asind returns values in
    ! the range [-90,90]. For values of x outside this range, asind returns
    ! NaN (Not a Number).
    !
    ! Examples
    !-----------------------------------------------------------------------
    ! y = asind(1.)
    !     90.
    !
    ! y = asind(2.)
    !     NaN
    !
    ! x = [ -1., 0., 1. ]
    ! y = asind(x)
    !     -90.  0.  90.

    ! atand
    !-----------------------------------------------------------------------
    ! atand computes the inverse tangent in degrees.
    !
    ! Syntax
    !-----------------------------------------------------------------------
    ! y = atand(x)
    !
    ! Description
    !-----------------------------------------------------------------------
    ! y = atand(x) returns the inverse tangent of the elements in x in
    ! degrees. For real elements of x in the domain [-Inf,Inf], atand
    ! returns values in the range [-90,90].
    !
    ! Examples
    !-----------------------------------------------------------------------
    ! y = atand(0.)
    !     0.
    !
    ! y = atand(50.)
    !     88.8542328
    !
    ! x = [ -50., 0., 50. ]
    ! y = atand(x)
    !     -88.8542328   0.  88.8542328
    module procedure acosd_sp
        acosd_sp=acos(x)*180/pi_sp
    end procedure

    module procedure acosd_dp
        acosd_dp=acos(x)*180/pi_dp
    end procedure

    module procedure acosd_qp
        acosd_qp=acos(x)*180/pi_qp
    end procedure

    module procedure asind_sp
        asind_sp=asin(x)*180/pi_sp
    end procedure

    module procedure asind_dp
        asind_dp=asin(x)*180/pi_dp
    end procedure

    module procedure asind_qp
        asind_qp=asin(x)*180/pi_qp
    end procedure

    module procedure atand_sp
        atand_sp=atan(x)*180/pi_sp
    end procedure

    module procedure atand_dp
        atand_dp=atan(x)*180/pi_dp
    end procedure

    module procedure atand_qp
        atand_qp=atan(x)*180/pi_qp
    end procedure

    ! sind
    !-----------------------------------------------------------------------
    ! sind computes the sine of argument in degrees.
    !
    ! Syntax
    !-----------------------------------------------------------------------
    ! y = sind(x)
    !
    ! Description
    !-----------------------------------------------------------------------
    ! y = sind(x) returns the sine of the elements in x, which are expressed
    ! in degrees.
    !
    ! Examples
    !-----------------------------------------------------------------------
    ! y = sind(90.)
    !     1.
    !
    ! x = [ 0., 90., 180., 270. ]
    ! y = sind(x)
    !     0.  1.  0.  -1.

    ! cosd
    !-----------------------------------------------------------------------
    ! cosd computes the cosine of argument in degrees.
    !
    ! Syntax
    !-----------------------------------------------------------------------
    ! y = cosd(x)
    !
    ! Description
    !-----------------------------------------------------------------------
    ! y = cosd(x) returns the cosine of the elements in x, which are
    ! expressed in degrees.
    !
    ! Examples
    !-----------------------------------------------------------------------
    ! y = cosd(0.)
    !     1.
    !
    ! x = [ 0., 90., 180., 270. ]
    ! y = cosd(x)
    !     1.  0. -1.  0.

    ! tand
    !-----------------------------------------------------------------------
    ! tand computes the tangent of argument in degrees.
    !
    ! Syntax
    !-----------------------------------------------------------------------
    ! y = tand(x)
    !
    ! Description
    !-----------------------------------------------------------------------
    ! y = tand(x) returns the tangent of the elements in x, which are
    ! expressed in degrees.
    !
    ! Examples
    !-----------------------------------------------------------------------
    ! y = tand(0.)
    !     0.
    !
    ! x = [ 0., 90., 180., 270. ]
    ! y = tand(x)
    !     0.  Inf   0.  -Inf
    module procedure cosd_sp
        cosd_sp=cos(x*pi_sp/180)
    end procedure

    module procedure cosd_dp
        cosd_dp=cos(x*pi_dp/180)
    end procedure

    module procedure cosd_qp
        cosd_qp=cos(x*pi_qp/180)
    end procedure

    module procedure sind_sp
        sind_sp=sin(x*pi_sp/180)
    end procedure

    module procedure sind_dp
        sind_dp=sin(x*pi_dp/180)
    end procedure

    module procedure sind_qp
        sind_qp=sin(x*pi_qp/180)
    end procedure

    module procedure tand_sp
        tand_sp=tan(x*pi_sp/180)
    end procedure

    module procedure tand_dp
        tand_dp=tan(x*pi_dp/180)
    end procedure

    module procedure tand_qp
        tand_qp=tan(x*pi_qp/180)
    end procedure

end submodule


!!# MODULE <<FUN_CoefficientBinomial>>
MODULE FUN_CoefficientBinomial

!!## PURPOSE
!! Defines function <CoefficientBinomial(n,k)> which produces the
!! binomial coefficient,
!
!!             / n \         n!
!!            |     | = -----------
!!             \ k /     (n-k)! k!
!
!! or in \LaTeX, the formula is,
!! $$
!!    \left( {\begin{array}{*{20}c} n \\ k \\ \end{array}} \right) = \frac{{n!}}{{k!\left( {n - k} \right)!}}
!! $$
!

!!## USAGE
!
!!    y = CoefficientBinomial(n,k)
!!
!! where <y> is <REAL(KIND_Rdp)>, <n> and <k> are integers,
!! <INTEGER(KIND_I1)>, <INTEGER(KIND_I2)>, <INTEGER(KIND_I4)>,
!! or <INTEGER(KIND_I8).>

!!## EXTERNAL KINDS
!! * kind of the real function return value
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                                  !!((01-A-KND_IntrinsicTypes.f90))
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp,KIND_I1,KIND_I2,KIND_I4,KIND_I8 !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PROCEDURES
USE FUN_FactorialLn,ONLY: FactorialLn                                          !!((08-B-FUN_FactorialLn.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
!! * debug with PUBLIC default access, run with PRIVATE default access
PRIVATE

!!## FUNCTION OVERLOADING
INTERFACE CoefficientBinomial
 MODULE PROCEDURE CoefficientBinomial_I1
 MODULE PROCEDURE CoefficientBinomial_I2
 MODULE PROCEDURE CoefficientBinomial_I4
 MODULE PROCEDURE CoefficientBinomial_I8
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: CoefficientBinomial

!!## CONTAINED PROCEDURES
CONTAINS

!!### CoefficientBinomial_I1
PURE ELEMENTAL FUNCTION CoefficientBinomial_I1( n , k ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I1                                   !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "10-B-FUN_CoefficientBinomial.f90.hdr"
!!--begin--
INCLUDE "10-B-FUN_CoefficientBinomial.f90.bdy"
!!--end--
END FUNCTION

!!### CoefficientBinomial_I2
PURE ELEMENTAL FUNCTION CoefficientBinomial_I2( n , k ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I2                                   !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "10-B-FUN_CoefficientBinomial.f90.hdr"
!!--begin--
INCLUDE "10-B-FUN_CoefficientBinomial.f90.bdy"
!!--end--
END FUNCTION

!!### CoefficientBinomial_I4
PURE ELEMENTAL FUNCTION CoefficientBinomial_I4( n , k ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4                                   !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "10-B-FUN_CoefficientBinomial.f90.hdr"
!!--begin--
INCLUDE "10-B-FUN_CoefficientBinomial.f90.bdy"
!!--end--
END FUNCTION

!!### CoefficientBinomial_I8
PURE ELEMENTAL FUNCTION CoefficientBinomial_I8( n , k ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8                                   !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "10-B-FUN_CoefficientBinomial.f90.hdr"
!!--begin--
INCLUDE "10-B-FUN_CoefficientBinomial.f90.bdy"
!!--end--
END FUNCTION

END MODULE


PURE SUBROUTINE sub_ttest_ind(arr1, arr2, similarVar, t, p)
    ! NOTE: See https://en.wikipedia.org/wiki/Student's_t-test
    !         * "Equal or unequal sample sizes, similar variances" section
    !         * "Equal or unequal sample sizes, unequal variances" section
    ! NOTE: See https://en.wikipedia.org/wiki/Welch's_t-test
    ! NOTE: See https://docs.scipy.org/doc/scipy/reference/generated/scipy.stats.ttest_ind.html

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    LOGICAL(kind = INT8), INTENT(in)                                            :: similarVar
    REAL(kind = REAL64), INTENT(out)                                            :: p
    REAL(kind = REAL64), INTENT(out)                                            :: t
    REAL(kind = REAL64), DIMENSION(:), INTENT(in)                               :: arr1
    REAL(kind = REAL64), DIMENSION(:), INTENT(in)                               :: arr2

    ! Declare internal variables ...
    INTEGER(kind = INT64)                                                       :: n1
    INTEGER(kind = INT64)                                                       :: n2
    REAL(kind = REAL64)                                                         :: dof
    REAL(kind = REAL64)                                                         :: s
    REAL(kind = REAL64)                                                         :: mean1
    REAL(kind = REAL64)                                                         :: mean2
    REAL(kind = REAL64)                                                         :: var1
    REAL(kind = REAL64)                                                         :: var1n1
    REAL(kind = REAL64)                                                         :: var2
    REAL(kind = REAL64)                                                         :: var2n2

    ! Find size of arrays ...
    n1 = SIZE(arr1, kind = INT64)
    n2 = SIZE(arr2, kind = INT64)

    ! Find means ...
    mean1 = func_mean(arr1)
    mean2 = func_mean(arr2)

    ! Find variances ...
    var1 = func_var(arr1, 1_INT64)
    var2 = func_var(arr2, 1_INT64)

    ! Check if the variances are supposed to be similar ...
    IF(similarVar)THEN
        ! Calculate the degrees-of-freedom, the variance and the t-statistic ...
        dof = REAL(n1 + n2 - 2_INT64, kind = REAL64)
        s = SQRT((REAL(n1 - 1_INT64, kind = REAL64) * var1 + REAL(n2 - 1_INT64, kind = REAL64) * var2) / dof)
        t = (mean1 - mean2) / (s * SQRT(1.0e0_REAL64 / REAL(n1, kind = REAL64) + 1.0e0_REAL64 / REAL(n2, kind = REAL64)))
    ELSE
        ! Create short-hands ...
        var1n1 = var1 / REAL(n1, kind = REAL64)
        var2n2 = var2 / REAL(n2, kind = REAL64)

        ! Calculate the degrees-of-freedom, the variance and the t-statistic ...
        dof = ((var1n1 + var2n2) ** 2) / (((var1n1 ** 2) / REAL(n1 - 1_INT64, kind = REAL64)) + ((var2n2 ** 2) / REAL(n2 - 1_INT64, kind = REAL64)))
        s = SQRT(var1n1 + var2n2)
        t = (mean1 - mean2) / s
    END IF

    ! Calculate probability ...
    p = 2.0e0_REAL64 * (1.0e0_REAL64 - func_t_CDF(ABS(t), dof))
END SUBROUTINE sub_ttest_ind


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%
!%  Description:
!%      +   Return the natural logarithm of an ndim-dimensional Multivariate Normal (MVN)
!%          probability density function (PDF) with the Mean and Covariance Matrix as defined below.
!%          Reference: https://en.wikipedia.org/wiki/Multivariate_normal_distribution
!%  Input:
!%      +   ndim:       The number of dimensions of the domain of the objective function.
!%      +   point:      The input 64-bit real-valued vector of length ndim,
!%                      at which the natural logarithm of objective function is computed.
!%  Output:
!%      +   logFunc:    A 64-bit real scalar number representing the natural logarithm of the objective function.
!%  Author:
!%      +   Computational Data Science Lab, Monday 9:03 AM, May 16 2016, ICES, UT Austin
!%  Visit:
!%      +   https://www.cdslab.org/paramonte
!%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

module LogFunc_mod

    use paramonte, only: IK, RK

    implicit none

    ! The number of dimensions of the domain of the objective function

    integer(IK), parameter  :: NDIM = 4_IK

    ! The mean vector of the MVN

    real(RK), parameter     :: MEAN(NDIM) = [0._RK, 0._RK, 0._RK, 0._RK]

    ! The coefficient of the Multivariate Normal Distribution: log(1/sqrt(2*Pi)^ndim)

    real(RK), parameter     :: LOG_INVERSE_SQRT_TWO_PI = log(1._RK/sqrt(2._RK*acos(-1._RK)))

    ! The covariance matrix of the MVN

    real(RK), parameter     :: COVMAT(NDIM,NDIM) =  reshape([ 1.0_RK,0.5_RK,0.5_RK,0.5_RK &
                                                            , 0.5_RK,1.0_RK,0.5_RK,0.5_RK &
                                                            , 0.5_RK,0.5_RK,1.0_RK,0.5_RK &
                                                            , 0.5_RK,0.5_RK,0.5_RK,1.0_RK ], shape=shape(COVMAT))

    ! The inverse covariance matrix of the MVN

    real(RK), parameter     :: INVCOVMAT(NDIM,NDIM) = reshape(  [ +1.6_RK, -0.4_RK, -0.4_RK, -0.4_RK &
                                                                , -0.4_RK, +1.6_RK, -0.4_RK, -0.4_RK &
                                                                , -0.4_RK, -0.4_RK, +1.6_RK, -0.4_RK &
                                                                , -0.4_RK, -0.4_RK, -0.4_RK, +1.6_RK ], shape=shape(INVCOVMAT))

    ! The logarithm of square root of the determinant of the inverse covariance matrix of the Multivariate Normal Distribution

    real(RK), parameter     :: LOG_SQRT_DET_INV_COV = 0.581575404902840_RK

    ! MVN_COEF

    real(RK), parameter     :: MVN_COEF = NDIM * LOG_INVERSE_SQRT_TWO_PI + LOG_SQRT_DET_INV_COV

contains

    function getLogFunc(ndim,Point) result(logFunc)
        ! Return the negative natural logarithm of MVN distribution evaluated at the input vector point.
        implicit none
        integer(IK), intent(in) :: ndim
        real(RK), intent(in)    :: Point(ndim)
        real(RK)                :: NormedPoint(ndim)
        real(RK)                :: logFunc
        NormedPoint = Point - MEAN
        logFunc = MVN_COEF - 0.5_RK * ( dot_product(NormedPoint,matmul(INVCOVMAT,NormedPoint)) )
    end function getLogFunc

end module LogFunc_mod

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


PROGRAM A9Q2
!--
! This program uses Dijkstra's algorithm to find the smallest route between two cities.
!--
IMPLICIT NONE
INTEGER, DIMENSION(:,:), ALLOCATABLE :: A
INTEGER :: Check, n, i, m, k, len

PRINT *, "This Program uses Dijkstra's algorithm to find the smallest path between two 'cities'"
DO
	PRINT *, "Please enter the size of the array A[1:n,1:n] as n: (0 to stop)"
    READ *, n
    IF (n .eq. 0) STOP
    ALLOCATE(A(n,n), STAT=Check)
    IF (Check .eq. 0) THEN
		PRINT *, "Please enter the data for A:"
        READ *, (A(i,1:n), i=1,n)
        PRINT *, "Now please enter the starting and ending points (m and k respectively)"
		READ *, m,k
		len = ShortestPath(A,n,m,k)
        IF (len .ne. -1) THEN
        	PRINT "(1X, 'The shortest path from', I5, '  to', I5, '  is: ', I5)", m, k, len
        ELSE
          	PRINT "(1X, 'There exists no path from', I5, '  to', I5)", m, k
        END IF
    	DEALLOCATE(A)
	ELSE
    	PRINT *, "Allocation unsuccessful, please try again."
  	END IF
END DO

CONTAINS
INTEGER FUNCTION ShortestPath(A,n,m,k)
INTEGER, DIMENSION(n,n), INTENT(IN) :: A
INTEGER, INTENT(IN) :: n,m,k
LOGICAL :: different
INTEGER, DIMENSION(n) :: B, Bprev
INTEGER :: i,j,s,min

PRINT *, "Calculating... B will be printed at each step."
Bprev = 0
!- Initilize the array B with the sum of A + 1. B[m] = 0
s = SUM(A) + 1
DO i=1,n
	B(i) = s
END DO
B(m) = 0
PRINT *, B
!- now loop through and modify B until B is no longer changed
different = .true.
DO WHILE (different)
    Bprev = B
    !- For each node,
    DO i= 1,n
    	IF (i .ne. m) THEN
            !- then find the minimum value
            min = s
	    DO j=1,n
        	!- Do not consider node loops or when a node is not connected to another
		IF (j .ne. i .and. A(j,i) .ne. 0) THEN
            	    IF (min > B(j) + A(j, i)) THEN
                    	min =  B(j) + A(j, i)
                    END IF
		END IF
	    END DO
       	    !- Then update the node in B
	    B(i) = min
        END IF
    END DO
    PRINT *, B
    !- prove that B changed:
    different = .false.
    DO i = 1,n
        IF (B(i) .ne. Bprev(i))different = .true.
    END DO
END DO
IF (B(k) .ne. s) THEN
    ShortestPath = B(k)
ELSE
    ShortestPath = -1
END IF

END FUNCTION ShortestPath
END PROGRAM A9Q2


program test_scalar_cholesky

  integer, parameter :: r64 = selected_real_kind (14),                         &
                        r32 = selected_real_kind (6)
  integer :: n

  integer :: i, j, k

  logical :: positive_definite

  real (r64), allocatable :: A (:,:), B (:,:), L (:,:)

  real start_time, stop_time

  read (*, *) n

  allocate ( A (1:n, 1:n), B (1:n, 1:n), L (1:n, 1:n) )

  ! -------------------------------------------------------------
  ! create a positive definite matrix A by setting A equal to the
  ! matrix-matrix product B B^T.  This normal equations matrix is
  ! positive-definite as long as B is full rank.
  ! -------------------------------------------------------------

    write (*,*) "Cholesky Factorization Tests"
    write (*,*) "   Matrix Dimension: ", n
    write (*,*) "   Block Size      : ", 1
    write (*,*) "   Indexing Base   : ", 1

   call random_number ( harvest = B )

  do i = 1, n
     do j = 1, n
        A (i,j) = 0.0
        do k = 1, n
           A (i,j) = A (i,j) + B (i,k) * B (j,k)
        end do
     end do
  end do

  ! factorization algorithms overwrite a copy of A, leaving
  ! the factor L in its place

  L = A

  call cpu_time ( start_time )
  call scalar_outer_product_cholesky ( n, L, positive_definite )
  call cpu_time ( stop_time )

  elapsed_time = stop_time - start_time
  write (*,*)  "  Cholesky Factorization time:   ", elapsed_time
  write (*,*)  "  Collective speed in megaflops: ",                            &
               ( (n**3) / 3.0 )  / ( 1.0E6 * elapsed_time )

  if ( positive_definite ) then
     call check_factorization ( n, A, L )
  else
     write (*,*) "factorization failed for non-positive semi-definite matrix"
  end if

end program test_scalar_cholesky

subroutine scalar_outer_product_cholesky ( n, A, positive_definite )

  integer, parameter :: r64 = selected_real_kind (14),                         &
                        r32 = selected_real_kind (6)
  integer    :: n
  real (r64) :: A (1:n, 1:n)
  logical    :: positive_definite

  integer    :: j, k

  positive_definite = .true.

  do j = 1, n

     if ( A (j,j) > 0.0 ) then

        A (j,j) = sqrt ( A (j,j) )

        A (j+1:n, j) = A (j+1:n, j) / A (j,j)

        do k = j+1, n
           A (k:n, k) = A (k:n, k) - A(k:n, j) * A (k, j)
        end do

     else

        positive_definite = .false.
        exit

     end if

  end do

end subroutine scalar_outer_product_cholesky

subroutine check_factorization ( n, A, L )

  integer, parameter :: r64 = selected_real_kind (14),                         &
                        r32 = selected_real_kind (6)
  integer    :: n

  real (r64) :: A (1:n, 1:n), L (1:n, 1:n)

  ! -----------------------------------------------------------------------
  ! Check the factorization by forming L L^T and comparing the result to A.
  ! The factorization is successful if the results are within the
  ! point-wise perturbation bounds of Demmel, given as Theorem 10.5 in
  ! Higham's "Accuracy and Stability of Numerical Algorithms, 2nd Ed."
  ! -----------------------------------------------------------------------

  real (r64) :: unit_roundoff, gamma_n1

  real (r64) :: d (1:n)

  real (r64) :: resid, max_ratio

  unit_roundoff = 2.0 ** (-53) ! IEEE 64 bit floating point,
  !  also epsilon (unit_roundoff) in Fortran

  gamma_n1      = (n * unit_roundoff) / (1.0 - n * unit_roundoff)

  max_ratio = 0.0

  do i = 1, n
     d (i) = sqrt ( A (i,i) )
  end do

  do i = 1, n
     do j = i+1, n

        resid = A (i,j)
        do k = 1, min (i,j)
           resid = resid - L (i,k) * L (j,k)
        end do
        resid = abs (resid)

        max_ratio = max ( max_ratio,                                           &
                          resid * (1 - gamma_n1) /                             &
                          ( gamma_n1 * d (i) * d (j) ) )

     end do
  end do

  if ( max_ratio <= 1.0 ) then
     write (*,*)   "factorization successful"
  else
     write (*,*) "factorization error exceeds bound by ratio:", max_ratio
  end if

end subroutine check_factorization


!---------------------------------------------------------------------------------------------------------------
! getNormalPdf returns the density function of a standard normal random variable
      double precision function getNormalPdf(x)
      double precision :: x

      getNormalPdf = 0.398942280401433D0 * exp(-x * x * 0.5D0)
      !0.398942280401433 = 1/sqrt(2*pi)
      end function


! Created by EverLookNeverSee@GitHub on 6/5/20
! For more information see FCS/img/Exercise_08_c.png

! Solution:
!   Since x = z * (2 ** m) Hence z = x / (2 ** m)
!   We can choose any `m` as long as -1 <= z <= 1
!   Our x = 3 , for which m = 2 and z = 0.75 works.
!   Smaller `m` will give a larger `z` which will give
!   smaller `xi` which will lead to fewer terms necessary
!   for a certain precision.

! I could not have done it without @taless474, @diehlpk and @LKedward

program main
    implicit none
    ! xi_sum --> sum of xi elements
    ! previous --> sum of xi elements in previous step
    ! Ea --> approximation error
    ! declaring and initializing variables
    integer :: i = 1
    real :: x = 3.0, m = 2.0, z = 0.75, ln2 = 0.6931472, ln3, xi, xi_sum = 0.0, previous, Ea
    xi = (1 - z) / (1 + z)
    do  ! only xi part of formula is infinite and we need to truncate it
        ! Adding up first element of `xi` series -> `xi` itself
        if (i == 1) then
            xi_sum = xi
            i = i + 1
        else    ! Calculating and adding up rest of the elements of series
            previous = xi_sum
            xi_sum = xi_sum + (xi **(2 * i - 1) / (2 * i - 1))
            Ea = xi_sum - previous
            ! Exit whenever approximation error is less than 10e-10
            if (Ea < 10e-10) then
                exit
            else    ! Keep going to calculate and add up next element of seirs
                i = i + 1
                cycle
            end if
        end if
    end do
    ! calculating final result for ln(x)
    ln3 = m * ln2 - (2 * xi_sum)
    ! printing and comparing results
    print *, "ln(", x, "):", ln3
    print *, "ln(", x, ") --> fortran intrinsic function:", ALOG(x)
end program main


program example
implicit none
real :: d

d = haversine(36.12,-86.67,33.94,-118.40) ! BNA to LAX
print '(A,F9.4,A)', 'distance: ',d,' km' ! distance: 2887.2600 km

contains

      function to_radian(degree) result(rad)
          ! degrees to radians
          real,intent(in) :: degree
          real, parameter :: deg_to_rad = atan(1.0)/45 ! exploit intrinsic atan to generate pi/180 runtime constant
          real :: rad

          rad = degree*deg_to_rad
      end function to_radian

      function haversine(deglat1,deglon1,deglat2,deglon2) result (dist)
          ! great circle distance -- adapted from Matlab
          real,intent(in) :: deglat1,deglon1,deglat2,deglon2
          real :: a,c,dist,dlat,dlon,lat1,lat2
          real,parameter :: radius = 6372.8

          dlat = to_radian(deglat2-deglat1)
          dlon = to_radian(deglon2-deglon1)
          lat1 = to_radian(deglat1)
          lat2 = to_radian(deglat2)
          a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2
          c = 2*asin(sqrt(a))
          dist = radius*c
      end function haversine

end program example


C PROGRAM FOR INTERGRATION BY GAUSSIAN QUADRATURE
C GAURAV RUDRA MALIK R.NO:23
	P1(X)=(3003*x**6 - 3465*x**4 + 945*x**2 - 35)/16
	F(X)=1/(1+X**2)
	DIMENSION Y(8),W(8)
	Y(1) = -0.96028985
	Y(2) = -0.79666647
	Y(3) = -0.52553240
	Y(4) = -0.18343464
	DO 1 I=5,8
	Y(I)=Y(9-I)*(-1)
1	CONTINUE
	DO 2 I=1,8
	A=(1-(Y(I)**2))*(P1(Y(I)**2))
	W(I)= 2/A
2	CONTINUE
	WRITE(*,*)'ENTER THE LOWER AND UPPER LIMITS'
	READ(*,*) A,B
	C=(A+B)/2
	D=ABS(A-B)/2
	S=0.0
	DO 3 I=1,8
	S=S + W(I)*F(D*Y(I)+C)
3	CONTINUE
	S=S*D
	WRITE(*,*)'THE INTEGRAL IS CALCULATED TO BE:',S
	STOP
	END

Result

 ENTER THE LOWER AND UPPER LIMITS
1
2
 THE INTEGRAL IS CALCULATED TO BE:  .328349978


MODULE my_math
 !
 USE kind
 !
 CONTAINS
    FUNCTION dot_prod(a,b)
       REAL(KIND=DP) :: dot_prod
       REAL(KIND=DP), DIMENSION(:), INTENT(IN) :: a,b
       dot_prod = SUM(a*b)
       !dot_prod=a(1)*b(1)+a(2)*b(2)+a(3)*b(3)
    ENDFUNCTION dot_prod
    !
    FUNCTION x_prod(a,b)
       REAL(KIND=DP), DIMENSION(3) :: x_prod
       REAL(KIND=DP), DIMENSION(3), INTENT(IN) :: a,b
       x_prod(1)=a(2)*b(3)-a(3)*b(2)
       x_prod(2)=a(3)*b(1)-a(1)*b(3)
       x_prod(3)=a(1)*b(2)-a(2)*b(1)
    ENDFUNCTION x_prod
    !
    FUNCTION mix_prod(a,b,c)
       REAL(KIND=DP) :: mix_prod
       REAL(KIND=DP), DIMENSION(3), INTENT(IN) :: a,b,c
       mix_prod=dot_prod(a,x_prod(b,c))
    ENDFUNCTION mix_prod
    !
    FUNCTION vect_len(a)
       REAL(KIND=DP) :: vect_len
       REAL(KIND=DP), DIMENSION(3), INTENT(IN) :: a
       vect_len = SQRT(SUM(a*a))
    ENDFUNCTION
    !
ENDMODULE my_math


! September 29, 2021
! Lecture 02
! Practice: Solve the quadratic equation using a standard formula and try four
! different inputs for the coefficients...
program quadratic
    implicit none
    integer, parameter :: SP = kind(0.e0)
    integer, parameter :: dP = kind(0.d0)
    integer, parameter :: QP = kind(0.q0)
    integer, parameter :: WP = SP
    real(kind=WP) :: a, b, c, D, x1, x2, zero, tol
    complex(kind=WP) :: zD, z1, z2, z_zero
    character(len=7) :: mode

    print *, "For a quadratic equation a x^2 + b x + c = 0,"
    print *, "coefficients a, b, and c are:"
    read *, a, b, c
    print *, "Which mode, 'real' or 'complex'?"
    read *, mode

    select case (mode)
    case ("real")
        tol = 10.0_WP * epsilon(0.0_WP) ! tolerance = numerical precision x 10
        D = b**2 - 4.0_WP * a * c
        if (D > 0.0_WP) then ! two distinct roots
            x1 = (-b + sqrt(D)) / (2.0_WP * a)
            x2 = (-b - sqrt(D)) / (2.0_WP * a)
            print *, "1st distinct root is ", x1
            print *, "2nd distinct root is ", x2

            zero = a * x1**2 + b * x1 + c
            print *, "Test: a x_1^2 + b x_1 + c = ", zero
            zero = a * x2**2 + b * x2 + c
            print *, "Test: a x_2^2 + b x_2 + c = ", zero
        else if (abs(D) <= tol) then
            x1 = -b / (2.0_WP * a) ! equal roots
            print *, "One double root is ", x1

            zero = a * x1**2 + b * x1 + c
            print *, "Test: a x_1^2 + b x_1 + c = ", zero
        else ! D < 0.0: no real roots
            print *, "There are no real roots, D = ", D
        end if
    case ("complex")
        zD = b**2 - 4.0_wp * a * c
        z1 = (-b + sqrt(zD)) / (2.0_WP * a)
        z2 = (-b - sqrt(zD)) / (2.0_WP * a)
        print *, "1st complex root is ", z1
        print *, "2nd complex root is ", z2
        !print "(a, 2(1x, f0.8, sp, f0.8, 'i'))", "Two complex roots are ", z1, z2

        z_zero = a * z1**2 + b * z1 + c
        print *, "Test: a z_1^2 + b z_1^2 + c = ", z_zero
        z_zero = a * z2**2 + b * z2 + c
        print *, "Test: a z_2^2 + b z_2^2 + c = ", z_zero
    case default
        stop "Wrong mode = " // mode
    end select
end program quadratic


!
  module various_functions_mod
!
  contains
!
    subroutine dmatinv3(A,B,ierr)
         !! Performs a direct calculation of the inverse of a 3×3 matrix.
         double precision,dimension(3,3), intent(in) :: A  !! Matrix
         double precision,dimension(3,3), intent(out) :: B(3,3)   !! Inverse matrix
         integer, intent(out) :: ierr
         double precision             :: detinv
!
         !Integer for error status (0 ... no error, 1 ... singular matrix)
         ierr = 0
!
         !Calculate the inverse determinant of the matrix
         detinv = (A(1,1)*A(2,2)*A(3,3) - A(1,1)*A(2,3)*A(3,2)&
                   - A(1,2)*A(2,1)*A(3,3) + A(1,2)*A(2,3)*A(3,1)&
                   + A(1,3)*A(2,1)*A(3,2) - A(1,3)*A(2,2)*A(3,1))
!
         if(detinv.eq.0.d0) then
           ierr = 1
           B = 0.d0
           print *,"Error in dmatinv3: Matrix is singular - Inverse matrix doesn't exist."
           stop
         endif
!
         detinv = 1/detinv
!
         ! Calculate the inverse of the matrix
         B(1,1) = +detinv * (A(2,2)*A(3,3) - A(2,3)*A(3,2))
         B(2,1) = -detinv * (A(2,1)*A(3,3) - A(2,3)*A(3,1))
         B(3,1) = +detinv * (A(2,1)*A(3,2) - A(2,2)*A(3,1))
         B(1,2) = -detinv * (A(1,2)*A(3,3) - A(1,3)*A(3,2))
         B(2,2) = +detinv * (A(1,1)*A(3,3) - A(1,3)*A(3,1))
         B(3,2) = -detinv * (A(1,1)*A(3,2) - A(1,2)*A(3,1))
         B(1,3) = +detinv * (A(1,2)*A(2,3) - A(1,3)*A(2,2))
         B(2,3) = -detinv * (A(1,1)*A(2,3) - A(1,3)*A(2,1))
         B(3,3) = +detinv * (A(1,1)*A(2,2) - A(1,2)*A(2,1))
       end subroutine
!
  end module various_functions_mod
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!


SUBROUTINE kepler_eq (M, ec, E)

! ----------------------------------------------------------------------
! SUBROUTINE: kepler_eq.f90
! ----------------------------------------------------------------------
! Purpose:
!  Kepler's Equation solution based on Newton method
! ----------------------------------------------------------------------
! Input arguments:
! - M:			Mean amomaly (degrees)
! - ec:			Eccentricity
!
! Output arguments:
! - E:      	Eccentric anomaly (degrees)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia           29 August 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: M, ec
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: E
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: Mrad, Eo, f_E
      REAL (KIND = prec_q) :: E_arr(8)
      INTEGER (KIND = prec_int8) :: Niter, i, sz1
! ----------------------------------------------------------------------

! converse in radians
Mrad = M * (PI_global /180.D0)

! ----------------------------------------------------------------------
! Initial approximate value of Eccentric anomaly (E)
! - small eccentricity:			Eo = M
! - high eccentricity (e>0.8):	Eo = pi
if (e < 0.8D0) then
    if (Mrad == 0.D0) then
        Eo = Mrad + 0.001D0
    else
        Eo = Mrad
    end if
else
    Eo = PI_global
end if
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! number of iterations
Niter = 7
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Newton method: Iterative solution
Do i = 1 , Niter

    if (i == 1) then
        E_arr(i) = Eo
    end if

    ! auxiliary function
    f_E = E_arr(i) - ec * sin( E_arr(i) ) - Mrad

    E_arr(i+1) = E_arr(i) - f_E / ( 1.D0 - ec * cos( E_arr(i) ) )

End Do
! ----------------------------------------------------------------------

! Converse in degrees
E_arr = E_arr * (180.D0 / PI_global)

! Solution from the final iteration value
sz1 = size(E_arr, DIM = 1)

E = E_arr(sz1)

End


Module mo_cost

  use mo_kind, only: sp, dp

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: cost_sp,  cost_dp
  PUBLIC :: cost_valid_sp,  cost_valid_dp
  PUBLIC :: range_sp, range_dp

CONTAINS

  FUNCTION cost_sp (paraset)

    implicit none

    REAL(SP), DIMENSION(:), INTENT(IN)  :: paraset
    REAL(SP)                            :: cost_sp
    REAL(SP), DIMENSION(6,2)            :: meas
    REAL(SP), DIMENSION(6)              :: calc

    ! function: f(x) = ax^3 + bx^2 + cx + d
    ! measurements: (0.5,5.725), (1.0, 21.7), (1.5, 49.175), (2.0, 88.9), (2.5, 141.625), (3.0, 208.1)
    ! --> a=1.0, b=20.0, c=0.2, d=0.5

    meas(:,1) = (/0.5_sp, 1.0_sp, 1.5_sp, 2.0_sp, 2.5_sp, 3.0_sp/)
    meas(:,2) = (/5.7250_sp, 21.7000_sp, 49.1750_sp, 88.9000_sp, 141.6250_sp, 208.1000_sp/)

    calc(:) = paraset(1)*meas(:,1)**3+paraset(2)*meas(:,1)**2+paraset(3)*meas(:,1)+paraset(4)

    ! MAE  Mean Absolute Error
    cost_sp = sum(abs( meas(:,2)-calc(:) ))/size(meas,1)

    RETURN
  END FUNCTION cost_sp

  FUNCTION cost_dp (paraset)

    implicit none

    REAL(DP), DIMENSION(:), INTENT(IN)  :: paraset
    REAL(DP)                            :: cost_dp
    REAL(DP), DIMENSION(6,2)            :: meas
    REAL(DP), DIMENSION(6)              :: calc

    ! function: f(x) = ax^3 + bx^2 + cx + d
    ! measurements: (0.5,5.725), (1.0, 21.7), (1.5, 49.175), (2.0, 88.9), (2.5, 141.625), (3.0, 208.1)
    ! --> a=1.0, b=20.0, c=0.2, d=0.5

    meas(:,1) = (/0.5_dp, 1.0_dp, 1.5_dp, 2.0_dp, 2.5_dp, 3.0_dp/)
    meas(:,2) = (/5.7250_dp, 21.7000_dp, 49.1750_dp, 88.9000_dp, 141.6250_dp, 208.1000_dp/)

    calc(:) = paraset(1)*meas(:,1)**3+paraset(2)*meas(:,1)**2+paraset(3)*meas(:,1)+paraset(4)

    ! MAE  Mean Absolute Error
    cost_dp = sum(abs( meas(:,2)-calc(:) ))/size(meas,1)

    RETURN
  END FUNCTION cost_dp

  FUNCTION cost_valid_sp (paraset,status_in)

    implicit none

    REAL(SP), DIMENSION(:), INTENT(IN)  :: paraset
    LOGICAL,  OPTIONAL,     INTENT(OUT) :: status_in
    REAL(SP)                            :: cost_valid_sp
    REAL(SP), DIMENSION(6,2)            :: meas
    REAL(SP), DIMENSION(6)              :: calc

    ! function: f(x) = ax^3 + bx^2 + cx + d
    ! measurements: (0.5,5.725), (1.0, 21.7), (1.5, 49.175), (2.0, 88.9), (2.5, 141.625), (3.0, 208.1)
    ! --> a=1.0, b=20.0, c=0.2, d=0.5

    meas(:,1) = (/0.5_sp, 1.0_sp, 1.5_sp, 2.0_sp, 2.5_sp, 3.0_sp/)
    meas(:,2) = (/5.7250_sp, 21.7000_sp, 49.1750_sp, 88.9000_sp, 141.6250_sp, 208.1000_sp/)

    calc(:) = paraset(1)*meas(:,1)**3+paraset(2)*meas(:,1)**2+paraset(3)*meas(:,1)+paraset(4)

    if (present(status_in)) then
       status_in = .true.
       ! Define a status .false. if calculation of "calc" was not successful
    end if

    ! MAE  Mean Absolute Error
    cost_valid_sp = sum(abs( meas(:,2)-calc(:) ))/size(meas,1)

    RETURN
  END FUNCTION cost_valid_sp

  FUNCTION cost_valid_dp (paraset,status_in)

    implicit none

    REAL(DP), DIMENSION(:), INTENT(IN)  :: paraset
    LOGICAL,  OPTIONAL,     INTENT(OUT) :: status_in
    REAL(DP)                            :: cost_valid_dp
    REAL(DP), DIMENSION(6,2)            :: meas
    REAL(DP), DIMENSION(6)              :: calc

    ! function: f(x) = ax^3 + bx^2 + cx + d
    ! measurements: (0.5,5.725), (1.0, 21.7), (1.5, 49.175), (2.0, 88.9), (2.5, 141.625), (3.0, 208.1)
    ! --> a=1.0, b=20.0, c=0.2, d=0.5

    meas(:,1) = (/0.5_dp, 1.0_dp, 1.5_dp, 2.0_dp, 2.5_dp, 3.0_dp/)
    meas(:,2) = (/5.7250_dp, 21.7000_dp, 49.1750_dp, 88.9000_dp, 141.6250_dp, 208.1000_dp/)

    calc(:) = paraset(1)*meas(:,1)**3+paraset(2)*meas(:,1)**2+paraset(3)*meas(:,1)+paraset(4)

    if (present(status_in)) then
       status_in = .true.
       ! Define a status .false. if calculation of "calc" was not successful
    end if

    ! MAE  Mean Absolute Error
    cost_valid_dp = sum(abs( meas(:,2)-calc(:) ))/size(meas,1)

    RETURN
  END FUNCTION cost_valid_dp

  SUBROUTINE range_dp(paraset, iPar, rangePar)
    use mo_kind
    REAL(DP), DIMENSION(:), INTENT(IN)  :: paraset
    INTEGER(I4),            INTENT(IN)  :: iPar
    REAL(DP), DIMENSION(2), INTENT(OUT) :: rangePar

    ! Range does not depend on parameter set
    ! select case(iPar)
    !    case(1_i4)
    !       rangePar(1) =  0.0_dp
    !       rangePar(2) = 10.0_dp
    !    case(2_i4)
    !       rangePar(1) =  0.0_dp
    !       rangePar(2) = 40.0_dp
    !    case(3_i4)
    !       rangePar(1) =  0.0_dp
    !       rangePar(2) = 10.0_dp
    !    case(4_i4)
    !       rangePar(1) =  0.0_dp
    !       rangePar(2) =  5.0_dp
    ! end select

    ! Range of parameter 2 depends on value of parameter 1:
    !    parameter 2 at most 40* parameter 1 :
    !       0 <= p2 <= 40p1
    !       0 <= p1 <= 0.025p2
    select case(iPar)
    case(1_i4)
       rangePar(1) =  0.025_dp*paraset(2)
       rangePar(2) =  10.0_dp
    case(2_i4)
       rangePar(1) =  0.0_dp
       rangePar(2) =  40.0_dp*paraset(1)
    case(3_i4)
       rangePar(1) =  0.0_dp
       rangePar(2) = 10.0_dp
    case(4_i4)
       rangePar(1) =  0.0_dp
       rangePar(2) =  5.0_dp
    end select

  END SUBROUTINE range_dp

  SUBROUTINE range_sp(paraset, iPar, rangePar)
    use mo_kind
    REAL(SP), DIMENSION(:), INTENT(IN)  :: paraset
    INTEGER(I4),            INTENT(IN)  :: iPar
    REAL(SP), DIMENSION(2), INTENT(OUT) :: rangePar

    ! Range does not depend on parameter set
    ! select case(iPar)
    !    case(1_i4)
    !       rangePar(1) =  0.0_sp
    !       rangePar(2) = 10.0_sp
    !    case(2_i4)
    !       rangePar(1) =  0.0_sp
    !       rangePar(2) = 40.0_sp
    !    case(3_i4)
    !       rangePar(1) =  0.0_sp
    !       rangePar(2) = 10.0_sp
    !    case(4_i4)
    !       rangePar(1) =  0.0_sp
    !       rangePar(2) =  5.0_sp
    ! end select

    ! Range of parameter 2 depends on value of parameter 1:
    !    parameter 2 at most 4* parameter 1 :
    !       0     <= p2 <= 4p1
    !       0.25p2 <= p1 <= 10.0
    select case(iPar)
    case(1_i4)
       rangePar(1) =  0.025_sp*paraset(2)
       rangePar(2) = 10.0_sp
    case(2_i4)
       rangePar(1) =  0.0_sp
       rangePar(2) =  40.0_sp*paraset(1)
    case(3_i4)
       rangePar(1) =  0.0_sp
       rangePar(2) = 10.0_sp
    case(4_i4)
       rangePar(1) =  0.0_sp
       rangePar(2) =  5.0_sp
    end select

  END SUBROUTINE range_sp

END MODULE mo_cost


function chebpts(n,I_in) result(c)
! Returns chebyshev points on interval I
! === Parameters ===
! n - number of chebyshev points
! I - (array) 2x1 array containing inteval
! === Output ===
! c - (array) nx1 array of chebyshev points
integer, intent(in) :: n
real(kind=8), intent(in), optional :: I_in(2)
real(kind=8) :: c(n), m, a, I(2)
integer :: j
if(present(I_in)) then
    I = I_in
else
    I = (/ -1.d0, 1.d0 /)
endif

m = (I(2) + I(1))/2.d0
a = (I(2) - I(1))/2.d0
do j=1,n
    c(j) = -1.d0 * a * cos((j-1.d0)*PI/(n-1.d0)) + m
enddo
end function chebpts


MODULE Simulation

  IMPLICIT NONE

  CONTAINS

  FUNCTION Pi(samples)
    REAL :: Pi
    REAL :: coords(2), length
    INTEGER :: i, in_circle, samples

    in_circle = 0
    DO i=1, samples
      CALL RANDOM_NUMBER(coords)
      coords = coords * 2 - 1
      length = SQRT(coords(1)*coords(1) + coords(2)*coords(2))
      IF (length <= 1) in_circle = in_circle + 1
    END DO
    Pi = 4.0 * REAL(in_circle) / REAL(samples)
  END FUNCTION Pi

END MODULE Simulation

PROGRAM MONTE_CARLO

  USE Simulation

  INTEGER :: n = 1000000000
  WRITE (*,*) 'pi: ', Pi(n)

END PROGRAM MONTE_CARLO


!**********************************************************************
!   pi3f90.f - compute pi by integrating f(x) = 4/(1 + x**2)
!
!  (C) 2001 by Argonne National Laboratory.
!  modified by Thomas Hauser
!
!   Each node:
!    1) receives the number of rectangles used in the approximation.
!    2) calculates the areas of it's rectangles.
!    3) Synchronizes for a global summation.
!   Node 0 prints the result.
!
!  Variables:
!
!    pi  the calculated result
!    n   number of points of integration.
!    x           midpoint of each rectangle's interval
!    f           function to integrate
!    sum,pi      area of rectangles
!    tmp         temporary scratch space for global summation
!    i           do loop index
!****************************************************************************
PROGRAM pi_mpi

  USE mpi

  INTEGER, parameter :: dp = kind(1.0d0)
  REAL(dp)::  PI25DT = 3.141592653589793238462643d0

  REAL(dp) ::  mypi, pi, h, sum, x, f, a
  INTEGER :: n, myid, numprocs, i, rc
  !                                 function to integrate
  f(a) = 4.d0 / (1.d0 + a*a)

  CALL MPI_INIT( ierr )
  CALL MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
  CALL MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
  PRINT *, 'Process ', myid, ' of ', numprocs, ' is alive'

  sizetype   = 1
  sumtype    = 2

  IF ( myid .EQ. 0 ) THEN
     WRITE(6,98)
98   FORMAT('Enter the number of intervals:')
     READ(5,99) n
99   FORMAT(i10)
  ENDIF

  CALL MPI_BCAST(n,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)

  !                                 check for quit signal

  !                                 calculate the interval size
  h = 1.0d0/n

  sum  = 0.0d0
  DO i = myid+1, n, numprocs
     x = h * (DBLE(i) - 0.5d0)
     sum = sum + f(x)
  ENDDO
  mypi = h * sum

  !                                 collect all the partial sums
  CALL MPI_REDUCE(mypi,pi,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
       MPI_COMM_WORLD,ierr)

  !                                 node 0 prints the answer.
  IF (myid .EQ. 0) THEN
     WRITE(6, 97) pi, ABS(pi - PI25DT)
97   FORMAT('  pi is approximately: ', F18.16, &
          '  Error is: ', F18.16)
  ENDIF

  CALL MPI_FINALIZE(rc)
END PROGRAM pi_mpi


MODULE m_lagrange

! ----------------------------------------------------------------------
! MODULE: m_lagrange.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the subroutine 'interp_lag' for Lagrange interpolation
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	13 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE interp_lag (Xint, X_interp, Y_interp, Yint)

! ----------------------------------------------------------------------
! SUBROUTINE: interp_lag
! ----------------------------------------------------------------------
! Purpose:
!  Interpolation based on Lagrange polynomials
! ----------------------------------------------------------------------
! Input arguments:
! - Xint:  			X value where the interpolated value of Y is required
! - X_interp:   	array of values of the independent variable X
! - Y_interp:   	array of the Y function values corresponding to X i.e. y=f(x)
!
! Output arguments:
! - Yint:			Y interpolated value at Xint
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	5 August 2016
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 14 November 2017:
!	Upgraded from Fortran 90 to Fortran 2003 for considering the
!	Fortran 2003 adavantages in dynamic memory allocation
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      !USE mdl_arr
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: Xint
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(:), ALLOCATABLE :: X_interp
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(:), ALLOCATABLE :: Y_interp
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: Yint
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int4) :: sz1, n, i, j
      REAL (KIND = prec_q) :: L_numerator, L_denominator, Li
      REAL (KIND = prec_q), DIMENSION(:), ALLOCATABLE :: L
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
! ----------------------------------------------------------------------

! Number of Data points
n = size(X_interp, DIM = 1)

!sz1 = size(Y_interp, DIM = 1)
!print *,'n,sz1', n, sz1

Allocate( L(n), STAT = AllocateStatus)
!print *, "AllocateStatus=", AllocateStatus
if (AllocateStatus == 0) then

! Computation of coefficients Li (xint)
DO i = 1 , n
   L_numerator   = 1.0D0
   L_denominator = 1.0D0

   DO j = 1 , n
	  If (j == i) then
	     ! not
	  Else
		L_numerator   = ( xint - X_interp(j) ) * L_numerator
        L_denominator = ( X_interp(i) - X_interp(j) ) * L_denominator
	  End If
	End Do

    L(i) = L_numerator / L_denominator
	!Li = L_numerator / L_denominator
    !L(i) = Li
End Do

!print *,"X_interp", X_interp
!print *,"L", L

! Value of function Y(X) at the point xint
! Value is approximated by interpolant Pn(xint) based on Lagrange Polynomial
yint = 0.D0

Do i = 1 , n
    yint = Y_interp(i) * L(i) + yint
End Do

Deallocate(L, STAT = DeAllocateStatus)
else
        ! only hit if the allocation fails
        yint = 1.d0
end if

!print *,"yint",yint

End subroutine

End Module


! Objetivo: Reproduzir o grafico do periodo em funcao do angulo inicial

MODULE pendulo
!Dados globais
   REAL :: k
CONTAINS
   FUNCTION func_integral_elip(xi)
      IMPLICIT none
      REAL, DIMENSION (:), INTENT(in) :: xi
      REAL, DIMENSION(SIZE(xi)) :: func_integral_elip
      func_integral_elip = 1./sqrt(1.-(k*sin(xi))**2)
   END FUNCTION func_integral_elip
END MODULE pendulo

PROGRAM pendulo_simples

   USE pendulo
   USE nrtype
   USE nrutil
   USE nr, ONLY: qromb, trapzd, polint

   IMPLICIT none
   REAL :: theta, integral
   INTEGER :: n_repeticoes
   REAL, PARAMETER :: theta_inicial = 0., theta_final = pi
   INTEGER, PARAMETER :: n_pontos = 1000, dados_pendulo = 8
   REAL, PARAMETER :: n_pontos_real = REAL(n_pontos)
   REAL, PARAMETER :: incremento = (theta_final-theta_inicial)/n_pontos_real
   REAL, PARAMETER :: intervalo_a = 0., intervalo_b = pio2

   OPEN(dados_pendulo,file="dados_pendulo.dat")
   theta = theta_inicial
   DO n_repeticoes = 1, n_pontos
      k=sin(0.5*theta)
!Calcular a integral no intervalo de 0 a pi/2
      integral = qromb( func_integral_elip, intervalo_a, intervalo_b )
      WRITE(dados_pendulo, *) theta/pi, integral/pio2
      theta = theta +incremento
   END DO
   CLOSE(dados_pendulo)

END PROGRAM pendulo_simples